diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,26 +1,40 @@ Name: Chart -Version: 1.1 +Version: 1.9.5 License: BSD3 License-file: LICENSE -Copyright: Tim Docker, 2006-2010 +Copyright: Tim Docker, 2006-2014 Author: Tim Docker Maintainer: Tim Docker 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, based upon the cairo graphics library. +Description: A library for generating 2D Charts and Plots, with backends provided by + Cairo () + and + 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 && < 3.11 + , 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: Graphics.Rendering.Chart, Graphics.Rendering.Chart.Drawing, @@ -31,13 +45,12 @@ 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, Graphics.Rendering.Chart.Layout, Graphics.Rendering.Chart.Legend, - Graphics.Rendering.Chart.Simple, - Graphics.Rendering.Chart.Simple.Internal, Graphics.Rendering.Chart.Grid, Graphics.Rendering.Chart.Plot, Graphics.Rendering.Chart.Plot.Types, @@ -49,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 diff --git a/Graphics/Rendering/Chart.hs b/Graphics/Rendering/Chart.hs --- a/Graphics/Rendering/Chart.hs +++ b/Graphics/Rendering/Chart.hs @@ -1,32 +1,40 @@ ---------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006-2013 -- License : BSD-style (see chart/COPYRIGHT) -- -- A framework for creating 2D charts in Haskell. -- --- The basic model is that you define a value of type 'Renderable', --- typically by applying 'toRenderable' to some other value. This --- 'Renderable' is then actually displayed or output by calling either --- 'renderableToPNGFile', or 'renderableToWindow'. +-- For the simplest API, see the "Graphics.Rendering.Chart.Easy" +-- module. -- --- Currently, there are two kinds of 'Renderable' for displaying charts: +-- 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'. -- --- * a standard two axes chart can be is created by applying --- 'toRenderable' to a value of type 'Layout1' +-- Currently, there are three types of charts: -- --- * a pie chart can be is created by applying --- 'toRenderable' to a value of type 'PieLayout' +-- * 'Layout' is a standard XY chart +-- +-- * 'LayoutLR' is an XY chart with independent left +-- and right axes -- --- Multiple Renderables can be composed using the "Graphics.Rendering.Chart.Grid" module. +-- * 'PieLayout' is a pie chart -- --- Many of the record structure involved in the API have a large --- number of fields. For each record type X, there is generally a --- default value called defaultX with sensibly initialised fields. --- For example, 'Layout1' has 'defaultLayout1', etc. +-- 'Layout' and 'LayoutLR' charts can be stacked vertically using +-- the 'StackedLayouts' type. +-- +-- 'Renderable's can be composed in arbitrary ways using the +-- "Graphics.Rendering.Chart.Grid" module. -- --- For a simpler though less flexible API, see "Graphics.Rendering.Chart.Simple". +-- Many of the record structure involved in the API have a large +-- number of fields. 'Lens'es are provided to access each field. Also, +-- for each record type, there is generally a default value, which can +-- be accessed through the 'def' value of the 'Default' typeclass. -- ----------------------------------------------------------------------------- @@ -39,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 @@ -49,3 +58,4 @@ import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Plot import Graphics.Rendering.Chart.Legend +import Graphics.Rendering.Chart.Backend.Types diff --git a/Graphics/Rendering/Chart/Axis.hs b/Graphics/Rendering/Chart/Axis.hs --- a/Graphics/Rendering/Chart/Axis.hs +++ b/Graphics/Rendering/Chart/Axis.hs @@ -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 diff --git a/Graphics/Rendering/Chart/Axis/Floating.hs b/Graphics/Rendering/Chart/Axis/Floating.hs --- a/Graphics/Rendering/Chart/Axis/Floating.hs +++ b/Graphics/Rendering/Chart/Axis/Floating.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis.Floating --- Copyright : (c) Tim Docker 2010 +-- Copyright : (c) Tim Docker 2010, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Calculate and render floating value axes @@ -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,22 +30,29 @@ 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 -import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Utils import Graphics.Rendering.Chart.Axis.Types +-- Note: the following code uses explicit Integer types +-- to avoid -Wall 'defaulting to Integer' messages. + 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} @@ -57,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 @@ -70,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 @@ -79,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, @@ -88,27 +185,23 @@ _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 } -- | Generate a linear axis with the specified bounds scaledAxis :: RealFloat a => LinearAxisParams a -> (a,a) -> AxisFn a -scaledAxis lap (min,max) ps0 = makeAxis' realToFrac realToFrac +scaledAxis lap rs@(minV,maxV) ps0 = makeAxis' realToFrac realToFrac (_la_labelf lap) (labelvs,tickvs,gridvs) where ps = filter isValidNumber ps0 range [] = (0,1) - range _ | min == max = if min==0 then (-1,1) else - let d = abs (min * 0.01) in (min-d,max+d) - | otherwise = (min,max) + range _ | minV == maxV = if minV==0 then (-1,1) else + let d = abs (minV * 0.01) in (minV-d,maxV+d) + | otherwise = rs labelvs = map fromRational $ steps (fromIntegral (_la_nLabels lap)) r tickvs = map fromRational $ steps (fromIntegral (_la_nTicks lap)) (minimum labelvs,maximum labelvs) @@ -118,25 +211,26 @@ -- | Generate a linear axis automatically, scaled appropriately for the -- input data. autoScaledAxis :: RealFloat a => LinearAxisParams a -> AxisFn a -autoScaledAxis lap ps0 = scaledAxis lap (min,max) ps0 +autoScaledAxis lap ps0 = scaledAxis lap rs ps where - (min,max) = (minimum ps0,maximum ps0) + ps = filter isValidNumber ps0 + rs = (minimum ps,maximum ps) steps :: RealFloat a => a -> (a,a) -> [Rational] -steps nSteps (min,max) = map ((s*) . fromIntegral) [min' .. max'] +steps nSteps rs@(minV,maxV) = map ((s*) . fromIntegral) [min' .. max'] where - s = chooseStep nSteps (min,max) - min' = floor $ realToFrac min / s - max' = ceiling $ realToFrac max / s - n = (max' - min') - + s = chooseStep nSteps rs + min' :: Integer + min' = floor $ realToFrac minV / s + max' = ceiling $ realToFrac maxV / s chooseStep :: RealFloat a => a -> (a,a) -> Rational -chooseStep nsteps (x1,x2) = minimumBy (comparing proximity) steps +chooseStep nsteps (x1,x2) = minimumBy (comparing proximity) stepVals where delta = x2 - x1 - mult = 10 ^^ (floor $ log10 $ delta / nsteps) - steps = map (mult*) [0.1,0.2,0.25,0.5,1.0,2.0,2.5,5.0,10,20,25,50] + 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 -- | Given a target number of values, and a list of input points, @@ -146,99 +240,101 @@ autoSteps nSteps vs = map fromRational $ steps (fromIntegral nSteps) r where range [] = (0,1) - range _ | min == max = (min-0.5,min+0.5) - | otherwise = (min,max) - (min,max) = (minimum ps,maximum ps) + range _ | minV == maxV = (minV-0.5,minV+0.5) + | otherwise = rs + rs@(minV,maxV) = (minimum ps,maximum ps) ps = filter isValidNumber vs r = range ps ---------------------------------------------------------------------- -{-# 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 - (min,max) = (minimum ps,maximum ps) + (minV,maxV) = (minimum ps,maximum ps) wrap = map fromRational range [] = (3,30) - range _ | min == max = (realToFrac $ min/3, realToFrac $ max*3) - | otherwise = (realToFrac $ min, realToFrac $ max) - (rlabelvs, rtickvs, rgridvs) = logTicks (range ps) + range _ | minV == maxV = (realToFrac $ minV/3, realToFrac $ maxV*3) + | otherwise = (realToFrac $ minV, realToFrac $ maxV) + (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 + + -- frac :: (RealFrac a, Integral b) => a -> (b, a) + frac :: (RealFrac a) => a -> (Integer, a) + frac x | 0 <= b = (a,b) + | otherwise = (a-1,b+1) + where + (a,b) = properFraction x + ratio = high/low lower a l = let (i,r) = frac (log10 a) in - (maximum (1:filter (\x -> log10 (fromRational x) <= r) l))*10^^i - upper a l = let (i,r) = properFraction (log10 a) in - (minimum (10:filter (\x -> r <= log10 (fromRational x)) l))*10^^i + 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))] + 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) - major | 17.5 < log10 ratio = map (\x -> 10^^(round x)) $ - steps (min 5 (log10 ratio)) - (log10 low, log10 high) - | 12 < log10 ratio = map (\x -> 10^^(round x)) $ - steps ((log10 ratio)/5) (log10 low, log10 high) - | 6 < log10 ratio = map (\x -> 10^^(round x)) $ - steps ((log10 ratio)/2) (log10 low, log10 high) + + 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 $ + steps (log10 ratio / 5) logRange + | 6 < log10 ratio = map roundPow $ + steps (log10 ratio / 2) logRange | 3 < log10 ratio = midselection (low,high) [1,10] | 20 < ratio = midselection (low,high) [1,5,10] | 6 < ratio = midselection (low,high) [1,2,4,6,8,10] | 3 < ratio = midselection (low,high) [1..10] | otherwise = steps 5 (low,high) + (l',h') = (minimum major, maximum major) (dl',dh') = (fromRational l', fromRational h') - ratio' = fromRational (h'/l') - minor | 50 < log10 ratio' = map (\x -> 10^^(round x)) $ - steps 50 (log10 $ dl', log10 $ dh') - | 6 < log10 ratio' = filter (\x -> l'<=x && x <=h') $ - powers (dl', dh') [1,10] - | 3 < log10 ratio' = filter (\x -> l'<=x && x <=h') $ - powers (dl',dh') [1,5,10] - | 6 < ratio' = filter (\x -> l'<=x && x <=h') $ - powers (dl',dh') [1..10] - | 3 < ratio' = filter (\x -> l'<=x && x <=h') $ - powers (dl',dh') [1,1.2..10] - | otherwise = steps 50 (dl', dh') - -log10 :: (Floating a) => a -> a -log10 = logBase 10 + ratio' :: Double + ratio' = fromRational (h'/l') + filterX = filter (\x -> l'<=x && x <=h') . powers (dl',dh') -frac x | 0 <= b = (a,b) - | otherwise = (a-1,b+1) - where - (a,b) = properFraction x + minor | 50 < log10 ratio' = map roundPow $ + steps 50 (log10 dl', log10 dh') + | 6 < log10 ratio' = filterX [1,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') $( makeLenses ''LinearAxisParams ) $( makeLenses ''LogAxisParams ) - diff --git a/Graphics/Rendering/Chart/Axis/Indexed.hs b/Graphics/Rendering/Chart/Axis/Indexed.hs --- a/Graphics/Rendering/Chart/Axis/Indexed.hs +++ b/Graphics/Rendering/Chart/Axis/Indexed.hs @@ -1,19 +1,21 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis.Unit --- Copyright : (c) Tim Docker 2010 +-- Copyright : (c) Tim Docker 2010, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Calculate and render indexed axes {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} module Graphics.Rendering.Chart.Axis.Indexed( PlotIndex(..), + autoIndexAxis', autoIndexAxis, addIndexes, ) where - + import Data.Default.Class import Graphics.Rendering.Chart.Axis.Types @@ -30,23 +32,26 @@ -- | Augment a list of values with index numbers for plotting. addIndexes :: [a] -> [(PlotIndex,a)] -addIndexes as = map (\(i,a) -> (PlotIndex i,a)) (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_labels = [filter (\(i,l) -> i >= imin && i <= imax) - (zip [0..] labels)], + _axis_ticks = if tks then map (, 5) $ take (length labels) [0..] else [], + _axis_labels = [filter (\(i,_) -> i >= imin && i <= imax) + (zip [0..] labels)], _axis_grid = [] } where vport r i = linMap id ( fromIntegral imin - 0.5 , fromIntegral imax + 0.5) r (fromIntegral i) - invport r z = invLinMap round fromIntegral (imin, imax) r z + invport = invLinMap round fromIntegral (imin, imax) imin = minimum vs imax = maximum vs + +autoIndexAxis :: Integral i => [String] -> AxisFn i +autoIndexAxis = autoIndexAxis' False diff --git a/Graphics/Rendering/Chart/Axis/Int.hs b/Graphics/Rendering/Chart/Axis/Int.hs --- a/Graphics/Rendering/Chart/Axis/Int.hs +++ b/Graphics/Rendering/Chart/Axis/Int.hs @@ -1,10 +1,11 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis.Int --- Copyright : (c) Tim Docker 2010 +-- Copyright : (c) Tim Docker 2010, 2014 -- 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,8 +14,9 @@ ) 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.Drawing import Graphics.Rendering.Chart.Axis.Types import Graphics.Rendering.Chart.Axis.Floating @@ -23,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 @@ -30,25 +77,25 @@ defaultIntAxis :: (Show a) => LinearAxisParams a defaultIntAxis = LinearAxisParams { - _la_labelf = show, + _la_labelf = map show, _la_nLabels = 5, _la_nTicks = 10 } autoScaledIntAxis :: (Integral i, PlotValue i) => LinearAxisParams i -> AxisFn i -autoScaledIntAxis lap ps = scaledIntAxis lap (min,max) ps +autoScaledIntAxis lap ps = scaledIntAxis lap rs ps where - (min,max) = (minimum ps,maximum ps) + rs = (minimum ps,maximum ps) scaledIntAxis :: (Integral i, PlotValue i) => LinearAxisParams i -> (i,i) -> AxisFn i -scaledIntAxis lap (min,max) ps = +scaledIntAxis lap (minI,maxI) ps = makeAxis (_la_labelf lap) (labelvs,tickvs,gridvs) where range [] = (0,1) - range _ | min == max = (fromIntegral $ min-1, fromIntegral $ min+1) - | otherwise = (fromIntegral $ min, fromIntegral $ max) + range _ | minI == maxI = (fromIntegral $ minI-1, fromIntegral $ minI+1) + | otherwise = (fromIntegral minI, fromIntegral maxI) -- labelvs :: [i] labelvs = stepsInt (fromIntegral $ _la_nLabels lap) r tickvs = stepsInt (fromIntegral $ _la_nTicks lap) @@ -62,16 +109,25 @@ where bestSize n a (a':as) = let n' = goodness a' in if n' < n then bestSize n' a' as else a + bestSize _ _ [] = [] 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 - steps size (min,max) = takeWhile ( ([LocalTime],[LocalTime]) coverTS :: TimeSeq -> LocalTime -> LocalTime -> [LocalTime] -coverTS tseq min max = min' ++ enumerateTS tseq min max ++ max' +coverTS tseq minT maxT = min' ++ enumerateTS tseq minT maxT ++ max' where - min' = if elemTS min tseq then [] else take 1 (fst (tseq min)) - max' = if elemTS max tseq then [] else take 1 (snd (tseq max)) + 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 -> LocalTime -> LocalTime -> [LocalTime] -enumerateTS tseq min max = - reverse (takeWhile (>=min) ts1) ++ takeWhile (<=max) ts2 +enumerateTS tseq minT maxT = + reverse (takeWhile (>=minT) ts1) ++ takeWhile (<=maxT) ts2 where - (ts1,ts2) = tseq min + (ts1,ts2) = tseq minT elemTS :: LocalTime -> TimeSeq -> Bool elemTS t tseq = case tseq t of - (_,(t0:_)) | t == t0 -> True - _ -> False + (_,t0:_) | t == t0 -> True + _ -> False -- | How to display a time type TimeLabelFn = LocalTime -> String @@ -78,15 +84,24 @@ | BetweenTicks deriving (Show) --- | Create an 'AxisFn' to for a time axis. The first 'TimeSeq' sets the --- minor ticks, and the ultimate range will be aligned to its elements. --- The second 'TimeSeq' sets the labels and grid. The third 'TimeSeq' --- sets the second line of labels. The 'TimeLabelFn' is --- used to format LocalTimes for labels. The values to be plotted --- against this axis can be created with 'doubleFromLocalTime'. -timeAxis :: TimeSeq -> TimeSeq -> TimeLabelFn -> TimeLabelAlignment -> - TimeSeq -> TimeLabelFn -> TimeLabelAlignment -> - AxisFn LocalTime +-- | Create an 'AxisFn' to for a time axis. +-- +-- The values to be plotted against this axis can be created with +-- 'doubleFromLocalTime'. +timeAxis :: + 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 `LocalTime` for labels. + -> TimeLabelAlignment + -> AxisFn LocalTime timeAxis tseq lseq labelf lal cseq contextf clal pts = AxisData { _axis_visibility = def, _axis_viewport = vmap(min', max'), @@ -94,28 +109,28 @@ _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 - (min,max) = case pts of + (minT,maxT) = case pts of [] -> (refLocalTime,refLocalTime) ps -> (minimum ps, maximum ps) refLocalTime = LocalTime (ModifiedJulianDay 0) midnight - times = coverTS tseq min max - ltimes = coverTS lseq min max - ctimes = coverTS cseq min max + 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) + labels f ts lal' = + [ (align lal' m1' m2', f m1) | (m1,m2) <- zip ts (tail ts) , let m1' = if m1max' then max' else m2 ] align BetweenTicks m1 m2 = avg m1 m2 - align UnderTicks m1 m2 = m1 + align UnderTicks m1 _ = m1 avg m1 m2 = localTimeFromDouble $ m1' + (m2' - m1')/2 where @@ -146,28 +161,27 @@ secondSeq step t = (iterate rev t1, tail (iterate fwd t1)) where h0 = todHour (localTimeOfDay t) m0 = todMin (localTimeOfDay t) - s0 = todSec (localTimeOfDay t) `truncateTo` (fromIntegral 1 / 1000) + s0 = todSec (localTimeOfDay t) `truncateTo` (1 / 1000) t0 = LocalTime (localDay t) (TimeOfDay h0 m0 s0) - t1 = if t0 < t then t0 else (rev t0) + t1 = if t0 < t then t0 else rev t0 rev = addTod 0 0 (negate step) - fwd = addTod 0 0 (step) + fwd = addTod 0 0 step millis1, millis10, millis100, seconds, fiveSeconds :: TimeSeq -millis1 = secondSeq (fromIntegral 1 / 1000) -millis10 = secondSeq (fromIntegral 1 / 100) -millis100 = secondSeq (fromIntegral 1 / 10) -seconds = secondSeq (fromIntegral 1) -fiveSeconds = secondSeq (fromIntegral 5) +millis1 = secondSeq (1 / 1000) +millis10 = secondSeq (1 / 100) +millis100 = secondSeq (1 / 10) +seconds = secondSeq 1 +fiveSeconds = secondSeq 5 minuteSeq :: Int -> TimeSeq minuteSeq step t = (iterate rev t1, tail (iterate fwd t1)) where h0 = todHour (localTimeOfDay t) m0 = todMin (localTimeOfDay t) t0 = LocalTime (localDay t) (TimeOfDay h0 m0 0) - t1 = if t0 < t then t0 else (rev t0) - rev = addTod 0 (negate step) (fromIntegral 0) - fwd = addTod 0 step (fromIntegral 0) - + t1 = if t0 < t then t0 else rev t0 + rev = addTod 0 (negate step) 0 + fwd = addTod 0 step 0 minutes, fiveMinutes :: TimeSeq minutes = minuteSeq 1 @@ -178,15 +192,15 @@ hours t = (iterate rev t1, tail (iterate fwd t1)) where h0 = todHour (localTimeOfDay t) t0 = LocalTime (localDay t) (TimeOfDay h0 0 0) - t1 = if t0 < t then t0 else (rev t0) - rev = addTod (-1) 0 (fromIntegral 0) - fwd = addTod 1 0 (fromIntegral 0) + t1 = if t0 < t then t0 else rev t0 + rev = addTod (-1) 0 0 + fwd = addTod 1 0 0 -- | A 'TimeSeq' for calendar days. days :: TimeSeq days t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) where t0 = localDay t - t1 = if (toTime t0) < t then t0 else (rev t0) + t1 = if toTime t0 < t then t0 else rev t0 rev = pred fwd = succ toTime d = LocalTime d midnight @@ -194,8 +208,8 @@ -- | 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,d) = toGregorian $ localDay t in fromGregorian y m 1 - t1 = if toTime t0 < t then t0 else (rev t0) + where t0 = let (y,m,_) = toGregorian $ localDay t in fromGregorian y m 1 + t1 = if toTime t0 < t then t0 else rev t0 rev = addGregorianMonthsClip (-1) fwd = addGregorianMonthsClip 1 toTime d = LocalTime d midnight @@ -203,15 +217,15 @@ -- | A 'TimeSeq' for calendar years. years :: TimeSeq years t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) - where t0 = let (y,m,d) = toGregorian $ localDay t in y - t1 = if toTime t0 < t then t0 else (rev t0) + where t0 = toGregorian (localDay t) ^. _1 + t1 = if toTime t0 < t then t0 else rev t0 rev = pred fwd = succ toTime y = LocalTime (fromGregorian y 1 1) midnight -- | A 'TimeSeq' for no sequence at all. noTime :: TimeSeq -noTime t = ([],[]) +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 @@ -220,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 diff --git a/Graphics/Rendering/Chart/Axis/Time.hs b/Graphics/Rendering/Chart/Axis/Time.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Axis/Time.hs @@ -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 m1max' 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 diff --git a/Graphics/Rendering/Chart/Axis/Types.hs b/Graphics/Rendering/Chart/Axis/Types.hs --- a/Graphics/Rendering/Chart/Axis/Types.hs +++ b/Graphics/Rendering/Chart/Axis/Types.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Axis.Types --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Type definitions for Axes @@ -18,7 +18,6 @@ AxisFn, defaultAxisLineStyle, - defaultAxisStyle, defaultGridLineStyle, makeAxis, @@ -57,13 +56,9 @@ ) where -import Data.Time -import Data.Fixed -import Data.Maybe -import System.Locale (defaultTimeLocale) import Control.Monad import Data.List(sort,intersperse) -import Control.Lens +import Control.Lens hiding (at, re) import Data.Colour (opaque) import Data.Colour.Names (black, lightgrey) import Data.Default.Class @@ -182,17 +177,17 @@ axisLabelsOverride :: [(x,String)] -> AxisData x -> AxisData x axisLabelsOverride o ad = ad{ _axis_labels = [o] } -minsizeAxis :: AxisT x -> ChartBackend RectSize -minsizeAxis (AxisT at as rev ad) = do - let labelVis = _axis_show_labels $ _axis_visibility $ ad - tickVis = _axis_show_ticks $ _axis_visibility $ ad +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 labels = if labelVis then labelTexts ad else [] ticks = if tickVis then _axis_ticks ad else [] - labelSizes <- withFontStyle (_axis_label_style as) $ do + labelSizes <- withFontStyle (_axis_label_style as) $ mapM (mapM textDimension) labels let ag = _axis_label_gap as - let tsize = maximum ([0] ++ [ max 0 (-l) | (v,l) <- ticks ]) + let tsize = maximum (0 : [ max 0 (-l) | (_,l) <- ticks ]) let hw = maximum0 (map (maximum0.map fst) labelSizes) let hh = ag + tsize + (sum . intersperse ag . map (maximum0.map snd) $ labelSizes) @@ -201,24 +196,25 @@ 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]] labelTexts ad = map (map snd) (_axis_labels ad) +maximum0 :: (Num a, Ord a) => [a] -> a maximum0 [] = 0 maximum0 vs = maximum vs -- | Calculate the amount by which the labels extend beyond -- the ends of the axis. -axisOverhang :: (Ord x) => AxisT x -> ChartBackend (Double,Double) -axisOverhang (AxisT at as rev ad) = do +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) $ do + labelSizes <- withFontStyle (_axis_label_style as) $ mapM textDimension labels case labelSizes of [] -> return (0,0) @@ -232,18 +228,18 @@ E_Left -> ohangv E_Right -> ohangh -renderAxis :: AxisT x -> RectSize -> ChartBackend (PickFn x) -renderAxis at@(AxisT et as rev ad) sz = do +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 - when (_axis_show_line vis) $ do + when (_axis_show_line vis) $ withLineStyle (ls {_line_cap = LineCapSquare}) $ do p <- alignStrokePoints [Point sx sy,Point ex ey] strokePointPath p - when (_axis_show_ticks vis) $ do - withLineStyle (ls {_line_cap = LineCapButt}) $ do + when (_axis_show_ticks vis) $ + withLineStyle (ls {_line_cap = LineCapButt}) $ mapM_ drawTick (_axis_ticks ad) - when (_axis_show_labels vis) $ do + when (_axis_show_labels vis) $ withFontStyle (_axis_label_style as) $ do labelSizes <- mapM (mapM textDimension) (labelTexts ad) let sizes = map ((+ag).maximum0.map coord) labelSizes @@ -253,24 +249,24 @@ where (sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz - drawTick (value,length) = + drawTick (value,len) = let t1 = axisPoint value - t2 = t1 `pvadd` (vscale length tp) + t2 = t1 `pvadd` vscale len tp in alignStrokePoints [t1,t2] >>= strokePointPath (hta,vta,coord,awayFromAxis) = case et of - E_Top -> (HTA_Centre, VTA_Bottom, snd, \v -> (Vector 0 (-v))) - E_Bottom -> (HTA_Centre, VTA_Top, snd, \v -> (Vector 0 v)) - E_Left -> (HTA_Right, VTA_Centre, fst, \v -> (Vector (-v) 0)) - E_Right -> (HTA_Left, VTA_Centre, fst, \v -> (Vector v 0)) + E_Top -> (HTA_Centre, VTA_Bottom, snd, \v -> Vector 0 (-v)) + E_Bottom -> (HTA_Centre, VTA_Top, snd, \v -> Vector 0 v) + E_Left -> (HTA_Right, VTA_Centre, fst, \v -> Vector (-v) 0) + E_Right -> (HTA_Left, VTA_Centre, fst, \v -> Vector v 0) avoidOverlaps labels = do rects <- mapM labelDrawRect labels return $ map snd . head . filter (noOverlaps . map fst) - $ map (\n -> eachNth n rects) [0 .. length rects] + $ map (`eachNth` rects) [0 .. length rects] labelDrawRect (value,s) = do - let pt = axisPoint value `pvadd` (awayFromAxis ag) + let pt = axisPoint value `pvadd` awayFromAxis ag r <- textDrawRect hta vta pt s return (hBufferRect r,(value,s)) @@ -279,7 +275,7 @@ mapM_ drawLabel labels' where drawLabel (value,s) = do - drawTextA hta vta (axisPoint value `pvadd` (awayFromAxis offset)) s + drawTextA hta vta (axisPoint value `pvadd` awayFromAxis offset) s textDimension s ag = _axis_label_gap as @@ -288,7 +284,7 @@ hBufferRect :: Rect -> Rect hBufferRect (Rect p (Point x y)) = Rect p $ Point x' y where x' = x + w/2 - w = x - (p_x p) + w = x - p_x p noOverlaps :: [Rect] -> Bool noOverlaps [] = True @@ -304,6 +300,7 @@ p4 = Point x2 y1 ps = [p1,p2,p3,p4] +eachNth :: Int -> [a] -> [a] eachNth n = skipN where n' = n - 1 @@ -317,15 +314,15 @@ axisMapping :: AxisT z -> RectSize -> (Double,Double,Double,Double,Vector,z->Point,Point->z) -axisMapping (AxisT et as rev ad) (x2,y2) = case et of - E_Top -> (x1,y2,x2,y2, (Vector 0 1), mapx y2, imapx) - E_Bottom -> (x1,y1,x2,y1, (Vector 0 (-1)), mapx y1, imapx) - E_Left -> (x2,y2,x2,y1, (Vector (1) 0), mapy x2, imapy) - E_Right -> (x1,y2,x1,y1, (Vector (-1) 0), mapy x1, imapy) +axisMapping (AxisT et _ rev ad) (x2,y2) = case et of + E_Top -> (x1,y2,x2,y2, Vector 0 1, mapx y2, imapx) + E_Bottom -> (x1,y1,x2,y1, Vector 0 (-1), mapx y1, imapx) + E_Left -> (x2,y2,x2,y1, Vector 1 0, mapy x2, imapy) + E_Right -> (x1,y2,x1,y1, Vector (-1) 0, mapy x1, imapy) where (x1,y1) = (0,0) - xr = reverse (x1,x2) - yr = reverse (y2,y1) + xr = reverseR (x1,x2) + yr = reverseR (y2,y1) mapx y x = Point (_axis_viewport ad xr x) y mapy x y = Point x (_axis_viewport ad yr y) @@ -333,15 +330,15 @@ imapx (Point x _) = _axis_tropweiv ad xr x imapy (Point _ y) = _axis_tropweiv ad yr y - reverse r@(r0,r1) = if rev then (r1,r0) else r + reverseR r@(r0,r1) = if rev then (r1,r0) else r -- -renderAxisGrid :: RectSize -> AxisT z -> ChartBackend () -renderAxisGrid sz@(w,h) at@(AxisT re as rev ad) = do - withLineStyle (_axis_grid_style as) $ do +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) where - (sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz + (_,_,_,_,_,axisPoint,_) = axisMapping at sz drawGridLine E_Top = vline drawGridLine E_Bottom = vline @@ -357,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, @@ -370,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, @@ -384,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)] } @@ -397,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 diff --git a/Graphics/Rendering/Chart/Axis/Unit.hs b/Graphics/Rendering/Chart/Axis/Unit.hs --- a/Graphics/Rendering/Chart/Axis/Unit.hs +++ b/Graphics/Rendering/Chart/Axis/Unit.hs @@ -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, diff --git a/Graphics/Rendering/Chart/Backend.hs b/Graphics/Rendering/Chart/Backend.hs --- a/Graphics/Rendering/Chart/Backend.hs +++ b/Graphics/Rendering/Chart/Backend.hs @@ -1,10 +1,16 @@ --- | This module provides the API for drawing operations abstracted --- to arbitrary 'ChartBackend's. +----------------------------------------------------------------------------- +-- | +-- 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 drive arbitrary Backend. + module Graphics.Rendering.Chart.Backend ( -- * The backend Monad - ChartBackend(..) - , CRender + BackendProgram -- * Backend Operations , fillPath @@ -42,8 +48,6 @@ , FontSlant(..) , FontStyle(..) - , defaultFontStyle - , HTextAnchor(..) , VTextAnchor(..) diff --git a/Graphics/Rendering/Chart/Backend/Impl.hs b/Graphics/Rendering/Chart/Backend/Impl.hs --- a/Graphics/Rendering/Chart/Backend/Impl.hs +++ b/Graphics/Rendering/Chart/Backend/Impl.hs @@ -1,18 +1,18 @@ {-# LANGUAGE GADTs #-} --- | This module provides the implementation details common to all 'ChartBackend's. +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Backend.Impl +-- Copyright : (c) Tim Docker 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- This module provides the implementation details common to all 'ChartBackend's. + module Graphics.Rendering.Chart.Backend.Impl where -import Data.Monoid -import Control.Applicative -import Control.Monad.Reader +import Control.Monad import Control.Monad.Operational -import Data.Default.Class - -import Data.Colour -import Data.Colour.Names - import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Backend.Types @@ -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) diff --git a/Graphics/Rendering/Chart/Backend/Types.hs b/Graphics/Rendering/Chart/Backend/Types.hs --- a/Graphics/Rendering/Chart/Backend/Types.hs +++ b/Graphics/Rendering/Chart/Backend/Types.hs @@ -1,5 +1,12 @@ {-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Backend.Types +-- Copyright : (c) Tim Docker 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- + module Graphics.Rendering.Chart.Backend.Types where import Data.Default.Class @@ -98,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 @@ -131,15 +133,15 @@ -- | Abstract data type for a fill style. -- --- The contained Cairo action sets the required fill --- style in the Cairo rendering state. +-- 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 } ------------------------------------------------------------------------- @@ -159,25 +161,29 @@ -- -- This is usually used to align prior to stroking. - -- | A adjustment applied immediately prior to coordinates + -- | The adjustment applied immediately prior to coordinates -- being transformed. -- -- This is usually used to align prior to filling. afCoordAlignFn :: AlignmentFn } --- | Alignment to render good on raster based graphics. +-- | Alignment to render on raster based graphics. bitmapAlignmentFns :: AlignmentFns bitmapAlignmentFns = AlignmentFns (adjfn 0.5) (adjfn 0.0) where adjfn offset (Point x y) = Point (adj x) (adj y) where - adj v = (fromIntegral.round) v +offset + -- avoid messages about Integer default + rnd :: Double -> Integer + rnd = round + adj v = (fromIntegral.rnd) v +offset --- | Alignment to render good on vector based graphics. +-- | Alignment to render on vector based graphics. vectorAlignmentFns :: AlignmentFns vectorAlignmentFns = AlignmentFns id id $( makeLenses ''LineStyle ) $( makeLenses ''FontStyle ) +$( makeLenses ''FillStyle ) diff --git a/Graphics/Rendering/Chart/Drawing.hs b/Graphics/Rendering/Chart/Drawing.hs --- a/Graphics/Rendering/Chart/Drawing.hs +++ b/Graphics/Rendering/Chart/Drawing.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Drawing --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- This module contains basic types and functions used for drawing. @@ -13,7 +13,7 @@ -- -- These accessors are not shown in this API documentation. They have -- the same name as the field, but with the trailing underscore --- dropped. Hence for data field f_::F in type D, they have type +-- dropped. Hence for data field @f_::F@ in type @D@, they have type -- -- @ -- f :: Control.Lens.Lens' D F @@ -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 @@ -85,50 +85,53 @@ ) where import Data.Default.Class -import Control.Lens hiding (moveTo) +-- lens < 4 includes Control.Lens.Zipper.moveTo which clashes +-- with Graphics.Rendering.Chart.Geometry.moveTo (so you get +-- -Wall notices). This would suggest a 'hiding (moveTo)' in +-- the import, but it's been removed in lens-4.0 and I don't +-- feel it's worth the use of conditional compilation. This does +-- lead to the qualified Geometry import below. +import Control.Lens import Data.Colour -import Data.Colour.SRGB import Data.Colour.Names import Data.List (unfoldr) -import Data.Monoid -import Control.Monad.Reader - import Graphics.Rendering.Chart.Backend -import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Geometry hiding (moveTo) +import qualified Graphics.Rendering.Chart.Geometry as G -- ----------------------------------------------------------------------- -- Transformation helpers -- ----------------------------------------------------------------------- -- | 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 = do - withLineStyle (def { _line_color = bcl, _line_width = bw }) $ do +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 -- ----------------------------------------------------------------------- @@ -137,24 +140,24 @@ -- | Align the path by applying the given function on all points. alignPath :: (Point -> Point) -> Path -> Path -alignPath f = foldPath (\p -> moveTo $ f p) - (\p -> lineTo $ f p) - (\p -> arc $ f p) - (\p -> arcNeg $ f p) - (close) +alignPath f = foldPath (G.moveTo . f) + (lineTo . f) + (arc . f) + (arcNeg . f) + 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 @@ -162,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 @@ -170,38 +173,38 @@ -- | 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) -- | Create a path by connecting all points with a line. -- The path is not closed. stepPath :: [Point] -> Path -stepPath (p:ps) = moveTo p +stepPath (p:ps) = G.moveTo p <> mconcat (map lineTo ps) 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 -- ----------------------------------------------------------------------- @@ -210,14 +213,27 @@ -- | Draw a line of text that is aligned at a different anchor point. -- See 'drawText'. -drawTextA :: HTextAnchor -> VTextAnchor -> Point -> String -> ChartBackend () -drawTextA hta vta p s = drawTextR hta vta 0 p s +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)) + (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 @@ -230,17 +246,17 @@ -- 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 - _ -> do + _ -> withTranslation p $ withRotation theta $ do tss <- mapM textSize ss let ts = head tss - let widths = map textSizeWidth tss - maxw = maximum widths + let -- widths = map textSizeWidth tss + -- maxw = maximum widths maxh = maximum (map textSizeYBearing tss) gap = maxh / 2 -- half-line spacing totalHeight = fromIntegral num*maxh + @@ -253,11 +269,11 @@ ss = lines s num = length ss - drawT x y s = drawText (Point x y) s + drawT x y = drawText (Point x y) theta = angle*pi/180.0 - yinit VTA_Top ts height = textSizeAscent ts - yinit VTA_BaseLine ts height = 0 + yinit VTA_Top ts _ = textSizeAscent ts + yinit VTA_BaseLine _ _ = 0 yinit VTA_Centre ts height = height / 2 + textSizeAscent ts yinit VTA_Bottom ts height = height + textSizeAscent ts @@ -268,37 +284,42 @@ -- | Calculate the correct offset to align the horizontal anchor. adjustTextX :: HTextAnchor -> TextSize -> Double adjustTextX HTA_Left _ = 0 -adjustTextX HTA_Centre ts = (- (textSizeWidth ts / 2)) -adjustTextX HTA_Right ts = (- textSizeWidth ts) +adjustTextX HTA_Centre ts = - (textSizeWidth ts / 2) +adjustTextX HTA_Right ts = - textSizeWidth ts -- | Calculate the correct offset to align the vertical anchor. adjustTextY :: VTextAnchor -> TextSize -> Double adjustTextY VTA_Top ts = textSizeAscent ts -adjustTextY VTA_Centre ts = - (textSizeYBearing ts) / 2 +adjustTextY VTA_Centre ts = - textSizeYBearing ts / 2 adjustTextY VTA_BaseLine _ = 0 -adjustTextY VTA_Bottom ts = -(textSizeDescent ts) +adjustTextY VTA_Bottom ts = - textSizeDescent ts -- | 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 - let (w,h) = (textSizeWidth ts, textSizeHeight ts) - let lx = adjustTextX hta ts - let ly = adjustTextY vta ts - let (x',y') = (x + lx, y + ly) - let p1 = Point x' y' - let p2 = Point (x' + w) (y' + h) + -- This does not account for the pixel width of the label; e.g. + -- with a label "bread" and a large-enough foint size (e.g. 36) + -- I have seen the right-hand edge of the bounding box go through + -- the vertical part of the 'd' character (see chart-tests/tests/Test8.hs + -- and bump up the label size). + let (w,h,dh) = (textSizeWidth ts, textSizeHeight ts, textSizeDescent ts) + lx = adjustTextX hta ts + ly = adjustTextY vta ts + (x',y') = (x + lx, y + ly + dh) + p1 = Point x' (y' - h) + p2 = Point (x' + w) y' return $ Rect p1 p2 -- | 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 -- ----------------------------------------------------------------------- @@ -309,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 @@ -326,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 @@ -334,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 cl bcl bw 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 @@ -356,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] - (p:ps) = map (\a -> Point (x + r * sin a) - (y + r * cos a)) angles - let path = moveTo p <> mconcat (map lineTo ps) <> lineTo p + (p1:p1':p1s) = map (\a -> Point (x + r * sin a) + (y + r * cos a)) angles + let path = G.moveTo p1 <> mconcat (map lineTo $ p1':p1s) <> lineTo p1 <> lineTo p1' fillPath path strokePath path - PointShapePlus -> do + 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) @@ -382,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 @@ -409,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. @@ -417,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. @@ -427,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. @@ -436,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. @@ -444,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. @@ -463,8 +489,16 @@ 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 -solidFillStyle cl = FillStyleSolid cl +solidFillStyle = FillStyleSolid $( makeLenses ''PointStyle ) diff --git a/Graphics/Rendering/Chart/Easy.hs b/Graphics/Rendering/Chart/Easy.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Easy.hs @@ -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 + +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)) diff --git a/Graphics/Rendering/Chart/Geometry.hs b/Graphics/Rendering/Chart/Geometry.hs --- a/Graphics/Rendering/Chart/Geometry.hs +++ b/Graphics/Rendering/Chart/Geometry.hs @@ -1,3 +1,9 @@ +----------------------------------------------------------------------------- +-- | +-- 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(..) @@ -6,7 +12,7 @@ , RectSize , Range - + , pointToVec , mkrect @@ -14,6 +20,8 @@ , pvadd , pvsub , psub + , vangle + , vlen , vscale , within , intersectRect @@ -21,7 +29,7 @@ , RectEdge(..) , Limit(..) , PointMapFn - + -- * Paths , Path(..) , lineTo, moveTo @@ -29,10 +37,10 @@ , arc, arc' , arcNeg, arcNeg' , close - + , foldPath , makeLinesExplicit - + -- * Matrices , transformP, scaleP, rotateP, translateP , Matrix(..) @@ -43,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, @@ -61,21 +74,32 @@ 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)) +vscale c (Vector x y) = Vector (x*c) (y*c) -- | Add a point and a vector. pvadd :: Point -> Vector -> Point -pvadd (Point x1 y1) (Vector x2 y2) = (Point (x1+x2) (y1+y2)) +pvadd (Point x1 y1) (Vector x2 y2) = Point (x1+x2) (y1+y2) -- | Subtract a vector from a point. pvsub :: Point -> Vector -> Point -pvsub (Point x1 y1) (Vector x2 y2) = (Point (x1-x2) (y1-y2)) +pvsub (Point x1 y1) (Vector x2 y2) = Point (x1-x2) (y1-y2) -- | Subtract two points. psub :: Point -> Point -> Vector -psub (Point x1 y1) (Point x2 y2) = (Vector (x1-x2) (y1-y2)) +psub (Point x1 y1) (Point x2 y2) = Vector (x1-x2) (y1-y2) data Limit a = LMin | LValue a | LMax deriving Show @@ -109,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 @@ -124,16 +148,16 @@ -- | 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)) = - let p2 = (Point x1 y2) - p4 = (Point x2 y1) +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 -- ----------------------------------------------------------------------- @@ -141,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. @@ -189,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 @@ -205,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 @@ -237,23 +264,23 @@ -> m -- ^ Close -> Path -- ^ Path to fold -> m -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 +foldPath moveTo_ lineTo_ arc_ arcNeg_ close_ path = + let restF = foldPath moveTo_ lineTo_ arc_ arcNeg_ close_ + 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 + Close -> close_ -- | Enriches the path with explicit instructions to draw lines, -- 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 @@ -261,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 -- ----------------------------------------------------------------------- @@ -303,13 +330,16 @@ -- | Copied from Graphics.Rendering.Cairo.Matrix instance Num Matrix where - (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') = - Matrix (xx * xx' + yx * xy') - (xx * yx' + yx * yy') - (xy * xx' + yy * xy') - (xy * yx' + yy * yy') - (x0 * xx' + y0 * xy' + x0') - (x0 * yx' + y0 * yy' + y0') + -- use underscore to avoid ghc complaints about shadowing the Matrix + -- field names + (*) (Matrix xx_ yx_ xy_ yy_ x0_ y0_) + (Matrix xx'_ yx'_ xy'_ yy'_ x0'_ y0'_) = + Matrix (xx_ * xx'_ + yx_ * xy'_) + (xx_ * yx'_ + yx_ * yy'_) + (xy_ * xx'_ + yy_ * xy'_) + (xy_ * yx'_ + yy_ * yy'_) + (x0_ * xx'_ + y0_ * xy'_ + x0'_) + (x0_ * yx'_ + y0_ * yy'_ + y0'_) (+) = pointwise2 (+) (-) = pointwise2 (-) @@ -317,18 +347,20 @@ 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 f (Matrix xx yx xy yy x0 y0) = - Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0) +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_) -- | Copied from Graphics.Rendering.Cairo.Matrix {-# INLINE pointwise2 #-} -pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') = - Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0') +pointwise2 :: (Double -> Double -> Double) -> Matrix -> Matrix -> Matrix +pointwise2 f (Matrix xx_ yx_ xy_ yy_ x0_ y0_) (Matrix xx'_ yx'_ xy'_ yy'_ x0'_ y0'_) = + Matrix (f xx_ xx'_) (f yx_ yx'_) (f xy_ xy'_) (f yy_ yy'_) (f x0_ x0'_) (f y0_ y0'_) -- | Copied from Graphics.Rendering.Cairo.Matrix identity :: Matrix @@ -336,16 +368,16 @@ -- | Copied and adopted from Graphics.Rendering.Cairo.Matrix translate :: Vector -> Matrix -> Matrix -translate tv m = m * (Matrix 1 0 0 1 (v_x tv) (v_y tv)) +translate tv m = m * Matrix 1 0 0 1 (v_x tv) (v_y tv) -- | Copied and adopted from Graphics.Rendering.Cairo.Matrix scale :: Vector -> Matrix -> Matrix -scale sv m = m * (Matrix (v_x sv) 0 0 (v_y sv) 0 0) +scale sv m = m * Matrix (v_x sv) 0 0 (v_y sv) 0 0 -- | Copied from Graphics.Rendering.Cairo.Matrix -- Rotations angle is given in radians. rotate :: Double -> Matrix -> Matrix -rotate r m = m * (Matrix c s (-s) c 0 0) +rotate r m = m * Matrix c s (-s) c 0 0 where s = sin r c = cos r @@ -360,17 +392,5 @@ -- | Copied from Graphics.Rendering.Cairo.Matrix invert :: Matrix -> Matrix -invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m - where det = xx*yy - yx*xy - - - - - - - - - - - - +invert m@(Matrix xx_ yx_ xy_ yy_ _ _) = scalarMultiply (recip det) $ adjoint m + where det = xx_*yy_ - yx_*xy_ diff --git a/Graphics/Rendering/Chart/Grid.hs b/Graphics/Rendering/Chart/Grid.hs --- a/Graphics/Rendering/Chart/Grid.hs +++ b/Graphics/Rendering/Chart/Grid.hs @@ -1,14 +1,14 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Grid --- Copyright : (c) Tim Docker 2010 +-- Copyright : (c) Tim Docker 2010, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- A container type for values that can be composed by horizonal -- and vertical layout. module Graphics.Rendering.Chart.Grid ( - Grid, Span, + Grid, Span, SpaceWeight, tval, tspan, empty, nullt, (.|.), (./.), @@ -26,18 +26,12 @@ fullOverlayOver ) where -import Data.List import Data.Array import Control.Monad -import Control.Monad.Trans -import Numeric import Graphics.Rendering.Chart.Renderable -import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Geometry hiding (x0, y0) import Graphics.Rendering.Chart.Drawing -import Data.Colour -import Data.Colour.Names - type Span = (Int,Int) type Size = (Int,Int) @@ -67,17 +61,17 @@ width Null = 0 width Empty = 1 width (Value _) = 1 -width (Beside _ _ (w,h)) = w -width (Above _ _ (w,h)) = w -width (Overlay _ _ (w,h)) = w +width (Beside _ _ (w,_)) = w +width (Above _ _ (w,_)) = w +width (Overlay _ _ (w,_)) = w height :: Grid a -> Int height Null = 0 height Empty = 1 height (Value _) = 1 -height (Beside _ _ (w,h)) = h -height (Above _ _ (w,h)) = h -height (Overlay _ _ (w,h)) = h +height (Beside _ _ (_,h)) = h +height (Above _ _ (_,h)) = h +height (Overlay _ _ (_,h)) = h -- | A 1x1 grid from a given value, with no extra space. tval :: a -> Grid a @@ -85,7 +79,7 @@ -- | A WxH (measured in cells) grid from a given value, with space weight (1,1). tspan :: a -> Span -> Grid a -tspan a span = Value (a,span,(1,1)) +tspan a spn = Value (a,spn,(1,1)) -- | A 1x1 empty grid. empty :: Grid a @@ -103,30 +97,30 @@ -- | A value occupying 1 row with the same horizontal span as the grid. wideAbove :: a -> Grid a -> Grid a -wideAbove a g = (weights (0,0) $ tspan a (width g,1)) `above` g +wideAbove a g = weights (0,0) (tspan a (width g,1)) `above` g -- | A value placed below the grid, occupying 1 row with the same -- horizontal span as the grid. aboveWide :: Grid a -> a -> Grid a -aboveWide g a = g `above` (weights (0,0) $ tspan a (width g,1)) +aboveWide g a = g `above` weights (0,0) (tspan a (width g,1)) -- | A value placed to the left of the grid, occupying 1 column with -- the same vertical span as the grid. tallBeside :: a -> Grid a -> Grid a -tallBeside a g = (weights (0,0) $ tspan a (1,height g)) `beside` g +tallBeside a g = weights (0,0) (tspan a (1,height g)) `beside` g -- | A value placed to the right of the grid, occupying 1 column with -- the same vertical span as the grid. besideTall :: Grid a -> a -> Grid a -besideTall g a = g `beside` (weights (0,0) $ tspan a (1,height g)) +besideTall g a = g `beside` weights (0,0) (tspan a (1,height g)) -- | A value placed under a grid, with the same span as the grid. fullOverlayUnder :: a -> Grid a -> Grid a -fullOverlayUnder a g = g `overlay` (tspan a (width g,height g)) +fullOverlayUnder a g = g `overlay` tspan a (width g,height g) -- | A value placed over a grid, with the same span as the grid. fullOverlayOver :: a -> Grid a -> Grid a -fullOverlayOver a g = (tspan a (width g,height g)) `overlay` g +fullOverlayOver a g = tspan a (width g,height g) `overlay` g beside Null t = t beside t Null = t @@ -154,8 +148,8 @@ -- | Sets the space weight of *every* cell of the grid to given value. weights :: SpaceWeight -> Grid a -> Grid a -weights sw Null = Null -weights sw Empty = Empty +weights _ Null = Null +weights _ Empty = Empty weights sw (Value (v,sp,_)) = Value (v,sp,sw) weights sw (Above t1 t2 sz) = Above (weights sw t1) (weights sw t2) sz weights sw (Beside t1 t2 sz) = Beside (weights sw t1) (weights sw t2) sz @@ -165,27 +159,27 @@ -- than ./. and .//. instance Functor Grid where - fmap f (Value (a,span,ew)) = Value (f a,span,ew) + fmap f (Value (a,spn,ew)) = Value (f a,spn,ew) fmap f (Above t1 t2 s) = Above (fmap f t1) (fmap f t2) s fmap f (Beside t1 t2 s) = Beside (fmap f t1) (fmap f t2) s fmap f (Overlay t1 t2 s) = Overlay (fmap f t1) (fmap f t2) s - fmap f Empty = Empty - fmap f Null = Null + fmap _ Empty = Empty + fmap _ Null = Null mapGridM :: Monad m => (a -> m b) -> Grid a -> m (Grid b) -mapGridM f (Value (a,span,ew)) = do b <- f a - return (Value (b,span,ew)) -mapGridM f (Above t1 t2 s) = do t1' <- mapGridM f t1 - t2' <- mapGridM f t2 - return (Above t1' t2' s) -mapGridM f (Beside t1 t2 s) = do t1' <- mapGridM f t1 - t2' <- mapGridM f t2 - return (Beside t1' t2' s) -mapGridM f (Overlay t1 t2 s) = do t1' <- mapGridM f t1 - t2' <- mapGridM f t2 - return (Overlay t1' t2' s) -mapGridM _ Empty = return Empty -mapGridM _ Null = return Null +mapGridM f (Value (a,spn,ew)) = do b <- f a + return (Value (b,spn,ew)) +mapGridM f (Above t1 t2 s) = do t1' <- mapGridM f t1 + t2' <- mapGridM f t2 + return (Above t1' t2' s) +mapGridM f (Beside t1 t2 s) = do t1' <- mapGridM f t1 + t2' <- mapGridM f t2 + return (Beside t1' t2' s) +mapGridM f (Overlay t1 t2 s) = do t1' <- mapGridM f t1 + t2' <- mapGridM f t2 + return (Overlay t1' t2' s) +mapGridM _ Empty = return Empty +mapGridM _ Null = return Null ---------------------------------------------------------------------- type FlatGrid a = Array (Int,Int) [(a,Span,SpaceWeight)] @@ -197,21 +191,21 @@ type FlatEl a = ((Int,Int),Cell a) flatten2 :: (Int,Int) -> Grid a -> [FlatEl a] -> [FlatEl a] -flatten2 i Empty els = els -flatten2 i Null els = els +flatten2 _ Empty els = els +flatten2 _ Null els = els flatten2 i (Value cell) els = (i,cell):els -flatten2 i@(x,y) (Above t1 t2 size) els = (f1.f2) els +flatten2 i@(x,y) (Above t1 t2 _) els = (f1.f2) els where f1 = flatten2 i t1 f2 = flatten2 (x,y + height t1) t2 -flatten2 i@(x,y) (Beside t1 t2 size) els = (f1.f2) els +flatten2 i@(x,y) (Beside t1 t2 _) els = (f1.f2) els where f1 = flatten2 i t1 f2 = flatten2 (x + width t1, y) t2 -flatten2 i@(x,y) (Overlay t1 t2 size) els = (f1.f2) els +flatten2 i (Overlay t1 t2 _) els = (f1.f2) els where f1 = flatten2 i t1 f2 = flatten2 i t2 @@ -219,14 +213,14 @@ foldT :: ((Int,Int) -> Cell a -> r -> r) -> r -> FlatGrid a -> r foldT f iv ft = foldr f' iv (assocs ft) where - f' (i,vs) r = foldr (\cell -> f i cell) r vs + f' (i,vs) r = foldr (f i) r vs ---------------------------------------------------------------------- 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') @@ -238,53 +232,53 @@ (foldT (ef ywf snd) [] szs') return (widths,heights,xweights,yweights) where - wf (x,y) (w,h) (ww,wh) = (x,w) - hf (x,y) (w,h) (ww,wh) = (y,h) - xwf (x,y) (w,h) (xw,yw) = (x,xw) - ywf (x,y) (w,h) (xw,yw) = (y,yw) + wf (x,_) (w,_) _ = (x,w) + hf (_,y) (_,h) _ = (y,h) + xwf (x,_) _ (xw,_) = (x,xw) + ywf (_,y) _ (_,yw) = (y,yw) - ef f ds loc (size,span,ew) r | ds span == 1 = (f loc size ew:r) - | otherwise = r + ef f ds loc (size,spn,ew) r | ds spn == 1 = f loc size ew:r + | otherwise = r instance (ToRenderable a) => ToRenderable (Grid a) where toRenderable = gridToRenderable . fmap toRenderable gridToRenderable :: Grid (Renderable a) -> Renderable a -gridToRenderable t = Renderable minsizef renderf +gridToRenderable gt = Renderable minsizef renderf where - minsizef :: ChartBackend RectSize + minsizef :: BackendProgram RectSize minsizef = do - (widths, heights, xweights, yweights) <- getSizes t + (widths, heights, _, _) <- getSizes gt return (sum (elems widths), sum (elems heights)) renderf (w,h) = do - (widths, heights, xweights, yweights) <- getSizes t + (widths, heights, xweights, yweights) <- getSizes gt let widths' = addExtraSpace w widths xweights let heights' = addExtraSpace h heights yweights let borders = (ctotal widths',ctotal heights') - rf1 borders (0,0) t + rf1 borders (0,0) gt -- (x borders, y borders) -> (x,y) -> grid -> drawing rf1 borders loc@(i,j) t = case t of Null -> return nullPickFn Empty -> return nullPickFn - (Value (r,span,_)) -> do - let (Rect p0 p1) = mkRect borders loc span - p0'@(Point x0 y0) <- alignFillPoint p0 - p1'@(Point x1 y1) <- alignFillPoint p1 + (Value (r,spn,_)) -> do + let (Rect p0 p1) = mkRect borders loc spn + (Point x0 y0) <- alignFillPoint p0 + (Point x1 y1) <- alignFillPoint p1 withTranslation (Point x0 y0) $ do pf <- render r (x1-x0,y1-y0) return (newpf pf x0 y0) (Above t1 t2 _) -> do pf1 <- rf1 borders (i,j) t1 pf2 <- rf1 borders (i,j+height t1) t2 - let pf p@(Point x y) = if y < (snd borders ! (j + height t1)) + let pf p@(Point _ y) = if y < (snd borders ! (j + height t1)) then pf1 p else pf2 p return pf (Beside t1 t2 _) -> do pf1 <- rf1 borders (i,j) t1 pf2 <- rf1 borders (i+width t1,j) t2 - let pf p@(Point x y) = if x < (fst borders ! (i + width t1)) + let pf p@(Point x _) = if x < (fst borders ! (i + width t1)) then pf1 p else pf2 p return pf (Overlay t1 t2 _) -> do @@ -293,7 +287,7 @@ let pf p = pf1 p `mplus` pf2 p return pf - newpf pf x0 y0 = \ (Point x1 y1)-> pf (Point (x1-x0) (y1-y0)) + newpf pf x0 y0 (Point x1 y1) = pf (Point (x1-x0) (y1-y0)) -- (x borders, y borders) -> (x,y) -> (w,h) -- -> rectangle of grid[x..x+w, y..y+h] @@ -304,17 +298,17 @@ y1 = cheights ! y x2 = cwidths ! min (x+w) (snd $ bounds cwidths) y2 = cheights ! min (y+h) (snd $ bounds cheights) - mx = fst (bounds cwidths) - my = fst (bounds cheights) + -- mx = fst (bounds cwidths) + -- my = fst (bounds cheights) -- total size -> item sizes -> item weights -> new item sizes such that -- their sum == total size, and added size is proportional to weight addExtraSpace :: Double -> DArray -> DArray -> DArray - addExtraSpace size sizes weights = + addExtraSpace size sizes weights' = if totalws == 0 then sizes else listArray (bounds sizes) sizes' where - ws = elems weights + ws = elems weights' totalws = sum ws extra = size - sum (elems sizes) extras = map (*(extra/totalws)) ws diff --git a/Graphics/Rendering/Chart/Layout.hs b/Graphics/Rendering/Chart/Layout.hs --- a/Graphics/Rendering/Chart/Layout.hs +++ b/Graphics/Rendering/Chart/Layout.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Layout --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- This module glues together axes and plots to actually create a renderable @@ -11,50 +11,45 @@ -- (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(..) , StackedLayouts(..) , 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 @@ -69,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 @@ -86,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 @@ -102,8 +110,7 @@ import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Grid import Control.Monad -import Control.Monad.Reader (local) -import Control.Lens +import Control.Lens hiding (at) import Data.Colour import Data.Colour.Names (white) import Data.Default.Class @@ -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 l = fillBackground (_layout_background l) - $ gridToRenderable (layoutToGrid l) +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 + 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) @@ -229,9 +242,9 @@ renderLegend l legItems = gridToRenderable g where g = besideN [ tval $ mkLegend (_layout_legend l) (_layout_margin l) legItems - , weights (1,1) $ tval $ emptyRenderable ] + , 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)) @@ -244,8 +257,8 @@ lge_margin = _layout_margin l } where - xvals = [ x | p <- (_layout_plots l), x <- fst $ _plot_all_points p] - yvals = [ y | p <- (_layout_plots l), y <- snd $ _plot_all_points p] + xvals = [ x | p <- _layout_plots l, x <- fst $ _plot_all_points p] + yvals = [ y | p <- _layout_plots l, y <- snd $ _plot_all_points p] bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layout_x_axis _layout_bottom_axis_visibility) xvals tAxis = mkAxis E_Top (overrideAxisVisibility l _layout_x_axis _layout_top_axis_visibility ) xvals @@ -253,21 +266,21 @@ rAxis = mkAxis E_Right (overrideAxisVisibility l _layout_y_axis _layout_right_axis_visibility ) yvals axes = (bAxis,lAxis,tAxis,rAxis) - plotsToRenderable l = Renderable { + plotsToRenderable lxy = Renderable { minsize = return (0,0), - render = renderPlots l + render = renderPlots lxy } -- | 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 l sz@(w,h) = do - when (not (_layout_grid_last l)) (renderGrids sz axes) - withClipRegion (Rect (Point 0 0) (Point w h)) $ do - mapM_ rPlot (_layout_plots l) - when (_layout_grid_last l) (renderGrids sz axes) + 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)) $ + mapM_ rPlot (_layout_plots lxy) + when (_layout_grid_last lxy) (renderGrids sz axes) return pickfn where - rPlot p = renderSinglePlot sz bAxis lAxis p + rPlot = renderSinglePlot sz bAxis lAxis xr = (0, w) yr = (h, 0) @@ -286,10 +299,10 @@ (Just at,_) -> Just at (_,Just at) -> Just at (Nothing,Nothing) -> Nothing - mapx (AxisT _ _ rev ad) x = _axis_tropweiv ad (optPairReverse rev xr) x - mapy (AxisT _ _ rev ad) y = _axis_tropweiv ad (optPairReverse rev yr) y + 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,18 +384,20 @@ 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 l = fillBackground (_layoutlr_background l) +layoutLRToRenderable l = fillBackground (_layoutlr_background l) $ gridToRenderable (layoutLRToGrid l) - 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) - ] +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] @@ -396,8 +411,8 @@ -- Left and right plot legend items are still separated. getLegendItemsLR :: LayoutLR x yl yr -> ([LegendItem],[LegendItem]) getLegendItemsLR l = ( - concat [ _plot_legend p | (Left p ) <- (_layoutlr_plots l) ], - concat [ _plot_legend p | (Right p) <- (_layoutlr_plots l) ] + concat [ _plot_legend p | (Left p ) <- _layoutlr_plots l ], + concat [ _plot_legend p | (Right p) <- _layoutlr_plots l ] ) -- | Render the given 'LegendItem's for a 'LayoutLR'. @@ -405,12 +420,12 @@ renderLegendLR l (lefts,rights) = gridToRenderable g where g = besideN [ tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) lefts - , weights (1,1) $ tval $ emptyRenderable + , weights (1,1) $ tval emptyRenderable , tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) rights ] - lm = _layoutlr_margin l + -- 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,24 +440,24 @@ ++ [ 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 rAxis = mkAxis E_Right (overrideAxisVisibility l _layoutlr_right_axis _layoutlr_right_axis_visibility) yvalsR axes = (bAxis,lAxis,tAxis,rAxis) - plotsToRenderable l = Renderable { + plotsToRenderable llr = Renderable { minsize = return (0,0), - render = renderPlots l + render = renderPlots llr } - renderPlots :: LayoutLR x yl yr -> RectSize -> ChartBackend (PickFn (LayoutPick x yl yr)) - renderPlots l sz@(w,h) = do - when (not (_layoutlr_grid_last l)) (renderGrids sz axes) - withClipRegion (Rect (Point 0 0) (Point w h)) $ do - mapM_ rPlot (_layoutlr_plots l) - when (_layoutlr_grid_last l) (renderGrids sz axes) + 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)) $ + mapM_ rPlot (_layoutlr_plots llr) + when (_layoutlr_grid_last llr) (renderGrids sz axes) return pickfn where rPlot (Left p) = renderSinglePlot sz bAxis lAxis p @@ -463,8 +478,8 @@ myats = case (lAxis,rAxis) of (Just at1,Just at2) -> Just (at1,at2) (_,_) -> Nothing - mapx (AxisT _ _ rev ad) x = _axis_tropweiv ad (optPairReverse rev xr) x - mapy (AxisT _ _ rev ad) y = _axis_tropweiv ad (optPairReverse rev yr) y + mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr) + mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr) ---------------------------------------------------------------------- @@ -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,12 +521,12 @@ where g = fullOverlayUnder (fillBackground bg emptyRenderable) $ foldr (above.mkGrid) nullt (zip sls [0,1..]) - + mkGrid :: (StackedLayout x, Int) -> Grid (Renderable ()) mkGrid (sl, i) = titleR `wideAbove` - (addMarginsToGrid (lm,lm,lm,lm) $ mkPlotArea usedAxis) + addMarginsToGrid (lm,lm,lm,lm) (mkPlotArea usedAxis) `aboveWide` (if showLegend then legendR else emptyRenderable) where @@ -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, []) - lebendItems (StackedLayoutLR l) = getLegendItemsLR 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 [ @@ -589,13 +606,13 @@ rs = tval $ spacer (r,0) titleToRenderable :: Double -> FontStyle -> String -> Renderable (LayoutPick x yl yr) -titleToRenderable lm fs "" = emptyRenderable +titleToRenderable _ _ "" = emptyRenderable titleToRenderable lm fs s = addMargins (lm/2,0,0,0) (mapPickFn LayoutPick_Title title) where title = label fs HTA_Centre VTA_Centre s mkLegend :: Maybe LegendStyle -> Double -> [LegendItem] -> Renderable (LayoutPick x yl yr) -mkLegend ls lm vals = case ls of +mkLegend mls lm vals = case mls of Nothing -> emptyRenderable Just ls -> case filter ((/="").fst) vals of [] -> emptyRenderable ; @@ -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), @@ -629,20 +646,20 @@ , besideN [er, er, er, btitle, er, er, er ] ] - er = tval $ emptyRenderable + er = tval emptyRenderable plots = tval $ lge_plots lge - (tdata,tlbl,tstyle) = lge_taxis lge + (tdata,_,_) = lge_taxis lge (bdata,blbl,bstyle) = lge_baxis lge (ldata,llbl,lstyle) = lge_laxis lge (rdata,rlbl,rstyle) = lge_raxis lge - (ttitle,_) = mktitle HTA_Centre VTA_Bottom 0 tlbl tstyle LayoutPick_XTopAxisTitle + -- (ttitle,_) = mktitle HTA_Centre VTA_Bottom 0 tlbl tstyle LayoutPick_XTopAxisTitle (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,19 +674,19 @@ 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 (label,gap) + mktitle ha va rot lbl style pf = if lbl == "" then (er,er) else (labelG,gapG) where - label = tval $ mapPickFn pf $ rlabel style ha va rot lbl - gap = tval $ spacer (lge_margin lge,0) + labelG = tval $ mapPickFn pf $ rlabel style ha va rot lbl + 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,20 +699,20 @@ -- | 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 (w, h) (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p = +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) - yrange = if yrev then (0, h) else (h, 0) + -- yrange = if yrev then (0, h) else (h, 0) pmfn (x,y) = Point (mapv xr (_axis_viewport xaxis xr) x) (mapv yr (_axis_viewport yaxis yr) y) - mapv (min,max) _ LMin = min - mapv (min,max) _ LMax = max - mapv _ f (LValue v) = f v + mapv lims _ LMin = fst lims + mapv lims _ LMax = snd lims + mapv _ f (LValue v) = f v 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,27 +721,27 @@ 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 - adata = (_laxis_override laxis) (_laxis_generate laxis vals) + adata = _laxis_override laxis (_laxis_generate laxis vals) vis = _axis_visibility adata 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 = selVis ly }) + 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) diff --git a/Graphics/Rendering/Chart/Legend.hs b/Graphics/Rendering/Chart/Legend.hs --- a/Graphics/Rendering/Chart/Legend.hs +++ b/Graphics/Rendering/Chart/Legend.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Legend --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Types and functions for handling the legend(s) on a chart. A legend @@ -12,22 +12,21 @@ Legend(..), LegendStyle(..), LegendOrientation(..), - defaultLegendStyle, + LegendPosition(..), legendToRenderable, legend_label_style, legend_margin, legend_plot_size, - legend_orientation + legend_orientation, + legend_position ) where -import Control.Monad -import Data.List (nub, partition,intersperse) +import Data.List (partition,intersperse) import Control.Lens import Data.Default.Class import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Plot.Types import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Grid @@ -38,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 @@ -46,62 +46,79 @@ -- 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 = aboveN.(intersperse ggap1) - besideG = besideN.(intersperse ggap1) + 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 rfn = tval $ Renderable { + + rp :: (Rect -> BackendProgram ()) -> Grid (Renderable String) + rp rfn = tval Renderable { minsize = return (_legend_plot_size ls, 0), - render = \(w,h) -> do - rfn (Rect (Point 0 0) (Point w h)) + 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 s = label (_legend_label_style ls) HTA_Left VTA_Centre s + lbl :: String -> Renderable String + lbl = label (_legend_label_style ls) HTA_Left VTA_Centre + groups :: Int -> [a] -> [[a]] -groups n [] = [] -groups n vs = let (vs1,vs2) = splitAt n vs in vs1:groups n vs2 +groups _ [] = [] +groups n vs = let (vs1,vs2) = splitAt n vs in vs1:groups n vs2 join_nub :: [(String, a)] -> [(String, [a])] join_nub ((x,a1):ys) = case partition ((==x) . fst) ys of (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 ) diff --git a/Graphics/Rendering/Chart/Plot.hs b/Graphics/Rendering/Chart/Plot.hs --- a/Graphics/Rendering/Chart/Plot.hs +++ b/Graphics/Rendering/Chart/Plot.hs @@ -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 diff --git a/Graphics/Rendering/Chart/Plot/Annotation.hs b/Graphics/Rendering/Chart/Plot/Annotation.hs --- a/Graphics/Rendering/Chart/Plot/Annotation.hs +++ b/Graphics/Rendering/Chart/Plot/Annotation.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Annotation --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Show textual annotations on a chart. @@ -10,71 +10,92 @@ 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.Colour (opaque) -import Data.Colour.Names (black, blue) -import Data.Colour.SRGB (sRGB) -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 --- can be rotated and styled. Rotation angle is given in degrees, --- rotation is performend around the anchor point. +-- can be rotated and styled. data PlotAnnotation x y = PlotAnnotation { _plot_annotation_hanchor :: HTextAnchor, _plot_annotation_vanchor :: VTextAnchor, _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 (\(x,_,_)->x) vs , map (\(_,y,_)->y) 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 $ do +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 ) diff --git a/Graphics/Rendering/Chart/Plot/AreaSpots.hs b/Graphics/Rendering/Chart/Plot/AreaSpots.hs --- a/Graphics/Rendering/Chart/Plot/AreaSpots.hs +++ b/Graphics/Rendering/Chart/Plot/AreaSpots.hs @@ -11,48 +11,36 @@ module Graphics.Rendering.Chart.Plot.AreaSpots ( AreaSpots(..) - , defaultAreaSpots , area_spots_title , area_spots_linethick , area_spots_linecolour , area_spots_fillcolour + , area_spots_opacity , area_spots_max_radius , area_spots_values , AreaSpots4D(..) - , defaultAreaSpots4D , area_spots_4d_title , area_spots_4d_linethick , area_spots_4d_palette + , area_spots_4d_opacity , area_spots_4d_max_radius , area_spots_4d_values ) where -import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Geometry hiding (scale, x0, y0) import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Plot.Types import Graphics.Rendering.Chart.Axis import Control.Lens -import Data.Colour +import Data.Colour hiding (over) import Data.Colour.Names import Data.Default.Class import Control.Monad - --- stuff that belongs in Data.Tuple -fst3 (a,_,_) = a -snd3 (_,a,_) = a -thd3 (_,_,a) = a - -fst4 (a,_,_,_) = a -snd4 (_,a,_,_) = a -thd4 (_,_,a,_) = a -fth4 (_,_,_,a) = a - - -- | A collection of unconnected spots, with x,y position, and an -- independent z value to be represented by the area of the spot. data AreaSpots z x y = AreaSpots @@ -61,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 = "" @@ -83,13 +67,13 @@ instance (PlotValue z) => ToPlot (AreaSpots z) where toPlot p = Plot { _plot_render = renderAreaSpots p , _plot_legend = [(_area_spots_title p, renderSpotLegend p)] - , _plot_all_points = ( map fst3 (_area_spots_values p) - , map snd3 (_area_spots_values p) ) + , _plot_all_points = ( map (^._1) (_area_spots_values p) + , 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) + forM_ (scaleMax (_area_spots_max_radius p^(2::Integer)) (_area_spots_values p)) (\ (x,y,z)-> do let radius = sqrt z @@ -105,23 +89,21 @@ ) where scaleMax :: PlotValue z => Double -> [(x,y,z)] -> [(x,y,Double)] - scaleMax n points = let largest = maximum (map (toValue . thd3) points) + scaleMax n points = let largest = maximum (map (^._3.to toValue) points) scale v = n * toValue v / largest - in map (\ (x,y,z) -> (x,y, scale z)) points + in over (mapped._3) scale points -renderSpotLegend :: AreaSpots z x y -> Rect -> ChartBackend () -renderSpotLegend p r@(Rect p1 p2) = do +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 - let psSpot = filledCircles radius $ - flip withOpacity - (_area_spots_opacity p) $ - _area_spots_fillcolour p - drawPoint psSpot centre - let psSpot = hollowCircles radius - (_area_spots_linethick p) - (_area_spots_linecolour p) + psSpot = filledCircles radius $ withOpacity + (_area_spots_fillcolour p) + (_area_spots_opacity p) + psOutline = hollowCircles radius (_area_spots_linethick p) + (_area_spots_linecolour p) drawPoint psSpot centre + drawPoint psOutline centre where linearInterpolate (Point x0 y0) (Point x1 y1) = Point (x0 + abs(x1-x0)/2) (y0 + abs(y1-y0)/2) @@ -136,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 = "" @@ -158,22 +136,22 @@ toPlot p = Plot { _plot_render = renderAreaSpots4D p , _plot_legend = [ (_area_spots_4d_title p , renderSpotLegend4D p) ] - , _plot_all_points = ( map fst4 (_area_spots_4d_values p) - , map snd4 (_area_spots_4d_values p) ) + , _plot_all_points = ( map (^._1) (_area_spots_4d_values p) + , map (^._2) (_area_spots_4d_values p) ) } 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) + forM_ (scaleMax (_area_spots_4d_max_radius p^(2::Integer)) (length (_area_spots_4d_palette p)) (_area_spots_4d_values p)) (\ (x,y,z,t)-> do let radius = sqrt z - let colour = (_area_spots_4d_palette p) !! t + let colour = _area_spots_4d_palette p !! t let psSpot = filledCircles radius $ - flip withOpacity (_area_spots_4d_opacity p) $ colour + withOpacity colour (_area_spots_4d_opacity p) drawPoint psSpot (pmap (LValue x, LValue y)) let psOutline = hollowCircles radius (_area_spots_4d_linethick p) @@ -183,9 +161,9 @@ where scaleMax :: (PlotValue z, PlotValue t, Show t) => Double -> Int -> [(x,y,z,t)] -> [(x,y,Double,Int)] - scaleMax n c points = let largest = maximum (map (toValue . thd4) points) + scaleMax n c points = let largest = maximum (map (^._3.to toValue) points) scale v = n * toValue v / largest - colVals = map (toValue . fth4) points + colVals = map (^._4.to toValue) points colMin = minimum colVals colMax = maximum colVals select t = min (c-1) $ @@ -195,19 +173,16 @@ in map (\ (x,y,z,t) -> (x,y, scale z, select t)) points -renderSpotLegend4D :: AreaSpots4D z t x y -> Rect -> ChartBackend () -renderSpotLegend4D p r@(Rect p1 p2) = do +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 - let psSpot = filledCircles radius $ - flip withOpacity - (_area_spots_4d_opacity p) $ - head $ _area_spots_4d_palette p + palCol = head $ _area_spots_4d_palette p + psSpot = filledCircles radius $ withOpacity palCol + (_area_spots_4d_opacity p) + psOutline = hollowCircles radius (_area_spots_4d_linethick p) + (opaque palCol) drawPoint psSpot centre - let psOutline = hollowCircles radius - (_area_spots_4d_linethick p) - (opaque $ - head (_area_spots_4d_palette p)) drawPoint psOutline centre where linearInterpolate (Point x0 y0) (Point x1 y1) = diff --git a/Graphics/Rendering/Chart/Plot/Bars.hs b/Graphics/Rendering/Chart/Plot/Bars.hs --- a/Graphics/Rendering/Chart/Plot/Bars.hs +++ b/Graphics/Rendering/Chart/Plot/Bars.hs @@ -1,57 +1,84 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Bars --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- 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.Colour (opaque) +import Data.Colour.Names (black) +import Data.Default.Class +import Data.Tuple(swap) import Data.List(nub,sort) -import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Geometry hiding (x0, y0) import Graphics.Rendering.Chart.Plot.Types -import Graphics.Rendering.Chart.Axis -import Data.Colour (opaque) -import Data.Colour.Names (black, blue) -import Data.Colour.SRGB (sRGB) -import Data.Default.Class - +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. @@ -73,154 +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,_)) -> do - withFillStyle fstyle $ do - p <- alignFillPath (barPath (offset i) x yref0 y) - fillPath p - forM_ (zip3 [0,1..] ys styles) $ \(i, y, (_,mlstyle)) -> do - whenJust mlstyle $ \lstyle -> do - withLineStyle lstyle $ do - p <- alignStrokePath (barPath (offset i) x yref0 y) - strokePath p + 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..] vs styles) $ \(i, (v, _), (_,mlstyle)) -> + unless (barsIsNull v) $ + whenJust mlstyle $ \lstyle -> + withLineStyle lstyle $ + alignStrokePath (barPath (offset i) k vref0 v) + >>= strokePath + 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 - 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 + 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 -> -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 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 - stackedBars (x,ys) = do - let y2s = zip (yref0:stack ys) (stack ys) - let ofs = case (_plot_bars_alignment p) of { - BarsLeft -> 0 ; - BarsRight -> (-width) ; - BarsCentered -> (-width/2) - } - forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> do - withFillStyle fstyle $ do - p <- alignFillPath (barPath ofs x y0 y1) - fillPath p - forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> do - whenJust mlstyle $ \lstyle -> do - withLineStyle lstyle $ do - p <- alignStrokePath (barPath ofs x y0 y1) - strokePath p + styles = _bars_settings_item_styles p - 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')) + barPath os k v0 v1 = rectPath $ r os bsize k v0 v1 - 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 + 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 + BarsFixWidth width' -> width' - 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 | (x,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 -stack :: (BarsPlotValue y) => [y] -> [y] -stack ys = scanl1 barsAdd ys +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,mlstyle) r@(Rect p1 p2) = do - withFillStyle fstyle $ do +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 diff --git a/Graphics/Rendering/Chart/Plot/Candle.hs b/Graphics/Rendering/Chart/Plot/Candle.hs --- a/Graphics/Rendering/Chart/Plot/Candle.hs +++ b/Graphics/Rendering/Chart/Plot/Candle.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Candle --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Candlestick charts for financial plotting @@ -11,7 +11,6 @@ module Graphics.Rendering.Chart.Plot.Candle( PlotCandle(..), Candle(..), - defaultPlotCandle, plot_candle_title, plot_candle_line_style, @@ -24,17 +23,14 @@ plot_candle_values, ) where -import Control.Lens -import Data.Monoid +import Control.Lens hiding (op) -import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Geometry hiding (close) import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types import Control.Monad import Data.Colour (opaque) -import Data.Colour.Names (black, white, blue) -import Data.Colour.SRGB (sRGB) +import Data.Colour.Names (white, blue) import Data.Default.Class -- | Value defining a financial interval: opening and closing prices, with @@ -77,8 +73,8 @@ where pts = _plot_candle_values p -renderPlotCandle :: PlotCandle x y -> PointMapFn x y -> ChartBackend () -renderPlotCandle p pmap = do +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) = @@ -90,6 +86,7 @@ (Point _ hi') = pmap' (x,hi) pmap' = mapXY pmap +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 @@ -98,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) $ do + else _plot_candle_fall_fill_style ps) $ fillPath $ moveTo' (x-wd) open <> lineTo' (x-wd) close <> lineTo' (x+wd) close @@ -121,29 +118,25 @@ <> lineTo' (x+tl) lo <> moveTo' (x-tl) hi <> lineTo' (x+tl) hi - - when (ct > 0) $ do strokePath $ moveTo' (x-ct) mid - <> lineTo' (x+ct) mid -renderPlotLegendCandle :: PlotCandle x y -> Rect -> ChartBackend () -renderPlotLegendCandle p r@(Rect p1 p2) = do - drawCandle p{ _plot_candle_width = 2} - (Candle ((p_x p1 + p_x p2)*1/4) lo open mid close hi) - drawCandle p{ _plot_candle_width = 2} - (Candle ((p_x p1 + p_x p2)*2/3) lo close mid open hi) + when (ct > 0) $ strokePath $ moveTo' (x-ct) mid + <> lineTo' (x+ct) mid + +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) where + pc2 = pc { _plot_candle_width = 2 } + xwid = p_x p1 + p_x p2 lo = max (p_y p1) (p_y p2) mid = (p_y p1 + p_y p2)/2 hi = min (p_y p1) (p_y p2) 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 diff --git a/Graphics/Rendering/Chart/Plot/ErrBars.hs b/Graphics/Rendering/Chart/Plot/ErrBars.hs --- a/Graphics/Rendering/Chart/Plot/ErrBars.hs +++ b/Graphics/Rendering/Chart/Plot/ErrBars.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.ErrBars --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Plot series of points with associated error bars. @@ -10,7 +10,6 @@ module Graphics.Rendering.Chart.Plot.ErrBars( PlotErrBars(..), - defaultPlotErrBars, ErrPoint(..), ErrValue(..), symErrPoint, @@ -26,15 +25,12 @@ ) where import Control.Lens -import Data.Monoid import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque) -import Data.Colour.Names (black, blue) -import Data.Colour.SRGB (sRGB) +import Data.Colour.Names (blue) import Data.Default.Class -- | Value for holding a point with associated error bounds for each axis. @@ -78,8 +74,8 @@ where pts = _plot_errbars_values p -renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> ChartBackend () -renderPlotErrBars p pmap = do +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)) = @@ -90,10 +86,11 @@ drawErrBar = drawErrBar0 p pmap' = mapXY pmap +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) $ do + withLineStyle (_plot_errbars_line_style ps) $ strokePath $ moveTo' (xl-oh) y <> lineTo' (xh+oh) y <> moveTo' x (yl-oh) @@ -107,22 +104,19 @@ <> moveTo' (x-tl) yh <> lineTo' (x+tl) yh -renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> ChartBackend () -renderPlotLegendErrBars p r@(Rect p1 p2) = do - drawErrBar (symErrPoint (p_x p1) ((p_y p1 + p_y p2)/2) dx dx) - drawErrBar (symErrPoint ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2) dx dx) - drawErrBar (symErrPoint (p_x p2) ((p_y p1 + p_y p2)/2) dx dx) +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) + drawErrBar (symErrPoint (p_x p2) y dx dx) where drawErrBar = drawErrBar0 p dx = min ((p_x p2 - p_x p1)/6) ((p_y p2 - p_y p1)/2) - -{-# DEPRECATED defaultPlotErrBars "Use the according Data.Default instance!" #-} -defaultPlotErrBars :: PlotErrBars x y -defaultPlotErrBars = def + y = (p_y p1 + p_y p2)/2 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 diff --git a/Graphics/Rendering/Chart/Plot/FillBetween.hs b/Graphics/Rendering/Chart/Plot/FillBetween.hs --- a/Graphics/Rendering/Chart/Plot/FillBetween.hs +++ b/Graphics/Rendering/Chart/Plot/FillBetween.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.FillBetween --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Plots that fill the area between two lines. @@ -10,22 +10,20 @@ 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 import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque) -import Data.Colour.Names (black, blue) import Data.Colour.SRGB (sRGB) import Data.Default.Class @@ -35,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))] } @@ -46,23 +45,31 @@ _plot_all_points = plotAllPointsFillBetween p } -renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> ChartBackend () -renderPlotFillBetween p pmap = - renderPlotFillBetween' p (_plot_fillbetween_values p) pmap +renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> BackendProgram () +renderPlotFillBetween p = + renderPlotFillBetween' p (_plot_fillbetween_values p) -renderPlotFillBetween' p [] _ = return () +renderPlotFillBetween' :: + PlotFillBetween x y + -> [(a, (b, b))] + -> ((Limit a, Limit b) -> Point) + -> 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,y2)) <- vs ] - p2s = map pmap' [ (x,y2) | (x,(y1,y2)) <- vs ] + (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) $ do + withFillStyle (_plot_fillbetween_style p) $ fillPath (rectPath r) plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y]) @@ -71,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 = [] } diff --git a/Graphics/Rendering/Chart/Plot/Hidden.hs b/Graphics/Rendering/Chart/Plot/Hidden.hs --- a/Graphics/Rendering/Chart/Plot/Hidden.hs +++ b/Graphics/Rendering/Chart/Plot/Hidden.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Hidden --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Plots that don't show, but occupy space so as to effect axis @@ -11,16 +11,16 @@ module Graphics.Rendering.Chart.Plot.Hidden( PlotHidden(..), + + plot_hidden_x_values, + plot_hidden_y_values ) where import Control.Lens -import Graphics.Rendering.Chart.Geometry -import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types --- | Value defining some hidden x and y values. The values don't --- get displayed, but still affect axis scaling. +-- | Value defining some hidden x and y values. The values are +-- not displayed, but they still affect axis scaling. data PlotHidden x y = PlotHidden { _plot_hidden_x_values :: [x], _plot_hidden_y_values :: [y] diff --git a/Graphics/Rendering/Chart/Plot/Histogram.hs b/Graphics/Rendering/Chart/Plot/Histogram.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Histogram.hs @@ -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 ) diff --git a/Graphics/Rendering/Chart/Plot/Lines.hs b/Graphics/Rendering/Chart/Plot/Lines.hs --- a/Graphics/Rendering/Chart/Plot/Lines.hs +++ b/Graphics/Rendering/Chart/Plot/Lines.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Lines --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Line plots @@ -10,7 +10,6 @@ module Graphics.Rendering.Chart.Plot.Lines( PlotLines(..), - defaultPlotLines, defaultPlotLineStyle, hlinePlot, vlinePlot, @@ -24,10 +23,9 @@ import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types import Data.Colour (opaque) -import Data.Colour.Names (black, blue) +import Data.Colour.Names (blue) import Data.Default.Class -- | Value defining a series of (possibly disjointed) lines, @@ -56,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) @@ -64,8 +62,8 @@ where drawLines mapfn pts = alignStrokePoints (map mapfn pts) >>= strokePointPath -renderPlotLegendLines :: PlotLines x y -> Rect -> ChartBackend () -renderPlotLegendLines p r@(Rect p1 p2) = +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 ps <- alignStrokePoints [Point (p_x p1) y, Point (p_x p2) y] @@ -77,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 = "" @@ -91,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)]] @@ -99,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)]] diff --git a/Graphics/Rendering/Chart/Plot/Pie.hs b/Graphics/Rendering/Chart/Plot/Pie.hs --- a/Graphics/Rendering/Chart/Plot/Pie.hs +++ b/Graphics/Rendering/Chart/Plot/Pie.hs @@ -1,241 +1,228 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Chart.Plot.Pie --- Copyright : (c) Tim Docker 2008 --- 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 --- $ defaultPieLayout --- 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 - -import Data.List -import Data.Bits -import Control.Lens hiding (moveTo) -import Data.Colour -import Data.Colour.Names (black, white) -import Data.Monoid -import Data.Default.Class -import Control.Monad - -import Graphics.Rendering.Chart.Geometry -import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Legend -import Graphics.Rendering.Chart.Renderable -import Graphics.Rendering.Chart.Grid -import Graphics.Rendering.Chart.Plot.Types - -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 = defaultPieChart - , _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 (map _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 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 [ pi{_pitem_value=_pitem_value pi/total} - | pi <- _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 = do - withFontStyle (_pie_label_style p) $ do - withLineStyle (_pie_label_line_style p) $ do - let p1 = ray angle (radius+label_rgap+label_rlength+offset) - p1a <- alignStrokePoint $ p1 - (tw,th) <- 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 $ 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) a1 a2 color = do - let path = arc' x y radius (radian a1) (radian a2) - <> lineTo' x y - <> lineTo' x y - <> close - - withFillStyle (FillStyleSolid color) $ do - fillPath path - withLineStyle (def { _line_color = withOpacity white 0.1 }) $ do - 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 - x'' = ((x + r) - x) - x = p_x center - y = p_y center - - radian = (*(pi / 180.0)) - - -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 ) diff --git a/Graphics/Rendering/Chart/Plot/Points.hs b/Graphics/Rendering/Chart/Plot/Points.hs --- a/Graphics/Rendering/Chart/Plot/Points.hs +++ b/Graphics/Rendering/Chart/Plot/Points.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Points --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Functions to plot sets of points, marked in various styles. @@ -10,7 +10,6 @@ module Graphics.Rendering.Chart.Plot.Points( PlotPoints(..), - defaultPlotPoints, -- * Accessors -- | These accessors are generated by template haskell @@ -23,10 +22,7 @@ import Control.Lens import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Plot.Types -import Data.Colour (opaque) -import Data.Colour.Names (black, blue) import Data.Default.Class -- | Value defining a series of datapoints, and a style in @@ -46,25 +42,22 @@ where pts = _plot_points_values p -renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> ChartBackend () -renderPlotPoints p pmap = do +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) + ps = _plot_points_style p -renderPlotLegendPoints :: PlotPoints x y -> Rect -> ChartBackend () -renderPlotLegendPoints p r@(Rect p1 p2) = do - drawPoint ps (Point (p_x p1) ((p_y p1 + p_y p2)/2)) - drawPoint ps (Point ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2)) - drawPoint ps (Point (p_x p2) ((p_y p1 + p_y p2)/2)) +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) + drawPoint ps (Point (p_x p2) y) where - ps = (_plot_points_style p) - -{-# DEPRECATED defaultPlotPoints "Use the according Data.Default instance!" #-} -defaultPlotPoints :: PlotPoints x y -defaultPlotPoints = def + ps = _plot_points_style p + y = (p_y p1 + p_y p2)/2 instance Default (PlotPoints x y) where def = PlotPoints diff --git a/Graphics/Rendering/Chart/Plot/Types.hs b/Graphics/Rendering/Chart/Plot/Types.hs --- a/Graphics/Rendering/Chart/Plot/Types.hs +++ b/Graphics/Rendering/Chart/Plot/Types.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Plot.Types --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- Datatypes and functions common to the implementation of the various @@ -24,23 +24,19 @@ import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing -import Graphics.Rendering.Chart.Renderable -import Control.Monad import Control.Lens -import Data.Colour -import Data.Colour.Names -- | Interface to control plotting on a 2D area. data Plot x y = Plot { -- | 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. @@ -51,6 +47,9 @@ 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 joinPlot Plot{ _plot_render = renderP @@ -68,7 +67,7 @@ ---------------------------------------------------------------------- -mapXY :: PointMapFn x y -> ((x,y) -> Point) +mapXY :: PointMapFn x y -> (x,y) -> Point mapXY f (x,y) = f (LValue x, LValue y) ---------------------------------------------------------------------- diff --git a/Graphics/Rendering/Chart/Plot/Vectors.hs b/Graphics/Rendering/Chart/Plot/Vectors.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Vectors.hs @@ -0,0 +1,145 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Vectors +-- Copyright : (c) Anton Vorontsov 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 = [] + } diff --git a/Graphics/Rendering/Chart/Renderable.hs b/Graphics/Rendering/Chart/Renderable.hs --- a/Graphics/Rendering/Chart/Renderable.hs +++ b/Graphics/Rendering/Chart/Renderable.hs @@ -1,21 +1,25 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Renderable --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- This module contains the definition of the 'Renderable' type, which -- is a composable drawing element, along with assorted functions to -- them. -- +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Renderable( Renderable(..), ToRenderable(..), PickFn, - + Rectangle(..), + RectCornerStyle(..), + rectangleToRenderable, + drawRectangle, fillBackground, addMargins, @@ -38,8 +42,6 @@ import Control.Monad import Control.Lens -import Data.List ( nub, transpose, sort ) -import Data.Monoid import Data.Default.Class import Graphics.Rendering.Chart.Geometry @@ -50,7 +52,7 @@ -- -- Perhaps it might be generalised from Maybe a to -- (MonadPlus m ) => m a in the future. -type PickFn a = Point -> (Maybe a) +type PickFn a = Point -> Maybe a nullPickFn :: PickFn a nullPickFn = const Nothing @@ -59,25 +61,29 @@ -- graphic element. data Renderable a = Renderable { - -- | A Cairo action to calculate a minimum size. - minsize :: ChartBackend RectSize, + -- | Calculate the minimum size of the renderable. + minsize :: BackendProgram RectSize, - -- | A Cairo action for drawing it within a rectangle. - -- The rectangle is from the origin to the given point. + -- | 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 @@ -91,7 +97,7 @@ -- | Replace the pick function of a renderable with another. setPickFn :: PickFn b -> Renderable a -> Renderable b -setPickFn pickfn r = r{ render = \sz -> do { render r sz; return pickfn; } } +setPickFn pickfn r = r{ render = \sz -> render r sz >> return pickfn } -- | Map a function over the result of a renderable's pickfunction, keeping only 'Just' results. mapMaybePickFn :: (a -> Maybe b) -> Renderable a -> Renderable b @@ -112,14 +118,14 @@ (w,h) <- minsize rd return (w+l+r,h+t+b) - rf (w,h) = do + 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)) - mkpickf pickf (t,b,l,r) (w,h) (Point x y) - | x >= l && x <= w-r && y >= t && t <= h-b = pickf (Point (x-l) (y-t)) - | otherwise = Nothing + mkpickf pickf (t',b',l',r') (w,h) (Point x y) + | x >= l' && x <= w-r' && y >= t' && t' <= h-b' = pickf (Point (x-l') (y-t')) + | otherwise = Nothing -- | Overlay a renderable over a solid background fill. fillBackground :: FillStyle -> Renderable a -> Renderable a @@ -132,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 } @@ -148,34 +154,42 @@ label fs hta vta = rlabel fs hta vta 0 -- | Construct a renderable from a text string, rotated wrt to axes. The angle --- of rotation is in degrees. +-- of rotation is in degrees, measured clockwise from the horizontal. rlabel :: FontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable String rlabel fs hta vta rot s = Renderable { minsize = mf, render = rf } where mf = withFontStyle fs $ do ts <- textSize s - let (w,h) = (textSizeWidth ts, textSizeHeight ts) - return (w*acr+h*asr,w*asr+h*acr) + 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) - let descent = textSizeDescent ts - withTranslation (Point 0 (-descent)) $ do - withTranslation (Point (xadj sz hta 0 w0) (yadj sz vta 0 h0)) $ do + 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)) $ withRotation rot' $ do drawText (Point (-w/2) (h/2)) s return (\_-> Just s) -- PickFn String - xadj (w,h) HTA_Left x1 x2 = x1 +(w*acr+h*asr)/2 - xadj (w,h) HTA_Centre x1 x2 = (x1 + x2)/2 - xadj (w,h) HTA_Right x1 x2 = x2 -(w*acr+h*asr)/2 - yadj (w,h) VTA_Top y1 y2 = y1 +(w*asr+h*acr)/2 - yadj (w,h) VTA_Centre y1 y2 = (y1+y2)/2 - yadj (w,h) VTA_Bottom y1 y2 = y2 - (w*asr+h*acr)/2 rot' = rot / 180 * pi (cr,sr) = (cos rot', sin rot') (acr,asr) = (abs cr, abs sr) + xwid (w,h) = w*acr + h*asr + ywid (w,h) = w*asr + h*acr + ---------------------------------------------------------------------- -- Rectangles @@ -190,10 +204,6 @@ _rect_cornerStyle :: RectCornerStyle } -{-# DEPRECATED defaultRectangle "Use the according Data.Default instance!" #-} -defaultRectangle :: Rectangle -defaultRectangle = def - instance Default Rectangle where def = Rectangle { _rect_minsize = (0,0) @@ -208,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 = do - withFillStyle fs $ do - 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 = do - withLineStyle ls $ do - 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 ) diff --git a/Graphics/Rendering/Chart/Simple.hs b/Graphics/Rendering/Chart/Simple.hs deleted file mode 100644 --- a/Graphics/Rendering/Chart/Simple.hs +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Chart.Simple --- Copyright : (c) David Roundy 2007 --- License : BSD-style (see chart/COPYRIGHT) --- --- An even simpler framework for creating 2D charts in Haskell. --- --- The basic idea is to make it as easy to plot as octave, which means that --- you provide no more information than you wish to provide. We provide --- four plotting functions, which differ only in their output. One --- produces a "Layout1" that you can customize using other --- Graphics.Rendering.Chart functions. The other three produce their --- output directly. All three accept the same input and produce the same plots. --- --- The plot functions accept a variable number of arguments. You must --- provide a [Double] which defines the points on the x axis, which must --- precede any of the "y" values. The y values may either be [Double] or --- functions. After any given y value, you can give either Strings or --- PlotKinds describing how you'd like that y printed. --- --- Examples: --- --- > plotPDF "foo.pdf" [0,0.1..10] sin "- " cos ". " cos "o" --- --- > plotPS "foo.ps" [0,0.1..10] (sin . exp) "- " (sin . exp) "o-" ------------------------------------------------------------------------------ -module Graphics.Rendering.Chart.Simple( plot, PlotKind(..), xcoords, - plotPDF, plotPS, - plotLayout, plotPNG, LayoutDDD, - layoutDddToRenderable - , PlotPDFType(..) - , PlotPSType(..) - , PlotPNGType(..) - , uplot - ) where - -import Graphics.Rendering.Chart.Simple.Internal diff --git a/Graphics/Rendering/Chart/Simple/Internal.hs b/Graphics/Rendering/Chart/Simple/Internal.hs deleted file mode 100644 --- a/Graphics/Rendering/Chart/Simple/Internal.hs +++ /dev/null @@ -1,269 +0,0 @@ - -module Graphics.Rendering.Chart.Simple.Internal where - -import Data.Maybe ( catMaybes ) -import Data.Colour -import Data.Colour.Names -import Data.Default.Class - -import Graphics.Rendering.Chart -import Graphics.Rendering.Chart.Utils - - -styleColor :: Int -> AlphaColour Double -styleColor ind = colorSequence !! ind - where colorSequence = cycle $ map opaque [ blue, red, green, yellow - , cyan, magenta, black ] - -styleSymbol :: Int -> PlotKind -styleSymbol ind = symbolSequence !! ind - where symbolSequence = cycle [ Ex, HollowCircle, Square, Diamond - , Triangle, DownTriangle, Plus, Star - , FilledCircle ] - -iplot :: (PlotValue x, PlotValue y) => [InternalPlot x y] -> Layout x y -iplot foobar = def { - _layout_plots = concat $ zipWith toplot (ip foobar) [0..] - } - where - ip (xs@(IPX _ _):xyss) = map (\ys -> (xs,ys)) yss ++ ip rest - where yss = takeWhile isIPY xyss - rest = dropWhile isIPY xyss - ip (_:xyss) = ip xyss - ip [] = [] - isIPY (IPY _ _) = True - isIPY _ = False - toplot (IPX xs _, IPY ys yks) ind = plots - where - vs = zip xs ys - plots = case catMaybes $ map plotas yks of - [] -> [ toPlot $ def - { _plot_lines_title = name yks, - _plot_lines_values = [vs], - _plot_lines_style = solidLine 1 (styleColor ind) - } ] - xs -> xs - plotas Solid = Just $ toPlot $ def - { _plot_lines_title = name yks, - _plot_lines_values = [vs], - _plot_lines_style = solidLine 1 (styleColor ind) } - plotas Dashed = Just $ toPlot $ def - { _plot_lines_title = name yks, - _plot_lines_values = [vs], - _plot_lines_style = dashedLine 1 [10,10] - (styleColor ind) } - plotas Dotted = Just $ toPlot $ def - { _plot_lines_title = name yks, - _plot_lines_values = [vs], - _plot_lines_style = dashedLine 1 [1,11] - (styleColor ind) } - plotas FilledCircle = Just $ toPlot $ def - { _plot_points_title = name yks, - _plot_points_values = vs, - _plot_points_style = filledCircles 4 - (styleColor ind) } - plotas HollowCircle = Just $ toPlot $ def - { _plot_points_title = name yks, - _plot_points_values = vs, - _plot_points_style = hollowCircles 5 1 - (styleColor ind) } - plotas Triangle = Just $ toPlot $ def - { _plot_points_title = name yks, - _plot_points_values = vs, - _plot_points_style = hollowPolygon 7 1 3 False - (styleColor ind) } - plotas DownTriangle = Just $ toPlot $ def - { _plot_points_title = name yks, - _plot_points_values = vs, - _plot_points_style = hollowPolygon 7 1 3 True - (styleColor ind) } - plotas Square = Just $ toPlot $ def - { _plot_points_title = name yks, - _plot_points_values = vs, - _plot_points_style = hollowPolygon 7 1 4 False - (styleColor ind) } - plotas Diamond = Just $ toPlot $ def - { _plot_points_title = name yks, - _plot_points_values = vs, - _plot_points_style = hollowPolygon 7 1 4 True - (styleColor ind) } - plotas Plus = Just $ toPlot $ def - { _plot_points_title = name yks, - _plot_points_values = vs, - _plot_points_style = plusses 7 1 (styleColor ind) } - plotas Ex = Just $ toPlot $ def - { _plot_points_title = name yks, - _plot_points_values = vs, - _plot_points_style = exes 7 1 (styleColor ind) } - plotas Star = Just $ toPlot $ def - { _plot_points_title = name yks, - _plot_points_values = vs, - _plot_points_style = stars 7 1 (styleColor ind) } - plotas Symbols = plotas (styleSymbol ind) - plotas _ = Nothing - -name :: [PlotKind] -> String -name (Name s:_) = s -name (_:ks) = name ks -name [] = "" - -str2k :: String -> [PlotKind] -str2k "" = [] -str2k ". " = [Dotted] -str2k s@('?':_) = str2khelper s Symbols -str2k s@('@':_) = str2khelper s FilledCircle -str2k s@('#':_) = str2khelper s Square -str2k s@('v':_) = str2khelper s DownTriangle -str2k s@('^':_) = str2khelper s Triangle -str2k s@('o':_) = str2khelper s HollowCircle -str2k s@('+':_) = str2khelper s Plus -str2k s@('x':_) = str2khelper s Ex -str2k s@('*':_) = str2khelper s Star -str2k s@('.':_) = str2khelper s LittleDot -str2k "- " = [Dashed] -str2k "-" = [Solid] -str2k n = [Name n] - -str2khelper :: String -> PlotKind -> [PlotKind] -str2khelper s@(_:r) x = case str2k r of - [] -> [x] - [Name _] -> [Name s] - xs -> x:xs - --- | Type to define a few simple properties of each plot. -data PlotKind = Name String | FilledCircle | HollowCircle - | Triangle | DownTriangle | Square | Diamond - | Plus | Ex | Star | Symbols - | LittleDot | Dashed | Dotted | Solid - deriving ( Eq, Show, Ord ) -data InternalPlot x y = IPY [y] [PlotKind] | IPX [x] [PlotKind] - -newtype LayoutDDD = LayoutDDD { plotLayout :: Layout Double Double } - -layoutDddToRenderable :: LayoutDDD -> Renderable (LayoutPick Double Double Double) -layoutDddToRenderable = layoutToRenderable . plotLayout - -instance ToRenderable LayoutDDD where - toRenderable = setPickFn nullPickFn . toRenderable - -uplot :: [UPlot] -> LayoutDDD -uplot us = LayoutDDD $ iplot $ nameDoubles $ evalfuncs us - where - nameDoubles :: [UPlot] -> [InternalPlot Double Double] - nameDoubles (X xs: uus) = case grabName uus of - (ks,uus') -> IPX (filter isValidNumber xs) ks - : nameDoubles uus' - nameDoubles (UDoubles xs:uus)= case grabName uus of - (ks,uus') -> IPY (filter isValidNumber xs) ks - : nameDoubles uus' - nameDoubles (_:uus) = nameDoubles uus - nameDoubles [] = [] - evalfuncs :: [UPlot] -> [UPlot] - evalfuncs (UDoubles xs:uus) = X xs : map ef (takeWhile (not.isX) uus) - ++ evalfuncs (dropWhile (not.isX) uus) - where ef (UFunction f) = UDoubles (map f xs) - ef u = u - evalfuncs (X xs:uus) = X xs : map ef (takeWhile (not.isX) uus) - ++ evalfuncs (dropWhile (not.isX) uus) - where ef (UFunction f) = UDoubles (map f xs) - ef u = u - evalfuncs (u:uus) = u : evalfuncs uus - evalfuncs [] = [] - grabName :: [UPlot] -> ([PlotKind],[UPlot]) - grabName (UString n:uus) = case grabName uus of - (ks,uus') -> (str2k n++ks,uus') - grabName (UKind ks:uus) = case grabName uus of - (ks',uus') -> (ks++ks',uus') - grabName uus = ([],uus) - isX (X _) = True - isX _ = False - --- | The main plotting function. The idea behind PlotType is shamelessly --- copied from Text.Printf (and is not exported). All you need to know is --- that your arguments need to be in class PlotArg. And PlotArg consists --- of functions and [Double] and String and PlotKind or [PlotKind]. - -plot :: PlotType a => a -plot = pl [] -class PlotType t where - pl :: [UPlot] -> t -instance (PlotArg a, PlotType r) => PlotType (a -> r) where - pl args = \ a -> pl (toUPlot a ++ args) -instance PlotType LayoutDDD where - pl args = uplot (reverse args) - --- | Save a plot as a PDF file. - -plotPDF :: PlotPDFType a => String -> a -plotPDF fn = pld fn [] -class PlotPDFType t where - pld :: FilePath -> [UPlot] -> t -instance (PlotArg a, PlotPDFType r) => PlotPDFType (a -> r) where - pld fn args = \ a -> pld fn (toUPlot a ++ args) - --- | Save a plot as a postscript file. - -plotPS :: PlotPSType a => String -> a -plotPS fn = pls fn [] -class PlotPSType t where - pls :: FilePath -> [UPlot] -> t -instance (PlotArg a, PlotPSType r) => PlotPSType (a -> r) where - pls fn args = \ a -> pls fn (toUPlot a ++ args) - --- | Save a plot as a png file. -plotPNG :: PlotPNGType a => String -> a -plotPNG fn = plp fn [] - -class PlotPNGType t where - plp :: FilePath -> [UPlot] -> t -instance (PlotArg a, PlotPNGType r) => PlotPNGType (a -> r) where - plp fn args = \ a -> plp fn (toUPlot a ++ args) - -data UPlot = UString String | UDoubles [Double] | UFunction (Double -> Double) - | UKind [PlotKind] | X [Double] - -xcoords :: [Double] -> UPlot -xcoords = X - -class PlotArg a where - toUPlot :: a -> [UPlot] - -instance IsPlot p => PlotArg [p] where - toUPlot = toUPlot' - -instance (Real a, Real b, Fractional a, Fractional b) => PlotArg (a -> b) where - toUPlot x = [UFunction (realToFrac . x . realToFrac)] - -instance (Real a, Real b, Fractional a, Fractional b) => IsPlot (a -> b) where - toUPlot' = reverse . concatMap f - where f x = [UFunction (realToFrac . x . realToFrac)] - -instance PlotArg UPlot where - toUPlot = (:[]) - -instance PlotArg PlotKind where - toUPlot = (:[]) . UKind . (:[]) - - -class IsPlot c where - toUPlot' :: [c] -> [UPlot] - -instance IsPlot PlotKind where - toUPlot' = (:[]) . UKind - -instance IsPlot Double where - toUPlot' = (:[]) . UDoubles - -instance IsPlot Char where - toUPlot' = (:[]) . UString - -instance IsPlot p => IsPlot [p] where - toUPlot' = reverse . concatMap toUPlot' - -instance (IsPlot p, IsPlot q, IsPlot r) => IsPlot (p,q,r) where - toUPlot' = reverse . concatMap f - where f (p,q,r) = toUPlot' [p] ++ toUPlot' [q] ++ toUPlot' [r] - -instance (IsPlot p, IsPlot q) => IsPlot (p,q) where - toUPlot' = reverse . concatMap f - where f (p,q) = toUPlot' [p] ++ toUPlot' [q] diff --git a/Graphics/Rendering/Chart/SparkLine.hs b/Graphics/Rendering/Chart/SparkLine.hs --- a/Graphics/Rendering/Chart/SparkLine.hs +++ b/Graphics/Rendering/Chart/SparkLine.hs @@ -1,27 +1,29 @@ --------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Sparkline --- Copyright : (c) Hitesh Jasani, 2008, Malcolm Wallace 2011 +-- Copyright : (c) Hitesh Jasani, 2008, Malcolm Wallace 2011, Tim Docker 2014 -- License : BSD3 -- --- Created : 2008-02-26 --- Modified : 2011-02-11 --- Version : 0.2 --- --- Sparklines implementation in Haskell. Sparklines are --- mini graphs inspired by Edward Tufte. +-- Sparklines are mini graphs inspired by Edward Tufte; see +-- +-- and +-- for more information. -- -- The original implementation (by Hitesh Jasani) used the gd -- package as a backend renderer, and is still available at --- http://hackage.haskell.org/package/hsparklines --- The present version uses Cairo as its renderer, and integrates with +-- . +-- +-- The present version integrates with -- the Chart package, in the sense that Sparklines are just another --- kind of (ToRenderable a => a), so can be composed into grids etc. +-- kind of (@ToRenderable a => a@), so they can be composed into grids +-- and used with the rest of Chart. -- -- > dp :: [Double] -- > dp = [24,21,32.3,24,15,34,43,55,57,72,74,75,73,72,55,44] -- > --- > sparkLineToPNG "bar_spark.png" (SparkLine barSpark dp) +-- > sl = SparkLine barSpark dp +-- > fopts = FileOptions (sparkSize sl) PNG +-- > renderableToFile fopts (sparkLineToRenderable sl) "bar_spark.png" -- > --------------------------------------------------------------- @@ -90,9 +92,10 @@ barSpark :: SparkOptions barSpark = smoothSpark { so_smooth=False } +-- | Create a renderable from a SparkLine. sparkLineToRenderable :: SparkLine -> Renderable () sparkLineToRenderable sp = Renderable - { minsize = return (0, fromIntegral (so_height (sl_options sp))) + { minsize = let (w,h) = sparkSize sp in return (fromIntegral w , fromIntegral h) , render = \_rect-> renderSparkLine sp } @@ -109,11 +112,12 @@ | otherwise = 2 in w +-- | Return the width and height of the SparkLine. sparkSize :: SparkLine -> (Int,Int) sparkSize s = (sparkWidth s, so_height (sl_options s)) --- | Render a SparkLine to a drawing surface using cairo. -renderSparkLine :: SparkLine -> ChartBackend (PickFn ()) +-- | Render a SparkLine to a drawing surface. +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 diff --git a/Graphics/Rendering/Chart/State.hs b/Graphics/Rendering/Chart/State.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/State.hs @@ -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) diff --git a/Graphics/Rendering/Chart/Utils.hs b/Graphics/Rendering/Chart/Utils.hs --- a/Graphics/Rendering/Chart/Utils.hs +++ b/Graphics/Rendering/Chart/Utils.hs @@ -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 diff --git a/Numeric/Histogram.hs b/Numeric/Histogram.hs new file mode 100644 --- /dev/null +++ b/Numeric/Histogram.hs @@ -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