diff --git a/app/timeseries/Main.hs b/app/timeseries/Main.hs --- a/app/timeseries/Main.hs +++ b/app/timeseries/Main.hs @@ -1,15 +1,46 @@ +{-# language OverloadedStrings #-} module Main where -import Graphics.Rendering.Plot.Light.IO.Text +import Control.Arrow ((***), (&&&)) -import qualified Data.Attoparsec.Text as A -import qualified Data.Text.IO as T +-- import Graphics.Rendering.Plot.Light.IO.Text +-- import Graphics.Rendering.Plot.Light.Internal +-- -- import Graphics.Rendering.Plot.Light.Internal.Types +-- import Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries +-- -- import Data.TimeSeries.Forex + +-- import qualified Data.Attoparsec.Text as A +-- import qualified Data.Text as T +-- import qualified Data.Text.IO as T +-- import Data.Scientific (Scientific, toRealFloat) +-- import Text.Blaze.Svg.Renderer.String (renderSvg) +-- import qualified Data.Colour.Names as C + fname = "data/forex" -main = do - d <- T.readFile fname - let pd = A.parseOnly parseFxDataset d - case pd of Left e -> error e - Right datarows -> pure datarows +xPlot = 400 +yPlot = 300 +fnameOut = "data/forex_plot.svg" + +-- figData = mkFigureData 10 10 xPlot yPlot + +main = print "hello!" + +-- main = do +-- d <- T.readFile fname +-- let pd = A.parseOnly parseFxDataset d +-- case pd of Left e -> error e +-- Right datarows -> do +-- let +-- dat = tspToTuple rateHigh <$> reverse datarows +-- (dat', fdat) = mkFigureData xPlot yPlot toFloat dat +-- svg_t = renderSvg $ figure fdat +-- (polyline dat' 0.5 C.red) +-- T.writeFile fnameOut $ T.pack svg_t + +-- toFloat :: Scientific -> Float +-- toFloat x = toRealFloat x :: Float + + diff --git a/plot-light.cabal b/plot-light.cabal --- a/plot-light.cabal +++ b/plot-light.cabal @@ -1,7 +1,7 @@ name: plot-light -version: 0.1.0.1 +version: 0.1.0.2 synopsis: A lightweight plotting library, exporting to SVG --- description: +description: A lightweight plotting library, exporting to SVG homepage: https://github.com/ocramz/plot-light license: BSD3 license-file: LICENSE @@ -21,14 +21,15 @@ default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src - exposed-modules: Lib - Graphics.Rendering.Plot.Light + exposed-modules: Graphics.Rendering.Plot.Light + other-modules: Graphics.Rendering.Plot.Light.Internal Graphics.Rendering.Plot.Light.IO.Text Graphics.Rendering.Plot.Light.PlotTypes.Heatmap Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries - other-modules: Data.TimeSeries.Forex + Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries.Candlestick Data.TimeSeries.Forex Graphics.Rendering.Plot.Light.Internal.Types + Graphics.Rendering.Plot.Light.Internal.Geometry build-depends: base >= 4.7 && < 5 , time , attoparsec-time @@ -47,8 +48,11 @@ main-is: Main.hs build-depends: base , plot-light - , attoparsec - , text + -- , attoparsec + -- , text + -- , colour + -- , blaze-svg + -- , scientific test-suite spec default-language: Haskell2010 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,16 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} module Graphics.Rendering.Plot.Light.Internal where +import Data.Monoid ((<>)) import Control.Arrow ((&&&), (***)) +import Control.Monad (forM, forM_) +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.Svg -import Text.Blaze.Svg11 -- ((!), mkPath, rotate, translate, l, m) -import qualified Text.Blaze.Svg11 as S -import qualified Text.Blaze.Svg11.Attributes as S +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 @@ -20,53 +24,148 @@ import GHC.Real import Graphics.Rendering.Plot.Light.Internal.Types - - --- axis f1 figd = undefined --- where --- d = f1 <$> _figData figd -- pick out data --- numd = length d --- mm = maximum d --- m = minimum d +import Graphics.Rendering.Plot.Light.Internal.Geometry +mkFigureData :: Num a => a -> a -> a -> a -> FigureData a +mkFigureData xmin ymin xlen ylen = + FigData xlen ylen xmin (xmin + xlen) ymin (ymin + ylen) -- | Header for a Figure -figure :: FigureData Int d -> Svg -> Svg +figure :: FigureData Int -> Svg -> Svg figure fd = S.docTypeSvg - ! S.version "1.1" - ! S.width (vi $ _width fd) - ! S.height (vi $ _height fd) - ! S.viewbox (vis [_xmin fd, _ymin fd, _xmax fd, _ymax fd]) + ! 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]) -- | A filled rectangle, centered at (x0, y0) rectCentered :: Double -> Double -> Double -> Double -> C.Colour Double -> Svg -rectCentered x0 y0 wid hei col = S.g ! S.transform (translate x0c y0c) $ - S.rect ! S.width (vd wid) ! S.height (vd hei) ! S.fill (colourAttr col) where +rectCentered x0 y0 wid hei col = S.g ! SA.transform (S.translate x0c y0c) $ + S.rect ! SA.width (vd wid) ! SA.height (vd hei) ! SA.fill (colourAttr col) where x0c = x0 - (wid / 2) y0c = y0 - (hei / 2) -- centeredAt x0 y0 = S.g ! A.transform (translate x0 y0) +-- | Line segment +-- +-- e.g. +-- > putStrLn $ renderSvg (line 0 0 1 1 0.1 C.blueviolet) +-- +-- +line :: Double -> Double -> Double -> Double -> Double -> C.Colour Double -> Svg +line x1 y1 x2 y2 sw col = 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) -line x1 x2 y1 y2 = S.line ! S.x1 (vd x1) ! S.x2 (vd x2) ! S.y1 (vd y1) ! S.y2 (vd y2) +tick :: Axis -> Double -> Double -> C.Colour Double -> Point Double -> Svg +tick ax len sw col (Point x y) = line x1 y1 x2 y2 sw 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 :: + Double -- | Length + -> Double -- | Stroke width + -> C.Colour Double -- | Stroke colour + -> Point Double -- | Center coordinates + -> Svg +tickX = tick X +tickY = tick Y +-- | 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 => + Axis -- | Axis + -> Double -- | Length + -> Double -- | Stroke width + -> C.Colour Double -- | Stroke colour + -> t (Point Double) -- | Center coordinates + -> Svg +ticks ax len sw col ps = forM_ ps (tick ax len sw col) + + +-- | An axis with tickmarks +-- +-- λ> putStrLn $ renderSvg $ axis X 200 2 C.red 0.05 (Point 150 10) [Point 50 1, Point 60 1, Point 70 1] +-- +axis :: (Functor t, Foldable t) => + Axis + -> Double + -> Double + -> C.Colour Double + -> Double + -> Point Double + -> t (Point Double) + -> Svg +axis ax len sw col tickLenFrac p@(Point x y) ps = do + tick ax len sw col p + ticks (otherAxis ax) (tickLenFrac * len) sw col (f <$> ps) + where + f | ax == X = setPointY y + | otherwise = setPointX x + + + +-- * text + +-- | `text` renders text onto the SVG canvas. It is also possible to rotate and move the text, however the order of these modifier matters. +-- NB1: `x` and `y` determine the position of the bottom-left corner of the text box. If a nonzero rotation is applied, the whole text box will move in a circle of radius || x^2 + y^2 || +-- NB2: the `rotate` and `translate` apply to the _center_ of the text box instead +-- +-- > putStrLn $ renderSvg $ text (-45) C.red "hullo!" (V2 (-30) 0) (Point 0 20) +-- hullo! +text :: (Show a, Show a1, S.ToValue a2) => + a1 -- | Rotation angle + -> C.Colour Double -- | Font colour + -> T.Text -- | Text + -> V2 a2 -- | Displacement + -> Point a -- | Initial center position of the text box + -> Svg +text rot col te (V2 x y) (Point dx dy) = + S.text_ (S.toMarkup te) ! SA.x (S.toValue x) ! SA.y (S.toValue y) ! SA.transform (S.translate dx dy <> S.rotate rot) ! SA.fill (colourAttr col) + + + +-- + +-- + +-- | Polyline (piecewise straight line) +-- e.g. +-- > putStrLn $ renderSvg (polyline [(1,1), (2,1), (2,2), (3,4)] 0.1 C.red) +-- +-- +polyline :: (Show a1, Show a) => [(a1, a)] -> Double -> C.Colour Double -> Svg +polyline lis sw col = S.polyline ! SA.points (S.toValue $ unwords $ map showP2 lis) ! SA.fill none ! SA.stroke (colourAttr col )! SA.strokeWidth (vd sw) ! SA.strokeLinejoin (S.toValue ("round" :: String)) + +showP2 :: (Show a, Show a1) => (a1, a) -> String +showP2 (x, y) = show x ++ "," ++ show y + + +none :: S.AttributeValue +none = S.toValue ("none" :: String) + + + -- * Helpers -- | Given a point `x` in a range [x1min, x1max], map it by affine transformation onto the interval [x2min, x2max] +-- More precisely, first it maps `x` onto the unit interval and from this onto the interval of interest affine :: Fractional t => t -> t -> t -> t -> t -> t -affine x2min x2max x1min x1max x = (x - x1min)*d2/d1 + x2min where +affine = withAffine id + +-- | Applies a function to the values in the unit interval +withAffine :: Fractional t => (t -> t) -> t -> t -> t -> t -> t -> t +withAffine f x2min x2max x1min x1max x = (f (x - x1min)/d1)*d2 + x2min where d1 = x1max - x1min d2 = x2max - x2min - @@ -78,16 +177,23 @@ vi :: Int -> S.AttributeValue vi = S.toValue - -- | For use e.g. in `viewbox` vis :: [Int] -> S.AttributeValue vis = S.toValue . unwords . map show +-- Double vd :: Double -> S.AttributeValue vd = S.toValue +vds :: [Double] -> S.AttributeValue +vds = S.toValue . unwords . map show +-- Float +vf :: Float -> S.AttributeValue +vf = S.toValue +vfs :: [Float] -> S.AttributeValue +vfs = S.toValue . unwords . map show -- diff --git a/src/Graphics/Rendering/Plot/Light/Internal/Geometry.hs b/src/Graphics/Rendering/Plot/Light/Internal/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Plot/Light/Internal/Geometry.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# language TypeFamilies, FlexibleContexts #-} +{- | +This module provides functionality for working with affine transformations (i.e. in the unit square) + +-} +module Graphics.Rendering.Plot.Light.Internal.Geometry where + +import Graphics.Rendering.Plot.Light.Internal.Types + + + +-- | V2 is a vector in R^2 +data V2 a = V2 a a deriving (Eq, Show) + +-- | 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) + +-- | Additive group : +-- v ^+^ zero = zero ^+^ v = v +-- v ^-^ v == zero +class AdditiveGroup v where + zero :: v + (^+^) :: v -> v -> v + (^-^) :: v -> v -> v + +instance Num a => AdditiveGroup (V2 a) where + zero = mempty + (^+^) = mappend + (V2 a b) ^-^ (V2 c d) = V2 (a - c) (b - d) + +-- | Vector space : multiplication by a scalar quantity +class AdditiveGroup v => VectorSpace v where + type Scalar v :: * + (.*) :: Scalar v -> v -> v + +instance Num a => VectorSpace (V2 a) where + type Scalar (V2 a) = a + n .* (V2 vx vy) = V2 (n*vx) (n*vy) + +-- | Hermitian space : inner product +class VectorSpace v => Hermitian v where + type InnerProduct v :: * + (<.>) :: v -> v -> InnerProduct v + +instance Num a => Hermitian (V2 a) where + type InnerProduct (V2 a) = a + (V2 a b) <.> (V2 c d) = (a*c) + (b*d) + +-- | Euclidean (L^2) norm +norm2 :: + (Hermitian v, Floating n, n ~ (InnerProduct v)) => v -> n +norm2 v = sqrt $ v <.> v + +-- | Normalize a V2 w.r.t. its Euclidean norm +normalize2 :: (InnerProduct v ~ Scalar v, Floating (Scalar v), Hermitian v) => + v -> v +normalize2 v = (1/norm2 v) .* v + + +-- | Create a V2 `v` from two endpoints p1, p2. That is `v` can be seen as pointing from `p1` to `p2` +mkV2fromEndpoints, (-.) :: Num a => Point a -> Point a -> V2 a +mkV2fromEndpoints (Point px py) (Point qx qy) = V2 (qx-px) (qy-py) +(-.) = mkV2fromEndpoints + +-- | The origin of the axes, point (0, 0) +origin :: Num a => Point a +origin = Point 0 0 + + +-- | A Mat2 can be seen as a linear operator V2 -> V2 +data Mat2 a = Mat2 a a a a deriving (Eq, Show) + +-- | Linear maps, i.e. linear transformations of vectors +class Hermitian v => LinearMap m v where + (#>) :: m -> v -> v + +-- | Multiplicative matrix semigroup ("multiplying" two matrices together) +class MultiplicativeSemigroup m where + (##) :: m -> m -> m + +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) + +-- | 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) + +-- | Create a diagonal matrix +mkDMat2 :: a -> a -> DiagMat2 a +mkDMat2 = DMat2 + +-- | The class of invertible linear transformations +class LinearMap m v => MatrixGroup m v where + (<\>) :: m -> v -> v + +instance Num a => MultiplicativeSemigroup (DiagMat2 a) where + DMat2 a b ## DMat2 c d = DMat2 (a*c) (b*d) + +-- | Diagonal matrices can always be inverted +instance Num a => LinearMap (DiagMat2 a) (V2 a) where + DMat2 d1 d2 #> V2 vx vy = V2 (d1 * vx) (d2 * vy) +instance Fractional a => MatrixGroup (DiagMat2 a) (V2 a) where + DMat2 d1 d2 <\> V2 vx vy = V2 (vx / d1) (vy / d2) + +-- | Build a V2 from a `Point` p (i.e. assuming the V2 points from the origin (0,0) to p) +v2fromPoint :: Num a => Point a -> V2 a +v2fromPoint p = origin -. p + +-- | Move a point along a vector +movePoint :: Num a => V2 a -> Point a -> Point a +movePoint (V2 vx vy) (Point px py) = Point (px + vx) (py + vy) + +-- | Move a `LabeledPoint` along a vector +moveLabeledPointV2 :: Num a => V2 a -> LabeledPoint l a -> LabeledPoint l a +moveLabeledPointV2 = moveLabeledPoint . movePoint + + +-- | The vector translation from a `Point` contained in a `Frame` onto the unit square +-- +-- 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 => Frame a -> Point a -> Point a +toUnitSquare from p = movePoint vmove p + where + mm = mkDMat2 (width from) (height from) + o1 = _fpmin from + vmove = mm <\> (p -. o1) + +-- | The vector translation from a `Point` 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 + where + mm = mkDMat2 (width to) (height to) + vo = v2fromPoint (_fpmin to) + vmove = (mm #> v2fromPoint p) ^+^ vo + + +-- | Coordinate unit vectors +e1, e2 :: Num a => V2 a +e1 = V2 1 0 +e2 = V2 0 1 + + + + + + +-- class Located v where +-- type Coords v :: * +-- position :: v -> Coords v diff --git a/src/Graphics/Rendering/Plot/Light/Internal/Types.hs b/src/Graphics/Rendering/Plot/Light/Internal/Types.hs --- a/src/Graphics/Rendering/Plot/Light/Internal/Types.hs +++ b/src/Graphics/Rendering/Plot/Light/Internal/Types.hs @@ -1,7 +1,7 @@ -module Graphics.Rendering.Plot.Light.Internal.Types where +module Graphics.Rendering.Plot.Light.Internal.Types where -data FigureData a d = +data FigureData a = FigData { _width :: a , _height :: a @@ -9,12 +9,57 @@ , _xmax :: a , _ymin :: a , _ymax :: a - , _figData :: d - } + } deriving (Eq, Show) --- | A LabeledPoint carries the information of where a point should be plotted, what label should it carry (e.g. for labelling the axes) and its function value -data LabeledPoint c l a = - LabeledPoint { _coord :: c, _label :: l, _value :: a } -data P1 a = P1 a -data P2 a = P2 a a +-- | A `Point` defines a point in R2 +data Point a = Point { _px :: a, _py :: a} deriving (Eq, Show) + +mkPoint :: a -> a -> Point a +mkPoint = Point + +-- | Overwrite either coordinate of a Point, to e.g. project on an axis +setPointCoord :: Axis -> a -> Point a -> Point a +setPointCoord axis c (Point x y) + | axis == X = Point c y + | otherwise = Point x c + +setPointX, setPointY :: a -> Point a -> Point a +setPointX = setPointCoord X +setPointY = setPointCoord Y + +-- | A `LabeledPoint` carries the information of where a point should be plotted, what label should it carry (e.g. for labelling the axes) and its function value +data LabeledPoint l a = + LabeledPoint { + _lp :: Point a, + _lplabel :: l } deriving (Eq, Show) + +moveLabeledPoint :: (Point a -> Point b) -> LabeledPoint l a -> LabeledPoint l b +moveLabeledPoint f (LabeledPoint p l) = LabeledPoint (f p) l + +-- | A frame, i.e. a bounding box for objects +data Frame a = Frame { + _fpmin :: Point a, + _fpmax :: Point a} deriving (Eq, Show) + +-- | Frame corner coordinates +xmin, xmax, ymin, ymax :: Frame a -> a +xmin = _px . _fpmin +xmax = _px . _fpmax +ymin = _py . _fpmin +ymax = _py . _fpmax + +-- | The `width` is the extent in the `x` direction and `height` is the extent in the `y` direction +width, height :: Num a => Frame a -> a +width f = xmax f - xmin f +height f = ymax f - ymin f + + + +-- * Axis + +data Axis = X | Y deriving (Eq, Show, Enum) + +otherAxis :: Axis -> Axis +otherAxis X = Y +otherAxis _ = X 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 @@ -10,7 +10,18 @@ import Data.TimeSeries.Forex +-- | 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 + + + + + +-- * Helpers + -- | 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 @@ -22,44 +33,14 @@ -- | Map a Tick onto the rationals fromTick :: Tick -> Rational fromTick (Tick d t) = fromIntegral (toModifiedJulianDay d) + timeOfDayToDayFraction t - - - + --- | Transform the time coordinate of a timeseries point -mapToViewbox :: FigureData (Ratio Integer) d - -> Tick -- | Lower bound - -> Tick -- | Upper bound - -> TsPoint a -- | A point in the timeseries - -> LabeledPoint (Ratio Integer) Tick a -mapToViewbox fd tmin tmax p = LabeledPoint t' (_tick p) (_val p) - where - t' = toViewboxRange fd tmin tmax p +tspToTuple :: (a -> b) -> TsPoint a -> (Float, b) +tspToTuple f tsp = (tickToFloat tsp, f $ _val tsp) - -toViewboxRange :: - FigureData Rational d -> Tick -> Tick -> TsPoint a -> Rational -toViewboxRange fd tmin tmax p = - affine (_xmin fd) (_xmax fd) (fromTick tmin) (fromTick tmax) (fromTick $ _tick p) +tickToFloat :: TsPoint a -> Float +tickToFloat = fromRational . fromTick . _tick --- SVG with text - --- --- --- --- Example text01 - 'Hello, out there' in blue - --- --- Hello, out there --- - --- --- --- diff --git a/src/Graphics/Rendering/Plot/Light/PlotTypes/TimeSeries/Candlestick.hs b/src/Graphics/Rendering/Plot/Light/PlotTypes/TimeSeries/Candlestick.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Plot/Light/PlotTypes/TimeSeries/Candlestick.hs @@ -0,0 +1,5 @@ +module Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries.Candlestick where + + +import Graphics.Rendering.Plot.Light.Internal +import Graphics.Rendering.Plot.Light.Internal.Types diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 --- a/src/Lib.hs +++ /dev/null @@ -1,1 +0,0 @@ -module Lib where