Skip to content

Commit

Permalink
Port to lens-y Chart 1.0
Browse files Browse the repository at this point in the history
  • Loading branch information
@bgamari
bgamari committed May 7, 2013
1 parent fe56501 commit 9c28b74
Show file tree
Hide file tree
Showing 3 changed files with 55 additions and 58 deletions.
81 changes: 40 additions & 41 deletions Graphics/Rendering/Chart/Plot/Histogram.hs
View file
Expand Up @@ -17,11 +17,11 @@ module Graphics.Rendering.Chart.Plot.Histogram ( -- * Histograms
, plot_hist_fill_style
) where

import Control.Monad (when)
import Control.Monad (when)
import Data.List (transpose)
import qualified Data.Vector as V

import Data.Accessor.Template
import Control.Lens
import Graphics.Rendering.Chart.Types
import Graphics.Rendering.Chart.Axis.Types
import Graphics.Rendering.Chart.Plot.Types
Expand All @@ -33,49 +33,49 @@ import Data.Colour.SRGB (sRGB)

import Numeric.Histogram

data PlotHist x y = PlotHist { plot_hist_title_ :: String
, plot_hist_bins_ :: Int
, plot_hist_values_ :: V.Vector x
, plot_hist_no_zeros_ :: Bool
, plot_hist_range_ :: Maybe (x,x)
, plot_hist_drop_lines_ :: Bool
, plot_hist_fill_style_ :: CairoFillStyle
, plot_hist_line_style_ :: CairoLineStyle
, plot_hist_norm_func_ :: Double -> Int -> y
data PlotHist x y = PlotHist { _plot_hist_title :: String
, _plot_hist_bins :: Int
, _plot_hist_values :: V.Vector x
, _plot_hist_no_zeros :: Bool
, _plot_hist_range :: Maybe (x,x)
, _plot_hist_drop_lines :: Bool
, _plot_hist_fill_style :: CairoFillStyle
, _plot_hist_line_style :: CairoLineStyle
, _plot_hist_norm_func :: Double -> Int -> y
}

defaultPlotHist :: PlotHist x Int
defaultPlotHist = PlotHist { plot_hist_bins_ = 20
, plot_hist_title_ = ""
, plot_hist_values_ = V.empty
, 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 = PlotHist { _plot_hist_bins = 20
, _plot_hist_title = ""
, _plot_hist_values = V.empty
, _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
}

defaultFloatPlotHist :: PlotHist x Double
defaultFloatPlotHist = defaultPlotHist { plot_hist_norm_func_ = const realToFrac }
defaultFloatPlotHist = defaultPlotHist { _plot_hist_norm_func = const realToFrac }

defaultNormedPlotHist :: PlotHist x Double
defaultNormedPlotHist = defaultPlotHist { plot_hist_norm_func_ = \n y->realToFrac y / n }
defaultNormedPlotHist = defaultPlotHist { _plot_hist_norm_func = \n y->realToFrac y / n }

defaultFillStyle :: CairoFillStyle
defaultFillStyle = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0)

defaultLineStyle :: CairoLineStyle
defaultLineStyle = (solidLine 1 $ opaque blue) {
line_cap_ = C.LineCapButt,
line_join_ = C.LineJoinMiter
_line_cap = C.LineCapButt,
_line_join = C.LineJoinMiter
}

histToPlot :: (RealFrac x, PlotValue 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
_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
}
Expand All @@ -86,13 +86,13 @@ buildHistPath bins = (x1,fromValue 0):f bins
where ((x1,_),_) = head bins
f (((x1,x2),y):[]) = [(x1,y), (x2,y), (x2,fromValue 0)]
f (((x1,x2),y):bins) = (x1,y):(x2,y):f bins

renderPlotHist :: (RealFrac x, PlotValue y) => PlotHist x y -> PointMapFn x y -> CRender ()
renderPlotHist p pmap = preserveCState $ do
setFillStyle (plot_hist_fill_style_ p)
setFillStyle (_plot_hist_fill_style p)
fillPath $ map (mapXY pmap) $ buildHistPath bins
setLineStyle (plot_hist_line_style_ p)
when (plot_hist_drop_lines_ p) $
setLineStyle (_plot_hist_line_style p)
when (_plot_hist_drop_lines p) $
mapM_ (\((x1,x2), y)->drawLines (mapXY pmap) [(x1,fromValue 0), (x1,y)]) $ tail bins
drawLines (mapXY pmap) $ buildHistPath bins
where
Expand All @@ -101,31 +101,30 @@ renderPlotHist p pmap = preserveCState $ do

renderPlotLegendHist :: PlotHist x y -> Rect -> CRender ()
renderPlotLegendHist p r@(Rect p1 p2) = preserveCState $ do
setLineStyle (plot_hist_line_style_ p)
setLineStyle (_plot_hist_line_style p)
let y = (p_y p1 + p_y p2) / 2
strokePath [Point (p_x p1) y, Point (p_x p2) y]

histToBins :: (RealFrac x, PlotValue y) => PlotHist x y -> [((x,x), y)]
histToBins hist =
filter_zeros $ zip bounds $ V.toList counts
where n = plot_hist_bins_ hist
where n = _plot_hist_bins hist
(a,b) = realHistRange hist
dx = realToFrac (b-a) / realToFrac n
bounds = binBounds a b n
values = plot_hist_values_ hist
filter_zeros | plot_hist_no_zeros_ hist = filter (\(b,c)->c>fromValue 0)
values = _plot_hist_values hist
filter_zeros | _plot_hist_no_zeros hist = filter (\(b,c)->c>fromValue 0)
| otherwise = id
norm = dx * realToFrac (V.length values)
normalize = plot_hist_norm_func_ hist $ norm
normalize = _plot_hist_norm_func hist $ norm
counts = 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 = maybe (dmin,dmax) id $ plot_hist_range_ hist
where values = plot_hist_values_ hist
realHistRange hist = maybe (dmin,dmax) id $ _plot_hist_range hist
where values = _plot_hist_values hist
dmin = V.minimum values
dmax = V.maximum values

$( deriveAccessors ''PlotHist )

$( makeLenses ''PlotHist )
18 changes: 8 additions & 10 deletions Test.hs
View file
@@ -1,6 +1,6 @@
module Main where

import Data.Accessor
import Control.Lens
import Graphics.Rendering.Chart
import Graphics.Rendering.Chart.Gtk
import Graphics.Rendering.Chart.Plot.Histogram
Expand All @@ -9,16 +9,14 @@ import qualified Data.Vector as V
values = V.fromList [1,1,2,3, 8,8,8,8, 10] :: V.Vector Double

chart = layout
where hist = plot_hist_values ^= values
$ plot_hist_range ^= Just (0, 10)
$ plot_hist_bins ^= 10
$ plot_hist_drop_lines ^= True
where hist = plot_hist_values .~ values
$ plot_hist_range .~ Just (0, 10)
$ plot_hist_bins .~ 10
$ plot_hist_drop_lines .~ True
$ defaultPlotHist
layout :: Layout1 Double Int
layout = layout1_title ^= "Hello World"
$ layout1_plots ^= [ Left (histToPlot hist)
]
layout = layout1_title .~ "Hello World"
$ layout1_plots .~ [ Left (histToPlot hist) ]
$ defaultLayout1

main = do renderableToWindow (toRenderable chart) 640 480

main = renderableToWindow (toRenderable chart) 640 480
14 changes: 7 additions & 7 deletions chart-histogram.cabal
View file
Expand Up @@ -13,7 +13,7 @@ Version: 0.2
Synopsis: Easily render histograms with Chart

-- A longer description of the package.
-- Description:
-- Description:

-- The license under which the package is released.
License: BSD3
Expand All @@ -29,15 +29,15 @@ Author: Ben Gamari
Maintainer: bgamari.foss@gmail.com

-- A copyright notice.
-- Copyright:
-- Copyright:

Category: Graphics

Build-type: Simple

-- Extra files to be distributed with the package, such as examples or
-- a README.
-- Extra-source-files:
-- Extra-source-files:

-- Constraint on the version of Cabal needed to build this package.
Cabal-version: >=1.2
Expand All @@ -46,10 +46,10 @@ Cabal-version: >=1.2
Library
-- Modules exported by the library.
Exposed-modules: Numeric.Histogram, Graphics.Rendering.Chart.Plot.Histogram

-- Packages needed in order to build this package.
Build-depends: base, vector, Chart, data-accessor, data-accessor-template, colour, cairo
Build-depends: base, vector, Chart >= 1.0, lens, colour, cairo

Executable Test
Main-is: Test.hs
Build-depends: Chart-gtk, data-accessor
Build-depends: Chart-gtk >= 1.0, lens

0 comments on commit 9c28b74

Please sign in to comment.