{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}

module Graphics.Rendering.Chart.Plot.Histogram
  ( -- * Histograms
    PlotHist (..)
  , histToPlot
  , defaultPlotHist
  , defaultFloatPlotHist
  , defaultNormedPlotHist
  , histToBins
    -- * 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
      PlotHist x y -> String
_plot_hist_title                :: String

      -- | Number of bins
    , PlotHist x y -> Int
_plot_hist_bins                 :: Int

      -- | Values to histogram
    , PlotHist x y -> [x]
_plot_hist_values               :: [x]

      -- | Don't attempt to plot bins with zero counts. Useful when
      -- the y-axis is logarithmically scaled.
    , PlotHist x y -> Bool
_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.
    , PlotHist x y -> Maybe (x, x)
_plot_hist_range                :: Maybe (x,x)

      -- | Plot vertical lines between bins
    , PlotHist x y -> Bool
_plot_hist_drop_lines           :: Bool

      -- | Fill style of the bins
    , PlotHist x y -> FillStyle
_plot_hist_fill_style           :: FillStyle

      -- | Line style of the bin outlines
    , PlotHist x y -> LineStyle
_plot_hist_line_style           :: LineStyle

      -- | Normalization function
    , PlotHist x y -> Double -> Int -> y
_plot_hist_norm_func            :: Double -> Int -> y
    }

instance Default (PlotHist x Int) where
    def :: PlotHist x Int
def = PlotHist x Int
forall x. PlotHist x Int
defaultPlotHist

-- | The default style is an unnormalized histogram of 20 bins.
defaultPlotHist :: PlotHist x Int
defaultPlotHist :: PlotHist x Int
defaultPlotHist = PlotHist :: forall x y.
String
-> Int
-> [x]
-> Bool
-> Maybe (x, x)
-> Bool
-> FillStyle
-> LineStyle
-> (Double -> Int -> y)
-> PlotHist x y
PlotHist { _plot_hist_bins :: Int
_plot_hist_bins        = Int
20
                           , _plot_hist_title :: String
_plot_hist_title       = String
""
                           , _plot_hist_values :: [x]
_plot_hist_values      = []
                           , _plot_hist_no_zeros :: Bool
_plot_hist_no_zeros    = Bool
False
                           , _plot_hist_range :: Maybe (x, x)
_plot_hist_range       = Maybe (x, x)
forall a. Maybe a
Nothing
                           , _plot_hist_drop_lines :: Bool
_plot_hist_drop_lines  = Bool
False
                           , _plot_hist_line_style :: LineStyle
_plot_hist_line_style  = LineStyle
defaultLineStyle
                           , _plot_hist_fill_style :: FillStyle
_plot_hist_fill_style  = FillStyle
defaultFillStyle
                           , _plot_hist_norm_func :: Double -> Int -> Int
_plot_hist_norm_func   = (Int -> Int) -> Double -> Int -> Int
forall a b. a -> b -> a
const Int -> Int
forall a. a -> a
id
                           }

-- | @defaultPlotHist@ but with real counts
defaultFloatPlotHist :: PlotHist x Double
defaultFloatPlotHist :: PlotHist x Double
defaultFloatPlotHist = PlotHist x Int
forall x. PlotHist x Int
defaultPlotHist { _plot_hist_norm_func :: Double -> Int -> Double
_plot_hist_norm_func = (Int -> Double) -> Double -> Int -> Double
forall a b. a -> b -> a
const Int -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac }

-- | @defaultPlotHist@ but normalized such that the integral of the
-- histogram is one.
defaultNormedPlotHist :: PlotHist x Double
defaultNormedPlotHist :: PlotHist x Double
defaultNormedPlotHist = PlotHist x Int
forall x. PlotHist x Int
defaultPlotHist { _plot_hist_norm_func :: Double -> Int -> Double
_plot_hist_norm_func = \Double
n Int
y->Int -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
y Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
n }

defaultFillStyle :: FillStyle
defaultFillStyle :: FillStyle
defaultFillStyle = AlphaColour Double -> FillStyle
solidFillStyle (Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque (Colour Double -> AlphaColour Double)
-> Colour Double -> AlphaColour Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Colour Double
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Double
0.5 Double
0.5 Double
1.0)

