simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-09-19 18:29:36 +03:00
Code Issues Projects Releases Wiki Activity

budget: use a new first-class BudgetReport for --budget

Browse Source
This commit is contained in:
Simon Michael 2018-04-03 13:07:13 +01:00
parent 4b3c6afe75
commit 43287a3e26
13 changed files with 431 additions and 220 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
hledger-lib/Hledger/Reports.hs
View File

@ -16,6 +16,7 @@ module Hledger.Reports (
module Hledger.Reports.TransactionsReports,
module Hledger.Reports.BalanceReport,
module Hledger.Reports.MultiBalanceReports,
module Hledger.Reports.BudgetReport,
-- module Hledger.Reports.BalanceHistoryReport,
-- * Tests
@ -32,6 +33,7 @@ import Hledger.Reports.PostingsReport
import Hledger.Reports.TransactionsReports
import Hledger.Reports.BalanceReport
import Hledger.Reports.MultiBalanceReports
import Hledger.Reports.BudgetReport
-- import Hledger.Reports.BalanceHistoryReport
tests_Hledger_Reports :: Test
@ -42,5 +44,6 @@ tests_Hledger_Reports = TestList $
tests_Hledger_Reports_EntriesReport,
tests_Hledger_Reports_PostingsReport,
tests_Hledger_Reports_BalanceReport,
tests_Hledger_Reports_MultiBalanceReport
tests_Hledger_Reports_MultiBalanceReport,
tests_Hledger_Reports_BudgetReport
]

341
hledger-lib/Hledger/Reports/BudgetReport.hs Normal file
View File

