diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,5 +1,5 @@ Name: Chart -Version: 1.3.3 +Version: 1.4 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006-2014 @@ -19,12 +19,14 @@ Build-depends: base >= 3 && < 5 , old-locale , time, mtl, array - , lens >= 3.9 && < 4.8 + , lens >= 3.9 && < 4.10 , colour >= 2.2.1 && < 2.4 , data-default-class < 0.1 , mtl >= 2.0 && < 2.3 , operational >= 0.2.2 && < 0.3 + , vector >=0.9 && <0.11 + Ghc-options: -Wall -fno-warn-orphans Exposed-modules: @@ -55,14 +57,15 @@ Graphics.Rendering.Chart.Plot.Lines, Graphics.Rendering.Chart.Plot.Vectors, Graphics.Rendering.Chart.Plot.Pie, - Graphics.Rendering.Chart.Plot.Points + Graphics.Rendering.Chart.Plot.Points, + Graphics.Rendering.Chart.Plot.Histogram Graphics.Rendering.Chart.SparkLine Graphics.Rendering.Chart.Backend Graphics.Rendering.Chart.Backend.Impl Graphics.Rendering.Chart.Backend.Types - Graphics.Rendering.Chart.Easy, + Graphics.Rendering.Chart.Easy Graphics.Rendering.Chart.State - + Numeric.Histogram source-repository head type: git location: https://github.com/timbod7/haskell-chart diff --git a/Graphics/Rendering/Chart/Axis/Floating.hs b/Graphics/Rendering/Chart/Axis/Floating.hs --- a/Graphics/Rendering/Chart/Axis/Floating.hs +++ b/Graphics/Rendering/Chart/Axis/Floating.hs @@ -46,6 +46,11 @@ fromValue= id autoAxis = autoScaledAxis def +instance PlotValue Float where + toValue = realToFrac + fromValue= realToFrac + autoAxis = autoScaledAxis def + -- | A wrapper class for doubles used to indicate they are to -- be plotted against a percentage axis. newtype Percent = Percent {unPercent :: Double} diff --git a/Graphics/Rendering/Chart/Plot.hs b/Graphics/Rendering/Chart/Plot.hs --- a/Graphics/Rendering/Chart/Plot.hs +++ b/Graphics/Rendering/Chart/Plot.hs @@ -20,6 +20,7 @@ module Graphics.Rendering.Chart.Plot.Annotation, module Graphics.Rendering.Chart.Plot.AreaSpots, module Graphics.Rendering.Chart.Plot.Pie, + module Graphics.Rendering.Chart.Plot.Histogram, ) where import Graphics.Rendering.Chart.Plot.Types @@ -34,3 +35,4 @@ import Graphics.Rendering.Chart.Plot.Annotation import Graphics.Rendering.Chart.Plot.AreaSpots import Graphics.Rendering.Chart.Plot.Pie +import Graphics.Rendering.Chart.Plot.Histogram diff --git a/Graphics/Rendering/Chart/Plot/Histogram.hs b/Graphics/Rendering/Chart/Plot/Histogram.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Histogram.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances #-} + +module Graphics.Rendering.Chart.Plot.Histogram + ( -- * 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 + ) 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 Control.Lens +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 Numeric.Histogram + +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 + } + +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 + } + +-- | @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, Num y, Ord y) => PlotHist x y -> Plot x y +histToPlot p = Plot { + _plot_render = renderPlotHist p, + _plot_legend = [(_plot_hist_title p, renderPlotLegendHist p)], + _plot_all_points = unzip + $ concatMap (\((x1,x2), y)->[(x1,y), (x2,y)]) + $ histToBins p + } + +buildHistPath :: (RealFrac x, Num y) + => PointMapFn x y -> [((x,x), y)] -> 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) + +renderPlotHist :: (RealFrac x, Num y, Ord y) + => PlotHist x y -> PointMapFn x y -> ChartBackend () +renderPlotHist p pmap + | null bins = return () + | otherwise = do + withFillStyle (_plot_hist_fill_style p) $ + alignFillPath (buildHistPath pmap bins) >>= fillPath + withLineStyle (_plot_hist_line_style p) $ do + when (_plot_hist_drop_lines p) $ + alignStrokePath dropLinesPath >>= strokePath + alignStrokePath (buildHistPath pmap bins) >>= strokePath + where bins = histToBins p + pt x y = pmap (LValue x, LValue y) + dropLinesPath = F.foldMap (\((x1,_), y)->moveTo (pt x1 0) + <> lineTo (pt x1 y) + ) $ tail bins + +renderPlotLegendHist :: PlotHist x y -> Rect -> ChartBackend () +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) + +-- TODO: Determine more aesthetically pleasing range +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/Numeric/Histogram.hs b/Numeric/Histogram.hs new file mode 100644 --- /dev/null +++ b/Numeric/Histogram.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE PatternGuards #-} + +module Numeric.Histogram ( 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' +binBounds :: RealFrac a => a -> a -> Int -> [Range a] +binBounds a b n = map (\i->(lbound i, lbound (i+1))) [0..n] + 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' +histWithBins :: (Num w, RealFrac a) => V.Vector (Range a) -> [(w, a)] -> V.Vector (Range a, w) +histWithBins bins xs = + let testBin :: RealFrac a => a -> Range a -> Bool + testBin x (a,b) = 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 . snd) $ V.indexed bins1 of + v | V.null v -> return () + v | (idx,_) <- V.head v -> do + n <- MV.read bs idx + MV.write bs idx $! n+w + + counts = runST $ do b <- MV.replicate (V.length bins) 0 + mapM_ (f bins b) xs + V.freeze b + in V.zip bins counts