diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,5 +1,5 @@ Name: Chart -Version: 1.0 +Version: 1.1 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006-2010 @@ -16,10 +16,10 @@ Build-depends: base >= 3 && < 5 , old-locale , time, mtl, array - , lens >= 3.9 - , colour >= 2.2.1 + , lens >= 3.9 && < 3.11 + , colour >= 2.2.1 && < 2.4 , data-default-class < 0.1 - , operational >= 0.2.2 + , operational >= 0.2.2 && < 0.3 Exposed-modules: Graphics.Rendering.Chart, diff --git a/Graphics/Rendering/Chart/Axis/Indexed.hs b/Graphics/Rendering/Chart/Axis/Indexed.hs --- a/Graphics/Rendering/Chart/Axis/Indexed.hs +++ b/Graphics/Rendering/Chart/Axis/Indexed.hs @@ -13,6 +13,8 @@ autoIndexAxis, addIndexes, ) where + +import Data.Default.Class import Graphics.Rendering.Chart.Axis.Types @@ -34,6 +36,7 @@ -- list of strings are the labels to be used. autoIndexAxis :: Integral i => [String] -> [i] -> AxisData i autoIndexAxis labels vs = AxisData { + _axis_visibility = def { _axis_show_ticks = False }, _axis_viewport = vport, _axis_tropweiv = invport, _axis_ticks = [], diff --git a/Graphics/Rendering/Chart/Axis/LocalTime.hs b/Graphics/Rendering/Chart/Axis/LocalTime.hs --- a/Graphics/Rendering/Chart/Axis/LocalTime.hs +++ b/Graphics/Rendering/Chart/Axis/LocalTime.hs @@ -11,7 +11,8 @@ autoTimeAxis, days, months, years ) where - + +import Data.Default.Class import Data.Time import Data.Fixed import System.Locale (defaultTimeLocale) @@ -87,6 +88,7 @@ TimeSeq -> TimeLabelFn -> TimeLabelAlignment -> AxisFn LocalTime timeAxis tseq lseq labelf lal cseq contextf clal pts = AxisData { + _axis_visibility = def, _axis_viewport = vmap(min', max'), _axis_tropweiv = invmap(min', max'), _axis_ticks = [ (t,2) | t <- times] ++ [ (t,5) | t <- ltimes, visible t], diff --git a/Graphics/Rendering/Chart/Axis/Types.hs b/Graphics/Rendering/Chart/Axis/Types.hs --- a/Graphics/Rendering/Chart/Axis/Types.hs +++ b/Graphics/Rendering/Chart/Axis/Types.hs @@ -11,6 +11,7 @@ module Graphics.Rendering.Chart.Axis.Types( AxisData(..), + AxisVisibility(..), AxisT(..), AxisStyle(..), PlotValue(..), @@ -36,10 +37,13 @@ axisGridAtBigTicks, axisGridAtLabels, axisGridHide, - axisTicksHide, - axisLabelsHide, axisLabelsOverride, + + axis_show_line, + axis_show_ticks, + axis_show_labels, + axis_visibility, axis_viewport, axis_tropweiv, axis_ticks, @@ -75,9 +79,25 @@ fromValue:: Double -> a autoAxis :: AxisFn a +-- | Configures whick visual elements of a axis are shown at the +-- appropriate edge of a plot area. +data AxisVisibility = AxisVisibility + { -- | Whether to display a line along the axis. + _axis_show_line :: Bool + + -- | Whether to display the tick marks. + , _axis_show_ticks :: Bool + + -- | Whether to display the labels. + , _axis_show_labels :: Bool + } + -- | The basic data associated with an axis showing values of type x. data AxisData x = AxisData { - + + -- | Which parts of the axis shall be displayed. + _axis_visibility :: AxisVisibility, + -- | The _axis_viewport function maps values into device coordinates. _axis_viewport :: Range -> x -> Double, @@ -106,8 +126,11 @@ -- | Control values for how an axis gets displayed. data AxisStyle = AxisStyle { + -- | 'LineStyle' to use for axis line and ticks. _axis_line_style :: LineStyle, + -- | 'FontStyle' to use for axis labels. _axis_label_style :: FontStyle, + -- | 'LineStyle' to use for axis grid. _axis_grid_style :: LineStyle, -- | How far the labels are to be drawn from the axis. @@ -155,25 +178,21 @@ [] -> [] 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 = []} - -- | Modifier to change labels on an axis axisLabelsOverride :: [(x,String)] -> AxisData x -> AxisData x axisLabelsOverride o ad = ad{ _axis_labels = [o] } minsizeAxis :: AxisT x -> ChartBackend RectSize minsizeAxis (AxisT at as rev ad) = do + let labelVis = _axis_show_labels $ _axis_visibility $ ad + tickVis = _axis_show_ticks $ _axis_visibility $ ad + labels = if labelVis then labelTexts ad else [] + ticks = if tickVis then _axis_ticks ad else [] labelSizes <- withFontStyle (_axis_label_style as) $ do - mapM (mapM textDimension) (labelTexts ad) + mapM (mapM textDimension) labels let ag = _axis_label_gap as - let tsize = maximum ([0] ++ [ max 0 (-l) | (v,l) <- _axis_ticks ad ]) + let tsize = maximum ([0] ++ [ max 0 (-l) | (v,l) <- ticks ]) let hw = maximum0 (map (maximum0.map fst) labelSizes) let hh = ag + tsize + (sum . intersperse ag . map (maximum0.map snd) $ labelSizes) @@ -216,16 +235,20 @@ renderAxis :: AxisT x -> RectSize -> ChartBackend (PickFn x) renderAxis at@(AxisT et as rev ad) sz = do let ls = _axis_line_style as - withLineStyle (ls {_line_cap = LineCapSquare}) $ do - p <- alignStrokePoints [Point sx sy,Point ex ey] - strokePointPath p - withLineStyle (ls {_line_cap = LineCapButt}) $ do - mapM_ drawTick (_axis_ticks ad) - withFontStyle (_axis_label_style as) $ do - labelSizes <- mapM (mapM textDimension) (labelTexts ad) - let sizes = map ((+ag).maximum0.map coord) labelSizes - let offsets = scanl (+) ag sizes - mapM_ drawLabels (zip offsets (_axis_labels ad)) + vis = _axis_visibility ad + when (_axis_show_line vis) $ do + withLineStyle (ls {_line_cap = LineCapSquare}) $ do + p <- alignStrokePoints [Point sx sy,Point ex ey] + strokePointPath p + when (_axis_show_ticks vis) $ do + withLineStyle (ls {_line_cap = LineCapButt}) $ do + mapM_ drawTick (_axis_ticks ad) + when (_axis_show_labels vis) $ do + withFontStyle (_axis_label_style as) $ do + labelSizes <- mapM (mapM textDimension) (labelTexts ad) + let sizes = map ((+ag).maximum0.map coord) labelSizes + let offsets = scanl (+) ag sizes + mapM_ drawLabels (zip offsets (_axis_labels ad)) return pickfn where (sx,sy,ex,ey,tp,axisPoint,invAxisPoint) = axisMapping at sz @@ -336,6 +359,7 @@ -- labels, and the labelling function makeAxis :: PlotValue x => (x -> String) -> ([x],[x],[x]) -> AxisData x makeAxis labelf (labelvs, tickvs, gridvs) = AxisData { + _axis_visibility = def, _axis_viewport = newViewport, _axis_tropweiv = newTropweiv, _axis_ticks = newTicks, @@ -355,6 +379,7 @@ makeAxis' :: Ord x => (x -> Double) -> (Double -> x) -> (x -> String) -> ([x],[x],[x]) -> AxisData x makeAxis' t f labelf (labelvs, tickvs, gridvs) = AxisData { + _axis_visibility = def, _axis_viewport = linMap t (minimum labelvs, maximum labelvs), _axis_tropweiv = invLinMap f t (minimum labelvs, maximum labelvs), _axis_ticks = zip tickvs (repeat 2) ++ zip labelvs (repeat 5), @@ -365,9 +390,11 @@ ---------------------------------------------------------------------- +-- | The default 'LineStyle' of an axis. defaultAxisLineStyle :: LineStyle defaultAxisLineStyle = solidLine 1 $ opaque black +-- | The default 'LineStyle' of a plot area grid. defaultGridLineStyle :: LineStyle defaultGridLineStyle = dashedLine 1 [5,5] $ opaque lightgrey @@ -383,6 +410,14 @@ , _axis_label_gap = 10 } +-- | By default all parts of a axis are visible. +instance Default AxisVisibility where + def = AxisVisibility + { _axis_show_line = True + , _axis_show_ticks = True + , _axis_show_labels = True + } + ---------------------------------------------------------------------- -- | A linear mapping of points in one range to another. @@ -409,6 +444,7 @@ where doubleRange = t v4 - t v3 +$( makeLenses ''AxisVisibility ) $( makeLenses ''AxisData ) $( makeLenses ''AxisStyle ) diff --git a/Graphics/Rendering/Chart/Axis/Unit.hs b/Graphics/Rendering/Chart/Axis/Unit.hs --- a/Graphics/Rendering/Chart/Axis/Unit.hs +++ b/Graphics/Rendering/Chart/Axis/Unit.hs @@ -10,6 +10,8 @@ unitAxis, ) where +import Data.Default.Class + import Graphics.Rendering.Chart.Axis.Types instance PlotValue () where @@ -19,6 +21,10 @@ unitAxis :: AxisData () unitAxis = AxisData { + _axis_visibility = def + { _axis_show_ticks = False + , _axis_show_labels = False + }, _axis_viewport = \(x0,x1) _ -> (x0+x1)/2, _axis_tropweiv = \_ _ -> (), _axis_ticks = [((), 0)], diff --git a/Graphics/Rendering/Chart/Drawing.hs b/Graphics/Rendering/Chart/Drawing.hs --- a/Graphics/Rendering/Chart/Drawing.hs +++ b/Graphics/Rendering/Chart/Drawing.hs @@ -9,9 +9,7 @@ -- Note that Template Haskell is used to derive accessor functions -- (see 'Control.Lens') for each field of the following data types: -- --- * 'LineStyle' --- --- * 'FontStyle' +-- * 'PointStyle' -- -- These accessors are not shown in this API documentation. They have -- the same name as the field, but with the trailing underscore @@ -22,6 +20,8 @@ -- @ -- +{-# LANGUAGE TemplateHaskell #-} + module Graphics.Rendering.Chart.Drawing ( -- * Point Types and Drawing PointShape(..) @@ -75,6 +75,13 @@ -- * Backend and general Types , module Graphics.Rendering.Chart.Backend + + -- * Accessors + , point_color + , point_border_color + , point_border_width + , point_radius + , point_shape ) where import Data.Default.Class @@ -304,10 +311,7 @@ | PointShapeStar -- ^ Combination of a cross and a plus. -- | Abstract data type for the style of a plotted point. --- --- The contained Cairo action draws a point in the desired --- style, at the supplied device coordinates. -data PointStyle = PointStyle +data PointStyle = PointStyle { _point_color :: AlphaColour Double -- ^ The color to fill the point with. , _point_border_color :: AlphaColour Double @@ -463,3 +467,4 @@ solidFillStyle :: AlphaColour Double -> FillStyle solidFillStyle cl = FillStyleSolid cl +$( makeLenses ''PointStyle ) 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 @@ -10,15 +10,17 @@ -- Note that Template haskell is used to derive accessor functions -- (see 'Control.Lens') for each field of the following data types: -- --- * 'Layout1' +-- * 'Layout' +-- +-- * 'LayoutLR' -- -- * 'StackedLayouts' -- -- * 'LayoutAxis' -- -- These accessors are not shown in this API documentation. They have --- the same name as the field, but with the trailing underscore --- dropped. Hence for data field f_::F in type D, they have type +-- the same name as the field, but with the leading underscore +-- dropped. Hence for data field _f::F in type D, they have type -- -- @ -- f :: Control.Lens.Lens' D F @@ -28,51 +30,67 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ExistentialQuantification #-} -module Graphics.Rendering.Chart.Layout( - Layout1(..), - LayoutAxis(..), - Layout1Pick(..), - StackedLayouts(..), - StackedLayout(..), - MAxisFn, - - defaultLayout1, - layout1ToRenderable, - linkAxes, - independentAxes, - - updateAllAxesStyles, - setLayout1Foreground, +module Graphics.Rendering.Chart.Layout + ( Layout(..) + , LayoutLR(..) + , LayoutAxis(..) + , LayoutPick(..) + , StackedLayouts(..) + , StackedLayout(..) + , MAxisFn + + , layoutToRenderable + , layoutLRToRenderable - defaultLayoutAxis, - laxis_title_style, - laxis_title, - laxis_style, - laxis_visible, - laxis_generate, - laxis_override, - laxis_reverse, + , setLayoutForeground + , updateAllAxesStyles + , setLayoutLRForeground + , updateAllAxesStylesLR - layout1_background, - layout1_plot_background, - layout1_title, - layout1_title_style, - layout1_left_axis, - layout1_right_axis, - layout1_top_axis, - layout1_bottom_axis, - layout1_yaxes_control, - layout1_margin, - layout1_plots, - layout1_legend, - layout1_grid_last, + , defaultLayoutAxis + , laxis_title_style + , laxis_title + , laxis_style + , laxis_generate + , laxis_override + , laxis_reverse + + , layout_background + , layout_plot_background + , layout_title + , layout_title_style + , layout_x_axis + , layout_top_axis_visibility + , layout_bottom_axis_visibility + , layout_y_axis + , layout_left_axis_visibility + , layout_right_axis_visibility + , layout_margin + , layout_plots + , layout_legend + , layout_grid_last + + , layoutlr_background + , layoutlr_plot_background + , layoutlr_title + , layoutlr_title_style + , layoutlr_x_axis + , layoutlr_top_axis_visibility + , layoutlr_bottom_axis_visibility + , layoutlr_left_axis + , layoutlr_right_axis + , layoutlr_left_axis_visibility + , layoutlr_right_axis_visibility + , layoutlr_plots + , layoutlr_legend + , layoutlr_margin + , layoutlr_grid_last - defaultStackedLayouts, - slayouts_layouts, - slayouts_compress_xlabels, - slayouts_compress_legend, + , defaultStackedLayouts + , slayouts_layouts + , slayouts_compress_legend - renderStackedLayouts, + , renderStackedLayouts ) where import Graphics.Rendering.Chart.Axis @@ -94,148 +112,468 @@ -- given the points plotted against that axis. type MAxisFn t = [t] -> Maybe (AxisData t) -data LayoutAxis x = LayoutAxis { - _laxis_title_style :: FontStyle, - _laxis_title :: String, - _laxis_style :: AxisStyle, +-- | Type of axis that is used in 'Layout' and 'LayoutLR'. +-- +-- To generate the actual axis type ('AxisData' and 'AxisT') +-- the '_laxis_generate' function is called and custom settings +-- are applied with '_laxis_override'. Note that the 'AxisVisibility' +-- values in 'Layout' and 'LayoutLR' override visibility related +-- settings of the axis. +data LayoutAxis x = LayoutAxis + { _laxis_title_style :: FontStyle + -- ^ Font style to use for the axis title. + , _laxis_title :: String + -- ^ Title displayed for the axis. + , _laxis_style :: AxisStyle + -- ^ Axis style applied. - -- | Function that determines whether an axis should be visible, - -- based upon the points plotted on this axis. The default value - -- is 'not.null'. - _laxis_visible :: [x] -> Bool, + , _laxis_generate :: AxisFn x + -- ^ Function that generates the axis data, based upon the + -- points plotted. The default value is 'autoAxis'. + + , _laxis_override :: AxisData x -> AxisData x + -- ^ Function that can be used to override the generated axis data. + -- The default value is 'id'. + + , _laxis_reverse :: Bool + -- ^ True if left to right (bottom to top) is to show descending values. + + } - -- | Function that generates the axis data, based upon the - -- points plotted. The default value is 'autoAxis'. - _laxis_generate :: AxisFn x, +-- | Information on what is at a specifc location of a 'Layout' or 'LayoutLR'. +-- This is delivered by the 'PickFn' of a 'Renderable'. +data LayoutPick x y1 y2 = LayoutPick_Legend String -- ^ A legend entry. + | LayoutPick_Title String -- ^ The title. + | LayoutPick_XTopAxisTitle String -- ^ The title of the top x axis. + | LayoutPick_XBottomAxisTitle String -- ^ The title of the bottom x axis. + | LayoutPick_YLeftAxisTitle String -- ^ The title of the left y axis. + | LayoutPick_YRightAxisTitle String -- ^ The title of the right y axis. + | LayoutPick_PlotArea x y1 y2 -- ^ The plot area at the given plot coordinates. + | LayoutPick_XTopAxis x -- ^ The top x axis at the given plot coordinate. + | LayoutPick_XBottomAxis x -- ^ The bottom x axis at the given plot coordinate. + | LayoutPick_YLeftAxis y1 -- ^ The left y axis at the given plot coordinate. + | LayoutPick_YRightAxis y2 -- ^ The right y axis at the given plot coordinate. + deriving (Show) - -- | Function that can be used to override the generated axis data. - -- The default value is 'id'. - _laxis_override :: AxisData x -> AxisData x, +type LegendItem = (String,Rect -> ChartBackend ()) - -- | True if left to right (bottom to top) is to show descending values. - _laxis_reverse :: Bool +-- | A Layout value is a single plot area, with single x and y +-- axis. The title is at the top and the legend at the bottom. It's +-- parametrized by the types of values to be plotted on the x +-- and y axes. +data Layout x y = Layout + { _layout_background :: FillStyle + -- ^ How to fill the background of everything. + , _layout_plot_background :: Maybe FillStyle + -- ^ How to fill the background of the plot, + -- if different from the overall background. -} + , _layout_title :: String + -- ^ Title to display above the chart. + , _layout_title_style :: FontStyle + -- ^ Font style to use for the title. --- | A Layout1 value is a single plot area, with optional: axes on --- each of the 4 sides; title at the top; legend at the bottom. It's --- parameterised by the types of values to be plotted on the horizonal --- and vertical axes. -data Layout1 x y = Layout1 { + , _layout_x_axis :: LayoutAxis x + -- ^ Rules to generate the x axis. + , _layout_top_axis_visibility :: AxisVisibility + -- ^ Visibility options for the top axis. + , _layout_bottom_axis_visibility :: AxisVisibility + -- ^ Visibility options for the bottom axis. - _layout1_background :: FillStyle, - _layout1_plot_background :: Maybe FillStyle, + , _layout_y_axis :: LayoutAxis y + -- ^ Rules to generate the y axis. + , _layout_left_axis_visibility :: AxisVisibility + -- ^ Visibility options for the left axis. + , _layout_right_axis_visibility :: AxisVisibility + -- ^ Visibility options for the right axis. - _layout1_title :: String, - _layout1_title_style :: FontStyle, + , _layout_plots :: [Plot x y] + -- ^ The data sets to plot in the chart. + -- The are ploted over each other. - _layout1_bottom_axis :: LayoutAxis x, - _layout1_top_axis :: LayoutAxis x, - _layout1_left_axis :: LayoutAxis y, - _layout1_right_axis :: LayoutAxis y, + , _layout_legend :: Maybe LegendStyle + -- ^ How to style the legend. + , _layout_margin :: Double + -- ^ The margin distance to use. + , _layout_grid_last :: Bool + -- ^ If the grid shall be rendered + -- beneath (@False@) or over (@True@) all plots. + } - -- | Function to map points from the left/right plot - -- to the left/right axes. The default value is 'id'. - _layout1_yaxes_control :: ([y],[y]) -> ([y],[y]), +instance (Ord x, Ord y) => ToRenderable (Layout x y) where + toRenderable = setPickFn nullPickFn . layoutToRenderable - _layout1_margin :: Double, - _layout1_plots :: [Either (Plot x y) (Plot x y)], - _layout1_legend :: Maybe LegendStyle, +-- | Render the given 'Layout'. +layoutToRenderable :: forall x y . (Ord x, Ord y) => Layout x y -> Renderable (LayoutPick x y y) +layoutToRenderable l = fillBackground (_layout_background l) + $ gridToRenderable (layoutToGrid l) + where + layoutToGrid l = aboveN + [ tval $ titleToRenderable (_layout_margin l) (_layout_title_style l) (_layout_title l) + , weights (1,1) $ tval $ gridToRenderable $ + addMarginsToGrid (lm,lm,lm,lm) (layoutPlotAreaToGrid l) + , tval $ renderLegend l (getLegendItems l) + ] - -- | True if the grid is to be rendered on top of the Plots. - _layout1_grid_last :: Bool -} + lm = _layout_margin l + +getLayoutXVals :: Layout x y -> [x] +getLayoutXVals l = concatMap (fst . _plot_all_points) (_layout_plots l) -instance (Ord x, Ord y) => ToRenderable (Layout1 x y) where - toRenderable = setPickFn nullPickFn . layout1ToRenderable +-- | Extract all 'LegendItem's from the plots of a 'Layout'. +getLegendItems :: Layout x y -> [LegendItem] +getLegendItems l = concat [ _plot_legend p | p <- _layout_plots l ] -data Layout1Pick x y = L1P_Legend String - | L1P_Title String - | L1P_BottomAxisTitle String - | L1P_TopAxisTitle String - | L1P_LeftAxisTitle String - | L1P_RightAxisTitle String - | L1P_PlotArea x y y - | L1P_BottomAxis x - | L1P_TopAxis x - | L1P_LeftAxis y - | L1P_RightAxis y - deriving (Show) +-- | Render the given 'LegendItem's for a 'Layout'. +renderLegend :: Layout x y -> [LegendItem] -> Renderable (LayoutPick x y y) +renderLegend l legItems = gridToRenderable g + where + g = besideN [ tval $ mkLegend (_layout_legend l) (_layout_margin l) legItems + , weights (1,1) $ tval $ emptyRenderable ] -type LegendItem = (String,Rect -> ChartBackend ()) +-- | Render the plot area of a 'Layout'. This consists of the +-- actual plot area with all plots, the axis and their titles. +layoutPlotAreaToGrid :: forall x y. (Ord x, Ord y) => + Layout x y -> Grid (Renderable (LayoutPick x y y)) +layoutPlotAreaToGrid l = buildGrid LayoutGridElements{ + lge_plots = mfill (_layout_plot_background l) $ plotsToRenderable l, + lge_taxis = (tAxis,_laxis_title $ _layout_x_axis l, _laxis_title_style $ _layout_x_axis l), + lge_baxis = (bAxis,_laxis_title $ _layout_x_axis l, _laxis_title_style $ _layout_x_axis l), + lge_laxis = (lAxis,_laxis_title $ _layout_y_axis l, _laxis_title_style $ _layout_y_axis l), + lge_raxis = (rAxis,"", def), + lge_margin = _layout_margin l + } + where + xvals = [ x | p <- (_layout_plots l), x <- fst $ _plot_all_points p] + yvals = [ y | p <- (_layout_plots l), y <- snd $ _plot_all_points p] + bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layout_x_axis _layout_bottom_axis_visibility) xvals + tAxis = mkAxis E_Top (overrideAxisVisibility l _layout_x_axis _layout_top_axis_visibility ) xvals + lAxis = mkAxis E_Left (overrideAxisVisibility l _layout_y_axis _layout_left_axis_visibility ) yvals + rAxis = mkAxis E_Right (overrideAxisVisibility l _layout_y_axis _layout_right_axis_visibility ) yvals + axes = (bAxis,lAxis,tAxis,rAxis) + + plotsToRenderable l = Renderable { + minsize = return (0,0), + render = renderPlots l + } + + -- | Render the plots of a 'Layout' to a plot area of given size. + renderPlots :: Layout x y -> RectSize -> ChartBackend (PickFn (LayoutPick x y y)) + renderPlots l sz@(w,h) = do + when (not (_layout_grid_last l)) (renderGrids sz axes) + withClipRegion (Rect (Point 0 0) (Point w h)) $ do + mapM_ rPlot (_layout_plots l) + when (_layout_grid_last l) (renderGrids sz axes) + return pickfn + where + rPlot p = renderSinglePlot sz bAxis lAxis p + + xr = (0, w) + yr = (h, 0) + + pickfn :: PickFn (LayoutPick x y y) + pickfn (Point x y) = do -- Maybe monad + xat <- mxat + yat <- myat + return (LayoutPick_PlotArea (mapx xat x) (mapy yat y) (mapy yat y)) + where + mxat = case (bAxis,tAxis) of + (Just at,_) -> Just at + (_,Just at) -> Just at + (Nothing,Nothing) -> Nothing + myat = case (lAxis,rAxis) of + (Just at,_) -> Just at + (_,Just at) -> Just at + (Nothing,Nothing) -> Nothing + mapx (AxisT _ _ rev ad) x = _axis_tropweiv ad (optPairReverse rev xr) x + mapy (AxisT _ _ rev ad) y = _axis_tropweiv ad (optPairReverse rev yr) y + +-- | Empty 'Layout' without title and plots. The background is white and +-- the grid is drawn beneath all plots. There will be a legend. The top +-- and right axis will not be visible. +instance (PlotValue x, PlotValue y) => Default (Layout x y) where + def = Layout + { _layout_background = solidFillStyle $ opaque white + , _layout_plot_background = Nothing + + , _layout_title = "" + , _layout_title_style = def { _font_size = 15 + , _font_weight = FontWeightBold } + + , _layout_x_axis = def + , _layout_top_axis_visibility = def { _axis_show_line = False + , _axis_show_ticks = False + , _axis_show_labels = False } + , _layout_bottom_axis_visibility = def + , _layout_y_axis = def + , _layout_left_axis_visibility = def + , _layout_right_axis_visibility = def { _axis_show_line = False + , _axis_show_ticks = False + , _axis_show_labels = False } + + , _layout_margin = 10 + , _layout_plots = [] + , _layout_legend = Just def + , _layout_grid_last = False + } + +---------------------------------------------------------------------- + +-- | A LayoutLR value is a single plot area, with an x axis and +-- independent left and right y axes, with a title at the top; +-- legend at the bottom. It's parametrized by the types of values +-- to be plotted on the x and two y axes. +data LayoutLR x y1 y2 = LayoutLR + { _layoutlr_background :: FillStyle + -- ^ How to fill the background of everything. + , _layoutlr_plot_background :: Maybe FillStyle + -- ^ How to fill the background of the plot, + -- if different from the overall background. + + , _layoutlr_title :: String + -- ^ Title to display above the chart. + , _layoutlr_title_style :: FontStyle + -- ^ Font style to use for the title. + + , _layoutlr_x_axis :: LayoutAxis x + -- ^ Rules to generate the x axis. + , _layoutlr_top_axis_visibility :: AxisVisibility + -- ^ Visibility options for the top axis. + , _layoutlr_bottom_axis_visibility :: AxisVisibility + -- ^ Visibility options for the bottom axis. + + , _layoutlr_left_axis :: LayoutAxis y1 + -- ^ Rules to generate the left y axis. + , _layoutlr_left_axis_visibility :: AxisVisibility + -- ^ Visibility options for the left axis. + , _layoutlr_right_axis :: LayoutAxis y2 + -- ^ Rules to generate the right y axis. + , _layoutlr_right_axis_visibility :: AxisVisibility + -- ^ Visibility options for the right axis. + + , _layoutlr_plots :: [Either (Plot x y1) (Plot x y2)] + -- ^ The data sets to plot in the chart. + -- The are ploted over each other. + -- The either type associates the plot with the + -- left or right y axis. + + , _layoutlr_legend :: Maybe LegendStyle + -- ^ How to style the legend. + , _layoutlr_margin :: Double + -- ^ The margin distance to use. + , _layoutlr_grid_last :: Bool + -- ^ If the grid shall be rendered + -- beneath (@False@) or over (@True@) all plots. + } + +instance (Ord x, Ord yl, Ord yr) => ToRenderable (LayoutLR x yl yr) where + toRenderable = setPickFn nullPickFn . layoutLRToRenderable + +-- | Render the given 'LayoutLR'. +layoutLRToRenderable :: forall x yl yr . (Ord x, Ord yl, Ord yr) + => LayoutLR x yl yr -> Renderable (LayoutPick x yl yr) +layoutLRToRenderable l = fillBackground (_layoutlr_background l) + $ gridToRenderable (layoutLRToGrid l) + where + layoutLRToGrid l = aboveN + [ tval $ titleToRenderable (_layoutlr_margin l) (_layoutlr_title_style l) (_layoutlr_title l) + , weights (1,1) $ tval $ gridToRenderable $ + addMarginsToGrid (lm,lm,lm,lm) (layoutLRPlotAreaToGrid l) + , tval $ renderLegendLR l (getLegendItemsLR l) + ] + + lm = _layoutlr_margin l + +getLayoutLRXVals :: LayoutLR x yl yr -> [x] +getLayoutLRXVals l = concatMap deEither $ _layoutlr_plots l + where + deEither :: Either (Plot x yl) (Plot x yr) -> [x] + deEither (Left x) = fst $ _plot_all_points x + deEither (Right x) = fst $ _plot_all_points x + +-- | Extract all 'LegendItem's from the plots of a 'LayoutLR'. +-- Left and right plot legend items are still separated. +getLegendItemsLR :: LayoutLR x yl yr -> ([LegendItem],[LegendItem]) +getLegendItemsLR l = ( + concat [ _plot_legend p | (Left p ) <- (_layoutlr_plots l) ], + concat [ _plot_legend p | (Right p) <- (_layoutlr_plots l) ] + ) + +-- | Render the given 'LegendItem's for a 'LayoutLR'. +renderLegendLR :: LayoutLR x yl yr -> ([LegendItem],[LegendItem]) -> Renderable (LayoutPick x yl yr) +renderLegendLR l (lefts,rights) = gridToRenderable g + where + g = besideN [ tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) lefts + , weights (1,1) $ tval $ emptyRenderable + , tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) rights ] + lm = _layoutlr_margin l + +layoutLRPlotAreaToGrid :: forall x yl yr. (Ord x, Ord yl, Ord yr) + => LayoutLR x yl yr + -> Grid (Renderable (LayoutPick x yl yr)) +layoutLRPlotAreaToGrid l = buildGrid LayoutGridElements{ + lge_plots = mfill (_layoutlr_plot_background l) $ plotsToRenderable l, + lge_taxis = (tAxis,_laxis_title $ _layoutlr_x_axis l, _laxis_title_style $ _layoutlr_x_axis l), + lge_baxis = (bAxis,_laxis_title $ _layoutlr_x_axis l, _laxis_title_style $ _layoutlr_x_axis l), + lge_laxis = (lAxis,_laxis_title $ _layoutlr_left_axis l, _laxis_title_style $ _layoutlr_left_axis l), + lge_raxis = (rAxis,_laxis_title $ _layoutlr_right_axis l, _laxis_title_style $ _layoutlr_right_axis l), + lge_margin = _layoutlr_margin l + } + where + xvals = [ x | (Left p) <- _layoutlr_plots l, x <- fst $ _plot_all_points p] + ++ [ x | (Right p) <- _layoutlr_plots l, x <- fst $ _plot_all_points p] + yvalsL = [ y | (Left p) <- _layoutlr_plots l, y <- snd $ _plot_all_points p] + yvalsR = [ y | (Right p) <- _layoutlr_plots l, y <- snd $ _plot_all_points p] + + bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_bottom_axis_visibility) xvals + tAxis = mkAxis E_Top (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_top_axis_visibility ) xvals + lAxis = mkAxis E_Left (overrideAxisVisibility l _layoutlr_left_axis _layoutlr_left_axis_visibility ) yvalsL + rAxis = mkAxis E_Right (overrideAxisVisibility l _layoutlr_right_axis _layoutlr_right_axis_visibility) yvalsR + axes = (bAxis,lAxis,tAxis,rAxis) + + plotsToRenderable l = Renderable { + minsize = return (0,0), + render = renderPlots l + } + + renderPlots :: LayoutLR x yl yr -> RectSize -> ChartBackend (PickFn (LayoutPick x yl yr)) + renderPlots l sz@(w,h) = do + when (not (_layoutlr_grid_last l)) (renderGrids sz axes) + withClipRegion (Rect (Point 0 0) (Point w h)) $ do + mapM_ rPlot (_layoutlr_plots l) + when (_layoutlr_grid_last l) (renderGrids sz axes) + return pickfn + where + rPlot (Left p) = renderSinglePlot sz bAxis lAxis p + rPlot (Right p) = renderSinglePlot sz bAxis rAxis p + + xr = (0, w) + yr = (h, 0) + + pickfn (Point x y) = do -- Maybe monad + xat <- mxat + (yatL,yatR) <- myats + return (LayoutPick_PlotArea (mapx xat x) (mapy yatL y) (mapy yatR y)) + where + mxat = case (bAxis,tAxis) of + (Just at,_) -> Just at + (_,Just at) -> Just at + (Nothing,Nothing) -> Nothing + myats = case (lAxis,rAxis) of + (Just at1,Just at2) -> Just (at1,at2) + (_,_) -> Nothing + mapx (AxisT _ _ rev ad) x = _axis_tropweiv ad (optPairReverse rev xr) x + mapy (AxisT _ _ rev ad) y = _axis_tropweiv ad (optPairReverse rev yr) y + +---------------------------------------------------------------------- + -- | A layout with its y type hidden, so that it can be stacked --- with other layouts (with differing y types) -data StackedLayout x = forall y . Ord y => StackedLayout (Layout1 x y) +-- with other layouts with differing y axis, but the same x axis. +-- See 'StackedLayouts'. +data StackedLayout x = forall y . (Ord y) => StackedLayout (Layout x y) + -- ^ A 'Layout' to stack. + | forall yl yr . (Ord yl, Ord yr) => StackedLayoutLR (LayoutLR x yl yr) + -- ^ A 'LayoutLR' to stack. --- | A container for a set of vertically stacked layouts -data StackedLayouts x = StackedLayouts { - _slayouts_layouts :: [StackedLayout x], - _slayouts_compress_xlabels :: Bool, - _slayouts_compress_legend :: Bool -} +-- | A container for a set of vertically 'StackedLayout's. +-- The x axis of the different layouts will be aligned. +data StackedLayouts x = StackedLayouts + { _slayouts_layouts :: [StackedLayout x] + -- ^ The stacked layouts from top (first element) to bottom (last element). + , _slayouts_compress_legend :: Bool + -- ^ If the different legends shall be combined in one legend at the bottom. + } {-# DEPRECATED defaultStackedLayouts "Use the according Data.Default instance!" #-} defaultStackedLayouts :: StackedLayouts x defaultStackedLayouts = def +-- | A empty 'StackedLayout' with compressions applied. instance Default (StackedLayouts x) where - def = StackedLayouts [] True True + def = StackedLayouts [] 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 () +-- The legends from all the charts may be optionally combined, and shown +-- once on the bottom chart. See 'StackedLayouts' for further information. +renderStackedLayouts :: forall x. (Ord x) => StackedLayouts x -> Renderable () renderStackedLayouts (StackedLayouts{_slayouts_layouts=[]}) = emptyRenderable renderStackedLayouts slp@(StackedLayouts{_slayouts_layouts=sls@(sl1:_)}) = gridToRenderable g where g = fullOverlayUnder (fillBackground bg emptyRenderable) $ foldr (above.mkGrid) nullt (zip sls [0,1..]) - - mkGrid ((StackedLayout l),i) - = (noPickFn $ layout1TitleToRenderable l) + + mkGrid :: (StackedLayout x, Int) -> Grid (Renderable ()) + mkGrid (sl, i) + = titleR `wideAbove` - (addMarginsToGrid (lm,lm,lm,lm) $ mkPlotArea baxis taxis) + (addMarginsToGrid (lm,lm,lm,lm) $ mkPlotArea usedAxis) `aboveWide` - (if showLegend then noPickFn $ renderLegend l legenditems else emptyRenderable) - + (if showLegend then legendR else emptyRenderable) where + titleR = case sl of + StackedLayout l -> noPickFn $ titleToRenderable (_layout_margin l) (_layout_title_style l) (_layout_title l) + StackedLayoutLR l -> noPickFn $ titleToRenderable (_layoutlr_margin l) (_layoutlr_title_style l) (_layoutlr_title l) + legendR = case sl of + StackedLayout l -> noPickFn $ renderLegend l $ fst legenditems + StackedLayoutLR l -> noPickFn $ renderLegendLR l legenditems + legenditems = case (_slayouts_compress_legend slp,isBottomPlot) of - (False,_) -> getLegendItems l - (True,True) -> alllegendItems + (False,_) -> case sl of + StackedLayout l -> (getLegendItems l, []) + StackedLayoutLR l -> getLegendItemsLR l + (True,True) -> allLegendItems (True,False) -> ([],[]) - - mkPlotArea bx tx = fmap (mapPickFn (const ())) - $ layout1PlotAreaToGrid l{_layout1_bottom_axis=bx,_layout1_top_axis=tx} + + mkPlotArea :: LayoutAxis x -> Grid (Renderable ()) + mkPlotArea axis = case sl of + StackedLayout l -> fmap noPickFn + $ layoutPlotAreaToGrid + $ l { _layout_x_axis = axis } + StackedLayoutLR l -> fmap noPickFn + $ layoutLRPlotAreaToGrid + $ l { _layoutlr_x_axis = axis } showLegend = not (null (fst legenditems)) || not (null (snd legenditems)) - 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=[]} - } + isBottomPlot = i == length sls - 1 - bg = (\(StackedLayout l) -> _layout1_background l) sl1 + lm = case sl of + StackedLayout l -> _layout_margin l + StackedLayoutLR l -> _layoutlr_margin l + + xAxis :: LayoutAxis x + xAxis = case sl of + StackedLayout l -> _layout_x_axis l + StackedLayoutLR l -> _layoutlr_x_axis l + + usedAxis :: LayoutAxis x + usedAxis = xAxis + { _laxis_generate = const (_laxis_generate xAxis all_xvals) } + + bg = case sl1 of + StackedLayout l -> _layout_background l + StackedLayoutLR l -> _layoutlr_background l - all_xvals = concatMap (\(StackedLayout l) -> getLayout1XVals l) sls + getXVals :: StackedLayout x -> [x] + getXVals (StackedLayout l) = getLayoutXVals l + getXVals (StackedLayoutLR l) = getLayoutLRXVals l + + all_xvals = concatMap getXVals sls - alllegendItems = (concatMap (fst.legendItems) sls, concatMap (snd.legendItems) sls) - legendItems (StackedLayout l) = (getLegendItems l) + allLegendItems = (concatMap (fst.legendItems) sls, concatMap (snd.legendItems) sls) + legendItems :: StackedLayout x -> ([LegendItem], [LegendItem]) + legendItems (StackedLayout l) = (getLegendItems l, []) + lebendItems (StackedLayoutLR l) = getLegendItemsLR l + noPickFn :: Renderable a -> Renderable () noPickFn = mapPickFn (const ()) +---------------------------------------------------------------------- + addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a) -> Grid (Renderable a) addMarginsToGrid (t,b,l,r) g = aboveN [ @@ -250,241 +588,178 @@ bs = tval $ spacer (0,b) rs = tval $ spacer (r,0) -layout1ToRenderable :: (Ord x, Ord y) => - Layout1 x y -> Renderable (Layout1Pick x y) -layout1ToRenderable l = - fillBackground (_layout1_background l) $ gridToRenderable (layout1ToGrid l) - -layout1ToGrid :: (Ord x, Ord y) => - Layout1 x y -> Grid (Renderable (Layout1Pick x y)) -layout1ToGrid l = aboveN - [ tval $ layout1TitleToRenderable l - , weights (1,1) $ tval $ gridToRenderable $ - addMarginsToGrid (lm,lm,lm,lm) (layout1PlotAreaToGrid l) - , tval $ layout1LegendsToRenderable l - ] - where - lm = _layout1_margin l - -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) +titleToRenderable :: Double -> FontStyle -> String -> Renderable (LayoutPick x yl yr) +titleToRenderable lm fs "" = emptyRenderable +titleToRenderable lm fs s = addMargins (lm/2,0,0,0) (mapPickFn LayoutPick_Title title) where - title = label (_layout1_title_style l) HTA_Centre VTA_Centre - (_layout1_title l) - lm = _layout1_margin l + title = label fs HTA_Centre VTA_Centre s -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 +mkLegend :: Maybe LegendStyle -> Double -> [LegendItem] -> Renderable (LayoutPick x yl yr) +mkLegend ls lm vals = case ls of + Nothing -> emptyRenderable + Just ls -> case filter ((/="").fst) vals of + [] -> emptyRenderable ; + lvs -> addMargins (0,lm,lm,lm) $ + mapPickFn LayoutPick_Legend $ legendToRenderable (Legend ls lvs) -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 ] - - lm = _layout1_margin l - - mkLegend vals = case (_layout1_legend l) of - Nothing -> emptyRenderable - Just ls -> case filter ((/="").fst) vals of - [] -> emptyRenderable ; - lvs -> addMargins (0,lm,lm,lm) $ - mapPickFn L1P_Legend $ legendToRenderable (Legend ls lvs) +data LayoutGridElements x yl yr = LayoutGridElements { + lge_plots :: Renderable (LayoutPick x yl yr), + + lge_taxis :: (Maybe (AxisT x),String,FontStyle), + lge_baxis :: (Maybe (AxisT x),String,FontStyle), + lge_laxis :: (Maybe (AxisT yl),String,FontStyle), + lge_raxis :: (Maybe (AxisT yr),String,FontStyle), -layout1LegendsToRenderable :: (Ord x, Ord y) => - Layout1 x y -> Renderable (Layout1Pick x y) -layout1LegendsToRenderable l = renderLegend l (getLegendItems l) + lge_margin :: Double +} -layout1PlotAreaToGrid :: forall x y. (Ord x, Ord y) => - Layout1 x y -> Grid (Renderable (Layout1Pick x y)) -layout1PlotAreaToGrid l = layer2 `overlay` layer1 +buildGrid :: (Ord x, Ord yl, Ord yr) => LayoutGridElements x yl yr -> Grid (Renderable (LayoutPick x yl yr)) +buildGrid lge = layer2 `overlay` layer1 where layer1 = aboveN [ besideN [er, er, er, er ] - , besideN [er, er, er, er ] , besideN [er, er, er, weights (1,1) plots ] ] layer2 = aboveN - [ besideN [er, er, er, ttitle, er, er, er ] - , besideN [er, er, tl, taxis, tr, 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,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 :: HTextAnchor -> VTextAnchor - -> Double - -> (Layout1 x y -> LayoutAxis z) - -> (String -> Layout1Pick x y) - -> (Grid (Renderable (Layout1Pick x y)), Grid (Renderable (Layout1Pick x y))) - 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) - plots = tval $ mfill (_layout1_plot_background l) $ plotsToRenderable l - where - mfill Nothing = id - mfill (Just fs) = fillBackground fs + plots = tval $ lge_plots lge - (ba,la,ta,ra) = getAxes l + (tdata,tlbl,tstyle) = lge_taxis lge + (bdata,blbl,bstyle) = lge_baxis lge + (ldata,llbl,lstyle) = lge_laxis lge + (rdata,rlbl,rstyle) = lge_raxis lge + + (ttitle,_) = mktitle HTA_Centre VTA_Bottom 0 tlbl tstyle LayoutPick_XTopAxisTitle + (btitle,_) = mktitle HTA_Centre VTA_Top 0 blbl bstyle LayoutPick_XBottomAxisTitle + (ltitle,lam) = mktitle HTA_Right VTA_Centre 270 llbl lstyle LayoutPick_YLeftAxisTitle + (rtitle,ram) = mktitle HTA_Left VTA_Centre 270 rlbl rstyle LayoutPick_YRightAxisTitle + baxis = tval $ maybe emptyRenderable - (mapPickFn L1P_BottomAxis . axisToRenderable) ba + (mapPickFn LayoutPick_XBottomAxis . axisToRenderable) bdata taxis = tval $ maybe emptyRenderable - (mapPickFn L1P_TopAxis . axisToRenderable) ta + (mapPickFn LayoutPick_XTopAxis . axisToRenderable) tdata laxis = tval $ maybe emptyRenderable - (mapPickFn L1P_LeftAxis . axisToRenderable) la + (mapPickFn LayoutPick_YLeftAxis . axisToRenderable) ldata raxis = tval $ maybe emptyRenderable - (mapPickFn L1P_RightAxis . axisToRenderable) ra - - tl = tval $ axesSpacer fst ta fst la - bl = tval $ axesSpacer fst ba snd la - tr = tval $ axesSpacer snd ta fst ra - br = tval $ axesSpacer snd ba snd ra - -plotsToRenderable :: Layout1 x y -> Renderable (Layout1Pick x y) -plotsToRenderable l = Renderable { - minsize = return (0,0), - render = renderPlots l - } - -renderPlots :: Layout1 x y -> RectSize -> ChartBackend (PickFn (Layout1Pick x y)) -renderPlots l sz@(w,h) = do - when (not (_layout1_grid_last l)) renderGrids - withClipRegion (Rect (Point 0 0) (Point w h)) $ do - mapM_ rPlot (_layout1_plots l) - when (_layout1_grid_last l) renderGrids - return pickfn - - where - (bAxis,lAxis,tAxis,rAxis) = getAxes l + (mapPickFn LayoutPick_YRightAxis . axisToRenderable) rdata - rPlot (Left p) = rPlot1 bAxis lAxis p - rPlot (Right p) = rPlot1 bAxis rAxis p + tl = tval $ axesSpacer fst tdata fst ldata + bl = tval $ axesSpacer fst bdata snd ldata + tr = tval $ axesSpacer snd tdata fst rdata + br = tval $ axesSpacer snd bdata snd rdata - xr = (0, w) - yr = (h, 0) - reverse rev (a,b) = if rev then (b,a) else (a,b) + mktitle :: HTextAnchor -> VTextAnchor + -> Double + -> String -> FontStyle + -> (String -> LayoutPick x yl yr) + -> ( Grid (Renderable (LayoutPick x yl yr)) + , Grid (Renderable (LayoutPick x yl yr)) ) + mktitle ha va rot lbl style pf = if lbl == "" then (er,er) else (label,gap) + where + label = tval $ mapPickFn pf $ rlabel style ha va rot lbl + gap = tval $ spacer (lge_margin lge,0) - rPlot1 (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p = - let - xr1 = reverse xrev xr - yr1 = reverse yrev yr - yrange = if yrev then (0, h) else (h, 0) - 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 () +-- | Render the grids of the given axis to a plot area of given size. +renderGrids :: RectSize -> (Maybe (AxisT x), Maybe (AxisT yl), Maybe (AxisT x), Maybe (AxisT yr)) -> ChartBackend () +renderGrids sz (bAxis, lAxis, tAxis, rAxis) = do + maybeM () (renderAxisGrid sz) tAxis + maybeM () (renderAxisGrid sz) bAxis + maybeM () (renderAxisGrid sz) lAxis + maybeM () (renderAxisGrid sz) rAxis - pickfn (Point x y) = do -- Maybe monad - xat <- mxat - (yat1,yat2) <- myats - return (L1P_PlotArea (mapx xat x) (mapy yat1 y) (mapy yat2 y)) - where - mxat = case (bAxis,tAxis) of - (Just at,_) -> Just at - (_,Just at) -> Just at - (Nothing,Nothing) -> Nothing - myats = case (lAxis,rAxis) of - (Just at,Nothing) -> Just (at,at) - (Nothing,Just at) -> Just (at,at) - (Just at1,Just at2) -> Just (at1,at2) - (Nothing,Nothing) -> Nothing - mapx (AxisT _ _ rev ad) x = _axis_tropweiv ad (reverse rev xr) x - mapy (AxisT _ _ rev ad) y = _axis_tropweiv ad (reverse rev yr) y +-- | Swap the contents of the pair depending on the flag. +optPairReverse :: Bool -> (a,a) -> (a,a) +optPairReverse rev (a,b) = if rev then (b,a) else (a,b) - renderGrids = do - maybeM () (renderAxisGrid sz) tAxis - maybeM () (renderAxisGrid sz) bAxis - maybeM () (renderAxisGrid sz) lAxis - maybeM () (renderAxisGrid sz) rAxis +-- | Render a single set of plot data onto a plot area of given size using +-- the given x and y axis. +renderSinglePlot :: RectSize -> Maybe (AxisT x) -> Maybe (AxisT y) -> Plot x y -> ChartBackend () +renderSinglePlot (w, h) (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p = + let xr = optPairReverse xrev (0, w) + yr = optPairReverse yrev (h, 0) + yrange = if yrev then (0, h) else (h, 0) + pmfn (x,y) = Point (mapv xr (_axis_viewport xaxis xr) x) + (mapv yr (_axis_viewport yaxis yr) y) + mapv (min,max) _ LMin = min + mapv (min,max) _ LMax = max + mapv _ f (LValue v) = f v + in _plot_render p pmfn +renderSinglePlot _ _ _ _ = return () +axesSpacer :: (Ord x, Ord y) + => ((Double, Double) -> Double) -> Maybe (AxisT x) + -> ((Double, Double) -> Double) -> Maybe (AxisT y) + -> Renderable a axesSpacer f1 a1 f2 a2 = embedRenderable $ do oh1 <- maybeM (0,0) axisOverhang a1 oh2 <- maybeM (0,0) axisOverhang a2 return (spacer (f1 oh1, f2 oh2)) -getAxes :: Layout1 x y -> - (Maybe (AxisT x), Maybe (AxisT y), Maybe (AxisT x), Maybe (AxisT y)) -getAxes l = (bAxis,lAxis,tAxis,rAxis) +-- | Construct a axis for the given edge using the attributes +-- from a 'LayoutAxis' the given values. +mkAxis :: RectEdge -> LayoutAxis z -> [z] -> Maybe (AxisT z) +mkAxis edge laxis vals = case axisVisible of + False -> Nothing + True -> Just $ AxisT edge style rev adata where - (xvals0,xvals1,yvals0,yvals1) = allPlottedValues (_layout1_plots l) - xvals = xvals0 ++ xvals1 - (yvals0',yvals1') = _layout1_yaxes_control l (yvals0,yvals1) - - bAxis = mkAxis E_Bottom (_layout1_bottom_axis l) xvals - tAxis = mkAxis E_Top (_layout1_top_axis l) xvals - lAxis = mkAxis E_Left (_layout1_left_axis l) yvals0' - rAxis = mkAxis E_Right (_layout1_right_axis l) yvals1' - - mkAxis t laxis vals = case _laxis_visible laxis vals of - False -> Nothing - True -> Just (AxisT t style rev adata) - where - style = _laxis_style laxis - rev = _laxis_reverse laxis - adata = (_laxis_override laxis) (_laxis_generate laxis vals) + style = _laxis_style laxis + rev = _laxis_reverse laxis + adata = (_laxis_override laxis) (_laxis_generate laxis vals) + vis = _axis_visibility adata + axisVisible = _axis_show_labels vis || _axis_show_line vis || _axis_show_ticks vis -allPlottedValues :: [(Either (Plot x y) (Plot x' y'))] - -> ( [x], [x'], [y], [y'] ) -allPlottedValues plots = (xvals0,xvals1,yvals0,yvals1) - where - xvals0 = [ x | (Left p) <- plots, x <- fst $ _plot_all_points p] - yvals0 = [ y | (Left p) <- plots, y <- snd $ _plot_all_points p] - xvals1 = [ x | (Right p) <- plots, x <- fst $ _plot_all_points p] - yvals1 = [ y | (Right p) <- plots, y <- snd $ _plot_all_points p] +-- | Override the visibility of a selected axis with the selected 'AxisVisibility'. +overrideAxisVisibility :: layout + -> (layout -> LayoutAxis z) + -> (layout -> AxisVisibility) + -> LayoutAxis z +overrideAxisVisibility ly selAxis selVis = + let vis = selVis ly + in (selAxis ly) { _laxis_override = (\ad -> ad { _axis_visibility = selVis ly }) + . _laxis_override (selAxis ly) + } -{-# DEPRECATED defaultLayout1 "Use the according Data.Default instance!" #-} -defaultLayout1 :: (PlotValue x,PlotValue y) => Layout1 x y -defaultLayout1 = def +mfill :: Maybe FillStyle -> Renderable a -> Renderable a +mfill Nothing = id +mfill (Just fs) = fillBackground fs -instance (PlotValue x, PlotValue y) => Default (Layout1 x y) where - def = Layout1 - { _layout1_background = solidFillStyle $ opaque white - , _layout1_plot_background = Nothing +-- | Empty 'LayoutLR' without title and plots. The background is white and +-- the grid is drawn beneath all plots. There will be a legend. The top +-- axis will not be visible. +instance (PlotValue x, PlotValue y1, PlotValue y2) => Default (LayoutLR x y1 y2) where + def = LayoutLR + { _layoutlr_background = solidFillStyle $ opaque white + , _layoutlr_plot_background = Nothing - , _layout1_title = "" - , _layout1_title_style = def { _font_size = 15 - , _font_weight = FontWeightBold } + , _layoutlr_title = "" + , _layoutlr_title_style = def { _font_size = 15 + , _font_weight = FontWeightBold } - , _layout1_top_axis = def {_laxis_visible = const False} - , _layout1_bottom_axis = def - , _layout1_left_axis = def - , _layout1_right_axis = def + , _layoutlr_x_axis = def + , _layoutlr_top_axis_visibility = def { _axis_show_line = False + , _axis_show_ticks = False + , _axis_show_labels = False } + , _layoutlr_bottom_axis_visibility = def - , _layout1_yaxes_control = id + , _layoutlr_left_axis = def + , _layoutlr_left_axis_visibility = def + , _layoutlr_right_axis = def + , _layoutlr_right_axis_visibility = def + + , _layoutlr_plots = [] - , _layout1_margin = 10 - , _layout1_plots = [] - , _layout1_legend = Just def - , _layout1_grid_last = False + , _layoutlr_legend = Just def + , _layoutlr_margin = 10 + , _layoutlr_grid_last = False } {-# DEPRECATED defaultLayoutAxis "Use the according Data.Default instance!" #-} @@ -496,7 +771,6 @@ { _laxis_title_style = def { _font_size=10 } , _laxis_title = "" , _laxis_style = def - , _laxis_visible = not.null , _laxis_generate = autoAxis , _laxis_override = id , _laxis_reverse = False @@ -505,28 +779,34 @@ ---------------------------------------------------------------------- -- Template haskell to derive an instance of Data.Accessor.Accessor -- for each field. -$( makeLenses ''Layout1 ) +$( makeLenses ''Layout ) +$( makeLenses ''LayoutLR ) $( makeLenses ''LayoutAxis ) $( makeLenses ''StackedLayouts ) -- | Helper to update all axis styles on a Layout1 simultaneously. -updateAllAxesStyles :: (AxisStyle -> AxisStyle) -> Layout1 x y -> Layout1 x y -updateAllAxesStyles uf = (layout1_top_axis . laxis_style %~ uf) . - (layout1_bottom_axis . laxis_style %~ uf) . - (layout1_left_axis . laxis_style %~ uf) . - (layout1_right_axis . laxis_style %~ uf) +updateAllAxesStyles :: (AxisStyle -> AxisStyle) -> Layout x y -> Layout x y +updateAllAxesStyles uf = (layout_x_axis . laxis_style %~ uf) . + (layout_y_axis . laxis_style %~ uf) --- | Helper to set the forground color uniformly on a Layout1. -setLayout1Foreground :: AlphaColour Double -> Layout1 x y -> Layout1 x y -setLayout1Foreground fg = +-- | Helper to update all axis styles on a LayoutLR simultaneously. +updateAllAxesStylesLR :: (AxisStyle -> AxisStyle) -> LayoutLR x yl yr -> LayoutLR x yl yr +updateAllAxesStylesLR uf = (layoutlr_x_axis . laxis_style %~ uf) + . (layoutlr_left_axis . laxis_style %~ uf) + . (layoutlr_right_axis . laxis_style %~ uf) + +-- | Helper to set the forground color uniformly on a Layout. +setLayoutForeground :: AlphaColour Double -> Layout x y -> Layout x y +setLayoutForeground fg = updateAllAxesStyles ( (axis_line_style . line_color .~ fg) . (axis_label_style . font_color .~ fg)) - . (layout1_title_style . font_color .~ fg) - . (layout1_legend %~ fmap (legend_label_style .> font_color .~ fg)) - - -linkAxes :: ([a], [a]) -> ([a], [a]) -linkAxes (ys1,ys2) = (ys1++ys2,ys1++ys2) + . (layout_title_style . font_color .~ fg) + . (layout_legend %~ fmap (legend_label_style .> font_color .~ fg)) -independentAxes :: (a, b) -> (a, b) -independentAxes (ys1,ys2) = (ys1,ys2) +-- | Helper to set the forground color uniformly on a LayoutLR. +setLayoutLRForeground :: AlphaColour Double -> LayoutLR x yl yr -> LayoutLR x yl yr +setLayoutLRForeground fg = updateAllAxesStylesLR + ( (axis_line_style . line_color .~ fg) + . (axis_label_style . font_color .~ fg)) + . (layoutlr_title_style . font_color .~ fg) + . (layoutlr_legend %~ fmap (legend_label_style .> font_color .~ fg)) diff --git a/Graphics/Rendering/Chart/Plot/Bars.hs b/Graphics/Rendering/Chart/Plot/Bars.hs --- a/Graphics/Rendering/Chart/Plot/Bars.hs +++ b/Graphics/Rendering/Chart/Plot/Bars.hs @@ -69,8 +69,8 @@ -- | 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 + | BarsCentered -- ^ Bars are centered around deviceX + | BarsRight -- ^ The right edge of bars is at deviceX deriving (Show) -- | Value describing how to plot a set of bars. 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 @@ -27,8 +27,8 @@ ----------------------------------------------------------------------------- module Graphics.Rendering.Chart.Simple( plot, PlotKind(..), xcoords, plotPDF, plotPS, - plotLayout, plotPNG, Layout1DDD, - layout1DddToRenderable + plotLayout, plotPNG, LayoutDDD, + layoutDddToRenderable , PlotPDFType(..) , PlotPSType(..) , PlotPNGType(..) diff --git a/Graphics/Rendering/Chart/Simple/Internal.hs b/Graphics/Rendering/Chart/Simple/Internal.hs --- a/Graphics/Rendering/Chart/Simple/Internal.hs +++ b/Graphics/Rendering/Chart/Simple/Internal.hs @@ -21,11 +21,9 @@ , Triangle, DownTriangle, Plus, Star , FilledCircle ] --- When defaultLayout1 has been generalized, change this signature to --- [InternalPlot x y] -> Layout1 x y z -iplot :: [InternalPlot Double Double] -> Layout1 Double Double -iplot foobar = (def :: Layout1 Double Double) { - _layout1_plots = concat $ zipWith toplot (ip foobar) [0..] +iplot :: (PlotValue x, PlotValue y) => [InternalPlot x y] -> Layout x y +iplot foobar = def { + _layout_plots = concat $ zipWith toplot (ip foobar) [0..] } where ip (xs@(IPX _ _):xyss) = map (\ys -> (xs,ys)) yss ++ ip rest @@ -35,7 +33,7 @@ ip [] = [] isIPY (IPY _ _) = True isIPY _ = False - toplot (IPX xs _, IPY ys yks) ind = map Left plots + toplot (IPX xs _, IPY ys yks) ind = plots where vs = zip xs ys plots = case catMaybes $ map plotas yks of @@ -140,16 +138,16 @@ deriving ( Eq, Show, Ord ) data InternalPlot x y = IPY [y] [PlotKind] | IPX [x] [PlotKind] -newtype Layout1DDD = Layout1DDD { plotLayout :: Layout1 Double Double } +newtype LayoutDDD = LayoutDDD { plotLayout :: Layout Double Double } -layout1DddToRenderable :: Layout1DDD -> Renderable (Layout1Pick Double Double) -layout1DddToRenderable = layout1ToRenderable . plotLayout +layoutDddToRenderable :: LayoutDDD -> Renderable (LayoutPick Double Double Double) +layoutDddToRenderable = layoutToRenderable . plotLayout -instance ToRenderable Layout1DDD where +instance ToRenderable LayoutDDD where toRenderable = setPickFn nullPickFn . toRenderable -uplot :: [UPlot] -> Layout1DDD -uplot us = Layout1DDD $ iplot $ nameDoubles $ evalfuncs us +uplot :: [UPlot] -> LayoutDDD +uplot us = LayoutDDD $ iplot $ nameDoubles $ evalfuncs us where nameDoubles :: [UPlot] -> [InternalPlot Double Double] nameDoubles (X xs: uus) = case grabName uus of @@ -191,7 +189,7 @@ pl :: [UPlot] -> t instance (PlotArg a, PlotType r) => PlotType (a -> r) where pl args = \ a -> pl (toUPlot a ++ args) -instance PlotType Layout1DDD where +instance PlotType LayoutDDD where pl args = uplot (reverse args) -- | Save a plot as a PDF file.