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.1.0.7 +version: 0.1.0.8 synopsis: A lightweight plotting library, exporting to SVG description: A lightweight plotting library, exporting to SVG homepage: https://github.com/ocramz/plot-light @@ -28,6 +28,7 @@ Graphics.Rendering.Plot.Light.PlotTypes.Scatter Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries.Candlestick + Data.TimeSeries Data.TimeSeries.Forex Graphics.Rendering.Plot.Light.Internal.Geometry build-depends: base >= 4.7 && < 5 @@ -63,6 +64,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + other-modules: LibSpec build-depends: base , plot-light , hspec diff --git a/src/Data/TimeSeries.hs b/src/Data/TimeSeries.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimeSeries.hs @@ -0,0 +1,14 @@ +module Data.TimeSeries where + +import Data.Time + +-- | An instant, defined by date (Day) and TimeOfDay +data Tick = Tick Day TimeOfDay + deriving (Eq, Show, Ord) + +-- | A point in a time series +data TsPoint a = + Tsp { + _tick :: Tick, + _val :: a + } deriving (Eq, Show) diff --git a/src/Data/TimeSeries/Forex.hs b/src/Data/TimeSeries/Forex.hs --- a/src/Data/TimeSeries/Forex.hs +++ b/src/Data/TimeSeries/Forex.hs @@ -1,7 +1,7 @@ module Data.TimeSeries.Forex where -import Data.Time + data FxRow a = FxRow { rateOpen :: a , rateHigh :: a @@ -10,13 +10,4 @@ } deriving (Eq, Show) --- | An instant, defined by date (Day) and TimeOfDay -data Tick = Tick Day TimeOfDay - deriving (Eq, Show, Ord) --- | A point in a time series -data TsPoint a = - Tsp { - _tick :: Tick, - _val :: a - } deriving (Eq, Show) diff --git a/src/Graphics/Rendering/Plot/Light.hs b/src/Graphics/Rendering/Plot/Light.hs --- a/src/Graphics/Rendering/Plot/Light.hs +++ b/src/Graphics/Rendering/Plot/Light.hs @@ -11,7 +11,7 @@ -- -- == Usage -- --- To use this project you just need `import Graphics.Rendering.Plot.Light`. If GHC complains of name clashes you can import the module in "qualified" form. +-- To use this project you just need @import Graphics.Rendering.Plot.Light@. If GHC complains of name clashes you can import the module in "qualified" form. -- -- If you wish to try out the examples in this page, you will need to have these additional import statements: -- @@ -35,28 +35,26 @@ Mat2(..), DiagMat2(..), diagMat2, -- ** Primitive elements origin, e1, e2, - -- ** Vector operations + -- ** Vector norm operations norm2, normalize2, -- ** Vector construction v2fromEndpoints, v2fromPoint, -- ** Operations on points - movePoint, moveLabeledPointV2, fromUnitSquare, toUnitSquare, + movePoint, moveLabeledPointV2, (-.), + -- ** Operations on vectors + frameToFrame, -- ** Typeclasses AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..) ) where --- import Data.Foldable -import qualified Data.Text as T +-- import qualified Data.Text as T -import Text.Blaze.Svg --- import Text.Blaze.Svg11 ((!), mkPath, rotate, translate, l, m) --- import qualified Text.Blaze.Svg11 as S --- import qualified Text.Blaze.Svg11.Attributes as A -import Text.Blaze.Svg.Renderer.String (renderSvg) +-- import Text.Blaze.Svg +-- 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 qualified Data.Colour as C +-- import qualified Data.Colour.Names as C +-- import qualified Data.Colour.SRGB as C import Graphics.Rendering.Plot.Light.Internal diff --git a/src/Graphics/Rendering/Plot/Light/IO/Text.hs b/src/Graphics/Rendering/Plot/Light/IO/Text.hs --- a/src/Graphics/Rendering/Plot/Light/IO/Text.hs +++ b/src/Graphics/Rendering/Plot/Light/IO/Text.hs @@ -9,6 +9,7 @@ import Data.Time (Day, TimeOfDay) import qualified Attoparsec.Time as AT +import Data.TimeSeries import Data.TimeSeries.Forex 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,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -module Graphics.Rendering.Plot.Light.Internal (Frame(..), Point(..), LabeledPoint(..), Axis(..), svgHeader, rectCentered, circle, line, tick, ticks, axis, text, polyline, strokeLineJoin, LineStroke_(..), StrokeLineJoin_(..), TextAnchor_(..), V2(..), Mat2(..), DiagMat2(..), diagMat2, AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..), norm2, normalize2, v2fromEndpoints, v2fromPoint, origin, movePoint, moveLabeledPointV2, fromUnitSquare, toUnitSquare, e1, e2) where +module Graphics.Rendering.Plot.Light.Internal (Frame(..), mkFrame, mkFrameOrigin, frameToFrame, frameFromDataset, Point(..), mkPoint, LabeledPoint(..), mkLabeledPoint, Axis(..), svgHeader, rectCentered, circle, line, tick, ticks, axis, text, polyline, strokeLineJoin, LineStroke_(..), StrokeLineJoin_(..), TextAnchor_(..), V2(..), Mat2(..), DiagMat2(..), diagMat2, AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..), norm2, normalize2, v2fromEndpoints, v2fromPoint, origin, (-.), movePoint, moveLabeledPointV2, moveLabeledPointV2Frames, e1, e2) where import Data.Monoid ((<>)) import qualified Data.Foldable as F (toList) import Data.List -import Control.Arrow ((&&&), (***)) +-- import Control.Arrow ((&&&), (***)) import Control.Monad (forM, forM_) -import Data.Semigroup (Min(..), Max(..)) +-- import Data.Semigroup (Min(..), Max(..)) import Data.Scientific (Scientific, toRealFloat) -- import Data.Foldable @@ -30,13 +30,13 @@ -- | Create the SVG header from a `Frame` -svgHeader :: Frame Int -> Svg -> Svg +svgHeader :: Real a => Frame a -> Svg -> Svg svgHeader fd = S.docTypeSvg ! SA.version "1.1" - ! SA.width (vi $ width fd) - ! SA.height (vi $ height fd) - ! SA.viewbox (vis [xmin fd, ymin fd, xmax fd, ymax fd]) + ! SA.width (vd $ width fd) + ! SA.height (vd $ height fd) + ! SA.viewbox (vds [xmin fd, ymin fd, xmax fd, ymax fd]) @@ -83,56 +83,74 @@ -tick :: (Show a, RealFrac a) => Axis -> a -> a -> C.Colour Double -> LineStroke_ a -> Point a -> Svg -tick ax len sw col ls (Point x y) = line (Point x1 y1) (Point x2 y2) sw ls col where +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) -tickX, tickY :: (Show a, RealFrac a) => - a -- ^ Length - -> a -- ^ Stroke width - -> C.Colour Double -- ^ Stroke colour - -> LineStroke_ a - -> Point a -- ^ Center coordinates - -> Svg -tickX = tick X -tickY = tick Y +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 + -> V2 a -- ^ Label shift + -> LabeledPoint t a + -> Svg +labeledTick ax len sw col fontsize lrot tanchor flab vlab (LabeledPoint p label) = do + let ls = Continuous + 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 - -> LineStroke_ a -> t (Point a) -- ^ Center coordinates -> Svg -ticks ax len sw col ls ps = forM_ ps (tick ax len sw col ls) +ticks ax len sw col ps = forM_ ps (tick ax len sw col) --- | An axis with tickmarks +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 X 200 2 C.red 0.05 (Point 150 10) Continuous [Point 50 1, Point 60 1, Point 70 1] --- > +-- > > 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) => - Axis -- ^ Axis (i.e. either `X` or `Y`) - -> a -- ^ Length + 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 -- ^ Tick length fraction (w.r.t axis length) - -> Point a -- ^ Axis center coordinate - -> LineStroke_ a - -> t (Point a) -- ^ Tick center coordinates + -> 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 ax len sw col tickLenFrac p@(Point x y) ls ps = do - tick ax len sw col ls p - ticks (otherAxis ax) (tickLenFrac * len) sw col ls (f <$> ps) - where - f | ax == X = setPointY y - | otherwise = setPointX x - +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 -- * text @@ -150,14 +168,15 @@ -- > > 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 frame + a -- ^ Rotation angle of the frame + -> Int -- ^ Font size -> C.Colour Double -- ^ Font colour - -> TextAnchor_ + -> TextAnchor_ -- ^ How to anchor a text label to the axis -> T.Text -- ^ Text -> V2 a -- ^ Displacement w.r.t. rotated frame -> Point a -- ^ Reference frame origin of the text box -> Svg -text rot 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.fill (colourAttr col) ! textAnchor ta +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) @@ -195,8 +214,8 @@ polyline :: (Foldable t, Show a1, Show a, RealFrac a, RealFrac a1) => t (Point a) -- ^ Data -> a1 -- ^ Stroke width - -> LineStroke_ a - -> StrokeLineJoin_ + -> LineStroke_ a -- ^ Stroke type + -> StrokeLineJoin_ -- ^ Stroke join type -> C.Colour Double -- ^ Stroke colour -> Svg polyline lis sw Continuous slj col = 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 @@ -245,14 +264,9 @@ vs :: String -> S.AttributeValue vs x = S.toValue (x :: String) --- Int - vi :: Int -> S.AttributeValue vi = S.toValue --- | For use e.g. in `viewbox` -vis :: [Int] -> S.AttributeValue -vis = S.toValue . unwords . map show -- Double vd0 :: Double -> S.AttributeValue @@ -264,37 +278,16 @@ real :: (Real a, Fractional b) => a -> b real = fromRational . toRational -showd :: Real a => a -> String -showd = show . real --- vds :: [Double] -> S.AttributeValue --- vds = S.toValue . unwords . map show +vds :: Real a => [a] -> S.AttributeValue +vds = S.toValue . unwords . map (show . real) --- -- Float --- vf :: Float -> S.AttributeValue --- vf = S.toValue --- vfs :: [Float] -> S.AttributeValue --- vfs = S.toValue . unwords . map show - - --- - --- main :: IO () --- main = do --- let a = renderSvg svgDoc --- putStrLn a - --- svgDoc :: S.Svg --- svgDoc = S.docTypeSvg ! A.version "1.1" ! A.width "150" ! A.height "100" ! A.viewbox "0 0 3 2" $ do --- S.g ! A.transform makeTransform $ do --- -- S.rect ! A.width "1" ! A.height "2" ! A.fill "#008d46" --- -- S.rect ! A.width "1" ! A.height "2" ! A.fill "#ffffff" -- S.rect ! A.width "1" ! A.height "2" ! A.fill "#d2232c" -- -- S.path ! A.d makePath 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 @@ -5,8 +5,10 @@ -} module Graphics.Rendering.Plot.Light.Internal.Geometry where -import Data.Monoid ((<>)) +-- import Data.Monoid ((<>)) + + -- | A `Point` defines a point in R2 data Point a = Point { _px :: a, _py :: a } deriving (Eq) @@ -34,6 +36,9 @@ _lplabel :: l } deriving (Eq, Show) +mkLabeledPoint :: Point a -> l -> LabeledPoint l a +mkLabeledPoint = LabeledPoint + moveLabeledPoint :: (Point a -> Point b) -> LabeledPoint l a -> LabeledPoint l b moveLabeledPoint f (LabeledPoint p l) = LabeledPoint (f p) l @@ -43,6 +48,30 @@ _fpmax :: Point a } deriving (Eq, Show) +mkFrame :: Point a -> Point a -> Frame a +mkFrame = Frame + +-- | Build a frame rooted at the origin (0, 0) +mkFrameOrigin :: Num a => a -> a -> Frame a +mkFrameOrigin w h = Frame origin (Point w h) + + +-- | Create a `Frame` from a container of `LabeledPoint`s `P`, i.e. construct two points `p1` and `p2` such that : +-- +-- p1 := inf(x,y) P +-- p2 := sup(x,y) P +frameFromDataset :: + (Functor t, Ord a, Foldable t) => t (LabeledPoint l a) -> Frame a +frameFromDataset ds = mkFrame (Point mx my) (Point mmx mmy) + where + xcoord = _px . _lp <$> ds + ycoord = _py . _lp <$> ds + mmx = maximum xcoord + mmy = maximum ycoord + mx = minimum xcoord + my = minimum ycoord + + -- | Frame corner coordinates xmin, xmax, ymin, ymax :: Frame a -> a xmin = _px . _fpmin @@ -67,21 +96,9 @@ --- * Dataset --- data Dataset l a = Dataset --- { --- dsdat :: [LabeledPoint l a] --- , dsframe ::Frame a --- } deriving (Eq, Show) --- instance Monoid (Dataset l a) where - - - - - @@ -92,7 +109,7 @@ -- | Vectors form a monoid w.r.t. vector addition instance Num a => Monoid (V2 a) where mempty = V2 0 0 - (V2 a b) `mappend` (V2 c d) = V2 (a + b) (c + d) + (V2 a b) `mappend` (V2 c d) = V2 (a + c) (b + d) -- | Additive group : -- @@ -173,14 +190,25 @@ instance Num a => LinearMap (Mat2 a) (V2 a) where (Mat2 a00 a01 a10 a11) #> (V2 vx vy) = V2 (a00 * vx + a01 * vy) (a10 * vx + a11 * vy) --- | Create a diagonal matrix -diagMat2 :: Num a => a -> a -> Mat2 a -diagMat2 rx ry = Mat2 rx 0 0 ry + -- | Diagonal matrices in R2 behave as scaling transformations data DiagMat2 a = DMat2 a a deriving (Eq, Show) +-- | Diagonal matrices form a monoid w.r.t. matrix multiplication and have the identity matrix as neutral element +instance Num a => Monoid (DiagMat2 a) where + mempty = DMat2 1 1 + mappend = (##) +-- | Matrices form a monoid w.r.t. matrix multiplication and have the identity matrix as neutral element +instance Num a => Monoid (Mat2 a) where + mempty = Mat2 1 0 0 1 + mappend = (##) + +-- | Create a diagonal matrix +diagMat2 :: Num a => a -> a -> DiagMat2 a +diagMat2 = DMat2 + -- | The class of invertible linear transformations class LinearMap m v => MatrixGroup m v where -- | Inverse matrix action on a vector @@ -209,37 +237,66 @@ moveLabeledPointV2 = moveLabeledPoint . movePoint --- | The vector translation from a `Point` contained in a `Frame` onto the unit square + + +fromFrame :: Fractional a => Frame a -> V2 a -> V2 a +fromFrame from v = mfrom <\> (v ^-^ vfrom) where + vfrom = v2fromPoint (_fpmin from) -- min.point vector of `from` + mfrom = diagMat2 (width from) (height from) -- rescaling matrix of `from` + +toFrame :: Num a => Frame a -> V2 a -> V2 a +toFrame to v01 = (mto #> v01) ^+^ vto where + vto = v2fromPoint (_fpmin to) -- min.point vector of `to` + mto = diagMat2 (width to) (height to) -- rescaling matrix of `to` + + + + +-- | Given two frames `F1` and `F2`, returns a function `f` that maps an arbitrary vector `v` that points within `F1` to one contained within `F2`. -- --- NB: we do not check that `p` is actually contained within the frame. This has to be supplied correctly by the user -toUnitSquare :: (Fractional a, MatrixGroup (Mat2 a) (V2 a)) => - Frame a -> Point a -> Point a -toUnitSquare from p = movePoint vmove p +-- 1. map `v` into a unit square vector `v01` with an affine transformation +-- +-- 2. (optional) map `v01` into another point in the unit square via a linear rescaling +-- +-- 3. map `v01'` onto `F2` with a second affine transformation +-- +-- NB: we do not check that `v` is actually contained within the `F1`. This has to be supplied correctly by the user. +frameToFrame :: (Fractional a, LinearMap m (V2 a)) => + Frame a -- ^ Initial frame + -> Frame a -- ^ Final frame + -> m -- ^ Optional rescaling in [0,1] x [0,1] + -> V2 a -- ^ Optional shift + -> V2 a -- ^ Initial vector + -> V2 a +frameToFrame from to mopt vopt v = toFrame to v01' where - mm = diagMat2 (width from) (height from) - o1 = _fpmin from - vmove = mm <\> (p -. o1) + v01 = fromFrame from v + v01' = (mopt #> v01) ^+^ vopt --- | The vector translation from a `Point` `p` contained in the unit square onto a `Frame` --- --- NB: we do not check that `p` is actually contained in [0,1] x [0,1], This has to be supplied correctly by the user -fromUnitSquare :: Num a => Frame a -> Point a -> Point a -fromUnitSquare to p = movePoint vmove p +moveLabeledPointV2Frames :: + (LinearMap m (V2 a), Fractional a) => + Frame a -- ^ Initial frame + -> Frame a -- ^ Final frame + -> m -- ^ Optional rescaling in [0,1] x [0,1] + -> V2 a -- ^ Optional shift + -> LabeledPoint l a -- ^ Initial `LabeledPoint` + -> LabeledPoint l a +moveLabeledPointV2Frames from to mopt vopt lp = moveLabeledPointV2 vmove lp where - mm = diagMat2 (width to) (height to) - vo = v2fromPoint (_fpmin to) - vmove = (mm #> v2fromPoint p) ^+^ vo + vlp = v2fromPoint $ _lp lp -- vector associated with starting point + vmove = frameToFrame from to mopt vopt vlp -- frame translation vector --- * HasFrame : things which have a bounding box -class HasFrame v where - type UnitInterval v :: * - type FrameType v :: * - fromFrame :: v -> UnitInterval v - toFrame :: UnitInterval v -> v +-- -- * HasFrame : things which have a bounding box +-- class HasFrame v where +-- type UnitInterval v :: * +-- type FrameType v :: * +-- fromFrame :: v -> UnitInterval v +-- toFrame :: UnitInterval v -> v + -- | X-aligned unit vector e1 :: Num a => V2 a e1 = V2 1 0 @@ -271,6 +328,3 @@ --- class Located v where --- type Coords v :: * --- position :: v -> Coords v 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 @@ -1,45 +1,90 @@ +{-# language OverloadedStrings #-} +{-# language FlexibleContexts #-} module Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries where import GHC.Real import Data.Fixed (Pico) import Data.Time +import Data.Scientific + import qualified Data.Text as T import Graphics.Rendering.Plot.Light.Internal -import Data.TimeSeries.Forex +import Data.TimeSeries +-- For debugging +import Text.Blaze.Svg +import qualified Data.Colour as C +import qualified Data.Colour.Names as C +import Text.Blaze.Svg.Renderer.String (renderSvg) + -- | Compute the plotting coordinates of a timeseries point -- | Preprocess the dataset for plotting -- 1. Remap the figure data to fit within the FigData ranges, expressed in pixels -- 2. Flip the data along the y axis since the origin in SVG is the top-left corner of the screen +-- tsAxis :: (Num a, LinearMap (DiagMat2 a) (V2 a), RealFrac a, Show a, +-- Foldable t, Functor t) => +-- (a -> a) +-- -> a +-- -> a +-- -> a +-- -> C.Colour Double +-- -> a +-- -> t (TsPoint a) +-- -> Svg +tsAxis fval wFig hFig sw col rot ps = dat' -- axis origin X wFig sw col 0.01 Continuous rot TAEnd T.pack (V2 (-10) 0) dat' + where + lpFun = tspToLP fval (\t _ -> show t) + dat = lpFun <$> ps + frameFrom = frameFromDataset dat + frameTo = mkFrameOrigin wFig hFig + dat' = moveLabeledPointV2Frames frameFrom frameTo (mempty :: DiagMat2 Scientific) (V2 0 0) <$> dat --- * Helpers +nth xss n = reverse $ go xss n [] where + go (_:xs) i l | i>0 = go xs (i-1) l + go (x:xs) i l | i==0 = go xs n (x : l) + go [] _ l = l --- | Create a Tick from valid (year, month, day, hour, minute, second) -mkTick :: Integer -> Int -> Int -> Int -> Int -> Pico -> Maybe Tick -mkTick yy mm dd hr mi se = do - tim <- makeTimeOfDayValid hr mi se - let d = fromGregorian yy mm dd - return $ Tick d tim + +-- * Helpers -tspToTuple :: (a -> b) -> TsPoint a -> (Float, b) -tspToTuple f tsp = (tickToFloat tsp, f $ _val tsp) +-- | Create a `LabeledPoint` from a time series point (`TsPoint`). The `_tick` (time axis) field will be used for the x coordinate, whereas both fields of TsPoint may be used to create the label field. +-- +-- NB : The coordinates of the resulting LabelPoint still live in the original data space; they must be rescaled to fit in the figure viewport +tspToLP :: Fractional a => + (t -> a) + -> (Tick -> t -> l) + -> TsPoint t + -> LabeledPoint l a +tspToLP fy g = LabeledPoint <$> pf <*> lf where + pf = Point <$> tickToFractional <*> fy . _val + lf = g <$> _tick <*> _val -tickToFloat :: TsPoint a -> Float -tickToFloat = fromRational . fromTick . _tick + +tickToFractional :: Fractional b => TsPoint a -> b +tickToFractional = fromRational . fromTick . _tick -- | Map a Tick onto the rationals fromTick :: Tick -> Rational fromTick (Tick d t) = fromIntegral (toModifiedJulianDay d) + timeOfDayToDayFraction t + + + +-- | Create a Tick from valid (year, month, day, hour, minute, second) +mkTick :: Integer -> Int -> Int -> Int -> Int -> Pico -> Maybe Tick +mkTick yy mm dd hr mi se = do + tim <- makeTimeOfDayValid hr mi se + let d = fromGregorian yy mm dd + return $ Tick d tim diff --git a/test/LibSpec.hs b/test/LibSpec.hs new file mode 100644 --- /dev/null +++ b/test/LibSpec.hs @@ -0,0 +1,129 @@ +{-# language FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-} +module LibSpec where + +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import Graphics.Rendering.Plot.Light + +main :: IO () +main = hspec spec + +spec :: Spec +spec = + describe "Graphics.Rendering.Plot.Light" $ do + -- it "works" $ + -- True `shouldBe` True + prop "V2 : additive group [Float]" $ \(v :: V2r Float) -> + prop_V2_additiveGroup v `shouldBe` True + prop "V2 : additive group [Double]" $ \(v :: V2 Double) -> + prop_V2_additiveGroup v `shouldBe` True + prop "Mat2 : multiplicative group [Float]: m <\\> (m #> v) ~= v" $ + \(PropDiagMatVec (m :: DiagMat2r Float) v ) -> prop_multMatGroup m v `shouldBe` True + prop "Mat2 : multiplicative group [Double]: m <\\> (m #> v) ~= v" $ + \(PropDiagMatVec (m :: DiagMat2r Double) v ) -> prop_multMatGroup m v `shouldBe` True + it "Frame : frameToFrame works" $ do + let from = Frame (Point 5 1) (Point 8 3) :: Frame Double + to = Frame (Point 1 2) (Point 4 4) + v1 = v2fromPoint $ Point 7 2 + mopt = diagMat2 1 1 :: DiagMat2 Double + vopt = V2 0 0 + v2 = frameToFrame from to mopt vopt v1 + p2 = movePoint v2 origin + -- p2 `shouldBe` Point 3 3 + norm2 (p2 -. Point 3 3) ~= 0 `shouldBe` True + + + + + + + + + + + +-- * Properties + +prop_V2_additiveGroup + :: (Eps v, VectorSpace v, Num (Scalar v)) => v -> Bool +prop_V2_additiveGroup v = + v ^+^ zero ~= v && + (v ^+^ v) ~= (2 .* v) && + (v ^-^ v) ~= zero + +prop_multMatGroup :: (MatrixGroup m v, Eps v) => m -> v -> Bool +prop_multMatGroup m v = m <\> (m #> v) ~= v + + + + +data PropMatVec a = PropMatVec (Mat2r a) (V2r a) deriving (Eq, Show) +instance Arbitrary (PropMatVec Float) where + arbitrary = PropMatVec <$> arbitrary <*> arbitrary + +data PropDiagMatVec a = PropDiagMatVec (DiagMat2r a) (V2r a) deriving (Eq, Show) +instance Arbitrary (PropDiagMatVec Float) where + arbitrary = PropDiagMatVec <$> arbitrary <*> arbitrary + +instance Arbitrary (PropDiagMatVec Double) where + arbitrary = PropDiagMatVec <$> arbitrary <*> arbitrary + + + + + +-- * Newtypes and their Arbitrary instances + + +-- | Float +type V2r a = V2 a +type Mat2r a = Mat2 a +type DiagMat2r a = DiagMat2 a + +instance Arbitrary (V2r Float) where + arbitrary = genV2 + +instance Arbitrary (Mat2r Float) where + arbitrary = genMat2 + +instance Arbitrary (DiagMat2r Float) where + arbitrary = genDiagMat2nz + + +-- | Double +instance Arbitrary (V2r Double) where + arbitrary = genV2 + +instance Arbitrary (Mat2r Double) where + arbitrary = genMat2 + +instance Arbitrary (DiagMat2r Double) where + arbitrary = genDiagMat2nz + + + + + +-- helpers + +sized2 :: (Int -> Int -> Gen a) -> Gen a +sized2 f = sized $ \i -> sized $ \j -> f i j + + +genV2 :: (Arbitrary a, Num a) => Gen (V2 a) +genV2 = V2 <$> arbitrary <*> arbitrary + +genDiagMat2 :: (Arbitrary a, Num a) => Gen (DiagMat2 a) +genDiagMat2 = DMat2 <$> arbitrary <*> arbitrary + +genDiagMat2nz :: (Num a, Arbitrary a, Ord a) => Gen (DiagMat2 a) +genDiagMat2nz = do + d1 <- arbitrary `suchThat` (> 0) + d2 <- arbitrary `suchThat` (> 0) + pure (DMat2 d1 d2) + +genMat2 :: (Arbitrary a, Num a) => Gen (Mat2 a) +genMat2 = Mat2 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +