{-# language OverloadedStrings, DeriveGeneric, LambdaCase #-} {-# language CPP #-} {-| Module : RigelViz Description : Mid-level bindings to @vega-lite@ Copyright : (c) Marco Zocca, 2019 License : BSD3 Maintainer : ocramz fripost org Stability : experimental Portability : POSIX A (mid-level, simplified, opinionated) Haskell wrapper for [vega-lite](https://vega.github.io/vega-lite/), currently targeting version 3 of the @vega-lite@ schema. == Aims / definitions * mid-level : * types which can take one of a few possible values are represented by sum types, not by strings. * glyph colours are encoded via the @colour@ Haskell library. * simplified : the generated @vega-lite@ JSON is not normalized, i.e. has some redundancies. This reflects the internal representation but also makes it easier to reason "locally" (i.e. code sections don't visibly exploit inheritance from higher layers). * opinionated : part of the @vega-lite@ API is not used at all. For example, there is no support for data preprocessing (e.g. summarization etc.). This forces the user to use the host language for preprocessing, which is bound to be more expressive and robust. == Examples These examples require @lucid@ and @lucid-extras@ (> 0.2.2): @lucid@ provides @renderToFile@ and @lucid-extras@ provides @mkVegaHtml@. === Scatter plot <<doc/fig/scatter1.png>> @ render0 :: IO () render0 = 'renderToFile' "scatter.html" $ 'mkVegaHtml' $ 'A.toJSON' vls0 vls0 :: 'VLSpec' TestValue vls0 = 'vegaLiteSpec' 400 300 [ 'layer' 'MCircle' ('DataJSON' testVs) ( 'posEnc' 'X' "tv" 'Nominal' <> posEnc 'Y' "tvb" 'Quantitative' <> 'colourEnc' "tvb" Quantitative <> 'sizeEnc' "tvb" Quantitative ) ] data TestValue = TV { tv :: T, tvb :: Double } deriving (Eq, Show, Generic) instance A.ToJSON TestValue data T = A | B | C deriving (Eq, Show, Generic) instance A.ToJSON T testVs :: [TestValue] testVs = [TV A 3.2, TV B 5.4, TV A 2.2, TV A 6.7, TV B 4.9] @ === Heatmap <<doc/fig/heatmap1.png>> @ render0 :: IO () render0 = 'renderToFile' "heatmap.html" $ 'mkVegaHtml' $ 'A.toJSON' vls1 vls1 :: VLSpec (V3 Double) vls1 = vegaLiteSpec 400 400 [ layer 'MRect' (DataJSON dats) $ posEnc X "v3x" 'Ordinal' <> posEnc Y "v3y" Ordinal <> colourEnc "v3z" Quantitative <> sizeEnc "v3z" Quantitative data V3 a = V3 { v3x :: a, v3y :: a, v3z :: a } deriving (Eq, Show, Generic) instance A.ToJSON a => A.ToJSON (V3 a) dats :: [V3 Double] dats = [V3 x y (f x y) | x <- xs, y <- ys] where xs = map (/10) [0, 1 .. 20] ys = xs f x y = sin $ 2 * pi * sqrt (x ** 2 + y ** 2) @ -} module RigelViz ( vegaLiteSpec, VLSpec, -- * Data sources DataSource(..), -- * Layer layer, LayerMetadata, -- * Mark MarkType(..), -- * Data encoding options EncSet, posEnc, Pos(..), colourEnc, colour, size, sizeEnc, EncodingType(..)) where import qualified Data.Set as S import GHC.Generics (Generic(..)) import qualified Data.Aeson as A import Data.Aeson ((.=)) import Data.Char (toLower) import qualified Data.Text as T -- import qualified Data.Text.Encoding as T (decodeUtf8) -- import qualified Data.ByteString as BS hiding (pack) -- import qualified Data.ByteString.Lazy.Char8 as BS (unpack) -- import qualified Data.ByteString.Lazy as LBS (toStrict) -- import Data.Monoid import qualified Data.Colour as C import qualified Data.Colour.SRGB as C (sRGB24show) #if !MIN_VERSION_base(4,8,0) import Data.Semigroup #endif -- toJSONText :: A.ToJSON a => a -> T.Text -- toJSONText e = T.decodeUtf8 $ LBS.toStrict $ A.encode e -- | The current schema version is 3 schema :: Int -> String schema vn = mconcat ["https://vega.github.io/schema/vega-lite/v", show vn,".json"] -- | Create a @vega-lite@ spec vegaLiteSpec :: Int -- ^ Plot width -> Int -- ^ Plot height -> [LayerMetadata a] -> VLSpec a vegaLiteSpec = VLSpec -- | Specification of a vega-lite plot -- -- A 'VLSpec' can be encoded into a JSON blob via its 'A.ToJSON' instance. data VLSpec a = VLSpec { vlsWidth :: Int , vlsHeight :: Int , vlsView :: [LayerMetadata a] } deriving (Eq, Show, Generic) instance A.ToJSON a => A.ToJSON (VLSpec a) where toJSON (VLSpec w h lms) = A.object $ ("layer" .= map A.toJSON lms) : defs where defs = [ "$schema" .= schema 3 , "width" .= w , "height" .= h ] -- | Data source data DataSource a = DataJSON [a] -- ^ Data row type must have a 'A.ToJSON' instance | DataURI String -- ^ URI or filepath of dataset deriving (Eq, Show, Generic) instance A.ToJSON a => A.ToJSON (DataSource a) where toJSON = \case DataJSON vs -> A.object ["values" .= vs] DataURI u -> A.object ["url" .= u] -- | Plot layer data and encoding metadata data LayerMetadata a = LayerMD Mark (DataSource a) EncSet deriving (Eq, Show, Generic) instance A.ToJSON a => A.ToJSON (LayerMetadata a) where toJSON (LayerMD m ds e) = A.object ["mark" .= m, "encoding" .= e, "data" .= ds] -- | Declare a plot layer layer :: MarkType -> DataSource a -> EncSet -> LayerMetadata a layer m ds es = LayerMD (Mark m) ds es -- | Set of channel encoding options. -- -- Options are created with 'posEnc', 'colourEnc', 'colour', 'sizeEnc', 'size' and can be added to an 'EncSet' via its 'Semigroup' instance newtype EncSet = EncSet (S.Set Encoding) deriving (Eq, Show, Generic) instance A.ToJSON EncSet where toJSON (EncSet es) = A.object $ S.foldr insf [] es where insf el acc = case el of EsPos p emd -> (showPos p .= emd) : acc EsColour emd -> ("color" .= emd) : acc EsSize emd -> ("size" .= emd) : acc singleton :: Encoding -> EncSet singleton = EncSet . S.singleton instance Semigroup EncSet where (EncSet s1) <> (EncSet s2) = EncSet $ s1 <> s2 -- | Position encoding posEnc :: Pos -> T.Text -- ^ Field in the data source -> EncodingType -> EncSet posEnc p f t = singleton $ EsPos p $ EncMD f t -- | Fixed colour colour :: C.Colour Double -> EncSet colour c = singleton $ EsColour $ ColourFixed c -- | Colour encoding colourEnc :: T.Text -- ^ Field in the data source -> EncodingType -> EncSet colourEnc f t = singleton $ EsColour $ ColourEnc $ EncMD f t -- | Size encoding sizeEnc :: T.Text -- ^ Field in the data source -> EncodingType -> EncSet sizeEnc f t = singleton $ EsSize $ SizeEnc $ EncMD f t -- | Fixed size size :: Double -> EncSet size s = singleton $ EsSize $ SizeFixed s -- | Encoding channels for a layer data Encoding = EsPos Pos EncMetadata | EsColour Colour | EsSize Size deriving (Eq, Show, Ord, Generic) -- | Position encoding alternatives data Pos = X | Y | X2 | Y2 deriving (Eq, Ord, Show) showPos :: Pos -> T.Text showPos p = T.pack $ map toLower $ show p newtype Mark = Mark { mType :: MarkType } deriving (Eq, Show, Generic) instance A.ToJSON Mark where toJSON (Mark mty) = A.object ["type" .= mty] -- | Mark type alternatives data MarkType = MPoint -- ^ "point" | MCircle -- ^ "circle" | MRect -- ^ "rect" | MSquare -- ^ "square" | MBar -- ^ "bar" | MArea -- ^ "area" | MRule -- ^ "rule" | MLine -- ^ "line" deriving (Eq, Show, Generic) instance A.ToJSON MarkType where toJSON = \case MPoint -> "point" MCircle -> "circle" MRect -> "rect" MSquare -> "square" MBar -> "bar" MArea -> "area" MRule -> "rule" MLine -> "line" data EncMetadata = EncMD { encField :: T.Text, emType :: EncodingType } deriving (Eq, Show, Ord, Generic) instance A.ToJSON EncMetadata where toJSON (EncMD f t) = A.object [ "field" .= f, "type" .= t] -- | "colour" encoding channel metadata data Colour = ColourFixed (C.Colour Double) | ColourEnc EncMetadata deriving (Eq, Show, Generic) instance Ord Colour where ColourFixed c1 <= ColourFixed c2 = C.sRGB24show c1 <= C.sRGB24show c2 -- ewwwwwww ColourEnc e1 <= ColourEnc e2 = e1 <= e2 _ <= _ = False instance A.ToJSON Colour where toJSON = \case ColourFixed c -> A.object ["value" .= C.sRGB24show c] ColourEnc emd -> A.toJSON emd -- | "size" encoding channel metadata data Size = SizeFixed Double | SizeEnc EncMetadata deriving (Eq, Show, Ord, Generic) instance A.ToJSON Size where toJSON = \case SizeFixed sz -> A.object ["value" .= sz] SizeEnc emd -> A.toJSON emd -- | encoding type data EncodingType = Nominal | Quantitative | Temporal | Ordinal deriving (Eq, Show, Ord, Generic) instance A.ToJSON EncodingType where toJSON = \case Nominal -> "nominal" Quantitative -> "quantitative" Temporal -> "temporal" Ordinal -> "ordinal" {- { "$schema": "https://vega.github.io/schema/vega-lite/v3.json", "data": {"url": "data/movies.json"}, "transform": [{ "filter": {"and": [ {"field": "IMDB_Rating", "valid": true}, {"field": "Rotten_Tomatoes_Rating", "valid": true} ]} }], "mark": "rect", "width": 300, "height": 200, "encoding": { "x": { "bin": {"maxbins":60}, "field": "IMDB_Rating", "type": "quantitative" }, "y": { "bin": {"maxbins": 40}, "field": "Rotten_Tomatoes_Rating", "type": "quantitative" }, "color": { "aggregate": "count", "type": "quantitative" } }, "config": { "range": { "heatmap": { "scheme": "greenblue" } }, "view": { "stroke": "transparent" } } } -}