1{- | 2-} 3 4{-# LANGUAGE CPP #-} 5{-# LANGUAGE NamedFieldPuns #-} 6{-# LANGUAGE OverloadedStrings #-} 7{-# LANGUAGE RecordWildCards #-} 8{-# LANGUAGE ScopedTypeVariables #-} 9 10module Hledger.Reports.BudgetReport ( 11 BudgetGoal, 12 BudgetTotal, 13 BudgetAverage, 14 BudgetCell, 15 BudgetReportRow, 16 BudgetReport, 17 budgetReport, 18 budgetReportAsTable, 19 budgetReportAsText, 20 -- * Helpers 21 reportPeriodName, 22 -- * Tests 23 tests_BudgetReport 24) 25where 26 27import Data.Decimal 28import Data.HashMap.Strict (HashMap) 29import qualified Data.HashMap.Strict as HM 30import Data.List 31import Data.List.Extra (nubSort) 32import Data.Maybe 33#if !(MIN_VERSION_base(4,11,0)) 34import Data.Monoid ((<>)) 35#endif 36import Data.Time.Calendar 37import Safe 38--import Data.List 39--import Data.Maybe 40import qualified Data.Map as Map 41import Data.Map (Map) 42import qualified Data.Text as T 43--import qualified Data.Text.Lazy as TL 44--import System.Console.CmdArgs.Explicit as C 45--import Lucid as L 46import Text.Printf (printf) 47import Text.Tabular as T 48 49import Hledger.Data 50import Hledger.Utils 51import Hledger.Reports.ReportOptions 52import Hledger.Reports.ReportTypes 53import Hledger.Reports.MultiBalanceReport 54 55 56type BudgetGoal = Change 57type BudgetTotal = Total 58type BudgetAverage = Average 59 60-- | A budget report tracks expected and actual changes per account and subperiod. 61type BudgetCell = (Maybe Change, Maybe BudgetGoal) 62type BudgetReportRow = PeriodicReportRow DisplayName BudgetCell 63type BudgetReport = PeriodicReport DisplayName BudgetCell 64 65-- | Calculate budget goals from all periodic transactions, 66-- actual balance changes from the regular transactions, 67-- and compare these to get a 'BudgetReport'. 68-- Unbudgeted accounts may be hidden or renamed (see budgetRollup). 69budgetReport :: ReportOpts -> Bool -> DateSpan -> Day -> Journal -> BudgetReport 70budgetReport ropts' assrt reportspan d j = dbg1 "sortedbudgetreport" budgetreport 71 where 72 -- Budget report demands ALTree mode to ensure subaccounts and subaccount budgets are properly handled 73 -- and that reports with and without --empty make sense when compared side by side 74 ropts = ropts' { accountlistmode_ = ALTree } 75 showunbudgeted = empty_ ropts 76 budgetedaccts = 77 dbg2 "budgetedacctsinperiod" $ 78 nub $ 79 concatMap expandAccountName $ 80 accountNamesFromPostings $ 81 concatMap tpostings $ 82 concatMap (`runPeriodicTransaction` reportspan) $ 83 jperiodictxns j 84 actualj = dbg1With (("actualj"++).show.jtxns) $ budgetRollUp budgetedaccts showunbudgeted j 85 budgetj = dbg1With (("budgetj"++).show.jtxns) $ budgetJournal assrt ropts reportspan j 86 actualreport@(PeriodicReport actualspans _ _) = 87 dbg1 "actualreport" $ multiBalanceReport d ropts{empty_=True} actualj 88 budgetgoalreport@(PeriodicReport _ budgetgoalitems budgetgoaltotals) = 89 dbg1 "budgetgoalreport" $ multiBalanceReport d ropts{empty_=True} budgetj 90 budgetgoalreport' 91 -- If no interval is specified: 92 -- budgetgoalreport's span might be shorter actualreport's due to periodic txns; 93 -- it should be safe to replace it with the latter, so they combine well. 94 | interval_ ropts == NoInterval = PeriodicReport actualspans budgetgoalitems budgetgoaltotals 95 | otherwise = budgetgoalreport 96 budgetreport = combineBudgetAndActual ropts j budgetgoalreport' actualreport 97 98-- | Use all periodic transactions in the journal to generate 99-- budget transactions in the specified report period. 100-- Budget transactions are similar to forecast transactions except 101-- their purpose is to set goal amounts (of change) per account and period. 102budgetJournal :: Bool -> ReportOpts -> DateSpan -> Journal -> Journal 103budgetJournal assrt _ropts reportspan j = 104 either error' id $ journalBalanceTransactions assrt j{ jtxns = budgetts } -- PARTIAL: 105 where 106 budgetspan = dbg2 "budgetspan" $ reportspan 107 budgetts = 108 dbg1 "budgetts" $ 109 [makeBudgetTxn t 110 | pt <- jperiodictxns j 111 , t <- runPeriodicTransaction pt budgetspan 112 ] 113 makeBudgetTxn t = txnTieKnot $ t { tdescription = T.pack "Budget transaction" } 114 115-- | Adjust a journal's account names for budget reporting, in two ways: 116-- 117-- 1. accounts with no budget goal anywhere in their ancestry are moved 118-- under the "unbudgeted" top level account. 119-- 120-- 2. subaccounts with no budget goal are merged with their closest parent account 121-- with a budget goal, so that only budgeted accounts are shown. 122-- This can be disabled by --empty. 123-- 124budgetRollUp :: [AccountName] -> Bool -> Journal -> Journal 125budgetRollUp budgetedaccts showunbudgeted j = j { jtxns = remapTxn <$> jtxns j } 126 where 127 remapTxn = mapPostings (map remapPosting) 128 where 129 mapPostings f t = txnTieKnot $ t { tpostings = f $ tpostings t } 130 remapPosting p = p { paccount = remapAccount $ paccount p, poriginal = Just . fromMaybe p $ poriginal p } 131 where 132 remapAccount a 133 | hasbudget = a 134 | hasbudgetedparent = if showunbudgeted then a else budgetedparent 135 | otherwise = if showunbudgeted then u <> acctsep <> a else u 136 where 137 hasbudget = a `elem` budgetedaccts 138 hasbudgetedparent = not $ T.null budgetedparent 139 budgetedparent = headDef "" $ filter (`elem` budgetedaccts) $ parentAccountNames a 140 u = unbudgetedAccountName 141 142-- | Combine a per-account-and-subperiod report of budget goals, and one 143-- of actual change amounts, into a budget performance report. 144-- The two reports should have the same report interval, but need not 145-- have exactly the same account rows or date columns. 146-- (Cells in the combined budget report can be missing a budget goal, 147-- an actual amount, or both.) The combined report will include: 148-- 149-- - consecutive subperiods at the same interval as the two reports, 150-- spanning the period of both reports 151-- 152-- - all accounts mentioned in either report, sorted by account code or 153-- account name or amount as appropriate. 154-- 155combineBudgetAndActual :: ReportOpts -> Journal -> MultiBalanceReport -> MultiBalanceReport -> BudgetReport 156combineBudgetAndActual ropts j 157 (PeriodicReport budgetperiods budgetrows (PeriodicReportRow _ budgettots budgetgrandtot budgetgrandavg)) 158 (PeriodicReport actualperiods actualrows (PeriodicReportRow _ actualtots actualgrandtot actualgrandavg)) = 159 PeriodicReport periods sortedrows totalrow 160 where 161 periods = nubSort . filter (/= nulldatespan) $ budgetperiods ++ actualperiods 162 163 -- first, combine any corresponding budget goals with actual changes 164 rows1 = 165 [ PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal 166 | PeriodicReportRow acct actualamts actualtot actualavg <- actualrows 167 , let mbudgetgoals = HM.lookup (displayFull acct) budgetGoalsByAcct :: Maybe ([BudgetGoal], BudgetTotal, BudgetAverage) 168 , let budgetmamts = maybe (Nothing <$ periods) (map Just . first3) mbudgetgoals :: [Maybe BudgetGoal] 169 , let mbudgettot = second3 <$> mbudgetgoals :: Maybe BudgetTotal 170 , let mbudgetavg = third3 <$> mbudgetgoals :: Maybe BudgetAverage 171 , let acctBudgetByPeriod = Map.fromList [ (p,budgetamt) | (p, Just budgetamt) <- zip budgetperiods budgetmamts ] :: Map DateSpan BudgetGoal 172 , let acctActualByPeriod = Map.fromList [ (p,actualamt) | (p, Just actualamt) <- zip actualperiods (map Just actualamts) ] :: Map DateSpan Change 173 , let amtandgoals = [ (Map.lookup p acctActualByPeriod, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [BudgetCell] 174 , let totamtandgoal = (Just actualtot, mbudgettot) 175 , let avgamtandgoal = (Just actualavg, mbudgetavg) 176 ] 177 where 178 budgetGoalsByAcct :: HashMap AccountName ([BudgetGoal], BudgetTotal, BudgetAverage) = 179 HM.fromList [ (displayFull acct, (amts, tot, avg)) 180 | PeriodicReportRow acct amts tot avg <- budgetrows ] 181 182 -- next, make rows for budget goals with no actual changes 183 rows2 = 184 [ PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal 185 | PeriodicReportRow acct budgetgoals budgettot budgetavg <- budgetrows 186 , displayFull acct `notElem` map prrFullName rows1 187 , let acctBudgetByPeriod = Map.fromList $ zip budgetperiods budgetgoals :: Map DateSpan BudgetGoal 188 , let amtandgoals = [ (Nothing, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [BudgetCell] 189 , let totamtandgoal = (Nothing, Just budgettot) 190 , let avgamtandgoal = (Nothing, Just budgetavg) 191 ] 192 193 -- combine and re-sort rows 194 -- TODO: add --sort-budget to sort by budget goal amount 195 sortedrows :: [BudgetReportRow] = sortRowsLike (mbrsorted unbudgetedrows ++ mbrsorted rows') rows 196 where 197 (unbudgetedrows, rows') = partition ((==unbudgetedAccountName) . prrFullName) rows 198 mbrsorted = map prrFullName . sortRows ropts j . map (fmap $ fromMaybe 0 . fst) 199 rows = rows1 ++ rows2 200 201 -- TODO: grand total & average shows 0% when there are no actual amounts, inconsistent with other cells 202 totalrow = PeriodicReportRow () 203 [ (Map.lookup p totActualByPeriod, Map.lookup p totBudgetByPeriod) | p <- periods ] 204 ( Just actualgrandtot, Just budgetgrandtot ) 205 ( Just actualgrandavg, Just budgetgrandavg ) 206 where 207 totBudgetByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal 208 totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change 209 210-- | Render a budget report as plain text suitable for console output. 211budgetReportAsText :: ReportOpts -> BudgetReport -> String 212budgetReportAsText ropts@ReportOpts{..} budgetr = 213 title ++ "\n\n" ++ 214 tableAsText ropts showcell (maybetranspose $ budgetReportAsTable ropts budgetr) 215 where 216 multiperiod = interval_ /= NoInterval 217 title = printf "Budget performance in %s%s:" 218 (showDateSpan $ periodicReportSpan budgetr) 219 (case value_ of 220 Just (AtCost _mc) -> ", valued at cost" 221 Just (AtThen _mc) -> error' unsupportedValueThenError -- PARTIAL: 222 Just (AtEnd _mc) -> ", valued at period ends" 223 Just (AtNow _mc) -> ", current value" 224 -- XXX duplicates the above 225 Just (AtDefault _mc) | multiperiod -> ", valued at period ends" 226 Just (AtDefault _mc) -> ", current value" 227 Just (AtDate d _mc) -> ", valued at "++showDate d 228 Nothing -> "") 229 actualwidth = maximum' $ map fst amountsAndGoals 230 budgetwidth = maximum' $ map snd amountsAndGoals 231 amountsAndGoals = 232 map (\(a,g) -> (amountWidth a, amountWidth g)) . concatMap prrAmounts $ prRows budgetr 233 where 234 amountWidth = maybe 0 (length . showMixedAmountElided False) 235 -- XXX lay out actual, percentage and/or goal in the single table cell for now, should probably use separate cells 236 showcell :: BudgetCell -> String 237 showcell (mactual, mbudget) = actualstr ++ " " ++ budgetstr 238 where 239 percentwidth = 4 240 actual = fromMaybe 0 mactual 241 actualstr = printf ("%"++show actualwidth++"s") (showamt actual) 242 budgetstr = case mbudget of 243 Nothing -> replicate (percentwidth + 7 + budgetwidth) ' ' 244 Just budget -> 245 case percentage actual budget of 246 Just pct -> 247 printf ("[%"++show percentwidth++"s%% of %"++show budgetwidth++"s]") 248 (show $ roundTo 0 pct) (showamt' budget) 249 Nothing -> 250 printf ("["++replicate (percentwidth+5) ' '++"%"++show budgetwidth++"s]") 251 (showamt' budget) 252 showamt = showMixedAmountElided color_ 253 showamt' = showMixedAmountElided False -- XXX colored budget amounts disrupts layout 254 255 -- | Calculate the percentage of actual change to budget goal to show, if any. 256 -- If valuing at cost, both amounts are converted to cost before comparing. 257 -- A percentage will not be shown if: 258 -- - actual or goal are not the same, single, commodity 259 -- - the goal is zero 260 percentage :: Change -> BudgetGoal -> Maybe Percentage 261 percentage actual budget = 262 case (maybecost $ normaliseMixedAmount actual, maybecost $ normaliseMixedAmount budget) of 263 (Mixed [a], Mixed [b]) | (acommodity a == acommodity b || amountLooksZero a) && not (amountLooksZero b) 264 -> Just $ 100 * aquantity a / aquantity b 265 _ -> -- trace (pshow $ (maybecost actual, maybecost budget)) -- debug missing percentage 266 Nothing 267 where 268 maybecost = if valuationTypeIsCost ropts then mixedAmountCost else id 269 270 maybetranspose | transpose_ = \(Table rh ch vals) -> Table ch rh (transpose vals) 271 | otherwise = id 272 273-- | Build a 'Table' from a multi-column balance report. 274budgetReportAsTable :: ReportOpts -> BudgetReport -> Table String String (Maybe MixedAmount, Maybe MixedAmount) 275budgetReportAsTable 276 ropts@ReportOpts{balancetype_} 277 (PeriodicReport spans rows (PeriodicReportRow _ coltots grandtot grandavg)) = 278 addtotalrow $ 279 Table 280 (T.Group NoLine $ map Header accts) 281 (T.Group NoLine $ map Header colheadings) 282 (map rowvals rows) 283 where 284 colheadings = map (reportPeriodName balancetype_ spans) spans 285 ++ [" Total" | row_total_ ropts] 286 ++ ["Average" | average_ ropts] 287 288 accts = map renderacct rows 289 -- FIXME. Have to check explicitly for which to render here, since 290 -- budgetReport sets accountlistmode to ALTree. Find a principled way to do 291 -- this. 292 renderacct row = case accountlistmode_ ropts of 293 ALTree -> replicate ((prrDepth row - 1)*2) ' ' ++ T.unpack (prrDisplayName row) 294 ALFlat -> T.unpack . accountNameDrop (drop_ ropts) $ prrFullName row 295 rowvals (PeriodicReportRow _ as rowtot rowavg) = 296 as ++ [rowtot | row_total_ ropts] ++ [rowavg | average_ ropts] 297 addtotalrow 298 | no_total_ ropts = id 299 | otherwise = (+----+ (row "" $ 300 coltots ++ [grandtot | row_total_ ropts && not (null coltots)] 301 ++ [grandavg | average_ ropts && not (null coltots)] 302 )) 303 304-- | Make a name for the given period in a multiperiod report, given 305-- the type of balance being reported and the full set of report 306-- periods. This will be used as a column heading (or row heading, in 307-- a register summary report). We try to pick a useful name as follows: 308-- 309-- - ending-balance reports: the period's end date 310-- 311-- - balance change reports where the periods are months and all in the same year: 312-- the short month name in the current locale 313-- 314-- - all other balance change reports: a description of the datespan, 315-- abbreviated to compact form if possible (see showDateSpan). 316-- 317reportPeriodName :: BalanceType -> [DateSpan] -> DateSpan -> String 318reportPeriodName balancetype spans = 319 case balancetype of 320 PeriodChange -> if multiyear then showDateSpan else showDateSpanMonthAbbrev 321 where 322 multiyear = (>1) $ length $ nubSort $ map spanStartYear spans 323 _ -> maybe "" (showDate . prevday) . spanEnd 324 325-- tests 326 327tests_BudgetReport = tests "BudgetReport" [ 328 ] 329