From aebd6c50d6a8d32fc6b5f37e1e777e028bf1f843 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Mon, 16 Jul 2018 23:36:06 +0100 Subject: [PATCH] smooth: smoothes out irregular transactions (experimental addon) --- bin/hledger-smooth.hs | 138 +++++++++++++++++++++++++++++ hledger-lib/Hledger/Data/Amount.hs | 10 +++ 2 files changed, 148 insertions(+) create mode 100755 bin/hledger-smooth.hs diff --git a/bin/hledger-smooth.hs b/bin/hledger-smooth.hs new file mode 100755 index 000000000..21bbd398f --- /dev/null +++ b/bin/hledger-smooth.hs @@ -0,0 +1,138 @@ +#!/usr/bin/env stack +{- stack runghc --verbosity info + --package hledger-lib + --package hledger + --package here + --package text + --package time + --package safe +-} +-- Requires latest hledger/hledger-lib from master. +-- Run it inside an up to date hledger source tree, eg: bin/hledger-smooth.hs ACCT +-- Or add bin/ to $PATH and [stack ghc bin/hledger-smooth;] hledger smooth ACCT + +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-} + +import Data.List +import Data.Maybe +import Data.String.Here +import qualified Data.Text as T +import Data.Time.Calendar +import Safe +import Hledger +import Hledger.Cli + +------------------------------------------------------------------------------ +cmdmode = hledgerCommandMode + [here| smooth +Like the print command, but splits any posting to ACCT (a full account name) +into multiple daily postings having a similar overall effect. + +Each posting is smoothed across the period until the next ACCT posting, and +the last one is smoothed until the report end date, or today. +Eg: $30 on 1/1 and $50 on 1/4, if smoothed on 1/6 with no end date specified, +becomes $10 on 1/1, $10 on 1/2, $10 on 1/3, $25 on 1/4, $25 on 1/5. + +The last new posting's amount is left blank to ensure a balanced transaction. +It can differ from the others. + +Useful for preprocessing a journal to smooth out irregular revenues or +expenses in daily/weekly/monthly reports, eg: +hledger smooth revenues:consulting | hledger -f- incomestatement -W + +FLAGS + |] + [] + [generalflagsgroup1] + [] + ([], Just $ argsFlag "ACCT") +------------------------------------------------------------------------------ +-- we could smooth postings across the journal period, or within standard intervals: --smooth-interval=posting|journal|weekly|monthly|... +-- we could perhaps split transactions instead: --smooth-split=postings|transactions + +main :: IO () +main = do + copts' <- getHledgerCliOpts cmdmode + withJournalDo copts' $ \copts@CliOpts{reportopts_=ropts, rawopts_} j -> do + today <- getCurrentDay + menddate <- specifiedEndDate ropts + let + args = words' $ query_ ropts + q = queryFromOpts today ropts + acct = T.pack $ headDef (error' "Please provide an account name argument") args + pr = postingsReport ropts (And [Acct $ accountNameToAccountRegex acct, q]) j + + -- dates of postings to acct (in report) + pdates = map (postingDate . fourth5) (snd pr) + -- the specified report end date or today's date + enddate = fromMaybe today menddate + dates = pdates ++ [enddate] + (_,ts') = mapAccumL (splitTransactionPostings q acct) dates $ jtxns j + j' = j{jtxns=ts'} + copts' = copts{ + -- One of our postings will probably have a missing amount; this ensures it's + -- explicit on all the others. + rawopts_=("explicit",""):rawopts_ + -- Don't let our ACCT argument be interpreted as a query by print + ,reportopts_=ropts{query_=""} + } + print' copts' j' + +-- | Split a transaction's postings to acct, if the transaction is matched by q, +-- into equivalent daily postings up to the next given end date, +-- keeping track of remaining end dates. +splitTransactionPostings :: Query -> AccountName -> [Day] -> Transaction -> ([Day], Transaction) +splitTransactionPostings q acct dates t + -- | q `matchesTransaction` t = (dates', t') + -- | otherwise = (dates, t) + | otherwise = (dates', t') + where + (dates', pss') = mapAccumL (splitPosting acct) dates $ tpostings t + t' = txnTieKnot t{tpostings=concat pss'} + +-- | Split a posting to acct into equivalent daily postings +-- up to the next given end date, keeping track of remaining end dates. +-- We assume we will see postings in number and order corresponding the given end dates. +splitPosting :: AccountName -> [Day] -> Posting -> ([Day], [Posting]) +splitPosting acct dates p@Posting{paccount,pamount} + | paccount == acct = (dates', ps') + | otherwise = (dates, [p]) + where + start = dbg4 "start" $ postingDate p + (end, dates') = + case dbg4 "dates" dates of + (d1:d2:ds) -> if d1==start then (d2, d2:ds) else error' "splitPosting got wrong date, should not happen" + [d] -> (d, []) + [] -> error' "splitPosting ran out of dates, should not happen" + days = initSafe [start..end] + amt = pamount `divideMixedAmount` (fromIntegral $ length days) + -- give one of the postings an exact balancing amount to ensure the transaction is balanced + -- lastamt = pamount - ptrace (amt `multiplyMixedAmount` (fromIntegral $ length days)) + lastamt = missingmixedamt + daysamts = zip days (take (length days - 1) (repeat amt) ++ [lastamt]) + ps' = [postingSetDate (Just d) p{pamount=a} | (d,a) <- daysamts ] + +-- | Set a posting's (primary) date, as if it had been parsed from the journal entry: +-- Updates the date field, +-- adds a "date" tag to the parsed tag list (replacing any existing "date" tags there), +-- and adds the "date" tag to the unparsed comment field as well, for display purposes. +-- If the date is Nothing, unsets the date and removes it from the tags list. +-- Does not remove existing date tags from the comment field. +postingSetDate :: Maybe Day -> Posting -> Posting +postingSetDate md p@Posting{ptags,pcomment} = p{pdate=md, ptags=ptags'', pcomment=pcomment'} + where + ptags'' = case md of + Nothing -> ptags' + Just d -> ptags'++[("date", T.pack $ show d)] + where + ptags' = filter (not.(=="date").fst) ptags + + pcomment' = case md of + Nothing -> pcomment + Just d -> pcomment `add` T.pack ("date:"++show d) + where + c1 `add` c2 | T.head c1 == '\n' = c2 <> c1 + c1 `add` c2 = c1 <> c2 diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index a1fe1680d..e2a7d67be 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -58,6 +58,7 @@ module Hledger.Data.Amount ( -- ** arithmetic costOfAmount, divideAmount, + multiplyAmount, amountValue, -- ** rendering amountstyle, @@ -84,6 +85,7 @@ module Hledger.Data.Amount ( -- ** arithmetic costOfMixedAmount, divideMixedAmount, + multiplyMixedAmount, averageMixedAmounts, isNegativeAmount, isNegativeMixedAmount, @@ -217,6 +219,10 @@ costOfAmount a@Amount{aquantity=q, aprice=price} = divideAmount :: Amount -> Quantity -> Amount divideAmount a@Amount{aquantity=q} d = a{aquantity=q/d} +-- | Multiply an amount's quantity by a constant. +multiplyAmount :: Amount -> Quantity -> Amount +multiplyAmount a@Amount{aquantity=q} d = a{aquantity=q*d} + -- | Is this amount negative ? The price is ignored. isNegativeAmount :: Amount -> Bool isNegativeAmount Amount{aquantity=q} = q < 0 @@ -539,6 +545,10 @@ costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as divideMixedAmount :: MixedAmount -> Quantity -> MixedAmount divideMixedAmount (Mixed as) d = Mixed $ map (`divideAmount` d) as +-- | Multiply a mixed amount's quantities by a constant. +multiplyMixedAmount :: MixedAmount -> Quantity -> MixedAmount +multiplyMixedAmount (Mixed as) d = Mixed $ map (`multiplyAmount` d) as + -- | Calculate the average of some mixed amounts. averageMixedAmounts :: [MixedAmount] -> MixedAmount averageMixedAmounts [] = 0