smooth: smoothes out irregular transactions (experimental addon)

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

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