diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,39 +1,78 @@ Name: Chart -Version: 0.11 +Version: 1.9.5 License: BSD3 License-file: LICENSE -Copyright: Tim Docker, 2006-2009 +Copyright: Tim Docker, 2006-2014 Author: Tim Docker Maintainer: Tim Docker -Homepage: http://www.dockerz.net/software/chart.html +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 -Extra-Source-Files: tests/test.hs, tests/Prices.hs +library + default-language: Haskell98 + Build-depends: base >= 3 && < 5 + , old-locale + , time, array + , lens >= 3.9 && < 5.3 + , colour >= 2.2.1 && < 2.4 + , data-default-class < 0.2 + , mtl >= 2.0 && < 2.4 + , operational >= 0.2.2 && < 0.3 + , vector >=0.9 && <0.14 -flag splitbase - description: Choose the new smaller, split-up base package. + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.18.4 && <0.19 -library - if flag(splitbase) - Build-depends: base >= 3, old-locale, time, mtl, array - else - Build-depends: base < 3 - Build-depends: gtk >= 0.9.11, cairo >= 0.9.11, time, mtl, array, data-accessor == 0.2.*, data-accessor-template >= 0.2.1.1 && < 0.3, colour >= 2.2.1 + Ghc-options: -Wall -fno-warn-orphans + Exposed-modules: Graphics.Rendering.Chart, - Graphics.Rendering.Chart.Gtk, - Graphics.Rendering.Chart.Types, + Graphics.Rendering.Chart.Drawing, + Graphics.Rendering.Chart.Geometry, + Graphics.Rendering.Chart.Utils, Graphics.Rendering.Chart.Renderable, Graphics.Rendering.Chart.Axis, + 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.Grid, Graphics.Rendering.Chart.Plot, - Graphics.Rendering.Chart.Pie, - Graphics.Rendering.Chart.Simple, - Graphics.Rendering.Chart.Grid - + Graphics.Rendering.Chart.Plot.Types, + Graphics.Rendering.Chart.Plot.Annotation, + Graphics.Rendering.Chart.Plot.AreaSpots, + Graphics.Rendering.Chart.Plot.Bars, + Graphics.Rendering.Chart.Plot.Candle, + Graphics.Rendering.Chart.Plot.ErrBars, + 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.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,51 +1,61 @@ ---------------------------------------------------------------------------- -- | -- 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 'Graphics.Rendering.Chart.Gtk.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 'Graphics.Rendering.Chart.Layout.Layout1' +-- Currently, there are three types of charts: -- --- * a pie chart can be is created by applying --- 'toRenderable' to a value of type 'Graphics.Rendering.Chart.Pie.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 - eg --- '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. -- ----------------------------------------------------------------------------- module Graphics.Rendering.Chart( - module Graphics.Rendering.Chart.Types, + module Graphics.Rendering.Chart.Geometry, + module Graphics.Rendering.Chart.Drawing, module Graphics.Rendering.Chart.Renderable, module Graphics.Rendering.Chart.Layout, module Graphics.Rendering.Chart.Axis, module Graphics.Rendering.Chart.Plot, module Graphics.Rendering.Chart.Legend, - module Graphics.Rendering.Chart.Pie, + module Graphics.Rendering.Chart.Backend.Types ) where -import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Layout import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Plot import Graphics.Rendering.Chart.Legend -import Graphics.Rendering.Chart.Pie +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 @@ -6,613 +6,19 @@ -- -- Code to calculate and render axes. -- --- Note that template haskell is used to derive accessor functions --- (see 'Data.Accessor') for each field of the following data types: --- --- * 'AxisData' --- --- * 'Axis' --- --- * 'AxisStyle' --- --- * 'LinearAxisParams' --- --- * 'LogAxisParams' --- --- 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 --- --- @ --- f :: Data.Accessor.Accessor D F --- @ --- -{-# OPTIONS_GHC -XTemplateHaskell #-} - module Graphics.Rendering.Chart.Axis( - AxisData(..), - AxisT(..), - LinearAxisParams(..), - LogAxisParams(..), - AxisStyle(..), - PlotValue(..), - LogValue(..), - PlotIndex(..), - AxisFn, - - defaultAxisLineStyle, - defaultLinearAxis, - defaultLogAxis, - defaultAxisStyle, - autoScaledAxis, - autoScaledLogAxis, - timeAxis, - autoTimeAxis, - days, months, years, - autoIndexAxis, - addIndexes, - - axisToRenderable, - renderAxisGrid, - axisOverhang, - vmap, - - axisGridAtTicks, - axisGridAtLabels, - axisGridHide, - axisTicksHide, - axisLabelsHide, - - axis_viewport, - axis_ticks, - axis_labels, - axis_grid, - - axis_line_style, - axis_label_style, - axis_grid_style, - axis_label_gap, - - la_labelf, - la_nLabels, - la_nTicks, - - loga_labelf, - + module Graphics.Rendering.Chart.Axis.Types, + module Graphics.Rendering.Chart.Axis.Floating, + module Graphics.Rendering.Chart.Axis.Int, + module Graphics.Rendering.Chart.Axis.Time, + module Graphics.Rendering.Chart.Axis.Unit, + module Graphics.Rendering.Chart.Axis.Indexed, ) where -import qualified Graphics.Rendering.Cairo as C -import Data.Time -import System.Locale (defaultTimeLocale) -import Control.Monad -import Data.List -import Data.Accessor.Template -import Data.Colour (opaque) -import Data.Colour.Names (black, lightgrey) - -import Graphics.Rendering.Chart.Types -import Graphics.Rendering.Chart.Renderable - --- | The basic data associated with an axis showing values of type x -data AxisData x = AxisData { - - -- | The axis_viewport_ function maps values into device - -- cordinates. - axis_viewport_ :: Range -> x -> Double, - - -- | The tick marks on the axis as pairs. - -- The first element is the position on the axis - -- (in viewport units) and the second element is the - -- length of the tick in output coordinates. - -- The tick starts on the axis, and positive number are drawn - -- towards the plot area. - axis_ticks_ :: [(x,Double)], - - -- | The labels on an axis as pairs. The first element - -- is the position on the axis (in viewport units) and - -- the second is the label text string. - axis_labels_ :: [ (x, String) ], - - -- | The positions on the axis (in viewport units) where - -- we want to show grid lines. - axis_grid_ :: [ x ] -} - --- | Control values for how an axis gets displayed -data AxisStyle = AxisStyle { - axis_line_style_ :: CairoLineStyle, - axis_label_style_ :: CairoFontStyle, - axis_grid_style_ :: CairoLineStyle, - - -- | How far the labels are to be drawn from the axis. - axis_label_gap_ :: Double -} - - --- | A function to generate the axis data given the data values --- to be plotted against it. -type AxisFn x = [x] -> AxisData x - --- | Collect the information we need to render an axis. The --- bool is true if the axis direction is reversed -data AxisT x = AxisT RectEdge AxisStyle Bool (AxisData x) - -instance ToRenderable (AxisT x) where - toRenderable = setPickFn nullPickFn.axisToRenderable - -axisToRenderable :: AxisT x -> Renderable x -axisToRenderable at = Renderable { - minsize=minsizeAxis at, - render=renderAxis at - } - -axisGridHide :: AxisData x -> AxisData x -axisGridHide ad = ad{axis_grid_=[]} - -axisGridAtTicks :: AxisData x -> AxisData x -axisGridAtTicks ad = ad{axis_grid_=map fst (axis_ticks_ ad)} - -axisGridAtLabels :: AxisData x -> AxisData x -axisGridAtLabels ad = ad{axis_grid_=map fst (axis_labels_ ad)} - -axisTicksHide :: AxisData x -> AxisData x -axisTicksHide ad = ad{axis_ticks_=[]} - -axisLabelsHide :: AxisData x -> AxisData x -axisLabelsHide ad = ad{axis_labels_=[]} - -minsizeAxis :: AxisT x -> CRender RectSize -minsizeAxis (AxisT at as rev ad) = do - let labels = map snd (axis_labels_ ad) - labelSizes <- preserveCState $ do - setFontStyle (axis_label_style_ as) - mapM textSize labels - let (lw,lh) = foldl maxsz (0,0) labelSizes - let ag = axis_label_gap_ as - let tsize = maximum ([0] ++ [ max 0 (-l) | (v,l) <- axis_ticks_ ad ]) - let sz = case at of - E_Top -> (lw,max (addIfNZ lh ag) tsize) - E_Bottom -> (lw,max (addIfNZ lh ag) tsize) - E_Left -> (max (addIfNZ lw ag) tsize, lh) - E_Right -> (max (addIfNZ lw ag) tsize, lh) - return sz - - where - maxsz (w1,h1) (w2,h2) = (max w1 w2, max h1 h2) - addIfNZ a b | a == 0 = 0 - | otherwise = a+b - - --- | Calculate the amount by which the labels extend beyond --- the ends of the axis -axisOverhang :: Ord x => AxisT x -> CRender (Double,Double) -axisOverhang (AxisT at as rev ad) = do - let labels = map snd (sort (axis_labels_ ad)) - labelSizes <- preserveCState $ do - setFontStyle (axis_label_style_ as) - mapM textSize labels - case labelSizes of - [] -> return (0,0) - ls -> let l1 = head ls - l2 = last ls - ohangv = return (snd l1 / 2, snd l2 / 2) - ohangh = return (fst l1 / 2, fst l2 / 2) - in - case at of - E_Top -> ohangh - E_Bottom -> ohangh - E_Left -> ohangv - E_Right -> ohangh - -renderAxis :: AxisT x -> RectSize -> CRender (PickFn x) -renderAxis at@(AxisT et as rev ad) sz = do - let ls = axis_line_style_ as - preserveCState $ do - setLineStyle ls{line_cap_=C.LineCapSquare} - strokeLines [Point sx sy,Point ex ey] - preserveCState $ do - setLineStyle ls{line_cap_=C.LineCapButt} - mapM_ drawTick (axis_ticks_ ad) - preserveCState $ do - setFontStyle (axis_label_style_ as) - mapM_ drawLabel (axis_labels_ ad) - return nullPickFn - where - (sx,sy,ex,ey,tp,axisPoint) = axisMapping at sz - - drawTick (value,length) = - let t1 = axisPoint value - t2 = t1 `pvadd` (vscale length tp) - in strokeLines [t1,t2] - - (hta,vta,lp) = - let g = axis_label_gap_ as - in case et of - E_Top -> (HTA_Centre,VTA_Bottom,(Vector 0 (-g))) - E_Bottom -> (HTA_Centre,VTA_Top,(Vector 0 g)) - E_Left -> (HTA_Right,VTA_Centre,(Vector (-g) 0)) - E_Right -> (HTA_Left,VTA_Centre,(Vector g 0)) - - drawLabel (value,s) = do - drawText hta vta (axisPoint value `pvadd` lp) s - -axisMapping :: AxisT z -> RectSize -> (Double,Double,Double,Double,Vector,z->Point) -axisMapping (AxisT et as rev ad) (x2,y2) = case et of - E_Top -> (x1,y2,x2,y2, (Vector 0 1), mapx (x1,x2) y2) - E_Bottom -> (x1,y1,x2,y1, (Vector 0 (-1)), mapx (x1,x2) y1) - E_Left -> (x2,y2,x2,y1, (Vector (1) 0), mapy (y1,y2) x2) - E_Right -> (x1,y2,x1,y1, (Vector (-1) 0), mapy (y1,y2) x1) - where - (x1,y1) = (0,0) - - mapx xr y x = Point (axis_viewport_ ad (reverse xr) x) y - mapy (yr0,yr1) x y = Point x (axis_viewport_ ad (reverse (yr1,yr0)) y) - reverse r@(r0,r1) = if rev then (r1,r0) else r - -renderAxisGrid :: RectSize -> AxisT z -> CRender () -renderAxisGrid sz@(w,h) at@(AxisT re as rev ad) = do - preserveCState $ do - setLineStyle (axis_grid_style_ as) - mapM_ (drawGridLine re) (axis_grid_ ad) - where - (sx,sy,ex,ey,tp,axisPoint) = axisMapping at sz - - drawGridLine E_Top = vline - drawGridLine E_Bottom = vline - drawGridLine E_Left = hline - drawGridLine E_Right = hline - - vline v = let v' = p_x (axisPoint v) - in strokeLines [Point v' 0,Point v' h] - - hline v = let v' = p_y (axisPoint v) - in strokeLines [Point 0 v',Point w v'] - - - -steps:: Double -> Range -> [Rational] -steps nSteps (min,max) = [ (fromIntegral (min' + i)) * s | i <- [0..n] ] - where - min' = floor (min / fromRational s) - max' = ceiling (max / fromRational s) - n = (max' - min') - s = chooseStep nSteps (min,max) - -chooseStep :: Double -> Range -> Rational -chooseStep nsteps (min,max) = s - where - mult = 10 ^^ (floor ((log (max-min) - log nsteps) / log 10)) - steps = map (mult*) [0.1, 0.2, 0.25, 0.5, 1.0, 2.0, 2.5, 5.0, 10, 20, 25, 50] - steps' = sort [ (abs((max-min)/(fromRational s) - nsteps), s) | s <- steps ] - s = snd (head steps') - -makeAxis :: PlotValue x => (x -> String) -> ([x],[x],[x]) -> AxisData x -makeAxis labelf (labelvs, tickvs, gridvs) = AxisData { - axis_viewport_=newViewport, - axis_ticks_=newTicks, - axis_grid_=gridvs, - axis_labels_=newLabels - } - where - newViewport = vmap (min',max') - newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | v <- labelvs ] - newLabels = [(v,labelf v) | v <- labelvs] - min' = minimum labelvs - max' = maximum labelvs - -data GridMode = GridNone | GridAtMajor | GridAtMinor - -data LinearAxisParams = LinearAxisParams { - -- | The function used to show the axes labels - la_labelf_ :: Double -> String, - - -- | The target number of labels to be shown - la_nLabels_ :: Int, - - -- | The target number of ticks to be shown - la_nTicks_ :: Int -} - - -defaultLinearAxis = LinearAxisParams { - la_labelf_ = showD, - la_nLabels_ = 5, - la_nTicks_ = 50 -} - --- | Generate a linear axis automatically. --- The supplied axis is used as a template, with the viewport, ticks, labels --- and grid set appropriately for the data displayed against that axies. --- The resulting axis will only show a grid if the template has some grid --- values. -autoScaledAxis :: LinearAxisParams -> AxisFn Double -autoScaledAxis lap ps0 = makeAxis (la_labelf_ lap) (labelvs,tickvs,gridvs) - where - ps = filter isValidNumber ps0 - (min,max) = (minimum ps,maximum ps) - range [] = (0,1) - range _ | min == max = (min-0.5,min+0.5) - | otherwise = (min,max) - labelvs = map fromRational $ steps (fromIntegral (la_nLabels_ lap)) r - tickvs = map fromRational $ steps (fromIntegral (la_nTicks_ lap)) (minimum labelvs,maximum labelvs) - gridvs = labelvs - r = range ps - -showD x = case reverse $ show x of - '0':'.':r -> reverse r - _ -> show x - - -log10 :: (Floating a) => a -> a -log10 = logBase 10 - -frac x | 0 <= b = (a,b) - | otherwise = (a-1,b+1) - where - (a,b) = properFraction x - -{- - Rules: Do no subdivide between powers of 10 until all powers of 10 - get a 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) --} -logTicks :: Range -> ([Rational],[Rational],[Rational]) -logTicks (low,high) = (major,minor,major) - where - 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 - inRange (a,b) l x = (lower a l <= x) && (x <= upper b l) - powers :: (Double,Double) -> [Rational] -> [Rational] - powers (x,y) l = [a*10^^p | p<-[(floor (log10 x))..(ceiling (log10 y))], a<-l] - midselection r l = filter (inRange r l) (powers r 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) - | 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') - --- | Generate a log axis automatically. --- The supplied axis is used as a template, with the viewport, ticks, labels --- and grid set appropriately for the data displayed against that axies. --- The resulting axis will only show a grid if the template has some grid --- values. -autoScaledLogAxis :: LogAxisParams -> AxisFn LogValue -autoScaledLogAxis lap ps0 = makeAxis labelf (wrap rlabelvs, wrap rtickvs, wrap rgridvs) - where - ps = filter (\(LogValue x) -> isValidNumber x && 0 < x) ps0 - (min, max) = (minimum ps,maximum ps) - range [] = (3,30) - range _ | min == max = (unLogValue min/3,unLogValue max*3) - | otherwise = (unLogValue min,unLogValue max) - (rlabelvs, rtickvs, rgridvs) = logTicks (range ps) - wrap = map (LogValue . fromRational) - unLogValue (LogValue x) = x - labelf = loga_labelf_ lap - - -data LogAxisParams = LogAxisParams { - -- | The function used to show the axes labels - loga_labelf_ :: LogValue -> String -} - -defaultLogAxis = LogAxisParams { - loga_labelf_ = \(LogValue x) -> showD x -} - ----------------------------------------------------------------------- - -defaultAxisLineStyle = solidLine 1 $ opaque black -defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey - -defaultAxisStyle = AxisStyle { - axis_line_style_ = defaultAxisLineStyle, - axis_label_style_ = defaultFontStyle, - axis_grid_style_ = defaultGridLineStyle, - axis_label_gap_ = 10 -} - ----------------------------------------------------------------------- - --- | Map a LocalTime value to a plot cordinate -doubleFromLocalTime :: LocalTime -> Double -doubleFromLocalTime lt = fromIntegral (toModifiedJulianDay (localDay lt)) - + fromRational (timeOfDayToDayFraction (localTimeOfDay lt)) - --- | Map a plot cordinate to a LocalTime -localTimeFromDouble :: Double -> LocalTime -localTimeFromDouble v = - LocalTime (ModifiedJulianDay i) (dayFractionToTimeOfDay (toRational d)) - where - (i,d) = properFraction v - --- | TimeSeq is a (potentially infinite) set of times. When passes --- 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 = LocalTime-> ([LocalTime],[LocalTime]) - -coverTS tseq min max = min' ++ enumerateTS tseq min max ++ 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)) - -enumerateTS tseq min max = reverse (takeWhile (>=min) ts1) ++ takeWhile (<=max) ts2 - where - (ts1,ts2) = tseq min - -elemTS t tseq = case tseq t of - (_,(t0:_)) | t == t0 -> True - _ -> False - --- | How to display a time -type TimeLabelFn = LocalTime -> String - --- | Create an 'AxisFn' to for a time axis. The first 'TimeSeq' sets the minor ticks, --- and the ultimate range will aligned to it's elements. The second 'TimeSeq' sets --- the labels and grid. 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 -> AxisFn LocalTime -timeAxis tseq lseq labelf pts = AxisData { - axis_viewport_=vmap(min', max'), - axis_ticks_=[ (t,2) | t <- times] ++ [ (t,5) | t <- ltimes, visible t], - axis_labels_=[ (t,l) | (t,l) <- labels, visible t], - axis_grid_=[ t | t <- ltimes, visible t] - } - where - (min,max) = 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 - min' = minimum times - max' = maximum times - visible t = min' <= t && t <= max' - labels = [ (avg m1 m2, labelf m1) | (m1,m2) <- zip ltimes (tail ltimes) ] - avg m1 m2 = localTimeFromDouble $ m1' + (m2' - m1')/2 - where - m1' = doubleFromLocalTime m1 - m2' = doubleFromLocalTime m2 - --- | 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) - rev = pred - fwd = succ - toTime d = LocalTime d midnight - --- | 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) - rev = addGregorianMonthsClip (-1) - fwd = addGregorianMonthsClip 1 - toTime d = LocalTime d midnight - --- | 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) - rev = pred - fwd = succ - toTime y = LocalTime (fromGregorian y 1 1) midnight - --- | 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 'doubleFromLocalTime' -autoTimeAxis :: AxisFn LocalTime -autoTimeAxis [] = timeAxis days days (formatTime defaultTimeLocale "%d-%b") [] -autoTimeAxis pts = - if tdiff < 15 - then timeAxis days days (ft "%d-%b") pts - else if tdiff < 90 - then timeAxis days months (ft "%b-%y") pts - else if tdiff < 450 - then timeAxis months months (ft "%b-%y") pts - else if tdiff < 1800 - then timeAxis months years (ft "%Y") pts - else timeAxis years years (ft "%Y") pts - where - tdiff = diffDays (localDay t1) (localDay t0) - t1 = maximum pts - t0 = minimum pts - ft = formatTime defaultTimeLocale - ------------------------------------------------------------------------------ - -class Ord a => PlotValue a where - toValue :: a -> Double - autoAxis ::AxisFn a - -instance PlotValue Double where - toValue = id - autoAxis = autoScaledAxis defaultLinearAxis - -newtype LogValue = LogValue Double - deriving (Eq, Ord) - -instance Show LogValue where - show (LogValue x) = show x - -instance PlotValue LogValue where - toValue (LogValue x) = log x - autoAxis = autoScaledLogAxis defaultLogAxis - -instance PlotValue LocalTime where - toValue = doubleFromLocalTime - autoAxis = autoTimeAxis - ----------------------------------------------------------------------- - --- | Type for capturing values plotted by index number --- (ie position in a list) rather than a numerical value -newtype PlotIndex = PlotIndex { plotindex_i :: Int } - deriving (Eq,Ord) - -instance PlotValue PlotIndex where - toValue (PlotIndex i)= fromIntegral i - autoAxis = autoIndexAxis [] - --- | Create an axis for values indexed by position. The --- list of strings are the labels to be used. -autoIndexAxis :: [String] -> [PlotIndex] -> AxisData PlotIndex -autoIndexAxis labels vs = AxisData { - axis_viewport_= vport, - axis_ticks_ = [], - axis_labels_ = filter (\(i,l) -> i >= imin && i <= imax) (addIndexes labels), - axis_grid_ = [] - } - where - vport r (PlotIndex i) = vmap (fi (plotindex_i imin) - 0.5, - fi (plotindex_i imax) + 0.5) r (fi i) - imin = minimum vs - imax = maximum vs - fi = fromIntegral :: Int -> Double - - --- | 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) - - --- | A linear mapping of points in one range to another -vmap :: PlotValue x => (x,x) -> Range -> x -> Double -vmap (v1,v2) (v3,v4) v = v3 + (toValue v - toValue v1) * (v4-v3) / (toValue v2 - toValue v1) - ----------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field -$( deriveAccessors ''AxisData ) -$( deriveAccessors ''AxisStyle ) -$( deriveAccessors ''LinearAxisParams ) -$( deriveAccessors ''LogAxisParams ) - +import Graphics.Rendering.Chart.Axis.Types +import Graphics.Rendering.Chart.Axis.Floating +import Graphics.Rendering.Chart.Axis.Int +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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Axis/Floating.hs @@ -0,0 +1,340 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis.Floating +-- Copyright : (c) Tim Docker 2010, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Calculate and render floating value axes +-- including doubles with linear, log, and percentage scaling. +-- + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Graphics.Rendering.Chart.Axis.Floating( + Percent(..), + LinearAxisParams(..), + LogValue(..), + LogAxisParams(..), + scaledAxis, + autoScaledAxis, + autoScaledLogAxis, + autoSteps, + + la_labelf, + la_nLabels, + la_nTicks, + + loga_labelf +) where + +import Data.List(minimumBy, nub) +import Data.Ord (comparing) +import Data.Default.Class +import Numeric (showEFloat, showFFloat) + +import Control.Lens +import Graphics.Rendering.Chart.Geometry +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 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} + deriving (Eq,Ord,Num,Real,Fractional,RealFrac,Floating,RealFloat) + +instance Show Percent where + show (Percent d) = showD (d*100) ++ "%" + +instance PlotValue Percent where + toValue = unPercent + fromValue= Percent + 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 {unLogValue :: Double} + deriving (Eq, Ord, Num, Real, Fractional, RealFrac, Floating, RealFloat) + +instance Show LogValue where + show (LogValue x) = show x + +instance PlotValue LogValue where + toValue (LogValue x) = log x + fromValue d = LogValue (exp d) + 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 + r -> reverse r + +data LinearAxisParams a = LinearAxisParams { + -- | The function used to show the axes labels. + _la_labelf :: [a] -> [String], + + -- | The target number of labels to be shown. + _la_nLabels :: Int, + + -- | The target number of ticks to be shown. + _la_nTicks :: Int +} + +instance (Show a, RealFloat a) => Default (LinearAxisParams a) where + 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 rs@(minV,maxV) ps0 = makeAxis' realToFrac realToFrac + (_la_labelf lap) (labelvs,tickvs,gridvs) + where + ps = filter isValidNumber ps0 + range [] = (0,1) + 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) + gridvs = labelvs + r = range ps + +-- | Generate a linear axis automatically, scaled appropriately for the +-- input data. +autoScaledAxis :: RealFloat a => LinearAxisParams a -> AxisFn a +autoScaledAxis lap ps0 = scaledAxis lap rs ps + where + ps = filter isValidNumber ps0 + rs = (minimum ps,maximum ps) + +steps :: RealFloat a => a -> (a,a) -> [Rational] +steps nSteps rs@(minV,maxV) = map ((s*) . fromIntegral) [min' .. max'] + where + 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) stepVals + where + delta = x2 - x1 + 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, +-- find evenly spaced values from the set {1*X, 2*X, 2.5*X, 5*X} (where +-- X is some power of ten) that evenly cover the input points. +autoSteps :: Int -> [Double] -> [Double] +autoSteps nSteps vs = map fromRational $ steps (fromIntegral nSteps) r + where + range [] = (0,1) + 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 + +---------------------------------------------------------------------- + +instance (Show a, RealFloat a) => Default (LogAxisParams a) where + def = LogAxisParams + { _loga_labelf = showDs + } + +-- | 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 rlabelvs) + where + ps = filter (\x -> isValidNumber x && 0 < x) ps0 + (minV,maxV) = (minimum ps,maximum ps) + wrap = map fromRational + range [] = (3,30) + 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] +} + +{- + Rules: Do not subdivide between powers of 10 until all powers of 10 + get major ticks. + Do not subdivide between powers of ten as [1,2,4,6,8,10] when + 5 gets a major tick + (i.e. the major ticks need to be a subset of the minor ticks) +-} +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) = pf (log10 a) in + minimum (10:filter (\x -> r <= log10 (fromRational x)) l)*10^^i + + powers :: (Double,Double) -> [Rational] -> [Rational] + powers (x,y) l = [ a*10^^p | p <- [(floor (log10 x))..(ceiling (log10 y))] :: [Integer] + , a <- l ] + midselection r l = filter (inRange r l) (powers r l) + inRange (a,b) l x = (lower a l <= x) && (x <= upper b l) + + logRange = (log10 low, log10 high) + + roundPow x = 10^^(round x :: Integer) + + major | 17.5 < log10 ratio = map roundPow $ + steps (min 5 (log10 ratio)) logRange + | 12 < log10 ratio = map roundPow $ + 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' :: Double + ratio' = fromRational (h'/l') + filterX = filter (\x -> l'<=x && x <=h') . powers (dl',dh') + + minor | 50 < log10 ratio' = map roundPow $ + steps 50 (log10 dl', log10 dh') + | 6 < log10 ratio' = filterX [1,10] + | 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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Axis/Indexed.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis.Unit +-- 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 + +-- | Type for capturing values plotted by index number +-- (ie position in a list) rather than a numerical value. +newtype PlotIndex = PlotIndex { plotindex_i :: Int } + deriving (Eq,Ord,Enum,Num,Real,Integral,Show) + +instance PlotValue PlotIndex where + toValue (PlotIndex i) = fromIntegral i + fromValue = PlotIndex . round + autoAxis = autoIndexAxis [] + +-- | Augment a list of values with index numbers for plotting. +addIndexes :: [a] -> [(PlotIndex,a)] +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 => Bool -> [String] -> AxisFn i +autoIndexAxis' tks labels vs = AxisData { + _axis_visibility = def { _axis_show_ticks = False }, + _axis_viewport = vport, + _axis_tropweiv = invport, + _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 = 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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Axis/Int.hs @@ -0,0 +1,133 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis.Int +-- 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, + scaledIntAxis, + autoScaledIntAxis +) where + +import Data.List(genericLength) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Axis.Types +import Graphics.Rendering.Chart.Axis.Floating + +instance PlotValue Int where + toValue = fromIntegral + 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 + autoAxis = autoScaledIntAxis defaultIntAxis + +defaultIntAxis :: (Show a) => LinearAxisParams a +defaultIntAxis = LinearAxisParams { + _la_labelf = map show, + _la_nLabels = 5, + _la_nTicks = 10 +} + +autoScaledIntAxis :: (Integral i, PlotValue i) => + LinearAxisParams i -> AxisFn i +autoScaledIntAxis lap ps = scaledIntAxis lap rs ps + where + rs = (minimum ps,maximum ps) + +scaledIntAxis :: (Integral i, PlotValue i) => + LinearAxisParams i -> (i,i) -> AxisFn i +scaledIntAxis lap (minI,maxI) ps = + makeAxis (_la_labelf lap) (labelvs,tickvs,gridvs) + where + range [] = (0,1) + 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) + ( fromIntegral $ minimum labelvs + , fromIntegral $ maximum labelvs ) + gridvs = labelvs + r = range ps + +stepsInt :: Integral a => a -> Range -> [a] +stepsInt nSteps range = bestSize (goodness alt0) alt0 alts + 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' + + -- 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 (minV,maxV) = takeWhile ( Double +doubleFromLocalTime lt = fromIntegral (toModifiedJulianDay (localDay lt)) + + fromRational (timeOfDayToDayFraction (localTimeOfDay lt)) + +-- | Map a plot coordinate to a LocalTime. +localTimeFromDouble :: Double -> LocalTime +localTimeFromDouble v = + LocalTime (ModifiedJulianDay i) (dayFractionToTimeOfDay (toRational d)) + where + (i,d) = properFraction 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 = LocalTime-> ([LocalTime],[LocalTime]) + +coverTS :: TimeSeq -> LocalTime -> LocalTime -> [LocalTime] +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 -> LocalTime -> LocalTime -> [LocalTime] +enumerateTS tseq minT maxT = + reverse (takeWhile (>=minT) ts1) ++ takeWhile (<=maxT) ts2 + where + (ts1,ts2) = tseq minT + +elemTS :: LocalTime -> TimeSeq -> Bool +elemTS t tseq = case tseq t of + (_,t0:_) | t == t0 -> True + _ -> False + +-- | How to display a time +type TimeLabelFn = LocalTime -> 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'. +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'), + _axis_tropweiv = invmap(min', max'), + _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 + (minT,maxT) = case pts of + [] -> (refLocalTime,refLocalTime) + ps -> (minimum ps, maximum ps) + refLocalTime = LocalTime (ModifiedJulianDay 0) midnight + 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 = localTimeFromDouble $ m1' + (m2' - m1')/2 + where + m1' = doubleFromLocalTime m1 + m2' = doubleFromLocalTime m2 + +normalizeTimeOfDay :: LocalTime -> LocalTime +normalizeTimeOfDay t@(LocalTime day (TimeOfDay h m s)) + | s < 0 = normalizeTimeOfDay (LocalTime day (TimeOfDay h (m-1) (s+60))) + | m < 0 = normalizeTimeOfDay (LocalTime day (TimeOfDay (h-1) (m+60) s)) + | h < 0 = normalizeTimeOfDay (LocalTime (addDays (-1) day) (TimeOfDay (h+24) m s)) + | s >= 60 = normalizeTimeOfDay (LocalTime day (TimeOfDay h (m+s`div'`60) + (s`mod'`60))) + | m >= 60 = normalizeTimeOfDay (LocalTime day (TimeOfDay (h+m`div`60) + (m`mod`60) s)) + | h >= 24 = LocalTime (addDays (fromIntegral (h`div`24)) day) + (TimeOfDay (h`mod`24) m s) + | otherwise = t + +addTod :: Int -> Int -> Pico -> LocalTime -> LocalTime +addTod dh dm ds (LocalTime day (TimeOfDay h m s)) = normalizeTimeOfDay t' + where t' = LocalTime day (TimeOfDay (h+dh) (m+dm) (s+ds)) + +truncateTo :: (HasResolution a) => Fixed a -> Fixed a -> Fixed a +truncateTo t step = t - t `mod'` step + +secondSeq :: Pico -> TimeSeq +secondSeq step t = (iterate rev t1, tail (iterate fwd t1)) + where h0 = todHour (localTimeOfDay t) + m0 = todMin (localTimeOfDay t) + s0 = todSec (localTimeOfDay t) `truncateTo` (1 / 1000) + t0 = LocalTime (localDay t) (TimeOfDay h0 m0 s0) + t1 = if t0 < t then t0 else rev t0 + rev = addTod 0 0 (negate step) + fwd = addTod 0 0 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 + +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) 0 + fwd = addTod 0 step 0 + +minutes, fiveMinutes :: TimeSeq +minutes = minuteSeq 1 +fiveMinutes = minuteSeq 5 + +-- | A 'TimeSeq' for hours. +hours :: TimeSeq +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 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 + rev = pred + fwd = succ + toTime d = LocalTime d midnight + +-- | 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 $ 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 + +-- | A 'TimeSeq' for calendar years. +years :: TimeSeq +years t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) + 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 _ = ([],[]) + +-- | 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 'doubleFromLocalTime'. +autoTimeAxis :: AxisFn LocalTime +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 + noTime (ft "%S%Q") UnderTicks pts + | 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 + | tdiff==0 && dsec<5 = timeAxis millis100 seconds (ft "%M:%S%Q") UnderTicks + seconds (ft "%M:%S") BetweenTicks pts + | tdiff==0 && dsec<32 = timeAxis seconds seconds (ft "%Ss") UnderTicks + minutes (ft "%d-%b-%y %H:%M") BetweenTicks pts + | tdiff==0 && dsec<120 = timeAxis seconds fiveSeconds (ft "%Ss") UnderTicks + minutes (ft "%d-%b-%y %H:%M") BetweenTicks pts + | tdiff==0 && dmin<7 = timeAxis fiveSeconds minutes (ft "%Mm") UnderTicks + hours (ft "%d-%b-%y %H:00") BetweenTicks pts + | tdiff==0 && dmin<32 = timeAxis minutes minutes (ft "%Mm") UnderTicks + hours (ft "%d-%b-%y %H:00") BetweenTicks pts + | tdiff==0 && dmin<90 = timeAxis minutes fiveMinutes (ft "%Mm") UnderTicks + hours (ft "%d-%b-%y %H:00") BetweenTicks pts + | tdiff < 2 && dhour<4 = timeAxis fiveMinutes hours (ft "%H:%M") UnderTicks + days (ft "%d-%b-%y") BetweenTicks pts + | tdiff < 2 && dhour<32 = timeAxis hours hours (ft "%H:%M") UnderTicks + days (ft "%d-%b-%y") BetweenTicks pts + | tdiff < 4 = timeAxis hours days (ft "%d-%b-%y") BetweenTicks + noTime (ft "") BetweenTicks pts + | tdiff < 12 = timeAxis days days (ft "%d-%b") BetweenTicks + years (ft "%Y") BetweenTicks pts + | tdiff < 45 = timeAxis days days (ft "%d") BetweenTicks + months (ft "%b-%y") BetweenTicks pts + | tdiff < 95 = timeAxis days months (ft "%b-%y") BetweenTicks + noTime (ft "") BetweenTicks pts + | tdiff < 450 = timeAxis months months (ft "%b-%y") BetweenTicks + noTime (ft "") BetweenTicks pts + | tdiff < 735 = timeAxis months months (ft "%b") BetweenTicks + years (ft "%Y") BetweenTicks pts + | tdiff < 1800 = timeAxis months years (ft "%Y") BetweenTicks + noTime (ft "") BetweenTicks pts + | otherwise = timeAxis years years (ft "%Y") BetweenTicks + noTime (ft "") BetweenTicks pts + where + tdiff = diffDays (localDay t1) (localDay t0) + dhour = if tdiff==0 then h1-h0 else 24*fromIntegral tdiff +h1-h0 + dmin = 60*dhour+(m1-m0) + dsec = fromIntegral (60*dmin) + (s1-s0) + (TimeOfDay h0 m0 s0) = localTimeOfDay t0 + (TimeOfDay h1 m1 s1) = localTimeOfDay t1 + t1 = maximum pts + t0 = minimum pts + ft = formatTime defaultTimeLocale + + 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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Axis/Types.hs @@ -0,0 +1,454 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis.Types +-- Copyright : (c) Tim Docker 2006, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Type definitions for Axes +-- + +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Axis.Types( + AxisData(..), + AxisVisibility(..), + AxisT(..), + AxisStyle(..), + PlotValue(..), + AxisFn, + + defaultAxisLineStyle, + defaultGridLineStyle, + + makeAxis, + makeAxis', + + axisToRenderable, + renderAxisGrid, + axisOverhang, + vmap, + invmap, + + linMap, + invLinMap, + + axisGridAtTicks, + axisGridAtBigTicks, + axisGridAtLabels, + axisGridHide, + axisLabelsOverride, + + axis_show_line, + axis_show_ticks, + axis_show_labels, + + axis_visibility, + axis_viewport, + axis_tropweiv, + axis_ticks, + axis_labels, + axis_grid, + + axis_line_style, + axis_label_style, + axis_grid_style, + axis_label_gap, + +) where + +import Control.Monad +import Data.List(sort,intersperse) +import Control.Lens hiding (at, re) +import Data.Colour (opaque) +import Data.Colour.Names (black, lightgrey) +import Data.Default.Class + +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Renderable + +-- | A typeclass abstracting the functions we need +-- to be able to plot against an axis of type a +class Ord a => PlotValue a where + toValue :: a -> Double + fromValue:: Double -> a + autoAxis :: AxisFn a + +-- | Configures whick visual elements of a axis are shown at the +-- appropriate edge of a plot area. +data AxisVisibility = AxisVisibility + { -- | Whether to display a line along the axis. + _axis_show_line :: Bool + + -- | Whether to display the tick marks. + , _axis_show_ticks :: Bool + + -- | Whether to display the labels. + , _axis_show_labels :: Bool + } + +-- | The basic data associated with an axis showing values of type x. +data AxisData x = AxisData { + + -- | Which parts of the axis shall be displayed. + _axis_visibility :: AxisVisibility, + + -- | The _axis_viewport function maps values into device coordinates. + _axis_viewport :: Range -> x -> Double, + + -- | The _axis_tropweiv function maps device coordinates back to values. + _axis_tropweiv :: Range -> Double -> x, + + -- | The tick marks on the axis as pairs. + -- The first element is the position on the axis + -- (in viewport units) and the second element is the + -- length of the tick in output coordinates. + -- The tick starts on the axis, and positive numbers are drawn + -- towards the plot area. + _axis_ticks :: [(x,Double)], + + -- | The labels on an axis as pairs. The first element of the pair + -- is the position on the axis (in viewport units) and the + -- second is the label text string. Note that multiple sets of + -- labels can be specified, and are shown successively further + -- away from the axis line. + _axis_labels :: [[(x, String)]], + + -- | The positions on the axis (in viewport units) where + -- we want to show grid lines. + _axis_grid :: [ x ] +} + +-- | Control values for how an axis gets displayed. +data AxisStyle = AxisStyle { + -- | 'LineStyle' to use for axis line and ticks. + _axis_line_style :: LineStyle, + -- | 'FontStyle' to use for axis labels. + _axis_label_style :: FontStyle, + -- | 'LineStyle' to use for axis grid. + _axis_grid_style :: LineStyle, + + -- | How far the labels are to be drawn from the axis. + _axis_label_gap :: Double +} + +-- | A function to generate the axis data, given the data values +-- to be plotted against it. +type AxisFn x = [x] -> AxisData x + +-- | Collect the information we need to render an axis. The +-- bool is true if the axis direction is reversed. +data AxisT x = AxisT RectEdge AxisStyle Bool (AxisData x) + +-- | Construct a renderable from an axis, in order that +-- it can be composed with other renderables and drawn. This +-- does not include the drawing of the grid, which must be done +-- separately by the `renderAxisGrid` function. +axisToRenderable :: AxisT x -> Renderable x +axisToRenderable at = Renderable { + minsize = minsizeAxis at, + render = renderAxis at + } + +-- | Modifier to remove grid lines from an axis +axisGridHide :: AxisData x -> AxisData x +axisGridHide ad = ad{ _axis_grid = [] } + +-- | Modifier to position grid lines to line up with the ticks +axisGridAtTicks :: AxisData x -> AxisData x +axisGridAtTicks ad = ad{ _axis_grid = map fst (_axis_ticks ad) } + +-- | Modifier to position grid lines to line up with only the major ticks +axisGridAtBigTicks :: AxisData x -> AxisData x +axisGridAtBigTicks ad = ad{ _axis_grid = + map fst $ + filter ((> minimum (map (abs.snd) (_axis_ticks ad))).snd) $ + _axis_ticks ad } + +-- | Modifier to position grid lines to line up with the labels +axisGridAtLabels :: AxisData x -> AxisData x +axisGridAtLabels ad = ad{ _axis_grid = map fst vs } + where + vs = case _axis_labels ad of + [] -> [] + ls -> head ls + +-- | Modifier to change labels on an axis +axisLabelsOverride :: [(x,String)] -> AxisData x -> AxisData x +axisLabelsOverride o ad = ad{ _axis_labels = [o] } + +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) $ + mapM (mapM textDimension) labels + + let ag = _axis_label_gap as + 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) + + let vw = ag + tsize + (sum . intersperse ag . map (maximum0.map fst) $ labelSizes) + 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) + 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 -> BackendProgram (Double,Double) +axisOverhang (AxisT at as _ ad) = do + let labels = map snd . sort . concat . _axis_labels $ ad + labelSizes <- withFontStyle (_axis_label_style as) $ + mapM textDimension labels + case labelSizes of + [] -> return (0,0) + ls -> let l1 = head ls + l2 = last ls + ohangv = return (snd l1 / 2, snd l2 / 2) + ohangh = return (fst l1 / 2, fst l2 / 2) + in case at of + E_Top -> ohangh + E_Bottom -> ohangh + E_Left -> ohangv + E_Right -> ohangh + +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) $ + withLineStyle (ls {_line_cap = LineCapSquare}) $ do + p <- alignStrokePoints [Point sx sy,Point ex ey] + strokePointPath p + when (_axis_show_ticks vis) $ + withLineStyle (ls {_line_cap = LineCapButt}) $ + mapM_ drawTick (_axis_ticks ad) + 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 + let offsets = scanl (+) ag sizes + mapM_ drawLabels (zip offsets (_axis_labels ad)) + return pickfn + where + (sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz + + drawTick (value,len) = + let t1 = axisPoint value + 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) + + avoidOverlaps labels = do + rects <- mapM labelDrawRect labels + return $ map snd . head . filter (noOverlaps . map fst) + $ map (`eachNth` rects) [0 .. length rects] + + labelDrawRect (value,s) = do + let pt = axisPoint value `pvadd` awayFromAxis ag + r <- textDrawRect hta vta pt s + return (hBufferRect r,(value,s)) + + drawLabels (offset,labels) = do + labels' <- avoidOverlaps labels + mapM_ drawLabel labels' + where + drawLabel (value,s) = do + drawTextA hta vta (axisPoint value `pvadd` awayFromAxis offset) s + textDimension s + + ag = _axis_label_gap as + pickfn = Just . invAxisPoint + +hBufferRect :: Rect -> Rect +hBufferRect (Rect p (Point x y)) = Rect p $ Point x' y + where x' = x + w/2 + w = x - p_x p + +noOverlaps :: [Rect] -> Bool +noOverlaps [] = True +noOverlaps [_] = True +noOverlaps (x:y:l) | rectsOverlap x y = False + | otherwise = noOverlaps (y:l) + +rectsOverlap :: Rect -> Rect -> Bool +rectsOverlap (Rect p1 p2) r = any (withinRect r) ps + where (Point x1 y1) = p1 + (Point x2 y2) = p2 + p3 = Point x1 y2 + p4 = Point x2 y1 + ps = [p1,p2,p3,p4] + +eachNth :: Int -> [a] -> [a] +eachNth n = skipN + where + n' = n - 1 + skipN [] = [] + skipN (x:xs) = x : skipN (drop n' xs) + +withinRect :: Rect -> Point -> Bool +withinRect (Rect (Point x1 y1) (Point x2 y2)) (Point x y) + = and [x >= x1 && x <= x2, + y >= y1 && y <= y2] + +axisMapping :: AxisT z -> RectSize + -> (Double,Double,Double,Double,Vector,z->Point,Point->z) +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 = 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) + + imapx (Point x _) = _axis_tropweiv ad xr x + imapy (Point _ y) = _axis_tropweiv ad yr y + + reverseR r@(r0,r1) = if rev then (r1,r0) else r + +-- +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 + (_,_,_,_,_,axisPoint,_) = axisMapping at sz + + drawGridLine E_Top = vline + drawGridLine E_Bottom = vline + drawGridLine E_Left = hline + drawGridLine E_Right = hline + + vline v = let v' = p_x (axisPoint v) + in alignStrokePoints [Point v' 0,Point v' h] >>= strokePointPath + + hline v = let v' = p_y (axisPoint v) + in alignStrokePoints [Point 0 v',Point w v'] >>= strokePointPath + + +-- | 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 labelf (labelvs, tickvs, gridvs) = AxisData { + _axis_visibility = def, + _axis_viewport = newViewport, + _axis_tropweiv = newTropweiv, + _axis_ticks = newTicks, + _axis_grid = gridvs, + _axis_labels = [newLabels] + } + where + newViewport = vmap (min',max') + newTropweiv = invmap (min',max') + newTicks = [ (v,2) | v <- tickvs ] ++ [ (v,5) | 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]) + -> ([x],[x],[x]) -> AxisData x +makeAxis' t f labelf (labelvs, tickvs, gridvs) = AxisData { + _axis_visibility = def, + _axis_viewport = linMap t (minimum labelvs, maximum labelvs), + _axis_tropweiv = invLinMap f t (minimum labelvs, maximum labelvs), + _axis_ticks = zip tickvs (repeat 2) ++ zip labelvs (repeat 5), + _axis_grid = gridvs, + _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)] + } + + +---------------------------------------------------------------------- + +-- | The default 'LineStyle' of an axis. +defaultAxisLineStyle :: LineStyle +defaultAxisLineStyle = solidLine 1 $ opaque black + +-- | The default 'LineStyle' of a plot area grid. +defaultGridLineStyle :: LineStyle +defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey + +instance Default AxisStyle where + def = AxisStyle + { _axis_line_style = defaultAxisLineStyle + , _axis_label_style = def + , _axis_grid_style = defaultGridLineStyle + , _axis_label_gap = 10 + } + +-- | By default all parts of a axis are visible. +instance Default AxisVisibility where + def = AxisVisibility + { _axis_show_line = True + , _axis_show_ticks = True + , _axis_show_labels = True + } + +---------------------------------------------------------------------- + +-- | A linear mapping of points in one range to another. +vmap :: PlotValue x => (x,x) -> Range -> x -> Double +vmap (v1,v2) (v3,v4) v = v3 + (toValue v - toValue v1) * (v4-v3) + / (toValue v2 - toValue v1) + +-- | The inverse mapping from device co-ordinate range back to +-- interesting values. +invmap :: PlotValue x => (x,x) -> Range -> Double -> x +invmap (v3,v4) (d1,d2) d = fromValue (toValue v3 + ( (d-d1) * doubleRange + / (d2-d1) )) + where doubleRange = toValue v4 - toValue v3 + +-- | A linear mapping of points in one range to another. +linMap :: (a -> Double) -> (a,a) -> Range -> a -> Double +linMap f (x1,x2) (d1,d2) x = + d1 + (d2 - d1) * (f x - f x1) / (f x2 - f x1) + +-- | An inverse linear mapping of points from one range to another. +invLinMap :: (Double -> a) -> (a -> Double) -> (a,a) -> Range -> Double -> a +invLinMap f t (v3,v4) (d1,d2) d = + f (t v3 + ( (d-d1) * doubleRange / (d2-d1) )) + where + doubleRange = t v4 - t v3 + +$( makeLenses ''AxisVisibility ) +$( makeLenses ''AxisData ) +$( makeLenses ''AxisStyle ) + diff --git a/Graphics/Rendering/Chart/Axis/Unit.hs b/Graphics/Rendering/Chart/Axis/Unit.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Axis/Unit.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis.Unit +-- Copyright : (c) Tim Docker 2010 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Calculate and render unit indexed axes +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Graphics.Rendering.Chart.Axis.Unit( + unitAxis, +) where + +import Data.Default.Class + +import Graphics.Rendering.Chart.Axis.Types + +instance PlotValue () where + toValue () = 0 + fromValue = const () + autoAxis = const unitAxis + +unitAxis :: AxisData () +unitAxis = AxisData { + _axis_visibility = def + { _axis_show_ticks = False + , _axis_show_labels = False + }, + _axis_viewport = \(x0,x1) _ -> (x0+x1)/2, + _axis_tropweiv = \_ _ -> (), + _axis_ticks = [((), 0)], + _axis_labels = [[((), "")]], + _axis_grid = [] +} diff --git a/Graphics/Rendering/Chart/Backend.hs b/Graphics/Rendering/Chart/Backend.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Backend.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- | +-- 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 + BackendProgram + + -- * Backend Operations + , fillPath + , strokePath + , drawText, textSize + , withTransform + , withClipRegion + , withFontStyle, withFillStyle, withLineStyle + + -- * Backend Helpers +-- , getTransform +-- , getFillStyle, getFontStyle +-- , getLineStyle, getClipRegion + , getPointAlignFn, getCoordAlignFn + + -- * Text Metrics + , TextSize(..) + + -- * Line Types + , LineCap(..) + , LineJoin(..) + , LineStyle(..) + + , line_width + , line_color + , line_dashes + , line_cap + , line_join + + -- * Fill Types + , FillStyle(..) + + -- * Font and Text Types + , FontWeight(..) + , FontSlant(..) + , FontStyle(..) + + , HTextAnchor(..) + , VTextAnchor(..) + + , font_name + , font_size + , font_slant + , font_weight + , font_color + + , AlignmentFn + , AlignmentFns + , vectorAlignmentFns + , bitmapAlignmentFns + ) where + +import Graphics.Rendering.Chart.Backend.Types +import Graphics.Rendering.Chart.Backend.Impl diff --git a/Graphics/Rendering/Chart/Backend/Impl.hs b/Graphics/Rendering/Chart/Backend/Impl.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Backend/Impl.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE GADTs #-} + +----------------------------------------------------------------------------- +-- | +-- 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 Control.Monad +import Control.Monad.Operational + +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Backend.Types + +-- ----------------------------------------------------------------------- +-- Rendering Backend Class +-- ----------------------------------------------------------------------- + +-- | 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 () + GetTextSize :: String -> ChartBackendInstr TextSize + DrawText :: Point -> String -> ChartBackendInstr () + GetAlignments :: ChartBackendInstr AlignmentFns + WithTransform :: Matrix -> Program ChartBackendInstr a -> ChartBackendInstr a + WithFontStyle :: FontStyle -> Program ChartBackendInstr a -> ChartBackendInstr a + WithFillStyle :: FillStyle -> Program ChartBackendInstr a -> ChartBackendInstr a + WithLineStyle :: LineStyle -> Program ChartBackendInstr a -> ChartBackendInstr a + WithClipRegion :: Rect -> Program ChartBackendInstr a -> ChartBackendInstr a + +-- | 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 +-- 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 +-- initially. +-- +-- Information about the semantics of the instructions can be +-- found in the documentation of 'ChartBackendInstr'. +type BackendProgram a = Program ChartBackendInstr a + +-- | 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 -> BackendProgram () +strokePath p = singleton (StrokePath p) + +-- | Fill the given path using the current 'FillStyle'. +-- The given path will be closed prior to filling. +-- This function does /not/ perform +-- alignment operations on the path. +-- See 'Path' for the exact semantic of paths. +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 -> BackendProgram TextSize +textSize text = singleton (GetTextSize text) + +-- | Draw a single-line textual label anchored by the baseline (vertical) +-- left (horizontal) point. Uses the current 'FontStyle' for drawing. +drawText :: Point -> String -> BackendProgram () +drawText p text = singleton (DrawText p text) + +-- | Apply the given transformation in this local +-- environment when drawing. The given transformation +-- is applied after the current transformation. This +-- means both are combined. +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 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 +-- it is required to fall back to a custom fail-safe font +-- and use it instead. +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 -> 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 -> 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 +-- escape the clip! +withClipRegion :: Rect -> BackendProgram a -> BackendProgram a +withClipRegion c p = singleton (WithClipRegion c p) + +-- ----------------------------------------------------------------------- +-- Rendering Utility Functions +-- ----------------------------------------------------------------------- + +-- | Get the point alignment function +getPointAlignFn :: BackendProgram (Point->Point) +getPointAlignFn = liftM afPointAlignFn (singleton GetAlignments) + +-- | Get the coordinate alignment function +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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Backend/Types.hs @@ -0,0 +1,189 @@ +{-# 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 +import Data.Colour +import Data.Colour.Names +import Control.Lens + +import Graphics.Rendering.Chart.Geometry + +-- ----------------------------------------------------------------------- +-- Line Types +-- ----------------------------------------------------------------------- + +-- | The different supported line ends. +data LineCap = LineCapButt -- ^ Just cut the line straight. + | LineCapRound -- ^ Make a rounded line end. + | LineCapSquare -- ^ Make a square that ends the line. + deriving (Show, Eq, Ord) + +-- | The different supported ways to join line ends. +data LineJoin = LineJoinMiter -- ^ Extends the outline until they meet each other. + | LineJoinRound -- ^ Draw a circle fragment to connet line end. + | LineJoinBevel -- ^ Like miter, but cuts it off if a certain + -- threshold is exceeded. + deriving (Show, Eq, Ord) + +-- | Data type for the style of a line. +data LineStyle = LineStyle + { _line_width :: Double + -- ^ The thickness of a line in device units. + , _line_color :: AlphaColour Double + -- ^ The color of a line. + , _line_dashes :: [Double] + -- ^ The dash pattern. Every value at a even index gives a dash width and + -- every value at a odd index gives a gap width in device units. + , _line_cap :: LineCap + -- ^ How to end a line. + , _line_join :: LineJoin + -- ^ How to connect two lines. + } deriving (Show, Eq) + +-- | The default line style. +instance Default LineStyle where + def = LineStyle + { _line_width = 1 + , _line_color = opaque black + , _line_dashes = [] + , _line_cap = LineCapButt + , _line_join = LineJoinBevel + } + +-- ----------------------------------------------------------------------- +-- Font & Text Types +-- ----------------------------------------------------------------------- + +-- | The possible slants of a font. +data FontSlant = FontSlantNormal -- ^ Normal font style without slant. + | FontSlantItalic -- ^ With a slight slant. + | FontSlantOblique -- ^ With a greater slant. + deriving (Show, Eq, Ord) + +-- | The default font slant. +instance Default FontSlant where + def = FontSlantNormal + +-- | The possible weights of a font. +data FontWeight = FontWeightNormal -- ^ Normal font style without weight. + | FontWeightBold -- ^ Bold font. + deriving (Show, Eq, Ord) + +-- | The default font weight. +instance Default FontWeight where + def = FontWeightNormal + +-- | Data type for a font. +data FontStyle = FontStyle { + _font_name :: String, + -- ^ The font family or font face to use. + _font_size :: Double, + -- ^ The height of the rendered font in device coordinates. + _font_slant :: FontSlant, + -- ^ The slant to render with. + _font_weight :: FontWeight, + -- ^ The weight to render with. + _font_color :: AlphaColour Double + -- ^ The color to render text with. +} deriving (Show, Eq) + +-- | The default font style. +instance Default FontStyle where + def = FontStyle + { _font_name = "sans-serif" + , _font_size = 10 + , _font_slant = def + , _font_weight = def + , _font_color = opaque black + } + +-- | Possible horizontal anchor points for text. +data HTextAnchor = HTA_Left + | HTA_Centre + | HTA_Right + deriving (Show, Eq, Ord) + +-- | Possible vertical anchor points for text. +data VTextAnchor = VTA_Top + | VTA_Centre + | VTA_Bottom + | VTA_BaseLine + deriving (Show, Eq, Ord) + +-- | Text metrics returned by 'textSize'. +data TextSize = TextSize + { textSizeWidth :: Double -- ^ The total width of the text. + , textSizeAscent :: Double -- ^ The ascent or space above the baseline. + , textSizeDescent :: Double -- ^ The decent or space below the baseline. + , textSizeYBearing :: Double -- ^ The Y bearing. + , textSizeHeight :: Double -- ^ The total height of the text. + } deriving (Show, Eq) + +-- ----------------------------------------------------------------------- +-- Fill Types +-- ----------------------------------------------------------------------- + +-- | Abstract data type for a fill style. +-- +-- The contained action sets the required fill +-- style in the rendering state. +newtype FillStyle = FillStyleSolid + { _fill_color :: AlphaColour Double + } deriving (Show, Eq) + +-- | The default fill style. +instance Default FillStyle where + def = FillStyleSolid { _fill_color = opaque white } + +------------------------------------------------------------------------- + +-- | A function to align points for a certain rendering device. +type AlignmentFn = Point -> Point + +-- | Holds the point and coordinate alignment function. +data AlignmentFns = AlignmentFns { + afPointAlignFn :: AlignmentFn, + -- ^ An adjustment applied immediately prior to points + -- being displayed in device coordinates. + -- + -- When device coordinates correspond to pixels, a cleaner + -- image is created if this transform rounds to the nearest + -- pixel. With higher-resolution output, this transform can + -- just be the identity function. + -- + -- This is usually used to align prior to stroking. + + -- | The adjustment applied immediately prior to coordinates + -- being transformed. + -- + -- This is usually used to align prior to filling. + afCoordAlignFn :: AlignmentFn + } + +-- | 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 + -- avoid messages about Integer default + rnd :: Double -> Integer + rnd = round + adj v = (fromIntegral.rnd) v +offset + +-- | 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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Drawing.hs @@ -0,0 +1,504 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Drawing +-- Copyright : (c) Tim Docker 2006, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- This module contains basic types and functions used for drawing. +-- +-- Note that Template Haskell is used to derive accessor functions +-- (see 'Control.Lens') for each field of the following data types: +-- +-- * 'PointStyle' +-- +-- 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 +-- +-- @ +-- f :: Control.Lens.Lens' D F +-- @ +-- + +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Drawing + ( -- * Point Types and Drawing + PointShape(..) + , PointStyle(..) + , drawPoint + + -- * Alignments and Paths + , alignPath + , alignFillPath + , alignStrokePath + , alignFillPoints + , alignStrokePoints + + , alignFillPoint + , alignStrokePoint + + , strokePointPath + , fillPointPath + + -- * Transformation and Style Helpers + , withRotation + , withTranslation + , withScale + , withScaleX, withScaleY + , withPointStyle + , withDefaultStyle + + -- * Text Drawing + , drawTextA + , drawTextR + , drawTextsR + , textDrawRect + , textDimension + + -- * Style Helpers + , defaultColorSeq + + , solidLine + , dashedLine + + , filledCircles + , hollowCircles + , filledPolygon + , hollowPolygon + , plusses + , exes + , stars + , arrows + + , solidFillStyle + + -- * Backend and general Types + , module Graphics.Rendering.Chart.Backend + + -- * Accessors + , point_color + , point_border_color + , point_border_width + , point_radius + , point_shape +) where + +import Data.Default.Class +-- 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.Names +import Data.List (unfoldr) + +import Graphics.Rendering.Chart.Backend +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 -> BackendProgram a -> BackendProgram a +withRotation angle = withTransform (rotate angle 1) + +-- | Apply a local translation. +withTranslation :: Point -> BackendProgram a -> BackendProgram a +withTranslation p = withTransform (translate (pointToVec p) 1) + +-- | Apply a local scale. +withScale :: Vector -> BackendProgram a -> BackendProgram a +withScale v = withTransform (scale v 1) + +-- | Apply a local scale on the x-axis. +withScaleX :: Double -> BackendProgram a -> BackendProgram a +withScaleX x = withScale (Vector x 1) + +-- | Apply a local scale on the y-axis. +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 -> 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 :: BackendProgram a -> BackendProgram a +withDefaultStyle = withLineStyle def . withFillStyle def . withFontStyle def + +-- ----------------------------------------------------------------------- +-- Alignment Helpers +-- ----------------------------------------------------------------------- + +-- | Align the path by applying the given function on all points. +alignPath :: (Point -> Point) -> Path -> Path +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. +-- See 'alignPath' and 'getPointAlignFn'. +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. +-- See 'alignPath' and 'getCoordAlignFn'. +alignFillPath :: Path -> BackendProgram Path +alignFillPath p = do + f <- getCoordAlignFn + return $ alignPath f p + +-- | 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] -> BackendProgram [Point] +alignStrokePoints p = do + f <- getPointAlignFn + return $ fmap f p + +-- | The points will be aligned by the 'getCoordAlignFn', so that +-- when drawing bitmaps, the edges of the region will fall between +-- pixels. +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 -> 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 -> 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) = G.moveTo p + <> mconcat (map lineTo ps) +stepPath [] = mempty + +-- | Draw lines between the specified points. +strokePointPath :: [Point] -> BackendProgram () +strokePointPath pts = strokePath $ stepPath pts + +-- | Fill the region with the given corners. +fillPointPath :: [Point] -> BackendProgram () +fillPointPath pts = fillPath $ stepPath pts + +-- ----------------------------------------------------------------------- +-- Text Drawing +-- ----------------------------------------------------------------------- + +-- | Draw a line of text that is aligned at a different anchor point. +-- See 'drawText'. +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 -> BackendProgram () +drawTextR hta vta angle p s = + withTranslation p $ + withRotation theta $ do + ts <- textSize s + drawText (adjustText hta vta ts) s + where + theta = angle*pi/180.0 + +-- | Draw a multi-line 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'. +drawTextsR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> BackendProgram () +drawTextsR hta vta angle p s = case num of + 0 -> return () + 1 -> drawTextR hta vta angle p s + _ -> + withTranslation p $ + withRotation theta $ do + tss <- mapM textSize ss + let ts = head tss + let -- widths = map textSizeWidth tss + -- maxw = maximum widths + maxh = maximum (map textSizeYBearing tss) + gap = maxh / 2 -- half-line spacing + totalHeight = fromIntegral num*maxh + + (fromIntegral num-1)*gap + ys = take num (unfoldr (\y-> Just (y, y-gap-maxh)) + (yinit vta ts totalHeight)) + xs = map (adjustTextX hta) tss + sequence_ (zipWith3 drawT xs ys ss) + where + ss = lines s + num = length ss + + drawT x y = drawText (Point x y) + theta = angle*pi/180.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 + +-- | Calculate the correct offset to align the text anchor. +adjustText :: HTextAnchor -> VTextAnchor -> TextSize -> Point +adjustText hta vta ts = Point (adjustTextX hta ts) (adjustTextY vta ts) + +-- | 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 + +-- | 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_BaseLine _ = 0 +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 -> BackendProgram Rect +textDrawRect hta vta (Point x y) s = do + ts <- textSize s + -- This does not account for the pixel width of the label; e.g. + -- 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 -> BackendProgram RectSize +textDimension s = do + ts <- textSize s + return (textSizeWidth ts, textSizeHeight ts) + +-- ----------------------------------------------------------------------- +-- Point Types and Drawing +-- ----------------------------------------------------------------------- + +-- | The different shapes a point can have. +data PointShape = PointShapeCircle -- ^ A circle. + | PointShapePolygon Int Bool -- ^ Number of vertices and is right-side-up? + | 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 + { _point_color :: AlphaColour Double + -- ^ The color to fill the point with. + , _point_border_color :: AlphaColour Double + -- ^ The color to stroke the outline with. + , _point_border_width :: Double + -- ^ The width of the outline. + , _point_radius :: Double + -- ^ The radius of the tightest surrounding circle of the point. + , _point_shape :: PointShape + -- ^ The shape. + } + +-- | Default style to use for points. +instance Default PointStyle where + def = PointStyle + { _point_color = opaque black + , _point_border_color = transparent + , _point_border_width = 0 + , _point_radius = 1 + , _point_shape = PointShapeCircle + } + +-- | Draw a single point at the given location. +drawPoint :: PointStyle -- ^ Style to use when rendering the point. + -> Point -- ^ Position of the point to render. + -> BackendProgram () +drawPoint ps@(PointStyle cl _ _ r shape) p = withPointStyle ps $ do + p'@(Point x y) <- alignStrokePoint p + case shape of + PointShapeCircle -> do + let path = arc p' r 0 (2*pi) + fillPath path + strokePath path + PointShapePolygon sides isrot -> do + let intToAngle n = + if isrot + then fromIntegral n * 2*pi/fromIntegral sides + else (0.5 + fromIntegral n)*2*pi/fromIntegral sides + angles = map intToAngle [0 .. sides-1] + (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 + 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) + <> lineTo' x (y+r) + PointShapeCross -> do + let rad = r / sqrt 2 + strokePath $ moveTo' (x+rad) (y+rad) + <> lineTo' (x-rad) (y-rad) + <> moveTo' (x+rad) (y-rad) + <> lineTo' (x-rad) (y+rad) + PointShapeStar -> do + let rad = r / sqrt 2 + strokePath $ moveTo' (x+r) y + <> lineTo' (x-r) y + <> moveTo' x (y-r) + <> lineTo' x (y+r) + <> moveTo' (x+rad) (y+rad) + <> 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 +-- ----------------------------------------------------------------------- + +-- | The default sequence of colours to use when plotings different data sets +-- in a graph. +defaultColorSeq :: [AlphaColour Double] +defaultColorSeq = cycle $ map opaque [blue, red, green, yellow, cyan, magenta] + +-- | Create a solid line style (not dashed). +solidLine :: Double -- ^ Width of line. + -> AlphaColour Double -- ^ Colour of line. + -> LineStyle +solidLine w cl = LineStyle w cl [] LineCapButt LineJoinMiter + +-- | Create a dashed line style. +dashedLine :: Double -- ^ Width of line. + -> [Double] -- ^ The dash pattern in device coordinates. + -> AlphaColour Double -- ^ Colour of line. + -> LineStyle +dashedLine w ds cl = LineStyle w cl ds LineCapButt LineJoinMiter + +-- | Style for filled circle points. +filledCircles :: Double -- ^ Radius of circle. + -> AlphaColour Double -- ^ Fill colour. + -> PointStyle +filledCircles radius cl = + PointStyle cl transparent 0 radius PointShapeCircle + +-- | Style for stroked circle points. +hollowCircles :: Double -- ^ Radius of circle. + -> Double -- ^ Thickness of line. + -> AlphaColour Double -- Colour of line. + -> PointStyle +hollowCircles radius w cl = + PointStyle transparent cl w radius PointShapeCircle + +-- | Style for stroked polygon points. +hollowPolygon :: Double -- ^ Radius of circle. + -> Double -- ^ Thickness of line. + -> Int -- ^ Number of vertices. + -> Bool -- ^ Is right-side-up? + -> AlphaColour Double -- ^ Colour of line. + -> PointStyle +hollowPolygon radius w sides isrot cl = + PointStyle transparent cl w radius (PointShapePolygon sides isrot) + +-- | Style for filled polygon points. +filledPolygon :: Double -- ^ Radius of circle. + -> Int -- ^ Number of vertices. + -> Bool -- ^ Is right-side-up? + -> AlphaColour Double -- ^ Fill color. + -> PointStyle +filledPolygon radius sides isrot cl = + PointStyle cl transparent 0 radius (PointShapePolygon sides isrot) + +-- | Plus sign point style. +plusses :: Double -- ^ Radius of tightest surrounding circle. + -> Double -- ^ Thickness of line. + -> AlphaColour Double -- ^ Color of line. + -> PointStyle +plusses radius w cl = + PointStyle transparent cl w radius PointShapePlus + +-- | Cross point style. +exes :: Double -- ^ Radius of circle. + -> Double -- ^ Thickness of line. + -> AlphaColour Double -- ^ Color of line. + -> PointStyle +exes radius w cl = + PointStyle transparent cl w radius PointShapeCross + +-- | Combination of plus and cross point style. +stars :: Double -- ^ Radius of circle. + -> Double -- ^ Thickness of line. + -> AlphaColour Double -- ^ Color of line. + -> PointStyle +stars radius w cl = + PointStyle transparent cl w radius PointShapeStar + +arrows :: Double -- ^ Radius of circle. + -> Double -- ^ Rotation (Tau) + -> Double -- ^ Thickness of line. + -> AlphaColour Double -- ^ Color of line. + -> PointStyle +arrows radius angle w cl = + PointStyle transparent cl w radius (PointShapeArrowHead angle) + +-- | Fill style that fill everything this the given colour. +solidFillStyle :: AlphaColour Double -> FillStyle +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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Geometry.hs @@ -0,0 +1,396 @@ +----------------------------------------------------------------------------- +-- | +-- 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(..) + , Point(..) + , Vector(..) + + , RectSize + , Range + + , pointToVec + + , mkrect + , rectPath + , pvadd + , pvsub + , psub + , vangle + , vlen + , vscale + , within + , intersectRect + + , RectEdge(..) + , Limit(..) + , PointMapFn + + -- * Paths + , Path(..) + , lineTo, moveTo + , lineTo', moveTo' + , arc, arc' + , arcNeg, arcNeg' + , close + + , foldPath + , makeLinesExplicit + + -- * Matrices + , transformP, scaleP, rotateP, translateP + , Matrix(..) + , identity + , rotate, scale, translate + , scalarMultiply + , adjoint + , invert + ) where + +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, + p_y :: Double +} deriving Show + +-- | A vector in two dimensions. +data Vector = Vector { + v_x :: Double, + v_y :: Double +} deriving Show + +-- | Convert a 'Point' to a 'Vector'. +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) + +-- | Add a point and a vector. +pvadd :: Point -> Vector -> Point +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) + +-- | Subtract two points. +psub :: Point -> Point -> Vector +psub (Point x1 y1) (Point x2 y2) = Vector (x1-x2) (y1-y2) + +data Limit a = LMin | LValue a | LMax + deriving Show + +-- | A function mapping between points. +type PointMapFn x y = (Limit x, Limit y) -> Point + +-- | A rectangle is defined by two points. +data Rect = Rect Point Point + deriving Show + +-- | Edge of a rectangle. +data RectEdge = E_Top | E_Bottom | E_Left | E_Right + +-- | Create a rectangle based upon the coordinates of 4 points. +mkrect :: Point -> Point -> Point -> Point -> Rect +mkrect (Point x1 _) (Point _ y2) (Point x3 _) (Point _ y4) = + Rect (Point x1 y2) (Point x3 y4) + +-- | Test if a point is within a rectangle. +within :: Point -> Rect -> Bool +within (Point x y) (Rect (Point x1 y1) (Point x2 y2)) = + x >= x1 && x <= x2 && y >= y1 && y <= y2 + +-- | Intersects the rectangles. If they intersect the +-- intersection rectangle is returned. +-- 'LMin' is the empty rectangle / intersection and +-- 'LMax' is the infinite plane. +intersectRect :: Limit Rect -> Limit Rect -> Limit Rect +intersectRect LMax r = r +intersectRect r LMax = r +intersectRect LMin _ = LMin +intersectRect _ LMin = LMin +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 + then LMin + else LValue $ Rect p1 p2 + +type Range = (Double,Double) +type RectSize = (Double,Double) + +{- +-- | 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 + 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 + in moveTo p1 <> lineTo p2 <> lineTo p3 <> lineTo p4 <> close + +-- ----------------------------------------------------------------------- +-- Path Types +-- ----------------------------------------------------------------------- + +-- | 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 + | LineTo Point Path + | Arc Point Double Double Double Path + | ArcNeg Point Double Double Double Path + | End + | Close + +-- | Paths are monoids. After a path is closed you can not append +-- anything to it anymore. The empty path is open. +-- Use 'close' to close a path. +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. +moveTo :: Point -> Path +moveTo p = MoveTo p mempty + +-- | Short-cut for 'moveTo', if you don't want to create a 'Point'. +moveTo' :: Double -> Double -> Path +moveTo' x y = moveTo $ Point x y + +-- | Move the paths pointer to the given location and draw a straight +-- line while doing so. +lineTo :: Point -> Path +lineTo p = LineTo p mempty + +-- | Short-cut for 'lineTo', if you don't want to create a 'Point'. +lineTo' :: Double -> Double -> Path +lineTo' x y = lineTo $ Point x y + +-- | Draw the arc of a circle. A straight line connects +-- the end of the previous path with the beginning of the arc. +-- The zero angle points in direction of the positive x-axis. +-- Angles increase in clock-wise direction. If the stop angle +-- 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 -- ^ Radius of the circle. + -> Double -- ^ Angle to start drawing at, in radians. + -> Double -- ^ Angle to stop drawing at, in radians. + -> Path +arc p r a1 a2 = Arc p r a1 a2 mempty + +-- | Short-cut for 'arc', if you don't want to create a 'Point'. +arc' :: Double -> Double -> Double -> Double -> Double -> Path +arc' x y r a1 a2 = Arc (Point x y) r a1 a2 mempty + +-- | Like 'arc', but draws from the stop angle to the start angle +-- instead of between them. +arcNeg :: Point -> Double -> Double -> Double -> Path +arcNeg p r a1 a2 = ArcNeg p r a1 a2 mempty + +-- | Short-cut for 'arcNeg', if you don't want to create a 'Point'. +arcNeg' :: Double -> Double -> Double -> Double -> Double -> Path +arcNeg' x y r a1 a2 = ArcNeg (Point x y) r a1 a2 mempty + +-- | A closed empty path. Closes a path when appended. +close :: Path +close = Close + +-- | Fold the given path to a monoid structure. +foldPath :: (Monoid m) + => (Point -> m) -- ^ MoveTo + -> (Point -> m) -- ^ LineTo + -> (Point -> Double -> Double -> Double -> m) -- ^ Arc + -> (Point -> Double -> Double -> Double -> m) -- ^ ArcNeg + -> 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 `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_ + +-- | 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) = + Arc c r s e $ makeLinesExplicit' rest +makeLinesExplicit (ArcNeg c r s e rest) = + ArcNeg c r s e $ makeLinesExplicit' rest +makeLinesExplicit path = makeLinesExplicit' path + +-- | Utility for 'makeLinesExplicit'. +makeLinesExplicit' :: Path -> Path +makeLinesExplicit' End = End +makeLinesExplicit' Close = Close +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) = + let p = translateP (pointToVec c) $ rotateP s $ Point r 0 + in lineTo p <> arcNeg c r s e <> makeLinesExplicit' rest +makeLinesExplicit' (MoveTo p0 rest) = + MoveTo p0 $ makeLinesExplicit' rest +makeLinesExplicit' (LineTo p0 rest) = + LineTo p0 $ makeLinesExplicit' rest + +-- ----------------------------------------------------------------------- +-- Matrix Type +-- ----------------------------------------------------------------------- + +-- | Transform a point using the given matrix. +transformP :: Matrix -> Point -> Point +transformP t (Point x y) = Point + (xx t * x + xy t * y + x0 t) + (yx t * x + yy t * y + y0 t) + +-- | Rotate a point around the origin. +-- The angle is given in radians. +rotateP :: Double -> Point -> Point +rotateP a = transformP (rotate a 1) + +-- | Scale a point. +scaleP :: Vector -> Point -> Point +scaleP s = transformP (scale s 1) + +-- | Translate a point. +translateP :: Vector -> Point -> Point +translateP = flip pvadd + +-- | Copied from Graphics.Rendering.Cairo.Matrix +data Matrix = Matrix { xx :: !Double, yx :: !Double, + xy :: !Double, yy :: !Double, + x0 :: !Double, y0 :: !Double } + deriving Show + +-- | Copied from Graphics.Rendering.Cairo.Matrix +instance Num Matrix where + -- 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 (-) + + negate = pointwise negate + abs = pointwise abs + signum = pointwise signum + + fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0 + +-- | Copied from Graphics.Rendering.Cairo.Matrix +{-# INLINE pointwise #-} +pointwise :: (Double -> Double) -> Matrix -> Matrix +pointwise 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 :: (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 +identity = Matrix 1 0 0 1 0 0 + +-- | 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) + +-- | 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 + +-- | 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 + where s = sin r + c = cos r + +-- | Copied from Graphics.Rendering.Cairo.Matrix +scalarMultiply :: Double -> Matrix -> Matrix +scalarMultiply scalar = pointwise (* scalar) + +-- | Copied from Graphics.Rendering.Cairo.Matrix +adjoint :: Matrix -> Matrix +adjoint (Matrix a b c d tx ty) = + Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty) + +-- | 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_ 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,5 +1,14 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Grid +-- 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, + Grid, Span, SpaceWeight, tval, tspan, empty, nullt, (.|.), (./.), @@ -8,119 +17,169 @@ overlay, width, height, gridToRenderable, - weights + weights, + aboveWide, + wideAbove, + tallBeside, + besideTall, + fullOverlayUnder, + fullOverlayOver ) where -import Data.List import Data.Array --- import qualified Data.Map as Map import Control.Monad -import Numeric import Graphics.Rendering.Chart.Renderable -import Graphics.Rendering.Chart.Types ---import Graphics.Rendering.Chart.Gtk -import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Geometry hiding (x0, y0) +import Graphics.Rendering.Chart.Drawing -type Span = (Int,Int) -type Size = (Int,Int) +type Span = (Int,Int) +type Size = (Int,Int) + +-- | When more space is available for an item than the total width of items, +-- extra added space is proportional to 'space weight'. type SpaceWeight = (Double,Double) -type Cell a = (a,Span,SpaceWeight) +type Cell a = (a,Span,SpaceWeight) -data Grid a = Value (a,Span,SpaceWeight) - | Above (Grid a) (Grid a) Size - | Beside (Grid a) (Grid a) Size - | Overlay (Grid a) (Grid a) Size - | Empty - | Null +-- | Abstract datatype representing a grid. +data Grid a + = Value (a,Span,SpaceWeight) -- ^ A singleton grid item "a" spanning + -- a given rectangle (measured in grid + -- cells), with given space weight. + | Above (Grid a) (Grid a) Size -- ^ One grid above the other. "Size" is + -- their cached total size (so it is + -- NOT specified manually). + | Beside (Grid a) (Grid a) Size -- ^ One grid horizontally beside + -- the other. + | Overlay (Grid a) (Grid a) Size -- ^ Two grids positioned one over + -- the other. + | Empty -- ^ An empty 1x1 grid cell. + | Null -- ^ An empty 0x0 grid cell. deriving (Show) width :: Grid a -> Int -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 Null = 0 +width Empty = 1 +width (Value _) = 1 +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 Null = 0 +height Empty = 1 +height (Value _) = 1 +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 tval a = Value (a,(1,1),(0,0)) +-- | 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)) -empty, nullt :: Grid a +-- | A 1x1 empty grid. +empty :: Grid a empty = Empty + +-- | A 0x0 empty grid. +nullt :: Grid a nullt = Null above, beside :: Grid a -> Grid a -> Grid a above Null t = t above t Null = t -above t1 t2 = Above t1 t2 size +above t1 t2 = Above t1 t2 size where size = (max (width t1) (width t2), height t1 + height t2) - + +-- | 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 + +-- | 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)) + +-- | 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 + +-- | 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)) + +-- | 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) + +-- | 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 + beside Null t = t beside t Null = t -beside t1 t2 = Beside t1 t2 size - where size = (width t1 + width t2, max (height t1) (height t2)) +beside t1 t2 = Beside t1 t2 size + where size = (width t1 + width t2, max (height t1) (height t2)) aboveN, besideN :: [Grid a] -> Grid a -aboveN = foldl above nullt +aboveN = foldl above nullt besideN = foldl beside nullt +-- | One grid over the other. The first argument is shallow, the second is deep. +overlay :: Grid a -> Grid a -> Grid a overlay Null t = t overlay t Null = t -overlay t1 t2 = Overlay t1 t2 size - where size = (max (width t1) (width t2), max (height t1) (height t2)) +overlay t1 t2 = Overlay t1 t2 size + where size = (max (width t1) (width t2), max (height t1) (height t2)) +-- | A synonym for 'beside'. +(.|.) :: Grid a -> Grid a -> Grid a (.|.) = beside + +-- | A synonym for 'above'. +(./.) :: Grid a -> Grid a -> Grid a (./.) = above +-- | 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 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 +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 weights sw (Overlay t1 t2 sz) = Overlay (weights sw t1) (weights sw t2) sz -- fix me, need to make .|. and .||. higher precedence -- than ./. and .//. instance Functor Grid where - fmap f (Value (a,span,ew)) = Value (f a,span,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 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 _ 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)] @@ -132,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 @@ -154,91 +213,108 @@ 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 -gridToRenderable :: Grid (Renderable a) -> Renderable a -gridToRenderable t = Renderable minsizef renderf +getSizes :: Grid (Renderable a) -> BackendProgram (DArray, DArray, DArray, DArray) +getSizes t = do + 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') + let heights = accumArray max 0 (0, height t - 1) + (foldT (ef hf snd) [] szs') + let xweights = accumArray max 0 (0, width t - 1) + (foldT (ef xwf fst) [] szs') + let yweights = accumArray max 0 (0, height t - 1) + (foldT (ef ywf snd) [] szs') + return (widths,heights,xweights,yweights) where - getSizes :: CRender (DArray, DArray, DArray, DArray) - getSizes = do - szs <- mapGridM minsize t :: CRender (Grid RectSize) - let szs' = flatten szs - let widths = accumArray max 0 (0, width t - 1) (foldT (ef wf) [] szs') - let heights = accumArray max 0 (0, height t - 1) (foldT (ef hf) [] szs') - let xweights = accumArray max 0 (0, width t - 1) (foldT (ef xwf) [] szs') - let yweights = accumArray max 0 (0, height t - 1) (foldT (ef ywf) [] szs') - return (widths,heights,xweights,yweights) + wf (x,_) (w,_) _ = (x,w) + hf (_,y) (_,h) _ = (y,h) + xwf (x,_) _ (xw,_) = (x,xw) + ywf (_,y) _ (_,yw) = (y,yw) - 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) + ef f ds loc (size,spn,ew) r | ds spn == 1 = f loc size ew:r + | otherwise = r - ef f loc (size,span,ew) | span == (1,1) = (f loc size ew:) - | otherwise = id - +instance (ToRenderable a) => ToRenderable (Grid a) where + toRenderable = gridToRenderable . fmap toRenderable + +gridToRenderable :: Grid (Renderable a) -> Renderable a +gridToRenderable gt = Renderable minsizef renderf + where + minsizef :: BackendProgram RectSize minsizef = do - (widths, heights, xweights, yweights) <- getSizes + (widths, heights, _, _) <- getSizes gt return (sum (elems widths), sum (elems heights)) renderf (w,h) = do - (widths, heights, xweights, yweights) <- getSizes - let widths' = addExtraSpace w widths xweights + (widths, heights, xweights, yweights) <- getSizes gt + let widths' = addExtraSpace w widths xweights let heights' = addExtraSpace h heights yweights - let csizes = (ctotal widths',ctotal heights') - rf1 csizes (0,0) t + let borders = (ctotal widths',ctotal heights') + rf1 borders (0,0) gt - rf1 csizes loc@(i,j) t = case t of - Null -> return nullPickFn + -- (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 csizes loc span - p0'@(Point x0 y0) <- alignc p0 - p1'@(Point x1 y1) <- alignc p1 - preserveCState $ do - c $ C.translate x0 y0 - render r (x1-x0,y1-y0) + (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 csizes (i,j) t1 - pf2 <- rf1 csizes (i,j+height t1) t2 - let pf p@(Point x y) = if y < (snd csizes ! (j + height t1)) then pf1 p - else pf2 p + pf1 <- rf1 borders (i,j) t1 + pf2 <- rf1 borders (i,j+height t1) t2 + 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 csizes (i,j) t1 - pf2 <- rf1 csizes (i+width t1,j) t2 - let pf p@(Point x y) = if x < (fst csizes ! (i + width t1)) then pf1 p - else pf2 p + pf1 <- rf1 borders (i,j) t1 + pf2 <- rf1 borders (i+width t1,j) t2 + let pf p@(Point x _) = if x < (fst borders ! (i + width t1)) + then pf1 p else pf2 p return pf (Overlay t1 t2 _) -> do - pf2 <- rf1 csizes (i,j) t2 - pf1 <- rf1 csizes (i,j) t1 + pf2 <- rf1 borders (i,j) t2 + pf1 <- rf1 borders (i,j) t1 let pf p = pf1 p `mplus` pf2 p return pf + 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] mkRect :: (DArray, DArray) -> (Int,Int) -> (Int,Int) -> Rect mkRect (cwidths,cheights) (x,y) (w,h) = Rect (Point x1 y1) (Point x2 y2) where - x1 = cwidths ! x + x1 = cwidths ! x y1 = cheights ! y - x2 = cwidths ! min (x+w) (snd $ bounds cwidths) + 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 - sizes' = zipWith (+) extras (elems sizes) + extra = size - sum (elems sizes) + extras = map (*(extra/totalws)) ws + sizes' = zipWith (+) extras (elems sizes) + -- [1,2,3] -> [0,1,3,6]. ctotal :: DArray -> DArray - ctotal a = listArray (let (i,j) = bounds a in (i,j+1)) (scanl (+) 0 (elems a)) + ctotal a = listArray (let (i,j) = bounds a in (i,j+1)) + (scanl (+) 0 (elems a)) diff --git a/Graphics/Rendering/Chart/Gtk.hs b/Graphics/Rendering/Chart/Gtk.hs deleted file mode 100644 --- a/Graphics/Rendering/Chart/Gtk.hs +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Chart.Gtk --- Copyright : (c) Tim Docker 2006 --- License : BSD-style (see chart/COPYRIGHT) - -module Graphics.Rendering.Chart.Gtk( - renderableToWindow - ) where - -import qualified Graphics.UI.Gtk as G -import qualified Graphics.UI.Gtk.Gdk.Events as G -import qualified Graphics.Rendering.Cairo as C -import Graphics.Rendering.Chart -import Graphics.Rendering.Chart.Renderable -import Graphics.Rendering.Chart.Types -import Data.List (isPrefixOf) - --- do action m for any keypress (except meta keys) -anyKey :: (Monad m) => m a -> G.Event -> m Bool -anyKey m (G.Key {G.eventKeyName=key}) - | any (`isPrefixOf` key) ignores = return True - | otherwise = m >> return True - where ignores = ["Shift","Control","Alt", - "Super","Meta","Hyper"] - -renderableToWindow :: Renderable a -> Int -> Int -> IO () -renderableToWindow chart windowWidth windowHeight = do - G.unsafeInitGUIForThreadedRTS - -- G.initGUI - window <- G.windowNew - canvas <- G.drawingAreaNew - -- fix size - -- G.windowSetResizable window False - G.widgetSetSizeRequest window windowWidth windowHeight - -- press any key to quit - G.onKeyPress window $ anyKey (G.widgetDestroy window) - G.onDestroy window G.mainQuit - G.onExpose canvas $ const (updateCanvas chart canvas) - G.set window [G.containerChild G.:= canvas] - G.widgetShowAll window - G.mainGUI - -updateCanvas :: Renderable a -> G.DrawingArea -> IO Bool -updateCanvas chart canvas = do - win <- G.widgetGetDrawWindow canvas - (width, height) <- G.widgetGetSize canvas - let sz = (fromIntegral width,fromIntegral height) - G.renderWithDrawable win $ runCRender (render chart sz) bitmapEnv - return True 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,344 +1,855 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Layout --- Copyright : (c) Tim Docker 2006 --- License : BSD-style (see chart/COPYRIGHT) --- --- This module glues together axes and plots to actually create a renderable --- for a chart. --- --- Note that template haskell is used to derive accessor functions --- (see 'Data.Accessor') for each field of the following data types: --- --- * 'Layout1' --- --- * 'LayoutAxis' --- --- 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 --- --- @ --- f :: Data.Accessor.Accessor D F --- @ --- - -{-# OPTIONS_GHC -XTemplateHaskell #-} - -module Graphics.Rendering.Chart.Layout( - Layout1(..), - LayoutAxis(..), - MAxisFn, - - defaultLayout1, - linkAxes, - independentAxes, - - updateAllAxesStyles, - setLayout1Foreground, - - defaultLayoutAxis, - laxis_title_style, - laxis_title, - laxis_style, - laxis_visible, - laxis_generate, - laxis_override, - laxis_reverse, - - layout1_background, - layout1_plot_background, - layout1_title, - layout1_title_style, - layout1_left_axis, - layout1_right_axis, - layout1_top_axis, - layout1_bottom_axis, - layout1_yaxes_control, - layout1_margin, - layout1_plots, - layout1_legend, - layout1_grid_last - ) where - -import qualified Graphics.Rendering.Cairo as C - -import Graphics.Rendering.Chart.Axis -import Graphics.Rendering.Chart.Types -import Graphics.Rendering.Chart.Plot -import Graphics.Rendering.Chart.Legend -import Graphics.Rendering.Chart.Renderable -import Graphics.Rendering.Chart.Grid -import Control.Monad -import Control.Monad.Reader (local) -import Data.Accessor.Template -import Data.Accessor -import Data.Colour -import Data.Colour.Names (white) - --- | A @MAxisFn@ is a function that generates an (optional) axis --- given the points plotted against that axis. -type MAxisFn t = [t] -> Maybe (AxisData t) - -data LayoutAxis x = LayoutAxis { - laxis_title_style_ :: CairoFontStyle, - laxis_title_ :: String, - laxis_style_ :: AxisStyle, - - -- | function that determines whether an axis should be visible, - -- based upon the points plotted on this axis. The default value - -- is 'not.null' - laxis_visible_ :: [x] -> Bool, - - -- | function that generates the axis data, based upon the - -- points plotted. The default value is 'autoAxis'. - laxis_generate_ :: AxisFn x, - - -- | function that can be used to override the generated axis data. - -- The default value is 'id'. - laxis_override_ :: AxisData x -> AxisData x, - - -- | True if left to right (bottom to top) is to show descending values - laxis_reverse_ :: Bool - -} - --- | A Layout1 value is a single plot area, with optional: axes on --- each of the 4 sides; title at the top; legend at the bottom. It's --- parameterised by the types of values to be plotted on the horizonal --- and vertical axes. -data Layout1 x y = Layout1 { - - layout1_background_ :: CairoFillStyle, - layout1_plot_background_ :: Maybe CairoFillStyle, - - layout1_title_ :: String, - layout1_title_style_ :: CairoFontStyle, - - layout1_bottom_axis_ :: LayoutAxis x, - layout1_top_axis_ :: LayoutAxis x, - layout1_left_axis_ :: LayoutAxis y, - layout1_right_axis_ :: LayoutAxis y, - - -- | function to map points from the left/right plot - -- to the left/right axes. The default value is 'id' - layout1_yaxes_control_ :: ([y],[y]) -> ([y],[y]), - - layout1_margin_ :: Double, - layout1_plots_ :: [Either (Plot x y) (Plot x y)], - layout1_legend_ :: Maybe(LegendStyle), - - -- | True if the grid is to be rendered on top of the Plots - layout1_grid_last_ :: Bool -} - -data Layout1Pick x y = L1P_Legend String - | L1P_PlotArea x y y - | L1P_BottomAxis x - | L1P_TopAxis x - | L1P_LeftAxis y - | L1P_RightAxis y - -instance (Ord x, Ord y) => ToRenderable (Layout1 x y) where - toRenderable = setPickFn nullPickFn.layout1ToRenderable - -layout1ToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable (Layout1Pick x y) -layout1ToRenderable l = - fillBackground (layout1_background_ l) ( - gridToRenderable $ aboveN [ - tval $ addMargins (lm/2,0,0,0) title, - weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) plotArea, - tval $ legends - ] ) - where - title = label (layout1_title_style_ l) HTA_Centre VTA_Centre (layout1_title_ l) - - plotArea = gridToRenderable (layer2 `overlay` layer1) - - layer1 = aboveN [ - besideN [er, er, er ], - besideN [er, er, er ], - besideN [er, er, weights (1,1) plots ] - ] - - layer2 = aboveN [ - besideN [er, er, ttitle, er, er ], - besideN [er, tl, taxis, tr, er ], - besideN [ltitle, laxis, er, raxis, rtitle ], - besideN [er, bl, baxis, br, er ], - besideN [er, er, btitle, er, er ] - ] - - ttitle = atitle HTA_Centre VTA_Bottom 0 layout1_top_axis_ - btitle = atitle HTA_Centre VTA_Top 0 layout1_bottom_axis_ - ltitle = atitle HTA_Right VTA_Centre 90 layout1_left_axis_ - rtitle = atitle HTA_Left VTA_Centre 90 layout1_right_axis_ - - er = tval $ emptyRenderable - - atitle ha va rot af = if ttext == "" then er else tval $ rlabel tstyle ha va rot ttext - where - tstyle = laxis_title_style_ (af l) - ttext = laxis_title_ (af l) - - plots = tval $ mfill (layout1_plot_background_ l) $ plotsToRenderable l - where - mfill Nothing = id - mfill (Just fs) = fillBackground fs - - (ba,la,ta,ra) = getAxes l - baxis = tval $ maybe emptyRenderable (mapPickFn L1P_BottomAxis . axisToRenderable) ba - taxis = tval $ maybe emptyRenderable (mapPickFn L1P_TopAxis . axisToRenderable) ta - laxis = tval $ maybe emptyRenderable (mapPickFn L1P_LeftAxis . axisToRenderable) la - raxis = tval $ maybe emptyRenderable (mapPickFn L1P_RightAxis . axisToRenderable) ra - - tl = tval $ axesSpacer fst ta fst la - bl = tval $ axesSpacer fst ba snd la - tr = tval $ axesSpacer snd ta fst ra - br = tval $ axesSpacer snd ba snd ra - - legends = gridToRenderable (besideN [ tval $ mkLegend lefts, - weights (1,1) $ tval $ emptyRenderable, - tval $ mkLegend rights ]) - lefts = concat [ plot_legend_ p | (Left p) <- (layout1_plots_ l) ] - rights = concat [ plot_legend_ p | (Right p) <- (layout1_plots_ l) ] - - mkLegend vals = case (layout1_legend_ l) of - Nothing -> emptyRenderable - (Just ls) -> case filter ((/="").fst) vals of - [] -> emptyRenderable - lvs -> addMargins (0,lm,lm,lm) - (mapPickFn L1P_Legend $ legendToRenderable (Legend True ls lvs)) - - lm = layout1_margin_ l - -plotsToRenderable :: Layout1 x y -> Renderable (Layout1Pick x y) -plotsToRenderable l = Renderable { - minsize=return (0,0), - render= renderPlots l - } - -renderPlots :: Layout1 x y -> RectSize -> CRender (PickFn (Layout1Pick x y)) -renderPlots l sz@(w,h) = do - when (not (layout1_grid_last_ l)) renderGrids - preserveCState $ do - -- render the plots - setClipRegion (Point 0 0) (Point w h) - mapM_ rPlot (layout1_plots_ l) - when (layout1_grid_last_ l) renderGrids - return nullPickFn - - where - (bAxis,lAxis,tAxis,rAxis) = getAxes l - - rPlot (Left p) = rPlot1 bAxis lAxis p - rPlot (Right p) = rPlot1 bAxis rAxis p - - rPlot1 (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p = - let xrange = if xrev then (w, 0) else (0,w) - yrange = if yrev then (0, h) else (h, 0) - pmfn (x,y) = Point (mapv xrange (axis_viewport_ xaxis xrange) x) - (mapv yrange (axis_viewport_ yaxis yrange) y) - mapv (min,max) _ LMin = min - mapv (min,max) _ LMax = max - mapv _ f (LValue v) = f v - in plot_render_ p pmfn - rPlot1 _ _ _ = return () - - renderGrids = do - maybeM () (renderAxisGrid sz) tAxis - maybeM () (renderAxisGrid sz) bAxis - maybeM () (renderAxisGrid sz) lAxis - maybeM () (renderAxisGrid sz) rAxis - -axesSpacer f1 a1 f2 a2 = embedRenderable $ do - oh1 <- maybeM (0,0) axisOverhang a1 - oh2 <- maybeM (0,0) axisOverhang a2 - return (spacer (f1 oh1, f2 oh2)) - -getAxes :: Layout1 x y -> (Maybe (AxisT x), Maybe (AxisT y), Maybe (AxisT x), Maybe (AxisT y)) -getAxes l = (bAxis,lAxis,tAxis,rAxis) - where - (xvals0,xvals1,yvals0,yvals1) = allPlottedValues (layout1_plots_ l) - xvals = xvals0 ++ xvals1 - (yvals0',yvals1') = layout1_yaxes_control_ l (yvals0,yvals1) - - bAxis = mkAxis E_Bottom (layout1_bottom_axis_ l) xvals - tAxis = mkAxis E_Top (layout1_top_axis_ l) xvals - lAxis = mkAxis E_Left (layout1_left_axis_ l) yvals0' - rAxis = mkAxis E_Right (layout1_right_axis_ l) yvals1' - - mkAxis t laxis vals = case laxis_visible_ laxis vals of - False -> Nothing - True -> Just (AxisT t style rev adata) - where - style = laxis_style_ laxis - rev = laxis_reverse_ laxis - adata = (laxis_override_ laxis) (laxis_generate_ laxis vals) - -allPlottedValues :: [(Either (Plot x y) (Plot x' y'))] -> ( [x], [x'], [y], [y'] ) -allPlottedValues plots = (xvals0,xvals1,yvals0,yvals1) - where - xvals0 = [ x | (Left p) <- plots, x <- fst $ plot_all_points_ p] - yvals0 = [ y | (Left p) <- plots, y <- snd $ plot_all_points_ p] - xvals1 = [ x | (Right p) <- plots, x <- fst $ plot_all_points_ p] - yvals1 = [ y | (Right p) <- plots, y <- snd $ plot_all_points_ p] - -defaultLayout1 :: (PlotValue x,PlotValue y) => Layout1 x y -defaultLayout1 = Layout1 { - layout1_background_ = solidFillStyle $ opaque white, - layout1_plot_background_ = Nothing, - - layout1_title_ = "", - layout1_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold}, - - layout1_top_axis_ = defaultLayoutAxis { - laxis_visible_ = const False - }, - layout1_bottom_axis_ = defaultLayoutAxis, - layout1_left_axis_ = defaultLayoutAxis, - layout1_right_axis_ = defaultLayoutAxis, - - layout1_yaxes_control_ = id, - - layout1_margin_ = 10, - layout1_plots_ = [], - layout1_legend_ = Just defaultLegendStyle, - layout1_grid_last_ = False -} - -defaultLayoutAxis :: PlotValue t => LayoutAxis t -defaultLayoutAxis = LayoutAxis { - laxis_title_style_ = defaultFontStyle{font_size_=10}, - laxis_title_ = "", - laxis_style_ = defaultAxisStyle, - laxis_visible_ = not.null, - laxis_generate_ = autoAxis, - laxis_override_ = id, - laxis_reverse_ = False -} - ----------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field -$( deriveAccessors ''Layout1 ) -$( deriveAccessors ''LayoutAxis ) - --- | Helper to update all axis styles on a Layout1 simultaneously -updateAllAxesStyles :: (AxisStyle -> AxisStyle) -> Layout1 x y -> Layout1 x y -updateAllAxesStyles uf = (layout1_top_axis .> laxis_style ^: uf) . - (layout1_bottom_axis .> laxis_style ^: uf) . - (layout1_left_axis .> laxis_style ^: uf) . - (layout1_right_axis .> laxis_style ^: uf) - --- | Helper to set the forground color uniformly on a Layout1 -setLayout1Foreground :: AlphaColour Double -> Layout1 x y -> Layout1 x y -setLayout1Foreground fg = updateAllAxesStyles ( - (axis_line_style .> line_color ^= fg). - (axis_label_style .> font_color ^= fg) - ) - . (layout1_title_style .> font_color ^= fg) - . (layout1_legend ^: fmap (legend_label_style .> font_color ^= fg)) - - -linkAxes (ys1,ys2) = (ys1++ys2,ys1++ys2) -independentAxes (ys1,ys2) = (ys1,ys2) +-- Copyright : (c) Tim Docker 2006, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- This module glues together axes and plots to actually create a renderable +-- for a chart. +-- +-- Note that Template haskell is used to derive accessor functions +-- (see 'Control.Lens') for each field of the following data types: +-- +-- * 'Layout' +-- +-- * 'LayoutLR' +-- +-- * 'StackedLayouts' +-- +-- * 'LayoutAxis' +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Graphics.Rendering.Chart.Layout + ( -- * Types + Layout(..) + , LayoutLR(..) + , LayoutAxis(..) + , LayoutPick(..) + , StackedLayouts(..) + , StackedLayout(..) + -- , LegendItem haddock complains about this being missing, but from what? + , MAxisFn + + -- * Rendering + , layoutToRenderable + , layoutToGrid + , layoutLRToRenderable + , layoutLRToGrid + , renderStackedLayouts + + -- * LayoutAxis lenses + , laxis_title_style + , laxis_title + , laxis_style + , laxis_generate + , laxis_override + , laxis_reverse + + -- * Layout lenses + , layout_background + , layout_plot_background + , layout_title + , layout_title_style + , layout_x_axis + , layout_top_axis_visibility + , layout_bottom_axis_visibility + , layout_y_axis + , layout_left_axis_visibility + , layout_right_axis_visibility + , layout_margin + , 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 + , layoutlr_title_style + , layoutlr_x_axis + , layoutlr_top_axis_visibility + , layoutlr_bottom_axis_visibility + , layoutlr_left_axis + , layoutlr_right_axis + , layoutlr_left_axis_visibility + , layoutlr_right_axis_visibility + , layoutlr_plots + , layoutlr_legend + , layoutlr_margin + , layoutlr_grid_last + + , layoutlr_axes_styles + , layoutlr_axes_title_styles + , layoutlr_all_font_styles + , layoutlr_foreground + + -- * StackedLayouts lenses + , slayouts_layouts + , slayouts_compress_legend + ) 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 +import Graphics.Rendering.Chart.Utils +import Graphics.Rendering.Chart.Plot +import Graphics.Rendering.Chart.Legend +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Grid +import Control.Monad +import Control.Lens hiding (at) +import Data.Colour +import Data.Colour.Names (white) +import Data.Default.Class + +-- | A @MAxisFn@ is a function that generates an (optional) axis +-- given the points plotted against that axis. +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 +-- settings of the axis. +data LayoutAxis x = LayoutAxis + { _laxis_title_style :: FontStyle + -- ^ Font style to use for the axis title. + , _laxis_title :: String + -- ^ Title displayed for the axis. + , _laxis_style :: AxisStyle + -- ^ Axis style applied. + + , _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. + deriving (Show) + +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 + { _layout_background :: FillStyle + -- ^ How to fill the background of everything. + , _layout_plot_background :: Maybe FillStyle + -- ^ How to fill the background of the plot, + -- if different from the overall background. + + , _layout_title :: String + -- ^ Title to display above the chart. + , _layout_title_style :: FontStyle + -- ^ Font style to use for the title. + + , _layout_x_axis :: LayoutAxis x + -- ^ Rules to generate the x axis. + , _layout_top_axis_visibility :: AxisVisibility + -- ^ Visibility options for the top axis. + , _layout_bottom_axis_visibility :: AxisVisibility + -- ^ Visibility options for the bottom axis. + + , _layout_y_axis :: LayoutAxis y + -- ^ Rules to generate the y axis. + , _layout_left_axis_visibility :: AxisVisibility + -- ^ Visibility options for the left axis. + , _layout_right_axis_visibility :: AxisVisibility + -- ^ Visibility options for the right axis. + + , _layout_plots :: [Plot x y] + -- ^ The data sets to plot in the chart. + -- They are plotted over each other. + + , _layout_legend :: Maybe LegendStyle + -- ^ How to style the legend. + , _layout_margin :: Double + -- ^ The margin distance to use. + , _layout_grid_last :: Bool + -- ^ If the grid shall be rendered + -- beneath (@False@) or over (@True@) all plots. + } + +instance (Ord x, Ord y) => ToRenderable (Layout x y) where + toRenderable = setPickFn nullPickFn . layoutToRenderable + +-- | 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) + +layoutToGrid :: forall x y . (Ord x, Ord y) => Layout x y -> Grid (Renderable (LayoutPick x y y)) +layoutToGrid l = grid + where + 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) + +-- | Extract all 'LegendItem's from the plots of a 'Layout'. +getLegendItems :: Layout x y -> [LegendItem] +getLegendItems l = concat [ _plot_legend p | p <- _layout_plots l ] + +-- | Render the given 'LegendItem's for a 'Layout'. +renderLegend :: Layout x y -> [LegendItem] -> Renderable (LayoutPick x y y) +renderLegend l legItems = gridToRenderable g + where + g = besideN [ tval $ mkLegend (_layout_legend l) (_layout_margin l) legItems + , weights (1,1) $ tval emptyRenderable ] + +-- | Render the plot area of a 'Layout'. This consists of the +-- 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)) +layoutPlotAreaToGrid l = buildGrid LayoutGridElements{ + lge_plots = mfill (_layout_plot_background l) $ plotsToRenderable l, + lge_taxis = (tAxis,_laxis_title $ _layout_x_axis l, _laxis_title_style $ _layout_x_axis l), + lge_baxis = (bAxis,_laxis_title $ _layout_x_axis l, _laxis_title_style $ _layout_x_axis l), + lge_laxis = (lAxis,_laxis_title $ _layout_y_axis l, _laxis_title_style $ _layout_y_axis l), + lge_raxis = (rAxis,"", def), + 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] + + 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 + lAxis = mkAxis E_Left (overrideAxisVisibility l _layout_y_axis _layout_left_axis_visibility ) yvals + rAxis = mkAxis E_Right (overrideAxisVisibility l _layout_y_axis _layout_right_axis_visibility ) yvals + axes = (bAxis,lAxis,tAxis,rAxis) + + plotsToRenderable lxy = Renderable { + minsize = return (0,0), + render = renderPlots lxy + } + + -- | Render the plots of a 'Layout' to a plot area of given size. + 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 = renderSinglePlot sz bAxis lAxis + + xr = (0, w) + yr = (h, 0) + + pickfn :: PickFn (LayoutPick x y y) + pickfn (Point x y) = do -- Maybe monad + xat <- mxat + yat <- myat + return (LayoutPick_PlotArea (mapx xat x) (mapy yat y) (mapy yat y)) + where + mxat = case (bAxis,tAxis) of + (Just at,_) -> Just at + (_,Just at) -> Just at + (Nothing,Nothing) -> Nothing + myat = case (lAxis,rAxis) of + (Just at,_) -> Just at + (_,Just at) -> Just at + (Nothing,Nothing) -> Nothing + 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 +-- 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 + def = Layout + { _layout_background = solidFillStyle $ opaque white + , _layout_plot_background = Nothing + + , _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 + , _axis_show_labels = False } + , _layout_bottom_axis_visibility = def + , _layout_y_axis = def + , _layout_left_axis_visibility = def + , _layout_right_axis_visibility = def { _axis_show_line = False + , _axis_show_ticks = False + , _axis_show_labels = False } + + , _layout_margin = 10 + , _layout_plots = [] + , _layout_legend = Just def + , _layout_grid_last = False + } + +---------------------------------------------------------------------- + +-- | 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 + { _layoutlr_background :: FillStyle + -- ^ How to fill the background of everything. + , _layoutlr_plot_background :: Maybe FillStyle + -- ^ How to fill the background of the plot, + -- if different from the overall background. + + , _layoutlr_title :: String + -- ^ Title to display above the chart. + , _layoutlr_title_style :: FontStyle + -- ^ Font style to use for the title. + + , _layoutlr_x_axis :: LayoutAxis x + -- ^ Rules to generate the x axis. + , _layoutlr_top_axis_visibility :: AxisVisibility + -- ^ Visibility options for the top axis. + , _layoutlr_bottom_axis_visibility :: AxisVisibility + -- ^ Visibility options for the bottom axis. + + , _layoutlr_left_axis :: LayoutAxis y1 + -- ^ Rules to generate the left y axis. + , _layoutlr_left_axis_visibility :: AxisVisibility + -- ^ Visibility options for the left axis. + , _layoutlr_right_axis :: LayoutAxis y2 + -- ^ 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. + -- They are plotted over each other. + -- The either type associates the plot with the + -- left or right y axis. + + , _layoutlr_legend :: Maybe LegendStyle + -- ^ How to style the legend. + , _layoutlr_margin :: Double + -- ^ The margin distance to use. + , _layoutlr_grid_last :: Bool + -- ^ If the grid shall be rendered + -- beneath (@False@) or over (@True@) all plots. + } + +instance (Ord x, Ord yl, Ord yr) => ToRenderable (LayoutLR x yl yr) where + toRenderable = setPickFn nullPickFn . layoutLRToRenderable + +-- | Render the given 'LayoutLR'. +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) + $ gridToRenderable (layoutLRToGrid 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] +getLayoutLRXVals l = concatMap deEither $ _layoutlr_plots l + where + deEither :: Either (Plot x yl) (Plot x yr) -> [x] + deEither (Left x) = fst $ _plot_all_points x + deEither (Right x) = fst $ _plot_all_points x + +-- | Extract all 'LegendItem's from the plots of a 'LayoutLR'. +-- 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 ] + ) + +-- | Render the given 'LegendItem's for a 'LayoutLR'. +renderLegendLR :: LayoutLR x yl yr -> ([LegendItem],[LegendItem]) -> Renderable (LayoutPick x yl yr) +renderLegendLR l (lefts,rights) = gridToRenderable g + where + g = besideN [ tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) lefts + , weights (1,1) $ tval emptyRenderable + , tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) rights ] + -- lm = _layoutlr_margin l + +layoutLRPlotAreaToGrid :: forall x yl yr. (Ord x, Ord yl, Ord yr) + => LayoutLR x yl yr + -> Grid (Renderable (LayoutPick x yl yr)) +layoutLRPlotAreaToGrid l = buildGrid LayoutGridElements{ + lge_plots = mfill (_layoutlr_plot_background l) $ plotsToRenderable l, + lge_taxis = (tAxis,_laxis_title $ _layoutlr_x_axis l, _laxis_title_style $ _layoutlr_x_axis l), + lge_baxis = (bAxis,_laxis_title $ _layoutlr_x_axis l, _laxis_title_style $ _layoutlr_x_axis l), + lge_laxis = (lAxis,_laxis_title $ _layoutlr_left_axis l, _laxis_title_style $ _layoutlr_left_axis l), + lge_raxis = (rAxis,_laxis_title $ _layoutlr_right_axis l, _laxis_title_style $ _layoutlr_right_axis l), + lge_margin = _layoutlr_margin l + } + where + xvals = [ x | (Left p) <- _layoutlr_plots l, x <- fst $ _plot_all_points p] + ++ [ 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 llr = Renderable { + minsize = return (0,0), + render = renderPlots llr + } + + 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 + rPlot (Right p) = renderSinglePlot sz bAxis rAxis p + + xr = (0, w) + yr = (h, 0) + + pickfn (Point x y) = do -- Maybe monad + xat <- mxat + (yatL,yatR) <- myats + return (LayoutPick_PlotArea (mapx xat x) (mapy yatL y) (mapy yatR y)) + where + mxat = case (bAxis,tAxis) of + (Just at,_) -> Just at + (_,Just at) -> Just at + (Nothing,Nothing) -> Nothing + myats = case (lAxis,rAxis) of + (Just at1,Just at2) -> Just (at1,at2) + (_,_) -> Nothing + mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr) + mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr) + +---------------------------------------------------------------------- + +-- | A layout with its y type hidden, so that it can be stacked +-- with other layouts with differing y axis, but the same x axis. +-- See 'StackedLayouts'. +data StackedLayout x = forall y . (Ord y) => StackedLayout (Layout x y) + -- ^ A 'Layout' to stack. + | forall yl yr . (Ord yl, Ord yr) => StackedLayoutLR (LayoutLR x yl yr) + -- ^ A 'LayoutLR' to stack. + +-- | A container for a set of vertically 'StackedLayout's. +-- The x axis of the different layouts will be aligned. +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. + } + +-- | 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. +-- +-- The legends from all the charts may be optionally combined, and shown +-- once on the bottom chart. See 'StackedLayouts' for further information. +renderStackedLayouts :: forall x. (Ord x) => StackedLayouts x -> Renderable () +renderStackedLayouts (StackedLayouts{_slayouts_layouts=[]}) = emptyRenderable +renderStackedLayouts slp@(StackedLayouts{_slayouts_layouts=sls@(sl1:_)}) = gridToRenderable g + 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) + `aboveWide` + (if showLegend then legendR else emptyRenderable) + where + titleR = case sl of + StackedLayout l -> noPickFn $ titleToRenderable (_layout_margin l) (_layout_title_style l) (_layout_title l) + StackedLayoutLR l -> noPickFn $ titleToRenderable (_layoutlr_margin l) (_layoutlr_title_style l) (_layoutlr_title l) + 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 + $ l { _layout_x_axis = axis } + StackedLayoutLR l -> fmap noPickFn + $ layoutLRPlotAreaToGrid + $ l { _layoutlr_x_axis = axis } + + showLegend = not (null (fst legenditems)) || not (null (snd legenditems)) + + isBottomPlot = i == length sls - 1 + + 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 + { _laxis_generate = const (_laxis_generate xAxis all_xvals) } + + bg = case sl1 of + StackedLayout l -> _layout_background l + StackedLayoutLR l -> _layoutlr_background l + + getXVals :: StackedLayout x -> [x] + getXVals (StackedLayout l) = getLayoutXVals l + getXVals (StackedLayoutLR l) = getLayoutLRXVals l + + all_xvals = concatMap getXVals sls + + allLegendItems = (concatMap (fst.legendItems) sls, concatMap (snd.legendItems) sls) + + legendItems :: StackedLayout x -> ([LegendItem], [LegendItem]) + legendItems (StackedLayout l) = (getLegendItems l, []) + legendItems (StackedLayoutLR l) = getLegendItemsLR l + + noPickFn :: Renderable a -> Renderable () + noPickFn = mapPickFn (const ()) + +---------------------------------------------------------------------- + +addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a) + -> Grid (Renderable a) +addMarginsToGrid (t,b,l,r) g = aboveN [ + besideN [er, ts, er], + besideN [ls, g, rs], + besideN [er, bs, er] + ] + where + er = empty + ts = tval $ spacer (0,t) + ls = tval $ spacer (l,0) + bs = tval $ spacer (0,b) + rs = tval $ spacer (r,0) + +titleToRenderable :: Double -> FontStyle -> String -> Renderable (LayoutPick x yl yr) +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 mls lm vals = case mls of + Nothing -> emptyRenderable + Just ls -> case filter ((/="").fst) vals of + [] -> emptyRenderable ; + lvs -> addMargins (0,lm,lm,lm) $ + mapPickFn LayoutPick_Legend $ legendToRenderable (Legend ls lvs) + + +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), + lge_raxis :: (Maybe (AxisT yr),String,FontStyle), + + lge_margin :: Double +} + +buildGrid :: (Ord x, Ord yl, Ord yr) => LayoutGridElements x yl yr -> Grid (Renderable (LayoutPick x yl yr)) +buildGrid lge = layer2 `overlay` layer1 + where + layer1 = aboveN + [ besideN [er, er, er, er ] + , besideN [er, er, er, weights (1,1) plots ] + ] + + layer2 = aboveN + [ besideN [er, er, tl, taxis, tr, er, er ] + , besideN [ltitle, lam, laxis, er, raxis, ram, rtitle ] + , besideN [er, er, bl, baxis, br, er, er ] + , besideN [er, er, er, btitle, er, er, er ] + ] + + er = tval emptyRenderable + + plots = tval $ lge_plots 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 + (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 + (mapPickFn LayoutPick_XTopAxis . axisToRenderable) tdata + laxis = tval $ maybe emptyRenderable + (mapPickFn LayoutPick_YLeftAxis . axisToRenderable) ldata + raxis = tval $ maybe emptyRenderable + (mapPickFn LayoutPick_YRightAxis . axisToRenderable) rdata + + tl = tval $ axesSpacer fst tdata fst ldata + bl = tval $ axesSpacer fst bdata snd ldata + tr = tval $ axesSpacer snd tdata fst rdata + br = tval $ axesSpacer snd bdata snd rdata + + mktitle :: HTextAnchor -> VTextAnchor + -> Double + -> String -> FontStyle + -> (String -> LayoutPick x yl yr) + -> ( Grid (Renderable (LayoutPick x yl yr)) + , Grid (Renderable (LayoutPick x yl yr)) ) + mktitle ha va rot lbl style pf = if lbl == "" then (er,er) else (labelG,gapG) + where + 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)) -> BackendProgram () +renderGrids sz (bAxis, lAxis, tAxis, rAxis) = do + maybeM () (renderAxisGrid sz) tAxis + maybeM () (renderAxisGrid sz) bAxis + maybeM () (renderAxisGrid sz) lAxis + maybeM () (renderAxisGrid sz) rAxis + +-- | Swap the contents of the pair depending on the flag. +optPairReverse :: Bool -> (a,a) -> (a,a) +optPairReverse rev (a,b) = if rev then (b,a) else (a,b) + +-- | 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 -> 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) + pmfn (x,y) = Point (mapv xr (_axis_viewport xaxis xr) x) + (mapv yr (_axis_viewport yaxis yr) y) + 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) + => ((Double, Double) -> Double) -> Maybe (AxisT x) + -> ((Double, Double) -> Double) -> Maybe (AxisT y) + -> Renderable a +axesSpacer f1 a1 f2 a2 = embedRenderable $ do + oh1 <- maybeM (0,0) axisOverhang a1 + oh2 <- maybeM (0,0) axisOverhang a2 + return (spacer (f1 oh1, f2 oh2)) + +-- | 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 = 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) + 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 = + let vis = selVis ly + in (selAxis ly) { _laxis_override = (\ad -> ad { _axis_visibility = vis }) + . _laxis_override (selAxis ly) + } + +mfill :: Maybe FillStyle -> Renderable a -> Renderable a +mfill Nothing = id +mfill (Just fs) = fillBackground fs + +-- | 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 + def = LayoutLR + { _layoutlr_background = solidFillStyle $ opaque white + , _layoutlr_plot_background = Nothing + + , _layoutlr_title = "" + , _layoutlr_title_style = def { _font_size = 15 + , _font_weight = FontWeightBold } + + , _layoutlr_x_axis = def + , _layoutlr_top_axis_visibility = def { _axis_show_line = False + , _axis_show_ticks = False + , _axis_show_labels = False } + , _layoutlr_bottom_axis_visibility = def + + , _layoutlr_left_axis = def + , _layoutlr_left_axis_visibility = def + , _layoutlr_right_axis = def + , _layoutlr_right_axis_visibility = def + + , _layoutlr_plots = [] + + , _layoutlr_legend = Just def + , _layoutlr_margin = 10 + , _layoutlr_grid_last = False + } + +instance PlotValue t => Default (LayoutAxis t) where + def = LayoutAxis + { _laxis_title_style = def { _font_size=10 } + , _laxis_title = "" + , _laxis_style = def + , _laxis_generate = autoAxis + , _laxis_override = id + , _laxis_reverse = False + } + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. +$( makeLenses ''Layout ) +$( makeLenses ''LayoutLR ) +$( makeLenses ''LayoutAxis ) +$( makeLenses ''StackedLayouts ) + +-- | 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) + +-- | 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) + +-- | 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) + +-- | 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,28 +1,32 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Legend --- Copyright : (c) Tim Docker 2006 +-- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) - -{-# OPTIONS_GHC -XTemplateHaskell #-} +-- +-- Types and functions for handling the legend(s) on a chart. A legend +-- is an area on the chart used to label the plotted values. +{-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Chart.Legend( Legend(..), LegendStyle(..), - defaultLegendStyle, + LegendOrientation(..), + LegendPosition(..), legendToRenderable, legend_label_style, legend_margin, legend_plot_size, + legend_orientation, + legend_position ) where -import qualified Graphics.Rendering.Cairo as C -import Control.Monad -import Data.List (nub, partition,intersperse) -import Data.Accessor.Template +import Data.List (partition,intersperse) +import Control.Lens +import Data.Default.Class -import Graphics.Rendering.Chart.Types -import Graphics.Rendering.Chart.Plot +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Grid @@ -30,51 +34,92 @@ -- Legend data LegendStyle = LegendStyle { - legend_label_style_ :: CairoFontStyle, - legend_margin_ :: Double, - legend_plot_size_ :: Double + _legend_label_style :: FontStyle, + _legend_margin :: Double, + _legend_plot_size :: Double, + _legend_orientation :: LegendOrientation, + _legend_position :: LegendPosition } -data Legend x y = Legend Bool LegendStyle [(String, Rect -> CRender ())] +-- | Legends can be constructed in two orientations: in rows +-- (where we specify the maximum number of columns), and in +-- columns (where we specify the maximum number of rows) +data LegendOrientation = LORows Int + | LOCols Int +-- | 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 + toRenderable = setPickFn nullPickFn . legendToRenderable legendToRenderable :: Legend x y -> Renderable String -legendToRenderable (Legend _ ls lvs) = gridToRenderable grid +legendToRenderable (Legend ls lvs) = gridToRenderable grid where - grid = besideN $ intersperse ggap1 (map (tval.rf) ps) + grid :: Grid (Renderable String) + grid = case _legend_orientation ls of + LORows n -> mkGrid n aboveG besideG + LOCols n -> mkGrid n besideG aboveG - ps :: [(String, [Rect -> CRender ()])] - ps = join_nub lvs + aboveG, besideG :: [Grid (Renderable String)] -> Grid (Renderable String) + aboveG = aboveN.intersperse ggap1 + besideG = besideN.intersperse ggap1 - rf (title,rfs) = gridToRenderable grid1 + 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 -> BackendProgram ()])] + ps = join_nub lvs + + rf :: (String, [Rect -> BackendProgram ()]) -> Grid (Renderable String) + rf (title,rfs) = besideN [gpic,ggap2,gtitle] where - grid1 = besideN $ intersperse ggap2 (map rp rfs) ++ [ggap2,gtitle] + gpic :: Grid (Renderable String) + gpic = besideN $ intersperse ggap2 (map rp rfs) + + gtitle :: Grid (Renderable String) gtitle = tval $ lbl title - rp rfn = tval $ Renderable { - minsize = return (legend_plot_size_ ls, 0), - render = \(w,h) -> do - rfn (Rect (Point 0 0) (Point w h)) - return nullPickFn - } - ggap1 = tval $ spacer (legend_margin_ ls,0) + 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)) + 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_Centre VTA_Centre s + lbl :: String -> Renderable String + lbl = label (_legend_label_style ls) HTA_Left VTA_Centre + +groups :: Int -> [a] -> [[a]] +groups _ [] = [] +groups n vs = let (vs1,vs2) = splitAt n vs in vs1:groups n vs2 + 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 [] = [] +join_nub [] = [] -defaultLegendStyle = LegendStyle { - legend_label_style_=defaultFontStyle, - legend_margin_=20, - legend_plot_size_=20 -} +instance Default LegendStyle where + def = LegendStyle + { _legend_label_style = def + , _legend_margin = 20 + , _legend_plot_size = 20 + , _legend_orientation = LORows 4 + , _legend_position = LegendBelow + } ----------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field -$( deriveAccessors ''LegendStyle ) +$( makeLenses ''LegendStyle ) diff --git a/Graphics/Rendering/Chart/Pie.hs b/Graphics/Rendering/Chart/Pie.hs deleted file mode 100644 --- a/Graphics/Rendering/Chart/Pie.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# OPTIONS_GHC -XTemplateHaskell #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Chart.Layout --- Copyright : (c) Tim Docker 2008 --- License : BSD-style (see chart/COPYRIGHT) --- --- A basic pie chart. --- --- Note that template haskell is used to derive accessor functions --- (see 'Data.Accessor') for each field of the following data types: --- --- * 'PieLayout' --- --- * 'PieChart' --- --- * 'PieItem' --- --- 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 --- --- @ --- f :: Data.Accessor.Accessor D F --- @ --- - - -module Graphics.Rendering.Chart.Pie( - PieLayout(..), - PieChart(..), - PieItem(..), - defaultPieLayout, - defaultPieChart, - defaultPieItem, - - 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 qualified Graphics.Rendering.Cairo as C - -import Data.List -import Data.Bits -import Data.Accessor.Template -import Data.Colour -import Data.Colour.Names (black, white) -import Control.Monad - -import Graphics.Rendering.Chart.Types -import Graphics.Rendering.Chart.Legend -import Graphics.Rendering.Chart.Renderable -import Graphics.Rendering.Chart.Grid - -data PieLayout = PieLayout { - pie_title_ :: String, - pie_title_style_ :: CairoFontStyle, - pie_plot_ :: PieChart, - pie_background_ :: CairoFillStyle, - pie_margin_ :: Double -} - -data PieChart = PieChart { - pie_data_ :: [PieItem], - pie_colors_ :: [AlphaColour Double], - pie_label_style_ :: CairoFontStyle, - pie_label_line_style_ :: CairoLineStyle, - pie_start_angle_ :: Double - -} - -data PieItem = PieItem { - pitem_label_ :: String, - pitem_offset_ :: Double, - pitem_value_ :: Double -} - -defaultPieChart = PieChart { - pie_data_ = [], - pie_colors_ = defaultColorSeq, - pie_label_style_ = defaultFontStyle, - pie_label_line_style_ = solidLine 1 $ opaque black, - pie_start_angle_ = 0 -} - -defaultPieItem = PieItem "" 0 0 - -defaultPieLayout = PieLayout { - pie_background_ = solidFillStyle $ opaque white, - pie_title_ = "", - pie_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold}, - pie_plot_ = defaultPieChart, - pie_margin_ = 10 -} - -instance ToRenderable PieLayout where - toRenderable p = fillBackground (pie_background_ p) ( - gridToRenderable $ aboveN [ - tval $ addMargins (lm/2,0,0,0) title, - weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) (toRenderable $ pie_plot_ p) - ] ) - where - title = label (pie_title_style_ p) HTA_Centre VTA_Top (pie_title_ p) - lm = pie_margin_ p - -instance ToRenderable PieChart where - toRenderable p = Renderable { - minsize=minsizePie p, - render=renderPie p - } - -extraSpace p = do - textSizes <- mapM textSize (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 p = do - (extraw,extrah) <- extraSpace p - return (extraw * 2, extrah * 2) - -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) -> CRender 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 -> CRender () - pieLabel name angle offset = do - setFontStyle (pie_label_style_ p) - setLineStyle (pie_label_line_style_ p) - - moveTo (ray angle (radius + label_rgap+offset)) - let p1 = (ray angle (radius + label_rgap + label_rlength+offset)) - lineTo p1 - (tw,th) <- textSize name - let (offset,anchor) = if angle < 90 || angle > 270 - then ((0+),HTA_Left) - else ((0-),HTA_Right) - c $ C.relLineTo (offset (tw + label_rgap)) 0 - c $ C.stroke - - let p2 = p1 `pvadd` (Vector (offset label_rgap) 0) - drawText anchor VTA_Bottom p2 name - - pieSlice :: Point -> Double -> Double -> AlphaColour Double -> CRender () - pieSlice (Point x y) a1 a2 color = c $ do - C.newPath - C.arc x y radius (radian a1) (radian a2) - C.lineTo x y - C.lineTo x y - C.closePath - - setSourceColor color - C.fillPreserve - C.setSourceRGBA 1 1 1 0.1 - - C.stroke - - 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 - ----------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field -$( deriveAccessors ''PieLayout ) -$( deriveAccessors ''PieChart ) -$( deriveAccessors ''PieItem ) - 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 @@ -4,525 +4,35 @@ -- Copyright : (c) Tim Docker 2006 -- License : BSD-style (see chart/COPYRIGHT) -- --- Definitions of various types of Plots we can put on a 2D Chart. --- --- Note that template haskell is used to derive accessor functions --- (see 'Data.Accessor') for each field of the following data types: --- --- * 'Plot' --- --- * 'PlotLines' --- --- * 'PlotPoints' --- --- * 'PlotFillBetween' --- --- * 'PlotErrBars' --- --- * 'PlotBars' --- --- 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 --- --- @ --- f :: Data.Accessor.Accessor D F --- @ +-- Code to calculate and render various types of plots. -- - -{-# OPTIONS_GHC -XTemplateHaskell #-} - module Graphics.Rendering.Chart.Plot( - Plot(..), - ToPlot(..), - PlotPoints(..), - PlotErrBars(..), - PlotLines(..), - PlotFillBetween(..), - ErrPoint(..), - PlotBars(..), - PlotBarsStyle(..), - PlotBarsSpacing(..), - - symErrPoint, - - defaultPlotLineStyle, - defaultPlotPoints, - defaultPlotErrBars, - defaultPlotFillBetween, - defaultPlotLines, - defaultPlotBars, - - plot_lines_title, - plot_lines_style, - plot_lines_values, - plot_lines_limit_values, - - hlinePlot, - vlinePlot, - - plot_render, - plot_legend, - plot_all_points, - - plot_points_title, - plot_points_style, - plot_points_values, - - plot_fillbetween_title, - plot_fillbetween_style, - plot_fillbetween_values, - - plot_errbars_title, - plot_errbars_line_style, - plot_errbars_tick_length, - plot_errbars_overhang, - plot_errbars_values, - - plotBars, - plot_bars_style, - plot_bars_item_styles, - plot_bars_titles, - plot_bars_spacing, - plot_bars_reference, - plot_bars_values, - - ) where - -import qualified Graphics.Rendering.Cairo as C -import Graphics.Rendering.Chart.Types -import Graphics.Rendering.Chart.Axis -import Control.Monad -import Data.List -import Data.Accessor.Template -import Data.Colour -import Data.Colour.SRGB (sRGB) -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 -> CRender (), - - -- | 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 -> CRender ()) ], - - -- | All of the model space coordinates to be plotted. These are - -- used to autoscale the axes where necessary. - plot_all_points_ :: ([x],[y]) -} - --- | a type class abstracting the conversion of a value to a Plot. -class ToPlot a where - toPlot :: a x y -> Plot x y - ----------------------------------------------------------------------- - -mapXY :: PointMapFn x y -> ((x,y) -> Point) -mapXY f (x,y) = f (LValue x, LValue y) - ----------------------------------------------------------------------- - --- | Value defining a series of (possibly disjointed) lines, --- and a style in which to render them -data PlotLines x y = PlotLines { - plot_lines_title_ :: String, - plot_lines_style_ :: CairoLineStyle, - plot_lines_values_ :: [[(x,y)]], - plot_lines_limit_values_ :: [[(Limit x, Limit y)]] -} - - -instance ToPlot PlotLines where - toPlot p = Plot { - plot_render_ = renderPlotLines p, - plot_legend_ = [(plot_lines_title_ p, renderPlotLegendLines p)], - plot_all_points_ = (map fst pts ++ xs , map snd pts ++ ys) - } - where - pts = concat (plot_lines_values_ p) - 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 -> CRender () -renderPlotLines p pmap = preserveCState $ do - setLineStyle (plot_lines_style_ p) - mapM_ (drawLines (mapXY pmap)) (plot_lines_values_ p) - mapM_ (drawLines pmap) (plot_lines_limit_values_ p) - where - drawLines pmap (p:ps) = do - moveTo (pmap p) - mapM_ (\p -> lineTo (pmap p)) ps - c $ C.stroke - -renderPlotLegendLines :: PlotLines x y -> Rect -> CRender () -renderPlotLegendLines p r@(Rect p1 p2) = preserveCState $ do - setLineStyle (plot_lines_style_ p) - let y = (p_y p1 + p_y p2) / 2 - moveTo (Point (p_x p1) y) - lineTo (Point (p_x p2) y) - c $ C.stroke - -defaultPlotLineStyle = (solidLine 1 $ opaque blue){ - line_cap_ = C.LineCapRound, - line_join_ = C.LineJoinRound - } - -defaultPlotLines = PlotLines { - plot_lines_title_ = "", - plot_lines_style_ = defaultPlotLineStyle, - plot_lines_values_ = [], - plot_lines_limit_values_ = [] -} - --- | Helper function to plot a single horizontal line -hlinePlot :: String -> CairoLineStyle -> b -> Plot a b -hlinePlot t ls v = toPlot defaultPlotLines { - plot_lines_title_=t, - plot_lines_style_=ls, - plot_lines_limit_values_=[[(LMin, LValue v),(LMax, LValue v)]] - } - --- | Helper function to plot a single vertical line -vlinePlot :: String -> CairoLineStyle -> a -> Plot a b -vlinePlot t ls v = toPlot defaultPlotLines { - plot_lines_title_=t, - plot_lines_style_=ls, - plot_lines_limit_values_=[[(LValue v,LMin),(LValue v,LMax)]] - } - ----------------------------------------------------------------------- - --- | Value defining a series of datapoints, and a style in --- which to render them -data PlotPoints x y = PlotPoints { - plot_points_title_ :: String, - plot_points_style_ :: CairoPointStyle, - plot_points_values_ :: [(x,y)] -} - - -instance ToPlot PlotPoints where - toPlot p = Plot { - plot_render_ = renderPlotPoints p, - plot_legend_ = [(plot_points_title_ p, renderPlotLegendPoints p)], - plot_all_points_ = (map fst pts, map snd pts) - } - where - pts = plot_points_values_ p - -renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> CRender () -renderPlotPoints p pmap = preserveCState $ do - mapM_ (drawPoint.pmap') (plot_points_values_ p) - where - pmap' = mapXY pmap - (CairoPointStyle drawPoint) = (plot_points_style_ p) - - -renderPlotLegendPoints :: PlotPoints x y -> Rect -> CRender () -renderPlotLegendPoints p r@(Rect p1 p2) = preserveCState $ do - drawPoint (Point (p_x p1) ((p_y p1 + p_y p2)/2)) - drawPoint (Point ((p_x p1 + p_x p2)/2) ((p_y p1 + p_y p2)/2)) - drawPoint (Point (p_x p2) ((p_y p1 + p_y p2)/2)) - - where - (CairoPointStyle drawPoint) = (plot_points_style_ p) - -defaultPlotPoints = PlotPoints { - plot_points_title_ = "", - plot_points_style_ =defaultPointStyle, - plot_points_values_ = [] -} ----------------------------------------------------------------------- --- | Value specifying a plot filling the area between two sets of Y --- coordinates, given common X coordinates. - -data PlotFillBetween x y = PlotFillBetween { - plot_fillbetween_title_ :: String, - plot_fillbetween_style_ :: CairoFillStyle, - plot_fillbetween_values_ :: [ (x, (y,y))] -} - - -instance ToPlot PlotFillBetween where - toPlot p = Plot { - plot_render_ = renderPlotFillBetween p, - plot_legend_ = [(plot_fillbetween_title_ p, renderPlotLegendFill p)], - plot_all_points_ = plotAllPointsFillBetween p - } - -renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> CRender () -renderPlotFillBetween p pmap = renderPlotFillBetween' p (plot_fillbetween_values_ p) pmap - -renderPlotFillBetween' p [] _ = return () -renderPlotFillBetween' p vs pmap = preserveCState $ do - setFillStyle (plot_fillbetween_style_ p) - moveTo p0 - mapM_ lineTo p1s - mapM_ lineTo (reverse p2s) - lineTo p0 - c $ C.fill - where - pmap' = mapXY pmap - (p0:p1s) = map pmap' [ (x,y1) | (x,(y1,y2)) <- vs ] - p2s = map pmap' [ (x,y2) | (x,(y1,y2)) <- vs ] - -renderPlotLegendFill :: PlotFillBetween x y -> Rect -> CRender () -renderPlotLegendFill p r = preserveCState $ do - setFillStyle (plot_fillbetween_style_ p) - rectPath r - c $ C.fill - -plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y]) -plotAllPointsFillBetween p = ([x|(x,(_,_)) <- pts], concat [[y1,y2]|(_,(y1,y2)) <- pts]) - where - pts = plot_fillbetween_values_ p - - -defaultPlotFillBetween = PlotFillBetween { - plot_fillbetween_title_ = "", - plot_fillbetween_style_ = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0), - plot_fillbetween_values_= [] -} - ----------------------------------------------------------------------- - --- | Value for holding a point with associated error bounds for --- each axis. - -data ErrValue x = ErrValue { - ev_low :: x, - ev_best :: x, - ev_high :: x -} deriving Show - -data ErrPoint x y = ErrPoint { - ep_x :: ErrValue x, - ep_y :: ErrValue y -} deriving Show - --- | When the error is symetric, we can simply pass in dx for the error -symErrPoint x y dx dy = ErrPoint (ErrValue (x-dx) x (x+dx)) - (ErrValue (y-dy) y (y+dy)) - --- | Value defining a series of error intervals, and a style in --- which to render them -data PlotErrBars x y = PlotErrBars { - plot_errbars_title_ :: String, - plot_errbars_line_style_ :: CairoLineStyle, - plot_errbars_tick_length_ :: Double, - plot_errbars_overhang_ :: Double, - plot_errbars_values_ :: [ErrPoint x y] -} - - -instance ToPlot PlotErrBars where - toPlot p = Plot { - plot_render_ = renderPlotErrBars p, - plot_legend_ = [(plot_errbars_title_ p,renderPlotLegendErrBars p)], - plot_all_points_ = ( concat [[ev_low x,ev_high x] |ErrPoint x _ <-pts ], - concat [[ev_low y,ev_high y] |ErrPoint _ y <-pts ] ) - } - where - pts = plot_errbars_values_ p - -renderPlotErrBars :: PlotErrBars x y -> PointMapFn x y -> CRender () -renderPlotErrBars p pmap = preserveCState $ do - mapM_ (drawErrBar.epmap) (plot_errbars_values_ p) - where - epmap (ErrPoint (ErrValue xl x xh) (ErrValue yl y yh)) = - ErrPoint (ErrValue xl' x' xh') (ErrValue yl' y' yh') - where (Point x' y') = pmap' (x,y) - (Point xl' yl') = pmap' (xl,yl) - (Point xh' yh') = pmap' (xh,yh) - drawErrBar = drawErrBar0 p - pmap' = mapXY pmap - -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 - setLineStyle (plot_errbars_line_style_ ps) - c $ C.newPath - c $ C.moveTo (xl-oh) y - c $ C.lineTo (xh+oh) y - c $ C.moveTo x (yl-oh) - c $ C.lineTo x (yh+oh) - c $ C.moveTo xl (y-tl) - c $ C.lineTo xl (y+tl) - c $ C.moveTo (x-tl) yl - c $ C.lineTo (x+tl) yl - c $ C.moveTo xh (y-tl) - c $ C.lineTo xh (y+tl) - c $ C.moveTo (x-tl) yh - c $ C.lineTo (x+tl) yh - c $ C.stroke - -renderPlotLegendErrBars :: PlotErrBars x y -> Rect -> CRender () -renderPlotLegendErrBars p r@(Rect p1 p2) = preserveCState $ 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) - - where - drawErrBar = drawErrBar0 p - dx = min ((p_x p2 - p_x p1)/6) ((p_y p2 - p_y p1)/2) - -defaultPlotErrBars = PlotErrBars { - plot_errbars_title_ = "", - plot_errbars_line_style_ = solidLine 1 $ opaque blue, - plot_errbars_tick_length_ = 3, - plot_errbars_overhang_ = 0, - plot_errbars_values_ = [] -} - ----------------------------------------------------------------------- - -class PlotValue a => BarsPlotValue a where - barsReference :: a - barsAdd :: a -> a -> a - -instance BarsPlotValue Double where - barsReference = 0 - barsAdd = (+) - -data PlotBarsStyle = BarsStacked | BarsClustered -data PlotBarsSpacing = BarsFixWidth Double - | BarsFixGap Double - --- | 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 { - -- | This value specifies whether each value from [y] should be - -- shown beside or above the previous value. - plot_bars_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_ :: [ (CairoFillStyle,Maybe CairoLineStyle) ], - - -- | The title of each element of [y]. These will be shown in the - -- legend. - plot_bars_titles_ :: [String], - - -- | 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, - - -- | The starting level for the chart (normally 0). - plot_bars_reference_ :: y, - - -- | The actual points to be plotted - plot_bars_values_ :: [ (x,[y]) ] -} - -defaultPlotBars :: BarsPlotValue y => PlotBars x y -defaultPlotBars = PlotBars { - plot_bars_style_ = BarsClustered, - plot_bars_item_styles_ = cycle istyles, - plot_bars_titles_ = [], - plot_bars_spacing_ = BarsFixGap 10, - plot_bars_values_ = [], - plot_bars_reference_ = barsReference - } - where - istyles = map mkstyle defaultColorSeq - mkstyle c = (solidFillStyle c,Just (solidLine 1.0 $ opaque black)) - -plotBars :: (BarsPlotValue y) => PlotBars x y -> Plot x y -plotBars p = Plot { - plot_render_ = renderPlotBars p, - plot_legend_ = zip (plot_bars_titles_ p) (map renderPlotLegendBars (plot_bars_item_styles_ p)), - plot_all_points_ = allBarPoints p - } - -renderPlotBars :: BarsPlotValue y => PlotBars x y -> PointMapFn x y -> CRender () -renderPlotBars p pmap = case (plot_bars_style_ p) of - BarsClustered -> do forM_ vals clusteredBars - BarsStacked -> forM_ vals stackedBars - where - clusteredBars (x,ys) = preserveCState $ do - forM_ (zip3 [0,1..] ys styles) $ \(i, y, (fstyle,_)) -> do - setFillStyle fstyle - barPath (offset i) x yref0 y - c $ C.fill - forM_ (zip3 [0,1..] ys styles) $ \(i, y, (_,mlstyle)) -> do - whenJust mlstyle $ \lstyle -> do - setLineStyle lstyle - barPath (offset i) x yref0 y - c $ C.stroke - - offset i = fromIntegral (2*i-nys) * width/2 - - stackedBars (x,ys) = preserveCState $ do - let y2s = zip (yref0:stack ys) (stack ys) - forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> do - setFillStyle fstyle - barPath (-width/2) x y0 y1 - c $ C.fill - forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> do - whenJust mlstyle $ \lstyle -> do - setLineStyle lstyle - barPath (-width/2) x y0 y1 - c $ C.stroke - - 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')) - - yref0 = plot_bars_reference_ p - vals = plot_bars_values_ p - width = case plot_bars_spacing_ p of - BarsFixGap gap -> case (plot_bars_style_ p) of - BarsClustered -> (minXInterval - gap) / fromIntegral nys - BarsStacked -> (minXInterval - gap) - BarsFixWidth width -> width - styles = plot_bars_item_styles_ p - - minXInterval = minimum $ zipWith (-) (tail xs) xs - where - xs = nub $ sort $ map (\x-> p_x (pmap' (x,barsReference))) (fst (allBarPoints p)) - - nys = maximum [ length ys | (x,ys) <- vals ] - - pmap' = mapXY pmap - -whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () -whenJust (Just a) f = f a -whenJust _ _ = return () - -allBarPoints :: (BarsPlotValue y) => PlotBars x y -> ([x],[y]) -allBarPoints p = case (plot_bars_style_ p) of - BarsClustered -> ( [x| (x,_) <- pts], concat [ys| (_,ys) <- pts] ) - BarsStacked -> ( [x| (x,_) <- pts], concat [stack ys | (_,ys) <- pts] ) - where - pts = plot_bars_values_ p - y0 = plot_bars_reference_ p - -stack :: (BarsPlotValue y) => [y] -> [y] -stack ys = scanl1 barsAdd ys - - -renderPlotLegendBars :: (CairoFillStyle,Maybe CairoLineStyle) -> Rect -> CRender () -renderPlotLegendBars (fstyle,mlstyle) r@(Rect p1 p2) = do - setFillStyle fstyle - rectPath r - c $ C.fill + 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, + module Graphics.Rendering.Chart.Plot.Candle, + module Graphics.Rendering.Chart.Plot.Bars, + module Graphics.Rendering.Chart.Plot.Hidden, + 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 ----------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field -$( deriveAccessors ''Plot ) -$( deriveAccessors ''PlotLines ) -$( deriveAccessors ''PlotPoints ) -$( deriveAccessors ''PlotFillBetween ) -$( deriveAccessors ''PlotErrBars ) -$( deriveAccessors ''PlotBars ) +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 +import Graphics.Rendering.Chart.Plot.Candle +import Graphics.Rendering.Chart.Plot.Bars +import Graphics.Rendering.Chart.Plot.Hidden +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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Annotation.hs @@ -0,0 +1,101 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Annotation +-- Copyright : (c) Tim Docker 2006, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Show textual annotations on a chart. + +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Annotation( + PlotAnnotation(..), + + 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 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. + +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 (^._1) vs , map (^._2) vs) + } + where + vs = _plot_annotation_values p + + +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 + 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 + { _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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/AreaSpots.hs @@ -0,0 +1,192 @@ +-- | +-- Module : Graphics.Rendering.Chart.Plot.AreaSpots +-- Copyright : (c) Malcolm Wallace 2009 +-- License : BSD-style (see COPYRIGHT file) +-- +-- Area spots are a collection of unconnected filled circles, +-- with x,y position, and an independent z value to be represented +-- by the relative area of the spots. + +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.AreaSpots + ( AreaSpots(..) + + , area_spots_title + , area_spots_linethick + , area_spots_linecolour + , area_spots_fillcolour + , area_spots_opacity + , area_spots_max_radius + , area_spots_values + + , AreaSpots4D(..) + + , 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 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 hiding (over) +import Data.Colour.Names +import Data.Default.Class + +import Control.Monad + +-- | 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 + { _area_spots_title :: String + , _area_spots_linethick :: Double + , _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_values :: [(x,y,z)] + } + +instance Default (AreaSpots z x y) where + def = AreaSpots + { _area_spots_title = "" + , _area_spots_linethick = 0.1 + , _area_spots_linecolour = opaque blue + , _area_spots_fillcolour = blue + , _area_spots_opacity = 0.2 + , _area_spots_max_radius = 20 -- in pixels + , _area_spots_values = [] + } + +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 (^._1) (_area_spots_values p) + , map (^._2) (_area_spots_values p) ) + } + +renderAreaSpots :: (PlotValue z) => AreaSpots z x y -> PointMapFn x y -> BackendProgram () +renderAreaSpots p pmap = + forM_ (scaleMax (_area_spots_max_radius p^(2::Integer)) + (_area_spots_values p)) + (\ (x,y,z)-> do + let radius = sqrt z + let psSpot = filledCircles radius $ + flip withOpacity + (_area_spots_opacity p) $ + _area_spots_fillcolour p + drawPoint psSpot (pmap (LValue x, LValue y)) + let psOutline = hollowCircles radius + (_area_spots_linethick p) + (_area_spots_linecolour p) + drawPoint psOutline (pmap (LValue x, LValue y)) + ) + where + scaleMax :: PlotValue z => Double -> [(x,y,z)] -> [(x,y,Double)] + scaleMax n points = let largest = maximum (map (^._3.to toValue) points) + scale v = n * toValue v / largest + in over (mapped._3) scale points + +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 + 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) + +-- | A collection of unconnected spots, with x,y position, an +-- independent z value to be represented by the area of the spot, +-- and in addition, a fourth variable t to be represented by a colour +-- from a given palette. (A linear transfer function from t to palette +-- is assumed.) +data AreaSpots4D z t x y = AreaSpots4D + { _area_spots_4d_title :: String + , _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_values :: [(x,y,z,t)] + } + +instance Default (AreaSpots4D z t x y) where + def = AreaSpots4D + { _area_spots_4d_title = "" + , _area_spots_4d_linethick = 0.1 + , _area_spots_4d_palette = [ blue, green, yellow, orange, red ] + , _area_spots_4d_opacity = 0.2 + , _area_spots_4d_max_radius = 20 -- in pixels + , _area_spots_4d_values = [] + } + +instance (PlotValue z, PlotValue t, Show t) => ToPlot (AreaSpots4D z t) where + toPlot p = Plot { _plot_render = renderAreaSpots4D p + , _plot_legend = [ (_area_spots_4d_title p + , renderSpotLegend4D 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 -> BackendProgram () +renderAreaSpots4D p pmap = + 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 psSpot + = filledCircles radius $ + withOpacity colour (_area_spots_4d_opacity p) + drawPoint psSpot (pmap (LValue x, LValue y)) + let psOutline + = hollowCircles radius (_area_spots_4d_linethick p) + (opaque colour) + drawPoint psOutline (pmap (LValue x, LValue y)) + ) + 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 (^._3.to toValue) points) + scale v = n * toValue v / largest + colVals = map (^._4.to toValue) points + colMin = minimum colVals + colMax = maximum colVals + select t = min (c-1) $ + truncate ( fromIntegral c + * (toValue t-colMin) + / (colMax-colMin)) + in map (\ (x,y,z,t) -> (x,y, scale z, select t)) + points + +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 + 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 + drawPoint psOutline centre + where + linearInterpolate (Point x0 y0) (Point x1 y1) = + Point (x0 + abs(x1-x0)/2) (y0 + abs(y1-y0)/2) + +$( makeLenses ''AreaSpots ) +$( makeLenses ''AreaSpots4D ) diff --git a/Graphics/Rendering/Chart/Plot/Bars.hs b/Graphics/Rendering/Chart/Plot/Bars.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Bars.hs @@ -0,0 +1,411 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Bars +-- 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(..), + 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_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.Axis +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Geometry hiding (x0, y0) +import Graphics.Rendering.Chart.Plot.Types +import Graphics.Rendering.Chart.Utils +class PlotValue a => BarsPlotValue a where + 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 + barsIsNull a = a == 0.0 + barsReference = const 0 + barsAdd = (+) + +instance BarsPlotValue Int where + 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. + | BarsClustered -- ^ Bars for a fixed x are put horizontally + -- beside each other. + deriving (Show) + +data PlotBarsSpacing + = BarsFixWidth Double -- ^ All bars have the same width in pixels. + | BarsFixGap Double Double -- ^ (BarsFixGap g mw) means make the gaps between + -- the bars equal to g, but with a minimum bar width + -- of mw + deriving (Show) + +-- | How bars for a given (x,[y]) are aligned with respect to screen +-- coordinate corresponding to x (deviceX). +data PlotBarsAlignment = BarsLeft -- ^ The left edge of bars is at deviceX + | BarsCentered -- ^ Bars are centered around deviceX + | 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 BarsSettings = BarsSettings { + -- | This value specifies whether each value from [y] should be + -- shown beside or above the previous value. + _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. + _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. + _bars_settings_spacing :: PlotBarsSpacing, + + -- | This value controls how bars for a fixed x are aligned with + -- respect to the device coordinate corresponding to x. + _bars_settings_alignment :: PlotBarsAlignment, + + _bars_settings_singleton_width :: Double, + + -- | The point on the bar to horizontally anchor the label to + _bars_settings_label_bar_hanchor :: BarHorizAnchor, + + -- | The point on the bar to vertically anchor the label to + _bars_settings_label_bar_vanchor :: BarVertAnchor, + + -- | The anchor point on the label. + _bars_settings_label_text_hanchor :: HTextAnchor, + + -- | 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 = \pmap -> renderBars s vals yref0 + (barRect pmap) (mapX pmap), + _plot_legend = zip (_plot_bars_titles p) + (map renderPlotLegendBars + (_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 + + 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 (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 + + 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 + + styles = _bars_settings_item_styles p + + barPath os k v0 v1 = rectPath $ r os bsize k v0 v1 + + bsize = case _bars_settings_spacing p of + BarsFixGap gap minw -> let w = max (minKInterval - gap) minw in + case _bars_settings_style p of + BarsClustered -> w / fromIntegral nvs + BarsStacked -> w + BarsFixWidth width' -> width' + + minKInterval = let diffs = zipWith (-) (tail mks) mks + in if null diffs + then _bars_settings_singleton_width p + else minimum diffs + where + mks = nub $ sort $ map (mapk . fst) vals + + nvs = maximum $ map (length . snd) vals + +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 + +-- Helper function for printing bar values as labels +addLabels :: Show y => [(x, [y])] -> [(x, [(y, String)])] +addLabels = map . second $ map (\y -> (y, show y)) + +refVal :: (BarsPlotValue y) => BarsSettings -> [(x, [(y, String)])] -> y +refVal p vals = barsReference $ case _bars_settings_style p of + BarsClustered -> concatMap (map fst . snd) vals + BarsStacked -> concatMap (take 1 . dropWhile barsIsNull . stack . map fst . snd) vals + +allBarPoints :: (BarsPlotValue y) => BarsSettings -> [(x, [(y, String)])] -> ([x],[y]) +allBarPoints p vals = case _bars_settings_style p of + BarsClustered -> + let ys = concatMap (map fst) yls in + ( xs, barsReference ys:ys ) + BarsStacked -> + let ys = map (stack . map fst) yls in + ( xs, barsReference (concatMap (take 1 . dropWhile barsIsNull) ys):concat ys) + where (xs, yls) = unzip vals + +stack :: (BarsPlotValue y) => [y] -> [y] +stack = scanl1 barsAdd + +renderPlotLegendBars :: (FillStyle,Maybe LineStyle) -> Rect -> 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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Candle.hs @@ -0,0 +1,151 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Candle +-- Copyright : (c) Tim Docker 2006, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Candlestick charts for financial plotting +-- +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Candle( + PlotCandle(..), + Candle(..), + + plot_candle_title, + plot_candle_line_style, + plot_candle_tick_length, + plot_candle_width, + plot_candle_centre, + plot_candle_fill, + plot_candle_rise_fill_style, + plot_candle_fall_fill_style, + plot_candle_values, +) where + +import Control.Lens hiding (op) + +import Graphics.Rendering.Chart.Geometry hiding (close) +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Plot.Types +import Control.Monad +import Data.Colour (opaque) +import Data.Colour.Names (white, blue) +import Data.Default.Class + +-- | Value defining a financial interval: opening and closing prices, with +-- maxima and minima; and a style in which to render them. +-- By convention, there are different fill styles depending on whether +-- the price rises (open < close) or falls (close < open). +-- (This plot type can also be re-purposed for statistical intervals, e.g. +-- minimum, first quartile, median, third quartile, maximum.) +data PlotCandle x y = PlotCandle { + _plot_candle_title :: String, + _plot_candle_line_style :: LineStyle, + _plot_candle_fill :: Bool, + _plot_candle_rise_fill_style :: FillStyle, + _plot_candle_fall_fill_style :: FillStyle, + _plot_candle_tick_length :: Double, + _plot_candle_width :: Double, + _plot_candle_centre :: Double, + _plot_candle_values :: [Candle x y] +} + +-- | A Value holding price intervals for a given x-coord. +-- An alternative view is that these are statistical intervals: the +-- 0th, 25th, 50th, 75th, and 100th percentiles. +data Candle x y = Candle { candle_x :: x + , candle_low :: y + , candle_open :: y + , candle_mid :: y + , candle_close :: y + , candle_high :: y + } deriving (Show) + +instance ToPlot PlotCandle where + toPlot p = Plot { + _plot_render = renderPlotCandle p, + _plot_legend = [(_plot_candle_title p, renderPlotLegendCandle p)], + _plot_all_points = ( map candle_x pts + , concat [ [candle_low c, candle_high c] + | c <- pts ] ) + } + where + pts = _plot_candle_values p + +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) = + Candle x' lo' op' mid' cl' hi' + where (Point x' mid') = pmap' (x,mid) + (Point _ lo') = pmap' (x,lo) + (Point _ op') = pmap' (x,op) + (Point _ cl') = pmap' (x,cl) + (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 + let ct = _plot_candle_centre ps + let f = _plot_candle_fill ps + -- 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) $ + fillPath $ moveTo' (x-wd) open + <> lineTo' (x-wd) close + <> lineTo' (x+wd) close + <> lineTo' (x+wd) open + <> lineTo' (x-wd) open + + withLineStyle (_plot_candle_line_style ps) $ do + strokePath $ moveTo' (x-wd) open + <> lineTo' (x-wd) close + <> lineTo' (x+wd) close + <> lineTo' (x+wd) open + <> lineTo' (x-wd) open + + strokePath $ moveTo' x (min lo hi) + <> lineTo' x (min open close) + <> moveTo' x (max open close) + <> lineTo' x (max hi lo) + + when (tl > 0) $ strokePath $ moveTo' (x-tl) lo + <> lineTo' (x+tl) lo + <> moveTo' (x-tl) hi + <> lineTo' (x+tl) hi + + when (ct > 0) $ strokePath $ moveTo' (x-ct) mid + <> lineTo' (x+ct) mid + +renderPlotLegendCandle :: PlotCandle x y -> Rect -> 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 + +instance Default (PlotCandle x y) where + def = PlotCandle + { _plot_candle_title = "" + , _plot_candle_line_style = solidLine 1 $ opaque blue + , _plot_candle_fill = False + , _plot_candle_rise_fill_style = solidFillStyle $ opaque white + , _plot_candle_fall_fill_style = solidFillStyle $ opaque blue + , _plot_candle_tick_length = 2 + , _plot_candle_width = 5 + , _plot_candle_centre = 0 + , _plot_candle_values = [] + } + +$( makeLenses ''PlotCandle ) diff --git a/Graphics/Rendering/Chart/Plot/ErrBars.hs b/Graphics/Rendering/Chart/Plot/ErrBars.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/ErrBars.hs @@ -0,0 +1,127 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.ErrBars +-- Copyright : (c) Tim Docker 2006, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Plot series of points with associated error bars. +-- +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.ErrBars( + PlotErrBars(..), + ErrPoint(..), + ErrValue(..), + symErrPoint, + + -- * Accessors + -- | These accessors are generated by template haskell + + plot_errbars_title, + plot_errbars_line_style, + plot_errbars_tick_length, + plot_errbars_overhang, + plot_errbars_values, +) where + +import Control.Lens + +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Plot.Types +import Data.Colour (opaque) +import Data.Colour.Names (blue) +import Data.Default.Class + +-- | Value for holding a point with associated error bounds for each axis. + +data ErrValue x = ErrValue { + ev_low :: x, + ev_best :: x, + ev_high :: x +} deriving Show + +data ErrPoint x y = ErrPoint { + ep_x :: ErrValue x, + ep_y :: ErrValue y +} deriving Show + +-- | When the error is symmetric, we can simply pass in dx for the error. +symErrPoint :: (Num a, Num b) => a -> b -> a -> b -> ErrPoint a b +symErrPoint x y dx dy = ErrPoint (ErrValue (x-dx) x (x+dx)) + (ErrValue (y-dy) y (y+dy)) + +-- | Value defining a series of error intervals, and a style in +-- which to render them. +data PlotErrBars x y = PlotErrBars { + _plot_errbars_title :: String, + _plot_errbars_line_style :: LineStyle, + _plot_errbars_tick_length :: Double, + _plot_errbars_overhang :: Double, + _plot_errbars_values :: [ErrPoint x y] +} + + +instance ToPlot PlotErrBars where + toPlot p = Plot { + _plot_render = renderPlotErrBars p, + _plot_legend = [(_plot_errbars_title p, renderPlotLegendErrBars p)], + _plot_all_points = ( concat [ [ev_low x,ev_high x] + | ErrPoint x _ <- pts ] + , concat [ [ev_low y,ev_high y] + | ErrPoint _ y <- pts ] ) + } + where + pts = _plot_errbars_values p + +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)) = + ErrPoint (ErrValue xl' x' xh') (ErrValue yl' y' yh') + where (Point x' y') = pmap' (x,y) + (Point xl' yl') = pmap' (xl,yl) + (Point xh' yh') = pmap' (xh,yh) + 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) $ + strokePath $ moveTo' (xl-oh) y + <> lineTo' (xh+oh) y + <> moveTo' x (yl-oh) + <> lineTo' x (yh+oh) + <> moveTo' xl (y-tl) + <> lineTo' xl (y+tl) + <> moveTo' (x-tl) yl + <> lineTo' (x+tl) yl + <> moveTo' xh (y-tl) + <> lineTo' xh (y+tl) + <> moveTo' (x-tl) yh + <> lineTo' (x+tl) yh + +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) + y = (p_y p1 + p_y p2)/2 + +instance Default (PlotErrBars x y) where + def = PlotErrBars + { _plot_errbars_title = "" + , _plot_errbars_line_style = solidLine 1 $ opaque blue + , _plot_errbars_tick_length = 3 + , _plot_errbars_overhang = 0 + , _plot_errbars_values = [] + } + +$( makeLenses ''PlotErrBars ) diff --git a/Graphics/Rendering/Chart/Plot/FillBetween.hs b/Graphics/Rendering/Chart/Plot/FillBetween.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/FillBetween.hs @@ -0,0 +1,89 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.FillBetween +-- Copyright : (c) Tim Docker 2006, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Plots that fill the area between two lines. +-- +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.FillBetween( + PlotFillBetween(..), + + -- * 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.Plot.Types +import Data.Colour (opaque) +import Data.Colour.SRGB (sRGB) +import Data.Default.Class + +-- | Value specifying a plot filling the area between two sets of Y +-- coordinates, given common X coordinates. + +data PlotFillBetween x y = PlotFillBetween { + _plot_fillbetween_title :: String, + _plot_fillbetween_style :: FillStyle, + _plot_fillbetween_line :: Maybe LineStyle, + _plot_fillbetween_values :: [ (x, (y,y))] +} + + +instance ToPlot PlotFillBetween where + toPlot p = Plot { + _plot_render = renderPlotFillBetween p, + _plot_legend = [(_plot_fillbetween_title p,renderPlotLegendFill p)], + _plot_all_points = plotAllPointsFillBetween p + } + +renderPlotFillBetween :: PlotFillBetween x y -> PointMapFn x y -> BackendProgram () +renderPlotFillBetween p = + renderPlotFillBetween' p (_plot_fillbetween_values p) + +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,_)) <- vs ] + p2s = map pmap' [ (x,y2) | (x,(_,y2)) <- vs ] + +renderPlotLegendFill :: PlotFillBetween x y -> Rect -> BackendProgram () +renderPlotLegendFill p r = + withFillStyle (_plot_fillbetween_style p) $ + fillPath (rectPath r) + +plotAllPointsFillBetween :: PlotFillBetween x y -> ([x],[y]) +plotAllPointsFillBetween p = ( [ x | (x,(_,_)) <- pts ] + , concat [ [y1,y2] | (_,(y1,y2)) <- pts ] ) + where + pts = _plot_fillbetween_values p + +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 = [] + } + +$( makeLenses ''PlotFillBetween ) diff --git a/Graphics/Rendering/Chart/Plot/Hidden.hs b/Graphics/Rendering/Chart/Plot/Hidden.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Hidden.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Hidden +-- 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 +-- scaling +-- +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Hidden( + PlotHidden(..), + + plot_hidden_x_values, + plot_hidden_y_values +) where + +import Control.Lens +import Graphics.Rendering.Chart.Plot.Types + +-- | 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] +} + +instance ToPlot PlotHidden where + toPlot ph = Plot { + _plot_render = \_ -> return (), + _plot_legend = [], + _plot_all_points = (_plot_hidden_x_values ph, _plot_hidden_y_values ph) + } + +$( makeLenses ''PlotHidden ) 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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Lines.hs @@ -0,0 +1,102 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Lines +-- Copyright : (c) Tim Docker 2006, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Line plots +-- +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Lines( + PlotLines(..), + defaultPlotLineStyle, + hlinePlot, + vlinePlot, + + plot_lines_title, + plot_lines_style, + plot_lines_values, + plot_lines_limit_values, +) where + +import Control.Lens +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Plot.Types +import Data.Colour (opaque) +import Data.Colour.Names (blue) +import Data.Default.Class + +-- | Value defining a series of (possibly disjointed) lines, +-- and a style in which to render them. +data PlotLines x y = PlotLines { + _plot_lines_title :: String, + _plot_lines_style :: LineStyle, + + -- | The lines to be plotted + _plot_lines_values :: [[(x,y)]], + + -- | Additional lines to be plotted, specified using + -- the Limit type to allow referencing the edges of + -- the plot area. + _plot_lines_limit_values :: [[(Limit x, Limit y)]] +} + +instance ToPlot PlotLines where + toPlot p = Plot { + _plot_render = renderPlotLines p, + _plot_legend = [(_plot_lines_title p, renderPlotLegendLines p)], + _plot_all_points = ( map fst pts ++ xs, map snd pts ++ ys ) + } + where + pts = concat (_plot_lines_values p) + 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 -> BackendProgram () +renderPlotLines p pmap = + withLineStyle (_plot_lines_style p) $ do + mapM_ (drawLines (mapXY pmap)) (_plot_lines_values p) + mapM_ (drawLines pmap) (_plot_lines_limit_values p) + where + drawLines mapfn pts = alignStrokePoints (map mapfn pts) >>= strokePointPath + +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] + strokePointPath ps + +defaultPlotLineStyle :: LineStyle +defaultPlotLineStyle = (solidLine 1 $ opaque blue){ + _line_cap = LineCapRound, + _line_join = LineJoinRound + } + +instance Default (PlotLines x y) where + def = PlotLines + { _plot_lines_title = "" + , _plot_lines_style = defaultPlotLineStyle + , _plot_lines_values = [] + , _plot_lines_limit_values = [] + } + +-- | Helper function to plot a single horizontal line. +hlinePlot :: String -> LineStyle -> b -> Plot a b +hlinePlot t ls v = toPlot def { + _plot_lines_title = t, + _plot_lines_style = ls, + _plot_lines_limit_values = [[(LMin, LValue v),(LMax, LValue v)]] + } + +-- | Helper function to plot a single vertical line. +vlinePlot :: String -> LineStyle -> a -> Plot a b +vlinePlot t ls v = toPlot def { + _plot_lines_title = t, + _plot_lines_style = ls, + _plot_lines_limit_values = [[(LValue v,LMin),(LValue v,LMax)]] + } + +$( makeLenses ''PlotLines ) diff --git a/Graphics/Rendering/Chart/Plot/Pie.hs b/Graphics/Rendering/Chart/Plot/Pie.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Pie.hs @@ -0,0 +1,228 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Pie +-- Copyright : (c) Tim Docker 2008, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- A basic pie chart. +-- +-- Pie charts are handled different to other plots, in that they +-- have their own layout, and can't be composed with other plots. A +-- pie chart is rendered with code in the following form: +-- +-- @ +-- values :: [PieItem] +-- values = [...] +-- layout :: PieLayout +-- layout = pie_plot ^: pie_data ^= values +-- $ def +-- renderable = toRenderable layout +-- @ +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Pie( + PieLayout(..), + PieChart(..), + PieItem(..), + + 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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Points.hs @@ -0,0 +1,69 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Points +-- Copyright : (c) Tim Docker 2006, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Functions to plot sets of points, marked in various styles. + +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Points( + PlotPoints(..), + + -- * Accessors + -- | These accessors are generated by template haskell + + plot_points_title, + plot_points_style, + plot_points_values, +) where + +import Control.Lens +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Plot.Types +import Data.Default.Class + +-- | Value defining a series of datapoints, and a style in +-- which to render them. +data PlotPoints x y = PlotPoints { + _plot_points_title :: String, + _plot_points_style :: PointStyle, + _plot_points_values :: [(x,y)] +} + +instance ToPlot PlotPoints where + toPlot p = Plot { + _plot_render = renderPlotPoints p, + _plot_legend = [(_plot_points_title p, renderPlotLegendPoints p)], + _plot_all_points = (map fst pts, map snd pts) + } + where + pts = _plot_points_values p + +renderPlotPoints :: PlotPoints x y -> PointMapFn x y -> BackendProgram () +renderPlotPoints p pmap = + mapM_ (drawPoint ps . pmap') (_plot_points_values p) + where + pmap' = mapXY pmap + ps = _plot_points_style p + +renderPlotLegendPoints :: PlotPoints x y -> Rect -> 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 + y = (p_y p1 + p_y p2)/2 + +instance Default (PlotPoints x y) where + def = PlotPoints + { _plot_points_title = "" + , _plot_points_style = def + , _plot_points_values = [] + } + +$( makeLenses ''PlotPoints ) diff --git a/Graphics/Rendering/Chart/Plot/Types.hs b/Graphics/Rendering/Chart/Plot/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Plot/Types.hs @@ -0,0 +1,79 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Types +-- Copyright : (c) Tim Docker 2006, 2014 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Datatypes and functions common to the implementation of the various +-- plot types. +-- +{-# LANGUAGE TemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Types( + Plot(..), + joinPlot, + ToPlot(..), + + mapXY, + + plot_render, + plot_legend, + plot_all_points, + + ) where + +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing +import Control.Lens + +-- | 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 -> 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 -> BackendProgram ()) ], + + -- | All of the model space coordinates to be plotted. These are + -- used to autoscale the axes where necessary. + _plot_all_points :: ([x],[y]) +} + +-- | A type class abstracting the conversion of a value to a Plot. +class ToPlot a where + toPlot :: a x y -> Plot x y + +instance ToPlot Plot where + toPlot p = p + +-- | Join any two plots together (they will share a legend). +joinPlot :: Plot x y -> Plot x y -> Plot x y +joinPlot Plot{ _plot_render = renderP + , _plot_legend = legendP + , _plot_all_points = (xsP,ysP) } + Plot{ _plot_render = renderQ + , _plot_legend = legendQ + , _plot_all_points = (xsQ,ysQ) } + + = Plot{ _plot_render = \a-> renderP a >> renderQ a + , _plot_legend = legendP ++ legendQ + , _plot_all_points = ( xsP++xsQ, ysP++ysQ ) + } + + +---------------------------------------------------------------------- + +mapXY :: PointMapFn x y -> (x,y) -> Point +mapXY f (x,y) = f (LValue x, LValue y) + +---------------------------------------------------------------------- + + + +---------------------------------------------------------------------- + +$( makeLenses ''Plot ) 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,26 +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, - - renderableToPNGFile, - renderableToPDFFile, - renderableToPSFile, - renderableToSVGFile, + Rectangle(..), + RectCornerStyle(..), - vectorEnv, - bitmapEnv, + rectangleToRenderable, + drawRectangle, fillBackground, addMargins, @@ -31,6 +30,7 @@ spacer, spacer1, setPickFn, + mapMaybePickFn, mapPickFn, nullPickFn, @@ -40,82 +40,77 @@ rect_cornerStyle, ) where -import qualified Graphics.Rendering.Cairo as C import Control.Monad -import Data.Accessor -import Data.List ( nub, transpose, sort ) +import Control.Lens +import Data.Default.Class -import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Utils --- | A function that maps a point in device coordinates --- to some value. +-- | A function that maps a point in device coordinates to some value. -- --- Perhaps it might be generalised from Maybe a to --- (MonadPlus m ) => m a in the future. -type PickFn a = Point -> (Maybe a) +-- Perhaps it might be generalised from Maybe a to +-- (MonadPlus m ) => m a in the future. +type PickFn a = Point -> Maybe a nullPickFn :: PickFn a nullPickFn = const Nothing -- | A Renderable is a record of functions required to layout a --- graphic element. +-- graphic element. data Renderable a = Renderable { - -- | a Cairo action to calculate a minimum size, - minsize :: CRender 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 -> CRender (PickFn a) + -- The resulting "pick" function maps a point in the image to a value. + render :: RectSize -> BackendProgram (PickFn a) } - --- | A type class abtracting the conversion of a value to a --- Renderable. + deriving (Functor) +-- | A type class abtracting the conversion of a value to a Renderable. class ToRenderable a where - toRenderable :: a -> Renderable () + 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 sz = Renderable { +-- | Create a blank renderable with a specified minimum size. +spacer :: RectSize -> Renderable a +spacer sz = Renderable { minsize = return sz, render = \_ -> return nullPickFn } -- | Create a blank renderable with a minimum size the same as --- some other renderable. +-- some other renderable. spacer1 :: Renderable a -> Renderable b -spacer1 r = Renderable { - minsize = minsize r, - render = \_ -> return nullPickFn -} +spacer1 r = r{ render = \_ -> return nullPickFn } --- | Replace the pick function of a renderable with another +-- | Replace the pick function of a renderable with another. setPickFn :: PickFn b -> Renderable a -> Renderable b -setPickFn pickfn r = Renderable { - minsize=minsize r, - render = \sz -> do { render r sz; return pickfn; } - } +setPickFn pickfn r = r{ render = \sz -> render r sz >> return pickfn } --- | Map a function over result of a renderables pickfunction. +-- | Map a function over the result of a renderable's pickfunction, keeping only 'Just' results. +mapMaybePickFn :: (a -> Maybe b) -> Renderable a -> Renderable b +mapMaybePickFn f r = r{ render = \sz -> do pf <- render r sz + return (join . fmap f . pf) } + +-- | Map a function over result of a renderable's pickfunction. mapPickFn :: (a -> b) -> Renderable a -> Renderable b -mapPickFn f r = Renderable { - minsize=minsize r, - render = \sz -> do { - pf <- render r sz; - return (\p -> fmap f (pf p)); - } - } +mapPickFn f = mapMaybePickFn (Just . f) -- | Add some spacing at the edges of a renderable. -addMargins :: (Double,Double,Double,Double) -- ^ The spacing to be added - -> Renderable a -- ^ The source renderable +addMargins :: (Double,Double,Double,Double) -- ^ The spacing to be added. + -> Renderable a -- ^ The source renderable. -> Renderable a addMargins (t,b,l,r) rd = Renderable { minsize = mf, render = rf } where @@ -123,122 +118,78 @@ (w,h) <- minsize rd return (w+l+r,h+t+b) - rf (w,h) = do - preserveCState $ do - c $ C.translate l t - pickf <- render rd (w-l-r,h-t-b) - mtx <- c $ C.getMatrix - return (mkpickf pickf (w,h) mtx) - - mkpickf pickf (w,h) mtx pt | within pt' rect = pickf pt' - | otherwise = Nothing - where - pt' = transform mtx pt - rect = (Rect (Point 0 0) (Point w h)) + rf (w,h) = + withTranslation (Point l t) $ do + pickf <- render rd (w-l-r,h-t-b) + return (mkpickf pickf (t,b,l,r) (w,h)) -transform :: C.Matrix -> Point -> Point -transform = undefined + 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 :: CairoFillStyle -> Renderable a -> Renderable a -fillBackground fs r = Renderable { minsize = minsize r, render = rf } +fillBackground :: FillStyle -> Renderable a -> Renderable a +fillBackground fs r = r{ render = rf } where rf rsize@(w,h) = do - preserveCState $ do - setClipRegion (Point 0 0) (Point w h) - setFillStyle fs - c $ C.paint - render r rsize - --- | Output the given renderable to a PNG file of the specifed size --- (in pixels), to the specified file. -renderableToPNGFile :: Renderable a -> Int -> Int -> FilePath -> IO () -renderableToPNGFile chart width height path = - C.withImageSurface C.FormatARGB32 width height $ \result -> do - C.renderWith result $ runCRender rfn bitmapEnv - C.surfaceWriteToPNG result path - where - rfn = do - render chart (fromIntegral width, fromIntegral height) - -renderableToFile withSurface chart width height path = - withSurface path (fromIntegral width) (fromIntegral height) $ \result -> do - C.renderWith result $ runCRender rfn vectorEnv - C.surfaceFinish result - where - rfn = do - render chart (fromIntegral width, fromIntegral height) - c $ C.showPage - --- | Output the given renderable to a PDF file of the specifed size --- (in points), to the specified file. -renderableToPDFFile :: Renderable a -> Int -> Int -> FilePath -> IO () -renderableToPDFFile = renderableToFile C.withPDFSurface - --- | Output the given renderable to a postscript file of the specifed size --- (in points), to the specified file. -renderableToPSFile :: Renderable a -> Int -> Int -> FilePath -> IO () -renderableToPSFile = renderableToFile C.withPSSurface - --- | Output the given renderable to an SVG file of the specifed size --- (in points), to the specified file. -renderableToSVGFile :: Renderable a -> Int -> Int -> FilePath -> IO () -renderableToSVGFile = renderableToFile C.withSVGSurface - -bitmapEnv = CEnv (adjfn 0.5) (adjfn 0.0) - where - adjfn offset (Point x y) = Point (adj x) (adj y) - where - adj v = (fromIntegral.round) v +offset - -vectorEnv = CEnv id id + withFillStyle fs $ do + p <- alignFillPath $ rectPath (Rect (Point 0 0) (Point w h)) + fillPath p + render r rsize -- | Helper function for using a renderable, when we generate it --- in the CRender monad. -embedRenderable :: CRender (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 } + render = \ r -> do { a <- ca; render a r } } ---------------------------------------------------------------------- -- Labels --- | Construct a renderable from a text string, aligned with the axes -label :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable a +-- | Construct a renderable from a text string, aligned with the axes. +label :: FontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable String 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. -rlabel :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable a +-- 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 = preserveCState $ do - setFontStyle fs - (w,h) <- textSize s - return (w*acr+h*asr,w*asr+h*acr) - rf (w0,h0) = preserveCState $ do - setFontStyle fs - sz@(w,h) <- textSize s - fe <- c $ C.fontExtents - c $ C.translate 0 (-C.fontExtentsDescent fe) - c $ C.translate (xadj sz hta 0 w0) (yadj sz vta 0 h0) - c $ C.rotate rot' - c $ C.moveTo (-w/2) (h/2) - c $ C.showText s - return nullPickFn - 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 + mf = withFontStyle fs $ do + ts <- textSize s + let sz = (textSizeWidth ts, textSizeHeight ts) + return (xwid sz, ywid sz) - rot' = rot / 180 * pi - (cr,sr) = (cos rot', sin rot') + rf (w0,h0) = withFontStyle fs $ do + ts <- textSize s + let sz@(w,h) = (textSizeWidth ts, textSizeHeight ts) + descent = textSizeDescent ts + + xadj HTA_Left = xwid sz/2 + xadj HTA_Centre = w0/2 + xadj HTA_Right = w0 - xwid sz/2 + + yadj VTA_Top = ywid sz/2 + yadj VTA_Centre = h0/2 + yadj VTA_Bottom = h0 - ywid sz/2 + yadj VTA_BaseLine = h0 - ywid sz/2 + descent*acr + + withTranslation (Point 0 (-descent)) $ + withTranslation (Point (xadj hta) (yadj vta)) $ + withRotation rot' $ do + drawText (Point (-w/2) (h/2)) s + return (\_-> Just s) -- PickFn String + + rot' = rot / 180 * pi + (cr,sr) = (cos rot', sin rot') (acr,asr) = (abs cr, abs sr) + xwid (w,h) = w*acr + h*asr + ywid (w,h) = w*asr + h*acr + ---------------------------------------------------------------------- -- Rectangles @@ -247,80 +198,74 @@ | RCornerRounded Double data Rectangle = Rectangle { - rect_minsize_ :: RectSize, - rect_fillStyle_ :: Maybe CairoFillStyle, - rect_lineStyle_ :: Maybe CairoLineStyle, - rect_cornerStyle_ :: RectCornerStyle + _rect_minsize :: RectSize, + _rect_fillStyle :: Maybe FillStyle, + _rect_lineStyle :: Maybe LineStyle, + _rect_cornerStyle :: RectCornerStyle } --- | Accessor for field rect_minsize_ -rect_minsize = accessor (\v->rect_minsize_ v) (\a v -> v{rect_minsize_=a}) - --- | Accessor for field rect_fillStyle_ -rect_fillStyle = accessor (\v->rect_fillStyle_ v) (\a v -> v{rect_fillStyle_=a}) - --- | Accessor for field rect_lineStyle_ -rect_lineStyle = accessor (\v->rect_lineStyle_ v) (\a v -> v{rect_lineStyle_=a}) +instance Default Rectangle where + def = Rectangle + { _rect_minsize = (0,0) + , _rect_fillStyle = Nothing + , _rect_lineStyle = Nothing + , _rect_cornerStyle = RCornerSquare + } --- | Accessor for field rect_cornerStyle_ -rect_cornerStyle = accessor (\v->rect_cornerStyle_ v) (\a v -> v{rect_cornerStyle_=a}) +instance ToRenderable Rectangle where + toRenderable = rectangleToRenderable +rectangleToRenderable :: Rectangle -> Renderable a +rectangleToRenderable rectangle = Renderable mf rf + where + mf = return (_rect_minsize rectangle) + rf = \rectSize -> drawRectangle (Point 0 0) + rectangle{ _rect_minsize = rectSize } -defaultRectangle = Rectangle { - rect_minsize_ = (0,0), - rect_fillStyle_ = Nothing, - rect_lineStyle_ = Nothing, - rect_cornerStyle_ = RCornerSquare -} +-- | 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 -instance ToRenderable Rectangle where - toRenderable rectangle = Renderable mf rf - where - mf = return (rect_minsize_ rectangle) - rf sz = preserveCState $ do - maybeM () (fill sz) (rect_fillStyle_ rectangle) - maybeM () (stroke sz) (rect_lineStyle_ rectangle) - return nullPickFn + fill p sz fs = + withFillStyle fs $ + fillPath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) - fill sz fs = do - setFillStyle fs - strokeRectangle sz (rect_cornerStyle_ rectangle) - c $ C.fill + stroke p sz ls = + withLineStyle ls $ + strokePath $ strokeRectangleP p sz (_rect_cornerStyle rectangle) - stroke sz ls = do - setLineStyle ls - strokeRectangle sz (rect_cornerStyle_ rectangle) - c $ C.stroke + 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 - strokeRectangle (x2,y2) RCornerSquare = c $ do - let (x1,y1) = (0,0) - C.moveTo x1 y1 - C.lineTo x1 y2 - C.lineTo x2 y2 - C.lineTo x2 y1 - C.lineTo x1 y1 - C.lineTo x1 y2 - - strokeRectangle (x2,y2) (RCornerBevel s) = c $ do - let (x1,y1) = (0,0) - C.moveTo x1 (y1+s) - C.lineTo x1 (y2-s) - C.lineTo (x1+s) y2 - C.lineTo (x2-s) y2 - C.lineTo x2 (y2-s) - C.lineTo x2 (y1+s) - C.lineTo (x2-s) y1 - C.lineTo (x1+s) y1 - C.lineTo x1 (y1+s) - C.lineTo x1 (y2-s) + 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) - strokeRectangle (x2,y2) (RCornerRounded s) = c $ do - let (x1,y1) = (0,0) - C.arcNegative (x1+s) (y2-s) s (pi2*2) pi2 - C.arcNegative (x2-s) (y2-s) s pi2 0 - C.arcNegative (x2-s) (y1+s) s 0 (pi2*3) - C.arcNegative (x1+s) (y1+s) s (pi2*3) (pi2*2) - C.lineTo x1 (y2-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,304 +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 (except for the --- filename required by plotPDF and plotPS), 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: --- --- > renderableToWindow (toRenderable $ plotLayout $ plot [0,0.1..10] sin "sin(x)") 640 480 --- --- > plotWindow [0,1,3,4,8] [12,15,1,5,8] "o" "points" --- --- > 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, - plotWindow, plotPDF, plotPS, - plotLayout - ) where - -import Data.Maybe ( catMaybes ) -import Data.Colour -import Data.Colour.Names - -import Graphics.Rendering.Chart -import Graphics.Rendering.Chart.Gtk - -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 ] - --- When defaultLayout1 has been generalized, change this signature to --- [InternalPlot x y] -> Layout1 x y z -iplot :: [InternalPlot Double Double] -> Layout1 Double Double -iplot foobar = defaultLayout1 { - layout1_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 = map Left plots - where vs = zip xs ys - plots = case catMaybes $ map plotas yks of - [] -> [toPlot $ defaultPlotLines - { plot_lines_title_ = name yks, - plot_lines_values_ = [vs], - plot_lines_style_ = solidLine 1 (styleColor ind) }] - xs -> xs - plotas Solid = Just $ toPlot $ defaultPlotLines - { plot_lines_title_ = name yks, - plot_lines_values_ = [vs], - plot_lines_style_ = solidLine 1 (styleColor ind) } - plotas Dashed = Just $ toPlot $ defaultPlotLines - { plot_lines_title_ = name yks, - plot_lines_values_ = [vs], - plot_lines_style_ = dashedLine 1 [10,10] (styleColor ind) } - plotas Dotted = Just $ toPlot $ defaultPlotLines - { plot_lines_title_ = name yks, - plot_lines_values_ = [vs], - plot_lines_style_ = dashedLine 1 [1,11] (styleColor ind) } - plotas FilledCircle = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=filledCircles 4 (styleColor ind) } - plotas HollowCircle = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=hollowCircles 5 1 (styleColor ind) } - plotas Triangle = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=hollowPolygon 7 1 3 False (styleColor ind) } - plotas DownTriangle = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=hollowPolygon 7 1 3 True (styleColor ind) } - plotas Square = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=hollowPolygon 7 1 4 False (styleColor ind) } - plotas Diamond = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=hollowPolygon 7 1 4 True (styleColor ind) } - plotas Plus = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=plusses 7 1 (styleColor ind) } - plotas Ex = Just $ toPlot $ defaultPlotPoints - { plot_points_title_ = name yks, - plot_points_values_ = vs, - plot_points_style_=exes 7 1 (styleColor ind) } - plotas Star = Just $ toPlot $ defaultPlotPoints - { 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 Layout1DDD = Layout1DDD { plotLayout :: Layout1 Double Double } -instance ToRenderable Layout1DDD where - toRenderable = toRenderable . plotLayout - -uplot :: [UPlot] -> Layout1DDD -uplot us = Layout1DDD $ 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 Layout1DDD where - pl args = uplot (reverse args) - --- | Display a plot on the screen. - -plotWindow :: PlotWindowType a => a -plotWindow = plw [] -class PlotWindowType t where - plw :: [UPlot] -> t -instance (PlotArg a, PlotWindowType r) => PlotWindowType (a -> r) where - plw args = \ a -> plw (toUPlot a ++ args) -instance PlotWindowType (IO a) where - plw args = do renderableToWindow (toRenderable $ uplot (reverse args)) 640 480 - return undefined - --- | 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) -instance PlotPDFType (IO a) where - pld fn args = do renderableToPDFFile (toRenderable $ uplot (reverse args)) 640 480 fn - return undefined - --- | 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) -instance PlotPSType (IO a) where - pls fn args = do renderableToPSFile (toRenderable $ uplot (reverse args)) 640 480 fn - return undefined - --- | 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) -instance PlotPNGType (IO a) where - plp fn args = do renderableToPNGFile (toRenderable $ uplot (reverse args)) 640 480 fn - return undefined - - - -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 new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/SparkLine.hs @@ -0,0 +1,169 @@ +--------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Sparkline +-- Copyright : (c) Hitesh Jasani, 2008, Malcolm Wallace 2011, Tim Docker 2014 +-- License : BSD3 +-- +-- 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 +-- . +-- +-- The present version integrates with +-- the Chart package, in the sense that Sparklines are just another +-- 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] +-- > +-- > sl = SparkLine barSpark dp +-- > fopts = FileOptions (sparkSize sl) PNG +-- > renderableToFile fopts (sparkLineToRenderable sl) "bar_spark.png" +-- > +--------------------------------------------------------------- + +module Graphics.Rendering.Chart.SparkLine + ( -- * SparkLine type + SparkLine(..) + -- * Drawing options + , SparkOptions(..) + , smoothSpark + , barSpark + -- * Size calculation + , sparkSize + -- * Rendering function + , renderSparkLine + , sparkLineToRenderable + , sparkWidth + ) where + +import Control.Monad +import Data.List +import Data.Ord +import Graphics.Rendering.Chart.Geometry +import Graphics.Rendering.Chart.Drawing +import Graphics.Rendering.Chart.Renderable +import Data.Colour +import Data.Colour.Names + +-- | A sparkline is a single sequence of data values, treated as y-values. +-- The x-values are anonymous and implicit in the sequence. +data SparkLine = SparkLine { sl_options :: SparkOptions + , sl_data :: [Double] + } + +-- | Options to render the sparklines in different ways. +data SparkOptions = SparkOptions + { so_smooth :: Bool -- ^ smooth or bars + , so_step :: Int -- ^ step size + , so_height :: Int -- ^ graph height (pixels) + , so_limits :: (Double,Double) -- ^ data point limits + , so_bgColor :: Colour Double -- ^ background color + , so_minColor :: Colour Double -- ^ color of minimum datapoint + , so_maxColor :: Colour Double -- ^ color of maximum datapoint + , so_lastColor :: Colour Double -- ^ color of last datapoint + , so_minMarker :: Bool -- ^ display minimum marker + , so_maxMarker :: Bool -- ^ display maximum marker + , so_lastMarker :: Bool -- ^ display last marker + } deriving (Show) + +-- | Default options for a smooth sparkline. +smoothSpark :: SparkOptions +smoothSpark = SparkOptions + { so_smooth = True + , so_step = 2 + , so_height = 20 + , so_limits = (0,100) + , so_bgColor = white + , so_minColor = red + , so_maxColor = green + , so_lastColor = blue + , so_minMarker = True + , so_maxMarker = True + , so_lastMarker = True + } + +-- | Default options for a barchart sparkline. +barSpark :: SparkOptions +barSpark = smoothSpark { so_smooth=False } + +-- | Create a renderable from a SparkLine. +sparkLineToRenderable :: SparkLine -> Renderable () +sparkLineToRenderable sp = Renderable + { minsize = let (w,h) = sparkSize sp in return (fromIntegral w , fromIntegral h) + , render = \_rect-> renderSparkLine sp + } + +instance ToRenderable SparkLine where + toRenderable = sparkLineToRenderable + +-- | Compute the width of a SparkLine, for rendering purposes. +sparkWidth :: SparkLine -> Int +sparkWidth SparkLine{sl_options=opt, sl_data=ds} = + let w = 4 + (so_step opt) * (length ds - 1) + extrawidth + extrawidth | so_smooth opt = 0 + | otherwise = bw * length ds + bw | so_smooth opt = 0 + | 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. +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 + | otherwise = bw * length ds + bw | so_smooth opt = 0 + | otherwise = 2 + h = so_height opt + dmin = fst (so_limits opt) + dmax = snd (so_limits opt) + coords = zipWith (\x y-> Point (fi x) y) + [1,(1+bw+so_step opt)..(1+(so_step opt+bw)*(length ds))] + [ fi h - ( (y-dmin) / + ((dmax-dmin+1) / fi (h-4)) ) + | y <- ds ] + -- remember y increases as we go down the page + minpt = maximumBy (comparing p_y) coords + maxpt = minimumBy (comparing p_y) coords + endpt = last coords + boxpt :: Point -> Rect + boxpt (Point x y) = Rect (Point (x-1)(y-1)) (Point (x+1)(y+1)) + fi :: (Num b, Integral a) => a -> b + fi = fromIntegral + in do + + withFillStyle (solidFillStyle (opaque (so_bgColor opt))) $ do + fillPath (rectPath (Rect (Point 0 0) (Point (fi w) (fi h)))) + if so_smooth opt + then do + withLineStyle (solidLine 1 (opaque grey)) $ do + p <- alignStrokePoints coords + strokePointPath p + else do + withFillStyle (solidFillStyle (opaque grey)) $ do + forM_ coords $ \ (Point x y) -> + fillPath (rectPath (Rect (Point (x-1) y) (Point (x+1) (fi h)))) + when (so_minMarker opt) $ do + withFillStyle (solidFillStyle (opaque (so_minColor opt))) $ do + p <- alignFillPath (rectPath (boxpt minpt)) + fillPath p + when (so_maxMarker opt) $ do + withFillStyle (solidFillStyle (opaque (so_maxColor opt))) $ do + p <- alignFillPath (rectPath (boxpt maxpt)) + fillPath p + when (so_lastMarker opt) $ do + withFillStyle (solidFillStyle (opaque (so_lastColor opt))) $ do + p <- alignFillPath (rectPath (boxpt endpt)) + fillPath p + return nullPickFn + 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/Types.hs b/Graphics/Rendering/Chart/Types.hs deleted file mode 100644 --- a/Graphics/Rendering/Chart/Types.hs +++ /dev/null @@ -1,507 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -XTemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Chart.Types --- Copyright : (c) Tim Docker 2006 --- License : BSD-style (see chart/COPYRIGHT) --- --- This module contains basic types and functions used for drawing. --- --- Note that template haskell is used to derive accessor functions --- (see 'Data.Accessor') for each field of the following data types: --- --- * 'CairoLineStyle' --- --- * 'CairoFontStyle' --- --- 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 --- --- @ --- f :: Data.Accessor.Accessor D F --- @ --- - -module Graphics.Rendering.Chart.Types( - Rect(..), - Point(..), - Vector(..), - - RectSize, - Range, - - mkrect, - pvadd, - pvsub, - psub, - vscale, - within, - - RectEdge(..), - Limit(..), - PointMapFn, - - preserveCState, - setClipRegion, - strokeLines, - moveTo, - lineTo, - rectPath, - - isValidNumber, - maybeM, - - defaultColorSeq, - - setSourceColor, - - CairoLineStyle(..), - solidLine, - dashedLine, - setLineStyle, - - CairoFillStyle(..), - defaultPointStyle, - solidFillStyle, - setFillStyle, - - CairoFontStyle(..), - defaultFontStyle, - setFontStyle, - - CairoPointStyle(..), - filledPolygon, - hollowPolygon, - filledCircles, - hollowCircles, - plusses, - exes, - stars, - - HTextAnchor(..), - VTextAnchor(..), - drawText, - textSize, - - CRender(..), - CEnv(..), - runCRender, - c, - alignp, - alignc, - - line_width, - line_color, - line_dashes, - line_cap, - line_join, - - font_name, - font_size, - font_slant, - font_weight, - font_color, - -) where - -import qualified Graphics.Rendering.Cairo as C -import Control.Monad.Reader -import Data.Accessor -import Data.Accessor.Template -import Data.Colour -import Data.Colour.SRGB -import Data.Colour.Names - --- | A point in two dimensions -data Point = Point { - p_x :: Double, - p_y :: Double -} deriving Show - -data Vector = Vector { - v_x :: Double, - v_y :: Double -} deriving Show - --- | scale a vector by a constant -vscale :: Double -> Vector -> Vector -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)) - --- | subtract a vector from a point -pvsub :: Point -> Vector -> Point -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)) - -data Limit a = LMin | LValue a | LMax - deriving Show - --- | a function mapping between points -type PointMapFn x y = (Limit x, Limit y) -> Point - --- | A rectangle is defined by two points -data Rect = Rect Point Point - deriving Show - -data RectEdge = E_Top | E_Bottom | E_Left | E_Right - --- | Create a rectangle based upon the coordinates of 4 points -mkrect :: Point -> Point -> Point -> Point -> Rect -mkrect (Point x1 _) (Point _ y2) (Point x3 _) (Point _ y4) = - Rect (Point x1 y2) (Point x3 y4) - --- | Test if a point is within a rectangle -within :: Point -> Rect -> Bool -within (Point x y) (Rect (Point x1 y1) (Point x2 y2)) = - x >= x1 && x <= x2 && y >= y1 && y <= y2 - - ----------------------------------------------------------------------- - --- | The environment present in the CRender Monad. -data CEnv = CEnv { - -- | An adjustment applied immediately prior to points - -- being displayed in device coordinates - -- - -- When device coordinates correspond to pixels, a cleaner - -- image is created if this transform rounds to the nearest - -- pixel. With higher-resolution output, this transform can - -- just be the identity function. - cenv_point_alignfn :: Point -> Point, - - -- | A adjustment applied immediately prior to coordinates - -- being transformed - cenv_coord_alignfn :: Point -> Point -} - --- | The reader monad containing context information to control --- the rendering process. -newtype CRender a = DR (ReaderT CEnv C.Render a) - deriving (Functor, Monad, MonadReader CEnv) - -runCRender :: CRender a -> CEnv -> C.Render a -runCRender (DR m) e = runReaderT m e - -c :: C.Render a -> CRender a -c = DR . lift - ----------------------------------------------------------------------- - --- | Abstract data type for the style of a plotted point --- --- The contained Cairo action draws a point in the desired --- style, at the supplied device coordinates. -newtype CairoPointStyle = CairoPointStyle (Point -> CRender ()) - --- | Data type for the style of a line -data CairoLineStyle = CairoLineStyle { - line_width_ :: Double, - line_color_ :: AlphaColour Double, - line_dashes_ :: [Double], - line_cap_ :: C.LineCap, - line_join_ :: C.LineJoin -} - --- | Abstract data type for a fill style --- --- The contained Cairo action sets the required fill --- style in the Cairo rendering state. -newtype CairoFillStyle = CairoFillStyle (CRender ()) - --- | Data type for a font -data CairoFontStyle = CairoFontStyle { - font_name_ :: String, - font_size_ :: Double, - font_slant_ :: C.FontSlant, - font_weight_ :: C.FontWeight, - font_color_ :: AlphaColour Double -} - -type Range = (Double,Double) -type RectSize = (Double,Double) - -defaultColorSeq :: [AlphaColour Double] -defaultColorSeq = cycle $ map opaque [blue, red, green, yellow, cyan, magenta] - ----------------------------------------------------------------------- --- Assorted helper functions in Cairo Usage - -moveTo, lineTo :: Point -> CRender () -moveTo p = do - p' <- alignp p - c $ C.moveTo (p_x p') (p_y p') - -alignp :: Point -> CRender Point -alignp p = do - alignfn <- fmap cenv_point_alignfn ask - return (alignfn p) - -alignc :: Point -> CRender Point -alignc p = do - alignfn <- fmap cenv_coord_alignfn ask - return (alignfn p) - -lineTo p = do - p' <- alignp p - c $ C.lineTo (p_x p') (p_y p') - -setClipRegion p2 p3 = do - c $ C.moveTo (p_x p2) (p_y p2) - c $ C.lineTo (p_x p2) (p_y p3) - c $ C.lineTo (p_x p3) (p_y p3) - c $ C.lineTo (p_x p3) (p_y p2) - c $ C.lineTo (p_x p2) (p_y p2) - c $ C.clip - --- | stroke the lines between successive points -strokeLines :: [Point] -> CRender () -strokeLines (p1:ps) = do - c $ C.newPath - moveTo p1 - mapM_ lineTo ps - c $ C.stroke -strokeLines _ = return () - --- | make a path from a rectangle -rectPath :: Rect -> CRender () -rectPath (Rect p1@(Point x1 y1) p3@(Point x2 y2)) = do - c $ C.newPath - moveTo p1 >> lineTo p2 >> lineTo p3 >> lineTo p4 >> lineTo p1 - where - p2 = (Point x1 y2) - p4 = (Point x2 y1) - -setFontStyle f = do - c $ C.selectFontFace (font_name_ f) (font_slant_ f) (font_weight_ f) - c $ C.setFontSize (font_size_ f) - c $ setSourceColor (font_color_ f) - -setLineStyle ls = do - c $ C.setLineWidth (line_width_ ls) - c $ setSourceColor (line_color_ ls) - c $ C.setLineCap (line_cap_ ls) - c $ C.setLineJoin (line_join_ ls) - case line_dashes_ ls of - [] -> return () - ds -> c $ C.setDash ds 0 - -setFillStyle (CairoFillStyle s) = s - -colourChannel :: (Floating a, Ord a) => AlphaColour a -> Colour a -colourChannel c = darken (recip (alphaChannel c)) (c `over` black) - -setSourceColor c = let (RGB r g b) = toSRGB $ colourChannel c - in C.setSourceRGBA r g b (alphaChannel c) - --- | Return the bounding rectancgle for a text string rendered --- in the current context. -textSize :: String -> CRender RectSize -textSize s = c $ do - te <- C.textExtents s - fe <- C.fontExtents - return (C.textExtentsWidth te, C.fontExtentsHeight fe) - -data HTextAnchor = HTA_Left | HTA_Centre | HTA_Right -data VTextAnchor = VTA_Top | VTA_Centre | VTA_Bottom | VTA_BaseLine - --- | Function to draw a textual label anchored by one of it's corners --- or edges. -drawText :: HTextAnchor -> VTextAnchor -> Point -> String -> CRender () -drawText hta vta (Point x y) s = c $ do - te <- C.textExtents s - fe <- C.fontExtents - let lx = xadj hta (C.textExtentsWidth te) - let ly = yadj vta te fe - C.moveTo (x+lx) (y+ly) - C.showText s - where - xadj HTA_Left w = 0 - xadj HTA_Centre w = (-w/2) - xadj HTA_Right w = (-w) - yadj VTA_Top te fe = C.fontExtentsAscent fe - yadj VTA_Centre te fe = - (C.textExtentsYbearing te) / 2 - yadj VTA_BaseLine te fe = 0 - yadj VTA_Bottom te fe = -(C.fontExtentsDescent fe) - --- | Execute a rendering action in a saved context (ie bracketed --- between C.save and C.restore) -preserveCState :: CRender a -> CRender a -preserveCState a = do - c $ C.save - v <- a - c $ C.restore - return v - ----------------------------------------------------------------------- - -filledCircles :: - Double -- ^ radius of circle - -> AlphaColour Double -- ^ colour - -> CairoPointStyle -filledCircles radius cl = CairoPointStyle rf - where - rf p = do - (Point x y) <- alignp p - c $ setSourceColor cl - c $ C.newPath - c $ C.arc x y radius 0 (2*pi) - c $ C.fill - -hollowCircles :: - Double -- ^ radius of circle - -> Double -- ^ thickness of line - -> AlphaColour Double - -> CairoPointStyle -hollowCircles radius w cl = CairoPointStyle rf - where - rf p = do - (Point x y) <- alignp p - c $ C.setLineWidth w - c $ setSourceColor cl - c $ C.newPath - c $ C.arc x y radius 0 (2*pi) - c $ C.stroke - -hollowPolygon :: - Double -- ^ radius of circle - -> Double -- ^ thickness of line - -> Int -- ^ Number of vertices - -> Bool -- ^ Is right-side-up? - -> AlphaColour Double - -> CairoPointStyle -hollowPolygon radius w sides isrot cl = CairoPointStyle rf - where rf p = - do (Point x y ) <- alignp p - c $ C.setLineWidth w - c $ setSourceColor cl - c $ C.newPath - let intToAngle n = if isrot - 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 + radius * sin a) (y + radius * cos a)) angles - moveTo p - mapM_ lineTo (ps++[p]) - c $ C.stroke - -filledPolygon :: - Double -- ^ radius of circle - -> Int -- ^ Number of vertices - -> Bool -- ^ Is right-side-up? - -> AlphaColour Double - -> CairoPointStyle -filledPolygon radius sides isrot cl = CairoPointStyle rf - where rf p = - do (Point x y ) <- alignp p - c $ setSourceColor cl - c $ C.newPath - let intToAngle n = if isrot - 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 + radius * sin a) (y + radius * cos a)) angles - moveTo p - mapM_ lineTo (ps++[p]) - c $ C.fill - -plusses :: - Double -- ^ radius of circle - -> Double -- ^ thickness of line - -> AlphaColour Double - -> CairoPointStyle -plusses radius w cl = CairoPointStyle rf - where rf p = do (Point x y ) <- alignp p - c $ C.setLineWidth w - c $ setSourceColor cl - c $ C.newPath - c $ C.moveTo (x+radius) y - c $ C.lineTo (x-radius) y - c $ C.moveTo x (y-radius) - c $ C.lineTo x (y+radius) - c $ C.stroke - -exes :: - Double -- ^ radius of circle - -> Double -- ^ thickness of line - -> AlphaColour Double - -> CairoPointStyle -exes radius w cl = CairoPointStyle rf - where rad = radius / sqrt 2 - rf p = do (Point x y ) <- alignp p - c $ C.setLineWidth w - c $ setSourceColor cl - c $ C.newPath - c $ C.moveTo (x+rad) (y+rad) - c $ C.lineTo (x-rad) (y-rad) - c $ C.moveTo (x+rad) (y-rad) - c $ C.lineTo (x-rad) (y+rad) - c $ C.stroke - -stars :: - Double -- ^ radius of circle - -> Double -- ^ thickness of line - -> AlphaColour Double - -> CairoPointStyle -stars radius w cl = CairoPointStyle rf - where rad = radius / sqrt 2 - rf p = do (Point x y ) <- alignp p - c $ C.setLineWidth w - c $ setSourceColor cl - c $ C.newPath - c $ C.moveTo (x+radius) y - c $ C.lineTo (x-radius) y - c $ C.moveTo x (y-radius) - c $ C.lineTo x (y+radius) - c $ C.moveTo (x+rad) (y+rad) - c $ C.lineTo (x-rad) (y-rad) - c $ C.moveTo (x+rad) (y-rad) - c $ C.lineTo (x-rad) (y+rad) - c $ C.stroke - -solidLine :: - Double -- ^ width of line - -> AlphaColour Double - -> CairoLineStyle -solidLine w cl = CairoLineStyle w cl [] C.LineCapButt C.LineJoinMiter - -dashedLine :: - Double -- ^ width of line - -> [Double] -- ^ the dash pattern in device coordinates - -> AlphaColour Double - -> CairoLineStyle -dashedLine w ds cl = CairoLineStyle w cl ds C.LineCapButt C.LineJoinMiter - -solidFillStyle :: - AlphaColour Double - -> CairoFillStyle -solidFillStyle cl = CairoFillStyle fn - where fn = c $ setSourceColor cl - -defaultPointStyle = filledCircles 1 $ opaque white - -defaultFontStyle = CairoFontStyle { - font_name_ = "sans", - font_size_ = 10, - font_slant_ = C.FontSlantNormal, - font_weight_ = C.FontWeightNormal, - font_color_ = opaque black -} - -isValidNumber v = not (isNaN v) && not (isInfinite v) - -maybeM v = maybe (return v) - ----------------------------------------------------------------------- --- Template haskell to derive an instance of Data.Accessor.Accessor for each field -$( deriveAccessors ''CairoLineStyle ) -$( deriveAccessors ''CairoFontStyle ) - diff --git a/Graphics/Rendering/Chart/Utils.hs b/Graphics/Rendering/Chart/Utils.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Utils.hs @@ -0,0 +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 +-- 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 diff --git a/tests/Prices.hs b/tests/Prices.hs deleted file mode 100644 --- a/tests/Prices.hs +++ /dev/null @@ -1,296 +0,0 @@ -module Prices where - -prices :: [(Int,Int,Int,Double,Double)] -prices = [ - (03,05,2005, 16.18, 42.02), - (04,05,2005, 16.25, 42.31), - (05,05,2005, 16.50, 42.95), - (06,05,2005, 16.52, 43.50), - (09,05,2005, 16.84, 44.91), - (10,05,2005, 16.70, 44.55), - (11,05,2005, 16.43, 43.63), - (12,05,2005, 16.29, 43.18), - (13,05,2005, 15.95, 42.40), - (16,05,2005, 15.55, 41.65), - (17,05,2005, 15.71, 42.17), - (18,05,2005, 15.93, 42.37), - (19,05,2005, 16.20, 42.85), - (20,05,2005, 15.88, 42.30), - (23,05,2005, 15.92, 42.53), - (24,05,2005, 16.25, 42.81), - (25,05,2005, 16.20, 42.67), - (26,05,2005, 16.05, 42.35), - (27,05,2005, 16.45, 43.12), - (30,05,2005, 16.85, 43.24), - (31,05,2005, 16.68, 42.57), - (01,06,2005, 16.85, 43.22), - (02,06,2005, 17.17, 43.85), - (03,06,2005, 17.42, 44.15), - (06,06,2005, 17.50, 44.07), - (07,06,2005, 17.37, 43.76), - (08,06,2005, 17.15, 43.21), - (09,06,2005, 17.12, 43.42), - (10,06,2005, 17.15, 43.27), - (14,06,2005, 17.34, 43.30), - (15,06,2005, 17.46, 43.90), - (16,06,2005, 17.71, 44.43), - (17,06,2005, 18.25, 45.45), - (20,06,2005, 18.23, 45.16), - (21,06,2005, 18.26, 45.54), - (22,06,2005, 18.11, 45.06), - (23,06,2005, 17.79, 44.65), - (24,06,2005, 17.76, 44.43), - (27,06,2005, 17.63, 44.22), - (28,06,2005, 18.08, 44.94), - (29,06,2005, 18.13, 44.80), - (30,06,2005, 18.15, 44.82), - (01,07,2005, 18.09, 45.12), - (04,07,2005, 18.20, 45.20), - (05,07,2005, 18.45, 45.85), - (06,07,2005, 18.40, 45.91), - (07,07,2005, 18.60, 46.35), - (08,07,2005, 18.38, 45.76), - (11,07,2005, 18.80, 46.41), - (12,07,2005, 18.60, 45.86), - (13,07,2005, 18.73, 46.00), - (14,07,2005, 18.70, 46.44), - (15,07,2005, 18.67, 46.25), - (18,07,2005, 18.54, 45.77), - (19,07,2005, 18.20, 45.21), - (20,07,2005, 18.65, 46.13), - (21,07,2005, 19.00, 46.87), - (22,07,2005, 19.09, 47.32), - (25,07,2005, 19.22, 47.36), - (26,07,2005, 19.19, 47.66), - (27,07,2005, 19.17, 47.64), - (28,07,2005, 19.15, 47.98), - (29,07,2005, 19.36, 49.12), - (01,08,2005, 19.40, 49.30), - (02,08,2005, 19.30, 49.17), - (03,08,2005, 19.52, 49.91), - (04,08,2005, 19.80, 50.60), - (05,08,2005, 19.60, 50.40), - (08,08,2005, 19.92, 50.94), - (09,08,2005, 20.34, 52.09), - (10,08,2005, 20.45, 51.42), - (11,08,2005, 20.74, 52.30), - (12,08,2005, 21.05, 53.01), - (15,08,2005, 21.16, 53.02), - (16,08,2005, 20.90, 52.74), - (17,08,2005, 20.55, 51.93), - (18,08,2005, 20.28, 51.42), - (19,08,2005, 20.68, 52.20), - (22,08,2005, 21.22, 53.10), - (23,08,2005, 21.07, 53.01), - (24,08,2005, 20.56, 52.72), - (25,08,2005, 19.90, 50.45), - (26,08,2005, 20.60, 51.42), - (29,08,2005, 20.03, 50.10), - (30,08,2005, 20.47, 50.74), - (31,08,2005, 20.46, 50.31), - (01,09,2005, 20.93, 51.80), - (02,09,2005, 20.83, 51.60), - (05,09,2005, 20.46, 51.56), - (06,09,2005, 20.25, 50.60), - (07,09,2005, 20.55, 51.54), - (08,09,2005, 20.03, 50.55), - (09,09,2005, 20.19, 50.90), - (12,09,2005, 20.20, 51.27), - (13,09,2005, 20.47, 51.91), - (14,09,2005, 20.59, 51.59), - (15,09,2005, 20.70, 52.44), - (16,09,2005, 20.99, 53.77), - (19,09,2005, 21.39, 55.45), - (20,09,2005, 21.53, 55.88), - (21,09,2005, 20.89, 54.63), - (22,09,2005, 21.41, 55.50), - (23,09,2005, 21.30, 55.56), - (26,09,2005, 21.86, 57.55), - (27,09,2005, 22.01, 58.56), - (28,09,2005, 21.81, 58.26), - (29,09,2005, 22.48, 60.01), - (30,09,2005, 22.25, 59.14), - (03,10,2005, 22.30, 58.93), - (04,10,2005, 22.20, 58.61), - (05,10,2005, 21.45, 57.10), - (06,10,2005, 20.76, 56.30), - (07,10,2005, 20.47, 56.50), - (10,10,2005, 20.72, 57.25), - (11,10,2005, 20.33, 57.00), - (12,10,2005, 20.83, 57.48), - (13,10,2005, 20.47, 56.69), - (14,10,2005, 19.98, 55.21), - (17,10,2005, 20.05, 55.95), - (18,10,2005, 20.75, 57.90), - (19,10,2005, 20.05, 56.19), - (20,10,2005, 20.01, 56.30), - (21,10,2005, 20.03, 55.82), - (24,10,2005, 19.77, 54.27), - (25,10,2005, 20.09, 54.82), - (26,10,2005, 20.42, 55.58), - (27,10,2005, 20.49, 55.80), - (28,10,2005, 20.10, 54.94), - (31,10,2005, 20.75, 56.31), - (01,11,2005, 20.89, 57.00), - (02,11,2005, 20.70, 57.11), - (03,11,2005, 21.28, 58.39), - (04,11,2005, 21.35, 58.60), - (07,11,2005, 21.09, 58.18), - (08,11,2005, 21.35, 59.80), - (09,11,2005, 21.03, 59.25), - (10,11,2005, 21.11, 59.21), - (11,11,2005, 21.12, 59.71), - (14,11,2005, 21.60, 61.24), - (15,11,2005, 21.53, 60.96), - (16,11,2005, 21.42, 60.60), - (17,11,2005, 21.40, 60.79), - (18,11,2005, 21.85, 62.45), - (21,11,2005, 21.71, 62.60), - (22,11,2005, 21.67, 61.70), - (23,11,2005, 21.55, 60.70), - (24,11,2005, 21.86, 61.89), - (25,11,2005, 22.02, 62.21), - (28,11,2005, 22.22, 62.09), - (29,11,2005, 21.83, 61.35), - (30,11,2005, 21.87, 61.76), - (01,12,2005, 21.50, 60.40), - (02,12,2005, 21.95, 61.92), - (05,12,2005, 22.03, 63.33), - (06,12,2005, 21.83, 62.99), - (07,12,2005, 21.85, 63.84), - (08,12,2005, 21.56, 63.10), - (09,12,2005, 21.80, 63.55), - (12,12,2005, 21.92, 63.60), - (13,12,2005, 21.65, 63.35), - (14,12,2005, 21.72, 63.15), - (15,12,2005, 21.69, 63.16), - (16,12,2005, 21.60, 62.63), - (19,12,2005, 21.87, 63.81), - (20,12,2005, 22.10, 65.50), - (21,12,2005, 22.50, 67.18), - (22,12,2005, 22.49, 67.75), - (23,12,2005, 22.58, 68.50), - (28,12,2005, 22.59, 68.25), - (29,12,2005, 22.93, 69.10), - (30,12,2005, 22.75, 69.00), - (03,01,2006, 23.18, 69.90), - (04,01,2006, 23.85, 71.06), - (05,01,2006, 23.60, 69.80), - (06,01,2006, 23.35, 68.80), - (09,01,2006, 24.06, 70.18), - (10,01,2006, 23.85, 69.15), - (11,01,2006, 23.88, 69.35), - (12,01,2006, 23.80, 70.19), - (13,01,2006, 23.73, 70.50), - (16,01,2006, 23.74, 71.05), - (17,01,2006, 23.96, 71.94), - (18,01,2006, 23.73, 70.25), - (19,01,2006, 24.45, 72.50), - (20,01,2006, 24.66, 74.00), - (23,01,2006, 24.47, 73.25), - (24,01,2006, 24.84, 74.25), - (25,01,2006, 25.08, 73.96), - (27,01,2006, 26.05, 76.10), - (30,01,2006, 26.58, 78.45), - (31,01,2006, 25.80, 75.82), - (01,02,2006, 25.99, 75.21), - (02,02,2006, 25.50, 74.98), - (03,02,2006, 25.53, 74.75), - (06,02,2006, 25.85, 75.57), - (07,02,2006, 25.70, 75.06), - (08,02,2006, 24.37, 72.75), - (09,02,2006, 24.68, 72.77), - (13,02,2006, 23.88, 70.95), - (14,02,2006, 24.16, 72.37), - (15,02,2006, 24.35, 71.84), - (16,02,2006, 24.29, 71.89), - (17,02,2006, 23.88, 71.65), - (20,02,2006, 24.54, 74.90), - (21,02,2006, 24.98, 75.50), - (22,02,2006, 24.90, 73.24), - (23,02,2006, 25.28, 74.69), - (24,02,2006, 24.55, 72.20), - (27,02,2006, 24.66, 73.00), - (28,02,2006, 24.25, 71.20), - (01,03,2006, 24.03, 70.25), - (02,03,2006, 24.45, 70.50), - (03,03,2006, 24.34, 70.35), - (06,03,2006, 24.51, 70.85), - (08,03,2006, 23.60, 67.95), - (09,03,2006, 23.70, 68.65), - (10,03,2006, 23.37, 67.50), - (13,03,2006, 23.93, 70.36), - (14,03,2006, 23.64, 69.45), - (15,03,2006, 23.90, 69.40), - (16,03,2006, 24.46, 70.90), - (17,03,2006, 24.70, 71.25), - (20,03,2006, 25.24, 72.85), - (21,03,2006, 25.32, 73.08), - (22,03,2006, 25.18, 72.99), - (23,03,2006, 25.57, 74.34), - (24,03,2006, 25.92, 75.23), - (27,03,2006, 26.78, 77.05), - (28,03,2006, 26.85, 77.13), - (30,03,2006, 27.60, 77.96), - (31,03,2006, 28.00, 78.85), - (03,01,2007, 23.18, 69.90), - (04,01,2007, 23.85, 71.06), - (05,01,2007, 23.60, 69.80), - (06,01,2007, 23.35, 68.80), - (09,01,2007, 24.06, 70.18), - (10,01,2007, 23.85, 69.15), - (11,01,2007, 23.88, 69.35), - (12,01,2007, 23.80, 70.19), - (13,01,2007, 23.73, 70.50), - (16,01,2007, 23.74, 71.05), - (17,01,2007, 23.96, 71.94), - (18,01,2007, 23.73, 70.25), - (19,01,2007, 24.45, 72.50), - (20,01,2007, 24.66, 74.00), - (23,01,2007, 24.47, 73.25), - (24,01,2007, 24.84, 74.25), - (25,01,2007, 25.08, 73.96), - (27,01,2007, 26.05, 76.10), - (30,01,2007, 26.58, 78.45), - (31,01,2007, 25.80, 75.82), - (01,02,2007, 25.99, 75.21), - (02,02,2007, 25.50, 74.98), - (03,02,2007, 25.53, 74.75), - (06,02,2007, 25.85, 75.57), - (07,02,2007, 25.70, 75.06), - (08,02,2007, 24.37, 72.75), - (09,02,2007, 24.68, 72.77), - (13,02,2007, 23.88, 70.95), - (14,02,2007, 24.16, 72.37), - (15,02,2007, 24.35, 71.84), - (16,02,2007, 24.29, 71.89), - (17,02,2007, 23.88, 71.65), - (20,02,2007, 24.54, 74.90), - (21,02,2007, 24.98, 75.50), - (22,02,2007, 24.90, 73.24), - (23,02,2007, 25.28, 74.69), - (24,02,2007, 24.55, 72.20), - (27,02,2007, 24.66, 73.00), - (28,02,2007, 24.25, 71.20), - (01,03,2007, 24.03, 70.25), - (02,03,2007, 24.45, 70.50), - (03,03,2007, 24.34, 70.35), - (06,03,2007, 24.51, 70.85), - (08,03,2007, 23.60, 67.95), - (09,03,2007, 23.70, 68.65), - (10,03,2007, 23.37, 67.50), - (13,03,2007, 23.93, 70.36), - (14,03,2007, 23.64, 69.45), - (15,03,2007, 23.90, 69.40), - (16,03,2007, 24.46, 70.90), - (17,03,2007, 24.70, 71.25), - (20,03,2007, 25.24, 72.85), - (21,03,2007, 25.32, 73.08), - (22,03,2007, 25.18, 72.99), - (23,03,2007, 25.57, 74.34), - (24,03,2007, 25.92, 75.23), - (27,03,2007, 26.78, 77.05), - (28,03,2007, 26.85, 77.13), - (30,03,2007, 27.60, 77.96), - (31,03,2007, 28.00, 78.85) - ] diff --git a/tests/test.hs b/tests/test.hs deleted file mode 100644 --- a/tests/test.hs +++ /dev/null @@ -1,456 +0,0 @@ -import qualified Graphics.Rendering.Cairo as C -import Graphics.Rendering.Chart -import Graphics.Rendering.Chart.Simple -import Graphics.Rendering.Chart.Gtk -import Graphics.Rendering.Chart.Grid - -import System.Environment(getArgs) -import System.Time -import System.Random -import Data.Time.Calendar -import Data.Time.LocalTime -import Data.Accessor -import Data.Accessor.Tuple -import Data.Colour -import Data.Colour.Names -import Data.Colour.SRGB -import Data.List(sort,nub,scanl1) -import qualified Data.Map as Map -import Control.Monad -import Prices - -data OutputType = Window | PNG | PS | PDF | SVG - -chooseLineWidth Window = 1.0 -chooseLineWidth PNG = 1.0 -chooseLineWidth PDF = 0.25 -chooseLineWidth PS = 0.25 -chooseLineWidth SVG = 0.25 - -green1 = opaque $ sRGB 0.5 1 0.5 -red1 = opaque $ sRGB 0.5 0.5 1 -fwhite = solidFillStyle $ opaque white -fparchment = solidFillStyle $ opaque $ sRGB 1.0 0.99 0.90 - ----------------------------------------------------------------------- -test1Layout otype = layout - where - am :: Double -> Double - am x = (sin (x*pi/45) + 1) / 2 * (sin (x*pi/5)) - - sinusoid1 = plot_lines_values ^= [[ (x,(am x)) | x <- [0,(0.5)..400]]] - $ plot_lines_style ^= solidLine lineWidth (opaque blue) - $ plot_lines_title ^="am" - $ defaultPlotLines - - sinusoid2 = plot_points_style ^= filledCircles 2 (opaque red) - $ plot_points_values ^= [ (x,(am x)) | x <- [0,7..400]] - $ plot_points_title ^="am points" - $ defaultPlotPoints - - layout = layout1_plots ^= [Left (toPlot sinusoid1), - Left (toPlot sinusoid2)] - $ layout1_background ^= fparchment - $ layout1_plot_background ^= Just fwhite - $ defaultLayout1 - - lineWidth = chooseLineWidth otype - -test1 :: OutputType -> Renderable () -test1 otype = toRenderable layout - where - layout = layout1_title ^= "Amplitude Modulation" - $ (test1Layout otype) - -test1a :: OutputType -> Renderable () -test1a otype = fillBackground fwhite $ (gridToRenderable t) - where - t = weights (1,1) $ aboveN [ besideN [rf g1, rf g2, rf g3], - besideN [rf g4, rf g5, rf g6] ] - - g1 = layout1_title ^= "minimal" - $ layout1_bottom_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) - $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) - $ test1Layout otype - - g2 = layout1_title ^= "with borders" - $ layout1_bottom_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) - $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) - $ layout1_top_axis ^: axisBorderOnly - $ layout1_right_axis ^: axisBorderOnly - $ test1Layout otype - - g3 = layout1_title ^= "default" - $ test1Layout otype - - g4 = layout1_title ^= "tight grid" - $ layout1_left_axis ^: laxis_generate ^= axis - $ layout1_left_axis ^: laxis_override ^= axisGridAtTicks - $ layout1_bottom_axis ^: laxis_generate ^= axis - $ layout1_bottom_axis ^: laxis_override ^= axisGridAtTicks - $ test1Layout otype - where - axis = autoScaledAxis ( - la_nLabels ^= 5 - $ la_nTicks ^= 20 - $ defaultLinearAxis - ) - - g5 = layout1_title ^= "y linked" - $ layout1_yaxes_control ^= linkAxes - $ test1Layout otype - - g6 = layout1_title ^= "everything" - $ layout1_yaxes_control ^= linkAxes - $ layout1_top_axis ^: laxis_visible ^= const True - $ test1Layout otype - - rf = tval.toRenderable - - axisBorderOnly = (laxis_visible ^= const True) - . (laxis_override ^= (axisGridHide.axisTicksHide.axisLabelsHide)) - ----------------------------------------------------------------------- -test2 :: [(Int,Int,Int,Double,Double)] -> Bool -> OutputType -> Renderable () -test2 prices showMinMax otype = toRenderable layout - where - - lineStyle c = line_width ^= 3 * chooseLineWidth otype - $ line_color ^= c - $ defaultPlotLines ^. plot_lines_style - - limitLineStyle c = line_width ^= chooseLineWidth otype - $ line_color ^= opaque c - $ line_dashes ^= [5,10] - $ defaultPlotLines ^. plot_lines_style - - price1 = plot_lines_style ^= lineStyle (opaque blue) - $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,v,_) <- prices]] - $ plot_lines_title ^= "price 1" - $ defaultPlotLines - - price2 = plot_lines_style ^= lineStyle (opaque green) - $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,_,v) <- prices]] - $ plot_lines_title ^= "price 2" - $ defaultPlotLines - - (min1,max1) = (minimum [v | (_,_,_,v,_) <- prices],maximum [v | (_,_,_,v,_) <- prices]) - (min2,max2) = (minimum [v | (_,_,_,_,v) <- prices],maximum [v | (_,_,_,_,v) <- prices]) - limits | showMinMax = [ Left $ hlinePlot "min/max" (limitLineStyle blue) min1, - Left $ hlinePlot "" (limitLineStyle blue) max1, - Right $ hlinePlot "min/max" (limitLineStyle green) min2, - Right $ hlinePlot "" (limitLineStyle green) max2 ] - | otherwise = [] - - bg = opaque $ sRGB 0 0 0.25 - fg = opaque white - fg1 = opaque $ sRGB 0.0 0.0 0.15 - - layout = layout1_title ^="Price History" - $ layout1_background ^= solidFillStyle bg - $ updateAllAxesStyles (axis_grid_style ^= solidLine 1 fg1) - $ layout1_left_axis ^: laxis_override ^= axisGridHide - $ layout1_right_axis ^: laxis_override ^= axisGridHide - $ layout1_bottom_axis ^: laxis_override ^= axisGridHide - $ layout1_plots ^= ([Left (toPlot price1), Right (toPlot price2)] ++ limits) - $ layout1_grid_last ^= False - $ setLayout1Foreground fg - $ defaultLayout1 - -date dd mm yyyy = (LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight) - ----------------------------------------------------------------------- -test3 :: OutputType -> Renderable () -test3 otype = toRenderable layout - where - - price1 = plot_fillbetween_style ^= solidFillStyle green1 - $ plot_fillbetween_values ^= [ (date d m y,(0,v2)) | (d,m,y,v1,v2) <- prices] - $ plot_fillbetween_title ^= "price 1" - $ defaultPlotFillBetween - - price2 = plot_fillbetween_style ^= solidFillStyle red1 - $ plot_fillbetween_values ^= [ (date d m y,(0,v1)) | (d,m,y,v1,v2) <- prices] - $ plot_fillbetween_title ^= "price 2" - $ defaultPlotFillBetween - - layout = layout1_title ^= "Price History" - $ layout1_grid_last ^= True - $ layout1_plots ^= [Left (toPlot price1), - Left (toPlot price2)] - $ defaultLayout1 - ----------------------------------------------------------------------- -test4 :: Bool -> Bool -> OutputType -> Renderable () -test4 xrev yrev otype = toRenderable layout - where - - points = plot_points_style ^= filledCircles 3 (opaque red) - $ plot_points_values ^= [ (x, LogValue (10**x)) | x <- [0.5,1,1.5,2,2.5] ] - $ plot_points_title ^= "values" - $ defaultPlotPoints - - lines = plot_lines_values ^= [ [(x, LogValue (10**x)) | x <- [0,3]] ] - $ plot_lines_title ^= "values" - $ defaultPlotLines - - layout = layout1_title ^= "Log/Linear Example" - $ layout1_bottom_axis ^: laxis_title ^= "horizontal" - $ layout1_bottom_axis ^: laxis_reverse ^= xrev - $ layout1_left_axis ^: laxis_title ^= "vertical" - $ layout1_left_axis ^: laxis_reverse ^= yrev - $ layout1_plots ^= [Left (toPlot points), Left (toPlot lines) ] - $ defaultLayout1 - ----------------------------------------------------------------------- --- Example thanks to Russell O'Connor - -test5 :: OutputType -> Renderable () -test5 otype = toRenderable (layout 1001 (trial bits) :: Layout1 Double LogValue) - where - bits = randoms $ mkStdGen 0 - - layout n t = layout1_title ^= "Simulation of betting on a biased coin" - $ layout1_plots ^= [ - Left (toPlot (plot "f=0.05" s1 n 0 (t 0.05))), - Left (toPlot (plot "f=0.1" s2 n 0 (t 0.1))) - ] - $ defaultLayout1 - - plot tt s n m t = plot_lines_style ^= s - $ plot_lines_values ^= - [[(fromIntegral x, LogValue y) | (x,y) <- - filter (\(x,_)->x `mod` (m+1)==0) $ take n $ zip [0..] t]] - $ plot_lines_title ^= tt - $ defaultPlotLines - - b = 0.1 - - trial bits frac = scanl (*) 1 (map f bits) - where - f True = (1+frac*(1+b)) - f False = (1-frac) - - s1 = solidLine lineWidth $ opaque green - s2 = solidLine lineWidth $ opaque blue - - lineWidth = chooseLineWidth otype - - ----------------------------------------------------------------------- --- Test the Simple interface - -test6 :: OutputType -> Renderable () -test6 otype = toRenderable (plotLayout pp){layout1_title_="Graphics.Rendering.Chart.Simple example"} - where - pp = plot xs sin "sin" - cos "cos" "o" - (sin.sin.cos) "sin.sin.cos" "." - (/3) "- " - (const 0.5) - [0.1,0.7,0.5::Double] "+" - xs = [0,0.3..3] :: [Double] - ----------------------------------------------------------------------- -test7 :: OutputType -> Renderable () -test7 otype = toRenderable layout - where - vals :: [(Double,Double,Double,Double)] - vals = [ (x,sin (exp x),sin x/2,cos x/10) | x <- [1..20]] - bars = plot_errbars_values ^= [symErrPoint x y dx dy | (x,y,dx,dy) <- vals] - $ plot_errbars_title ^="test" - $ defaultPlotErrBars - - points = plot_points_style ^= filledCircles 2 (opaque red) - $ plot_points_values ^= [(x,y) | (x,y,dx,dy) <- vals] - $ plot_points_title ^= "test" - $ defaultPlotPoints - - layout = layout1_title ^= "errorbars example" - $ layout1_plots ^= [Left (toPlot bars), - Left (toPlot points)] - $ defaultLayout1 - ----------------------------------------------------------------------- - -test8 :: OutputType -> Renderable () -test8 otype = toRenderable layout - where - values = [ ("eggs",38,e), ("milk",45,e), ("bread",11,e1), ("salmon",8,e) ] - e = 0 - e1 = 25 - layout = pie_title ^= "Pie Chart Example" - $ pie_plot ^: pie_data ^= [ defaultPieItem{pitem_value_=v,pitem_label_=s,pitem_offset_=o} - | (s,v,o) <- values ] - $ defaultPieLayout - ----------------------------------------------------------------------- - - -test9 :: OutputType -> Renderable () -test9 otype = fillBackground fwhite $ (gridToRenderable t) - where - t = weights (1,1) $ aboveN [ besideN [rf g0, rf g1, rf g2], - besideN [rf g3, rf g4, rf g5] ] - - g0 = layout "clustered 1" - $ plot_bars_style ^= BarsClustered - $ plot_bars_spacing ^= BarsFixWidth 25 - $ bars1 - - g1 = layout "clustered / fix width " - $ plot_bars_style ^= BarsClustered - $ plot_bars_spacing ^= BarsFixWidth 25 - $ bars2 - - g2 = layout "clustered / fix gap " - $ plot_bars_style ^= BarsClustered - $ plot_bars_spacing ^= BarsFixGap 10 - $ bars2 - - g3 = layout "stacked 1" - $ plot_bars_style ^= BarsStacked - $ plot_bars_spacing ^= BarsFixWidth 25 - $ bars1 - - g4 = layout "stacked / fix width" - $ plot_bars_style ^= BarsStacked - $ plot_bars_spacing ^= BarsFixWidth 25 - $ bars2 - - g5 = layout "stacked / fix gap" - $ plot_bars_style ^= BarsStacked - $ plot_bars_spacing ^= BarsFixGap 10 - $ bars2 - - rf = tval.toRenderable - - alabels = [ "Jun", "Jul", "Aug", "Sep", "Oct" ] - - - layout title bars = layout1_title ^= title - $ layout1_bottom_axis ^: laxis_generate ^= autoIndexAxis alabels - $ layout1_left_axis ^: laxis_override ^= (axisGridHide.axisTicksHide) - $ layout1_plots ^= [ Left (plotBars bars) ] - $ defaultLayout1 :: Layout1 PlotIndex Double - - bars1 = plot_bars_titles ^= ["Cash"] - $ plot_bars_values ^= addIndexes [[20],[45],[30],[70]] - $ defaultPlotBars - - bars2 = plot_bars_titles ^= ["Cash","Equity"] - $ plot_bars_values ^= addIndexes [[20,45],[45,30],[30,20],[70,25]] - $ defaultPlotBars - -------------------------------------------------------------------------------- - -test10 :: [(Int,Int,Int,Double,Double)] -> OutputType -> Renderable () -test10 prices otype = toRenderable layout - where - - lineStyle c = line_width ^= 3 * chooseLineWidth otype - $ line_color ^= c - $ defaultPlotLines ^. plot_lines_style - - price1 = plot_lines_style ^= lineStyle (opaque blue) - $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,v,_) <- prices]] - $ plot_lines_title ^= "price 1" - $ defaultPlotLines - - price1_area = plot_fillbetween_values ^= [((date d m y), (v * 0.95, v * 1.05)) | (d,m,y,v,_) <- prices] - $ plot_fillbetween_style ^= solidFillStyle (withOpacity blue 0.2) - $ defaultPlotFillBetween - - price2 = plot_lines_style ^= lineStyle (opaque red) - $ plot_lines_values ^= [[ ((date d m y), v) | (d,m,y,_,v) <- prices]] - $ plot_lines_title ^= "price 2" - $ defaultPlotLines - - price2_area = plot_fillbetween_values ^= [((date d m y), (v * 0.95, v * 1.05)) | (d,m,y,_,v) <- prices] - $ plot_fillbetween_style ^= solidFillStyle (withOpacity red 0.2) - $ defaultPlotFillBetween - - fg = opaque black - fg1 = opaque $ sRGB 0.0 0.0 0.15 - - layout = layout1_title ^="Price History" - $ layout1_background ^= solidFillStyle (opaque white) - $ layout1_right_axis ^: laxis_override ^= axisGridHide - $ layout1_plots ^= [ Left (toPlot price1_area), Right (toPlot price2_area) - , Left (toPlot price1), Right (toPlot price2) - ] - $ setLayout1Foreground fg - $ defaultLayout1 - ----------------------------------------------------------------------- --- a quick test to display labels with all combinations --- of anchors -misc1 rot otype = fillBackground fwhite $ (gridToRenderable t) - where - t = weights (1,1) $ aboveN [ besideN [tval (lb h v) | h <- hs] | v <- vs ] - lb h v = addMargins (20,20,20,20) $ fillBackground fblue $ crossHairs $ rlabel fs h v rot s - s = "Labelling" - hs = [HTA_Left, HTA_Centre, HTA_Right] - vs = [VTA_Top, VTA_Centre, VTA_Bottom] - fwhite = solidFillStyle $ opaque white - fblue = solidFillStyle $ opaque $ sRGB 0.8 0.8 1 - fs = defaultFontStyle{font_size_=20,font_weight_=C.FontWeightBold} - crossHairs r =Renderable { - minsize = minsize r, - render = \sz@(w,h) -> do - let xa = w / 2 - let ya = h / 2 - strokeLines [Point 0 ya,Point w ya] - strokeLines [Point xa 0,Point xa h] - render r sz - } - ----------------------------------------------------------------------- -allTests :: [ (String, OutputType -> Renderable ()) ] -allTests = - [ ("test1", test1) - , ("test1a", test1a) - , ("test2a", test2 prices False) - , ("test2b", test2 (filterPrices (date 1 1 2005) (date 31 12 2005)) False) - , ("test2c", test2 (filterPrices (date 1 5 2005) (date 1 7 2005)) False) - , ("test2d", test2 (filterPrices (date 1 1 2006) (date 10 1 2006)) False) - , ("test2e", test2 (filterPrices (date 1 8 2005) (date 31 8 2005)) True) - , ("test3", test3) - , ("test4a", test4 False False) - , ("test4b", test4 True False) - , ("test4c", test4 False True) - , ("test5", test5) - , ("test6", test6) - , ("test7", test7) - , ("test8", test8) - , ("test9", test9) - , ("test10", test10 (filterPrices (date 1 1 2005) (date 31 12 2005))) - , ("misc1", misc1 0) - , ("misc1a", misc1 45) - ] - -filterPrices t1 t2 = [ v | v@(d,m,y,_,_) <- prices, let t = date d m y in t >= t1 && t <= t2] - -main = do - args <- getArgs - main1 args - -main1 :: [String] -> IO () -main1 ("--png":tests) = showTests tests renderToPNG -main1 ("--pdf":tests) = showTests tests renderToPDF -main1 ("--svg":tests) = showTests tests renderToSVG -main1 ("--ps":tests) = showTests tests renderToPS -main1 tests = showTests tests renderToWindow - -showTests :: [String] -> ((String,OutputType -> Renderable ()) -> IO()) -> IO () -showTests tests ofn = mapM_ ofn (filter (match tests) allTests) - -match :: [String] -> (String,a) -> Bool -match [] t = True -match ts t = (fst t) `elem` ts - -renderToWindow (n,ir) = renderableToWindow (ir Window) 640 480 -renderToPNG (n,ir) = renderableToPNGFile (ir PNG) 640 480 (n ++ ".png") -renderToPS (n,ir) = renderableToPSFile (ir PS) 640 480 (n ++ ".ps") -renderToPDF (n,ir) = renderableToPDFFile (ir PDF) 640 480 (n ++ ".pdf") -renderToSVG (n,ir) = renderableToSVGFile (ir SVG) 640 480 (n ++ ".svg")