amby 0.2.1 → 0.3.1

raw patch · 12 files changed

+1120/−188 lines, 12 filesdep +doctestdep +lensdep +mwc-randomdep −microlensdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: doctest, lens, mwc-random, tasty, tasty-hunit, vector-algorithms

Dependencies removed: microlens

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• amby.cabal +30/−14
• app/Main.hs +0/−6
• src/Amby.hs +5/−1
• src/Amby/Compatibility/HistogramNumeric.hs +69/−0
• src/Amby/Compatibility/HistogramPlot.hs +216/−0
• src/Amby/Display.hs +5/−3
• src/Amby/Numeric.hs +113/−3
• src/Amby/Plot.hs +297/−48
• src/Amby/Style.hs +96/−45
• src/Amby/Theme.hs +70/−45
• src/Amby/Types.hs +198/−22
• test/Spec.hs +21/−1

@@ -1,10 +1,24 @@ name:                amby-version:             0.2.1+version:             0.3.1 synopsis:            Statistical data visualization-description:         Statistical data visualization. Provides a high-level-                     interface built on top of-                     <https://github.com/timbod7/haskell-chart/wiki Chart>-                     to quickly display attractive visualizations within GHCi.+description:         <<https://travis-ci.org/jsermeno/amby.svg?branch=master>>+                     <<https://img.shields.io/badge/language-Haskell-blue.svg>>+                     <<http://img.shields.io/badge/license-BSD3-brightgreen.svg>>+                     .+                     <<https://cloud.githubusercontent.com/assets/197051/20435959/262da202-ad7c-11e6-99e4-b6348cab0898.png>>+                     <<https://cloud.githubusercontent.com/assets/197051/20435962/2796c380-ad7c-11e6-9cc8-0fbc74ba259a.png>>+                     <<https://cloud.githubusercontent.com/assets/197051/20435968/2a059e52-ad7c-11e6-8f8d-1fd648dfcf4b.png>>+                     .+                     A statistics visualization library built on top of+                     <https://github.com/timbod7/haskell-chart Chart> inspired by+                     <https://github.com/mwaskom/seaborn Seaborn>. Amby provides+                     a high-level interface to quickly display attractive+                     visualizations. Amby also provides tools to display Charts+                     from both Amby and the Chart package within GHCi.+                     .+                     For examples visit the+                     <https://github.com/jsermeno/amby#readme README>+ homepage:            https://github.com/jsermeno/amby#readme license:             BSD3 license-file:        LICENSE@@ -25,14 +39,16 @@                      , Amby.Numeric                      , Amby.Plot                      , Amby.Display+                     , Amby.Compatibility.HistogramPlot+                     , Amby.Compatibility.HistogramNumeric   build-depends:       base >= 4.7 && < 5                      , data-default-class                      , Chart-cairo                      , Chart-diagrams                      , Chart                      , vector+                     , vector-algorithms                      , statistics-                     , microlens                      , colour                      , scientific                      , mtl@@ -42,14 +58,10 @@                      , process                      , exceptions                      , data-default-  default-language:    Haskell2010--executable amby-exe-  hs-source-dirs:      app-  main-is:             Main.hs-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N-  build-depends:       base-                     , amby+                     -- 'Lens' package used as dependency of 'Chart'+                     , lens+                     , mwc-random+  ghc-options:         -Wall -fno-warn-orphans   default-language:    Haskell2010  test-suite amby-test@@ -58,6 +70,10 @@   main-is:             Spec.hs   build-depends:       base                      , amby+                     , doctest+                     , tasty+                     , tasty-hunit+                     , vector   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010 

@@ -1,6 +0,0 @@-module Main where--import Amby--main :: IO ()-main = return ()

@@ -11,11 +11,15 @@   , module Amby.Numeric   , module Amby.Types   , module Amby.Plot++  -- * Lens operators+  , (.=)   ) where +import Graphics.Rendering.Chart.Easy ((.=))+ import Amby.Types import Amby.Numeric import Amby.Theme-import Amby.Style import Amby.Plot import Amby.Display ()

