----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Chart.Layout -- Copyright : (c) Tim Docker 2006, 2014 -- License : BSD-style (see chart/COPYRIGHT) -- -- This module glues together axes and plots to actually create a renderable -- for a chart. -- -- Note that Template haskell is used to derive accessor functions -- (see 'Control.Lens') for each field of the following data types: -- -- * 'Layout' -- -- * 'LayoutLR' -- -- * 'StackedLayouts' -- -- * 'LayoutAxis' -- {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ExistentialQuantification #-} module Graphics.Rendering.Chart.Layout ( -- * Types Layout(..) , LayoutLR(..) , LayoutAxis(..) , LayoutPick(..) , StackedLayouts(..) , StackedLayout(..) -- , LegendItem haddock complains about this being missing, but from what? , MAxisFn -- * Rendering , layoutToRenderable , layoutToGrid , layoutLRToRenderable , layoutLRToGrid , renderStackedLayouts -- * LayoutAxis lenses , laxis_title_style , laxis_title , laxis_style , laxis_generate , laxis_override , laxis_reverse -- * Layout lenses , layout_background , layout_plot_background , layout_title , layout_title_style , layout_x_axis , layout_top_axis_visibility , layout_bottom_axis_visibility , layout_y_axis , layout_left_axis_visibility , layout_right_axis_visibility , layout_margin , layout_plots , layout_legend , layout_grid_last , layout_axes_styles , layout_axes_title_styles , layout_all_font_styles , layout_foreground -- * LayoutLR lenses , layoutlr_background , layoutlr_plot_background , layoutlr_title , layoutlr_title_style , layoutlr_x_axis , layoutlr_top_axis_visibility , layoutlr_bottom_axis_visibility , layoutlr_left_axis , layoutlr_right_axis , layoutlr_left_axis_visibility , layoutlr_right_axis_visibility , layoutlr_plots , layoutlr_legend , layoutlr_margin , layoutlr_grid_last , layoutlr_axes_styles , layoutlr_axes_title_styles , layoutlr_all_font_styles , layoutlr_foreground -- * StackedLayouts lenses , slayouts_layouts , slayouts_compress_legend ) where import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Geometry import Graphics.Rendering.Chart.Drawing import Graphics.Rendering.Chart.Utils import Graphics.Rendering.Chart.Plot import Graphics.Rendering.Chart.Legend import Graphics.Rendering.Chart.Renderable import Graphics.Rendering.Chart.Grid import Control.Monad import Control.Lens hiding (at) import Data.Colour import Data.Colour.Names (white) import Data.Default.Class -- | A @MAxisFn@ is a function that generates an (optional) axis -- given the points plotted against that axis. type MAxisFn t = [t] -> Maybe (AxisData t) -- | Type of axis that is used in 'Layout' and 'LayoutLR'. -- -- To generate the actual axis type ('AxisData' and 'AxisT') -- the '_laxis_generate' function is called and custom settings -- are applied with '_laxis_override'. Note that the 'AxisVisibility' -- values in 'Layout' and 'LayoutLR' override visibility related -- settings of the axis. data LayoutAxis x = LayoutAxis { _laxis_title_style :: FontStyle -- ^ Font style to use for the axis title. , _laxis_title :: String -- ^ Title displayed for the axis. , _laxis_style :: AxisStyle -- ^ Axis style applied. , _laxis_generate :: AxisFn x -- ^ Function that generates the axis data, based upon the -- points plotted. The default value is 'autoAxis'. , _laxis_override :: AxisData x -> AxisData x -- ^ Function that can be used to override the generated axis data. -- The default value is 'id'. , _laxis_reverse :: Bool -- ^ True if left to right (bottom to top) is to show descending values. } -- | Information on what is at a specifc location of a 'Layout' or 'LayoutLR'. -- This is delivered by the 'PickFn' of a 'Renderable'. data LayoutPick x y1 y2 = LayoutPick_Legend String -- ^ A legend entry. | LayoutPick_Title String -- ^ The title. | LayoutPick_XTopAxisTitle String -- ^ The title of the top x axis. | LayoutPick_XBottomAxisTitle String -- ^ The title of the bottom x axis. | LayoutPick_YLeftAxisTitle String -- ^ The title of the left y axis. | LayoutPick_YRightAxisTitle String -- ^ The title of the right y axis. | LayoutPick_PlotArea x y1 y2 -- ^ The plot area at the given plot coordinates. | LayoutPick_XTopAxis x -- ^ The top x axis at the given plot coordinate. | LayoutPick_XBottomAxis x -- ^ The bottom x axis at the given plot coordinate. | LayoutPick_YLeftAxis y1 -- ^ The left y axis at the given plot coordinate. | LayoutPick_YRightAxis y2 -- ^ The right y axis at the given plot coordinate. deriving (Show) type LegendItem = (String,Rect -> BackendProgram ()) -- | A Layout value is a single plot area, with single x and y -- axis. The title is at the top and the legend at the bottom. It's -- parametrized by the types of values to be plotted on the x -- and y axes. data Layout x y = Layout { _layout_background :: FillStyle -- ^ How to fill the background of everything. , _layout_plot_background :: Maybe FillStyle -- ^ How to fill the background of the plot, -- if different from the overall background. , _layout_title :: String -- ^ Title to display above the chart. , _layout_title_style :: FontStyle -- ^ Font style to use for the title. , _layout_x_axis :: LayoutAxis x -- ^ Rules to generate the x axis. , _layout_top_axis_visibility :: AxisVisibility -- ^ Visibility options for the top axis. , _layout_bottom_axis_visibility :: AxisVisibility -- ^ Visibility options for the bottom axis. , _layout_y_axis :: LayoutAxis y -- ^ Rules to generate the y axis. , _layout_left_axis_visibility :: AxisVisibility -- ^ Visibility options for the left axis. , _layout_right_axis_visibility :: AxisVisibility -- ^ Visibility options for the right axis. , _layout_plots :: [Plot x y] -- ^ The data sets to plot in the chart. -- The are ploted over each other. , _layout_legend :: Maybe LegendStyle -- ^ How to style the legend. , _layout_margin :: Double -- ^ The margin distance to use. , _layout_grid_last :: Bool -- ^ If the grid shall be rendered -- beneath (@False@) or over (@True@) all plots. } instance (Ord x, Ord y) => ToRenderable (Layout x y) where toRenderable = setPickFn nullPickFn . layoutToRenderable -- | Render the given 'Layout'. layoutToRenderable :: forall x y . (Ord x, Ord y) => Layout x y -> Renderable (LayoutPick x y y) layoutToRenderable l = fillBackground (_layout_background l) $ gridToRenderable (layoutToGrid l) layoutToGrid :: forall x y . (Ord x, Ord y) => Layout x y -> Grid (Renderable (LayoutPick x y y)) layoutToGrid l = grid where grid = titleToRenderable lm (_layout_title_style l) (_layout_title l) `wideAbove` addMarginsToGrid (lm,lm,lm,lm) (layoutPlotAreaToGrid l) `aboveWide` renderLegend l (getLegendItems l) lm = _layout_margin l getLayoutXVals :: Layout x y -> [x] getLayoutXVals l = concatMap (fst . _plot_all_points) (_layout_plots l) -- | Extract all 'LegendItem's from the plots of a 'Layout'. getLegendItems :: Layout x y -> [LegendItem] getLegendItems l = concat [ _plot_legend p | p <- _layout_plots l ] -- | Render the given 'LegendItem's for a 'Layout'. renderLegend :: Layout x y -> [LegendItem] -> Renderable (LayoutPick x y y) renderLegend l legItems = gridToRenderable g where g = besideN [ tval $ mkLegend (_layout_legend l) (_layout_margin l) legItems , weights (1,1) $ tval emptyRenderable ] -- | Render the plot area of a 'Layout'. This consists of the -- actual plot area with all plots, the axis and their titles. layoutPlotAreaToGrid :: forall x y. (Ord x, Ord y) => Layout x y -> Grid (Renderable (LayoutPick x y y)) layoutPlotAreaToGrid l = buildGrid LayoutGridElements{ lge_plots = mfill (_layout_plot_background l) $ plotsToRenderable l, lge_taxis = (tAxis,_laxis_title $ _layout_x_axis l, _laxis_title_style $ _layout_x_axis l), lge_baxis = (bAxis,_laxis_title $ _layout_x_axis l, _laxis_title_style $ _layout_x_axis l), lge_laxis = (lAxis,_laxis_title $ _layout_y_axis l, _laxis_title_style $ _layout_y_axis l), lge_raxis = (rAxis,"", def), lge_margin = _layout_margin l } where xvals = [ x | p <- _layout_plots l, x <- fst $ _plot_all_points p] yvals = [ y | p <- _layout_plots l, y <- snd $ _plot_all_points p] bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layout_x_axis _layout_bottom_axis_visibility) xvals tAxis = mkAxis E_Top (overrideAxisVisibility l _layout_x_axis _layout_top_axis_visibility ) xvals lAxis = mkAxis E_Left (overrideAxisVisibility l _layout_y_axis _layout_left_axis_visibility ) yvals rAxis = mkAxis E_Right (overrideAxisVisibility l _layout_y_axis _layout_right_axis_visibility ) yvals axes = (bAxis,lAxis,tAxis,rAxis) plotsToRenderable lxy = Renderable { minsize = return (0,0), render = renderPlots lxy } -- | Render the plots of a 'Layout' to a plot area of given size. renderPlots :: Layout x y -> RectSize -> BackendProgram (PickFn (LayoutPick x y y)) renderPlots lxy sz@(w,h) = do unless (_layout_grid_last lxy) (renderGrids sz axes) withClipRegion (Rect (Point 0 0) (Point w h)) $ mapM_ rPlot (_layout_plots lxy) when (_layout_grid_last lxy) (renderGrids sz axes) return pickfn where rPlot = renderSinglePlot sz bAxis lAxis xr = (0, w) yr = (h, 0) pickfn :: PickFn (LayoutPick x y y) pickfn (Point x y) = do -- Maybe monad xat <- mxat yat <- myat return (LayoutPick_PlotArea (mapx xat x) (mapy yat y) (mapy yat y)) where mxat = case (bAxis,tAxis) of (Just at,_) -> Just at (_,Just at) -> Just at (Nothing,Nothing) -> Nothing myat = case (lAxis,rAxis) of (Just at,_) -> Just at (_,Just at) -> Just at (Nothing,Nothing) -> Nothing mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr) mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr) -- | Empty 'Layout' without title and plots. The background is white and -- the grid is drawn beneath all plots. There will be a legend. The top -- and right axis will not be visible. instance (PlotValue x, PlotValue y) => Default (Layout x y) where def = Layout { _layout_background = solidFillStyle $ opaque white , _layout_plot_background = Nothing , _layout_title = "" , _layout_title_style = def { _font_size = 15 , _font_weight = FontWeightBold } , _layout_x_axis = def , _layout_top_axis_visibility = def { _axis_show_line = False , _axis_show_ticks = False , _axis_show_labels = False } , _layout_bottom_axis_visibility = def , _layout_y_axis = def , _layout_left_axis_visibility = def , _layout_right_axis_visibility = def { _axis_show_line = False , _axis_show_ticks = False , _axis_show_labels = False } , _layout_margin = 10 , _layout_plots = [] , _layout_legend = Just def , _layout_grid_last = False } ---------------------------------------------------------------------- -- | A LayoutLR value is a single plot area, with an x axis and -- independent left and right y axes, with a title at the top; -- legend at the bottom. It's parametrized by the types of values -- to be plotted on the x and two y axes. data LayoutLR x y1 y2 = LayoutLR { _layoutlr_background :: FillStyle -- ^ How to fill the background of everything. , _layoutlr_plot_background :: Maybe FillStyle -- ^ How to fill the background of the plot, -- if different from the overall background. , _layoutlr_title :: String -- ^ Title to display above the chart. , _layoutlr_title_style :: FontStyle -- ^ Font style to use for the title. , _layoutlr_x_axis :: LayoutAxis x -- ^ Rules to generate the x axis. , _layoutlr_top_axis_visibility :: AxisVisibility -- ^ Visibility options for the top axis. , _layoutlr_bottom_axis_visibility :: AxisVisibility -- ^ Visibility options for the bottom axis. , _layoutlr_left_axis :: LayoutAxis y1 -- ^ Rules to generate the left y axis. , _layoutlr_left_axis_visibility :: AxisVisibility -- ^ Visibility options for the left axis. , _layoutlr_right_axis :: LayoutAxis y2 -- ^ Rules to generate the right y axis. , _layoutlr_right_axis_visibility :: AxisVisibility -- ^ Visibility options for the right axis. , _layoutlr_plots :: [Either (Plot x y1) (Plot x y2)] -- ^ The data sets to plot in the chart. -- 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) layoutLRToGrid :: forall x yl yr . (Ord x, Ord yl, Ord yr) => LayoutLR x yl yr -> Grid (Renderable (LayoutPick x yl yr)) layoutLRToGrid l = grid where grid = titleToRenderable lm (_layoutlr_title_style l) (_layoutlr_title l) `wideAbove` addMarginsToGrid (lm,lm,lm,lm) (layoutLRPlotAreaToGrid l) `aboveWide` renderLegendLR l (getLegendItemsLR l) lm = _layoutlr_margin l getLayoutLRXVals :: LayoutLR x yl yr -> [x] getLayoutLRXVals l = concatMap deEither $ _layoutlr_plots l where deEither :: Either (Plot x yl) (Plot x yr) -> [x] deEither (Left x) = fst $ _plot_all_points x deEither (Right x) = fst $ _plot_all_points x -- | Extract all 'LegendItem's from the plots of a 'LayoutLR'. -- Left and right plot legend items are still separated. getLegendItemsLR :: LayoutLR x yl yr -> ([LegendItem],[LegendItem]) getLegendItemsLR l = ( concat [ _plot_legend p | (Left p ) <- _layoutlr_plots l ], concat [ _plot_legend p | (Right p) <- _layoutlr_plots l ] ) -- | Render the given 'LegendItem's for a 'LayoutLR'. renderLegendLR :: LayoutLR x yl yr -> ([LegendItem],[LegendItem]) -> Renderable (LayoutPick x yl yr) renderLegendLR l (lefts,rights) = gridToRenderable g where g = besideN [ tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) lefts , weights (1,1) $ tval emptyRenderable , tval $ mkLegend (_layoutlr_legend l) (_layoutlr_margin l) rights ] -- lm = _layoutlr_margin l layoutLRPlotAreaToGrid :: forall x yl yr. (Ord x, Ord yl, Ord yr) => LayoutLR x yl yr -> Grid (Renderable (LayoutPick x yl yr)) layoutLRPlotAreaToGrid l = buildGrid LayoutGridElements{ lge_plots = mfill (_layoutlr_plot_background l) $ plotsToRenderable l, lge_taxis = (tAxis,_laxis_title $ _layoutlr_x_axis l, _laxis_title_style $ _layoutlr_x_axis l), lge_baxis = (bAxis,_laxis_title $ _layoutlr_x_axis l, _laxis_title_style $ _layoutlr_x_axis l), lge_laxis = (lAxis,_laxis_title $ _layoutlr_left_axis l, _laxis_title_style $ _layoutlr_left_axis l), lge_raxis = (rAxis,_laxis_title $ _layoutlr_right_axis l, _laxis_title_style $ _layoutlr_right_axis l), lge_margin = _layoutlr_margin l } where xvals = [ x | (Left p) <- _layoutlr_plots l, x <- fst $ _plot_all_points p] ++ [ x | (Right p) <- _layoutlr_plots l, x <- fst $ _plot_all_points p] yvalsL = [ y | (Left p) <- _layoutlr_plots l, y <- snd $ _plot_all_points p] yvalsR = [ y | (Right p) <- _layoutlr_plots l, y <- snd $ _plot_all_points p] bAxis = mkAxis E_Bottom (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_bottom_axis_visibility) xvals tAxis = mkAxis E_Top (overrideAxisVisibility l _layoutlr_x_axis _layoutlr_top_axis_visibility ) xvals lAxis = mkAxis E_Left (overrideAxisVisibility l _layoutlr_left_axis _layoutlr_left_axis_visibility ) yvalsL rAxis = mkAxis E_Right (overrideAxisVisibility l _layoutlr_right_axis _layoutlr_right_axis_visibility) yvalsR axes = (bAxis,lAxis,tAxis,rAxis) plotsToRenderable llr = Renderable { minsize = return (0,0), render = renderPlots llr } renderPlots :: LayoutLR x yl yr -> RectSize -> BackendProgram (PickFn (LayoutPick x yl yr)) renderPlots llr sz@(w,h) = do unless (_layoutlr_grid_last llr) (renderGrids sz axes) withClipRegion (Rect (Point 0 0) (Point w h)) $ mapM_ rPlot (_layoutlr_plots llr) when (_layoutlr_grid_last llr) (renderGrids sz axes) return pickfn where rPlot (Left p) = renderSinglePlot sz bAxis lAxis p rPlot (Right p) = renderSinglePlot sz bAxis rAxis p xr = (0, w) yr = (h, 0) pickfn (Point x y) = do -- Maybe monad xat <- mxat (yatL,yatR) <- myats return (LayoutPick_PlotArea (mapx xat x) (mapy yatL y) (mapy yatR y)) where mxat = case (bAxis,tAxis) of (Just at,_) -> Just at (_,Just at) -> Just at (Nothing,Nothing) -> Nothing myats = case (lAxis,rAxis) of (Just at1,Just at2) -> Just (at1,at2) (_,_) -> Nothing mapx (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev xr) mapy (AxisT _ _ rev ad) = _axis_tropweiv ad (optPairReverse rev yr) ---------------------------------------------------------------------- -- | A layout with its y type hidden, so that it can be stacked -- with other layouts with differing y axis, but the same x axis. -- See 'StackedLayouts'. data StackedLayout x = forall y . (Ord y) => StackedLayout (Layout x y) -- ^ A 'Layout' to stack. | forall yl yr . (Ord yl, Ord yr) => StackedLayoutLR (LayoutLR x yl yr) -- ^ A 'LayoutLR' to stack. -- | A container for a set of vertically 'StackedLayout's. -- The x axis of the different layouts will be aligned. data StackedLayouts x = StackedLayouts { _slayouts_layouts :: [StackedLayout x] -- ^ The stacked layouts from top (first element) to bottom (last element). , _slayouts_compress_legend :: Bool -- ^ If the different legends shall be combined in one legend at the bottom. } -- | A empty 'StackedLayout' with compressions applied. instance Default (StackedLayouts x) where def = StackedLayouts [] True instance Ord x => ToRenderable (StackedLayouts x) where toRenderable = renderStackedLayouts -- | Render several layouts with the same x-axis type and range, -- vertically stacked so that their origins and x-values are aligned. -- -- The legends from all the charts may be optionally combined, and shown -- once on the bottom chart. See 'StackedLayouts' for further information. renderStackedLayouts :: forall x. (Ord x) => StackedLayouts x -> Renderable () renderStackedLayouts (StackedLayouts{_slayouts_layouts=[]}) = emptyRenderable renderStackedLayouts slp@(StackedLayouts{_slayouts_layouts=sls@(sl1:_)}) = gridToRenderable g where g = fullOverlayUnder (fillBackground bg emptyRenderable) $ foldr (above.mkGrid) nullt (zip sls [0,1..]) mkGrid :: (StackedLayout x, Int) -> Grid (Renderable ()) mkGrid (sl, i) = titleR `wideAbove` addMarginsToGrid (lm,lm,lm,lm) (mkPlotArea usedAxis) `aboveWide` (if showLegend then legendR else emptyRenderable) where titleR = case sl of StackedLayout l -> noPickFn $ titleToRenderable (_layout_margin l) (_layout_title_style l) (_layout_title l) StackedLayoutLR l -> noPickFn $ titleToRenderable (_layoutlr_margin l) (_layoutlr_title_style l) (_layoutlr_title l) legendR = case sl of StackedLayout l -> noPickFn $ renderLegend l $ fst legenditems StackedLayoutLR l -> noPickFn $ renderLegendLR l legenditems legenditems = case (_slayouts_compress_legend slp,isBottomPlot) of (False,_) -> case sl of StackedLayout l -> (getLegendItems l, []) StackedLayoutLR l -> getLegendItemsLR l (True,True) -> allLegendItems (True,False) -> ([],[]) mkPlotArea :: LayoutAxis x -> Grid (Renderable ()) mkPlotArea axis = case sl of StackedLayout l -> fmap noPickFn $ layoutPlotAreaToGrid $ l { _layout_x_axis = axis } StackedLayoutLR l -> fmap noPickFn $ layoutLRPlotAreaToGrid $ l { _layoutlr_x_axis = axis } showLegend = not (null (fst legenditems)) || not (null (snd legenditems)) isBottomPlot = i == length sls - 1 lm = case sl of StackedLayout l -> _layout_margin l StackedLayoutLR l -> _layoutlr_margin l xAxis :: LayoutAxis x xAxis = case sl of StackedLayout l -> _layout_x_axis l StackedLayoutLR l -> _layoutlr_x_axis l usedAxis :: LayoutAxis x usedAxis = xAxis { _laxis_generate = const (_laxis_generate xAxis all_xvals) } bg = case sl1 of StackedLayout l -> _layout_background l StackedLayoutLR l -> _layoutlr_background l getXVals :: StackedLayout x -> [x] getXVals (StackedLayout l) = getLayoutXVals l getXVals (StackedLayoutLR l) = getLayoutLRXVals l all_xvals = concatMap getXVals sls allLegendItems = (concatMap (fst.legendItems) sls, concatMap (snd.legendItems) sls) legendItems :: StackedLayout x -> ([LegendItem], [LegendItem]) legendItems (StackedLayout l) = (getLegendItems l, []) legendItems (StackedLayoutLR l) = getLegendItemsLR l noPickFn :: Renderable a -> Renderable () noPickFn = mapPickFn (const ()) ---------------------------------------------------------------------- addMarginsToGrid :: (Double,Double,Double,Double) -> Grid (Renderable a) -> Grid (Renderable a) addMarginsToGrid (t,b,l,r) g = aboveN [ besideN [er, ts, er], besideN [ls, g, rs], besideN [er, bs, er] ] where er = empty ts = tval $ spacer (0,t) ls = tval $ spacer (l,0) bs = tval $ spacer (0,b) rs = tval $ spacer (r,0) titleToRenderable :: Double -> FontStyle -> String -> Renderable (LayoutPick x yl yr) titleToRenderable _ _ "" = emptyRenderable titleToRenderable lm fs s = addMargins (lm/2,0,0,0) (mapPickFn LayoutPick_Title title) where title = label fs HTA_Centre VTA_Centre s mkLegend :: Maybe LegendStyle -> Double -> [LegendItem] -> Renderable (LayoutPick x yl yr) mkLegend mls lm vals = case mls of Nothing -> emptyRenderable Just ls -> case filter ((/="").fst) vals of [] -> emptyRenderable ; lvs -> addMargins (0,lm,lm,lm) $ mapPickFn LayoutPick_Legend $ legendToRenderable (Legend ls lvs) data LayoutGridElements x yl yr = LayoutGridElements { lge_plots :: Renderable (LayoutPick x yl yr), lge_taxis :: (Maybe (AxisT x),String,FontStyle), lge_baxis :: (Maybe (AxisT x),String,FontStyle), lge_laxis :: (Maybe (AxisT yl),String,FontStyle), lge_raxis :: (Maybe (AxisT yr),String,FontStyle), lge_margin :: Double } buildGrid :: (Ord x, Ord yl, Ord yr) => LayoutGridElements x yl yr -> Grid (Renderable (LayoutPick x yl yr)) buildGrid lge = layer2 `overlay` layer1 where layer1 = aboveN [ besideN [er, er, er, er ] , besideN [er, er, er, weights (1,1) plots ] ] layer2 = aboveN [ besideN [er, er, tl, taxis, tr, er, er ] , besideN [ltitle, lam, laxis, er, raxis, ram, rtitle ] , besideN [er, er, bl, baxis, br, er, er ] , besideN [er, er, er, btitle, er, er, er ] ] er = tval emptyRenderable plots = tval $ lge_plots lge (tdata,_,_) = lge_taxis lge (bdata,blbl,bstyle) = lge_baxis lge (ldata,llbl,lstyle) = lge_laxis lge (rdata,rlbl,rstyle) = lge_raxis lge -- (ttitle,_) = mktitle HTA_Centre VTA_Bottom 0 tlbl tstyle LayoutPick_XTopAxisTitle (btitle,_) = mktitle HTA_Centre VTA_Top 0 blbl bstyle LayoutPick_XBottomAxisTitle (ltitle,lam) = mktitle HTA_Right VTA_Centre 270 llbl lstyle LayoutPick_YLeftAxisTitle (rtitle,ram) = mktitle HTA_Left VTA_Centre 270 rlbl rstyle LayoutPick_YRightAxisTitle baxis = tval $ maybe emptyRenderable (mapPickFn LayoutPick_XBottomAxis . axisToRenderable) bdata taxis = tval $ maybe emptyRenderable (mapPickFn LayoutPick_XTopAxis . axisToRenderable) tdata laxis = tval $ maybe emptyRenderable (mapPickFn LayoutPick_YLeftAxis . axisToRenderable) ldata raxis = tval $ maybe emptyRenderable (mapPickFn LayoutPick_YRightAxis . axisToRenderable) rdata tl = tval $ axesSpacer fst tdata fst ldata bl = tval $ axesSpacer fst bdata snd ldata tr = tval $ axesSpacer snd tdata fst rdata br = tval $ axesSpacer snd bdata snd rdata mktitle :: HTextAnchor -> VTextAnchor -> Double -> String -> FontStyle -> (String -> LayoutPick x yl yr) -> ( Grid (Renderable (LayoutPick x yl yr)) , Grid (Renderable (LayoutPick x yl yr)) ) mktitle ha va rot lbl style pf = if lbl == "" then (er,er) else (labelG,gapG) where labelG = tval $ mapPickFn pf $ rlabel style ha va rot lbl gapG = tval $ spacer (lge_margin lge,0) -- | Render the grids of the given axis to a plot area of given size. renderGrids :: RectSize -> (Maybe (AxisT x), Maybe (AxisT yl), Maybe (AxisT x), Maybe (AxisT yr)) -> BackendProgram () renderGrids sz (bAxis, lAxis, tAxis, rAxis) = do maybeM () (renderAxisGrid sz) tAxis maybeM () (renderAxisGrid sz) bAxis maybeM () (renderAxisGrid sz) lAxis maybeM () (renderAxisGrid sz) rAxis -- | Swap the contents of the pair depending on the flag. optPairReverse :: Bool -> (a,a) -> (a,a) optPairReverse rev (a,b) = if rev then (b,a) else (a,b) -- | Render a single set of plot data onto a plot area of given size using -- the given x and y axis. renderSinglePlot :: RectSize -> Maybe (AxisT x) -> Maybe (AxisT y) -> Plot x y -> BackendProgram () renderSinglePlot (w, h) (Just (AxisT _ _ xrev xaxis)) (Just (AxisT _ _ yrev yaxis)) p = let xr = optPairReverse xrev (0, w) yr = optPairReverse yrev (h, 0) -- yrange = if yrev then (0, h) else (h, 0) pmfn (x,y) = Point (mapv xr (_axis_viewport xaxis xr) x) (mapv yr (_axis_viewport yaxis yr) y) mapv lims _ LMin = fst lims mapv lims _ LMax = snd lims mapv _ f (LValue v) = f v in _plot_render p pmfn renderSinglePlot _ _ _ _ = return () axesSpacer :: (Ord x, Ord y) => ((Double, Double) -> Double) -> Maybe (AxisT x) -> ((Double, Double) -> Double) -> Maybe (AxisT y) -> Renderable a axesSpacer f1 a1 f2 a2 = embedRenderable $ do oh1 <- maybeM (0,0) axisOverhang a1 oh2 <- maybeM (0,0) axisOverhang a2 return (spacer (f1 oh1, f2 oh2)) -- | Construct a axis for the given edge using the attributes -- from a 'LayoutAxis' the given values. mkAxis :: RectEdge -> LayoutAxis z -> [z] -> Maybe (AxisT z) mkAxis edge laxis vals = case axisVisible of False -> Nothing True -> Just $ AxisT edge style rev adata where style = _laxis_style laxis rev = _laxis_reverse laxis adata = _laxis_override laxis (_laxis_generate laxis vals) vis = _axis_visibility adata axisVisible = _axis_show_labels vis || _axis_show_line vis || _axis_show_ticks vis -- | Override the visibility of a selected axis with the selected 'AxisVisibility'. overrideAxisVisibility :: layout -> (layout -> LayoutAxis z) -> (layout -> AxisVisibility) -> LayoutAxis z overrideAxisVisibility ly selAxis selVis = let vis = selVis ly in (selAxis ly) { _laxis_override = (\ad -> ad { _axis_visibility = vis }) . _laxis_override (selAxis ly) } mfill :: Maybe FillStyle -> Renderable a -> Renderable a mfill Nothing = id mfill (Just fs) = fillBackground fs -- | Empty 'LayoutLR' without title and plots. The background is white and -- the grid is drawn beneath all plots. There will be a legend. The top -- axis will not be visible. instance (PlotValue x, PlotValue y1, PlotValue y2) => Default (LayoutLR x y1 y2) where def = LayoutLR { _layoutlr_background = solidFillStyle $ opaque white , _layoutlr_plot_background = Nothing , _layoutlr_title = "" , _layoutlr_title_style = def { _font_size = 15 , _font_weight = FontWeightBold } , _layoutlr_x_axis = def , _layoutlr_top_axis_visibility = def { _axis_show_line = False , _axis_show_ticks = False , _axis_show_labels = False } , _layoutlr_bottom_axis_visibility = def , _layoutlr_left_axis = def , _layoutlr_left_axis_visibility = def , _layoutlr_right_axis = def , _layoutlr_right_axis_visibility = def , _layoutlr_plots = [] , _layoutlr_legend = Just def , _layoutlr_margin = 10 , _layoutlr_grid_last = False } instance PlotValue t => Default (LayoutAxis t) where def = LayoutAxis { _laxis_title_style = def { _font_size=10 } , _laxis_title = "" , _laxis_style = def , _laxis_generate = autoAxis , _laxis_override = id , _laxis_reverse = False } ---------------------------------------------------------------------- -- Template haskell to derive an instance of Data.Accessor.Accessor -- for each field. $( makeLenses ''Layout ) $( makeLenses ''LayoutLR ) $( makeLenses ''LayoutAxis ) $( makeLenses ''StackedLayouts ) -- | Setter to update all axis styles on a `Layout` layout_axes_styles :: Setter' (Layout x y) AxisStyle layout_axes_styles = sets $ \af -> (layout_x_axis . laxis_style %~ af) . (layout_y_axis . laxis_style %~ af) -- | Setter to update all the axes title styles on a `Layout` layout_axes_title_styles :: Setter' (Layout x y) FontStyle layout_axes_title_styles = sets $ \af -> (layout_x_axis . laxis_title_style %~ af) . (layout_y_axis . laxis_title_style %~ af) -- | Setter to update all the font styles on a `Layout` layout_all_font_styles :: Setter' (Layout x y) FontStyle layout_all_font_styles = sets $ \af -> (layout_axes_title_styles %~ af) . (layout_x_axis . laxis_style . axis_label_style %~ af) . (layout_y_axis . laxis_style . axis_label_style %~ af) . (layout_legend . _Just . legend_label_style %~ af) . (layout_title_style %~ af) -- | Setter to update the foreground color of core chart elements on a `Layout` layout_foreground :: Setter' (Layout x y) (AlphaColour Double) layout_foreground = sets $ \af -> (layout_all_font_styles . font_color %~ af) . (layout_axes_styles . axis_line_style . line_color %~ af) -- | Setter to update all axis styles on a `LayoutLR` layoutlr_axes_styles :: Setter' (LayoutLR x y1 y2) AxisStyle layoutlr_axes_styles = sets $ \af -> (layoutlr_x_axis . laxis_style %~ af) . (layoutlr_left_axis . laxis_style %~ af) . (layoutlr_right_axis . laxis_style %~ af) -- | Setter to update all the axes title styles on a `LayoutLR` layoutlr_axes_title_styles :: Setter' (LayoutLR x y1 y2) FontStyle layoutlr_axes_title_styles = sets $ \af -> (layoutlr_x_axis . laxis_title_style %~ af) . (layoutlr_left_axis . laxis_title_style %~ af) . (layoutlr_right_axis . laxis_title_style %~ af) -- | Setter to update all the font styles on a `LayoutLR` layoutlr_all_font_styles :: Setter' (LayoutLR x y1 y2) FontStyle layoutlr_all_font_styles = sets $ \af -> (layoutlr_axes_title_styles %~ af) . (layoutlr_x_axis . laxis_style . axis_label_style %~ af) . (layoutlr_left_axis . laxis_style . axis_label_style %~ af) . (layoutlr_right_axis . laxis_style . axis_label_style %~ af) . (layoutlr_legend . _Just . legend_label_style %~ af) . (layoutlr_title_style %~ af) -- | Setter to update the foreground color of core chart elements on a `LayoutLR` layoutlr_foreground :: Setter' (LayoutLR x y1 y2) (AlphaColour Double) layoutlr_foreground = sets $ \af -> (layoutlr_all_font_styles . font_color %~ af) . (layoutlr_axes_styles . axis_line_style . line_color %~ af)