{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE CPP #-}
#if ( __GLASGOW_HASKELL__ < 820 )
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Chart.Bar
( BarOptions(..)
, BarValueAcc(..)
, BarData(..)
, barDataLowerUpper
, barRange
, barChart
) where
import Chart.Core
import Chart.Data
import Chart.Hud
import Chart.Rect
import qualified Control.Foldl as L
import Data.Colour.Palette.ColorSet
import Data.Generics.Product
import Diagrams.Prelude hiding (Additive, Color, D, zero, (<>))
import NumHask.Prelude
import NumHask.Range
import NumHask.Rect
import NumHask.Space
data BarValueAcc
= BarValueSeparate
| BarValueAccumulate
deriving (Show, Generic)
data BarOptions = BarOptions
{ rectOptions :: [RectOptions]
, outerGap :: Double
, innerGap :: Double
, displayValues :: Bool
, accumulateValues :: BarValueAcc
, orientation :: Orientation
, hudOptions :: HudOptions
} deriving (Show, Generic)
instance Default BarOptions where
def =
BarOptions
((\x -> RectOptions 0.002 ugrey (d3Colors1 x `withOpacity` 0.5)) <$>
[0 .. 10])
0.1
zero
True
BarValueSeparate
Hori
def
data BarData = BarData
{ barData :: [[Double]]
, barRowLabels :: Maybe [Text]
, barColumnLabels :: Maybe [Text]
} deriving (Show, Generic)
barRects ::
BarOptions
-> [[Double]]
-> [[Rect Double]]
barRects (BarOptions _ ogap igap _ add orient _) bs = rects'' orient
where
rects'' Hori = rects'
rects'' Vert = fmap rectTrans <$> rects'
rects' = zipWith batSet [zero ..] (barDataLowerUpper add bs)
batSet z ys =
zipWith
(\x (yl, yh) ->
abs
(Rect
(x + ogap + z * bstep)
(x + ogap + z * bstep + bstep - igap')
yl
yh))
[zero ..]
ys
n = fromIntegral (length bs)
bstep = (one - (one + one) * ogap + (n - one) * igap') / n
igap' = igap * (one - (one + one) * ogap)
barDataLowerUpper :: BarValueAcc -> [[Double]] -> [[(Double, Double)]]
barDataLowerUpper add bs =
case add of
BarValueSeparate -> fmap (\x -> (zero, x)) <$> bs
BarValueAccumulate -> accBarData bs
where accBarData [] = []
accBarData (x:xs) =
L.fold
(L.Fold
(\(acc, res) a ->
let acc' = zipWith (+) acc a
in (acc', zip acc acc' : res))
(x, [(\x' -> (zero, x')) <$> x])
(reverse . snd))
xs
barRange ::
[[Double]] -> Rect Double
barRange ys = Rect zero (fromIntegral $ maximum (length <$> ys)) (min zero l) u
where
(Range l u) = foldMap space ys
barChart :: BarOptions -> BarData -> Chart b
barChart bo bd =
rectChart (bo ^. field @"rectOptions") sixbyfour
(barRange (bd ^. field @"barData")) (barRects bo (bd ^. field @"barData"))