slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

memoise market valuation, making it fast (#999)

Browse Source
This commit is contained in:
Simon Michael 2019-08-19 02:16:39 +01:00
parent 4beb416070
commit 1cbbe8f43d
9 changed files with 116 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
hledger-lib/Hledger/Data/Posting.hs
View File

@ -319,6 +319,7 @@ accountNameApplyAliases aliases a = accountNameWithPostingType atype aname'
-- | Memoising version of accountNameApplyAliases, maybe overkill.
accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> AccountName
accountNameApplyAliasesMemo aliases = memo (accountNameApplyAliases aliases)
-- XXX re-test this memoisation
-- aliasMatches :: AccountAlias -> AccountName -> Bool
-- aliasMatches (BasicAlias old _) a = old `isAccountNamePrefixOf` a
@ -331,18 +332,18 @@ aliasReplace (BasicAlias old new) a
aliasReplace (RegexAlias re repl) a = T.pack $ regexReplaceCIMemo re repl $ T.unpack a -- XXX
-- Apply a specified valuation to this posting's amount, using the provided
-- prices db, commodity styles, period-end/current dates, and whether
-- price oracle, commodity styles, period-end/current dates, and whether
-- this is for a multiperiod report or not.
postingApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> Posting -> ValuationType -> Posting
postingApplyValuation prices styles periodend today ismultiperiod p v =
postingApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> Posting -> ValuationType -> Posting
postingApplyValuation priceoracle styles periodend today ismultiperiod p v =
case v of
AtCost Nothing -> postingToCost styles p
AtCost mc -> postingValueAtDate prices styles mc periodend $ postingToCost styles p
AtEnd mc -> postingValueAtDate prices styles mc periodend p
AtNow mc -> postingValueAtDate prices styles mc today p
AtDefault mc | ismultiperiod -> postingValueAtDate prices styles mc periodend p
AtDefault mc -> postingValueAtDate prices styles mc today p
AtDate d mc -> postingValueAtDate prices styles mc d p
AtCost mc -> postingValueAtDate priceoracle styles mc periodend $ postingToCost styles p
AtEnd mc -> postingValueAtDate priceoracle styles mc periodend p
AtNow mc -> postingValueAtDate priceoracle styles mc today p
AtDefault mc | ismultiperiod -> postingValueAtDate priceoracle styles mc periodend p
AtDefault mc -> postingValueAtDate priceoracle styles mc today p
AtDate d mc -> postingValueAtDate priceoracle styles mc d p
-- | Convert this posting's amount to cost, and apply the appropriate amount styles.
postingToCost :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting
@ -350,11 +351,11 @@ postingToCost styles p@Posting{pamount=a} = p{pamount=mixedAmountToCost styles a
-- | Convert this posting's amount to market value in the given commodity,
-- or the default valuation commodity, at the given valuation date,
-- using the given market prices.
-- using the given market price oracle.
-- When market prices available on that date are not sufficient to
-- calculate the value, amounts are left unchanged.
postingValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Posting -> Posting
postingValueAtDate prices styles mc d p = postingTransformAmount (mixedAmountValueAtDate prices styles mc d) p
postingValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Posting -> Posting
postingValueAtDate priceoracle styles mc d p = postingTransformAmount (mixedAmountValueAtDate priceoracle styles mc d) p
-- | Apply a transform function to this posting's amount.
postingTransformAmount :: (MixedAmount -> MixedAmount) -> Posting -> Posting

5
hledger-lib/Hledger/Data/Types.hs
View File

@ -468,6 +468,11 @@ data PriceGraph = PriceGraph {
instance NFData PriceGraph
-- | A price oracle is a magic function that looks up market prices
-- (exchange rates) from one commodity to another (or if unspecified,
-- to a default valuation commodity) on a given date, somewhat efficiently.
type PriceOracle = (Day, CommoditySymbol, Maybe CommoditySymbol) -> Maybe (CommoditySymbol, Quantity)
-- | What kind of value conversion should be done on amounts ?
-- UI: --value=cost|end|now|DATE[,COMM]
data ValuationType =

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

@ -11,8 +11,9 @@ looking up historical market prices (exchange rates) between commodities.
{-# LANGUAGE ScopedTypeVariables #-}
module Hledger.Data.Valuation (
amountValueAtDate
,amountApplyValuation
journalPriceOracle
-- ,amountValueAtDate
-- ,amountApplyValuation
,mixedAmountValueAtDate
,mixedAmountApplyValuation
,marketPriceReverse
@ -32,6 +33,7 @@ import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Data.MemoUgly (memo)
import Safe (headMay)
import Hledger.Utils
@ -44,37 +46,39 @@ tests_Valuation = tests "Valuation" [
tests_priceLookup
]
------------------------------------------------------------------------------
-- Valuation
-- Apply a specified valuation to this mixed amount, using the provided
-- prices db, commodity styles, period-end/current dates,
-- | Apply a specified valuation to this mixed amount, using the provided
-- price oracle, commodity styles, period-end/current dates,
-- and whether this is for a multiperiod report or not.
mixedAmountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> MixedAmount -> MixedAmount
mixedAmountApplyValuation prices styles periodend today ismultiperiod v (Mixed as) =
Mixed $ map (amountApplyValuation prices styles periodend today ismultiperiod v) as
mixedAmountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> MixedAmount -> MixedAmount
mixedAmountApplyValuation priceoracle styles periodend today ismultiperiod v (Mixed as) =
Mixed $ map (amountApplyValuation priceoracle styles periodend today ismultiperiod v) as
-- | Apply a specified valuation to this amount, using the provided
-- price oracle, commodity styles, period-end/current dates,
-- and whether this is for a multiperiod report or not.
amountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> Amount -> Amount
amountApplyValuation priceoracle styles periodend today ismultiperiod v a =
case v of
AtCost Nothing -> amountToCost styles a
AtCost mc -> amountValueAtDate priceoracle styles mc periodend $ amountToCost styles a
AtEnd mc -> amountValueAtDate priceoracle styles mc periodend a
AtNow mc -> amountValueAtDate priceoracle styles mc today a
AtDefault mc | ismultiperiod -> amountValueAtDate priceoracle styles mc periodend a
AtDefault mc -> amountValueAtDate priceoracle styles mc today a
AtDate d mc -> amountValueAtDate priceoracle styles mc d a
-- | Find the market value of each component amount in the given
-- commodity, or its default valuation commodity, at the given
-- valuation date, using the given market prices.
-- valuation date, using the given market price oracle.
-- When market prices available on that date are not sufficient to
-- calculate the value, amounts are left unchanged.
mixedAmountValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
mixedAmountValueAtDate prices styles mc d (Mixed as) = Mixed $ map (amountValueAtDate prices styles mc d) as
-- | Apply a specified valuation to this amount, using the provided
-- prices db, commodity styles, period-end/current dates,
-- and whether this is for a multiperiod report or not.
amountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> Amount -> Amount
amountApplyValuation prices styles periodend today ismultiperiod v a =
case v of
AtCost Nothing -> amountToCost styles a
AtCost mc -> amountValueAtDate prices styles mc periodend $ amountToCost styles a
AtEnd mc -> amountValueAtDate prices styles mc periodend a
AtNow mc -> amountValueAtDate prices styles mc today a
AtDefault mc | ismultiperiod -> amountValueAtDate prices styles mc periodend a
AtDefault mc -> amountValueAtDate prices styles mc today a
AtDate d mc -> amountValueAtDate prices styles mc d a
mixedAmountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
mixedAmountValueAtDate priceoracle styles mc d (Mixed as) = Mixed $ map (amountValueAtDate priceoracle styles mc d) as
-- | Find the market value of this amount in the given valuation
-- commodity if any, otherwise the default valuation commodity, at the
@ -88,9 +92,9 @@ amountApplyValuation prices styles periodend today ismultiperiod v a =
--
-- If the market prices available on that date are not sufficient to
-- calculate this value, the amount is left unchanged.
amountValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Amount -> Amount
amountValueAtDate pricedirectives styles mto d a =
case priceLookup pricedirectives d (acommodity a) mto of
amountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Amount -> Amount
amountValueAtDate priceoracle styles mto d a =
case priceoracle (d, acommodity a, mto) of
Nothing -> a
Just (comm, rate) ->
-- setNaturalPrecisionUpTo 8 $ -- XXX force higher precision in case amount appears to be zero ?
@ -102,24 +106,21 @@ amountValueAtDate pricedirectives styles mto d a =
------------------------------------------------------------------------------
-- Market price lookup
tests_priceLookup =
-- From a journal's market price directives, generate a memoising function
-- that efficiently looks up exchange rates between commodities on any date.
-- For best results, you should generate this only once per journal, reusing it
-- across reports if there are more than one (as in compoundBalanceCommand).
journalPriceOracle :: Journal -> PriceOracle
journalPriceOracle Journal{jpricedirectives} =
-- traceStack "journalPriceOracle" $
let
d = parsedate
a q c = amount{acommodity=c, aquantity=q}
p date from q to = PriceDirective{pddate=d date, pdcommodity=from, pdamount=a q to}
ps1 = [
p "2000/01/01" "A" 10 "B"
,p "2000/01/01" "B" 10 "C"
,p "2000/01/01" "C" 10 "D"
,p "2000/01/01" "E" 2 "D"
,p "2001/01/01" "A" 11 "B"
]
in tests "priceLookup" [
priceLookup ps1 (d "1999/01/01") "A" Nothing `is` Nothing
,priceLookup ps1 (d "2000/01/01") "A" Nothing `is` Just ("B",10)
,priceLookup ps1 (d "2000/01/01") "B" (Just "A") `is` Just ("A",0.1)
,priceLookup ps1 (d "2000/01/01") "A" (Just "E") `is` Just ("E",500)
]
pricesatdate =
memo $
pricesAtDate jpricedirectives
in
memo $
uncurry3 $
priceLookup pricesatdate
-- | Given a list of price directives in parse order, find the market
-- value at the given date of one unit of a given source commodity, in
@ -152,16 +153,13 @@ tests_priceLookup =
-- prices can be found, or the source commodity and the valuation
-- commodity are the same, returns Nothing.
--
-- A 'PriceGraph' is built each time this is called, which is probably
-- wasteful when looking up multiple prices on the same day; it could
-- be built at a higher level, or memoised.
--
priceLookup :: [PriceDirective] -> Day -> CommoditySymbol -> Maybe CommoditySymbol -> Maybe (CommoditySymbol, Quantity)
priceLookup pricedirectives d from mto =
priceLookup :: (Day -> PriceGraph) -> Day -> CommoditySymbol -> Maybe CommoditySymbol -> Maybe (CommoditySymbol, Quantity)
priceLookup pricesatdate d from mto =
-- trace ("priceLookup ("++show d++", "++show from++", "++show 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, prDeclaredPairs=dps} = pricesAtDate pricedirectives d
PriceGraph{prGraph=g, prNodemap=m, prDeclaredPairs=dps} = pricesatdate d
fromnode = node m from
mto' = mto <|> mdefaultto
where
@ -195,6 +193,26 @@ priceLookup pricedirectives d from mto =
-- log a message and a Maybe Quantity, hiding Just/Nothing and limiting decimal places
dbg msg = dbg4With (((msg++": ")++) . maybe "" (show . roundTo 8))
tests_priceLookup =
let
d = parsedate
a q c = amount{acommodity=c, aquantity=q}
p date from q to = PriceDirective{pddate=d date, pdcommodity=from, pdamount=a q to}
ps1 = [
p "2000/01/01" "A" 10 "B"
,p "2000/01/01" "B" 10 "C"
,p "2000/01/01" "C" 10 "D"
,p "2000/01/01" "E" 2 "D"
,p "2001/01/01" "A" 11 "B"
]
pricesatdate = pricesAtDate ps1
in tests "priceLookup" [
priceLookup pricesatdate (d "1999/01/01") "A" Nothing `is` Nothing
,priceLookup pricesatdate (d "2000/01/01") "A" Nothing `is` Just ("B",10)
,priceLookup pricesatdate (d "2000/01/01") "B" (Just "A") `is` Just ("A",0.1)
,priceLookup pricesatdate (d "2000/01/01") "A" (Just "E") `is` Just ("E",500)
]
------------------------------------------------------------------------------
-- Building the price graph (network of commodity conversions) on a given day.
@ -202,7 +220,9 @@ priceLookup pricedirectives d from mto =
-- graph of all prices in effect on a given day, allowing efficient
-- lookup of exchange rates between commodity pairs.
pricesAtDate :: [PriceDirective] -> Day -> PriceGraph
pricesAtDate pricedirectives d = PriceGraph{prGraph=g, prNodemap=m, prDeclaredPairs=dps}
pricesAtDate pricedirectives d =
-- trace ("pricesAtDate ("++show d++")") $
PriceGraph{prGraph=g, prNodemap=m, prDeclaredPairs=dps}
where
declaredprices = latestPriceForEachPairOn pricedirectives d
@ -212,7 +232,6 @@ pricesAtDate pricedirectives d = PriceGraph{prGraph=g, prNodemap=m, prDeclaredPa
map marketPriceReverse declaredprices \\ declaredprices
-- build the graph and associated node map
-- (g :: Gr CommoditySymbol Quantity, m :: NodeMap CommoditySymbol) =
(g, m) =
mkMapGraph
(dbg5 "g nodelabels" $ sort allcomms) -- this must include all nodes mentioned in edges
@ -237,7 +256,6 @@ latestPriceForEachPairOn pricedirectives d =
map priceDirectiveToMarketPrice $
filter ((<=d).pddate) pricedirectives -- consider only price declarations up to the valuation date
priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
priceDirectiveToMarketPrice PriceDirective{..} =
MarketPrice{ mpdate = pddate

2
hledger-lib/Hledger/Read/Common.hs
View File

@ -552,7 +552,7 @@ modifiedaccountnamep = do
a <- lift accountnamep
return $!
accountNameApplyAliases aliases $
-- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference
-- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference (retest that function)
joinAccountNames parent
a

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

@ -80,11 +80,12 @@ balanceReport ropts@ReportOpts{..} q j@Journal{..} =
accttree = ledgerRootAccount $ ledgerFromJournal q $ journalSelectingAmountFromOpts ropts j
-- For other kinds of valuation, convert the summed amounts to value.
priceoracle = journalPriceOracle j
valuedaccttree = mapAccounts valueaccount accttree
where
valueaccount a@Account{..} = a{aebalance=val aebalance, aibalance=val aibalance}
where
val = maybe id (mixedAmountApplyValuation jpricedirectives styles periodlastday today multiperiod) value_
val = maybe id (mixedAmountApplyValuation priceoracle styles periodlastday today multiperiod) value_
where
periodlastday =
fromMaybe (error' "balanceReport: expected a non-empty journal") $ -- XXX shouldn't happen

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

@ -40,7 +40,8 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} =
datefn = transactionDateFn ropts
styles = journalCommodityStyles j
tvalue t@Transaction{..} = t{tpostings=map pvalue tpostings}
pvalue p = maybe p (postingApplyValuation jpricedirectives styles end today False p) value_
priceoracle = journalPriceOracle j
pvalue p = maybe p (postingApplyValuation priceoracle styles end today False p) value_
where
today = fromMaybe (error' "erValue: ReportOpts today_ is unset so could not satisfy --value=now") today_
end = fromMaybe (postingDate p) mperiodorjournallastday

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

@ -9,6 +9,7 @@ module Hledger.Reports.MultiBalanceReport (
MultiBalanceReport(..),
MultiBalanceReportRow,
multiBalanceReport,
multiBalanceReportWith,
balanceReportFromMultiBalanceReport,
mbrNegate,
mbrNormaliseSign,
@ -94,9 +95,16 @@ type ClippedAccountName = AccountName
-- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts
-- (see ReportOpts and CompoundBalanceCommand).
-- hledger's most powerful and useful report, used by the balance
-- command (in multiperiod mode) and by the bs/cf/is commands.
-- command (in multiperiod mode) and (via multiBalanceReport') by the bs/cf/is commands.
multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport
multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
multiBalanceReport ropts q j = multiBalanceReportWith ropts q j (journalPriceOracle j)
-- | A helper for multiBalanceReport. This one takes an extra argument, a
-- PriceOracle to be used for looking up market prices. Commands which
-- run multiple reports (bs etc.) can generate the price oracle just once
-- for efficiency, passing it to each report by calling this function directly.
multiBalanceReportWith :: ReportOpts -> Query -> Journal -> PriceOracle -> MultiBalanceReport
multiBalanceReportWith ropts@ReportOpts{..} q j@Journal{..} priceoracle =
(if invert_ then mbrNegate else id) $
MultiBalanceReport (colspans, sortedrows, totalsrow)
where
@ -252,7 +260,7 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
CumulativeChange -> drop 1 $ scanl (+) 0 changes
HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes
-- The row amounts valued according to --value if needed.
, let val end = maybe id (mixedAmountApplyValuation jpricedirectives styles end today multiperiod) value_
, let val end = maybe id (mixedAmountApplyValuation priceoracle styles end today multiperiod) value_
, let valuedrowbals = dbg1 "valuedrowbals" $ [val periodlastday amt | (amt,periodlastday) <- zip rowbals lastdays]
-- The total and average for the row, and their values.
-- Total for a cumulative/historical report is always zero.

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

@ -99,7 +99,8 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
reportPeriodOrJournalLastDay ropts j
multiperiod = interval_ /= NoInterval
showempty = empty_ || average_
pvalue p end = maybe p (postingApplyValuation jpricedirectives styles end today multiperiod p) value_
priceoracle = journalPriceOracle j
pvalue p end = maybe p (postingApplyValuation priceoracle styles end today multiperiod p) value_
-- Postings, or summary postings with their subperiod's end date, to be displayed.
displayps :: [(Posting, Maybe Day)]
@ -121,7 +122,7 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
-- For --value=end/now/DATE, convert the initial running total/average to value.
startbalvalued = val startbal
where
val = maybe id (mixedAmountApplyValuation jpricedirectives styles daybeforereportstart today multiperiod) value_
val = maybe id (mixedAmountApplyValuation priceoracle styles daybeforereportstart today multiperiod) value_
where
daybeforereportstart = maybe
(error' "postingsReport: expected a non-empty journal") -- XXX shouldn't happen

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

@ -145,12 +145,14 @@ compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportopts_=r
userq = queryFromOpts d ropts'
format = outputFormatFromOpts opts
-- make a CompoundBalanceReport
-- make a CompoundBalanceReport.
-- For efficiency, generate a price oracle here and reuse it with each subreport.
priceoracle = journalPriceOracle j
subreports =
map (\CBCSubreportSpec{..} ->
(cbcsubreporttitle
,mbrNormaliseSign cbcsubreportnormalsign $ -- <- convert normal-negative to normal-positive
compoundBalanceSubreport ropts' userq j cbcsubreportquery cbcsubreportnormalsign
compoundBalanceSubreport ropts' userq j priceoracle cbcsubreportquery cbcsubreportnormalsign
,cbcsubreportincreasestotal
))
cbcqueries
@ -252,14 +254,14 @@ showEndDates es = case es of
-- | Run one subreport for a compound balance command in multi-column mode.
-- This returns a MultiBalanceReport.
compoundBalanceSubreport :: ReportOpts -> Query -> Journal -> (Journal -> Query) -> NormalSign -> MultiBalanceReport
compoundBalanceSubreport ropts@ReportOpts{..} userq j subreportqfn subreportnormalsign = r'
compoundBalanceSubreport :: ReportOpts -> Query -> Journal -> PriceOracle -> (Journal -> Query) -> NormalSign -> MultiBalanceReport
compoundBalanceSubreport ropts@ReportOpts{..} userq j priceoracle subreportqfn subreportnormalsign = r'
where
-- force --empty to ensure same columns in all sections
ropts' = ropts { empty_=True, normalbalance_=Just subreportnormalsign }
-- run the report
q = And [subreportqfn j, userq]
r@(MultiBalanceReport (dates, rows, totals)) = multiBalanceReport ropts' q j
r@(MultiBalanceReport (dates, rows, totals)) = multiBalanceReportWith ropts' q j priceoracle
-- if user didn't specify --empty, now remove the all-zero rows, unless they have non-zero subaccounts
-- in this report
r' | empty_ = r