diff --git a/app/heatmap/Main.hs b/app/heatmap/Main.hs new file mode 100644 --- /dev/null +++ b/app/heatmap/Main.hs @@ -0,0 +1,116 @@ +module Main where + +import Control.Monad (forM_) +import Data.Ratio + +import Graphics.Rendering.Plot.Light +import Graphics.Rendering.Plot.Light.PlotTypes + +import qualified Data.Attoparsec.Text as A +import qualified Data.Text as T +import qualified Data.Text.IO as T (readFile, writeFile) +import Data.Scientific (Scientific, toRealFloat) +import Text.Blaze.Svg.Renderer.String (renderSvg) +import Text.Blaze.Svg + +import qualified Data.Colour.Names as C +import qualified Data.Colour as C +import qualified Data.Colour.Palette.BrewerSet as CP + +-- main = print "hello" + + +fname = "data/heatmap-bw" + +xPlot = 300 +yPlot = 300 +fnameOut = "data/heatmap-1.svg" + +fdat = FigureData xPlot yPlot 0.1 0.9 0.1 0.85 10 + + +nColors = 9 -- 3 - 9 +palette :: [C.Colour Double] +palette = CP.brewerSet CP.GnBu nColors + +main = do + dat <- T.readFile fname + let pd = A.parseOnly (gridNum space) dat + case pd of Left e -> error e + Right d -> do + let (nh, nw, vmin, vmax, d') = prepData d + w = xPlot / nw + h = yPlot / nh + from = Frame (Point 0 0) (Point 1 1) + to = frameFromFigData fdat + pixels = forM_ d' (mkPixel w h vmin vmax . toFigFrame from to) + svg_t = svgHeader (mkFrameOrigin xPlot yPlot) pixels +-- -- putStrLn $ renderSvg svg_t + T.writeFile fnameOut $ T.pack $ renderSvg svg_t + +toFigFrame + :: Fractional a => + Frame a -> Frame a -> LabeledPoint l Rational -> LabeledPoint l a +toFigFrame from to = moveLabeledPointBwFrames from to False False . fromRationalLP + +fromRationalLP :: Fractional a => LabeledPoint l Rational -> LabeledPoint l a +fromRationalLP (LabeledPoint (Point x y) l) = LabeledPoint (Point (fromRational x) (fromRational y)) l + + +mkPixel + :: (Show a, RealFrac a) => + a + -> a + -> Scientific + -> Scientific + -> LabeledPoint Scientific a + -> Svg +mkPixel w h vmin vmax (LabeledPoint p l) = rect w h 0 Nothing (Just col) p where + col = pickColor (toFloat vmin) (toFloat vmax) (toFloat l) + + +pickColor :: RealFrac t => t -> t -> t -> C.Colour Double +pickColor xmin xmax x = palette !! i + where + i = floor (x01 * fromIntegral (nColors - 1)) + x01 = (x-xmin)/(xmax - xmin) + + + + +prepData :: + Ord t => [[t]] -> (Rational, Rational, t, t, [LabeledPoint t Rational]) +prepData ll = (nh, nw, valMin, valMax, d') + where + nh = toRational $ length ll + nw = toRational $ length (head ll) + d' = toUnitFramedLP nw nh <$> toCoord ll + valMin = minimum $ _lplabel <$> d' + valMax = maximum $ _lplabel <$> d' + + + +toCoord :: (Num i, Enum i) => [[c]] -> [(i, i, c)] +toCoord ll = concat $ reverse $ go 0 ll [] where + go i (x:xs) acc = go (i + 1) xs $ zip3 (repeat i) [0 ..] x : acc + go _ [] acc = acc + +toUnitFramedLP :: (Fractional t) => + t -> t -> (t, t, l) -> LabeledPoint l t +toUnitFramedLP w h (i, j, x) = LabeledPoint p x + where p = Point (i/h) (j/w) + + + +-- parsers + +-- | Parse a row of numbers, separated by `sep` +rowNums :: A.Parser s -> A.Parser [Scientific] +rowNums = A.sepBy A.scientific + +rowNumSpace :: A.Parser [Scientific] +rowNumSpace = rowNums space + +-- | parse a grid of numbers, separated by `sep` +gridNum :: A.Parser s -> A.Parser [[Scientific]] +gridNum sep = A.sepBy (rowNums sep) A.endOfLine diff --git a/app/timeseries/Main.hs b/app/timeseries/Main.hs --- a/app/timeseries/Main.hs +++ b/app/timeseries/Main.hs @@ -24,23 +24,33 @@ xPlot = 800 yPlot = 600 -fnameOut = "data/forex_plot_3.svg" +fnameOut = "data/forex_plot_4.svg" +fdat = FigureData xPlot yPlot 0.1 0.9 0.1 0.85 10 + main = do - d <- T.readFile fname - let pd = A.parseOnly parseFxDataset d + dat <- T.readFile fname + let pd = A.parseOnly parseFxDataset dat case pd of Left e -> error e - Right d -> -- print $ tsAxis (toFloat . rateOpen) xPlot yPlot 3 C.blue (-45) d + Right d -> do - let svg_t = svgHeader (mkFrameOrigin xPlot yPlot) $ tsAxis avgTs xPlot yPlot 3 C.black C.red (-45) d - -- putStrLn $ renderSvg svg_t - T.writeFile fnameOut $ T.pack $ renderSvg svg_t + let + figure = tsAxis fdat fop fcl fhi flo 1 C.black (-45) Nothing Nothing ( tspToLP fhi (\_ x -> x) <$> d) + -- figure = tsAxis fdat 2 C.black C.red (-45) Nothing Nothing ( tspToLP fplot (\ti _ -> show ti) <$> d) + svg_t = svgHeader (mkFrameOrigin xPlot yPlot) figure + -- svg_t = svgHeader (mkFrameOrigin xPlot yPlot) $ tsAxis fdat 2 C.black C.red (-45) Nothing Nothing ( tspToLP fplot (\ti _ -> show ti) <$> d) + putStrLn $ renderSvg svg_t + -- T.writeFile fnameOut $ T.pack $ renderSvg svg_t + where + fhi = toFloat . rateHigh + flo = toFloat . rateLow + fop = toFloat . rateOpen + fcl = toFloat . rateClose -toFloat :: Scientific -> Float -toFloat x = toRealFloat x :: Float + avgTs :: FxRow Scientific -> Float avgTs x = 0.5 * (h + l) where h = toFloat (rateHigh x) @@ -51,30 +61,6 @@ -- Forex time series parsers - related - - -data FxRow a = FxRow { - rateOpen :: a - , rateHigh :: a - , rateLow :: a - , rateClose :: a - } deriving (Eq, Show) - - -space, comma :: A.Parser Char -space = A.char ' ' -comma = A.char ',' - --- | Parse a row of numbers, separated by `sep` -rowNums :: A.Parser s -> A.Parser [Scientific] -rowNums sep = A.sepBy A.scientific sep - -rowNumSpace :: A.Parser [Scientific] -rowNumSpace = rowNums space - --- | parse a grid of numbers, separated by `sep` -gridNum :: A.Parser s -> A.Parser [[Scientific]] -gridNum sep = A.sepBy (rowNums sep) A.endOfLine 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.2.2 +version: 0.2.3 synopsis: A lightweight plotting library, exporting to SVG description: A lightweight plotting library, exporting to SVG homepage: https://github.com/ocramz/plot-light @@ -22,14 +22,16 @@ ghc-options: -Wall hs-source-dirs: src exposed-modules: Graphics.Rendering.Plot.Light + Data.TimeSeries Graphics.Rendering.Plot.Light.PlotTypes other-modules: Graphics.Rendering.Plot.Light.Internal Graphics.Rendering.Plot.Light.PlotTypes.Heatmap Graphics.Rendering.Plot.Light.PlotTypes.Scatter Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries.Candlestick - Data.TimeSeries Graphics.Rendering.Plot.Light.Internal.Geometry + Graphics.Rendering.Plot.Light.Internal.Utils + Data.Parsers build-depends: base >= 4.7 && < 5 , time , scientific @@ -37,11 +39,12 @@ , colour , palette , blaze-svg + , attoparsec -- , hspec -- , QuickCheck -executable plot-light +executable timeseries default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: app/timeseries @@ -55,6 +58,22 @@ , colour , blaze-svg , scientific + +executable heatmap + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: app/heatmap + main-is: Main.hs + build-depends: base + , plot-light + , attoparsec + , attoparsec-time + , time + , text + , colour + , palette + , blaze-svg + , scientific test-suite spec default-language: Haskell2010 diff --git a/src/Data/Parsers.hs b/src/Data/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Data/Parsers.hs @@ -0,0 +1,6 @@ +module Data.Parsers where +import qualified Data.Attoparsec.Text as A + +space, comma :: A.Parser Char +space = A.char ' ' +comma = A.char ',' diff --git a/src/Data/TimeSeries.hs b/src/Data/TimeSeries.hs --- a/src/Data/TimeSeries.hs +++ b/src/Data/TimeSeries.hs @@ -1,14 +1,54 @@ module Data.TimeSeries where import Data.Time +import Data.Fixed (Pico) +import Graphics.Rendering.Plot.Light.Internal.Utils -- | An instant, defined by date (Day) and TimeOfDay data Tick = Tick Day TimeOfDay deriving (Eq, Show, Ord) +-- | 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 + -- | A point in a time series data TsPoint a = Tsp { _tick :: Tick, _val :: a } deriving (Eq, Show) + + +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 + +-- | Map a rational onto a Tick +toTick :: Rational -> Tick +toTick n = Tick d t where + t = dayFractionToTimeOfDay dec + d = ModifiedJulianDay wh + (wh, dec) = wholeDecimal n + + +hourTick, halfHourTick, quarterHourTick :: Double +hourTick = 1/24 +halfHourTick = 1/2 * hourTick +quarterHourTick = 1/4 * hourTick + + + + + + +-- tickRange :: Tick -> Tick -> Rational -> [Tick] +-- tickRange t1 t2 dt = toTick <$> [td1, td1 + dt .. td2] where +-- td1 = fromTick t1 +-- td2 = fromTick t2 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 @@ -32,7 +32,7 @@ -- ** SVG utilities svgHeader, translateSvg, -- * Types - Frame(..), Point(..), LabeledPoint(..), labelPoint, Axis(..), + Frame(..), Point(..), LabeledPoint(..), labelPoint, mapLabel, Axis(..), -- * Geometry -- ** Vectors V2(..), @@ -45,13 +45,15 @@ -- ** Vector construction v2fromEndpoints, v2fromPoint, -- ** Operations on points - movePoint, moveLabeledPointV2, (-.), toSvgFrame, toSvgFrameLP, pointRange, + movePoint, moveLabeledPointV2, moveLabeledPointBwFrames, (-.), toSvgFrame, toSvgFrameLP, pointRange, -- ** Operations on vectors frameToFrame, -- ** Operations on frames - frameFromPoints, mkFrame, mkFrameOrigin, width, height, + frameFromPoints, frameFromFigData, mkFrame, mkFrameOrigin, width, height, -- ** Typeclasses - AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..) + AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..), + -- ** Helpers + toFloat, wholeDecimal ) where -- import qualified Data.Text as T 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,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Graphics.Rendering.Plot.Light.Internal (FigureData(..), Frame(..), mkFrame, mkFrameOrigin, frameToFrame, frameFromPoints, width, height, Point(..), mkPoint, LabeledPoint(..), mkLabeledPoint, labelPoint, Axis(..), svgHeader, rect, rectCentered, circle, line, tick, ticks, axis, toPlot, text, polyline, filledPolyline, filledBand, candlestick, strokeLineJoin, LineStroke_(..), StrokeLineJoin_(..), TextAnchor_(..), V2(..), Mat2(..), DiagMat2(..), diagMat2, AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..), norm2, normalize2, v2fromEndpoints, v2fromPoint, origin, (-.), pointRange, movePoint, moveLabeledPointV2, moveLabeledPointV2Frames, translateSvg, toSvgFrame, toSvgFrameLP, e1, e2) where +module Graphics.Rendering.Plot.Light.Internal (FigureData(..), Frame(..), mkFrame, mkFrameOrigin, frameToFrame, frameToFrameValue, frameFromPoints, frameFromFigData, xmin,xmax,ymin,ymax, width, height, Point(..), mkPoint, LabeledPoint(..), mkLabeledPoint, labelPoint, mapLabel, Axis(..), svgHeader, rect, rectCentered, circle, line, tick, ticks, axis, toPlot, text, polyline, filledPolyline, filledBand, candlestick, strokeLineJoin, LineStroke_(..), StrokeLineJoin_(..), TextAnchor_(..), 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) where import Data.Monoid ((<>)) import qualified Data.Foldable as F (toList) @@ -26,6 +26,7 @@ import GHC.Real import Graphics.Rendering.Plot.Light.Internal.Geometry +import Graphics.Rendering.Plot.Light.Internal.Utils -- | Figure data @@ -63,14 +64,14 @@ -- > > putStrLn $ renderSvg $ rect (Point 100 200) 30 60 2 Nothing (Just C.aquamarine) -- > rect :: (Show a, RealFrac a) => - Point a -- ^ Corner point coordinates - -> a -- ^ Width + a -- ^ Width -> a -- ^ Height -> a -- ^ Stroke width -> Maybe (C.Colour Double) -- ^ Stroke colour - -> Maybe (C.Colour Double) -- ^ Fill colour + -> Maybe (C.Colour Double) -- ^ Fill colour + -> Point a -- ^ Corner point coordinates -> Svg -rect (Point x0 y0) wid hei sw scol fcol = 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) +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) -- | A rectangle, defined by its center coordinates and side lengths @@ -78,15 +79,15 @@ -- > > putStrLn $ renderSvg $ rectCentered (Point 20 30) 15 30 (Just C.blue) (Just C.red) -- > rectCentered :: (Show a, RealFrac a) => - Point a -- ^ Center coordinates - -> a -- ^ Width + a -- ^ Width -> a -- ^ Height -> a -- ^ Stroke width -> Maybe (C.Colour Double) -- ^ Stroke colour - -> Maybe (C.Colour Double) -- ^ Fill colour + -> Maybe (C.Colour Double) -- ^ Fill colour + -> Point a -- ^ Center coordinates -> Svg -rectCentered p@(Point x0 y0) wid hei sw scol fcol = - translateSvg (Point x0c y0c) $ rect p wid hei sw scol fcol where +rectCentered wid hei sw scol fcol p@(Point x0 y0) = + translateSvg (Point x0c y0c) $ rect wid hei sw scol fcol p where x0c = x0 - (wid / 2) y0c = y0 - (hei / 2) @@ -212,31 +213,45 @@ -> t (LabeledPoint l a) -- ^ Data -> Svg toPlot fd flabelx flabely rotx roty sw col1 tickxe tickye plotf dat = do - axis oSvg X (right - left) sw col1 0.05 Continuous fontsize rotx TAEnd flabelx (V2 (-10) 0) tickx - axis oSvg Y (top - bot) sw col1 0.05 Continuous fontsize roty TAEnd flabely (V2 (-10) 0) ticky + 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 - 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 from = frameFromPoints $ _lp <$> dat - to = mkFrame oTo p2To + 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 left bot + 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 +-- | Create Axis labels from +-- * fig.data (axis ranges) +-- * label font size +-- * a container of `LabeledPoint`s +-- mkAxisLabels figdata fontsize lps = undefined +-- where +-- laxis = + + + + -- * text -- | `text` renders text onto the SVG canvas @@ -297,14 +312,14 @@ -- > > 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) => - t (Point a) -- ^ Data - -> a1 -- ^ Stroke width + a1 -- ^ Stroke width -> LineStroke_ a -- ^ Stroke type -> StrokeLineJoin_ -- ^ Stroke join type -> C.Colour Double -- ^ Stroke colour + -> t (Point a) -- ^ Data -> 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 -polyline lis sw (Dashed d) 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 ! strokeDashArray d +polyline sw Continuous slj col lis = 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 +polyline sw (Dashed d) slj col lis = 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 ! strokeDashArray d none :: S.AttributeValue none = S.toValue ("none" :: String) @@ -355,11 +370,11 @@ -- 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) => - (LabeledPoint l a -> Bool) -- ^ If True, fill the box with the first colour, otherwise with the second - -> (LabeledPoint l a -> a) -- ^ Box maximum value - -> (LabeledPoint l a -> a) -- ^ Box minimum value - -> (LabeledPoint l a -> a) -- ^ Line maximum value - -> (LabeledPoint l a -> a) -- ^ Line minimum value + (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 -> C.Colour Double -- ^ First box colour @@ -369,13 +384,14 @@ -> Svg candlestick fdec fboxmin fboxmax fmin fmax wid sw col1 col2 colstroke lp = do line pmin pmax sw Continuous colstroke - rectCentered p wid hei sw (Just colstroke) (Just col) + rectCentered wid hei sw (Just colstroke) (Just col) p where p = _lp lp - pmin = setPointY (fmin lp) p - pmax = setPointY (fmax lp) p - hei = fboxmax lp - fboxmin lp - col | fdec lp = col1 + lab = _lplabel lp + pmin = setPointY (fmin lab) p + pmax = setPointY (fmax lab) p + hei = fboxmax lab - fboxmin lab + col | fdec (fboxmax lab) (fboxmin lab) = col1 | otherwise = col2 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 @@ -36,15 +36,21 @@ _lplabel :: l } deriving (Eq, Show) + mkLabeledPoint :: Point a -> l -> LabeledPoint l a mkLabeledPoint = LabeledPoint +-- | Given a labelling function and a `Point` `p`, returned a `LabeledPoint` containing `p` and the computed label labelPoint :: (Point a -> l) -> Point a -> LabeledPoint l a labelPoint lf p = LabeledPoint p (lf p) moveLabeledPoint :: (Point a -> Point b) -> LabeledPoint l a -> LabeledPoint l b moveLabeledPoint f (LabeledPoint p l) = LabeledPoint (f p) l +-- | Apply a function to the label +mapLabel :: (l1 -> l2) -> LabeledPoint l1 a -> LabeledPoint l2 a +mapLabel f (LabeledPoint p l) = LabeledPoint p (f l) + -- | A frame, i.e. a bounding box for objects data Frame a = Frame { _fpmin :: Point a, @@ -86,8 +92,8 @@ -- | 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 +width f = abs $ xmax f - xmin f +height f = abs $ ymax f - ymin f @@ -309,9 +315,20 @@ flipUD01 (V2 a b) = V2 a (1 - b) +-- | Map function values across frames +frameToFrameValue :: Fractional t => + Frame t -- ^ Initial frame + -> Frame t -- ^ Final frame + -> t -- ^ Initial value + -> t +frameToFrameValue from to x = (x01 * rto) + ymin to where + x01 = (x - ymin from)/rfrom + rfrom = height from + rto = height to -moveLabeledPointV2Frames :: + +moveLabeledPointBwFrames :: Fractional a => Frame a -- ^ Initial frame -> Frame a -- ^ Final frame @@ -319,7 +336,7 @@ -> Bool -- ^ Flip U-D in [0,1] x [0,1] -> LabeledPoint l a -- ^ Initial `LabeledPoint` -> LabeledPoint l a -moveLabeledPointV2Frames from to fliplr flipud lp = LabeledPoint p' (_lplabel lp) +moveLabeledPointBwFrames from to fliplr flipud lp = LabeledPoint p' (_lplabel lp) where vlp = v2fromPoint $ _lp lp -- vector associated with starting point vlp' = frameToFrame from to fliplr flipud vlp -- vector associated w new point @@ -360,7 +377,7 @@ v1 ~= v2 = norm2 (v1 ^-^ v2) <= 1e-8 instance Eps (V2 Float) where - v1 ~= v2 = norm2 (v1 ^-^ v2) <= 1e-3 + v1 ~= v2 = norm2 (v1 ^-^ v2) <= 1e-2 diff --git a/src/Graphics/Rendering/Plot/Light/Internal/Utils.hs b/src/Graphics/Rendering/Plot/Light/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Plot/Light/Internal/Utils.hs @@ -0,0 +1,23 @@ +module Graphics.Rendering.Plot.Light.Internal.Utils where + + +import Data.Scientific (Scientific, toRealFloat) + +-- * Misc helpers + + + + +-- ** Numeric formats + +toFloat :: Scientific -> Float +toFloat x = toRealFloat x :: Float + +-- | Separate whole and decimal part of a fractional number +-- e.g. +-- +-- > > wholeDecimal +wholeDecimal :: (Integral a, RealFrac b) => b -> (a, b) +wholeDecimal x = (w, d) where + w = floor x + d = x - fromIntegral w diff --git a/src/Graphics/Rendering/Plot/Light/PlotTypes.hs b/src/Graphics/Rendering/Plot/Light/PlotTypes.hs --- a/src/Graphics/Rendering/Plot/Light/PlotTypes.hs +++ b/src/Graphics/Rendering/Plot/Light/PlotTypes.hs @@ -1,5 +1,8 @@ module Graphics.Rendering.Plot.Light.PlotTypes (module X) where import Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries as X +import Graphics.Rendering.Plot.Light.PlotTypes.Heatmap as X + +import Data.Parsers as X import Data.TimeSeries as X diff --git a/src/Graphics/Rendering/Plot/Light/PlotTypes/Heatmap.hs b/src/Graphics/Rendering/Plot/Light/PlotTypes/Heatmap.hs --- a/src/Graphics/Rendering/Plot/Light/PlotTypes/Heatmap.hs +++ b/src/Graphics/Rendering/Plot/Light/PlotTypes/Heatmap.hs @@ -6,3 +6,9 @@ + + +-- hmPlot fd + + + 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 @@ -2,6 +2,8 @@ {-# language FlexibleContexts #-} module Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries where +import Control.Monad (forM, forM_) + import GHC.Real import Data.Fixed (Pico) import Data.Time @@ -10,6 +12,7 @@ import qualified Data.Text as T import Graphics.Rendering.Plot.Light.Internal +import Graphics.Rendering.Plot.Light.Internal.Utils import Data.TimeSeries -- For debugging @@ -25,53 +28,62 @@ -- 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 fval wfig hfig sw col1 col2 rot ps = do - axis oSvg X (right - left) sw col1 0.01 Continuous 10 rot TAEnd (T.pack . fst) (V2 (-10) 0) dat' - axis oSvg Y (top - bot) sw col1 0.01 Continuous 10 0 TAEnd (T.pack . snd) (V2 (-10) 0) dat' - polyline (_lp <$> dat') sw Continuous Round col2 - where - dat = tspToLP fval (\(Tick d t) v -> (show (d, t), show (fval v))) <$> ps - dat' = toSvgFrameLP from to False <$> dat - (left, right) = (0.1 * wfig, 0.9 * wfig) - (top, bot) = (0.1 * hfig, 0.9 * hfig) - oTo = Point left top - p2To = Point right bot - from = frameFromPoints $ _lp <$> dat - to = mkFrame oTo p2To - oSvg = Point left bot +-- tsAxis fval wfig hfig sw col1 col2 rot ps = do +-- axis oSvg X (right - left) sw col1 0.01 Continuous 10 rot TAEnd (T.pack . fst) (V2 (-10) 0) dat' +-- axis oSvg Y (top - bot) sw col1 0.01 Continuous 10 0 TAEnd (T.pack . snd) (V2 (-10) 0) dat' +-- polyline (_lp <$> dat') sw Continuous Round col2 +-- where +-- dat = tspToLP fval (\(Tick d t) v -> (show (d, t), show (fval v))) <$> ps +-- dat' = toSvgFrameLP from to False <$> dat +-- (left, right) = (0.1 * wfig, 0.9 * wfig) +-- (top, bot) = (0.1 * hfig, 0.9 * hfig) +-- oTo = Point left top +-- p2To = Point right bot +-- from = frameFromPoints $ _lp <$> dat +-- to = mkFrame oTo p2To +-- oSvg = Point left bot - -tsAxisTest fd sw colAxis colData rot ps = - toPlot fd T.pack T.pack rot 0 sw colAxis (Just ptx) (Just pty) fplot ps where - fplot lps = polyline (_lp <$> lps) sw Continuous Round colData +-- tsAxis +-- :: (Functor t, Foldable t, Show a, RealFrac a) => +-- FigureData a +-- -> a +-- -> C.Colour Double +-- -> C.Colour Double +-- -> a +-- -> Maybe (t (LabeledPoint String a)) +-- -> Maybe (t (LabeledPoint String a)) +-- -> t (LabeledPoint String a) +-- -> Svg +-- tsAxis fd sw colAxis colData rot plabx plaby ps = +-- toPlot fd T.pack T.pack rot 0 sw colAxis plabx plaby fplot ps where +-- fplot lps = polyline sw Continuous Round colData (_lp <$> lps) - - -fdat = FigureData 400 300 0.1 0.9 0.1 0.85 10 - -dat1 :: [ LabeledPoint String Double ] -dat1 = [LabeledPoint (Point 0 0) "blah", - LabeledPoint (Point 0 1) "asdf", - LabeledPoint (Point 1 1) "yo", - LabeledPoint (Point 1 2) "blap", - LabeledPoint (Point 2 2) "chow"] - -ptx = labelPoint (show . _px) <$> pointRange 2 (Point 0 0) (Point 2 0) -pty = labelPoint (show . _py) <$> pointRange 2 (Point 0 0) (Point 0 2) - -to, from :: Frame Double -from = frameFromPoints $ _lp <$> dat1 -to = mkFrameOrigin 400 300 - +tsAxis + :: (Functor t, Foldable t, Show a, RealFrac a) => + FigureData a + -> (l -> a) + -> (l -> a) + -> (l -> a) + -> (l -> a) + -> a + -> C.Colour Double + -> a + -> Maybe (t (LabeledPoint l a)) + -> Maybe (t (LabeledPoint l a)) + -> t (LabeledPoint l a) + -> Svg +tsAxis fd fsela fselb fselc fseld sw colAxis rot plabx plaby ps = + toPlot fd baz baz rot 0 sw colAxis plabx plaby fplot ps where + baz = const (T.pack "") + fplot lps = + forM_ lps (candlestick (>) fsela fselb fselc fseld 5 1 C.green C.red colAxis) - - -- * Helpers -- | 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. @@ -87,32 +99,64 @@ lf = g <$> _tick <*> _val -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 - --- fromTickI (Tick d t) = toModifiedJulianDay d + timeOfDayToDayFraction t +labeledTsPointRange n p t1 q dt = zipWith LabeledPoint p_ t_ + where + t_ = toTick <$> [td1, td1 + dt .. ] + p_ = pointRange n p q + td1 = fromTick t1 --- | 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 +frameToFrameFxRow from to fxr = f <$> fxr + where + f = frameToFrameValue from to + +data FxRow a = FxRow { + rateOpen :: a + , rateHigh :: a + , rateLow :: a + , rateClose :: a + } deriving (Eq, Show) + +instance Functor FxRow where + fmap f (FxRow o h l c) = FxRow (f o) (f h) (f l) (f c) + +c1 = FxRow 1.0876 1.0880 1.0872 1.0874 + + + +-- test data + +-- svg1 = renderSvg $ tsAxis fdat1 2 C.black C.red (-45) (Just ptx) (Just pty) dat1 + +-- svg2 = renderSvg $ tsAxis fdat1 2 C.black C.red (-45) Nothing (Just pty) dat1 + + +fdat1 = FigureData 400 300 0.1 0.9 0.1 0.85 10 + +dat1 :: [ LabeledPoint String Double ] +dat1 = [LabeledPoint (Point 0 0) "blah", + LabeledPoint (Point 0 1) "asdf", + LabeledPoint (Point 1 1) "yo", + LabeledPoint (Point 1 2) "blap", + LabeledPoint (Point 2 2) "chow"] + +ptx = labelPoint (show . _px) <$> pointRange 2 (Point 0 0) (Point 2 0) +pty = labelPoint (show . _py) <$> pointRange 2 (Point 0 0) (Point 0 2) + +to, from :: Frame Double +from = frameFromPoints $ _lp <$> dat1 +to = mkFrameOrigin 400 300 diff --git a/test/LibSpec.hs b/test/LibSpec.hs --- a/test/LibSpec.hs +++ b/test/LibSpec.hs @@ -6,15 +6,18 @@ import Test.QuickCheck import Graphics.Rendering.Plot.Light +import Data.TimeSeries main :: IO () main = hspec spec spec :: Spec -spec = +spec = do + describe "Data.Timeseries" $ + it "correctly converts between `Tick`s and `Fractional`s" $ do + let t0 = 57957.475 + fromTick (toTick t0) `shouldBe` t0 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) -> @@ -32,7 +35,6 @@ -- p2 `shouldBe` Point 3 3 norm2 (p2 -. Point 3 3) ~= 0 `shouldBe` True -