diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,60 @@ # Revision history for granite +## 0.5.0.0 -- 2026-05-13 + +A major refactor introducing a declarative, Grammar-of-Graphics-style +IR shared between the terminal and SVG backends. Legacy chart +functions (`scatter`, `bars`, `pie`, …) remain unchanged and continue +to work; the new IR is additive. + +* New module `Granite.Spec` exposing the chart IR: `Chart`, `Layer`, + `Mapping`, `Geom`, `Stat`, `Position`, `Scale`, `Coord`, `Facet`, + `Theme`, `Size`, `ColorSpec`, `Formatter`. All types are plain ADTs + of basic Haskell types so a downstream user can derive `ToJSON` / + `FromJSON` instances with the JSON library of their choice. Granite + itself ships no JSON instances; the dependency footprint remains + `base + text`. +* New module `Granite.Data.Frame` providing a column-oriented + `DataFrame` (`ColNum`, `ColCat`, `ColTime`, `ColBool`). +* New module `Granite.Format` with a declarative `Formatter` enum + (`FormatPrecision`, `FormatScientific`, `FormatPercent`, + `FormatComma`, `FormatSI`, …). Replaces the function-typed + `LabelFormatter` for IR users; legacy `Plot { xFormatter, yFormatter }` + remains in place. +* New module `Granite.Scale` with linear, log (base 2/e/10), sqrt, + reverse, and identity scales, plus Heckbert-style "nice" tick + selection. (Talbot–Lin–Hanrahan "Extended" tick scoring is a future + upgrade — see the source for the TODO.) +* New module `Granite.Render.Scene` with backend-agnostic primitive + marks: `MCircle`, `MRect`, `MPolyline`, `MPath`, `MText`, `MArc`, + `MGroup`. Both backends consume the same `Scene`. +* New module `Granite.Render.Terminal` with the unified terminal + backend. The Braille canvas and AVL-backed `Array2D` were extracted + from `Granite` and now power both the legacy chart functions and + the new IR pipeline. +* New module `Granite.Render.Svg` with the unified SVG backend. + `renderSceneResponsive` produces SVG using `viewBox` + + `preserveAspectRatio` + `width="100%"` so charts embed responsively. +* New module `Granite.Render.Chrome` with axes, ticks, gridlines, + title, and legend as primitive marks — chrome code is no longer + duplicated between backends. +* New module `Granite.Render.Pipeline` exposing `chartToScene`, + `renderChartTerminal`, and `renderChartSvg`. Phase 3 supports the + cartesian path with identity stat and identity position. Polar + coord, facets, stats, positions, ribbons / errorbars, and multi- + chart figures are scheduled for later releases. +* New module `Granite.Chart` with thin builders (`scatterChart`, + `lineChart`) that construct an IR `Chart` from the same input shapes + the legacy chart functions accept. +* New module `Granite.Color` extracted from `Granite`; exports the + ANSI palette, ANSI escape helpers, and hex mapping. +* New module `Granite.Internal.Util` with the shared numeric, list, + text, and tick helpers that used to live (duplicated) in both + `Granite` and `Granite.Svg`. +* `ColorSpec` adds `RGB` and `Hex` constructors for cross-renderer + color fidelity, with terminal backends quantising to the nearest + ANSI color. + ## 0.4.0.0 -- 2026-02-27 * Add Svg support. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,6 @@ # Granite -A library for producing terminal plots. It depends only on Haskell's base and text (only for efficiency but it could use `String`. In fact, we expose an API that uses `String` for easier use in GHCi) packages so it should be easy to use and install. +A library for producing terminal and SVG plots. It depends only on Haskell's +`base` and `text` packages so it stays easy to install in any environment. # Supported graph types diff --git a/app/GenerateTutorial.hs b/app/GenerateTutorial.hs new file mode 100644 --- /dev/null +++ b/app/GenerateTutorial.hs @@ -0,0 +1,796 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Regenerate @docs/tutorial.md@ from @docs/base/tutorial.md@ by +rendering each @\@ marker to an SVG under +@docs/images/@ and inserting the image link after the code block. +-} +module Main where + +import Control.Monad (forM_) +import Data.List qualified as List +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) + +import Granite.Color (Color (..)) +import Granite.Data.Frame +import Granite.Render.Pipeline (renderChartSvg) +import Granite.Spec + +baseFile, outputFile, imagesDir :: FilePath +baseFile = "docs/base/tutorial.md" +outputFile = "docs/tutorial.md" +imagesDir = "docs/images" + +main :: IO () +main = do + createDirectoryIfMissing True imagesDir + src <- Text.IO.readFile baseFile + let rendered = renderTutorial src + Text.IO.writeFile outputFile rendered + forM_ fixtures $ \(slug, chart) -> do + let svgPath = imagesDir Text.unpack slug <> ".svg" + Text.IO.writeFile svgPath (renderChartSvg chart) + putStrLn $ "Wrote " <> outputFile + putStrLn $ "Wrote " <> show (length fixtures) <> " SVGs under " <> imagesDir + +renderTutorial :: Text -> Text +renderTutorial src = Text.unlines (go (Text.lines src)) + where + go :: [Text] -> [Text] + go [] = [] + go (line : rest) = case chartSlug line of + Just slug -> + let (block, afterBlock) = takeCodeBlock rest + output = renderChartOutput slug + in line : block <> output <> go afterBlock + Nothing -> line : go rest + +chartSlug :: Text -> Maybe Text +chartSlug ln = + let stripped = Text.strip ln + in case Text.stripPrefix "" (Text.strip rest) of + Just slug -> Just (Text.strip slug) + Nothing -> Nothing + Nothing -> Nothing + +takeCodeBlock :: [Text] -> ([Text], [Text]) +takeCodeBlock = goOpen [] + where + goOpen acc [] = (reverse acc, []) + goOpen acc (ln : rest) + | Text.isPrefixOf "```" (Text.stripStart ln) = + goClose (ln : acc) rest + | otherwise = goOpen (ln : acc) rest + + goClose acc [] = (reverse acc, []) + goClose acc (ln : rest) + | Text.isPrefixOf "```" (Text.stripStart ln) = + (reverse (ln : acc), rest) + | otherwise = goClose (ln : acc) rest + +renderChartOutput :: Text -> [Text] +renderChartOutput slug = case lookup slug fixtures of + Nothing -> + [ "" + , "> _(no fixture for chart slug `" <> slug <> "` — skipped)_" + ] + Just _chart -> + let imgRel = "images/" <> slug <> ".svg" + in [ "" + , "![" <> slug <> "](" <> imgRel <> ")" + ] + +fixtures :: [(Text, Chart)] +fixtures = + [ ("scatter", scatterChart) + , ("line", lineChart) + , ("bar", barChart) + , ("bar-horizontal", barHorizontal) + , ("bar-stacked", barStacked) + , ("bar-grouped", barGrouped) + , ("pie", pieChart) + , ("area", areaChart) + , ("histogram", histChart) + , ("boxplot", boxChart) + , ("errorbar", errorbarChart) + , ("density", densityChart) + , ("distplot", distplotChart) + , ("heatmap", heatmapChart) + , ("heatmap-annotated", heatmapAnnotated) + , ("funnel", funnelChart) + , ("waterfall", waterfallChart) + , ("polar", polarChart) + , ("facet", facetChart) + , ("log-y", logYChart) + , ("layer-bar-line", barLineChart) + , ("layer-scatter-radius", scatterRadiusChart) + , ("layer-scatter-fit", scatterFitChart) + , ("layer-line-ribbon", lineRibbonChart) + ] + +scatterChart :: Chart +scatterChart = + let xs = [0, 1, 2, 3, 4] :: [Double] + ys = [0, 1, 4, 9, 16] :: [Double] + df = fromColumns [("x", ColNum xs), ("y", ColNum ys)] + layer = + (defLayer GeomPoint) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "y = x^2" + , chartSize = SizeChars 40 14 + } + +lineChart :: Chart +lineChart = + let xs = [0, 0.5 .. 6.0] :: [Double] + ys = map sin xs + df = fromColumns [("x", ColNum xs), ("y", ColNum ys)] + layer = + (defLayer GeomLine) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "sin(x)" + , chartSize = SizeChars 50 14 + } + +barChart :: Chart +barChart = + let xs = ["A", "B", "C", "D"] + ys = [12, 7, 18, 9] :: [Double] + df = fromColumns [("x", ColCat xs), ("y", ColNum ys)] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Bars" + , chartSize = SizeChars 40 14 + } + +barHorizontal :: Chart +barHorizontal = + let xs = ["Alpha", "Bravo", "Charlie", "Delta", "Echo"] + ys = [82, 67, 45, 33, 21] :: [Double] + df = fromColumns [("item", ColCat xs), ("value", ColNum ys)] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "item") + , aesY = Just (ColumnRef "value") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartCoord = CoordFlip + , chartTitle = Just "Top 5 (horizontal)" + , chartSize = SizeChars 60 16 + } + +barStackedFrame :: DataFrame +barStackedFrame = + let quarters = concat [replicate 3 q | q <- ["Q1", "Q2", "Q3", "Q4"]] + products = take 12 (cycle ["Widgets", "Gadgets", "Gizmos"]) + sales = [12, 8, 4, 15, 10, 6, 18, 12, 8, 22, 14, 10] :: [Double] + in fromColumns + [ ("quarter", ColCat quarters) + , ("product", ColCat products) + , ("sales", ColNum sales) + ] + +barStacked :: Chart +barStacked = + let layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "quarter") + , aesY = Just (ColumnRef "sales") + , aesGroup = Just (ColumnRef "product") + , aesFill = Just (ColumnRef "product") + } + , layerStat = StatIdentity + , layerPosition = PosStack + } + in emptyChart + { chartData = barStackedFrame + , chartLayers = [layer] + , chartTitle = Just "Sales by quarter (stacked)" + , chartSize = SizeChars 60 16 + } + +barGrouped :: Chart +barGrouped = + barStacked + { chartLayers = + [ (List.head (chartLayers barStacked)) + { layerPosition = PosDodge 0.25 + } + ] + , chartTitle = Just "Sales by quarter (grouped)" + } + +pieChart :: Chart +pieChart = + let df = + fromColumns + [ ("slice", ColCat ["A", "B", "C", "D"]) + , ("value", ColNum [40, 25, 20, 15]) + ] + layer = + (defLayer GeomArc) + { layerMapping = emptyMapping{aesY = Just (ColumnRef "value")} + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Pie" + , chartSize = SizeChars 30 16 + } + +areaChart :: Chart +areaChart = + let xs = [0 .. 12] :: [Double] + ymax = [sin (x / 2) + 2 | x <- xs] + zeros = replicate (length xs) 0 :: [Double] + df = + fromColumns + [ ("x", ColNum xs) + , ("ymin", ColNum zeros) + , ("ymax", ColNum ymax) + ] + layer = + (defLayer GeomRibbon) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesYmin = Just (ColumnRef "ymin") + , aesYmax = Just (ColumnRef "ymax") + } + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Filled area" + , chartSize = SizeChars 56 14 + } + +histChart :: Chart +histChart = + let raw = take 50 (cycle [1.0, 1.2, 1.8, 2.0, 2.3, 2.7, 3.1, 3.4, 3.8, 4.2]) + df = fromColumns [("x", ColNum raw)] + layer = + (defLayer GeomHistogram) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "count") + } + , layerStat = StatBin (BinByCount 8) + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Histogram" + , chartSize = SizeChars 44 14 + } + +boxChart :: Chart +boxChart = + let pts = + [("A", v) | v <- [1, 2, 3, 4, 5, 6, 7, 8, 9 :: Double]] + <> [("B", v) | v <- [3, 4, 5, 6, 7, 8, 9, 10, 11]] + <> [("C", v) | v <- [5, 6, 7, 8, 9, 10, 11, 12, 13]] + df = + fromColumns + [ ("g", ColCat [g | (g, _) <- pts]) + , ("y", ColNum [v | (_, v) <- pts]) + ] + layer = + (defLayer GeomBoxplot) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "g") + , aesY = Just (ColumnRef "y") + } + , layerStat = StatBoxplot + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Boxplot" + , chartSize = SizeChars 40 16 + } + +errorbarChart :: Chart +errorbarChart = + let xs = [1 .. 5] :: [Double] + ys = [2.1, 3.5, 5.2, 4.7, 6.1] :: [Double] + los = [1.5, 2.8, 4.6, 4.0, 5.3] :: [Double] + his = [2.7, 4.2, 5.8, 5.4, 6.9] :: [Double] + df = + fromColumns + [ ("x", ColNum xs) + , ("y", ColNum ys) + , ("lo", ColNum los) + , ("hi", ColNum his) + ] + m = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesYmin = Just (ColumnRef "lo") + , aesYmax = Just (ColumnRef "hi") + } + bars = (defLayer GeomErrorbar){layerMapping = m, layerStat = StatIdentity} + pts = (defLayer GeomPoint){layerMapping = m, layerStat = StatIdentity} + in emptyChart + { chartData = df + , chartLayers = [bars, pts] + , chartTitle = Just "Measurements +/- CI" + , chartSize = SizeChars 56 14 + } + +densitySample :: [Double] +densitySample = + [ 1.0 + , 1.2 + , 1.3 + , 1.5 + , 1.7 + , 2.0 + , 2.1 + , 2.3 + , 2.5 + , 2.8 + , 3.0 + , 3.1 + , 3.3 + , 3.7 + , 3.9 + , 4.0 + ] + +densityChart :: Chart +densityChart = + let df = fromColumns [("x", ColNum densitySample)] + layer = + (defLayer GeomDensity) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "density") + } + , layerStat = StatDensity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Density (KDE)" + , chartSize = SizeChars 56 14 + } + +distplotChart :: Chart +distplotChart = + let df = fromColumns [("x", ColNum densitySample)] + hist = + (defLayer GeomHistogram) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "count") + } + , layerStat = StatBin (BinByCount 8) + } + kde = + (defLayer GeomDensity) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "density") + } + , layerStat = StatDensity + } + in emptyChart + { chartData = df + , chartLayers = [hist, kde] + , chartTitle = Just "Distribution" + , chartSize = SizeChars 56 16 + } + +heatmapCoords :: [(Double, Double, Double)] +heatmapCoords = + [ ( fromIntegral x + , fromIntegral y + , sin (fromIntegral x / 2) + cos (fromIntegral y / 2) + ) + | x <- [0 .. 4 :: Int] + , y <- [0 .. 4 :: Int] + ] + +heatmapChart :: Chart +heatmapChart = + let df = + fromColumns + [ ("x", ColNum [x | (x, _, _) <- heatmapCoords]) + , ("y", ColNum [y | (_, y, _) <- heatmapCoords]) + , ("z", ColNum [z | (_, _, z) <- heatmapCoords]) + ] + layer = + (defLayer GeomTile) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesFill = Just (ColumnRef "z") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Heatmap" + , chartSize = SizeChars 48 16 + } + +heatmapAnnotated :: Chart +heatmapAnnotated = + let labels = [Text.pack (show (round (z * 10) :: Int)) | (_, _, z) <- heatmapCoords] + df = + fromColumns + [ ("x", ColNum [x | (x, _, _) <- heatmapCoords]) + , ("y", ColNum [y | (_, y, _) <- heatmapCoords]) + , ("z", ColNum [z | (_, _, z) <- heatmapCoords]) + , ("label", ColCat labels) + ] + tile = + (defLayer GeomTile) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesFill = Just (ColumnRef "z") + } + , layerStat = StatIdentity + } + label = + (defLayer GeomText) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesLabel = Just (ColumnRef "label") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [tile, label] + , chartTitle = Just "Annotated heatmap" + , chartSize = SizeChars 48 16 + } + +funnelChart :: Chart +funnelChart = + let xs = ["Visited", "Signed up", "Confirmed", "Active", "Paid"] + ys = [1000, 720, 480, 220, 120] :: [Double] + df = fromColumns [("stage", ColCat xs), ("count", ColNum ys)] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "stage") + , aesY = Just (ColumnRef "count") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartCoord = CoordFlip + , chartTitle = Just "Sales funnel" + , chartSize = SizeChars 60 14 + } + +waterfallChart :: Chart +waterfallChart = + let xs = ["Start", "Q1", "Q2", "Q3", "Refund", "Net"] + ystart = [0, 100, 130, 180, 175, 0] :: [Double] + yend = [100, 130, 180, 175, 195, 195] :: [Double] + df = + fromColumns + [ ("x", ColCat xs) + , ("y", ColNum yend) + , ("__ybase", ColNum ystart) + ] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Waterfall" + , chartSize = SizeChars 60 14 + } + +polarChart :: Chart +polarChart = + let nSteps = 32 :: Int + pts = + [ (theta, abs (sin (2 * theta))) + | i <- [0 .. nSteps] + , let theta = (fromIntegral i / fromIntegral nSteps) * 2 * pi + ] + df = + fromColumns + [ ("theta", ColNum [t | (t, _) <- pts]) + , ("r", ColNum [r | (_, r) <- pts]) + ] + layer = + (defLayer GeomLine) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "theta") + , aesY = Just (ColumnRef "r") + } + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartCoord = CoordPolar ThetaX 0 PolarCCW + , chartTitle = Just "r = |sin(2 theta)|" + , chartSize = SizeChars 40 20 + } + +facetChart :: Chart +facetChart = + let df = + fromColumns + [ ("x", ColNum [0, 1, 2, 3, 0, 1, 2, 3, 0, 1, 2, 3]) + , ("y", ColNum [1, 4, 9, 16, 0, 2, 4, 6, 5, 4, 3, 2]) + , ("series", ColCat (replicate 4 "A" <> replicate 4 "B" <> replicate 4 "C")) + ] + layer = + (defLayer GeomPoint) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartFacet = FacetWrap (ColumnRef "series") (Just 3) Nothing ScalesFixed + , chartTitle = Just "Faceted by series" + , chartSize = SizeChars 70 18 + } + +logYChart :: Chart +logYChart = + let xs = [1 .. 6] :: [Double] + ys = [3, 30, 80, 200, 700, 2100] :: [Double] + df = fromColumns [("x", ColNum xs), ("y", ColNum ys)] + layer = + (defLayer GeomPoint) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartScales = defScales{scaleY = SLog Base10 defScaleOpts} + , chartTitle = Just "Log Y" + , chartSize = SizeChars 50 14 + } + +barLineChart :: Chart +barLineChart = + let months = ["Jan", "Feb", "Mar", "Apr", "May", "Jun"] + sales = [12, 18, 15, 24, 20, 28] :: [Double] + movavg = [12, 15, 16.5, 19.5, 22, 24] :: [Double] + df = + fromColumns + [ ("month", ColCat months) + , ("sales", ColNum sales) + , ("avg", ColNum movavg) + ] + bars = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "month") + , aesY = Just (ColumnRef "sales") + } + , layerStat = StatIdentity + } + trend = + (defLayer GeomLine) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "month") + , aesY = Just (ColumnRef "avg") + } + , layerAesDef = + emptyAesDefaults + { defColor = Just (NamedColor BrightRed) + , defLineWidth = Just 2.5 + } + } + in emptyChart + { chartData = df + , chartLayers = [bars, trend] + , chartTitle = Just "Monthly sales + trend" + , chartSize = SizeChars 60 14 + } + +scatterRadiusChart :: Chart +scatterRadiusChart = + let pts = + [ (0.2, 0.5) + , (0.8, 1.2) + , (-0.5, 0.3) + , (1.1, -0.2) + , (1.8, 0.7) + , (-0.3, -0.6) + , (2.2, 1.5) + , (1.5, -1.1) + , (0.1, 2.1) + , (2.5, 0.3) + , (-1.0, 1.0) + , (0.7, -0.4) + ] :: + [(Double, Double)] + points = + fromColumns + [ ("lon", ColNum [x | (x, _) <- pts]) + , ("lat", ColNum [y | (_, y) <- pts]) + ] + poi = + fromColumns + [ ("lon", ColNum [0.5]) + , ("lat", ColNum [0.5]) + ] + radius = + (defLayer GeomPoint) + { layerData = Just poi + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "lon") + , aesY = Just (ColumnRef "lat") + } + , layerAesDef = + emptyAesDefaults + { defColor = Just (NamedColor BrightCyan) + , defSize = Just 60 + , defAlpha = Just 0.25 + } + } + scatter = + (defLayer GeomPoint) + { layerData = Just points + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "lon") + , aesY = Just (ColumnRef "lat") + } + } + in emptyChart + { chartLayers = [radius, scatter] + , chartTitle = Just "Points near POI" + , chartSize = SizeChars 50 18 + } + +scatterFitChart :: Chart +scatterFitChart = + let xs = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] :: [Double] + noise = [0.3, -0.5, 0.7, -0.2, 0.4, -0.6, 0.1, 0.3, -0.4, 0.5] + ys = [2 * x + 1 + n | (x, n) <- zip xs noise] + df = fromColumns [("x", ColNum xs), ("y", ColNum ys)] + m = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + points = (defLayer GeomPoint){layerMapping = m} + fit = + (defLayer GeomLine) + { layerMapping = m + , layerStat = StatSmooth SmoothLm + , layerAesDef = + emptyAesDefaults + { defColor = Just (NamedColor BrightRed) + , defLineWidth = Just 2 + } + } + in emptyChart + { chartData = df + , chartLayers = [points, fit] + , chartTitle = Just "Scatter + OLS fit" + , chartSize = SizeChars 50 14 + } + +lineRibbonChart :: Chart +lineRibbonChart = + let xs = [0, 0.5 .. 6.0] :: [Double] + ys = map sin xs + los = map (\x -> sin x - 0.3) xs + his = map (\x -> sin x + 0.3) xs + df = + fromColumns + [ ("x", ColNum xs) + , ("y", ColNum ys) + , ("lo", ColNum los) + , ("hi", ColNum his) + ] + ribbon = + (defLayer GeomRibbon) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesYmin = Just (ColumnRef "lo") + , aesYmax = Just (ColumnRef "hi") + } + , layerAesDef = + emptyAesDefaults + { defColor = Just (NamedColor BrightCyan) + , defAlpha = Just 0.3 + } + } + line = + (defLayer GeomLine) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + , layerAesDef = + emptyAesDefaults + { defColor = Just (NamedColor BrightBlue) + , defLineWidth = Just 2 + } + } + in emptyChart + { chartData = df + , chartLayers = [ribbon, line] + , chartTitle = Just "sin(x) +/- 0.3 band" + , chartSize = SizeChars 56 14 + } diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,27 +2,50 @@ module Main where -import Control.Monad +import Data.Text (Text) import Data.Text qualified as Text -import Data.Text.IO qualified as Text +import Data.Text.IO qualified as Text.IO import Granite main :: IO () main = do - -- scatter - let ptsA_x = [0 .. 599] - let ptsA_y = [0 .. 599] - let ptsB_x = [0 .. 599] - let ptsB_y = [599, 598 .. 0] - Text.putStrLn $ - scatter - [series "A" (zip ptsA_x ptsA_y), series "B" (zip ptsB_x ptsB_y)] - defPlot{widthChars = 68, heightChars = 22, plotTitle = "Random points"} + section "Scatter — two series, 600 points each" + Text.IO.putStrLn $ + let ptsA = [(x, x) | x <- [0 .. 599]] + ptsB = [(x, 599 - x) | x <- [0 .. 599]] + in scatter + [series "A" ptsA, series "B" ptsB] + defPlot{widthChars = 68, heightChars = 22, plotTitle = "Random points"} - -- histogram + section "Line graph — three product trends" + Text.IO.putStrLn $ + lineGraph + [ ("Product A", [(1, 100), (2, 120), (3, 115), (4, 140), (5, 155), (6, 148)]) + , ("Product B", [(1, 80), (2, 85), (3, 95), (4, 92), (5, 110), (6, 125)]) + , ("Product C", [(1, 60), (2, 62), (3, 70), (4, 85), (5, 82), (6, 90)]) + ] + defPlot{plotTitle = "Monthly Sales Trends"} + + section "Bar chart — quarterly sales" + Text.IO.putStrLn $ + bars + [("Q1", 12), ("Q2", 18), ("Q3", 9), ("Q4", 15)] + defPlot{plotTitle = "Sales", xNumTicks = 4} + + section "Stacked bar chart — revenue by product type" + Text.IO.putStrLn $ + stackedBars + [ ("Q1", [("Hardware", 120), ("Software", 200), ("Services", 80)]) + , ("Q2", [("Hardware", 135), ("Software", 220), ("Services", 95)]) + , ("Q3", [("Hardware", 110), ("Software", 240), ("Services", 110)]) + , ("Q4", [("Hardware", 145), ("Software", 260), ("Services", 125)]) + ] + defPlot{plotTitle = "Quarterly Revenue Breakdown"} + + section "Histogram — sample heights" let heights = concat $ zipWith replicate [0 .. 40] [160 .. 200] - Text.putStrLn $ + Text.IO.putStrLn $ histogram (bins 40 155 195) heights @@ -36,14 +59,8 @@ , plotTitle = "Heights (cm)" } - -- bars - Text.putStrLn $ - bars - [("Q1", 12), ("Q2", 18), ("Q3", 9), ("Q4", 15)] - defPlot{plotTitle = "Sales", xNumTicks = 4} - - -- pie - Text.putStrLn $ + section "Pie chart — market share" + Text.IO.putStrLn $ pie [("Alpha", 0.35), ("Beta", 0.25), ("Gamma", 0.20), ("Delta", 0.20)] defPlot @@ -53,17 +70,18 @@ , plotTitle = "Share" } - -- line graph - Text.putStrLn $ - lineGraph - [ ("Product A", [(1, 100), (2, 120), (3, 115), (4, 140), (5, 155), (6, 148)]) - , ("Product B", [(1, 80), (2, 85), (3, 95), (4, 92), (5, 110), (6, 125)]) - , ("Product C", [(1, 60), (2, 62), (3, 70), (4, 85), (5, 82), (6, 90)]) + section "Heatmap — correlation matrix" + let matrix = + [ [1.0, 0.8, 0.3, -0.2, 0.1] + , [0.8, 1.0, 0.5, -0.1, 0.2] + , [0.3, 0.5, 1.0, 0.6, 0.4] + , [-0.2, -0.1, 0.6, 1.0, 0.7] + , [0.1, 0.2, 0.4, 0.7, 1.0] ] - defPlot{plotTitle = "Monthly Sales Trends"} + Text.IO.putStrLn $ heatmap matrix defPlot{plotTitle = "Correlation Matrix"} - -- box plot - Text.putStrLn $ + section "Box plot — test score distribution by class" + Text.IO.putStrLn $ boxPlot [ ("Class A", [78, 82, 85, 88, 90, 92, 85, 87, 89, 91, 76, 94, 88]) , ("Class B", [70, 75, 72, 80, 85, 78, 82, 77, 79, 81, 74, 83]) @@ -72,22 +90,117 @@ ] defPlot{plotTitle = "Test Score Distribution by Class"} - -- stacked bar chart - Text.putStrLn $ - stackedBars - [ ("Q1", [("Hardware", 120), ("Software", 200), ("Services", 80)]) - , ("Q2", [("Hardware", 135), ("Software", 220), ("Services", 95)]) - , ("Q3", [("Hardware", 110), ("Software", 240), ("Services", 110)]) - , ("Q4", [("Hardware", 145), ("Software", 260), ("Services", 125)]) + section "Area — filled curve from y=0" + Text.IO.putStrLn $ + area + [ ("revenue", [(x, sin (x / 2) * 50 + 200) | x <- [0 .. 12 :: Double]]) ] - defPlot{plotTitle = "Quarterly Revenue Breakdown"} + defPlot{widthChars = 60, heightChars = 18, plotTitle = "Daily revenue"} - -- heatmap - let matrix = - [ [1.0, 0.8, 0.3, -0.2, 0.1] - , [0.8, 1.0, 0.5, -0.1, 0.2] - , [0.3, 0.5, 1.0, 0.6, 0.4] - , [-0.2, -0.1, 0.6, 1.0, 0.7] - , [0.1, 0.2, 0.4, 0.7, 1.0] + section "Ribbon — confidence band" + Text.IO.putStrLn $ + ribbon + [ ("CI 90%", [(x, sin x - 0.4, sin x + 0.4) | x <- [0, 0.5 .. 6.0 :: Double]]) ] - Text.putStrLn $ heatmap matrix defPlot{plotTitle = "Correlation Matrix"} + defPlot{widthChars = 60, heightChars = 16, plotTitle = "sin(x) +/- 0.4 band"} + + section "Density — KDE over a sample" + Text.IO.putStrLn $ + density + [ + ( "class A" + , concat [replicate 5 v | v <- [1.0, 1.4, 1.6, 2.0, 2.3, 2.6, 3.0, 3.2, 3.5]] + ) + , + ( "class B" + , concat [replicate 5 v | v <- [2.5, 2.7, 3.0, 3.4, 3.8, 4.1, 4.4, 4.7, 5.0]] + ) + ] + defPlot{widthChars = 60, heightChars = 16, plotTitle = "Distribution of scores"} + + section "Error bars — points with vertical CIs" + Text.IO.putStrLn $ + errorBars + [ + ( "treatment" + , + [ (1, 2.1, 1.5, 2.7) + , (2, 3.5, 2.8, 4.2) + , (3, 5.2, 4.6, 5.8) + , (4, 4.7, 4.0, 5.4) + , (5, 6.1, 5.3, 6.9) + ] + ) + ] + defPlot{widthChars = 60, heightChars = 16, plotTitle = "Measurements +/- CI"} + + section "Funnel — sales pipeline" + Text.IO.putStrLn $ + funnel + [ ("Visited", 1000) + , ("Signed up", 720) + , ("Confirmed", 480) + , ("Active", 220) + , ("Paid", 120) + ] + defPlot{widthChars = 60, heightChars = 16, plotTitle = "Sales funnel"} + + section "Polar line — four-petal rose r = |sin(2θ)|" + let nSteps = 32 :: Int + roseTheta i = fromIntegral i / fromIntegral nSteps * 2 * pi + rosePts = [(roseTheta i, abs (sin (2 * roseTheta i))) | i <- [0 .. nSteps]] + Text.IO.putStrLn $ + polarLine + [("r = |sin(2theta)|", rosePts)] + defPlot{widthChars = 40, heightChars = 22, plotTitle = "Polar rose"} + + section "Waterfall — running revenue total" + Text.IO.putStrLn $ + waterfall + [ ("Start", 0, 100) + , ("Q1", 100, 130) + , ("Q2", 130, 180) + , ("Q3", 180, 175) -- a small dip + , ("Refund", 175, 195) + , ("Net", 0, 195) + ] + defPlot{widthChars = 60, heightChars = 16, plotTitle = "Revenue waterfall"} + + section "Distplot — histogram + density overlay" + Text.IO.putStrLn $ + distPlot + [ + ( "sample" + , concat + [ replicate 5 v + | v <- + [ 1.0 + , 1.2 + , 1.3 + , 1.5 + , 1.7 + , 2.0 + , 2.1 + , 2.3 + , 2.5 + , 2.8 + , 3.0 + , 3.1 + , 3.3 + , 3.7 + , 3.9 + , 4.0 + , 4.2 + ] + ] + ) + ] + defPlot{widthChars = 60, heightChars = 18, plotTitle = "Distribution"} + +section :: Text -> IO () +section name = do + Text.IO.putStrLn "" + Text.IO.putStrLn (Text.replicate 72 "=") + Text.IO.putStrLn name + Text.IO.putStrLn (Text.replicate 72 "-") + Text.IO.putStrLn "" diff --git a/granite.cabal b/granite.cabal --- a/granite.cabal +++ b/granite.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: granite -version: 0.4.0.1 +version: 0.5.0.0 synopsis: Easy terminal plotting. description: A terminal plotting library for quick and easy visualisation. license: MIT @@ -42,8 +42,23 @@ library import: ghc-options exposed-modules: Granite, + Granite.Chart, + Granite.Color, + Granite.Data.Frame, + Granite.Format, + Granite.Position, + Granite.Render.Chrome, + Granite.Render.Pipeline, + Granite.Render.Scene, + Granite.Render.Svg, + Granite.Render.Terminal, + Granite.Scale, + Granite.Spec, + Granite.Stat, Granite.String, Granite.Svg + other-modules: Granite.Internal.LegacyChart, + Granite.Internal.Util build-depends: base >=4 && <5, text >= 1 && < 3 @@ -54,11 +69,23 @@ main-is: Main.hs build-depends: base >=4 && <5, - granite ^>= 0.4, + granite ^>= 0.5, text >= 1 && < 3 hs-source-dirs: app default-language: GHC2021 +executable granite-tutorial + import: ghc-options + main-is: GenerateTutorial.hs + build-depends: + base >=4 && <5, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6, + granite ^>= 0.5, + text >= 1 && < 3 + hs-source-dirs: app + default-language: GHC2021 + test-suite granite-test import: ghc-options type: exitcode-stdio-1.0 @@ -66,11 +93,20 @@ main-is: Spec.hs other-modules: + Golden + GoldenSpec GraniteSpec + PipelineSpec + PlotlySpec + PositionSpec + RenderSpec + ScaleSpec + SpecPropSpec + StatSpec build-depends: base >= 4.14 && < 5 - , granite ^>= 0.4 + , granite ^>= 0.5 , text >= 1.2 && < 3 , hspec >= 2.7 && < 2.12 , QuickCheck >= 2.14 && < 3 diff --git a/src/Granite.hs b/src/Granite.hs --- a/src/Granite.hs +++ b/src/Granite.hs @@ -75,11 +75,19 @@ heatmap, lineGraph, boxPlot, + + -- * Plotly-Express-style helpers + area, + ribbon, + density, + errorBars, + funnel, + polarLine, + waterfall, + distPlot, ) where -import Data.Bits (xor, (.&.), (.|.)) -import Data.Char (chr) -import Data.Function (on) +import Data.Bits (xor, (.&.)) import Data.List qualified as List import Data.Maybe import Data.Text (Text) @@ -87,6 +95,36 @@ import Numeric (showEFloat, showFFloat) import Text.Printf +import Granite.Color (Color (..), paint, paletteColors, pieColors) +import Granite.Internal.LegacyChart qualified as LC +import Granite.Internal.Util ( + addAt, + angleWithin, + clamp, + ellipsisize, + eps, + gridWidth, + justifyRight, + maximum', + minimum', + mod', + normalize, + quartiles, + setAt, + ticks1D, + updateAt, + wcswidth, + ) +import Granite.Render.Pipeline (renderChartTerminal) +import Granite.Render.Terminal ( + Canvas (..), + fillDotsC, + lineDotsC, + newCanvas, + renderCanvas, + setDotC, + ) + -- | Position of the legend in the plot. data LegendPos = -- | Display legend on the right side of the plot @@ -208,27 +246,6 @@ -- ^ total number of ticks } --- | Supported ANSI colo(u)rs. -data Color - = Default - | Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - | BrightBlack - | BrightRed - | BrightGreen - | BrightYellow - | BrightBlue - | BrightMagenta - | BrightCyan - | BrightWhite - deriving (Eq, Show) - {- | Create a named data series for multi-series plots. @ @@ -868,58 +885,6 @@ setGridChar grid x y ch col = updateAt grid y (\row -> setAt row x (ch, col)) -ansiCode :: Color -> Int -ansiCode Black = 30 -ansiCode Red = 31 -ansiCode Green = 32 -ansiCode Yellow = 33 -ansiCode Blue = 34 -ansiCode Magenta = 35 -ansiCode Cyan = 36 -ansiCode White = 37 -ansiCode BrightBlack = 90 -ansiCode BrightRed = 91 -ansiCode BrightGreen = 92 -ansiCode BrightYellow = 93 -ansiCode BrightBlue = 94 -ansiCode BrightMagenta = 95 -ansiCode BrightCyan = 96 -ansiCode BrightWhite = 97 -ansiCode Default = 39 - -ansiOn :: Color -> Text -ansiOn c = "\ESC[" <> Text.pack (show (ansiCode c)) <> "m" - -ansiOff :: Text -ansiOff = "\ESC[0m" - -paint :: Color -> Char -> Text -paint c ch = if ch == ' ' then " " else ansiOn c <> Text.singleton ch <> ansiOff - -paletteColors :: [Color] -paletteColors = - [ BrightBlue - , BrightMagenta - , BrightCyan - , BrightGreen - , BrightYellow - , BrightRed - , BrightWhite - , BrightBlack - ] - -pieColors :: [Color] -pieColors = - [ BrightRed - , BrightGreen - , BrightYellow - , BrightBlue - , BrightMagenta - , BrightCyan - , BrightWhite - , BrightBlack - ] - data Pat = Solid | Checker | DiagA | DiagB | Sparse deriving (Eq, Show) ink :: Pat -> Int -> Int -> Bool @@ -932,99 +897,6 @@ palette :: [Pat] palette = [Solid, Checker, DiagA, DiagB, Sparse] -data Array2D a = A2D Int Int (Arr a) - -getA2D :: Array2D a -> Int -> Int -> a -getA2D (A2D w _ xs) x y = indexA xs (y * w + x) - -setA2D :: Array2D a -> Int -> Int -> a -> Array2D a -setA2D (A2D w h xs) x y v = - let i = y * w + x - in A2D w h (setA xs i v) - -newA2D :: Int -> Int -> a -> Array2D a -newA2D w h v = A2D w h (fromList (replicate (w * h) v)) - -toBit :: Int -> Int -> Int -toBit ry rx = case (ry, rx) of - (0, 0) -> 1 - (1, 0) -> 2 - (2, 0) -> 4 - (3, 0) -> 64 - (0, 1) -> 8 - (1, 1) -> 16 - (2, 1) -> 32 - (3, 1) -> 128 - _ -> 0 - -data Canvas = Canvas - { cW :: Int - , cH :: Int - , buffer :: Array2D Int - , cbuf :: Array2D (Maybe Color) - } - -newCanvas :: Int -> Int -> Canvas -newCanvas w h = Canvas w h (newA2D w h 0) (newA2D w h Nothing) - -setDotC :: Canvas -> Int -> Int -> Maybe Color -> Canvas -setDotC c xDot yDot mcol - | xDot < 0 || yDot < 0 || xDot >= cW c * 2 || yDot >= cH c * 4 = c - | otherwise = - let (cx, rx) = xDot `divMod` 2 - (cy, ry) = yDot `divMod` 4 - b = toBit ry rx - m = getA2D (buffer c) cx cy - c' = c{buffer = setA2D (buffer c) cx cy (m .|. b)} - in case mcol of - Nothing -> c' - Just col -> c'{cbuf = setA2D (cbuf c) cx cy (Just col)} - -fillDotsC :: - (Int, Int) -> - (Int, Int) -> - (Int -> Int -> Bool) -> - Maybe Color -> - Canvas -> - Canvas -fillDotsC (x0, y0) (x1, y1) p mcol c0 = - let xs = [max 0 x0 .. min (cW c0 * 2 - 1) x1] - ys = [max 0 y0 .. min (cH c0 * 4 - 1) y1] - in List.foldl' - (\c y -> List.foldl' (\c' x -> if p x y then setDotC c' x y mcol else c') c xs) - c0 - ys - -renderCanvas :: Canvas -> Text -renderCanvas (Canvas w h a colA) = - let glyph 0 = ' ' - glyph m = chr (0x2800 + m) - rows = - fmap - ( \y -> flip fmap [0 .. w - 1] $ \x -> - let m = getA2D a x y - ch = glyph m - mc = getA2D colA x y - in maybe (Text.singleton ch) (`paint` ch) mc - ) - [0 .. h - 1] - in Text.unlines (fmap Text.concat rows) - -justifyRight :: Int -> Text -> Text -justifyRight n s = Text.replicate (max 0 (n - wcswidth s)) " " <> s - -wcswidth :: Text -> Int -wcswidth = go 0 - where - go acc xs - | Text.null xs = acc - | Text.isPrefixOf "\ESC[" xs = - let - rest' = Text.dropWhile (/= 'm') xs - in - if Text.null rest' then acc else go acc (Text.tail rest') - | otherwise = go (acc + 1) (Text.tail xs) - fmt :: AxisEnv -> Int -> Double -> Text fmt _ _ v | abs v >= 10000 || abs v < 0.01 && v /= 0 = @@ -1038,35 +910,6 @@ (not . Text.null) [plotTitle cfg, contentWithAxes, legendBlockStr] -{- | Evenly spaced tick positions in screen space paired with data values. - If invertY = True, 0 maps to ymax (top row) and 1 maps to ymin (bottom). --} -ticks1D :: - -- | screen length in chars (width for X, height for Y) - Int -> - -- | requested number of ticks (will clamp to >= 2) - Int -> - -- | (vmin, vmax) in data space - (Double, Double) -> - -- | invertY? (True for Y axis so row 0 = ymax) - Bool -> - -- | (screenPos, dataValue) - [(Int, Double)] -ticks1D screenLen want (vmin, vmax) invertY = - let n = max 2 want - lastIx = max 0 (screenLen - 1) - toVal t = - if invertY - then vmax - t * (vmax - vmin) - else vmin + t * (vmax - vmin) - mk' k = - let t = if n == 1 then 0 else fromIntegral k / fromIntegral (n - 1) - pos = round (t * fromIntegral lastIx) - in (pos, toVal t) - raw = [mk' k | k <- [0 .. n - 1]] - dedup = List.nubBy ((==) `on` fst) raw - in dedup - slotBudget :: Int -> Int -> Int slotBudget plotPixels numTicks = max 1 (plotPixels `div` max 1 numTicks) @@ -1244,12 +1087,6 @@ s = renderCanvas c in Text.dropWhileEnd (== '\n') s -clamp :: (Ord a) => a -> a -> a -> a -clamp low high x = max low (min high x) - -eps :: Double -eps = 1e-12 - boundsXY :: Plot -> [(Double, Double)] -> (Double, Double, Double, Double) boundsXY cfg pts = let (xs, ys) = unzip pts @@ -1265,9 +1102,6 @@ , fromMaybe (ymax + pady) (snd (yBounds cfg)) ) -mod' :: Double -> Double -> Double -mod' a m = a - fromIntegral (floor (a / m) :: Int) * m - blockChar :: Int -> Char blockChar n = case clamp 0 8 n of 0 -> ' ' @@ -1311,195 +1145,50 @@ | (i, v) <- zip [0 ..] xs ] -addAt :: [Int] -> Int -> Int -> [Int] -addAt xs i v = updateAt xs i (+ v) - -normalize :: [(Text, Double)] -> [(Text, Double)] -normalize xs = - let s = sum (map (abs . snd) xs) + 1e-12 - in [(n, max 0 (v / s)) | (n, v) <- xs] - -angleWithin :: Double -> Double -> Double -> Bool -angleWithin ang a0 a1 - | a1 >= a0 = ang >= a0 && ang <= a1 - | otherwise = ang >= a0 || ang <= a1 - -lineDotsC :: (Int, Int) -> (Int, Int) -> Maybe Color -> Canvas -> Canvas -lineDotsC (x0, y0) (x1, y1) mcol c0 = - let dx = abs (x1 - x0) - sx = if x0 < x1 then 1 else -1 - dy = negate (abs (y1 - y0)) - sy = if y0 < y1 then 1 else -1 - go x y err c - | x == x1 && y == y1 = setDotC c x y mcol - | otherwise = - let e2 = 2 * err - (x', err') = if e2 >= dy then (x + sx, err + dy) else (x, err) - (y', err'') = if e2 <= dx then (y + sy, err' + dx) else (y, err') - in go x' y' err'' (setDotC c x y mcol) - in go x0 y0 (dx + dy) c0 - -quartiles :: [Double] -> (Double, Double, Double, Double, Double) -quartiles [] = (0, 0, 0, 0, 0) -- Idk. Maybe throw an error here??? -quartiles xs = - let sorted = List.sort xs - n = length sorted - q1Idx = n `div` 4 - q2Idx = n `div` 2 - q3Idx = 3 * n `div` 4 - getIdx i = if i < n then sorted !! i else last sorted - in if n < 5 - then let m = sum xs / fromIntegral n in (m, m, m, m, m) - else - ( fromMaybe 0 (listToMaybe sorted) - , getIdx q1Idx - , getIdx q2Idx - , getIdx q3Idx - , last sorted - ) - -gridWidth :: [[a]] -> Int -gridWidth [] = 0 -gridWidth (x : _) = length x - --- | Min and max function for axis bounds which defaults to 0 and 1 when empty. -minimum', maximum' :: [Double] -> Double -minimum' [] = 0 -minimum' xs = minimum xs -maximum' [] = 1 -maximum' xs = maximum xs - --- AVL Tree we'll use as an array. --- This improves upon the previous implementation that relies --- on linked list for indexing and update (both O(n)) while keeping --- the dependencies very light (wouldn't want to install all of containers --- just to get an int map). -data Arr a - = E - | N Int Int (Arr a) a (Arr a) - -size :: Arr a -> Int -size E = 0 -size (N sz _ _ _ _) = sz - -height :: Arr a -> Int -height E = 0 -height (N _ h _ _ _) = h - -mk :: Arr a -> a -> Arr a -> Arr a -mk l x r = N sz h l x r - where - sl = size l - sr = size r - hl = height l - hr = height r - sz = 1 + sl + sr - h = 1 + max hl hr - -rotateL :: Arr a -> Arr a -rotateL (N _ _ l x (N _ _ rl y rr)) = mk (mk l x rl) y rr -rotateL _ = error "rotateL: malformed tree" - -rotateR :: Arr a -> Arr a -rotateR (N _ _ (N _ _ ll y lr) x r) = mk ll y (mk lr x r) -rotateR _ = error "rotateR: malformed tree" +-- | Filled-area chart with the curve closed down to @y=0@. +area :: [(Text, [(Double, Double)])] -> Plot -> Text +area sers cfg = + renderChartTerminal $ + LC.areaChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) -balance :: Arr a -> Arr a -balance t@(N _ _ l x r) - | height l > height r + 1 = - case l of - N _ _ ll _ lr -> - if height ll >= height lr - then rotateR t - else rotateR (mk (rotateL l) x r) - _ -> t - | height r > height l + 1 = - case r of - N _ _ rl _ rr -> - if height rr >= height rl - then rotateL t - else rotateL (mk l x (rotateR r)) - _ -> t - | otherwise = mk l x r -balance t = t +-- | Filled band between @(x, ymin, ymax)@ curves — e.g. CI envelopes. +ribbon :: [(Text, [(Double, Double, Double)])] -> Plot -> Text +ribbon sers cfg = + renderChartTerminal $ + LC.ribbonChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) -indexA :: Arr a -> Int -> a -indexA t i = - case t of - E -> error ("index out of bounds: " <> show i) - N _ _ l x r -> - let sl = size l - in if i < 0 || i >= 1 + sl + size r - then error ("index out of bounds: " <> show i) - else - if i < sl - then indexA l i - else - if i == sl - then x - else indexA r (i - sl - 1) +-- | Gaussian KDE per series (Silverman bandwidth). +density :: [(Text, [Double])] -> Plot -> Text +density sers cfg = + renderChartTerminal $ + LC.densityChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) -setA :: Arr a -> Int -> a -> Arr a -setA t i y = - case t of - E -> error ("index out of bounds when setting: " <> show i) - N _ _ l x r -> - let sl = size l - in if i < 0 || i >= 1 + sl + size r - then error ("index out of bounds: " <> show i) - else - if i < sl - then balance (mk (setA l i y) x r) - else - if i == sl - then mk l y r - else balance (mk l x (setA r (i - sl - 1) y)) +-- | Points with vertical error bars: @(x, y, ymin, ymax)@ per row. +errorBars :: [(Text, [(Double, Double, Double, Double)])] -> Plot -> Text +errorBars sers cfg = + renderChartTerminal $ + LC.errorBarsChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) -fromList :: [a] -> Arr a -fromList xs = fst (build (length xs) xs) - where - build :: Int -> [a] -> (Arr a, [a]) - build 0 ys = (E, ys) - build n ys = - let (l, ys1) = build (n `div` 2) ys - (x, ys2) = case ys1 of - [] -> error "IMPOSSIBLE" - (v : vs) -> (v, vs) - (r, ys3) = build (n - n `div` 2 - 1) ys2 - in (mk l x r, ys3) +-- | Horizontal bars sized by their values. +funnel :: [(Text, Double)] -> Plot -> Text +funnel stages cfg = + renderChartTerminal $ + LC.funnelChart stages (widthChars cfg) (heightChars cfg) (plotTitle cfg) --- >>> setAt "abc" (-1) 'x' --- "abc" --- >>> setAt "abc" 0 'x' --- "xbc" --- >>> setAt "abc" 2 'x' --- "abx" --- >>> setAt "abc" 10 'x' --- "abc" -setAt :: [a] -> Int -> a -> [a] -setAt xs i v = updateAt xs i (const v) +-- | Polar line chart; theta in radians CCW from +x. +polarLine :: [(Text, [(Double, Double)])] -> Plot -> Text +polarLine sers cfg = + renderChartTerminal $ + LC.polarLineChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) -updateAt :: [a] -> Int -> (a -> a) -> [a] -updateAt xs i f - | i < 0 = xs - | otherwise = go xs i - where - go [] _ = [] - go (x : rest) 0 = f x : rest - go (x : rest) n = x : go rest (n - 1) +-- | Waterfall chart: rows are @(label, start, end)@. +waterfall :: [(Text, Double, Double)] -> Plot -> Text +waterfall rows cfg = + renderChartTerminal $ + LC.waterfallChart rows (widthChars cfg) (heightChars cfg) (plotTitle cfg) -{- | Ensure the text fits within maxWidth. If it doesn't, truncate and append an ellipsis. ->>> ellipsisize 5 "Hello, World!" -"Hell\8230" ->>> ellipsisize 1 "Hi" -"\8230" ->>> ellipsisize 0 "Hello, World!" -"" ->>> ellipsisize 20 "Hello, World!" -"Hello, World!" --} -ellipsisize :: Int -> Text -> Text -ellipsisize maxWidth lbl - | maxWidth <= 0 = "" - | wcswidth lbl > maxWidth = Text.take (maxWidth - 1) lbl <> "…" - | otherwise = lbl +-- | Histogram + KDE overlay per series. +distPlot :: [(Text, [Double])] -> Plot -> Text +distPlot sers cfg = + renderChartTerminal $ + LC.distPlotChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) diff --git a/src/Granite/Chart.hs b/src/Granite/Chart.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Chart.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Chart +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Convenience builders that construct a 'Chart' from the same kinds of +arguments accepted by the legacy chart functions in "Granite". Use +these when you want the declarative IR while still keeping ergonomic +construction: + +@ +import Granite.Chart +import qualified Data.Text.IO as T +import Granite.Render.Pipeline + +main = do + let ch = scatterChart + [("A", [(0,0),(1,1),(2,4)]) + ,("B", [(0,1),(1,3),(2,6)]) + ] (Just "Random points") + T.putStrLn (renderChartTerminal ch) +@ +-} +module Granite.Chart ( + scatterChart, + lineChart, +) where + +import Data.Text (Text) + +import Granite.Data.Frame (Column (..), fromColumns) +import Granite.Spec + +{- | Build an IR scatter chart from N series, each with its own (x, y) +pairs. Each series becomes a separate 'GeomPoint' layer carrying its +own data frame and a group aesthetic that drives the legend. +-} +scatterChart :: [(Text, [(Double, Double)])] -> Maybe Text -> Chart +scatterChart sers title = + emptyChart + { chartTitle = title + , chartLayers = map mkLayer sers + } + where + mkLayer (name, pts) = + let xs = map fst pts + ys = map snd pts + df = fromColumns [("x", ColNum xs), ("y", ColNum ys)] + in (defLayer GeomPoint) + { layerData = Just df + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesGroup = Just (ColumnRef name) + } + } + +{- | Build an IR line chart from N series; analogous to 'scatterChart' +but with one 'GeomLine' layer per series. +-} +lineChart :: [(Text, [(Double, Double)])] -> Maybe Text -> Chart +lineChart sers title = + emptyChart + { chartTitle = title + , chartLayers = map mkLayer sers + } + where + mkLayer (name, pts) = + let xs = map fst pts + ys = map snd pts + df = fromColumns [("x", ColNum xs), ("y", ColNum ys)] + in (defLayer GeomLine) + { layerData = Just df + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesGroup = Just (ColumnRef name) + } + } diff --git a/src/Granite/Color.hs b/src/Granite/Color.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Color.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Color +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Color primitives shared by both the terminal and SVG backends: +the ANSI 16-color palette ('Color'), escape-code helpers, and the +hex mapping used by the SVG backend. +-} +module Granite.Color ( + Color (..), + ansiCode, + ansiOn, + ansiOff, + paint, + colorHex, + paletteColors, + pieColors, +) where + +import Data.Text (Text) +import Data.Text qualified as Text + +-- | Supported ANSI colo(u)rs. +data Color + = Default + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + | BrightBlack + | BrightRed + | BrightGreen + | BrightYellow + | BrightBlue + | BrightMagenta + | BrightCyan + | BrightWhite + deriving (Eq, Show, Read) + +ansiCode :: Color -> Int +ansiCode Black = 30 +ansiCode Red = 31 +ansiCode Green = 32 +ansiCode Yellow = 33 +ansiCode Blue = 34 +ansiCode Magenta = 35 +ansiCode Cyan = 36 +ansiCode White = 37 +ansiCode BrightBlack = 90 +ansiCode BrightRed = 91 +ansiCode BrightGreen = 92 +ansiCode BrightYellow = 93 +ansiCode BrightBlue = 94 +ansiCode BrightMagenta = 95 +ansiCode BrightCyan = 96 +ansiCode BrightWhite = 97 +ansiCode Default = 39 + +ansiOn :: Color -> Text +ansiOn c = "\ESC[" <> Text.pack (show (ansiCode c)) <> "m" + +ansiOff :: Text +ansiOff = "\ESC[0m" + +-- | Wrap a character in ANSI on/off sequences. Spaces pass through unchanged. +paint :: Color -> Char -> Text +paint c ch = if ch == ' ' then " " else ansiOn c <> Text.singleton ch <> ansiOff + +-- | Hex RGB approximation of the ANSI palette, used by the SVG backend. +colorHex :: Color -> Text +colorHex Default = "#555555" +colorHex Black = "#2c3e50" +colorHex Red = "#c0392b" +colorHex Green = "#27ae60" +colorHex Yellow = "#f39c12" +colorHex Blue = "#2980b9" +colorHex Magenta = "#8e44ad" +colorHex Cyan = "#16a085" +colorHex White = "#ecf0f1" +colorHex BrightBlack = "#7f8c8d" +colorHex BrightRed = "#e74c3c" +colorHex BrightGreen = "#2ecc71" +colorHex BrightYellow = "#f1c40f" +colorHex BrightBlue = "#3498db" +colorHex BrightMagenta = "#9b59b6" +colorHex BrightCyan = "#1abc9c" +colorHex BrightWhite = "#bdc3c7" + +-- | Default palette for layered charts (scatter, line, bars, …). +paletteColors :: [Color] +paletteColors = + [ BrightBlue + , BrightMagenta + , BrightCyan + , BrightGreen + , BrightYellow + , BrightRed + , BrightWhite + , BrightBlack + ] + +-- | Palette used by pie / box plots (categorical, more saturated). +pieColors :: [Color] +pieColors = + [ BrightRed + , BrightGreen + , BrightYellow + , BrightBlue + , BrightMagenta + , BrightCyan + , BrightWhite + , BrightBlack + ] diff --git a/src/Granite/Data/Frame.hs b/src/Granite/Data/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Data/Frame.hs @@ -0,0 +1,104 @@ + +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Data.Frame +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Column-oriented data frame used as input to the chart IR. +-} +module Granite.Data.Frame ( + Column (..), + columnLength, + columnAsNum, + columnAsText, + DataFrame (..), + emptyFrame, + addColumn, + lookupColumn, + columnNames, + frameLength, + fromColumns, + filterByRows, + uniqueText, + pickRows, +) where + +import Data.Int (Int64) +import Data.List qualified as List +import Data.Text (Text) +import Data.Text qualified as Text + +data Column + = ColNum ![Double] + | ColCat ![Text] + | ColTime ![Int64] + | ColBool ![Bool] + deriving (Eq, Show, Read) + +columnLength :: Column -> Int +columnLength col = case col of + ColNum xs -> length xs + ColCat xs -> length xs + ColTime xs -> length xs + ColBool xs -> length xs + +columnAsNum :: Column -> Maybe [Double] +columnAsNum col = case col of + ColNum xs -> Just xs + ColBool xs -> Just (map (\b -> if b then 1 else 0) xs) + ColTime xs -> Just (map fromIntegral xs) + ColCat _ -> Nothing + +columnAsText :: Column -> [Text] +columnAsText col = case col of + ColCat xs -> xs + ColNum xs -> map showD xs + ColTime xs -> map (Text.pack . show) xs + ColBool xs -> map (Text.pack . show) xs + where + showD :: Double -> Text + showD d = Text.pack (show d) + +newtype DataFrame = DataFrame {unDataFrame :: [(Text, Column)]} + deriving (Eq, Show, Read) + +emptyFrame :: DataFrame +emptyFrame = DataFrame [] + +addColumn :: Text -> Column -> DataFrame -> DataFrame +addColumn name col (DataFrame xs) + | any ((== name) . fst) xs = + DataFrame [(n, if n == name then col else c) | (n, c) <- xs] + | otherwise = DataFrame (xs ++ [(name, col)]) + +lookupColumn :: Text -> DataFrame -> Maybe Column +lookupColumn name (DataFrame xs) = lookup name xs + +columnNames :: DataFrame -> [Text] +columnNames (DataFrame xs) = map fst xs + +frameLength :: DataFrame -> Int +frameLength (DataFrame xs) = foldr (max . columnLength . snd) 0 xs + +fromColumns :: [(Text, Column)] -> DataFrame +fromColumns = DataFrame + +pickRows :: [Int] -> Column -> Column +pickRows ixs col = case col of + ColNum xs -> ColNum (pick xs) + ColCat xs -> ColCat (pick xs) + ColTime xs -> ColTime (pick xs) + ColBool xs -> ColBool (pick xs) + where + pick :: [a] -> [a] + pick xs = [xs !! i | i <- ixs, i < length xs] + +filterByRows :: [Int] -> DataFrame -> DataFrame +filterByRows ixs (DataFrame cols) = + DataFrame [(n, pickRows ixs c) | (n, c) <- cols] + +uniqueText :: [Text] -> [Text] +uniqueText = List.nub diff --git a/src/Granite/Format.hs b/src/Granite/Format.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Format.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Format +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Apply a declarative 'Formatter' to a 'Double'. Replaces the +function-typed @LabelFormatter@ used by the legacy 'Granite.Plot' +record, so the entire chart spec can stay JSON-shaped. +-} +module Granite.Format ( + Formatter (..), + runFormatter, +) where + +import Data.Text (Text) +import Data.Text qualified as Text +import Numeric (showEFloat, showFFloat) + +{- | A declarative formatter applied to numeric tick / label values. + +The /Default/ behaves like the legacy formatter: scientific for +very small or very large magnitudes, fixed-point with one decimal +otherwise. The other constructors give the caller explicit control +without needing to embed a Haskell function in the spec. +-} +data Formatter + = FormatDefault + | -- | fixed point with the given decimals + FormatPrecision Int + | -- | scientific notation with the given decimals + FormatScientific Int + | -- | percentage (multiplies by 100), with given decimals + FormatPercent Int + | -- | integer with comma grouping (1,234,567) + FormatComma + | {- | epoch-millisecond value formatted with the given strftime-style + pattern; unsupported in this phase, returns the raw value. + -} + FormatDateTime !Text + | {- | a printf-like template with a single \"{}" placeholder. + This phase only supports \"{}" itself. + -} + FormatTemplate !Text + | -- | SI suffixes (1.2k, 3.4M) + FormatSI + deriving (Eq, Show, Read) + +runFormatter :: Formatter -> Double -> Text +runFormatter f v = case f of + FormatDefault -> defaultFmt v + FormatPrecision n -> Text.pack (showFFloat (Just n) v "") + FormatScientific n -> Text.pack (showEFloat (Just n) v "") + FormatPercent n -> Text.pack (showFFloat (Just n) (v * 100) "") <> "%" + FormatComma -> commaGroup (round v :: Integer) + FormatDateTime _ -> Text.pack (show v) + FormatTemplate t -> Text.replace "{}" (defaultFmt v) t + FormatSI -> siSuffix v + +defaultFmt :: Double -> Text +defaultFmt v + | abs v >= 10000 || abs v < 0.01 && v /= 0 = + Text.pack (showEFloat (Just 1) v "") + | otherwise = Text.pack (showFFloat (Just 1) v "") + +commaGroup :: Integer -> Text +commaGroup n = + let neg = n < 0 + digits = reverse (show (abs n)) + chunks = chunkN 3 digits + grouped = reverse (intercalateRev "," chunks) + in (if neg then "-" else "") <> Text.pack grouped + +chunkN :: Int -> [a] -> [[a]] +chunkN _ [] = [] +chunkN n xs = take n xs : chunkN n (drop n xs) + +intercalateRev :: [a] -> [[a]] -> [a] +intercalateRev sep = go + where + go [] = [] + go [x] = x + go (x : xs) = x ++ sep ++ go xs + +siSuffix :: Double -> Text +siSuffix v + | a >= 1e12 = fmt (v / 1e12) "T" + | a >= 1e9 = fmt (v / 1e9) "G" + | a >= 1e6 = fmt (v / 1e6) "M" + | a >= 1e3 = fmt (v / 1e3) "k" + | a >= 1 = Text.pack (showFFloat (Just 1) v "") + | a >= 1e-3 = fmt (v * 1e3) "m" + | a >= 1e-6 = fmt (v * 1e6) "\x00b5" + | otherwise = Text.pack (showEFloat (Just 1) v "") + where + a = abs v + fmt x suf = Text.pack (showFFloat (Just 1) x "") <> suf diff --git a/src/Granite/Internal/LegacyChart.hs b/src/Granite/Internal/LegacyChart.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Internal/LegacyChart.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Internal.LegacyChart +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Chart builders shared between 'Granite' and 'Granite.Svg' for the +plotly-express-style helpers (area, ribbon, density, errorBars, +funnel, polarLine, waterfall, distPlot). +-} +module Granite.Internal.LegacyChart ( + Chart, + plotChart, + areaChart, + ribbonChart, + densityChart, + errorBarsChart, + funnelChart, + polarLineChart, + waterfallChart, + distPlotChart, +) where + +import Data.Text (Text) +import Data.Text qualified as Text + +import Granite.Data.Frame (Column (..), fromColumns) +import Granite.Spec + +plotChart :: Int -> Int -> Text -> Chart -> Chart +plotChart w h title chart = + chart + { chartSize = SizeChars w h + , chartTitle = if Text.null title then Nothing else Just title + } + +areaChart :: [(Text, [(Double, Double)])] -> Int -> Int -> Text -> Chart +areaChart series w h title = + let layers = concatMap mkSeries series + in plotChart w h title $ emptyChart{chartLayers = layers} + where + mkSeries (name, pts) = + let xs = map fst pts + ys = map snd pts + zeros = replicate (length pts) 0 :: [Double] + df = + fromColumns + [ ("x", ColNum xs) + , ("y", ColNum ys) + , ("ymin", ColNum zeros) + ] + ribbonL = + (defLayer GeomRibbon) + { layerData = Just df + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesYmin = Just (ColumnRef "ymin") + , aesYmax = Just (ColumnRef "y") + , aesGroup = Just (ColumnRef name) + } + , layerAesDef = emptyAesDefaults{defAlpha = Just 0.35} + } + lineL = + (defLayer GeomLine) + { layerData = Just df + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesGroup = Just (ColumnRef name) + } + } + in [ribbonL, lineL] + +ribbonChart :: + [(Text, [(Double, Double, Double)])] -> + Int -> + Int -> + Text -> + Chart +ribbonChart series w h title = + let layers = map mkLayer series + in plotChart w h title $ emptyChart{chartLayers = layers} + where + mkLayer (name, pts) = + let xs = [x | (x, _, _) <- pts] + los = [l | (_, l, _) <- pts] + his = [hi | (_, _, hi) <- pts] + df = + fromColumns + [ ("x", ColNum xs) + , ("ymin", ColNum los) + , ("ymax", ColNum his) + ] + in (defLayer GeomRibbon) + { layerData = Just df + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesYmin = Just (ColumnRef "ymin") + , aesYmax = Just (ColumnRef "ymax") + , aesGroup = Just (ColumnRef name) + } + , layerAesDef = emptyAesDefaults{defAlpha = Just 0.4} + } + +densityChart :: [(Text, [Double])] -> Int -> Int -> Text -> Chart +densityChart series w h title = + let layers = map mkLayer series + in plotChart w h title $ emptyChart{chartLayers = layers} + where + mkLayer (name, sample) = + let df = fromColumns [("x", ColNum sample)] + in (defLayer GeomDensity) + { layerData = Just df + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "density") + , aesGroup = Just (ColumnRef name) + } + , layerStat = StatDensity + } + +errorBarsChart :: + [(Text, [(Double, Double, Double, Double)])] -> + Int -> + Int -> + Text -> + Chart +errorBarsChart series w h title = + let layers = concatMap mkSeries series + in plotChart w h title $ emptyChart{chartLayers = layers} + where + mkSeries (name, rows) = + let xs = [x | (x, _, _, _) <- rows] + ys = [y | (_, y, _, _) <- rows] + los = [l | (_, _, l, _) <- rows] + his = [hi | (_, _, _, hi) <- rows] + df = + fromColumns + [ ("x", ColNum xs) + , ("y", ColNum ys) + , ("lo", ColNum los) + , ("hi", ColNum his) + ] + m = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesYmin = Just (ColumnRef "lo") + , aesYmax = Just (ColumnRef "hi") + , aesGroup = Just (ColumnRef name) + } + bars = + (defLayer GeomErrorbar) + { layerData = Just df + , layerMapping = m + , layerStat = StatIdentity + } + pts = + (defLayer GeomPoint) + { layerData = Just df + , layerMapping = m + , layerStat = StatIdentity + } + in [bars, pts] + +funnelChart :: [(Text, Double)] -> Int -> Int -> Text -> Chart +funnelChart stages w h title = + let names = [n | (n, _) <- stages] + values = [v | (_, v) <- stages] + df = + fromColumns + [ ("stage", ColCat names) + , ("value", ColNum values) + ] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "stage") + , aesY = Just (ColumnRef "value") + } + , layerStat = StatIdentity + } + in plotChart w h title $ + emptyChart + { chartData = df + , chartLayers = [layer] + , chartCoord = CoordFlip + } + +polarLineChart :: [(Text, [(Double, Double)])] -> Int -> Int -> Text -> Chart +polarLineChart series w h title = + let layers = map mkLayer series + in plotChart w h title $ + emptyChart + { chartLayers = layers + , chartCoord = CoordPolar ThetaX 0 PolarCCW + } + where + mkLayer (name, pts) = + let thetas = [t | (t, _) <- pts] + rs = [r | (_, r) <- pts] + df = fromColumns [("theta", ColNum thetas), ("r", ColNum rs)] + in (defLayer GeomLine) + { layerData = Just df + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "theta") + , aesY = Just (ColumnRef "r") + , aesGroup = Just (ColumnRef name) + } + } + +waterfallChart :: [(Text, Double, Double)] -> Int -> Int -> Text -> Chart +waterfallChart rows w h title = + let labels = [n | (n, _, _) <- rows] + starts = [s | (_, s, _) <- rows] + ends = [e | (_, _, e) <- rows] + df = + fromColumns + [ ("x", ColCat labels) + , ("y", ColNum ends) + , ("__ybase", ColNum starts) + ] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + , layerStat = StatIdentity + } + in plotChart w h title $ + emptyChart + { chartData = df + , chartLayers = [layer] + } + +distPlotChart :: [(Text, [Double])] -> Int -> Int -> Text -> Chart +distPlotChart series w h title = + let layers = concatMap mkSeries series + in plotChart w h title $ emptyChart{chartLayers = layers} + where + mkSeries (name, sample) = + let df = fromColumns [("x", ColNum sample)] + hist = + (defLayer GeomHistogram) + { layerData = Just df + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "count") + , aesGroup = Just (ColumnRef name) + } + , layerStat = StatBin (BinByCount 20) + , layerAesDef = emptyAesDefaults{defAlpha = Just 0.6} + } + kde = + (defLayer GeomDensity) + { layerData = Just df + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "density") + , aesGroup = Just (ColumnRef name) + } + , layerStat = StatDensity + } + in [hist, kde] diff --git a/src/Granite/Internal/Util.hs b/src/Granite/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Internal/Util.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Internal.Util +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Internal helpers shared across backends. +-} +module Granite.Internal.Util ( + clamp, + eps, + minimum', + maximum', + mod', + angleWithin, + quartiles, + normalize, + setAt, + updateAt, + addAt, + gridWidth, + wcswidth, + ellipsisize, + justifyRight, + showD, + escXml, + ticks1D, +) where + +import Data.List qualified as List +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Numeric (showFFloat) + +clamp :: (Ord a) => a -> a -> a -> a +clamp low high x = max low (min high x) + +eps :: Double +eps = 1e-12 + +minimum', maximum' :: [Double] -> Double +minimum' [] = 0 +minimum' xs = minimum xs +maximum' [] = 1 +maximum' xs = maximum xs + +mod' :: Double -> Double -> Double +mod' a m = a - fromIntegral (floor (a / m) :: Int) * m + +angleWithin :: Double -> Double -> Double -> Bool +angleWithin ang a0 a1 + | a1 >= a0 = ang >= a0 && ang <= a1 + | otherwise = ang >= a0 || ang <= a1 + +{- | Five-number summary: @(min, Q1, median, Q3, max)@. For @n < 5@, +all five values collapse to the mean. +-} +quartiles :: [Double] -> (Double, Double, Double, Double, Double) +quartiles [] = (0, 0, 0, 0, 0) +quartiles xs = + let sorted = List.sort xs + n = length sorted + q1Idx = n `div` 4 + q2Idx = n `div` 2 + q3Idx = 3 * n `div` 4 + getIdx i = if i < n then sorted !! i else last sorted + in if n < 5 + then let m = sum xs / fromIntegral n in (m, m, m, m, m) + else + ( fromMaybe 0 (listToMaybe sorted) + , getIdx q1Idx + , getIdx q2Idx + , getIdx q3Idx + , last sorted + ) + +normalize :: [(Text, Double)] -> [(Text, Double)] +normalize xs = + let s = sum (map (abs . snd) xs) + 1e-12 + in [(n, max 0 (v / s)) | (n, v) <- xs] + +setAt :: [a] -> Int -> a -> [a] +setAt xs i v = updateAt xs i (const v) + +updateAt :: [a] -> Int -> (a -> a) -> [a] +updateAt xs i f + | i < 0 = xs + | otherwise = go xs i + where + go [] _ = [] + go (x : rest) 0 = f x : rest + go (x : rest) n = x : go rest (n - 1) + +addAt :: [Int] -> Int -> Int -> [Int] +addAt xs i v = updateAt xs i (+ v) + +gridWidth :: [[a]] -> Int +gridWidth [] = 0 +gridWidth (x : _) = length x + +-- | Visible width of text, skipping ANSI escape sequences. +wcswidth :: Text -> Int +wcswidth = go 0 + where + go acc xs + | Text.null xs = acc + | Text.isPrefixOf "\ESC[" xs = + let rest' = Text.dropWhile (/= 'm') xs + in if Text.null rest' then acc else go acc (Text.tail rest') + | otherwise = go (acc + 1) (Text.tail xs) + +{- | Ensure the text fits within maxWidth. If it doesn't, truncate and append an ellipsis. +>>> ellipsisize 5 "Hello, World!" +"Hell\8230" +>>> ellipsisize 1 "Hi" +"\8230" +>>> ellipsisize 0 "Hello, World!" +"" +>>> ellipsisize 20 "Hello, World!" +"Hello, World!" +-} +ellipsisize :: Int -> Text -> Text +ellipsisize maxWidth lbl + | maxWidth <= 0 = "" + | wcswidth lbl > maxWidth = Text.take (maxWidth - 1) lbl <> "…" + | otherwise = lbl + +justifyRight :: Int -> Text -> Text +justifyRight n s = Text.replicate (max 0 (n - wcswidth s)) " " <> s + +showD :: Double -> Text +showD d + | d == fromIntegral (round d :: Int) = Text.pack (show (round d :: Int)) + | otherwise = Text.pack (showFFloat (Just 2) d "") + +escXml :: Text -> Text +escXml = + Text.replace "&" "&" + . Text.replace "<" "<" + . Text.replace ">" ">" + . Text.replace "\"" """ + +{- | Evenly spaced tick positions in screen space paired with data values. +With @invertY = True@, position 0 maps to @vmax@ (top row). +-} +ticks1D :: Int -> Int -> (Double, Double) -> Bool -> [(Int, Double)] +ticks1D screenLen want (vmin, vmax) invertY = + let n = max 2 want + lastIx = max 0 (screenLen - 1) + toVal t = + if invertY + then vmax - t * (vmax - vmin) + else vmin + t * (vmax - vmin) + mk' k = + let t = if n == 1 then 0 else fromIntegral k / fromIntegral (n - 1) + pos = round (t * fromIntegral lastIx) + in (pos, toVal t) + raw = [mk' k | k <- [0 .. n - 1]] + in List.nubBy (\a b -> fst a == fst b) raw diff --git a/src/Granite/Position.hs b/src/Granite/Position.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Position.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Position +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Position adjustments — 'PosStack', 'PosFill', 'PosDodge', 'PosJitter'. +Operates on long-format frames; @stack@ and @fill@ additionally write +a @__ybase@ column for the bar bottom. +-} +module Granite.Position ( + applyPosition, +) where + +import Data.List qualified as List +import Data.Text (Text) + +import Granite.Data.Frame ( + Column (..), + DataFrame (..), + columnAsNum, + columnAsText, + fromColumns, + lookupColumn, + ) +import Granite.Spec ( + ColumnRef (..), + Mapping (..), + Position (..), + ) + +applyPosition :: Position -> Mapping -> DataFrame -> DataFrame +applyPosition pos m df = case pos of + PosIdentity -> df + PosStack -> stackPos False m df + PosFill -> stackPos True m df + PosDodge gap -> dodgePos gap m df + PosJitter dx dy -> jitterPos dx dy m df + +stackPos :: Bool -> Mapping -> DataFrame -> DataFrame +stackPos fill m df = + case ( numColAt (aesX m) df + , numColAt (aesY m) df + ) of + (Just xs, Just ys) -> + let gs = groupKeys m df (length xs) + rows = zip3 xs ys gs + uniqXs = List.nub xs + stackedPerX = + concatMap + ( \x -> + let here = [(x', y', g') | (x', y', g') <- rows, x' == x] + ordered = List.sortOn (\(_, _, g) -> seriesIx gs g) here + running = scanl (+) 0 [y | (_, y, _) <- ordered] + tops = drop 1 running + bots = init running + segs = zip3 ordered tops bots + total = last running + norm = if fill && total /= 0 then 1 / total else 1 + in [(xi, yi * norm, gi, top * norm, bot * norm) | ((xi, yi, gi), top, bot) <- segs] + ) + uniqXs + xs' = [x | (x, _, _, _, _) <- stackedPerX] + ys' = [y | (_, _, _, y, _) <- stackedPerX] + bases = [b | (_, _, _, _, b) <- stackedPerX] + gs' = [g | (_, _, g, _, _) <- stackedPerX] + xName = refName (aesX m) "x" + yName = refName (aesY m) "y" + gName = case groupRef m of + Just (ColumnRef n) -> n + Nothing -> "_group" + base0 = [(xName, ColNum xs'), (yName, ColNum ys'), ("__ybase", ColNum bases)] + cols = + if isJustGroup m + then base0 <> [(gName, ColCat gs')] + else base0 + in fromColumns cols + _ -> df + +dodgePos :: Double -> Mapping -> DataFrame -> DataFrame +dodgePos gap m df = + case numColAt (aesX m) df of + Just xs -> + let gs = groupKeys m df (length xs) + seriesOrder = List.nub gs + nSeries = max 1 (length seriesOrder) + center = fromIntegral (nSeries - 1) / 2 + shifted = + [ x + gap * (fromIntegral (seriesIx gs g) - center) + | (x, g) <- zip xs gs + ] + xName = refName (aesX m) "x" + in replaceColumn xName (ColNum shifted) df + _ -> df + +{- | Deterministic jitter via the golden-ratio low-discrepancy +sequence, so two runs on the same data produce the same offsets +(golden tests stay stable). +-} +jitterPos :: Double -> Double -> Mapping -> DataFrame -> DataFrame +jitterPos dx dy m df = + let phi = (sqrt 5 - 1) / 2 :: Double + wobble seed i = + let r = (fromIntegral i + 1) * phi + seed + in (r - fromIntegral (floor r :: Int)) - 0.5 + update mc seedScale axis col = case col of + Just (ColumnRef name) -> case lookupColumn name df of + Just (ColNum vs) -> + let vs' = [v + axis * 2 * wobble seedScale i | (i, v) <- zip [0 :: Int ..] vs] + in replaceColumn name (ColNum vs') mc + _ -> mc + Nothing -> mc + df1 = update df 0.123 dx (aesX m) + df2 = update df1 0.789 dy (aesY m) + in df2 + +{- | A 'ColCat' column projects each row to its index in the +unique-value list, so stack / dodge group rows that share a +category. +-} +numColAt :: Maybe ColumnRef -> DataFrame -> Maybe [Double] +numColAt Nothing _ = Nothing +numColAt (Just (ColumnRef n)) df = + case lookupColumn n df of + Just (ColCat xs) -> + let uniques = List.nub xs + indexOf x = maybe 0 fromIntegral (List.elemIndex x uniques) + in Just (map indexOf xs) + Just c -> columnAsNum c + Nothing -> Nothing + +groupRef :: Mapping -> Maybe ColumnRef +groupRef m = case aesGroup m of + Just r -> Just r + Nothing -> case aesColor m of + Just r -> Just r + Nothing -> aesFill m + +isJustGroup :: Mapping -> Bool +isJustGroup m = case groupRef m of + Just _ -> True + Nothing -> False + +groupKeys :: Mapping -> DataFrame -> Int -> [Text] +groupKeys m df fallbackLen = case groupRef m of + Just (ColumnRef n) -> case lookupColumn n df of + Just c -> columnAsText c + Nothing -> replicate fallbackLen "all" + Nothing -> replicate fallbackLen "all" + +seriesIx :: [Text] -> Text -> Int +seriesIx all_ k = + let order = List.nub all_ + go _ [] = 0 + go i (x : xs) = if x == k then i else go (i + 1) xs + in go 0 order + +refName :: Maybe ColumnRef -> Text -> Text +refName (Just (ColumnRef n)) _ = n +refName Nothing fb = fb + +replaceColumn :: Text -> Column -> DataFrame -> DataFrame +replaceColumn name col (DataFrame cols) + | any ((== name) . fst) cols = + DataFrame [(n, if n == name then col else c) | (n, c) <- cols] + | otherwise = DataFrame (cols <> [(name, col)]) diff --git a/src/Granite/Render/Chrome.hs b/src/Granite/Render/Chrome.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Render/Chrome.hs @@ -0,0 +1,339 @@ + +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Render.Chrome +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Backend-agnostic chart chrome: axes, title, legend. Each helper +returns a list of primitive 'Mark's. +-} +module Granite.Render.Chrome ( + PlotBox (..), + computePlotBox, + axesMarks, + titleMarks, + legendMarks, +) where + +import Data.Text (Text) +import Data.Text qualified as Text + +import Granite.Color (Color (..)) +import Granite.Render.Scene ( + Mark (..), + Point (..), + Rect (..), + Style (..), + TextAnchor (..), + TextStyle (..), + defaultStyle, + defaultTextStyle, + pxPerChar, + pxPerLine, + ) +import Granite.Scale (TrainedScale (..)) +import Granite.Spec ( + ColorSpec (..), + Coord (..), + PolarAes (..), + PolarDir (..), + Size (..), + Theme (..), + ) + +{- | Pixel rectangle the chart body occupies, plus the overall scene +bounds. Margins around the plot area host title, axis labels, legend. +-} +data PlotBox = PlotBox + { boxSceneW :: !Double + , boxSceneH :: !Double + , boxX :: !Double + , boxY :: !Double + , boxW :: !Double + , boxH :: !Double + } + deriving (Eq, Show) + +computePlotBox :: Size -> Theme -> Bool -> Bool -> Bool -> PlotBox +computePlotBox sz theme hasTitle hasRightLegend hasBottomLegend = + let (sceneW, sceneH) = case sz of + SizeChars w h -> + (fromIntegral w * themePxPerChar theme, fromIntegral h * themePxPerLine theme) + SizePixels w h -> (fromIntegral w, fromIntegral h) + SizeResponsive ar -> + let h = 320 + in (h * ar, h) + topMargin = if hasTitle then themeTitleSize theme + 20 else 10 + bottomMargin = (if hasBottomLegend then 30 else 0) + themeFontSize theme * 1.8 + 8 + leftMargin = themeFontSize theme * 5 + rightMargin = if hasRightLegend then 120 else 20 + plotW = max 1 (sceneW - leftMargin - rightMargin) + plotH = max 1 (sceneH - topMargin - bottomMargin) + in PlotBox sceneW sceneH leftMargin topMargin plotW plotH + +axesMarks :: Theme -> PlotBox -> Coord -> TrainedScale -> TrainedScale -> [Mark] +axesMarks theme box coord xs ys = case coord of + CoordCartesian -> cartesianAxes theme box False xs ys + -- CoordFlip rotates 90° CW so the Y axis grows top-down. + CoordFlip -> cartesianAxes theme box True ys xs + CoordPolar aes a0 dir -> polarAxes theme box aes a0 dir xs ys + +{- | Axes are 'MAxisLine' spines (clean box-drawing chars in terminal, +@@ in SVG). Gridlines and tick stubs are omitted so the +terminal output stays uncluttered; tick /labels/ sit beside each +break. @flipY@ inverts Y for 'CoordFlip'. +-} +cartesianAxes :: + Theme -> PlotBox -> Bool -> TrainedScale -> TrainedScale -> [Mark] +cartesianAxes theme box flipY xs ys = + let axisColor = colorOfSpec (themeAxisColor theme) + textColor = colorOfSpec (themeTextColor theme) + + px = boxX box + py = boxY box + pw = boxW box + ph = boxH box + + spineStyle = defaultStyle{styleStroke = Just axisColor, styleStrokeWidth = 1} + + xAxis = MAxisLine (Point px (py + ph)) (Point (px + pw) (py + ph)) spineStyle + yAxis = MAxisLine (Point px py) (Point px (py + ph)) spineStyle + + xLabels = + [ MText + (Point xPos (py + ph + themeFontSize theme + 4)) + lbl + defaultTextStyle + { textFill = textColor + , textSize = themeFontSize theme + , textAnchor = AnchorMiddle + } + | (v, lbl) <- zip (tsBreaks xs) (tsLabels xs) + , inDomain (tsDomain xs) v + , let xPos = px + tsProject xs v * pw + ] + + yLabels = + [ MText + (Point (px - 6) (yPos + themeFontSize theme / 3)) + lbl + defaultTextStyle + { textFill = textColor + , textSize = themeFontSize theme + , textAnchor = AnchorEnd + } + | (v, lbl) <- zip (tsBreaks ys) (tsLabels ys) + , inDomain (tsDomain ys) v + , let yPos = + if flipY + then py + tsProject ys v * ph + else py + ph - tsProject ys v * ph + ] + in [xAxis, yAxis] <> xLabels <> yLabels + +{- | Concentric rings (radial breaks) + radial spokes (angular breaks) ++ tick labels. Centred in the plot box with radius = half its +shortest side. +-} +polarAxes :: + Theme -> + PlotBox -> + PolarAes -> + Double -> + PolarDir -> + TrainedScale -> + TrainedScale -> + [Mark] +polarAxes theme box aes a0 dir xs ys = + let cx = boxX box + boxW box / 2 + cy = boxY box + boxH box / 2 + maxR = min (boxW box) (boxH box) / 2 + gridColor = colorOfSpec (themeGridColor theme) + axisColor = colorOfSpec (themeAxisColor theme) + textColor = colorOfSpec (themeTextColor theme) + sign = case dir of + PolarCW -> 1 + PolarCCW -> -1 :: Double + + (thetaScale, radialScale) = case aes of + ThetaX -> (xs, ys) + ThetaY -> (ys, xs) + + circleAt :: Double -> Maybe Color -> Double -> Mark + circleAt rPx stroke widthPx = + let nSeg = 64 :: Int + pts = + [ Point (cx + rPx * cos a) (cy + rPx * sin a) + | i <- [0 .. nSeg] + , let a = (fromIntegral i / fromIntegral nSeg) * 2 * pi + ] + in MPolyline pts defaultStyle{styleStroke = stroke, styleStrokeWidth = widthPx} + + rings = + [ circleAt (tsProject radialScale v * maxR) (Just gridColor) 0.5 + | v <- tsBreaks radialScale + , inDomain (tsDomain radialScale) v + , tsProject radialScale v > 1e-6 + ] + + outerRing = circleAt maxR (Just axisColor) 1 + + spokeFor v = + let t = tsProject thetaScale v + theta = a0 + sign * t * 2 * pi + ox = cx + maxR * cos theta + oy = cy + maxR * sin theta + in MPolyline + [Point cx cy, Point ox oy] + defaultStyle{styleStroke = Just gridColor, styleStrokeWidth = 0.5} + spokes = + [ spokeFor v + | v <- tsBreaks thetaScale + , inDomain (tsDomain thetaScale) v + ] + + thetaLabelOffset = 10 + thetaLabels = + [ MText + ( Point + (cx + (maxR + thetaLabelOffset) * cos theta) + (cy + (maxR + thetaLabelOffset) * sin theta + themeFontSize theme / 3) + ) + lbl + defaultTextStyle + { textFill = textColor + , textSize = themeFontSize theme + , textAnchor = AnchorMiddle + } + | (v, lbl) <- zip (tsBreaks thetaScale) (tsLabels thetaScale) + , inDomain (tsDomain thetaScale) v + , let theta = a0 + sign * tsProject thetaScale v * 2 * pi + ] + + rLabels = + [ MText + ( Point + (cx + rPx * cos a0 + 3) + (cy + rPx * sin a0 - 2) + ) + lbl + defaultTextStyle + { textFill = textColor + , textSize = themeFontSize theme + , textAnchor = AnchorStart + } + | (v, lbl) <- zip (tsBreaks radialScale) (tsLabels radialScale) + , inDomain (tsDomain radialScale) v + , let rPx = tsProject radialScale v * maxR + , rPx > 1e-6 + ] + in rings <> spokes <> [outerRing] <> thetaLabels <> rLabels + +inDomain :: (Double, Double) -> Double -> Bool +inDomain (lo, hi) v = v >= lo - 1e-9 && v <= hi + 1e-9 + +titleMarks :: Theme -> PlotBox -> Maybe Text -> [Mark] +titleMarks _ _ Nothing = [] +titleMarks _ _ (Just t) | Text.null t = [] +titleMarks theme box (Just t) = + [ MText + (Point (boxX box + boxW box / 2) (boxY box - 8)) + t + defaultTextStyle + { textFill = colorOfSpec (themeTextColor theme) + , textSize = themeTitleSize theme + , textAnchor = AnchorMiddle + } + ] + +legendMarks :: Theme -> PlotBox -> [(Text, ColorSpec)] -> [Mark] +legendMarks theme box entries = + let lx = boxX box + boxW box + 15 + ly = boxY box + 5 + rowH = themeFontSize theme + 6 + in concat + [ let yy = ly + fromIntegral i * rowH + swatch = + MRect + (Rect lx yy 12 12) + defaultStyle{styleFill = Just (colorOfSpec col)} + label = + MText + (Point (lx + 16) (yy + themeFontSize theme - 1)) + name + defaultTextStyle + { textFill = colorOfSpec (themeTextColor theme) + , textSize = themeFontSize theme + , textAnchor = AnchorStart + } + in [swatch, label] + | (i, (name, col)) <- zip [0 :: Int ..] entries + ] + +{- | Quantise a 'ColorSpec' to the nearest ANSI 'Color' for the +terminal backend; SVG reads RGB / Hex directly. +-} +colorOfSpec :: ColorSpec -> Color +colorOfSpec (NamedColor c) = c +colorOfSpec (RGB r g b) = nearestAnsi (fromIntegral r) (fromIntegral g) (fromIntegral b) +colorOfSpec (Hex h) = + case parseHex h of + Just (r, g, b) -> nearestAnsi r g b + Nothing -> Default + +parseHex :: Text -> Maybe (Double, Double, Double) +parseHex t = + let s = Text.unpack (Text.dropWhile (== '#') t) + in case s of + [a, b, c, d, e, f] -> + (,,) <$> fromHex2 [a, b] <*> fromHex2 [c, d] <*> fromHex2 [e, f] + _ -> Nothing + +fromHex2 :: String -> Maybe Double +fromHex2 [a, b] = do + h <- digit a + l <- digit b + pure (fromIntegral (h * 16 + l)) + where + digit ch + | isDigit ch = Just (fromEnum ch - fromEnum '0') + | ch >= 'a' && ch <= 'f' = Just (10 + fromEnum ch - fromEnum 'a') + | ch >= 'A' && ch <= 'F' = Just (10 + fromEnum ch - fromEnum 'A') + | otherwise = Nothing +fromHex2 _ = Nothing + +{- | Nearest of the 16 ANSI colors using the canonical VGA palette +(not the pastel SVG hex values). Important for visibility: mid-gray +@#555555@ maps to 'BrightBlack' (a real grey), not 'Black' (which +would be invisible on a dark terminal). +-} +nearestAnsi :: Double -> Double -> Double -> Color +nearestAnsi r g b = + let candidates = + [ (Black, 0, 0, 0) + , (Red, 170, 0, 0) + , (Green, 0, 170, 0) + , (Yellow, 170, 85, 0) + , (Blue, 0, 0, 170) + , (Magenta, 170, 0, 170) + , (Cyan, 0, 170, 170) + , (White, 170, 170, 170) + , (BrightBlack, 85, 85, 85) + , (BrightRed, 255, 85, 85) + , (BrightGreen, 85, 255, 85) + , (BrightYellow, 255, 255, 85) + , (BrightBlue, 85, 85, 255) + , (BrightMagenta, 255, 85, 255) + , (BrightCyan, 85, 255, 255) + , (BrightWhite, 255, 255, 255) + ] + dist (_, cr, cg, cb) = sq (r - cr) + sq (g - cg) + sq (b - cb) + sq x = x * x + pick (best, bd) cand = + let d = dist cand + in if d < bd then (fstC cand, d) else (best, bd) + fstC (c, _, _, _) = c + in fst (foldl pick (Default, 1 / 0) candidates) diff --git a/src/Granite/Render/Pipeline.hs b/src/Granite/Render/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Render/Pipeline.hs @@ -0,0 +1,896 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Render.Pipeline +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Chart → Scene pipeline. 'chartToScene' compiles a 'Chart' spec into +a backend-agnostic 'Scene'; 'renderChartTerminal' and +'renderChartSvg' pair it with the matching backend. +-} +module Granite.Render.Pipeline ( + renderChart, + renderChartTerminal, + renderChartSvg, + chartToScene, +) where + +import Data.List qualified as List +import Data.Text (Text) +import Data.Text qualified as Text + +import Granite.Color (Color (..)) +import Granite.Data.Frame ( + Column (..), + DataFrame (..), + columnAsNum, + columnAsText, + filterByRows, + lookupColumn, + ) +import Granite.Position (applyPosition) +import Granite.Render.Chrome ( + PlotBox (..), + axesMarks, + computePlotBox, + legendMarks, + titleMarks, + ) +import Granite.Render.Scene ( + Mark (..), + Point (..), + Rect (..), + Scene (..), + Style (..), + TextAnchor (..), + TextStyle (..), + defaultStyle, + defaultTextStyle, + ) +import Granite.Render.Svg qualified as Svg +import Granite.Render.Terminal qualified as Terminal +import Granite.Scale (TrainedScale (..), train) +import Granite.Spec ( + AesDefaults (..), + Chart (..), + ColorSpec (..), + ColumnRef (..), + Coord (..), + Facet (..), + FacetScales (..), + Geom (..), + Layer (..), + Mapping (..), + PolarAes (..), + PolarDir (..), + Scales (..), + Size (..), + Theme (..), + aesX, + aesY, + ) +import Granite.Stat (applyStat) + +type Projector = Double -> Double -> Point + +buildProjector :: Coord -> PlotBox -> TrainedScale -> TrainedScale -> Projector +buildProjector c box xs ys = case c of + CoordCartesian -> cartesianProjector box xs ys + CoordFlip -> flipProjector box xs ys + CoordPolar aes a0 dir -> polarProjector aes a0 dir box xs ys + +cartesianProjector :: PlotBox -> TrainedScale -> TrainedScale -> Projector +cartesianProjector box xs ys x y = + Point + (boxX box + tsProject xs x * boxW box) + (boxY box + boxH box - tsProject ys y * boxH box) + +{- | 'CoordFlip' rotates the chart 90° clockwise: the X aesthetic +projects top-down (data x=0 → top), matching ggplot @coord_flip()@ +and Plotly's horizontal-bar / funnel convention. +-} +flipProjector :: PlotBox -> TrainedScale -> TrainedScale -> Projector +flipProjector box xs ys x y = + Point + (boxX box + tsProject ys y * boxW box) + (boxY box + tsProject xs x * boxH box) + +polarProjector :: + PolarAes -> + Double -> + PolarDir -> + PlotBox -> + TrainedScale -> + TrainedScale -> + Projector +polarProjector aes a0 dir box xs ys = + let cx = boxX box + boxW box / 2 + cy = boxY box + boxH box / 2 + maxR = min (boxW box) (boxH box) / 2 + sign = case dir of + PolarCW -> 1 + PolarCCW -> -1 + in \x y -> + let (tVal, rVal) = case aes of + ThetaX -> (tsProject xs x, tsProject ys y) + ThetaY -> (tsProject ys y, tsProject xs x) + theta = a0 + sign * tVal * 2 * pi + r = rVal * maxR + in Point (cx + r * cos theta) (cy + r * sin theta) + +renderChartTerminal :: Chart -> Text +renderChartTerminal = Terminal.renderScene . chartToScene + +{- | SVG render; uses responsive sizing when 'chartSize' is +'SizeResponsive', explicit pixel dimensions otherwise. +-} +renderChartSvg :: Chart -> Text +renderChartSvg chart = + let render = case chartSize chart of + SizeResponsive _ -> Svg.renderSceneResponsive + _ -> Svg.renderScene + in render (chartToScene chart) + +renderChart :: Chart -> (Text, Text) +renderChart c = (renderChartTerminal c, renderChartSvg c) + +chartToScene :: Chart -> Scene +chartToScene chart = + let theme = chartTheme chart + palette = themePalette theme + coord = chartCoord chart + hasTitle = case chartTitle chart of + Just t -> not (Text.null t) + Nothing -> False + legendEntries = collectLegend (chartLayers chart) palette + hasRightLegend = not (null legendEntries) + box = computePlotBox (chartSize chart) theme hasTitle hasRightLegend False + + panels = layoutPanels theme box chart + panelMarks = concatMap (renderPanel theme palette coord) panels + + legend = legendMarks theme box legendEntries + title = titleMarks theme box (chartTitle chart) + + marks = panelMarks <> title <> legend + in Scene (boxSceneW box) (boxSceneH box) marks + +data PanelSpec = PanelSpec + { panelBox :: PlotBox + , panelLabel :: Text + , panelData :: DataFrame + , panelLayers :: [Layer] + , panelXScale :: TrainedScale + , panelYScale :: TrainedScale + } + +renderPanel :: Theme -> [ColorSpec] -> Coord -> PanelSpec -> [Mark] +renderPanel theme palette coord ps = + let proj = buildProjector coord (panelBox ps) (panelXScale ps) (panelYScale ps) + layerMarks = + concat + [ runLayer theme (panelBox ps) proj palette i (panelData ps) layer + | (i, layer) <- zip [0 :: Int ..] (panelLayers ps) + ] + axes = axesMarks theme (panelBox ps) coord (panelXScale ps) (panelYScale ps) + strip = stripMark theme (panelBox ps) (panelLabel ps) + in axes <> layerMarks <> strip + +stripMark :: Theme -> PlotBox -> Text -> [Mark] +stripMark theme box label + | Text.null label = [] + | otherwise = + [ MText + (Point (boxX box + boxW box / 2) (boxY box - 4)) + label + defaultTextStyle + { textFill = colorOfSpec (themeTextColor theme) + , textSize = themeFontSize theme + , textAnchor = AnchorMiddle + } + ] + where + colorOfSpec spec = case spec of + NamedColor c -> c + _ -> Default + +layoutPanels :: Theme -> PlotBox -> Chart -> [PanelSpec] +layoutPanels theme box chart = case chartFacet chart of + FacetNull -> + [singlePanel chart box ""] + FacetWrap colRef mNcol mNrow scalesMode -> + let keys = facetKeys colRef (chartData chart) (chartLayers chart) + in case keys of + [] -> [singlePanel chart box ""] + _ -> + let n = length keys + (nrow, ncol) = wrapDims n mNcol mNrow + cells = gridCells theme box nrow ncol + in [ panelFor chart colRef key scalesMode cellBox + | (key, cellBox) <- zip keys cells + ] + FacetGrid rowRefs colRefs scalesMode -> + let (rowKeys, colKeys) = gridKeys rowRefs colRefs (chartData chart) (chartLayers chart) + rowKeys' = if null rowKeys then [""] else rowKeys + colKeys' = if null colKeys then [""] else colKeys + nrow = length rowKeys' + ncol = length colKeys' + cells = gridCells theme box nrow ncol + in [ gridPanel chart rowRefs colRefs rowKey colKey scalesMode cellBox + | (rowKey, rowIx) <- zip rowKeys' [0 :: Int ..] + , (colKey, colIx) <- zip colKeys' [0 :: Int ..] + , let cellBox = cells !! (rowIx * ncol + colIx) + ] + +singlePanel :: Chart -> PlotBox -> Text -> PanelSpec +singlePanel chart box label = + let xRange = paddedRange (chartLayers chart) (chartData chart) xRangeRefs True + yRange = paddedRange (chartLayers chart) (chartData chart) yRangeRefs False + xs0 = train (scaleX (chartScales chart)) xRange + ys0 = train (scaleY (chartScales chart)) yRange + xs = applyCategorical aesX (chartLayers chart) (chartData chart) xs0 + ys = applyCategorical aesY (chartLayers chart) (chartData chart) ys0 + in PanelSpec + { panelBox = box + , panelLabel = label + , panelData = chartData chart + , panelLayers = chartLayers chart + , panelXScale = xs + , panelYScale = ys + } + +panelFor :: Chart -> ColumnRef -> Text -> FacetScales -> PlotBox -> PanelSpec +panelFor chart colRef key scalesMode box = + let (frame, layers) = filterChartByKey chart colRef key + chart' = chart{chartData = frame, chartLayers = layers} + (xs, ys) = trainPanelScales chart chart' scalesMode + in PanelSpec + { panelBox = box + , panelLabel = key + , panelData = frame + , panelLayers = layers + , panelXScale = xs + , panelYScale = ys + } + +gridPanel :: + Chart -> + [ColumnRef] -> + [ColumnRef] -> + Text -> + Text -> + FacetScales -> + PlotBox -> + PanelSpec +gridPanel chart rowRefs colRefs rowKey colKey scalesMode box = + let frame0 = chartData chart + frame1 = foldl (\f c -> filterFrameByKey c rowKey f) frame0 rowRefs + frame2 = foldl (\f c -> filterFrameByKey c colKey f) frame1 colRefs + filterLayer l = + l + { layerData = + fmap + ( \df -> + let g0 = foldl (\f c -> filterFrameByKey c rowKey f) df rowRefs + in foldl (\f c -> filterFrameByKey c colKey f) g0 colRefs + ) + (layerData l) + } + layers = map filterLayer (chartLayers chart) + chart' = chart{chartData = frame2, chartLayers = layers} + label = case (Text.null rowKey, Text.null colKey) of + (True, True) -> "" + (True, False) -> colKey + (False, True) -> rowKey + (False, False) -> rowKey <> " | " <> colKey + (xs, ys) = trainPanelScales chart chart' scalesMode + in PanelSpec + { panelBox = box + , panelLabel = label + , panelData = frame2 + , panelLayers = layers + , panelXScale = xs + , panelYScale = ys + } + +trainPanelScales :: + Chart -> Chart -> FacetScales -> (TrainedScale, TrainedScale) +trainPanelScales whole panel mode = + let xS = scaleX (chartScales whole) + yS = scaleY (chartScales whole) + wholeXRange = paddedRange (chartLayers whole) (chartData whole) xRangeRefs True + wholeYRange = paddedRange (chartLayers whole) (chartData whole) yRangeRefs False + panelXRange = paddedRange (chartLayers panel) (chartData panel) xRangeRefs True + panelYRange = paddedRange (chartLayers panel) (chartData panel) yRangeRefs False + (xRange, yRange) = case mode of + ScalesFixed -> (wholeXRange, wholeYRange) + ScalesFreeX -> (panelXRange, wholeYRange) + ScalesFreeY -> (wholeXRange, panelYRange) + ScalesFree -> (panelXRange, panelYRange) + xs = applyCategorical aesX (chartLayers panel) (chartData panel) (train xS xRange) + ys = applyCategorical aesY (chartLayers panel) (chartData panel) (train yS yRange) + in (xs, ys) + +{- | Strip height of 32 px = two terminal lines, so panel data never +shares a character row with its facet strip label. +-} +gridCells :: Theme -> PlotBox -> Int -> Int -> [PlotBox] +gridCells theme box nrow ncol = + let stripH = max 32 (themeFontSize theme * 2 + 10) + gutterX = 10 + gutterY = 14 + cellW = boxW box / fromIntegral ncol + cellH = boxH box / fromIntegral nrow + in [ box + { boxX = boxX box + fromIntegral c * cellW + gutterX / 2 + , boxY = boxY box + fromIntegral r * cellH + stripH + , boxW = cellW - gutterX + , boxH = cellH - stripH - gutterY + } + | r <- [0 .. nrow - 1] + , c <- [0 .. ncol - 1] + ] + +wrapDims :: Int -> Maybe Int -> Maybe Int -> (Int, Int) +wrapDims n mNcol mNrow = case (mNcol, mNrow) of + (Just c, Just r) -> (max 1 r, max 1 c) + (Just c, Nothing) -> (ceilingDiv n (max 1 c), max 1 c) + (Nothing, Just r) -> (max 1 r, ceilingDiv n (max 1 r)) + (Nothing, Nothing) -> + let c = max 1 (ceiling (sqrt (fromIntegral n :: Double))) + in (ceilingDiv n c, c) + where + ceilingDiv a b = (a + b - 1) `div` b + +facetKeys :: ColumnRef -> DataFrame -> [Layer] -> [Text] +facetKeys colRef chartFrame layers = + case keysFrom colRef chartFrame of + Just ks -> List.nub ks + Nothing -> + List.nub $ + concat + [ ks + | Just frame <- map layerData layers + , Just ks <- [keysFrom colRef frame] + ] + where + keysFrom (ColumnRef name) (DataFrame cols) = + case lookup name cols of + Just c -> Just (columnAsText c) + Nothing -> Nothing + +gridKeys :: + [ColumnRef] -> [ColumnRef] -> DataFrame -> [Layer] -> ([Text], [Text]) +gridKeys rowRefs colRefs chartFrame _layers = + let rowKeys = compoundKeys rowRefs chartFrame + colKeys = compoundKeys colRefs chartFrame + in (rowKeys, colKeys) + where + compoundKeys refs frame + | null refs = [] + | otherwise = + let perCol = [maybe [] columnAsText (lookupColumnByRef r frame) | r <- refs] + rows = + case perCol of + [] -> [] + (xs : _) -> map (compoundAt perCol) [0 .. length xs - 1] + in List.nub rows + compoundAt cols i = + Text.intercalate "\x00" [if i < length c then c !! i else "" | c <- cols] + lookupColumnByRef (ColumnRef n) (DataFrame cols) = lookup n cols + +filterFrameByKey :: ColumnRef -> Text -> DataFrame -> DataFrame +filterFrameByKey (ColumnRef name) key df@(DataFrame cols) = + case lookup name cols of + Nothing -> df + Just c -> + let texts = columnAsText c + ixs = [i | (i, v) <- zip [0 ..] texts, v == key] + in filterByRows ixs df + +filterChartByKey :: Chart -> ColumnRef -> Text -> (DataFrame, [Layer]) +filterChartByKey chart colRef key = + let frame' = filterFrameByKey colRef key (chartData chart) + filterLayer l = + l{layerData = fmap (filterFrameByKey colRef key) (layerData l)} + layers' = map filterLayer (chartLayers chart) + in (frame', layers') + +runLayer :: + Theme -> + PlotBox -> + Projector -> + [ColorSpec] -> + Int -> + DataFrame -> + Layer -> + [Mark] +runLayer theme box proj palette ix globalFrame layer = + let frame0 = Data.Maybe.fromMaybe globalFrame (layerData layer) + framePostStat = applyStat (layerStat layer) (layerMapping layer) frame0 + frame = applyPosition (layerPosition layer) (layerMapping layer) framePostStat + m = layerMapping layer + defaults = layerAesDef layer + colorSpec = case defColor defaults of + Just c -> c + Nothing -> layerDefaultColor palette ix layer + col = specToTerminal colorSpec + radius = case defSize defaults of + Just r -> r + Nothing -> pointSize theme layer + alpha = Data.Maybe.fromMaybe 1 (defAlpha defaults) + lineW = Data.Maybe.fromMaybe 2 (defLineWidth defaults) + in case layerGeom layer of + GeomPoint -> drawPoints proj frame m colorSpec radius alpha + GeomLine -> drawLine proj frame m colorSpec lineW + GeomBar -> drawBars proj frame m col + GeomCol -> drawBars proj frame m col + GeomHistogram -> drawBars proj frame m col + GeomRibbon -> drawRibbon proj frame m col + GeomErrorbar -> drawErrorbar proj frame m col + GeomTile -> drawTiles proj frame m col + GeomBoxplot -> drawBoxplot proj frame m col + GeomDensity -> drawDensity proj frame m col + GeomText -> drawText proj frame m col (themeFontSize theme) + GeomArc -> drawArcs box frame m palette + +drawPoints :: + Projector -> + DataFrame -> + Mapping -> + ColorSpec -> + Double -> + Double -> + [Mark] +drawPoints proj frame m col r alpha = + case (resolveNumColumn frame (aesX m), resolveNumColumn frame (aesY m)) of + (Just xv, Just yv) -> + [ MCircle + (proj x y) + r + defaultStyle + { styleFill = Just (specToTerminal col) + , styleFillOpacity = alpha + } + | (x, y) <- zip xv yv + ] + _ -> [] + +drawLine :: + Projector -> + DataFrame -> + Mapping -> + ColorSpec -> + Double -> + [Mark] +drawLine proj frame m col lineW = + case (resolveNumColumn frame (aesX m), resolveNumColumn frame (aesY m)) of + (Just xv, Just yv) -> + let sorted = List.sortOn fst (zip xv yv) + pts = [proj x y | (x, y) <- sorted] + in [ MPolyline + pts + defaultStyle + { styleStroke = Just (specToTerminal col) + , styleStrokeWidth = lineW + } + ] + _ -> [] + +drawBars :: Projector -> DataFrame -> Mapping -> Color -> [Mark] +drawBars proj frame m col = + case (resolveNumColumn frame (aesX m), resolveNumColumn frame (aesY m)) of + (Just xs, Just ys) -> + let bases = case lookupColumn "__ybase" frame >>= columnAsNum of + Just bs | length bs == length xs -> bs + _ -> replicate (length xs) 0 + w = barWidth xs + halfW = w / 2 + in [ rectFromCorners + (proj (x - halfW) y0) + (proj (x + halfW) y1) + col + | (x, y1, y0) <- zip3 xs ys bases + ] + _ -> [] + +barWidth :: [Double] -> Double +barWidth xs + | length unique < 2 = 0.8 + | otherwise = + let diffs = zipWith (-) (drop 1 unique) unique + pos = filter (> 1e-9) diffs + in if null pos then 0.8 else minimum pos * 0.8 + where + unique = List.nub (List.sort xs) + +rectFromCorners :: Point -> Point -> Color -> Mark +rectFromCorners (Point xa ya) (Point xb yb) col = + let x0 = min xa xb + y0 = min ya yb + w = abs (xa - xb) + h = abs (ya - yb) + in MRect (Rect x0 y0 w h) defaultStyle{styleFill = Just col} + +drawRibbon :: Projector -> DataFrame -> Mapping -> Color -> [Mark] +drawRibbon proj frame m col = + case ( resolveNumColumn frame (aesX m) + , resolveNumColumn frame (aesYmin m) + , resolveNumColumn frame (aesYmax m) + ) of + (Just xs, Just lo, Just hi) -> + let triples = List.sortOn (\(a, _, _) -> a) (zip3 xs lo hi) + topPts = [proj x h | (x, _, h) <- triples] + botPts = reverse [proj x l | (x, l, _) <- triples] + in [ MPolygon + (topPts <> botPts) + defaultStyle + { styleFill = Just col + , styleFillOpacity = 0.4 + , styleStroke = Just col + , styleStrokeWidth = 1 + } + ] + _ -> [] + +drawErrorbar :: Projector -> DataFrame -> Mapping -> Color -> [Mark] +drawErrorbar proj frame m col = + case ( resolveNumColumn frame (aesX m) + , resolveNumColumn frame (aesYmin m) + , resolveNumColumn frame (aesYmax m) + ) of + (Just xs, Just lo, Just hi) -> + let capW = barWidth xs * 0.4 + halfW = capW / 2 + style = defaultStyle{styleStroke = Just col, styleStrokeWidth = 1.5} + in concat + [ [ MPolyline [proj x l, proj x h] style + , MPolyline [proj (x - halfW) l, proj (x + halfW) l] style + , MPolyline [proj (x - halfW) h, proj (x + halfW) h] style + ] + | (x, l, h) <- zip3 xs lo hi + ] + _ -> [] + +drawTiles :: Projector -> DataFrame -> Mapping -> Color -> [Mark] +drawTiles proj frame m col = + case (resolveNumColumn frame (aesX m), resolveNumColumn frame (aesY m)) of + (Just xs, Just ys) -> + let wX = barWidth xs / 0.8 + wY = barWidth ys / 0.8 + halfX = wX / 2 + halfY = wY / 2 + fillCol = resolveNumColumn frame (aesFill m) + fillRange = case fillCol of + Just vs | not (null vs) -> (minimum vs, maximum vs) + _ -> (0, 1) + colorFor i = case fillCol of + Just vs + | i < length vs -> + let (lo, hi) = fillRange + t = + if hi == lo + then 0.5 + else (vs !! i - lo) / (hi - lo) + in gradientColor t + _ -> col + in [ rectFromCorners + (proj (x - halfX) (y - halfY)) + (proj (x + halfX) (y + halfY)) + (colorFor i) + | (i, (x, y)) <- zip [0 :: Int ..] (zip xs ys) + ] + _ -> [] + +gradientColor :: Double -> Color +gradientColor t = + let palette = + [ Blue + , BrightBlue + , BrightCyan + , BrightGreen + , BrightYellow + , BrightRed + ] + n = length palette + clamped = max 0 (min 0.9999 t) + ix = floor (clamped * fromIntegral n) :: Int + in palette !! ix + +drawBoxplot :: Projector -> DataFrame -> Mapping -> Color -> [Mark] +drawBoxplot proj frame m col = + case ( resolveNumColumn frame (aesX m) + , lookupColumn "__ymin" frame >>= columnAsNum + , lookupColumn "__q1" frame >>= columnAsNum + , lookupColumn "__median" frame >>= columnAsNum + , lookupColumn "__q3" frame >>= columnAsNum + , lookupColumn "__ymax" frame >>= columnAsNum + ) of + (Just xs, Just mins, Just qq1, Just meds, Just qq3, Just maxs) -> + let w = barWidth xs + halfW = w / 2 + style = defaultStyle{styleStroke = Just col, styleStrokeWidth = 1} + fillStyle = style{styleFill = Just col, styleFillOpacity = 0.2} + in concat + [ [ MPolygon + [ proj (x - halfW) qLo + , proj (x + halfW) qLo + , proj (x + halfW) qHi + , proj (x - halfW) qHi + ] + fillStyle + , MPolyline + [proj (x - halfW) medV, proj (x + halfW) medV] + style{styleStrokeWidth = 2} + , MPolyline [proj x qLo, proj x ymin] style + , MPolyline [proj x qHi, proj x ymax] style + ] + | (x, ymin, qLo, medV, qHi, ymax) <- List.zip6 xs mins qq1 meds qq3 maxs + ] + _ -> [] + +drawDensity :: Projector -> DataFrame -> Mapping -> Color -> [Mark] +drawDensity proj frame m col = + drawLine proj frame m (NamedColor col) 2 + +drawText :: Projector -> DataFrame -> Mapping -> Color -> Double -> [Mark] +drawText proj frame m col size = + case ( resolveNumColumn frame (aesX m) + , resolveNumColumn frame (aesY m) + , aesLabel m + ) of + (Just xs, Just ys, Just (ColumnRef labelCol)) -> + case lookupColumn labelCol frame of + Just labelColData -> + let labels = columnAsText labelColData + triples = zip3 xs ys labels + in [ MText + (proj x y) + lbl + defaultTextStyle + { textFill = col + , textSize = size + , textAnchor = AnchorMiddle + } + | (x, y, lbl) <- triples + ] + Nothing -> [] + _ -> [] + +drawArcs :: PlotBox -> DataFrame -> Mapping -> [ColorSpec] -> [Mark] +drawArcs box frame m palette = + case resolveNumColumn frame (aesY m) of + Just vs + | not (null vs) -> + let total = sum vs + cx = boxX box + boxW box / 2 + cy = boxY box + boxH box / 2 + r = min (boxW box) (boxH box) / 2 * 0.9 + fracs = if total == 0 then map (const 0) vs else map (/ total) vs + starts = scanl (+) (- (pi / 2)) (map (* (2 * pi)) fracs) + ends = drop 1 starts + colorAt i = palette !! (i `mod` max 1 (length palette)) + in [ MArc + (Point cx cy) + r + s + e + defaultStyle + { styleFill = Just (specToTerminal (colorAt i)) + , styleStroke = Just (specToTerminal (NamedColor BrightBlack)) + , styleStrokeWidth = 1 + } + | (i, (s, e)) <- zip [0 :: Int ..] (zip starts ends) + ] + _ -> [] + +{- | Resolve a column to numeric values for projection. Categorical +columns map each row to its position in the unique-value list, so +repeated values share an X position (needed for stacked / grouped +/ faceted bars). +-} +resolveNumColumn :: DataFrame -> Maybe ColumnRef -> Maybe [Double] +resolveNumColumn _ Nothing = Nothing +resolveNumColumn df (Just (ColumnRef n)) = + case lookupColumn n df of + Just (ColCat xs) -> Just (categoricalIndices xs) + Just c -> columnAsNum c + Nothing -> Nothing + +categoricalIndices :: [Text] -> [Double] +categoricalIndices xs = + let uniques = List.nub xs + indexOf x = maybe 0 fromIntegral (List.elemIndex x uniques) + in map indexOf xs + +{- | Range across one or more aesthetic getters; the Y-axis caller +folds @aesY@ + @aesYmin@ + @aesYmax@ + the conventional internal +columns so ribbon / errorbar / boxplot layers (which leave 'aesY' +unset) still get a sensible Y range. Stat and position are applied +so histogram-style 'count' columns appear. +-} +unionDataRange :: + [Mapping -> Maybe ColumnRef] -> + [Layer] -> + DataFrame -> + (Double, Double) +unionDataRange getRefs layers globalFrame = + let pulls = + [ values + | layer <- layers + , let m = layerMapping layer + base = Data.Maybe.fromMaybe globalFrame (layerData layer) + stat' = applyStat (layerStat layer) m base + frame = applyPosition (layerPosition layer) m stat' + , getRef <- getRefs + , Just values <- [resolveNumColumn frame (getRef m)] + ] + all_ = concat pulls + in if null all_ + then (0, 1) + else (minimum all_, maximum all_) + +{- | Range with geom adjustments: bar/col/histogram/tile pad ±halfWidth +around (x, y) so boundary rects don't overflow the plot box; bars +also extend the Y range to include their @__ybase@ (default 0) so a +horizontal bar chart with all-positive values doesn't put its +baseline outside the scale. +-} +paddedRange :: + [Layer] -> + DataFrame -> + [Mapping -> Maybe ColumnRef] -> + Bool -> + (Double, Double) +paddedRange layers frame getRefs isXAxis = + let (lo, hi) = unionDataRange getRefs layers frame + primary = case getRefs of + (g : _) -> g + [] -> const Nothing + pad = geomAxisPadding primary isXAxis layers frame + loPadded = lo - pad + hiPadded = hi + pad + in case barAxisAnchor isXAxis layers frame of + Nothing -> (loPadded, hiPadded) + Just anchor -> (min loPadded anchor, max hiPadded anchor) + +yRangeRefs :: [Mapping -> Maybe ColumnRef] +yRangeRefs = + [ aesY + , aesYmin + , aesYmax + , const (Just (ColumnRef "__ymin")) + , const (Just (ColumnRef "__q1")) + , const (Just (ColumnRef "__median")) + , const (Just (ColumnRef "__q3")) + , const (Just (ColumnRef "__ymax")) + , const (Just (ColumnRef "__ybase")) + ] + +xRangeRefs :: [Mapping -> Maybe ColumnRef] +xRangeRefs = [aesX] + +{- | When an aesthetic resolves to a 'ColCat' column, override the +trained scale's breaks and labels so each category sits at its +integer index with the category text as its tick label. Numeric +data passes through unchanged. +-} +applyCategorical :: + (Mapping -> Maybe ColumnRef) -> + [Layer] -> + DataFrame -> + TrainedScale -> + TrainedScale +applyCategorical getRef layers globalFrame ts = + case categoricalLabelsFor getRef layers globalFrame of + Nothing -> ts + Just labels -> + let breaks = [fromIntegral i | i <- [0 .. length labels - 1 :: Int]] + in ts{tsBreaks = breaks, tsLabels = labels} + +{- | Read /pre-stat/ — a stat like 'StatBoxplot' consumes the +categorical X and emits numeric indices, but the labels we want +are the user's original group names. +-} +categoricalLabelsFor :: + (Mapping -> Maybe ColumnRef) -> + [Layer] -> + DataFrame -> + Maybe [Text] +categoricalLabelsFor getRef layers globalFrame = findFirst layers + where + findFirst [] = Nothing + findFirst (layer : rest) = + let m = layerMapping layer + frame = Data.Maybe.fromMaybe globalFrame (layerData layer) + in case getRef m of + Just (ColumnRef n) -> case lookupColumn n frame of + Just (ColCat xs) -> Just (List.nub xs) + _ -> findFirst rest + Nothing -> findFirst rest + +geomAxisPadding :: + (Mapping -> Maybe ColumnRef) -> + Bool -> + [Layer] -> + DataFrame -> + Double +geomAxisPadding getRef isXAxis layers globalFrame = + let perLayerPad layer + | not (needsPadding (layerGeom layer) isXAxis) = 0 + | otherwise = + let m = layerMapping layer + base = Data.Maybe.fromMaybe globalFrame (layerData layer) + postStat = applyStat (layerStat layer) m base + postPos = applyPosition (layerPosition layer) m postStat + in case resolveNumColumn postPos (getRef m) of + Just vs -> barWidth vs / 2 + Nothing -> 0 + pads = map perLayerPad layers + in if null pads then 0 else maximum (0 : pads) + +needsPadding :: Geom -> Bool -> Bool +needsPadding GeomBar isX = isX +needsPadding GeomCol isX = isX +needsPadding GeomHistogram isX = isX +needsPadding GeomBoxplot isX = isX +needsPadding GeomErrorbar isX = isX +needsPadding GeomTile _ = True +needsPadding _ _ = False + +{- | Bar baseline: the minimum of @__ybase@ across bar-like layers +(default 0), so an all-positive chart still includes 0 at the +bottom of the bars. +-} +barAxisAnchor :: Bool -> [Layer] -> DataFrame -> Maybe Double +barAxisAnchor isXAxis layers globalFrame + | isXAxis = Nothing + | otherwise = + let bases = [anchorFor layer | layer <- layers, isBarLike (layerGeom layer)] + in case bases of + [] -> Nothing + xs -> Just (minimum (0 : xs)) + where + isBarLike GeomBar = True + isBarLike GeomCol = True + isBarLike GeomHistogram = True + isBarLike _ = False + + anchorFor layer = + let m = layerMapping layer + base = Data.Maybe.fromMaybe globalFrame (layerData layer) + postStat = applyStat (layerStat layer) m base + postPos = applyPosition (layerPosition layer) m postStat + in case lookupColumn "__ybase" postPos >>= columnAsNum of + Just bs | not (null bs) -> minimum bs + _ -> 0 + +layerDefaultColor :: [ColorSpec] -> Int -> Layer -> ColorSpec +layerDefaultColor palette ix _layer + | null palette = NamedColor BrightBlue + | otherwise = palette !! (ix `mod` length palette) + +pointSize :: Theme -> Layer -> Double +pointSize _ _ = 3 + +collectLegend :: [Layer] -> [ColorSpec] -> [(Text, ColorSpec)] +collectLegend layers palette = + [ (legendName ix layer, palette !! (ix `mod` max 1 (length palette))) + | (ix, layer) <- zip [0 :: Int ..] layers + ] + where + legendName ix layer = + case aesGroup (layerMapping layer) of + Just (ColumnRef n) -> n + Nothing -> "series " <> Text.pack (show ix) + +{- | Quantise 'ColorSpec' to the nearest renderable ANSI 'Color' for +the terminal backend. SVG reads RGB / Hex directly. +-} +specToTerminal :: ColorSpec -> Color +specToTerminal (NamedColor c) = c +specToTerminal (RGB {}) = BrightBlue +specToTerminal (Hex _) = BrightBlue diff --git a/src/Granite/Render/Scene.hs b/src/Granite/Render/Scene.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Render/Scene.hs @@ -0,0 +1,97 @@ + +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Render.Scene +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Backend-agnostic IR. Coordinates are in logical pixels; the terminal +backend maps them to character cells via 'pxPerChar' / 'pxPerLine' +(Braille gives 2×4 sub-cell resolution). +-} +module Granite.Render.Scene ( + Point (..), + Rect (..), + Mark (..), + Scene (..), + Style (..), + defaultStyle, + TextStyle (..), + defaultTextStyle, + TextAnchor (..), + pxPerChar, + pxPerLine, +) where + +import Data.Text (Text) +import Granite.Color (Color (..)) + +data Point = Point !Double !Double + deriving (Eq, Show) + +-- | Axis-aligned rectangle by top-left + size. +data Rect = Rect + { rectX :: !Double + , rectY :: !Double + , rectW :: !Double + , rectH :: !Double + } + deriving (Eq, Show) + +-- | 'Nothing' on fill or stroke means "don't paint that side". +data Style = Style + { styleFill :: !(Maybe Color) + , styleStroke :: !(Maybe Color) + , styleStrokeWidth :: !Double + , styleFillOpacity :: !Double + } + deriving (Eq, Show) + +defaultStyle :: Style +defaultStyle = Style Nothing Nothing 1 1 + +data TextAnchor = AnchorStart | AnchorMiddle | AnchorEnd + deriving (Eq, Show) + +data TextStyle = TextStyle + { textFill :: !Color + , textSize :: !Double + , textAnchor :: !TextAnchor + } + deriving (Eq, Show) + +defaultTextStyle :: TextStyle +defaultTextStyle = TextStyle Default 11 AnchorStart + +{- | Primitive drawable marks. 'MArc' takes (center, radius, a0, a1) +in radians CCW from +x. 'MPolygon' is a closed filled polyline. +'MAxisLine' is an axis-aligned 1-px line that the terminal backend +writes as box-drawing chars (@│@ / @─@ / @┼@) for crisp axes; +everything else is rasterised through Braille. +-} +data Mark + = MCircle !Point !Double !Style + | MRect !Rect !Style + | MPolyline ![Point] !Style + | MPolygon ![Point] !Style + | MPath !Text !Style + | MText !Point !Text !TextStyle + | MArc !Point !Double !Double !Double !Style + | MAxisLine !Point !Point !Style + | MGroup ![Mark] + deriving (Eq, Show) + +data Scene = Scene + { sceneWidth :: !Double + , sceneHeight :: !Double + , sceneMarks :: ![Mark] + } + deriving (Eq, Show) + +pxPerChar :: Double +pxPerChar = 10 + +pxPerLine :: Double +pxPerLine = 16 diff --git a/src/Granite/Render/Svg.hs b/src/Granite/Render/Svg.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Render/Svg.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Render.Svg +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +SVG backend. +-} +module Granite.Render.Svg ( + renderScene, + renderSceneResponsive, + attr, + svgDoc, + svgDocWith, + svgRect, + svgCircle, + svgLine, + svgPolyline, + svgPath, + svgText, +) where + +import Data.Text (Text) +import Data.Text qualified as T + +import Granite.Color (Color (..), colorHex) +import Granite.Internal.Util (escXml, showD) +import Granite.Render.Scene ( + Mark (..), + Point (..), + Rect (..), + Scene (..), + Style (..), + TextAnchor (..), + TextStyle (..), + ) + +attr :: Text -> Text -> Text +attr k v = " " <> k <> "=\"" <> v <> "\"" + +svgDoc :: Double -> Double -> Text -> Text +svgDoc = svgDocWith False + +svgDocWith :: Bool -> Double -> Double -> Text -> Text +svgDocWith responsive w h content = + " attr "viewBox" ("0 0 " <> showD w <> " " <> showD h) + <> sizing + <> attr "font-family" "system-ui, -apple-system, sans-serif" + <> ">\n" + <> "\n" + <> content + <> "\n" + where + sizing + | responsive = + attr "preserveAspectRatio" "xMidYMid meet" + <> attr "width" "100%" + <> attr "style" "height:auto" + | otherwise = + attr "width" (showD w) <> attr "height" (showD h) + +svgRect :: Double -> Double -> Double -> Double -> Text -> Text -> Text +svgRect x y w h fill extra = + " attr "x" (showD x) + <> attr "y" (showD y) + <> attr "width" (showD w) + <> attr "height" (showD h) + <> attr "fill" fill + <> extra + <> "/>\n" + +svgCircle :: Double -> Double -> Double -> Text -> Text +svgCircle cx cy r fill = + " attr "cx" (showD cx) + <> attr "cy" (showD cy) + <> attr "r" (showD r) + <> attr "fill" fill + <> "/>\n" + +svgLine :: Double -> Double -> Double -> Double -> Text -> Double -> Text +svgLine x1 y1 x2 y2 stroke strokeW = + " attr "x1" (showD x1) + <> attr "y1" (showD y1) + <> attr "x2" (showD x2) + <> attr "y2" (showD y2) + <> attr "stroke" stroke + <> attr "stroke-width" (showD strokeW) + <> "/>\n" + +svgPolyline :: [(Double, Double)] -> Text -> Double -> Text +svgPolyline pts stroke strokeW = + " attr "points" (T.intercalate " " [showD x <> "," <> showD y | (x, y) <- pts]) + <> attr "fill" "none" + <> attr "stroke" stroke + <> attr "stroke-width" (showD strokeW) + <> attr "stroke-linejoin" "round" + <> attr "stroke-linecap" "round" + <> "/>\n" + +svgText :: Double -> Double -> Text -> Text -> Double -> Text -> Text +svgText x y anchor fill size content = + " attr "x" (showD x) + <> attr "y" (showD y) + <> attr "text-anchor" anchor + <> attr "fill" fill + <> attr "font-size" (showD size) + <> ">" + <> escXml content + <> "\n" + +svgPath :: Text -> Text -> Text -> Text +svgPath d fill extra = + " attr "d" d + <> attr "fill" fill + <> extra + <> "/>\n" + +renderScene :: Scene -> Text +renderScene scene = + svgDoc (sceneWidth scene) (sceneHeight scene) $ + T.concat (map renderMark (sceneMarks scene)) + +renderSceneResponsive :: Scene -> Text +renderSceneResponsive scene = + svgDocWith True (sceneWidth scene) (sceneHeight scene) $ + T.concat (map renderMark (sceneMarks scene)) + +renderMark :: Mark -> Text +renderMark m = case m of + MRect (Rect x y w h) sty -> + let fill = maybe "none" colorHex (styleFill sty) + extras = + strokeAttrs sty + <> opacityAttr sty + in svgRect x y w h fill extras + MCircle (Point x y) r sty -> + let fill = maybe "none" colorHex (styleFill sty) + in " attr "cx" (showD x) + <> attr "cy" (showD y) + <> attr "r" (showD r) + <> attr "fill" fill + <> strokeAttrs sty + <> opacityAttr sty + <> "/>\n" + MText (Point x y) txt ts -> + svgText + x + y + (anchorText (textAnchor ts)) + (colorHex (textFill ts)) + (textSize ts) + txt + MPolyline pts sty -> + let stroke = maybe "#000000" colorHex (styleStroke sty) + pairs = [(px, py) | Point px py <- pts] + in svgPolyline pairs stroke (styleStrokeWidth sty) + MPolygon pts sty -> + let fill = maybe "none" colorHex (styleFill sty) + pairs = [(px, py) | Point px py <- pts] + ptsStr = T.intercalate " " [showD px <> "," <> showD py | (px, py) <- pairs] + in " attr "points" ptsStr + <> attr "fill" fill + <> strokeAttrs sty + <> opacityAttr sty + <> "/>\n" + MAxisLine (Point x1 y1) (Point x2 y2) sty -> + let stroke = maybe "#000000" colorHex (styleStroke sty) + in svgLine x1 y1 x2 y2 stroke (styleStrokeWidth sty) + MPath d sty -> + let fill = maybe "none" colorHex (styleFill sty) + in svgPath d fill (strokeAttrs sty) + MArc (Point cx cy) r a0 a1 sty -> + let x0 = cx + r * cos a0 + y0 = cy + r * sin a0 + x1 = cx + r * cos a1 + y1 = cy + r * sin a1 + largeArc = if a1 - a0 > pi then "1" else "0" + d = + "M " + <> showD cx + <> " " + <> showD cy + <> " L " + <> showD x0 + <> " " + <> showD y0 + <> " A " + <> showD r + <> " " + <> showD r + <> " 0 " + <> largeArc + <> " 0 " + <> showD x1 + <> " " + <> showD y1 + <> " Z" + fill = maybe "none" colorHex (styleFill sty) + in svgPath d fill (strokeAttrs sty) + MGroup ms -> + "" <> T.concat (map renderMark ms) <> "\n" + +anchorText :: TextAnchor -> Text +anchorText AnchorStart = "start" +anchorText AnchorMiddle = "middle" +anchorText AnchorEnd = "end" + +strokeAttrs :: Style -> Text +strokeAttrs sty = + case styleStroke sty of + Nothing -> "" + Just c -> + attr "stroke" (colorHex c) <> attr "stroke-width" (showD (styleStrokeWidth sty)) + +opacityAttr :: Style -> Text +opacityAttr sty + | styleFillOpacity sty < 1 = attr "fill-opacity" (showD (styleFillOpacity sty)) + | otherwise = "" diff --git a/src/Granite/Render/Terminal.hs b/src/Granite/Render/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Render/Terminal.hs @@ -0,0 +1,450 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Render.Terminal +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Terminal backend. +-} +module Granite.Render.Terminal ( + renderScene, + Canvas (..), + Array2D, + newCanvas, + setDotC, + fillDotsC, + lineDotsC, + renderCanvas, + toBit, + getA2D, + setA2D, + newA2D, +) where + +import Data.Bits ((.|.)) +import Data.Char (chr) +import Data.List qualified as List +import Data.Text (Text) +import Data.Text qualified as Text + +import Granite.Color (Color, ansiOff, ansiOn, paint) +import Granite.Internal.Util (setAt, updateAt) +import Granite.Render.Scene ( + Mark (..), + Point (..), + Rect (..), + Scene (..), + Style (..), + TextAnchor (..), + TextStyle (..), + pxPerChar, + pxPerLine, + ) + +renderScene :: Scene -> Text +renderScene scene = + let wChars = max 1 (ceiling (sceneWidth scene / pxPerChar)) + hChars = max 1 (ceiling (sceneHeight scene / pxPerLine)) + grid0 = replicate hChars (replicate wChars (' ', Nothing :: Maybe Color)) + canvas0 = newCanvas wChars hChars + (grid1, canvas1) = List.foldl' (drawMark wChars hChars) (grid0, canvas0) (sceneMarks scene) + grid2 = mergeCanvas grid1 canvas1 + in Text.unlines (map renderRuns grid2) + +mergeCanvas :: [[(Char, Maybe Color)]] -> Canvas -> [[(Char, Maybe Color)]] +mergeCanvas grid canvas = + [ zipWith merge row [0 :: Int ..] + | (y, row) <- zip [0 :: Int ..] grid + , let merge (ch, mc) x = + case (ch, mc) of + (' ', Nothing) -> + let bits = getA2D (buffer canvas) x y + col = getA2D (cbuf canvas) x y + glyph = if bits == 0 then ' ' else chr (0x2800 + bits) + in (glyph, col) + _ -> (ch, mc) + ] + +drawMark :: + Int -> + Int -> + ([[(Char, Maybe Color)]], Canvas) -> + Mark -> + ([[(Char, Maybe Color)]], Canvas) +drawMark wChars hChars (grid, canvas) mark = case mark of + MRect (Rect x y w h) sty -> + let col = styleFill sty + cx0 = clampInt 0 (wChars - 1) (floor (x / pxPerChar)) + cy0 = clampInt 0 (hChars - 1) (floor (y / pxPerLine)) + cx1 = clampInt 0 (wChars - 1) (floor ((x + w - 1) / pxPerChar)) + cy1 = clampInt 0 (hChars - 1) (floor ((y + h - 1) / pxPerLine)) + grid' = + List.foldl' + ( \g cy -> + List.foldl' + (\g' cx -> setCell g' cx cy ('█', col)) + g + [cx0 .. cx1] + ) + grid + [cy0 .. cy1] + in (grid', canvas) + MText (Point x y) txt ts -> + let cy = clampInt 0 (hChars - 1) (floor (y / pxPerLine)) + width = Text.length txt + startCol = case textAnchor ts of + AnchorStart -> floor (x / pxPerChar) + AnchorMiddle -> floor (x / pxPerChar) - width `div` 2 + AnchorEnd -> floor (x / pxPerChar) - width + grid' = placeChars grid wChars cy startCol (Text.unpack txt) (textFill ts) + in (grid', canvas) + MCircle (Point x y) r sty -> + let col = styleFill sty + xDotC = round (x * 2 / pxPerChar) + yDotC = round (y * 4 / pxPerLine) + rDotX = max 1 (round (r * 2 / pxPerChar)) + rDotY = max 1 (round (r * 4 / pxPerLine)) + canvas' = + fillDotsC + (xDotC - rDotX, yDotC - rDotY) + (xDotC + rDotX, yDotC + rDotY) + ( \dx dy -> + let ddx = fromIntegral (dx - xDotC) / fromIntegral rDotX :: Double + ddy = fromIntegral (dy - yDotC) / fromIntegral rDotY :: Double + in ddx * ddx + ddy * ddy <= 1 + ) + col + canvas + in (grid, canvas') + MPolyline pts sty -> + let col = styleFill sty + toDot (Point x y) = + ( round (x * 2 / pxPerChar) + , round (y * 4 / pxPerLine) + ) + dots = map toDot pts + pairs = zip dots (drop 1 dots) + canvas' = + List.foldl' + (\c ((x0, y0), (x1, y1)) -> lineDotsC (x0, y0) (x1, y1) col c) + canvas + pairs + in (grid, canvas') + MPolygon pts sty -> + let stroke = case styleStroke sty of + Just c -> Just c + Nothing -> styleFill sty + outline = + if null pts + then pts + else pts <> [head pts] + in drawMark + wChars + hChars + (grid, canvas) + (MPolyline outline sty{styleStroke = stroke}) + MAxisLine (Point x1 y1) (Point x2 y2) sty -> + let col = styleStroke sty + grid' = drawAxisLine wChars hChars x1 y1 x2 y2 col grid + in (grid', canvas) + MArc (Point cx cy) r a0 a1 sty -> + let nSeg = 32 :: Int + ang i = a0 + (a1 - a0) * fromIntegral i / fromIntegral nSeg + pts = + [ Point (cx + r * cos (ang i)) (cy + r * sin (ang i)) + | i <- [0 .. nSeg] + ] + in drawMark wChars hChars (grid, canvas) (MPolyline pts sty) + MPath _ _ -> (grid, canvas) + MGroup ms -> + List.foldl' (drawMark wChars hChars) (grid, canvas) ms + +placeChars :: + [[(Char, Maybe Color)]] -> + Int -> + Int -> + Int -> + String -> + Color -> + [[(Char, Maybe Color)]] +placeChars grid wChars cy startCol s col + | cy < 0 || cy >= length grid = grid + | otherwise = + let row0 = grid !! cy + row' = applyChars row0 wChars startCol s + in setAt grid cy row' + where + applyChars row _ _ [] = row + applyChars row w c (ch : rest) + | c < 0 || c >= w = applyChars row w (c + 1) rest + | otherwise = + let row' = setAt row c (ch, Just col) + in applyChars row' w (c + 1) rest + +setCell :: + [[(Char, Maybe Color)]] -> + Int -> + Int -> + (Char, Maybe Color) -> + [[(Char, Maybe Color)]] +setCell grid cx cy cell = + updateAt grid cy (\row -> setAt row cx cell) + +clampInt :: Int -> Int -> Int -> Int +clampInt low high x = max low (min high x) + +drawAxisLine :: + Int -> + Int -> + Double -> + Double -> + Double -> + Double -> + Maybe Color -> + [[(Char, Maybe Color)]] -> + [[(Char, Maybe Color)]] +drawAxisLine wChars hChars x1 y1 x2 y2 col grid + | abs (y2 - y1) < 1e-6 = + let cy = clampInt 0 (hChars - 1) (floor (y1 / pxPerLine)) + cxL = clampInt 0 (wChars - 1) (floor (min x1 x2 / pxPerChar)) + cxR = clampInt 0 (wChars - 1) (floor (max x1 x2 / pxPerChar)) + in List.foldl' (\g cx -> writeAxisCell g cx cy '─' col) grid [cxL .. cxR] + | abs (x2 - x1) < 1e-6 = + let cx = clampInt 0 (wChars - 1) (floor (x1 / pxPerChar)) + cyT = clampInt 0 (hChars - 1) (floor (min y1 y2 / pxPerLine)) + cyB = clampInt 0 (hChars - 1) (floor (max y1 y2 / pxPerLine)) + in List.foldl' (\g cy -> writeAxisCell g cx cy '│' col) grid [cyT .. cyB] + | otherwise = grid + +writeAxisCell :: + [[(Char, Maybe Color)]] -> + Int -> + Int -> + Char -> + Maybe Color -> + [[(Char, Maybe Color)]] +writeAxisCell grid cx cy ch col = + let existing = case grid `atRow` cy >>= (`atCol` cx) of + Just (c, _) -> c + Nothing -> ' ' + finalCh = combineAxis existing ch + in setCell grid cx cy (finalCh, col) + where + atRow rs i + | i < 0 || i >= length rs = Nothing + | otherwise = Just (rs !! i) + atCol cs i + | i < 0 || i >= length cs = Nothing + | otherwise = Just (cs !! i) + +combineAxis :: Char -> Char -> Char +combineAxis existing new + | existing == '│' && new == '─' = '┼' + | existing == '─' && new == '│' = '┼' + | existing == '┼' = '┼' + | otherwise = new + +renderRuns :: [(Char, Maybe Color)] -> Text +renderRuns = go + where + go [] = Text.empty + go xs@((_, Nothing) : _) = + let (plain, rest) = span (\(_, mc) -> case mc of Nothing -> True; _ -> False) xs + in Text.pack (map fst plain) <> go rest + go ((ch, Just c) : rest) = + let (run, after) = + span (\(_, mc) -> mc == Just c || isNothing mc) rest + chunk = ch : map fst run + in if all (== ' ') chunk + then Text.pack chunk <> go after + else ansiOn c <> Text.pack chunk <> ansiOff <> go after + +data Array2D a = A2D Int Int (Arr a) + +getA2D :: Array2D a -> Int -> Int -> a +getA2D (A2D w _ xs) x y = indexA xs (y * w + x) + +setA2D :: Array2D a -> Int -> Int -> a -> Array2D a +setA2D (A2D w h xs) x y v = + let i = y * w + x + in A2D w h (setArr xs i v) + +newA2D :: Int -> Int -> a -> Array2D a +newA2D w h v = A2D w h (fromList (replicate (w * h) v)) + +toBit :: Int -> Int -> Int +toBit ry rx = case (ry, rx) of + (0, 0) -> 1 + (1, 0) -> 2 + (2, 0) -> 4 + (3, 0) -> 64 + (0, 1) -> 8 + (1, 1) -> 16 + (2, 1) -> 32 + (3, 1) -> 128 + _ -> 0 + +data Canvas = Canvas + { cW :: Int + , cH :: Int + , buffer :: Array2D Int + , cbuf :: Array2D (Maybe Color) + } + +newCanvas :: Int -> Int -> Canvas +newCanvas w h = Canvas w h (newA2D w h 0) (newA2D w h Nothing) + +setDotC :: Canvas -> Int -> Int -> Maybe Color -> Canvas +setDotC c xDot yDot mcol + | xDot < 0 || yDot < 0 || xDot >= cW c * 2 || yDot >= cH c * 4 = c + | otherwise = + let (cx, rx) = xDot `divMod` 2 + (cy, ry) = yDot `divMod` 4 + b = toBit ry rx + m = getA2D (buffer c) cx cy + c' = c{buffer = setA2D (buffer c) cx cy (m .|. b)} + in case mcol of + Nothing -> c' + Just col -> c'{cbuf = setA2D (cbuf c) cx cy (Just col)} + +fillDotsC :: + (Int, Int) -> + (Int, Int) -> + (Int -> Int -> Bool) -> + Maybe Color -> + Canvas -> + Canvas +fillDotsC (x0, y0) (x1, y1) p mcol c0 = + let xs = [max 0 x0 .. min (cW c0 * 2 - 1) x1] + ys = [max 0 y0 .. min (cH c0 * 4 - 1) y1] + in List.foldl' + (\c y -> List.foldl' (\c' x -> if p x y then setDotC c' x y mcol else c') c xs) + c0 + ys + +lineDotsC :: (Int, Int) -> (Int, Int) -> Maybe Color -> Canvas -> Canvas +lineDotsC (x0, y0) (x1, y1) mcol c0 = + let dx = abs (x1 - x0) + sx = if x0 < x1 then 1 else -1 + dy = negate (abs (y1 - y0)) + sy = if y0 < y1 then 1 else -1 + go x y err c + | x == x1 && y == y1 = setDotC c x y mcol + | otherwise = + let e2 = 2 * err + (x', err') = if e2 >= dy then (x + sx, err + dy) else (x, err) + (y', err'') = if e2 <= dx then (y + sy, err' + dx) else (y, err') + in go x' y' err'' (setDotC c x y mcol) + in go x0 y0 (dx + dy) c0 + +renderCanvas :: Canvas -> Text +renderCanvas (Canvas w h a colA) = + let glyph 0 = ' ' + glyph m = chr (0x2800 + m) + rows = + fmap + ( \y -> flip fmap [0 .. w - 1] $ \x -> + let m = getA2D a x y + ch = glyph m + mc = getA2D colA x y + in maybe (Text.singleton ch) (`paint` ch) mc + ) + [0 .. h - 1] + in Text.unlines (fmap Text.concat rows) + +data Arr a + = E + | N Int Int (Arr a) a (Arr a) + +sizeA :: Arr a -> Int +sizeA E = 0 +sizeA (N sz _ _ _ _) = sz + +heightA :: Arr a -> Int +heightA E = 0 +heightA (N _ h _ _ _) = h + +mk :: Arr a -> a -> Arr a -> Arr a +mk l x r = N sz h l x r + where + sl = sizeA l + sr = sizeA r + hl = heightA l + hr = heightA r + sz = 1 + sl + sr + h = 1 + max hl hr + +rotateL :: Arr a -> Arr a +rotateL (N _ _ l x (N _ _ rl y rr)) = mk (mk l x rl) y rr +rotateL _ = error "rotateL: malformed tree" + +rotateR :: Arr a -> Arr a +rotateR (N _ _ (N _ _ ll y lr) x r) = mk ll y (mk lr x r) +rotateR _ = error "rotateR: malformed tree" + +balance :: Arr a -> Arr a +balance t@(N _ _ l x r) + | heightA l > heightA r + 1 = + case l of + N _ _ ll _ lr -> + if heightA ll >= heightA lr + then rotateR t + else rotateR (mk (rotateL l) x r) + _ -> t + | heightA r > heightA l + 1 = + case r of + N _ _ rl _ rr -> + if heightA rr >= heightA rl + then rotateL t + else rotateL (mk l x (rotateR r)) + _ -> t + | otherwise = mk l x r +balance t = t + +indexA :: Arr a -> Int -> a +indexA t i = + case t of + E -> error ("index out of bounds: " <> show i) + N _ _ l x r -> + let sl = sizeA l + in if i < 0 || i >= 1 + sl + sizeA r + then error ("index out of bounds: " <> show i) + else + if i < sl + then indexA l i + else + if i == sl + then x + else indexA r (i - sl - 1) + +setArr :: Arr a -> Int -> a -> Arr a +setArr t i y = + case t of + E -> error ("index out of bounds when setting: " <> show i) + N _ _ l x r -> + let sl = sizeA l + in if i < 0 || i >= 1 + sl + sizeA r + then error ("index out of bounds: " <> show i) + else + if i < sl + then balance (mk (setArr l i y) x r) + else + if i == sl + then mk l y r + else balance (mk l x (setArr r (i - sl - 1) y)) + +fromList :: [a] -> Arr a +fromList xs = fst (build (length xs) xs) + where + build :: Int -> [a] -> (Arr a, [a]) + build 0 ys = (E, ys) + build n ys = + let (l, ys1) = build (n `div` 2) ys + (x, ys2) = case ys1 of + [] -> error "IMPOSSIBLE" + (v : vs) -> (v, vs) + (r, ys3) = build (n - n `div` 2 - 1) ys2 + in (mk l x r, ys3) diff --git a/src/Granite/Scale.hs b/src/Granite/Scale.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Scale.hs @@ -0,0 +1,223 @@ + +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Scale +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Scale training: turn a declarative 'Scale' into a 'TrainedScale' that +projects data values onto [0,1] and generates round-number ticks. +-} +module Granite.Scale ( + TrainedScale (..), + train, + niceTicks, + niceNum, +) where + +import Data.Text (Text) + +import Granite.Format (Formatter (..), runFormatter) +import Granite.Internal.Util (eps) +import Granite.Spec ( + BreaksSpec (..), + Expand (..), + LogBase (..), + Scale (..), + ScaleOpts (..), + ) + +data TrainedScale = TrainedScale + { tsDomain :: !(Double, Double) + , tsProject :: !(Double -> Double) + , tsUnproject :: !(Double -> Double) + , tsBreaks :: ![Double] + , tsLabels :: ![Text] + } + +train :: Scale -> (Double, Double) -> TrainedScale +train scale dataRange = case scale of + SLinear opts -> trainLinear opts dataRange + SLog base opts -> trainLog base opts dataRange + SSqrt opts -> trainSqrt opts dataRange + SIdentity -> trainIdentity dataRange + SReverse inner -> reverseScale (train inner dataRange) + SDiscrete -> trainLinear (defaultOpts BreaksNice) dataRange + SColorContinuous _ -> trainLinear (defaultOpts BreaksNice) dataRange + SColorDiscrete _ -> trainLinear (defaultOpts BreaksNice) dataRange + +defaultOpts :: BreaksSpec -> ScaleOpts +defaultOpts brk = + ScaleOpts + { scaleDomain = Nothing + , scaleBreaks = brk + , scaleLabels = FormatDefault + , scaleExpand = Expand 0.05 0 + , scaleClip = False + } + +trainLinear :: ScaleOpts -> (Double, Double) -> TrainedScale +trainLinear opts dataRange = + let (lo, hi) = expandRange (scaleExpand opts) (overrideRange (scaleDomain opts) dataRange) + span_ = hi - lo + eps + project v = (v - lo) / span_ + unproject t = lo + t * span_ + breaks = chooseBreaks (scaleBreaks opts) (lo, hi) + labels = map (runFormatter (scaleLabels opts)) breaks + in TrainedScale (lo, hi) project unproject breaks labels + +{- | Log scales need a strictly positive domain. When the data range +contains zero or negatives we fall back to a window 3 decades below +the data max (or [1, 10] if neither bound is positive). +-} +trainLog :: LogBase -> ScaleOpts -> (Double, Double) -> TrainedScale +trainLog base opts (dlo, dhi) = + let safeLo + | dlo > 0 = dlo + | dhi > 0 = dhi / 1000 + | otherwise = 1 + safeHi + | dhi > safeLo = dhi + | otherwise = safeLo * 10 + (lo, hi) = + expandLog (scaleExpand opts) (overrideRange (scaleDomain opts) (safeLo, safeHi)) + b = logBaseConst base + ll = logBase b lo + lh = logBase b hi + span_ = lh - ll + eps + project v = (logBase b (max safeLo v) - ll) / span_ + unproject t = b ** (ll + t * span_) + breaks = case scaleBreaks opts of + BreaksAt xs -> xs + BreaksCount n -> sampleLogBreaks b lo hi n + BreaksNice -> integerPowers b lo hi + labels = map (runFormatter (scaleLabels opts)) breaks + in TrainedScale (lo, hi) project unproject breaks labels + +logBaseConst :: LogBase -> Double +logBaseConst Base2 = 2 +logBaseConst BaseE = exp 1 +logBaseConst Base10 = 10 + +integerPowers :: Double -> Double -> Double -> [Double] +integerPowers b lo hi = + let kLo = floor (logBase b lo) :: Int + kHi = ceiling (logBase b hi) :: Int + n = kHi - kLo + 1 + maxTicks = 10 + in if n <= maxTicks + then [b ** fromIntegral k | k <- [kLo .. kHi]] + else + let stride = (n + maxTicks - 1) `div` maxTicks + in [b ** fromIntegral k | k <- [kLo, kLo + stride .. kHi]] + +sampleLogBreaks :: Double -> Double -> Double -> Int -> [Double] +sampleLogBreaks b lo hi n + | n < 2 = [lo, hi] + | otherwise = + let ll = logBase b lo + lh = logBase b hi + step = (lh - ll) / fromIntegral (n - 1) + in [b ** (ll + step * fromIntegral i) | i <- [0 .. n - 1]] + +trainSqrt :: ScaleOpts -> (Double, Double) -> TrainedScale +trainSqrt opts dataRange = + let (lo0, hi0) = overrideRange (scaleDomain opts) dataRange + lo = max 0 lo0 + hi = max lo hi0 + (lo', hi') = expandRange (scaleExpand opts) (lo, hi) + sLo = sqrt (max 0 lo') + sHi = sqrt (max sLo hi') + span_ = sHi - sLo + eps + project v = (sqrt (max 0 v) - sLo) / span_ + unproject t = + let s = sLo + t * span_ + in s * s + breaks = chooseBreaks (scaleBreaks opts) (lo', hi') + labels = map (runFormatter (scaleLabels opts)) breaks + in TrainedScale (lo', hi') project unproject breaks labels + +trainIdentity :: (Double, Double) -> TrainedScale +trainIdentity (lo, hi) = + let breaks = chooseBreaks BreaksNice (lo, hi) + labels = map (runFormatter FormatDefault) breaks + in TrainedScale + { tsDomain = (lo, hi) + , tsProject = id + , tsUnproject = id + , tsBreaks = breaks + , tsLabels = labels + } + +reverseScale :: TrainedScale -> TrainedScale +reverseScale ts = + ts + { tsProject = \v -> 1 - tsProject ts v + , tsUnproject = tsUnproject ts . (1 -) + } + +overrideRange :: Maybe (Double, Double) -> (Double, Double) -> (Double, Double) +overrideRange Nothing r = r +overrideRange (Just (a, b)) _ = (a, b) + +expandRange :: Expand -> (Double, Double) -> (Double, Double) +expandRange (Expand m a) (lo, hi) = + let pad = (hi - lo) * m + a + in (lo - pad, hi + pad) + +expandLog :: Expand -> (Double, Double) -> (Double, Double) +expandLog (Expand m _) (lo, hi) + | m <= 0 = (lo, hi) + | otherwise = + let factor = (hi / lo) ** m + in (lo / factor, hi * factor) + +chooseBreaks :: BreaksSpec -> (Double, Double) -> [Double] +chooseBreaks brk (lo, hi) = case brk of + BreaksAt xs -> xs + BreaksCount n -> niceTicks (lo, hi) n + BreaksNice -> niceTicks (lo, hi) 5 + +{- | Heckbert "loose label" tick selection. Round-number positions in +@{1, 2, 2.5, 5} × 10^k@ that bracket the data range. +-} +niceTicks :: (Double, Double) -> Int -> [Double] +niceTicks (lo, hi) target0 + | not (isValid lo && isValid hi) || lo == hi = [lo] + | lo > hi = niceTicks (hi, lo) target0 + | otherwise = + let target = max 2 target0 + range = niceNum (hi - lo) False + step = niceNum (range / fromIntegral (target - 1)) True + gMin = (fromIntegral :: Int -> Double) (floor (lo / step)) * step + gMax = (fromIntegral :: Int -> Double) (ceiling (hi / step)) * step + n = round ((gMax - gMin) / step) + 1 + in [gMin + step * fromIntegral i | i <- [0 .. n - 1]] + where + isValid x = not (isNaN x || isInfinite x) + +niceNum :: Double -> Bool -> Double +niceNum 0 _ = 1 +niceNum x roundIt = + let absX = abs x + sign = if x < 0 then (-1) else 1 + exp10 = floor (logBase 10 absX) :: Int + f = absX / (10 ** fromIntegral exp10) + nf + | roundIt = + if f < 1.5 + then 1 + else + if f < 3 + then 2 + else + if f < 7 + then 5 + else 10 + | f <= 1 = 1 + | f <= 2 = 2 + | f <= 5 = 5 + | otherwise = 10 + in sign * nf * (10 ** fromIntegral exp10) diff --git a/src/Granite/Spec.hs b/src/Granite/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Spec.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Spec +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Declarative Grammar-of-Graphics chart IR: data + layers + scales + +coord + facet + theme + size. +-} +module Granite.Spec ( + Chart (..), + emptyChart, + module Granite.Data.Frame, + module Granite.Format, + ColumnRef (..), + Mapping (..), + emptyMapping, + AesDefaults (..), + emptyAesDefaults, + ColorSpec (..), + Layer (..), + defLayer, + Geom (..), + Stat (..), + BinSpec (..), + SmoothMethod (..), + SummaryFun (..), + Position (..), + Scale (..), + ScaleOpts (..), + defScaleOpts, + LogBase (..), + BreaksSpec (..), + Expand (..), + Scales (..), + defScales, + Coord (..), + PolarAes (..), + PolarDir (..), + Facet (..), + FacetScales (..), + Theme (..), + defTheme, + Size (..), +) where + +import Data.Text (Text) +import Data.Word (Word8) + +import Granite.Color (Color (..)) +import Granite.Data.Frame +import Granite.Format + +newtype ColumnRef = ColumnRef Text + deriving (Eq, Show, Read) + +data Mapping = Mapping + { aesX :: Maybe ColumnRef + , aesY :: Maybe ColumnRef + , aesColor :: Maybe ColumnRef + , aesFill :: Maybe ColumnRef + , aesSize :: Maybe ColumnRef + , aesAlpha :: Maybe ColumnRef + , aesGroup :: Maybe ColumnRef + , aesYmin :: Maybe ColumnRef + , aesYmax :: Maybe ColumnRef + , aesLabel :: Maybe ColumnRef + } + deriving (Eq, Show, Read) + +emptyMapping :: Mapping +emptyMapping = + Mapping + { aesX = Nothing + , aesY = Nothing + , aesColor = Nothing + , aesFill = Nothing + , aesSize = Nothing + , aesAlpha = Nothing + , aesGroup = Nothing + , aesYmin = Nothing + , aesYmax = Nothing + , aesLabel = Nothing + } + +data AesDefaults = AesDefaults + { defColor :: Maybe ColorSpec + , defFill :: Maybe ColorSpec + , defSize :: Maybe Double + , defAlpha :: Maybe Double + , defLineWidth :: Maybe Double + , defLineDash :: Maybe [Double] + } + deriving (Eq, Show, Read) + +emptyAesDefaults :: AesDefaults +emptyAesDefaults = + AesDefaults + { defColor = Nothing + , defFill = Nothing + , defSize = Nothing + , defAlpha = Nothing + , defLineWidth = Nothing + , defLineDash = Nothing + } + +data ColorSpec + = NamedColor Color + | RGB Word8 Word8 Word8 + | Hex Text + deriving (Eq, Show, Read) + +data Layer = Layer + { layerData :: Maybe DataFrame + , layerMapping :: Mapping + , layerGeom :: Geom + , layerStat :: Stat + , layerPosition :: Position + , layerAesDef :: AesDefaults + } + deriving (Eq, Show, Read) + +defLayer :: Geom -> Layer +defLayer g = + Layer + { layerData = Nothing + , layerMapping = emptyMapping + , layerGeom = g + , layerStat = defaultStat g + , layerPosition = PosIdentity + , layerAesDef = emptyAesDefaults + } + +defaultStat :: Geom -> Stat +defaultStat g = case g of + GeomBar -> StatCount + GeomBoxplot -> StatBoxplot + GeomDensity -> StatDensity + GeomHistogram -> StatBin (BinByCount 30) + _ -> StatIdentity + +data Geom + = GeomPoint + | GeomLine + | GeomBar + | GeomCol + | GeomRibbon + | GeomErrorbar + | GeomTile + | GeomBoxplot + | GeomDensity + | GeomHistogram + | GeomText + | GeomArc + deriving (Eq, Show, Read) + +data Stat + = StatIdentity + | StatBin BinSpec + | StatDensity + | StatSmooth SmoothMethod + | StatBoxplot + | StatCount + | StatSummary SummaryFun + deriving (Eq, Show, Read) + +data BinSpec + = BinByCount Int + | BinByWidth Double + | BinByEdges [Double] + deriving (Eq, Show, Read) + +data SmoothMethod + = SmoothLm + | SmoothLoess Double + | SmoothMovingAvg Int + deriving (Eq, Show, Read) + +data SummaryFun + = SumMean + | SumMedian + | SumQuantile Double + | SumSum + deriving (Eq, Show, Read) + +data Position + = PosIdentity + | PosStack + | PosDodge Double + | PosJitter Double Double + | PosFill + deriving (Eq, Show, Read) + +data LogBase = Base2 | BaseE | Base10 + deriving (Eq, Show, Read) + +data Expand = Expand + { expandMult :: Double + , expandAdd :: Double + } + deriving (Eq, Show, Read) + +data BreaksSpec + = BreaksNice + | BreaksCount Int + | BreaksAt [Double] + deriving (Eq, Show, Read) + +data ScaleOpts = ScaleOpts + { scaleDomain :: Maybe (Double, Double) + , scaleBreaks :: BreaksSpec + , scaleLabels :: Formatter + , scaleExpand :: Expand + , scaleClip :: Bool + } + deriving (Eq, Show, Read) + +defScaleOpts :: ScaleOpts +defScaleOpts = + ScaleOpts + { scaleDomain = Nothing + , scaleBreaks = BreaksNice + , scaleLabels = FormatDefault + , scaleExpand = Expand 0.05 0 + , scaleClip = False + } + +data Scale + = SLinear ScaleOpts + | SLog LogBase ScaleOpts + | SSqrt ScaleOpts + | SReverse Scale + | SIdentity + | SDiscrete + | SColorContinuous [ColorSpec] + | SColorDiscrete [ColorSpec] + deriving (Eq, Show, Read) + +data Scales = Scales + { scaleX :: Scale + , scaleY :: Scale + , scaleColor :: Maybe Scale + , scaleFill :: Maybe Scale + , scaleSize :: Maybe Scale + } + deriving (Eq, Show, Read) + +defScales :: Scales +defScales = + Scales + { scaleX = SLinear defScaleOpts + , scaleY = SLinear defScaleOpts + , scaleColor = Nothing + , scaleFill = Nothing + , scaleSize = Nothing + } + +data PolarAes = ThetaX | ThetaY + deriving (Eq, Show, Read) + +data PolarDir = PolarCW | PolarCCW + deriving (Eq, Show, Read) + +data Coord + = CoordCartesian + | CoordFlip + | CoordPolar PolarAes Double PolarDir + deriving (Eq, Show, Read) + +data FacetScales + = ScalesFixed + | ScalesFreeX + | ScalesFreeY + | ScalesFree + deriving (Eq, Show, Read) + +data Facet + = FacetNull + | FacetWrap ColumnRef (Maybe Int) (Maybe Int) FacetScales + | FacetGrid [ColumnRef] [ColumnRef] FacetScales + deriving (Eq, Show, Read) + +data Theme = Theme + { themePalette :: [ColorSpec] + , themePieColors :: [ColorSpec] + , themeAxisColor :: ColorSpec + , themeGridColor :: ColorSpec + , themeTextColor :: ColorSpec + , themeBackground :: ColorSpec + , themeFontSize :: Double + , themeTitleSize :: Double + , themeStrokeWidth :: Double + , themePxPerChar :: Double + , themePxPerLine :: Double + } + deriving (Eq, Show, Read) + +defTheme :: Theme +defTheme = + Theme + { themePalette = + [ NamedColor BrightBlue + , NamedColor BrightMagenta + , NamedColor BrightCyan + , NamedColor BrightGreen + , NamedColor BrightYellow + , NamedColor BrightRed + , NamedColor BrightWhite + , NamedColor BrightBlack + ] + , themePieColors = + [ NamedColor BrightRed + , NamedColor BrightGreen + , NamedColor BrightYellow + , NamedColor BrightBlue + , NamedColor BrightMagenta + , NamedColor BrightCyan + , NamedColor BrightWhite + , NamedColor BrightBlack + ] + , themeAxisColor = Hex "#aaaaaa" + , themeGridColor = Hex "#eeeeee" + , themeTextColor = Hex "#555555" + , themeBackground = Hex "#ffffff" + , themeFontSize = 11 + , themeTitleSize = 14 + , themeStrokeWidth = 1 + , themePxPerChar = 10 + , themePxPerLine = 16 + } + +data Size + = SizeChars Int Int + | SizePixels Int Int + | SizeResponsive Double + deriving (Eq, Show, Read) + +data Chart = Chart + { chartData :: DataFrame + , chartLayers :: [Layer] + , chartScales :: Scales + , chartCoord :: Coord + , chartFacet :: Facet + , chartTheme :: Theme + , chartTitle :: Maybe Text + , chartSize :: Size + } + deriving (Eq, Show, Read) + +emptyChart :: Chart +emptyChart = + Chart + { chartData = emptyFrame + , chartLayers = [] + , chartScales = defScales + , chartCoord = CoordCartesian + , chartFacet = FacetNull + , chartTheme = defTheme + , chartTitle = Nothing + , chartSize = SizeChars 60 20 + } diff --git a/src/Granite/Stat.hs b/src/Granite/Stat.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Stat.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Stat +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Statistical transforms ('Stat'). Each runs on a layer's mapped X / Y +columns and returns a new frame, generally with the same column names +holding the transformed values. 'StatBoxplot' additionally writes +@__ymin@ / @__q1@ / @__median@ / @__q3@ / @__ymax@ for the boxplot +geom to read. +-} +module Granite.Stat ( + applyStat, + binData, + kdeData, + smoothLm, + smoothMovingAvg, + smoothLoess, + boxplotSummary, + BoxStats (..), + countByCategory, + summarizeByCategory, +) where + +import Data.List qualified as List +import Data.Text (Text) + +import Granite.Data.Frame ( + Column (..), + DataFrame (..), + columnAsNum, + columnAsText, + fromColumns, + lookupColumn, + ) +import Granite.Spec ( + BinSpec (..), + ColumnRef (..), + Mapping (..), + SmoothMethod (..), + Stat (..), + SummaryFun (..), + ) + +applyStat :: Stat -> Mapping -> DataFrame -> DataFrame +applyStat stat m df = case stat of + StatIdentity -> df + StatBin spec -> runBin spec m df + StatDensity -> runDensity m df + StatSmooth method -> runSmooth method m df + StatBoxplot -> runBoxplot m df + StatCount -> runCount m df + StatSummary fn -> runSummary fn m df + +runBin :: BinSpec -> Mapping -> DataFrame -> DataFrame +runBin spec m df = + case resolveNum (aesX m) df of + Nothing -> df + Just xs -> + let (mids, counts) = binData spec xs + xName = refName (aesX m) "x" + yName = refName (aesY m) "count" + in fromColumns + [ (xName, ColNum mids) + , (yName, ColNum counts) + ] + +binData :: BinSpec -> [Double] -> ([Double], [Double]) +binData _ [] = ([], []) +binData spec xs = + let lo = minimum xs + hi = maximum xs + edges = case spec of + BinByCount n -> evenEdges n lo hi + BinByWidth w + | w <= 0 -> evenEdges 1 lo hi + | otherwise -> stepEdges w lo hi + BinByEdges es -> List.sort es + nBins = max 1 (length edges - 1) + mids = + [ (e0 + e1) / 2 + | (e0, e1) <- zip edges (drop 1 edges) + ] + counts0 = replicate nBins (0 :: Int) + counts = + foldr + ( \v acc -> + let ix = which edges v + in update acc ix + ) + counts0 + xs + in (mids, map fromIntegral counts) + where + update :: [Int] -> Int -> [Int] + update cs i + | i < 0 || i >= length cs = cs + | otherwise = take i cs ++ [cs !! i + 1] ++ drop (i + 1) cs + + -- Epsilon tolerance so values landing exactly on an internal edge + -- go to the right-side bin, matching @[lo, hi)@ even after the + -- rounding error in @lo + step * i@. + which :: [Double] -> Double -> Int + which es v + | length es < 2 = -1 + | v + eps < head es = -1 + | v > last es + eps = -1 + | otherwise = go 0 + where + eps = 1e-9 + n = length es - 1 + go i + | i >= n = n - 1 + | v + eps < es !! (i + 1) = i + | i == n - 1 && v <= es !! (i + 1) + eps = i + | otherwise = go (i + 1) + +evenEdges :: Int -> Double -> Double -> [Double] +evenEdges n lo hi + | n < 1 = [lo, hi] + | lo == hi = [lo - 0.5, hi + 0.5] + | otherwise = + let step = (hi - lo) / fromIntegral n + in [lo + step * fromIntegral i | i <- [0 .. n]] + +stepEdges :: Double -> Double -> Double -> [Double] +stepEdges w lo hi + | lo == hi = [lo - w / 2, hi + w / 2] + | otherwise = + let n = max 1 (ceiling ((hi - lo) / w)) + in [lo + w * fromIntegral i | i <- [0 .. n]] + +runDensity :: Mapping -> DataFrame -> DataFrame +runDensity m df = + case resolveNum (aesX m) df of + Nothing -> df + Just xs -> + let (gx, gy) = kdeData 128 xs + xName = refName (aesX m) "x" + yName = refName (aesY m) "density" + in fromColumns [(xName, ColNum gx), (yName, ColNum gy)] + +-- | Gaussian KDE on @n@ grid points; bandwidth is Silverman's rule. +kdeData :: Int -> [Double] -> ([Double], [Double]) +kdeData _ [] = ([], []) +kdeData n xs = + let nn = length xs + mu = sum xs / fromIntegral nn + var = sum [(x - mu) ** 2 | x <- xs] / fromIntegral (max 1 (nn - 1)) + sigma = sqrt (max var 1e-12) + h = 1.06 * sigma * fromIntegral nn ** (-0.2) + lo = minimum xs - 3 * h + hi = maximum xs + 3 * h + grid = evenSpaced n lo hi + density g = + let k v = exp (negate ((g - v) ** 2) / (2 * h * h)) / (h * sqrt (2 * pi)) + in sum (map k xs) / fromIntegral nn + in (grid, map density grid) + +evenSpaced :: Int -> Double -> Double -> [Double] +evenSpaced n lo hi + | n < 2 = [lo] + | otherwise = + let step = (hi - lo) / fromIntegral (n - 1) + in [lo + step * fromIntegral i | i <- [0 .. n - 1]] + +runSmooth :: SmoothMethod -> Mapping -> DataFrame -> DataFrame +runSmooth method m df = + case ( resolveNum (aesX m) df + , resolveNum (aesY m) df + ) of + (Just xs, Just ys) -> + let pairs = List.sortOn fst (zip xs ys) + (sx, sy) = unzip pairs + fitted = case method of + SmoothLm -> smoothLm sx sy + SmoothLoess span_ -> smoothLoess span_ sx sy + SmoothMovingAvg w -> smoothMovingAvg w sy + xName = refName (aesX m) "x" + yName = refName (aesY m) "y" + in fromColumns [(xName, ColNum sx), (yName, ColNum fitted)] + _ -> df + +-- | OLS regression, evaluated at the input X positions. +smoothLm :: [Double] -> [Double] -> [Double] +smoothLm xs ys + | length xs < 2 = ys + | otherwise = + let n = fromIntegral (length xs) :: Double + mx = sum xs / n + my = sum ys / n + num = sum (zipWith (\x y -> (x - mx) * (y - my)) xs ys) + den = sum [(x - mx) ** 2 | x <- xs] + slope = if den == 0 then 0 else num / den + intercept = my - slope * mx + in [intercept + slope * x | x <- xs] + +{- | Trailing moving average; leading edge is the partial-window mean +so the output length matches the input. +-} +smoothMovingAvg :: Int -> [Double] -> [Double] +smoothMovingAvg w ys + | w <= 1 = ys + | otherwise = + [ let lo = max 0 (i - w + 1) + window = take (i - lo + 1) (drop lo ys) + k = fromIntegral (length window) :: Double + in if k == 0 then 0 else sum window / k + | i <- [0 .. length ys - 1] + ] + +{- | LOESS-style local linear regression with tricube weights; +@span_@ is the neighbourhood fraction in @(0, 1]@. +-} +smoothLoess :: Double -> [Double] -> [Double] -> [Double] +smoothLoess span_ xs ys + | length xs < 2 = ys + | otherwise = + let n = length xs + k = max 2 (round (span_ * fromIntegral n)) + in [loessAt xs ys k x | x <- xs] + +loessAt :: [Double] -> [Double] -> Int -> Double -> Double +loessAt xs ys k x0 = + let dists = [(abs (x - x0), x, y) | (x, y) <- zip xs ys] + nearest = take k (List.sortOn (\(d, _, _) -> d) dists) + maxD = case nearest of + [] -> 1 + ds -> maximum [d | (d, _, _) <- ds] + 1e-12 + wts = [tricube (d / maxD) | (d, _, _) <- nearest] + xv = [x | (_, x, _) <- nearest] + yv = [y | (_, _, y) <- nearest] + sw = sum wts + swx = sum (zipWith (*) wts xv) + swy = sum (zipWith (*) wts yv) + swxx = sum (zipWith (\w x -> w * x * x) wts xv) + swxy = sum (zipWith3 (\w x y -> w * x * y) wts xv yv) + denom = sw * swxx - swx * swx + slope = if denom == 0 then 0 else (sw * swxy - swx * swy) / denom + intercept = if sw == 0 then 0 else (swy - slope * swx) / sw + in intercept + slope * x0 + +tricube :: Double -> Double +tricube u + | abs u >= 1 = 0 + | otherwise = (1 - abs u ** 3) ** 3 + +runBoxplot :: Mapping -> DataFrame -> DataFrame +runBoxplot m df = + case resolveNum (aesY m) df of + Nothing -> df + Just ys -> + let groupNames = case aesX m of + Just (ColumnRef n) -> case lookupColumn n df of + Just c -> columnAsText c + Nothing -> replicate (length ys) "all" + Nothing -> replicate (length ys) "all" + grouped = groupBy fst (zip groupNames ys) + summaries = + [ (name, boxplotSummary [v | (_, v) <- xs]) + | (name, xs) <- grouped + ] + xName = refName (aesX m) "group" + in fromColumns + [ (xName, ColCat [n | (n, _) <- summaries]) + , ("__ymin", ColNum [yMin s | (_, s) <- summaries]) + , ("__q1", ColNum [q1 s | (_, s) <- summaries]) + , ("__median", ColNum [med s | (_, s) <- summaries]) + , ("__q3", ColNum [q3 s | (_, s) <- summaries]) + , ("__ymax", ColNum [yMax s | (_, s) <- summaries]) + ] + +data BoxStats = BoxStats + { yMin :: !Double + , q1 :: !Double + , med :: !Double + , q3 :: !Double + , yMax :: !Double + } + deriving (Eq, Show) + +{- | Five-number summary using Tukey hinges: when @n@ is odd the +median is included in both halves, so @boxplotSummary [1..9]@ +gives @(1, 3, 5, 7, 9)@. +-} +boxplotSummary :: [Double] -> BoxStats +boxplotSummary [] = BoxStats 0 0 0 0 0 +boxplotSummary xs = + let sorted = List.sort xs + n = length sorted + m = + if n `mod` 2 == 1 + then sorted !! (n `div` 2) + else (sorted !! (n `div` 2 - 1) + sorted !! (n `div` 2)) / 2 + half = + if n `mod` 2 == 1 + then (n `div` 2) + 1 + else n `div` 2 + lower = take half sorted + upper = drop (n - half) sorted + qq xs' = + if null xs' + then m + else + let k = length xs' + in if k `mod` 2 == 1 + then xs' !! (k `div` 2) + else (xs' !! (k `div` 2 - 1) + xs' !! (k `div` 2)) / 2 + in BoxStats + { yMin = head sorted + , q1 = qq lower + , med = m + , q3 = qq upper + , yMax = last sorted + } + +runCount :: Mapping -> DataFrame -> DataFrame +runCount m df = + let xs = case aesX m of + Just (ColumnRef n) -> maybe [] columnAsText (lookupColumn n df) + Nothing -> [] + counts = countByCategory xs + xName = refName (aesX m) "x" + yName = refName (aesY m) "count" + in fromColumns + [ (xName, ColCat [k | (k, _) <- counts]) + , (yName, ColNum [fromIntegral v | (_, v) <- counts]) + ] + +countByCategory :: [Text] -> [(Text, Int)] +countByCategory xs = + let uniq = List.nub xs + in [(u, length [x | x <- xs, x == u]) | u <- uniq] + +runSummary :: SummaryFun -> Mapping -> DataFrame -> DataFrame +runSummary fn m df = + case resolveNum (aesY m) df of + Nothing -> df + Just ys -> + let groupKeys = case aesX m of + Just (ColumnRef n) -> case lookupColumn n df of + Just c -> columnAsText c + Nothing -> replicate (length ys) "all" + Nothing -> replicate (length ys) "all" + summaries = summarizeByCategory fn (zip groupKeys ys) + xName = refName (aesX m) "x" + yName = refName (aesY m) "y" + in fromColumns + [ (xName, ColCat [k | (k, _) <- summaries]) + , (yName, ColNum [v | (_, v) <- summaries]) + ] + +summarizeByCategory :: SummaryFun -> [(Text, Double)] -> [(Text, Double)] +summarizeByCategory fn pairs = + let grouped = groupBy fst pairs + in [(name, applyFn fn (map snd vs)) | (name, vs) <- grouped] + where + applyFn SumMean xs = if null xs then 0 else sum xs / fromIntegral (length xs) + applyFn SumSum xs = sum xs + applyFn SumMedian xs = + let s = List.sort xs + n = length s + in if n == 0 + then 0 + else + if n `mod` 2 == 1 + then s !! (n `div` 2) + else (s !! (n `div` 2 - 1) + s !! (n `div` 2)) / 2 + applyFn (SumQuantile p) xs = + let s = List.sort xs + n = length s + ix = max 0 (min (n - 1) (round (p * fromIntegral (n - 1)) :: Int)) + in if n == 0 then 0 else s !! ix + +resolveNum :: Maybe ColumnRef -> DataFrame -> Maybe [Double] +resolveNum Nothing _ = Nothing +resolveNum (Just (ColumnRef n)) df = lookupColumn n df >>= columnAsNum + +refName :: Maybe ColumnRef -> Text -> Text +refName (Just (ColumnRef n)) _ = n +refName Nothing fallback = fallback + +groupBy :: (Eq k) => (a -> k) -> [a] -> [(k, [a])] +groupBy f xs = + let keys = List.nub (map f xs) + in [(k, [x | x <- xs, f x == k]) | k <- keys] diff --git a/src/Granite/Svg.hs b/src/Granite/Svg.hs --- a/src/Granite/Svg.hs +++ b/src/Granite/Svg.hs @@ -6,27 +6,11 @@ Copyright : (c) 2025 License : MIT Maintainer : mschavinda@gmail.com -Stability : experimental -Portability : POSIX -An SVG-based plotting backend that mirrors the API of "Granite". -Every chart function returns a self-contained SVG document as 'Text'. - -= Basic Usage - -@ -{\-# LANGUAGE OverloadedStrings #-\} -import qualified Data.Text.IO as T -import Granite.Svg - -main = do - let chart = bars [(\"Q1\",12),(\"Q2\",18),(\"Q3\",9),(\"Q4\",15)] - defPlot { plotTitle = \"Sales\" } - T.writeFile \"chart.svg\" chart -@ +SVG plotting backend that mirrors the API of "Granite". Each chart +function returns a self-contained SVG document as 'Text'. -} module Granite.Svg ( - -- * Re-exports from Granite Plot (..), defPlot, LegendPos (..), @@ -36,8 +20,6 @@ Bins (..), bins, series, - - -- * Chart types (SVG output) scatter, lineGraph, bars, @@ -46,10 +28,18 @@ pie, heatmap, boxPlot, + area, + ribbon, + density, + errorBars, + funnel, + polarLine, + waterfall, + distPlot, ) where import Data.List qualified as List -import Data.Maybe (fromMaybe, listToMaybe) +import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Granite ( @@ -63,52 +53,44 @@ defPlot, series, ) +import Granite.Color (colorHex) +import Granite.Internal.LegacyChart qualified as LC +import Granite.Internal.Util ( + addAt, + clamp, + eps, + maximum', + minimum', + normalize, + quartiles, + showD, + ticks1D, + ) +import Granite.Render.Pipeline (renderChartSvg) +import Granite.Render.Svg ( + attr, + svgCircle, + svgDoc, + svgLine, + svgPath, + svgPolyline, + svgRect, + svgText, + ) import Numeric (showFFloat) ------------------------------------------------------------------------- --- Scaling constants ------------------------------------------------------------------------- - --- | Pixels per terminal character width. cW :: Double cW = 10 --- | Pixels per terminal character height. cH :: Double cH = 16 --- | Font size for axis labels (px). labelFontSize :: Double labelFontSize = 11 --- | Font size for chart title (px). titleFontSize :: Double titleFontSize = 14 ------------------------------------------------------------------------- --- Colour mapping (ANSI → hex) ------------------------------------------------------------------------- - -colorHex :: Color -> Text -colorHex Default = "#555555" -colorHex Black = "#2c3e50" -colorHex Red = "#c0392b" -colorHex Green = "#27ae60" -colorHex Yellow = "#f39c12" -colorHex Blue = "#2980b9" -colorHex Magenta = "#8e44ad" -colorHex Cyan = "#16a085" -colorHex White = "#ecf0f1" -colorHex BrightBlack = "#7f8c8d" -colorHex BrightRed = "#e74c3c" -colorHex BrightGreen = "#2ecc71" -colorHex BrightYellow = "#f1c40f" -colorHex BrightBlue = "#3498db" -colorHex BrightMagenta = "#9b59b6" -colorHex BrightCyan = "#1abc9c" -colorHex BrightWhite = "#bdc3c7" - --- Heatmap intensity palette (low → high). heatColors :: [Text] heatColors = [ "#2980b9" @@ -124,22 +106,6 @@ , "#c0392b" ] ------------------------------------------------------------------------- --- Helpers copied from Granite (not exported there) ------------------------------------------------------------------------- - -clamp :: (Ord a) => a -> a -> a -> a -clamp lo hi x = max lo (min hi x) - -eps :: Double -eps = 1e-12 - -minimum', maximum' :: [Double] -> Double -minimum' [] = 0 -minimum' xs = minimum xs -maximum' [] = 1 -maximum' xs = maximum xs - boundsXY :: Plot -> [(Double, Double)] -> (Double, Double, Double, Double) boundsXY cfg pts = let (xs, ys) = unzip pts @@ -155,68 +121,20 @@ , fromMaybe (ymax + pady) (snd (yBounds cfg)) ) -quartiles :: [Double] -> (Double, Double, Double, Double, Double) -quartiles [] = (0, 0, 0, 0, 0) -quartiles xs = - let sorted = List.sort xs - n = length sorted - q1Idx = n `div` 4 - q2Idx = n `div` 2 - q3Idx = 3 * n `div` 4 - getIdx i = if i < n then sorted !! i else last sorted - in if n < 5 - then let m = sum xs / fromIntegral n in (m, m, m, m, m) - else - ( fromMaybe 0 (listToMaybe sorted) - , getIdx q1Idx - , getIdx q2Idx - , getIdx q3Idx - , last sorted - ) - -normalize :: [(Text, Double)] -> [(Text, Double)] -normalize xs = - let s = sum (map (abs . snd) xs) + 1e-12 - in [(n, max 0 (v / s)) | (n, v) <- xs] - -ticks1D :: - Int -> - Int -> - (Double, Double) -> - Bool -> - [(Int, Double)] -ticks1D screenLen want (vmin, vmax) invertY = - let n = max 2 want - lastIx = max 0 (screenLen - 1) - toVal t = - if invertY - then vmax - t * (vmax - vmin) - else vmin + t * (vmax - vmin) - mk' k = - let t = if n == 1 then 0 else fromIntegral k / fromIntegral (n - 1) - pos = round (t * fromIntegral lastIx) - in (pos, toVal t) - raw = [mk' k | k <- [0 .. n - 1]] - in List.nubBy (\a b -> fst a == fst b) raw - ------------------------------------------------------------------------- --- Layout record ------------------------------------------------------------------------- - data Layout = Layout { svgW :: !Double , svgH :: !Double - , plotX :: !Double -- left edge of plot area - , plotY :: !Double -- top edge of plot area - , plotW :: !Double -- width of plot area - , plotH :: !Double -- height of plot area + , plotX :: !Double + , plotY :: !Double + , plotW :: !Double + , plotH :: !Double } mkLayout :: Plot -> Layout mkLayout cfg = let pw = fromIntegral (widthChars cfg) * cW ph = fromIntegral (heightChars cfg) * cH - lm = fromIntegral (leftMargin cfg) * cW + 10 -- extra padding + lm = fromIntegral (leftMargin cfg) * cW + 10 tm = if T.null (plotTitle cfg) then 10 @@ -237,103 +155,6 @@ , plotH = ph } ------------------------------------------------------------------------- --- SVG primitives ------------------------------------------------------------------------- - -showD :: Double -> Text -showD d - | d == fromIntegral (round d :: Int) = T.pack (show (round d :: Int)) - | otherwise = T.pack (showFFloat (Just 2) d "") - -escXml :: Text -> Text -escXml = - T.replace "&" "&" - . T.replace "<" "<" - . T.replace ">" ">" - . T.replace "\"" """ - -attr :: Text -> Text -> Text -attr k v = " " <> k <> "=\"" <> v <> "\"" - -svgDoc :: Double -> Double -> Text -> Text -svgDoc w h content = - " attr "viewBox" ("0 0 " <> showD w <> " " <> showD h) - <> attr "width" (showD w) - <> attr "height" (showD h) - <> attr "font-family" "system-ui, -apple-system, sans-serif" - <> ">\n" - <> "\n" - <> content - <> "\n" - -svgRect :: Double -> Double -> Double -> Double -> Text -> Text -> Text -svgRect x y w h fill extra = - " attr "x" (showD x) - <> attr "y" (showD y) - <> attr "width" (showD w) - <> attr "height" (showD h) - <> attr "fill" fill - <> extra - <> "/>\n" - -svgCircle :: Double -> Double -> Double -> Text -> Text -svgCircle cx cy r fill = - " attr "cx" (showD cx) - <> attr "cy" (showD cy) - <> attr "r" (showD r) - <> attr "fill" fill - <> "/>\n" - -svgLine :: Double -> Double -> Double -> Double -> Text -> Double -> Text -svgLine x1 y1 x2 y2 stroke strokeW = - " attr "x1" (showD x1) - <> attr "y1" (showD y1) - <> attr "x2" (showD x2) - <> attr "y2" (showD y2) - <> attr "stroke" stroke - <> attr "stroke-width" (showD strokeW) - <> "/>\n" - -svgPolyline :: [(Double, Double)] -> Text -> Double -> Text -svgPolyline pts stroke strokeW = - " attr "points" (T.intercalate " " [showD x <> "," <> showD y | (x, y) <- pts]) - <> attr "fill" "none" - <> attr "stroke" stroke - <> attr "stroke-width" (showD strokeW) - <> attr "stroke-linejoin" "round" - <> attr "stroke-linecap" "round" - <> "/>\n" - -svgText :: Double -> Double -> Text -> Text -> Double -> Text -> Text -svgText x y anchor fill size content = - " attr "x" (showD x) - <> attr "y" (showD y) - <> attr "text-anchor" anchor - <> attr "fill" fill - <> attr "font-size" (showD size) - <> ">" - <> escXml content - <> "\n" - -svgPath :: Text -> Text -> Text -> Text -svgPath d fill extra = - " attr "d" d - <> attr "fill" fill - <> extra - <> "/>\n" - ------------------------------------------------------------------------- --- Shared drawing: title, axes, legend ------------------------------------------------------------------------- - drawTitle :: Plot -> Layout -> Text drawTitle cfg lay | T.null (plotTitle cfg) = "" @@ -353,11 +174,9 @@ pw = plotW lay ph = plotH lay - -- Axis lines xAxis = svgLine px (py + ph) (px + pw) (py + ph) "#aaa" 1 yAxis = svgLine px py px (py + ph) "#aaa" 1 - -- Y ticks yN = yNumTicks cfg yTks = ticks1D (round ph) yN (ymin, ymax) True ySlot = max 1 (leftMargin cfg) @@ -369,11 +188,10 @@ lbl = yFormatter cfg (yEnv i) ySlot v in svgLine px yy (px - 4) yy "#aaa" 1 <> svgText (px - 8) (yy + 4) "end" "#555" labelFontSize lbl - <> svgLine px yy (px + pw) yy "#eee" 0.5 -- grid line + <> svgLine px yy (px + pw) yy "#eee" 0.5 | (i, (pos, v)) <- zip [0 ..] yTks ] - -- X ticks xN = xNumTicks cfg xTks = ticks1D (round pw) xN (xmin, xmax) False xSlot = max 1 (round pw `div` max 1 xN) @@ -385,7 +203,7 @@ lbl = xFormatter cfg (xEnv i) xSlot v in svgLine xx (py + ph) xx (py + ph + 4) "#aaa" 1 <> svgText xx (py + ph + 16) "middle" "#555" labelFontSize lbl - <> svgLine xx py xx (py + ph) "#eee" 0.5 -- grid line + <> svgLine xx py xx (py + ph) "#eee" 0.5 | (i, (pos, v)) <- zip [0 ..] xTks ] in xAxis <> yAxis <> yElems <> xElems @@ -400,7 +218,6 @@ xAxis = svgLine px (py + ph) (px + pw) (py + ph) "#aaa" 1 yAxis = svgLine px py px (py + ph) "#aaa" 1 - -- Y ticks (value axis) yN = yNumTicks cfg yTks = ticks1D (round ph) yN (ymin, ymax) True ySlot = max 1 (leftMargin cfg) @@ -416,7 +233,6 @@ | (i, (pos, v)) <- zip [0 ..] yTks ] - -- X category labels n = length catNames catElems = T.concat @@ -459,24 +275,14 @@ (startX, "") entries ------------------------------------------------------------------------- --- Coordinate mapping ------------------------------------------------------------------------- - --- | Map data X to SVG X. mapX :: Layout -> Double -> Double -> Double -> Double mapX lay xmin xmax x = plotX lay + (x - xmin) / (xmax - xmin + eps) * plotW lay --- | Map data Y to SVG Y (flipped: higher values → lower Y). mapY :: Layout -> Double -> Double -> Double -> Double mapY lay ymin ymax y = plotY lay + plotH lay - (y - ymin) / (ymax - ymin + eps) * plotH lay ------------------------------------------------------------------------- --- SCATTER ------------------------------------------------------------------------- - scatter :: [(Text, [(Double, Double)])] -> Plot -> @@ -505,10 +311,6 @@ legend = drawLegend cfg lay [(n, col) | ((n, _), col) <- withCol] in svgDoc (svgW lay) (svgH lay) (title <> axes <> points <> legend) ------------------------------------------------------------------------- --- LINE GRAPH ------------------------------------------------------------------------- - lineGraph :: [(Text, [(Double, Double)])] -> Plot -> @@ -535,10 +337,6 @@ legend = drawLegend cfg lay [(n, col) | ((n, _), col) <- withCol] in svgDoc (svgW lay) (svgH lay) (title <> axes <> lines' <> legend) ------------------------------------------------------------------------- --- BARS ------------------------------------------------------------------------- - bars :: [(Text, Double)] -> Plot -> @@ -550,7 +348,7 @@ cols = cycle (colorPalette cfg) n = length kvs - barGap = 0.15 -- 15% gap on each side + barGap = 0.15 groupW = plotW lay / fromIntegral (max 1 n) rects = @@ -568,10 +366,6 @@ legend = drawLegend cfg lay [(name, col) | ((name, _), col) <- zip kvs cols] in svgDoc (svgW lay) (svgH lay) (title <> axes <> rects <> legend) ------------------------------------------------------------------------- --- STACKED BARS ------------------------------------------------------------------------- - stackedBars :: [(Text, [(Text, Double)])] -> Plot -> @@ -615,10 +409,6 @@ legend = drawLegend cfg lay [(n, col) | (n, col) <- seriesColors] in svgDoc (svgW lay) (svgH lay) (title <> axes <> rects <> legend) ------------------------------------------------------------------------- --- HISTOGRAM ------------------------------------------------------------------------- - histogram :: Bins -> [Double] -> @@ -656,10 +446,6 @@ legend = drawLegend cfg lay [("count", BrightCyan)] in svgDoc (svgW lay) (svgH lay) (title <> axes <> rects <> legend) ------------------------------------------------------------------------- --- PIE ------------------------------------------------------------------------- - pie :: [(Text, Double)] -> Plot -> @@ -715,10 +501,6 @@ legend = drawLegend cfg lay [(n, col) | (n, _, col) <- withP] in svgDoc (svgW lay) (svgH lay) (title <> slices <> legend) ------------------------------------------------------------------------- --- HEATMAP ------------------------------------------------------------------------- - heatmap :: [[Double]] -> Plot -> @@ -752,7 +534,7 @@ [ T.concat [ let cx = plotX lay + fromIntegral c * cellW cy = plotY lay + fromIntegral r * cellH - dataRow = rows - 1 - r -- flip: row 0 at bottom + dataRow = rows - 1 - r v = (matrix !! dataRow) !! c in svgRect cx cy cellW cellH (colorForVal v) "" | c <- [0 .. cols - 1] @@ -760,7 +542,6 @@ | r <- [0 .. rows - 1] ] - -- Axis labels: column indices on x, row indices on y colLabels = T.concat [ svgText @@ -784,7 +565,6 @@ | r <- [0 .. rows - 1] ] - -- Draw border border = svgRect (plotX lay) @@ -796,7 +576,6 @@ title = drawTitle cfg lay - -- Gradient legend gradLegend = let gw = min 200 (plotW lay * 0.5) gh = 12 @@ -829,10 +608,6 @@ (svgH lay) (title <> cells <> colLabels <> rowLabels <> border <> gradLegend) ------------------------------------------------------------------------- --- BOX PLOT ------------------------------------------------------------------------- - boxPlot :: [(Text, [Double])] -> Plot -> @@ -860,11 +635,9 @@ (minV, q1, med, q3, maxV) = qs col = colorHex c - -- Whisker: min to Q1 whiskerBot = svgLine midX (scY minV) midX (scY q1) col 1.5 capBot = svgLine (bx + boxW * 0.25) (scY minV) (bx + boxW * 0.75) (scY minV) col 1.5 - -- Box: Q1 to Q3 boxY = scY q3 boxH = scY q1 - scY q3 box = @@ -880,10 +653,8 @@ <> attr "rx" "2" ) - -- Median line medLine = svgLine bx (scY med) (bx + boxW) (scY med) col 2.5 - -- Whisker: Q3 to max whiskerTop = svgLine midX (scY q3) midX (scY maxV) col 1.5 capTop = svgLine (bx + boxW * 0.25) (scY maxV) (bx + boxW * 0.75) (scY maxV) col 1.5 in whiskerBot <> capBot <> whiskerTop <> capTop <> box <> medLine @@ -896,14 +667,42 @@ legend = drawLegend cfg lay [(name, col) | ((name, _), col) <- zip stats cols] in svgDoc (svgW lay) (svgH lay) (title <> axes <> boxes <> legend) -addAt :: [Int] -> Int -> Int -> [Int] -addAt xs i v = updateAt xs i (+ v) +area :: [(Text, [(Double, Double)])] -> Plot -> Text +area sers cfg = + renderChartSvg $ + LC.areaChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) -updateAt :: [a] -> Int -> (a -> a) -> [a] -updateAt xs i f - | i < 0 = xs - | otherwise = go xs i - where - go [] _ = [] - go (x : rest) 0 = f x : rest - go (x : rest) n = x : go rest (n - 1) +ribbon :: [(Text, [(Double, Double, Double)])] -> Plot -> Text +ribbon sers cfg = + renderChartSvg $ + LC.ribbonChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) + +density :: [(Text, [Double])] -> Plot -> Text +density sers cfg = + renderChartSvg $ + LC.densityChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) + +errorBars :: [(Text, [(Double, Double, Double, Double)])] -> Plot -> Text +errorBars sers cfg = + renderChartSvg $ + LC.errorBarsChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) + +funnel :: [(Text, Double)] -> Plot -> Text +funnel stages cfg = + renderChartSvg $ + LC.funnelChart stages (widthChars cfg) (heightChars cfg) (plotTitle cfg) + +polarLine :: [(Text, [(Double, Double)])] -> Plot -> Text +polarLine sers cfg = + renderChartSvg $ + LC.polarLineChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) + +waterfall :: [(Text, Double, Double)] -> Plot -> Text +waterfall rows cfg = + renderChartSvg $ + LC.waterfallChart rows (widthChars cfg) (heightChars cfg) (plotTitle cfg) + +distPlot :: [(Text, [Double])] -> Plot -> Text +distPlot sers cfg = + renderChartSvg $ + LC.distPlotChart sers (widthChars cfg) (heightChars cfg) (plotTitle cfg) diff --git a/test/Golden.hs b/test/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Golden.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +A tiny golden-file helper. Compares actual output against a reference +committed to @test/golden/@. Set @GRANITE_BLESS_GOLDEN=1@ to overwrite +the reference with the actual output (useful when you intentionally +change the renderer). + +Designed for the granite dep budget (base + text only): no +tasty-golden, no hspec-golden, no system-filepath. +-} +module Golden ( + goldenText, + goldenDir, +) where + +import Control.Exception (IOException, try) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import System.Environment (lookupEnv) +import System.IO (hPutStrLn, stderr) +import Test.Hspec + +goldenDir :: FilePath +goldenDir = "test/golden" + +{- | Compare @actual@ against the file at @goldenDir/name@. + + * If the file is missing → the test fails with a clear hint. + * If @GRANITE_BLESS_GOLDEN=1@ → write @actual@ to disk and pass. + * Otherwise compare byte-for-byte. +-} +goldenText :: FilePath -> Text -> Expectation +goldenText name actual = do + let path = goldenDir <> "/" <> name + blessing <- lookupEnv "GRANITE_BLESS_GOLDEN" + case blessing of + Just "1" -> do + Text.IO.writeFile path actual + hPutStrLn stderr ("blessed: " <> path) + _ -> do + r <- try (Text.IO.readFile path) :: IO (Either IOException Text) + case r of + Left _ -> + expectationFailure $ + "Missing golden file " + <> path + <> ".\nRun with GRANITE_BLESS_GOLDEN=1 to create it." + Right expected -> do + let aLines = Text.lines actual + eLines = Text.lines expected + if actual == expected + then pure () + else + expectationFailure $ + "Golden mismatch in " + <> path + <> "\nFirst diverging line " + <> firstDiff aLines eLines + <> "\n(Re-bless with GRANITE_BLESS_GOLDEN=1 if the change is intentional.)" + +firstDiff :: [Text] -> [Text] -> String +firstDiff as es = go 0 as es + where + go _ [] [] = "(unknown — file lengths match but bytes differ)" + go i [] (e : _) = " (line " <> show i <> ": actual EOF, expected " <> Text.unpack e <> ")" + go i (a : _) [] = " (line " <> show i <> ": actual " <> Text.unpack a <> ", expected EOF)" + go i (a : as') (e : es') + | a == e = go (i + 1) as' es' + | otherwise = + " (line " + <> show i + <> ":\n actual: " + <> Text.unpack a + <> "\n expected: " + <> Text.unpack e + <> ")" diff --git a/test/GoldenSpec.hs b/test/GoldenSpec.hs new file mode 100644 --- /dev/null +++ b/test/GoldenSpec.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GoldenSpec (spec) where + +import Data.Text (Text) + +import Golden (goldenText) +import Granite.Chart (lineChart, scatterChart) +import Granite.Color (Color (..)) +import Granite.Data.Frame (Column (..)) +import Granite.Render.Pipeline (renderChartSvg, renderChartTerminal) +import Granite.Render.Scene ( + Mark (..), + Point (..), + Rect (..), + Scene (..), + Style (..), + TextStyle (..), + defaultStyle, + defaultTextStyle, + ) +import Granite.Render.Svg qualified as Svg +import Granite.Render.Terminal qualified as Terminal +import Granite.Spec ( + BinSpec (..), + Chart (..), + ColumnRef (..), + Coord (..), + Facet (..), + FacetScales (..), + Geom (..), + Layer (..), + LogBase (..), + Mapping (..), + PolarAes (..), + PolarDir (..), + Scale (..), + Scales (..), + Size (..), + Stat (..), + defLayer, + defScaleOpts, + defScales, + emptyChart, + emptyMapping, + fromColumns, + scaleY, + ) +import Test.Hspec + +------------------------------------------------------------------------ +-- Fixtures +------------------------------------------------------------------------ + +quadraticSeries :: Text -> [(Double, Double)] -> (Text, [(Double, Double)]) +quadraticSeries n pts = (n, pts) + +twoSeriesScatter :: Chart +twoSeriesScatter = + scatterChart + [ quadraticSeries "A" [(0, 0), (1, 1), (2, 4), (3, 9), (4, 16)] + , quadraticSeries "B" [(0, 1), (1, 3), (2, 6), (3, 10), (4, 15)] + ] + (Just "Random points") + +singleSeriesLine :: Chart +singleSeriesLine = + lineChart + [("sine", [(x, sin x) | x <- [0, 0.5 .. 6.0]])] + (Just "sin(x)") + +logYScatter :: Chart +logYScatter = + twoSeriesScatter + { chartScales = defScales{scaleY = SLog Base10 defScaleOpts} + , chartTitle = Just "Log Y" + } + +responsiveScatter :: Chart +responsiveScatter = + twoSeriesScatter + { chartSize = SizeResponsive 1.6 + , chartTitle = Just "Responsive" + } + +reverseYLine :: Chart +reverseYLine = + singleSeriesLine + { chartScales = defScales{scaleY = SReverse (scaleY defScales)} + , chartTitle = Just "Reverse Y" + } + +flippedLine :: Chart +flippedLine = + lineChart + [("y=2x", [(0, 0), (1, 2), (2, 4), (3, 6), (4, 8)])] + (Just "CoordFlip") + `withCoord` CoordFlip + where + withCoord c k = c{chartCoord = k} + +-- A faceted scatter: same data spread across three panels by the +-- @series@ column. Tests FacetWrap layout + per-panel chrome. +facetedScatter :: Chart +facetedScatter = + let pts = + [ (0 :: Double, 1 :: Double, "A" :: Text) + , (1, 4, "A") + , (2, 9, "A") + , (3, 16, "A") + , (0, 0, "B") + , (1, 2, "B") + , (2, 4, "B") + , (3, 6, "B") + , (0, 5, "C") + , (1, 4, "C") + , (2, 3, "C") + , (3, 2, "C") + ] + xs = [x | (x, _, _) <- pts] + ys = [y | (_, y, _) <- pts] + gs = [g | (_, _, g) <- pts] + df = + fromColumns + [ ("x", ColNum xs) + , ("y", ColNum ys) + , ("series", ColCat gs) + ] + layer = + (defLayer GeomPoint) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartFacet = FacetWrap (ColumnRef "series") (Just 3) Nothing ScalesFixed + , chartTitle = Just "Faceted by series" + , chartSize = SizeChars 70 18 + } + +-- A vertical bar chart with pre-aggregated heights. Uses StatIdentity +-- (the ggplot @stat="identity"@ convention) so the Y values pass +-- through unchanged. Exercises GeomBar. +barBasic :: Chart +barBasic = + let xs = [0, 1, 2, 3] :: [Double] + ys = [12, 7, 18, 9] :: [Double] + df = fromColumns [("x", ColNum xs), ("y", ColNum ys)] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Bars" + , chartSize = SizeChars 40 14 + } + +-- Histogram of 50 numeric values bucketed into 8 bins. Exercises +-- StatBin + GeomHistogram. aesY points to the @count@ column that +-- StatBin emits, so the bar heights track the bin counts. +histBasic :: Chart +histBasic = + let raw = take 50 (cycle [1.0, 1.2, 1.8, 2.0, 2.3, 2.7, 3.1, 3.4, 3.8, 4.2]) + df = fromColumns [("x", ColNum raw)] + layer = + (defLayer GeomHistogram) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "count") + } + , layerStat = StatBin (BinByCount 8) + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Histogram" + , chartSize = SizeChars 44 14 + } + +-- Boxplot summarising three groups (A/B/C). Exercises StatBoxplot + +-- GeomBoxplot. +boxBasic :: Chart +boxBasic = + let pts = + [ (0 :: Double, v) + | v <- [1, 2, 3, 4, 5, 6, 7, 8, 9 :: Double] + ] + <> [(1, v) | v <- [3, 4, 5, 6, 7, 8, 9, 10, 11 :: Double]] + <> [(2, v) | v <- [5, 6, 7, 8, 9, 10, 11, 12, 13 :: Double]] + df = + fromColumns + [ ("g", ColNum [g | (g, _) <- pts]) + , ("y", ColNum [v | (_, v) <- pts]) + ] + layer = + (defLayer GeomBoxplot) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "g") + , aesY = Just (ColumnRef "y") + } + , layerStat = StatBoxplot + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Boxplot" + , chartSize = SizeChars 40 16 + } + +-- Pie chart of 4 slices. Exercises GeomArc. +pieBasic :: Chart +pieBasic = + let df = + fromColumns + [ ("slice", ColCat ["A", "B", "C", "D"]) + , ("value", ColNum [40, 25, 20, 15]) + ] + layer = + (defLayer GeomArc) + { layerMapping = + emptyMapping{aesY = Just (ColumnRef "value")} + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Pie" + , chartSize = SizeChars 30 16 + } + +-- A four-petal rose in polar coordinates: r = |sin(2θ)| sampled at 33 +-- angular positions. Locks in the polar projector + polar chrome. +polarRose :: Chart +polarRose = + let nSteps = 32 :: Int + pts = + [ (theta, abs (sin (2 * theta))) + | i <- [0 .. nSteps] + , let theta = (fromIntegral i / fromIntegral nSteps) * 2 * pi + ] + base = lineChart [("r = |sin(2θ)|", pts)] (Just "Polar rose") + in base + { chartCoord = CoordPolar ThetaX 0 PolarCCW + , chartSize = SizeChars 40 20 + } + +noTitleScatter :: Chart +noTitleScatter = twoSeriesScatter{chartTitle = Nothing} + +emptyChartFixture :: Chart +emptyChartFixture = emptyChart + +-- A scene mixing every primitive mark; locked in once so future renderer +-- changes have to be intentional. +mixedPrimitivesScene :: Scene +mixedPrimitivesScene = + Scene + { sceneWidth = 240 + , sceneHeight = 120 + , sceneMarks = + [ MRect (Rect 10 10 40 30) defaultStyle{styleFill = Just BrightBlue} + , MCircle (Point 120 50) 12 defaultStyle{styleFill = Just BrightRed} + , MPolyline + [Point 20 100, Point 80 80, Point 140 90, Point 220 70] + defaultStyle{styleStroke = Just BrightGreen, styleStrokeWidth = 2} + , MText (Point 120 25) "Primitives" defaultTextStyle{textFill = BrightYellow} + , MArc (Point 200 50) 20 0 1.5 defaultStyle{styleFill = Just BrightMagenta} + ] + } + +------------------------------------------------------------------------ +-- Spec +------------------------------------------------------------------------ + +spec :: Spec +spec = describe "Golden charts (run GRANITE_BLESS_GOLDEN=1 to refresh)" $ do + describe "Scatter" $ do + it "two-series scatter renders to expected terminal output" $ + goldenText "scatter-basic.txt" (renderChartTerminal twoSeriesScatter) + + it "two-series scatter renders to expected SVG output" $ + goldenText "scatter-basic.svg" (renderChartSvg twoSeriesScatter) + + it "no-title scatter renders to expected SVG output" $ + goldenText "scatter-no-title.svg" (renderChartSvg noTitleScatter) + + describe "Line chart" $ do + it "single-series line renders to expected terminal output" $ + goldenText "line-basic.txt" (renderChartTerminal singleSeriesLine) + + it "single-series line renders to expected SVG output" $ + goldenText "line-basic.svg" (renderChartSvg singleSeriesLine) + + describe "Scales" $ do + it "log-Y scatter renders to expected SVG output" $ + goldenText "scatter-log-y.svg" (renderChartSvg logYScatter) + + it "reverse-Y line renders to expected SVG output" $ + goldenText "line-reverse-y.svg" (renderChartSvg reverseYLine) + + describe "Coord" $ do + it "CoordFlip line renders to expected terminal output" $ + goldenText "line-coord-flip.txt" (renderChartTerminal flippedLine) + + it "CoordFlip line renders to expected SVG output" $ + goldenText "line-coord-flip.svg" (renderChartSvg flippedLine) + + it "Polar rose renders to expected terminal output" $ + goldenText "polar-rose.txt" (renderChartTerminal polarRose) + + it "Polar rose renders to expected SVG output" $ + goldenText "polar-rose.svg" (renderChartSvg polarRose) + + describe "Facets" $ do + it "FacetWrap by series renders to expected terminal output" $ + goldenText "facet-wrap.txt" (renderChartTerminal facetedScatter) + + it "FacetWrap by series renders to expected SVG output" $ + goldenText "facet-wrap.svg" (renderChartSvg facetedScatter) + + describe "Geoms (Phase 7b)" $ do + it "bar chart renders to expected terminal output" $ + goldenText "bar-basic.txt" (renderChartTerminal barBasic) + it "bar chart renders to expected SVG output" $ + goldenText "bar-basic.svg" (renderChartSvg barBasic) + + it "histogram renders to expected terminal output" $ + goldenText "hist-basic.txt" (renderChartTerminal histBasic) + it "histogram renders to expected SVG output" $ + goldenText "hist-basic.svg" (renderChartSvg histBasic) + + it "boxplot renders to expected terminal output" $ + goldenText "box-basic.txt" (renderChartTerminal boxBasic) + it "boxplot renders to expected SVG output" $ + goldenText "box-basic.svg" (renderChartSvg boxBasic) + + it "pie chart renders to expected SVG output" $ + goldenText "pie-basic.svg" (renderChartSvg pieBasic) + + describe "Sizing" $ do + it "responsive scatter renders to expected SVG output" $ + goldenText "scatter-responsive.svg" (renderChartSvg responsiveScatter) + + describe "Empty chart" $ do + it "empty chart renders to expected SVG output" $ + goldenText "empty.svg" (renderChartSvg emptyChartFixture) + + describe "Scene primitives" $ do + it "mixed-marks Scene → terminal" $ + goldenText "primitives.txt" (Terminal.renderScene mixedPrimitivesScene) + + it "mixed-marks Scene → SVG" $ + goldenText "primitives.svg" (Svg.renderScene mixedPrimitivesScene) diff --git a/test/PipelineSpec.hs b/test/PipelineSpec.hs new file mode 100644 --- /dev/null +++ b/test/PipelineSpec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} + +module PipelineSpec (spec) where + +import Data.Text qualified as Text + +import Granite.Render.Pipeline +import Granite.Render.Scene (Scene (..)) +import Granite.Spec +import Test.Hspec + +-- A scatter chart equivalent to the README example: two named series +-- of (x, y) data, rendered through the new IR pipeline. +scatterChart :: Chart +scatterChart = + emptyChart + { chartTitle = Just "Random points" + , chartSize = SizeChars 68 22 + , chartLayers = + [ pointLayer "A" [(0, 0), (1, 1), (2, 4), (3, 9), (4, 16)] + , pointLayer "B" [(0, 1), (1, 3), (2, 6), (3, 10), (4, 15)] + ] + } + where + pointLayer name pts = + let xs = map fst pts + ys = map snd pts + df = + fromColumns + [ ("x", ColNum xs) + , ("y", ColNum ys) + ] + in (defLayer GeomPoint) + { layerData = Just df + , layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesGroup = Just (ColumnRef name) + } + } + +spec :: Spec +spec = describe "Granite.Render.Pipeline" $ do + describe "scatter Chart through the IR" $ do + it "produces a non-empty Scene with both axes" $ do + let scene = chartToScene scatterChart + sceneWidth scene `shouldSatisfy` (> 0) + sceneHeight scene `shouldSatisfy` (> 0) + length (sceneMarks scene) `shouldSatisfy` (> 0) + + it "terminal output contains the title" $ do + let term = renderChartTerminal scatterChart + term `shouldSatisfy` Text.isInfixOf "Random points" + + it "SVG output contains the title and viewBox" $ do + let svg = renderChartSvg scatterChart + svg `shouldSatisfy` Text.isInfixOf "Random points" + svg `shouldSatisfy` Text.isInfixOf "viewBox" + + it "SVG output has axis structure (lines + tick text)" $ do + let svg = renderChartSvg scatterChart + -- Axes are emitted as (since the chrome + -- gridline/tick refactor); still appears for + -- data layers. + svg `shouldSatisfy` Text.isInfixOf "= 5 * 2) -- 5 points × 2 series + it "SVG output has a legend swatch per series" $ do + let svg = renderChartSvg scatterChart + nrects = Text.count "= 3) + + it "terminal line count is similar to legacy output" $ do + let term = renderChartTerminal scatterChart + lineCount = length (Text.lines term) + -- For a 68×22 char canvas plus title + bottom labels we expect + -- roughly 24 lines (22 plot rows + title + axis labels). + lineCount `shouldSatisfy` (>= 15) + lineCount `shouldSatisfy` (<= 40) + + describe "Log-scale chart" $ do + let logChart = + scatterChart + { chartScales = + defScales{scaleY = SLog Base10 defScaleOpts} + , chartTitle = Just "Log Y" + } + it "renders without error and includes log-friendly breaks" $ do + let svg = renderChartSvg logChart + svg `shouldSatisfy` Text.isInfixOf "Log Y" + svg `shouldSatisfy` Text.isInfixOf "= 0) + + describe "SizeResponsive" $ do + let responsive = + scatterChart{chartSize = SizeResponsive 2.0} + let fixed = + scatterChart{chartSize = SizeChars 60 20} + + it "drops absolute width/height for SizeResponsive" $ do + let svg = renderChartSvg responsive + svg `shouldSatisfy` Text.isInfixOf "viewBox=\"0 0" + svg `shouldSatisfy` Text.isInfixOf "preserveAspectRatio" + svg `shouldSatisfy` Text.isInfixOf "width=\"100%\"" + svg `shouldSatisfy` Text.isInfixOf "style=\"height:auto" + + it "keeps absolute width/height for SizeChars / SizePixels" $ do + let svg = renderChartSvg fixed + -- inspect just the opening tag, not the body + openSvg = Text.takeWhile (/= '>') (Text.dropWhile (/= '<') svg) + openSvg `shouldSatisfy` Text.isInfixOf "viewBox" + openSvg `shouldSatisfy` (not . Text.isInfixOf "preserveAspectRatio") + openSvg `shouldSatisfy` (not . Text.isInfixOf "width=\"100%\"") diff --git a/test/PlotlySpec.hs b/test/PlotlySpec.hs new file mode 100644 --- /dev/null +++ b/test/PlotlySpec.hs @@ -0,0 +1,467 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Replicas of canonical examples from the Plotly basic / statistical / +scientific / financial galleries: + + * https://plotly.com/python/basic-charts/ + * https://plotly.com/python/statistical-charts/ + * https://plotly.com/python/scientific-charts/ + * https://plotly.com/python/financial-charts/ + +Each fixture is one chart, locked as a terminal + SVG golden. Charts +already covered by 'GoldenSpec' (line, scatter, vertical bar, pie, +histogram, box plot, polar rose, log-Y) are not duplicated here. + +Out of scope (see memory @granite-ir-rewrite@ for the rationale): +3D, ternary, contour, network, dendrogram, sunburst, sankey, treemap, +gantt, candlestick / OHLC, gauge / indicator, imshow, wind rose, +violin, 2D-density heatmap. +-} +module PlotlySpec (spec) where + +import Data.Text (Text) +import Data.Text qualified as Text + +import Golden (goldenText) +import Granite.Data.Frame (Column (..), fromColumns) +import Granite.Render.Pipeline (renderChartSvg, renderChartTerminal) +import Granite.Spec ( + BinSpec (..), + Chart (..), + ColumnRef (..), + Coord (..), + Geom (..), + Layer (..), + Mapping (..), + Position (..), + Size (..), + Stat (..), + defLayer, + emptyChart, + emptyMapping, + ) +import Test.Hspec + +------------------------------------------------------------------------ +-- Spec entry +------------------------------------------------------------------------ + +spec :: Spec +spec = describe "Plotly gallery replicas (Phase 8)" $ do + describe "Basic" $ do + chartCase "plotly-bar-horizontal" horizontalBar + chartCase "plotly-bar-stacked" stackedBar + chartCase "plotly-bar-grouped" groupedBar + chartCase "plotly-area-filled" filledArea + + describe "Statistical" $ do + chartCase "plotly-error-bars" errorBars + chartCase "plotly-density" densityCurve + chartCase "plotly-distplot" distPlot + + describe "Scientific" $ do + chartCase "plotly-heatmap" heatmap + chartCase "plotly-heatmap-annotated" annotatedHeatmap + + describe "Financial" $ do + chartCase "plotly-funnel" funnel + chartCase "plotly-waterfall" waterfall + +-- | Bless one chart as a (terminal, svg) pair of goldens. +chartCase :: String -> Chart -> SpecWith () +chartCase name chart = do + it (name <> " — terminal") $ + goldenText (name <> ".txt") (renderChartTerminal chart) + it (name <> " — svg") $ + goldenText (name <> ".svg") (renderChartSvg chart) + +------------------------------------------------------------------------ +-- Basic +------------------------------------------------------------------------ + +{- | Horizontal bar chart: five items ranked left-to-right (highest +value at top). Built from a vertical bar + 'CoordFlip'. +-} +horizontalBar :: Chart +horizontalBar = + let xs = [0, 1, 2, 3, 4] :: [Double] + ys = [82, 67, 45, 33, 21] :: [Double] + df = fromColumns [("item", ColNum xs), ("value", ColNum ys)] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "item") + , aesY = Just (ColumnRef "value") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartCoord = CoordFlip + , chartTitle = Just "Top 5 (horizontal)" + , chartSize = SizeChars 60 16 + } + +{- | Stacked bar chart: four quarters × three product lines. Long +format + 'PosStack' splits each X-column into a vertical stack. +-} +stackedBar :: Chart +stackedBar = + let quarters = concat [replicate 3 q | q <- [0, 1, 2, 3 :: Double]] + products = take 12 (cycle ["Product A", "Product B", "Product C"]) + sales = [12, 8, 4, 15, 10, 6, 18, 12, 8, 22, 14, 10] :: [Double] + df = + fromColumns + [ ("quarter", ColNum quarters) + , ("product", ColCat products) + , ("sales", ColNum sales) + ] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "quarter") + , aesY = Just (ColumnRef "sales") + , aesGroup = Just (ColumnRef "product") + , aesFill = Just (ColumnRef "product") + } + , layerStat = StatIdentity + , layerPosition = PosStack + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Sales by quarter (stacked)" + , chartSize = SizeChars 60 16 + } + +{- | Grouped (dodged) bar chart: same data as 'stackedBar' but each +product sits side-by-side at every quarter via 'PosDodge'. +-} +groupedBar :: Chart +groupedBar = + stackedBar + { chartLayers = + [ (head (chartLayers stackedBar)) + { layerPosition = PosDodge 0.25 + } + ] + , chartTitle = Just "Sales by quarter (grouped)" + } + +{- | Filled area chart: a smooth curve with the region between the +curve and 'aesYmin'=0 shaded. +-} +filledArea :: Chart +filledArea = + let xs = [0 .. 12] :: [Double] + ys = [sin (x / 2) + 2 | x <- xs] + zeros = replicate (length xs) 0 :: [Double] + df = + fromColumns + [ ("x", ColNum xs) + , ("ymin", ColNum zeros) + , ("ymax", ColNum ys) + ] + layer = + (defLayer GeomRibbon) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesYmin = Just (ColumnRef "ymin") + , aesYmax = Just (ColumnRef "ymax") + } + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Filled area" + , chartSize = SizeChars 56 14 + } + +------------------------------------------------------------------------ +-- Statistical +------------------------------------------------------------------------ + +{- | Five (x, y) points each with a vertical confidence interval shown +as an 'MPolyline' error bar. Two layers: GeomPoint over GeomErrorbar. +-} +errorBars :: Chart +errorBars = + let xs = [1, 2, 3, 4, 5] :: [Double] + ys = [2.1, 3.5, 5.2, 4.7, 6.1] :: [Double] + los = [1.5, 2.8, 4.6, 4.0, 5.3] :: [Double] + his = [2.7, 4.2, 5.8, 5.4, 6.9] :: [Double] + df = + fromColumns + [ ("x", ColNum xs) + , ("y", ColNum ys) + , ("lo", ColNum los) + , ("hi", ColNum his) + ] + m = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesYmin = Just (ColumnRef "lo") + , aesYmax = Just (ColumnRef "hi") + } + pts = (defLayer GeomPoint){layerMapping = m, layerStat = StatIdentity} + bars = (defLayer GeomErrorbar){layerMapping = m, layerStat = StatIdentity} + in emptyChart + { chartData = df + , chartLayers = [bars, pts] + , chartTitle = Just "Measurements ± CI" + , chartSize = SizeChars 56 14 + } + +{- | Density (KDE) curve over a small sample. StatDensity produces a +(grid x, density) frame; GeomDensity renders it as a line. +-} +densityCurve :: Chart +densityCurve = + let sample = + [ 1.0 + , 1.2 + , 1.3 + , 1.4 + , 1.5 + , 1.7 + , 2.0 + , 2.1 + , 2.2 + , 2.3 + , 2.5 + , 2.8 + , 3.0 + , 3.1 + , 3.3 + , 3.4 + , 3.7 + , 3.9 + , 4.0 + , 4.2 + ] :: + [Double] + df = fromColumns [("x", ColNum sample)] + layer = + (defLayer GeomDensity) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "density") + } + , layerStat = StatDensity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Density (KDE)" + , chartSize = SizeChars 56 14 + } + +{- | Two layers on shared axes: a histogram of the sample with a KDE +line on top. The layers share the chart-level data frame. +-} +distPlot :: Chart +distPlot = + let sample = + [ 1.0 + , 1.2 + , 1.3 + , 1.4 + , 1.5 + , 1.7 + , 2.0 + , 2.1 + , 2.2 + , 2.3 + , 2.5 + , 2.8 + , 3.0 + , 3.1 + , 3.3 + , 3.4 + , 3.7 + , 3.9 + , 4.0 + , 4.2 + ] :: + [Double] + df = fromColumns [("x", ColNum sample)] + hist = + (defLayer GeomHistogram) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "count") + } + , layerStat = StatBin (BinByCount 8) + } + kde = + (defLayer GeomDensity) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "density") + } + , layerStat = StatDensity + } + in emptyChart + { chartData = df + , chartLayers = [hist, kde] + , chartTitle = Just "Distribution" + , chartSize = SizeChars 56 16 + } + +------------------------------------------------------------------------ +-- Scientific +------------------------------------------------------------------------ + +{- | A 5×5 heatmap with intensity varying as @sin(x) + cos(y)@. Rendered +via 'GeomTile' — the SVG backend gets distinct fill rectangles per +cell; terminal renders the cell outlines. +-} +heatmap :: Chart +heatmap = + let coords = + [ ( fromIntegral x + , fromIntegral y + , sin (fromIntegral x / 2) + cos (fromIntegral y / 2) + ) + | x <- [0 .. 4 :: Int] + , y <- [0 .. 4 :: Int] + ] + df = + fromColumns + [ ("x", ColNum [x | (x, _, _) <- coords]) + , ("y", ColNum [y | (_, y, _) <- coords]) + , ("z", ColNum [z | (_, _, z) <- coords]) + ] + layer = + (defLayer GeomTile) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesFill = Just (ColumnRef "z") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Heatmap" + , chartSize = SizeChars 48 16 + } + +{- | Same data as 'heatmap' but with value labels overlaid in each +cell via a 'GeomText' layer. Plotly\'s "annotated heatmap" example. +-} +annotatedHeatmap :: Chart +annotatedHeatmap = + let coords = + [ ( fromIntegral x + , fromIntegral y + , sin (fromIntegral x / 2) + cos (fromIntegral y / 2) + ) + | x <- [0 .. 4 :: Int] + , y <- [0 .. 4 :: Int] + ] + labels = [oneDecimal z | (_, _, z) <- coords] + df = + fromColumns + [ ("x", ColNum [x | (x, _, _) <- coords]) + , ("y", ColNum [y | (_, y, _) <- coords]) + , ("z", ColNum [z | (_, _, z) <- coords]) + , ("label", ColCat labels) + ] + labelLayer = + (defLayer GeomText) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesLabel = Just (ColumnRef "label") + } + , layerStat = StatIdentity + } + in heatmap + { chartData = df + , chartLayers = chartLayers heatmap <> [labelLayer] + , chartTitle = Just "Annotated heatmap" + } + +oneDecimal :: Double -> Text +oneDecimal v = + let rounded = fromIntegral (round (v * 10) :: Int) / 10 :: Double + in Text.pack (show rounded) + +------------------------------------------------------------------------ +-- Financial +------------------------------------------------------------------------ + +{- | Funnel: five sales-pipeline stages with shrinking counts. Built +from horizontal bars (CoordFlip + GeomBar). +-} +funnel :: Chart +funnel = + let xs = [0, 1, 2, 3, 4] :: [Double] + ys = [1000, 720, 480, 220, 120] :: [Double] + df = fromColumns [("stage", ColNum xs), ("count", ColNum ys)] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "stage") + , aesY = Just (ColumnRef "count") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartCoord = CoordFlip + , chartTitle = Just "Sales funnel" + , chartSize = SizeChars 60 14 + } + +{- | Waterfall: incremental deltas making up a final total. Built from +a stacked bar where the base of each bar is the running total up +to that step (encoded as a per-row __ybase via a manual second +layer; for the IR we just place each delta as a bar with its +visible y range). +-} +waterfall :: Chart +waterfall = + let xs = [0, 1, 2, 3, 4, 5] :: [Double] + -- starting total, three positive deltas, one negative, ending total + ystart = [0, 100, 130, 180, 175, 0] :: [Double] + yend = [100, 130, 180, 175, 195, 195] :: [Double] + -- We render the bars by reading the explicit __ybase column, + -- which the bar geom already understands (Phase 7a wrote that + -- convention). + df = + fromColumns + [ ("x", ColNum xs) + , ("y", ColNum yend) + , ("__ybase", ColNum ystart) + ] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartTitle = Just "Waterfall" + , chartSize = SizeChars 60 14 + } diff --git a/test/PositionSpec.hs b/test/PositionSpec.hs new file mode 100644 --- /dev/null +++ b/test/PositionSpec.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE OverloadedStrings #-} + +module PositionSpec (spec) where + +import Data.Text qualified as Text + +import Granite.Data.Frame ( + Column (..), + DataFrame (..), + fromColumns, + lookupColumn, + ) +import Granite.Position (applyPosition) +import Granite.Spec ( + ColumnRef (..), + Mapping (..), + Position (..), + emptyMapping, + ) +import Test.Hspec + +-- Long-format fixture: two X values, two series ("A", "B"), totals 30 +-- at X=1 and 40 at X=2. +sampleFrame :: DataFrame +sampleFrame = + fromColumns + [ ("x", ColNum [1, 1, 2, 2]) + , ("y", ColNum [10, 20, 15, 25]) + , ("series", ColCat ["A", "B", "A", "B"]) + ] + +sampleMapping :: Mapping +sampleMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesGroup = Just (ColumnRef "series") + } + +spec :: Spec +spec = describe "Granite.Position" $ do + describe "PosIdentity" $ do + it "leaves the frame unchanged" $ + applyPosition PosIdentity sampleMapping sampleFrame + `shouldBe` sampleFrame + + describe "PosStack" $ do + let stacked = applyPosition PosStack sampleMapping sampleFrame + + it "produces the same number of rows" $ do + let DataFrame cols = stacked + case lookup "x" cols of + Just (ColNum xs) -> length xs `shouldBe` 4 + _ -> expectationFailure "x column missing" + + it "stacks y values cumulatively within each x" $ do + case lookupColumn "y" stacked of + Just (ColNum ys) -> ys `shouldBe` [10, 30, 15, 40] + _ -> expectationFailure "y column missing" + + it "writes __ybase column with segment bottoms" $ do + case lookupColumn "__ybase" stacked of + Just (ColNum bs) -> bs `shouldBe` [0, 10, 0, 15] + _ -> expectationFailure "__ybase column missing" + + describe "PosFill" $ do + let filled = applyPosition PosFill sampleMapping sampleFrame + + it "normalises every x-group to sum to 1" $ do + case lookupColumn "y" filled of + Just (ColNum ys) -> + let near a b = abs (a - b) < 1e-9 + -- (10/30, (10+20)/30, 15/40, (15+25)/40) + expected = [1 / 3, 1, 3 / 8, 1] + in and (zipWith near ys expected) `shouldBe` True + _ -> expectationFailure "y column missing" + + describe "PosDodge" $ do + let dodged = applyPosition (PosDodge 0.3) sampleMapping sampleFrame + + it "preserves row count" $ do + case lookupColumn "x" dodged of + Just (ColNum xs) -> length xs `shouldBe` 4 + _ -> expectationFailure "x column missing" + + it "spreads two series symmetrically around the original x" $ do + -- nSeries=2, center=0.5, gap=0.3; series A gets -0.15, B gets +0.15 + case lookupColumn "x" dodged of + Just (ColNum xs) -> xs `shouldBe` [0.85, 1.15, 1.85, 2.15] + _ -> expectationFailure "x column missing" + + describe "PosJitter" $ do + let jittered = applyPosition (PosJitter 0.2 0.5) sampleMapping sampleFrame + + it "preserves row count" $ do + case lookupColumn "x" jittered of + Just (ColNum xs) -> length xs `shouldBe` 4 + _ -> expectationFailure "x column missing" + + it "is deterministic across runs" $ do + let again = applyPosition (PosJitter 0.2 0.5) sampleMapping sampleFrame + jittered `shouldBe` again + + it "keeps offsets within the requested amplitude" $ do + case (lookupColumn "x" jittered, lookupColumn "y" jittered) of + (Just (ColNum xs), Just (ColNum ys)) -> do + -- amplitude is ±dx and ±dy; allow a tiny epsilon + all (\(a, b) -> abs (a - b) <= 0.2 + 1e-9) (zip xs [1, 1, 2, 2]) + `shouldBe` True + all (\(a, b) -> abs (a - b) <= 0.5 + 1e-9) (zip ys [10, 20, 15, 25]) + `shouldBe` True + _ -> expectationFailure "x / y missing" + + describe "edge cases" $ do + it "stack with no group column treats everything as one series" $ do + let m = emptyMapping{aesX = Just (ColumnRef "x"), aesY = Just (ColumnRef "y")} + df = + fromColumns + [ ("x", ColNum [1, 1, 2]) + , ("y", ColNum [5, 10, 7]) + ] + stacked = applyPosition PosStack m df + case lookupColumn "y" stacked of + Just (ColNum ys) -> ys `shouldBe` [5, 15, 7] + _ -> expectationFailure "y missing" + + it "frame without the mapped x/y is returned unchanged for stack" $ do + let bare = fromColumns [("not_x", ColNum [1, 2, 3])] + m = emptyMapping{aesX = Just (ColumnRef "x"), aesY = Just (ColumnRef "y")} + applyPosition PosStack m bare `shouldBe` bare + + it "compiles against the Text import" $ + Text.length "ok" `shouldBe` 2 diff --git a/test/RenderSpec.hs b/test/RenderSpec.hs new file mode 100644 --- /dev/null +++ b/test/RenderSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +module RenderSpec (spec) where + +import Data.Text qualified as Text +import Granite.Color (Color (..)) +import Granite.Render.Scene +import Granite.Render.Svg qualified as Svg +import Granite.Render.Terminal qualified as Terminal +import Test.Hspec + +-- A small fixture exercising the four marks both backends understand today. +sampleScene :: Scene +sampleScene = + Scene + { sceneWidth = 200 + , sceneHeight = 100 + , sceneMarks = + [ MRect (Rect 10 10 40 30) defaultStyle{styleFill = Just BrightBlue} + , MCircle (Point 120 50) 12 defaultStyle{styleFill = Just BrightRed} + , MPolyline + [Point 20 80, Point 60 70, Point 100 75, Point 160 60] + defaultStyle{styleStroke = Just BrightGreen, styleStrokeWidth = 2} + , MText (Point 100 20) "Hello" defaultTextStyle{textFill = BrightYellow} + ] + } + +spec :: Spec +spec = do + describe "Granite.Render.Scene + backends" $ do + it "both backends accept the same Scene" $ do + let terminal = Terminal.renderScene sampleScene + svg = Svg.renderScene sampleScene + Text.length terminal `shouldSatisfy` (> 0) + Text.length svg `shouldSatisfy` (> 0) + + it "SVG output is a well-formed document with all four marks" $ do + let svg = Svg.renderScene sampleScene + svg `shouldSatisfy` Text.isInfixOf "" + svg `shouldSatisfy` Text.isInfixOf " 1) + + it "Terminal output dimensions track the scene size" $ do + let small = + Terminal.renderScene + sampleScene{sceneWidth = 80, sceneHeight = 32} + big = + Terminal.renderScene + sampleScene{sceneWidth = 320, sceneHeight = 128} + length (Text.lines big) `shouldSatisfy` (> length (Text.lines small)) + + it "An empty scene still renders without crashing" $ do + let empty = Scene 100 50 [] + term = Terminal.renderScene empty + svg = Svg.renderScene empty + Text.length term `shouldSatisfy` (>= 0) + svg `shouldSatisfy` Text.isInfixOf "" + Text.length (Terminal.renderScene grouped) + `shouldBe` Text.length (Terminal.renderScene flat) diff --git a/test/ScaleSpec.hs b/test/ScaleSpec.hs new file mode 100644 --- /dev/null +++ b/test/ScaleSpec.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ScaleSpec (spec) where + +import Granite.Scale (TrainedScale (..), niceNum, niceTicks, train) +import Granite.Spec ( + Expand (..), + LogBase (..), + Scale (..), + ScaleOpts (..), + defScaleOpts, + ) +import Test.Hspec +import Test.QuickCheck + +{- | A floating-point domain that the property tests treat as well-formed: +finite, non-NaN, and strictly increasing. +-} +data Domain = Domain {dLo :: Double, dHi :: Double} + deriving (Eq, Show) + +instance Arbitrary Domain where + arbitrary = do + a <- choose (-1000, 1000) + d <- choose (0.5, 1000) -- guaranteed positive span + pure (Domain a (a + d)) + +-- | A strictly-positive domain for log-scale tests. +data PosDomain = PosDomain {pdLo :: Double, pdHi :: Double} + deriving (Eq, Show) + +instance Arbitrary PosDomain where + arbitrary = do + lo <- choose (0.01, 100) + factor <- choose (1.1, 1000) + pure (PosDomain lo (lo * factor)) + +spec :: Spec +spec = describe "Granite.Scale" $ do + describe "niceNum" $ do + it "is idempotent on numbers already in {1,2,5} × 10^k" $ do + niceNum 1 False `shouldBe` 1 + niceNum 2 False `shouldBe` 2 + niceNum 5 False `shouldBe` 5 + niceNum 10 False `shouldBe` 10 + niceNum 100 False `shouldBe` 100 + niceNum 0.5 False `shouldBe` 0.5 + niceNum 0.1 False `shouldBe` 0.1 + + it "is always positive for positive input" $ + property $ \(Positive (x :: Double)) -> + niceNum x True > 0 + + it "is non-decreasing in 'ceil' mode" $ + property $ \(Positive (x :: Double)) -> + niceNum x False >= x + + describe "niceTicks" $ do + it "returns at least 2 ticks for a non-degenerate range" $ + property $ \(Domain lo hi) -> + length (niceTicks (lo, hi) 5) >= 2 + + it "ticks span the data range" $ + property $ \(Domain lo hi) -> + let ticks = niceTicks (lo, hi) 5 + tMin = minimum ticks + tMax = maximum ticks + in tMin <= lo + 1e-9 .&&. tMax >= hi - 1e-9 + + it "ticks are monotonically increasing" $ + property $ \(Domain lo hi) -> + let ticks = niceTicks (lo, hi) 5 + in and (zipWith (<) ticks (drop 1 ticks)) + + it "uses round-number step sizes ({1, 2, 5} × 10^k)" $ + property $ \(Domain lo hi) -> + let ticks = niceTicks (lo, hi) 5 + in case ticks of + (a : b : _) -> isRoundStep (b - a) + _ -> True + + it "tick count is reasonable for the requested target" $ + property $ \(Domain lo hi) -> + let ticks = niceTicks (lo, hi) 5 + n = length ticks + in n >= 2 .&&. n <= 12 -- nice numbers can over- or under-shoot a bit + describe "train (linear)" $ do + it "projects the lower bound to 0 and upper bound to 1" $ + property $ \(Domain lo hi) -> + let ts = train (SLinear defScaleOpts) (lo, hi) + (lo', hi') = tsDomain ts + in abs (tsProject ts lo') < 1e-9 + .&&. abs (tsProject ts hi' - 1) < 1e-9 + + it "is the identity round-trip: unproject . project ≈ id" $ + property $ \(Domain lo hi) (v0 :: Double) -> + let ts = train (SLinear defScaleOpts) (lo, hi) + (lo', hi') = tsDomain ts + v = lo' + (v0 `divNorm` (hi' - lo')) + t = tsProject ts v + v' = tsUnproject ts t + in abs (v - v') < 1e-6 .||. abs (hi' - lo') < 1e-12 + + it "applies the configured expansion factor symmetrically" $ + property $ \(Domain lo hi) -> + let mult = 0.1 + expand = Expand mult 0 + ts = train (SLinear defScaleOpts{scaleExpand = expand}) (lo, hi) + (lo', hi') = tsDomain ts + pad = (hi - lo) * mult + in abs ((lo - pad) - lo') < 1e-6 + .&&. abs ((hi + pad) - hi') < 1e-6 + + describe "train (log)" $ do + it "log-base-10 of 1..1000 produces three-decade nice breaks" $ do + let ts = train (SLog Base10 defScaleOpts) (1, 1000) + breaks = tsBreaks ts + length breaks `shouldSatisfy` (>= 2) + length breaks `shouldSatisfy` (<= 12) + -- All breaks must be positive powers of 10 + all + (\v -> abs (v - 10 ** fromIntegral (round (logBase 10 v) :: Int)) < 1e-6 * v) + breaks + `shouldBe` True + + it "handles data with zero by clamping the domain" $ do + -- previously this emitted hundreds of ticks; now caps at 10 + let ts = train (SLog Base10 defScaleOpts) (0, 100) + breaks = tsBreaks ts + length breaks `shouldSatisfy` (<= 12) + + it "is positive-only: projection of values below the floor saturates" $ do + let ts = train (SLog Base10 defScaleOpts) (1, 1000) + tsProject ts 0.0001 `shouldSatisfy` (\t -> t >= -1e-6) + + describe "train (sqrt)" $ do + it "projects 0 to 0 (sqrt scale is bounded at 0)" $ do + let ts = train (SSqrt defScaleOpts) (0, 100) + abs (tsProject ts 0) `shouldSatisfy` (< 0.1) + tsProject ts 100 `shouldSatisfy` (> 0.8) + + it "places 25 closer to 50% than to 50 (sqrt compresses tail)" $ do + let ts = train (SSqrt defScaleOpts) (0, 100) + t25 = tsProject ts 25 + t50 = tsProject ts 50 + -- sqrt(25) / sqrt(100) = 0.5 (so 25 lands at 50% — that's the point) + abs (t25 - 0.5) `shouldSatisfy` (< 0.1) + t50 `shouldSatisfy` (> t25) + + describe "train (reverse)" $ do + it "reverses the projection of its inner scale" $ + property $ \(Domain lo hi) (Positive (t :: Double)) -> + let unit = min 1.0 (t / 10) + inner = SLinear defScaleOpts{scaleExpand = Expand 0 0} + ts = train inner (lo, hi) + rs = train (SReverse inner) (lo, hi) + (l, h) = tsDomain ts + mid = l + unit * (h - l) + in abs (tsProject ts mid + tsProject rs mid - 1) < 1e-6 + + describe "train (identity)" $ do + it "projects values through unchanged" $ do + let ts = train SIdentity (0, 10) + tsProject ts 0 `shouldBe` 0 + tsProject ts 5 `shouldBe` 5 + tsUnproject ts 7 `shouldBe` 7 + +------------------------------------------------------------------------ +-- Helpers +------------------------------------------------------------------------ + +-- | Is @step@ of the form @{1, 2, 2.5, 5} × 10^k@? +isRoundStep :: Double -> Bool +isRoundStep s + | s <= 0 = False + | otherwise = + let k = floor (logBase 10 s) :: Int + mant = s / (10 ** fromIntegral k) + -- Heckbert's set is {1, 2, 5}; we are slightly looser. + allowed = [1, 2, 2.5, 5, 10] + in any (\a -> abs (mant - a) < 1e-6) allowed + +-- | Normalise a Double to a value in @[0, 1]@. +divNorm :: Double -> Double -> Double +divNorm v span_ + | abs span_ < 1e-12 = 0 + | otherwise = + let u = abs v / (abs v + 1) + in u * span_ diff --git a/test/SpecPropSpec.hs b/test/SpecPropSpec.hs new file mode 100644 --- /dev/null +++ b/test/SpecPropSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SpecPropSpec (spec) where + +import Data.Text qualified as Text + +import Granite.Color (Color (..)) +import Granite.Spec +import Test.Hspec + +-- A representative chart that exercises every constructor we expect to +-- be JSON-faithful: layers with mappings + stats + positions, scales of +-- various transforms, polar coord, facet wrap, theme, responsive size. +representativeChart :: Chart +representativeChart = + emptyChart + { chartData = + fromColumns + [ ("x", ColNum [1, 2, 3, 4, 5]) + , ("y", ColNum [1.1, 4.0, 9.2, 16.05, 25.5]) + , ("group", ColCat ["A", "A", "B", "B", "B"]) + , + ( "when" + , ColTime + [1700000000000, 1700000003600, 1700000007200, 1700000010800, 1700000014400] + ) + , ("active", ColBool [True, False, True, False, True]) + ] + , chartLayers = + [ (defLayer GeomPoint) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "x") + , aesY = Just (ColumnRef "y") + , aesColor = Just (ColumnRef "group") + } + , layerAesDef = emptyAesDefaults{defSize = Just 3} + } + , (defLayer GeomLine) + { layerMapping = + emptyMapping{aesX = Just (ColumnRef "x"), aesY = Just (ColumnRef "y")} + , layerStat = StatSmooth (SmoothLoess 0.5) + } + , (defLayer GeomBar) + { layerMapping = emptyMapping{aesX = Just (ColumnRef "group")} + , layerStat = StatCount + , layerPosition = PosDodge 0.1 + } + ] + , chartScales = + defScales + { scaleX = SLog Base10 defScaleOpts{scaleBreaks = BreaksCount 5} + , scaleY = SSqrt defScaleOpts{scaleLabels = FormatPrecision 2} + , scaleColor = + Just (SColorDiscrete [NamedColor BrightBlue, Hex "#ff0000", RGB 0 128 0]) + } + , chartCoord = CoordPolar ThetaX 0 PolarCCW + , chartFacet = FacetWrap (ColumnRef "group") (Just 2) Nothing ScalesFreeY + , chartTitle = Just "Round-trip fixture" + , chartSize = SizeResponsive 1.5 + } + +spec :: Spec +spec = describe "Granite.Spec" $ do + describe "show / read round trip (sentinel for JSON faithfulness)" $ do + it "round-trips emptyChart" $ do + (read (show emptyChart) :: Chart) `shouldBe` emptyChart + + it "round-trips a representative chart" $ do + (read (show representativeChart) :: Chart) `shouldBe` representativeChart + + it "double-encoding is idempotent" $ do + let s = show representativeChart + show (read s :: Chart) `shouldBe` s + + describe "DataFrame" $ do + it "addColumn preserves order" $ do + let f = + addColumn "z" (ColNum [3]) $ + addColumn "y" (ColNum [2]) $ + addColumn "x" (ColNum [1]) emptyFrame + columnNames f `shouldBe` ["x", "y", "z"] + + it "addColumn replaces existing in place" $ do + let f0 = + addColumn "y" (ColNum [10]) $ + addColumn "x" (ColNum [1]) emptyFrame + f1 = addColumn "x" (ColNum [99]) f0 + columnNames f1 `shouldBe` ["x", "y"] + lookupColumn "x" f1 `shouldBe` Just (ColNum [99]) + + it "frameLength is the longest column" $ do + let f = + addColumn "short" (ColNum [1]) $ + addColumn "long" (ColNum [1, 2, 3]) emptyFrame + frameLength f `shouldBe` 3 + + describe "Granite.Format" $ do + it "FormatPrecision 2 uses fixed notation" $ + runFormatter (FormatPrecision 2) 3.14159 `shouldBe` "3.14" + it "FormatPercent 1 multiplies by 100" $ + runFormatter (FormatPercent 1) 0.345 `shouldBe` "34.5%" + it "FormatComma groups thousands" $ + runFormatter FormatComma 1234567 `shouldBe` "1,234,567" + it "FormatSI uses k for thousands" $ + Text.isInfixOf "k" (runFormatter FormatSI 1500) `shouldBe` True + it "FormatSI uses M for millions" $ + Text.isInfixOf "M" (runFormatter FormatSI 2_500_000) `shouldBe` True diff --git a/test/StatSpec.hs b/test/StatSpec.hs new file mode 100644 --- /dev/null +++ b/test/StatSpec.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} + +module StatSpec (spec) where + +import Granite.Spec (BinSpec (..), SummaryFun (..)) +import Granite.Stat ( + BoxStats (..), + binData, + boxplotSummary, + countByCategory, + kdeData, + smoothLm, + smoothMovingAvg, + summarizeByCategory, + ) +import Test.Hspec + +spec :: Spec +spec = describe "Granite.Stat" $ do + describe "binData" $ do + it "10 evenly-spaced values into 5 equal-width bins → counts of 2 each" $ do + let xs = [0.5, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5] + (mids, counts) = binData (BinByCount 5) xs + length mids `shouldBe` 5 + counts `shouldBe` [2, 2, 2, 2, 2] + + it "BinByWidth covers every input value" $ do + let (_, counts) = binData (BinByWidth 1.0) [0, 0.5, 1.2, 1.8, 2.1] + sum counts `shouldBe` 5 + + it "BinByEdges respects manual breaks" $ do + let (_, counts) = binData (BinByEdges [0, 1, 2, 3]) [0.5, 1.5, 2.5, 2.7] + counts `shouldBe` [1, 1, 2] + + it "empty input → empty output" $ + binData (BinByCount 5) [] `shouldBe` ([], []) + + describe "kdeData" $ do + it "produces n grid points" $ do + let (gx, gy) = kdeData 64 [0, 1, 2, 3, 4, 5] + length gx `shouldBe` 64 + length gy `shouldBe` 64 + + it "all density values are non-negative" $ do + let (_, gy) = kdeData 32 [0, 1, 2, 3, 4, 5] + all (>= 0) gy `shouldBe` True + + describe "smoothLm" $ do + it "fits a perfect line exactly" $ do + let xs = [0, 1, 2, 3, 4] + ys = [1, 3, 5, 7, 9] + fitted = smoothLm xs ys + all (< 1e-9) (zipWith (\a b -> abs (a - b)) ys fitted) `shouldBe` True + + describe "smoothMovingAvg" $ do + it "window of 1 is identity" $ + smoothMovingAvg 1 [1, 2, 3, 4, 5] `shouldBe` [1, 2, 3, 4, 5] + + it "window of 3 on a constant signal preserves the constant" $ + all (== 3) (smoothMovingAvg 3 [3, 3, 3, 3, 3]) `shouldBe` True + + describe "boxplotSummary" $ do + it "[1..9] → min=1, Q1=3, med=5, Q3=7, max=9" $ do + let bs = boxplotSummary [1 .. 9] + yMin bs `shouldBe` 1 + q1 bs `shouldBe` 3 + med bs `shouldBe` 5 + q3 bs `shouldBe` 7 + yMax bs `shouldBe` 9 + + describe "countByCategory" $ do + it "preserves first-seen order" $ + countByCategory ["b", "a", "b", "c", "a"] + `shouldBe` [("b", 2), ("a", 2), ("c", 1)] + + describe "summarizeByCategory" $ do + it "mean per group" $ + summarizeByCategory SumMean [("a", 1), ("a", 3), ("b", 10), ("b", 20)] + `shouldBe` [("a", 2.0), ("b", 15.0)] + + it "sum per group" $ + summarizeByCategory SumSum [("a", 1), ("a", 3), ("b", 10), ("b", 20)] + `shouldBe` [("a", 4.0), ("b", 30.0)] + + it "median per group" $ + summarizeByCategory + SumMedian + [("a", 1), ("a", 2), ("a", 3), ("b", 10), ("b", 20), ("b", 30)] + `shouldBe` [("a", 2.0), ("b", 20.0)]