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

lib: also infer market prices from transactions, like Ledger (#1239) (WIP)

Browse Source
This commit is contained in:
Simon Michael 2020-05-23 18:19:43 -07:00
parent cbacef21eb
commit e1ddfc3a1b
6 changed files with 166 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
hledger-lib/Hledger/Data/Journal.hs
View File

@ -21,6 +21,7 @@ module Hledger.Data.Journal (
addPeriodicTransaction,
addTransaction,
journalBalanceTransactions,
journalInferMarketPricesFromTransactions,
journalApplyCommodityStyles,
commodityStylesFromAmounts,
journalCommodityStyles,
@ -185,6 +186,7 @@ instance Semigroup Journal where
,jcommodities = jcommodities j1 <> jcommodities j2
,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2
,jpricedirectives = jpricedirectives j1 <> jpricedirectives j2
,jtransactionimpliedmarketprices = jtransactionimpliedmarketprices j1 <> jtransactionimpliedmarketprices j2
,jtxnmodifiers = jtxnmodifiers j1 <> jtxnmodifiers j2
,jperiodictxns = jperiodictxns j1 <> jperiodictxns j2
,jtxns = jtxns j1 <> jtxns j2
@ -210,6 +212,7 @@ nulljournal = Journal {
,jcommodities = M.empty
,jinferredcommodities = M.empty
,jpricedirectives = []
,jtransactionimpliedmarketprices = []
,jtxnmodifiers = []
,jperiodictxns = []
,jtxns = []
@ -1036,6 +1039,32 @@ canonicalStyleFrom ss@(s:_) =
-- case ps of (PriceDirective{pdamount=a}:_) -> Just a
-- _ -> Nothing
-- | Infer transaction-implied market prices from commodity-exchanging
-- transactions, if any. It's best to call this after transactions have
-- been balanced and posting amounts have appropriate prices attached.
journalInferMarketPricesFromTransactions :: Journal -> Journal
journalInferMarketPricesFromTransactions j =
j{jtransactionimpliedmarketprices =
dbg4 "jtransactionimpliedmarketprices" $
mapMaybe postingImpliedMarketPrice $ journalPostings j
}
-- | Make a market price equivalent to this posting's amount's unit
-- price, if any. If the posting amount is multicommodity, only the
-- first commodity amount is considered.
postingImpliedMarketPrice :: Posting -> Maybe MarketPrice
postingImpliedMarketPrice p@Posting{pamount} =
-- convert any total prices to unit prices
case mixedAmountTotalPriceToUnitPrice pamount of
Mixed ( Amount{acommodity=fromcomm, aprice = Just (UnitPrice Amount{acommodity=tocomm, aquantity=rate})} : _) ->
Just MarketPrice {
mpdate = postingDate p
,mpfrom = fromcomm
,mpto = tocomm
,mprate = rate
}
_ -> Nothing
-- | Convert all this journal's amounts to cost using the transaction prices, if any.
-- The journal's commodity styles are applied to the resulting amounts.
journalToCost :: Journal -> Journal

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

@ -471,8 +471,8 @@ data Journal = Journal {
,jdeclaredaccounttypes :: M.Map AccountType [AccountName] -- ^ Accounts whose type has been declared in account directives (usually 5 top-level accounts)
,jcommodities :: M.Map CommoditySymbol Commodity -- ^ commodities and formats declared by commodity directives
,jinferredcommodities :: M.Map CommoditySymbol AmountStyle -- ^ commodities and formats inferred from journal amounts TODO misnamed - jusedstyles
,jpricedirectives :: [PriceDirective] -- ^ All market price declarations (P directives), in parse order (after journal finalisation).
-- These will be converted to a Prices db for looking up prices by date.
,jpricedirectives :: [PriceDirective] -- ^ Declarations of market prices by P directives, in parse order (after journal finalisation)
,jtransactionimpliedmarketprices :: [MarketPrice] -- ^ Market prices implied by transactions, in parse order (after journal finalisation)
,jtxnmodifiers :: [TransactionModifier]
,jperiodictxns :: [PeriodicTransaction]
,jtxns :: [Transaction]

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

@ -31,7 +31,7 @@ import Control.Applicative ((<|>))
import Control.DeepSeq (NFData)
import Data.Data
import Data.Decimal (roundTo)
import Data.Function (on)
import Data.Function ((&), on)
import Data.Graph.Inductive (Gr, Node, NodeMap, mkMapGraph, mkNode, lab, out, sp)
import Data.List
import Data.List.Extra (nubSortBy)
@ -58,17 +58,22 @@ data PriceGraph = PriceGraph {
prGraph :: Gr CommoditySymbol Quantity
-- ^ A directed graph of exchange rates between commodity pairs.
-- Node labels are commodities and edge labels are exchange rates,
-- either explicitly declared (preferred) or inferred by reversing a declared rate.
-- which were either:
-- declared by P directives,
-- implied by transaction prices,
-- inferred by reversing a declared rate,
-- or inferred by reversing a transaction-implied rate.
-- There will be at most one edge between each directed pair of commodities,
-- eg there can be one USD->EUR and one EUR->USD.
,prNodemap :: NodeMap CommoditySymbol
-- ^ Mapping of graph node ids to commodity symbols.
,prDeclaredPairs :: [(Node,Node)]
-- ^ Which of the edges in this graph are declared rates,
-- rather than inferred reverse rates.
-- A bit ugly. We could encode this in the edges,
-- but those have to be Real for shortest path finding,
-- so we'd have to transform them all first.
,prDefaultValuationCommodities :: M.Map CommoditySymbol CommoditySymbol
-- ^ The default valuation commodity for each source commodity.
-- These are used when a valuation commodity is not specified
-- (-V). They are the destination commodity of the latest
-- (declared or transaction-implied, but not reverse) each
-- source commodity's latest market price (on the date of this
-- graph).
}
deriving (Show,Generic)
@ -184,17 +189,18 @@ amountValueAtDate priceoracle styles mto d a =
------------------------------------------------------------------------------
-- Market price lookup
-- 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).
-- From a journal's directive-declared and transaction-implied market
-- prices, generate a memoising function that efficiently looks up
-- exchange rates between commodities on any date. For best performance,
-- 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} =
journalPriceOracle Journal{jpricedirectives, jtransactionimpliedmarketprices} =
-- traceStack "journalPriceOracle" $
let
pricesatdate =
memo $
pricesAtDate jpricedirectives
pricesAtDate jpricedirectives jtransactionimpliedmarketprices
in
memo $
uncurry3 $
@ -205,21 +211,32 @@ journalPriceOracle Journal{jpricedirectives} =
-- a different specified valuation commodity, or a default valuation
-- commodity.
--
-- When the valuation commodity is specified, this looks for, in order:
-- When the valuation commodity is specified, this looks for an
-- exchange rate (market price) calculated in any of the following
-- ways, in order of preference:
--
-- - a price declaration giving the exchange rate from source
-- commodity to valuation commodity ("declared price").
-- 1. a declared market price (DMP) - a P directive giving the
-- exchange rate from source commodity to valuation commodity
--
-- - a price declaration from valuation to source commodity, which
-- gets inverted ("reverse price").
-- 2. a transaction-implied market price (TMP) - a market price
-- equivalent to the transaction price used in the latest
-- transaction from source commodity to valuation commodity
-- (on or before the valuation date)
--
-- - the shortest chain of prices (declared or reverse) leading from
-- source commodity to valuation commodity, which gets collapsed
-- into a single synthetic exchange rate ("indirect price").
-- 3. a reverse declared market price (RDMP) - calculated by inverting
-- a DMP
--
-- 4. a reverse transaction-implied market price (RTMP) - calculated
-- by inverting a TMP
--
-- 5. an indirect market price (IMP) - calculated by combining the
-- shortest chain of market prices (any of the above types) leading
-- from source commodity to valuation commodity.
--
-- When the valuation commodity is not specified, this looks for the
-- latest applicable declared price, and converts to the commodity
-- mentioned in that price (the default valuation commodity).
-- latest applicable declared or transaction-implied price, and
-- converts to the commodity mentioned in that price (the default
-- valuation commodity).
--
-- Note this default valuation commodity can vary across successive
-- calls for different dates, since it depends on the price
@ -237,17 +254,12 @@ priceLookup pricesatdate 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, prDeclaredPairs=dps} = pricesatdate d
PriceGraph{prGraph=g, prNodemap=m, prDefaultValuationCommodities=defaultdests} = pricesatdate d
fromnode = node m from
mto' = mto <|> mdefaultto
where
-- If to is unspecified, try to pick a default valuation commodity from declared prices (only).
-- XXX how to choose ? Take lowest sorted ?
-- Take first, hoping current order is useful ? <-
-- Keep parse order in label and take latest parsed ?
mdefaultto =
dbg4 ("default valuation commodity for "++T.unpack from) $
headMay [t | (f,t,_) <- out g fromnode, (f,t) `elem` dps] >>= lab g
mdefaultto = dbg4 ("default valuation commodity for "++T.unpack from) $
M.lookup from defaultdests
in
case mto' of
Nothing -> Nothing
@ -283,7 +295,7 @@ tests_priceLookup =
,p "2000/01/01" "E" 2 "D"
,p "2001/01/01" "A" 11 "B"
]
pricesatdate = pricesAtDate ps1
pricesatdate = pricesAtDate ps1 []
in test "priceLookup" $ do
priceLookup pricesatdate (d "1999/01/01") "A" Nothing @?= Nothing
priceLookup pricesatdate (d "2000/01/01") "A" Nothing @?= Just ("B",10)
@ -293,20 +305,21 @@ tests_priceLookup =
------------------------------------------------------------------------------
-- Building the price graph (network of commodity conversions) on a given day.
-- | Convert a list of market price directives in parse order to a
-- 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 =
-- | Convert a list of market price directives in parse order, and a
-- list of transaction-implied market prices in parse order, to a
-- graph of the effective exchange rates between commodity pairs on
-- the given day.
pricesAtDate :: [PriceDirective] -> [MarketPrice] -> Day -> PriceGraph
pricesAtDate pricedirectives transactionimpliedmarketprices d =
-- trace ("pricesAtDate ("++show d++")") $
PriceGraph{prGraph=g, prNodemap=m, prDeclaredPairs=dps}
PriceGraph{prGraph=g, prNodemap=m, prDefaultValuationCommodities=defaultdests}
where
declaredprices = latestPriceForEachPairOn pricedirectives d
declaredandimpliedprices = latestPriceForEachPairOn pricedirectives transactionimpliedmarketprices d
-- infer additional reverse prices where not already declared
-- infer any additional reverse prices not already declared or implied
reverseprices =
dbg5 "reverseprices" $
map marketPriceReverse declaredprices \\ declaredprices
map marketPriceReverse declaredandimpliedprices \\ declaredandimpliedprices
-- build the graph and associated node map
(g, m) =
@ -315,23 +328,37 @@ pricesAtDate pricedirectives d =
(dbg5 "g edges" $ [(mpfrom, mpto, mprate) | MarketPrice{..} <- prices])
:: (Gr CommoditySymbol Quantity, NodeMap CommoditySymbol)
where
prices = declaredprices ++ reverseprices
prices = declaredandimpliedprices ++ reverseprices
allcomms = map mpfrom prices
-- remember which edges correspond to declared prices
dps = [(node m mpfrom, node m mpto) | MarketPrice{..} <- declaredprices ]
-- save the forward prices' destinations as the default valuation
-- commodity for those source commodities
defaultdests = M.fromList [(mpfrom,mpto) | MarketPrice{..} <- declaredandimpliedprices]
-- From a list of price directives in parse order, get the latest
-- price declared on or before date d for each commodity pair.
latestPriceForEachPairOn :: [PriceDirective] -> Day -> [MarketPrice]
latestPriceForEachPairOn pricedirectives d =
-- From a list of price directives in parse order, and a list of
-- transaction-implied market prices in parse order, get the effective
-- price on the given date for each commodity pair. That is, the
-- latest declared or transaction-implied price dated on or before
-- that day, with declared prices taking precedence.
latestPriceForEachPairOn :: [PriceDirective] -> [MarketPrice] -> Day -> [MarketPrice]
latestPriceForEachPairOn pricedirectives transactionimpliedmarketprices d =
dbg5 "latestPriceForEachPairOn" $
nubSortBy (compare `on` (\(MarketPrice{..})->(mpfrom,mpto))) $ -- keep only the first (ie newest and latest parsed) price for each pair
map snd $ -- discard the parse order label
sortBy (flip compare `on` (\(parseorder,mp)->(mpdate mp,parseorder))) $ -- sort with newest dates and latest parse order first
zip [1..] $ -- label with parse order
map priceDirectiveToMarketPrice $
filter ((<=d).pddate) pricedirectives -- consider only price declarations up to the valuation date
let
-- consider only declarations/transactions before the valuation date
declaredprices = map priceDirectiveToMarketPrice $ filter ((<=d).pddate) pricedirectives
transactionimpliedmarketprices' = filter ((<=d).mpdate) transactionimpliedmarketprices
-- label the items with their precedence and then their parse order
declaredprices' = [(1, i, p) | (i,p) <- zip [1..] declaredprices]
transactionimpliedmarketprices'' = [(0, i, p) | (i,p) <- zip [1..] transactionimpliedmarketprices']
in
-- combine
declaredprices' ++ transactionimpliedmarketprices''
-- sort by newest date then highest precedence then latest 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 and latest parsed) price for each pair
& nubSortBy (compare `on` (\(MarketPrice{..})->(mpfrom,mpto)))
priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
priceDirectiveToMarketPrice PriceDirective{..} =

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