defaultLineStyle :: LineStyle
defaultLineStyle :: LineStyle
defaultLineStyle = (Double -> AlphaColour Double -> LineStyle
solidLine Double
1 (AlphaColour Double -> LineStyle)
-> AlphaColour Double -> LineStyle
forall a b. (a -> b) -> a -> b
$ Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque Colour Double
forall a. (Ord a, Floating a) => Colour a
blue)
     { _line_cap :: LineCap
_line_cap  = LineCap
LineCapButt
     , _line_join :: LineJoin
_line_join = LineJoin
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 :: PlotHist x y -> Plot x y
histToPlot PlotHist x y
p = Plot :: forall x y.
(PointMapFn x y -> BackendProgram ())
-> [(String, Rect -> BackendProgram ())] -> ([x], [y]) -> Plot x y
Plot {
        _plot_render :: PointMapFn x y -> BackendProgram ()
_plot_render      = PlotHist x y -> PointMapFn x y -> BackendProgram ()
forall x y.
(RealFrac x, Num y, Ord y) =>
PlotHist x y -> PointMapFn x y -> BackendProgram ()
renderPlotHist PlotHist x y
p,
        _plot_legend :: [(String, Rect -> BackendProgram ())]
_plot_legend      = [(PlotHist x y -> String
forall x y. PlotHist x y -> String
_plot_hist_title PlotHist x y
p, PlotHist x y -> Rect -> BackendProgram ()
forall x y. PlotHist x y -> Rect -> BackendProgram ()
renderPlotLegendHist PlotHist x y
p)],
        _plot_all_points :: ([x], [y])
_plot_all_points  = [(x, y)] -> ([x], [y])
forall a b. [(a, b)] -> ([a], [b])
unzip
                            ([(x, y)] -> ([x], [y])) -> [(x, y)] -> ([x], [y])
forall a b. (a -> b) -> a -> b
$ (((x, x), y) -> [(x, y)]) -> [((x, x), y)] -> [(x, y)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\((x
x1,x
x2), y
y)->[ (x
x1,y
y)
                                                        , (x
x2,y
y)
                                                        , (x
x1,y
0)
                                                        , (x
x2,y
0)
                                                        ])
                            ([((x, x), y)] -> [(x, y)]) -> [((x, x), y)] -> [(x, y)]
forall a b. (a -> b) -> a -> b
$ PlotHist x y -> [((x, x), y)]
forall x y.
(RealFrac x, Num y, Ord y) =>
PlotHist x y -> [((x, x), y)]
histToBins PlotHist x y
p
    }

buildHistPath :: (RealFrac x, Num y)
              => PointMapFn x y -> [((x,x), y)] -> Path
buildHistPath :: PointMapFn x y -> [((x, x), y)] -> Path
buildHistPath PointMapFn x y
_ [] = Path
End
buildHistPath PointMapFn x y
pmap [((x, x), y)]
bins = Point -> Path -> Path
MoveTo (x -> y -> Point
pt x
xb y
0) ([((x, x), y)] -> Path
go [((x, x), y)]
bins)
    where go :: [((x, x), y)] -> Path
go [((x
x1,x
x2),y
y)]      = Point -> Path -> Path
LineTo (x -> y -> Point
pt x
x1 y
y)
                                (Path -> Path) -> Path -> Path
forall a b. (a -> b) -> a -> b
$ Point -> Path -> Path
LineTo (x -> y -> Point
pt x
x2 y
y)
                                (Path -> Path) -> Path -> Path
forall a b. (a -> b) -> a -> b
$ Point -> Path -> Path
LineTo (x -> y -> Point
pt x
x2 y
0)
                                (Path -> Path) -> Path -> Path
forall a b. (a -> b) -> a -> b
$ Path
End
          go (((x
x1,x
x2),y
y):[((x, x), y)]
rest) = Point -> Path -> Path
LineTo (x -> y -> Point
pt x
x1 y
y)
                                (Path -> Path) -> Path -> Path
forall a b. (a -> b) -> a -> b
$ Point -> Path -> Path
LineTo (x -> y -> Point
pt x
x2 y
y)
                                (Path -> Path) -> Path -> Path
forall a b. (a -> b) -> a -> b
$ [((x, x), y)] -> Path
go [((x, x), y)]
rest
          go []                 = Path
End
          ((x
xb,x
_),y
_) = [((x, x), y)] -> ((x, x), y)
forall a. [a] -> a
head [((x, x), y)]
bins
          pt :: x -> y -> Point
pt x
x y
y = PointMapFn x y
pmap (x -> Limit x
forall a. a -> Limit a
LValue x
x, y -> Limit y
forall a. a -> Limit a
LValue y
y)

renderPlotHist :: (RealFrac x, Num y, Ord y)
               => PlotHist x y -> PointMapFn x y -> BackendProgram ()
renderPlotHist :: PlotHist x y -> PointMapFn x y -> BackendProgram ()
renderPlotHist PlotHist x y
p PointMapFn x y
pmap
    | [((x, x), y)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((x, x), y)]
bins = () -> BackendProgram ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = do
        FillStyle -> BackendProgram () -> BackendProgram ()
forall a. FillStyle -> BackendProgram a -> BackendProgram a
withFillStyle (PlotHist x y -> FillStyle
forall x y. PlotHist x y -> FillStyle
_plot_hist_fill_style PlotHist x y
p) (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$
            Path -> BackendProgram Path
alignFillPath (PointMapFn x y -> [((x, x), y)] -> Path
forall x y.
(RealFrac x, Num y) =>
PointMapFn x y -> [((x, x), y)] -> Path
buildHistPath PointMapFn x y
pmap [((x, x), y)]
bins) BackendProgram Path
-> (Path -> BackendProgram ()) -> BackendProgram ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Path -> BackendProgram ()
fillPath
        LineStyle -> BackendProgram () -> BackendProgram ()
forall a. LineStyle -> BackendProgram a -> BackendProgram a
withLineStyle (PlotHist x y -> LineStyle
forall x y. PlotHist x y -> LineStyle
_plot_hist_line_style PlotHist x y
p) (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ do
            Bool -> BackendProgram () -> BackendProgram ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PlotHist x y -> Bool
forall x y. PlotHist x y -> Bool
_plot_hist_drop_lines PlotHist x y
p) (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$
                Path -> BackendProgram Path
alignStrokePath Path
dropLinesPath BackendProgram Path
-> (Path -> BackendProgram ()) -> BackendProgram ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Path -> BackendProgram ()
strokePath
            Path -> BackendProgram Path
alignStrokePath (PointMapFn x y -> [((x, x), y)] -> Path
forall x y.
(RealFrac x, Num y) =>
PointMapFn x y -> [((x, x), y)] -> Path
buildHistPath PointMapFn x y
pmap [((x, x), y)]
bins) BackendProgram Path
-> (Path -> BackendProgram ()) -> BackendProgram ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Path -> BackendProgram ()
strokePath
    where bins :: [((x, x), y)]
bins = PlotHist x y -> [((x, x), y)]
forall x y.
(RealFrac x, Num y, Ord y) =>
PlotHist x y -> [((x, x), y)]
histToBins PlotHist x y
p
          pt :: x -> y -> Point
pt x
x y
y = PointMapFn x y
pmap (x -> Limit x
forall a. a -> Limit a
LValue x
x, y -> Limit y
forall a. a -> Limit a
LValue y
y)
          dropLinesPath :: Path
dropLinesPath = (((x, x), y) -> Path) -> [((x, x), y)] -> Path
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (\((x
x1,x
_), y
y)->Point -> Path
moveTo (x -> y -> Point
pt x
x1 y
0)
                                                Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Point -> Path
lineTo (x -> y -> Point
pt x
x1 y
y)
                                    ) ([((x, x), y)] -> Path) -> [((x, x), y)] -> Path
forall a b. (a -> b) -> a -> b
$ [((x, x), y)] -> [((x, x), y)]
forall a. [a] -> [a]
tail [((x, x), y)]
bins

renderPlotLegendHist :: PlotHist x y -> Rect -> BackendProgram ()
renderPlotLegendHist :: PlotHist x y -> Rect -> BackendProgram ()
renderPlotLegendHist PlotHist x y
p (Rect Point
p1 Point
p2) =
    LineStyle -> BackendProgram () -> BackendProgram ()
forall a. LineStyle -> BackendProgram a -> BackendProgram a
withLineStyle (PlotHist x y -> LineStyle
forall x y. PlotHist x y -> LineStyle
_plot_hist_line_style PlotHist x y
p) (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$
        let y :: Double
y = (Point -> Double
p_y Point
p1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Point -> Double
p_y Point
p2) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
        in Path -> BackendProgram ()
strokePath (Path -> BackendProgram ()) -> Path -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Path
moveTo' (Point -> Double
p_x Point
p1) Double
y Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Point -> Double
p_x Point
p2) Double
y

-- | Obtain the bin dimensions of a given @PlotHist@.
histToBins :: (RealFrac x, Num y, Ord y) => PlotHist x y -> [((x,x), y)]
histToBins :: PlotHist x y -> [((x, x), y)]
histToBins PlotHist x y
hist =
    [((x, x), y)] -> [((x, x), y)]
forall a. [(a, y)] -> [(a, y)]
filter_zeros ([((x, x), y)] -> [((x, x), y)]) -> [((x, x), y)] -> [((x, x), y)]
forall a b. (a -> b) -> a -> b
$ [(x, x)] -> [y] -> [((x, x), y)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(x, x)]
bounds ([y] -> [((x, x), y)]) -> [y] -> [((x, x), y)]
forall a b. (a -> b) -> a -> b
$ [y]
counts
    where n :: Int
n = PlotHist x y -> Int
forall x y. PlotHist x y -> Int
_plot_hist_bins PlotHist x y
hist
          (x
a,x
b) = PlotHist x y -> (x, x)
forall x y. RealFrac x => PlotHist x y -> (x, x)
realHistRange PlotHist x y
hist
          dx :: Double
dx = x -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (x
bx -> x -> x
forall a. Num a => a -> a -> a
-x
a) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
n
          bounds :: [(x, x)]
bounds = x -> x -> Int -> [(x, x)]
forall a. RealFrac a => a -> a -> Int -> [Range a]
binBounds x
a x
b Int
n
          values :: Vector x
values = [x] -> Vector x
forall a. [a] -> Vector a
V.fromList (PlotHist x y -> [x]
forall x y. PlotHist x y -> [x]
_plot_hist_values PlotHist x y
hist)
          filter_zeros :: [(a, y)] -> [(a, y)]
filter_zeros | PlotHist x y -> Bool
forall x y. PlotHist x y -> Bool
_plot_hist_no_zeros PlotHist x y
hist  = ((a, y) -> Bool) -> [(a, y)] -> [(a, y)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
_,y
c)->y
c y -> y -> Bool
forall a. Ord a => a -> a -> Bool
> y
0)
                       | Bool
otherwise                 = [(a, y)] -> [(a, y)]
forall a. a -> a
id
          norm :: Double
norm = Double
dx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Vector x -> Int
forall a. Vector a -> Int
V.length Vector x
values)
          normalize :: Int -> y
