Chart 1.2.4 → 1.9.5
raw patch · 37 files changed
Files
- Chart.cabal +23/−9
- Graphics/Rendering/Chart.hs +11/−5
- Graphics/Rendering/Chart/Axis.hs +2/−2
- Graphics/Rendering/Chart/Axis/Floating.hs +129/−45
- Graphics/Rendering/Chart/Axis/Indexed.hs +10/−6
- Graphics/Rendering/Chart/Axis/Int.hs +58/−2
- Graphics/Rendering/Chart/Axis/LocalTime.hs +29/−24
- Graphics/Rendering/Chart/Axis/Time.hs +316/−0
- Graphics/Rendering/Chart/Axis/Types.hs +23/−17
- Graphics/Rendering/Chart/Axis/Unit.hs +1/−0
- Graphics/Rendering/Chart/Backend.hs +3/−6
- Graphics/Rendering/Chart/Backend/Impl.hs +36/−40
- Graphics/Rendering/Chart/Backend/Types.hs +3/−7
- Graphics/Rendering/Chart/Drawing.hs +72/−60
- Graphics/Rendering/Chart/Easy.hs +108/−0
- Graphics/Rendering/Chart/Geometry.hs +60/−40
- Graphics/Rendering/Chart/Grid.hs +3/−3
- Graphics/Rendering/Chart/Layout.hs +187/−144
- Graphics/Rendering/Chart/Legend.hs +32/−13
- Graphics/Rendering/Chart/Plot.hs +4/−0
- Graphics/Rendering/Chart/Plot/Annotation.hs +39/−14
- Graphics/Rendering/Chart/Plot/AreaSpots.hs +6/−16
- Graphics/Rendering/Chart/Plot/Bars.hs +288/−99
- Graphics/Rendering/Chart/Plot/Candle.hs +7/−13
- Graphics/Rendering/Chart/Plot/ErrBars.hs +6/−12
- Graphics/Rendering/Chart/Plot/FillBetween.hs +9/−8
- Graphics/Rendering/Chart/Plot/Histogram.hs +188/−0
- Graphics/Rendering/Chart/Plot/Lines.hs +4/−9
- Graphics/Rendering/Chart/Plot/Pie.hs +228/−244
- Graphics/Rendering/Chart/Plot/Points.hs +2/−7
- Graphics/Rendering/Chart/Plot/Types.hs +5/−2
- Graphics/Rendering/Chart/Plot/Vectors.hs +145/−0
- Graphics/Rendering/Chart/Renderable.hs +64/−52
- Graphics/Rendering/Chart/SparkLine.hs +1/−1
- Graphics/Rendering/Chart/State.hs +108/−0
- Graphics/Rendering/Chart/Utils.hs +10/−2
- Numeric/Histogram.hs +69/−0
Chart.cabal view
@@ -1,29 +1,38 @@ Name: Chart-Version: 1.2.4+Version: 1.9.5 License: BSD3 License-file: LICENSE-Copyright: Tim Docker, 2006-2010+Copyright: Tim Docker, 2006-2014 Author: Tim Docker <tim@dockerz.net> Maintainer: Tim Docker <tim@dockerz.net> Homepage: https://github.com/timbod7/haskell-chart/wiki Synopsis: A library for generating 2D Charts and Plots-Description: A library for generating 2D Charts and Plots, with backends provided by +Description: A library for generating 2D Charts and Plots, with backends provided by Cairo (<http://hackage.haskell.org/package/Chart-cairo>) and Diagrams (<http://hackage.haskell.org/package/Chart-diagrams>).++ Documentation: https://github.com/timbod7/haskell-chart/wiki. Category: Graphics-Cabal-Version: >= 1.6+Cabal-Version: 1.18 Build-Type: Simple library+ default-language: Haskell98 Build-depends: base >= 3 && < 5 , old-locale- , time, mtl, array- , lens >= 3.9 && < 4.4+ , time, array+ , lens >= 3.9 && < 5.3 , colour >= 2.2.1 && < 2.4- , data-default-class < 0.1+ , data-default-class < 0.2+ , mtl >= 2.0 && < 2.4 , operational >= 0.2.2 && < 0.3+ , vector >=0.9 && <0.14 + if !impl(ghc >= 8.0)+ build-depends: semigroups >= 0.18.4 && <0.19++ Ghc-options: -Wall -fno-warn-orphans Exposed-modules:@@ -36,6 +45,7 @@ Graphics.Rendering.Chart.Axis.Floating, Graphics.Rendering.Chart.Axis.Indexed, Graphics.Rendering.Chart.Axis.Int,+ Graphics.Rendering.Chart.Axis.Time, Graphics.Rendering.Chart.Axis.LocalTime, Graphics.Rendering.Chart.Axis.Types, Graphics.Rendering.Chart.Axis.Unit,@@ -52,13 +62,17 @@ Graphics.Rendering.Chart.Plot.FillBetween, Graphics.Rendering.Chart.Plot.Hidden, 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.State+ Numeric.Histogram source-repository head type: git location: https://github.com/timbod7/haskell-chart
Graphics/Rendering/Chart.hs view
@@ -6,12 +6,16 @@ -- -- A framework for creating 2D charts in Haskell. ----- The basic model is that you define a value representing a chart to--- be displayed, and then convert it to a 'Renderable' by applying--- 'toRenderable'. This 'Renderable' is then actually output by--- calling a function in an appropriate graphics backend, eg--- 'renderableToFile'.+-- For the simplest API, see the "Graphics.Rendering.Chart.Easy"+-- module. --+-- When more control is required, understanding the various data types+-- is necessary. The basic model is that you define a value+-- representing a chart to be displayed (eg. a `Layout`), and then+-- convert it to a 'Renderable' by applying 'toRenderable'. This+-- 'Renderable' is then actually output by calling a function in an+-- appropriate graphics backend, eg 'renderableToFile'.+-- -- Currently, there are three types of charts: -- -- * 'Layout' is a standard XY chart@@ -43,6 +47,7 @@ module Graphics.Rendering.Chart.Axis, module Graphics.Rendering.Chart.Plot, module Graphics.Rendering.Chart.Legend,+ module Graphics.Rendering.Chart.Backend.Types ) where @@ -53,3 +58,4 @@ import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Plot import Graphics.Rendering.Chart.Legend+import Graphics.Rendering.Chart.Backend.Types
Graphics/Rendering/Chart/Axis.hs view
@@ -11,7 +11,7 @@ module Graphics.Rendering.Chart.Axis.Types, module Graphics.Rendering.Chart.Axis.Floating, module Graphics.Rendering.Chart.Axis.Int,- module Graphics.Rendering.Chart.Axis.LocalTime,+ module Graphics.Rendering.Chart.Axis.Time, module Graphics.Rendering.Chart.Axis.Unit, module Graphics.Rendering.Chart.Axis.Indexed, ) where@@ -19,6 +19,6 @@ import Graphics.Rendering.Chart.Axis.Types import Graphics.Rendering.Chart.Axis.Floating import Graphics.Rendering.Chart.Axis.Int-import Graphics.Rendering.Chart.Axis.LocalTime+import Graphics.Rendering.Chart.Axis.Time import Graphics.Rendering.Chart.Axis.Unit import Graphics.Rendering.Chart.Axis.Indexed
Graphics/Rendering/Chart/Axis/Floating.hs view
@@ -10,14 +10,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Rendering.Chart.Axis.Floating( Percent(..), LinearAxisParams(..), LogValue(..), LogAxisParams(..),- defaultLinearAxis,- defaultLogAxis, scaledAxis, autoScaledAxis, autoScaledLogAxis,@@ -30,10 +30,10 @@ loga_labelf ) where -import Data.List(minimumBy)+import Data.List(minimumBy, nub) import Data.Ord (comparing) import Data.Default.Class-import Numeric (showFFloat)+import Numeric (showEFloat, showFFloat) import Control.Lens import Graphics.Rendering.Chart.Geometry@@ -46,8 +46,13 @@ instance PlotValue Double where toValue = id fromValue= id- autoAxis = autoScaledAxis defaultLinearAxis+ 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}@@ -59,11 +64,11 @@ instance PlotValue Percent where toValue = unPercent fromValue= Percent- autoAxis = autoScaledAxis defaultLinearAxis{-_la_labelf=-}+ autoAxis = autoScaledAxis def {-_la_labelf=-} -- | A wrapper class for doubles used to indicate they are to -- be plotted against a log axis.-newtype LogValue = LogValue Double+newtype LogValue = LogValue {unLogValue :: Double} deriving (Eq, Ord, Num, Real, Fractional, RealFrac, Floating, RealFloat) instance Show LogValue where@@ -72,8 +77,98 @@ instance PlotValue LogValue where toValue (LogValue x) = log x fromValue d = LogValue (exp d)- autoAxis = autoScaledLogAxis defaultLogAxis+ autoAxis = autoScaledLogAxis def +-- | Show a list of axis labels.+-- If some are too big or all are too small, switch to scientific notation for all.+-- If the range is much smaller than the mean, use an offset.+-- TODO: show this offset only once, not on every label.+-- When thinking about improving this function,+-- https://github.com/matplotlib/matplotlib/blob/master/lib/matplotlib/ticker.py+-- is a good read.+--+-- >>> showDs [0, 1, 2 :: Double]+-- ["0","1","2"]+--+-- >>> showDs [0, 1000000, 2000000 :: Double]+-- ["0.0e0","1.0e6","2.0e6"]+--+-- >>> showDs [0, 0.001, 0.002 :: Double]+-- ["0","0.001","0.002"]+--+-- >>> showDs [-10000000, -1000000, 9000000 :: Double]+-- ["-1.0e7","-1.0e6","9.0e6"]+--+-- >>> showDs [10, 11, 12 :: Double]+-- ["10","11","12"]+--+-- >>> showDs [100, 101, 102 :: Double]+-- ["100","101","102"]+--+-- >>> showDs [100000, 100001, 100002 :: Double]+-- ["100000","100001","100002"]+--+-- >>> showDs [1000000, 1000001, 1000002 :: Double]+-- ["1.0e6 + 0","1.0e6 + 1","1.0e6 + 2"]+--+-- >>> showDs [10000000, 10000001, 10000002 :: Double]+-- ["1.0e7 + 0","1.0e7 + 1","1.0e7 + 2"]+--+-- >>> showDs [-10000000, -10000001, -10000002 :: Double]+-- ["-1.0e7 + 2","-1.0e7 + 1","-1.0e7 + 0"]+--+-- prop> let [s0, s1] = showDs [x, x + 1.0 :: Double] in s0 /= s1+showDs :: forall d . (RealFloat d) => [d] -> [String]+showDs xs = case showWithoutOffset xs of+ (s0:others)+ | anyEqualNeighbor s0 others -> map addShownOffset $ showWithoutOffset (map (\x -> x - offset) xs)+ s -> s+ where+ anyEqualNeighbor z0 (z1:others)+ | z0 == z1 = True+ | otherwise = anyEqualNeighbor z1 others+ anyEqualNeighbor _ [] = False++ -- Use the min for offset. Another good choice could be the mean.+ offset :: d+ offset = minimum xs+ shownOffset = case showWithoutOffset [offset] of+ [r] -> r+ rs -> error $ "showDs: shownOffset expected 1 element, got " ++ show (length rs)++ addShownOffset :: String -> String+ addShownOffset ('-':x) = shownOffset ++ " - " ++ x+ addShownOffset x = shownOffset ++ " + " ++ x++showWithoutOffset :: RealFloat d => [d] -> [String]+showWithoutOffset xs+ | useScientificNotation = map (showEFloat' (Just 1)) xs+ | otherwise = map showD xs+ where+ -- use scientific notation if max value is too big or too small+ useScientificNotation = maxAbs >= 1e6 || maxAbs <= 1e-6+ maxAbs = maximum (map abs xs)+++-- | Changes the behavior of showEFloat to drop more than one trailings 0.+-- Instead of 1.000e4 you get 1.0e4+showEFloat' :: forall d . RealFloat d => Maybe Int -> d -> String+showEFloat' mdigits x = reverse $ cleanup0 (reverse shown0)+ where+ shown0 = showEFloat mdigits x ""++ -- wait until we get the "e"+ cleanup0 :: String -> String+ cleanup0 (e@'e':ys) = e:cleanup1 ys+ cleanup0 (y:ys) = y : cleanup0 ys+ cleanup0 [] = reverse shown0 -- something went wrong, just return the original++ -- get rid of redundant 0s before the '.'+ cleanup1 :: String -> String+ cleanup1 ('0':ys@('0':_)) = cleanup1 ys+ cleanup1 y = y++ showD :: (RealFloat d) => d -> String showD x = case reverse $ showFFloat Nothing x "" of '0':'.':r -> reverse r@@ -81,7 +176,7 @@ data LinearAxisParams a = LinearAxisParams { -- | The function used to show the axes labels.- _la_labelf :: a -> String,+ _la_labelf :: [a] -> [String], -- | The target number of labels to be shown. _la_nLabels :: Int,@@ -90,13 +185,9 @@ _la_nTicks :: Int } -{-# DEPRECATED defaultLinearAxis "Use the according Data.Default instance!" #-}-defaultLinearAxis :: (Show a, RealFloat a) => LinearAxisParams a-defaultLinearAxis = def- instance (Show a, RealFloat a) => Default (LinearAxisParams a) where- def = LinearAxisParams - { _la_labelf = showD+ def = LinearAxisParams+ { _la_labelf = showDs , _la_nLabels = 5 , _la_nTicks = 50 }@@ -120,9 +211,10 @@ -- | Generate a linear axis automatically, scaled appropriately for the -- input data. autoScaledAxis :: RealFloat a => LinearAxisParams a -> AxisFn a-autoScaledAxis lap ps0 = scaledAxis lap rs ps0+autoScaledAxis lap ps0 = scaledAxis lap rs ps where- rs = (minimum ps0,maximum ps0)+ ps = filter isValidNumber ps0+ rs = (minimum ps,maximum ps) steps :: RealFloat a => a -> (a,a) -> [Rational] steps nSteps rs@(minV,maxV) = map ((s*) . fromIntegral) [min' .. max']@@ -136,7 +228,8 @@ chooseStep nsteps (x1,x2) = minimumBy (comparing proximity) stepVals where delta = x2 - x1- mult = 10 ^^ ((floor $ log10 $ delta / nsteps)::Integer)+ mult | delta == 0 = 1 -- Otherwise the case below will use all of memory+ | otherwise = 10 ^^ ((floor $ log10 $ delta / nsteps)::Integer) stepVals = map (mult*) [0.1,0.2,0.25,0.5,1.0,2.0,2.5,5.0,10,20,25,50] proximity x = abs $ delta / realToFrac x - nsteps @@ -155,21 +248,17 @@ ---------------------------------------------------------------------- -{-# DEPRECATED defaultLogAxis "Use the according Data.Default instance!" #-}-defaultLogAxis :: (Show a, RealFloat a) => LogAxisParams a-defaultLogAxis = def- instance (Show a, RealFloat a) => Default (LogAxisParams a) where- def = LogAxisParams - { _loga_labelf = showD+ def = LogAxisParams+ { _loga_labelf = showDs } --- | Generate a log axis automatically, scaled appropriate for the+-- | Generate a log axis automatically, scaled appropriately for the -- input data. autoScaledLogAxis :: RealFloat a => LogAxisParams a -> AxisFn a autoScaledLogAxis lap ps0 = makeAxis' (realToFrac . log) (realToFrac . exp)- (_loga_labelf lap) (wrap rlabelvs, wrap rtickvs, wrap rgridvs)+ (_loga_labelf lap) (wrap rlabelvs, wrap rtickvs, wrap rlabelvs) where ps = filter (\x -> isValidNumber x && 0 < x) ps0 (minV,maxV) = (minimum ps,maximum ps)@@ -177,23 +266,23 @@ range [] = (3,30) range _ | minV == maxV = (realToFrac $ minV/3, realToFrac $ maxV*3) | otherwise = (realToFrac $ minV, realToFrac $ maxV)- (rlabelvs, rtickvs, rgridvs) = logTicks (range ps)+ (rlabelvs, rtickvs) = logTicks (range ps) data LogAxisParams a = LogAxisParams { -- | The function used to show the axes labels.- _loga_labelf :: a -> String+ _loga_labelf :: [a] -> [String] } {- Rules: Do not subdivide between powers of 10 until all powers of 10- get a major ticks.+ get major ticks. Do not subdivide between powers of ten as [1,2,4,6,8,10] when- 5 gets a major ticks- (ie the major ticks need to be a subset of the minor tick)+ 5 gets a major tick+ (i.e. the major ticks need to be a subset of the minor ticks) -}-logTicks :: Range -> ([Rational],[Rational],[Rational])-logTicks (low,high) = (major,minor,major)+logTicks :: Range -> ([Rational],[Rational])+logTicks (low,high) = (nub major,nub minor) where pf :: RealFrac a => a -> (Integer, a) pf = properFraction@@ -210,17 +299,17 @@ maximum (1:filter (\x -> log10 (fromRational x) <= r) l)*10^^i upper a l = let (i,r) = pf (log10 a) in minimum (10:filter (\x -> r <= log10 (fromRational x)) l)*10^^i- + powers :: (Double,Double) -> [Rational] -> [Rational] powers (x,y) l = [ a*10^^p | p <- [(floor (log10 x))..(ceiling (log10 y))] :: [Integer] , a <- l ] midselection r l = filter (inRange r l) (powers r l) inRange (a,b) l x = (lower a l <= x) && (x <= upper b l)- + logRange = (log10 low, log10 high)- + roundPow x = 10^^(round x :: Integer)- + major | 17.5 < log10 ratio = map roundPow $ steps (min 5 (log10 ratio)) logRange | 12 < log10 ratio = map roundPow $@@ -237,20 +326,15 @@ (dl',dh') = (fromRational l', fromRational h') ratio' :: Double ratio' = fromRational (h'/l')- filterX = filter (\x -> l'<=x && x <=h') . powers (dl',dh') - + filterX = filter (\x -> l'<=x && x <=h') . powers (dl',dh')+ minor | 50 < log10 ratio' = map roundPow $ steps 50 (log10 dl', log10 dh') | 6 < log10 ratio' = filterX [1,10]- | 3 < log10 ratio' = filterX [1,5,10]+ | 4 < log10 ratio' = filterX [1,5,10] | 6 < ratio' = filterX [1..10] | 3 < ratio' = filterX [1,1.2..10] | otherwise = steps 50 (dl', dh') --log10 :: (Floating a) => a -> a-log10 = logBase 10- $( makeLenses ''LinearAxisParams ) $( makeLenses ''LogAxisParams )-
Graphics/Rendering/Chart/Axis/Indexed.hs view
@@ -7,14 +7,15 @@ -- Calculate and render indexed axes {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-} module Graphics.Rendering.Chart.Axis.Indexed( PlotIndex(..),+ autoIndexAxis', autoIndexAxis, addIndexes, ) where -import Control.Arrow (first) import Data.Default.Class import Graphics.Rendering.Chart.Axis.Types@@ -31,18 +32,18 @@ -- | Augment a list of values with index numbers for plotting. addIndexes :: [a] -> [(PlotIndex,a)]-addIndexes as = map (first PlotIndex) (zip [0..] as)+addIndexes = zipWith (\n x -> (PlotIndex n, x)) [0..] -- | Create an axis for values indexed by position. The -- list of strings are the labels to be used.-autoIndexAxis :: Integral i => [String] -> [i] -> AxisData i-autoIndexAxis labels vs = AxisData {+autoIndexAxis' :: Integral i => Bool -> [String] -> AxisFn i+autoIndexAxis' tks labels vs = AxisData { _axis_visibility = def { _axis_show_ticks = False }, _axis_viewport = vport, _axis_tropweiv = invport,- _axis_ticks = [],+ _axis_ticks = if tks then map (, 5) $ take (length labels) [0..] else [], _axis_labels = [filter (\(i,_) -> i >= imin && i <= imax)- (zip [0..] labels)],+ (zip [0..] labels)], _axis_grid = [] } where@@ -51,3 +52,6 @@ invport = invLinMap round fromIntegral (imin, imax) imin = minimum vs imax = maximum vs++autoIndexAxis :: Integral i => [String] -> AxisFn i+autoIndexAxis = autoIndexAxis' False
Graphics/Rendering/Chart/Axis/Int.hs view
@@ -5,6 +5,7 @@ -- License : BSD-style (see chart/COPYRIGHT) -- -- Calculate and render integer indexed axes+{-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Rendering.Chart.Axis.Int( defaultIntAxis,@@ -13,6 +14,8 @@ ) where import Data.List(genericLength)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64) import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Axis.Types import Graphics.Rendering.Chart.Axis.Floating@@ -22,6 +25,51 @@ fromValue = round autoAxis = autoScaledIntAxis defaultIntAxis +instance PlotValue Int8 where+ toValue = fromIntegral+ fromValue = round+ autoAxis = autoScaledIntAxis defaultIntAxis++instance PlotValue Int16 where+ toValue = fromIntegral+ fromValue = round+ autoAxis = autoScaledIntAxis defaultIntAxis++instance PlotValue Int32 where+ toValue = fromIntegral+ fromValue = round+ autoAxis = autoScaledIntAxis defaultIntAxis++instance PlotValue Int64 where+ toValue = fromIntegral+ fromValue = round+ autoAxis = autoScaledIntAxis defaultIntAxis++instance PlotValue Word where+ toValue = fromIntegral+ fromValue = round+ autoAxis = autoScaledIntAxis defaultIntAxis++instance PlotValue Word8 where+ toValue = fromIntegral+ fromValue = round+ autoAxis = autoScaledIntAxis defaultIntAxis++instance PlotValue Word16 where+ toValue = fromIntegral+ fromValue = round+ autoAxis = autoScaledIntAxis defaultIntAxis++instance PlotValue Word32 where+ toValue = fromIntegral+ fromValue = round+ autoAxis = autoScaledIntAxis defaultIntAxis++instance PlotValue Word64 where+ toValue = fromIntegral+ fromValue = round+ autoAxis = autoScaledIntAxis defaultIntAxis+ instance PlotValue Integer where toValue = fromIntegral fromValue = round@@ -29,7 +77,7 @@ defaultIntAxis :: (Show a) => LinearAxisParams a defaultIntAxis = LinearAxisParams {- _la_labelf = show,+ _la_labelf = map show, _la_nLabels = 5, _la_nTicks = 10 }@@ -65,8 +113,16 @@ goodness vs = abs (genericLength vs - nSteps) - (alt0:alts) = map (\n -> steps n range) sampleSteps+ (alt0:alts) = map (\n -> steps n range) sampleSteps' + -- throw away sampleSteps that are definitely too small as+ -- they takes a long time to process + sampleSteps' = let rangeMag = ceiling (snd range - fst range)+ + (s1,s2) = span (< (rangeMag `div` nSteps)) sampleSteps+ in ((reverse . take 5 . reverse) s1) ++ s2++ -- generate all possible step sizes sampleSteps = [1,2,5] ++ sampleSteps1 sampleSteps1 = [10,20,25,50] ++ map (*10) sampleSteps1
Graphics/Rendering/Chart/Axis/LocalTime.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis.LocalTime@@ -6,33 +8,36 @@ -- -- Calculate and render time axes -module Graphics.Rendering.Chart.Axis.LocalTime(+module Graphics.Rendering.Chart.Axis.LocalTime+ {-# DEPRECATED "Use Graphics.Rendering.Chart.Axis.Time module" #-}+ ( TimeSeq, TimeLabelFn, TimeLabelAlignment(..),- + timeAxis, autoTimeAxis,- + days, months, years,- + -- * Utilities doubleFromLocalTime- - ) where- ++ )+ where+ import Data.Default.Class+#if MIN_VERSION_time(1,5,0)+import Data.Time hiding (months)+#else import Data.Time-import Data.Fixed import System.Locale (defaultTimeLocale)+#endif+import Data.Fixed import Control.Lens import Graphics.Rendering.Chart.Axis.Types--instance PlotValue LocalTime where- toValue = doubleFromLocalTime- fromValue = localTimeFromDouble- autoAxis = autoTimeAxis+import Graphics.Rendering.Chart.Axis.Time () ---------------------------------------------------------------------- @@ -83,19 +88,19 @@ -- -- The values to be plotted against this axis can be created with -- 'doubleFromLocalTime'.-timeAxis :: - TimeSeq +timeAxis ::+ TimeSeq -- ^ Set the minor ticks, and the final range will be aligned to its -- elements.- -> TimeSeq + -> TimeSeq -- ^ Set the labels and grid.- -> TimeLabelFn - -> TimeLabelAlignment - -> TimeSeq + -> TimeLabelFn+ -> TimeLabelAlignment+ -> TimeSeq -- ^ Set the second line of labels.- -> TimeLabelFn + -> TimeLabelFn -- ^ Format `LocalTime` for labels.- -> TimeLabelAlignment + -> TimeLabelAlignment -> AxisFn LocalTime timeAxis tseq lseq labelf lal cseq contextf clal pts = AxisData { _axis_visibility = def,@@ -104,7 +109,7 @@ _axis_ticks = [ (t,2) | t <- times] ++ [ (t,5) | t <- ltimes, visible t], _axis_labels = [ [ (t,l) | (t,l) <- labels labelf ltimes lal, visible t] , [ (t,l) | (t,l) <- labels contextf ctimes clal, visible t]- ], + ], _axis_grid = [ t | t <- ltimes, visible t] } where@@ -229,9 +234,9 @@ autoTimeAxis pts | null pts = timeAxis days days (ft "%d-%b-%y") UnderTicks noTime (ft "") UnderTicks []- | tdiff==0 && 100*dsec<1= timeAxis millis1 millis1 (ft "%S%Q") UnderTicks + | tdiff==0 && 100*dsec<1= timeAxis millis1 millis1 (ft "%S%Q") UnderTicks noTime (ft "%S%Q") UnderTicks pts- | tdiff==0 && 10*dsec<1 = timeAxis millis10 millis10 (ft "%S%Q") UnderTicks + | tdiff==0 && 10*dsec<1 = timeAxis millis10 millis10 (ft "%S%Q") UnderTicks noTime (ft "%S%Q") UnderTicks pts | tdiff==0 && dsec<1 = timeAxis millis10 millis100 (ft "%S%Q") UnderTicks seconds (ft "%M:%S") BetweenTicks pts
+ Graphics/Rendering/Chart/Axis/Time.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Chart.Axis.Time+-- Copyright : (c) Tim Docker 2010, 2014+-- License : BSD-style (see chart/COPYRIGHT)+--+-- Calculate and render time axes++module Graphics.Rendering.Chart.Axis.Time(+ TimeSeq,+ TimeLabelFn,+ TimeLabelAlignment(..),++ TimeValue (..),++ timeValueAxis,+ autoTimeValueAxis,++ days, months, years,++ ) where++import Data.Default.Class+#if MIN_VERSION_time(1,5,0)+import Data.Time hiding (months)+#else+import Data.Time+import System.Locale (defaultTimeLocale)+#endif+import Data.Fixed+import Control.Lens++import Graphics.Rendering.Chart.Axis.Types+import Graphics.Rendering.Chart.Geometry (Range)++-- | A typeclass abstracting the functions we need+-- to be able to plot against an axis of time type @d@.+class TimeValue t where+ utctimeFromTV :: t -> UTCTime+ tvFromUTCTime :: UTCTime -> t++ {-# MINIMAL utctimeFromTV, tvFromUTCTime #-}++ doubleFromTimeValue :: t -> Double+ doubleFromTimeValue = doubleFromTimeValue . utctimeFromTV++ timeValueFromDouble :: Double -> t+ timeValueFromDouble = tvFromUTCTime . timeValueFromDouble++instance TimeValue UTCTime where+ utctimeFromTV = id+ tvFromUTCTime = id+ doubleFromTimeValue = doubleFromUTCTime+ timeValueFromDouble = utcTimeFromDouble++instance TimeValue Day where+ utctimeFromTV d = UTCTime d 0+ tvFromUTCTime = utctDay+ doubleFromTimeValue = doubleFromDay+ timeValueFromDouble = dayFromDouble++instance TimeValue LocalTime where+ utctimeFromTV (LocalTime d tod) = UTCTime d (timeOfDayToTime tod)+ tvFromUTCTime (UTCTime d dt) = LocalTime d (timeToTimeOfDay dt)++----------------------------------------------------------------------++instance PlotValue LocalTime where+ toValue = doubleFromTimeValue+ fromValue = timeValueFromDouble+ autoAxis = autoTimeValueAxis++instance PlotValue UTCTime where+ toValue = doubleFromTimeValue+ fromValue = timeValueFromDouble+ autoAxis = autoTimeValueAxis++instance PlotValue Day where+ toValue = doubleFromTimeValue+ fromValue = timeValueFromDouble+ autoAxis = autoTimeValueAxis++----------------------------------------------------------------------++-- | Map a UTCTime value to a plot coordinate.+doubleFromUTCTime :: UTCTime -> Double+doubleFromUTCTime ut = fromIntegral (toModifiedJulianDay (utctDay ut))+ + fromRational (timeOfDayToDayFraction (timeToTimeOfDay (utctDayTime ut)))++-- | Map a plot coordinate to a UTCTime.+utcTimeFromDouble :: Double -> UTCTime+utcTimeFromDouble v =+ UTCTime (ModifiedJulianDay i) (timeOfDayToTime (dayFractionToTimeOfDay (toRational d)))+ where+ (i,d) = properFraction v++-- | Map a Day value to a plot coordinate.+doubleFromDay :: Day -> Double+doubleFromDay d = fromIntegral (toModifiedJulianDay d)++-- | Map a plot coordinate to a Day.+dayFromDouble :: Double -> Day+dayFromDouble v = ModifiedJulianDay (truncate v)++----------------------------------------------------------------------++-- | TimeSeq is a (potentially infinite) set of times. When passed+-- a reference time, the function returns a a pair of lists. The first+-- contains all times in the set less than the reference time in+-- decreasing order. The second contains all times in the set greater+-- than or equal to the reference time, in increasing order.+type TimeSeq = UTCTime -> ([UTCTime],[UTCTime])++coverTS :: TimeSeq -> UTCTime -> UTCTime -> [UTCTime]+coverTS tseq minT maxT = min' ++ enumerateTS tseq minT maxT ++ max'+ where+ min' = if elemTS minT tseq then [] else take 1 (fst (tseq minT))+ max' = if elemTS maxT tseq then [] else take 1 (snd (tseq maxT))++enumerateTS :: TimeSeq -> UTCTime -> UTCTime -> [UTCTime]+enumerateTS tseq minT maxT =+ reverse (takeWhile (>=minT) ts1) ++ takeWhile (<=maxT) ts2+ where+ (ts1,ts2) = tseq minT++elemTS :: UTCTime -> TimeSeq -> Bool+elemTS t tseq = case tseq t of+ (_,t0:_) | t == t0 -> True+ _ -> False++-- | How to display a time+type TimeLabelFn = UTCTime -> String++data TimeLabelAlignment = UnderTicks+ | BetweenTicks+ deriving (Show)++-- | Create an 'AxisFn' to for a time axis.+--+-- The values to be plotted against this axis can be created with+-- 'doubleFromLocalTime'.+--+-- Implementation detail: 'PlotValue' constraint is needed to use `vmap`.+timeValueAxis ::+ TimeValue t+ => TimeSeq+ -- ^ Set the minor ticks, and the final range will be aligned to its+ -- elements.+ -> TimeSeq+ -- ^ Set the labels and grid.+ -> TimeLabelFn+ -> TimeLabelAlignment+ -> TimeSeq+ -- ^ Set the second line of labels.+ -> TimeLabelFn+ -- ^ Format @t@ for labels.+ -> TimeLabelAlignment+ -> AxisFn t+timeValueAxis tseq lseq labelf lal cseq contextf clal pts = AxisData {+ _axis_visibility = def,+ _axis_viewport = vmap' (tvFromUTCTime min', tvFromUTCTime max'),+ _axis_tropweiv = invmap' (tvFromUTCTime min', tvFromUTCTime max'),+ _axis_ticks = [ (tvFromUTCTime t,2) | t <- times] ++ [ (tvFromUTCTime t,5) | t <- ltimes, visible t],+ _axis_labels = [ [ (tvFromUTCTime t,l) | (t,l) <- labels labelf ltimes lal, visible t]+ , [ (tvFromUTCTime t,l) | (t,l) <- labels contextf ctimes clal, visible t]+ ],+ _axis_grid = [ tvFromUTCTime t | t <- ltimes, visible t]+ }+ where+ (minT,maxT) = case pts of+ [] -> (refTimeValue,refTimeValue)+ ps -> (minimum (map utctimeFromTV ps), maximum (map utctimeFromTV ps))+ refTimeValue = timeValueFromDouble 0++ times, ltimes, ctimes :: [UTCTime]+ times = coverTS tseq minT maxT+ ltimes = coverTS lseq minT maxT+ ctimes = coverTS cseq minT maxT+ min' = minimum times+ max' = maximum times+ visible t = min' <= t && t <= max'+ labels f ts lal' =+ [ (align lal' m1' m2', f m1)+ | (m1,m2) <- zip ts (tail ts)+ , let m1' = if m1<min' then min' else m1+ , let m2' = if m2>max' then max' else m2 ]++ align BetweenTicks m1 m2 = avg m1 m2+ align UnderTicks m1 _ = m1++ avg m1 m2 = timeValueFromDouble $ m1' + (m2' - m1')/2+ where+ m1' = doubleFromTimeValue m1+ m2' = doubleFromTimeValue m2++vmap' :: TimeValue x => (x,x) -> Range -> x -> Double+vmap' (v1,v2) (v3,v4) v = v3 + (doubleFromTimeValue v - doubleFromTimeValue v1) * (v4-v3)+ / (doubleFromTimeValue v2 - doubleFromTimeValue v1)++invmap' :: TimeValue x => (x,x) -> Range -> Double -> x+invmap' (v3,v4) (d1,d2) d = timeValueFromDouble (doubleFromTimeValue v3 + ( (d-d1) * doubleRange+ / (d2-d1) ))+ where doubleRange = doubleFromTimeValue v4 - doubleFromTimeValue v3++truncateTo :: Real a => a -> a -> a+truncateTo t step = t - t `mod'` step++secondSeq :: NominalDiffTime -> TimeSeq+secondSeq step t@(UTCTime day dt) = (iterate rev t1, tail (iterate fwd t1))+ where t0 = UTCTime day (truncateTo dt step')+ t1 = if t0 < t then t0 else rev t0+ rev = addUTCTime (negate step)+ fwd = addUTCTime step+ step' = realToFrac step++millis1, millis10, millis100, seconds, fiveSeconds :: TimeSeq+millis1 = secondSeq (1 / 1000)+millis10 = secondSeq (1 / 100)+millis100 = secondSeq (1 / 10)+seconds = secondSeq 1+fiveSeconds = secondSeq 5++minutes, fiveMinutes :: TimeSeq+minutes = secondSeq 60+fiveMinutes = secondSeq (5 * 60)++-- | A 'TimeSeq' for hours.+hours :: TimeSeq+hours = secondSeq (60 * 60)++-- | A 'TimeSeq' for calendar days.+days :: TimeSeq+days t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1))+ where t0 = utctDay t+ t1 = if toTime t0 < t then t0 else rev t0+ rev = pred+ fwd = succ+ toTime d = UTCTime d 0++-- | A 'TimeSeq' for calendar months.+months :: TimeSeq+months t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1))+ where t0 = let (y,m,_) = toGregorian $ utctDay t in fromGregorian y m 1+ t1 = if toTime t0 < t then t0 else rev t0+ rev = addGregorianMonthsClip (-1)+ fwd = addGregorianMonthsClip 1+ toTime d = UTCTime d 0++-- | A 'TimeSeq' for calendar years.+years :: TimeSeq+years t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1))+ where t0 = toGregorian (utctDay t) ^. _1+ t1 = if toTime t0 < t then t0 else rev t0+ rev = pred+ fwd = succ+ toTime y = UTCTime (fromGregorian y 1 1) 0++-- | A 'TimeSeq' for no sequence at all.+noTime :: TimeSeq+noTime _ = ([],[])++-- | Automatically choose a suitable time axis, based upon the time range+-- of data. The values to be plotted against this axis can be created+-- with 'doubleFromTimeValue'.+autoTimeValueAxis :: TimeValue t => AxisFn t+autoTimeValueAxis pts+ | null pts = timeValueAxis days days (ft "%d-%b-%y") UnderTicks+ noTime (ft "") UnderTicks []+ | 100*dsec<1 = timeValueAxis millis1 millis1 (ft "%S%Q") UnderTicks+ noTime (ft "%S%Q") UnderTicks pts+ | 10*dsec<1 = timeValueAxis millis10 millis10 (ft "%S%Q") UnderTicks+ noTime (ft "%S%Q") UnderTicks pts+ | dsec<1 = timeValueAxis millis10 millis100 (ft "%S%Q") UnderTicks+ seconds (ft "%M:%S") BetweenTicks pts+ | dsec<5 = timeValueAxis millis100 seconds (ft "%M:%S%Q") UnderTicks+ seconds (ft "%M:%S") BetweenTicks pts+ | dsec<32 = timeValueAxis seconds seconds (ft "%Ss") UnderTicks+ minutes (ft "%d-%b-%y %H:%M") BetweenTicks pts+ | dsec<120 = timeValueAxis seconds fiveSeconds (ft "%Ss") UnderTicks+ minutes (ft "%d-%b-%y %H:%M") BetweenTicks pts+ | dsec<7*60 = timeValueAxis fiveSeconds minutes (ft "%Mm") UnderTicks+ hours (ft "%d-%b-%y %H:00") BetweenTicks pts+ | dsec<32*60 = timeValueAxis minutes minutes (ft "%Mm") UnderTicks+ hours (ft "%d-%b-%y %H:00") BetweenTicks pts+ | dsec<90*60 = timeValueAxis minutes fiveMinutes (ft "%Mm") UnderTicks+ hours (ft "%d-%b-%y %H:00") BetweenTicks pts+ | dsec<4*3600 = timeValueAxis fiveMinutes hours (ft "%H:%M") UnderTicks+ days (ft "%d-%b-%y") BetweenTicks pts+ | dsec<32*3600 = timeValueAxis hours hours (ft "%H:%M") UnderTicks+ days (ft "%d-%b-%y") BetweenTicks pts+ | dday<4 = timeValueAxis hours days (ft "%d-%b-%y") BetweenTicks+ noTime (ft "") BetweenTicks pts+ | dday<12 = timeValueAxis days days (ft "%d-%b") BetweenTicks+ years (ft "%Y") BetweenTicks pts+ | dday<45 = timeValueAxis days days (ft "%d") BetweenTicks+ months (ft "%b-%y") BetweenTicks pts+ | dday<95 = timeValueAxis days months (ft "%b-%y") BetweenTicks+ noTime (ft "") BetweenTicks pts+ | dday<450 = timeValueAxis months months (ft "%b-%y") BetweenTicks+ noTime (ft "") BetweenTicks pts+ | dday<735 = timeValueAxis months months (ft "%b") BetweenTicks+ years (ft "%Y") BetweenTicks pts+ | dday<1800 = timeValueAxis months years (ft "%Y") BetweenTicks+ noTime (ft "") BetweenTicks pts+ | otherwise = timeValueAxis years years (ft "%Y") BetweenTicks+ noTime (ft "") BetweenTicks pts+ where+ upts = map utctimeFromTV pts+ dsec = diffUTCTime t1 t0 -- seconds+ dday = dsec / 86400 -- days+ t1 = maximum upts+ t0 = minimum upts+ ft = formatTime defaultTimeLocale
Graphics/Rendering/Chart/Axis/Types.hs view
@@ -18,7 +18,6 @@ AxisFn, defaultAxisLineStyle,- defaultAxisStyle, defaultGridLineStyle, makeAxis,@@ -178,7 +177,7 @@ axisLabelsOverride :: [(x,String)] -> AxisData x -> AxisData x axisLabelsOverride o ad = ad{ _axis_labels = [o] } -minsizeAxis :: AxisT x -> ChartBackend RectSize+minsizeAxis :: AxisT x -> BackendProgram RectSize minsizeAxis (AxisT at as _ ad) = do let labelVis = _axis_show_labels $ _axis_visibility ad tickVis = _axis_show_ticks $ _axis_visibility ad@@ -197,10 +196,10 @@ let vh = maximum0 (map (maximum0.map snd) labelSizes) let sz = case at of- E_Top -> (hw,hh)- E_Bottom -> (hw,hh)- E_Left -> (vw,vh)- E_Right -> (vw,vh)+ E_Top -> (hw,hh)+ E_Bottom -> (hw,hh)+ E_Left -> (vw,vh)+ E_Right -> (vw,vh) return sz labelTexts :: AxisData a -> [[String]]@@ -212,7 +211,7 @@ -- | Calculate the amount by which the labels extend beyond -- the ends of the axis.-axisOverhang :: (Ord x) => AxisT x -> ChartBackend (Double,Double)+axisOverhang :: (Ord x) => AxisT x -> BackendProgram (Double,Double) axisOverhang (AxisT at as _ ad) = do let labels = map snd . sort . concat . _axis_labels $ ad labelSizes <- withFontStyle (_axis_label_style as) $@@ -229,7 +228,7 @@ E_Left -> ohangv E_Right -> ohangh -renderAxis :: AxisT x -> RectSize -> ChartBackend (PickFn x)+renderAxis :: AxisT x -> RectSize -> BackendProgram (PickFn x) renderAxis at@(AxisT et as _ ad) sz = do let ls = _axis_line_style as vis = _axis_visibility ad@@ -334,7 +333,7 @@ reverseR r@(r0,r1) = if rev then (r1,r0) else r -- -renderAxisGrid :: RectSize -> AxisT z -> ChartBackend ()+renderAxisGrid :: RectSize -> AxisT z -> BackendProgram () renderAxisGrid sz@(w,h) at@(AxisT re as _ ad) = withLineStyle (_axis_grid_style as) $ mapM_ (drawGridLine re) (_axis_grid ad)@@ -355,7 +354,7 @@ -- | Construct an axis given the positions for ticks, grid lines, and -- labels, and the labelling function-makeAxis :: PlotValue x => (x -> String) -> ([x],[x],[x]) -> AxisData x+makeAxis :: PlotValue x => ([x] -> [String]) -> ([x],[x],[x]) -> AxisData x makeAxis labelf (labelvs, tickvs, gridvs) = AxisData { _axis_visibility = def, _axis_viewport = newViewport,@@ -368,13 +367,19 @@ newViewport = vmap (min',max') newTropweiv = invmap (min',max') newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | v <- labelvs ]- newLabels = [ (v,labelf v) | v <- labelvs ]+ newLabels = zipWithLengthCheck labelvs (labelf labelvs)+ where+ zipWithLengthCheck (x:xs) (y:ys) = (x,y) : zipWithLengthCheck xs ys+ zipWithLengthCheck [] [] = []+ zipWithLengthCheck _ _ =+ error "makeAxis: label function returned the wrong number of labels"+ min' = minimum labelvs max' = maximum labelvs -- | Construct an axis given the positions for ticks, grid lines, and -- labels, and the positioning and labelling functions-makeAxis' :: Ord x => (x -> Double) -> (Double -> x) -> (x -> String)+makeAxis' :: Ord x => (x -> Double) -> (Double -> x) -> ([x] -> [String]) -> ([x],[x],[x]) -> AxisData x makeAxis' t f labelf (labelvs, tickvs, gridvs) = AxisData { _axis_visibility = def,@@ -382,7 +387,12 @@ _axis_tropweiv = invLinMap f t (minimum labelvs, maximum labelvs), _axis_ticks = zip tickvs (repeat 2) ++ zip labelvs (repeat 5), _axis_grid = gridvs,- _axis_labels = [[ (v,labelf v) | v <- labelvs ]]+ _axis_labels =+ let zipWithLengthCheck (x:xs) (y:ys) = (x,y) : zipWithLengthCheck xs ys+ zipWithLengthCheck [] [] = []+ zipWithLengthCheck _ _ =+ error "makeAxis': label function returned the wrong number of labels"+ in [zipWithLengthCheck labelvs (labelf labelvs)] } @@ -395,10 +405,6 @@ -- | The default 'LineStyle' of a plot area grid. defaultGridLineStyle :: LineStyle defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey--{-# DEPRECATED defaultAxisStyle "Use the according Data.Default instance!" #-}-defaultAxisStyle :: AxisStyle-defaultAxisStyle = def instance Default AxisStyle where def = AxisStyle
Graphics/Rendering/Chart/Axis/Unit.hs view
@@ -5,6 +5,7 @@ -- License : BSD-style (see chart/COPYRIGHT) -- -- Calculate and render unit indexed axes+{-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Rendering.Chart.Axis.Unit( unitAxis,
Graphics/Rendering/Chart/Backend.hs view
@@ -1,17 +1,16 @@ ----------------------------------------------------------------------------- -- |--- Module : Graphics.Rendering.Chart.Axis.Unit+-- Module : Graphics.Rendering.Chart.Backend -- Copyright : (c) Tim Docker 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- This module provides the API for drawing operations abstracted--- to arbitrary 'ChartBackend's.+-- to drive arbitrary Backend. module Graphics.Rendering.Chart.Backend ( -- * The backend Monad- ChartBackend- , CRender+ BackendProgram -- * Backend Operations , fillPath@@ -49,8 +48,6 @@ , FontSlant(..) , FontStyle(..) - , defaultFontStyle- , HTextAnchor(..) , VTextAnchor(..)
Graphics/Rendering/Chart/Backend/Impl.hs view
@@ -10,7 +10,7 @@ module Graphics.Rendering.Chart.Backend.Impl where -import Control.Monad.Reader+import Control.Monad import Control.Monad.Operational import Graphics.Rendering.Chart.Geometry@@ -22,20 +22,20 @@ -- | The abstract drawing operation generated when using the -- the chart drawing API.--- +-- -- See the documentation of the different function for the correct semantics -- of each instruction:--- +-- -- * 'strokePath', 'fillPath'--- +-- -- * 'drawText', 'textSize'--- +-- -- * 'getPointAlignFn', 'getCoordAlignFn', 'AlignmentFns'--- +-- -- * 'withTransform', 'withClipRegion'--- +-- -- * 'withLineStyle', 'withFillStyle', 'withFontStyle'--- +-- data ChartBackendInstr a where StrokePath :: Path -> ChartBackendInstr () FillPath :: Path -> ChartBackendInstr ()@@ -48,31 +48,27 @@ WithLineStyle :: LineStyle -> Program ChartBackendInstr a -> ChartBackendInstr a WithClipRegion :: Rect -> Program ChartBackendInstr a -> ChartBackendInstr a --- | A 'ChartBackend' provides the capability to render a chart somewhere.--- +-- | A 'BackendProgram' provides the capability to render a chart somewhere.+-- -- The coordinate system of the backend has its initial origin (0,0)--- in the top left corner of the drawing plane. The x-axis points --- towards the top right corner and the y-axis points towards +-- in the top left corner of the drawing plane. The x-axis points+-- towards the top right corner and the y-axis points towards -- the bottom left corner. The unit used by coordinates, the font size, -- and lengths is the always the same, but depends on the backend. -- All angles are measured in radians.--- --- The line, fill and font style are set to their default values +--+-- The line, fill and font style are set to their default values -- initially.--- --- Information about the semantics of the instructions can be +--+-- Information about the semantics of the instructions can be -- found in the documentation of 'ChartBackendInstr'.-type ChartBackend a = Program ChartBackendInstr a--{-# DEPRECATED CRender "Use the new name ChartBackend!" #-}--- | Alias so the old name for rendering code still works.-type CRender a = ChartBackend a+type BackendProgram a = Program ChartBackendInstr a --- | Stroke the outline of the given path using the +-- | Stroke the outline of the given path using the -- current 'LineStyle'. This function does /not/ perform -- alignment operations on the path. See 'Path' for the exact semantic -- of paths.-strokePath :: Path -> ChartBackend ()+strokePath :: Path -> BackendProgram () strokePath p = singleton (StrokePath p) -- | Fill the given path using the current 'FillStyle'.@@ -80,53 +76,53 @@ -- This function does /not/ perform -- alignment operations on the path. -- See 'Path' for the exact semantic of paths.-fillPath :: Path -> ChartBackend ()+fillPath :: Path -> BackendProgram () fillPath p = singleton (FillPath p) -- | Calculate a 'TextSize' object with rendering information -- about the given string without actually rendering it.-textSize :: String -> ChartBackend TextSize+textSize :: String -> BackendProgram TextSize textSize text = singleton (GetTextSize text) --- | Draw a single-line textual label anchored by the baseline (vertical) +-- | Draw a single-line textual label anchored by the baseline (vertical) -- left (horizontal) point. Uses the current 'FontStyle' for drawing.-drawText :: Point -> String -> ChartBackend ()+drawText :: Point -> String -> BackendProgram () drawText p text = singleton (DrawText p text) -- | Apply the given transformation in this local--- environment when drawing. The given transformation +-- environment when drawing. The given transformation -- is applied after the current transformation. This -- means both are combined.-withTransform :: Matrix -> ChartBackend a -> ChartBackend a+withTransform :: Matrix -> BackendProgram a -> BackendProgram a withTransform t p = singleton (WithTransform t p) -- | Use the given font style in this local -- environment when drawing text.--- --- An implementing backend is expected to guarentee+--+-- An implementing backend is expected to guarantee -- to support the following font families: @serif@, @sans-serif@ and @monospace@;--- --- If the backend is not able to find or load a given font +--+-- If the backend is not able to find or load a given font -- it is required to fall back to a custom fail-safe font -- and use it instead.-withFontStyle :: FontStyle -> ChartBackend a -> ChartBackend a+withFontStyle :: FontStyle -> BackendProgram a -> BackendProgram a withFontStyle fs p = singleton (WithFontStyle fs p) -- | Use the given fill style in this local -- environment when filling paths.-withFillStyle :: FillStyle -> ChartBackend a -> ChartBackend a+withFillStyle :: FillStyle -> BackendProgram a -> BackendProgram a withFillStyle fs p = singleton (WithFillStyle fs p) -- | Use the given line style in this local -- environment when stroking paths.-withLineStyle :: LineStyle -> ChartBackend a -> ChartBackend a+withLineStyle :: LineStyle -> BackendProgram a -> BackendProgram a withLineStyle ls p = singleton (WithLineStyle ls p) -- | Use the given clipping rectangle when drawing -- in this local environment. The new clipping region--- is intersected with the given clip region. You cannot +-- is intersected with the given clip region. You cannot -- escape the clip!-withClipRegion :: Rect -> ChartBackend a -> ChartBackend a+withClipRegion :: Rect -> BackendProgram a -> BackendProgram a withClipRegion c p = singleton (WithClipRegion c p) -- -----------------------------------------------------------------------@@ -134,10 +130,10 @@ -- ----------------------------------------------------------------------- -- | Get the point alignment function-getPointAlignFn :: ChartBackend (Point->Point)+getPointAlignFn :: BackendProgram (Point->Point) getPointAlignFn = liftM afPointAlignFn (singleton GetAlignments) -- | Get the coordinate alignment function-getCoordAlignFn :: ChartBackend (Point->Point)+getCoordAlignFn :: BackendProgram (Point->Point) getCoordAlignFn = liftM afCoordAlignFn (singleton GetAlignments)
Graphics/Rendering/Chart/Backend/Types.hs view
@@ -105,11 +105,6 @@ , _font_color = opaque black } -{-# DEPRECATED defaultFontStyle "Use the according Data.Default instance!" #-}--- | The default font style.-defaultFontStyle :: FontStyle-defaultFontStyle = def- -- | Possible horizontal anchor points for text. data HTextAnchor = HTA_Left | HTA_Centre @@ -141,12 +136,12 @@ -- The contained action sets the required fill -- style in the rendering state. newtype FillStyle = FillStyleSolid - { _fill_colour :: AlphaColour Double + { _fill_color :: AlphaColour Double } deriving (Show, Eq) -- | The default fill style. instance Default FillStyle where- def = FillStyleSolid { _fill_colour = opaque white }+ def = FillStyleSolid { _fill_color = opaque white } ------------------------------------------------------------------------- @@ -190,4 +185,5 @@ $( makeLenses ''LineStyle ) $( makeLenses ''FontStyle )+$( makeLenses ''FillStyle )
Graphics/Rendering/Chart/Drawing.hs view
@@ -27,21 +27,20 @@ PointShape(..) , PointStyle(..) , drawPoint- , defaultPointStyle- + -- * Alignments and Paths , alignPath , alignFillPath , alignStrokePath , alignFillPoints , alignStrokePoints- + , alignFillPoint , alignStrokePoint- + , strokePointPath , fillPointPath- + -- * Transformation and Style Helpers , withRotation , withTranslation@@ -49,17 +48,17 @@ , withScaleX, withScaleY , withPointStyle , withDefaultStyle- + -- * Text Drawing , drawTextA , drawTextR , drawTextsR , textDrawRect , textDimension- + -- * Style Helpers , defaultColorSeq- + , solidLine , dashedLine @@ -70,12 +69,13 @@ , plusses , exes , stars- + , arrows+ , solidFillStyle- + -- * Backend and general Types , module Graphics.Rendering.Chart.Backend- + -- * Accessors , point_color , point_border_color@@ -95,7 +95,6 @@ import Data.Colour import Data.Colour.Names import Data.List (unfoldr)-import Data.Monoid import Graphics.Rendering.Chart.Backend import Graphics.Rendering.Chart.Geometry hiding (moveTo)@@ -106,33 +105,33 @@ -- ----------------------------------------------------------------------- -- | Apply a local rotation. The angle is given in radians.-withRotation :: Double -> ChartBackend a -> ChartBackend a+withRotation :: Double -> BackendProgram a -> BackendProgram a withRotation angle = withTransform (rotate angle 1) -- | Apply a local translation.-withTranslation :: Point -> ChartBackend a -> ChartBackend a+withTranslation :: Point -> BackendProgram a -> BackendProgram a withTranslation p = withTransform (translate (pointToVec p) 1) -- | Apply a local scale.-withScale :: Vector -> ChartBackend a -> ChartBackend a+withScale :: Vector -> BackendProgram a -> BackendProgram a withScale v = withTransform (scale v 1) -- | Apply a local scale on the x-axis.-withScaleX :: Double -> ChartBackend a -> ChartBackend a+withScaleX :: Double -> BackendProgram a -> BackendProgram a withScaleX x = withScale (Vector x 1) -- | Apply a local scale on the y-axis.-withScaleY :: Double -> ChartBackend a -> ChartBackend a+withScaleY :: Double -> BackendProgram a -> BackendProgram a withScaleY y = withScale (Vector 1 y) -- | Changes the 'LineStyle' and 'FillStyle' to comply with -- the given 'PointStyle'.-withPointStyle :: PointStyle -> ChartBackend a -> ChartBackend a-withPointStyle (PointStyle cl bcl bw _ _) m = - withLineStyle (def { _line_color = bcl, _line_width = bw }) $ +withPointStyle :: PointStyle -> BackendProgram a -> BackendProgram a+withPointStyle (PointStyle cl bcl bw _ _) m =+ withLineStyle (def { _line_color = bcl, _line_width = bw, _line_join = LineJoinMiter }) $ withFillStyle (solidFillStyle cl) m -withDefaultStyle :: ChartBackend a -> ChartBackend a+withDefaultStyle :: BackendProgram a -> BackendProgram a withDefaultStyle = withLineStyle def . withFillStyle def . withFontStyle def -- -----------------------------------------------------------------------@@ -148,17 +147,17 @@ close -- | Align the path using the environment's alignment function for points.--- This is generally useful when stroking. +-- This is generally useful when stroking. -- See 'alignPath' and 'getPointAlignFn'.-alignStrokePath :: Path -> ChartBackend Path+alignStrokePath :: Path -> BackendProgram Path alignStrokePath p = do f <- getPointAlignFn return $ alignPath f p -- | Align the path using the environment's alignment function for coordinates.--- This is generally useful when filling. +-- This is generally useful when filling. -- See 'alignPath' and 'getCoordAlignFn'.-alignFillPath :: Path -> ChartBackend Path+alignFillPath :: Path -> BackendProgram Path alignFillPath p = do f <- getCoordAlignFn return $ alignPath f p@@ -166,7 +165,7 @@ -- | The points will be aligned by the 'getPointAlignFn', so that -- when drawing bitmaps, 1 pixel wide lines will be centred on the -- pixels.-alignStrokePoints :: [Point] -> ChartBackend [Point]+alignStrokePoints :: [Point] -> BackendProgram [Point] alignStrokePoints p = do f <- getPointAlignFn return $ fmap f p@@ -174,22 +173,22 @@ -- | The points will be aligned by the 'getCoordAlignFn', so that -- when drawing bitmaps, the edges of the region will fall between -- pixels.-alignFillPoints :: [Point] -> ChartBackend [Point]+alignFillPoints :: [Point] -> BackendProgram [Point] alignFillPoints p = do f <- getCoordAlignFn return $ fmap f p -- | Align the point using the environment's alignment function for points. -- See 'getPointAlignFn'.-alignStrokePoint :: Point -> ChartBackend Point-alignStrokePoint p = do +alignStrokePoint :: Point -> BackendProgram Point+alignStrokePoint p = do alignfn <- getPointAlignFn return (alignfn p) -- | Align the point using the environment's alignment function for coordinates. -- See 'getCoordAlignFn'.-alignFillPoint :: Point -> ChartBackend Point-alignFillPoint p = do +alignFillPoint :: Point -> BackendProgram Point+alignFillPoint p = do alignfn <- getCoordAlignFn return (alignfn p) @@ -201,11 +200,11 @@ stepPath [] = mempty -- | Draw lines between the specified points.-strokePointPath :: [Point] -> ChartBackend ()+strokePointPath :: [Point] -> BackendProgram () strokePointPath pts = strokePath $ stepPath pts -- | Fill the region with the given corners.-fillPointPath :: [Point] -> ChartBackend ()+fillPointPath :: [Point] -> BackendProgram () fillPointPath pts = fillPath $ stepPath pts -- -----------------------------------------------------------------------@@ -214,27 +213,27 @@ -- | Draw a line of text that is aligned at a different anchor point. -- See 'drawText'.-drawTextA :: HTextAnchor -> VTextAnchor -> Point -> String -> ChartBackend ()+drawTextA :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram () drawTextA hta vta = drawTextR hta vta 0 -{- +{- The following is useful for checking out the bounding-box calculation. At present it looks okay for PNG/Cairo but is a bit off for SVG/Diagrams; this may well be down to differences in how fonts are rendered in the two backends drawTextA hta vta p txt =- drawTextR hta vta 0 p txt - >> withLineStyle (solidLine 1 (opaque red)) + drawTextR hta vta 0 p txt+ >> withLineStyle (solidLine 1 (opaque red)) (textDrawRect hta vta p txt >>= \rect -> alignStrokePath (rectPath rect) >>= strokePath) -}- + -- | Draw a textual label anchored by one of its corners -- or edges, with rotation. Rotation angle is given in degrees, -- rotation is performed around anchor point. -- See 'drawText'.-drawTextR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> ChartBackend ()+drawTextR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> BackendProgram () drawTextR hta vta angle p s = withTranslation p $ withRotation theta $ do@@ -247,11 +246,11 @@ -- or edges, with rotation. Rotation angle is given in degrees, -- rotation is performed around anchor point. -- See 'drawText'.-drawTextsR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> ChartBackend ()+drawTextsR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> BackendProgram () drawTextsR hta vta angle p s = case num of 0 -> return () 1 -> drawTextR hta vta angle p s- _ -> + _ -> withTranslation p $ withRotation theta $ do tss <- mapM textSize ss@@ -298,7 +297,7 @@ -- | Return the bounding rectangle for a text string positioned -- where it would be drawn by 'drawText'. -- See 'textSize'.-textDrawRect :: HTextAnchor -> VTextAnchor -> Point -> String -> ChartBackend Rect+textDrawRect :: HTextAnchor -> VTextAnchor -> Point -> String -> BackendProgram Rect textDrawRect hta vta (Point x y) s = do ts <- textSize s -- This does not account for the pixel width of the label; e.g.@@ -316,11 +315,11 @@ -- | Get the width and height of the string when rendered. -- See 'textSize'.-textDimension :: String -> ChartBackend RectSize+textDimension :: String -> BackendProgram RectSize textDimension s = do ts <- textSize s return (textSizeWidth ts, textSizeHeight ts)- + -- ----------------------------------------------------------------------- -- Point Types and Drawing -- -----------------------------------------------------------------------@@ -331,6 +330,8 @@ | PointShapePlus -- ^ A plus sign. | PointShapeCross -- ^ A cross. | PointShapeStar -- ^ Combination of a cross and a plus.+ | PointShapeArrowHead Double+ | PointShapeEllipse Double Double -- ^ Ratio of minor to major axis and rotation -- | Abstract data type for the style of a plotted point. data PointStyle = PointStyle@@ -348,7 +349,7 @@ -- | Default style to use for points. instance Default PointStyle where- def = PointStyle + def = PointStyle { _point_color = opaque black , _point_border_color = transparent , _point_border_width = 0@@ -356,16 +357,11 @@ , _point_shape = PointShapeCircle } -{-# DEPRECATED defaultPointStyle "Use the according Data.Default instance!" #-}--- | Default style for points.-defaultPointStyle :: PointStyle-defaultPointStyle = def- -- | Draw a single point at the given location. drawPoint :: PointStyle -- ^ Style to use when rendering the point. -> Point -- ^ Position of the point to render.- -> ChartBackend ()-drawPoint ps@(PointStyle _ _ _ r shape) p = withPointStyle ps $ do+ -> BackendProgram ()+drawPoint ps@(PointStyle cl _ _ r shape) p = withPointStyle ps $ do p'@(Point x y) <- alignStrokePoint p case shape of PointShapeCircle -> do@@ -378,12 +374,15 @@ then fromIntegral n * 2*pi/fromIntegral sides else (0.5 + fromIntegral n)*2*pi/fromIntegral sides angles = map intToAngle [0 .. sides-1]- (p1:p1s) = map (\a -> Point (x + r * sin a)+ (p1:p1':p1s) = map (\a -> Point (x + r * sin a) (y + r * cos a)) angles- let path = G.moveTo p1 <> mconcat (map lineTo p1s) <> lineTo p1+ let path = G.moveTo p1 <> mconcat (map lineTo $ p1':p1s) <> lineTo p1 <> lineTo p1' fillPath path strokePath path- PointShapePlus -> + PointShapeArrowHead theta ->+ withTranslation p $ withRotation (theta - pi/2) $+ drawPoint (filledPolygon r 3 True cl) (Point 0 0)+ PointShapePlus -> strokePath $ moveTo' (x+r) y <> lineTo' (x-r) y <> moveTo' x (y-r)@@ -404,6 +403,11 @@ <> lineTo' (x-rad) (y-rad) <> moveTo' (x+rad) (y-rad) <> lineTo' (x-rad) (y+rad)+ PointShapeEllipse b theta ->+ withTranslation p $ withRotation theta $ withScaleX b $ do+ let path = arc (Point 0 0) r 0 (2*pi)+ fillPath path+ strokePath path -- ----------------------------------------------------------------------- -- Style Helpers@@ -431,7 +435,7 @@ filledCircles :: Double -- ^ Radius of circle. -> AlphaColour Double -- ^ Fill colour. -> PointStyle-filledCircles radius cl = +filledCircles radius cl = PointStyle cl transparent 0 radius PointShapeCircle -- | Style for stroked circle points.@@ -439,7 +443,7 @@ -> Double -- ^ Thickness of line. -> AlphaColour Double -- Colour of line. -> PointStyle-hollowCircles radius w cl = +hollowCircles radius w cl = PointStyle transparent cl w radius PointShapeCircle -- | Style for stroked polygon points.@@ -449,7 +453,7 @@ -> Bool -- ^ Is right-side-up? -> AlphaColour Double -- ^ Colour of line. -> PointStyle-hollowPolygon radius w sides isrot cl = +hollowPolygon radius w sides isrot cl = PointStyle transparent cl w radius (PointShapePolygon sides isrot) -- | Style for filled polygon points.@@ -458,7 +462,7 @@ -> Bool -- ^ Is right-side-up? -> AlphaColour Double -- ^ Fill color. -> PointStyle-filledPolygon radius sides isrot cl = +filledPolygon radius sides isrot cl = PointStyle cl transparent 0 radius (PointShapePolygon sides isrot) -- | Plus sign point style.@@ -466,7 +470,7 @@ -> Double -- ^ Thickness of line. -> AlphaColour Double -- ^ Color of line. -> PointStyle-plusses radius w cl = +plusses radius w cl = PointStyle transparent cl w radius PointShapePlus -- | Cross point style.@@ -484,6 +488,14 @@ -> PointStyle stars radius w cl = PointStyle transparent cl w radius PointShapeStar++arrows :: Double -- ^ Radius of circle.+ -> Double -- ^ Rotation (Tau)+ -> Double -- ^ Thickness of line.+ -> AlphaColour Double -- ^ Color of line.+ -> PointStyle+arrows radius angle w cl =+ PointStyle transparent cl w radius (PointShapeArrowHead angle) -- | Fill style that fill everything this the given colour. solidFillStyle :: AlphaColour Double -> FillStyle
+ Graphics/Rendering/Chart/Easy.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}+----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Chart.Easy+-- Copyright : (c) Tim Docker 2014+-- License : BSD-style (see chart/COPYRIGHT)+--+-- A high level API for generating a plot quickly.+--+-- Importing the Easy module brings into scope all core functions and types required+-- for working with the chart library. This includes key external dependencies such as+-- Control.Lens and Data.Colour. The module also provides several helper functions for+-- quickly generating common plots. Note that chart backends must still be explicitly+-- imported, as some backends cannot be built on all platforms.+--+-- Example usage:+--+-- > import Graphics.Rendering.Chart.Easy+-- > import Graphics.Rendering.Chart.Backend.Cairo+-- >+-- > signal :: [Double] -> [(Double,Double)]+-- > signal xs = [ (x,(sin (x*3.14159/45) + 1) / 2 * (sin (x*3.14159/5))) | x <- xs ]+-- >+-- > main = toFile def "example.png" $ do+-- > layout_title .= "Amplitude Modulation"+-- > plot (line "am" [signal [0,(0.5)..400]])+-- > plot (points "am points" (signal [0,7..400]))+--+-- More examples can be found on the <https://github.com/timbod7/haskell-chart/wiki library's wiki>++module Graphics.Rendering.Chart.Easy(++ module Control.Lens,+ module Data.Default.Class,+ module Data.Colour,+ module Data.Colour.Names,++ module Graphics.Rendering.Chart,+ module Graphics.Rendering.Chart.State,++ line,+ points,+ bars,+ setColors,+ setShapes+ ) where++import Control.Lens+import Control.Monad(unless)+import Data.Default.Class+import Data.Colour hiding (over) -- overlaps with lens over function+import Data.Colour.Names+import Graphics.Rendering.Chart+import Graphics.Rendering.Chart.State++-- | Set the contents of the colour source, for+-- subsequent plots+setColors :: [AlphaColour Double] -> EC l ()+setColors cs = liftCState $ colors .= cycle cs++-- | Set the contents of the shape source, for+-- subsequent plots+setShapes :: [PointShape] -> EC l ()+setShapes ps = liftCState $ shapes .= cycle ps++-- | Constuct a line plot with the given title and+-- data, using the next available color.+line :: String -> [[(x,y)]] -> EC l (PlotLines x y)+line title values = liftEC $ do+ color <- takeColor+ plot_lines_title .= title+ plot_lines_values .= values+ plot_lines_style . line_color .= color++-- | Construct a scatter plot with the given title and data, using the+-- next available color and point shape.+points :: String -> [(x,y)] -> EC l (PlotPoints x y)+points title values = liftEC $ do+ color <- takeColor+ shape <- takeShape+ plot_points_values .= values+ plot_points_title .= title+ plot_points_style . point_color .= color+ plot_points_style . point_shape .= shape+ plot_points_style . point_radius .= 2++ -- Show borders for unfilled shapes+ unless (isFilled shape) $ do+ plot_points_style . point_border_color .= color+ plot_points_style . point_border_width .= 1++isFilled :: PointShape -> Bool+isFilled PointShapeCircle = True+isFilled PointShapePolygon{} = True+isFilled _ = False++-- | Construct a bar chart with the given titles and data, using the+-- next available colors+bars :: (PlotValue x, BarsPlotValue y) => [String] -> [(x,[y])] -> EC l (PlotBars x y)+bars titles vals = liftEC $ do+ styles <- sequence [fmap mkStyle takeColor | _ <- titles]+ plot_bars_titles .= titles+ plot_bars_values .= vals+ plot_bars_style .= BarsClustered+ plot_bars_spacing .= BarsFixGap 30 5+ plot_bars_item_styles .= styles+ where+ mkStyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black))
Graphics/Rendering/Chart/Geometry.hs view
@@ -3,7 +3,7 @@ -- Module : Graphics.Rendering.Chart.Geometry -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT)--- +-- module Graphics.Rendering.Chart.Geometry ( -- * Points and Vectors Rect(..)@@ -12,7 +12,7 @@ , RectSize , Range- + , pointToVec , mkrect@@ -20,6 +20,8 @@ , pvadd , pvsub , psub+ , vangle+ , vlen , vscale , within , intersectRect@@ -27,7 +29,7 @@ , RectEdge(..) , Limit(..) , PointMapFn- + -- * Paths , Path(..) , lineTo, moveTo@@ -35,10 +37,10 @@ , arc, arc' , arcNeg, arcNeg' , close- + , foldPath , makeLinesExplicit- + -- * Matrices , transformP, scaleP, rotateP, translateP , Matrix(..)@@ -49,8 +51,13 @@ , invert ) where -import Data.Monoid+import qualified Prelude+import Prelude hiding ((^)) +-- The homomorphic version to avoid casts inside the code.+(^) :: Num a => a -> Integer -> a+(^) = (Prelude.^)+ -- | A point in two dimensions. data Point = Point { p_x :: Double,@@ -67,6 +74,17 @@ pointToVec :: Point -> Vector pointToVec (Point x y) = Vector x y +-- | Angle of a vector (counterclockwise from positive x-axis)+vangle :: Vector -> Double+vangle (Vector x y)+ | x > 0 = atan (y/x)+ | x < 0 = atan (y/x) + pi+ | otherwise = if y > 0 then pi/2 else -pi/2++-- | Length/magnitude of a vector+vlen :: Vector -> Double+vlen (Vector x y) = sqrt $ x^2 + y^2+ -- | Scale a vector by a constant. vscale :: Double -> Vector -> Vector vscale c (Vector x y) = Vector (x*c) (y*c)@@ -115,11 +133,11 @@ intersectRect r LMax = r intersectRect LMin _ = LMin intersectRect _ LMin = LMin-intersectRect (LValue (Rect (Point x11 y11) (Point x12 y12))) +intersectRect (LValue (Rect (Point x11 y11) (Point x12 y12))) (LValue (Rect (Point x21 y21) (Point x22 y22))) = let p1@(Point x1 y1) = Point (max x11 x21) (max y11 y21) p2@(Point x2 y2) = Point (min x12 x22) (min y12 y22)- in if x2 < x1 || y2 < y1 + in if x2 < x1 || y2 < y1 then LMin else LValue $ Rect p1 p2 @@ -130,14 +148,14 @@ -- | Make a path from a rectangle. rectPointPath :: Rect -> [Point] rectPointPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = [p1,p2,p3,p4,p1]- where + where p2 = (Point x1 y2) p4 = (Point x2 y1) -} -- | Make a path from a rectangle. rectPath :: Rect -> Path-rectPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = +rectPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = let p2 = Point x1 y2 p4 = Point x2 y1 in moveTo p1 <> lineTo p2 <> lineTo p3 <> lineTo p4 <> close@@ -147,44 +165,47 @@ -- ----------------------------------------------------------------------- -- | The path type used by Charts.--- +-- -- A path can consist of several subpaths. Each -- is started by a 'MoveTo' operation. All subpaths -- are open, except the last one, which may be closed -- using the 'Close' operation. When filling a path -- all subpaths are closed implicitly.--- +-- -- Closing a subpath means that a line is drawn from -- the end point to the start point of the subpath.--- +-- -- If a 'Arc' (or 'ArcNeg') is drawn a implicit line -- from the last end point of the subpath is drawn -- to the beginning of the arc. Another implicit line -- is drawn from the end of an arc to the beginning of -- the next path segment.--- +-- -- The beginning of a subpath is either (0,0) or set -- by a 'MoveTo' instruction. If the first subpath is started -- with an arc the beginning of that subpath is the beginning -- of the arc.-data Path = MoveTo Point Path +data Path = MoveTo Point Path | LineTo Point Path | Arc Point Double Double Double Path | ArcNeg Point Double Double Double Path- | End + | End | Close -- | Paths are monoids. After a path is closed you can not append--- anything to it anymore. The empty path is open. +-- anything to it anymore. The empty path is open. -- Use 'close' to close a path.-instance Monoid Path where- mappend p1 p2 = case p1 of- MoveTo p path -> MoveTo p $ mappend path p2- LineTo p path -> LineTo p $ mappend path p2- Arc p r a1 a2 path -> Arc p r a1 a2 $ mappend path p2- ArcNeg p r a1 a2 path -> ArcNeg p r a1 a2 $ mappend path p2+instance Semigroup Path where+ p1 <> p2 = case p1 of+ MoveTo p path -> MoveTo p $ path <> p2+ LineTo p path -> LineTo p $ path <> p2+ Arc p r a1 a2 path -> Arc p r a1 a2 $ path <> p2+ ArcNeg p r a1 a2 path -> ArcNeg p r a1 a2 $ path <> p2 End -> p2 Close -> Close++instance Monoid Path where+ mappend = (<>) mempty = End -- | Move the paths pointer to the given location.@@ -195,7 +216,7 @@ moveTo' :: Double -> Double -> Path moveTo' x y = moveTo $ Point x y --- | Move the paths pointer to the given location and draw a straight +-- | Move the paths pointer to the given location and draw a straight -- line while doing so. lineTo :: Point -> Path lineTo p = LineTo p mempty@@ -211,7 +232,7 @@ -- is smaller then the start angle it is increased by multiples of -- @2 * pi@ until is is greater or equal. arc :: Point -- ^ Center point of the circle arc.- -> Double -- ^ Redius of the circle.+ -> Double -- ^ Radius of the circle. -> Double -- ^ Angle to start drawing at, in radians. -> Double -- ^ Angle to stop drawing at, in radians. -> Path@@ -243,13 +264,13 @@ -> m -- ^ Close -> Path -- ^ Path to fold -> m-foldPath moveTo_ lineTo_ arc_ arcNeg_ close_ path = +foldPath moveTo_ lineTo_ arc_ arcNeg_ close_ path = let restF = foldPath moveTo_ lineTo_ arc_ arcNeg_ close_- in case path of - MoveTo p rest -> moveTo_ p <> restF rest- LineTo p rest -> lineTo_ p <> restF rest- Arc p r a1 a2 rest -> arc_ p r a1 a2 <> restF rest- ArcNeg p r a1 a2 rest -> arcNeg_ p r a1 a2 <> restF rest+ in case path of+ MoveTo p rest -> moveTo_ p `mappend` restF rest+ LineTo p rest -> lineTo_ p `mappend` restF rest+ Arc p r a1 a2 rest -> arc_ p r a1 a2 `mappend` restF rest+ ArcNeg p r a1 a2 rest -> arcNeg_ p r a1 a2 `mappend` restF rest End -> mempty Close -> close_ @@ -257,9 +278,9 @@ -- that otherwise would be implicit. See 'Path' for details -- about what lines in paths are implicit. makeLinesExplicit :: Path -> Path-makeLinesExplicit (Arc c r s e rest) = +makeLinesExplicit (Arc c r s e rest) = Arc c r s e $ makeLinesExplicit' rest-makeLinesExplicit (ArcNeg c r s e rest) = +makeLinesExplicit (ArcNeg c r s e rest) = ArcNeg c r s e $ makeLinesExplicit' rest makeLinesExplicit path = makeLinesExplicit' path @@ -267,15 +288,15 @@ makeLinesExplicit' :: Path -> Path makeLinesExplicit' End = End makeLinesExplicit' Close = Close-makeLinesExplicit' (Arc c r s e rest) = +makeLinesExplicit' (Arc c r s e rest) = let p = translateP (pointToVec c) $ rotateP s $ Point r 0 in lineTo p <> arc c r s e <> makeLinesExplicit' rest-makeLinesExplicit' (ArcNeg c r s e rest) = +makeLinesExplicit' (ArcNeg c r s e rest) = let p = translateP (pointToVec c) $ rotateP s $ Point r 0 in lineTo p <> arcNeg c r s e <> makeLinesExplicit' rest-makeLinesExplicit' (MoveTo p0 rest) = +makeLinesExplicit' (MoveTo p0 rest) = MoveTo p0 $ makeLinesExplicit' rest-makeLinesExplicit' (LineTo p0 rest) = +makeLinesExplicit' (LineTo p0 rest) = LineTo p0 $ makeLinesExplicit' rest -- -----------------------------------------------------------------------@@ -326,12 +347,12 @@ negate = pointwise negate abs = pointwise abs signum = pointwise signum- + fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0 -- | Copied from Graphics.Rendering.Cairo.Matrix {-# INLINE pointwise #-}-pointwise :: (Double -> Double) -> Matrix -> Matrix +pointwise :: (Double -> Double) -> Matrix -> Matrix pointwise f (Matrix xx_ yx_ xy_ yy_ x0_ y0_) = Matrix (f xx_) (f yx_) (f xy_) (f yy_) (f x0_) (f y0_) @@ -373,4 +394,3 @@ invert :: Matrix -> Matrix invert m@(Matrix xx_ yx_ xy_ yy_ _ _) = scalarMultiply (recip det) $ adjoint m where det = xx_*yy_ - yx_*xy_-
Graphics/Rendering/Chart/Grid.hs view
@@ -218,9 +218,9 @@ ---------------------------------------------------------------------- type DArray = Array Int Double -getSizes :: Grid (Renderable a) -> ChartBackend (DArray, DArray, DArray, DArray)+getSizes :: Grid (Renderable a) -> BackendProgram (DArray, DArray, DArray, DArray) getSizes t = do- szs <- mapGridM minsize t :: ChartBackend (Grid RectSize)+ szs <- mapGridM minsize t :: BackendProgram (Grid RectSize) let szs' = flatten szs let widths = accumArray max 0 (0, width t - 1) (foldT (ef wf fst) [] szs')@@ -246,7 +246,7 @@ gridToRenderable :: Grid (Renderable a) -> Renderable a gridToRenderable gt = Renderable minsizef renderf where- minsizef :: ChartBackend RectSize+ minsizef :: BackendProgram RectSize minsizef = do (widths, heights, _, _) <- getSizes gt return (sum (elems widths), sum (elems heights))
Graphics/Rendering/Chart/Layout.hs view
@@ -11,27 +11,21 @@ -- (see 'Control.Lens') for each field of the following data types: -- -- * 'Layout'--- +-- -- * 'LayoutLR'--- +-- -- * 'StackedLayouts' -- -- * 'LayoutAxis' ----- These accessors are not shown in this API documentation. They have--- the same name as the field, but with the leading underscore--- dropped. Hence for data field @_f::F@ in type @D@, they have type------ @--- f :: `Control.Lens.Lens'` D F--- @---+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ExistentialQuantification #-} module Graphics.Rendering.Chart.Layout- ( Layout(..)+ ( -- * Types+ Layout(..) , LayoutLR(..) , LayoutAxis(..) , LayoutPick(..)@@ -39,23 +33,23 @@ , StackedLayout(..) -- , LegendItem haddock complains about this being missing, but from what? , MAxisFn- ++ -- * Rendering , layoutToRenderable+ , layoutToGrid , layoutLRToRenderable-- , setLayoutForeground- , updateAllAxesStyles- , setLayoutLRForeground- , updateAllAxesStylesLR+ , layoutLRToGrid+ , renderStackedLayouts - , defaultLayoutAxis+ -- * LayoutAxis lenses , laxis_title_style , laxis_title , laxis_style , laxis_generate , laxis_override , laxis_reverse- ++ -- * Layout lenses , layout_background , layout_plot_background , layout_title@@ -70,7 +64,13 @@ , layout_plots , layout_legend , layout_grid_last- ++ , layout_axes_styles+ , layout_axes_title_styles+ , layout_all_font_styles+ , layout_foreground++ -- * LayoutLR lenses , layoutlr_background , layoutlr_plot_background , layoutlr_title@@ -87,13 +87,20 @@ , layoutlr_margin , layoutlr_grid_last - , defaultStackedLayouts+ , layoutlr_axes_styles+ , layoutlr_axes_title_styles+ , layoutlr_all_font_styles+ , layoutlr_foreground++ -- * StackedLayouts lenses , slayouts_layouts , slayouts_compress_legend-- , renderStackedLayouts ) where +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+ import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing@@ -113,11 +120,11 @@ type MAxisFn t = [t] -> Maybe (AxisData t) -- | Type of axis that is used in 'Layout' and 'LayoutLR'.--- +-- -- To generate the actual axis type ('AxisData' and 'AxisT') -- the '_laxis_generate' function is called and custom settings -- are applied with '_laxis_override'. Note that the 'AxisVisibility'--- values in 'Layout' and 'LayoutLR' override visibility related +-- values in 'Layout' and 'LayoutLR' override visibility related -- settings of the axis. data LayoutAxis x = LayoutAxis { _laxis_title_style :: FontStyle@@ -130,42 +137,42 @@ , _laxis_generate :: AxisFn x -- ^ Function that generates the axis data, based upon the -- points plotted. The default value is 'autoAxis'.- + , _laxis_override :: AxisData x -> AxisData x -- ^ Function that can be used to override the generated axis data. -- The default value is 'id'.- + , _laxis_reverse :: Bool -- ^ True if left to right (bottom to top) is to show descending values.- + } -- | Information on what is at a specifc location of a 'Layout' or 'LayoutLR'. -- This is delivered by the 'PickFn' of a 'Renderable'.-data LayoutPick x y1 y2 = LayoutPick_Legend String -- ^ A legend entry.- | LayoutPick_Title String -- ^ The title.- | LayoutPick_XTopAxisTitle String -- ^ The title of the top x axis.- | LayoutPick_XBottomAxisTitle String -- ^ The title of the bottom x axis.- | LayoutPick_YLeftAxisTitle String -- ^ The title of the left y axis.- | LayoutPick_YRightAxisTitle String -- ^ The title of the right y axis.- | LayoutPick_PlotArea x y1 y2 -- ^ The plot area at the given plot coordinates.- | LayoutPick_XTopAxis x -- ^ The top x axis at the given plot coordinate.- | LayoutPick_XBottomAxis x -- ^ The bottom x axis at the given plot coordinate.- | LayoutPick_YLeftAxis y1 -- ^ The left y axis at the given plot coordinate.- | LayoutPick_YRightAxis y2 -- ^ The right y axis at the given plot coordinate.+data LayoutPick x y1 y2 = LayoutPick_Legend String -- ^ A legend entry.+ | LayoutPick_Title String -- ^ The title.+ | LayoutPick_XTopAxisTitle String -- ^ The title of the top x axis.+ | LayoutPick_XBottomAxisTitle String -- ^ The title of the bottom x axis.+ | LayoutPick_YLeftAxisTitle String -- ^ The title of the left y axis.+ | LayoutPick_YRightAxisTitle String -- ^ The title of the right y axis.+ | LayoutPick_PlotArea x y1 y2 -- ^ The plot area at the given plot coordinates.+ | LayoutPick_XTopAxis x -- ^ The top x axis at the given plot coordinate.+ | LayoutPick_XBottomAxis x -- ^ The bottom x axis at the given plot coordinate.+ | LayoutPick_YLeftAxis y1 -- ^ The left y axis at the given plot coordinate.+ | LayoutPick_YRightAxis y2 -- ^ The right y axis at the given plot coordinate. deriving (Show) -type LegendItem = (String,Rect -> ChartBackend ())+type LegendItem = (String,Rect -> BackendProgram ()) -- | A Layout value is a single plot area, with single x and y -- axis. The title is at the top and the legend at the bottom. It's -- parametrized by the types of values to be plotted on the x -- and y axes.-data Layout x y = Layout +data Layout x y = Layout { _layout_background :: FillStyle -- ^ How to fill the background of everything. , _layout_plot_background :: Maybe FillStyle- -- ^ How to fill the background of the plot, + -- ^ How to fill the background of the plot, -- if different from the overall background. , _layout_title :: String@@ -189,7 +196,7 @@ , _layout_plots :: [Plot x y] -- ^ The data sets to plot in the chart.- -- The are ploted over each other.+ -- They are plotted over each other. , _layout_legend :: Maybe LegendStyle -- ^ How to style the legend.@@ -205,18 +212,24 @@ -- | Render the given 'Layout'. layoutToRenderable :: forall x y . (Ord x, Ord y) => Layout x y -> Renderable (LayoutPick x y y)-layoutToRenderable lxy = fillBackground (_layout_background lxy) - $ gridToRenderable (layoutToGrid lxy)+layoutToRenderable l = fillBackground (_layout_background l) $ gridToRenderable (layoutToGrid l)++layoutToGrid :: forall x y . (Ord x, Ord y) => Layout x y -> Grid (Renderable (LayoutPick x y y))+layoutToGrid l = grid where- layoutToGrid l = aboveN- [ tval $ titleToRenderable (_layout_margin l) (_layout_title_style l) (_layout_title l)- , weights (1,1) $ tval $ gridToRenderable $- addMarginsToGrid (lm,lm,lm,lm) (layoutPlotAreaToGrid l)- , tval $ renderLegend l (getLegendItems l)- ]+ lp :: Grid a -> a -> Grid a+ lp = case maybe LegendBelow _legend_position $ _layout_legend l of+ LegendAbove -> flip wideAbove+ LegendBelow -> aboveWide+ LegendRight -> besideTall+ LegendLeft -> flip tallBeside - lm = _layout_margin lxy- + title = titleToRenderable lm (_layout_title_style l) (_layout_title l)+ plotArea = addMarginsToGrid (lm,lm,lm,lm) (layoutPlotAreaToGrid l)+ legend = renderLegend l (getLegendItems l)+ grid = title `wideAbove` (plotArea `lp` legend)+ lm = _layout_margin l+ getLayoutXVals :: Layout x y -> [x] getLayoutXVals l = concatMap (fst . _plot_all_points) (_layout_plots l) @@ -231,7 +244,7 @@ g = besideN [ tval $ mkLegend (_layout_legend l) (_layout_margin l) legItems , weights (1,1) $ tval emptyRenderable ] --- | Render the plot area of a 'Layout'. This consists of the +-- | Render the plot area of a 'Layout'. This consists of the -- actual plot area with all plots, the axis and their titles. layoutPlotAreaToGrid :: forall x y. (Ord x, Ord y) => Layout x y -> Grid (Renderable (LayoutPick x y y))@@ -259,7 +272,7 @@ } -- | Render the plots of a 'Layout' to a plot area of given size.- renderPlots :: Layout x y -> RectSize -> ChartBackend (PickFn (LayoutPick x y y))+ renderPlots :: Layout x y -> RectSize -> BackendProgram (PickFn (LayoutPick x y y)) renderPlots lxy sz@(w,h) = do unless (_layout_grid_last lxy) (renderGrids sz axes) withClipRegion (Rect (Point 0 0) (Point w h)) $@@ -289,7 +302,7 @@ mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr) mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr) --- | Empty 'Layout' without title and plots. The background is white and +-- | Empty 'Layout' without title and plots. The background is white and -- the grid is drawn beneath all plots. There will be a legend. The top -- and right axis will not be visible. instance (PlotValue x, PlotValue y) => Default (Layout x y) where@@ -300,7 +313,7 @@ , _layout_title = "" , _layout_title_style = def { _font_size = 15 , _font_weight = FontWeightBold }- + , _layout_x_axis = def , _layout_top_axis_visibility = def { _axis_show_line = False , _axis_show_ticks = False@@ -319,16 +332,16 @@ } ----------------------------------------------------------------------- + -- | A LayoutLR value is a single plot area, with an x axis and -- independent left and right y axes, with a title at the top; -- legend at the bottom. It's parametrized by the types of values -- to be plotted on the x and two y axes.-data LayoutLR x y1 y2 = LayoutLR +data LayoutLR x y1 y2 = LayoutLR { _layoutlr_background :: FillStyle -- ^ How to fill the background of everything. , _layoutlr_plot_background :: Maybe FillStyle- -- ^ How to fill the background of the plot, + -- ^ How to fill the background of the plot, -- if different from the overall background. , _layoutlr_title :: String@@ -351,10 +364,10 @@ -- ^ Rules to generate the right y axis. , _layoutlr_right_axis_visibility :: AxisVisibility -- ^ Visibility options for the right axis.- + , _layoutlr_plots :: [Either (Plot x y1) (Plot x y2)] -- ^ The data sets to plot in the chart.- -- The are ploted over each other.+ -- They are plotted over each other. -- The either type associates the plot with the -- left or right y axis. @@ -371,19 +384,21 @@ toRenderable = setPickFn nullPickFn . layoutLRToRenderable -- | Render the given 'LayoutLR'.-layoutLRToRenderable :: forall x yl yr . (Ord x, Ord yl, Ord yr) +layoutLRToRenderable :: forall x yl yr . (Ord x, Ord yl, Ord yr) => LayoutLR x yl yr -> Renderable (LayoutPick x yl yr)-layoutLRToRenderable llr = fillBackground (_layoutlr_background llr) - $ gridToRenderable (layoutLRToGrid llr)- where- layoutLRToGrid l = aboveN- [ tval $ titleToRenderable (_layoutlr_margin l) (_layoutlr_title_style l) (_layoutlr_title l)- , weights (1,1) $ tval $ gridToRenderable $- addMarginsToGrid (lm,lm,lm,lm) (layoutLRPlotAreaToGrid l)- , tval $ renderLegendLR l (getLegendItemsLR l)- ]+layoutLRToRenderable l = fillBackground (_layoutlr_background l)+ $ gridToRenderable (layoutLRToGrid l) - lm = _layoutlr_margin llr+layoutLRToGrid :: forall x yl yr . (Ord x, Ord yl, Ord yr)+ => LayoutLR x yl yr -> Grid (Renderable (LayoutPick x yl yr))+layoutLRToGrid l = grid+ where+ grid = titleToRenderable lm (_layoutlr_title_style l) (_layoutlr_title l)+ `wideAbove`+ addMarginsToGrid (lm,lm,lm,lm) (layoutLRPlotAreaToGrid l)+ `aboveWide`+ renderLegendLR l (getLegendItemsLR l)+ lm = _layoutlr_margin l getLayoutLRXVals :: LayoutLR x yl yr -> [x] getLayoutLRXVals l = concatMap deEither $ _layoutlr_plots l@@ -409,8 +424,8 @@ , tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) rights ] -- lm = _layoutlr_margin l -layoutLRPlotAreaToGrid :: forall x yl yr. (Ord x, Ord yl, Ord yr) - => LayoutLR x yl yr +layoutLRPlotAreaToGrid :: forall x yl yr. (Ord x, Ord yl, Ord yr)+ => LayoutLR x yl yr -> Grid (Renderable (LayoutPick x yl yr)) layoutLRPlotAreaToGrid l = buildGrid LayoutGridElements{ lge_plots = mfill (_layoutlr_plot_background l) $ plotsToRenderable l,@@ -425,7 +440,7 @@ ++ [ x | (Right p) <- _layoutlr_plots l, x <- fst $ _plot_all_points p] yvalsL = [ y | (Left p) <- _layoutlr_plots l, y <- snd $ _plot_all_points p] yvalsR = [ y | (Right p) <- _layoutlr_plots l, y <- snd $ _plot_all_points p]- + bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_bottom_axis_visibility) xvals tAxis = mkAxis E_Top (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_top_axis_visibility ) xvals lAxis = mkAxis E_Left (overrideAxisVisibility l _layoutlr_left_axis _layoutlr_left_axis_visibility ) yvalsL@@ -437,7 +452,7 @@ render = renderPlots llr } - renderPlots :: LayoutLR x yl yr -> RectSize -> ChartBackend (PickFn (LayoutPick x yl yr))+ renderPlots :: LayoutLR x yl yr -> RectSize -> BackendProgram (PickFn (LayoutPick x yl yr)) renderPlots llr sz@(w,h) = do unless (_layoutlr_grid_last llr) (renderGrids sz axes) withClipRegion (Rect (Point 0 0) (Point w h)) $@@ -478,21 +493,23 @@ -- | A container for a set of vertically 'StackedLayout's. -- The x axis of the different layouts will be aligned.-data StackedLayouts x = StackedLayouts +data StackedLayouts x = StackedLayouts { _slayouts_layouts :: [StackedLayout x] -- ^ The stacked layouts from top (first element) to bottom (last element). , _slayouts_compress_legend :: Bool -- ^ If the different legends shall be combined in one legend at the bottom. } -{-# DEPRECATED defaultStackedLayouts "Use the according Data.Default instance!" #-}-defaultStackedLayouts :: StackedLayouts x-defaultStackedLayouts = def- -- | A empty 'StackedLayout' with compressions applied. instance Default (StackedLayouts x) where def = StackedLayouts [] True +++instance Ord x => ToRenderable (StackedLayouts x) where+ toRenderable = renderStackedLayouts++ -- | Render several layouts with the same x-axis type and range, -- vertically stacked so that their origins and x-values are aligned. --@@ -504,7 +521,7 @@ where g = fullOverlayUnder (fillBackground bg emptyRenderable) $ foldr (above.mkGrid) nullt (zip sls [0,1..])- + mkGrid :: (StackedLayout x, Int) -> Grid (Renderable ()) mkGrid (sl, i) = titleR@@ -519,21 +536,21 @@ legendR = case sl of StackedLayout l -> noPickFn $ renderLegend l $ fst legenditems StackedLayoutLR l -> noPickFn $ renderLegendLR l legenditems- + legenditems = case (_slayouts_compress_legend slp,isBottomPlot) of (False,_) -> case sl of StackedLayout l -> (getLegendItems l, []) StackedLayoutLR l -> getLegendItemsLR l (True,True) -> allLegendItems (True,False) -> ([],[])- + mkPlotArea :: LayoutAxis x -> Grid (Renderable ()) mkPlotArea axis = case sl of- StackedLayout l -> fmap noPickFn - $ layoutPlotAreaToGrid + StackedLayout l -> fmap noPickFn+ $ layoutPlotAreaToGrid $ l { _layout_x_axis = axis }- StackedLayoutLR l -> fmap noPickFn - $ layoutLRPlotAreaToGrid + StackedLayoutLR l -> fmap noPickFn+ $ layoutLRPlotAreaToGrid $ l { _layoutlr_x_axis = axis } showLegend = not (null (fst legenditems)) || not (null (snd legenditems))@@ -543,37 +560,37 @@ lm = case sl of StackedLayout l -> _layout_margin l StackedLayoutLR l -> _layoutlr_margin l- + xAxis :: LayoutAxis x xAxis = case sl of StackedLayout l -> _layout_x_axis l StackedLayoutLR l -> _layoutlr_x_axis l- + usedAxis :: LayoutAxis x- usedAxis = xAxis + usedAxis = xAxis { _laxis_generate = const (_laxis_generate xAxis all_xvals) }- + bg = case sl1 of StackedLayout l -> _layout_background l StackedLayoutLR l -> _layoutlr_background l- + getXVals :: StackedLayout x -> [x] getXVals (StackedLayout l) = getLayoutXVals l getXVals (StackedLayoutLR l) = getLayoutLRXVals l- + all_xvals = concatMap getXVals sls allLegendItems = (concatMap (fst.legendItems) sls, concatMap (snd.legendItems) sls)- + legendItems :: StackedLayout x -> ([LegendItem], [LegendItem]) legendItems (StackedLayout l) = (getLegendItems l, []) legendItems (StackedLayoutLR l) = getLegendItemsLR l- + noPickFn :: Renderable a -> Renderable () noPickFn = mapPickFn (const ()) ----------------------------------------------------------------------- + addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a) -> Grid (Renderable a) addMarginsToGrid (t,b,l,r) g = aboveN [@@ -605,7 +622,7 @@ data LayoutGridElements x yl yr = LayoutGridElements { lge_plots :: Renderable (LayoutPick x yl yr),- + lge_taxis :: (Maybe (AxisT x),String,FontStyle), lge_baxis :: (Maybe (AxisT x),String,FontStyle), lge_laxis :: (Maybe (AxisT yl),String,FontStyle),@@ -642,7 +659,7 @@ (btitle,_) = mktitle HTA_Centre VTA_Top 0 blbl bstyle LayoutPick_XBottomAxisTitle (ltitle,lam) = mktitle HTA_Right VTA_Centre 270 llbl lstyle LayoutPick_YLeftAxisTitle (rtitle,ram) = mktitle HTA_Left VTA_Centre 270 rlbl rstyle LayoutPick_YRightAxisTitle- + baxis = tval $ maybe emptyRenderable (mapPickFn LayoutPick_XBottomAxis . axisToRenderable) bdata taxis = tval $ maybe emptyRenderable@@ -657,10 +674,10 @@ tr = tval $ axesSpacer snd tdata fst rdata br = tval $ axesSpacer snd bdata snd rdata - mktitle :: HTextAnchor -> VTextAnchor + mktitle :: HTextAnchor -> VTextAnchor -> Double -> String -> FontStyle- -> (String -> LayoutPick x yl yr) + -> (String -> LayoutPick x yl yr) -> ( Grid (Renderable (LayoutPick x yl yr)) , Grid (Renderable (LayoutPick x yl yr)) ) mktitle ha va rot lbl style pf = if lbl == "" then (er,er) else (labelG,gapG)@@ -669,7 +686,7 @@ gapG = tval $ spacer (lge_margin lge,0) -- | Render the grids of the given axis to a plot area of given size.-renderGrids :: RectSize -> (Maybe (AxisT x), Maybe (AxisT yl), Maybe (AxisT x), Maybe (AxisT yr)) -> ChartBackend ()+renderGrids :: RectSize -> (Maybe (AxisT x), Maybe (AxisT yl), Maybe (AxisT x), Maybe (AxisT yr)) -> BackendProgram () renderGrids sz (bAxis, lAxis, tAxis, rAxis) = do maybeM () (renderAxisGrid sz) tAxis maybeM () (renderAxisGrid sz) bAxis@@ -682,7 +699,7 @@ -- | Render a single set of plot data onto a plot area of given size using -- the given x and y axis.-renderSinglePlot :: RectSize -> Maybe (AxisT x) -> Maybe (AxisT y) -> Plot x y -> ChartBackend ()+renderSinglePlot :: RectSize -> Maybe (AxisT x) -> Maybe (AxisT y) -> Plot x y -> BackendProgram () renderSinglePlot (w, h) (Just (AxisT _ _ xrev xaxis)) (Just (AxisT _ _ yrev yaxis)) p = let xr = optPairReverse xrev (0, w) yr = optPairReverse yrev (h, 0)@@ -695,7 +712,7 @@ in _plot_render p pmfn renderSinglePlot _ _ _ _ = return () -axesSpacer :: (Ord x, Ord y) +axesSpacer :: (Ord x, Ord y) => ((Double, Double) -> Double) -> Maybe (AxisT x) -> ((Double, Double) -> Double) -> Maybe (AxisT y) -> Renderable a@@ -704,12 +721,12 @@ oh2 <- maybeM (0,0) axisOverhang a2 return (spacer (f1 oh1, f2 oh2)) --- | Construct a axis for the given edge using the attributes +-- | Construct a axis for the given edge using the attributes -- from a 'LayoutAxis' the given values. mkAxis :: RectEdge -> LayoutAxis z -> [z] -> Maybe (AxisT z)-mkAxis edge laxis vals = case axisVisible of- False -> Nothing- True -> Just $ AxisT edge style rev adata+mkAxis edge laxis vals = if axisVisible+ then Just $ AxisT edge style rev adata+ else Nothing where style = _laxis_style laxis rev = _laxis_reverse laxis@@ -718,13 +735,13 @@ axisVisible = _axis_show_labels vis || _axis_show_line vis || _axis_show_ticks vis -- | Override the visibility of a selected axis with the selected 'AxisVisibility'.-overrideAxisVisibility :: layout - -> (layout -> LayoutAxis z) - -> (layout -> AxisVisibility) - -> LayoutAxis z -overrideAxisVisibility ly selAxis selVis = +overrideAxisVisibility :: layout+ -> (layout -> LayoutAxis z)+ -> (layout -> AxisVisibility)+ -> LayoutAxis z+overrideAxisVisibility ly selAxis selVis = let vis = selVis ly- in (selAxis ly) { _laxis_override = (\ad -> ad { _axis_visibility = vis }) + in (selAxis ly) { _laxis_override = (\ad -> ad { _axis_visibility = vis }) . _laxis_override (selAxis ly) } @@ -732,7 +749,7 @@ mfill Nothing = id mfill (Just fs) = fillBackground fs --- | Empty 'LayoutLR' without title and plots. The background is white and +-- | Empty 'LayoutLR' without title and plots. The background is white and -- the grid is drawn beneath all plots. There will be a legend. The top -- axis will not be visible. instance (PlotValue x, PlotValue y1, PlotValue y2) => Default (LayoutLR x y1 y2) where@@ -754,7 +771,7 @@ , _layoutlr_left_axis_visibility = def , _layoutlr_right_axis = def , _layoutlr_right_axis_visibility = def- + , _layoutlr_plots = [] , _layoutlr_legend = Just def@@ -762,10 +779,6 @@ , _layoutlr_grid_last = False } -{-# DEPRECATED defaultLayoutAxis "Use the according Data.Default instance!" #-}-defaultLayoutAxis :: PlotValue t => LayoutAxis t-defaultLayoutAxis = def- instance PlotValue t => Default (LayoutAxis t) where def = LayoutAxis { _laxis_title_style = def { _font_size=10 }@@ -784,29 +797,59 @@ $( makeLenses ''LayoutAxis ) $( makeLenses ''StackedLayouts ) --- | Helper to update all axis styles on a Layout1 simultaneously.-updateAllAxesStyles :: (AxisStyle -> AxisStyle) -> Layout x y -> Layout x y-updateAllAxesStyles uf = (layout_x_axis . laxis_style %~ uf) .- (layout_y_axis . laxis_style %~ uf)+-- | Setter to update all axis styles on a `Layout`+layout_axes_styles :: Setter' (Layout x y) AxisStyle+layout_axes_styles = sets $ \af ->+ (layout_x_axis . laxis_style %~ af) .+ (layout_y_axis . laxis_style %~ af) --- | Helper to update all axis styles on a LayoutLR simultaneously.-updateAllAxesStylesLR :: (AxisStyle -> AxisStyle) -> LayoutLR x yl yr -> LayoutLR x yl yr-updateAllAxesStylesLR uf = (layoutlr_x_axis . laxis_style %~ uf)- . (layoutlr_left_axis . laxis_style %~ uf)- . (layoutlr_right_axis . laxis_style %~ uf)+-- | Setter to update all the axes title styles on a `Layout`+layout_axes_title_styles :: Setter' (Layout x y) FontStyle+layout_axes_title_styles = sets $ \af ->+ (layout_x_axis . laxis_title_style %~ af) .+ (layout_y_axis . laxis_title_style %~ af) --- | Helper to set the forground color uniformly on a Layout.-setLayoutForeground :: AlphaColour Double -> Layout x y -> Layout x y-setLayoutForeground fg =- updateAllAxesStyles ( (axis_line_style . line_color .~ fg)- . (axis_label_style . font_color .~ fg))- . (layout_title_style . font_color .~ fg)- . (layout_legend %~ fmap (legend_label_style .> font_color .~ fg))+-- | Setter to update all the font styles on a `Layout`+layout_all_font_styles :: Setter' (Layout x y) FontStyle+layout_all_font_styles = sets $ \af ->+ (layout_axes_title_styles %~ af) .+ (layout_x_axis . laxis_style . axis_label_style %~ af) .+ (layout_y_axis . laxis_style . axis_label_style %~ af) .+ (layout_legend . _Just . legend_label_style %~ af) .+ (layout_title_style %~ af) --- | Helper to set the forground color uniformly on a LayoutLR.-setLayoutLRForeground :: AlphaColour Double -> LayoutLR x yl yr -> LayoutLR x yl yr-setLayoutLRForeground fg = updateAllAxesStylesLR - ( (axis_line_style . line_color .~ fg)- . (axis_label_style . font_color .~ fg))- . (layoutlr_title_style . font_color .~ fg)- . (layoutlr_legend %~ fmap (legend_label_style .> font_color .~ fg))+-- | Setter to update the foreground color of core chart elements on a `Layout`+layout_foreground :: Setter' (Layout x y) (AlphaColour Double)+layout_foreground = sets $ \af ->+ (layout_all_font_styles . font_color %~ af) .+ (layout_axes_styles . axis_line_style . line_color %~ af)++-- | Setter to update all axis styles on a `LayoutLR`+layoutlr_axes_styles :: Setter' (LayoutLR x y1 y2) AxisStyle+layoutlr_axes_styles = sets $ \af ->+ (layoutlr_x_axis . laxis_style %~ af) .+ (layoutlr_left_axis . laxis_style %~ af) .+ (layoutlr_right_axis . laxis_style %~ af)++-- | Setter to update all the axes title styles on a `LayoutLR`+layoutlr_axes_title_styles :: Setter' (LayoutLR x y1 y2) FontStyle+layoutlr_axes_title_styles = sets $ \af ->+ (layoutlr_x_axis . laxis_title_style %~ af) .+ (layoutlr_left_axis . laxis_title_style %~ af) .+ (layoutlr_right_axis . laxis_title_style %~ af)++-- | Setter to update all the font styles on a `LayoutLR`+layoutlr_all_font_styles :: Setter' (LayoutLR x y1 y2) FontStyle+layoutlr_all_font_styles = sets $ \af ->+ (layoutlr_axes_title_styles %~ af) .+ (layoutlr_x_axis . laxis_style . axis_label_style %~ af) .+ (layoutlr_left_axis . laxis_style . axis_label_style %~ af) .+ (layoutlr_right_axis . laxis_style . axis_label_style %~ af) .+ (layoutlr_legend . _Just . legend_label_style %~ af) .+ (layoutlr_title_style %~ af)++-- | Setter to update the foreground color of core chart elements on a `LayoutLR`+layoutlr_foreground :: Setter' (LayoutLR x y1 y2) (AlphaColour Double)+layoutlr_foreground = sets $ \af ->+ (layoutlr_all_font_styles . font_color %~ af) .+ (layoutlr_axes_styles . axis_line_style . line_color %~ af)
Graphics/Rendering/Chart/Legend.hs view
@@ -12,12 +12,13 @@ Legend(..), LegendStyle(..), LegendOrientation(..),- defaultLegendStyle,+ LegendPosition(..), legendToRenderable, legend_label_style, legend_margin, legend_plot_size,- legend_orientation+ legend_orientation,+ legend_position ) where import Data.List (partition,intersperse)@@ -36,7 +37,8 @@ _legend_label_style :: FontStyle, _legend_margin :: Double, _legend_plot_size :: Double,- _legend_orientation :: LegendOrientation+ _legend_orientation :: LegendOrientation,+ _legend_position :: LegendPosition } -- | Legends can be constructed in two orientations: in rows@@ -44,43 +46,63 @@ -- columns (where we specify the maximum number of rows) data LegendOrientation = LORows Int | LOCols Int- -data Legend x y = Legend LegendStyle [(String, Rect -> ChartBackend ())]+-- | Defines the position of the legend, relative to the plot.+data LegendPosition = LegendAbove+ | LegendBelow+ | LegendRight+ | LegendLeft +data Legend x y = Legend LegendStyle [(String, Rect -> BackendProgram ())]+ instance ToRenderable (Legend x y) where toRenderable = setPickFn nullPickFn . legendToRenderable legendToRenderable :: Legend x y -> Renderable String legendToRenderable (Legend ls lvs) = gridToRenderable grid where+ grid :: Grid (Renderable String) grid = case _legend_orientation ls of LORows n -> mkGrid n aboveG besideG LOCols n -> mkGrid n besideG aboveG + aboveG, besideG :: [Grid (Renderable String)] -> Grid (Renderable String) aboveG = aboveN.intersperse ggap1 besideG = besideN.intersperse ggap1 + mkGrid :: Int+ -> ([Grid (Renderable String)] -> Grid (Renderable String))+ -> ([Grid (Renderable String)] -> Grid (Renderable String))+ -> Grid (Renderable String) mkGrid n join1 join2 = join1 [ join2 (map rf ps1) | ps1 <- groups n ps ] - ps :: [(String, [Rect -> ChartBackend ()])]+ ps :: [(String, [Rect -> BackendProgram ()])] ps = join_nub lvs + rf :: (String, [Rect -> BackendProgram ()]) -> Grid (Renderable String) rf (title,rfs) = besideN [gpic,ggap2,gtitle] where+ gpic :: Grid (Renderable String) gpic = besideN $ intersperse ggap2 (map rp rfs)++ gtitle :: Grid (Renderable String) gtitle = tval $ lbl title++ rp :: (Rect -> BackendProgram ()) -> Grid (Renderable String) rp rfn = tval Renderable { minsize = return (_legend_plot_size ls, 0),- render = \(w,h) -> do + render = \(w,h) -> do _ <- rfn (Rect (Point 0 0) (Point w h)) return (\_-> Just title) } + ggap1, ggap2 :: Grid (Renderable String) ggap1 = tval $ spacer (_legend_margin ls,_legend_margin ls / 2) ggap2 = tval $ spacer1 (lbl "X")- lbl = label (_legend_label_style ls) HTA_Left VTA_Centre + lbl :: String -> Renderable String+ lbl = label (_legend_label_style ls) HTA_Left VTA_Centre+ groups :: Int -> [a] -> [[a]] groups _ [] = [] groups n vs = let (vs1,vs2) = splitAt n vs in vs1:groups n vs2@@ -90,16 +112,13 @@ (xs, rest) -> (x, a1:map snd xs) : join_nub rest join_nub [] = [] -{-# DEPRECATED defaultLegendStyle "Use the according Data.Default instance!" #-}-defaultLegendStyle :: LegendStyle-defaultLegendStyle = def- instance Default LegendStyle where- def = LegendStyle + def = LegendStyle { _legend_label_style = def , _legend_margin = 20 , _legend_plot_size = 20 , _legend_orientation = LORows 4+ , _legend_position = LegendBelow } $( makeLenses ''LegendStyle )
Graphics/Rendering/Chart/Plot.hs view
@@ -10,6 +10,7 @@ module Graphics.Rendering.Chart.Plot( module Graphics.Rendering.Chart.Plot.Types, module Graphics.Rendering.Chart.Plot.Lines,+ module Graphics.Rendering.Chart.Plot.Vectors, module Graphics.Rendering.Chart.Plot.Points, module Graphics.Rendering.Chart.Plot.FillBetween, module Graphics.Rendering.Chart.Plot.ErrBars,@@ -19,10 +20,12 @@ 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 import Graphics.Rendering.Chart.Plot.Lines+import Graphics.Rendering.Chart.Plot.Vectors import Graphics.Rendering.Chart.Plot.Points import Graphics.Rendering.Chart.Plot.FillBetween import Graphics.Rendering.Chart.Plot.ErrBars@@ -32,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
Graphics/Rendering/Chart/Plot/Annotation.hs view
@@ -10,20 +10,25 @@ module Graphics.Rendering.Chart.Plot.Annotation( PlotAnnotation(..),- defaultPlotAnnotation, plot_annotation_hanchor, plot_annotation_vanchor, plot_annotation_angle, plot_annotation_style,+ plot_annotation_background,+ plot_annotation_offset, plot_annotation_values ) where import Control.Lens+import Data.Default.Class import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types-import Data.Default.Class+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Plot.Types -- | Value for describing a series of text annotations -- to be placed at arbitrary points on the graph. Annotations@@ -35,42 +40,62 @@ _plot_annotation_angle :: Double, -- ^ Angle, in degrees, to rotate the annotation about the anchor point. _plot_annotation_style :: FontStyle,+ _plot_annotation_background :: Rectangle,+ -- ^ Rectangle which style determines the background of the annotation+ -- text and which '_rect_minsize' determines the additional width and+ -- height of the background area+ _plot_annotation_offset :: Vector, _plot_annotation_values :: [(x,y,String)] } instance ToPlot PlotAnnotation where toPlot p = Plot {- _plot_render = renderAnnotation p,- _plot_legend = [],- _plot_all_points = (map (^._1) vs , map (^._2) vs)+ _plot_render = renderAnnotation p,+ _plot_legend = [],+ _plot_all_points = (map (^._1) vs , map (^._2) vs) } where vs = _plot_annotation_values p -renderAnnotation :: PlotAnnotation x y -> PointMapFn x y -> ChartBackend ()-renderAnnotation p pMap = withFontStyle style $+renderAnnotation :: PlotAnnotation x y -> PointMapFn x y -> BackendProgram ()+renderAnnotation p pMap = withFontStyle style $ do+ mapM_ drawRect values mapM_ drawOne values where hta = _plot_annotation_hanchor p vta = _plot_annotation_vanchor p values = _plot_annotation_values p angle = _plot_annotation_angle p style = _plot_annotation_style p- drawOne (x,y,s) = drawTextsR hta vta angle point s- where point = pMap (LValue x, LValue y)--{-# DEPRECATED defaultPlotAnnotation "Use the according Data.Default instance!" #-}-defaultPlotAnnotation :: PlotAnnotation x y-defaultPlotAnnotation = def+ offset = _plot_annotation_offset p+ rectangle = _plot_annotation_background p+ (x1,y1) = _rect_minsize rectangle+ drawRect (x,y,s) = do+ ts <- textSize s+ let (x2,y2) = (textSizeWidth ts, textSizeHeight ts)+ Point x3 y3 = point x y+ -- position of top-left vertex of the rectangle+ xvp HTA_Left = x3 - x1 / 2+ xvp HTA_Centre = x3 - (x1 + x2) / 2+ xvp HTA_Right = x3 - x2 - x1 / 2+ yvp VTA_Top = y3 - y1 / 2+ yvp VTA_Centre = y3 - (y1 + y2) / 2+ yvp VTA_Bottom = y3 - y2 - y1 / 2+ yvp VTA_BaseLine = y3 - y1 / 2 - textSizeAscent ts+ drawRectangle (Point (xvp hta) (yvp vta) `pvadd` offset) rectangle{ _rect_minsize = (x1+x2,y1+y2) }+ drawOne (x,y,s) = drawTextsR hta vta angle (point x y) s+ point x y = pMap (LValue x, LValue y) `pvadd` offset instance Default (PlotAnnotation x y) where- def = PlotAnnotation + def = PlotAnnotation { _plot_annotation_hanchor = HTA_Centre , _plot_annotation_vanchor = VTA_Centre , _plot_annotation_angle = 0 , _plot_annotation_style = def+ , _plot_annotation_background = def , _plot_annotation_values = []+ , _plot_annotation_offset = Vector 0 0 } $( makeLenses ''PlotAnnotation )
Graphics/Rendering/Chart/Plot/AreaSpots.hs view
@@ -11,7 +11,6 @@ module Graphics.Rendering.Chart.Plot.AreaSpots ( AreaSpots(..)- , defaultAreaSpots , area_spots_title , area_spots_linethick@@ -22,7 +21,6 @@ , area_spots_values , AreaSpots4D(..)- , defaultAreaSpots4D , area_spots_4d_title , area_spots_4d_linethick@@ -51,14 +49,10 @@ , _area_spots_linecolour :: AlphaColour Double , _area_spots_fillcolour :: Colour Double , _area_spots_opacity :: Double- , _area_spots_max_radius :: Double -- ^ the largest size of spot+ , _area_spots_max_radius :: Double -- ^ the largest size of spot , _area_spots_values :: [(x,y,z)] } -{-# DEPRECATED defaultAreaSpots "Use the according Data.Default instance!" #-}-defaultAreaSpots :: AreaSpots z x y-defaultAreaSpots = def- instance Default (AreaSpots z x y) where def = AreaSpots { _area_spots_title = ""@@ -77,7 +71,7 @@ , map (^._2) (_area_spots_values p) ) } -renderAreaSpots :: (PlotValue z) => AreaSpots z x y -> PointMapFn x y -> ChartBackend ()+renderAreaSpots :: (PlotValue z) => AreaSpots z x y -> PointMapFn x y -> BackendProgram () renderAreaSpots p pmap = forM_ (scaleMax (_area_spots_max_radius p^(2::Integer)) (_area_spots_values p))@@ -99,7 +93,7 @@ scale v = n * toValue v / largest in over (mapped._3) scale points -renderSpotLegend :: AreaSpots z x y -> Rect -> ChartBackend ()+renderSpotLegend :: AreaSpots z x y -> Rect -> BackendProgram () renderSpotLegend p (Rect p1 p2) = do let radius = min (abs (p_y p1 - p_y p2)) (abs (p_x p1 - p_x p2)) centre = linearInterpolate p1 p2@@ -124,14 +118,10 @@ , _area_spots_4d_linethick :: Double , _area_spots_4d_palette :: [Colour Double] , _area_spots_4d_opacity :: Double- , _area_spots_4d_max_radius :: Double -- ^ the largest size of spot+ , _area_spots_4d_max_radius :: Double -- ^ the largest size of spot , _area_spots_4d_values :: [(x,y,z,t)] } -{-# DEPRECATED defaultAreaSpots4D "Use the according Data.Default instance!" #-}-defaultAreaSpots4D :: AreaSpots4D z t x y-defaultAreaSpots4D = def- instance Default (AreaSpots4D z t x y) where def = AreaSpots4D { _area_spots_4d_title = ""@@ -151,7 +141,7 @@ } renderAreaSpots4D :: (PlotValue z, PlotValue t, Show t) =>- AreaSpots4D z t x y -> PointMapFn x y -> ChartBackend ()+ AreaSpots4D z t x y -> PointMapFn x y -> BackendProgram () renderAreaSpots4D p pmap = forM_ (scaleMax (_area_spots_4d_max_radius p^(2::Integer)) (length (_area_spots_4d_palette p))@@ -183,7 +173,7 @@ in map (\ (x,y,z,t) -> (x,y, scale z, select t)) points -renderSpotLegend4D :: AreaSpots4D z t x y -> Rect -> ChartBackend ()+renderSpotLegend4D :: AreaSpots4D z t x y -> Rect -> BackendProgram () renderSpotLegend4D p (Rect p1 p2) = do let radius = min (abs (p_y p1 - p_y p2)) (abs (p_x p1 - p_x p2)) centre = linearInterpolate p1 p2
Graphics/Rendering/Chart/Plot/Bars.hs view
@@ -7,49 +7,78 @@ -- Bar Charts -- {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} module Graphics.Rendering.Chart.Plot.Bars( PlotBars(..),- defaultPlotBars, PlotBarsStyle(..), PlotBarsSpacing(..), PlotBarsAlignment(..), BarsPlotValue(..),+ BarHorizAnchor(..),+ BarVertAnchor(..), plotBars,+ plotHBars,+ plot_bars_style, plot_bars_item_styles, plot_bars_titles, plot_bars_spacing, plot_bars_alignment,- plot_bars_reference, plot_bars_singleton_width,+ plot_bars_label_bar_hanchor,+ plot_bars_label_bar_vanchor,+ plot_bars_label_text_hanchor,+ plot_bars_label_text_vanchor,+ plot_bars_label_angle,+ plot_bars_label_style,+ plot_bars_label_offset,+ plot_bars_values, + plot_bars_settings,+ plot_bars_values_with_labels,++ addLabels ) where +import Control.Arrow import Control.Lens import Control.Monad-import Data.List(nub,sort)-import Graphics.Rendering.Chart.Geometry hiding (x0, y0)-import Graphics.Rendering.Chart.Drawing-import Graphics.Rendering.Chart.Plot.Types-import Graphics.Rendering.Chart.Axis import Data.Colour (opaque) import Data.Colour.Names (black) import Data.Default.Class-+import Data.Tuple(swap)+import Data.List(nub,sort)+import Graphics.Rendering.Chart.Axis+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Geometry hiding (x0, y0)+import Graphics.Rendering.Chart.Plot.Types+import Graphics.Rendering.Chart.Utils class PlotValue a => BarsPlotValue a where- barsReference :: a+ barsIsNull :: a -> Bool+ -- | The starting level for the chart, a function of some statistic+ -- (normally the lowest value or just const 0).+ barsReference :: [a] -> a barsAdd :: a -> a -> a instance BarsPlotValue Double where- barsReference = 0+ barsIsNull a = a == 0.0+ barsReference = const 0 barsAdd = (+)+ instance BarsPlotValue Int where- barsReference = 0+ barsIsNull a = a == 0+ barsReference = const 0 barsAdd = (+) +instance BarsPlotValue LogValue where+ barsIsNull (LogValue a) = a == 0.0+ barsReference as =+ 10.0 ^^ (floor (log10 $ minimum $ filter (/= 0.0) as) :: Integer)+ barsAdd = (+)+ data PlotBarsStyle = BarsStacked -- ^ Bars for a fixed x are stacked vertically -- on top of each other.@@ -71,152 +100,312 @@ | BarsRight -- ^ The right edge of bars is at deviceX deriving (Show) +data BarHorizAnchor+ = BHA_Left+ | BHA_Centre+ | BHA_Right+ deriving (Show)++data BarVertAnchor+ = BVA_Bottom+ | BVA_Centre+ | BVA_Top+ deriving (Show)+ -- | Value describing how to plot a set of bars. -- Note that the input data is typed [(x,[y])], ie for each x value -- we plot several y values. Typically the size of each [y] list would -- be the same.-data PlotBars x y = PlotBars {+data BarsSettings = BarsSettings { -- | This value specifies whether each value from [y] should be -- shown beside or above the previous value.- _plot_bars_style :: PlotBarsStyle,+ _bars_settings_style :: PlotBarsStyle, -- | The style in which to draw each element of [y]. A fill style -- is required, and if a linestyle is given, each bar will be -- outlined.- _plot_bars_item_styles :: [ (FillStyle,Maybe LineStyle) ],-- -- | The title of each element of [y]. These will be shown in the legend.- _plot_bars_titles :: [String],+ _bars_settings_item_styles :: [ (FillStyle,Maybe LineStyle) ], -- | This value controls how the widths of the bars are -- calculated. Either the widths of the bars, or the gaps between -- them can be fixed.- _plot_bars_spacing :: PlotBarsSpacing,+ _bars_settings_spacing :: PlotBarsSpacing, -- | This value controls how bars for a fixed x are aligned with -- respect to the device coordinate corresponding to x.- _plot_bars_alignment :: PlotBarsAlignment,+ _bars_settings_alignment :: PlotBarsAlignment, - -- | The starting level for the chart (normally 0).- _plot_bars_reference :: y,+ _bars_settings_singleton_width :: Double, - _plot_bars_singleton_width :: Double,+ -- | The point on the bar to horizontally anchor the label to+ _bars_settings_label_bar_hanchor :: BarHorizAnchor, - -- | The actual points to be plotted.- _plot_bars_values :: [ (x,[y]) ]-}+ -- | The point on the bar to vertically anchor the label to+ _bars_settings_label_bar_vanchor :: BarVertAnchor, -{-# DEPRECATED defaultPlotBars "Use the according Data.Default instance!" #-}-defaultPlotBars :: BarsPlotValue y => PlotBars x y-defaultPlotBars = def+ -- | The anchor point on the label.+ _bars_settings_label_text_hanchor :: HTextAnchor, -instance BarsPlotValue y => Default (PlotBars x y) where- def = PlotBars- { _plot_bars_style = BarsClustered- , _plot_bars_item_styles = cycle istyles- , _plot_bars_titles = []- , _plot_bars_spacing = BarsFixGap 10 2- , _plot_bars_alignment = BarsCentered- , _plot_bars_values = []- , _plot_bars_singleton_width = 20- , _plot_bars_reference = barsReference+ -- | The anchor point on the label.+ _bars_settings_label_text_vanchor :: VTextAnchor,++ -- | Angle, in degrees, to rotate the label about the anchor point.+ _bars_settings_label_angle :: Double,++ -- | The style to use for the label.+ _bars_settings_label_style :: FontStyle,++ -- | The offset from the anchor point to display the label at.+ _bars_settings_label_offset :: Vector+}+instance Default BarsSettings where+ def = BarsSettings+ { _bars_settings_style = BarsClustered+ , _bars_settings_item_styles = cycle istyles+ , _bars_settings_spacing = BarsFixGap 10 2+ , _bars_settings_alignment = BarsCentered+ , _bars_settings_singleton_width = 20+ , _bars_settings_label_bar_hanchor = BHA_Centre+ , _bars_settings_label_bar_vanchor = BVA_Top+ , _bars_settings_label_text_hanchor = HTA_Centre+ , _bars_settings_label_text_vanchor = VTA_Bottom+ , _bars_settings_label_angle = 0+ , _bars_settings_label_style = def+ , _bars_settings_label_offset = Vector 0 0 } where istyles = map mkstyle defaultColorSeq mkstyle c = (solidFillStyle c, Just (solidLine 1.0 $ opaque black))+data PlotBars x y = PlotBars {+ _plot_bars_settings :: BarsSettings,+ -- | The title of each element of [y]. These will be shown in the legend.+ _plot_bars_titles :: [String],+ -- | The actual points to be plotted, and their labels+ _plot_bars_values_with_labels :: [(x, [(y, String)])]+}+instance Default (PlotBars x y) where+ def = PlotBars+ { _plot_bars_settings = def+ , _plot_bars_titles = []+ , _plot_bars_values_with_labels = []+ } plotBars :: (BarsPlotValue y) => PlotBars x y -> Plot x y plotBars p = Plot {- _plot_render = renderPlotBars p,+ _plot_render = \pmap -> renderBars s vals yref0+ (barRect pmap) (mapX pmap), _plot_legend = zip (_plot_bars_titles p) (map renderPlotLegendBars- (_plot_bars_item_styles p)),- _plot_all_points = allBarPoints p+ (_bars_settings_item_styles s)),+ _plot_all_points = allBarPoints s vals }+ where+ s = _plot_bars_settings p+ vals = _plot_bars_values_with_labels p+ yref0 = refVal s vals -renderPlotBars :: (BarsPlotValue y) => PlotBars x y -> PointMapFn x y -> ChartBackend ()-renderPlotBars p pmap = case _plot_bars_style p of+ barRect pmap xos width x y0 y1 = Rect (Point (x'+xos) y0') (Point (x'+xos+width) y') where+ Point x' y' = mapXY pmap (x,y1)+ Point _ y0' = mapXY pmap (x,y0)++ mapX pmap x = p_x (mapXY pmap (x, yref0))++plotHBars :: (BarsPlotValue x) => PlotBars y x -> Plot x y+plotHBars p = Plot {+ _plot_render = \pmap -> renderBars s vals xref0+ (barRect pmap) (mapY pmap),+ _plot_legend = zip (_plot_bars_titles p)+ (map renderPlotLegendBars+ (_bars_settings_item_styles s)),+ _plot_all_points = swap $ allBarPoints s vals+ }+ where+ s = _plot_bars_settings p+ vals = _plot_bars_values_with_labels p+ xref0 = refVal s vals++ barRect pmap yos height y x0 x1 = Rect (Point x0' (y'+yos)) (Point x' (y'+yos+height)) where+ Point x' y' = mapXY pmap (x1,y)+ Point x0' _ = mapXY pmap (x0,y)++ mapY pmap y = p_y (mapXY pmap (xref0, y))++renderBars :: (BarsPlotValue v) =>+ BarsSettings+ -> [(k, [(v, String)])]+ -> v+ -> (Double -> Double -> k -> v -> v -> Rect)+ -> (k -> Double)+ -> BackendProgram ()+renderBars p vals vref0 r mapk = case _bars_settings_style p of BarsClustered -> forM_ vals clusteredBars BarsStacked -> forM_ vals stackedBars where- clusteredBars (x,ys) = do- forM_ (zip3 [0,1..] ys styles) $ \(i, y, (fstyle,_)) -> - withFillStyle fstyle $ - alignFillPath (barPath (offset i) x yref0 y)+ clusteredBars (k,vs) = do+ let offset i = case _bars_settings_alignment p of+ BarsLeft -> fromIntegral i * bsize+ BarsRight -> fromIntegral (i-nvs) * bsize+ BarsCentered -> fromIntegral (2*i-nvs) * bsize/2+ forM_ (zip3 [0,1..] vs styles) $ \(i, (v, _), (fstyle,_)) ->+ unless (barsIsNull v) $+ withFillStyle fstyle $+ alignFillPath (barPath (offset i) k vref0 v) >>= fillPath- forM_ (zip3 [0,1..] ys styles) $ \(i, y, (_,mlstyle)) -> - whenJust mlstyle $ \lstyle -> - withLineStyle lstyle $ - alignStrokePath (barPath (offset i) x yref0 y)+ forM_ (zip3 [0,1..] vs styles) $ \(i, (v, _), (_,mlstyle)) ->+ unless (barsIsNull v) $+ whenJust mlstyle $ \lstyle ->+ withLineStyle lstyle $+ alignStrokePath (barPath (offset i) k vref0 v) >>= strokePath-- offset = case _plot_bars_alignment p of- BarsLeft -> \i -> fromIntegral i * width- BarsRight -> \i -> fromIntegral (i-nys) * width- BarsCentered -> \i -> fromIntegral (2*i-nys) * width/2+ withFontStyle (_bars_settings_label_style p) $+ forM_ (zip [0,1..] vs) $ \(i, (v, txt)) ->+ unless (null txt) $ do+ let ha = _bars_settings_label_bar_hanchor p+ let va = _bars_settings_label_bar_vanchor p+ let pt = rectCorner ha va (r (offset i) bsize k vref0 v)+ drawTextR+ (_bars_settings_label_text_hanchor p)+ (_bars_settings_label_text_vanchor p)+ (_bars_settings_label_angle p)+ (pvadd pt $ _bars_settings_label_offset p)+ txt - stackedBars (x,ys) = do- let y2s = zip (yref0:stack ys) (stack ys)- let ofs = case _plot_bars_alignment p of+ stackedBars (k,vs) = do+ let (vs', lbls) = unzip vs+ let vs'' = map (\v -> if barsIsNull v then vref0 else v) (stack vs')+ let v2s = zip (vref0:vs'') vs''+ let ofs = case _bars_settings_alignment p of BarsLeft -> 0- BarsRight -> -width- BarsCentered -> -(width/2)- forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> - withFillStyle fstyle $ - alignFillPath (barPath ofs x y0 y1)+ BarsRight -> -bsize+ BarsCentered -> -(bsize/2)+ forM_ (zip v2s styles) $ \((v0,v1), (fstyle,_)) ->+ unless (v0 >= v1) $+ withFillStyle fstyle $+ alignFillPath (barPath ofs k v0 v1) >>= fillPath- forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> - whenJust mlstyle $ \lstyle -> - withLineStyle lstyle $ - alignStrokePath (barPath ofs x y0 y1)+ forM_ (zip v2s styles) $ \((v0,v1), (_,mlstyle)) ->+ unless (v0 >= v1) $+ whenJust mlstyle $ \lstyle ->+ withLineStyle lstyle $+ alignStrokePath (barPath ofs k v0 v1) >>= strokePath+ withFontStyle (_bars_settings_label_style p) $+ forM_ (zip v2s lbls) $ \((v0, v1), txt) ->+ unless (null txt) $ do+ let ha = _bars_settings_label_bar_hanchor p+ let va = _bars_settings_label_bar_vanchor p+ let pt = rectCorner ha va (r ofs bsize k v0 v1)+ drawTextR+ (_bars_settings_label_text_hanchor p)+ (_bars_settings_label_text_vanchor p)+ (_bars_settings_label_angle p)+ (pvadd pt $ _bars_settings_label_offset p)+ txt - barPath xos x y0 y1 = do- let (Point x' y') = pmap' (x,y1)- let (Point _ y0') = pmap' (x,y0)- rectPath (Rect (Point (x'+xos) y0') (Point (x'+xos+width) y'))+ styles = _bars_settings_item_styles p - yref0 = _plot_bars_reference p- vals = _plot_bars_values p- width = case _plot_bars_spacing p of- BarsFixGap gap minw -> let w = max (minXInterval - gap) minw in- case _plot_bars_style p of- BarsClustered -> w / fromIntegral nys+ barPath os k v0 v1 = rectPath $ r os bsize k v0 v1++ bsize = case _bars_settings_spacing p of+ BarsFixGap gap minw -> let w = max (minKInterval - gap) minw in+ case _bars_settings_style p of+ BarsClustered -> w / fromIntegral nvs BarsStacked -> w BarsFixWidth width' -> width'- styles = _plot_bars_item_styles p - minXInterval = let diffs = zipWith (-) (tail mxs) mxs+ minKInterval = let diffs = zipWith (-) (tail mks) mks in if null diffs- then _plot_bars_singleton_width p+ then _bars_settings_singleton_width p else minimum diffs where- xs = fst (allBarPoints p)- mxs = nub $ sort $ map mapX xs+ mks = nub $ sort $ map (mapk . fst) vals - nys = maximum [ length ys | (_,ys) <- vals ]+ nvs = maximum $ map (length . snd) vals - pmap' = mapXY pmap- mapX x = p_x (pmap' (x,barsReference))+rectCorner :: BarHorizAnchor -> BarVertAnchor -> Rect -> Point+rectCorner h v (Rect (Point x0 y0) (Point x1 y1)) = Point x' y' where+ x' = case h of+ BHA_Left -> x0+ BHA_Right -> x1+ BHA_Centre -> (x0 + x1) / 2+ y' = case v of+ BVA_Bottom -> y0+ BVA_Top -> y1+ BVA_Centre -> (y0 + y1) / 2 -whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()-whenJust (Just a) f = f a-whenJust _ _ = return ()+-- Helper function for printing bar values as labels+addLabels :: Show y => [(x, [y])] -> [(x, [(y, String)])]+addLabels = map . second $ map (\y -> (y, show y)) -allBarPoints :: (BarsPlotValue y) => PlotBars x y -> ([x],[y])-allBarPoints p = case _plot_bars_style p of- BarsClustered -> ( [x| (x,_) <- pts], y0:concat [ys| (_,ys) <- pts] )- BarsStacked -> ( [x| (x,_) <- pts], y0:concat [stack ys | (_,ys) <- pts] )- where- pts = _plot_bars_values p- y0 = _plot_bars_reference p+refVal :: (BarsPlotValue y) => BarsSettings -> [(x, [(y, String)])] -> y+refVal p vals = barsReference $ case _bars_settings_style p of+ BarsClustered -> concatMap (map fst . snd) vals+ BarsStacked -> concatMap (take 1 . dropWhile barsIsNull . stack . map fst . snd) vals +allBarPoints :: (BarsPlotValue y) => BarsSettings -> [(x, [(y, String)])] -> ([x],[y])+allBarPoints p vals = case _bars_settings_style p of+ BarsClustered ->+ let ys = concatMap (map fst) yls in+ ( xs, barsReference ys:ys )+ BarsStacked ->+ let ys = map (stack . map fst) yls in+ ( xs, barsReference (concatMap (take 1 . dropWhile barsIsNull) ys):concat ys)+ where (xs, yls) = unzip vals+ stack :: (BarsPlotValue y) => [y] -> [y] stack = scanl1 barsAdd -renderPlotLegendBars :: (FillStyle,Maybe LineStyle) -> Rect -> ChartBackend ()-renderPlotLegendBars (fstyle,_) r = - withFillStyle fstyle $ +renderPlotLegendBars :: (FillStyle,Maybe LineStyle) -> Rect -> BackendProgram ()+renderPlotLegendBars (fstyle,_) r =+ withFillStyle fstyle $ fillPath (rectPath r) +$( makeLenses ''BarsSettings ) $( makeLenses ''PlotBars )++-- Lens provided for backward compat.++-- Note that this one does not satisfy the lens laws, as it discards/overwrites the labels.+plot_bars_values :: Lens' (PlotBars x y) [(x, [y])]+plot_bars_values = lens getter setter+ where+ getter = mapYs fst . _plot_bars_values_with_labels+ setter pb vals' = pb { _plot_bars_values_with_labels = mapYs (, "") vals' }+ mapYs :: (a -> b) -> [(c, [a])] -> [(c, [b])]+ mapYs f = map (over _2 $ map f)++plot_bars_style :: Lens' (PlotBars x y) PlotBarsStyle+plot_bars_style = plot_bars_settings . bars_settings_style++plot_bars_item_styles :: Lens' (PlotBars x y) [(FillStyle, Maybe LineStyle)]+plot_bars_item_styles = plot_bars_settings . bars_settings_item_styles++plot_bars_spacing :: Lens' (PlotBars x y) PlotBarsSpacing+plot_bars_spacing = plot_bars_settings . bars_settings_spacing++plot_bars_alignment :: Lens' (PlotBars x y) PlotBarsAlignment+plot_bars_alignment = plot_bars_settings . bars_settings_alignment++plot_bars_singleton_width :: Lens' (PlotBars x y) Double+plot_bars_singleton_width = plot_bars_settings . bars_settings_singleton_width++plot_bars_label_bar_hanchor :: Lens' (PlotBars x y) BarHorizAnchor+plot_bars_label_bar_hanchor = plot_bars_settings . bars_settings_label_bar_hanchor++plot_bars_label_bar_vanchor :: Lens' (PlotBars x y) BarVertAnchor+plot_bars_label_bar_vanchor = plot_bars_settings . bars_settings_label_bar_vanchor++plot_bars_label_text_hanchor :: Lens' (PlotBars x y) HTextAnchor+plot_bars_label_text_hanchor = plot_bars_settings . bars_settings_label_text_hanchor++plot_bars_label_text_vanchor :: Lens' (PlotBars x y) VTextAnchor+plot_bars_label_text_vanchor = plot_bars_settings . bars_settings_label_text_vanchor++plot_bars_label_angle :: Lens' (PlotBars x y) Double+plot_bars_label_angle = plot_bars_settings . bars_settings_label_angle++plot_bars_label_style :: Lens' (PlotBars x y) FontStyle+plot_bars_label_style = plot_bars_settings . bars_settings_label_style++plot_bars_label_offset :: Lens' (PlotBars x y) Vector+plot_bars_label_offset = plot_bars_settings . bars_settings_label_offset
Graphics/Rendering/Chart/Plot/Candle.hs view
@@ -11,7 +11,6 @@ module Graphics.Rendering.Chart.Plot.Candle( PlotCandle(..), Candle(..),- defaultPlotCandle, plot_candle_title, plot_candle_line_style,@@ -25,7 +24,6 @@ ) where import Control.Lens hiding (op)-import Data.Monoid import Graphics.Rendering.Chart.Geometry hiding (close) import Graphics.Rendering.Chart.Drawing@@ -75,8 +73,8 @@ where pts = _plot_candle_values p -renderPlotCandle :: PlotCandle x y -> PointMapFn x y -> ChartBackend ()-renderPlotCandle p pmap = +renderPlotCandle :: PlotCandle x y -> PointMapFn x y -> BackendProgram ()+renderPlotCandle p pmap = mapM_ (drawCandle p . candlemap) (_plot_candle_values p) where candlemap (Candle x lo op mid cl hi) =@@ -88,7 +86,7 @@ (Point _ hi') = pmap' (x,hi) pmap' = mapXY pmap -drawCandle :: PlotCandle x y -> Candle Double Double -> ChartBackend ()+drawCandle :: PlotCandle x y -> Candle Double Double -> BackendProgram () drawCandle ps (Candle x lo open mid close hi) = do let tl = _plot_candle_tick_length ps let wd = _plot_candle_width ps@@ -97,7 +95,7 @@ -- the pixel coordinate system is inverted wrt the value coords. when f $ withFillStyle (if open >= close then _plot_candle_rise_fill_style ps- else _plot_candle_fall_fill_style ps) $ + else _plot_candle_fall_fill_style ps) $ fillPath $ moveTo' (x-wd) open <> lineTo' (x-wd) close <> lineTo' (x+wd) close@@ -120,11 +118,11 @@ <> lineTo' (x+tl) lo <> moveTo' (x-tl) hi <> lineTo' (x+tl) hi- + when (ct > 0) $ strokePath $ moveTo' (x-ct) mid <> lineTo' (x+ct) mid -renderPlotLegendCandle :: PlotCandle x y -> Rect -> ChartBackend ()+renderPlotLegendCandle :: PlotCandle x y -> Rect -> BackendProgram () renderPlotLegendCandle pc (Rect p1 p2) = do drawCandle pc2 (Candle (xwid*1/4) lo open mid close hi) drawCandle pc2 (Candle (xwid*2/3) lo close mid open hi)@@ -137,12 +135,8 @@ open = (lo + mid) / 2 close = (mid + hi) / 2 -{-# DEPRECATED defaultPlotCandle "Use the according Data.Default instance!" #-}-defaultPlotCandle :: PlotCandle x y-defaultPlotCandle = def- instance Default (PlotCandle x y) where- def = PlotCandle + def = PlotCandle { _plot_candle_title = "" , _plot_candle_line_style = solidLine 1 $ opaque blue , _plot_candle_fill = False
Graphics/Rendering/Chart/Plot/ErrBars.hs view
@@ -10,7 +10,6 @@ module Graphics.Rendering.Chart.Plot.ErrBars( PlotErrBars(..),- defaultPlotErrBars, ErrPoint(..), ErrValue(..), symErrPoint,@@ -26,7 +25,6 @@ ) where import Control.Lens-import Data.Monoid import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing@@ -76,8 +74,8 @@ where pts = _plot_errbars_values p -renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> ChartBackend ()-renderPlotErrBars p pmap = +renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> BackendProgram ()+renderPlotErrBars p pmap = mapM_ (drawErrBar.epmap) (_plot_errbars_values p) where epmap (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) =@@ -88,11 +86,11 @@ drawErrBar = drawErrBar0 p pmap' = mapXY pmap -drawErrBar0 :: PlotErrBars x y -> ErrPoint Double Double -> ChartBackend ()+drawErrBar0 :: PlotErrBars x y -> ErrPoint Double Double -> BackendProgram () drawErrBar0 ps (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = do let tl = _plot_errbars_tick_length ps let oh = _plot_errbars_overhang ps- withLineStyle (_plot_errbars_line_style ps) $ + withLineStyle (_plot_errbars_line_style ps) $ strokePath $ moveTo' (xl-oh) y <> lineTo' (xh+oh) y <> moveTo' x (yl-oh)@@ -106,7 +104,7 @@ <> moveTo' (x-tl) yh <> lineTo' (x+tl) yh -renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> ChartBackend ()+renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> BackendProgram () renderPlotLegendErrBars p (Rect p1 p2) = do drawErrBar (symErrPoint (p_x p1) y dx dx) drawErrBar (symErrPoint ((p_x p1 + p_x p2)/2) y dx dx)@@ -117,12 +115,8 @@ dx = min ((p_x p2 - p_x p1)/6) ((p_y p2 - p_y p1)/2) y = (p_y p1 + p_y p2)/2 -{-# DEPRECATED defaultPlotErrBars "Use the according Data.Default instance!" #-}-defaultPlotErrBars :: PlotErrBars x y-defaultPlotErrBars = def- instance Default (PlotErrBars x y) where- def = PlotErrBars + def = PlotErrBars { _plot_errbars_title = "" , _plot_errbars_line_style = solidLine 1 $ opaque blue , _plot_errbars_tick_length = 3
Graphics/Rendering/Chart/Plot/FillBetween.hs view
@@ -10,12 +10,12 @@ module Graphics.Rendering.Chart.Plot.FillBetween( PlotFillBetween(..),- defaultPlotFillBetween, -- * Accessors -- | These accessors are generated by template haskell plot_fillbetween_title, plot_fillbetween_style,+ plot_fillbetween_line, plot_fillbetween_values, ) where @@ -33,6 +33,7 @@ data PlotFillBetween x y = PlotFillBetween { _plot_fillbetween_title :: String, _plot_fillbetween_style :: FillStyle,+ _plot_fillbetween_line :: Maybe LineStyle, _plot_fillbetween_values :: [ (x, (y,y))] } @@ -44,7 +45,7 @@ _plot_all_points = plotAllPointsFillBetween p } -renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> ChartBackend ()+renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> BackendProgram () renderPlotFillBetween p = renderPlotFillBetween' p (_plot_fillbetween_values p) @@ -52,18 +53,21 @@ PlotFillBetween x y -> [(a, (b, b))] -> ((Limit a, Limit b) -> Point)- -> ChartBackend ()+ -> BackendProgram () renderPlotFillBetween' _ [] _ = return () renderPlotFillBetween' p vs pmap = withFillStyle (_plot_fillbetween_style p) $ do ps <- alignFillPoints $ [p0] ++ p1s ++ reverse p2s ++ [p0] fillPointPath ps+ case _plot_fillbetween_line p of+ Nothing -> return ()+ Just lineStyle -> withLineStyle lineStyle $ strokePointPath ps where pmap' = mapXY pmap (p0:p1s) = map pmap' [ (x,y1) | (x,(y1,_)) <- vs ] p2s = map pmap' [ (x,y2) | (x,(_,y2)) <- vs ] -renderPlotLegendFill :: PlotFillBetween x y -> Rect -> ChartBackend ()+renderPlotLegendFill :: PlotFillBetween x y -> Rect -> BackendProgram () renderPlotLegendFill p r = withFillStyle (_plot_fillbetween_style p) $ fillPath (rectPath r)@@ -74,14 +78,11 @@ where pts = _plot_fillbetween_values p -{-# DEPRECATED defaultPlotFillBetween "Use the according Data.Default instance!" #-}-defaultPlotFillBetween :: PlotFillBetween x y-defaultPlotFillBetween = def - instance Default (PlotFillBetween x y) where def = PlotFillBetween { _plot_fillbetween_title = "" , _plot_fillbetween_style = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0)+ , _plot_fillbetween_line = Nothing , _plot_fillbetween_values = [] }
+ Graphics/Rendering/Chart/Plot/Histogram.hs view
@@ -0,0 +1,188 @@+{-# 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+ _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)+ , (x1,0)+ , (x2,0)+ ])+ $ 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 -> BackendProgram ()+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 -> BackendProgram ()+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++-- | Obtain the bin dimensions of a given @PlotHist@.+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)++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 )
Graphics/Rendering/Chart/Plot/Lines.hs view
@@ -10,7 +10,6 @@ module Graphics.Rendering.Chart.Plot.Lines( PlotLines(..),- defaultPlotLines, defaultPlotLineStyle, hlinePlot, vlinePlot,@@ -55,7 +54,7 @@ xs = [ x | (LValue x,_) <- concat (_plot_lines_limit_values p)] ys = [ y | (_,LValue y) <- concat (_plot_lines_limit_values p)] -renderPlotLines :: PlotLines x y -> PointMapFn x y -> ChartBackend ()+renderPlotLines :: PlotLines x y -> PointMapFn x y -> BackendProgram () renderPlotLines p pmap = withLineStyle (_plot_lines_style p) $ do mapM_ (drawLines (mapXY pmap)) (_plot_lines_values p)@@ -63,7 +62,7 @@ where drawLines mapfn pts = alignStrokePoints (map mapfn pts) >>= strokePointPath -renderPlotLegendLines :: PlotLines x y -> Rect -> ChartBackend ()+renderPlotLegendLines :: PlotLines x y -> Rect -> BackendProgram () renderPlotLegendLines p (Rect p1 p2) = withLineStyle (_plot_lines_style p) $ do let y = (p_y p1 + p_y p2) / 2@@ -76,10 +75,6 @@ _line_join = LineJoinRound } -{-# DEPRECATED defaultPlotLines "Use the according Data.Default instance!" #-}-defaultPlotLines :: PlotLines x y-defaultPlotLines = def- instance Default (PlotLines x y) where def = PlotLines { _plot_lines_title = ""@@ -90,7 +85,7 @@ -- | Helper function to plot a single horizontal line. hlinePlot :: String -> LineStyle -> b -> Plot a b-hlinePlot t ls v = toPlot defaultPlotLines {+hlinePlot t ls v = toPlot def { _plot_lines_title = t, _plot_lines_style = ls, _plot_lines_limit_values = [[(LMin, LValue v),(LMax, LValue v)]]@@ -98,7 +93,7 @@ -- | Helper function to plot a single vertical line. vlinePlot :: String -> LineStyle -> a -> Plot a b-vlinePlot t ls v = toPlot defaultPlotLines {+vlinePlot t ls v = toPlot def { _plot_lines_title = t, _plot_lines_style = ls, _plot_lines_limit_values = [[(LValue v,LMin),(LValue v,LMax)]]
Graphics/Rendering/Chart/Plot/Pie.hs view
@@ -1,244 +1,228 @@------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Chart.Plot.Pie --- Copyright : (c) Tim Docker 2008, 2014 --- License : BSD-style (see chart/COPYRIGHT) --- --- A basic pie chart. --- --- Pie charts are handled different to other plots, in that they --- have their own layout, and can't be composed with other plots. A --- pie chart is rendered with code in the following form: --- --- @ --- values :: [PieItem] --- values = [...] --- layout :: PieLayout --- layout = pie_plot ^: pie_data ^= values --- $ def --- renderable = toRenderable layout --- @ -{-# LANGUAGE TemplateHaskell #-} - -module Graphics.Rendering.Chart.Plot.Pie( - PieLayout(..), - PieChart(..), - PieItem(..), - defaultPieLayout, - defaultPieChart, - defaultPieItem, - - pieToRenderable, - pieChartToRenderable, - - pie_title, - pie_title_style, - pie_plot, - pie_background, - pie_margin, - pie_data, - pie_colors, - pie_label_style, - pie_label_line_style, - pie_start_angle, - pitem_label, - pitem_offset, - pitem_value, - -) where --- original code thanks to Neal Alexander - --- see ../Drawing.hs for why we do not use hiding (moveTo) for --- lens < 4 -import Control.Lens -import Data.Colour -import Data.Colour.Names (white) -import Data.Monoid -import Data.Default.Class -import Control.Monad - -import Graphics.Rendering.Chart.Geometry hiding (moveTo) -import qualified Graphics.Rendering.Chart.Geometry as G -import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Renderable -import Graphics.Rendering.Chart.Grid - -data PieLayout = PieLayout { - _pie_title :: String, - _pie_title_style :: FontStyle, - _pie_plot :: PieChart, - _pie_background :: FillStyle, - _pie_margin :: Double -} - -data PieChart = PieChart { - _pie_data :: [PieItem], - _pie_colors :: [AlphaColour Double], - _pie_label_style :: FontStyle, - _pie_label_line_style :: LineStyle, - _pie_start_angle :: Double - -} - -data PieItem = PieItem { - _pitem_label :: String, - _pitem_offset :: Double, - _pitem_value :: Double -} - -{-# DEPRECATED defaultPieChart "Use the according Data.Default instance!" #-} -defaultPieChart :: PieChart -defaultPieChart = def - -instance Default PieChart where - def = PieChart - { _pie_data = [] - , _pie_colors = defaultColorSeq - , _pie_label_style = def - , _pie_label_line_style = solidLine 1 $ opaque black - , _pie_start_angle = 0 - } - -{-# DEPRECATED defaultPieItem "Use the according Data.Default instance!" #-} -defaultPieItem :: PieItem -defaultPieItem = def - -instance Default PieItem where - def = PieItem "" 0 0 - -{-# DEPRECATED defaultPieLayout "Use the according Data.Default instance!" #-} -defaultPieLayout :: PieLayout -defaultPieLayout = def - -instance Default PieLayout where - def = PieLayout - { _pie_background = solidFillStyle $ opaque white - , _pie_title = "" - , _pie_title_style = def { _font_size = 15 - , _font_weight = FontWeightBold } - , _pie_plot = def - , _pie_margin = 10 - } - -instance ToRenderable PieLayout where - toRenderable = setPickFn nullPickFn . pieToRenderable - -pieChartToRenderable :: PieChart -> Renderable (PickFn a) -pieChartToRenderable p = Renderable { minsize = minsizePie p - , render = renderPie p - } - -instance ToRenderable PieChart where - toRenderable = setPickFn nullPickFn . pieChartToRenderable - -pieToRenderable :: PieLayout -> Renderable (PickFn a) -pieToRenderable p = fillBackground (_pie_background p) ( - gridToRenderable $ aboveN - [ tval $ addMargins (lm/2,0,0,0) (setPickFn nullPickFn title) - , weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) - (pieChartToRenderable $ _pie_plot p) - ] ) - where - title = label (_pie_title_style p) HTA_Centre VTA_Top (_pie_title p) - lm = _pie_margin p - -extraSpace :: PieChart -> ChartBackend (Double, Double) -extraSpace p = do - textSizes <- mapM (textDimension . _pitem_label) (_pie_data p) - let maxw = foldr (max.fst) 0 textSizes - let maxh = foldr (max.snd) 0 textSizes - let maxo = foldr (max._pitem_offset) 0 (_pie_data p) - let extra = label_rgap + label_rlength + maxo - return (extra + maxw, extra + maxh ) - -minsizePie :: PieChart -> ChartBackend (Double, Double) -minsizePie p = do - (extraw,extrah) <- extraSpace p - return (extraw * 2, extrah * 2) - -renderPie :: PieChart -> (Double, Double) -> ChartBackend (PickFn a) -renderPie p (w,h) = do - (extraw,extrah) <- extraSpace p - -- let (w,h) = (p_x p2 - p_x p1, p_y p2 - p_y p1) - -- let center = Point (p_x p1 + w/2) (p_y p1 + h/2) - -- - let center = Point (w/2) (h/2) - let radius = min (w - 2*extraw) (h - 2*extrah) / 2 - - foldM_ (paint center radius) (_pie_start_angle p) - (zip (_pie_colors p) content) - return nullPickFn - - where - -- p1 = Point 0 0 - -- p2 = Point w h - content = let total = sum (map _pitem_value (_pie_data p)) - in [ pitem{_pitem_value=_pitem_value pitem/total} - | pitem <- _pie_data p ] - - paint :: Point -> Double -> Double -> (AlphaColour Double, PieItem) - -> ChartBackend Double - paint center radius a1 (color,pitem) = do - let ax = 360.0 * _pitem_value pitem - let a2 = a1 + (ax / 2) - let a3 = a1 + ax - let offset = _pitem_offset pitem - - pieSlice (ray a2 offset) a1 a3 color - pieLabel (_pitem_label pitem) a2 offset - - return a3 - - where - pieLabel :: String -> Double -> Double -> ChartBackend () - pieLabel name angle offset = - withFontStyle (_pie_label_style p) $ - withLineStyle (_pie_label_line_style p) $ do - let p1 = ray angle (radius+label_rgap+label_rlength+offset) - p1a <- alignStrokePoint p1 - (tw,_) <- textDimension name - let (offset',anchor) = if angle < 90 || angle > 270 - then ((0+),HTA_Left) - else ((0-),HTA_Right) - p0 <- alignStrokePoint $ ray angle (radius + label_rgap+offset) - strokePath $ G.moveTo p0 - <> lineTo p1a - <> lineTo' (p_x p1a + offset' (tw + label_rgap)) (p_y p1a) - - let p2 = p1 `pvadd` Vector (offset' label_rgap) 0 - drawTextA anchor VTA_Bottom p2 name - - pieSlice :: Point -> Double -> Double -> AlphaColour Double -> ChartBackend () - pieSlice (Point x y) arc1 arc2 pColor = do - let path = arc' x y radius (radian arc1) (radian arc2) - <> lineTo' x y - <> lineTo' x y - <> close - - withFillStyle (FillStyleSolid pColor) $ - fillPath path - withLineStyle (def { _line_color = withOpacity white 0.1 }) $ - strokePath path - - ray :: Double -> Double -> Point - ray angle r = Point x' y' - where - x' = x + (cos' * x'') - y' = y + (sin' * x'') - cos' = (cos . radian) angle - sin' = (sin . radian) angle - -- TODO: is x'' defined in this way to try and avoid - -- numerical rounding? - x'' = (x + r) - x - x = p_x center - y = p_y center - - radian = (*(pi / 180.0)) - -label_rgap, label_rlength :: Double -label_rgap = 5 -label_rlength = 15 - -$( makeLenses ''PieLayout ) -$( makeLenses ''PieChart ) -$( makeLenses ''PieItem ) +-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Chart.Plot.Pie+-- Copyright : (c) Tim Docker 2008, 2014+-- License : BSD-style (see chart/COPYRIGHT)+--+-- A basic pie chart.+--+-- Pie charts are handled different to other plots, in that they+-- have their own layout, and can't be composed with other plots. A+-- pie chart is rendered with code in the following form:+--+-- @+-- values :: [PieItem]+-- values = [...]+-- layout :: PieLayout+-- layout = pie_plot ^: pie_data ^= values+-- $ def+-- renderable = toRenderable layout+-- @+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Pie(+ PieLayout(..),+ PieChart(..),+ PieItem(..),++ pieToRenderable,+ pieChartToRenderable,++ pie_title,+ pie_title_style,+ pie_plot,+ pie_background,+ pie_margin,+ pie_data,+ pie_colors,+ pie_label_style,+ pie_label_line_style,+ pie_start_angle,+ pitem_label,+ pitem_offset,+ pitem_value,++) where+-- original code thanks to Neal Alexander++-- see ../Drawing.hs for why we do not use hiding (moveTo) for+-- lens < 4+import Control.Lens+import Data.Colour+import Data.Colour.Names (white)+import Data.Default.Class+import Control.Monad++import Graphics.Rendering.Chart.Geometry hiding (moveTo)+import qualified Graphics.Rendering.Chart.Geometry as G+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Renderable+import Graphics.Rendering.Chart.Grid++data PieLayout = PieLayout {+ _pie_title :: String,+ _pie_title_style :: FontStyle,+ _pie_plot :: PieChart,+ _pie_background :: FillStyle,+ _pie_margin :: Double+}++data PieChart = PieChart {+ _pie_data :: [PieItem],+ _pie_colors :: [AlphaColour Double],+ _pie_label_style :: FontStyle,+ _pie_label_line_style :: LineStyle,+ _pie_start_angle :: Double++}++data PieItem = PieItem {+ _pitem_label :: String,+ _pitem_offset :: Double,+ _pitem_value :: Double+}++instance Default PieChart where+ def = PieChart+ { _pie_data = []+ , _pie_colors = defaultColorSeq+ , _pie_label_style = def+ , _pie_label_line_style = solidLine 1 $ opaque black+ , _pie_start_angle = 0+ }++instance Default PieItem where+ def = PieItem "" 0 0++instance Default PieLayout where+ def = PieLayout+ { _pie_background = solidFillStyle $ opaque white+ , _pie_title = ""+ , _pie_title_style = def { _font_size = 15+ , _font_weight = FontWeightBold }+ , _pie_plot = def+ , _pie_margin = 10+ }++instance ToRenderable PieLayout where+ toRenderable = setPickFn nullPickFn . pieToRenderable++pieChartToRenderable :: PieChart -> Renderable (PickFn a)+pieChartToRenderable p = Renderable { minsize = minsizePie p+ , render = renderPie p+ }++instance ToRenderable PieChart where+ toRenderable = setPickFn nullPickFn . pieChartToRenderable++pieToRenderable :: PieLayout -> Renderable (PickFn a)+pieToRenderable p = fillBackground (_pie_background p) (+ gridToRenderable $ aboveN+ [ tval $ addMargins (lm/2,0,0,0) (setPickFn nullPickFn title)+ , weights (1,1) $ tval $ addMargins (lm,lm,lm,lm)+ (pieChartToRenderable $ _pie_plot p)+ ] )+ where+ title = label (_pie_title_style p) HTA_Centre VTA_Top (_pie_title p)+ lm = _pie_margin p++extraSpace :: PieChart -> BackendProgram (Double, Double)+extraSpace p = do+ textSizes <- mapM (textDimension . _pitem_label) (_pie_data p)+ let maxw = foldr (max.fst) 0 textSizes+ let maxh = foldr (max.snd) 0 textSizes+ let maxo = foldr (max._pitem_offset) 0 (_pie_data p)+ let extra = label_rgap + label_rlength + maxo+ return (extra + maxw, extra + maxh )++minsizePie :: PieChart -> BackendProgram (Double, Double)+minsizePie p = do+ (extraw,extrah) <- extraSpace p+ return (extraw * 2, extrah * 2)++renderPie :: PieChart -> (Double, Double) -> BackendProgram (PickFn a)+renderPie p (w,h) = do+ (extraw,extrah) <- extraSpace p+ -- let (w,h) = (p_x p2 - p_x p1, p_y p2 - p_y p1)+ -- let center = Point (p_x p1 + w/2) (p_y p1 + h/2)+ --+ let center = Point (w/2) (h/2)+ let radius = min (w - 2*extraw) (h - 2*extrah) / 2++ foldM_ (paint center radius) (_pie_start_angle p)+ (zip (_pie_colors p) content)+ return nullPickFn++ where+ -- p1 = Point 0 0+ -- p2 = Point w h+ content = let total = sum (map _pitem_value (_pie_data p))+ in [ pitem{_pitem_value=_pitem_value pitem/total}+ | pitem <- _pie_data p ]++ paint :: Point -> Double -> Double -> (AlphaColour Double, PieItem)+ -> BackendProgram Double+ paint center radius a1 (color,pitem) = do+ let ax = 360.0 * _pitem_value pitem+ let a2 = a1 + (ax / 2)+ let a3 = a1 + ax+ let offset = _pitem_offset pitem++ pieSlice (ray a2 offset) a1 a3 color+ pieLabel (_pitem_label pitem) a2 offset++ return a3++ where+ pieLabel :: String -> Double -> Double -> BackendProgram ()+ pieLabel name angle offset =+ withFontStyle (_pie_label_style p) $+ withLineStyle (_pie_label_line_style p) $ do+ let p1 = ray angle (radius+label_rgap+label_rlength+offset)+ p1a <- alignStrokePoint p1+ (tw,_) <- textDimension name+ let (offset',anchor) = if angle < 90 || angle > 270+ then ((0+),HTA_Left)+ else ((0-),HTA_Right)+ p0 <- alignStrokePoint $ ray angle (radius + label_rgap+offset)+ strokePath $ G.moveTo p0+ <> lineTo p1a+ <> lineTo' (p_x p1a + offset' (tw + label_rgap)) (p_y p1a)++ let p2 = p1 `pvadd` Vector (offset' label_rgap) 0+ drawTextA anchor VTA_Bottom p2 name++ pieSlice :: Point -> Double -> Double -> AlphaColour Double -> BackendProgram ()+ pieSlice (Point x y) arc1 arc2 pColor = do+ let path = arc' x y radius (radian arc1) (radian arc2)+ <> lineTo' x y+ <> lineTo' x y+ <> close++ withFillStyle (FillStyleSolid pColor) $+ fillPath path+ withLineStyle (def { _line_color = withOpacity white 0.1 }) $+ strokePath path++ ray :: Double -> Double -> Point+ ray angle r = Point x' y'+ where+ x' = x + (cos' * x'')+ y' = y + (sin' * x'')+ cos' = (cos . radian) angle+ sin' = (sin . radian) angle+ -- TODO: is x'' defined in this way to try and avoid+ -- numerical rounding?+ x'' = (x + r) - x+ x = p_x center+ y = p_y center++ radian = (*(pi / 180.0))++label_rgap, label_rlength :: Double+label_rgap = 5+label_rlength = 15++$( makeLenses ''PieLayout )+$( makeLenses ''PieChart )+$( makeLenses ''PieItem )
Graphics/Rendering/Chart/Plot/Points.hs view
@@ -10,7 +10,6 @@ module Graphics.Rendering.Chart.Plot.Points( PlotPoints(..),- defaultPlotPoints, -- * Accessors -- | These accessors are generated by template haskell@@ -43,14 +42,14 @@ where pts = _plot_points_values p -renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> ChartBackend ()+renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> BackendProgram () renderPlotPoints p pmap = mapM_ (drawPoint ps . pmap') (_plot_points_values p) where pmap' = mapXY pmap ps = _plot_points_style p -renderPlotLegendPoints :: PlotPoints x y -> Rect -> ChartBackend ()+renderPlotLegendPoints :: PlotPoints x y -> Rect -> BackendProgram () renderPlotLegendPoints p (Rect p1 p2) = do drawPoint ps (Point (p_x p1) y) drawPoint ps (Point ((p_x p1 + p_x p2)/2) y)@@ -59,10 +58,6 @@ where ps = _plot_points_style p y = (p_y p1 + p_y p2)/2--{-# DEPRECATED defaultPlotPoints "Use the according Data.Default instance!" #-}-defaultPlotPoints :: PlotPoints x y-defaultPlotPoints = def instance Default (PlotPoints x y) where def = PlotPoints
Graphics/Rendering/Chart/Plot/Types.hs view
@@ -31,12 +31,12 @@ -- | Given the mapping between model space coordinates and device -- coordinates, render this plot into a chart.- _plot_render :: PointMapFn x y -> ChartBackend (),+ _plot_render :: PointMapFn x y -> BackendProgram (), -- | Details for how to show this plot in a legend. For each item -- the string is the text to show, and the function renders a -- graphical sample of the plot.- _plot_legend :: [ (String, Rect -> ChartBackend ()) ],+ _plot_legend :: [ (String, Rect -> BackendProgram ()) ], -- | All of the model space coordinates to be plotted. These are -- used to autoscale the axes where necessary.@@ -46,6 +46,9 @@ -- | A type class abstracting the conversion of a value to a Plot. class ToPlot a where toPlot :: a x y -> Plot x y++instance ToPlot Plot where+ toPlot p = p -- | Join any two plots together (they will share a legend). joinPlot :: Plot x y -> Plot x y -> Plot x y
+ Graphics/Rendering/Chart/Plot/Vectors.hs view
@@ -0,0 +1,145 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Chart.Plot.Vectors+-- Copyright : (c) Anton Vorontsov <anton@enomsg.org> 2014+-- License : BSD-style (see chart/COPYRIGHT)+--+-- Vector plots+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Graphics.Rendering.Chart.Plot.Vectors(+ PlotVectors(..),+ VectorStyle(..),+ plotVectorField,+ plot_vectors_mapf,+ plot_vectors_grid,+ plot_vectors_title,+ plot_vectors_style,+ plot_vectors_scale,+ plot_vectors_values,+ vector_line_style,+ vector_head_style,+) where++import Control.Lens+import Control.Monad+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Data.Tuple+import Data.Colour hiding (over)+import Data.Colour.Names+import Data.Default.Class+import Graphics.Rendering.Chart.Axis+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Geometry+import Graphics.Rendering.Chart.Plot.Types++data VectorStyle = VectorStyle+ { _vector_line_style :: LineStyle+ , _vector_head_style :: PointStyle+ }++$( makeLenses ''VectorStyle )++data PlotVectors x y = PlotVectors+ { _plot_vectors_title :: String+ , _plot_vectors_style :: VectorStyle+ -- | Set to 1 (default) to normalize the length of vectors to a space+ -- between them (so that the vectors never overlap on the graph).+ -- Set to 0 to disable any scaling.+ -- Values in between 0 and 1 are also permitted to adjust scaling.+ , _plot_vectors_scale :: Double+ -- | Provide a square-tiled regular grid.+ , _plot_vectors_grid :: [(x,y)]+ -- | Provide a vector field (R^2 -> R^2) function.+ , _plot_vectors_mapf :: (x,y) -> (x,y)+ -- | Provide a prepared list of (start,vector) pairs.+ , _plot_vectors_values :: [((x,y),(x,y))]+ }++$( makeLenses ''PlotVectors )++mapGrid :: (PlotValue y, PlotValue x)+ => [(x,y)] -> ((x,y) -> (x,y)) -> [((x,y),(x,y))]+mapGrid grid f = zip grid (f <$> grid)++plotVectorField :: (PlotValue x, PlotValue y) => PlotVectors x y -> Plot x y+plotVectorField pv = Plot+ { _plot_render = renderPlotVectors pv+ , _plot_legend = [(_plot_vectors_title pv, renderPlotLegendVectors pv)]+ , _plot_all_points = (map fst pts, map snd pts)+ }+ where+ pvals = _plot_vectors_values pv+ mvals = mapGrid (_plot_vectors_grid pv) (_plot_vectors_mapf pv)+ pts = concatMap (\(a,b) -> [a,b]) (pvals ++ mvals)++renderPlotVectors :: (PlotValue x, PlotValue y)+ => PlotVectors x y -> PointMapFn x y -> BackendProgram ()+renderPlotVectors pv pmap = do+ let pvals = _plot_vectors_values pv+ mvals = mapGrid (_plot_vectors_grid pv) (_plot_vectors_mapf pv)+ trans = translateToStart <$> (pvals ++ mvals)+ pvecs = filter (\v -> vlen' v > 0) $ over both (mapXY pmap) <$> trans+ mgrid = take 2 $ fst <$> pvecs+ maxLen = maximum $ vlen' <$> pvecs+ spacing = (!!1) $ (vlen <$> zipWith psub mgrid (reverse mgrid)) ++ [maxLen]+ sfactor = spacing/maxLen -- Non-adjusted scale factor+ afactor = sfactor + (1 - sfactor)*(1 - _plot_vectors_scale pv)+ tails = pscale afactor <$> pvecs -- Paths of arrows' tails+ angles = (vangle . psub' . swap) <$> pvecs -- Angles of the arrows+ centers = snd <$> tails -- Where to draw arrow heads+ mapM_ (drawTail radius) tails+ zipWithM_ (drawArrowHead radius) centers angles+ where+ psub' = uncurry psub+ vlen' = vlen . psub'+ pvs = _plot_vectors_style pv+ radius = _point_radius $ _vector_head_style pvs+ hs angle = _vector_head_style pvs & point_shape+ %~ (\(PointShapeArrowHead a) -> PointShapeArrowHead $ a+angle)+ translateToStart (s@(x,y),(vx,vy)) = (s,(tr x vx,tr y vy))+ where tr p t = fromValue $ toValue p + toValue t+ pscale w v@(s,_) = (s,translateP (vscale w . psub' $ swap v) s)+ drawTail r v = withLineStyle (_vector_line_style pvs) $+ strokePointPath $ (^..each) v'+ where+ v' = pscale (1-(3/2)*r/l) v+ l = vlen' v+ drawArrowHead r (Point x y) theta =+ withTranslation (Point (-r*cos theta) (-r*sin theta))+ (drawPoint (hs theta) (Point x y))++renderPlotLegendVectors :: (PlotValue x, PlotValue y)+ => PlotVectors x y -> Rect -> BackendProgram ()+renderPlotLegendVectors pv (Rect p1 p2) = do+ let y = (p_y p1 + p_y p2)/2+ pv' = plot_vectors_grid .~ []+ $ plot_vectors_values .~ [((fromValue $ p_x p1, fromValue y),+ (fromValue $ p_x p2, fromValue 0))]+ $ pv+ renderPlotVectors pv' pmap+ where+ pmap (LValue x,LValue y) = Point (toValue x) (toValue y)+ pmap _ = Point 0 0++instance Default VectorStyle where+ def = VectorStyle+ { _vector_line_style = (solidLine lw $ opaque blue)+ { _line_cap = LineCapSquare }+ , _vector_head_style = PointStyle (opaque red) transparent lw (2*lw)+ (PointShapeArrowHead 0)+ } where lw = 2++instance Default (PlotVectors x y) where+ def = PlotVectors+ { _plot_vectors_title = ""+ , _plot_vectors_style = def+ , _plot_vectors_scale = 1+ , _plot_vectors_grid = []+ , _plot_vectors_mapf = id+ , _plot_vectors_values = []+ }
Graphics/Rendering/Chart/Renderable.hs view
@@ -8,6 +8,7 @@ -- is a composable drawing element, along with assorted functions to -- them. --+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Renderable(@@ -16,8 +17,9 @@ PickFn, Rectangle(..), RectCornerStyle(..),- + rectangleToRenderable,+ drawRectangle, fillBackground, addMargins,@@ -40,7 +42,6 @@ import Control.Monad import Control.Lens-import Data.Monoid import Data.Default.Class import Graphics.Rendering.Chart.Geometry@@ -61,24 +62,28 @@ data Renderable a = Renderable { -- | Calculate the minimum size of the renderable.- minsize :: ChartBackend RectSize,+ minsize :: BackendProgram RectSize, -- | Draw the renderable with a rectangle, which covers -- the origin to a given point. -- -- The resulting "pick" function maps a point in the image to a value.- render :: RectSize -> ChartBackend (PickFn a)+ render :: RectSize -> BackendProgram (PickFn a) }+ deriving (Functor) -- | A type class abtracting the conversion of a value to a Renderable. class ToRenderable a where toRenderable :: a -> Renderable () +instance ToRenderable (Renderable a) where+ toRenderable = void+ emptyRenderable :: Renderable a emptyRenderable = spacer (0,0) -- | Create a blank renderable with a specified minimum size.-spacer :: RectSize -> Renderable a +spacer :: RectSize -> Renderable a spacer sz = Renderable { minsize = return sz, render = \_ -> return nullPickFn@@ -113,7 +118,7 @@ (w,h) <- minsize rd return (w+l+r,h+t+b) - rf (w,h) = + rf (w,h) = withTranslation (Point l t) $ do pickf <- render rd (w-l-r,h-t-b) return (mkpickf pickf (t,b,l,r) (w,h))@@ -133,8 +138,8 @@ render r rsize -- | Helper function for using a renderable, when we generate it--- in the CRender monad.-embedRenderable :: ChartBackend (Renderable a) -> Renderable a+-- in the BackendProgram monad.+embedRenderable :: BackendProgram (Renderable a) -> Renderable a embedRenderable ca = Renderable { minsize = do { a <- ca; minsize a }, render = \ r -> do { a <- ca; render a r }@@ -157,27 +162,27 @@ ts <- textSize s let sz = (textSizeWidth ts, textSizeHeight ts) return (xwid sz, ywid sz)- + rf (w0,h0) = withFontStyle fs $ do ts <- textSize s let sz@(w,h) = (textSizeWidth ts, textSizeHeight ts) descent = textSizeDescent ts- + xadj HTA_Left = xwid sz/2 xadj HTA_Centre = w0/2 xadj HTA_Right = w0 - xwid sz/2- + yadj VTA_Top = ywid sz/2 yadj VTA_Centre = h0/2 yadj VTA_Bottom = h0 - ywid sz/2 yadj VTA_BaseLine = h0 - ywid sz/2 + descent*acr - withTranslation (Point 0 (-descent)) $ - withTranslation (Point (xadj hta) (yadj vta)) $ + withTranslation (Point 0 (-descent)) $+ withTranslation (Point (xadj hta) (yadj vta)) $ withRotation rot' $ do drawText (Point (-w/2) (h/2)) s return (\_-> Just s) -- PickFn String- + rot' = rot / 180 * pi (cr,sr) = (cos rot', sin rot') (acr,asr) = (abs cr, abs sr)@@ -213,47 +218,54 @@ rectangleToRenderable :: Rectangle -> Renderable a rectangleToRenderable rectangle = Renderable mf rf where- mf = return (_rect_minsize rectangle)- rf sz = do- maybeM () (fill sz) (_rect_fillStyle rectangle)- maybeM () (stroke sz) (_rect_lineStyle rectangle)- return nullPickFn+ mf = return (_rect_minsize rectangle)+ rf = \rectSize -> drawRectangle (Point 0 0)+ rectangle{ _rect_minsize = rectSize } - fill sz fs = - withFillStyle fs $ - fillPath $ strokeRectangleP sz (_rect_cornerStyle rectangle)+-- | Draw the specified rectangle such that its top-left vertex is placed at+-- the given position+drawRectangle :: Point -> Rectangle -> BackendProgram (PickFn a)+drawRectangle point rectangle = do+ maybeM () (fill point size) (_rect_fillStyle rectangle)+ maybeM () (stroke point size) (_rect_lineStyle rectangle)+ return nullPickFn+ where+ size = _rect_minsize rectangle - stroke sz ls = - withLineStyle ls $ - strokePath $ strokeRectangleP sz (_rect_cornerStyle rectangle)+ fill p sz fs =+ withFillStyle fs $+ fillPath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) - strokeRectangleP (x2,y2) RCornerSquare =- let (x1,y1) = (0,0) in moveTo' x1 y1- <> lineTo' x1 y2- <> lineTo' x2 y2- <> lineTo' x2 y1- <> lineTo' x1 y1- <> lineTo' x1 y2- - strokeRectangleP (x2,y2) (RCornerBevel s) =- let (x1,y1) = (0,0) in moveTo' x1 (y1+s)- <> lineTo' x1 (y2-s)- <> lineTo' (x1+s) y2- <> lineTo' (x2-s) y2- <> lineTo' x2 (y2-s)- <> lineTo' x2 (y1+s)- <> lineTo' (x2-s) y1- <> lineTo' (x1+s) y1- <> lineTo' x1 (y1+s)- <> lineTo' x1 (y2-s)+ stroke p sz ls =+ withLineStyle ls $+ strokePath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) - strokeRectangleP (x2,y2) (RCornerRounded s) =- let (x1,y1) = (0,0) in arcNeg (Point (x1+s) (y2-s)) s (pi2*2) pi2 - <> arcNeg (Point (x2-s) (y2-s)) s pi2 0- <> arcNeg (Point (x2-s) (y1+s)) s 0 (pi2*3)- <> arcNeg (Point (x1+s) (y1+s)) s (pi2*3) (pi2*2)- <> lineTo' x1 (y2-s)- - pi2 = pi / 2+ strokeRectangleP (Point x1 y1) (x2,y2) RCornerSquare =+ let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 y1+ <> lineTo' x1 y3+ <> lineTo' x3 y3+ <> lineTo' x3 y1+ <> lineTo' x1 y1++ strokeRectangleP (Point x1 y1) (x2,y2) (RCornerBevel s) =+ let (x3,y3) = (x1+x2,y1+y2) in moveTo' x1 (y1+s)+ <> lineTo' x1 (y3-s)+ <> lineTo' (x1+s) y3+ <> lineTo' (x3-s) y3+ <> lineTo' x3 (y3-s)+ <> lineTo' x3 (y1+s)+ <> lineTo' (x3-s) y1+ <> lineTo' (x1+s) y1+ <> lineTo' x1 (y1+s)++ strokeRectangleP (Point x1 y1) (x2,y2) (RCornerRounded s) =+ let (x3,y3) = (x1+x2,y1+y2) in+ arcNeg (Point (x1+s) (y3-s)) s (pi2*2) pi2+ <> arcNeg (Point (x3-s) (y3-s)) s pi2 0+ <> arcNeg (Point (x3-s) (y1+s)) s 0 (pi2*3)+ <> arcNeg (Point (x1+s) (y1+s)) s (pi2*3) (pi2*2)+ <> lineTo' x1 (y3-s)++ pi2 = pi / 2 $( makeLenses ''Rectangle )
Graphics/Rendering/Chart/SparkLine.hs view
@@ -117,7 +117,7 @@ sparkSize s = (sparkWidth s, so_height (sl_options s)) -- | Render a SparkLine to a drawing surface.-renderSparkLine :: SparkLine -> ChartBackend (PickFn ())+renderSparkLine :: SparkLine -> BackendProgram (PickFn ()) renderSparkLine SparkLine{sl_options=opt, sl_data=ds} = let w = 4 + (so_step opt) * (length ds - 1) + extrawidth extrawidth | so_smooth opt = 0
+ Graphics/Rendering/Chart/State.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}+module Graphics.Rendering.Chart.State(+ plot,+ plotLeft,+ plotRight,++ takeColor,+ takeShape,++ CState,+ colors,+ shapes,++ EC,+ execEC,+ liftEC,+ liftCState,+ ) where++import Control.Lens+import Control.Monad.State+import Data.Default.Class++import Data.Colour+import Data.Colour.Names++import Graphics.Rendering.Chart.Layout+import Graphics.Rendering.Chart.Plot+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.Renderable++-- | The state held when monadically constructing a graphical element+data CState = CState {+ _colors :: [AlphaColour Double], -- ^ An infinite source of colors, for use in plots+ _shapes :: [PointShape] -- ^ An infinite source of shapes, for use in plots+ }++$( makeLenses ''CState )++-- | We use nested State monads to give nice syntax. The outer state+-- is the graphical element being constructed (typically a+-- layout). The inner state contains any additional state+-- reqired. This approach means that lenses and the state monad lens+-- operators can be used directly on the value being constructed.+type EC l a = StateT l (State CState) a++instance Default CState where+ def = CState defColors defShapes+ where+ defColors = cycle (map opaque [blue,green,red,orange,yellow,violet])+ defShapes = cycle [PointShapeCircle,PointShapePlus,PointShapeCross,PointShapeStar]++instance (Default a,ToRenderable a) => ToRenderable (EC a b) where+ toRenderable = toRenderable . execEC+ +-- | Run the monadic `EC` computation, and return the graphical+-- element (ie the outer monad' state)+execEC :: (Default l) => EC l a -> l+execEC ec = evalState (execStateT ec def) def++-- | Nest the construction of a graphical element within+-- the construction of another.+liftEC :: (Default l1) => EC l1 a -> EC l2 l1+liftEC ec = do+ cs <- lift get+ let (l,cs') = runState (execStateT ec def) cs+ lift (put cs')+ return l++-- | Lift a a computation over `CState`+liftCState :: State CState a -> EC l a+liftCState = lift++-- | Add a plot to the `Layout` being constructed.+plot :: (ToPlot p) => EC (Layout x y) (p x y) -> EC (Layout x y) ()+plot pm = do+ p <- pm+ layout_plots %= (++[toPlot p])++-- | Add a plot against the left axis to the `LayoutLR` being constructed.+plotLeft :: (ToPlot p) => EC (LayoutLR x y1 y2) (p x y1) -> EC (LayoutLR x y1 y2) ()+plotLeft pm = do+ p <- pm+ layoutlr_plots %= (++[Left (toPlot p)])++-- | Add a plot against the right axis tof the `LayoutLR` being constructed.+plotRight :: (ToPlot p) => EC (LayoutLR x y1 y2) (p x y2) -> EC (LayoutLR x y1 y2) ()+plotRight pm = do+ p <- pm+ layoutlr_plots %= (++[Right (toPlot p)])++-- | Pop and return the next color from the state+takeColor :: EC l (AlphaColour Double)+takeColor = liftCState $ do+ (c,cs) <- fromInfiniteList `fmap` use colors+ colors .= cs+ return c++-- | Pop and return the next shape from the state+takeShape :: EC l PointShape+takeShape = liftCState $ do+ (c,cs) <- fromInfiniteList `fmap` use shapes+ shapes .= cs+ return c++fromInfiniteList :: [a] -> (a, [a])+fromInfiniteList [] = error "fromInfiniteList (takeColor or takeShape): empty list"+fromInfiniteList (x:xs) = (x, xs)
Graphics/Rendering/Chart/Utils.hs view
@@ -1,16 +1,24 @@ -- | Non chart specific utility functions. module Graphics.Rendering.Chart.Utils( isValidNumber,+ log10, maybeM,+ whenJust, ) where --- | Checks if the given value is and actual numeric value and not +-- | Checks if the given value is and actual numeric value and not -- a concept like NaN or infinity. isValidNumber :: (RealFloat a) => a -> Bool isValidNumber v = not (isNaN v) && not (isInfinite v) +-- | Shorthand for the decimal logarithm+log10 :: (Floating a) => a -> a+log10 = logBase 10+ -- | Version of 'Prelude.maybe' that returns a monadic value. maybeM :: (Monad m) => b -> (a -> m b) -> Maybe a -> m b maybeM v = maybe (return v) -+-- | Specialization to ()+whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()+whenJust m f = maybeM () f m
+ Numeric/Histogram.hs view
@@ -0,0 +1,69 @@+{-# 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'+--+-- Examples:+--+-- >>> binBounds 0 3 4+-- [(0.0,0.75),(0.75,1.5),(1.5,2.25),(2.25,3.0)]+binBounds :: RealFrac a => a -> a -> Int -> [Range a]+binBounds a b n = map (\i->(lbound i, lbound (i+1))) [0..n-1]+ 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'+--+-- Examples:+--+-- >>> :{+-- histWithBins+-- (V.fromList [(0.0, 0.75), (0.75, 1.5), (1.5, 2.25), (2.25, 3.0)])+-- [(1, 0), (1, 0), (1, 1), (1, 2), (1, 2), (1, 2), (1, 3)]+-- :}+-- [((0.0,0.75),2),((0.75,1.5),1),((1.5,2.25),3),((2.25,3.0),1)]+histWithBins :: (Num w, RealFrac a) => V.Vector (Range a) -> [(w, a)] -> V.Vector (Range a, w)+histWithBins bins xs =+ let n = V.length bins+ testBin :: RealFrac a => a -> (Int, Range a) -> Bool+ testBin x (i, (a,b)) =+ if i == n - 1+ then x >= a && x <= b+ else 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) $ V.indexed bins1 of+ v | V.null v -> return ()+ v | (idx,_) <- V.head v -> do+ m <- MV.read bs idx+ MV.write bs idx $! m+w++ counts = runST $ do b <- MV.replicate n 0+ mapM_ (f bins b) xs+ V.freeze b+ in V.zip bins counts