{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE CPP #-}
#if ( __GLASGOW_HASKELL__ < 820 )
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Chart.Hud
( HudOptions(..)
, hud
, withHud
, withHud_
, placeOutside
, placeGap
, TickStyle(..)
, precision
, AxisOptions(..)
, defXAxis
, defYAxis
, axis
, AutoOptions(..)
, adjustAxis
, axisSane
, computeTicks
, TitleOptions(..)
, title
, LegendType(..)
, LegendOptions(..)
, legend
, GridStyle(..)
, GridOptions(..)
, GridPos(..)
, gridPos
, defXGrid
, defYGrid
, gridl
) where
import Chart.Arrow
import Chart.Core
import Chart.Glyph
import Chart.Line (LineOptions(..), lines, oneline)
import Chart.Rect
import Chart.Text
import qualified Control.Foldl as L
import Data.Generics.Product
import Data.List (nub)
import Data.Ord (max)
import Data.Scientific
import Diagrams.Prelude
hiding (Color, D, (*.), (<>), project, width, zero, (<>))
import qualified Diagrams.TwoD.Size as D
import Formatting
import NumHask.Pair
import NumHask.Prelude hiding (max)
import NumHask.Range
import NumHask.Rect
import NumHask.Space
import Diagrams.Backend.SVG (SVG)
data HudOptions = HudOptions
{ outerPad :: Double
, axes :: [AxisOptions]
, grids :: [GridOptions]
, titles :: [(TitleOptions, Text)]
, legends :: [LegendOptions]
, canvas :: RectOptions
} deriving (Show, Generic)
instance Default HudOptions where
def = HudOptions 1.1 [defXAxis, defYAxis] [] [] [] clear
hud :: () => HudOptions -> Rect Double -> Rect Double -> Chart b
hud (HudOptions p as gs ts ls can) asp@(Ranges ax ay) r@(Ranges rx ry) =
mconcat ((\x -> gridl x asp r) <$> gs) <>
L.fold (L.Fold addTitle uptoLegend (pad p)) ts
where
addTitle x (topts, t) =
beside (placeOutside (topts ^. field @"place")) x (title asp topts t)
addLegend x lopts =
beside (placeOutside (lopts ^. field @"place")) x $
case length (lopts ^. field @"chartType") of
0 -> mempty
_ -> (\x' ->
moveTo
(p_ $ pos' (lopts ^. field @"align")
(lopts ^. field @"place") x') x') $
legend lopts
pos' AlignCenter _ _ = Pair 0 0
pos' AlignLeft PlaceTop x = Pair (lower ax - 0.5 * D.width x) 0
pos' AlignLeft PlaceBottom x = Pair (lower ax - 0.5 * D.width x) 0
pos' AlignLeft PlaceLeft x = Pair 0 (lower ay - 0.5 * D.height x)
pos' AlignLeft PlaceRight x = Pair 0 (upper ay - 0.5 * D.height x)
pos' AlignRight PlaceTop x = Pair (upper ax + 0.5 * D.width x) 0
pos' AlignRight PlaceBottom x = Pair (upper ax + 0.5 * D.width x) 0
pos' AlignRight PlaceLeft x = Pair 0 (upper ay + 0.5 * D.height x)
pos' AlignRight PlaceRight x = Pair 0 (lower ay + 0.5 * D.height x)
uptoLegend = L.fold (L.Fold addLegend uptoAxes identity) ls
uptoAxes = L.fold (L.Fold addAxis canvas' identity) as
canvas' = rect_ can asp
addAxis x aopts =
case aopts ^. field @"orientation" of
Hori -> beside (placeOutside (aopts ^. field @"place")) x (axis aopts ax rx)
Vert -> beside (placeOutside (aopts ^. field @"place")) x (axis aopts ay ry)
withHud ::
HudOptions
-> Rect Double
-> Rect Double
-> (Rect Double -> Rect Double -> [f (Pair Double)] -> Chart b)
-> [f (Pair Double)]
-> Chart b
withHud opts asp r renderer d =
hud opts asp r <>
renderer asp r d
withHud_ ::
(Foldable f)
=> HudOptions
-> Rect Double
-> (Rect Double -> Rect Double -> [f (Pair Double)] -> Chart b)
-> [f (Pair Double)]
-> Chart b
withHud_ opts asp renderer d =
withHud opts asp (foldMap space d) renderer d
placeOutside :: Num n => Place -> V2 n
placeOutside pl =
case pl of
PlaceBottom -> r2 (0, -1)
PlaceTop -> r2 (0, 1)
PlaceLeft -> r2 (-1, 0)
PlaceRight -> r2 (1, 0)
placeGap ::
(Monoid m, Semigroup m, Ord n, Floating n)
=> Place
-> n
-> QDiagram b V2 n m
-> QDiagram b V2 n m
placeGap pl s x = beside (placeOutside pl) (strut' pl s) x
where
strut' PlaceTop = strutY
strut' PlaceBottom = strutY
strut' PlaceLeft = strutX
strut' PlaceRight = strutX
data AxisOptions = AxisOptions
{ outerPad :: Double
, orientation :: Orientation
, place :: Place
, rect :: RectOptions
, rectHeight :: Double
, mark :: GlyphOptions
, markStart :: Double
, gap :: Double
, label :: LabelOptions
, tickStyle :: TickStyle
} deriving (Show, Generic)
defXAxis :: AxisOptions
defXAxis =
AxisOptions
1
Hori
PlaceBottom
(RectOptions 0 transparent (withOpacity black 0.1))
0.02
(GlyphOptions 0.03 transparent (withOpacity black 0.6) 0.005 (VLine 1.0))
0
0.04
(LabelOptions
(field @"color" .~ withOpacity black 0.6 $ def)
(Pair 0 -1)
0.015)
(TickRound 8)
defYAxis :: AxisOptions
defYAxis =
AxisOptions
1
Vert
PlaceLeft
(RectOptions 0 transparent (withOpacity black 0.1))
0.02
(GlyphOptions 0.03 transparent (withOpacity black 0.6) 0.005 (HLine 1.0))
0
0.04
(LabelOptions
(field @"color" .~ withOpacity black 0.6 $ def)
(Pair -1 0)
0.015)
(TickRound 8)
instance Default AxisOptions where
def = defXAxis
axis :: () => AxisOptions -> Range Double -> Range Double -> Chart b
axis opts asp r =
mo $
pad (opts ^. field @"outerPad") $
astrut $
atPoints
(pl <$> tickLocations)
((\x -> labelled (opts ^. field @"label") x (glyph_ (opts ^. field @"mark"))) <$> tickLabels)
`atop`
arect (opts ^. field @"orientation" )
where
mo = moveOriginTo (p2 ((-lower asp) - width asp / 2, 0))
arect Hori =
rect_ (opts ^. field @"rect") (Ranges asp (Range 0 (opts ^. field @"rectHeight")))
arect Vert =
rect_ (opts ^. field @"rect") (Ranges (Range 0 (opts ^. field @"rectHeight")) asp)
astrut =
beside (placeOutside (opts ^. field @"place"))
(case opts ^. field @"orientation" of
Hori -> strutY (opts ^. field @"gap")
Vert -> strutX (opts ^. field @"gap"))
pl =
let gs = (opts ^. field @"mark" . field @"size")
in case opts ^. field @"place" of
PlaceBottom ->
\x ->
p2 (x, (-0.5 * gs) + opts ^. field @"rectHeight" + opts ^. field @"markStart")
PlaceLeft ->
\y ->
p2 ((-0.5 * gs) + opts ^. field @"rectHeight" + opts ^. field @"markStart", y)
PlaceTop -> \x -> p2 (x, (0.5 * gs) + opts ^. field @"markStart")
PlaceRight -> \y -> p2 ((0.5 * gs) + opts ^. field @"markStart", y)
(tickLocations, tickLabels) = computeTicks opts r asp
data AutoOptions =
AutoOptions
{ maxXRatio :: Double
, maxYRatio :: Double
, angledRatio :: Double
, allowDiagonal :: Bool
} deriving (Show, Generic)
instance Default AutoOptions where
def = AutoOptions 0.08 0.06 0.12 True
adjustAxis :: AutoOptions -> Range Double -> Range Double ->
AxisOptions -> AxisOptions
adjustAxis (AutoOptions mrx ma mry ad) asp r opts = case opts ^. field @"orientation" of
Hori -> case ad of
False -> (field @"label" . field @"text" . field @"size" %~ (/adjustSizeX)) opts
True ->
case adjustSizeX > one of
True -> (field @"label" . field @"text" . field @"rotation" .~ (-45)) .
(field @"label" . field @"text" . field @"alignH" .~ AlignLeft) $
(field @"label" . field @"text" . field @"size" %~ (/adjustSizeA)) opts
False -> (field @"label" . field @"text" . field @"size" %~ (/adjustSizeA)) opts
Vert -> (field @"label" . field @"text" . field @"size" %~ (/adjustSizeY)) opts
where
tickl = snd (computeTicks opts r asp)
maxWidth =
maximum $
(\x ->
D.width
(text_ (opts ^. field @"label" . field @"text") x :: QDiagram SVG V2 Double Any))
<$> tickl
maxHeight =
maximum $
(\x ->
D.height
(text_ (opts ^. field @"label" . field @"text") x :: QDiagram SVG V2 Double Any))
<$> tickl
adjustSizeX = maximum [(maxWidth / (upper asp - lower asp)) / mrx, one]
adjustSizeY = maximum [(maxHeight / (upper asp - lower asp)) / mry, one]
adjustSizeA = maximum [(maxHeight / (upper asp - lower asp)) / ma, one]
axisSane :: () => AutoOptions -> AxisOptions -> Range Double -> Range Double -> Chart b
axisSane ao opts asp r =
axis (adjustAxis ao asp r opts) asp r
computeTicks :: AxisOptions -> Range Double -> Range Double -> ([Double], [Text])
computeTicks opts r asp =
case opts ^. field @"tickStyle" of
TickNone -> ([], [])
TickRound n -> (project r asp <$> ticks0, precision 0 ticks0)
where ticks0 = gridSensible OuterPos r (fromIntegral n)
TickExact n -> (project r asp <$> ticks0, precision 3 ticks0)
where ticks0 = grid OuterPos r n
TickLabels ls ->
( project (Range 0 (fromIntegral $ length ls)) asp <$>
((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls])
, ls)
TickPlaced xs -> (project r asp . fst <$> xs, snd <$> xs)
data TickStyle
= TickNone
| TickLabels [Text]
| TickRound Int
| TickExact Int
| TickPlaced [(Double, Text)]
deriving (Show, Generic)
precision :: Int -> [Double] -> [Text]
precision n0 xs
| foldr max 0 xs < 0.01 = precLoop expt' n0 (fromFloatDigits <$> xs)
| foldr max 0 xs > 100000 = precLoop expt' n0 (fromFloatDigits <$> xs)
| foldr max 0 xs > 1000 =
precLoopInt (const Formatting.commas) n0 (floor <$> xs :: [Integer])
| otherwise = precLoop fixed n0 xs
where
expt' x = scifmt Exponent (Just x)
precLoop f n xs' =
let s = sformat (f n) <$> xs'
in if s == nub s
then s
else precLoop f (n + 1) xs'
precLoopInt f n xs' =
let s = sformat (f n) <$> xs'
in if s == nub s
then s
else precLoopInt f (n + 1) xs'
data TitleOptions = TitleOptions
{ text :: TextOptions
, align :: AlignH
, place :: Place
, gap :: Double
} deriving (Show, Generic)
instance Default TitleOptions where
def =
TitleOptions
(field @"size" .~ 0.12 $
field @"color" .~ withOpacity black 0.6 $
def)
AlignCenter
PlaceTop
0.04
title :: Rect Double -> TitleOptions -> Text -> Chart b
title (Ranges aspx aspy) (TitleOptions textopts a p s) t =
placeGap p s (positioned (pos a p) (text_ ( field @"alignH" .~ a $ textopts) t))
where
pos AlignCenter _ = Pair 0 0
pos AlignLeft PlaceTop = Pair (lower aspx) 0
pos AlignLeft PlaceBottom = Pair (lower aspx) 0
pos AlignLeft PlaceLeft = Pair 0 (lower aspy)
pos AlignLeft PlaceRight = Pair 0 (upper aspy)
pos AlignRight PlaceTop = Pair (upper aspx) 0
pos AlignRight PlaceBottom = Pair (upper aspx) 0
pos AlignRight PlaceLeft = Pair 0 (upper aspy)
pos AlignRight PlaceRight = Pair 0 (lower aspy)
data LegendType
= LegendText TextOptions
| LegendGlyph GlyphOptions
| LegendLine LineOptions
Double
| LegendGLine GlyphOptions
LineOptions
Double
| LegendRect RectOptions
Double
| LegendArrow ArrowOptions
Double
| LegendPixel RectOptions
Double
deriving (Show, Generic)
data LegendOptions = LegendOptions
{ chartType :: [(LegendType, Text)]
, innerPad :: Double
, innerSep :: Double
, gap :: Double
, rowPad :: Double
, place :: Place
, align :: AlignH
, sep :: Double
, canvasRect :: RectOptions
, text :: TextOptions
} deriving (Show, Generic)
instance Default LegendOptions where
def =
LegendOptions
[]
1.1
0.03
0.05
1
PlaceRight
AlignRight
0.02
(RectOptions 0.002 (withOpacity black 0.2) transparent)
(field @"size" .~ 0.07 $
field @"color" .~ withOpacity black 0.63 $
def)
legend :: LegendOptions -> Chart b
legend opts =
placeGap (opts ^. field @"place") (opts ^. field @"gap") $
bound (opts ^. field @"canvasRect") 1 $
pad (opts ^. field @"innerPad") $
centerXY $
vert
(pad (opts ^. field @"rowPad"))
(intersperse (strutY (opts ^. field @"innerSep")) $
legend__ <$> opts ^. field @"chartType")
where
legend__ (LegendText c, t) = text_ c t
legend__ (LegendGlyph c, t) =
hori
identity
[glyph_ c, strutX (opts ^. field @"sep"), text_ (opts ^. field @"text") t]
legend__ (LegendLine c l, t) =
hori
identity
[ oneline c (Pair (Pair 0 0) (Pair l 0))
, strutX (opts ^. field @"sep")
, text_ (opts ^. field @"text") t
]
legend__ (LegendGLine gc lopts l, t) =
hori
identity
[ glyph_ gc `atop` oneline lopts (Pair (Pair (-l) 0) (Pair l 0))
, strutX (opts ^. field @"sep")
, text_ (opts ^. field @"text") t
]
legend__ (LegendRect c s, t) =
hori
identity
[rect_ c (s *. one), strutX (opts ^. field @"sep"), text_ (opts ^. field @"text") t]
legend__ (LegendArrow c s, t) =
hori
identity
[ arrows c [Arrow zero (s *. one), Arrow (s *. one) zero]
, strutX (opts ^. field @"sep")
, text_ (opts ^. field @"text") t
]
legend__ (LegendPixel c s, t) =
hori
identity
[ rect_ c (s *. one)
, strutX (opts ^. field @"sep")
, text_ (opts ^. field @"text") t
]
data GridPos
= GridOuterPos
| GridInnerPos
| GridLowerPos
| GridUpperPos
| GridMidPos
deriving (Show, Generic, Eq)
gridPos :: GridPos -> Pos
gridPos GridOuterPos = OuterPos
gridPos GridInnerPos = InnerPos
gridPos GridLowerPos = LowerPos
gridPos GridUpperPos = UpperPos
gridPos GridMidPos = MidPos
data GridStyle
= GridNone
| GridRound GridPos Int
| GridExact GridPos Int
| GridPlaced [Double]
deriving (Show, Generic)
data GridOptions = GridOptions
{ gridOrientation :: Orientation
, gridStyle :: GridStyle
, gridLine :: LineOptions
} deriving (Show, Generic)
defXGrid :: GridOptions
defXGrid =
GridOptions
Hori
(GridRound GridOuterPos 10)
(LineOptions 0.002 ublue)
defYGrid :: GridOptions
defYGrid =
GridOptions
Vert
(GridRound GridOuterPos 10)
(LineOptions 0.002 ublue)
instance Default GridOptions where
def = defXGrid
gridl :: GridOptions -> Rect Double -> Rect Double -> Chart b
gridl gopt (Ranges aspx aspy) (Ranges rx ry) = ls
where
ls = mconcat $ lines (gridLine gopt) <$> (l1d <$> lineLocations)
lineLocations =
case gridStyle gopt of
GridNone -> []
GridRound p n -> project r0 asp0 <$> gridSensible (gridPos p) r0 (fromIntegral n)
GridExact p n -> project r0 asp0 <$> grid (gridPos p) r0 n
GridPlaced xs -> project r0 asp0 <$> xs
(asp0, r0) =
case gridOrientation gopt of
Vert -> (aspx, rx)
Hori -> (aspy, ry)
l1d =
case gridOrientation gopt of
Hori -> \y -> [Pair (lower aspx) y, Pair (upper aspx) y]
Vert -> \x -> [Pair x (lower aspy), Pair x (upper aspy)]