normalize = PlotHist x y -> Double -> Int -> y
forall x y. PlotHist x y -> Double -> Int -> y
_plot_hist_norm_func PlotHist x y
hist Double
norm
          counts :: [y]
counts = Vector y -> [y]
forall a. Vector a -> [a]
V.toList (Vector y -> [y]) -> Vector y -> [y]
forall a b. (a -> b) -> a -> b
$ (((x, x), Int) -> y) -> Vector ((x, x), Int) -> Vector y
forall a b. (a -> b) -> Vector a -> Vector b
V.map (Int -> y
normalize (Int -> y) -> (((x, x), Int) -> Int) -> ((x, x), Int) -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((x, x), Int) -> Int
forall a b. (a, b) -> b
snd)
                   (Vector ((x, x), Int) -> Vector y)
-> Vector ((x, x), Int) -> Vector y
forall a b. (a -> b) -> a -> b
$ Vector (x, x) -> [(Int, x)] -> Vector ((x, x), Int)
forall w a.
(Num w, RealFrac a) =>
Vector (Range a) -> [(w, a)] -> Vector (Range a, w)
histWithBins ([(x, x)] -> Vector (x, x)
forall a. [a] -> Vector a
V.fromList [(x, x)]
bounds)
                   ([(Int, x)] -> Vector ((x, x), Int))
