diff --git a/README.ja.md b/README.ja.md new file mode 100644 --- /dev/null +++ b/README.ja.md @@ -0,0 +1,98 @@ +# hanalyze-plot + +[`hanalyze`](../README.ja.md) と姉妹プロジェクト **hgg** を +繋ぐ**統合層**。 fit 済みの解析モデルを hgg の `VisualSpec` へ +変換する `toPlot` / `Plottable` を提供する 8 module。 + +依存が他の層と違う点に注意: + +- **umbrella package `hanalyze` の上**に乗る (`Fit` / `Wrappers` を + import するため)。 umbrella → plot 方向にすると package 循環になるので、 + この向きは cabal file にも明記されている。 +- sibling repo の `hgg-{core,svg,3d,custom}` に依存する。 このため + **既定の `cabal.project` には含まれない**。 build には専用の build root + `cabal.project.plot` を使う。 + +```bash +cabal build --project-file=cabal.project.plot hanalyze-plot +cabal test --project-file=cabal.project.plot hanalyze-plot-test +``` + +> **Vega-Lite で HTML の図・レポートを出したい場合**は +> [`hanalyze-viz`](../hanalyze-viz/README.ja.md) を使う。 +> こちらは SVG / PDF / PNG の静的描画が対象。 + +## 主要 module (全 8 module) + +| Module | 役割 | +|---|---| +| `Hanalyze.Plot` | 統合層の入口。 下記 instance 群と `Fit` 系 API (`\|->` / `lm` / `glm` …) をまとめて再輸出する | +| `Plot.Core` | モデル族に依存しない骨格 — `Plottable` / `SingleVarModel` / `MultiVarModel` と grid 評価核 | +| `Plot.Linear` | 線形モデル族の instance (`LMModel` / `GLMModel` / `WeightedLMModel` …) | +| `Plot.Bayes` | ベイズ / HBM 族の instance (`ChainModel` / `ForestSpec` / `PPCSpec` / `DagSpec` / `GLMMResultRE`) + 抽出子 | +| `Plot.ML` | ML / 統計モデル族の instance + 抽出子 | +| `Plot.Robust` | ロバスト回帰・分位点回帰族の instance | +| `Plot.Smooth` | 平滑化・カーネル法族の instance | +| `Plot.Wrappers` | 汎用ラッパ型 (`MultiFit` / `RegModel`) の instance | + +中核の型クラスは `Plot.Core` の 1 本だけ: + +```haskell +class Plottable m where + -- | 代表 1 枚の図 (= layer 重畳の主役、 <> で他 layer と合成可)。 + toPlot :: m -> VisualSpec + + -- | 診断図の束 (= レポート用)。 既定は代表 1 枚のみ。 + diagnosticPlots :: m -> [VisualSpec] + diagnosticPlots m = [toPlot m] +``` + +モデル型ごとに `Plottable` の instance を足していく設計なので、 新しいモデルを +描けるようにするのは「instance を 1 本書く」 だけで済む。 + +## 使い方 + +```cabal +build-depends: hanalyze-plot +``` + +```haskell +{-# LANGUAGE OverloadedStrings #-} +import Graphics.Hgg.Frame ((|>>)) +import Graphics.Hgg.Spec (layer, scatter) +import Graphics.Hgg.Backend.SVG (saveSVGBound) +import Hanalyze.Plot (toPlot, statModel, grid, (|->), lm) + +main :: IO () +main = do + let m = df |-> lm "x" "y" + lmPlot = df |>> (layer (scatter "x" "y") <> toPlot m) + saveSVGBound "lm-scatter-ci.svg" lmPlot +``` + +`df |-> lm "x" "y"` (fit) → `toPlot` (図化) → `|>>` で他の layer と重ねる、 +という 1 本の流れになる。 `toPlot` に渡す前に `statModel m <> grid 200` の +ように**描画オプションを合成**できる (grid 分割数・信頼帯の種類 `bandMode` / +`piMethod`・色 `statColor` 等)。 + +上の形は demo `plot-integration-demo` +(`hanalyze-demos/demo-plot/PlotIntegrationDemo.hs`) がそのまま使って +いる経路で、 LM / GLM / spline / GP / 分位点回帰などの実例が並んでいる: + +```bash +cabal run --project-file=cabal.project.demos plot-integration-demo +``` + +## テスト + +test-suite `hanalyze-plot-test` (`test-plot/Spec.hs`) が、 モデル種別ごとの +`toPlot` 結果の構造・数値を検証する。 元は umbrella 側にあったが、 umbrella の +component がこの package に依存すると循環するため Phase 106.4 で移設した。 + +## 関連 docs + +- 静的描画との統合: [docs/visualization/03-plot-integration.ja.md](../docs/visualization/03-plot-integration.ja.md) +- 可視化の入口: [01-visualization.ja.md](../docs/visualization/01-visualization.ja.md) +- API 一覧 (en): [api-guide/12-plot.md](../docs/api-guide/12-plot.md) + +← [repository README](../README.ja.md) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,100 @@ +# hanalyze-plot + +The **integration layer** between [`hanalyze`](../README.md) and the +sibling project **hgg**. Its 8 modules provide `toPlot` / +`Plottable`, which turn a fitted analysis model into an hgg +`VisualSpec`. + +Its dependencies differ from the other layers in two ways: + +- It sits **above the umbrella package `hanalyze`** (it imports `Fit` + and `Wrappers`). Pointing the dependency the other way — umbrella → plot — + would create a package cycle, and the cabal file says so explicitly. +- It depends on `hgg-{core,svg,3d,custom}` from a sibling repo, so + it is **not part of the default `cabal.project`**. Build it through the + dedicated build root `cabal.project.plot`: + +```bash +cabal build --project-file=cabal.project.plot hanalyze-plot +cabal test --project-file=cabal.project.plot hanalyze-plot-test +``` + +> **If you want Vega-Lite figures and HTML reports**, use +> [`hanalyze-viz`](../hanalyze-viz/README.md) instead. This +> package targets static SVG / PDF / PNG rendering. + +## Main modules (all 8) + +| Module | Role | +|---|---| +| `Hanalyze.Plot` | Entry point of the integration layer; re-exports the instances below together with the `Fit` API (`\|->`, `lm`, `glm`, …) | +| `Plot.Core` | Model-family-agnostic skeleton — `Plottable` / `SingleVarModel` / `MultiVarModel` and the grid evaluation core | +| `Plot.Linear` | Instances for the linear family (`LMModel`, `GLMModel`, `WeightedLMModel`, …) | +| `Plot.Bayes` | Instances for the Bayesian / HBM family (`ChainModel`, `ForestSpec`, `PPCSpec`, `DagSpec`, `GLMMResultRE`) plus extractors | +| `Plot.ML` | Instances and extractors for the ML / statistical model family | +| `Plot.Robust` | Instances for robust and quantile regression | +| `Plot.Smooth` | Instances for smoothing and kernel methods | +| `Plot.Wrappers` | Instances for the generic wrapper types (`MultiFit`, `RegModel`) | + +There is exactly one core type class, in `Plot.Core`: + +```haskell +class Plottable m where + -- | The one representative figure (composable with other layers via <>). + toPlot :: m -> VisualSpec + + -- | A bundle of diagnostic figures (for reports); defaults to just toPlot. + diagnosticPlots :: m -> [VisualSpec] + diagnosticPlots m = [toPlot m] +``` + +Support for a new model type is therefore a single instance away. + +## Usage + +```cabal +build-depends: hanalyze-plot +``` + +```haskell +{-# LANGUAGE OverloadedStrings #-} +import Graphics.Hgg.Frame ((|>>)) +import Graphics.Hgg.Spec (layer, scatter) +import Graphics.Hgg.Backend.SVG (saveSVGBound) +import Hanalyze.Plot (toPlot, statModel, grid, (|->), lm) + +main :: IO () +main = do + let m = df |-> lm "x" "y" + lmPlot = df |>> (layer (scatter "x" "y") <> toPlot m) + saveSVGBound "lm-scatter-ci.svg" lmPlot +``` + +The flow is a single line: `df |-> lm "x" "y"` (fit) → `toPlot` (figure) → +`|>>` to overlay it on other layers. Before handing a model to `toPlot` you +can **compose rendering options** onto it, e.g. `statModel m <> grid 200` +(grid resolution, band type via `bandMode` / `piMethod`, colour via +`statColor`, …). + +This is the exact path used by the `plot-integration-demo` executable +(`hanalyze-demos/demo-plot/PlotIntegrationDemo.hs`), which walks +through LM, GLM, spline, GP and quantile regression examples: + +```bash +cabal run --project-file=cabal.project.demos plot-integration-demo +``` + +## Tests + +The `hanalyze-plot-test` suite (`test-plot/Spec.hs`) checks the structure and +numerics of `toPlot` output per model type. It used to live in the umbrella +package and was moved here in Phase 106.4, because an umbrella component +depending on this package would close a cycle. + +## Related docs + +- Static-rendering integration: [docs/visualization/03-plot-integration.md](../docs/visualization/03-plot-integration.md) +- Visualization overview: [01-visualization.md](../docs/visualization/01-visualization.md) +- API reference: [api-guide/12-plot.md](../docs/api-guide/12-plot.md) + +← [repository README](../README.md) diff --git a/hanalyze-plot.cabal b/hanalyze-plot.cabal new file mode 100644 --- /dev/null +++ b/hanalyze-plot.cabal @@ -0,0 +1,117 @@ +cabal-version: 3.0 +name: hanalyze-plot +version: 0.2.0.1 +synopsis: Static-plot integration for hanalyze (toPlot / Plottable) +description: + The integration layer between hanalyze and the sibling + hgg project. It provides the Plottable class, whose toPlot turns + a fitted analysis model into an hgg VisualSpec that can be + layered with other marks and rendered to static SVG / PDF / PNG. Instances + cover the linear family (LM / GLM / weighted LM), Bayesian and HBM results + (chains, forest plots, posterior predictive checks, model DAGs), robust + and quantile regression, smoothing and kernel methods, and the generic fit + wrappers. + . + Unlike the other layers this package sits above the umbrella package + hanalyze (the reverse direction would close a package cycle) and + depends on the sibling hgg packages, so it is built through the + dedicated build root cabal.project.plot rather than the default + cabal.project. For Vega-Lite figures and HTML reports see + hanalyze-viz instead. See README.md for the module map and a + usage example. +license: BSD-3-Clause +author: Toshiaki Honda +maintainer: frenzieddoll@gmail.com +copyright: 2026 Aelysce Project (Toshiaki Honda) +category: Math, Statistics, Numeric, Machine Learning +build-type: Simple +tested-with: GHC == 9.6.7 +extra-source-files: + README.md + README.ja.md + +common warnings + ghc-options: -Wall -Wcompat -Widentities -Wredundant-constraints + +-- -O2 は分割前と同一 (性能変更と構造変更を混ぜない、 層別 -O 調整は 106.5 後の別 Phase) +common opt + ghc-options: -O2 -funbox-strict-fields + +library + import: warnings, opt + hs-source-dirs: src + default-language: GHC2021 + exposed-modules: + Hanalyze.Plot + Hanalyze.Plot.Bayes + Hanalyze.Plot.Core + Hanalyze.Plot.Linear + Hanalyze.Plot.ML + Hanalyze.Plot.Robust + Hanalyze.Plot.Smooth + Hanalyze.Plot.Wrappers + build-depends: + base >= 4.14 && < 5 + , array >= 0.5 && < 0.6 + , async >= 2.2 && < 2.3 + , bytestring >= 0.11 && < 0.13 + , cassava >= 0.5 && < 0.6 + , containers >= 0.6 && < 0.8 + , filepath >= 1.4 && < 1.6 + , hmatrix >= 0.20 && < 0.22 + , hvega >= 0.12 && < 0.13 + , mwc-random >= 0.15 && < 0.16 + , primitive >= 0.7 && < 0.10 + , deepseq >= 1.4 && < 1.6 + , parallel >= 3.2 && < 3.3 + , process >= 1.6 && < 1.8 + , statistics >= 0.16 && < 0.17 + , text >= 1.2 && < 2.2 + , aeson >= 2.0 && < 2.3 + , directory >= 1.3 && < 1.4 + , temporary >= 1.3 && < 1.4 + , unordered-containers >= 0.2 && < 0.3 + , ad >= 4.4 && < 4.6 + , reflection >= 2.1 && < 2.2 + , vector >= 0.12 && < 0.14 + , dataframe-core ^>= 1.1 + , dataframe-operations >= 1.1.1 && < 1.2 + , dataframe-csv ^>= 1.0.2 + , dataframe-json ^>= 1.0 + , dataframe-parquet ^>= 1.1 + , massiv >= 1.0 && < 1.1 + , vector-algorithms >= 0.9 && < 0.10 + , megaparsec >= 9.0 && < 9.7 + , parser-combinators >= 1.3 && < 1.4 + , unicode-transforms >= 0.4 && < 0.5 + , regex-tdfa >= 1.3 && < 1.4 + , regex-base >= 0.94 && < 0.95 + , hanalyze == 0.2.0.1 + , hgg-core >= 0.2 && < 0.3 + , hgg-svg >= 0.2 && < 0.3 + , hgg-3d >= 0.2 && < 0.3 + , hgg-custom >= 0.2 && < 0.3 + +-- Phase 46 (hgg 統合) のテスト。 Phase 106 で umbrella から移設 +-- (umbrella component が本 package に依存すると package 循環になるため)。 +test-suite hanalyze-plot-test + import: warnings + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test-plot + default-language: GHC2021 + build-depends: + base + , hspec >= 2.10 && < 2.12 + , hmatrix + , vector + , containers + , text + , mwc-random + , dataframe-core ^>= 1.1 + , hanalyze + , hanalyze-plot + , hgg-core + , hgg-3d + , hgg-custom + , aeson diff --git a/src/Hanalyze/Plot.hs b/src/Hanalyze/Plot.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Plot.hs @@ -0,0 +1,1069 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Hanalyze.Plot +-- Description : 解析モデルを hgg の VisualSpec へ変換する連携層 (別パッケージ hanalyze-plot) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: hgg 連携層 (= 解析モデル → 図 @VisualSpec@)。 +-- +-- ⚠ 本モジュールは別パッケージ @hanalyze-plot@ に属し、 +-- @cabal build --project-file=cabal.project.plot@ で build される。 +-- @hgg-core@ に依存するため +-- __upstream hanalyze には cherry-pick しない__ +-- (= 依存方向 analyze→plot-core を別パッケージへ切り出すことで隔離した設計)。 +-- 中立 protocol ('Hanalyze.Model.Core' の +-- @ResidualModel@ / @PredictiveModel@) は portable、 こちらは非 portable。 +-- +-- 系統 A (モデル・アウト型): フィット済みモデルを @toPlot@ で @VisualSpec@ 化し、 +-- hgg の layer 文法に @df |>> (layer scatter <> toPlot fit)@ で重畳する +-- (@VisualSpec@ は Monoid なので新コンビネータ不要)。 +-- +-- [English]: The hgg integration layer (= analysis models -> +-- figures via @VisualSpec@). +-- +-- ⚠ This module lives in the separate package @hanalyze-plot@, +-- built via @cabal build --project-file=cabal.project.plot@. Because it +-- depends on @hgg-core@, +-- it is __not cherry-picked into the upstream hanalyze__ (= the +-- analyze->plot-core dependency direction is isolated by splitting it +-- into a separate package, by design). The neutral protocol +-- ('Hanalyze.Model.Core''s +-- @ResidualModel@ \/ @PredictiveModel@) is portable; this module is not. +-- +-- Lineage A (model-out type): a fitted model is turned into a +-- @VisualSpec@ via @toPlot@, then layered onto hgg's layer +-- grammar with @df |>> (layer scatter <> toPlot fit)@ (no new combinator +-- is needed since @VisualSpec@ is a Monoid). +module Hanalyze.Plot + ( Plottable (..) + -- * ルート1 grid 評価 (滑らかな回帰曲線・CI 帯) + , ModelSpec + , SingleVarModel (..) + , GridOpts (..) + , statModel + , grid + , gridRange + , BandMode (..) + , bandMode + -- 予測区間の算出法セレクタ (closed-form / bootstrap — Phase 70.H) + , PIMethod (..) + , piMethod + , statColor + , statFill + , statLinetype + , LineType (..) + , statLinewidth + , statAlpha + , statLabel + , statEquation + , statR2 + , statLevel + , predAt + -- * 多変量 effect plot + , MultiVarModel (..) + , AlongSpec + , along + , statModelMulti + , HoldAgg (..) + , holdAt + , byVar + , MultiLMModel (..) + , multiLMModel + , multiLMModelF + , MultiGLMModel (..) + , multiGLMModel + , multiGLMModelF + -- 多変量ロバスト回帰 (formula 不要・列名リスト — Phase 70.D) + , MultiRobustModel (..) + , multiRobustModelF + , additiveFormula + -- PLS effect plot (frame 保持ラッパ + 出力セレクタ — Phase 70.B2/B3) + , PLSModel (..) + , plsModel + , selectOutput + -- * 応答曲面 3D 直結 + , SurfaceOpts (..) + , defaultSurfaceOpts + , surfaceGrid + , surfaceOf + , surfaceOfWith + , dataScatter3DOf + , epredSurfaceOf + , epredSurfaceOfWith + -- * モデル API 層 (描画と独立: predict / describe / coefficients) + , ModelAPI (..) + , Coef (..) + -- * 統一係数サマリ (t/z・p 値・95% CI) + , CoefRow (..) + , HasCoefSummary (..) + , HasCoefBoot (..) + , coefSummaryBoot + -- * 平滑項単位の近似有意性 (mgcv 流 edf + 近似 F) + , TermRow (..) + , HasTermSummary (..) + , termSummary + -- * 統一玄関 (.summary() 風) + , ModelReport (..) + , HasReport (..) + , modelReport + , showReport + -- * 回帰診断の可視化 (係数 forest / 実測vs予測) + , HasObsPred (..) + , obsVsPred + , obsPredSpec + , coefForest + -- * 線形モデル (描画可能 = X 同梱) + , LMModel (..) + , lmModel + -- * 一般化線形モデル (描画可能 = X + family/link 同梱) + , GLMModel (..) + , glmModel + -- * ガウス過程 (描画可能 = 予測 grid 同梱の 'GPResult' をそのまま) + , GPResult (..) + -- * カーネル法ファミリ統合 (GP / KRR / RFF・df |-> gp) + , Kernel (..) + , GPParams (..) + , defaultGPParams + , GPMethod (..) + , HyperStrategy (..) + , GPConfig (..) + , defaultGP + , GPSpec + , gp + , GPRegModel (..) + , GPMultiSpec + , gpMulti + , GPRegModelN (..) + -- * 罰則付き回帰 統合 (Ridge/Lasso/EN/MCP/SCAD/Adaptive/Group・df |-> regularized) + , RegMethod (..) + , LambdaStrat (..) + , RegConfig (..) + , defaultRidge + , defaultLasso + , RegSpec + , regularized + , regularizedMulti + , ridge + , ridgeMulti + , lasso + , lassoMulti + , elasticNet + , elasticNetMulti + , RegModel (..) + , regPredict + -- * スプライン回帰 (描画可能 = X 同梱、 平滑曲線 + CI band) + , SplineModel (..) + , splineModel + -- * 一般化加法モデル (描画可能 = X 同梱、 平滑曲線のみ・band 非提供) + , GAMModel (..) + , gamModel + -- ** GAM 基底一般化 + GCV (df|-> 高レベル) + , GAMBasis (..) + , GAMLambda (..) + , GAMConfig (..) + , defaultGAMConfig + , GAMSpec (..) + , gam + , gamMulti + , GAMModelN (..) + , fitGAMWith + -- * ロバスト回帰 (描画可能 = X 同梱、 ロバスト直線・重み diagnostic) + , RobustModel (..) + , robustModel + -- * 多出力線形回帰 (描画可能 = 自己完結の 'MultiFit'、 残差相関 heatmap) + , MultiFit (..) + -- * 分位点回帰 (描画可能 = X 同梱、 複数分位線を色分け重畳) + , QuantileModel (..) + , quantileModel + -- * MCMC チェーン (描画可能 = trace + 周辺事後密度、 ベイズ出入口) + , ChainModel (..) + , chainModel + -- * 生存解析 (描画可能 = 自己完結、 KM 生存曲線 / 競合リスク CIF) + , KMResult (..) + , CRFit (..) + -- * 時系列予測 (描画可能 = 履歴 + AR 予測 + 予測区間 band) + , ForecastModel (..) + , forecastModel + -- * 多変量・木 (描画可能 = 自己完結、 PCA scree / RF 重要度) + , PCAResult (..) + , RandomForest (..) + -- * 木/アンサンブル (重要度 bar / 決定木 樹形図) + -- GradientBoosting / RandomForestClassifier = 特徴重要度 bar、 + -- DecisionTree = MDAG 再利用の樹形図 (新規 mark 不要) + , GBRegressor (..) + , GBClassifier (..) + , RFClassifierFit (..) + , DTree (..) + , DTFit (..) + , treeImportances + , treePlot + , treePlotRaw + -- * 分類 (決定境界 + confusion + 代表散布) + -- Discriminant / NaiveBayes / KNN。 決定境界・confusion はヘルパ (要範囲/データ)、 + -- toPlot は KNN=訓練点散布 / Discriminant・NB=クラス平均散布 + , ClassPredict (..) + , decisionBoundaryOf + , confusionOf + , MDSView + , mdsView + , mdsGroupBy + , nnLossOf + , ResidualMode (..) + , ProfilerSpec (..) + , profiler + , profilerResidual + , contourOf + -- DOE ワークフロー (Phase 78・Hanalyze.Fit 由来) + , Design (..) + , DesignFactor (..) + , FactorKind (..) + , FactorScale (..) + , DesignKind (..) + , contFactor + , contFactorLog + , numFactor + , catFactor + , CustomSpec (..) + , customSpec + , customDesign + , Structure (..) + , splitPlot + , stripPlot + , blocked + , Constraint (..) + , ConstraintRel (..) + , ConstraintGuard (..) + , FactorValue (..) + , NatConstraint (..) + , natLeq + , natGeq + , natEq + , natForbid + , formulaToCustomModel + , factorialDesign + , centralCompositeDesign + , boxBehnkenDesign + , Resolution (..) + , resNum + , fractionalDesign + , fractionalDesignGen + , fractionalDesignInter + , fractionalDesignGenInter + , fractionalCatalog + , fracResolution + , aliasStructure + , OATable (..) + , taguchiDesign + , taguchiDesignOA + , OptCriterion (..) + , optimalDesign + , optimalDesignWith + , optimalDesignLevels + , mainEffects + , twoWay + , quadratic + , designTable + , designFrame + , designFrameRound + , designFactorNames + , designFormula + , RSMNature (..) + , RSMReport (..) + , rsmAnalysis + , steepestAscentNatural + , saveDesign + , planFromFrame + , DesignModelSpec (..) + , designModel + , DesignModelGPSpec (..) + , designModelGP + , ranIntercept + , ranSlope + , DesignHBMFit (..) + , designModelHBM + , MultiOutputSpec (..) + , multiOutput + , modelFor + , svmSupportVectorsOf + , ScorePredict (..) + , decisionLineOf + -- 部分従属図 (PDP / ICE) — Phase 75.27 + , RegPredict (..) + , PDPView + , pdp + , pdpIce + , pdpOf + , pdpIceOf + , pdpPlot + , pdpIcePlot + , partialDependencePlot + , partialDependenceIcePlot + , DiscriminantFit (..) + , NBModel (..) + , GaussianNB (..) + , KNNClassifier (..) + -- * 次元圧縮 (PLS score/loading/VIP, MultiGP 多出力 curve) + , PLSFit (..) + -- ** PLS 診断ビュー (中間 Plottable Spec・HBM 式統一) + , PLSView (..) + , PLSViewKind (..) + , scoreView + , loadingView + , vipView + , MultiGPResult (..) + , multiGpCurves + -- * 時系列・生存・FDA + -- GARCH=volatility 帯付き線 / AFT=生存曲線 / FDA=平均+固有関数 / β(t) + , GARCHFit (..) + , garchVolatility + , AFTFit (..) + , aftSurvivalAt + , FunctionalPCA (..) + , FLMResult (..) + -- * 罰則回帰・因果探索 + -- Regularized=係数 bar/係数パス / LiNGAM=因果 DAG (MDAG 再利用) + , RegFit (..) + , regPathPlot + , DirectLiNGAMFit (..) + , lingamDag + -- * 記述統計・検定 (describe 分布図 / 検定 effect-CI forest) + , TestResult (..) + , testForest + , testForestLabeled + , describeBox + -- * クラスタリング — KMeans の図 + -- 'Plottable' 'KMeansResult' (toPlot = centroid 散布) + データ点ヘルパ + , clusterScatterOf + , centroidsOf + , clusterHullOf + , clusterEllipseOf + , DendroOpts (..) + , defaultDendroOpts + , dendrogramOf + , dendrogramOf' + -- * HBM (ベイズ確率プログラム) の学習 + , HBMConfig (..) + , defaultHBM + , HBMModel (..) + , hbmModel + , hbmModelPure + , hbmModelIO + -- * HBM の出力抽出子 (trace / forest) + , hbmParamNames + , TraceOpts (..) + , defaultTraceOpts + , tracesOf + , tracesOfWith + , marginalsOf + , marginalsByChainOf + -- * HBM のサンプリング診断 (divergence 可視化) + , divergencesOf + , pairOf + , energyOf + , autocorrOf + , autocorrOfLag + , defaultAutocorrMaxLag + , rankOf + , rankOfBins + , defaultRankBins + , ForestSpec (..) + , forestOf + , forestOfLevel + -- * HBM の出力抽出子 (epred = 事後予測平均 + HDI band) + , epred + , epredAt + -- * HBM の出力抽出子 (ppc = 事後予測チェック) + , PPCConfig (..) + , defaultPPC + , PPCSpec (..) + , ppcOf + , ppcOfWith + , ppcOfIO + , ppcOfWithIO + -- * HBM の出力抽出子 (dag = モデル構造の DAG) + , DagSpec (..) + , dagOf + , dagOfRaw + , dagOfModel + , dagOfModelWith + -- * HBM 診断ダッシュボード (抽出子束ね) + , dashboardOf + , dashboardFullOf + , traceDensityOf + -- * df |-> spec 統一 fit API (ColumnSource から学習) + , Fit (..) + , (|->) + , (|->!) + -- ** 二変量近道 spec (列名2つ) + , LMSpec (..) + , lm + , GLMSpec (..) + , glm + , SplineSpec (..) + , spline + , RobustSpec (..) + , rlm + , QuantileSpec (..) + , rq + -- ** 行列入力モデルの高レベル spec (列名リスト) + , PCASpec (..) + , pca + -- MDS (Phase 75.21) + , MDSSpec (..) + , mds + , MDSConfig (..) + , MDSMethod (..) + , defaultMDS + , MDSResult (..) + , PCAStandardize (..) + , PLSSpec (..) + , pls + , PLSConfig (..) + , defaultPLS + , LDASpec (..) + , lda + , CCASpec (..) + , ccaOf + , CCAFit (..) + -- ** 教師あり ML 分類器/回帰器 spec (特徴列 + ラベル列) + , GBRSpec (..) + , gbmReg + , GBCSpec (..) + , gbmCls + , GBConfig (..) + , defaultGBM + , DTSpec (..) + , decisionTree + , DTConfig (..) + , defaultDecisionTree + , KNNCSpec (..) + , knnCls + , KNNRSpec (..) + , knnReg + , NBSpec (..) + , naiveBayes + -- ** seed 純粋化した RNG モデル spec (KMeans / RandomForest) + , KMeansSpec (..) + , kmeans + , KMeansConfig (..) + , defaultKMeans + , RFSpec (..) + , randomForestReg + -- 因果探索 LiNGAM (高レベル df|-> ・Phase 77) + , DirectLiNGAMSpec (..) + , directLingam + , ParceLiNGAMSpec (..) + , parceLingam + , MultiGroupLiNGAMSpec (..) + , multiGroupLingam + , VARLiNGAMSpec (..) + , varLingam + , PairwiseLiNGAMSpec (..) + , pairwiseLingam + , BootstrapLiNGAMSpec (..) + , bootstrapLingam + , ICALiNGAMSpec (..) + , icaLingam + , CorrelationSpec (..) + , correlationOf + , CorrelationGraph (..) + , LiNGAMFitted (..) + , lingamDagNamed + , varLagDagNamed + , bootstrapEdgeProbOf + , RFCSpec (..) + , randomForestCls + , RFCConfig (..) + , defaultRFCConfig + , RFConfig (..) + , defaultRandomForest + -- ** SVM / 古典 MLP 高レベル spec (純粋・df |->) + , MLPClsSpec (..) + , mlpCls + , MLPRegSpec (..) + , mlpReg + , SVMSpec (..) + , svmCls + , SVMHyper (..) + , SVMTuneGrid (..) + , defaultSVMTuneGrid + , SVMConfig (..) + , defaultSVM + , SVM (..) + , SVMMulti (..) + , numSupportVectors + -- ** 重み付き最小二乗 (WLS) spec + , WeightedLMSpec (..) + , weighted + , WeightedLMModel (..) + -- ** 透過標準化ラッパ (自動逆変換) + , StandardizedSpec (..) + , standardized + , standardizedY + , StandardizedModel (..) + -- ** 群別フィット spec + , GroupedSpec (..) + , grouped + , GroupedFit (..) + , groupModels + , groupLabels + , groupedFullrange + -- ** 係数診断の薄アクセサ + , CoefStats (..) + , lmDiag + , groupedLmDiag + -- ** formula 多変量 spec (R 流) + , LMFormulaSpec (..) + , lmF + , GLMFormulaSpec (..) + , glmF + , GLMMFormulaSpec (..) + , glmmF + -- ** 重回帰 spec (列名リスト・formula 不要) + , LMMultiSpec (..) + , lmMulti + , GLMMultiSpec (..) + , glmMulti + , RobustMultiSpec (..) + , rlmMulti + , QuantileMultiSpec (..) + , rqMulti + , MultiQuantileModel (..) + -- ** HBM spec + データ散布図 + , HBMSpec + , hbm + , dataScatterOf + ) where + +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Numeric.LinearAlgebra as LA + +import Data.Text (Text) +import qualified Data.Text as T +-- (DataFrame の直接 import は未使用のため削除 = upstream decomp PR#2 移植の副産物調査で判明) + +import Hanalyze.Data.ColumnSource (ColumnSource (..)) + +import Graphics.Hgg.Spec ( VisualSpec, layer, inline, inlineCat + , ColData (..) + , scatter, line + , heatmap, colorBy + , scaleColorManual, legend + , bar, title + , LineType (..) ) +import qualified Graphics.Hgg.ThreeD.Spec as P3 + +import Hanalyze.Model.Wrappers +import Hanalyze.Plot.Core +-- 族別 instance module (Phase 71.5)。 orphan instance を scope に取り込み、 +-- 移した族固有 helper (multiGpCurves) を re-export する。 +import Hanalyze.Plot.Linear () +import Hanalyze.Plot.Smooth (multiGpCurves) +import Hanalyze.Plot.Robust () +-- ベイズ / HBM 連携族 (Phase 71.6)。 orphan instance を scope に取り込み (())、 +-- 移した抽出子・型を re-export する。 epredPredRange は本 module の +-- epredSurfaceOfWith でも使うため明示 import する。 +import Hanalyze.Plot.Bayes () +import Hanalyze.Plot.Bayes + ( hbmParamNames, TraceOpts (..), defaultTraceOpts + , tracesOf, tracesOfWith, marginalsOf + , marginalsByChainOf, divergencesOf + , pairOf, energyOf, autocorrOf, autocorrOfLag, defaultAutocorrMaxLag + , rankOf, rankOfBins, defaultRankBins + , ForestSpec (..), forestOf, forestOfLevel + , epred, epredAt, epredPredRange + , PPCConfig (..), defaultPPC, PPCSpec (..) + , ppcOf, ppcOfWith, ppcOfIO, ppcOfWithIO + , DagSpec (..), dagOf, dagOfRaw, dagOfModel, dagOfModelWith + , dashboardOf, dashboardFullOf, traceDensityOf + , epredSurfaceOf, epredSurfaceOfWith, dataScatterOf ) +-- 汎用ラッパ族 (Phase 71.7)。 orphan instance を scope に取り込み (())、 +-- 移したヘルパ (lmDiag / groupedLmDiag / groupedFullrange) を re-export する。 +import Hanalyze.Plot.Wrappers () +import Hanalyze.Plot.Wrappers + ( lmDiag, groupedLmDiag, groupedFullrange ) +-- ML / 統計モデル連携族 (Phase 71.6)。 orphan instance を scope に取り込み (())、 +-- 移した抽出子・ヘルパ・型を re-export する。 +import Hanalyze.Plot.ML () +import Hanalyze.Plot.ML + ( clusterScatterOf, centroidsOf, clusterHullOf, clusterEllipseOf + , DendroOpts (..), defaultDendroOpts, dendrogramOf, dendrogramOf' + , treeImportances, treePlot, treePlotRaw + , decisionBoundaryOf, confusionOf, MDSView, mdsView, mdsGroupBy, nnLossOf, svmSupportVectorsOf, ScorePredict (..), decisionLineOf + , RegPredict (..), PDPView, pdp, pdpIce + , pdpOf, pdpIceOf, pdpPlot, pdpIcePlot, partialDependencePlot, partialDependenceIcePlot + , PLSView (..), PLSViewKind (..), scoreView, loadingView, vipView + , garchVolatility, aftSurvivalAt + , regPathPlot, lingamDag, lingamDagNamed, varLagDagNamed, bootstrapEdgeProbOf + , ResidualMode (..), ProfilerSpec (..), profiler, profilerResidual, contourOf + , testForest, testForestLabeled, describeBox ) +import Hanalyze.Diagnostics +import Hanalyze.Fit +import Hanalyze.Model.SVM (SVMConfig (..) + , defaultSVM, SVM (..) + , SVMMulti (..), numSupportVectors + , SVMHyper (..) + , SVMTuneGrid (..), defaultSVMTuneGrid) +import Hanalyze.Model.MDS (MDSResult (..)) +import Hanalyze.Model.LM.Diagnostics (CoefStats (..), lmCoefStats) +import Hanalyze.Model.GP (GPResult (..), Kernel (..), GPParams (..), defaultGPParams) +import Hanalyze.Model.LM (linspace) +import Hanalyze.Model.GAM (GAMBasis (..), GAMLambda (..) + , fitGAMWith) +import Hanalyze.Model.MultiLM (MultiFit (..)) +import Hanalyze.Model.Cluster (KMeansConfig (..), defaultKMeans) +import Hanalyze.MCMC.Core (Chain (..)) +import Hanalyze.Model.HBM (ModelP, withData + , runDeterministics) +import Hanalyze.Model.Survival (KMResult (..)) +import Hanalyze.Model.CompetingRisks (CRFit (..)) +import Hanalyze.Model.PCA (PCAResult (..), PCAStandardize (..)) +import Hanalyze.Stat.Standardize + ( Standardizer (..) + , applyStandardizerCol ) +import Hanalyze.Model.RandomForest (RandomForest (..) + , RFConfig (..), defaultRandomForest) +import Hanalyze.Model.GradientBoosting (GBRegressor (..), GBClassifier (..) + , GBConfig (..), defaultGBM) +import Hanalyze.Model.RandomForestClassifier (RFClassifierFit (..) + , RFCConfig (..), defaultRFCConfig) +import Hanalyze.Model.DecisionTree (DTree (..), DTFit (..), DTConfig (..), defaultDecisionTree) +import Hanalyze.Model.Discriminant (DiscriminantFit (..)) +import Hanalyze.Model.Multivariate (CCAFit (..)) +import Hanalyze.Model.NaiveBayes (NBModel (..), GaussianNB (..)) +import Hanalyze.Model.KNN (KNNClassifier (..) + , KNNRegressor (..), predictKNNR) +import Hanalyze.Model.PLS (PLSFit (..), PLSConfig (..), defaultPLS) +import Hanalyze.Model.MultiGP (MultiGPResult (..)) +import Hanalyze.Model.GARCH (GARCHFit (..)) +import Hanalyze.Model.AFT (AFTFit (..)) +import Hanalyze.Model.FDA (FunctionalPCA (..), FLMResult (..)) +import Hanalyze.Model.Regularized (RegFit (..)) +import Hanalyze.Model.LiNGAM.Direct (DirectLiNGAMFit (..)) +import Hanalyze.Stat.Test (TestResult (..)) + +-- =========================================================================== +-- 共通基盤 (class / ModelSpec / grid 評価核) は 'Hanalyze.Plot.Core' へ +-- 切り出した (Phase 71.4)。 本モジュールは Core を import して従来 export を +-- re-export しつつ、 各モデル族固有の instance を残置する。 +-- =========================================================================== + +-- =========================================================================== +-- ルート1 grid 評価 (ModelSpec) — Phase 16 §3 C1 [→ Plot.Core へ移動] +-- +-- fit 済モデルの回帰曲線・CI 帯を **訓練点ではなく等間隔 grid** で評価して描く。 +-- 疎・不均一データで曲線がガタつくのを解消する (散布図の点は従来通り訓練データ)。 +-- 'statModel' で 'ModelSpec' を作り、 @<>@ でオプションを足す: +-- +-- > df |>> (layer (scatter "x" "y") <> toPlot (statModel m <> grid 200)) +-- +-- 'ModelSpec' は Monoid。 学習済モデル @m@ はクロージャに閉じ込め、 予測は +-- @toPlot@ (描画時) に grid 評価する (ユーザ直感「m は学習・layer で予測」)。 +-- =========================================================================== + + +-- =========================================================================== +-- 多変量 effect plot (Phase 16 §3 C3) +-- +-- 単変数 grid 評価 (C1) を多変量モデルへ一般化する。 along 変数を grid で動かし、 +-- 他の説明変数を 'HoldAgg' で固定した「評価点 ModelFrame」 を合成して、 訓練 formula の +-- @designMatrixF@ で評価点設計行列を組み CI を評価する。 +-- +-- ★評価点 ModelFrame の合成は **DataFrame を経由せず VarRole を直接差し替える** +-- (@designMatrixF@ は 'mfRoles' のみ参照し応答列は使わない = Design.hs:331)。 列構造・ +-- 順序が訓練と完全一致するので @confidenceBandAt@ / 'predictGlmMuWithCI' がそのまま使える。 +-- 型で単/多変量を分離し ('SingleVarModel' / @MultiVarModel@)、 along 忘れをコンパイル時に弾く。 +-- =========================================================================== + + + +-- =========================================================================== +-- 多変量モデル型 (effect plot 用、 新規 fit) +-- +-- 既存の単変数 'LMModel' / 'GLMModel' (設計行列が @[1, x]@ 固定) とは別型。 +-- formula 文字列 + @DataFrame@ で多変量 fit し、 formula を保持して評価点設計行列を +-- 組む (HoldAgg 固定 + along grid)。 ★GLM は formula 経路が未整備なので +-- @designMatrixF@ で設計行列を作り 'fitGLMFull' を直接呼ぶ。 +-- =========================================================================== + +-- (instance MultiVarModel MultiLMModel は Hanalyze.Plot.Linear へ移動 — Phase 71.5) + +-- =========================================================================== +-- 列名リスト → 加法線形 Formula AST (パース無し直接合成) — Phase 70.D +-- +-- 重回帰 (multiple regression) は formula DSL とは別概念: 説明変数の列名リストから +-- 設計行列 @[1, x1, …, xp]@ を作るだけ。 これを文字列を介さず 'Formula' AST に直接 +-- 組み立て、 既存の 'multiLMModelF' / @designMatrixF@ / effect plot 機構をそのまま使う +-- (= @parseModel "y ~ x1 + … + xp"@ と同一 AST。 パラメータ名 @_p0.._pp@ も同じ規約)。 +-- =========================================================================== + +-- =========================================================================== +-- 多変量ロバスト回帰 (effect plot + 係数サマリ) — Phase 70.D +-- +-- ロバスト回帰は formula 経路を持たない (単回帰 'RobustModel' のみだった) ので、 +-- 'MultiLMModel' と同型の frame-carrying ラッパを新設する。 設計行列は +-- 'additiveFormula' 由来 (@designMatrixF@ で @[1, x1,…,xp]@)、 fit は 'fitRobustLM'、 +-- CI 帯は M 推定量サンドイッチ共分散 ('robustCovBeta'・statsmodels RLM 一致)。 +-- =========================================================================== + +-- (instance MultiVarModel MultiRobustModel は Hanalyze.Plot.Robust へ移動 — Phase 71.5) + +-- (instance MultiVarModel MultiGLMModel は Hanalyze.Plot.Linear へ移動 — Phase 71.5) + +-- (instance MultiVarModel PLSModel は Hanalyze.Plot.ML へ移動 — Phase 71.6) + +-- =========================================================================== +-- 線形モデル (描画可能) +-- +-- 'FitResult' (数値核) は設計行列 X を保持しないが、 回帰線・CI band を描くには +-- X が要る (@confidenceBand@ は X 引数)。 そこで X と生 predictor を束ねた +-- 「描画可能なモデル」 を別型にする (= plot Phase 15 §2.1 の開放論点を (i) で確定)。 +-- =========================================================================== + + +-- (instance Plottable LMModel / SingleVarModel LMModel は +-- Hanalyze.Plot.Linear へ移動 — Phase 71.5) + +-- =========================================================================== +-- 一般化線形モデル (描画可能) +-- +-- GLM の不確実性帯は **μ (応答) スケールで非対称** (線形予測子 η の対称 Wald CI を +-- 逆リンク gInv で μ に写すため、 Logit/Log 等では下側・上側の半幅が異なる)。 ゆえに +-- LMModel/GPResult の対称 band (ŷ±se) では忠実に描けない。 そこで +-- 下境界 lo / 上境界 hi を別々に持てる 'band' layer (= MBand area fill) を使い、 μ 曲線は +-- 'line' で重ねる。 帯は **訓練点での Wald CI** を 'predictGlmMuWithCI' で評価する +-- (= grid 補間でなく fit と整合)。 'fitGLMFull' が返す逆 Fisher 情報 Σ=(XᵀWX)⁻¹ が要る。 +-- =========================================================================== + +-- (instance Plottable GLMModel / SingleVarModel GLMModel は +-- Hanalyze.Plot.Linear へ移動 — Phase 71.5) + +-- =========================================================================== +-- ガウス過程 (描画可能) +-- +-- 'GPResult' (Hanalyze.Model.GP) は予測 grid (gpTestX) + 事後平均 (gpMean) + +-- credible band (gpLower/gpUpper) を **自己完結** で保持する。 ゆえに LMModel の +-- ように X を別途束ねる必要がなく、 結果型をそのまま 'Plottable' にできる +-- (= 'FitResult' 系と異なる形でも protocol が成り立つことの実証 = plot Phase 15 +-- / analyze Phase 46 A6)。 +-- =========================================================================== + +-- (instance Plottable GPResult は Hanalyze.Plot.Smooth へ移動 — Phase 71.5) + +-- =========================================================================== +-- スプライン回帰 (描画可能) +-- +-- 'SplineFit' (Hanalyze.Model.Spline) は基底係数 'sfBeta' と、 基底行列で fit した +-- 線形モデル核 'sfResult' (= 'FitResult') を保持する。 ゆえに **基底行列を設計行列と +-- みなせば** LMModel と同じ @confidenceBand@ (= X (XᵀX)⁻¹ Xᵀ の対角) がそのまま使える。 +-- 違いは「曲線」 である点だけ: 単回帰の直線でなく、 訓練点を x 昇順に結ぶと基底展開に +-- よる平滑曲線になる ('renderRegression' は encX/encY を線形再フィットせず折れ線で +-- 結ぶため、 ソート済みの点列を渡せば曲線がそのまま描ける = GP と同じ性質)。 帯は +-- LM と同じ **線形モデルの対称 Wald CI** (基底空間での予測分散) なので意味付けも明快。 +-- =========================================================================== + +-- (splineBasisAt / instance Plottable SplineModel / SingleVarModel SplineModel / +-- Plottable GAMModel / gamGridCI / SingleVarModel GAMModel / SingleVarModel GAMModelN / +-- Plottable GAMModelN は Hanalyze.Plot.Smooth へ移動 — Phase 71.5) + +-- =========================================================================== +-- ロバスト回帰 (描画可能) +-- +-- 'RobustFit' (Hanalyze.Model.Robust) は M-estimator IRLS の係数 'rfCoef' / fitted +-- 'rfFitted' / 最終重み 'rfWeights' (≤ 1、 外れ値ほど小) を持つが、 **CI / 予測帯を +-- 返す helper を持たない** (sandwich 分散等を別途計算すれば帯は出せるが本 Phase 対象外)。 +-- ゆえに代表図 (@toPlot@) は **ロバスト直線のみ** (band 無し)。 ロバスト回帰の価値= +-- 「どの点がダウンウェイトされたか」 は 'diagnosticPlots' 側で **点サイズ = IRLS 重み** +-- の散布図に encode して見せる (主図に点を描くと合成 @df |>> layer scatter <> toPlot@ +-- で点が二重になるため、 主図は直線だけにして重み表示は診断束へ回す = user 決定 2026-06-04)。 +-- =========================================================================== + +-- (instance Plottable RobustModel / robustBand / SingleVarModel RobustModel は +-- Hanalyze.Plot.Robust へ移動 — Phase 71.5) + +-- =========================================================================== +-- 多出力線形回帰 (描画可能) +-- +-- 'MultiFit' (Hanalyze.Model.MultiLM) は q 個の応答を共通の予測子で同時回帰し、 +-- 固有の成果物として **出力間の残差相関 'mfResidCor' (q×q)** を保持する。 q 本の回帰 +-- 関係を単一図に素直に載せる方法は一意でない (出力ごとスケールが異なり得る) ため、 +-- 代表図 (@toPlot@) は **残差相関 heatmap** とする (= 多出力回帰固有の図。 user 決定 +-- 2026-06-04)。 'MultiFit' は heatmap に必要な相関行列を自己完結で持つので、 'GPResult' +-- 同様 X を別途束ねず結果型をそのまま 'Plottable' にできる。 個別の出力 j の回帰線は +-- 'predictMultiLM' で別途描ける (本 instance の対象外)。 +-- +-- ⚠ 'heatmap' (geom_tile) は **categorical 軸専用** (renderHeatmap が x/y をラベルとして +-- カテゴリ軸の index に引く。 実測: Render/Statistical.hs)。 ゆえに格子座標は数値でなく +-- **出力名ラベル** ("y1", "y2", …) を 'inlineCat' で渡す (数値だとカテゴリ軸が立たず +-- 全セルが drop されてタイルが描かれない = 計測で確認)。 +-- =========================================================================== + +-- (instance Plottable MultiFit は Hanalyze.Plot.Wrappers へ移動 — Phase 71.7) + +-- =========================================================================== +-- 分位点回帰 (描画可能) +-- +-- 'QRFit' (Hanalyze.Model.Quantile) は 1 つの分位 τ に対する係数 + fitted 'qfYHat' を +-- 持つ。 OLS が条件付き平均を引くのに対し分位回帰は条件付き τ-分位を引くので、 複数の +-- τ (例 0.1/0.5/0.9) の fit を重ねると **予測区間そのものを線群で** 表現できる +-- (= heteroscedastic データで帯より直接的)。 ゆえに 'QuantileModel' は複数の τ-fit を +-- 束ね、 @toPlot@ で **分位ごとに 1 本の line layer を色分けして重畳** する (band は使わ +-- ない。 分位線自体が区間の縁を成すため)。 各線は 'color' ('fromHex') で固定色を割り当てる。 +-- =========================================================================== + +-- (instance Plottable QuantileModel / Plottable MultiQuantileModel は +-- Hanalyze.Plot.Robust へ移動 — Phase 71.5) + + +-- =========================================================================== +-- クラスタリング (KMeans) の図 — Phase 68 A1 +-- +-- KMeans の分野定番の図は「クラスタ別散布 (色=ラベル)」。 ただし +-- 'KMeansResult' は centroids + labels + inertia のみ保持し **生データ座標を +-- 持たない**。 そこで 'surfaceOf' <> 'dataScatter3DOf' と同じ **model 層 / data +-- 層の二層イディオム**に分ける: +-- +-- * 'Plottable' 'KMeansResult' の @toPlot@ = centroid 散布のみ (データ不要・ +-- クラス契約 @m -> VisualSpec@ を満たす)。 既定は centroid 行列の第 0/1 次元。 +-- * 'clusterScatterOf' = データ点をラベル色で散布 (要データ源・列名指定)。 +-- * 'centroidsOf' = centroid を任意 2 次元で重畳 (✚ マーカー・次元 index 明示)。 +-- +-- 定番図 = @df |>> (clusterScatterOf df res \"x\" \"y\" <> centroidsOf res 0 1)@。 +-- ⚠ centroid 行列は **学習時の特徴量列順**のみで列名を持たない。 重畳時は +-- データ列 (@xn@, @yn@) と centroid 次元 (@i@, @j@) の対応をユーザが揃える。 +-- =========================================================================== + +-- (instance Plottable KMeansResult / clusterScatterOf / centroidsOf は +-- Hanalyze.Plot.ML へ移動 — Phase 71.6) + +-- =========================================================================== +-- HBM (ベイズ確率プログラム) の学習 — Phase 49 A1 +-- +-- 'Hanalyze.Model.HBM' の free-monad DSL で書いた確率プログラム ('ModelP') を +-- NUTS で学習し、 「学習済 HBM モデル」 ('HBMModel') という第一級の値にする。 +-- 命名は頻度論側の @lmModel → LMModel@ / @glmModel → GLMModel@ と対称的 +-- ('hbmModel → HBMModel')。 違いは学習が MCMC ゆえ IO・重い・async 並列 +-- (既存 'nutsChains' が 'mapConcurrently' で multi-chain 並列) という点のみ。 +-- +-- データは df 由来の列 (名前付き) を 'withData' でモデル中の placeholder +-- (@dataNamed@ / observe の参照名) に **自動 bind** する。 これは PyMC の +-- @pm.Data@ + @set_data@ と同型 (= 同じモデルを別データで再評価できる設計)。 +-- +-- ★ 'HBMModel' は **直接 'Plottable' にしない** (確率プログラムは「単一の図」 に +-- 一意に落ちない)。 描画は抽出子 (@epred@ / @tracesOf@ / 'ppcOf' / 'forestOf' / +-- @dagOf@、 後続 sub で追加) を明示する設計 (Phase 49 計画 Q1)。 +-- =========================================================================== + + +-- =========================================================================== +-- 生存解析 (描画可能) +-- +-- 生存関数 Ŝ(t) (Kaplan-Meier) と累積発生関数 CIF (競合リスク) はいずれも **階段関数** +-- (イベント時刻で不連続にジャンプ、 その間は平坦)。 折れ線 ('line') は点間を線形に結ぶので、 +-- そのまま渡すとジャンプが斜めになる。 ゆえに **階段頂点を明示展開** する helper +-- 'stepVerts' で (0, s0) から各イベント時刻の「水平→垂直」 2 頂点を作り、 line で結ぶ +-- (= 正しい階段形)。 KM は s0=1 で下降、 CIF は s0=0 で上昇。 KMResult / CRFit は時刻と +-- 値を自己完結で持つので 'GPResult' 同様そのまま 'Plottable' にできる。 +-- =========================================================================== + + +-- (instance Plottable KMResult / Plottable CRFit は +-- Hanalyze.Plot.ML へ移動 — Phase 71.6) + +-- =========================================================================== +-- 時系列予測 (描画可能) +-- +-- AR(p) の点予測 'forecastAR' は将来値の中心のみを返す。 予測の不確実性帯は **h-step +-- 予測分散** から得る: AR の MA(∞) 表現の ψ-weights (ψ₀=1, ψⱼ=Σφᵢψⱼ₋ᵢ) を用いて +-- @Var(ŷ_{n+k}) = σ² Σ_{j=0}^{k-1} ψⱼ²@ (σ² = 革新分散 'arResidVar')。 これは Gaussian +-- 革新の下での正統な予測区間 (地平 k とともに単調に広がる)。 対称ゆえ band は +-- @中心 ± z·se@。 @toPlot@ は履歴折れ線 + 予測折れ線 + 予測区間 band を 1 枚に重ねる。 +-- =========================================================================== + +-- (arPsiWeights / arForecastSE / instance Plottable ForecastModel は +-- Hanalyze.Plot.ML へ移動 — Phase 71.6) + +-- =========================================================================== +-- 多変量・木 (描画可能) +-- +-- PCA の代表図は **scree plot** (各主成分の寄与率 'pcaExplainedRatio' を棒で)、 木 (RF) の +-- 代表図は **特徴重要度バー** ('featureImportance')。 いずれも自己完結ゆえそのまま +-- 'Plottable'。 棒の x 軸はラベル ("PC1".. / "f1"..) なので 'inlineCat' (categorical) で渡す +-- (heatmap A9 と同じく 'bar' も categorical 軸が必要)。 優先低 (§3.5 A14) ゆえ scree/重要度 +-- の 1 枚ずつに絞る (biplot や木構造図は将来拡張)。 +-- =========================================================================== + +-- (instance Plottable PCAResult / Plottable RandomForest は +-- Hanalyze.Plot.ML へ移動 — Phase 71.6) + +-- =========================================================================== +-- 木/アンサンブル — Phase 68 A2 +-- +-- 各モデルの分野定番図を **既存 mark のみ**で描く (新規 plot mark 不要): +-- +-- * GradientBoosting (回帰/分類)・RandomForestClassifier = **特徴重要度 bar**。 +-- GBM は重要度フィールドを持たないので弱学習器 ('Tree') の split 使用回数から +-- 純粋計算する ('treeImportances'・RF.'featureImportance' と同方式・正規化)。 +-- * DecisionTree = **樹形図**。 決定木は DAG の特殊形 (二分木) ゆえ、 HBM の +-- ModelGraph と同じ MDAG (Sugiyama 階層 layout) を **再利用**して node-link で描く +-- (split ノード = "f{j} ≤ {thr}"、 葉 = "y={class}")。 +-- +-- ⚠ DecisionTree の edge True/False ラベル・gini・サンプル数表示 (sklearn plot_tree +-- 相当) は DAGNode/DAGEdge が持たないため v1 では描かない。 必要なら専用 mark を +-- plot 側 Phase として起こす (= dendrogram Phase 48 と同型の判断)。 +-- =========================================================================== + +-- (treeImportances / instance Plottable GBRegressor / GBClassifier / +-- RFClassifierFit / DTree / dtreeToDag は Hanalyze.Plot.ML へ移動 — Phase 71.6) + +-- =========================================================================== +-- 分類 (Discriminant / NaiveBayes / KNN) — Phase 68 A3 +-- +-- 代表図は **決定境界** と **confusion 行列**。 いずれも「学習済モデルを評価点で +-- 走らせる」 図ゆえ、 KMeans (A1) と同じく **データ/範囲を取るヘルパ**で提供する +-- (新規 plot mark 不要): +-- +-- * @decisionBoundaryOf@ = 2D grid を予測しクラス色で塗る (= 連続軸の散布を +-- 四角マーカー・低 alpha で「領域」表現。 ★renderHeatmap はカテゴリ軸なので +-- 連続 grid には不適 → 'MScatter' + 'colorBy' (離散色) を採用)。 2 特徴前提。 +-- * 'confusionOf' = テストデータの真値×予測の件数を @MHeatmap@ で (カテゴリ軸が適合)。 +-- +-- 'Plottable' の @toPlot@ (データ非保持で描ける代表 1 枚): +-- * KNN は訓練データ ('knnCX'/'knnCY') を保持 → **ラベル色の訓練点散布**。 +-- * Discriminant / NaiveBayes(Gaussian) は **クラス平均散布** (✚)、 +-- NaiveBayes(Multinomial) は **クラス事前確率 bar**。 +-- =========================================================================== + + +-- (instance ClassPredict DiscriminantFit / NBModel / KNNClassifier / +-- decisionBoundaryOf / confusionOf / instance Plottable KNNClassifier / +-- DiscriminantFit / NBModel は Hanalyze.Plot.ML へ移動 — Phase 71.6) + +-- =========================================================================== +-- 次元圧縮 (PLS / MultiGP) — Phase 68 A4 +-- +-- どちらも結果が自己完結 ('PCAResult' 同様) なので外部データ不要で 'Plottable': +-- +-- * 'PLSFit' = 潜在空間の **score plot** (標本 T) を代表図に、 'loading plot' (変数 P) +-- と **VIP bar** を診断図束に。 いずれも既存 'MScatter'/'bar'。 +-- * 'MultiGPResult' = **多出力の予測曲線 + 95% band** (出力ごとに色分け・x=index)。 +-- 'MLine' + 'MBand' を出力数ぶん重畳。 +-- +-- ※ 'Hanalyze.Model.MultiOutput' は変換+メトリクスの **ユーティリティ**で +-- fit 結果型を持たないため 'Plottable' 対象外 (多出力の「相関」図は既存 +-- 'MultiFit' = 残差相関 heatmap が担当)。 新規 plot mark は不要。 +-- =========================================================================== + + +-- (PLSViewKind / PLSView / scoreView / loadingView / vipView / +-- instance Plottable PLSView / PLSFit は Hanalyze.Plot.ML へ移動 — Phase 71.6) + +-- (multiGpCurves / instance Plottable MultiGPResult は +-- Hanalyze.Plot.Smooth へ移動 — Phase 71.5) + +-- =========================================================================== +-- 時系列・生存・FDA (GARCH / AFT / FDA) — Phase 68 A5 +-- +-- 新規 plot mark は不要 (既存 line/band の重畳): +-- +-- * 'GARCHFit' = 系列 (μ + ε_t) + 条件付き volatility 帯 (μ ± 2σ_t) の帯付き線。 +-- * 'AFTFit' = パラメトリック生存曲線 S(t|x)。 fit は観測時刻を持たないので +-- 代表図 (@toPlot@) は **基準共変量** (intercept のみ) の曲線、 +-- 任意共変量は 'aftSurvivalAt' ヘルパ。 t 範囲は予測平均寿命から導出。 +-- * 'FunctionalPCA' = 平均関数 + 上位固有関数を grid 上に重畳 (x = grid index)。 +-- * 'FLMResult' = 関数回帰係数 β(t) の曲線。 +-- =========================================================================== + +-- (garchVolatility / instance Plottable GARCHFit / aftSurvivalAt / +-- instance Plottable AFTFit / FunctionalPCA / FLMResult は +-- Hanalyze.Plot.ML へ移動 — Phase 71.6) + +-- =========================================================================== +-- 罰則回帰・因果探索 (Regularized / LiNGAM) — Phase 68 A6 +-- +-- 新規 plot mark は不要: +-- +-- * 'RegFit' = 単一 λ の係数 ('rfBeta') を bar (代表図)。 +-- * 'regPathPlot' = 正則化パス @[(λ, [β_j])]@ ('regularizationPath' 出力) を、 +-- 係数ごとに 1 本の line で λ-横軸に重畳 (= LASSO 係数パス図)。 +-- * @DirectLiNGAMFit@ = 推定した因果構造を **MDAG** で描く (B 行列 → node/edge、 +-- 決定木と同じ MDAG 再利用)。 edge j→i は @|adjacency[i,j]|>0@。 +-- =========================================================================== + +-- (instance Plottable RegFit / regPathPlot / lingamDag / +-- instance Plottable DirectLiNGAMFit は Hanalyze.Plot.ML へ移動 — Phase 71.6) + +-- =========================================================================== +-- 記述統計・検定 (Stat.*) — Phase 68 A7 +-- +-- 新規 plot mark は不要: +-- +-- * 'TestResult' = 効果量 + 95% CI の **forest** (検定パラメータの区間 + 0 基準線)。 +-- 代表図 (@toPlot@) は 1 行 forest、 複数検定は 'testForest'。 +-- * 'describeBox' = 生データ列の **box plot** (= describe の分布図・5 数要約を可視化)。 +-- =========================================================================== + +-- (testForest / testForestLabeled / instance Plottable TestResult / +-- describeBox は Hanalyze.Plot.ML へ移動 — Phase 71.6) + + +-- (instance SingleVarModel WeightedLMModel / Plottable WeightedLMModel は +-- Hanalyze.Plot.Linear へ移動 — Phase 71.5) + + + +-- C2: 元スケール逆変換 instance (Phase 70.3 項目 C) ------------------------- +-- +-- 内側モデルは標準化空間で学習されている。 ここで予測子 x を入力時に標準化し、 +-- (@standardizedY@ なら) 応答 y を出力時に逆変換することで、 図・予測を**元スケール**で +-- 返す。 単変量 (1 特徴) 描画が対象 (smXStd の 0 次元を使う)。 + +-- (instance SingleVarModel KNNRegressor / stMu1 / stSd1 / unstdY / +-- SingleVarModel (StandardizedModel m) / Plottable (StandardizedModel m) は +-- Hanalyze.Plot.Wrappers へ移動 — Phase 71.7) + +-- =========================================================================== +-- 混合効果モデル (random effects) — Phase 52 D3 +-- +-- 'GLMMResultRE' (Phase 48 の vector random effects: random intercept + slope) +-- を caterpillar plot で描く。 各 group の BLUP @b̂_j@ を **値で昇順ソート**し、 +-- forest mark (水平棒) で並べる。 0 (= 固定効果からの偏差ゼロ) に参照線を引く。 +-- group 間の random effect のばらつき・外れ群を一目で読めるのが GLMM 固有の定番図。 +-- +-- ★ CI 帯は現状なし (点のみ): 'GLMMResultRE' は per-group の conditional variance +-- も観測数 @n_j@ も格納しておらず (scalar 専用の 'glmmBLUPSE' は 'GLMMResult' 用で +-- 流用不可)、 BLUP の標準誤差を単体から計算できない。 将来 conditional variance を +-- 持たせれば forest の誤差半幅を埋めて帯化できる (forest mark は対称 CI 対応済)。 +-- +-- @toPlot@ = random-effect 第 1 列 (通常 intercept) の caterpillar 1 枚。 +-- 'diagnosticPlots' = 全 r 列 (intercept + 各 slope) の caterpillar list。 +-- =========================================================================== + + + +-- (instance SingleVarModel GPRegModel / Plottable GPRegModel / +-- SingleVarModel GPRegModelN / Plottable GPRegModelN は +-- Hanalyze.Plot.Smooth へ移動 — Phase 71.5) + + +-- (instance Plottable RegModel / regMethodName / roundTo は +-- Hanalyze.Plot.Wrappers へ移動 — Phase 71.7) + +-- (familyObsDist は Hanalyze.Plot.Linear へ移動 — Phase 71.5) + +-- (lmDiag / groupedLmDiag / instance Plottable (GroupedFit spec) / +-- renderGrouped / groupedFullrange / renderGroupedWith / +-- instance ColumnSource [(Text, ColData)] は +-- Hanalyze.Plot.Wrappers へ移動 — Phase 71.7) + +-- (dataScatterOf は Hanalyze.Plot.Bayes へ移動 — Phase 71.7) + diff --git a/src/Hanalyze/Plot/Bayes.hs b/src/Hanalyze/Plot/Bayes.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Plot/Bayes.hs @@ -0,0 +1,1341 @@ +-- | +-- Module : Hanalyze.Plot.Bayes +-- Description : hgg 連携層 — ベイズ / HBM 連携族の図化 instance + 抽出子 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: hgg 連携層 — __ベイズ / HBM 連携族__ の図化 instance + 抽出子。 +-- +-- ⚠ 親 'Hanalyze.Plot' と同じく別パッケージ @hanalyze-plot@ に属し、 +-- @cabal build --project-file=cabal.project.plot@ で build される。 共通基盤 (class / ModelSpec / grid 評価核) は +-- 'Hanalyze.Plot.Core' を import して取り込む (orphan instance を許容)。 +-- +-- 担当する型・抽出子 (= MCMC chain / HBM 出力): +-- ChainModel の trace / 周辺事後密度・HBM の trace/forest/epred/ppc/dag 抽出子 (統一済)・ +-- GLMMResultRE の caterpillar plot。 HBM の *学習* (hbmModel 等) は +-- 'Hanalyze.Fit' / 'Hanalyze.Model.Wrappers' 側 (こちらは描画連携のみ)。 +-- +-- [English]: hgg integration layer — __Bayesian / HBM family__ +-- plotting instances and extractors. +-- +-- ⚠ Lives in the same separate package @hanalyze-plot@ as the parent +-- module 'Hanalyze.Plot', built via @cabal build --project-file=cabal.project.plot@. +-- It imports the +-- shared foundation (the class \/ ModelSpec \/ grid-evaluation core) from +-- 'Hanalyze.Plot.Core' (orphan instances are allowed here). +-- +-- Types and extractors covered (= MCMC chains \/ HBM output): +-- 'ChainModel'\'s trace \/ marginal posterior density; HBM's unified +-- trace\/forest\/epred\/ppc\/dag extractors; and 'GLMMResultRE'\'s +-- caterpillar plot. HBM *training* (@hbmModel@ etc.) lives on the +-- 'Hanalyze.Fit' \/ 'Hanalyze.Model.Wrappers' side (this +-- module handles plotting integration only). +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Hanalyze.Plot.Bayes + ( -- * HBM の出力抽出子 (trace / forest) + hbmParamNames + , TraceOpts (..) + , defaultTraceOpts + , tracesOf + , tracesOfWith + , marginalsOf + , marginalsByChainOf + -- * HBM のサンプリング診断 (divergence 可視化) + , divergencesOf + , pairOf + , energyOf + , autocorrOf + , autocorrOfLag + , defaultAutocorrMaxLag + , rankOf + , rankOfBins + , defaultRankBins + , ForestSpec (..) + , forestOf + , forestOfLevel + -- * HBM の出力抽出子 (epred = 事後予測平均 + HDI band) + , epred + , epredAt + , epredPredRange + -- * 応答曲面 3D / 散布 (HBM 固有) + , epredSurfaceOf + , epredSurfaceOfWith + , dataScatterOf + -- * HBM の出力抽出子 (ppc = 事後予測チェック) + , PPCConfig (..) + , defaultPPC + , PPCSpec (..) + , ppcOf + , ppcOfWith + , ppcOfIO + , ppcOfWithIO + -- * HBM の出力抽出子 (dag = モデル構造の DAG) + , DagSpec (..) + , dagOf + , dagOfRaw + , dagOfModel + , dagOfModelWith + -- * HBM 診断ダッシュボード (抽出子束ね) + , dashboardOf + , dashboardFullOf + , traceDensityOf + ) where + +import Data.List (sortBy, transpose) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Data.Word (Word32) +import qualified Data.Vector as V +import System.Random.MWC (createSystemRandom, initialize, Gen) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.ST (runST) +import qualified Numeric.LinearAlgebra as LA + +import Data.Text (Text) +import qualified Data.Text as T + +import Graphics.Hgg.Spec ( VisualSpec, layer, inline, inlineCat + , Color (..), fromHex + , scatter, line, band, bar + , position, Position (..) + , color, colorBy, lineRange + , scaleColorManual, legendOff + , legendPos, LegendPosition (..) + , trace, density, forest, forestNull + , subplots, subplotCols, width, height + , xLabel, yLabel, title + , ecdf, alpha + , dagFromListsWithPlates + , DAGNode (..), DAGEdge (..), DAGPlate (..) + , DAGNodeKind (..), DAGLayoutAlgorithm (..) ) +import Graphics.Hgg.DAG (layoutHierarchicalFullWithPlates) +import Graphics.Hgg.Render.Special (bakeDAGRoutesInSpec) +import qualified Graphics.Hgg.ThreeD.Spec as P3 + +import Hanalyze.Model.Wrappers +import Hanalyze.Plot.Core +import Hanalyze.MCMC.Core (Chain (..), chainVals) +import Hanalyze.MCMC.BayesianTest (highestDensityInterval) +import Hanalyze.Stat.MCMC (kde, autocorr, rankHist) +import Hanalyze.Model.HBM.Sampling (sampleObsRep) +import Hanalyze.Model.HBM (ModelP, withData + , runDeterministics, runObserveDists + , buildModelGraph, ModelGraph (..) + , collapseIndexedPlateNodes + , sampleNames + , Node (..), NodeKind (..)) +import Hanalyze.Model.LM (linspace) +import Hanalyze.Model.GLMM (GLMMResultRE (..)) + +-- =========================================================================== +-- MCMC チェーン (描画可能) +-- +-- 'Chain' (Hanalyze.MCMC.Core) は post-burn-in の draw 列 'chainSamples' を保持する +-- (各 draw は Map パラメータ名→値)。 ベイズの「出入口」 = サンプラの収束診断と周辺事後の +-- 可視化。 1 つのパラメータを選び、 代表図 (@toPlot@) は **trace plot** (draw index 対値、 +-- = 混合・定常性の目視)、 診断束 ('diagnosticPlots') に **周辺事後密度** (MDensity) を加える。 +-- trace と density は座標系が異なる (index-値 vs 値-密度) ため 1 枚に混ぜず別図にする。 +-- =========================================================================== + +instance Plottable ChainModel where + -- trace plot: draw index 対 パラメータ値 (折れ線 = MTrace)。 + toPlot m = + let vals = chainVals (cmParam m) (cmChain m) + iters = [ fromIntegral i | i <- [1 .. length vals] ] :: [Double] + in layer (trace (inline iters) (inline vals)) + + -- 診断束: trace + 周辺事後密度 (MDensity)。 + diagnosticPlots m = + let vals = chainVals (cmParam m) (cmChain m) + iters = [ fromIntegral i | i <- [1 .. length vals] ] :: [Double] + in [ layer (trace (inline iters) (inline vals)) + , layer (density (inline vals)) + ] + +-- =========================================================================== +-- HBM の出力抽出子 — Phase 49 A2 / Phase 74 (trace / forest) +-- +-- 'HBMModel' は直接 'Plottable' にしない (確率プログラムは単一の図に一意に落ちない)。 +-- 代わりに抽出子を明示する。 trace は @tracesOf@ / 'tracesOfWith' に統一: +-- * @tracesOf@ = 各 latent パラメータの trace plot を **param ごと独立パネル** +-- ('[VisualSpec]') で返す。 divergence rug は既定 ON (ArviZ 流)。 +-- * 'tracesOfWith' = 'TraceOpts' で divergence on/off と chain 別重畳を切り替える。 +-- * 'forestOf' = 各 latent の事後区間 (事後平均 + 94% HDI) を 'MForest' mark で。 +-- +-- ★ Phase 74 で旧 @traceOf@ ([ChainModel]) / @tracesByChainOf@ / +-- @tracesWithDivergencesOf@ の 3 本を統合した。 戻り型を兄弟抽出子 (marginalsOf 等) +-- と同じ '[VisualSpec]' に揃え、 @vconcat (tracesOf m)@ で param ごと縦並びに描ける +-- (旧 docs の @foldMap toPlot (traceOf m)@ = 全 param を 1 軸に重畳する誤りを排除)。 +-- =========================================================================== + +-- | [日本語]: 学習済モデルの latent パラメータ名 (= 事後を持つ未知数の一覧)。 +-- [English]: The trained model's latent parameter names (= the list of +-- unknowns that have a posterior). +hbmParamNames :: HBMModel -> [Text] +hbmParamNames = sampleNames . hbmModelSpec + +-- | [日本語]: 1 パラメータの post-burn-in draw を全 chain 連結で取り出す。 +-- [English]: Retrieves one parameter's post-burn-in draws, concatenated +-- across all chains. +hbmDraws :: Text -> HBMModel -> [Double] +hbmDraws name = concatMap (chainVals name) . hbmChainsR + +-- | [日本語]: 全 chain の draw を 1 本に連結した 'Chain' (trace 表示用)。 index は +-- chain を端から端へ並べた通し番号になる (trace は混合の目視が目的)。 +-- divergence index も同じ連結順の通し番号に変換する ('pooledDivergences' が正本。 +-- chain 内 index のまま連結すると merged frame で別の draw を指してしまう)。 +-- [English]: A single 'Chain' with all chains' draws concatenated (for +-- trace display). The index becomes a running number across the +-- end-to-end chains (the trace's purpose is to visually check mixing). +-- Divergence indices are converted to the same concatenated running +-- numbering ('pooledDivergences' is the canonical source; concatenating +-- with raw within-chain indices would point at the wrong draw in the +-- merged frame). +mergeChains :: [Chain] -> Chain +mergeChains [] = Chain [] 0 0 [] [] [] +mergeChains chs = Chain + { chainSamples = concatMap chainSamples chs + , chainAccepted = sum (map chainAccepted chs) + , chainTotal = sum (map chainTotal chs) + , chainEnergy = concatMap chainEnergy chs + , chainDivergences = pooledDivergences chs + , chainTreeDepths = concatMap chainTreeDepths chs + } + +-- | [日本語]: trace 診断の設定 ('ppcOf' / 'PPCConfig' と同じ「関数 + config」 慣用)。 +-- [English]: Trace-diagnostic settings (the same "function + config" idiom +-- as 'ppcOf' \/ 'PPCConfig'). +data TraceOpts = TraceOpts + { toShowDivergences :: !Bool -- ^ [日本語]: 発散 draw の rug を重ねる (既定 True・ArviZ 流)。 [English]: Overlay a rug of divergent draws (default True, ArviZ-style). + , toByChain :: !Bool -- ^ [日本語]: True で chain 別重畳、 False で全 chain merged (既定)。 [English]: True overlays chains separately; False merges all chains (the default). + } deriving (Show, Eq) + +-- | [日本語]: 既定の trace 設定 = divergence rug ON・全 chain merged。 +-- [English]: Default trace settings = divergence rug ON, all chains +-- merged. +defaultTraceOpts :: TraceOpts +defaultTraceOpts = TraceOpts { toShowDivergences = True, toByChain = False } + +-- | [日本語]: 各 latent パラメータの trace plot を __param ごと独立パネル__ ('[VisualSpec]') +-- で返す (divergence rug 既定 ON)。 @noDf |>> vconcat (tracesOf m)@ で param ごとに +-- 縦並びの trace になる (= ArviZ @plot_trace@ 右列)。 設定は 'tracesOfWith'。 +-- [English]: Returns the trace plot of each latent parameter as an +-- __independent panel per param__ ('[VisualSpec]') with the divergence rug +-- on by default. @noDf |>> vconcat (tracesOf m)@ stacks the traces +-- vertically per param (= ArviZ's @plot_trace@ right column). Use +-- 'tracesOfWith' to configure it. +tracesOf :: HBMModel -> [VisualSpec] +tracesOf = tracesOfWith defaultTraceOpts + +-- | [日本語]: 'TraceOpts' を明示する @tracesOf@。 旧 @traceOf@ (merged 単線) / +-- @tracesByChainOf@ (chain 別重畳) / @tracesWithDivergencesOf@ (chain 別 + rug) の +-- 3 本を 1 つに統合したもの: +-- +-- * @tracesOfWith (TraceOpts False False)@ = 旧 @traceOf@ 相当 (merged 単線・rug 無し) +-- * @tracesOfWith (TraceOpts False True )@ = 旧 @tracesByChainOf@ (chain 別重畳・rug 無し) +-- * @tracesOfWith (TraceOpts True True )@ = 旧 @tracesWithDivergencesOf@ (chain 別 + rug) +-- * 既定 @tracesOf@ = @TraceOpts True False@ (merged + rug) +-- +-- divergence rug は各図下端 (y = 当該 param の全 chain 最小値) に発散 draw の x 位置を +-- 縦棒 ('lineRange') で打つ。 merged では通し index ('divergencesOf')、 chain 別では +-- chain 内 1-based iteration を x にする (それぞれの trace の x 軸と整合)。 +-- divergence が無ければ rug レイヤは付かない。 +-- [English]: @tracesOf@ with an explicit 'TraceOpts'. Unifies the former +-- three functions — @traceOf@ (merged single line), @tracesByChainOf@ +-- (overlaid per chain), and @tracesWithDivergencesOf@ (per chain + rug) — +-- into one: +-- +-- * @tracesOfWith (TraceOpts False False)@ = the old @traceOf@ (merged single line, no rug) +-- * @tracesOfWith (TraceOpts False True )@ = the old @tracesByChainOf@ (overlaid per chain, no rug) +-- * @tracesOfWith (TraceOpts True True )@ = the old @tracesWithDivergencesOf@ (per chain + rug) +-- * default @tracesOf@ = @TraceOpts True False@ (merged + rug) +-- +-- The divergence rug draws a vertical tick ('lineRange') at each divergent +-- draw's x position, at the bottom of each panel (y = that param's minimum +-- across all chains). Merged mode uses the running index +-- ('divergencesOf'); per-chain mode uses the 1-based iteration within the +-- chain (matching each trace's own x axis). No rug layer is added when +-- there are no divergences. +tracesOfWith :: TraceOpts -> HBMModel -> [VisualSpec] +tracesOfWith opts hbm = + [ traceLayers nm <> rugLayer nm <> title nm | nm <- hbmParamNames hbm ] + where + chs = hbmChainsR hbm + traceLayers nm + | toByChain opts = + foldMap (\(k, ch) -> + let vals = chainVals nm ch + iters = [ fromIntegral i | i <- [1 .. length vals] ] :: [Double] + in layer (trace (inline iters) (inline vals) <> color (fromHex (chainColor k)))) + (zip [0 ..] chs) + | otherwise = + let vals = chainVals nm (mergeChains chs) + iters = [ fromIntegral i | i <- [1 .. length vals] ] :: [Double] + in layer (trace (inline iters) (inline vals)) + rugLayer nm + | not (toShowDivergences opts) = mempty + | otherwise = + let allVals = concatMap (chainVals nm) chs + -- merged: 連結通し index (divergencesOf)。chain 別: chain 内 1-based iteration。 + xs | toByChain opts = [ fromIntegral (i + 1) | ch <- chs, i <- chainDivergences ch ] :: [Double] + | otherwise = [ fromIntegral (i + 1) | i <- divergencesOf hbm ] :: [Double] + in if null xs || null allVals + then mempty + -- ArviZ tick 同型 = 下端から値域 2% の短い縦棒。 定数 trace では 1e-9 最小高。 + -- ★lineRange の意味論は (x, 中心 y, ±err) = 下端 yMin〜yMin+tick の棒。 + else let yMin = minimum allVals + yMax = maximum allVals + tick = max ((yMax - yMin) * 0.02) 1e-9 + nDiv = length xs + in layer (lineRange (inline xs) + (inline (replicate nDiv (yMin + tick / 2))) + (inline (replicate nDiv (tick / 2))) + <> color (fromHex divergenceColor)) + +-- | [日本語]: 各 latent パラメータの __周辺事後密度__ を per-param で list 返しする。 +-- @tracesOf@ (per-param trace) の密度版で、 'ChainModel' の @diagnosticPlots@ が出す +-- 周辺事後密度 (@density@、 root: 'diagnosticPlots' ChainModel 経路) を 1 パラメータ +-- 1 図に切り出したもの。 全 chain の post-burn-in draw をプール ('hbmDraws') した +-- 周辺分布を描き、 図タイトルにパラメータ名を付す。 +-- +-- @subplots (map toPlot (marginalsOf fit)) <> subplotCols 1@ で周辺事後の grid を組め、 +-- 入れ子 subplots と合わせて HBM ダッシュボードの 1 列になる。 +-- [English]: Returns each latent parameter's __marginal posterior density__ +-- as a per-param list. This is the density counterpart of +-- @tracesOf@ (per-param trace): it slices out the marginal posterior +-- density (@density@; sourced from 'ChainModel'\'s @diagnosticPlots@ path) +-- into one figure per parameter. It plots the marginal distribution built +-- by pooling all chains' post-burn-in draws ('hbmDraws'), with the +-- parameter name as the figure title. +-- +-- @subplots (map toPlot (marginalsOf fit)) <> subplotCols 1@ builds a grid +-- of marginal posteriors, which combined with nested subplots becomes one +-- column of an HBM dashboard. +marginalsOf :: HBMModel -> [VisualSpec] +marginalsOf hbm = + [ layer (density (inline (hbmDraws nm hbm))) <> title nm + | nm <- hbmParamNames hbm ] + +-- =========================================================================== +-- HBM のサンプリング診断 — Phase 59.4 / 74 (divergence の通し index + pair/energy) +-- +-- 'Chain' は NUTS の発散 draw index ('chainDivergences' = chain 内 0-based・ +-- post-burn-in、 root: request/255 §4) と Hamiltonian energy を記録済み。 ここでは +-- それを plot-core の語彙 (scatter + color) で図示する。 rug 用の新 MarkKind は +-- 追加しない (計画 md の設計判断: 既存 mark の組合せで足りることを確認してから諮る)。 +-- trace の divergence rug 自体は 'tracesOfWith' (Phase 74 統合) に移譲した。 +-- =========================================================================== + +-- | [日本語]: [Chain] の発散 draw を連結順の通し index に変換する内部正本 +-- (chain c の offset = それ以前の chain の draw 数合計)。 'mergeChains' / +-- 'divergencesOf' の双方がこれを使う (重複実装しない)。 +-- [English]: The internal canonical function converting each 'Chain'\'s +-- divergent draws into a running, concatenated index (chain c's offset = +-- the total draw count of the chains before it). Both 'mergeChains' and +-- 'divergencesOf' use this (no duplicated implementation). +pooledDivergences :: [Chain] -> [Int] +pooledDivergences chs = + concat [ map (+ off) (chainDivergences ch) + | (off, ch) <- zip offsets chs ] + where offsets = scanl (+) 0 (map (length . chainSamples) chs) + +-- | [日本語]: 全 chain を pool した発散 draw の通し index ('mergeChains' の連結順と整合)。 +-- @tracesOf@ (merged trace) の rug 位置や、 発散 draw の抽出 +-- (@map (chainSamples merged !!) (divergencesOf fit)@) に使う。 +-- [English]: The running index of divergent draws pooled across all +-- chains (consistent with 'mergeChains'\'s concatenation order). Used for +-- the rug position in @tracesOf@ (merged trace) and to extract divergent +-- draws (@map (chainSamples merged !!) (divergencesOf fit)@). +divergencesOf :: HBMModel -> [Int] +divergencesOf = pooledDivergences . hbmChainsR + +-- | [日本語]: divergence rug / 強調点の色 ('Hanalyze.Viz.MCMC' の pairScatterDiv と同じ赤)。 +-- [English]: The color for the divergence rug \/ highlighted points (the +-- same red as 'Hanalyze.Viz.MCMC'\'s @pairScatterDiv@). +divergenceColor :: Text +divergenceColor = "#dd2222" -- 小文字 (toCss 出力と byte 一致・視覚は #DD2222 と同一) + +-- | [日本語]: ArviZ @plot_pair(divergences=True)@ 流: 指定パラメータ対の joint 散布 +-- (全 chain pool・薄表示) + 発散 draw を強調色で重畳。 funnel 診断の本命 +-- (例: @pairOf fit [("tau_b1", "b1_2")]@ で漏斗の首に発散が集中するのが見える)。 +-- 発散 draw の抽出は 'divergencesOf' の通し index を pool 後の draw 列に引く +-- (chain 連結順は 'hbmDraws' = 'mergeChains' と同一)。 +-- divergence が無ければ強調レイヤは付かない。 +-- [English]: ArviZ @plot_pair(divergences=True)@-style: the joint scatter +-- of a given parameter pair (pooled across all chains, drawn faintly), +-- with divergent draws overlaid in a highlight color. This is the go-to +-- funnel diagnostic (e.g. @pairOf fit [("tau_b1", "b1_2")]@ shows +-- divergences concentrated at the neck of the funnel). Divergent draws are +-- extracted by indexing the pooled draw list with 'divergencesOf'\'s +-- running index (the chain concatenation order matches 'hbmDraws' = +-- 'mergeChains'). No highlight layer is added when there are no +-- divergences. +pairOf :: HBMModel -> [(Text, Text)] -> [VisualSpec] +pairOf hbm prs = + [ let xs = hbmDraws xn hbm + ys = hbmDraws yn hbm + n = min (length xs) (length ys) + dIdx = [ i | i <- divergencesOf hbm, i < n ] + dxs = map (xs !!) dIdx + dys = map (ys !!) dIdx + in layer (scatter (inline xs) (inline ys) <> alpha 0.25) + <> (if null dIdx + then mempty + else layer (scatter (inline dxs) (inline dys) + <> color (fromHex divergenceColor))) + <> xLabel xn <> yLabel yn <> title (xn <> " × " <> yn) + | (xn, yn) <- prs ] + +-- | [日本語]: ArviZ @plot_energy@ 流: marginal energy (E − Ē、 chain 別中心化) と +-- transition energy (ΔE = E_{i+1} − E_i、 chain 内差分・境界を跨がない) の密度重畳。 +-- ΔE 分布が marginal より極端に狭ければ、 サンプラが posterior の energy 分布を +-- 探索しきれていないサイン (低 BFMI 相当。 数値は 'Hanalyze.Viz.MCMC' の bfmi)。 +-- energy ('chainEnergy' = draw ごとの Hamiltonian) は HMC / NUTS のみ記録される +-- ため、 MH / Gibbs 等の fit では空図になる。 系列名は Viz 側 energyPlot と同一。 +-- +-- ★mark は 'density' でなく KDE ('Hanalyze.Stat.MCMC' の kde 200 = Viz energyPlot と +-- 同一) + 'line'。 理由: 固定色 'color' と categorical 'colorBy' は同一 field (lyColor) の +-- Last で相互排他、 かつ renderDensity は categorical 色を見ない (staticColorOr のみ) ため、 +-- density mark では「2 色の曲線 + 凡例」 が両立できない。 line は群色対応済なので +-- 多モデル重畳 (line + color inlineCat + scaleColorManual + legend) の確立パターンに +-- 乗せる。 +-- [English]: ArviZ @plot_energy@-style: overlaid densities of the marginal +-- energy (E − Ē, centered per chain) and the transition energy +-- (ΔE = E_{i+1} − E_i, within-chain difference, never crossing a chain +-- boundary). If the ΔE distribution is markedly narrower than the +-- marginal, that's a sign the sampler hasn't fully explored the +-- posterior's energy distribution (equivalent to low BFMI; the numeric +-- diagnostic is 'Hanalyze.Viz.MCMC'\'s @bfmi@). Energy +-- ('chainEnergy' = the per-draw Hamiltonian) is only recorded for HMC \/ +-- NUTS, so fits from MH \/ Gibbs etc. yield an empty figure. Series names +-- match the Viz-side @energyPlot@. +-- +-- ★The mark is KDE ('Hanalyze.Stat.MCMC'\'s @kde@ with 200 points, +-- the same as Viz's @energyPlot@) + 'line', not 'density'. Reason: a fixed +-- 'color' and a categorical 'colorBy' both target the same field +-- (@lyColor@) under Last-wins semantics, and are mutually exclusive; also +-- @renderDensity@ ignores categorical color (it only looks at +-- @staticColorOr@), so a @density@ mark cannot produce "two colored curves +-- + a legend" at once. @line@ already supports group coloring, so this +-- rides the established pattern for overlaying multiple models (@line@ + +-- @color inlineCat@ + @scaleColorManual@ + legend). +energyOf :: HBMModel -> VisualSpec +energyOf hbm = + curve lblMar eMar <> curve lblTr eTrans <> legendSpec + <> xLabel "Energy" <> yLabel "Density" <> title "energy" + where + lblMar = "marginal E (centered)" + lblTr = "transition ΔE" + ess = filter (not . null) (map chainEnergy (hbmChainsR hbm)) + center es = let mu = sum es / fromIntegral (length es) + in map (subtract mu) es + eMar = concatMap center ess + eTrans = concatMap (\es -> zipWith (-) (drop 1 es) es) ess + curve lbl vals + | length vals < 2 = mempty + | otherwise = + let (gx, gy) = unzip (kde 200 vals) + in layer (line (inline gx) (inline gy) + <> colorBy (inlineCat (replicate (length gx) lbl))) + legendSpec + | null eMar = mempty + | otherwise = scaleColorManual [ (lblMar, "#4C72B0"), (lblTr, "#DD8452") ] + -- 凡例は図内 (右上)。 密度は中央が高く右裾は 0 ゆえ右上が空く。 + -- 外・右だと右に余白が出て subplot/dashboard が不格好になる。 + <> legendPos LegendInsideTopRight + +-- | [日本語]: chain 別の __周辺事後密度__ を 1 図に重畳した per-param list (= ArviZ @plot_trace@ 左側 / +-- @plot_posterior@ の chain 重ね)。 'marginalsOf' が全 chain プールの 1 本を描くのに対し、 +-- こちらは chain ごとに別レイヤを 'color' ('fromHex') で重ねる。 +-- [English]: A per-param list overlaying each chain's __marginal posterior density__ +-- in one figure (= ArviZ's @plot_trace@ left column \/ +-- the chain overlay in @plot_posterior@). Where 'marginalsOf' draws a +-- single pooled curve across all chains, this overlays a separate layer +-- per chain, colored via 'color' \/ 'fromHex'. +marginalsByChainOf :: HBMModel -> [VisualSpec] +marginalsByChainOf hbm = + [ foldMap (\(k, ch) -> layer (density (inline (chainVals nm ch)) <> color (fromHex (chainColor k)))) + (zip [0 ..] (hbmChainsR hbm)) + <> title nm + | nm <- hbmParamNames hbm ] + +-- | [日本語]: 自己相関 plot の既定最大ラグ (= ArviZ @plot_autocorr@ の見やすさに合わせた 30。 +-- ArviZ 既定の 100 は SVG では横に潰れるので短めにする)。 +-- [English]: The default maximum lag for the autocorrelation plot (= 30, +-- chosen for readability with ArviZ's @plot_autocorr@; ArviZ's default of +-- 100 gets squashed horizontally in SVG, so this is kept shorter). +defaultAutocorrMaxLag :: Int +defaultAutocorrMaxLag = 30 + +-- | [日本語]: 各 latent パラメータの __自己相関__ を per-param list で返す (= ArviZ @plot_autocorr@)。 +-- lag 0..'defaultAutocorrMaxLag' の ACF を縦棒 ('bar') で描く。 chain 連結の境界アーティ +-- ファクトを避けるため __chain ごとに 'autocorr' を計算し lag ごとに平均__する +-- ('energyOf' が chain 別に算出して連結するのと同方針)。 ACF が速く 0 に減衰するほど +-- mixing が良い (高い自己相関 = ESS 低下のサイン)。 +-- [English]: Returns each latent parameter's __autocorrelation__ as a +-- per-param list (= ArviZ's @plot_autocorr@). Plots the ACF for lags +-- 0..'defaultAutocorrMaxLag' as vertical bars ('bar'). To avoid boundary +-- artifacts from concatenating chains, this __computes 'autocorr' per chain and averages per lag__ +-- (the same policy as 'energyOf' computing +-- per chain before concatenating). The faster the ACF decays to 0, the +-- better the mixing (high autocorrelation is a sign of reduced ESS). +autocorrOf :: HBMModel -> [VisualSpec] +autocorrOf = autocorrOfLag defaultAutocorrMaxLag + +-- | [日本語]: 最大ラグを明示する 'autocorrOf'。 +-- [English]: 'autocorrOf' with an explicit maximum lag. +autocorrOfLag :: Int -> HBMModel -> [VisualSpec] +autocorrOfLag maxLag hbm = + [ acSpec nm | nm <- hbmParamNames hbm ] + where + chains = hbmChainsR hbm + acSpec nm = + let perChain = [ autocorr maxLag vs + | c <- chains, let vs = chainVals nm c, not (null vs) ] + in case perChain of + [] -> mempty + (ac0:_) -> + let lags = map (fromIntegral . fst) ac0 :: [Double] + acfByCh = map (map snd) perChain -- [chain][lag] + meanACF = map (\col -> sum col / fromIntegral (length col)) + (transpose acfByCh) -- lag ごとの chain 平均 + -- y 軸ラベルは省く (図が潰れるため。 title でパラメータ名は分かる)。 + in layer (bar (inline lags) (inline meanACF)) + <> title nm <> xLabel "lag" + +-- | [日本語]: rank plot の既定ビン数 (= PyMC @plot_rank@ 既定 20)。 +-- [English]: The default number of bins for the rank plot (= 20, matching +-- PyMC's @plot_rank@ default). +defaultRankBins :: Int +defaultRankBins = 20 + +-- | [日本語]: 各 latent パラメータの __rank plot__ を per-param list で返す (= ArviZ @plot_rank@・ +-- Vehtari et al. 2021)。 全 chain をプールした値の rank を chain ごとにヒストグラム化し、 +-- chain 別の棒を色分けして重畳する。 __収束時は各 chain がほぼ一様__ (= どのビンも同程度)。 +-- chain が偏る (= 山ができる) と R̂ 悪化のサイン。 rank 計算は 'rankHist' (Stat.MCMC) に +-- 一元化し Viz 経路と共有する。 __要 chain ≥ 2__ (1 本だと rank が自明に一様ゆえ空図)。 +-- [English]: Returns each latent parameter's __rank plot__ as a per-param +-- list (= ArviZ's @plot_rank@; Vehtari et al. 2021). Ranks the values +-- pooled across all chains, histograms them per chain, and overlays the +-- per-chain bars in distinct colors. __At convergence each chain is nearly uniform__ +-- (i.e. every bin has roughly equal counts); a chain skewing +-- toward a bump is a sign of worse R̂. Rank computation is centralized in +-- 'rankHist' (Stat.MCMC) and shared with the Viz path. __Requires chain ≥ 2__ +-- (with a single chain the rank is trivially uniform, so the +-- figure is empty). +rankOf :: HBMModel -> [VisualSpec] +rankOf = rankOfBins defaultRankBins + +-- | [日本語]: ビン数を明示する 'rankOf'。 +-- [English]: 'rankOf' with an explicit number of bins. +rankOfBins :: Int -> HBMModel -> [VisualSpec] +rankOfBins nBins hbm = + [ rankSpec nm | nm <- hbmParamNames hbm ] + where + chains = hbmChainsR hbm + nCh = length chains + rankSpec nm = + let perChain = map (chainVals nm) chains + in if nCh < 2 || all null perChain + then mempty + else + -- chain を横並び (dodge) にした 1 層の bar (= ArviZ plot_rank の単一パネル版)。 + -- long-form: (bin, count, chain) を chain×bin 行で展開し colorBy + PosDodge。 + let hists = rankHist nBins perChain -- [chain][bin] + -- ビンは categorical だが軸はアルファベット順ゆえ、 数値順を保つよう + -- 0 埋めラベル ("00".."19") にする (= 文字列ソート = 数値順)。 + w = length (show (nBins - 1)) + pad i = let s = show (i :: Int) + in T.pack (replicate (w - length s) '0' ++ s) + binCat = concat [ [ pad b | b <- [0 .. nBins - 1] ] | _ <- [1 .. nCh] ] + cntCol = concatMap (map fromIntegral) hists :: [Double] + chainCat = concat [ replicate nBins (T.pack ("chain " <> show k)) + | k <- [0 .. nCh - 1] ] + -- y 軸ラベル・凡例は省く (図が潰れるため。 chain は色 dodge で判別可)。 + -- colorBy は既定で凡例を出すので legendOff で明示的に抑制する。 + in layer ( bar (inlineCat binCat) (inline cntCol) + <> colorBy (inlineCat chainCat) + <> position PosDodge ) + <> title nm <> xLabel "rank bin" <> legendOff + + +-- | [日本語]: 係数 forest plot の描画仕様。 'HBMModel' を直接 'Plottable' にしないため、 +-- 抽出後の図を包む薄い newtype (後続 sub の ppc/epred/dag も同型に揃える)。 +-- [English]: The plotting spec for a coefficient forest plot. Since +-- 'HBMModel' isn't made directly 'Plottable', this is a thin newtype +-- wrapping the extracted figure (the later ppc \/ epred \/ dag specs +-- follow the same shape). +newtype ForestSpec = ForestSpec { unForestSpec :: VisualSpec } + +instance Plottable ForestSpec where + toPlot = unForestSpec + +-- | [日本語]: 各 latent パラメータの事後区間を 1 枚の forest plot にする (94% HDI 既定)。 +-- [English]: Renders each latent parameter's posterior interval as a +-- single forest plot (default 94% HDI). +forestOf :: HBMModel -> ForestSpec +forestOf = forestOfLevel 0.94 + +-- | [日本語]: 信頼水準を明示する 'forestOf'。 point = 事後平均、 bar 半幅 = HDI 半幅。 +-- +-- ★ 'forest' mark は対称 CI (± 半幅) のみ対応するため、 非対称な HDI は +-- 「事後平均 ± (hi−lo)/2」 の対称バーで近似表示する (mark 側の TODO = 非対称 forest 未対応)。 +-- [English]: 'forestOf' with an explicit confidence level. The point is +-- the posterior mean; the bar half-width is the HDI half-width. +-- +-- ★ Since the 'forest' mark only supports a symmetric CI (± half-width), +-- the asymmetric HDI is approximated as a symmetric bar of "posterior mean +-- ± (hi−lo)/2" (a TODO on the mark side: asymmetric forest bars are not +-- yet supported). +forestOfLevel :: Double -> HBMModel -> ForestSpec +forestOfLevel level hbm = ForestSpec $ + layer (forest (inlineCat names) (inline ests) (inline errs) <> forestNull 0) + where + names = hbmParamNames hbm + rows = [ (mean, (hi - lo) / 2) + | nm <- names + , let d = hbmDraws nm hbm + mean = if null d then 0 else sum d / fromIntegral (length d) + (lo, hi) = highestDensityInterval level d + ] + ests = map fst rows + errs = map snd rows + +-- =========================================================================== +-- HBM の事後予測平均 — Phase 49 A3 (epred = E[y|x] の grid 評価 + HDI band) +-- +-- ベイズ回帰の代表図。 予測子 (@predName@、 学習時 @dataNamed@ の参照名) を grid 上で +-- 1 点ずつ動かし、 各 posterior draw でモデル中の deterministic ノード (@muName@、 +-- 通常は線形予測子の平均 μ) を 'runDeterministics' で評価する。 これで grid 点ごとに +-- N draws 分の μ サンプルが得られ、 その **事後平均** (線) と **94% HDI** (帯、 ArviZ 既定) +-- を描く。 これは PyMC の @pm.sample_posterior_predictive@ で得る epred (expected value of +-- the posterior predictive) に相当する (観測ノイズを含まない平均の不確実性)。 +-- +-- ★ O1 規約: epred 用モデルは予測子を @dataNamed predName@ で受け、 その平均を +-- @deterministic muName@ で 1 点スカラとして公開する (学習 likelihood とは併存)。 +-- grid 評価では @withData predName [xi]@ で 1 点に差し替えるため、 deterministic 内で +-- @head x@ を取れば @xi@ が読める。 +-- +-- ★ Phase 74: 多予測子の hold。 非軸の予測子 slot は、 既定では 'HoldAgg' に従って +-- bind データの集約値 ('Mean' 既定) で固定する (旧実装は bind データ先頭値 @head@ に +-- 固定で選択不能だった)。 頻度論 effect plot ('statModelMulti') と **同じ語彙**を共有: +-- * @epred fit "x1" "mu" \<\> holdAt Median@ … 非軸を中央値で固定 +-- * @epred fit "x1" "mu" \<\> holdAt (Fixed [("x2", 5)])@ … x2 のみ 5・他は Mean +-- * @epred fit "x1" "mu" \<\> byVar "x2" [0, 1]@ … x2 の水準別に曲線色分け重畳 +-- 'holdAt' / 'byVar' は 'Hanalyze.Plot.Core' の既存コンビネータ (= ModelSpec の +-- @msHoldAt@ / @msByVar@ を設定) をそのまま使う (epred 専用版は作らない)。 +-- +-- ★ 設計: 専用 newtype を作らず **'ModelSpec' を再利用**する (record は描画クロージャの +-- 容れ物で 'SingleVarModel' 束縛ではない)。 これにより @epred hbm "x" "mu" \<\> grid 200 +-- \<\> statLevel 0.9@ が Phase 16 C1 のコンビネータと同綴りで合成できる (既定 level 0.94 と +-- 帯 ON = ArviZ 流の HDI 帯を焼き込む。 epred の帯はオプトアウト不可)。 +-- =========================================================================== + +-- | [日本語]: 1 つの予測子値 @x@ における事後予測平均と HDI (非軸予測子は bind データのまま)。 +-- @predName@ を @[x]@ に差し替え、 全 chain の各 draw で deterministic @muName@ を +-- 評価し、 (事後平均, (lo, hi)) を返す。 非軸予測子を固定する版は 'epredAtHeld'。 +-- [English]: The posterior predictive mean and HDI at a single predictor +-- value @x@ (non-axis predictors stay at their bound data). Substitutes +-- @[x]@ for @predName@, evaluates the deterministic @muName@ node for +-- every draw across all chains, and returns (posterior mean, (lo, hi)). +-- The variant that also fixes non-axis predictors is 'epredAtHeld'. +epredAt + :: HBMModel + -> Text -- ^ [日本語]: 予測子の data 参照名 (@dataNamed@ / @withData@ の名前)。 [English]: The predictor's data reference name (the name used by @dataNamed@ \/ @withData@). + -> Text -- ^ [日本語]: 平均の deterministic ノード名。 [English]: The deterministic node name for the mean. + -> Double -- ^ [日本語]: HDI 水準 (例 0.94)。 [English]: The HDI level (e.g. 0.94). + -> Double -- ^ [日本語]: 予測子値 x。 [English]: The predictor value x. + -> (Double, (Double, Double)) +epredAt hbm = epredAtHeld hbm [] + +-- | [日本語]: (slot 名, 固定値) のリストを @withData@ で 1 点ずつ bind してネストする。 +-- 'ModelP' は impredicative (@forall a. Model a r@) ゆえ foldr では多相が逃げる。 +-- トップレベル再帰なら各 'withData' が @ModelP r -> ModelP r@ を保つので通る。 +-- [English]: Binds a list of (slot name, fixed value) pairs one at a time +-- via @withData@, nesting them. Since 'ModelP' is impredicative +-- (@forall a. Model a r@), @foldr@ would let the polymorphism escape; a +-- top-level recursion works because each @withData@ preserves +-- @ModelP r -> ModelP r@. +bindHolds :: [(Text, Double)] -> ModelP r -> ModelP r +bindHolds [] m = m +bindHolds ((nm, v) : rest) m = withData nm [v] (bindHolds rest m) + +-- | [日本語]: 'epredAt' の多予測子版。 @holds@ = 非軸予測子の (slot 名, 固定値) を 1 点ずつ +-- @withData@ で bind し ('head' でその値が読める)、 軸 @predName@ を @[gx]@ に差し替える。 +-- [English]: The multi-predictor variant of 'epredAt'. @holds@ = the +-- non-axis predictors' (slot name, fixed value) pairs, each bound via +-- @withData@ (readable with @head@), while the axis predictor @predName@ +-- is substituted with @[gx]@. +epredAtHeld + :: HBMModel + -> [(Text, Double)] -- ^ [日本語]: 非軸予測子の固定 (slot 名, 値)。 [English]: The fixed (slot name, value) pairs for non-axis predictors. + -> Text -> Text -> Double -> Double + -> (Double, (Double, Double)) +epredAtHeld hbm holds predName muName level gx = + let bound :: ModelP () + bound = withData predName [gx] (bindHolds holds (hbmModelSpec hbm)) + draws = concatMap chainSamples (hbmChainsR hbm) + mus = [ v | ps <- draws + , Just v <- [Map.lookup muName (runDeterministics bound ps)] ] + mean = if null mus then 0 else sum mus / fromIntegral (length mus) + in (mean, highestDensityInterval level mus) + +-- | [日本語]: grid 点 @gx@ における事後予測区間 (PI = 観測ノイズ込みの新規 1 点の HDI)。 +-- 'epredAtHeld' が deterministic μ の HDI (= CI 相当) を返すのに対し、 こちらは +-- __観測ノードの予測分布から y をサンプルしてプール__し HDI を取る。 観測ノード名は +-- 引数に取らず 'runObserveDists' でモデルから自動検出する (頻度論 @svGridPI@ が obs 名を +-- 要らないのと対称)。 単一 likelihood の通常ケースが対象で、 observe が複数なら全プール。 +-- 任意の観測分布 (Normal/Poisson/NegBinom…) に効く (@ppc@ の @sampleDist@ を再利用)。 +-- @runST@ + 固定 seed (既定 'epredPISeed' = 42・'ppcOfWith' と同方式) で純粋・決定的。 +-- [English]: The posterior predictive interval at grid point @gx@ +-- (PI = the HDI of a new single point, including observation noise). +-- Where 'epredAtHeld' returns the HDI of the deterministic μ (equivalent +-- to a CI), this one __samples y from the observation node's predictive distribution and pools it__ +-- before taking the HDI. It doesn't take the +-- observation node name as an argument; it auto-detects it from the model +-- via 'runObserveDists' (symmetric with how the frequentist @svGridPI@ +-- doesn't need an obs name either). It targets the usual single-likelihood +-- case; with multiple observe nodes, everything is pooled. It works with +-- any observation distribution (Normal\/Poisson\/NegBinom…) by reusing +-- @ppc@'s @sampleDist@. It stays pure and deterministic via @runST@ + a +-- fixed seed (default 'epredPISeed' = 42, the same scheme as +-- 'ppcOfWith'). +epredPIAtHeld + :: HBMModel + -> [(Text, Double)] -- ^ [日本語]: 非軸予測子の固定 (slot 名, 値)。 [English]: The fixed (slot name, value) pairs for non-axis predictors. + -> Text -- ^ [日本語]: 軸予測子の data 参照名。 [English]: The axis predictor's data reference name. + -> Word32 -- ^ [日本語]: サンプリング seed。 [English]: The sampling seed. + -> Double -- ^ [日本語]: HDI 水準。 [English]: The HDI level. + -> Double -- ^ [日本語]: 予測子値 x。 [English]: The predictor value x. + -> (Double, Double) +epredPIAtHeld hbm holds predName seed level gx = + let bound :: ModelP () + bound = withData predName [gx] (bindHolds holds (hbmModelSpec hbm)) + draws = concatMap chainSamples (hbmChainsR hbm) + samples = runST $ do + gen <- initialize (V.singleton seed) + concat <$> mapM + (\ps -> + let nodes = [ (d, ys) | (_, d, ys) <- runObserveDists bound ps ] + in concat <$> mapM (\(d, ys) -> sampleObsRep gen d ys) nodes) + draws + in if null samples then (0, 0) else highestDensityInterval level samples + +-- | [日本語]: @epredPIAtHeld@ の既定サンプリング seed (純粋・決定的に閉じる。 'ppcOfWith' と同値)。 +-- [English]: The default sampling seed for @epredPIAtHeld@ (keeps it pure +-- and deterministic; the same value as 'ppcOfWith'). +epredPISeed :: Word32 +epredPISeed = 42 + +-- | [日本語]: 非軸予測子 1 slot の固定値を 'HoldAgg' (+ byVar override) から決める。 +-- @override@ (byVar の明示固定) が 'HoldAgg' より優先。 HBM データは数値列ゆえ +-- factor / Reference は無く、 Reference\/Marginalize は安全側に Mean とする +-- (Marginalize の真の周辺化は epred では未対応)。 +-- [English]: Determines a single non-axis predictor slot's fixed value +-- from 'HoldAgg' (plus a byVar override). @override@ (an explicit byVar +-- fixed value) takes priority over 'HoldAgg'. Since HBM data is numeric +-- columns, there is no factor \/ Reference notion, so Reference \/ +-- Marginalize safely fall back to Mean (true marginalization for +-- Marginalize is not yet supported in epred). +epredHoldValue :: HoldAgg -> Text -> [Double] -> [(Text, Double)] -> Double +epredHoldValue hold nm vs override = + case lookup nm override of + Just v -> v + Nothing -> case hold of + Mean -> meanL vs + Median -> medianL vs + Mode -> medianL vs -- 数値連続に最頻は無意味 → 中央値で代替 + Reference -> meanL vs + Marginalize -> meanL vs + Fixed fm -> fromMaybe (meanL vs) (lookup nm fm) + where + meanL xs = if null xs then 0 else sum xs / fromIntegral (length xs) + medianL xs = case xs of + [] -> 0 + _ -> let s = sortBy compare xs + k = length s + in if even k + then (s !! (k `div` 2 - 1) + s !! (k `div` 2)) / 2 + else s !! (k `div` 2) + +-- | [日本語]: grid 上の事後予測平均線 + HDI 帯を組む 'GridOpts' クロージャ (@epred@ が設定)。 +-- 'renderGridMulti' (頻度論 effect plot) と同型: 非軸予測子を 'goHoldAt' で固定し、 +-- 'goByVar' があれば第2予測子の水準ごとに曲線を色分け重畳する。 各曲線は帯 (先) + +-- 線 (後)。 'goPredAt' 指定点は lineRange (区間) + scatter (事後平均) で重畳する。 +-- 帯は非対称な HDI を lo/hi で忠実に描く。 +-- [English]: The 'GridOpts' closure that builds the posterior predictive +-- mean line + HDI band on the grid (set up by @epred@). Shaped the same +-- as 'renderGridMulti' (the frequentist effect plot): non-axis predictors +-- are fixed via 'goHoldAt', and if 'goByVar' is present, a distinctly +-- colored curve is overlaid per level of the second predictor. Each curve +-- draws its band first, then its line. Points given via 'goPredAt' are +-- overlaid with a @lineRange@ (interval) + @scatter@ (posterior mean). +-- The band faithfully draws the asymmetric HDI using lo\/hi. +renderEpred :: HBMModel -> Text -> Text -> GridOpts -> VisualSpec +renderEpred hbm predName muName opts = + let (lo0, hi0) = epredPredRange hbm predName + (lo, hi) = fromMaybe (lo0, hi0) (goRange opts) + n = max 2 (goN opts) + gxs = linspace lo hi n + level = goLevel opts + hold = goHoldAt opts + -- 非軸予測子 (= hbmData の predName 以外の slot) を HoldAgg + byVar override で固定。 + -- 応答列も含むが deterministic μ は応答に依存しないため無害。 + holdBinds override = + [ (nm, epredHoldValue hold nm vs override) + | (nm, vs) <- hbmData hbm, nm /= predName ] + -- 1 曲線分 (override = byVar 固定の (名,値)、 mCol = 線/帯色)。 + -- BandMode で CI (μ HDI) / PI (観測ノイズ込み) / CIPI (入れ子) / なし を切替 + -- (頻度論 'renderGrid' と同型)。 PI 系は遅延ゆえ CI/Off では評価されない。 + oneCurve override mCol = + let holds = holdBinds override + rows = map (epredAtHeld hbm holds predName muName level) gxs + mu = map fst rows + ciLos = map (fst . snd) rows + ciHis = map (snd . snd) rows + piPairs = map (epredPIAtHeld hbm holds predName epredPISeed level) gxs + piLos = map fst piPairs + piHis = map snd piPairs + lineL = layer (goLineDeco opts mCol n (line (inline gxs) (inline mu))) + ciDeco = goBandDeco opts mCol + -- 入れ子時の PI 帯は薄め (CI が内側で見えるように・頻度論と同じ既定)。 + piA = maybe 0.10 (* 0.5) (goAlpha opts) + piDeco = goBandDeco (opts { goAlpha = Just piA }) mCol + mkBand deco los his = layer (deco (band (inline gxs) (inline los) (inline his))) + in case goBandMode opts of + BandOff -> lineL + BandCI -> mkBand ciDeco ciLos ciHis <> lineL + BandPI -> mkBand ciDeco piLos piHis <> lineL + BandCIPI -> mkBand piDeco piLos piHis -- 外: PI 薄 (下) + <> mkBand ciDeco ciLos ciHis -- 内: CI 濃 (上) + <> lineL + curves = case goByVar opts of + Nothing -> oneCurve [] Nothing + Just (v2, vals) -> + foldMap + (\(i, val) -> + let col = fromHex (effectPalette !! (i `mod` length effectPalette)) + in oneCurve [(v2, val)] (Just col)) + (zip [0 :: Int ..] vals) + pts = goPredAt opts + predLayers + | null pts = mempty + | otherwise = + let prows = map (epredAtHeld hbm (holdBinds []) predName muName level) pts + pmu = map fst prows + mids = map (\(_, (l, h)) -> (l + h) / 2) prows + halfs = map (\(_, (l, h)) -> (h - l) / 2) prows + in layer (lineRange (inline pts) (inline mids) (inline halfs)) + <> layer (scatter (inline pts) (inline pmu)) + in curves <> predLayers <> labelLegend opts + +-- | [日本語]: 予測子列の観測範囲 (grid 既定範囲)。 bind 済みデータ ('hbmData') から引く。 +-- [English]: The predictor column's observed range (the default grid +-- range). Looked up from the bound data ('hbmData'). +epredPredRange :: HBMModel -> Text -> (Double, Double) +epredPredRange hbm predName = + case lookup predName (hbmData hbm) of + Just vs | not (null vs) -> (minimum vs, maximum vs) + _ -> (0, 1) + +-- | [日本語]: HBM の事後予測平均 (E[y|x]) を grid 評価する 'ModelSpec' を作る。 既定は 94% HDI 帯 +-- (ArviZ 流・帯 ON 焼き込み)、 grid 100 点、 範囲 = 予測子の観測 min/max。 @\<\>@ で +-- 'grid' / 'gridRange' / 'statLevel' / 'predAt' を合成できる (既存コンビネータと同じ綴り)。 +-- +-- @ +-- noDf |>> toPlot (epred fit \"x\" \"mu\" \<\> grid 200 \<\> statLevel 0.9) +-- @ +-- [English]: Builds a 'ModelSpec' that grid-evaluates the HBM's posterior +-- predictive mean (E[y|x]). Defaults to a 94% HDI band (ArviZ-style, band +-- baked on by default), a grid of 100 points, and a range spanning the +-- predictor's observed min\/max. Composable via @\<\>@ with 'grid' \/ +-- 'gridRange' \/ 'statLevel' \/ 'predAt' (using the same spelling as the +-- existing combinators). +-- +-- @ +-- noDf |>> toPlot (epred fit \"x\" \"mu\" \<\> grid 200 \<\> statLevel 0.9) +-- @ +epred + :: HBMModel + -> Text -- ^ [日本語]: 予測子の data 参照名。 [English]: The predictor's data reference name. + -> Text -- ^ [日本語]: 平均の deterministic ノード名。 [English]: The deterministic node name for the mean. + -> ModelSpec +epred hbm predName muName = mempty + { msRender = Just (renderEpred hbm predName muName) + , msLevel = Just 0.94 -- ArviZ 既定の 94% HDI (statLevel で上書き可) + , msBandMode = Just BandCI -- HDI 帯が epred の本体ゆえ既定で出す + } + +-- =========================================================================== +-- HBM の事後予測チェック — Phase 49 A4 (ppc = posterior predictive check) +-- +-- 観測 y の分布に対して、 学習済モデルが再現する複製データ y_rep の分布を重ねる +-- (ArviZ @az.plot_ppc@ 相当)。 各 posterior draw について 'runObserveDists' で +-- observe ノードの分布 (= 観測ノイズ込みの予測分布) を取り出し、 @sampleDist@ で +-- 1 セット y_rep をサンプリングする。 これを N draw 分重ねると「観測がモデルの予測 +-- 分布の典型から外れていないか」 を目視できる。 +-- +-- 描画 (ArviZ 流): +-- * 観測 density (濃色・実線) … 実データ。 +-- * y_rep density を N 本 (薄色・低 alpha) … 各 draw の複製データ。 +-- * プール y_rep density (破線) … 事後予測分布全体 (= ppc の中心)。 +-- +-- ★ サンプリングに RNG が要るため 'IO' (頻度論 toPlot や epred/forest と違い純粋に +-- できない)。 'hbmModel' 自体 IO なので非対称ではない。 cumulative 版は density を +-- 'ecdf' に差し替える ('ppcCumulative')。 +-- =========================================================================== + +-- | [日本語]: ppc の設定: 重ねる複製データ本数 ('ppcReps')、 乱数シード、 累積版 (ecdf) 切替。 +-- [English]: The ppc settings: the number of overlaid replicated datasets +-- ('ppcReps'), the RNG seed, and whether to switch to the cumulative +-- (ecdf) variant. +data PPCConfig = PPCConfig + { ppcReps :: !Int -- ^ [日本語]: 重ねる y_rep 本数 (既定 40・draw から等間隔抽出)。 [English]: The number of overlaid y_rep replicates (default 40, evenly sampled from the draws). + , ppcSeed :: !(Maybe Word32) -- ^ [日本語]: サンプリングのシード (Nothing = system)。 [English]: The sampling seed (Nothing = system RNG). + , ppcCumulative :: !Bool -- ^ [日本語]: True で density を ecdf (累積分布) に差し替える。 [English]: True switches the density to an ecdf (cumulative distribution). + } deriving (Show, Eq) + +-- | [日本語]: 既定 ppc 設定: y_rep 40 本・system 乱数・density 表示。 +-- [English]: The default ppc settings: 40 y_rep replicates, the system +-- RNG, and density display. +defaultPPC :: PPCConfig +defaultPPC = PPCConfig { ppcReps = 40, ppcSeed = Nothing, ppcCumulative = False } + +-- | [日本語]: 事後予測チェック plot の描画仕様 ('forestOf' 等と同型の薄い newtype)。 +-- [English]: The plotting spec for a posterior predictive check (a thin +-- newtype shaped like 'forestOf' and friends). +newtype PPCSpec = PPCSpec { unPPCSpec :: VisualSpec } + +instance Plottable PPCSpec where + toPlot = unPPCSpec + +-- | [日本語]: observe ノード名が prefix に一致するか。 単一 @observe \"obs\"@ (n == prefix) と +-- @observeColumns@ 由来の @\"obs_0\"@.. (prefix <> \"_\" が接頭辞) の両方を拾う。 +-- [English]: Whether an observe node name matches the prefix. Matches +-- both a single @observe \"obs\"@ (n == prefix) and @observeColumns@-style +-- names like @\"obs_0\"@.. (where @prefix <> \"_\"@ is a prefix). +ppcMatches :: Text -> Text -> Bool +ppcMatches prefix n = n == prefix || (prefix <> "_") `T.isPrefixOf` n + +-- | [日本語]: 1 draw 分の複製データ y_rep をサンプリングする。 prefix 一致の各 observe ノードの +-- 分布から、 観測値と同数だけ引いてプールする。 'PrimMonad' に一般化してあるため +-- IO でも ST でも引ける (→ 純粋な 'ppcOf' が runST で決定的にサンプリングできる)。 +-- [English]: Samples one draw's worth of replicated data y_rep. Draws the +-- same count as the observed values from each prefix-matching observe +-- node's distribution, and pools them. Generalized over 'PrimMonad', so it +-- can be run in either IO or ST (which lets the pure 'ppcOf' sample +-- deterministically via @runST@). +sampleYRep :: PrimMonad m + => Gen (PrimState m) -> ModelP () -> Text -> Map.Map Text Double -> m [Double] +sampleYRep gen spec prefix ps = + let nodes = [ (d, ys) | (n, d, ys) <- runObserveDists spec ps, ppcMatches prefix n ] + in concat <$> mapM (\(d, ys) -> sampleObsRep gen d ys) nodes + +-- | [日本語]: 観測値 (prefix 一致 observe ノードの ys をプール)。 params に依らないので任意 draw から。 +-- [English]: The observed values (pooling the ys of prefix-matching +-- observe nodes). Independent of the params, so any draw can be used. +ppcObserved :: HBMModel -> Text -> [Double] +ppcObserved hbm prefix = + case concatMap chainSamples (hbmChainsR hbm) of + (p0:_) -> concat [ ys | (n, _, ys) <- runObserveDists (hbmModelSpec hbm) p0 + , ppcMatches prefix n ] + [] -> [] + +-- | [日本語]: ppc の対象 draw 群 ('ppcReps' 本に間引き)。 +-- [English]: The draws targeted for ppc (thinned down to 'ppcReps' +-- replicates). +ppcDrawsFor :: PPCConfig -> HBMModel -> [Map.Map Text Double] +ppcDrawsFor cfg hbm = selectEvenly (ppcReps cfg) (concatMap chainSamples (hbmChainsR hbm)) + +-- | [日本語]: 観測値・y_rep 群から ppc plot を組む (純粋)。 薄い y_rep 群 (背景・各 draw) を先に、 +-- 観測 (濃) を上に重ねる。 純粋 'ppcOfWith' と IO 'ppcOfWithIO' で共有。 +-- +-- ★ 旧実装はプール y_rep (全 draw 連結) の密度を赤破線で重ねていたが、 KDE の Silverman +-- バンド幅が __n 依存__ (@h ∝ n^(-0.2)@) ゆえ、 n=Σ(draw×n_obs) のプールは観測 (n=n_obs) より +-- バンド幅が小さく過小平滑になり、 観測と異なる形 (外側へ膨らむ) に見えて誤解を招いた。 +-- 比較は観測 (黒) vs 各 draw の y_rep (青・同じ n) で行うべきなので、 プール線は削除した +-- (ArviZ @plot_ppc@ もプール KDE は描かない)。 +-- [English]: Builds the ppc plot from the observed values and the y_rep +-- replicates (pure). Draws the faint y_rep replicates (background, one per +-- draw) first, then overlays the observed (dark) on top. Shared between +-- the pure 'ppcOfWith' and the IO 'ppcOfWithIO'. +-- +-- ★ The former implementation overlaid a red dashed density of the pooled +-- y_rep (all draws concatenated), but since the KDE's Silverman bandwidth +-- is __n-dependent__ (@h ∝ n^(-0.2)@), the pool (n=Σ(draw×n_obs)) has a +-- smaller bandwidth than the observed (n=n_obs), under-smoothing it into a +-- shape that looked different from the observed (bulging outward) and was +-- misleading. Since the comparison should be observed (black) vs. each +-- draw's y_rep (blue, same n), the pooled line was removed (ArviZ's +-- @plot_ppc@ doesn't draw a pooled KDE either). +buildPPCSpec :: PPCConfig -> [Double] -> [[Double]] -> PPCSpec +buildPPCSpec cfg observed yreps = + let densLayer = if ppcCumulative cfg then ecdf else density + repLayers = foldMap + (\yr -> layer (densLayer (inline yr) <> color (fromHex "#1f77b4") <> alpha 0.15)) + yreps + obsLayer = layer (densLayer (inline observed) <> color (fromHex "#000000")) + in PPCSpec (repLayers <> obsLayer) + +-- | [日本語]: draw 列から 'ppcReps' 本を等間隔で抽出する (本数以下ならそのまま)。 +-- [English]: Extracts 'ppcReps' replicates evenly spaced from the draw +-- list (returns the input as-is if it already has fewer). +selectEvenly :: Int -> [a] -> [a] +selectEvenly k xs + | k <= 0 || n <= k = xs + | otherwise = [ xs !! (i * n `div` k) | i <- [0 .. k - 1] ] + where n = length xs + +-- | [日本語]: 既定設定の事後予測チェック (純粋・決定的が__正本__。 'ppcOfWith' 'defaultPPC')。 +-- y_rep サンプリングを @runST@ で閉じ、 @ppcSeed@ 既定 (42) で常に再現可能。 IO 版は 'ppcOfIO'。 +-- [English]: The posterior predictive check with default settings (the +-- pure, deterministic version is __canonical__; 'ppcOfWith' 'defaultPPC'). +-- Closes the y_rep sampling over @runST@, always reproducible via the +-- default @ppcSeed@ (42). The IO variant is 'ppcOfIO'. +ppcOf :: HBMModel -> Text -> PPCSpec +ppcOf = ppcOfWith defaultPPC + +-- | [日本語]: 事後予測チェックを組む (純粋・正本)。 @prefix@ は observe ノード名 (@observeColumns@ なら接頭辞)。 +-- y_rep サンプリングを @runST@ で閉じる。 @ppcSeed@ が 'Nothing' のときは固定既定 seed (42) で再現可能。 +-- [English]: Builds the posterior predictive check (pure, canonical). +-- @prefix@ is the observe node name (or the prefix, for +-- @observeColumns@). Closes the y_rep sampling over @runST@. When +-- @ppcSeed@ is 'Nothing', a fixed default seed (42) keeps it reproducible. +ppcOfWith :: PPCConfig -> HBMModel -> Text -> PPCSpec +ppcOfWith cfg hbm prefix = + let spec :: ModelP () + spec = hbmModelSpec hbm + draws = ppcDrawsFor cfg hbm + seed = fromMaybe 42 (ppcSeed cfg) + yreps = runST $ do + gen <- initialize (V.singleton seed) + mapM (sampleYRep gen spec prefix) draws + in buildPPCSpec cfg (ppcObserved hbm prefix) yreps + +-- | [日本語]: 既定設定の事後予測チェック (IO 版・'ppcOfWithIO' 'defaultPPC')。 通常は純粋な 'ppcOf' を使う +-- (将来 deprecate 予定)。 @ppcSeed@ 'Nothing' でシステム乱数を引きたいときだけ IO 版が要る。 +-- [English]: The posterior predictive check with default settings (IO +-- variant; 'ppcOfWithIO' 'defaultPPC'). Normally use the pure 'ppcOf' +-- instead (this is slated for future deprecation). The IO variant is only +-- needed when you want to draw the system RNG with @ppcSeed@ 'Nothing'. +ppcOfIO :: HBMModel -> Text -> IO PPCSpec +ppcOfIO = ppcOfWithIO defaultPPC + +-- | [日本語]: 事後予測チェックを組む (IO 版)。 @ppcSeed@ 'Nothing' で 'createSystemRandom' を引く。 +-- [English]: Builds the posterior predictive check (IO variant). Draws +-- 'createSystemRandom' when @ppcSeed@ is 'Nothing'. +ppcOfWithIO :: PPCConfig -> HBMModel -> Text -> IO PPCSpec +ppcOfWithIO cfg hbm prefix = do + let spec :: ModelP () + spec = hbmModelSpec hbm + draws = ppcDrawsFor cfg hbm + gen <- case ppcSeed cfg of + Nothing -> createSystemRandom + Just w -> initialize (V.singleton w) + yreps <- mapM (sampleYRep gen spec prefix) draws + pure $ buildPPCSpec cfg (ppcObserved hbm prefix) yreps + +-- =========================================================================== +-- HBM 診断ダッシュボード — 複数の抽出子を 1 枚に束ねる便宜関数 (Phase 74.8) +-- +-- 個別の抽出子 (dagOf / forestOf / ppcOf / energyOf / tracesOf / marginalsOf) を +-- 'subplots' で並べ「構造・推定・当てはまり・収束を一目で点検する」 パネル束にする。 2 種: +-- * 'dashboardOf' … コンパクト 2×2 (構造 / 推定値 / 当てはまり / サンプラ健全性)。 +-- 各 1 パネルゆえ param 数に依らず一定で見やすい。 +-- * 'dashboardFullOf' … 上段に同じ 2×2、 その下に param ごと [事後分布 | trace] を 2 列で +-- 連結 (ArviZ @plot_trace@ 流)。 係数が増えると下へ行が増えるだけ。 +-- どちらも observe ノード名を引数に取る (ppc 用)。 @noDf |>> dashboardOf m "obs"@。 +-- autocorr/rank はダッシュボードに入れない (mixing は trace・BFMI は energy で見えるため。 +-- ESS 定量は個別 'autocorrOf'、 chain 一様性は 'rankOf' で見る)。 +-- =========================================================================== + +-- | [日本語]: コンパクト健全性 2×2 のパネル群 (左上から 構造 / 推定値 / 当てはまり / サンプラ健全性)。 +-- 'dashboardOf' (単体) と 'dashboardFullOf' (上段) で共有する内部ヘルパ。 +-- [English]: The compact 2×2 health-panel group (from top-left: structure +-- \/ estimates \/ fit \/ sampler health). An internal helper shared by +-- 'dashboardOf' (standalone) and 'dashboardFullOf' (its top section). +dashboardHealthPanels :: HBMModel -> Text -> [VisualSpec] +dashboardHealthPanels hbm obsName = + [ toPlot (dagOf hbm) <> title "構造 (DAG)" + , toPlot (forestOf hbm) <> title "推定値 (forest 94% HDI)" + , toPlot (ppcOf hbm obsName) <> title "当てはまり (PPC: 観測 vs 事後予測)" + , energyOf hbm <> title "サンプラ健全性 (energy / BFMI)" ] + +-- | [日本語]: コンパクトな HBM 診断ダッシュボード (2×2)。 __構造__ (@dagOf@・左上)・__推定値__ +-- ('forestOf'・94% HDI)・__当てはまり__ ('ppcOf'・観測 vs 事後予測の密度重ね)・ +-- __サンプラ健全性__ ('energyOf'・BFMI) を 1 パネルずつ。 各 1 パネルゆえ param 数に依らず見やすい +-- (係数が増えても forest が縦に密になるだけ。 収束 R̂/trace は 'dashboardFullOf' で見る)。 +-- [English]: A compact HBM diagnostic dashboard (2×2). One panel each for +-- __structure__ (@dagOf@, top-left), __estimates__ ('forestOf', 94% HDI), +-- __fit__ ('ppcOf', observed vs. posterior predictive density overlay), +-- and __sampler health__ ('energyOf', BFMI). Since it's one panel each, it +-- stays readable regardless of the parameter count (more coefficients +-- just make the forest more densely packed vertically; check convergence +-- R̂ \/ trace via 'dashboardFullOf' instead). +dashboardOf :: HBMModel -> Text -> VisualSpec +dashboardOf hbm obsName = + subplots (dashboardHealthPanels hbm obsName) + <> subplotCols 2 <> width 1100 <> height 760 + +-- | [日本語]: param ごと __[事後分布 (左) | trace (右)]__ のパネル群 (ArviZ @plot_trace@ の中身)。 +-- 'traceDensityOf' (単体) と 'dashboardFullOf' (下段) で共有する内部ヘルパ。 事後分布・ +-- trace とも chain 別を色違いで重畳する ('marginalsByChainOf' / 'tracesOfWith' byChain)。 +-- [English]: A per-param panel group of __[posterior (left) | trace (right)]__ +-- (the content of ArviZ's @plot_trace@). An internal helper +-- shared by 'traceDensityOf' (standalone) and 'dashboardFullOf' (its +-- bottom section). Both the posterior and the trace overlay each chain in +-- a distinct color ('marginalsByChainOf' \/ 'tracesOfWith' with +-- @byChain@). +tracePostPanels :: HBMModel -> [VisualSpec] +tracePostPanels hbm = + concat (zipWith (\p t -> [p, t]) + (marginalsByChainOf hbm) + (tracesOfWith defaultTraceOpts { toByChain = True } hbm)) + +-- | [日本語]: trace と事後分布だけのダッシュボード (= ArviZ @plot_trace@ 相当)。 param ごとに +-- __[事後分布 (左) | trace (右)]__ を 2 列で並べる (chain は色違いで重畳)。 収束 (定常・ +-- chain 一致) と事後の形を同時に確認する定番。 係数が増えると下に行が増える。 +-- [English]: A dashboard of just the trace and posterior (= equivalent to +-- ArviZ's @plot_trace@). Lays out __[posterior (left) | trace (right)]__ +-- in two columns per param (chains overlaid in distinct colors). The +-- standard way to check convergence (stationarity, chain agreement) and +-- the posterior's shape at the same time. More coefficients add more +-- rows below. +traceDensityOf :: HBMModel -> VisualSpec +traceDensityOf hbm = + let np = max 1 (length (hbmParamNames hbm)) + in subplots (tracePostPanels hbm) + <> subplotCols 2 <> width 900 <> height (180 * fromIntegral np) + +-- | [日本語]: フルの HBM 診断ダッシュボード。 上段に 'dashboardOf' と同じ健全性 2×2、 その下に +-- param ごと __[事後分布 (左) | trace (右)]__ を 2 列で連結する (ArviZ @plot_trace@ 流・ +-- chain は色違いで重畳)。 全体が 1 つの 2 列グリッドなので、 +-- __係数が増えると下に行が増えるだけ__ (高さを行数 = 2 + param 数 に比例させ各パネルを潰さない)。 epred (予測曲線) +-- はモデル固有の予測子/平均ノード名と df が要るためここには含めない (個別に描く)。 +-- [English]: The full HBM diagnostic dashboard. The top section is the +-- same 2×2 health group as 'dashboardOf'; below it, __[posterior (left) | trace (right)]__ +-- is appended per param in two columns (ArviZ +-- @plot_trace@-style, chains overlaid in distinct colors). Since the +-- whole thing is one 2-column grid, __adding coefficients only adds more rows below__ +-- (the height scales with the row count = 2 + the number of +-- params, so no panel gets squashed). epred (the prediction curve) isn't +-- included here, since it needs a model-specific predictor \/ mean node +-- name and a df (draw it separately instead). +dashboardFullOf :: HBMModel -> Text -> VisualSpec +dashboardFullOf hbm obsName = + let np = max 1 (length (hbmParamNames hbm)) + rows = 2 + np -- 健全性 2 行 + param 行 + in subplots (dashboardHealthPanels hbm obsName ++ tracePostPanels hbm) + <> subplotCols 2 <> width 1100 <> height (220 * fromIntegral rows) + +-- =========================================================================== +-- HBM のモデル構造 DAG — Phase 49 A5 (dag = 確率プログラムの依存グラフ) +-- +-- 確率プログラム ('ModelP') の依存構造を @buildModelGraph@ (= @extractDeps@ + +-- 同名ノード統合) で 'ModelGraph' (nodes / edges / plates) にし、 plot-core の +-- DAG 描画 ('dagFromListsWithPlates'、 Sugiyama 階層 layout) に橋渡しする。 PyMC の +-- @pm.model_to_graphviz@ に相当する「モデルの絵」。 +-- +-- ノード種 (latent / observed) と分布名は 'Node' のメタデータをそのまま 'DAGNode' に +-- 写す。 plate ('plate' で囲んだ繰り返し) は 'mgPlates' を 'DAGPlate' に変換する +-- (plate メンバは 'nodePlates' から逆引き)。 plate を使わないモデルでは +-- @observeColumns@ 由来の @obs_0..@ が個別ノードとして出る (collapse したい場合は +-- モデル側を 'plate' で囲む)。 +-- =========================================================================== + +-- | [日本語]: モデル構造 DAG の描画仕様 ('forestOf' 等と同型の薄い newtype)。 +-- [English]: The plotting spec for a model-structure DAG (a thin newtype +-- shaped like 'forestOf' and friends). +newtype DagSpec = DagSpec { unDagSpec :: VisualSpec } + +instance Plottable DagSpec where + toPlot = unDagSpec + +-- | [日本語]: 学習済モデルの構造を DAG にする (@buildModelGraph@ → plate-collapse → +-- plot-core DAG)。 layout は階層 ('LayoutHierarchical')。 学習結果には依存しない +-- (構造のみ)。 plate 内の indexed RV (@b0_0..b0_2@ 等) を +-- 'collapseIndexedPlateNodes' で 1 ノードに畳むのが既定 (PyMC +-- @model_to_graphviz@ と同じ見た目)。 indexed 個別ノードのまま見たい場合は +-- 'dagOfRaw'。 +-- [English]: Turns a trained model's structure into a DAG +-- (@buildModelGraph@ → plate-collapse → plot-core DAG). The layout is +-- hierarchical ('LayoutHierarchical'). Independent of the training result +-- (structure only). By default, indexed RVs inside a plate (e.g. +-- @b0_0..b0_2@) are collapsed into a single node via +-- 'collapseIndexedPlateNodes' (matching PyMC's @model_to_graphviz@ look). +-- Use 'dagOfRaw' to see the indexed nodes individually instead. +dagOf :: HBMModel -> DagSpec +dagOf = dagFromModelGraph . collapseIndexedPlateNodes . buildModelGraph . hbmModelSpec + +-- | [日本語]: @dagOf@ の plate-collapse 無し版 (かつての旧既定。 plate 内 indexed RV を +-- 個別ノードで列挙する。 展開後の全ノード/エッジを確認するデバッグ用)。 +-- [English]: The plate-collapse-free variant of @dagOf@ (the former +-- default; enumerates plate-internal indexed RVs as individual nodes). +-- Useful for debugging by inspecting all expanded nodes \/ edges. +dagOfRaw :: HBMModel -> DagSpec +dagOfRaw = dagFromModelGraph . buildModelGraph . hbmModelSpec + +-- | [日本語]: __学習前__にモデル構造だけを DAG にする (PyMC @pm.model_to_graphviz@ 相当)。 +-- @dagOf@ が学習済 'HBMModel' を取るのに対し、 こちらは生の 'ModelP' を直接取り +-- __サンプリングを一切しない__ (構造は事後に依らないため)。 @noDf |>> toPlot (dagOfModel m)@。 +-- +-- ★ 注意: データ駆動 plate (@plateForM_@ / @observeColumns@ で plate サイズを __データ長__から +-- 決めるモデル) は、 データ未束縛 (slot が @[]@) だとループ本体が回らず plate 内ノード +-- (mu / obs 等) が出ない。 その場合は 'dagOfModelWith' でダミーでないデータを束ねてから描く +-- (サンプリングは走らない)。 明示 plate (@plate name N@ / @plateI@ で N を直書き) のモデルは +-- データ無しでも構造が完全に出る。 +-- [English]: Turns just the model structure into a DAG __before training__ +-- (equivalent to PyMC's @pm.model_to_graphviz@). Where @dagOf@ +-- takes a trained 'HBMModel', this one takes a raw 'ModelP' directly and +-- __never samples__ (structure doesn't depend on the posterior). +-- @noDf |>> toPlot (dagOfModel m)@. +-- +-- ★ Caution: for data-driven plates (models where @plateForM_@ \/ +-- @observeColumns@ determine the plate size from the __data length__), +-- leaving the data unbound (an empty @[]@ slot) means the loop body never +-- runs, so plate-internal nodes (mu \/ obs etc.) won't appear. In that +-- case, bind non-dummy data first with 'dagOfModelWith' before drawing +-- (still no sampling runs). Models with explicit plates (@plate name N@ \/ +-- @plateI@ hard-coding N) show the full structure even without data. +dagOfModel :: ModelP () -> DagSpec +dagOfModel = dagFromModelGraph . collapseIndexedPlateNodes . buildModelGraph + +-- | [日本語]: 'dagOfModel' のデータ束ね版 (PyMC で観測を渡してから @model_to_graphviz@ する形)。 +-- @dat@ を 'bindCols' でモデルへ束ねてから DAG を組む = +-- __データ駆動 plate のサイズが正しく出る__。 'hbmModel' と同じ束ね方だが __NUTS は走らない__ (学習前のプレビュー)。 +-- @noDf |>> toPlot (dagOfModelWith [("x", xs), ("y", ys)] m)@。 +-- [English]: The data-bound variant of 'dagOfModel' (like passing +-- observations to PyMC before calling @model_to_graphviz@). Binds @dat@ +-- to the model via 'bindCols' before building the DAG, so +-- __data-driven plate sizes come out correctly__. Binds the same way as 'hbmModel', but +-- __NUTS never runs__ (it's a pre-training preview). +-- @noDf |>> toPlot (dagOfModelWith [("x", xs), ("y", ys)] m)@. +dagOfModelWith :: [(Text, [Double])] -> ModelP () -> DagSpec +dagOfModelWith dat = dagOfModel . bindCols dat + +-- | [日本語]: 'ModelGraph' → plot-core DAG 描画仕様 (@dagOf@ / 'dagOfRaw' の共通部)。 +-- [English]: 'ModelGraph' → plot-core DAG plotting spec (the shared part +-- of @dagOf@ \/ 'dagOfRaw'). +dagFromModelGraph :: ModelGraph -> DagSpec +dagFromModelGraph mg = + -- ★ renderDAG は dnX/dnY をそのまま使い layout を実行しない。 ゆえに描画前に + -- Sugiyama 階層 layout ('layoutHierarchicalFullWithPlates') で座標を確定させる + -- (これを省くと全ノードが原点 (0,0) に重なる)。 + let (positioned, routed) = layoutHierarchicalFullWithPlates dnodes dedges dplates + -- ★ HS=PS parity: routing を spec へ焼き込む (= 'deRoute' 充填)。 これが無いと PS canvas + -- は 'deRoute = Nothing' で直線フォールバックになり、 HS の live routing (曲線) と乖離する。 + -- baking は area 非依存 (dagToScreen が 0..1 domain を正規化 pt 空間へ map・描画時に + -- fitPrimsToArea で affine fit) なので layout 直後のここで焼ける。 + in DagSpec $ bakeDAGRoutesInSpec $ + layer (dagFromListsWithPlates positioned routed LayoutHierarchical dplates) + where + ns = mgNodes mg + dnodes = map toDNode ns + dedges = [ DAGEdge { deFrom = p, deTo = c, dePath = Nothing, deRoute = Nothing } + | (p, c) <- mgEdges mg ] + dplates = [ DAGPlate + { dpLabel = nm <> " (" <> T.pack (show sz) <> ")" + , dpNodeIds = [ nodeName n | n <- ns, nm `elem` nodePlates n ] } + | (nm, sz) <- Map.toList (mgPlates mg) ] + toDNode n = DAGNode + { dnId = nodeName n + , dnLabel = nodeName n + , dnKind = case nodeKind n of + LatentN -> NodeLatent + ObservedN _ -> NodeObserved + DeterministicN -> NodeDeterministic + -- Phase 60.4: NodeData は plot-core に既実装 (Phase 26 §E-6) + DataN _ -> NodeData + , dnDist = Just (nodeDist n) + , dnX = 0 + , dnY = 0 + } + +-- | [日本語]: random-effect 第 @k@ 列の caterpillar plot。 BLUP を group ごとに取り、 +-- __値で昇順ソート__して forest mark (errs=0 の点) で並べ、 0 に 'forestNull' 参照線。 +-- [English]: The caterpillar plot for random-effect column @k@. Takes the +-- BLUPs per group, __sorts them ascending by value__, lays them out with +-- the forest mark (points with errs=0), and draws a 'forestNull' +-- reference line at 0. +caterpillarColumn :: GLMMResultRE -> Int -> VisualSpec +caterpillarColumn res k = + let cols = LA.toColumns (reBLUPs res) + blups = if k >= 0 && k < length cols then LA.toList (cols !! k) else [] + groups = V.toList (reGroups res) + sorted = sortBy (comparing snd) (zip groups blups) + gs = map fst sorted + es = map snd sorted + zeros = map (const (0 :: Double)) es + in layer (forest (inlineCat gs) (inline es) (inline zeros) <> forestNull 0) + <> title ("Random effects (col " <> T.pack (show k) <> ")") + +instance Plottable GLMMResultRE where + -- 代表 1 枚 = 第 1 列 (通常 random intercept) の caterpillar。 + toPlot res = caterpillarColumn res 0 + -- 診断束 = 全 r 列 (intercept + slope) の caterpillar。 + diagnosticPlots res = + [ caterpillarColumn res k | k <- [0 .. LA.cols (reBLUPs res) - 1] ] + +-- | [日本語]: HBM の事後予測平均 (epred) 応答曲面。 2 つの予測子 slot (@p1@, @p2@) を +-- grid で動かし、 各点で deterministic @muName@ の事後平均を取る +-- ('epredAt' の 2 変数版・O1 規約は 'renderEpred' の節を参照)。 +-- ★コスト = grid 点数² × 全 draw のモデル評価。 既定 n=30 (900 点)。 +-- [English]: The HBM posterior predictive mean (epred) response surface. +-- Moves two predictor slots (@p1@, @p2@) across a grid, taking the +-- posterior mean of the deterministic @muName@ at each point (the +-- two-variable version of 'epredAt'; see the note on the O1 convention in +-- 'renderEpred'\'s section). +-- ★Cost = (grid points)² × model evaluations across all draws. Default +-- n=30 (900 points). +epredSurfaceOf :: HBMModel -> Text -> Text -> Text -> P3.VisualSpec3D +epredSurfaceOf hbm p1 p2 muName = + epredSurfaceOfWith hbm p1 p2 muName defaultSurfaceOpts { soN = 30 } + +epredSurfaceOfWith :: HBMModel -> Text -> Text -> Text -> SurfaceOpts -> P3.VisualSpec3D +epredSurfaceOfWith hbm p1 p2 muName opts = + let (xlo, xhi) = fromMaybe (epredPredRange hbm p1) (soXRange opts) + (ylo, yhi) = fromMaybe (epredPredRange hbm p2) (soYRange opts) + n = max 2 (soN opts) + gxs = linspace xlo xhi n + gys = linspace ylo yhi n + draws = concatMap chainSamples (hbmChainsR hbm) + muAt gx gy = + let bound :: ModelP () + bound = withData p1 [gx] (withData p2 [gy] (hbmModelSpec hbm)) + mus = [ v | ps <- draws + , Just v <- [Map.lookup muName (runDeterministics bound ps)] ] + in if null mus then 0 else sum mus / fromIntegral (length mus) + grid = [ [ muAt gx gy | gx <- gxs ] | gy <- gys ] + in P3.layer3D ( P3.surface3DGrid grid + <> P3.xRange3D (xlo, xhi) + <> P3.yRange3D (ylo, yhi) + <> P3.colormap3D ) + +-- | [日本語]: 学習済 HBM が保持するデータ列 ('hbmData') から散布図層を作る。 +-- +-- @df |-> hbm cfg model@ で学習した後、 @dataScatterOf m \"x\" \"y\"@ で +-- 観測散布図を出せるので、 epred\/forest 等の抽出子と重畳するとき +-- __df を学習時 1 回だけ__書けばよい: +-- +-- > let m = df |-> hbm defaultHBM model +-- > noDf |>> (dataScatterOf m "x" "y" <> toPlot (epred m "x" "mu")) +-- [English]: Builds a scatter layer from the trained HBM's retained data +-- columns ('hbmData'). +-- +-- After training with @df |-> hbm cfg model@, @dataScatterOf m \"x\" +-- \"y\"@ produces the observed scatter, so when overlaying it with +-- extractors like epred \/ forest, you only need to +-- __write the df once, at training time__: +-- +-- > let m = df |-> hbm defaultHBM model +-- > noDf |>> (dataScatterOf m "x" "y" <> toPlot (epred m "x" "mu")) +dataScatterOf :: HBMModel -> Text -> Text -> VisualSpec +dataScatterOf m xn yn = + case (lookup xn (hbmData m), lookup yn (hbmData m)) of + (Just xs, Just ys) -> layer (scatter (inline xs) (inline ys)) + _ -> mempty diff --git a/src/Hanalyze/Plot/Core.hs b/src/Hanalyze/Plot/Core.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Plot/Core.hs @@ -0,0 +1,1200 @@ +-- | +-- Module : Hanalyze.Plot.Core +-- Description : hgg 連携層の共通基盤 (モデル族非依存のクラス・型・評価核) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: hgg 連携層の __共通基盤__ (= モデル族非依存のクラス・型・評価核)。 +-- +-- ⚠ 本モジュールは親 'Hanalyze.Plot' と同じく別パッケージ @hanalyze-plot@ +-- に属し、 @cabal build --project-file=cabal.project.plot@ で build される。 +-- @hgg-core@ に依存するため +-- __upstream hanalyze には cherry-pick しない__。 +-- +-- ここに集約するもの: +-- +-- * 図化能力の最終クラス 'Plottable'、 grid 評価クラス 'SingleVarModel' / +-- @MultiVarModel@、 分類器抽象 'ClassPredict'。 +-- * grid 評価の仕様 'ModelSpec' (Semigroup\/Monoid)・確定オプション 'GridOpts'・ +-- ブートストラップ素材 'BootKit'、 および @statModel@\/@grid@\/@bandMode@ 等の +-- 合成子 (smart ctor)。 +-- * grid 評価核 ('renderGrid' \/ 'renderGridMulti' \/ 'bootstrapBands' \/ 'evalFrame' +-- 系)・応答曲面核 ('surfaceGrid' \/ 'surfaceOf' 系) と、 複数のモデル族が共有する +-- 描画 helper。 +-- +-- 各モデル族固有の @instance Plottable XxxModel@ 等は親 'Hanalyze.Plot' 側に +-- 残置する (orphan instance を許容: クラスは Core・instance は Plot・型は Wrappers)。 +-- +-- [English]: The __common foundation__ of the hgg integration layer +-- (= model-family-agnostic classes, types, and the evaluation core). +-- +-- ⚠ This module lives in the same separate package @hanalyze-plot@ as +-- its parent 'Hanalyze.Plot', built via +-- @cabal build --project-file=cabal.project.plot@. Because it +-- depends on @hgg-core@, it is __never cherry-picked__ into +-- upstream hanalyze. +-- +-- Gathered here: +-- +-- * The final plotting-capability class 'Plottable', the grid-evaluation +-- classes 'SingleVarModel' \/ @MultiVarModel@, and the classifier +-- abstraction 'ClassPredict'. +-- * The grid-evaluation spec 'ModelSpec' (Semigroup\/Monoid), its resolved +-- options 'GridOpts', bootstrap material 'BootKit', and the smart +-- constructors @statModel@\/@grid@\/@bandMode@ etc. that build it up. +-- * The grid-evaluation core ('renderGrid' \/ 'renderGridMulti' \/ +-- 'bootstrapBands' \/ 'evalFrame' family), the response-surface core +-- ('surfaceGrid' \/ 'surfaceOf' family), and the drawing helpers shared +-- across multiple model families. +-- +-- Family-specific @instance Plottable XxxModel@ declarations etc. remain in +-- the parent 'Hanalyze.Plot' module (orphan instances are accepted by +-- design: classes live in Core, instances in Plot, types in Wrappers). +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Hanalyze.Plot.Core + ( -- * Plottable protocol + Plottable (..) + -- * ルート1 grid 評価 (ModelSpec) + , ModelSpec (..) + , GridOpts (..) + , BootKit (..) + , SingleVarModel (..) + , MultiVarModel (..) + -- ** 合成子 (smart ctor) + , statModel + , grid + , gridRange + , bandMode + , piMethod + , statColor + , statFill + , statLinetype + , statLinewidth + , statAlpha + , statLabel + , statEquation + , statR2 + , statLevel + , holdAt + , byVar + , predAt + , statModelMulti + -- ** 描画 deco / 凡例 helper + , goLineDeco + , goBandDeco + , labelLegend + , fitLabelText + -- ** grid 評価核 + , bootstrapBands + , renderGrid + , renderGridMulti + , marginalizeCurve + , alongRange + , evalFrame + , setAlong + , isResponseRole + , holdRole + , fixedRole + , clampIdx + , effectPalette + -- * 応答曲面 3D 核 + , evalFrame2 + , surfaceGrid + , chunkRows + , surfaceOf + , surfaceOfWith + , dataScatter3DOf + -- * 集約 helper (連続列の代表値) + , meanV + , medianV + , modeV + , modeIdx + , mostCommon + -- * 共有描画 helper (複数族が利用) + , defaultCILevel + , quantilePalette + , stepVerts + , gridCurves + , importanceBar + , matCols2 + , classMeansScatter + , classMeansScatterNamed + , chainColor + -- * 分類器抽象 + , ClassPredict (..) + -- * 回帰診断の可視化 (係数 forest / 実測vs予測) + , HasObsPred (..) + , obsVsPred + , obsPredSpec + , coefForest + ) where + +import Control.Applicative ((<|>)) +import Data.List (group, maximumBy, sort, transpose) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Data.Word (Word32) +import qualified Data.Vector as V +import System.Random.MWC (initialize, uniformR) +import Control.Monad.ST (runST) +import Control.Monad (replicateM) +import Hanalyze.Model.HBM.Interp (percentileOf) +import Hanalyze.Model.HBM.Sampling (sampleDist) +import qualified Hanalyze.Model.HBM.Distribution as BD +import qualified Numeric.LinearAlgebra as LA + +import Data.Text (Text) +import qualified Data.Text as T + +import Graphics.Hgg.Spec ( VisualSpec, Layer, layer, inline, inlineCat + , Color (..), fromHex + , scatter, line, band + , shape, MarkShape (..) + , color, colorBy, lineRange, bar + , scaleColorManual, legend + , forest, forestNull + , xLabel, yLabel + , LineType (..) + , linetype, alpha, stroke ) +import Hanalyze.Diagnostics ( CoefRow (..), HasCoefSummary (..) ) +import Graphics.Hgg.Unit (pt', (*~)) +import qualified Graphics.Hgg.ThreeD.Spec as P3 +import Graphics.Hgg.ThreeD.Types (Point3 (..)) +import Graphics.Hgg.Color (toCss) + +import Hanalyze.Model.Wrappers +import Hanalyze.Model.Formula.Frame (ModelFrame (..), VarRole (..)) +import Hanalyze.Model.LM (linspace) +import Numeric (showFFloat) + +-- =========================================================================== +-- Plottable protocol +-- =========================================================================== + +-- | [日本語]: 解析オブジェクトを図 (@VisualSpec@) に変換できる能力。 +-- +-- 能力差は中立 protocol ('Hanalyze.Model.Core' の @ResidualModel@ / +-- @PredictiveModel@) 側に持たせ、 ここは「図にできる」 という最終能力のみを表す。 +-- [English]: The capability to convert an analysis object into a figure +-- (@VisualSpec@). +-- +-- Capability differences live on the neutral protocol side +-- ('Hanalyze.Model.Core''s @ResidualModel@ \/ @PredictiveModel@); +-- this class expresses only the final "can be plotted" capability. +class Plottable m where + -- | [日本語]: 代表 1 枚の図 (= layer 重畳の主役、 @<>@ で他 layer と合成可)。 + -- [English]: The single representative figure (= the main layer to + -- overlay onto; composable with other layers via @<>@). + toPlot :: m -> VisualSpec + + -- | [日本語]: 診断図の束 (= レポート用)。 既定は代表 1 枚のみ。 + -- [English]: A bundle of diagnostic figures (= for reports). Defaults + -- to just the single representative figure. + diagnosticPlots :: m -> [VisualSpec] + diagnosticPlots m = [toPlot m] + +-- =========================================================================== +-- ルート1 grid 評価 (ModelSpec) — Phase 16 §3 C1 +-- +-- fit 済モデルの回帰曲線・CI 帯を **訓練点ではなく等間隔 grid** で評価して描く。 +-- 疎・不均一データで曲線がガタつくのを解消する (散布図の点は従来通り訓練データ)。 +-- 'statModel' で 'ModelSpec' を作り、 @<>@ でオプションを足す: +-- +-- > df |>> (layer (scatter "x" "y") <> toPlot (statModel m <> grid 200)) +-- +-- 'ModelSpec' は Monoid。 学習済モデル @m@ はクロージャに閉じ込め、 予測は +-- @toPlot@ (描画時) に grid 評価する (ユーザ直感「m は学習・layer で予測」)。 +-- =========================================================================== + +-- | [日本語]: grid 評価の確定オプション ('ModelSpec' の Maybe field を既定で埋めたもの)。 +-- [English]: The resolved grid-evaluation options ('ModelSpec''s Maybe +-- fields, filled in with defaults). +data GridOpts = GridOpts + { goN :: Int -- ^ [日本語]: 評価点数 (既定 100)。 [English]: Number of evaluation points (default 100). + , goRange :: Maybe (Double, Double) -- ^ [日本語]: 評価範囲 (既定 = 説明変数 min/max)。 [English]: Evaluation range (default = predictor min/max). + , goLevel :: Double -- ^ [日本語]: CI 水準 (既定 0.95)。 [English]: CI confidence level (default 0.95). + , goBandMode :: BandMode -- ^ [日本語]: 帯モード (既定 'BandCI')。 [English]: Band mode (default 'BandCI'). + , goPIMethod :: PIMethod -- ^ [日本語]: 帯の算出法 (既定 'PIClosedForm')。 [English]: Band computation method (default 'PIClosedForm'). + , goPredAt :: [Double] -- ^ [日本語]: 予測点 x のリスト。 [English]: List of prediction points x. + , goHoldAt :: HoldAgg -- ^ [日本語]: 多変量 effect の他変数固定方式 (既定 Mean)。 [English]: How other predictors are held fixed for a multivariate effect plot (default Mean). + , goByVar :: Maybe (Text, [Double]) -- ^ [日本語]: 層別 = 第2変数を複数値で固定。 [English]: Stratification = fixing a second variable at multiple values. + , goColor :: Maybe Color -- ^ [日本語]: 線の固定色 (statColor)。 [English]: Fixed line color (statColor). + , goFill :: Maybe Color -- ^ [日本語]: 帯の塗り色 (statFill)。 [English]: Band fill color (statFill). + , goLinetype :: Maybe LineType -- ^ [日本語]: 線種 (statLinetype)。 [English]: Line type (statLinetype). + , goLinewidth :: Maybe Double -- ^ [日本語]: 線幅 = stroke (statLinewidth)。 [English]: Line width = stroke (statLinewidth). + , goAlpha :: Maybe Double -- ^ [日本語]: 帯/線の透明度 (statAlpha)。 [English]: Band/line transparency (statAlpha). + , goLabel :: Maybe Text -- ^ [日本語]: 単線の凡例ラベル (statLabel)。 [English]: Legend label for a single line (statLabel). + , goShowEq :: Bool -- ^ [日本語]: 回帰式を凡例ラベルに出す (statEquation)。 [English]: Show the regression equation in the legend label (statEquation). + , goShowR2 :: Bool -- ^ [日本語]: R² を凡例ラベルに出す (statR2)。 [English]: Show R² in the legend label (statR2). + } + +-- | [日本語]: grid 上で曲線評価できる単変数モデル。 'statModel' が要求する能力。 +-- [English]: A single-variable model that can be evaluated as a curve on a +-- grid. The capability required by 'statModel'. +class SingleVarModel m where + -- | [日本語]: 生 predictor の範囲 (grid 既定範囲の算出元)。 + -- [English]: The range of the raw predictor (source of the grid's + -- default range). + svRange :: m -> (Double, Double) + -- | [日本語]: 信頼水準と grid x 列から (中心 μ̂, 帯 @(lo, hi)@) を評価する。 + -- band を持たないモデル (GAM/Robust) は 'Nothing'。 + -- [English]: Evaluates (center μ̂, band @(lo, hi)@) from the confidence + -- level and grid x column. Models without a band (GAM/Robust) return + -- 'Nothing'. + svGrid :: m -> Double -> [Double] -> ([Double], Maybe ([Double], [Double])) + -- | [日本語]: __予測区間__ (PI) 帯 @(lo, hi)@ を評価する。 観測分散 σ̂² を持つモデル + -- (LM・Gaussian/Identity GLM) のみ実装し、 それ以外は既定の 'Nothing' (= PI 非提供)。 + -- 中心 μ̂ は 'svGrid' と共通ゆえここでは帯のみ返す。 + -- [English]: Evaluates the __prediction interval__ (PI) band @(lo, + -- hi)@. Only implemented for models with an observation variance σ̂² + -- (LM, Gaussian/Identity GLM); everything else falls back on the + -- default 'Nothing' (= PI not provided). The center μ̂ is shared with + -- 'svGrid', so only the band is returned here. + svGridPI :: m -> Double -> [Double] -> Maybe ([Double], [Double]) + svGridPI _ _ _ = Nothing + -- | [日本語]: 当てはめ係数 @[β₀, β₁]@ と R² (式/R² 凡例注釈用)。 線形で「式」 の意味が + -- 明快なモデル (LM) のみ実装し、 それ以外は既定の 'Nothing' (= 式注釈を出さない)。 + -- GLM は係数が η (リンク) スケールゆえ @y = β₀ + β₁x@ の素朴な式が成り立たず Nothing。 + -- [English]: The fitted coefficients @[β₀, β₁]@ and R² (for the + -- equation/R² legend annotation). Only implemented for models where + -- "the equation" has an unambiguous linear meaning (LM); everything + -- else defaults to 'Nothing' (= no equation annotation shown). GLM + -- coefficients live on the η (link) scale, so the naive + -- @y = β₀ + β₁x@ equation does not hold and it returns Nothing. + svCoefR2 :: m -> Maybe ([Double], Double) + svCoefR2 _ = Nothing + -- | [日本語]: ブートストラップ ('piMethod (PIBootstrap …)') 用の素材。 訓練 (x, y)・ + -- 再標本化データで refit する関数・新規観測の分布 (GLM family。 'Nothing' = 加法残差) + -- を束ねて返す。 既定 'Nothing' (= ブートストラップ非対応 → 閉形式へフォールバック)。 + -- closed-form を持たないモデル (非 Gaussian GLM / ロバスト) でも、 これを実装すれば + -- PI を出せる。 + -- [English]: Material for bootstrapping ('piMethod (PIBootstrap …)'). Bundles + -- the training (x, y), a function that refits on resampled data, and the + -- distribution of a new observation (GLM family; 'Nothing' = additive + -- residual). Defaults to 'Nothing' (= bootstrap unsupported → falls back + -- to closed form). Even models without a closed form (non-Gaussian GLM / + -- robust) can offer a PI by implementing this. + svBootKit :: m -> Maybe (BootKit m) + svBootKit _ = Nothing + +-- | [日本語]: ブートストラップに必要な素材 ('svBootKit' が返す。 内部利用)。 +-- [English]: The material required for bootstrapping (returned by +-- 'svBootKit'; internal use). +data BootKit m = BootKit + { bkX :: [Double] -- ^ [日本語]: 訓練 x。 [English]: Training x. + , bkY :: [Double] -- ^ [日本語]: 訓練 y。 [English]: Training y. + , bkRefit :: [Double] -> [Double] -> m -- ^ [日本語]: 再標本化 (x, y) で refit。 [English]: Refit on a resampled (x, y). + , bkObsDist :: Maybe (Double -> BD.Distribution Double) -- ^ [日本語]: 新規観測の分布 (GLM)。 Nothing=加法残差。 [English]: The distribution of a new observation (GLM). Nothing = additive residual. + } + +-- | [日本語]: grid 評価の仕様。 'statModel' で生成し @<>@ でオプション合成 (Monoid)。 +-- @msRender@ にモデルの grid 評価関数をクロージャで保持する。 +-- [English]: The grid-evaluation spec. Created via 'statModel' and +-- composed with options via @<>@ (Monoid). @msRender@ holds the model's +-- grid-evaluation function as a closure. +data ModelSpec = ModelSpec + { msRender :: Maybe (GridOpts -> VisualSpec) -- ^ [日本語]: statModel が設定 (先勝ち)。 [English]: Set by statModel (first wins). + , msN :: Maybe Int -- ^ [日本語]: grid 点数 (後勝ち)。 [English]: Number of grid points (last wins). + , msRange :: Maybe (Double, Double) -- ^ [日本語]: grid 範囲 (後勝ち)。 [English]: Grid range (last wins). + , msLevel :: Maybe Double -- ^ [日本語]: CI 水準 (後勝ち)。 [English]: CI confidence level (last wins). + , msBandMode :: Maybe BandMode -- ^ [日本語]: 帯モード (後勝ち、 既定 'BandCI'。 + -- 帯 ON/OFF と CI/PI を 'bandMode' 1 本に統合)。 + -- [English]: Band mode (last wins, default 'BandCI'. + -- 'bandMode' unifies band on/off and CI/PI into one + -- knob). + , msPIMethod :: Maybe PIMethod -- ^ [日本語]: 帯の算出法 (後勝ち、 既定 'PIClosedForm')。 [English]: Band computation method (last wins, default 'PIClosedForm'). + , msPredAt :: [Double] -- ^ [日本語]: 予測点 x (リスト累積 ++)。 [English]: Prediction points x (accumulated via list ++). + , msHoldAt :: Maybe HoldAgg -- ^ [日本語]: 多変量 effect の固定方式 (後勝ち、 既定 Mean)。 [English]: How other predictors are held fixed for a multivariate effect plot (last wins, default Mean). + , msByVar :: Maybe (Text, [Double]) -- ^ [日本語]: 層別変数 (後勝ち)。 [English]: Stratification variable (last wins). + , msColor :: Maybe Color -- ^ [日本語]: 線の固定色 (後勝ち)。 [English]: Fixed line color (last wins). + , msFill :: Maybe Color -- ^ [日本語]: 帯の塗り色 (後勝ち)。 [English]: Band fill color (last wins). + , msLinetype :: Maybe LineType -- ^ [日本語]: 線種 (後勝ち)。 [English]: Line type (last wins). + , msLinewidth :: Maybe Double -- ^ [日本語]: 線幅 = stroke (後勝ち)。 [English]: Line width = stroke (last wins). + , msAlpha :: Maybe Double -- ^ [日本語]: 帯/線の透明度 (後勝ち)。 [English]: Band/line transparency (last wins). + , msLabel :: Maybe Text -- ^ [日本語]: 単線の凡例ラベル (後勝ち)。 [English]: Legend label for a single line (last wins). + , msShowEq :: Bool -- ^ [日本語]: 回帰式を凡例に出す (Any)。 [English]: Show the regression equation in the legend (Any monoid). + , msShowR2 :: Bool -- ^ [日本語]: R² を凡例に出す (Any)。 [English]: Show R² in the legend (Any monoid). + } + +instance Semigroup ModelSpec where + a <> b = ModelSpec + { msRender = msRender a <|> msRender b -- モデルは先勝ち (通常 1 個) + , msN = msN b <|> msN a -- オプションは後勝ち + , msRange = msRange b <|> msRange a + , msLevel = msLevel b <|> msLevel a + , msBandMode = msBandMode b <|> msBandMode a -- 帯モードは後勝ち + , msPIMethod = msPIMethod b <|> msPIMethod a -- 算出法も後勝ち + , msPredAt = msPredAt a ++ msPredAt b -- 予測点はリスト累積 + , msHoldAt = msHoldAt b <|> msHoldAt a + , msByVar = msByVar b <|> msByVar a + , msColor = msColor b <|> msColor a -- aes は後勝ち + , msFill = msFill b <|> msFill a + , msLinetype = msLinetype b <|> msLinetype a + , msLinewidth = msLinewidth b <|> msLinewidth a + , msAlpha = msAlpha b <|> msAlpha a + , msLabel = msLabel b <|> msLabel a + , msShowEq = msShowEq a || msShowEq b -- 注釈はオプトイン (Any) + , msShowR2 = msShowR2 a || msShowR2 b + } + +instance Monoid ModelSpec where + mempty = ModelSpec + { msRender = Nothing, msN = Nothing, msRange = Nothing, msLevel = Nothing + , msBandMode = Nothing, msPIMethod = Nothing, msPredAt = [], msHoldAt = Nothing, msByVar = Nothing + , msColor = Nothing, msFill = Nothing, msLinetype = Nothing + , msLinewidth = Nothing, msAlpha = Nothing, msLabel = Nothing + , msShowEq = False, msShowR2 = False } + +-- | [日本語]: 学習済の単変数モデルから grid 評価 'ModelSpec' を作る (along 不要)。 +-- [English]: Builds a grid-evaluation 'ModelSpec' from a fitted +-- single-variable model (no along needed). +statModel :: SingleVarModel m => m -> ModelSpec +statModel m = mempty { msRender = Just (renderGrid m) } + +-- | [日本語]: grid 評価点数を指定 (既定 100)。 +-- [English]: Specifies the number of grid-evaluation points (default 100). +grid :: Int -> ModelSpec +grid n = mempty { msN = Just n } + +-- | [日本語]: grid 評価範囲を指定 (既定 = 説明変数 min/max)。 +-- [English]: Specifies the grid-evaluation range (default = predictor +-- min/max). +gridRange :: Double -> Double -> ModelSpec +gridRange lo hi = mempty { msRange = Just (lo, hi) } + +-- | [日本語]: 出す帯を 1 つの値で選ぶ (帯 ON/OFF と CI/PI を統合)。 'BandMode' は +-- @BandOff@ (なし) \/ @BandCI@ (既定・信頼区間) \/ @BandPI@ (予測区間) \/ @BandCIPI@ +-- (入れ子)。 既定 (未指定) は @BandCI@。 PI 非提供モデルでは PI 系は CI へフォールバック。 +-- +-- @statModel m \<\> bandMode BandPI@ \/ @… \<\> bandMode BandCIPI@ \/ @… \<\> bandMode BandOff@。 +-- [English]: Picks which band to show via a single value (unifies band +-- on/off with CI/PI). 'BandMode' is @BandOff@ (none) \/ @BandCI@ (default; +-- confidence interval) \/ @BandPI@ (prediction interval) \/ @BandCIPI@ +-- (nested). The default (unspecified) is @BandCI@. For models that don't +-- provide a PI, PI-based modes fall back to CI. +-- +-- @statModel m \<\> bandMode BandPI@ \/ @… \<\> bandMode BandCIPI@ \/ @… \<\> bandMode BandOff@. +bandMode :: BandMode -> ModelSpec +bandMode m = mempty { msBandMode = Just m } + +-- | [日本語]: 帯 (CI/PI) の__算出法__を選ぶ。 @bandMode@ が「どの帯を出すか」を選ぶのに対し、 +-- @piMethod@ は「どう計算するか」を選ぶ直交軸: +-- +-- * @PIClosedForm@ = 閉形式 (Wald / 基底空間 OLS。 __既定__)。 +-- * @PIBootstrap seed draws@ = case-resampling ブートストラップ (seed で決定的)。 +-- 閉形式 CI/PI を持たないモデル (非 Gaussian GLM / ロバスト) でも PI を出せる。 +-- +-- @statModel m \<\> bandMode BandPI \<\> piMethod (PIBootstrap 42 2000)@。 +-- [English]: Chooses the __computation method__ for a band (CI/PI). Where +-- @bandMode@ picks "which band to show," @piMethod@ is the orthogonal axis +-- that picks "how to compute it": +-- +-- * @PIClosedForm@ = closed form (Wald \/ basis-space OLS. __default__). +-- * @PIBootstrap seed draws@ = case-resampling bootstrap (deterministic +-- given the seed). Lets even models without a closed-form CI/PI +-- (non-Gaussian GLM \/ robust) produce a PI. +-- +-- @statModel m \<\> bandMode BandPI \<\> piMethod (PIBootstrap 42 2000)@. +piMethod :: PIMethod -> ModelSpec +piMethod p = mempty { msPIMethod = Just p } + +-- | [日本語]: 回帰線の固定色 (ggplot @geom_smooth(color=)@)。 凡例は付かない (単線命名は +-- 'statLabel')。 型安全な 'Color' を受ける (plot-core の 'color' と同じ方針)。 +-- @statColor (fromHex "#ff0000")@ \/ @statColor N.red@ \/ @statColor (rgb 255 0 0)@。 +-- Text→Color は 'fromHex' に委ねる。 +-- [English]: Fixed color for the regression line (ggplot +-- @geom_smooth(color=)@). No legend is added (naming a single line is +-- 'statLabel''s job). Takes a type-safe 'Color' (same policy as +-- plot-core's 'color'). @statColor (fromHex "#ff0000")@ \/ @statColor +-- N.red@ \/ @statColor (rgb 255 0 0)@. Text→Color conversion is delegated +-- to 'fromHex'. +statColor :: Color -> ModelSpec +statColor c = mempty { msColor = Just c } + +-- | [日本語]: CI 帯の塗り色 (ggplot @geom_smooth(fill=)@)。 型安全な 'Color' を受ける。 +-- [English]: Fill color for the CI band (ggplot @geom_smooth(fill=)@). +-- Takes a type-safe 'Color'. +statFill :: Color -> ModelSpec +statFill c = mempty { msFill = Just c } + +-- | [日本語]: 回帰線の線種 (ggplot @geom_smooth(linetype=)@)。 'LineType' = 'LtSolid' / +-- 'LtDashed' 等。 +-- [English]: Line type for the regression line (ggplot +-- @geom_smooth(linetype=)@). 'LineType' = 'LtSolid' \/ 'LtDashed' etc. +statLinetype :: LineType -> ModelSpec +statLinetype lt = mempty { msLinetype = Just lt } + +-- | [日本語]: 回帰線の太さ (= stroke 幅。 ggplot @geom_smooth(linewidth=)@)。 +-- [English]: Thickness of the regression line (= stroke width; ggplot +-- @geom_smooth(linewidth=)@). +statLinewidth :: Double -> ModelSpec +statLinewidth w = mempty { msLinewidth = Just w } + +-- | [日本語]: 帯/線の透明度 (ggplot @geom_smooth(alpha=)@)。 帯に適用 (薄い塗り潰しの ggplot 流)。 +-- [English]: Transparency for the band/line (ggplot @geom_smooth(alpha=)@). +-- Applied to the band (following ggplot's convention of a light fill). +statAlpha :: Double -> ModelSpec +statAlpha a = mempty { msAlpha = Just a } + +-- | [日本語]: 単線に凡例ラベルを付ける。 1 群カテゴリ (@ColorByCol@) + 'scaleColorManual' で +-- 色を固定し凡例エントリを 1 つ出す (固定色 'color' は @hasColorEncoding=False@ で +-- 凡例が出ない罠を回避)。 色は 'statColor' があればそれ、 なければ既定パレット先頭。 +-- ★モデル比較で各線に名前を付ける用途 (= 群数 1 の @byGroup@ 特殊形)。 +-- [English]: Adds a legend label to a single line. Fixes the color via a +-- single-group category (@ColorByCol@) + 'scaleColorManual' and emits one +-- legend entry (avoids the trap where a fixed 'color' has +-- @hasColorEncoding=False@ and no legend appears). Uses 'statColor' if +-- given, otherwise the first color in the default palette. ★Used to name +-- each line when comparing models (= a special case of @byGroup@ with a +-- single group). +statLabel :: Text -> ModelSpec +statLabel lbl = mempty { msLabel = Just lbl } + +-- | [日本語]: 回帰式を凡例ラベルに出す (ggplot @ggpubr::stat_regline_equation@ 相当)。 +-- @svCoefR2@ を持つモデル (LM) で @y = β₀ + β₁x@ を自動生成し 凡例機構に載せる。 +-- 明示 'statLabel' があればそちらを優先。 式の出せないモデル (GLM 等) では注釈なし。 +-- 'statR2' と併用すると @y = … + …x, R² = …@ のように 1 ラベルに連結する。 +-- [English]: Shows the regression equation in the legend label (equivalent +-- to ggplot's @ggpubr::stat_regline_equation@). For models with +-- @svCoefR2@ (LM), auto-generates @y = β₀ + β₁x@ and feeds it into the +-- legend mechanism. An explicit 'statLabel' takes precedence. Models that +-- can't produce an equation (GLM etc.) get no annotation. Combined with +-- 'statR2', the two are joined into one label as @y = … + …x, R² = …@. +statEquation :: ModelSpec +statEquation = mempty { msShowEq = True } + +-- | [日本語]: R² を凡例ラベルに出す (ggplot @ggpubr::stat_cor(aes(label=..rr.label..))@ 相当)。 +-- @svCoefR2@ を持つモデル (LM) の R² を @R² = 0.987@ の形で凡例に載せる。 +-- [English]: Shows R² in the legend label (equivalent to ggplot's +-- @ggpubr::stat_cor(aes(label=..rr.label..))@). Puts the R² of a model +-- with @svCoefR2@ (LM) into the legend as @R² = 0.987@. +statR2 :: ModelSpec +statR2 = mempty { msShowR2 = True } + +-- | [日本語]: CI 水準を指定 (既定 0.95)。 +-- [English]: Specifies the CI confidence level (default 0.95). +statLevel :: Double -> ModelSpec +statLevel l = mempty { msLevel = Just l } + +-- | [日本語]: 多変量 effect で along 以外の説明変数の固定方式を指定 (既定 'Mean')。 +-- [English]: Specifies how predictors other than along are held fixed in +-- a multivariate effect plot (default 'Mean'). +holdAt :: HoldAgg -> ModelSpec +holdAt h = mempty { msHoldAt = Just h } + +-- | [日本語]: 層別 = 第2変数 @v@ を複数値 @vals@ で固定し、 値ごとに 1 曲線を色分け重畳する +-- (R @ggpredict@ terms 第2項相当)。 多変量モデル ('statModelMulti') 専用。 +-- [English]: Stratification: fixes a second variable @v@ at multiple +-- values @vals@ and overlays one color-coded curve per value (equivalent +-- to the second term of R's @ggpredict@ terms). For multivariate models +-- ('statModelMulti') only. +byVar :: Text -> [Double] -> ModelSpec +byVar v vals = mempty { msByVar = Just (v, vals) } + +-- | [日本語]: 予測点を 1 つ足す。 @<>@ でリスト累積 → @… <> predAt 1 <> predAt 3@ で複数点。 +-- 各点は μ̂ (scatter) + CI 区間 [lo, hi] (lineRange) で描かれる (band を持たない GAM/ +-- Robust は μ̂ 点のみ)。 単変数モデル前提 (多変量 effect は statModelMulti で対応)。 +-- [English]: Adds one prediction point. Accumulated via @<>@ → @… <> +-- predAt 1 <> predAt 3@ for multiple points. Each point is drawn as μ̂ +-- (scatter) + a CI interval [lo, hi] (lineRange); models without a band +-- (GAM/Robust) get just the μ̂ point. Assumes a single-variable model +-- (multivariate effects are handled by statModelMulti). +predAt :: Double -> ModelSpec +predAt x = mempty { msPredAt = [x] } + +-- | [日本語]: 線レイヤへ aes (色・線種・太さ) を適用。 色の決定順は +-- (1) 群色 @mCol@ (byVar) → 'color'、 (2) 'statLabel' (@goLabel@) → 1 群 'colorBy' +-- (凡例を出すため・@n@ 点ぶんのカテゴリ列)、 (3) 'statColor' → 'color'。 +-- 線種・太さは色と独立に適用。 @n@ = grid 点数 (label カテゴリ列の長さ)。 +-- [English]: Applies aes (color, line type, width) to a line layer. Color +-- is resolved in order: (1) the group color @mCol@ (byVar) → 'color', (2) +-- 'statLabel' (@goLabel@) → a single-group 'colorBy' (to show a legend; a +-- category column of length @n@), (3) 'statColor' → 'color'. Line type and +-- width are applied independently of color. @n@ = number of grid points +-- (the length of the label category column). +goLineDeco :: GridOpts -> Maybe Color -> Int -> Layer -> Layer +goLineDeco o mCol n l = + let colorL = case (mCol, goLabel o) of + (Just c, _) -> color c -- 群色優先 + (Nothing, Just lbl) -> colorBy (inlineCat (replicate n lbl)) -- statLabel: ColorByCol で凡例 + (Nothing, Nothing) -> maybe mempty color (goColor o) -- statColor or 無色 + in l <> colorL + <> maybe mempty linetype (goLinetype o) + <> maybe mempty (\lw -> stroke (lw *~ pt')) (goLinewidth o) + +-- | [日本語]: 帯レイヤへ fill 色・透明度を適用。 群色 @mCol@ があれば fill は群色を優先 +-- ('statFill' で上書き不可)。 +-- [English]: Applies fill color and transparency to a band layer. If a +-- group color @mCol@ is present, fill prefers the group color (cannot be +-- overridden by 'statFill'). +goBandDeco :: GridOpts -> Maybe Color -> Layer -> Layer +goBandDeco o mCol b = + b <> maybe mempty color (mCol <|> goFill o) + <> maybe mempty alpha (goAlpha o) + +-- | [日本語]: 'statLabel' があれば @scaleColorManual@ で色を固定し @legend@ を出す +-- @VisualSpec@。 色は 'statColor' (@goColor@) 優先・なければ既定パレット先頭。 +-- ラベル無しは空。 +-- [English]: A @VisualSpec@ that, when 'statLabel' is present, fixes the +-- color via @scaleColorManual@ and shows a @legend@. Color prefers +-- 'statColor' (@goColor@), falling back to the first color in the default +-- palette. Empty when there is no label. +labelLegend :: GridOpts -> VisualSpec +labelLegend o = case goLabel o of + Just lbl -> scaleColorManual [(lbl, maybe (head effectPalette) toCss (goColor o))] <> legend + Nothing -> mempty + +-- | [日本語]: 式/R² 凡例ラベル文字列を組む。 @showEq@ で @y = β₀ + β₁x@、 @showR2@ で +-- @R² = 0.987@ を入れ、 両方なら @", "@ で連結する。 係数は単回帰 @[β₀, β₁]@ を想定 +-- (β₁ の符号で @+@/@-@ を切替)。 どちらの flag も立っていなければ 'Nothing'。 +-- [English]: Builds the equation/R² legend label string. Inserts @y = β₀ + +-- β₁x@ when @showEq@ is set and @R² = 0.987@ when @showR2@ is set, joining +-- the two with @", "@ if both are present. Coefficients are assumed to be +-- a simple regression @[β₀, β₁]@ (the sign of β₁ switches @+@\/@-@). +-- Returns 'Nothing' if neither flag is set. +fitLabelText :: Bool -> Bool -> [Double] -> Double -> Maybe Text +fitLabelText showEq showR2 coefs r2 = + let f3 x = T.pack (showFFloat (Just 3) x "") -- 小数 3 桁固定 + eqPart = case coefs of + (b0 : b1 : _) -> + let sgn = if b1 < 0 then " − " else " + " + in "y = " <> f3 b0 <> sgn <> f3 (abs b1) <> "x" + [b0] -> "y = " <> f3 b0 + _ -> "y = ?" + r2Part = "R² = " <> f3 r2 + parts = [ eqPart | showEq ] ++ [ r2Part | showR2 ] + in if null parts then Nothing else Just (T.intercalate ", " parts) + +-- | [日本語]: case-resampling ブートストラップで grid 上の CI / PI 帯を計算する。 +-- 訓練 (x, y) を seed 付きで再標本化 → 'bkRefit' で refit → 'svGrid' で grid μ を予測、 +-- を @draws@ 回。 CI = μ_b の分位点 (係数の不確実性)。 PI = 新規観測 y* の分位点 +-- (加法残差 'bkObsDist'=Nothing、 または Family(μ) からの parametric ドロー)。 seed 純粋 +-- (runST + mwc・同 seed でビット同一)。 戻り = (CI (lo,hi), PI (lo,hi))。 +-- [English]: Computes CI / PI bands on the grid via case-resampling +-- bootstrap. Resamples the training (x, y) with a seed → refits via +-- 'bkRefit' → predicts grid μ via 'svGrid', repeated @draws@ times. CI = +-- quantiles of μ_b (coefficient uncertainty). PI = quantiles of a new +-- observation y* (additive residual when 'bkObsDist'=Nothing, or a +-- parametric draw from Family(μ) otherwise). Pure given the seed (runST + +-- mwc; bit-identical for the same seed). Returns (CI (lo,hi), PI (lo,hi)). +bootstrapBands :: SingleVarModel m + => m -> BootKit m -> Word32 -> Int -> Double -> [Double] + -> (([Double], [Double]), ([Double], [Double])) +bootstrapBands m kit seed draws level gxs = + let xs = V.fromList (bkX kit) + ys = V.fromList (bkY kit) + n = V.length xs + ng = length gxs + a2 = (1 - level) / 2 + resid = V.fromList (zipWith (-) (bkY kit) (fst (svGrid m level (bkX kit)))) + paths = runST $ do + gen <- initialize (V.singleton seed) + replicateM draws $ do + idx <- replicateM n (uniformR (0, n - 1) gen) + let xs' = [ xs V.! i | i <- idx ] + ys' = [ ys V.! i | i <- idx ] + muB = fst (svGrid (bkRefit kit xs' ys') level gxs) + pis <- case bkObsDist kit of + Just toDist -> mapM (\mu -> sampleDist (toDist mu) gen) muB + Nothing -> mapM (\mu -> do j <- uniformR (0, n - 1) gen + pure (mu + resid V.! j)) muB + pure (muB, pis) + muT = transpose (map fst paths) -- ng × draws + piT = transpose (map snd paths) + q lo xss = map (percentileOf lo) xss + in if n < 2 || ng == 0 + then (([], []), ([], [])) + else ( (q a2 muT, q (1 - a2) muT), (q a2 piT, q (1 - a2) piT) ) + +-- | [日本語]: grid 評価して曲線 (+ 帯) + 予測点の @VisualSpec@ を組む。 'statModel' がクロージャ化。 +-- 帯がある場合は @band@ を先に置き @line@ (μ̂ 曲線) を上に重ねる。 予測点 (goPredAt) は +-- CI 区間を @lineRange@ (縦線 [lo,hi]) + μ̂ を @scatter@ で重ね、 μ̂ が区間内のどこにあるか +-- (非対称な GLM 帯でも) 忠実に示す。 +-- [English]: Grid-evaluates the model and builds the @VisualSpec@ for the +-- curve (+ band) + prediction points. Closed over by 'statModel'. When a +-- band is present, @band@ is drawn first and @line@ (the μ̂ curve) is +-- layered on top. Prediction points (goPredAt) overlay the CI interval as +-- @lineRange@ (a vertical segment [lo,hi]) with μ̂ as a @scatter@ point, +-- faithfully showing where μ̂ sits within the interval (even for +-- asymmetric GLM bands). +renderGrid :: SingleVarModel m => m -> GridOpts -> VisualSpec +renderGrid m opts0 = + -- A8: statEquation/statR2 が立っていれば svCoefR2 から式/R² 文字列を作り、 + -- A3 と同じ凡例経路 (goLabel) に流す。 明示 statLabel が優先 (上書きしない)。 + let autoLabel = case (goShowEq opts0 || goShowR2 opts0, svCoefR2 m) of + (True, Just (coefs, r2)) -> fitLabelText (goShowEq opts0) (goShowR2 opts0) coefs r2 + _ -> Nothing + opts = case goLabel opts0 of + Just _ -> opts0 -- 明示ラベル優先 + Nothing -> opts0 { goLabel = autoLabel } + (lo0, hi0) = svRange m + (lo, hi) = fromMaybe (lo0, hi0) (goRange opts) + n = max 2 (goN opts) + gxs = linspace lo hi n + (mu, mbCIcf) = svGrid m (goLevel opts) gxs + -- 帯の算出法 (Phase 70.H): 既定 closed-form、 PIBootstrap で case-resampling。 + -- bootstrap は CI/PI を両方その場で計算 ('svBootKit' を持つモデルのみ。 無ければ + -- closed-form へフォールバック)。 中心曲線 mu は元の当てはめのまま。 + (mbCI, mbPI) = case goPIMethod opts of + PIBootstrap seed draws + | Just kit <- svBootKit m -> + let (ci, pii) = bootstrapBands m kit seed draws (goLevel opts) gxs + in (Just ci, Just pii) + _ -> (mbCIcf, svGridPI m (goLevel opts) gxs) + -- 帯モードで CI/PI/両方/なしを描く (Phase 70.F)。 PI 非提供は CI へフォールバック。 + lineL = layer (goLineDeco opts Nothing n (line (inline gxs) (inline mu))) + bandL deco mb = case mb of + Just (los, his) -> layer (deco (band (inline gxs) (inline los) (inline his))) + Nothing -> mempty + ciDeco = goBandDeco opts Nothing + -- 入れ子時の PI 帯は薄め (CI が内側で見えるように)。 + piA = maybe 0.10 (* 0.5) (goAlpha opts) + piDeco = goBandDeco (opts { goAlpha = Just piA }) Nothing + curve = case goBandMode opts of + BandOff -> lineL + BandCI -> bandL ciDeco mbCI <> lineL + BandPI -> case mbPI of + Just _ -> bandL ciDeco mbPI <> lineL -- PI 単独 (通常の濃さ) + Nothing -> bandL ciDeco mbCI <> lineL -- PI 非提供 → CI + BandCIPI -> case mbPI of + Just _ -> bandL piDeco mbPI -- 外: PI 薄 (下) + <> bandL ciDeco mbCI -- 内: CI 濃 (上) + <> lineL + Nothing -> bandL ciDeco mbCI <> lineL -- PI 非提供 → CI のみ + pts = goPredAt opts + predLayers + | null pts = mempty + | otherwise = + let (pmu, pmb) = svGrid m (goLevel opts) pts + in case pmb of + Just (plos, phis) -> + let mids = zipWith (\l h -> (l + h) / 2) plos phis + halfs = zipWith (\l h -> (h - l) / 2) plos phis + in layer (lineRange (inline pts) (inline mids) (inline halfs)) + <> layer (scatter (inline pts) (inline pmu)) + Nothing -> layer (scatter (inline pts) (inline pmu)) + in curve <> predLayers <> labelLegend opts + +-- ★案B: 既存 'Plottable' の @toPlot@ を 'ModelSpec' にも overload (同綴り)。 +instance Plottable ModelSpec where + toPlot ms = case msRender ms of + Nothing -> mempty -- モデル未設定 (オプションのみ) は空図。 + Just f -> f GridOpts + { goN = fromMaybe 100 (msN ms) + , goRange = msRange ms + , goLevel = fromMaybe 0.95 (msLevel ms) + , goBandMode = fromMaybe BandCI (msBandMode ms) + , goPIMethod = fromMaybe PIClosedForm (msPIMethod ms) + , goPredAt = msPredAt ms + , goHoldAt = fromMaybe Mean (msHoldAt ms) + , goByVar = msByVar ms + , goColor = msColor ms + , goFill = msFill ms + , goLinetype = msLinetype ms + , goLinewidth = msLinewidth ms + , goAlpha = msAlpha ms + , goLabel = msLabel ms + , goShowEq = msShowEq ms + , goShowR2 = msShowR2 ms + } + +-- =========================================================================== +-- 多変量 effect plot (Phase 16 §3 C3) +-- +-- 単変数 grid 評価 (C1) を多変量モデルへ一般化する。 along 変数を grid で動かし、 +-- 他の説明変数を 'HoldAgg' で固定した「評価点 ModelFrame」 を合成して、 訓練 formula の +-- @designMatrixF@ で評価点設計行列を組み CI を評価する。 +-- +-- ★評価点 ModelFrame の合成は **DataFrame を経由せず VarRole を直接差し替える** +-- (@designMatrixF@ は 'mfRoles' のみ参照し応答列は使わない = Design.hs:331)。 列構造・ +-- 順序が訓練と完全一致するので @confidenceBandAt@ / 'predictGlmMuWithCI' がそのまま使える。 +-- 型で単/多変量を分離し ('SingleVarModel' / @MultiVarModel@)、 along 忘れをコンパイル時に弾く。 +-- =========================================================================== + +-- | [日本語]: along を必須引数に持つ多変量モデル。 'statModelMulti' が要求する能力。 +-- [English]: A multivariate model that requires along as a mandatory +-- argument. The capability required by 'statModelMulti'. +class MultiVarModel m where + -- | [日本語]: 訓練 'ModelFrame' (along の range と他変数の集約元)。 + -- [English]: The training 'ModelFrame' (the source of along's range and + -- of other variables' aggregate values). + mvFrame :: m -> ModelFrame + -- | [日本語]: 評価点 'ModelFrame' から (中心 μ̂, CI 帯 @(lo, hi)@) を評価する。 + -- 設計行列が組めない場合は空 + 'Nothing'。 + -- [English]: Evaluates (center μ̂, CI band @(lo, hi)@) from an + -- evaluation-point 'ModelFrame'. Returns empty + 'Nothing' if the design + -- matrix cannot be built. + mvEvalFrame :: m -> Double -> ModelFrame -> ([Double], Maybe ([Double], [Double])) + -- | [日本語]: 評価点での予測区間 (PI)。 既定 'Nothing' (PI 非提供)。 closed-form PI を持つ + -- モデル ('MultiLMModel' = 多変量 OLS) のみ override する (@svGridPI@ と同じ方針)。 + -- [English]: The prediction interval (PI) at the evaluation points. + -- Defaults to 'Nothing' (PI not provided). Only overridden by models + -- with a closed-form PI ('MultiLMModel' = multivariate OLS), following + -- the same policy as @svGridPI@. + mvEvalFramePI :: m -> Double -> ModelFrame -> Maybe ([Double], [Double]) + mvEvalFramePI _ _ _ = Nothing + +-- | [日本語]: 学習済の多変量モデルと along 変数から effect plot の 'ModelSpec' を作る。 +-- along は __必須引数__ (型で単/多変量を分離し誤用を弾く)。 +-- @df |>> (layer (scatter \"x1\" \"y\") <> toPlot (statModelMulti m (along \"x1\") <> holdAt Median))@。 +-- [English]: Builds an effect-plot 'ModelSpec' from a fitted multivariate +-- model and an along variable. along is a __mandatory argument__ (the type +-- separates single/multivariate to catch misuse at compile time). +-- @df |>> (layer (scatter \"x1\" \"y\") <> toPlot (statModelMulti m (along \"x1\") <> holdAt Median))@. +statModelMulti :: MultiVarModel m => m -> AlongSpec -> ModelSpec +statModelMulti m (AlongSpec v) = mempty { msRender = Just (renderGridMulti m v) } + +-- | [日本語]: effect plot の @VisualSpec@ を組む。 along を grid で動かし他変数を 'HoldAgg' で固定。 +-- byVar があれば第2変数の各値で曲線を色分け重畳する。 'statModelMulti' がクロージャ化。 +-- [English]: Builds the effect-plot @VisualSpec@. Sweeps along over the +-- grid while holding other variables fixed via 'HoldAgg'. If byVar is +-- present, overlays one color-coded curve per value of the second +-- variable. Closed over by 'statModelMulti'. +renderGridMulti :: MultiVarModel m => m -> Text -> GridOpts -> VisualSpec +renderGridMulti m alongV opts = + let mf = mvFrame m + (lo0, hi0) = alongRange mf alongV + (lo, hi) = fromMaybe (lo0, hi0) (goRange opts) + n = max 2 (goN opts) + gxs = linspace lo hi n + level = goLevel opts + hold = goHoldAt opts + -- 1 曲線分 (override = byVar 固定, mCol = 線色)。 + oneCurve override mCol = + case hold of + Marginalize -> marginalizeCurve opts m alongV level gxs override mCol + _ -> + let ef = evalFrame mf alongV hold override gxs + (mu, mbCI) = mvEvalFrame m level ef + mbPI = mvEvalFramePI m level ef + lineL = layer (goLineDeco opts mCol n (line (inline gxs) (inline mu))) + bL deco mb = case mb of + Just (los, his) -> layer (deco (band (inline gxs) (inline los) (inline his))) + Nothing -> mempty + ciDeco = goBandDeco opts mCol + piA = maybe 0.10 (* 0.5) (goAlpha opts) + piDeco = goBandDeco (opts { goAlpha = Just piA }) mCol + bands = case goBandMode opts of + BandOff -> mempty + BandCI -> bL ciDeco mbCI + BandPI -> case mbPI of + Just _ -> bL ciDeco mbPI + Nothing -> bL ciDeco mbCI -- PI 非提供 → CI + BandCIPI -> case mbPI of + Just _ -> bL piDeco mbPI <> bL ciDeco mbCI + Nothing -> bL ciDeco mbCI -- PI 非提供 → CI のみ + in bands <> lineL + in case goByVar opts of + Nothing -> oneCurve [] Nothing <> labelLegend opts + Just (v2, vals) -> + foldMap + (\(i, val) -> + let col = fromHex (effectPalette !! (i `mod` length effectPalette)) + in oneCurve [(v2, val)] (Just col)) + (zip [0 :: Int ..] vals) + +-- | [日本語]: Marginalize (PDP/AME): 各 grid 点で along=gx に固定し他変数は __観測分布のまま__、 +-- μ̂ を全観測行で平均する (band なし・曲線のみ。 全観測行 × grid で重い)。 +-- [English]: Marginalize (PDP/AME): at each grid point, fixes along=gx +-- while leaving other variables at __their observed distribution__, and +-- averages μ̂ over all observation rows (no band, curve only; heavy since +-- it's all observation rows × grid). +marginalizeCurve :: MultiVarModel m + => GridOpts -> m -> Text -> Double -> [Double] -> [(Text, Double)] -> Maybe Color -> VisualSpec +marginalizeCurve opts m alongV level gxs override mCol = + let mf = mvFrame m + nObs = mfNRows mf + base = mf { mfRoles = [ (nm, baseRole nm r) | (nm, r) <- mfRoles mf ] } + baseRole nm r + | isResponseRole r = RoleResponse (V.replicate nObs 0) + | Just fv <- lookup nm override = fixedRole r nObs fv + | otherwise = r -- 観測分布のまま + muAt gx = + let (mu, _) = mvEvalFrame m level (setAlong base alongV gx) + in sum mu / fromIntegral (max 1 (length mu)) + mus = map muAt gxs + in layer (goLineDeco opts mCol (length gxs) (line (inline gxs) (inline mus))) + +-- | [日本語]: along 変数の観測範囲 (effect grid の既定範囲)。 along が連続でなければ退避 @(0,1)@。 +-- [English]: The observed range of the along variable (the effect grid's +-- default range). Falls back to @(0,1)@ if along is not continuous. +alongRange :: ModelFrame -> Text -> (Double, Double) +alongRange mf v = case lookup v (mfRoles mf) of + Just (RoleContinuous xs) | not (V.null xs) -> (V.minimum xs, V.maximum xs) + _ -> (0, 1) + +-- | [日本語]: 各説明変数を 'HoldAgg' で固定値の定数列に差し替えた評価点 'ModelFrame' を合成する。 +-- along 変数は grid (gxs)、 応答列はダミー (@designMatrixF@ は応答を使わない)。 +-- override は byVar 等の明示固定で 'HoldAgg' より優先する。 +-- [English]: Composes an evaluation-point 'ModelFrame' by replacing each +-- predictor with a constant column fixed via 'HoldAgg'. The along variable +-- becomes the grid (gxs); the response column is a dummy (@designMatrixF@ +-- doesn't use the response). override (explicit fixes like byVar) takes +-- precedence over 'HoldAgg'. +evalFrame :: ModelFrame -> Text -> HoldAgg -> [(Text, Double)] -> [Double] -> ModelFrame +evalFrame mf alongV hold override gxs = + let n = length gxs + adjust (nm, role) + | isResponseRole role = (nm, RoleResponse (V.replicate n 0)) + | nm == alongV = (nm, RoleContinuous (V.fromList gxs)) + | Just fv <- lookup nm override = (nm, fixedRole role n fv) + | otherwise = (nm, holdRole hold n nm role) + in mf { mfRoles = map adjust (mfRoles mf), mfNRows = n } + +-- | [日本語]: frame の along 列だけを定数 gx に差し替える (行数据え置き、 Marginalize 用)。 +-- [English]: Replaces only the frame's along column with the constant gx +-- (row count unchanged; for Marginalize). +setAlong :: ModelFrame -> Text -> Double -> ModelFrame +setAlong mf alongV gx = + let n = mfNRows mf + adj (nm, role) + | nm == alongV = (nm, RoleContinuous (V.replicate n gx)) + | otherwise = (nm, role) + in mf { mfRoles = map adj (mfRoles mf) } + +isResponseRole :: VarRole -> Bool +isResponseRole (RoleResponse _) = True +isResponseRole _ = False + +-- | [日本語]: 1 変数を 'HoldAgg' で固定した定数列にする (連続は集約値、 factor は固定水準 index)。 +-- factor は Mean\/Median\/Mode\/Fixed すべて最頻水準に振替 (Reference のみ参照=index 0)。 +-- [English]: Turns one variable into a constant column fixed via +-- 'HoldAgg' (an aggregate value for continuous, a fixed-level index for +-- factor). For factor, Mean\/Median\/Mode\/Fixed all redirect to the most +-- common level (only Reference uses the reference level = index 0). +holdRole :: HoldAgg -> Int -> Text -> VarRole -> VarRole +holdRole hold n nm role = case role of + RoleContinuous xs -> + let v = case hold of + Mean -> meanV xs + Median -> medianV xs + Mode -> modeV xs + Reference -> meanV xs -- 連続に参照水準は無し → 平均で代替 + Marginalize -> meanV xs -- (Marginalize は別経路。 安全側に平均) + Fixed fm -> fromMaybe (meanV xs) (lookup nm fm) + in RoleContinuous (V.replicate n v) + RoleFactor levels idx -> + let fixIdx = case hold of + Reference -> 0 + Fixed fm -> maybe (modeIdx idx) (clampIdx levels . round) (lookup nm fm) + _ -> modeIdx idx + in RoleFactor levels (V.replicate n fixIdx) + RoleResponse _ -> RoleResponse (V.replicate n 0) + +-- | [日本語]: 明示値 (byVar / Fixed override) で 1 変数を定数列にする。 +-- [English]: Turns one variable into a constant column using an explicit +-- value (byVar / Fixed override). +fixedRole :: VarRole -> Int -> Double -> VarRole +fixedRole role n fv = case role of + RoleContinuous _ -> RoleContinuous (V.replicate n fv) + RoleFactor levels _ -> RoleFactor levels (V.replicate n (clampIdx levels (round fv))) + RoleResponse _ -> RoleResponse (V.replicate n fv) + +clampIdx :: [Text] -> Int -> Int +clampIdx levels i = max 0 (min (length levels - 1) i) + +-- | [日本語]: byVar 曲線の固定色パレット (層別の値ごとに 1 色)。 +-- [English]: Fixed color palette for byVar curves (one color per +-- stratification value). +effectPalette :: [Text] +effectPalette = + [ "#1f77b4", "#ff7f0e", "#2ca02c", "#d62728", "#9467bd", "#8c564b", "#e377c2" ] + +-- =========================================================================== +-- 応答曲面 3D 直結 — plot Phase 24 A3 (fit 済み多変量モデル → surface) +-- +-- JMP Surface Profiler 同型: 2 因子 (v1, v2) を grid で動かし他変数を 'HoldAgg' +-- で固定、 μ̂ を 3D surface (z colormap 既定 ON) で描く。 effect plot +-- ('statModelMulti') の 2 因子版で、 評価核は同じ 'mvEvalFrame'。 +-- =========================================================================== + +-- | [日本語]: 2 因子 grid + 'HoldAgg' の評価点 frame ('evalFrame' の 2 変数版)。 +-- 行 = v2 (外側)、 列 = v1 (内側) — 'P3.surface3D' の grid 規約 +-- (row = y 方向) に一致させる。 +-- [English]: The evaluation-point frame for a two-factor grid + 'HoldAgg' +-- (the two-variable version of 'evalFrame'). Rows = v2 (outer), columns = +-- v1 (inner) — matching 'P3.surface3D''s grid convention (row = y +-- direction). +evalFrame2 :: ModelFrame -> Text -> Text -> HoldAgg -> [Double] -> [Double] -> ModelFrame +evalFrame2 mf v1 v2 hold gxs gys = + let n = length gxs * length gys + x1s = [ gx | _ <- gys, gx <- gxs ] + x2s = [ gy | gy <- gys, _ <- gxs ] + adjust (nm, role) + | isResponseRole role = (nm, RoleResponse (V.replicate n 0)) + | nm == v1 = (nm, RoleContinuous (V.fromList x1s)) + | nm == v2 = (nm, RoleContinuous (V.fromList x2s)) + | otherwise = (nm, holdRole hold n nm role) + in mf { mfRoles = map adjust (mfRoles mf), mfNRows = n } + +-- | [日本語]: 応答曲面の数値核: @(gxs, gys, grid)@。 @grid !! j !! i = μ̂(gxs!!i, gys!!j)@。 +-- [English]: The numerical core of the response surface: @(gxs, gys, +-- grid)@. @grid !! j !! i = μ̂(gxs!!i, gys!!j)@. +surfaceGrid :: MultiVarModel m + => m -> Text -> Text -> SurfaceOpts -> ([Double], [Double], [[Double]]) +surfaceGrid m v1 v2 opts = + let mf = mvFrame m + (xlo, xhi) = fromMaybe (alongRange mf v1) (soXRange opts) + (ylo, yhi) = fromMaybe (alongRange mf v2) (soYRange opts) + n = max 2 (soN opts) + gxs = linspace xlo xhi n + gys = linspace ylo yhi n + ef = evalFrame2 mf v1 v2 (soHoldAt opts) gxs gys + (mu, _) = mvEvalFrame m 0.95 ef + in (gxs, gys, chunkRows n mu) + +chunkRows :: Int -> [a] -> [[a]] +chunkRows k = go + where go [] = [] + go xs = let (h, t) = splitAt k xs in h : go t + +-- | [日本語]: fit 済み多変量モデル → 3D 応答曲面 (z colormap 既定 ON・colorbar 自動)。 +-- @saveSVG3D path (surfaceOf m "x1" "x2" <> dataScatter3DOf m "x1" "x2")@。 +-- [English]: Fitted multivariate model → 3D response surface (z colormap +-- on by default, colorbar automatic). +-- @saveSVG3D path (surfaceOf m "x1" "x2" <> dataScatter3DOf m "x1" "x2")@. +surfaceOf :: MultiVarModel m => m -> Text -> Text -> P3.VisualSpec3D +surfaceOf m v1 v2 = surfaceOfWith m v1 v2 defaultSurfaceOpts + +-- | [日本語]: オプション付き ('SurfaceOpts': grid 点数・hold・範囲)。 +-- [English]: The variant with options ('SurfaceOpts': grid point count, +-- hold, range). +surfaceOfWith :: MultiVarModel m => m -> Text -> Text -> SurfaceOpts -> P3.VisualSpec3D +surfaceOfWith m v1 v2 opts = + let (gxs, gys, grid') = surfaceGrid m v1 v2 opts + in P3.layer3D ( P3.surface3DGrid grid' + <> P3.xRange3D (head gxs, last gxs) + <> P3.yRange3D (head gys, last gys) + <> P3.colormap3D ) + +-- | [日本語]: 実測点の 3D overlay: 訓練データの @(v1, v2, y)@ を scatter3D で重畳。 +-- [English]: A 3D overlay of the observed points: overlays the training +-- data's @(v1, v2, y)@ via scatter3D. +dataScatter3DOf :: MultiVarModel m => m -> Text -> Text -> P3.VisualSpec3D +dataScatter3DOf m v1 v2 = + let mf = mvFrame m + contOf nm = case lookup nm (mfRoles mf) of + Just (RoleContinuous xs) -> V.toList xs + _ -> [] + ys = case [ v | (_, RoleResponse v) <- mfRoles mf ] of + (v : _) -> V.toList v + [] -> [] + pts = zipWith3 Point3 (contOf v1) (contOf v2) ys + in P3.layer3D (P3.scatter3DPoints pts <> P3.color3D (fromHex "#d62728") <> P3.size3D 4) + +meanV :: V.Vector Double -> Double +meanV xs | V.null xs = 0 + | otherwise = V.sum xs / fromIntegral (V.length xs) + +medianV :: V.Vector Double -> Double +medianV xs + | null ys = 0 + | odd k = ys !! (k `div` 2) + | otherwise = (ys !! (k `div` 2 - 1) + ys !! (k `div` 2)) / 2 + where ys = sort (V.toList xs) + k = length ys + +-- | [日本語]: 連続列の最頻 (観測値の完全一致でグループ化。 繰り返しのない真の連続では任意)。 +-- [English]: The mode of a continuous column (grouped by exact value +-- match; arbitrary for genuinely continuous data with no repeats). +modeV :: V.Vector Double -> Double +modeV xs | V.null xs = 0 + | otherwise = mostCommon (V.toList xs) + +-- | [日本語]: factor の最頻水準 index。 +-- [English]: The index of the most common factor level. +modeIdx :: V.Vector Int -> Int +modeIdx idx | V.null idx = 0 + | otherwise = mostCommon (V.toList idx) + +mostCommon :: Ord a => [a] -> a +mostCommon = fst . maximumBy (comparing snd) + . map (\g -> (head g, length g)) . group . sort + +-- =========================================================================== +-- 共有描画 helper (複数のモデル族が利用) +-- =========================================================================== + +-- | [日本語]: CI band の既定 level (95%)。 +-- [English]: The default level for a CI band (95%). +defaultCILevel :: Double +defaultCILevel = 0.95 + +-- | [日本語]: 分位線の色パレット (τ 昇順に割当て。 必要数を循環)。 +-- [English]: Color palette for quantile lines (assigned in ascending τ +-- order; cycles if more are needed). +quantilePalette :: [T.Text] +quantilePalette = + [ "#4575b4", "#d73027", "#1a9850", "#984ea3", "#ff7f00", "#377eb8" ] + +-- | [日本語]: 階段関数の頂点列を作る。 開始値 @s0@ (= t=0 での値) から、 各 @(tᵢ, sᵢ)@ について +-- 直前の高さで @tᵢ@ まで水平に来てから @sᵢ@ に垂直に跳ぶ 2 頂点を出す。 +-- [English]: Builds the vertex list of a step function. Starting from +-- @s0@ (= the value at t=0), for each @(tᵢ, sᵢ)@ emits two vertices: a +-- horizontal run to @tᵢ@ at the previous height, then a vertical jump to +-- @sᵢ@. +stepVerts :: Double -> [(Double, Double)] -> [(Double, Double)] +stepVerts s0 pts = (0, s0) : go s0 pts + where + go _ [] = [] + go prev ((t, s) : rest) = (t, prev) : (t, s) : go s rest + +-- | [日本語]: grid index を x として複数曲線を色分け重畳する内部 helper。 +-- [English]: An internal helper that overlays multiple color-coded curves +-- using the grid index as x. +gridCurves :: [(Text, [Double])] -> VisualSpec +gridCurves named = + let mkLine (lbl, ys) = + let xs = [ fromIntegral i | i <- [1 .. length ys] ] :: [Double] + in layer ( line (inline xs) (inline ys) + <> colorBy (inlineCat (replicate (length ys) lbl)) ) + in mconcat (map mkLine named) + +-- | [日本語]: 特徴重要度 → bar layer ("f1", "f2", … をカテゴリ軸に・値=重要度)。 +-- [English]: Feature importances → bar layer ("f1", "f2", … as the +-- category axis; value = importance). +importanceBar :: [Double] -> VisualSpec +importanceBar imps = + let labels = [ "f" <> T.pack (show k) | k <- [1 .. length imps] ] + in layer (bar (inlineCat labels) (inline imps)) + +-- | [日本語]: 行列の第 @i@/@j@ 列を (xs, ys) として取り出す (列不足は 0 埋め)。 +-- [English]: Extracts a matrix's @i@-th\/@j@-th columns as (xs, ys) +-- (missing columns are zero-filled). +matCols2 :: LA.Matrix Double -> Int -> Int -> ([Double], [Double]) +matCols2 m i j = + let cols = LA.toColumns m + colAt k = if k < length cols then LA.toList (cols !! k) else replicate (LA.rows m) 0 + in (colAt i, colAt j) + +-- | [日本語]: クラス代表点 (平均) をクラス色 ✚ で散布する (第 0/1 特徴)。 Discriminant / +-- NaiveBayes(Gaussian) の data-free 代表図。 +-- [English]: Scatters each class's representative point (mean) as a +-- class-colored ✚ (features 0/1). A data-free representative figure for +-- Discriminant \/ NaiveBayes(Gaussian). +classMeansScatter :: [[Double]] -> [Int] -> VisualSpec +classMeansScatter rows cids = classMeansScatterNamed rows cids [] + +-- | [日本語]: 'classMeansScatter' の __クラス名つき__版。 @names@ があれば凡例をクラス名 (levels) +-- に、 無ければ整数へフォールバック (@names !! k@・範囲外は show)。 df|-> 経路が +-- levels を載せた分類モデルの代表図で使う。 +-- [English]: The __class-named__ variant of 'classMeansScatter'. If +-- @names@ is present, the legend uses the class names (levels); otherwise +-- falls back to integers (@names !! k@; out-of-range uses show). Used by +-- the representative figure of classification models where the df|-> +-- path attaches levels. +classMeansScatterNamed :: [[Double]] -> [Int] -> [Text] -> VisualSpec +classMeansScatterNamed rows cids names + | null rows = mempty + | otherwise = + let xs = [ if not (null r) then head r else 0 | r <- rows ] + ys = [ if length r >= 2 then r !! 1 else 0 | r <- rows ] + nameOf k | k >= 0 && k < length names = names !! k + | otherwise = T.pack (show k) + labs = map nameOf cids + in layer ( scatter (inline xs) (inline ys) + <> colorBy (inlineCat labs) + <> shape MShCross ) + +-- | [日本語]: chain index → 色 (effectPalette を巡回)。 +-- [English]: chain index → color (cycles through effectPalette). +chainColor :: Int -> Text +chainColor k = effectPalette !! (k `mod` length effectPalette) + +-- =========================================================================== +-- 分類器抽象 (Discriminant / NaiveBayes / KNN 共通) — Phase 68 A3 +-- =========================================================================== + +-- | [日本語]: 学習済分類器を評価点行列で走らせ、 各行の予測クラスを返す共通インターフェース。 +-- (@decisionBoundaryOf@ / @confusionOf@ が分類器種に依らず動くための薄い抽象)。 +-- [English]: A common interface that runs a fitted classifier over an +-- evaluation-point matrix and returns each row's predicted class. (A thin +-- abstraction letting @decisionBoundaryOf@ \/ @confusionOf@ work +-- regardless of classifier type.) +class ClassPredict c where + predictClasses :: c -> LA.Matrix Double -> [Int] + -- | [日本語]: クラス番号 0..K-1 に対応する __クラス名 (levels)__。 高レベル @df |->@ 経路が + -- fit 時に載せる (factor 列なら levels 名・数値列なら数値)。 既定は空 = 名前を + -- 持たないモデル (@confusionOf@ 等は空なら整数ラベルにフォールバック)。 + -- [English]: The __class names (levels)__ corresponding to class + -- numbers 0..K-1. Attached by the high-level @df |->@ path at fit time + -- (level names for a factor column, numbers for a numeric column). + -- Defaults to empty = a model with no names (@confusionOf@ etc. fall + -- back to integer labels when empty). + classNamesOf :: c -> [Text] + classNamesOf _ = [] + +-- =========================================================================== +-- 回帰診断の可視化 (係数 forest / 実測vs予測) — Phase 72.4/72.5 +-- +-- 係数表 (@coefSummary@・'Hanalyze.Diagnostics') と各モデルの実測/予測ペアを +-- 図に落とす薄い玄関。 数値層 (係数統計・予測) は別パッケージに依存しない +-- 'Diagnostics' / 各 fit が持ち、 ここ (別パッケージ hanalyze-plot 側) では +-- @VisualSpec@ 化だけを担う。 +-- =========================================================================== + +-- | [日本語]: fit 済モデルから (実測値, 予測値) の対を取り出せる能力。 実測値は +-- @fitted + residual@ で復元する (回帰一般で成り立つ)。 instance は各モデル族の +-- 'Plottable' と同じ Plot.* 側に置く (orphan・クラス=Core / instance=族 module)。 +-- [English]: The capability to extract (observed, predicted) pairs from a +-- fitted model. The observed value is reconstructed as @fitted + +-- residual@ (holds for regression in general). Instances live on the same +-- Plot.* side as each model family's 'Plottable' (orphan instances; class +-- in Core, instance in the family module). +class HasObsPred m where + -- | [日本語]: @(observed, predicted)@。 長さは観測数 n で一致する。 + -- [English]: @(observed, predicted)@. Both have length equal to the + -- number of observations n. + obsPredPairs :: m -> ([Double], [Double]) + +-- | [日本語]: 実測 vs 予測プロット。 x=実測値・y=予測値の散布に @y = x@ の参照線 (灰の破線) を +-- 重ねる。 点が参照線に近いほど当てはまりが良い (残差が小さい)。 +-- [English]: Observed-vs-predicted plot. Overlays a @y = x@ reference line +-- (gray dashed) on a scatter of x=observed, y=predicted. The closer the +-- points are to the reference line, the better the fit (smaller +-- residuals). +obsVsPred :: HasObsPred m => m -> VisualSpec +obsVsPred m = let (obs, prd) = obsPredPairs m in obsPredSpec obs prd + +-- | [日本語]: (実測, 予測) のリストから実測 vs 予測 spec を組む。 'obsVsPred' の純データ版 +-- (テスト・任意のペアからの作図に再利用)。 空入力は空図。 +-- [English]: Builds an observed-vs-predicted spec from lists of +-- (observed, predicted). The pure-data variant of 'obsVsPred' (reusable +-- for tests or plotting arbitrary pairs). Empty input yields an empty +-- figure. +obsPredSpec :: [Double] -> [Double] -> VisualSpec +obsPredSpec obs prd + | null obs = mempty + | otherwise = + let lo = minimum (obs ++ prd) + hi = maximum (obs ++ prd) + in layer ( line (inline [lo, hi]) (inline [lo, hi]) + <> linetype LtDashed + <> color (fromHex "#888888") ) + <> layer (scatter (inline obs) (inline prd)) + <> xLabel "observed" + <> yLabel "predicted" + +-- | [日本語]: 係数 forest plot。 各係数の点推定 ('crEstimate') を中心、 95% CI ('crCI95') の +-- 半幅を誤差バーとして 1 行ずつ水平に並べ、 0 (= 効果なし) に参照線を引く。 解析 +-- Wald CI (@coefSummary@) を持つ線形系で使う (CI は左右対称なので半幅で表せる)。 +-- bootstrap 由来の非対称 CI を図にしたい場合は @coefSummaryBoot@ の行から個別に組む。 +-- [English]: Coefficient forest plot. Lays out each coefficient's point +-- estimate ('crEstimate') as the center, one row per coefficient, with the +-- half-width of the 95% CI ('crCI95') as the error bar, and draws a +-- reference line at 0 (= no effect). Used for linear systems with an +-- analytic Wald CI (@coefSummary@) (since the CI is symmetric and can be +-- expressed as a half-width). To plot asymmetric bootstrap-derived CIs, +-- build the figure manually from 'coefSummaryBoot''s rows instead. +coefForest :: HasCoefSummary m => m -> VisualSpec +coefForest m = + let rows = coefSummary m + names = [ crTerm r | r <- rows ] + ests = [ crEstimate r | r <- rows ] + errs = [ (hi - lo) / 2 | r <- rows, let (lo, hi) = crCI95 r ] + in if null rows + then mempty + else layer (forest (inlineCat names) (inline ests) (inline errs) <> forestNull 0) diff --git a/src/Hanalyze/Plot/Linear.hs b/src/Hanalyze/Plot/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Plot/Linear.hs @@ -0,0 +1,306 @@ +-- | +-- Module : Hanalyze.Plot.Linear +-- Description : hgg 連携層 — 線形モデル族の図化 instance +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: hgg 連携層 — __線形モデル族__ の図化 instance。 +-- +-- ⚠ 親 'Hanalyze.Plot' と同じく別パッケージ @hanalyze-plot@ に属し、 +-- @cabal build --project-file=cabal.project.plot@ で build される。 共通基盤 (class / ModelSpec / grid 評価核) は +-- 'Hanalyze.Plot.Core' を import して取り込む (orphan instance を許容: +-- クラス=Core・instance=ここ・型=Wrappers)。 +-- +-- 担当する型 (= LM 系・GLM 系・WLS): +-- LMModel / MultiLMModel / WeightedLMModel / GLMModel / MultiGLMModel。 +-- +-- [English]: hgg integration layer — plotting instances for the +-- __linear-model family__. +-- +-- ⚠ Lives in the same separate package @hanalyze-plot@ as its parent +-- 'Hanalyze.Plot', built via @cabal build --project-file=cabal.project.plot@. +-- The shared foundation +-- (class \/ ModelSpec \/ grid evaluation core) is pulled in via +-- 'Hanalyze.Plot.Core' (orphan instances allowed: class in Core, +-- instances here, types in Wrappers). +-- +-- Types covered (= LM family, GLM family, WLS): +-- LMModel \/ MultiLMModel \/ WeightedLMModel \/ GLMModel \/ MultiGLMModel. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Hanalyze.Plot.Linear + ( familyObsDist + ) where + +import Data.List (sortBy, zip4) +import Data.Ord (comparing) +import qualified Hanalyze.Model.HBM.Distribution as BD +import qualified Numeric.LinearAlgebra as LA + +import Graphics.Hgg.Spec ( layer, inline + , scatter, line, band ) + +import Hanalyze.Model.Wrappers +import Hanalyze.Plot.Core +import Hanalyze.Fit (weightedR2) +import Hanalyze.Model.Core (FitResult, coefficientsV, fittedV, residualsV, rSquared1) +import Hanalyze.Model.GLM ( Family (..), LinkFn (..), GlmPredictCI (..) + , predictGlmMuWithCI ) +import Hanalyze.Model.LM ( CIBand (..), confidenceBand, confidenceBandAt + , predictionBandAt ) +import Hanalyze.Model.Formula.Design (designMatrixF) + +-- =========================================================================== +-- 多変量モデル型 (effect plot 用、 新規 fit) +-- +-- 既存の単変数 'LMModel' / 'GLMModel' (設計行列が @[1, x]@ 固定) とは別型。 +-- formula 文字列 + @DataFrame@ で多変量 fit し、 formula を保持して評価点設計行列を +-- 組む (HoldAgg 固定 + along grid)。 ★GLM は formula 経路が未整備なので +-- 'designMatrixF' で設計行列を作り 'fitGLMFull' を直接呼ぶ。 +-- =========================================================================== + +instance MultiVarModel MultiLMModel where + mvFrame = mlmFrame + mvEvalFrame m level ef = + case designMatrixF (mlmFormula m) ef of + Left _ -> ([], Nothing) + Right (xe, _) -> + let cib = confidenceBandAt (mlmDesign m) (mlmResult m) level xe + los = lowerBound cib + his = upperBound cib + mu = zipWith (\l h -> (l + h) / 2) los his + in (mu, Just (los, his)) + -- 多変量 OLS の closed-form PI (評価点設計行列 → predictionBandAt)。 + mvEvalFramePI m level ef = + case designMatrixF (mlmFormula m) ef of + Left _ -> Nothing + Right (xe, _) -> + let pib = predictionBandAt (mlmDesign m) (mlmResult m) level xe + in Just (lowerBound pib, upperBound pib) + +instance MultiVarModel MultiGLMModel where + mvFrame = mglmFrame + mvEvalFrame m level ef = + case designMatrixF (mglmFormula m) ef of + Left _ -> ([], Nothing) + Right (xe, _) -> + let beta = coefficientsV (mglmResult m) + cis = [ predictGlmMuWithCI (mglmLink m) level beta (mglmSigma m) r + | r <- LA.toRows xe ] + in (map gpMu cis, Just (map gpLo cis, map gpHi cis)) + +-- =========================================================================== +-- 線形モデル (描画可能) +-- +-- 'FitResult' (数値核) は設計行列 X を保持しないが、 回帰線・CI band を描くには +-- X が要る (@confidenceBand@ は X 引数)。 そこで X と生 predictor を束ねた +-- 「描画可能なモデル」 を別型にする (= plot Phase 15 §2.1 の開放論点を (i) で確定)。 +-- =========================================================================== + + +instance Plottable LMModel where + -- 散布図に重ねる回帰線 + CI band。 @confidenceBand@ は **訓練点**で評価し + -- @yHats ± se@ を返す (= grid を渡すと fitted と不整合)。 ゆえに合成 grid を + -- 使わず、 訓練 x を昇順ソートして直線を結ぶ (= 単回帰なら直線で grid と同形、 + -- かつ @confidenceBand@ を無改修で再利用できる)。 ± 半幅 errorY = se。 + toPlot m = + let res = lmResult m + xs = LA.toList (lmXraw m) + yhat = LA.toList (fittedV res) + cib = confidenceBand (lmDesign m) res defaultCILevel + se = zipWith (-) (upperBound cib) yhat -- upper - ŷ = 片側半幅 + sorted = sortBy (comparing (\(x, _, _) -> x)) (zip3 xs yhat se) + xsS = [ x | (x, _, _) <- sorted ] + yhatS = [ y | (_, y, _) <- sorted ] + seS = [ e | (_, _, e) <- sorted ] + in layer (band (inline xsS) (inline (zipWith (-) yhatS seS)) (inline (zipWith (+) yhatS seS))) + <> layer (line (inline xsS) (inline yhatS)) + + -- 残差診断 (代表回帰線 + 残差 vs fitted)。 + diagnosticPlots m = + let res = lmResult m + yhat = LA.toList (fittedV res) + resd = LA.toList (residualsV res) + in [ toPlot m + , layer (scatter (inline yhat) (inline resd)) + ] + +-- | [日本語]: grid 評価。 grid x で設計行列 @[1, x]@ を再構築し、 +-- 訓練の分散核を流用する @confidenceBandAt@ で滑らかな曲線 + 対称 CI 帯を出す。 +-- [English]: Grid evaluation. Rebuilds the design matrix @[1, x]@ at the +-- grid x, reusing the training variance kernel via @confidenceBandAt@ to +-- produce a smooth curve + symmetric CI band. +instance SingleVarModel LMModel where + svRange m = let xs = LA.toList (lmXraw m) in (minimum xs, maximum xs) + svGrid m level gxs = + let xEval = LA.fromColumns [ LA.konst 1 (length gxs), LA.fromList gxs ] + cib = confidenceBandAt (lmDesign m) (lmResult m) level xEval + los = lowerBound cib + his = upperBound cib + mu = zipWith (\l h -> (l + h) / 2) los his + in (mu, Just (los, his)) + -- PI = closed form σ̂²(1 + xᵀ(XᵀX)⁻¹x) (statsmodels obs_ci と一致)。 + svGridPI m level gxs = + let xEval = LA.fromColumns [ LA.konst 1 (length gxs), LA.fromList gxs ] + pib = predictionBandAt (lmDesign m) (lmResult m) level xEval + in Just (lowerBound pib, upperBound pib) + -- A8: 係数 [β₀, β₁] と R² (式/R² 凡例注釈用)。 + svCoefR2 m = Just (LA.toList (coefficientsV (lmResult m)), rSquared1 (lmResult m)) + -- ブートストラップ: 加法誤差ゆえ obsDist=Nothing (μ + 再標本化残差)。 + svBootKit m = Just BootKit + { bkX = LA.toList (lmXraw m) + , bkY = zipWith (+) (LA.toList (fittedV (lmResult m))) (LA.toList (residualsV (lmResult m))) + , bkRefit = \xs ys -> lmModel (LA.fromList xs) (LA.fromList ys) + , bkObsDist = Nothing } + +-- =========================================================================== +-- 一般化線形モデル (描画可能) +-- +-- GLM の不確実性帯は **μ (応答) スケールで非対称** (線形予測子 η の対称 Wald CI を +-- 逆リンク gInv で μ に写すため、 Logit/Log 等では下側・上側の半幅が異なる)。 ゆえに +-- LMModel/GPResult の対称 band (ŷ±se) では忠実に描けない。 そこで +-- 下境界 lo / 上境界 hi を別々に持てる 'band' layer (= MBand area fill) を使い、 μ 曲線は +-- 'line' で重ねる。 帯は **訓練点での Wald CI** を 'predictGlmMuWithCI' で評価する +-- (= grid 補間でなく fit と整合)。 'fitGLMFull' が返す逆 Fisher 情報 Σ=(XᵀWX)⁻¹ が要る。 +-- =========================================================================== + +instance Plottable GLMModel where + -- μ 曲線 + 非対称 Wald CI 帯。 各訓練点 (設計行列の行) で 'predictGlmMuWithCI' を + -- 評価し、 x 昇順にソートして band (lo→hi の area) と μ 折れ線を重ねる。 帯を先に + -- 置いて μ 線を上に描く。 + toPlot m = + let beta = coefficientsV (glmResult m) + rows = LA.toRows (glmDesign m) + cis = [ predictGlmMuWithCI (glmLink m) defaultCILevel beta (glmSigma m) r + | r <- rows ] + quads = sortBy (comparing (\(x, _, _, _) -> x)) + (zip4 (LA.toList (glmXraw m)) + (map gpMu cis) (map gpLo cis) (map gpHi cis)) + xsS = [ x | (x, _, _, _) <- quads ] + muS = [ u | (_, u, _, _) <- quads ] + loS = [ l | (_, _, l, _) <- quads ] + hiS = [ h | (_, _, _, h) <- quads ] + in layer (band (inline xsS) (inline loS) (inline hiS)) + <> layer (line (inline xsS) (inline muS)) + + -- 残差診断 (μ 曲線 + 帯、 残差 vs fitted μ̂)。 + diagnosticPlots m = + let res = glmResult m + yhat = LA.toList (fittedV res) + resd = LA.toList (residualsV res) + in [ toPlot m + , layer (scatter (inline yhat) (inline resd)) + ] + +-- | [日本語]: grid 評価。 grid x の行 @[1, x]@ を 'predictGlmMuWithCI' に渡し、 +-- μ スケールの非対称 Wald CI 帯を滑らかに評価する (band lo/hi は別々に保持)。 +-- [English]: Grid evaluation. Passes each grid-x row @[1, x]@ to +-- 'predictGlmMuWithCI', smoothly evaluating the asymmetric Wald CI band +-- on the μ scale (band lo\/hi are kept separately). +instance SingleVarModel GLMModel where + svRange m = let xs = LA.toList (glmXraw m) in (minimum xs, maximum xs) + svGrid m level gxs = + let beta = coefficientsV (glmResult m) + cis = [ predictGlmMuWithCI (glmLink m) level beta (glmSigma m) + (LA.fromList [1, gx]) + | gx <- gxs ] + in (map gpMu cis, Just (map gpLo cis, map gpHi cis)) + -- PI は **Gaussian + Identity のみ** = LM の closed form に帰着 (μ̂ = Xβ・W=I)。 + -- 非 Gaussian (Poisson/Binomial) は予測区間が応答分布の離散/非対称分位を要し + -- closed form で出ないため 'Nothing' (over-claim しない・CI 帯と同じ部分集合方針)。 + svGridPI m level gxs = case (glmFamily m, glmLink m) of + (Gaussian, Identity) -> + let xEval = LA.fromColumns [ LA.konst 1 (length gxs), LA.fromList gxs ] + pib = predictionBandAt (glmDesign m) (glmResult m) level xEval + in Just (lowerBound pib, upperBound pib) + _ -> Nothing + -- ブートストラップ: 新規観測は Family(μ) から parametric にドロー (Poisson/Bernoulli)。 + -- これにより closed form PI を持たない非 Gaussian GLM でも PI を出せる。 + svBootKit m = Just BootKit + { bkX = LA.toList (glmXraw m) + , bkY = zipWith (+) (LA.toList (fittedV (glmResult m))) (LA.toList (residualsV (glmResult m))) + , bkRefit = \xs ys -> glmModel (glmFamily m) (glmLink m) (LA.fromList xs) (LA.fromList ys) + , bkObsDist = familyObsDist (glmFamily m) } + +-- =========================================================================== +-- 重み付き最小二乗 (WLS) +-- =========================================================================== + +-- | [日本語]: grid 経路に委譲 (内側 LM の svGrid/PI は非スケール xEval × スケール設計で正しい +-- WLS CI を出す)。 'svRange' は元 x ('lmXraw') から。 @svCoefR2@ のみ override し、 +-- R² は statsmodels WLS と一致する weighted R² を返す (β̂ は内側のスケール OLS が WLS)。 +-- [English]: Delegates to the grid path (the inner LM's svGrid\/PI produces +-- the correct WLS CI from the unscaled xEval × scaled design). 'svRange' +-- comes from the raw x ('lmXraw'). Only @svCoefR2@ is overridden, returning +-- a weighted R² matching statsmodels WLS (β̂ itself is the inner scaled +-- OLS, which is the WLS estimate). +instance SingleVarModel WeightedLMModel where + svRange (WeightedLMModel m _ _) = svRange m + svGrid (WeightedLMModel m _ _) = svGrid m + svGridPI (WeightedLMModel m _ _) = svGridPI m + svCoefR2 (WeightedLMModel m ws ys) = + let coefs = LA.toList (coefficientsV (lmResult m)) + yhats = case coefs of -- ŷ = β₀ + β₁x (元スケール) + (b0 : b1 : _) -> [ b0 + b1 * x | x <- LA.toList (lmXraw m) ] + [b0] -> [ b0 | _ <- LA.toList (lmXraw m) ] + _ -> ys + in Just (coefs, weightedR2 ws ys yhats) + +-- | [日本語]: ★訓練点経路 ('LMModel' の素の @toPlot@) を__使わず__ grid 経路 ('statModel') に +-- 固定する。 これで WLS 線+CI が元 x スケールで出て、 元データ散布図と整合する。 +-- [English]: ★Deliberately does __not__ use the training-point path +-- (plain 'LMModel' @toPlot@), fixing instead on the grid path +-- ('statModel'). This makes the WLS line+CI come out on the original x +-- scale, matching the original data scatter. +instance Plottable WeightedLMModel where + toPlot = toPlot . statModel + +-- =========================================================================== +-- GLM family → 観測分布 (ブートストラップ PI 用) +-- =========================================================================== + +-- | [日本語]: GLM family → 新規観測の分布関数 (μ ↦ 分布。 ブートストラップ PI の parametric ドロー用)。 +-- Gaussian は加法残差で扱うため 'Nothing' (σ̂ を別途要さない)。 'svBootKit' が使う。 +-- [English]: GLM family → distribution function for new observations +-- (μ ↦ distribution; used for parametric draws in bootstrap PI). Gaussian +-- is handled via additive residuals, so it returns 'Nothing' (no separate +-- σ̂ needed). Used by 'svBootKit'. +familyObsDist :: Family -> Maybe (Double -> BD.Distribution Double) +familyObsDist Poisson = Just (\mu -> BD.Poisson (max 1e-9 mu)) +familyObsDist Binomial = Just (\mu -> BD.Bernoulli (min (1 - 1e-12) (max 1e-12 mu))) +familyObsDist Gaussian = Nothing + +-- =========================================================================== +-- 実測 vs 予測 (HasObsPred) — Phase 72.4 +-- +-- 実測値 = fitted + residual で復元する (回帰一般)。 WLS は内側 fit が √w スケール +-- なので予測を 1/√w で元スケールへ戻し、 実測は保持した元 y ('wlmY') を使う。 +-- =========================================================================== + +-- | [日本語]: FitResult から (実測, 予測) を復元する共通ヘルパ。 +-- [English]: A shared helper that recovers (observed, predicted) from a +-- FitResult. +obsPredFromFit :: FitResult -> ([Double], [Double]) +obsPredFromFit r = + let f = LA.toList (fittedV r) + e = LA.toList (residualsV r) + in (zipWith (+) f e, f) + +instance HasObsPred LMModel where + obsPredPairs = obsPredFromFit . lmResult + +instance HasObsPred MultiLMModel where + obsPredPairs = obsPredFromFit . mlmResult + +instance HasObsPred GLMModel where + obsPredPairs = obsPredFromFit . glmResult + +instance HasObsPred MultiGLMModel where + obsPredPairs = obsPredFromFit . mglmResult + +instance HasObsPred WeightedLMModel where + obsPredPairs m = + let fScaled = LA.toList (fittedV (lmResult (wlmInner m))) + prd = zipWith (\f w -> if w > 0 then f / sqrt w else f) fScaled (wlmWeights m) + in (wlmY m, prd) diff --git a/src/Hanalyze/Plot/ML.hs b/src/Hanalyze/Plot/ML.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Plot/ML.hs @@ -0,0 +1,2161 @@ +-- | +-- Module : Hanalyze.Plot.ML +-- Description : hgg 連携層 — ML / 統計モデル連携族の図化 instance + 抽出子 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: hgg 連携層 — __ML / 統計モデル連携族__ の図化 instance + 抽出子。 +-- +-- ⚠ 親 'Hanalyze.Plot' と同じく別パッケージ @hanalyze-plot@ に属し、 +-- @cabal build --project-file=cabal.project.plot@ で build される。 共通基盤 (class / ModelSpec / grid 評価核) は +-- 'Hanalyze.Plot.Core' を import して取り込む (orphan instance を許容: +-- クラス=Core・instance=ここ・型=Wrappers/各 Model module)。 +-- +-- 担当する型・ヘルパ: +-- クラスタリング (KMeans) / 木・アンサンブル (PCA/RF/GB/DT) / 分類 +-- (Discriminant/NaiveBayes/KNN) / 次元圧縮 (PLS) / 時系列・生存・FDA +-- (Forecast/GARCH/AFT/FunctionalPCA/FLM) / 罰則回帰・因果探索 (Reg/LiNGAM) / +-- 記述統計・検定 (TestResult)。 新規 plot mark は不要 (既存 mark の組合せ)。 +-- +-- [English]: hgg integration layer — __plotting instances and extractors__ +-- for the ML \/ statistical-model family. +-- +-- ⚠ Lives in the same separate package @hanalyze-plot@ as the parent +-- 'Hanalyze.Plot', built via @cabal build --project-file=cabal.project.plot@. +-- It imports the common +-- foundation (class \/ ModelSpec \/ grid evaluation core) from +-- 'Hanalyze.Plot.Core' (orphan instances are permitted: class = +-- Core, instance = here, type = Wrappers \/ each Model module). +-- +-- Types and helpers covered: +-- clustering (KMeans) \/ trees and ensembles (PCA\/RF\/GB\/DT) \/ +-- classification (Discriminant\/NaiveBayes\/KNN) \/ dimensionality reduction +-- (PLS) \/ time series, survival, FDA (Forecast\/GARCH\/AFT\/FunctionalPCA\/FLM) +-- \/ penalized regression and causal discovery (Reg\/LiNGAM) \/ descriptive +-- statistics and testing (TestResult). No new plot marks are needed +-- (combinations of existing marks suffice). +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Hanalyze.Plot.ML + ( -- * クラスタリング + clusterScatterOf + , centroidsOf + -- * クラスタを囲む (凸包輪郭 / 95% 共分散楕円) + , clusterHullOf + , clusterEllipseOf + -- * DOE prediction profiler + , ResidualMode (..) + , ProfilerSpec (..) + , profiler + , profilerResidual + , contourOf + -- * 階層クラスタリング dendrogram + , DendroOpts (..) + , defaultDendroOpts + , dendrogramOf + , dendrogramOf' + -- * 木/アンサンブル + , treeImportances + -- * 決定木 樹形図 (rpart.plot 流・annotation ベース) + , treePlot + , treePlotRaw + -- * 分類 + , decisionBoundaryOf + , confusionOf + -- * MDS 埋め込み (モデル型 + 群色オプション) + , MDSView + , mdsView + , mdsGroupBy + -- * NN 可視化 + , nnLossOf + -- * カーネル SVM サポートベクタ可視化 + , svmSupportVectorsOf + -- * 決定境界を線で描く (等高線) + , ScorePredict (..) + , decisionLineOf + -- * 部分従属図 (PDP / ICE) + , RegPredict (..) + -- ** Plottable 中間型 (HBM 抽出子と同型・toPlot で描画) + , PDPView + , pdp + , pdpIce + , pdpOf + , pdpIceOf + , pdpPlot + , pdpIcePlot + , partialDependencePlot + , partialDependenceIcePlot + -- * 次元圧縮 (PLS 診断ビュー) + , PLSView (..) + , PLSViewKind (..) + , scoreView + , loadingView + , vipView + -- * 時系列・生存・FDA + , garchVolatility + , aftSurvivalAt + -- * 罰則回帰・因果探索 + , regPathPlot + , lingamDag + , lingamDagNamed + , varLagDagNamed + , bootstrapEdgeProbOf + -- * 記述統計・検定 + , testForest + , testForestLabeled + , describeBox + ) where + +import Control.Applicative ((<|>)) +import Data.Maybe (fromMaybe) +import Data.List (nub, sort, elemIndex, sortBy, foldl') +import Data.Ord (comparing) +import qualified Data.Map.Strict as Map +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Numeric.LinearAlgebra as LA + +import Data.Text (Text) +import qualified Data.Text as T + +import Graphics.Hgg.Spec ( VisualSpec, layer, inline, inlineCat + , fromHex + , scatter, line, band + , shape, MarkShape (..) + , heatmap, contour, contourFilled, contourLevels + , label, color, colorBy, bar, boxplot, forest, forestNull + , legendOff + , title, coordFlip, coordCartesian, subplots, subplotCols + , scaleXDiscreteLimits + , xLabel, yLabel + , annotTextP, annotRectP + , annotate, Annotation (..) + , theme, ThemeName (..), themeGrid, themeAxisLine, panelBorder + , tickColor + , xAxis, yAxis, hideTicks + , axisBreaksLabeled, axisRotate + , scaleColorManual + , themeLegendFont, fontSize + , alpha + , dagFromListsWithPlates + , DAGNode (..), DAGEdge (..) + , DAGNodeKind (..), DAGLayoutAlgorithm (..) ) +import Graphics.Hgg.Unit (Pos (..)) +import Graphics.Hgg.Palette (ggplotHue) +import Graphics.Hgg.Custom.Dendrogram (DendroSeg (..), DendroPayload (..), dendrogramMark) -- Phase 48 +import Graphics.Hgg.DAG (layoutHierarchicalFullWithPlates) +import Graphics.Hgg.Render.Special (bakeDAGRoutesInSpec) + +import Numeric (showFFloat) + +import Hanalyze.Data.ColumnSource (ColumnSource (..)) +import Hanalyze.Model.Formula.Frame (ModelFrame (..), VarRole (..)) +import Hanalyze.Model.Formula.Design (designMatrixF) +import Hanalyze.Fit (DesignHBMFit (..)) +import Hanalyze.Model.Wrappers +import Hanalyze.Plot.Core +import Hanalyze.Model.LM (linspace) +import Hanalyze.Model.GP (gpNoiseVar) +import Hanalyze.Model.Weibull (quantileNormal) +import Hanalyze.Model.PLS (predictPLS) +import Hanalyze.Model.Cluster (KMeansResult (..)) +import Hanalyze.Model.HierarchicalCluster + (HClusterFit (..), cutTree) +import Hanalyze.Model.RandomForest (RandomForest (..), featureImportance, rfPermutationImportance, defaultFeatureNames, Tree) +import qualified Hanalyze.Model.RandomForest as RF +import Hanalyze.Model.GradientBoosting (GBRegressor (..), GBClassifier (..), predictGBR) +import Hanalyze.Model.PartialDependence + (PDPResult, partialDependence, pdpGrid, pdpMean) -- pdpIce 欄は PD. で参照 (関数名と衝突回避) +import qualified Hanalyze.Model.PartialDependence as PD +import Hanalyze.Model.RandomForestClassifier (RFClassifierFit (..)) +import Hanalyze.Model.DecisionTree (DTree (..), DTFit (..)) +import Hanalyze.Model.Discriminant (DiscriminantFit (..), predictDiscriminant) +import Hanalyze.Model.NaiveBayes (NBModel (..), GaussianNB (..) + , MultinomialNB (..), predictNB) +import Hanalyze.Model.KNN (KNNClassifier (..), predictKNNC) +import Hanalyze.Model.NeuralNetwork (MLPFit (..), predictMLPClass) +import Hanalyze.Model.SVM (SVM (..), SVMMulti (..) + , predictSVM, predictSVMMulti, predictSVMScore) +import Hanalyze.Model.MDS (MDSResult (..)) +import Hanalyze.DataIO.Convert (getTextVec, getDoubleVec) +import qualified DataFrame.Internal.DataFrame as DXD +import Hanalyze.Model.PLS (PLSFit (..)) +import Hanalyze.Model.GARCH (GARCHFit (..)) +import Hanalyze.Model.AFT (AFTFit (..), logS, predictAFT) +import Hanalyze.Model.FDA (FunctionalPCA (..), FLMResult (..)) +import Hanalyze.Model.Regularized (RegFit (..)) +import Hanalyze.Model.LiNGAM.Direct (DirectLiNGAMFit (..)) +import Hanalyze.Model.LiNGAM.Parce (ParceFit (..)) +import Hanalyze.Model.LiNGAM.MultiGroup (MultiGroupFit (..)) +import Hanalyze.Model.LiNGAM.VAR (VARLiNGAMFit (..)) +import Hanalyze.Model.LiNGAM.Pairwise (PairwiseResult (..), PairwiseDirection (..)) +import Hanalyze.Model.LiNGAM.Bootstrap (BootstrapResult (..)) +import Hanalyze.Model.LiNGAM.ICA (ICALiNGAMFit (..)) +import Hanalyze.Stat.CorrelationNetwork (CorrelationGraph (..)) +import Hanalyze.Stat.Test (TestResult (..)) +import Hanalyze.Model.PCA (PCAResult (..)) +import Hanalyze.Model.Survival (KMResult (..)) +import Hanalyze.Model.CompetingRisks (CRFit (..)) +import Hanalyze.Model.TimeSeries (ARFit (..), forecastAR) + +-- =========================================================================== +-- クラスタリング (KMeans) の図 — Phase 68 A1 +-- +-- KMeans の分野定番の図は「クラスタ別散布 (色=ラベル)」。 ただし +-- 'KMeansResult' は centroids + labels + inertia のみ保持し **生データ座標を +-- 持たない**。 そこで 'surfaceOf' <> 'dataScatter3DOf' と同じ **model 層 / data +-- 層の二層イディオム**に分ける: +-- +-- * 'Plottable' 'KMeansResult' の @toPlot@ = centroid 散布のみ (データ不要・ +-- クラス契約 @m -> VisualSpec@ を満たす)。 既定は centroid 行列の第 0/1 次元。 +-- * 'clusterScatterOf' = データ点をラベル色で散布 (要データ源・列名指定)。 +-- * 'centroidsOf' = centroid を任意 2 次元で重畳 (✚ マーカー・次元 index 明示)。 +-- +-- 定番図 = @df |>> (clusterScatterOf df res \"x\" \"y\" <> centroidsOf res 0 1)@。 +-- ⚠ centroid 行列は **学習時の特徴量列順**のみで列名を持たない。 重畳時は +-- データ列 (@xn@, @yn@) と centroid 次元 (@i@, @j@) の対応をユーザが揃える。 +-- =========================================================================== + +-- | [日本語]: KMeans クラスタの代表図 = centroid 散布 (第 0/1 次元・クラスタ色・✚ マーカー)。 +-- 生データ点は 'clusterScatterOf' で別 layer に重ねる +-- (cf. 'surfaceOf' (model) <> 'dataScatter3DOf' (data) の二層イディオム)。 +-- [English]: The representative KMeans cluster plot = a centroid scatter +-- (dimensions 0\/1, cluster color, cross marker). Raw data points are +-- overlaid as a separate layer via 'clusterScatterOf' (cf. the two-layer +-- idiom of 'surfaceOf' (model) <> 'dataScatter3DOf' (data)). +instance Plottable KMeansResult where + toPlot res = centroidsOf res 0 1 + +-- | [日本語]: データ点をラベル色で散布する (= KMeans の定番「クラスタ別散布」)。 +-- @d@ は 'ColumnSource' (DataFrame / assoc / Map 等)、 @xn@\/@yn@ は描く列名。 +-- 色はクラスタラベル ('kmrLabels') の categorical (= 点と同順)。 +-- 列が無ければ空 ('mempty')。 +-- [English]: Scatters the data points colored by cluster label (the +-- classic KMeans "scatter colored by cluster"). @d@ is a 'ColumnSource' +-- (DataFrame \/ assoc \/ Map, etc.), and @xn@\/@yn@ are the column names to +-- plot. Color is the categorical cluster label ('kmrLabels', in the same +-- order as the points). Empty ('mempty') if the columns don't exist. +clusterScatterOf :: ColumnSource d => d -> KMeansResult -> Text -> Text -> VisualSpec +clusterScatterOf d res xn yn = + case (lookupCol xn d, lookupCol yn d) of + (Just xs, Just ys) -> + layer ( scatter (inline xs) (inline ys) + <> colorBy (inlineCat (map (T.pack . show) (kmrLabels res))) ) + _ -> mempty + +-- | [日本語]: centroid を任意 2 次元 (@i@, @j@) で散布 (クラスタ色・✚ マーカーで点と区別)。 +-- index が centroid 次元数を超える / 負なら空 ('mempty')。 +-- [English]: Scatters the centroids over any two dimensions (@i@, @j@) +-- (cluster color, cross marker to distinguish from the data points). +-- Empty ('mempty') if an index exceeds the centroid dimension count or is +-- negative. +centroidsOf :: KMeansResult -> Int -> Int -> VisualSpec +centroidsOf res i j + | i < 0 || j < 0 || i >= d || j >= d = mempty + | otherwise = + layer ( scatter (inline xs) (inline ys) + <> colorBy (inlineCat cids) + <> shape MShCross ) + where + cs = kmrCentroids res + d = LA.cols cs + k = LA.rows cs + cols = LA.toColumns cs + xs = LA.toList (cols !! i) + ys = LA.toList (cols !! j) + cids = map (T.pack . show) [0 .. k - 1 :: Int] + +-- | [日本語]: render の categorical 群色 (colorBy → @sort.nub@ 順 → 'ggplotHue') を analyze 側で +-- 再現し、 カテゴリ名 → 色(hex) の辞書を返す。 annotation の色は spec 時に確定するため +-- ('clusterScatterOf'/@toPlot@ の凡例色と一致させる用)。 +-- [English]: Reproduces render's categorical group color (colorBy → +-- @sort.nub@ order → 'ggplotHue') on the analyze side and returns a +-- category name → color (hex) dictionary. Since annotation colors are +-- fixed at spec time, this keeps them matching 'clusterScatterOf'\/@toPlot@ +-- legend colors. +hueColorMap :: [Text] -> Map.Map Text Text +hueColorMap labels = + let cats = sort (nub labels) + in Map.fromList (zip cats (ggplotHue (length cats) ++ repeat "#cccccc")) + +-- | [日本語]: 色・太さ指定の線分注釈 (@annotLineP@ は色固定なので 'AnnLine' を直接構築)。 +-- [English]: A line-segment annotation with a specified color and width +-- (built directly as 'AnnLine' since @annotLineP@ has a fixed color). +annotLineC :: Text -> Double -> (Double, Double) -> (Double, Double) -> VisualSpec +annotLineC col w (x1, y1) (x2, y2) = annotate AnnLine + { anX1 = PNative x1, anY1 = PNative y1, anX2 = PNative x2, anY2 = PNative y2 + , anColor = col, anWidth = w } + +-- | [日本語]: 頂点列を閉じた折れ線 (最後→最初も結ぶ) として色付き線分で描く。 +-- [English]: Draws a vertex sequence as a closed polyline (also connecting +-- the last vertex back to the first) using colored line segments. +closedPolyline :: Text -> Double -> [(Double, Double)] -> VisualSpec +closedPolyline _ _ [] = mempty +closedPolyline _ _ [_] = mempty +closedPolyline col w vs = + mconcat [ annotLineC col w p q | (p, q) <- zip vs (tail vs ++ [head vs]) ] + +-- | [日本語]: 2D 凸包 (Andrew monotone chain)・反時計回り頂点列。 3 点未満は入力そのまま。 +-- [English]: 2D convex hull (Andrew's monotone chain); returns a +-- counter-clockwise vertex sequence. Fewer than 3 points are returned as-is. +convexHull :: [(Double, Double)] -> [(Double, Double)] +convexHull ps0 = + let ps = sort (nub ps0) -- lexicographic (x, y) + in if length ps <= 2 then ps + else let lower = half ps + upper = half (reverse ps) + in init lower ++ init upper -- 端点重複を除いて連結 + where + -- 単調鎖: 直近 2 点と p が右回り (cross<=0) の間は pop。 stack は head=最新。 + half = reverse . foldl step [] + step acc p = p : popRight acc p + popRight (b : a : rest) p + | cross a b p <= 0 = popRight (a : rest) p + popRight acc _ = acc + cross (ox, oy) (ax, ay) (bx, by) = (ax - ox) * (by - oy) - (ay - oy) * (bx - ox) + +-- | [日本語]: クラスタ点群をラベルごとにグルーピング (色は 'clusterScatterOf' と一致)。 +-- d が xn/yn 列を持たなければ空。 +-- [English]: Groups the cluster point cloud by label (colors match +-- 'clusterScatterOf'). Empty if @d@ lacks the xn\/yn columns. +clusterGroups + :: ColumnSource d => d -> KMeansResult -> Text -> Text + -> [(Text, [(Double, Double)])] -- (群色 hex, 点列) +clusterGroups d res xn yn = + case (lookupCol xn d, lookupCol yn d) of + (Just xs, Just ys) -> + let labs = kmrLabels res + cmap = hueColorMap (map (T.pack . show) labs) + gmap = Map.fromListWith (flip (++)) + [ (l, [(x, y)]) | (l, x, y) <- zip3 labs xs ys ] + in [ (Map.findWithDefault "#cccccc" (T.pack (show l)) cmap, ps) + | (l, ps) <- Map.toList gmap ] + _ -> [] + +-- | [日本語]: 各クラスタを __凸包の輪郭線__ で囲む (ggplot @geom_encircle@ 相当・塗りなし)。 +-- 群色は 'clusterScatterOf' と一致。 定番 = @cdf |>> (clusterScatterOf … \<\> clusterHullOf …)@。 +-- ⚠ annotation は軸平行矩形しか塗れないため __輪郭線のみ__ (半透明塗りは将来 @MPolygon@ 移譲)。 +-- [English]: Encircles each cluster with its __convex-hull outline__ +-- (equivalent to ggplot's @geom_encircle@; unfilled). Group colors match +-- 'clusterScatterOf'. Typical usage = @cdf |>> (clusterScatterOf … \<\> clusterHullOf …)@. +-- ⚠ Since annotations can only fill axis-aligned rectangles, this draws +-- __only the outline__ (semi-transparent fill is deferred to a future +-- @MPolygon@ hand-off). +clusterHullOf :: ColumnSource d => d -> KMeansResult -> Text -> Text -> VisualSpec +clusterHullOf d res xn yn = + mconcat [ closedPolyline col 1.5 (convexHull ps) + | (col, ps) <- clusterGroups d res xn yn ] + +-- | [日本語]: 各クラスタを __95% 共分散楕円__ (χ²(0.95, 2)=5.991) の輪郭で囲む (ggplot @stat_ellipse@ +-- 相当・正規分布仮定)。 群平均 μ・共分散 Σ を固有分解 ('LA.eigSH') し、 固有軸方向へ +-- 半径 √5.991·√λ の楕円点列を折れ線で近似。 群色は 'clusterScatterOf' と一致。 +-- 点数 3 未満の群は描かない (共分散が定義できないため)。 +-- [English]: Encircles each cluster with its __95% covariance ellipse__ +-- outline (χ²(0.95, 2) = 5.991; equivalent to ggplot's @stat_ellipse@, +-- assuming normality). Eigendecomposes ('LA.eigSH') the group mean μ and +-- covariance Σ, then approximates the ellipse with a polyline of points at +-- radius √5.991·√λ along the eigenvector axes. Group colors match +-- 'clusterScatterOf'. Groups with fewer than 3 points are not drawn +-- (covariance is undefined). +clusterEllipseOf :: ColumnSource d => d -> KMeansResult -> Text -> Text -> VisualSpec +clusterEllipseOf d res xn yn = + let ellipses = [ (col, ellipse95 ps) | (col, ps) <- clusterGroups d res xn yn ] + outlines = mconcat [ closedPolyline col 1.5 pts | (col, pts) <- ellipses ] + allPts = concatMap snd ellipses + -- annotation は軸ドメインを駆動しないため、 95% 楕円 (データ点より外へ広がる) が + -- フレームをはみ出す。 楕円点を alpha=0 の不可視散布で載せ軸を広げる (colorBy 無し= + -- 凡例に出ない)。 決定境界の coordCartesian と違い、 ここは重畳データ点も含めて + -- auto-fit させたいので固定でなく anchor 方式。 + anchor + | null allPts = mempty + | otherwise = layer ( scatter (inline (map fst allPts)) (inline (map snd allPts)) + <> alpha 0 ) + in outlines <> anchor + where + seg = 64 :: Int + scl = sqrt 5.991 -- χ²(0.95, 2) + ellipse95 ps + | n < 3 = [] + | otherwise = + [ ( mux + a * (v1 !! 0) + b * (v2 !! 0) + , muy + a * (v1 !! 1) + b * (v2 !! 1) ) + | t <- [ 2 * pi * fromIntegral k / fromIntegral seg | k <- [0 .. seg - 1] ] + , let a = scl * sqrt (max 0 l1) * cos t + b = scl * sqrt (max 0 l2) * sin t ] + where + n = length ps + xs = map fst ps; ys = map snd ps + mux = sum xs / fromIntegral n + muy = sum ys / fromIntegral n + sxx = sum [ (x - mux) ^ (2 :: Int) | x <- xs ] / fromIntegral (n - 1) + syy = sum [ (y - muy) ^ (2 :: Int) | y <- ys ] / fromIntegral (n - 1) + sxy = sum [ (x - mux) * (y - muy) | (x, y) <- ps ] / fromIntegral (n - 1) + sigma = LA.fromLists [[sxx, sxy], [sxy, syy]] + (vals, vecs) = LA.eigSH (LA.trustSym sigma) -- λ 降順・列=固有ベクトル + l1 = vals `LA.atIndex` 0 + l2 = vals `LA.atIndex` 1 + cols = LA.toColumns vecs + v1 = LA.toList (cols !! 0) + v2 = LA.toList (cols !! 1) + +-- | [日本語]: dendrogram の描画オプション。 +-- [English]: Rendering options for the dendrogram. +data DendroOpts = DendroOpts + { doLineColor :: !Text -- ^ [日本語]: 閾値超 (または閾値未指定) の線色。 [English]: Line color above the threshold (or when no threshold is set). + , doWidth :: !Double -- ^ [日本語]: 線幅。 [English]: Line width. + , doColorThreshold :: !(Maybe Double) -- ^ [日本語]: @Just t@ で高さ @t@ 未満のサブツリーをクラスタ色分け + -- (scipy @color_threshold@ 流)。 @Nothing@ で単色。 + -- [English]: With @Just t@, subtrees below height @t@ are + -- colored by cluster (scipy's @color_threshold@ convention). + -- @Nothing@ renders a single color. + } deriving (Show) + +-- | [日本語]: 既定 = 単色 (grey20 相当・閾値なし)。 +-- [English]: The default: a single color (equivalent to grey20, no threshold). +defaultDendroOpts :: DendroOpts +defaultDendroOpts = DendroOpts "#4C4C4C" 1.2 Nothing + +instance Plottable HClusterFit where + toPlot = dendrogramOf + +-- | [日本語]: 階層クラスタリング結果を __dendrogram__ で描く (scipy @dendrogram@ / ggdendro 流)。 +-- マージ列 ('hcMerges') と高さ ('hcHeights') から U 字リンク (縦 2 + 横 1) を 'AnnLine' で +-- 描画。 葉は x 軸に等間隔・各マージノードの x = 子の中点・y = マージ高。 リーフに元サンプル +-- ID ラベル。 plot core は触らず annotation で描く (将来 plot 正式 mark 移譲予定)。 +-- [English]: Renders a hierarchical clustering result as a __dendrogram__ +-- (following scipy's @dendrogram@ \/ ggdendro convention). Draws U-shaped +-- links (2 vertical + 1 horizontal) via 'AnnLine' from the merge sequence +-- ('hcMerges') and heights ('hcHeights'). Leaves are equally spaced on the +-- x axis; each merge node's x = the midpoint of its children, y = the +-- merge height. Leaves are labeled with the original sample ID. Drawn via +-- annotation without touching the plot core (a future hand-off to a +-- proper plot mark is planned). +dendrogramOf :: HClusterFit -> VisualSpec +dendrogramOf = dendrogramOf' defaultDendroOpts + +-- | [日本語]: 色閾値・線色等を指定できる版。 +-- [English]: A variant that lets you specify the color threshold, line +-- color, etc. +dendrogramOf' :: DendroOpts -> HClusterFit -> VisualSpec +dendrogramOf' opts fit + | n <= 1 || null merges = mempty + | otherwise = + -- R base / scipy 同様 grid・軸線・枠なし (theme_minimal + grid off)。 + theme ThemeMinimal <> themeGrid False <> themeAxisLine False <> panelBorder False + <> tickColor "transparent" -- 目盛マーク (短線) を消す。 数字ラベルは残る。 + -- 葉ラベルは x 軸目盛 (slot 位置・縦書き) で。 軸ラベルは margin を予約するので + -- リンク根と被らない (annotText と違い R と同挙動)。 + -- ★ axisRotate は CCW 正 (R/matplotlib/ggplot 準拠・hgg Phase 50 A1)。 + -- 90 = CCW 90 = 下→上読みで R base / scipy dendrogram の既定向きと一致。 + <> xAxis (axisBreaksLabeled leafTicks <> axisRotate 90) + <> layer (dendrogramMark payload) -- ★ Phase 48: U字リンクを custom mark で描く (焼き込み)。 + -- encX/encY で軸 range を束ねる (旧 anchor 不要)。 + <> yAxisLine -- 軸線は 2 辺一括制御しか無いので y 軸線だけ自前描画。 + <> yLabel "height" -- y = マージ高 (結合時の非類似度・Ward 増分)。 + where + n = hcNumOriginals fit + merges = hcMerges fit + heights = hcHeights fit + root = 2 * n - 2 -- 最終マージ = 根ノード + childrenOf node = merges !! (node - n) + leavesOf node + | node < n = [node] + | otherwise = let (a, b) = childrenOf node in leavesOf a ++ leavesOf b + order = leavesOf root -- 葉 ID を左→右の並びで + slotOf = Map.fromList (zip order [0 :: Int ..]) + -- ノードの x (子の中点)・高さ・代表葉を fold で確定 (子は id が小さく先に入る)。 + (nodeX, nodeH, leafRep) = foldl' step (x0, h0, r0) (zip [0 :: Int ..] merges) + where + x0 = Map.fromList [ (l, fromIntegral (slotOf Map.! l)) | l <- [0 .. n - 1] ] + h0 = Map.fromList [ (l, 0 :: Double) | l <- [0 .. n - 1] ] + r0 = Map.fromList [ (l, l) | l <- [0 .. n - 1] ] + step (mx, mh, mr) (i, (a, b)) = + let node = n + i + in ( Map.insert node ((mx Map.! a + mx Map.! b) / 2) mx + , Map.insert node (heights !! i) mh + , Map.insert node (mr Map.! a) mr ) + maxH = maximum heights + -- 葉ラベル = x 軸目盛 (slot 位置に元サンプル ID)。 縦書きは axisRotate 90。 + leafTicks = [ (fromIntegral slot, T.pack (show leaf)) + | (leaf, slot) <- zip order [0 :: Int ..] ] + -- 色閾値: t 未満マージ数だけ切って各葉のクラスタ ID を得る (hcMerges は高さ昇順)。 + thrInf = maybe (1 / 0) id (doColorThreshold opts) + kCut = n - length (filter (< thrInf) heights) + clusterIds = cutTree fit kCut + distinctCs = foldr (\c acc -> if c `elem` acc then acc else acc ++ [c]) + [] (V.toList clusterIds) -- 出現順 + cmap = Map.fromList (zip distinctCs + (ggplotHue (length distinctCs) ++ repeat "#999999")) + linkColor i = case doColorThreshold opts of + Just t | heights !! i < t -> + Map.findWithDefault (doLineColor opts) + (clusterIds V.! (leafRep Map.! (n + i))) cmap + _ -> doLineColor opts + -- U 字リンク (子の高さ→マージ高の縦線 2 本 + マージ高の横線 1 本) を焼き込み線分に。 + -- 座標系は従来の annotLine 版と同一 (x=葉 slot/node 中点、 y=height)。 + payload = DendroPayload + { dpSegments = concat + [ [ DendroSeg xa ha xa hgt col w + , DendroSeg xa hgt xb hgt col w + , DendroSeg xb hgt xb hb col w ] + | (i, (a, b)) <- zip [0 :: Int ..] merges + , let xa = nodeX Map.! a; xb = nodeX Map.! b + ha = nodeH Map.! a; hb = nodeH Map.! b + hgt = heights !! i + col = linkColor i + w = doWidth opts ] + , dpXRange = (-0.6, fromIntegral n - 0.4) -- 旧 anchor と同じ range + , dpYRange = (0, maxH * 1.05) + } + -- 左辺 (panel npc x=0) に y 軸線を 1 本 (下辺 x 軸線は出さない = R 流)。 + yAxisLine = annotate AnnLine + { anX1 = PNpc 0, anY1 = PNpc 0, anX2 = PNpc 0, anY2 = PNpc 1 + , anColor = "#333333", anWidth = 1 } + +-- =========================================================================== +-- 時系列予測 (描画可能) +-- +-- AR(p) の点予測 'forecastAR' は将来値の中心のみを返す。 予測の不確実性帯は **h-step +-- 予測分散** から得る: AR の MA(∞) 表現の ψ-weights (ψ₀=1, ψⱼ=Σφᵢψⱼ₋ᵢ) を用いて +-- @Var(ŷ_{n+k}) = σ² Σ_{j=0}^{k-1} ψⱼ²@ (σ² = 革新分散 'arResidVar')。 これは Gaussian +-- 革新の下での正統な予測区間 (地平 k とともに単調に広がる)。 対称ゆえ band は +-- @中心 ± z·se@。 @toPlot@ は履歴折れ線 + 予測折れ線 + 予測区間 band を 1 枚に重ねる。 +-- =========================================================================== + +-- | [日本語]: AR(p) の MA(∞) 表現の ψ-weights ψ₀..ψ_{h-1} (ψ₀=1, ψⱼ=Σ_{i=1}^{min j p} φᵢ ψⱼ₋ᵢ)。 +-- [English]: The ψ-weights ψ₀..ψ_{h-1} of the AR(p) model's MA(∞) +-- representation (ψ₀=1, ψⱼ=Σ_{i=1}^{min j p} φᵢ ψⱼ₋ᵢ). +arPsiWeights :: [Double] -> Int -> [Double] +arPsiWeights phi h = go [1.0] + where + p = length phi + go ps + | length ps >= h = take h ps + | otherwise = + let j = length ps + pj = sum [ (phi !! (i - 1)) * (ps !! (j - i)) | i <- [1 .. min j p] ] + in go (ps ++ [pj]) + +-- | [日本語]: k-step (k=1..h) 予測標準誤差 se_k = sqrt(σ² Σ_{j Int -> [Double] +arForecastSE fit h = + let phi = LA.toList (arPhi fit) + s2 = arResidVar fit + psis = arPsiWeights phi h + in [ sqrt (s2 * sum (map (^ (2 :: Int)) (take k psis))) | k <- [1 .. h] ] + +instance Plottable ForecastModel where + -- 履歴折れ線 + 予測折れ線 + 予測区間 band (中心 ± 1.96·se)。 x = 時刻 index + -- (履歴 1..n、 予測 n+1..n+h)。 予測線は履歴末尾点から繋げる。 帯を先・線を後に重ねる。 + toPlot m = + let fit = fmFit m + hist = LA.toList (fmHistory m) + n = length hist + h = fmHorizon m + fc = LA.toList (forecastAR fit (fmHistory m) h) + se = arForecastSE fit h + fx = [ fromIntegral (n + k) | k <- [1 .. h] ] :: [Double] + lo = zipWith (\f s -> f - 1.96 * s) fc se + hi = zipWith (\f s -> f + 1.96 * s) fc se + histX = [ fromIntegral i | i <- [1 .. n] ] :: [Double] + -- 予測線は履歴末尾 (n, hist[n-1]) から始めて連続させる。 + lineX = fromIntegral n : fx + lineY = last hist : fc + in layer (band (inline fx) (inline lo) (inline hi)) + <> layer (line (inline histX) (inline hist)) + <> layer (line (inline lineX) (inline lineY)) + +-- =========================================================================== +-- 生存解析 (描画可能) +-- +-- KM 生存曲線・CIF (競合リスク) はいずれも階段関数。 'stepVerts' (Core) で階段頂点を +-- 明示展開して line で結ぶ。 KM は s0=1 で下降、 CIF は s0=0 で上昇。 +-- =========================================================================== + +instance Plottable KMResult where + -- KM 生存曲線 (階段、 S=1 から下降)。 + toPlot km = + let pts = zip (kmrTimes km) (kmrSurvival km) + verts = stepVerts 1.0 pts + in layer (line (inline (map fst verts)) (inline (map snd verts))) + +instance Plottable CRFit where + -- 競合リスク CIF (cause ごとに 0 から上昇する階段、 色分け重畳)。 + toPlot cr = + let ts = LA.toList (crfTimes cr) + mkCause (i, (_cause, cifV)) = + let pts = zip ts (LA.toList cifV) + verts = stepVerts 0.0 pts + col = quantilePalette !! (i `mod` length quantilePalette) + in layer (line (inline (map fst verts)) (inline (map snd verts)) + <> color (fromHex col)) + in foldMap mkCause (zip [0 ..] (crfCIF cr)) + +-- =========================================================================== +-- 多変量・木 (描画可能) +-- +-- PCA の代表図は **scree plot** (各主成分の寄与率 'pcaExplainedRatio' を棒で)、 木 (RF) の +-- 代表図は **特徴重要度バー** ('featureImportance')。 いずれも自己完結ゆえそのまま +-- 'Plottable'。 棒の x 軸はラベル ("PC1".. / "f1"..) なので 'inlineCat' (categorical) で渡す +-- (heatmap A9 と同じく 'bar' も categorical 軸が必要)。 優先低 (§3.5 A14) ゆえ scree/重要度 +-- の 1 枚ずつに絞る (biplot や木構造図は将来拡張)。 +-- =========================================================================== + +instance Plottable PCAResult where + -- scree plot: 各主成分 (PC1, PC2, …) の寄与率を棒で。 + toPlot res = + let ratios = LA.toList (pcaExplainedRatio res) + labels = [ "PC" <> T.pack (show k) | k <- [1 .. length ratios] ] + in layer (bar (inlineCat labels) (inline ratios)) + +instance Plottable RandomForest where + -- R @varImpPlot@ 流の 2 パネル: 左 = impurity (IncNodePurity)、 右 = permutation + -- (%IncMSE)。 各パネルは降順ソート + 実列名 + 横棒 ('coordFlip')。 + toPlot rf = + let n = V.length (featureImportance rf) + names = case rfFeatureNames rf of + [] -> defaultFeatureNames n + ns -> ns + imp = V.toList (featureImportance rf) + perm = V.toList (rfPermutationImportance rf) + in subplots + [ importanceBarNamed "IncNodePurity (impurity)" names imp + , importanceBarNamed "%IncMSE (permutation)" names perm ] + <> subplotCols 2 + +-- | [日本語]: 名前つき importance を横棒 ('coordFlip') で描く (R @varImpPlot@ 流)。 重要度で +-- ソートするため 'scaleXDiscreteLimits' でカテゴリ順を明示する (bar 軸は既定 +-- アルファベット順ゆえデータ並びでは効かない)。 coordFlip 後は limits 順が下→上 +-- なので、 昇順 limits を渡して最重要を上端に置く。 タイトル付き。 +-- [English]: Draws named importances as a horizontal bar ('coordFlip', +-- following R's @varImpPlot@). Since the bar axis defaults to alphabetical +-- order (unaffected by data order), 'scaleXDiscreteLimits' is used to make +-- the category order explicit for sorting. After @coordFlip@ the limits +-- order runs bottom→top, so ascending limits are passed to place the most +-- important feature at the top. Includes a title. +importanceBarNamed :: T.Text -> [T.Text] -> [Double] -> VisualSpec +importanceBarNamed ttl names vals = + let ascByVal = map fst (sortBy (comparing snd) (zip names vals)) -- 昇順 → 最大が末尾 = 上端 + in layer (bar (inlineCat names) (inline vals)) + <> scaleXDiscreteLimits ascByVal + <> coordFlip <> title ttl + +-- =========================================================================== +-- 木/アンサンブル — Phase 68 A2 +-- +-- 各モデルの分野定番図を **既存 mark のみ**で描く (新規 plot mark 不要): +-- +-- * GradientBoosting (回帰/分類)・RandomForestClassifier = **特徴重要度 bar**。 +-- GBM は重要度フィールドを持たないので弱学習器 ('Tree') の split 使用回数から +-- 純粋計算する ('treeImportances'・RF.'featureImportance' と同方式・正規化)。 +-- * DecisionTree = **樹形図**。 決定木は DAG の特殊形 (二分木) ゆえ、 HBM の +-- ModelGraph と同じ MDAG (Sugiyama 階層 layout) を **再利用**して node-link で描く +-- (split ノード = "f{j} ≤ {thr}"、 葉 = "y={class}")。 +-- +-- ⚠ DecisionTree の edge True/False ラベル・gini・サンプル数表示 (sklearn plot_tree +-- 相当) は DAGNode/DAGEdge が持たないため v1 では描かない。 必要なら専用 mark を +-- plot 側 Phase として起こす (= dendrogram Phase 48 と同型の判断)。 +-- =========================================================================== + +-- | [日本語]: 弱学習器 ('Tree') 列の split 使用回数による特徴重要度 (RF と同方式・合計 1 に正規化)。 +-- 特徴数は出現した最大 index + 1 (= 木で一度も使われない末尾特徴は現れない)。 +-- [English]: Feature importance from the split-usage count of the weak +-- learner ('Tree') sequence (the same method as RF, normalized to sum 1). +-- The feature count is the max observed index + 1 (a trailing feature +-- never used in any tree simply doesn't appear). +treeImportances :: [Tree] -> [Double] +treeImportances trees = + let counts = foldr walk Map.empty trees + walk (RF.Leaf _) m = m + walk (RF.Node j _ l r) m = walk l (walk r (Map.insertWith (+) j (1 :: Double) m)) + d = if Map.null counts then 0 else maximum (Map.keys counts) + 1 + raw = [ Map.findWithDefault 0 j counts | j <- [0 .. d - 1] ] + tot = sum raw + in if tot <= 0 then raw else map (/ tot) raw + +instance Plottable GBRegressor where + -- 弱学習器の split 使用回数による特徴重要度 bar。 + toPlot gb = importanceBar (treeImportances (gbrTrees gb)) + +instance Plottable GBClassifier where + toPlot gb = importanceBar (treeImportances (gbcTrees gb)) + +instance Plottable RFClassifierFit where + -- R @varImpPlot@ 流の 2 パネル: 左 = permutation (MeanDecreaseAccuracy)、 + -- 右 = gini 減少 (MeanDecreaseGini・MDI)。 各パネル降順・実列名・横棒。 + toPlot fit = + let perm = LA.toList (rfcImportance fit) + gini = LA.toList (rfcGiniImportance fit) + names = case rfcFeatureNames fit of + [] -> defaultFeatureNames (length perm) + ns -> ns + in subplots + [ importanceBarNamed "MeanDecreaseAccuracy" names perm + , importanceBarNamed "MeanDecreaseGini" names gini ] + <> subplotCols 2 + +instance Plottable DTree where + -- 決定木 → node-link 樹形図 (MDAG 再利用・Sugiyama 階層 layout)。 + toPlot t = + let (dnodes, dedges) = dtreeToDag t + (positioned, routed) = layoutHierarchicalFullWithPlates dnodes dedges [] + in bakeDAGRoutesInSpec $ + layer (dagFromListsWithPlates positioned routed LayoutHierarchical []) + +-- | [日本語]: 学習済み 'DTFit' → __rpart.plot 流__ の樹形図 ('treePlot' と同じ)。 @df |-> decisionTree@ +-- の返り値をそのまま @toPlot@ に渡せる。 素の node-link 図は 'DTree' の 'Plottable'。 +-- [English]: A trained 'DTFit' → the __rpart.plot style__ tree diagram +-- (same as 'treePlot'). The return value of @df |-> decisionTree@ can be +-- passed straight to @toPlot@. The plain node-link diagram is 'DTree'\'s +-- 'Plottable'. +instance Plottable DTFit where + toPlot = treePlot + +-- | [日本語]: 'DTree' を MDAG の node/edge 列へ変換する。 ノード id は根から L/R を辿る経路 +-- ("n" / "nL" / "nLR" …) で一意。 split ノードは @NodeOther@、 葉は @NodeObserved@ +-- (色で区別)。 左 child = 条件成立 (≤)・右 = 不成立 (>) の慣例で並べる。 +-- [English]: Converts a 'DTree' into MDAG node\/edge lists. Node ids are +-- unique paths from the root following L\/R ("n" \/ "nL" \/ "nLR" …). Split +-- nodes are @NodeOther@, leaves are @NodeObserved@ (distinguished by +-- color). By convention, the left child = the condition holds (≤), the +-- right = it doesn't (>). +dtreeToDag :: DTree -> ([DAGNode], [DAGEdge]) +dtreeToDag = go "n" + where + mkNode nid lbl kind = DAGNode + { dnId = nid, dnLabel = lbl, dnKind = kind, dnDist = Nothing, dnX = 0, dnY = 0 } + go nid DLeaf{dlMajority = maj} = + ( [ mkNode nid ("y=" <> T.pack (show maj)) NodeObserved ], [] ) + go nid DNode{dnFeature = f, dnThr = thr, dnLeft = l, dnRight = r} = + let self = mkNode nid ("f" <> T.pack (show f) <> " ≤ " <> fmt2 thr) NodeOther + lid = nid <> "L" + rid = nid <> "R" + (ln, le) = go lid l + (rn, re) = go rid r + edges = [ DAGEdge nid lid Nothing Nothing + , DAGEdge nid rid Nothing Nothing ] + in (self : ln ++ rn, edges ++ le ++ re) + fmt2 x = T.pack (showFFloat (Just 2) x "") + +-- --------------------------------------------------------------------------- +-- Phase 75.26: 決定木 樹形図 (rpart.plot 流・annotation ベース) +-- --------------------------------------------------------------------------- + +-- | [日本語]: 位置付け済みの決定木ノード (annotation 描画用の中間表現)。 @tpU@ は葉単位の +-- 水平座標 (葉 = 0,1,2,…・内部 = 子の中点)、 @tpDepth@ は根からの深さ。 +-- [English]: A positioned decision-tree node (an intermediate +-- representation for annotation-based rendering). @tpU@ is the +-- per-leaf horizontal coordinate (leaves = 0,1,2,…; internal nodes = the +-- midpoint of their children), and @tpDepth@ is the depth from the root. +data TPNode = TPNode + { tpU :: !Double -- ^ [日本語]: 葉単位の水平座標。 [English]: The per-leaf horizontal coordinate. + , tpDepth :: !Int -- ^ [日本語]: 根からの深さ (根 = 0)。 [English]: Depth from the root (root = 0). + , tpMaj :: !Int -- ^ [日本語]: 多数決 (予測) クラス。 [English]: The majority-vote (predicted) class. + , tpN :: !Int -- ^ [日本語]: ノードのサンプル数。 [English]: The node's sample count. + , tpProbs :: !(Map.Map Int Double) -- ^ [日本語]: クラス割合。 [English]: Class proportions. + , tpSplit :: !(Maybe (Int, Double)) -- ^ [日本語]: 分岐なら (特徴 index, 閾値)。 葉は Nothing。 [English]: @(feature index, threshold)@ for a split node; @Nothing@ for a leaf. + , tpKids :: [TPNode] -- ^ [日本語]: [] = 葉、 [左, 右] = 分岐。 [English]: @[]@ = leaf, @[left, right]@ = split. + } + +-- | [日本語]: 決定木を __rpart.plot 流__ の樹形図で描く (analyze 側 annotation ベース)。 +-- +-- 各ノードを矩形で表し、 内部に __予測クラス / 全クラス確率 / サンプル割合__ を 3 行で +-- 書く (rpart.plot @type=2@ 既定に相当)。 配線は R と同じく __親→バスの縦線を引かず__、 +-- 分割条件 @feat < thr@ を親の少し下の水平バス上に置き、 枝はその両端から出て子の真上で +-- 折れる。 条件の両脇 (__根の分岐のみ__) に枠付き白箱で @yes@ (左=成立)・@no@ (右) を添える。 +-- +-- 塗り色は rpart.plot @box.palette="auto"@ 準拠で、 クラスごとに ColorBrewer 連番 +-- パレット (Reds/Greys/Greens/…) を割当て、 __濃淡で予測クラスの確率 (確信度)__ を表す +-- (淡=低・濃=高)。 暗い塗りには白文字を自動選択。 右上にクラス色の凡例を出す。 +-- +-- 第 1 = 特徴量名、 第 2 = クラス名 (@printRpart@ と同型・長さ不足は @f{i}@/整数へ +-- フォールバック)。 木レイアウトは葉を左→右へ等間隔・深さ→縦位置で配置し、 座標は +-- panel 正規化 (PNpc) で算術する。 plot core の型は触らず annotation だけで描く +-- (図が固まれば plot 正式 mark へ移譲予定・PS parity は移譲時に対応)。 +-- +-- ⚠ 文字幅は annotation では実測できないため npc で概算する (@wpc@)。 既定は図幅 +-- 〜680px 前提に調律してあり、 極端なサイズでは箱幅/マスク幅が僅かにズレる。 +-- +-- 高レベル 'treePlot' は 'DTFit' 一つを取り (@df |-> decisionTree@ の返り値をそのまま +-- 渡せる)、 内部に載った特徴量名・クラス名を使う。 名前を手渡ししたい行列 fit 用は +-- 'treePlotRaw'。 'DTFit' は 'Plottable' なので @toPlot@ でも同じ図が出る。 +-- +-- [English]: Draws a decision tree as an __rpart.plot-style__ tree diagram +-- (annotation-based, on the analyze side). +-- +-- Each node is drawn as a rectangle, with +-- __the predicted class \/ all class probabilities \/ sample proportion__ +-- written inside on three lines (equivalent to rpart.plot's default +-- @type=2@). Wiring follows R: +-- __no vertical line is drawn from the parent to the bus__; +-- the split condition @feat < thr@ is placed on a horizontal bus just +-- below the parent, and the branches leave from its two ends and bend down +-- directly above each child. Bordered white boxes with @yes@ (left = holds) +-- \/ @no@ (right) flank the condition (root split only). +-- +-- Fill colors follow rpart.plot's @box.palette="auto"@: each class is +-- assigned a sequential ColorBrewer palette (Reds\/Greys\/Greens\/…), with +-- __shade encoding the predicted class's probability (confidence)__ +-- (light = low, dark = high). Dark fills automatically get white text. A +-- class-color legend is shown in the top right. +-- +-- The 1st argument is the feature names, the 2nd is the class names (same +-- form as @printRpart@; falls back to @f{i}@\/integers when too short). The +-- tree layout spaces leaves evenly left→right, maps depth to the vertical +-- position, and computes coordinates in panel-normalized units (PNpc). It +-- is drawn purely via annotation without touching the plot core types (a +-- hand-off to a proper plot mark is planned once the diagram stabilizes; +-- PS parity will be handled at hand-off time). +-- +-- ⚠ Since annotation cannot measure text width, it is approximated in npc +-- units (@wpc@). The default is tuned for a figure width of ~680px; box \/ +-- mask widths drift slightly at extreme sizes. +-- +-- The high-level 'treePlot' takes a single 'DTFit' (the return value of +-- @df |-> decisionTree@ can be passed straight through), using the feature +-- \/ class names carried inside it. For matrix fits where you want to pass +-- names explicitly, use 'treePlotRaw'. Since 'DTFit' is 'Plottable', @toPlot@ +-- produces the same diagram. +treePlot :: DTFit -> VisualSpec +treePlot (DTFit tree feats classes) = treePlotRaw feats classes tree + +-- | [日本語]: 行列 fit 用の低レベル版 — 特徴量名・クラス名を明示的に渡す (名無しは @f{i}@/整数へ +-- フォールバック)。 +-- [English]: The low-level variant for matrix fits — pass feature \/ class +-- names explicitly (falls back to @f{i}@\/integers when unnamed). +treePlotRaw :: [Text] -> [Text] -> DTree -> VisualSpec +treePlotRaw featNames classNames tree = + theme ThemeVoid + <> xAxis hideTicks <> yAxis hideTicks -- 目盛線・目盛ラベルを消す (樹形図は座標軸不要)。 + <> legendLayer -- クラス色の凡例 (標準機構・他マークと同じ)。 + <> themeLegendFont (fontSize 11) -- 凡例文字をノード (class 11pt) に揃える。 + <> mconcat (concatMap edgesOf allNodes) -- 枝を先に (ノード矩形の下敷き)。 + <> mconcat (concatMap nodeAnns allNodes) + where + (nLeaves, root) = assign 0 0 tree + allNodes = flatten root + total = tpN root + maxD = maximum (map tpDepth allNodes) + classes = Map.keys (Map.fromList + [ (c, ()) | t <- allNodes + , c <- tpMaj t : Map.keys (tpProbs t) ]) + nClasses = length classes + colorIx = Map.fromList (zip classes [0 :: Int ..]) + + -- ---- 配色: rpart.plot box.palette="auto" 準拠 -------------------------- + -- クラスごとに ColorBrewer 連番パレット (Reds/Greys/Greens/…) を割当て、 + -- 塗りの **濃淡で予測クラスの確率 (確信度)** を表す。 R iris 実測と一致: + -- setosa=Reds・versicolor=Greys・virginica=Greens、 淡=低確率・濃=高確率。 + nodeFill t = + let pi_ = maybe 0 id (Map.lookup (tpMaj t) colorIx) + pal9 = ix greysP brewerPals (pi_ `mod` length brewerPals) + p = Map.findWithDefault 0 (tpMaj t) (tpProbs t) + in ix "#cccccc" pal9 (shadeIx p) + -- 予測確率 p∈[1/K,1] を 9 段 palette の index (概ね 1..5) へ (R 実測に fit)。 + shadeIx p = + let k = fromIntegral (max 2 nClasses) :: Double + in max 0 (min 8 (round (1 + (p - 1 / k) / (1 - 1 / k) * 4) :: Int)) + -- 塗りが暗いときは白文字 (簡易輝度判定)。 + textColorFor hex = if luminance hex < 0.5 then "#ffffff" else "#111111" + + -- ---- npc 座標変換 ----------------------------------------------------- + leftM = 0.04; rightM = 0.04; topM = 0.85; botM = 0.16 + spanX = 1 - leftM - rightM + xNpc u = leftM + (u + 0.5) / fromIntegral nLeaves * spanX + yNpc d | maxD <= 0 = topM + | otherwise = topM - fromIntegral d / fromIntegral maxD * (topM - botM) + colW = spanX / fromIntegral nLeaves + -- 箱は中身 (最長のクラス名 / 確率行) に合わせて締める (スカスカ回避)。 フォントは + -- **凡例 (themeLegendFont 11pt) と揃える** (class 11 / 数値 10)。 font を膨らませず + -- 箱側を締めて詰めて見せる (凡例とノードのサイズを統一)。 + contentW = maximum (0.06 : [ wpc 10 (plineOf t) | t <- allNodes ] + ++ [ wpc 11 (classLabel (tpMaj t)) | t <- allNodes ]) + hw = min (colW * 0.47) (contentW / 2 + 0.016) -- 矩形半幅。 + hh = 0.054 -- 矩形半高。 + dy = 0.030 -- 3 行ラベルの行間 (npc)。 + bc = -0.011 -- ベースライン補正 (npc・下げて上下中央に見せる)。 + plineOf t = T.intercalate " " + [ fmtP (Map.findWithDefault 0 c (tpProbs t)) | c <- classes ] + + -- ---- ノード矩形 + 3 行ラベル (rpart.plot type=2 相当・上下中央) --------- + -- 1 行目 = 予測クラス、 2 行目 = 全クラス確率 (.34 .30 .35 形式)、 + -- 3 行目 = 全体に占めるサンプル割合 (%)。 + nodeAnns t = + let x = xNpc (tpU t); y = yNpc (tpDepth t) + fill = nodeFill t + tc = textColorFor fill + pct = 100 * fromIntegral (tpN t) / fromIntegral total :: Double + box = rectA fill "#404040" 0.7 (x - hw) (y - hh) (x + hw) (y + hh) + l1 = textC tc x (y + dy + bc) 11 (classLabel (tpMaj t)) + l2 = textC tc x (y + bc) 10 (plineOf t) + l3 = textC tc x (y - dy + bc) 10 (fmt0 pct <> "%") + in [box, l1, l2, l3] + + -- ---- 凡例 (標準機構) -------------------------------------------------- + -- 手描き annotation は中央アンカーで文字が揃わないため、 **他マークと同じ + -- 凡例機構**に載せる: 不可視 (alpha 0) の colorBy 散布レイヤを 1 枚足し、 + -- 'scaleColorManual' で各クラス名→代表色 (ColorBrewer index 4) を固定する。 + -- 凡例スウォッチは layer alpha 非適用ゆえ満色で出る (グリフだけ不可視)。 + reprColor i = ix "#888888" (ix greysP brewerPals (i `mod` length brewerPals)) 4 + legendLayer = + let cats = [ classLabel c | c <- classes ] :: [Text] + xs = [ fromIntegral i | i <- [0 .. nClasses - 1] ] :: [Double] + dict = [ (classLabel c, reprColor i) | (i, c) <- zip [0 :: Int ..] classes ] + in layer (scatter (inline xs) (inline xs) <> colorBy (inlineCat cats) <> alpha 0) + <> scaleColorManual dict + + -- ---- 枝 = rpart.plot type=2 の配線 ----------------------------------- + -- ★親→バスの縦線は引かない (R 準拠)。 分割ラベルを親の少し下に置き、 枝は + -- ラベル両端から水平に出て子の真上で下へ折れる。 中央 (ラベル/yes-no) 部分は + -- 線を描かないことで枝線をマスクする。 yes/no は **根の分岐のみ**・枠付き白箱。 + edgesOf t = case (tpKids t, tpSplit t) of + ([l, r], Just (f, thr)) -> + let px = xNpc (tpU t); pBot = yNpc (tpDepth t) - hh + lx = xNpc (tpU l); rx = xNpc (tpU r) + cTop = yNpc (tpDepth l) + hh -- 子上端 (左右子は同じ深さ)。 + busY = pBot - 0.03 -- バスは親の少し下 (縦線なし)。 + condTxt = featName f <> " < " <> fmt2 thr + lw = wpc 11 condTxt + isRoot = tpDepth t == 0 + -- 中央の非描画幅 (ラベル + 根なら yes/no 箱ぶん)。 + clr = lw / 2 + (if isRoot then 0.075 else 0.008) + branch = [ lineA lx busY (px - clr) busY -- 左枝 (水平)。 + , lineA (px + clr) busY rx busY -- 右枝 (水平)。 + , lineA lx busY lx cTop -- 左子へ縦。 + , lineA rx busY rx cTop ] -- 右子へ縦。 + cond = textA px (busY - 0.004) 11 condTxt + yn = if isRoot + then labelBox (px - lw / 2 - 0.03) busY "yes" + ++ labelBox (px + lw / 2 + 0.026) busY "no" + else [] + in branch ++ cond : yn + _ -> [] + + -- yes/no の枠付き白箱 (中央にテキスト)。 + labelBox cx cy txt = + let w = wpc 10 txt + 0.014; h = 0.03 + in [ rectA "#ffffff" "#555555" 0.7 (cx - w / 2) (cy - h / 2) (cx + w / 2) (cy + h / 2) + , textA cx (cy - 0.004) 10 txt ] + + -- ---- annotation プリミティブ (PNpc 固定) ---------------------------- + rectA fill stroke sw x1 y1 x2 y2 = annotate $ + AnnRect (PNpc x1) (PNpc y1) (PNpc x2) (PNpc y2) fill stroke sw 1.0 + textA = textC "#111111" + textC col x y sz t = annotate $ + AnnText (PNpc x) (PNpc y) t col sz + lineA x1 y1 x2 y2 = annotate $ + AnnLine (PNpc x1) (PNpc y1) (PNpc x2) (PNpc y2) "#606060" 0.8 + + -- 文字列の描画幅を npc で概算 (font px と文字数から線形近似・図幅 ~680px 前提)。 + -- annotation は実測不可ゆえの heuristic。 doc/demo は size を指定して調律に合わせる。 + wpc fs t = 0.00095 * fs * fromIntegral (T.length t) + + -- ---- 名前解決 (@printRpart@ と同じ規則) ------------------------------ + featName i = pick i featNames ("f" <> tShowI i) + classLabel i = pick i classNames (tShowI i) + pick i xs d = case drop i xs of + (nm : _) | not (T.null nm) -> nm + _ -> d + + tShowI = T.pack . show :: Int -> Text + fmt2 x = T.pack (showFFloat (Just 2) x "") + fmt0 x = T.pack (showFFloat (Just 0) x "") + -- rpart.plot 流の確率表記 (先頭 0 を落として ".34"、 1.00 は据置き)。 + fmtP x = let s = T.pack (showFFloat (Just 2) x "") + in maybe s id (T.stripPrefix "0" s) + ix d xs i = if i >= 0 && i < length xs then xs !! i else d + +-- | [日本語]: 'DTree' を葉単位で位置付けした 'TPNode' へ変換する。 葉に左→右で連番 (slot) を +-- 振り、 内部ノードは左右子の中点を水平座標にする。 戻りは (葉総数, 根ノード)。 +-- [English]: Converts a 'DTree' into a leaf-positioned 'TPNode'. Assigns +-- leaves consecutive left→right numbers (slots), and gives internal nodes +-- the midpoint of their left\/right children as horizontal coordinate. +-- Returns @(total leaf count, root node)@. +assign :: Int -> Int -> DTree -> (Int, TPNode) +assign depth k node = case node of + DLeaf p m n _ -> + (k + 1, TPNode (fromIntegral k) depth m n p Nothing []) + DNode f thr l r n _ p m -> + let (k1, lp) = assign (depth + 1) k l + (k2, rp) = assign (depth + 1) k1 r + u = (tpU lp + tpU rp) / 2 + in (k2, TPNode u depth m n p (Just (f, thr)) [lp, rp]) + +-- | [日本語]: 'TPNode' 木を前順で平坦化する。 +-- [English]: Flattens a 'TPNode' tree in pre-order. +flatten :: TPNode -> [TPNode] +flatten t = t : concatMap flatten (tpKids t) + +-- | [日本語]: ColorBrewer 9 段連番パレット (rpart.plot box.palette="auto" の per-class 割当)。 +-- クラス index 0,1,2,… に Reds, Greys, Greens, Blues, Purples, Oranges を循環割当。 +-- [English]: The 9-step sequential ColorBrewer palettes (rpart.plot's +-- @box.palette="auto"@ per-class assignment). Class indices 0,1,2,… cycle +-- through Reds, Greys, Greens, Blues, Purples, Oranges. +brewerPals :: [[Text]] +brewerPals = [redsP, greysP, greensP, bluesP, purplesP, orangesP] + +redsP, greysP, greensP, bluesP, purplesP, orangesP :: [Text] +redsP = ["#fff5f0","#fee0d2","#fcbba1","#fc9272","#fb6a4a","#ef3b2c","#cb181d","#a50f15","#67000d"] +greysP = ["#ffffff","#f0f0f0","#d9d9d9","#bdbdbd","#969696","#737373","#525252","#252525","#000000"] +greensP = ["#f7fcf5","#e5f5e0","#c7e9c0","#a1d99b","#74c476","#41ab5d","#238b45","#006d2c","#00441b"] +bluesP = ["#f7fbff","#deebf7","#c6dbef","#9ecae1","#6baed6","#4292c6","#2171b5","#08519c","#08306b"] +purplesP = ["#fcfbfd","#efedf5","#dadaeb","#bcbddc","#9e9ac8","#807dba","#6a51a3","#54278f","#3f007d"] +orangesP = ["#fff5eb","#fee6ce","#fdd0a2","#fdae6b","#fd8d3c","#f16913","#d94801","#a63603","#7f2704"] + +-- | [日本語]: @#rrggbb@ の相対輝度 (0..1・Rec.601 加重和)。 塗りの明暗で文字色を切替える用。 +-- [English]: The relative luminance of a @#rrggbb@ color (0..1, Rec.601 +-- weighted sum). Used to switch text color based on fill lightness. +luminance :: Text -> Double +luminance hex = + let s = T.dropWhile (== '#') hex + hx a b = fromIntegral (16 * hv a + hv b) :: Double + hv c | c >= '0' && c <= '9' = fromEnum c - fromEnum '0' + | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10 + | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10 + | otherwise = 0 + in case T.unpack s of + (r1:r2:g1:g2:b1:b2:_) -> + (0.299 * hx r1 r2 + 0.587 * hx g1 g2 + 0.114 * hx b1 b2) / 255 + _ -> 1 + +-- =========================================================================== +-- 分類 (Discriminant / NaiveBayes / KNN) — Phase 68 A3 +-- +-- 代表図は **決定境界** と **confusion 行列**。 いずれも「学習済モデルを評価点で +-- 走らせる」 図ゆえ、 KMeans (A1) と同じく **データ/範囲を取るヘルパ**で提供する +-- (新規 plot mark 不要): +-- +-- * @decisionBoundaryOf@ = 2D grid を予測しクラス色で塗る (= 連続軸の散布を +-- 四角マーカー・低 alpha で「領域」表現。 ★renderHeatmap はカテゴリ軸なので +-- 連続 grid には不適 → 'MScatter' + 'colorBy' (離散色) を採用)。 2 特徴前提。 +-- * 'confusionOf' = テストデータの真値×予測の件数を @MHeatmap@ で (カテゴリ軸が適合)。 +-- +-- 'Plottable' の @toPlot@ (データ非保持で描ける代表 1 枚): +-- * KNN は訓練データ ('knnCX'/'knnCY') を保持 → **ラベル色の訓練点散布**。 +-- * Discriminant / NaiveBayes(Gaussian) は **クラス平均散布** (✚)、 +-- NaiveBayes(Multinomial) は **クラス事前確率 bar**。 +-- =========================================================================== + + +instance ClassPredict DiscriminantFit where + predictClasses fit m = V.toList (fst (predictDiscriminant fit m)) + +instance ClassPredict NBModel where + predictClasses nb m = VU.toList (predictNB nb m) + classNamesOf (NBGaussian g) = gnbClassNames g + classNamesOf (NBMultinomial g) = mnbClassNames g + +instance ClassPredict KNNClassifier where + predictClasses knn m = VU.toList (predictKNNC knn m) + classNamesOf = knnCClassNames + +-- Phase 75.5: 分類 NN も同様に decisionBoundaryOf / confusionOf 対応。 +instance ClassPredict MLPFit where + predictClasses fit m = V.toList (predictMLPClass fit m) + classNamesOf = mlpClassNames + +-- Phase 75.12: カーネル SVM (真の SV) も decisionBoundaryOf (非線形境界) / confusionOf 対応。 +instance ClassPredict SVM where + predictClasses m x = VU.toList (predictSVM m x) + +instance ClassPredict SVMMulti where + predictClasses m x = VU.toList (predictSVMMulti m x) + classNamesOf = svmmClassNames + +-- | [日本語]: 決定境界 (2 特徴) の __領域塗り__ (annotation ベース)。 +-- +-- @res×res@ の格子セルを中心で予測し、 各セルを予測クラス色の塗り矩形 ('annotRectP') +-- で敷き詰める (sklearn @DecisionBoundaryDisplay@ の pcolormesh 相当)。 点散布でなく +-- __実矩形__ をセル境界ぴったりに敷くので、 旧実装 (半透明の四角散布) の __縞模様__ が出ない。 +-- +-- クラス色は @toPlot@ の凡例 (@colorBy@ → ggplot @hue_pal()@) と一致させる。 render が +-- categorical を @sort.nub@ 順に並べ 'ggplotHue' を割り当てるのと同順で再現する。 +-- 訓練点・クラス平均は呼び出し側で上に重ねる (@decisionBoundaryOf c xr yr res \<\> toPlot c@)。 +-- +-- ⚠ __annotation の制約__: 塗りは 'annotRectP' 固定の @fill-opacity=0.2@ (薄塗り)。 +-- また annotation は layer の __後__ に描かれるため、 塗りは重ねた訓練点の __上__ に来る +-- (0.2 の薄塗りなので点は透けて見える)。 「点が上・塗りが下」 の厳密な重ね順や +-- 半透明でない濃淡は将来 plot 正式 mark (@MTile@/@MRaster@) 移譲時に対応する。 +-- クラス色は既定 hue パレット前提 (theme series palette を差し替えた場合、 塗り色は +-- 追従しない — annotation 色は spec 時に確定するため)。 +-- +-- [English]: __Filled region__ rendering of the decision boundary (2 +-- features; annotation-based). +-- +-- Predicts at the center of each @res×res@ grid cell and tiles each cell as +-- a fill rectangle ('annotRectP') colored by the predicted class +-- (equivalent to sklearn's @DecisionBoundaryDisplay@ pcolormesh). Since it +-- tiles __actual rectangles__ flush with cell boundaries rather than point +-- scatter, it doesn't show the __striping__ of the old implementation +-- (semi-transparent square scatter). +-- +-- Class colors are kept in sync with @toPlot@\'s legend (@colorBy@ → ggplot +-- @hue_pal()@): the same procedure render uses — sorting categoricals in +-- @sort.nub@ order and assigning 'ggplotHue' — is reproduced here. Training +-- points and class means are overlaid by the caller +-- (@decisionBoundaryOf c xr yr res \<\> toPlot c@). +-- +-- ⚠ __Annotation constraints__: fills use 'annotRectP'\'s fixed +-- @fill-opacity=0.2@ (light fill). Also, since annotations are drawn +-- __after__ layers, the fill ends up __on top of__ any overlaid training +-- points (points still show through the 0.2 light fill). Strict "points on +-- top, fill below" ordering, or non-transparent shading, is deferred to a +-- future hand-off to a proper plot mark (@MTile@\/@MRaster@). Class colors +-- assume the default hue palette (if the theme's series palette is +-- swapped, the fill colors won't follow — annotation colors are fixed at +-- spec time). +decisionBoundaryOf + :: ClassPredict c => c -> (Double, Double) -> (Double, Double) -> Int -> VisualSpec +decisionBoundaryOf c (x0, x1) (y0, y1) res + | res <= 0 || x1 <= x0 || y1 <= y0 = mempty + | otherwise = + -- 軸ドメインをグリッド範囲へ正確に固定 (expand=FALSE)。 annotation は軸を駆動しない + -- ため、 これが無いと軸がデータ点範囲に縮み塗りがフレーム外へはみ出す (sklearn は + -- 軸 = グリッド範囲)。 範囲外の重畳点は panel に clip される。 + coordCartesian x0 x1 y0 y1 <> mconcat + [ annotRectP (PNative cx0) (PNative cy0) (PNative cx1) (PNative cy1) (colorFor k) + | (idx, k) <- zip [0 :: Int ..] preds + , let (i, j) = idx `divMod` res + cx0 = x0 + fromIntegral i * dx + cx1 = cx0 + dx + cy0 = y0 + fromIntegral j * dy + cy1 = cy0 + dy ] + where + dx = (x1 - x0) / fromIntegral res + dy = (y1 - y0) / fromIntegral res + -- セル中心 (行 = i*res + j・列 = [x, y]) をまとめて 1 回でバッチ予測する。 + centers = [ [ x0 + (fromIntegral i + 0.5) * dx, y0 + (fromIntegral j + 0.5) * dy ] + | i <- [0 .. res - 1], j <- [0 .. res - 1] ] + preds = predictClasses c (LA.fromLists centers) + -- クラス色の対応: render は colorBy の categorical を sort.nub 順に並べ ggplotHue を + -- 割り当てる。 同じ手順を再現し、 予測クラス k → クラス名 → cats 内 index → 色。 + names = classNamesOf c + labelOf k = classNameByIx names k + classK = if null names then sort (nub preds) else [0 .. length names - 1] + cmap = hueColorMap (map labelOf classK) + colorFor k = Map.findWithDefault "#cccccc" (labelOf k) cmap + +-- | [日本語]: confusion 行列のヒートマップ: テストデータ @X@ を予測し、 真値 @yTrue@ との件数を +-- x=予測 / y=真値 のセルに集計する (@MHeatmap@・色 = 件数)。 +-- [English]: A confusion-matrix heatmap: predicts on test data @X@ and +-- tallies counts against the true value @yTrue@ into cells with +-- x=predicted \/ y=true (@MHeatmap@; color = count). +-- | [日本語]: クラス番号 k → 名前 (levels があれば @names !! k@・範囲外/空なら整数 show)。 +-- 分類 toPlot / confusion がクラス名を出す共通ヘルパ。 +-- [English]: Class number k → name (@names !! k@ if levels exist; +-- otherwise the integer's @show@). A shared helper used by classification +-- toPlot \/ confusion to render class names. +classNameByIx :: [Text] -> Int -> Text +classNameByIx names k + | k >= 0 && k < length names = names !! k + | otherwise = T.pack (show k) + +confusionOf :: ClassPredict c => c -> LA.Matrix Double -> [Int] -> VisualSpec +confusionOf c x yTrue = + let yPred = predictClasses c x + classes = sort (nub (yTrue ++ yPred)) + -- クラス番号 → クラス名 (levels があれば名前・無ければ整数)。 対角は t==p→同名→ + -- 同 index ゆえ、 名前順が整数順とずれても混同行列は正しい (対角=正解が保たれる)。 + nameOf = classNameByIx (classNamesOf c) + counts = Map.fromListWith (+) [ ((t, p), 1 :: Int) | (t, p) <- zip yTrue yPred ] + cells = [ (t, p, Map.findWithDefault 0 (t, p) counts) | t <- classes, p <- classes ] + xs = [ nameOf p | (_, p, _) <- cells ] + ys = [ nameOf t | (t, _, _) <- cells ] + vs = [ fromIntegral nC | (_, _, nC) <- cells ] :: [Double] + -- セル件数の数値注釈 (sklearn ConfusionMatrixDisplay 同型)。 heatmap の categorical + -- 軸は label を 'orderedCats' (= sort.nub) の index 位置に置くので、 text は同じ + -- index 位置 (数値座標) に重ねる (任意クラス数で整合)。 背景 box 付き ('label') ゆえ + -- viridis のどのセル色 (暗紫〜黄) でも読める。 + axisLabels = sort (nub xs) -- x/y 同 classes ゆえ共通・軸順と一致 + idxOf lbl = maybe 0 fromIntegral (elemIndex lbl axisLabels) :: Double + txIdx = [ idxOf (nameOf p) | (_, p, _) <- cells ] + tyIdx = [ idxOf (nameOf t) | (t, _, _) <- cells ] + cntTxt = [ T.pack (show nC) | (_, _, nC) <- cells ] + in layer (heatmap (inlineCat xs) (inlineCat ys) (inline vs)) + <> layer (label (inline txIdx) (inline tyIdx) (inlineCat cntTxt)) + <> xLabel "predicted" <> yLabel "true" + +-- =========================================================================== +-- MDS 埋め込み (モデル型 'MDSResult' + 群色オプション) — Phase 75.21 +-- +-- 'MDSResult' は @df |-> mds cfg cols@ の結果 (PCAResult 同格のモデル型)。 +-- 既定は単色散布 ('Plottable' 'MDSResult' の @toPlot m@)、 群色は元データの列名を +-- 指定する 'mdsGroupBy' を @<>@ で合成する (regression の @statModel <> statColor@ と +-- 同形。 ただし 'statColor' は 'Color' 専用ゆえ「列名で群色」は別オプション)。 +-- +-- > m = df |-> mds defaultMDS ["x1","x2","x3"] +-- > noDf |>> toPlot m -- 単色 +-- > noDf |>> toPlot (mdsView m <> mdsGroupBy "species") -- species で群色 +-- +-- MDS は反転・回転自由度があるので軸の向きは本質でない (相対配置を見る)。 +-- =========================================================================== + +-- | [日本語]: MDS 埋め込みの描画オプション束 (Monoid)。 'mdsView' で結果を載せ、 +-- 'mdsGroupBy' で群色列を足して @<>@ で合成する。 +-- [English]: A bundle of MDS embedding rendering options (Monoid). Load the +-- result via 'mdsView', then compose with @<>@ to add a group-color column +-- via 'mdsGroupBy'. +data MDSView = MDSView + { mvResult :: !(Maybe MDSResult) -- ^ [日本語]: 描く埋め込み (後勝ち)。 [English]: The embedding to draw (last write wins). + , mvGroupCol :: !(Maybe Text) -- ^ [日本語]: 群色に使う元データの列名 (後勝ち)。 [English]: The source data column name used for group color (last write wins). + } + +instance Semigroup MDSView where + a <> b = MDSView (orElse (mvResult b) (mvResult a)) + (orElse (mvGroupCol b) (mvGroupCol a)) + where orElse (Just x) _ = Just x + orElse Nothing y = y + +instance Monoid MDSView where + mempty = MDSView Nothing Nothing + +-- | [日本語]: MDS 結果を描画オプションに載せる (@<>@ の起点)。 +-- [English]: Loads an MDS result into rendering options (the @<>@ starting +-- point). +mdsView :: MDSResult -> MDSView +mdsView m = mempty { mvResult = Just m } + +-- | [日本語]: 元データの列名で群色を付ける (factor/数値どちらでも categorical 色に)。 +-- @toPlot (mdsView m <> mdsGroupBy "species")@。 +-- [English]: Adds group color from a source-data column name (factor or +-- numeric alike become categorical color). @toPlot (mdsView m <> mdsGroupBy "species")@. +mdsGroupBy :: Text -> MDSView +mdsGroupBy c = mempty { mvGroupCol = Just c } + +instance Plottable MDSResult where + -- 単色の埋め込み散布。 + toPlot m = toPlot (mdsView m) + +instance Plottable MDSView where + toPlot v = case mvResult v of + Nothing -> mempty + Just m -> + let cols = LA.toColumns (mdsEmbedding m) + xs = if not (null cols) then LA.toList (head cols) else [] + ys = if length cols >= 2 then LA.toList (cols !! 1) else replicate (length xs) 0 + base = scatter (inline xs) (inline ys) + withColor = case mvGroupCol v >>= \gc -> groupLabels gc (mdsSourceFrame m) of + Just labs -> base <> colorBy (inlineCat labs) + Nothing -> base + in layer withColor <> xLabel "MDS1" <> yLabel "MDS2" + +-- | [日本語]: 元データの列を categorical な群ラベル ('[Text]') に変換する。 text 列 +-- ('getTextVec') を優先し、 無ければ数値列 ('getDoubleVec') を整数寄せで文字列化。 +-- [English]: Converts a source-data column into categorical group labels +-- ('[Text]'). Prefers a text column ('getTextVec'); otherwise falls back to +-- a numeric column ('getDoubleVec'), stringified with integer rounding. +groupLabels :: Text -> DXD.DataFrame -> Maybe [Text] +groupLabels gc frame = + case getTextVec gc frame of + Just tv -> Just (V.toList tv) + Nothing -> case getDoubleVec gc frame of + Just dv -> Just (map numLabel (V.toList dv)) + Nothing -> Nothing + where + -- 整数値は小数点を出さない (0.0 → "0")。 + numLabel x = let r = round x :: Int + in if fromIntegral r == x then T.pack (show r) else T.pack (show x) + +-- | [日本語]: NN 学習損失曲線。 'mlpLossHist' (エポックごとの損失) を epoch (x) 対 +-- loss (y) の line で描く。 損失が単調減少して平坦化すれば収束 (keras @history@ 同型)。 +-- [English]: The NN training loss curve. Draws 'mlpLossHist' (per-epoch +-- loss) as a line of epoch (x) against loss (y). Monotonic decrease +-- flattening out indicates convergence (equivalent to keras's @history@). +nnLossOf :: MLPFit -> VisualSpec +nnLossOf fit = + let losses = mlpLossHist fit + epochs = [ fromIntegral i | i <- [1 .. length losses] ] :: [Double] + in layer (line (inline epochs) (inline losses)) + <> xLabel "epoch" <> yLabel "loss" + +-- | [日本語]: カーネル SVM のサポートベクタ (α>0 の点) を強調散布する。 第 0/1 特徴を +-- __そのクラスの色のまま ✚ (cross) マーカー__ で打つ (通常点 ○ と形で区別・色はクラスで一致)。 +-- 決定境界に重ねて「SV が境界を定義する」 様子を見る。 凡例は通常点散布側に任せる +-- ('legendOff')。 SV が無い/1 次元なら空。 +-- [English]: Emphasis-scatters the kernel SVM's support vectors (points +-- with α>0). Features 0\/1 are plotted with a +-- __cross marker in the same color as the class__ +-- (distinguished from ordinary points' circle shape, with matching class +-- color). Overlaid on the decision boundary to show how +-- SVs define it. The legend is left to the ordinary point scatter +-- ('legendOff'). Empty if there are no SVs or the data is 1-dimensional. +svmSupportVectorsOf :: SVM -> VisualSpec +svmSupportVectorsOf m = + let cols = LA.toColumns (svmSVx m) + xs = if not (null cols) then LA.toList (head cols) else [] + ys = if length cols >= 2 then LA.toList (cols !! 1) else [] + -- svmSVy は ±1 (+1 = 正クラス=1・-1 = クラス 0)。 散布の colorBy "cls" と同綴りに + -- "0"/"1" の categorical 色で合わせる (= 同グループ同色)。 + labs = [ if y > 0 then "1" else "0" | y <- VU.toList (svmSVy m) ] :: [Text] + in if null xs || null ys then mempty + else layer ( scatter (inline xs) (inline ys) + <> colorBy (inlineCat labs) <> shape MShCross ) + +-- | [日本語]: 連続な決定スコアを持つ分類器 (decisionLineOf 用)。 score ≥ 0 が片クラス、 < 0 が他。 +-- [English]: A classifier with a continuous decision score (for +-- decisionLineOf). @score ≥ 0@ is one class, @< 0@ is the other. +class ScorePredict c where + decisionScore :: c -> LA.Matrix Double -> [Double] + +instance ScorePredict SVM where + decisionScore m x = VU.toList (predictSVMScore m x) + +-- | [日本語]: 決定境界を __線 (等高線)__ で描く。 @decisionBoundaryOf@ が領域を色で +-- 塗り分けるのに対し、 こちらは決定スコア = 0 の等値線を marching squares で引く +-- (sklearn の @contour(…, levels=[0])@ 相当)。 スコアベースなので滑らかな曲線になる。 +-- @res@ = grid 解像度 (大きいほど滑らか)。 2 特徴前提。 +-- [English]: Draws the decision boundary as a __line (contour)__. Whereas +-- @decisionBoundaryOf@ fills regions with color, this draws the +-- score-equals-zero level curve via marching squares (equivalent to +-- sklearn's @contour(…, levels=[0])@). Being score-based, it produces a +-- smooth curve. @res@ = grid resolution (larger = smoother); assumes 2 +-- features. +decisionLineOf :: ScorePredict c + => c -> (Double, Double) -> (Double, Double) -> Int -> VisualSpec +decisionLineOf c (xlo, xhi) (ylo, yhi) res0 = + let res = max 2 res0 + ax i = xlo + (xhi - xlo) * fromIntegral i / fromIntegral (res - 1) + ay j = ylo + (yhi - ylo) * fromIntegral j / fromIntegral (res - 1) + xsV = V.generate res ax + ysV = V.generate res ay + grid = LA.fromLists [ [xsV V.! i, ysV V.! j] | j <- [0 .. res - 1], i <- [0 .. res - 1] ] + zV = V.fromList (decisionScore c grid) -- row-major: index = j*res + i + z i j = zV V.! (j * res + i) + lvl = 0 :: Double + straddle a b = (a < lvl) /= (b < lvl) + interp (px, py) (qx, qy) va vb = + let t = (lvl - va) / (vb - va) in (px + t * (qx - px), py + t * (qy - py)) + cellSegs i j = + let p00 = (xsV V.! i, ysV V.! j); v00 = z i j + p10 = (xsV V.! (i+1), ysV V.! j); v10 = z (i+1) j + p01 = (xsV V.! i, ysV V.! (j+1)); v01 = z i (j+1) + p11 = (xsV V.! (i+1), ysV V.! (j+1)); v11 = z (i+1) (j+1) + cross = concat + [ [ interp p00 p10 v00 v10 | straddle v00 v10 ] + , [ interp p10 p11 v10 v11 | straddle v10 v11 ] + , [ interp p01 p11 v01 v11 | straddle v01 v11 ] + , [ interp p00 p01 v00 v01 | straddle v00 v01 ] ] + in case cross of + [a, b] -> [(a, b)] + [a, b, d, e] -> [(a, b), (d, e)] -- saddle (近似ペアリング) + _ -> [] + segs = concat [ cellSegs i j | i <- [0 .. res - 2], j <- [0 .. res - 2] ] + in mconcat + [ layer ( line (inline [x1, x2]) (inline [y1, y2]) + <> color (fromHex "#333333") ) + | ((x1, y1), (x2, y2)) <- segs ] + + + +-- =========================================================================== +-- 部分従属図 (PDP / ICE) — Phase 75.27 +-- +-- 純粋エンジン 'partialDependence' ('Model.PartialDependence') を VisualSpec に落とす +-- 玄関。 回帰モデルは 'RegPredict' instance で短く (@pdpPlot rf trainX 0 "age"@)、 未対応の +-- モデルや分類確率は predict 閉包を直接渡す escape hatch (@partialDependencePlot@) で描く。 +-- R @pdp::partial@ / sklearn @PartialDependenceDisplay@ 相当。 +-- =========================================================================== + +-- | [日本語]: 学習済モデルを評価点行列で走らせ、 各行の __連続予測値__ を返す共通インターフェース +-- (回帰モデルの PDP を種に依らず組むための薄い抽象)。 分類確率など instance の無い +-- ものは 'partialDependencePlot' に predict 閉包を直接渡す。 +-- [English]: A common interface that runs a trained model on an +-- evaluation-point matrix and returns a __continuous prediction__ per +-- row (a thin abstraction letting regression-model PDPs be built without +-- caring about model kind). Models lacking an instance — such as +-- classification probabilities — pass a predict closure directly to +-- 'partialDependencePlot'. +class RegPredict m where + predictReg :: m -> LA.Matrix Double -> [Double] + +instance RegPredict RandomForest where + predictReg rf x = map (RF.predictRF rf) (LA.toLists x) + +instance RegPredict GBRegressor where + predictReg gb x = VU.toList (predictGBR gb x) + +-- | [日本語]: 高レベル PDP: 訓練 df ('ColumnSource') と __列名__ で部分従属図を描く。 +-- @featCols@ = fit に使った特徴列 (順序込み)、 @target@ = 部分従属を見る列。 注目特徴を +-- 観測範囲の grid で振り、 他特徴は訓練分布のまま各行予測して平均した曲線を描く +-- (R pdp / sklearn @kind=@average@@ 相当)。 列が引けない / target が featCols に無いときは空図。 +-- [English]: The high-level PDP: draws a partial-dependence plot from a +-- training df ('ColumnSource') and __column names__. @featCols@ = the +-- feature columns used to fit (in order), @target@ = the column to view +-- partial dependence for. Sweeps the feature of interest over a grid +-- spanning its observed range, predicts each row with the other features +-- held at their training distribution, and draws the averaged curve +-- (equivalent to R's pdp \/ sklearn's @kind=@average@@). Yields an empty +-- plot if the columns can't be resolved or @target@ isn't in @featCols@. +pdpOf :: (RegPredict m, ColumnSource d) => m -> d -> [Text] -> Text -> VisualSpec +pdpOf model d featCols target = + case (reqColsM featCols d, elemIndex target featCols) of + (Right x, Just j) -> partialDependencePlot x (predictReg model) j target + _ -> mempty + +-- | [日本語]: 高レベル PDP + ICE 重畳 (sklearn @kind=@both@@)。 個体条件付き期待 (ICE) を薄灰で観測数 +-- ぶん重ね、 平均 (PDP) を上描きする。 'pdpOf' の ICE 版。 +-- [English]: The high-level PDP + ICE overlay (sklearn @kind=@both@@). +-- Overlays individual conditional expectation (ICE) curves in light gray, +-- one per observation, then draws the average (PDP) on top. The ICE +-- variant of 'pdpOf'. +pdpIceOf :: (RegPredict m, ColumnSource d) => m -> d -> [Text] -> Text -> VisualSpec +pdpIceOf model d featCols target = + case (reqColsM featCols d, elemIndex target featCols) of + (Right x, Just j) -> partialDependenceIcePlot x (predictReg model) j target + _ -> mempty + +-- | [日本語]: 低レベル PDP: 訓練特徴 __行列__ と列 index を直接取る ('pdpOf' の実体)。 +-- [English]: The low-level PDP: takes the training feature __matrix__ and +-- column index directly (the implementation behind 'pdpOf'). +pdpPlot :: RegPredict m => m -> LA.Matrix Double -> Int -> Text -> VisualSpec +pdpPlot m x j name = partialDependencePlot x (predictReg m) j name + +-- | [日本語]: 低レベル PDP + ICE (行列・列 index 版)。 +-- [English]: The low-level PDP + ICE (matrix and column-index variant). +pdpIcePlot :: RegPredict m => m -> LA.Matrix Double -> Int -> Text -> VisualSpec +pdpIcePlot m x j name = partialDependenceIcePlot x (predictReg m) j name + +-- | [日本語]: 任意モデル用 PDP。 predict 閉包 (行列 → 予測値) を直接受ける escape hatch。 +-- 分類の部分従属 (あるクラスの予測確率) 等、 'RegPredict' instance の無いモデルに使う。 +-- [English]: PDP for any model. An escape hatch that takes a predict +-- closure (matrix → predictions) directly. Used for models without a +-- 'RegPredict' instance, such as classification partial dependence (a +-- given class's predicted probability). +partialDependencePlot + :: LA.Matrix Double -> (LA.Matrix Double -> [Double]) -> Int -> Text -> VisualSpec +partialDependencePlot x predict j name = + let r = partialDependence x predict j 40 + in if null (pdpGrid r) + then mempty + else layer ( line (inline (pdpGrid r)) (inline (pdpMean r)) + <> color (fromHex "#1f77b4") ) + <> xLabel name <> yLabel "partial dependence" + +-- | [日本語]: 任意モデル用 PDP+ICE。 'partialDependencePlot' の ICE 重畳版 (predict 閉包版)。 +-- [English]: PDP+ICE for any model. The ICE-overlay variant of +-- 'partialDependencePlot' (predict-closure version). +partialDependenceIcePlot + :: LA.Matrix Double -> (LA.Matrix Double -> [Double]) -> Int -> Text -> VisualSpec +partialDependenceIcePlot x predict j name = + let r = partialDependence x predict j 40 + g = pdpGrid r + in if null g + then mempty + else mconcat + [ layer ( line (inline g) (inline curve) + <> color (fromHex "#bbbbbb") <> alpha 0.35 ) + | curve <- PD.pdpIce r ] + <> layer ( line (inline g) (inline (pdpMean r)) + <> color (fromHex "#1f77b4") ) + <> xLabel name <> yLabel "partial dependence" + +-- --------------------------------------------------------------------------- +-- Phase 76.D: PDP を HBM 抽出子と同型に (Plottable 中間型 + toPlot・<> で合成) +-- +-- @pdpOf model d featCols target@ は @VisualSpec@ を直に返すが、 demo は @[] |>> (…)@ の +-- ダミー束ねが要り不格好だった。 HBM の @forestOf@/@epred@ と同じく **Plottable 中間型** +-- ('PDPView') にし、 @toPlot@ で描画・@<>@ で装飾を合成する: +-- +-- > noDf |>> (toPlot (pdp rf trainDf featCols target) <> title \"…\") +-- +-- ★HBM 抽出子は fit が事後分布を内包し自己完結だが、 RF/GBM は訓練データを保持しないため +-- PDP は訓練 df ('ColumnSource') を受け取る (周辺化に訓練分布が要る)。 予測は 'RegPredict'。 +-- --------------------------------------------------------------------------- + +data PDPKind = PDPAverage | PDPBoth + +-- | [日本語]: PDP の Plottable 中間型。 特徴行列・予測子・注目列 index を捕捉し、 +-- @toPlot@ で PDP (平均) / PDP+ICE 曲線に描く。 'pdp' / 'pdpIce' で作る。 +-- [English]: The Plottable intermediate type for PDP. Captures the +-- feature matrix, predictor, and the column index of interest, and draws +-- a PDP (average) \/ PDP+ICE curve via @toPlot@. Built with 'pdp' \/ +-- 'pdpIce'. +data PDPView = PDPView + { pvX :: !(LA.Matrix Double) -- 訓練特徴行列 (周辺化の分布) + , pvPredict :: LA.Matrix Double -> [Double] -- モデルの連続予測 (RegPredict 由来) + , pvJ :: !Int -- 注目特徴の列 index + , pvName :: !Text -- 注目特徴名 (x 軸) + , pvKind :: !PDPKind + } + +-- | [日本語]: 訓練 df + 特徴列から (特徴行列, 注目列 index) を解く。 引けない / target が featCols に +-- 無いときは 0×0 行列 (toPlot が 'mempty' にする)。 +-- [English]: Resolves @(feature matrix, target column index)@ from a +-- training df and feature columns. Yields a 0×0 matrix when the columns +-- can't be resolved or @target@ isn't in @featCols@ (which @toPlot@ turns +-- into 'mempty'). +pdpXJ :: ColumnSource d => d -> [Text] -> Text -> (LA.Matrix Double, Int) +pdpXJ d feats target = + case (reqColsM feats d, elemIndex target feats) of + (Right x, Just j) -> (x, j) + _ -> (LA.fromLists [], 0) + +-- | [日本語]: 平均部分従属 (PDP)。 @noDf |>> (toPlot (pdp model trainDf featCols target) <> …)@。 +-- [English]: Average partial dependence (PDP). +-- @noDf |>> (toPlot (pdp model trainDf featCols target) <> …)@. +pdp :: (RegPredict m, ColumnSource d) => m -> d -> [Text] -> Text -> PDPView +pdp model d feats target = + let (x, j) = pdpXJ d feats target in PDPView x (predictReg model) j target PDPAverage + +-- | [日本語]: PDP + ICE 重畳 (sklearn @kind=@both@@)。 個体曲線 (薄灰) + 平均 (青)。 +-- [English]: PDP + ICE overlay (sklearn @kind=@both@@). Individual curves +-- (light gray) + average (blue). +pdpIce :: (RegPredict m, ColumnSource d) => m -> d -> [Text] -> Text -> PDPView +pdpIce model d feats target = + let (x, j) = pdpXJ d feats target in PDPView x (predictReg model) j target PDPBoth + +instance Plottable PDPView where + toPlot (PDPView x predict j name k) + | LA.rows x == 0 = mempty + | otherwise = case k of + PDPAverage -> partialDependencePlot x predict j name + PDPBoth -> partialDependenceIcePlot x predict j name + +instance Plottable KNNClassifier where + -- 訓練データをラベル色で散布 (第 0/1 特徴)。 KNN は X/Y を保持するので data-rich。 + -- 凡例は df|-> が載せた knnCClassNames があればクラス名・無ければ整数 ('classNameByIx')。 + toPlot knn = + let cols = LA.toColumns (knnCX knn) + xs = if not (null cols) then LA.toList (head cols) else [] + ys = if length cols >= 2 then LA.toList (cols !! 1) else [] + labs = map (classNameByIx (knnCClassNames knn)) (VU.toList (knnCY knn)) + in layer (scatter (inline xs) (inline ys) <> colorBy (inlineCat labs)) + +instance Plottable DiscriminantFit where + toPlot fit = + classMeansScatter (LA.toLists (dfMeans fit)) + (map round (LA.toList (dfClasses fit))) + +instance Plottable NBModel where + toPlot (NBGaussian m) = + classMeansScatterNamed (map LA.toList (gnbMeans m)) (gnbClasses m) (gnbClassNames m) + toPlot (NBMultinomial m) = + let labels = [ classNameByIx (mnbClassNames m) cl | cl <- mnbClasses m ] + in layer (bar (inlineCat labels) (inline (map exp (mnbLogPrior m)))) + +-- =========================================================================== +-- 次元圧縮 (PLS / MultiGP) — Phase 68 A4 +-- +-- どちらも結果が自己完結 ('PCAResult' 同様) なので外部データ不要で 'Plottable': +-- +-- * 'PLSFit' = 潜在空間の **score plot** (標本 T) を代表図に、 'loading plot' (変数 P) +-- と **VIP bar** を診断図束に。 いずれも既存 'MScatter'/'bar'。 +-- * 'MultiGPResult' = **多出力の予測曲線 + 95% band** (出力ごとに色分け・x=index)。 +-- 'MLine' + 'MBand' を出力数ぶん重畳。 +-- +-- ※ 'Hanalyze.Model.MultiOutput' は変換+メトリクスの **ユーティリティ**で +-- fit 結果型を持たないため 'Plottable' 対象外 (多出力の「相関」図は既存 +-- 'MultiFit' = 残差相関 heatmap が担当)。 新規 plot mark は不要。 +-- =========================================================================== + + +-- | [日本語]: PLS 診断ビューの種別 (score / loading / VIP)。 +-- [English]: The PLS diagnostic view kind (score \/ loading \/ VIP). +data PLSViewKind = ScoreView | LoadingView | VipView + deriving (Show, Eq) + +-- | [日本語]: PLS の中間 Plottable Spec (HBM 式統一)。 終端 @VisualSpec@ を +-- 直返ししていた旧 @plsScorePlot@ 系を、 forest/trace 等と同じく +-- __'Plottable' な中間 Spec__ に揃える (@toPlot@ 境界でオプション合成可・診断束を型で表現)。 +-- [English]: The PLS intermediate Plottable Spec (unified with the HBM +-- style). Brings the old @plsScorePlot@ family — which directly returned a +-- terminal @VisualSpec@ — in line with forest\/trace etc. as an +-- __intermediate 'Plottable' Spec__ +-- (options can be composed at the @toPlot@ boundary; the diagnostic bundle +-- is expressed as a type). +data PLSView = PLSView !PLSFit !PLSViewKind + +-- | [日本語]: score ビュー: 標本を潜在空間の第 1/2 成分 (T[:,0] vs T[:,1]) で散布。 +-- [English]: The score view: scatters samples over latent-space +-- components 1\/2 (T[:,0] vs T[:,1]). +scoreView :: PLSFit -> PLSView +scoreView fit = PLSView fit ScoreView + +-- | [日本語]: loading ビュー: 変数を潜在空間の第 1/2 成分 (P[:,0] vs P[:,1]) で散布。 +-- [English]: The loading view: scatters variables over latent-space +-- components 1\/2 (P[:,0] vs P[:,1]). +loadingView :: PLSFit -> PLSView +loadingView fit = PLSView fit LoadingView + +-- | [日本語]: VIP ビュー: 変数重要度 (Variable Importance in Projection) bar。 +-- [English]: The VIP view: a Variable Importance in Projection bar chart. +vipView :: PLSFit -> PLSView +vipView fit = PLSView fit VipView + +instance Plottable PLSView where + toPlot (PLSView fit ScoreView) = + let (xs, ys) = matCols2 (plsScoresT fit) 0 1 + in layer (scatter (inline xs) (inline ys)) + <> xLabel "comp 1" <> yLabel "comp 2" + toPlot (PLSView fit LoadingView) = + let (xs, ys) = matCols2 (plsLoadingsP fit) 0 1 + in layer (scatter (inline xs) (inline ys)) + <> xLabel "loading 1" <> yLabel "loading 2" + toPlot (PLSView fit VipView) = + let vips = LA.toList (plsVIP fit) + labels = [ "f" <> T.pack (show k) | k <- [1 .. length vips] ] + in layer (bar (inlineCat labels) (inline vips)) + +instance Plottable PLSFit where + -- 代表図 = score ビュー (標本の潜在空間布置)。 + toPlot = toPlot . scoreView + -- 診断束 = score / loading / VIP の 3 枚。 + diagnosticPlots fit = map toPlot [ scoreView fit, loadingView fit, vipView fit ] + +-- =========================================================================== +-- 時系列・生存・FDA (GARCH / AFT / FDA) — Phase 68 A5 +-- +-- 新規 plot mark は不要 (既存 line/band の重畳): +-- +-- * 'GARCHFit' = 系列 (μ + ε_t) + 条件付き volatility 帯 (μ ± 2σ_t) の帯付き線。 +-- * 'AFTFit' = パラメトリック生存曲線 S(t|x)。 fit は観測時刻を持たないので +-- 代表図 (@toPlot@) は **基準共変量** (intercept のみ) の曲線、 +-- 任意共変量は 'aftSurvivalAt' ヘルパ。 t 範囲は予測平均寿命から導出。 +-- * 'FunctionalPCA' = 平均関数 + 上位固有関数を grid 上に重畳 (x = grid index)。 +-- * 'FLMResult' = 関数回帰係数 β(t) の曲線。 +-- =========================================================================== + +-- | [日本語]: GARCH の条件付き volatility 帯付き線: 系列 @y_t = μ + ε_t@ の line に、 +-- @μ ± 2σ_t@ (σ_t = √σ²_t) の帯を重ねる。 x = 時刻 index。 +-- [English]: A banded line of GARCH conditional volatility: overlays a +-- band of @μ ± 2σ_t@ (σ_t = √σ²_t) on the line of series +-- @y_t = μ + ε_t@. x = time index. +garchVolatility :: GARCHFit -> VisualSpec +garchVolatility fit = + let eps = LA.toList (gResiduals fit) + s2 = LA.toList (gSigma2 fit) + mu = gMu fit + n = min (length eps) (length s2) + xs = [ fromIntegral i | i <- [1 .. n] ] :: [Double] + ys = [ mu + e | e <- take n eps ] + sig = [ sqrt (max 0 v) | v <- take n s2 ] + lo = zipWith (\_ s -> mu - 2 * s) xs sig + hi = zipWith (\_ s -> mu + 2 * s) xs sig + in layer (band (inline xs) (inline lo) (inline hi) <> alpha 0.25) + <> layer (line (inline xs) (inline ys)) + <> xLabel "t" <> yLabel "y" + +instance Plottable GARCHFit where + toPlot = garchVolatility + +-- | [日本語]: AFT 生存曲線 S(t|x): 共変量 @x@ の線形予測子 @lp = x·β@ から +-- @z(t) = (log t − lp)/σ@・@S = exp(logS dist z)@ を t-grid 上で評価する。 +-- t 範囲は予測平均寿命の @(0.01, 3×mean)@、 grid 120 点。 +-- [English]: The AFT survival curve S(t|x): evaluates +-- @z(t) = (log t − lp)/σ@ \/ @S = exp(logS dist z)@ over a t-grid from +-- covariate @x@'s linear predictor @lp = x·β@. The t range is derived +-- from the predicted mean lifetime as @(0.01, 3×mean)@, with a 120-point +-- grid. +aftSurvivalAt :: AFTFit -> [Double] -> VisualSpec +aftSurvivalAt fit x = + let beta = LA.toList (aftBeta fit) + lp = sum (zipWith (*) x beta) + sigma = aftScale fit + dist = aftDistribution fit + meanL = let v = predictAFT fit (LA.fromLists [x]) in head (LA.toList v) + tMax = if meanL > 0 && not (isInfinite meanL) then 3 * meanL else 10 + tMin = max 1e-3 (tMax / 200) + ts = linspace tMin tMax 120 + surv t = exp (logS dist ((log t - lp) / sigma)) + ss = map surv ts + in layer (line (inline ts) (inline ss)) + <> xLabel "t" <> yLabel "S(t)" + +instance Plottable AFTFit where + -- 代表図 = 基準共変量 (intercept 列のみ = [1,0,…,0]) の生存曲線。 + toPlot fit = + let p = LA.size (aftBeta fit) + xRef = if p <= 0 then [] else 1 : replicate (p - 1) 0 + in aftSurvivalAt fit xRef + + +instance Plottable FunctionalPCA where + -- 平均関数 + 上位 (最大 3) 固有関数を grid 上に重畳。 + toPlot fpca = + let meanFn = LA.toList (fpcaMeanFn fpca) + eigs = LA.toRows (fpcaEigenfn fpca) + eigNs = [ ("PC" <> T.pack (show k), LA.toList e) + | (k, e) <- zip [1 :: Int ..] (take 3 eigs) ] + in gridCurves (("mean", meanFn) : eigNs) + +instance Plottable FLMResult where + -- 関数回帰係数 β(t) の曲線 (x = grid index)。 + toPlot flm = + let betaFn = LA.toList (flmBetaFn flm) + xs = [ fromIntegral i | i <- [1 .. length betaFn] ] :: [Double] + in layer (line (inline xs) (inline betaFn)) + <> xLabel "t" <> yLabel "beta(t)" + +-- =========================================================================== +-- 罰則回帰・因果探索 (Regularized / LiNGAM) — Phase 68 A6 +-- +-- 新規 plot mark は不要: +-- +-- * 'RegFit' = 単一 λ の係数 ('rfBeta') を bar (代表図)。 +-- * 'regPathPlot' = 正則化パス @[(λ, [β_j])]@ ('regularizationPath' 出力) を、 +-- 係数ごとに 1 本の line で λ-横軸に重畳 (= LASSO 係数パス図)。 +-- * @DirectLiNGAMFit@ = 推定した因果構造を **MDAG** で描く (B 行列 → node/edge、 +-- 決定木と同じ MDAG 再利用)。 edge j→i は @|adjacency[i,j]|>0@。 +-- =========================================================================== + +instance Plottable RegFit where + -- 係数 bar (b1, b2, … = rfBeta)。 intercept 含む並びをそのまま描く。 + toPlot fit = + let bs = LA.toList (rfBeta fit) + labels = [ "b" <> T.pack (show k) | k <- [0 .. length bs - 1] ] + in layer (bar (inlineCat labels) (inline bs)) + +-- | [日本語]: 正則化パス図: @[(λ, [β_j])]@ を係数ごとに 1 本の line で重畳。 横軸は __log₁₀λ__ +-- (glmnet の係数パス図と同じ慣例・小 λ=full model が左、 大 λ=sparse が右)。 色=係数 index。 +-- λ は正を仮定する (パスの λ グリッドは常に @> 0@)。 +-- [English]: The regularization-path plot: overlays @[(λ, [β_j])]@ as one +-- line per coefficient. The x axis is __log₁₀λ__ (following glmnet's +-- coefficient-path convention: small λ = full model on the left, large +-- λ = sparse on the right). Color = coefficient index. Assumes λ is +-- positive (the path's λ grid is always @> 0@). +regPathPlot :: [(Double, [Double])] -> VisualSpec +regPathPlot path + | null path = mempty + | otherwise = + let logLams = map (logBase 10 . fst) path -- x = log₁₀λ + rows = map snd path -- λ ごとの [β_j] + p = minimum (map length rows) + mkCoef j = + let ys = [ r !! j | r <- rows ] + lbl = "b" <> T.pack (show j) + in layer ( line (inline logLams) (inline ys) + <> colorBy (inlineCat (replicate (length logLams) lbl)) ) + in mconcat [ mkCoef j | j <- [0 .. p - 1] ] + <> xLabel "log10(lambda)" <> yLabel "coef" + +-- | [日本語]: 隣接行列 + 変数名から因果 DAG (MDAG) を描く低レベル関数。 +-- edge @j→i@ は @|adj[i,j]| > 0@ (= x_i が x_j に依存)。 @names@ が列数と一致しなければ +-- @x0..@ フォールバック。 全 LiNGAM variant の Plottable が共有する。 +-- [English]: The low-level function that draws a causal DAG (MDAG) from +-- an adjacency matrix and variable names. Edge @j→i@ means +-- @|adj[i,j]| > 0@ (i.e. x_i depends on x_j). Falls back to @x0..@ if +-- @names@ doesn't match the column count. Shared by every LiNGAM +-- variant's Plottable instance. +lingamDagNamed :: [Text] -> LA.Matrix Double -> VisualSpec +lingamDagNamed rawNames adj = + let p = LA.rows adj + names = if length rawNames == p && p > 0 + then rawNames + else [ "x" <> T.pack (show j) | j <- [0 .. p - 1] ] + dnodes = [ DAGNode { dnId = nm, dnLabel = nm, dnKind = NodeObserved + , dnDist = Nothing, dnX = 0, dnY = 0 } | nm <- names ] + dedges = [ DAGEdge (names !! j) (names !! i) Nothing Nothing + | i <- [0 .. p - 1], j <- [0 .. p - 1] + , abs (adj `LA.atIndex` (i, j)) > 0 ] + (positioned, routed) = layoutHierarchicalFullWithPlates dnodes dedges [] + in bakeDAGRoutesInSpec $ + layer (dagFromListsWithPlates positioned routed LayoutHierarchical []) + +-- | [日本語]: 推定因果構造 (DirectLiNGAM) を MDAG で描く。 ノード = @x0..x_{p-1}@ (変数名は +-- 高レベル @df |-> directLingam@ 経由で付く・'LiNGAMFitted' の Plottable 参照)。 +-- [English]: Draws the estimated causal structure (DirectLiNGAM) as an +-- MDAG. Nodes are @x0..x_{p-1}@ (variable names come from the high-level +-- @df |-> directLingam@; see 'LiNGAMFitted'\'s Plottable instance). +lingamDag :: DirectLiNGAMFit -> VisualSpec +lingamDag fit = lingamDagNamed [] (dlAdjacency fit) + +instance Plottable DirectLiNGAMFit where + toPlot = lingamDag + +-- | [日本語]: 高レベル @df |-> directLingam cols@ の結果 = __実変数名__ の因果 DAG。 +-- [English]: The result of the high-level @df |-> directLingam cols@ = +-- the causal DAG with __actual variable names__. +instance Plottable (LiNGAMFitted DirectLiNGAMFit) where + toPlot (LiNGAMFitted fit names) = lingamDagNamed names (dlAdjacency fit) + +-- | [日本語]: ParceLiNGAM の名前付き DAG (pcAdjacency)。 +-- [English]: ParceLiNGAM's named DAG (pcAdjacency). +instance Plottable (LiNGAMFitted ParceFit) where + toPlot (LiNGAMFitted fit names) = lingamDagNamed names (pcAdjacency fit) + +-- | [日本語]: MultiGroupLiNGAM の __共通__ DAG (多数決 mgCommonAdj・名前付き)。 +-- [English]: MultiGroupLiNGAM's __common__ DAG (majority-vote +-- mgCommonAdj, named). +instance Plottable (LiNGAMFitted MultiGroupFit) where + toPlot (LiNGAMFitted fit names) = lingamDagNamed names (mgCommonAdj fit) + +-- | [日本語]: VARLiNGAM の __時間ラグ DAG__。 ノード = 各変数の @name[t]@ / @name[t-l]@、 +-- 辺 = 同時刻 (@B0@: x_j[t]→x_i[t]) + ラグ (@structuralLags[l]@: x_j[t-l]→x_i[t])。 +-- @thr@ 未満の係数は辺を出さない。 孤立したラグノード (辺に現れない) は省く。 +-- [English]: VARLiNGAM's __time-lag DAG__. Nodes are each variable's +-- @name[t]@ \/ @name[t-l]@; edges are contemporaneous (@B0@: +-- x_j[t]→x_i[t]) plus lagged (@structuralLags[l]@: x_j[t-l]→x_i[t]). +-- Coefficients below @thr@ yield no edge. Isolated lag nodes (not +-- appearing in any edge) are omitted. +varLagDagNamed :: [Text] -> LA.Matrix Double -> [LA.Matrix Double] -> Double -> VisualSpec +varLagDagNamed rawNames b0 lags thr = + let k = LA.rows b0 + base = if length rawNames == k && k > 0 + then rawNames else [ "x" <> T.pack (show j) | j <- [0 .. k - 1] ] + p = length lags + nm i 0 = base !! i <> "[t]" + nm i l = base !! i <> "[t-" <> T.pack (show l) <> "]" + contempEdges = [ DAGEdge (nm j 0) (nm i 0) Nothing Nothing + | i <- [0 .. k - 1], j <- [0 .. k - 1] + , abs (b0 `LA.atIndex` (i, j)) > thr ] + lagEdges = [ DAGEdge (nm j l) (nm i 0) Nothing Nothing + | l <- [1 .. p], i <- [0 .. k - 1], j <- [0 .. k - 1] + , abs ((lags !! (l - 1)) `LA.atIndex` (i, j)) > thr ] + dedges = contempEdges ++ lagEdges + refIds = concatMap (\(DAGEdge a b _ _) -> [a, b]) dedges + allNodes = [ (i, l) | l <- [0 .. p], i <- [0 .. k - 1] ] + keep (i, l) = l == 0 || nm i l `elem` refIds -- 現時刻は常に・ラグは辺があるものだけ + dnodes = [ DAGNode { dnId = nm i l, dnLabel = nm i l, dnKind = NodeObserved + , dnDist = Nothing, dnX = 0, dnY = 0 } + | (i, l) <- allNodes, keep (i, l) ] + (positioned, routed) = layoutHierarchicalFullWithPlates dnodes dedges [] + in bakeDAGRoutesInSpec $ + layer (dagFromListsWithPlates positioned routed LayoutHierarchical []) + +-- | [日本語]: VARLiNGAM の高レベル結果 = 時間ラグ DAG (辺閾値 0.1・同時刻 + ラグ)。 +-- [English]: VARLiNGAM's high-level result = the time-lag DAG (edge +-- threshold 0.1; contemporaneous + lagged). +instance Plottable (LiNGAMFitted VARLiNGAMFit) where + toPlot (LiNGAMFitted fit names) = + varLagDagNamed names (vlB0 fit) (vlStructuralLags fit) 0.1 + +-- | [日本語]: PairwiseLiNGAM の 2 変数向き図。 検出向きの矢印 1 本 (Inconclusive は無向)。 +-- 2×2 隣接に落として 'lingamDagNamed' を再利用する。 +-- [English]: PairwiseLiNGAM's two-variable direction diagram. A single +-- arrow in the detected direction (undirected for Inconclusive). Reduced +-- to a 2×2 adjacency and reuses 'lingamDagNamed'. +instance Plottable (LiNGAMFitted PairwiseResult) where + toPlot (LiNGAMFitted r names) = + let adj = case prDirection r of + XtoY -> LA.fromLists [[0, 0], [1, 0]] -- x(0) → y(1): adj[1,0]=1 + YtoX -> LA.fromLists [[0, 1], [0, 0]] -- y(1) → x(0) + Inconclusive -> LA.fromLists [[0, 0], [0, 0]] -- 無向 (2 ノードのみ) + in lingamDagNamed names adj + +-- | [日本語]: ICA-LiNGAM の名前付き DAG (ilAdjacency)。 +-- [English]: ICA-LiNGAM's named DAG (ilAdjacency). +instance Plottable (LiNGAMFitted ICALiNGAMFit) where + toPlot (LiNGAMFitted fit names) = lingamDagNamed names (ilAdjacency fit) + +-- | [日本語]: 相関ネットワークのグラフ。 @|r| > cgThreshold@ の対を辺にする (無向・向きは +-- index 順の便宜配置で __因果でない__ )。 LiNGAM DAG と対比すると間接相関の過剰さが分かる。 +-- 下三角のみ辺にして重複/自己ループを避ける (相関は対称ゆえ)。 +-- [English]: The correlation-network graph. Pairs with @|r| > cgThreshold@ +-- become edges (undirected; the index-order layout is a convenience and +-- __is not causal__). Contrasting this with the LiNGAM DAG reveals the +-- excess of indirect correlations. Only the lower triangle is edged, to +-- avoid duplicates \/ self-loops (correlation is symmetric). +instance Plottable CorrelationGraph where + toPlot (CorrelationGraph corr names thr) = + let p = LA.rows corr + adj = LA.build (p, p) + (\i j -> let (ii, jj) = (round i, round j) + in if ii > jj && abs (corr `LA.atIndex` (ii, jj)) > thr + then 1 else 0 :: Double) + in lingamDagNamed names adj + +-- | [日本語]: BootstrapLiNGAM の __確信度 DAG__。 出現確率 ≥ 0.5 のエッジだけ描く +-- (= 過半数の bootstrap で現れた信頼できる因果構造)。 全確率は 'bootstrapEdgeProbOf' で。 +-- [English]: BootstrapLiNGAM's __confidence DAG__. Draws only edges with +-- occurrence probability ≥ 0.5 (i.e. causal structure trusted enough to +-- appear in a majority of bootstrap resamples). See 'bootstrapEdgeProbOf' +-- for the full probabilities. +instance Plottable (LiNGAMFitted BootstrapResult) where + toPlot (LiNGAMFitted res names) = + let prob = brEdgeProbability res + p = LA.rows prob + adj = LA.build (p, p) + (\i j -> if prob `LA.atIndex` (round i, round j) >= 0.5 then 1 else 0) + in lingamDagNamed names adj + +-- | [日本語]: BootstrapLiNGAM の __エッジ出現確率ヒートマップ__。 行=結果 i・列=原因 j、 +-- セル = P(j→i) (0..1)。 確信度の全体像を DAG と別に見せる (python lingam の確率行列相当)。 +-- [English]: BootstrapLiNGAM's __edge-occurrence-probability heatmap__. +-- Rows = effect i, columns = cause j; cells = P(j→i) (0..1). Shows the +-- full picture of confidence separately from the DAG (equivalent to +-- python lingam's probability matrix). +bootstrapEdgeProbOf :: LiNGAMFitted BootstrapResult -> VisualSpec +bootstrapEdgeProbOf (LiNGAMFitted res rawNames) = + let prob = brEdgeProbability res + p = LA.rows prob + names = if length rawNames == p && p > 0 + then rawNames else [ "x" <> T.pack (show j) | j <- [0 .. p - 1] ] + cells = [ (names !! j, names !! i, prob `LA.atIndex` (i, j)) + | i <- [0 .. p - 1], j <- [0 .. p - 1] ] + xs = [ c | (c, _, _) <- cells ] -- 原因 j (x 軸) + ys = [ r | (_, r, _) <- cells ] -- 結果 i (y 軸) + vs = [ v | (_, _, v) <- cells ] + in layer (heatmap (inlineCat xs) (inlineCat ys) (inline vs)) + <> xLabel "cause (j)" <> yLabel "effect (i)" + +-- =========================================================================== +-- DOE prediction profiler — Phase 78.C/D/F +-- +-- JMP の Prediction Profiler 相当 = **応答 × 各因子**のパネルをグリッドに並べる +-- (行=応答・列=因子)。 各パネル = 予測線 + 95% CI 帯 (他因子は中央値固定) + 打点。 +-- 打点は 'Raw' (実測 y) か 'Partial' (偏残差 = 部分効果 + 全モデル残差) を @<>@ で選ぶ。 +-- 既存 effect plot ('statModelMulti' + 'along' + 'holdAt') を再利用する。 +-- +-- 中間 Plottable 型 ('ProfilerSpec') にして @toPlot@ で描画・@<>@ でオプション合成 +-- (HBM @epred@ / 'PDPView' と同じ流儀)。 打点はモデル ('mvFrame') の観測値から算出 +-- するので @noDf@ で束ねられる。 複数応答は @df |-> @multiOutput@ ys (designModel plan)@ +-- が返す @[(応答名, モデル)]@ をそのまま渡す。 +-- +-- > let model = df |-> multiOutput ["strength","yield"] (designModel plan) +-- > noDf |>> toPlot (profiler model ["temp","time"] <> profilerResidual Partial) +-- =========================================================================== + +-- | [日本語]: 打点の種別。 'Raw' = 実測 y (他因子が動くぶん予測線から縦に散る = 多変量の正しい挙動)。 +-- 'Partial' = __偏残差__ @fⱼ(xⱼ) + (全モデル残差)@ で他因子の寄与を除き点を予測線に乗せる +-- (R @termplot(partial.resid=TRUE)@ / @car::crPlots@ 相当)。 +-- [English]: The kind of plotted points. 'Raw' = observed y (scatters +-- vertically off the prediction line as other factors vary — the correct +-- multivariate behavior). 'Partial' = removes other factors' +-- contributions via the __partial residual__ +-- @fⱼ(xⱼ) + (whole-model residual)@, placing points on the prediction +-- line (equivalent to R's @termplot(partial.resid=TRUE)@ \/ +-- @car::crPlots@). +data ResidualMode = Raw | Partial + deriving (Eq, Show) + +-- | [日本語]: prediction profiler の中間 Plottable Spec。 @(応答名, モデル)@ のリスト +-- (複数応答)・因子名・打点モード ('ResidualMode') を捕捉し、 @toPlot@ で「行=応答 × +-- 列=因子」 のグリッドに描く。 'profiler' で作り、 @<> 'profilerResidual' Partial@ で +-- モードを合成する。 +-- [English]: The prediction profiler's intermediate Plottable Spec. +-- Captures a list of @(response name, model)@ (multiple responses), +-- factor names, and the plotted-point mode ('ResidualMode'), and draws a +-- "rows = responses × columns = factors" grid via @toPlot@. Built with +-- 'profiler'; compose the mode with @<> 'profilerResidual' Partial@. +data ProfilerSpec m = ProfilerSpec + { psModels :: [(Text, m)] -- ^ [日本語]: (応答ラベル, 学習済モデル)。 行になる。 [English]: @(response label, trained model)@; becomes a row. + , psFactors :: [Text] -- ^ [日本語]: 説明因子名。 列になる。 [English]: Explanatory factor names; becomes a column. + , psResidual :: Maybe ResidualMode -- ^ [日本語]: 打点モード (合成後 'Nothing' は 'Raw' 既定)。 [English]: The plotted-point mode (@Nothing@ after composition defaults to 'Raw'). + } + +-- | [日本語]: 右バイアス合成 (option-only 片は models\/factors が空)。 mode は後勝ち。 +-- [English]: Right-biased composition (an option-only side has empty +-- models\/factors). @mode@ follows last-write-wins. +instance Semigroup (ProfilerSpec m) where + a <> b = ProfilerSpec + { psModels = psModels a <> psModels b + , psFactors = if null (psFactors b) then psFactors a else psFactors b + , psResidual = psResidual b <|> psResidual a } + +instance Monoid (ProfilerSpec m) where + mempty = ProfilerSpec [] [] Nothing + +-- | [日本語]: @profiler models factors@ — 応答×因子の profiler。 @models@ は +-- @df |-> @multiOutput@ ys (designModel plan)@ が返す @[(応答名, モデル)]@。 既定は 'Raw'。 +-- [English]: @profiler models factors@ — a response × factor profiler. +-- @models@ is the @[(response name, model)]@ returned by +-- @df |-> @multiOutput@ ys (designModel plan)@. Defaults to 'Raw'. +profiler :: [(Text, m)] -> [Text] -> ProfilerSpec m +profiler models factors = ProfilerSpec models factors Nothing + +-- | [日本語]: 打点モードを差す option (@<>@ で合成)。 @profiler … <> profilerResidual Partial@。 +-- [English]: An option that sets the plotted-point mode (composed via +-- @<>@). @profiler … <> profilerResidual Partial@. +profilerResidual :: ResidualMode -> ProfilerSpec m +profilerResidual mode = mempty { psResidual = Just mode } + +instance MultiVarModel m => Plottable (ProfilerSpec m) where + toPlot (ProfilerSpec models factors mMode) + | null models || null factors = mempty + | otherwise = + subplots [ panel lbl m f | (lbl, m) <- models, f <- factors ] + <> subplotCols (length factors) + where + mode = fromMaybe Raw mMode + -- 1 パネル = 予測線 + CI + 打点 (Raw: 実測 y / Partial: 偏残差)。他因子は中央値固定。 + panel lbl m f = + let mf = mvFrame m + contOf nm = case lookup nm (mfRoles mf) of + Just (RoleContinuous xs) -> V.toList xs + _ -> [] + xsf = contOf f + (pts, ylab) = case mode of + Raw -> + let ysObs = case [ v | (_, RoleResponse v) <- mfRoles mf ] of + (v : _) -> V.toList v + [] -> [] + in (ysObs, lbl) + Partial -> + let ysObs = case [ v | (_, RoleResponse v) <- mfRoles mf ] of + (v : _) -> V.toList v + [] -> [] + (muFull, _) = mvEvalFrame m 0.95 mf + resid = zipWith (-) ysObs muFull + -- 部分効果 fⱼ(xⱼ): f=観測値・他因子=中央値固定 (予測線と同じ hold)。 + ef = evalFrame mf f Median [] xsf + (muPart, _) = mvEvalFrame m 0.95 ef + in (zipWith (+) muPart resid, "partial: " <> lbl) + in layer (scatter (inline xsf) (inline pts)) + <> toPlot (statModelMulti m (along f) <> holdAt Median <> grid 60) + <> xLabel f <> yLabel ylab + +-- | [日本語]: RSM __等高線 / 応答曲面__。 2 因子 (v1, v2) を grid で動かし他因子を +-- 中央値固定して応答 μ̂ を評価し、 __塗り等値帯 ('contourFilled') + 等高線 ('contour')__ で +-- 描く (R @rsm::contour@ / matplotlib @contourf+contour@ 相当・応答面を平面で俯瞰)。 +-- 3D の応答曲面は 'surfaceOf' (別途 @saveSVG3D@)。 評価はモデル観測範囲なので +-- @noDf |>> contourOf model "temp" "time"@ で描ける。 +-- [English]: The RSM __contour \/ response-surface plot__. Sweeps two +-- factors (v1, v2) on a grid, holds other factors at their median, and +-- evaluates the response μ̂, drawing it as a +-- __filled contour band ('contourFilled') + contour lines ('contour')__ +-- (equivalent to R's @rsm::contour@ \/ matplotlib's @contourf+contour@; a +-- flat-plane overview of the response surface). The 3D response surface +-- is 'surfaceOf' (separate @saveSVG3D@). Since evaluation uses the +-- model's observed range, it can be drawn simply as +-- @noDf |>> contourOf model "temp" "time"@. +contourOf :: MultiVarModel m => m -> Text -> Text -> VisualSpec +contourOf m v1 v2 = + let (gxs, gys, grid') = surfaceGrid m v1 v2 (defaultSurfaceOpts { soHoldAt = Median }) + -- grid' !! j !! i = μ̂(gxs!!i, gys!!j)。 (x, y, z) へ平坦化。 + pts = concat (zipWith (\gy row -> zipWith (\gx z -> (gx, gy, z)) gxs row) gys grid') + xs = [ x | (x, _, _) <- pts ] + ys = [ y | (_, y, _) <- pts ] + zs = [ z | (_, _, z) <- pts ] + in layer (contourFilled (inline xs) (inline ys) (inline zs)) + <> layer (contour (inline xs) (inline ys) (inline zs) <> contourLevels 10) + <> xLabel v1 <> yLabel v2 + +-- =========================================================================== +-- 記述統計・検定 (Stat.*) — Phase 68 A7 +-- +-- 新規 plot mark は不要: +-- +-- * 'TestResult' = 効果量 + 95% CI の **forest** (検定パラメータの区間 + 0 基準線)。 +-- 代表図 (@toPlot@) は 1 行 forest、 複数検定は 'testForest'。 +-- * 'describeBox' = 生データ列の **box plot** (= describe の分布図・5 数要約を可視化)。 +-- =========================================================================== + +-- | [日本語]: 検定結果の forest plot: 各検定の 95% CI ('trCI') を区間、 中心を点推定として +-- 1 行に並べ、 0 の基準線を引く。 CI を持たない検定は除外する。 行ラベルは +-- 'trMethod'。 同種検定を群間で並べるなど +-- __ラベルを区別したい場合は 'testForestLabeled'__ を使う。 +-- +-- ⚠ 0 基準線は __平均差・効果量__ (null = 0) 向け。 生の平均など null ≠ 0 の量を +-- 混在させると軸ドメインが歪むので、 同一スケールの量だけを 1 枚に並べること。 +-- +-- [English]: A forest plot of test results: lays out each test's 95% CI +-- ('trCI') as an interval, with the point estimate as the center, one per +-- row, and draws a reference line at 0. Tests without a CI are excluded. +-- Row labels come from 'trMethod'. When you need to __distinguish labels__ +-- — e.g. laying out the same test kind across groups — use +-- __'testForestLabeled'__. +-- +-- ⚠ The 0 reference line targets __mean differences \/ effect sizes__ +-- (null = 0). Mixing in quantities whose null ≠ 0, such as raw means, would +-- distort the axis domain, so only lay out quantities on the same scale in +-- one plot. +testForest :: [TestResult] -> VisualSpec +testForest = testForestLabeled . map (\r -> (trMethod r, r)) + +-- | [日本語]: ラベル指定版 'testForest' (= 行ラベルを呼び出し側で与える)。 同じ検定種を +-- 群ごとに並べる (= 同名衝突を避ける) 用途に使う。 +-- [English]: A label-specified variant of 'testForest' (the caller +-- supplies the row labels). Used for cases like laying out the same test +-- kind across groups (avoiding name collisions). +testForestLabeled :: [(Text, TestResult)] -> VisualSpec +testForestLabeled labeled = + let rows = [ (nm, lo, hi) | (nm, r) <- labeled, Just (lo, hi) <- [trCI r] ] + names = [ nm | (nm, _, _ ) <- rows ] + ests = [ (lo + hi) / 2 | (_, lo, hi) <- rows ] + errs = [ (hi - lo) / 2 | (_, lo, hi) <- rows ] + in if null rows + then mempty + else layer (forest (inlineCat names) (inline ests) (inline errs) <> forestNull 0) + +instance Plottable TestResult where + -- 代表図 = 単一検定の 1 行 forest (effect/CI)。 + toPlot r = testForest [r] + +-- | [日本語]: describe の分布図: 生データ列の box plot (5 数要約を可視化)。 +-- [English]: The describe distribution plot: a box plot of a raw data +-- column (visualizes the five-number summary). +describeBox :: [Double] -> VisualSpec +describeBox xs = layer (boxplot (inline xs)) + +-- =========================================================================== +-- 次元圧縮 (PLS effect plot) — Phase 70.B2/B3 +-- =========================================================================== + +instance MultiVarModel PLSModel where + mvFrame = plsmFrame + -- PLS は閉形式 CI を持たない → band 非提供 (曲線のみ・GAM と同じ honest 方針)。 + mvEvalFrame m _level ef = + let n = mfNRows ef + colOf nm = case lookup nm (mfRoles ef) of + Just (RoleContinuous v) -> LA.fromList (V.toList v) + _ -> LA.fromList (replicate n 0) + xMat = LA.fromColumns (map colOf (plsmXNames m)) -- n × p (xNames 順) + yPred = predictPLS (plsmFit m) xMat -- n × q + ycols = LA.toColumns yPred + idx = plsmOutIdx m + mu = if idx < length ycols then LA.toList (ycols !! idx) + else replicate n 0 + in (mu, Nothing) + +-- Phase 78.G-e: 多変量カーネル回帰 (GP/RFF) を effect plot / profiler / contour で使う +-- (DOE の非 LM 化)。 mvEvalFrame は ef から予測子を 'gprnNames' 順に取り 'gprnPredict' +-- に渡す ('PLSModel' と同型)。 帯 = **事後予測帯** (潜在分散 + 観測 noise σ_n²) で、 +-- 分布あり象限 (Gp/GpRff) のみ Just、 mean のみ象限 (Krr/KrrRff) は帯なし。 'gpmvVar' は +-- σ_n² を含まない ('GP.hs' の diagKss=σ_f²) ので noise を足して予測帯にする。 +instance MultiVarModel GPRegModelN where + mvFrame m = + let n = LA.size (gprnYraw m) + roles = ("__gp_resp", RoleResponse (V.fromList (LA.toList (gprnYraw m)))) + : [ (nm, RoleContinuous (V.fromList (LA.toList xv))) + | (nm, xv) <- zip (gprnNames m) (gprnXraws m) ] + in ModelFrame { mfRoles = roles, mfNRows = n } + mvEvalFrame m level ef = + let n = mfNRows ef + colOf nm = case lookup nm (mfRoles ef) of + Just (RoleContinuous v) -> V.toList v + _ -> replicate n 0 + xMat = LA.fromColumns (map (LA.fromList . colOf) (gprnNames m)) -- n × p + (mu, mbVar) = gprnPredict m xMat + z = quantileNormal (1 - (1 - level) / 2) + sn2 = max 0 (gpNoiseVar (gprnParams m)) + in case mbVar of + Just vs -> let sds = map (\v -> sqrt (max 0 v + sn2)) vs + in ( mu, Just ( zipWith (\u s -> u - z * s) mu sds + , zipWith (\u s -> u + z * s) mu sds ) ) + Nothing -> (mu, Nothing) + +-- | [日本語]: DOE 階層ベイズ fit の effect plot 対応。固定効果 β の事後 draw で +-- 評価点の μ を計算し、事後予測帯 (μ の分散 + 観測 noise σ²) を CI slot に載せる。 +-- ランダム効果は集団平均で marginalize (profiler = 代表条件の予測)。 +-- [English]: Effect-plot support for the DOE hierarchical Bayesian fit. +-- Computes μ at evaluation points from the fixed effect β's posterior +-- draws, and loads the posterior predictive band (variance of μ + +-- observation noise σ²) into the CI slot. Random effects are marginalized +-- over the population average (the profiler predicts a representative +-- condition). +instance MultiVarModel DesignHBMFit where + mvFrame = dhfFrame + mvEvalFrame m level ef = + case designMatrixF (dhfFormula m) ef of + Left _ -> ([], Nothing) + Right (xMat, _) -> + let rows = map LA.toList (LA.toRows xMat) -- 評価点 × p + draws = dhfBetaDraws m -- draws × p + muAt row = [ sum (zipWith (*) row bd) | bd <- draws ] + perPoint = map muAt rows -- 評価点ごとの draw 列 + z = quantileNormal (1 - (1 - level) / 2) + s2bar = let ss = dhfSigmaDraws m + in if null ss then 0 else sum (map (^ (2::Int)) ss) / fromIntegral (length ss) + center = map mean0L perPoint + sds = map (\ds -> sqrt (varL ds + s2bar)) perPoint + in ( center + , Just ( zipWith (\c s -> c - z * s) center sds + , zipWith (\c s -> c + z * s) center sds ) ) + where + mean0L xs = if null xs then 0 else sum xs / fromIntegral (length xs) + varL xs = let mu = mean0L xs + in if null xs then 0 else sum (map (\x -> (x - mu) ^ (2::Int)) xs) / fromIntegral (length xs) + diff --git a/src/Hanalyze/Plot/Robust.hs b/src/Hanalyze/Plot/Robust.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Plot/Robust.hs @@ -0,0 +1,233 @@ +-- | +-- Module : Hanalyze.Plot.Robust +-- Description : hgg 連携層 — ロバスト・分位点回帰族の図化 instance +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: hgg 連携層 — __ロバスト・分位点回帰族__ の図化 instance。 +-- +-- ⚠ 親 'Hanalyze.Plot' と同じく別パッケージ @hanalyze-plot@ に属し、 +-- @cabal build --project-file=cabal.project.plot@ で build される。 共通基盤 (class / ModelSpec / grid 評価核) は +-- 'Hanalyze.Plot.Core' を import して取り込む (orphan instance を許容)。 +-- +-- 担当する型 (= M 推定ロバスト回帰・分位点回帰): +-- RobustModel / MultiRobustModel / QuantileModel / MultiQuantileModel。 +-- +-- [English]: hgg integration layer — plotting instances for the +-- __robust and quantile regression family__. +-- +-- ⚠ Lives in the same separate package @hanalyze-plot@ as the parent +-- 'Hanalyze.Plot', built via @cabal build --project-file=cabal.project.plot@. +-- It imports the common +-- foundation (class \/ ModelSpec \/ grid evaluation core) from +-- 'Hanalyze.Plot.Core' (permitting orphan instances). +-- +-- Types covered (M-estimator robust regression and quantile regression): +-- RobustModel \/ MultiRobustModel \/ QuantileModel \/ MultiQuantileModel. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Hanalyze.Plot.Robust + ( robustBand + ) where + +import Data.List (sortBy, minimumBy) +import Data.Ord (comparing) +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA + +import Graphics.Hgg.Spec ( layer, inline, fromHex + , scatter, line, band + , sizeBy, color ) + +import Hanalyze.Model.Wrappers +import Hanalyze.Plot.Core +import Hanalyze.Model.LM (designMatrix) +import Hanalyze.Model.Robust (RobustFit (..), robustCovBeta) +import Hanalyze.Model.Weibull (quantileNormal) +import Hanalyze.Model.Quantile (QRFit (..)) +import Hanalyze.Model.Formula.Design (designMatrixF) + +-- =========================================================================== +-- 多変量ロバスト回帰 (effect plot + 係数サマリ) — Phase 70.D +-- +-- ロバスト回帰は formula 経路を持たない (単回帰 'RobustModel' のみだった) ので、 +-- 'MultiLMModel' と同型の frame-carrying ラッパを新設する。 設計行列は +-- 'additiveFormula' 由来 ('designMatrixF' で @[1, x1,…,xp]@)、 fit は 'fitRobustLM'、 +-- CI 帯は M 推定量サンドイッチ共分散 ('robustCovBeta'・statsmodels RLM 一致)。 +-- =========================================================================== + +instance MultiVarModel MultiRobustModel where + mvFrame = mrmFrame + mvEvalFrame m level ef = + case designMatrixF (mrmFormula m) ef of + Left _ -> ([], Nothing) + Right (xe, _) -> + let fit = mrmFit m + beta = rfCoef fit + cov = robustCovBeta (rfEstimator fit) (rfScale fit) + (rfResiduals fit) (mrmDesign m) + z = quantileNormal ((1 + level) / 2) + rows = LA.toRows xe + mu = [ r `LA.dot` beta | r <- rows ] + se = [ sqrt (max 0 (r `LA.dot` (cov LA.#> r))) | r <- rows ] + in ( mu, Just ( zipWith (\mu' s -> mu' - z * s) mu se + , zipWith (\mu' s -> mu' + z * s) mu se ) ) + +-- =========================================================================== +-- ロバスト回帰 (描画可能) +-- +-- 'RobustFit' (Hanalyze.Model.Robust) は M-estimator IRLS の係数 'rfCoef' / fitted +-- 'rfFitted' / 最終重み 'rfWeights' (≤ 1、 外れ値ほど小) を持つ。 代表図 (@toPlot@) は +-- ロバスト直線 + サンドイッチ CI 帯。 「どの点がダウンウェイトされたか」 は +-- 'diagnosticPlots' 側で **点サイズ = IRLS 重み** の散布図に encode して見せる。 +-- =========================================================================== + +instance Plottable RobustModel where + -- ロバスト直線 + CI 帯 ('robustBand' = M 推定量サンドイッチ共分散)。 LM と揃え、 + -- 訓練点の ŷ='rfFitted' を x 昇順に結ぶ (= 単回帰なので直線) + 帯を重ねる。 + toPlot m = + let fit = rmFit m + xs = LA.toList (rmXraw m) + yhat = LA.toList (rfFitted fit) + sorted = sortBy (comparing fst) (zip xs yhat) + xsS = map fst sorted + yhatS = map snd sorted + (los, his) = robustBand m defaultCILevel xsS + in layer (band (inline xsS) (inline los) (inline his)) + <> layer (line (inline xsS) (inline yhatS)) + + -- 診断束: ロバスト直線 + 残差 vs fitted + **重み encode 散布図** (点サイズ = IRLS + -- 重み、 小さい点 = ダウンウェイトされた外れ値)。 y は ŷ + 残差で復元。 + diagnosticPlots m = + let fit = rmFit m + xs = LA.toList (rmXraw m) + yhat = LA.toList (rfFitted fit) + resd = LA.toList (rfResiduals fit) + ys = zipWith (+) yhat resd + ws = LA.toList (rfWeights fit) + in [ toPlot m + , layer (scatter (inline yhat) (inline resd)) + , layer (scatter (inline xs) (inline ys) <> sizeBy (inline ws)) + ] + +-- | [日本語]: ロバスト回帰の CI 帯。 M 推定量 β̂ の漸近共分散 ('robustCovBeta'・サンドイッチ・ +-- statsmodels RLM 一致) から、 評価点 x での @se(ŷ) = √([1,x]·Cov·[1,x]ᵀ)@、 +-- 帯 = @μ̂ ∓ z·se@ (z = 正規分位点・RLM は正規で Wald CI)。 +-- [English]: The robust regression CI band. From the M-estimator β̂'s +-- asymptotic covariance ('robustCovBeta'; sandwich estimator, matching +-- statsmodels RLM), compute @se(ŷ) = √([1,x]·Cov·[1,x]ᵀ)@ at evaluation +-- point x; the band is @μ̂ ∓ z·se@ (z = the normal quantile; RLM uses the +-- normal distribution for its Wald CI). +robustBand :: RobustModel -> Double -> [Double] -> ([Double], [Double]) +robustBand m level gxs = + let fit = rmFit m + xd = designMatrix (V.fromList (LA.toList (rmXraw m))) -- [1, x] + cov = robustCovBeta (rfEstimator fit) (rfScale fit) (rfResiduals fit) xd + z = quantileNormal ((1 + level) / 2) + beta = rfCoef fit + b0 = LA.atIndex beta 0 + b1 = if LA.size beta > 1 then LA.atIndex beta 1 else 0 + muAt gx = b0 + b1 * gx + seAt gx = let v = LA.fromList [1, gx] + in sqrt (max 0 (v `LA.dot` (cov LA.#> v))) + in ( [ muAt gx - z * seAt gx | gx <- gxs ] + , [ muAt gx + z * seAt gx | gx <- gxs ] ) + +-- | [日本語]: grid 評価。 grid x で β̂·[1, x] を評価しロバスト直線を滑らかに描く。 +-- band は 'robustBand' (サンドイッチ CI) を返す (LM と揃えた)。 +-- [English]: Grid evaluation. Evaluates β̂·[1, x] at grid x to draw a +-- smooth robust regression line. The band comes from 'robustBand' +-- (sandwich CI), consistent with LM. +instance SingleVarModel RobustModel where + svRange m = let xs = LA.toList (rmXraw m) in (minimum xs, maximum xs) + svGrid m level gxs = + let beta = rfCoef (rmFit m) + mu = [ LA.atIndex beta 0 + + (if LA.size beta > 1 then LA.atIndex beta 1 * gx else 0) + | gx <- gxs ] + (los, his) = robustBand m level gxs + in (mu, Just (los, his)) + -- ブートストラップ: 加法誤差 (残差再標本化)。 refit は同じ estimator で再 fit。 + svBootKit m = + let fit = rmFit m + in Just BootKit + { bkX = LA.toList (rmXraw m) + , bkY = zipWith (+) (LA.toList (rfFitted fit)) (LA.toList (rfResiduals fit)) + , bkRefit = \xs ys -> robustModel (rfEstimator fit) (LA.fromList xs) (LA.fromList ys) + , bkObsDist = Nothing } + +-- =========================================================================== +-- 分位点回帰 (描画可能) +-- +-- 'QRFit' (Hanalyze.Model.Quantile) は 1 つの分位 τ に対する係数 + fitted 'qfYHat' を +-- 持つ。 複数の τ (例 0.1/0.5/0.9) の fit を重ねると **予測区間そのものを線群で** 表現 +-- できる (= heteroscedastic データで帯より直接的)。 各線は 'color' ('fromHex') で固定色。 +-- =========================================================================== + +instance Plottable QuantileModel where + -- 各 τ-fit を x 昇順に結んだ折れ線を、 固定色で重畳 (分位ごとに 1 layer)。 + toPlot m = + let xs = LA.toList (qmXraw m) + mkLine (i, (_tau, fit)) = + let yhat = LA.toList (qfYHat fit) + sorted = sortBy (comparing fst) (zip xs yhat) + col = quantilePalette !! (i `mod` length quantilePalette) + in layer (line (inline (map fst sorted)) (inline (map snd sorted)) + <> color (fromHex col)) + in foldMap mkLine (zip [0 ..] (qmFits m)) + +-- | [日本語]: 多変量分位点回帰の代表図 = __第 1 予測子に沿った effect plot__ (他予測子は +-- 訓練平均に固定)。 各 τ を 1 本の線で色分け重畳する (単変量 'QuantileModel' の τ 別 +-- 線群の一般化)。 分位点回帰は閉形式 CI を持たないため帯はなし。 +-- [English]: The representative plot for multivariate quantile regression +-- = __an effect plot along the first predictor__ (other predictors held +-- fixed at their training mean). Each τ is overlaid as a separate +-- color-coded line (a generalization of the single-variable +-- 'QuantileModel''s per-τ line group). Quantile regression has no +-- closed-form CI, so there is no band. +instance Plottable MultiQuantileModel where + toPlot m = + case LA.toColumns (mqmX m) of -- [1, x₁, …, xₚ] + (_ : x1 : rest) -> + let xs1 = LA.toList x1 + means = [ LA.sumElements c / fromIntegral (max 1 (LA.size c)) | c <- rest ] -- x₂..xₚ の平均 + (lo, hi) = (minimum xs1, maximum xs1) + gn = 100 :: Int + grid' = [ lo + (hi - lo) * fromIntegral i / fromIntegral (gn - 1) | i <- [0 .. gn - 1] ] + evalX = LA.fromRows [ LA.fromList (1 : gx : means) | gx <- grid' ] + mkLine (i, (_t, fit)) = + let yhat = LA.toList (evalX LA.#> qfBeta fit) + col = quantilePalette !! (i `mod` length quantilePalette) + in layer (line (inline grid') (inline yhat) <> color (fromHex col)) + in foldMap mkLine (zip [0 :: Int ..] (mqmFits m)) + _ -> mempty -- 予測子が無い (設計行列が intercept のみ) = 描画不能 + +-- =========================================================================== +-- 実測 vs 予測 (HasObsPred) — Phase 72.4 +-- +-- ロバスト/分位点 fit は ŷ と残差を直接持つので 実測 = ŷ + residual。 分位点回帰は +-- 0.5 (中央値) に最も近い τ の fit を代表予測に使う (中央値回帰 = 条件付き中央値)。 +-- =========================================================================== + +instance HasObsPred RobustModel where + obsPredPairs m = + let f = LA.toList (rfFitted (rmFit m)) + e = LA.toList (rfResiduals (rmFit m)) + in (zipWith (+) f e, f) + +instance HasObsPred MultiRobustModel where + obsPredPairs m = + let f = LA.toList (rfFitted (mrmFit m)) + e = LA.toList (rfResiduals (mrmFit m)) + in (zipWith (+) f e, f) + +instance HasObsPred QuantileModel where + obsPredPairs m = + case qmFits m of + [] -> ([], []) + fs -> + let (_, fit) = minimumBy (comparing (\(t, _) -> abs (t - 0.5))) fs + f = LA.toList (qfYHat fit) + e = LA.toList (qfResid fit) + in (zipWith (+) f e, f) diff --git a/src/Hanalyze/Plot/Smooth.hs b/src/Hanalyze/Plot/Smooth.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Plot/Smooth.hs @@ -0,0 +1,371 @@ +-- | +-- Module : Hanalyze.Plot.Smooth +-- Description : hgg 連携層 — 平滑化・カーネル法族の図化 instance +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: hgg 連携層 — __平滑化・カーネル法族__ の図化 instance。 +-- +-- ⚠ 親 'Hanalyze.Plot' と同じく別パッケージ @hanalyze-plot@ に属し、 +-- @cabal build --project-file=cabal.project.plot@ で build される。 共通基盤 (class / ModelSpec / grid 評価核) は +-- 'Hanalyze.Plot.Core' を import して取り込む (orphan instance を許容)。 +-- +-- 担当する型 (= spline / GAM / GP / kernel 法): +-- SplineModel / GAMModel / GAMModelN / GPResult / GPRegModel / GPRegModelN / +-- MultiGPResult。 +-- +-- [English]: hgg integration layer — plotting instances for the +-- __smoothing/kernel-method family__. +-- +-- ⚠ Lives in the same separate package @hanalyze-plot@ as the parent +-- 'Hanalyze.Plot', built via @cabal build --project-file=cabal.project.plot@. +-- The shared foundation +-- (class \/ ModelSpec \/ grid evaluation core) is pulled in by importing +-- 'Hanalyze.Plot.Core' (allowing orphan instances). +-- +-- Types covered (= spline \/ GAM \/ GP \/ kernel methods): +-- SplineModel, GAMModel, GAMModelN, GPResult, GPRegModel, GPRegModelN, +-- MultiGPResult. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Hanalyze.Plot.Smooth + ( splineBasisAt + , gamGridCI + , multiGpCurves + ) where + +import Data.List (sortBy) +import Data.Ord (comparing) +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA + +import Data.Text (Text) +import qualified Data.Text as T + +import Graphics.Hgg.Spec ( VisualSpec, layer, inline, inlineCat + , scatter, line, band + , colorBy, alpha ) + +import Hanalyze.Model.Wrappers +import Hanalyze.Plot.Core +import Hanalyze.Model.Core (fittedV, residualsV) +import Hanalyze.Model.GP (GPResult (..), gpNoiseVar) +import Hanalyze.Model.LM ( CIBand (..), confidenceBand, confidenceBandAt + , predictionBandAt ) +import Hanalyze.Model.Spline ( SplineKind (..), SplineFit (..) + , bsplineBasis, naturalSplineBasis ) +import Hanalyze.Model.GAM (GAMFit (..), predictGAMSE) +import Hanalyze.Model.Weibull (quantileNormal) +import Hanalyze.Model.MultiGP (MultiGPResult (..)) +import qualified Statistics.Distribution as SD +import Statistics.Distribution.StudentT (studentT) + +-- =========================================================================== +-- ガウス過程 (描画可能) +-- +-- 'GPResult' (Hanalyze.Model.GP) は予測 grid (gpTestX) + 事後平均 (gpMean) + +-- credible band (gpLower/gpUpper) を **自己完結** で保持する。 ゆえに LMModel の +-- ように X を別途束ねる必要がなく、 結果型をそのまま 'Plottable' にできる。 +-- =========================================================================== + +instance Plottable GPResult where + -- 事後平均 (曲線) + credible band。 予測 grid をソートして 'line' に渡せば GP の曲線が + -- そのまま描ける。 band 半幅は対称 (mean ± 2σ) ゆえ es = gpUpper − gpMean とし、 + -- 'band' に [mean−es, mean+es] を、 'line' に mean を載せる。 + toPlot res = + let triples = sortBy (comparing (\(x, _, _) -> x)) + (zip3 (gpTestX res) (gpMean res) + (zipWith (-) (gpUpper res) (gpMean res))) + xs = [ x | (x, _, _) <- triples ] + ys = [ y | (_, y, _) <- triples ] + es = [ e | (_, _, e) <- triples ] + in layer (band (inline xs) (inline (zipWith (-) ys es)) (inline (zipWith (+) ys es))) + <> layer (line (inline xs) (inline ys)) + +-- =========================================================================== +-- スプライン回帰 (描画可能) +-- +-- 'SplineFit' (Hanalyze.Model.Spline) は基底係数 'sfBeta' と、 基底行列で fit した +-- 線形モデル核 'sfResult' (= 'FitResult') を保持する。 ゆえに **基底行列を設計行列と +-- みなせば** LMModel と同じ @confidenceBand@ (= X (XᵀX)⁻¹ Xᵀ の対角) がそのまま使える。 +-- 違いは「曲線」 である点だけ: 単回帰の直線でなく、 訓練点を x 昇順に結ぶと基底展開に +-- よる平滑曲線になる。 帯は LM と同じ **線形モデルの対称 Wald CI** (基底空間での予測分散)。 +-- =========================================================================== + +-- | [日本語]: 'SplineFit' を訓練 x で評価したときの基底行列 (= confidenceBand の設計行列)。 +-- [English]: The basis matrix obtained by evaluating a 'SplineFit' at the +-- training x values (= the design matrix for confidenceBand). +splineBasisAt :: SplineFit -> LA.Vector Double -> LA.Matrix Double +splineBasisAt fit xs = + let xsV = V.fromList (LA.toList xs) + in case sfKind fit of + BSpline k -> bsplineBasis k (sfKnots fit) xsV + NaturalCubic -> naturalSplineBasis (sfKnots fit) xsV + +instance Plottable SplineModel where + -- 平滑曲線 + CI band。 基底行列を設計行列とみなして @confidenceBand@ を訓練点で + -- 評価し (LMModel と同じ Wald CI)、 x 昇順にソートして折れ線で結ぶ (= 平滑曲線)。 + -- ± 半幅 errorY = se (帯は基底空間の予測分散 = 対称)。 + toPlot m = + let fit = splFit m + res = sfResult fit + xs = LA.toList (splXraw m) + yhat = LA.toList (fittedV res) + basis = splineBasisAt fit (splXraw m) + cib = confidenceBand basis res defaultCILevel + se = zipWith (-) (upperBound cib) yhat -- upper - ŷ = 片側半幅 + sorted = sortBy (comparing (\(x, _, _) -> x)) (zip3 xs yhat se) + xsS = [ x | (x, _, _) <- sorted ] + yhatS = [ y | (_, y, _) <- sorted ] + seS = [ e | (_, _, e) <- sorted ] + in layer (band (inline xsS) (inline (zipWith (-) yhatS seS)) (inline (zipWith (+) yhatS seS))) + <> layer (line (inline xsS) (inline yhatS)) + + -- 残差診断 (平滑曲線 + 残差 vs fitted)。 + diagnosticPlots m = + let res = sfResult (splFit m) + yhat = LA.toList (fittedV res) + resd = LA.toList (residualsV res) + in [ toPlot m + , layer (scatter (inline yhat) (inline resd)) + ] + +-- | [日本語]: grid 評価。 grid x で基底行列を再構築し、 それを設計行列とみなして +-- @confidenceBandAt@ を評価する (基底空間の対称 Wald CI = 訓練 @confidenceBand@ と同核)。 +-- [English]: Grid evaluation. Rebuilds the basis matrix at the grid x +-- values, treats it as a design matrix, and evaluates @confidenceBandAt@ +-- (the symmetric Wald CI in basis space — the same core as the training +-- @confidenceBand@). +instance SingleVarModel SplineModel where + svRange m = let xs = LA.toList (splXraw m) in (minimum xs, maximum xs) + svGrid m level gxs = + let fit = splFit m + basisTrain = splineBasisAt fit (splXraw m) + basisGrid = splineBasisAt fit (LA.fromList gxs) + cib = confidenceBandAt basisTrain (sfResult fit) level basisGrid + los = lowerBound cib + his = upperBound cib + mu = zipWith (\l h -> (l + h) / 2) los his + in (mu, Just (los, his)) + -- PI = closed form σ̂²(1 + xᵀ(XᵀX)⁻¹x) (基底空間 OLS ゆえ LM と同型・statsmodels obs_ci 相当)。 + svGridPI m level gxs = + let fit = splFit m + basisTrain = splineBasisAt fit (splXraw m) + basisGrid = splineBasisAt fit (LA.fromList gxs) + pib = predictionBandAt basisTrain (sfResult fit) level basisGrid + in Just (lowerBound pib, upperBound pib) + -- ブートストラップ: 加法誤差。 refit は同じ kind/knots で再 fit。 + svBootKit m = + let fit = splFit m + res = sfResult fit + in Just BootKit + { bkX = LA.toList (splXraw m) + , bkY = zipWith (+) (LA.toList (fittedV res)) (LA.toList (residualsV res)) + , bkRefit = \xs ys -> splineModel (sfKind fit) (sfKnots fit) (LA.fromList xs) (LA.fromList ys) + , bkObsDist = Nothing } + +-- =========================================================================== +-- 一般化加法モデル (描画可能) +-- +-- 'GAMFit' (Hanalyze.Model.GAM) は各特徴の基底係数 + fitted 'gamYHat' を保持する。 +-- 本 Phase では mgcv 流 Bayesian CI を実装した平滑曲線 + CI 帯を描く。 +-- =========================================================================== + +instance Plottable GAMModel where + -- 平滑曲線 + CI 帯 (Phase 70.6 G で mgcv 流 Bayesian CI を実装)。 grid 経路 + -- ('statModel') に固定し、 LM/spline と同様 band + line を出す。 + toPlot = toPlot . statModel + + -- 残差診断 (平滑曲線 + 残差 vs fitted)。 + diagnosticPlots m = + let fit = gamFit m + yhat = LA.toList (gamYHat fit) + resd = LA.toList (gamResid fit) + in [ toPlot m + , layer (scatter (inline yhat) (inline resd)) + ] + +-- | [日本語]: GAM の grid 評価 (中心 μ̂ + __mgcv 流 Bayesian 信頼帯__)。 'predictGAMSE' の +-- pointwise se に t_{n−edf} 臨界値を掛けて帯にする (Vβ='gamCov')。 +-- [English]: GAM grid evaluation (center μ̂ + an __mgcv-style Bayesian confidence band__). +-- Multiplies the pointwise se from 'predictGAMSE' by the t_{n−edf} +-- critical value to form the band (Vβ='gamCov'). +gamGridCI :: GAMFit -> Double -> [V.Vector Double] -> ([Double], Maybe ([Double], [Double])) +gamGridCI fit level cols = + let (muV, seV) = predictGAMSE fit cols + mu = V.toList muV + se = V.toList seV + df = fromIntegral (LA.size (gamResid fit)) - gamEdf fit + tVal = SD.quantile (studentT (max 1 df)) ((1 + level) / 2) + lo = zipWith (\u s -> u - tVal * s) mu se + hi = zipWith (\u s -> u + tVal * s) mu se + in (mu, Just (lo, hi)) + +-- | [日本語]: grid 評価。 grid x を 'predictGAMSE' に通し平滑曲線 + CI 帯を評価する +-- (mgcv 流 Bayesian CI を実装)。 +-- [English]: Grid evaluation. Runs the grid x through 'predictGAMSE' to +-- evaluate the smooth curve and CI band (implements an mgcv-style +-- Bayesian CI). +instance SingleVarModel GAMModel where + svRange m = let xs = LA.toList (gamXraw m) in (minimum xs, maximum xs) + svGrid m level gxs = gamGridCI (gamFit m) level [V.fromList gxs] + + +-- | [日本語]: 第1予測子を描画軸に、 他予測子は訓練平均に固定して偏依存曲線を評価する。 +-- [English]: Evaluates a partial-dependence curve using the first +-- predictor as the plotting axis, with the other predictors held fixed +-- at their training means. +instance SingleVarModel GAMModelN where + svRange m = case gamNXraws m of + (x:_) -> let xs = LA.toList x in (minimum xs, maximum xs) + [] -> (0, 1) + svGrid m level gxs = + let n = length gxs + others = drop 1 (gamNXraws m) + holdMean v = V.replicate n (LA.sumElements v / fromIntegral (LA.size v)) + cols = V.fromList gxs : map holdMean others + in gamGridCI (gamNFit m) level cols + svCoefR2 m = Just ([gamIntercept (gamNFit m)], gamR2 (gamNFit m)) + +instance Plottable GAMModelN where + -- 平滑曲線 + CI 帯 (Phase 70.6 G)。 grid 経路 ('statModel') に固定。 多予測子では + -- 第1予測子を軸に他を訓練平均で固定した偏依存曲線 + その点の CI。 + toPlot = toPlot . statModel + +-- =========================================================================== +-- カーネル回帰 (GP / KRR / RFF) の描画可能ラッパ +-- =========================================================================== + +-- | [日本語]: grid 評価 (E2)。 予測子 'gprPredict' を grid x に当て、 分布あり象限 +-- (Gp/GpRff) は事後分散→正規 credible 帯 (μ̂ ± z·σ)、 点象限 (Ridge/RidgeRff) は +-- 帯なし ('Nothing')。 信頼水準 @level@ → @z = Φ⁻¹(1 − (1−level)/2)@ +-- ('quantileNormal')。 'WeightedLMModel' と同じく @toPlot@ を grid 経路 +-- ('statModel') に固定する (元データ散布図と整合)。 +-- [English]: Grid evaluation (E2). Applies the predictor 'gprPredict' to +-- the grid x. For distribution-bearing quadrants (Gp\/GpRff), converts +-- the posterior variance into a normal credible band (μ̂ ± z·σ); for +-- point quadrants (Ridge\/RidgeRff), there is no band ('Nothing'). The +-- confidence level @level@ maps to @z = Φ⁻¹(1 − (1−level)/2)@ +-- ('quantileNormal'). Like 'WeightedLMModel', @toPlot@ is fixed to the +-- grid path ('statModel') to stay consistent with the raw-data scatter +-- plot. +instance SingleVarModel GPRegModel where + svRange m = let xs = LA.toList (gprXraw m) in (minimum xs, maximum xs) + svGrid m level gxs = + let (mu, mbVar) = gprPredict m gxs + z = quantileNormal (1 - (1 - level) / 2) + in case mbVar of + Just vs -> let sds = map (sqrt . max 0) vs + los = zipWith (\u s -> u - z * s) mu sds + his = zipWith (\u s -> u + z * s) mu sds + in (mu, Just (los, his)) + Nothing -> (mu, Nothing) -- Ridge 系 = 帯なし + -- 予測区間 (PI) = 事後予測分散 (f の分散 + 観測ノイズ σ_n²) の正規帯。 分布あり象限のみ。 + svGridPI m level gxs = + let (mu, mbVar) = gprPredict m gxs + z = quantileNormal (1 - (1 - level) / 2) + sn2 = max 0 (gpNoiseVar (gprParams m)) + in case mbVar of + Just vs -> let sds = map (\v -> sqrt (max 0 v + sn2)) vs + in Just ( zipWith (\u s -> u - z * s) mu sds + , zipWith (\u s -> u + z * s) mu sds ) + Nothing -> Nothing + -- カーネル回帰は β₀+β₁x の線形「式」を持たないため式/R² 注釈は出さない。 + svCoefR2 _ = Nothing + +-- | [日本語]: ★訓練点経路ではなく grid 経路 ('statModel') に固定 (元データ散布図と整合)。 +-- 分布あり象限は曲線 + credible 帯、 点象限は曲線のみ。 +-- [English]: ★Fixed to the grid path ('statModel') rather than the +-- training-point path (to stay consistent with the raw-data scatter +-- plot). Distribution-bearing quadrants get a curve + credible band; +-- point quadrants get only a curve. +instance Plottable GPRegModel where + toPlot = toPlot . statModel + + +-- | [日本語]: 第1予測子を描画軸に、 他予測子を訓練平均に固定した偏依存曲線 (band は +-- 分布あり象限のみ)。 +-- [English]: A partial-dependence curve using the first predictor as +-- the plotting axis, with the other predictors held fixed at their +-- training means (the band appears only for distribution-bearing +-- quadrants). +instance SingleVarModel GPRegModelN where + svRange m = case gprnXraws m of + (x:_) -> let xs = LA.toList x in (minimum xs, maximum xs) + [] -> (0, 1) + svGrid m level gxs = + let n = length gxs + others = drop 1 (gprnXraws m) + holdMean v = LA.konst (LA.sumElements v / fromIntegral (LA.size v)) n + testX = LA.fromColumns (LA.fromList gxs : map holdMean others) + (mu, mbVar) = gprnPredict m testX + z = quantileNormal (1 - (1 - level) / 2) + in case mbVar of + Just vs -> let sds = map (sqrt . max 0) vs + in (mu, Just ( zipWith (\u s -> u - z * s) mu sds + , zipWith (\u s -> u + z * s) mu sds )) + Nothing -> (mu, Nothing) + svGridPI m level gxs = + let n = length gxs + others = drop 1 (gprnXraws m) + holdMean v = LA.konst (LA.sumElements v / fromIntegral (LA.size v)) n + testX = LA.fromColumns (LA.fromList gxs : map holdMean others) + (mu, mbVar) = gprnPredict m testX + z = quantileNormal (1 - (1 - level) / 2) + sn2 = max 0 (gpNoiseVar (gprnParams m)) + in case mbVar of + Just vs -> let sds = map (\v -> sqrt (max 0 v + sn2)) vs + in Just ( zipWith (\u s -> u - z * s) mu sds + , zipWith (\u s -> u + z * s) mu sds ) + Nothing -> Nothing + svCoefR2 _ = Nothing + +instance Plottable GPRegModelN where + toPlot = toPlot . statModel + +-- =========================================================================== +-- 多出力 GP (描画可能) +-- =========================================================================== + +-- | [日本語]: 多出力 GP の予測曲線 + 95% band (出力ごとに色分け・x = 予測点 index)。 +-- [English]: Multi-output GP prediction curves + 95% band (colored per +-- output; x = prediction-point index). +multiGpCurves :: MultiGPResult -> VisualSpec +multiGpCurves res = + let outs = zip3 (mgpMean res) (mgpLower res) (mgpUpper res) + mkOut k (m, lo, hi) = + let xs = [ fromIntegral i | i <- [1 .. length m] ] :: [Double] + lbl = "y" <> T.pack (show (k :: Int)) + grp = inlineCat (replicate (length m) lbl) + in layer (band (inline xs) (inline lo) (inline hi) <> colorBy grp <> alpha 0.2) + <> layer (line (inline xs) (inline m) <> colorBy grp) + in mconcat (zipWith mkOut [0 ..] outs) + +instance Plottable MultiGPResult where + toPlot = multiGpCurves + +-- =========================================================================== +-- 実測 vs 予測 (HasObsPred) — Phase 72.4 +-- +-- spline は内側の線形 fit ('sfResult') から、 GAM は保持する ŷ/残差から復元する。 +-- =========================================================================== + +instance HasObsPred SplineModel where + obsPredPairs m = + let r = sfResult (splFit m) + f = LA.toList (fittedV r) + e = LA.toList (residualsV r) + in (zipWith (+) f e, f) + +instance HasObsPred GAMModel where + obsPredPairs m = + let f = LA.toList (gamYHat (gamFit m)) + e = LA.toList (gamResid (gamFit m)) + in (zipWith (+) f e, f) + +instance HasObsPred GAMModelN where + obsPredPairs m = + let f = LA.toList (gamYHat (gamNFit m)) + e = LA.toList (gamResid (gamNFit m)) + in (zipWith (+) f e, f) diff --git a/src/Hanalyze/Plot/Wrappers.hs b/src/Hanalyze/Plot/Wrappers.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Plot/Wrappers.hs @@ -0,0 +1,339 @@ +-- | +-- Module : Hanalyze.Plot.Wrappers +-- Description : hgg 連携層 — 汎用ラッパの Plottable / SingleVarModel 連携 instance +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: hgg 連携層 — __汎用ラッパ (どの族にも属さない) の Plottable / SingleVarModel__ 連携 instance + 専用 helper。 +-- +-- ⚠ 親 'Hanalyze.Plot' と同じく別パッケージ @hanalyze-plot@ に属し、 +-- @cabal build --project-file=cabal.project.plot@ で build される。 共通基盤 (class / ModelSpec / grid 評価核) は +-- 'Hanalyze.Plot.Core' を import して取り込む (orphan instance を許容: +-- クラス=Core・instance=ここ・型=Wrappers/各 Model module)。 +-- +-- 担当する型・ヘルパ (= 特定の ML / ベイズ族に属さない汎用ラッパ): +-- 多出力線形回帰 'MultiFit' の残差相関 heatmap・k-NN 回帰の単変量描画 +-- ('KNNRegressor')・透過標準化ラッパ 'StandardizedModel'・罰則回帰結果 +-- 'RegModel' の係数 bar・群別フィット 'GroupedFit' の N 曲線重畳・plot ColData +-- 源の 'ColumnSource'・LM 係数診断アクセサ ('lmDiag' / 'groupedLmDiag')。 +-- +-- [English]: hgg integration layer — __Plottable\/SingleVarModel instances for generic wrappers (those not belonging to any specific family)__, plus dedicated helpers. +-- +-- ⚠ Lives in the same separate package @hanalyze-plot@ as the parent +-- 'Hanalyze.Plot', built via @cabal build --project-file=cabal.project.plot@. +-- The shared foundation +-- (class \/ ModelSpec \/ grid-evaluation core) is pulled in by importing +-- 'Hanalyze.Plot.Core' (orphan instances are allowed by design: +-- class = Core, instance = here, type = Wrappers\/each model module). +-- +-- Types and helpers covered here (= generic wrappers not belonging to any +-- specific ML\/Bayesian family): +-- the residual-correlation heatmap for multi-output linear regression +-- 'MultiFit'; univariate plotting for k-NN regression ('KNNRegressor'); +-- the transparent standardization wrapper 'StandardizedModel'; the +-- coefficient bar chart for penalized regression results 'RegModel'; the +-- N-curve overlay for grouped fits 'GroupedFit'; the 'ColumnSource' +-- instance for plot ColData sources; and the LM coefficient diagnostic +-- accessors ('lmDiag' \/ 'groupedLmDiag'). +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module Hanalyze.Plot.Wrappers + ( -- ** 係数診断の薄アクセサ — A9 + lmDiag + , groupedLmDiag + -- ** 群別フィットの fullrange レンダラ — A4 / A7 + , groupedFullrange + ) where + +import qualified Data.Map.Strict as Map +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Numeric.LinearAlgebra as LA + +import Data.Text (Text) +import qualified Data.Text as T +import qualified DataFrame.Internal.Column as DX +import qualified DataFrame.Internal.DataFrame as DX + +import Hanalyze.Data.ColumnSource (ColumnSource (..)) + +import Graphics.Hgg.Spec ( VisualSpec, layer, inline, inlineCat + , ColData (..) + , scatter, line + , heatmap, colorBy + , scaleColorManual, legend + , bar, title ) + +import Hanalyze.Model.Wrappers +import Hanalyze.Plot.Core +import Hanalyze.Fit +import Hanalyze.Model.LM.Diagnostics (CoefStats (..), lmCoefStats) +import Hanalyze.Model.LM (linspace) +import Hanalyze.Model.MultiLM (MultiFit (..)) +import Hanalyze.Stat.Standardize + ( Standardizer (..) + , applyStandardizerCol ) +import Hanalyze.Model.KNN (KNNRegressor (..), predictKNNR) + +-- =========================================================================== +-- 多出力線形回帰 (描画可能) +-- +-- 'MultiFit' (Hanalyze.Model.MultiLM) は q 個の応答を共通の予測子で同時回帰し、 +-- 固有の成果物として **出力間の残差相関 'mfResidCor' (q×q)** を保持する。 q 本の回帰 +-- 関係を単一図に素直に載せる方法は一意でない (出力ごとスケールが異なり得る) ため、 +-- 代表図 (@toPlot@) は **残差相関 heatmap** とする (= 多出力回帰固有の図。 user 決定 +-- 2026-06-04)。 'MultiFit' は heatmap に必要な相関行列を自己完結で持つので、 'GPResult' +-- 同様 X を別途束ねず結果型をそのまま 'Plottable' にできる。 個別の出力 j の回帰線は +-- 'predictMultiLM' で別途描ける (本 instance の対象外)。 +-- +-- ⚠ 'heatmap' (geom_tile) は **categorical 軸専用** (renderHeatmap が x/y をラベルとして +-- カテゴリ軸の index に引く。 実測: Render/Statistical.hs)。 ゆえに格子座標は数値でなく +-- **出力名ラベル** ("y1", "y2", …) を 'inlineCat' で渡す (数値だとカテゴリ軸が立たず +-- 全セルが drop されてタイルが描かれない = 計測で確認)。 +-- =========================================================================== + +instance Plottable MultiFit where + -- 残差相関 q×q を heatmap に。 行 i・列 j のセル (x=yⱼ, y=yᵢ) に相関値 mfResidCor[i,j] + -- を割り当てて 'heatmap' (= geom_tile) layer を 1 枚返す。 軸は出力名ラベル (categorical)。 + toPlot mf = + let cor = LA.toLists (mfResidCor mf) + q = length cor + lbl k = "y" <> T.pack (show (k + 1 :: Int)) -- 出力名ラベル + cells = [ (lbl j, lbl i, (cor !! i) !! j) + | i <- [0 .. q - 1], j <- [0 .. q - 1] ] + xs = [ x | (x, _, _) <- cells ] + ys = [ y | (_, y, _) <- cells ] + vs = [ v | (_, _, v) <- cells ] + in layer (heatmap (inlineCat xs) (inlineCat ys) (inline vs)) + +-- C2: 元スケール逆変換 instance (Phase 70.3 項目 C) ------------------------- +-- +-- 内側モデルは標準化空間で学習されている。 ここで予測子 x を入力時に標準化し、 +-- (@standardizedY@ なら) 応答 y を出力時に逆変換することで、 図・予測を**元スケール**で +-- 返す。 単変量 (1 特徴) 描画が対象 (smXStd の 0 次元を使う)。 + +-- | [日本語]: k-NN 回帰の単変量描画 (透過標準化の内側として要る)。 1 特徴 ('knnRX' が +-- 1 列) を仮定し grid 点を予測曲線にする。 局所平均ゆえ band は持たない (Nothing)。 +-- [English]: Univariate plotting for k-NN regression (needed as the inner +-- model of transparent standardization). Assumes a single feature +-- ('knnRX' has 1 column) and turns grid points into the predicted curve. +-- Since it's a local average, there's no band (Nothing). +instance SingleVarModel KNNRegressor where + svRange m = + let c0 = LA.toList (head (LA.toColumns (knnRX m))) + in (minimum c0, maximum c0) + svGrid m _ gxs = + let xEval = LA.fromColumns [LA.fromList gxs] -- n × 1 (単一特徴) + in (VU.toList (predictKNNR m xEval), Nothing) -- 帯なし + +-- | [日本語]: 0 次元 (単変量描画の予測子) の (μ, σ)。 +-- [English]: The (μ, σ) of dimension 0 (the univariate-plotting predictor). +stMu1, stSd1 :: Standardizer -> Double +stMu1 = head . stMu +stSd1 = head . stSd + +-- | [日本語]: 応答 y の逆変換 (@smYStd = Just@ のみ実施。 @Nothing@ は元 y スケールのまま)。 +-- [English]: Inverse-transforms the response y (only performed when +-- @smYStd = Just@; @Nothing@ leaves it in the original y scale). +unstdY :: Maybe (Double, Double) -> Double -> Double +unstdY (Just (muY, sdY)) v = v * sdY + muY +unstdY Nothing v = v + +-- | [日本語]: 透過標準化ラッパの単変量描画 (元スケール)。 入力 x を標準化 → 内側を評価 → +-- (@standardizedY@ なら) 出力 y を逆変換する。 内側 'svRange' (標準化空間) は +-- smXStd の 0 次元で元スケールへ戻す。 band/PI も同様に y を逆変換。 +-- [English]: Univariate plotting for the transparent standardization +-- wrapper (in the original scale). Standardizes input x → evaluates the +-- inner model → (if @standardizedY@) inverse-transforms output y. The +-- inner 'svRange' (in standardized space) is converted back to the +-- original scale via dimension 0 of smXStd. The band\/PI likewise have y +-- inverse-transformed. +instance SingleVarModel m => SingleVarModel (StandardizedModel m) where + svRange (StandardizedModel inner sx _ _) = + let (zlo, zhi) = svRange inner + unX z = z * stSd1 sx + stMu1 sx + in (unX zlo, unX zhi) + svGrid (StandardizedModel inner sx mY _) level xs = + let zs = map (applyStandardizerCol sx 0) xs + (muZ, mbBand) = svGrid inner level zs + in ( map (unstdY mY) muZ + , fmap (\(lo, hi) -> (map (unstdY mY) lo, map (unstdY mY) hi)) mbBand ) + svGridPI (StandardizedModel inner sx mY _) level xs = + let zs = map (applyStandardizerCol sx 0) xs + in fmap (\(lo, hi) -> (map (unstdY mY) lo, map (unstdY mY) hi)) + (svGridPI inner level zs) + -- 線形内側のみ式注釈 (係数を元スケールへ逆変換・R² はスケール不変で透過)。 + -- X のみ標準化: y = β₀ + β₁·(x−μₓ)/σₓ = (β₀ − β₁μₓ/σₓ) + (β₁/σₓ)·x。 + -- X+y 標準化: y = σ_y·(β₀ + β₁·(x−μₓ)/σₓ) + μ_y。 + svCoefR2 (StandardizedModel inner sx mY _) = + case svCoefR2 inner of + Just ([b0, b1], r2) -> + let mux = stMu1 sx; sdx = stSd1 sx + (a0, a1) = case mY of + Nothing -> (b0 - b1 * mux / sdx, b1 / sdx) + Just (muY, sdY) -> (b0 * sdY + muY - b1 * sdY * mux / sdx, b1 * sdY / sdx) + in Just ([a0, a1], r2) + _ -> Nothing -- 非線形 (kNN 等) は式注釈なし + +-- | [日本語]: 透過標準化ラッパの代表図 = 元スケールの予測曲線 (+ 単変量散布 'smTrain')。 +-- 内側 @toPlot@ (標準化軸) には依存せず、 ラッパ自身の 'SingleVarModel' を +-- 'statModel' grid 機構へ流す。 +-- [English]: The transparent standardization wrapper's representative +-- plot = the predicted curve in the original scale (+ the univariate +-- scatter 'smTrain'). Doesn't depend on the inner @toPlot@ (standardized +-- axes); instead feeds the wrapper's own 'SingleVarModel' into the +-- 'statModel' grid mechanism. +instance SingleVarModel m => Plottable (StandardizedModel m) where + toPlot sm = case smTrain sm of + Just (xs, ys) -> layer (scatter (inline xs) (inline ys)) <> toPlot (statModel sm) + Nothing -> toPlot (statModel sm) + +-- | [日本語]: 係数 bar (特徴名ラベル・元スケール) を代表図に。 CV パスがあれば診断束に +-- λ-MSE 図。 +-- [English]: Uses the coefficient bar chart (feature-name labels, original +-- scale) as the representative plot. If a CV path exists, adds a λ-MSE +-- plot to the diagnostic bundle. +instance Plottable RegModel where + toPlot m = + layer (bar (inlineCat (rmgNames m)) (inline (rmgCoefs m))) + <> title (regMethodName (rmgMethod m) <> " coefficients (\955=" + <> T.pack (show (roundTo 4 (rmgLambda m))) <> ")") + diagnosticPlots m = toPlot m : case rmgCVPath m of + Just (lams, scores) -> + [ layer (line (inline lams) (inline scores)) <> title "CV/LOOCV score path" ] + Nothing -> [] + +-- | [日本語]: RegMethod の表示名 (図タイトル用)。 +-- [English]: The display name of a RegMethod (for figure titles). +regMethodName :: RegMethod -> Text +regMethodName Ridge = "Ridge" +regMethodName Lasso = "Lasso" +regMethodName (ElasticNet _) = "Elastic Net" +regMethodName (MCP _) = "MCP" +regMethodName (SCAD _) = "SCAD" +regMethodName (AdaptiveLasso _) = "Adaptive Lasso" +regMethodName (GroupLasso _) = "Group Lasso" + +-- | [日本語]: 小数 n 桁丸め (タイトル表示用)。 +-- [English]: Rounds to n decimal places (for title display). +roundTo :: Int -> Double -> Double +roundTo n v = let f = 10 ^^ n in fromIntegral (round (v * f) :: Integer) / f + +-- | [日本語]: A9: 'LMModel' の係数診断 (SE / t値 / p値) を一発取得する薄アクセサ。 +-- 数値核は 'Hanalyze.Model.LM.Diagnostics.lmCoefStats'。 描画用に X を束ねた +-- 'LMModel' から設計行列 ('lmDesign') と fit 結果 ('lmResult') を渡すだけ。 +-- 返りは係数順 (@[(Intercept), x]@) の 'CoefStats' リスト。 +-- [English]: A9: A thin accessor to get 'LMModel' coefficient diagnostics +-- (SE \/ t-value \/ p-value) in one call. The numeric core is +-- 'Hanalyze.Model.LM.Diagnostics.lmCoefStats'; it just passes the +-- design matrix ('lmDesign') and fit result ('lmResult') from the +-- plotting-bundled 'LMModel'. Returns a 'CoefStats' list in coefficient +-- order (@[(Intercept), x]@). +lmDiag :: LMModel -> [CoefStats] +lmDiag m = lmCoefStats (lmDesign m) (lmResult m) + +-- | [日本語]: A9: 群別 LM フィット ('grouped "g" (lm …)' の結果) の各群係数診断を取り出す。 +-- @[(群ラベル, [係数の CoefStats])]@。 群間で傾き SE/有意性を比較する用途。 +-- ★@Fitted spec ~ LMModel@ に特殊化 (LM 群フィット専用)。 +-- [English]: A9: Extracts the per-group coefficient diagnostics from a +-- grouped LM fit (the result of @grouped "g" (lm …)@). Returns +-- @[(group label, [coefficient CoefStats])]@, for comparing slope SE\/ +-- significance across groups. +-- ★Specialized to @Fitted spec ~ LMModel@ (LM grouped-fit only). +groupedLmDiag :: (Fitted spec ~ LMModel) => GroupedFit spec -> [(Text, [CoefStats])] +groupedLmDiag = map (fmap lmDiag) . groupModels + +-- | [日本語]: 群別フィットを N 曲線で重畳する (@toPlot@ = 各群 'svGrid' の μ̂ 曲線・群色 + 凡例)。 +-- ★A3 の凡例機構を N 群へ一般化: 各曲線を @ColorByCol@ (群ラベル) に載せ +-- 'scaleColorManual' で群色を固定し 'legend' を出す (固定色だと凡例が出ない罠を回避)。 +-- grid 点数 100・帯なし (A1 既定 OFF) 固定。 群色は 'effectPalette' の循環。 +-- [English]: Overlays a grouped fit as N curves (@toPlot@ = the μ̂ curve of +-- each group's 'svGrid', with per-group color + legend). +-- ★Generalizes the A3 legend mechanism to N groups: each curve is placed +-- on @ColorByCol@ (the group label), fixed with 'scaleColorManual' to a +-- per-group color, and 'legend' is shown (avoiding the trap where a fixed +-- color makes no legend appear). Fixed at 100 grid points, no band +-- (A1 default OFF). Group colors cycle through 'effectPalette'. +instance SingleVarModel (Fitted spec) => Plottable (GroupedFit spec) where + toPlot = renderGrouped + +-- | [日本語]: 群別フィットを __各群の x 範囲のみ__で描く (既定。 @toPlot@ = これ)。 +-- [English]: Plots a grouped fit using __only each group's own x range__ +-- (the default; @toPlot@ = this). +renderGrouped :: SingleVarModel (Fitted spec) => GroupedFit spec -> VisualSpec +renderGrouped = renderGroupedWith False + +-- | [日本語]: 群別フィットを __データ全幅__ (全群 x の union 範囲) へ延ばして描く (A7 fullrange)。 +-- ggplot @geom_smooth(fullrange = TRUE)@ 相当: 各群の回帰線を、 その群の x 範囲だけでなく +-- __全群を合わせた x の min/max__ まで延長して評価する (群間の傾き差を全域で比較しやすい)。 +-- ★単一モデルでは「データ全幅 = 訓練 x」 ゆえ意味を持たない (range 拡張は grouped 固有)。 +-- @toPlot@ とは別経路 (結果型 'GroupedFit' に描画 flag を持たせない・別レンダラとして提供)。 +-- [English]: Plots a grouped fit extended to __the full data width__ (the +-- union range of all groups' x) — the A7 fullrange variant. +-- Equivalent to ggplot's @geom_smooth(fullrange = TRUE)@: each group's +-- regression line is evaluated not just over its own x range but extended +-- to __the min\/max of x across all groups combined__ (making it easier to +-- compare slope differences across the whole domain). +-- ★Meaningless for a single model, since "full data width = training x" +-- there (range extension is specific to grouped fits). +-- Reached via a separate path from @toPlot@ (the result type 'GroupedFit' +-- carries no plotting flag; this is offered as a separate renderer). +groupedFullrange :: SingleVarModel (Fitted spec) => GroupedFit spec -> VisualSpec +groupedFullrange = renderGroupedWith True + +-- | [日本語]: 群別フィットの共通レンダラ。 @full@ で評価 x 範囲を切替える +-- (@False@ = 各群自範囲、 @True@ = 全群 union 範囲 = A7 fullrange)。 +-- [English]: The shared renderer for grouped fits. @full@ switches the +-- evaluated x range (@False@ = each group's own range, @True@ = the union +-- range of all groups = A7 fullrange). +renderGroupedWith :: SingleVarModel (Fitted spec) => Bool -> GroupedFit spec -> VisualSpec +renderGroupedWith full gf = + let pairs = zip [0 :: Int ..] (gfGroups gf) + n = 100 + colOf i = effectPalette !! (i `mod` length effectPalette) + -- fullrange = 全群 svRange の union (lo = 最小, hi = 最大)。 群が無ければ使われない。 + ranges = [ svRange m | (_, (_, m)) <- pairs ] + unionLo = minimum (map fst ranges) + unionHi = maximum (map snd ranges) + curveOf (_, (lbl, m)) = + let (lo, hi) = if full then (unionLo, unionHi) else svRange m + gxs = linspace lo hi n + (mu, _) = svGrid m defaultCILevel gxs + in layer (line (inline gxs) (inline mu) + <> colorBy (inlineCat (replicate n lbl))) + legendSpec + | null pairs = mempty + | otherwise = scaleColorManual [ (lbl, colOf i) | (i, (lbl, _)) <- pairs ] + <> legend + in foldMap curveOf pairs <> legendSpec + +-- --- plot ColData 源の ColumnSource instance (flag 配下・非 portable) ------- +-- +-- hgg の @[(Text, ColData)]@ (= df 中立表現)。 'NumData' は数値列、 +-- 'TxtData' は factor 列。 'lookupCol' は数値列のみ返し、 'toFrame' は +-- 数値・文字列の両方を @DX.DataFrame@ に詰めて formula 経路で factor を温存する。 +instance ColumnSource [(Text, ColData)] where + lookupCol n cs = case lookup n cs of + Just (NumData v) -> Just (V.toList v) + _ -> Nothing + columnNames = map fst + toFrame cs = DX.fromNamedColumns (concatMap toCol cs) + where + toCol (n, NumData v) = [(n, DX.fromList (V.toList v))] + toCol (n, TxtData v) = [(n, DX.fromList (V.toList v))] + +-- =========================================================================== +-- 実測 vs 予測 (HasObsPred) — Phase 72.4 +-- +-- 罰則回帰 ('RegModel') は元スケール係数 (rmgIntercept + rmgCoefs) と生設計 +-- 'rmgXraw' から予測を再構成し、 実測は生応答 'rmgYraw' を使う。 +-- =========================================================================== + +instance HasObsPred RegModel where + obsPredPairs m = + let beta = LA.fromList (rmgCoefs m) + prd = map (+ rmgIntercept m) (LA.toList (rmgXraw m LA.#> beta)) + in (LA.toList (rmgYraw m), prd) diff --git a/test-plot/Spec.hs b/test-plot/Spec.hs new file mode 100644 --- /dev/null +++ b/test-plot/Spec.hs @@ -0,0 +1,3749 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Phase 46 (hgg 統合) の数値・構造テスト。 +-- +-- 別パッケージ hanalyze-plot の一部として build/run される (= Hanalyze.Plot が必要)。 +-- cabal test --project-file=cabal.project.plot hanalyze-plot-test +module Main (main) where + +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Numeric.LinearAlgebra as LA +import Test.Hspec + +import Graphics.Hgg.Spec (ColorEnc (..), ColRef (..), Layer (..), + MarkKind (..), MarkShape (..), VisualSpec (..), + Annotation (..), CustomMark (..), + ColData (..), LineType (..), fromHex, + DAGSpec (..), DAGNode (..), DAGEdge (..), + DAGNodeKind (..), DAGPlate (..)) +import Graphics.Hgg.Custom.Dendrogram (DendroPayload (..), DendroSeg (..)) +import Data.Aeson (fromJSON, Result (..)) +import qualified Data.Map.Strict as Map +import qualified System.Random.MWC as MWC +import Hanalyze.MCMC.Core (Chain (..)) +import Hanalyze.Model.PCA (PCAStandardize (..)) +import qualified Hanalyze.Model.PCA as PCALow +import Hanalyze.Model.RandomForest (defaultRandomForest, fitRF + , fitRFVPure, predictRF, RandomForest (..)) +import Hanalyze.Model.CompetingRisks (CRSample (..), fitCompetingRisks) +import Hanalyze.Model.Quantile (QRFit (..)) +import Hanalyze.Model.Survival (Event (..), SurvSample (..), + kaplanMeier) +import Hanalyze.Model.MultiLM (fitMultiLM) +import Hanalyze.Model.NeuralNetwork (fitMLPClassifier, fitMLPClassifierPure, defaultMLP, MLPFit (..)) +import Hanalyze.Model.GP (Kernel (..), GPParams (..), defaultGPParams) +import Hanalyze.Model.Kernel (defaultKernelParams) +import Hanalyze.Model.Robust (RobustEstimator (..), RobustFit (..), + defaultHuberK, fitRobustLM, robustCovBeta) +import Hanalyze.Model.Core (coefficientsV, fittedV, predictAt) +import Hanalyze.Model.GLM (Family (..), LinkFn (..)) +import Hanalyze.Model.GP (GPResult (..)) +import Hanalyze.Model.GAM (GAMFit (..), fitGAM) +import Hanalyze.Model.Spline (SplineFit (..), SplineKind (..)) +import Hanalyze.Plot (GAMModel (..), GLMModel (..), + GAMBasis (..), GAMLambda (..), + GAMConfig (..), defaultGAMConfig, gam, gamMulti, + GAMModelN (..), fitGAMWith, + GPConfig (..), defaultGP, gp, GPMethod (..), + HyperStrategy (..), GPRegModel (..), + gpMulti, GPRegModelN (..), + RegMethod (..), LambdaStrat (..), RegConfig (..), + defaultRidge, defaultLasso, regularized, + ridge, lasso, elasticNet, RegModel (..), regPredict, + fitEither, + Kernel (..), GPParams (..), defaultGPParams, + LMModel (..), QuantileModel (..), + RobustModel (..), SplineModel (..), + chainModel, diagnosticPlots, + forecastModel, gamModel, glmModel, + lmModel, quantileModel, robustModel, + splineModel, toPlot, + Coef (..), modelCoefficients, + predictPoint, describeModel, + statModel, grid, gridRange, + BandMode (..), bandMode, + statColor, statFill, statLinetype, + statLinewidth, statAlpha, statLabel, + statEquation, statR2, + SingleVarModel (..), + predAt, + MultiLMModel (..), multiLMModel, + MultiGLMModel (..), multiGLMModel, + along, statModelMulti, + HoldAgg (..), holdAt, byVar, + plsModel, selectOutput, + SurfaceOpts (..), defaultSurfaceOpts, + surfaceGrid, surfaceOf, surfaceOfWith, + dataScatter3DOf, + epredSurfaceOf, epredSurfaceOfWith, + HBMConfig (..), defaultHBM, + HBMModel (..), hbmModel, hbmModelPure, + hbmModelIO, + ppcOfWithIO, + hbmParamNames, marginalsOf, + TraceOpts (..), defaultTraceOpts, + tracesOf, tracesOfWith, + ForestSpec (..), forestOf, + statLevel, epred, epredAt, + PPCConfig (..), defaultPPC, + PPCSpec (..), ppcOf, ppcOfWith, + DagSpec (..), dagOf, dagOfRaw, + dagOfModel, dagOfModelWith, + dashboardOf, dashboardFullOf, traceDensityOf, + divergencesOf, + pairOf, energyOf, autocorrOf, autocorrOfLag, + rankOf, rankOfBins, + Fit (..), (|->), (|->!), + lm, glm, rq, rlm, + piMethod, PIMethod (..), + lmF, glmF, glmmF, + hbm, dataScatterOf, + grouped, groupModels, groupLabels, + groupedFullrange, + weighted, WeightedLMModel (..), + CoefStats (..), lmDiag, groupedLmDiag, + clusterScatterOf, centroidsOf, + clusterHullOf, clusterEllipseOf, + dendrogramOf, dendrogramOf', defaultDendroOpts, DendroOpts (..), + GBRegressor (..), GBClassifier (..), + RFClassifierFit (..), DTree (..), + treeImportances, + ClassPredict (..), decisionBoundaryOf, + confusionOf, mdsView, mdsGroupBy, mds, defaultMDS, nnLossOf, + mlpCls, mlpReg, + svmCls, defaultSVM, + SVMConfig (..), SVMMulti (..), + numSupportVectors, svmSupportVectorsOf, decisionLineOf, + RegPredict (..), pdp, pdpIce, pdpOf, pdpIceOf, pdpPlot, pdpIcePlot, + partialDependencePlot, partialDependenceIcePlot, + KNNClassifier (..), + PLSFit (..), scoreView, vipView, + MultiGPResult (..), multiGpCurves, + GARCHFit (..), garchVolatility, + AFTFit (..), aftSurvivalAt, + FunctionalPCA (..), FLMResult (..), + RegFit (..), regPathPlot, + DirectLiNGAMFit (..), lingamDag, + directLingam, parceLingam, multiGroupLingam, + varLingam, pairwiseLingam, + bootstrapLingam, icaLingam, bootstrapEdgeProbOf, LiNGAMFitted (..), + correlationOf, CorrelationGraph (..), + factorialDesign, centralCompositeDesign, designTable, designModel, multiOutput, + contFactor, catFactor, + profiler, profilerResidual, ProfilerSpec (..), ResidualMode (..), contourOf, + TestResult (..), testForest, + testForestLabeled, describeBox, + pca, pls, lda, ccaOf, CCAFit (..), + gbmReg, gbmCls, defaultGBM, + decisionTree, defaultDecisionTree, knnCls, knnReg, naiveBayes, + kmeans, randomForestReg, randomForestCls, + lmMulti, glmMulti, rlmMulti, + CoefRow (..), coefSummary, + obsVsPred, obsPredPairs, coefForest, + MultiRobustModel (..), + standardized, standardizedY, + StandardizedModel (..), + predictorCols, responseCol, + rqMulti, MultiQuantileModel (..)) +import Hanalyze.Model.Multivariate (cca) +import Control.Exception (evaluate) +import Hanalyze.Stat.Test (Alternative (..)) +import Hanalyze.Model.AFT (AFTDistribution (..)) +import Hanalyze.Model.Regularized (Penalty (NoPen)) +import Hanalyze.Model.Cluster (KMeansResult (..) + , KMeansConfig (..), defaultKMeans, kMeansPure, kMeans) +import Hanalyze.Model.HierarchicalCluster (fitHierarchical, Linkage (..), HClusterFit (..)) +import Hanalyze.Model.LiNGAM.Direct (fitDirectLiNGAM, defaultDirectLiNGAMConfig) +import Hanalyze.Model.LiNGAM.Parce (defaultParceConfig) +import Hanalyze.Model.LiNGAM.MultiGroup (defaultMultiGroupConfig) +import Hanalyze.Model.LiNGAM.VAR (defaultVARLiNGAMConfig) +import Hanalyze.Model.LiNGAM.Bootstrap (defaultBootstrapConfig, BootstrapConfig (..) + , BootstrapResult (..), fitBootstrapLiNGAM, fitBootstrapLiNGAMPure) +import Hanalyze.Model.LiNGAM.ICA (defaultICALiNGAMConfig, ICALiNGAMFit (..) + , fitICALiNGAM, fitICALiNGAMPure) +import qualified Hanalyze.Model.RandomForest as RF +import Hanalyze.Model.RandomForestClassifier (defaultRFCConfig, fitRFClassifierPure) +import Hanalyze.Model.PLS (fitPLS, defaultPLS, PLSConfig (..)) +import Hanalyze.Model.KNN (predictKNNR, fitKNNR) +import Hanalyze.Stat.Standardize (Standardizer (..), fitStandardizer, applyStandardizer) +import qualified Graphics.Hgg.ThreeD.Spec as P3 +import Graphics.Hgg.ThreeD.Types (Point3 (..)) +import Hanalyze.Model.HBM ( Distribution (Normal, HalfNormal) + , sample, dataNamedX, dataNamedObs, dataNamedIx, (!!!) + , deterministic + , observeColumns, observe, withData + , plate, ModelP ) +import Hanalyze.Data.ColumnSource (ColumnSource (lookupCol)) +import Control.Monad (forM_) +import qualified Data.Text as T +import Hanalyze.MCMC.Core (chainVals) +import qualified DataFrame.Internal.Column as DX +import qualified DataFrame.Internal.DataFrame as DX +-- Phase 106.4: WorkflowSpec (umbrella test) から移行した plot 連携診断テスト用。 +import Data.Maybe (isJust) +import Hanalyze.Fit (designModelHBM, DesignHBMFit (..), ranIntercept) +import Hanalyze.Model.Formula.Frame (ModelFrame (..), VarRole (..)) +import Hanalyze.Plot.Core (MultiVarModel (..)) +import Hanalyze.Plot.ML () -- instance MultiVarModel DesignHBMFit + +-- y = 2x + 1 (完全線形) を入れて係数を検証する。 +xs, ys :: LA.Vector Double +xs = LA.fromList [1, 2, 3, 4, 5] +ys = LA.fromList [3, 5, 7, 9, 11] + +m :: LMModel +m = lmModel xs ys + +allClose :: [Double] -> [Double] -> Bool +allClose a b = length a == length b && and (zipWith (\x y -> abs (x - y) < 1e-9) a b) + +-- Phase 49 A1: 線形 HBM (y ~ Normal(a + b·x, s))。 data は placeholder ([]) で書き、 +-- hbmModel が列名で withData 自動 bind する (PyMC set_data 同型)。 +hbmLinModel :: ModelP () +hbmLinModel = do + x <- dataNamedX "x" [] + y <- dataNamedObs "y" [] + a <- sample "a" (Normal 0 10) + b <- sample "b" (Normal 0 10) + s <- sample "s" (HalfNormal 1) + observeColumns "obs" + [ (Normal (a + b * xi) s, [yi]) | (xi, yi) <- zip x y ] + +posteriorMeanOf :: Text -> [Chain] -> Double +posteriorMeanOf name chains = + let vals = concatMap (chainVals name) chains + in sum vals / fromIntegral (length vals) + +-- Phase 49 A3: epred 用 O1 規約モデル。 学習 likelihood は per-point inline mu のまま、 +-- 平均 μ を deterministic "mu" として 1 点スカラで併存公開する。 epred は grid を +-- withData "x" [xi] で 1 点に差し替えて mu を読む (head x = xi)。 訓練時は x が full data +-- ゆえ head x は安全 (deterministic 値は thunk で構築時に head [] を踏まない)。 +hbmEpredModel :: ModelP () +hbmEpredModel = do + x <- dataNamedX "x" [] + y <- dataNamedObs "y" [] + a <- sample "a" (Normal 0 10) + b <- sample "b" (Normal 0 10) + s <- sample "s" (HalfNormal 1) + _ <- deterministic "mu" (a + b * head x) + observeColumns "obs" + [ (Normal (a + b * xi) s, [yi]) | (xi, yi) <- zip x y ] + +-- plot Phase 24 A3: epred 応答曲面用の 2 予測子 O1 規約モデル。 +hbmEpred2Model :: ModelP () +hbmEpred2Model = do + x1 <- dataNamedX "x1" [] + x2 <- dataNamedX "x2" [] + y <- dataNamedObs "y" [] + a <- sample "a" (Normal 0 10) + b <- sample "b" (Normal 0 10) + c <- sample "c" (Normal 0 10) + s <- sample "s" (HalfNormal 1) + _ <- deterministic "mu" (a + b * head x1 + c * head x2) + observeColumns "obs" + [ (Normal (a + b * xi + c * zi) s, [yi]) + | (xi, (zi, yi)) <- zip x1 (zip x2 y) ] + +-- Phase 60.3: dataNamedIx で群 index を受ける 2 群モデル (factor 自動コード化の検証)。 +-- mus !! g に round が消えるのが新 DSL の眼目。 sort 順 levels なら code 0 = "A"。 +hbmIxModel :: ModelP () +hbmIxModel = do + gs <- dataNamedIx "g" [] + y <- dataNamedObs "y" [] + mu0 <- sample "mu0" (Normal 0 5) + mu1 <- sample "mu1" (Normal 0 5) + s <- sample "s" (HalfNormal 1) + let mus = [mu0, mu1] + observeColumns "obs" [ (Normal (mus !!! g) s, [yi]) | (g, yi) <- zip gs y ] + +-- Phase 49 A5: plate を使う階層モデル (dagOf の DAGPlate 変換検証用)。 group g の +-- 各メンバ eta_j を plate "g" 4 で囲い、 mu/tau は plate 外に置く (8-schools 風)。 +hbmPlateModel :: ModelP () +hbmPlateModel = do + mu <- sample "mu" (Normal 0 5) + tau <- sample "tau" (HalfNormal 5) + _ <- plate "g" 4 $ forM_ [0 .. 3 :: Int] $ \j -> do + eta <- sample ("eta_" <> T.pack (show j)) (Normal 0 1) + observe ("y_" <> T.pack (show j)) (Normal (mu + tau * eta) 1) [realToFrac j] + pure () + +main :: IO () +main = hspec $ do + describe "Phase 46 A4: LMModel + toPlot" $ do + + it "係数 ≈ [1, 2] (intercept, slope) = fitLM 直計算と一致" $ do + let cs = LA.toList (coefficientsV (lmResult m)) + cs `shouldSatisfy` allClose [1, 2] + + it "predictAt (lmResult) X == fitted (PredictiveModel 整合)" $ do + let yhat = LA.toList (LA.flatten (predictAt (lmResult m) (lmDesign m))) + yhat `shouldSatisfy` allClose (LA.toList (fittedV (lmResult m))) + + it "toPlot は band + line の 2 layer を inline encY 付きで返す" $ do + let ls = vsLayers (toPlot m) + length ls `shouldBe` 2 + getFirst (lyKind (ls !! 0)) `shouldBe` Just MBand + getFirst (lyKind (ls !! 1)) `shouldBe` Just MLine + case getLast (lyEncY (ls !! 1)) of + Just (ColNum v) -> V.length v `shouldBe` 5 + _ -> expectationFailure "line encY が inline ColNum でない" + + it "line layer の inline encY ≈ 予測 ŷ = Xβ (回帰線が fit と一致)" $ do + let l = vsLayers (toPlot m) !! 1 -- line layer + yhatFit = LA.toList (fittedV (lmResult m)) -- x 昇順入力ゆえ既に整列 + case getLast (lyEncY l) of + Just (ColNum v) -> V.toList v `shouldSatisfy` allClose yhatFit + _ -> expectationFailure "line encY が inline ColNum でない" + + it "CI band 半幅 (encY2 − encY) は全点 ≥ 0" $ do + let b = head (vsLayers (toPlot m)) -- band layer + case (getLast (lyEncY b), getLast (lyEncY2 b)) of + (Just (ColNum vlo), Just (ColNum vhi)) -> + zipWith (-) (V.toList vhi) (V.toList vlo) `shouldSatisfy` all (>= 0) + _ -> expectationFailure "band encY/encY2 が inline ColNum でない" + + describe "Phase 70.A: df |-> pca / pls (行列入力モデルの高レベル化)" $ do + -- 3 列の df と、 同じ並びの行列。 列名 spec が低レベル行列 fit と一致するか。 + let c1 = [ 5 * sin (fromIntegral i * 0.3) | i <- [1 .. 30 :: Int] ] + c2 = [ 1.2 * cos (fromIntegral i * 0.5) | i <- [1 .. 30 :: Int] ] + c3 = [ 0.3 * sin (fromIntegral i) | i <- [1 .. 30 :: Int] ] + df = [ ("x1", NumData (V.fromList c1)) + , ("x2", NumData (V.fromList c2)) + , ("x3", NumData (V.fromList c3)) ] :: [(Text, ColData)] + xmat = LA.fromColumns (map LA.fromList [c1, c2, c3]) + encY r = case getLast (lyEncY (head (vsLayers (toPlot r)))) of + Just (ColNum v) -> V.toList v + _ -> [] + + it "df |-> pca == 低レベル pca (toPlot 寄与率が一致)" $ do + let resHi = df |-> pca CenterScale Nothing ["x1", "x2", "x3"] + resLo = PCALow.pca CenterScale Nothing xmat + encY resHi `shouldSatisfy` allClose (encY resLo) + + it "df |-> pls == 低レベル fitPLS (回帰係数 plsBeta が一致)" $ do + let y = [ 2 * a + 0.5 * b | (a, b) <- zip c1 c2 ] + df' = df ++ [ ("y", NumData (V.fromList y)) ] :: [(Text, ColData)] + ymat = LA.fromColumns [LA.fromList y] + mHi = df' |-> pls defaultPLS ["x1", "x2"] ["y"] + case fitPLS defaultPLS (LA.fromColumns (map LA.fromList [c1, c2])) ymat of + Right mLo -> concat (LA.toLists (plsCoef mHi)) + `shouldSatisfy` allClose (concat (LA.toLists (plsCoef mLo))) + Left e -> expectationFailure (T.unpack e) + + it "df |-> ccaOf == 低レベル cca (正準相関 ccaCorr が一致)" $ do + let y1 = [ a + 0.1 * b | (a, b) <- zip c1 c2 ] + y2 = [ b - 0.2 * a | (a, b) <- zip c1 c2 ] + df' = df ++ [ ("y1", NumData (V.fromList y1)) + , ("y2", NumData (V.fromList y2)) ] :: [(Text, ColData)] + mHi = df' |-> ccaOf ["x1", "x2"] ["y1", "y2"] + mLo = cca (LA.fromColumns (map LA.fromList [c1, c2])) + (LA.fromColumns (map LA.fromList [y1, y2])) + LA.toList (ccaCorr mHi) `shouldSatisfy` allClose (LA.toList (ccaCorr mLo)) + + it "df |-> lda は DiscriminantFit を当て描画可能 (クラス列の整数化が効く)" $ do + let cls = [ if a > 0 then 1 else 0 | a <- c1 ] :: [Int] -- 2 クラス + df' = df ++ [ ("cls", NumData (V.fromList (map fromIntegral cls))) ] + :: [(Text, ColData)] + m = df' |-> lda ["x1", "x2"] "cls" + length (vsLayers (toPlot m)) `shouldSatisfy` (> 0) + + -- 教師あり ML 分類器/回帰器 (純粋 fit)。 ラベル/応答列を足した df で fit→描画可。 + let yreg = [ 2 * a + 0.5 * b | (a, b) <- zip c1 c2 ] + cls2 = [ fromIntegral (if a > 0 then 1 else 0 :: Int) | a <- c1 ] :: [Double] + dfML = df ++ [ ("y", NumData (V.fromList yreg)) + , ("cls", NumData (V.fromList cls2)) ] :: [(Text, ColData)] + it "df |-> gbmReg / decisionTree / knnCls / naiveBayes が当てて描画可 (toPlot レイヤ > 0)" $ do + let mGB = dfML |-> gbmReg defaultGBM ["x1", "x2"] "y" + mDT = dfML |-> decisionTree defaultDecisionTree ["x1", "x2"] "cls" + mKN = dfML |-> knnCls 3 ["x1", "x2"] "cls" + mNB = dfML |-> naiveBayes ["x1", "x2"] "cls" + length (vsLayers (toPlot mGB)) `shouldSatisfy` (> 0) + length (vsLayers (toPlot mDT)) `shouldSatisfy` (> 0) + length (vsLayers (toPlot mKN)) `shouldSatisfy` (> 0) + length (vsLayers (toPlot mNB)) `shouldSatisfy` (> 0) + it "df |-> gbmCls / knnReg は error なく当たる (fitEither が Right)" $ do + let mGBC = dfML |-> gbmCls defaultGBM ["x1", "x2"] "cls" + mKNR = dfML |-> knnReg 3 ["x1", "x2"] "y" + _ <- evaluate (length (vsLayers (toPlot mGBC))) -- GBClassifier は Plottable + _ <- evaluate mKNR -- KNNRegressor は WHNF へ強制 + pure () + + describe "Phase 76: mark 拡充 (決定領域塗り / クラスタ囲み / dendrogram) の primitive" $ do + let isAnnLine a = case a of AnnLine{} -> True; _ -> False + -- Phase 48: dendrogram の U 字リンクは custom mark の焼き込み payload に載る。 + -- 先頭 layer の lyCustom (Last CustomMark) → cmOptions (JSON) を DendroPayload へ + -- decode し、 その線分列 (dpSegments) を取り出す。 + dendroSegs vs = case vsLayers vs of + (ly:_) -> case getLast (lyCustom ly) of + Just cm -> case fromJSON (cmOptions cm) of + Success p -> dpSegments p + _ -> [] + Nothing -> [] + _ -> [] + -- 2 群 (各 3 点・非共線の三角形) の決定的データ + KMeansResult。 + hdf = [ ("x", NumData (V.fromList [0, 1, 0.5, 5, 6, 5.5])) + , ("y", NumData (V.fromList [0, 0, 1.0, 5, 5, 6.0])) ] :: [(Text, ColData)] + kres = KMeansResult + { kmrCentroids = LA.fromLists [[0.5, 0.33], [5.5, 5.33]] + , kmrLabels = [0, 0, 0, 1, 1, 1] + , kmrInertia = 0, kmrIters = 1, kmrConverged = True } + + it "clusterHullOf: 各群の凸包 = 三角形 (3 点) → 群ごと 3 辺・全て AnnLine・layer 無し" $ do + let vs = clusterHullOf hdf kres "x" "y" + vsLayers vs `shouldBe` [] + length (vsAnnotations vs) `shouldBe` 6 -- 2 群 × 3 辺 + all isAnnLine (vsAnnotations vs) `shouldBe` True + + it "clusterHullOf: 列が無ければ空" $ + clusterHullOf hdf kres "nope" "y" `shouldBe` mempty + + it "clusterEllipseOf: 群ごと 64 辺の楕円折れ線 + 不可視 anchor layer 1" $ do + let vs = clusterEllipseOf hdf kres "x" "y" + length (vsAnnotations vs) `shouldBe` 128 -- 2 群 × 64 辺 + all isAnnLine (vsAnnotations vs) `shouldBe` True + length (vsLayers vs) `shouldBe` 1 -- 軸 auto-fit 用の alpha=0 散布 + + it "dendrogramOf: U 字リンク 3*(n-1) 本 (custom mark 焼き込み) + y 軸線 1 本 (AnnLine)" $ do + let xm = LA.fromLists [[0,0],[0.2,0.1],[5,5],[5.1,4.9]] -- n=4・2 群 + hc = fitHierarchical Ward xm + vs = dendrogramOf hc + n = 4 :: Int + -- Phase 48: U 字リンクは 1 layer (MCustom) に焼き込み・segments = 3*(n-1) 本。 + length (vsLayers vs) `shouldBe` 1 + getFirst (lyKind (head (vsLayers vs))) `shouldBe` Just MCustom + length (dendroSegs vs) `shouldBe` 3 * (n - 1) + -- annotation は y 軸線 1 本のみ。 + length (vsAnnotations vs) `shouldBe` 1 + all isAnnLine (vsAnnotations vs) `shouldBe` True + + it "dendrogramOf': 色閾値で葉クラスタが色分け (閾値超は既定線色・複数色出る)" $ do + let xm = LA.fromLists [[0,0],[0.2,0.1],[5,5],[5.1,4.9]] + hc = fitHierarchical Ward xm + hs = hcHeights hc + thr = (hs !! (length hs - 2) + hs !! (length hs - 1)) / 2 + vs = dendrogramOf' defaultDendroOpts { doColorThreshold = Just thr } hc + cols = map segColor (dendroSegs vs) -- 焼き込み線分の色 + any (/= head cols) cols `shouldBe` True -- 群色 + 閾値超色 = 2 色以上 + + -- Phase 76.D: PDP を HBM 同型の Plottable 中間型 (toPlot) に。 pdpOf と同一 primitive。 + it "toPlot (pdp …) == pdpOf (同一 layer 数)" $ do + let pdf = [ ("a", NumData (V.fromList [0,1,2,3,4,5,6,7])) + , ("b", NumData (V.fromList [1,0,1,0,1,0,1,0])) ] :: [(Text, ColData)] + xm = LA.fromColumns [ LA.fromList [0,1,2,3,4,5,6,7], LA.fromList [1,0,1,0,1,0,1,0] ] + yv = VU.fromList [1,2,3,4,5,6,7,8 :: Double] + rf = fitRFVPure defaultRandomForest xm yv 7 + viaView = toPlot (pdp rf pdf ["a","b"] "a") + viaDirect = pdpOf rf pdf ["a","b"] "a" + length (vsLayers viaView) `shouldBe` length (vsLayers viaDirect) + length (vsLayers viaView) `shouldSatisfy` (> 0) + + it "toPlot (pdpIce …) は ICE 曲線 + 平均で pdp より layer が多い" $ do + let pdf = [ ("a", NumData (V.fromList [0,1,2,3,4,5,6,7])) + , ("b", NumData (V.fromList [1,0,1,0,1,0,1,0])) ] :: [(Text, ColData)] + xm = LA.fromColumns [ LA.fromList [0,1,2,3,4,5,6,7], LA.fromList [1,0,1,0,1,0,1,0] ] + yv = VU.fromList [1,2,3,4,5,6,7,8 :: Double] + rf = fitRFVPure defaultRandomForest xm yv 7 + nP = length (vsLayers (toPlot (pdp rf pdf ["a","b"] "a"))) + nI = length (vsLayers (toPlot (pdpIce rf pdf ["a","b"] "a"))) + nI `shouldSatisfy` (> nP) + + describe "Phase 70.A: KMeans / RandomForest の seed 純粋化 (df |-> + 決定性)" $ do + -- 2 クラスタ (中心 (1,1) と (5,5)・各 20 点) の決定的データ。 + let pts = [ (1 + 0.1 * sin (fromIntegral i), 1 + 0.1 * cos (fromIntegral i)) + | i <- [1 .. 20 :: Int] ] + ++ [ (5 + 0.1 * sin (fromIntegral i), 5 + 0.1 * cos (fromIntegral i)) + | i <- [1 .. 20 :: Int] ] + as = map fst pts + bs = map snd pts + xmatK = LA.fromColumns [LA.fromList as, LA.fromList bs] + dfK = [ ("a", NumData (V.fromList as)) + , ("b", NumData (V.fromList bs)) ] :: [(Text, ColData)] + cfgK = defaultKMeans 2 + + it "kMeansPure は決定的 (同 seed → inertia/centroids/labels がビット一致)" $ do + let r1 = kMeansPure cfgK xmatK 42 + r2 = kMeansPure cfgK xmatK 42 + kmrInertia r1 `shouldBe` kmrInertia r2 + LA.toList (LA.flatten (kmrCentroids r1)) + `shouldBe` LA.toList (LA.flatten (kmrCentroids r2)) + kmrLabels r1 `shouldBe` kmrLabels r2 + + it "kMeansPure seed==42 は IO kMeans(initialize 42) とビット一致 (ST/IO 同コード)" $ do + gen <- MWC.initialize (V.singleton 42) + rIO <- kMeans cfgK xmatK gen + let rST = kMeansPure cfgK xmatK 42 + kmrInertia rIO `shouldBe` kmrInertia rST + kmrLabels rIO `shouldBe` kmrLabels rST + LA.toList (LA.flatten (kmrCentroids rIO)) + `shouldBe` LA.toList (LA.flatten (kmrCentroids rST)) + + it "df |-> kmeans == kMeansPure (列名経路と行列経路が一致・描画可)" $ do + let r = dfK |-> kmeans cfgK 42 ["a", "b"] + kmrInertia r `shouldBe` kmrInertia (kMeansPure cfgK xmatK 42) + length (vsLayers (toPlot r)) `shouldSatisfy` (> 0) + + -- RandomForest 回帰: y = 2a + 3b。 + let yR = [ 2 * a + 3 * b | (a, b) <- pts ] + yvR = VU.fromList yR + dfR = dfK ++ [ ("y", NumData (V.fromList yR)) ] :: [(Text, ColData)] + cfgR = defaultRandomForest + + it "fitRFVPure は決定的 (同 seed → importance/予測がビット一致)" $ do + let f1 = fitRFVPure cfgR xmatK yvR 7 + f2 = fitRFVPure cfgR xmatK yvR 7 + V.toList (rfImportance f1) `shouldBe` V.toList (rfImportance f2) + predictRF f1 [1, 1] `shouldBe` predictRF f2 [1, 1] + + it "df |-> randomForestReg == fitRFVPure (同 seed・特徴重要度バー描画可)" $ do + let r = dfR |-> randomForestReg cfgR 7 ["a", "b"] "y" + V.toList (rfImportance r) + `shouldBe` V.toList (rfImportance (fitRFVPure cfgR xmatK yvR 7)) + -- toPlot は 2 パネル (impurity + permutation) の subplots (75.24)。 + length (vsSubplots (toPlot r)) `shouldBe` 2 + + -- RandomForest 分類 (75.24d): 2 クラスタ → クラス 0/1。df|-> で実列名・決定的。 + let clsC = replicate 20 0 ++ replicate 20 1 :: [Int] + dfC = dfK ++ [ ("cls", NumData (V.fromList (map fromIntegral clsC))) ] :: [(Text, ColData)] + + it "df |-> randomForestCls == fitRFClassifierPure (同 seed・実列名・2 パネル)" $ do + let r = dfC |-> randomForestCls defaultRFCConfig 7 ["a", "b"] "cls" + ref = fitRFClassifierPure defaultRFCConfig xmatK (VU.fromList clsC) 7 + -- 決定性: gini/permutation がビット一致 (df|-> = 行列経路) + LA.toList (rfcGiniImportance r) `shouldBe` LA.toList (rfcGiniImportance ref) + LA.toList (rfcImportance r) `shouldBe` LA.toList (rfcImportance ref) + -- df|-> は実列名を載せる (行列経路の f1.. でなく) + rfcFeatureNames r `shouldBe` ["a", "b"] + length (vsSubplots (toPlot r)) `shouldBe` 2 + + describe "Phase 70.D: 重回帰 統一 API (lmMulti/glmMulti/robustMulti + coefSummary)" $ do + -- 固定データ (12 行・x1,x2,x3)。 末尾 y=40 が外れ値 (ロバストの効きを見る)。 + -- 期待値は statsmodels 0.14.6 で生成 (experiments/phase-70d-coefsummary/ref_statsmodels.py)。 + let x1 = [1,2,3,4,5,6,7,8,9,10,11,12] :: [Double] + x2 = [2,1,4,3,6,5,8,7,10,9,12,11] :: [Double] + x3 = [0.5,1.5,1,2.5,2,3.5,3,4.5,4,5.5,5,6.5] :: [Double] + yv = [3.1,4,7.2,8.1,11,12.3,15.1,16,19.2,20.1,23,40] :: [Double] + dfM = [ ("x1", NumData (V.fromList x1)), ("x2", NumData (V.fromList x2)) + , ("x3", NumData (V.fromList x3)), ("y", NumData (V.fromList yv)) ] + :: [(Text, ColData)] + near a b = abs (a - b) < 1e-6 + nearV xs ys = and (zipWith near xs ys) + -- GLM は IRLS 収束点が statsmodels とごく僅か異なり SE が ~1e-5 ずれる + -- (β は 1e-9 一致。 独立実装間として 5 桁一致は良好)。 GLM のみ緩い許容。 + nearV4 xs ys = and (zipWith (\a b -> abs (a - b) < 1e-4) xs ys) + rowsOf m = ( map crEstimate m, map crStdErr m, map crStat m + , map crPValue m, concatMap (\r -> [fst (crCI95 r), snd (crCI95 r)]) m ) + + it "lmMulti coefSummary (t) == statsmodels OLS .summary()" $ do + let m = dfM |-> lmMulti ["x1", "x2", "x3"] "y" :: MultiLMModel + cs = coefSummary m + (est, se, tv, pv, ci) = rowsOf cs + -- 名前 = (Intercept) + 列名 + map crTerm cs `shouldBe` ["(Intercept)", "x1", "x2", "x3"] + nearV est [-3.121363636363598,-5.105000000000107,3.5004545454546294,8.650909090909133] + `shouldBe` True + nearV se [3.2114157547937565,10.36170010985987,5.21966108203359,10.83050421206717] + `shouldBe` True + nearV tv [-0.97195874800834,-0.49267976740055897,0.6706287037492568,0.798754048890026] + `shouldBe` True + nearV pv [0.35953762982419396,0.6354752397806847,0.5213433571725514,0.4474952370377395] + `shouldBe` True + nearV ci [-10.526901646229312,4.284174373502117,-28.999123299312696,18.789123299312482 + ,-8.536105493187584,15.537014584096845,-16.3242784066141,33.62609658843236] + `shouldBe` True + + it "robustMulti coefSummary (z, Huber 1.345) == statsmodels RLM (cov=H1)" $ do + let m = dfM |-> rlmMulti (Huber 1.345) ["x1", "x2", "x3"] "y" :: MultiRobustModel + cs = coefSummary m + (est, se, zv, pv, ci) = rowsOf cs + map crTerm cs `shouldBe` ["(Intercept)", "x1", "x2", "x3"] + nearV est [0.5497573872869811,1.4082792355091573,0.5398730747685647,0.12443445533346953] + `shouldBe` True + nearV se [0.1120721724104495,0.3616032086297613,0.18215603377936052,0.3779635612533277] + `shouldBe` True + nearV zv [4.905387086399712,3.8945429739011743,2.9637946301712677,0.3292234175189923] + `shouldBe` True + nearV pv [9.324326853300844e-7,9.838404940536295e-5,0.0030387101129149083,0.7419868240281127] + `shouldBe` True + nearV ci [0.33009996569333655,0.7694148088806256,0.699549969900702,2.1170085011176125 + ,0.1828538089943566,0.8968923405427729,-0.6163605121915514,0.8652294228584905] + `shouldBe` True + + -- GLM は scale=1 の族 (Poisson/Binomial) が本来用途。 z 経路 (正規) で statsmodels + -- GLM と一致する (Gaussian は分散スケール推定が入り別経路 → 連続応答は lmMulti を使う)。 + it "glmMulti Poisson/log coefSummary (z) == statsmodels GLM Poisson" $ do + let yc = [1,2,2,4,5,7,10,14,19,26,35,48] :: [Double] + dfP = [ ("x1", NumData (V.fromList x1)), ("x2", NumData (V.fromList x2)) + , ("x3", NumData (V.fromList x3)), ("yc", NumData (V.fromList yc)) ] + :: [(Text, ColData)] + cs = coefSummary (dfP |-> glmMulti Poisson Log ["x1", "x2", "x3"] "yc") + (est, se, zv, pv, ci) = rowsOf cs + nearV est [0.03218678346706216,1.0213360876134985,-0.35313387540543173,-0.6945102404086394] + `shouldBe` True + nearV4 se [0.31691453822410903,2.071111308008677,1.0400997867517308,2.081045612659335] + `shouldBe` True + nearV4 zv [0.1015629754552345,0.4931343301850291,-0.3395192268121519,-0.33373138780996536] + `shouldBe` True + nearV4 pv [0.9191035687400753,0.6219176751774244,0.7342186154504002,0.7385822621359937] + `shouldBe` True + nearV4 ci [-0.5889542976293338,0.6533278645634581,-3.037967484057151,5.080639659284148 + ,-2.3916919977666145,1.6854242469557508,-4.773284691406028,3.3842642105887486] + `shouldBe` True + + it "lmMulti は effect plot (statModelMulti + along) が即使える" $ do + let m = dfM |-> lmMulti ["x1", "x2", "x3"] "y" :: MultiLMModel + spec = statModelMulti m (along "x1") <> holdAt Mean + length (vsLayers (toPlot spec)) `shouldSatisfy` (> 0) + + it "robustMulti も effect plot (band + line) が即使える" $ do + let m = dfM |-> rlmMulti (Huber 1.345) ["x1", "x2", "x3"] "y" :: MultiRobustModel + spec = statModelMulti m (along "x1") <> holdAt Mean + length (vsLayers (toPlot spec)) `shouldSatisfy` (>= 2) + + describe "Phase 46 A8: GLMModel + toPlot (非対称 μ-CI 帯)" $ do + -- Poisson 回帰 (log link)。 count が単調増加するデータ。 + let gxs = LA.fromList [1, 2, 3, 4, 5, 6] + gys = LA.fromList [1, 2, 4, 7, 12, 20] + gm = glmModel Poisson Log gxs gys + layersOf = vsLayers (toPlot gm) + bandL = head [ l | l <- layersOf, getFirst (lyKind l) == Just MBand ] + lineL = head [ l | l <- layersOf, getFirst (lyKind l) == Just MLine ] + numOf f l = case getLast (f l) of + Just (ColNum v) -> V.toList v + _ -> error "encoding が inline ColNum でない" + + it "toPlot は band (MBand) + μ 線 (MLine) の 2 layer を返す" $ do + length layersOf `shouldBe` 2 + map (getFirst . lyKind) layersOf `shouldMatchList` + [Just MBand, Just MLine] + + it "band の x は昇順、 点数は n=6" $ do + let xb = numOf lyEncX bandL + length xb `shouldBe` 6 + xb `shouldSatisfy` \v -> and (zipWith (<=) v (drop 1 v)) + + it "band 上境界 (encY2) ≥ 下境界 (encY) = 帯が潰れない" $ do + let lo = numOf lyEncY bandL + hi = numOf lyEncY2 bandL + and (zipWith (<=) lo hi) `shouldBe` True + + it "μ 線 (MLine encY) は band の [lo, hi] 内 = 中心が帯内" $ do + let lo = numOf lyEncY bandL + hi = numOf lyEncY2 bandL + mu = numOf lyEncY lineL + and (zipWith3 (\l u c -> l - 1e-9 <= c && c <= u + 1e-9) lo hi mu) + `shouldBe` True + + it "μ 線は fitted μ̂ と一致 (= predictGlmMuWithCI が fit と整合)" $ do + let mu = numOf lyEncY lineL + mu `shouldSatisfy` allClose (LA.toList (fittedV (glmResult gm))) + + describe "Phase 46 A6: GPResult + toPlot (protocol 汎用性)" $ do + -- 予測 grid をわざと降順にして、 toPlot がソートして折れ線を作ることを検証。 + -- 値は手組み (GP 数値計算に非依存・決定的): mean = grid, band 半幅 = 0.5。 + let gres = GPResult + { gpTestX = [3, 1, 2] + , gpMean = [30, 10, 20] + , gpVar = [0.25, 0.25, 0.25] + , gpLower = [29.5, 9.5, 19.5] + , gpUpper = [30.5, 10.5, 20.5] + } + + it "toPlot は band + line の 2 layer を返す (FitResult 系と別型でも成立)" $ do + let ls = vsLayers (toPlot gres) + length ls `shouldBe` 2 + getFirst (lyKind (ls !! 0)) `shouldBe` Just MBand + getFirst (lyKind (ls !! 1)) `shouldBe` Just MLine + + it "line の encX/encY は x 昇順にソートされる (= 折れ線が交差しない)" $ do + let l = vsLayers (toPlot gres) !! 1 -- line layer + case (getLast (lyEncX l), getLast (lyEncY l)) of + (Just (ColNum vx), Just (ColNum vy)) -> do + V.toList vx `shouldSatisfy` allClose [1, 2, 3] + V.toList vy `shouldSatisfy` allClose [10, 20, 30] + _ -> expectationFailure "encX/encY が inline ColNum でない" + + it "band は gpMean ± (gpUpper − gpMean) = [low, high] を encY/encY2 に持つ" $ do + let b = head (vsLayers (toPlot gres)) -- band layer + case (getLast (lyEncY b), getLast (lyEncY2 b)) of + (Just (ColNum vlo), Just (ColNum vhi)) -> do + V.toList vlo `shouldSatisfy` allClose [9.5, 19.5, 29.5] + V.toList vhi `shouldSatisfy` allClose [10.5, 20.5, 30.5] + _ -> expectationFailure "band encY/encY2 が inline ColNum でない" + + describe "Phase 46 A9: SplineModel + toPlot (平滑曲線 + 対称 CI band)" $ do + -- なめらかな非線形データ。 x は意図的に降順で渡し、 toPlot が昇順整列することも確認。 + let sxs = LA.fromList [6, 5, 4, 3, 2, 1, 0] + sys = LA.fromList [36, 25, 16, 9, 4, 1, 0] -- y = x² + sm = splineModel (BSpline 3) [0, 2, 4, 6] sxs sys + sBand = head (vsLayers (toPlot sm)) -- band layer (CI) + sLine = vsLayers (toPlot sm) !! 1 -- line layer (ŷ 曲線) + numBand f = case getLast (f sBand) of + Just (ColNum v) -> V.toList v + _ -> error "band encoding が inline ColNum でない" + numLine f = case getLast (f sLine) of + Just (ColNum v) -> V.toList v + _ -> error "line encoding が inline ColNum でない" + + it "toPlot は band + line の 2 layer を返す (曲線 + band)" $ do + let ls = vsLayers (toPlot sm) + length ls `shouldBe` 2 + getFirst (lyKind sBand) `shouldBe` Just MBand + getFirst (lyKind sLine) `shouldBe` Just MLine + + it "encX は x 昇順にソートされる (= 平滑曲線が交差しない)" $ do + let xb = numLine lyEncX + and (zipWith (<=) xb (drop 1 xb)) `shouldBe` True + + it "line encY (ŷ) は fitted と一致 (= 基底空間 fit と整合)" $ do + -- fittedV は入力順 (降順)、 encY は昇順整列ゆえ reverse して突合。 + let yhatFit = reverse (LA.toList (fittedV (sfResult (splFit sm)))) + numLine lyEncY `shouldSatisfy` allClose yhatFit + + it "CI band 半幅 (encY2 − encY) は全点 ≥ 0 (基底空間 Wald CI)" $ do + zipWith (-) (numBand lyEncY2) (numBand lyEncY) `shouldSatisfy` all (>= 0) + + it "Phase 70.G: svGridPI (PI) ⊃ svGrid (CI) — 基底空間 closed-form PI" $ do + let gx = [1.0, 3.0, 5.0] + case (svGrid sm 0.95 gx, svGridPI sm 0.95 gx) of + ((_, Just (clo, chi)), Just (plo, phi)) -> do + and (zipWith (<=) plo clo) `shouldBe` True -- PI 下限 ≤ CI 下限 + and (zipWith (>=) phi chi) `shouldBe` True -- PI 上限 ≥ CI 上限 + _ -> expectationFailure "spline の CI/PI が出ない" + + it "Phase 70.G: bandMode BandCIPI で CI+PI 入れ子 (MBand 2 + MLine 1)" $ do + let ls = vsLayers (toPlot (statModel sm <> grid 10 <> bandMode BandCIPI)) + map (getFirst . lyKind) ls `shouldMatchList` [Just MBand, Just MBand, Just MLine] + + describe "Phase 70.6 G: GAMModel CI 帯 (mgcv 流 Bayesian)" $ do + -- 非線形データ。 GAM は CI 実装後、 grid 経路で band + line を出す。 + let gmxs = LA.fromList [0, 1, 2, 3, 4, 5, 6, 7, 8] + gmys = LA.fromList [ sin x + 0.1 * x | x <- LA.toList gmxs ] + gmm = gamModel 3 5 0.0 gmxs gmys + + it "toPlot は band(MBand) + line(MLine) の 2 layer を返す" $ do + let ls = vsLayers (toPlot gmm) + length ls `shouldBe` 2 + getFirst (lyKind (ls !! 0)) `shouldBe` Just MBand + getFirst (lyKind (ls !! 1)) `shouldBe` Just MLine + + it "svGrid は Just の CI 帯を返し lo ≤ μ ≤ hi (帯幅 > 0)" $ do + let (mu, mb) = svGrid gmm 0.95 [1.0, 4.0, 7.0] + length mu `shouldBe` 3 + case mb of + Just (lo, hi) -> do + and (zipWith (<=) lo mu) `shouldBe` True + and (zipWith (<=) mu hi) `shouldBe` True + and (zipWith (\l h -> h - l > 0) lo hi) `shouldBe` True + Nothing -> expectationFailure "CI 帯 (Just) を期待" + + it "★厳密検証: GAM(PolyB 1, λ=0) の CI 帯は LM と一致 (基底が {1,x} と同一スパン)" $ do + -- y = 2x + 1 + ノイズ。 PolyB 1・λ=0 の列空間は {1, x} ＝ OLS と同一ゆえ、 + -- 予測も予測分散も (したがって CI 帯も) LMModel と厳密一致するはず。 + let xsC = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Double] + ysC = [3.1, 4.8, 7.2, 8.9, 11.3, 12.7, 15.1, 16.8, 19.2, 20.9] + dfC = [ ("x", xsC), ("y", ysC) ] :: [(Text, [Double])] + gmP = dfC |-> gam (GAMConfig (PolyB 1) (FixedL 0)) "x" "y" -- GAMModelN + lmM = lmModel (LA.fromList xsC) (LA.fromList ysC) -- LMModel (OLS) + gridC = [2.0, 4.5, 6.0, 8.5] + (gmu, Just (glo, ghi)) = svGrid gmP 0.95 gridC + (lmu, Just (llo, lhi)) = svGrid lmM 0.95 gridC + gmu `shouldSatisfy` allClose lmu + glo `shouldSatisfy` allClose llo + ghi `shouldSatisfy` allClose lhi + + describe "Phase 70.6: GAM 基底一般化 + GCV + gam/gamMulti (df|->)" $ do + -- 非線形 y = sin x + 0.1 x を x∈[0,8] で 21 点。 + let gx70 = [ 0.4 * fromIntegral i | i <- [0 .. 20 :: Int] ] :: [Double] + gy70 = [ sin x + 0.1 * x | x <- gx70 ] + xv70 = V.fromList gx70 + yv70 = V.fromList gy70 + df70 = [ ("x", gx70), ("y", gy70) ] :: [(Text, [Double])] + + it "F1: fitGAMWith [BSplineB] が fitGAM とビット一致 (後方互換)" $ do + let a = fitGAMWith [BSplineB 3 5] 0.0 [xv70] yv70 + b = fitGAM 3 5 0.0 [xv70] yv70 + LA.toList (gamYHat a) `shouldSatisfy` allClose (LA.toList (gamYHat b)) + + it "F1: 自然3次基底で非線形を高 R² でフィット" $ do + gamR2 (fitGAMWith [NaturalCubicB 6] 0.0 [xv70] yv70) `shouldSatisfy` (> 0.9) + + it "F1: Fourier 基底で非線形をフィット (周期=レンジゆえ sin の周期と不一致で 0.8 台)" $ do + gamR2 (fitGAMWith [FourierB 4] 0.0 [xv70] yv70) `shouldSatisfy` (> 0.8) + + it "F1: RBF 基底で非線形を高 R² でフィット" $ do + gamR2 (fitGAMWith [RBFB 8 1.0] 0.0 [xv70] yv70) `shouldSatisfy` (> 0.9) + + it "F1: 多項基底でも非線形をある程度フィット (R² > 0.7)" $ do + gamR2 (fitGAMWith [PolyB 5] 0.0 [xv70] yv70) `shouldSatisfy` (> 0.7) + + it "F2: GCV が有限な λ を選び高 R² (gam 経由)" $ do + let m = df70 |-> gam (GAMConfig (BSplineB 3 8) GCV) "x" "y" + f = gamNFit m + gamLambda f `shouldSatisfy` (\l -> not (isNaN l) && not (isInfinite l) && l >= 0) + gamEdf f `shouldSatisfy` (< 21) -- edf < n + gamR2 f `shouldSatisfy` (> 0.95) + + it "F3: gam の toPlot は band(MBand) + line(MLine) の 2 layer を返す (CI 実装後)" $ do + let m = df70 |-> gam defaultGAMConfig "x" "y" + ls = vsLayers (toPlot m) + length ls `shouldBe` 2 + getFirst (lyKind (ls !! 0)) `shouldBe` Just MBand + getFirst (lyKind (ls !! 1)) `shouldBe` Just MLine + + it "F3: gam の svGrid が grid 点数分の有限値 + CI 帯 (Just) を返す" $ do + let m = df70 |-> gam defaultGAMConfig "x" "y" + (mu, b) = svGrid m 0.95 [1.0, 4.0, 7.0] + length mu `shouldBe` 3 + all (\v -> not (isNaN v)) mu `shouldBe` True + case b of + Just (lo, hi) -> and (zipWith3 (\l u h -> l <= u && u <= h) lo mu hi) `shouldBe` True + Nothing -> expectationFailure "CI 帯 (Just) を期待" + + it "F3: 多予測子は第1予測子を軸に・他を訓練平均で固定して評価できる" $ do + let dfMV = [ ("x1", gx70) + , ("x2", reverse gx70) + , ("y", zipWith (\a c -> sin a + 0.05 * c) gx70 (reverse gx70)) ] + :: [(Text, [Double])] + m = dfMV |-> gamMulti (GAMConfig (BSplineB 3 5) (FixedL 0.1)) ["x1", "x2"] "y" + (lo, hi) = svRange m + (mu, _) = svGrid m 0.95 [lo, (lo + hi) / 2, hi] + gamNNames m `shouldBe` ["x1", "x2"] + length mu `shouldBe` 3 + all (\v -> not (isNaN v)) mu `shouldBe` True + + describe "Phase 70.5 項目 E (E1): GP/KRR/RFF 統合 (gp + GPConfig・df|->)" $ do + -- 非線形 y = sin x を x∈[0,6] で 21 点 (帯/予測の数値検証用)。 + let ex = [ 0.3 * fromIntegral i | i <- [0 .. 20 :: Int] ] :: [Double] + ey = map sin ex + dfE = [ ("x", ex), ("y", ey) ] :: [(Text, [Double])] + q = [1.0, 3.0, 5.0] + truth = map sin q + -- 予測 RMSE (μ̂ vs 真値)。 + rmse cfg = + let (mu, _) = gprPredict (dfE |-> gp cfg "x" "y") q + in sqrt (sum (zipWith (\a b -> (a - b) ^ (2 :: Int)) mu truth) / 3) + + it "E1: defaultGP (厳密 GP・周辺尤度) が sin を高精度予測 (RMSE < 0.1)" $ do + rmse defaultGP `shouldSatisfy` (< 0.1) + + it "E1: Gp 象限は事後分散 (Just) を返す・Ridge 象限は帯なし (Nothing)" $ do + let (_, vGp) = gprPredict (dfE |-> gp (GPConfig RBF Gp AutoMarginalLik) "x" "y") q + (_, vRidge) = gprPredict (dfE |-> gp (GPConfig RBF Krr AutoMarginalLik) "x" "y") q + vRidge `shouldBe` Nothing + case vGp of + Just vs -> do length vs `shouldBe` 3 + all (\v -> not (isNaN v) && v >= 0) vs `shouldBe` True + Nothing -> expectationFailure "Gp 象限は Just 分散を返すべき" + + it "E1: KRR (Ridge) の μ̂ ≡ GP 事後平均 (同ハイパラでビット一致)" $ do + let p = defaultGPParams { gpLengthScale = 1.0, gpSignalVar = 1.0, gpNoiseVar = 0.05 } + cfgG = GPConfig RBF Gp (FixedHyper p) + cfgR = GPConfig RBF Krr (FixedHyper p) + (muG, _) = gprPredict (dfE |-> gp cfgG "x" "y") q + (muR, _) = gprPredict (dfE |-> gp cfgR "x" "y") q + muR `shouldBe` muG -- KRR は GP の mean のみ (帯を捨てるだけ) + + it "E1: RFF 近似 (GpRff) が厳密 GP に概ね一致 (RMSE < 0.15)" $ do + rmse (GPConfig RBF (GpRff 500 12345) AutoMarginalLik) `shouldSatisfy` (< 0.15) + + it "E1: RFF seed 純粋化 = 同 seed で完全再現・別 seed で別結果" $ do + let pull s = fst (gprPredict (dfE |-> gp (GPConfig RBF (GpRff 300 s) AutoMarginalLik) "x" "y") q) + pull 7 `shouldBe` pull 7 + pull 7 `shouldNotBe` pull 99 + + it "E1: AutoCV (Gram-LOOCV) が有限な予測を返し高精度 (RMSE < 0.12)" $ do + let (mu, _) = gprPredict (dfE |-> gp (GPConfig RBF Gp AutoCV) "x" "y") q + all (\v -> not (isNaN v) && not (isInfinite v)) mu `shouldBe` True + rmse (GPConfig RBF Gp AutoCV) `shouldSatisfy` (< 0.12) + + it "E1: Periodic + RFF 近似指定 → 厳密象限へフォールバック (gprMethod = Gp)" $ do + let m = dfE |-> gp (GPConfig Periodic (GpRff 200 7) AutoMarginalLik) "x" "y" + gprMethod m `shouldBe` Gp + let (mu, v) = gprPredict m q + all (\val -> not (isNaN val)) mu `shouldBe` True + v `shouldSatisfy` (/= Nothing) -- Gp へ落ちたので分布あり + + it "E1: Matern52 厳密 GP も sin を高精度予測" $ do + rmse (GPConfig Matern52 Gp AutoMarginalLik) `shouldSatisfy` (< 0.1) + + -- E2: SingleVarModel + Plottable + it "E2: Gp 象限の svGrid は credible 帯 (Just) を返す" $ do + let m = dfE |-> gp defaultGP "x" "y" + (mu, b) = svGrid m 0.95 [1.0, 3.0, 5.0] + length mu `shouldBe` 3 + case b of + Just (los, his) -> do + length los `shouldBe` 3 + and (zipWith3 (\l u h -> l <= u && u <= h) los mu his) `shouldBe` True + Nothing -> expectationFailure "Gp 象限は帯を返すべき" + + it "E2: Ridge 象限の svGrid は帯なし (Nothing)" $ do + let m = dfE |-> gp (GPConfig RBF Krr AutoMarginalLik) "x" "y" + (_, b) = svGrid m 0.95 [1.0, 3.0, 5.0] + b `shouldBe` Nothing + + it "E2: Gp の toPlot は band + line の 2 layer・Ridge は line のみ 1 layer" $ do + let mGp = dfE |-> gp defaultGP "x" "y" + mRi = dfE |-> gp (GPConfig RBF Krr AutoMarginalLik) "x" "y" + length (vsLayers (toPlot mGp)) `shouldBe` 2 + length (vsLayers (toPlot mRi)) `shouldBe` 1 + getFirst (lyKind (last (vsLayers (toPlot mGp)))) `shouldBe` Just MLine + + it "E2: svGridPI (事後予測分散) は CI より広い帯 (Gp 象限)" $ do + let m = dfE |-> gp defaultGP "x" "y" + (_, mbCI) = svGrid m 0.95 [1.0, 3.0, 5.0] + mbPI = svGridPI m 0.95 [1.0, 3.0, 5.0] + case (mbCI, mbPI) of + (Just (lci, hci), Just (lpi, hpi)) -> + and (zipWith (\(lc, hc) (lp, hp) -> (hp - lp) >= (hc - lc)) + (zip lci hci) (zip lpi hpi)) + `shouldBe` True + _ -> expectationFailure "Gp 象限は CI/PI 両帯を返すべき" + + describe "Phase 70.5 項目 E (E3): gpMulti 多変量 (df|->)" $ do + -- y = sin x1 + 0.5 x2 を 2 予測子で。 第1予測子を軸に偏依存曲線を評価。 + let ex1 = [ 0.4 * fromIntegral i | i <- [0 .. 20 :: Int] ] :: [Double] + ex2 = [ 0.2 * fromIntegral i | i <- [0 .. 20 :: Int] ] :: [Double] + ey3 = zipWith (\a c -> sin a + 0.5 * c) ex1 ex2 + dfM = [ ("x1", ex1), ("x2", ex2), ("y", ey3) ] :: [(Text, [Double])] + + it "E3: gpMulti Gp は予測子名を保持し svGrid が credible 帯を返す" $ do + let m = dfM |-> gpMulti defaultGP ["x1", "x2"] "y" + (lo, hi) = svRange m + (mu, b) = svGrid m 0.95 [lo, (lo + hi) / 2, hi] + gprnNames m `shouldBe` ["x1", "x2"] + length mu `shouldBe` 3 + all (\v -> not (isNaN v)) mu `shouldBe` True + b `shouldSatisfy` (/= Nothing) + + it "E3: gpMulti Ridge は帯なし (Nothing)" $ do + let m = dfM |-> gpMulti (GPConfig RBF Krr AutoMarginalLik) ["x1", "x2"] "y" + (_, b) = svGrid m 0.95 [1.0, 3.0, 5.0] + b `shouldBe` Nothing + + it "E3: gpMulti GpRff (MV RFF GP) も帯を返し有限・同 seed 再現" $ do + let mk s = dfM |-> gpMulti (GPConfig RBF (GpRff 300 s) AutoMarginalLik) ["x1", "x2"] "y" + (mu1, b1) = svGrid (mk 7) 0.95 [1.0, 3.0, 5.0] + (mu2, _) = svGrid (mk 7) 0.95 [1.0, 3.0, 5.0] + all (\v -> not (isNaN v)) mu1 `shouldBe` True + b1 `shouldSatisfy` (/= Nothing) + mu1 `shouldBe` mu2 + + it "E3: gpMulti の偏依存曲線が sin(x1) の山谷を捉える (x2 平均固定)" $ do + let m = dfM |-> gpMulti defaultGP ["x1", "x2"] "y" + (mu, _) = svGrid m 0.95 [1.5, 4.5] -- sin の山 (≈1) と谷 (≈−1) + -- x2 を平均で固定すれば PD 曲線 ≈ sin(x1) + const ゆえ μ(1.5) > μ(4.5)。 + (mu !! 0 > mu !! 1) `shouldBe` True + + it "E3: gpMulti AutoCV も有限な多変量予測を返す" $ do + let m = dfM |-> gpMulti (GPConfig RBF Gp AutoCV) ["x1", "x2"] "y" + (mu, _) = svGrid m 0.95 [1.0, 4.0, 7.0] + all (\v -> not (isNaN v) && not (isInfinite v)) mu `shouldBe` True + + describe "Phase 70.7 項目 G (G1): 罰則付き回帰の高レベル df|-> 化" $ do + -- y = 2 x1 + 0 x2 + 3 x3 + 小ノイズ。 x2 は無関係 (Lasso が 0 にすべき)。 + let n = 60 :: Int + x1d = [ sin (0.3 * fromIntegral i) | i <- [0 .. n - 1] ] :: [Double] + x2d = [ cos (0.21 * fromIntegral i) | i <- [0 .. n - 1] ] -- 無関係 + x3d = [ sin (0.13 * fromIntegral i + 1.0) | i <- [0 .. n - 1] ] + noised = [ 0.02 * sin (3.1 * fromIntegral i) | i <- [0 .. n - 1] ] + yd = zipWith3 (\a c e -> 2 * a + 3 * c + e) x1d x3d noised + dfR = [ ("x1", x1d), ("x2", x2d), ("x3", x3d), ("y", yd) ] :: [(Text, [Double])] + rows = [ [a, b, c] | (a, b, c) <- zip3 x1d x2d x3d ] + rmseOf m = sqrt (sum (zipWith (\p t -> (p - t) ^ (2 :: Int)) (regPredict m rows) yd) + / fromIntegral n) + + it "G1: ridge (df|->) が名前を保持し元スケールで高精度予測 (RMSE 小)" $ do + let m = dfR |-> ridge ["x1", "x2", "x3"] "y" + rmgNames m `shouldBe` ["x1", "x2", "x3"] + length (rmgCoefs m) `shouldBe` 3 + rmseOf m `shouldSatisfy` (< 0.3) + + it "G1: lasso が無関係な x2 を縮約 (|β₂| < |β₁|,|β₃|)" $ do + let m = dfR |-> lasso ["x1", "x2", "x3"] "y" + [b1, b2, b3] = map abs (rmgCoefs m) + b2 `shouldSatisfy` (< b1) + b2 `shouldSatisfy` (< b3) + + it "G1: FixedLambda 経路 — Ridge/Lasso/EN/MCP/SCAD/Adaptive すべて有限係数" $ do + let mk meth = dfR |-> regularized (RegConfig meth (FixedLambda 0.1)) ["x1", "x2", "x3"] "y" + finite m = all (\v -> not (isNaN v) && not (isInfinite v)) (rmgCoefs m) + all finite [ mk Ridge, mk Lasso, mk (ElasticNet 0.5) + , mk (MCP 3.0), mk (SCAD 3.7), mk (AdaptiveLasso 1.0) ] `shouldBe` True + + it "G1: LambdaLOOCV は Ridge で成功・Lasso では Left (線形平滑器専用)" $ do + let okRidge = fitEither (regularized (RegConfig Ridge LambdaLOOCV) ["x1","x2","x3"] "y") dfR + noLasso = fitEither (regularized (RegConfig Lasso LambdaLOOCV) ["x1","x2","x3"] "y") dfR + (case okRidge of Right _ -> True; Left _ -> False) `shouldBe` True + (case (noLasso :: Either String RegModel) of Left _ -> True; Right _ -> False) `shouldBe` True + + it "G1: LambdaCV seed 再現性 (同 seed → 同 λ・別 seed で変わりうる)" $ do + let mk s = dfR |-> regularized (RegConfig Lasso (LambdaCV 5 s)) ["x1","x2","x3"] "y" + rmgLambda (mk 7) `shouldBe` rmgLambda (mk 7) + + it "G1: LambdaCV1SE の λ は LambdaCV(best) 以上 (より保守的=スパース)" $ do + let best = rmgLambda (dfR |-> regularized (RegConfig Lasso (LambdaCV 5 7)) ["x1","x2","x3"] "y") + one = rmgLambda (dfR |-> regularized (RegConfig Lasso (LambdaCV1SE 5 7)) ["x1","x2","x3"] "y") + one `shouldSatisfy` (>= best) + + it "G1: Group Lasso の群 ID 長さ不一致は Left" $ do + let bad = fitEither (regularized (RegConfig (GroupLasso [0,0]) (FixedLambda 0.1)) ["x1","x2","x3"] "y") dfR + (case (bad :: Either String RegModel) of Left _ -> True; Right _ -> False) `shouldBe` True + + it "G1: Group Lasso (群指定) も有限な係数で当てはまる" $ do + let m = dfR |-> regularized (RegConfig (GroupLasso [0,1,0]) (FixedLambda 0.05)) ["x1","x2","x3"] "y" + all (\v -> not (isNaN v)) (rmgCoefs m) `shouldBe` True + + describe "Phase 46 A9 + 70.C: RobustModel + toPlot (ロバスト直線 + CI 帯)" $ do + -- y = 2x + 1 にして、 1 点だけ大きな外れ値を入れる。 ロバスト傾きが外れ値に + -- 引っ張られず ≈ 2 に留まることを確認。 + let rxs = LA.fromList [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] + rys = LA.fromList [3, 5, 7, 9, 11, 13, 15, 17, 19, 100] -- 末尾が外れ値 (本来 21) + rm = robustModel (Huber defaultHuberK) rxs rys + rLine = head [ l | l <- vsLayers (toPlot rm), getFirst (lyKind l) == Just MLine ] + + it "toPlot は MBand + MLine の 2 layer (CI 帯付き・Phase 70.C で揃えた)" $ do + let ls = vsLayers (toPlot rm) + map (getFirst . lyKind) ls `shouldBe` [Just MBand, Just MLine] + + it "ロバスト傾き ≈ 2 (外れ値に引っ張られない)" $ do + -- 直線 2 点から傾きを復元 (encX/encY は昇順)。 + case (getLast (lyEncX rLine), getLast (lyEncY rLine)) of + (Just (ColNum vx), Just (ColNum vy)) -> do + let xs = V.toList vx; ys = V.toList vy + slope = (last ys - head ys) / (last xs - head xs) + abs (slope - 2) `shouldSatisfy` (< 0.2) + _ -> expectationFailure "encX/encY が inline ColNum でない" + + it "外れ値 (末尾) の IRLS 重みは健全点より小さい" $ do + let ws = LA.toList (rfWeights (rmFit rm)) + last ws `shouldSatisfy` (< minimum (init ws) + 1e-9) + + -- 検証: Huber の k を巨大にすると全点 inlier (ψ'=1, ψ(u)=u) ゆえ、 サンドイッチ + -- 共分散は σ が打ち消えて OLS 共分散 (Σr²/(n-p)·(XᵀX)⁻¹) に厳密一致する。 + -- = statsmodels RLM cov="H1" の OLS 極限。 これを数値で実測する。 + it "robustCovBeta(Huber 巨大k) の SE は OLS SE に厳密一致 (サンドイッチ→OLS極限)" $ do + let n = LA.rows xX + xX = LA.fromColumns [ LA.konst 1 (LA.size rxs), rxs ] -- [1, x] + xtxInv = LA.inv (LA.tr xX LA.<> xX) + betaO = xtxInv LA.#> (LA.tr xX LA.#> rys) + residO = rys - (xX LA.#> betaO) + sigma2 = (residO LA.<.> residO) / fromIntegral (n - 2) + olsSE = map sqrt (LA.toList (LA.takeDiag (LA.scale sigma2 xtxInv))) + rfit = fitRobustLM (Huber 1e6) xX rys 50 1e-9 + rcov = robustCovBeta (Huber 1e6) (rfScale rfit) (rfResiduals rfit) xX + rSE = map sqrt (LA.toList (LA.takeDiag rcov)) + rSE `shouldSatisfy` allClose olsSE + + -- ★statsmodels RLM (HuberT t=1.345, scale=mad, cov="H1") との実測突合。 + -- 参照値 (statsmodels 0.14.6): + -- params = [0.83418235, 2.06340481]、 scale = 0.64004295、 bse = [0.41150687, 0.06632034] + it "robust SE/係数/scale が statsmodels RLM (HuberT, cov=H1) に一致" $ do + let vx = LA.fromList [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] + vy = LA.fromList [3.4, 4.6, 7.5, 8.7, 11.3, 12.6, 15.4, 16.8, 19.2, 45] + xX = LA.fromColumns [ LA.konst 1 (LA.size vx), vx ] + rfit = fitRobustLM (Huber 1.345) xX vy 100 1e-10 + se = map sqrt (LA.toList (LA.takeDiag + (robustCovBeta (Huber 1.345) (rfScale rfit) (rfResiduals rfit) xX))) + near tol a b = abs (a - b) <= tol * (1 + abs b) + closeTo tol ref xs = length xs == length ref && and (zipWith (near tol) xs ref) + LA.toList (rfCoef rfit) `shouldSatisfy` closeTo 1e-3 [0.83418235, 2.06340481] + rfScale rfit `shouldSatisfy` near 1e-3 0.64004295 + se `shouldSatisfy` closeTo 1e-3 [0.41150687, 0.06632034] + + it "diagnosticPlots は 3 枚 (直線 + 残差 + 重み encode 散布図)" $ do + let ds = diagnosticPlots rm + length ds `shouldBe` 3 + -- 3 枚目に size encoding (lySizeBy) が乗っている。 + let wLayer = head (vsLayers (ds !! 2)) + getLast (lySizeBy wLayer) `shouldSatisfy` \x -> case x of + Just (ColNum _) -> True + _ -> False + + describe "Phase 46 A9: MultiFit + toPlot (残差相関 heatmap)" $ do + -- 3 出力。 各出力に残差を残すため決定的な wiggle を加える (完全 fit だと残差分散 0 + -- → 相関が NaN になる)。 共有 wiggle で out1/out2 は正相関、 out3 は逆相関にする。 + let nObs = 20 + xcol = [ fromIntegral i | i <- [1 .. nObs] ] :: [Double] + wig = [ sin (fromIntegral i) | i <- [1 .. nObs] ] :: [Double] + xmat = LA.fromColumns [LA.konst 1 nObs, LA.fromList xcol] -- n×2 (intercept+x) + y1 = zipWith (\x w -> 2*x + w) xcol wig + y2 = zipWith (\x w -> x + 0.8*w) xcol wig -- wig 共有 → +相関 + y3 = zipWith (\x w -> -x - w) xcol wig -- -wig → 逆相関 + ymat = LA.fromColumns (map LA.fromList [y1, y2, y3]) -- n×3 + mf = fitMultiLM xmat ymat + hLayer = head (vsLayers (toPlot mf)) + -- heatmap は categorical 軸: encX/encY は出力名ラベル (ColTxt inline)。 + txtH f = case getLast (f hLayer) of + Just (ColTxt v) -> V.toList v + _ -> error "encoding が inline ColTxt でない" + -- value は lyColor = ColorByContinuous (inline) に入る。 + valsH = case getLast (lyColor hLayer) of + Just (ColorByContinuous (ColNum v)) -> V.toList v + _ -> error "color が ColorByContinuous inline でない" + + it "toPlot は MHeatmap layer を 1 つ返す" $ do + length (vsLayers (toPlot mf)) `shouldBe` 1 + getFirst (lyKind hLayer) `shouldBe` Just MHeatmap + + it "heatmap は q×q = 9 セル・軸は出力名ラベル (q=3 出力)" $ do + length (txtH lyEncX) `shouldBe` 9 + txtH lyEncX `shouldSatisfy` all (`elem` ["y1", "y2", "y3"]) + + it "対角は相関 = 1 (自己相関)" $ do + -- セルは (x=yⱼ, y=yᵢ)。 対角 = x==y のラベル一致セル。 + let xs = txtH lyEncX; ys = txtH lyEncY; vs = valsH + diag = [ v | (x, y, v) <- zip3 xs ys vs, x == y ] + diag `shouldSatisfy` allClose [1, 1, 1] + + it "out1-out2 は正相関、 out1-out3 は逆相関 (符号検証)" $ do + let xs = txtH lyEncX; ys = txtH lyEncY; vs = valsH + at i j = head [ v | (x, y, v) <- zip3 xs ys vs, x == j, y == i ] + at "y1" "y2" `shouldSatisfy` (> 0) -- out1 vs out2 + at "y1" "y3" `shouldSatisfy` (< 0) -- out1 vs out3 + + describe "Phase 46 A10: QuantileModel + toPlot (複数分位線・色分け重畳)" $ do + -- heteroscedastic データ: 分散が x で増える → 分位線が末広がりになる。 + let qxs = LA.fromList [ fromIntegral i | i <- [1 .. 40 :: Int] ] + qys = LA.fromList [ 2 * x + (x / 8) * sin (fromIntegral i) + | (i, x) <- zip [1 :: Int ..] (LA.toList qxs) ] + qm = quantileModel [0.1, 0.5, 0.9] qxs qys + qLayers = vsLayers (toPlot qm) + + it "toPlot は分位数ぶんの MLine layer を返す (3 本)" $ do + length qLayers `shouldBe` 3 + map (getFirst . lyKind) qLayers `shouldSatisfy` all (== Just MLine) + + it "各 line layer に固定色 (ColorStatic) が付く" $ do + qLayers `shouldSatisfy` all (\l -> case getLast (lyColor l) of + Just (ColorStatic _) -> True + _ -> False) + + it "分位は単調: 全 x で τ=0.1 の ŷ ≤ τ=0.9 の ŷ" $ do + let yhatOf t = head [ V.toList (V.fromList (LA.toList (qfYHat f))) + | (tt, f) <- qmFits qm, tt == t ] + lo = yhatOf 0.1; hi = yhatOf 0.9 + and (zipWith (<=) lo hi) `shouldBe` True + + it "中央値 (τ=0.5) の傾き ≈ 2" $ do + let med = head [ f | (tt, f) <- qmFits qm, tt == 0.5 ] + b = LA.toList (qfBeta med) + abs (b !! 1 - 2) `shouldSatisfy` (< 0.3) + + describe "Phase 46 A11: ChainModel + toPlot (trace + 周辺事後密度)" $ do + -- AR(1) 風の決定的な draw 列 (平均 5 まわりに揺れる)。 1 パラメータ "mu"。 + let draws = take 100 (iterate (\v -> 5 + 0.7 * (v - 5) + 0.5 * sin v) 4.0) + ch = Chain { chainSamples = [ Map.singleton "mu" v | v <- draws ] + , chainAccepted = 100 + , chainTotal = 120 + , chainEnergy = [] + , chainDivergences = [] + , chainTreeDepths = [] } + cm = chainModel "mu" ch + tLayer = head (vsLayers (toPlot cm)) + + it "toPlot は trace (MTrace) layer を 1 つ返す" $ do + length (vsLayers (toPlot cm)) `shouldBe` 1 + getFirst (lyKind tLayer) `shouldBe` Just MTrace + + it "trace の encX は draw index 1..N、 encY は draw 値" $ do + case (getLast (lyEncX tLayer), getLast (lyEncY tLayer)) of + (Just (ColNum vx), Just (ColNum vy)) -> do + V.toList vx `shouldSatisfy` allClose [ fromIntegral i | i <- [1 .. length draws] ] + V.toList vy `shouldSatisfy` allClose draws + _ -> expectationFailure "encX/encY が inline ColNum でない" + + it "diagnosticPlots は 2 枚 (trace + density)" $ do + let ds = diagnosticPlots cm + length ds `shouldBe` 2 + getFirst (lyKind (head (vsLayers (ds !! 0)))) `shouldBe` Just MTrace + getFirst (lyKind (head (vsLayers (ds !! 1)))) `shouldBe` Just MDensity + + describe "Phase 46 A12: KMResult + toPlot (KM 生存曲線・階段)" $ do + let samples = [ SurvSample t e + | (t, e) <- [ (1, Observed), (2, Observed), (3, Censored) + , (4, Observed), (5, Observed), (6, Censored) + , (7, Observed), (8, Observed) ] ] + km = kaplanMeier samples + kLayer = head (vsLayers (toPlot km)) + kY = case getLast (lyEncY kLayer) of + Just (ColNum v) -> V.toList v + _ -> error "encY が ColNum でない" + + it "toPlot は MLine layer を 1 つ返す (階段)" $ do + length (vsLayers (toPlot km)) `shouldBe` 1 + getFirst (lyKind kLayer) `shouldBe` Just MLine + + it "生存曲線は S=1 から始まり単調非増加 (∈ [0,1])" $ do + head kY `shouldBe` 1.0 + and (zipWith (>=) kY (drop 1 kY)) `shouldBe` True + kY `shouldSatisfy` all (\s -> s >= 0 && s <= 1) + + describe "Phase 46 A12: CRFit + toPlot (競合リスク CIF・色分け階段)" $ do + -- 2 cause + 打ち切り (cause 0)。 + let crs = [ CRSample t c + | (t, c) <- [ (1, 1), (2, 2), (3, 1), (4, 0), (5, 2) + , (6, 1), (7, 0), (8, 2), (9, 1), (10, 2) ] ] + cr = fitCompetingRisks crs + crLayers = vsLayers (toPlot cr) + firstY = case getLast (lyEncY (head crLayers)) of + Just (ColNum v) -> V.toList v + _ -> error "encY が ColNum でない" + + it "toPlot は cause 数ぶんの MLine layer を返す (2 本)" $ do + length crLayers `shouldBe` 2 + map (getFirst . lyKind) crLayers `shouldSatisfy` all (== Just MLine) + + it "各 cause CIF は 0 から始まり単調非減少" $ do + head firstY `shouldBe` 0.0 + and (zipWith (<=) firstY (drop 1 firstY)) `shouldBe` True + + it "各 line layer に固定色 (ColorStatic) が付く" $ do + crLayers `shouldSatisfy` all (\l -> case getLast (lyColor l) of + Just (ColorStatic _) -> True + _ -> False) + + describe "Phase 46 A13: ForecastModel + toPlot (AR 予測 + 予測区間 band)" $ do + -- 定常 AR(1) 風の系列。 h=8 step 予測。 + let series = LA.fromList [ 10 + 3 * sin (fromIntegral i * 0.4) + 0.5 * cos (fromIntegral i) + | i <- [1 .. 60 :: Int] ] + fm = forecastModel 2 8 series + layers = vsLayers (toPlot fm) + bandL = head [ l | l <- layers, getFirst (lyKind l) == Just MBand ] + bandLo f = case getLast (f bandL) of + Just (ColNum v) -> V.toList v + _ -> error "band encoding が ColNum でない" + + it "toPlot は band (MBand) + line 2 本 (履歴 + 予測) を返す" $ do + length layers `shouldBe` 3 + length [ l | l <- layers, getFirst (lyKind l) == Just MBand ] `shouldBe` 1 + length [ l | l <- layers, getFirst (lyKind l) == Just MLine ] `shouldBe` 2 + + it "band は h=8 点、 上境界 ≥ 下境界" $ do + let lo = bandLo lyEncY; hi = bandLo lyEncY2 + length lo `shouldBe` 8 + and (zipWith (<=) lo hi) `shouldBe` True + + it "予測区間幅は地平とともに単調増加 (se が h で広がる)" $ do + let lo = bandLo lyEncY; hi = bandLo lyEncY2 + widths = zipWith (-) hi lo + and (zipWith (<=) widths (drop 1 widths)) `shouldBe` True + + describe "Phase 46 A14: PCAResult + toPlot (scree plot)" $ do + -- 第 1 軸に強い分散・第 2 軸に弱い分散を持たせた 3 次元データ。 + let rows = [ [ 5 * sin (fromIntegral i * 0.3) + , 1.2 * cos (fromIntegral i * 0.5) + , 0.3 * sin (fromIntegral i) ] + | i <- [1 .. 40 :: Int] ] + xmat = LA.fromLists rows + res = PCALow.pca CenterScale Nothing xmat + pLayer = head (vsLayers (toPlot res)) + + it "toPlot は bar (MBar) layer を 1 つ返す" $ do + length (vsLayers (toPlot res)) `shouldBe` 1 + getFirst (lyKind pLayer) `shouldBe` Just MBar + + it "棒は PC ラベル軸・寄与率は降順 (PCA は分散順)" $ do + case getLast (lyEncY pLayer) of + Just (ColNum v) -> do + let ratios = V.toList v + and (zipWith (>=) ratios (drop 1 ratios)) `shouldBe` True + abs (sum ratios - 1) `shouldSatisfy` (< 1e-6) -- 全成分で和=1 + _ -> expectationFailure "encY が ColNum でない" + + describe "Phase 46 A14 / 75.24: RandomForest + toPlot (2 パネル importance)" $ do + it "toPlot は 2 パネル (impurity/permutation)・impurity は特徴数ぶんの bar・非負" $ do + -- y は主に x0 で決まる → x0 の重要度が高いはず (構造のみ検証)。 + let xss = [ [ fromIntegral i, sin (fromIntegral i) ] | i <- [1 .. 50 :: Int] ] + ys = [ 2 * fromIntegral i | i <- [1 .. 50 :: Int] ] + gen <- MWC.createSystemRandom + rf <- fitRF defaultRandomForest xss ys gen + let panels = vsSubplots (toPlot rf) + length panels `shouldBe` 2 -- R varImpPlot 流 2 パネル + let impLayer = head (vsLayers (head panels)) -- 左 = impurity + getFirst (lyKind impLayer) `shouldBe` Just MBar + case getLast (lyEncY impLayer) of + Just (ColNum v) -> do + V.length v `shouldBe` 2 -- 2 特徴 + V.toList v `shouldSatisfy` all (>= 0) -- impurity 重要度 ≥ 0 + _ -> expectationFailure "encY が ColNum でない" + + describe "Phase 16 §3-D: モデル API 層 (predict / describe / coefficients)" $ do + -- m は冒頭の LMModel (y = 2x + 1)。 + it "modelCoefficients == coefficientsV (LM)" $ do + modelCoefficients m `shouldSatisfy` allClose (LA.toList (coefficientsV (lmResult m))) + + it "predictPoint LM (訓練点) == fitted (線形予測の整合)" $ do + let preds = map (predictPoint m) (LA.toList xs) + preds `shouldSatisfy` allClose (LA.toList (fittedV (lmResult m))) + + it "describeModel: 係数値=modelCoefficients・SE≥0・CI が値を含む" $ do + let cs = describeModel m + map coefValue cs `shouldSatisfy` allClose (modelCoefficients m) + cs `shouldSatisfy` all (\c -> coefSE c >= 0) + cs `shouldSatisfy` all (\c -> let (lo, hi) = coefCI c + in lo <= coefValue c && coefValue c <= hi) + + it "predictPoint GLM (訓練点) == 逆リンク後の μ̂ (Poisson/Log)" $ do + let gxs = LA.fromList [1, 2, 3, 4, 5, 6] + gys = LA.fromList [1, 2, 4, 7, 12, 20] + gm = glmModel Poisson Log gxs gys + preds = map (predictPoint gm) (LA.toList gxs) + preds `shouldSatisfy` allClose (LA.toList (fittedV (glmResult gm))) + + describe "Phase 16 §3 C1: grid 評価 (滑らかな曲線・ModelSpec)" $ do + -- m = 冒頭の LMModel (y = 2x + 1, x ∈ [1..5])。 grid 評価は訓練点数と独立。 + let lineLayerOf spec = head [ l | l <- vsLayers (toPlot spec) + , getFirst (lyKind l) == Just MLine ] + numX l = case getLast (lyEncX l) of + Just (ColNum v) -> V.toList v + _ -> error "encX が ColNum でない" + numY l = case getLast (lyEncY l) of + Just (ColNum v) -> V.toList v + _ -> error "encY が ColNum でない" + + it "grid n で曲線の頂点数 = n (訓練点数 5 と独立)" $ do + length (numX (lineLayerOf (statModel m <> grid 25))) `shouldBe` 25 + + it "既定 grid = 100 点" $ do + length (numX (lineLayerOf (statModel m))) `shouldBe` 100 + + it "grid 範囲の既定は説明変数 min/max (= [1, 5])" $ do + let xg = numX (lineLayerOf (statModel m <> grid 50)) + head xg `shouldSatisfy` (\v -> abs (v - 1) < 1e-9) + last xg `shouldSatisfy` (\v -> abs (v - 5) < 1e-9) + + it "gridRange lo hi が評価範囲を上書きする" $ do + let xg = numX (lineLayerOf (statModel m <> grid 11 <> gridRange 0 10)) + head xg `shouldSatisfy` (\v -> abs v < 1e-9) + last xg `shouldSatisfy` (\v -> abs (v - 10) < 1e-9) + + it "grid 上の μ̂ = predictPoint (= fit と整合・補間でない)" $ do + let l = lineLayerOf (statModel m <> grid 7) + numY l `shouldSatisfy` allClose (map (predictPoint m) (numX l)) + + it "LM grid: 曲線は 2x+1 (完全線形データを正しく外挿)" $ do + let l = lineLayerOf (statModel m <> grid 9) + numY l `shouldSatisfy` allClose (map (\x -> 2 * x + 1) (numX l)) + + it "既定 (帯 ON, Phase 70.E) は MBand + MLine の 2 layer" $ do + let ls = vsLayers (toPlot (statModel m <> grid 20)) + map (getFirst . lyKind) ls `shouldMatchList` [Just MBand, Just MLine] + + it "bandMode BandOff で帯が消え MLine 1 layer のみ" $ do + let ls = vsLayers (toPlot (statModel m <> grid 20 <> bandMode BandOff)) + map (getFirst . lyKind) ls `shouldBe` [Just MLine] + + it "bandMode BandCIPI で CI+PI 入れ子 (MBand 2 + MLine 1)・PI ⊃ CI" $ do + let ls = vsLayers (toPlot (statModel m <> grid 20 <> bandMode BandCIPI)) + bands = [ l | l <- ls, getFirst (lyKind l) == Just MBand ] + loY l = case getLast (lyEncY l) of + Just (ColNum v) -> V.toList v + _ -> error "encY が ColNum でない" + map (getFirst . lyKind) ls `shouldMatchList` [Just MBand, Just MBand, Just MLine] + -- 1 本目が PI (下に描く=広い)、 2 本目が CI。 PI 下限 < CI 下限。 + case bands of + [pib, cib] -> and (zipWith (<=) (loY pib) (loY cib)) `shouldBe` True + _ -> expectationFailure "MBand が 2 本でない" + + it "オプションのみ (モデル無し) は空図" $ do + vsLayers (toPlot (grid 50 <> bandMode BandOff)) `shouldBe` [] + + it "GAM grid は CI 帯 + 線 (Phase 70.6 G・grid 点数反映)" $ do + let gm = gamModel 3 5 0.0 + (LA.fromList [0, 1, 2, 3, 4, 5, 6, 7, 8]) + (LA.fromList [0, 1, 4, 9, 16, 25, 36, 49, 64]) + ls = vsLayers (toPlot (statModel gm <> grid 30)) + map (getFirst . lyKind) ls `shouldMatchList` [Just MBand, Just MLine] + length (numX (head ls)) `shouldBe` 30 -- band も line も grid 30 点 + + -- Phase 52 A2: 線/帯 aes setter (color/fill/linetype/linewidth/alpha) + let bandLayerOf spec = head [ l | l <- vsLayers (toPlot spec) + , getFirst (lyKind l) == Just MBand ] + + it "A2 statColor: 線レイヤに固定色 (ColorStatic)" $ do + getLast (lyColor (lineLayerOf (statModel m <> statColor (fromHex "#ff0000")))) + `shouldBe` Just (ColorStatic "#ff0000") + + it "A2 statLinetype: 線レイヤに固定線種" $ do + getLast (lyLinetype (lineLayerOf (statModel m <> statLinetype LtDashed))) + `shouldBe` Just LtDashed + + it "A2 statLinewidth: 線レイヤに stroke 幅" $ do + getLast (lyStroke (lineLayerOf (statModel m <> statLinewidth 2.5))) + `shouldBe` Just 2.5 + + it "A2 statFill + statAlpha: 帯レイヤに塗り色 + 透明度" $ do + let spec = statModel m <> statFill (fromHex "#4682b4") <> statAlpha 0.2 + b = bandLayerOf spec + getLast (lyColor b) `shouldBe` Just (ColorStatic "#4682b4") + getLast (lyAlpha b) `shouldBe` Just 0.2 + + it "A2 statColor は帯 fill に漏れない (線のみ・帯は statFill)" $ do + let spec = statModel m <> statColor (fromHex "#ff0000") + getLast (lyColor (lineLayerOf spec)) `shouldBe` Just (ColorStatic "#ff0000") + getLast (lyColor (bandLayerOf spec)) `shouldBe` Nothing + + -- Phase 52 A3: statLabel (単線命名・凡例) + it "A3 statLabel: 線は ColorByCol (固定色でなく凡例が出る encoding)" $ do + let l = lineLayerOf (statModel m <> statLabel "OLS") + case getLast (lyColor l) of + Just (ColorByCol _) -> pure () + other -> expectationFailure ("ColorByCol を期待: " ++ show other) + + it "A3 statLabel: scaleColorManual で色固定 (既定パレット先頭) + legend 有効" $ do + let vs = toPlot (statModel m <> statLabel "OLS") + getLast (vsColorManual vs) `shouldBe` Just [("OLS", "#1f77b4")] + getLast (vsLegend vs) `shouldSatisfy` \x -> case x of + Just _ -> True + Nothing -> False + + it "A3 statLabel + statColor: scaleColorManual の色は statColor" $ do + let vs = toPlot (statModel m <> statLabel "OLS" <> statColor (fromHex "#aa0000")) + getLast (vsColorManual vs) `shouldBe` Just [("OLS", "#aa0000")] + + it "A3 statLabel 無し: scaleColorManual も legend も付かない" $ do + let vs = toPlot (statModel m) + getLast (vsColorManual vs) `shouldBe` Nothing + getLast (vsLegend vs) `shouldBe` Nothing + + -- Phase 52 A8: statEquation / statR2 (回帰式/R² 凡例注釈)。 + -- m = y = 2x + 1 (intercept 1・slope 2・R²=1)。 A3 と同じ ColorByCol+scaleColorManual 経路。 + it "A8 statEquation: 凡例ラベルが回帰式 'y = 1.000 + 2.000x'" $ do + let vs = toPlot (statModel m <> statEquation) + getLast (vsColorManual vs) `shouldBe` Just [("y = 1.000 + 2.000x", "#1f77b4")] + getLast (vsLegend vs) `shouldSatisfy` \x -> case x of Just _ -> True; Nothing -> False + + it "A8 statR2: 凡例ラベルが 'R² = 1.000'" $ do + let vs = toPlot (statModel m <> statR2) + getLast (vsColorManual vs) `shouldBe` Just [("R² = 1.000", "#1f77b4")] + + it "A8 statEquation + statR2: 1 ラベルに連結 'y = … , R² = …'" $ do + let vs = toPlot (statModel m <> statEquation <> statR2) + getLast (vsColorManual vs) + `shouldBe` Just [("y = 1.000 + 2.000x, R² = 1.000", "#1f77b4")] + + it "A8 statLabel 明示は autoLabel より優先 (式に上書きされない)" $ do + let vs = toPlot (statModel m <> statEquation <> statLabel "OLS") + getLast (vsColorManual vs) `shouldBe` Just [("OLS", "#1f77b4")] + + it "A8 注釈無し: scaleColorManual は付かない (オプトイン)" $ do + getLast (vsColorManual (toPlot (statModel m))) `shouldBe` Nothing + + it "A8 svCoefR2 を持たないモデル (GAM) は式注釈が出ない" $ do + -- GAM は svCoefR2 = Nothing ゆえ statEquation を付けても凡例ラベルなし。 + let gamM = gamModel 3 5 0.0 (LA.fromList [1, 2, 3, 4, 5]) + (LA.fromList [1, 4, 9, 16, 25]) + vs = toPlot (statModel gamM <> statEquation) + getLast (vsColorManual vs) `shouldBe` Nothing + + describe "Phase 16 §3 C2: predAt (予測点・点 + CI エラーバー)" $ do + -- m = 冒頭の LMModel (y = 2x + 1)。 band ありモデルは lineRange + scatter。 + let kindsOf spec = map (getFirst . lyKind) (vsLayers (toPlot spec)) + layerOfKind k spec = head [ l | l <- vsLayers (toPlot spec) + , getFirst (lyKind l) == Just k ] + numOf f l = case getLast (f l) of + Just (ColNum v) -> V.toList v + _ -> error "encoding が ColNum でない" + + it "predAt 1 点: band + line に lineRange + scatter が加わる (LM)" $ do + kindsOf (statModel m <> grid 20 <> predAt 3) + `shouldMatchList` [Just MBand, Just MLine, Just MLineRange, Just MScatter] + + it "predAt はリスト累積 (<> で複数点): scatter に 3 点" $ do + let sc = layerOfKind MScatter (statModel m <> predAt 1 <> predAt 3 <> predAt 5) + numOf lyEncX sc `shouldSatisfy` allClose [1, 3, 5] + + it "予測点 μ̂ = predictPoint (= D の点予測と一致・LM 2x+1)" $ do + let sc = layerOfKind MScatter (statModel m <> predAt 2 <> predAt 4) + numOf lyEncY sc `shouldSatisfy` allClose [5, 9] -- 2·2+1, 2·4+1 + + it "CI エラーバー (lineRange) の中心は区間中点・半幅 ≥ 0 (LM=対称)" $ do + let lr = layerOfKind MLineRange (statModel m <> predAt 3) + numOf lyErrorY lr `shouldSatisfy` all (>= 0) + -- LM は対称ゆえ中点 = μ̂ = 7 + numOf lyEncY lr `shouldSatisfy` allClose [7] + + it "GLM predAt: μ̂ は逆リンク後 μ̂、 lineRange 区間は μ̂ を内包 (非対称可)" $ do + let gxs = LA.fromList [1, 2, 3, 4, 5, 6] + gys = LA.fromList [1, 2, 4, 7, 12, 20] + gm = glmModel Poisson Log gxs gys + spec = statModel gm <> predAt 4 + sc = layerOfKind MScatter spec + lr = layerOfKind MLineRange spec + mu = head (numOf lyEncY sc) + mid = head (numOf lyEncY lr) + haf = head (numOf lyErrorY lr) + -- μ̂ は区間 [mid-haf, mid+haf] = [lo, hi] 内 + (mid - haf - 1e-9 <= mu && mu <= mid + haf + 1e-9) `shouldBe` True + + it "GAM predAt: CI 帯ありゆえ band + line + lineRange + scatter (Phase 70.6 G)" $ do + let gm = gamModel 3 5 0.0 + (LA.fromList [0, 1, 2, 3, 4, 5, 6, 7, 8]) + (LA.fromList [0, 1, 4, 9, 16, 25, 36, 49, 64]) + kindsOf (statModel gm <> predAt 4) -- GAM に CI 実装後は LM と同形 + `shouldMatchList` [Just MBand, Just MLine, Just MLineRange, Just MScatter] + + describe "Phase 16 §3 C3: 多変量 effect plot (statModelMulti + holdAt + byVar)" $ do + -- y = 1 + 2·x1 + 3·x2 + 4·x3 (厳密線形・無誤差)。 12 行 = x1∈{1,2,3} × x2∈{0,1} × x3∈{0,1}。 + -- 設計フルランクゆえ OLS は β=[1,2,3,4] を厳密復元 → 評価点 μ̂ も厳密。 + let dfMV = DX.fromNamedColumns + [ ("y", DX.fromList ([3,7,6,10, 5,9,8,12, 7,11,10,14] :: [Double])) + , ("x1", DX.fromList ([1,1,1,1, 2,2,2,2, 3,3,3,3] :: [Double])) + , ("x2", DX.fromList ([0,0,1,1, 0,0,1,1, 0,0,1,1] :: [Double])) + , ("x3", DX.fromList ([0,1,0,1, 0,1,0,1, 0,1,0,1] :: [Double])) + ] + mlm = either error id (multiLMModel "y ~ x1 + x2 + x3" dfMV) + lineLayersOf spec = [ l | l <- vsLayers (toPlot spec) + , getFirst (lyKind l) == Just MLine ] + bandLayersOf spec = [ l | l <- vsLayers (toPlot spec) + , getFirst (lyKind l) == Just MBand ] + firstLine spec = head (lineLayersOf spec) + numXof l = case getLast (lyEncX l) of + Just (ColNum v) -> V.toList v + _ -> error "encX が ColNum でない" + numYof l = case getLast (lyEncY l) of + Just (ColNum v) -> V.toList v + _ -> error "encY が ColNum でない" + kindsMV spec = map (getFirst . lyKind) (vsLayers (toPlot spec)) + + it "along x1 (既定 帯 ON, 既定 holdAt Mean): MBand + MLine の 2 layer・頂点 100" $ do + let spec = statModelMulti mlm (along "x1") + kindsMV spec `shouldMatchList` [Just MBand, Just MLine] + length (numXof (firstLine spec)) `shouldBe` 100 + + it "Phase 70.G: 重回帰 effect plot も BandCIPI で CI+PI 入れ子 (PI ⊃ CI)" $ do + -- σ̂²>0 のノイズ入り重回帰 (exact-linear だと PI=CI になるため別データ)。 + let nz = cycle [0.4,-0.5,0.3,-0.2,0.6,-0.4,0.2,-0.3] + ys' = zipWith3 (\a b e -> 1 + 2*a + 1.5*b + e) + ([1..12] :: [Double]) (cycle [0,1,2]) (take 12 nz) + dfN = DX.fromNamedColumns + [ ("y", DX.fromList ys') + , ("x1", DX.fromList ([1..12] :: [Double])) + , ("x2", DX.fromList (take 12 (cycle [0,1,2]) :: [Double])) ] + mN = either error id (multiLMModel "y ~ x1 + x2" dfN) + spec = statModelMulti mN (along "x1") <> grid 5 <> bandMode BandCIPI + bands = bandLayersOf spec + halfOf l = case (getLast (lyEncY l), getLast (lyEncY2 l)) of + (Just (ColNum lo), Just (ColNum hi)) -> zipWith (-) (V.toList hi) (V.toList lo) + _ -> error "band encoding が ColNum でない" + length bands `shouldBe` 2 -- PI (外) + CI (内) + -- bands[0]=PI が bands[1]=CI より各点で広い (PI ⊃ CI)。 + case bands of + [pib, cib] -> and (zipWith (>=) (halfOf pib) (halfOf cib)) `shouldBe` True + _ -> expectationFailure "MBand が 2 本でない" + + it "along grid 範囲は x1 の観測 min/max = [1, 3]" $ do + let xg = numXof (firstLine (statModelMulti mlm (along "x1") <> grid 5)) + head xg `shouldSatisfy` (\v -> abs (v - 1) < 1e-9) + last xg `shouldSatisfy` (\v -> abs (v - 3) < 1e-9) + + it "holdAt Mean: 曲線 = 4.5 + 2·x1 (x2,x3 を平均 0.5 で固定)" $ do + let l = firstLine (statModelMulti mlm (along "x1") <> grid 9) + numYof l `shouldSatisfy` allClose (map (\x -> 4.5 + 2 * x) (numXof l)) + + it "holdAt (Fixed x2=1, x3=1): 曲線 = 8 + 2·x1" $ do + let l = firstLine (statModelMulti mlm (along "x1") <> grid 7 + <> holdAt (Fixed [("x2", 1), ("x3", 1)])) + numYof l `shouldSatisfy` allClose (map (\x -> 8 + 2 * x) (numXof l)) + + it "holdAt (Fixed x2=0) 部分指定: x3 は Mean 0.5 のまま → 曲線 = 3 + 2·x1" $ do + let l = firstLine (statModelMulti mlm (along "x1") <> grid 7 + <> holdAt (Fixed [("x2", 0)])) + numYof l `shouldSatisfy` allClose (map (\x -> 3 + 2 * x) (numXof l)) + + it "byVar x2 [0,1] (既定 帯 ON): 2 曲線 (MLine 2 本・MBand 2 本)" $ do + let spec = statModelMulti mlm (along "x1") <> byVar "x2" [0, 1] + length (lineLayersOf spec) `shouldBe` 2 + length (bandLayersOf spec) `shouldBe` 2 + + it "byVar x2 [0,1]: 曲線は x2=0→3+2x1, x2=1→6+2x1 (x3 は Mean・順序保持)" $ do + let spec = statModelMulti mlm (along "x1") <> grid 5 <> byVar "x2" [0, 1] + ls = lineLayersOf spec + [l0, l1] = ls + length ls `shouldBe` 2 + numYof l0 `shouldSatisfy` allClose (map (\x -> 3 + 2 * x) (numXof l0)) + numYof l1 `shouldSatisfy` allClose (map (\x -> 6 + 2 * x) (numXof l1)) + + it "holdAt Marginalize: band 無し (MLine のみ)・PDP = 4.5+2x1 (線形ゆえ Mean と一致)" $ do + let spec = statModelMulti mlm (along "x1") <> grid 6 <> holdAt Marginalize + kindsMV spec `shouldBe` [Just MLine] + numYof (firstLine spec) + `shouldSatisfy` allClose (map (\x -> 4.5 + 2 * x) (numXof (firstLine spec))) + + it "bandMode BandOff: MLine のみ" $ do + kindsMV (statModelMulti mlm (along "x1") <> bandMode BandOff) `shouldBe` [Just MLine] + + it "多変量 GLM effect (Poisson/Log, 既定 帯 ON): μ 曲線 + 非対称帯 (MBand + MLine)・μ̂ > 0 単調増" $ do + let glm = either error id (multiGLMModel Poisson Log "y ~ x1 + x2" dfMV) + spec = statModelMulti glm (along "x1") <> grid 8 + l = firstLine spec + ys' = numYof l + kindsMV spec `shouldMatchList` [Just MBand, Just MLine] + all (> 0) ys' `shouldBe` True + -- Log リンク + 正係数 → x1 に対し μ̂ 単調増 + and (zipWith (<=) ys' (tail ys')) `shouldBe` True + + describe "Phase 49 A1: hbmModel (HBM 学習 = 列名 bind + 並列 multi-chain)" $ do + -- y = 1 + 2x + 小さな決定論的ゆらぎ を生成し、 線形 HBM で a≈1, b≈2 を復元する。 + -- (完全無ノイズだと σ→0 で尤度が発散し NUTS が荒れるため微小ゆらぎを足す)。 + let xdat = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Double] + noise = [0.12, -0.08, 0.05, -0.15, 0.10, 0.03, -0.07, 0.14, -0.04, 0.06] + ydat = zipWith (\x e -> 1 + 2 * x + e) xdat noise + cfg = defaultHBM { hbmChains = 2, hbmSamples = 500, hbmWarmup = 500 + , hbmSeed = Just 20260605 } + + it "列名で withData 自動 bind し multi-chain で学習・posterior が真値を復元" $ do + studied <- hbmModel cfg hbmLinModel [("x", xdat), ("y", ydat)] + -- chain 数 = config 通り。 + length (hbmChainsR studied) `shouldBe` 2 + -- bind 済みデータが保持されている。 + hbmData studied `shouldBe` [("x", xdat), ("y", ydat)] + -- 事後平均が真値 a=1, b=2 を概ね復元 (緩い許容)。 + let aHat = posteriorMeanOf "a" (hbmChainsR studied) + bHat = posteriorMeanOf "b" (hbmChainsR studied) + abs (aHat - 1) `shouldSatisfy` (< 0.5) + abs (bHat - 2) `shouldSatisfy` (< 0.2) + + it "各 chain の draw 数 = hbmSamples (post-warmup)" $ do + studied <- hbmModel cfg hbmLinModel [("x", xdat), ("y", ydat)] + map (length . chainSamples) (hbmChainsR studied) + `shouldBe` [500, 500] + + describe "Phase 49 A2 / 74: tracesOf + forestOf (HBM 出力抽出子)" $ do + let xdat = [1, 2, 3, 4, 5, 6, 7, 8] :: [Double] + ydat = zipWith (\x e -> 1 + 2 * x + e) xdat + [0.1, -0.05, 0.08, -0.1, 0.05, -0.03, 0.07, -0.06] + -- A2 は構造検証ゆえ軽い設定で十分。 + cfgS = defaultHBM { hbmChains = 2, hbmSamples = 60, hbmWarmup = 60 + , hbmSeed = Just 49 } + + it "tracesOf: latent パラメータ数 (a,b,s = 3) 個の VisualSpec" $ do + studied <- hbmModel cfgS hbmLinModel [("x", xdat), ("y", ydat)] + hbmParamNames studied `shouldMatchList` ["a", "b", "s"] + length (tracesOf studied) `shouldBe` 3 + + it "tracesOf: merged trace の頂点数 = 全 chain 連結の draw 総数 (2×60=120)" $ do + studied <- hbmModel cfgS hbmLinModel [("x", xdat), ("y", ydat)] + -- 既定は merged + rug。trace 層は先頭 (rug は分岐後)。divergence 無しでも先頭は trace。 + let vs = head (tracesOf studied) + tLayer = head (vsLayers vs) + case getLast (lyEncX tLayer) of + Just (ColNum vx) -> V.length vx `shouldBe` 120 + _ -> expectationFailure "trace encX が inline ColNum でない" + getFirst (lyKind tLayer) `shouldBe` Just MTrace + + it "forestOf: MForest layer・点 3 個 (= パラメータ数)・誤差半幅 ≥ 0" $ do + studied <- hbmModel cfgS hbmLinModel [("x", xdat), ("y", ydat)] + let fLayer = head (vsLayers (toPlot (forestOf studied))) + getFirst (lyKind fLayer) `shouldBe` Just MForest + case (getLast (lyEncX fLayer), getLast (lyErrorX fLayer)) of + (Just (ColNum ests), Just (ColNum errs)) -> do + V.length ests `shouldBe` 3 + V.length errs `shouldBe` 3 + V.toList errs `shouldSatisfy` all (>= 0) + _ -> expectationFailure "forest encX/errorX が inline ColNum でない" + + -- Phase 52.B2: marginalsOf = 周辺事後密度を per-param で list 返し。 + it "marginalsOf: latent 数 (3) 個・各図 density layer 1 枚 + title=param 名" $ do + studied <- hbmModel cfgS hbmLinModel [("x", xdat), ("y", ydat)] + let ms = marginalsOf studied + length ms `shouldBe` 3 + -- 各図のタイトル = パラメータ名 (a,b,s) + [ t | s <- ms, Just t <- [getLast (vsTitle s)] ] + `shouldMatchList` ["a", "b", "s"] + -- 各図は density (MDensity) layer のみ + [ getFirst (lyKind l) | s <- ms, l <- vsLayers s ] + `shouldSatisfy` all (== Just MDensity) + + describe "Phase 49 A3: epred (事後予測平均 + HDI band・O1 規約)" $ do + -- y = 1 + 2x + 微小ゆらぎ。 epred の事後平均線が真値 1+2x を復元するか検証。 + let xdat = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Double] + ydat = zipWith (\x e -> 1 + 2 * x + e) xdat + [0.12, -0.08, 0.05, -0.15, 0.10, 0.03, -0.07, 0.14, -0.04, 0.06] + cfg = defaultHBM { hbmChains = 2, hbmSamples = 400, hbmWarmup = 400 + , hbmSeed = Just 4903 } + lineLayerOf spec = head [ l | l <- vsLayers (toPlot spec) + , getFirst (lyKind l) == Just MLine ] + numX l = case getLast (lyEncX l) of + Just (ColNum v) -> V.toList v + _ -> error "encX が ColNum でない" + numY l = case getLast (lyEncY l) of + Just (ColNum v) -> V.toList v + _ -> error "encY が ColNum でない" + + it "既定は band (MBand) + 事後平均線 (MLine) の 2 layer・grid 100 点" $ do + studied <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + let ls = vsLayers (toPlot (epred studied "x" "mu")) + map (getFirst . lyKind) ls `shouldMatchList` [Just MBand, Just MLine] + length (numX (lineLayerOf (epred studied "x" "mu"))) `shouldBe` 100 + + it "grid n / gridRange が grid を制御 (既定範囲 = 予測子 min/max = [1,10])" $ do + studied <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + let xg = numX (lineLayerOf (epred studied "x" "mu" <> grid 21)) + length xg `shouldBe` 21 + head xg `shouldSatisfy` (\v -> abs (v - 1) < 1e-9) + last xg `shouldSatisfy` (\v -> abs (v - 10) < 1e-9) + + -- epred は HDI 帯を本体として焼き込む (帯既定 ON・bandOff でも消えない)。 + + it "事後平均線が真値 1+2x を概ね復元 (grid 上で平均絶対誤差 < 0.4)" $ do + studied <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + let l = lineLayerOf (epred studied "x" "mu" <> grid 10) + errs = zipWith (\x mu -> abs (mu - (1 + 2 * x))) (numX l) (numY l) + mae = sum errs / fromIntegral (length errs) + mae `shouldSatisfy` (< 0.4) + + it "epredAt: HDI 幅は level とともに単調増 (0.5 < 0.94 < 0.99)" $ do + studied <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + let widthAt lvl = + let (_, (lo, hi)) = epredAt studied "x" "mu" lvl 5.0 in hi - lo + w50 = widthAt 0.50 + w94 = widthAt 0.94 + w99 = widthAt 0.99 + w50 `shouldSatisfy` (< w94) + w94 `shouldSatisfy` (< w99) + + it "epredAt: 事後平均は線層の対応点と一致 (= 同じ評価核)" $ do + studied <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + let (mean5, _) = epredAt studied "x" "mu" 0.94 5.0 + abs (mean5 - (1 + 2 * 5)) `shouldSatisfy` (< 0.4) + + -- Phase 74: epred の多予測子 hold (holdAt / byVar)。 mu = a + b*x1 + c*x2 で + -- 非軸 x2 を固定値/水準別に動かし、 既存 holdAt/byVar (頻度論と同綴り) が効くか検証。 + describe "Phase 74: epred holdAt / byVar (多予測子 hold)" $ do + let x1d = [1, 2, 3, 4, 5, 6, 7, 8] :: [Double] + x2d = [2, 1, 3, 2, 4, 3, 5, 4] :: [Double] + y2d = zipWith3 (\a b e -> 1 + 2 * a + 3 * b + e) x1d x2d + [0.05, -0.04, 0.03, -0.06, 0.02, 0.01, -0.03, 0.04] + cfg2 = defaultHBM { hbmChains = 2, hbmSamples = 400, hbmWarmup = 400 + , hbmSeed = Just 7402 } + lineLayerOf spec = head [ l | l <- vsLayers (toPlot spec) + , getFirst (lyKind l) == Just MLine ] + mlines spec = [ l | l <- vsLayers (toPlot spec), getFirst (lyKind l) == Just MLine ] + numY l = case getLast (lyEncY l) of + Just (ColNum v) -> V.toList v + _ -> error "encY が ColNum でない" + + it "holdAt (Fixed): x2 を Δ=4 上げると曲線が c*Δ ≈ 12 だけ一様に上シフト" $ do + m <- hbmModel cfg2 hbmEpred2Model [("x1", x1d), ("x2", x2d), ("y", y2d)] + let muAt v = numY (lineLayerOf (epred m "x1" "mu" <> holdAt (Fixed [("x2", v)]) <> grid 6)) + diffs = zipWith (-) (muAt 4) (muAt 0) + -- c ≈ 3・Δx2 = 4 ゆえ全 grid 点で ≈ 12 の一様シフト (傾きは x1 のまま不変)。 + diffs `shouldSatisfy` all (\d -> abs (d - 12) < 1.5) + + it "holdAt 既定 (Mean) = Fixed mean(x2) (非軸の既定は head でなく中央化された Mean)" $ do + m <- hbmModel cfg2 hbmEpred2Model [("x1", x1d), ("x2", x2d), ("y", y2d)] + let meanX2 = sum x2d / fromIntegral (length x2d) + dflt = numY (lineLayerOf (epred m "x1" "mu" <> grid 6)) + fixd = numY (lineLayerOf (epred m "x1" "mu" <> holdAt (Fixed [("x2", meanX2)]) <> grid 6)) + zip dflt fixd `shouldSatisfy` all (\(a, b) -> abs (a - b) < 1e-9) + + it "byVar: x2 の水準数だけ曲線 (MLine) が出て、 水準が高いほど mu 大" $ do + m <- hbmModel cfg2 hbmEpred2Model [("x1", x1d), ("x2", x2d), ("y", y2d)] + let spec = epred m "x1" "mu" <> byVar "x2" [0, 4] <> grid 6 + ls = mlines spec + midOf l = numY l !! 3 + length ls `shouldBe` 2 + midOf (ls !! 1) `shouldSatisfy` (> midOf (head ls)) + + -- Phase 74.5: epred の予測区間 (PI) 帯。 bandMode で CI (μ HDI) / PI (観測ノイズ込み) / + -- CIPI (入れ子) を切替 (頻度論 statModel と同綴り)。 PI は観測分布サンプルゆえ固定 seed で + -- 決定的。 noise を大きめにして PI が CI を有意に上回る (s が効く) ことを検証可能にする。 + describe "Phase 74.5: epred bandMode (CI / PI / CIPI)" $ do + let xdat = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Double] + ydat = zipWith (\x e -> 1 + 2 * x + e) xdat + [0.4, -0.3, 0.5, -0.5, 0.3, 0.2, -0.4, 0.5, -0.2, 0.3] + cfg = defaultHBM { hbmChains = 2, hbmSamples = 400, hbmWarmup = 400 + , hbmSeed = Just 4903 } + bandsOf spec = [ l | l <- vsLayers (toPlot spec), getFirst (lyKind l) == Just MBand ] + kindsOf spec = map (getFirst . lyKind) (vsLayers (toPlot spec)) + loY l = case getLast (lyEncY l) of { Just (ColNum v) -> V.toList v; _ -> error "encY" } + hiY l = case getLast (lyEncY2 l) of { Just (ColNum v) -> V.toList v; _ -> error "encY2" } + widthsOf l = zipWith (-) (hiY l) (loY l) + + it "既定 (bandMode 無し) = bandMode BandCI とバイト一致 (後方互換)" $ do + m <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + let dflt = bandsOf (epred m "x" "mu" <> grid 8) + ci = bandsOf (epred m "x" "mu" <> grid 8 <> bandMode BandCI) + map loY dflt `shouldBe` map loY ci + map hiY dflt `shouldBe` map hiY ci + + it "BandPI: PI 帯は CI 帯を全 grid 点で包含し、 幅が広い (観測 σ ぶん)" $ do + m <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + let [ciB] = bandsOf (epred m "x" "mu" <> grid 8 <> bandMode BandCI) + [piB] = bandsOf (epred m "x" "mu" <> grid 8 <> bandMode BandPI) + and (zipWith (<=) (loY piB) (loY ciB)) `shouldBe` True + and (zipWith (>=) (hiY piB) (hiY ciB)) `shouldBe` True + and (zipWith (>) (widthsOf piB) (widthsOf ciB)) `shouldBe` True + + it "BandCIPI: MBand 2 (外 PI + 内 CI) + MLine 1、 PI が外側 (包含)" $ do + m <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + let spec = epred m "x" "mu" <> grid 8 <> bandMode BandCIPI + bands = bandsOf spec + kindsOf spec `shouldMatchList` [Just MBand, Just MBand, Just MLine] + case bands of + [pib, cib] -> do + and (zipWith (<=) (loY pib) (loY cib)) `shouldBe` True + and (zipWith (>=) (hiY pib) (hiY cib)) `shouldBe` True + _ -> expectationFailure "MBand が 2 本でない" + + it "BandOff: 帯が消え MLine 1 layer のみ" $ do + m <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + kindsOf (epred m "x" "mu" <> grid 8 <> bandMode BandOff) `shouldBe` [Just MLine] + + it "BandPI: PI 帯は妥当な区間 (全 grid 点で lo < hi・grid 点数一致)" $ do + m <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + let [piB] = bandsOf (epred m "x" "mu" <> grid 6 <> bandMode BandPI) + length (widthsOf piB) `shouldBe` 6 + widthsOf piB `shouldSatisfy` all (> 0) + + -- Phase 74.8: 診断ダッシュボード (抽出子を subplots で束ねる便宜関数)。 + describe "Phase 74.8: dashboardOf / dashboardFullOf" $ do + let xdat = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Double] + ydat = zipWith (\x e -> 1 + 2 * x + e) xdat + [0.4, -0.3, 0.5, -0.5, 0.3, 0.2, -0.4, 0.5, -0.2, 0.3] + cfg = defaultHBM { hbmChains = 2, hbmSamples = 300, hbmWarmup = 300 + , hbmSeed = Just 4903 } + + it "dashboardOf: 2×2 = 4 パネル (構造 / 推定値 / 当てはまり / サンプラ健全性)" $ do + m <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + length (vsSubplots (dashboardOf m "obs")) `shouldBe` 4 + + it "dashboardFullOf: 健全性 4 + param ごと [事後分布,trace] 2×3 = 10 パネル" $ do + m <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + -- a,b,s の 3 param ゆえ 4 + 2*3 = 10。 係数が増えると下に行 (2 パネル) ずつ増える。 + length (vsSubplots (dashboardFullOf m "obs")) `shouldBe` 10 + + it "traceDensityOf: param ごと [事後分布,trace] = 2*3 = 6 パネル" $ do + m <- hbmModel cfg hbmEpredModel [("x", xdat), ("y", ydat)] + length (vsSubplots (traceDensityOf m)) `shouldBe` 6 + + describe "Phase 49 A4: ppcOf (事後予測チェック = ArviZ kde overlay)" $ do + -- y = 1 + 2x + 微小ゆらぎ。 ppc は観測 (黒) + 各 draw の y_rep 群 (青) を重ねる + -- (Phase 74.10: プール赤線は KDE バンド幅が n 依存で誤解を招くため削除)。 + let xdat = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Double] + ydat = zipWith (\x e -> 1 + 2 * x + e) xdat + [0.12, -0.08, 0.05, -0.15, 0.10, 0.03, -0.07, 0.14, -0.04, 0.06] + cfg = defaultHBM { hbmChains = 2, hbmSamples = 300, hbmWarmup = 300 + , hbmSeed = Just 7711 } + ppcCfg = defaultPPC { ppcReps = 10, ppcSeed = Just 2024 } + numX l = case getLast (lyEncX l) of + Just (ColNum v) -> V.toList v + _ -> error "encX が ColNum でない" + meanOf zs = sum zs / fromIntegral (length zs) + varOf zs = let m = meanOf zs + in sum [ (z - m) ^ (2 :: Int) | z <- zs ] + / fromIntegral (length zs) + + it "層 = y_rep 10 本 + 観測 = 11 層・全て MDensity (プール線なし)" $ do + studied <- hbmModel cfg hbmLinModel [("x", xdat), ("y", ydat)] + sp <- ppcOfWithIO ppcCfg studied "obs" + let ls = vsLayers (toPlot sp) + length ls `shouldBe` 11 + map (getFirst . lyKind) ls `shouldSatisfy` all (== Just MDensity) + + it "ppcCumulative で全層 MEcdf に切り替わる" $ do + studied <- hbmModel cfg hbmLinModel [("x", xdat), ("y", ydat)] + sp <- ppcOfWithIO ppcCfg { ppcCumulative = True } studied "obs" + let ls = vsLayers (toPlot sp) + map (getFirst . lyKind) ls `shouldSatisfy` all (== Just MEcdf) + + it "観測層 (最後) の encX = 実 y データ (10 点)" $ do + studied <- hbmModel cfg hbmLinModel [("x", xdat), ("y", ydat)] + sp <- ppcOfWithIO ppcCfg studied "obs" + let ls = vsLayers (toPlot sp) + obs = numX (last ls) + obs `shouldSatisfy` (\v -> length v == 10 + && all (\(a, b) -> abs (a - b) < 1e-9) (zip v ydat)) + + it "各 draw の y_rep 層 (先頭 = 1 draw) の平均/分散が観測と整合" $ do + studied <- hbmModel cfg hbmLinModel [("x", xdat), ("y", ydat)] + sp <- ppcOfWithIO ppcCfg studied "obs" + let ls = vsLayers (toPlot sp) + yrep = numX (head ls) -- 先頭 = 1 つの draw の y_rep 層 (n=n_obs・観測と同条件) + obs = numX (last ls) + -- 事後予測が観測の中心・広がりを再現 (緩い許容)。 + abs (meanOf yrep - meanOf obs) `shouldSatisfy` (< 2.0) + (varOf yrep / varOf obs) `shouldSatisfy` (\r -> r > 0.5 && r < 2.0) + + it "ppcReps が draw 総数を超えても全 draw 数で頭打ち (層 = draw+1)" $ do + let smallCfg = defaultHBM { hbmChains = 1, hbmSamples = 5, hbmWarmup = 50 + , hbmSeed = Just 5 } + studied <- hbmModel smallCfg hbmLinModel [("x", xdat), ("y", ydat)] + sp <- ppcOfWithIO defaultPPC { ppcReps = 1000, ppcSeed = Just 1 } studied "obs" + length (vsLayers (toPlot sp)) `shouldBe` 5 + 1 + + describe "Phase 49 A5: dagOf (モデル構造 DAG = buildModelGraph 橋渡し)" $ do + -- dagOf は構造のみ (学習不要)。 data を withData で bind した spec を手で組み、 + -- chains 空の HBMModel を作って DAG を取り出す (NUTS を回さず高速)。 + let xdat = [1, 2, 3, 4] :: [Double] + ydat = [3, 5, 7, 9] :: [Double] + boundLin :: ModelP () + boundLin = withData "x" xdat (withData "y" ydat hbmLinModel) + linDagM = HBMModel { hbmModelSpec = boundLin + , hbmChainsR = [], hbmData = [] + , hbmFactorLevels = [] } + plateDagM = HBMModel { hbmModelSpec = hbmPlateModel + , hbmChainsR = [], hbmData = [] + , hbmFactorLevels = [] } + -- Phase 59.3: dagOf は collapse 済が既定、 旧挙動 (indexed 個別) は dagOfRaw + dsOf hm = case getLast (lyDAG (head (vsLayers (toPlot (dagOf hm))))) of + Just ds -> ds + Nothing -> error "dagOf に lyDAG が無い" + dsOfRaw hm = case getLast (lyDAG (head (vsLayers (toPlot (dagOfRaw hm))))) of + Just ds -> ds + Nothing -> error "dagOfRaw に lyDAG が無い" + + it "MDAG layer 1 枚 (mark = MDAG)" $ do + let ls = vsLayers (toPlot (dagOf linDagM)) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MDAG + + -- Phase 60.4: dataNamedX/dataNamedObs slot (x, y) が NodeData として DAG に + -- 出るようになった (pm.Data parity・既定 ON)。 x は mu 経由で obs への + -- エッジを持つが、 y (dataNamedObs = 生 [Double] view) はエッジなし。 + it "線形モデル (collapsed 既定): a,b,s,obs + data x,y = 6 node" $ do + let ds = dsOf linDagM + names = map dnId (dsNodes ds) + length (dsNodes ds) `shouldBe` 6 + names `shouldSatisfy` (\ns -> all (`elem` ns) ["a", "b", "s", "obs", "x", "y"]) + length (filter (\n -> dnKind n == NodeLatent) (dsNodes ds)) `shouldBe` 3 + length (filter (\n -> dnKind n == NodeObserved) (dsNodes ds)) `shouldBe` 1 + length (filter (\n -> dnKind n == NodeData) (dsNodes ds)) `shouldBe` 2 + + it "線形モデル (collapsed 既定): edge は (a,b,s,x) → obs の 4 本" $ do + let ds = dsOf linDagM + es = [ (deFrom e, deTo e) | e <- dsEdges ds ] + length es `shouldBe` 4 + es `shouldSatisfy` (("a", "obs") `elem`) + es `shouldSatisfy` (("s", "obs") `elem`) + es `shouldSatisfy` (("x", "obs") `elem`) + + it "線形モデル (dagOfRaw): latent 3 + obs_0..3 + data 2 = 9 node" $ do + let ds = dsOfRaw linDagM + names = map dnId (dsNodes ds) + length (dsNodes ds) `shouldBe` 9 + names `shouldSatisfy` (\ns -> all (`elem` ns) ["a", "b", "s", "x", "y"]) + length (filter (\n -> dnKind n == NodeLatent) (dsNodes ds)) `shouldBe` 3 + length (filter (\n -> dnKind n == NodeObserved) (dsNodes ds)) `shouldBe` 4 + length (filter (\n -> dnKind n == NodeData) (dsNodes ds)) `shouldBe` 2 + + it "線形モデル (dagOfRaw): edge は (a,b,s,x) → 各 obs (4×4 = 16 本)" $ do + let ds = dsOfRaw linDagM + es = [ (deFrom e, deTo e) | e <- dsEdges ds ] + length es `shouldBe` 16 + es `shouldSatisfy` (("a", "obs_0") `elem`) + es `shouldSatisfy` (("s", "obs_3") `elem`) + es `shouldSatisfy` (("x", "obs_0") `elem`) + + it "線形モデル (plate 無し): dsPlates は空 (collapsed/raw とも)" $ do + dsPlates (dsOf linDagM) `shouldBe` [] + dsPlates (dsOfRaw linDagM) `shouldBe` [] + + it "plate モデル (collapsed 既定): eta_0..3/y_0..3 が eta/y に畳まれる" $ do + let ds = dsOf plateDagM + names = map dnId (dsNodes ds) + length (dsNodes ds) `shouldBe` 4 -- mu, tau, eta, y + names `shouldSatisfy` (\ns -> all (`elem` ns) ["mu", "tau", "eta", "y"]) + length (dsPlates ds) `shouldBe` 1 + let p = head (dsPlates ds) + dpLabel p `shouldBe` "g (4)" + dpNodeIds p `shouldSatisfy` ("eta" `elem`) + + it "plate モデル (dagOfRaw): dsPlates に \"g (4)\" が 1 個・eta_0 を含む" $ do + let ds = dsOfRaw plateDagM + length (dsPlates ds) `shouldBe` 1 + let p = head (dsPlates ds) + dpLabel p `shouldBe` "g (4)" + dpNodeIds p `shouldSatisfy` ("eta_0" `elem`) + + it "plate モデル: 分布名が dnDist に入る (mu ~ Normal)" $ do + let ds = dsOf plateDagM + case filter (\n -> dnId n == "mu") (dsNodes ds) of + [n] -> dnDist n `shouldBe` Just "Normal" + _ -> expectationFailure "mu node not found" + + -- Phase 74.9: 学習前 DAG (ModelP 直接・サンプリングなし)。 + describe "Phase 74.9: dagOfModel / dagOfModelWith" $ do + let xdat = [1, 2, 3, 4] :: [Double] + ydat = [3, 5, 7, 9] :: [Double] + dsD d = case getLast (lyDAG (head (vsLayers (toPlot d)))) of + Just ds -> ds + Nothing -> error "DAG に lyDAG が無い" + + it "dagOfModelWith: データ束ねで data 駆動 plate の全ノードが出る (6 node・NUTS なし)" $ do + let ds = dsD (dagOfModelWith [("x", xdat), ("y", ydat)] hbmLinModel) + names = map dnId (dsNodes ds) + length (dsNodes ds) `shouldBe` 6 + names `shouldSatisfy` (\ns -> all (`elem` ns) ["a", "b", "s", "obs", "x", "y"]) + + it "dagOfModel: 既に withData 束ね済みモデルなら dagOf と同一構造 (6 node)" $ do + let bound :: ModelP () + bound = withData "x" xdat (withData "y" ydat hbmLinModel) + ds = dsD (dagOfModel bound) + length (dsNodes ds) `shouldBe` 6 + + it "dagOfModel: 未束縛 (slot []) は data 駆動 plate 本体が出ない (caveat: obs 無し)" $ do + let ds = dsD (dagOfModel hbmLinModel) + names = map dnId (dsNodes ds) + -- a,b,s + data x,y は出るが、 ループ本体 (obs) は 0 反復ゆえ出ない。 + names `shouldSatisfy` (\ns -> notElem "obs" ns) + names `shouldSatisfy` (\ns -> all (`elem` ns) ["a", "b", "s"]) + + describe "Phase 59.4 / 74: divergencesOf / tracesOfWith byChain+divergence (divergence 診断)" $ do + -- fake chain で offset 規約を決定的に検証 (chainDivergences = chain 内 0-based + -- post-burn-in index、 root: request/255 §4。 NUTS を回さない) + let muModel :: ModelP () + muModel = do + _ <- sample "mu" (Normal 0 1) + pure () + mkCh vals divs = Chain { chainSamples = [ Map.singleton "mu" v | v <- vals ] + , chainAccepted = 0 + , chainTotal = length vals + , chainEnergy = map (* 2) vals + , chainDivergences = divs + , chainTreeDepths = [] } + ch1 = mkCh [1, 2, 3] [0, 2] -- 3 draws・div = 0,2 + ch2 = mkCh [4, 5] [1] -- 2 draws・div = 1 + divM = HBMModel { hbmModelSpec = muModel + , hbmChainsR = [ch1, ch2], hbmData = [] + , hbmFactorLevels = [] } + cleanM = HBMModel { hbmModelSpec = muModel + , hbmChainsR = [mkCh [1, 2, 3] [], mkCh [4, 5] []] + , hbmData = [], hbmFactorLevels = [] } + + it "divergencesOf: chain offset 加算の通し index ([0,2] ++ map (+3) [1] = [0,2,4])" $ do + divergencesOf divM `shouldBe` [0, 2, 4] + + it "divergencesOf: divergence 無しなら空" $ do + divergencesOf cleanM `shouldBe` [] + + -- Phase 74: 旧 tracesWithDivergencesOf = tracesOfWith (byChain + divergence ON)。 + let byChainDiv = tracesOfWith defaultTraceOpts { toByChain = True } + + it "tracesOfWith byChain+div: trace 2 層 (chain 別) + rug 1 層 (MLineRange 縦棒)" $ do + let [vs] = byChainDiv divM + ls = vsLayers vs + length ls `shouldBe` 3 + -- Phase 60.5: rug は scatter の点から lineRange の縦棒へ (ArviZ tick 同型) + map (getFirst . lyKind) ls `shouldBe` [Just MTrace, Just MTrace, Just MLineRange] + + it "tracesOfWith byChain+div: rug の x = chain 内 1-based iteration・縦棒 = 下端から値域 2%" $ do + let [vs] = byChainDiv divM + rug = last (vsLayers vs) + case (getLast (lyEncX rug), getLast (lyEncY rug), getLast (lyErrorY rug)) of + (Just (ColNum vx), Just (ColNum vy), Just (ColNum ve)) -> do + V.toList vx `shouldBe` [1, 3, 2] -- ch1: 0,2 → 1,3 / ch2: 1 → 2 + -- lineRange は (x, 中心 y, ±err)。 divM の mu は 1..5 → 値域 4・ + -- tick = 4*0.02 = 0.08。 中心 = 1 + 0.04、 err = 0.04 + V.toList vy `shouldSatisfy` all (\v -> abs (v - 1.04) < 1e-9) + V.toList ve `shouldSatisfy` all (\v -> abs (v - 0.04) < 1e-9) + _ -> expectationFailure "rug の encX/encY/errorY が inline ColNum でない" + + it "tracesOfWith byChain+div: divergence 無しなら rug 層なし" $ do + let [vs] = byChainDiv cleanM + map (getFirst . lyKind) (vsLayers vs) `shouldBe` [Just MTrace, Just MTrace] + + it "tracesOf 既定 (merged + div): merged trace 1 層 + rug 1 層" $ do + let [vs] = tracesOf divM + ls = vsLayers vs + -- merged は単線 trace 1 層 + rug 1 層 + map (getFirst . lyKind) ls `shouldBe` [Just MTrace, Just MLineRange] + + it "tracesOfWith divergence OFF: rug 層なし (merged)" $ do + let [vs] = tracesOfWith defaultTraceOpts { toShowDivergences = False } divM + map (getFirst . lyKind) (vsLayers vs) `shouldBe` [Just MTrace] + + describe "Phase 59.5: pairOf (joint 散布 + 発散強調)" $ do + let abModel :: ModelP () + abModel = do + _ <- sample "a" (Normal 0 1) + _ <- sample "b" (Normal 0 1) + pure () + mkCh2 avs bvs divs = Chain + { chainSamples = [ Map.fromList [("a", av), ("b", bv)] + | (av, bv) <- zip avs bvs ] + , chainAccepted = 0 + , chainTotal = length avs + , chainEnergy = [] + , chainDivergences = divs } + ch1 = mkCh2 [10, 11, 12] [20, 21, 22] [2] -- div: chain 内 2 → 通し 2 + ch2 = mkCh2 [13, 14] [23, 24] [0] -- div: chain 内 0 → 通し 3 + m2 = HBMModel { hbmModelSpec = abModel + , hbmChainsR = [ch1, ch2], hbmData = [] + , hbmFactorLevels = [] } + + it "pairOf: 図数 = ペア数・layer = base + 強調の MScatter 2 層" $ do + let vss = pairOf m2 [("a", "b")] + length vss `shouldBe` 1 + map (getFirst . lyKind) (vsLayers (head vss)) + `shouldBe` [Just MScatter, Just MScatter] + + it "pairOf: 強調点 = 通し index の draw (chain 跨ぎ x=[12,13] y=[22,23])" $ do + let [vs] = pairOf m2 [("a", "b")] + ov = last (vsLayers vs) + case (getLast (lyEncX ov), getLast (lyEncY ov)) of + (Just (ColNum vx), Just (ColNum vy)) -> do + V.toList vx `shouldBe` [12, 13] + V.toList vy `shouldBe` [22, 23] + _ -> expectationFailure "強調層の encX/encY が inline ColNum でない" + + it "pairOf: divergence 無しなら base 層のみ" $ do + let m0 = HBMModel { hbmModelSpec = abModel + , hbmChainsR = [mkCh2 [1] [2] []], hbmData = [] + , hbmFactorLevels = [] } + [vs] = pairOf m0 [("a", "b")] + map (getFirst . lyKind) (vsLayers vs) `shouldBe` [Just MScatter] + + describe "Phase 59.6: energyOf (marginal vs ΔE energy 密度)" $ do + let muModel :: ModelP () + muModel = do + _ <- sample "mu" (Normal 0 1) + pure () + mkEnCh es = Chain { chainSamples = [ Map.singleton "mu" e | e <- es ] + , chainAccepted = 0 + , chainTotal = length es + , chainEnergy = es + , chainDivergences = [] + , chainTreeDepths = [] } + es1 = [10, 13, 11, 15, 12, 14, 16, 11, 13, 12] + enM = HBMModel { hbmModelSpec = muModel + , hbmChainsR = [mkEnCh es1, mkEnCh (map (+ 1) es1)] + , hbmData = [], hbmFactorLevels = [] } + noEnM = HBMModel { hbmModelSpec = muModel + , hbmChainsR = + [ Chain [Map.singleton "mu" 1] 0 1 [] [] [] ] + , hbmData = [], hbmFactorLevels = [] } + + it "energyOf: marginal + ΔE の MLine 2 層 (KDE 200 点)" $ do + let vs = energyOf enM + ls = vsLayers vs + map (getFirst . lyKind) ls `shouldBe` [Just MLine, Just MLine] + case getLast (lyEncX (head ls)) of + Just (ColNum vx) -> V.length vx `shouldBe` 200 + _ -> expectationFailure "encX が inline ColNum でない" + + it "energyOf: energy 記録なし (MH 等) なら layer 0 (空図)" $ do + length (vsLayers (energyOf noEnM)) `shouldBe` 0 + + describe "Phase 73.1: autocorrOf (自己相関・ArviZ plot_autocorr)" $ do + let muModel :: ModelP () + muModel = sample "mu" (Normal 0 1) >> pure () + mkAcCh xs = Chain { chainSamples = [ Map.singleton "mu" x | x <- xs ] + , chainAccepted = 0 + , chainTotal = length xs + , chainEnergy = [] + , chainDivergences = [] + , chainTreeDepths = [] } + acXs = [ sin (0.3 * fromIntegral i) | i <- [0 .. 49 :: Int] ] -- 自己相関のある系列 + acM = HBMModel { hbmModelSpec = muModel + , hbmChainsR = [mkAcCh acXs, mkAcCh (map (* 0.9) acXs)] + , hbmData = [], hbmFactorLevels = [] } + + it "autocorrOf: param ごと 1 図・MBar 層" $ do + let specs = autocorrOf acM + length specs `shouldBe` 1 -- "mu" の 1 つ + map (getFirst . lyKind) (vsLayers (head specs)) `shouldBe` [Just MBar] + + it "autocorrOf: lag 0 の ACF == 1.0 (自己相関の定義・chain 平均)" $ do + let l = head (vsLayers (head (autocorrOf acM))) + case getLast (lyEncY l) of + Just (ColNum v) -> V.head v `shouldSatisfy` (\a -> abs (a - 1.0) < 1e-9) + _ -> expectationFailure "encY が inline ColNum でない" + + it "autocorrOfLag: 最大ラグ k なら bar は k+1 本 (lag 0..k)" $ do + let l = head (vsLayers (head (autocorrOfLag 8 acM))) + case getLast (lyEncX l) of + Just (ColNum v) -> V.length v `shouldBe` 9 + _ -> expectationFailure "encX が inline ColNum でない" + + describe "Phase 73.2: rankOf (rank plot・ArviZ plot_rank)" $ do + let muModel :: ModelP () + muModel = sample "mu" (Normal 0 1) >> pure () + mkRkCh xs = Chain { chainSamples = [ Map.singleton "mu" x | x <- xs ] + , chainAccepted = 0 + , chainTotal = length xs + , chainEnergy = [] + , chainDivergences = [] + , chainTreeDepths = [] } + rkXs1 = [ fromIntegral i * 0.5 | i <- [0 .. 39 :: Int] ] + rkXs2 = map (+ 0.25) rkXs1 + rk2M = HBMModel { hbmModelSpec = muModel + , hbmChainsR = [mkRkCh rkXs1, mkRkCh rkXs2] + , hbmData = [], hbmFactorLevels = [] } + rk1M = HBMModel { hbmModelSpec = muModel + , hbmChainsR = [mkRkCh rkXs1] -- chain 1 本 + , hbmData = [], hbmFactorLevels = [] } + + it "rankOf: 2 chain を横並び (dodge) した MBar 1 層" $ do + let ls = vsLayers (head (rankOf rk2M)) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MBar + + it "rankOf: count 総和 = 全 chain の総標本数 (2 chain × 40)" $ do + let l0 = head (vsLayers (head (rankOf rk2M))) + case getLast (lyEncY l0) of + Just (ColNum v) -> round (V.sum v) `shouldBe` (80 :: Int) + _ -> expectationFailure "encY が inline ColNum でない" + + it "rankOf: chain 1 本なら空図 (rank が自明に一様)" $ do + length (vsLayers (head (rankOf rk1M))) `shouldBe` 0 + + it "rankOfBins: ビン数 k・chain c なら long-form bar は k×c 本" $ do + let l0 = head (vsLayers (head (rankOfBins 10 rk2M))) + case getLast (lyEncY l0) of + Just (ColNum v) -> V.length v `shouldBe` 20 -- 10 bins × 2 chains + _ -> expectationFailure "encY が inline ColNum でない" + + describe "Phase 50.4: hbmModelPure / ppcOf (HBM 純粋版・正本)" $ do + let xdat = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Double] + ydat = zipWith (\x e -> 1 + 2 * x + e) xdat + [0.12,-0.08,0.05,-0.15,0.10,0.03,-0.07,0.14,-0.04,0.06] + cfg = defaultHBM { hbmChains = 2, hbmSamples = 300, hbmWarmup = 300 + , hbmSeed = Just 314 } + dat = [("x", xdat), ("y", ydat)] + chainsData m = map chainSamples (hbmChainsR m) + + it "hbmModelPure: IO 無しで学習でき posterior が真値 (a≈1,b≈2) を復元" $ do + let m = hbmModelPure cfg hbmLinModel dat + length (hbmChainsR m) `shouldBe` 2 + abs (posteriorMeanOf "a" (hbmChainsR m) - 1) `shouldSatisfy` (< 0.5) + abs (posteriorMeanOf "b" (hbmChainsR m) - 2) `shouldSatisfy` (< 0.2) + + it "hbmModelPure: 同 config なら chainSamples がビット同一 (再現性)" $ do + let m1 = hbmModelPure cfg hbmLinModel dat + m2 = hbmModelPure cfg hbmLinModel dat + chainsData m1 `shouldBe` chainsData m2 + + -- Phase 61.3: IO + 進捗表示版は bind + seed 規約 (chainSeeds 共有) が + -- 同一ゆえ純粋版とビット一致するのが設計の柱 (進捗は stderr に出る)。 + it "hbmModelIO: hbmModelPure と chainSamples ビット同一 (Phase 61.3)" $ do + mIO <- hbmModelIO cfg hbmLinModel dat + let mP = hbmModelPure cfg hbmLinModel dat + chainsData mIO `shouldBe` chainsData mP + + -- Phase 61.4: IO 動詞 (|->!) = fitIO。 HBM は進捗つき学習 (ビット一致)、 + -- 純粋 spec は既定実装 (pure . fitWith) で挙動不変。 + it "df |->! hbm == df |-> hbm (chainSamples ビット同一・Phase 61.4)" $ do + mIO <- dat |->! hbm cfg hbmLinModel + let mP = dat |-> hbm cfg hbmLinModel + chainsData mIO `shouldBe` chainsData mP + + it "(|->!): 純粋 spec (lm) は既定 fitIO = pure . fitWith (Phase 61.4)" $ do + let dat61 = [("x", [1, 2, 3, 4, 5]), ("y", [3, 5, 7, 9, 11])] + :: [(Text, [Double])] + m1 <- dat61 |->! lm "x" "y" + let m2 = dat61 |-> lm "x" "y" + LA.toList (coefficientsV (lmResult m1)) + `shouldBe` LA.toList (coefficientsV (lmResult m2)) + + it "ppcOf (純粋): 層 = y_rep + 観測・全て MDensity (純粋・プール線なし)" $ do + let m = hbmModelPure cfg hbmLinModel dat + sp = ppcOfWith defaultPPC { ppcReps = 8, ppcSeed = Just 1 } m "obs" + ls = vsLayers (toPlot sp) + length ls `shouldBe` 8 + 1 + map (getFirst . lyKind) ls `shouldSatisfy` all (== Just MDensity) + + it "ppcOf (純粋): 同 seed なら y_rep がビット同一 (再現性)" $ do + let m = hbmModelPure cfg hbmLinModel dat + c = defaultPPC { ppcReps = 8, ppcSeed = Just 7 } + dataOf sp = [ case getLast (lyEncX l) of + Just (ColNum v) -> V.toList v + _ -> [] + | l <- vsLayers (toPlot sp) ] :: [[Double]] + dataOf (ppcOfWith c m "obs") `shouldBe` dataOf (ppcOfWith c m "obs") + + describe "Phase 51.2: df |-> spec (二変量近道・ColumnSource)" $ do + -- y = 2x + 1 を assoc データ源 ([(Text,[Double])] = core instance) で渡す。 + let dat51 = [ ("x", [1, 2, 3, 4, 5]) + , ("y", [3, 5, 7, 9, 11]) ] :: [(Text, [Double])] + + it "df |-> lm \"x\" \"y\" == lmModel xs ys (係数一致)" $ do + let m1 = dat51 |-> lm "x" "y" + m2 = lmModel xs ys + LA.toList (coefficientsV (lmResult m1)) + `shouldSatisfy` allClose (LA.toList (coefficientsV (lmResult m2))) + + it "df |-> lm の係数 ≈ [1, 2] (intercept, slope)" $ do + let m1 = dat51 |-> lm "x" "y" + LA.toList (coefficientsV (lmResult m1)) `shouldSatisfy` allClose [1, 2] + + it "fitWith == (|->) (演算子は fitWith のラッパ)" $ do + let m1 = dat51 |-> lm "x" "y" + m2 = fitWith (lm "x" "y") dat51 + LA.toList (coefficientsV (lmResult m1)) + `shouldSatisfy` allClose (LA.toList (coefficientsV (lmResult m2))) + + it "df |-> glm Gauss Identity == glmModel (係数一致)" $ do + let m1 = dat51 |-> glm Gaussian Identity "x" "y" + m2 = glmModel Gaussian Identity xs ys + LA.toList (coefficientsV (glmResult m1)) + `shouldSatisfy` allClose (LA.toList (coefficientsV (glmResult m2))) + + it "fitEither: 列が存在すれば Right" $ do + case fitEither (lm "x" "y") dat51 of + Right m1 -> LA.toList (coefficientsV (lmResult m1)) + `shouldSatisfy` allClose [1, 2] + Left e -> expectationFailure ("Right を期待したが Left: " <> e) + + it "fitEither: 欠落列は Left (total・error を投げない)" $ do + case fitEither (lm "nope" "y") dat51 of + Left _ -> pure () + Right _ -> expectationFailure "欠落列で Left を期待" + + it "df |-> rq [0.5] == 中央値回帰 (傾き ≈ 2)" $ do + let m1 = dat51 |-> rq [0.5] "x" "y" + case qmFits m1 of + [(t, qf)] -> do + t `shouldBe` 0.5 + (LA.toList (qfBeta qf) !! 1) `shouldSatisfy` (\b -> abs (b - 2) < 1e-6) + _ -> expectationFailure "分位 fit が 1 本でない" + + describe "Phase 70.3 項目 C: 透過標準化ラッパ (standardized / standardizedY)" $ do + -- y = 2x + 1 (μx=3, σx=√2.5≈1.58114)。 X のみ標準化した内側 LM の係数は + -- β1 = a1·σx = 2·1.58114 = 3.16228, β0 = a0 + a1·μx = 1 + 6 = 7 になる。 + let datC = [ ("x", [1, 2, 3, 4, 5]) + , ("y", [3, 5, 7, 9, 11]) ] :: [(Text, [Double])] + -- スケール差の大きい 2 特徴 (x1 ~ O(1), x2 ~ O(1000))。 距離は x2 が支配。 + datKNN = [ ("x1", [0.1, 0.2, 0.3, 0.4, 0.5, 0.6]) + , ("x2", [1000, 2000, 3000, 4000, 5000, 6000]) + , ("y", [1, 2, 3, 4, 5, 6]) ] :: [(Text, [Double])] + + it "predictorCols / responseCol が spec から正しく出る (列名を二重に書かない)" $ do + predictorCols (knnReg 3 ["x1", "x2"] "y") `shouldBe` ["x1", "x2"] + responseCol (knnReg 3 ["x1", "x2"] "y") `shouldBe` Just "y" + predictorCols (knnCls 3 ["x1", "x2"] "c") `shouldBe` ["x1", "x2"] + responseCol (knnCls 3 ["x1", "x2"] "c") `shouldBe` Nothing -- 分類 + responseCol (glm Poisson Log "x" "y") `shouldBe` Nothing -- family/link 拘束 + + it "standardized (lm): 内側 LM は標準化空間の係数 [7, 3.16228]" $ do + let StandardizedModel { smInner = inner, smXStd = sx, smYStd = sy } = + datC |-> standardized (lm "x" "y") + LA.toList (coefficientsV (lmResult inner)) `shouldSatisfy` allClose [7, sqrt 2.5 * 2] + stMu sx `shouldSatisfy` allClose [3] + stSd sx `shouldSatisfy` allClose [sqrt 2.5] + sy `shouldBe` Nothing -- X のみ → y 標準化なし + + it "standardizedY (lm): X+y 標準化で内側係数 ≈ [0, 1] (完全相関)" $ do + let StandardizedModel { smInner = inner, smYStd = sy } = + datC |-> standardizedY (lm "x" "y") + LA.toList (coefficientsV (lmResult inner)) + `shouldSatisfy` (\cs -> allClose [0, 1] (map (\v -> if abs v < 1e-9 then 0 else v) cs)) + case sy of + Just (muY, sdY) -> do + muY `shouldSatisfy` (\v -> abs (v - 7) < 1e-9) -- ȳ = 7 + sdY `shouldSatisfy` (\v -> abs (v - sqrt 10) < 1e-9) -- σy = √10 + Nothing -> expectationFailure "standardizedY は smYStd = Just を期待" + + it "smTrain: 単変量 (予測子1列) では元スケール (x,y) を保持" $ do + let StandardizedModel { smTrain = tr } = datC |-> standardized (lm "x" "y") + tr `shouldBe` Just ([1, 2, 3, 4, 5], [3, 5, 7, 9, 11]) + + it "standardized (knnReg): 内側は手動標準化 df の fit とビット一致" $ do + -- 手動: 特徴行列を fitStandardizer/applyStandardizer で標準化 → 同じ列名 df を組む。 + let feats = ["x1", "x2"] + col n = LA.fromList (maybe (error "col") id (lookup n datKNN)) + xm = LA.fromColumns (map col feats) -- n × p + sx = fitStandardizer xm + xmZ = applyStandardizer sx xm + datZ = zip feats (map LA.toList (LA.toColumns xmZ)) + ++ [("y", [1, 2, 3, 4, 5, 6])] :: [(Text, [Double])] + mWrap = datKNN |-> standardized (knnReg 3 feats "y") + mManual = datZ |-> knnReg 3 feats "y" + -- 標準化空間の query (訓練点) で予測を突合。 + q = xmZ + VU.toList (predictKNNR (smInner mWrap) q) + `shouldBe` VU.toList (predictKNNR mManual q) + + it "ガード: 内部標準化済 spec (regularized) に standardized → Left" $ do + case fitEither (standardized (ridge ["x1", "x2"] "y")) datKNN of + Left _ -> pure () + Right _ -> expectationFailure "predictorCols=[] の spec は Left を期待" + + it "ガード: スケール不変 spec (randomForestReg) に standardized → Left" $ do + case fitEither (standardized (randomForestReg defaultRandomForest 42 ["x1", "x2"] "y")) datKNN of + Left _ -> pure () + Right _ -> expectationFailure "木系は predictorCols=[] ゆえ Left を期待" + + it "ガード: standardizedY を分類 spec (knnCls) に付けると Left" $ do + case fitEither (standardizedY (knnCls 3 ["x1", "x2"] "y")) datKNN of + Left _ -> pure () + Right _ -> expectationFailure "responseCol=Nothing への standardizedY は Left を期待" + + it "ガード: standardizedY を GLM (family/link 拘束) に付けると Left" $ do + case fitEither (standardizedY (glm Gaussian Identity "x" "y")) datC of + Left _ -> pure () + Right _ -> expectationFailure "GLM の responseCol=Nothing ゆえ standardizedY は Left を期待" + + -- --- C2: 元スケール逆変換 (SingleVarModel / Plottable) --- + let plainLM = lmModel (LA.fromList [1, 2, 3, 4, 5]) (LA.fromList [3, 5, 7, 9, 11]) + gC = [1.5, 2.5, 3.5, 4.5] + + it "C2 svRange: standardized ラッパは元スケールの x 範囲 (1,5) を返す" $ do + let wrap = datC |-> standardized (lm "x" "y") + svRange wrap `shouldSatisfy` (\(lo, hi) -> abs (lo - 1) < 1e-9 && abs (hi - 5) < 1e-9) + + it "C2 svGrid: standardized (lm) の元スケール予測が plain lm と一致 (X 標準化は ŷ 不変)" $ do + let wrap = datC |-> standardized (lm "x" "y") + (muW, _) = svGrid wrap 0.95 gC + (muP, _) = svGrid plainLM 0.95 gC + muW `shouldSatisfy` allClose muP + + it "C2 svGrid: standardizedY (lm) も round-trip で plain lm 予測に一致" $ do + let wrap = datC |-> standardizedY (lm "x" "y") + (muW, _) = svGrid wrap 0.95 gC + (muP, _) = svGrid plainLM 0.95 gC + muW `shouldSatisfy` allClose muP + + it "C2 svGrid CI band: standardized (lm) の帯も plain lm と一致" $ do + let wrap = datC |-> standardized (lm "x" "y") + case (svGrid wrap 0.95 gC, svGrid plainLM 0.95 gC) of + ((_, Just (loW, hiW)), (_, Just (loP, hiP))) -> do + loW `shouldSatisfy` allClose loP + hiW `shouldSatisfy` allClose hiP + _ -> expectationFailure "両者とも CI band (Just) を期待" + + it "C2 svCoefR2: 元スケール係数が plain lm [1,2] に一致 (standardized / standardizedY)" $ do + let plainCs = LA.toList (coefficientsV (lmResult plainLM)) + case (svCoefR2 (datC |-> standardized (lm "x" "y")), + svCoefR2 (datC |-> standardizedY (lm "x" "y"))) of + (Just (csX, _), Just (csXY, _)) -> do + csX `shouldSatisfy` allClose plainCs + csXY `shouldSatisfy` allClose plainCs + csX `shouldSatisfy` allClose [1, 2] + _ -> expectationFailure "両ラッパとも線形ゆえ svCoefR2 = Just を期待" + + it "C2 svGrid: standardized (knnReg・1 特徴) は plain kNN と一致 (単調変換で近傍不変)" $ do + let dat1 = [ ("x", [1, 2, 3, 4, 5, 6, 7, 8]) + , ("y", [1, 3, 2, 5, 4, 7, 6, 9]) ] :: [(Text, [Double])] + wrap = dat1 |-> standardized (knnReg 2 ["x"] "y") + plainK = fitKNNR 2 (LA.fromColumns [LA.fromList [1,2,3,4,5,6,7,8]]) + (VU.fromList [1,3,2,5,4,7,6,9]) + g = [1.5, 3.0, 5.5, 7.0] + (muW, mbBand) = svGrid wrap 0.95 g + muP = VU.toList (predictKNNR plainK (LA.fromColumns [LA.fromList g])) + muW `shouldSatisfy` allClose muP + mbBand `shouldBe` Nothing -- kNN は band なし + + it "C2 toPlot: standardized ラッパは散布 + 曲線の 2 レイヤ以上を出す" $ do + let wrap = datC |-> standardized (lm "x" "y") + length (vsLayers (toPlot wrap)) `shouldSatisfy` (>= 2) + + describe "Phase 70.4?: quantileMulti (多変量分位点回帰)" $ do + -- 厳密線形 (無誤差) y = 1 + 2·x1 + 3·x2。 無誤差なら全 τ が同じ β=[1,2,3] を復元。 + let dfQM = [ ("x1", [1, 2, 3, 1, 2, 3, 1, 2, 3]) + , ("x2", [0, 0, 0, 1, 1, 1, 2, 2, 2]) + , ("y", [ 1 + 2*a + 3*b + | (a, b) <- zip [1,2,3,1,2,3,1,2,3] [0,0,0,1,1,1,2,2,2] ]) ] + :: [(Text, [Double])] + + it "predictorCols / responseCol が正しい" $ do + predictorCols (rqMulti [0.5] ["x1", "x2"] "y") `shouldBe` ["x1", "x2"] + responseCol (rqMulti [0.5] ["x1", "x2"] "y") `shouldBe` Just "y" + + it "★無誤差線形: 全 τ が β=[1,2,3] を復元 (intercept, x1, x2)" $ do + let m = dfQM |-> rqMulti [0.25, 0.5, 0.75] ["x1", "x2"] "y" + length (mqmFits m) `shouldBe` 3 + mqmNames m `shouldBe` ["x1", "x2"] + -- QR は MM-IRLS (eps=1e-6) ゆえ厳密一致でなく 1e-5 許容で突合。 + mapM_ (\(_, qf) -> LA.toList (qfBeta qf) + `shouldSatisfy` (\bs -> and (zipWith (\a b -> abs (a - b) < 1e-5) bs [1, 2, 3]))) + (mqmFits m) + + it "toPlot は τ ごとに 1 本ずつ線を出す (3 τ → 3 MLine)" $ do + let m = dfQM |-> rqMulti [0.1, 0.5, 0.9] ["x1", "x2"] "y" + ls = vsLayers (toPlot m) + length ls `shouldBe` 3 + all (\l -> getFirst (lyKind l) == Just MLine) ls `shouldBe` True + + describe "Phase 51.3: df |-> formula spec (R 流多変量)" $ do + -- y = 1 + 2 x1 + 3 x2 (完全線形・OLS が係数を厳密復元)。 + let dfMV = DX.fromNamedColumns + [ ("x1", DX.fromList ([1, 2, 3, 4, 5] :: [Double])) + , ("x2", DX.fromList ([2, 1, 4, 3, 6] :: [Double])) + , ("y", DX.fromList ([9, 8, 19, 18, 29] :: [Double])) ] + assocMV = [ ("x1", [1, 2, 3, 4, 5]) + , ("x2", [2, 1, 4, 3, 6]) + , ("y", [9, 8, 19, 18, 29]) ] :: [(Text, [Double])] + -- glmmF 用 (text factor 列 = toFrame=id で温存する canonical 経路)。 + dfRE = DX.fromNamedColumns + [ ("x", DX.fromList ([1,2,3,4, 1,2,3,4, 1,2,3,4] :: [Double])) + , ("y", DX.fromList ([7.1,6.9,7.0,7.0, 5.0,4.9,5.1,5.0, 3.0,2.9,3.1,3.0] :: [Double])) + , ("group", DX.fromList (["A","A","A","A","B","B","B","B","C","C","C","C"] :: [T.Text])) ] + + it "df |-> lmF == multiLMModel (係数一致)" $ do + let m1 = dfMV |-> lmF "y ~ x1 + x2" + case multiLMModel "y ~ x1 + x2" dfMV of + Right m2 -> LA.toList (coefficientsV (mlmResult m1)) + `shouldSatisfy` allClose (LA.toList (coefficientsV (mlmResult m2))) + Left e -> expectationFailure e + + it "df |-> lmF の係数 ≈ [1, 2, 3] (完全線形を復元)" $ do + let m1 = dfMV |-> lmF "y ~ x1 + x2" + LA.toList (coefficientsV (mlmResult m1)) `shouldSatisfy` allClose [1, 2, 3] + + it "assoc 源 (toFrame 数値再構築) でも同じ係数" $ do + let m1 = assocMV |-> lmF "y ~ x1 + x2" + LA.toList (coefficientsV (mlmResult m1)) `shouldSatisfy` allClose [1, 2, 3] + + it "df |-> glmF Gaussian Identity == multiGLMModel (係数一致)" $ do + let m1 = dfMV |-> glmF Gaussian Identity "y ~ x1 + x2" + case multiGLMModel Gaussian Identity "y ~ x1 + x2" dfMV of + Right m2 -> LA.toList (coefficientsV (mglmResult m1)) + `shouldSatisfy` allClose (LA.toList (coefficientsV (mglmResult m2))) + Left e -> expectationFailure e + + it "fitEither: formula parse 失敗は Left (total)" $ do + case fitEither (lmF "garbage") dfMV of + Left _ -> pure () + Right _ -> expectationFailure "parse 失敗で Left を期待" + + it "df |-> glmmF (1|group): Right で固定効果 2 個 (toFrame=id で factor 温存)" $ do + case fitEither (glmmF "y ~ x + (1|group)") dfRE of + Right (_, labels) -> length labels `shouldBe` 2 + Left e -> expectationFailure e + + describe "Phase 51.4: df |-> hbm + dataScatterOf (ColumnSource→HBM)" $ do + let xdat4 = [1,2,3,4,5,6,7,8,9,10] :: [Double] + ydat4 = zipWith (\x e -> 1 + 2 * x + e) xdat4 + [0.12,-0.08,0.05,-0.15,0.10,0.03,-0.07,0.14,-0.04,0.06] + cfg4 = defaultHBM { hbmChains = 2, hbmSamples = 200, hbmWarmup = 200 + , hbmSeed = Just 314 } + assoc4 = [("x", xdat4), ("y", ydat4)] :: [(Text, [Double])] + df4 = DX.fromNamedColumns [ ("x", DX.fromList xdat4) + , ("y", DX.fromList ydat4) ] + coldata4 = [ ("x", NumData (V.fromList xdat4)) + , ("y", NumData (V.fromList ydat4)) ] :: [(Text, ColData)] + sams m = map chainSamples (hbmChainsR m) + + it "assoc |-> hbm == hbmModelPure (chainSamples ビット同一)" $ do + let m1 = assoc4 |-> hbm cfg4 hbmLinModel + m2 = hbmModelPure cfg4 hbmLinModel assoc4 + sams m1 `shouldBe` sams m2 + + it "DataFrame 源でも posterior が真値 (a≈1, b≈2)" $ do + let m = df4 |-> hbm cfg4 hbmLinModel + abs (posteriorMeanOf "a" (hbmChainsR m) - 1) `shouldSatisfy` (< 0.5) + abs (posteriorMeanOf "b" (hbmChainsR m) - 2) `shouldSatisfy` (< 0.2) + + it "ColData 源 (NumData) でも assoc と同じ結果 (ビット同一)" $ do + let m1 = coldata4 |-> hbm cfg4 hbmLinModel + m2 = assoc4 |-> hbm cfg4 hbmLinModel + sams m1 `shouldBe` sams m2 + + it "dataScatterOf: hbmData から scatter 層 1 枚 (10 点・MScatter)" $ do + let m = assoc4 |-> hbm cfg4 hbmLinModel + ls = vsLayers (dataScatterOf m "x" "y") + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MScatter + case getLast (lyEncX (head ls)) of + Just (ColNum v) -> V.length v `shouldBe` 10 + _ -> expectationFailure "encX が inline ColNum でない" + + it "dataScatterOf: 欠落列なら空 (mempty)" $ do + let m = assoc4 |-> hbm cfg4 hbmLinModel + vsLayers (dataScatterOf m "nope" "y") `shouldBe` [] + + describe "Phase 60.3: DataIx 束縛 + Integer 許容 + 突合 loud error" $ do + let cfg60 = defaultHBM { hbmChains = 1, hbmSamples = 100, hbmWarmup = 100 + , hbmSeed = Just 60 } + -- 群 A ≈ 1、 群 B ≈ 5。 行順は B,A,B,A,... (sort 順コード化の検証: + -- 出現順なら B=0 になるが、 sort 順なら A=0)。 + gTxt = ["B","A","B","A","B","A","B","A"] :: [T.Text] + yMix = [5.1, 0.9, 4.9, 1.1, 5.0, 1.0, 5.2, 0.8] :: [Double] + dfFac = DX.fromNamedColumns [ ("g", DX.fromList gTxt) + , ("y", DX.fromList yMix) ] + + it "Text factor 列 → sort 順コード化 (levels=[A,B]・mu0=A群≈1, mu1=B群≈5)" $ do + let m = dfFac |-> hbm cfg60 hbmIxModel + hbmFactorLevels m `shouldBe` [("g", ["A", "B"])] + abs (posteriorMeanOf "mu0" (hbmChainsR m) - 1) `shouldSatisfy` (< 0.5) + abs (posteriorMeanOf "mu1" (hbmChainsR m) - 5) `shouldSatisfy` (< 0.5) + + it "Int 数値列でも DataIx slot に直結 (levels は空)" $ do + let dfNum = DX.fromNamedColumns + [ ("g", DX.fromList ([1,0,1,0,1,0,1,0] :: [Int])) + , ("y", DX.fromList yMix) ] + m = dfNum |-> hbm cfg60 hbmIxModel + hbmFactorLevels m `shouldBe` [] + abs (posteriorMeanOf "mu0" (hbmChainsR m) - 1) `shouldSatisfy` (< 0.5) + abs (posteriorMeanOf "mu1" (hbmChainsR m) - 5) `shouldSatisfy` (< 0.5) + + it "Integer 列が dataNamedX (連続) で黙殺されず通る (60.3a 根治の確認)" $ do + let dfInt = DX.fromNamedColumns + [ ("x", DX.fromList ([1..10] :: [Integer])) + , ("y", DX.fromList (zipWith (\x e -> 1 + 2 * x + e) + ([1..10] :: [Double]) + [0.12,-0.08,0.05,-0.15,0.10 + ,0.03,-0.07,0.14,-0.04,0.06])) ] + lookupCol "x" dfInt `shouldBe` Just (map fromIntegral [1..10 :: Int]) + let m = dfInt |-> hbm cfg60 hbmLinModel + abs (posteriorMeanOf "b" (hbmChainsR m) - 2) `shouldSatisfy` (< 0.3) + + it "空 placeholder dataNamed の列欠落は fitEither Left (loud)" $ do + let dfNoX = DX.fromNamedColumns [ ("y", DX.fromList yMix) ] + case fitEither (hbm cfg60 hbmLinModel) dfNoX of + Left e -> e `shouldSatisfy` (("dataNamed" `T.isInfixOf`) . T.pack) + Right _ -> expectationFailure "列欠落 (x) で Left を期待" + + it "空 placeholder dataNamedIx の列欠落も Left (loud)" $ do + let dfNoG = DX.fromNamedColumns [ ("y", DX.fromList yMix) ] + case fitEither (hbm cfg60 hbmIxModel) dfNoG of + Left e -> e `shouldSatisfy` (("dataNamedIx" `T.isInfixOf`) . T.pack) + Right _ -> expectationFailure "列欠落 (g) で Left を期待" + + it "非整数の数値列を DataIx slot に bind すると Left" $ do + let dfBad = DX.fromNamedColumns + [ ("g", DX.fromList ([0.5, 1.5, 0.5, 1.5, 0.5, 1.5, 0.5, 1.5] :: [Double])) + , ("y", DX.fromList yMix) ] + case fitEither (hbm cfg60 hbmIxModel) dfBad of + Left e -> e `shouldSatisfy` (("非整数" `T.isInfixOf`) . T.pack) + Right _ -> expectationFailure "非整数列で Left を期待" + + describe "Phase 52.A4: grouped (群別フィット・HBM 整合)" $ do + -- 群 0 = y=2x (傾き 2)、 群 1 = y=5x (傾き 5)。 数値群列 "g"。 + let datG = [ ("x", [1, 2, 3, 4, 1, 2, 3, 4]) + , ("y", [2, 4, 6, 8, 5, 10, 15, 20]) + , ("g", [0, 0, 0, 0, 1, 1, 1, 1]) ] :: [(Text, [Double])] + gfG = datG |-> grouped "g" (lm "x" "y") + slopeOf m = LA.toList (coefficientsV (lmResult m)) !! 1 + lineLayers vs = [ l | l <- vsLayers vs, getFirst (lyKind l) == Just MLine ] + + it "groupLabels: 群が 2 つ (出現順 [\"0\", \"1\"])" $ do + groupLabels gfG `shouldBe` ["0", "1"] + + it "groupModels: 各群を別々に fit (群 0 傾き≈2・群 1 傾き≈5)" $ do + case map snd (groupModels gfG) of + [m0, m1] -> do + slopeOf m0 `shouldSatisfy` (\b -> abs (b - 2) < 1e-9) + slopeOf m1 `shouldSatisfy` (\b -> abs (b - 5) < 1e-9) + _ -> expectationFailure "群モデルが 2 本でない" + + it "toPlot: 群数ぶんの MLine layer (2 本)・各線は ColorByCol" $ do + let ls = lineLayers (toPlot gfG) + length ls `shouldBe` 2 + let colorEncs = map (getLast . lyColor) ls + colorEncs `shouldSatisfy` all (\x -> case x of + Just (ColorByCol _) -> True + _ -> False) + + it "toPlot: scaleColorManual で群色固定 (effectPalette) + legend" $ do + let vs = toPlot gfG + getLast (vsColorManual vs) + `shouldBe` Just [("0", "#1f77b4"), ("1", "#ff7f0e")] + getLast (vsLegend vs) `shouldSatisfy` \x -> case x of + Just _ -> True + Nothing -> False + + it "factor (文字) 群列でも分割できる (DataFrame 源・getTextVec 経路)" $ do + let dfG = DX.fromNamedColumns + [ ("x", DX.fromList ([1, 2, 3, 4, 1, 2, 3, 4] :: [Double])) + , ("y", DX.fromList ([2, 4, 6, 8, 5, 10, 15, 20] :: [Double])) + , ("g", DX.fromList (["a", "a", "a", "a", "b", "b", "b", "b"] :: [Text])) ] + gf = dfG |-> grouped "g" (lm "x" "y") + groupLabels gf `shouldBe` ["a", "b"] + case map snd (groupModels gf) of + [m0, m1] -> do + slopeOf m0 `shouldSatisfy` (\b -> abs (b - 2) < 1e-9) + slopeOf m1 `shouldSatisfy` (\b -> abs (b - 5) < 1e-9) + _ -> expectationFailure "群モデルが 2 本でない" + + it "fitEither: 群列が無ければ Left (total)" $ do + case fitEither (grouped "nope" (lm "x" "y")) datG of + Left _ -> pure () + Right _ -> expectationFailure "欠落群列で Left を期待" + + describe "Phase 52.A7: groupedFullrange (回帰線をデータ全幅へ延長)" $ do + -- 群 0 = x∈[1..4]・y=2x、 群 1 = x∈[10..13]・y=5x。 x 範囲が群間で重ならない。 + let datF = [ ("x", [1, 2, 3, 4, 10, 11, 12, 13]) + , ("y", [2, 4, 6, 8, 50, 55, 60, 65]) + , ("g", [0, 0, 0, 0, 1, 1, 1, 1]) ] :: [(Text, [Double])] + gfF = datF |-> grouped "g" (lm "x" "y") + lineLayers' vs = [ l | l <- vsLayers vs, getFirst (lyKind l) == Just MLine ] + xRangeOf l = case getLast (lyEncX l) of + Just (ColNum vx) -> let xs = V.toList vx in (minimum xs, maximum xs) + _ -> error "encX が inline ColNum でない" + + it "既定 toPlot: 各群線は自群の x 範囲のみ ([1,4] と [10,13])" $ do + case lineLayers' (toPlot gfF) of + [l0, l1] -> do + xRangeOf l0 `shouldSatisfy` \(lo, hi) -> abs (lo - 1) < 1e-9 && abs (hi - 4) < 1e-9 + xRangeOf l1 `shouldSatisfy` \(lo, hi) -> abs (lo - 10) < 1e-9 && abs (hi - 13) < 1e-9 + _ -> expectationFailure "群線が 2 本でない" + + it "groupedFullrange: 各群線が全群 union 範囲 [1,13] へ延長される" $ do + case lineLayers' (groupedFullrange gfF) of + [l0, l1] -> do + xRangeOf l0 `shouldSatisfy` \(lo, hi) -> abs (lo - 1) < 1e-9 && abs (hi - 13) < 1e-9 + xRangeOf l1 `shouldSatisfy` \(lo, hi) -> abs (lo - 1) < 1e-9 && abs (hi - 13) < 1e-9 + _ -> expectationFailure "群線が 2 本でない" + + it "groupedFullrange: 傾き・凡例は toPlot と不変 (range のみ拡張)" $ do + let vsF = groupedFullrange gfF + -- 凡例 (scaleColorManual) は既定と同じ群色固定。 + getLast (vsColorManual vsF) `shouldBe` Just [("0", "#1f77b4"), ("1", "#ff7f0e")] + -- 延長端でも各線は当該群の傾きを保つ (群 1 は y=5x ゆえ x=1 で μ≈5)。 + case lineLayers' vsF of + [_, l1] -> case (getLast (lyEncX l1), getLast (lyEncY l1)) of + (Just (ColNum vx), Just (ColNum vy)) -> do + -- linspace は昇順 (lo=1 が先頭) ゆえ先頭が x=1 での μ̂。 + V.head vx `shouldSatisfy` (\x -> abs (x - 1) < 1e-9) + V.head vy `shouldSatisfy` (\y -> abs (y - 5) < 1e-6) + _ -> expectationFailure "encX/encY が inline ColNum でない" + _ -> expectationFailure "群線が 2 本でない" + + describe "Phase 52.A9: lmDiag (係数診断の薄アクセサ)" $ do + -- statsmodels OLS と突合: x=[1..5], y=[2.1,3.9,6.2,7.8,10.1]。 + -- intercept: SE=0.19807406 t=0.25243083 p=0.81701518 + -- slope : SE=0.05972158 t=33.32129066 p=5.94153911e-5 + let m9 = lmModel (LA.fromList [1, 2, 3, 4, 5]) + (LA.fromList [2.1, 3.9, 6.2, 7.8, 10.1]) + + it "lmDiag: 係数 2 つ ([(Intercept), slope]) の CoefStats" $ do + length (lmDiag m9) `shouldBe` 2 + + it "lmDiag: SE/t/p が statsmodels と一致 (intercept)" $ do + case lmDiag m9 of + (c0 : _) -> do + csSE c0 `shouldSatisfy` \v -> abs (v - 0.19807406) < 1e-6 + csTValue c0 `shouldSatisfy` \v -> abs (v - 0.25243083) < 1e-6 + csPValue c0 `shouldSatisfy` \v -> abs (v - 0.81701518) < 1e-6 + _ -> expectationFailure "係数が空" + + it "lmDiag: SE/t/p が statsmodels と一致 (slope)" $ do + case lmDiag m9 of + (_ : c1 : _) -> do + csSE c1 `shouldSatisfy` \v -> abs (v - 0.05972158) < 1e-6 + csTValue c1 `shouldSatisfy` \v -> abs (v - 33.32129066) < 1e-5 + csPValue c1 `shouldSatisfy` \v -> abs (v - 5.94153911e-5) < 1e-9 + _ -> expectationFailure "slope が無い" + + it "groupedLmDiag: 各群の係数診断を群ラベル付きで取り出す" $ do + -- 群 0 = y=2x, 群 1 = y=5x (傾きは厳密ゆえ SE≈0・t は大)。 + let datG = [ ("x", [1, 2, 3, 4, 1, 2, 3, 4]) + , ("y", [2, 4, 6, 8, 5, 10, 15, 20]) + , ("g", [0, 0, 0, 0, 1, 1, 1, 1]) ] :: [(Text, [Double])] + gf = datG |-> grouped "g" (lm "x" "y") + diags = groupedLmDiag gf + map fst diags `shouldBe` ["0", "1"] + map (length . snd) diags `shouldBe` [2, 2] -- 各群 intercept+slope + + describe "Phase 52.A6: weighted (WLS 露出)" $ do + -- statsmodels WLS と突合: x=[1..5], y=[2.1,3.9,6.2,7.8,10.1], w=[1..5]。 + -- beta=[0.00285714, 2.00285714], rsquared=0.99619888, + -- mean_ci @x=3,5: lower=[5.68995295,9.60211961] upper=[6.33290419,10.4321661] + let datW6 = [ ("x", [1, 2, 3, 4, 5]) + , ("y", [2.1, 3.9, 6.2, 7.8, 10.1]) + , ("w", [1, 2, 3, 4, 5]) -- 重み列 (列名で参照) + , ("w1", [1, 1, 1, 1, 1]) -- 全重み 1 (OLS 一致確認用) + , ("wbad", [1, 2, 3]) ] :: [(Text, [Double])] -- 長さ不一致 (Left 確認用) + wm6 = datW6 |-> weighted "w" (lm "x" "y") + nearW a b = abs (a - b) < 1e-6 + allNearW xs ys = and (zipWith nearW xs ys) + + it "weighted β̂ が statsmodels WLS と一致" $ do + LA.toList (coefficientsV (lmResult (wlmInner wm6))) + `shouldSatisfy` allNearW [0.00285714, 2.00285714] + + it "weighted svGrid (CI) が statsmodels WLS mean_ci と一致 (x=3,5)" $ do + case svGrid wm6 0.95 [3.0, 5.0] of + (_, Just (los, his)) -> do + los `shouldSatisfy` allNearW [5.68995295, 9.60211961] + his `shouldSatisfy` allNearW [6.33290419, 10.4321661] + _ -> expectationFailure "WLS CI 帯が出ない" + + it "weighted svCoefR2 の R² が statsmodels WLS rsquared と一致 (weighted R²)" $ do + case svCoefR2 wm6 of + Just (_, r2) -> r2 `shouldSatisfy` nearW 0.9961988825728395 + Nothing -> expectationFailure "svCoefR2 が Nothing" + + it "全重み 1 の WLS は OLS と一致" $ do + let wm1 = datW6 |-> weighted "w1" (lm "x" "y") + ols = datW6 |-> lm "x" "y" + LA.toList (coefficientsV (lmResult (wlmInner wm1))) + `shouldSatisfy` allNearW (LA.toList (coefficientsV (lmResult ols))) + + it "重み列長が観測数と不一致なら Left" $ do + case fitEither (weighted "wbad" (lm "x" "y")) datW6 of + Left _ -> pure () + Right _ -> expectationFailure "長さ不一致が Left にならない" + + it "toPlot は grid 経路 (line layer) を返す (訓練点経路を使わない)" $ do + length (vsLayers (toPlot wm6)) `shouldSatisfy` (>= 1) + + describe "Phase 52.A5 / 70.F: bandMode CI/PI (予測区間)" $ do + -- statsmodels OLS の mean_ci / obs_ci と突合する固定データ (σ̂²>0)。 + let xsA5 = LA.fromList [1, 2, 3, 4, 5] + ysA5 = LA.fromList [2.1, 3.9, 6.2, 7.8, 10.1] + mA5 = lmModel xsA5 ysA5 + gxA5 = [3.0, 5.0] + near a b = abs (a - b) < 1e-6 + allNear xs ys = and (zipWith near xs ys) + + it "svGrid (CI) が statsmodels mean_ci と一致 (x=3,5)" $ do + case svGrid mA5 0.95 gxA5 of + (_, Just (los, his)) -> do + los `shouldSatisfy` allNear [5.75121357, 9.53444824] + his `shouldSatisfy` allNear [6.28878643, 10.46555176] + _ -> expectationFailure "CI 帯が出ない" + + it "svGridPI (PI) が statsmodels obs_ci と一致 (x=3,5)" $ do + case svGridPI mA5 0.95 gxA5 of + Just (los, his) -> do + los `shouldSatisfy` allNear [5.36161039, 9.23975716] + his `shouldSatisfy` allNear [6.67838961, 10.76024284] + Nothing -> expectationFailure "PI 帯が出ない" + + it "PI ⊃ CI (各点で PI の方が広い)" $ do + case (svGrid mA5 0.95 gxA5, svGridPI mA5 0.95 gxA5) of + ((_, Just (clo, chi)), Just (plo, phi)) -> do + and (zipWith (<) plo clo) `shouldBe` True -- PI 下限 < CI 下限 + and (zipWith (>) phi chi) `shouldBe` True -- PI 上限 > CI 上限 + _ -> expectationFailure "帯が揃わない" + + it "GLM Gaussian/Identity の PI は LM と一致 (closed form 帰着)" $ do + let gm = glmModel Gaussian Identity xsA5 ysA5 + case (svGridPI gm 0.95 gxA5, svGridPI mA5 0.95 gxA5) of + (Just (glo, ghi), Just (llo, lhi)) -> do + allNear glo llo `shouldBe` True + allNear ghi lhi `shouldBe` True + _ -> expectationFailure "GLM/LM PI が揃わない" + + it "非 Gaussian GLM は PI=Nothing (over-claim しない)" $ do + let gp = glmModel Poisson Log xsA5 (LA.fromList [1, 2, 3, 5, 8]) + svGridPI gp 0.95 gxA5 `shouldBe` Nothing + + it "GAM は PI=Nothing (既定実装)" $ do + let gm = gamModel 3 5 0.0 xsA5 ysA5 + svGridPI gm 0.95 gxA5 `shouldBe` Nothing + + it "renderGrid: bandMode BandPI の帯は CI より広い" $ do + let bandLayerOf spec = head [ l | l <- vsLayers (toPlot spec) + , getFirst (lyKind l) == Just MBand ] + loY l = case getLast (lyEncY l) of + Just (ColNum v) -> V.toList v + _ -> error "encY が ColNum でない" + spec k = statModel mA5 <> gridRange 3 5 <> grid 2 <> bandMode k + ciLo = loY (bandLayerOf (spec BandCI)) + piLo = loY (bandLayerOf (spec BandPI)) + and (zipWith (<) piLo ciLo) `shouldBe` True -- PI 帯下限 < CI 帯下限 + head piLo `shouldSatisfy` near 5.36161039 -- PI 下限 = obs_ci 下限 + + it "renderGrid: BandPI は GAM (PI 非提供・CI 提供) で CI へフォールバックし帯が出る (Phase 70.6 G)" $ do + let gm = gamModel 3 5 0.0 xsA5 ysA5 + spec = statModel gm <> gridRange 1 5 <> grid 5 <> bandMode BandPI + bands = [ l | l <- vsLayers (toPlot spec), getFirst (lyKind l) == Just MBand ] + -- GAM は CI (svGrid Just) を持つが PI (svGridPI) は Nothing。BandPI は CI へフォールバック。 + length bands `shouldBe` 1 + + describe "Phase 70.H: ブートストラップ CI/PI (piMethod PIBootstrap)" $ do + let bxs = [1,2,3,4,5,6,7,8,9,10,11,12] :: [Double] + bys = [2.4,3.6,6.5,7.4,11.1,11.9,15.2,15.8,19.0,20.4,22.7,24.1] :: [Double] + bdf = [ ("x", NumData (V.fromList bxs)), ("y", NumData (V.fromList bys)) ] + :: [(Text, ColData)] + ycount = [1,2,2,4,5,8,11,15,20,27,36,49] :: [Double] + bdfP = [ ("x", NumData (V.fromList bxs)), ("y", NumData (V.fromList ycount)) ] + :: [(Text, ColData)] + boot = PIBootstrap 7 400 -- seed 7・400 draws + -- statModel model <> bandMode <> piMethod (PIBootstrap …) の第 1 MBand 層の (lo, hi)。 + bandBoundsP model mode pm = + let ls = vsLayers (toPlot (statModel model <> grid 100 <> bandMode mode <> piMethod pm)) + b = head [ l | l <- ls, getFirst (lyKind l) == Just MBand ] + col f = case getLast (f b) of + Just (ColNum v) -> V.toList v + _ -> error "band encoding が ColNum でない" + in (col lyEncY, col lyEncY2) + lmM = bdf |-> lm "x" "y" :: LMModel + glmM = bdfP |-> glm Poisson Log "x" "y" :: GLMModel + robM = bdf |-> rlm (Huber defaultHuberK) "x" "y" :: RobustModel + + it "決定的: 同 seed → ビット同一の帯 (PI)" $ do + bandBoundsP lmM BandPI boot `shouldBe` bandBoundsP lmM BandPI boot + + it "別 seed → 異なる帯 (実際に確率的)" $ do + (bandBoundsP lmM BandPI boot == bandBoundsP lmM BandPI (PIBootstrap 99 400)) + `shouldBe` False + + it "LM: bootstrap PI ⊃ CI かつ grid 100 点" $ do + let (clo, chi) = bandBoundsP lmM BandCI boot + (plo, phi) = bandBoundsP lmM BandPI boot + length clo `shouldBe` 100 + and (zipWith (<=) plo clo) `shouldBe` True + and (zipWith (>=) phi chi) `shouldBe` True + + it "非 Gaussian GLM (Poisson/Log) でも bootstrap PI が出る (closed-form 非対応)" $ do + let (clo, chi) = bandBoundsP glmM BandCI boot + (plo, phi) = bandBoundsP glmM BandPI boot + length plo `shouldBe` 100 + and (zipWith (<=) plo clo) `shouldBe` True -- PI 下限 ≤ CI 下限 + and (zipWith (>=) phi chi) `shouldBe` True + + it "ロバスト (Huber) でも bootstrap PI が出る" $ do + let (clo, chi) = bandBoundsP robM BandCI boot + (plo, phi) = bandBoundsP robM BandPI boot + and (zipWith (<=) plo clo) `shouldBe` True + and (zipWith (>=) phi chi) `shouldBe` True + + it "piMethod 既定 (PIClosedForm) は closed-form 帯と一致" $ do + let viaDefault = vsLayers (toPlot (statModel lmM <> grid 20 <> bandMode BandCI)) + viaClosed = vsLayers (toPlot (statModel lmM <> grid 20 <> bandMode BandCI + <> piMethod PIClosedForm)) + map (getFirst . lyKind) viaDefault `shouldBe` map (getFirst . lyKind) viaClosed + + describe "Phase 52.D3: GLMMResultRE + toPlot (混合効果 caterpillar)" $ do + -- 3 群 (A,B,C) の random intercept。 群ごとに水準が違う (A≈7, B≈5, C≈3)。 + let dfRE3 = DX.fromNamedColumns + [ ("x", DX.fromList ([1,2,3,4, 1,2,3,4, 1,2,3,4] :: [Double])) + , ("y", DX.fromList ([7.1,6.9,7.0,7.0, 5.0,4.9,5.1,5.0, 3.0,2.9,3.1,3.0] :: [Double])) + , ("group", DX.fromList (["A","A","A","A","B","B","B","B","C","C","C","C"] :: [T.Text])) ] + reOf = case fitEither (glmmF "y ~ x + (1|group)") dfRE3 of + Right (re, _) -> re + Left e -> error e + + it "toPlot: MForest layer・点 3 個 (= 群数)・誤差半幅 0 (CI 帯なし)" $ do + let fLayer = head (vsLayers (toPlot reOf)) + getFirst (lyKind fLayer) `shouldBe` Just MForest + case (getLast (lyEncX fLayer), getLast (lyErrorX fLayer)) of + (Just (ColNum ests), Just (ColNum errs)) -> do + V.length ests `shouldBe` 3 + V.toList errs `shouldSatisfy` all (== 0) -- conditional variance 未格納ゆえ点のみ + _ -> expectationFailure "forest encX/errorX が inline ColNum でない" + + it "toPlot: BLUP が値で昇順ソート (caterpillar の並び順)" $ do + let fLayer = head (vsLayers (toPlot reOf)) + case getLast (lyEncX fLayer) of + Just (ColNum ests) -> + let es = V.toList ests + in and (zipWith (<=) es (drop 1 es)) `shouldBe` True + _ -> expectationFailure "encX が inline ColNum でない" + + it "diagnosticPlots: random intercept のみ (r=1) ゆえ 1 枚" $ do + length (diagnosticPlots reOf) `shouldBe` 1 + + describe "plot Phase 24 A3: 応答曲面 3D 直結 (surfaceGrid / surfaceOf / epredSurfaceOf)" $ do + -- y = 1 + 2·x1 + 3·x2 + 4·x3 (厳密線形・無誤差、 C3 と同じ design)。 + let dfRS = DX.fromNamedColumns + [ ("y", DX.fromList ([3,7,6,10, 5,9,8,12, 7,11,10,14] :: [Double])) + , ("x1", DX.fromList ([1,1,1,1, 2,2,2,2, 3,3,3,3] :: [Double])) + , ("x2", DX.fromList ([0,0,1,1, 0,0,1,1, 0,0,1,1] :: [Double])) + , ("x3", DX.fromList ([0,1,0,1, 0,1,0,1, 0,1,0,1] :: [Double])) + ] + mrs = either error id (multiLMModel "y ~ x1 + x2 + x3" dfRS) + opts5 = defaultSurfaceOpts { soN = 5 } + + it "surfaceGrid: 範囲 = 観測 min/max・寸法 n×n" $ do + let (gxs, gys, grd) = surfaceGrid mrs "x1" "x2" opts5 + (head gxs, last gxs) `shouldBe` (1, 3) + (head gys, last gys) `shouldBe` (0, 1) + (length grd, length (head grd)) `shouldBe` (5, 5) + + it "surfaceGrid: grid[j][i] = 3 + 2·gxs[i] + 3·gys[j] (x3 hold Mean 0.5) を厳密復元" $ do + let (gxs, gys, grd) = surfaceGrid mrs "x1" "x2" opts5 + expectAt j i = 1 + 2 * (gxs !! i) + 3 * (gys !! j) + 4 * 0.5 + sequence_ [ (grd !! j !! i) `shouldSatisfy` + (\v -> abs (v - expectAt j i) < 1e-8) + | j <- [0 .. 4], i <- [0 .. 4] ] + + it "surfaceGrid: holdAt (Fixed x3=1) で面全体が +2 (vs Mean 0.5)" $ do + let (_, _, g0) = surfaceGrid mrs "x1" "x2" opts5 + (_, _, g1) = surfaceGrid mrs "x1" "x2" opts5 { soHoldAt = Fixed [("x3", 1)] } + (g1 !! 2 !! 2 - g0 !! 2 !! 2) `shouldSatisfy` (\d -> abs (d - 2) < 1e-8) + + it "surfaceOf: M3Surface 1 layer・colormap ON・x/y range 焼き込み" $ do + let ls = P3.vs3Layers (surfaceOf mrs "x1" "x2") + length ls `shouldBe` 1 + let l = head ls + getFirst (P3.lyr3Kind l) `shouldBe` Just P3.M3Surface + getLast (P3.lyr3Colormap l) `shouldBe` Just P3.viridisStops3D + getLast (P3.lyr3XRange l) `shouldBe` Just (1, 3) + getLast (P3.lyr3YRange l) `shouldBe` Just (0, 1) + + it "dataScatter3DOf: 訓練 12 点の M3Scatter (z = 実測 y)" $ do + let ls = P3.vs3Layers (dataScatter3DOf mrs "x1" "x2") + l = head ls + getFirst (P3.lyr3Kind l) `shouldBe` Just P3.M3Scatter + case getLast (P3.lyr3Points l) of + Just pts -> do + length pts `shouldBe` 12 + case head pts of Point3 px py pz -> (px, py, pz) `shouldBe` (1, 0, 3) + Nothing -> expectationFailure "scatter3D の points が無い" + + it "epredSurfaceOf: 事後平均面が 1 + 2·x1 + 1.5·x2 に近い (無誤差データ)" $ do + let xs1 = [0, 0.5, 1, 1.5, 2, 0, 0.5, 1, 1.5, 2] + xs2 = [0, 1, 0, 1, 0, 1, 0, 1, 0, 1] + ysE = [ 1 + 2 * a + 1.5 * b | (a, b) <- zip xs1 xs2 ] + cfg = defaultHBM { hbmChains = 2, hbmSamples = 400, hbmWarmup = 400 } + studied <- hbmModel cfg hbmEpred2Model + [("x1", xs1), ("x2", xs2), ("y", ysE)] + let spec = epredSurfaceOfWith studied "x1" "x2" "mu" defaultSurfaceOpts { soN = 3 } + l = head (P3.vs3Layers spec) + getFirst (P3.lyr3Kind l) `shouldBe` Just P3.M3Surface + case getLast (P3.lyr3Grid l) of + Just grd -> do + (length grd, length (head grd)) `shouldBe` (3, 3) + -- 角 (x1=2, x2=1) の真値 = 6.5、 原点 = 1 + (grd !! 0 !! 0) `shouldSatisfy` (\v -> abs (v - 1) < 0.5) + (grd !! 2 !! 2) `shouldSatisfy` (\v -> abs (v - 6.5) < 0.5) + Nothing -> expectationFailure "surface3D の grid が無い" + + -- ===================================================================== + -- Phase 68 A1: KMeans クラスタリングの図 (Plottable + ヘルパ) + -- 二層イディオム: clusterScatterOf (data 層・色=ラベル) <> centroidsOf + -- (model 層・✚ centroid)。 KMeansResult を直接構築して構造を検証する。 + -- ===================================================================== + describe "Phase 68 A1: KMeans + Plottable / clusterScatterOf / centroidsOf" $ do + let kres = KMeansResult + { kmrCentroids = LA.fromLists [[1, 1], [5, 5], [1, 5]] -- 3×2 + , kmrLabels = [0, 0, 1, 1, 2] + , kmrInertia = 0 + , kmrIters = 1 + , kmrConverged = True + } + kdf = [ ("x", [0.9, 1.1, 5.2, 4.8, 1.0]) + , ("y", [1.2, 0.8, 5.1, 4.9, 5.3]) ] :: [(Text, [Double])] + + it "centroidsOf: 第 0/1 次元 centroid を MScatter + ✚ shape + クラスタ色で 1 layer" $ do + let ls = vsLayers (centroidsOf kres 0 1) + length ls `shouldBe` 1 + let l = head ls + getFirst (lyKind l) `shouldBe` Just MScatter + getLast (lyShape l) `shouldBe` Just MShCross + -- x = centroid 第0次元 [1,5,1]、 y = 第1次元 [1,5,5] + case (getLast (lyEncX l), getLast (lyEncY l)) of + (Just (ColNum vx), Just (ColNum vy)) -> do + V.toList vx `shouldBe` [1, 5, 1] + V.toList vy `shouldBe` [1, 5, 5] + _ -> expectationFailure "centroid encX/encY が inline ColNum でない" + -- 色 = クラスタ id "0","1","2" の categorical + case getLast (lyColor l) of + Just (ColorByCol (ColTxt v)) -> V.toList v `shouldBe` ["0", "1", "2"] + _ -> expectationFailure "centroid の colorBy が ColTxt クラスタ id でない" + + it "centroidsOf: 範囲外 index は mempty (layer ゼロ)" $ do + vsLayers (centroidsOf kres 0 2) `shouldBe` [] -- d=2 ゆえ index 2 は範囲外 + vsLayers (centroidsOf kres (-1) 0) `shouldBe` [] + + it "toPlot (KMeansResult) == centroidsOf res 0 1 (代表図 = centroid 散布)" $ do + let a = vsLayers (toPlot kres) + b = vsLayers (centroidsOf kres 0 1) + length a `shouldBe` 1 + map (getFirst . lyKind) a `shouldBe` map (getFirst . lyKind) b + map (getLast . lyShape) a `shouldBe` map (getLast . lyShape) b + + it "clusterScatterOf: データ点を MScatter + ラベル色で 1 layer (点と同順)" $ do + let ls = vsLayers (clusterScatterOf kdf kres "x" "y") + length ls `shouldBe` 1 + let l = head ls + getFirst (lyKind l) `shouldBe` Just MScatter + case (getLast (lyEncX l), getLast (lyEncY l)) of + (Just (ColNum vx), Just (ColNum vy)) -> do + V.toList vx `shouldBe` [0.9, 1.1, 5.2, 4.8, 1.0] + V.length vy `shouldBe` 5 + _ -> expectationFailure "data 散布の encX/encY が inline ColNum でない" + -- 色 = kmrLabels を文字列化した categorical (5 点ぶん) + case getLast (lyColor l) of + Just (ColorByCol (ColTxt v)) -> V.toList v `shouldBe` ["0", "0", "1", "1", "2"] + _ -> expectationFailure "data 散布の colorBy が ColTxt ラベルでない" + + it "clusterScatterOf: 存在しない列名は mempty" $ do + vsLayers (clusterScatterOf kdf kres "nope" "y") `shouldBe` [] + + -- ===================================================================== + -- Phase 68 A2: 木/アンサンブル (重要度 bar / 決定木 樹形図) + -- 結果型を直接構築して構造を検証 (IO/学習不要)。 + -- ===================================================================== + describe "Phase 68 A2: GBM/RFClassifier 重要度 bar + DecisionTree 樹形図" $ do + -- feature 0 を 2 回・feature 1 を 1 回 split に使う木 + let tree1 = RF.Node 0 0.5 (RF.Leaf 1) (RF.Node 1 0.5 (RF.Leaf 0) (RF.Leaf 1)) + tree2 = RF.Node 0 0.5 (RF.Leaf 0) (RF.Leaf 1) + + it "treeImportances: split 使用回数を正規化 (feat0 2回 / feat1 1回 → [2/3, 1/3])" $ do + treeImportances [tree1, tree2] `shouldSatisfy` + (\xs -> length xs == 2 + && abs (xs !! 0 - 2/3) < 1e-9 + && abs (xs !! 1 - 1/3) < 1e-9) + + it "treeImportances: 空入力は []" $ do + treeImportances [] `shouldBe` [] + + it "GBRegressor toPlot: 1 bar layer・重要度は合計 1 に正規化" $ do + let gb = GBRegressor { gbrInit = 0, gbrTrees = [tree1, tree2], gbrLR = 0.1 } + ls = vsLayers (toPlot gb) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MBar + case getLast (lyEncY (head ls)) of + Just (ColNum v) -> do + V.length v `shouldBe` 2 + abs (V.head v - 2/3) `shouldSatisfy` (< 1e-9) + sum (V.toList v) `shouldSatisfy` (\s -> abs (s - 1) < 1e-9) + _ -> expectationFailure "GBM importance bar の encY が inline ColNum でない" + + it "GBClassifier toPlot: 1 bar layer (MBar)" $ do + let gb = GBClassifier { gbcInit = 0, gbcTrees = [tree2], gbcLR = 0.1 } + ls = vsLayers (toPlot gb) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MBar + + it "RFClassifierFit toPlot: 2 パネル (permutation/gini)・実列名 (75.24b)" $ do + let fit = RFClassifierFit + { rfcTrees = [] + , rfcOOBSamples = [] + , rfcClasses = [0, 1] + , rfcOOBError = 0 + , rfcImportance = LA.fromList [1, 3] + , rfcGiniImportance = LA.fromList [0.25, 0.75] + , rfcFeatureNames = ["a", "b"] + , rfcConfig = defaultRFCConfig + } + panels = vsSubplots (toPlot fit) + length panels `shouldBe` 2 -- permutation + gini + let permLayer = head (vsLayers (head panels)) -- 左 = permutation + getFirst (lyKind permLayer) `shouldBe` Just MBar + case getLast (lyEncY permLayer) of + Just (ColNum v) -> V.toList v `shouldBe` [1, 3] -- permutation raw (データ順・sort は limits 側) + _ -> expectationFailure "RFClassifier importance bar の encY が inline ColNum でない" + + it "DTree toPlot: MDAG 樹形図を 1 layer (split=矩形/葉)" $ do + let dt = DNode 1 3.5 (DLeaf (Map.fromList [(0,1)]) 0 5 0) + (DLeaf (Map.fromList [(1,1)]) 1 4 0) + 9 0.49 (Map.fromList [(0,0.55),(1,0.45)]) 0 + ls = vsLayers (toPlot dt) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MDAG + + -- ===================================================================== + -- Phase 75.27: 部分従属図 (PDP / ICE) + -- 純粋エンジンは PartialDependenceSpec で検証済。 ここは VisualSpec への + -- 落とし込み (line layer 数・grid・encY 値) を検証。 + -- ===================================================================== + describe "Phase 75.27: PDP / ICE (pdpPlot / partialDependencePlot)" $ do + -- 3 行 × 2 列。 列 0 = {0,1,2}, 列 1 = {10,20,30}。 + let trainX = LA.fromLists [[0, 10], [1, 20], [2, 30]] + -- 加法 predict f = 2*x0 + x1 → 特徴 0 の PDP = 2*grid + mean(x1) = 2*grid + 20。 + predict m = [ 2 * (row LA.! 0) + (row LA.! 1) | row <- LA.toRows m ] + + it "partialDependencePlot (閉包): 1 line layer・grid 40 点・PDP = 2*grid+20" $ do + let ls = vsLayers (partialDependencePlot trainX predict 0 "x0") + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MLine + case getLast (lyEncY (head ls)) of + Just (ColNum v) -> do + V.length v `shouldBe` 40 + abs (V.head v - 20) `shouldSatisfy` (< 1e-9) -- g=0 → 20 + abs (V.last v - 24) `shouldSatisfy` (< 1e-9) -- g=2 → 24 + _ -> expectationFailure "PDP line の encY が inline ColNum でない" + + it "partialDependenceIcePlot (閉包): ICE n 本 + PDP 1 本 = n+1 line layer" $ do + let ls = vsLayers (partialDependenceIcePlot trainX predict 0 "x0") + length ls `shouldBe` 4 -- 3 ICE + 1 PDP + all ((== Just MLine) . getFirst . lyKind) ls `shouldBe` True + + it "pdpPlot (RegPredict GBRegressor instance): line layer を出す" $ do + let t = RF.Node 0 0.5 (RF.Leaf 0) (RF.Leaf 1) + gb = GBRegressor { gbrInit = 0, gbrTrees = [t], gbrLR = 1 } + ls = vsLayers (pdpPlot gb trainX 0 "x0") + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MLine + + it "pdpOf (高レベル・df + 列名): 行列版 pdpPlot と一致" $ do + let t = RF.Node 0 0.5 (RF.Leaf 0) (RF.Leaf 1) + gb = GBRegressor { gbrInit = 0, gbrTrees = [t], gbrLR = 1 } + -- trainX = [[0,10],[1,20],[2,30]] を df 化。 + df = [ ("x0", NumData (V.fromList [0, 1, 2])) + , ("x1", NumData (V.fromList [10, 20, 30])) ] :: [(Text, ColData)] + encOf spec = getLast (lyEncY (head (vsLayers spec))) + encOf (pdpOf gb df ["x0","x1"] "x0") `shouldBe` encOf (pdpPlot gb trainX 0 "x0") + + it "pdpOf: target が featCols に無ければ空 spec" $ do + let t = RF.Node 0 0.5 (RF.Leaf 0) (RF.Leaf 1) + gb = GBRegressor { gbrInit = 0, gbrTrees = [t], gbrLR = 1 } + df = [ ("x0", NumData (V.fromList [0, 1, 2])) ] :: [(Text, ColData)] + vsLayers (pdpOf gb df ["x0"] "nope") `shouldBe` [] + + it "列外 index は空 spec" $ + vsLayers (partialDependencePlot trainX predict 9 "x9") `shouldBe` [] + + -- ===================================================================== + -- Phase 68 A3: 分類 (決定境界 + confusion + 代表散布) + -- KNNClassifier を直接構築 (1-NN・2 点) して構造を検証。 + -- ===================================================================== + describe "Phase 68 A3: ClassPredict / decisionBoundaryOf / confusionOf" $ do + let knn = KNNClassifier + { knnCK = 1 + , knnCX = LA.fromLists [[0, 0], [4, 4]] + , knnCY = VU.fromList [0, 1] + , knnCClasses = [0, 1] + , knnCClassNames = [] + } + + it "predictClasses (1-NN): 近い訓練点のクラスを返す" $ do + predictClasses knn (LA.fromLists [[0, 0], [4, 4], [0.5, 0.5], [3.6, 3.6]]) + `shouldBe` [0, 1, 0, 1] + + it "decisionBoundaryOf: res×res の annotRect grid で領域塗り (Phase 76.A)" $ do + let vs = decisionBoundaryOf knn (0, 4) (0, 4) 3 + -- layer は持たず (塗りは全て annotation)、 res² = 9 個の塗り矩形を敷き詰める。 + vsLayers vs `shouldBe` [] + length (vsAnnotations vs) `shouldBe` 9 + -- 全 annotation が AnnRect (塗り矩形) であること。 + let isAnnRect a = case a of AnnRect{} -> True; _ -> False + all isAnnRect (vsAnnotations vs) `shouldBe` True + -- 軸ドメインをグリッド範囲へ固定 (expand=FALSE・はみ出し防止)。 + getLast (vsCoordXLim vs) `shouldBe` Just (0, 4) + getLast (vsCoordYLim vs) `shouldBe` Just (0, 4) + + it "confusionOf: MHeatmap + MLabel (件数注釈)・セル数 = クラス数² (完全予測で対角)" $ do + let spec = confusionOf knn (LA.fromLists [[0, 0], [4, 4]]) [0, 1] + ls = vsLayers spec + map (getFirst . lyKind) ls `shouldBe` [Just MHeatmap, Just MLabel] -- Phase 75.2 + case getLast (lyEncY (head ls)) of + Just (ColTxt v) -> V.length v `shouldBe` 4 -- 2 クラス × 2 + _ -> expectationFailure "confusion の encY が inlineCat でない" + -- 件数注釈 (MLabel) は cells 数 (=4) の数値ラベルを持ち、 値は counts と一致 + -- (完全予測ゆえ対角 = [1,0,0,1] = (t,p)∈{(0,0),(0,1),(1,0),(1,1)} の件数)。 + case getLast (lyLabel (ls !! 1)) of + Just (ColTxt v) -> V.toList v `shouldBe` ["1", "0", "0", "1"] + _ -> expectationFailure "confusion 件数注釈の lyLabel が ColTxt でない" + + -- Phase 75.21: MDS モデル型 (df |-> mds) + 単色/群色 toPlot。 + it "df |-> mds: 埋め込みの散布点数 = n (toPlot m・単色)" $ do + let df = [ ("x1", NumData (V.fromList [0,1,5,6])) + , ("x2", NumData (V.fromList [0,1,5,6])) + , ("x3", NumData (V.fromList [0,1,5,6])) + , ("cls", NumData (V.fromList [0,0,1,1])) ] :: [(Text, ColData)] + m = df |-> mds defaultMDS ["x1","x2","x3"] + sl = head [ l | l <- vsLayers (toPlot m), getFirst (lyKind l) == Just MScatter ] + case getLast (lyEncX sl) of + Just (ColNum v) -> V.length v `shouldBe` 4 + _ -> expectationFailure "mds toPlot encX が ColNum でない" + + it "toPlot (mdsView m <> mdsGroupBy cls): 群色列が colorBy に乗る" $ do + let df = [ ("x1", NumData (V.fromList [0,1,5,6])) + , ("x2", NumData (V.fromList [0,1,5,6])) + , ("x3", NumData (V.fromList [0,1,5,6])) + , ("cls", TxtData (V.fromList ["a","a","b","b"])) ] :: [(Text, ColData)] + m = df |-> mds defaultMDS ["x1","x2","x3"] + sl = head [ l | l <- vsLayers (toPlot (mdsView m <> mdsGroupBy "cls")) + , getFirst (lyKind l) == Just MScatter ] + -- 群色列があれば lyColor (categorical) が入る。 + case getLast (lyColor sl) of + Just _ -> pure () + Nothing -> expectationFailure "mdsGroupBy で lyColor が入らない" + + it "nnLossOf: 損失曲線の点数 = epoch 数 (mlpLossHist)・MLPFit decisionBoundaryOf" $ do + let xMat = LA.fromLists [[0, 0], [0, 1], [4, 4], [4, 5]] + yLab = VU.fromList [0, 0, 1, 1] + gen <- MWC.initialize (V.fromList [7]) + fit <- fitMLPClassifier defaultMLP xMat yLab gen + let ln = head [ l | l <- vsLayers (nnLossOf fit), getFirst (lyKind l) == Just MLine ] + length (mlpLossHist fit) `shouldSatisfy` (> 0) + case getLast (lyEncX ln) of + Just (ColNum v) -> V.length v `shouldBe` length (mlpLossHist fit) + _ -> expectationFailure "nnLoss encX が ColNum でない" + length (vsAnnotations (decisionBoundaryOf fit (0, 4) (0, 5) 8)) `shouldBe` 64 + + -- Phase 75.8: 乱数純粋化 (NN は seed でビット一致)。 + it "fitMLPClassifierPure ≡ fitMLPClassifier (同 seed)・損失ビット一致" $ do + let xMat = LA.fromLists [[0, 0], [0, 1], [4, 4], [4, 5]] + yLab = VU.fromList [0, 0, 1, 1] + gen <- MWC.initialize (V.fromList [99]) + ioFit <- fitMLPClassifier defaultMLP xMat yLab gen + let pFit = fitMLPClassifierPure defaultMLP xMat yLab 99 + mlpLossHist pFit `shouldBe` mlpLossHist ioFit + + -- Phase 75.9: 高レベル df |-> (mlpCls)。 + it "df |-> mlpCls: MLPFit を返し損失曲線/決定境界が出る" $ do + let df2 = [ ("x1", NumData (V.fromList [0,0,4,4])) + , ("x2", NumData (V.fromList [0,1,4,5])) + , ("cls", NumData (V.fromList [0,0,1,1])) ] :: [(Text, ColData)] + m = df2 |-> mlpCls defaultMLP 7 ["x1","x2"] "cls" + length (mlpLossHist m) `shouldSatisfy` (> 0) + length (vsAnnotations (decisionBoundaryOf m (0,4) (0,5) 8)) `shouldBe` 64 + + -- Phase 75.11/75.12: カーネル SVM の高レベル + SV 可視化。 + it "df |-> svmCls: SVMMulti・非線形 decisionBoundaryOf・SV 強調" $ do + let df = [ ("x1", NumData (V.fromList [0,0.2,-0.2, 3,-3,0,0,2.1,-2.1])) + , ("x2", NumData (V.fromList [0,0.1,0.1, 0,0,3,-3,2.1,-2.1])) + , ("cls", NumData (V.fromList [0,0,0, 1,1,1,1,1,1])) ] :: [(Text, ColData)] + -- RBF・γ=0.5 ⇔ ℓ=1 (γ=1/(2ℓ²)・Phase 75.15 共有 Kernel)。 + m = df |-> svmCls defaultSVM + { svmKernel = RBF, svmParams = defaultKernelParams, svmC = 10 } + ["x1","x2"] "cls" + length (svmmClasses m) `shouldBe` 2 + length (vsAnnotations (decisionBoundaryOf m (-4,4) (-4,4) 8)) `shouldBe` 64 + let bin = head (svmmBinaries m) + sv = vsLayers (svmSupportVectorsOf bin) + numSupportVectors bin `shouldSatisfy` (> 0) + length sv `shouldSatisfy` (> 0) + -- 決定境界を線 (スコア=0 等高線) で: 内外を分ける曲線ゆえ segment が出る。 + length (vsLayers (decisionLineOf bin (-4,4) (-4,4) 40)) `shouldSatisfy` (> 0) + + it "KNNClassifier toPlot: 訓練点をラベル色で散布 (MScatter)" $ do + let ls = vsLayers (toPlot knn) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MScatter + case getLast (lyColor (head ls)) of + Just (ColorByCol (ColTxt v)) -> V.toList v `shouldBe` ["0", "1"] + _ -> expectationFailure "KNN 訓練散布の colorBy が ColTxt ラベルでない" + + -- ===================================================================== + -- Phase 68 A4: 次元圧縮 (PLS score/loading/VIP, MultiGP 多出力曲線) + -- ===================================================================== + describe "Phase 68 A4: PLS + MultiGP" $ do + let xP = LA.fromLists [[1,0],[0,1],[2,1],[1,2],[3,2]] -- 5×2 + yP = LA.fromLists [[1],[2],[3],[4],[5]] -- 5×1 + plsFit = either (error . T.unpack) id + (fitPLS defaultPLS { plsN_Components = 2 } xP yP) + + it "scoreView: 1 MScatter layer・点数 = 標本数 n" $ do + let ls = vsLayers (toPlot (scoreView plsFit)) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MScatter + case getLast (lyEncX (head ls)) of + Just (ColNum v) -> V.length v `shouldBe` 5 + _ -> expectationFailure "score plot の encX が inline ColNum でない" + + it "vipView: 1 MBar layer・本数 = 特徴数 p" $ do + let ls = vsLayers (toPlot (vipView plsFit)) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MBar + case getLast (lyEncY (head ls)) of + Just (ColNum v) -> V.length v `shouldBe` 2 + _ -> expectationFailure "VIP bar の encY が inline ColNum でない" + + it "multiGpCurves: 出力ごとに band+line の 2 layer (2 出力 → 4 layer)" $ do + let res = MultiGPResult + { mgpMean = [[1, 2, 3], [3, 2, 1]] + , mgpLower = [[0, 1, 2], [2, 1, 0]] + , mgpUpper = [[2, 3, 4], [4, 3, 2]] + , mgpModels = [] + } + ls = vsLayers (multiGpCurves res) + length ls `shouldBe` 4 + map (getFirst . lyKind) ls + `shouldBe` [Just MBand, Just MLine, Just MBand, Just MLine] + + it "MultiGPResult toPlot == multiGpCurves" $ do + let res = MultiGPResult + { mgpMean = [[1, 2]], mgpLower = [[0, 1]] + , mgpUpper = [[2, 3]], mgpModels = [] } + length (vsLayers (toPlot res)) `shouldBe` length (vsLayers (multiGpCurves res)) + + -- ===================================================================== + -- Phase 70.B2/B3: PLS effect plot (plsModel + statModelMulti + selectOutput) + -- ===================================================================== + describe "Phase 70.B2/B3: PLS effect plot + 出力セレクタ" $ do + -- 2 入力・2 出力。 y1 = 2*x1、 y2 = -3*x2 (出力で傾きの符号が違う = セレクタ確認用)。 + let n = 30 + x1 = [ fromIntegral i * 0.2 | i <- [1 .. n :: Int] ] + x2 = [ 1 + sin (fromIntegral i) | i <- [1 .. n :: Int] ] + y1 = [ 2 * a | a <- x1 ] + y2 = [ negate (3 * b) | b <- x2 ] + dfP = [ ("x1", NumData (V.fromList x1)), ("x2", NumData (V.fromList x2)) + , ("y1", NumData (V.fromList y1)), ("y2", NumData (V.fromList y2)) ] + :: [(Text, ColData)] + cfgP = defaultPLS { plsN_Components = 2 } + m = either error id (plsModel cfgP ["x1", "x2"] ["y1", "y2"] dfP) + -- effect plot の MLine layer の encY (μ 曲線) を取り出す + -- (ModelSpec は Plottable・データはモデル frame 内ゆえ df |>> 不要)。 + effLine mdl = + let ls = vsLayers (toPlot (statModelMulti mdl (along "x1"))) + ln = head [ l | l <- ls, getFirst (lyKind l) == Just MLine ] + in case getLast (lyEncY ln) of + Just (ColNum v) -> V.toList v + _ -> [] + + it "plsModel + statModelMulti: along 曲線 (MLine) を 1 本・band 非提供" $ do + let ls = vsLayers (toPlot (statModelMulti m (along "x1"))) + map (getFirst . lyKind) ls `shouldBe` [Just MLine] -- band 無し (PLS CI 非提供) + + it "selectOutput: 第0出力 (y1) は x1 増で増加・既定と一致" $ do + let muDefault = effLine m + muY1 = effLine (selectOutput "y1" m) + muDefault `shouldSatisfy` allClose muY1 -- 既定 = 第0出力 + head muY1 `shouldSatisfy` (< last muY1) -- y1 ∝ +x1 → 単調増 + + it "selectOutput: 第1出力 (y2) は第0出力と異なる曲線 (出力選択が効く)" $ do + let muY1 = effLine (selectOutput "y1" m) + muY2 = effLine (selectOutput "y2" m) + (muY1 == muY2) `shouldBe` False -- 出力で曲線が変わる + + it "selectOutput: 未知の出力名は無変更 (既定 = 第0出力のまま)" $ do + effLine (selectOutput "nope" m) `shouldSatisfy` allClose (effLine m) + + -- ===================================================================== + -- Phase 68 A5: 時系列・生存・FDA (GARCH / AFT / FunctionalPCA / FLM) + -- ===================================================================== + describe "Phase 68 A5: GARCH / AFT / FDA" $ do + it "GARCHFit toPlot: band + line の 2 layer・hi ≥ lo" $ do + let gf = GARCHFit { gOmega = 0.1, gAlpha = 0.1, gBeta = 0.8, gMu = 0 + , gSigma2 = LA.fromList [1, 4, 1] + , gResiduals = LA.fromList [0.5, -1, 0.2], gLogLik = 0 } + ls = vsLayers (garchVolatility gf) + length ls `shouldBe` 2 + map (getFirst . lyKind) ls `shouldBe` [Just MBand, Just MLine] + case (getLast (lyEncY (head ls)), getLast (lyEncY2 (head ls))) of + (Just (ColNum lo), Just (ColNum hi)) -> + zipWith (-) (V.toList hi) (V.toList lo) `shouldSatisfy` all (>= 0) + _ -> expectationFailure "GARCH band の encY/encY2 が ColNum でない" + + it "AFTFit toPlot: 生存曲線 S(t) は [0,1]・単調非増加・始点 ≈ 1" $ do + let af = AFTFit { aftBeta = LA.fromList [1, 0.5], aftScale = 1 + , aftLogLik = 0, aftDistribution = AFTWeibull, aftIters = 1 } + ls = vsLayers (toPlot af) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MLine + case getLast (lyEncY (head ls)) of + Just (ColNum v) -> do + let ss = V.toList v + all (\s -> s >= -1e-9 && s <= 1 + 1e-9) ss `shouldBe` True + and (zipWith (>=) ss (drop 1 ss)) `shouldBe` True -- 単調非増加 + head ss `shouldSatisfy` (> 0.9) + _ -> expectationFailure "AFT survival の encY が ColNum でない" + + it "aftSurvivalAt: 共変量を変えると線形予測子で生存が変わる" $ do + let af = AFTFit { aftBeta = LA.fromList [1, 0.5], aftScale = 1 + , aftLogLik = 0, aftDistribution = AFTWeibull, aftIters = 1 } + length (vsLayers (aftSurvivalAt af [1, 2])) `shouldBe` 1 + + it "FunctionalPCA toPlot: 平均 + 上位固有関数 (≤3) を line 重畳 (4 layer)" $ do + let fpca = FunctionalPCA + { fpcaScores = LA.fromLists [[1, 0, 0]] + , fpcaEigenfn = LA.fromLists [[0,1,2],[2,1,0],[1,1,1],[0,0,1]] -- 4 PC + , fpcaEigenvalues = LA.fromList [4, 2, 1, 0.5] + , fpcaMeanFn = LA.fromList [1, 2, 3] } + ls = vsLayers (toPlot fpca) + length ls `shouldBe` 4 -- mean + 上位 3 PC + all (\l -> getFirst (lyKind l) == Just MLine) ls `shouldBe` True + + it "FLMResult toPlot: β(t) を 1 MLine" $ do + let flm = FLMResult { flmAlpha = 0, flmBetaFn = LA.fromList [0.1, 0.3, 0.2] + , flmFitted = LA.fromList [1, 2], flmR2 = 0.8 } + ls = vsLayers (toPlot flm) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MLine + + -- ===================================================================== + -- Phase 68 A6: 罰則回帰・因果 (RegFit bar / 係数パス / LiNGAM DAG) + -- ===================================================================== + describe "Phase 68 A6: Regularized + LiNGAM" $ do + it "RegFit toPlot: 係数 bar (本数 = β の長さ)" $ do + let rf = RegFit { rfBeta = LA.fromList [0.5, 1.2, 0] + , rfYHat = LA.fromList [1], rfResid = LA.fromList [0] + , rfR2 = 0.9, rfPenalty = NoPen, rfNonZero = 2, rfIters = 0 } + ls = vsLayers (toPlot rf) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MBar + case getLast (lyEncY (head ls)) of + Just (ColNum v) -> V.length v `shouldBe` 3 + _ -> expectationFailure "RegFit bar の encY が ColNum でない" + + it "regPathPlot: 係数ごとに 1 line (2 係数 → 2 layer)" $ do + let path = [ (0.1, [3.0, 1.0]), (0.5, [2.0, 0.5]), (1.0, [0.0, 0.0]) ] + ls = vsLayers (regPathPlot path) + length ls `shouldBe` 2 + all (\l -> getFirst (lyKind l) == Just MLine) ls `shouldBe` True + + it "regPathPlot: 空パスは mempty" $ do + vsLayers (regPathPlot []) `shouldBe` [] + + it "DirectLiNGAMFit toPlot: 因果 DAG を MDAG 1 layer (x0->x1->x2)" $ do + let adj = LA.fromLists [[0,0,0],[1,0,0],[0,1,0]] -- edge 0->1, 1->2 + fit = DirectLiNGAMFit { dlOrder = [0,1,2], dlB = adj, dlAdjacency = adj + , dlResiduals = LA.fromLists [[0,0,0]] } + ls = vsLayers (toPlot fit) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MDAG + + -- Phase 77.A: 高レベル df |-> directLingam (変数名保持・名前付き DAG)。 + it "df |-> directLingam: 変数名保持・低レベル fit と一致・toPlot は名前付き MDAG" $ do + let xs0 = [0.5, -0.3, 0.8, -0.6, 0.2, -0.9, 0.7, -0.1] + xs1 = [1.1, -0.5, 1.7, -1.3, 0.3, -1.9, 1.5, -0.4] -- ≈ 2·xs0 + 揺らぎ + xs2 = [-1.5, 0.8, -2.4, 2.0, -0.6, 2.7, -2.1, 0.5] -- ≈ -1.5·xs1 + 揺らぎ + df = [ ("smoking", NumData (V.fromList xs0)) + , ("tar", NumData (V.fromList xs1)) + , ("cancer", NumData (V.fromList xs2)) ] :: [(Text, ColData)] + mat = LA.fromColumns [LA.fromList xs0, LA.fromList xs1, LA.fromList xs2] + fitted = df |-> directLingam defaultDirectLiNGAMConfig ["smoking","tar","cancer"] + lfNames fitted `shouldBe` ["smoking","tar","cancer"] + -- df|-> は低レベル fitDirectLiNGAM と同一 (列名経路と行列経路が一致) + LA.toLists (dlAdjacency (lfFit fitted)) + `shouldBe` LA.toLists (dlAdjacency (fitDirectLiNGAM defaultDirectLiNGAMConfig mat)) + -- toPlot は名前付き DAG (1 MDAG layer) + let ls2 = vsLayers (toPlot fitted) + length ls2 `shouldBe` 1 + getFirst (lyKind (head ls2)) `shouldBe` Just MDAG + + -- Phase 77.B: Parce / MultiGroup も高レベル df|-> + 名前付き DAG。 + it "df |-> parceLingam: 変数名保持・toPlot は名前付き MDAG" $ do + let xs0 = [0.5,-0.3,0.8,-0.6,0.2,-0.9,0.7,-0.1,0.4,-0.5] + xs1 = [1.1,-0.5,1.7,-1.3,0.3,-1.9,1.5,-0.4,0.9,-1.0] + xs2 = [-1.5,0.8,-2.4,2.0,-0.6,2.7,-2.1,0.5,-1.2,1.4] + df = [ ("a", NumData (V.fromList xs0)), ("b", NumData (V.fromList xs1)) + , ("c", NumData (V.fromList xs2)) ] :: [(Text, ColData)] + fitted = df |-> parceLingam defaultParceConfig ["a","b","c"] + lfNames fitted `shouldBe` ["a","b","c"] + getFirst (lyKind (head (vsLayers (toPlot fitted)))) `shouldBe` Just MDAG + + it "df |-> multiGroupLingam: group 列で分割・共通 DAG (名前付き MDAG)" $ do + let g0x0 = [0.5,-0.3,0.8,-0.6,0.2,-0.9]; g0x1 = [1.1,-0.5,1.7,-1.3,0.3,-1.9] + g1x0 = [0.4,-0.5,0.7,-0.2,0.6,-0.8]; g1x1 = [0.9,-1.0,1.5,-0.4,1.2,-1.6] + df = [ ("a", NumData (V.fromList (g0x0 ++ g1x0))) + , ("b", NumData (V.fromList (g0x1 ++ g1x1))) + , ("grp", NumData (V.fromList (replicate 6 0 ++ replicate 6 1))) ] :: [(Text, ColData)] + fitted = df |-> multiGroupLingam defaultMultiGroupConfig ["a","b"] "grp" + lfNames fitted `shouldBe` ["a","b"] + getFirst (lyKind (head (vsLayers (toPlot fitted)))) `shouldBe` Just MDAG + + it "df |-> varLingam: 時系列因果・toPlot は時間ラグ MDAG" $ do + let n = 40 :: Int + ea = [ sin (fromIntegral i * 0.7) | i <- [1..n] ] + eb = [ cos (fromIntegral i * 0.9) | i <- [1..n] ] + go (aP,bP) (x,y) = let a = 0.5*aP + x; b = 0.6*a + 0.3*bP + 0.3*y in (a,b) + ps = tail (scanl go (0,0) (zip ea eb)) + df = [ ("a", NumData (V.fromList (map fst ps))) + , ("b", NumData (V.fromList (map snd ps))) ] :: [(Text, ColData)] + fitted = df |-> varLingam defaultVARLiNGAMConfig ["a","b"] + lfNames fitted `shouldBe` ["a","b"] + getFirst (lyKind (head (vsLayers (toPlot fitted)))) `shouldBe` Just MDAG + + it "df |-> pairwiseLingam: 2 変数の向き・toPlot は 2 ノード MDAG" $ do + let xs = [0.5,-0.3,0.8,-0.6,0.2,-0.9,0.7,-0.1,0.4,-0.5] + ys = map (\v -> 2.0*v) xs -- x → y (関数従属で向き明確) + df = [ ("x", NumData (V.fromList xs)), ("y", NumData (V.fromList ys)) ] :: [(Text, ColData)] + fitted = df |-> pairwiseLingam 0.0 "x" "y" + lfNames fitted `shouldBe` ["x","y"] + getFirst (lyKind (head (vsLayers (toPlot fitted)))) `shouldBe` Just MDAG + + -- Phase 77.C: Bootstrap / ICA の seed 純粋版 (IO とビット一致) + 高レベル + plot。 + let semABC = let xs0 = [0.5,-0.3,0.8,-0.6,0.2,-0.9,0.7,-0.1,0.4,-0.5,0.3,-0.7] + xs1 = zipWith (\a i -> 2.0*a + 0.2*sin (fromIntegral i)) xs0 [0..] + xs2 = zipWith (\b i -> -1.5*b + 0.2*cos (fromIntegral i)) xs1 [0..] + in (xs0, xs1, xs2) + (sa, sb, sc) = semABC + semMat = LA.fromColumns [LA.fromList sa, LA.fromList sb, LA.fromList sc] + semDF = [ ("a", NumData (V.fromList sa)), ("b", NumData (V.fromList sb)) + , ("c", NumData (V.fromList sc)) ] :: [(Text, ColData)] + bcfg = defaultBootstrapConfig { bcNumBootstraps = 20 } + + it "fitBootstrapLiNGAMPure ≡ fitBootstrapLiNGAM (同 seed・edge 確率ビット一致)" $ do + ioRes <- fitBootstrapLiNGAM bcfg semMat + let pRes = fitBootstrapLiNGAMPure bcfg semMat + LA.toLists (brEdgeProbability pRes) `shouldBe` LA.toLists (brEdgeProbability ioRes) + + it "df |-> bootstrapLingam: 確信度 DAG (MDAG) + edge 確率ヒートマップ (MHeatmap)" $ do + let fitted = semDF |-> bootstrapLingam bcfg ["a","b","c"] + lfNames fitted `shouldBe` ["a","b","c"] + getFirst (lyKind (head (vsLayers (toPlot fitted)))) `shouldBe` Just MDAG + getFirst (lyKind (head (vsLayers (bootstrapEdgeProbOf fitted)))) `shouldBe` Just MHeatmap + + it "fitICALiNGAMPure ≡ fitICALiNGAM (同 seed・adjacency ビット一致)" $ do + ioFit <- fitICALiNGAM defaultICALiNGAMConfig semMat + let pFit = fitICALiNGAMPure defaultICALiNGAMConfig semMat + LA.toLists (ilAdjacency pFit) `shouldBe` LA.toLists (ilAdjacency ioFit) + + it "df |-> icaLingam: 名前付き DAG (MDAG)" $ do + let fitted = semDF |-> icaLingam defaultICALiNGAMConfig ["a","b","c"] + lfNames fitted `shouldBe` ["a","b","c"] + getFirst (lyKind (head (vsLayers (toPlot fitted)))) `shouldBe` Just MDAG + + -- Phase 77: 相関ネットワーク (高レベル df|-> correlationOf → toPlot)。 + it "df |-> correlationOf: 相関行列 (対角=1) + toPlot は相関グラフ (MDAG)" $ do + let cg = semDF |-> correlationOf 0.3 ["a","b","c"] + cgNames cg `shouldBe` ["a","b","c"] + cgThreshold cg `shouldBe` 0.3 + -- 相関行列の対角は 1 (自己相関) + [ cgCorr cg `LA.atIndex` (i,i) | i <- [0..2] ] `shouldSatisfy` all ((< 1e-9) . abs . subtract 1) + getFirst (lyKind (head (vsLayers (toPlot cg)))) `shouldBe` Just MDAG + + -- Phase 78.C/D/F: DOE prediction profiler (行=応答 × 列=因子・toPlot + <> オプション)。 + it "multiOutput + profiler: 応答×因子ぶんの subplots (2 応答 × 2 因子 = 4)" $ do + let plan = factorialDesign [contFactor "a" (0,1), contFactor "b" (0,1)] + rs = designTable plan + av = maybe [] id (lookup "a" rs); bv = maybe [] id (lookup "b" rs) + y1 = zipWith (\x y -> 1 + 2*x + 3*y) av bv + y2 = zipWith (\x y -> 5 + x - y) av bv + df = [ (n, NumData (V.fromList v)) + | (n,v) <- ("y1",y1):("y2",y2):rs ] :: [(Text,ColData)] + models = df |-> multiOutput ["y1","y2"] (designModel plan) + vs = toPlot (profiler models ["a","b"]) + length models `shouldBe` 2 -- multiOutput = [(応答名, モデル)] + map fst models `shouldBe` ["y1","y2"] + length (vsSubplots vs) `shouldBe` 4 -- 2 応答 × 2 因子 + all (not . null . vsLayers) (vsSubplots vs) `shouldBe` True + + it "profiler: 空 models / 空 factors は mempty (subplots なし)" $ do + let plan = factorialDesign [contFactor "a" (0,1)] + rs = designTable plan + av = maybe [] id (lookup "a" rs) + df = [ (n, NumData (V.fromList v)) | (n,v) <- ("y",av):rs ] :: [(Text,ColData)] + models = df |-> multiOutput ["y"] (designModel plan) + vsSubplots (toPlot (profiler models [])) `shouldBe` [] + vsSubplots (toPlot (profiler [] ["a"] :: ProfilerSpec MultiLMModel)) `shouldBe` [] + + it "profilerResidual: <> で打点モードが後勝ち合成 (Semigroup)" $ do + psResidual (profiler [] [] <> profilerResidual Partial :: ProfilerSpec MultiLMModel) + `shouldBe` Just Partial + psResidual (profilerResidual Raw <> profilerResidual Partial :: ProfilerSpec MultiLMModel) + `shouldBe` Just Partial -- 右 (後) 勝ち + psResidual (profiler [] [] :: ProfilerSpec MultiLMModel) + `shouldBe` Nothing -- 既定 (= Raw) + + -- Phase 78.G-e: FRR/HBM 化 (GP/RFF)。MultiVarModel GPRegModelN で profiler/contour に + -- GP 事後予測帯を出す。分布あり象限 (Gp/GpRff) は帯、mean のみ象限 (Krr) は帯なし。 + it "profiler (GP): 応答×因子の subplots + Gp は予測帯・Krr は帯なし" $ do + let plan = factorialDesign [contFactor "a" (0,1), contFactor "b" (0,1)] + rs = designTable plan + av = maybe [] id (lookup "a" rs); bv = maybe [] id (lookup "b" rs) + y = zipWith (\x z -> 1 + 2*x + 3*z) av bv + df = [ (n, NumData (V.fromList v)) | (n,v) <- ("y",y):rs ] :: [(Text,ColData)] + mGp = df |-> gpMulti (GPConfig RBF Gp AutoMarginalLik) ["a","b"] "y" + mKrr = df |-> gpMulti (GPConfig RBF Krr AutoMarginalLik) ["a","b"] "y" + panelLayers mm = + length (vsLayers (head (vsSubplots (toPlot (profiler [("y", mm)] ["a"]))))) + length (vsSubplots (toPlot (profiler [("y", mGp)] ["a","b"]))) `shouldBe` 2 + panelLayers mGp `shouldSatisfy` (> panelLayers mKrr) -- Gp = 帯レイヤぶん多い + + -- Phase 78.E: RSM 等高線 / 応答曲面 (contourFilled + contour の 2 層)。 + it "contourOf: 塗り等値帯 (MContourFilled) + 等高線 (MContour) の 2 層" $ do + let plan = centralCompositeDesign [contFactor "a" (0,1), contFactor "b" (0,1)] + rs = designTable plan + av = maybe [] id (lookup "a" rs); bv = maybe [] id (lookup "b" rs) + ys = zipWith (\x y -> 1 + 2*x + 3*y + x*y) av bv + df = [ (n, NumData (V.fromList v)) | (n,v) <- ("y",ys):rs ] :: [(Text,ColData)] + m = df |-> designModel plan "y" + ls = vsLayers (contourOf m "a" "b") + length ls `shouldBe` 2 + map (getFirst . lyKind) ls `shouldBe` [Just MContourFilled, Just MContour] + + -- ===================================================================== + -- Phase 68 A7: 記述統計・検定 (test forest / describe box) + -- ===================================================================== + describe "Phase 68 A7: TestResult forest + describeBox" $ do + let mkTest nm ci = TestResult + { trMethod = nm, trStatistic = 2.0 + , trDf = Just (10, Nothing), trPValue = 0.04 + , trEffect = Just ("d", 0.8), trCI = ci + , trAlternative = TwoSided, trNote = Nothing } + + it "TestResult toPlot: CI 付き検定を 1 行 forest (MForest)" $ do + let ls = vsLayers (toPlot (mkTest "t-test" (Just (0.2, 1.4)))) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MForest + + it "testForest: CI を持たない検定は除外 (全滅なら mempty)" $ do + vsLayers (testForest [mkTest "a" Nothing, mkTest "b" Nothing]) `shouldBe` [] + + it "testForestLabeled: CI 中心=点推定・半幅=誤差 (1 行 forest)" $ do + let ls = vsLayers (testForestLabeled [("A vs B", mkTest "t" (Just (-1.0, 0.2)))]) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MForest + + it "describeBox: 生データ列を box plot (MBox)" $ do + let ls = vsLayers (describeBox [1, 2, 3, 4, 5, 6, 7]) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MBox + + -- ===================================================================== + -- Phase 72.4/72.5: 回帰診断の可視化 (実測vs予測 / 係数 forest) + -- ===================================================================== + describe "Phase 72.4/72.5: obsVsPred + coefForest (回帰診断の可視化)" $ do + + it "obsVsPred: y=x 参照線 (MLine) + 散布 (MScatter) の 2 layer" $ do + let ls = vsLayers (obsVsPred m) + length ls `shouldBe` 2 + getFirst (lyKind (ls !! 0)) `shouldBe` Just MLine -- 参照線が下 + getFirst (lyKind (ls !! 1)) `shouldBe` Just MScatter -- 散布が上 + + it "obsVsPred: 散布の (x=実測, y=予測) は obsPredPairs と一致" $ do + let (obs, prd) = obsPredPairs m + sl = vsLayers (obsVsPred m) !! 1 + case (getLast (lyEncX sl), getLast (lyEncY sl)) of + (Just (ColNum vx), Just (ColNum vy)) -> do + V.toList vx `shouldSatisfy` allClose obs + V.toList vy `shouldSatisfy` allClose prd + _ -> expectationFailure "scatter encX/encY が inline ColNum でない" + + it "obsPredPairs: 完全線形 fit は 実測 == 予測" $ do + let (obs, prd) = obsPredPairs m + prd `shouldSatisfy` allClose obs + + it "obsVsPred: y=x 参照線は (lo,hi)→(lo,hi) の 2 点 (傾き 1)" $ do + let l = head (vsLayers (obsVsPred m)) + case (getLast (lyEncX l), getLast (lyEncY l)) of + (Just (ColNum vx), Just (ColNum vy)) -> do + V.length vx `shouldBe` 2 + V.toList vx `shouldBe` V.toList vy -- y = x + _ -> expectationFailure "参照線 encX/encY が inline ColNum でない" + + it "coefForest: 係数表を 1 行 forest (MForest)" $ do + let ls = vsLayers (coefForest m) + length ls `shouldBe` 1 + getFirst (lyKind (head ls)) `shouldBe` Just MForest + + it "coefForest: 点推定 (encX) は coefSummary の crEstimate と一致 ([1,2])" $ do + let l = head (vsLayers (coefForest m)) + case getLast (lyEncX l) of + Just (ColNum v) -> V.toList v `shouldSatisfy` allClose (map crEstimate (coefSummary m)) + _ -> expectationFailure "forest encX が inline ColNum でない" + + it "coefForest: 誤差 (errorX) は CI 半幅 = (hi-lo)/2 と一致" $ do + let l = head (vsLayers (coefForest m)) + halfCIs = [ (hi - lo) / 2 | r <- coefSummary m, let (lo, hi) = crCI95 r ] + case getLast (lyErrorX l) of + Just (ColNum v) -> V.toList v `shouldSatisfy` allClose halfCIs + _ -> expectationFailure "forest errorX が inline ColNum でない" + + -- ========================================================================== + -- Phase 106.4: umbrella の WorkflowSpec から移行した plot 連携診断テスト + -- (旧 #ifdef PLOT_INTEGRATION 節。 umbrella component は hanalyze-plot に + -- 依存できない = package 循環のため、 本 suite が正式な置き場)。 + describe "Design.Workflow x plot 連携 (Phase 78.J / 78.G-f Task 4)" $ do + + -- Phase 78.J: designModelHBM の学習済 HBM を dhfModel で露出し、 診断抽出子 + -- (tracesOf / dagOf 等) に渡せる (DesignHBMFit から診断が出せる)。 + it "designModelHBM: dhfModel で診断 (tracesOf) が出せる" $ do + let temps = [-1, 1, -1, 1, -1, 1, -1, 1] :: [Double] + lots = ["A","A","A","A","B","B","B","B"] :: [T.Text] + yv = [ 2 + 3 * t + (if l == "A" then -1 else 1) | (t, l) <- zip temps lots ] + df = DX.insertColumn "lot" (DX.fromList lots) + $ DX.insertColumn "temp" (DX.fromList temps) + $ DX.insertColumn "y" (DX.fromList yv) + $ DX.empty + plan = factorialDesign [contFactor "temp" (-1, 1)] + mWk = df |-> designModelHBM defaultHBM plan [ranIntercept "lot"] "y" + length (tracesOf (dhfModel mWk)) `shouldSatisfy` (> 0) -- param ごとの trace が出る + + -- Phase 78.G-f Task 4: profiler/contour が designModelHBM に載る事後予測帯。 + -- designMatrixF (dhfFormula mWk) ef を直接叩き、 fit 時と同じ列順の設計行列を作る + -- ( evalFrameAt 相当の helper は無いので eval ModelFrame を手組みする)。 + -- ★mfParams (合成パラメータ名 "_p0"/"_p1"…) は formula 内部表現なので手で推測せず、 + -- 訓練済 'dhfFrame' (= mvFrame mWk) を土台に mfRoles/mfNRows だけ差し替える + -- (本番の Core.hs evalFrame と同じ据え置き方)。 + it "MultiVarModel DesignHBMFit は事後予測帯を返す" $ do + let temps = [-1, 1, -1, 1, -1, 1, -1, 1, -1, 1, -1, 1] :: [Double] + lots = ["A","A","A","A","A","A","B","B","B","B","B","B"] :: [T.Text] + noise = [0.05, -0.03, 0.02, -0.04, 0.01, -0.02, 0.03, -0.01, 0.04, -0.05, 0.02, -0.03] + lotShift l = if l == "A" then (-1.0) else 1.0 + yv = [ 2 + 3 * t + lotShift l + e + | (t, l, e) <- zip3 temps lots noise ] + mkFrameHBM = DX.insertColumn "lot" (DX.fromList lots) + $ DX.insertColumn "temp" (DX.fromList temps) + $ DX.insertColumn "y" (DX.fromList yv) + $ DX.empty + plan = factorialDesign [contFactor "temp" (-1, 1)] + mWk = mkFrameHBM |-> designModelHBM defaultHBM plan [ranIntercept "lot"] "y" + ef = (mvFrame mWk) + { mfRoles = [ ("y", RoleResponse (V.fromList [0, 0, 0])) + , ("temp", RoleContinuous (V.fromList [-1, 0, 1])) + ] + , mfNRows = 3 + } + (mu, band) = mvEvalFrame mWk 0.95 ef + length mu `shouldBe` 3 + band `shouldSatisfy` isJust + -- 中心 μ は temp とともに増加 (真の傾き ≈ 3)。 + (last mu - head mu) `shouldSatisfy` (> 3)