{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

{- |
Internal Vega-Lite spec model plus aeson encoding, shared by the web plot
backends. Not public. Channel encodings resolve to a 'ResolvedField' carrying
the field name, Vega-Lite type, and inlined column values.
-}
module DataFrame.Display.Internal.VegaLite (
    -- * Spec model
    Mark (..),
    Channel (..),
    FieldType (..),
    ChannelEnc (..),
    Sort (..),
    ScaleSpec (..),
    ScaleType (..),
    defaultScale,
    Transform (..),
    VLSpec (..),
    emptySpec,
    chanEnc,
    channelName,

    -- * Resolving expressions to fields
    ResolvedField (..),
    fieldTypeOf,
    resolveField,
    textField,
    numField,

    -- * Encoding to JSON / HTML
    specToValue,
    inlineRows,
    specHtml,
    rowCountWarning,
) where

import qualified Control.Monad
import Data.Aeson (ToJSON (toJSON), Value (Null), object, (.=))
import qualified Data.Aeson.Key as K
import Data.Aeson.Text (encodeToLazyText)
import qualified Data.List as L
import Data.Maybe (catMaybes, fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Vector as V
import System.IO (hPutStrLn, stderr)
import Type.Reflection (TypeRep, tyConName, typeRep, typeRepTyCon, pattern App)

import DataFrame.Internal.Column (Column, Columnable, unwrapTypedColumn)
import DataFrame.Internal.DataFrame (DataFrame, getColumn)
import DataFrame.Internal.Expression (Expr (Col))
import DataFrame.Internal.Interpreter (interpret)

import DataFrame.Display.Internal.Common (columnToDoubles, columnToStrings)

-- ---------------------------------------------------------------------------
-- Spec model
-- ---------------------------------------------------------------------------

data Mark = Bar | Line | Point | Area | Boxplot | Arc | Rule | Tick
    deriving (Mark -> Mark -> Bool
(Mark -> Mark -> Bool) -> (Mark -> Mark -> Bool) -> Eq Mark
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mark -> Mark -> Bool
== :: Mark -> Mark -> Bool
$c/= :: Mark -> Mark -> Bool
/= :: Mark -> Mark -> Bool
Eq, Int -> Mark -> ShowS
[Mark] -> ShowS
Mark -> [Char]
(Int -> Mark -> ShowS)
-> (Mark -> [Char]) -> ([Mark] -> ShowS) -> Show Mark
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mark -> ShowS
showsPrec :: Int -> Mark -> ShowS
$cshow :: Mark -> [Char]
show :: Mark -> [Char]
$cshowList :: [Mark] -> ShowS
showList :: [Mark] -> ShowS
Show)

markName :: Mark -> T.Text
markName :: Mark -> Text
markName Mark
m = case Mark
m of
    Mark
Bar -> Text
"bar"
    Mark
Line -> Text
"line"
    Mark
Point -> Text
"point"
    Mark
Area -> Text
"area"
    Mark
Boxplot -> Text
"boxplot"
    Mark
Arc -> Text
"arc"
    Mark
Rule -> Text
"rule"
    Mark
Tick -> Text
"tick"

data Channel
    = X
    | Y
    | Color
    | Size
    | Shape
    | Column
    | Row
    | Opacity
    | Theta
    | Tooltip
    | Order
    deriving (Channel -> Channel -> Bool
(Channel -> Channel -> Bool)
-> (Channel -> Channel -> Bool) -> Eq Channel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Channel -> Channel -> Bool
== :: Channel -> Channel -> Bool
$c/= :: Channel -> Channel -> Bool
/= :: Channel -> Channel -> Bool
Eq, Int -> Channel -> ShowS
[Channel] -> ShowS
Channel -> [Char]
(Int -> Channel -> ShowS)
-> (Channel -> [Char]) -> ([Channel] -> ShowS) -> Show Channel
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Channel -> ShowS
showsPrec :: Int -> Channel -> ShowS
$cshow :: Channel -> [Char]
show :: Channel -> [Char]
$cshowList :: [Channel] -> ShowS
showList :: [Channel] -> ShowS
Show)

channelName :: Channel -> T.Text
channelName :: Channel -> Text
channelName Channel
c = case Channel
c of
    Channel
X -> Text
"x"
    Channel
Y -> Text
"y"
    Channel
Color -> Text
"color"
    Channel
Size -> Text
"size"
    Channel
Shape -> Text
"shape"
    Channel
Column -> Text
"column"
    Channel
Row -> Text
"row"
    Channel
Opacity -> Text
"opacity"
    Channel
Theta -> Text
"theta"
    Channel
Tooltip -> Text
"tooltip"
    Channel
Order -> Text
"order"

data FieldType = Quantitative | Nominal | Ordinal | Temporal
    deriving (FieldType -> FieldType -> Bool
(FieldType -> FieldType -> Bool)
-> (FieldType -> FieldType -> Bool) -> Eq FieldType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldType -> FieldType -> Bool
== :: FieldType -> FieldType -> Bool
$c/= :: FieldType -> FieldType -> Bool
/= :: FieldType -> FieldType -> Bool
Eq, Int -> FieldType -> ShowS
[FieldType] -> ShowS
FieldType -> [Char]
(Int -> FieldType -> ShowS)
-> (FieldType -> [Char])
-> ([FieldType] -> ShowS)
-> Show FieldType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldType -> ShowS
showsPrec :: Int -> FieldType -> ShowS
$cshow :: FieldType -> [Char]
show :: FieldType -> [Char]
$cshowList :: [FieldType] -> ShowS
showList :: [FieldType] -> ShowS
Show)

fieldTypeName :: FieldType -> T.Text
fieldTypeName :: FieldType -> Text
fieldTypeName FieldType
t = case FieldType
t of
    FieldType
Quantitative -> Text
"quantitative"
    FieldType
Nominal -> Text
"nominal"
    FieldType
Ordinal -> Text
"ordinal"
    FieldType
Temporal -> Text
"temporal"

{- | A single channel encoding. An empty 'ceField' with a 'ceAggregate' of
@count@ produces a fieldless count aggregation, as Vega-Lite expects.
-}
data ChannelEnc = ChannelEnc
    { ChannelEnc -> Channel
ceChannel :: Channel
    , ChannelEnc -> Text
ceField :: T.Text
    , ChannelEnc -> FieldType
ceType :: FieldType
    , ChannelEnc -> Maybe Text
ceAggregate :: Maybe T.Text
    , ChannelEnc -> Bool
ceBin :: Bool
    , ChannelEnc -> ScaleSpec
ceScale :: ScaleSpec
    , ChannelEnc -> Maybe Sort
ceSort :: Maybe Sort
    }

-- | A bare channel encoding with no aggregation, binning, scale, or sort options.
chanEnc :: Channel -> T.Text -> FieldType -> ChannelEnc
chanEnc :: Channel -> Text -> FieldType -> ChannelEnc
chanEnc Channel
ch Text
fld FieldType
ft = Channel
-> Text
-> FieldType
-> Maybe Text
-> Bool
-> ScaleSpec
-> Maybe Sort
-> ChannelEnc
ChannelEnc Channel
ch Text
fld FieldType
ft Maybe Text
forall a. Maybe a
Nothing Bool
False ScaleSpec
defaultScale Maybe Sort
forall a. Maybe a
Nothing

{- | Domain ordering for a discrete channel, mirroring Vega-Lite's @sort@.
'DataOrder' pins the axis to the order rows appear in the inlined data, so
pre-sorted values (e.g. histogram bins) display in that order.
-}
data Sort = DataOrder
    deriving (Sort -> Sort -> Bool
(Sort -> Sort -> Bool) -> (Sort -> Sort -> Bool) -> Eq Sort
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Sort -> Sort -> Bool
== :: Sort -> Sort -> Bool
$c/= :: Sort -> Sort -> Bool
/= :: Sort -> Sort -> Bool
Eq, Int -> Sort -> ShowS
[Sort] -> ShowS
Sort -> [Char]
(Int -> Sort -> ShowS)
-> (Sort -> [Char]) -> ([Sort] -> ShowS) -> Show Sort
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Sort -> ShowS
showsPrec :: Int -> Sort -> ShowS
$cshow :: Sort -> [Char]
show :: Sort -> [Char]
$cshowList :: [Sort] -> ShowS
showList :: [Sort] -> ShowS
Show)

{- | Per-channel scale configuration, mirroring Vega-Lite's @scale@ object.
'Nothing' fields leave the Vega-Lite default in place; grow this record
(domain, nice, clamp, scheme, ...) as the public vocabulary grows.
-}
data ScaleSpec = ScaleSpec
    { ScaleSpec -> Maybe ScaleType
scaleType :: Maybe ScaleType
    , ScaleSpec -> Maybe Bool
scaleZero :: Maybe Bool
    }
    deriving (ScaleSpec -> ScaleSpec -> Bool
(ScaleSpec -> ScaleSpec -> Bool)
-> (ScaleSpec -> ScaleSpec -> Bool) -> Eq ScaleSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScaleSpec -> ScaleSpec -> Bool
== :: ScaleSpec -> ScaleSpec -> Bool
$c/= :: ScaleSpec -> ScaleSpec -> Bool
/= :: ScaleSpec -> ScaleSpec -> Bool
Eq, Int -> ScaleSpec -> ShowS
[ScaleSpec] -> ShowS
ScaleSpec -> [Char]
(Int -> ScaleSpec -> ShowS)
-> (ScaleSpec -> [Char])
-> ([ScaleSpec] -> ShowS)
-> Show ScaleSpec
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScaleSpec -> ShowS
showsPrec :: Int -> ScaleSpec -> ShowS
$cshow :: ScaleSpec -> [Char]
show :: ScaleSpec -> [Char]
$cshowList :: [ScaleSpec] -> ShowS
showList :: [ScaleSpec] -> ShowS
Show)

data ScaleType = LogS
    deriving (ScaleType -> ScaleType -> Bool
(ScaleType -> ScaleType -> Bool)
-> (ScaleType -> ScaleType -> Bool) -> Eq ScaleType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScaleType -> ScaleType -> Bool
== :: ScaleType -> ScaleType -> Bool
$c/= :: ScaleType -> ScaleType -> Bool
/= :: ScaleType -> ScaleType -> Bool
Eq, Int -> ScaleType -> ShowS
[ScaleType] -> ShowS
ScaleType -> [Char]
(Int -> ScaleType -> ShowS)
-> (ScaleType -> [Char])
-> ([ScaleType] -> ShowS)
-> Show ScaleType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScaleType -> ShowS
showsPrec :: Int -> ScaleType -> ShowS
$cshow :: ScaleType -> [Char]
show :: ScaleType -> [Char]
$cshowList :: [ScaleType] -> ShowS
showList :: [ScaleType] -> ShowS
Show)

defaultScale :: ScaleSpec
defaultScale :: ScaleSpec
defaultScale = Maybe ScaleType -> Maybe Bool -> ScaleSpec
ScaleSpec Maybe ScaleType
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing

data Transform
    = -- | Fit @regression(yField) on xField@ (used inside a layer).
      RegressionT T.Text T.Text
    | -- | Kernel-density estimate of a field.
      DensityT T.Text
    deriving (Transform -> Transform -> Bool
(Transform -> Transform -> Bool)
-> (Transform -> Transform -> Bool) -> Eq Transform
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Transform -> Transform -> Bool
== :: Transform -> Transform -> Bool
$c/= :: Transform -> Transform -> Bool
/= :: Transform -> Transform -> Bool
Eq, Int -> Transform -> ShowS
[Transform] -> ShowS
Transform -> [Char]
(Int -> Transform -> ShowS)
-> (Transform -> [Char])
-> ([Transform] -> ShowS)
-> Show Transform
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Transform -> ShowS
showsPrec :: Int -> Transform -> ShowS
$cshow :: Transform -> [Char]
show :: Transform -> [Char]
$cshowList :: [Transform] -> ShowS
showList :: [Transform] -> ShowS
Show)

{- | A Vega-Lite spec. When 'vlLayers' is non-empty the spec is a layered
container: the top level carries the shared data and each layer carries its own
mark/encoding/transform.
-}
data VLSpec = VLSpec
    { VLSpec -> Mark
vlMark :: Mark
    , VLSpec -> [ChannelEnc]
vlEncodings :: [ChannelEnc]
    , VLSpec -> [Transform]
vlTransforms :: [Transform]
    , VLSpec -> Maybe Text
vlTitle :: Maybe T.Text
    , VLSpec -> Int
vlWidth :: Int
    , VLSpec -> Int
vlHeight :: Int
    , VLSpec -> [VLSpec]
vlLayers :: [VLSpec]
    }

emptySpec :: Mark -> VLSpec
emptySpec :: Mark -> VLSpec
emptySpec Mark
m = Mark
-> [ChannelEnc]
-> [Transform]
-> Maybe Text
-> Int
-> Int
-> [VLSpec]
-> VLSpec
VLSpec Mark
m [] [] Maybe Text
forall a. Maybe a
Nothing Int
600 Int
400 []

-- ---------------------------------------------------------------------------
-- Field-type inference from the expression's element type
-- ---------------------------------------------------------------------------

{- | Derive the Vega-Lite field type from a Haskell type: numeric →
'Quantitative', date/time → 'Temporal', everything else → 'Nominal'. @Maybe a@
classifies as its inner type.
-}
fieldTypeOf :: forall a. (Columnable a) => FieldType
fieldTypeOf :: forall a. Columnable a => FieldType
fieldTypeOf = TypeRep a -> FieldType
forall k (x :: k). TypeRep x -> FieldType
classify (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a)

classify :: forall k (x :: k). TypeRep x -> FieldType
classify :: forall k (x :: k). TypeRep x -> FieldType
classify TypeRep x
tr
    | [Char]
nm [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
quantNames = FieldType
Quantitative
    | [Char]
nm [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
temporalNames = FieldType
Temporal
    | [Char]
nm [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"Maybe" = case TypeRep x
tr of
        App TypeRep a
_ TypeRep b
arg -> TypeRep b -> FieldType
forall k (x :: k). TypeRep x -> FieldType
classify TypeRep b
arg
        TypeRep x
_ -> FieldType
Nominal
    | Bool
otherwise = FieldType
Nominal
  where
    nm :: [Char]
nm = TyCon -> [Char]
tyConName (TypeRep x -> TyCon
forall {k} (a :: k). TypeRep a -> TyCon
typeRepTyCon TypeRep x
tr)
    quantNames :: [[Char]]
quantNames =
        [ [Char]
"Int"
        , [Char]
"Int8"
        , [Char]
"Int16"
        , [Char]
"Int32"
        , [Char]
"Int64"
        , [Char]
"Word"
        , [Char]
"Word8"
        , [Char]
"Word16"
        , [Char]
"Word32"
        , [Char]
"Word64"
        , [Char]
"Integer"
        , [Char]
"Natural"
        , [Char]
"Double"
        , [Char]
"Float"
        , [Char]
"Scientific"
        ]
    temporalNames :: [[Char]]
temporalNames =
        [[Char]
"Day", [Char]
"UTCTime", [Char]
"LocalTime", [Char]
"ZonedTime", [Char]
"TimeOfDay"]

-- ---------------------------------------------------------------------------
-- Resolving an expression to a field + values
-- ---------------------------------------------------------------------------

data ResolvedField = ResolvedField
    { ResolvedField -> Text
rfName :: T.Text
    , ResolvedField -> FieldType
rfType :: FieldType
    , ResolvedField -> [Value]
rfValues :: [Value]
    }

{- | Resolve an expression against a frame. A bare @Col name@ reuses the named
column; any other expression is materialised with the core interpreter and
stored under the given fallback name.
-}
resolveField ::
    forall a. (Columnable a) => DataFrame -> T.Text -> Expr a -> ResolvedField
resolveField :: forall a.
Columnable a =>
DataFrame -> Text -> Expr a -> ResolvedField
resolveField DataFrame
df Text
fallbackName Expr a
expr =
    let ft :: FieldType
ft = forall a. Columnable a => FieldType
fieldTypeOf @a
        (Text
name, Column
col) = case Expr a
expr of
            Col Text
cname -> (Text
cname, Text -> Column
lookupCol Text
cname)
            Expr a
_ -> (Text
fallbackName, DataFrame -> Expr a -> Column
forall a. Columnable a => DataFrame -> Expr a -> Column
materialiseExpr DataFrame
df Expr a
expr)
     in Text -> FieldType -> [Value] -> ResolvedField
ResolvedField Text
name FieldType
ft (FieldType -> Column -> [Value]
columnToValues FieldType
ft Column
col)
  where
    lookupCol :: Text -> Column
lookupCol Text
cname = case Text -> DataFrame -> Maybe Column
getColumn Text
cname DataFrame
df of
        Just Column
c -> Column
c
        Maybe Column
Nothing ->
            [Char] -> Column
forall a. HasCallStack => [Char] -> a
error ([Char] -> Column) -> [Char] -> Column
forall a b. (a -> b) -> a -> b
$ [Char]
"DataFrame.Display.Web: column not found: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
cname

materialiseExpr :: (Columnable a) => DataFrame -> Expr a -> Column
materialiseExpr :: forall a. Columnable a => DataFrame -> Expr a -> Column
materialiseExpr DataFrame
df Expr a
expr = case DataFrame -> Expr a -> Either DataFrameException (TypedColumn a)
forall a.
Columnable a =>
DataFrame -> Expr a -> Either DataFrameException (TypedColumn a)
interpret DataFrame
df Expr a
expr of
    Right TypedColumn a
tc -> TypedColumn a -> Column
forall a. TypedColumn a -> Column
unwrapTypedColumn TypedColumn a
tc
    Left DataFrameException
err ->
        [Char] -> Column
forall a. HasCallStack => [Char] -> a
error ([Char] -> Column) -> [Char] -> Column
forall a b. (a -> b) -> a -> b
$ [Char]
"DataFrame.Display.Web: could not evaluate expression: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> DataFrameException -> [Char]
forall a. Show a => a -> [Char]
show DataFrameException
err

columnToValues :: FieldType -> Column -> [Value]
columnToValues :: FieldType -> Column -> [Value]
columnToValues FieldType
Quantitative Column
col = (Double -> Value) -> [Double] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Value
forall a. ToJSON a => a -> Value
toJSON (HasCallStack => Column -> [Double]
Column -> [Double]
columnToDoubles Column
col)
columnToValues FieldType
_ Column
col = (Text -> Value) -> [Text] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Value
forall a. ToJSON a => a -> Value
toJSON :: T.Text -> Value) (HasCallStack => Column -> [Text]
Column -> [Text]
columnToStrings Column
col)

-- | A nominal field built directly from text values (for pre-computed data).
textField :: T.Text -> [T.Text] -> ResolvedField
textField :: Text -> [Text] -> ResolvedField
textField Text
name [Text]
vals = Text -> FieldType -> [Value] -> ResolvedField
ResolvedField Text
name FieldType
Nominal ((Text -> Value) -> [Text] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Value
forall a. ToJSON a => a -> Value
toJSON :: T.Text -> Value) [Text]
vals)

-- | A quantitative field built directly from numeric values (for pre-computed data).
numField :: T.Text -> [Double] -> ResolvedField
numField :: Text -> [Double] -> ResolvedField
numField Text
name [Double]
vals = Text -> FieldType -> [Value] -> ResolvedField
ResolvedField Text
name FieldType
Quantitative ((Double -> Value) -> [Double] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Value
forall a. ToJSON a => a -> Value
toJSON [Double]
vals)

-- ---------------------------------------------------------------------------
-- Encoding to JSON
-- ---------------------------------------------------------------------------

schemaUrl :: T.Text
schemaUrl :: Text
schemaUrl = Text
"https://vega.github.io/schema/vega-lite/v5.json"

specToValue :: [ResolvedField] -> VLSpec -> Value
specToValue :: [ResolvedField] -> VLSpec -> Value
specToValue [ResolvedField]
fields VLSpec
spec
    | [VLSpec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (VLSpec -> [VLSpec]
vlLayers VLSpec
spec) =
        [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
            [Pair]
commonPairs [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ VLSpec -> [Pair]
unitPairs VLSpec
spec
    | Bool
otherwise =
        [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
            [Pair]
commonPairs [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [(Key
"layer", [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ((VLSpec -> Value) -> [VLSpec] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ([Pair] -> Value
object ([Pair] -> Value) -> (VLSpec -> [Pair]) -> VLSpec -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VLSpec -> [Pair]
unitPairs) (VLSpec -> [VLSpec]
vlLayers VLSpec
spec)))]
  where
    commonPairs :: [Pair]
commonPairs =
        [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
            [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"$schema" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
schemaUrl)
            , (Text -> Pair) -> Maybe Text -> Maybe Pair
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"title" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (VLSpec -> Maybe Text
vlTitle VLSpec
spec)
            , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"width" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VLSpec -> Int
vlWidth VLSpec
spec)
            , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"height" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VLSpec -> Int
vlHeight VLSpec
spec)
            , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"data" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Key
"values" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [ResolvedField] -> Value
inlineRows [ResolvedField]
fields])
            ]

-- | The mark/encoding/transform pairs of a unit spec (no data — that is shared).
unitPairs :: VLSpec -> [(K.Key, Value)]
unitPairs :: VLSpec -> [Pair]
unitPairs VLSpec
spec =
    [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
        [ if [Transform] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (VLSpec -> [Transform]
vlTransforms VLSpec
spec)
            then Maybe Pair
forall a. Maybe a
Nothing
            else Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"transform" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Transform -> Value) -> [Transform] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Transform -> Value
transformValue (VLSpec -> [Transform]
vlTransforms VLSpec
spec))
        , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"mark" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Mark -> Value
markValue (VLSpec -> Mark
vlMark VLSpec
spec))
        , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"encoding" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [ChannelEnc] -> Value
encodingValue (VLSpec -> [ChannelEnc]
vlEncodings VLSpec
spec))
        ]

markValue :: Mark -> Value
markValue :: Mark -> Value
markValue Mark
m = [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Mark -> Text
markName Mark
m, Key
"tooltip" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
True]

encodingValue :: [ChannelEnc] -> Value
encodingValue :: [ChannelEnc] -> Value
encodingValue [ChannelEnc]
encs =
    [Pair] -> Value
object [Text -> Key
K.fromText (Channel -> Text
channelName (ChannelEnc -> Channel
ceChannel ChannelEnc
e)) Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ChannelEnc -> Value
channelValue ChannelEnc
e | ChannelEnc
e <- [ChannelEnc]
encs]

channelValue :: ChannelEnc -> Value
channelValue :: ChannelEnc -> Value
channelValue ChannelEnc
e =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
        [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
            [ if Text -> Bool
T.null (ChannelEnc -> Text
ceField ChannelEnc
e) then Maybe Pair
forall a. Maybe a
Nothing else Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"field" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ChannelEnc -> Text
ceField ChannelEnc
e)
            , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= FieldType -> Text
fieldTypeName (ChannelEnc -> FieldType
ceType ChannelEnc
e))
            , (Text -> Pair) -> Maybe Text -> Maybe Pair
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"aggregate" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (ChannelEnc -> Maybe Text
ceAggregate ChannelEnc
e)
            , if ChannelEnc -> Bool
ceBin ChannelEnc
e then Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"bin" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
True) else Maybe Pair
forall a. Maybe a
Nothing
            , (Value -> Pair) -> Maybe Value -> Maybe Pair
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"scale" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (ScaleSpec -> Maybe Value
scaleValue (ChannelEnc -> ScaleSpec
ceScale ChannelEnc
e))
            , (Key
"sort" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Value -> Pair) -> (Sort -> Value) -> Sort -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sort -> Value
sortValue (Sort -> Pair) -> Maybe Sort -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChannelEnc -> Maybe Sort
ceSort ChannelEnc
e
            ]

