diff --git a/chart-unit.cabal b/chart-unit.cabal --- a/chart-unit.cabal +++ b/chart-unit.cabal @@ -1,20 +1,22 @@ name: chart-unit -version: 0.4.1 +version: 0.5.0 synopsis: Native haskell charts. description: See for chart bling and usage. . . - <> + ![example](other/mainExample.svg) . These charts are designed to be scale independent and amenable to combinatory busywork (hence the unit suffix). . . extra-source-files: - readme.md - index.html - stack.yaml + readme.md, + stack.yaml, + other/*.svg +extra-doc-files: + other/*.svg category: charts homepage: @@ -32,67 +34,57 @@ build-type: Simple cabal-version: - >=1.10 + >=1.18 library hs-source-dirs: src exposed-modules: Chart, - Chart.Unit, - Chart.Types + Chart.Arrow, + Chart.Core, + Chart.Glyph, + Chart.Hud, + Chart.Line, + Chart.Rect, + Chart.Text, + Chart.Lenses ghc-options: -funbox-strict-fields - -fforce-recomp + -fforce-recomp build-depends: base >= 4.7 && < 5, colour, + palette, diagrams-lib, diagrams-svg, foldl, formatting, lens, linear, + data-default, numhask >= 0.0.5 && < 1, numhask-range >= 0.0.3 && < 1, - text + text, + SVGFonts default-language: Haskell2010 default-extensions: - NoImplicitPrelude, - UnicodeSyntax, - BangPatterns, - BinaryLiterals, - DeriveFoldable, - DeriveFunctor, DeriveGeneric, DeriveTraversable, - DisambiguateRecordFields, - EmptyCase, FlexibleContexts, FlexibleInstances, - FunctionalDependencies, - GADTSyntax, InstanceSigs, - KindSignatures, - LambdaCase, - MonadComprehensions, MultiParamTypeClasses, - MultiWayIf, NegativeLiterals, + NoImplicitPrelude, OverloadedStrings, - ParallelListComp, - PartialTypeSignatures, PatternSynonyms, RankNTypes, - RecordWildCards, - RecursiveDo, - ScopedTypeVariables, - TupleSections, TypeFamilies, - TypeOperators + UnicodeSyntax -executable chart-unit-examples +executable chart-source-examples default-language: Haskell2010 ghc-options: @@ -104,61 +96,38 @@ hs-source-dirs: examples main-is: - examples.hs + sourceExamples.hs other-modules: FakeData build-depends: base >= 4.7 && < 5, chart-unit, - protolude, + containers, + diagrams-lib, foldl, - text, - numhask, - -- for data examples - mwc-random, + lens, mwc-probability, + mwc-random, + numhask, primitive, - ad, - reflection, + protolude, tdigest, - -- for animation example - diagrams-rasterific, - JuicyPixels, - diagrams-lib - + text, + diagrams-rasterific default-extensions: - NoImplicitPrelude, - UnicodeSyntax, - BangPatterns, - BinaryLiterals, - DeriveFoldable, - DeriveFunctor, DeriveGeneric, DeriveTraversable, - DisambiguateRecordFields, - EmptyCase, FlexibleContexts, FlexibleInstances, - FunctionalDependencies, - GADTSyntax, InstanceSigs, - KindSignatures, - LambdaCase, - MonadComprehensions, MultiParamTypeClasses, - MultiWayIf, NegativeLiterals, + NoImplicitPrelude, OverloadedStrings, - ParallelListComp, - PartialTypeSignatures, PatternSynonyms, RankNTypes, - RecordWildCards, - RecursiveDo, - ScopedTypeVariables, - TupleSections, TypeFamilies, - TypeOperators + UnicodeSyntax test-suite test default-language: @@ -172,42 +141,24 @@ build-depends: base >= 4.7 && < 5, chart-unit, + numhask, tasty, tasty-hspec, - numhask + text default-extensions: - NoImplicitPrelude, - UnicodeSyntax, - BangPatterns, - BinaryLiterals, - DeriveFoldable, - DeriveFunctor, DeriveGeneric, DeriveTraversable, - DisambiguateRecordFields, - EmptyCase, FlexibleContexts, FlexibleInstances, - FunctionalDependencies, - GADTSyntax, InstanceSigs, - KindSignatures, - LambdaCase, - MonadComprehensions, MultiParamTypeClasses, - MultiWayIf, NegativeLiterals, + NoImplicitPrelude, OverloadedStrings, - ParallelListComp, - PartialTypeSignatures, PatternSynonyms, RankNTypes, - RecordWildCards, - RecursiveDo, - ScopedTypeVariables, - TupleSections, TypeFamilies, - TypeOperators + UnicodeSyntax source-repository head type: diff --git a/examples/FakeData.hs b/examples/FakeData.hs --- a/examples/FakeData.hs +++ b/examples/FakeData.hs @@ -1,10 +1,11 @@ -{- -various fake data --} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -{-# LANGUAGE DataKinds #-} +#if ( __GLASGOW_HASKELL__ < 820 ) +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#endif module FakeData where @@ -12,14 +13,13 @@ import NumHask.Prelude import Control.Monad.Primitive (PrimState) -import Data.Reflection -import Numeric.AD -import Numeric.AD.Internal.Reverse import System.Random.MWC import System.Random.MWC.Probability import qualified Control.Foldl as L import qualified Protolude as P import Data.TDigest +import qualified Data.Map as Map +import Data.List {- Standard normal random variates in one dimension. @@ -32,54 +32,82 @@ This generates n V2 random variates where the x and y parts are correlated. -} -rvsCorr :: Gen (PrimState IO) -> Int -> Double -> IO [V2 Double] +rvsCorr :: Gen (PrimState IO) -> Int -> Double -> IO [Pair Double] rvsCorr gen n c = do s0 <- rvs gen n s1 <- rvs gen n let s1' = zipWith (\x y -> c * x + sqrt (1 - c * c) * y) s0 s1 - pure $ zipWith V2 s0 s1' + pure $ zipWith Pair s0 s1' -mkScatterData :: IO [[V2 Double]] +mkScatterData :: IO [[Pair Double]] mkScatterData = do g <- create xys <- rvsCorr g 1000 0.7 xys1 <- rvsCorr g 1000 -0.5 - pure [ over _y (+1) . over _x (\x -> x^^2 + 3*x - 1) <$> xys - , over _x (\x -> x^^2 + 3*x + 1) <$> xys1] + pure [ (\(Pair x y) -> Pair ( x^^2 + 3*x - 1) (y+1)) <$> xys + , (\(Pair x y) -> Pair ( x^^2 + 3*x + 1) y) <$> xys1] +data DealOvers = IgnoreOvers | IncludeOvers Double + makeHist :: Int -> [Double] -> [Rect Double] -makeHist n xs = fromHist (IncludeOvers 1) (fill cuts xs) +makeHist n xs = fromHist IgnoreOvers (fill cuts xs) where - r = Chart.range xs - cuts = linearSpace OuterPos r n + cuts = grid MidPos (space xs :: Range Double) n -makeRvs :: IO [[Double]] +fill :: (Functor f, Foldable f) => [Double] -> f Double -> Histogram +fill cuts xs = Histogram cuts (histMap cuts xs) + where + histMap cuts xs = L.fold count $ (\x -> L.fold countBool (fmap (x >) cuts)) <$> xs + count = L.premap (\x -> (x,1.0)) countW + countBool = L.Fold (\x a -> x + if a then 1 else 0) 0 identity + countW = L.Fold (\x (a,w) -> Map.insertWith (+) a w x) Map.empty identity + +fromHist :: DealOvers -> Histogram -> [Rect Double] +fromHist o (Histogram cuts counts) = zipWith4 Rect x z y w' + where + y = repeat 0 + w = zipWith (/) + ((\x -> Map.findWithDefault 0 x counts) <$> [f..l]) + (zipWith (-) z x) + f = case o of + IgnoreOvers -> 1 + IncludeOvers _ -> 0 + l = case o of + IgnoreOvers -> length cuts - 1 + IncludeOvers _ -> length cuts + w' = (/P.sum w) <$> w + x = case o of + IgnoreOvers -> cuts + IncludeOvers outw -> [Data.List.head cuts - outw] <> cuts <> [last cuts + outw] + z = drop 1 x + +makeRvs :: IO ([Double],[Double]) makeRvs = do g <- create xys <- rvs g 1000 xys1 <- rvs g 1000 - pure [xys, (1.5*) <$> xys1] + pure (xys, (1.5*) <$> xys1) -mkHistData :: IO [[Rect Double]] -mkHistData = do - d0 <- makeRvs - pure $ makeHist 30 <$> d0 +data Histogram = Histogram + { _cuts :: [Double] -- bucket boundaries + , _values :: Map.Map Int Double -- bucket counts + } deriving (Show, Eq) -mkHistogramData :: IO [Histogram] -mkHistogramData = do - d0 <- makeRvs - let cuts = linearSpace OuterPos (Range (-3.0,3.0)) 6 - pure $ fill cuts <$> d0 +makeHistDiffExample :: IO ([Rect Double],[Rect Double]) +makeHistDiffExample = do + (d0,d1) <- makeRvs + let cuts = grid OuterPos (Range -5.0 5.0) 50 + pure (fromHist IgnoreOvers (fill cuts d0), fromHist IgnoreOvers (fill cuts d1)) makeRectQuantiles :: Double -> IO [Rect Double] makeRectQuantiles n = do vs <- makeQuantiles n let begin = ([],Nothing) - let step :: ([V4 Double],Maybe Double) -> Double -> ([V4 Double],Maybe Double) + let step :: ([Rect Double],Maybe Double) -> Double -> ([Rect Double],Maybe Double) step (_, Nothing) a = ([], Just a) - step (acc, Just l) a = (acc <> [V4 l 0 a (0.1/(a-l))], Just a) + step (acc, Just l) a = (acc <> [Rect l a 0 (0.1/(a-l))], Just a) let h = L.fold (L.Fold step begin fst) vs - pure $ view rect <$> h + pure h makeQuantiles :: Double -> IO [Double] makeQuantiles n = do @@ -95,24 +123,4 @@ step x a = Data.TDigest.insert a x begin = tdigest ([]::[Double]) :: TDigest 25 done x = fromMaybe nan . (`quantile` compress x) <$> qs - -arrowData :: [V4 Double] -arrowData = zipWith (\(V2 x y) (V2 z w) -> V4 x y z w) pos dir' - where - pos = gridP OuterPos (Rect (V2 (-1 ... 1) (-1 ... 1))) (V2 20 20) - dir' = gradF rosenbrock 0.01 <$> pos - -gradF :: - (forall s. (Reifies s Tape) => [Reverse s Double] -> Reverse s Double) -> - Double -> - V2 Double -> - V2 Double -gradF f step (V2 x y) = - - r2 ((\[x',y'] -> (x',y')) $ - gradWith (\x0 x1 -> x0 + (x1 - x0) * step) f [x,y]) - -rosenbrock :: (Num a) => [a] -> a -rosenbrock [] = 0 -rosenbrock [x] = 100 P.* (P.negate x P.^ 2) P.^ 2 P.+ (x P.- 1) P.^ 2 -rosenbrock (x:y:_) = 100 P.* (y P.- x P.^ 2) P.^ 2 P.+ (x P.- 1) P.^ 2 diff --git a/examples/examples.hs b/examples/examples.hs deleted file mode 100644 --- a/examples/examples.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-type-defaults #-} - -import Chart -import NumHask.Prelude -import Codec.Picture.Gif (GifDelay) -import Diagrams.Backend.Rasterific.CmdLine (B, GifOpts(..)) -import Diagrams.Backend.CmdLine (DiagramOpts(..), mainRender) - -import FakeData - -import qualified Control.Foldl as L -import Data.List ((!!)) -import Data.Text (pack) - -scratch :: Chart SVG -> IO () -scratch = fileSvg "other/scratchpad.svg" (600,400) - -exampleBox :: Chart a -exampleBox = box one - -exampleAxes :: Chart' a -exampleAxes = axes def - -exampleEmpty :: Chart' a -exampleEmpty = - withChart def (\_ _ -> mempty) [corners one] - -exampleGrid :: Chart a -exampleGrid = - scatterChart - [ScatterConfig 0.01 (palette!!4)] - sixbyfour - [V2 <$> [0..10] <*> [0..10]] - -lineDefs :: [LineConfig] -lineDefs = - [ LineConfig 0.01 (Color 0.945 0.345 0.329 0.8) - , LineConfig 0.02 (Color 0.698 0.569 0.184 0.5) - , LineConfig 0.005 (Color 0.5 0.5 0.5 1.0) - ] - -lineData :: [[V2 Double]] -lineData = - fmap r2 <$> - [ [(0.0,1.0),(1.0,1.0),(2.0,5.0)] - , [(0.0,0.0),(3.0,3.0)] - , [(0.5,4.0),(0.5,0)] - ] - -exampleLine :: Chart a -exampleLine = lineChart lineDefs sixbyfour lineData - -exampleLineAxes :: Chart' a -exampleLineAxes = - lineChart lineDefs sixbyfour lineData <> - axes (chartRange .~ Just (rangeR2s lineData) $ def) - -exampleLineAxes2 :: Chart' a -exampleLineAxes2 = - withChart def (lineChart lineDefs) lineData - -scatterDefs :: [ScatterConfig] -scatterDefs = zipWith ScatterConfig [0.01,0.02,0.03] (opacs 0.5 palette) - -exampleScatter :: [[V2 Double]] -> Chart' a -exampleScatter xys = - withChart (chartAspect .~ asquare $ def) (scatterChart scatterDefs) xys - -exampleScatter2 :: [[V2 Double]] -> Chart' a -exampleScatter2 xys = - withChart (chartAspect .~ asquare $ def) (scatterChart scatterDefs) xys1 - where - xys1 = fmap (over _x (*1e8) . over _y (*1e-8)) <$> xys - -histDefs :: [RectConfig] -histDefs = - [ def - , rectBorderColor .~ Color 0 0 0 0 - $ rectColor .~ Color 0.333 0.333 0.333 0.4 - $ def - ] - --- | withCharts doesn't work with a V4 where w and z effect the XY plane range -exampleHist :: [[Rect Double]] -> Chart' a -exampleHist rs = - histChart histDefs widescreen rs <> - axes - ( chartRange .~ Just (fold . fold $ rs) - $ chartAspect .~ widescreen - $ def) - -exampleHistGrey :: [Rect Double] -> Chart' a -exampleHistGrey xys = - histChart [histDefs!!1] widescreen [xys] <> - axes - ( chartRange .~ Just (fold xys) - $ chartAspect .~ widescreen - $ def) - -exampleHistCompare :: DealOvers -> Histogram -> Histogram -> Chart' a -exampleHistCompare o h1 h2 = - let h = fromHist o h1 - h' = fromHist o h2 - h'' = zipWith (\(Rect (V2 (Range (x,y)) (Range (z,w)))) (Rect (V2 _ (Range (_,w')))) -> Rect (V2 (Range (x,y)) (Range (z,w-w')))) h h' - flat = Aspect $ Rect (V2 (Range (-0.75,0.75)) (Range (-0.25,0.25))) - in - pad 1.1 $ - beside (r2 (0,-1)) (histChart - [ def - , rectBorderColor .~ Color 0 0 0 0 - $ rectColor .~ Color 0.333 0.333 0.333 0.1 - $ def ] sixbyfour [h,h'] <> - axes (ChartConfig 1.1 - [def] - (Just (fold $ fold [h,h'])) - sixbyfour (uncolor transparent))) - (histChart - [ rectBorderColor .~ Color 0 0 0 0 - $ rectColor .~ Color 0.888 0.333 0.333 0.8 - $ def ] flat [h''] <> - axes (ChartConfig 1.1 - [ axisAlignedTextBottom .~ 0.65 $ - axisAlignedTextRight .~ 1 $ - axisOrientation .~ Y $ - axisPlacement .~ AxisLeft $ - def - ] - (Just (fold h'')) - flat (uncolor transparent))) - -exampleHistGrey2 :: [Rect Double] -> Chart' a -exampleHistGrey2 rs = - lineChart lineDefs widescreen - [(\(Rect (V2 (Range (x,z)) (Range (_,w)))) -> V2 ((x+z)/(one+one)) w) <$> - rs] <> - axes - ( chartRange .~ Just (fold rs) - $ chartAspect .~ widescreen - $ def) - -exampleLabelledBar :: Chart' a -exampleLabelledBar = - histChart [def] - sixbyfour - [rs] <> - axes - ( chartAxes .~ - [ axisTickStyle .~ - TickLabels labels' $ def - ] - $ chartAspect .~ sixbyfour - $ chartRange .~ Just (fold rs) - $ def - ) - where - labels' = fmap pack <$> take 10 $ (:[]) <$> ['a'..] - rs :: [Rect Double] - rs = abs . view rect <$> - zipWith4 V4 [0..10] (replicate 11 0) [1..11] [1,2,3,5,8,0,-2,11,2,1] - -exampleArrow :: [V4 Double] -> Chart' a -exampleArrow xs = - arrowChart def (V4 one one one one) xs <> - axes ( chartRange .~ Just - ( rangeV42Rect $ rangeV4 $ scaleV4s (V4 one one one one) xs) - $ chartAspect .~ asquare $ def) - --- clipping -exampleClipping :: Chart a -exampleClipping = - L.fold (L.Fold step1 mempty identity) $ - (\y -> L.fold (L.Fold step mempty identity) - (Rect . (`V2` y) <$> qb)) <$> - qb - where - step x a = beside (r2 (1,0)) x (pad 1.05 $ center $ blob (Color 0 0 0 0.02) box a <> clip ch a) - step1 x a = beside (r2 (0,1)) x (pad 1.05 $ center a) - qs = fromIntegral <$> ([0..4] :: [Int]) :: [Double] - qb = (\x -> (-0.5 + x*0.2) ... (-0.5 + (x+1.0)*0.2)) <$> qs - clip ch1 sq = clipped (pathFromLocTrail $ box sq) ch1 - ch = lineChart lineDefs asquare lineData - --- compound charts -exampleCompound :: IO [QChart a [[V2 Double]]] -exampleCompound = do - xys <- mkScatterData - let qsc = QChart (scatterChart scatterDefs) (rangeR2s xys) xys - let xy0 = rangeR2s $ lineData <> xys - pure [qsc, qaxes xy0, qline] - where - qline = QChart (lineChart lineDefs) (rangeR2s lineData) lineData - qaxes xy = - QChart - (\a _ -> axes - ( chartRange .~ Just xy - $ chartAspect .~ a - $ def)) xy [] - -exampleScatterHist :: [[V2 Double]] -> Chart' a -exampleScatterHist xys = - beside (r2 (1,0)) - (beside (r2 (0,-1)) - (sc1 <> axes1) - (reflectY histx)) - (reflectY $ rotateBy (3/4) histy) - where - sc1 = scatterChart [scatterColor .~ Color 0.365 0.647 0.855 0.1 $ def, def] asquare xys - histx = histChart defHist xyHist hx - histy = histChart defHist xyHist hy - defHist = - [ def - , rectBorderColor .~ Color 0 0 0 0 - $ rectColor .~ Color 0.333 0.333 0.333 0.4 - $ def - ] - xyHist = Aspect (Rect (V2 one ((0.2*)<$>one))) - hx = makeHist 50 . fmap (view _x) <$> xys - hy = makeHist 50 . fmap (view _y) <$> xys - axes2 = - [ axisAlignedTextBottom .~ 0.65 $ - axisAlignedTextRight .~ 0.5 $ - axisLabelStrut .~ 0.04 $ - axisOrientation .~ X $ - axisPlacement .~ AxisTop $ - def, - axisInsideStrut .~ 0.05 $ - axisAlignedTextBottom .~ 0.65 $ - axisAlignedTextRight .~ 1 $ - axisOrientation .~ Y $ - axisPlacement .~ AxisLeft $ - def] - axes1 = - axes - (ChartConfig 1 axes2 (Just $ rangeR2s xys) asquare (Color 0.5 0.5 1 0.04)) - -exampleGgplot :: Chart' a -exampleGgplot = - lineChart (repeat (LineConfig 0.002 (Color 0.98 0.98 0.98 1))) sixbyfour (gridX <> gridY) <> - blob (Color 0.92 0.92 0.92 1) (box (Rect (V2 ((1.5*) <$> one) one))) <> - axes ggdef - where - gridX = (\x -> [V2 0 x, V2 10 x]) . fromIntegral <$> ([0..10] :: [Int]) - gridY = (\x -> [V2 x 0, V2 x 10]) . fromIntegral <$> ([0..10] :: [Int]) - ggdef = - ChartConfig - 1.1 - [defx] - (Just $ Rect (V2 (0 ... 10) (0 ... 10))) - sixbyfour - (Color 1 1 1 0) - defx = - AxisConfig - 1.0 - X - AxisBottom - 0 - (Color 0 0 0 0.2) - 0.018 - (Color 0 0 0 1) - 0 - 0.01 - 0.04 - (Color 0.2 0.2 0.2 0.7) - (TickRound 5) - 0.5 - 1 - -examplePixels :: Chart' a -examplePixels = - pixelf - (pixelGrain .~ V2 10 10 $ def) - asquare (Rect (V2 (-1 ... 1) (-1 ... 1))) - (\(V2 x y) -> x*y+x*x) <> - axes - ( chartRange .~ Just (Rect (V2 (-1 ... 1) (-1 ... 1))) - $ chartAspect .~ asquare - $ def) - -makeOneDim :: IO [[(Double,Text)]] -makeOneDim = do - qs <- makeQuantiles 20 - qs5 <- makeQuantiles 4 - let labels5 = ["min","3rd Q","median","1st Q","max"] - pure [zip qs5 labels5, zip qs (repeat "")] - -exampleOneDim :: [[(Double,Text)]] -> Chart' a -exampleOneDim qss = - axes (ChartConfig 1.1 [def] (Just (Rect (V2 (range $ fst <$> (qss!!0)) (Range (0,0))))) skinny (uncolor transparent)) <> - axes (ChartConfig 1.1 [axisColor .~ uncolor transparent $ axisMarkSize .~ 0.05 $ axisMarkColor .~ uncolor (withOpacity red 0.3) $ axisTickStyle .~ TickPlaced (qss!!1) $ def] (Just (Rect (V2 (range $ fst <$> (qss!!1)) (Range (0,0))))) skinny (uncolor transparent)) <> - axes (ChartConfig 1.1 [axisColor .~ uncolor transparent $ axisMarkSize .~ 0.1 $ axisTextSize .~ 0.08 $ axisMarkColor .~ uncolor (withOpacity black 0.5) $ axisTickStyle .~ TickPlaced (qss!!0) $ def] (Just (Rect (V2 (range $ fst <$> (qss!!0)) (Range (0,0))))) skinny (uncolor transparent)) - where - skinny = Aspect (Rect (V2 ((5*) <$> one) one)) - -displayHeader :: FilePath -> [(Diagram B, GifDelay)] -> IO () -displayHeader fn = - mainRender ( DiagramOpts (Just 900) (Just 700) fn - , GifOpts {_dither = False, _noLooping = False, _loopRepeat = Just 2} - ) - -chartRange' :: [[Rect Double]] -> Rect Double -chartRange' = fold . fold - -exampleHistAnim :: Rect Double -> Aspect -> [[Rect Double]] -> Chart' a -exampleHistAnim cr asp rs = - histChartWithRange cr histDefs asp rs <> - axes - ( chartRange .~ Just cr - $ chartAspect .~ asp - $ def) - -exampleAnimation :: FilePath -> IO () -exampleAnimation f = do - xs <- mkHistData - let yss = inits (xs!!0) - let cr = chartRange' yss - let us :: [Diagram B ] - us = exampleHistAnim cr widescreen . pure <$> yss - - displayHeader f $ zip us (repeat (10 :: Int)) - -main :: IO () -main = do - let sOne = (400,400) - let s6by4 = (600,400) - let sWide = (750,250) - - fileSvg "other/exampleBox.svg" s6by4 exampleBox - fileSvg "other/exampleAxes.svg" s6by4 exampleAxes - fileSvg "other/exampleEmpty.svg" s6by4 exampleEmpty - fileSvg "other/exampleGgplot.svg" sWide exampleGgplot - fileSvg "other/exampleGrid.svg" sOne exampleGrid - fileSvg "other/exampleLine.svg" s6by4 exampleLine - fileSvg "other/exampleLineAxes.svg" s6by4 exampleLineAxes - fileSvg "other/exampleLineAxes2.svg" s6by4 exampleLineAxes2 - xys <- mkScatterData - fileSvg "other/exampleScatter.svg" sOne (exampleScatter xys) - fileSvg "other/exampleScatter2.svg" sOne (exampleScatter2 xys) - xs <- mkHistData - fileSvg "other/exampleHist.svg" sWide (exampleHist xs) - rectqs <- makeRectQuantiles 50 - fileSvg "other/exampleHistUnequal.svg" sWide (exampleHistGrey rectqs) - fileSvg "other/exampleHistUnequal2.svg" sWide (exampleHistGrey2 rectqs) - hs <- mkHistogramData - fileSvg "other/exampleHistCompare.svg" s6by4 (exampleHistCompare (IncludeOvers 1) (hs!!0) (hs!!1)) - fileSvg "other/exampleScatterHist.svg" sOne (pad 1.1 $ center $ exampleScatterHist xys) - fileSvg "other/exampleLabelledBar.svg" s6by4 exampleLabelledBar - fileSvg "other/exampleArrow.svg" sOne (exampleArrow arrowData) - exc <- exampleCompound - fileSvg "other/exampleCompound.svg" s6by4 (pad 1.1 $ center $ combine golden exc) - fileSvg "other/exampleClipping.svg" sOne exampleClipping - fileSvg "other/examplePixels.svg" sOne examplePixels - qss <- makeOneDim - fileSvg "other/exampleOneDim.svg" (750,150) (exampleOneDim qss) - exampleAnimation "other/anim.gif" - - scratch (exampleHistCompare (IncludeOvers 1) (hs!!0) (hs!!1)) - -- fileSvg "other/scratchpad.svg" (600,150) $ pad 1.1 $ - -- showOrigin $ exampleOneDim qss diff --git a/examples/sourceExamples.hs b/examples/sourceExamples.hs new file mode 100644 --- /dev/null +++ b/examples/sourceExamples.hs @@ -0,0 +1,633 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +import Chart +import Control.Lens hiding (beside, (#), at) +import qualified Data.Text as Text +import NumHask.Prelude +import Data.List (zipWith3, zipWith4) +import Diagrams.Prelude hiding ((*.), scaleX, scaleY, width) +import FakeData +import Diagrams.Backend.Rasterific (Rasterific, animatedGif, GifLooping(..)) + +hudbits :: Text -> Maybe Text -> [Text] -> [LegendType b] -> HudOptions b -> HudOptions b +hudbits t subt ts ls x = + hudTitles_ .~ + [ (titlePlace_ .~ PlaceLeft $ + titleAlign_ .~ AlignLeft $ + titleText_ . textRotation_ .~ 90 $ + titleText_ . textSize_ .~ 0.25 $ + titleText_ . textColor_ .~ d3Colors1 0 `withOpacity` 1 $ + def, t)] <> + (case subt of + Nothing -> [] + Just subt' -> + [(titlePlace_ .~ PlaceBottom $ + titleAlign_ .~ AlignRight $ + titleText_ . textRotation_ .~ 0 $ + titleText_ . textSize_ .~ 0.14 $ + titleText_ . textColor_ .~ d3Colors1 0 `withOpacity` 1 $ + def, subt')]) $ + hudLegends_ .~ + [ legendChartType_ .~ + zip ls ts $ + legendAlign_ .~ AlignRight $ def + ] $ + hudAxes_ . each . axisGap_ .~ 0.1 $ + x + +text_Example :: Chart b +text_Example = text_ def "Welcome to chart-unit!" + +textsExample :: Chart b +textsExample = texts def ts [Pair (0.05 * x) 0 | x <- [0 .. 5]] + where + ts = map Text.singleton ['a' .. 'z'] + +ts :: [(Text, Pair Double)] +ts = + zip + (map Text.singleton ['a' .. 'z']) + [Pair (sin (x * 0.1)) x | x <- [0 .. 25]] + +textChart_Example :: Chart b +textChart_Example = + textChart_ (repeat $ def {textSize = 0.33}) widescreen [ts] + +textHudExample :: Chart b +textHudExample = hud + ( hudbits "Text Chart" (Just "text and glyphs have a similar feel") [] [] $ + hudRange_ .~ Just (range ts) $ + hudAspect_ .~ widescreen $ + def) + +labelledExample :: Chart b +labelledExample = + labelled + (LabelOptions + (def {textAlignH = AlignLeft, textRotation = 45}) + (Pair 1 1) + 0.05) + "a label" + (glyph_ def) + +glyph_Example :: Chart b +glyph_Example = glyph_ def + +glyphsExample :: Chart b +glyphsExample = glyphs def [Pair (x / 10) (sin x / 10) | x <- [0 .. 10]] + +gopts :: [GlyphOptions b] +gopts = [def, def {glyphBorderColor = ured, glyphShape = triangle}] + +gdata :: [[Pair Double]] +gdata = [p_1, p_2] + where + p_1 = [Pair x (sin (x / 10)) | x <- [0 .. 100]] + p_2 = [Pair x (cos (x / 10)) | x <- [0 .. 100]] + +glyphChart_Example :: Chart b +glyphChart_Example = glyphChart_ gopts widescreen gdata + +glyphHudExample :: Chart b +glyphHudExample = + hud (hudLegends_ . each . legendAlign_ .~ AlignLeft $ + hudbits "Glyph Chart" Nothing ["sin", "cos"] + (LegendGlyph <$> gopts) $ + hudRange_ .~ Just (range gdata) $ + hudAspect_ .~ widescreen $ + def) + +lglyphsExample :: Chart b +lglyphsExample = + lglyphs def def $ + zip (show <$> [0 ..]) [Pair (x / 10) (sin x / 10) | x <- [0 .. 10]] + + +lgdata :: [[(Text, Pair Double)]] +lgdata = + [(\(p@(Pair x y)) -> (show x <> "," <> show y, fromIntegral <$> p)) <$> g] + where + g = Pair <$> [0 .. 5] <*> [0 .. 5] :: [Pair Int] + +lglyphChart_Example :: Aspect -> Chart b +lglyphChart_Example a = + lglyphChart_ + [labelGap_ .~ 0.015 $ labelText_ . textSize_ .~ 0.12 $ def] + [glyphColor_ .~ black `withOpacity` 1 $ + glyphBorderSize_ .~ 0 $ + glyphSize_ .~ 0.01 $ + def] + a + lgdata + +lglyphHudExample :: Chart b +lglyphHudExample = hud + ( hudTitles_ . each . _1 . titleGap_ .~ 0.2 $ + hudbits "LGlyph Chart" (Just "Glyphs with text labels are very useful") [] [] $ + hudAxes_ .~ [] $ + hudRange_ .~ Just (range (fmap snd <$> lgdata)) $ + hudAspect_ .~ widescreen $ + def) + +linesExample :: Int -> Chart b +linesExample n = + lines + def + [ Pair (10 * x / fromIntegral n) (cos (x * (10 / fromIntegral n))) + | x <- fromIntegral <$> [0 .. n] + ] + +ls :: [[Pair Double]] +ls = + map (uncurry Pair) <$> + [ [(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)] + , [(0.0, 0.0), (3.0, 3.0)] + , [(0.5, 4.0), (0.5, 0)] + ] + +lopts :: [LineOptions] +lopts = + zipWith + (\x y -> LineOptions x (withOpacity (d3Colors1 y) 0.6)) + [0.01, 0.02, 0.005] + [0,1,2] + +lineChart_Example :: Chart b +lineChart_Example = lineChart_ lopts sixbyfour ls + +lineHudExample :: Chart b +lineHudExample = + hud (hudbits "Line Chart" Nothing ["hockey stick", "slope", "vertical"] + ((`LegendLine` 0.05) <$> lopts) $ + hudRange_ .~ Just (range ls) $ + def) + +gopts3 :: (Renderable (Path V2 Double) b) => [GlyphOptions b] +gopts3 = + zipWith + (\x y -> + def + { glyphColor = withOpacity (d3Colors1 x) 0.2 + , glyphBorderColor = withOpacity (d3Colors1 x) 1 + , glyphBorderSize = 0.005 + , glyphShape = y + , glyphSize = 0.08 + }) + [6,8,2] + [triangle, square, circle . (0.5*)] + +glineChart_Example :: Chart b +glineChart_Example = glineChart_ lopts gopts3 sixbyfour ls + +glineHudExample :: Chart b +glineHudExample = + hud ( hudLegends_ . each . legendGap_ .~ 0.2 $ + hudTitles_ . each . _1 . titleGap_ .~ 0.2 $ + hudbits "Gline Chart" Nothing ["triangle", "square", "circle"] + (zipWith3 LegendGLine gopts3 lopts (repeat 0.1)) $ + hudAxes_ .~ [] $ + hudRange_ .~ Just (Rect 0 5 0 5) $ + def) <> + glineChart lopts gopts3 sixbyfour (Rect 0 5 0 5) ls <> + lglyphChart_Example sixbyfour + +rect_Example :: Double -> Chart b +rect_Example n = + labelled (opts (Pair n 1)) "z,w" $ + labelled (opts (Pair n -1)) "z,y" $ + labelled (opts (Pair (-n) 1)) "x,w" $ + labelled (opts (Pair (-n) -1)) "x,y" $ + rect_ def (Ranges (n *. one) one) + where + opts o = + def + { labelText = + (labelText def) {textColor = withOpacity black 0.8, textSize = 0.3} + , labelOrientation = o + } + +rectsExample :: Chart b +rectsExample = + rects def $ + zipWith (\x y -> Rect x (x + 1) 0 y) [0 ..] [1, 2, 3, 5, 8, 0, -2, 11, 2, 1] + +ropts :: [RectOptions] +ropts = + [ def {rectBorderSize = 0} + , def {rectBorderSize = 0, rectColor = ucolor 0.3 0.3 0.3 0.2} + ] + +rss :: [[Rect Double]] +rss = zipWith (\x y -> Rect x (x + 1) 0 y) [0 ..] <$> pss + where + pss = + transpose + [ [exp (-(x ** 2) / 2), 0.5 * exp (-(x ** 2) / 8)] + | x <- grid LowerPos (Range -5 5) 1000 + ] + +rectChart_Example :: Chart b +rectChart_Example = rectChart_ ropts widescreen rss + +rectHudExample :: Chart b +rectHudExample = + hud ( hudLegends_ . each . legendPlace_ .~ PlaceBottom $ + hudLegends_ . each . legendAlign_ .~ AlignCenter $ + hudbits "Rect Chart" Nothing ["blue gaussian", "grey wider distribution"] + ((`LegendRect` 0.05) <$> ropts) $ + hudRange_ .~ Just (fold $ fold rss) $ + hudAspect_ .~ widescreen $ + hudAxes_ .~ [defXAxis] $ + def) + +pixel_Example :: Chart b +pixel_Example = text_ opt "I'm a pixel!" <> pixel_ (Pixel one ublue) + where + opt = def {textColor = withOpacity black 0.8, textSize = 0.2} + +pixelsExample :: Chart b +pixelsExample = + pixels + [ Pixel + (Rect (5 * x) (5 * x + 0.1) (sin (10 * x)) (sin (10 * x) + 0.1)) + (dissolve (2 * x) ublue) + | x <- grid OuterPos (Range 0 1) 100 + ] + +pixelChart_Example :: Chart b +pixelChart_Example = + pixelChart_ + asquare + [ [ Pixel + (Rect x (x + 0.05) y (y + 0.05)) + (blend (x * y + x * x) ured ublue) + | x <- grid MidPos (one :: Range Double) 20 + , y <- grid MidPos (one :: Range Double) 20 + ] + ] + +pixelateChartExample :: Chart b +pixelateChartExample = pixelateChart def asquare one (\(Pair x y) -> x*y+x*x) + +pixelHudExample :: Chart b +pixelHudExample = + hud (hudbits "Pixel Chart" Nothing ["red", "blue"] + ((`LegendPixel` 0.05) <$> ropts) $ + hudRange_ .~ Just one $ + hudAspect_ .~ asquare $ + def) + +arrowsExample :: Chart b +arrowsExample = + arrows + (def + {arrowMaxLength = 0.5, arrowMaxHeadLength = 0.2, arrowMaxStaffWidth = 0.01}) + [ Arrow (Pair x (sin (5 * x))) (Pair x (cos x)) + | x <- grid MidPos (one :: Range Double) 100 + ] + +arrowChart_Example :: Chart b +arrowChart_Example = arrowChart_ [def] asquare [as] + where + as = + normArrows + [ Arrow (Pair x y) (Pair (sin 1 / x + 0.0001) (cos 1 / y + 0.0001)) + | x <- grid MidPos (one :: Range Double) 20 + , y <- grid MidPos (one :: Range Double) 20 + ] + +arrowHudExample :: Chart b +arrowHudExample = + hud ( hudbits "Arrow Chart" Nothing ["this way up"] [] $ +-- ((`LegendArrow` 0.05) <$> [def]) $ + hudRange_ .~ Nothing $ + hudAspect_ .~ asquare $ + def) + +hudExample :: Chart b +hudExample = hud def + +withHudExample :: Chart b +withHudExample = withHud hopts (lineChart lopts) ls + where + hopts = + def + { hudTitles = [(def, "withHud Example")] + , hudLegends = + [ def + { legendChartType = + zipWith + (\x y -> (LegendLine x 0.05, y)) + lopts + ["line1", "line2", "line3"] + } + ] + } + +axisExample :: Chart b +axisExample = axis aopts one (Range 0 100000) + where + aopts = + def + { axisLabel = + (axisLabel def) + { labelGap = 0.0001 + , labelText = + (labelText (axisLabel def)) + {textSize = 0.06, textAlignH = AlignLeft, textRotation = -45} + } + } + +legends :: [(LegendType b, Text)] +legends = + [(LegendText def, "legend")] <> [(LegendPixel (blob ublue) 0.05, "pixel")] <> + -- [ (LegendArrow (def {arrowMinStaffWidth=0.01, + -- arrowMinHeadLength=0.03}) 0.05, "arrow")] <> + [(LegendRect def 0.05, "rect")] <> + [(LegendGLine def def 0.10, "glyph+line")] <> + [(LegendGlyph def, "just a glyph")] <> + zipWith + (\x y -> (LegendLine x 0.05, y)) + lopts + ["short", "much longer name", "line 3"] + +legendExample :: Chart b +legendExample = legend $ def {legendChartType = legends} + +mainExample :: Diagram B +mainExample = withHud opts (lineChart lopts) ls + where + opts = + hudTitles_ .~ titles $ hudAxes_ .~ + [ defXAxis + , defYAxis + , axisLabel_ . labelOrientation_ .~ Pair 0 1 $ axisPlace_ .~ PlaceTop $ + defXAxis + , axisLabel_ . labelOrientation_ .~ Pair 1 0 $ axisPlace_ .~ PlaceRight $ + defYAxis + ] $ + hudAxes_ %~ + map (axisPad_ .~ 1) $ + hudLegends_ .~ + [legendChartType_ .~ legends $ def] $ + def + +titles :: [(TitleOptions, Text)] +titles = + [ (def, "Example Chart") + , ( titleAlign_ .~ AlignCenter $ titleText_ . textRotation_ .~ 90 $ titleText_ . + textSize_ .~ + 0.12 $ + titlePlace_ .~ + PlaceLeft $ + def + , "left axis title") + , ( titleText_ . textColor_ .~ ublue $ titleText_ . textSize_ .~ 0.08 $ + titleAlign_ .~ + AlignRight $ + titlePlace_ .~ + PlaceBottom $ + def + , "bottom right, non-essential note") + ] + + +-- gallery + +scatterHistExample :: [[Pair Double]] -> Diagram B +scatterHistExample xys = + beside (r2 (1,0)) + (beside (r2 (0,-1)) + (sc1 <> hud1) + (reflectY histx)) + (reflectY $ rotateBy (3/4) histy) + where + sopts = + zipWith3 (\x y z -> GlyphOptions x y (ucolor 0 0 0 0) 0 z) + [0.01,0.02,0.03] + ((\x -> withOpacity (d3Colors1 x) 0.3) <$> [6,8]) + [circle, triangle, square] + + mainAspect = Aspect $ Rect -0.5 0.5 -0.5 0.5 + minorAspect = Aspect $ Rect -0.5 0.5 -0.1 0.1 + sc1 = glyphChart_ sopts mainAspect xys + histx = rectChart_ defHist minorAspect hx + histy = rectChart_ defHist minorAspect hy + hud1 = hud (hudAxes_ .~ [axisPlace_ .~ PlaceTop $ + axisLabel_ . labelOrientation_ .~ Pair 0 1 $ + def] $ + hudAspect_ .~ mainAspect $ + hudRange_ .~ Just (range xys) $ + def) + defHist = + (\x -> rectBorderSize_ .~ 0 $ + rectColor_ .~ d3Colors1 x `withOpacity` 0.5 $ + def) <$> [6,8] + hx = makeHist 50 . fmap (view _x) <$> xys + hy = makeHist 50 . fmap (view _y) <$> xys + + +labelledBarExample :: Diagram B +labelledBarExample = + rectChart_ [def] + sixbyfour + [rs] <> + textChart (repeat (textColor_ .~ ucolor 0.33 0.33 0.33 0.8 $ def)) sixbyfour + (Rect -0.5 9.5 (-2) 11) + [zipWith (\x y -> (show y, Pair x ((if y>0 then -1 else 0.5) + y))) [0..] ys] <> + hud + ( hudAxes_ .~ + [ axisTickStyle_ .~ + TickLabels labels' $ + def + ] + $ hudAspect_ .~ sixbyfour + $ hudRange_ .~ Just (fold (abs <$> rs)) + $ def + ) + where + labels' = fmap Text.pack <$> take 10 $ (:[]) <$> ['a'..] + rs :: [Rect Double] + rs = (\(Ranges a b) -> Ranges (abs a) (abs b)) <$> zipWith4 Rect [0..10] [1..11] (replicate 11 0) ys + ys = [1,2,3,5,8,0,-2,11,2,1] + +skinnyExample :: IO (Diagram B) +skinnyExample = do + qs <- makeQuantiles 20 + qs' <- makeQuantiles 4 + let r = Ranges (space qs) (Range 0 0.2) + let hud' = + hud (HudOptions 1.1 + [axisLabel_ . labelText_ . textSize_ .~ 0.25 $ def] [] [] + (Just r) + skinny clear) + let labels' = textChart + [textAlignH_ .~ AlignLeft $ + textRotation_ .~ 45 $ + textSize_ .~ 0.2 $ + def] skinny r + [zipWith (\x y -> (x,Pair y 0.05)) + ["min","3rd Q","median","1st Q","max"] qs'] + let ticks' = glyphChart [def] skinny r [(\x -> Pair x 0.02) <$> qs] + pure $ hud' <> ticks' <> labels' + +histDiffExample :: ([Rect Double],[Rect Double]) -> Chart b +histDiffExample (h1, h2) = + let deltah = zipWith (\(Rect x y z w) (Rect _ _ _ w') -> Rect x y z (w-w')) h1 h2 + mainAspect = Aspect (Rect -0.75 0.75 -0.5 0.5) + botAspect = Aspect (Rect -0.75 0.75 -0.2 0.2) + (Ranges rx ry) = fold $ fold [h1,h2] + (Ranges _ deltary) = fold (abs <$> deltah) + in + pad 1.1 $ + beside (r2 (0,-1)) + (rectChart + [ rectBorderColor_ .~ ucolor 0 0 0 0 $ + rectColor_ .~ ucolor 0.365 0.647 0.855 0.2 $ + def + , rectBorderColor_ .~ ucolor 0 0 0 0 $ + rectColor_ .~ ucolor 0.333 0.333 0.333 0.2 $ + def ] + mainAspect + (Ranges rx ry) + [h1,h2]) + (rectChart + [ rectBorderColor_ .~ ucolor 0 0 0 0 $ + rectColor_ .~ ucolor 0.88 0.53 0.23 0.8 $ + def ] + botAspect + (Ranges rx deltary) + [deltah] <> + hud (hudAspect_ .~ botAspect $ + hudRange_ .~ Just (Ranges rx deltary) $ + def)) + + +clip :: Rect Double -> Chart b -> Chart b +clip (Rect xl xu yl yu) c = + clipped (pathFromLocTrail $ + moveTo (p2(xl,yl)) $ + scaleY (yu - yl) $ + scaleX (xu - xl) $ + moveOriginTo (p2(-0.5,-0.5)) + unitSquare) $ c + +grp :: Int -> [a] -> [[a]] +grp n = unfoldr + (\x -> let y = splitAt n x in + if length (fst y) == 0 then Nothing else Just y) + +exampleClipping :: RectOptions -> Double -> Int -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any +exampleClipping rcfg p n ch = + foldl' vert mempty $ (foldl' hori mempty) <$> qb + where + hori x a = beside (r2 (0,1)) x (pad p $ bound rcfg 1 $ centerXY $ clip a ch) + vert x a = beside (r2 (1,0)) x (pad p $ centerXY $ a) + qb :: [[Rect Double]] = grp n $ gridSpace (Rect xl xu yl yu) (Pair n n) + (xl,xu) = fromMaybe (-0.5,0.5) (extentX ch) + (yl,yu) = fromMaybe (-0.5,0.5) (extentY ch) + +exampleClipping' :: RectOptions -> Double -> Double -> Int -> QDiagram Rasterific V2 Double Any -> QDiagram Rasterific V2 Double Any +exampleClipping' rcfg rot p n ch = + foldl' vert mempty $ (foldl' hori mempty) <$> qb + where + hori x a = beside (r2 (0,1)) x (Diagrams.Prelude.rotate (rot @@ deg) $ pad p $ bound rcfg 1 $ centerXY $ clip a ch) + vert x a = beside (r2 (1,0)) x (pad p $ centerXY $ a) + qb :: [[Rect Double]] = grp n $ gridSpace (Rect xl xu yl yu) (Pair n n) + (xl,xu) = fromMaybe (-0.5,0.5) (extentX ch) + (yl,yu) = fromMaybe (-0.5,0.5) (extentY ch) + +animationExample :: FilePath -> IO () +animationExample f = do + let c = ((\x -> bound (rectColor_ .~ ucolor 1 1 1 0.1 $ def) 1 $ + exampleClipping' (rectBorderSize_ .~ 0.001 $ + rectColor_ .~ ucolor 1 1 1 0.1 $ def) + (x*12) 1 5 lineChart_Example) <$> [0..30]) + animatedGif f (mkSizeSpec (Just <$> r2 (600,400))) LoopingNever 20 c + +schoolbookExample :: Diagram B +schoolbookExample = + pad 1.1 $ + lineChart_ + (repeat $ + lineColor_ .~ ucolor 0.4 0.5 0.2 0.8 $ + lineSize_ .~ 0.001 $ + def) asquare $ + (\x -> [Pair -10.0 (-10 + 2*x), Pair 10.0 (-10 + 2*x)]) <$> + fromIntegral <$> ([0..10] :: [Int]) + +main :: IO () +main = do + fileSvg "other/text_Example.svg" (400, 100) text_Example + fileSvg "other/textsExample.svg" (400, 100) textsExample + fileSvg "other/textChart_Example.svg" (300, 100) textChart_Example + fileSvg "other/labelledExample.svg" (300, 100) labelledExample + fileSvg "other/glyph_Example.svg" (400, 100) glyph_Example + fileSvg "other/glyphsExample.svg" (400, 100) glyphsExample + fileSvg "other/glyphChart_Example.svg" (450, 150) glyphChart_Example + fileSvg "other/lglyphsExample.svg" (400, 100) lglyphsExample + fileSvg "other/lglyphChart_Example.svg" (600, 200) (lglyphChart_Example widescreen) + fileSvg "other/linesExample.svg" (400, 100) (linesExample 100) + fileSvg "other/lineChart_Example.svg" (300, 200) lineChart_Example + fileSvg "other/glineChart_Example.svg" (300, 200) glineChart_Example + fileSvg "other/rect_Example.svg" (300, 200) $ rect_Example 2 + fileSvg "other/rectsExample.svg" (300, 200) rectsExample + fileSvg "other/rectChart_Example.svg" (300, 100) rectChart_Example + fileSvg "other/pixel_Example.svg" (100, 100) pixel_Example + fileSvg "other/pixelsExample.svg" (300, 100) pixelsExample + fileSvg "other/pixelChart_Example.svg" (300, 300) pixelChart_Example + fileSvg "other/arrowsExample.svg" (100, 300) arrowsExample + fileSvg "other/arrowChart_Example.svg" (300, 300) arrowChart_Example + fileSvg "other/hudExample.svg" (300, 300) hudExample + fileSvg "other/withHudExample.svg" (300, 200) withHudExample + fileSvg "other/axisExample.svg" (400, 100) axisExample + fileSvg "other/legendExample.svg" (300, 300) legendExample + fileSvg "other/mainExample.svg" (600, 400) mainExample + + -- readme images + fileSvg "other/textHudExample.svg" (600, 400) $ + textHudExample <> textChart_Example + fileSvg "other/glyphHudExample.svg" (600, 400) $ + glyphHudExample <> glyphChart_Example + fileSvg "other/lglyphHudExample.svg" (600, 400) $ + lglyphHudExample <> lglyphChart_Example widescreen + fileSvg "other/lineHudExample.svg" (600, 400) $ + lineHudExample <> lineChart_Example + fileSvg "other/glineHudExample.svg" (600, 400) + glineHudExample + fileSvg "other/rectHudExample.svg" (600, 400) $ + rectHudExample <> rectChart_Example + fileSvg "other/pixelHudExample.svg" (600, 400) $ + pixelHudExample <> pixelateChartExample + fileSvg "other/arrowHudExample.svg" (600, 400) $ + arrowHudExample <> arrowChart_Example + + + -- gallery + + xys <- mkScatterData + putStrLn ("scatterHistExample" :: Text) + fileSvg "other/scatterHistExample.svg" (600,400) (scatterHistExample xys) + putStrLn ("labelledBarExample" :: Text) + fileSvg "other/labelledBarExample.svg" (600,400) labelledBarExample + putStrLn ("skinnyExample" :: Text) + skinnyExample' <- skinnyExample + fileSvg "other/skinnyExample.svg" (600,150) skinnyExample' + putStrLn ("histDiffExample" :: Text) + hs <- makeHistDiffExample + fileSvg "other/histDiffExample.svg" (600,600) $ + histDiffExample hs + putStrLn ("clippingExample" :: Text) + fileSvg "other/clippingExample.svg" (600,600) $ + exampleClipping (rectColor_ .~ ucolor 0.3 0.3 0.3 0.1 $ def) 1.1 5 + lineChart_Example + putStrLn ("animationExample" :: Text) + animationExample "other/animationExample.gif" + putStrLn ("schoolbookExample" :: Text) + fileSvg "other/schoolbookExample.svg" (400,400) schoolbookExample diff --git a/index.html b/index.html deleted file mode 100644 --- a/index.html +++ /dev/null @@ -1,159 +0,0 @@ - - -

chart-unit

-

Build Status Hackage lts nightly

-

repo

-

chart-unit is an experimental haskell chart library.

-

scratchpad

-

-

unital charting

-

This slowly growing collection of charts:

- -

charts

-

A chart can be anything that is represented on an XY plane, and usually comes with visual clues about what is being represented, such as axes, titles and legends. Here's the default blank chart:

-
- - -
-
axes (chartAspect .~ sixbyfour $ chartRange .~ Just one $ def)
-

sixbyfour is a value of type XY, and represents the rectangle that the chart will be rendered with. As with any SVG element, the ultimate product is still subject to sizing on use, so think of sixbyfour as a relative aspect ratio rather than a concrete size.

-

XY

-

chartRange is the range which we would like to plot. chartRange .~ Nothing represents that the range should be whatever the data range is.

-

customization

-

Axes and most other things are highly customizable. Here's another style of chart:

-
- - -
-

line chart

-

Some actual, real-life lines to be plotted:

-
- - -
-
lines lineDefs sixbyfour lineData
-

Breaking the code down:

- -

withChart

-

You don't have to do anything special to combine these lines with axes.

-
- - -
-
lines lineDefs sixbyfour lineData <> 
-axes (chartRange .~ Just (rangeR2s lineData) $ def)
-

withChart is a convenience function for this common operation, and the code below is equivalent to the above code:

-
withChart def (lines lineDefs) lineData
-

scatter

-

Other default chart types follow this same pattern:

-
- - -
-
xys <- mkScatterData
-withChart (chartAspect .~ asquare $ def) (scatters scatterDefs) xys
-

As with line, scatter zips together multiple configurations and multiple containers of data. It's often much easier to construct charts assuming multiple data sets.

-

A major point of the chart-unit library is that the look-n-feel of a chart is invariant to the data scale.

-
- - -
-
let xys1 = fmap (over _x (*1e8) . over _y (*1e-8)) <$> xys in
-withChart (chartAspect .~ asquare $ def) (scatters scatterDefs) xys1
-

histogram

-

A histogram, in widescreen

-
- - -
-

A histogram, with unequal bin sizes (based on quantiles)

-
- - -
-

... converted to a line chart

-
- - -
-

A labelled bar chart:

-
- - -
-

pixel chart

-

A chart with a color for each XY point in a plane. Close synonyms are probably an area chart, a surface chart. A contour chart must be close.

-
- - -
-

One-dim chart

-

axes technology can be re-purposed to create skinny charts:

-
- - -
-

Compound charts

-

chart-unit is a fairly thin wrapper over diagrams that establishes the basics of what a chart is, and provides some sane defaults. From this starting point, production of high-quality charting is easy and pleasant. Some examples:

-

Comparing two histograms.

-
- - -
-

A scatter chart with histograms of the data along the x & y dimensions.

-
- - -
-

A unital gradient chart, using diagrams arrows:

-
- - -
-

The QChart type exists to enable combining different types of charts using the same scale.

-
- - -
-

Clipping charts

-
- - -
-

animation

-

-

data

-

Double-containered dimensioned data covers what a chart charts - one or more data sets with at least an x and y dimension (called R2 in the linear library).

-

Most chart variations are about what to do with the extra dimensions in the data. A rectangle, for example, is built from 4 dimensions, an anchoring of position in XY space, with a width (W) and height (Z). A contour map is three dimensional data (V3 in linear), with placement as XY and color as Z.

-

diagrams development recipe

-

In constructing new chart units:

- -

You can slide up and down the various diagrams abstraction levels creating transformations at each level. For example, here's something I use to work at the point level:

-
unitp f = unitSquare # f # fromVertices # closeTrail # strokeTrail
-

workflow

-

recipe 1

-
scratch :: Chart SVG -> IO ()
-scratch = fileSvg "other/scratchpad.svg" (600,400)
-

I tend to work in ghci a lot, using the above scratch to try code out, mashing the refresh button in the browser. Or I switch on stacks --file-watch ...

-

recipe 2

-
stack build --test --exec "$(stack path --local-install-root)/bin/chart-unit-examples" --exec "$(stack path --local-bin)/pandoc -f markdown -i examples/examples.md -t html -o index.html --filter pandoc-include --mathjax" --file-watch
diff --git a/other/arrowChart_Example.svg b/other/arrowChart_Example.svg new file mode 100644 --- /dev/null +++ b/other/arrowChart_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/arrowHudExample.svg b/other/arrowHudExample.svg new file mode 100644 --- /dev/null +++ b/other/arrowHudExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/arrowsExample.svg b/other/arrowsExample.svg new file mode 100644 --- /dev/null +++ b/other/arrowsExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/axisExample.svg b/other/axisExample.svg new file mode 100644 --- /dev/null +++ b/other/axisExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/clippingExample.svg b/other/clippingExample.svg new file mode 100644 --- /dev/null +++ b/other/clippingExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/glineChart_Example.svg b/other/glineChart_Example.svg new file mode 100644 --- /dev/null +++ b/other/glineChart_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/glineHudExample.svg b/other/glineHudExample.svg new file mode 100644 --- /dev/null +++ b/other/glineHudExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/glyphChart_Example.svg b/other/glyphChart_Example.svg new file mode 100644 --- /dev/null +++ b/other/glyphChart_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/glyphHudExample.svg b/other/glyphHudExample.svg new file mode 100644 --- /dev/null +++ b/other/glyphHudExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/glyph_Example.svg b/other/glyph_Example.svg new file mode 100644 --- /dev/null +++ b/other/glyph_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/glyphsExample.svg b/other/glyphsExample.svg new file mode 100644 --- /dev/null +++ b/other/glyphsExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/histDiffExample.svg b/other/histDiffExample.svg new file mode 100644 --- /dev/null +++ b/other/histDiffExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/hudExample.svg b/other/hudExample.svg new file mode 100644 --- /dev/null +++ b/other/hudExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/labelledBarExample.svg b/other/labelledBarExample.svg new file mode 100644 --- /dev/null +++ b/other/labelledBarExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/labelledExample.svg b/other/labelledExample.svg new file mode 100644 --- /dev/null +++ b/other/labelledExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/legendExample.svg b/other/legendExample.svg new file mode 100644 --- /dev/null +++ b/other/legendExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/lglyphChart_Example.svg b/other/lglyphChart_Example.svg new file mode 100644 --- /dev/null +++ b/other/lglyphChart_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/lglyphHudExample.svg b/other/lglyphHudExample.svg new file mode 100644 --- /dev/null +++ b/other/lglyphHudExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/lglyphsExample.svg b/other/lglyphsExample.svg new file mode 100644 --- /dev/null +++ b/other/lglyphsExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/lineChart_Example.svg b/other/lineChart_Example.svg new file mode 100644 --- /dev/null +++ b/other/lineChart_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/lineHudExample.svg b/other/lineHudExample.svg new file mode 100644 --- /dev/null +++ b/other/lineHudExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/linesExample.svg b/other/linesExample.svg new file mode 100644 --- /dev/null +++ b/other/linesExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/mainExample.svg b/other/mainExample.svg new file mode 100644 --- /dev/null +++ b/other/mainExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/pixelChart_Example.svg b/other/pixelChart_Example.svg new file mode 100644 --- /dev/null +++ b/other/pixelChart_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/pixelHudExample.svg b/other/pixelHudExample.svg new file mode 100644 --- /dev/null +++ b/other/pixelHudExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/pixel_Example.svg b/other/pixel_Example.svg new file mode 100644 --- /dev/null +++ b/other/pixel_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/pixelsExample.svg b/other/pixelsExample.svg new file mode 100644 --- /dev/null +++ b/other/pixelsExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/rectChart_Example.svg b/other/rectChart_Example.svg new file mode 100644 --- /dev/null +++ b/other/rectChart_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/rectHudExample.svg b/other/rectHudExample.svg new file mode 100644 --- /dev/null +++ b/other/rectHudExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/rect_Example.svg b/other/rect_Example.svg new file mode 100644 --- /dev/null +++ b/other/rect_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/rectsExample.svg b/other/rectsExample.svg new file mode 100644 --- /dev/null +++ b/other/rectsExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/scatterHistExample.svg b/other/scatterHistExample.svg new file mode 100644 --- /dev/null +++ b/other/scatterHistExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/schoolbookExample.svg b/other/schoolbookExample.svg new file mode 100644 --- /dev/null +++ b/other/schoolbookExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/skinnyExample.svg b/other/skinnyExample.svg new file mode 100644 --- /dev/null +++ b/other/skinnyExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/textChart_Example.svg b/other/textChart_Example.svg new file mode 100644 --- /dev/null +++ b/other/textChart_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/textHudExample.svg b/other/textHudExample.svg new file mode 100644 --- /dev/null +++ b/other/textHudExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/text_Example.svg b/other/text_Example.svg new file mode 100644 --- /dev/null +++ b/other/text_Example.svg @@ -0,0 +1,3 @@ + + diff --git a/other/textsExample.svg b/other/textsExample.svg new file mode 100644 --- /dev/null +++ b/other/textsExample.svg @@ -0,0 +1,3 @@ + + diff --git a/other/withHudExample.svg b/other/withHudExample.svg new file mode 100644 --- /dev/null +++ b/other/withHudExample.svg @@ -0,0 +1,3 @@ + + diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -1,58 +1,88 @@ +```include +other/header.md +``` -[chart-unit](https://tonyday567.github.io/chart-unit) +[chart-unit](https://github.com/tonyday567/chart-unit) === [![Build Status](https://travis-ci.org/tonyday567/chart-unit.svg)](https://travis-ci.org/tonyday567/chart-unit) [![Hackage](https://img.shields.io/hackage/v/chart-unit.svg)](https://hackage.haskell.org/package/chart-unit) [![lts](https://www.stackage.org/package/chart-unit/badge/lts)](http://stackage.org/lts/package/chart-unit) [![nightly](https://www.stackage.org/package/chart-unit/badge/nightly)](http://stackage.org/nightly/package/chart-unit) -[repo](https://github.com/tonyday567/chart-unit) +`chart-unit` is a haskell chart library focusing on a small set of high-quality charts using native haskell. Here's a recent example, chock-a-block fill of titles and legends, since they've just been added: -`chart-unit` is an experimental haskell chart library. +![](other/mainExample.svg) -See https://tonyday567.github.io/chart-unit for an extended description. +Chart Types +=== -chart bling +So far, there are 8 major chart types: + +![](other/textHudExample.svg) + +![](other/glyphHudExample.svg) + +![](other/lglyphHudExample.svg) + +![](other/lineHudExample.svg) + +![](other/glineHudExample.svg) + +![](other/rectHudExample.svg) + +![](other/pixelHudExample.svg) + +![](other/arrowHudExample.svg) + +Gallery === -line chart ---- - +The main chart types and the power of diagrams make it easy to invent new charts. Hrere's some inspiration (all code for these charts is in [examples/sourceExamples.hs](examples/sourceExamples.hs)). -scatter chart +schoolbook --- - -histogram ---- - +![](other/schoolbookExample.svg) -pixel chart +labelled bar --- - +![](other/labelledBarExample.svg) + histogram diff --- - -arrow chart +![](other/histDiffExample.svg) + + +combined scatter histogram --- - -compound +![](other/scatterHistExample.svg) + + +clipping --- - +![](other/clippingExample.svg) + +skinny +--- + +![](other/skinnyExample.svg) + + animation --- - -compile recipe --------- +![](other/animationExample.gif) + +workflow +=== + ~~~ -stack build --test --exec "$(stack path --local-install-root)/bin/chart-unit-examples" --exec "$(stack path --local-bin)/pandoc -f markdown -i examples/examples.md -t html -o index.html --filter pandoc-include --mathjax" --file-watch +stack build --test --exec "$(stack path --local-install-root)/bin/chart-source-examples" --exec "$(stack path --local-bin)/pandoc -f markdown -i readme.md -t html -o index.html --filter pandoc-include --mathjax" --file-watch ~~~ -to do ---- - -- legends, text (titles, etc) +```include +other/footer.md +``` diff --git a/src/Chart.hs b/src/Chart.hs --- a/src/Chart.hs +++ b/src/Chart.hs @@ -1,21 +1,67 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK prune, not-home #-} +-- | native haskell charts +-- +-- > {-# NoImplicitPrelude #-} +-- > {-# OverloadedString #-} +-- > import NumHask.Prelude +-- > import Chart +-- +-- chart-unit is designed to be used in conjunction with the numhask prelude. +-- + module Chart - ( module X + ( module Chart.Core + , module Chart.Arrow + , module Chart.Glyph + , module Chart.Hud + , module Chart.Line + , module Chart.Rect + , module Chart.Text + , module Chart.Lenses + , module NumHask.Pair + , module NumHask.Space + , module NumHask.Range + , module NumHask.Rect + , module Data.Colour + , module Data.Colour.Palette.Harmony + , module Data.Colour.Palette.ColorSet + , Diagram + , triangle + , square + , circle , SVG - , V4(..) - , zipWith4 - , module Diagrams.Prelude + , B + , Renderable + , Path + , V2 + , Default(..) + , Text + , scratch ) where -import Data.List (zipWith4) -import Diagrams.Backend.SVG (SVG) -import Diagrams.Prelude hiding - ((<>), arrow, Color(..), lineColor, scaleX, scaleY, width, zero, unsnoc, uncons, Additive, Loop, Magma, Metric, getLast, getFirst, normalize, inv, First, Last, (&), Strict, unit, from, to, size, distance, (.-.), (-~), (*.), rect, element, aspect, project, intersection) -import Linear (V4(..)) +import Chart.Arrow +import Chart.Core +import Chart.Glyph +import Chart.Hud +import Chart.Lenses +import Chart.Line +import Chart.Rect +import Chart.Text +import Data.Colour +import Data.Colour.Palette.ColorSet +import Data.Colour.Palette.Harmony +import Data.Default (Default(..)) +import Data.Text +import Diagrams.Backend.SVG (SVG, B) +import Diagrams.Prelude +import NumHask.Pair +import NumHask.Range +import NumHask.Rect +import NumHask.Space hiding (width) +import NumHask.Prelude (IO) -import NumHask.Range as X -import NumHask.Rect as X -import NumHask.Histogram as X -import Chart.Types as X -import Chart.Unit as X +-- | a scratch pad +scratch :: Diagram SVG -> IO () +scratch = fileSvg "other/scratchpad.svg" (600, 400) diff --git a/src/Chart/Arrow.hs b/src/Chart/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Arrow.hs @@ -0,0 +1,136 @@ +{-# OPTIONS_GHC -Wall #-} + +-- | Charts that depict gradients and similar, using arrows + +module Chart.Arrow ( + Arrow(..) + , ArrowOptions(..) + , normArrows + , arrows + , arrowChart + , arrowChart_ + ) where + +import Chart.Core + +import NumHask.Prelude hiding (max,(&)) +import NumHask.Space +import NumHask.Range +import NumHask.Rect +import NumHask.Pair + +import Data.Ord (max) +import Diagrams.Prelude hiding (width, D, Color, project) + +data ArrowOptions a = ArrowOptions + { arrowMinLength :: a + , arrowMaxLength :: a + , arrowMinHeadLength :: a + , arrowMaxHeadLength :: a + , arrowMinStaffWidth :: a + , arrowMaxStaffWidth :: a + , arrowColor :: AlphaColour Double + , arrowHeadStyle :: ArrowHT a + } + +instance Default (ArrowOptions Double) where + def = ArrowOptions 0.02 0.2 0.01 0.1 0.002 0.005 ublue dart + +-- | equalize the arrow space width with the data space one. +-- this creates the right arrow sizing in physical chart space +normArrows :: [Arrow] -> [Arrow] +normArrows xs = + zipWith Arrow ps as' + where + -- data points + ps = arrowPos <$> xs + -- arrow vectors + as = arrowDir <$> xs + as' = (\x -> + x * + width (space $ arrowPos <$> xs :: Rect Double) / + width (space $ arrowDir <$> xs :: Rect Double)) <$> + as + +-- | an arrow structure contains position, direction and size information +data Arrow = Arrow + { arrowPos :: Pair Double -- position of arrow tail + , arrowDir :: Pair Double -- direction and strength of arrow + } deriving (Eq, Show) + +-- | arrows rescale data across position, and between position and arrow direction +-- note that, due t0 all this scaling stuff, there is no such thing as a single arrow_ chart +-- +-- > arrows (def {arrowMaxLength=0.5,arrowMaxHeadLength=0.2,arrowMaxStaffWidth=0.01}) [Arrow (Pair x (sin (5*x))) (Pair x (cos x)) | x<-grid MidPos (one::Range Double) 100] +-- +-- ![arrows example](other/arrowsExample.svg) +-- +arrows :: (Traversable f) => ArrowOptions Double -> f Arrow -> Chart b +arrows opts xs = c + where + c = fcA (arrowColor opts) $ position $ getZipList $ + (\ps' as' hrel' wrel' srel' -> + (ps', + arrowAt' (arropts hrel' wrel') (p2 (0, 0)) + ((srel'/norm as') *^ as'))) <$> ZipList + (toList $ p_ <$> ps) <*> ZipList + (toList $ r_ <$> as) <*> ZipList + (toList hrel) <*> ZipList + (toList wrel) <*> ZipList + srel + ps = arrowPos <$> xs + -- arrow vectors + as = arrowDir <$> xs + -- width of the data space + (Pair dx dy) = width (space ps :: Rect Double) + -- norm of arrow vectors relative to the data space metric + anorm = (\(Pair x y) -> sqrt((x/dx)**2+(y/dy)**2)) <$> as + -- the maximum arrow vector norm + (Range _ anormMax) = space anorm + -- the overall size of the arrows, as a proportion to the data space + arel = (\x -> max (anormMax * arrowMinLength opts) + (x / anormMax * arrowMaxLength opts)) <$> anorm + -- size of the head (as a proportion of the data space) + hrel = (\x -> max (arrowMinHeadLength opts) (arrowMaxHeadLength opts * x)) <$> + arel + -- widt of the staff + wrel = (\x -> max (arrowMinStaffWidth opts) (arrowMaxStaffWidth opts * x)) <$> + arel + -- length of the staff (taking into account the head length) + srel = zipWith (\la lh -> max 1e-12 (la - lh)) (toList arel) (toList hrel) + -- diagrams arrow options + arropts lh lw'' = with & arrowHead .~ arrowHeadStyle opts & + headLength .~ global lh & + shaftStyle %~ (lwG lw'' & lcA (arrowColor opts)) & + headStyle %~ (lcA (arrowColor opts) & fcA (arrowColor opts)) + +-- | A chart of arrows +arrowChart :: + (Traversable f) => + [ArrowOptions Double] -> + Aspect -> + Rect Double -> + [f Arrow] -> + Chart b +arrowChart optss (Aspect asp) r xss = + mconcat $ zipWith (\opts xs -> arrows opts $ + (\(Arrow d arr) -> + Arrow (project r asp d) (project r asp arr)) <$> xs) optss xss + +-- | an arrow chart scaled to its own range +-- +-- > let as = normArrows [Arrow (Pair x y) (Pair (sin 1/x+0.0001) (cos 1/y+0.0001)) | x<-grid MidPos (one::Range Double) 20, y<-grid MidPos (one::Range Double) 20] +-- > arrowChart_ [def] asquare [as] +-- +-- ![arrowChart_ example](other/arrowChart_Example.svg) +-- +arrowChart_ :: + (Traversable f) => + [ArrowOptions Double] -> + Aspect -> + [f Arrow] -> + Chart b +arrowChart_ optss asp xss = + arrowChart optss asp r xss + where + r = fold (space . map arrowPos <$> xss) diff --git a/src/Chart/Core.hs b/src/Chart/Core.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Core.hs @@ -0,0 +1,280 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +#if ( __GLASGOW_HASKELL__ < 820 ) +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#endif + +module Chart.Core + ( -- * chart + -- + -- $chart + Chart + , UChart(..) + , combine + -- * scaling + -- + -- $scaling + , range + , projectss + , Aspect(..) + , aspect + , asquare + , sixbyfour + , golden + , widescreen + , skinny + , AlignH(..) + , AlignV(..) + , alignHU + , alignHTU + , alignVU + -- * combinator + -- + -- $combinator + , positioned + , p_ + , r_ + , vert + , hori + , sepVert + , sepHori + -- * IO + -- + -- $io + , fileSvg + -- * color + -- + -- $color + , ucolor + , ublue + , ugrey + , ugreen + , ured + -- * errata + -- + -- $errata + , scaleX + , scaleY + , scale + ) where + +import Data.Colour.Palette.ColorSet +import Diagrams.Backend.SVG (SVG, renderSVG) +import Diagrams.Prelude + hiding (Color, D, aspect, project, scale, scaleX, scaleY, zero) +import qualified Diagrams.Prelude as Diagrams +import NumHask.Pair +import NumHask.Prelude +import NumHask.Rect +import NumHask.Space + +-- $chart +-- +-- base chart type +-- | A Chart is simply a type synonym for a typical Diagrams object. A close relation to this type is 'Diagram' 'B', but this usage tends to force a single backend (B comes from the backend libraries), so this is preferred to maintain backend polymorphism. +-- Just about everything - text, circles, lines, triangles, charts, axes, titles, legends etc - are 'Chart's, which means that most things are amenable to full use of the 'diagrams-lib' library. +type Chart b + = (Renderable (Path V2 Double) b) => + QDiagram b V2 Double Any + +-- | a UChart is mostly a late binding of the Chart Aspect that is to be projected on to and the data. +data UChart a b = UChart + { uchartRenderer :: () => + Aspect -> Rect Double -> a -> Chart b + , uchartRenderRange :: Rect Double + , uchartData :: a + } + +-- | render a list of charts, taking into account each of their ranges +combine :: Aspect -> [UChart a b] -> Chart b +combine asp qcs = mconcat $ (\(UChart c _ x) -> c asp rall x) <$> qcs + where + rall = fold $ (\(UChart _ r1 _) -> r1) <$> qcs + +-- $scaling +-- +-- scaling functionality +projectss :: + (Functor f, Functor g) + => Rect Double + -> Rect Double + -> g (f (Pair Double)) + -> g (f (Pair Double)) +projectss r0 r1 xyss = map (project r0 r1) <$> xyss + +range :: (Foldable f, Foldable g) => g (f (Pair Double)) -> Rect Double +range xyss = foldMap space xyss + +-- | the rendering plane +newtype Aspect = Aspect + { aspectRect :: Rect Double + } + +-- | the rendering aspect of a chart expressed as a ratio of x-plane : y-plane. +aspect :: Double -> Aspect +aspect a = Aspect $ Ranges ((a *) <$> one) one + +-- | 1:1 +asquare :: Aspect +asquare = aspect 1 + +-- | 1.5:1 +sixbyfour :: Aspect +sixbyfour = aspect 1.5 + +-- | golden ratio +golden :: Aspect +golden = aspect 1.61803398875 + +-- | 3:1 +widescreen :: Aspect +widescreen = aspect 3 + +-- | 5:1 +skinny :: Aspect +skinny = aspect 5 + +-- | horizontal alignment +data AlignH + = AlignLeft + | AlignCenter + | AlignRight + +-- | vertical alignment +data AlignV + = AlignTop + | AlignMid + | AlignBottom + +-- | conversion of horizontal alignment to one :: Range Double +alignHU :: AlignH -> Double +alignHU a = + case a of + AlignLeft -> 0.5 + AlignCenter -> 0 + AlignRight -> -0.5 + +-- | svg text is forced to be lower left (-0.5) by default +alignHTU :: AlignH -> Double +alignHTU a = + case a of + AlignLeft -> 0 + AlignCenter -> -0.5 + AlignRight -> -1 + +-- | conversion of vertical alignment to one :: Range Double +alignVU :: AlignV -> Double +alignVU a = + case a of + AlignTop -> -0.5 + AlignMid -> 0 + AlignBottom -> 0.5 + +-- $combinator +-- +-- chart combinators +-- | position an element +positioned :: (R2 r) => r Double -> Chart b -> Chart b +positioned p = moveTo (p_ p) + +-- | convert an R2 to a diagrams Point +p_ :: (R2 r) => r Double -> Point V2 Double +p_ r = curry p2 (r ^. _x) (r ^. _y) + +-- | convert an R2 to a V2 +r_ :: R2 r => r a -> V2 a +r_ r = V2 (r ^. _x) (r ^. _y) + +-- | combine elements vertically, with a premap +vert :: + (V a ~ V2, Foldable t, Juxtaposable a, Semigroup a, Num (N a), Monoid a) + => (a -> a) + -> t a + -> a +vert f xs = foldr (\a x -> beside (r2 (0, -1)) (f a) x) mempty xs + +-- | combine elements horizontally, with a premap +hori :: + (V a ~ V2, Foldable t, Juxtaposable a, Semigroup a, Num (N a), Monoid a) + => (a -> a) + -> t a + -> a +hori f xs = foldr (\a x -> beside (r2 (1, 0)) (f a) x) mempty xs + +-- | horizontal separator +sepHori :: Double -> Chart b -> Chart b +sepHori s x = beside (r2 (0, -1)) x (strutX s) + +-- | vertical separator +sepVert :: Double -> Chart b -> Chart b +sepVert s x = beside (r2 (1, 0)) x (strutY s) + +-- $io +-- +-- | write an svg to file +fileSvg :: FilePath -> (Double, Double) -> Diagram SVG -> IO () +fileSvg f s = renderSVG f (mkSizeSpec (Just <$> r2 s)) + +-- $color +-- +ucolor :: (Floating a, Ord a) => a -> a -> a -> a -> AlphaColour a +ucolor r g b o = withOpacity (sRGB r g b) o + +ublue :: AlphaColour Double +ublue = ucolor 0.365 0.647 0.855 0.5 + +ugreen :: AlphaColour Double +ugreen = rybColor 11 `withOpacity` 0.5 + +ured :: AlphaColour Double +ured = rybColor 0 `withOpacity` 0.5 + +ugrey :: AlphaColour Double +ugrey = ucolor 0.5 0.5 0.5 0.5 + +-- $errata +-- +instance R1 Pair where + _x f (Pair a b) = (`Pair` b) <$> f a + +instance R2 Pair where + _y f (Pair a b) = Pair a <$> f b + _xy f p = fmap (\(V2 a b) -> Pair a b) . f . (\(Pair a b) -> V2 a b) $ p + +-- avoiding the diagrams throw on zero divides +eps :: N [Point V2 Double] +eps = 1e-8 + +scaleX :: + (N t ~ Double, Transformable t, R2 (V t), Diagrams.Additive (V t)) + => Double + -> t + -> t +scaleX s = + Diagrams.scaleX + (if s == zero + then eps + else s) + +scaleY :: + (N t ~ Double, Transformable t, R2 (V t), Diagrams.Additive (V t)) + => Double + -> t + -> t +scaleY s = + Diagrams.scaleY + (if s == zero + then eps + else s) + +scale :: + (N t ~ Double, Transformable t, R2 (V t), Diagrams.Additive (V t)) + => Double + -> t + -> t +scale s = + Diagrams.scale + (if s == zero + then eps + else s) diff --git a/src/Chart/Glyph.hs b/src/Chart/Glyph.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Glyph.hs @@ -0,0 +1,141 @@ +{-# OPTIONS_GHC -Wall #-} + +module Chart.Glyph + ( GlyphOptions(..) + , hline_ + , vline_ + , glyph_ + , glyphs + , lglyphs + , glyphChart + , glyphChart_ + , lglyphChart + , lglyphChart_ + ) where + +import Chart.Core +import Chart.Text +import Diagrams.Prelude hiding (Color, D, scaleX, scaleY) +import NumHask.Pair +import NumHask.Prelude hiding (shape) +import NumHask.Rect + +-- | The actual shape of a glyph can be any Chart element +data GlyphOptions b = GlyphOptions + { glyphSize :: Double -- ^ glyph radius + , glyphColor :: AlphaColour Double + , glyphBorderColor :: AlphaColour Double + , glyphBorderSize :: Double -- ^ normalized + , glyphShape :: Double -> Chart b + } + +instance Default (GlyphOptions b) where + def = GlyphOptions 0.03 ublue ugrey 0.015 circle + +-- | vertical line glyph shape +vline_ :: Double -> Double -> Chart b +vline_ fatness x = vrule x # scaleX (1.6 / 0.5 * fatness) + +-- | horizontal line glyph shape +hline_ :: Double -> Double -> Chart b +hline_ fatness x = hrule x # scaleY (1.6 / 0.5 * fatness) + +-- | create a glyph from a configuration +-- +-- > let glyph_Example = glyph_ def +-- +-- ![glyph_ example](other/glyph_Example.svg) +-- +glyph_ :: GlyphOptions b -> Chart b +glyph_ (GlyphOptions s c bc bs shape) = shape s # fcA c # lcA bc # lwN bs + +-- | positioned glyphs +-- +-- > let ps = [Pair (x/10) ((sin x)/10) | x<-[0..10]] +-- > glyphs def ps +-- +-- ![glyphs example](other/glyphsExample.svg) +-- +glyphs :: (R2 r, Traversable f) => GlyphOptions b -> f (r Double) -> Chart b +glyphs opts xs = mconcat $ toList $ (\x -> positioned x (glyph_ opts)) <$> xs + +-- | a chart of glyphs +glyphChart :: + (Traversable f) + => [GlyphOptions b] + -> Aspect + -> Rect Double + -> [f (Pair Double)] + -> Chart b +glyphChart optss (Aspect asp) r xyss = + mconcat $ zipWith glyphs optss (projectss r asp xyss) + +-- | a chart of glyphs scaled to its own range +-- +-- > let gopts = [def,def {glyphBorderColor=withOpacity red 0.2, glyphShape=triangle}] +-- > let p_1 = [Pair x (sin (x/10)) | x<-[0..100]] +-- > let p_2 = [Pair x (cos (x/10)) | x<-[0..100]] +-- > glyphChart_ gopts widescreen [p_1,p_2] +-- +-- ![glyphChart_ example](other/glyphChart_Example.svg) +-- +glyphChart_ :: + (Traversable f) + => [GlyphOptions b] + -> Aspect + -> [f (Pair Double)] + -> Chart b +glyphChart_ optss asp xyss = glyphChart optss asp (range xyss) xyss + +-- | labelled, positioned glyphs +-- +-- > lglyphs def def $ zip (show <$> [0..]) ps +-- +-- ![lglyphs example](other/lglyphsExample.svg) +-- +lglyphs :: + (R2 r, Traversable f) + => LabelOptions + -> GlyphOptions b + -> f (Text, r Double) + -> Chart b +lglyphs lopts gopts xs = + mconcat $ + toList $ (\(t, x) -> moveTo (p_ x) $ labelled lopts t (glyph_ gopts)) <$> xs + +-- | a chart of labelled glyphs +lglyphChart :: + (Traversable f) + => [LabelOptions] + -> [GlyphOptions b] + -> Aspect + -> Rect Double + -> [f (Text, Pair Double)] + -> Chart b +lglyphChart ls gs (Aspect asp) r xyss = + mconcat $ + getZipList $ + lglyphs <$> ZipList ls <*> ZipList gs <*> + ZipList + (zipWith + zip + (map fst . toList <$> xyss) + (projectss r asp (map snd . toList <$> xyss))) + +-- | a chart of labelled glyphs scaled to its own range +-- +-- > let g = Pair <$> [0..5] <*> [0..5] :: [Pair Int] +-- > let xs = [(\(p@(Pair x y)) -> ((show x <> "," <> show y), fromIntegral <$> p)) <$> g] +-- > lglyphChart_ [def {labelGap=0.01}] [def] sixbyfour xs +-- +-- ![lglyphChart_ example](other/lglyphChart_Example.svg) +-- +lglyphChart_ :: + (Traversable f) + => [LabelOptions] + -> [GlyphOptions b] + -> Aspect + -> [f (Text, Pair Double)] + -> Chart b +lglyphChart_ ls gs asp xyss = + lglyphChart ls gs asp (range (map snd . toList <$> xyss)) xyss diff --git a/src/Chart/Hud.hs b/src/Chart/Hud.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Hud.hs @@ -0,0 +1,448 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} +#if ( __GLASGOW_HASKELL__ < 820 ) +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#endif + +-- | collective noun for axes, titles & legends +module Chart.Hud + ( HudOptions(..) + , withHud + , hud + , Orientation(..) + , Place(..) + , placeOutside + , placeGap + , TickStyle(..) + , precision + , AxisOptions(..) + , defXAxis + , defYAxis + , axis + , TitleOptions(..) + , title + , LegendType(..) + , LegendOptions(..) + , legend + ) where + +import Chart.Arrow +import Chart.Core +import Chart.Glyph +import Chart.Line +import Chart.Rect +import Chart.Text +import qualified Control.Foldl as L +import Data.List (nub) +import Data.Ord (max) +import Diagrams.Prelude + hiding (Color, D, (*.), (<>), project, width, zero) +import qualified Diagrams.TwoD.Size as D +import Formatting +import NumHask.Pair +import NumHask.Prelude hiding (max) +import NumHask.Range +import NumHask.Rect +import NumHask.Space + +-- | various options for a hud +-- Defaults to an x- and y-axis, sixbyfour aspect, no titles and no legends +data HudOptions b = HudOptions + { hudPad :: Double + , hudAxes :: [AxisOptions b] + , hudTitles :: [(TitleOptions, Text)] + , hudLegends :: [LegendOptions b] + , hudRange :: Maybe (Rect Double) + , hudAspect :: Aspect + , hudCanvas :: RectOptions + } + +instance Default (HudOptions b) where + def = HudOptions 1.1 [defXAxis, defYAxis] [] [] Nothing sixbyfour clear + +-- | create a hud based upon HudOptions +-- +-- > hud def +-- +-- ![hud example](other/hudExample.svg) +-- +hud :: () => HudOptions b -> Chart b +hud (HudOptions p axes titles legends mr asp@(Aspect ar@(Ranges ax ay)) can) = + L.fold (L.Fold addTitle uptoLegend (pad p)) titles + where + addTitle x (topts, t) = + beside (placeOutside (titlePlace topts)) x (title asp topts t) + addLegend x lopts = + beside (placeOutside (legendPlace lopts)) x $ + if 0 == length (legendChartType lopts) + then mempty + else (\x' -> + moveTo (p_ $ pos' (legendAlign lopts) (legendPlace lopts) x') x') $ + legend lopts + pos' AlignCenter _ _ = Pair 0 0 + pos' AlignLeft PlaceTop x = Pair (lower ax - 0.5 * D.width x) 0 + pos' AlignLeft PlaceBottom x = Pair (lower ax - 0.5 * D.width x) 0 + pos' AlignLeft PlaceLeft x = Pair 0 (lower ay - 0.5 * D.height x) + pos' AlignLeft PlaceRight x = Pair 0 (upper ay - 0.5 * D.height x) + pos' AlignRight PlaceTop x = Pair (upper ax + 0.5 * D.width x) 0 + pos' AlignRight PlaceBottom x = Pair (upper ax + 0.5 * D.width x) 0 + pos' AlignRight PlaceLeft x = Pair 0 (upper ay + 0.5 * D.height x) + pos' AlignRight PlaceRight x = Pair 0 (lower ay + 0.5 * D.height x) + uptoLegend = L.fold (L.Fold addLegend uptoAxes identity) legends + uptoAxes = L.fold (L.Fold addAxis canvas identity) axes + canvas = rect_ can ar + addAxis x aopts = + case axisOrientation aopts of + Hori -> beside (placeOutside (axisPlace aopts)) x (axis aopts ax rx) + Vert -> beside (placeOutside (axisPlace aopts)) x (axis aopts ay ry) + where + (Ranges rx ry) = fromMaybe one mr + +-- | create a chart with a hud from data (using the data range) +-- +-- > withHudExample :: Chart b +-- > withHudExample = withHud hopts (lineChart lopts) ls +-- > where +-- > hopts = def {hudTitles=[(def,"withHud Example")], +-- > hudLegends=[def {legendChartType=zipWith (\x y -> (LegendLine x 0.05, y)) lopts ["line1", "line2", "line3"]}]} +-- +-- ![withHud example](other/withHudExample.svg) +-- +withHud :: + (Foldable f) + => HudOptions b + -> (Aspect -> Rect Double -> [f (Pair Double)] -> Chart b) + -> [f (Pair Double)] + -> Chart b +withHud opts renderer d = + case hudRange opts of + Nothing -> + renderer (hudAspect opts) (foldMap space d) d <> + hud (opts {hudRange = Just (foldMap space d)}) + Just r -> + combine + (hudAspect opts) + [ UChart renderer r d + , UChart + (\asp _ _ -> hud (opts {hudAspect = asp, hudRange = Just r})) + r + [] + ] + +-- | placement of hud elements around (what is implicity but maybe shouldn't just be) a rectangular canvas +data Place + = PlaceLeft + | PlaceRight + | PlaceTop + | PlaceBottom + deriving (Eq, Show) + +-- | direction to place stuff on the outside of the built-up chart +placeOutside :: Num n => Place -> V2 n +placeOutside pl = + case pl of + PlaceBottom -> r2 (0, -1) + PlaceTop -> r2 (0, 1) + PlaceLeft -> r2 (-1, 0) + PlaceRight -> r2 (1, 0) + +-- | a strut to add to a placement +placeGap :: + (Monoid m, Semigroup m, Ord n, Floating n) + => Place + -> n + -> QDiagram b V2 n m + -> QDiagram b V2 n m +placeGap pl s x = beside (placeOutside pl) (strut' pl s) x + where + strut' PlaceTop = strutY + strut' PlaceBottom = strutY + strut' PlaceLeft = strutX + strut' PlaceRight = strutX + +-- | orientation for a hud element. Watch this space for curvature! +data Orientation + = Hori + | Vert + +-- | axes are somewhat complicated. For instance, they contain a range within which tick marks need to be supplied or computed. +data AxisOptions b = AxisOptions + { axisPad :: Double + , axisOrientation :: Orientation + , axisPlace :: Place + , axisRect :: RectOptions + , axisRectHeight :: Double + , axisMark :: GlyphOptions b + , axisMarkStart :: Double + , axisGap :: Double -- distance of axis from plane + , axisLabel :: LabelOptions + , axisTickStyle :: TickStyle + } + +-- | default X axis +defXAxis :: AxisOptions b +defXAxis = + AxisOptions + 1 + Hori + PlaceBottom + (RectOptions 0 transparent (withOpacity black 0.1)) + 0.02 + (GlyphOptions 0.03 transparent (withOpacity black 0.6) 0.005 (vline_ 1)) + 0 + 0.04 + (LabelOptions + (TextOptions 0.08 AlignCenter (withOpacity black 0.6) EvenOdd 0) + (Pair 0 -1) + 0.015) + (TickRound 8) + +-- | default Y axis +defYAxis :: AxisOptions b +defYAxis = + AxisOptions + 1 + Vert + PlaceLeft + (RectOptions 0 transparent (withOpacity black 0.1)) + 0.02 + (GlyphOptions 0.03 transparent (withOpacity black 0.6) 0.005 (hline_ 1)) + 0 + 0.04 + (LabelOptions + (TextOptions 0.08 AlignCenter (withOpacity black 0.6) EvenOdd 0) + (Pair -1 0) + 0.015) + (TickRound 8) + +instance Default (AxisOptions b) where + def = defXAxis + +-- | create an axis, based on AxisOptions, a physical aspect, and a range +-- +-- Under-the-hood, the axis function has gone through many a re-factor, and still has a ways to go. A high degree of technical debt tends to acrue here. +-- +-- > axisExample :: Chart b +-- > axisExample = axis aopts one (Range 0 100000) +-- > where +-- > aopts = def {axisLabel=(axisLabel def) {labelGap=0.0001,labelText=(labelText (axisLabel def)) {textSize=0.06,textAlignH=AlignLeft,textRotation=(-45)}}} +-- +-- ![axis example](other/axisExample.svg) +-- +axis :: () => AxisOptions b -> Range Double -> Range Double -> Chart b +axis opts asp r = + mo $ + pad (axisPad opts) $ + astrut $ + centerXY $ + atPoints + (pl <$> tickLocations) + ((\x -> labelled (axisLabel opts) x (glyph_ (axisMark opts))) <$> tickLabels) `atop` + arect (axisOrientation opts) + where + mo = moveOriginTo (p2 ((-lower asp) - width asp / 2, 0)) + arect Hori = + rect_ (axisRect opts) (Ranges asp (Range 0 (axisRectHeight opts))) + arect Vert = + rect_ (axisRect opts) (Ranges (Range 0 (axisRectHeight opts)) asp) + astrut = + beside (placeOutside (axisPlace opts)) + (case axisOrientation opts of + Hori -> strutY (axisGap opts) + Vert -> strutX (axisGap opts)) + pl = + let gs = glyphSize (axisMark opts) + in case axisPlace opts of + PlaceBottom -> + \x -> + p2 (x, (-0.5 * gs) + axisRectHeight opts + axisMarkStart opts) + PlaceLeft -> + \y -> + p2 ((-0.5 * gs) + axisRectHeight opts + axisMarkStart opts, y) + PlaceTop -> \x -> p2 (x, (0.5 * gs) + axisMarkStart opts) + PlaceRight -> \y -> p2 ((0.5 * gs) + axisMarkStart opts, y) + (tickLocations, tickLabels) = + case axisTickStyle opts of + TickNone -> ([], []) + {- To Do: + rounded ticks introduce the possibility of marks beyond the existing range. + if this happens, it should really be fed into the chart rendering as a new, + revised range. + -} + TickRound n -> (project r asp <$> ticks0, precision 0 ticks0) + where ticks0 = gridSensible OuterPos r n + TickExact n -> (project r asp <$> ticks0, precision 3 ticks0) + where ticks0 = grid OuterPos r n + TickLabels ls -> + ( project (Range 0 (fromIntegral $ length ls)) asp <$> + ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) + , ls) + TickPlaced xs -> (project r asp . fst <$> xs, snd <$> xs) + +-- | style of tick marks on an axis +data TickStyle + = TickNone -- ^ no ticks on axis + | TickLabels [Text] -- ^ specific labels + | TickRound Int -- ^ sensibly rounded ticks and a guide to how many + | TickExact Int -- ^ exactly n equally spaced ticks + | TickPlaced [(Double, Text)] -- ^ specific labels and placement + +-- | provide a formatted text from a list of numbers so that they are just distinguished. 'precision 2 ticks' means give the tick labels as much precision as is needed for them to be distinguished, but with at least 2 significant figues. +precision :: Int -> [Double] -> [Text] +precision n0 xs + | foldr max 0 xs < 0.01 = precLoop Formatting.expt n0 xs + | foldr max 0 xs > 100000 = precLoop Formatting.expt n0 xs + | foldr max 0 xs > 1000 = + precLoopInt (const Formatting.commas) n0 (floor <$> xs) + | otherwise = precLoop fixed n0 xs + where + precLoop f n xs' = + let s = sformat (f n) <$> xs' + in if s == nub s + then s + else precLoop f (n + 1) xs' + precLoopInt f n xs' = + let s = sformat (f n) <$> xs' + in if s == nub s + then s + else precLoopInt f (n + 1) xs' + +-- | options for titles. Defaults to center aligned, and placed at Top of the hud +data TitleOptions = TitleOptions + { titleText :: TextOptions + , titleAlign :: AlignH + , titlePlace :: Place + , titleGap :: Double + } + +instance Default TitleOptions where + def = + TitleOptions + (TextOptions 0.12 AlignCenter (withOpacity black 0.6) EvenOdd 0) + AlignCenter + PlaceTop + 0.04 + +-- | Create a title for a chart. The logic used to work out placement is flawed due to being able to freely specify text rotation. It works for specific rotations (Top, Bottom at 0, Left at 90, Right @ 270) +title :: Aspect -> TitleOptions -> Text -> Chart b +title (Aspect (Ranges aspx aspy)) (TitleOptions textopts a p s) t = + placeGap p s (positioned (pos a p) (text_ (textopts {textAlignH = a}) t)) + where + pos AlignCenter _ = Pair 0 0 + pos AlignLeft PlaceTop = Pair (lower aspx) 0 + pos AlignLeft PlaceBottom = Pair (lower aspx) 0 + pos AlignLeft PlaceLeft = Pair 0 (lower aspy) + pos AlignLeft PlaceRight = Pair 0 (upper aspy) + pos AlignRight PlaceTop = Pair (upper aspx) 0 + pos AlignRight PlaceBottom = Pair (upper aspx) 0 + pos AlignRight PlaceLeft = Pair 0 (upper aspy) + pos AlignRight PlaceRight = Pair 0 (lower aspy) + +-- | the LegendType reuses all the various chart option types to help formulate a legend +data LegendType b + = LegendText TextOptions + | LegendGlyph (GlyphOptions b) + | LegendLine LineOptions + Double + | LegendGLine (GlyphOptions b) + LineOptions + Double + | LegendRect RectOptions + Double + | LegendArrow (ArrowOptions Double) + Double + | LegendPixel RectOptions + Double + +-- | legend options. The main missing piece here is to allow for horizontal concatenation. +data LegendOptions b = LegendOptions + { legendChartType :: [(LegendType b, Text)] + , legendInnerPad :: Double + , legendInnerSep :: Double + , legendGap :: Double + , legendRowPad :: Double + , legendPlace :: Place + , legendAlign :: AlignH + , legendSep :: Double + , legendRect :: RectOptions + , legendText :: TextOptions + } + +instance Default (LegendOptions b) where + def = + LegendOptions + [] + 1.1 + 0.03 + 0.05 + 1 + PlaceRight + AlignRight + 0.02 + (RectOptions 0.002 (withOpacity black 0.2) transparent) + (TextOptions 0.07 AlignCenter (withOpacity black 0.63) EvenOdd 0) + +-- | Create a legend based on a LegendOptions +-- +-- > legendExample :: Chart b +-- > legendExample = legend $ def {legendChartType=legends} +-- > where +-- > legends = +-- > [ (LegendText def, "legend")] <> +-- > [ (LegendPixel (blob (withOpacity blue 0.4)) 0.05, "pixel")] <> +-- > -- [ (LegendArrow (def {arrowMinStaffWidth=0.01, +-- > -- arrowMinHeadLength=0.03}) 0.05, "arrow")] <> +-- > [ (LegendRect def 0.05, "rect")] <> +-- > [ (LegendGLine def def 0.10, "glyph+line")] <> +-- > [ (LegendGlyph def, "just a glyph")] <> +-- > (zipWith (\x y -> (LegendLine x 0.05, y)) +-- > lopts ["short", "much longer name", "line 3"]) +-- +-- +-- ![legend example](other/legendExample.svg) +-- +legend :: LegendOptions b -> Chart b +legend opts = + placeGap (legendPlace opts) (legendGap opts) $ + bound (legendRect opts) 1 $ + pad (legendInnerPad opts) $ + centerXY $ + vert + (pad (legendRowPad opts)) + (intersperse (strutY (legendInnerSep opts)) $ + legend__ <$> legendChartType opts) + where + legend__ (LegendText c, t) = text_ c t + legend__ (LegendGlyph c, t) = + hori + identity + [glyph_ c, strutX (legendSep opts), text_ (legendText opts) t] + legend__ (LegendLine c l, t) = + hori + identity + [ oneline c (Pair (Pair 0 0) (Pair l 0)) + , strutX (legendSep opts) + , text_ (legendText opts) t + ] + legend__ (LegendGLine gc lopts l, t) = + hori + identity + [ glyph_ gc `atop` oneline lopts (Pair (Pair (-l) 0) (Pair l 0)) + , strutX (legendSep opts) + , text_ (legendText opts) t + ] + legend__ (LegendRect c s, t) = + hori + identity + [rect_ c (s *. one), strutX (legendSep opts), text_ (legendText opts) t] + legend__ (LegendArrow c s, t) = + hori + identity + [ arrows c [Arrow zero (s *. one), Arrow (s *. one) zero] + , strutX (legendSep opts) + , text_ (legendText opts) t + ] + legend__ (LegendPixel c s, t) = + hori + identity + [rect_ c (s *. one), strutX (legendSep opts), text_ (legendText opts) t] diff --git a/src/Chart/Lenses.hs b/src/Chart/Lenses.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Lenses.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Lenses for all the options. Note the trailing underscore naming convention, rather than the more obnoxious _prefixed conventions. +module Chart.Lenses + -- * tea anyone? + ( arrowMinLength_ + , arrowMaxLength_ + , arrowMinHeadLength_ + , arrowMaxHeadLength_ + , arrowMinStaffWidth_ + , arrowMaxStaffWidth_ + , arrowColor_ + , arrowHeadStyle_ + , glyphSize_ + , glyphColor_ + , glyphBorderColor_ + , glyphBorderSize_ + -- , glyphShape_ + , hudPad_ + , hudAxes_ + , hudTitles_ + , hudLegends_ + , hudRange_ + , hudAspect_ + , hudCanvas_ + , axisPad_ + , axisOrientation_ + , axisPlace_ + , axisRect_ + , axisRectHeight_ + , axisMark_ + , axisMarkStart_ + , axisGap_ + , axisLabel_ + , axisTickStyle_ + , titleText_ + , titleAlign_ + , titlePlace_ + , titleGap_ + , legendChartType_ + , legendInnerPad_ + , legendInnerSep_ + , legendGap_ + , legendRowPad_ + , legendPlace_ + , legendAlign_ + , legendSep_ + , legendRect_ + , legendText_ + , lineSize_ + , lineColor_ + , rectBorderSize_ + , rectBorderColor_ + , rectColor_ + , textSize_ + , textAlignH_ + , textColor_ + , textFillRule_ + , textRotation_ + , labelText_ + , labelOrientation_ + , labelGap_ + ) where + +import Chart.Arrow +import Chart.Glyph +import Chart.Hud +import Chart.Line +import Chart.Rect +import Chart.Text +import Control.Lens + +makeLensesFor + [ ("arrowMinLength", "arrowMinLength_") + , ("arrowMaxLength", "arrowMaxLength_") + , ("arrowMinHeadLength", "arrowMinHeadLength_") + , ("arrowMaxHeadLength", "arrowMaxHeadLength_") + , ("arrowMinStaffWidth", "arrowMinStaffWidth_") + , ("arrowMaxStaffWidth", "arrowMaxStaffWidth_") + , ("arrowColor", "arrowColor_") + , ("arrowHeadStyle", "arrowHeadStyle_") + ] + ''ArrowOptions + +makeLensesFor + [ ("glyphSize", "glyphSize_") + , ("glyphColor", "glyphColor_") + , ("glyphBorderColor", "glyphBorderColor_") + , ("glyphBorderSize", "glyphBorderSize_") + -- GHC doesn't yet support impredicative polymorphism + -- In the type signature: + -- glyphShape_ :: forall b_agHOV b_agNLd. + -- Lens (GlyphOptions b_agHOV) (GlyphOptions b_agNLd) (ghc-prim-0.5.0.0:GHC.Types.Double -> Chart.Core.Chart b_agHOV) (ghc-prim-0.5.0.0:GHC.Types.Double -> Chart.Core.Chart b_agNLd) + -- , ("glyphShape", "glyphShape_") + ] + ''GlyphOptions + +makeLensesFor + [ ("hudPad", "hudPad_") + , ("hudAxes", "hudAxes_") + , ("hudTitles", "hudTitles_") + , ("hudLegends", "hudLegends_") + , ("hudRange", "hudRange_") + , ("hudAspect", "hudAspect_") + , ("hudCanvas", "hudCanvas_") + ] + ''HudOptions + +makeLensesFor + [ ("axisPad", "axisPad_") + , ("axisOrientation", "axisOrientation_") + , ("axisPlace", "axisPlace_") + , ("axisRect", "axisRect_") + , ("axisRectHeight", "axisRectHeight_") + , ("axisMark", "axisMark_") + , ("axisMarkStart", "axisMarkStart_") + , ("axisGap", "axisGap_") + , ("axisLabel", "axisLabel_") + , ("axisTickStyle", "axisTickStyle_") + ] + ''AxisOptions + +makeLensesFor + [ ("titleText", "titleText_") + , ("titleAlign", "titleAlign_") + , ("titlePlace", "titlePlace_") + , ("titleGap", "titleGap_") + ] + ''TitleOptions + +makeLensesFor + [ ("legendChartType", "legendChartType_") + , ("legendInnerPad", "legendInnerPad_") + , ("legendInnerSep", "legendInnerSep_") + , ("legendGap", "legendGap_") + , ("legendRowPad", "legendRowPad_") + , ("legendPlace", "legendPlace_") + , ("legendAlign", "legendAlign_") + , ("legendSep", "legendSep_") + , ("legendRect", "legendRect_") + , ("legendText", "legendText_") + ] + ''LegendOptions + +makeLensesFor + [("lineSize", "lineSize_"), ("lineColor", "lineColor_")] + ''LineOptions + +makeLensesFor + [ ("rectBorderSize", "rectBorderSize_") + , ("rectBorderColor", "rectBorderColor_") + , ("rectColor", "rectColor_") + ] + ''RectOptions + +makeLensesFor + [ ("textSize", "textSize_") + , ("textAlignH", "textAlignH_") + , ("textColor", "textColor_") + , ("textFillRule", "textFillRule_") + , ("textRotation", "textRotation_") + ] + ''TextOptions + +makeLensesFor + [ ("labelText", "labelText_") + , ("labelOrientation", "labelOrientation_") + , ("labelGap", "labelGap_") + ] + ''LabelOptions diff --git a/src/Chart/Line.hs b/src/Chart/Line.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Line.hs @@ -0,0 +1,125 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} +#if ( __GLASGOW_HASKELL__ < 820 ) +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#endif + +module Chart.Line + ( -- * line + -- + -- $line + LineOptions(..) + , oneline + , lines + , glines + , lineChart + , lineChart_ + , glineChart + , glineChart_ + ) where + +import Chart.Core +import Chart.Glyph +import Data.Default (Default(..)) +import Diagrams.Prelude hiding ((<>)) +import NumHask.Pair +import NumHask.Prelude +import NumHask.Rect + +-- $line +-- +-- line chart elements +-- The main features of a line (that distinguish it from a glyph say) is that: +-- - it exists over multiple points (a line can't exist at a single point) +-- - line rendering is normalized to the eventual physical chart +-- +data LineOptions = LineOptions + { lineSize :: Double -- ^ normalized + , lineColor :: AlphaColour Double + } + +instance Default LineOptions where + def = LineOptions 0.02 ublue + +-- | a line connecting a series of points +-- +-- > lines def [Pair (10*x/100.0) (cos (x * (10 / 100.0))) | x <- fromIntegral <$> [0..n]] +-- +-- ![lines example](other/linesExample.svg) +-- +lines :: (Traversable f, R2 r) => LineOptions -> f (r Double) -> Chart b +lines (LineOptions s c) xs = + case NumHask.Prelude.head xs of + Nothing -> mempty + Just p -> + trailLike (trailFromVertices (toList $ p_ <$> xs) `at` p_ p) # lcA c # + lwN s + +-- a single line connecting 2 points +oneline :: (R2 r) => LineOptions -> Pair (r Double) -> Chart b +oneline (LineOptions s c) (Pair x0 x1) = + stroke (trailFromVertices [p_ x0, p_ x1] `at` p_ x0) # lcA c # lwN s + +-- | a chart of lines +lineChart :: + (Traversable f) + => [LineOptions] + -> Aspect + -> Rect Double + -> [f (Pair Double)] + -> Chart b +lineChart optss (Aspect asp) r xyss = + mconcat $ zipWith lines optss (projectss r asp xyss) + +-- | a chart of lines scaled to its own range +-- +-- > import Data.Colour.Palette.Harmony (tetrad) +-- > ls = map (uncurry Pair) <$> [[(0.0,1.0),(1.0,1.0),(2.0,5.0)], [(0.0,0.0),(3.0,3.0)], [(0.5,4.0),(0.5,0)]] +-- > lopts = zipWith (\x y -> LineOptions x (withOpacity y 0.6)) [0.01,0.02,0.005] (tetrad blue) +-- > lineChart_ lopts sixbyfour ls +-- +-- ![lineChart_ example](other/lineChart_Example.svg) +-- +lineChart_ :: + (Traversable f) => [LineOptions] -> Aspect -> [f (Pair Double)] -> Chart b +lineChart_ optss asp xyss = lineChart optss asp (range xyss) xyss + +-- | lines with glyphs atop +glines :: + (Traversable f, R2 r) + => LineOptions + -> GlyphOptions b + -> f (r Double) + -> Chart b +glines opts gopts xs = glyphs gopts xs <> lines opts xs + +-- | a chart of glines +glineChart :: + (Traversable f) + => [LineOptions] + -> [GlyphOptions b] + -> Aspect + -> Rect Double + -> [f (Pair Double)] + -> Chart b +glineChart ls gs (Aspect asp) r xyss = + mconcat $ + getZipList $ + glines <$> ZipList ls <*> ZipList gs <*> ZipList (projectss r asp xyss) + +-- | a chart of glyphs_lines scaled to its own range +-- +-- > let gopts = zipWith (\x y -> def {glyphColor=transparent, glyphBorderColor=withOpacity x 0.6, glyphShape=y}) (tetrad green) [triangle, square, circle] +-- > +-- > glineChart_ lopts gopts sixbyfour ls +-- +-- ![lineChart_ example](other/glineChart_Example.svg) +-- +glineChart_ :: + (Traversable f) + => [LineOptions] + -> [GlyphOptions b] + -> Aspect + -> [f (Pair Double)] + -> Chart b +glineChart_ ls gs asp xyss = glineChart ls gs asp (range xyss) xyss diff --git a/src/Chart/Rect.hs b/src/Chart/Rect.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Rect.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} +#if ( __GLASGOW_HASKELL__ < 820 ) +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#endif +-- | rectangular chart elements +module Chart.Rect + ( RectOptions(..) + , blob + , box + , clear + , bound + , rect_ + , rects + , rectChart + , rectChart_ + , Pixel(..) + , pixel_ + , pixels + , pixelChart + , pixelChart_ + , PixelationOptions(..) + , pixelate + , pixelateChart + ) where + +import Chart.Core +import Diagrams.Prelude hiding (Color, D, scaleX, scaleY) +import NumHask.Pair +import NumHask.Prelude +import NumHask.Range +import NumHask.Rect +import NumHask.Space + +data RectOptions = RectOptions + { rectBorderSize :: Double + , rectBorderColor :: AlphaColour Double + , rectColor :: AlphaColour Double + } + +instance Default RectOptions where + def = RectOptions 0.005 (ucolor 0.4 0.4 0.4 1) ublue + +-- | solid rect, no border +blob :: AlphaColour Double -> RectOptions +blob c = RectOptions 0 transparent c + +-- | clear and transparent rect +clear :: RectOptions +clear = RectOptions 0 transparent transparent + +-- | clear rect, with border +box :: AlphaColour Double -> RectOptions +box c = RectOptions 0.015 c transparent + +-- | place a rect around an Chart +bound :: RectOptions -> Double -> Chart b -> Chart b +bound (RectOptions bs bc c) p x = + (boundingRect x' # lcA bc # lwN bs # fcA c) <> x' + where + x' = pad p x + +-- | a single rectangle specified using a Rect x z y w where +-- (x,y) is location of lower left corner +-- (z,w) is location of upper right corner +-- +-- > let opts o = def {labelText = (labelText def) {textColor=withOpacity black 0.8, textSize = 0.3}, labelOrientation=o} +-- > labelled (opts (Pair 2 1)) ("z,w") $ labelled (opts (Pair -2 -1)) ("x,y") (rect_ def (Ranges (2*.one) one)) +-- +-- ![rect_ example](other/rect_Example.svg) +-- +rect_ :: + ( N b ~ Double + , V b ~ V2 + , Transformable b + , HasOrigin b + , TrailLike b + , HasStyle b + ) + => RectOptions + -> Rect Double + -> b +rect_ (RectOptions bs bc c) (Rect x z y w) = + unitSquare # moveTo (p2 (0.5, 0.5)) # scaleX (z - x) # scaleY (w - y) # + moveTo (p2 (x, y)) # + fcA c # + lcA bc # + lwN bs + +-- | rectangles with the same configuration +-- +-- > rects def $ zipWith (\x y -> Rect x (x+1) 0 y) [0..] [1,2,3,5,8,0,-2,11,2,1] +-- +-- ![rects example](other/rectsExample.svg) +-- +rects :: + ( V a ~ V2 + , N a ~ Double + , Functor t + , HasStyle a + , TrailLike a + , HasOrigin a + , Transformable a + , Foldable t + , Monoid a + ) + => RectOptions + -> t (Rect Double) + -> a +rects opts xs = mconcat $ toList $ rect_ opts <$> xs + +-- | a chart of rects +rectChart :: + (Traversable f) + => [RectOptions] + -> Aspect + -> Rect Double + -> [f (Rect Double)] + -> Chart b +rectChart optss (Aspect asp) r rs = + mconcat . zipWith rects optss $ fmap (projectRect r asp) <$> rs + +-- | a chart of histograms scaled to its own range +-- +-- > let ropts = [def {rectBorderSize=0}, def {rectBorderSize=0,rectColor=ucolor 0.3 0.3 0.3 0.2}] +-- > let pss = transpose [[exp (-(x**2)/2), 0.5 * exp (-(x**2)/8)] | x <- grid LowerPos (Range -5 5) 1000] +-- > let rss = (zipWith (\x y -> Rect x (x+1) 0 y) [0..]) <$> pss +-- > rectChart_ ropts widescreen rss +-- +-- ![rectChart_ example](other/rectChart_Example.svg) +-- +rectChart_ :: + (Traversable f) => [RectOptions] -> Aspect -> [f (Rect Double)] -> Chart b +rectChart_ optss asp rs = rectChart optss asp (fold $ fold <$> rs) rs + +-- | at some point, a color of a rect becomes more about data than stylistic option, hence the pixel. Echewing rect border leaves a Pixel with no stylistic options to choose. +data Pixel = Pixel + { pixelRect :: Rect Double + , pixelColor :: AlphaColour Double + } + +-- | a pixel is a rectangle with a color. +-- +-- > let opt = def {textColor=withOpacity black 0.8, textSize = 0.2} +-- > text_ opt "I'm a pixel!" <> pixel_ (Pixel one ublue) +-- +-- ![pixel_ example](other/pixel_Example.svg) +-- +pixel_ :: Pixel -> Chart b +pixel_ (Pixel (Rect x z y w) c) = + unitSquare # moveTo (p2 (0.5, 0.5)) # scaleX (z - x) # scaleY (w - y) # + moveTo (p2 (x, y)) # + fcA c # + lcA transparent # + lw 0 + +-- | render multiple pixels +-- +-- > pixels $ [Pixel (Rect (5*x) (5*x+0.1) (sin (10*x)) (sin (10*x) + 0.1)) (dissolve (2*x) ublue) | x <- grid OuterPos (Range 0 1) 100] +-- +-- ![pixels example](other/pixelsExample.svg) +-- +pixels :: (Traversable f) => f Pixel -> Chart b +pixels ps = mconcat $ toList $ pixel_ <$> ps + +-- | a chart of pixels +pixelChart :: (Traversable f) => Aspect -> Rect Double -> [f Pixel] -> Chart b +pixelChart (Aspect asp) r pss = + mconcat $ pixels . projectPixels r asp . toList <$> pss + where + projectPixels r0 r1 ps = + zipWith Pixel (projectRect r0 r1 . pixelRect <$> ps) (pixelColor <$> ps) + +-- | a chart of pixels scaled to its own range +-- +-- > pixelChart_ asquare [[Pixel (Rect x (x+0.05) y (y+0.05)) (blend (x*y+x*x) ugrey ublue) | x <- grid OuterPos (one::Range Double) 20, y <- grid OuterPos (one::Range Double) 20]] +-- +-- ![pixelChart_ example](other/pixelChart_Example.svg) +-- +pixelChart_ :: (Traversable f) => Aspect -> [f Pixel] -> Chart b +pixelChart_ asp ps = pixelChart asp (fold $ fold . map pixelRect <$> ps) ps + +-- | options to pixelate a Rect using a function +data PixelationOptions = PixelationOptions + { pixelationGradient :: Range (AlphaColour Double) + , pixelationGrain :: Pair Int + } + +instance Default PixelationOptions where + def = PixelationOptions (Range ugrey ublue) (Pair 20 20) + +-- | transform a Rect into Pixels using a function over a Pair +pixelate :: + PixelationOptions -> Rect Double -> (Pair Double -> Double) -> [Pixel] +pixelate (PixelationOptions (Range lc0 uc0) grain) xy f = zipWith Pixel g cs + where + g = gridSpace xy grain + xs = f . mid <$> g + (Range lx ux) = space xs + cs = (\x -> blend ((x - lx) / (ux - lx)) lc0 uc0) <$> xs + +-- | chart pixels using a function +-- This is a convenience function, and the example below is equivalent to the pixelChart_ example +-- +-- > pixelateChart def asquare one (\(Pair x y) -> x*y+x*x) +-- +pixelateChart :: + PixelationOptions + -> Aspect + -> Rect Double + -> (Pair Double -> Double) + -> Chart b +pixelateChart opts asp xy f = pixelChart asp xy [pixelate opts xy f] diff --git a/src/Chart/Text.hs b/src/Chart/Text.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Text.hs @@ -0,0 +1,102 @@ +{-# OPTIONS_GHC -Wall #-} +-- | text chart elements +module Chart.Text + ( TextOptions(..) + , text_ + , texts + , textChart + , textChart_ + , LabelOptions(..) + , labelled + ) where + +import Chart.Core +import qualified Data.Text as Text +import Diagrams.Prelude hiding (Color, D, scale) +import qualified Diagrams.TwoD.Size as D +import Graphics.SVGFonts +import NumHask.Pair +import NumHask.Prelude hiding (rotate) +import NumHask.Rect + +-- | text options +data TextOptions = TextOptions + { textSize :: Double + , textAlignH :: AlignH + , textColor :: AlphaColour Double + , textFillRule :: FillRule + , textRotation :: Double + } + +instance Default TextOptions where + def = TextOptions 0.08 AlignCenter (withOpacity black 0.33) EvenOdd 0 + +-- | create a text primitive +-- +-- > let text_Example = text_ def "Welcome to chart-unit!" +-- +-- ![text_ example](other/text_Example.svg) +-- +text_ :: TextOptions -> Text -> Chart b +text_ (TextOptions s a c fr rot) t = + moveTo (p_ (Pair (alignHTU a * D.width path) 0)) $ + path # fcA c # lw 0 # fillRule fr # rotate (rot @@ deg) + where + path = textSVG_ (TextOpts lin2 INSIDE_H KERN False s s) (Text.unpack t) + +-- | positioned svg text from a list +-- +-- > let ts = map (Text.singleton) ['a'..'z'] +-- > texts def ts [Pair (0.05*x) 0 |x <- [0..5]] +-- +-- ![texts example](other/textsExample.svg) +-- +texts :: (R2 r) => TextOptions -> [Text] -> [r Double] -> Chart b +texts opts ts ps = mconcat $ zipWith (\p t -> positioned p (text_ opts t)) ps ts + +-- | a chart of text +textChart :: + (Traversable f) + => [TextOptions] + -> Aspect + -> Rect Double + -> [f (Text, Pair Double)] + -> Chart b +textChart optss (Aspect asp) r xyss = + mconcat $ + getZipList $ + texts <$> ZipList optss <*> ZipList (map fst . toList <$> xyss) <*> + ZipList (projectss r asp (fmap snd . toList <$> xyss)) + +-- | a chart of text scaled to its own range +-- +-- > import qualified Data.Text as Text +-- > let ps = [Pair (sin (x*0.1)) x | x<-[0..25]] +-- > textChart_ (repeat $ def {textSize=0.33}) widescreen [zip ts ps] +-- +-- ![textChart_ example](other/textChart_Example.svg) +-- +textChart_ :: [TextOptions] -> Aspect -> [[(Text, Pair Double)]] -> Chart b +textChart_ optss asp xyss = + textChart optss asp (range $ fmap snd . toList <$> xyss) xyss + +-- | a label is a text element attached to a chart element +data LabelOptions = LabelOptions + { labelText :: TextOptions + , labelOrientation :: Pair Double -- ^ direction of label + , labelGap :: Double -- ^ distance to label + } + +instance Default LabelOptions where + def = LabelOptions def (Pair 0 1) 0.05 + +-- | label a chart element with some text +-- +-- > let lopts = def {textAlignH = AlignLeft, textRotation=45} +-- > labelled (LabelOptions lopts (Pair 1 1) 0.05) "a label" (glyph_ def) +-- +-- ![labelled example](other/labelledExample.svg) +-- +labelled :: LabelOptions -> Text -> Chart b -> Chart b +labelled (LabelOptions texto o g) t ch = + beside (r_ o) (beside (r_ o) ch (strut (r_ o) # scale g)) (text_ texto t) diff --git a/src/Chart/Types.hs b/src/Chart/Types.hs deleted file mode 100644 --- a/src/Chart/Types.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} -{-# LANGUAGE TemplateHaskell #-} - -module Chart.Types - ( Chart - , Chart' - , Aspect(..) - , aspect - , asquare - , sixbyfour - , golden - , widescreen - , QChart(..) - , qXY - , qChart - , qData - , Orientation(..) - , Placement(..) - , TickStyle(..) - , Color(..) - , color - , uncolor - , opac - , opacs - , palette - , AxisConfig(..) - , axisPad - , axisOrientation - , axisPlacement - , axisHeight - , axisColor - , axisMarkSize - , axisMarkColor - , axisInsideStrut - , axisLabelStrut - , axisTextSize - , axisTextColor - , axisTickStyle - , axisAlignedTextRight - , axisAlignedTextBottom - , ChartConfig(..) - , chartPad - , chartAxes - , chartRange - , chartAspect - , chartCanvasColor - , LineConfig(..) - , lineSize - , Chart.Types.lineColor - , ScatterConfig(..) - , scatterSize - , scatterColor - , RectConfig(..) - , rectBorderWidth - , rectBorderColor - , rectColor - , ArrowConfig(..) - , arrowMinHeadSize - , arrowMaxHeadSize - , arrowHeadSize - , arrowMinStaffLength - , arrowMaxStaffLength - , arrowStaffLength - , arrowMinStaffWidth - , arrowMaxStaffWidth - , arrowStaffWidth - , arrowColor - , PixelConfig(..) - , pixelGradient - , pixelGrain - , TextConfig - , textPad - , textOrientation - , textPlacement - , textSize - , textColor - , textRight - , textBottom - ) where - -import NumHask.Prelude -import Diagrams.Prelude hiding (Color(..), aspect) -import qualified Diagrams.TwoD.Text -import NumHask.Range -import NumHask.Rect -import Data.Colour - --- | a Chart has a concrete scale, and combinatory options amount to mappend (on top of) and beside -type Chart a = - ( Renderable (Path V2 Double) a - ) => - QDiagram a V2 Double Any - --- | an alternative synonym where text is involved. -type Chart' a = - ( Renderable (Path V2 Double) a - , Renderable (Diagrams.TwoD.Text.Text Double) a - ) => - QDiagram a V2 Double Any - --- | the rendering aspect (or plane) of the chart. Wrapped to distinguish this from a plain XY -data Aspect = Aspect { unAspect :: Rect Double} - -aspect :: Double -> Aspect -aspect a = Aspect (Rect (V2 ((a*) <$> one) one)) - -asquare :: Aspect -asquare = aspect 1 - -sixbyfour :: Aspect -sixbyfour = aspect 1.5 - -golden :: Aspect -golden = aspect 1.61803398875 - -widescreen :: Aspect -widescreen = aspect 3 - --- | The concrete nature of a QDiagram, and a desire to scale data and hud items naturally, a QChart is mostly a late binding of the Aspect that the chart is to be projected on to and the data. -data QChart a b = QChart - { _qChart :: ( ( Renderable (Diagrams.TwoD.Text.Text Double) a) - , Renderable (Path V2 Double) a) => - Aspect -> b -> QDiagram a V2 Double Any - , _qXY :: Rect Double - , _qData :: b - } - -makeLenses ''QChart - -data Orientation = X | Y - -data Placement = AxisLeft | AxisRight | AxisTop | AxisBottom - -data TickStyle = TickNone | TickLabels [Text] | TickRound Int | TickExact Int | TickPlaced [(Double,Text)] - -data Color = - Color - { _red :: Double - , _green :: Double - , _blue :: Double - , _aaa :: Double - } deriving (Eq, Show) - -color ∷ Color → AlphaColour Double -color (Color r g b a)= withOpacity (sRGB r g b) a - -uncolor ∷ AlphaColour Double → Color -uncolor c = Color r g b a - where - a = alphaChannel c - (RGB r g b) = toSRGB (Data.Colour.over c black) - -palette ∷ [Color] -palette = - [ Color 0.333 0.333 0.333 1.00 -- grey - , Color 0.365 0.647 0.855 1.00 -- blue - , Color 0.980 0.647 0.855 1.00 -- orange - , Color 0.376 0.741 0.408 1.00 -- green - , Color 0.945 0.486 0.690 1.00 -- pink - , Color 0.698 0.569 0.184 1.00 -- brown - , Color 0.698 0.463 0.698 1.00 -- purple - , Color 0.871 0.812 0.247 1.00 -- yellow - , Color 0.945 0.345 0.329 1.00 -- red - ] - -opacs :: Double -> [Color] -> [Color] -opacs t cs = (\(Color r g b o) -> Color r g b (o*t)) <$> cs - -opac :: Double -> Color -> Color -opac t (Color r g b o) = Color r g b (o*t) - -data AxisConfig = AxisConfig - { _axisPad :: Double - , _axisOrientation :: Orientation - , _axisPlacement :: Placement - , _axisHeight :: Double - , _axisColor :: Color - , _axisMarkSize :: Double -- mark length - , _axisMarkColor :: Color - , _axisInsideStrut :: Double -- distance of axis from plane - , _axisLabelStrut :: Double -- distance of label from mark - , _axisTextSize :: Double - , _axisTextColor :: Color - , _axisTickStyle :: TickStyle - , _axisAlignedTextRight :: Double - , _axisAlignedTextBottom :: Double - } - -instance Default AxisConfig where - def = - AxisConfig - 1 - X - AxisBottom - 0.02 - (Color 0.333 0.333 0.333 0.2) - 0.02 - (Color 0.1 0.4 0.8 0.5) - 0.05 - 0.02 - 0.04 - (Color 0.2 0.2 0.2 0.7) - (TickRound 8) - 0.5 - 1 - -makeLenses ''AxisConfig - -data ChartConfig = ChartConfig - { _chartPad :: Double - , _chartAxes :: [AxisConfig] - , _chartRange :: Maybe (Rect Double) - , _chartAspect :: Aspect - , _chartCanvasColor :: Color - } - -instance Default ChartConfig where - def = - ChartConfig - 1.3 - [def, - axisAlignedTextBottom .~ 0.65 $ - axisAlignedTextRight .~ 1 $ - axisOrientation .~ Y $ - axisPlacement .~ AxisLeft $ - def] - Nothing - sixbyfour - (Color 1 1 1 0.02) - -makeLenses ''ChartConfig - -data LineConfig = LineConfig - { _lineSize :: Double - , _lineColor :: Color - } - -instance Default LineConfig where - def = LineConfig 0.02 (Color 0.365 0.647 0.855 1.00) - -makeLenses ''LineConfig - -data ScatterConfig = ScatterConfig - { _scatterSize :: Double - , _scatterColor :: Color - } - -instance Default ScatterConfig where - def = ScatterConfig 0.03 (Color 0.33 0.33 0.33 0.2) - -makeLenses ''ScatterConfig - -data RectConfig = RectConfig - { _rectBorderWidth :: Double - , _rectBorderColor :: Color - , _rectColor :: Color - } - -instance Default RectConfig where - def = RectConfig 1 (Color 0.333 0.333 0.333 0.4) (Color 0.365 0.647 0.855 0.5) - -makeLenses ''RectConfig - -data ArrowConfig a = ArrowConfig - { _arrowMinHeadSize :: a - , _arrowMaxHeadSize :: a - , _arrowHeadSize :: a - , _arrowMinStaffLength :: a - , _arrowMaxStaffLength :: a - , _arrowStaffLength :: a - , _arrowMinStaffWidth :: a - , _arrowMaxStaffWidth :: a - , _arrowStaffWidth :: a - , _arrowColor :: Color - } - -instance Default (ArrowConfig Double) where - def = ArrowConfig 0.01 0.05 0.03 0.1 0.1 0.1 0.01 0.005 0.2 - (Color 0.333 0.333 0.888 0.8) - -makeLenses ''ArrowConfig - -data PixelConfig = - PixelConfig - { _pixelGradient :: Range Color - , _pixelGrain :: V2 Int - } - -instance Default PixelConfig where - def = PixelConfig - (Range ( Color 1 1 1 1 - , Color 0 0 0 1)) - (V2 20 20) - -makeLenses ''PixelConfig - -data TextConfig = TextConfig - { _textPad :: Double - , _textOrientation :: Orientation - , _textPlacement :: Placement - , _textSize :: Double - , _textColor :: Color - , _textRight :: Double - , _textBottom :: Double - } - -instance Default TextConfig where - def = - TextConfig - 1 - X - AxisBottom - 0.08 - (Color 0.333 0.333 0.333 0.2) - 0.5 - 1 - -makeLenses ''TextConfig - diff --git a/src/Chart/Unit.hs b/src/Chart/Unit.hs deleted file mode 100644 --- a/src/Chart/Unit.hs +++ /dev/null @@ -1,515 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - -module Chart.Unit - ( scaleX - , scaleY - , blob - , line1 - , scatter1 - , rect1 - , pixel1 - , arrow1 - , box - , scatterChart - , scatterChartWithRange - , lineChart - , lineChartWithRange - , histChart - , histChartWithRange - , arrowChart - , arrowChartWithRange - , rangeV4 - , rangeV42Rect - , scaleV4s - , toPixels - , rescalePixels - , pixelf - , withChart - , axes - , combine - , fileSvg - , bubble - -- , text1 - , histCompare - ) where - -import NumHask.Prelude hiding (min,max,from,to,(&)) - -import NumHask.Range -import NumHask.Rect -import NumHask.Histogram -import Chart.Types - -import Control.Lens hiding (beside, none, (#), at) -import Data.Ord (max, min) -import Diagrams.Backend.SVG (SVG, renderSVG) -import Diagrams.Prelude hiding (width, unit, D, Color, scale, zero, scaleX, scaleY, aspect, rect, project) -import Formatting -import Linear hiding (zero, identity, unit, project) - -import qualified Control.Foldl as L -import qualified Data.Text as Text -import qualified Diagrams.Prelude as Diagrams - --- | avoiding the scaleX zero throw -eps :: N [Point V2 Double] -eps = 1e-8 - -scaleX :: Double -> [Point V2 Double] -> [Point V2 Double] -scaleX s = Diagrams.scaleX (if s==zero then eps else s) - -scaleY :: Double -> [Point V2 Double] -> [Point V2 Double] -scaleY s = Diagrams.scaleY (if s==zero then eps else s) - --- * chartlets are recipes for constructing QDiagrams from traversable containers of vectors and a configuration --- a solid blob (shape) with a colour fill and no border -blob ∷ (Floating (N a), Ord (N a), Typeable (N a), HasStyle a, V a ~ V2) ⇒ - Chart.Types.Color → a → a -blob c = fcA (color c) # lcA (withOpacity black 0) # lw none - --- a line is just a scatter chart rendered with a line --- (and with a usually stable x-value series) -line1 ∷ (Traversable f, R2 r) => LineConfig → f (r Double) → Chart b -line1 (LineConfig s c) ps = case NumHask.Prelude.head ps of - Nothing -> mempty - Just p0 -> stroke (trailFromVertices (toList $ (p2 . unr2) . view _xy <$> ps) - `at` - p2 (unr2 (view _xy p0))) # lcA (color c) # lwN s - --- dots on the XY plane -scatter1 ∷ (Traversable f, R2 r) => ScatterConfig → f (r Double) → Chart b -scatter1 (ScatterConfig s c) ps = - atPoints (toList $ (p2 . unr2) . view _xy <$> ps) - (repeat $ circle s # - blob c - ) - --- | rectangles specified using a V4 x y z w where --- (x,y) is location of lower left corner --- (z,w) is location of upper right corner -rect1 :: (Traversable f) => RectConfig -> f (Rect Double) -> Chart b -rect1 cfg rs = mconcat $ toList $ - (\(Rect (V2 (Range (x,z)) (Range (y,w)))) -> - (unitSquare # - moveTo (p2 (0.5,0.5)) # - Diagrams.scaleX (if z-x==zero then eps else z-x) # - Diagrams.scaleY (if w-y==zero then eps else w-y) # - moveTo (p2 (x,y)) # - fcA (color $ cfg ^. rectColor) # - lcA (color $ cfg ^. rectBorderColor) # - lw 1 - )) <$> rs - -arrow1 :: (Traversable f) => ArrowConfig Double -> f (V4 Double) -> Chart b -arrow1 cfg qs = - fcA (color $ cfg ^. arrowColor) $ position $ - zip - ((\(V4 x y _ _) -> p2 (x,y)) <$> toList qs) - (arrowStyle cfg <$> toList qs) - -arrowStyle :: ArrowConfig Double -> V4 Double -> Chart b -arrowStyle cfg (V4 _ _ z w) = - arrowAt' opts (p2 (0, 0)) (sL *^ V2 z w) - where - trunc minx maxx a = min (max minx a) maxx - m = norm (V2 z w) - hs = trunc (cfg ^. arrowMinHeadSize) (cfg ^. arrowMaxHeadSize) (cfg ^. arrowHeadSize * m) - sW = trunc (cfg ^. arrowMinStaffWidth) (cfg ^. arrowMaxStaffWidth) (cfg ^. arrowStaffWidth * m) - sL = trunc (cfg ^. arrowMinStaffLength) (cfg ^. arrowMaxStaffLength) (cfg ^. arrowStaffLength * m) - opts = with & arrowHead .~ tri & - headLength .~ global hs & - shaftStyle %~ (lwG sW & lcA (color $ cfg ^. arrowColor)) & - headStyle %~ (lcA (color $ cfg ^. arrowColor) & fcA (color $ cfg ^. arrowColor)) - --- | convert from an XY to a polymorphic qdiagrams rectangle -box :: - ( Field (N t) - , N t ~ Double - , V t ~ V2 - , HasOrigin t - , Transformable t - , TrailLike t) => - Rect Double -> t -box (Rect (V2 x y)) = - moveOriginTo (p2 ( -x^.low - (x^.width/2) - , -y^.low - (y^.width/2))) $ - Diagrams.scaleX (if x^.width==zero then eps else x^.width) $ - Diagrams.scaleY (if y^.width==zero then eps else y^.width) - unitSquare - --- | a pixel is a rectangle with a color. -pixel1 :: (Traversable f) => f (Rect Double, Color) -> Chart b -pixel1 rs = mconcat $ toList $ - (\(Rect (V2 (Range (x,z)) (Range (y,w))), c) -> - (unitSquare # - moveTo (p2 (0.5,0.5)) # - Diagrams.scaleX (if z-x==zero then eps else z-x) # - Diagrams.scaleY (if w-y==zero then eps else w-y) # - moveTo (p2 (x,y)) # - fcA (color c) # - lcA transparent # - lw 0 - )) <$> rs - --- * charts are recipes for constructing a QDiagram from a specification of the XY plane to be projected on to (XY), a list of traversable vector containers and a list of configurations. The charts are self-scaling. --- | a chart of scattered dot points scaled to its own range -scatterChart :: - (R2 r, Traversable f) => - [ScatterConfig] -> - Aspect -> - [f (r Double)] -> - Chart a -scatterChart defs asp xyss = - scatterChartWithRange (foldMap rangeR2 xyss) defs asp xyss - --- | a chart of scattered dot points with a specific range -scatterChartWithRange :: - (R2 r, Traversable f) => - Rect Double -> - [ScatterConfig] -> - Aspect -> - [f (r Double)] -> - Chart a -scatterChartWithRange cr defs (Aspect xy) xyss = - mconcat $ zipWith scatter1 defs (projectR2 cr xy <$> xyss) - --- | a chart of lines scaled to its own range -lineChart :: - (R2 r, Traversable f) => - [LineConfig] -> - Aspect -> - [f (r Double)] -> - Chart a -lineChart defs asp xyss = - lineChartWithRange (foldMap rangeR2 xyss) defs asp xyss - --- | a chart of lines with a specific range -lineChartWithRange :: - (R2 r, Traversable f) => - Rect Double -> - [LineConfig] -> - Aspect -> - [f (r Double)] -> - Chart a -lineChartWithRange cr defs (Aspect xy) xyss = - mconcat $ zipWith line1 defs (projectR2 cr xy <$> xyss) - --- | a chart of histograms scaled to its own range -histChart :: - (Traversable f) => - [RectConfig] -> - Aspect -> - [f (Rect Double)] -> - Chart a -histChart defs asp rs = - histChartWithRange (fold $ fold <$> rs) defs asp rs - --- | a chart of histograms with a specific range -histChartWithRange :: - (Traversable f) => - Rect Double -> - [RectConfig] -> - Aspect -> - [f (Rect Double)] -> - Chart a -histChartWithRange cr defs (Aspect xy) rs = - mconcat . zipWith rect1 defs $ fmap (projectRect cr xy) <$> rs - -toPixels :: Rect Double -> (V2 Double -> Double) -> PixelConfig -> [(Rect Double, Color)] -toPixels xy f cfg = zip g cs - where - g = grid xy (view pixelGrain cfg) - xs = f . midRect <$> g - (Range (lx,ux)) = range xs - (Range (lc0,uc0)) = view pixelGradient cfg - cs = uncolor . (\x -> blend ((x - lx)/(ux - lx)) (color lc0) (color uc0)) <$> xs - -rescalePixels :: Rect Double -> [(Rect Double, Color)] -> [(Rect Double, Color)] -rescalePixels xy xys = zip vs cs - where - vs = projectRect (fold $ fst <$> xys) xy . fst <$> xys - cs = snd <$> xys - --- | pixels over an XY plane using a function -pixelf :: - PixelConfig -> - Aspect -> - Rect Double -> - (V2 Double -> Double) -> - Chart a -pixelf cfg (Aspect asp) xy f = - pixel1 $ rescalePixels asp (toPixels xy f cfg) - --- | arrow lengths and sizes also need to be scaled, and so arrows doesnt fit as neatly into the whole scaling idea -arrowChartWithRange :: - (Traversable f) => - V4 (Range Double) -> - ArrowConfig Double -> - V4 (Range Double) -> - f (V4 Double) -> - Chart a -arrowChartWithRange cr cfg xy xs = - arrow1 cfg $ rescaleV4P cr xy <$> xs - -arrowChart :: - (Traversable f) => - ArrowConfig Double -> - V4 (Range Double) -> - f (V4 Double) -> - Chart a -arrowChart cfg xy xs = - arrow1 cfg $ rescaleV4P (rangeV4 xs) xy <$> xs - --- | rescale a V4 from rold to rnew -rescaleV4P :: V4 (Range Double) -> V4 (Range Double) -> V4 Double -> V4 Double -rescaleV4P rold rnew q = - over _x (project (rold^._x) (rnew^._x)) $ - over _y (project (rold^._y) (rnew^._y)) $ - over _z (project (rold^._z) (rnew^._z)) $ - over _w (project (rold^._w) (rnew^._w)) - q - --- | rescale a container of V4s -rescaleV4 :: (Functor f) => - V4 (Range Double) -> V4 (Range Double) -> f (V4 Double) -> f (V4 Double) -rescaleV4 rold rnew qs = rescaleV4P rold rnew <$> qs - --- | scale a double container of V4s from the current range -scaleV4s :: (Traversable f) => - V4 (Range Double) -> f (V4 Double) -> f (V4 Double) -scaleV4s r f = rescaleV4 (rangeV4 f) r f - --- | V4 range of a V4 container -rangeV4 :: (Traversable f) => f (V4 Double) -> V4 (Range Double) -rangeV4 qs = V4 rx ry rz rw - where - rx = range $ toList (view _x <$> qs) - ry = range $ toList (view _y <$> qs) - rz = range $ toList (view _z <$> qs) - rw = range $ toList (view _w <$> qs) - -rangeV42Rect :: V4 (Range Double) -> Rect Double -rangeV42Rect (V4 x y z w) = Rect (V2 (x<>z) (y<>w)) - --- * axis rendering - --- | render with a chart configuration -withChart :: - ( Traversable f - , R2 r) => - ChartConfig -> - (Aspect -> [f (r Double)] -> QDiagram a V2 Double Any) -> - [f (r Double)] -> - Chart' a -withChart conf renderer d = case conf^.chartRange of - Nothing -> - renderer (conf^.chartAspect) d <> - axes (chartRange .~ Just (foldMap rangeR2 d) $ conf) - Just axesRange -> - combine (conf ^. chartAspect) - [ QChart renderer r d - , QChart - (\asp _ -> - axes - ( chartAspect.~asp - $ chartRange .~ Just axesRange - $ conf)) - r - [] - ] - where - r = foldMap rangeR2 d - -axes :: - ChartConfig -> - Chart' a -axes (ChartConfig p a r (Aspect asp@(Rect (V2 ax ay))) cc) = - L.fold (L.Fold step begin (pad p)) a - where - begin = box asp # fcA (color cc) # lcA (withOpacity black 0) # lw none - step x cfg = beside dir x (mo $ axis1 cfg rendr tickr) - where - rendr = case view axisOrientation cfg of - X -> ax - Y -> ay - tickr = case view axisOrientation cfg of - X -> rx - Y -> ry - dir = case view axisPlacement cfg of - AxisBottom -> r2 (0,-1) - AxisTop -> r2 (0,1) - AxisLeft -> r2 (-1,0) - AxisRight -> r2 (1,0) - mo = case view axisOrientation cfg of - X -> moveOriginTo (p2 ((-ax^.low)-(ax^.width)/2,0)) - Y -> moveOriginTo (p2 (0,(-ay^.low)-(ay^.width)/2)) - (Rect (V2 rx ry)) = fromMaybe one r - -axis1 :: - AxisConfig -> - Range Double -> - Range Double -> - Chart' b -axis1 cfg rendr tickr = pad (cfg ^. axisPad) $ strut2 $ centerXY $ - atPoints - (t <$> tickLocations) - ((`mkLabel` cfg) <$> tickLabels) - `atop` - (axisRect (cfg ^. axisHeight) rendr - # blob (cfg ^. axisColor)) - where - strut2 x = beside dir x $ strut1 (cfg ^. axisInsideStrut) - dir = case cfg ^. axisPlacement of - AxisBottom -> r2 (0,1) - AxisTop -> r2 (0,-1) - AxisLeft -> r2 (1,0) - AxisRight -> r2 (-1,0) - strut1 = case cfg ^. axisOrientation of - X -> strutY - Y -> strutX - t = case cfg ^. axisOrientation of - X -> \x -> p2 (x, 0) - Y -> \y -> p2 (-(cfg ^. axisMarkSize), y) - ticks0 = case cfg ^. axisTickStyle of - TickNone -> [] - TickRound n -> linearSpaceSensible OuterPos tickr n - TickExact n -> linearSpace OuterPos tickr n - TickLabels _ -> [] - TickPlaced xs -> fst <$> xs - tickLocations = case cfg ^. axisTickStyle of - TickNone -> [] - {- To Do: - rounded ticks introduce the possibility of marks beyond the existing range. - if this happens, it should really be fed into the chart rendering as a new, - revised range. - -} - TickRound _ -> project tickr rendr <$> ticks0 - TickExact _ -> project tickr rendr <$> ticks0 - TickLabels ls -> - project - (Range (0, fromIntegral $ length ls)) - rendr <$> - ((\x -> x - 0.5) . fromIntegral <$> [1..length ls]) - TickPlaced _ -> project tickr rendr <$> ticks0 - tickLabels = case cfg ^. axisTickStyle of - TickNone -> [] - TickRound _ -> tickFormat <$> ticks0 - TickExact _ -> tickFormat <$> ticks0 - TickLabels ls -> ls - TickPlaced xs -> snd <$> xs - tickFormat = sformat (prec 2) - axisRect h (Range (l,u)) = case cfg ^. axisOrientation of - X -> moveTo (p2 (u,0)) . - strokeTrail . - closeTrail . - fromVertices . - scaleY h . - scaleX (u-l) $ - unitSquare - Y -> moveTo (p2 (0,l)) . - strokeTrail . - closeTrail . - fromVertices . - scaleX h . - scaleY (u-l) $ - unitSquare - -mkLabel :: - Text -> - AxisConfig -> - Chart' b -mkLabel label cfg = - beside dir - (beside dir - (rule (cfg ^. axisMarkSize) # - lcA (color $ cfg ^. axisMarkColor)) - s) - (Diagrams.Prelude.alignedText - (cfg ^. axisAlignedTextRight) - (cfg ^. axisAlignedTextBottom) - (Text.unpack label) # - Diagrams.scale (cfg ^. axisTextSize) # - fcA (color $ cfg ^.axisTextColor)) - where - dir = case cfg ^. axisOrientation of - X -> r2 (0,-1) - Y -> r2 (-1,0) - rule = case cfg ^. axisOrientation of - X -> vrule - Y -> hrule - s = case cfg ^. axisOrientation of - X -> strutY (cfg ^. axisLabelStrut) - Y -> strutX (cfg ^. axisLabelStrut) - -{- -text1 :: - TextConfig -> - Text -> - Chart' b -text1 cfg label = - Diagrams.Prelude.alignedText - (cfg ^. textRight) - (cfg ^. textBottom) - (Text.unpack label) # - Diagrams.scale (cfg ^. textSize) # - fcA (color $ cfg ^.textColor) - where - dir = case cfg ^. textOrientation of - X -> r2 (0,-1) - Y -> r2 (-1,0) --} - --- * rendering --- | render a list of qcharts using a common scale -combine :: Aspect -> [QChart a b] -> Chart' a -combine (Aspect xy) qcs = mconcat $ - (\(QChart c xy1 x) -> c - (Aspect $ xy `times` xy1 `times` recip xysum) - x) <$> qcs - where - xysum = mconcat $ (\(QChart _ xy1 _) -> xy1) <$> qcs - -fileSvg ∷ FilePath → (Double, Double) → Chart SVG → IO () -fileSvg f s = renderSVG f (mkSizeSpec (Just <$> r2 s)) - --- outline of a chart -bubble ∷ ∀ a. (FromInteger (N a), MultiplicativeGroup (N a), RealFloat (N a), Traced a, V a ~ V2) ⇒ [a] → Int → [V a (N a)] -bubble chart' n = bubble' - where - bubble' = ps - ps = catMaybes $ maxRayTraceV (p2 (0,0)) <$> - ((\x -> view (Diagrams.Prelude.from r2PolarIso) (1, x @@ rad)) . - (\x -> fromIntegral x/10.0) <$> [0..n]) <*> - chart' - -histCompare :: DealOvers -> Histogram -> Histogram -> Chart' a -histCompare o h1 h2 = - let h = fromHist o h1 - h' = fromHist o h2 - h'' = zipWith (\(Rect (V2 (Range (x,y)) (Range (z,w)))) (Rect (V2 _ (Range (_,w')))) -> Rect (V2 (Range (x,y)) (Range (z,w-w')))) h h' - flat = Aspect $ Rect (V2 (Range (-0.75,0.75)) (Range (-0.25,0.25))) - in - pad 1.1 $ - beside (r2 (0,-1)) (histChart - [ def - , rectBorderColor .~ Color 0 0 0 0 - $ rectColor .~ Color 0.333 0.333 0.333 0.1 - $ def ] sixbyfour [h,h'] <> - axes (ChartConfig 1.1 - [def] - (Just (fold $ fold [abs <$> h,abs <$> h'])) - sixbyfour (uncolor transparent))) - (histChart - [ rectBorderColor .~ Color 0 0 0 0 - $ rectColor .~ Color 0.888 0.333 0.333 0.8 - $ def ] flat [abs <$> h''] <> - axes (ChartConfig 1.1 - [ axisAlignedTextBottom .~ 0.65 $ - axisAlignedTextRight .~ 1 $ - axisOrientation .~ Y $ - axisPlacement .~ AxisLeft $ - def - ] - (Just (fold $ abs <$> h'')) - flat (uncolor transparent))) diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,19 @@ -resolver: lts-8.23 +resolver: lts-8.24 packages: -- '.' + - '.' extra-deps: -- numhask-0.0.5 -- numhask-range-0.0.3 + - numhask-0.1.2 + - numhask-range-0.1.1 + #- SVGFonts-1.6.0.1 + #- diagrams-lib-1.4.1.2 + #- diagrams-svg-1.4.1 + #- palette-0.1.0.4 + #- diagrams-core-1.4 + #- diagrams-solve-0.1.1 + #- cereal-vector-0.2.0.1 + #- dual-tree-0.2.1 + #- svg-builder-0.1.0.2 + +allow-newer: true diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,52 +1,43 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE DataKinds #-} module Main where import Chart import NumHask.Prelude - -import Test.Tasty (testGroup, defaultMain) +import Test.Tasty (defaultMain, testGroup) import Test.Tasty.Hspec testWithChart :: SpecWith () -testWithChart = describe "withChart" $ do +testWithChart = + describe "withChart" $ do it "axes and chartWith should render the same" $ do - fileSvg "test/empty.svg" (400,400) emptyChart - fileSvg "test/justAxes.svg" (400,400) justAxesChart - t1 <- readFile "test/empty.svg" - t2 <- readFile "test/justAxes.svg" - t1 `shouldBe` t2 - + fileSvg "test/empty.svg" (400, 400) emptyChart + fileSvg "test/justAxes.svg" (400, 400) justAxesChart + t1 <- readFile "test/empty.svg" + t2 <- readFile "test/justAxes.svg" + t1 `shouldBe` t2 it "chartWith lines and lines <> axes" $ do - fileSvg "test/line.svg" (400,400) line1Chart - fileSvg "test/line2.svg" (400,400) line2Chart - t1 <- readFile "test/line.svg" - t2 <- readFile "test/line2.svg" - t1 `shouldBe` t2 - where - emptyChart = withChart def (\_ _ -> mempty) [corners one] - justAxesChart = axes def - line1Chart = withChart def (lineChart lineDefs) lineData - line2Chart = - lineChart lineDefs sixbyfour lineData <> - axes (chartRange .~ Just (rangeR2s lineData) $ def) - - lineDefs :: [LineConfig] - lineDefs = - [ LineConfig 0.01 (Color 0.945 0.345 0.329 0.8) - , LineConfig 0.02 (Color 0.698 0.569 0.184 0.5) - , LineConfig 0.005 (Color 0.5 0.5 0.5 1.0) - ] - lineData :: [[V2 Double]] - lineData = - fmap r2 <$> - [ [(0.0,1.0),(1.0,1.0),(2.0,5.0)] - , [(0.0,0.0),(3.0,3.0)] - , [(0.5,4.0),(0.5,0)] - ] + fileSvg "test/line.svg" (400, 400) line1Chart + fileSvg "test/line2.svg" (400, 400) line2Chart + t1 <- readFile "test/line.svg" + t2 <- readFile "test/line2.svg" + t1 `shouldBe` t2 + where + emptyChart = withHud def (\_ _ -> mempty) [corners one] + justAxesChart = hud def + line1Chart = withHud def (lineChart (repeat def)) lineData + line2Chart = + lineChart_ (repeat def) sixbyfour lineData <> + hud (def {hudRange = Just (range lineData)}) + lineData :: [[Pair Double]] + lineData = + fmap (uncurry Pair) <$> + [ [(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)] + , [(0.0, 0.0), (3.0, 3.0)] + , [(0.5, 4.0), (0.5, 0)] + ] main :: IO () main = do - t1 <- testSpec "withChart" testWithChart - defaultMain $ testGroup "chart-unit" [t1] + t1 <- testSpec "withChart" testWithChart + defaultMain $ testGroup "chart-unit" [t1]