{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Plots.Axis.Render
(
RenderAxis (..)
, r2AxisMain
, buildPlots
)where
import Data.Bool
import Data.Foldable as F
import Data.List (sort)
import Data.Typeable
import Diagrams.BoundingBox
import Diagrams.Prelude
import Diagrams.TwoD.Text
import Linear hiding (rotate, translation)
import Diagrams.Backend.CmdLine
import Diagrams.Coordinates.Polar
import Plots.Axis
import Plots.Axis.ColourBar
import Plots.Axis.Grid
import Plots.Axis.Labels
import Plots.Axis.Line
import Plots.Axis.Scale
import Plots.Axis.Ticks
import Plots.Axis.Title
import Plots.Legend
import Plots.Style
import Plots.Types
import Plots.Util
import Prelude
instance (TypeableFloat n,
Renderable (Path V2 n) b,
Mainable (QDiagram b V2 n Any))
=> Mainable (Axis b Polar n) where
type MainOpts (Axis b Polar n) = MainOpts (QDiagram b V2 n Any)
mainRender opts = mainRender opts . renderAxis
instance (TypeableFloat n,
Renderable (Path V2 n) b,
Mainable (QDiagram b V2 n Any))
=> Mainable (Axis b V2 n) where
type MainOpts (Axis b V2 n) = MainOpts (QDiagram b V2 n Any)
mainRender opts = mainRender opts . renderAxis
instance ToResult (Axis b v n) where
type Args (Axis b v n) = ()
type ResultOf (Axis b v n) = Axis b v n
toResult d _ = d
r2AxisMain
:: (Parseable (MainOpts (QDiagram b V2 Double Any)),
Mainable (Axis b V2 Double))
=> Axis b V2 Double
-> IO ()
r2AxisMain = mainWith
buildPlots :: BaseSpace c ~ v => Axis b c n -> [StyledPlot b v n]
buildPlots a = map (appEndo $ a ^. plotModifier)
$ zipWith styleDynamic (a ^.. axisStyles) (a ^. axisPlots)
class RenderAxis b v n where
renderAxis :: Axis b v n -> QDiagram b (BaseSpace v) n Any
instance (TypeableFloat n, Renderable (Path V2 n) b)
=> RenderAxis b V2 n where
renderAxis = renderR2Axis
renderR2Axis :: (TypeableFloat n, Renderable (Path V2 n) b)
=> Axis b V2 n -> QDiagram b V2 n Any
renderR2Axis a = frame 40
$ leg
<> ttl
<> cBar
<> plots
<> drawAxis ex ey LowerLabels
<> drawAxis ey ex LeftLabels
where
spec = AxisSpec xs t (a^.axes . column logScale) (a ^. axisColourMap)
plots = foldMap (renderStyledPlot spec) styledPlots
drawAxis ll ll2 = axisOnBasis origin xs (a^.axes.el ll) (a^.axes.column logScale) t ll ll2
(xs, tv, t') = calculateScaling (a^.axes.column axisScaling) (boundingBox styledPlots)
t = tv <> t'
bb = fromCorners (P . apply t $ fmap fst xs) (P . apply t $ fmap snd xs)
leg = drawLegend bb (styledPlotLegends styledPlots) (a ^. legend)
cBar = addColourBar bb (a^.colourBar) (a ^. axisColourMap) (a^.colourBarRange)
ttl = drawTitle bb (a^.title)
styledPlots = buildPlots a
data LabelPosition
= NoLabels
| LowerLabels
| LeftLabels
| RightLabels
| UpperLabels
deriving (Show, Eq, Typeable)
axisOnBasis
:: forall b v n. (v ~ V2, TypeableFloat n, HasLinearMap v, Metric v,
Renderable (Path V2 n) b, n ~ N (v n), v ~ V (v n), OrderedField n)
=> Point v n
-> v (n, n)
-> SingleAxis b v n
-> v LogScale
-> T2 n
-> E v
-> E v
-> LabelPosition
-> QDiagram b V2 n Any
axisOnBasis p bs a ls t e eO lp
| a ^. hidden = phantom axis
| otherwise = axis
where
axis = tickLabels <> axLabels <> ticks <> line <> grid
tStroke = stroke . transform t
axLabels
| null txt || lp == NoLabels || a ^. axisLabel . hidden
= mempty
| otherwise = (a ^. axisLabelTextFunction) txtAlign txt
# moveTo p'
# applyStyle (a ^. axisLabelStyle)
where
p' = p & ep e .~ x
& ep eO .~ y0
& coscale
& papply t
& ep eO +~ negate' labelGap
labelGap = a ^. axisLabelGap
txt = a ^. axisLabelText
x = case a ^. axisLabelPosition of
MiddleAxisLabel -> (x0 + x1) / 2
LowerAxisLabel -> x0
UpperAxisLabel -> x1
tickLabels
| lp == NoLabels || a ^. tickLabel . hidden = mempty
| otherwise = foldMap drawLabels (map snd $ take 1 ys)
# applyStyle (a ^. tickLabelStyle)
where
labelFun = a ^. tickLabelFunction
drawLabels y = foldMap f (labelFun (filter inRange majorTickXs) b)
where
f (x, l) = place dia p'
where
dia = view tickLabelTextFunction a txtAlign l
p' = p & ep e .~ x
& ep eO .~ y
& coscale
& papply t
& ep eO +~ negate' (a ^. tickLabelGap)
grid = majorLines <> minorLines
where
majorLines
| a ^. majorGridLines . hidden = mempty
| otherwise = foldMap mkGridLine majorGridXs'
# tStroke
# applyStyle (a ^. majorGridLinesStyle)
majorGridXs = view majorGridLinesFunction a majorTickXs b
majorGridXs' = map coscaleNum (filter inRange majorGridXs)
minorLines
| a ^. minorGridLines . hidden = mempty
| otherwise = foldMap mkGridLine minorGridXs'
# tStroke
# applyStyle (a ^. minorGridLinesStyle)
minorGridXs = view minorGridLinesFunction a minorTickXs b
minorGridXs' = map coscaleNum (filter inRange minorGridXs)
mkGridLine x = pathFromVertices [f y0, f y1]
where f y = over lensP ((el e .~ x) . (el eO .~ y)) p
ticks = foldMap drawTicks ys
drawTicks (pos,y) = maTicks <> miTicks
where
maTicks
| a ^. majorTicks . hidden = mempty
| otherwise = foldMap (positionTick majorTick) majorTickXs'
# stroke
# applyStyle (a ^. majorTicksStyle)
miTicks
| a ^. minorTicks . hidden = mempty
| otherwise = foldMap (positionTick minorTick) minorTickXs'
# stroke
# applyStyle (a ^. minorTicksStyle)
minorTick = someTick (a ^. minorTicksAlignment) (a ^. minorTicksLength)
majorTick = someTick (a ^. majorTicksAlignment) (a ^. majorTicksLength)
someTick tType d = pathFromVertices $
case tType of
AutoTick ->
case pos of
LowerAxis -> [origin & ep eO -~ d, origin]
MiddleAxis -> [origin & ep eO -~ d, origin & ep eO +~ d]
UpperAxis -> [origin, origin & ep eO +~ d]
TickSpec (fromRational -> aa) (fromRational -> bb) ->
case pos of
UpperAxis -> [origin & ep eO -~ d*bb, origin & ep eO +~ d*aa]
_ -> [origin & ep eO -~ d*aa, origin & ep eO +~ d*bb]
positionTick tick x = place tick p'
where
p' = over lensP ((el e .~ x) . (el eO .~ y)) p
# transform t
line
| a ^. axisLine . hidden = mempty
| otherwise = foldMap mkline (map snd ys)
# transform t
# stroke
# lineCap LineCapSquare
# applyStyle (a^.axisLineStyle)
where
mkline y = pathFromVertices
$ map (\x -> over lensP ((el e .~ x) . (el eO .~ y)) p) [x0, x1] :: Path v n
b@(x0,x1) = bs ^. el e :: (n, n)
coscale = ep e %~ coscaleNum
coscaleNum = scaleNum (bs ^. el e) (ls ^. el e)
yb@(y0,y1) = bs ^. el eO . if lp == UpperLabels
then swapped
else id
inRange x = x >= x0 && x <= x1
majorTickXs = sort $ view majorTicksFunction a b
majorTickXs' = map coscaleNum (filter inRange majorTickXs)
minorTickXs = sort $ view minorTicksFunction a majorTickXs b
minorTickXs' = map coscaleNum (filter inRange minorTickXs)
ys = getAxisLinePos yb lineType
lineType = a ^. axisLineType
txtAlign =
case lp of
LowerLabels -> BoxAlignedText 0.5 1
LeftLabels -> BoxAlignedText 1 0.5
RightLabels -> BoxAlignedText 0 0.5
UpperLabels -> BoxAlignedText 1 0
_ -> error "No labels"
negate' = if lp == UpperLabels || lp == RightLabels
then id
else negate
getAxisLinePos :: (Num n, Ord n) => (n, n) -> AxisLineType -> [(AxisPos, n)]
getAxisLinePos (a,b) aType = case aType of
BoxAxisLine -> [(LowerAxis, a), (UpperAxis, b)]
LeftAxisLine -> [(LowerAxis, a)]
MiddleAxisLine -> [(,) MiddleAxis $
if | a > 0 -> a
| b < 0 -> b
| otherwise -> 0]
RightAxisLine -> [(UpperAxis, b)]
NoAxisLine -> []
data AxisPos = LowerAxis | MiddleAxis | UpperAxis
ep :: E v -> Lens' (Point v x) x
ep (E l) = lensP . l
{-# INLINE ep #-}
instance (TypeableFloat n, Renderable (Path V2 n) b)
=> RenderAxis b Polar n where
renderAxis = renderPolarAxis
boundingRadiusR :: (InSpace V2 n a, Enveloped a) => Int -> a -> (n, n)
boundingRadiusR (max 3 -> n) e =
case appEnvelope (getEnvelope e) of
Nothing -> (0,0)
Just f ->
let thetas = map (@@rad) $ enumFromToN 0 tau n
vs = map angleV thetas
lowerBound = F.foldr (\v r -> max (f v) r) 0 vs
upperBound = lowerBound / cos (pi / fromIntegral n)
in (lowerBound, upperBound)
renderPolarAxis
:: (TypeableFloat n, Renderable (Path V2 n) b)
=> Axis b Polar n -> QDiagram b V2 n Any
renderPolarAxis a = frame 15
$ leg
<> plots
<> theAxis
where
r = snd $ boundingRadiusR 30 styledPlots
spec = AxisSpec xs t (pure LinearAxis) (a ^. axisColourMap)
plots = F.foldMap (renderStyledPlot spec) styledPlots
dataBB = fromCorners (mkP2 (-r) (-r)) (mkP2 r r)
(xs, tv, t') = calculateScaling (view _Wrapped $ a^.axes.column axisScaling) dataBB
t = tv <> t'
theAxis = drawPolarAxis spec (a ^. axes)
bb = fromCorners (P . apply t $ fmap fst xs) (P . apply t $ fmap snd xs)
leg = drawLegend bb (styledPlotLegends styledPlots) (a ^. legend)
styledPlots = map (appEndo $ a ^. plotModifier)
$ zipWith styleDynamic (a ^.. axisStyles) (a ^. axisPlots)
drawPolarAxis
:: forall b n. (Renderable (Path V2 n) b, TypeableFloat n)
=> AxisSpec V2 n -> Polar (SingleAxis b V2 n) -> QDiagram b V2 n Any
drawPolarAxis spec (Polar (V2 rA thetaA)) = fcA transparent $ rAx <> thetaAx where
r = spec ^. specBounds . _x . _2
t = spec ^. specTrans
s = avgScale t
rInRange x = x >= 0 && x <= r*1.000001
thetaInRange x = x >= 0 && x < tau
rAx
| rA ^. hidden = mempty
| otherwise = rAxLine <> rAxLabel <> rAxTicks <> rAxTickLabels <> rAxGridLines
rAxLine = line # whenever (rA ^. axisLine . hidden) phantom
where
line = (origin ~~ mkP2 r 0) # applyStyle (rA^.axisLineStyle)
# transform t
rAxLabel
| null rTxt || rA ^. axisLabel . hidden = mempty
| otherwise = view axisLabelTextFunction rA rLabelAlign rTxt
# translate rLabelPos
# applyStyle (rA ^. axisLabelStyle)
# fc black
rLabelPos = V2 (s*x) (- view axisLabelGap rA) where
x = case rA ^. axisLabelPosition of
MiddleAxisLabel -> r/2
LowerAxisLabel -> 0
UpperAxisLabel -> r
rTxt = rA ^. axisLabelText
rLabelAlign = BaselineText
majorTickRs = view majorTicksFunction rA (0,r)
majorTickRs' = map (*s) $ filter rInRange majorTickRs
minorTickRs = view minorTicksFunction rA majorTickRs (0,r)
minorTickRs' = map (*s) $ filter rInRange minorTickRs
rAxTicks = rAxMajorTicks <> rAxMinorTicks
rAxMajorTicks
| rA ^. majorTicks . hidden = mempty
| otherwise = F.foldMap (\x -> rAxMajorTick # translateX x) majorTickRs'
# applyStyle (rA ^. majorTicksStyle)
rAxMinorTicks
| rA ^. minorTicks . hidden = mempty
| otherwise = F.foldMap (\x -> rAxMinorTick # translateX x) minorTickRs'
# applyStyle (rA ^. minorTicksStyle)
rAxMajorTick = someTick (rA ^. majorTicksAlignment) (rA ^. majorTicksLength)
rAxMinorTick = someTick (rA ^. minorTicksAlignment) (rA ^. minorTicksLength)
someTick tType d = case tType of
TickSpec (fromRational -> aa) (fromRational -> bb)
-> mkP2 0 (-d*bb) ~~ mkP2 0 (d*aa)
AutoTick -> mkP2 0 (-d) ~~ mkP2 0 d
rAxGridLines
| otherwise = rMajorGridLines <> rMinorGridLines
majorGridRs = view majorGridLinesFunction rA majorTickRs (0,r)
majorGridRs' = map (*s) $ filter rInRange majorGridRs
rMajorGridLines :: QDiagram b V2 n Any
rMajorGridLines
| rA ^. majorGridLines . hidden = mempty
| otherwise = F.foldMap circle (filter (>0) majorGridRs')
# applyStyle (rA ^. majorGridLinesStyle)
minorGridRs = view minorGridLinesFunction rA minorTickRs (0,r)
minorGridRs' = map (*s) $ filter rInRange minorGridRs
rMinorGridLines :: QDiagram b V2 n Any
rMinorGridLines
| rA ^. minorGridLines . hidden = mempty
| otherwise = F.foldMap circle (filter (>0) minorGridRs')
# applyStyle (rA ^. minorGridLinesStyle)
rAxTickLabels :: QDiagram b V2 n Any
rAxTickLabels
| rA ^. tickLabel . hidden = mempty
| otherwise = F.foldMap rDrawTickLabel tickLabelRs
tickLabelRs :: [(n, String)]
tickLabelRs = view tickLabelFunction rA (filter rInRange majorTickRs) (0,r)
rDrawTickLabel :: (n,String) -> QDiagram b V2 n Any
rDrawTickLabel (x,label) =
view tickLabelTextFunction rA (BoxAlignedText 0.5 1) label
# translate (V2 (s*x) (- view axisLabelGap rA))
# applyStyle (rA ^. tickLabelStyle)
# fc black
thetaAx
| thetaA ^. hidden = mempty
| otherwise = thetaAxLine <> thetaAxLabel
<> thetaAxTicks <> thetaAxTickLabels <> thetaAxGridLines
theta = 2*pi
thetaAxLine = line # whenever (thetaA ^. axisLine . hidden) phantom
where
line = circle (s*r) # applyStyle (thetaA^.axisLineStyle)
thetaAxLabel
| null thetaTxt || thetaA ^. axisLabel . hidden = mempty
| otherwise = view axisLabelTextFunction thetaA thetaLabelAlign thetaTxt
# translate thetaLabelPos
# applyStyle (thetaA ^. axisLabelStyle)
# fc black
thetaLabelPos = view xy_ (mkPolar (s*r + view axisLabelGap thetaA) x) where
x = case thetaA ^. axisLabelPosition of
MiddleAxisLabel -> quarterTurn
LowerAxisLabel -> zero
UpperAxisLabel -> halfTurn
thetaTxt = thetaA ^. axisLabelText
thetaLabelAlign = BaselineText
majorTickThetas = view majorTicksFunction thetaA (0,theta)
majorTickThetas' = filter thetaInRange majorTickThetas
minorTickThetas = view minorTicksFunction thetaA majorTickThetas (0,theta)
minorTickThetas' = filter thetaInRange minorTickThetas
thetaAxTicks = thetaAxMajorTicks <> thetaAxMinorTicks
thetaAxMajorTicks
| thetaA ^. majorTicks . hidden = mempty
| otherwise = F.foldMap (\phi -> thetaAxMajorTick # translateX (s*r) # rotate (phi@@rad)) majorTickThetas'
# applyStyle (thetaA ^. majorTicksStyle)
thetaAxMinorTicks
| thetaA ^. minorTicks . hidden = mempty
| otherwise = F.foldMap (\phi -> thetaAxMinorTick # translateX (s*r) # rotate (phi@@rad)) minorTickThetas'
# applyStyle (thetaA ^. minorTicksStyle)
thetaAxMajorTick = someThetaTick (thetaA ^. majorTicksAlignment) (thetaA ^. majorTicksLength)
thetaAxMinorTick = someThetaTick (thetaA ^. minorTicksAlignment) (thetaA ^. minorTicksLength)
someThetaTick tType d = case tType of
TickSpec (fromRational -> aa) (fromRational -> bb)
-> mkP2 (-d*bb) 0 ~~ mkP2 (d*aa) 0
AutoTick -> mkP2 (-d) 0 ~~ mkP2 d 0
thetaAxGridLines
| otherwise = thetaMajorGridLines <> thetaMinorGridLines
majorGridThetas = view majorGridLinesFunction thetaA majorTickThetas (0,theta)
majorGridThetas' = filter thetaInRange majorGridThetas
thetaMajorGridLines :: QDiagram b V2 n Any
thetaMajorGridLines
| thetaA ^. majorGridLines . hidden = mempty
| otherwise = F.foldMap (\phi -> origin ~~ mkP2 r 0 # rotate (phi@@rad)) majorGridThetas'
# transform t
# applyStyle (thetaA ^. majorGridLinesStyle)
minorGridThetas = view minorGridLinesFunction thetaA minorTickThetas (0,theta)
minorGridThetas' = filter thetaInRange minorGridThetas
thetaMinorGridLines :: QDiagram b V2 n Any
thetaMinorGridLines
| thetaA ^. minorGridLines . hidden = mempty
| otherwise = F.foldMap (\phi -> origin ~~ mkP2 r 0 # rotate (phi@@rad)) minorGridThetas'
# transform t
# applyStyle (thetaA ^. minorGridLinesStyle)
thetaAxTickLabels :: QDiagram b V2 n Any
thetaAxTickLabels
| thetaA ^. tickLabel . hidden = mempty
| otherwise = F.foldMap thetaDrawTickLabel tickLabelThetas
tickLabelThetas :: [(n, String)]
tickLabelThetas = view tickLabelFunction thetaA majorTickThetas' (0,theta)
thetaDrawTickLabel :: (n, String) -> QDiagram b V2 n Any
thetaDrawTickLabel (x,label) =
view tickLabelTextFunction thetaA a label
# translate v
# applyStyle (thetaA ^. tickLabelStyle)
# fc black
where v = mkPolar (s*r + view axisLabelGap thetaA) (x@@rad) ^. xy_
a = BoxAlignedText 0.5 0.5