module Graphics.Rendering.Chart.Layout(
Layout1(..),
LayoutAxis(..),
MAxisFn,
defaultLayout1,
mAxis,
noAxis,
updateAllAxesStyles,
updateXAxesData,
updateYAxesData,
setForeground,
laxis_title_style,
laxis_title,
laxis_style,
laxis_data,
laxis_reverse,
layout1_background,
layout1_title,
layout1_title_style,
layout1_left_axis,
layout1_right_axis,
layout1_top_axis,
layout1_bottom_axis,
layout1_margin,
layout1_plots,
layout1_legend,
layout1_grid_last
) where
import qualified Graphics.Rendering.Cairo as C
import Graphics.Rendering.Chart.Axis
import Graphics.Rendering.Chart.Types
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.Monad.Reader (local)
import Data.Accessor.Template
import Data.Accessor
type MAxisFn t = [t] -> Maybe (AxisData t)
data LayoutAxis x = LayoutAxis {
laxis_title_style_ :: CairoFontStyle,
laxis_title_ :: String,
laxis_style_ :: AxisStyle,
laxis_data_ :: MAxisFn x,
laxis_reverse_ :: Bool
}
data Layout1 x y = Layout1 {
layout1_background_ :: CairoFillStyle,
layout1_title_ :: String,
layout1_title_style_ :: CairoFontStyle,
layout1_bottom_axis_ :: LayoutAxis x,
layout1_top_axis_ :: LayoutAxis x,
layout1_left_axis_ :: LayoutAxis y,
layout1_right_axis_ :: LayoutAxis y,
layout1_margin_ :: Double,
layout1_plots_ :: [(String,Either (Plot x y) (Plot x y))],
layout1_legend_ :: Maybe(LegendStyle),
layout1_grid_last_ :: Bool
}
data Layout1Pick x y = L1P_Legend String
| L1P_PlotArea x y y
| L1P_BottomAxis x
| L1P_TopAxis x
| L1P_LeftAxis y
| L1P_RightAxis y
instance (Ord x, Ord y) => ToRenderable (Layout1 x y) where
toRenderable = setPickFn nullPickFn.layout1ToRenderable
layout1ToRenderable :: (Ord x, Ord y) => Layout1 x y -> Renderable (Layout1Pick x y)
layout1ToRenderable l =
fillBackground (layout1_background_ l) (
gridToRenderable $ aboveN [
tval $ addMargins (lm/2,0,0,0) title,
weights (1,1) $ tval $ addMargins (lm,lm,lm,lm) plotArea,
tval $ legends
] )
where
title = label (layout1_title_style_ l) HTA_Centre VTA_Centre (layout1_title_ l)
plotArea = gridToRenderable (layer2 `overlay` layer1)
layer1 = aboveN [
besideN [er, er, er ],
besideN [er, er, er ],
besideN [er, er, weights (1,1) plots ]
]
layer2 = aboveN [
besideN [er, er, ttitle, er, er ],
besideN [er, tl, taxis, tr, er ],
besideN [ltitle, laxis, er, raxis, rtitle ],
besideN [er, bl, baxis, br, er ],
besideN [er, er, btitle, er, er ]
]
ttitle = atitle HTA_Centre VTA_Bottom 0 layout1_top_axis_
btitle = atitle HTA_Centre VTA_Top 0 layout1_bottom_axis_
ltitle = atitle HTA_Right VTA_Centre 90 layout1_left_axis_
rtitle = atitle HTA_Left VTA_Centre 90 layout1_right_axis_
er = tval $ emptyRenderable
atitle ha va rot af = if ttext == "" then er else tval $ rlabel tstyle ha va rot ttext
where
tstyle = laxis_title_style_ (af l)
ttext = laxis_title_ (af l)
plots = tval $ plotsToRenderable l
(ba,la,ta,ra) = getAxes l
baxis = tval $ maybe emptyRenderable (mapPickFn L1P_BottomAxis . axisToRenderable) ba
taxis = tval $ maybe emptyRenderable (mapPickFn L1P_TopAxis . axisToRenderable) ta
laxis = tval $ maybe emptyRenderable (mapPickFn L1P_LeftAxis . axisToRenderable) la
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
legends = gridToRenderable (besideN [ tval $ mkLegend lefts,
weights (1,1) $ tval $ emptyRenderable,
tval $ mkLegend rights ])
lefts = [ (s,p) | (s,Left p) <- (layout1_plots_ l) ]
rights = [ (s,p) | (s,Right p) <- (layout1_plots_ l) ]
mkLegend plots = case (layout1_legend_ l) of
Nothing -> emptyRenderable
(Just ls) -> case plots of
[] -> emptyRenderable
ps -> addMargins (0,lm,lm,lm)
(mapPickFn L1P_Legend $ legendToRenderable (Legend True ls ps))
lm = layout1_margin_ l
plotsToRenderable :: Layout1 x y -> Renderable (Layout1Pick x y)
plotsToRenderable l = Renderable {
minsize=return (0,0),
render= renderPlots l
}
renderPlots :: Layout1 x y -> RectSize -> CRender (PickFn (Layout1Pick x y))
renderPlots l sz@(w,h) = preserveCState $ do
setClipRegion (Point 0 0) (Point w h)
when (not (layout1_grid_last_ l)) renderGrids
local (const vectorEnv) $ do
mapM_ rPlot (layout1_plots_ l)
when (layout1_grid_last_ l) renderGrids
return nullPickFn
where
(bAxis,lAxis,tAxis,rAxis) = getAxes l
rPlot (_,Left p) = rPlot1 bAxis lAxis p
rPlot (_,Right p) = rPlot1 bAxis rAxis p
rPlot1 (Just (AxisT _ xs xrev xaxis)) (Just (AxisT _ ys yrev yaxis)) p =
let xrange = if xrev then (w, 0) else (0,w)
yrange = if yrev then (0, h) else (h, 0)
pmfn (x,y) = Point (axis_viewport_ xaxis xrange x) (axis_viewport_ yaxis yrange y)
in plot_render_ p pmfn
rPlot1 _ _ _ = return ()
renderGrids = do
maybeM () (renderAxisGrid sz) tAxis
maybeM () (renderAxisGrid sz) bAxis
maybeM () (renderAxisGrid sz) lAxis
maybeM () (renderAxisGrid sz) rAxis
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)
where
(xvals0,xvals1,yvals0,yvals1) = allPlottedValues (layout1_plots_ l)
xvals = xvals0 ++ xvals1
(yvals0',yrev0) = if null yvals0 then (yvals0++yvals1, layout1_right_axis_)
else (yvals0, layout1_left_axis_)
(yvals1',yrev1) = if null yvals1 then (yvals0++yvals1, layout1_left_axis_)
else (yvals1, layout1_right_axis_)
bAxis = mkAxis E_Bottom layout1_bottom_axis_ layout1_bottom_axis_ xvals
tAxis = mkAxis E_Top layout1_top_axis_ layout1_bottom_axis_ xvals
lAxis = mkAxis E_Left layout1_left_axis_ yrev0 yvals0'
rAxis = mkAxis E_Right layout1_right_axis_ yrev1 yvals1'
mkAxis t axisf revf vals = do
adata <- laxis_data_ (axisf l) vals
return (AxisT t (laxis_style_ (axisf l)) (laxis_reverse_ (revf l)) adata)
allPlottedValues :: [(String,Either (Plot x y) (Plot x' y'))] -> ( [x], [x'], [y], [y'] )
allPlottedValues plots = (xvals0,xvals1,yvals0,yvals1)
where
xvals0 = [ x | (_, Left p) <- plots, (x,_) <- plot_all_points_ p]
yvals0 = [ y | (_, Left p) <- plots, (_,y) <- plot_all_points_ p]
xvals1 = [ x | (_, Right p) <- plots, (x,_) <- plot_all_points_ p]
yvals1 = [ y | (_, Right p) <- plots, (_,y) <- plot_all_points_ p]
defaultLayout1 :: (PlotValue x,PlotValue y) => Layout1 x y
defaultLayout1 = Layout1 {
layout1_background_ = solidFillStyle white,
layout1_title_ = "",
layout1_title_style_ = defaultFontStyle{font_size_=15, font_weight_=C.FontWeightBold},
layout1_top_axis_ = defaultLayoutAxis,
layout1_bottom_axis_ = defaultLayoutAxis,
layout1_left_axis_ = defaultLayoutAxis,
layout1_right_axis_ = defaultLayoutAxis,
layout1_margin_ = 10,
layout1_plots_ = [],
layout1_legend_ = Just defaultLegendStyle,
layout1_grid_last_ = False
}
defaultLayoutAxis :: PlotValue t => LayoutAxis t
defaultLayoutAxis = LayoutAxis {
laxis_title_style_ = defaultFontStyle{font_size_=10},
laxis_title_ = "",
laxis_style_ = defaultAxisStyle,
laxis_data_ = mAxis autoAxis,
laxis_reverse_ = False
}
mAxis :: PlotValue t => AxisFn t -> MAxisFn t
mAxis axisfn [] = Nothing
mAxis axisfn ps = Just (axisfn ps)
noAxis :: PlotValue t => LayoutAxis t
noAxis = LayoutAxis {
laxis_title_style_ = defaultFontStyle{font_size_=10},
laxis_title_ = "",
laxis_style_ = defaultAxisStyle,
laxis_data_ = const Nothing,
laxis_reverse_ = False
}
$( deriveAccessors ''Layout1 )
$( deriveAccessors ''LayoutAxis )
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)
updateXAxesData :: (MAxisFn x -> MAxisFn x) -> Layout1 x y -> Layout1 x y
updateXAxesData uf = (layout1_top_axis .> laxis_data ^: uf) .
(layout1_bottom_axis .> laxis_data ^: uf)
updateYAxesData :: (MAxisFn y -> MAxisFn y) -> Layout1 x y -> Layout1 x y
updateYAxesData uf = (layout1_left_axis .> laxis_data ^: uf) .
(layout1_right_axis .> laxis_data ^: uf)
setForeground :: Color -> Layout1 x y -> Layout1 x y
setForeground 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))