#if ( __GLASGOW_HASKELL__ < 820 )
#endif
module Chart.Hud
( HudOptions(..)
, hud
, withHud
, Orientation(..)
, Place(..)
, placeOutside
, placeGap
, TickStyle(..)
, precision
, AxisOptions(..)
, defXAxis
, defYAxis
, axis
, TitleOptions(..)
, title
, LegendType(..)
, LegendOptions(..)
, legend
, GridStyle(..)
, GridOptions(..)
, defXGrid
, defYGrid
, gridl
) where
import Chart.Arrow
import Chart.Core
import Chart.Glyph
import Chart.Line
import Chart.Rect
import Chart.Text
import qualified Control.Foldl as L
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 Graphics.SVGFonts
data HudOptions b = HudOptions
{ hudPad :: Double
, hudAxes :: [AxisOptions b]
, hudGrids :: [GridOptions]
, hudTitles :: [(TitleOptions, Text)]
, hudLegends :: [LegendOptions b]
, hudRange :: Maybe (Rect Double)
, hudAspect :: Aspect
, hudCanvas :: RectOptions
}
instance Default (HudOptions b) where
def = HudOptions 1.1 [defXAxis, defYAxis] [] [] []
Nothing sixbyfour clear
hud :: () => HudOptions b -> Chart b
hud (HudOptions p axes grids titles legends mr asp@(Aspect ar@(Ranges ax ay)) can) =
(mconcat $ (\x -> gridl x asp r) <$> grids) <>
L.fold (L.Fold addTitle uptoLegend (pad p)) titles
where
r = fromMaybe one mr
addTitle x (topts, t) =
beside (placeOutside (titlePlace topts)) x (title asp topts t)
addLegend x lopts =
beside (placeOutside (legendPlace lopts)) x $
if 0 == length (legendChartType lopts)
then mempty
else (\x' ->
moveTo (p_ $ pos' (legendAlign lopts) (legendPlace lopts) 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) legends
uptoAxes = L.fold (L.Fold addAxis canvas identity) axes
canvas = rect_ can ar
addAxis x aopts =
case axisOrientation aopts of
Hori -> beside (placeOutside (axisPlace aopts)) x (axis aopts ax rx)
Vert -> beside (placeOutside (axisPlace aopts)) x (axis aopts ay ry)
where
(Ranges rx ry) = fromMaybe one mr
withHud ::
(Foldable f)
=> HudOptions b
-> (Aspect -> Rect Double -> [f (Pair Double)] -> Chart b)
-> [f (Pair Double)]
-> Chart b
withHud opts renderer d =
case hudRange opts of
Nothing ->
renderer (hudAspect opts) (foldMap space d) d <>
hud (opts {hudRange = Just (foldMap space d)})
Just r ->
combine
(hudAspect opts)
[ UChart renderer r d
, UChart
(\asp _ _ -> hud (opts {hudAspect = asp, hudRange = Just r}))
r
[]
]
data Place
= PlaceLeft
| PlaceRight
| PlaceTop
| PlaceBottom
deriving (Eq, Show)
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 Orientation
= Hori
| Vert
data AxisOptions b = AxisOptions
{ axisPad :: Double
, axisOrientation :: Orientation
, axisPlace :: Place
, axisRect :: RectOptions
, axisRectHeight :: Double
, axisMark :: GlyphOptions b
, axisMarkStart :: Double
, axisGap :: Double
, axisLabel :: LabelOptions
, axisTickStyle :: TickStyle
}
defXAxis :: AxisOptions b
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.04
(LabelOptions
(TextOptions 0.08 AlignCenter (withOpacity black 0.6) EvenOdd 0 lin2)
(Pair 0 1)
0.015)
(TickRound 8)
defYAxis :: AxisOptions b
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.04
(LabelOptions
(TextOptions 0.08 AlignCenter (withOpacity black 0.6) EvenOdd 0 lin2)
(Pair 1 0)
0.015)
(TickRound 8)
instance Default (AxisOptions b) where
def = defXAxis
axis :: () => AxisOptions b -> Range Double -> Range Double -> Chart b
axis opts asp r =
mo $
pad (axisPad opts) $
astrut $
centerXY $
atPoints
(pl <$> tickLocations)
((\x -> labelled (axisLabel opts) x (glyph_ (axisMark opts))) <$> tickLabels) `atop`
arect (axisOrientation opts)
where
mo = moveOriginTo (p2 ((lower asp) width asp / 2, 0))
arect Hori =
rect_ (axisRect opts) (Ranges asp (Range 0 (axisRectHeight opts)))
arect Vert =
rect_ (axisRect opts) (Ranges (Range 0 (axisRectHeight opts)) asp)
astrut =
beside (placeOutside (axisPlace opts))
(case axisOrientation opts of
Hori -> strutY (axisGap opts)
Vert -> strutX (axisGap opts))
pl =
let gs = glyphSize (axisMark opts)
in case axisPlace opts of
PlaceBottom ->
\x ->
p2 (x, (0.5 * gs) + axisRectHeight opts + axisMarkStart opts)
PlaceLeft ->
\y ->
p2 ((0.5 * gs) + axisRectHeight opts + axisMarkStart opts, y)
PlaceTop -> \x -> p2 (x, (0.5 * gs) + axisMarkStart opts)
PlaceRight -> \y -> p2 ((0.5 * gs) + axisMarkStart opts, y)
(tickLocations, tickLabels) =
case axisTickStyle opts of
TickNone -> ([], [])
TickRound n -> (project r asp <$> ticks0, precision 0 ticks0)
where ticks0 = gridSensible OuterPos r 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)]
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)
| 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
{ titleText :: TextOptions
, titleAlign :: AlignH
, titlePlace :: Place
, titleGap :: Double
}
instance Default TitleOptions where
def =
TitleOptions
(TextOptions 0.12 AlignCenter (withOpacity black 0.6) EvenOdd 0 lin2)
AlignCenter
PlaceTop
0.04
title :: Aspect -> TitleOptions -> Text -> Chart b
title (Aspect (Ranges aspx aspy)) (TitleOptions textopts a p s) t =
placeGap p s (positioned (pos a p) (text_ (textopts {textAlignH = a}) 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 b
= LegendText TextOptions
| LegendGlyph (GlyphOptions b)
| LegendLine LineOptions
Double
| LegendGLine (GlyphOptions b)
LineOptions
Double
| LegendRect RectOptions
Double
| LegendArrow (ArrowOptions Double)
Double
| LegendPixel RectOptions
Double
data LegendOptions b = LegendOptions
{ legendChartType :: [(LegendType b, Text)]
, legendInnerPad :: Double
, legendInnerSep :: Double
, legendGap :: Double
, legendRowPad :: Double
, legendPlace :: Place
, legendAlign :: AlignH
, legendSep :: Double
, legendRect :: RectOptions
, legendText :: TextOptions
}
instance Default (LegendOptions b) where
def =
LegendOptions
[]
1.1
0.03
0.05
1
PlaceRight
AlignRight
0.02
(RectOptions 0.002 (withOpacity black 0.2) transparent)
(TextOptions 0.07 AlignCenter (withOpacity black 0.63) EvenOdd 0 lin2)
legend :: LegendOptions b -> Chart b
legend opts =
placeGap (legendPlace opts) (legendGap opts) $
bound (legendRect opts) 1 $
pad (legendInnerPad opts) $
centerXY $
vert
(pad (legendRowPad opts))
(intersperse (strutY (legendInnerSep opts)) $
legend__ <$> legendChartType opts)
where
legend__ (LegendText c, t) = text_ c t
legend__ (LegendGlyph c, t) =
hori
identity
[glyph_ c, strutX (legendSep opts), text_ (legendText opts) t]
legend__ (LegendLine c l, t) =
hori
identity
[ oneline c (Pair (Pair 0 0) (Pair l 0))
, strutX (legendSep opts)
, text_ (legendText opts) t
]
legend__ (LegendGLine gc lopts l, t) =
hori
identity
[ glyph_ gc `atop` oneline lopts (Pair (Pair (l) 0) (Pair l 0))
, strutX (legendSep opts)
, text_ (legendText opts) t
]
legend__ (LegendRect c s, t) =
hori
identity
[rect_ c (s *. one), strutX (legendSep opts), text_ (legendText opts) t]
legend__ (LegendArrow c s, t) =
hori
identity
[ arrows c [Arrow zero (s *. one), Arrow (s *. one) zero]
, strutX (legendSep opts)
, text_ (legendText opts) t
]
legend__ (LegendPixel c s, t) =
hori
identity
[rect_ c (s *. one), strutX (legendSep opts), text_ (legendText opts) t]
data GridStyle
= GridNone
| GridRound Pos Int
| GridExact Pos Int
| GridPlaced [Double]
data GridOptions = GridOptions
{ gridOrientation :: Orientation
, gridStyle :: GridStyle
, gridLine :: LineOptions
}
defXGrid :: GridOptions
defXGrid =
GridOptions
Hori
(GridRound OuterPos 10)
(LineOptions 0.002 ublue)
defYGrid :: GridOptions
defYGrid =
GridOptions
Vert
(GridRound OuterPos 10)
(LineOptions 0.002 ublue)
instance Default GridOptions where
def = defXGrid
gridl :: GridOptions -> Aspect -> Rect Double -> Chart b
gridl gopt (Aspect (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 p r0 n
GridExact p n -> project r0 asp0 <$> grid 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)])