-- | Render a sort spec to its Vega-Lite JSON value.
sortValue :: Sort -> Value
sortValue :: Sort -> Value
sortValue Sort
DataOrder = Value
Null

-- | Render a scale spec, or 'Nothing' when every field is at its default.
scaleValue :: ScaleSpec -> Maybe Value
scaleValue :: ScaleSpec -> Maybe Value
scaleValue ScaleSpec
s
    | [Pair] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair]
pairs = Maybe Value
forall a. Maybe a
Nothing
    | Bool
otherwise = Value -> Maybe Value
forall a. a -> Maybe a
Just ([Pair] -> Value
object [Pair]
pairs)
  where
    pairs :: [Pair]
pairs =
        [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
            [ (ScaleType -> Pair) -> Maybe ScaleType -> Maybe Pair
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Text -> Pair) -> (ScaleType -> Text) -> ScaleType -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScaleType -> Text
scaleTypeName) (ScaleSpec -> Maybe ScaleType
scaleType ScaleSpec
s)
            , (Bool -> Pair) -> Maybe Bool -> Maybe Pair
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"zero" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (ScaleSpec -> Maybe Bool
scaleZero ScaleSpec
s)
            ]

scaleTypeName :: ScaleType -> T.Text
scaleTypeName :: ScaleType -> Text
scaleTypeName ScaleType
LogS = Text
"log"

