diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,18 @@ # Revision history for dataframe +## 3.0.0.0 + +A breaking release that removes internal functions from the public API. + +### Highlights +* Internalish modules now have public APIs/contracts. `DataFrame.Core`, `DataFrame.Schema`, and `DataFrame.Learn`. +* `import DataFrame` now surfaces `Columnable`, `Columnable'`, `eSize`, `NamedExpr`, + `SchemaType(..)`, and the `Semigroup`/`Monoid DataFrame` instances directly. + +### Breaking changes +* Internal modules are no longer on the public surface. +* Subpackage major bumps. + ## 2.3.0.0 ### Breaking changes diff --git a/app/LazyBenchmark.hs b/app/LazyBenchmark.hs --- a/app/LazyBenchmark.hs +++ b/app/LazyBenchmark.hs @@ -2,21 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -{- | End-to-end smoke test and benchmark for the Lazy streaming API. +{- | End-to-end smoke test and benchmark for the Lazy streaming API: + generate a CSV then run five Lazy queries over it. Usage: - cabal run lazy-bench [-- [OPTIONS]] - - Options: - --rows N Number of rows to generate (default: 1_000_000_000) - --file PATH Output CSV path (default: /tmp/lazy_1b.csv) - --skip-gen Skip generation if the file already exists - - The executable generates a CSV file (streaming, constant memory) then - runs five Lazy queries over it, printing timing and result summaries. - - For heap/GC stats run with: - cabal run lazy-bench -- +RTS -s -RTS + cabal run lazy-bench [-- [OPTIONS]] (+RTS -s -RTS for heap stats) + --rows N rows to generate (default 1_000_000_000) + --file PATH output CSV path (default /tmp/lazy_1b.csv) + --skip-gen reuse the file if it already exists -} module Main where @@ -26,9 +19,9 @@ import qualified Data.Text as T import Data.Time (UTCTime, diffUTCTime, getCurrentTime) import qualified DataFrame as D -import DataFrame.Internal.Schema (Schema (..), schemaType) import qualified DataFrame.Lazy as L import DataFrame.Operators +import DataFrame.Schema (Schema (..), schemaType) import System.Directory (doesFileExist, getFileSize) import System.Environment (getArgs) import System.Exit (exitFailure) @@ -185,9 +178,6 @@ n = optRows opts pathT = T.pack path - -- ----------------------------------------------------------------------- - -- Phase 1: Generate - -- ----------------------------------------------------------------------- putStrLn "=== Lazy API 1B-row benchmark ===" putStrLn $ " rows : " ++ commas n putStrLn $ " file : " ++ path @@ -205,12 +195,8 @@ sz <- getFileSize path putStrLn $ " file size: " ++ showBytes sz - -- ----------------------------------------------------------------------- - -- Phase 2: Lazy queries - -- ----------------------------------------------------------------------- putStrLn "\nPhase 2: Lazy queries" - -- Schema for the generated CSV: id (Int), x (Double), y (Double), category (Text) let schema = Schema $ M.fromList @@ -220,25 +206,17 @@ , ("category", schemaType @T.Text) ] - -- Q1: Preview — limit 20, no filter. - -- Demonstrates that the executor reads only the first batch. runQuery "Q1 — preview first 20 rows (no filter)" $ L.runDataFrame $ L.take 20 $ L.scanCsv schema pathT - -- Q2: Filter + limit. - -- x > 0.999 ≈ 0.1% of rows. With a 512K-row batch the executor finds - -- ~512 matches in the first batch and stops — reads only one batch. runQuery "Q2 — filter (x > 0.999), limit 20" $ L.runDataFrame $ L.take 20 $ L.filter (col @Double "x" .> lit (0.999 :: Double)) $ L.scanCsv schema pathT - -- Q3: Filter + derive + select + limit. - -- Shows projection pushdown: only id/x/y/category are read, z is derived. - -- Predicate pushdown moves the filter into the scan batch loop. runQuery "Q3 — filter (x > 0.999), derive z = x*y, select [id,z], limit 20" $ L.runDataFrame $ L.take 20 $ @@ -247,10 +225,6 @@ L.filter (col @Double "x" .> lit (0.999 :: Double)) $ L.scanCsv schema pathT - -- Q4: Filter fusion demo. - -- Two consecutive filters are fused into one AND predicate by the optimizer. - -- Result: rows where x > 0.5 AND y > 0.5 (≈ 25% of total). - -- We limit to keep result size manageable. runQuery "Q4 — filter fusion: (x > 0.5) . (y > 0.5), limit 20" $ L.runDataFrame $ L.take 20 $ @@ -258,10 +232,6 @@ L.filter (col @Double "x" .> lit (0.5 :: Double)) $ L.scanCsv schema pathT - -- Q5: Full scan, heavy filter, count results. - -- x > 0.999 across the whole file ≈ 0.1% × N rows. - -- For 1B rows that is ~1M results — materialised into one DataFrame. - -- This query exercises streaming across all batches. runQuery ( "Q5 — full scan, filter (x > 0.999), count (~" ++ approx (n `div` 1000) diff --git a/app/Synthesis.hs b/app/Synthesis.hs --- a/app/Synthesis.hs +++ b/app/Synthesis.hs @@ -47,8 +47,8 @@ D.randomSplit (mkStdGen 4232) 0.7 (DT.thaw (clean train)) testDf = DT.thaw (clean test) - model = - fitDecisionTree + fitted = + fit ( defaultTreeConfig { maxTreeDepth = 5 , minSamplesSplit = 5 @@ -68,8 +68,9 @@ ) (F.fromMaybe 0 (F.col @(Maybe Int) "Survived")) (trainDf |> D.exclude ["PassengerId"]) + model = predict fitted - print model + print fitted putStrLn "Training accuracy: " print $ computeAccuracy (trainDf |> D.derive (F.name prediction) model) diff --git a/dataframe.cabal b/dataframe.cabal --- a/dataframe.cabal +++ b/dataframe.cabal @@ -1,6 +1,6 @@ -cabal-version: 3.0 +cabal-version: 3.4 name: dataframe -version: 2.3.0.0 +version: 3.0.0.0 synopsis: A fast, safe, and intuitive DataFrame library. description: A fast, safe, and intuitive DataFrame library for exploratory data analysis. @@ -54,7 +54,7 @@ default: False manual: True description: Exclude the Parquet reader/writer (@dataframe-parquet@ - plus pinch, zstd, snappy, streamly). Enable with + plus pinch, zstd, snappy). Enable with @-f +no-parquet@. (Reading Parquet from HuggingFace lives in the separate @dataframe-huggingface@ package, which is not a dependency of this meta-package.) @@ -82,20 +82,8 @@ DataFrame.Display.Web.Plot, DataFrame.Display.Web.Chart, DataFrame.Display.Web.Chart.Typed, - DataFrame.Internal.Types, - DataFrame.Internal.Expression, - DataFrame.Internal.Grouping, - DataFrame.Internal.Interpreter, - DataFrame.Internal.Nullable, - DataFrame.Internal.Parsing, - DataFrame.Internal.Column, - DataFrame.Internal.Binary, - DataFrame.Internal.Statistics, - DataFrame.Display.Terminal.PrettyPrint, - DataFrame.Display.Terminal.Colours, - DataFrame.Internal.DataFrame, - DataFrame.Internal.Row, - DataFrame.Internal.Schema, + DataFrame.Core, + DataFrame.Schema, DataFrame.Errors, DataFrame.Operations.Core, DataFrame.Operations.Join, @@ -111,7 +99,24 @@ DataFrame.Display.Terminal.Plot, DataFrame.Monad, DataFrame.DecisionTree, + DataFrame.Model, + DataFrame.ModelSelection, + DataFrame.LinearModel, + DataFrame.LinearModel.Regression, + DataFrame.LinearModel.Logistic, + DataFrame.Segmented, + DataFrame.SVM, + DataFrame.KMeans, + DataFrame.PCA, + DataFrame.DBSCAN, + DataFrame.GMM, + DataFrame.Boosting, + DataFrame.Boosting.GBM, + DataFrame.Boosting.AdaBoost, + DataFrame.Metrics, DataFrame.IO.JSON, + DataFrame.Expr.Serialize, + DataFrame.IR.ExprJson, DataFrame.Typed.Types, DataFrame.Typed.Schema, DataFrame.Typed.Freeze, @@ -123,16 +128,18 @@ DataFrame.Typed.Record, DataFrame.Typed.Generic build-depends: base >= 4 && <5, - dataframe-core ^>= 1.1, - dataframe-json ^>= 1.0, - dataframe-operations >= 1.1.1 && < 1.2, - dataframe-parsing ^>= 1.0.2, - dataframe-viz ^>= 1.0.3, - dataframe-learn ^>= 1.1 + dataframe-core >= 2.0 && < 2.1, + dataframe-json >= 1.1 && < 1.2, + dataframe-expr-serializer >= 1.1 && < 1.2, + dataframe-operations >= 2.0 && < 2.1, + dataframe-parsing >= 2.0 && < 2.1, + dataframe-viz >= 1.1 && < 1.2, + dataframe-learn >= 2.0 && < 2.1 if !flag(no-csv) - reexported-modules: DataFrame.IO.CSV - build-depends: dataframe-csv ^>= 1.0.2 + reexported-modules: DataFrame.IO.CSV, + DataFrame.Typed.IO.CSV + build-depends: dataframe-csv >= 2.0 && < 2.1 cpp-options: -DWITH_CSV if !flag(no-parquet) @@ -148,8 +155,9 @@ DataFrame.IO.Parquet.Utils, DataFrame.IO.Parquet.Seeking, DataFrame.IO.Parquet.Time, - DataFrame.IO.Utils.RandomAccess - build-depends: dataframe-parquet ^>= 1.1 + DataFrame.IO.Utils.RandomAccess, + DataFrame.Typed.IO.Parquet + build-depends: dataframe-parquet >= 1.2 && < 1.3 cpp-options: -DWITH_PARQUET -- The lazy executor calls both CSV and Parquet readers directly, so @@ -158,27 +166,22 @@ reexported-modules: DataFrame.Lazy, DataFrame.Lazy.IO.Binary, DataFrame.Lazy.IO.CSV, - DataFrame.Lazy.Internal.DataFrame, - DataFrame.Lazy.Internal.LogicalPlan, - DataFrame.Lazy.Internal.PhysicalPlan, - DataFrame.Lazy.Internal.Optimizer, - DataFrame.Lazy.Internal.Executor, DataFrame.Typed.Lazy - build-depends: dataframe-lazy ^>= 1.1 + build-depends: dataframe-lazy >= 2.0 && < 2.1 cpp-options: -DWITH_LAZY if !flag(no-th) - build-depends: dataframe-th ^>= 1.0.1.1 + build-depends: dataframe-th >= 2.0 && < 2.1 cpp-options: -DWITH_TH exposed-modules: DataFrame.TH, DataFrame.Typed.TH if !flag(no-th) && !flag(no-csv) - build-depends: dataframe-csv-th ^>= 1.0 + build-depends: dataframe-csv-th >= 1.1 && < 1.2 cpp-options: -DWITH_CSV_TH if !flag(no-th) && !flag(no-parquet) - build-depends: dataframe-parquet-th ^>= 1.0 + build-depends: dataframe-parquet-th >= 1.1 && < 1.2 cpp-options: -DWITH_PARQUET_TH hs-source-dirs: src @@ -190,25 +193,29 @@ hs-source-dirs: ffi exposed-modules: DataFrame.IO.Arrow DataFrame.IR - DataFrame.IR.ExprJson + -- The expr/pipeline JSON codec now lives in its own lightweight package; + -- re-export it so the Python FFI and Haskell consumers keep importing + -- @DataFrame.IR.ExprJson@ unchanged. + reexported-modules: DataFrame.IR.ExprJson -- The Arrow bridge IR loads CSV + Parquet readers, so it requires -- both backends. If either flag is off, skip building it. if flag(no-csv) || flag(no-parquet) buildable: False build-depends: base >= 4 && < 5, - dataframe-core ^>= 1.1, - dataframe-csv ^>= 1.0.2, - dataframe-json ^>= 1.0, - dataframe-lazy ^>= 1.1, - dataframe-operations >= 1.1.1 && < 1.2, - dataframe-parquet ^>= 1.1, - dataframe-parsing ^>= 1.0.2, + dataframe-core:internal >= 2.0 && < 2.1, + dataframe-expr-serializer >= 1.1 && < 1.2, + dataframe-csv >= 2.0 && < 2.1, + dataframe-json >= 1.1 && < 1.2, + dataframe-lazy >= 2.0 && < 2.1, + dataframe-operations >= 2.0 && < 2.1, + dataframe-parquet >= 1.2 && < 1.3, + dataframe-parsing >= 2.0 && < 2.1, text >= 2.1 && < 3, aeson >= 0.11 && < 3, - bytestring >= 0.11 && < 0.13, - containers >= 0.6.7 && < 0.9, - vector ^>= 0.13 + bytestring >= 0.11 && < 0.14, + containers >= 0.6.7 && < 0.10, + vector >= 0.13 && < 0.15 include-dirs: cbits default-language: Haskell2010 @@ -216,11 +223,11 @@ import: warnings main-is: Benchmark.hs build-depends: base >= 4 && < 5, - dataframe >= 1 && < 3, - dataframe-operations >= 1.1.1 && < 1.2, + dataframe >= 3.0 && < 3.1, + dataframe-operations >= 2.0 && < 2.1, random >= 1 && < 2, time >= 1.12 && < 2, - vector ^>= 0.13, + vector >= 0.13 && < 0.15, hs-source-dirs: app default-language: Haskell2010 ghc-options: -rtsopts -threaded -with-rtsopts=-N @@ -229,10 +236,10 @@ import: warnings main-is: Synthesis.hs build-depends: base >= 4 && < 5, - dataframe >= 1 && < 3, - dataframe-core ^>= 1.1, - dataframe-learn ^>= 1.1, - dataframe-operations >= 1.1.1 && < 1.2, + dataframe >= 3.0 && < 3.1, + dataframe-core >= 2.0 && < 2.1, + dataframe-learn >= 2.0 && < 2.1, + dataframe-operations >= 2.0 && < 2.1, random >= 1 && < 2, text >= 2.1 && < 3 hs-source-dirs: app @@ -261,12 +268,12 @@ if flag(no-csv) || flag(no-parquet) buildable: False build-depends: base >= 4 && < 5, - bytestring >= 0.11 && < 0.13, - containers >= 0.6.7 && < 0.9, - dataframe >= 1 && < 3, - dataframe-core ^>= 1.1, - dataframe-lazy ^>= 1.1, - dataframe-parsing ^>= 1.0.2, + bytestring >= 0.11 && < 0.14, + containers >= 0.6.7 && < 0.10, + dataframe >= 3.0 && < 3.1, + dataframe-core >= 2.0 && < 2.1, + dataframe-lazy >= 2.0 && < 2.1, + dataframe-parsing >= 2.0 && < 2.1, directory >= 1.3.0.0 && < 2, random >= 1 && < 2, text >= 2.1 && < 3, @@ -284,7 +291,9 @@ criterion >= 1 && < 2, deepseq >= 1.4 && < 2, process >= 1.6 && < 2, - dataframe >= 1 && < 3, + dataframe >= 3.0 && < 3.1, + dataframe-core:internal >= 2.0 && < 2.1, + dataframe-operations >= 2.0 && < 2.1, random >= 1 && < 2, default-language: Haskell2010 ghc-options: @@ -304,8 +313,6 @@ if flag(no-csv) || flag(no-parquet) || flag(no-th) buildable: False other-modules: Assertions, - Cart, - DecisionTree, Functions, GenDataFrame, Internal.ColumnBuilder, @@ -314,21 +321,20 @@ Internal.PackedText, Internal.Parsing, PackedTextMigration, - Learn.Numerics, + PrettyPrint, Learn.Denotation, Learn.Models, + Learn.TypedModel, + Learn.Segmented, Learn.Ensembles, - Learn.Symbolic, Learn.SklearnParity, Learn.Synthesis, Learn.MetricsTests, Learn.Metamorphic, - Learn.EdgeCases, - Learn.NumericalRigor, IO.CSV, IO.CsvGolden, IO.JSON, - LinearSolver, + IR.ExprJsonRoundtrip, Operations.Aggregations, Operations.Apply, Operations.Core, @@ -363,33 +369,36 @@ Plotting, Properties, Properties.Categorical, - Properties.Simplify, Simplify, - TreePruning, - Worklist, + Typed.Parity, + Typed.IOReaders, Monad build-depends: base >= 4 && < 5, aeson >= 0.11.0.0 && < 3, - bytestring >= 0.11 && < 0.13, - dataframe >= 1 && < 3, - dataframe-core ^>= 1.1, - dataframe-csv ^>= 1.0.2, - dataframe-json ^>= 1.0, - dataframe-lazy ^>= 1.1, - dataframe-learn ^>= 1.1, - dataframe-operations >= 1.1.1 && < 1.2, - dataframe-parquet ^>= 1.1, - dataframe-parsing ^>= 1.0.2, - HUnit ^>= 1.6, + bytestring >= 0.11 && < 0.14, + dataframe >= 3.0 && < 3.1, + dataframe-core >= 2.0 && < 2.1, + dataframe-core:internal >= 2.0 && < 2.1, + dataframe-csv >= 2.0 && < 2.1, + dataframe-expr-serializer >= 1.1 && < 1.2, + dataframe-json >= 1.1 && < 1.2, + dataframe-lazy >= 2.0 && < 2.1, + dataframe-learn >= 2.0 && < 2.1, + dataframe-operations >= 2.0 && < 2.1, + dataframe-operations:internal >= 2.0 && < 2.1, + dataframe-parquet >= 1.2 && < 1.3, + dataframe-parsing >= 2.0 && < 2.1, + dataframe-parsing:internal >= 2.0 && < 2.1, + HUnit >= 1.6 && < 1.8, QuickCheck >= 2 && < 3, random-shuffle >= 0.0.4 && < 1, random >= 1 && < 2, text >= 2.1 && < 3, time >= 1.12 && < 2, - vector ^>= 0.13, - temporary >= 1.3 && < 1.4, + vector >= 0.13 && < 0.15, + temporary >= 1.3 && < 1.5, directory >= 1.3 && < 1.4, - containers >= 0.6.7 && < 0.9 + containers >= 0.6.7 && < 0.10 hs-source-dirs: tests default-language: Haskell2010 @@ -403,12 +412,12 @@ buildable: False other-modules: Internal.PackedText build-depends: base >= 4 && < 5, - bytestring >= 0.11 && < 0.13, - dataframe >= 1 && < 3, - dataframe-core ^>= 1.1, - dataframe-operations >= 1.1.1 && < 1.2, - HUnit ^>= 1.6, + bytestring >= 0.11 && < 0.14, + dataframe >= 3.0 && < 3.1, + dataframe-core:internal >= 2.0 && < 2.1, + dataframe-operations >= 2.0 && < 2.1, + HUnit >= 1.6 && < 1.8, text >= 2.1 && < 3, - vector ^>= 0.13 + vector >= 0.13 && < 0.15 hs-source-dirs: tests default-language: Haskell2010 diff --git a/ffi/DataFrame/IR.hs b/ffi/DataFrame/IR.hs --- a/ffi/DataFrame/IR.hs +++ b/ffi/DataFrame/IR.hs @@ -49,7 +49,6 @@ import DataFrame.Internal.Column (Column (..), Columnable) import DataFrame.Internal.DataFrame (DataFrame, unsafeGetColumn) import DataFrame.Internal.Expression (Expr (..), NamedExpr) -import DataFrame.Internal.Schema (Schema, makeSchema, schemaType) import qualified DataFrame.Lazy as Lazy import DataFrame.Operations.Aggregation (aggregate, distinct, groupBy) import DataFrame.Operations.Core (insertVector, renameMany) @@ -60,6 +59,7 @@ import qualified DataFrame.Operations.Subset as Subset import DataFrame.Operations.Transformations (derive) import DataFrame.Operators ((.=)) +import DataFrame.Schema (Schema, makeSchema, schemaType) -- --------------------------------------------------------------------------- -- IR types @@ -225,8 +225,7 @@ let r = Stats.correlation a b df valueCol = case r of Just d -> V.singleton d - Nothing -> V.singleton (0 / 0 :: Double) -- NaN when correlation is undefined - -- Return a single-row frame: { first, second, correlation } + Nothing -> V.singleton (0 / 0 :: Double) return $ insertVector "first" (V.singleton a) $ insertVector "second" (V.singleton b) $ @@ -239,8 +238,6 @@ executePlan reader (WriteCsv path node) = do df <- executePlan reader node writeCsv path df - -- Return the same frame so callers that pipe through .collect() get the - -- written data back too. Callers that don't care can discard. return df executePlan reader (ScanCsv path schemaPairs) = do schema <- buildSchema schemaPairs diff --git a/ffi/DataFrame/IR/ExprJson.hs b/ffi/DataFrame/IR/ExprJson.hs deleted file mode 100644 --- a/ffi/DataFrame/IR/ExprJson.hs +++ /dev/null @@ -1,701 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -{- | JSON wire format for 'Expr' values. - - The Python bindings build expression trees as JSON; this module decodes them - back into 'Expr' GADTs (typed) and encodes them in the reverse direction - (used for shipping fitted decision trees back to Python). - - Encoded shape: - - > { "node": "col" , "out_type": "double", "name": "x" } - > { "node": "lit" , "out_type": "int" , "value": 42 } - > { "node": "unary" , "out_type": "double", "op": "toDouble" - > , "arg_type": "int" , "arg": } - > { "node": "binary", "out_type": "bool" , "op": "leq" - > , "arg_type": "double", "lhs": , "rhs": } - > { "node": "if" , "out_type": "text" , "cond": - > , "then": , "else": } - - Operator names follow 'binaryName' / 'unaryName' from - "DataFrame.Internal.Expression". Nullable variants ("nulladd", "nullor", …) - are accepted on decode and treated as their non-null equivalents — Python - data crosses the FFI boundary as non-null Arrow buffers, so this is lossless - for the supported workflow. --} -module DataFrame.IR.ExprJson ( - SomeExpr (..), - encodeExpr, - encodeExprToBytes, - decodeExprAny, - decodeExprAt, - parseSomeExpr, - typeTagOf, - withTypeTag, - withOrdTypeTag, - withNumTypeTag, - withFracTypeTag, - withRealTypeTag, -) where - -import Data.Aeson (object, (.:), (.=)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Proxy (Proxy (..)) -import qualified Data.Text as T -import Data.Type.Equality (TestEquality (testEquality), type (:~:) (Refl)) -import Data.Word (Word16, Word32, Word64, Word8) -import Type.Reflection (TypeRep, Typeable, typeRep) - -import qualified DataFrame.Functions as F -import DataFrame.Internal.Column (Columnable) -import DataFrame.Internal.Expression ( - AggStrategy (..), - BinaryOp (binaryName), - Expr (..), - UnaryOp (unaryName), - ) -import qualified DataFrame.Internal.Expression as F -import DataFrame.Operators ( - ifThenElse, - (.&&.), - (./=.), - (.<.), - (.<=.), - (.==.), - (.>.), - (.>=.), - (.||.), - ) - -{- | Existential wrapper around a typed expression decoded from JSON. -TODO: mchavinda - Maybe consolidate with UExpr from the main package. --} -data SomeExpr where - SomeExpr :: (Columnable a) => TypeRep a -> Expr a -> SomeExpr - --- | Map a Haskell type to its wire-format tag string. -typeTagOf :: forall a. (Typeable a) => Maybe T.Text -typeTagOf - | Just _ <- testEquality (typeRep @a) (typeRep @Int) = Just "int" - | Just _ <- testEquality (typeRep @a) (typeRep @Int8) = Just "int8" - | Just _ <- testEquality (typeRep @a) (typeRep @Int16) = Just "int16" - | Just _ <- testEquality (typeRep @a) (typeRep @Int32) = Just "int32" - | Just _ <- testEquality (typeRep @a) (typeRep @Int64) = Just "int64" - | Just _ <- testEquality (typeRep @a) (typeRep @Word) = Just "word" - | Just _ <- testEquality (typeRep @a) (typeRep @Word8) = Just "word8" - | Just _ <- testEquality (typeRep @a) (typeRep @Word16) = Just "word16" - | Just _ <- testEquality (typeRep @a) (typeRep @Word32) = Just "word32" - | Just _ <- testEquality (typeRep @a) (typeRep @Word64) = Just "word64" - | Just _ <- testEquality (typeRep @a) (typeRep @Integer) = Just "integer" - | Just _ <- testEquality (typeRep @a) (typeRep @Double) = Just "double" - | Just _ <- testEquality (typeRep @a) (typeRep @Float) = Just "float" - | Just _ <- testEquality (typeRep @a) (typeRep @Bool) = Just "bool" - | Just _ <- testEquality (typeRep @a) (typeRep @Char) = Just "char" - | Just _ <- testEquality (typeRep @a) (typeRep @T.Text) = Just "text" - | Just _ <- testEquality (typeRep @a) (typeRep @String) = Just "string" - | otherwise = Nothing - --- | Dispatch on a type tag with a 'Columnable' continuation. -withTypeTag :: - T.Text -> - (forall a. (Columnable a) => Proxy a -> Aeson.Parser r) -> - Aeson.Parser r -withTypeTag t k = case t of - "int" -> k (Proxy @Int) - "int8" -> k (Proxy @Int8) - "int16" -> k (Proxy @Int16) - "int32" -> k (Proxy @Int32) - "int64" -> k (Proxy @Int64) - "word" -> k (Proxy @Word) - "word8" -> k (Proxy @Word8) - "word16" -> k (Proxy @Word16) - "word32" -> k (Proxy @Word32) - "word64" -> k (Proxy @Word64) - "integer" -> k (Proxy @Integer) - "double" -> k (Proxy @Double) - "float" -> k (Proxy @Float) - "bool" -> k (Proxy @Bool) - "char" -> k (Proxy @Char) - "text" -> k (Proxy @T.Text) - "string" -> k (Proxy @String) - _ -> fail $ "DataFrame.IR.ExprJson: unknown type tag: " <> T.unpack t - --- | Subset that supports 'Ord' (for comparison ops). -withOrdTypeTag :: - T.Text -> - (forall a. (Columnable a, Ord a) => Proxy a -> Aeson.Parser r) -> - Aeson.Parser r -withOrdTypeTag t k = case t of - "int" -> k (Proxy @Int) - "int8" -> k (Proxy @Int8) - "int16" -> k (Proxy @Int16) - "int32" -> k (Proxy @Int32) - "int64" -> k (Proxy @Int64) - "word" -> k (Proxy @Word) - "word8" -> k (Proxy @Word8) - "word16" -> k (Proxy @Word16) - "word32" -> k (Proxy @Word32) - "word64" -> k (Proxy @Word64) - "integer" -> k (Proxy @Integer) - "double" -> k (Proxy @Double) - "float" -> k (Proxy @Float) - "bool" -> k (Proxy @Bool) - "char" -> k (Proxy @Char) - "text" -> k (Proxy @T.Text) - "string" -> k (Proxy @String) - _ -> - fail $ "DataFrame.IR.ExprJson: type does not support ordering: " <> T.unpack t - --- | Subset that supports 'Num' (arithmetic). -withNumTypeTag :: - T.Text -> - (forall a. (Columnable a, Num a) => Proxy a -> Aeson.Parser r) -> - Aeson.Parser r -withNumTypeTag t k = case t of - "int" -> k (Proxy @Int) - "int8" -> k (Proxy @Int8) - "int16" -> k (Proxy @Int16) - "int32" -> k (Proxy @Int32) - "int64" -> k (Proxy @Int64) - "word" -> k (Proxy @Word) - "word8" -> k (Proxy @Word8) - "word16" -> k (Proxy @Word16) - "word32" -> k (Proxy @Word32) - "word64" -> k (Proxy @Word64) - "integer" -> k (Proxy @Integer) - "double" -> k (Proxy @Double) - "float" -> k (Proxy @Float) - _ -> - fail $ "DataFrame.IR.ExprJson: type does not support arithmetic: " <> T.unpack t - --- | Subset that supports 'Fractional' (division). -withFracTypeTag :: - T.Text -> - (forall a. (Columnable a, Fractional a) => Proxy a -> Aeson.Parser r) -> - Aeson.Parser r -withFracTypeTag t k = case t of - "double" -> k (Proxy @Double) - "float" -> k (Proxy @Float) - _ -> - fail $ - "DataFrame.IR.ExprJson: type does not support fractional division: " - <> T.unpack t - --- | Subset that supports 'Real' (used by toDouble source types). -withRealTypeTag :: - T.Text -> - (forall a. (Columnable a, Real a) => Proxy a -> Aeson.Parser r) -> - Aeson.Parser r -withRealTypeTag t k = case t of - "int" -> k (Proxy @Int) - "int8" -> k (Proxy @Int8) - "int16" -> k (Proxy @Int16) - "int32" -> k (Proxy @Int32) - "int64" -> k (Proxy @Int64) - "word" -> k (Proxy @Word) - "word8" -> k (Proxy @Word8) - "word16" -> k (Proxy @Word16) - "word32" -> k (Proxy @Word32) - "word64" -> k (Proxy @Word64) - "integer" -> k (Proxy @Integer) - "double" -> k (Proxy @Double) - "float" -> k (Proxy @Float) - _ -> - fail $ - "DataFrame.IR.ExprJson: type does not support Real (toDouble source): " - <> T.unpack t - --- | Subset that supports 'Floating'. -withFloatingTypeTag :: - T.Text -> - (forall a. (Columnable a, Floating a) => Proxy a -> Aeson.Parser r) -> - Aeson.Parser r -withFloatingTypeTag t k = case t of - "double" -> k (Proxy @Double) - "float" -> k (Proxy @Float) - _ -> - fail $ "DataFrame.IR.ExprJson: type does not support Floating: " <> T.unpack t - -{- | Encode an 'Expr' to a JSON value. Returns 'Left' on unsupported -constructors (Agg, Over, CastWith, CastExprWith) or unsupported operator -names (binaryUdf, unaryUdf, …). --} -encodeExpr :: forall a. (Columnable a) => Expr a -> Either String Aeson.Value -encodeExpr expr = case expr of - Col name -> do - outTag <- requireTypeTag @a - Right $ - object - [ "node" .= ("col" :: T.Text) - , "out_type" .= outTag - , "name" .= name - ] - Lit v -> do - outTag <- requireTypeTag @a - litVal <- encodeLit @a v - Right $ - object - [ "node" .= ("lit" :: T.Text) - , "out_type" .= outTag - , "value" .= litVal - ] - Unary op (arg :: Expr b) -> do - outTag <- requireTypeTag @a - argTag <- requireTypeTag @b - opTag <- recognizeUnary (unaryName op) - argEnc <- encodeExpr arg - Right $ - object - [ "node" .= ("unary" :: T.Text) - , "out_type" .= outTag - , "op" .= opTag - , "arg_type" .= argTag - , "arg" .= argEnc - ] - Binary op (lhs :: Expr c) (rhs :: Expr b) -> do - outTag <- requireTypeTag @a - argTag <- requireTypeTag @c - opTag <- recognizeBinary (binaryName op) - lEnc <- encodeExpr lhs - rEnc <- encodeExpr rhs - Right $ - object - [ "node" .= ("binary" :: T.Text) - , "out_type" .= outTag - , "op" .= opTag - , "arg_type" .= argTag - , "lhs" .= lEnc - , "rhs" .= rEnc - ] - If cond th el -> do - outTag <- requireTypeTag @a - cEnc <- encodeExpr cond - tEnc <- encodeExpr th - eEnc <- encodeExpr el - Right $ - object - [ "node" .= ("if" :: T.Text) - , "out_type" .= outTag - , "cond" .= cEnc - , "then" .= tEnc - , "else" .= eEnc - ] - CastWith{} -> - Left - "DataFrame.IR.ExprJson.encodeExpr: CastWith is not supported in the wire format" - CastExprWith{} -> - Left - "DataFrame.IR.ExprJson.encodeExpr: CastExprWith is not supported in the wire format" - Agg (strat :: F.AggStrategy a b) (inner :: F.Expr b) -> do - outTag <- requireTypeTag @a - argTag <- requireTypeTag @b - innerEnc <- encodeExpr inner - Right $ - object - [ "node" .= ("agg" :: T.Text) - , "out_type" .= outTag - , "agg" .= aggStrategyName strat - , "arg_type" .= argTag - , "arg" .= innerEnc - ] - Over names inner -> do - outTag <- requireTypeTag @a - innerEnc <- encodeExpr inner - Right $ - object - [ "node" .= ("over" :: T.Text) - , "out_type" .= outTag - , "partition_by" .= names - , "arg" .= innerEnc - ] - where - requireTypeTag :: forall x. (Typeable x) => Either String T.Text - requireTypeTag = case typeTagOf @x of - Just t -> Right t - Nothing -> - Left $ - "DataFrame.IR.ExprJson.encodeExpr: unsupported type: " <> show (typeRep @x) - --- | Wire-format name for an aggregation strategy. -aggStrategyName :: AggStrategy a b -> T.Text -aggStrategyName (CollectAgg n _) = n -aggStrategyName (FoldAgg n _ _) = n -aggStrategyName (MergeAgg n _ _ _ _) = n - --- | Encode an 'Expr' to a strict 'BS.ByteString' of JSON. -encodeExprToBytes :: - forall a. (Columnable a) => Expr a -> Either String BS.ByteString -encodeExprToBytes e = BL.toStrict . Aeson.encode <$> encodeExpr e - -encodeLit :: forall a. (Columnable a) => a -> Either String Aeson.Value -encodeLit v - | Just Refl <- testEquality (typeRep @a) (typeRep @Int) = - Right $ Aeson.toJSON (v :: Int) - | Just Refl <- testEquality (typeRep @a) (typeRep @Int8) = - Right $ Aeson.toJSON (v :: Int8) - | Just Refl <- testEquality (typeRep @a) (typeRep @Int16) = - Right $ Aeson.toJSON (v :: Int16) - | Just Refl <- testEquality (typeRep @a) (typeRep @Int32) = - Right $ Aeson.toJSON (v :: Int32) - | Just Refl <- testEquality (typeRep @a) (typeRep @Int64) = - Right $ Aeson.toJSON (v :: Int64) - | Just Refl <- testEquality (typeRep @a) (typeRep @Word) = - Right $ Aeson.toJSON (v :: Word) - | Just Refl <- testEquality (typeRep @a) (typeRep @Word8) = - Right $ Aeson.toJSON (v :: Word8) - | Just Refl <- testEquality (typeRep @a) (typeRep @Word16) = - Right $ Aeson.toJSON (v :: Word16) - | Just Refl <- testEquality (typeRep @a) (typeRep @Word32) = - Right $ Aeson.toJSON (v :: Word32) - | Just Refl <- testEquality (typeRep @a) (typeRep @Word64) = - Right $ Aeson.toJSON (v :: Word64) - | Just Refl <- testEquality (typeRep @a) (typeRep @Integer) = - Right $ Aeson.toJSON (v :: Integer) - | Just Refl <- testEquality (typeRep @a) (typeRep @Double) = - Right $ Aeson.toJSON (v :: Double) - | Just Refl <- testEquality (typeRep @a) (typeRep @Float) = - Right $ Aeson.toJSON (v :: Float) - | Just Refl <- testEquality (typeRep @a) (typeRep @Bool) = - Right $ Aeson.toJSON (v :: Bool) - | Just Refl <- testEquality (typeRep @a) (typeRep @T.Text) = - Right $ Aeson.toJSON (v :: T.Text) - | Just Refl <- testEquality (typeRep @a) (typeRep @Char) = - Right $ Aeson.toJSON [v :: Char] - | Just Refl <- testEquality (typeRep @a) (typeRep @String) = - Right $ Aeson.toJSON (v :: String) - | otherwise = - Left $ - "DataFrame.IR.ExprJson.encodeLit: unsupported type: " <> show (typeRep @a) - --- | Map a 'binaryName' string to a wire-format op name. Errors on opaque UDF names. -recognizeBinary :: T.Text -> Either String T.Text -recognizeBinary n = case n of - "add" -> Right "add" - "sub" -> Right "sub" - "mult" -> Right "mult" - "divide" -> Right "divide" - "eq" -> Right "eq" - "neq" -> Right "neq" - "lt" -> Right "lt" - "leq" -> Right "leq" - "gt" -> Right "gt" - "geq" -> Right "geq" - "and" -> Right "and" - "or" -> Right "or" - -- Nullable-aware aliases (lossless on non-null inputs) - "nulladd" -> Right "add" - "nullsub" -> Right "sub" - "nullmul" -> Right "mult" - "nulldiv" -> Right "divide" - "nulland" -> Right "and" - "nullor" -> Right "or" - "exponentiate" -> Right "exponentiate" - "logBase" -> Right "logBase" - "div" -> Right "div" - "mod" -> Right "mod" - "pow" -> Right "pow" - other -> - Left $ - "DataFrame.IR.ExprJson: unsupported binary op (cannot serialize): " - <> T.unpack other - --- | Map a 'unaryName' string to a wire-format op name. Errors on opaque UDF names. -recognizeUnary :: T.Text -> Either String T.Text -recognizeUnary n = case n of - "not" -> Right "not" - "negate" -> Right "negate" - "abs" -> Right "abs" - "signum" -> Right "signum" - "exp" -> Right "exp" - "sqrt" -> Right "sqrt" - "log" -> Right "log" - "sin" -> Right "sin" - "cos" -> Right "cos" - "tan" -> Right "tan" - "asin" -> Right "asin" - "acos" -> Right "acos" - "atan" -> Right "atan" - "sinh" -> Right "sinh" - "cosh" -> Right "cosh" - "asinh" -> Right "asinh" - "acosh" -> Right "acosh" - "atanh" -> Right "atanh" - "toDouble" -> Right "toDouble" - other -> - Left $ - "DataFrame.IR.ExprJson: unsupported unary op (cannot serialize): " - <> T.unpack other - -{- | Decode a JSON value into a 'SomeExpr'. The output type comes from the -@out_type@ field on the root node. --} -decodeExprAny :: Aeson.Value -> Either String SomeExpr -decodeExprAny = Aeson.parseEither parseSomeExpr - --- | Decode a JSON value, asserting the result type matches @a@. -decodeExprAt :: - forall a. (Columnable a) => Aeson.Value -> Either String (Expr a) -decodeExprAt v = do - SomeExpr trep expr <- decodeExprAny v - case testEquality trep (typeRep @a) of - Just Refl -> Right expr - Nothing -> - Left $ - "DataFrame.IR.ExprJson.decodeExprAt: expected " - <> show (typeRep @a) - <> " but got " - <> show trep - --- | The Aeson.Parser entry point — useful when composing with bigger parsers. -parseSomeExpr :: Aeson.Value -> Aeson.Parser SomeExpr -parseSomeExpr = Aeson.withObject "Expr" $ \o -> do - node <- o .: "node" :: Aeson.Parser T.Text - outType <- o .: "out_type" :: Aeson.Parser T.Text - case node of - "col" -> do - name <- o .: "name" :: Aeson.Parser T.Text - withTypeTag outType $ \(_ :: Proxy a) -> - return $ SomeExpr (typeRep @a) (Col @a name) - "lit" -> do - rawVal <- o .: "value" - withTypeTag outType $ \(_ :: Proxy a) -> do - litVal <- decodeLit @a rawVal - return $ SomeExpr (typeRep @a) (Lit @a litVal) - "if" -> do - rawCond <- o .: "cond" - rawThen <- o .: "then" - rawElse <- o .: "else" - cond <- parseExprAt @Bool rawCond - withTypeTag outType $ \(_ :: Proxy a) -> do - thenE <- parseExprAt @a rawThen - elseE <- parseExprAt @a rawElse - return $ SomeExpr (typeRep @a) (ifThenElse cond thenE elseE) - "unary" -> do - op <- o .: "op" :: Aeson.Parser T.Text - argType <- o .: "arg_type" :: Aeson.Parser T.Text - rawArg <- o .: "arg" - parseUnary op outType argType rawArg - "binary" -> do - op <- o .: "op" :: Aeson.Parser T.Text - argType <- o .: "arg_type" :: Aeson.Parser T.Text - rawLhs <- o .: "lhs" - rawRhs <- o .: "rhs" - parseBinary op outType argType rawLhs rawRhs - other -> fail $ "DataFrame.IR.ExprJson: unknown node kind: " <> T.unpack other - -parseExprAt :: forall a. (Columnable a) => Aeson.Value -> Aeson.Parser (Expr a) -parseExprAt v = do - SomeExpr trep expr <- parseSomeExpr v - case testEquality trep (typeRep @a) of - Just Refl -> return expr - Nothing -> - fail $ - "DataFrame.IR.ExprJson: expected " - <> show (typeRep @a) - <> " but got " - <> show trep - -decodeLit :: forall a. (Columnable a) => Aeson.Value -> Aeson.Parser a -decodeLit v - | Just Refl <- testEquality (typeRep @a) (typeRep @Int) = parseAs @Int v - | Just Refl <- testEquality (typeRep @a) (typeRep @Int8) = parseAs @Int8 v - | Just Refl <- testEquality (typeRep @a) (typeRep @Int16) = parseAs @Int16 v - | Just Refl <- testEquality (typeRep @a) (typeRep @Int32) = parseAs @Int32 v - | Just Refl <- testEquality (typeRep @a) (typeRep @Int64) = parseAs @Int64 v - | Just Refl <- testEquality (typeRep @a) (typeRep @Word) = parseAs @Word v - | Just Refl <- testEquality (typeRep @a) (typeRep @Word8) = parseAs @Word8 v - | Just Refl <- testEquality (typeRep @a) (typeRep @Word16) = parseAs @Word16 v - | Just Refl <- testEquality (typeRep @a) (typeRep @Word32) = parseAs @Word32 v - | Just Refl <- testEquality (typeRep @a) (typeRep @Word64) = parseAs @Word64 v - | Just Refl <- testEquality (typeRep @a) (typeRep @Integer) = parseAs @Integer v - | Just Refl <- testEquality (typeRep @a) (typeRep @Double) = parseAs @Double v - | Just Refl <- testEquality (typeRep @a) (typeRep @Float) = parseAs @Float v - | Just Refl <- testEquality (typeRep @a) (typeRep @Bool) = parseAs @Bool v - | Just Refl <- testEquality (typeRep @a) (typeRep @T.Text) = parseAs @T.Text v - | Just Refl <- testEquality (typeRep @a) (typeRep @Char) = parseChar v - | Just Refl <- testEquality (typeRep @a) (typeRep @String) = parseAs @String v - | otherwise = - fail $ - "DataFrame.IR.ExprJson.decodeLit: unsupported type: " <> show (typeRep @a) - -parseAs :: forall b. (Aeson.FromJSON b) => Aeson.Value -> Aeson.Parser b -parseAs = Aeson.parseJSON - -parseChar :: Aeson.Value -> Aeson.Parser Char -parseChar v = do - s <- Aeson.parseJSON v :: Aeson.Parser T.Text - case T.unpack s of - [c] -> return c - _ -> - fail $ - "DataFrame.IR.ExprJson: expected single-character string, got: " <> show s - -requireTag :: T.Text -> T.Text -> Aeson.Parser () -requireTag actual expected - | actual == expected = return () - | otherwise = - fail $ - "DataFrame.IR.ExprJson: type mismatch — expected " - <> T.unpack expected - <> " but got " - <> T.unpack actual - -requireSame :: T.Text -> T.Text -> Aeson.Parser () -requireSame a b - | a == b = return () - | otherwise = - fail $ - "DataFrame.IR.ExprJson: type mismatch — " - <> T.unpack a - <> " vs " - <> T.unpack b - -parseUnary :: - T.Text -> T.Text -> T.Text -> Aeson.Value -> Aeson.Parser SomeExpr -parseUnary op outType argType rawArg = case op of - "not" -> do - requireTag outType "bool" - requireTag argType "bool" - arg <- parseExprAt @Bool rawArg - return $ SomeExpr (typeRep @Bool) (F.not arg) - "negate" -> withNumTypeTag outType $ \(_ :: Proxy a) -> do - requireSame outType argType - arg <- parseExprAt @a rawArg - return $ SomeExpr (typeRep @a) (negate arg) - "abs" -> withNumTypeTag outType $ \(_ :: Proxy a) -> do - requireSame outType argType - arg <- parseExprAt @a rawArg - return $ SomeExpr (typeRep @a) (abs arg) - "signum" -> withNumTypeTag outType $ \(_ :: Proxy a) -> do - requireSame outType argType - arg <- parseExprAt @a rawArg - return $ SomeExpr (typeRep @a) (signum arg) - "toDouble" -> do - requireTag outType "double" - withRealTypeTag argType $ \(_ :: Proxy a) -> do - arg <- parseExprAt @a rawArg - return $ SomeExpr (typeRep @Double) (F.toDouble arg) - "exp" -> floatingUnary outType argType rawArg exp - "sqrt" -> floatingUnary outType argType rawArg sqrt - "log" -> floatingUnary outType argType rawArg log - "sin" -> floatingUnary outType argType rawArg sin - "cos" -> floatingUnary outType argType rawArg cos - "tan" -> floatingUnary outType argType rawArg tan - "asin" -> floatingUnary outType argType rawArg asin - "acos" -> floatingUnary outType argType rawArg acos - "atan" -> floatingUnary outType argType rawArg atan - "sinh" -> floatingUnary outType argType rawArg sinh - "cosh" -> floatingUnary outType argType rawArg cosh - "asinh" -> floatingUnary outType argType rawArg asinh - "acosh" -> floatingUnary outType argType rawArg acosh - "atanh" -> floatingUnary outType argType rawArg atanh - other -> fail $ "DataFrame.IR.ExprJson: unsupported unary op: " <> T.unpack other - -floatingUnary :: - T.Text -> - T.Text -> - Aeson.Value -> - (forall x. (Columnable x, Floating x) => Expr x -> Expr x) -> - Aeson.Parser SomeExpr -floatingUnary outType argType rawArg f = withFloatingTypeTag outType $ \(_ :: Proxy a) -> do - requireSame outType argType - arg <- parseExprAt @a rawArg - return $ SomeExpr (typeRep @a) (f arg) - -parseBinary :: - T.Text -> - T.Text -> - T.Text -> - Aeson.Value -> - Aeson.Value -> - Aeson.Parser SomeExpr -parseBinary op outType argType rawLhs rawRhs = case op of - "eq" -> do - requireTag outType "bool" - withTypeTag argType $ \(_ :: Proxy a) -> do - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @Bool) (l .==. r) - "neq" -> do - requireTag outType "bool" - withTypeTag argType $ \(_ :: Proxy a) -> do - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @Bool) (l ./=. r) - "lt" -> do - requireTag outType "bool" - withOrdTypeTag argType $ \(_ :: Proxy a) -> do - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @Bool) (l .<. r) - "leq" -> do - requireTag outType "bool" - withOrdTypeTag argType $ \(_ :: Proxy a) -> do - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @Bool) (l .<=. r) - "gt" -> do - requireTag outType "bool" - withOrdTypeTag argType $ \(_ :: Proxy a) -> do - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @Bool) (l .>. r) - "geq" -> do - requireTag outType "bool" - withOrdTypeTag argType $ \(_ :: Proxy a) -> do - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @Bool) (l .>=. r) - "and" -> do - requireTag outType "bool" - l <- parseExprAt @Bool rawLhs - r <- parseExprAt @Bool rawRhs - return $ SomeExpr (typeRep @Bool) (l .&&. r) - "or" -> do - requireTag outType "bool" - l <- parseExprAt @Bool rawLhs - r <- parseExprAt @Bool rawRhs - return $ SomeExpr (typeRep @Bool) (l .||. r) - "add" -> withNumTypeTag outType $ \(_ :: Proxy a) -> do - requireSame outType argType - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @a) (l + r) - "sub" -> withNumTypeTag outType $ \(_ :: Proxy a) -> do - requireSame outType argType - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @a) (l - r) - "mult" -> withNumTypeTag outType $ \(_ :: Proxy a) -> do - requireSame outType argType - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @a) (l * r) - "divide" -> withFracTypeTag outType $ \(_ :: Proxy a) -> do - requireSame outType argType - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @a) (l / r) - "exponentiate" -> withFloatingTypeTag outType $ \(_ :: Proxy a) -> do - requireSame outType argType - l <- parseExprAt @a rawLhs - r <- parseExprAt @a rawRhs - return $ SomeExpr (typeRep @a) (l ** r) - "nulladd" -> parseBinary "add" outType argType rawLhs rawRhs - "nullsub" -> parseBinary "sub" outType argType rawLhs rawRhs - "nullmul" -> parseBinary "mult" outType argType rawLhs rawRhs - "nulldiv" -> parseBinary "divide" outType argType rawLhs rawRhs - "nulland" -> parseBinary "and" outType argType rawLhs rawRhs - "nullor" -> parseBinary "or" outType argType rawLhs rawRhs - other -> fail $ "DataFrame.IR.ExprJson: unsupported binary op: " <> T.unpack other diff --git a/src/DataFrame.hs b/src/DataFrame.hs --- a/src/DataFrame.hs +++ b/src/DataFrame.hs @@ -8,201 +8,13 @@ Stability : experimental Portability : POSIX -Batteries-included entry point for the DataFrame library. - -This module re-exports the most commonly used pieces of the @dataframe@ library so you -can get productive fast in GHCi, IHaskell, or scripts. - -__Naming convention__ - -* Use the @D.@ (\"DataFrame\") prefix for core table operations. -* Use the @F.@ (\"Functions\") prefix for the expression DSL (columns, math, aggregations). - -Example session: - -We provide a script that imports the core functionality and defines helpful -macros for writing safe code. - -@ -\$ cabal update -\$ cabal install dataframe -\$ dataframe -Configuring library for fake-package-0... -Warning: No exposed modules -GHCi, version 9.6.7: https:\/\/www.haskell.org\/ghc\/ :? for help -Loaded GHCi configuration from \/tmp\/cabal-repl.-242816\/setcwd.ghci -======================================== - 📦Dataframe -======================================== - -✨ Modules were automatically imported. - -💡 Use prefix 'D' for core functionality. - ● E.g. D.readCsv \"\/path\/to\/file\" -💡 Use prefix 'F' for expression functions. - ● E.g. F.sum (F.col \@Int \"value\") - -✅ Ready. -Loaded GHCi configuration from ./dataframe.ghci -ghci> -@ - -= Quick start -Load a CSV, select a few columns, filter, derive a column, then group + aggregate: - -@ --- 1) Load data -ghci> df0 <- D.readCsv "data/housing.csv" -ghci> D.describeColumns df0 -------------------------------------------------------------------------------------------------------------- - Column Name | # Non-null Values | # Null Values | # Partially parsed | # Unique Values | Type ---------------------|-------------------|---------------|--------------------|-----------------|------------- - Text | Int | Int | Int | Int | Text ---------------------|-------------------|---------------|--------------------|-----------------|------------- - ocean_proximity | 20640 | 0 | 0 | 5 | Text - median_house_value | 20640 | 0 | 0 | 3842 | Double - median_income | 20640 | 0 | 0 | 12928 | Double - households | 20640 | 0 | 0 | 1815 | Double - population | 20640 | 0 | 0 | 3888 | Double - total_bedrooms | 20640 | 0 | 0 | 1924 | Maybe Double - total_rooms | 20640 | 0 | 0 | 5926 | Double - housing_median_age | 20640 | 0 | 0 | 52 | Double - latitude | 20640 | 0 | 0 | 862 | Double - longitude | 20640 | 0 | 0 | 844 | Double - --- 2) Project & filter -ghci> :declareColumns df -ghci> df1 = D.filterWhere (ocean_proximity .== \"ISLAND\") df0 D.|> D.select [F.name median_house_value, F.name median_income, F.name ocean_proximity] - --- 3) Add a derived column using the expression DSL --- (col types are explicit via TypeApplications) -ghci> df2 = D.derive "rooms_per_household" (total_rooms / households) df0 - --- 4) Group + aggregate -ghci> import DataFrame.Operators -ghci> let grouped = D.groupBy ["ocean_proximity"] df0 -ghci> let summary = - D.aggregate - [ F.maximum median_house_value \`as\` "max_house_value"] - grouped -ghci> D.take 5 summary ----------------------------------- - ocean_proximity | max_house_value ------------------|---------------- - Text | Double ------------------|---------------- - <1H OCEAN | 500001.0 - INLAND | 500001.0 - ISLAND | 450000.0 - NEAR BAY | 500001.0 - NEAR OCEAN | 500001.0 -@ - -== Simple operations (cheat sheet) -Most users only need a handful of verbs: - -__I/O__ - - * @D.readCsv :: FilePath -> IO DataFrame@ - * @D.readTsv :: FilePath -> IO DataFrame@ - * @D.writeCsv :: FilePath -> DataFrame -> IO ()@ - * @D.readParquet :: FilePath -> IO DataFrame@ - * @D.readParquetWithOpts :: ParquetReadOptions -> FilePath -> IO DataFrame@ - * @D.readParquetFiles :: FilePath -> IO DataFrame@ - * @D.readParquetFilesWithOpts :: ParquetReadOptions -> FilePath -> IO DataFrame@ - -__Exploration__ - - * @D.take :: Int -> DataFrame -> DataFrame@ - * @D.takeLast :: Int -> DataFrame -> DataFrame@ - * @D.describeColumns :: DataFrame -> DataFrame@ - * @D.summarize :: DataFrame -> DataFrame@ - -__Row ops__ - - * @D.filter :: Expr a -> (a -> Bool) -> DataFrame -> DataFrame@ - * @D.filterWhere :: Expr Bool -> DataFrame -> DataFrame@ - * @D.sortBy :: SortOrder -> [Text] -> DataFrame -> DataFrame@ - -__Column ops__ - - * @D.select :: [Text] -> DataFrame -> DataFrame@ - * @D.exclude :: [Text] -> DataFrame -> DataFrame@ - * @D.rename :: [(Text,Text)] -> DataFrame -> DataFrame@ - * @D.derive :: Text -> D.Expr a -> DataFrame -> DataFrame@ - -__Group & aggregate__ - - * @D.groupBy :: [Text] -> DataFrame -> GroupedDataFrame@ - * @D.aggregate :: [NamedExpr] -> GroupedDataFrame -> DataFrame@ - -__Joins__ - - * @D.innerJoin \/ D.leftJoin \/ D.rightJoin \/ D.fullOuterJoin@ - -== Expression DSL (F.*) at a glance -Columns (typed): - -@ -F.col \@Text "ocean_proximity" -F.col \@Double "total_rooms" -F.lit \@Double 1.0 -@ - -Math & comparisons (overloaded by type): - -@ -(+), (-), (*), (/), abs, log, exp, round -(F.eq), (F.gt), (F.geq), (F.lt), (F.leq) -(.==), (.>), (.>=), (.<), (.<=) -@ - -Aggregations (for D.'aggregate'): - -@ -F.count \@a (F.col \@a "c") -F.sum \@Double (F.col \@Double "x") -F.mean \@Double (F.col \@Double "x") -F.min \@t (F.col \@t "x") -F.max \@t (F.col \@t "x") -@ - -== REPL power-tool: ':declareColumns' - -Use @:declareColumns @ in GHCi/IHaskell to turn each column of a bound 'DataFrame' -into a local binding with the same (mangled if needed) name and the column's concrete -vector type. This is great for quick ad-hoc analysis, plotting, or hand-rolled checks. - -@ --- Suppose df has columns: "passengers" :: Int, "fare" :: Double, "payment" :: Text -ghci> :set -XTemplateHaskell -ghci> :declareColumns df - --- Now you have in scope: -ghci> :type passengers -passengers :: Expr Int - -ghci> :type fare -fare :: Expr Double - -ghci> :type payment -payment :: Expr Text - --- You can use them directly: -ghci> D.derive "fare_with_tip" (fare * 1.2) -@ - -Notes: - -* Name mangling: spaces and non-identifier characters are replaced (e.g. @"trip id"@ -> @trip_id@). -* Optional/nullable columns are exposed as @Expr (Maybe a)@. +Batteries-included entry point for @dataframe@: re-exports the most commonly +used pieces for GHCi and scripts. Use the @D.@ prefix for core table operations +and @F.@ for the expression DSL. -} module DataFrame ( -- * Core data structures - module Dataframe, - module Column, - module Row, - module Expression, + module CoreTypes, -- * Operator symbols. module Operators, @@ -266,11 +78,10 @@ ) where --- DecisionTree defines its own `percentile`/`percentiles` helpers; the --- public versions surfaced through the meta module are the ones from --- Operations.Statistics / DataFrame.Synthesis. Hide the duplicates to --- avoid ambiguous-export errors. -import DataFrame.DecisionTree as DecisionTree hiding (percentile, percentiles) +-- DecisionTree's own `percentile`/`percentiles` are hidden here; the public +-- versions come from Operations.Statistics / DataFrame.Synthesis, avoiding +-- ambiguous-export errors. +import DataFrame.DecisionTree as DecisionTree import DataFrame.Display as Display ( DisplayOptions (..), defaultDisplayOptions, @@ -299,6 +110,9 @@ readJSON, readJSONEither, ) +-- Marks the dataframe-expr-serializer dependency as used (the codec modules are +-- surfaced to consumers via this library's @reexported-modules@). +import DataFrame.Expr.Serialize () #ifdef WITH_PARQUET import DataFrame.IO.Parquet as Parquet ( ParquetReadOptions (..), @@ -309,56 +123,58 @@ readParquetWithOpts, ) #endif -import DataFrame.Internal.Column as Column ( +import DataFrame.Core as CoreTypes ( + Any, Column, - fromList, - fromUnboxedVector, - fromVector, - hasElemType, - hasMissing, - isNumeric, - mkRandom, - toList, - toVector, - ) -import DataFrame.Internal.DataFrame as Dataframe ( + Columnable, + Columnable', DataFrame, + Expr, GroupedDataFrame, + NamedExpr, + Row, TruncateConfig (..), columnNames, defaultTruncateConfig, + eSize, empty, + fromAny, + fromList, fromNamedColumns, + fromUnboxedVector, + fromVector, + hasElemType, + hasMissing, insertColumn, + isNumeric, + mkRandom, null, + prettyPrint, + prettyPrintWidth, + rowValue, + toAny, toCsv, toCsv', + toList, toMarkdown, toMarkdown', - toSeparated, - ) -import DataFrame.Internal.Expression as Expression (Expr, prettyPrint) -import DataFrame.Internal.Row as Row ( - Any, - Row, - fromAny, - rowValue, - toAny, toRowList, toRowVector, + toSeparated, + toVector, ) -import DataFrame.Internal.Schema as Schema ( +import DataFrame.Schema as Schema ( + SchemaType (..), makeSchema, schemaType, ) #ifdef WITH_TH -import DataFrame.Internal.Schema.TH as SchemaTH (deriveSchema) +import DataFrame.Typed.TH.Records as SchemaTH (deriveSchemaFromType, deriveSchemaValues) #endif #ifdef WITH_LAZY --- Re-export the lazy query engine's entry points. Only types and source --- constructors are surfaced; the operator surface (filter/select/derive/...) --- collides with the eager API already re-exported above, so users wanting --- full lazy access should `import qualified DataFrame.Lazy as L`. +-- Re-export only the lazy engine's types and source constructors; its +-- operator surface (filter/select/derive/...) collides with the eager API, +-- so users wanting full lazy access `import qualified DataFrame.Lazy as L`. import DataFrame.Lazy as Lazy ( LazyDataFrame, fromDataFrame, @@ -375,11 +191,7 @@ distinct, groupBy, ) -import DataFrame.Operations.Core as Core hiding ( - ColumnInfo (..), - nulls, - renameSafe, - ) +import DataFrame.Operations.Core as Core import DataFrame.Operations.Join as Join ( JoinType (..), fullOuterJoin, @@ -442,6 +254,7 @@ sample, select, selectBy, + selectRows, stratifiedSample, stratifiedSplit, take, diff --git a/src/DataFrame/Typed.hs b/src/DataFrame/Typed.hs --- a/src/DataFrame/Typed.hs +++ b/src/DataFrame/Typed.hs @@ -104,6 +104,7 @@ -- * Aggregation expression combinators DataFrame.Typed.Expr.sum, mean, + median, count, countAll, DataFrame.Typed.Expr.minimum, @@ -111,6 +112,42 @@ collect, over, + -- * Expression combinators (full DataFrame.Functions parity) + DataFrame.Typed.Expr.div, + DataFrame.Typed.Expr.mod, + mode, + sumMaybe, + DataFrame.Typed.Expr.meanMaybe, + DataFrame.Typed.Expr.variance, + DataFrame.Typed.Expr.medianMaybe, + DataFrame.Typed.Expr.percentile, + stddev, + stddevMaybe, + zScore, + pow, + relu, + DataFrame.Typed.Expr.min, + DataFrame.Typed.Expr.max, + reduce, + toMaybe, + fromMaybe, + isJust, + isNothing, + fromJust, + whenPresent, + whenBothPresent, + recode, + recodeWithCondition, + recodeWithDefault, + firstOrNothing, + lastOrNothing, + splitOn, + match, + matchAll, + parseDate, + daysBetween, + bind, + -- * Cast / coercion expressions castExpr, castExprWithDefault, @@ -132,6 +169,13 @@ -- * Typed column access columnAsVector, columnAsList, + columnAsIntVector, + columnAsDoubleVector, + columnAsFloatVector, + columnAsUnboxedVector, + toDoubleMatrix, + toFloatMatrix, + toIntMatrix, -- * Schema-preserving operations filterWhere, @@ -140,6 +184,7 @@ filterAllJust, filterJust, filterNothing, + filterAllNothing, sortBy, take, takeLast, @@ -192,6 +237,29 @@ aggregate, aggregateUntyped, + -- * Column transformations + applyColumn, + applyMany, + applyWhere, + applyAtIndex, + safeApply, + deriveWithExpr, + insertWithDefault, + insertVectorWithDefault, + insertUnboxedVector, + (|||), + + -- * Sampling and splitting + randomSplit, + kFolds, + selectRows, + stratifiedSample, + stratifiedSplit, + + -- * Frequencies + valueCounts, + valueProportions, + #ifdef WITH_TH -- * Template Haskell deriveSchema, @@ -199,6 +267,9 @@ deriveSchemaFromCsvFile, deriveSchemaFromCsvFileWith, #endif +#ifdef WITH_PARQUET_TH + deriveSchemaFromParquetFile, +#endif deriveSchemaFromType, deriveSchemaFromTypeWith, SchemaOptions (..), @@ -227,6 +298,7 @@ RenameManyInSchema, RemoveColumn, Impute, + SetColumnType, Append, Reverse, StripAllMaybe, @@ -239,6 +311,10 @@ AssertAbsent, AssertAllPresent, AssertPresent, + AssertDisjoint, + AssertRealColumn, + AllColumnsReal, + IsRealType, -- * Constraints KnownSchema (..), @@ -247,13 +323,42 @@ import Prelude hiding (drop, filter, take) -import DataFrame.Typed.Access (columnAsList, columnAsVector) +import DataFrame.Typed.Access ( + columnAsDoubleVector, + columnAsFloatVector, + columnAsIntVector, + columnAsList, + columnAsUnboxedVector, + columnAsVector, + toDoubleMatrix, + toFloatMatrix, + toIntMatrix, + ) import DataFrame.Typed.Aggregate ( aggregate, aggregateUntyped, as, groupBy, ) +import DataFrame.Typed.Apply ( + applyAtIndex, + applyColumn, + applyMany, + applyWhere, + deriveWithExpr, + insertUnboxedVector, + insertVectorWithDefault, + insertWithDefault, + safeApply, + (|||), + ) +import DataFrame.Typed.Sampling ( + kFolds, + randomSplit, + selectRows, + stratifiedSample, + stratifiedSplit, + ) import DataFrame.Typed.Expr import DataFrame.Typed.Freeze (freeze, freezeWithError, thaw, unsafeFreeze) import DataFrame.Typed.Generic ( @@ -279,6 +384,9 @@ #ifdef WITH_CSV_TH deriveSchemaFromCsvFile, deriveSchemaFromCsvFileWith, +#endif +#ifdef WITH_PARQUET_TH + deriveSchemaFromParquetFile, #endif deriveSchemaFromType, deriveSchemaFromTypeWith, diff --git a/src/DataFrame/Typed/TH.hs b/src/DataFrame/Typed/TH.hs --- a/src/DataFrame/Typed/TH.hs +++ b/src/DataFrame/Typed/TH.hs @@ -19,9 +19,15 @@ #ifdef WITH_CSV_TH module DataFrame.Typed.TH.CSV, #endif +#ifdef WITH_PARQUET_TH + module DataFrame.Typed.TH.Parquet, +#endif ) where import DataFrame.Typed.TH.Records #ifdef WITH_CSV_TH import DataFrame.Typed.TH.CSV +#endif +#ifdef WITH_PARQUET_TH +import DataFrame.Typed.TH.Parquet #endif diff --git a/tests/Cart.hs b/tests/Cart.hs deleted file mode 100644 --- a/tests/Cart.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -{- | Agreement tests: the Haskell 'buildCartTree' must predict identically to -sklearn @DecisionTreeClassifier(random_state=0, max_depth=4)@ on the shared -folds. The oracle is golden fixtures (per-row test predictions) generated by -@bench/export_cart_fixtures.py@ in a sklearn env. wine/bcw (continuous) assert -exact equality; adult (one-hot, RNG-tie-prone) only reports a match fraction. - -Tests SKIP (pass with a notice) when a fixture is absent, so the suite stays -green until the fixtures are generated. --} -module Cart (tests) where - -import Control.Exception (SomeException, try) -import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.:)) -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Vector as V -import Test.HUnit - -import qualified DataFrame as D -import DataFrame.DecisionTree ( - TreeConfig (..), - buildCartTree, - defaultTreeConfig, - predictManyWithTree, - ) -import qualified DataFrame.Operations.Subset as DSub - -data Fold = Fold ![Int] ![Int] -instance FromJSON Fold where - parseJSON = withObject "fold" $ \o -> Fold <$> o .: "train" <*> o .: "test" - -newtype Folds = Folds [Fold] -instance FromJSON Folds where - parseJSON = withObject "folds" $ \o -> Folds <$> o .: "folds" - -data Fixture = Fixture ![Int] ![T.Text] -instance FromJSON Fixture where - parseJSON = withObject "fixture" $ \o -> Fixture <$> o .: "test_index" <*> o .: "test_pred" - --- sklearn cart_d4 params: max_depth 4, min_samples_leaf 1 (min_samples_split is --- fixed at 2 inside buildCartTree). -cartCfg :: TreeConfig -cartCfg = defaultTreeConfig{maxTreeDepth = 4, minLeafSize = 1} - -cartCases :: [(String, Int)] -cartCases = - [("wine", i) | i <- [0 .. 4]] ++ [("bcw", i) | i <- [0 .. 4]] ++ [("adult", 0)] - -tests :: [Test] -tests = - [ TestLabel ("cart: " ++ n ++ " fold " ++ show i) (TestCase (runCase n i)) - | (n, i) <- cartCases - ] - -readJson :: (FromJSON a) => FilePath -> IO (Either String a) -readJson fp = do - e <- try (BL.readFile fp) :: IO (Either SomeException BL.ByteString) - pure $ case e of - Left _ -> Left "missing" - Right raw -> eitherDecode raw - -runCase :: String -> Int -> IO () -runCase name i = do - efx <- readJson ("tests/fixtures/cart/" ++ name ++ "_fold" ++ show i ++ ".json") - case efx of - Left "missing" -> - putStrLn - ( " [skip] cart " - ++ name - ++ " fold " - ++ show i - ++ ": fixture missing (run bench/export_cart_fixtures.py)" - ) - Left e -> assertFailure ("fixture parse (" ++ name ++ "): " ++ e) - Right (Fixture _ predExpected) -> do - efolds <- readJson ("data/folds/" ++ name ++ ".json") - case efolds of - Left e -> assertFailure ("folds parse (" ++ name ++ "): " ++ e) - Right (Folds fs) -> do - df <- D.readCsv ("data/uci/" ++ name ++ "_clean.csv") - let Fold trainIdx testIdx = fs !! i - trainDf = DSub.selectRows trainIdx df - tree = buildCartTree @Int cartCfg "target" trainDf - preds = - map - (T.pack . show) - (V.toList (predictManyWithTree tree df (V.fromList testIdx))) - -- wine is tie-free ⇒ sklearn is deterministic ⇒ exact match is the bar. - -- bcw/adult have equal-gain ties that sklearn breaks with a seeded per-node - -- feature permutation (verified: 4/5 bcw folds change with random_state); our - -- builder breaks ties deterministically by feature order and is gain-optimal - -- (verified bit-identical to an independent deterministic-CART reference), so - -- we only report the match fraction there rather than chase sklearn's RNG. - if name == "wine" - then assertEqual ("cart " ++ name ++ " fold " ++ show i) predExpected preds - else do - let n = length predExpected - m = length (filter id (zipWith (==) predExpected preds)) - putStrLn - ( " [diagnostic] cart " - ++ name - ++ " fold " - ++ show i - ++ ": " - ++ show m - ++ "/" - ++ show n - ++ " predictions match sklearn(random_state=0) (remainder = sklearn's seeded equal-gain tie-break)" - ) diff --git a/tests/DecisionTree.hs b/tests/DecisionTree.hs deleted file mode 100644 --- a/tests/DecisionTree.hs +++ /dev/null @@ -1,1384 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module DecisionTree where - -import qualified DataFrame as D -import DataFrame.DecisionTree -import qualified DataFrame.Functions as F -import qualified DataFrame.Internal.Column as DI -import DataFrame.Internal.Expression (Expr (..), eqExpr, getColumns) -import DataFrame.Internal.Interpreter (interpret) -import qualified DataFrame.LinearSolver -import DataFrame.Operators - -import Data.Function (on) -import Data.List (maximumBy, sort) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import Test.HUnit - ------------------------------------------------------------------------- --- Shared fixtures ------------------------------------------------------------------------- - -{- | Build a 'TargetInfo' or fail loudly; the test fixtures always satisfy -'mkTargetInfo', so a 'Nothing' here is a broken test, not a runtime case. --} -requireTargetInfo :: T.Text -> D.DataFrame -> TargetInfo T.Text -requireTargetInfo target df = case mkTargetInfo @T.Text target df of - Just ti -> ti - Nothing -> error ("requireTargetInfo: no target info for " <> T.unpack target) - --- 4 rows: label = ["A","B","A","C"], x = [1.0,2.0,3.0,4.0] -fixtureDF :: D.DataFrame -fixtureDF = - D.fromNamedColumns - [ ("label", DI.fromList (["A", "B", "A", "C"] :: [T.Text])) - , ("x", DI.fromList ([1.0, 2.0, 3.0, 4.0] :: [Double])) - ] - -allIndices :: V.Vector Int -allIndices = V.fromList [0, 1, 2, 3] - -leftTree :: Tree T.Text -leftTree = Leaf "A" - -rightTree :: Tree T.Text -rightTree = Leaf "B" - --- x <= 2.5: True for idx 0,1 (→ left); False for idx 2,3 (→ right) -splitCond :: Expr Bool -splitCond = F.col @Double "x" .<= F.lit (2.5 :: Double) - --- Pre-computed care points for the full fixture -carePoints3 :: [CarePoint] -carePoints3 = - identifyCarePoints @T.Text "label" fixtureDF allIndices leftTree rightTree - ------------------------------------------------------------------------- --- Unit tests: identifyCarePoints ------------------------------------------------------------------------- - -carePointsBothWrong :: Test -carePointsBothWrong = - TestCase $ - assertBool - "idx 3 (label=C, neither A nor B) should not be a care point" - (3 `notElem` map cpIndex carePoints3) - -carePointsLeftCorrect :: Test -carePointsLeftCorrect = TestCase $ do - let cp0 = filter ((== 0) . cpIndex) carePoints3 - assertBool "idx 0 should be a care point" (not (null cp0)) - assertEqual - "idx 0 (label=A matches left Leaf A) should route GoLeft" - GoLeft - (cpCorrectDir (head cp0)) - -carePointsRightCorrect :: Test -carePointsRightCorrect = TestCase $ do - let cp1 = filter ((== 1) . cpIndex) carePoints3 - assertBool "idx 1 should be a care point" (not (null cp1)) - assertEqual - "idx 1 (label=B matches right Leaf B) should route GoRight" - GoRight - (cpCorrectDir (head cp1)) - -carePointsMixed :: Test -carePointsMixed = TestCase $ do - assertEqual "exactly 3 care points" 3 (length carePoints3) - let idxs = map cpIndex carePoints3 - assertBool "idx 0 present" (0 `elem` idxs) - assertBool "idx 1 present" (1 `elem` idxs) - assertBool "idx 2 present" (2 `elem` idxs) - assertBool "idx 3 absent" (3 `notElem` idxs) - -carePointsBothCorrect :: Test -carePointsBothCorrect = TestCase $ do - let df2 = - D.fromNamedColumns - [ ("label", DI.fromList (["A", "A"] :: [T.Text])) - , ("x", DI.fromList ([1.0, 2.0] :: [Double])) - ] - cps = - identifyCarePoints @T.Text - "label" - df2 - (V.fromList [0, 1]) - (Leaf "A") - (Leaf "A") - assertEqual "no care points when both subtrees agree" 0 (length cps) - ------------------------------------------------------------------------- --- Unit tests: majorityValueFromIndices ------------------------------------------------------------------------- - -majorityVoteTest :: Test -majorityVoteTest = TestCase $ do - let df = - D.fromNamedColumns - [ ("label", DI.fromList (["cat", "dog", "cat", "cat"] :: [T.Text])) - , ("x", DI.fromList ([1.0, 2.0, 3.0, 4.0] :: [Double])) - ] - assertEqual - "majority is cat (3 votes)" - "cat" - (majorityValueFromIndices @T.Text "label" df (V.fromList [0, 1, 2, 3])) - -majorityVoteSubset :: Test -majorityVoteSubset = TestCase $ do - let df = - D.fromNamedColumns - [ ("label", DI.fromList (["cat", "dog", "cat", "cat"] :: [T.Text])) - , ("x", DI.fromList ([1.0, 2.0, 3.0, 4.0] :: [Double])) - ] - -- indices [0,1,3]: cat×2, dog×1 → "cat" wins clearly - result = majorityValueFromIndices @T.Text "label" df (V.fromList [0, 1, 3]) - assertEqual "majority from subset [0,1,3] is cat" "cat" result - ------------------------------------------------------------------------- --- Unit tests: computeTreeLoss ------------------------------------------------------------------------- - -computeLossZero :: Test -computeLossZero = TestCase $ do - -- target = ["A","A","B","B"]: perfect split on x <= 2.5 - let df = - D.fromNamedColumns - [ ("label", DI.fromList (["A", "A", "B", "B"] :: [T.Text])) - , ("x", DI.fromList ([1.0, 2.0, 3.0, 4.0] :: [Double])) - ] - stump = Branch splitCond (Leaf "A") (Leaf "B") :: Tree T.Text - loss = computeTreeLoss @T.Text "label" df (V.fromList [0, 1, 2, 3]) stump - assertEqual "perfect stump has zero loss" 0.0 loss - -computeLossHalf :: Test -computeLossHalf = TestCase $ do - let df = - D.fromNamedColumns - [ ("label", DI.fromList (["A", "A", "B", "B"] :: [T.Text])) - , ("x", DI.fromList ([1.0, 2.0, 3.0, 4.0] :: [Double])) - ] - constTree = Leaf "A" :: Tree T.Text - loss = computeTreeLoss @T.Text "label" df (V.fromList [0, 1, 2, 3]) constTree - assertEqual "constant leaf misclassifies half of balanced data" 0.5 loss - ------------------------------------------------------------------------- --- Unit tests: partitionIndices ------------------------------------------------------------------------- - -partitionDisjoint :: Test -partitionDisjoint = TestCase $ do - let (lft, rgt) = partitionIndices splitCond fixtureDF allIndices - leftSet = V.toList lft - rightSet = V.toList rgt - intersection = filter (`elem` rightSet) leftSet - assertEqual "left and right partitions are disjoint" [] intersection - -partitionUnion :: Test -partitionUnion = TestCase $ do - let (lft, rgt) = partitionIndices splitCond fixtureDF allIndices - combined = sort (V.toList lft ++ V.toList rgt) - assertEqual - "union of partitions equals the original index set" - [0, 1, 2, 3] - combined - ------------------------------------------------------------------------- --- Unit tests: countCarePointErrors ------------------------------------------------------------------------- - -countErrorsAllCorrect :: Test -countErrorsAllCorrect = TestCase $ do - -- x <= 1.5: idx 0 goes left (True), idx 1 goes right (False) - -- CarePoint 0 GoLeft → goesLeft=True, shouldGoLeft=True → correct - -- CarePoint 1 GoRight → goesLeft=False, shouldGoLeft=False → correct - let cps = [CarePoint 0 GoLeft, CarePoint 1 GoRight] - cond = F.col @Double "x" .<= F.lit (1.5 :: Double) - errs = countCarePointErrors cond fixtureDF cps - assertEqual "condition routes all care points correctly" 0 errs - -countErrorsAllWrong :: Test -countErrorsAllWrong = TestCase $ do - -- x > 1.5: idx 0 goes right (False), idx 1 goes left (True) — both wrong - -- CarePoint 0 GoLeft → goesLeft=False, shouldGoLeft=True → wrong - -- CarePoint 1 GoRight → goesLeft=True, shouldGoLeft=False → wrong - let cps = [CarePoint 0 GoLeft, CarePoint 1 GoRight] - cond = F.col @Double "x" .> F.lit (1.5 :: Double) - errs = countCarePointErrors cond fixtureDF cps - assertEqual "reversed condition misroutes all care points" 2 errs - ------------------------------------------------------------------------- --- Unit tests: predictWithTree ------------------------------------------------------------------------- - -predictLeaf :: Test -predictLeaf = - TestCase $ - assertEqual - "leaf prediction ignores row index" - "Z" - (predictWithTree @T.Text "label" fixtureDF 0 (Leaf "Z")) - -predictBranch :: Test -predictBranch = TestCase $ do - let stump = Branch splitCond (Leaf "A") (Leaf "B") :: Tree T.Text - assertEqual - "idx 0 (x=1.0 <= 2.5) routes left -> A" - "A" - (predictWithTree @T.Text "label" fixtureDF 0 stump) - assertEqual - "idx 3 (x=4.0 > 2.5) routes right -> B" - "B" - (predictWithTree @T.Text "label" fixtureDF 3 stump) - ------------------------------------------------------------------------- --- Integration tests ------------------------------------------------------------------------- - --- 20-row, linearly separable: x in [1..10] -> "pos", x in [11..20] -> "neg" -sepDF :: D.DataFrame -sepDF = - let xs = map fromIntegral [1 .. 20 :: Int] :: [Double] - labels = map (\x -> if x <= 10.0 then "pos" else "neg") xs :: [T.Text] - in D.fromNamedColumns - [ ("label", DI.fromList labels) - , ("x", DI.fromList xs) - ] - --- Candidate conditions that bracket the decision boundary -sepConds :: [Expr Bool] -sepConds = - [ F.col @Double "x" .<= F.lit (10.5 :: Double) - , F.col @Double "x" .> F.lit (10.5 :: Double) - ] - -testCfg :: TreeConfig -testCfg = - defaultTreeConfig - { taoIterations = 5 - , expressionPairs = 4 - , minLeafSize = 1 - } - --- Initial tree deliberately wrong: routes "pos" rows to the "neg" leaf -wrongStump :: Tree T.Text -wrongStump = - Branch - (F.col @Double "x" .> F.lit (10.5 :: Double)) - (Leaf "pos") - (Leaf "neg") - -taoNoDegradation :: Test -taoNoDegradation = TestCase $ do - let indices = V.enumFromN 0 20 - initialLoss = computeTreeLoss @T.Text "label" sepDF indices wrongStump - optimized = - taoOptimize @T.Text testCfg "label" sepConds sepDF indices wrongStump - finalLoss = computeTreeLoss @T.Text "label" sepDF indices optimized - assertBool - "taoOptimize must not increase loss" - (finalLoss <= initialLoss + 1e-9) - -taoMonotone :: Test -taoMonotone = TestCase $ do - let indices = V.enumFromN 0 20 - initLoss = computeTreeLoss @T.Text "label" sepDF indices wrongStump - stepTree = taoIteration @T.Text testCfg "label" sepConds sepDF indices - -- Track (tree, loss) pairs: take 6 snapshots (initial + 5 steps) - step (tree, _) = - let tree' = stepTree tree - in (tree', computeTreeLoss @T.Text "label" sepDF indices tree') - snapshots = take 6 $ iterate step (wrongStump, initLoss) - losses = map snd snapshots - pairs = zip losses (tail losses) - assertBool - "loss must be non-increasing across taoIteration steps" - (all (\(a, b) -> b <= a + 1e-9) pairs) - -taoConvergesPureLabels :: Test -taoConvergesPureLabels = TestCase $ do - let df = - D.fromNamedColumns - [ ("label", DI.fromList (replicate 10 ("A" :: T.Text))) - , ("x", DI.fromList ([1.0 .. 10.0] :: [Double])) - ] - indices = V.enumFromN 0 10 - initTree = Leaf "A" :: Tree T.Text - initLoss = computeTreeLoss @T.Text "label" df indices initTree - result = - taoOptimize @T.Text testCfg "label" sepConds df indices initTree - finalLoss = computeTreeLoss @T.Text "label" df indices result - assertEqual "pure-label initial loss must be zero" 0.0 initLoss - assertEqual "pure-label final loss must still be zero" 0.0 finalLoss - -taoDeadBranchNoCrash :: Test -taoDeadBranchNoCrash = TestCase $ do - -- Threshold below all x values: x <= 0.5 is False for every row - -- → all indices route to the right child; left partition is always empty - let badCond = F.col @Double "x" .<= F.lit (0.5 :: Double) - indices = V.enumFromN 0 20 - initTree = Branch badCond (Leaf "pos") (Leaf "neg") :: Tree T.Text - result = - taoOptimize @T.Text testCfg "label" [badCond] sepDF indices initTree - finalLoss = computeTreeLoss @T.Text "label" sepDF indices result - assertBool - "dead-branch tree must produce a valid loss in [0,1]" - (finalLoss >= 0.0 && finalLoss <= 1.0) - ------------------------------------------------------------------------- --- Shared fixtures: 4x4 grid ------------------------------------------------------------------------- - -gridPairs :: [(Double, Double)] -gridPairs = [(x, y) | y <- [1 .. 4], x <- [1 .. 4]] - -gridBaseDF :: D.DataFrame -gridBaseDF = - D.fromNamedColumns - [ ("x", DI.fromList (map fst gridPairs)) - , ("y", DI.fromList (map snd gridPairs)) - ] - ------------------------------------------------------------------------- --- Oblique recovery tests ------------------------------------------------------------------------- - -taoRecoversSingleObliqueDerived :: Test -taoRecoversSingleObliqueDerived = TestCase $ do - let labelExpr = - F.ifThenElse - ((F.col @Double "x" + F.col @Double "y") .<= F.lit (4.5 :: Double)) - (F.lit ("pos" :: T.Text)) - (F.lit ("neg" :: T.Text)) - df = D.derive @T.Text "label" labelExpr gridBaseDF - indices = V.enumFromN 0 16 - initTree = - Branch - (F.col @Double "x" .<= F.lit (2.5 :: Double)) - (Leaf "pos") - (Leaf "neg") :: - Tree T.Text - conds = - [ (F.col @Double "x" + F.col @Double "y") .<= F.lit (4.5 :: Double) - , (F.col @Double "x" + F.col @Double "y") .> F.lit (4.5 :: Double) - ] - cfg = defaultTreeConfig{taoIterations = 5, expressionPairs = 4, minLeafSize = 1} - result = taoOptimize @T.Text cfg "label" conds df indices initTree - finalLoss = computeTreeLoss @T.Text "label" df indices result - assertEqual - "TAO recovers single oblique (x+y) split with zero loss" - 0.0 - finalLoss - -taoRecoversNestedObliqueDerived :: Test -taoRecoversNestedObliqueDerived = TestCase $ do - let labelExpr = - F.ifThenElse - ((F.col @Double "x" + F.col @Double "y") .<= F.lit (4.5 :: Double)) - (F.lit ("low" :: T.Text)) - ( F.ifThenElse - ((F.col @Double "x" - F.col @Double "y") .<= F.lit (0.5 :: Double)) - (F.lit "mid") - (F.lit "high") - ) - df = D.derive @T.Text "label" labelExpr gridBaseDF - indices = V.enumFromN 0 16 - initTree = - Branch - (F.col @Double "x" .<= F.lit (1.5 :: Double)) - (Leaf "low") - ( Branch - (F.col @Double "y" .<= F.lit (3.5 :: Double)) - (Leaf "mid") - (Leaf "high") - ) :: - Tree T.Text - conds = - [ (F.col @Double "x" + F.col @Double "y") .<= F.lit (4.5 :: Double) - , (F.col @Double "x" + F.col @Double "y") .> F.lit (4.5 :: Double) - , (F.col @Double "x" - F.col @Double "y") .<= F.lit (0.5 :: Double) - , (F.col @Double "x" - F.col @Double "y") .> F.lit (0.5 :: Double) - ] - cfg = defaultTreeConfig{taoIterations = 5, expressionPairs = 4, minLeafSize = 1} - result = taoOptimize @T.Text cfg "label" conds df indices initTree - finalLoss = computeTreeLoss @T.Text "label" df indices result - assertEqual - "TAO recovers nested oblique (x+y)/(x-y) tree with zero loss" - 0.0 - finalLoss - --- Shared setup for C2 (a) and (b): axis-aligned pool only, oblique label. -obliqueAxisAlignedFixture :: - (D.DataFrame, V.Vector Int, [Expr Bool], Tree T.Text) -obliqueAxisAlignedFixture = - let labelExpr = - F.ifThenElse - ((F.col @Double "x" + F.col @Double "y") .<= F.lit (4.5 :: Double)) - (F.lit ("pos" :: T.Text)) - (F.lit ("neg" :: T.Text)) - df = D.derive @T.Text "label" labelExpr gridBaseDF - indices = V.enumFromN 0 16 - axisConds = - [F.col @Double "x" .<= F.lit (t :: Double) | t <- [1.5, 2.5, 3.5]] - ++ [F.col @Double "y" .<= F.lit (t :: Double) | t <- [1.5, 2.5, 3.5]] - initTree = - Branch - (F.col @Double "x" .<= F.lit (2.5 :: Double)) - (Leaf "pos") - (Leaf "neg") :: - Tree T.Text - in (df, indices, axisConds, initTree) - --- C2 (a): with the linear solver OFF, axis-aligned pool cannot recover the --- oblique decision boundary. Preserves the original guarantee of the test. -taoAxisAlignedInsufficientForObliqueDiscreteOnly :: Test -taoAxisAlignedInsufficientForObliqueDiscreteOnly = TestCase $ do - let (df, indices, axisConds, initTree) = obliqueAxisAlignedFixture - cfg = - defaultTreeConfig - { taoIterations = 10 - , expressionPairs = 6 - , minLeafSize = 1 - , useLinearSolver = False - } - result = taoOptimize @T.Text cfg "label" axisConds df indices initTree - finalLoss = computeTreeLoss @T.Text "label" df indices result - assertBool - "axis-aligned stump cannot recover oblique label without linear solver (loss > 0.1)" - (finalLoss > 0.1) - --- C2 (b): with the linear solver ON, the L1-LR fit discovers the oblique --- (x + y) hyperplane even though only axis-aligned conditions are in the --- candidate pool. This is the test that licenses calling the implementation --- canonical TAO. -taoLinearRecoversObliqueFromAxisAlignedPool :: Test -taoLinearRecoversObliqueFromAxisAlignedPool = TestCase $ do - let (df, indices, axisConds, initTree) = obliqueAxisAlignedFixture - cfg = - defaultTreeConfig - { taoIterations = 10 - , expressionPairs = 6 - , minLeafSize = 1 - , useLinearSolver = True - , minCarePointsForLinear = 2 - } - result = taoOptimize @T.Text cfg "label" axisConds df indices initTree - finalLoss = computeTreeLoss @T.Text "label" df indices result - assertEqual - "linear solver recovers oblique split from axis-aligned-only pool" - 0.0 - finalLoss - ------------------------------------------------------------------------- --- Nullable numeric feature tests ------------------------------------------------------------------------- - --- Cleanly separable: Just 1..6 -> "pos", Just 7..12 -> "neg", no nulls. --- Uses OptionalColumn directly to exercise the new nullable numeric path. -nullableSepDF :: D.DataFrame -nullableSepDF = - D.fromNamedColumns - [ ("label", DI.fromList (replicate 6 "pos" ++ replicate 6 "neg" :: [T.Text])) - , - ( "x" - , DI.fromVector - ( V.fromList $ - map (Just . fromIntegral) ([1 .. 6] :: [Int]) - ++ map (Just . fromIntegral) ([7 .. 12] :: [Int]) :: - V.Vector (Maybe Double) - ) - ) - ] - --- DF with genuine nulls interspersed. -nullsMixedDF :: D.DataFrame -nullsMixedDF = - D.fromNamedColumns - [ ("label", DI.fromList (["pos", "pos", "pos", "neg", "neg", "neg"] :: [T.Text])) - , - ( "x" - , DI.fromVector - ( V.fromList - [Just 1.0, Nothing, Just 3.0, Just 7.0, Nothing, Just 9.0] :: - V.Vector (Maybe Double) - ) - ) - ] - --- numericCols picks up DI.fromVector (Maybe Double) as NMaybeDouble. -numericColsNullableDoubleTest :: Test -numericColsNullableDoubleTest = TestCase $ do - let exprs = numericCols nullableSepDF - hasMD = any (\case NMaybeDouble _ -> True; _ -> False) exprs - assertBool - "numericCols finds NMaybeDouble for DI.fromVector (Maybe Double)" - hasMD - --- numericCols picks up DI.fromVector (Maybe Int) as NMaybeDouble (via whenPresent). -numericColsNullableIntTest :: Test -numericColsNullableIntTest = TestCase $ do - let df = - D.fromNamedColumns - [ ("label", DI.fromList (["pos", "neg"] :: [T.Text])) - , - ( "n" - , DI.fromVector (V.fromList [Just (1 :: Int), Just 2] :: V.Vector (Maybe Int)) - ) - ] - hasMD = any (\case NMaybeDouble _ -> True; _ -> False) (numericCols df) - assertBool "numericCols finds NMaybeDouble for DI.fromVector (Maybe Int)" hasMD - --- generateNumericConds is non-empty for a DF with an DI.fromVector (Maybe Double). -numericCondsNullableNonEmptyTest :: Test -numericCondsNullableNonEmptyTest = - TestCase $ - assertBool - "generateNumericConds non-empty for DI.fromVector (Maybe Double)" - (not (null (generateNumericConds defaultTreeConfig nullableSepDF))) - --- Null values evaluate to False for threshold conditions (null rows route right). -nullValueRoutesFalseTest :: Test -nullValueRoutesFalseTest = TestCase $ do - let df = - D.fromNamedColumns - [ ("label", DI.fromList (["A", "B"] :: [T.Text])) - , - ( "x" - , DI.fromVector - (V.fromList [Nothing, Just (5.0 :: Double)] :: V.Vector (Maybe Double)) - ) - ] - -- Nothing <= 6.0 = Nothing -> fromMaybe False = False -> right - -- Just 5.0 <= 6.0 = Just True -> fromMaybe False = True -> left - cond = F.fromMaybe False (F.col @(Maybe Double) "x" .<= F.lit (6.0 :: Double)) - (lft, rgt) = partitionIndices cond df (V.fromList [0, 1]) - assertBool "null row (idx 0) routes to right (false) partition" (0 `V.elem` rgt) - assertBool "Just 5.0 <= 6.0 routes to left (true) partition" (1 `V.elem` lft) - --- fitDecisionTree with an OptionalColumn nullable feature achieves zero loss --- on cleanly separable data (no actual nulls in the column). -nullableFitZeroLossTest :: Test -nullableFitZeroLossTest = TestCase $ do - let cfg = defaultTreeConfig{taoIterations = 5, expressionPairs = 4, minLeafSize = 1} - featureDf = D.exclude ["label"] nullableSepDF - conds = generateNumericConds cfg featureDf - initTree = buildCartTree @T.Text cfg "label" nullableSepDF - indices = V.enumFromN 0 12 - result = taoOptimize @T.Text cfg "label" conds nullableSepDF indices initTree - loss = computeTreeLoss @T.Text "label" nullableSepDF indices result - assertEqual "zero loss on cleanly separable OptionalColumn data" 0.0 loss - --- fitDecisionTree with genuine nulls: loss is a valid probability and no crash. -nullableFitWithNullsNoCrashTest :: Test -nullableFitWithNullsNoCrashTest = TestCase $ do - let cfg = defaultTreeConfig{taoIterations = 3, expressionPairs = 4, minLeafSize = 1} - featureDf = D.exclude ["label"] nullsMixedDF - conds = generateNumericConds cfg featureDf - initTree = buildCartTree @T.Text cfg "label" nullsMixedDF - indices = V.enumFromN 0 6 - result = taoOptimize @T.Text cfg "label" conds nullsMixedDF indices initTree - loss = computeTreeLoss @T.Text "label" nullsMixedDF indices result - assertBool - "loss is in [0,1] with null values present" - (loss >= 0.0 && loss <= 1.0) - --- numericExprsWithTerms produces cross-column combinations when one col is --- DI.fromVector (Maybe Double) and another is a plain UnboxedColumn Double. -numericExprsWithTermsMixedTest :: Test -numericExprsWithTermsMixedTest = TestCase $ do - let df = - D.fromNamedColumns - [ - ( "x" - , DI.fromVector - (V.fromList [Just 1.0, Just 2.0, Just 3.0] :: V.Vector (Maybe Double)) - ) - , ("y", DI.fromList ([4.0, 5.0, 6.0] :: [Double])) - ] - cfg = defaultSynthConfig{maxExprDepth = 2, enableArithOps = True} - exprs = numericExprsWithTerms cfg df - assertBool - "more than 2 expressions: base cols + combinations" - (length exprs > 2) - assertBool - "combined exprs include NMaybeDouble (nullable arithmetic)" - (any (\case NMaybeDouble _ -> True; _ -> False) exprs) - ------------------------------------------------------------------------- --- Probability tree tests ------------------------------------------------------------------------- - --- probsFromIndices: counts correct on a 3-row slice -probsFromIndicesBasic :: Test -probsFromIndicesBasic = TestCase $ do - let df = - D.fromNamedColumns - [ ("label", DI.fromList (["A", "A", "B"] :: [T.Text])) - , ("x", DI.fromList ([1.0, 2.0, 3.0] :: [Double])) - ] - probs = probsFromIndices @T.Text "label" df (V.fromList [0, 1, 2]) - assertBool "A prob ≈ 2/3" (abs (probs M.! "A" - 2 / 3) < 1e-9) - assertBool "B prob ≈ 1/3" (abs (probs M.! "B" - 1 / 3) < 1e-9) - --- probsFromIndices: only a subset of rows counted -probsFromIndicesSubset :: Test -probsFromIndicesSubset = TestCase $ do - let df = - D.fromNamedColumns - [ ("label", DI.fromList (["A", "A", "B", "B"] :: [T.Text])) - , ("x", DI.fromList ([1.0, 2.0, 3.0, 4.0] :: [Double])) - ] - probs = probsFromIndices @T.Text "label" df (V.fromList [0, 1]) - assertEqual "only rows 0,1 → A:1.0" (M.fromList [("A", 1.0)]) probs - --- probsFromIndices: single class → probability 1.0 -probsFromIndicesSingleClass :: Test -probsFromIndicesSingleClass = TestCase $ do - let probs = probsFromIndices @T.Text "label" fixtureDF (V.fromList [0, 2]) - assertEqual "rows 0,2 both A → A:1.0" (M.fromList [("A", 1.0)]) probs - --- buildProbTree: Leaf preserves distribution -buildProbTreeLeaf :: Test -buildProbTreeLeaf = TestCase $ do - let df = - D.fromNamedColumns - [ ("label", DI.fromList (["A", "A", "A"] :: [T.Text])) - , ("x", DI.fromList ([1.0, 2.0, 3.0] :: [Double])) - ] - pt = buildProbTree @T.Text (Leaf "A") "label" df (V.fromList [0, 1, 2]) - case pt of - Leaf m -> assertEqual "pure-A leaf → {A:1.0}" (M.fromList [("A", 1.0)]) m - _ -> assertFailure "expected Leaf" - --- buildProbTree: Branch distributes rows to left/right leaves correctly -buildProbTreeBranch :: Test -buildProbTreeBranch = TestCase $ do - -- splitCond: x <= 2.5 → idx 0,1 go left; idx 2,3 go right - -- left (idx 0,1): labels ["A","B"] → {A:0.5, B:0.5} - -- right (idx 2,3): labels ["A","C"] → {A:0.5, C:0.5} - let stump = Branch splitCond (Leaf "A") (Leaf "B") :: Tree T.Text - pt = buildProbTree @T.Text stump "label" fixtureDF allIndices - case pt of - Branch _ (Leaf lm) (Leaf rm) -> do - assertBool "left leaf has A:0.5" (abs (M.findWithDefault 0 "A" lm - 0.5) < 1e-9) - assertBool "left leaf has B:0.5" (abs (M.findWithDefault 0 "B" lm - 0.5) < 1e-9) - assertBool - "right leaf has A:0.5" - (abs (M.findWithDefault 0 "A" rm - 0.5) < 1e-9) - assertBool - "right leaf has C:0.5" - (abs (M.findWithDefault 0 "C" rm - 0.5) < 1e-9) - _ -> assertFailure "expected Branch with two Leaves" - --- probExprs: leaf tree produces Lit values -probExprsLeaf :: Test -probExprsLeaf = TestCase $ do - let pt = Leaf (M.fromList [("A", 0.75), ("B", 0.25)]) :: ProbTree T.Text - pe = probExprs pt - assertBool "A expr is Lit 0.75" (eqExpr (Lit 0.75) (pe M.! "A")) - assertBool "B expr is Lit 0.25" (eqExpr (Lit 0.25) (pe M.! "B")) - --- probExprs: class absent from one leaf gets Lit 0.0 on that side -probExprsMissingClass :: Test -probExprsMissingClass = TestCase $ do - let pt = - Branch - splitCond - (Leaf (M.fromList [("A", 1.0)])) - (Leaf (M.fromList [("B", 1.0)])) :: - ProbTree T.Text - pe = probExprs pt - assertBool - "A expr: If cond (Lit 1.0) (Lit 0.0)" - (eqExpr (F.ifThenElse splitCond (Lit 1.0) (Lit 0.0)) (pe M.! "A")) - assertBool - "B expr: If cond (Lit 0.0) (Lit 1.0)" - (eqExpr (F.ifThenElse splitCond (Lit 0.0) (Lit 1.0)) (pe M.! "B")) - --- probExprs: keys equal all classes that appear across any leaf -probExprsAllClasses :: Test -probExprsAllClasses = TestCase $ do - let pt = - Branch - splitCond - (Leaf (M.fromList [("A", 1.0)])) - (Leaf (M.fromList [("B", 0.6), ("C", 0.4)])) :: - ProbTree T.Text - pe = probExprs pt - assertEqual "three classes in result" (sort ["A", "B", "C"]) (sort (M.keys pe)) - --- Probabilities sum to 1.0 at every row after applying probExprs -probsSumToOne :: Test -probsSumToOne = TestCase $ do - let stump = Branch splitCond (Leaf "A") (Leaf "B") :: Tree T.Text - pt = buildProbTree @T.Text stump "label" fixtureDF allIndices - pe = probExprs pt - sumExpr = foldl1 (.+) (M.elems pe) - case interpret @Double fixtureDF sumExpr of - Left e -> assertFailure (show e) - Right (DI.TColumn sumCol) -> - case DI.toVector @Double sumCol of - Left e2 -> assertFailure (show e2) - Right vals -> - mapM_ - (\v -> assertBool ("sum ≈ 1.0, got " ++ show v) (abs (v - 1.0) < 1e-9)) - (V.toList vals) - --- argmax of probExprs agrees with fitDecisionTree on sepDF -probArgmaxMatchesClassifier :: Test -probArgmaxMatchesClassifier = TestCase $ do - let cfg = defaultTreeConfig{taoIterations = 5, expressionPairs = 4, minLeafSize = 1} - hardExpr = fitDecisionTree @T.Text cfg (Col "label") sepDF - pe = fitProbTree @T.Text cfg (Col "label") sepDF - indices = [0 .. D.nRows sepDF - 1] - case interpret @T.Text sepDF hardExpr of - Left e -> assertFailure (show e) - Right (DI.TColumn hardCol) -> - case DI.toVector @T.Text hardCol of - Left e2 -> assertFailure (show e2) - Right hardVals -> do - probCols <- - mapM - ( \(cls, expr) -> case interpret @Double sepDF expr of - Left e3 -> assertFailure (show e3) >> return (cls, V.empty) - Right (DI.TColumn col2) -> case DI.toVector @Double col2 of - Left e4 -> assertFailure (show e4) >> return (cls, V.empty) - Right v -> return (cls, v) - ) - (M.toList pe) - mapM_ - ( \i -> - let argmax = fst $ maximumBy (compare `on` (V.! i) . snd) probCols - hard = hardVals V.! i - in assertEqual ("row " ++ show i) hard argmax - ) - indices - ------------------------------------------------------------------------- --- C4-C9 / D-series: linear solver integration tests ------------------------------------------------------------------------- - --- C4: Nested oblique recovery without supplying any oblique hints. --- The label is determined by two oblique boundaries: (x+y <= 4.5) and --- (x-y <= 0.5). Only axis-aligned thresholds are in the candidate pool. --- With the linear solver, both oblique splits should be learned and the --- tree should reach zero loss. -taoRecoversNestedObliqueWithoutHint :: Test -taoRecoversNestedObliqueWithoutHint = TestCase $ do - let labelExpr = - F.ifThenElse - ((F.col @Double "x" + F.col @Double "y") .<= F.lit (4.5 :: Double)) - (F.lit ("low" :: T.Text)) - ( F.ifThenElse - ((F.col @Double "x" - F.col @Double "y") .<= F.lit (0.5 :: Double)) - (F.lit "mid") - (F.lit "high") - ) - df = D.derive @T.Text "label" labelExpr gridBaseDF - indices = V.enumFromN 0 16 - initTree = - Branch - (F.col @Double "x" .<= F.lit (1.5 :: Double)) - (Leaf "low") - ( Branch - (F.col @Double "y" .<= F.lit (3.5 :: Double)) - (Leaf "mid") - (Leaf "high") - ) :: - Tree T.Text - axisOnlyConds = - [F.col @Double "x" .<= F.lit (t :: Double) | t <- [1.5, 2.5, 3.5]] - ++ [F.col @Double "y" .<= F.lit (t :: Double) | t <- [1.5, 2.5, 3.5]] - cfg = - defaultTreeConfig - { taoIterations = 20 - , expressionPairs = 6 - , minLeafSize = 1 - , useLinearSolver = True - , minCarePointsForLinear = 2 - } - result = taoOptimize @T.Text cfg "label" axisOnlyConds df indices initTree - finalLoss = computeTreeLoss @T.Text "label" df indices result - assertEqual - "linear solver recovers nested oblique tree from axis-aligned-only pool" - 0.0 - finalLoss - --- C5: Monotone loss across iterations with the linear solver enabled. --- Resolves Issue 1 from the prior plan (currentCond included in the --- competition pool). -taoMonotoneWithLinear :: Test -taoMonotoneWithLinear = TestCase $ do - let indices = V.enumFromN 0 20 - cfg = defaultTreeConfig{taoIterations = 5, expressionPairs = 4, minLeafSize = 1} - initLoss = computeTreeLoss @T.Text "label" sepDF indices wrongStump - stepTree = taoIteration @T.Text cfg "label" sepConds sepDF indices - step (tree, _) = - let tree' = stepTree tree - in (tree', computeTreeLoss @T.Text "label" sepDF indices tree') - snapshots = take 6 $ iterate step (wrongStump, initLoss) - losses = map snd snapshots - pairs = zip losses (tail losses) - assertBool - ("loss must be non-increasing across iterations (got " ++ show losses ++ ")") - (all (\(a, b) -> b <= a + 1e-9) pairs) - --- C6: When the discrete pool contains an exact-zero-error split (axis-aligned --- works perfectly), the competition picks the simpler discrete candidate --- rather than a similarly-good but more complex linear one. -taoLinearVsDiscreteCompetition :: Test -taoLinearVsDiscreteCompetition = TestCase $ do - -- sepDF is axis-aligned-separable by x <= 10.5. The discrete pool - -- sepConds contains this exact condition. Linear solver may also - -- produce a hyperplane that works, but the discrete one has smaller - -- eSize, so the tie-breaker should pick it. - let indices = V.enumFromN 0 20 - cfg = - defaultTreeConfig - { taoIterations = 5 - , expressionPairs = 4 - , minLeafSize = 1 - , useLinearSolver = True - , minCarePointsForLinear = 2 - } - result = taoOptimize @T.Text cfg "label" sepConds sepDF indices wrongStump - finalLoss = computeTreeLoss @T.Text "label" sepDF indices result - assertEqual - "axis-aligned separable data should fit to zero loss" - 0.0 - finalLoss - --- C8: Linear solver respects the L1 penalty and produces sparse hyperplanes --- on data where only some features are informative. -taoLinearProducesSparsity :: Test -taoLinearProducesSparsity = TestCase $ do - -- 50 rows, 4 features. label depends only on (a + b). c and d are noise. - -- With sufficient L1 strength, the chosen split should mention only a and b. - let n = 50 :: Int - xs = [fromIntegral i / 10 - 2.5 :: Double | i <- [0 .. n - 1]] - avals = xs - bs = map (* 0.7) xs - -- noise: take xs and shift them so they don't correlate with a+b - cs = [fromIntegral ((i * 7) `mod` 11) / 5 - 1 :: Double | i <- [0 .. n - 1]] - ds = [fromIntegral ((i * 13) `mod` 7) / 3 - 1 :: Double | i <- [0 .. n - 1]] - labels = - [ if (avals !! i) + (bs !! i) > 0 then "pos" else "neg" :: T.Text - | i <- [0 .. n - 1] - ] - df = - D.fromNamedColumns - [ ("label", DI.fromList labels) - , ("a", DI.fromList avals) - , ("b", DI.fromList bs) - , ("c", DI.fromList cs) - , ("d", DI.fromList ds) - ] - cfg = - defaultTreeConfig - { maxTreeDepth = 1 - , taoIterations = 10 - , minLeafSize = 1 - , useLinearSolver = True - , minCarePointsForLinear = 2 - , linearSolverConfig = - (linearSolverConfig defaultTreeConfig) - { DataFrame.LinearSolver.scL1Lambda = 0.05 - } - } - result = fitDecisionTree @T.Text cfg (Col "label") df - rootCols = getColumns result - -- Hard fail only if NONE of a/b show up — that would mean the model - -- is ignoring the signal. We expect at most 4 columns; the H3 target - -- is that fewer than 4 (some noise columns dropped) -- but the test - -- only asserts the signal columns appear. - assertBool - ( "informative columns 'a' or 'b' must appear in the fitted Expr (got " - ++ show rootCols - ++ ")" - ) - ("a" `elem` rootCols || "b" `elem` rootCols) - --- C9: Determinism — same training data produces an equal (eqExpr) tree. -taoLinearDeterministic :: Test -taoLinearDeterministic = TestCase $ do - let cfg = - defaultTreeConfig - { taoIterations = 5 - , expressionPairs = 4 - , minLeafSize = 1 - , useLinearSolver = True - , minCarePointsForLinear = 2 - } - r1 = fitDecisionTree @T.Text cfg (Col "label") sepDF - r2 = fitDecisionTree @T.Text cfg (Col "label") sepDF - assertBool "fitDecisionTree is deterministic on the same input" (eqExpr r1 r2) - --- D1: One care point — solver must not crash; integration should fall back --- gracefully (via minCarePointsForLinear) and rely on the discrete path. -taoLinearTinyCareSet :: Test -taoLinearTinyCareSet = TestCase $ do - -- Use the toy sepDF, but force minCarePointsForLinear = 100 so the - -- linear path is always skipped. The result should match the - -- linear-off baseline. - let cfg = - defaultTreeConfig - { taoIterations = 5 - , expressionPairs = 4 - , minLeafSize = 1 - , useLinearSolver = True - , minCarePointsForLinear = 100 - } - result = fitDecisionTree @T.Text cfg (Col "label") sepDF - -- Sanity: the tree should still classify correctly. - cfgOff = cfg{useLinearSolver = False} - resultOff = fitDecisionTree @T.Text cfgOff (Col "label") sepDF - assertBool - "skipping linear solver yields same expression as linear-off baseline" - (eqExpr result resultOff) - ------------------------------------------------------------------------- --- Categorical-condition generator tests (Phase 1-2 of the plan) ------------------------------------------------------------------------- - --- A binary-target DataFrame with a 5-level Text column whose levels have --- monotonically-increasing positive rates. Breiman's algorithm should --- enumerate the 4 contiguous-prefix splits in that exact rate order. -breimanBinaryDF :: D.DataFrame -breimanBinaryDF = - let n = 100 :: Int - -- Levels chosen so positive rates after Laplace are: - -- a: 0/n+1 / 2+n+2 → very low - -- b: 0.25 - -- c: 0.5 - -- d: 0.75 - -- e: ~1.0 - mkLabel "a" = "neg" - mkLabel "b" = "neg" - mkLabel "c" = "pos" - mkLabel "d" = "pos" - mkLabel "e" = "pos" - mkLabel _ = "neg" - levels = cycle ["a", "b", "c", "d", "e"] - feats = take n levels - labs = map mkLabel feats - in D.fromUnnamedColumns - [ DI.fromList (map T.pack feats :: [T.Text]) - , DI.fromList (map T.pack labs :: [T.Text]) - ] - |> D.rename "0" "feat" - |> D.rename "1" "label" - -testCategoricalBreimanBinary :: Test -testCategoricalBreimanBinary = TestCase $ do - let ti = requireTargetInfo "label" breimanBinaryDF - conds = - discreteConditions @T.Text - ti - defaultTreeConfig - (D.exclude ["label"] breimanBinaryDF) - feat = "feat" - -- Filter only conditions over "feat" (cross-column equality could - -- mix in if there were other categoricals; here there aren't). - feats = filter (\c -> feat `elem` getColumns c) conds - -- 5 levels → 4 prefixes - assertEqual "Breiman emits k-1 prefixes" 4 (length feats) - -testCategoricalSubsetsMulticlassLowCard :: Test -testCategoricalSubsetsMulticlassLowCard = TestCase $ do - -- 3-class target, 3-level Text column. Subset enumeration: 2^3 - 2 = 6. - let n = 30 :: Int - feats = take n (cycle ["x", "y", "z"]) - labs = take n (cycle ["A", "B", "C"]) - df = - D.fromUnnamedColumns - [ DI.fromList (map T.pack feats :: [T.Text]) - , DI.fromList (map T.pack labs :: [T.Text]) - ] - |> D.rename "0" "feat" - |> D.rename "1" "label" - ti = requireTargetInfo "label" df - conds = discreteConditions @T.Text ti defaultTreeConfig (D.exclude ["label"] df) - feat = "feat" - feats' = filter (\c -> feat `elem` getColumns c) conds - -- 3 classes → multi-class path → subsets at cap=4 → 2^3 - 2 = 6 - assertEqual "subsets at low cardinality" 6 (length feats') - -testCategoricalSingletonsMulticlassHighCard :: Test -testCategoricalSingletonsMulticlassHighCard = TestCase $ do - -- 3-class target, 6-level Text column. Above cap=4 → singletons (6). - let n = 60 :: Int - feats = take n (cycle ["a", "b", "c", "d", "e", "f"]) - labs = take n (cycle ["A", "B", "C"]) - df = - D.fromUnnamedColumns - [ DI.fromList (map T.pack feats :: [T.Text]) - , DI.fromList (map T.pack labs :: [T.Text]) - ] - |> D.rename "0" "feat" - |> D.rename "1" "label" - ti = requireTargetInfo "label" df - conds = discreteConditions @T.Text ti defaultTreeConfig (D.exclude ["label"] df) - feat = "feat" - feats' = filter (\c -> feat `elem` getColumns c) conds - -- 6 > cap=4 → singletons → 6 conditions - assertEqual "singletons at high cardinality" 6 (length feats') - -testCategoricalCardZero :: Test -testCategoricalCardZero = TestCase $ do - -- Empty column → no conditions. - let df = - D.fromUnnamedColumns - [ DI.fromList ([] :: [T.Text]) - , DI.fromList ([] :: [T.Text]) - ] - |> D.rename "0" "feat" - |> D.rename "1" "label" - ti = requireTargetInfo "label" df - conds = discreteConditions @T.Text ti defaultTreeConfig (D.exclude ["label"] df) - feat = "feat" - feats' = filter (\c -> feat `elem` getColumns c) conds - assertEqual "no candidates on empty column" 0 (length feats') - -testCategoricalNullableBinary :: Test -testCategoricalNullableBinary = TestCase $ do - -- Maybe Text feature with nulls, binary target. Breiman should fire on - -- the non-null distinct values; nulls drop out via validBoxedValues. - let feats = - [ Just "a" - , Just "b" - , Just "c" - , Nothing - , Just "a" - , Just "b" - , Just "c" - , Nothing - , Just "a" - , Just "b" - , Just "c" - , Just "a" - , Just "b" - , Just "c" - , Just "a" - , Just "b" - ] - labs = - [ "neg" - , "neg" - , "pos" - , "neg" - , "neg" - , "neg" - , "pos" - , "neg" - , "neg" - , "neg" - , "pos" - , "neg" - , "neg" - , "pos" - , "neg" - , "pos" - ] - df = - D.fromUnnamedColumns - [ DI.fromList (feats :: [Maybe T.Text]) - , DI.fromList (map T.pack labs :: [T.Text]) - ] - |> D.rename "0" "feat" - |> D.rename "1" "label" - ti = requireTargetInfo "label" df - conds = discreteConditions @T.Text ti defaultTreeConfig (D.exclude ["label"] df) - feat = "feat" :: T.Text - feats' = filter (\c -> feat `elem` getColumns c) conds - -- 3 non-null distinct levels → k-1 = 2 Breiman prefixes - assertEqual "Breiman prefixes on nullable column ignore nulls" 2 (length feats') - ------------------------------------------------------------------------- --- PR 2 extended: threshold-consolidation rewrite in combineAndVec / --- combineOrVec. Eight positive cases (one per <, ≤, >, ≥ × AND / OR), --- six negative cases (rule must NOT fire), one semantic-preservation --- QuickCheck-style spot check. ------------------------------------------------------------------------- - --- A small synthetic DataFrame to materialize CondVecs against. -threshFixtureDF :: D.DataFrame -threshFixtureDF = - D.fromNamedColumns - [ ("x", DI.fromList ([0.0, 1.0, 2.0, 3.0, 4.0, 5.0] :: [Double])) - , ("y", DI.fromList ([5.0, 4.0, 3.0, 2.0, 1.0, 0.0] :: [Double])) - ] - -materializeOrFail :: Expr Bool -> CondVec -materializeOrFail e = case materializeCondVec threshFixtureDF e of - Just cv -> cv - Nothing -> error "materializeOrFail: condition could not be materialized" - --- | Helper: assert that two `Expr Bool`s agree by 'eqExpr'. -assertEqExpr :: String -> Expr Bool -> Expr Bool -> Assertion -assertEqExpr msg expected actual = - assertBool - (msg ++ "\n expected: " ++ show expected ++ "\n actual: " ++ show actual) - (eqExpr expected actual) - --- Eight positive cases. - -threshAndLeq :: Test -threshAndLeq = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .<=. F.lit (3.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .<=. F.lit (1.0 :: Double)) - r = combineAndVec a b - assertEqExpr - "AND of x≤3 and x≤1 collapses to x≤1" - (F.col @Double "x" .<=. F.lit (1.0 :: Double)) - (cvExpr r) - -threshOrLeq :: Test -threshOrLeq = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .<=. F.lit (3.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .<=. F.lit (1.0 :: Double)) - r = combineOrVec a b - assertEqExpr - "OR of x≤3 and x≤1 collapses to x≤3" - (F.col @Double "x" .<=. F.lit (3.0 :: Double)) - (cvExpr r) - -threshAndLt :: Test -threshAndLt = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .<. F.lit (3.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .<. F.lit (1.0 :: Double)) - r = combineAndVec a b - assertEqExpr - "AND of x<3 and x<1 collapses to x<1" - (F.col @Double "x" .<. F.lit (1.0 :: Double)) - (cvExpr r) - -threshOrLt :: Test -threshOrLt = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .<. F.lit (3.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .<. F.lit (1.0 :: Double)) - r = combineOrVec a b - assertEqExpr - "OR of x<3 and x<1 collapses to x<3" - (F.col @Double "x" .<. F.lit (3.0 :: Double)) - (cvExpr r) - -threshAndGeq :: Test -threshAndGeq = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .>=. F.lit (1.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .>=. F.lit (3.0 :: Double)) - r = combineAndVec a b - assertEqExpr - "AND of x≥1 and x≥3 collapses to x≥3" - (F.col @Double "x" .>=. F.lit (3.0 :: Double)) - (cvExpr r) - -threshOrGeq :: Test -threshOrGeq = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .>=. F.lit (1.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .>=. F.lit (3.0 :: Double)) - r = combineOrVec a b - assertEqExpr - "OR of x≥1 and x≥3 collapses to x≥1" - (F.col @Double "x" .>=. F.lit (1.0 :: Double)) - (cvExpr r) - -threshAndGt :: Test -threshAndGt = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .>. F.lit (1.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .>. F.lit (3.0 :: Double)) - r = combineAndVec a b - assertEqExpr - "AND of x>1 and x>3 collapses to x>3" - (F.col @Double "x" .>. F.lit (3.0 :: Double)) - (cvExpr r) - -threshOrGt :: Test -threshOrGt = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .>. F.lit (1.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .>. F.lit (3.0 :: Double)) - r = combineOrVec a b - assertEqExpr - "OR of x>1 and x>3 collapses to x>1" - (F.col @Double "x" .>. F.lit (1.0 :: Double)) - (cvExpr r) - --- Six negative cases: rewrite must NOT fire. - -threshNegMixedDirection :: Test -threshNegMixedDirection = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .<. F.lit (3.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .>=. F.lit (1.0 :: Double)) - r = combineAndVec a b - -- Mixed directions (< vs ≥): consolidation deliberately out-of-scope. - -- Expect the generic F.and form. - assertEqExpr - "mixed-direction AND keeps generic F.and form" - (F.and (cvExpr a) (cvExpr b)) - (cvExpr r) - -threshNegCrossColumn :: Test -threshNegCrossColumn = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .>. F.lit (1.0 :: Double)) - b = materializeOrFail (F.col @Double "y" .>. F.lit (3.0 :: Double)) - r = combineAndVec a b - -- Same op, different columns: no rewrite. - assertEqExpr - "cross-column AND keeps generic F.and form" - (F.and (cvExpr a) (cvExpr b)) - (cvExpr r) - -threshNegMixedOpFamily :: Test -threshNegMixedOpFamily = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .>. F.lit (1.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .<. F.lit (4.0 :: Double)) - r = combineAndVec a b - -- > and < are different op families: no rewrite. - assertEqExpr - "different-op-family AND keeps generic F.and form" - (F.and (cvExpr a) (cvExpr b)) - (cvExpr r) - -threshNegEqualityOp :: Test -threshNegEqualityOp = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .==. F.lit (3.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .==. F.lit (1.0 :: Double)) - r = combineOrVec a b - -- Equality is not in the threshold family; consolidate doesn't fire. - assertEqExpr - "equality OR keeps generic F.or form" - (F.or (cvExpr a) (cvExpr b)) - (cvExpr r) - -threshNegLitOnLeft :: Test -threshNegLitOnLeft = TestCase $ do - -- Lit on LEFT of the comparison: pattern requires (Col, Lit) ordering. - let a = materializeOrFail (F.lit (1.0 :: Double) .<. F.col @Double "x") - b = materializeOrFail (F.lit (3.0 :: Double) .<. F.col @Double "x") - r = combineAndVec a b - assertEqExpr - "Lit-on-left AND keeps generic F.and form" - (F.and (cvExpr a) (cvExpr b)) - (cvExpr r) - -threshNegNonLiteralRhs :: Test -threshNegNonLiteralRhs = TestCase $ do - -- RHS is a Col, not a Lit: pattern doesn't match. - let a = materializeOrFail (F.col @Double "x" .>. F.col @Double "y") - b = materializeOrFail (F.col @Double "x" .>. F.lit (3.0 :: Double)) - r = combineAndVec a b - assertEqExpr - "non-literal RHS AND keeps generic F.and form" - (F.and (cvExpr a) (cvExpr b)) - (cvExpr r) - --- Semantic-preservation spot check (in lieu of a full QuickCheck property --- which would require generators for strict-op Expr Bool — followup work). --- Verifies that the consolidated cvVec matches the elementwise AND/OR of --- the inputs at every row of a synthetic DataFrame. -threshSemanticPreservation :: Test -threshSemanticPreservation = TestCase $ do - let a = materializeOrFail (F.col @Double "x" .>. F.lit (1.0 :: Double)) - b = materializeOrFail (F.col @Double "x" .>. F.lit (3.0 :: Double)) - rAnd = combineAndVec a b - rOr = combineOrVec a b - expectedAnd = VU.zipWith (&&) (cvVec a) (cvVec b) - expectedOr = VU.zipWith (||) (cvVec a) (cvVec b) - assertEqual - "consolidated AND vec matches elementwise &&" - expectedAnd - (cvVec rAnd) - assertEqual - "consolidated OR vec matches elementwise ||" - expectedOr - (cvVec rOr) - ------------------------------------------------------------------------- --- Test list ------------------------------------------------------------------------- - -tests :: [Test] -tests = - [ TestLabel "carePointsBothWrong" carePointsBothWrong - , TestLabel "carePointsLeftCorrect" carePointsLeftCorrect - , TestLabel "carePointsRightCorrect" carePointsRightCorrect - , TestLabel "carePointsMixed" carePointsMixed - , TestLabel "carePointsBothCorrect" carePointsBothCorrect - , TestLabel "majorityVoteTest" majorityVoteTest - , TestLabel "majorityVoteSubset" majorityVoteSubset - , TestLabel "computeLossZero" computeLossZero - , TestLabel "computeLossHalf" computeLossHalf - , TestLabel "partitionDisjoint" partitionDisjoint - , TestLabel "partitionUnion" partitionUnion - , TestLabel "countErrorsAllCorrect" countErrorsAllCorrect - , TestLabel "countErrorsAllWrong" countErrorsAllWrong - , TestLabel "predictLeaf" predictLeaf - , TestLabel "predictBranch" predictBranch - , TestLabel "taoNoDegradation" taoNoDegradation - , TestLabel "taoMonotone" taoMonotone - , TestLabel "taoConvergesPureLabels" taoConvergesPureLabels - , TestLabel "taoDeadBranchNoCrash" taoDeadBranchNoCrash - , TestLabel "taoRecoversSingleObliqueDerived" taoRecoversSingleObliqueDerived - , TestLabel "taoRecoversNestedObliqueDerived" taoRecoversNestedObliqueDerived - , TestLabel - "C2a taoAxisAlignedInsufficientForObliqueDiscreteOnly" - taoAxisAlignedInsufficientForObliqueDiscreteOnly - , TestLabel - "C2b taoLinearRecoversObliqueFromAxisAlignedPool" - taoLinearRecoversObliqueFromAxisAlignedPool - , TestLabel "numericColsNullableDouble" numericColsNullableDoubleTest - , TestLabel "numericColsNullableInt" numericColsNullableIntTest - , TestLabel "numericCondsNullableNonEmpty" numericCondsNullableNonEmptyTest - , TestLabel "nullValueRoutesFalse" nullValueRoutesFalseTest - , TestLabel "nullableFitZeroLoss" nullableFitZeroLossTest - , TestLabel "nullableFitWithNullsNoCrash" nullableFitWithNullsNoCrashTest - , TestLabel "numericExprsWithTermsMixed" numericExprsWithTermsMixedTest - , TestLabel "probsFromIndicesBasic" probsFromIndicesBasic - , TestLabel "probsFromIndicesSubset" probsFromIndicesSubset - , TestLabel "probsFromIndicesSingleClass" probsFromIndicesSingleClass - , TestLabel "buildProbTreeLeaf" buildProbTreeLeaf - , TestLabel "buildProbTreeBranch" buildProbTreeBranch - , TestLabel "probExprsLeaf" probExprsLeaf - , TestLabel "probExprsMissingClass" probExprsMissingClass - , TestLabel "probExprsAllClasses" probExprsAllClasses - , TestLabel "probsSumToOne" probsSumToOne - , TestLabel "probArgmaxMatchesClassifier" probArgmaxMatchesClassifier - , TestLabel - "C4 taoRecoversNestedObliqueWithoutHint" - taoRecoversNestedObliqueWithoutHint - , TestLabel "C5 taoMonotoneWithLinear" taoMonotoneWithLinear - , TestLabel "C6 taoLinearVsDiscreteCompetition" taoLinearVsDiscreteCompetition - , TestLabel "C8 taoLinearProducesSparsity" taoLinearProducesSparsity - , TestLabel "C9 taoLinearDeterministic" taoLinearDeterministic - , TestLabel "D1 taoLinearTinyCareSet" taoLinearTinyCareSet - , TestLabel "E1 categoricalBreimanBinary" testCategoricalBreimanBinary - , TestLabel - "E2 categoricalSubsetsMulticlassLowCard" - testCategoricalSubsetsMulticlassLowCard - , TestLabel - "E3 categoricalSingletonsMulticlassHighCard" - testCategoricalSingletonsMulticlassHighCard - , TestLabel "E4 categoricalCardZero" testCategoricalCardZero - , TestLabel "E5 categoricalNullableBinary" testCategoricalNullableBinary - , -- PR 2 extended: threshold-consolidation rewrite (positive cases). - TestLabel "F1 threshAndLeq" threshAndLeq - , TestLabel "F2 threshOrLeq" threshOrLeq - , TestLabel "F3 threshAndLt" threshAndLt - , TestLabel "F4 threshOrLt" threshOrLt - , TestLabel "F5 threshAndGeq" threshAndGeq - , TestLabel "F6 threshOrGeq" threshOrGeq - , TestLabel "F7 threshAndGt" threshAndGt - , TestLabel "F8 threshOrGt" threshOrGt - , -- PR 2 extended: negative cases (rewrite must NOT fire). - TestLabel "F9 threshNegMixedDirection" threshNegMixedDirection - , TestLabel "F10 threshNegCrossColumn" threshNegCrossColumn - , TestLabel "F11 threshNegMixedOpFamily" threshNegMixedOpFamily - , TestLabel "F12 threshNegEqualityOp" threshNegEqualityOp - , TestLabel "F13 threshNegLitOnLeft" threshNegLitOnLeft - , TestLabel "F14 threshNegNonLiteralRhs" threshNegNonLiteralRhs - , TestLabel "F15 threshSemanticPreservation" threshSemanticPreservation - ] diff --git a/tests/IO/CsvGolden.hs b/tests/IO/CsvGolden.hs --- a/tests/IO/CsvGolden.hs +++ b/tests/IO/CsvGolden.hs @@ -3,9 +3,8 @@ {-# LANGUAGE TypeApplications #-} {- | Golden semantics for the default CSV reader, pinned against the -cassava-based implementation (oracle runs of 2026-06-12) before the -strict-scanner rewrite. Ragged-row cases encode the new pad-with-null -behavior (audit D6) — the one intentional change. +cassava-based oracle (2026-06-12) before the strict-scanner rewrite. +Ragged-row cases encode the one intentional change: pad-with-null (audit D6). -} module IO.CsvGolden (tests) where @@ -25,8 +24,8 @@ forceDataFrame, getColumn, ) -import DataFrame.Internal.Schema (schemaType) import DataFrame.Operations.Typing (SafeReadMode (..)) +import DataFrame.Schema (schemaType) import Test.HUnit data Expect @@ -156,8 +155,7 @@ , "a,b\n\t1\t,\tx\t\n2,y\n" , Cols (2, 2) [("a", ints [1, 2]), ("b", texts ["x", "y"])] ) - , -- D6: short rows now pad trailing columns with null (was: misaligned). - + , ( "ragged_short_D6" , defaultReadOptions , "a,b,c\n1,2,3\n4,5\n6,7,8\n" @@ -224,8 +222,7 @@ , "1,2\n3,4\n" , Cols (2, 2) [("x", ints [1, 3]), ("1", ints [2, 4])] ) - , -- D6: the always-short padded column is now row-aligned (all null). - + , ( "providenames_more_D6" , defaultReadOptions{headerSpec = ProvideNames ["x", "y", "z"]} , "1,2\n3,4\n" @@ -416,8 +413,7 @@ , "a,b\nNA,1\n2,2\n" , Cols (2, 2) [("a", texts ["NA", "2"]), ("b", eti [Right 1, Right 2])] ) - , -- D6: the column after the EOF-truncated quote field is now padded. - + , ( "unclosed_quote_D6" , defaultReadOptions , "a,b\n\"x,2\n" diff --git a/tests/IR/ExprJsonRoundtrip.hs b/tests/IR/ExprJsonRoundtrip.hs new file mode 100644 --- /dev/null +++ b/tests/IR/ExprJsonRoundtrip.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{- | Round-trip, pipeline, end-to-end, and wire-shape contract tests for the +expression/pipeline serializer. +-} +module IR.ExprJsonRoundtrip (tests) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as BS8 +import Data.Either (fromRight, isLeft) +import Test.HUnit + +import qualified Data.Vector.Unboxed as VU +import qualified DataFrame as D +import qualified DataFrame.Functions as F +import DataFrame.Internal.Column (Columnable, TypedColumn (..), toVector) +import qualified DataFrame.Internal.Column as DI +import DataFrame.Internal.Expression (Expr, UExpr (..)) +import DataFrame.Internal.Interpreter (interpret) +import DataFrame.Operators (ifThenElse, (.>.)) + +import DataFrame.LinearModel (defaultLinearConfig) +import DataFrame.Model (fit, predict) +import DataFrame.Transform (Transform (..), applyTransform) +import DataFrame.Transform.Serialize ( + loadTransformFromFile, + saveTransformToFile, + ) + +import DataFrame.Expr.Serialize ( + SomeExpr (..), + decodeExprAny, + decodeExprAt, + decodeExprFromBytes, + encodeExpr, + loadExprAtFromFile, + loadPipelineFromFile, + saveExprToFile, + savePipelineToFile, + ) +import System.IO.Temp (withSystemTempDirectory) + +interpD :: D.DataFrame -> Expr Double -> [Double] +interpD df e = case interpret @Double df e of + Right (TColumn c) -> either (const []) VU.toList (toVector @Double @VU.Vector c) + Left err -> error (show err) + +close :: [Double] -> [Double] -> Bool +close a b = length a == length b && and (zipWith (\x y -> abs (x - y) <= 1e-9) a b) + +df3 :: D.DataFrame +df3 = D.fromNamedColumns [("x", DI.fromList [1, 2, 3 :: Double])] + +regDF :: D.DataFrame +regDF = + D.fromNamedColumns + [ ("x1", DI.fromList xs1) + , ("x2", DI.fromList xs2) + , ("y", DI.fromList [2 * a - 3 * b + 1 | (a, b) <- zip xs1 xs2]) + ] + where + xs1 = [1, 2, 3, 4, 5, 6, 7, 8] :: [Double] + xs2 = [2, 1, 4, 3, 6, 5, 8, 7] :: [Double] + +{- | An expression round-trips when encode → decode → re-encode yields the same +JSON. Avoids needing an 'Eq' instance on the GADT. +-} +roundtrips :: (Columnable a) => Expr a -> Bool +roundtrips e = fromRight False $ do + v1 <- encodeExpr e + SomeExpr _ e' <- decodeExprAny v1 + v2 <- encodeExpr e' + Right (v1 == v2) + +testCase :: String -> Bool -> Test +testCase name ok = TestCase (assertBool name ok) + +-- Row-wise expression node kinds. +exprRoundtripTests :: [Test] +exprRoundtripTests = + [ testCase "col" (roundtrips (F.col @Double "x")) + , testCase "lit" (roundtrips (F.lit @Int 42)) + , testCase "arithmetic" (roundtrips (F.col @Double "x" * F.lit 2 + F.lit 1)) + , testCase "division" (roundtrips (F.col @Double "x" / F.lit 2)) + , testCase "comparison" (roundtrips (F.col @Double "x" .>. F.lit 0)) + , testCase "unary sqrt" (roundtrips (sqrt (F.col @Double "x"))) + , testCase + "if/then/else" + ( roundtrips + ( ifThenElse (F.col @Double "x" .>. F.lit 0) (F.lit 1.0) (F.lit (-1.0)) :: + Expr Double + ) + ) + ] + +-- Aggregation and window node kinds (the decoder cases added for full parity). +aggRoundtripTests :: [Test] +aggRoundtripTests = + [ testCase "sum" (roundtrips (F.sum (F.col @Double "x"))) + , testCase "count" (roundtrips (F.count (F.col @Double "x"))) + , testCase "minimum" (roundtrips (F.minimum (F.col @Double "x"))) + , testCase "maximum" (roundtrips (F.maximum (F.col @Int "x"))) + , testCase "mean" (roundtrips (F.mean (F.col @Double "x"))) + , testCase "variance" (roundtrips (F.variance (F.col @Double "x"))) + , testCase "median" (roundtrips (F.median (F.col @Double "x"))) + , testCase "over" (roundtrips (F.over ["g"] (F.sum (F.col @Double "x")))) + ] + +-- Documented limitation: collect's list-typed output has no type tag, so it +-- cannot be encoded. +limitationTests :: [Test] +limitationTests = + [ testCase + "collect cannot encode" + (isLeft (encodeExpr (F.collect (F.col @Double "x")))) + ] + +-- Pin the wire shape Python decodes against: (x * 2) + 1 over doubles. +contractTests :: [Test] +contractTests = + [ TestCase $ case Aeson.eitherDecodeStrict (BS8.pack contractJson) >>= decodeExprAt @Double of + Left err -> assertFailure ("contract decode failed: " <> err) + Right e -> + assertBool "contract interprets to [3,5,7]" (close (interpD df3 e) [3, 5, 7]) + , testCase + "collect agg node fails to decode" + (isLeft (decodeExprFromBytes (BS8.pack collectJson))) + ] + +contractJson :: String +contractJson = + "{\"node\":\"binary\",\"out_type\":\"double\",\"op\":\"add\",\"arg_type\":\"double\"," + <> "\"lhs\":{\"node\":\"binary\",\"out_type\":\"double\",\"op\":\"mult\",\"arg_type\":\"double\"," + <> "\"lhs\":{\"node\":\"col\",\"out_type\":\"double\",\"name\":\"x\"}," + <> "\"rhs\":{\"node\":\"lit\",\"out_type\":\"double\",\"value\":2.0}}," + <> "\"rhs\":{\"node\":\"lit\",\"out_type\":\"double\",\"value\":1.0}}" + +collectJson :: String +collectJson = + "{\"node\":\"agg\",\"out_type\":\"double\",\"agg\":\"collect\",\"arg_type\":\"double\"," + <> "\"arg\":{\"node\":\"col\",\"out_type\":\"double\",\"name\":\"x\"}}" + +-- File round-trips for a single expression, a pipeline, and a fitted model. +ioTests :: [Test] +ioTests = + [ TestCase $ withSystemTempDirectory "expr-ser" $ \dir -> do + let fp = dir ++ "/expr.json" + e = F.col @Double "x" * F.lit 2 + F.lit 1 + sr <- saveExprToFile fp e + assertEqual "save expr ok" (Right ()) sr + loaded <- loadExprAtFromFile @Double fp + case loaded of + Left err -> assertFailure ("load expr failed: " <> err) + Right e' -> + assertBool + "loaded expr interprets equal" + (close (interpD df3 e') (interpD df3 e)) + , TestCase $ withSystemTempDirectory "expr-ser" $ \dir -> do + let fp = dir ++ "/pipeline.json" + nes = + [ ("z", UExpr (F.col @Double "x" * F.lit 2)) + , ("w", UExpr (F.col @Double "x" + F.lit 10)) + ] + sr <- savePipelineToFile fp nes + assertEqual "save pipeline ok" (Right ()) sr + loaded <- loadPipelineFromFile fp + case loaded of + Left err -> assertFailure ("load pipeline failed: " <> err) + Right nes' -> do + let df' = applyTransform (Transform nes') df3 + assertBool "z = 2x" (close (interpD df' (F.col @Double "z")) [2, 4, 6]) + assertBool "w = x+10" (close (interpD df' (F.col @Double "w")) [11, 12, 13]) + , TestCase $ withSystemTempDirectory "expr-ser" $ \dir -> do + let fp = dir ++ "/transform.json" + t = Transform [("z", UExpr (F.col @Double "x" * F.lit 2))] + sr <- saveTransformToFile fp t + assertEqual "save transform ok" (Right ()) sr + loaded <- loadTransformFromFile fp + case loaded of + Left err -> assertFailure ("load transform failed: " <> err) + Right t' -> + assertBool + "transform z = 2x" + (close (interpD (applyTransform t' df3) (F.col @Double "z")) [2, 4, 6]) + , TestCase $ withSystemTempDirectory "expr-ser" $ \dir -> do + -- End-to-end: fit OLS, persist its prediction, reload, compare outputs. + let fp = dir ++ "/model.json" + m = fit defaultLinearConfig (F.col @Double "y") regDF + sr <- saveExprToFile fp (predict m) + assertEqual "save model ok" (Right ()) sr + loaded <- loadExprAtFromFile @Double fp + case loaded of + Left err -> assertFailure ("load model failed: " <> err) + Right e' -> + assertBool + "reloaded prediction matches original" + (close (interpD regDF e') (interpD regDF (predict m))) + ] + +tests :: [Test] +tests = + exprRoundtripTests + ++ aggRoundtripTests + ++ limitationTests + ++ contractTests + ++ ioTests diff --git a/tests/Internal/Markdown.hs b/tests/Internal/Markdown.hs --- a/tests/Internal/Markdown.hs +++ b/tests/Internal/Markdown.hs @@ -1,14 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} --- | Markdown rendering must escape pipe-table metacharacters in cell values, --- or an operator name like @<|>@ splits the row into the wrong columns. +{- | Markdown rendering must escape pipe-table metacharacters in cell values, +or an operator name like @<|>@ splits the row into the wrong columns. +-} module Internal.Markdown (tests) where import qualified Data.Text as T +import DataFrame.Display.Terminal.PrettyPrint (escapeMarkdownCell) import DataFrame.Internal.Column (fromList) import qualified DataFrame.Internal.DataFrame as D -import DataFrame.Display.Terminal.PrettyPrint (escapeMarkdownCell) import Test.HUnit -- Count the column-delimiter pipes in a rendered row: a bare '|' delimits a diff --git a/tests/LazyParity.hs b/tests/LazyParity.hs --- a/tests/LazyParity.hs +++ b/tests/LazyParity.hs @@ -2,14 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -{- | The HARD GATE for the lazy engine: for a bounded source, the lazy result -must be BYTE-IDENTICAL to the eager result computed with the same eager ops -('Join.join' / 'Agg.aggregate' . 'Agg.groupBy' / 'Perm.sortBy'). - -The lazy executor routes bounded HashJoin/HashAggregate through the whole-frame -eager fast paths, so 'show' of the two results must agree exactly. Both a LEFT -join pipeline (join -> groupBy -> aggregate -> sort) and a pure groupBy pipeline -are covered. +{- | The HARD GATE for the lazy engine: for a bounded source the lazy result +must be BYTE-IDENTICAL to the eager result of the same ops (bounded joins and +aggregates route through the eager fast paths). Covers a LEFT-join pipeline +(join -> groupBy -> aggregate -> sort) and a pure groupBy pipeline. -} module LazyParity (tests) where @@ -21,14 +17,14 @@ import qualified DataFrame.IO.CSV as Csv import qualified DataFrame.Internal.Column as DI import qualified DataFrame.Internal.Expression as E -import DataFrame.Internal.Schema (Schema (..), schemaType) +import DataFrame.Lazy (SortOrder (Descending)) import qualified DataFrame.Lazy as L -import DataFrame.Lazy.Internal.LogicalPlan (SortOrder (Descending)) import qualified DataFrame.Operations.Aggregation as Agg import DataFrame.Operations.Join (JoinType (LEFT)) import qualified DataFrame.Operations.Join as Join import qualified DataFrame.Operations.Permutation as Perm import DataFrame.Operators (as, (|>)) +import DataFrame.Schema (Schema (..), schemaType) import System.Directory (removeFile) import System.IO.Temp (emptySystemTempFile) import Test.HUnit @@ -102,15 +98,13 @@ [ F.sum (amount - discount) `as` "revenue" , F.count amount `as` "orders" ] - -- Eager: the exact ops the lazy executor delegates to. ordersDf <- Csv.readCsvWithSchema ordersSchema ordersPath customersDf <- Csv.readCsvWithSchema customersSchema customersPath let eager = Perm.sortBy [Perm.Desc (E.Col @Double "revenue")] $ Agg.aggregate aggs $ Agg.groupBy ["region", "plan"] $ - Join.join LEFT ["customer_id"] customersDf ordersDf - -- Lazy: same query through the bounded-source fast path. + Join.join LEFT ["customer_id"] ordersDf customersDf let customersQ = L.scanCsv customersSchema (T.pack customersPath) lazy <- L.scanCsv ordersSchema (T.pack ordersPath) diff --git a/tests/LazyParquet.hs b/tests/LazyParquet.hs --- a/tests/LazyParquet.hs +++ b/tests/LazyParquet.hs @@ -9,9 +9,9 @@ import Data.Time (UTCTime) import qualified DataFrame as D import qualified DataFrame.Functions as F -import DataFrame.Internal.Schema (Schema (..), schemaType) +import DataFrame.Lazy (SortOrder (..)) import qualified DataFrame.Lazy as L -import DataFrame.Lazy.Internal.LogicalPlan (SortOrder (..)) +import DataFrame.Schema (Schema (..), schemaType) import Test.HUnit -- | Schema matching all columns in alltypes_plain.parquet. diff --git a/tests/Learn/EdgeCases.hs b/tests/Learn/EdgeCases.hs deleted file mode 100644 --- a/tests/Learn/EdgeCases.hs +++ /dev/null @@ -1,481 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -{- | Edge-case / degeneracy tests (tests.md category 7) and numerical-stability -tests (category 8) for @dataframe-learn@. - -Each test asserts the *mathematically correct* result (computed by hand, with -the derivation in a comment) or a *specific* documented degenerate behaviour -- -never "it returned something". Where the library's contract is to clamp/guard a -degeneracy (e.g. @k > n@, constant columns) we assert the concrete clamped -result; where the underlying routine is stable we assert it matches the closed -form a naive implementation would get wrong. --} -module Learn.EdgeCases (tests) where - -import qualified Data.Map.Strict as M -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU - -import qualified DataFrame as D -import qualified DataFrame.Functions as F -import DataFrame.Internal.Column (TypedColumn (..), toVector) -import qualified DataFrame.Internal.Column as DI -import DataFrame.Internal.Expression (Expr) -import DataFrame.Internal.Interpreter (interpret) - -import DataFrame.GMM -import DataFrame.KMeans -import DataFrame.LinearAlgebra (logSumExp) -import DataFrame.LinearAlgebra.Eigen (jacobiEigenSym) -import DataFrame.LinearAlgebra.Solve (choleskySolve) -import DataFrame.LinearModel -import DataFrame.LinearSolver (sigmoid) -import DataFrame.Model (fit, predict) -import DataFrame.PCA - -import DataFrame.Internal.Statistics (correlation', variance') - -import Test.HUnit - --- Helpers (mirrors Learn.Models) -------------------------------------------- - -interpD :: D.DataFrame -> Expr Double -> [Double] -interpD df e = case interpret @Double df e of - Right (TColumn c) -> either (const []) VU.toList (toVector @Double @VU.Vector c) - Left err -> error (show err) - -interpI :: D.DataFrame -> Expr Int -> [Int] -interpI df e = case interpret @Int df e of - Right (TColumn c) -> either (const []) VU.toList (toVector @Int @VU.Vector c) - Left err -> error (show err) - -mat :: [[Double]] -> V.Vector (VU.Vector Double) -mat = V.fromList . map VU.fromList - -close :: Double -> Double -> Double -> Bool -close tol a b = abs (a - b) <= tol - -finite :: Double -> Bool -finite x = not (isNaN x) && not (isInfinite x) - --- =========================================================================== --- Category 8: numerical stability --- =========================================================================== - -{- logSumExp on a large-positive cluster. - log(e^1000 + e^1001 + e^1002) - = 1002 + log(e^-2 + e^-1 + 1) - e^-2 = 0.1353352832366127, e^-1 = 0.36787944117144233 - sum = 1.5032147243... ; log(sum) = 0.40760596444... - => 1002.4076059644... - A naive `log . sum . map exp` overflows to +Inf here. -} -testLogSumExpLargePositive :: Test -testLogSumExpLargePositive = TestCase $ do - let lse = logSumExp (VU.fromList [1000, 1001, 1002]) - expected = 1002 + log (exp (-2) + exp (-1) + 1) - assertBool "lse large-positive is finite" (finite lse) - assertBool - "lse [1000,1001,1002] == 1002 + log(e^-2+e^-1+1)" - (close 1e-9 lse expected) - -- sanity on the literal so the test pins the actual number, not just the formula - assertBool "lse literal ~ 1002.40760596" (close 1e-7 lse 1002.4076059644443) - -{- logSumExp on a large-negative cluster. - log(e^-1000 + e^-1001 + e^-1002) - = -1000 + log(1 + e^-1 + e^-2) [max is -1000] - = -1000 + 0.40760596444... - = -999.59239403556... - A naive implementation underflows every term to 0 -> log 0 = -Inf. -} -testLogSumExpLargeNegative :: Test -testLogSumExpLargeNegative = TestCase $ do - let lse = logSumExp (VU.fromList [-1000, -1001, -1002]) - expected = -1000 + log (1 + exp (-1) + exp (-2)) - assertBool "lse large-negative is finite" (finite lse) - assertBool - "lse [-1000,-1001,-1002] == -1000 + log(1+e^-1+e^-2)" - (close 1e-9 lse expected) - assertBool "lse literal ~ -999.59239403" (close 1e-7 lse (-999.5923940355557)) - -{- logSumExp of a single element is that element exactly (m + log 1). -} -testLogSumExpSingleton :: Test -testLogSumExpSingleton = TestCase $ do - assertBool "lse [42] == 42" (close 0 (logSumExp (VU.fromList [42])) 42) - -{- sigmoid at extreme arguments must stay in [0,1] and not NaN/Inf. - sigmoid(1000) is 1 up to rounding (1 - ~0); sigmoid(-1000) is 0. - The naive 1/(1+exp(-z)) overflows exp(1000)=Inf at z=-1000 -> 1/Inf = 0 ok, - but exp(-(-1000)) path; the stable branch in DataFrame.LinearSolver.sigmoid - picks ez/(1+ez) for z<0 so e^-1000 underflows to 0 cleanly -> 0. -} -testSigmoidExtreme :: Test -testSigmoidExtreme = TestCase $ do - let sp = sigmoid 1000 - sn = sigmoid (-1000) - assertBool "sigmoid(1000) finite" (finite sp) - assertBool "sigmoid(-1000) finite" (finite sn) - assertBool "sigmoid(1000) in [0,1]" (sp >= 0 && sp <= 1) - assertBool "sigmoid(-1000) in [0,1]" (sn >= 0 && sn <= 1) - -- saturated values: 1 and 0 to within machine epsilon - assertBool "sigmoid(1000) == 1" (close 1e-12 sp 1) - assertBool "sigmoid(-1000) == 0" (close 1e-12 sn 0) - -- sigmoid(0) is exactly 0.5 - assertBool "sigmoid(0) == 0.5" (close 1e-15 (sigmoid 0) 0.5) - -- antisymmetry: sigmoid(-z) == 1 - sigmoid(z) at a moderate z - assertBool - "sigmoid antisymmetric at 3" - (close 1e-12 (sigmoid (-3)) (1 - sigmoid 3)) - -{- Variance of large-but-low-variance data: [1e8+1, 1e8+2, 1e8+3]. - True sample variance (n-1) of {1,2,3} shifted by 1e8 is 1.0 exactly. - A naive sum-of-squares-minus-square-of-sum formula loses all precision here - (catastrophic cancellation) -> 0 or negative. Welford keeps it ~1. -} -testVarianceCatastrophicCancellation :: Test -testVarianceCatastrophicCancellation = TestCase $ do - let xs = VU.fromList [1e8 + 1, 1e8 + 2, 1e8 + 3] :: VU.Vector Double - v = variance' xs - assertBool "variance finite" (finite v) - assertBool "variance is positive" (v > 0) - -- sample variance of {1,2,3} = ((1-2)^2 + 0 + (3-2)^2)/(3-1) = 2/2 = 1 - assertBool "variance of shifted {1,2,3} == 1.0" (close 1e-6 v 1.0) - -{- Variance of an identical column is exactly 0 (not a tiny negative from - cancellation). -} -testVarianceConstant :: Test -testVarianceConstant = TestCase $ do - let v = variance' (VU.replicate 100 (7.0 :: Double)) - assertEqual "variance of constant column is 0" 0 v - -{- Variance of fewer than two samples is defined to be 0 (computeVariance guard), - not NaN from a /0. -} -testVarianceSingleton :: Test -testVarianceSingleton = TestCase $ do - assertEqual - "variance of one sample is 0" - 0 - (variance' (VU.fromList [3.5 :: Double])) - -{- Correlation of a perfectly linear pair is exactly +1 (and -1 reversed), - computed stably. y = 2x+1 over a spread of x. -} -testCorrelationPerfect :: Test -testCorrelationPerfect = TestCase $ do - let xs = VU.fromList [1, 2, 3, 4, 5] :: VU.Vector Double - ys = VU.map (\x -> 2 * x + 1) xs - yneg = VU.map (\x -> -(2 * x) + 1) xs - case correlation' xs ys of - Just r -> assertBool "corr(x, 2x+1) == 1" (close 1e-9 r 1) - Nothing -> assertFailure "expected a correlation" - case correlation' xs yneg of - Just r -> assertBool "corr(x, -2x+1) == -1" (close 1e-9 r (-1)) - Nothing -> assertFailure "expected a correlation" - -{- Degeneracy: correlation against a constant column. The denominator - sqrt(... * (n*Syy - Sy^2)) is 0, so the library returns Just NaN. This pins - the ACTUAL behaviour: it does not throw, but it does produce a NaN that the - caller must guard. If a future fix makes it return Nothing or 0 this test - flags the contract change. -} -testCorrelationConstantColumnIsNaN :: Test -testCorrelationConstantColumnIsNaN = TestCase $ do - let xs = VU.fromList [1, 2, 3, 4, 5] :: VU.Vector Double - ys = VU.replicate 5 (9.0 :: Double) - case correlation' xs ys of - Just r -> - assertBool - "corr with a zero-variance column is NaN (degenerate denom)" - (isNaN r) - Nothing -> assertFailure "correlation' returned Nothing (contract changed)" - -{- correlation' on n<2 returns Nothing (guarded), not a NaN. -} -testCorrelationTooFew :: Test -testCorrelationTooFew = TestCase $ do - assertEqual - "correlation of one point is Nothing" - Nothing - (correlation' (VU.fromList [1]) (VU.fromList [2])) - --- =========================================================================== --- Category 8: stability inside the model expr layer --- =========================================================================== - -{- Logistic probability expressions at extreme feature values must remain in - [0,1] and finite. The prob expr is 1/(1+exp(-margin)); with a separating - model and |x| pushed to 1e6 the margin is huge, so a non-stable evaluation - could overflow. We assert every probability is finite and in [0,1] and that - the two one-vs-rest class probabilities are present. -} -testLogisticProbsExtremeFeatures :: Test -testLogisticProbsExtremeFeatures = TestCase $ do - let trainDf = - D.fromNamedColumns - [ ("x", DI.fromList ([-3, -2, -1, -0.5, 0.5, 1, 2, 3] :: [Double])) - , ("label", DI.fromList ([0, 0, 0, 0, 1, 1, 1, 1] :: [Int])) - ] - m = fit defaultLogisticConfig (F.col @Int "label") trainDf - probs = logisticProbExprs m - -- evaluate the class-1 probability at extreme inputs - extremeDf = - D.fromNamedColumns - [("x", DI.fromList ([-1e6, -1, 0, 1, 1e6] :: [Double]))] - assertEqual "two one-vs-rest probability exprs" 2 (M.size probs) - let allProbVals = - concat [interpD extremeDf e | e <- M.elems probs] - assertBool "all logistic probabilities finite" (all finite allProbVals) - assertBool - "all logistic probabilities in [0,1]" - (all (\p -> p >= 0 && p <= 1) allProbVals) - --- =========================================================================== --- Category 7: edge cases / degeneracy on models --- =========================================================================== - -{- One-row OLS: a single point (x=2, y=7). With one observation OLS is - under-determined; the QR design [1, 2] is rank deficient (n=1 < d=2 cols of - the intercept-augmented matrix) so olsSolve falls back to ridge(1e-8). The - fitted line must at minimum interpolate the single training point: the - prediction at x=2 must equal 7 (within tolerance). It must NOT be NaN/Inf. -} -testOLSOneRow :: Test -testOLSOneRow = TestCase $ do - let df = - D.fromNamedColumns - [ ("x", DI.fromList ([2] :: [Double])) - , ("y", DI.fromList ([7] :: [Double])) - ] - m = fit defaultLinearConfig (F.col @Double "y") df - preds = interpD df (predict m) - assertBool "single OLS prediction finite" (all finite preds) - assertBool - "OLS fits the single training point" - (case preds of [p] -> close 1e-3 p 7; _ -> False) - -{- All-identical labels in logistic regression: every row is class 1. There is - exactly one class, so predict must return that class for every row (no - division-by-zero, no crash, no spurious second class). -} -testLogisticSingleClass :: Test -testLogisticSingleClass = TestCase $ do - let df = - D.fromNamedColumns - [ ("x", DI.fromList ([-2, -1, 0, 1, 2] :: [Double])) - , ("label", DI.fromList ([1, 1, 1, 1, 1] :: [Int])) - ] - m = fit defaultLogisticConfig (F.col @Int "label") df - preds = interpI df (predict m) - assertEqual - "single-class logistic predicts that class everywhere" - [1, 1, 1, 1, 1] - preds - -{- Perfectly separable logistic data with a constant (zero-variance) feature - added. The constant column has variance 0 and is dropped by keptIndices - (>= 1e-12 threshold); the informative column still separates the classes. - Prediction must recover the labels exactly and not be corrupted by the - constant column. -} -testLogisticConstantFeatureIgnored :: Test -testLogisticConstantFeatureIgnored = TestCase $ do - let df = - D.fromNamedColumns - [ ("x", DI.fromList ([-3, -2, -1, -0.5, 0.5, 1, 2, 3] :: [Double])) - , ("const", DI.fromList (replicate 8 (5.0 :: Double))) - , ("label", DI.fromList ([0, 0, 0, 0, 1, 1, 1, 1] :: [Int])) - ] - m = fit defaultLogisticConfig (F.col @Int "label") df - preds = interpI df (predict m) - assertEqual - "logistic ignores constant column and separates" - [0, 0, 0, 0, 1, 1, 1, 1] - preds - -{- Linear regression with an irrelevant constant feature: the constant column is - near-constant (variance 0) and must get a zero weight, while the informative - coefficient is recovered. y = 3x + 4 exactly. -} -testLinearConstantFeatureZeroWeight :: Test -testLinearConstantFeatureZeroWeight = TestCase $ do - let xs = [1, 2, 3, 4, 5, 6] :: [Double] - df = - D.fromNamedColumns - [ ("x", DI.fromList xs) - , ("const", DI.fromList (replicate 6 (5.0 :: Double))) - , ("y", DI.fromList [3 * x + 4 | x <- xs]) - ] - m = fit defaultLinearConfig (F.col @Double "y") df - coefs = VU.toList (regCoef m) - names = V.toList (regFeatureNames m) - byName = zip names coefs - -- find the const column weight; it must be ~0 (no information, possibly - -- collinear with the intercept) - case lookup "const" byName of - Just w -> assertBool "constant feature gets ~zero weight" (close 1e-6 w 0) - Nothing -> assertFailure "const column missing from feature names" - let preds = interpD df (predict m) - truth = [3 * x + 4 | x <- xs] - assertBool - "regression with constant feature still fits y=3x+4" - (and (zipWith (close 1e-4) preds truth)) - -{- k-means with k > n: requesting more clusters than data points. The library - clamps k = min k (max 1 n), so with 3 rows and kmK=10 we must get exactly 3 - centres (one per point), labels in range, and finite centres -- not a crash - or empty/duplicate-degenerate centres. -} -testKMeansKGreaterThanN :: Test -testKMeansKGreaterThanN = TestCase $ do - let df = - D.fromNamedColumns - [ ("a", DI.fromList ([0, 5, 10] :: [Double])) - , ("b", DI.fromList ([0, 5, 10] :: [Double])) - ] - cfg = defaultKMeansConfig{kmK = 10, kmNInit = 3, kmSeed = 1} - m = fit cfg [F.col @Double "a", F.col @Double "b"] df - assertEqual "k clamped to n=3 centres" 3 (V.length (kmCenters m)) - let labels = VU.toList (kmLabels m) - assertBool "all labels in [0,2]" (all (\l -> l >= 0 && l < 3) labels) - assertBool - "all centre coordinates finite" - (all (VU.all finite) (V.toList (kmCenters m))) - -- with 3 distinct points and 3 clusters, inertia must be ~0 (each point is - -- its own centre) - assertBool "k=n clustering has ~zero inertia" (close 1e-9 (kmInertia m) 0) - -{- k-means on an all-identical (zero-variance) feature set: every row is the same - point. Any clustering has inertia 0; centres must all equal that point and be - finite (no NaN from dividing by an empty cluster or by a zero distance sum in - k-means++ sampling). -} -testKMeansAllIdentical :: Test -testKMeansAllIdentical = TestCase $ do - let df = - D.fromNamedColumns - [ ("a", DI.fromList (replicate 6 (4.0 :: Double))) - , ("b", DI.fromList (replicate 6 (4.0 :: Double))) - ] - cfg = defaultKMeansConfig{kmK = 2, kmNInit = 3, kmSeed = 1} - m = fit cfg [F.col @Double "a", F.col @Double "b"] df - assertBool - "centres finite on degenerate identical data" - (all (VU.all finite) (V.toList (kmCenters m))) - assertBool "inertia is 0 for identical points" (close 1e-12 (kmInertia m) 0) - -- predict must still assign a valid (finite, in-range) label to every row - let assigns = interpI df (predict m) - assertBool "assignments in [0,1]" (all (\l -> l >= 0 && l < 2) assigns) - -{- GMM with k > n: clamped like k-means (k = min k (max 1 n)). Two rows, gmmK=5 - must yield 2 components, finite weights summing to ~1, and a finite log - likelihood -- not a crash or NaN. -} -testGMMKGreaterThanN :: Test -testGMMKGreaterThanN = TestCase $ do - let df = - D.fromNamedColumns - [ ("a", DI.fromList ([0, 10] :: [Double])) - , ("b", DI.fromList ([0, 10] :: [Double])) - ] - cfg = defaultGMMConfig{gmmK = 5, gmmSeed = 1} - m = fit cfg [F.col @Double "a", F.col @Double "b"] df - assertEqual "GMM k clamped to n=2" 2 (VU.length (gmmWeights m)) - assertBool "GMM weights finite" (VU.all finite (gmmWeights m)) - assertBool "GMM weights sum to ~1" (close 1e-6 (VU.sum (gmmWeights m)) 1) - assertBool "GMM log-likelihood finite" (finite (gmmLogLikelihood m)) - -{- PCA on a single informative axis plus a constant column: the constant column - carries zero variance, so its explained-variance ratio must be ~0 and the - ratios must still sum to ~1 and stay finite. The first component should align - with the varying axis. Catches a divide-by-zero in the ratio normalisation - when one eigenvalue is 0. -} -testPCAConstantColumn :: Test -testPCAConstantColumn = TestCase $ do - let df = - D.fromNamedColumns - [ ("x", DI.fromList ([-2, -1, 0, 1, 2] :: [Double])) - , ("const", DI.fromList (replicate 5 (3.0 :: Double))) - ] - m = - fit - (PCAConfig (NComp 2) False) - [F.col @Double "x", F.col @Double "const"] - df - ratio = VU.toList (pcaExplainedVarianceRatio m) - assertBool "explained ratios finite" (all finite ratio) - assertBool "explained ratios sum to ~1" (close 1e-9 (sum ratio) 1) - -- the variance is entirely along x, so the top ratio must be ~1 - assertBool "first PC explains ~all variance" (close 1e-9 (head ratio) 1) - -- projection exprs must evaluate to finite numbers - let es = map snd (pcaExprs m) - assertBool - "pca exprs finite on constant column" - (all (all finite . interpD df) es) - -{- PCA on extreme-scale features (1e8-shifted) without standardisation: the - covariance entries are ~1 (variance of {1,2,3}) despite the 1e8 offset. - Components must stay unit-length and finite -- catches cancellation in the - covariance / eigendecomposition at large magnitudes. -} -testPCAExtremeScale :: Test -testPCAExtremeScale = TestCase $ do - let df = - D.fromNamedColumns - [ ("x", DI.fromList ([1e8 + 1, 1e8 + 2, 1e8 + 3, 1e8 + 4] :: [Double])) - , ("y", DI.fromList ([1e8 + 1, 1e8 + 2, 1e8 + 3, 1e8 + 4] :: [Double])) - ] - m = - fit - (PCAConfig (NComp 1) False) - [F.col @Double "x", F.col @Double "y"] - df - comp0 = pcaComponents m V.! 0 - nrm = sqrt (VU.sum (VU.map (^ (2 :: Int)) comp0)) - assertBool "component finite at 1e8 scale" (VU.all finite comp0) - assertBool "component unit length at 1e8 scale" (close 1e-6 nrm 1) - assertBool - "explained ratio finite at 1e8 scale" - (VU.all finite (pcaExplainedVarianceRatio m)) - --- =========================================================================== --- Category 7/8: linear-algebra degeneracy --- =========================================================================== - -{- choleskySolve on a non-positive-definite (zero) matrix returns Nothing rather - than crashing or producing NaNs. A 2x2 all-zero matrix has a zero pivot. -} -testCholeskyNonPD :: Test -testCholeskyNonPD = TestCase $ do - assertEqual - "cholesky of singular zero matrix is Nothing" - Nothing - (choleskySolve (mat [[0, 0], [0, 0]]) (VU.fromList [1, 1])) - -{- Jacobi eigendecomposition of a 1x1 matrix (one-column degenerate case): - eigenvalue is the single entry, eigenvector is [1] (sign-canonicalised). -} -testJacobi1x1 :: Test -testJacobi1x1 = TestCase $ do - let (ev, vecs) = jacobiEigenSym (mat [[5]]) - assertBool "1x1 eigenvalue is the entry" (close 1e-12 (ev VU.! 0) 5) - assertBool "1x1 eigenvector is [1]" (close 1e-12 ((vecs V.! 0) VU.! 0) 1) - -{- Jacobi on an identity matrix: both eigenvalues are exactly 1 and the result is - finite (the rotation angle code must not divide by zero when off-diagonals are - already 0). -} -testJacobiIdentity :: Test -testJacobiIdentity = TestCase $ do - let (ev, vecs) = jacobiEigenSym (mat [[1, 0], [0, 1]]) - assertBool "identity eigenvalues both 1" (VU.all (close 1e-12 1) ev) - assertBool "identity eigenvectors finite" (all (VU.all finite) (V.toList vecs)) - -tests :: [Test] -tests = - [ testLogSumExpLargePositive - , testLogSumExpLargeNegative - , testLogSumExpSingleton - , testSigmoidExtreme - , testVarianceCatastrophicCancellation - , testVarianceConstant - , testVarianceSingleton - , testCorrelationPerfect - , testCorrelationConstantColumnIsNaN - , testCorrelationTooFew - , testLogisticProbsExtremeFeatures - , testOLSOneRow - , testLogisticSingleClass - , testLogisticConstantFeatureIgnored - , testLinearConstantFeatureZeroWeight - , testKMeansKGreaterThanN - , testKMeansAllIdentical - , testGMMKGreaterThanN - , testPCAConstantColumn - , testPCAExtremeScale - , testCholeskyNonPD - , testJacobi1x1 - , testJacobiIdentity - ] diff --git a/tests/Learn/Ensembles.hs b/tests/Learn/Ensembles.hs --- a/tests/Learn/Ensembles.hs +++ b/tests/Learn/Ensembles.hs @@ -14,11 +14,10 @@ import DataFrame.DBSCAN import DataFrame.GMM import DataFrame.LinearModel -import DataFrame.LinearSolver (defaultSolverConfig) import DataFrame.Metrics (r2) import DataFrame.ModelSelection -import Data.Maybe (isJust, isNothing) +import Data.Maybe (isJust, isNothing, listToMaybe) import qualified Data.Vector.Unboxed as VU import DataFrame.Model (fit, predict) import Test.HUnit @@ -97,7 +96,9 @@ blobs assigns = interpI blobs (predict m) assertBool "GMM converged" (gmmConverged m) - assertBool "GMM splits the blobs" (head assigns /= last assigns) + assertBool + "GMM splits the blobs" + (listToMaybe assigns /= listToMaybe (reverse assigns)) let m2 = fit defaultGMMConfig{gmmK = 2, gmmSeed = 1} @@ -138,12 +139,15 @@ , DI.fromList ([2 * fromIntegral i + 5 | i <- [1 .. 40 :: Int]] :: [Double]) ) ] - score alpha train test = + score alpha train test' = let mdl = - fit (LinearConfig (Ridge alpha) defaultSolverConfig) (F.col @Double "y") train + fit + (LinearConfig (Ridge alpha) defaultSolverConfig) + (F.col @Double "y") + (train :: D.DataFrame) in r2 - (VU.fromList (interpD test (predict mdl))) - (VU.fromList (interpD test (F.col @Double "y"))) + (VU.fromList (interpD test' (predict mdl))) + (VU.fromList (interpD test' (F.col @Double "y"))) res = gridSearch 4 7 [0.0, 1.0, 100.0] score df assertBool "best score high" (gsBestScore res > 0.99) assertEqual "all configs scored" 3 (length (gsAll res)) diff --git a/tests/Learn/MetricsTests.hs b/tests/Learn/MetricsTests.hs --- a/tests/Learn/MetricsTests.hs +++ b/tests/Learn/MetricsTests.hs @@ -8,7 +8,6 @@ import qualified DataFrame.Internal.Column as DI import DataFrame.LinearModel -import DataFrame.LinearSolver (defaultSolverConfig) import DataFrame.Metrics import DataFrame.Metrics.Report import DataFrame.ModelSelection @@ -48,14 +47,12 @@ testMulticlassMetrics :: Test testMulticlassMetrics = TestCase $ do assertBool "accuracy" (close 1e-9 (accuracy preds3 truth3) 0.875) - -- class 1: tp=2 (idx2,6), fp=1 (idx3) -> precision 2/3 assertBool "binary precision class 1" (close 1e-9 (precision (Binary 1) preds3 truth3) (2 / 3)) assertBool "macro f1 sane" (f1 Macro preds3 truth3 > 0.8 && f1 Macro preds3 truth3 <= 1) - -- micro f1 == accuracy for single-label assertBool "micro f1 == accuracy" (close 1e-9 (f1 Micro preds3 truth3) (accuracy preds3 truth3)) @@ -74,7 +71,6 @@ assertBool "report accuracy" (close 1e-9 (crAccuracy cr) 0.875) let rr = regressionReport (VU.fromList [1, 2, 3]) (VU.fromList [1, 2, 4]) assertBool "regression report rmse" (rrRMSE rr > 0) - -- Show instances don't crash assertBool "classification report shows" (not (null (show cr))) assertBool "confusion shows" (not (null (show (confusionMatrix preds3 truth3)))) @@ -103,7 +99,6 @@ testTransformCompose = TestCase $ do let scaler = standardScaler ["x"] reg pca = fit (PCAConfig (NComp 1) False) [F.col @Double "x"] reg - -- the whole point: scaler <> pcaTransform compose as a monoid pipeline = scalerTransform scaler <> pcaTransform pca out = applyTransform pipeline reg assertBool "pipeline produced a frame" (D.columnNames out /= []) diff --git a/tests/Learn/Models.hs b/tests/Learn/Models.hs --- a/tests/Learn/Models.hs +++ b/tests/Learn/Models.hs @@ -14,15 +14,17 @@ import DataFrame.DecisionTree.Regression import DataFrame.KMeans import DataFrame.LinearModel -import DataFrame.LinearSolver (SolverConfig (..), defaultSolverConfig) import DataFrame.PCA import DataFrame.SVM import DataFrame.Transform +import Control.Exception (evaluate, try) +import Data.List (isInfixOf) import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.Vector.Unboxed as VU +import DataFrame.Errors (DataFrameException) import DataFrame.Model (fit, predict) import Test.HUnit @@ -50,6 +52,19 @@ xs1 = [1, 2, 3, 4, 5, 6, 7, 8] :: [Double] xs2 = [2, 1, 4, 3, 6, 5, 8, 7] :: [Double] +-- | A custom enum label type — logistic regression must classify into it. +data Flower = Rose | Tulip | Daisy deriving (Show, Eq, Ord) + +flowerDF :: D.DataFrame +flowerDF = + D.fromNamedColumns + [ ("x", DI.fromList ([-5, -4, -3, 0, 0.3, 0.6, 5, 6, 7] :: [Double])) + , + ( "flower" + , DI.fromList [Rose, Rose, Rose, Tulip, Tulip, Tulip, Daisy, Daisy, Daisy] + ) + ] + clsDF :: D.DataFrame clsDF = D.fromNamedColumns @@ -68,6 +83,58 @@ truth = interpD regDF (F.col @Double "y") assertBool "OLS expr matches y" (and (zipWith (close 1e-6) preds truth)) +{- | A regression frame whose feature column @x@ is stored as @Int@; the target +@y@ is @Double@. Fitting must reject the Int feature at the boundary. +-} +intFeatureDF :: D.DataFrame +intFeatureDF = + D.fromNamedColumns + [ ("x", DI.fromList @Int [1 .. 8]) + , ("y", DI.fromList @Double [2, 4, 6, 8, 10, 12, 14, 16]) + ] + +{- | The fit boundary mandates Double: a non-Double feature column is a fit-time +error (naming the column and pointing at the fix), not a silent coercion. +-} +testFitRequiresDouble :: Test +testFitRequiresDouble = TestCase $ do + let m = fit defaultLinearConfig (F.col @Double "y") intFeatureDF + result <- + try (evaluate (VU.sum (regCoef m))) :: IO (Either DataFrameException Double) + case result of + Left e -> do + let msg = show e + assertBool "error mentions the Double requirement" ("Double" `isInfixOf` msg) + assertBool "error names the offending column x" ("x" `isInfixOf` msg) + Right _ -> assertFailure "expected a Double-input error for the Int feature column" + +{- | A regression frame whose feature @x@ is nullable (@Maybe Double@). Fitting +must reject it rather than letting nulls poison the solve into NaN. +-} +nullableFeatureDF :: D.DataFrame +nullableFeatureDF = + D.fromNamedColumns + [ ("x", DI.fromList @(Maybe Double) (Nothing : map Just [2, 3, 4, 5, 6, 7, 8])) + , ("y", DI.fromList @Double [2, 4, 6, 8, 10, 12, 14, 16]) + ] + +{- | The fit boundary rejects a nullable (Maybe Double) input column with an +actionable error, instead of silently producing NaN coefficients. +-} +testFitRejectsNullable :: Test +testFitRejectsNullable = TestCase $ do + let m = fit defaultLinearConfig (F.col @Double "y") nullableFeatureDF + result <- + try (evaluate (VU.sum (regCoef m))) :: IO (Either DataFrameException Double) + case result of + Left e -> do + let msg = show e + assertBool + "error flags the non-null requirement" + ("non-null Double" `isInfixOf` msg) + assertBool "error names the nullable column x" ("x" `isInfixOf` msg) + Right _ -> assertFailure "expected a nullable-input error for the Maybe Double feature" + testRidgeShrinks :: Test testRidgeShrinks = TestCase $ do let r0 = @@ -86,6 +153,18 @@ let probs = logisticProbExprs m assertBool "prob exprs present for both classes" (M.size probs == 2) +{- | Logistic regression must work with any enum label type, not just Int — +multiclass classification into a user-defined sum type. +-} +testLogisticEnumLabel :: Test +testLogisticEnumLabel = TestCase $ do + let m = fit defaultLogisticConfig (F.col @Flower "flower") flowerDF + preds = case interpret @Flower flowerDF (predict m) of + Right (TColumn c) -> either (const []) V.toList (toVector @Flower @V.Vector c) + Left e -> error (show e) + truth = [Rose, Rose, Rose, Tulip, Tulip, Tulip, Daisy, Daisy, Daisy] + assertEqual "logistic recovers enum-typed labels" truth preds + testSVC :: Test testSVC = TestCase $ do let m = fit defaultSVCConfig (F.col @Int "label") clsDF @@ -146,7 +225,6 @@ let scaler = standardScaler ["x1", "x2"] regDF t = scalerTransform scaler scaledDf = applyTransform t regDF - -- fit model on scaled features, then compile scaling into the expr m = fit defaultLinearConfig (F.col @Double "y") scaledDf composed = compileThrough t (predict m) viaCompose = interpD regDF composed @@ -158,8 +236,11 @@ tests :: [Test] tests = [ testOLS + , testFitRequiresDouble + , testFitRejectsNullable , testRidgeShrinks , testLogistic + , testLogisticEnumLabel , testSVC , testRegressionTree , testClassifierStats diff --git a/tests/Learn/NumericalRigor.hs b/tests/Learn/NumericalRigor.hs deleted file mode 100644 --- a/tests/Learn/NumericalRigor.hs +++ /dev/null @@ -1,438 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -{- | Numerical-rigor suite: gradient checks (cat 4), reproducibility across the -stochastic models (cat 16), and statistical / distributional properties of the -RNG and splitters (cat 5). Every test is constructed to FAIL on a real bug — no -@assertEqual v v@, no rubber tolerances. --} -module Learn.NumericalRigor (tests) where - -import qualified DataFrame as D -import qualified DataFrame.Functions as F -import qualified DataFrame.Internal.Column as DI - -import DataFrame.GMM -import DataFrame.KMeans -import DataFrame.LinearSolver.Loss ( - SmoothLoss (..), - logisticLoss, - sigmoid, - sqHingeLoss, - squaredLoss, - ) -import DataFrame.Model (fit) -import DataFrame.ModelSelection (trainTestSplit) -import DataFrame.Random -import DataFrame.SVM.RFF - -import qualified Data.Vector.Unboxed as VU -import Test.HUnit - --- --------------------------------------------------------------------------- --- Independent reference loss VALUE functions. --- --- The library only exposes the gradient 'slGradZ'; the per-loss scalar value is --- reconstructed here straight from the module's own documented definitions, so --- the finite difference below is computed INDEPENDENTLY of the analytic --- gradient (anti-tautology: never finite-difference a gradient against itself). --- --------------------------------------------------------------------------- - --- | @½ (z - y)²@ (squaredLoss). -squaredValue :: Double -> Double -> Double -squaredValue y z = 0.5 * (z - y) * (z - y) - --- | @log (1 + exp (-y z))@ (logisticLoss). softplus form, numerically stable. -logisticValue :: Double -> Double -> Double -logisticValue y z = - let m = negate (y * z) - in if m >= 0 then m + log1pExp (negate m) else log1pExp m - where - log1pExp x = log (1 + exp x) - --- | @(max 0 (1 - y z))²@ (sqHingeLoss). -sqHingeValue :: Double -> Double -> Double -sqHingeValue y z = let m = 1 - y * z in if m > 0 then m * m else 0 - --- | Central finite difference of @f@ in @z@ at @(y, z)@. -centralDiff :: - (Double -> Double -> Double) -> Double -> Double -> Double -> Double -centralDiff f eps y z = (f y (z + eps) - f y (z - eps)) / (2 * eps) - -{- | Gradient-check one 'SmoothLoss' against its reference value fn over a grid -of @(y, z)@ points (both labels in @{ -1, +1 }@, many margins including the hinge -kink neighbourhood). Fails if the analytic gradient differs from the finite -difference anywhere beyond @tol@. --} -gradCheck :: - String -> - SmoothLoss -> - (Double -> Double -> Double) -> - Double -> - Test -gradCheck nm loss valueFn tol = - TestCase $ - mapM_ check [(y, z) | y <- [-1, 1], z <- zs] - where - -- margins, deliberately avoiding the exact hinge kink z = y (m = 0) where - -- the squared-hinge second derivative is discontinuous; central diff is - -- still valid away from the kink. - zs = [-3.7, -2.1, -1.25, -0.6, -0.15, 0.22, 0.55, 1.4, 1.9, 2.8, 4.3] - check (y, z) = do - let analytic = slGradZ loss y z - fd = centralDiff valueFn 1e-6 y z - ok = abs (analytic - fd) <= tol * (1 + abs fd) - assertBool - ( nm - ++ " grad mismatch at (y=" - ++ show y - ++ ", z=" - ++ show z - ++ "): analytic=" - ++ show analytic - ++ " finite-diff=" - ++ show fd - ) - ok - --- | The squared-loss gradient @z - y@ checked against ½(z-y)². -testSquaredGradient :: Test -testSquaredGradient = gradCheck "squared" squaredLoss squaredValue 1e-5 - --- | The logistic gradient @-y·σ(-y z)@ checked against log(1+exp(-yz)). -testLogisticGradient :: Test -testLogisticGradient = gradCheck "logistic" logisticLoss logisticValue 1e-5 - --- | The squared-hinge gradient @-2y·max(0,1-yz)@ checked against (max 0 (1-yz))². -testSqHingeGradient :: Test -testSqHingeGradient = gradCheck "squared_hinge" sqHingeLoss sqHingeValue 1e-5 - -{- | Sign sanity that cannot be passed by a self-referential check: at a point -where the loss is strictly increasing in @z@ the analytic gradient must be -positive (and vice versa). Catches a flipped-sign gradient even if its -magnitude were somehow right. logistic with y=+1 decreases in z, so grad < 0; -squared with z>y increases, so grad > 0. --} -testGradientSigns :: Test -testGradientSigns = TestCase $ do - assertBool - "squared: grad>0 when z>y (loss rising)" - (slGradZ squaredLoss 1.0 3.0 > 0) - assertBool - "squared: grad<0 when z0" - (slGradZ logisticLoss (-1.0) 0.5 > 0) - assertBool - "sqHinge active margin y=+1: grad<0" - (slGradZ sqHingeLoss 1.0 0.0 < 0) - assertBool - "sqHinge satisfied margin: grad==0" - (slGradZ sqHingeLoss 1.0 5.0 == 0) - --- --------------------------------------------------------------------------- --- Statistical / distributional tests (cat 5). --- --- Tolerances are CI-derived from the sample size; with N = 100k the standard --- error of a uniform-mean estimate is ~ (1/sqrt12)/sqrt(N) ~ 8.3e-4, so a 6σ --- band is ~ 5e-3. A broken sampler (e.g. one that returns the same value, or --- biased) falls well outside. --- --------------------------------------------------------------------------- - --- | Draw @n@ uniforms threading the generator; returns the sample list. -drawUniforms :: Int -> Gen -> [Double] -drawUniforms n g0 = go n g0 [] - where - go 0 _ acc = acc - go k g acc = let (x, g') = nextDouble g in go (k - 1) g' (x : acc) - -mean :: [Double] -> Double -mean xs = sum xs / fromIntegral (length xs) - -variance :: [Double] -> Double -variance xs = - let m = mean xs - in sum [(x - m) * (x - m) | x <- xs] / fromIntegral (length xs) - -{- | @nextDouble@ is ~uniform on [0,1): mean ≈ 0.5 and variance ≈ 1/12, each -within a 6σ CI for 100k samples, AND every draw is in [0,1). A constant or -out-of-range sampler fails; a biased one (mean drifts) fails. --} -testUniformDistribution :: Test -testUniformDistribution = TestCase $ do - let n = 100000 :: Int - xs = drawUniforms n (mkGen 20240613) - m = mean xs - v = variance xs - seMean = (1 / sqrt 12) / sqrt (fromIntegral n) - assertBool "all uniforms in [0,1)" (all (\x -> x >= 0 && x < 1) xs) - assertBool - ("uniform mean ~0.5, got " ++ show m) - (abs (m - 0.5) <= 6 * seMean) - assertBool - ("uniform variance ~1/12, got " ++ show v) - (abs (v - 1 / 12) <= 0.01) - -- not a constant: spread across the unit interval - assertBool "uniform actually varies" (maximum xs - minimum xs > 0.9) - -{- | Box-Muller @gaussianVector@ produces standard normals: sample mean ≈ 0 and -variance ≈ 1 over 100k draws. SE of the mean is 1/sqrt(N) ~ 3.2e-3, so a 6σ -band ~ 2e-2. Catches a Box-Muller bug (wrong radius/angle, missing log) that -shifts the mean or scales the variance. --} -testGaussianMoments :: Test -testGaussianMoments = TestCase $ do - let n = 100000 :: Int - (vec, _) = gaussianVector n (mkGen 777) - xs = VU.toList vec - m = mean xs - v = variance xs - seMean = 1 / sqrt (fromIntegral n) - assertBool "gaussianVector length" (VU.length vec == n) - assertBool - "gaussian samples finite" - (all (\x -> not (isNaN x) && not (isInfinite x)) xs) - assertBool - ("gaussian mean ~0, got " ++ show m) - (abs m <= 6 * seMean) - assertBool - ("gaussian variance ~1, got " ++ show v) - (abs (v - 1) <= 0.03) - -- tail mass: ~4.55% should be |x|>2 for a true N(0,1); allow a wide band. - let tail2 = fromIntegral (length (filter (\x -> abs x > 2) xs)) / fromIntegral n - assertBool - ("gaussian |x|>2 frequency ~0.0455, got " ++ show tail2) - (abs (tail2 - 0.0455) <= 0.01) - -{- | @trainTestSplit frac@ over many seeds: the realized train fraction matches -@frac@ within a binomial CI, and train+test always sums to the input row count -(cat 2 invariant). A split that loses/dupes rows, or ignores @frac@, fails. --} -testSplitProportions :: Test -testSplitProportions = TestCase $ do - let nRows = 4000 - frac = 0.7 :: Double - df = D.fromNamedColumns [("x", DI.fromList [1 .. nRows :: Int])] - seeds = [1 .. 25] :: [Int] - -- binomial SE of the fraction for n=4000 ~ sqrt(0.7*0.3/4000) ~ 7.2e-3 - seFrac = sqrt (frac * (1 - frac) / fromIntegral nRows) - mapM_ - ( \s -> do - let (tr, te) = trainTestSplit frac s df - nTr = fst (D.dimensions tr) - nTe = fst (D.dimensions te) - realized = fromIntegral nTr / fromIntegral nRows - assertEqual - ("split preserves rows (seed " ++ show s ++ ")") - nRows - (nTr + nTe) - assertBool - ( "split fraction ~" - ++ show frac - ++ " (seed " - ++ show s - ++ "), got " - ++ show realized - ) - (abs (realized - frac) <= 5 * seFrac) - ) - seeds - -{- | k-means inertia on a clean, well-separated blob is stable across many -seeds and never beats the true within-cluster sum of squares of the generating -partition (the global optimum here is the obvious 2-cluster split). A broken -inertia (wrong distance, double counting) would report values below the optimum -or wildly seed-dependent. --} -testKMeansInertiaStable :: Test -testKMeansInertiaStable = TestCase $ do - let - -- two tight gaussian-ish blobs around (0,0) and (10,10) - as = [0, 0.1, -0.1, 0.05, -0.05, 10, 10.1, 9.9, 10.05, 9.95] :: [Double] - bs = [0, -0.1, 0.1, 0.05, -0.05, 10, 9.9, 10.1, 9.95, 10.05] :: [Double] - df = D.fromNamedColumns [("a", DI.fromList as), ("b", DI.fromList bs)] - fitSeed s = - kmInertia $ - fit - defaultKMeansConfig{kmK = 2, kmNInit = 1, kmSeed = s} - [F.col @Double "a", F.col @Double "b"] - df - inertias = map fitSeed [0 .. 19] - -- optimum: each blob's SS about its own mean. Blob means are ~ the - -- centroid; compute the true within-cluster SS for the 2-cluster split. - blob1 = take 5 (zip as bs) - blob2 = zip (drop 5 as) (drop 5 bs) - ssOf pts = - let mx = sum (map fst pts) / 5 - my = sum (map snd pts) / 5 - in sum [(x - mx) ^ (2 :: Int) + (y - my) ^ (2 :: Int) | (x, y) <- pts] - optimum = ssOf blob1 + ssOf blob2 - best = minimum inertias - worst = maximum inertias - assertBool - "k-means inertia finite" - (all (\i -> not (isNaN i) && not (isInfinite i)) inertias) - assertBool - ( "k-means inertia never below optimum (" - ++ show optimum - ++ "), best=" - ++ show best - ) - (best >= optimum - 1e-9) - assertBool - ( "k-means inertia stable across seeds, best=" - ++ show best - ++ " worst=" - ++ show worst - ) - (worst - best <= 1e-6 + 1e-3 * optimum) - --- --------------------------------------------------------------------------- --- Reproducibility tests (cat 16). --- --- Each compares two SEPARATE fits with the same seed (determinism) AND, where --- the seed is a real input, asserts that a DIFFERENT seed CAN change the model --- (so "always returns a constant" wouldn't pass). Models that derive Eq are --- compared with ==; others by a representative field or predicted expr. --- --------------------------------------------------------------------------- - -blobsDF :: D.DataFrame -blobsDF = - D.fromNamedColumns - [ - ( "a" - , DI.fromList ([0, 0.2, -0.1, 0.1, 8, 8.1, 7.9, 8.2, 0.05, 8.05] :: [Double]) - ) - , - ( "b" - , DI.fromList ([0, -0.1, 0.2, 0.0, 5, 5.2, 4.9, 5.1, 0.1, 5.05] :: [Double]) - ) - ] - --- | Many-cluster frame so k-means++ seeding genuinely depends on the seed. -spreadDF :: D.DataFrame -spreadDF = - D.fromNamedColumns - [ ("a", DI.fromList ([0, 1, 2, 10, 11, 12, 20, 21, 22, 30, 31, 32] :: [Double])) - , ("b", DI.fromList ([0, 1, 0, 10, 11, 10, 0, 1, 0, 10, 11, 10] :: [Double])) - ] - -{- | k-means: same seed → identical KMeansModel (Eq derived); a different seed -on a multi-blob frame CAN yield different centers (the seed actually drives -k-means++ init). Single-init so the seed is not washed out by nInit restarts. --} -testKMeansReproducible :: Test -testKMeansReproducible = TestCase $ do - let cfg s = defaultKMeansConfig{kmK = 4, kmNInit = 1, kmMaxIter = 1, kmSeed = s} - run s = fit (cfg s) [F.col @Double "a", F.col @Double "b"] - a = run 1 spreadDF - b = run 1 spreadDF - assertEqual "k-means same seed identical model" a b - -- different seeds CAN differ: scan several and require at least one diff in - -- the initial centroids (1 iteration keeps the init's footprint). - let centersFor s = kmCenters (run s spreadDF) - base = centersFor 1 - anyDiffer = any (\s -> centersFor s /= base) [2, 3, 5, 7, 11, 13] - assertBool "k-means: a different seed changes the model" anyDiffer - -{- | GMM: same seed → identical GMMModel (Eq derived); a different seed CAN move -the fitted means (seed drives the responsibility init via sampleIndices). --} -testGMMReproducible :: Test -testGMMReproducible = TestCase $ do - let cfg s = defaultGMMConfig{gmmK = 2, gmmMaxIter = 1, gmmSeed = s} - run s = fit (cfg s) [F.col @Double "a", F.col @Double "b"] blobsDF - a = run 1 - b = run 1 - assertEqual "GMM same seed identical model" a b - let meansFor s = gmmMeans (run s) - base = meansFor 1 - anyDiffer = any (\s -> meansFor s /= base) [2, 3, 4, 5, 6, 7, 8] - assertBool "GMM: a different seed changes the means" anyDiffer - -{- | RFF-SVM: same seed → identical random projection AND identical fitted SVC -coefficients; a different seed changes the random Fourier features. The model -type only derives Show, so compare representative numeric fields directly. --} -testRFFReproducible :: Test -testRFFReproducible = TestCase $ do - let clsDF = - D.fromNamedColumns - [ ("x", DI.fromList ([-3, -2, -1, -0.5, 0.5, 1, 2, 3] :: [Double])) - , ("label", DI.fromList ([0, 0, 0, 0, 1, 1, 1, 1] :: [Int])) - ] - cfg s = defaultRFFConfig{rffD = 40, rffGamma = 0.2, rffSeed = s} - run s = fit (cfg s) (F.col @Int "label") clsDF - a = run 5 - b = run 5 - -- projection matrix and the fitted SVC coefficients must match bit-for-bit. - assertEqual "RFF same seed: same projection B" (rffB a) (rffB b) - assertEqual "RFF same seed: same coefficients" (rffCoef a) (rffCoef b) - assertEqual "RFF same seed: same intercept" (rffIntercept a) (rffIntercept b) - -- different seed: the random projection should differ. - let projFor s = rffB (run s) - base = projFor 5 - anyDiffer = any (\s -> projFor s /= base) [1, 2, 3, 6, 7, 8] - assertBool "RFF: a different seed changes the projection" anyDiffer - --- --------------------------------------------------------------------------- --- randomSplit / trainTestSplit determinism + row-count invariant (cat 16 + 2). --- --------------------------------------------------------------------------- - -{- | @trainTestSplit@ with the same seed is bit-identical (compared via the -prettyPrinted frames), preserves total rows, and a different seed CAN change the -partition. --} -testSplitReproducible :: Test -testSplitReproducible = TestCase $ do - let df = D.fromNamedColumns [("x", DI.fromList [1 .. 200 :: Int])] - (tr1, te1) = trainTestSplit 0.6 42 df - (tr2, te2) = trainTestSplit 0.6 42 df - assertBool "trainTestSplit same seed: same train" (tr1 == tr2) - assertBool "trainTestSplit same seed: same test" (te1 == te2) - assertEqual - "trainTestSplit preserves row count" - 200 - (fst (D.dimensions tr1) + fst (D.dimensions te1)) - let trainFor s = fst (trainTestSplit 0.6 s df) - base = trainFor 42 - anyDiffer = any (\s -> trainFor s /= base) [1, 2, 3, 7, 99] - assertBool "trainTestSplit: a different seed changes the partition" anyDiffer - --- --------------------------------------------------------------------------- --- A self-consistency sanity for the helpers above so a broken reference value --- fn cannot make the gradient checks vacuous: the reference squared value must --- actually be ½(z-y)² at a known point. --- --------------------------------------------------------------------------- -testReferenceValueSanity :: Test -testReferenceValueSanity = TestCase $ do - assertBool - "squaredValue at (y=2,z=5) == 4.5" - (abs (squaredValue 2 5 - 4.5) < 1e-12) - assertBool - "logisticValue at (y=1,z=0) == log 2" - (abs (logisticValue 1 0 - log 2) < 1e-12) - assertBool "sqHingeValue at (y=1,z=0) == 1" (abs (sqHingeValue 1 0 - 1) < 1e-12) - assertBool "sigmoid 0 == 0.5" (abs (sigmoid 0 - 0.5) < 1e-12) - -tests :: [Test] -tests = - [ testReferenceValueSanity - , testSquaredGradient - , testLogisticGradient - , testSqHingeGradient - , testGradientSigns - , testUniformDistribution - , testGaussianMoments - , testSplitProportions - , testKMeansInertiaStable - , testKMeansReproducible - , testGMMReproducible - , testRFFReproducible - , testSplitReproducible - ] diff --git a/tests/Learn/Numerics.hs b/tests/Learn/Numerics.hs deleted file mode 100644 --- a/tests/Learn/Numerics.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Learn.Numerics (tests) where - -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import DataFrame.Model (fit, predict) -import Test.HUnit - -import DataFrame.LinearAlgebra -import DataFrame.LinearAlgebra.Eigen -import DataFrame.LinearAlgebra.Solve -import DataFrame.Random - -mat :: [[Double]] -> Matrix -mat = V.fromList . map VU.fromList - -approx :: Double -> Double -> Double -> Bool -approx tol a b = abs (a - b) <= tol - -vApprox :: Double -> VU.Vector Double -> VU.Vector Double -> Bool -vApprox tol a b = - VU.length a == VU.length b && VU.and (VU.zipWith (approx tol) a b) - -testQR :: Test -testQR = TestCase $ do - let a = mat [[1, 1], [1, 2], [1, 3], [1, 4]] - b = VU.fromList [3, 5, 7, 9] - case qrLeastSquares a b of - Right x -> - assertBool "QR recovers [1,2]" (vApprox 1e-9 x (VU.fromList [1, 2])) - Left cols -> assertFailure ("unexpected rank deficiency: " ++ show cols) - -testQRRankDeficient :: Test -testQRRankDeficient = TestCase $ do - let a = mat [[1, 2], [2, 4], [3, 6]] - case qrLeastSquares a (VU.fromList [1, 2, 3]) of - Left _ -> pure () - Right _ -> assertFailure "expected rank deficiency on collinear columns" - -testCholesky :: Test -testCholesky = TestCase $ do - let a = mat [[4, 2], [2, 3]] - case choleskySolve a (VU.fromList [2, 1]) of - Just x -> - assertBool "cholesky solves" (vApprox 1e-9 x (VU.fromList [0.5, 0])) - Nothing -> assertFailure "expected PD" - assertEqual "non-PD rejected" Nothing (cholesky (mat [[1, 2], [2, 1]])) - -testJacobi :: Test -testJacobi = TestCase $ do - let (ev, vecs) = jacobiEigenSym (mat [[2, 1], [1, 2]]) - assertBool "eigenvalues [3,1]" (vApprox 1e-9 ev (VU.fromList [3, 1])) - let v0 = vecs V.! 0 - recon = matVec (mat [[2, 1], [1, 2]]) v0 - assertBool - "A v = lambda v" - (vApprox 1e-9 recon (scaleV (ev VU.! 0) v0)) - -testPowerIter :: Test -testPowerIter = TestCase $ do - let (lam, _) = powerIterTop 200 (mat [[2, 1], [1, 2]]) - assertBool "dominant eigenvalue ~3" (approx 1e-6 lam 3) - -testLogSumExp :: Test -testLogSumExp = TestCase $ do - let xs = VU.fromList [1000, 1001, 1002] - lse = logSumExp xs - assertBool "logSumExp stable, finite" (not (isNaN lse) && not (isInfinite lse)) - assertBool "logSumExp >= max" (lse >= 1002) - -testRngDeterminism :: Test -testRngDeterminism = TestCase $ do - let (a, _) = shuffleInts 50 (mkGen 11) - (b, _) = shuffleInts 50 (mkGen 11) - assertEqual "same seed same shuffle" a b - assertBool - "is a permutation" - (VU.toList (VU.modify (const (pure ())) a) /= [] && all (`VU.elem` a) [0 .. 49]) - -testRngRange :: Test -testRngRange = TestCase $ do - let go 0 _ acc = acc - go k g acc = - let (x, g') = nextIntR (3, 7) g in go (k - 1 :: Int) g' (x : acc) - xs = go 1000 (mkGen 5) [] - assertBool "ints within range" (all (\x -> x >= 3 && x <= 7) xs) - -tests :: [Test] -tests = - [ testQR - , testQRRankDeficient - , testCholesky - , testJacobi - , testPowerIter - , testLogSumExp - , testRngDeterminism - , testRngRange - ] diff --git a/tests/Learn/Segmented.hs b/tests/Learn/Segmented.hs new file mode 100644 --- /dev/null +++ b/tests/Learn/Segmented.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Learn.Segmented (tests) where + +import Control.Exception (SomeException, evaluate, try) +import Data.List (isInfixOf) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU + +import qualified DataFrame as D +import qualified DataFrame.Functions as F +import DataFrame.Internal.Column (TypedColumn (..), toVector) +import qualified DataFrame.Internal.Column as DI +import DataFrame.Internal.Expression (Expr) +import DataFrame.Internal.Interpreter (interpret) + +import DataFrame.LinearModel.Logistic (defaultLogisticConfig) +import DataFrame.LinearModel.Regression ( + LinearRegressor (..), + defaultLinearConfig, + ) +import DataFrame.Metrics (rmse) +import DataFrame.ModelSelection (crossValidate) +import DataFrame.Segmented +import DataFrame.SymbolicRegression (SRConfig (..), SRModel, defaultSRConfig) + +import Test.HUnit + +interpD :: D.DataFrame -> Expr Double -> [Double] +interpD df e = case interpret @Double df e of + Right (TColumn c) -> either (const []) VU.toList (toVector @Double @VU.Vector c) + Left err -> error (show err) + +interpT :: D.DataFrame -> Expr T.Text -> [T.Text] +interpT df e = case interpret @T.Text df e of + Right (TColumn c) -> either (const []) V.toList (toVector @T.Text @V.Vector c) + Left err -> error (show err) + +close :: Double -> Double -> Double -> Bool +close tol a b = abs (a - b) <= tol + +-- | A two-segment frame: y = 2x+1 on group "a", y = -3x+5 on group "b". +twoSegDF :: D.DataFrame +twoSegDF = + D.fromNamedColumns + [ ("g", DI.fromList (replicate 4 ("a" :: T.Text) ++ replicate 4 "b")) + , ("x", DI.fromList xs) + , + ( "y" + , DI.fromList ([2 * x + 1 | x <- take 4 xs] ++ [(-3) * x + 5 | x <- drop 4 xs]) + ) + ] + where + xs = [1, 2, 3, 4, 1, 2, 3, 4] :: [Double] + +segByKey :: + [T.Text] -> SegmentedModel a LinearRegressor -> Segment LinearRegressor +segByKey k m = head [s | s <- smSegments m, segKey s == k] + +lowFloor :: Segmented cfg -> Segmented cfg +lowFloor s = s{segMinRows = 3} + +recoveryTests :: [Test] +recoveryTests = + [ "per-segment OLS recovered" ~: do + let m = fit (lowFloor (segmented defaultLinearConfig)) (F.col @Double "y") twoSegDF + a = segModel (segByKey ["a"] m) + b = segModel (segByKey ["b"] m) + assertBool "two segments" (length (smSegments m) == 2) + assertBool "a slope ~ 2" (close 1e-9 (regCoef a VU.! 0) 2) + assertBool "a intercept ~ 1" (close 1e-9 (regIntercept a) 1) + assertBool "b slope ~ -3" (close 1e-9 (regCoef b VU.! 0) (-3)) + assertBool "b intercept ~ 5" (close 1e-9 (regIntercept b) 5) + , "prediction reproduces y" ~: do + let m = fit (lowFloor (segmented defaultLinearConfig)) (F.col @Double "y") twoSegDF + preds = interpD twoSegDF (predict m) + truth = interpD twoSegDF (F.col @Double "y") + assertBool "routed predictions match y" (and (zipWith (close 1e-6) preds truth)) + ] + +routingTests :: [Test] +routingTests = + [ "unseen category routes to fallback" ~: do + let m = fit (lowFloor (segmented defaultLinearConfig)) (F.col @Double "y") twoSegDF + fb = smFallback m + unseen = + D.fromNamedColumns + [ ("g", DI.fromList (["c"] :: [T.Text])) + , ("x", DI.fromList ([2.0] :: [Double])) + , ("y", DI.fromList ([0.0] :: [Double])) + ] + p = case interpD unseen (predict m) of + [p'] -> p' + _ -> error "Expecting only a single segment" + expected = regIntercept fb + regCoef fb VU.! 0 * 2.0 + assertBool "unseen -> fallback affine" (close 1e-9 p expected) + ] + +genericityTests :: [Test] +genericityTests = + [ "logistic base composes" ~: do + let labels = replicate 4 ("pos" :: T.Text) ++ replicate 4 "neg" + df = + D.fromNamedColumns + [ ("g", DI.fromList (replicate 4 ("a" :: T.Text) ++ replicate 4 "b")) + , ("x", DI.fromList ([1, 2, 3, 4, 1, 2, 3, 4] :: [Double])) + , ("label", DI.fromList labels) + ] + m = fit (lowFloor (segmented defaultLogisticConfig)) (F.col @T.Text "label") df + preds = interpT df (predict m) + assertBool "logistic predicts one label per row" (length preds == 8) + , "symbolic base composes" ~: do + let cfg = defaultSRConfig{srGenerations = 2, srPopSize = 12} + m = fit (lowFloor (segmented cfg)) (F.col @Double "y") twoSegDF + preds = interpD twoSegDF (predict m) + assertBool "symbolic predicts one value per row" (length preds == 8) + ] + +selectionTests :: [Test] +selectionTests = + [ "segmentOn picks only the named column" ~: do + let df = + D.fromNamedColumns + [ ("g", DI.fromList (replicate 4 ("a" :: T.Text) ++ replicate 4 "b")) + , ("h", DI.fromList (cycle3 8)) + , ("x", DI.fromList ([1, 2, 3, 4, 1, 2, 3, 4] :: [Double])) + , ("y", DI.fromList ([1, 2, 3, 4, 5, 6, 7, 8] :: [Double])) + ] + m = + fit + (segmentOn (lowFloor (segmented defaultLinearConfig)) ["g"]) + (F.col @Double "y") + df + assertEqual "only g" ["g"] (smCatCols m) + , "cardinality cap skips high-cardinality text" ~: do + let df = + D.fromNamedColumns + [ ("g", DI.fromList (replicate 4 ("a" :: T.Text) ++ replicate 4 "b")) + , ("k", DI.fromList (map (T.pack . show) [1 .. 8 :: Int])) + , ("x", DI.fromList ([1, 2, 3, 4, 1, 2, 3, 4] :: [Double])) + , ("y", DI.fromList ([1, 2, 3, 4, 5, 6, 7, 8] :: [Double])) + ] + cfg = (lowFloor (segmented defaultLinearConfig)){segMaxCard = 2} + m = fit cfg (F.col @Double "y") df + assertEqual "k (8 distinct) skipped, g kept" ["g"] (smCatCols m) + ] + where + cycle3 n = take n (cycle (["p", "q", "r"] :: [T.Text])) + +nullTests :: [Test] +nullTests = + [ "null categorical routes to fallback" ~: do + let gcol = + [Just "a", Just "a", Just "a", Nothing, Just "b", Just "b", Just "b", Nothing] :: + [Maybe T.Text] + df = + D.fromNamedColumns + [ ("g", DI.fromList gcol) + , ("x", DI.fromList ([1, 2, 3, 9, 1, 2, 3, 9] :: [Double])) + , ("y", DI.fromList ([3, 5, 7, 0, 2, -1, -4, 0] :: [Double])) + ] + m = fit (lowFloor (segmented defaultLinearConfig)) (F.col @Double "y") df + -- Only "a" and "b" appear as segments; "null" is never a key. + assertBool + "no null-keyed segment" + (["null"] `notElem` map segKey (smSegments m)) + assertBool "two real segments" (length (smSegments m) == 2) + ] + +-- | Fit a segmented linear model, capturing any fit-time error message. +fitErr :: + D.DataFrame -> IO (Either SomeException (SegmentedModel Double LinearRegressor)) +fitErr df = + try + (evaluate (fit (lowFloor (segmented defaultLinearConfig)) (F.col @Double "y") df)) + +guardTests :: [Test] +guardTests = + [ "int feature error points at toDouble" ~: do + let df = + D.fromNamedColumns + [ ("g", DI.fromList (replicate 4 ("a" :: T.Text) ++ replicate 4 "b")) + , ("n", DI.fromList ([1, 2, 3, 4, 5, 6, 7, 8] :: [Int])) + , ("y", DI.fromList ([1, 2, 3, 4, 5, 6, 7, 8] :: [Double])) + ] + r <- fitErr df + case r of + Left e -> + assertBool + "names column n and toDouble" + ("n" `isInfixOf` show e && "toDouble" `isInfixOf` show e) + Right _ -> assertFailure "expected an actionable error for the Int feature" + , "nullable feature error points at dropping" ~: do + let df = + D.fromNamedColumns + [ ("g", DI.fromList (replicate 4 ("a" :: T.Text) ++ replicate 4 "b")) + , + ( "z" + , DI.fromList + ( [Just 1, Nothing, Just 3, Just 4, Just 5, Just 6, Just 7, Just 8] :: + [Maybe Double] + ) + ) + , ("y", DI.fromList ([1, 2, 3, 4, 5, 6, 7, 8] :: [Double])) + ] + r <- fitErr df + case r of + Left e -> + assertBool + "names column z and filterJust" + ("z" `isInfixOf` show e && "filterJust" `isInfixOf` show e) + Right _ -> assertFailure "expected an actionable error for the nullable feature" + , "well-typed frame fits after casting/dropping" ~: do + let df = + D.fromNamedColumns + [ ("g", DI.fromList (replicate 4 ("a" :: T.Text) ++ replicate 4 "b")) + , ("n", DI.fromList ([1, 2, 3, 4, 5, 6, 7, 8] :: [Double])) + , ("y", DI.fromList ([1, 2, 3, 4, 5, 6, 7, 8] :: [Double])) + ] + m = fit (lowFloor (segmented defaultLinearConfig)) (F.col @Double "y") df + assertEqual "two segments" 2 (length (smSegments m)) + ] + +diagnosticTests :: [Test] +diagnosticTests = + [ "undersized segment falls back, diagnostics correct" ~: do + let df = + D.fromNamedColumns + [ ("g", DI.fromList (replicate 4 ("a" :: T.Text) ++ ["b"])) + , ("x", DI.fromList ([1, 2, 3, 4, 9] :: [Double])) + , ("y", DI.fromList ([3, 5, 7, 9, 0] :: [Double])) + ] + m = fit (lowFloor (segmented defaultLinearConfig)) (F.col @Double "y") df + assertEqual "one local segment" 1 (length (smSegments m)) + assertEqual "segment a has 4 rows" 4 (segN (segByKey ["a"] m)) + assertEqual "b fell back with 1 row" [(["b"], 1)] (smFellBack m) + ] + +cvTests :: [Test] +cvTests = + [ "composes with crossValidate" ~: do + let scores = + crossValidate + 2 + 0 + rmse + (F.col @Double "y") + ( predict + . fit ((segmented defaultLinearConfig){segMinRows = 2}) (F.col @Double "y") + ) + twoSegDF + assertBool "two fold scores" (length scores == 2) + assertBool + "scores are finite" + (all (\s -> not (isNaN s || isInfinite s)) scores) + ] + +poolingTests :: [Test] +poolingTests = + [ "lambda limits and interior monotonicity" ~: do + let fitL lam = + fit + (pooled (lowFloor (segmented defaultLinearConfig)) lam) + (F.col @Double "y") + twoSegDF + m0 = fitL 0 + mInf = fitL 1e9 + mMid = fitL 5 + slope k mm = regCoef (segModel (segByKey k mm)) VU.! 0 + inter k mm = regIntercept (segModel (segByKey k mm)) + -- lambda = 0: independent OLS (matches recovery test). + assertBool "lambda0 a slope 2" (close 1e-9 (slope ["a"] m0) 2) + assertBool "lambda0 b slope -3" (close 1e-9 (slope ["b"] m0) (-3)) + -- lambda -> inf: both segments converge to the n_g-weighted reference + -- (raw slope -0.5, raw intercept 3.0 for this balanced fixture). + assertBool "lambdaInf a slope ~ -0.5" (close 1e-3 (slope ["a"] mInf) (-0.5)) + assertBool "lambdaInf b slope ~ -0.5" (close 1e-3 (slope ["b"] mInf) (-0.5)) + assertBool "lambdaInf a intercept ~ 3" (close 1e-3 (inter ["a"] mInf) 3.0) + assertBool + "lambdaInf segments coincide" + (close 1e-3 (slope ["a"] mInf) (slope ["b"] mInf)) + -- interior: a's slope sits strictly between its OLS (2) and the ref (-0.5). + assertBool + "interior between OLS and ref" + (slope ["a"] mMid < 2 && slope ["a"] mMid > (-0.5)) + , "pooling unsupported for symbolic base" ~: do + r <- + try + ( evaluate + ( fit + (pooled (lowFloor (segmented defaultSRConfig)) 1.0) + (F.col @Double "y") + twoSegDF + ) + ) :: + IO (Either SomeException (SegmentedModel Double SRModel)) + case r of + Left _ -> return () + Right _ -> assertFailure "expected a fit-time error for pooling on a symbolic base" + ] + +tests :: [Test] +tests = + concat + [ recoveryTests + , routingTests + , genericityTests + , selectionTests + , nullTests + , guardTests + , diagnosticTests + , cvTests + , poolingTests + ] diff --git a/tests/Learn/SklearnParity.hs b/tests/Learn/SklearnParity.hs --- a/tests/Learn/SklearnParity.hs +++ b/tests/Learn/SklearnParity.hs @@ -1,10 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -{- | Parity tests against scikit-learn on clean Kaggle-style datasets. The -reference values in @data/ml/golden.json@ are produced by -@scripts/gen_sklearn_golden.py@. Closed-form models (OLS, ridge, PCA) are held to -tight coefficient parity; iterative models to an accuracy/inertia floor. +{- | Parity tests against scikit-learn on clean Kaggle-style datasets; reference +values in @data/ml/golden.json@ come from @scripts/gen_sklearn_golden.py@. +Closed-form models get tight coefficient parity; iterative ones an accuracy floor. -} module Learn.SklearnParity (tests) where @@ -32,7 +31,6 @@ ) import DataFrame.KMeans import DataFrame.LinearModel -import DataFrame.LinearSolver (defaultSolverConfig) import DataFrame.PCA import DataFrame.SVM diff --git a/tests/Learn/Symbolic.hs b/tests/Learn/Symbolic.hs deleted file mode 100644 --- a/tests/Learn/Symbolic.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Learn.Symbolic (tests) where - -import qualified DataFrame as D -import qualified DataFrame.Functions as F -import DataFrame.Internal.Column (TypedColumn (..), toVector) -import qualified DataFrame.Internal.Column as DI -import DataFrame.Internal.Expression (Expr) -import DataFrame.Internal.Interpreter (interpret) - -import DataFrame.PCA.Kernel -import DataFrame.SVM.RFF -import DataFrame.SymbolicRegression -import DataFrame.SymbolicRegression.Expr -import DataFrame.SymbolicRegression.Optimize (meanSquaredError) -import DataFrame.SymbolicRegression.Simplify (simplify) - -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import DataFrame.Model (fit, predict) -import Test.HUnit - -interpD :: D.DataFrame -> Expr Double -> [Double] -interpD df e = case interpret @Double df e of - Right (TColumn c) -> either (const []) VU.toList (toVector @Double @VU.Vector c) - Left err -> error (show err) - -interpI :: D.DataFrame -> Expr Int -> [Int] -interpI df e = case interpret @Int df e of - Right (TColumn c) -> either (const []) VU.toList (toVector @Int @VU.Vector c) - Left err -> error (show err) - -testSRRecovers :: Test -testSRRecovers = TestCase $ do - let xs = [-3, -2, -1, 0, 1, 2, 3, 4, 5, 6] :: [Double] - df = - D.fromNamedColumns - [ ("x", DI.fromList xs) - , ("y", DI.fromList [x * x + x | x <- xs]) - ] - m = - fit - defaultSRConfig - { srSeed = 3 - , srGenerations = 60 - , srPopSize = 300 - , srUnaryOps = [] - } - (F.col @Double "y") - df - preds = interpD df (srBest m) - truth = interpD df (F.col @Double "y") - err = sum (zipWith (\p t -> (p - t) ^ (2 :: Int)) preds truth) / 10 - assertBool "SR recovers x*x+x to low error" (err < 1e-6) - assertBool "Pareto front non-empty" (not (null (srPareto m))) - -testSRDeterminism :: Test -testSRDeterminism = TestCase $ do - let xs = [1 .. 8] :: [Double] - df = - D.fromNamedColumns - [ ("x", DI.fromList xs) - , ("y", DI.fromList (map (\x -> 2 * x + 1) xs)) - ] - run = - fit - defaultSRConfig{srSeed = 9, srGenerations = 20} - (F.col @Double "y") - df - assertEqual "SR deterministic best MSE" (srBestMSE run) (srBestMSE (rerun df)) - where - rerun = - fit - defaultSRConfig{srSeed = 9, srGenerations = 20} - (F.col @Double "y") - -testSimplifyPreservesEval :: Test -testSimplifyPreservesEval = TestCase $ do - let feats = V.singleton (VU.fromList [1, 2, 3, 4 :: Double]) - n = 4 - e = SBin SAdd (SBin SMul (SVar 0) (SConst 1)) (SConst 0) - target = VU.fromList [1, 2, 3, 4] - assertBool - "simplify preserves evaluation" - ( abs - (meanSquaredError feats n target e - meanSquaredError feats n target (simplify e)) - < 1e-12 - ) - assertBool "simplify is size non-increasing" (srSize (simplify e) <= srSize e) - assertEqual "simplify idempotent" (simplify e) (simplify (simplify e)) - -testKernelPCA :: Test -testKernelPCA = TestCase $ do - let df = - D.fromNamedColumns - [ ("a", DI.fromList ([0, 0.2, -0.1, 0.1, 8, 8.1, 7.9, 8.2] :: [Double])) - , ("b", DI.fromList ([0, -0.1, 0.2, 0.0, 5, 5.2, 4.9, 5.1] :: [Double])) - ] - m = - fit - defaultKernelPCAConfig{kpcaNComponents = 2, kpcaNLandmarks = 8, kpcaSeed = 1} - [F.col @Double "a", F.col @Double "b"] - df - pc1 = interpD df (snd (head (kernelPCAExprs m))) - assertBool "kPCA finite" (not (any isNaN pc1)) - assertBool - "kPCA first component separates blobs" - (signum (head pc1) /= signum (last pc1)) - -testRFFSVM :: Test -testRFFSVM = TestCase $ do - let df = - D.fromNamedColumns - [ ("x", DI.fromList ([-3, -2, -1, -0.5, 0.5, 1, 2, 3] :: [Double])) - , ("label", DI.fromList ([0, 0, 0, 0, 1, 1, 1, 1] :: [Int])) - ] - m = - fit - defaultRFFConfig{rffD = 80, rffGamma = 0.2, rffSeed = 2} - (F.col @Int "label") - df - preds = interpI df (predict m) - assertEqual "RFF SVM separates" [0, 0, 0, 0, 1, 1, 1, 1] preds - -tests :: [Test] -tests = - [ testSRRecovers - , testSRDeterminism - , testSimplifyPreservesEval - , testKernelPCA - , testRFFSVM - ] diff --git a/tests/Learn/TypedModel.hs b/tests/Learn/TypedModel.hs new file mode 100644 --- /dev/null +++ b/tests/Learn/TypedModel.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{- | 'fit'/'predict' are frame-aware. Training on a 'TypedDataFrame' with a typed +target ('DT.col') returns a 'Fitted' carrying the schema, and 'predict' on it +yields a typed 'TExpr'; training on an untyped 'DataFrame' with an untyped target +('F.col') returns the bare model and an 'Expr'. Both paths must agree numerically. +-} +module Learn.TypedModel (tests) where + +import Data.Maybe (fromJust) +import qualified Data.Vector.Unboxed as VU + +import qualified DataFrame as D +import qualified DataFrame.Functions as F +import DataFrame.Internal.Column (TypedColumn (..), toVector) +import qualified DataFrame.Internal.Column as DI +import DataFrame.Internal.Expression (Expr) +import DataFrame.Internal.Interpreter (interpret) + +import DataFrame.LinearModel.Regression ( + LinearConfig (..), + LinearRegressor (..), + Penalty (..), + defaultLinearConfig, + ) +import DataFrame.Model (Fitted (..), fit, predict) +import qualified DataFrame.Typed as DT + +import Test.HUnit + +-- | All-Double schema: two features and a Double target. +type Houses = + '[ DT.Column "x1" Double + , DT.Column "x2" Double + , DT.Column "y" Double + ] + +regDF :: D.DataFrame +regDF = + D.fromNamedColumns + [ ("x1", DI.fromList xs1) + , ("x2", DI.fromList xs2) + , ("y", DI.fromList [2 * a - 3 * b + 1 | (a, b) <- zip xs1 xs2]) + ] + where + xs1 = [1, 2, 3, 4, 5, 6, 7, 8] :: [Double] + xs2 = [2, 1, 4, 3, 6, 5, 8, 7] :: [Double] + +housesTDF :: DT.TypedDataFrame Houses +housesTDF = fromJust (DT.freeze @Houses regDF) + +interpD :: D.DataFrame -> Expr Double -> [Double] +interpD df e = case interpret @Double df e of + Right (TColumn c) -> either (const []) VU.toList (toVector @Double @VU.Vector c) + Left err -> error (show err) + +close :: Double -> Double -> Double -> Bool +close tol a b = abs (a - b) <= tol + +sameModel :: LinearRegressor -> LinearRegressor -> Bool +sameModel a b = + and (zipWith (close 1e-12) (VU.toList (regCoef a)) (VU.toList (regCoef b))) + && close 1e-12 (regIntercept a) (regIntercept b) + +{- | 'fit' on a 'TypedDataFrame' returns a 'Fitted' whose model matches the +bare model from 'fit' on the equivalent 'DataFrame'. +-} +testTypedFitParity :: Test +testTypedFitParity = TestCase $ do + let onTyped = fit defaultLinearConfig (DT.col @"y") housesTDF + onUntyped = fit defaultLinearConfig (F.col @Double "y") regDF + assertBool + "fittedModel of typed fit == untyped fit" + (sameModel (fittedModel onTyped) onUntyped) + +{- | 'predict' on the typed fit yields a 'TExpr Houses Double'; unwrapped and +interpreted it matches 'predict' on the untyped fit. +-} +testTypedPredict :: Test +testTypedPredict = TestCase $ do + let onTyped = fit defaultLinearConfig (DT.col @"y") housesTDF + onUntyped = fit defaultLinearConfig (F.col @Double "y") regDF + typedExpr = DT.unTExpr (predict onTyped) -- :: Expr Double via TExpr Houses Double + untypedExpr = predict onUntyped -- :: Expr Double + truth = interpD regDF (F.col @Double "y") + assertBool + "typed predict matches untyped predict" + ( and + (zipWith (close 1e-12) (interpD regDF typedExpr) (interpD regDF untypedExpr)) + ) + assertBool + "typed predict recovers the target" + (and (zipWith (close 1e-6) (interpD regDF typedExpr) truth)) + +-- | The frame-awareness holds for a regularized fit too. +testTypedRidge :: Test +testTypedRidge = TestCase $ do + let cfg = defaultLinearConfig{lcPenalty = Ridge 0.01} + onTyped = fit cfg (DT.col @"y") housesTDF + onUntyped = fit cfg (F.col @Double "y") regDF + assertBool + "ridge: fittedModel of typed fit == untyped fit" + (sameModel (fittedModel onTyped) onUntyped) + +tests :: [Test] +tests = + [ TestLabel "typed fit returns Fitted matching untyped" testTypedFitParity + , TestLabel "typed predict yields TExpr matching untyped" testTypedPredict + , TestLabel "typed ridge fit parity" testTypedRidge + ] diff --git a/tests/LinearSolver.hs b/tests/LinearSolver.hs deleted file mode 100644 --- a/tests/LinearSolver.hs +++ /dev/null @@ -1,828 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module LinearSolver where - -import qualified DataFrame as D -import qualified DataFrame.Internal.Column as DI -import DataFrame.Internal.Expression (Expr (..), getColumns) -import DataFrame.Internal.Interpreter (interpret) -import DataFrame.LinearSolver - -import Data.List (sort) -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import System.Random (StdGen, mkStdGen, randomR) -import Test.HUnit - ------------------------------------------------------------------------- --- Test fixtures and helpers ------------------------------------------------------------------------- - --- Generate n points with d features, each value uniform in [-1, 1], from a seed. -syntheticPoints :: Int -> Int -> Int -> V.Vector (VU.Vector Double) -syntheticPoints seed n d = - let (rows, _) = foldr step ([], mkStdGen seed) [1 .. n] - in V.fromList (take n rows) - where - step _ (acc, g) = - let (row, g') = genRow d g - in (row : acc, g') - genRow k g0 = go k g0 [] - where - go 0 g xs = (VU.fromList (reverse xs), g) - go i g xs = - let (v, g') = randomR (-1.0 :: Double, 1.0) g - in go (i - 1) g' (v : xs) - --- Label each row by sign(w . x + b); +1 if score > 0, else -1. -labelsForHyperplane :: - V.Vector (VU.Vector Double) -> - VU.Vector Double -> - Double -> - VU.Vector Double -labelsForHyperplane rows w b = - VU.generate - (V.length rows) - ( \i -> - let score = dotProduct w (rows V.! i) + b - in if score > 0 then 1 else -1 - ) - --- Cosine similarity between two non-zero vectors. -cosineSim :: VU.Vector Double -> VU.Vector Double -> Double -cosineSim u v = - let nu = sqrt (dotProduct u u) - nv = sqrt (dotProduct v v) - in if nu == 0 || nv == 0 then 0 else dotProduct u v / (nu * nv) - --- Predict +1 or -1 from a fitted LinearModel. -predict :: LinearModel -> VU.Vector Double -> Double -predict m x = - let score = dotProduct (lmWeights m) x + lmIntercept m - in if score > 0 then 1 else -1 - --- Predict directly on standardized features (skipping de-standardization). -predictStandardized :: VU.Vector Double -> Double -> VU.Vector Double -> Double -predictStandardized w b x = - if dotProduct w x + b > 0 then 1 else -1 - --- Average binary logistic loss at (w, b). -logisticLoss :: - V.Vector (VU.Vector Double) -> - VU.Vector Double -> - VU.Vector Double -> - Double -> - Double -logisticLoss features labels w b = - let n = V.length features - loss i = - let yi = labels VU.! i - row = features V.! i - margin = yi * (dotProduct w row + b) - in -- log(1 + exp(-margin)), numerically stable - if margin >= 0 - then log (1 + exp (-margin)) - else (-margin) + log (1 + exp margin) - in sum [loss i | i <- [0 .. n - 1]] / fromIntegral n - ------------------------------------------------------------------------- --- A1: Recover known hyperplane with no L1 ------------------------------------------------------------------------- - -testA1RecoverHyperplane :: Test -testA1RecoverHyperplane = TestCase $ do - let groundTruth = VU.fromList [0.7, -0.5] - groundBias = 0.3 - rows = syntheticPoints 1 200 2 - labels = labelsForHyperplane rows groundTruth groundBias - cfg = - defaultSolverConfig - { scL1Lambda = 0 - , scL2Lambda = 0 - , scMaxIter = 500 - , scTol = 1e-6 - } - model = fitL1Logistic cfg rows labels (V.fromList ["x", "y"]) - cosSim = cosineSim (lmWeights model) groundTruth - sameSignAll = - all - (\i -> predict model (rows V.! i) == labels VU.! i) - [0 .. V.length rows - 1] - assertBool - ("recovered weights should align with ground truth (cos = " ++ show cosSim ++ ")") - (cosSim > 0.99) - assertBool "all training points predicted correctly" sameSignAll - ------------------------------------------------------------------------- --- A2: L1 produces sparse weights ------------------------------------------------------------------------- - -testA2L1Sparsity :: Test -testA2L1Sparsity = TestCase $ do - -- 10 features, only feature 1 and feature 4 carry signal. - let groundTruth = VU.fromList [0, 1.2, 0, 0, -1.5, 0, 0, 0, 0, 0] - groundBias = 0 - rows = syntheticPoints 7 500 10 - labels = labelsForHyperplane rows groundTruth groundBias - cfg = - defaultSolverConfig - { scL1Lambda = 0.1 - , scL2Lambda = 0 - , scMaxIter = 500 - , scTol = 1e-6 - } - names = V.fromList [T.pack ("f" ++ show i) | i <- [0 .. 9 :: Int]] - model = fitL1Logistic cfg rows labels names - ws = VU.toList (lmWeights model) - nonZeroIdxs = [i | (i, w) <- zip [0 :: Int ..] ws, w /= 0] - zeroIdxs = [i | (i, w) <- zip [0 :: Int ..] ws, w == 0] - assertBool - ( "informative feature 1 should have non-zero weight (got " - ++ show (ws !! 1) - ++ ")" - ) - (ws !! 1 /= 0) - assertBool - ( "informative feature 4 should have non-zero weight (got " - ++ show (ws !! 4) - ++ ")" - ) - (ws !! 4 /= 0) - -- Of the 8 noise features (indices 0,2,3,5,6,7,8,9), expect at least 6 to be 0. - let noiseFeatures = [0, 2, 3, 5, 6, 7, 8, 9] :: [Int] - noiseZero = length [i | i <- noiseFeatures, i `elem` zeroIdxs] - assertBool - ( "at least 6 noise features zeroed (got " - ++ show noiseZero - ++ "; non-zero idxs = " - ++ show nonZeroIdxs - ++ ")" - ) - (noiseZero >= 6) - ------------------------------------------------------------------------- --- A3: Convergence on well-conditioned input ------------------------------------------------------------------------- - -testA3Convergence :: Test -testA3Convergence = TestCase $ do - let groundTruth = VU.fromList [1.0, -0.5, 0.7] - rows = syntheticPoints 2 300 3 - labels = labelsForHyperplane rows groundTruth 0 - cfg = - defaultSolverConfig - { scL1Lambda = 0.01 - , scL2Lambda = 0 - , scMaxIter = 1000 - , scTol = 1e-5 - } - model = fitL1Logistic cfg rows labels (V.fromList ["a", "b", "c"]) - -- Loss at the fitted model - (rowsStd, _, _, _) = standardize rows - ws = lmWeights model - b = lmIntercept model - -- Re-standardize the weights for loss comparison on standardized data - loss0 = logisticLoss rowsStd labels (VU.replicate 3 0) 0 - -- Fit gives raw weights; compute loss on raw rows - lossFit = logisticLoss rows labels ws b - assertBool - ( "loss decreased from initial (initial=" - ++ show loss0 - ++ ", final=" - ++ show lossFit - ++ ")" - ) - (lossFit < loss0) - ------------------------------------------------------------------------- --- A4: Final loss <= initial loss (monotone or near-monotone in FISTA) ------------------------------------------------------------------------- - -testA4LossNotIncreasing :: Test -testA4LossNotIncreasing = TestCase $ do - let groundTruth = VU.fromList [0.8, 0.4] - rows = syntheticPoints 3 100 2 - labels = labelsForHyperplane rows groundTruth 0 - cfg = defaultSolverConfig{scL1Lambda = 0.05, scL2Lambda = 0, scMaxIter = 100} - model = fitL1Logistic cfg rows labels (V.fromList ["x", "y"]) - loss0 = logisticLoss rows labels (VU.replicate 2 0) 0 - lossFit = logisticLoss rows labels (lmWeights model) (lmIntercept model) - assertBool - ( "final loss must be <= initial loss (l0=" - ++ show loss0 - ++ ", lf=" - ++ show lossFit - ++ ")" - ) - (lossFit <= loss0 + 1e-9) - ------------------------------------------------------------------------- --- A5: Degenerate input — all labels +1 ------------------------------------------------------------------------- - -testA5AllSameDirection :: Test -testA5AllSameDirection = TestCase $ do - let rows = syntheticPoints 4 50 3 - labels = VU.replicate 50 1.0 - cfg = defaultSolverConfig{scL1Lambda = 0.01, scL2Lambda = 0, scMaxIter = 100} - model = fitL1Logistic cfg rows labels (V.fromList ["a", "b", "c"]) - ws = VU.toList (lmWeights model) - b = lmIntercept model - anyNaN = any isNaN ws || isNaN b - anyInf = any isInfinite ws || isInfinite b - allPositive = all (\i -> predict model (rows V.! i) == 1) [0 .. V.length rows - 1] - assertBool "no NaN in weights/intercept" (not anyNaN) - assertBool "no Inf in weights/intercept" (not anyInf) - assertBool - "all-same labels should produce a positive-predicting model" - allPositive - ------------------------------------------------------------------------- --- A6: Degenerate — empty input ------------------------------------------------------------------------- - -testA6Empty :: Test -testA6Empty = TestCase $ do - let cfg = defaultSolverConfig - emptyRows = V.empty :: V.Vector (VU.Vector Double) - emptyLabels = VU.empty :: VU.Vector Double - names = V.fromList ["a", "b"] - model = fitL1Logistic cfg emptyRows emptyLabels names - assertEqual - "empty input -> 2 zero weights" - (VU.fromList [0, 0]) - (lmWeights model) - assertEqual "empty input -> zero intercept" 0 (lmIntercept model) - ------------------------------------------------------------------------- --- A7: Degenerate — constant feature ------------------------------------------------------------------------- - -testA7ConstantFeature :: Test -testA7ConstantFeature = TestCase $ do - -- Feature 1 is informative (uniform in [-1,1]); feature 0 is constant at 0.5. - let baseRows = syntheticPoints 5 100 1 - rows = - V.map - (\row -> VU.fromList (0.5 : VU.toList row)) - baseRows - groundTruth = VU.fromList [0.0, 1.0] -- only feature 1 matters - labels = labelsForHyperplane rows groundTruth 0 - cfg = - defaultSolverConfig - { scL1Lambda = 0.01 - , scL2Lambda = 0 - , scMaxIter = 300 - , scTol = 1e-6 - } - model = fitL1Logistic cfg rows labels (V.fromList ["constant", "signal"]) - ws = VU.toList (lmWeights model) - anyBad = any (\x -> isNaN x || isInfinite x) ws - assertBool - ("constant feature weight ~ 0 (got " ++ show (head ws) ++ ")") - (abs (head ws) < 1e-6) - assertBool - ("signal feature non-zero (got " ++ show (ws !! 1) ++ ")") - (ws !! 1 /= 0) - assertBool "no NaN/Inf" (not anyBad) - ------------------------------------------------------------------------- --- A8: Numerical stability with large feature values ------------------------------------------------------------------------- - -testA8LargeValues :: Test -testA8LargeValues = TestCase $ do - let scale = 1000.0 :: Double - baseRows = syntheticPoints 6 100 2 - rows = V.map (VU.map (* scale)) baseRows - groundTruth = VU.fromList [0.5, -0.7] - labels = labelsForHyperplane rows groundTruth 0 - cfg = defaultSolverConfig{scL1Lambda = 0.01, scL2Lambda = 0, scMaxIter = 300} - model = fitL1Logistic cfg rows labels (V.fromList ["x", "y"]) - ws = VU.toList (lmWeights model) - b = lmIntercept model - anyBad = any (\x -> isNaN x || isInfinite x) (b : ws) - sameSigns = - length - [ () | i <- [0 .. V.length rows - 1], predict model (rows V.! i) == labels VU.! i - ] - assertBool "no NaN/Inf with scaled features" (not anyBad) - assertBool - ( "should correctly classify the vast majority of rows (" - ++ show sameSigns - ++ "/100)" - ) - (sameSigns >= 90) - ------------------------------------------------------------------------- --- A9: Standardization round-trip — recovered weights point in the true --- direction even when raw-feature scales differ by orders of magnitude. --- A broken de-standardization formula would scramble the per-feature scale --- of @wRaw@ and the cosine to ground truth would drop sharply. ------------------------------------------------------------------------- - -testA9StandardizationRoundTrip :: Test -testA9StandardizationRoundTrip = TestCase $ do - let nRows = 80 :: Int - -- Column 0 ranges 0..400 (mean ~200, std ~115). - -- Column 1 ranges 0..0.2 (mean ~0.1, std ~0.058). - -- True hyperplane: (col0 - 200) + 1000 * (col1 - 0.1) > 0 - -- True raw weights (modulo positive scaling): [1.0, 1000.0] - col0 = [fromIntegral i * 5 :: Double | i <- [0 .. nRows - 1]] - col1 = [fromIntegral i * 0.0025 :: Double | i <- [0 .. nRows - 1]] - rows = V.fromList [VU.fromList [c0, c1] | (c0, c1) <- zip col0 col1] - labels = - VU.fromList - [ if (c0 - 200) + 1000 * (c1 - 0.1) > 0 then 1.0 else -1.0 - | (c0, c1) <- zip col0 col1 - ] - cfg = - defaultSolverConfig - { scL1Lambda = 1.0e-4 - , scL2Lambda = 0 - , scMaxIter = 2000 - , scTol = 1.0e-7 - } - model = fitL1Logistic cfg rows labels (V.fromList ["x", "y"]) - truthDir = VU.fromList [1.0, 1000.0] - cs = cosineSim (lmWeights model) truthDir - -- All training points correctly classified - trainPreds = - [predict model (rows V.! i) | i <- [0 .. nRows - 1]] - trainLabs = - [labels VU.! i | i <- [0 .. nRows - 1]] - correct = - length - [() | (p, l) <- zip trainPreds trainLabs, p == l] - assertEqual "all training points correctly classified" nRows correct - assertBool - ( "recovered raw weights align with ground-truth direction across " - ++ "vastly different feature scales (cos = " - ++ show cs - ++ ")" - ) - (cs > 0.95) - ------------------------------------------------------------------------- --- A10: Determinism — same input -> same output ------------------------------------------------------------------------- - -testA10Determinism :: Test -testA10Determinism = TestCase $ do - let groundTruth = VU.fromList [0.6, 0.4] - rows = syntheticPoints 9 60 2 - labels = labelsForHyperplane rows groundTruth 0 - cfg = defaultSolverConfig{scL1Lambda = 0.05, scL2Lambda = 0, scMaxIter = 200} - m1 = fitL1Logistic cfg rows labels (V.fromList ["x", "y"]) - m2 = fitL1Logistic cfg rows labels (V.fromList ["x", "y"]) - assertEqual "same input -> same weights" (lmWeights m1) (lmWeights m2) - assertEqual "same input -> same intercept" (lmIntercept m1) (lmIntercept m2) - ------------------------------------------------------------------------- --- A11: Two-feature ground truth recovery (w_2/w_1 ratio) ------------------------------------------------------------------------- - -testA11GroundTruthRatio :: Test -testA11GroundTruthRatio = TestCase $ do - -- y = sign(x1 + 2*x2 - 3); pull from a larger range so a non-zero intercept matters. - let groundTruth = VU.fromList [1.0, 2.0] - groundBias = -3.0 - n = 500 - baseRows = syntheticPoints 10 n 2 - -- Scale up so x_i can range over [-3, 3] -- gives wider coverage of the boundary - rows = V.map (VU.map (* 3)) baseRows - labels = labelsForHyperplane rows groundTruth groundBias - cfg = - defaultSolverConfig - { scL1Lambda = 0.001 - , scL2Lambda = 0 - , scMaxIter = 1000 - , scTol = 1e-7 - } - model = fitL1Logistic cfg rows labels (V.fromList ["x", "y"]) - ws = lmWeights model - b = lmIntercept model - ratio = (ws VU.! 1) / (ws VU.! 0) - biasRatio = b / (ws VU.! 0) - assertBool - ("w2/w1 should approximate 2.0 (got " ++ show ratio ++ ")") - (ratio > 1.7 && ratio < 2.3) - assertBool - ("b/w1 should approximate -3.0 (got " ++ show biasRatio ++ ")") - (biasRatio > -3.4 && biasRatio < -2.6) - ------------------------------------------------------------------------- --- B1: modelToExpr produces a well-typed Expr Bool ------------------------------------------------------------------------- - -testB1ExprWellTyped :: Test -testB1ExprWellTyped = TestCase $ do - let model = - LinearModel - { lmWeights = VU.fromList [1.0, -2.0] - , lmIntercept = 0.5 - , lmFeatureNames = V.fromList ["x", "y"] - } - expr = modelToExpr model - -- Evaluate on a 3-row DataFrame - df = - D.fromNamedColumns - [ ("x", DI.fromList ([0.0, 1.0, 2.0] :: [Double])) - , ("y", DI.fromList ([0.0, 0.0, 5.0] :: [Double])) - ] - -- Manual predictions: 1*x - 2*y + 0.5 > 0 ? - manual = - [ (1.0 * 0.0 - 2.0 * 0.0 + 0.5) > 0 - , (1.0 * 1.0 - 2.0 * 0.0 + 0.5) > 0 - , (1.0 * 2.0 - 2.0 * 5.0 + 0.5) > 0 - ] - case interpret @Bool df expr of - Left e -> assertFailure ("interpret failed: " ++ show e) - Right (DI.TColumn col) -> case DI.toVector @Bool col of - Left e -> assertFailure ("toVector failed: " ++ show e) - Right vals -> - assertEqual "Expr matches manual evaluation" manual (V.toList vals) - ------------------------------------------------------------------------- --- B2: Zero weights are dropped from the resulting Expr ------------------------------------------------------------------------- - -testB2ZeroWeightsPruned :: Test -testB2ZeroWeightsPruned = TestCase $ do - let model = - LinearModel - { lmWeights = VU.fromList [0.0, 1.5, 0.0] - , lmIntercept = 0.0 - , lmFeatureNames = V.fromList ["a", "b", "c"] - } - expr = modelToExpr model - cols = sort (getColumns expr) - assertEqual "only column b appears in the Expr" ["b"] cols - ------------------------------------------------------------------------- --- A14: Constant feature at large raw value — weight must be exactly 0 --- and no NaN/Inf leaks into the rest of the fit. ------------------------------------------------------------------------- - -testA14ConstantHugeValue :: Test -testA14ConstantHugeValue = TestCase $ do - let baseRows = syntheticPoints 14 100 1 -- one informative feature - -- Prepend a constant column at 1e8 to each row. - rows = - V.map - (\row -> VU.fromList (1.0e8 : VU.toList row)) - baseRows - -- Label depends only on the informative (second) feature. - labels = labelsForHyperplane rows (VU.fromList [0.0, 1.0]) 0 - cfg = defaultSolverConfig{scL1Lambda = 0.01, scL2Lambda = 0, scMaxIter = 300} - model = fitL1Logistic cfg rows labels (V.fromList ["constant", "signal"]) - ws = VU.toList (lmWeights model) - b = lmIntercept model - anyBad = any (\v -> isNaN v || isInfinite v) (b : ws) - assertBool "no NaN/Inf with constant-at-1e8 feature" (not anyBad) - assertEqual - "constant feature is dropped — weight is exactly zero" - 0 - (head ws) - assertBool - ("signal feature has non-zero weight (got " ++ show (ws !! 1) ++ ")") - (ws !! 1 /= 0) - ------------------------------------------------------------------------- --- A15: Variance exactly zero (all rows identical for that column). ------------------------------------------------------------------------- - -testA15AllZeroFeature :: Test -testA15AllZeroFeature = TestCase $ do - -- A column that is exactly 0 for every row. - let baseRows = syntheticPoints 15 80 1 - rows = - V.map - (\row -> VU.fromList (0.0 : VU.toList row)) - baseRows - labels = labelsForHyperplane rows (VU.fromList [0.0, 1.0]) 0 - cfg = defaultSolverConfig{scL1Lambda = 0.01, scL2Lambda = 0, scMaxIter = 300} - model = fitL1Logistic cfg rows labels (V.fromList ["zero", "signal"]) - ws = VU.toList (lmWeights model) - assertEqual "zero-variance column has weight zero" 0 (head ws) - assertBool ("signal weight non-zero (" ++ show (ws !! 1) ++ ")") (ws !! 1 /= 0) - ------------------------------------------------------------------------- --- A16: Severely imbalanced labels (99:1) — should not collapse to a --- constant predictor on the majority class without some learning. ------------------------------------------------------------------------- - -testA16ImbalancedLabels :: Test -testA16ImbalancedLabels = TestCase $ do - let nPos = 99 - nNeg = 1 - n = nPos + nNeg - rows = syntheticPoints 16 n 2 - labels = - VU.fromList - (replicate nPos 1.0 ++ replicate nNeg (-1.0)) - cfg = defaultSolverConfig{scL1Lambda = 0.01, scL2Lambda = 0, scMaxIter = 500} - model = fitL1Logistic cfg rows labels (V.fromList ["x", "y"]) - ws = VU.toList (lmWeights model) - b = lmIntercept model - anyBad = any (\v -> isNaN v || isInfinite v) (b : ws) - assertBool "no NaN/Inf with 99:1 imbalance" (not anyBad) - -- The intercept should be positive (the easy thing for the model is to - -- predict the majority); weights may or may not be zero depending on lambda. - assertBool ("intercept favors majority class (got b=" ++ show b ++ ")") (b > 0) - ------------------------------------------------------------------------- --- A17: Mixed per-feature raw scales — should not diverge. ------------------------------------------------------------------------- - -testA17ImbalancedRawScales :: Test -testA17ImbalancedRawScales = TestCase $ do - let baseRows = syntheticPoints 17 100 3 - -- Per-row: [1e-6 * v, v, 1e6 * v] — three columns with vastly - -- different scales but the same underlying signal. - rows = - V.map - ( \row -> - let v0 = row VU.! 0 - v1 = row VU.! 1 - v2 = row VU.! 2 - in VU.fromList [1.0e-6 * v0, v1, 1.0e6 * v2] - ) - baseRows - labels = labelsForHyperplane baseRows (VU.fromList [1.0, -0.5, 0.7]) 0 - cfg = defaultSolverConfig{scL1Lambda = 1.0e-4, scL2Lambda = 0, scMaxIter = 500} - model = fitL1Logistic cfg rows labels (V.fromList ["tiny", "unit", "huge"]) - ws = VU.toList (lmWeights model) - b = lmIntercept model - anyBad = any (\v -> isNaN v || isInfinite v) (b : ws) - assertBool ("no NaN/Inf with mixed scales (ws=" ++ show ws ++ ")") (not anyBad) - -- The fit should classify the training points correctly on aggregate. - let preds = [predict model (rows V.! i) | i <- [0 .. V.length rows - 1]] - lbls = [labels VU.! i | i <- [0 .. VU.length labels - 1]] - correct = length [() | (p, l) <- zip preds lbls, p == l] - -- The wild per-feature scales make the problem poorly conditioned for - -- L1-regularized FISTA with a fixed Lipschitz upper bound. We don't - -- expect optimal accuracy — the assertion is "not random" (>=65%), - -- catching divergence-to-garbage rather than guaranteeing fit quality. - assertBool - ("non-divergent under wild scales (got " ++ show correct ++ "/100)") - (correct >= 65) - ------------------------------------------------------------------------- --- A12: maxIter = 0 returns the initial point unchanged ------------------------------------------------------------------------- - -testA12MaxIterZero :: Test -testA12MaxIterZero = TestCase $ do - let rows = syntheticPoints 20 50 2 - labels = labelsForHyperplane rows (VU.fromList [1.0, -0.5]) 0 - cfg = defaultSolverConfig{scMaxIter = 0} - model = fitL1Logistic cfg rows labels (V.fromList ["x", "y"]) - assertEqual - "maxIter=0 returns zero weights" - (VU.fromList [0, 0]) - (lmWeights model) - assertEqual "maxIter=0 returns zero intercept" 0 (lmIntercept model) - ------------------------------------------------------------------------- --- A13: maxIter = 1 takes exactly one prox step (results differ from --- the initial zero point but may not be near the optimum). ------------------------------------------------------------------------- - -testA13MaxIterOne :: Test -testA13MaxIterOne = TestCase $ do - let rows = syntheticPoints 21 80 2 - labels = labelsForHyperplane rows (VU.fromList [1.0, -0.5]) 0 - cfg = defaultSolverConfig{scMaxIter = 1, scL1Lambda = 0.001, scL2Lambda = 0} - cfg0 = cfg{scMaxIter = 0} - m1 = fitL1Logistic cfg rows labels (V.fromList ["x", "y"]) - m0 = fitL1Logistic cfg0 rows labels (V.fromList ["x", "y"]) - anyNonZero v = not (VU.all (== 0) v) - -- maxIter=0 returns zeros - assertEqual "baseline m0 weights are zero" (VU.fromList [0, 0]) (lmWeights m0) - -- maxIter=1 differs from maxIter=0 (one step actually happened) - assertBool - ("maxIter=1 must change at least one weight (got " ++ show (lmWeights m1) ++ ")") - (anyNonZero (lmWeights m1) || lmIntercept m1 /= 0) - -- Final value is finite - let badW = VU.any (\x -> isNaN x || isInfinite x) (lmWeights m1) - badB = isNaN (lmIntercept m1) || isInfinite (lmIntercept m1) - assertBool "no NaN/Inf after one iteration" (not (badW || badB)) - ------------------------------------------------------------------------- --- PR 3: Elastic Net recovery on correlated-feature pairs. --- Pure L1 picks ONE of two correlated informative features at random; --- Elastic Net keeps BOTH non-zero (Zou & Hastie 2005 "grouping effect", --- §2.3 Theorem 1). --- --- Two cases per the ML reviewer: ρ ≈ 0.97 (strong) and ρ ≈ 0.7 (moderate). ------------------------------------------------------------------------- - --- Generate two correlated features f0, f1 with correlation ρ, plus --- noise features f2..f7. Truth is sign(f0 + f1). -correlatedPairData :: - Int -> Double -> (V.Vector (VU.Vector Double), VU.Vector Double) -correlatedPairData seed rho = - let n = 400 :: Int - d = 8 :: Int - g0 = mkStdGen seed - drawUnit = randomR (-1.0 :: Double, 1.0) - drawRow !gIn = - let (z0, g1) = drawUnit gIn - (epsRaw, g2) = drawUnit g1 - eps = epsRaw * sqrt (max 0 (1 - rho * rho)) - f0 = z0 - f1 = rho * z0 + eps -- corr(f0, f1) ≈ rho by construction - drawNoise k g - | k >= d - 2 = ([], g) - | otherwise = - let (x, g') = drawUnit g - (xs, g'') = drawNoise (k + 1) g' - in (x : xs, g'') - (noise, g3) = drawNoise 0 g2 - row = f0 : f1 : noise - in (VU.fromList row, g3) - go 0 _ acc = reverse acc - go k g acc = - let (r, g') = drawRow g - in go (k - 1) g' (r : acc) - rows = V.fromList (go n g0 []) - labels = - VU.generate n $ \i -> - let r = rows V.! i - s = VU.unsafeIndex r 0 + VU.unsafeIndex r 1 - in if s > 0 then 1.0 else -1.0 - in (rows, labels) - -testA19ElasticNetRecoveryHigh :: Test -testA19ElasticNetRecoveryHigh = TestCase $ do - -- ρ ≈ 0.97: positive test for Elastic Net's "grouping effect" — - -- both correlated informative features kept non-zero and on the - -- same order of magnitude. (We don't assert pure L1 picks just one; - -- with strong-signal features L1 sometimes keeps both anyway.) - let (rows, labels) = correlatedPairData 31 0.97 - names = V.fromList ["f0", "f1", "f2", "f3", "f4", "f5", "f6", "f7"] - cfgEN = defaultSolverConfig{scL1Lambda = 0.05, scL2Lambda = 0.05, scMaxIter = 1000} - men = fitL1Logistic cfgEN rows labels names - wEN = VU.toList (lmWeights men) - nzCount xs = length (filter (/= 0) xs) - (aEN, bEN) = case wEN of - (a : b : _) -> (a, b) - _ -> error "elastic-net test: expected at least two weights" - assertBool - ("ρ=0.97 EN keeps f0 non-zero; wEN[:2] = " ++ show (take 2 wEN)) - (aEN /= 0) - assertBool - ("ρ=0.97 EN keeps f1 non-zero; wEN[:2] = " ++ show (take 2 wEN)) - (bEN /= 0) - let ratio = abs aEN / max (abs bEN) 1e-9 - assertBool - ("ρ=0.97 EN grouping: |w0/w1| ∈ [0.33, 3.0]; got ratio=" ++ show ratio) - (ratio >= 0.33 && ratio <= 3.0) - -- Sanity: shouldn't have spuriously activated all noise features. - assertBool - ("ρ=0.97 EN sparsity: total non-zero ≤ 5; got " ++ show (nzCount wEN)) - (nzCount wEN <= 5) - -testA19ElasticNetRecoveryMid :: Test -testA19ElasticNetRecoveryMid = TestCase $ do - -- ρ ≈ 0.7: theoretically required regime for grouping (Zou-Hastie 2005 §5.1). - let (rows, labels) = correlatedPairData 37 0.7 - names = V.fromList ["f0", "f1", "f2", "f3", "f4", "f5", "f6", "f7"] - cfgEN = defaultSolverConfig{scL1Lambda = 0.05, scL2Lambda = 0.05, scMaxIter = 1000} - men = fitL1Logistic cfgEN rows labels names - wEN = VU.toList (lmWeights men) - (aEN, bEN) = case wEN of - (a : b : _) -> (a, b) - _ -> error "elastic-net test: expected at least two weights" - assertBool - ("ρ=0.7 EN keeps f0 non-zero; wEN[:2] = " ++ show (take 2 wEN)) - (aEN /= 0) - assertBool - ("ρ=0.7 EN keeps f1 non-zero; wEN[:2] = " ++ show (take 2 wEN)) - (bEN /= 0) - let ratio = abs aEN / max (abs bEN) 1e-9 - assertBool - ("ρ=0.7 EN grouping: |w0/w1| ∈ [0.33, 3.0]; got ratio=" ++ show ratio) - (ratio >= 0.33 && ratio <= 3.0) - ------------------------------------------------------------------------- --- PR 3: A20 — class-balanced fit on 95/5 imbalance. --- Without weights the intercept polarises toward logit(0.95) ≈ 2.94. --- With sample weights mean-1 sklearn-form, the intercept sits near 0 and --- predictions become roughly balanced on a symmetric test set. ------------------------------------------------------------------------- - -testA20ClassBalancedFit :: Test -testA20ClassBalancedFit = TestCase $ do - -- Generate 200 rows: 190 positive, 10 negative. Class-conditional - -- means are at ±0.15 with σ ≈ 0.6 — only weakly informative on a - -- single feature, so the unweighted MLE intercept absorbs the - -- class prior @logit(0.95) ≈ 2.94@; class-balanced weighting must - -- pull it back toward zero. Highly-separable features (e.g. mu=±1) - -- would let the slope dominate and mask the intercept effect. - let n = 200 :: Int - nPos = 190 :: Int - g0 = mkStdGen 41 - drawN = randomR (-1.0 :: Double, 1.0) - drawRowAt mu g = - let (z, g') = drawN g - x = mu + 0.6 * z - in (VU.singleton x, g') - rowsAndLabels = - let go _ 0 _ acc = reverse acc - go !pCnt k g acc = - let !mu = if pCnt > 0 then 0.15 else -0.15 - (row, g') = drawRowAt mu g - !y = if pCnt > 0 then 1.0 else -1.0 - in go (pCnt - 1) (k - 1) g' ((row, y) : acc) - in go nPos n g0 [] - rows = V.fromList (map fst rowsAndLabels) - labels = VU.fromList (map snd rowsAndLabels) - names = V.fromList ["x"] - cfgUnbal = - defaultSolverConfig - { scL1Lambda = 0.001 - , scL2Lambda = 0 - , scMaxIter = 2000 - , scTol = 1e-7 - , scSampleWeights = Nothing - } - nNeg = n - nPos - balanced = - VU.generate n $ \i -> - let !y = VU.unsafeIndex labels i - in if y > 0 - then fromIntegral n / (2 * fromIntegral nPos) - else fromIntegral n / (2 * fromIntegral nNeg) - cfgBal = cfgUnbal{scSampleWeights = Just balanced} - mUnbal = fitL1Logistic cfgUnbal rows labels names - mBal = fitL1Logistic cfgBal rows labels names - bUnbal = lmIntercept mUnbal - bBal = lmIntercept mBal - -- Test set: 100 rows at each class-conditional mean. We measure - -- predictions on this BALANCED test set; the unweighted model - -- will predict mostly positive (intercept dominates), the - -- balanced model close to 50/50. - testRows = - V.fromList - ( replicate 100 (VU.singleton 0.15) - ++ replicate 100 (VU.singleton (-0.15)) - ) - predFracPos m = - let preds = V.map (predict m) testRows - ps = V.length (V.filter (> 0) preds) - in fromIntegral ps / fromIntegral (V.length testRows) :: Double - fracUnbal = predFracPos mUnbal - fracBal = predFracPos mBal - -- Reviewer-tightened intercept bounds (logit(0.95) ≈ 2.94 is the - -- intercept-only solution; the weak slope shrinks this slightly). - assertBool - ("unbalanced |b| > 2.0; got " ++ show bUnbal) - (abs bUnbal > 2.0) - assertBool - ("balanced |b| < 0.3; got " ++ show bBal) - (abs bBal < 0.3) - -- Prediction-class-balance assertion: - assertBool - ("unbalanced fraction-positive on balanced test ≥ 0.90; got " ++ show fracUnbal) - (fracUnbal >= 0.90) - assertBool - ( "balanced fraction-positive on balanced test ∈ [0.40, 0.60]; got " - ++ show fracBal - ) - (fracBal >= 0.40 && fracBal <= 0.60) - ------------------------------------------------------------------------- --- Test list ------------------------------------------------------------------------- - -tests :: [Test] -tests = - [ TestLabel "A1 recover known hyperplane" testA1RecoverHyperplane - , TestLabel "A2 L1 sparsity" testA2L1Sparsity - , TestLabel "A3 convergence" testA3Convergence - , TestLabel "A4 loss not increasing" testA4LossNotIncreasing - , TestLabel "A5 all same direction" testA5AllSameDirection - , TestLabel "A6 empty input" testA6Empty - , TestLabel "A7 constant feature" testA7ConstantFeature - , TestLabel "A8 large feature values" testA8LargeValues - , TestLabel "A9 standardization round-trip" testA9StandardizationRoundTrip - , TestLabel "A10 determinism" testA10Determinism - , TestLabel "A11 ground truth ratio" testA11GroundTruthRatio - , TestLabel "A12 maxIter zero" testA12MaxIterZero - , TestLabel "A13 maxIter one" testA13MaxIterOne - , TestLabel "A14 constant huge value" testA14ConstantHugeValue - , TestLabel "A15 all-zero feature" testA15AllZeroFeature - , TestLabel "A16 imbalanced 99:1 labels" testA16ImbalancedLabels - , TestLabel "A17 imbalanced raw scales" testA17ImbalancedRawScales - , TestLabel "B1 Expr well-typed" testB1ExprWellTyped - , TestLabel "B2 zero weights pruned" testB2ZeroWeightsPruned - , -- PR 3: Elastic Net + class-balanced weights. - TestLabel "A19 Elastic Net grouping ρ=0.97" testA19ElasticNetRecoveryHigh - , TestLabel "A19 Elastic Net grouping ρ=0.7" testA19ElasticNetRecoveryMid - , TestLabel "A20 class-balanced fit on 95/5" testA20ClassBalancedFit - ] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -8,12 +8,11 @@ import Test.HUnit import Test.QuickCheck -import qualified Cart -import qualified DecisionTree import qualified Functions import qualified IO.CSV import qualified IO.CsvGolden import qualified IO.JSON +import qualified IR.ExprJsonRoundtrip import qualified Internal.ColumnBuilder import qualified Internal.DictEncode import qualified Internal.Markdown @@ -22,17 +21,14 @@ import qualified LazyParity import qualified LazyParquet import qualified Learn.Denotation -import qualified Learn.EdgeCases import qualified Learn.Ensembles import qualified Learn.Metamorphic import qualified Learn.MetricsTests import qualified Learn.Models -import qualified Learn.NumericalRigor -import qualified Learn.Numerics +import qualified Learn.Segmented import qualified Learn.SklearnParity -import qualified Learn.Symbolic import qualified Learn.Synthesis -import qualified LinearSolver +import qualified Learn.TypedModel import qualified Monad import qualified Operations.Aggregations import qualified Operations.Apply @@ -64,33 +60,30 @@ import qualified PackedTextMigration import qualified Parquet import qualified Plotting +import qualified PrettyPrint import qualified Properties import qualified Properties.Categorical -import qualified Properties.Simplify import qualified Simplify -import qualified TreePruning -import qualified Worklist +import qualified Typed.IOReaders +import qualified Typed.Parity tests :: Test tests = TestList $ - DecisionTree.tests - ++ Internal.ColumnBuilder.tests + Internal.ColumnBuilder.tests ++ Internal.DictEncode.tests ++ Internal.Markdown.tests ++ Internal.PackedText.tests ++ Internal.Parsing.tests - ++ Learn.Numerics.tests ++ Learn.Denotation.tests ++ Learn.Models.tests + ++ Learn.TypedModel.tests ++ Learn.Ensembles.tests - ++ Learn.Symbolic.tests ++ Learn.SklearnParity.tests ++ Learn.Synthesis.tests ++ Learn.MetricsTests.tests ++ Learn.Metamorphic.tests - ++ Learn.EdgeCases.tests - ++ Learn.NumericalRigor.tests + ++ Learn.Segmented.tests ++ Operations.Aggregations.tests ++ Operations.Apply.tests ++ Operations.Core.tests @@ -122,16 +115,16 @@ ++ IO.CSV.tests ++ IO.CsvGolden.tests ++ IO.JSON.tests + ++ IR.ExprJsonRoundtrip.tests ++ Parquet.tests ++ LazyParquet.tests ++ LazyParity.tests ++ Plotting.tests - ++ LinearSolver.tests ++ Simplify.tests - ++ TreePruning.tests - ++ Worklist.tests - ++ Cart.tests ++ PackedTextMigration.tests + ++ PrettyPrint.tests + ++ Typed.Parity.tests + ++ Typed.IOReaders.tests isSuccessful :: Result -> Bool isSuccessful (Success{}) = True @@ -143,7 +136,6 @@ if failures result > 0 || errors result > 0 then Exit.exitFailure else do - -- Property tests propRes <- mapM (quickCheckWithResult stdArgs) @@ -155,14 +147,10 @@ Internal.ColumnBuilder.props propsRes <- mapM (quickCheckWithResult stdArgs) Properties.tests catRes <- mapM (quickCheckWithResult stdArgs) Properties.Categorical.tests - simpRes <- mapM (quickCheckWithResult stdArgs) Properties.Simplify.tests - wlRes <- mapM (quickCheckWithResult stdArgs) Worklist.props if not (all isSuccessful propRes) || not (all isSuccessful cbRes) || not (all isSuccessful monadRes) || not (all isSuccessful propsRes) || not (all isSuccessful catRes) - || not (all isSuccessful simpRes) - || not (all isSuccessful wlRes) then Exit.exitFailure else Exit.exitSuccess diff --git a/tests/Operations/Apply.hs b/tests/Operations/Apply.hs --- a/tests/Operations/Apply.hs +++ b/tests/Operations/Apply.hs @@ -17,6 +17,7 @@ import DataFrame.Operations.Transformations (impute) import Assertions +import Data.Maybe (listToMaybe) import Test.HUnit import Type.Reflection (typeRep) @@ -80,6 +81,20 @@ (print $ D.apply @[Char] (const (1 :: Int)) "test9" testData) ) +applyIntroducesNulls :: Test +applyIntroducesNulls = + TestCase + ( assertEqual + "apply with a -> Maybe b yields a nullable column, not a boxed Maybe vector" + (Just "NullableUnboxed") + ( DI.columnVersionString + <$> DI.getColumn "test" (D.apply @String listToMaybe "test" nullableApplyData) + ) + ) + where + nullableApplyData = + D.fromNamedColumns [("test", DI.fromList ["", "b" :: String])] + applyManyOnlyGivenFields :: Test applyManyOnlyGivenFields = TestCase @@ -270,6 +285,7 @@ , TestLabel "applyWrongType" applyWrongType , TestLabel "applyUnknownColumn" applyUnknownColumn , TestLabel "applyBoxedToBoxed" applyBoxedToBoxed + , TestLabel "applyIntroducesNulls" applyIntroducesNulls , TestLabel "applyManyBoxedToBoxed" applyManyBoxedToBoxed , TestLabel "applyManyOnlyGivenFields" applyManyOnlyGivenFields , TestLabel "applyManyBoxedToUnboxed" applyManyBoxedToUnboxed diff --git a/tests/Operations/Record.hs b/tests/Operations/Record.hs --- a/tests/Operations/Record.hs +++ b/tests/Operations/Record.hs @@ -23,8 +23,8 @@ import qualified DataFrame as D import qualified DataFrame.Functions as F import qualified DataFrame.Internal.Column as DI -import qualified DataFrame.Internal.Schema as IS import DataFrame.Operators +import qualified DataFrame.Schema as IS import DataFrame.Typed (Schema) import qualified DataFrame.Typed as DT @@ -39,7 +39,7 @@ deriving (Show, Eq) $(DT.deriveSchemaFromType ''Order) -$(D.deriveSchema ''Order) +$(D.deriveSchemaValues ''Order) -- Nullable fields (Maybe Text -> RNullableBoxed; Maybe Int -> RNullableUnboxed). data User = User @@ -50,7 +50,7 @@ deriving (Show, Eq) $(DT.deriveSchemaFromType ''User) -$(D.deriveSchema ''User) +$(D.deriveSchemaValues ''User) -- Identity-cased: keep the record selector names verbatim. data Account = Account @@ -90,7 +90,7 @@ deriving (Show, Eq) $(DT.deriveSchemaFromType ''Wide) -$(D.deriveSchema ''Wide) +$(D.deriveSchemaValues ''Wide) -- Generics opt-in: derive the schema via Generic, not TH. data Foo = Foo @@ -170,11 +170,12 @@ Left e -> assertFailure (T.unpack e) Right ys -> assertEqual "schema-name override round-trip" xs ys +-- order_id is deliberately Int (not the schema's Int64) to force a mismatch. typeMismatchError :: Test typeMismatchError = TestCase $ do let badDf = D.fromNamedColumns - [ ("order_id", DI.fromList ([1, 2, 3] :: [Int])) -- wrong: Int, not Int64 + [ ("order_id", DI.fromList ([1, 2, 3] :: [Int])) , ("region", DI.fromList (["us", "eu", "ap"] :: [T.Text])) , ("amount", DI.fromList ([10.0, 20.5, 30.0] :: [Double])) ] diff --git a/tests/Parquet.hs b/tests/Parquet.hs --- a/tests/Parquet.hs +++ b/tests/Parquet.hs @@ -17,6 +17,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Set as S import qualified Data.Text as T +import Data.Time (UTCTime (UTCTime), fromGregorian, picosecondsToDiffTime) import Data.Word import DataFrame.IO.Parquet.Thrift ( cc_meta_data, @@ -1307,9 +1308,33 @@ "score should NOT be nullable" (not (hasMissing (unsafeGetColumn "score" df))) +{- | Nanosecond-precision timestamps (@TIMESTAMP(NANOS)@) must decode to the +correct 'UTCTime'. Regression test for the unit-scaling bug where the NANOS +multiplier @1_000_000 \`div\` 1_000_000_000@ truncated to 0, collapsing every +value to the epoch. +-} +timestampNanos :: Test +timestampNanos = testBothReadParquetPaths $ \readParquet -> + TestCase $ + assertEqual + "TIMESTAMP(NANOS) decodes to correct UTCTime" + ( D.fromNamedColumns + [ + ( "ts" + , D.fromList + [ UTCTime (fromGregorian 2020 1 1) 0 + , UTCTime (fromGregorian 2021 6 15) (picosecondsToDiffTime 45045123456789000) + , UTCTime (fromGregorian 1999 12 31) (picosecondsToDiffTime 86399999999999000) + ] + ) + ] + ) + (unsafePerformIO (readParquet "./tests/data/timestamp_nanos.parquet")) + tests :: [Test] tests = - [ allTypesPlain + [ timestampNanos + , allTypesPlain , allTypesPlainSnappy , allTypesDictionary , selectedColumnsWithOpts diff --git a/tests/PrettyPrint.hs b/tests/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/tests/PrettyPrint.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{- | Golden tests pinning the format of 'prettyPrint'/'prettyPrintWidth': flat +@else if@ ladders, operator-precedence parenthesization, width-aware wrapping of +commutative chains, and short expressions staying on one line. +-} +module PrettyPrint (tests) where + +import qualified Data.Text as T +import DataFrame.Internal.Expression (Expr, prettyPrint, prettyPrintWidth) +import DataFrame.Operators +import Test.HUnit + +a, b, c :: Expr Double +a = col "a" +b = col "b" +c = col "c" + +golden :: String -> String -> String -> Test +golden label want got = + TestLabel label . TestCase $ assertEqual label want got + +tests :: [Test] +tests = + [ -- A short conditional stays compact; then/else still break onto own lines. + golden + "fits on one line" + "if x .>=. 0.0\nthen \"pos\"\nelse \"neg\"" + ( prettyPrint + (ifThenElse (col @Double "x" .>=. lit 0.0) (lit @T.Text "pos") (lit "neg")) + ) + , -- Nested else-if forms a flat ladder (no staircase indentation). + golden + "flat else-if ladder" + "if a .>. 1.0\nthen \"x\"\nelse if b .>. 2.0\nthen \"y\"\nelse \"z\"" + ( prettyPrint + ( ifThenElse + (col @Double "a" .>. lit 1.0) + (lit @T.Text "x") + (ifThenElse (col @Double "b" .>. lit 2.0) (lit "y") (lit "z")) + ) + ) + , -- A lower-precedence operand is parenthesized under a higher one. + golden "precedence: (a + b) * c" "(a + b) * c" (prettyPrint ((a + b) * c)) + , -- No spurious parens when precedence already disambiguates. + golden "precedence: a + b * c" "a + b * c" (prettyPrint (a + b * c)) + , -- Non-commutative operators are not flattened/reordered. + golden "left-assoc subtraction" "a - b - c" (prettyPrint (a - b - c)) + , -- A commutative chain stays on one line when it fits the width. + golden + "commutative chain fits" + "alpha + beta + gamma" + (prettyPrintWidth 80 (col @Double "alpha" + col "beta" + col "gamma")) + , -- The same chain wraps at the operator with a hanging indent when narrow. + golden + "commutative chain wraps" + "alpha\n + beta\n + gamma" + (prettyPrintWidth 12 (col @Double "alpha" + col "beta" + col "gamma")) + , -- A comparison/logical chain that fits stays free of grouping parens. + golden + "boolean chain fits: no paren noise" + "a + b .>=. c .&&. a .>. b" + (prettyPrintWidth 80 ((a + b .>=. c) .&&. (a .>. b))) + , -- When a nested operand wraps, parens delimit it; flat operands stay bare. + golden + "wrapped operand gets parens" + "(a + b + c\n .>=. 0.0)\n .&&. a .>. b" + (prettyPrintWidth 16 ((a + b + c .>=. lit 0.0) .&&. (a .>. b))) + ] diff --git a/tests/Properties/Simplify.hs b/tests/Properties/Simplify.hs deleted file mode 100644 --- a/tests/Properties/Simplify.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -{- | Property tests for the simplifier and tree-pruning pass: the durable -guarantees the hand-written examples only sample. - - * @simplify@ preserves denotation (@interpret e ≡ interpret (simplify e)@), - over Bool and Maybe Bool, on a DataFrame that includes NaN, null, and - exact-boundary rows. - * @simplify@ is idempotent (reaches a normal form within the fixpoint cap). - * @pruneDead@ preserves the function the tree computes, on every row. --} -module Properties.Simplify (tests) where - -import qualified DataFrame as D -import DataFrame.DecisionTree (Tree (..), predictWithTree, pruneDead) -import qualified DataFrame.Functions as F -import DataFrame.Internal.Column (TypedColumn (TColumn), toVector) -import qualified DataFrame.Internal.Column as DI -import DataFrame.Internal.Expression (Expr, eqExpr) -import DataFrame.Internal.Interpreter (interpret) -import DataFrame.Internal.Simplify (simplify) -import DataFrame.Operators - -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import Test.QuickCheck - --- A fixture spanning the interesting rows: exact thresholds, gaps, NaN, null. -fixtureDF :: D.DataFrame -fixtureDF = - D.fromNamedColumns - [ - ( "x" - , DI.fromList ([10, 20, 25, 30, 35, 40, 50, 0 / 0, -(1 / 0), 1 / 0] :: [Double]) - ) - , ("n", DI.fromList ([10, 20, 25, 30, 35, 40, 50, 0, 100, -5] :: [Int])) - , - ( "m" - , DI.fromList - ( [ Just 10 - , Nothing - , Just 30 - , Just 35 - , Nothing - , Just 50 - , Just 0 - , Just 30 - , Nothing - , Just 40 - ] :: - [Maybe Double] - ) - ) - ] - -thresholds :: [Double] -thresholds = [20, 25, 30, 35, 40] - --- ---- generators ---- - --- strict-Bool comparison atoms over the Double column "x" and Int column "n" -genAtomBool :: Gen (Expr Bool) -genAtomBool = do - t <- elements thresholds - oneof - [ elements - [ F.col @Double "x" .< F.lit t - , F.col @Double "x" .<= F.lit t - , F.col @Double "x" .> F.lit t - , F.col @Double "x" .>= F.lit t - , F.col @Double "x" .== F.lit t - , F.col @Double "x" ./= F.lit t - ] - , elements - [ F.toDouble (F.col @Int "n") .< F.lit t - , F.toDouble (F.col @Int "n") .<= F.lit t - , F.toDouble (F.col @Int "n") .> F.lit t - , F.toDouble (F.col @Int "n") .>= F.lit t - ] - ] - -genBoolExpr :: Int -> Gen (Expr Bool) -genBoolExpr d - | d <= 0 = genAtomBool - | otherwise = - oneof - [ genAtomBool - , F.and <$> genBoolExpr (d - 1) <*> genBoolExpr (d - 1) - , F.or <$> genBoolExpr (d - 1) <*> genBoolExpr (d - 1) - , F.not <$> genBoolExpr (d - 1) - ] - --- nullable comparison atoms over the Maybe Double column "m" -genAtomMaybe :: Gen (Expr (Maybe Bool)) -genAtomMaybe = do - t <- elements thresholds - elements - [ F.col @(Maybe Double) "m" .< F.lit t - , F.col @(Maybe Double) "m" .<= F.lit t - , F.col @(Maybe Double) "m" .> F.lit t - , F.col @(Maybe Double) "m" .>= F.lit t - , F.col @(Maybe Double) "m" .== F.lit t - , F.col @(Maybe Double) "m" ./= F.lit t - ] - -genMaybeExpr :: Int -> Gen (Expr (Maybe Bool)) -genMaybeExpr d - | d <= 0 = genAtomMaybe - | otherwise = - oneof - [ genAtomMaybe - , (.&&) <$> genMaybeExpr (d - 1) <*> genMaybeExpr (d - 1) - , (.||) <$> genMaybeExpr (d - 1) <*> genMaybeExpr (d - 1) - ] - -genTree :: Int -> Gen (Tree T.Text) -genTree d - | d <= 0 = Leaf <$> elements ["A", "B", "C"] - | otherwise = - oneof - [ Leaf <$> elements ["A", "B", "C"] - , do - cond <- genAtomBool - Branch cond <$> genTree (d - 1) <*> genTree (d - 1) - ] - --- ---- evaluation helpers ---- - -evalBool :: D.DataFrame -> Expr Bool -> Maybe (VU.Vector Bool) -evalBool df e = case interpret @Bool df e of - Right (TColumn tcol) -> either (const Nothing) Just (toVector @Bool @VU.Vector tcol) - Left _ -> Nothing - -evalMaybe :: D.DataFrame -> Expr (Maybe Bool) -> Maybe (V.Vector (Maybe Bool)) -evalMaybe df e = case interpret @(Maybe Bool) df e of - Right (TColumn tcol) -> either (const Nothing) Just (toVector @(Maybe Bool) @V.Vector tcol) - Left _ -> Nothing - --- ---- properties ---- - -prop_simplifyPreservesBool :: Property -prop_simplifyPreservesBool = - forAll (genBoolExpr 4) $ \e -> - evalBool fixtureDF e === evalBool fixtureDF (simplify e) - -prop_simplifyPreservesMaybe :: Property -prop_simplifyPreservesMaybe = - forAll (genMaybeExpr 3) $ \e -> - evalMaybe fixtureDF e === evalMaybe fixtureDF (simplify e) - -prop_simplifyIdempotent :: Property -prop_simplifyIdempotent = - forAll (genBoolExpr 4) $ \e -> - let s = simplify e in property (eqExpr (simplify s) s) - -prop_pruneDeadPreserves :: Property -prop_pruneDeadPreserves = - forAll (genTree 4) $ \t -> - let n = D.nRows fixtureDF - predAll tr = [predictWithTree @T.Text "x" fixtureDF i tr | i <- [0 .. n - 1]] - in predAll (pruneDead t) === predAll t - -tests :: [Property] -tests = - [ prop_simplifyPreservesBool - , prop_simplifyPreservesMaybe - , prop_simplifyIdempotent - , prop_pruneDeadPreserves - ] diff --git a/tests/TreePruning.hs b/tests/TreePruning.hs deleted file mode 100644 --- a/tests/TreePruning.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -{- | Specification for the fitted-tree pruning pass ('pruneDead'): path-condition -entailment, the false-edge NaN gate, and same-branch collapse. --} -module TreePruning (tests) where - -import DataFrame.DecisionTree (Tree (..), pruneDead) -import qualified DataFrame.Functions as F -import DataFrame.Internal.Expression (eqExpr) -import DataFrame.Operators - -import qualified Data.Text as T -import Test.HUnit - -treeEq :: (Eq a) => Tree a -> Tree a -> Bool -treeEq (Leaf x) (Leaf y) = x == y -treeEq (Branch c1 l1 r1) (Branch c2 l2 r2) = eqExpr c1 c2 && treeEq l1 l2 && treeEq r1 r2 -treeEq _ _ = False - -prunesTo :: String -> Tree T.Text -> Tree T.Text -> Test -prunesTo label input want = - TestLabel label . TestCase $ - assertBool - (label ++ ": got " ++ show (pruneDead input) ++ " want " ++ show want) - (treeEq (pruneDead input) want) - -preserved :: String -> Tree T.Text -> Test -preserved label t = prunesTo label t t - -pathEntailment :: [Test] -pathEntailment = - [ prunesTo - "ancestor entails child keeps true subtree" - ( Branch - (F.col @Double "age" .> F.lit (50 :: Double)) - (Branch (F.col @Double "age" .> F.lit (30 :: Double)) (Leaf "a") (Leaf "b")) - (Leaf "c") - ) - (Branch (F.col @Double "age" .> F.lit (50 :: Double)) (Leaf "a") (Leaf "c")) - , prunesTo - "ancestor refutes child keeps false subtree" - ( Branch - (F.col @Double "age" .> F.lit (50 :: Double)) - (Branch (F.col @Double "age" .< F.lit (40 :: Double)) (Leaf "a") (Leaf "b")) - (Leaf "c") - ) - (Branch (F.col @Double "age" .> F.lit (50 :: Double)) (Leaf "b") (Leaf "c")) - ] - -falseEdgeGate :: [Test] -falseEdgeGate = - [ prunesTo - "integral false edge entails child" - ( Branch - (F.toDouble (F.col @Int "ai") .> F.lit (50 :: Double)) - (Leaf "c") - ( Branch - (F.toDouble (F.col @Int "ai") .< F.lit (60 :: Double)) - (Leaf "a") - (Leaf "b") - ) - ) - ( Branch - (F.toDouble (F.col @Int "ai") .> F.lit (50 :: Double)) - (Leaf "c") - (Leaf "a") - ) - ] - -sameBranchCollapse :: [Test] -sameBranchCollapse = - [ prunesTo - "equal leaves collapse the branch" - (Branch (F.col @Double "age" .> F.lit (50 :: Double)) (Leaf "a") (Leaf "a")) - (Leaf "a") - , prunesTo - "collapse cascades upward" - ( Branch - (F.col @Double "age" .> F.lit (50 :: Double)) - (Branch (F.col @Double "hours" .> F.lit (40 :: Double)) (Leaf "a") (Leaf "a")) - (Leaf "a") - ) - (Leaf "a") - ] - -preservedTrees :: [Test] -preservedTrees = - [ preserved - "child not tight enough is kept" - ( Branch - (F.col @Double "age" .> F.lit (50 :: Double)) - (Branch (F.col @Double "age" .> F.lit (60 :: Double)) (Leaf "a") (Leaf "b")) - (Leaf "c") - ) - , preserved - "double false edge is kept (NaN)" - ( Branch - (F.col @Double "weight" .> F.lit (50 :: Double)) - (Leaf "c") - (Branch (F.col @Double "weight" .< F.lit (60 :: Double)) (Leaf "a") (Leaf "b")) - ) - , preserved - "cross-column descendant is kept" - ( Branch - (F.col @Double "age" .> F.lit (50 :: Double)) - (Branch (F.col @Double "income" .> F.lit (30000 :: Double)) (Leaf "a") (Leaf "b")) - (Leaf "c") - ) - ] - -tests :: [Test] -tests = concat [pathEntailment, falseEdgeGate, sameBranchCollapse, preservedTrees] diff --git a/tests/Typed/IOReaders.hs b/tests/Typed/IOReaders.hs new file mode 100644 --- /dev/null +++ b/tests/Typed/IOReaders.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{- | Tests for the typed CSV reader: a write\/read round-trip matches the untyped +reader, a wrong schema surfaces as 'Left' via 'readCsvWithError', and the +throwing 'readCsv' raises a 'DataFrameException'. The Parquet reader uses the +identical freeze-on-read path. +-} +module Typed.IOReaders (tests) where + +import Control.Exception (evaluate, try) +import Data.Either (isLeft) +import qualified Data.Text as T +import System.IO (hClose) +import System.IO.Temp (withSystemTempFile) + +import qualified DataFrame as D +import DataFrame.Errors (DataFrameException) +import qualified DataFrame.Internal.Column as DI +import qualified DataFrame.Typed as DT +import qualified DataFrame.Typed.IO.CSV as TCSV + +import Test.HUnit + +type S = + '[ DT.Column "x" Int + , DT.Column "y" Double + , DT.Column "g" T.Text + ] + +sampleDF :: D.DataFrame +sampleDF = + D.fromNamedColumns + [ ("x", DI.fromList [1, 2, 3 :: Int]) + , ("y", DI.fromList [1.5, 2.5, 3.5 :: Double]) + , ("g", DI.fromList ["a", "b", "c" :: T.Text]) + ] + +roundTrip :: Test +roundTrip = TestCase $ withSystemTempFile "typed_parity.csv" $ \fp h -> do + hClose h + D.writeCsv fp sampleDF + untyped <- D.readCsv fp + typed <- DT.thaw <$> TCSV.readCsv @S fp + assertEqual "typed readCsv round-trips like untyped readCsv" untyped typed + +wrongSchemaEither :: Test +wrongSchemaEither = TestCase $ withSystemTempFile "typed_err.csv" $ \fp h -> do + hClose h + D.writeCsv fp sampleDF + res <- TCSV.readCsvWithError @'[DT.Column "nope" Int] fp + assertBool "wrong schema => Left" (isLeft res) + +wrongSchemaThrows :: Test +wrongSchemaThrows = TestCase $ withSystemTempFile "typed_throw.csv" $ \fp h -> do + hClose h + D.writeCsv fp sampleDF + r <- + try (TCSV.readCsv @'[DT.Column "nope" Int] fp >>= evaluate . DT.nRows) :: + IO (Either DataFrameException Int) + assertBool "wrong schema => throws DataFrameException" (isLeft r) + +tests :: [Test] +tests = [roundTrip, wrongSchemaEither, wrongSchemaThrows] diff --git a/tests/Typed/Parity.hs b/tests/Typed/Parity.hs new file mode 100644 --- /dev/null +++ b/tests/Typed/Parity.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Typed.Parity (tests) where + +import Data.Either (fromRight) +import qualified Data.Text as T +import System.Random (mkStdGen) + +import qualified DataFrame as D +import qualified DataFrame.Functions as F +import qualified DataFrame.Internal.Column as DI +import qualified DataFrame.Typed as DT +import qualified DataFrame.Typed.Statistics as TS + +import Test.HUnit + +type S = + '[ DT.Column "x" Int + , DT.Column "y" Double + , DT.Column "g" T.Text + ] + +baseDF :: D.DataFrame +baseDF = + D.fromNamedColumns + [ ("x", DI.fromList [1, 2, 3, 4, 5, 6 :: Int]) + , ("y", DI.fromList [10.0, 25.0, 30.0, 5.0, 50.0, 12.0 :: Double]) + , ("g", DI.fromList ["a", "b", "a", "b", "a", "b" :: T.Text]) + ] + +tdf :: DT.TypedDataFrame S +tdf = either (error . show) id (DT.freezeWithError baseDF) + +-- Statistics reducers should match the untyped ones exactly (same code path). +statParity :: Test +statParity = + TestList + [ eq "mean" (TS.mean (DT.col @"y") tdf) (D.mean (F.col @Double "y") baseDF) + , eq "median" (TS.median (DT.col @"y") tdf) (D.median (F.col @Double "y") baseDF) + , eq + "variance" + (TS.variance (DT.col @"y") tdf) + (D.variance (F.col @Double "y") baseDF) + , eq + "stddev" + (TS.standardDeviation (DT.col @"y") tdf) + (D.standardDeviation (F.col @Double "y") baseDF) + , eq "sum" (TS.sum (DT.col @"x") tdf) (D.sum (F.col @Int "x") baseDF) + , eq + "percentile" + (TS.percentile 50 (DT.col @"y") tdf) + (D.percentile 50 (F.col @Double "y") baseDF) + , eq + "iqr" + (TS.interQuartileRange (DT.col @"y") tdf) + (D.interQuartileRange (F.col @Double "y") baseDF) + , eq + "skewness" + (TS.skewness (DT.col @"y") tdf) + (D.skewness (F.col @Double "y") baseDF) + , eq + "correlation" + (TS.correlation @"x" @"y" tdf) + (D.correlation "x" "y" baseDF) + ] + where + eq :: (Eq a, Show a) => String -> a -> a -> Test + eq lbl typed untyped = TestCase (assertEqual ("typed stat " ++ lbl) untyped typed) + +-- Expression combinators ported in Expr.Extra: derive a column both ways. +exprParity :: Test +exprParity = + TestList + [ deriveEq "pow" (DT.pow (DT.col @"x") 2) (F.pow (F.col @Int "x") 2) + , deriveEq "relu" (DT.relu (DT.col @"x")) (F.relu (F.col @Int "x")) + , deriveEq "toMaybe" (DT.toMaybe (DT.col @"x")) (F.toMaybe (F.col @Int "x")) + , deriveEq + "min" + (DT.min (DT.col @"x") (DT.lit 3)) + (F.min (F.col @Int "x") (F.lit @Int 3)) + , deriveEq + "splitOn" + (DT.splitOn "a" (DT.col @"g")) + (F.splitOn "a" (F.col @T.Text "g")) + , deriveEq + "recodeWithDefault" + (DT.recodeWithDefault 0 [(1 :: Int, 100 :: Int)] (DT.col @"x")) + (F.recodeWithDefault 0 [(1 :: Int, 100 :: Int)] (F.col @Int "x")) + ] + where + deriveEq :: + (DI.Columnable a) => + String -> DT.TExpr S a -> D.Expr a -> Test + deriveEq lbl te ue = + TestCase + ( assertEqual + ("typed derive " ++ lbl) + (D.derive "r" ue baseDF) + (DT.thaw (DT.derive @"r" te tdf)) + ) + +-- apply / valueCounts / horizontal merge. +applyParity :: Test +applyParity = + TestList + [ TestCase + ( assertEqual + "applyColumn type-change" + (D.apply (show :: Int -> String) "x" baseDF) + (DT.thaw (DT.applyColumn @"x" (show :: Int -> String) tdf)) + ) + , TestCase + ( assertEqual + "applyMany type-preserving" + (D.applyMany (+ (1 :: Int)) ["x"] baseDF) + (DT.thaw (DT.applyMany @'["x"] (+ (1 :: Int)) tdf)) + ) + , TestCase + ( assertEqual + "valueCounts" + (D.valueCounts (F.col @T.Text "g") baseDF) + (DT.valueCounts (DT.col @"g") tdf) + ) + , TestCase + ( assertEqual + "horizontal merge (|||)" + (leftDF D.||| rightDF) + (DT.thaw ((DT.|||) leftT rightT)) + ) + ] + +-- Sampling/splitting determinism: same seed => same rows as the untyped form. +samplingParity :: Test +samplingParity = + TestList + [ TestCase + ( assertEqual + "randomSplit" + (D.randomSplit (mkStdGen 7) 0.5 baseDF) + (let (a, b) = DT.randomSplit (mkStdGen 7) 0.5 tdf in (DT.thaw a, DT.thaw b)) + ) + , TestCase + ( assertEqual + "kFolds" + (D.kFolds (mkStdGen 7) 3 baseDF) + (map DT.thaw (DT.kFolds (mkStdGen 7) 3 tdf)) + ) + ] + +-- Matrix / numeric-vector extraction. +accessParity :: Test +accessParity = + TestList + [ TestCase + ( assertEqual + "columnAsDoubleVector" + (extract (D.columnAsDoubleVector (F.col @Double "y") baseDF)) + (DT.columnAsDoubleVector @"y" tdf) + ) + , TestCase + ( assertEqual + "toDoubleMatrix" + (extract (D.toDoubleMatrix numericDF)) + (DT.toDoubleMatrix numericT) + ) + ] + where + extract :: Either e a -> a + extract = fromRight (error "extraction failed") + +-- Disjoint frames for the (|||) test. +leftDF :: D.DataFrame +leftDF = D.fromNamedColumns [("x", DI.fromList [1, 2 :: Int])] + +rightDF :: D.DataFrame +rightDF = D.fromNamedColumns [("y", DI.fromList [1.0, 2.0 :: Double])] + +leftT :: DT.TypedDataFrame '[DT.Column "x" Int] +leftT = either (error . show) id (DT.freezeWithError leftDF) + +rightT :: DT.TypedDataFrame '[DT.Column "y" Double] +rightT = either (error . show) id (DT.freezeWithError rightDF) + +-- Numeric-only frame for the matrix test. +numericDF :: D.DataFrame +numericDF = + D.fromNamedColumns + [ ("x", DI.fromList [1, 2, 3 :: Int]) + , ("y", DI.fromList [1.5, 2.5, 3.5 :: Double]) + ] + +numericT :: DT.TypedDataFrame '[DT.Column "x" Int, DT.Column "y" Double] +numericT = either (error . show) id (DT.freezeWithError numericDF) + +tests :: [Test] +tests = + [ statParity + , exprParity + , applyParity + , samplingParity + , accessParity + ] diff --git a/tests/Worklist.hs b/tests/Worklist.hs deleted file mode 100644 --- a/tests/Worklist.hs +++ /dev/null @@ -1,466 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -{- | Up-front (TDD) spec for the saturation worklist 'saturateCandidates' that -will replace the lazy generate-all 'boolExprsVec'. The existing depth-bounded -'boolExprsVec' is kept as the behaviour-preservation oracle. - -State: 'saturateCandidates' is the identity stub, so the structural same-set -and truth-vector floor/collapse cases FAIL (red) — that is the spec PR1 must -meet; base-inclusion / dedup / determinism hold under the stub. --} -module Worklist (tests, props) where - -import qualified DataFrame as D -import DataFrame.DecisionTree ( - CondVec, - DedupMode (Structural, TruthVector), - boolExprsVec, - combineAndVec, - combineOrVec, - cvExpr, - cvVec, - materializeCondVec, - saturateCandidates, - ) -import qualified DataFrame.Functions as F -import qualified DataFrame.Internal.Column as DI -import DataFrame.Internal.Expression ( - Expr, - compareExpr, - eSize, - eqExpr, - normalize, - ) -import DataFrame.Operators - -import Data.Function (on) -import Data.List (minimumBy, nubBy) -import qualified Data.Maybe -import qualified Data.Set as Set -import qualified Data.Vector.Unboxed as VU -import Test.HUnit -import Test.QuickCheck - --- Fixture: x = 0..5, y = 5..0 (anti-correlated), z scrambled (independent of both). --- Note x>2 and y<3 share the truth vector [F,F,F,T,T,T], so the truth-vector mode --- must collapse them; z gives a third column for non-consolidating cross-column combos. -fixtureDF :: D.DataFrame -fixtureDF = - D.fromNamedColumns - [ ("x", DI.fromList ([0, 1, 2, 3, 4, 5] :: [Double])) - , ("y", DI.fromList ([5, 4, 3, 2, 1, 0] :: [Double])) - , ("z", DI.fromList ([2, 5, 1, 4, 0, 3] :: [Double])) - ] - -mat :: Expr Bool -> CondVec -mat e = - Data.Maybe.fromMaybe - (error "Worklist.mat: could not materialize") - (materializeCondVec fixtureDF e) - -xGt, xLt, yGt, yLt, zGt, zLt :: Double -> CondVec -xGt n = mat (F.col @Double "x" .>. F.lit n) -xLt n = mat (F.col @Double "x" .<. F.lit n) -yGt n = mat (F.col @Double "y" .>. F.lit n) -yLt n = mat (F.col @Double "y" .<. F.lit n) -zGt n = mat (F.col @Double "z" .>. F.lit n) -zLt n = mat (F.col @Double "z" .<. F.lit n) - --- Same truth vector as 'xGt 2' ([F,F,F,T,T,T]) but eSize 4 vs 3 — a non-degenerate --- truth-vector collision for the min-eSize representative rule. -notLe2 :: CondVec -notLe2 = mat (F.not (F.col @Double "x" .<=. F.lit 2)) - -litTrue :: CondVec -litTrue = mat (F.lit True) - -keyOf :: CondVec -> String -keyOf = show . normalize . cvExpr - -keySet :: [CondVec] -> Set.Set String -keySet = Set.fromList . map keyOf - -truthSet :: [CondVec] -> Set.Set [Bool] -truthSet = Set.fromList . map (VU.toList . cvVec) - --- Mirrors 'evalWithPenaltyVec' (DecisionTree.hs): score = (#care-point errors, eSize), --- depending only on the cached vector + size, so distinct same-vector same-size atoms tie. -penBy :: [Bool] -> CondVec -> (Int, Int) -penBy lbls cv = - ( length (filter id (zipWith (/=) lbls (VU.toList (cvVec cv)))) - , eSize (cvExpr cv) - ) - --- The candidate 'bestDiscreteCandidate' would select: the first 'minimumBy penalty' winner. -argminKey :: [Bool] -> [CondVec] -> String -argminKey lbls = keyOf . minimumBy (compare `on` penBy lbls) - --- Oracle: the current depth-bounded generate-all. -ref :: Int -> [CondVec] -> [CondVec] -ref d base = boolExprsVec base base 0 d - -base3 :: [CondVec] -base3 = [xGt 2, xGt 4, yGt 2] - --- x>2 and y<3 share the truth vector [F,F,F,T,T,T], so truth-vector mode collapses --- this 3-atom base to 2 distinct vectors while structural mode keeps all three. -collBase :: [CondVec] -collBase = [xGt 2, yLt 3, yGt 2] - --- Wider fixture (3 independent-ish columns, 10 rows) yielding many distinct truth --- vectors — broader coverage for the truth-vector floor / dedup than the 6-row x/y fixture. -wideDF :: D.DataFrame -wideDF = - D.fromNamedColumns - [ ("a", DI.fromList ([0, 1, 2, 3, 4, 5, 6, 7, 8, 9] :: [Double])) - , ("b", DI.fromList ([9, 7, 5, 3, 1, 8, 6, 4, 2, 0] :: [Double])) - , ("c", DI.fromList ([1, 1, 2, 2, 3, 3, 4, 4, 5, 5] :: [Double])) - ] - -matW :: Expr Bool -> CondVec -matW e = - Data.Maybe.fromMaybe - (error "Worklist.matW: could not materialize") - (materializeCondVec wideDF e) - -wideBase :: [CondVec] -wideBase = - [ matW (F.col @Double "a" .>. F.lit 3) - , matW (F.col @Double "b" .<. F.lit 5) - , matW (F.col @Double "c" .>=. F.lit 3) - ] - ------------------------------------------------------------------------- --- HUnit cases ------------------------------------------------------------------------- - -tests :: [Test] -tests = - [ TestLabel "structural: same distinct set as oracle" . TestCase $ - assertEqual - "keySet" - (keySet (ref 2 base3)) - (keySet (saturateCandidates Structural 2 base3)) - , TestLabel "structural: output deduped (length == distinct keys)" . TestCase $ - let out = saturateCandidates Structural 2 base3 - in assertEqual "no eqExpr duplicates" (Set.size (keySet out)) (length out) - , TestLabel "structural: base atoms all present" . TestCase $ - assertBool "base subset of output" $ - keySet base3 `Set.isSubsetOf` keySet (saturateCandidates Structural 1 base3) - , TestLabel "structural: deterministic" . TestCase $ - assertEqual - "two runs identical" - (map keyOf (saturateCandidates Structural 2 base3)) - (map keyOf (saturateCandidates Structural 2 base3)) - , TestLabel "structural: consolidation flows through the worklist" . TestCase $ - -- x>2 ∧ x>4 ↦ x>4, x>2 ∨ x>4 ↦ x>2, so the distinct set is just {x>2, x>4}. - assertEqual - "consolidated set" - (keySet [xGt 2, xGt 4]) - (keySet (saturateCandidates Structural 2 [xGt 2, xGt 4])) - , TestLabel "truth-vector: all output truth vectors distinct" . TestCase $ - let out = saturateCandidates TruthVector 2 [xGt 2, yLt 3] - in assertEqual "distinct cvVecs" (Set.size (truthSet out)) (length out) - , TestLabel "truth-vector: collapses same-truth atoms (x>2, y<3)" . TestCase $ - -- x>2 and y<3 are identical on the data; one representative survives. - assertEqual - "collapsed to one" - 1 - (length (saturateCandidates TruthVector 1 [xGt 2, yLt 3])) - , TestLabel "truth-vector: reaches the semantic floor (no split dropped)" - . TestCase - $ assertEqual - "same distinct truth vectors as oracle" - (truthSet (ref 2 base3)) - (truthSet (saturateCandidates TruthVector 2 base3)) - , TestLabel "truth-vector: strictly fewer candidates when a collision exists" - . TestCase - $ - -- collBase has x>2 ≡ y<3, so the truth-vector floor is strictly below the structural set. - assertBool "|truth| < |structural|" - $ length (saturateCandidates TruthVector 2 collBase) - < length (saturateCandidates Structural 2 collBase) - , TestLabel "truth-vector: keeps the minimum-eSize representative" . TestCase $ - -- x>2 (eSize 3) and not(x<=2) (eSize 4) share a truth vector; the smaller survives. - let out = saturateCandidates TruthVector 1 [xGt 2, notLe2] - in do - assertEqual "min eSize survivor" [3] (map (eSize . cvExpr) out) - assertEqual "survivor is x>2" [keyOf (xGt 2)] (map keyOf out) - , TestLabel "truth-vector: tie-break independent of input order" . TestCase $ - -- x>2 and y<3 tie on eSize 3; whichever survives must not depend on base order. - assertEqual - "order-independent survivor" - (map keyOf (saturateCandidates TruthVector 1 [xGt 2, yLt 3])) - (map keyOf (saturateCandidates TruthVector 1 [yLt 3, xGt 2])) - , TestLabel "edge: empty base" . TestCase $ - assertEqual - "empty in, empty out" - Set.empty - (keySet (saturateCandidates Structural 2 [])) - , TestLabel "edge: singleton base" . TestCase $ - assertEqual - "same as oracle" - (keySet (ref 2 [xGt 2])) - (keySet (saturateCandidates Structural 2 [xGt 2])) - , TestLabel "edge: maxDepth 0 is the base only" . TestCase $ - assertEqual - "no expansion" - (keySet base3) - (keySet (saturateCandidates Structural 0 base3)) - , TestLabel "edge: duplicate-seeded base" . TestCase $ - let base = [xGt 2, xGt 2, yGt 2] - in assertEqual - "dedups seed, same as oracle" - (keySet (ref 2 base)) - (keySet (saturateCandidates Structural 2 base)) - , TestLabel "edge: literal operand" . TestCase $ - let base = [xGt 2, litTrue] - in assertEqual - "same as oracle" - (keySet (ref 2 base)) - (keySet (saturateCandidates Structural 2 base)) - , TestLabel "law: cvVec is a homomorphism over AND" . TestCase $ - -- the law justifying one-representative-per-truth-class dedup. - assertEqual - "cvVec(a∧b) == cvVec a && cvVec b" - (VU.toList (VU.zipWith (&&) (cvVec (xGt 2)) (cvVec (yGt 2)))) - (VU.toList (cvVec (combineAndVec (xGt 2) (yGt 2)))) - , TestLabel "law: cvVec is a homomorphism over OR" . TestCase $ - assertEqual - "cvVec(a∨b) == cvVec a || cvVec b" - (VU.toList (VU.zipWith (||) (cvVec (xGt 2)) (cvVec (yGt 2)))) - (VU.toList (cvVec (combineOrVec (xGt 2) (yGt 2)))) - , TestLabel "law: consolidated expr re-interprets to its cached vector" . TestCase $ - -- x>2 ∧ x>4 consolidates to x>4; the cached vector must match re-materializing it. - let c = combineAndVec (xGt 2) (xGt 4) - in assertEqual - "cached == re-interpreted" - (VU.toList (cvVec c)) - (VU.toList (cvVec (mat (cvExpr c)))) - , TestLabel "structural: output order matches the deduped oracle" . TestCase $ - -- byte-identical to today's boolExprsVec, with eqExpr-duplicates removed (first kept): - -- this is what lets the consumer's first-wins minimumBy pick the same candidate. - assertEqual - "deduped-oracle order" - (map keyOf (nubBy ((==) `on` keyOf) (ref 2 base3))) - (map keyOf (saturateCandidates Structural 2 base3)) - , TestLabel - "structural: matches oracle set+order at depth 3+4 (non-consolidating)" - . TestCase - $ - -- cross-column base whose closure GROWS with depth (no consolidation); this is where the - -- frontier:=admitted optimisation could diverge from the oracle's frontier:=all-products. - let b = [xGt 2, yGt 2, zGt 1] - deduped d = map keyOf (nubBy ((==) `on` keyOf) (ref d b)) - out d = map keyOf (saturateCandidates Structural d b) - in do - assertEqual "set d3" (Set.fromList (deduped 3)) (Set.fromList (out 3)) - assertEqual "order d3" (deduped 3) (out 3) - assertEqual "set d4" (Set.fromList (deduped 4)) (Set.fromList (out 4)) - assertEqual "order d4" (deduped 4) (out 4) - , TestLabel "structural: stabilizes at fixpoint (depth cap is a no-op past it)" - . TestCase - $ - -- all AND/OR consolidate back into the base ⇒ a genuine fixpoint at round 1, so deeper - -- depth caps add nothing. (For a non-consolidating base the closure grows with depth, - -- since 'normalize' does not flatten associativity — there the cap always binds.) - assertEqual - "depth 2 == depth 5" - (keySet (saturateCandidates Structural 2 [xGt 1, xGt 2, xGt 3, xGt 4])) - (keySet (saturateCandidates Structural 5 [xGt 1, xGt 2, xGt 3, xGt 4])) - , TestLabel "truth-vector: reaches the floor on a wider fixture" . TestCase $ - assertEqual - "same distinct truth vectors as oracle" - (truthSet (ref 2 wideBase)) - (truthSet (saturateCandidates TruthVector 2 wideBase)) - , TestLabel "selection: surfaces the oracle's winning combination" . TestCase $ - -- labels = x>2 ∧ x<5; the unique min-penalty split is that band (not in the base), so - -- 'minimumBy penalty' over the worklist must pick it just as it does over the oracle. - let lbls = [False, False, False, True, True, False] - base = [xGt 2, xLt 5, yGt 2] - in assertEqual - "same argmin as oracle" - (argminKey lbls (ref 2 base)) - (argminKey lbls (saturateCandidates Structural 2 base)) - , TestLabel "selection: tie-winner tracks input order, matching the oracle" - . TestCase - $ - -- x>2 and y<3 both score the min (0,3); 'minimumBy' keeps the first, so the winner must - -- flip with input order exactly as the oracle does. A worklist that imposes its own - -- (eSize, exprKey) order would pick the same atom for both orders and fail one. (byte-identical) - let lbls = [False, False, False, True, True, True] - in do - assertEqual - "x>2-first order" - (argminKey lbls (ref 2 [xGt 2, yLt 3])) - (argminKey lbls (saturateCandidates Structural 2 [xGt 2, yLt 3])) - assertEqual - "y<3-first order" - (argminKey lbls (ref 2 [yLt 3, xGt 2])) - (argminKey lbls (saturateCandidates Structural 2 [yLt 3, xGt 2])) - , TestLabel - "bounded: output is the distinct closure, below the oracle's materialized count" - . TestCase - $ - -- Same-direction thresholds: every AND/OR consolidates, so the closure stays these 4 while - -- the oracle materializes far more. (Peak residency is the +RTS -s integration check.) - let base = [xGt 1, xGt 2, xGt 3, xGt 4] - gen = ref 3 base - in do - assertEqual - "output bounded to the distinct closure" - (Set.size (keySet gen)) - (length (saturateCandidates Structural 3 base)) - assertBool - "oracle materializes more than the closure (the explosion the worklist avoids)" - (Set.size (keySet gen) < length gen) - , TestLabel "structural: maxDepth 1 is base-only (no combination round)" - . TestCase - $ - -- boolExprsVec does no combining until depth 2; the worklist must match it depth-for-depth. - assertEqual - "no combination at depth 1" - (keySet (ref 1 [xGt 2, yGt 2])) - (keySet (saturateCandidates Structural 1 [xGt 2, yGt 2])) - , TestLabel "structural: base atoms survive the combination round" . TestCase $ - -- a base atom regenerated by a combination must not be dropped. - -- a base atom regenerated by a combination must not be dropped. - -- a base atom regenerated by a combination must not be dropped. - -- a base atom regenerated by a combination must not be dropped. - -- a base atom regenerated by a combination must not be dropped. - assertBool "base subset of output at depth 2" $ - keySet base3 `Set.isSubsetOf` keySet (saturateCandidates Structural 2 base3) - , TestLabel - "structural: re-saturating a closed base is stable (fixpoint idempotence)" - . TestCase - $ - -- on a base whose closure is itself, re-saturating changes nothing. (Depth-bounded - -- saturation is NOT idempotent on a growing closure — re-feeding goes one round deeper.) - let b = [xGt 1, xGt 2, xGt 3, xGt 4] - in assertEqual - "saturate ∘ saturate == saturate" - (keySet (saturateCandidates Structural 2 b)) - (keySet (saturateCandidates Structural 2 (saturateCandidates Structural 2 b))) - , TestLabel "law: combiner key is order-independent (congruence basis)" . TestCase $ - -- combining respects 'normalize', so deduping before combining is sound; also exercises - -- consolidation in both operand orders. - do - assertEqual - "AND consolidation commutes at the key" - (keyOf (combineAndVec (xGt 2) (xGt 4))) - (keyOf (combineAndVec (xGt 4) (xGt 2))) - assertEqual - "OR consolidation commutes at the key" - (keyOf (combineOrVec (xGt 2) (xGt 4))) - (keyOf (combineOrVec (xGt 4) (xGt 2))) - assertEqual - "cross-column AND commutes at the key" - (keyOf (combineAndVec (xGt 2) (yGt 2))) - (keyOf (combineAndVec (yGt 2) (xGt 2))) - , TestLabel - "truth-vector: section is the (eSize, compareExpr)-minimum of the fiber" - . TestCase - $ - -- not merely order-independent: the survivor is the deterministic min, never the max. - let fiber = [xGt 2, yLt 3] - cmp a b = - compare (eSize (cvExpr a)) (eSize (cvExpr b)) - <> compareExpr (cvExpr a) (cvExpr b) - want = keyOf (minimumBy cmp fiber) - in assertEqual - "min-section survivor" - [want] - (map keyOf (saturateCandidates TruthVector 1 fiber)) - ] - ------------------------------------------------------------------------- --- QuickCheck properties (over generated base pools and depths) ------------------------------------------------------------------------- - -genAtom :: Gen CondVec -genAtom = - elements - [xGt 1, xGt 2, xGt 3, xLt 2, xLt 4, yGt 1, yGt 3, yLt 3, zGt 1, zGt 3, zLt 4] - -genBase :: Gen [CondVec] -genBase = choose (2, 5) >>= \k -> vectorOf k genAtom - --- Random label vector of the fixture's length (6 rows), for selection-preservation. -genLabels :: Gen [Bool] -genLabels = vectorOf 6 (elements [False, True]) - -prop_structuralSameSet :: Property -prop_structuralSameSet = - forAllBlind genBase $ \base -> - forAll (choose (1, 3)) $ \d -> - counterexample (show (map keyOf base, d)) $ - keySet (saturateCandidates Structural d base) === keySet (ref d base) - -prop_truthVectorFloor :: Property -prop_truthVectorFloor = - forAllBlind genBase $ \base -> - forAll (choose (1, 3)) $ \d -> - counterexample (show (map keyOf base, d)) $ - truthSet (saturateCandidates TruthVector d base) === truthSet (ref d base) - --- The candidate *set* depends only on the base as a set, not its input order. (Output - --- * order* tracks input order — that is the byte-identity contract, see the selection tests.) -prop_orderInvariant :: Property -prop_orderInvariant = - forAllBlind genBase $ \base -> - forAllBlind (shuffle base) $ \base' -> - forAll (choose (1, 3)) $ \d -> - counterexample (show (map keyOf base, map keyOf base', d)) $ - keySet (saturateCandidates Structural d base) - === keySet (saturateCandidates Structural d base') - --- The candidate the consumer's 'minimumBy penaltyCV' selects is byte-identical to the oracle's, --- for any label vector (d >= 2 so combinations exist). This is the model-preservation contract. -prop_selectionPreserved :: Property -prop_selectionPreserved = - forAllBlind genBase $ \base -> - forAllBlind genLabels $ \lbls -> - forAll (choose (2, 3)) $ \d -> - counterexample (show (map keyOf base, lbls, d)) $ - argminKey lbls (saturateCandidates Structural d base) - === argminKey lbls (ref d base) - --- The full output (order included) is byte-identical to the deduped oracle, at every depth. --- Subsumes selection-preservation for ANY (cvVec,eSize)-penalty, and stresses the --- frontier:=admitted optimisation past the depth where it could first diverge. -prop_orderMatchesOracle :: Property -prop_orderMatchesOracle = - forAllBlind genBase $ \base -> - forAll (choose (2, 3)) $ \d -> - counterexample (show (map keyOf base, d)) $ - map keyOf (saturateCandidates Structural d base) - === map keyOf (nubBy ((==) `on` keyOf) (ref d base)) - --- The structural key faithfully represents the 'eqExpr' quotient on the candidate domain --- (atoms and their AND/OR products): show.normalize merges exactly what eqExpr merges. -genCand :: Gen CondVec -genCand = - oneof - [ genAtom - , combineAndVec <$> genAtom <*> genAtom - , combineOrVec <$> genAtom <*> genAtom - ] - -prop_keyFaithful :: Property -prop_keyFaithful = - forAllBlind genCand $ \a -> - forAllBlind genCand $ \b -> - counterexample (keyOf a ++ " vs " ++ keyOf b) $ - (keyOf a == keyOf b) === eqExpr (cvExpr a) (cvExpr b) - -props :: [Property] -props = - [ prop_structuralSameSet - , prop_truthVectorFloor - , prop_orderInvariant - , prop_selectionPreserved - , prop_orderMatchesOracle - , prop_keyFaithful - ] diff --git a/tests/data/timestamp_nanos.parquet b/tests/data/timestamp_nanos.parquet new file mode 100644 Binary files /dev/null and b/tests/data/timestamp_nanos.parquet differ