{-# 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.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
      forall x y. PlotHist x y -> String
_plot_hist_title                :: String

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

      -- | Values to histogram
    , forall x y. 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.
    , forall x y. 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.
    , forall x y. PlotHist x y -> Maybe (x, x)
_plot_hist_range                :: Maybe (x,x)

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

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

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

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

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

-- | The default style is an unnormalized histogram of 20 bins.
defaultPlotHist :: PlotHist x Int
defaultPlotHist :: forall x. PlotHist x Int
defaultPlotHist = 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       = 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   = forall a b. a -> b -> a
const forall a. a -> a
id
                           }

-- | @defaultPlotHist@ but with real counts
defaultFloatPlotHist :: PlotHist x Double
defaultFloatPlotHist :: forall x. PlotHist x Double
defaultFloatPlotHist = forall x. PlotHist x Int
defaultPlotHist { _plot_hist_norm_func :: Double -> Int -> Double
_plot_hist_norm_func = forall a b. a -> b -> a
const 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 :: forall x. PlotHist x Double
defaultNormedPlotHist = forall x. PlotHist x Int
defaultPlotHist { _plot_hist_norm_func :: Double -> Int -> Double
_plot_hist_norm_func = \Double
n Int
y->forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
y forall a. Fractional a => a -> a -> a
/ Double
n }

defaultFillStyle :: FillStyle
defaultFillStyle :: FillStyle
defaultFillStyle = AlphaColour Double -> FillStyle
solidFillStyle (forall a. Num a => Colour a -> AlphaColour a
opaque forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Colour a -> AlphaColour a
opaque 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 :: forall x y. (RealFrac x, Num y, Ord y) => PlotHist x y -> Plot x y
histToPlot PlotHist x y
p = Plot {
        _plot_render :: PointMapFn x y -> BackendProgram ()
_plot_render      = 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      = [(forall x y. PlotHist x y -> String
_plot_hist_title PlotHist x y
p, forall x y. PlotHist x y -> Rect -> BackendProgram ()
renderPlotLegendHist PlotHist x y
p)],
        _plot_all_points :: ([x], [y])
_plot_all_points  = forall a b. [(a, b)] -> ([a], [b])
unzip
                            forall a b. (a -> b) -> a -> b
$ 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)
                                                        ])
                            forall a b. (a -> b) -> a -> b
$ 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 :: forall x y.
(RealFrac x, Num y) =>
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)
                                forall a b. (a -> b) -> a -> b
$ Point -> Path -> Path
LineTo (x -> y -> Point
pt x
x2 y
y)
                                forall a b. (a -> b) -> a -> b
$ Point -> Path -> Path
LineTo (x -> y -> Point
pt x
x2 y
0)
                                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)
                                forall a b. (a -> b) -> a -> b
$ Point -> Path -> Path
LineTo (x -> y -> Point
pt x
x2 y
y)
                                forall a b. (a -> b) -> a -> b
$ [((x, x), y)] -> Path
go [((x, x), y)]
rest
          go []                 = Path
End
          ((x
xb,x
_),y
_) = forall a. [a] -> a
head [((x, x), y)]
bins
          pt :: x -> y -> Point
pt x
x y
y = PointMapFn x y
pmap (forall a. a -> Limit a
LValue x
x, forall a. a -> Limit a
LValue y
y)

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

renderPlotLegendHist :: PlotHist x y -> Rect -> BackendProgram ()
renderPlotLegendHist :: forall x y. PlotHist x y -> Rect -> BackendProgram ()
renderPlotLegendHist PlotHist x y
p (Rect Point
p1 Point
p2) =
    forall a. LineStyle -> BackendProgram a -> BackendProgram a
withLineStyle (forall x y. PlotHist x y -> LineStyle
_plot_hist_line_style PlotHist x y
p) forall a b. (a -> b) -> a -> b
$
        let y :: Double
y = (Point -> Double
p_y Point
p1 forall a. Num a => a -> a -> a
+ Point -> Double
p_y Point
p2) forall a. Fractional a => a -> a -> a
/ Double
2
        in Path -> BackendProgram ()
strokePath forall a b. (a -> b) -> a -> b
$ Double -> Double -> Path
moveTo' (Point -> Double
p_x Point
p1) Double
y 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 :: forall x y.
(RealFrac x, Num y, Ord y) =>
PlotHist x y -> [((x, x), y)]
histToBins PlotHist x y
hist =
    forall {a}. [(a, y)] -> [(a, y)]
filter_zeros forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [(x, x)]
bounds forall a b. (a -> b) -> a -> b
$ [y]
counts
    where n :: Int
n = forall x y. PlotHist x y -> Int
_plot_hist_bins PlotHist x y
hist
          (x
a,x
b) = forall x y. RealFrac x => PlotHist x y -> (x, x)
realHistRange PlotHist x y
hist
          dx :: Double
dx = forall a b. (Real a, Fractional b) => a -> b
realToFrac (x
bforall a. Num a => a -> a -> a
-x
a) forall a. Fractional a => a -> a -> a
/ forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
n
          bounds :: [(x, x)]
bounds = forall a. RealFrac a => a -> a -> Int -> [Range a]
binBounds x
a x
b Int
n
          values :: Vector x
values = forall a. [a] -> Vector a
V.fromList (forall x y. PlotHist x y -> [x]
_plot_hist_values PlotHist x y
hist)
          filter_zeros :: [(a, y)] -> [(a, y)]
filter_zeros | forall x y. PlotHist x y -> Bool
_plot_hist_no_zeros PlotHist x y
hist  = forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
_,y
c)->y
c forall a. Ord a => a -> a -> Bool
> y
0)
                       | Bool
otherwise                 = forall a. a -> a
id
          norm :: Double
norm = Double
dx forall a. Num a => a -> a -> a
* forall a b. (Real a, Fractional b) => a -> b
realToFrac (forall a. Vector a -> Int
V.length Vector x
values)
          normalize :: Int -> y
normalize = forall x y. PlotHist x y -> Double -> Int -> y
_plot_hist_norm_func PlotHist x y
hist Double
norm
          counts :: [y]
counts = forall a. Vector a -> [a]
V.toList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Vector a -> Vector b
V.map (Int -> y
normalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
                   forall a b. (a -> b) -> a -> b
$ forall w a.
(Num w, RealFrac a) =>
Vector (Range a) -> [(w, a)] -> Vector (Range a, w)
histWithBins (forall a. [a] -> Vector a
V.fromList [(x, x)]
bounds)
                   forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. a -> [a]
repeat Int
1) (forall a. Vector a -> [a]
V.toList Vector x
values)

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

$( makeLenses ''PlotHist )