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

hledger-lib/Hledger/Data/Journal.hs

@@ -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

hledger-lib/Hledger/Data/Types.hs

@@ -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).
+  ,jpricedirectives       :: [PriceDirective]                       -- ^ Declarations of market prices by P directives, in parse order (after journal finalisation)
-                                                                    --   These will be converted to a Prices db for looking up prices by date.
+  ,jtransactionimpliedmarketprices :: [MarketPrice]                 -- ^ Market prices implied by transactions, in parse order (after journal finalisation)
   ,jtxnmodifiers          :: [TransactionModifier]
   ,jperiodictxns          :: [PeriodicTransaction]
   ,jtxns                  :: [Transaction]

hledger-lib/Hledger/Data/Valuation.hs

@@ -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)]
+  ,prDefaultValuationCommodities :: M.Map CommoditySymbol CommoditySymbol
-    -- ^ Which of the edges in this graph are declared rates,
+    -- ^ The default valuation commodity for each source commodity.
-    --   rather than inferred reverse rates.
+    --   These are used when a valuation commodity is not specified
-    --   A bit ugly. We could encode this in the edges,
+    --   (-V). They are the destination commodity of the latest
-    --   but those have to be Real for shortest path finding,
+    --   (declared or transaction-implied, but not reverse) each
-    --   so we'd have to transform them all first.
+    --   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
+-- From a journal's directive-declared and transaction-implied market
--- that efficiently looks up exchange rates between commodities on any date.
+-- prices, generate a memoising function that efficiently looks up
--- For best results, you should generate this only once per journal, reusing it
+-- exchange rates between commodities on any date. For best performance,
--- across reports if there are more than one (as in compoundBalanceCommand).
+-- 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
+-- 1. a declared market price (DMP) - a P directive giving the
---   commodity to valuation commodity ("declared price").
+--    exchange rate from source commodity to valuation commodity
 --
--- - a price declaration from valuation to source commodity, which
+-- 2. a transaction-implied market price (TMP) - a market price
---   gets inverted ("reverse 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
+-- 3. a reverse declared market price (RDMP) - calculated by inverting
---   source commodity to valuation commodity, which gets collapsed
+--    a DMP
---   into a single synthetic exchange rate ("indirect price").
+--
+-- 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
+-- latest applicable declared or transaction-implied price, and
--- mentioned in that price (the default valuation commodity).
+-- 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).
+        mdefaultto = dbg4 ("default valuation commodity for "++T.unpack from) $
-        -- XXX how to choose ? Take lowest sorted ?
+                     M.lookup from defaultdests
-        -- 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
   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
+-- | Convert a list of market price directives in parse order, and a
--- graph of all prices in effect on a given day, allowing efficient
+-- list of transaction-implied market prices in parse order, to a
--- lookup of exchange rates between commodity pairs.
+-- graph of the effective exchange rates between commodity pairs on
-pricesAtDate :: [PriceDirective] -> Day -> PriceGraph
+-- the given day.
-pricesAtDate pricedirectives d =
+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
+    -- save the forward prices' destinations as the default valuation
-    dps = [(node m mpfrom, node m mpto) | MarketPrice{..} <- declaredprices ]
+    -- commodity for those source commodities
+    defaultdests = M.fromList [(mpfrom,mpto) | MarketPrice{..} <- declaredandimpliedprices]
 
--- From a list of price directives in parse order, get the latest
+-- From a list of price directives in parse order, and a list of
--- price declared on or before date d for each commodity pair.
+-- transaction-implied market prices in parse order, get the effective
-latestPriceForEachPairOn :: [PriceDirective] -> Day -> [MarketPrice]
+-- price on the given date for each commodity pair. That is, the
-latestPriceForEachPairOn pricedirectives d =
+-- 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
+  let
-  map snd $  -- discard the parse order label
+    -- consider only declarations/transactions before the valuation date
-  sortBy (flip compare `on` (\(parseorder,mp)->(mpdate mp,parseorder))) $  -- sort with newest dates and latest parse order first
+    declaredprices = map priceDirectiveToMarketPrice $ filter ((<=d).pddate) pricedirectives
-  zip [1..] $  -- label with parse order
+    transactionimpliedmarketprices' = filter ((<=d).mpdate) transactionimpliedmarketprices
-  map priceDirectiveToMarketPrice $
+    -- label the items with their precedence and then their parse order
-  filter ((<=d).pddate) pricedirectives  -- consider only price declarations up to the valuation date
+    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{..} =

hledger-lib/Hledger/Read/Common.hs

@@ -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)
+      & (if not (auto_ iopts) || null (jtxnmodifiers pj)
-        then
+         then
-          -- Auto postings are not active.
+           -- Auto postings are not active.
-          -- Balance all transactions and maybe check balance assertions.
+           -- Balance all transactions and maybe check balance assertions.
-          journalBalanceTransactions (not $ ignore_assertions_ iopts)
+           journalBalanceTransactions (not $ ignore_assertions_ iopts)
-        else \j -> do  -- Either monad
+         else \j -> do  -- Either monad
-          -- Auto postings are active.
+           -- Auto postings are active.
-          -- Balance all transactions without checking balance assertions,
+           -- Balance all transactions without checking balance assertions,
-          j' <- journalBalanceTransactions False j
+           j' <- journalBalanceTransactions False j
-          -- then add the auto postings
+           -- then add the auto postings
-          -- (Note adding auto postings after balancing means #893b fails;
+           -- (Note adding auto postings after balancing means #893b fails;
-          -- adding them before balancing probably means #893a, #928, #938 fail.)
+           -- adding them before balancing probably means #893a, #928, #938 fail.)
-          let j'' = journalModifyTransactions j'
+           let j'' = journalModifyTransactions j'
-          -- then apply commodity styles once more, to style the auto posting amounts. (XXX inefficient ?)
+           -- then apply commodity styles once more, to style the auto posting amounts. (XXX inefficient ?)
-          j''' <- journalApplyCommodityStyles j''
+           j''' <- journalApplyCommodityStyles j''
-          -- then check balance assertions.
+           -- then check balance assertions.
-          journalBalanceTransactions (not $ ignore_assertions_ iopts) j'''
+           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})

tests/journal/valuation.test

@@ -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/15 EEEE  41.66   ; default commodity H is used for these market prices
-P 2015/08/14 FFFF  74.62
+P 2015/08/15 FFFF  74.62
-P 2015/08/14 GGGG  32.39
+P 2015/08/15 GGGG  32.39
 
 2015/08/15
     a  2.4120 EEEE @@ 100  ; default commodity H is used for these transaction prices

tests/journal/valuation2.test

@@ -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