diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ + 0.4 + + Remove data-default-* + Improve shape colour representation: shapes can have a colour fill, a coloured contour, or both (see 'ShapeCol'). + + 0.3.3 Add Semigroup instances to everything that had Monoid instances (since from GHC 8.4.2 Semigroup m => Monoid m ) diff --git a/plot-light.cabal b/plot-light.cabal --- a/plot-light.cabal +++ b/plot-light.cabal @@ -1,5 +1,5 @@ name: plot-light -version: 0.3.3.2 +version: 0.4 synopsis: A lightweight plotting library, exporting to SVG description: This library provides drawing and plotting datastructures and functions; it is aimed in particular at scientific visualization, but it also exposes its plotting primitives and a small but general purpose 2D geometry library. @@ -37,14 +37,17 @@ Graphics.Rendering.Plot.Light.Internal.Utils Data.Parsers build-depends: base >= 4.7 && < 5 + , blaze-markup >= 0.8.0.0 , blaze-svg >= 0.3.6.1 , colour >= 2.3.3 , containers >= 0.5.7.1 + , histogram-fill >= 0.8.5.0 + , exceptions , mtl , scientific >= 0.3.5.1 , text >= 1.2.2.2 , time - , data-default-class >= 0.1.2.0 + , vector -- -- * DEBUG -- , hspec -- , QuickCheck diff --git a/src/Graphics/Rendering/Plot/Light/Internal.hs b/src/Graphics/Rendering/Plot/Light/Internal.hs --- a/src/Graphics/Rendering/Plot/Light/Internal.hs +++ b/src/Graphics/Rendering/Plot/Light/Internal.hs @@ -1,6 +1,31 @@ {-# LANGUAGE OverloadedStrings, DeriveFunctor, DeriveGeneric #-} module Graphics.Rendering.Plot.Light.Internal - (FigureData(..), Frame(..), mkFrame, mkFrameOrigin, frameToFrame, frameToFrameValue, frameFromPoints, frameFromFigData, xmin,xmax,ymin,ymax, width, height, figFWidth, figFHeight, Point(..), mkPoint, LabeledPoint(..), mkLabeledPoint, labelPoint, mapLabel, Axis(..), axes, meshGrid, subdivSegment, svgHeader, rect, rectCentered, squareCentered, circle, line, tick, ticks, axis, toPlot, text, pixel, pixel', pickColour, colourBar, legendBar, plusGlyph, crossGlyph, polyline, filledPolyline, filledBand, candlestick, strokeLineJoin, LineStroke_(..), StrokeLineJoin_(..), TextAnchor_(..), LegendPosition_(..), V2(..), Mat2(..), DiagMat2(..), diagMat2, AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..), norm2, normalize2, v2fromEndpoints, v2fromPoint, origin, (-.), pointRange, movePoint, moveLabeledPointV2, moveLabeledPointBwFrames, translateSvg, toSvgFrame, toSvgFrameLP, e1, e2, toFloat, wholeDecimal, blendTwo, palette, interpolateBilinear) + ( + -- * 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, rect, rectCentered, squareCentered, circle, line, tick, ticks, axis, toPlot, text, pixel, pixel', pickColour, colourBar, legendBar, plusGlyph, crossGlyph, polyline, filledPolyline, filledBand, candlestick, strokeLineJoin, LineStroke_(..), StrokeLineJoin_(..), TextAnchor_(..), 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 ((<>)) @@ -16,6 +41,7 @@ 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) @@ -29,7 +55,6 @@ import GHC.Real import GHC.Generics import Data.Fixed -import Data.Default.Class import Graphics.Rendering.Plot.Light.Internal.Geometry import Graphics.Rendering.Plot.Light.Internal.Utils @@ -56,11 +81,12 @@ , figLabelFontSize :: Int } deriving (Eq, Show, Functor, Generic) -instance (Default a, Fractional a) => Default (FigureData a) where - def = FigureData 400 300 0.1 0.9 0.1 0.9 10 +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) @@ -76,35 +102,86 @@ fd = mkFrameOrigin w h + +-- | A Col is both a 'Colour' and an alpha (opacity) coefficient +data Col a = Col { + cColour :: C.Colour Double + , cAlpha :: a } deriving (Eq, Show) + +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) + +shapeColNoBorder :: C.Colour Double -> a -> ShapeCol a +shapeColNoBorder c a = NoBorderCol $ col c a + +shapeColNoFill :: C.Colour Double -> a -> a -> ShapeCol a +shapeColNoFill c a = NoFillCol $ col c a + +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 (Point 100 200) 30 60 2 Nothing (Just C.aquamarine) --- > -rect :: (Show a, RealFrac a) => - a -- ^ Width - -> a -- ^ Height - -> a -- ^ Stroke width - -> Maybe (C.Colour Double) -- ^ Stroke colour - -> Maybe (C.Colour Double) -- ^ Fill colour - -> Point a -- ^ Corner point coordinates - -> Svg -rect wid hei sw scol fcol (Point x0 y0) = S.rect ! SA.x (vd x0) ! SA.y (vd y0) ! SA.width (vd wid) ! SA.height (vd hei) ! colourFillOpt fcol ! colourStrokeOpt scol ! SA.strokeWidth (vd sw) +-- > > 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 1 (Just C.blue) (Just C.red) (Point 20 30) --- > +-- > > putStrLn $ renderSvg $ rectCentered 15 30 (Just C.blue) (Just C.red) (Point 20 30) + rectCentered :: (Show a, RealFrac a) => a -- ^ Width -> a -- ^ Height - -> a -- ^ Stroke width - -> Maybe (C.Colour Double) -- ^ Stroke colour - -> Maybe (C.Colour Double) -- ^ Fill colour + -> ShapeCol a -- ^ Colour and alpha information -> Point a -- ^ Center coordinates -> Svg -rectCentered wid hei sw scol fcol (Point x0 y0) = - rect wid hei sw scol fcol p' where +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) @@ -114,24 +191,26 @@ squareCentered :: (Show a, RealFrac a) => a -- ^ Side length - -> a -- ^ Stroke width - -> Maybe (C.Colour Double) -- ^ Stroke colour - -> Maybe (C.Colour Double) -- ^ Fill colour + -> ShapeCol a -- ^ Colour and alpha information -> Point a -- ^ Center coordinates -> Svg squareCentered w = rectCentered w w +lineColourDefault :: C.Colour Double +lineColourDefault = C.blue -newtype Col = Col { unCol :: C.Colour Double} deriving (Eq, Show, Generic) -instance Default Col where - def = Col C.blue +lineStrokeTypeDefault :: LineStroke_ a +lineStrokeTypeDefault = Continuous data LineOptions a = LineOptions { loStrokeWidth :: a -- ^ Stroke width , loStrokeType :: LineStroke_ a -- ^ Stroke type - , loColour :: Col -- ^ Stroke colour + , 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 = @@ -140,7 +219,7 @@ replicate 5 Continuous <> replicate 5 (Dashed [0.2, 0.5]) <> replicate 5 (Dashed [0.5, 0.2]) - cols = Col <$> [C.blue, C.green, C.red, C.black, C.purple] + cols = [C.blue, C.green, C.red, C.black, C.purple] nc = length cols in LineOptions <$> @@ -148,8 +227,6 @@ strTys <*> cols -instance (Default a, Num a) => Default (LineOptions a) where - def = LineOptions 2 def def -- | Line segment between two `Point`s @@ -179,11 +256,10 @@ -- | Specify a continuous or dashed stroke data LineStroke_ a = Continuous | Dashed [a] deriving (Eq, Show, Generic) -instance Default (LineStroke_ a) where - def = Continuous + 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 @@ -192,16 +268,15 @@ | otherwise = (x-lh, y, x+lh, y) -plusGlyph, crossGlyph - :: (Show a, RealFrac a) => - a - -> a - -> C.Colour Double - -> Point a - -> Svg -plusGlyph w sw col (Point x y) = do - line pl pr sw Continuous col - line pt pb sw Continuous col +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 @@ -209,9 +284,9 @@ pt = Point x (y-wh) pb = Point x (y+wh) -crossGlyph w sw col (Point x y) = do - line pa pb sw Continuous col - line pc pd sw Continuous col +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) @@ -253,6 +328,18 @@ 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) @@ -318,20 +405,19 @@ -- * 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 :: (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 @@ -407,18 +493,16 @@ -- | A circle -- --- > > putStrLn $ renderSvg $ circle (Point 20 30) 15 (Just C.blue) (Just C.red) --- > +-- > > putStrLn $ renderSvg $ circle 15 (shapeColBoth C.red C.blue 1 5) (Point 10 20) +-- > circle :: (Real a1, Real a) => a -- ^ Radius - -> a -- ^ Stroke width - -> Maybe (C.Colour Double) -- ^ Stroke colour - -> Maybe (C.Colour Double) -- ^ Fill colour + -> ShapeCol a -> Point a1 -- ^ Center -> Svg -circle r sw scol fcol (Point x y) = - S.circle ! SA.cx (vd x) ! SA.cy (vd y) ! SA.r (vd r) ! colourFillOpt fcol ! colourStrokeOpt scol ! SA.strokeWidth (vd sw) +circle r col (Point x y) = + S.circle ! SA.cx (vd x) ! SA.cy (vd y) ! SA.r (vd r) !# col @@ -441,18 +525,9 @@ in case strTy of Continuous -> svg0 Dashed d -> svg0 ! strokeDashArray d -none :: S.AttributeValue -none = S.toValue ("none" :: String) -colourFillOpt :: Maybe (C.Colour Double) -> S.Attribute -colourFillOpt Nothing = SA.fill none -colourFillOpt (Just c) = SA.fill (colourAttr c) -colourStrokeOpt :: Maybe (C.Colour Double) -> S.Attribute -colourStrokeOpt Nothing = SA.stroke none -colourStrokeOpt (Just c) = SA.stroke (colourAttr c) - -- | A filled polyline -- -- > > putStrLn $ renderSvg $ filledPolyline C.coral 0.3 [(Point 0 1), (Point 10 40), Point 34 50, Point 30 5] @@ -497,14 +572,14 @@ -> (l -> a) -- ^ Line minimum value -> a -- ^ Box width -> a -- ^ Stroke width - -> C.Colour Double -- ^ First box colour - -> C.Colour Double -- ^ Second box colour + -> 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 sw (Just colstroke) (Just col) p + rectCentered wid hei col p where p = _lp lp lab = _lplabel lp @@ -573,30 +648,31 @@ -pixel - :: (Show a, RealFrac a) => - [C.Colour Double] - -> a - -> a - -> Scientific - -> Scientific - -> LabeledPoint Scientific a - -> Svg -pixel pal w h vmin vmax (LabeledPoint p l) = rect w h 0 Nothing (Just col) p where +pixel :: (Show a, RealFrac a) => + [C.Colour Double] -- ^ Palette + -> a -- ^ Width + -> a -- ^ Height + -> Scientific + -> Scientific + -> 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) pixel' :: (Show a, RealFrac a, RealFrac t) => [C.Colour Double] -> a -> a -> t -> t -> LabeledPoint t a -> Svg -pixel' pal w h vmin vmax (LabeledPoint p l) = rect w h 0 Nothing (Just col) p where +pixel' pal w h vmin vmax (LabeledPoint p l) = rect w h col p where col = pickColour pal vmin vmax l -pickColour :: RealFrac t => [C.Colour Double] -> t -> t -> t -> C.Colour Double -pickColour pal xmin xmax x = pal !! i +-- | 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) + x01 = (x - xmin) / (xmax - xmin) nColors = length pal @@ -629,17 +705,16 @@ 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 :: (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 @@ -669,7 +744,7 @@ -> 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 0 Nothing (Just $ pickColour pal vmin vmax val) p + rectCentered w h (pickColour pal vmin vmax val) p @@ -683,11 +758,6 @@ -- | Render a Colour from `colour` into a `blaze` Attribute colourAttr :: C.Colour Double -> S.AttributeValue colourAttr = S.toValue . C.sRGB24show - - --- ** - - diff --git a/src/Graphics/Rendering/Plot/Light/Internal/Geometry.hs b/src/Graphics/Rendering/Plot/Light/Internal/Geometry.hs --- a/src/Graphics/Rendering/Plot/Light/Internal/Geometry.hs +++ b/src/Graphics/Rendering/Plot/Light/Internal/Geometry.hs @@ -11,7 +11,7 @@ -- ** LabeledPoint LabeledPoint(..), mkLabeledPoint, labelPoint, mapLabel, -- ** Frame - Frame(..), mkFrame, frameFromPoints, mkFrameOrigin, height, width, xmin, xmax, ymin, ymax, + Frame(..), mkFrame, unitFrame, frameFromPoints, mkFrameOrigin, height, width, xmin, xmax, ymin, ymax, isPointInFrame, -- ** Axis Axis(..), otherAxis, -- ** Vectors @@ -37,16 +37,18 @@ -- import Data.Monoid ((<>)) +import Control.Exception +import Control.Monad.Catch (MonadThrow(..), throwM) import GHC.Generics -import Data.Default.Class + import Data.Semigroup (Semigroup(..)) -- | A `Point` object defines a point in the plane data Point a = Point { _px :: a, _py :: a } deriving (Eq, Generic) -instance Default a => Default (Point a) where + instance Ord a => Ord (Point a) where (Point x1 y1) <= (Point x2 y2) = x1 <= x2 && y1 <= y2 @@ -121,9 +123,6 @@ _fpmax :: Point a } deriving (Eq, Show, Generic) -instance (Default a, Num a) => Default (Frame a) where - def = unitFrame - -- | The semigroup operation (`mappend`) applied on two `Frames` results in a new `Frame` that bounds both. instance (Ord a) => Semigroup (Frame a) where @@ -133,6 +132,8 @@ mempty = Frame (Point 0 0) (Point 0 0) mappend = (<>) +isPointInFrame :: Ord a => Frame a -> Point a -> Bool +isPointInFrame (Frame p1 p2) p = p >= p1 && p <= p2 mkFrame :: Point a -> Point a -> Frame a mkFrame = Frame @@ -184,8 +185,16 @@ -- | Interpolation -interpolateBilinear :: Fractional a => Frame a -> Point a -> (Point a -> a) -> a -interpolateBilinear (Frame q11@(Point x1 y1) q22@(Point x2 y2)) (Point x y) f = +-- | Safe +interpolateBilinear :: (Ord p, Fractional p, Show p) => + Frame p -> (Point p -> p) -> Point p -> p +interpolateBilinear fr@(Frame p1 p2) f p + | isPointInFrame fr p = interpolateBilinear' p1 p2 f p + | otherwise = error $ unwords ["Point", show p, "is outside frame", show fr] + +-- | Unsafe +interpolateBilinear' :: Fractional a => Point a -> Point a -> (Point a -> a) -> Point a -> a +interpolateBilinear' q11@(Point x1 y1) q22@(Point x2 y2) f (Point x y) = let q12 = Point x1 y2 q21 = Point x2 y1 @@ -415,8 +424,7 @@ data MeshGrid a = MeshGrid (Frame a) Int Int deriving (Eq, Show, Generic) -instance (Default a, Num a) => Default (MeshGrid a) where - +-- meshGridDefault = MeshGrid subdivSegment :: (Real a, Enum b, RealFrac b) => a -> a -> Int -> [b] diff --git a/src/Graphics/Rendering/Plot/Light/Internal/Layout.hs b/src/Graphics/Rendering/Plot/Light/Internal/Layout.hs --- a/src/Graphics/Rendering/Plot/Light/Internal/Layout.hs +++ b/src/Graphics/Rendering/Plot/Light/Internal/Layout.hs @@ -91,15 +91,19 @@ -liftF :: Functor f => f r -> Free f r -liftF x = Free (fmap Pure x) -data Free f r = Free (f (Free f r)) | Pure r deriving Functor +-- * Free -instance Functor f => Applicative (Free f) where - pure = Pure -instance (Functor f) => Monad (Free f) where - return = pure - (Free x) >>= f = Free (fmap (>>= f) x) - (Pure r) >>= f = f r +-- liftF :: Functor f => f r -> Free f r +-- liftF x = Free (fmap Pure x) + +-- data Free f r = Free (f (Free f r)) | Pure r deriving Functor + +-- instance Functor f => Applicative (Free f) where +-- pure = Pure + +-- instance (Functor f) => Monad (Free f) where +-- return = pure +-- (Free x) >>= f = Free (fmap (>>= f) x) +-- (Pure r) >>= f = f r diff --git a/src/Graphics/Rendering/Plot/Light/PlotTypes/Histogram.hs b/src/Graphics/Rendering/Plot/Light/PlotTypes/Histogram.hs --- a/src/Graphics/Rendering/Plot/Light/PlotTypes/Histogram.hs +++ b/src/Graphics/Rendering/Plot/Light/PlotTypes/Histogram.hs @@ -1,12 +1,52 @@ +{-# language FlexibleContexts #-} module Graphics.Rendering.Plot.Light.PlotTypes.Histogram where import Graphics.Rendering.Plot.Light.Internal import Control.Monad (forM_) -import Text.Blaze.Svg +-- import Text.Blaze.Svg import qualified Data.Colour as C -- import qualified Data.Colour.Palette.BrewerSet as CP import qualified Data.Colour.Names as C +import qualified Data.Histogram as H (Histogram(..), Bin(..), bins, asList) +import qualified Data.Histogram.Bin as H (BinD(..), binD, BinI(..), binI, binSize, UniformBin(..)) +import qualified Data.Histogram.Fill as H (mkSimple, mkWeighted, fillBuilder, HBuilder(..)) -histogram figdata = undefined +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Generic as VG + +-- histogram figdata = + + + + + +histogram col h = undefined where + (binCenters, binCounts) = unzip $ H.asList h + binXOffset = - head binCenters + 0.5 * binSize + binSize = H.binSize $ H.bins h + -- hcol = case col of + -- NoBorderCol c a + + + +-- | Uniform, un-weighted bins +histo :: (Foldable v, VU.Unbox a, Num a) => + Int + -> v Double + -> H.Histogram H.BinD a +histo n v = histo'' bins v where + mi = minimum v + ma = maximum v + 1 + bins = H.binD mi n ma + + +histo'' :: (Foldable f, H.Bin bin, VU.Unbox val, Num val) => + bin + -> f (H.BinValue bin) + -> H.Histogram bin val +histo'' bins v = H.fillBuilder buildr v + where + buildr = H.mkSimple bins diff --git a/src/Graphics/Rendering/Plot/Light/PlotTypes/Scatter.hs b/src/Graphics/Rendering/Plot/Light/PlotTypes/Scatter.hs --- a/src/Graphics/Rendering/Plot/Light/PlotTypes/Scatter.hs +++ b/src/Graphics/Rendering/Plot/Light/PlotTypes/Scatter.hs @@ -16,16 +16,12 @@ -- | Scatter plot -- -- Every point in the plot has the same parameters, as declared in the `ScatterPointData` record -scatter - :: (Foldable t, Show a, RealFrac a) => - ScatterPointData a - -> t (Point a) - -> Svg -scatter (ScatterPointData glshape w sw fcol) ps = - forM_ ps $ glyph w sw glshape Nothing (Just fcol) - - - +scatter :: (Foldable t, Show a, RealFrac a) => + ScatterPointData a + -> t (Point a) + -> Svg +scatter (ScatterPointData glshape w sw fcol alpha) ps = + forM_ ps $ glyph w sw glshape fcol alpha -- | Parametric scatter plot @@ -33,50 +29,50 @@ -- The parameters of every point in the scatter plot are modulated according to the label, using the three functions. -- -- This can be used to produce rich infographics, in which e.g. the colour and size of the glyphs carry additional information. -scatterLP - :: (Foldable t, RealFrac a, Show a) => - (l -> b -> a) -- ^ Modifies the glyph size - -> (l -> b -> a) -- ^ Modifies the glyph stroke width - -> (l -> C.Colour Double -> C.Colour Double) -- ^ Modifies the glyph colour - -> ScatterPointData b -- ^ Glyph style defaults - -> t (LabeledPoint l a) -- ^ Data - -> Svg -scatterLP f g h spdat lps = forM_ lps (scatterLP1 f g h spdat) +scatterLP :: (Foldable t, RealFrac a, Show a) => + (l -> b -> a) -- ^ Modifies the glyph size + -> (l -> b -> a) -- ^ Modifies the glyph stroke width + -> (l -> C.Colour Double -> C.Colour Double) -- ^ Modifies the glyph colour + -> (l -> b -> a) + -> ScatterPointData b -- ^ Glyph style defaults + -> t (LabeledPoint l a) -- ^ Data + -> Svg +scatterLP f g h i spdat lps = forM_ lps (scatterLP1 f g h i spdat) -scatterLP1 - :: (Show a, RealFrac a) => - (l -> b -> a) -- ^ Modifies the glyph size - -> (l -> b -> a) -- ^ Modifies the glyph stroke width - -> (l -> C.Colour Double -> C.Colour Double) -- ^ Modifies the glyph colour - -> ScatterPointData b - -> LabeledPoint l a - -> Svg -scatterLP1 f g h spdat lp = glyph w' sw' sh Nothing (Just col') (_lp lp) +scatterLP1 :: (Show a, RealFrac a) => + (l -> b -> a) -- ^ Modifies the glyph size + -> (l -> b -> a) -- ^ Modifies the glyph stroke width + -> (l -> C.Colour Double -> C.Colour Double) -- ^ Modifies the glyph colour + -> (l -> b -> a) -- ^ Modifies the glyph opacity + -> ScatterPointData b + -> LabeledPoint l a + -> Svg +scatterLP1 f g h i spdat lp = glyph w' sw' sh col' a' (_lp lp) where - ScatterPointData sh w' sw' col' = modifyScatterPoint f g h spdat lp + ScatterPointData sh w' sw' col' a' = modifyScatterPoint f g h i spdat lp -scatterLPBar - :: (RealFrac t, Enum t, RealFrac b, Show b) => - FigureData b - -> b -- ^ Legend width - -> t -- ^ Data value lower bound - -> t -- ^ Data value upper bound - -> Int -- ^ Number of legend entries - -> LegendPosition_ -- ^ Legend position in the figure - -> b -- ^ Legend length - -> (t -> b -> b) -- ^ Modifies the glyph size - -> (t -> b -> b) -- ^ Modifies the glyph stroke width - -> (t -> C.Colour Double -> C.Colour Double) -- ^ Modifies the glyph colour - -> ScatterPointData b -- ^ Glyph style defaults - -> Svg -scatterLPBar fdat w vmin vmax n legpos legh f g h spdat = legendBar fdat w vmin vmax n legpos legh fun where +scatterLPBar :: (RealFrac t, Enum t, RealFrac b, Show b) => + FigureData b + -> b -- ^ Legend width + -> t -- ^ Data value lower bound + -> t -- ^ Data value upper bound + -> Int -- ^ Number of legend entries + -> LegendPosition_ -- ^ Legend position in the figure + -> b -- ^ Legend length + -> (t -> b -> b) -- ^ Modifies the glyph size + -> (t -> b -> b) -- ^ Modifies the glyph stroke width + -> (t -> C.Colour Double -> C.Colour Double) -- ^ Modifies the glyph colour + -> (t -> b -> b) -- ^ Modifies the glyph opacity + -> ScatterPointData b -- ^ Glyph style defaults + -> Svg +scatterLPBar fdat w vmin vmax n legpos legh f g h i spdat = legendBar fdat w vmin vmax n legpos legh fun where wglyph = spSize spdat fun _ _ _ _ _ lp@(LabeledPoint p val) = do - scatterLP1 f g h spdat lp - text 0 (figLabelFontSize fdat) C.black TAStart (T.pack $ show (rr val :: Fixed E3)) (V2 (2*wglyph) (0.5*wglyph)) p + scatterLP1 f g h i spdat lp + text 0 (figLabelFontSize fdat) C.black TAStart (T.pack $ show (rr val :: Fixed E3)) (V2 (2 * wglyph) (0.5 * wglyph)) p @@ -88,18 +84,20 @@ , spSize :: a , spStrokeWidth :: a , spColour :: C.Colour Double + , spAlpha :: a } deriving (Eq, Show) -modifyScatterPoint - :: (a -> b -> c) - -> (a -> b -> c) - -> (a -> C.Colour Double -> C.Colour Double) +modifyScatterPoint :: + (l -> b -> c) -- ^ Modifies glyph size + -> (l -> b -> c) -- ^ Modifies glyph stroke width + -> (l -> C.Colour Double -> C.Colour Double) -- ^ Modifies glyph colour + -> (l -> b -> c) -- ^ Modifies glyph opacity -> ScatterPointData b - -> LabeledPoint a d + -> LabeledPoint l d -> ScatterPointData c -modifyScatterPoint f g h (ScatterPointData glsh sz w col) lp = - ScatterPointData glsh (f lab sz) (g lab w) (h lab col) +modifyScatterPoint f g h i (ScatterPointData glsh sz w col alpha) lp = + ScatterPointData glsh (f lab sz) (g lab w) (h lab col) (i lab alpha) where lab = _lplabel lp @@ -108,19 +106,23 @@ data GlyphShape_ = Square | Circle | Cross | Plus deriving (Eq, Show, Enum) -- | Scatterplot glyph shapes -glyph - :: (Show a, RealFrac a) => - a - -> a - -> GlyphShape_ - -> Maybe (C.Colour Double) - -> Maybe (C.Colour Double) - -> Point a - -> Svg -glyph w sw Square scol fcol p = squareCentered w sw scol fcol p -glyph w sw Circle scol fcol p = circle w sw scol fcol p -glyph w sw Cross _ fcol p = crossGlyph w sw (fromMaybe C.black fcol) p -glyph w sw Plus _ fcol p = plusGlyph w sw (fromMaybe C.black fcol) p +glyph :: (Show a, RealFrac a) => + a -- ^ Width + -> a -- ^ Stroke width + -> GlyphShape_ -- ^ Glyph shape + -> C.Colour Double -- ^ Glyph colour + -> a -- ^ Opacity + -> Point a -- ^ Position + -> Svg +glyph w sw sh col alpha p = + let cf = shapeColNoBorder col alpha + in + case sh of + Square -> squareCentered w cf p + Circle -> circle w cf p + Cross -> crossGlyph w sw col p + Plus -> plusGlyph w sw col p + -- -- | Utility function for cycling glyph colours and shapes (i.e. unique combinations of these make it easy to tell different datasets apart) diff --git a/src/Graphics/Rendering/Plot/Light/PlotTypes/TimeSeries.hs b/src/Graphics/Rendering/Plot/Light/PlotTypes/TimeSeries.hs --- a/src/Graphics/Rendering/Plot/Light/PlotTypes/TimeSeries.hs +++ b/src/Graphics/Rendering/Plot/Light/PlotTypes/TimeSeries.hs @@ -30,8 +30,7 @@ -- 2. Flip the data along the y axis since the origin in SVG is the top-left corner of the screen - - + -- tsAxis -- :: (Functor t, Foldable t, Show a, RealFrac a) => -- FigureData a @@ -68,7 +67,9 @@ fdat = frameToFrameValue from to baz = const (T.pack "") fplot lps = - forM_ lps (candlestick (>) fboxmin' fboxmax' fmin' fmax' 5 1 C.green C.red colAxis) + forM_ lps (candlestick (>) fboxmin' fboxmax' fmin' fmax' 5 1 colUp colDown colAxis) + colUp = shapeColBoth C.green colAxis 1 sw + colDown = shapeColBoth C.red colAxis 1 sw fboxmin' = fdat . fboxmin fboxmax' = fdat . fboxmax fmin' = fdat . fmin