-> [(Int, x)] -> Vector ((x, x), Int)
forall a b. (a -> b) -> a -> b
$ [Int] -> [x] -> [(Int, x)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int]
forall a. a -> [a]
repeat Int
1) (Vector x -> [x]
forall a. Vector a -> [a]
V.toList Vector x
values)

realHistRange :: (RealFrac x) => PlotHist x y -> (x,x)
realHistRange :: PlotHist x y -> (x, x)
realHistRange PlotHist x y
hist = (x, x) -> Maybe (x, x) -> (x, x)
forall a. a -> Maybe a -> a
fromMaybe (x, x)
range (Maybe (x, x) -> (x, x)) -> Maybe (x, x) -> (x, x)
forall a b. (a -> b) -> a -> b
$ PlotHist x y -> Maybe (x, x)
forall x y. PlotHist x y -> Maybe (x, x)
_plot_hist_range PlotHist x y
hist
    where values :: Vector x
values = [x] -> Vector x
forall a. [a] -> Vector a
V.fromList (PlotHist x y -> [x]
forall x y. PlotHist x y -> [x]
_plot_hist_values PlotHist x y
hist)
          range :: (x, x)
range = if Vector x -> Bool
forall a. Vector a -> Bool
V.null Vector x
values
                    then (x
0,x
0)
                    else (Vector x -> x
forall a. Ord a => Vector a -> a
V.minimum Vector x
values, Vector x -> x
forall a. Ord a => Vector a -> a
V.maximum Vector x
values)

$( makeLenses ''PlotHist )