diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,11 +1,11 @@ Name: Chart -Version: 0.16 +Version: 0.17 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006-2010 Author: Tim Docker Maintainer: Tim Docker -Homepage: http://www.dockerz.net/software/chart.html +Homepage: https://github.com/timbod7/haskell-chart/wiki Synopsis: A library for generating 2D Charts and Plots Description: A library for generating 2D Charts and Plots, based upon the cairo graphics library. Category: Graphics @@ -71,3 +71,7 @@ Graphics.Rendering.Chart.Plot.Pie, Graphics.Rendering.Chart.Plot.Points Graphics.Rendering.Chart.SparkLine + +source-repository head + type: git + location: https://github.com/timbod7/haskell-chart 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 @@ -18,10 +18,10 @@ width, height, gridToRenderable, weights, - fullRowAbove, - fullRowBelow, - fullColLeft, - fullColRight, + aboveWide, + wideAbove, + tallBeside, + besideTall, fullOverlayUnder, fullOverlayOver ) where @@ -101,25 +101,24 @@ above t1 t2 = Above t1 t2 size where size = (max (width t1) (width t2), height t1 + height t2) --- | A value placed above the grid, occupying 1 row with the same --- horizontal span as the grid. -fullRowAbove :: a -> Double -> Grid a -> Grid a -fullRowAbove a w g = (weights (0,w) $ tspan a (width g,1)) `above` g +-- | A value occupying 1 row with the same horizontal span as the grid. +wideAbove :: a -> Grid a -> Grid a +wideAbove a g = (weights (0,0) $ tspan a (width g,1)) `above` g -- | A value placed below the grid, occupying 1 row with the same -- horizontal span as the grid. -fullRowBelow :: a -> Double -> Grid a -> Grid a -fullRowBelow a w g = g `above` (weights (0,w) $ tspan a (width g,1)) +aboveWide :: Grid a -> a -> Grid a +aboveWide g a = g `above` (weights (0,0) $ tspan a (width g,1)) -- | A value placed to the left of the grid, occupying 1 column with -- the same vertical span as the grid. -fullColLeft :: a -> Double -> Grid a -> Grid a -fullColLeft a w g = (weights (w,0) $ tspan a (1,height g)) `beside` g +tallBeside :: a -> Grid a -> Grid a +tallBeside a g = (weights (0,0) $ tspan a (1,height g)) `beside` g -- | A value placed to the right of the grid, occupying 1 column with -- the same vertical span as the grid. -fullColRight :: a -> Double -> Grid a -> Grid a -fullColRight a w g = g `beside` (weights (w,0) $ tspan a (1,height g)) +besideTall :: Grid a -> a -> Grid a +besideTall g a = g `beside` (weights (0,0) $ tspan a (1,height g)) -- | A value placed under a grid, with the same span as the grid. fullOverlayUnder :: a -> Grid a -> Grid a 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 @@ -11,6 +11,8 @@ -- (see 'Data.Accessor') for each field of the following data types: -- -- * 'Layout1' +-- +-- * 'StackedLayouts' -- -- * 'LayoutAxis' -- @@ -23,12 +25,14 @@ -- @ -- -{-# OPTIONS_GHC -XTemplateHaskell #-} +{-# OPTIONS_GHC -XTemplateHaskell -XExistentialQuantification #-} module Graphics.Rendering.Chart.Layout( Layout1(..), LayoutAxis(..), Layout1Pick(..), + StackedLayouts(..), + StackedLayout(..), MAxisFn, defaultLayout1, @@ -62,9 +66,12 @@ layout1_legend, layout1_grid_last, - renderLayout1sStacked, - AnyLayout1(), - withAnyOrdinate + defaultStackedLayouts, + slayouts_layouts, + slayouts_compress_xlabels, + slayouts_compress_legend, + + renderStackedLayouts, ) where import qualified Graphics.Rendering.Cairo as C @@ -154,43 +161,76 @@ instance (Ord x, Ord y) => ToRenderable (Layout1 x y) where toRenderable = setPickFn nullPickFn.layout1ToRenderable --- | Encapsulates a 'Layout1' with a fixed abscissa type but --- arbitrary ordinate type. -data AnyLayout1 x = AnyLayout1 { - background :: CairoFillStyle, - titleRenderable :: Renderable (), - plotAreaGrid :: Grid (Renderable ()), - legendRenderable :: Renderable (), - margin :: Double - } +type LegendItem = (String,Rect -> CRender ()) -withAnyOrdinate :: (Ord x,Ord y) => Layout1 x y -> AnyLayout1 x -withAnyOrdinate l = AnyLayout1 { - background = layout1_background_ l, - titleRenderable = mapPickFn (const ()) $ layout1TitleToRenderable l, - plotAreaGrid = fmap (mapPickFn (const ())) $ layout1PlotAreaToGrid l, - legendRenderable = mapPickFn (const ()) $ layout1LegendsToRenderable l, - margin = layout1_margin_ l - } +-- | A layout with it's y type hidded, so that it can be stacked +-- with other layouts (with differing y types) +data StackedLayout x = forall y . Ord y => StackedLayout (Layout1 x y) +-- | A holder for a set of vertically stacked layouts +data StackedLayouts x = StackedLayouts { + slayouts_layouts_ :: [StackedLayout x], + slayouts_compress_xlabels_ :: Bool, + slayouts_compress_legend_ :: Bool +} --- | Render several layouts with the same abscissa type stacked so that their --- origins and axis titles are aligned horizontally with respect to each --- other. The exterior margins and background are taken from the first --- element. -renderLayout1sStacked :: (Ord x) => [AnyLayout1 x] -> Renderable () -renderLayout1sStacked [] = emptyRenderable -renderLayout1sStacked ls@(l1:_) = gridToRenderable g +defaultStackedLayouts :: StackedLayouts x +defaultStackedLayouts = StackedLayouts [] True True + +-- | Render several layouts with the same x-axis type and range, +-- vertically stacked so that their origins and x-values are aligned. +-- +-- The legends from all the charts may be optionally combined, and shown +-- once on the bottom chart. The x labels may be optionally removed so that +-- they are only shown once. +renderStackedLayouts :: (Ord x) => StackedLayouts x -> Renderable () +renderStackedLayouts (StackedLayouts{slayouts_layouts_=[]}) = emptyRenderable +renderStackedLayouts slp@(StackedLayouts{slayouts_layouts_=sls@(sl1:_)}) = gridToRenderable g where - g = fullOverlayUnder (fillBackground (background l1) emptyRenderable) - $ addMarginsToGrid (lm,lm,lm,lm) - $ aboveN [ fullRowAbove (titleRenderable l) 0 ( - fullRowBelow (legendRenderable l) 0 - (plotAreaGrid l)) - | l <- ls ] + g = fullOverlayUnder (fillBackground bg emptyRenderable) + $ foldr (above.mkGrid) nullt (zip sls [0,1..]) + + mkGrid ((StackedLayout l),i) + = (noPickFn $ layout1TitleToRenderable l) + `wideAbove` + (addMarginsToGrid (lm,lm,lm,lm) $ mkPlotArea baxis taxis) + `aboveWide` + (if showLegend then noPickFn $ renderLegend l legenditems else emptyRenderable) - lm = margin l1 + where + legenditems = case (slayouts_compress_legend_ slp,isBottomPlot) of + (False,_) -> getLegendItems l + (True,True) -> alllegendItems + (True,False) -> ([],[]) + mkPlotArea bx tx = fmap (mapPickFn (const ())) + $ layout1PlotAreaToGrid l{layout1_bottom_axis_=bx,layout1_top_axis_=tx} + + showLegend = not (null (fst legenditems)) || not (null (snd legenditems)) + + isTopPlot = i == 0 + isBottomPlot = i == length sls -1 + + lm = layout1_margin_ l + + baxis = mkAxis (layout1_bottom_axis_ l) (isBottomPlot || not (slayouts_compress_xlabels_ slp)) + taxis = mkAxis (layout1_top_axis_ l) (isTopPlot || not (slayouts_compress_xlabels_ slp)) + + mkAxis a showLabels = a{ + laxis_generate_=const (laxis_generate_ a all_xvals), + laxis_override_= if showLabels then id else \ad -> ad{axis_labels_=[]} + } + + bg = (\(StackedLayout l) -> layout1_background_ l) sl1 + + all_xvals = concatMap (\(StackedLayout l) -> getLayout1XVals l) sls + + alllegendItems = (concatMap (fst.legendItems) sls, concatMap (snd.legendItems) sls) + legendItems (StackedLayout l) = (getLegendItems l) + + noPickFn :: Renderable a -> Renderable () + noPickFn = mapPickFn (const ()) + addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a) -> Grid (Renderable a) addMarginsToGrid (t,b,l,r) g = aboveN [ @@ -231,15 +271,25 @@ (layout1_title_ l) lm = layout1_margin_ l -layout1LegendsToRenderable :: (Ord x, Ord y) => - Layout1 x y -> Renderable (Layout1Pick x y) -layout1LegendsToRenderable l = gridToRenderable g +getLayout1XVals :: Layout1 x y -> [x] +getLayout1XVals l = concatMap (fst.plot_all_points_.deEither) (layout1_plots_ l) where + deEither (Left x) = x + deEither (Right x) = x + + +getLegendItems :: Layout1 x y -> ([LegendItem],[LegendItem]) +getLegendItems l = ( + concat [ plot_legend_ p | (Left p ) <- (layout1_plots_ l) ], + concat [ plot_legend_ p | (Right p) <- (layout1_plots_ l) ] + ) + +renderLegend :: Layout1 x y -> ([LegendItem],[LegendItem]) -> Renderable (Layout1Pick x y) +renderLegend l (lefts,rights) = gridToRenderable g + where g = besideN [ tval $ mkLegend lefts , weights (1,1) $ tval $ emptyRenderable , tval $ mkLegend rights ] - lefts = concat [ plot_legend_ p | (Left p ) <- (layout1_plots_ l) ] - rights = concat [ plot_legend_ p | (Right p) <- (layout1_plots_ l) ] lm = layout1_margin_ l @@ -248,38 +298,41 @@ Just ls -> case filter ((/="").fst) vals of [] -> emptyRenderable ; lvs -> addMargins (0,lm,lm,lm) $ - mapPickFn L1P_Legend $ - legendToRenderable (Legend ls lvs) + mapPickFn L1P_Legend $ legendToRenderable (Legend ls lvs) +layout1LegendsToRenderable :: (Ord x, Ord y) => + Layout1 x y -> Renderable (Layout1Pick x y) +layout1LegendsToRenderable l = renderLegend l (getLegendItems l) + layout1PlotAreaToGrid :: (Ord x, Ord y) => Layout1 x y -> Grid (Renderable (Layout1Pick x y)) layout1PlotAreaToGrid l = layer2 `overlay` layer1 where layer1 = aboveN - [ besideN [er, er, er ] - , besideN [er, er, er ] - , besideN [er, er, weights (1,1) plots ] + [ besideN [er, er, er, er ] + , besideN [er, er, er, er ] + , besideN [er, er, er, weights (1,1) plots ] ] layer2 = aboveN - [ besideN [er, er, ttitle, er, er ] - , besideN [er, tl, taxis, tr, er ] - , besideN [ltitle, laxis, er, raxis, rtitle ] - , besideN [er, bl, baxis, br, er ] - , besideN [er, er, btitle, er, er ] + [ besideN [er, er, er, ttitle, er, er, er ] + , besideN [er, er, tl, taxis, tr, er, er ] + , besideN [ltitle, lam, laxis, er, raxis, ram, rtitle ] + , besideN [er, er, bl, baxis, br, er, er ] + , besideN [er, er, er, btitle, er, er, er ] ] - ttitle = atitle HTA_Centre VTA_Bottom 0 layout1_top_axis_ L1P_TopAxisTitle - btitle = atitle HTA_Centre VTA_Top 0 layout1_bottom_axis_ L1P_BottomAxisTitle - ltitle = atitle HTA_Right VTA_Centre 270 layout1_left_axis_ L1P_LeftAxisTitle - rtitle = atitle HTA_Left VTA_Centre 270 layout1_right_axis_ L1P_RightAxisTitle + (ttitle,_) = atitle HTA_Centre VTA_Bottom 0 layout1_top_axis_ L1P_TopAxisTitle + (btitle,_) = atitle HTA_Centre VTA_Top 0 layout1_bottom_axis_ L1P_BottomAxisTitle + (ltitle,lam) = atitle HTA_Right VTA_Centre 270 layout1_left_axis_ L1P_LeftAxisTitle + (rtitle,ram) = atitle HTA_Left VTA_Centre 270 layout1_right_axis_ L1P_RightAxisTitle er = tval $ emptyRenderable - atitle ha va rot af pf = if ttext == "" then er - else tval $ mapPickFn pf - $ rlabel tstyle ha va rot ttext + atitle ha va rot af pf = if ttext == "" then (er,er) else (label,gap) where + label = tval $ mapPickFn pf $ rlabel tstyle ha va rot ttext + gap = tval $ spacer (layout1_margin_ l,0) tstyle = laxis_title_style_ (af l) ttext = laxis_title_ (af l) @@ -438,6 +491,7 @@ -- for each field. $( deriveAccessors ''Layout1 ) $( deriveAccessors ''LayoutAxis ) +$( deriveAccessors ''StackedLayouts ) -- | Helper to update all axis styles on a Layout1 simultaneously. updateAllAxesStyles :: (AxisStyle -> AxisStyle) -> Layout1 x y -> Layout1 x y diff --git a/tests/all_tests.hs b/tests/all_tests.hs --- a/tests/all_tests.hs +++ b/tests/all_tests.hs @@ -216,8 +216,7 @@ ------------------------------------------------------------------------------- -- A quick test of stacked layouts -test11 :: OutputType -> Renderable () -test11 otype = renderLayout1sStacked [withAnyOrdinate layout1, withAnyOrdinate layout2] +test11_ f = f layout1 layout2 where vs1 :: [(Int,Int)] vs1 = [ (2,2), (3,40), (8,400), (12,60) ] @@ -225,24 +224,42 @@ vs2 :: [(Int,Double)] vs2 = [ (0,0.7), (3,0.35), (4,0.25), (7, 0.6), (10,0.4) ] - allx = map fst vs1 ++ map fst vs2 - extendRange = PlotHidden allx [] - plot1 = plot_points_style ^= filledCircles 5 (opaque red) $ plot_points_values ^= vs1 + $ plot_points_title ^= "spots" $ defaultPlotPoints - layout1 = layout1_title ^= "Integer Axis" - $ layout1_plots ^= [Left (toPlot plot1), Left (toPlot extendRange)] + layout1 = layout1_title ^= "Multi typed stack" + $ layout1_plots ^= [Left (toPlot plot1)] + $ layout1_left_axis ^: laxis_title ^= "integer values" $ defaultLayout1 plot2 = plot_lines_values ^= [vs2] + $ plot_lines_title ^= "lines" $ defaultPlotLines - layout2 = layout1_title ^= "Float Axis" - $ layout1_plots ^= [Left (toPlot plot2), Left (toPlot extendRange)] + layout2 = layout1_plots ^= [Left (toPlot plot2)] + $ layout1_left_axis ^: laxis_title ^= "double values" $ defaultLayout1 +test11a :: OutputType -> Renderable () +test11a otype = test11_ f + where + f l1 l2 = renderStackedLayouts + $ slayouts_layouts ^= [StackedLayout l1, StackedLayout l2] + $ slayouts_compress_xlabels ^= False + $ slayouts_compress_legend ^= False + $ defaultStackedLayouts + +test11b :: OutputType -> Renderable () +test11b otype = test11_ f + where + f l1 l2 = renderStackedLayouts + $ slayouts_layouts ^= [StackedLayout l1, StackedLayout l2] + $ slayouts_compress_xlabels ^= True + $ slayouts_compress_legend ^= True + $ defaultStackedLayouts + ------------------------------------------------------------------------------- -- More of an example that a test: -- configuring axes explicitly configured axes @@ -371,7 +388,8 @@ , ("test9l", stdSize, test9 BarsLeft) , ("test9r", stdSize, test9 BarsRight) , ("test10", stdSize, test10 prices1) - , ("test11", stdSize, test11) + , ("test11a", stdSize, test11a) + , ("test11b", stdSize, test11b) , ("test12", stdSize, test12) , ("test13", stdSize, test13) , ("test14", stdSize, \o -> Test14.chart (chooseLineWidth o) )