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

lib: -X/--exchange now supports indirect price chains (#131)

Browse Source 
Adds fgl as a dependency.
This commit is contained in:
Simon Michael 2019-06-10 15:22:29 -07:00
parent 692620180e
commit ce0354ddbe
6 changed files with 206 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -354,12 +354,12 @@ postingApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -
postingApplyValuation prices styles periodend today ismultiperiod p v =
case v of
AtCost Nothing -> postingToCost styles p
AtCost mc -> postingValueAtDate prices mc periodend $ postingToCost styles p
AtEnd mc -> postingValueAtDate prices mc periodend p
AtNow mc -> postingValueAtDate prices mc today p
AtDefault mc | ismultiperiod -> postingValueAtDate prices mc periodend p
AtDefault mc -> postingValueAtDate prices mc today p
AtDate d mc -> postingValueAtDate prices mc d 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
-- | Convert this posting's amount to cost, and apply the appropriate amount styles.
postingToCost :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting
@ -370,8 +370,8 @@ postingToCost styles p@Posting{pamount=a} = p{pamount=mixedAmountToCost styles a
-- using the given market prices.
-- When market prices available on that date are not sufficient to
-- calculate the value, amounts are left unchanged.
postingValueAtDate :: [PriceDirective] -> Maybe CommoditySymbol -> Day -> Posting -> Posting
postingValueAtDate prices mc d p = postingTransformAmount (mixedAmountValueAtDate prices mc d) p
postingValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Posting -> Posting
postingValueAtDate prices styles mc d p = postingTransformAmount (mixedAmountValueAtDate prices styles mc d) p
-- | Apply a transform function to this posting's amount.
postingTransformAmount :: (MixedAmount -> MixedAmount) -> Posting -> Posting

255
hledger-lib/Hledger/Data/Prices.hs
View File

@ -1,7 +1,7 @@
{-|
Find historical market prices (exchange rates) between commodities,
convert amounts to value in various ways.
Convert amounts to some related value in various ways. This involves
looking up historical market prices (exchange rates) between commodities.
-}
@ -11,8 +11,7 @@ convert amounts to value in various ways.
{-# LANGUAGE ScopedTypeVariables #-}
module Hledger.Data.Prices (
Prices
,amountValueAtDate
amountValueAtDate
,amountApplyValuation
,mixedAmountValueAtDate
,mixedAmountApplyValuation
@ -22,8 +21,13 @@ module Hledger.Data.Prices (
where
import Control.Applicative ((<|>))
import Data.Decimal (roundTo)
import Data.Function (on)
import Data.Graph.Inductive (Gr, Node, NodeMap, mkMapGraph, mkNode, lab, out, suc, sp)
import Data.List
import Data.List.Extra
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Safe (headMay)
@ -34,9 +38,6 @@ import Hledger.Data.Amount
import Hledger.Data.Dates (parsedate)
d = parsedate
-- amt c q = nullamt{acommodity=c, aquantity=q}
tests_Prices = tests "Prices" [
tests_priceLookup
]
@ -58,8 +59,8 @@ mixedAmountApplyValuation prices styles periodend today ismultiperiod v (Mixed a
-- valuation date, using the given market prices.
-- When market prices available on that date are not sufficient to
-- calculate the value, amounts are left unchanged.
mixedAmountValueAtDate :: [PriceDirective] -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
mixedAmountValueAtDate prices mc d (Mixed as) = Mixed $ map (amountValueAtDate prices mc d) as
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,
@ -68,12 +69,12 @@ amountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle ->
amountApplyValuation prices styles periodend today ismultiperiod v a =
case v of
AtCost Nothing -> amountToCost styles a
AtCost mc -> amountValueAtDate prices mc periodend $ amountToCost styles a
AtEnd mc -> amountValueAtDate prices mc periodend a
AtNow mc -> amountValueAtDate prices mc today a
AtDefault mc | ismultiperiod -> amountValueAtDate prices mc periodend a
AtDefault mc -> amountValueAtDate prices mc today a
AtDate d mc -> amountValueAtDate prices mc d 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
-- | Find the market value of this amount in the given valuation
-- commodity if any, otherwise the default valuation commodity, at the
@ -82,85 +83,183 @@ amountApplyValuation prices styles periodend today ismultiperiod v a =
-- valuation date.)
-- If the market prices available on that date are not sufficient to
-- calculate this value, the amount is left unchanged.
amountValueAtDate :: [PriceDirective] -> Maybe CommoditySymbol -> Day -> Amount -> Amount
amountValueAtDate pricedirectives mc d a =
case priceLookup pricedirectives d mc (acommodity a) of
Just v -> v{aquantity=aquantity v * aquantity a}
Nothing -> a
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
Nothing -> a
Just (comm, rate) -> styleAmount styles $ amount{acommodity=comm, aquantity=rate * aquantity a}
------------------------------------------------------------------------------
-- Market price lookup, naive version
-- Market price lookup
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"
]
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)
]
-- | Given a list of price directives in parse order, find the market
-- value at the given date of one unit of a given commodity, in a
-- different specified valuation commodity, defaulting to the
-- commodity of the most recent applicable price.
-- This might be slow if there are many price declarations.
-- value at the given date of one unit of a given source commodity, in
-- a different specified valuation commodity, or a default valuation
-- commodity.
--
-- When the valuation commodity is specified, this looks for, in order:
--
-- - a direct price, giving the exchange rate from source commodity to
-- valuation commodity.
-- - a price declaration giving the exchange rate from source
-- commodity to valuation commodity ("declared price").
--
-- - a reverse direct price, giving the exchange rate from valuation
-- commodity to source commodity, which is inverted.
-- - a price declaration from valuation to source commodity, which
-- gets inverted ("reverse price").
--
-- - (TODO: the shortest chain of prices leading from source commodity
-- to valuation commodity, which is collapsed into a single
-- synthetic exchange rate.)
-- - 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").
--
-- When the valuation commodity is not specified, this looks for the
-- latest applicable market price, and converts to the commodity
-- mentioned in that price. Note when valuing amounts over multiple
-- periods, this default valuation commodity may vary, since it
-- depends on the presence and parse order of market price
-- declarations in each period.
-- mentioned in that price (default valuation commodity).
--
-- If no applicable market price or chain of prices can be found, or
-- if the source commodity and the valuation commodity are the same,
-- this returns Nothing.
-- Note when calling this repeatedly for different periods, the
-- default valuation commodity can vary, since it depends on the
-- presence and parse order of market price declarations in each
-- period.
--
priceLookup :: [PriceDirective] -> Day -> Maybe CommoditySymbol -> CommoditySymbol -> Maybe Amount
priceLookup pricedirectives d mto from
| mto == Just from = Nothing
| otherwise = mdirectprice <|> mreverseprice
-- This returns the valuation commodity that was specified or
-- inferred, and the quantity of it that one unit of the source
-- commodity is worth. Or if no applicable market price or chain of
-- prices can be found, or the source commodity and the valuation
-- commodity are the same, returns Nothing.
--
-- A 'Prices' database (price graphs) 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 =
let
-- build a graph of the commodity exchange rates in effect on this day
Prices{prNodemap=m, prDeclaredPrices=g, prWithReversePrices=gr} = pricesAtDate pricedirectives d
fromnode = node m from
-- if to is unspecified, try to find a default valuation commodity based on available prices
mto' = mto <|> mdefaultto
where
-- the default valuation commodity, if we could find one.
-- XXX how to choose ? Take lowest sorted ?
-- Take first, hoping current order is useful ? <-
-- Keep parse order in label and take latest parsed ?
mdefaultto = headMay (suc g fromnode) >>= lab g
in
case mto' of
Nothing -> Nothing
Just to | to==from -> Nothing
Just to ->
-- We have a commodity to convert to. Find the most direct price available,
-- and return it as an amount.
case
-- These seem unnecessary, and we can avoid building one of the graphs
-- mdeclaredprice <|> mreverseprice <|>
mindirectprice of
Nothing -> Nothing
Just q -> Just (to, q)
where
tonode = node m to
-- mdeclaredprice :: Maybe Quantity =
-- dbg ("declared market price "++T.unpack from++"->"++T.unpack to) $
-- nodesEdgeLabel g (fromnode,tonode)
-- mreverseprice :: Maybe Quantity =
-- dbg ("reverse market price "++T.unpack from++"->"++T.unpack to) $
-- ((1 /) <$> nodesEdgeLabel g (tonode,fromnode))
mindirectprice :: Maybe Quantity =
-- Find the shortest path, if any, between from and to.
-- This time use gr which includes both declared and reverse prices.
case sp fromnode tonode gr :: Maybe [Node] of
Nothing -> Nothing
Just nodes ->
dbg ("market price "++intercalate "->" (map T.unpack comms)) $
Just $ product $ pathEdgeLabels gr nodes -- convert to a single exchange rate
where comms = catMaybes $ map (lab g) nodes
-- log a message and a Maybe Quantity, hiding Just/Nothing and limiting decimal places
dbg msg = dbg4With (((msg++": ")++) . maybe "" (show . roundTo 3))
-- | Convert a list of market price directives in parse order to
-- a database of market prices in effect on a given day,
-- allowing efficient lookup of exchange rates between commodity pairs.
pricesAtDate :: [PriceDirective] -> Day -> Prices
pricesAtDate pricedirectives d = Prices{
prNodemap = m
,prDeclaredPrices = g
,prWithReversePrices = gr
}
where
dbgprice lbl =
dbg4With ( ((lbl++" for "++T.unpack from++" at "++show d++": ") ++)
. maybe "none" showAmount )
-- get the latest (before d) declared price for each commodity pair
latestdeclaredprices :: [MarketPrice] =
dbg4 "latestdeclaredprices" $
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
-- and the latest declared or reverse price for each commodity pair
latestdeclaredandreverseprices =
latestdeclaredprices `union` map marketPriceReverse latestdeclaredprices
-- XXX hopefully this prioritises the declared prices, test
allcomms = sort $ map mpfrom latestdeclaredandreverseprices
(g :: PriceGraph, m :: NodeMap CommoditySymbol) = mkMapGraph
(dbg5 "g nodelabels" allcomms) -- this must include all nodes mentioned in edges
(dbg5 "g edges" [(mpfrom, mpto, mprate) | MarketPrice{..} <- latestdeclaredprices])
(gr, _) = mkMapGraph
(dbg5 "gr nodelabels" allcomms) -- this must include all nodes mentioned in edges
(dbg5 "gr edges" [(mpfrom, mpto, mprate) | MarketPrice{..} <- latestdeclaredandreverseprices])
latestfirst = reverse $ sortOn pddate pricedirectives -- sortOn will preserve parse order within the same date I think
priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
priceDirectiveToMarketPrice PriceDirective{..} =
MarketPrice{ mpdate = pddate
, mpfrom = pdcommodity
, mpto = acommodity pdamount
, mprate = aquantity pdamount
}
-- Key to commodity symbols:
-- from - commodity we are converting from (looking up a price for)
-- mto - commodity we want to convert to, or Nothing meaning use default
-- pfrom - commodity that this market price converts from
-- pto - commodity that this market price converts to
-- prPriceDirectives is sorted by date then parse order, reversed. So the
-- first price on or before the valuation date is the effective one.
mdirectprice =
dbgprice "direct market price" $
headMay [pdamount | PriceDirective{pddate, pdcommodity=pfrom, pdamount} <- latestfirst
, let pto = acommodity pdamount
, pddate <= d
, pfrom == from
, maybe True (== pto) mto
]
mreverseprice =
dbgprice "reverse market price" $
headMay [ priceamt
| PriceDirective{pddate, pdcommodity=pfrom, pdamount} <- latestfirst
, let pto = acommodity pdamount
, pddate <= d
, pto == from
, maybe False (== pfrom) mto -- use reverse prices only when target commodity is explicitly specified
, let PriceDirective{pdamount=priceamt} = undefined -- marketPriceInvert mp
]
tests_priceLookup = tests "priceLookup" [
priceLookup [] (d "2019-06-01") Nothing "" `is` Nothing
]
marketPriceReverse :: MarketPrice -> MarketPrice
marketPriceReverse mp@MarketPrice{..} = mp{mpfrom=mpto, mpto=mpfrom, mprate=1/mprate}
------------------------------------------------------------------------------
-- fgl helpers
-- | Look up an existing node by its label in the given NodeMap.
-- (If the node does not exist, a new one will be generated, but not
-- persisted in the nodemap.)
node :: Ord a => NodeMap a -> a -> Node
node m = fst . fst . mkNode m
-- | Convert a valid path from the given graph to the corresponding
-- edge labels. When there are multiple edges between two nodes, the
-- lowest-sorting label is used.
pathEdgeLabels :: (Show b, Ord b) => Gr a b -> [Node] -> [b]
pathEdgeLabels g = map frommaybe . map (nodesEdgeLabel g) . pathEdges
where frommaybe = fromMaybe (error' "pathEdgeLabels: expected no Nothings here")
-- | Convert a path to node pairs representing the path's edges.
pathEdges :: [Node] -> [(Node,Node)]
pathEdges p = [(f,t) | f:t:_ <- tails p]
-- | Get the label of a graph edge from one node to another.
-- When there are multiple such edges, the lowest-sorting label is used.
nodesEdgeLabel :: Ord b => Gr a b -> (Node, Node) -> Maybe b
nodesEdgeLabel g (from,to) = headMay $ sort [l | (_,t,l) <- out g from, t==to]
------------------------------------------------------------------------------

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

@ -27,6 +27,7 @@ import Data.Data
import Data.Decimal
import Data.Default
import Data.Functor (($>))
import Data.Graph.Inductive (Gr, NodeMap)
import Data.List (intercalate)
import Text.Blaze (ToMarkup(..))
--XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html
@ -445,15 +446,17 @@ data MarketPrice = MarketPrice {
instance NFData MarketPrice
-- | A database of the exchange rates between commodity pairs at a given date,
-- organised as maps for efficient lookup.
-- | A graph whose node labels are commodities and edge labels are exchange rates.
type PriceGraph = Gr CommoditySymbol Quantity
-- | A snapshot of the known exchange rates between commodity pairs at a given date.
data Prices = Prices {
prDeclaredPrices ::
M.Map CommoditySymbol -- from commodity A
(M.Map CommoditySymbol -- to commodity B
Quantity) -- exchange rate from A to B (one A is worth this many B)
-- ^ Explicitly declared market prices, as { FROMCOMM : { TOCOMM : RATE } }.
prNodemap :: NodeMap CommoditySymbol
,prDeclaredPrices :: PriceGraph -- ^ Explicitly declared market prices for commodity pairs.
,prWithReversePrices :: PriceGraph -- ^ The above, plus derived reverse prices for any pairs which don't have a declared price.
-- ,prWithIndirectPrices :: PriceGraph -- ^ The above, plus indirect prices found for any pairs which don't have a declared or reverse price.
}
deriving (Show)
-- | What kind of value conversion should be done on amounts ?
-- UI: --value=cost|end|now|DATE[,COMM]

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

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: ac2028674178919d87ff7e06ea16e97e245e92deeb60beb9689c083547cd1a44
-- hash: 89c2a4dadadc88418d53e5b39a17bcc9831b58cf46dbf77c4a5598f6db326cbc
name: hledger-lib
version: 1.14.99
@ -121,6 +121,7 @@ library
, directory
, easytest >=0.2.1 && <0.3
, extra
, fgl >=5.5.3.0
, file-embed >=0.0.10
, filepath
, hashtables >=1.2.3.1
@ -223,6 +224,7 @@ test-suite doctests
, doctest >=0.16
, easytest >=0.2.1 && <0.3
, extra
, fgl >=5.5.3.0
, file-embed >=0.0.10
, filepath
, hashtables >=1.2.3.1
@ -324,6 +326,7 @@ test-suite easytests
, directory
, easytest >=0.2.1 && <0.3
, extra
, fgl >=5.5.3.0
, file-embed >=0.0.10
, filepath
, hashtables >=1.2.3.1

1
hledger-lib/package.yaml
View File

@ -55,6 +55,7 @@ dependencies:
- deepseq
- directory
- easytest >= 0.2.1 && <0.3
- fgl >=5.5.3.0
- file-embed >=0.0.10
- filepath
- hashtables >=1.2.3.1

8
hledger/hledger_options.m4.md
View File

@ -550,9 +550,11 @@ you want.
To select a different valuation commodity: write the commodity symbol
after the valuation type, separated by a comma (eg: **`--value=now,EUR`**).
Currently this will only use market prices leading directly from A to
B, or (after inverting them) prices from B to A;
it does not yet follow chains of market prices.
This will use, in this preferred order:
- declared prices (from source commodity to valuation commodity)
- reverse prices (declared prices from valuation to source commodity, inverted)
- indirect prices (prices calculated from the shortest chain of declared or reverse prices from source to valuation commodity).
#### --value examples