3de8c11de1
A bunch of account sorting changes that got intermingled.
First, account codes have been dropped. They can still be parsed and
will be ignored, for now. I don't know if anyone used them.
Instead, account display order is now controlled by the order of account
directives, if any. From the mail list:
I'd like to drop account codes, introduced in hledger 1.9 to control
the display order of accounts. In my experience,
- they are tedious to maintain
- they duplicate/compete with the natural tendency to arrange account
directives to match your mental chart of accounts
- they duplicate/compete with the tree structure created by account
names
and it gets worse if you think about using them more extensively,
eg to classify accounts by type.
Instead, I plan to just let the position (parse order) of account
directives determine the display order of those declared accounts.
Undeclared accounts will be displayed after declared accounts,
sorted alphabetically as usual.
Second, the various account sorting modes have been implemented more
widely and more correctly. All sorting modes (alphabetically, by account
declaration, by amount) should now work correctly in almost all commands
and modes (non-tabular and tabular balance reports, tree and flat modes,
the accounts command). Sorting bugs have been fixed, eg #875.
Only the budget report (balance --budget) does not yet support sorting.
Comprehensive functional tests for sorting in the accounts and balance
commands have been added. If you are confused by some sorting behaviour,
studying these tests is recommended, as sorting gets tricky.
337 lines
15 KiB
Haskell
337 lines
15 KiB
Haskell
{- |
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Hledger.Reports.BudgetReport
|
|
where
|
|
|
|
import Data.Decimal
|
|
import Data.List
|
|
import Data.Maybe
|
|
#if !(MIN_VERSION_base(4,11,0))
|
|
import Data.Monoid ((<>))
|
|
#endif
|
|
import Data.Ord
|
|
import Data.Time.Calendar
|
|
import Safe
|
|
--import Data.List
|
|
--import Data.Maybe
|
|
import qualified Data.Map as Map
|
|
import Data.Map (Map)
|
|
import qualified Data.Text as T
|
|
--import qualified Data.Text.Lazy as TL
|
|
--import System.Console.CmdArgs.Explicit as C
|
|
--import Lucid as L
|
|
import Text.Printf (printf)
|
|
import Text.Tabular as T
|
|
--import Text.Tabular.AsciiWide
|
|
|
|
import Hledger.Data
|
|
--import Hledger.Query
|
|
import Hledger.Utils
|
|
--import Hledger.Read (mamountp')
|
|
import Hledger.Reports.ReportOptions
|
|
import Hledger.Reports.ReportTypes
|
|
import Hledger.Reports.MultiBalanceReports
|
|
|
|
|
|
--type MultiBalanceReportRow = (AccountName, AccountName, Int, [MixedAmount], MixedAmount, MixedAmount)
|
|
--type MultiBalanceReportTotals = ([MixedAmount], MixedAmount, MixedAmount) -- (Totals list, sum of totals, average of totals)
|
|
|
|
--type PeriodicReportRow a =
|
|
-- ( AccountName -- ^ A full account name.
|
|
-- , [a] -- ^ The data value for each subperiod.
|
|
-- , a -- ^ The total of this row's values.
|
|
-- , a -- ^ The average of this row's values.
|
|
-- )
|
|
|
|
type BudgetGoal = Change
|
|
type BudgetTotal = Total
|
|
type BudgetAverage = Average
|
|
|
|
-- | A budget report tracks expected and actual changes per account and subperiod.
|
|
type BudgetReport = PeriodicReport (Maybe Change, Maybe BudgetGoal)
|
|
|
|
-- | Calculate budget goals from all periodic transactions,
|
|
-- actual balance changes from the regular transactions,
|
|
-- and compare these to get a 'BudgetReport'.
|
|
-- Unbudgeted accounts may be hidden or renamed (see budgetRollup).
|
|
budgetReport :: ReportOpts -> Bool -> Bool -> DateSpan -> Day -> Journal -> BudgetReport
|
|
budgetReport ropts assrt showunbudgeted reportspan d j =
|
|
let
|
|
q = queryFromOpts d ropts
|
|
budgetedaccts =
|
|
dbg2 "budgetedacctsinperiod" $
|
|
accountNamesFromPostings $
|
|
concatMap tpostings $
|
|
concatMap (flip runPeriodicTransaction reportspan) $
|
|
jperiodictxns j
|
|
actualj = dbg1 "actualj" $ budgetRollUp budgetedaccts showunbudgeted j
|
|
budgetj = dbg1 "budgetj" $ budgetJournal assrt ropts reportspan j
|
|
actualreport@(MultiBalanceReport (actualspans, _, _)) = dbg1 "actualreport" $ multiBalanceReport ropts q actualj
|
|
budgetgoalreport@(MultiBalanceReport (_, budgetgoalitems, budgetgoaltotals)) = dbg1 "budgetgoalreport" $ multiBalanceReport ropts q budgetj
|
|
budgetgoalreport'
|
|
-- If no interval is specified:
|
|
-- budgetgoalreport's span might be shorter actualreport's due to periodic txns;
|
|
-- it should be safe to replace it with the latter, so they combine well.
|
|
| interval_ ropts == NoInterval = MultiBalanceReport (actualspans, budgetgoalitems, budgetgoaltotals)
|
|
| otherwise = budgetgoalreport
|
|
in
|
|
dbg1 "budgetreport" $ combineBudgetAndActual budgetgoalreport' actualreport
|
|
|
|
-- | Use all periodic transactions in the journal to generate
|
|
-- budget transactions in the specified report period.
|
|
-- Budget transactions are similar to forecast transactions except
|
|
-- their purpose is to set goal amounts (of change) per account and period.
|
|
budgetJournal :: Bool -> ReportOpts -> DateSpan -> Journal -> Journal
|
|
budgetJournal assrt _ropts reportspan j =
|
|
either error' id $ journalBalanceTransactions assrt j{ jtxns = budgetts }
|
|
where
|
|
budgetspan = dbg2 "budgetspan" $ reportspan
|
|
budgetts =
|
|
dbg1 "budgetts" $
|
|
[makeBudgetTxn t
|
|
| pt <- jperiodictxns j
|
|
, t <- runPeriodicTransaction pt budgetspan
|
|
]
|
|
makeBudgetTxn t = txnTieKnot $ t { tdescription = T.pack "Budget transaction" }
|
|
|
|
-- | Adjust a journal's account names for budget reporting, in two ways:
|
|
--
|
|
-- 1. accounts with no budget goal anywhere in their ancestry are moved
|
|
-- under the "unbudgeted" top level account.
|
|
--
|
|
-- 2. subaccounts with no budget goal are merged with their closest parent account
|
|
-- with a budget goal, so that only budgeted accounts are shown.
|
|
-- This can be disabled by --show-unbudgeted.
|
|
--
|
|
budgetRollUp :: [AccountName] -> Bool -> Journal -> Journal
|
|
budgetRollUp budgetedaccts showunbudgeted j = j { jtxns = remapTxn <$> jtxns j }
|
|
where
|
|
remapTxn = mapPostings (map remapPosting)
|
|
where
|
|
mapPostings f t = txnTieKnot $ t { tpostings = f $ tpostings t }
|
|
remapPosting p = p { paccount = remapAccount $ paccount p, porigin = Just . fromMaybe p $ porigin p }
|
|
where
|
|
remapAccount a
|
|
| hasbudget = a
|
|
| hasbudgetedparent = if showunbudgeted then a else budgetedparent
|
|
| otherwise = if showunbudgeted then u <> acctsep <> a else u
|
|
where
|
|
hasbudget = a `elem` budgetedaccts
|
|
hasbudgetedparent = not $ T.null budgetedparent
|
|
budgetedparent = headDef "" $ filter (`elem` budgetedaccts) $ parentAccountNames a
|
|
u = unbudgetedAccountName
|
|
|
|
-- | Combine a per-account-and-subperiod report of budget goals, and one
|
|
-- of actual change amounts, into a budget performance report.
|
|
-- The two reports should have the same report interval, but need not
|
|
-- have exactly the same account rows or date columns.
|
|
-- (Cells in the combined budget report can be missing a budget goal,
|
|
-- an actual amount, or both.) The combined report will include:
|
|
--
|
|
-- - consecutive subperiods at the same interval as the two reports,
|
|
-- spanning the period of both reports
|
|
--
|
|
-- - all accounts mentioned in either report, sorted by account code or
|
|
-- account name or amount as appropriate.
|
|
--
|
|
combineBudgetAndActual :: MultiBalanceReport -> MultiBalanceReport -> BudgetReport
|
|
combineBudgetAndActual
|
|
(MultiBalanceReport (budgetperiods, budgetrows, (budgettots, budgetgrandtot, budgetgrandavg)))
|
|
(MultiBalanceReport (actualperiods, actualrows, (actualtots, actualgrandtot, actualgrandavg))) =
|
|
let
|
|
periods = nub $ sort $ filter (/= nulldatespan) $ budgetperiods ++ actualperiods
|
|
|
|
-- first, combine any corresponding budget goals with actual changes
|
|
rows1 =
|
|
[ (acct, treeacct, treeindent, amtandgoals, totamtandgoal, avgamtandgoal)
|
|
| (acct, treeacct, treeindent, actualamts, actualtot, actualavg) <- actualrows
|
|
, let mbudgetgoals = Map.lookup acct budgetGoalsByAcct :: Maybe ([BudgetGoal], BudgetTotal, BudgetAverage)
|
|
, let budgetmamts = maybe (replicate (length periods) Nothing) (map Just . first3) mbudgetgoals :: [Maybe BudgetGoal]
|
|
, let mbudgettot = maybe Nothing (Just . second3) mbudgetgoals :: Maybe BudgetTotal
|
|
, let mbudgetavg = maybe Nothing (Just . third3) mbudgetgoals :: Maybe BudgetAverage
|
|
, let acctBudgetByPeriod = Map.fromList [ (p,budgetamt) | (p, Just budgetamt) <- zip budgetperiods budgetmamts ] :: Map DateSpan BudgetGoal
|
|
, let acctActualByPeriod = Map.fromList [ (p,actualamt) | (p, Just actualamt) <- zip actualperiods (map Just actualamts) ] :: Map DateSpan Change
|
|
, let amtandgoals = [ (Map.lookup p acctActualByPeriod, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [(Maybe Change, Maybe BudgetGoal)]
|
|
, let totamtandgoal = (Just actualtot, mbudgettot)
|
|
, let avgamtandgoal = (Just actualavg, mbudgetavg)
|
|
]
|
|
where
|
|
budgetGoalsByAcct :: Map AccountName ([BudgetGoal], BudgetTotal, BudgetAverage) =
|
|
Map.fromList [ (acct, (amts, tot, avg)) | (acct, _, _, amts, tot, avg) <- budgetrows ]
|
|
|
|
-- next, make rows for budget goals with no actual changes
|
|
rows2 =
|
|
[ (acct, treeacct, treeindent, amtandgoals, totamtandgoal, avgamtandgoal)
|
|
| (acct, treeacct, treeindent, budgetgoals, budgettot, budgetavg) <- budgetrows
|
|
, not $ acct `elem` acctsdone
|
|
, let acctBudgetByPeriod = Map.fromList $ zip budgetperiods budgetgoals :: Map DateSpan BudgetGoal
|
|
, let amtandgoals = [ (Nothing, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [(Maybe Change, Maybe BudgetGoal)]
|
|
, let totamtandgoal = (Nothing, Just budgettot)
|
|
, let avgamtandgoal = (Nothing, Just budgetavg)
|
|
]
|
|
where
|
|
acctsdone = map first6 rows1
|
|
|
|
-- combine and re-sort rows
|
|
-- TODO: use MBR code
|
|
-- TODO: respect --sort-amount
|
|
-- TODO: add --sort-budget to sort by budget goal amount
|
|
rows :: [PeriodicReportRow (Maybe Change, Maybe BudgetGoal)] =
|
|
sortBy (comparing first6) $ rows1 ++ rows2
|
|
|
|
-- -- like MultiBalanceReport
|
|
-- sortedrows
|
|
-- | sort_amount_ opts && tree_ opts = sortTreeBURByAmount items
|
|
-- | sort_amount_ opts = sortFlatBURByAmount items
|
|
-- | otherwise = sortBURByAccountDeclaration items
|
|
--
|
|
-- where
|
|
-- -- Sort the report rows, representing a tree of accounts, by row total at each level.
|
|
-- sortTreeMBRByAmount rows = sortedrows
|
|
-- where
|
|
-- anamesandrows = [(first6 r, r) | r <- rows]
|
|
-- anames = map fst anamesandrows
|
|
-- atotals = [(a,tot) | (a,_,_,_,tot,_) <- rows]
|
|
-- accounttree = accountTree "root" anames
|
|
-- accounttreewithbals = mapAccounts setibalance accounttree
|
|
-- where
|
|
-- -- should not happen, but it's ugly; TODO
|
|
-- setibalance a = a{aibalance=fromMaybe (error "sortTreeBURByAmount 1") $ lookup (aname a) atotals}
|
|
-- sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ opts) accounttreewithbals
|
|
-- sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree
|
|
-- sortedrows = sortAccountItemsLike sortedanames anamesandrows
|
|
--
|
|
-- -- Sort the report rows, representing a flat account list, by row total.
|
|
-- sortFlatBURByAmount = sortBy (maybeflip $ comparing fifth6)
|
|
-- where
|
|
-- maybeflip = if normalbalance_ opts == Just NormallyNegative then id else flip
|
|
--
|
|
-- -- Sort the report rows by account declaration order then account name.
|
|
-- sortBURByAccountDeclaration rows = sortedrows
|
|
-- where
|
|
-- anamesandrows = [(first6 r, r) | r <- rows]
|
|
-- anames = map fst anamesandrows
|
|
-- sortedanames = sortAccountNamesByDeclaration j (tree_ opts) anames
|
|
-- sortedrows = sortAccountItemsLike sortedanames anamesandrows
|
|
|
|
-- TODO: grand total & average shows 0% when there are no actual amounts, inconsistent with other cells
|
|
totalrow =
|
|
( ""
|
|
, ""
|
|
, 0
|
|
, [ (Map.lookup p totActualByPeriod, Map.lookup p totBudgetByPeriod) | p <- periods ] :: [(Maybe Total, Maybe BudgetTotal)]
|
|
, ( Just actualgrandtot, Just budgetgrandtot ) :: (Maybe Total, Maybe BudgetTotal)
|
|
, ( Just actualgrandavg, Just budgetgrandavg ) :: (Maybe Total, Maybe BudgetTotal)
|
|
)
|
|
where
|
|
totBudgetByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal
|
|
totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change
|
|
|
|
in
|
|
PeriodicReport
|
|
( periods
|
|
, rows
|
|
, totalrow
|
|
)
|
|
|
|
-- | Figure out the overall period of a BudgetReport.
|
|
budgetReportSpan :: BudgetReport -> DateSpan
|
|
budgetReportSpan (PeriodicReport ([], _, _)) = DateSpan Nothing Nothing
|
|
budgetReportSpan (PeriodicReport (spans, _, _)) = DateSpan (spanStart $ head spans) (spanEnd $ last spans)
|
|
|
|
-- | Render a budget report as plain text suitable for console output.
|
|
budgetReportAsText :: ReportOpts -> BudgetReport -> String
|
|
budgetReportAsText ropts budgetr =
|
|
printf "Budget performance in %s:\n\n" (showDateSpan $ budgetReportSpan budgetr)
|
|
++
|
|
tableAsText ropts showcell (budgetReportAsTable ropts budgetr)
|
|
where
|
|
-- XXX lay out actual, percentage and/or goal in the single table cell for now, should probably use separate cells
|
|
showcell :: (Maybe Change, Maybe BudgetGoal) -> String
|
|
showcell (mactual, mbudget) = actualstr ++ " " ++ budgetstr
|
|
where
|
|
actualwidth = 7
|
|
percentwidth = 4
|
|
budgetwidth = 5
|
|
actual = fromMaybe 0 mactual
|
|
actualstr = printf ("%"++show actualwidth++"s") (showamt actual)
|
|
budgetstr = case mbudget of
|
|
Nothing -> replicate (percentwidth + 7 + budgetwidth) ' '
|
|
Just budget ->
|
|
case percentage actual budget of
|
|
Just pct ->
|
|
printf ("[%"++show percentwidth++"s%% of %"++show budgetwidth++"s]")
|
|
(show $ roundTo 0 pct) (showbudgetamt budget)
|
|
Nothing ->
|
|
printf ("["++replicate (percentwidth+5) ' '++"%"++show budgetwidth++"s]")
|
|
(showbudgetamt budget)
|
|
|
|
-- | Calculate the percentage of actual change to budget goal to show, if any.
|
|
-- Both amounts are converted to cost, if possible, before comparing.
|
|
-- A percentage will not be shown if:
|
|
-- - actual or goal are not the same, single, commodity
|
|
-- - the goal is zero
|
|
percentage :: Change -> BudgetGoal -> Maybe Percentage
|
|
percentage actual budget =
|
|
case (toCost actual, toCost budget) of
|
|
(Mixed [a], Mixed [b]) | (acommodity a == acommodity b || isZeroAmount a) && not (isZeroAmount b)
|
|
-> Just $ 100 * aquantity a / aquantity b
|
|
_ -> Nothing
|
|
where
|
|
toCost = normaliseMixedAmount . costOfMixedAmount
|
|
|
|
showamt :: MixedAmount -> String
|
|
showamt | color_ ropts = cshowMixedAmountOneLineWithoutPrice
|
|
| otherwise = showMixedAmountOneLineWithoutPrice
|
|
|
|
-- don't show the budget amount in color, it messes up alignment
|
|
showbudgetamt = showMixedAmountOneLineWithoutPrice
|
|
|
|
-- | Build a 'Table' from a multi-column balance report.
|
|
budgetReportAsTable :: ReportOpts -> BudgetReport -> Table String String (Maybe MixedAmount, Maybe MixedAmount)
|
|
budgetReportAsTable
|
|
ropts
|
|
(PeriodicReport
|
|
( periods
|
|
, rows
|
|
, (_, _, _, coltots, grandtot, grandavg)
|
|
)) =
|
|
addtotalrow $
|
|
Table
|
|
(T.Group NoLine $ map Header accts)
|
|
(T.Group NoLine $ map Header colheadings)
|
|
(map rowvals rows)
|
|
where
|
|
colheadings = map showDateSpanMonthAbbrev periods
|
|
++ (if row_total_ ropts then [" Total"] else [])
|
|
++ (if average_ ropts then ["Average"] else [])
|
|
accts = map renderacct rows
|
|
renderacct (a,a',i,_,_,_)
|
|
| tree_ ropts = replicate ((i-1)*2) ' ' ++ T.unpack a'
|
|
| otherwise = T.unpack $ maybeAccountNameDrop ropts a
|
|
rowvals (_,_,_,as,rowtot,rowavg) = as
|
|
++ (if row_total_ ropts then [rowtot] else [])
|
|
++ (if average_ ropts then [rowavg] else [])
|
|
addtotalrow | no_total_ ropts = id
|
|
| otherwise = (+----+ (row "" $
|
|
coltots
|
|
++ (if row_total_ ropts && not (null coltots) then [grandtot] else [])
|
|
++ (if average_ ropts && not (null coltots) then [grandavg] else [])
|
|
))
|
|
|
|
-- XXX here for now
|
|
-- | Drop leading components of accounts names as specified by --drop, but only in --flat mode.
|
|
maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName
|
|
maybeAccountNameDrop opts a | flat_ opts = accountNameDrop (drop_ opts) a
|
|
| otherwise = a
|
|
|
|
-- tests
|
|
|
|
tests_BudgetReport = tests "BudgetReport" [
|
|
]
|