diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2026 Michael Chavinda + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/dataframe-viz.cabal b/dataframe-viz.cabal new file mode 100644 --- /dev/null +++ b/dataframe-viz.cabal @@ -0,0 +1,46 @@ +cabal-version: 2.4 +name: dataframe-viz +version: 1.0.0.0 + +synopsis: Visualisation/plotting helpers for the dataframe ecosystem. +description: + Display harness plus terminal and web plotters. Built on top of + @dataframe-core@ and @dataframe-operations@. + +bug-reports: https://github.com/mchav/dataframe/issues +license: MIT +license-file: LICENSE +author: Michael Chavinda +maintainer: mschavinda@gmail.com +copyright: (c) 2024-2025 Michael Chavinda +category: Data +tested-with: GHC ==9.4.8 || ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2 + +common warnings + ghc-options: + -Wincomplete-patterns + -Wincomplete-uni-patterns + -Wunused-imports + -Wunused-local-binds + +library + import: warnings + exposed-modules: + DataFrame.Display + DataFrame.Display.Terminal.Plot + DataFrame.Display.Web.Plot + other-modules: DataFrame.Display.Internal.Common + build-depends: base >= 4 && < 5, + bytestring >= 0.11 && < 0.13, + containers >= 0.6.7 && < 0.9, + dataframe-core ^>= 1.0, + dataframe-operations ^>= 1.0, + directory >= 1.3.0.0 && < 2, + granite ^>= 0.6, + process ^>= 1.6, + random >= 1 && < 2, + temporary >= 1.3 && < 2, + text >= 2.0 && < 3, + vector ^>= 0.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/DataFrame/Display.hs b/src/DataFrame/Display.hs new file mode 100644 --- /dev/null +++ b/src/DataFrame/Display.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use newtype instead of data" #-} +module DataFrame.Display where + +import qualified Data.Text.IO as T +import DataFrame.Display.Terminal.PrettyPrint (RenderFormat (..)) +import qualified DataFrame.Internal.DataFrame as D + +data DisplayOptions = DisplayOptions + { {-- | Controls truncation on all three axes (rows, columns, cell width). + -- + -- * 'Nothing' renders every row and column at full width. + -- * 'Just cfg' caps each axis whose limit in @cfg@ is positive. + --} + displayTruncate :: Maybe D.TruncateConfig + } + +{- | Defaults aimed at terminal use: 10 rows, plus the standard column and cell +caps from 'D.defaultTruncateConfig'. +-} +defaultDisplayOptions :: DisplayOptions +defaultDisplayOptions = + DisplayOptions + { displayTruncate = Just D.defaultTruncateConfig{D.maxRows = 10} + } + +-- | Render a 'DataFrame' to stdout according to 'DisplayOptions'. +display :: DisplayOptions -> D.DataFrame -> IO () +display opts = T.putStrLn . D.asTextWith Plain (displayTruncate opts) diff --git a/src/DataFrame/Display/Internal/Common.hs b/src/DataFrame/Display/Internal/Common.hs new file mode 100644 --- /dev/null +++ b/src/DataFrame/Display/Internal/Common.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{- | +Internal shared helpers used by both the terminal and web plot backends. +Not part of the public API. +-} +module DataFrame.Display.Internal.Common ( + -- * Aggregation + Agg (..), + aggLabel, + aggregateByGroup, + + -- * Column extraction + extractStringColumn, + extractNumericColumn, + + -- * Type guards + isNumericColumn, + isNumericColumnCheck, + + -- * Categorical helpers + getCategoricalCounts, + + -- * Top-N rollup + groupWithOther, + groupWithOtherForPie, +) where + +import qualified Data.Bifunctor +import qualified Data.List as L +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Type.Equality (TestEquality (testEquality), type (:~:) (Refl)) +import qualified Data.Vector as V +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Unboxed as VU +import Data.Word (Word8) +import GHC.Stack (HasCallStack) +import Type.Reflection (TypeRep, typeRep) + +import DataFrame.Internal.Column (Column (..), Columnable, isNumeric) +import DataFrame.Internal.DataFrame (DataFrame (..), getColumn) +import DataFrame.Internal.Types + +-- | Aggregation strategy for grouped/categorical plots. +data Agg + = -- | Count rows per group; ignores the value column. + Count + | -- | Sum of value column per group. + Sum + | -- | Arithmetic mean of value column per group. + Mean + | -- | Median of value column per group. + Median + | -- | Minimum of value column per group. + Min + | -- | Maximum of value column per group. + Max + deriving (Eq, Show) + +-- | Short label for an aggregation, used in auto-generated chart titles. +aggLabel :: Agg -> T.Text +aggLabel Count = "count" +aggLabel Sum = "sum" +aggLabel Mean = "mean" +aggLabel Median = "median" +aggLabel Min = "min" +aggLabel Max = "max" + +{- | Apply an aggregation across rows grouped by the given category column. + +For 'Count', the value column is ignored. For all other aggregations, the +value column is extracted as numeric and folded per group. Group order is +the order in which categories first appear. +-} +aggregateByGroup :: + (HasCallStack) => + Agg -> + -- | Grouping column (categorical). + T.Text -> + -- | Value column; required for everything except 'Count'. + Maybe T.Text -> + DataFrame -> + [(T.Text, Double)] +aggregateByGroup Count groupCol _ df = + let groups = extractStringColumn groupCol df + m = L.foldl' (\acc g -> M.insertWith (+) g 1 acc) M.empty groups + seen = L.nub groups + in [(g, M.findWithDefault 0 g m) | g <- seen] +aggregateByGroup agg groupCol mValueCol df = case mValueCol of + Nothing -> + error $ + "Aggregation " + ++ show agg + ++ " requires a value column; only Count works without one." + Just valueCol -> + let groups = extractStringColumn groupCol df + values = extractNumericColumn valueCol df + seen = L.nub groups + pairs = zip groups values + byGroup = + L.foldl' + (\acc (g, v) -> M.insertWith (flip (++)) g [v] acc) + M.empty + pairs + reduce = numericReducer agg + in [(g, reduce (M.findWithDefault [] g byGroup)) | g <- seen] + +{- | The numeric reducers, broken out so the overlapping-Count case in + 'aggregateByGroup' can be dispatched at the head pattern without + producing a redundant inner match. +-} +numericReducer :: Agg -> [Double] -> Double +numericReducer Sum = sum +numericReducer Mean = \vs -> if null vs then 0 else sum vs / fromIntegral (length vs) +numericReducer Median = medianD +numericReducer Min = minimum +numericReducer Max = maximum +numericReducer Count = fromIntegral . length + +medianD :: [Double] -> Double +medianD [] = 0 +medianD xs = + let sorted = L.sort xs + n = length sorted + mid = n `div` 2 + in if even n + then (sorted !! (mid - 1) + sorted !! mid) / 2 + else sorted !! mid + +isNumericColumn :: DataFrame -> T.Text -> Bool +isNumericColumn df colName = maybe False isNumeric (getColumn colName df) + +isNumericColumnCheck :: T.Text -> DataFrame -> Bool +isNumericColumnCheck colName df = isNumericColumn df colName + +extractStringColumn :: (HasCallStack) => T.Text -> DataFrame -> [T.Text] +extractStringColumn colName df = + case M.lookup colName (columnIndices df) of + Nothing -> error $ "Column " ++ T.unpack colName ++ " not found" + Just idx -> + let col = columns df V.! idx + in case col of + BoxedColumn _ (vec :: V.Vector a) -> + case testEquality (typeRep @a) (typeRep @T.Text) of + Just Refl -> V.toList vec + Nothing -> V.toList $ V.map (T.pack . show) vec + UnboxedColumn _ vec -> + V.toList $ VG.map (T.pack . show) (VG.convert vec) + +extractNumericColumn :: (HasCallStack) => T.Text -> DataFrame -> [Double] +extractNumericColumn colName df = + case M.lookup colName (columnIndices df) of + Nothing -> error $ "Column " ++ T.unpack colName ++ " not found" + Just idx -> + let col = columns df V.! idx + in case col of + BoxedColumn _ vec -> vectorToDoubles vec + UnboxedColumn _ vec -> unboxedVectorToDoubles vec + +vectorToDoubles :: forall a. (Columnable a, Show a) => V.Vector a -> [Double] +vectorToDoubles vec = + case testEquality (typeRep @a) (typeRep @Double) of + Just Refl -> V.toList vec + Nothing -> case sIntegral @a of + STrue -> V.toList $ V.map fromIntegral vec + SFalse -> case sFloating @a of + STrue -> V.toList $ V.map realToFrac vec + SFalse -> + error $ "Column is not numeric (type: " ++ show (typeRep @a) ++ ")" + +unboxedVectorToDoubles :: + forall a. (Columnable a, VU.Unbox a, Show a) => VU.Vector a -> [Double] +unboxedVectorToDoubles vec = + case testEquality (typeRep @a) (typeRep @Double) of + Just Refl -> VU.toList vec + Nothing -> case sIntegral @a of + STrue -> VU.toList $ VU.map fromIntegral vec + SFalse -> case sFloating @a of + STrue -> VU.toList $ VU.map realToFrac vec + SFalse -> + error $ "Column is not numeric (type: " ++ show (typeRep @a) ++ ")" + +getCategoricalCounts :: + (HasCallStack) => T.Text -> DataFrame -> Maybe [(T.Text, Double)] +getCategoricalCounts colName df = + case M.lookup colName (columnIndices df) of + Nothing -> error $ "Column " ++ T.unpack colName ++ " not found" + Just idx -> + let col = columns df V.! idx + in case col of + BoxedColumn _ (vec :: V.Vector a) -> + Just (countBoxed (typeRep @a) vec) + UnboxedColumn _ (vec :: VU.Vector a) -> + Just (countUnboxed (typeRep @a) vec) + where + countBoxed :: + forall a. (Show a) => TypeRep a -> V.Vector a -> [(T.Text, Double)] + countBoxed tr vec + | Just Refl <- testEquality tr (typeRep @T.Text) = toPairsText $ countValues vec + | Just Refl <- testEquality tr (typeRep @String) = toPairs $ countValues vec + | Just Refl <- testEquality tr (typeRep @Integer) = toPairs $ countValues vec + | Just Refl <- testEquality tr (typeRep @Int) = toPairs $ countValues vec + | Just Refl <- testEquality tr (typeRep @Double) = toPairs $ countValues vec + | Just Refl <- testEquality tr (typeRep @Float) = toPairs $ countValues vec + | Just Refl <- testEquality tr (typeRep @Bool) = toPairs $ countValues vec + | Just Refl <- testEquality tr (typeRep @Char) = toPairs $ countValues vec + | otherwise = countByShow $ V.toList vec + + countUnboxed :: + forall a. (Show a, VU.Unbox a) => TypeRep a -> VU.Vector a -> [(T.Text, Double)] + countUnboxed tr vec + | Just Refl <- testEquality tr (typeRep @Int) = toPairs $ countValuesUnboxed vec + | Just Refl <- testEquality tr (typeRep @Double) = + toPairs $ countValuesUnboxed vec + | Just Refl <- testEquality tr (typeRep @Float) = + toPairs $ countValuesUnboxed vec + | Just Refl <- testEquality tr (typeRep @Bool) = + toPairs $ countValuesUnboxed vec + | Just Refl <- testEquality tr (typeRep @Char) = + toPairs $ countValuesUnboxed vec + | Just Refl <- testEquality tr (typeRep @Word8) = + toPairs $ countValuesUnboxed vec + | otherwise = countByShow $ VU.toList vec + + toPairs :: (Show a) => [(a, Int)] -> [(T.Text, Double)] + toPairs = map (\(k, v) -> (T.pack (show k), fromIntegral v)) + + toPairsText :: [(T.Text, Int)] -> [(T.Text, Double)] + toPairsText = map (Data.Bifunctor.second fromIntegral) + + countValues :: (Ord a) => V.Vector a -> [(a, Int)] + countValues vec = M.toList $ V.foldr' (\x acc -> M.insertWith (+) x 1 acc) M.empty vec + + countValuesUnboxed :: (Ord a, VU.Unbox a) => VU.Vector a -> [(a, Int)] + countValuesUnboxed vec = M.toList $ VU.foldr' (\x acc -> M.insertWith (+) x 1 acc) M.empty vec + + countByShow :: (Show a) => [a] -> [(T.Text, Double)] + countByShow xs = + map (Data.Bifunctor.bimap T.pack fromIntegral) $ + M.toList $ + L.foldl' (\acc x -> M.insertWith (+) (show x) (1 :: Int) acc) M.empty xs + +{- | Keep the top-N entries by value; fold the rest into a single "Other" +bucket. Used to limit bar/pie counts to a readable number. +-} +groupWithOther :: Int -> [(T.Text, Double)] -> [(T.Text, Double)] +groupWithOther n items = + let sorted = L.sortOn (negate . snd) items + (topN, rest) = splitAt n sorted + otherSum = sum (map snd rest) + in if null rest || otherSum == 0 + then topN + else topN ++ [("Other (" <> T.pack (show (length rest)) <> " items)", otherSum)] + +-- | Like 'groupWithOther' but annotates the "Other" bucket with its share %. +groupWithOtherForPie :: Int -> [(T.Text, Double)] -> [(T.Text, Double)] +groupWithOtherForPie n items = + let total = sum (map snd items) + sorted = L.sortOn (negate . snd) items + (topN, rest) = splitAt n sorted + otherSum = sum (map snd rest) + otherPct = if total == 0 then 0 else round (100 * otherSum / total) :: Int + in if null rest || otherSum == 0 + then topN + else + topN + ++ [ + ( "Other (" + <> T.pack (show (length rest)) + <> " items, " + <> T.pack (show otherPct) + <> "%)" + , otherSum + ) + ] diff --git a/src/DataFrame/Display/Terminal/Plot.hs b/src/DataFrame/Display/Terminal/Plot.hs new file mode 100644 --- /dev/null +++ b/src/DataFrame/Display/Terminal/Plot.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +{- | +A plotly-express-style one-shot plotting API for terminal output. + +Each chart kind has a small record spec (with sensible defaults) and a +single render function. Customise plots by record-update on the spec: + +@ +bar ((mkBar "Sex") { y = Just "Survived" }) titanic +bar ((mkBar "ocean_proximity") + { y = Just "median_house_value", agg = Mean }) housing +@ +-} +module DataFrame.Display.Terminal.Plot ( + -- * Aggregation + Agg (..), + + -- * Bar charts + Bar (..), + mkBar, + bar, + + -- * Histograms + Histogram (..), + mkHistogram, + histogram, + + -- * Scatter plots + Scatter (..), + mkScatter, + scatter, + + -- * Line charts + Line (..), + mkLine, + line, + + -- * Pie charts + Pie (..), + mkPie, + pie, + + -- * Box plots + Box (..), + mkBox, + box, + + -- * Whole-frame plots + heatmap, + correlationMatrix, + + -- * Deprecated legacy entry points + + {- | + These shims delegate to the parametrized API. They are kept for + one release to ease migration; prefer the spec-based functions + above for new code. + -} + plotHistogram, + plotScatter, + plotBars, + plotLines, + plotPie, + plotBoxPlots, + plotStackedBars, + plotHeatmap, + extractNumericColumn, + extractStringColumn, +) where + +import Control.Monad (forM) +import qualified Data.List as L +import qualified Data.Text as T +import qualified Data.Text.IO as T +import GHC.Stack (HasCallStack) + +import DataFrame.Display.Internal.Common ( + Agg (..), + aggLabel, + aggregateByGroup, + extractNumericColumn, + extractStringColumn, + groupWithOther, + groupWithOtherForPie, + isNumericColumn, + ) +import DataFrame.Internal.DataFrame (DataFrame (..), columnNames) +import Granite (Plot, defPlot) +import qualified Granite + +-- --------------------------------------------------------------------------- +-- Bar +-- --------------------------------------------------------------------------- + +{- | Bar-chart specification. + +@x@ is required; everything else has a default. When @y@ is @Nothing@ the +chart counts rows per group; otherwise @y@ is aggregated using @agg@. +-} +data Bar = Bar + { x :: T.Text + -- ^ Grouping (categorical) column. + , y :: Maybe T.Text + -- ^ Value column; @Nothing@ counts rows. + , agg :: Agg + -- ^ Aggregation applied to @y@. Defaults to 'Sum'. + , topN :: Maybe Int + -- ^ Optional cap on the number of bars (rest folded into "Other"). + , title :: Maybe T.Text + -- ^ Chart title; auto-generated if @Nothing@. + , plot :: Plot + -- ^ Granite plot configuration (size, palette, ticks, etc.). + } + +-- | Smart constructor: spec with sensible defaults, given the @x@ column. +mkBar :: T.Text -> Bar +mkBar c = + Bar + { x = c + , y = Nothing + , agg = Sum + , topN = Nothing + , title = Nothing + , plot = defPlot + } + +-- | Render a 'Bar' spec to stdout. +bar :: (HasCallStack) => Bar -> DataFrame -> IO () +bar spec df = do + let effectiveAgg = case spec.y of + Nothing -> Count + Just _ -> spec.agg + rows = aggregateByGroup effectiveAgg spec.x spec.y df + rows' = maybe rows (`groupWithOther` rows) spec.topN + t = case spec.title of + Just s -> s + Nothing -> autoTitle effectiveAgg spec.y spec.x + cfg = spec.plot{Granite.plotTitle = t} + T.putStrLn $ Granite.bars rows' cfg + +-- --------------------------------------------------------------------------- +-- Histogram +-- --------------------------------------------------------------------------- + +-- | Histogram specification for a numeric column. +data Histogram = Histogram + { x :: T.Text + -- ^ Numeric column to bin. + , bins :: Int + -- ^ Number of bins (default 30). + , title :: Maybe T.Text + , plot :: Plot + } + +mkHistogram :: T.Text -> Histogram +mkHistogram c = + Histogram + { x = c + , bins = 30 + , title = Nothing + , plot = defPlot + } + +histogram :: (HasCallStack) => Histogram -> DataFrame -> IO () +histogram spec df = do + let values = extractNumericColumn spec.x df + (lo, hi) = if null values then (0, 1) else (minimum values, maximum values) + t = case spec.title of + Just s -> s + Nothing -> "histogram of " <> spec.x + cfg = spec.plot{Granite.plotTitle = t} + T.putStrLn $ Granite.histogram (Granite.bins spec.bins lo hi) values cfg + +-- --------------------------------------------------------------------------- +-- Scatter +-- --------------------------------------------------------------------------- + +-- | Scatter-plot specification. +data Scatter = Scatter + { x :: T.Text + , y :: T.Text + , color :: Maybe T.Text + -- ^ Optional grouping column; produces a separate series per value. + , title :: Maybe T.Text + , plot :: Plot + } + +mkScatter :: T.Text -> T.Text -> Scatter +mkScatter xc yc = + Scatter + { x = xc + , y = yc + , color = Nothing + , title = Nothing + , plot = defPlot + } + +scatter :: (HasCallStack) => Scatter -> DataFrame -> IO () +scatter spec df = do + let t = case spec.title of + Just s -> s + Nothing -> spec.x <> " vs " <> spec.y + cfg = spec.plot{Granite.plotTitle = t} + xVals = extractNumericColumn spec.x df + yVals = extractNumericColumn spec.y df + case spec.color of + Nothing -> + T.putStrLn $ Granite.scatter [(spec.x <> " vs " <> spec.y, zip xVals yVals)] cfg + Just grp -> do + let groupVals = extractStringColumn grp df + triples = zip3 groupVals xVals yVals + uniqGroups = L.nub groupVals + series = + [ (g, [(xv, yv) | (gv, xv, yv) <- triples, gv == g]) + | g <- uniqGroups + ] + T.putStrLn $ Granite.scatter series cfg + +-- --------------------------------------------------------------------------- +-- Line +-- --------------------------------------------------------------------------- + +-- | Line-chart specification: one x column, one or more y series. +data Line = Line + { x :: T.Text + , y :: [T.Text] + , title :: Maybe T.Text + , plot :: Plot + } + +mkLine :: T.Text -> [T.Text] -> Line +mkLine xc ys = + Line + { x = xc + , y = ys + , title = Nothing + , plot = defPlot + } + +line :: (HasCallStack) => Line -> DataFrame -> IO () +line spec df = do + let t = case spec.title of + Just s -> s + Nothing -> case spec.y of + [single] -> single <> " over " <> spec.x + _ -> T.intercalate ", " spec.y <> " over " <> spec.x + cfg = spec.plot{Granite.plotTitle = t} + xVals = extractNumericColumn spec.x df + seriesData <- forM spec.y $ \col -> do + let values = extractNumericColumn col df + return (col, zip xVals values) + T.putStrLn $ Granite.lineGraph seriesData cfg + +-- --------------------------------------------------------------------------- +-- Pie +-- --------------------------------------------------------------------------- + +-- | Pie-chart specification. +data Pie = Pie + { values :: T.Text + {- ^ Slice-defining column. For 'Count', categorical; for the + numeric aggs, the value column. + -} + , names :: Maybe T.Text + {- ^ Optional label column. If @Nothing@, slices are labelled by + the value column directly (for 'Count') or by row index. + -} + , agg :: Agg + , topN :: Maybe Int + , title :: Maybe T.Text + , plot :: Plot + } + +mkPie :: T.Text -> Pie +mkPie c = + Pie + { values = c + , names = Nothing + , agg = Count + , topN = Just 8 + , title = Nothing + , plot = defPlot + } + +pie :: (HasCallStack) => Pie -> DataFrame -> IO () +pie spec df = do + let vCol = spec.values + mNames = spec.names + a = spec.agg + t = case spec.title of + Just s -> s + Nothing -> case mNames of + Just n -> aggLabel a <> "(" <> vCol <> ") by " <> n + Nothing -> aggLabel a <> " of " <> vCol + cfg = spec.plot{Granite.plotTitle = t} + rows = case (a, mNames) of + (Count, Nothing) -> aggregateByGroup Count vCol Nothing df + (Count, Just n) -> aggregateByGroup Count n Nothing df + (_, Nothing) -> + let xs = extractNumericColumn vCol df + in zip [T.pack ("Item " ++ show i) | i <- [1 .. length xs :: Int]] xs + (_, Just n) -> aggregateByGroup a n (Just vCol) df + rows' = maybe rows (`groupWithOtherForPie` rows) spec.topN + T.putStrLn $ Granite.pie rows' cfg + +-- --------------------------------------------------------------------------- +-- Box +-- --------------------------------------------------------------------------- + +-- | Box-plot specification across one or more numeric columns. +data Box = Box + { y :: [T.Text] + , title :: Maybe T.Text + , plot :: Plot + } + +mkBox :: [T.Text] -> Box +mkBox ys = + Box + { y = ys + , title = Nothing + , plot = defPlot + } + +box :: (HasCallStack) => Box -> DataFrame -> IO () +box spec df = do + let t = case spec.title of + Just s -> s + Nothing -> "box plot of " <> T.intercalate ", " spec.y + cfg = spec.plot{Granite.plotTitle = t} + boxData <- forM spec.y $ \col -> return (col, extractNumericColumn col df) + T.putStrLn $ Granite.boxPlot boxData cfg + +-- --------------------------------------------------------------------------- +-- Whole-frame plots +-- --------------------------------------------------------------------------- + +{- | Heatmap of all numeric columns in the dataframe; each numeric column +becomes a column of the matrix. +-} +heatmap :: (HasCallStack) => DataFrame -> IO () +heatmap df = do + let numericCols = filter (isNumericColumn df) (columnNames df) + matrix = map (`extractNumericColumn` df) numericCols + T.putStrLn $ Granite.heatmap matrix defPlot + +-- | Pearson correlation heatmap across all numeric columns. +correlationMatrix :: (HasCallStack) => DataFrame -> IO () +correlationMatrix df = do + let numericCols = filter (isNumericColumn df) (columnNames df) + cols = map (`extractNumericColumn` df) numericCols + correlations = + [ [corr xs ys | ys <- cols] + | xs <- cols + ] + print (zip [(0 :: Int) ..] numericCols) + T.putStrLn $ + Granite.heatmap correlations (defPlot{Granite.plotTitle = "correlation matrix"}) + where + corr xs ys = + let n = fromIntegral $ length xs + meanX = sum xs / n + meanY = sum ys / n + covXY = sum [(a - meanX) * (b - meanY) | (a, b) <- zip xs ys] / n + stdX = sqrt $ sum [(a - meanX) ^ (2 :: Int) | a <- xs] / n + stdY = sqrt $ sum [(b - meanY) ^ (2 :: Int) | b <- ys] / n + in covXY / (stdX * stdY) + +-- --------------------------------------------------------------------------- +-- Title helper +-- --------------------------------------------------------------------------- + +autoTitle :: Agg -> Maybe T.Text -> T.Text -> T.Text +autoTitle Count _ groupCol = "count by " <> groupCol +autoTitle a (Just yCol) groupCol = aggLabel a <> "(" <> yCol <> ") by " <> groupCol +autoTitle a Nothing groupCol = aggLabel a <> " by " <> groupCol + +-- --------------------------------------------------------------------------- +-- Deprecated legacy entry points +-- --------------------------------------------------------------------------- + +-- | Use 'histogram' with 'mkHistogram' instead. +plotHistogram :: (HasCallStack) => T.Text -> DataFrame -> IO () +plotHistogram c = histogram (mkHistogram c) +{-# DEPRECATED plotHistogram "use 'histogram (mkHistogram col)' instead" #-} + +-- | Use 'scatter' with 'mkScatter' instead. +plotScatter :: (HasCallStack) => T.Text -> T.Text -> DataFrame -> IO () +plotScatter xc yc = scatter (mkScatter xc yc) +{-# DEPRECATED plotScatter "use 'scatter (mkScatter xCol yCol)' instead" #-} + +-- | Use 'bar' with 'mkBar' instead. +plotBars :: (HasCallStack) => T.Text -> DataFrame -> IO () +plotBars c = bar (mkBar c) +{-# DEPRECATED plotBars "use 'bar (mkBar col)' instead" #-} + +-- | Use 'line' with 'mkLine' instead. +plotLines :: (HasCallStack) => T.Text -> [T.Text] -> DataFrame -> IO () +plotLines xc ys = line (mkLine xc ys) +{-# DEPRECATED plotLines "use 'line (mkLine xCol yCols)' instead" #-} + +-- | Use 'pie' with 'mkPie' instead. +plotPie :: (HasCallStack) => T.Text -> Maybe T.Text -> DataFrame -> IO () +plotPie c mLabel = + let s = mkPie c + in pie s{names = mLabel} +{-# DEPRECATED plotPie "use 'pie (mkPie col)' instead" #-} + +-- | Use 'box' with 'mkBox' instead. +plotBoxPlots :: (HasCallStack) => [T.Text] -> DataFrame -> IO () +plotBoxPlots ys = box (mkBox ys) +{-# DEPRECATED plotBoxPlots "use 'box (mkBox cols)' instead" #-} + +{- | Stacked-bar plot: one bar per category, segments from the listed value +columns. Kept as a direct passthrough to granite — has no spec record +because no aggregation is involved (segments are summed per category). +-} +plotStackedBars :: (HasCallStack) => T.Text -> [T.Text] -> DataFrame -> IO () +plotStackedBars categoryCol valueColumns df = do + let categories = extractStringColumn categoryCol df + uniqueCategories = L.nub categories + stackData <- forM uniqueCategories $ \cat -> do + let indices = [i | (i, c) <- zip [0 ..] categories, c == cat] + seriesData <- forM valueColumns $ \col -> do + let allValues = extractNumericColumn col df + vs = [allValues !! i | i <- indices, i < length allValues] + return (col, sum vs) + return (cat, seriesData) + T.putStrLn $ Granite.stackedBars stackData defPlot + +-- | Use 'heatmap' instead. +plotHeatmap :: (HasCallStack) => DataFrame -> IO () +plotHeatmap = heatmap +{-# DEPRECATED plotHeatmap "use 'heatmap' instead" #-} diff --git a/src/DataFrame/Display/Web/Plot.hs b/src/DataFrame/Display/Web/Plot.hs new file mode 100644 --- /dev/null +++ b/src/DataFrame/Display/Web/Plot.hs @@ -0,0 +1,558 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoFieldSelectors #-} + +{- | +A plotly-express-style one-shot plotting API for HTML output. Mirrors +'DataFrame.Display.Terminal.Plot' but emits embeddable Chart.js HTML. +-} +module DataFrame.Display.Web.Plot ( + -- * Aggregation + Agg (..), + + -- * Output + HtmlPlot (..), + showInDefaultBrowser, + + -- * Layout + Size (..), + defaultSize, + + -- * Bar charts + Bar (..), + mkBar, + bar, + + -- * Histograms + Histogram (..), + mkHistogram, + histogram, + + -- * Scatter plots + Scatter (..), + mkScatter, + scatter, + + -- * Line charts + Line (..), + mkLine, + line, + + -- * Pie charts + Pie (..), + mkPie, + pie, + + -- * Box plots + Box (..), + mkBox, + box, + + -- * Whole-frame plots + allHistograms, + + -- * Deprecated legacy entry points + plotHistogram, + plotScatter, + plotBars, + plotLines, + plotPie, + plotBoxPlots, +) where + +import Control.Monad (forM, void) +import Data.Char (chr) +import qualified Data.List as L +import qualified Data.Text as T +import qualified Data.Text.IO as T +import GHC.Stack (HasCallStack) +import Numeric (showFFloat) +import System.Directory (getHomeDirectory) +import System.Info (os) +import System.Process ( + StdStream (NoStream), + createProcess, + proc, + std_err, + std_in, + std_out, + waitForProcess, + ) +import System.Random (newStdGen, randomRs) + +import DataFrame.Display.Internal.Common ( + Agg (..), + aggLabel, + aggregateByGroup, + extractNumericColumn, + extractStringColumn, + groupWithOther, + groupWithOtherForPie, + isNumericColumn, + ) +import DataFrame.Internal.DataFrame (DataFrame, columnNames) + +-- --------------------------------------------------------------------------- +-- Output container + layout +-- --------------------------------------------------------------------------- + +-- | A snippet of HTML containing a Chart.js plot. +newtype HtmlPlot = HtmlPlot T.Text deriving (Show) + +-- | Display dimensions for the HTML canvas, in pixels. +data Size = Size {width :: Int, height :: Int} + +defaultSize :: Size +defaultSize = Size 600 400 + +generateChartId :: IO T.Text +generateChartId = do + gen <- newStdGen + let randomWords = + filter + (\c -> c `elem` ([49 .. 57] ++ [65 .. 90] ++ [97 .. 122])) + (take 64 (randomRs (49, 126) gen :: [Int])) + return $ "chart_" <> T.pack (map chr randomWords) + +wrapInHTML :: T.Text -> T.Text -> Size -> T.Text +wrapInHTML chartId content sz = + T.concat + [ "\n" + , "\n" + , "\n" + ] + +palette :: [T.Text] +palette = + [ "rgb(255, 99, 132)" + , "rgb(54, 162, 235)" + , "rgb(255, 206, 86)" + , "rgb(75, 192, 192)" + , "rgb(153, 102, 255)" + , "rgb(255, 159, 64)" + , "rgb(201, 203, 207)" + , "rgb(255, 99, 71)" + , "rgb(60, 179, 113)" + , "rgb(238, 130, 238)" + ] + +-- --------------------------------------------------------------------------- +-- Bar +-- --------------------------------------------------------------------------- + +data Bar = Bar + { x :: T.Text + , y :: Maybe T.Text + , agg :: Agg + , topN :: Maybe Int + , title :: Maybe T.Text + , size :: Size + } + +mkBar :: T.Text -> Bar +mkBar c = Bar c Nothing Sum Nothing Nothing defaultSize + +bar :: (HasCallStack) => Bar -> DataFrame -> IO HtmlPlot +bar spec df = do + chartId <- generateChartId + let effectiveAgg = case spec.y of + Nothing -> Count + Just _ -> spec.agg + rows = aggregateByGroup effectiveAgg spec.x spec.y df + rows' = maybe rows (`groupWithOther` rows) spec.topN + chartTitle = case spec.title of + Just s -> s + Nothing -> autoTitle effectiveAgg spec.y spec.x + labels = T.intercalate "," ["\"" <> label <> "\"" | (label, _) <- rows'] + dataPoints = T.intercalate "," [T.pack (show v) | (_, v) <- rows'] + legendLabel = case spec.y of + Nothing -> "count" + Just yCol -> aggLabel effectiveAgg <> "(" <> yCol <> ")" + jsCode = + T.concat + [ "setTimeout(function() { new Chart(\"" + , chartId + , "\", {\n type: \"bar\",\n data: {\n labels: [" + , labels + , "],\n datasets: [{\n label: \"" + , legendLabel + , "\",\n data: [" + , dataPoints + , "],\n backgroundColor: \"rgba(54, 162, 235, 0.6)\",\n borderColor: \"rgba(54, 162, 235, 1)\",\n borderWidth: 1\n }]\n },\n" + , " options: {\n title: { display: true, text: \"" + , chartTitle + , "\" },\n scales: { yAxes: [{ ticks: { beginAtZero: true } }] }\n }\n})}, 100);" + ] + return $ HtmlPlot $ wrapInHTML chartId jsCode spec.size + +-- --------------------------------------------------------------------------- +-- Histogram +-- --------------------------------------------------------------------------- + +data Histogram = Histogram + { x :: T.Text + , bins :: Int + , title :: Maybe T.Text + , size :: Size + } + +mkHistogram :: T.Text -> Histogram +mkHistogram c = Histogram c 30 Nothing defaultSize + +histogram :: (HasCallStack) => Histogram -> DataFrame -> IO HtmlPlot +histogram spec df = do + chartId <- generateChartId + let values = extractNumericColumn spec.x df + (lo, hi) = if null values then (0, 1) else (minimum values, maximum values) + binWidth = (hi - lo) / fromIntegral spec.bins + binStarts = [lo + fromIntegral i * binWidth | i <- [0 .. spec.bins - 1]] + countBin b = length [v | v <- values, v >= b && v < b + binWidth] + counts = map countBin binStarts + precision = max 0 $ ceiling (negate $ logBase 10 (max 1e-12 binWidth)) + labels = + T.intercalate + "," + [ "\"" <> T.pack (showFFloat (Just precision) b "") <> "\"" + | b <- binStarts + ] + dataPoints = T.intercalate "," [T.pack (show c) | c <- counts] + chartTitle = case spec.title of + Just s -> s + Nothing -> "histogram of " <> spec.x + jsCode = + T.concat + [ "setTimeout(function() { new Chart(\"" + , chartId + , "\", {\n type: \"bar\",\n data: {\n labels: [" + , labels + , "],\n datasets: [{\n label: \"" + , spec.x + , "\",\n data: [" + , dataPoints + , "],\n backgroundColor: \"rgba(75, 192, 192, 0.6)\",\n borderColor: \"rgba(75, 192, 192, 1)\",\n borderWidth: 1\n }]\n },\n" + , " options: {\n title: { display: true, text: \"" + , chartTitle + , "\" },\n scales: { yAxes: [{ ticks: { beginAtZero: true } }] }\n }\n})}, 100);" + ] + return $ HtmlPlot $ wrapInHTML chartId jsCode spec.size + +-- --------------------------------------------------------------------------- +-- Scatter +-- --------------------------------------------------------------------------- + +data Scatter = Scatter + { x :: T.Text + , y :: T.Text + , color :: Maybe T.Text + , title :: Maybe T.Text + , size :: Size + } + +mkScatter :: T.Text -> T.Text -> Scatter +mkScatter xc yc = Scatter xc yc Nothing Nothing defaultSize + +scatter :: (HasCallStack) => Scatter -> DataFrame -> IO HtmlPlot +scatter spec df = do + chartId <- generateChartId + let chartTitle = case spec.title of + Just s -> s + Nothing -> spec.x <> " vs " <> spec.y + xVals = extractNumericColumn spec.x df + yVals = extractNumericColumn spec.y df + datasets <- case spec.color of + Nothing -> + return $ + T.singleton '\n' + <> renderSeries chartTitle (head palette) (zip xVals yVals) + Just grp -> do + let groupVals = extractStringColumn grp df + triples = zip3 groupVals xVals yVals + uniq = L.nub groupVals + ds = + [ renderSeries g col [(xv, yv) | (gv, xv, yv) <- triples, gv == g] + | (g, col) <- zip uniq (cycle palette) + ] + return $ T.intercalate ",\n" ds + let jsCode = + T.concat + [ "setTimeout(function() { new Chart(\"" + , chartId + , "\", {\n type: \"scatter\",\n data: {\n datasets: [" + , datasets + , "\n ]\n },\n options: {\n" + , " title: { display: true, text: \"" + , chartTitle + , "\" },\n" + , " scales: {\n" + , " xAxes: [{ scaleLabel: { display: true, labelString: \"" + , spec.x + , "\" } }],\n yAxes: [{ scaleLabel: { display: true, labelString: \"" + , spec.y + , "\" } }]\n }\n }\n})}, 100);" + ] + return $ HtmlPlot $ wrapInHTML chartId jsCode spec.size + where + renderSeries label col pts = + let body = + T.intercalate + "," + [ "{x:" <> T.pack (show xv) <> ", y:" <> T.pack (show yv) <> "}" | (xv, yv) <- pts + ] + in T.concat + [ " {\n label: \"" + , label + , "\",\n data: [" + , body + , "],\n pointRadius: 4,\n pointBackgroundColor: \"" + , col + , "\"\n }" + ] + +-- --------------------------------------------------------------------------- +-- Line +-- --------------------------------------------------------------------------- + +data Line = Line + { x :: T.Text + , y :: [T.Text] + , title :: Maybe T.Text + , size :: Size + } + +mkLine :: T.Text -> [T.Text] -> Line +mkLine xc ys = Line xc ys Nothing defaultSize + +line :: (HasCallStack) => Line -> DataFrame -> IO HtmlPlot +line spec df = do + chartId <- generateChartId + let chartTitle = case spec.title of + Just s -> s + Nothing -> case spec.y of + [single] -> single <> " over " <> spec.x + _ -> T.intercalate ", " spec.y <> " over " <> spec.x + xValues = extractNumericColumn spec.x df + xLabels = T.intercalate "," [T.pack (show v) | v <- xValues] + datasets <- forM (zip spec.y (cycle palette)) $ \(col, c) -> do + let values = extractNumericColumn col df + body = T.intercalate "," [T.pack (show v) | v <- values] + return $ + T.concat + [ " {\n label: \"" + , col + , "\",\n data: [" + , body + , "],\n fill: false,\n borderColor: \"" + , c + , "\",\n tension: 0.1\n }" + ] + let datasetsStr = T.intercalate ",\n" datasets + jsCode = + T.concat + [ "setTimeout(function() { new Chart(\"" + , chartId + , "\", {\n type: \"line\",\n data: {\n labels: [" + , xLabels + , "],\n datasets: [\n" + , datasetsStr + , "\n ]\n },\n options: {\n" + , " title: { display: true, text: \"" + , chartTitle + , "\" },\n" + , " scales: { xAxes: [{ scaleLabel: { display: true, labelString: \"" + , spec.x + , "\" } }] }\n }\n})}, 100);" + ] + return $ HtmlPlot $ wrapInHTML chartId jsCode spec.size + +-- --------------------------------------------------------------------------- +-- Pie +-- --------------------------------------------------------------------------- + +data Pie = Pie + { values :: T.Text + , names :: Maybe T.Text + , agg :: Agg + , topN :: Maybe Int + , title :: Maybe T.Text + , size :: Size + } + +mkPie :: T.Text -> Pie +mkPie c = Pie c Nothing Count (Just 8) Nothing defaultSize + +pie :: (HasCallStack) => Pie -> DataFrame -> IO HtmlPlot +pie spec df = do + chartId <- generateChartId + let vCol = spec.values + mNames = spec.names + a = spec.agg + chartTitle = case spec.title of + Just s -> s + Nothing -> case mNames of + Just n -> aggLabel a <> "(" <> vCol <> ") by " <> n + Nothing -> aggLabel a <> " of " <> vCol + rows = case (a, mNames) of + (Count, Nothing) -> aggregateByGroup Count vCol Nothing df + (Count, Just n) -> aggregateByGroup Count n Nothing df + (_, Nothing) -> + let xs = extractNumericColumn vCol df + in zip [T.pack ("Item " ++ show i) | i <- [1 .. length xs :: Int]] xs + (_, Just n) -> aggregateByGroup a n (Just vCol) df + rows' = maybe rows (`groupWithOtherForPie` rows) spec.topN + labels = T.intercalate "," ["\"" <> label <> "\"" | (label, _) <- rows'] + dataPoints = T.intercalate "," [T.pack (show v) | (_, v) <- rows'] + colors = + T.intercalate + "," + ["\"" <> c <> "\"" | c <- take (length rows') palette] + jsCode = + T.concat + [ "setTimeout(function() { new Chart(\"" + , chartId + , "\", {\n type: \"pie\",\n data: {\n labels: [" + , labels + , "],\n datasets: [{\n data: [" + , dataPoints + , "],\n backgroundColor: [" + , colors + , "]\n }]\n },\n options: { title: { display: true, text: \"" + , chartTitle + , "\" } }\n})}, 100);" + ] + return $ HtmlPlot $ wrapInHTML chartId jsCode spec.size + +-- --------------------------------------------------------------------------- +-- Box +-- --------------------------------------------------------------------------- + +data Box = Box + { y :: [T.Text] + , title :: Maybe T.Text + , size :: Size + } + +mkBox :: [T.Text] -> Box +mkBox ys = Box ys Nothing defaultSize + +box :: (HasCallStack) => Box -> DataFrame -> IO HtmlPlot +box spec df = do + chartId <- generateChartId + boxData <- forM spec.y $ \col -> do + let vs = extractNumericColumn col df + sorted = L.sort vs + n = max 1 (length vs) + median = sorted !! (n `div` 2) + return (col, median) + let labels = T.intercalate "," ["\"" <> col <> "\"" | (col, _) <- boxData] + medians = T.intercalate "," [T.pack (show med) | (_, med) <- boxData] + chartTitle = case spec.title of + Just s -> s + Nothing -> "box plot of " <> T.intercalate ", " spec.y + jsCode = + T.concat + [ "setTimeout(function() { new Chart(\"" + , chartId + , "\", {\n type: \"bar\",\n data: {\n labels: [" + , labels + , "],\n datasets: [{\n label: \"Median\",\n data: [" + , medians + , "],\n backgroundColor: \"rgba(75, 192, 192, 0.6)\",\n borderColor: \"rgba(75, 192, 192, 1)\",\n borderWidth: 1\n }]\n },\n" + , " options: { title: { display: true, text: \"" + , chartTitle + , " (showing medians)\" }, scales: { yAxes: [{ ticks: { beginAtZero: true } }] } }\n})}, 100);" + ] + return $ HtmlPlot $ wrapInHTML chartId jsCode spec.size + +-- --------------------------------------------------------------------------- +-- Whole-frame helpers +-- --------------------------------------------------------------------------- + +{- | Concatenate a histogram for every numeric column in the frame. Useful +as a one-shot exploratory summary. +-} +allHistograms :: (HasCallStack) => DataFrame -> IO HtmlPlot +allHistograms df = do + let cols = filter (isNumericColumn df) (columnNames df) + xs <- forM cols $ \c -> histogram (mkHistogram c) df + let allPlots = L.foldl' (\acc (HtmlPlot contents) -> acc <> "\n" <> contents) "" xs + return (HtmlPlot allPlots) + +-- --------------------------------------------------------------------------- +-- Title helper +-- --------------------------------------------------------------------------- + +autoTitle :: Agg -> Maybe T.Text -> T.Text -> T.Text +autoTitle Count _ groupCol = "count by " <> groupCol +autoTitle a (Just yCol) groupCol = aggLabel a <> "(" <> yCol <> ") by " <> groupCol +autoTitle a Nothing groupCol = aggLabel a <> " by " <> groupCol + +-- --------------------------------------------------------------------------- +-- Deprecated legacy entry points +-- --------------------------------------------------------------------------- + +plotHistogram :: (HasCallStack) => T.Text -> DataFrame -> IO HtmlPlot +plotHistogram c = histogram (mkHistogram c) +{-# DEPRECATED plotHistogram "use 'histogram (mkHistogram col)' instead" #-} + +plotScatter :: (HasCallStack) => T.Text -> T.Text -> DataFrame -> IO HtmlPlot +plotScatter xc yc = scatter (mkScatter xc yc) +{-# DEPRECATED plotScatter "use 'scatter (mkScatter xCol yCol)' instead" #-} + +plotBars :: (HasCallStack) => T.Text -> DataFrame -> IO HtmlPlot +plotBars c = bar (mkBar c) +{-# DEPRECATED plotBars "use 'bar (mkBar col)' instead" #-} + +plotLines :: (HasCallStack) => T.Text -> [T.Text] -> DataFrame -> IO HtmlPlot +plotLines xc ys = line (mkLine xc ys) +{-# DEPRECATED plotLines "use 'line (mkLine xCol yCols)' instead" #-} + +plotPie :: (HasCallStack) => T.Text -> Maybe T.Text -> DataFrame -> IO HtmlPlot +plotPie c mLabel = + let s = mkPie c + in pie s{names = mLabel} +{-# DEPRECATED plotPie "use 'pie (mkPie col)' instead" #-} + +plotBoxPlots :: (HasCallStack) => [T.Text] -> DataFrame -> IO HtmlPlot +plotBoxPlots ys = box (mkBox ys) +{-# DEPRECATED plotBoxPlots "use 'box (mkBox cols)' instead" #-} + +-- --------------------------------------------------------------------------- +-- Browser launcher +-- --------------------------------------------------------------------------- + +showInDefaultBrowser :: HtmlPlot -> IO () +showInDefaultBrowser (HtmlPlot p) = do + plotId <- generateChartId + home <- getHomeDirectory + let path = "plot-" <> T.unpack plotId <> ".html" + fullPath = + if os == "mingw32" + then home <> "\\" <> path + else home <> "/" <> path + putStr "Saving plot to: " + putStrLn fullPath + T.writeFile fullPath p + case os of + "mingw32" -> openFileSilently "start" fullPath + "darwin" -> openFileSilently "open" fullPath + _ -> openFileSilently "xdg-open" fullPath + +openFileSilently :: FilePath -> FilePath -> IO () +openFileSilently program path = do + (_, _, _, ph) <- + createProcess + (proc program [path]) + { std_in = NoStream + , std_out = NoStream + , std_err = NoStream + } + void (waitForProcess ph)