diff --git a/amby.cabal b/amby.cabal --- a/amby.cabal +++ b/amby.cabal @@ -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 - - to quickly display attractive visualizations within GHCi. +description: <> + <> + <> + . + <> + <> + <> + . + A statistics visualization library built on top of + inspired by + . 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 + + 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 diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import Amby - -main :: IO () -main = return () diff --git a/src/Amby.hs b/src/Amby.hs --- a/src/Amby.hs +++ b/src/Amby.hs @@ -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 () diff --git a/src/Amby/Compatibility/HistogramNumeric.hs b/src/Amby/Compatibility/HistogramNumeric.hs new file mode 100644 --- /dev/null +++ b/src/Amby/Compatibility/HistogramNumeric.hs @@ -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 diff --git a/src/Amby/Compatibility/HistogramPlot.hs b/src/Amby/Compatibility/HistogramPlot.hs new file mode 100644 --- /dev/null +++ b/src/Amby/Compatibility/HistogramPlot.hs @@ -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 ) diff --git a/src/Amby/Display.hs b/src/Amby/Display.hs --- a/src/Amby/Display.hs +++ b/src/Amby/Display.hs @@ -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." diff --git a/src/Amby/Numeric.hs b/src/Amby/Numeric.hs --- a/src/Amby/Numeric.hs +++ b/src/Amby/Numeric.hs @@ -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 diff --git a/src/Amby/Plot.hs b/src/Amby/Plot.hs --- a/src/Amby/Plot.hs +++ b/src/Amby/Plot.hs @@ -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 diff --git a/src/Amby/Style.hs b/src/Amby/Style.hs --- a/src/Amby/Style.hs +++ b/src/Amby/Style.hs @@ -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)] + } diff --git a/src/Amby/Theme.hs b/src/Amby/Theme.hs --- a/src/Amby/Theme.hs +++ b/src/Amby/Theme.hs @@ -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") diff --git a/src/Amby/Types.hs b/src/Amby/Types.hs --- a/src/Amby/Types.hs +++ b/src/Amby/Types.hs @@ -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 + } diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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] + ]