{-# LANGUAGE OverloadedStrings #-}
module ProductMixAuction.Graphics.TQSSDemand
( tqssDemandChart
, demandTQSSLineChart
, normalisedBidsTQSSChart
) where
import Control.Arrow ((***))
import Control.Lens
import Data.List (nub, sortBy)
import Data.Maybe
import Data.Monoid hiding (All)
import Data.Ord (comparing, Down(..))
import qualified Data.Text as T
import Graphics.Plotly.Base hiding (x,y,z,i,j,k)
import Graphics.Plotly.Simple
import ProductMixAuction.Graphics.Types
import ProductMixAuction.LP
import ProductMixAuction.LP.Demand
import ProductMixAuction.LP.TQSS
import ProductMixAuction.Supply
import ProductMixAuction.Types
tqssDemandChart :: Ord bid => AuctionInput bid -> AuctionOutput bid -> [Plotly]
tqssDemandChart i o = case i ^. ac_tqss of
Nothing -> []
Just tqss -> case tqss ^. tqss_type of
TQSSAbsolute atqss -> [demandTQSSLineChart (tqss ^. tqss_fun) atqss (fromMaybe [] (o ^. ao_tqss_points))]
TQSSNormalised -> [normalisedBidsTQSSChart i o (tqss ^. tqss_fun)]
splitGaps :: [T2 Double] -> T2 [T2 Double]
splitGaps [] = ([], [])
splitGaps (xy0 : xys0) = go xy0 xys0
where
go (x0,y0) ((x1,y1) : xys)
| y0 == y1 = ([(x0,y0),(x0,gap)] ++) *** ([(x0,y0),(x1,y1),(x1,gap)] ++) $ go (x1,y1) xys
| otherwise = ((x0,y0) :) *** id $ go (x1,y1) xys
go (x0,y0) [] = ([(x0,y0)], [])
gap :: Double
gap = 0.0/0.0
demandLines :: Color -> T.Text -> [(Units,Double)] -> [Trace]
demandLines c n xs = [solid_t, dots_t]
where
dots_t = linePlot ys & line ?~ (defLine & linecolor ?~ c & dash ?~ Dot)
& name ?~ (n <> " (dotted)")
& mode ?~ [Lines,Markers]
& traceshowlegend ?~ False
& hoverinfo ?~ HoverPlus [HoverX, HoverY]
solid_t = linePlot zs & line ?~ (defLine & linecolor ?~ c & dash ?~ Solid)
& name ?~ n
& mode ?~ [Lines,Markers]
& hoverinfo ?~ HoverNone
(ys, zs) = splitGaps (nub (sortBy (comparing (\ (x,y) -> (x, Down y))) [(_Units x, y) | (x,y) <- xs]))
demandTQSSLineChart :: TQSSTable -> AbsoluteTQSS -> [TQSSPoint] -> Plotly
demandTQSSLineChart t atqss points =
plotly "pma-demand-TQSS" trs
& layout . title ?~ "TQSS and demand"
& layout . xaxis ?~ axis "Auction size"
& layout . yaxis ?~ axis (tqssTypeLabel (TQSSAbsolute atqss))
where
trs = tqssLine max_price t : demandLines lightred "Demand" [(_tqp_demand p, _tqp_price p) | p <- points]
max_price = round (1.1 * max (maybe 0 fromIntegral (maximumOf (traverse.step_price) t))
(fromMaybe 0 (maximumOf (traverse.tqp_price) points)))
tqssLine :: Price -> TQSSTable -> Trace
tqssLine max_price t = linePlot (stepsToPoints max_price t)
& line ?~ (defLine & linecolor ?~ lightblue & dash ?~ Solid)
& name ?~ "Supply"
normalisedBidsTQSSChart :: Ord bid
=> AuctionInput bid -> AuctionOutput bid -> TQSSTable
-> Plotly
normalisedBidsTQSSChart i o t
= plotly "pma-normalised-bids-tqss" [tqssLine max_price t, tr]
& layout . title ?~ "TQSS and (normalised) total demand"
& layout . xaxis ?~ axis "Quantity"
& layout . yaxis ?~ axis "Normalised price"
& layout %~ addFooter ("When some bids are paired, graph of demand is approximate " <>
"for quantities exceeding total actually allocated.")
where
tr = linePlot pts
& line ?~ (defLine & linecolor ?~ lightred)
& name ?~ "Demand"
max_price = round (1.1 * fromIntegral (max (fromMaybe 0 (maximumOf (traverse.step_price) t))
(fromMaybe 0 (maximumOf (traverse._2) pts))) :: Double)
pts = normalisedTotalDemandPoints supply bids ps allocs
supply = i ^. ac_supply
bids = flattenBidders (i ^. ac_bidders)
ps = o ^. ao_prices
allocs = o ^. ao_bid_allocations