@@ -0,0 +1,69 @@+{-# LANGUAGE PatternGuards #-}++module Amby.Compatibility.HistogramNumeric ( Range+                                           , binBounds+                                           , histValues+                                           , histWeightedValues+                                           , histWithBins+                                           ) where++import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import Control.Monad.ST++type Range a = (a,a)++-- | 'binBounds a b n' generates bounds for 'n' bins spaced linearly between+-- 'a' and 'b'+--+-- Examples:+--+-- >>> binBounds 0 3 4+-- [(0.0,0.75),(0.75,1.5),(1.5,2.25),(2.25,3.0)]+binBounds :: RealFrac a => a -> a -> Int -> [Range a]+binBounds a b n = map (\i->(lbound i, lbound (i+1))) [0..n-1]+        where lbound i = a + (b-a) * realToFrac i / realToFrac n++-- | 'histValues a b n vs' returns the bins for the histogram of+-- 'vs' on the range from 'a' to 'b' with 'n' bins+histValues :: RealFrac a => a -> a -> Int -> [a] -> V.Vector (Range a, Int)+histValues a b n = histWithBins (V.fromList $ binBounds a b n) . zip (repeat 1)++-- | 'histValues a b n vs' returns the bins for the weighted histogram of+-- 'vs' on the range from 'a' to 'b' with 'n' bins+histWeightedValues :: RealFrac a => a -> a -> Int -> [(Double,a)] -> V.Vector (Range a, Double)+histWeightedValues a b n = histWithBins (V.fromList $ binBounds a b n)++-- | 'histWithBins bins xs' is the histogram of weighted values 'xs' with 'bins'+--+-- Examples:+--+-- >>> :{+-- histWithBins+--     (V.fromList [(0.0, 0.75), (0.75, 1.5), (1.5, 2.25), (2.25, 3.0)])+--     [(1, 0), (1, 0), (1, 1), (1, 2), (1, 2), (1, 2), (1, 3)]+-- :}+-- [((0.0,0.75),2),((0.75,1.5),1),((1.5,2.25),3),((2.25,3.0),1)]+histWithBins :: (Num w, RealFrac a) => V.Vector (Range a) -> [(w, a)] -> V.Vector (Range a, w)+histWithBins bins xs =+    let n = V.length bins+        testBin :: RealFrac a => a -> (Int, Range a) -> Bool+        testBin x (i, (a,b)) =+            if i == n - 1+                then x >= a && x <= b+                else x >= a && x < b++        f :: (RealFrac a, Num w)+          => V.Vector (Range a) -> MV.STVector s w -> (w, a)+          -> ST s ()+        f bins1 bs (w,x) =+            case V.dropWhile (not . testBin x) $ V.indexed bins1 of+                v | V.null v  -> return ()+                v | (idx,_) <- V.head v  -> do+                    m <- MV.read bs idx+                    MV.write bs idx $! m+w++        counts = runST $ do b <- MV.replicate n 0+                            mapM_ (f bins b) xs+                            V.freeze b+    in V.zip bins counts

@@ -0,0 +1,216 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+module Amby.Compatibility.HistogramPlot+  ( -- * Histograms+    PlotHist (..)+  , histToPlot+  , defaultPlotHist+  , defaultFloatPlotHist+  , defaultNormedPlotHist+    -- * Accessors+  , plot_hist_title+  , plot_hist_bins+  , plot_hist_values+  , plot_hist_no_zeros+  , plot_hist_range+  , plot_hist_drop_lines+  , plot_hist_line_style+  , plot_hist_fill_style+  , plot_hist_norm_func+  , plot_hist_vertical+  ) where++import Control.Monad (when)+import Data.Monoid+import Data.Maybe (fromMaybe)+import qualified Data.Foldable as F+import qualified Data.Vector as V++import Graphics.Rendering.Chart.Easy (makeLenses)+import Graphics.Rendering.Chart.Plot.Types+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Drawing+import Data.Default.Class++import Data.Colour (opaque)+import Data.Colour.Names (blue)+import Data.Colour.SRGB (sRGB)++import Amby.Compatibility.HistogramNumeric++#if MIN_VERSION_Chart(1,7,0)+#else+type BackendProgram a = ChartBackend a+#endif++data PlotHist x y = PlotHist+    { -- | Plot title+      _plot_hist_title                :: String++      -- | Number of bins+    , _plot_hist_bins                 :: Int++      -- | Values to histogram+    , _plot_hist_values               :: [x]++      -- | Don't attempt to plot bins with zero counts. Useful when+      -- the y-axis is logarithmically scaled.+    , _plot_hist_no_zeros             :: Bool++      -- | Override the range of the histogram. If @Nothing@ the+      -- range of @_plot_hist_values@ is used.+      --+      -- Note that any normalization is always computed over the full+      -- data set, including samples not falling in the histogram range.+    , _plot_hist_range                :: Maybe (x,x)++      -- | Plot vertical lines between bins+    , _plot_hist_drop_lines           :: Bool++      -- | Fill style of the bins+    , _plot_hist_fill_style           :: FillStyle++      -- | Line style of the bin outlines+    , _plot_hist_line_style           :: LineStyle++      -- | Normalization function+    , _plot_hist_norm_func            :: Double -> Int -> y++      -- | If true observed values are one y-axis+    , _plot_hist_vertical             :: Bool+    }++instance Default (PlotHist x Int) where+    def = defaultPlotHist++-- | The default style is an unnormalized histogram of 20 bins.+defaultPlotHist :: PlotHist x Int+defaultPlotHist = PlotHist { _plot_hist_bins        = 20+                           , _plot_hist_title       = ""+                           , _plot_hist_values      = []+                           , _plot_hist_no_zeros    = False+                           , _plot_hist_range       = Nothing+                           , _plot_hist_drop_lines  = False+                           , _plot_hist_line_style  = defaultLineStyle+                           , _plot_hist_fill_style  = defaultFillStyle+                           , _plot_hist_norm_func   = const id+                           , _plot_hist_vertical    = False+                           }++-- | @defaultPlotHist@ but with real counts+defaultFloatPlotHist :: PlotHist x Double+defaultFloatPlotHist = defaultPlotHist { _plot_hist_norm_func = const realToFrac }++-- | @defaultPlotHist@ but normalized such that the integral of the+-- histogram is one.+defaultNormedPlotHist :: PlotHist x Double+defaultNormedPlotHist = defaultPlotHist { _plot_hist_norm_func = \n y->realToFrac y / n }++defaultFillStyle :: FillStyle+defaultFillStyle = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0)++defaultLineStyle :: LineStyle+defaultLineStyle = (solidLine 1 $ opaque blue)+     { _line_cap  = LineCapButt+     , _line_join = LineJoinMiter+     }++-- | Convert a @PlotHist@ to a @Plot@+--+-- N.B. In principle this should be Chart's @ToPlot@ class but unfortunately+-- this does not allow us to set bounds on the x and y axis types, hence+-- the need for this function.+histToPlot :: (RealFrac x) => PlotHist x x -> Plot x x+histToPlot p = Plot {+        _plot_render      = renderPlotHist p,+        _plot_legend      = [(_plot_hist_title p, renderPlotLegendHist p)],+        _plot_all_points  = unzip+                            $ concatMap binToPoints+                            $ histToBins p+    }+    where binToPoints ((x1,x2), y) = if _plot_hist_vertical p+              then [(y,x1), (y,x2), (0,x1), (0,x2)]+              else [(x1,y), (x2,y), (x1,0), (x2,0)]++buildHistPath :: (RealFrac x)+              => PointMapFn x x -> [((x,x), x)] -> Path+buildHistPath _ [] = End+buildHistPath pmap bins = MoveTo (pt xb 0) (go bins)+    where go [((x1,x2),y)]      = LineTo (pt x1 y)+                                $ LineTo (pt x2 y)+                                $ LineTo (pt x2 0)+                                $ End+          go (((x1,x2),y):rest) = LineTo (pt x1 y)+                                $ LineTo (pt x2 y)+                                $ go rest+          go []                 = End+          ((xb,_),_) = head bins+          pt x y = pmap (LValue x, LValue y)++buildHistPathVertical :: (RealFrac x)+                      => PointMapFn x x -> [((x,x), x)] -> Path+buildHistPathVertical _ [] = End+buildHistPathVertical pmap bins = MoveTo (pt 0 xb) (go bins)+    where go [((x1,x2),y)]      = LineTo (pt y x1)+                                $ LineTo (pt y x2)+                                $ LineTo (pt 0 x2)+                                $ End+          go (((x1,x2),y):rest) = LineTo (pt y x1)+                                $ LineTo (pt y x2)+                                $ go rest+          go []                 = End+          ((xb,_),_) = head bins+          pt x y = pmap (LValue x, LValue y)++renderPlotHist :: (RealFrac x)+               => PlotHist x x -> PointMapFn x x -> BackendProgram ()+renderPlotHist p pmap+    | null bins = return ()+    | otherwise = do+        withFillStyle (_plot_hist_fill_style p) $+            alignFillPath (buildHistPathFn pmap bins) >>= fillPath+        withLineStyle (_plot_hist_line_style p) $ do+            when (_plot_hist_drop_lines p) $+                alignStrokePath dropLinesPath >>= strokePath+            alignStrokePath (buildHistPathFn pmap bins) >>= strokePath+    where buildHistPathFn = if _plot_hist_vertical p+              then buildHistPathVertical+              else buildHistPath+          bins = histToBins p+          pt x y = pmap (LValue x, LValue y)+          dropLinesPath = F.foldMap dropLinesFoldFn $ tail bins+          dropLinesFoldFn ((x1,_), y) = if _plot_hist_vertical p+              then moveTo (pt 0 x1) <> lineTo (pt y x1)+              else moveTo (pt x1 0) <> lineTo (pt x1 y)++renderPlotLegendHist :: PlotHist x y -> Rect -> BackendProgram ()+renderPlotLegendHist p (Rect p1 p2) =+    withLineStyle (_plot_hist_line_style p) $+        let y = (p_y p1 + p_y p2) / 2+        in strokePath $ moveTo' (p_x p1) y <> lineTo' (p_x p2) y++histToBins :: (RealFrac x, Num y, Ord y) => PlotHist x y -> [((x,x), y)]+histToBins hist =+    filter_zeros $ zip bounds $ counts+    where n = _plot_hist_bins hist+          (a,b) = realHistRange hist+          dx = realToFrac (b-a) / realToFrac n+          bounds = binBounds a b n+          values = V.fromList (_plot_hist_values hist)+          filter_zeros | _plot_hist_no_zeros hist  = filter (\(_,c)->c > 0)+                       | otherwise                 = id+          norm = dx * realToFrac (V.length values)+          normalize = _plot_hist_norm_func hist norm+          counts = V.toList $ V.map (normalize . snd)+                   $ histWithBins (V.fromList bounds)+                   $ zip (repeat 1) (V.toList values)++realHistRange :: (RealFrac x) => PlotHist x y -> (x,x)+realHistRange hist = fromMaybe range $ _plot_hist_range hist+    where values = V.fromList (_plot_hist_values hist)+          range = if V.null values+                    then (0,0)+                    else (V.minimum values, V.maximum values)++$( makeLenses ''PlotHist )

@@ -39,10 +39,12 @@   catch readImg cHandler   where     readImg = do-      (ec, stdout, stderr) <- readProcessWithExitCode "imgcat" [Plot.cairoDefSave] ""-      if | (ExitFailure code) <- ec -> return (mkDtStr "Unable to display chart.")+      (ec, stdout, _) <- readProcessWithExitCode "imgcat" [Plot.cairoDefSave] ""+      if | (ExitFailure _) <- ec -> return (mkDtStr "Unable to display chart.")          | otherwise -> return (mkDtStr stdout)     cHandler e-      | Just (e :: SomeException) <- fromException e =+      | Just (_ :: SomeException) <- fromException e =         return $ mkDt "Could not find imgcat executable."+      | otherwise =+        return $ mkDt "Unknown display error." 

@@ -1,24 +1,55 @@ {-# LANGUAGE FlexibleContexts #-}+---------------------------------------------------------------------------------+-- |+-- Module       : Amby.Numeric+-- Copyright    : (C) 2016 Justin Sermeno+-- License      : BSD3+-- Maintainer   : Justin Sermeno+--+-- Functions for working with numerical ranges and statistics.+--------------------------------------------------------------------------------- module Amby.Numeric-  ( contDistrDomain+  ( -- * Ranges+    contDistrDomain   , contDistrRange   , linspace   , arange+  , random++  -- * Frequencies+  , scoreAtPercentile+  , interquartileRange+  , freedmanDiaconisBins+   ) where -import Data.Either.Combinators-import Data.Scientific+import Data.Vector.Generic ((!)) import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector as V+import qualified Data.Vector.Algorithms.Intro as V+ import Statistics.Distribution+import System.Random.MWC (withSystemRandom, asGenST) +-- $setup+-- >>> let demoData = V.fromList $ concat $ zipWith replicate [5, 4, 3, 7] [0..3]++---------------------+-- Ranges+---------------------++-- | @contDistrDomain d n@ generates a domain of 'n' evenly spaced points+-- for the continuous distribution 'd'. contDistrDomain :: (ContDistr d) => d -> Int -> U.Vector Double contDistrDomain d num = linspace (quantile d 0.0001) (quantile d 0.9999) num +-- | @contDistrRange d xs@ generates the pdf value of the continious distribution+-- 'd' for each value in 'xs'. contDistrRange :: (ContDistr d) => d -> U.Vector Double -> U.Vector Double contDistrRange d x = U.map (density d) x +-- | @linspace s e n@ generates 'n' evenly spaced values between ['s', 'e']. linspace :: Double -> Double -> Int -> U.Vector Double linspace start stop num   | num < 0 = error ("Number of samples, " ++ show num ++ ", must be non-negative.")@@ -29,5 +60,84 @@     step = delta / fromIntegral (num - 1)     addStart = U.map (realToFrac . (+ start)) +-- | @arange s e i@ generates numbers between ['s', 'e'] spaced by amount 'i'.+-- 'arange' is the equivalent of haskell's range notation except that it generates+-- a 'Vector'. As a result, the last element may be greater than less than, or+-- greater than the stop point. arange :: Double -> Double -> Double -> U.Vector Double arange start stop step = U.fromList [start,(start + step)..stop]++-- | Generates an unboxed vectors of random numbers from a distribution+-- that is an instance of 'ContGen'. This function is meant for ease of use+-- and is expensive.+random :: (ContGen d) => d -> Int -> IO (U.Vector Double)+random d n = withSystemRandom . asGenST $ \gen ->+  U.replicateM n $ genContVar d gen++---------------------+-- Frequencies+---------------------++-- | @scoreAtPercentile xs p@ calculates the score at percentile 'p'.+--+-- Examples:+--+-- >>> let a = arange 0 99 1+--+-- >>> scoreAtPercentile a 50+-- 49.5+scoreAtPercentile :: (G.Vector v Double) => v Double -> Double -> Double+scoreAtPercentile xs p+  | n == 0 = modErr "scoreAtPercentile" "Percentile sample size is 0"+  | p < 0 || p > 100 = modErr "scoreAtPercentile" "Percentile must be in [0, 100]"+  | otherwise = (getScore . G.modify V.sort) xs+  where+    n = G.length xs+    idx = (p / 100) * fromIntegral (n - 1)+    i = floor idx+    j = ceiling idx++    isInt :: Double -> Bool+    isInt a = fromIntegral (round a :: Int) == a++    interop :: (G.Vector v Double) => v Double -> Double+    interop vec =+      (vec ! i) * (fromIntegral j - idx) ++      (vec ! j) * (idx - fromIntegral i)++    getScore vec = if isInt idx+      then vec ! i+      else interop vec+{-# SPECIALIZE scoreAtPercentile :: U.Vector Double -> Double -> Double #-}+{-# SPECIALIZE scoreAtPercentile :: V.Vector Double -> Double -> Double #-}++-- | Calculate the interquartile range.+--+-- Examples:+--+-- >>> interquartileRange demoData+-- 2.5+interquartileRange :: (G.Vector v Double) => v Double -> Double+interquartileRange xs = scoreAtPercentile xs 75 - scoreAtPercentile xs 25+{-# SPECIALIZE interquartileRange :: U.Vector Double -> Double #-}+{-# SPECIALIZE interquartileRange :: V.Vector Double -> Double #-}++-- | Estimate a good default bin size.+--+-- Examples:+--+-- >>> freedmanDiaconisBins demoData+-- 2+freedmanDiaconisBins :: (G.Vector v Double) => v Double -> Int+freedmanDiaconisBins xs =+    if h == 0+      then floor $ sqrt $ (fromIntegral n :: Double)+      else ceiling $ (G.maximum xs - G.minimum xs) / h+  where+    n = G.length xs+    h = 2 * interquartileRange xs / fromIntegral n ** (1 / 3)++modErr :: String -> String -> a+modErr f err = error+  $ showString "Amby.Numeric."+  $ showString f err

@@ -1,13 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Amby.Plot-  ( plot-  , plotEq-  , getEC+  ( getEC   , save   , saveSvg @@ -19,21 +19,303 @@ import Control.Monad import Control.Monad.State import qualified Data.List as L+import qualified Data.Maybe as Maybe+import Data.Tuple (swap) import qualified Data.Vector.Generic as G+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U +import Control.Lens+import Data.Colour as Colour import Data.Default.Class-import Graphics.Rendering.Chart.Easy hiding (plot)+import Graphics.Rendering.Chart.Easy (Layout, EC) import qualified Graphics.Rendering.Chart.Easy as Chart import qualified Graphics.Rendering.Chart.Backend.Cairo as Cairo import qualified Graphics.Rendering.Chart.Backend.Diagrams as Diagrams-import Lens.Micro-import Statistics.Distribution+import Safe (maximumMay)+import qualified Statistics.Sample.KernelDensity.Simple as Stats+import qualified Statistics.Sample as Stats -import Amby.Types+import Amby.Compatibility.HistogramPlot import Amby.Numeric-import Amby.Theme-import Amby.Style+import Amby.Theme (toColour)+import Amby.Types +--------------------------+-- Instance declarations+--------------------------++instance AmbyContainer (V.Vector Double) where+  type Value (V.Vector Double) = Double+  plot = plotVec+  plot' = plotVec'+  plotEq = plotEqVec+  plotEq' = plotEqVec'+  distPlot = distPlotVec+  distPlot' = distPlotVec'+  kdePlot = kdePlotVec+  kdePlot' = kdePlotVec'+  rugPlot = rugPlotVec+  rugPlot' = rugPlotVec'++instance AmbyContainer (U.Vector Double) where+  type Value (U.Vector Double) = Double+  plot = plotVec+  plot' = plotVec'+  plotEq = plotEqVec+  plotEq' = plotEqVec'+  distPlot = distPlotVec+  distPlot' = distPlotVec'+  kdePlot = kdePlotVec+  kdePlot' = kdePlotVec'+  rugPlot = rugPlotVec+  rugPlot' = rugPlotVec'++instance (Real a) => AmbyContainer [a] where+  type Value [a] = a++  plot :: [a] -> [a] -> State PlotOpts () -> AmbyChart ()+  plot x y optsState = plotList vals opts+    where+      opts = execState optsState def+      vals = L.zipWith (\a b -> (realToFrac a, realToFrac b)) x y++  plot' :: [a] -> [a] -> AmbyChart ()+  plot' x y = plot x y $ return ()++  plotEq :: [a] -> (a -> a) -> State PlotEqOpts () -> AmbyChart ()+  plotEq x fn optsState = plotList vals $ def+      & color .~ (opts ^. color)+    where+      opts = execState optsState def+      vals = L.zipWith (\a b -> (realToFrac a, realToFrac b)) x $ map fn x++  plotEq' :: [a] -> (a -> a) -> AmbyChart ()+  plotEq' x fn = plotEq x fn $ return ()++  distPlot :: [a] -> State DistPlotOpts () -> AmbyChart ()+  distPlot xs optsState = distPlotVec valsVec optsState+    where+      valsVec = (V.map realToFrac . V.fromList) xs++  distPlot' :: [a] -> AmbyChart ()+  distPlot' xs = distPlot xs $ return ()++  kdePlot :: [a] -> State KdePlotOpts () -> AmbyChart ()+  kdePlot xs optsState = kdePlotVec valsVec optsState+    where+      valsVec = (V.map realToFrac . V.fromList) xs++  kdePlot' :: [a] -> AmbyChart ()+  kdePlot' xs = kdePlot xs $ return ()++  rugPlot :: [a] -> State RugPlotOpts () -> AmbyChart ()+  rugPlot xs optsState = rugPlotVec valsVec optsState+    where+      valsVec = (V.map realToFrac . V.fromList) xs++  rugPlot' :: [a] -> AmbyChart ()+  rugPlot' xs = rugPlot xs $ return ()++--------------------------+-- Generic vec plotters+--------------------------++plotVec :: (G.Vector v Double, G.Vector v (Double, Double))+        => v Double -> v Double -> State PlotOpts () -> AmbyChart ()+plotVec x y optsState = plotList vals opts+  where+    opts = execState optsState def+    vals = G.toList $ G.zip x y++plotVec' :: (G.Vector v Double, G.Vector v (Double, Double))+         => v Double -> v Double -> AmbyChart ()+plotVec' x y = plotVec x y $ return ()++plotEqVec :: (G.Vector v Double, G.Vector v (Double, Double))+          => v Double -> (Double -> Double) -> State PlotEqOpts ()+          -> AmbyChart ()+plotEqVec x fn optsState = plotList vals $ def+    & color .~ (opts ^. color)+  where+    opts = execState optsState def+    vals = G.toList $ G.zip x (G.map fn x)++plotEqVec' :: (G.Vector v Double, G.Vector v (Double, Double))+           => v Double -> (Double -> Double) -> AmbyChart ()+plotEqVec' x fn = plotEqVec x fn $ return ()++distPlotVec :: (G.Vector v Double) => v Double -> State DistPlotOpts ()+            -> AmbyChart ()+distPlotVec xs optsState = plotDistribution xs $ execState optsState def++distPlotVec' :: (G.Vector v Double) => v Double -> AmbyChart ()+distPlotVec' xs = distPlotVec xs $ return ()++kdePlotVec :: (G.Vector v Double) => v Double -> State KdePlotOpts ()+           -> AmbyChart ()+kdePlotVec xs optsState = do+    layout <- takeLayout+    putLayout $ do+      layout+      nextColor <- toColour (opts ^. color) <$> Chart.takeColor+      plotKde nextColor xs opts+  where+    opts = execState optsState def++kdePlotVec' :: (G.Vector v Double) => v Double -> AmbyChart ()+kdePlotVec' xs = kdePlotVec xs $ return ()++rugPlotVec :: (G.Vector v Double)+           => v Double -> State RugPlotOpts ()+           -> AmbyChart ()+rugPlotVec xs optsState = do+    layout <- takeLayout+    putLayout $ do+      layout+      nextColor <- toColour (opts ^. color) <$> Chart.takeColor+      plotRug nextColor xs opts+  where+    opts = execState optsState def++rugPlotVec' :: (G.Vector v Double)+            => v Double -> AmbyChart ()+rugPlotVec' xs = rugPlotVec xs $ return ()++--------------------------+-- Generic plotters+--------------------------++plotDistribution :: (G.Vector v Double) => v Double -> DistPlotOpts -> AmbyChart ()+plotDistribution xs opts = do+    layout <- takeLayout+    putLayout $ do+      layout+      nextColor <- toColour (opts ^. color) <$> Chart.takeColor+      when (opts ^. hist) $ plotHist opts nextColor numBins xs+      when (opts ^. kde) $ plotKde nextColor xs $ def+        & bw .~ (opts ^. bw)+        & shade .~ (opts ^. shade)+        & gridsize .~ (opts ^. gridsize)+        & axis .~ (opts ^. axis)+        & linewidth .~ (opts ^. kdeLinewidth)+        & cut .~ (opts ^. cut)+      when (opts ^. rug) $ plotRug nextColor xs $ def+        & height .~ (opts ^. rugHeight)+        & axis .~ (opts ^. axis)+        & linewidth .~ (opts ^. rugLinewidth)+  where+    numBins = if opts ^. bins /= 0+      then opts ^. bins+      else min 50 $ freedmanDiaconisBins xs++plotList :: [(Double, Double)] -> PlotOpts -> AmbyChart ()+plotList xs opts = do+    layout <- takeLayout+    putLayout $ do+      layout+      nextColor <- toColour (opts ^. color) <$> Chart.takeColor+      plotLine nextColor (opts ^. linewidth) xs++--------------------------+-- Composable plotters+--------------------------++plotHist :: (G.Vector v Double) => DistPlotOpts -> AlphaColour Double -> Int -> v Double+         -> EC (Layout Double Double) ()+plotHist opts c numBins xs =+  Chart.plot $ fmap histToPlot $ Chart.liftEC $ do+    plot_hist_bins .= numBins+    plot_hist_drop_lines .= True+    plot_hist_values .= G.toList xs+    plot_hist_line_style . Chart.line_width .= (opts ^. histLinewidth)+    plot_hist_line_style . Chart.line_color .= Colour.dissolve 0.5 c+    plot_hist_fill_style . Chart.fill_color .= Colour.dissolve 0.4 c+    plot_hist_vertical .= (opts ^. axis == YAxis)++plotRug :: (G.Vector v Double)+        => AlphaColour Double -> v Double -> RugPlotOpts+        -> EC (Layout Double Double) ()+plotRug c xs opts = do+      maxMay <- getPlotMaxHeightMay+      h <- calcRugHeight maxMay+      G.foldM (plotSingleLine h) () xs+      updatePlotHeight maxMay+    where+      getPlotMaxHeightMay :: EC (Layout Double Double) (Maybe Double)+      getPlotMaxHeightMay = do+        layout <- get+        layout ^.. Chart.layout_plots . each . Chart.plot_all_points+          & concatMap (if opts ^. axis == XAxis then snd else fst)+          & maximumMay+          & return++      calcRugHeight :: (Maybe Double) -> EC (Layout Double Double) Double+      calcRugHeight maxMay =+        return $ (Maybe.fromMaybe 1.0 maxMay) * (opts ^. height)++      plotSingleLine :: Double -> () -> Double -> EC (Layout Double Double) ()+      plotSingleLine h _ x = if opts ^. axis == XAxis+        then plotLine c (opts ^. linewidth) [(x, 0), (x, h)]+        else plotLine c (opts ^. linewidth)  [(0, x), (h, x)]++      updatePlotHeight :: (Maybe Double)+                       -> EC (Layout Double Double) ()+      updatePlotHeight maxMay = do+        layout2 <- get+        layout2 & Chart.layout_plots . mapped . Chart.plot_all_points+          %~ updatePlotPoints maxMay+          & put++      updatePlotPoints :: (Maybe Double) -> ([Double], [Double])+                       -> ([Double], [Double])+      updatePlotPoints maxMay (as, bs) =+        if | maxMay == Nothing && opts ^. axis == XAxis -> (0.0:as, 1.0:bs)+           | maxMay == Nothing && opts ^. axis == YAxis -> (1.0:as, 0.0:bs)+           | otherwise -> (as, bs)++plotKde :: (G.Vector v Double) => AlphaColour Double -> v Double -> KdePlotOpts+        -> EC (Layout Double Double) ()+plotKde c xs opts = do+    plotLine c (opts ^. linewidth) kdeVals+    when (opts ^. shade) $ plotShade c kdeVals+  where+    minX = G.minimum xs+    maxX = G.maximum xs+    iqr = interquartileRange xs+    std = Stats.stdDev xs+    n = fromIntegral $ G.length xs+    a = min std (iqr / 1.34)+    bandwidth = if | opts ^. bw == Scott -> 1.059 * a * n ** ((-1) / 5)+                   | (BwScalar b) <- opts ^. bw -> b+    clipLeft = minX - (opts ^. cut) * bandwidth+    clipRight = maxX + (opts ^. cut) * bandwidth+    sizeEstimate = fromIntegral $ opts ^. gridsize :: Double+    numEstimates = 2 ^ (ceiling (log sizeEstimate / log 2) :: Int)+    xVals = Stats.Points $ linspace clipLeft clipRight numEstimates+    kdeResult = Stats.estimatePDF Stats.gaussianKernel bandwidth xs xVals+    kdeVals' = U.zip (Stats.fromPoints xVals) kdeResult+    kdeVals = if opts ^. axis == YAxis+      then U.toList $ U.map swap kdeVals'+      else U.toList kdeVals'++plotLine :: AlphaColour Double -> Double -> [(Double, Double)]+         -> EC (Layout Double Double) ()+plotLine c lineWidth xs = Chart.plot $ Chart.liftEC $ do+  Chart.plot_lines_values .= [xs]+  Chart.plot_lines_style . Chart.line_width .= lineWidth+  Chart.plot_lines_style . Chart.line_color .= c++plotShade :: AlphaColour Double -> [(Double, Double)]+          -> EC (Layout Double Double) ()+plotShade c xs = Chart.plot $ Chart.liftEC $ do+  Chart.plot_fillbetween_values .= (xs & mapped . _2 %~ \y -> (0, y))+  Chart.plot_fillbetween_style .= Chart.solidFillStyle (Colour.dissolve 0.25 c)++--------------------------+-- Rendering+--------------------------+ cairoDefSave :: FilePath cairoDefSave = ".__amby.png" @@ -50,52 +332,19 @@ -- Short-hand to render to png file using Cairo backend. save :: AmbyChart () -> IO () save chart = Cairo.toFile-    def { Cairo._fo_size = size }+    def { Cairo._fo_size = newSize }     cairoDefSave     (getLayout st)   where     st = getState chart-    size = getSize st+    newSize = getSize st  -- | Short-hand to render to svg using Cairo backend saveSvg :: AmbyChart () -> IO () saveSvg chart = Diagrams.toFile-    def { Diagrams._fo_size = join (***) fromIntegral size }+    def { Diagrams._fo_size = join (***) fromIntegral newSize }     diagramsDefSave     (getLayout st)   where     st = getState chart-    size = getSize st---- | Basic x y line plot.-instance (G.Vector v Double, G.Vector v (Double, Double))-  => AmbyContainer (v Double) Double where-  plot :: v Double -> v Double -> AmbyChart ()-  plot x y = plotList $ G.toList (G.zip x y)--  plotEq :: v Double -> (Double -> Double) -> AmbyChart ()-  plotEq x fn = plotList $ G.toList (G.zip x (G.map fn x))--instance (Real a) => AmbyContainer [a] a where-  plot :: [a] -> [a] -> AmbyChart ()-  plot x y = plotList $ L.zipWith (\a b -> (realToFrac a, realToFrac b)) x y--  plotEq x fn = plotList $ L.zipWith (\a b -> (realToFrac a, realToFrac b)) x (map fn x)--plotList :: [(Double, Double)] -> AmbyChart ()-plotList plotVals = do-    theme <- takeTheme-    layout <- takeLayout-    putLayout $ layout >> mkLayout theme-  where--    linePlot :: EC l (PlotLines Double Double)-    linePlot = liftEC $ do-      nextColor <- takeColor-      plot_lines_values .= [plotVals]-      plot_lines_style . line_width .= 2.5-      plot_lines_style . line_color .= nextColor--    mkLayout :: Theme -> EC (Layout Double Double) ()-    mkLayout theme = do-      Chart.plot linePlot+    newSize = getSize st

@@ -3,72 +3,123 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-} module Amby.Style-  ( roundAxisData-  , noEdgeAxisData-  , scaledPaddedAxis-  , setThemeStyles+  ( setThemeStyles+  , scaledAxisCustom   )   where -import Safe import qualified Data.List as L+import Data.Ord (comparing) import Numeric -import Graphics.Rendering.Chart.Easy hiding (plot)+import Control.Lens+import Data.Default+import Safe +import Graphics.Rendering.Chart.Easy (EC, Layout, AxisData(..))+import qualified Graphics.Rendering.Chart.Easy as Chart+import Graphics.Rendering.Chart.Utils (isValidNumber)+import Graphics.Rendering.Chart.Axis.Floating (LinearAxisParams(..))+ import Amby.Theme --- | Equalizes precision for all labels.--- For example the labels [0, 0.2] become [0.0, 0.2].-roundAxisData :: AxisData x -> AxisData x-roundAxisData axisData = axisData & axis_labels %~ go+countAfterDecimal :: String -> Int+countAfterDecimal xs = case L.findIndex (== '.') xs of+  Nothing -> 0+  Just idx -> (length xs - 1) - idx++setThemeStyles :: Theme -> EC (Layout x y) ()+setThemeStyles theme = do+  Chart.layout_background .= (Chart.FillStyleSolid $ theme ^. bgColor)+  Chart.layout_plot_background .= Just (Chart.FillStyleSolid $ theme ^. plotBgColor)+  Chart.layout_all_font_styles . Chart.font_name .= (theme ^. fontFamily)+  Chart.layout_all_font_styles . Chart.font_size .= (theme ^. fontSize)+  Chart.layout_axes_styles . Chart.axis_line_style . Chart.line_width .= 0.0+  Chart.layout_axes_styles . Chart.axis_grid_style . Chart.line_color+    .= (theme ^. gridLineColor)+  Chart.layout_axes_styles . Chart.axis_grid_style . Chart.line_width .= 1.5+  Chart.layout_axes_styles . Chart.axis_grid_style . Chart.line_dashes .= []+  Chart.layout_axes_styles . Chart.axis_label_gap .= 8+  Chart.layout_x_axis . Chart.laxis_override .= roundAxisData+  Chart.layout_y_axis . Chart.laxis_override .= roundAxisData+  Chart.layout_margin .= 10++--- | Equalizes precision for all labels.+--- For example the labels [0, 0.2] become [0.0, 0.2].+roundAxisData :: Chart.AxisData x -> Chart.AxisData x+roundAxisData axisData = axisData & Chart.axis_labels %~ go   where     go xs = map go' xs     go' xs = xs         & mapped . _2-        %~ \x -> case readMay x of+        %~ \x -> case readMay x :: Maybe Double of           Just a -> showFFloat (Just precision) a ""           Nothing -> x       where         precision = maximum $ map (countAfterDecimal . snd) xs -noEdgeAxisData :: AxisData x -> AxisData x-noEdgeAxisData axisData = axisData & axis_grid %~ removeEdges+------------------------+-- Scaling+------------------------++-- | Take from the 'Chart' package with minor modifications.+scaledAxisCustom :: RealFloat a => Chart.LinearAxisParams a -> (a, a)+                 -> Chart.AxisFn a+scaledAxisCustom lap rs@(minV,maxV) ps0 = makeAxisCustom'+    realToFrac+    realToFrac+    labelFn+    (labelvs, tickvs, gridvs)+    rs   where-    removeEdges xs-      | length xs < 2 = []-      | otherwise = (init . tail) xs+#if MIN_VERSION_Chart(1,7,0)+    labelFn   = _la_labelf lap+#else+    labelFn   = map (_la_labelf lap)+#endif -scaledPaddedAxis :: forall x. (RealFloat x, PlotValue x) => [x] -> AxisData x-scaledPaddedAxis axisPoints = defaultAxis-    & axis_grid %~ (\xs -> gridMin : xs ++ [gridMax])+    ps        = filter isValidNumber ps0+    range []  = (0,1)+    range _   | minV == maxV = if minV==0 then (-1,1) else+                               let d = abs (minV * 0.01) in (minV-d,maxV+d)+              | otherwise    = rs+    labelvs   = map fromRational $ steps (fromIntegral (_la_nLabels lap)) r+    tickvs    = map fromRational $ steps (fromIntegral (_la_nTicks lap))+                                         (minimum labelvs,maximum labelvs)+    gridvs    = labelvs+    r         = range ps++steps :: RealFloat a => a -> (a,a) -> [Rational]+steps nSteps rs@(minV,maxV) = map ((s*) . fromIntegral) [min' .. max']   where-    getGridLimits xs-      | length xs < 1 = error "Not enough grid points"-      | otherwise = (head xs - spacing, last xs + spacing)-      where-        getSpacing (x:y:xs) = y - x-        spacing = getSpacing xs-    defaultAxis = autoAxis axisPoints-    (gridMin, gridMax) = getGridLimits (defaultAxis ^. axis_grid)+    s    = chooseStep nSteps rs+    min' :: Integer+    min' = floor   $ realToFrac minV / s+    max' = ceiling $ realToFrac maxV / s -countAfterDecimal :: String -> Int-countAfterDecimal xs = case L.findIndex (== '.') xs of-  Nothing -> 0-  Just idx -> (length xs - 1) - idx+chooseStep :: RealFloat a => a -> (a,a) -> Rational+chooseStep nsteps (x1,x2) = L.minimumBy (comparing proximity) stepVals+  where+    delta = x2 - x1+    mult  | delta == 0 = 1  -- Otherwise the case below will use all of memory+          | otherwise  = 10 ^^ ((floor $ log $ delta / nsteps)::Integer)+    stepVals = map (mult*) [0.1,0.2,0.25,0.5,1.0,2.0,2.5,5.0,10,20,25,50]+    proximity x = abs $ delta / realToFrac x - nsteps -setThemeStyles :: Theme -> EC (Layout Double Double) ()-setThemeStyles theme = do-  layout_background .= (FillStyleSolid $ getBgColor theme)-  layout_plot_background .= Just (FillStyleSolid $ getPlotBgColor theme)-  layout_all_font_styles . font_name .= (getFontFamily theme)-  layout_all_font_styles . font_size .= (getFontSize theme)-  layout_axes_styles . axis_line_style . line_width .= 0.0-  layout_axes_styles . axis_grid_style . line_color .= (getGridLineColor theme)-  layout_axes_styles . axis_grid_style . line_width .= 1.5-  layout_axes_styles . axis_grid_style . line_dashes .= []-  layout_axes_styles . axis_label_gap .= 8-  layout_x_axis . laxis_override .= roundAxisData-  layout_y_axis . laxis_override .= roundAxisData-  layout_margin .= 10+makeAxisCustom' :: Ord x => (x -> Double) -> (Double -> x) -> ([x] -> [String])+                   -> ([x],[x],[x]) -> (x, x) -> AxisData x+makeAxisCustom' t f labelf (labelvs, tickvs, gridvs) (minX, minY) = AxisData {+    _axis_visibility = def,+    _axis_viewport = Chart.linMap t (minX, minY),+    _axis_tropweiv = Chart.invLinMap f t (minimum labelvs, maximum labelvs),+    _axis_ticks    = zip tickvs (repeat 2)  ++  zip labelvs (repeat 5),+    _axis_grid     = gridvs,+    _axis_labels   =+      let zipWithLengthCheck (x:xs) (y:ys) = (x,y) : zipWithLengthCheck xs ys+          zipWithLengthCheck [] [] = []+          zipWithLengthCheck _ _ =+            error "makeAxis': label function returned the wrong number of labels"+      in [zipWithLengthCheck labelvs (labelf labelvs)]+    }

@@ -1,45 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-} module Amby.Theme-  ( Theme+  ( Theme(..)+  , AmbyColor(..)    -- * Themes   , mutedTheme   , deepTheme   , cleanTheme -  -- * Accessors-  , getBgColor-  , getPlotBgColor-  , getGridLineColor-  , getColorCycle-  , getFontFamily-  , getFontSize+  -- * Lenses+  , bgColor+  , plotBgColor+  , gridLineColor+  , colorCycle+  , fontFamily+  , fontSize++  -- * Color helpers+  , hexToRgb+  , hexToRgba+  , toColour   )   where +import Control.Lens import Data.Colour import Data.Colour.SRGB-import Data.Default.Class+import Data.Default +-- | Used to style a chart. data Theme = Theme-  { bgColor :: AlphaColour Double-  , plotBgColor :: AlphaColour Double-  , gridLineColor :: AlphaColour Double-  , fontFamily :: String-  , fontSize :: Double-  , colorCycle :: [AlphaColour Double]+  { _themeBgColor :: AlphaColour Double+  , _themePlotBgColor :: AlphaColour Double+  , _themeGridLineColor :: AlphaColour Double+  , _themeFontFamily :: String+  , _themeFontSize :: Double+  , _themeColorCycle :: [AlphaColour Double]   }+makeFields ''Theme  instance Default Theme where   def = deepTheme +-- | Api facing color selection.+data AmbyColor =+    DefaultColor+  | R | G | B | C | M | Y | K | W+  | CustomColor (AlphaColour Double)+  deriving (Show, Eq)+ mutedTheme :: Theme mutedTheme = Theme-  { bgColor = opaque (sRGB24read "#FFFFFF")-  , plotBgColor = opaque (sRGB24read "#EAEAF2")-  , gridLineColor = opaque (sRGB24read "#FFFFFF")-  , fontFamily = "Verdana"-  , fontSize = 14-  , colorCycle =+  { _themeBgColor = opaque (sRGB24read "#FFFFFF")+  , _themePlotBgColor = opaque (sRGB24read "#EAEAF2")+  , _themeGridLineColor = opaque (sRGB24read "#FFFFFF")+  , _themeFontFamily = "Verdana"+  , _themeFontSize = 14+  , _themeColorCycle =     [ opaque (sRGB24read "#4878CF")     , opaque (sRGB24read "#6ACC65")     , opaque (sRGB24read "#D65F5F")@@ -51,12 +71,12 @@  deepTheme :: Theme deepTheme = Theme-  { bgColor = opaque (sRGB24read "#FFFFFF")-  , plotBgColor = opaque (sRGB24read "#EAEAF2")-  , gridLineColor = opaque (sRGB24read "#FFFFFF")-  , fontFamily = "Verdana"-  , fontSize = 14-  , colorCycle =+  { _themeBgColor = opaque (sRGB24read "#FFFFFF")+  , _themePlotBgColor = opaque (sRGB24read "#EAEAF2")+  , _themeGridLineColor = opaque (sRGB24read "#FFFFFF")+  , _themeFontFamily = "Verdana"+  , _themeFontSize = 14+  , _themeColorCycle =     [ opaque (sRGB24read "#4C72B0")     , opaque (sRGB24read "#55A868")     , opaque (sRGB24read "#C44E52")@@ -68,10 +88,10 @@  cleanTheme :: Theme cleanTheme = def-  { bgColor = opaque (sRGB24read "#FFFFFF")-  , plotBgColor = opaque (sRGB24read "#FFFFFF")-  , gridLineColor = opaque (sRGB24read "#EEEEEE")-  , colorCycle =+  { _themeBgColor = opaque (sRGB24read "#FFFFFF")+  , _themePlotBgColor = opaque (sRGB24read "#FFFFFF")+  , _themeGridLineColor = opaque (sRGB24read "#EEEEEE")+  , _themeColorCycle =     [ opaque (sRGB24read "#1776B6")     , opaque (sRGB24read "#FF962A")     , opaque (sRGB24read "#24A122")@@ -80,20 +100,25 @@     ]   } -getBgColor :: Theme -> AlphaColour Double-getBgColor = bgColor--getPlotBgColor :: Theme -> AlphaColour Double-getPlotBgColor = plotBgColor--getGridLineColor :: Theme -> AlphaColour Double-getGridLineColor = gridLineColor+------------------------+-- Color helpers+------------------------ -getColorCycle :: Theme -> [AlphaColour Double]-getColorCycle = colorCycle+hexToRgb :: String -> AmbyColor+hexToRgb s = CustomColor $ opaque (sRGB24read s) -getFontFamily :: Theme -> String-getFontFamily = fontFamily+hexToRgba :: String -> Double -> AmbyColor+hexToRgba s a = CustomColor $ withOpacity (sRGB24read s) a -getFontSize :: Theme -> Double-getFontSize = fontSize+-- | Conversion from Amby Api 'Color' to  underlying 'Colour' type.+toColour :: AmbyColor -> AlphaColour Double -> AlphaColour Double+toColour DefaultColor d = d+toColour (CustomColor c) _ = c+toColour B _ = opaque (sRGB24read "#4878CF")+toColour G _ = opaque (sRGB24read "#6ACC65")+toColour R _ = opaque (sRGB24read "#D65F5F")+toColour M _ = opaque (sRGB24read "#B47CC7")+toColour Y _ = opaque (sRGB24read "#C4AD66")+toColour C _ = opaque (sRGB24read "#77BEDB")+toColour K _ = opaque (sRGB24read "#000000")+toColour W _ = opaque (sRGB24read "#FFFFFF")

@@ -1,12 +1,15 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} module Amby.Types   ( AmbyContainer(..)   , AmbyState   , AmbyChart -  -- * Accessors+  -- * General accessors   , takeTheme   , theme   , xlim@@ -16,40 +19,138 @@   , getLayout   , getSize   , putLayout+  , linewidth+  , histLinewidth+  , kdeLinewidth+  , rugLinewidth++  -- * Plot options+  , PlotOpts+  , PlotEqOpts+  , DistPlotOpts+  , KdePlotOpts+  , RugPlotOpts+  , Bandwidth(..)+  , Axis(..)+  , bins+  , hist+  , rug+  , rugHeight+  , cut+  , shade+  , kde+  , axis+  , height+  , gridsize+  , bw+  , color   )   where  import Control.Monad.State++import Control.Lens import Data.Default.Class-import Graphics.Rendering.Chart.Easy hiding (plot)+import Graphics.Rendering.Chart.Easy (EC, Layout)+import qualified Graphics.Rendering.Chart.Easy as Chart import Graphics.Rendering.Chart.Backend.Cairo (FileOptions(..)) +import Amby.Compatibility.HistogramPlot import Amby.Theme import Amby.Style +-----------------------------------+-- Parameter option types+-----------------------------------++data Axis = XAxis | YAxis deriving (Show, Eq)+data Bandwidth = Scott | BwScalar Double deriving (Show, Eq)++data PlotOpts = PlotOpts+  { _plotOptsColor :: AmbyColor+  , _plotOptsLinewidth :: Double+  } deriving (Show)+makeFields ''PlotOpts++data PlotEqOpts = PlotEqOpts+  { _plotEqOptsColor :: AmbyColor+  , _plotEqOptsLinewidth :: Double+  } deriving (Show)+makeFields ''PlotEqOpts++data DistPlotOpts = DistPlotOpts+  { _distPlotOptsRug :: Bool+  , _distPlotOptsKde :: Bool+  , _distPlotOptsHist :: Bool+  , _distPlotOptsColor :: AmbyColor++  -- hist opts+  , _distPlotOptsHistLinewidth :: Double+  , _distPlotOptsBins :: Int++  -- kde opts+  , _distPlotOptsShade :: Bool+  , _distPlotOptsBw :: Bandwidth+  , _distPlotOptsCut :: Double+  , _distPlotOptsAxis :: Axis+  , _distPlotOptsGridsize :: Int+  , _distPlotOptsKdeLinewidth :: Double++  -- rug opts+  , _distPlotOptsRugHeight :: Double+  , _distPlotOptsRugLinewidth :: Double+  } deriving (Show)+makeFields ''DistPlotOpts++data KdePlotOpts = KdePlotOpts+  { _kdePlotOptsShade :: Bool+  , _kdePlotOptsBw :: Bandwidth+  , _kdePlotOptsAxis :: Axis+  , _kdePlotOptsGridsize :: Int+  , _kdePlotOptsColor :: AmbyColor+  , _kdePlotOptsLinewidth :: Double+  , _kdePlotOptsCut :: Double+  } deriving (Show)+makeFields ''KdePlotOpts++data RugPlotOpts = RugPlotOpts+  { _rugPlotOptsHeight :: Double+  , _rugPlotOptsAxis :: Axis+  , _rugPlotOptsColor :: AmbyColor+  , _rugPlotOptsLinewidth :: Double+  }+makeFields ''RugPlotOpts++-----------------------------------+-- Main types+-----------------------------------+ data AmbyState = AmbyState   { _asThemeState :: Theme   , _asLayoutState :: EC (Layout Double Double) ()   , _asSize :: (Int, Int)   }--instance Default AmbyState where-  def = AmbyState-    { _asThemeState = def-    , _asLayoutState = do-      setColors (getColorCycle def)-      setThemeStyles def-    , _asSize = _fo_size def-    }--$( makeLenses ''AmbyState)+makeLenses ''AmbyState  type AmbyChart a = State AmbyState a -class AmbyContainer c a | c -> a where-  plot :: c -> c -> AmbyChart ()-  plotEq :: c -> (a -> a) -> AmbyChart ()+class AmbyContainer c where+  type Value c :: *+  plot :: c -> c -> State PlotOpts () -> AmbyChart ()+  plot' :: c -> c -> AmbyChart ()+  plotEq :: c -> (Value c -> Value c) -> State PlotEqOpts () -> AmbyChart ()+  plotEq' :: c -> (Value c -> Value c) -> AmbyChart ()+  distPlot :: c -> State DistPlotOpts () -> AmbyChart ()+  distPlot' :: c -> AmbyChart ()+  kdePlot :: c -> State KdePlotOpts () -> AmbyChart ()+  kdePlot' :: c -> AmbyChart ()+  rugPlot :: c -> State RugPlotOpts () -> AmbyChart()+  rugPlot' :: c -> AmbyChart () +-----------------------------------+-- General options+-----------------------------------+ getLayout :: AmbyState -> EC (Layout Double Double) () getLayout s = s ^. asLayoutState @@ -75,7 +176,7 @@   l <- use asLayoutState   asLayoutState .= do     l-    setColors (getColorCycle t)+    Chart.setColors $ t ^. colorCycle     setThemeStyles t   asThemeState .= t @@ -84,17 +185,92 @@   l <- use asLayoutState   asLayoutState .= do     l-    layout_x_axis . laxis_generate .= scaledAxis def rs+    Chart.layout_x_axis . Chart.laxis_generate .= scaledAxisCustom def rs  ylim :: (Double, Double) -> AmbyChart () ylim rs = do   l <- use asLayoutState   asLayoutState .= do     l-    layout_y_axis . laxis_generate .= scaledAxis def rs+    Chart.layout_y_axis . Chart.laxis_generate .= scaledAxisCustom def rs  size :: (Int, Int) -> AmbyChart ()-size rs = do-  l <- use asSize-  asSize .= rs+size rs = asSize .= rs +--------------------+-- Default instances+--------------------++instance Default AmbyState where+  def = AmbyState+    { _asThemeState = def+    , _asLayoutState = do+      Chart.setColors $ (def :: Theme) ^. colorCycle+      setThemeStyles def+    , _asSize = _fo_size def+    }++instance Default (PlotHist x Double) where+  def = PlotHist+    { _plot_hist_bins = 20+    , _plot_hist_title       = ""+    , _plot_hist_values      = []+    , _plot_hist_no_zeros    = False+    , _plot_hist_range       = Nothing+    , _plot_hist_drop_lines  = False+    , _plot_hist_line_style  = def+    , _plot_hist_fill_style  = def+    , _plot_hist_norm_func   = (\a b -> fromIntegral b / a)+    , _plot_hist_vertical    = False+    }++instance Default PlotOpts where+  def = PlotOpts+    { _plotOptsColor = DefaultColor+    , _plotOptsLinewidth = 2.5+    }++instance Default PlotEqOpts where+  def = PlotEqOpts+    { _plotEqOptsColor = DefaultColor+    , _plotEqOptsLinewidth = 2.5+    }++instance Default DistPlotOpts where+  def = DistPlotOpts+    { _distPlotOptsRug = False+    , _distPlotOptsHist = True+    , _distPlotOptsKde = True+    , _distPlotOptsBins = 0+    , _distPlotOptsColor = DefaultColor+    , _distPlotOptsHistLinewidth = 2.5+    , _distPlotOptsAxis = XAxis++    , _distPlotOptsShade = False+    , _distPlotOptsBw = Scott+    , _distPlotOptsGridsize = 100+    , _distPlotOptsKdeLinewidth = 2.5+    , _distPlotOptsCut = 3++    , _distPlotOptsRugHeight = 0.05+    , _distPlotOptsRugLinewidth = 1.2+    }++instance Default KdePlotOpts where+  def = KdePlotOpts+    { _kdePlotOptsShade = False+    , _kdePlotOptsBw = Scott+    , _kdePlotOptsGridsize = 100+    , _kdePlotOptsAxis = XAxis+    , _kdePlotOptsColor = DefaultColor+    , _kdePlotOptsLinewidth = 2.5+    , _kdePlotOptsCut = 3+    }++instance Default RugPlotOpts where+  def = RugPlotOpts+    { _rugPlotOptsHeight = 0.05+    , _rugPlotOptsAxis = XAxis+    , _rugPlotOptsColor = DefaultColor+    , _rugPlotOptsLinewidth = 1.2+    }

@@ -1,2 +1,22 @@+import qualified Data.Vector.Unboxed as U++import Test.DocTest+import Test.Tasty+import Test.Tasty.HUnit++import qualified Amby as Am+ main :: IO ()-main = putStrLn "Test suite not yet implemented"+main = do+  doctest+    [ "src/Amby/Numeric.hs"+    ]+  defaultMain tests++tests :: TestTree+tests = testGroup "Unit tests"+  [ testCase "linspace vector generation" $+      Am.linspace 0 5 6 @?= U.fromList [0.0, 1.0, 2.0, 3.0, 4.0, 5.0]+  , testCase "arange vector generation" $+      Am.arange 0 5 1 @?= U.fromList [0.0, 1.0, 2.0, 3.0, 4.0, 5.0]+  ]