hledger/hledger-lib/Hledger/Reports/BudgetReport.hs

{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Hledger.Reports.BudgetReport (
  BudgetGoal,
  BudgetTotal,
  BudgetAverage,
  BudgetCell,
  BudgetReportRow,
  BudgetReport,
  budgetReport,
  budgetReportAsTable,
  budgetReportAsText,
  budgetReportAsCsv,
  -- * Helpers
  combineBudgetAndActual,
  -- * Tests
  tests_BudgetReport
)
where

import Control.Applicative ((<|>))
import Data.Decimal (roundTo)
import Data.Default (def)
import Data.Function (on)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.List (find, partition, transpose, foldl')
import Data.List.Extra (nubSort)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
--import System.Console.CmdArgs.Explicit as C
--import Lucid as L
import Text.Tabular.AsciiWide as Tab

import Hledger.Data
import Hledger.Utils
import Hledger.Read.CsvReader (CSV)
import Hledger.Reports.ReportOptions
import Hledger.Reports.ReportTypes
import Hledger.Reports.MultiBalanceReport


type BudgetGoal    = Change
type BudgetTotal   = Total
type BudgetAverage = Average

-- | A budget report tracks expected and actual changes per account and subperiod.
type BudgetCell = (Maybe Change, Maybe BudgetGoal)
type BudgetReportRow = PeriodicReportRow DisplayName BudgetCell
type BudgetReport    = PeriodicReport    DisplayName BudgetCell


type BudgetDisplayCell = (BudgetCell, (Int, Int, Int))

-- | Calculate per-account, per-period budget (balance change) goals
-- from all periodic transactions, calculate actual balance changes
-- from the regular transactions, and compare these to get a 'BudgetReport'.
-- Unbudgeted accounts may be hidden or renamed (see journalWithBudgetAccountNames).
budgetReport :: ReportSpec -> BalancingOpts -> DateSpan -> Journal -> BudgetReport
budgetReport rspec bopts reportspan j = dbg4 "sortedbudgetreport" budgetreport
  where
    -- Budget report demands ALTree mode to ensure subaccounts and subaccount budgets are properly handled
    -- and that reports with and without --empty make sense when compared side by side
    ropts = (_rsReportOpts rspec){ accountlistmode_ = ALTree }
    showunbudgeted = empty_ ropts
    budgetedaccts =
      dbg3 "budgetedacctsinperiod" $
      S.fromList $
      expandAccountNames $
      accountNamesFromPostings $
      concatMap tpostings $
      concatMap (`runPeriodicTransaction` reportspan) $
      jperiodictxns j
    actualj = journalWithBudgetAccountNames budgetedaccts showunbudgeted j
    budgetj = journalAddBudgetGoalTransactions bopts ropts reportspan j
    actualreport@(PeriodicReport actualspans _ _) =
        dbg5 "actualreport" $ multiBalanceReport rspec{_rsReportOpts=ropts{empty_=True}} actualj
    budgetgoalreport@(PeriodicReport _ budgetgoalitems budgetgoaltotals) =
        dbg5 "budgetgoalreport" $ multiBalanceReport rspec{_rsReportOpts=ropts{empty_=True}} 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 = PeriodicReport actualspans budgetgoalitems budgetgoaltotals
      | otherwise = budgetgoalreport
    budgetreport = combineBudgetAndActual ropts j budgetgoalreport' actualreport

-- | Use all periodic transactions in the journal to generate
-- budget goal transactions in the specified date span.
-- Budget goal transactions are similar to forecast transactions except
-- their purpose and effect is to define balance change goals, per account and period,
-- for BudgetReport.
journalAddBudgetGoalTransactions :: BalancingOpts -> ReportOpts -> DateSpan -> Journal -> Journal
journalAddBudgetGoalTransactions bopts ropts reportspan j =
  either error' id $ journalBalanceTransactions bopts j{ jtxns = budgetts }  -- PARTIAL:
  where
    budgetspan = dbg3 "budget span" $ reportspan
    pat = fromMaybe "" $ dbg3 "budget pattern" $ T.toLower <$> budgetpat_ ropts
    -- select periodic transactions matching a pattern
    -- (the argument of the (final) --budget option).
    -- XXX two limitations/wishes, requiring more extensive type changes:
    -- - give an error if pat is non-null and matches no periodic txns
    -- - allow a regexp or a full hledger query, not just a substring
    budgetts =
      dbg5 "budget goal txns" $
      [makeBudgetTxn t
      | pt <- jperiodictxns j
      , pat `T.isInfixOf` T.toLower (ptdescription pt)
      , 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 -E/--empty.
--
journalWithBudgetAccountNames :: S.Set AccountName -> Bool -> Journal -> Journal
journalWithBudgetAccountNames budgetedaccts showunbudgeted j =
  dbg5With (("budget account names: "++).pshow.journalAccountNamesUsed) $
  j { jtxns = remapTxn <$> jtxns j }
  where
    remapTxn = txnTieKnot . transactionTransformPostings remapPosting
    remapPosting p = p { paccount = remapAccount $ paccount p, poriginal = poriginal p <|> Just p }
    remapAccount a
      | a `S.member` budgetedaccts = a
      | Just p <- budgetedparent   = if showunbudgeted then a else p
      | otherwise                  = if showunbudgeted then u <> acctsep <> a else u
      where
        budgetedparent = find (`S.member` 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 :: ReportOpts -> Journal -> MultiBalanceReport -> MultiBalanceReport -> BudgetReport
combineBudgetAndActual ropts j
      (PeriodicReport budgetperiods budgetrows (PeriodicReportRow _ budgettots budgetgrandtot budgetgrandavg))
      (PeriodicReport actualperiods actualrows (PeriodicReportRow _ actualtots actualgrandtot actualgrandavg)) =
    PeriodicReport periods sortedrows totalrow
  where
    periods = nubSort . filter (/= nulldatespan) $ budgetperiods ++ actualperiods

    -- first, combine any corresponding budget goals with actual changes
    rows1 =
      [ PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal
      | PeriodicReportRow acct actualamts actualtot actualavg <- actualrows
      , let mbudgetgoals       = HM.lookup (displayFull acct) budgetGoalsByAcct :: Maybe ([BudgetGoal], BudgetTotal, BudgetAverage)
      , let budgetmamts        = maybe (Nothing <$ periods) (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 :: HashMap AccountName ([BudgetGoal], BudgetTotal, BudgetAverage) =
          HM.fromList [ (displayFull acct, (amts, tot, avg))
                         | PeriodicReportRow acct amts tot avg <- budgetrows ]

    -- next, make rows for budget goals with no actual changes
    rows2 =
      [ PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal
      | PeriodicReportRow acct budgetgoals budgettot budgetavg <- budgetrows
      , displayFull acct `notElem` map prrFullName 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)
      ]

    -- combine and re-sort rows
    -- TODO: add --sort-budget to sort by budget goal amount
    sortedrows :: [BudgetReportRow] = sortRowsLike (mbrsorted unbudgetedrows ++ mbrsorted rows') rows
      where
        (unbudgetedrows, rows') = partition ((==unbudgetedAccountName) . prrFullName) rows
        mbrsorted = map prrFullName . sortRows ropts j . map (fmap $ fromMaybe nullmixedamt . fst)
        rows = rows1 ++ rows2

    totalrow = PeriodicReportRow ()
        [ (Map.lookup p totActualByPeriod, Map.lookup p totBudgetByPeriod) | p <- periods ]
        ( Just actualgrandtot, budget budgetgrandtot )
        ( Just actualgrandavg, budget budgetgrandavg )
      where
        totBudgetByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal
        totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change
        budget b = if mixedAmountLooksZero b then Nothing else Just b

-- | Render a budget report as plain text suitable for console output.
budgetReportAsText :: ReportOpts -> BudgetReport -> TL.Text
budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $
    TB.fromText title <> TB.fromText "\n\n" <>
      renderTableByRowsB def{tableBorders=False,prettyTable=pretty_tables_}
        renderCh renderRow displayTableWithWidths
  where
    title = "Budget performance in " <> showDateSpan (periodicReportSpan budgetr)
           <> (case cost_ of
                 Cost   -> ", converted to cost"
                 NoCost -> "")
           <> (case value_ of
                 Just (AtThen _mc)   -> ", valued at posting date"
                 Just (AtEnd _mc)    -> ", valued at period ends"
                 Just (AtNow _mc)    -> ", current value"
                 Just (AtDate d _mc) -> ", valued at " <> showDate d
                 Nothing             -> "")
           <> ":"

    renderCh
      | not commodity_column_ = fmap (textCell TopRight)
      | otherwise = zipWith ($) (Tab.textCell TopLeft : repeat (Tab.textCell TopRight))

    renderRow :: (Text, [((Int, Int, Int), BudgetDisplayCell)]) -> (Cell, [Cell])
    renderRow (rh, cells)
      | not commodity_column_ = (textCell TopLeft rh, fmap (uncurry showcell) cells)
      | otherwise =
          ( textCell TopLeft rh
          , textsCell TopLeft cs : fmap (uncurry (showcell' cs)) cells)
      where
        cs = filter (not . T.null) . S.toList . foldl' S.union mempty
            . fmap (budgetCellCommodities . fst . snd) $ cells

    budgetCellCommodities :: BudgetCell -> S.Set CommoditySymbol
    budgetCellCommodities (am, bm) = f am `S.union` f bm
      where f = S.fromList . fmap acommodity . amounts . fromMaybe nullmixedamt

    displayTableWithWidths :: Table Text Text ((Int, Int, Int), BudgetDisplayCell)
    displayTableWithWidths = Table rh ch $ map (zipWith (,) widths) displaycells
    Table rh ch displaycells = case budgetReportAsTable ropts budgetr of
        Table rh' ch' vals -> maybetranspose . Table rh' ch' $ map (map cellWidth) vals

    showNorm = showMixedAmountB oneLine{displayColour=color_, displayMaxWidth=Just 32}

    cellWidth :: BudgetCell -> BudgetDisplayCell
    cellWidth cell@(actual, budget) =
        let (showF, budgetF)
              | not commodity_column_ = (showamt , budgetAndPerc)
              | otherwise              = (showamt', budgetAndPerc')
            (bam, bp) = fromMaybe (0, 0) $ budgetF <$> budget
         in (cell, (showF actual', bam, bp))
      where
        actual' = fromMaybe nullmixedamt actual
        budgetAndPerc b = (showamt b, fromMaybe 0 $ showper <$> percentage actual' b)
        showamt = wbWidth . showNorm
        showper = T.length . showperc

        cs = S.toList $ budgetCellCommodities cell
        showComm amt = showMixedAmountLinesB noPrice{displayOrder = Just cs} amt
        showamt' = maximum' . fmap wbWidth . showComm
        budgetAndPerc' b = (showamt' b, maximum' $ fmap (fromMaybe 0 . fmap showper . percentage' actual' b) cs)

    widths = zip3 actualwidths budgetwidths percentwidths
    actualwidths  = map (maximum' . map (first3  . snd)) cols
    budgetwidths  = map (maximum' . map (second3 . snd)) cols
    percentwidths = map (maximum' . map (third3  . snd)) cols
    cols = transpose displaycells

    -- XXX lay out actual, percentage and/or goal in the single table cell for now, should probably use separate cells
    showcell :: (Int, Int, Int) -> BudgetDisplayCell -> Cell
    showcell abs@(actualwidth, _, _) ((actual, mbudget), dim@(wa, _, _)) =
        Cell TopRight [WideBuilder ( TB.fromText (T.replicate (actualwidth - wa) " ")
                                   <> TB.fromText (toText actual')
                                   <> budgetstr abs dim (budgetAndPerc <$> mbudget)
                                   ) (actualwidth + totalbudgetwidth)]
      where
        toText = TL.toStrict . TB.toLazyText . wbBuilder . showNorm
        actual' = fromMaybe nullmixedamt actual
        budgetAndPerc b = (toText b, showperc <$> percentage actual' b)

        (_, totalbudgetwidth) = budgetw abs

    showcell' :: [CommoditySymbol] -> (Int, Int, Int) -> BudgetDisplayCell -> Cell
    showcell' cs abs@(actualwidth, _, _) ((actual, mbudget), _) = Cell TopRight full
      where
        showComm = showMixedAmountLinesB noPrice{displayOrder = Just cs}

        actual' = fromMaybe nullmixedamt actual

        toPadded (WideBuilder b w) =
            (TB.fromText . flip T.replicate " " $ actualwidth - w) <> b
        paddedActual = fmap toPadded $ showComm actual'

        (_, totalbudgetwidth) = budgetw abs

        budgetAndPerc :: MixedAmount -> [TB.Builder]
        budgetAndPerc = fmap toBudgetStr . uncurry zip . toText
          where
            toBudgetStr t@(b, mp) =
              let bt = if b == "0" then Nothing else Just t
               in budgetstr abs (0, textWidth b, maybe 0 textWidth mp) bt
            toText b =
                ( fmap (TL.toStrict . TB.toLazyText . wbBuilder) $ showComm b
                , fmap (fmap showperc . percentage' actual' b) cs
                )

        full :: [WideBuilder]
        full = fmap (flip WideBuilder (actualwidth + totalbudgetwidth)) $
            zipWith (<>) paddedActual (fromMaybe (repeat (TB.fromText $ T.replicate totalbudgetwidth " ")) $ fmap budgetAndPerc mbudget)

    budgetw (_, budgetwidth, percentwidth) =
      let totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5
       in ( totalpercentwidth
          , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3
          )

    -- | Display a padded budget string
    budgetstr abs@(_, budgetwidth, percentwidth) (_, wb, wp) mbudget =
        TB.fromText $ case mbudget of
      Nothing                 -> T.replicate totalbudgetwidth " "
      Just (budget, Nothing)  -> " [" <> T.replicate totalpercentwidth " " <> T.replicate (budgetwidth - wb) " " <> budget <> "]"
      Just (budget, Just pct) -> " [" <> T.replicate (percentwidth - wp) " " <> pct <> "% of " <> T.replicate (budgetwidth - wb) " " <> budget <> "]"

      where (totalpercentwidth, totalbudgetwidth) = budgetw abs

    showperc :: Percentage -> Text
    showperc = T.pack . show . roundTo 0

    -- | Calculate the percentage of actual change to budget goal to show, if any.
    -- If valuing at cost, both amounts are converted to cost 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 (costedAmounts actual, costedAmounts budget) of
        ([a], [b]) | (acommodity a == acommodity b || amountLooksZero a) && not (amountLooksZero b)
            -> Just $ 100 * aquantity a / aquantity b
        _   -> -- trace (pshow $ (maybecost actual, maybecost budget))  -- debug missing percentage
               Nothing
      where
        costedAmounts = case cost_ of
            Cost   -> amounts . mixedAmountCost
            NoCost -> amounts

    -- | Calculate the percentage of actual change to budget goal for a particular commodity
    percentage' :: MixedAmount -> MixedAmount -> CommoditySymbol -> Maybe Percentage
    percentage' am bm c = case ((,) `on` find ((==) c . acommodity) . amounts) am bm of
        (Just a, Just b) -> percentage (mixedAmount a) (mixedAmount b)
        _                -> Nothing

    maybetranspose | transpose_ = \(Table rh ch vals) -> Table ch rh (transpose vals)
                   | otherwise  = id

-- | Build a 'Table' from a multi-column balance report.
budgetReportAsTable :: ReportOpts -> BudgetReport -> Table Text Text (Maybe MixedAmount, Maybe MixedAmount)
budgetReportAsTable
  ropts@ReportOpts{balanceaccum_}
  (PeriodicReport spans rows (PeriodicReportRow _ coltots grandtot grandavg)) =
    addtotalrow $
    Table
      (Tab.Group NoLine $ map Header accts)
      (Tab.Group NoLine $ map Header colheadings)
      (map rowvals rows)
  where
    colheadings = ["Commodity" | commodity_column_ ropts]
                  ++ map (reportPeriodName balanceaccum_ spans) spans
                  ++ ["  Total" | row_total_ ropts]
                  ++ ["Average" | average_ ropts]

    accts = map renderacct rows
    -- FIXME. Have to check explicitly for which to render here, since
    -- budgetReport sets accountlistmode to ALTree. Find a principled way to do
    -- this.
    renderacct row = case accountlistmode_ ropts of
        ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row
        ALFlat -> accountNameDrop (drop_ ropts) $ prrFullName row
    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)]
                    ))

-- XXX generalise this with multiBalanceReportAsCsv ?
-- | Render a budget report as CSV. Like multiBalanceReportAsCsv,
-- but includes alternating actual and budget amount columns.
budgetReportAsCsv :: ReportOpts -> BudgetReport -> CSV
budgetReportAsCsv
  ReportOpts{..}
  (PeriodicReport colspans items tr)
  = (if transpose_ then transpose else id) $

  -- heading row
  ("Account" :
  ["Commodity" | commodity_column_ ]
   ++ concatMap (\span -> [showDateSpan span, "budget"]) colspans
   ++ concat [["Total"  ,"budget"] | row_total_]
   ++ concat [["Average","budget"] | average_]
  ) :

  -- account rows
  concatMap (rowAsTexts prrFullName) items

  -- totals row
  ++ concat [ rowAsTexts (const "Total:") tr | not no_total_ ]

  where
    flattentuples abs = concat [[a,b] | (a,b) <- abs]
    showNorm = maybe "" (wbToText . showMixedAmountB oneLine)

    rowAsTexts :: (PeriodicReportRow a BudgetCell -> Text)
               -> PeriodicReportRow a BudgetCell
               -> [[Text]]
    rowAsTexts render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg))
      | not commodity_column_ = [render row : fmap showNorm all]
      | otherwise =
            joinNames . zipWith (:) cs  -- add symbols and names
          . transpose                   -- each row becomes a list of Text quantities
          . fmap (fmap wbToText . showMixedAmountLinesB oneLine{displayOrder=Just cs, displayMinWidth=Nothing})
          . fmap (fromMaybe nullmixedamt)
          $ all
      where
        cs = commodities $ catMaybes all
        commodities = filter (not . T.null) . S.toList
            . foldl' S.union mempty
            . fmap (S.fromList . fmap acommodity . amounts)
        all = flattentuples as
            ++ concat [[rowtot, budgettot] | row_total_]
            ++ concat [[rowavg, budgetavg] | average_]

        joinNames = fmap ((:) (render row))

-- tests

tests_BudgetReport = tests "BudgetReport" [
 ]