{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -- -- Based on the Elm VegaLite FillStrokeTests.elm as of version 1.12.0 -- -- Note that fill1, stroke1, and combined1 generate invalid Vega-Lite -- since they create empty objects for the fill or stroke fields, -- and that is not valid. I am leaving this as is for now. -- module FillStrokeTests (testSpecs) where import qualified Data.Text as T import Data.Aeson (Value) import Data.Aeson.QQ.Simple (aesonQQ) #if !(MIN_VERSION_base(4, 12, 0)) import Data.Monoid ((<>)) #endif import Graphics.Vega.VegaLite hiding (filter, repeat) testSpecs :: [(String, VegaLite)] testSpecs = [ ("default", defChart) , ("fill1", fill1) , ("fill2", fill2) , ("fill3", fill3) , ("stroke1", stroke1) , ("stroke2", stroke2) , ("stroke3", stroke3) , ("combined1", combined1) , ("combined2", combined2) , ("combined3", combined3) , ("geo1", geo1) , ("geo2", geo2) , ("gradient1", gradient1) , ("gradient2", gradient2) , ("gradient3", gradient3) , ("gradientr1", gradientr1) , ("gradientr2", gradientr2) , ("gradientr3", gradientr3) , ("vrounded", vrounded) , ("hrounded", hrounded) , ("strokedash1", strokeDash1) , ("strokedash2", strokeDash2) , ("strokedash3", strokeDash3) , ("strokedash4", strokeDash4) , ("strokedash5", strokeDash5) , ("strokedash6", strokeDash6) , ("strokedash7", strokeDash7) , ("strokedash8", strokeDash8) , ("strokedash9", strokeDash9) ] encChart :: ([a] -> [EncodingSpec]) -> VegaLite encChart extraEnc = let dataVals = dataFromColumns [] . dataColumn "x" (Numbers [ 10, 20, 30, 36 ]) . dataColumn "y" (Numbers [ 1, 2, 3, 4 ]) . dataColumn "val" (Numbers [ 1, 2, 3, 4 ]) . dataColumn "cat" (Strings [ "a", "b", "c", "d" ]) enc = encoding . position X [ PName "x", PmType Quantitative ] . position Y [ PName "y", PmType Quantitative ] . color [ MName "cat", MmType Nominal ] . size [ MNumber 2000 ] . extraEnc in toVegaLite [ width 200, height 200, dataVals [], enc [], mark Circle [ MStroke "black" ] ] defChart :: VegaLite defChart = encChart (const []) fill1, fill2, fill3 :: VegaLite fill1 = encChart (fill []) -- this produces invalid output fill2 = encChart (fill [ MName "y", MmType Ordinal ]) fill3 = encChart (fill [ MString "red" ]) stroke1, stroke2, stroke3 :: VegaLite stroke1 = encChart (stroke []) -- this produces invalid output stroke2 = encChart (stroke [ MName "y", MmType Ordinal ]) stroke3 = encChart (stroke [ MString "red" ]) combined1, combined2, combined3 :: VegaLite combined1 = encChart (stroke [] . fill []) combined2 = encChart (stroke [ MName "y", MmType Ordinal ] . fill [ MString "red" ]) combined3 = encChart (stroke [ MString "red" ] . fill [ MName "y", MmType Ordinal ]) geo1 :: VegaLite geo1 = let geojson = geoFeatureCollection [ geometry (GeoPolygon [ [ ( -2, 58 ), ( 3, 58 ), ( 3, 53 ), ( -2, 53 ), ( -2, 58 ) ] ]) [] , geometry (GeoLine [ ( 4, 52 ), ( 4, 59 ), ( -3, 59 ) ]) [] ] in toVegaLite [ width 300 , height 300 , dataFromJson geojson [] , mark Geoshape [] ] geo2 :: VegaLite geo2 = let geojson = geoFeatureCollection [ geometry (GeoPolygon [ [ ( -2, 58 ), ( 3, 58 ), ( 3, 53 ), ( -2, 53 ), ( -2, 58 ) ] ]) [] , geometry (GeoLine [ ( 4, 52 ), ( 4, 59 ), ( -3, 59 ) ]) [] ] -- NOTE: There is a bug in Vega-Lite that prevents nested geometry from being read correctly. enc = encoding . color [ MName "features.geometry.type", MmType Nominal ] in toVegaLite [ width 300 , height 300 , enc [] , dataFromJson geojson [] , mark Geoshape [] ] gradientTest :: PropertySpec -> VegaLite gradientTest markType = let dvals = dataFromColumns [] . dataColumn "cat" (Strings [ "a", "b", "c", "d" ]) . dataColumn "value" (Numbers [ 10, 5, 20, 8 ]) enc = encoding . position X [ PName "cat", PmType Nominal ] . position Y [ PName "value", PmType Quantitative ] in toVegaLite [ width 200, dvals [], enc [], markType ] gradient1 :: VegaLite gradient1 = let markType = mark Bar [ MColorGradient GrLinear stops opts ] stops = [ (0, "red"), (0.4, "orange"), (1, "blue") ] opts = [ GrX1 1 , GrX2 1 , GrY1 0 , GrY2 1 ] in gradientTest markType gradient2 :: VegaLite gradient2 = let markType = mark Bar [ MColorGradient GrLinear stops opts ] stops = [ (0, "red"), (1, "blue") ] opts = [ GrX1 0 , GrX2 1 , GrY1 1 , GrY2 1 ] in gradientTest markType gradient3 :: VegaLite gradient3 = let markType = mark Bar [ MColorGradient GrLinear stops opts ] stops = [ (1, "red"), (0, "blue") ] opts = [ GrX1 0 , GrX2 1 , GrY1 0 , GrY2 1 ] in gradientTest markType gradientr1 :: VegaLite gradientr1 = let markType = mark Circle [ MSize 1000 , MColorGradient GrRadial stops opts ] stops = [ (0, "red"), (0.5, "white"), (1, "blue") ] opts = [ ] in gradientTest markType -- these are the defaults, so they should be the same as r1 gradientr2 :: VegaLite gradientr2 = let markType = mark Circle [ MSize 1000 , MColorGradient GrRadial stops opts ] stops = [ (0, "red"), (1, "blue"), (0.5, "white") ] opts = [ GrX1 0.5 , GrX2 0.5 , GrY1 0.5 , GrY2 0.5 ] in gradientTest markType -- not sure if these options make sense, but they are valid according to -- the Vega-Lite 4.0.2 spec so leave them be. -- gradientr3 :: VegaLite gradientr3 = let markType = mark Circle [ MSize 1000 , MColorGradient GrRadial stops opts ] stops = [ (0, "red"), (1, "blue"), (0.5, "white") ] opts = [ GrX1 0.2 , GrX2 0.8 , GrY1 0.7 , GrY2 0.3 , GrR1 0.2 , GrR2 0.4 ] in gradientTest markType {- From https://vega.github.io/vega-lite/docs/bar.html#bar-chart-with-rounded-corners { "data": { "values": [ {"a": "A", "b": 28}, {"a": "B", "b": 55}, {"a": "C", "b": 43}, {"a": "D", "b": 91}, {"a": "E", "b": 81}, {"a": "F", "b": 53}, {"a": "G", "b": 19}, {"a": "H", "b": 87}, {"a": "I", "b": 52} ] }, "mark": {"type": "bar", "cornerRadiusEnd": 4}, "encoding": { "x": {"field": "a", "type": "ordinal"}, "y": {"field": "b", "type": "quantitative"} } } -} barData :: Value barData = [aesonQQ| [ {"a": "A", "b": 28}, {"a": "B", "b": 55}, {"a": "C", "b": 43}, {"a": "D", "b": 91}, {"a": "E", "b": 81}, {"a": "F", "b": 53}, {"a": "G", "b": 19}, {"a": "H", "b": 87}, {"a": "I", "b": 52} ] |] rounded :: Position -> Position -> VegaLite rounded h v = toVegaLite [ dataFromJson barData [] , mark Bar [ MCornerRadiusEnd 4 ] , encoding . position h [ PName "a", PmType Ordinal ] . position v [ PName "b", PmType Quantitative ] $ [] ] vrounded :: VegaLite vrounded = rounded X Y hrounded :: VegaLite hrounded = rounded Y X stockData :: Data stockData = dataFromUrl "https://vega.github.io/vega-lite/data/stocks.csv" [] xDate, yPrice :: BuildEncodingSpecs xDate = position X [ PName "date", PmType Temporal ] yPrice = position Y [ PName "price", PmType Quantitative ] strokeDashTest :: [MarkChannel] -> VegaLite strokeDashTest sOpts = let enc = encoding . xDate . yPrice . strokeDash ([ MName "symbol", MmType Nominal ] ++ sOpts) lineOpts = [MStrokeWidth 1, MOpacity 0.6] in toVegaLite [ width 350, stockData, enc [], mark Line lineOpts ] strokeDash1 :: VegaLite strokeDash1 = strokeDashTest [] strokeDash2 :: VegaLite strokeDash2 = strokeDashTest [ MScale [ SDomain (DStrings [ "AAPL", "AMZN", "GOOG", "IBM", "MSFT" ]) , SRange (RNumberLists [ [ 1, 0 ], [ 3, 1 ], [ 2, 3 ], [ 4, 4 ], [ 5, 6 ] ]) ] ] pName :: T.Text -> PositionChannel pName = PName mName :: T.Text -> MarkChannel mName = MName pQuant :: PositionChannel pQuant = PmType Quantitative mNominal, mOrdinal :: MarkChannel mNominal = MmType Nominal mOrdinal = MmType Ordinal sDash :: [MarkChannel] -> VegaLite sDash sdOpts = let dvals = dataFromColumns [] . toCol "x" [ 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1 ] . toCol "y" [ 100, 100, 90, 90, 80, 80, 70, 70, 60, 60, 50, 50, 40, 40, 30, 30, 20, 20, 10, 10 ] . toCol "cat" [ 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10 ] toCol l = dataColumn l . Numbers encBase = encoding . position X [ pName "x", pQuant ] . position Y [ pName "y", pQuant ] enc1 = encBase . strokeDash ([ mName "cat", mNominal ] ++ sdOpts) spec1 = asSpec [ title "Nominal" [], width 200, enc1 [], mark Line [] ] enc2 = encBase . strokeDash ([ mName "cat", mOrdinal ] ++ sdOpts) spec2 = asSpec [ title "Ordinal" [], width 200, enc2 [], mark Line [] ] res = resolve . resolution (RScale [ ( ChStrokeDash, Independent ) ]) cfg = configure . configuration (Axis [NoTitle, Grid False]) . configuration (LineStyle [MStrokeWidth 1, MColor "orange", MOpacity 0.6]) in toVegaLite [ dvals [], cfg [], res [], vlConcat [ spec1, spec2 ] ] d0, d1, d2, d3, d4, d5, d6, d7, d8, d9 :: [Double] d0 = [ 1, 0 ] d1 = [ 16, 4 ] d2 = [ 10, 4 ] d3 = [ 8, 4 ] d4 = [ 8, 4, 4, 4 ] d5 = [ 6, 4 ] d6 = [ 5, 4 ] d7 = [ 4, 6 ] d8 = [ 2, 4 ] d9 = [ 1, 3 ] strokeDash3, strokeDash4 :: VegaLite strokeDash3 = sDash [] strokeDash4 = sDash [ MScale [ SDomain (DNumbers [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]) , SRange (RNumberLists [d0, d6, d8, d4, d9, d1, d5, d3, d7, d2]) ] ] scaledStrokeDash :: Double -> VegaLite scaledStrokeDash dashScale = let scaleDash = map (map (dashScale *)) dvals = dataSequenceAs 0 100 0.1 "x0" trans = transform . calculateAs "abs(sin(datum.x0+random()))" "y0" . calculateAs "datum.x0 %10" "x" . calculateAs "floor(datum.x0 / 10)" "cat" . calculateAs "datum.y0 + datum.cat" "y" enc = encoding . position X [ pName "x", pQuant, PAxis [ AxGrid False ] ] . position Y [ pName "y", pQuant, PAxis [ AxGrid False ] ] . strokeDash [ mName "cat" , mOrdinal , MScale [ SDomain (DNumbers [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9 ]) , SRange (RNumberLists (scaleDash [ d0, d1, d2, d3, d4, d5, d6, d7, d8, d9 ])) ] ] in toVegaLite [ title ("Dash scale " <> T.pack (show dashScale)) [] , width 300 , height 300 , dvals , trans [] , enc [] , mark Line [] ] strokeDash5, strokeDash6, strokeDash7, strokeDash8, strokeDash9 :: VegaLite strokeDash5 = scaledStrokeDash 0.2 strokeDash6 = scaledStrokeDash 0.5 strokeDash7 = scaledStrokeDash 1 strokeDash8 = scaledStrokeDash 2 strokeDash9 = scaledStrokeDash 4