transformValue :: Transform -> Value
transformValue :: Transform -> Value
transformValue (RegressionT Text
yField Text
xField) =
    [Pair] -> Value
object [Key
"regression" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
yField, Key
"on" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
xField]
transformValue (DensityT Text
field) =
    [Pair] -> Value
object [Key
"density" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
field]

-- | Build the @data.values@ array of row objects, deduplicating fields by name.
inlineRows :: [ResolvedField] -> Value
inlineRows :: [ResolvedField] -> Value
inlineRows [ResolvedField]
fields =
    let uniq :: [ResolvedField]
uniq = (ResolvedField -> ResolvedField -> Bool)
-> [ResolvedField] -> [ResolvedField]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (\ResolvedField
a ResolvedField
b -> ResolvedField -> Text
rfName ResolvedField
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== ResolvedField -> Text
rfName ResolvedField
b) [ResolvedField]
fields
        vecs :: [(Text, Vector Value)]
vecs = [(ResolvedField -> Text
rfName ResolvedField
f, [Value] -> Vector Value
forall a. [a] -> Vector a
V.fromList (ResolvedField -> [Value]
rfValues ResolvedField
f)) | ResolvedField
f <- [ResolvedField]
uniq]
        n :: Int
n = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((Text, Vector Value) -> Int) -> [(Text, Vector Value)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Vector Value -> Int
forall a. Vector a -> Int
V.length (Vector Value -> Int)
-> ((Text, Vector Value) -> Vector Value)
-> (Text, Vector Value)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Vector Value) -> Vector Value
forall a b. (a, b) -> b
snd) [(Text, Vector Value)]
vecs)
        row :: Int -> Value
