{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}
module Graphics.Rendering.Chart.Plot.Histogram
(
PlotHist (..)
, histToPlot
, defaultPlotHist
, defaultFloatPlotHist
, defaultNormedPlotHist
, histToBins
, 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
{
forall x y. PlotHist x y -> String
_plot_hist_title :: String
, forall x y. PlotHist x y -> Int
_plot_hist_bins :: Int
, forall x y. PlotHist x y -> [x]
_plot_hist_values :: [x]
, forall x y. PlotHist x y -> Bool
_plot_hist_no_zeros :: Bool
, forall x y. PlotHist x y -> Maybe (x, x)
_plot_hist_range :: Maybe (x,x)
, forall x y. PlotHist x y -> Bool
_plot_hist_drop_lines :: Bool
, forall x y. PlotHist x y -> FillStyle
_plot_hist_fill_style :: FillStyle
, forall x y. PlotHist x y -> LineStyle
_plot_hist_line_style :: LineStyle
, 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
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
}
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 }
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
}
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
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 )