@ -0,0 +1,341 @@
{- |
-}
{-# 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 Test.HUnit
--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.CSV
--import Test.HUnit
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 periodic transactions with the specified report interval,
-- calculate actual inflows/outflows from the regular transactions (adjusted to match the
-- budget goals' account tree), and return both as a 'BudgetReport'.
budgetReport :: ReportOpts -> Bool -> Bool -> DateSpan -> Day -> Journal -> BudgetReport
budgetReport ropts assrt showunbudgeted reportspan d j =
let
budgetj = budgetJournal assrt ropts reportspan j
actualj = budgetRollUp showunbudgeted budgetj j
q = queryFromOpts d ropts
budgetgoalreport = dbg1 "budgetgoalreport" $ multiBalanceReport ropts q budgetj
actualreport = dbg1 "actualreport" $ multiBalanceReport ropts q actualj
in
dbg1 "budgetreport" $
combineBudgetAndActual budgetgoalreport actualreport
-- | Select all periodic transactions from the given journal which
-- match the requested report interval, and use them to generate
-- budget transactions (like forecast transactions) in the specified
-- report period (calculated in IO and passed in).
budgetJournal :: Bool -> ReportOpts -> DateSpan -> Journal -> Journal
budgetJournal assrt ropts reportspan j =
either error' id $ journalBalanceTransactions assrt j{ jtxns = budgetts }
where
budgetinterval = dbg2 "budgetinterval" $ interval_ ropts
budgetspan = dbg2 "budgetspan" $ reportspan
budgetts =
dbg1 "budgetts" $
[makeBudgetTxn t
| pt <- jperiodictxns j
, periodTransactionInterval pt == Just budgetinterval
, t <- runPeriodicTransaction pt budgetspan
]
makeBudgetTxn t = txnTieKnot $ t { tdescription = T.pack "Budget transaction" }
-- | Re-map account names to closest parent with periodic transaction from budget.
-- Accounts that don't have suitable parent are either remapped to "<unbudgeted>:topAccount"
-- or left as-is if --show-unbudgeted is provided.
budgetRollUp :: Bool -> Journal -> Journal -> Journal
budgetRollUp showunbudgeted budget j = j { jtxns = remapTxn <$> jtxns j }
where
budgetAccounts = nub $ concatMap (map paccount . ptpostings) $ jperiodictxns budget
remapAccount origAcctName = remapAccount' origAcctName
where
remapAccount' acctName
| acctName `elem` budgetAccounts = acctName
| otherwise =
case parentAccountName acctName of
"" | showunbudgeted -> origAcctName
| otherwise -> T.append (T.pack "<unbudgeted>:") acctName -- TODO: --drop should not remove this
parent -> remapAccount' parent
remapPosting p = p { paccount = remapAccount $ paccount p, porigin = Just . fromMaybe p $ porigin p }
remapTxn = mapPostings (map remapPosting)
mapPostings f t = txnTieKnot $ t { tpostings = f $ tpostings t }
-- | 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: respect hierarchy in tree mode
-- TODO: respect --sort-amount
-- TODO: add --sort-budget
rows :: [PeriodicReportRow (Maybe Change, Maybe BudgetGoal)] =
sortBy (comparing first6) $ rows1 ++ rows2
-- massive duplication from multiBalanceReport to handle tree mode sorting ?
-- dbg1 "sorteditems" $
-- sortitems items
-- where
-- sortitems
-- | sort_amount_ opts && accountlistmode_ opts == ALTree = sortTreeMultiBalanceReportRowsByAmount
-- | sort_amount_ opts = sortFlatMultiBalanceReportRowsByAmount
-- | not (sort_amount_ opts) && accountlistmode_ opts == ALTree = sortTreeMultiBalanceReportRowsByAccountCodeAndName
-- | otherwise = sortFlatMultiBalanceReportRowsByAccountCodeAndName
-- where
-- -- Sort the report rows, representing a flat account list, by row total.
-- sortFlatMultiBalanceReportRowsByAmount = sortBy (maybeflip $ comparing fifth6)
-- where
-- maybeflip = if normalbalance_ opts == Just NormallyNegative then id else flip
--
-- -- Sort the report rows, representing a tree of accounts, by row total at each level.
-- -- To do this we recreate an Account tree with the row totals as balances,
-- -- so we can do a hierarchical sort, flatten again, and then reorder the
-- -- report rows similarly. Yes this is pretty long winded.
-- sortTreeMultiBalanceReportRowsByAmount rows = sortedrows
-- where
-- anamesandrows = [(first6 r, r) | r <- rows]
-- anames = map fst anamesandrows
-- atotals = [(a,tot) | (a,_,_,_,tot,_) <- rows]
-- nametree = treeFromPaths $ map expandAccountName anames
-- accounttree = nameTreeToAccount "root" nametree
-- accounttreewithbals = mapAccounts setibalance accounttree
-- where
-- -- this error should not happen, but it's ugly TODO
-- setibalance a = a{aibalance=fromMaybe (error "sortTreeMultiBalanceReportRowsByAmount 1") $ lookup (aname a) atotals}
-- sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ opts) accounttreewithbals
-- sortedaccounts = drop 1 $ flattenAccounts sortedaccounttree
-- -- dropped the root account, also ignore any parent accounts not in rows
-- sortedrows = concatMap (\a -> maybe [] (:[]) $ lookup (aname a) anamesandrows) sortedaccounts
--
-- -- Sort the report rows by account code if any, with the empty account code coming last, then account name.
-- sortFlatMultiBalanceReportRowsByAccountCodeAndName = sortBy (comparing acodeandname)
-- where
-- acodeandname r = (acode', aname)
-- where
-- aname = first6 r
-- macode = fromMaybe Nothing $ lookup aname $ jaccounts j
-- acode' = fromMaybe maxBound macode
--
-- -- Sort the report rows, representing a tree of accounts, by account code and then account name at each level.
-- -- Convert a tree of account names, look up the account codes, sort and flatten the tree, reorder the rows.
-- sortTreeMultiBalanceReportRowsByAccountCodeAndName rows = sortedrows
-- where
-- anamesandrows = [(first6 r, r) | r <- rows]
-- anames = map fst anamesandrows
-- nametree = treeFromPaths $ map expandAccountName anames
-- accounttree = nameTreeToAccount "root" nametree
-- accounttreewithcodes = mapAccounts (accountSetCodeFrom j) accounttree
-- sortedaccounttree = sortAccountTreeByAccountCodeAndName accounttreewithcodes
-- sortedaccounts = drop 1 $ flattenAccounts sortedaccounttree
-- -- dropped the root account, also ignore any parent accounts not in rows
-- sortedrows = concatMap (\a -> maybe [] (:[]) $ lookup (aname a) anamesandrows) sortedaccounts
--
-- 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
showcell :: (Maybe Change, Maybe BudgetGoal) -> String
showcell (mactual, mbudget) = actualstr ++ " " ++ budgetstr
where
actualwidth = 7
percentwidth = 4
budgetwidth = 5
actualstr = printf ("%"++show actualwidth++"s") (maybe "0" showamt mactual)
budgetstr = case (mactual, mbudget) of
(_, Nothing) -> replicate (percentwidth + 7 + budgetwidth) ' '
(mactual, Just budget) ->
case percentage mactual 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 :: Maybe Change -> BudgetGoal -> Maybe Percentage
percentage Nothing _ = Nothing
percentage (Just actual) budget =
-- percentage of budget consumed is always computed in the cost basis
case (toCost actual, toCost budget) of
(Mixed [a1], Mixed [a2])
| isReallyZeroAmount a1 -> Just 0 -- if there are no postings, we consumed 0% of budget
| acommodity a1 == acommodity a2 && aquantity a2 /= 0 ->
Just $ 100 * aquantity a1 / aquantity a2
_ -> 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 | tree_ opts = a
| otherwise = accountNameDrop (drop_ opts) a
tests_Hledger_Reports_BudgetReport :: Test
tests_Hledger_Reports_BudgetReport = TestList [
]

25
hledger-lib/Hledger/Reports/MultiBalanceReports.hs
View File

@ -12,6 +12,8 @@ module Hledger.Reports.MultiBalanceReports (
balanceReportFromMultiBalanceReport,
mbrNegate,
mbrNormaliseSign,
multiBalanceReportSpan,
tableAsText,
-- -- * Tests
tests_Hledger_Reports_MultiBalanceReport
@ -24,6 +26,8 @@ import Data.Ord
import Data.Time.Calendar
import Safe
import Test.HUnit
import Text.Tabular as T
import Text.Tabular.AsciiWide
import Hledger.Data
import Hledger.Query
@ -259,6 +263,11 @@ mbrNegate (MultiBalanceReport (colspans, rows, totalsrow)) =
mbrRowNegate (acct,shortacct,indent,amts,tot,avg) = (acct,shortacct,indent,map negate amts,-tot,-avg)
mbrTotalsRowNegate (amts,tot,avg) = (map negate amts,-tot,-avg)
-- | Figure out the overall date span of a multicolumn balance report.
multiBalanceReportSpan :: MultiBalanceReport -> DateSpan
multiBalanceReportSpan (MultiBalanceReport ([], _, _)) = DateSpan Nothing Nothing
multiBalanceReportSpan (MultiBalanceReport (colspans, _, _)) = DateSpan (spanStart $ head colspans) (spanEnd $ last colspans)
-- | Generates a simple non-columnar BalanceReport, but using multiBalanceReport,
-- in order to support --historical. Does not support tree-mode boring parent eliding.
-- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts
@ -322,6 +331,22 @@ tests_multiBalanceReport =
Mixed [usd0])
]
-- common rendering helper, XXX here for now
tableAsText :: ReportOpts -> (a -> String) -> Table String String a -> String
tableAsText (ReportOpts{pretty_tables_ = pretty}) showcell =
unlines
. trimborder
. lines
. render pretty id id showcell
. align
where
trimborder = drop 1 . init . map (drop 1 . init)
align (Table l t d) = Table l' t d
where
acctswidth = maximum' $ map strWidth (headerContents l)
l' = padRightWide acctswidth <$> l
tests_Hledger_Reports_MultiBalanceReport :: Test
tests_Hledger_Reports_MultiBalanceReport = TestList
tests_multiBalanceReport

22
hledger-lib/Hledger/Reports/ReportTypes.hs
View File

@ -22,19 +22,19 @@ type Average = MixedAmount -- ^ The average of 'Change's or 'Balance's in a rep
-- budget performance, etc. Successor to MultiBalanceReport.
data PeriodicReport a =
PeriodicReport
( [DateSpan] -- ^ The subperiods formed by spliting the overall report period by the report interval.
-- For ending-balance reports, only the end date is significant.
-- Usually displayed as report columns.
, [PeriodicReportRow a] -- ^ One row per account in the report.
, PeriodicReportRow a -- ^ The grand totals row. The account name in this row is always empty.
( [DateSpan] -- The subperiods formed by splitting the overall report period by the report interval.
-- For ending-balance reports, only the end date is significant.
-- Usually displayed as report columns.
, [PeriodicReportRow a] -- One row per account in the report.
, PeriodicReportRow a -- The grand totals row. The account name in this row is always empty.
)
deriving (Show)
type PeriodicReportRow a =
( AccountName -- ^ A full account name.
, AccountName -- ^ Shortened form of the account name to display in tree mode. Usually the leaf name, possibly with parent accounts prefixed.
, Int -- ^ Indent level for displaying this account name in tree mode. 0, 1, 2...
, [a] -- ^ The data value for each subperiod.
, a -- ^ The total of this row's values.
, a -- ^ The average of this row's values.
( AccountName -- A full account name.
, AccountName -- Shortened form of the account name to display in tree mode. Usually the leaf name, possibly with parent accounts prefixed.
, Int -- Indent level for displaying this account name in tree mode. 0, 1, 2...
, [a] -- The data value for each subperiod.
, a -- The total of this row's values.
, a -- The average of this row's values.
)

0
hledger/Text/Tabular/AsciiWide.hs → hledger-lib/Text/Tabular/AsciiWide.hs
View File

11
hledger-lib/hledger-lib.cabal
View File

@ -113,8 +113,10 @@ library
Hledger.Read.TimeclockReader
Hledger.Reports
Hledger.Reports.ReportOptions
Hledger.Reports.ReportTypes
Hledger.Reports.BalanceHistoryReport
Hledger.Reports.BalanceReport
Hledger.Reports.BudgetReport
Hledger.Reports.EntriesReport
Hledger.Reports.MultiBalanceReports
Hledger.Reports.PostingsReport
@ -130,9 +132,8 @@ library
Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
Text.Tabular.AsciiWide
other-modules:
Hledger.Reports.BudgetReport
Hledger.Reports.ReportTypes
Paths_hledger_lib
default-language: Haskell2010
@ -172,6 +173,7 @@ test-suite doctests
, regex-tdfa
, safe >=0.2
, split >=0.1
, tabular >=0.2
, text >=1.2
, time >=1.5
, transformers >=0.2
@ -229,6 +231,7 @@ test-suite doctests
Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
Text.Tabular.AsciiWide
Paths_hledger_lib
default-language: Haskell2010
@ -268,6 +271,7 @@ test-suite easytests
, regex-tdfa
, safe >=0.2
, split >=0.1
, tabular >=0.2
, text >=1.2
, time >=1.5
, transformers >=0.2
@ -323,6 +327,7 @@ test-suite easytests
Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
Text.Tabular.AsciiWide
Paths_hledger_lib
default-language: Haskell2010
@ -363,6 +368,7 @@ test-suite hunittests
, split >=0.1
, test-framework
, test-framework-hunit
, tabular >=0.2
, text >=1.2
, time >=1.5
, transformers >=0.2
@ -418,5 +424,6 @@ test-suite hunittests
Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
Text.Tabular.AsciiWide
Paths_hledger_lib
default-language: Haskell2010

2
hledger-lib/package.yaml
View File

@ -63,6 +63,7 @@ dependencies:
- regex-tdfa
- safe >=0.2
- split >=0.1
- tabular >=0.2
- text >=1.2
- time >=1.5
- transformers >=0.2
@ -141,6 +142,7 @@ library:
- Hledger.Utils.Tree
- Hledger.Utils.UTF8IOCompat
- Text.Megaparsec.Compat
- Text.Tabular.AsciiWide
# other-modules:
# - Ledger.Parser.Text

6
hledger/Hledger/Cli/CliOptions.hs
View File

@ -53,7 +53,6 @@ module Hledger.Cli.CliOptions (
replaceNumericFlags,
-- | For register:
registerWidthsFromOpts,
maybeAccountNameDrop,
-- | For balance:
lineFormatFromOpts,
@ -584,11 +583,6 @@ registerWidthsFromOpts CliOpts{width_=Just s} =
eof
return (totalwidth, descwidth)
-- | Drop leading components of accounts names as specified by --drop, but only in --flat mode.
maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName
maybeAccountNameDrop opts a | tree_ opts = a
| otherwise = accountNameDrop (drop_ opts) a
-- for balance, currently:
-- | Parse the format option if provided, possibly returning an error,

203
hledger/Hledger/Cli/Commands/Balance.hs
View File

@ -245,25 +245,23 @@ module Hledger.Cli.Commands.Balance (
,multiBalanceReportAsCsv
,multiBalanceReportAsHtml
,multiBalanceReportHtmlRows
,renderBalanceReportTable
,balanceReportAsTable
,balanceReportTableAsText
,tests_Hledger_Cli_Commands_Balance
) where
import Data.Decimal
import Data.List
import Data.Maybe
import qualified Data.Map as Map
--import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import System.Console.CmdArgs.Explicit as C
import Data.Decimal (roundTo)
import Lucid as L
import Text.CSV
import Test.HUnit
import Text.Printf (printf)
import Text.Tabular as T
import Text.Tabular.AsciiWide
--import Text.Tabular.AsciiWide
import Hledger
import Hledger.Cli.CliOptions
@ -330,15 +328,15 @@ balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
_ | boolopt "budget" rawopts -> do
-- multi column budget report
reportspan <- reportSpan j ropts
let budget = budgetJournal opts reportspan j
j' = budgetRollUp opts budget j
report = dbg1 "report" $ multiBalanceReport ropts (queryFromOpts d ropts) j'
budgetReport = dbg1 "budgetreport" $ multiBalanceReport ropts (queryFromOpts d ropts) budget
let budgetreport = dbg1 "budgetreport" $ budgetReport ropts assrt showunbudgeted reportspan d j
where
showunbudgeted = boolopt "show-unbudgeted" rawopts
assrt = not $ ignore_assertions_ $ inputopts_ opts
render = case format of
"csv" -> const $ error' "Sorry, CSV output is not yet implemented for this kind of report." -- TODO
"html" -> const $ error' "Sorry, HTML output is not yet implemented for this kind of report." -- TODO
_ -> multiBalanceReportWithBudgetAsText ropts budgetReport
writeOutput opts $ render report
_ -> budgetReportAsText ropts
writeOutput opts $ render budgetreport
| otherwise -> do
-- multi column balance report
@ -349,50 +347,7 @@ balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
_ -> multiBalanceReportAsText ropts
writeOutput opts $ render report
-- | Re-map account names to closest parent with periodic transaction from budget.
-- Accounts that don't have suitable parent are either remapped to "<unbudgeted>:topAccount"
-- or left as-is if --show-unbudgeted is provided.
budgetRollUp :: CliOpts -> Journal -> Journal -> Journal
budgetRollUp CliOpts{rawopts_=rawopts} budget j = j { jtxns = remapTxn <$> jtxns j }
where
budgetAccounts = nub $ concatMap (map paccount . ptpostings) $ jperiodictxns budget
remapAccount origAcctName = remapAccount' origAcctName
where
remapAccount' acctName
| acctName `elem` budgetAccounts = acctName
| otherwise =
case parentAccountName acctName of
"" | boolopt "show-unbudgeted" rawopts -> origAcctName
| otherwise -> T.append (T.pack "<unbudgeted>:") acctName -- TODO: --drop should not remove this
parent -> remapAccount' parent
remapPosting p = p { paccount = remapAccount $ paccount p, porigin = Just . fromMaybe p $ porigin p }
remapTxn = mapPostings (map remapPosting)
mapPostings f t = txnTieKnot $ t { tpostings = f $ tpostings t }
-- | Select all periodic transactions from the given journal which
-- match the requested report interval, and use them to generate
-- budget transactions (like forecast transactions) in the specified
-- report period (calculated in IO and passed in).
budgetJournal :: CliOpts -> DateSpan -> Journal -> Journal
budgetJournal opts reportspan j = journalBalanceTransactions' opts j { jtxns = budgetts }
where
budgetinterval = dbg2 "budgetinterval" $ intervalFromRawOpts $ rawopts_ opts
budgetspan = dbg2 "budgetspan" $ reportspan
budgetts =
dbg1 "budgetts" $
[makeBudgetTxn t
| pt <- jperiodictxns j
, periodTransactionInterval pt == Just budgetinterval
, t <- runPeriodicTransaction pt budgetspan
]
makeBudgetTxn t = txnTieKnot $ t { tdescription = T.pack "Budget transaction" }
journalBalanceTransactions' opts j =
let assrt = not . ignore_assertions_ $ inputopts_ opts
in
either error' id $ journalBalanceTransactions assrt j
-- single-column balance reports
-- rendering single-column balance reports
-- | Find the best commodity to convert to when asked to show the
-- market value of this commodity on the given date. That is, the one
@ -522,7 +477,7 @@ renderComponent1 opts (acctname, depth, total) (FormatField ljust min max field)
| otherwise = showMixedAmountWithoutPrice
_ -> ""
-- multi-column balance reports
-- rendering multi-column balance reports
-- | Render a multi-column balance report as CSV.
-- The CSV will always include the initial headings row,
@ -641,7 +596,7 @@ multiBalanceReportHtmlFootRow ropts (acct:rest) =
multiBalanceReportAsText :: ReportOpts -> MultiBalanceReport -> String
multiBalanceReportAsText opts r =
printf "%s in %s:\n\n" desc (showDateSpan $ multiBalanceReportSpan r)
++ renderBalanceReportTable opts tabl
++ balanceReportTableAsText opts tabl
where
tabl = balanceReportAsTable opts r
desc = case balancetype_ opts of
@ -649,129 +604,11 @@ multiBalanceReportAsText opts r =
CumulativeChange -> "Ending balances (cumulative)"
HistoricalBalance -> "Ending balances (historical)"
type ActualAmount = MixedAmount
type BudgetAmount = MixedAmount
type ActualAmountsReport = MultiBalanceReport
type BudgetAmountsReport = MultiBalanceReport
type ActualAmountsTable = Table String String MixedAmount
type BudgetAmountsTable = Table String String MixedAmount
type ActualAndBudgetAmountsTable = Table String String (Maybe MixedAmount, Maybe MixedAmount)
type Percentage = Decimal
-- | Given two multi-column balance reports, the first representing a budget
-- (target change amounts) and the second representing actual change amounts,
-- render a budget report as plain text suitable for console output.
-- The reports should have the same number of columns.
multiBalanceReportWithBudgetAsText :: ReportOpts -> BudgetAmountsReport -> ActualAmountsReport -> String
multiBalanceReportWithBudgetAsText opts budgetr actualr =
printf "%s in %s:\n\n" desc (showDateSpan $ multiBalanceReportSpan actualr)
++ renderBalanceReportTable' opts showcell actualandbudgetamts
where
desc :: String
desc = case balancetype_ opts of
PeriodChange -> "Balance changes"
CumulativeChange -> "Ending balances (cumulative)"
HistoricalBalance -> "Ending balances (historical)"
actualandbudgetamts :: ActualAndBudgetAmountsTable
actualandbudgetamts = combineTables (balanceReportAsTable opts actualr) (balanceReportAsTable opts budgetr)
showcell :: (Maybe ActualAmount, Maybe BudgetAmount) -> String
showcell (mactual, mbudget) = actualstr ++ " " ++ budgetstr
where
actualwidth = 7
percentwidth = 4
budgetwidth = 5
actualstr = printf ("%"++show actualwidth++"s") (maybe "" showamt mactual)
budgetstr = case (mactual, mbudget) of
(_, Nothing) -> replicate (percentwidth + 7 + budgetwidth) ' '
(mactual, Just budget) ->
case percentage mactual budget of
Just pct ->
printf ("[%"++show percentwidth++"s%% of %"++show budgetwidth++"s]")
(show $ roundTo 0 pct) (showamt budget)
Nothing ->
printf ("["++replicate (percentwidth+5) ' '++"%"++show budgetwidth++"s]")
(showamt budget)
percentage :: Maybe ActualAmount -> BudgetAmount -> Maybe Percentage
percentage Nothing _ = Nothing
percentage (Just actual) budget =
-- percentage of budget consumed is always computed in the cost basis
case (toCost actual, toCost budget) of
(Mixed [a1], Mixed [a2])
| isReallyZeroAmount a1 -> Just 0 -- if there are no postings, we consumed 0% of budget
| acommodity a1 == acommodity a2 && aquantity a2 /= 0 ->
Just $ 100 * aquantity a1 / aquantity a2
_ -> Nothing
where
toCost = normaliseMixedAmount . costOfMixedAmount
showamt :: MixedAmount -> String
showamt | color_ opts = cshowMixedAmountOneLineWithoutPrice
| otherwise = showMixedAmountOneLineWithoutPrice
-- Combine a table of actual amounts and a table of budgeted amounts into
-- a single table of (Maybe actualamount, Maybe budgetamount) tuples.
-- The actual and budget table need not have the same account rows or date columns.
-- Every row and column from either table will appear in the combined table.
-- TODO better to combine the reports, not these tables which are just rendering helpers
combineTables :: ActualAmountsTable -> BudgetAmountsTable -> ActualAndBudgetAmountsTable
combineTables (Table aaccthdrs adatehdrs arows) (Table baccthdrs bdatehdrs brows) =
addtotalrow $ Table caccthdrs cdatehdrs crows
where
[aaccts, adates, baccts, bdates] = map headerContents [aaccthdrs, adatehdrs, baccthdrs, bdatehdrs]
-- combined account names
-- TODO Can't sort these or things will fall apart.
caccts = dbg2 "caccts" $ init $ (dbg2 "aaccts" $ filter (not . null) aaccts) `union` (dbg2 "baccts" baccts)
caccthdrs = T.Group NoLine $ map Header $ caccts
-- Actual column dates and budget column dates could be different.
-- TODO Can't easily combine these preserving correct order, will go wrong on monthly reports probably.
cdates = dbg2 "cdates" $ sort $ (dbg2 "adates" adates) `union` (dbg2 "bdates" bdates)
cdatehdrs = T.Group NoLine $ map Header cdates
-- corresponding rows of combined actual and/or budget amounts
crows = [ combineRow (actualRow a) (budgetRow a) | a <- caccts ]
-- totals row
addtotalrow | no_total_ opts = id
| otherwise = (+----+ (row "" $ combineRow (actualRow "") (budgetRow "")))
-- helpers
combineRow arow brow =
dbg1 "row" $ [(actualAmt d, budgetAmt d) | d <- cdates]
where
actualAmt date = Map.lookup date $ Map.fromList $ zip adates arow
budgetAmt date = Map.lookup date $ Map.fromList $ zip bdates brow
actualRow acct = fromMaybe [] $ Map.lookup acct $ Map.fromList $ zip aaccts arows
budgetRow acct = fromMaybe [] $ Map.lookup acct $ Map.fromList $ zip baccts brows
-- | Given a table representing a multi-column balance report (for example,
-- made using 'balanceReportAsTable'), render it in a format suitable for
-- console output.
renderBalanceReportTable :: ReportOpts -> Table String String MixedAmount -> String
renderBalanceReportTable ropts =
renderBalanceReportTable' ropts showamt
where
showamt | color_ ropts = cshowMixedAmountOneLineWithoutPrice
| otherwise = showMixedAmountOneLineWithoutPrice
renderBalanceReportTable' :: ReportOpts -> (a -> String) -> Table String String a -> String
renderBalanceReportTable' (ReportOpts { pretty_tables_ = pretty}) showamt =
unlines
. trimborder
. lines
. render pretty id id showamt
. align
where
trimborder = drop 1 . init . map (drop 1 . init)
align (Table l t d) = Table l' t d
where
acctswidth = maximum' $ map strWidth (headerContents l)
l' = padRightWide acctswidth <$> l
-- | Build a 'Table' from a multi-column balance report.
balanceReportAsTable :: ReportOpts -> MultiBalanceReport -> Table String String MixedAmount
balanceReportAsTable opts (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) =
addtotalrow $ Table
addtotalrow $
Table
(T.Group NoLine $ map Header accts)
(T.Group NoLine $ map Header colheadings)
(map rowvals items)
@ -796,10 +633,14 @@ balanceReportAsTable opts (MultiBalanceReport (colspans, items, (coltotals,tot,a
++ (if average_ opts && not (null coltotals) then [avg] else [])
))
-- | Figure out the overall date span of a multicolumn balance report.
multiBalanceReportSpan :: MultiBalanceReport -> DateSpan
multiBalanceReportSpan (MultiBalanceReport ([], _, _)) = DateSpan Nothing Nothing
multiBalanceReportSpan (MultiBalanceReport (colspans, _, _)) = DateSpan (spanStart $ head colspans) (spanEnd $ last colspans)
-- | Given a table representing a multi-column balance report (for example,
-- made using 'balanceReportAsTable'), render it in a format suitable for
-- console output.
balanceReportTableAsText :: ReportOpts -> Table String String MixedAmount -> String
balanceReportTableAsText ropts = tableAsText ropts showamt
where
showamt | color_ ropts = cshowMixedAmountOneLineWithoutPrice
| otherwise = showMixedAmountOneLineWithoutPrice
tests_Hledger_Cli_Commands_Balance = TestList

2
hledger/Hledger/Cli/CompoundBalanceCommand.hs
View File

@ -249,7 +249,7 @@ Balance Sheet
compoundBalanceReportAsText :: ReportOpts -> CompoundBalanceReport -> String
compoundBalanceReportAsText ropts (title, _colspans, subreports, (coltotals, grandtotal, grandavg)) =
title ++ "\n\n" ++
renderBalanceReportTable ropts bigtable'
balanceReportTableAsText ropts bigtable'
where
singlesubreport = length subreports == 1
bigtable =

1
hledger/hledger.cabal
View File

@ -150,7 +150,6 @@ library
Hledger.Cli.Commands.Stats
Hledger.Cli.Commands.Tags
Hledger.Cli.CompoundBalanceCommand
Text.Tabular.AsciiWide
other-modules:
Paths_hledger
default-language: Haskell2010

1
hledger/package.yaml
View File

@ -131,7 +131,6 @@ library:
- Hledger.Cli.Commands.Stats
- Hledger.Cli.Commands.Tags
- Hledger.Cli.CompoundBalanceCommand
- Text.Tabular.AsciiWide
dependencies:
- bytestring
- containers

32
tests/budget/budget.test
View File

@ -32,7 +32,7 @@
# 1. Test --budget switch
$ hledger bal -D -b 2016-12-01 -e 2016-12-04 -f - --budget
Balance changes in 2016/12/01-2016/12/03:
Budget performance in 2016/12/01-2016/12/03:
|| 2016/12/01 2016/12/02 2016/12/03
=======================++==============================================================================
@ -45,7 +45,7 @@ Balance changes in 2016/12/01-2016/12/03:
# 2. --show-unbudgeted
$ hledger bal -D -b 2016-12-01 -e 2016-12-04 -f - --budget --show-unbudgeted
Balance changes in 2016/12/01-2016/12/03:
Budget performance in 2016/12/01-2016/12/03:
|| 2016/12/01 2016/12/02 2016/12/03
==================++==============================================================================
@ -93,7 +93,7 @@ Balance changes in 2016/12/01-2016/12/03:
assets:cash
$ hledger bal -D -b 2016-12-01 -e 2016-12-04 -f - --budget
Balance changes in 2016/12/01-2016/12/03:
Budget performance in 2016/12/01-2016/12/03:
|| 2016/12/01 2016/12/02 2016/12/03
=======================++=====================================================================================
@ -137,7 +137,7 @@ $ hledger -f- bal --budget
# 5. With -D it selects the daily budget.
# The budget is unbounded, so extends through the report period.
$ hledger -f- bal --budget -D
Balance changes in 2018/01/01-2018/01/03:
Budget performance in 2018/01/01-2018/01/03:
|| 2018/01/01 2018/01/02 2018/01/03
===++==============================================================================
@ -150,7 +150,7 @@ Balance changes in 2018/01/01-2018/01/03:
# 6. And with -W it selects the weekly budget, defined by all weekly periodic transactions.
$ hledger -f- bal --budget -W
Balance changes in 2018/01/01w01:
Budget performance in 2018/01/01w01:
|| 2018/01/01w01
===++==========================
@ -182,7 +182,7 @@ Balance changes in 2018/01/01w01:
(b) 1
$ hledger -f- bal --budget -D
Balance changes in 2018/01/01-2018/01/04:
Budget performance in 2018/01/01-2018/01/04:
|| 2018/01/01 2018/01/02 2018/01/03 2018/01/04
================++========================================================================================================
@ -212,7 +212,7 @@ Balance changes in 2018/01/01-2018/01/04:
(a) 1
$ hledger -f- bal --budget -D
Balance changes in 2018/01/01-2018/01/04:
Budget performance in 2018/01/01-2018/01/04:
|| 2018/01/01 2018/01/02 2018/01/03 2018/01/04
===++========================================================================================================
@ -222,7 +222,7 @@ Balance changes in 2018/01/01-2018/01/04:
# 9. A "from A to B" budget should not be included in a report beginning on B.
$ hledger -f- bal --budget -D -b 2018/1/3
Balance changes in 2018/01/03-2018/01/04:
Budget performance in 2018/01/03-2018/01/04:
|| 2018/01/03 2018/01/04
===++====================================================
@ -243,18 +243,18 @@ Balance changes in 2018/01/03-2018/01/04:
# 10. accounts with non-zero budget should be shown by default
# even if there are no actual transactions in the period,
# or if the actual amount is zero.
# $ hledger -f- bal --budget -D date:2018/1/1-2018/1/3
# Balance changes in 2018/01/01-2018/01/02:
$ hledger -f- bal --budget -D date:2018/1/1-2018/1/3
Budget performance in 2018/01/01-2018/01/02:
# || 2018/01/01 2018/01/02
# ===++====================================================
# a || [ 1] [ 1]
# ---++----------------------------------------------------
# || [ 1] [ 1]
|| 2018/01/01 2018/01/02
===++====================================================
a || 0 [ 1] 0 [ 1]
---++----------------------------------------------------
|| 0 [ 1] 0 [ 1]
# 11. With -E, zeroes are shown
$ hledger -f- bal --budget -D date:2018/1/1-2018/1/3 -E
Balance changes in 2018/01/01-2018/01/02:
Budget performance in 2018/01/01-2018/01/02:
|| 2018/01/01 2018/01/02
===++====================================================