diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for granite +## 0.7.3.0 -- 2026-06-19 +* improved long text/axis display +* flame graphs +* fix exact colour in SVG charts + ## 0.7.1.1 -- 2026-05-25 * `GeomTile` honours a continuous `scaleFill` (`SColorContinuous`) via smooth RGB interpolation, and no longer emits a stray category legend entry. 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.7.2.0 +version: 0.7.3.0 synopsis: Easy terminal plotting. description: A terminal plotting library for quick and easy visualisation. license: MIT @@ -48,6 +48,7 @@ Granite.Chart, Granite.Color, Granite.Data.Frame, + Granite.Flame, Granite.Format, Granite.Position, Granite.Render.Chrome, @@ -84,6 +85,7 @@ main-is: Spec.hs other-modules: + FlameSpec Golden GoldenSpec GraniteSpec diff --git a/src/Granite.hs b/src/Granite.hs --- a/src/Granite.hs +++ b/src/Granite.hs @@ -85,6 +85,12 @@ polarLine, waterfall, distPlot, + + -- * Differential flame graphs + FlameNode (..), + FlameOpts (..), + defFlameOpts, + flameDiff, ) where import Data.Bits (xor, (.&.)) @@ -96,6 +102,12 @@ import Text.Printf import Granite.Color (Color (..), paint, paletteColors, pieColors) +import Granite.Flame ( + FlameNode (..), + FlameOpts (..), + defFlameOpts, + flameDiff, + ) import Granite.Internal.LegacyChart qualified as LC import Granite.Internal.Util ( addAt, diff --git a/src/Granite/Flame.hs b/src/Granite/Flame.hs new file mode 100644 --- /dev/null +++ b/src/Granite/Flame.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +{- | +Module : Granite.Flame +Copyright : (c) 2025 +License : MIT +Maintainer : mschavinda@gmail.com + +Differential flame\/icicle graphs. A 'FlameNode' tree carries, per frame, the +summed positive delta ('fnPos', an increase) and the magnitude of the summed +negative delta ('fnNeg', a decrease, kept non-negative). 'flameDiff' lays the +tree out top→down by depth and emits a standalone @\@ document. + +A frame's width is its /churn/ (@fnPos + fnNeg@) relative to the root churn. +Within a frame a red part (the increase) and a blue part (the decrease) are +drawn side by side, so a relocation — equal @+x@\/@-x@ — reads as half-red\/ +half-blue rather than as a net regression. +-} +module Granite.Flame ( + FlameNode (..), + FlameOpts (..), + defFlameOpts, + flameDiff, +) where + +import Data.List (sortOn) +import Data.Ord (Down (..)) +import Data.Text (Text) +import Data.Text qualified as T + +import Granite.Color (Color (..), colorHex) +import Granite.Internal.Util (escXml, showD, truncatePx) +import Granite.Render.Svg (attr, svgDoc) + +data FlameNode = FlameNode + { fnLabel :: Text + -- ^ Frame name. + , fnPos :: Double + {- ^ Summed positive self-delta in this subtree (an increase), in bytes + (tooltips format it as MB). + -} + , fnNeg :: Double + {- ^ Summed negative magnitude in this subtree (a decrease, @>= 0@), in bytes + (tooltips format it as MB). + -} + , fnChildren :: [FlameNode] + } + deriving (Eq, Show) + +data FlameOpts = FlameOpts + { foWidth :: Double + -- ^ Total SVG width in px. + , foRowH :: Double + -- ^ Height of one depth row in px. + , foMaxDepth :: Int + -- ^ Deepest depth drawn (root is depth 0). + , foTitle :: Text + -- ^ Heading drawn above the chart. + , foMinPx :: Double + -- ^ Frames narrower than this (in px) are dropped. + } + deriving (Eq, Show) + +defFlameOpts :: FlameOpts +defFlameOpts = + FlameOpts + { foWidth = 1200 + , foRowH = 18 + , foMaxDepth = 24 + , foTitle = "Differential flame graph" + , foMinPx = 1.5 + } + +flameRed :: Color +flameRed = Color 206 80 80 + +flameBlue :: Color +flameBlue = Color 80 100 206 + +-- | The churn (rendered width unit) of a frame: its red + blue magnitude. +churn :: FlameNode -> Double +churn n = fnPos n + fnNeg n + +{- | Render a differential flame graph as a full standalone @\@ document. +Rows go top→down by depth; a frame's width is proportional to its churn over the +root churn; children are laid left→right sorted by descending churn; frames +narrower than 'foMinPx' are dropped and recursion stops past 'foMaxDepth'. +-} +flameDiff :: FlameNode -> FlameOpts -> Text +flameDiff root opts = + let titleH = if T.null (foTitle opts) then 0 else 24 + body = layout opts root 0 0 (foWidth opts) titleH + depthUsed = maxDepthDrawn opts root 0 (foWidth opts) + svgH = titleH + fromIntegral (depthUsed + 1) * foRowH opts + 4 + heading + | T.null (foTitle opts) = "" + | otherwise = + " attr "x" (showD 8) + <> attr "y" (showD 16) + <> attr "font-size" (showD 13) + <> attr "font-weight" "600" + <> attr "fill" "#222" + <> ">" + <> escXml (foTitle opts) + <> "\n" + in svgDoc (foWidth opts) svgH (heading <> body) + +{- | Children paired with their pixel width given the parent's width @w@, +left→right in draw order (descending churn). Shared by 'layout' and +'maxDepthDrawn' so the height estimate uses the same widths that are drawn. +-} +childWidths :: FlameNode -> Double -> [(FlameNode, Double)] +childWidths node w + | total <= 0 = [] + | otherwise = + [(k, churn k / total * w) | k <- sortOn (Down . churn) (fnChildren node)] + where + total = churn node + +{- | The deepest depth that will actually be drawn, so the SVG height fits the +visible frames rather than 'foMaxDepth'. Measures child widths against the +parent's narrowed width (via 'childWidths'), matching 'layout'. +-} +maxDepthDrawn :: FlameOpts -> FlameNode -> Int -> Double -> Int +maxDepthDrawn opts node depth w + | depth >= foMaxDepth opts = depth + | otherwise = case visible of + [] -> depth + kids -> maximum (depth : [maxDepthDrawn opts k (depth + 1) kw | (k, kw) <- kids]) + where + visible = [(k, kw) | (k, kw) <- childWidths node w, kw >= foMinPx opts] + +{- | Emit a frame and its children. @x0@ is the frame's left edge in px, @w@ its +width in px; children share the parent's width split by churn proportion. +-} +layout :: FlameOpts -> FlameNode -> Int -> Double -> Double -> Double -> Text +layout opts node depth x0 w yOff + | depth > foMaxDepth opts = "" + | w < foMinPx opts = "" + | otherwise = frame <> childMarks + where + y = yOff + fromIntegral depth * foRowH opts + frame = drawFrame opts node x0 y w + childMarks = T.concat (go x0 (childWidths node w)) + go _ [] = [] + go cx ((k, kw) : ks) = + layout opts k (depth + 1) cx kw yOff : go (cx + kw) ks + +{- | One frame: a red rect (width ∝ 'fnPos') then a blue rect (width ∝ 'fnNeg') +side by side, a thin white stroke, a clipped label when wide enough, and a +@\@ tooltip carrying the full label plus the pos\/neg in MB. +-} +drawFrame :: FlameOpts -> FlameNode -> Double -> Double -> Double -> Text +drawFrame opts node x y w = + "" <> tooltip <> redRect <> blueRect <> label <> "\n" + where + h = foRowH opts - 1 + total = churn node + posW = if total <= 0 then 0 else fnPos node / total * w + negW = w - posW + redRect = rectAt x y posW h flameRed + blueRect = rectAt (x + posW) y negW h flameBlue + tooltip = "" <> escXml titleTxt <> "" + titleTxt = + fnLabel node + <> " (+" + <> mb (fnPos node) + <> " / -" + <> mb (fnNeg node) + <> ")" + label + | w < 24 = "" + | otherwise = + let (txt, _) = truncatePx 11 (w - 6) (fnLabel node) + in " attr "x" (showD (x + 3)) + <> attr "y" (showD (y + h - 4)) + <> attr "font-size" (showD 11) + <> attr "fill" "#fff" + <> ">" + <> escXml txt + <> "\n" + +rectAt :: Double -> Double -> Double -> Double -> Color -> Text +rectAt x y w h fill + | w <= 0 = "" + | otherwise = + " attr "x" (showD x) + <> attr "y" (showD y) + <> attr "width" (showD w) + <> attr "height" (showD h) + <> attr "fill" (colorHex fill) + <> attr "stroke" "#ffffff" + <> attr "stroke-width" (showD 0.5) + <> "/>\n" + +-- | Format a byte magnitude as megabytes to one decimal place (e.g. @9.4MB@). +mb :: Double -> Text +mb bytes = showD (roundTo 1 (bytes / 1e6)) <> "MB" + +-- | Round to @n@ decimal places. +roundTo :: Int -> Double -> Double +roundTo n x = fromIntegral (round (x * f) :: Integer) / f + where + f = 10 ^ n diff --git a/src/Granite/Render/Chrome.hs b/src/Granite/Render/Chrome.hs --- a/src/Granite/Render/Chrome.hs +++ b/src/Granite/Render/Chrome.hs @@ -272,9 +272,6 @@ , textRotate = rot , textTitle = title } - -- Upright labels are truncated to their per-tick slot so they never overrun - -- it — the only path that bites is the faceted fallback, where rotation is - -- forbidden and a long category would otherwise overflow its cell. upright slot (xp, full) = let (lbl, title) = truncatePx fontSize slot full in MText (Point xp baseY) lbl (sty AnchorMiddle 0 title) @@ -459,7 +456,7 @@ swatch = MRect (Rect lx yy 12 12) - defaultStyle{styleFill = Just (colorOfSpec col)} + defaultStyle{styleFill = Just (exactColor col)} label = MText (Point (lx + 16) (yy + themeFontSize theme - 1)) @@ -472,6 +469,17 @@ in [swatch, label] | (i, (name, col)) <- zip [0 :: Int ..] entries ] + +{- | The exact RGB 'Color' for a spec, so a legend swatch matches the data it +labels (the SVG backend renders it exactly; the terminal backend quantises +'Color' to ANSI at draw time). Contrast 'colorOfSpec', which quantises eagerly. +-} +exactColor :: ColorSpec -> Color +exactColor (NamedColor c) = c +exactColor (RGB r g b) = Color r g b +exactColor (Hex h) = case parseHex h of + Just (r, g, b) -> Color (round r) (round g) (round b) + Nothing -> Default {- | Quantise a 'ColorSpec' to the nearest ANSI 'Color' for the terminal backend; SVG reads RGB / Hex directly. diff --git a/src/Granite/Render/Pipeline.hs b/src/Granite/Render/Pipeline.hs --- a/src/Granite/Render/Pipeline.hs +++ b/src/Granite/Render/Pipeline.hs @@ -18,6 +18,7 @@ chartToScene, ) where +import Control.Applicative ((<|>)) import Data.List qualified as List import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -154,10 +155,17 @@ hasTitle = case chartTitle chart of Just t -> not (Text.null t) Nothing -> False - colorMaps = map (layerColorMap palette (chartData chart)) (chartLayers chart) fillCols = case scaleFill (chartScales chart) of Just (SColorContinuous cs) -> Just cs _ -> Nothing + fillManual = case scaleFill (chartScales chart) of + Just (SColorManual pairs) -> Just pairs + Just (SColorDiscrete cs) -> Just (discreteFillMap chart cs) + _ -> Nothing + -- The fill scale is folded into 'colorMaps' here so a single + -- category→colour map drives both the bars and the legend swatches. + colorMaps = + map (layerColorMap palette fillManual (chartData chart)) (chartLayers chart) legendEntries = collectLegend (chartLayers chart) palette colorMaps hasRightLegend = not (null legendEntries) -- Size margins to the actual labels so long words never clip, and decide @@ -186,7 +194,14 @@ panels = layoutPanels theme box chart panelMarks = concatMap - (renderPanel theme palette coord (alMode layout) colorMaps fillCols) + ( renderPanel + theme + palette + coord + (alMode layout) + colorMaps + fillCols + ) panels legend = legendMarks theme box legendEntries @@ -514,6 +529,13 @@ | Just cats <- categoricalColorColumn frame m -> map (\cat -> specToColor (fromMaybe colorSpec (lookup cat levelColors))) cats _ -> repeat col + -- Per-bar fill colours: a categorical 'aesFill' (falling back to + -- 'aesColor') maps each bar to its colour from 'colorMap', which already + -- folds in any manual\/discrete fill scale (see 'layerColorMap'), so the + -- bars and the legend swatches agree. Unmapped categories keep 'col'. + barColors = case categoricalFillColumn frame m of + Just cats -> map (\cat -> maybe col specToColor (colorMap >>= lookup cat)) cats + Nothing -> repeat col pointAlphas = case resolveNumColumn frame (aesAlpha m) of Just vs@(_ : _) -> let lo = minimum vs @@ -525,9 +547,9 @@ in case layerGeom layer of GeomPoint -> drawPoints proj frame m pointColors radius pointAlphas 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 + GeomBar -> drawBars proj frame m barColors + GeomCol -> drawBars proj frame m barColors + GeomHistogram -> drawBars proj frame m barColors GeomRibbon -> drawRibbon proj frame m col GeomErrorbar -> drawErrorbar proj frame m col GeomTile -> drawTiles proj frame m col fillCols @@ -579,21 +601,26 @@ ] _ -> [] -drawBars :: Projector -> DataFrame -> Mapping -> Color -> [Mark] -drawBars proj frame m col = +{- | One rect per row; each painted its own colour from 'cols', cycled when +shorter than the rows, so a categorical @aesFill@\/@aesColor@ gives each bar a +distinct fill rather than a single constant colour. Empty 'cols' draws nothing. +-} +drawBars :: Projector -> DataFrame -> Mapping -> [Color] -> [Mark] +drawBars proj frame m cols = 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 - ] + (Just xs, Just ys) + | not (null cols) -> + 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) + c + | ((x, y1, y0), c) <- zip (zip3 xs ys bases) (cycle cols) + ] _ -> [] barWidth :: [Double] -> Double @@ -1010,21 +1037,41 @@ | null palette = NamedColor BrightBlue | otherwise = palette !! (i `mod` length palette) -{- | The per-category colour map for a layer, when its 'aesColor' maps to a -categorical ('ColCat') column. Computed once from the whole-chart layer frame so -colours stay consistent across facets and the legend; 'Nothing' otherwise -(numeric colour columns keep the single per-layer colour). +{- | The per-category colour map for a layer, when its 'aesColor' (points) or +'aesFill' (bars) maps to a categorical ('ColCat') column. Computed once from the +whole-chart layer frame so colours stay consistent across facets, bars, and the +legend; 'Nothing' otherwise (numeric colour columns keep the single per-layer +colour). For bars, any manual\/discrete fill scale ('fillOverride') is layered +on top of the palette so the legend swatches match the bars. -} -layerColorMap :: [ColorSpec] -> DataFrame -> Layer -> Maybe [(Text, ColorSpec)] -layerColorMap palette globalFrame layer +layerColorMap :: + [ColorSpec] -> + Maybe [(Text, ColorSpec)] -> + DataFrame -> + Layer -> + Maybe [(Text, ColorSpec)] +layerColorMap palette fillOverride globalFrame layer | GeomPoint <- layerGeom layer - , Just cats <- - categoricalColorColumn - (fromMaybe globalFrame (layerData layer)) - (layerMapping layer) = + , Just cats <- categoricalColorColumn frame (layerMapping layer) = Just (categoricalColorMap palette (List.nub cats)) + | isBarGeom (layerGeom layer) + , Just cats <- categoricalFillColumn frame (layerMapping layer) = + Just (overrideColors fillOverride (categoricalColorMap palette (List.nub cats))) | otherwise = Nothing + where + frame = fromMaybe globalFrame (layerData layer) +{- | Replace the colour of each category that appears in 'override', leaving the +rest at their base (palette) colour. +-} +overrideColors :: + Maybe [(Text, ColorSpec)] -> [(Text, ColorSpec)] -> [(Text, ColorSpec)] +overrideColors override base = + [(cat, fromMaybe spec (override >>= lookup cat)) | (cat, spec) <- base] + +isBarGeom :: Geom -> Bool +isBarGeom g = g `elem` [GeomBar, GeomCol, GeomHistogram] + {- | The categorical ('ColCat') colour column's per-row values, if 'aesColor' maps to one. -} @@ -1034,6 +1081,36 @@ Just (ColCat xs) -> Just xs _ -> Nothing Nothing -> Nothing + +{- | The categorical ('ColCat') fill column's per-row values: 'aesFill' if it +maps to one, else 'aesColor'. Drives per-bar colours for bar\/col\/histogram. +-} +categoricalFillColumn :: DataFrame -> Mapping -> Maybe [Text] +categoricalFillColumn frame m = + catColumn (aesFill m) <|> categoricalColorColumn frame m + where + catColumn ref = case ref of + Just (ColumnRef n) -> case lookupColumn n frame of + Just (ColCat xs) -> Just xs + _ -> Nothing + Nothing -> Nothing + +{- | Resolve a discrete fill scale ('SColorDiscrete') into an explicit +category→colour map by zipping the chart's fill categories against the supplied +colours (cycled), so it reduces to the same manual-map path bars consume. +-} +discreteFillMap :: Chart -> [ColorSpec] -> [(Text, ColorSpec)] +discreteFillMap chart specs + | null specs = [] + | otherwise = zip cats (cycle specs) + where + cats = + List.nub $ + concat + [ fromMaybe [] (categoricalFillColumn (layerFrame l) (layerMapping l)) + | l <- chartLayers chart + ] + layerFrame l = fromMaybe (chartData chart) (layerData l) {- | Legend entries. A categorical-'aesColor' layer contributes one entry per category value (colours matching the points via 'layerColorMap'); 'GeomText' diff --git a/src/Granite/Scale.hs b/src/Granite/Scale.hs --- a/src/Granite/Scale.hs +++ b/src/Granite/Scale.hs @@ -46,6 +46,7 @@ SDiscrete -> trainLinear (defaultOpts BreaksNice) dataRange SColorContinuous _ -> trainLinear (defaultOpts BreaksNice) dataRange SColorDiscrete _ -> trainLinear (defaultOpts BreaksNice) dataRange + SColorManual _ -> trainLinear (defaultOpts BreaksNice) dataRange defaultOpts :: BreaksSpec -> ScaleOpts defaultOpts brk = diff --git a/src/Granite/Spec.hs b/src/Granite/Spec.hs --- a/src/Granite/Spec.hs +++ b/src/Granite/Spec.hs @@ -237,6 +237,11 @@ | SDiscrete | SColorContinuous [ColorSpec] | SColorDiscrete [ColorSpec] + | {- | Map specific category values to specific colours (e.g. + @[("NEW", Hex "#ce5050"), ("grown", Hex "#e0a030")]@); values + not listed fall back to the layer\/constant colour. + -} + SColorManual [(Text, ColorSpec)] deriving (Eq, Show, Read) data Scales = Scales diff --git a/test/FlameSpec.hs b/test/FlameSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlameSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +module FlameSpec (spec) where + +import Data.Text qualified as Text + +import Granite.Flame +import Test.Hspec + +-- A 3-level tree: a root with two children, one of which has a child. Mixes +-- increases (fnPos) and decreases (fnNeg) so both colours must appear. +sampleTree :: FlameNode +sampleTree = + FlameNode + { fnLabel = "root" + , fnPos = 9.0e6 + , fnNeg = 7.0e6 + , fnChildren = + [ FlameNode + { fnLabel = "Parse.parseModule" + , fnPos = 8.0e6 + , fnNeg = 2.0e6 + , fnChildren = + [ FlameNode "lexer" 1.0e6 3.0e6 [] + ] + } + , FlameNode "Typecheck.check" 1.0e6 5.0e6 [] + ] + } + +spec :: Spec +spec = describe "Granite.Flame.flameDiff" $ do + let svg = flameDiff sampleTree defFlameOpts + + it "emits a standalone document" $ do + svg `shouldSatisfy` Text.isInfixOf "" + + it "draws both red (increase) and blue (decrease) rects" $ do + svg `shouldSatisfy` Text.isInfixOf "#ce50" + svg `shouldSatisfy` Text.isInfixOf "#5064ce" + + it "carries a tooltip with the full label and pos/neg detail" $ do + svg `shouldSatisfy` Text.isInfixOf "" + svg `shouldSatisfy` Text.isInfixOf "Parse.parseModule" + svg `shouldSatisfy` Text.isInfixOf "MB" + + it "renders the title heading" $ do + flameDiff sampleTree defFlameOpts{foTitle = "My flame"} + `shouldSatisfy` Text.isInfixOf "My flame" diff --git a/test/GoldenSpec.hs b/test/GoldenSpec.hs --- a/test/GoldenSpec.hs +++ b/test/GoldenSpec.hs @@ -244,16 +244,39 @@ { chartSize = SizeChars 30 14 } --- Long category names under FacetWrap: rotation reserves no per-cell margin, so --- faceted panels must fall back to upright (never rotate/clip). Guards the --- facet branch of the x-label policy. +-- Long category names under FacetWrap (faceted by a separate column, so each +-- panel still shows all the long x categories): rotation reserves no per-cell +-- margin, so faceted panels fall back to upright and truncate each label to its +-- per-tick slot rather than rotate/clip. Guards the facet branch of the policy. facetedLongNames :: Chart facetedLongNames = - barLongNames - { chartFacet = FacetWrap (ColumnRef "fn") (Just 2) Nothing ScalesFixed - , chartTitle = Just "Faceted long names" - , chartSize = SizeChars 60 20 - } + let names = + [ "GHC.Core.Opt.Simplify.Iteration.Inline.Worker" + , "mkFastStringBytes" + , "GHC.Tc.Solver.Monad" + , "GHC.CmmToAsm.X86.Ppr" + ] + grp = ["before", "before", "after", "after"] + ys = [29.0, 18.5, 12.3, 9.1] :: [Double] + df = + fromColumns + [("fn", ColCat names), ("phase", ColCat grp), ("mb", ColNum ys)] + layer = + (defLayer GeomBar) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "fn") + , aesY = Just (ColumnRef "mb") + } + , layerStat = StatIdentity + } + in emptyChart + { chartData = df + , chartLayers = [layer] + , chartFacet = FacetWrap (ColumnRef "phase") (Just 2) Nothing ScalesFree + , chartTitle = Just "Faceted long names" + , chartSize = SizeChars 70 18 + } -- Histogram of 50 numeric values bucketed into 8 bins. Exercises -- StatBin + GeomHistogram. aesY points to the @count@ column that diff --git a/test/PipelineSpec.hs b/test/PipelineSpec.hs --- a/test/PipelineSpec.hs +++ b/test/PipelineSpec.hs @@ -2,6 +2,7 @@ module PipelineSpec (spec) where +import Data.List qualified as List import Data.Text qualified as Text import Granite.Color qualified as Col @@ -41,6 +42,57 @@ } } +-- A horizontal bar chart whose bars are categorically filled by "status". +statusBarChart :: Chart +statusBarChart = + emptyChart + { chartSize = SizeChars 40 20 + , chartCoord = CoordFlip + , chartData = + fromColumns + [ ("module", ColNum [0, 1, 2]) + , ("delta", ColNum [40, 20, 30]) + , ("status", ColCat ["NEW", "grown", "shrunk"]) + ] + , chartLayers = + [ (defLayer GeomCol) + { layerMapping = + emptyMapping + { aesX = Just (ColumnRef "module") + , aesY = Just (ColumnRef "delta") + , aesFill = Just (ColumnRef "status") + } + } + ] + } + +-- The distinct @fill="#…"@ values on @<rect>@ elements (data bars), ignoring +-- the white background rect. +distinctRectFills :: Text.Text -> [Text.Text] +distinctRectFills svg = + let rects = drop 1 (Text.splitOn "<rect" svg) + fillOf chunk = case Text.splitOn "fill=\"" chunk of + (_ : rest : _) -> Just (Text.takeWhile (/= '"') rest) + _ -> Nothing + fills = [f | Just f <- map fillOf rects, f /= "white"] + in dedup fills + where + dedup = foldr (\x acc -> if x `elem` acc then acc else x : acc) [] + +-- The distinct fills on the 12×12 legend swatch rects, so a test can assert the +-- legend swatches use the same colours as the bars. +legendSwatchFills :: Text.Text -> [Text.Text] +legendSwatchFills svg = + let rects = drop 1 (Text.splitOn "<rect" svg) + swatch chunk = Text.isInfixOf "width=\"12\"" chunk && Text.isInfixOf "height=\"12\"" chunk + fillOf chunk = case Text.splitOn "fill=\"" chunk of + (_ : rest : _) -> Just (Text.takeWhile (/= '"') rest) + _ -> Nothing + fills = [f | chunk <- rects, swatch chunk, Just f <- [fillOf chunk]] + in dedup fills + where + dedup = foldr (\x acc -> if x `elem` acc then acc else x : acc) [] + spec :: Spec spec = describe "Granite.Render.Pipeline" $ do describe "scatter Chart through the IR" $ do @@ -150,6 +202,53 @@ svg `shouldSatisfy` Text.isInfixOf ">a</text>" svg `shouldSatisfy` Text.isInfixOf ">c</text>" svg `shouldNotSatisfy` Text.isInfixOf "series 0" + + it "horizontal bars honour a categorical aesFill (distinct fills)" $ do + let svg = renderChartSvg statusBarChart{chartScales = defScales} + length (distinctRectFills svg) `shouldSatisfy` (>= 2) + + it "a manual fill scale maps status values to specific colours" $ do + let chart = + statusBarChart + { chartScales = + defScales + { scaleFill = + Just + ( SColorManual + [ ("NEW", Hex "#ce5050") + , ("grown", Hex "#e0a030") + , ("shrunk", Hex "#50a050") + ] + ) + } + } + svg = renderChartSvg chart + svg `shouldSatisfy` Text.isInfixOf "#ce5050" + svg `shouldSatisfy` Text.isInfixOf "#e0a030" + svg `shouldSatisfy` Text.isInfixOf "#50a050" + + it "the legend swatches use the same colours as the bars" $ do + let chart = + statusBarChart + { chartScales = + defScales + { scaleFill = + Just + ( SColorManual + [ ("NEW", Hex "#ce5050") + , ("grown", Hex "#e0a030") + , ("shrunk", Hex "#50a050") + ] + ) + } + } + svg = renderChartSvg chart + -- Bars and swatches draw from one map, so no palette colour leaks in: + -- the only rect fills are the three manual colours. + List.sort (distinctRectFills svg) + `shouldBe` ["#50a050", "#ce5050", "#e0a030"] + List.sort (legendSwatchFills svg) + `shouldBe` ["#50a050", "#ce5050", "#e0a030"] describe "Log-scale chart" $ do let logChart = diff --git a/test/golden/facet-long-names.svg b/test/golden/facet-long-names.svg --- a/test/golden/facet-long-names.svg +++ b/test/golden/facet-long-names.svg @@ -1,60 +1,27 @@ -<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 600 320" width="600" height="320" font-family="system-ui, -apple-system, sans-serif"> +<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 700 288" width="700" height="288" font-family="system-ui, -apple-system, sans-serif"> <rect width="100%" height="100%" fill="white"/> -<line x1="60" y1="106.07" x2="262.50" y2="106.07" stroke="#ecf0f1" stroke-width="1"/> -<line x1="60" y1="66" x2="60" y2="106.07" stroke="#ecf0f1" stroke-width="1"/> -<text x="81.90" y="121.07" text-anchor="middle" fill="#7f8c8d" font-size="11"><title>GHC.Core.Opt.Simplify.Iteration.Inline.WorkerGHC.Core.Opt.Simplify.Iterati… -0.0 -10.0 -20.0 -30.0 - -GHC.Core.Opt.Simplify.Iteration.Inline.WorkerGHC.Core.Opt.Simplify.Iterati… - - -mkFastStringBytes -0.0 -10.0 -20.0 -30.0 - -mkFastStringBytes - - -GHC.Tc.Solver.Monad -0.0 -10.0 -20.0 -30.0 - -GHC.Tc.Solver.Monad - - -GHC.CmmToAsm.X86.Ppr -0.0 -10.0 -20.0 -30.0 - -GHC.CmmToAsm.X86.Ppr - - -GHC.Stg.Unarise -0.0 -10.0 -20.0 -30.0 - -GHC.Stg.Unarise - - -GHC.HsToCore.Match.Constructor -0.0 -10.0 -20.0 -30.0 - -GHC.HsToCore.Match.Constructor -Faceted long names - -series 0 + + +GHC.Core.Opt.Simplify.Iteration.Inline.WorkerGHC.Core.Opt.Simpl… +mkFastStringBytes +0.0 +10.0 +20.0 +30.0 + + +before + + +GHC.Tc.Solver.Monad +GHC.CmmToAsm.X86.PprGHC.CmmToAsm.X86.P… +0.0 +5.0 +10.0 + + +after +Faceted long names + +series 0 diff --git a/test/golden/plotly-bar-grouped.svg b/test/golden/plotly-bar-grouped.svg --- a/test/golden/plotly-bar-grouped.svg +++ b/test/golden/plotly-bar-grouped.svg @@ -10,18 +10,22 @@ 10.0 20.0 - - + + - - + + - - + + - - + + Sales by quarter (grouped) -product +Product A + +Product B + +Product C diff --git a/test/golden/plotly-bar-grouped.txt b/test/golden/plotly-bar-grouped.txt --- a/test/golden/plotly-bar-grouped.txt +++ b/test/golden/plotly-bar-grouped.txt @@ -1,16 +1,16 @@ Sales by quarter (grouped)  │ ███ ██  -20.0 │ ███ ██product  - │ ███ ███  - │ ███ ███  - │ ███ ███ ██████  - │ ███ ███ █████ ██████  -10.0 │ ███ ██████ █████ ████████  - │ ██████ ██████ ████████ ████████  - │ ██████ █████████ ████████ ████████  - │ ████████ █████████ ████████ ████████  - │ ████████ █████████ ████████ ████████  - 0.0 │ ████████ █████████ ████████ ████████  +20.0 │ ███ ██Product A + │ ███ ███ ██Product B + │ ███ ███ ██Product C + │ ███ ███ ██████  + │ ███ ███ █████ ██████  +10.0 │ ███ ██████ █████ ████████  + │ ██████ ██████ ████████ ████████  + │ ██████ █████████ ████████ ████████  + │ ████████ █████████ ████████ ████████  + │ ████████ █████████ ████████ ████████  + 0.0 │ ████████ █████████ ████████ ████████  ┼───────────────────────────────────────────  0.0 1.0 2.0 3.0  diff --git a/test/golden/plotly-bar-stacked.svg b/test/golden/plotly-bar-stacked.svg --- a/test/golden/plotly-bar-stacked.svg +++ b/test/golden/plotly-bar-stacked.svg @@ -10,18 +10,22 @@ 20.0 40.0 - - + + - - + + - - + + - - + + Sales by quarter (stacked) -product +Product A + +Product B + +Product C diff --git a/test/golden/plotly-bar-stacked.txt b/test/golden/plotly-bar-stacked.txt --- a/test/golden/plotly-bar-stacked.txt +++ b/test/golden/plotly-bar-stacked.txt @@ -1,14 +1,14 @@ Sales by quarter (stacked)  - │ █████████ ██  - │ █████████ ██product  -40.0 │ █████████ █████████  - │ █████████ █████████  - │ █████████ █████████ █████████  - │ █████████ █████████ █████████ █████████  - │ █████████ █████████ █████████ █████████  -20.0 │ █████████ █████████ █████████ █████████  - │ █████████ █████████ █████████ █████████  + │ █████████ ██  + │ █████████ ██Product A +40.0 │ █████████ █████████ ██Product B + │ █████████ █████████ ██Product C + │ █████████ █████████ █████████  + │ █████████ █████████ █████████ █████████  + │ █████████ █████████ █████████ █████████  +20.0 │ █████████ █████████ █████████ █████████  + │ █████████ █████████ █████████ █████████  │ █████████ █████████ █████████ █████████  │ █████████ █████████ █████████ █████████  0.0 │ █████████ █████████ █████████ █████████