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

valuation: implement new --infer-value flag & semantics (#1239, #1253)

Browse Source
This commit is contained in:
Simon Michael 2020-06-19 14:33:34 -07:00
parent 467210c796
commit e3cae4aadc
10 changed files with 122 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
hledger-lib/Hledger/Data/Valuation.hs
View File

@ -101,11 +101,14 @@ type PriceOracle = (Day, CommoditySymbol, Maybe CommoditySymbol) -> Maybe (Commo
-- prices. For best performance, generate this only once per journal,
-- reusing it across reports if there are more than one, as
-- compoundBalanceCommand does.
journalPriceOracle :: Journal -> PriceOracle
journalPriceOracle Journal{jpricedirectives, jinferredmarketprices} =
-- The boolean argument is whether to infer market prices from
-- transactions or not.
journalPriceOracle :: Bool -> Journal -> PriceOracle
journalPriceOracle infer Journal{jpricedirectives, jinferredmarketprices} =
let
declaredprices = map priceDirectiveToMarketPrice jpricedirectives
makepricegraph = memo $ makePriceGraph declaredprices jinferredmarketprices
inferredprices = if infer then jinferredmarketprices else []
makepricegraph = memo $ makePriceGraph declaredprices inferredprices
in
memo $ uncurry3 $ priceLookup makepricegraph
@ -231,7 +234,8 @@ priceLookup makepricegraph d from mto =
let
-- build a graph of the commodity exchange rates in effect on this day
-- XXX should hide these fgl details better
PriceGraph{prGraph=g, prNodemap=m, prDefaultValuationCommodities=defaultdests} = makepricegraph d
PriceGraph{prGraph=g, prNodemap=m, prDefaultValuationCommodities=defaultdests} =
traceAt 1 ("valuation date: "++show d) $ makepricegraph d
fromnode = node m from
mto' = mto <|> mdefaultto
where
@ -290,7 +294,7 @@ tests_priceLookup =
--
-- 1. A *declared market price* or *inferred market price*:
-- A's latest market price in B on or before the valuation date
-- as declared by a P directive, or (with the `--value-infer` flag)
-- as declared by a P directive, or (with the `--infer-value` flag)
-- inferred from transaction prices.
--
-- 2. A *reverse market price*:
@ -305,15 +309,18 @@ tests_priceLookup =
--
-- We also identify each commodity's default valuation commodity, if
-- any. For each commodity A, hledger picks a default valuation
-- commodity as follows:
-- commodity as follows, in this order of preference:
--
-- 1. The price commodity from the latest (on or before valuation
-- date) declared market price for A.
-- 1. The price commodity from the latest declared market price for A
-- on or before valuation date.
--
-- 2. If there are no P directives at all (any commodity, any date),
-- and the `--value-infer` flag is used, then the price commodity
-- from the latest (on or before valuation date) transaction price
-- for A.
-- 2. The price commodity from the latest declared market price for A
-- on any date. (Allows conversion to proceed if there are inferred
-- prices before the valuation date.)
--
-- 3. If there are no P directives at all (any commodity or date), and
-- the `--infer-value` flag is used, then the price commodity from
-- the latest transaction price for A on or before valuation date.
--
makePriceGraph :: [MarketPrice] -> [MarketPrice] -> Day -> PriceGraph
makePriceGraph alldeclaredprices allinferredprices d =
@ -321,8 +328,10 @@ makePriceGraph alldeclaredprices allinferredprices d =
PriceGraph{prGraph=g, prNodemap=m, prDefaultValuationCommodities=defaultdests}
where
-- prices in effect on date d, either declared or inferred
visibledeclaredprices = filter ((<=d).mpdate) alldeclaredprices
visibleinferredprices = filter ((<=d).mpdate) allinferredprices
declaredandinferredprices = dbg2 "declaredandinferredprices" $
declaredOrInferredPricesOn alldeclaredprices allinferredprices d
effectiveMarketPrices visibledeclaredprices visibleinferredprices
-- infer any additional reverse prices not already declared or inferred
reverseprices = dbg2 "reverseprices" $
@ -338,33 +347,40 @@ makePriceGraph alldeclaredprices allinferredprices d =
prices = declaredandinferredprices ++ reverseprices
allcomms = map mpfrom prices
-- determine a default valuation commodity D for each source commodity S:
-- the price commodity in the latest declared market price for S (on any date)
defaultdests = M.fromList [(mpfrom,mpto) | MarketPrice{..} <- alldeclaredprices]
-- determine a default valuation commodity for each source commodity
-- somewhat but not quite like effectiveMarketPrices
defaultdests = M.fromList [(mpfrom,mpto) | MarketPrice{..} <- pricesfordefaultcomms]
where
pricesfordefaultcomms = dbg2 "prices for choosing default valuation commodities, by date then parse order" $
ps
& zip [1..] -- label items with their parse order
& sortBy (compare `on` (\(parseorder,MarketPrice{..})->(mpdate,parseorder))) -- sort by increasing date then increasing parse order
& map snd -- discard labels
where
ps | not $ null visibledeclaredprices = visibledeclaredprices
| not $ null alldeclaredprices = alldeclaredprices
| otherwise = visibleinferredprices -- will be null without --infer-value
-- | From a list of directive-declared market prices in parse order,
-- and a list of transaction-inferred market prices in parse order,
-- get the effective price on the given date for each commodity pair.
-- That is, the latest (by date then parse order) declared price or
-- inferred price, on or before that date, If there is both a declared
-- and inferred price on the same day, declared takes precedence.
declaredOrInferredPricesOn :: [MarketPrice] -> [MarketPrice] -> Day -> [MarketPrice]
declaredOrInferredPricesOn declaredprices inferredprices d =
-- | Given a list of P-declared market prices in parse order and a
-- list of transaction-inferred market prices in parse order, select
-- just the latest prices that are in effect for each commodity pair.
-- That is, for each commodity pair, the latest price by date then
-- parse order, with declared prices having precedence over inferred
-- prices on the same day.
effectiveMarketPrices :: [MarketPrice] -> [MarketPrice] -> [MarketPrice]
effectiveMarketPrices declaredprices inferredprices =
let
-- keeping only prices on or before the valuation date, label each
-- item with its same-day precedence (declared above inferred) and
-- then parse order
declaredprices' = [(1, i, p) | (i,p@MarketPrice{mpdate}) <- zip [1..] declaredprices, mpdate<=d]
inferredprices' = [(0, i, p) | (i,p@MarketPrice{mpdate}) <- zip [1..] inferredprices, mpdate<=d]
-- label each item with its same-day precedence, then parse order
declaredprices' = [(1, i, p) | (i,p) <- zip [1..] declaredprices]
inferredprices' = [(0, i, p) | (i,p) <- zip [1..] inferredprices]
in
-- combine
declaredprices' ++ inferredprices'
-- sort by newest date then highest precedence then latest parse order
-- sort by decreasing date then decreasing precedence then decreasing parse order
& sortBy (flip compare `on` (\(precedence,parseorder,mp)->(mpdate mp,precedence,parseorder)))
-- discard the sorting labels
& map third3
-- keep only the first (ie the newest, highest precedence, latest parsed) price for each pair
-- XXX or use a Map ?
& nubSortBy (compare `on` (\(MarketPrice{..})->(mpfrom,mpto)))
marketPriceReverse :: MarketPrice -> MarketPrice

2
hledger-lib/Hledger/Reports/AccountTransactionsReport.hs
View File

@ -102,7 +102,7 @@ accountTransactionsReport ropts j reportq thisacctq = (label, items)
ts3 = filter (matchesTransaction thisacctq . filterTransactionPostings (And [realq, statusq])) ts2
-- maybe convert these transactions to cost or value
prices = journalPriceOracle j
prices = journalPriceOracle (infer_value_ ropts) j
styles = journalCommodityStyles j
periodlast =
fromMaybe (error' "journalApplyValuation: expected a non-empty journal") $ -- XXX shouldn't happen

20
hledger-lib/Hledger/Reports/BalanceReport.hs
View File

@ -82,16 +82,20 @@ balanceReport ropts@ReportOpts{..} q j =
-- per hledger_options.m4.md "Effect of --value on reports".
valuedaccttree = mapAccounts avalue accttree
where
avalue a@Account{..} = a{aebalance=bvalue aebalance, aibalance=bvalue aibalance}
avalue a@Account{..} = a{aebalance=maybevalue aebalance, aibalance=maybevalue aibalance}
where
bvalue = maybe id (mixedAmountApplyValuation (journalPriceOracle j) (journalCommodityStyles j) periodlast mreportlast today multiperiod) value_
maybevalue = maybe id applyvaluation value_
where
periodlast =
fromMaybe (error' "balanceReport: expected a non-empty journal") $ -- XXX shouldn't happen
reportPeriodOrJournalLastDay ropts j
mreportlast = reportPeriodLastDay ropts
today = fromMaybe (error' "balanceReport: could not pick a valuation date, ReportOpts today_ is unset") today_
multiperiod = interval_ /= NoInterval
applyvaluation = mixedAmountApplyValuation priceoracle styles periodlast mreportlast today multiperiod
where
priceoracle = journalPriceOracle infer_value_ j
styles = journalCommodityStyles j
periodlast = fromMaybe
(error' "balanceReport: expected a non-empty journal") $ -- XXX shouldn't happen
reportPeriodOrJournalLastDay ropts j
mreportlast = reportPeriodLastDay ropts
today = fromMaybe (error' "balanceReport: could not pick a valuation date, ReportOpts today_ is unset") today_
multiperiod = interval_ /= NoInterval
-- Modify this tree for display - depth limit, boring parents, zeroes - and convert to a list.
displayaccts :: [Account]

2
hledger-lib/Hledger/Reports/EntriesReport.hs
View File

@ -40,7 +40,7 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} =
tvalue t@Transaction{..} = t{tpostings=map pvalue tpostings}
where
pvalue p = maybe p
(postingApplyValuation (journalPriceOracle j) (journalCommodityStyles j) periodlast mreportlast today False p)
(postingApplyValuation (journalPriceOracle infer_value_ j) (journalCommodityStyles j) periodlast mreportlast today False p)
value_
where
periodlast = fromMaybe today $ reportPeriodOrJournalLastDay ropts j

9
hledger-lib/Hledger/Reports/MultiBalanceReport.hs
View File

@ -72,7 +72,11 @@ type ClippedAccountName = AccountName
-- hledger's most powerful and useful report, used by the balance
-- command (in multiperiod mode) and (via multiBalanceReport') by the bs/cf/is commands.
multiBalanceReport :: Day -> ReportOpts -> Journal -> MultiBalanceReport
multiBalanceReport today ropts j = multiBalanceReportWith ropts (queryFromOpts today ropts) j (journalPriceOracle j)
multiBalanceReport today ropts j =
multiBalanceReportWith ropts q j (journalPriceOracle infer j)
where
q = queryFromOpts today ropts
infer = infer_value_ ropts
-- | A helper for multiBalanceReport. This one takes an explicit Query
-- instead of deriving one from ReportOpts, and an extra argument, a
@ -363,7 +367,8 @@ multiBalanceReportWith ropts@ReportOpts{..} q j priceoracle =
balanceReportFromMultiBalanceReport :: ReportOpts -> Query -> Journal -> BalanceReport
balanceReportFromMultiBalanceReport opts q j = (rows', total)
where
PeriodicReport _ rows (PeriodicReportRow _ _ totals _ _) = multiBalanceReportWith opts q j (journalPriceOracle j)
PeriodicReport _ rows (PeriodicReportRow _ _ totals _ _) =
multiBalanceReportWith opts q j (journalPriceOracle (infer_value_ opts) j)
rows' = [( a
, if flat_ opts then a else accountLeafName a -- BalanceReport expects full account name here with --flat
, if tree_ opts then d-1 else 0 -- BalanceReport uses 0-based account depths

2
hledger-lib/Hledger/Reports/PostingsReport.hs
View File

@ -74,7 +74,7 @@ postingsReport ropts@ReportOpts{..} q j =
whichdate = whichDateFromOpts ropts
depth = queryDepth q
styles = journalCommodityStyles j
priceoracle = journalPriceOracle j
priceoracle = journalPriceOracle infer_value_ j
multiperiod = interval_ /= NoInterval
today = fromMaybe (error' "postingsReport: could not pick a valuation date, ReportOpts today_ is unset") today_

3
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -93,6 +93,7 @@ data ReportOpts = ReportOpts {
,interval_ :: Interval
,statuses_ :: [Status] -- ^ Zero, one, or two statuses to be matched
,value_ :: Maybe ValuationType -- ^ What value should amounts be converted to ?
,infer_value_ :: Bool -- ^ Infer market prices from transactions ?
,depth_ :: Maybe Int
,display_ :: Maybe DisplayExp -- XXX unused ?
,date2_ :: Bool
@ -161,6 +162,7 @@ defreportopts = ReportOpts
def
def
def
def
rawOptsToReportOpts :: RawOpts -> IO ReportOpts
rawOptsToReportOpts rawopts = checkReportOpts <$> do
@ -173,6 +175,7 @@ rawOptsToReportOpts rawopts = checkReportOpts <$> do
,interval_ = intervalFromRawOpts rawopts'
,statuses_ = statusesFromRawOpts rawopts'
,value_ = valuationTypeFromRawOpts rawopts'
,infer_value_ = boolopt "infer-value" rawopts'
,depth_ = maybeintopt "depth" rawopts'
,display_ = maybedisplayopt d rawopts'
,date2_ = boolopt "date2" rawopts'

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

@ -155,7 +155,7 @@ reportflags = [
-- valuation
,flagNone ["B","cost"] (setboolopt "B")
"show amounts converted to their cost, using the transaction price. Equivalent to --value=cost."
"show amounts converted to their cost/selling amount, using the transaction price. Equivalent to --value=cost."
,flagNone ["V","market"] (setboolopt "V")
(unwords
["show amounts converted to current market value (single period reports)"
@ -178,6 +178,7 @@ reportflags = [
,"- current market value, in default valuation commodity or COMM"
,"- market value on the given date, in default valuation commodity or COMM"
])
,flagNone ["infer-value"] (setboolopt "infer-value") "with -V/-X/--value, also infer market prices from transactions"
-- generated postings/transactions
,flagNone ["auto"] (setboolopt "auto") "apply automated posting rules to modify transactions"

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

@ -146,7 +146,7 @@ compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportopts_=r
-- make a CompoundBalanceReport.
-- For efficiency, generate a price oracle here and reuse it with each subreport.
priceoracle = journalPriceOracle j
priceoracle = journalPriceOracle infer_value_ j
subreports =
map (\CBCSubreportSpec{..} ->
(cbcsubreporttitle

66
tests/journal/valuation2.test
View File

@ -222,31 +222,59 @@ P 2002/01/01 A 2 B
$ hledger -f- bal -N -V -e 2002-01-01
1 B a
# Test market prices inferred from transactions, as in Ledger.
# Test market prices inferred from transactions.
# 22. Market price is not inferred from transactions by default.
<
2020-01-01
(assets:stock) 1 TSLA @ $500
(a) 1 A @ 2 B
2020-03-01
(assets:stock) 1 TSLA @ $500
$ hledger -f- bal -N -V
1 A a
P 2020-03-01 TSLA $600
# 23. Market price is inferred from transactions with --infer-value,
# and -V can work with no P directives.
$ hledger -f- bal -N -V --infer-value
B2 a
2020-05-01
(assets:stock) 1 TSLA @ $800
# 24. A P-declared market price on the same date as a transaction price has precedence.
<
P 2020-01-01 A 1 B
# 22. Market price is inferred from a transaction price,
# -V works without a P directive.
$ hledger -f- bal -N -V -e 2020-01-02
$500 assets:stock
2020-01-01
(a) 1 A @ 2 B
# 23. A P-declared market price has precedence over a transaction price
# on the same date.
$ hledger -f- bal -N -V -e 2020-03-02
$1200 assets:stock
$ hledger -f- bal -N -V --infer-value
1 B a
# 25. A transaction-inferred price newer than a P-declared price has precedence.
<
P 2020-01-01 A 1 B
2020-01-02
(a) 1 A @ 2 B
$ hledger -f- bal -N -V --infer-value
2 B a
# 26. A later-dated P directive sets the valuation commodity even if parsed out of order.
<
P 2020-02-01 A 1 C
P 2020-01-01 A 1 B
2020-02-01
(a) 1 A @ 2 B
$ hledger -f- bal -N -V
1 C a
# 27. A later-dated transaction price sets the valuation commodity even if parsed out of order.
<
2020-01-01
(a) 1 A @ 1 C ; date: 2020-01-02
(a) 1 A @ 1 D ; date: 2020-01-02
(a) 1 A @ 1 B
$ hledger -f- bal -N -V --infer-value
D3 a
# 24. A transaction-implied market price has precedence
# over an older P-declared market price.
$ hledger -f- bal -N -V -e 2020-05-02
$2400 assets:stock