@ -290,6 +290,8 @@ parseAndFinaliseJournal' parser iopts f txt = do
--
-- - check balance assertions if enabled.
--
-- - infer transaction-implied market prices from transaction prices
--
journalFinalise :: InputOpts -> FilePath -> Text -> Journal -> ExceptT String IO Journal
journalFinalise iopts f txt pj = do
t <- liftIO getClockTime
@ -305,23 +307,25 @@ journalFinalise iopts f txt pj = do
& journalAddFile (f, txt) -- save the file path and content
& journalSetLastReadTime t -- save the last read time
& journalReverse -- convert all lists to parse order
& if not (auto_ iopts) || null (jtxnmodifiers pj)
then
-- Auto postings are not active.
-- Balance all transactions and maybe check balance assertions.
journalBalanceTransactions (not $ ignore_assertions_ iopts)
else \j -> do -- Either monad
-- Auto postings are active.
-- Balance all transactions without checking balance assertions,
j' <- journalBalanceTransactions False j
-- then add the auto postings
-- (Note adding auto postings after balancing means #893b fails;
-- adding them before balancing probably means #893a, #928, #938 fail.)
let j'' = journalModifyTransactions j'
-- then apply commodity styles once more, to style the auto posting amounts. (XXX inefficient ?)
j''' <- journalApplyCommodityStyles j''
-- then check balance assertions.
journalBalanceTransactions (not $ ignore_assertions_ iopts) j'''
& (if not (auto_ iopts) || null (jtxnmodifiers pj)
then
-- Auto postings are not active.
-- Balance all transactions and maybe check balance assertions.
journalBalanceTransactions (not $ ignore_assertions_ iopts)
else \j -> do -- Either monad
-- Auto postings are active.
-- Balance all transactions without checking balance assertions,
j' <- journalBalanceTransactions False j
-- then add the auto postings
-- (Note adding auto postings after balancing means #893b fails;
-- adding them before balancing probably means #893a, #928, #938 fail.)
let j'' = journalModifyTransactions j'
-- then apply commodity styles once more, to style the auto posting amounts. (XXX inefficient ?)
j''' <- journalApplyCommodityStyles j''
-- then check balance assertions.
journalBalanceTransactions (not $ ignore_assertions_ iopts) j'''
)
& fmap journalInferMarketPricesFromTransactions -- infer market prices from commodity-exchanging transactions
setYear :: Year -> JournalParser m ()
setYear y = modify' (\j -> j{jparsedefaultyear=Just y})

6
tests/journal/valuation.test
View File

@ -76,9 +76,9 @@ $ hledger -f- bal -N -V -e 3000/2
D 1000.00 H ; declare a default commodity named H
P 2015/08/14 EEEE 41.66 ; default commodity H is used for these market prices
P 2015/08/14 FFFF 74.62
P 2015/08/14 GGGG 32.39
P 2015/08/15 EEEE 41.66 ; default commodity H is used for these market prices
P 2015/08/15 FFFF 74.62
P 2015/08/15 GGGG 32.39
2015/08/15
a 2.4120 EEEE @@ 100 ; default commodity H is used for these transaction prices

29
tests/journal/valuation2.test
View File

@ -221,3 +221,32 @@ P 2002/01/01 A 2 B
# was inclusive.
$ hledger -f- bal -N -V -e 2002-01-01
1 B a
# Test market prices inferred from transactions, as in Ledger.
<
2020-01-01
(assets:stock) 1 TSLA @ $500
2020-03-01
(assets:stock) 1 TSLA @ $500
P 2020-03-01 TSLA $600
2020-05-01
(assets:stock) 1 TSLA @ $800
# 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
# 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
# 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