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