diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,8 +1,8 @@ Name: Chart -Version: 0.13.1 +Version: 0.14 License: BSD3 License-file: LICENSE -Copyright: Tim Docker, 2006-2009 +Copyright: Tim Docker, 2006-2010 Author: Tim Docker Maintainer: Tim Docker Homepage: http://www.dockerz.net/software/chart.html @@ -24,32 +24,57 @@ tests/Test8.hs, tests/Test9.hs, tests/Test14.hs, + tests/Test14a.hs, tests/Test15.hs, + tests/Test17.hs, tests/TestParametric.hs, tests/Prices.hs + tests/ExampleStocks.hs flag splitbase description: Choose the new smaller, split-up base package. +flag gtk + description: If gtk2hs is available, add extra API functions to use it. + default: True + library if flag(splitbase) Build-depends: base >= 3 && < 5, 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.*, + Build-depends: cairo >= 0.9.11, time, mtl, array, data-accessor == 0.2.*, data-accessor-template >= 0.2.1.1 && < 0.3, colour >= 2.2.1 + if flag(gtk) + build-depends: gtk >= 0.9.11 + exposed-modules: Graphics.Rendering.Chart.Gtk + cpp-options: -DHAVE_GTK=1 + Exposed-modules: Graphics.Rendering.Chart, - Graphics.Rendering.Chart.Gtk, Graphics.Rendering.Chart.Types, 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.LocalTime, + Graphics.Rendering.Chart.Axis.Types, + Graphics.Rendering.Chart.Axis.Unit, Graphics.Rendering.Chart.Layout, Graphics.Rendering.Chart.Legend, - Graphics.Rendering.Chart.Plot, - Graphics.Rendering.Chart.Pie, Graphics.Rendering.Chart.Simple, - Graphics.Rendering.Chart.Grid - Graphics.Rendering.Chart.AreaSpots - + Graphics.Rendering.Chart.Grid, + Graphics.Rendering.Chart.Plot, + 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.Pie, + Graphics.Rendering.Chart.Plot.Points diff --git a/Graphics/Rendering/Chart.hs b/Graphics/Rendering/Chart.hs --- a/Graphics/Rendering/Chart.hs +++ b/Graphics/Rendering/Chart.hs @@ -9,15 +9,15 @@ -- 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'. +-- 'renderableToPNGFile', or 'renderableToWindow'. -- -- Currently, there are two kinds of 'Renderable' for displaying charts: -- -- * a standard two axes chart can be is created by applying --- 'toRenderable' to a value of type 'Graphics.Rendering.Chart.Layout.Layout1' +-- 'toRenderable' to a value of type 'Layout1' -- -- * a pie chart can be is created by applying --- 'toRenderable' to a value of type 'Graphics.Rendering.Chart.Pie.PieLayout' +-- 'toRenderable' to a value of type 'PieLayout' -- -- Multiple Renderables can be composed using the "Graphics.Rendering.Chart.Grid" module. -- @@ -38,8 +38,6 @@ module Graphics.Rendering.Chart.Axis, module Graphics.Rendering.Chart.Plot, module Graphics.Rendering.Chart.Legend, - module Graphics.Rendering.Chart.AreaSpots, - module Graphics.Rendering.Chart.Pie, ) where @@ -49,5 +47,3 @@ import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Plot import Graphics.Rendering.Chart.Legend -import Graphics.Rendering.Chart.Pie -import Graphics.Rendering.Chart.AreaSpots diff --git a/Graphics/Rendering/Chart/AreaSpots.hs b/Graphics/Rendering/Chart/AreaSpots.hs deleted file mode 100644 --- a/Graphics/Rendering/Chart/AreaSpots.hs +++ /dev/null @@ -1,107 +0,0 @@ --- | --- Module : Graphics.Rendering.Chart.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. - -{-# OPTIONS_GHC -XTemplateHaskell #-} - -module Graphics.Rendering.Chart.AreaSpots - ( AreaSpots(..) - , defaultAreaSpots - - , area_spots_title - , area_spots_linethick - , area_spots_linecolour - , area_spots_fillcolour - , area_spots_max_radius - , area_spots_values - ) where - -import qualified Graphics.Rendering.Cairo as C - -import Graphics.Rendering.Chart.Types -import Graphics.Rendering.Chart.Plot -import Graphics.Rendering.Chart.Axis -import Data.Accessor.Template -import Data.Colour -import Data.Colour.Names - -import Control.Monad - --- stuff that belongs in Data.Tuple -fst3 (a,_,_) = a -snd3 (_,a,_) = a -thd3 (_,_,a) = a - - --- | A collection of unconnected spots, with x,y position, and an --- independent z value to be represented by the area of the spot. -data AreaSpots z x y = AreaSpots - { area_spots_title_ :: String - , area_spots_linethick_ :: Double - , area_spots_linecolour_ :: AlphaColour Double - , area_spots_fillcolour_ :: AlphaColour Double - , area_spots_max_radius_ :: Double -- ^ the largest size of spot - , area_spots_values_ :: [(x,y,z)] - } - -defaultAreaSpots :: AreaSpots z x y -defaultAreaSpots = AreaSpots - { area_spots_title_ = "" - , area_spots_linethick_ = 0.1 - , area_spots_linecolour_ = opaque blue - , area_spots_fillcolour_ = flip withOpacity 0.2 blue - , 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 fst3 (area_spots_values_ p) - , map snd3 (area_spots_values_ p) ) - } - -renderAreaSpots :: (PlotValue z) => - AreaSpots z x y -> PointMapFn x y -> CRender () -renderAreaSpots p pmap = preserveCState $ - forM_ (scaleMax ((area_spots_max_radius_ p)^2) - (area_spots_values_ p)) - (\ (x,y,z)-> do - let radius = sqrt z - let (CairoPointStyle drawSpotAt) = filledCircles radius - (area_spots_fillcolour_ p) - drawSpotAt (pmap (LValue x, LValue y)) - let (CairoPointStyle drawOutlineAt) = hollowCircles radius - (area_spots_linethick_ p) - (area_spots_linecolour_ p) - drawOutlineAt (pmap (LValue x, LValue y)) - ) - where - scaleMax :: PlotValue z => Double -> [(x,y,z)] -> [(x,y,Double)] - scaleMax n points = let largest = maximum (map (toValue . thd3) points) - scale v = n * toValue v / largest - in map (\ (x,y,z) -> (x,y, scale z)) points - -renderSpotLegend :: AreaSpots z x y -> Rect -> CRender () -renderSpotLegend p r@(Rect p1 p2) = preserveCState $ do - let radius = min (abs (p_y p1 - p_y p2)) (abs (p_x p1 - p_x p2)) - centre = linearInterpolate p1 p2 - let (CairoPointStyle drawSpotAt) = filledCircles radius - (area_spots_fillcolour_ p) - drawSpotAt centre - let (CairoPointStyle drawOutlineAt) = hollowCircles radius - (area_spots_linethick_ p) - (area_spots_linecolour_ p) - drawOutlineAt centre - where - linearInterpolate (Point x0 y0) (Point x1 y1) = - Point (x0 + abs(x1-x0)/2) (y0 + abs(y1-y0)/2) - -------------------------------------------------------------------------- --- Template haskell to derive Data.Accessor.Accessor -$( deriveAccessors ''AreaSpots ) 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,769 +6,22 @@ -- -- 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' --- --- * '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 --- @ --- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -XTemplateHaskell #-} module Graphics.Rendering.Chart.Axis( - AxisData(..), - AxisT(..), - LinearAxisParams(..), - LogAxisParams(..), - AxisStyle(..), - PlotValue(..), - LogValue(..), - PlotIndex(..), - AxisFn, - - defaultAxisLineStyle, - defaultLinearAxis, - defaultIntAxis, - defaultLogAxis, - defaultAxisStyle, - autoScaledAxis, - autoScaledLogAxis, - unitAxis, - timeAxis, - autoTimeAxis, - days, months, years, - autoIndexAxis, - addIndexes, - - autoSteps, - - 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.LocalTime, + module Graphics.Rendering.Chart.Axis.Unit, + module Graphics.Rendering.Chart.Axis.Indexed, ) where -import qualified Graphics.Rendering.Cairo as C -import Data.Time -import Data.Fixed -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 Data.Ord (comparing) - -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 coordinates. - 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 numbers 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} - strokePath [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 strokePath [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 strokePath [Point v' 0,Point v' h] - - hline v = let v' = p_y (axisPoint v) - in strokePath [Point 0 v',Point w v'] - - -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 - - goodness vs = abs (genericLength vs - nSteps) - - (alt0:alts) = map (\n -> steps n range) sampleSteps - - sampleSteps = [1,2,5] ++ sampleSteps1 - sampleSteps1 = [10,20,25,50] ++ map (*10) sampleSteps1 - - steps size (min,max) = takeWhile ( a -> (a,a) -> [Rational] -steps nSteps (min,max) = map ((s*) . fromIntegral) [min' .. max'] - where - s = chooseStep nSteps (min,max) - min' = floor $ realToFrac min / s - max' = ceiling $ realToFrac max / s - n = (max' - min') - - -chooseStep :: RealFloat a => a -> (a,a) -> Rational -chooseStep nsteps (x1,x2) = minimumBy (comparing proximity) steps - where - delta = x2 - x1 - mult = 10 ^^ (floor $ log10 $ delta / nsteps) - steps = map (mult*) [0.1,0.2,0.25,0.5,1.0,2.0,2.5,5.0,10,20,25,50] - 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 _ | min == max = (min-0.5,min+0.5) - | otherwise = (min,max) - (min,max) = (minimum ps,maximum ps) - ps = filter isValidNumber vs - r = range ps - -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 - -makeAxis' :: Ord x => (x -> Double) -> (x -> String) -> ([x],[x],[x]) -> AxisData x -makeAxis' f labelf (labelvs, tickvs, gridvs) = AxisData { - axis_viewport_ = linMap f (minimum labelvs, maximum labelvs), - axis_ticks_ = zip tickvs (repeat 2) ++ zip labelvs (repeat 5), - axis_grid_ = gridvs, - axis_labels_ = [ (v,labelf v) | v <- labelvs ] - } - -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 -} - - -defaultLinearAxis :: (Show a) => LinearAxisParams a -defaultLinearAxis = LinearAxisParams { - la_labelf_ = showD, - la_nLabels_ = 5, - la_nTicks_ = 50 -} - -defaultIntAxis :: (Show a) => LinearAxisParams a -defaultIntAxis = LinearAxisParams { - la_labelf_ = show, - la_nLabels_ = 5, - la_nTicks_ = 10 -} - --- | 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 :: RealFloat a => LinearAxisParams a -> AxisFn a -autoScaledAxis lap ps0 = makeAxis' realToFrac (la_labelf_ lap) (labelvs,tickvs,gridvs) - where - ps = filter isValidNumber ps0 - (min,max) = (minimum ps,maximum ps) - range [] = (0,1) - range _ | min == max = (min-1,min+1) - | 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 - - -autoScaledIntAxis :: (Integral i, PlotValue i) => - LinearAxisParams i -> AxisFn i -autoScaledIntAxis lap ps = - makeAxis (la_labelf_ lap) (labelvs,tickvs,gridvs) - where - (min,max) = (minimum ps,maximum ps) - range [] = (0,1) - range _ | min == max = (fromIntegral $ min-1, fromIntegral $ min+1) - | otherwise = (fromIntegral $ min, fromIntegral $ max) --- 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 - - -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 not 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 - 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) - inRange (a,b) l x = (lower a l <= x) && (x <= upper b l) - major | 17.5 < log10 ratio = map (\x -> 10^^(round x)) $ - steps (min 5 (log10 ratio)) - (log10 low, log10 high) - | 12 < log10 ratio = map (\x -> 10^^(round x)) $ - steps ((log10 ratio)/5) (log10 low, log10 high) - | 6 < log10 ratio = map (\x -> 10^^(round x)) $ - steps ((log10 ratio)/2) (log10 low, log10 high) - | 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 axis. --- The resulting axis will only show a grid if the template has some grid --- values. -autoScaledLogAxis :: RealFloat a => LogAxisParams a -> AxisFn a -autoScaledLogAxis lap ps0 = - makeAxis' (realToFrac . log) (loga_labelf_ lap) (wrap rlabelvs, wrap rtickvs, wrap rgridvs) - where - ps = filter (\x -> isValidNumber x && 0 < x) ps0 - (min,max) = (minimum ps,maximum ps) - wrap = map fromRational - range [] = (3,30) - range _ | min == max = (realToFrac $ min/3, realToFrac $ max*3) - | otherwise = (realToFrac $ min, realToFrac $ max) - (rlabelvs, rtickvs, rgridvs) = logTicks (range ps) - - -data LogAxisParams a = LogAxisParams { - -- | The function used to show the axes labels. - loga_labelf_ :: a -> String -} - -defaultLogAxis :: Show a => LogAxisParams a -defaultLogAxis = LogAxisParams { - loga_labelf_ = showD -} - ----------------------------------------------------------------------- - -defaultAxisLineStyle :: CairoLineStyle -defaultAxisLineStyle = solidLine 1 $ opaque black - -defaultGridLineStyle :: CairoLineStyle -defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey - -defaultAxisStyle :: AxisStyle -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 coordinate. -doubleFromLocalTime :: LocalTime -> 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 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 be aligned to its 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 - -normalizeTimeOfDay :: LocalTime -> LocalTime -normalizeTimeOfDay t@(LocalTime day (TimeOfDay h 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 -> Int -> LocalTime -> LocalTime -addTod dh dm ds (LocalTime day (TimeOfDay h m s)) = normalizeTimeOfDay t' - where t' = LocalTime day (TimeOfDay (h+dh) (m+dm) (s+fromIntegral ds)) - - --- | A 'TimeSeq' for seconds. -seconds :: TimeSeq -seconds t = (iterate rev t1, tail (iterate fwd t1)) - where h0 = todHour (localTimeOfDay t) - m0 = todMin (localTimeOfDay t) - s0 = todSec (localTimeOfDay t) - t0 = LocalTime (localDay t) (TimeOfDay h0 m0 s0) - t1 = if t0 < t then t0 else (rev t0) - rev = addTod 0 0 (-1) - fwd = addTod 0 0 1 - toTime h = LocalTime - --- | A 'TimeSeq' for minutes. -minutes :: TimeSeq -minutes 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 (-1)0 - fwd = addTod 0 1 0 - toTime h = LocalTime - --- | 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 - toTime h = LocalTime - --- | 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 - | tdiff==0 && dsec<60 = timeAxis seconds seconds (ft "%H:%M:%S") pts - | tdiff==0 && dsec<3600 = timeAxis minutes minutes (ft "%H:%M") pts - | tdiff < 1 = timeAxis hours hours (ft "%H:%M") pts - | tdiff < 2 = timeAxis days hours (ft "%d-%b") pts - | tdiff < 15 = timeAxis days days (ft "%d-%b") pts - | tdiff < 90 = timeAxis days months (ft "%b-%y") pts - | tdiff < 450 = timeAxis months months (ft "%b-%y") pts - | tdiff < 1800 = timeAxis months years (ft "%Y") pts - | otherwise = timeAxis years years (ft "%Y") pts - where - tdiff = diffDays (localDay t1) (localDay t0) - dsec = fromIntegral (3600*(h1-h0)+60*(m1-m0))+(s1-s0) - where (TimeOfDay h0 m0 s0) = localTimeOfDay t0 - (TimeOfDay h1 m1 s1) = localTimeOfDay t1 - t1 = maximum pts - t0 = minimum pts - ft = formatTime defaultTimeLocale - - -unitAxis :: AxisData () -unitAxis = AxisData { - axis_viewport_ = \(x0,x1) _ -> (x0+x1)/2, - axis_ticks_ = [((), 0)], - axis_labels_ = [((), "")], - axis_grid_ = [] -} - ------------------------------------------------------------------------------ - -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, Num, Real, Fractional, RealFrac, Floating, RealFloat) - -instance Show LogValue where - show (LogValue x) = show x - -instance PlotValue LogValue where - toValue (LogValue x) = log x - autoAxis = autoScaledLogAxis defaultLogAxis - -instance PlotValue Int where - toValue = fromIntegral - autoAxis = autoScaledIntAxis defaultIntAxis - -instance PlotValue Integer where - toValue = fromIntegral - autoAxis = autoScaledIntAxis defaultIntAxis - -instance PlotValue () where - toValue () = 0 - autoAxis = const unitAxis - -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,Enum,Num,Real,Integral,Show) - -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 :: Integral i => [String] -> [i] -> AxisData i -autoIndexAxis labels vs = AxisData { - axis_viewport_ = vport, - axis_ticks_ = [], - axis_labels_ = filter (\(i,l) -> 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) - imin = minimum vs - imax = maximum vs - --- | 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) - --- | 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) - ----------------------------------------------------------------------- --- 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.LocalTime +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,224 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis.Floating +-- Copyright : (c) Tim Docker 2010 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Calculate and render floating value axes +-- including doubles with linear, log, and percentage scaling. +-- + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Axis.Floating( + Percent(..), + LinearAxisParams(..), + LogValue(..), + LogAxisParams(..), + defaultLinearAxis, + defaultLogAxis, + autoScaledAxis, + autoScaledLogAxis, + autoSteps, + + la_labelf, + la_nLabels, + la_nTicks, + + loga_labelf +) where + +import Data.List(minimumBy) +import Data.Ord (comparing) + +import Data.Accessor.Template +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Axis.Types + +instance PlotValue Double where + toValue = id + fromValue= id + autoAxis = autoScaledAxis defaultLinearAxis + +-- | 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 defaultLinearAxis{-la_labelf_=-} + +-- | A wrapper class for doubles used to indicate they are to +-- be plotted against a log axis. +newtype LogValue = LogValue 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 defaultLogAxis + +showD x = case reverse $ show x of + '0':'.':r -> reverse r + _ -> show x + +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 +} + +defaultLinearAxis :: (Show a) => LinearAxisParams a +defaultLinearAxis = LinearAxisParams { + la_labelf_ = showD, + la_nLabels_ = 5, + la_nTicks_ = 50 +} + +-- | Generate a linear axis automatically, scaled appropriately for the +-- input data. +autoScaledAxis :: RealFloat a => LinearAxisParams a -> AxisFn a +autoScaledAxis lap ps0 = makeAxis' realToFrac realToFrac + (la_labelf_ lap) (labelvs,tickvs,gridvs) + where + ps = filter isValidNumber ps0 + (min,max) = (minimum ps,maximum ps) + range [] = (0,1) + range _ | min == max = (min-1,min+1) + | 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 + +steps :: RealFloat a => a -> (a,a) -> [Rational] +steps nSteps (min,max) = map ((s*) . fromIntegral) [min' .. max'] + where + s = chooseStep nSteps (min,max) + min' = floor $ realToFrac min / s + max' = ceiling $ realToFrac max / s + n = (max' - min') + + +chooseStep :: RealFloat a => a -> (a,a) -> Rational +chooseStep nsteps (x1,x2) = minimumBy (comparing proximity) steps + where + delta = x2 - x1 + mult = 10 ^^ (floor $ log10 $ delta / nsteps) + steps = map (mult*) [0.1,0.2,0.25,0.5,1.0,2.0,2.5,5.0,10,20,25,50] + 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 _ | min == max = (min-0.5,min+0.5) + | otherwise = (min,max) + (min,max) = (minimum ps,maximum ps) + ps = filter isValidNumber vs + r = range ps + +---------------------------------------------------------------------- + +defaultLogAxis :: Show a => LogAxisParams a +defaultLogAxis = LogAxisParams { + loga_labelf_ = showD +} + +-- | Generate a log axis automatically, scaled appropriate for the +-- input data. +autoScaledLogAxis :: RealFloat a => LogAxisParams a -> AxisFn a +autoScaledLogAxis lap ps0 = + makeAxis' (realToFrac . log) (realToFrac . exp) + (loga_labelf_ lap) (wrap rlabelvs, wrap rtickvs, wrap rgridvs) + where + ps = filter (\x -> isValidNumber x && 0 < x) ps0 + (min,max) = (minimum ps,maximum ps) + wrap = map fromRational + range [] = (3,30) + range _ | min == max = (realToFrac $ min/3, realToFrac $ max*3) + | otherwise = (realToFrac $ min, realToFrac $ max) + (rlabelvs, rtickvs, rgridvs) = logTicks (range ps) + + +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 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 + 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) + inRange (a,b) l x = (lower a l <= x) && (x <= upper b l) + major | 17.5 < log10 ratio = map (\x -> 10^^(round x)) $ + steps (min 5 (log10 ratio)) + (log10 low, log10 high) + | 12 < log10 ratio = map (\x -> 10^^(round x)) $ + steps ((log10 ratio)/5) (log10 low, log10 high) + | 6 < log10 ratio = map (\x -> 10^^(round x)) $ + steps ((log10 ratio)/2) (log10 low, log10 high) + | 3 < log10 ratio = midselection (low,high) [1,10] + | 20 < ratio = midselection (low,high) [1,5,10] + | 6 < ratio = midselection (low,high) [1,2,4,6,8,10] + | 3 < ratio = midselection (low,high) [1..10] + | otherwise = steps 5 (low,high) + (l',h') = (minimum major, maximum major) + (dl',dh') = (fromRational l', fromRational h') + ratio' = fromRational (h'/l') + minor | 50 < log10 ratio' = map (\x -> 10^^(round x)) $ + steps 50 (log10 $ dl', log10 $ dh') + | 6 < log10 ratio' = filter (\x -> l'<=x && x <=h') $ + powers (dl', dh') [1,10] + | 3 < log10 ratio' = filter (\x -> l'<=x && x <=h') $ + powers (dl',dh') [1,5,10] + | 6 < ratio' = filter (\x -> l'<=x && x <=h') $ + powers (dl',dh') [1..10] + | 3 < ratio' = filter (\x -> l'<=x && x <=h') $ + powers (dl',dh') [1,1.2..10] + | otherwise = steps 50 (dl', dh') + +log10 :: (Floating a) => a -> a +log10 = logBase 10 + +frac x | 0 <= b = (a,b) + | otherwise = (a-1,b+1) + where + (a,b) = properFraction x + +$( deriveAccessors ''LinearAxisParams ) +$( deriveAccessors ''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,50 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis.Unit +-- Copyright : (c) Tim Docker 2010 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Calculate and render indexed axes + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Axis.Indexed( + PlotIndex(..), + autoIndexAxis, + addIndexes, +) where + +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 as = map (\(i,a) -> (PlotIndex i,a)) (zip [0..] as) + +-- | Create an axis for values indexed by position. The +-- list of strings are the labels to be used. +autoIndexAxis :: Integral i => [String] -> [i] -> AxisData i +autoIndexAxis labels vs = AxisData { + axis_viewport_ = vport, + axis_tropweiv_ = invport, + axis_ticks_ = [], + axis_labels_ = [filter (\(i,l) -> i >= imin && i <= imax) + (zip [0..] labels)], + axis_grid_ = [] + } + where + vport r i = linMap id ( fromIntegral imin - 0.5 + , fromIntegral imax + 0.5) r (fromIntegral i) + invport r z = invLinMap round fromIntegral (imin, imax) r z + imin = minimum vs + imax = maximum vs 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,73 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis.Int +-- Copyright : (c) Tim Docker 2010 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Calculate and render integer indexed axes + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Axis.Int( + defaultIntAxis, + autoScaledIntAxis +) where + +import Data.List(genericLength) +import Graphics.Rendering.Chart.Types +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 Integer where + toValue = fromIntegral + fromValue = round + autoAxis = autoScaledIntAxis defaultIntAxis + +defaultIntAxis :: (Show a) => LinearAxisParams a +defaultIntAxis = LinearAxisParams { + la_labelf_ = show, + la_nLabels_ = 5, + la_nTicks_ = 10 +} + +autoScaledIntAxis :: (Integral i, PlotValue i) => + LinearAxisParams i -> AxisFn i +autoScaledIntAxis lap ps = + makeAxis (la_labelf_ lap) (labelvs,tickvs,gridvs) + where + (min,max) = (minimum ps,maximum ps) + range [] = (0,1) + range _ | min == max = (fromIntegral $ min-1, fromIntegral $ min+1) + | otherwise = (fromIntegral $ min, fromIntegral $ max) +-- 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 + + goodness vs = abs (genericLength vs - nSteps) + + (alt0:alts) = map (\n -> steps n range) sampleSteps + + sampleSteps = [1,2,5] ++ sampleSteps1 + sampleSteps1 = [10,20,25,50] ++ map (*10) sampleSteps1 + + steps size (min,max) = 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 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 :: TimeSeq -> LocalTime -> LocalTime -> [LocalTime] +enumerateTS tseq min max = + reverse (takeWhile (>=min) ts1) ++ takeWhile (<=max) ts2 + where + (ts1,ts2) = tseq min + +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 first 'TimeSeq' sets the +-- minor ticks, and the ultimate range will be aligned to its elements. +-- The second 'TimeSeq' sets the labels and grid. The third 'TimeSeq' +-- sets the second line of labels. The 'TimeLabelFn' is +-- used to format LocalTimes for labels. The values to be plotted +-- against this axis can be created with 'doubleFromLocalTime'. +timeAxis :: TimeSeq -> TimeSeq -> TimeLabelFn -> TimeLabelAlignment -> + TimeSeq -> TimeLabelFn -> TimeLabelAlignment -> + AxisFn LocalTime +timeAxis tseq lseq labelf lal cseq contextf clal pts = AxisData { + 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 + (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 + ctimes = coverTS cseq min max + 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 m2 = 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` (fromIntegral 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 (fromIntegral 1 / 1000) +millis10 = secondSeq (fromIntegral 1 / 100) +millis100 = secondSeq (fromIntegral 1 / 10) +seconds = secondSeq (fromIntegral 1) +fiveSeconds = secondSeq (fromIntegral 5) + +minuteSeq :: Int -> TimeSeq +minuteSeq step t = (iterate rev t1, tail (iterate fwd t1)) + where h0 = todHour (localTimeOfDay t) + m0 = todMin (localTimeOfDay t) + t0 = LocalTime (localDay t) (TimeOfDay h0 m0 0) + t1 = if t0 < t then t0 else (rev t0) + rev = addTod 0 (negate step) (fromIntegral 0) + fwd = addTod 0 step (fromIntegral 0) + + +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 (fromIntegral 0) + fwd = addTod 1 0 (fromIntegral 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,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 + +-- | A 'TimeSeq' for no sequence at all. +noTime :: TimeSeq +noTime t = ([],[]) + +-- | 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/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,405 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis.Types +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Type definitions for Axes +-- + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Axis.Types( + AxisData(..), + AxisT(..), + AxisStyle(..), + PlotValue(..), + AxisFn, + + defaultAxisLineStyle, + defaultAxisStyle, + defaultGridLineStyle, + + makeAxis, + makeAxis', + + axisToRenderable, + renderAxisGrid, + axisOverhang, + vmap, + invmap, + + linMap, + invLinMap, + + axisGridAtTicks, + axisGridAtLabels, + axisGridHide, + axisTicksHide, + axisLabelsHide, + + axis_viewport, + axis_tropweiv, + axis_ticks, + axis_labels, + axis_grid, + + axis_line_style, + axis_label_style, + axis_grid_style, + axis_label_gap, + +) where + +import qualified Graphics.Rendering.Cairo as C +import Data.Time +import Data.Fixed +import System.Locale (defaultTimeLocale) +import Control.Monad +import Data.List(sort,intersperse) +import Data.Accessor.Template +import Data.Colour (opaque) +import Data.Colour.Names (black, lightgrey) + +import Graphics.Rendering.Chart.Types +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 + +-- | The basic data associated with an axis showing values of type x. +data AxisData x = AxisData { + + -- | 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 { + 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) + +-- | 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 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 remove ticks from an axis +axisTicksHide :: AxisData x -> AxisData x +axisTicksHide ad = ad{ axis_ticks_ = [] } + +-- | Modifier to remove labels from an axis +axisLabelsHide :: AxisData x -> AxisData x +axisLabelsHide ad = ad{ axis_labels_ = []} + +minsizeAxis :: AxisT x -> CRender RectSize +minsizeAxis (AxisT at as rev ad) = do + labelSizes <- preserveCState $ do + setFontStyle (axis_label_style_ as) + mapM (mapM textSize) (labelTexts ad) + + let ag = axis_label_gap_ as + let tsize = maximum ([0] ++ [ max 0 (-l) | (v,l) <- axis_ticks_ ad ]) + + 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 [] = 0 +maximum0 vs = maximum vs + +-- | 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 . concat . 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} + strokePath [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) + labelSizes <- mapM (mapM textSize) (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,length) = + let t1 = axisPoint value + t2 = t1 `pvadd` (vscale length tp) + in strokePath [t1,t2] + + (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 (\n -> eachNth n 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 + drawText hta vta (axisPoint value `pvadd` (awayFromAxis offset)) s + textSize 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 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 as rev ad) (x2,y2) = case et of + E_Top -> (x1,y2,x2,y2, (Vector 0 1), mapx y2, imapx) + E_Bottom -> (x1,y1,x2,y1, (Vector 0 (-1)), mapx y1, imapx) + E_Left -> (x2,y2,x2,y1, (Vector (1) 0), mapy x2, imapy) + E_Right -> (x1,y2,x1,y1, (Vector (-1) 0), mapy x1, imapy) + where + (x1,y1) = (0,0) + xr = reverse (x1,x2) + yr = reverse (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 + + 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,invAxisPoint) = 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 strokePath [Point v' 0,Point v' h] + + hline v = let v' = p_y (axisPoint v) + in strokePath [Point 0 v',Point w v'] + + +-- | 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_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 = [ (v,labelf v) | v <- labelvs ] + 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_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_ = [[ (v,labelf v) | v <- labelvs ]] + } + + +---------------------------------------------------------------------- + +defaultAxisLineStyle :: CairoLineStyle +defaultAxisLineStyle = solidLine 1 $ opaque black + +defaultGridLineStyle :: CairoLineStyle +defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey + +defaultAxisStyle :: AxisStyle +defaultAxisStyle = AxisStyle { + axis_line_style_ = defaultAxisLineStyle, + axis_label_style_ = defaultFontStyle, + axis_grid_style_ = defaultGridLineStyle, + axis_label_gap_ = 10 +} + +---------------------------------------------------------------------- + +-- | 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 + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor for +-- each field. +$( deriveAccessors ''AxisData ) +$( deriveAccessors ''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,30 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Axis.Unit +-- Copyright : (c) Tim Docker 2010 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Calculate and render unit indexed axes + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Axis.Unit( + unitAxis, +) where + +import Graphics.Rendering.Chart.Axis.Types + +instance PlotValue () where + toValue () = 0 + fromValue = const () + autoAxis = const unitAxis + +unitAxis :: AxisData () +unitAxis = AxisData { + axis_viewport_ = \(x0,x1) _ -> (x0+x1)/2, + axis_tropweiv_ = \_ _ -> (), + axis_ticks_ = [((), 0)], + axis_labels_ = [[((), "")]], + axis_grid_ = [] +} 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,3 +1,12 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Grid +-- Copyright : (c) Tim Docker 2010 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- A container type for values that can be composed by horizonal +-- and vertical layout. + module Graphics.Rendering.Chart.Grid ( Grid, Span, tval, tspan, @@ -266,7 +275,8 @@ p1'@(Point x1 y1) <- alignc p1 preserveCState $ do c $ C.translate x0 y0 - render r (x1-x0,y1-y0) + pf <- render r (x1-x0,y1-y0) + return (newpf pf x0 y0) (Above t1 t2 _) -> do pf1 <- rf1 borders (i,j) t1 pf2 <- rf1 borders (i,j+height t1) t2 @@ -284,6 +294,8 @@ 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] diff --git a/Graphics/Rendering/Chart/Gtk.hs b/Graphics/Rendering/Chart/Gtk.hs --- a/Graphics/Rendering/Chart/Gtk.hs +++ b/Graphics/Rendering/Chart/Gtk.hs @@ -5,7 +5,9 @@ -- License : BSD-style (see chart/COPYRIGHT) module Graphics.Rendering.Chart.Gtk( - renderableToWindow + renderableToWindow, + createRenderableWindow, + updateCanvas ) where import qualified Graphics.UI.Gtk as G 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 @@ -28,9 +28,11 @@ module Graphics.Rendering.Chart.Layout( Layout1(..), LayoutAxis(..), + Layout1Pick(..), MAxisFn, defaultLayout1, + layout1ToRenderable, linkAxes, independentAxes, @@ -137,11 +139,14 @@ } data Layout1Pick x y = L1P_Legend String + | L1P_Title String + | L1P_AxisTitle String | L1P_PlotArea x y y | L1P_BottomAxis x | L1P_TopAxis x | L1P_LeftAxis y | L1P_RightAxis y + deriving (Show) instance (Ord x, Ord y) => ToRenderable (Layout1 x y) where toRenderable = setPickFn nullPickFn.layout1ToRenderable @@ -213,8 +218,11 @@ where lm = layout1_margin_ l -layout1TitleToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable a -layout1TitleToRenderable l = addMargins (lm/2,0,0,0) title +layout1TitleToRenderable :: (Ord x, Ord y) => Layout1 x y + -> Renderable (Layout1Pick x y) +layout1TitleToRenderable l | null (layout1_title_ l) = emptyRenderable +layout1TitleToRenderable l = addMargins (lm/2,0,0,0) + (mapPickFn L1P_Title title) where title = label (layout1_title_style_ l) HTA_Centre VTA_Centre (layout1_title_ l) @@ -266,7 +274,8 @@ er = tval $ emptyRenderable atitle ha va rot af = if ttext == "" then er - else tval $ rlabel tstyle ha va rot ttext + else tval $ mapPickFn L1P_AxisTitle + $ rlabel tstyle ha va rot ttext where tstyle = laxis_title_style_ (af l) ttext = laxis_title_ (af l) @@ -305,7 +314,7 @@ setClipRegion (Point 0 0) (Point w h) mapM_ rPlot (layout1_plots_ l) when (layout1_grid_last_ l) renderGrids - return nullPickFn + return pickfn where (bAxis,lAxis,tAxis,rAxis) = getAxes l @@ -313,16 +322,34 @@ rPlot (Left p) = rPlot1 bAxis lAxis p rPlot (Right p) = rPlot1 bAxis rAxis p + xr = (0, w) + yr = (h, 0) + reverse rev (a,b) = if rev then (b,a) else (a,b) + rPlot1 (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p = - let xrange = if xrev then (w, 0) else (0, w) + let + xr1 = reverse xrev xr + yr1 = reverse yrev yr 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) + pmfn (x,y) = Point (mapv xr1 (axis_viewport_ xaxis xr1) x) + (mapv yr1 (axis_viewport_ yaxis yr1) y) mapv (min,max) _ LMin = min mapv (min,max) _ LMax = max mapv _ f (LValue v) = f v in plot_render_ p pmfn rPlot1 _ _ _ = return () + + pickfn (Point x y) = Just (L1P_PlotArea xv yv1 yv2) + where + xv = case (bAxis,tAxis) of + (Just at,_) -> mapx at x + (_,Just at) -> mapx at x + (yv1,yv2) = case (lAxis,rAxis) of + (Just at,Nothing) -> (mapy at y,mapy at y) + (Nothing,Just at) -> (mapy at y,mapy at y) + (Just at1,Just at2) -> (mapy at1 y,mapy at2 y) + mapx (AxisT _ _ rev ad) x = axis_tropweiv_ ad (reverse rev xr) x + mapy (AxisT _ _ rev ad) y = axis_tropweiv_ ad (reverse rev yr) y renderGrids = do maybeM () (renderAxisGrid sz) tAxis 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 @@ -3,6 +3,9 @@ -- Module : Graphics.Rendering.Chart.Legend -- Copyright : (c) Tim Docker 2006 -- License : BSD-style (see chart/COPYRIGHT) +-- +-- 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. {-# OPTIONS_GHC -XTemplateHaskell #-} @@ -24,7 +27,7 @@ import Data.Accessor.Template import Graphics.Rendering.Chart.Types -import Graphics.Rendering.Chart.Plot +import Graphics.Rendering.Chart.Plot.Types import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Grid @@ -73,7 +76,7 @@ minsize = return (legend_plot_size_ ls, 0), render = \(w,h) -> do rfn (Rect (Point 0 0) (Point w h)) - return nullPickFn + return (\_-> Just title) } ggap1 = tval $ spacer (legend_margin_ ls,legend_margin_ ls / 2) 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,228 +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 -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 -defaultPieItem = PieItem "" 0 0 - -defaultPieLayout :: PieLayout -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,676 +4,34 @@ -- 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' --- --- * 'PlotHidden' --- --- * 'PlotAnnotation' --- --- 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. -- - +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -XTemplateHaskell #-} module Graphics.Rendering.Chart.Plot( - -- * Plot - Plot(..), - joinPlot, - -- ** Typeclass for casting to plot - ToPlot(..), - -- * Point plots - PlotPoints(..), - defaultPlotPoints, - -- * Lines plot - PlotLines(..), - defaultPlotLines, - defaultPlotLineStyle, - hlinePlot, - vlinePlot, - -- * Plot with error bars - PlotErrBars(..), - defaultPlotErrBars, - ErrPoint(..), - ErrValue(..), - symErrPoint, - -- * Plot with filled area - PlotFillBetween(..), - defaultPlotFillBetween, - -- * Bar plots - PlotBars(..), - defaultPlotBars, - PlotBarsStyle(..), - PlotBarsSpacing(..), - PlotBarsAlignment(..), - BarsPlotValue(..), - -- * Invisible plot - PlotHidden(..), - -- Annotation plot - PlotAnnotation(..), - defaultPlotAnnotation, - - -- * Accessors - -- | These accessors are generated by template haskell - plot_lines_title, - plot_lines_style, - plot_lines_values, - plot_lines_limit_values, - - 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_alignment, - plot_bars_reference, - plot_bars_singleton_width, - plot_bars_values, - - plot_annotation_hanchor, - plot_annotation_vanchor, - plot_annotation_angle, - plot_annotation_style, - plot_annotation_values - ) where - -import qualified Graphics.Rendering.Cairo as C -import Graphics.Rendering.Chart.Types -import Graphics.Rendering.Chart.Renderable -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 - --- | 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) - ----------------------------------------------------------------------- - --- | 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 mapfn pts = strokePath (map mapfn pts) - -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 - strokePath [Point (p_x p1) y, Point (p_x p2) y] - -defaultPlotLineStyle :: CairoLineStyle -defaultPlotLineStyle = (solidLine 1 $ opaque blue){ - line_cap_ = C.LineCapRound, - line_join_ = C.LineJoinRound - } - -defaultPlotLines :: PlotLines x y -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 x y -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) - fillPath ([p0] ++ p1s ++ reverse p2s ++ [p0]) - 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) - 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 - - -defaultPlotFillBetween :: PlotFillBetween x y -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 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_ :: 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 x y -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 = (+) -instance BarsPlotValue Int where - barsReference = 0 - 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 -- ^ The right edge of bars is at deviceX - | BarsRight -- ^ Bars are centered around deviceX - deriving (Show) - --- | Value describing how to plot a set of bars. --- Note that the input data is typed [(x,[y])], ie for each x value --- we plot several y values. Typically the size of each [y] list would --- be the same. -data PlotBars x y = PlotBars { - -- | 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, - - -- | This value controls how bars for a fixed x are aligned with - -- respect to the device coordinate corresponding to x. - plot_bars_alignment_ :: PlotBarsAlignment, - - -- | The starting level for the chart (normally 0). - plot_bars_reference_ :: y, - - plot_bars_singleton_width_ :: Double, - - -- | 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 2, - plot_bars_alignment_ = BarsCentered, - plot_bars_values_ = [], - plot_bars_singleton_width_ = 20, - 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 -> 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 - fillPath (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 - strokePath (barPath (offset i) x yref0 y) - - offset = case (plot_bars_alignment_ p) of - BarsLeft -> \i -> fromIntegral i * width - BarsRight -> \i -> fromIntegral (i-nys) * width - BarsCentered -> \i -> fromIntegral (2*i-nys) * width/2 - - stackedBars (x,ys) = preserveCState $ do - let y2s = zip (yref0:stack ys) (stack ys) - let ofs = case (plot_bars_alignment_ p) of { - BarsLeft -> 0 ; - BarsRight -> (-width) ; - BarsCentered -> (-width/2) - } - forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> do - setFillStyle fstyle - fillPath (barPath ofs x y0 y1) - forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> do - whenJust mlstyle $ \lstyle -> do - setLineStyle lstyle - strokePath (barPath ofs x y0 y1) - - 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 minw -> let w = max (minXInterval - gap) minw in - case (plot_bars_style_ p) of - BarsClustered -> w / fromIntegral nys - BarsStacked -> w - BarsFixWidth width -> width - styles = plot_bars_item_styles_ p - - minXInterval = let diffs = zipWith (-) (tail mxs) mxs - in if null diffs - then plot_bars_singleton_width_ p - else minimum diffs - where - xs = fst (allBarPoints p) - mxs = nub $ sort $ map mapX xs - - nys = maximum [ length ys | (x,ys) <- vals ] - - pmap' = mapXY pmap - mapX x = p_x (pmap' (x,barsReference)) - -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], y0:concat [ys| (_,ys) <- pts] ) - BarsStacked -> ( [x| (x,_) <- pts], y0:concat [stack ys | (_,ys) <- pts] ) - where - pts = plot_bars_values_ p - y0 = plot_bars_reference_ p - -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 - fillPath (rectPath r) - ----------------------------------------------------------------------- - --- | Value defining some hidden x and y values. The values don't --- get displayed, but 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) - } - - - ----------------------------------------------------------------------- - --- | Value for describing a series of text annotations --- to be placed at arbitrary points on the graph. Annotations --- can be rotated and styled. Rotation angle is given in degrees, --- rotation is performend around the anchor point. - -data PlotAnnotation x y = PlotAnnotation { - plot_annotation_hanchor_ :: HTextAnchor, - plot_annotation_vanchor_ :: VTextAnchor, - plot_annotation_angle_ :: Double, - plot_annotation_style_ :: CairoFontStyle, - plot_annotation_values_ :: [(x,y,String)] -} - - -instance ToPlot PlotAnnotation where - toPlot p = Plot { - plot_render_ = renderAnnotation p, - plot_legend_ = [], - plot_all_points_ = (map (\(x,_,_)->x) vs , map (\(_,y,_)->y) vs) - } - where - vs = plot_annotation_values_ p - - -renderAnnotation :: PlotAnnotation x y -> PointMapFn x y -> CRender () - -renderAnnotation p pMap = preserveCState $ do - setFontStyle style - mapM_ drawOne values - where hta = plot_annotation_hanchor_ p - vta = plot_annotation_vanchor_ p - values = plot_annotation_values_ p - angle = plot_annotation_angle_ p - style = plot_annotation_style_ p - drawOne (x,y,s) = drawTextR hta vta angle point s - where point = pMap (LValue x, LValue y) - -defaultPlotAnnotation = PlotAnnotation { - plot_annotation_hanchor_ = HTA_Centre, - plot_annotation_vanchor_ = VTA_Centre, - plot_annotation_angle_ = 0, - plot_annotation_style_ = defaultFontStyle, - plot_annotation_values_ = [] -} - - + module Graphics.Rendering.Chart.Plot.Types, + module Graphics.Rendering.Chart.Plot.Lines, + 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, +) 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 ) -$( deriveAccessors ''PlotHidden ) -$( deriveAccessors ''PlotAnnotation ) +import Graphics.Rendering.Chart.Plot.Types +import Graphics.Rendering.Chart.Plot.Lines +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 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,80 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Annotation +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Show textual annotations on a chart. + +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Annotation( + PlotAnnotation(..), + defaultPlotAnnotation, + + plot_annotation_hanchor, + plot_annotation_vanchor, + plot_annotation_angle, + plot_annotation_style, + plot_annotation_values +) where + +import Data.Accessor.Template +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Plot.Types +import Data.Colour (opaque) +import Data.Colour.Names (black, blue) +import Data.Colour.SRGB (sRGB) +-- | Value for describing a series of text annotations +-- to be placed at arbitrary points on the graph. Annotations +-- can be rotated and styled. Rotation angle is given in degrees, +-- rotation is performend around the anchor point. + +data PlotAnnotation x y = PlotAnnotation { + plot_annotation_hanchor_ :: HTextAnchor, + plot_annotation_vanchor_ :: VTextAnchor, + plot_annotation_angle_ :: Double, + plot_annotation_style_ :: CairoFontStyle, + plot_annotation_values_ :: [(x,y,String)] +} + + +instance ToPlot PlotAnnotation where + toPlot p = Plot { + plot_render_ = renderAnnotation p, + plot_legend_ = [], + plot_all_points_ = (map (\(x,_,_)->x) vs , map (\(_,y,_)->y) vs) + } + where + vs = plot_annotation_values_ p + + +renderAnnotation :: PlotAnnotation x y -> PointMapFn x y -> CRender () + +renderAnnotation p pMap = preserveCState $ do + setFontStyle style + mapM_ drawOne values + where hta = plot_annotation_hanchor_ p + vta = plot_annotation_vanchor_ p + values = plot_annotation_values_ p + angle = plot_annotation_angle_ p + style = plot_annotation_style_ p + drawOne (x,y,s) = drawTextsR hta vta angle point s + where point = pMap (LValue x, LValue y) + +defaultPlotAnnotation = PlotAnnotation { + plot_annotation_hanchor_ = HTA_Centre, + plot_annotation_vanchor_ = VTA_Centre, + plot_annotation_angle_ = 0, + plot_annotation_style_ = defaultFontStyle, + plot_annotation_values_ = [] +} + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. + +$( deriveAccessors ''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,202 @@ +-- | +-- 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. + +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.AreaSpots + ( AreaSpots(..) + , defaultAreaSpots + + , area_spots_title + , area_spots_linethick + , area_spots_linecolour + , area_spots_fillcolour + , area_spots_max_radius + , area_spots_values + + , AreaSpots4D(..) + , defaultAreaSpots4D + + , area_spots_4d_title + , area_spots_4d_linethick + , area_spots_4d_palette + , area_spots_4d_max_radius + , area_spots_4d_values + ) where + +import qualified Graphics.Rendering.Cairo as C + +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Plot.Types +import Graphics.Rendering.Chart.Axis +import Data.Accessor.Template +import Data.Colour +import Data.Colour.Names + +import Control.Monad + + +-- stuff that belongs in Data.Tuple +fst3 (a,_,_) = a +snd3 (_,a,_) = a +thd3 (_,_,a) = a + +fst4 (a,_,_,_) = a +snd4 (_,a,_,_) = a +thd4 (_,_,a,_) = a +fth4 (_,_,_,a) = a + + +-- | A collection of unconnected spots, with x,y position, and an +-- independent z value to be represented by the area of the spot. +data AreaSpots z x y = AreaSpots + { area_spots_title_ :: String + , area_spots_linethick_ :: Double + , area_spots_linecolour_ :: AlphaColour Double + , area_spots_fillcolour_ :: AlphaColour Double + , area_spots_max_radius_ :: Double -- ^ the largest size of spot + , area_spots_values_ :: [(x,y,z)] + } + +defaultAreaSpots :: AreaSpots z x y +defaultAreaSpots = AreaSpots + { area_spots_title_ = "" + , area_spots_linethick_ = 0.1 + , area_spots_linecolour_ = opaque blue + , area_spots_fillcolour_ = flip withOpacity 0.2 blue + , 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 fst3 (area_spots_values_ p) + , map snd3 (area_spots_values_ p) ) + } + +renderAreaSpots :: (PlotValue z) => + AreaSpots z x y -> PointMapFn x y -> CRender () +renderAreaSpots p pmap = preserveCState $ + forM_ (scaleMax ((area_spots_max_radius_ p)^2) + (area_spots_values_ p)) + (\ (x,y,z)-> do + let radius = sqrt z + let (CairoPointStyle drawSpotAt) = filledCircles radius + (area_spots_fillcolour_ p) + drawSpotAt (pmap (LValue x, LValue y)) + let (CairoPointStyle drawOutlineAt) = hollowCircles radius + (area_spots_linethick_ p) + (area_spots_linecolour_ p) + drawOutlineAt (pmap (LValue x, LValue y)) + ) + where + scaleMax :: PlotValue z => Double -> [(x,y,z)] -> [(x,y,Double)] + scaleMax n points = let largest = maximum (map (toValue . thd3) points) + scale v = n * toValue v / largest + in map (\ (x,y,z) -> (x,y, scale z)) points + +renderSpotLegend :: AreaSpots z x y -> Rect -> CRender () +renderSpotLegend p r@(Rect p1 p2) = preserveCState $ do + let radius = min (abs (p_y p1 - p_y p2)) (abs (p_x p1 - p_x p2)) + centre = linearInterpolate p1 p2 + let (CairoPointStyle drawSpotAt) = filledCircles radius + (area_spots_fillcolour_ p) + drawSpotAt centre + let (CairoPointStyle drawOutlineAt) = hollowCircles radius + (area_spots_linethick_ p) + (area_spots_linecolour_ p) + drawOutlineAt 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_max_radius_ :: Double -- ^ the largest size of spot + , area_spots_4d_values_ :: [(x,y,z,t)] + } + +defaultAreaSpots4D :: AreaSpots4D z t x y +defaultAreaSpots4D = AreaSpots4D + { area_spots_4d_title_ = "" + , area_spots_4d_linethick_ = 0.1 + , area_spots_4d_palette_ = [ blue, green, yellow, orange, red ] + , 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 fst4 (area_spots_4d_values_ p) + , map snd4 (area_spots_4d_values_ p) ) + } + +renderAreaSpots4D :: (PlotValue z, PlotValue t, Show t) => + AreaSpots4D z t x y -> PointMapFn x y -> CRender () +renderAreaSpots4D p pmap = preserveCState $ + forM_ (scaleMax ((area_spots_4d_max_radius_ p)^2) + (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 (CairoPointStyle drawSpotAt) + = filledCircles radius (flip withOpacity 0.2 colour) + drawSpotAt (pmap (LValue x, LValue y)) + let (CairoPointStyle drawOutlineAt) + = hollowCircles radius (area_spots_4d_linethick_ p) + (opaque colour) + drawOutlineAt (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 (toValue . thd4) points) + scale v = n * toValue v / largest + colVals = map (toValue . fth4) 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 -> CRender () +renderSpotLegend4D p r@(Rect p1 p2) = preserveCState $ do + let radius = min (abs (p_y p1 - p_y p2)) (abs (p_x p1 - p_x p2)) + centre = linearInterpolate p1 p2 + let (CairoPointStyle drawSpotAt) = filledCircles radius + (flip withOpacity 0.2 $ + head (area_spots_4d_palette_ p)) + drawSpotAt centre + let (CairoPointStyle drawOutlineAt) = hollowCircles radius + (area_spots_4d_linethick_ p) + (opaque $ + head (area_spots_4d_palette_ p)) + drawOutlineAt centre + where + linearInterpolate (Point x0 y0) (Point x1 y1) = + Point (x0 + abs(x1-x0)/2) (y0 + abs(y1-y0)/2) + +------------------------------------------------------------------------- +-- Template haskell to derive Data.Accessor.Accessor +$( deriveAccessors ''AreaSpots ) +$( deriveAccessors ''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,225 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Bars +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Bar Charts +-- +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Bars( + PlotBars(..), + defaultPlotBars, + PlotBarsStyle(..), + PlotBarsSpacing(..), + PlotBarsAlignment(..), + BarsPlotValue(..), + + plotBars, + plot_bars_style, + plot_bars_item_styles, + plot_bars_titles, + plot_bars_spacing, + plot_bars_alignment, + plot_bars_reference, + plot_bars_singleton_width, + plot_bars_values, + +) where + +import Data.Accessor.Template +import Control.Monad +import Data.List(nub,sort) +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Plot.Types +import Graphics.Rendering.Chart.Axis +import Data.Colour (opaque) +import Data.Colour.Names (black, blue) +import Data.Colour.SRGB (sRGB) + +class PlotValue a => BarsPlotValue a where + barsReference :: a + barsAdd :: a -> a -> a + +instance BarsPlotValue Double where + barsReference = 0 + barsAdd = (+) +instance BarsPlotValue Int where + barsReference = 0 + 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 -- ^ The right edge of bars is at deviceX + | BarsRight -- ^ Bars are centered around deviceX + deriving (Show) + +-- | Value describing how to plot a set of bars. +-- Note that the input data is typed [(x,[y])], ie for each x value +-- we plot several y values. Typically the size of each [y] list would +-- be the same. +data PlotBars x y = PlotBars { + -- | 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, + + -- | This value controls how bars for a fixed x are aligned with + -- respect to the device coordinate corresponding to x. + plot_bars_alignment_ :: PlotBarsAlignment, + + -- | The starting level for the chart (normally 0). + plot_bars_reference_ :: y, + + plot_bars_singleton_width_ :: Double, + + -- | 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 2, + plot_bars_alignment_ = BarsCentered, + plot_bars_values_ = [], + plot_bars_singleton_width_ = 20, + 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 -> 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 + fillPath (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 + strokePath (barPath (offset i) x yref0 y) + + offset = case (plot_bars_alignment_ p) of + BarsLeft -> \i -> fromIntegral i * width + BarsRight -> \i -> fromIntegral (i-nys) * width + BarsCentered -> \i -> fromIntegral (2*i-nys) * width/2 + + stackedBars (x,ys) = preserveCState $ do + let y2s = zip (yref0:stack ys) (stack ys) + let ofs = case (plot_bars_alignment_ p) of { + BarsLeft -> 0 ; + BarsRight -> (-width) ; + BarsCentered -> (-width/2) + } + forM_ (zip y2s styles) $ \((y0,y1), (fstyle,_)) -> do + setFillStyle fstyle + fillPath (barPath ofs x y0 y1) + forM_ (zip y2s styles) $ \((y0,y1), (_,mlstyle)) -> do + whenJust mlstyle $ \lstyle -> do + setLineStyle lstyle + strokePath (barPath ofs x y0 y1) + + 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 minw -> let w = max (minXInterval - gap) minw in + case (plot_bars_style_ p) of + BarsClustered -> w / fromIntegral nys + BarsStacked -> w + BarsFixWidth width -> width + styles = plot_bars_item_styles_ p + + minXInterval = let diffs = zipWith (-) (tail mxs) mxs + in if null diffs + then plot_bars_singleton_width_ p + else minimum diffs + where + xs = fst (allBarPoints p) + mxs = nub $ sort $ map mapX xs + + nys = maximum [ length ys | (x,ys) <- vals ] + + pmap' = mapXY pmap + mapX x = p_x (pmap' (x,barsReference)) + +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], y0:concat [ys| (_,ys) <- pts] ) + BarsStacked -> ( [x| (x,_) <- pts], y0:concat [stack ys | (_,ys) <- pts] ) + where + pts = plot_bars_values_ p + y0 = plot_bars_reference_ p + +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 + fillPath (rectPath r) + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. + +$( deriveAccessors ''PlotBars ) + 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,165 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Candle +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Candlestick charts for financial plotting +-- +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Candle( + PlotCandle(..), + Candle(..), + defaultPlotCandle, + + 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 Data.Accessor.Template +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Plot.Types +import Control.Monad +import Data.Colour (opaque) +import Data.Colour.Names (black, white, blue) +import Data.Colour.SRGB (sRGB) + +-- | 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_ :: CairoLineStyle, + plot_candle_fill_ :: Bool, + plot_candle_rise_fill_style_ :: CairoFillStyle, + plot_candle_fall_fill_style_ :: CairoFillStyle, + 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 -> CRender () +renderPlotCandle p pmap = preserveCState $ do + 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 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 $ do setFillStyle (if open >= close + then plot_candle_rise_fill_style_ ps + else plot_candle_fall_fill_style_ ps) + + c $ C.newPath + c $ C.moveTo (x-wd) open + c $ C.lineTo (x-wd) close + c $ C.lineTo (x+wd) close + c $ C.lineTo (x+wd) open + c $ C.lineTo (x-wd) open + c $ C.fill + + setLineStyle (plot_candle_line_style_ ps) + c $ C.newPath + c $ C.moveTo (x-wd) open + c $ C.lineTo (x-wd) close + c $ C.lineTo (x+wd) close + c $ C.lineTo (x+wd) open + c $ C.lineTo (x-wd) open + c $ C.stroke + + c $ C.newPath + c $ C.moveTo x (min lo hi) + c $ C.lineTo x (min open close) + c $ C.moveTo x (max open close) + c $ C.lineTo x (max hi lo) + c $ C.stroke + + when (tl > 0) $ do c $ C.newPath + c $ C.moveTo (x-tl) lo + c $ C.lineTo (x+tl) lo + c $ C.moveTo (x-tl) hi + c $ C.lineTo (x+tl) hi + c $ C.stroke + + when (ct > 0) $ do c $ C.moveTo (x-ct) mid + c $ C.lineTo (x+ct) mid + c $ C.stroke + +renderPlotLegendCandle :: PlotCandle x y -> Rect -> CRender () +renderPlotLegendCandle p r@(Rect p1 p2) = preserveCState $ do + drawCandle p{ plot_candle_width_ = 2} + (Candle ((p_x p1 + p_x p2)*1/4) lo open mid close hi) + drawCandle p{ plot_candle_width_ = 2} + (Candle ((p_x p1 + p_x p2)*2/3) lo close mid open hi) + where + 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 + +defaultPlotCandle :: PlotCandle x y +defaultPlotCandle = 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_ = [] +} + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. + +$( deriveAccessors ''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,132 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.ErrBars +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Plot series of points with associated error bars. +-- +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.ErrBars( + PlotErrBars(..), + defaultPlotErrBars, + 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 Data.Accessor.Template +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Plot.Types +import Data.Colour (opaque) +import Data.Colour.Names (black, blue) +import Data.Colour.SRGB (sRGB) + +-- | 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_ :: 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 x y +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_ = [] +} + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. + +$( deriveAccessors ''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,84 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.FillBetween +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Plots that fill the area between two lines. +-- +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.FillBetween( + PlotFillBetween(..), + defaultPlotFillBetween, + + -- * Accessors + -- | These accessors are generated by template haskell + plot_fillbetween_title, + plot_fillbetween_style, + plot_fillbetween_values, +) where + +import Data.Accessor.Template +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Plot.Types +import Data.Colour (opaque) +import Data.Colour.Names (black, blue) +import Data.Colour.SRGB (sRGB) + +-- | 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) + fillPath ([p0] ++ p1s ++ reverse p2s ++ [p0]) + 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) + 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 + + +defaultPlotFillBetween :: PlotFillBetween x y +defaultPlotFillBetween = PlotFillBetween { + plot_fillbetween_title_ = "", + plot_fillbetween_style_ = solidFillStyle (opaque $ sRGB 0.5 0.5 1.0), + plot_fillbetween_values_ = [] +} + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. + +$( deriveAccessors ''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,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Hidden +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Plots that don't show, but occupy space so as to effect axis +-- scaling +-- +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Hidden( + PlotHidden(..), +) where + +import Data.Accessor.Template +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Plot.Types + +-- | Value defining some hidden x and y values. The values don't +-- get displayed, but still affect axis scaling. +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) + } + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. + +$( deriveAccessors ''PlotHidden ) + 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,109 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Lines +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Line plots +-- +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Lines( + PlotLines(..), + defaultPlotLines, + defaultPlotLineStyle, + hlinePlot, + vlinePlot, + + plot_lines_title, + plot_lines_style, + plot_lines_values, + plot_lines_limit_values, +) where + +import Data.Accessor.Template +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Plot.Types +import Data.Colour (opaque) +import Data.Colour.Names (black, blue) + +-- | 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, + + -- | 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 -> 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 mapfn pts = strokePath (map mapfn pts) + +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 + strokePath [Point (p_x p1) y, Point (p_x p2) y] + +defaultPlotLineStyle :: CairoLineStyle +defaultPlotLineStyle = (solidLine 1 $ opaque blue){ + line_cap_ = C.LineCapRound, + line_join_ = C.LineJoinRound + } + +defaultPlotLines :: PlotLines x y +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)]] + } + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. +$( deriveAccessors ''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,224 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Pie +-- Copyright : (c) Tim Docker 2008 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- A basic pie chart. +-- +-- Pie charts are handled different to other plots, in that they +-- have their own layout, and can't be composed with other plots. A +-- pie chart is rendered with code in the following form: +-- +-- @ +-- values :: [PieItem] +-- values = [...] +-- layout :: PieLayout +-- layout = pie_plot ^: pie_data ^= values +-- $ defaultPieLayout +-- renderable = toRenderable layout +-- @ + +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.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 +import Graphics.Rendering.Chart.Plot.Types + +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 +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 +defaultPieItem = PieItem "" 0 0 + +defaultPieLayout :: PieLayout +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) (setPickFn nullPickFn 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/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,75 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Points +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Functions to plot sets of points, marked in various styles. + +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Points( + PlotPoints(..), + defaultPlotPoints, + + -- * Accessors + -- | These accessors are generated by template haskell + + plot_points_title, + plot_points_style, + plot_points_values, +) where + +import Data.Accessor.Template +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable +import Graphics.Rendering.Chart.Plot.Types +import Data.Colour (opaque) +import Data.Colour.Names (black, blue) + +-- | 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 x y +defaultPlotPoints = PlotPoints { + plot_points_title_ = "", + plot_points_style_ = defaultPointStyle, + plot_points_values_ = [] +} + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. + +$( deriveAccessors ''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,83 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Chart.Plot.Types +-- Copyright : (c) Tim Docker 2006 +-- License : BSD-style (see chart/COPYRIGHT) +-- +-- Datatypes and functions common to the implementation of the various +-- plot types. +-- +{-# OPTIONS_GHC -XTemplateHaskell #-} + +module Graphics.Rendering.Chart.Plot.Types( + Plot(..), + joinPlot, + ToPlot(..), + + mapXY, + + plot_render, + plot_legend, + plot_all_points, + + ) where + +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable +import Control.Monad +import Data.Accessor.Template +import Data.Colour +import Data.Colour.Names + +-- | Interface to control plotting on a 2D area. +data Plot x y = Plot { + + -- | Given the mapping between model space coordinates and device + -- coordinates, render this plot into a chart. + plot_render_ :: PointMapFn x y -> 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 + +-- | 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) + +---------------------------------------------------------------------- + + + +---------------------------------------------------------------------- + +---------------------------------------------------------------------- +-- Template haskell to derive an instance of Data.Accessor.Accessor +-- for each field. +$( deriveAccessors ''Plot ) 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 @@ -41,6 +41,7 @@ ) where import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Cairo.Matrix as Matrix import Control.Monad import Data.Accessor import Data.List ( nub, transpose, sort ) @@ -113,17 +114,11 @@ 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)) + 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 @@ -138,11 +133,12 @@ -- | 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 :: Renderable a -> Int -> Int -> FilePath -> IO (PickFn a) renderableToPNGFile chart width height path = C.withImageSurface C.FormatARGB32 width height $ \result -> do - C.renderWith result $ runCRender rfn bitmapEnv + pick <- C.renderWith result $ runCRender rfn bitmapEnv C.surfaceWriteToPNG result path + return pick where rfn = do render chart (fromIntegral width, fromIntegral height) @@ -194,13 +190,14 @@ -- Labels -- | Construct a renderable from a text string, aligned with the axes. -label :: CairoFontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable a +label :: CairoFontStyle -> 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 + -> Renderable String rlabel fs hta vta rot s = Renderable { minsize = mf, render = rf } where mf = preserveCState $ do @@ -216,7 +213,7 @@ c $ C.rotate rot' c $ C.moveTo (-w/2) (h/2) c $ C.showText s - return nullPickFn + return (\_-> Just s) -- PickFn String xadj (w,h) HTA_Left x1 x2 = x1 +(w*acr+h*asr)/2 xadj (w,h) HTA_Centre x1 x2 = (x1 + x2)/2 xadj (w,h) HTA_Right x1 x2 = x2 -(w*acr+h*asr)/2 diff --git a/Graphics/Rendering/Chart/Simple.hs b/Graphics/Rendering/Chart/Simple.hs --- a/Graphics/Rendering/Chart/Simple.hs +++ b/Graphics/Rendering/Chart/Simple.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Simple @@ -32,7 +33,10 @@ -- > plotPS "foo.ps" [0,0.1..10] (sin . exp) "- " (sin . exp) "o-" ----------------------------------------------------------------------------- module Graphics.Rendering.Chart.Simple( plot, PlotKind(..), xcoords, - plotWindow, plotPDF, plotPS, +#if HAVE_GTK + plotWindow, +#endif + plotPDF, plotPS, plotLayout, plotPNG, Layout1DDD ) where @@ -41,7 +45,9 @@ import Data.Colour.Names import Graphics.Rendering.Chart +#if HAVE_GTK import Graphics.Rendering.Chart.Gtk +#endif styleColor :: Int -> AlphaColour Double styleColor ind = colorSequence !! ind @@ -223,6 +229,7 @@ instance PlotType Layout1DDD where pl args = uplot (reverse args) +#if HAVE_GTK -- | Display a plot on the screen. plotWindow :: PlotWindowType a => a @@ -235,6 +242,7 @@ plw args = do renderableToWindow (toRenderable $ uplot (reverse args)) 640 480 return undefined +#endif -- | Save a plot as a PDF file. diff --git a/Graphics/Rendering/Chart/Types.hs b/Graphics/Rendering/Chart/Types.hs --- a/Graphics/Rendering/Chart/Types.hs +++ b/Graphics/Rendering/Chart/Types.hs @@ -86,7 +86,9 @@ VTextAnchor(..), drawText, drawTextR, + drawTextsR, textSize, + textDrawRect, CRender(..), CEnv(..), @@ -116,6 +118,7 @@ import Data.Colour import Data.Colour.SRGB import Data.Colour.Names +import Data.List (unfoldr) -- | A point in two dimensions. data Point = Point { @@ -338,6 +341,28 @@ data HTextAnchor = HTA_Left | HTA_Centre | HTA_Right data VTextAnchor = VTA_Top | VTA_Centre | VTA_Bottom | VTA_BaseLine +-- | Recturn the bounding rectangle for a text string positioned +-- where it would be drawn by drawText +textDrawRect :: HTextAnchor -> VTextAnchor -> Point -> String -> CRender Rect +textDrawRect hta vta (Point x y) s = preserveCState $ textSize s >>= rect + where + rect (w,h) = c $ do te <- C.textExtents s + fe <- C.fontExtents + let lx = xadj hta (C.textExtentsWidth te) + let ly = yadj vta te fe + let (x',y') = (x + lx, y + ly) + let p1 = Point x' y' + let p2 = Point (x' + w) (y' + h) + return $ Rect p1 p2 + + 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) + -- | Function to draw a textual label anchored by one of its corners -- or edges. drawText :: HTextAnchor -> VTextAnchor -> Point -> String -> CRender () @@ -365,6 +390,42 @@ yadj VTA_Centre te fe = - (C.textExtentsYbearing te) / 2 yadj VTA_BaseLine te fe = 0 yadj VTA_Bottom te fe = -(C.fontExtentsDescent fe) + +-- | Function to 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. +drawTextsR :: HTextAnchor -> VTextAnchor -> Double -> Point -> String -> CRender () +drawTextsR hta vta angle (Point x y) s = preserveCState $ drawAll + where + ss = lines s + num = length ss + drawAll = c $ do tes <- mapM C.textExtents ss + fe <- C.fontExtents + let widths = map C.textExtentsWidth tes + maxw = maximum widths + maxh = maximum (map C.textExtentsYbearing tes) + 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 fe totalHeight)) + xs = map (xadj hta) widths + C.translate x y + C.rotate theta + sequence_ (zipWith3 draw xs ys ss) + + draw lx ly s = do C.moveTo lx ly + C.showText s + theta = angle*pi/180.0 + + xadj HTA_Left w = 0 + xadj HTA_Centre w = (-w/2) + xadj HTA_Right w = (-w) + + yinit VTA_Top fe height = C.fontExtentsAscent fe + yinit VTA_BaseLine fe height = 0 + yinit VTA_Centre fe height = height / 2 + C.fontExtentsAscent fe + yinit VTA_Bottom fe height = height + C.fontExtentsAscent fe -- | Execute a rendering action in a saved context (ie bracketed diff --git a/tests/ExampleStocks.hs b/tests/ExampleStocks.hs new file mode 100644 --- /dev/null +++ b/tests/ExampleStocks.hs @@ -0,0 +1,219 @@ +module ExampleStocks where +import Data.Time.Calendar +import Data.Time.LocalTime + +mkDate :: Integer -> LocalTime +mkDate jday = + LocalTime (ModifiedJulianDay jday) midnight + +-- Price data imported from Yahoo: low, open, close, high + +pricesAAPL :: [(LocalTime,(Double,Double,Double,Double))] +pricesMSFT :: [(LocalTime,(Double,Double,Double,Double))] +pricesARMH :: [(LocalTime,(Double,Double,Double,Double))] + +pricesAAPL = + [ (mkDate 55105,(180.7,185.35,180.86,186.22)) + , (mkDate 55104,(182.61,186.13,185.35,186.45)) + , (mkDate 55103,(184.31,186.73,185.38,187.4)) + , (mkDate 55102,(183.33,183.87,186.15,186.68)) + , (mkDate 55099,(181.44,182.01,182.37,185.5)) + , (mkDate 55098,(182.77,187.2,183.82,187.7)) + , (mkDate 55097,(185.03,185.4,185.5,188.9)) + , (mkDate 55096,(182.85,185.19,184.48,185.38)) + , (mkDate 55095,(181.62,184.29,184.02,185.16)) + , (mkDate 55092,(184.76,185.83,185.02,186.55)) + , (mkDate 55091,(181.97,181.98,184.55,186.79)) + , (mkDate 55090,(177.88,177.99,181.87,182.75)) + , (mkDate 55089,(173.59,174.04,175.16,175.65)) + , (mkDate 55088,(170.25,170.83,173.72,173.9)) + , (mkDate 55085,(170.87,172.91,172.16,173.18)) + , (mkDate 55084,(170.81,172.06,172.56,173.25)) + , (mkDate 55083,(169.7,172.78,171.14,174.47)) + , (mkDate 55082,(172.0,172.98,172.93,173.14)) + , (mkDate 55078,(167.09,167.28,170.31,170.7)) + , (mkDate 55077,(165.0,166.44,166.55,167.1)) + , (mkDate 55076,(164.11,164.62,165.18,167.61)) + , (mkDate 55075,(164.94,167.99,165.3,170.0)) + , (mkDate 55074,(166.5,168.16,168.21,168.85)) + , (mkDate 55071,(168.53,172.27,170.05,172.49)) + , (mkDate 55070,(164.83,168.75,169.45,169.57)) + , (mkDate 55069,(166.76,168.92,167.41,169.55)) + , (mkDate 55068,(169.13,169.46,169.4,170.94)) + , (mkDate 55067,(168.27,170.12,169.06,170.71)) + , (mkDate 55064,(166.8,167.65,169.22,169.37)) + , (mkDate 55063,(164.61,164.98,166.33,166.72)) + , (mkDate 55062,(162.45,162.75,164.6,165.3)) + , (mkDate 55061,(161.41,161.63,164.0,164.24)) + , (mkDate 55060,(159.42,163.55,159.59,163.59)) + , (mkDate 55057,(165.53,167.94,166.78,168.23)) + , (mkDate 55056,(166.5,166.65,168.42,168.67)) + , (mkDate 55055,(162.46,162.55,165.31,166.71)) + , (mkDate 55054,(161.88,163.69,162.83,164.38)) + , (mkDate 55053,(163.66,165.66,164.72,166.6)) + , (mkDate 55050,(164.8,165.49,165.51,166.6)) + , (mkDate 55049,(163.09,165.58,163.91,166.51)) + , (mkDate 55048,(164.21,165.75,165.11,167.39)) + , (mkDate 55047,(164.21,164.93,165.55,165.57)) + , (mkDate 55046,(164.87,165.21,166.43,166.64)) + , (mkDate 55043,(162.91,162.99,163.39,165.0)) + , (mkDate 55042,(161.5,161.7,162.79,164.72)) + , (mkDate 55041,(158.25,158.9,160.03,160.45)) + , (mkDate 55040,(157.6,158.88,160.0,160.1)) + , (mkDate 55039,(157.26,160.17,160.1,160.88)) + , (mkDate 55036,(156.5,156.95,159.99,160.0)) + , (mkDate 55035,(155.56,156.63,157.82,158.44)) + , (mkDate 55034,(156.11,157.79,156.74,158.73)) + , (mkDate 55033,(149.75,153.29,151.51,153.43)) + , (mkDate 55032,(150.89,153.27,152.91,155.04)) + , (mkDate 55029,(148.63,149.08,151.75,152.02)) + , (mkDate 55028,(145.57,145.76,147.52,148.02)) + , (mkDate 55027,(144.32,145.04,146.88,147.0)) + , (mkDate 55026,(141.16,142.03,142.27,143.18)) + , (mkDate 55025,(137.53,139.54,142.34,142.34)) + , (mkDate 55022,(136.32,136.34,138.52,138.97)) + , (mkDate 55021,(135.93,137.76,136.36,137.99)) + , (mkDate 55020,(134.42,135.92,137.22,138.04)) + , (mkDate 55019,(135.18,138.48,135.4,139.68)) + , (mkDate 55018,(136.25,138.7,138.61,138.99)) + , (mkDate 55014,(139.79,141.25,140.02,142.83)) + , (mkDate 55013,(142.52,143.5,142.83,144.66)) + ] + +pricesMSFT = + [ (mkDate 55105,(24.8,25.41,24.88,25.47)) + , (mkDate 55104,(25.38,25.76,25.72,25.99)) + , (mkDate 55103,(25.69,25.91,25.75,25.96)) + , (mkDate 55102,(25.6,25.6,25.83,26.16)) + , (mkDate 55099,(25.52,25.69,25.55,25.82)) + , (mkDate 55098,(25.66,25.92,25.94,26.11)) + , (mkDate 55097,(25.64,25.92,25.71,26.25)) + , (mkDate 55096,(25.29,25.4,25.77,25.82)) + , (mkDate 55095,(25.1,25.11,25.3,25.37)) + , (mkDate 55092,(25.1,25.46,25.26,25.48)) + , (mkDate 55091,(25.06,25.06,25.3,25.38)) + , (mkDate 55090,(24.95,25.25,25.2,25.35)) + , (mkDate 55089,(24.86,24.97,25.2,25.27)) + , (mkDate 55088,(24.64,24.65,25.0,25.09)) + , (mkDate 55085,(24.81,24.93,24.86,25.17)) + , (mkDate 55084,(24.65,24.8,25.0,25.05)) + , (mkDate 55083,(24.67,24.74,24.78,24.95)) + , (mkDate 55082,(24.41,24.62,24.82,24.84)) + , (mkDate 55078,(24.08,24.09,24.62,24.8)) + , (mkDate 55077,(23.76,23.91,24.11,24.14)) + , (mkDate 55076,(23.78,23.82,23.86,24.14)) + , (mkDate 55075,(23.9,24.35,24.0,24.74)) + , (mkDate 55074,(24.29,24.57,24.65,24.85)) + , (mkDate 55071,(24.61,25.07,24.68,25.49)) + , (mkDate 55070,(24.3,24.41,24.69,24.78)) + , (mkDate 55069,(24.42,24.59,24.55,24.75)) + , (mkDate 55068,(24.46,24.6,24.64,24.82)) + , (mkDate 55067,(24.28,24.41,24.64,24.73)) + , (mkDate 55064,(23.77,23.93,24.41,24.42)) + , (mkDate 55063,(23.54,23.6,23.67,23.87)) + , (mkDate 55062,(23.25,23.25,23.65,23.72)) + , (mkDate 55061,(23.27,23.29,23.58,23.65)) + , (mkDate 55060,(23.23,23.32,23.25,23.6)) + , (mkDate 55057,(23.51,23.62,23.69,23.8)) + , (mkDate 55056,(23.4,23.63,23.62,23.85)) + , (mkDate 55055,(23.03,23.13,23.53,23.9)) + , (mkDate 55054,(23.05,23.32,23.13,23.4)) + , (mkDate 55053,(23.3,23.46,23.42,23.55)) + , (mkDate 55050,(23.5,23.75,23.56,23.82)) + , (mkDate 55049,(23.27,23.93,23.46,23.98)) + , (mkDate 55048,(23.79,23.84,23.81,24.25)) + , (mkDate 55047,(23.53,23.68,23.77,23.79)) + , (mkDate 55046,(23.5,23.82,23.83,23.86)) + , (mkDate 55043,(23.5,23.77,23.52,24.07)) + , (mkDate 55042,(23.71,24.2,23.81,24.43)) + , (mkDate 55041,(23.34,23.73,23.8,23.91)) + , (mkDate 55040,(22.9,22.99,23.47,23.55)) + , (mkDate 55039,(22.9,23.44,23.11,23.45)) + , (mkDate 55036,(22.81,23.61,23.45,23.89)) + , (mkDate 55035,(24.84,24.93,25.56,25.72)) + , (mkDate 55034,(24.51,24.7,24.8,24.9)) + , (mkDate 55033,(24.37,24.69,24.83,24.83)) + , (mkDate 55032,(24.15,24.44,24.53,24.53)) + , (mkDate 55029,(24.1,24.4,24.29,24.45)) + , (mkDate 55028,(23.86,23.93,24.44,24.44)) + , (mkDate 55027,(23.56,23.75,24.12,24.12)) + , (mkDate 55026,(22.86,23.2,23.11,23.22)) + , (mkDate 55025,(22.14,22.42,23.23,23.29)) + , (mkDate 55022,(22.15,22.19,22.39,22.54)) + , (mkDate 55021,(22.37,22.65,22.44,22.81)) + , (mkDate 55020,(22.0,22.31,22.56,22.69)) + , (mkDate 55019,(22.46,23.08,22.53,23.14)) + , (mkDate 55018,(22.87,23.21,23.2,23.28)) + , (mkDate 55014,(23.21,23.76,23.37,24.04)) + , (mkDate 55013,(23.96,24.05,24.04,24.3)) + ] + +pricesARMH = + [ (mkDate 55105,(6.65,6.83,6.65,6.86)) + , (mkDate 55104,(6.87,7.0,7.0,7.02)) + , (mkDate 55103,(6.88,6.92,6.95,6.97)) + , (mkDate 55102,(6.62,6.63,6.81,6.82)) + , (mkDate 55099,(6.69,6.88,6.72,6.88)) + , (mkDate 55098,(6.55,6.69,6.64,6.88)) + , (mkDate 55097,(6.8,6.87,6.8,6.94)) + , (mkDate 55096,(6.67,6.68,6.74,6.78)) + , (mkDate 55095,(6.62,6.67,6.7,6.77)) + , (mkDate 55092,(6.63,6.71,6.7,6.76)) + , (mkDate 55091,(6.64,6.7,6.67,6.76)) + , (mkDate 55090,(6.76,6.84,6.77,6.85)) + , (mkDate 55089,(6.69,6.73,6.84,6.9)) + , (mkDate 55088,(6.73,6.74,6.8,6.81)) + , (mkDate 55085,(6.84,7.05,6.87,7.07)) + , (mkDate 55084,(6.65,6.7,6.94,6.97)) + , (mkDate 55083,(6.65,6.71,6.7,6.75)) + , (mkDate 55082,(6.56,6.58,6.65,6.68)) + , (mkDate 55078,(6.16,6.18,6.39,6.41)) + , (mkDate 55077,(6.11,6.19,6.21,6.24)) + , (mkDate 55076,(6.03,6.07,6.09,6.14)) + , (mkDate 55075,(6.14,6.22,6.24,6.31)) + , (mkDate 55074,(6.3,6.45,6.35,6.45)) + , (mkDate 55071,(6.4,6.5,6.47,6.56)) + , (mkDate 55070,(6.13,6.18,6.35,6.39)) + , (mkDate 55069,(6.1,6.12,6.16,6.2)) + , (mkDate 55068,(6.14,6.3,6.17,6.3)) + , (mkDate 55067,(6.19,6.29,6.21,6.34)) + , (mkDate 55064,(6.25,6.32,6.3,6.38)) + , (mkDate 55063,(6.18,6.2,6.25,6.27)) + , (mkDate 55062,(6.09,6.11,6.19,6.22)) + , (mkDate 55061,(6.14,6.14,6.23,6.28)) + , (mkDate 55060,(5.91,6.02,5.98,6.04)) + , (mkDate 55057,(6.04,6.15,6.2,6.21)) + , (mkDate 55056,(6.1,6.18,6.22,6.26)) + , (mkDate 55055,(6.07,6.07,6.22,6.3)) + , (mkDate 55054,(6.09,6.23,6.14,6.23)) + , (mkDate 55053,(6.19,6.39,6.23,6.4)) + , (mkDate 55050,(6.25,6.31,6.32,6.41)) + , (mkDate 55049,(6.2,6.42,6.24,6.42)) + , (mkDate 55048,(6.4,6.55,6.46,6.55)) + , (mkDate 55047,(6.5,6.52,6.67,6.7)) + , (mkDate 55046,(6.5,6.51,6.58,6.6)) + , (mkDate 55043,(6.3,6.34,6.39,6.43)) + , (mkDate 55042,(6.42,6.47,6.46,6.64)) + , (mkDate 55041,(6.14,6.37,6.22,6.49)) + , (mkDate 55040,(6.28,6.32,6.52,6.56)) + , (mkDate 55039,(6.41,6.47,6.49,6.63)) + , (mkDate 55036,(6.27,6.36,6.44,6.44)) + , (mkDate 55035,(6.47,6.48,6.52,6.55)) + , (mkDate 55034,(6.38,6.41,6.47,6.51)) + , (mkDate 55033,(6.27,6.45,6.41,6.46)) + , (mkDate 55032,(6.32,6.44,6.45,6.48)) + , (mkDate 55029,(6.23,6.25,6.37,6.45)) + , (mkDate 55028,(6.24,6.29,6.35,6.39)) + , (mkDate 55027,(6.37,6.53,6.45,6.6)) + , (mkDate 55026,(6.12,6.13,6.19,6.23)) + , (mkDate 55025,(5.98,6.02,6.12,6.13)) + , (mkDate 55022,(5.93,5.96,6.08,6.12)) + , (mkDate 55021,(5.74,5.8,5.97,6.0)) + , (mkDate 55020,(5.61,5.74,5.69,5.82)) + , (mkDate 55019,(5.68,5.82,5.69,5.84)) + , (mkDate 55018,(5.77,5.84,5.91,5.93)) + , (mkDate 55014,(5.89,6.03,5.94,6.06)) + , (mkDate 55013,(5.93,5.98,5.95,6.03)) + ] + + diff --git a/tests/Prices.hs b/tests/Prices.hs --- a/tests/Prices.hs +++ b/tests/Prices.hs @@ -297,16 +297,96 @@ (31,03,2007, 28.00, 78.85) ] +rawHourly = [ + (03,05,2005,00, 16.18, 42.02), + (03,05,2005,01, 16.25, 42.31), + (03,05,2005,02, 16.50, 42.95), + (03,05,2005,03, 16.52, 43.50), + (03,05,2005,04, 16.84, 44.91), + (03,05,2005,05, 16.70, 44.55), + (03,05,2005,06, 16.43, 43.63), + (03,05,2005,07, 16.29, 43.18), + (03,05,2005,08, 15.95, 42.40), + (03,05,2005,09, 15.55, 41.65), + (03,05,2005,10, 15.71, 42.17), + (03,05,2005,11, 15.93, 42.37), + (03,05,2005,12, 16.20, 42.85), + (03,05,2005,13, 15.88, 42.30), + (03,05,2005,14, 15.92, 42.53), + (03,05,2005,15, 16.25, 42.81), + (03,05,2005,16, 16.20, 42.67), + (03,05,2005,17, 16.05, 42.35), + (03,05,2005,18, 16.45, 43.12), + (03,05,2005,19, 16.85, 43.24), + (03,05,2005,20, 16.68, 42.57), + (03,05,2005,21, 16.85, 43.22), + (03,05,2005,22, 17.17, 43.85), + (03,05,2005,23, 17.42, 44.15), + (04,05,2005,00, 17.50, 44.07), + (04,05,2005,01, 17.37, 43.76), + (04,05,2005,02, 17.15, 43.21), + (04,05,2005,03, 17.12, 43.42), + (04,05,2005,04, 17.15, 43.27), + (04,05,2005,05, 17.34, 43.30), + (04,05,2005,06, 17.46, 43.90), + (04,05,2005,07, 17.71, 44.43), + (04,05,2005,08, 18.25, 45.45), + (04,05,2005,09, 18.23, 45.16), + (04,05,2005,10, 18.26, 45.54), + (04,05,2005,11, 18.11, 45.06), + (04,05,2005,12, 17.79, 44.65) + ] + prices :: [(LocalTime,Double,Double)] prices = [ (mkDate dd mm yyyy, p1, p2) | (dd,mm,yyyy,p1,p2) <- rawPrices ] -filterPrices t1 t2 = [ v | v@(d,_,_) <- prices, let t = d in t >= t1 && t <= t2] +hourlyPrices :: [(LocalTime,Double,Double)] +hourlyPrices = [ (mkDateTime dd mm yyyy hh 00, p1, p2) + | (dd,mm,yyyy,hh,p1,p2) <- rawHourly ] -prices1 = filterPrices (mkDate 1 1 2005) (mkDate 31 12 2005) -prices2 = filterPrices (mkDate 1 6 2005) (mkDate 1 9 2005) -prices3 = filterPrices (mkDate 1 1 2006) (mkDate 10 1 2006) -prices4 = filterPrices (mkDate 1 8 2005) (mkDate 31 8 2005) +minutePrices :: [(LocalTime,Double,Double)] +minutePrices = [ (mkDateTime dd mm yyyy 05 hh, p1, p2) + | (dd,mm,yyyy,hh,p1,p2) <- take 24 rawHourly ] + ++ [ (mkDateTime dd mm yyyy 05 (hh+24), p1, p2) + | (dd,mm,yyyy,hh,p1,p2) <- take 24 rawHourly ] -mkDate dd mm yyyy = (LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight) +secondPrices :: [(LocalTime,Double,Double)] +secondPrices = [ (mkSeconds ss, p1, p2) + | (ss,(_,_,_,p1,p2)) <- zip [0..] rawPrices ] +filterPrices prices t1 t2 = [ v | v@(d,_,_) <- prices + , let t = d in t >= t1 && t <= t2] + +prices1 = filterPrices prices (mkDate 1 1 2005) (mkDate 31 12 2005) +prices2 = filterPrices prices (mkDate 1 6 2005) (mkDate 1 9 2005) +prices3 = filterPrices prices (mkDate 1 1 2006) (mkDate 10 1 2006) +prices4 = filterPrices prices (mkDate 1 8 2005) (mkDate 31 8 2005) +prices5 = filterPrices prices (mkDate 1 6 2005) (mkDate 15 7 2005) +prices6 = filterPrices prices (mkDate 1 6 2005) (mkDate 2 7 2005) +prices7 = filterPrices prices (mkDate 20 6 2005) (mkDate 12 7 2005) +prices8 = filterPrices prices (mkDate 6 6 2005) (mkDate 9 6 2005) +prices9 = filterPrices prices (mkDate 6 6 2005) (mkDate 8 6 2005) +prices10 = hourlyPrices +prices10a = take 31 hourlyPrices +prices10b = take 15 hourlyPrices +prices11 = filterPrices hourlyPrices (mkDateTime 3 5 2005 02 30) + (mkDateTime 4 5 2005 02 30) +prices12 = filterPrices hourlyPrices (mkDateTime 3 5 2005 02 30) + (mkDateTime 3 5 2005 06 30) +prices13 = minutePrices +prices13a = take 24 minutePrices +prices13b = take 16 minutePrices +prices14 = secondPrices +prices14a = take 90 secondPrices +prices14b = take 35 secondPrices +prices14c = take 30 secondPrices +prices14d = take 7 secondPrices + +mkDate dd mm yyyy = + LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight +mkDateTime dd mm yyyy hh nn = + LocalTime (fromGregorian (fromIntegral yyyy) mm dd) + (dayFractionToTimeOfDay ((hh*60+nn)/1440)) +mkSeconds ss = LocalTime (fromGregorian (fromIntegral 2009) 11 23) + (dayFractionToTimeOfDay (((14*60+32)*60+ss)/(1440*60))) diff --git a/tests/Test1.hs b/tests/Test1.hs --- a/tests/Test1.hs +++ b/tests/Test1.hs @@ -31,10 +31,10 @@ $ plot_points_title ^="am points" $ defaultPlotPoints -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile (chart 0.25) 320 240 "test1_small.png" main1 ["big"] = renderableToPNGFile (chart 0.25) 800 600 "test1_big.png" -main1 _ = renderableToWindow (chart 1.00) 640 480 +main1 _ = renderableToWindow (chart 1.00) 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/Test14.hs b/tests/Test14.hs --- a/tests/Test14.hs +++ b/tests/Test14.hs @@ -40,9 +40,9 @@ $ line_color ^= opaque blue $ defaultPlotLines ^. plot_lines_style -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile (chart 0.25) 320 240 "test14_small.png" main1 ["big"] = renderableToPNGFile (chart 0.25) 800 600 "test14_big.png" -main1 _ = renderableToWindow (chart 1.00) 640 480 +main1 _ = renderableToWindow (chart 1.00) 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/Test14a.hs b/tests/Test14a.hs new file mode 100644 --- /dev/null +++ b/tests/Test14a.hs @@ -0,0 +1,50 @@ +module Test14a where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Graphics.Rendering.Chart.Plot +import Data.Colour +import Data.Colour.Names +import Data.Accessor +import System.Random +import System.Environment(getArgs) +import Prices(prices1) + +-- demonstrate AreaSpots4D + +chart :: Double -> Renderable () +chart lwidth = toRenderable layout + where + layout = layout1_title ^="Price History" + $ layout1_background ^= solidFillStyle (opaque white) + $ layout1_left_axis ^: laxis_override ^= axisTicksHide + $ layout1_plots ^= [ Left (toPlot price1), Left (toPlot spots) ] + $ setLayout1Foreground (opaque black) + $ defaultLayout1 + + price1 = plot_lines_style ^= lineStyle + $ plot_lines_values ^= [[ (d, v) | (d,v,_) <- prices1]] + $ plot_lines_title ^= "price 1" + $ defaultPlotLines + + spots = area_spots_4d_title ^= "random value" + $ area_spots_4d_max_radius ^= 20 + $ area_spots_4d_values ^= values + $ defaultAreaSpots4D + + points = map (\ (d,v,z,t)-> (d,v) ) values + values = [ (d, v, z, t) | ((d,v,_),z,t) <- zip3 prices1 zs ts ] + zs,ts :: [Int] + zs = randoms $ mkStdGen 0 + ts = randomRs (-2,27) $ mkStdGen 1 + + lineStyle = line_width ^= 3 * lwidth + $ line_color ^= opaque blue + $ defaultPlotLines ^. plot_lines_style + +main1 :: [String] -> IO (PickFn ()) +main1 ["small"] = renderableToPNGFile (chart 0.25) 320 240 "test14_small.png" +main1 ["big"] = renderableToPNGFile (chart 0.25) 800 600 "test14_big.png" +main1 _ = renderableToWindow (chart 1.00) 640 480 >> return undefined + +main = getArgs >>= main1 diff --git a/tests/Test15.hs b/tests/Test15.hs --- a/tests/Test15.hs +++ b/tests/Test15.hs @@ -35,10 +35,10 @@ btitle = "" mkstyle c = (solidFillStyle c, Nothing) -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile (chart (LORows 3)) 320 240 "test15_small.png" main1 ["big"] = renderableToPNGFile (chart (LORows 3)) 800 600 "test15_big.png" -main1 _ = renderableToWindow (chart (LORows 3)) 640 480 +main1 _ = renderableToWindow (chart (LORows 3)) 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/Test17.hs b/tests/Test17.hs new file mode 100644 --- /dev/null +++ b/tests/Test17.hs @@ -0,0 +1,82 @@ +module Test17 where + +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Gtk +import Data.Colour +import Data.Colour.Names +import Data.Accessor +import System.Random +import System.Environment(getArgs) +import ExampleStocks + +-- demonstrate Candles + +chart :: Double -> Renderable () +chart lwidth = toRenderable layout + where + layout = layout1_title ^="Stock Prices" + $ layout1_background ^= solidFillStyle (opaque white) + $ layout1_left_axis ^: laxis_override ^= axisTicksHide + $ layout1_plots ^= [ Right (toPlot msftArea) + , Right (toPlot msftLine) + , Right (toPlot msftCandle) + , Left (toPlot aaplArea) + , Left (toPlot aaplLine) + , Left (toPlot aaplCandle) ] + $ setLayout1Foreground (opaque black) + $ defaultLayout1 + + aaplLine = plot_lines_style ^= lineStyle 2 green + $ plot_lines_values ^= [[ (d, cl) + | (d,(lo,op,cl,hi)) <- pricesAAPL]] + $ plot_lines_title ^= "AAPL closing" + $ defaultPlotLines + + msftLine = plot_lines_style ^= lineStyle 2 purple + $ plot_lines_values ^= [[ (d, cl) + | (d,(lo,op,cl,hi)) <- pricesMSFT]] + $ plot_lines_title ^= "MSFT closing" + $ defaultPlotLines + + aaplArea = plot_fillbetween_style ^= solidFillStyle (withOpacity green 0.4) + $ plot_fillbetween_values ^= [ (d, (lo,hi)) + | (d,(lo,op,cl,hi)) <- pricesAAPL] + $ plot_fillbetween_title ^= "AAPL spread" + $ defaultPlotFillBetween + + msftArea = plot_fillbetween_style ^= solidFillStyle (withOpacity purple 0.4) + $ plot_fillbetween_values ^= [ (d, (lo,hi)) + | (d,(lo,op,cl,hi)) <- pricesMSFT] + $ plot_fillbetween_title ^= "MSFT spread" + $ defaultPlotFillBetween + + aaplCandle = plot_candle_line_style ^= lineStyle 1 blue + $ plot_candle_fill ^= True + $ plot_candle_tick_length ^= 0 + $ plot_candle_width ^= 2 + $ plot_candle_values ^= [ Candle d lo op 0 cl hi + | (d,(lo,op,cl,hi)) <- pricesAAPL] + $ plot_candle_title ^= "AAPL candle" + $ defaultPlotCandle + + msftCandle = plot_candle_line_style ^= lineStyle 1 red + $ plot_candle_fill ^= True + $ plot_candle_rise_fill_style ^= solidFillStyle (opaque pink) + $ plot_candle_fall_fill_style ^= solidFillStyle (opaque red) + $ plot_candle_tick_length ^= 0 + $ plot_candle_width ^= 2 + $ plot_candle_values ^= [ Candle d lo op 0 cl hi + | (d,(lo,op,cl,hi)) <- pricesMSFT] + $ plot_candle_title ^= "MSFT candle" + $ defaultPlotCandle + + lineStyle n colour = line_width ^= n * lwidth + $ line_color ^= opaque colour + $ defaultPlotLines ^. plot_lines_style + +main1 :: [String] -> IO (PickFn ()) +main1 ["small"] = renderableToPNGFile (chart 0.25) 320 240 "test17_small.png" +main1 ["big"] = renderableToPNGFile (chart 0.25) 800 600 "test17_big.png" +main1 _ = renderableToWindow (chart 1.00) 640 480 >> return undefined + +main = getArgs >>= main1 diff --git a/tests/Test2.hs b/tests/Test2.hs --- a/tests/Test2.hs +++ b/tests/Test2.hs @@ -56,9 +56,9 @@ $ setLayout1Foreground fg $ defaultLayout1 -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile (chart prices2 True 0.25) 320 240 "test2_small.png" main1 ["big"] = renderableToPNGFile (chart prices2 True 0.25) 800 600 "test2_big.png" -main1 _ = renderableToWindow (chart prices2 True 1.00) 640 480 +main1 _ = renderableToWindow (chart prices2 True 1.00) 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/Test3.hs b/tests/Test3.hs --- a/tests/Test3.hs +++ b/tests/Test3.hs @@ -32,9 +32,9 @@ $ defaultLayout1 -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile chart 320 240 "test3_small.png" main1 ["big"] = renderableToPNGFile chart 800 600 "test3_big.png" -main1 _ = renderableToWindow chart 640 480 +main1 _ = renderableToWindow chart 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/Test4.hs b/tests/Test4.hs --- a/tests/Test4.hs +++ b/tests/Test4.hs @@ -29,10 +29,10 @@ $ layout1_plots ^= [Left (toPlot points), Left (toPlot lines) ] $ defaultLayout1 -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile (chart False False) 320 240 "test4_small.png" main1 ["big"] = renderableToPNGFile (chart False False) 800 600 "test4_big.png" -main1 _ = renderableToWindow (chart False False) 640 480 +main1 _ = renderableToWindow (chart False False) 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/Test5.hs b/tests/Test5.hs --- a/tests/Test5.hs +++ b/tests/Test5.hs @@ -40,10 +40,10 @@ s1 = solidLine lwidth $ opaque green s2 = solidLine lwidth $ opaque blue -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile (chart 0.25) 320 240 "test5_small.png" main1 ["big"] = renderableToPNGFile (chart 0.25) 800 600 "test5_big.png" -main1 _ = renderableToWindow (chart 1.00) 640 480 +main1 _ = renderableToWindow (chart 1.00) 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/Test6.hs b/tests/Test6.hs --- a/tests/Test6.hs +++ b/tests/Test6.hs @@ -16,9 +16,9 @@ [0.1,0.7,0.5::Double] "+" xs = [0,0.3..3] :: [Double] -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile chart 320 240 "test6_small.png" main1 ["big"] = renderableToPNGFile chart 800 600 "test6_big.png" -main1 _ = renderableToWindow chart 640 480 +main1 _ = renderableToWindow chart 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/Test7.hs b/tests/Test7.hs --- a/tests/Test7.hs +++ b/tests/Test7.hs @@ -26,10 +26,10 @@ $ defaultLayout1 -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile chart 320 240 "test7_small.png" main1 ["big"] = renderableToPNGFile chart 800 600 "test7_big.png" -main1 _ = renderableToWindow chart 640 480 +main1 _ = renderableToWindow chart 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/Test8.hs b/tests/Test8.hs --- a/tests/Test8.hs +++ b/tests/Test8.hs @@ -16,10 +16,10 @@ | (s,v,o) <- values ] $ defaultPieLayout -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile chart 320 240 "test8_small.png" main1 ["big"] = renderableToPNGFile chart 800 600 "test8_big.png" -main1 _ = renderableToWindow chart 640 480 +main1 _ = renderableToWindow chart 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/Test9.hs b/tests/Test9.hs --- a/tests/Test9.hs +++ b/tests/Test9.hs @@ -30,10 +30,10 @@ bstyle = if borders then Just (solidLine 1.0 $ opaque black) else Nothing mkstyle c = (solidFillStyle c, bstyle) -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile (chart True) 320 240 "test9_small.png" main1 ["big"] = renderableToPNGFile (chart True) 800 600 "test9_big.png" -main1 _ = renderableToWindow (chart True) 640 480 +main1 _ = renderableToWindow (chart True) 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/TestParametric.hs b/tests/TestParametric.hs --- a/tests/TestParametric.hs +++ b/tests/TestParametric.hs @@ -22,9 +22,9 @@ $ layout1_plots ^= [Left (toPlot circleP)] $ defaultLayout1 -main1 :: [String] -> IO() +main1 :: [String] -> IO (PickFn ()) main1 ["small"] = renderableToPNGFile (chart 1.00) 320 240 "test_parametric_small.png" main1 ["big"] = renderableToPNGFile (chart 1.00) 800 600 "test_parametric_big.png" -main1 _ = renderableToWindow (chart 1.00) 640 480 +main1 _ = renderableToWindow (chart 1.00) 640 480 >> return undefined main = getArgs >>= main1 diff --git a/tests/all_tests.hs b/tests/all_tests.hs --- a/tests/all_tests.hs +++ b/tests/all_tests.hs @@ -27,7 +27,9 @@ import qualified Test8 import qualified Test9 import qualified Test14 +import qualified Test14a import qualified Test15 +import qualified Test17 import qualified TestParametric data OutputType = Window | PNG | PS | PDF | SVG @@ -254,16 +256,18 @@ baxis = AxisData { axis_viewport_ = vmap (0,15), + axis_tropweiv_ = invmap (0,15), axis_ticks_ = [(v,3) | v <- [0,1..15]], axis_grid_ = [0,5..15], - axis_labels_ = [(v,show v) | v <- [0,5..15]] + axis_labels_ = [[(v,show v) | v <- [0,5..15]]] } laxis = AxisData { axis_viewport_ = vmap (0,500), + axis_tropweiv_ = invmap (0,500), axis_ticks_ = [(v,3) | v <- [0,25..500]], axis_grid_ = [0,100..500], - axis_labels_ = [(v,show v) | v <- [0,100..500]] + axis_labels_ = [[(v,show v) | v <- [0,100..500]]] } plot = plot_lines_values ^= [vs1] @@ -293,11 +297,11 @@ annotated h v = toRenderable ( layout1_plots ^= [Left (toPlot labelPlot), Left (toPlot rotPlot), p] $ defaultLayout1 ) where labelPlot = plot_annotation_hanchor ^= h $ plot_annotation_vanchor ^= v - $ plot_annotation_values ^= [(x,x,"Hello World (plain)")|x<-points] + $ plot_annotation_values ^= [(x,x,"Hello World\n(plain)")|x<-points] $ defaultPlotAnnotation rotPlot = plot_annotation_angle ^= -45.0 $ plot_annotation_style ^= defaultFontStyle{font_size_=10,font_weight_=C.FontWeightBold, font_color_ =(opaque blue) } - $ plot_annotation_values ^= [(x,x,"Hello World (fancy)")|x<-points] + $ plot_annotation_values ^= [(x,x,"Hello World\n(fancy)")|x<-points] $ labelPlot @@ -329,11 +333,28 @@ allTests = [ ("test1", \o -> Test1.chart (chooseLineWidth o) ) , ("test1a", \o -> test1a (chooseLineWidth o) ) - , ("test2a", \o -> Test2.chart prices False (chooseLineWidth o)) - , ("test2b", \o -> Test2.chart prices1 False (chooseLineWidth o)) - , ("test2c", \o -> Test2.chart prices2 False (chooseLineWidth o)) - , ("test2d", \o -> Test2.chart prices3 False (chooseLineWidth o)) - , ("test2e", \o -> Test2.chart prices4 True (chooseLineWidth o)) + , ("test2a", \o -> Test2.chart prices False (chooseLineWidth o)) + , ("test2b", \o -> Test2.chart prices1 False (chooseLineWidth o)) + , ("test2c", \o -> Test2.chart prices2 False (chooseLineWidth o)) + , ("test2d", \o -> Test2.chart prices5 True (chooseLineWidth o)) + , ("test2e", \o -> Test2.chart prices6 True (chooseLineWidth o)) + , ("test2f", \o -> Test2.chart prices7 True (chooseLineWidth o)) + , ("test2g", \o -> Test2.chart prices3 False (chooseLineWidth o)) + , ("test2h", \o -> Test2.chart prices8 True (chooseLineWidth o)) + , ("test2i", \o -> Test2.chart prices9 True (chooseLineWidth o)) + , ("test2j", \o -> Test2.chart prices10 True (chooseLineWidth o)) + , ("test2k", \o -> Test2.chart prices10a True (chooseLineWidth o)) + , ("test2m", \o -> Test2.chart prices11 True (chooseLineWidth o)) + , ("test2n", \o -> Test2.chart prices10b True (chooseLineWidth o)) + , ("test2o", \o -> Test2.chart prices12 True (chooseLineWidth o)) + , ("test2p", \o -> Test2.chart prices13 True (chooseLineWidth o)) + , ("test2q", \o -> Test2.chart prices13a True (chooseLineWidth o)) + , ("test2r", \o -> Test2.chart prices13b True (chooseLineWidth o)) + , ("test2s", \o -> Test2.chart prices14 True (chooseLineWidth o)) + , ("test2t", \o -> Test2.chart prices14a True (chooseLineWidth o)) + , ("test2u", \o -> Test2.chart prices14b True (chooseLineWidth o)) + , ("test2v", \o -> Test2.chart prices14c True (chooseLineWidth o)) + , ("test2w", \o -> Test2.chart prices14d True (chooseLineWidth o)) , ("test3", const Test3.chart) , ("test4a", const (Test4.chart False False)) , ("test4b", const (Test4.chart True False)) @@ -353,10 +374,12 @@ , ("test12", test12) , ("test13", test13) , ("test14", \o -> Test14.chart (chooseLineWidth o) ) + , ("test14a", \o -> Test14a.chart (chooseLineWidth o) ) , ("test15a", const (Test15.chart (LORows 2))) , ("test15b", const (Test15.chart (LOCols 2))) - , ("misc1", misc1 0) - , ("misc1a", misc1 45) + , ("test17", \o -> Test17.chart (chooseLineWidth o)) + , ("misc1", setPickFn nullPickFn . misc1 0) + , ("misc1a", setPickFn nullPickFn . misc1 45) , ("parametric", \o -> TestParametric.chart (chooseLineWidth o) ) ] @@ -372,7 +395,12 @@ main1 tests = showTests tests renderToWindow showTests :: [String] -> ((String,OutputType -> Renderable ()) -> IO()) -> IO () -showTests tests ofn = mapM_ ofn (filter (match tests) allTests) +showTests tests ofn = mapM_ doTest (filter (match tests) allTests) + where + doTest (s,f) = do + putStrLn (s ++ "... ") + ofn (s,f) + match :: [String] -> (String,a) -> Bool match [] t = True @@ -380,6 +408,7 @@ renderToWindow (n,ir) = renderableToWindow (ir Window) 640 480 renderToPNG (n,ir) = renderableToPNGFile (ir PNG) 640 480 (n ++ ".png") + >> return () 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")