{-# LANGUAGE OverloadedStrings, DeriveFunctor, DeriveGeneric #-} module Graphics.Rendering.Plot.Light.Internal ( -- * Frame Frame(..), mkFrame, unitFrame, mkFrameOrigin, frameToFrame, frameToFrameValue, frameFromPoints, frameFromFigData, xmin,xmax,ymin,ymax, width, height, -- * FigureData FigureData(..), figFWidth, figFHeight -- * Point , Point(..), mkPoint, origin -- * LabeledPoint , LabeledPoint(..), mkLabeledPoint, labelPoint, mapLabel, Axis(..), axes, meshGrid, subdivSegment, -- * SVG elements svgHeader, toPlot, -- ** Rectangle/square rect, rectCentered, rectCenteredMidpointBase, squareCentered, -- ** Circle circle, -- ** Lines line, tick, ticks, axis, -- ** Polylines polyline, filledPolyline, filledBand, strokeLineJoin, LineStroke_(..), StrokeLineJoin_(..), -- ** Text text, TextAnchor_(..), -- ** Specialized plot elements pixel, pixel', plusGlyph, crossGlyph, candlestick, -- ** Plot legend pickColour, colourBar, legendBar, LegendPosition_(..), -- * Geometry -- ** R^2 Vectors V2(..), e1, e2, norm2, normalize2, v2fromEndpoints, v2fromPoint, (-.), pointRange -- ** R^2 -> R^2 Matrices , Mat2(..), DiagMat2(..), diagMat2 -- ** Typeclasses , AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..), movePoint, moveLabeledPointV2, moveLabeledPointBwFrames, translateSvg, toSvgFrame, toSvgFrameLP, toFloat, wholeDecimal -- * Colours , blendTwo, palette -- ** Col , (!#), Col(..), ShapeCol(..), col, col50, col100, shapeColBoth , shapeColNoBorder, shapeColNoFill -- * General utility -- ** Function interpolation , interpolateBilinear) where import Data.Monoid ((<>)) import qualified Data.Foldable as F (toList) import Data.List -- import Control.Arrow ((&&&), (***)) import Control.Monad (forM, forM_) import Control.Monad.State -- import Data.Semigroup (Min(..), Max(..)) import Data.Scientific (Scientific, toRealFloat) -- import Data.Foldable import qualified Data.Text as T -- import qualified Data.Vector as V import Text.Blaze.Internal (Attributable(..)) import Text.Blaze.Svg import Text.Blaze.Svg11 ((!)) import qualified Text.Blaze.Svg11 as S hiding (style) import qualified Text.Blaze.Svg11.Attributes as SA hiding (rotate) import Text.Blaze.Svg.Renderer.String (renderSvg) import qualified Data.Colour as C import qualified Data.Colour.Names as C import qualified Data.Colour.SRGB as C import GHC.Real import GHC.Generics import Data.Fixed import Graphics.Rendering.Plot.Light.Internal.Geometry import Graphics.Rendering.Plot.Light.Internal.Utils -- | Figure data data FigureData a = FigureData { -- | Figure width figWidth :: a -- | Figure height , figHeight :: a -- | Left margin fraction (w.r.t figure width) , figLeftMFrac :: a -- | Right margin fraction (w.r.t figure width) , figRightMFrac :: a -- | Top margin fraction (w.r.t figure height) , figTopMFrac :: a -- | Bottom margin fraction (w.r.t figure height) , figBottomMFrac :: a -- -- | Axis stroke width -- , figAxisStrokeWidth :: a -- | Tick label font size , figLabelFontSize :: Int } deriving (Eq, Show, Functor, Generic) figureDataDefault :: Floating a => FigureData a figureDataDefault = FigureData 400 300 0.1 0.9 0.1 0.9 10 -- | Create the SVG header svgHeader :: Real a => a -- ^ Image width (X axis) -> a -- ^ Image height (Y axis) -> Svg -- ^ Image content -> Svg svgHeader w h = S.docTypeSvg ! SA.version "1.1" ! SA.width (vd w) ! SA.height (vd h) ! SA.viewbox (vds [xmin fd, ymin fd, xmax fd, ymax fd]) where fd = mkFrameOrigin w h -- | A Col is both a 'Colour' and an alpha (opacity) coefficient data Col a = Col { cColour :: C.Colour Double -- ^ Colour , cAlpha :: a -- ^ Opacity, [0 .. 1] } deriving (Eq, Show) -- | 'Col' constructor col :: C.Colour Double -> a -> Col a col = Col -- | Full opacity colour col100 :: Num a => C.Colour Double -> Col a col100 c = col c 1 -- | Half opacity colour col50 :: Fractional a => C.Colour Double -> Col a col50 c = col c 0.5 -- | A shape can either be only filled, or only contoured, or both data ShapeCol a = NoBorderCol (Col a) -- ^ Only fill colour | NoFillCol (Col a) a -- ^ Only border colour + stroke width | BothCol (Col a) (Col a) a -- ^ Fill and border colours deriving (Eq, Show) -- | Construct a 'ShapeCol' for shapes that have no border stroke (i.e. have only the fill colour) shapeColNoBorder :: C.Colour Double -> a -> ShapeCol a shapeColNoBorder c a = NoBorderCol $ col c a -- | Construct a 'ShapeCol' for shapes that have no fill colour (i.e. have only the stroke colour) shapeColNoFill :: C.Colour Double -> a -> a -> ShapeCol a shapeColNoFill c a = NoFillCol $ col c a -- | Construct a 'ShapeCol' for shapes that have both fill and stroke colour shapeColBoth :: C.Colour Double -- ^ Fill colour -> C.Colour Double -- ^ Stroke colour -> a -- ^ Opacity -> a -- ^ Stroke width -> ShapeCol a shapeColBoth cs cf a = BothCol (col cs a) (col cf a) -- | Set the fill and stroke colour and opacity attributes all at once (e.g. if the fill is set to invisible, the stroke must be visible somehow. (!#) :: (Attributable h, Real a) => h -> ShapeCol a -> h m !# col = case col of NoBorderCol (Col c a) -> m ! SA.fillOpacity (vd a) ! SA.fill (colourAttr c) ! SA.stroke none NoFillCol (Col c a) sw -> m ! SA.strokeOpacity (vd a) ! SA.stroke (colourAttr c) ! SA.strokeWidth (vd sw) ! SA.fill none BothCol (Col cf af) (Col cb ab) sw -> m ! SA.fillOpacity (vd af) ! SA.fill (colourAttr cf) ! SA.strokeOpacity (vd ab) ! SA.stroke (colourAttr cb) ! SA.strokeWidth (vd sw) none :: S.AttributeValue none = S.toValue ("none" :: String) -- | A rectangle, defined by its anchor point coordinates and side lengths -- -- > > putStrLn $ renderSvg $ rect 50 60 (shapeColNoBorder C.blue 0.5) (Point 100 30) -- > rect :: Real a => a -- ^ Width -> a -- ^ Stroke width -> ShapeCol a -- ^ Colour and alpha information -> Point a -- ^ Corner point coordinates -> Svg rect wid hei col (Point x0 y0) = S.rect ! SA.x (vd x0) ! SA.y (vd y0) ! SA.width (vd wid) ! SA.height (vd hei) !# col -- | A rectangle, defined by its center coordinates and side lengths -- -- > > putStrLn $ renderSvg $ rectCentered 15 30 (shapeColBoth C.blue C.red 1 5) (Point 20 30) -- > rectCentered :: (Show a, RealFrac a) => a -- ^ Width -> a -- ^ Height -> ShapeCol a -- ^ Colour and alpha information -> Point a -- ^ Center coordinates -> Svg rectCentered wid hei col (Point x0 y0) = rect wid hei col p' where p' = Point x0c y0c x0c = x0 - (wid / 2) y0c = y0 - (hei / 2) -- | A rectangle, defined by the coordinates of the midpoint of its base rectCenteredMidpointBase :: (Show a, RealFrac a) => a -- ^ Width -> a -- ^ Height -> ShapeCol a -- ^ Colour and alpha information -> Point a -- ^ Base midpoint coordinates -> Svg rectCenteredMidpointBase wid hei col (Point x0 y0) = rect wid hei col p' where p' = Point x0c y0 x0c = x0 - (wid / 2) -- | A square, defined by its center coordinates and side length -- -- > > putStrLn $ renderSvg $ squareCentered 30 (shapeColBoth C.blue C.red 1 5) (Point 20 30) -- > squareCentered :: (Show a, RealFrac a) => a -- ^ Side length -> ShapeCol a -- ^ Colour and alpha information -> Point a -- ^ Center coordinates -> Svg squareCentered w = rectCentered w w lineColourDefault :: C.Colour Double lineColourDefault = C.blue lineStrokeTypeDefault :: LineStroke_ a lineStrokeTypeDefault = Continuous data LineOptions a = LineOptions { loStrokeWidth :: a -- ^ Stroke width , loStrokeType :: LineStroke_ a -- ^ Stroke type , loColour :: C.Colour Double -- ^ Stroke colour } deriving (Eq, Show, Generic) lineOptionsDefault :: Num a => LineOptions a lineOptionsDefault = LineOptions 2 lineStrokeTypeDefault lineColourDefault -- | Line options "picker". Creates an unbounded stream of LineOptions, may be useful when plotting multiple timeseries (essentially imitating the Matlab behaviour) lineOptionCycle :: Fractional a => a -> [LineOptions a] lineOptionCycle lw = let strTys = replicate 5 Continuous <> replicate 5 (Dashed [0.2, 0.5]) <> replicate 5 (Dashed [0.5, 0.2]) cols = [C.blue, C.green, C.red, C.black, C.purple] nc = length cols in LineOptions <$> repeat lw <*> strTys <*> cols -- | Line segment between two `Point`s -- -- > > putStrLn $ renderSvg $ line (Point 0 0) (Point 1 1) 0.1 Continuous C.blueviolet -- > -- -- > > putStrLn $ renderSvg (line (Point 0 0) (Point 1 1) 0.1 (Dashed [0.2, 0.3]) C.blueviolet) -- > line :: (Show a, RealFrac a) => Point a -- ^ First point -> Point a -- ^ Second point -> a -- ^ Stroke width -> LineStroke_ a -- ^ Stroke type -> C.Colour Double -- ^ Stroke colour -> Svg line (Point x1 y1) (Point x2 y2) sw lstr col = let svg0 = S.line ! SA.x1 (vd x1) ! SA.y1 (vd y1) ! SA.x2 (vd x2) ! SA.y2 (vd y2) ! SA.stroke (colourAttr col) ! SA.strokeWidth (vd sw) in case lstr of Continuous -> svg0 Dashed d -> svg0 ! strokeDashArray d strokeDashArray :: Real a => [a] -> S.Attribute strokeDashArray sz = SA.strokeDasharray (S.toValue str) where str = intercalate ", " $ map (show . real) sz -- | Specify a continuous or dashed stroke data LineStroke_ a = Continuous | Dashed [a] deriving (Eq, Show, Generic) tick :: (Show a, RealFrac a) => Axis -> a -> a -> C.Colour Double -> Point a -> Svg tick ax len sw col (Point x y) = line (Point x1 y1) (Point x2 y2) sw Continuous col where lh = len / 2 (x1, y1, x2, y2) | ax == Y = (x, y-lh, x, y+lh) | otherwise = (x-lh, y, x+lh, y) plusGlyph, crossGlyph :: (Show a, RealFrac a) => a -- ^ Width -> a -- ^ Stroke width -> C.Colour Double -> Point a -> Svg plusGlyph w sw k (Point x y) = do line pl pr sw Continuous k line pt pb sw Continuous k where wh = w / 2 pl = Point (x-wh) y pr = Point (x+wh) y pt = Point x (y-wh) pb = Point x (y+wh) crossGlyph w sw k (Point x y) = do line pa pb sw Continuous k line pc pd sw Continuous k where wh = 1.4142 * w pa = Point (x+wh) (x+wh) pb = Point (x-wh) (x-wh) pc = Point (x+wh) (x-wh) pd = Point (x-wh) (x+wh) labeledTick :: (Show a, RealFrac a) => Axis -> a -- ^ Length -> a -- ^ Stroke width -> C.Colour Double -> Int -- ^ Font size -> a -- ^ Label angle -> TextAnchor_ -> (t -> T.Text) -- ^ Label rendering function -> V2 a -- ^ Label shift -> LabeledPoint t a -> Svg labeledTick ax len sw col fontsize lrot tanchor flab vlab (LabeledPoint p label) = do tick ax len sw col p text lrot fontsize col tanchor (flab label) vlab p -- | An array of axis-aligned identical segments (to be used as axis tickmarks), with centers given by the array of `Point`s ticks :: (Foldable t, Show a, RealFrac a) => Axis -- ^ Axis -> a -- ^ Length -> a -- ^ Stroke width -> C.Colour Double -- ^ Stroke colour -> t (Point a) -- ^ Center coordinates -> Svg ticks ax len sw col ps = forM_ ps (tick ax len sw col) labeledTicks :: (Foldable t, Show a, RealFrac a) => Axis -> a -> a -> C.Colour Double -> Int -> a -> TextAnchor_ -> (t2 -> T.Text) -> V2 a -> t (LabeledPoint t2 a) -> Svg labeledTicks ax len sw col fontsize lrot tanchor flab vlab ps = forM_ ps (labeledTick ax len sw col fontsize lrot tanchor flab vlab) -- | A plot axis with labeled tickmarks -- -- > > putStrLn $ renderSvg $ axis (Point 0 50) X 200 2 C.red 0.05 Continuous 15 (-45) TAEnd T.pack (V2 (-10) 0) [LabeledPoint (Point 50 1) "bla", LabeledPoint (Point 60 1) "asdf"] -- > blaasdf axis :: (Functor t, Foldable t, Show a, RealFrac a) => Point a -- ^ Origin coordinates -> Axis -- ^ Axis (i.e. either `X` or `Y`) -> a -- ^ Length of the axis -> a -- ^ Stroke width -> C.Colour Double -- ^ Stroke colour -> a -- ^ The tick length is a fraction of the axis length -> LineStroke_ a -- ^ Stroke type -> Int -- ^ Label font size -> a -- ^ Label rotation angle -> TextAnchor_ -- ^ How to anchor a text label to the axis -> (l -> T.Text) -- ^ How to render the tick label -> V2 a -- ^ Offset the label -> t (LabeledPoint l a) -- ^ Tick center coordinates -> Svg axis o@(Point ox oy) ax len sw col tickLenFrac ls fontsize lrot tanchor flab vlab ps = do line o pend sw ls col labeledTicks (otherAxis ax) (tickLenFrac * len) sw col fontsize lrot tanchor flab vlab (moveLabeledPoint f <$> ps) where pend | ax == X = Point (ox + len) oy | otherwise = Point ox (oy + len) f | ax == X = setPointY oy | otherwise = setPointX ox -- | A pair of Cartesian axes axes :: (Show a, RealFrac a) => FigureData a -> Frame a -> a -> C.Colour Double -> Int -> Int -> Svg axes fdat (Frame (Point xmi ymi) (Point xma yma)) sw col nx ny = do axis o X lenx sw col 0.01 Continuous fontsize (-45) TAEnd showlabf (V2 (-10) 0) plabx_ axis o Y (- leny) sw col 0.01 Continuous fontsize 0 TAEnd showlabf (V2 (-10) 0) plaby_ where o = Point (figWidth fdat * figLeftMFrac fdat) (figHeight fdat * figBottomMFrac fdat) pxend = movePoint (V2 lenx 0) o pyend = movePoint (V2 0 (- leny)) o plabx_ = zipWith LabeledPoint (pointRange nx o pxend) (take (nx+1) $ subdivSegment xmi xma $ fromIntegral nx) plaby_ = zipWith LabeledPoint (pointRange ny o pyend) (take (ny+1) $ subdivSegment ymi yma $ fromIntegral ny) fontsize = figLabelFontSize fdat lenx = figFWidth fdat leny = figFHeight fdat showlabf x = T.pack $ show (fromRational x :: Fixed E2) -- | `toPlot` performs a number of related operations: -- -- * Maps the dataset to the figure frame -- -- * Renders the X, Y axes -- -- * Renders the transformed dataset onto the newly created plot canvas toPlot :: (Functor t, Foldable t, Show a, RealFrac a) => FigureData a -> (l -> T.Text) -- ^ X tick label -> (l -> T.Text) -- ^ Y tick label -> a -- ^ X label rotation angle -> a -- ^ Y label rotation angle -> a -- ^ Stroke width -> C.Colour Double -- ^ Stroke colour -> Maybe (t (LabeledPoint l a)) -- ^ X axis labels -> Maybe (t (LabeledPoint l a)) -- ^ Y axis labels -> (t (LabeledPoint l a) -> Svg) -- ^ Data rendering function -> t (LabeledPoint l a) -- ^ Data -> Svg toPlot fd flabelx flabely rotx roty sw col1 tickxe tickye plotf dat = do axis oSvg X (width to) sw col1 0.05 Continuous fontsize rotx TAEnd flabelx (V2 (-10) 0) tickx axis oSvg Y (negate $ height to) sw col1 0.05 Continuous fontsize roty TAEnd flabely (V2 (-10) 0) ticky plotf dat' where fontsize = figLabelFontSize fd from = frameFromPoints $ _lp <$> dat to = frameFromFigData fd datf = toSvgFrameLP from to False -- data mapping function dat' = datf <$> dat tickDefault ti d = case ti of Just t -> datf <$> t Nothing -> d tickx = tickDefault tickxe dat' ticky = tickDefault tickye dat' oSvg = Point (xmin to) (ymax to) frameFromFigData :: Num a => FigureData a -> Frame a frameFromFigData fd = mkFrame oTo p2To where fontsize = figLabelFontSize fd wfig = figWidth fd hfig = figHeight fd (left, right) = (figLeftMFrac fd * wfig, figRightMFrac fd * wfig) (top, bot) = (figTopMFrac fd * hfig, figBottomMFrac fd * hfig) oTo = Point left top p2To = Point right bot figFWidth, figFHeight :: Num a => FigureData a -> a figFWidth = width . frameFromFigData figFHeight = height . frameFromFigData -- * text -- | `text` renders text onto the SVG canvas -- -- === Conventions -- -- The `Point` argument `p` refers to the /lower-left/ corner of the text box. -- -- The text box can be rotated by `rot` degrees around `p` and then anchored at either its beginning, middle or end to `p` with the `TextAnchor_` flag. -- -- The user can supply an additional `V2` displacement which will be applied /after/ rotation and anchoring and refers to the rotated text box frame. -- -- > > putStrLn $ renderSvg $ text (-45) C.green TAEnd "blah" (V2 (- 10) 0) (Point 250 0) -- > blah text :: (Show a, Real a) => a -- ^ Rotation angle of the textbox -> Int -- ^ Font size -> C.Colour Double -- ^ Font colour -> TextAnchor_ -- ^ How to anchor the text to the point -> T.Text -- ^ Text -> V2 a -- ^ Displacement w.r.t. rotated textbox -> Point a -- ^ Initial position of the text box (i.e. before rotation and displacement) -> Svg text rot fontsize col ta te (V2 vx vy) (Point x y) = S.text_ (S.toMarkup te) ! SA.x (vd vx) ! SA.y (vd vy) ! SA.transform (S.translate (real x) (real y) <> S.rotate (real rot)) ! SA.fontSize (vi fontsize) ! SA.fill (colourAttr col) ! textAnchor ta -- | Specify at which end should the text be anchored to its current point data TextAnchor_ = TAStart | TAMiddle | TAEnd deriving (Eq, Show) textAnchor :: TextAnchor_ -> S.Attribute textAnchor TAStart = SA.textAnchor (vs "start") textAnchor TAMiddle = SA.textAnchor (vs "middle") textAnchor TAEnd = SA.textAnchor (vs "end") -- | A circle -- -- > > putStrLn $ renderSvg $ circle 15 (shapeColBoth C.red C.blue 1 5) (Point 10 20) -- > circle :: (Real a1, Real a) => a -- ^ Radius -> ShapeCol a -> Point a1 -- ^ Center -> Svg circle r col (Point x y) = S.circle ! SA.cx (vd x) ! SA.cy (vd y) ! SA.r (vd r) !# col -- | Polyline (piecewise straight line) -- -- > > putStrLn $ renderSvg (polyline [Point 100 50, Point 120 20, Point 230 50] 4 (Dashed [3, 5]) Round C.blueviolet) -- > polyline :: (Foldable t, Show a1, Show a, RealFrac a, RealFrac a1) => a1 -- ^ Stroke width -> LineStroke_ a -- ^ Stroke type -> StrokeLineJoin_ -- ^ Stroke join type -> C.Colour Double -- ^ Stroke colour -> t (Point a) -- ^ Data -> Svg polyline sw strTy slj col lis = let svg0 = S.polyline ! SA.points (S.toValue $ unwords $ map show $ F.toList lis) ! SA.fill none ! SA.stroke (colourAttr col ) ! SA.strokeWidth (vd sw) ! strokeLineJoin slj in case strTy of Continuous -> svg0 Dashed d -> svg0 ! strokeDashArray d -- | A filled polyline -- -- > > putStrLn $ renderSvg $ filledPolyline C.coral 0.3 [(Point 0 1), (Point 10 40), Point 34 50, Point 30 5] -- > filledPolyline :: (Foldable t, Show a, Real o) => C.Colour Double -- ^ Fill colour -> o -- ^ Fill opacity -> t (Point a) -- ^ Contour point coordinates -> Svg filledPolyline col opac lis = S.polyline ! SA.points (S.toValue $ unwords $ map show $ F.toList lis) ! SA.fill (colourAttr col) ! SA.fillOpacity (vd opac) -- | A filled band of colour, given the coordinates of its center line -- -- This element can be used to overlay uncertainty ranges (e.g. the first standard deviation) associated with a given data series. filledBand :: (Foldable t, Real o, Show a) => C.Colour Double -- ^ Fill colour -> o -- ^ Fill opacity -> (l -> a) -- ^ Band maximum value -> (l -> a) -- ^ Band minimum value -> t (LabeledPoint l a) -- ^ Centerline points -> Svg filledBand col opac ftop fbot lis0 = filledPolyline col opac (lis1 <> lis2) where lis = F.toList lis0 f1 lp = setPointY (ftop $ _lplabel lp) $ _lp lp f2 lp = setPointY (fbot $ _lplabel lp) $ _lp lp lis1 = f1 <$> lis lis2 = f2 <$> reverse lis -- | A `candlestick` glyph for time series plots. This is a type of box glyph, commonly used in plotting financial time series. -- -- Some financial market quantities such as currency exchange rates are aggregated over some time period (e.g. a day) and summarized by various quantities, for example opening and closing rates, as well as maximum and minimum over the period. -- -- By convention, the `candlestick` colour depends on the derivative sign of one such quantity (e.g. it is green if the market closes higher than it opened, and red otherwise). candlestick :: (Show a, RealFrac a) => (a -> a -> Bool) -- ^ If True, fill the box with the first colour, otherwise with the second -> (l -> a) -- ^ Box maximum value -> (l -> a) -- ^ Box minimum value -> (l -> a) -- ^ Line maximum value -> (l -> a) -- ^ Line minimum value -> a -- ^ Box width -> a -- ^ Stroke width -> ShapeCol a -- ^ First box colour -> ShapeCol a -- ^ Second box colour -> C.Colour Double -- ^ Line stroke colour -> LabeledPoint l a -- ^ Data point -> Svg candlestick fdec fboxmin fboxmax fmin fmax wid sw col1 col2 colstroke lp = do line pmin pmax sw Continuous colstroke rectCentered wid hei col p where p = _lp lp lab = _lplabel lp pmin = setPointY (fmin lab) p pmax = setPointY (fmax lab) p hei = abs $ fboxmax lab - fboxmin lab col | fdec (fboxmax lab) (fboxmin lab) = col1 | otherwise = col2 -- | Specify the type of connection between line segments data StrokeLineJoin_ = Miter | Round | Bevel | Inherit deriving (Eq, Show) strokeLineJoin :: StrokeLineJoin_ -> S.Attribute strokeLineJoin slj = SA.strokeLinejoin (S.toValue str) where str | slj == Miter = "miter" :: String | slj == Round = "round" | slj == Bevel = "bevel" | otherwise = "inherit" -- | Move a Svg entity to a new position translateSvg :: Show a => Point a -> Svg -> Svg translateSvg (Point x y) svg = S.g ! SA.transform (S.translate x y) $ svg -- | Move point to the SVG frame of reference (for which the origing is a the top-left corner of the screen) toSvgFrame :: Fractional a => Frame a -- ^ Initial frame -> Frame a -- ^ Final frame -> Bool -- ^ Flip L-R in [0,1] x [0,1] -> Point a -- ^ Point in the initial frame -> Point a toSvgFrame from to fliplr p = pointFromV2 v' where v' = frameToFrame from to fliplr True (v2fromPoint p) -- | Move LabeledPoint to the SVG frame of reference (uses `toSvgFrame` ) toSvgFrameLP :: Fractional a => Frame a -> Frame a -> Bool -> LabeledPoint l a -> LabeledPoint l a toSvgFrameLP from to fliplr (LabeledPoint p lab) = LabeledPoint (toSvgFrame from to fliplr p) lab -- withToSvgFrame figdata dat = datf -- where -- from = frameFromPoints $ _lp <$> dat -- to = frameFromFigData figdata -- datf = toSvgFrameLP from to False -- data mapping function -- | A 'pixel' is a filled square shape used for populating 'heatmap' plots , coloured from a palette pixel :: (Show a, RealFrac a) => [C.Colour Double] -- ^ Palette -> a -- ^ Width -> a -- ^ Height -> Scientific -- ^ Function minimum -> Scientific -- ^ Function maximum -> LabeledPoint Scientific a -> Svg pixel pal w h vmin vmax (LabeledPoint p l) = rect w h col p where col = pickColour pal (toFloat vmin) (toFloat vmax) (toFloat l) -- | A 'pixel'' is a filled square shape used for populating 'heatmap' plots , coloured from a palette pixel' :: (Show a, RealFrac a, RealFrac t) => [C.Colour Double] -- ^ Palette -> a -- ^ Width -> a -- ^ Height -> t -- ^ Function minimum -> t -- ^ Function maximum -> LabeledPoint t a -> Svg pixel' pal w h vmin vmax (LabeledPoint p l) = rect w h col p where col = pickColour pal vmin vmax l -- | Pick a colour from a list, assumed to be a palette mapped onto a compact numerical interval. pickColour :: (RealFrac t, Num a) => [C.Colour Double] -> t -> t -> t -> ShapeCol a pickColour pal xmin xmax x = NoBorderCol $ Col (pal !! i) 1 where i = floor (x01 * fromIntegral (nColors - 1)) x01 = (x - xmin) / (xmax - xmin) nColors = length pal data LegendPosition_ = TopLeft | TopRight | BottomLeft | BottomRight deriving (Eq, Show) posCoeff :: Fractional a => LegendPosition_ -> (a, a) posCoeff pos = case pos of TopLeft -> (0.1, 0.1) TopRight -> (0.83, 0.15) BottomLeft -> (0.1, 0.9) BottomRight -> (0.9, 0.9) -- | A colour bar legend, to be used within `heatmap`-style plots. colourBar :: (RealFrac t, RealFrac a, Show a, Enum t, Floating a) => FigureData (Ratio Integer) -- ^ Figure data -> [C.Colour Double] -- ^ Palette -> a -- ^ Width -> t -- ^ Value range minimum -> t -- ^ Value range maximum -> Int -- ^ Number of distinct values -> LegendPosition_ -- ^ Legend position in the figure -> a -- ^ Colour bar length -> Svg colourBar fdat pal w vmin vmax n legpos legh = legendBar (fromRational <$> fdat) w vmin vmax n legpos legh (colBarPx pal) legendBar :: (Monad m, Enum t, Fractional t, Fractional a) => FigureData a -> a -> t -> t -> Int -> LegendPosition_ -> a -> (FigureData a -> a -> a -> t -> t -> LabeledPoint t a -> m b) -> m () legendBar fdat w vmin vmax n legpos legh fun = do -- rect wrect hrect 1 (Just C.black) (Just C.white) prect forM_ lps (fun fdat w h vmin vmax) where wrect = 0.95 * (1 - figRightMFrac fdat) * figWidth fdat hrect = 1.5 * legh prect = movePoint (V2 (-0.5 * w) (-0.5 * w)) p2 (legx, legy) = posCoeff legpos legendX = figWidth fdat * legx legendY = figHeight fdat * legy p1 = Point legendX (legendY + legh) p2 = Point legendX legendY lps = zipWith LabeledPoint (pointRange n p1 p2) v_ h = legh / fromIntegral n v_ = take (n+1) [vmin, vmin + dv ..] dv = (vmax - vmin)/fromIntegral n colBarPx :: (Show a, RealFrac a, RealFrac t) => [C.Colour Double] -> FigureData a1 -> a -> a -> t -> t -> LabeledPoint t a -> Svg colBarPx pal fdat w h vmin vmax (LabeledPoint p val) = do text 0 (figLabelFontSize fdat) C.black TAStart (T.pack $ show (rr val :: Fixed E3)) (V2 (1.1*w) (0.5*h)) p rectCentered w h (pickColour pal vmin vmax val) p -- * Helpers -- | Render a Colour from `colour` into a `blaze` Attribute colourAttr :: C.Colour Double -> S.AttributeValue colourAttr = S.toValue . C.sRGB24show -- ** Conversion from primitive numerical types to AttributeValue -- String vs :: String -> S.AttributeValue vs x = S.toValue (x :: String) vi :: Int -> S.AttributeValue vi = S.toValue -- Double vd0 :: Double -> S.AttributeValue vd0 = S.toValue vd :: Real a => a -> S.AttributeValue vd = vd0 . real real :: (Real a, Fractional b) => a -> b real = fromRational . toRational vds :: Real a => [a] -> S.AttributeValue vds = S.toValue . unwords . map (show . real)