{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hledger.Reports.BudgetReport
where
import Data.Decimal
import Data.List
import Data.List.Extra (nubSort)
import Data.Maybe
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>))
#endif
import Data.Ord
import Data.Time.Calendar
import Safe
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Text as T
import Text.Printf (printf)
import Text.Tabular as T
import Hledger.Data
import Hledger.Utils
import Hledger.Reports.ReportOptions
import Hledger.Reports.ReportTypes
import Hledger.Reports.BalanceReport (sortAccountItemsLike)
import Hledger.Reports.MultiBalanceReport
type BudgetGoal = Change
type BudgetTotal = Total
type BudgetAverage = Average
type BudgetCell = (Maybe Change, Maybe BudgetGoal)
type BudgetReport = PeriodicReport AccountName BudgetCell
type BudgetReportRow = PeriodicReportRow AccountName BudgetCell
budgetReport :: ReportOpts -> Bool -> DateSpan -> Day -> Journal -> BudgetReport
budgetReport ropts' assrt reportspan d j =
let
ropts = ropts' { accountlistmode_ = ALTree }
showunbudgeted = empty_ ropts
q = queryFromOpts d ropts
budgetedaccts =
dbg2 "budgetedacctsinperiod" $
nub $
concatMap expandAccountName $
accountNamesFromPostings $
concatMap tpostings $
concatMap (`runPeriodicTransaction` reportspan) $
jperiodictxns j
actualj = dbg1With (("actualj"++).show.jtxns) $ budgetRollUp budgetedaccts showunbudgeted j
budgetj = dbg1With (("budgetj"++).show.jtxns) $ budgetJournal assrt ropts reportspan j
actualreport@(PeriodicReport actualspans _ _) =
dbg1 "actualreport" $ multiBalanceReport ropts q actualj
budgetgoalreport@(PeriodicReport _ budgetgoalitems budgetgoaltotals) =
dbg1 "budgetgoalreport" $ multiBalanceReport (ropts{empty_=True}) q budgetj
budgetgoalreport'
| interval_ ropts == NoInterval = PeriodicReport actualspans budgetgoalitems budgetgoaltotals
| otherwise = budgetgoalreport
budgetreport = combineBudgetAndActual budgetgoalreport' actualreport
sortedbudgetreport = sortBudgetReport ropts j budgetreport
in
dbg1 "sortedbudgetreport" sortedbudgetreport
sortBudgetReport :: ReportOpts -> Journal -> BudgetReport -> BudgetReport
sortBudgetReport ropts j (PeriodicReport ps rows trow) = PeriodicReport ps sortedrows trow
where
sortedrows
| sort_amount_ ropts && tree_ ropts = sortTreeBURByActualAmount rows
| sort_amount_ ropts = sortFlatBURByActualAmount rows
| otherwise = sortByAccountDeclaration rows
sortTreeBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow]
sortTreeBURByActualAmount rows = sortedrows
where
anamesandrows = [(prrName r, r) | r <- rows]
anames = map fst anamesandrows
atotals = [(a, tot) | PeriodicReportRow a _ _ (tot,_) _ <- rows]
accounttree = accountTree "root" anames
accounttreewithbals = mapAccounts setibalance accounttree
where
setibalance a = a{aibalance=
fromMaybe 0 $
fromMaybe (error "sortTreeByAmount 1") $
lookup (aname a) atotals
}
sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals
sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree
sortedrows = sortAccountItemsLike sortedanames anamesandrows
sortFlatBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow]
sortFlatBURByActualAmount = case normalbalance_ ropts of
Just NormallyNegative -> sortOn (fst . prrTotal)
_ -> sortOn (Down . fst . prrTotal)
sortByAccountDeclaration rows = sortedrows
where
(unbudgetedrow,rows') = partition ((=="<unbudgeted>") . prrName) rows
anamesandrows = [(prrName r, r) | r <- rows']
anames = map fst anamesandrows
sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames
sortedrows = unbudgetedrow ++ sortAccountItemsLike sortedanames anamesandrows
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" }
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, poriginal = Just . fromMaybe p $ poriginal 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
combineBudgetAndActual :: MultiBalanceReport -> MultiBalanceReport -> BudgetReport
combineBudgetAndActual
(PeriodicReport budgetperiods budgetrows (PeriodicReportRow _ _ budgettots budgetgrandtot budgetgrandavg))
(PeriodicReport actualperiods actualrows (PeriodicReportRow _ _ actualtots actualgrandtot actualgrandavg)) =
PeriodicReport periods rows totalrow
where
periods = nubSort . filter (/= nulldatespan) $ budgetperiods ++ actualperiods
rows1 =
[ PeriodicReportRow acct treeindent amtandgoals totamtandgoal avgamtandgoal
| PeriodicReportRow acct 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 = second3 <$> mbudgetgoals :: Maybe BudgetTotal
, let mbudgetavg = 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 ] :: [BudgetCell]
, let totamtandgoal = (Just actualtot, mbudgettot)
, let avgamtandgoal = (Just actualavg, mbudgetavg)
]
where
budgetGoalsByAcct :: Map AccountName ([BudgetGoal], BudgetTotal, BudgetAverage) =
Map.fromList [ (acct, (amts, tot, avg))
| PeriodicReportRow acct _ amts tot avg <- budgetrows ]
rows2 =
[ PeriodicReportRow acct treeindent amtandgoals totamtandgoal avgamtandgoal
| PeriodicReportRow acct treeindent budgetgoals budgettot budgetavg <- budgetrows
, acct `notElem` map prrName rows1
, let acctBudgetByPeriod = Map.fromList $ zip budgetperiods budgetgoals :: Map DateSpan BudgetGoal
, let amtandgoals = [ (Nothing, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [BudgetCell]
, let totamtandgoal = (Nothing, Just budgettot)
, let avgamtandgoal = (Nothing, Just budgetavg)
]
rows :: [BudgetReportRow] =
sortOn prrName $ rows1 ++ rows2
totalrow = PeriodicReportRow () 0
[ (Map.lookup p totActualByPeriod, Map.lookup p totBudgetByPeriod) | p <- periods ]
( Just actualgrandtot, Just budgetgrandtot )
( Just actualgrandavg, Just budgetgrandavg )
where
totBudgetByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal
totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change
budgetReportAsText :: ReportOpts -> BudgetReport -> String
budgetReportAsText ropts@ReportOpts{..} budgetr =
title ++ "\n\n" ++
tableAsText ropts showcell (maybetranspose $ budgetReportAsTable ropts budgetr)
where
multiperiod = interval_ /= NoInterval
title = printf "Budget performance in %s%s:"
(showDateSpan $ periodicReportSpan budgetr)
(case value_ of
Just (AtCost _mc) -> ", valued at cost"
Just (AtThen _mc) -> error' unsupportedValueThenError
Just (AtEnd _mc) -> ", valued at period ends"
Just (AtNow _mc) -> ", current value"
Just (AtDefault _mc) | multiperiod -> ", valued at period ends"
Just (AtDefault _mc) -> ", current value"
Just (AtDate d _mc) -> ", valued at "++showDate d
Nothing -> "")
actualwidth = maximum' $ map fst amountsAndGoals
budgetwidth = maximum' $ map snd amountsAndGoals
amountsAndGoals = map (\(a,g) -> (amountLength a, amountLength g))
. concatMap prrAmounts $ prRows budgetr
where amountLength = maybe 0 (length . showMixedAmountOneLineWithoutPrice)
showcell :: BudgetCell -> String
showcell (mactual, mbudget) = actualstr ++ " " ++ budgetstr
where
percentwidth = 4
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)
percentage :: Change -> BudgetGoal -> Maybe Percentage
percentage actual budget =
case (maybecost $ normaliseMixedAmount actual, maybecost $ normaliseMixedAmount budget) of
(Mixed [a], Mixed [b]) | (acommodity a == acommodity b || isZeroAmount a) && not (isZeroAmount b)
-> Just $ 100 * aquantity a / aquantity b
_ ->
Nothing
where
maybecost = if valuationTypeIsCost ropts then costOfMixedAmount else id
showamt :: MixedAmount -> String
showamt | color_ = cshowMixedAmountOneLineWithoutPrice
| otherwise = showMixedAmountOneLineWithoutPrice
showbudgetamt = showMixedAmountOneLineWithoutPrice
maybetranspose | transpose_ = \(Table rh ch vals) -> Table ch rh (transpose vals)
| otherwise = id
budgetReportAsTable :: ReportOpts -> BudgetReport -> Table String String (Maybe MixedAmount, Maybe MixedAmount)
budgetReportAsTable
ropts
(PeriodicReport periods rows (PeriodicReportRow _ _ 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
++ [" Total" | row_total_ ropts]
++ ["Average" | average_ ropts]
accts = map renderacct rows
renderacct (PeriodicReportRow a i _ _ _)
| tree_ ropts = replicate ((i-1)*2) ' ' ++ T.unpack (accountLeafName a)
| otherwise = T.unpack $ maybeAccountNameDrop ropts a
rowvals (PeriodicReportRow _ _ as rowtot rowavg) =
as ++ [rowtot | row_total_ ropts] ++ [rowavg | average_ ropts]
addtotalrow
| no_total_ ropts = id
| otherwise = (+----+ (row "" $
coltots ++ [grandtot | row_total_ ropts && not (null coltots)]
++ [grandavg | average_ ropts && not (null coltots)]
))
maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName
maybeAccountNameDrop opts a | flat_ opts = accountNameDrop (drop_ opts) a
| otherwise = a
tests_BudgetReport = tests "BudgetReport" [
]