row Int
i = [Pair] -> Value
object [Text -> Key
K.fromText Text
nm Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Vector Value
vs Vector Value -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
V.!? Int
i) | (Text
nm, Vector Value
vs) <- [(Text, Vector Value)]
vecs]
     in [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [Int -> Value
row Int
i | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

-- ---------------------------------------------------------------------------
-- HTML embedding (vega-embed via CDN)
-- ---------------------------------------------------------------------------

{- | Render a spec to a self-contained HTML snippet that loads vega/vega-lite/
vega-embed from a CDN and embeds the chart. Data is inlined, so the snippet
renders correctly even from a @file://@ URL.
-}
specHtml :: T.Text -> [ResolvedField] -> VLSpec -> T.Text
specHtml :: Text -> [ResolvedField] -> VLSpec -> Text
specHtml Text
chartId [ResolvedField]
fields VLSpec
spec =
    let specJson :: Text
specJson = LazyText -> Text
TL.toStrict (Value -> LazyText
forall a. ToJSON a => a -> LazyText
encodeToLazyText ([ResolvedField] -> VLSpec -> Value
specToValue [ResolvedField]
fields VLSpec
spec))
     in [Text] -> Text
T.concat
            [ Text
"<div id=\""
            , Text
chartId
            , Text
"\"></div>\n"
            , Text
"<script src=\"https://cdn.jsdelivr.net/npm/vega@5\"></script>\n"
            , Text
"<script src=\"https://cdn.jsdelivr.net/npm/vega-lite@5\"></script>\n"
            , Text
"<script src=\"https://cdn.jsdelivr.net/npm/vega-embed@6\"></script>\n"
            , Text
"<script>vegaEmbed('#"
            , Text
chartId
            , Text
"', "
            , Text
specJson
            , Text
");</script>\n"
            ]

{- | Warn on stderr when a large number of rows is being inlined, which bloats
the spec and can slow the browser.
-}
rowCountWarning :: [ResolvedField] -> IO ()
rowCountWarning :: [ResolvedField] -> IO ()
rowCountWarning [ResolvedField]
fields = do
    let n :: Int
n = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (ResolvedField -> Int) -> [ResolvedField] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Value] -> Int)
-> (ResolvedField -> [Value]) -> ResolvedField -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedField -> [Value]
rfValues) [ResolvedField]
fields)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5000) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Char]
"DataFrame.Display.Web: inlining "
                [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
                [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" rows into the plot spec; consider filtering or aggregating first."