{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Chart.Various
(
defaultRender,
xify,
xify',
yify,
yify',
addLineX,
addLineY,
stdLineChart,
stdLines,
lineLegend,
tsAxes,
titlesHud,
gpalette,
gpaletteStyle,
blendMidLineStyles,
quantileChart,
digitChart,
scatterChart,
histChart,
quantileHistChart,
digitPixelChart,
tableChart,
scanChart,
scanHud,
foldScanChart,
scannerChart,
scannersChart,
tsRatesHud,
write',
tryChart,
) where
import Chart
import NumHask.Prelude hiding (fold)
import Control.Lens
import qualified Data.List as List
import Data.Time (UTCTime(..))
import Data.List ((!!))
import Data.Mealy
import NumHask.Space
import qualified Data.HashMap.Strict as HashMap
defaultRender :: SvgOptions -> (HudOptions, [Chart Double]) -> Text
defaultRender svgo (h, c) = renderHudOptionsChart svgo h [] c
taker :: Int -> [a] -> [a]
taker n = reverse . take n . reverse
type Rate = Double
xify :: [Double] -> [Point Double]
xify ys =
zipWith Point [0 ..] ys
xify' :: [Double] -> [XY Double]
xify' ys =
zipWith P [0 ..] ys
yify :: [Double] -> [Point Double]
yify xs =
zipWith Point xs [0 ..]
yify' :: [Double] -> [XY Double]
yify' xs =
zipWith P xs [0 ..]
addLineX :: Double -> LineStyle -> [Chart Double] -> [Chart Double]
addLineX y ls cs = cs <> [l]
where
l = Chart (LineA ls) (PointXY <$> [Point lx y, Point ux y])
(Rect lx ux _ _) = fromMaybe one $ foldRect $ mconcat $ fmap toRect . xys <$> cs
addLineY :: Double -> LineStyle -> [Chart Double] -> [Chart Double]
addLineY x ls cs = cs <> [zeroLine]
where
zeroLine = Chart (LineA ls) (PointXY <$> [Point x ly, Point x uy])
(Rect _ _ ly uy) = fromMaybe one $ foldRect $ mconcat $ fmap toRect . xys <$> cs
stdLineChart :: Double -> [Colour] -> [[Double]] -> [Chart Double]
stdLineChart w p xss =
zipWith
(\c xs -> Chart (LineA (defaultLineStyle & #color .~ c & #width .~ w))
(xify' xs))
p
xss
stdLines :: Double -> [LineStyle]
stdLines w = (\c -> defaultLineStyle & #color .~ c & #width .~ w) <$> palette1
lineLegend :: Double -> [Text] -> [Colour] -> (LegendOptions, [(Annotation, Text)])
lineLegend w rs cs =
( defaultLegendOptions
& #ltext . #size .~ 0.3
& #lplace .~ PlaceBottom
& #legendFrame .~ Just (RectStyle 0.02 (palette1 !! 5) white),
zipWith
(\a r -> (LineA a, r))
((\c -> defaultLineStyle & #color .~ c & #width .~ w) <$> cs)
rs
)
tsAxes :: [UTCTime] -> [AxisOptions]
tsAxes ds =
[ defaultAxisOptions
& #atick . #tstyle .~ TickRound (FormatPrec (Just 3)) 6 TickExtend
& #place .~ PlaceLeft,
defaultAxisOptions & #atick . #tstyle
.~ TickPlaced
( first fromIntegral
<$> makeTickDates PosIncludeBoundaries Nothing 8 ds
)
]
titlesHud :: Text -> Text -> Text -> HudOptions
titlesHud t x y =
defaultHudOptions
& #hudTitles
.~ [ defaultTitle t,
defaultTitle x & #place .~ PlaceBottom & #style . #size .~ 0.08,
defaultTitle y & #place .~ PlaceLeft & #style . #size .~ 0.08
]
gpaletteStyle :: Double -> [GlyphStyle]
gpaletteStyle s = zipWith (\c g -> defaultGlyphStyle & #size .~ s & #color .~ c & #shape .~ fst g & #borderSize .~ snd g) palette1 gpalette
gpalette :: [(GlyphShape, Double)]
gpalette =
[ (CircleGlyph, 0.01 :: Double),
(SquareGlyph, 0.01),
(RectSharpGlyph 0.75, 0.01),
(RectRoundedGlyph 0.75 0.01 0.01, 0.01),
(EllipseGlyph 0.75, 0),
(VLineGlyph 0.005, 0.01),
(HLineGlyph 0.005, 0.01),
(TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), 0.01),
(PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z", 0.01)
]
quantileChart ::
Text ->
[Text] ->
[LineStyle] ->
[AxisOptions] ->
[[Double]] ->
(HudOptions, [Chart Double])
quantileChart title names ls as xs =
(hudOptions, chart')
where
hudOptions =
defaultHudOptions
& #hudTitles .~ [defaultTitle title]
& ( #hudLegend
.~ Just
( defaultLegendOptions
& #ltext . #size .~ 0.1
& #vgap .~ 0.05
& #innerPad .~ 0.2
& #lplace .~ PlaceRight,
legendFromChart names chart'
)
)
& #hudAxes .~ as
chart' =
zipWith (\l c -> Chart (LineA l) c) ls
(zipWith P [0 ..] <$> xs)
blendMidLineStyles :: Int -> Double -> (Colour, Colour) -> [LineStyle]
blendMidLineStyles l w (c1, c2) = lo
where
m = (fromIntegral l - 1) / 2 :: Double
cs = (\x -> 1 - abs (fromIntegral x - m) / m) <$> [0 .. (l - 1)]
bs = (\x -> blend x c1 c2) <$> cs
lo = (\c -> defaultLineStyle & #width .~ w & #color .~ c) <$> bs
digitChart ::
Text ->
[UTCTime] ->
[Double] ->
(HudOptions, [Chart Double])
digitChart title utcs xs =
(hudOptions, [c])
where
hudOptions =
defaultHudOptions
& #hudTitles .~ [defaultTitle title]
& #hudAxes .~ tsAxes utcs
c = Chart (GlyphA (defaultGlyphStyle &
#color .~ Colour 0 0 1 1 &
#shape .~ CircleGlyph & #size .~ 0.01))
(xify' xs)
scatterChart ::
[[Point Double]] ->
[Chart Double]
scatterChart xss = zipWith (\gs xs -> Chart (GlyphA gs) (PointXY <$> xs)) (gpaletteStyle 0.02) xss
histChart ::
Text ->
Maybe [Text] ->
Range Double ->
Int ->
[Double] ->
(HudOptions, [Chart Double])
histChart title names r g xs =
barChart defaultBarOptions barData
& first (#hudTitles .~ [defaultTitle title])
where
barData = BarData [hr] names Nothing
hcuts = grid OuterPos r g
h = fill hcuts xs
hr = (\(Rect x x' _ _) -> (x+x')/2) <$>
makeRects (IncludeOvers (NumHask.Space.width r / fromIntegral g)) h
quantileHistChart ::
Text ->
Maybe [Text] ->
[Double] ->
[Double] ->
(HudOptions, [Chart Double])
quantileHistChart title names qs vs = (hudOptions, [chart'])
where
hudOptions =
defaultHudOptions
& #hudTitles
.~ [defaultTitle title]
& #hudAxes
.~ [ maybe
(defaultAxisOptions & #atick . #tstyle .~
TickRound (FormatPrec (Just 3)) 8 TickExtend)
( \x ->
defaultAxisOptions & #atick . #tstyle
.~ TickPlaced (zip vs x)
)
names
]
chart' = Chart (RectA defaultRectStyle) (RectXY <$> hr)
hr =
zipWith (\(y, w) (x, z) -> Rect x z 0 ((w - y) / (z - x)))
(zip qs (drop 1 qs))
(zip vs (drop 1 vs))
digitPixelChart ::
PixelStyle ->
PixelLegendOptions ->
(Text, Text, Text) ->
[Text] ->
[(Int, Int)] ->
[Chart Double]
digitPixelChart pixelStyle plo ts names ps =
runHud (aspect 1) (hs0 <> hs1) (cs0 <> cs1)
where
l = length names
pts = Point l l
gr :: Rect Double
gr = fromIntegral <$> Rect 0 l 0 l
mapCount = foldl' (\m x -> HashMap.insertWith (+) x 1.0 m) HashMap.empty ps
f :: Point Double -> Double
f (Point x y) = fromMaybe 0 $ HashMap.lookup (fromIntegral (floor x :: Integer), fromIntegral (floor y :: Integer)) mapCount
(hs0, cs0) = makeHud gr (qvqHud ts names)
(cs1, hs1) =
pixelfl
f
(PixelOptions pixelStyle pts gr)
plo
qvqHud :: (Text, Text, Text) -> [Text] -> HudOptions
qvqHud ts labels =
defaultHudOptions
& #hudTitles .~ makeTitles ts
& #hudAxes
.~ [ defaultAxisOptions
& #atick . #tstyle .~ TickPlaced (zip ((0.5 +) <$> [0 ..]) labels)
& #place .~ PlaceLeft,
defaultAxisOptions
& #atick . #tstyle .~ TickPlaced (zip ((0.5 +) <$> [0 ..]) labels)
& #place .~ PlaceBottom
]
makeTitles :: (Text, Text, Text) -> [Title]
makeTitles (t, xt, yt) =
reverse
[ defaultTitle t,
defaultTitle xt & #place .~ PlaceBottom & #style . #size .~ 0.06,
defaultTitle yt & #place .~ PlaceLeft & #style . #size .~ 0.06
]
tableChart :: [[Text]] -> [Chart Double]
tableChart tss = zipWith (\ts x -> Chart (TextA defaultTextStyle ts) (P x <$> take (length ts) [0..])) tss [0..]
scanChart :: (Rate -> Mealy a Double) -> [Rate] -> Int -> [a] -> [Chart Double]
scanChart m rates d xs =
zipWith (\s xs' -> Chart (LineA s) xs')
(stdLines 0.003)
(zipWith P (fromIntegral <$> [d..]) <$> ((\r -> drop d $ scan (m r) xs) <$> rates))
scanHud :: Double -> Text -> [Double] -> HudOptions
scanHud w t rates =
defaultHudOptions &
#hudTitles .~ [ defaultTitle t] &
#hudLegend .~ Just (lineLegend w (("rate = " <>) . show <$> rates) palette1)
foldScanChart :: (Rate -> Mealy a b) -> (Rate -> Mealy b Double) -> [Rate] -> [a] -> [Chart Double]
foldScanChart scan' fold' rates xs =
(: []) $
Chart
(LineA defaultLineStyle)
(zipWith P rates ((\r -> fold (fold' r) $ scan (scan' r) xs) <$> rates))
zeroLineStyle :: LineStyle
zeroLineStyle = defaultLineStyle & #color .~ (palette1!!7) & #width .~ 0.002
scannerChart :: Int -> [Double] -> (Double -> [a] -> [Double]) -> [a] -> [Chart Double]
scannerChart n rs rscan xs =
addLineX 0 zeroLineStyle $
stdLineChart 0.005 palette1 (tsrs n rs rscan xs)
where
tsrs n rs rscan xs = taker n . (`rscan` xs) <$> rs
scannersChart :: Int -> Double -> (Double -> [a] -> [[Double]]) -> [a] -> [Chart Double]
scannersChart n r rscan xs =
addLineX 0 zeroLineStyle $
stdLineChart 0.005 palette1 (tsrs n r rscan xs)
where
tsrs n r rscan xs = taker n <$> (List.transpose $ rscan r xs)
tsRatesHud :: Text -> [Double] -> [UTCTime] -> HudOptions
tsRatesHud title rs ds =
defaultHudOptions
& #hudTitles
.~ [defaultTitle title & #style . #size .~ 0.08]
& #hudLegend
.~ Just (lineLegend 0.001 ((("rate: " <>) . show) <$> rs) palette1)
& #hudAxes .~ tsAxes ds
chartAny :: Text -> Either Text Text
chartAny t = maybe (Left "<html>bad read</html>") Right . head . rights $
[
tryChart t (\xs -> bool
(let (h,c) = barChart defaultBarOptions (BarData [xs] Nothing Nothing) in renderHudOptionsChart defaultSvgOptions h [] c)
(anyLineChart [xs])
(length xs > 10)
),
tryChart t chartList2,
tryChart t (\x -> anyScatterChart [x]),
tryChart t anyScatterChart,
tryChart t anyTextChart,
tryChart t chartText1,
tryChart ("\"" <> t <> "\"") (\x -> renderHudOptionsChart defaultSvgOptions mempty [] [Chart (TextA defaultTextStyle ["\"" <> x <> "\""]) [zero]])
]
chartList2 :: [[Double]] -> Text
chartList2 xss
| (length xss < 4) && (length (xss!!0) < 10) = anyBarChart xss
| all (length xss ==) (length <$> xss) =
anyPixelChart xss
| otherwise = anyLineChart xss
chartText1 :: [Text] -> Text
chartText1 xs
| (length xs < 20) = anyTextChart [xs]
| otherwise = anySingleNamedBarChart (second fromIntegral <$> HashMap.toList mapCount)
where
mapCount = foldl' (\m x -> HashMap.insertWith (+) x (1::Int) m) HashMap.empty xs
anyBarChart :: [[Double]] -> Text
anyBarChart xss = renderHudOptionsChart defaultSvgOptions h [] c
where
(h,c) = barChart defaultBarOptions
(BarData xss
(Just (("row " <>) . show <$> take nx [(0::Int)..]))
(Just (("col " <>) . show <$> take ny [(0::Int)..]))
)
where
nx = length xss
ny = maximum (length <$> xss)
anySingleNamedBarChart :: [(Text, Double)] -> Text
anySingleNamedBarChart xs = renderHudOptionsChart defaultSvgOptions h [] c
where
(h,c) = barChart defaultBarOptions
(BarData [snd <$> xs]
(Just (fst <$> xs))
Nothing
)
anyLineChart :: [[Double]] -> Text
anyLineChart xss =
renderHudOptionsChart defaultSvgOptions defaultHudOptions [] (stdLineChart 0.02 palette1 xss)
anyScatterChart :: [[(Double, Double)]] -> Text
anyScatterChart xss =
renderHudOptionsChart defaultSvgOptions defaultHudOptions [] (scatterChart (fmap (fmap (uncurry Point)) xss))
anyTextChart :: [[Text]] -> Text
anyTextChart xss =
renderHudOptionsChart defaultSvgOptions defaultHudOptions [] (tableChart xss)
anyPixelChart :: [[Double]] -> Text
anyPixelChart xss = renderHudOptionsChart defaultSvgOptions (anyPixelHud nx ny) h c
where
(c,h) =
pixelfl
(\(Point x y) -> ((xss !! (floor x)) !! (floor y)))
(PixelOptions defaultPixelStyle (Point nx ny) (Rect 0 (fromIntegral nx :: Double) 0 (fromIntegral ny)))
(defaultPixelLegendOptions "square")
nx = length xss
ny = length (xss!!0)
anyPixelHud :: Int -> Int -> HudOptions
anyPixelHud nx ny =
defaultHudOptions
& #hudAxes
.~ [ defaultAxisOptions
& #atick . #tstyle .~ TickPlaced (zip ((0.5 +) <$> [0 ..]) labelsy)
& #place .~ PlaceLeft,
defaultAxisOptions
& #atick . #tstyle .~ TickPlaced (zip ((0.5 +) <$> [0 ..]) labelsx)
& #place .~ PlaceBottom
]
where
labelsx = show <$> [0..(nx - 1)]
labelsy = show <$> [0..(ny - 1)]
tryChart :: (Read a) => Text -> (a -> Text) -> Either Text Text
tryChart t c = either (Left . pack) (Right . c) $ readEither (unpack t)
write' :: Text -> IO ()
write' t = writeFile "scratch.svg" $ either id id $ chartAny t