diff --git a/README.ja.md b/README.ja.md new file mode 100644 --- /dev/null +++ b/README.ja.md @@ -0,0 +1,143 @@ +# hanalyze-models + +[`hanalyze`](../README.ja.md) の**モデル層**。 古典的な回帰から +機械学習・多変量解析・時系列・生存/信頼性・因果推論までの **model zoo** を +担う、 分割 6 層で最も大きい package (67 module)。 + +依存は `core` (数値基盤) / `frame` (dataframe interop) / `bayes` (MCMC) の +3 層 + 外部 12 package。 `-design` (DoE) と `-viz` はこの層の上に乗る。 +Formula DSL のパーサを持つため `megaparsec` に依存するのはこの層だけ。 + +## 主要 module (全 67 module) + +### 回帰の基本 (`Hanalyze.Model.*`) + +| Module | 役割 | +|---|---| +| `Model.LM` / `Model.LM.Diagnostics` | 最小二乗回帰と残差診断 (てこ比 / Cook 距離 / VIF) | +| `Model.GLM` / `Model.GLMM` | IRLS による GLM (Gaussian / Binomial / Poisson を統一) と混合効果 GLM | +| `Model.MultiLM` | 多出力線形回帰 | +| `Model.Regularized` / `Model.RegularizedAdvanced` | Lasso / Ridge / Elastic Net + MCP / SCAD / Adaptive / Group。 λ は k-fold CV + 1-SE ルールで自動選択 | +| `Model.Robust` / `Model.Quantile` | M 推定によるロバスト回帰 / 分位点回帰 | +| `Model.Spline` / `Model.GAM` | スプライン平滑化 / 一般化加法モデル | + +### Formula DSL (`Model.Formula.*`) + +| Module | 役割 | +|---|---| +| `Model.Formula` | **Formula DSL 正本 front-end** の parser と AST (`y ~ x1 + x2*x3`) | +| `Model.Formula.Design` / `.Frame` | AST → model matrix / dataframe との結合 | +| `Model.Formula.Mixed` / `.Nonlinear` / `.RFormula` | 混合効果 / 非線形項 / R 互換 formula の解釈 | + +### 多変量・次元圧縮 + +| Module | 役割 | +|---|---| +| `Model.PCA` | 主成分分析 (応答を使わない分散最大化) | +| `Model.PLS` | 部分最小二乗回帰 — 応答との共分散を最大化 + VIP + CV による成分数選択 | +| `Model.Discriminant` | 判別分析 (LDA = 線形境界 / QDA = 二次境界) | +| `Model.Multivariate` | RRR / PLS / CCA の多変量回帰族 | +| `Model.MDS` / `Model.FDA` | 多次元尺度構成法 / 関数データ解析 | +| `Model.Cluster` / `Model.HierarchicalCluster` / `Model.LatentClassAnalysis` | k-means / 階層クラスタリング / 潜在クラス分析 | + +### 機械学習 + +| Module | 役割 | +|---|---| +| `Model.RandomForest` / `Model.RandomForestClassifier` | ランダムフォレスト (回帰 / 分類) | +| `Model.DecisionTree` / `Model.GradientBoosting` | 決定木 / 勾配ブースティング | +| `Model.SVM` / `Model.KNN` / `Model.NaiveBayes` / `Model.NeuralNetwork` | SVM / k 近傍 / 単純ベイズ / NN | +| `Model.Kernel` / `Model.KernelRegression` | カーネル関数群 / カーネル回帰 | +| `Model.PartialDependence` | PDP / ICE によるモデル解釈 | + +### ガウス過程・多出力 + +| Module | 役割 | +|---|---| +| `Model.GP` / `Model.GPRobust` | GP 回帰 (RBF / Matérn / Periodic + ARD) / 外れ値に強い GP | +| `Model.MultiGP` / `Model.MultiOutput` | 多出力 GP / 多出力回帰の統合 API | +| `Model.RFF` | Random Fourier Features による大規模 GP 近似 | + +### 時系列 + +| Module | 役割 | +|---|---| +| `Model.TimeSeries` | ARIMA 系の入口 | +| `Model.VAR` / `Model.GARCH` / `Model.StateSpace` | ベクトル自己回帰 / GARCH / 状態空間モデル (カルマンフィルタ) | + +### 生存時間・信頼性 + +| Module | 役割 | +|---|---| +| `Model.Survival` | Kaplan-Meier / Cox 比例ハザード | +| `Model.AFT` / `Model.CompetingRisks` | 加速故障時間モデル / 競合リスク (CIF) | +| `Model.Weibull` | Weibull MLE (打ち切り対応) + B_p 寿命 + Wald 信頼区間 | +| `Model.Reliability` | 加速寿命試験 (Arrhenius / Eyring / Inverse Power Law) | +| `Model.ReliabilityBlockDiagram` | 直列 / 並列 / k-of-n の系統信頼度 | + +### 因果推論 + +| Module | 役割 | +|---|---| +| `Model.LiNGAM.Direct` / `.ICA` / `.Pairwise` / `.Parce` | 非ガウス性を使った構造推定 (DirectLiNGAM / ICA-LiNGAM 等) | +| `Model.LiNGAM.VAR` / `.Bootstrap` / `.MultiGroup` | 時系列版 / ブートストラップ信頼度 / 多群同時推定 | +| `Model.DAG` | DAG の表現と探索 | +| `Stat.Causal.PropensityScore` / `.IPW` / `.DoublyRobust` / `.CATE` | 傾向スコア / IPW / 二重ロバスト推定 / 条件付き平均処置効果 | + +### その他 + +| Module | 役割 | +|---|---| +| `Model.FitYByX` | JMP の "Fit Y by X" 相当 — 変数の型の組合せから手法を自動選択 | +| `Stat.ModelSelect` | AIC / BIC によるモデル選択 | +| `Optim.BayesOpt` | ベイズ最適化 (GP + 獲得関数)。 GP を使うためこの層に置く | + +## 単体で使う + +umbrella が不要なら、 この package を直接依存に書ける。 結果型 +`FitResult` は core 層にあるため、 **`hanalyze-core` も明示的に要る**: + +```cabal +build-depends: hanalyze-models, hanalyze-core, hmatrix +``` + +```haskell +import qualified Numeric.LinearAlgebra as LA +import Hanalyze.Model.Core (FitResult (..)) +import Hanalyze.Model.LM (fitLM) + +main :: IO () +main = do + let x = LA.fromLists [ [1, 1.0], [1, 2.0], [1, 3.0], [1, 4.0], [1, 5.0] ] + y = LA.fromLists [ [2.1], [3.9], [6.2], [7.8], [10.1] ] + fit = fitLM x y + print (LA.toLists (coefficients fit)) + print (LA.toList (rSquared fit)) + -- [[5.000000000000132e-2],[1.9899999999999998]] + -- [0.9973053289009771] +``` + +切片列 (`1`) は自分で入れる。 formula から model matrix を作るなら +`Model.Formula` を使う。 + +なお、 通常は umbrella package `hanalyze` を依存に書けば +`import Hanalyze` だけで上記もすべて使える。 層を直接指定するのは +依存を最小化したいときのみで十分。 + +## 関連 docs + +- 線形回帰: [docs/regression/01-lm.ja.md](../docs/regression/01-lm.ja.md) / + GLM: [02-glm.ja.md](../docs/regression/02-glm.ja.md) +- 罰則付き回帰: [04-regularized.ja.md](../docs/regression/04-regularized.ja.md) / + [usage-regularized-advanced.ja.md](../docs/regression/usage-regularized-advanced.ja.md) +- PLS: [usage-pls.ja.md](../docs/regression/usage-pls.ja.md) / + 判別分析 (LDA·QDA): [usage-discriminant.ja.md](../docs/regression/usage-discriminant.ja.md) +- Weibull / B_p 寿命: [usage-weibull.ja.md](../docs/regression/usage-weibull.ja.md) / + 加速寿命試験: [usage-reliability.ja.md](../docs/regression/usage-reliability.ja.md) +- 生存時間解析: [10-survival.ja.md](../docs/regression/10-survival.ja.md) / + 多出力: [05-multivariate.ja.md](../docs/regression/05-multivariate.ja.md) +- Formula DSL: [11-formula-dsl.ja.md](../docs/regression/11-formula-dsl.ja.md) +- 因果推論: [docs/causal/](../docs/causal/) / + ベイズ最適化: [docs/optim/01-singleobj.ja.md](../docs/optim/01-singleobj.ja.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,146 @@ +# hanalyze-models + +The **model layer** of [`hanalyze`](../README.md). It owns the +**model zoo** — everything from classical regression through machine +learning, multivariate analysis, time series, survival/reliability, and +causal inference. It is the largest of the six split layers (67 modules). + +It depends on the three layers `core` (numerical foundation) / `frame` +(dataframe interop) / `bayes` (MCMC), plus 12 external packages. `-design` +(DoE) and `-viz` sit on top of this layer. It is the only layer that depends +on `megaparsec`, since it owns the Formula DSL parser. + +## Main modules (67 in total) + +### Basic regression (`Hanalyze.Model.*`) + +| Module | Role | +|---|---| +| `Model.LM` / `Model.LM.Diagnostics` | Least-squares regression and residual diagnostics (leverage / Cook's distance / VIF) | +| `Model.GLM` / `Model.GLMM` | GLM by IRLS (unifying Gaussian / Binomial / Poisson) and mixed-effects GLM | +| `Model.MultiLM` | Multi-output linear regression | +| `Model.Regularized` / `Model.RegularizedAdvanced` | Lasso / Ridge / Elastic Net + MCP / SCAD / Adaptive / Group. λ is auto-selected via k-fold CV plus the 1-SE rule | +| `Model.Robust` / `Model.Quantile` | Robust regression via M-estimation / quantile regression | +| `Model.Spline` / `Model.GAM` | Spline smoothing / generalized additive models | + +### Formula DSL (`Model.Formula.*`) + +| Module | Role | +|---|---| +| `Model.Formula` | Parser and AST for the **canonical Formula DSL front-end** (`y ~ x1 + x2*x3`) | +| `Model.Formula.Design` / `.Frame` | AST → model matrix, and joining with a dataframe | +| `Model.Formula.Mixed` / `.Nonlinear` / `.RFormula` | Interpretation of mixed-effects / nonlinear terms / R-compatible formulas | + +### Multivariate & dimensionality reduction + +| Module | Role | +|---|---| +| `Model.PCA` | Principal component analysis (variance maximization, no response) | +| `Model.PLS` | Partial least squares — maximizes covariance with the response, plus VIP and CV-based component selection | +| `Model.Discriminant` | Discriminant analysis (LDA = linear boundary / QDA = quadratic boundary) | +| `Model.Multivariate` | The RRR / PLS / CCA family of multivariate regression | +| `Model.MDS` / `Model.FDA` | Multidimensional scaling / functional data analysis | +| `Model.Cluster` / `Model.HierarchicalCluster` / `Model.LatentClassAnalysis` | k-means / hierarchical clustering / latent class analysis | + +### Machine learning + +| Module | Role | +|---|---| +| `Model.RandomForest` / `Model.RandomForestClassifier` | Random forest (regression / classification) | +| `Model.DecisionTree` / `Model.GradientBoosting` | Decision trees / gradient boosting | +| `Model.SVM` / `Model.KNN` / `Model.NaiveBayes` / `Model.NeuralNetwork` | SVM / k-nearest neighbors / naive Bayes / NN | +| `Model.Kernel` / `Model.KernelRegression` | Kernel function family / kernel regression | +| `Model.PartialDependence` | Model interpretation via PDP / ICE | + +### Gaussian processes & multi-output + +| Module | Role | +|---|---| +| `Model.GP` / `Model.GPRobust` | GP regression (RBF / Matérn / Periodic + ARD) / outlier-robust GP | +| `Model.MultiGP` / `Model.MultiOutput` | Multi-output GP / a unified API for multi-output regression | +| `Model.RFF` | Large-scale GP approximation via Random Fourier Features | + +### Time series + +| Module | Role | +|---|---| +| `Model.TimeSeries` | Entry point for the ARIMA family | +| `Model.VAR` / `Model.GARCH` / `Model.StateSpace` | Vector autoregression / GARCH / state-space models (Kalman filter) | + +### Survival & reliability + +| Module | Role | +|---|---| +| `Model.Survival` | Kaplan-Meier / Cox proportional hazards | +| `Model.AFT` / `Model.CompetingRisks` | Accelerated failure time models / competing risks (CIF) | +| `Model.Weibull` | Weibull MLE (with censoring support) + B_p life + Wald confidence intervals | +| `Model.Reliability` | Accelerated life testing (Arrhenius / Eyring / Inverse Power Law) | +| `Model.ReliabilityBlockDiagram` | System reliability for series / parallel / k-of-n configurations | + +### Causal inference + +| Module | Role | +|---|---| +| `Model.LiNGAM.Direct` / `.ICA` / `.Pairwise` / `.Parce` | Structure estimation using non-Gaussianity (DirectLiNGAM / ICA-LiNGAM, etc.) | +| `Model.LiNGAM.VAR` / `.Bootstrap` / `.MultiGroup` | Time-series variant / bootstrap confidence / simultaneous multi-group estimation | +| `Model.DAG` | DAG representation and search | +| `Stat.Causal.PropensityScore` / `.IPW` / `.DoublyRobust` / `.CATE` | Propensity score / IPW / doubly robust estimation / conditional average treatment effect | + +### Miscellaneous + +| Module | Role | +|---|---| +| `Model.FitYByX` | Equivalent of JMP's "Fit Y by X" — auto-selects a method from the combination of variable types | +| `Stat.ModelSelect` | Model selection via AIC / BIC | +| `Optim.BayesOpt` | Bayesian optimization (GP + acquisition function). Placed in this layer because it uses GP | + +## Using it standalone + +If you do not need the umbrella package, you can depend on this package +directly. Since the `FitResult` result type lives in the core layer, **you +also need `hanalyze-core` explicitly**: + +```cabal +build-depends: hanalyze-models, hanalyze-core, hmatrix +``` + +```haskell +import qualified Numeric.LinearAlgebra as LA +import Hanalyze.Model.Core (FitResult (..)) +import Hanalyze.Model.LM (fitLM) + +main :: IO () +main = do + let x = LA.fromLists [ [1, 1.0], [1, 2.0], [1, 3.0], [1, 4.0], [1, 5.0] ] + y = LA.fromLists [ [2.1], [3.9], [6.2], [7.8], [10.1] ] + fit = fitLM x y + print (LA.toLists (coefficients fit)) + print (LA.toList (rSquared fit)) + -- [[5.000000000000132e-2],[1.9899999999999998]] + -- [0.9973053289009771] +``` + +You must add the intercept column (`1`) yourself. To build a model matrix +from a formula, use `Model.Formula`. + +Normally you would just depend on the umbrella package `hanalyze` and +get all of the above from a single `import Hanalyze`. Naming a layer +directly is only worth it when you want to minimize dependencies. + +## Related docs + +- Linear regression: [docs/regression/01-lm.md](../docs/regression/01-lm.md) / + GLM: [02-glm.md](../docs/regression/02-glm.md) +- Regularized regression: [04-regularized.md](../docs/regression/04-regularized.md) / + [usage-regularized-advanced.md](../docs/regression/usage-regularized-advanced.md) +- PLS: [usage-pls.md](../docs/regression/usage-pls.md) / + Discriminant analysis (LDA/QDA): [usage-discriminant.md](../docs/regression/usage-discriminant.md) +- Weibull / B_p life: [usage-weibull.md](../docs/regression/usage-weibull.md) / + Accelerated life testing: [usage-reliability.md](../docs/regression/usage-reliability.md) +- Survival analysis: [10-survival.md](../docs/regression/10-survival.md) / + Multi-output: [05-multivariate.md](../docs/regression/05-multivariate.md) +- Formula DSL: [11-formula-dsl.md](../docs/regression/11-formula-dsl.md) +- Causal inference: [docs/causal/](../docs/causal/) / + Bayesian optimization: [docs/optim/01-singleobj.md](../docs/optim/01-singleobj.md) + +← [repository README](../README.md) diff --git a/hanalyze-models.cabal b/hanalyze-models.cabal new file mode 100644 --- /dev/null +++ b/hanalyze-models.cabal @@ -0,0 +1,125 @@ +cabal-version: 3.0 +name: hanalyze-models +version: 0.2.0.1 +synopsis: Model layer of hanalyze: regression, ML, survival, causal +description: + The model layer of the hanalyze toolkit: a model zoo spanning + classical regression (LM, GLM, GLMM, robust, quantile, splines, GAM), + penalised regression with automatic lambda selection (Lasso / Ridge / + Elastic Net / MCP / SCAD), the Formula DSL front-end, multivariate + analysis (PCA, PLS, LDA / QDA, MDS, clustering), machine learning + (random forest, gradient boosting, SVM, k-NN, neural networks), + Gaussian processes and multi-output models, time series (VAR, GARCH, + state space), survival and reliability (Kaplan-Meier, Cox, AFT, + Weibull MLE, accelerated-life models), causal inference (LiNGAM, + propensity score, IPW, doubly robust, CATE) and Bayesian optimisation. + . + Module names match the umbrella package hanalyze, which re-exports + everything, so downstream imports stay identical. See README.md for the + module map and a standalone 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.Model.AFT + Hanalyze.Model.Cluster + Hanalyze.Model.CompetingRisks + Hanalyze.Model.DAG + Hanalyze.Model.DecisionTree + Hanalyze.Model.Discriminant + Hanalyze.Model.FDA + Hanalyze.Model.FitYByX + Hanalyze.Model.Formula + Hanalyze.Model.Formula.Design + Hanalyze.Model.Formula.Frame + Hanalyze.Model.Formula.Mixed + Hanalyze.Model.Formula.Nonlinear + Hanalyze.Model.Formula.RFormula + Hanalyze.Model.GAM + Hanalyze.Model.GARCH + Hanalyze.Model.GLM + Hanalyze.Model.GLMM + Hanalyze.Model.GP + Hanalyze.Model.GPRobust + Hanalyze.Model.GradientBoosting + Hanalyze.Model.HierarchicalCluster + Hanalyze.Model.KNN + Hanalyze.Model.Kernel + Hanalyze.Model.KernelRegression + Hanalyze.Model.LM + Hanalyze.Model.LM.Diagnostics + Hanalyze.Model.LatentClassAnalysis + Hanalyze.Model.LiNGAM.Bootstrap + Hanalyze.Model.LiNGAM.Direct + Hanalyze.Model.LiNGAM.ICA + Hanalyze.Model.LiNGAM.MultiGroup + Hanalyze.Model.LiNGAM.Pairwise + Hanalyze.Model.LiNGAM.Parce + Hanalyze.Model.LiNGAM.VAR + Hanalyze.Model.MDS + Hanalyze.Model.MultiGP + Hanalyze.Model.MultiLM + Hanalyze.Model.MultiOutput + Hanalyze.Model.Multivariate + Hanalyze.Model.NaiveBayes + Hanalyze.Model.NeuralNetwork + Hanalyze.Model.PCA + Hanalyze.Model.PLS + Hanalyze.Model.PartialDependence + Hanalyze.Model.Quantile + Hanalyze.Model.RFF + Hanalyze.Model.RandomForest + Hanalyze.Model.RandomForestClassifier + Hanalyze.Model.Regularized + Hanalyze.Model.RegularizedAdvanced + Hanalyze.Model.Reliability + Hanalyze.Model.ReliabilityBlockDiagram + Hanalyze.Model.Robust + Hanalyze.Model.SVM + Hanalyze.Model.Spline + Hanalyze.Model.StateSpace + Hanalyze.Model.Survival + Hanalyze.Model.TimeSeries + Hanalyze.Model.VAR + Hanalyze.Model.Weibull + Hanalyze.Optim.BayesOpt + Hanalyze.Stat.Causal.CATE + Hanalyze.Stat.Causal.DoublyRobust + Hanalyze.Stat.Causal.IPW + Hanalyze.Stat.Causal.PropensityScore + Hanalyze.Stat.ModelSelect + build-depends: + base >= 4.14 && < 5 + , containers >= 0.6 && < 0.8 + , hmatrix >= 0.20 && < 0.22 + , mwc-random >= 0.15 && < 0.16 + , primitive >= 0.7 && < 0.10 + , statistics >= 0.16 && < 0.17 + , text >= 1.2 && < 2.2 + , vector >= 0.12 && < 0.14 + , dataframe-core ^>= 1.1 + , vector-algorithms >= 0.9 && < 0.10 + , megaparsec >= 9.0 && < 9.7 + , parser-combinators >= 1.3 && < 1.4 + , hanalyze-core == 0.2.0.1 + , hanalyze-frame == 0.2.0.1 + , hanalyze-bayes == 0.2.0.1 diff --git a/src/Hanalyze/Model/AFT.hs b/src/Hanalyze/Model/AFT.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/AFT.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.AFT +-- Description : Accelerated Failure Time (AFT) パラメトリック生存モデル +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Accelerated Failure Time (AFT) パラメトリック生存モデル。 +-- +-- AFT は寿命 T の対数を共変量の線形関数として表現する: +-- +-- @ +-- log T_i = X_i β + σ ε_i +-- @ +-- +-- ε の分布で family が決まる: +-- +-- - 'AFTWeibull' : ε ~ Gumbel (生存解析の Weibull AFT) +-- - 'AFTLogNormal' : ε ~ Normal(0, 1) +-- - 'AFTLogLogistic': ε ~ Logistic(0, 1) +-- - 'AFTExponential': Weibull with σ = 1 を固定 +-- +-- 右側打ち切り (right censoring) 対応。 推定は対数尤度の最大化を +-- Nelder-Mead で行う (純粋関数のため runIdentity 経由)。 +-- +-- API: +-- +-- > fitAFT :: AFTDistribution -> Matrix Double -> Vector Double +-- > -> Vector Bool -> IO (Either Text AFTFit) +-- > predictAFT :: AFTFit -> Matrix Double -> Vector Double -- 期待寿命 +-- +-- [English]: Accelerated Failure Time (AFT) parametric survival model. +-- +-- AFT expresses the log of lifetime T as a linear function of covariates: +-- +-- @ +-- log T_i = X_i β + σ ε_i +-- @ +-- +-- The distribution of ε determines the family: +-- +-- - 'AFTWeibull' : ε ~ Gumbel (the Weibull AFT of survival analysis). +-- - 'AFTLogNormal' : ε ~ Normal(0, 1). +-- - 'AFTLogLogistic': ε ~ Logistic(0, 1). +-- - 'AFTExponential': Weibull with σ = 1 fixed. +-- +-- Supports right censoring. Estimation maximizes the log-likelihood via +-- Nelder-Mead (routed through runIdentity since it is a pure function). +-- +-- API: +-- +-- > fitAFT :: AFTDistribution -> Matrix Double -> Vector Double +-- > -> Vector Bool -> IO (Either Text AFTFit) +-- > predictAFT :: AFTFit -> Matrix Double -> Vector Double -- expected lifetime +module Hanalyze.Model.AFT + ( AFTDistribution (..) + , AFTFit (..) + , fitAFT + , predictAFT + , logS + -- ^ [日本語]: 標準化誤差 z の log 生存関数 (= 生存曲線描画に使用)。 + -- [English]: The log survival function of the standardized error z + -- (used for drawing survival curves). + ) where + +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA +import Data.Text (Text) +import qualified Data.Text as T +import qualified Statistics.Distribution as SD +import qualified Statistics.Distribution.Normal as ND + +import Hanalyze.Optim.NelderMead (runNelderMeadWith, defaultNMConfig, + NMConfig (..)) +import Hanalyze.Optim.Common (OptimResult (..), StopCriteria (..)) + +-- =========================================================================== +-- 型 +-- =========================================================================== + +data AFTDistribution + = AFTWeibull + | AFTLogNormal + | AFTLogLogistic + | AFTExponential + deriving (Show, Eq) + +data AFTFit = AFTFit + { aftBeta :: !(LA.Vector Double) + , aftScale :: !Double -- ^ [日本語]: scale parameter σ。 [English]: The scale parameter σ. + , aftLogLik :: !Double + , aftDistribution :: !AFTDistribution + , aftIters :: !Int + } deriving (Show) + +-- =========================================================================== +-- fit +-- =========================================================================== + +-- | [日本語]: AFT モデルを MLE で fit する。 +-- X: n × p 共変量、 t: n 観測時間 (> 0)、 delta: n failure indicator +-- (True = 観測、 False = 右側打ち切り)。 +-- [English]: Fits an AFT model with MLE. +-- X: n × p covariates, t: n observed times (> 0), delta: n failure +-- indicators (True = observed, False = right-censored). +fitAFT + :: AFTDistribution + -> LA.Matrix Double + -> LA.Vector Double + -> V.Vector Bool + -> IO (Either Text AFTFit) +fitAFT dist x t delta + | LA.rows x /= LA.size t || LA.rows x /= V.length delta = + pure (Left "fitAFT: input dimensions mismatch") + | LA.size t == 0 = + pure (Left "fitAFT: empty input") + | V.any (<= 0) (V.fromList (LA.toList t)) = + pure (Left "fitAFT: t must be > 0") + | otherwise = do + let p = LA.cols x + -- intercept-only start: β_0 = mean(log t), β_j = 0 (j ≥ 1) + logT = LA.cmap log t + beta0 = + let mu = LA.sumElements logT / fromIntegral (LA.size logT) + in if p == 0 + then [] + else mu : replicate (p - 1) 0 + -- log σ を最後に追加 (Exponential では 0 固定) + x0 = case dist of + AFTExponential -> beta0 + _ -> beta0 ++ [0] -- log σ = 0 → σ = 1 として開始 + obj params = + let (betaPart, logSigma) = case dist of + AFTExponential -> (params, 0) + _ -> (init params, last params) + sigma = exp logSigma + betaV = LA.fromList betaPart + in negate (logLikAFT dist x t delta betaV sigma) + cfg = defaultNMConfig + { nmStop = StopCriteria + { stMaxIter = 2000 + , stTolFun = 1e-8 + , stTolX = 1e-8 + } + } + res <- runNelderMeadWith cfg obj x0 + let xs = orBest res + (betaPart, sigma) = case dist of + AFTExponential -> (xs, 1) + _ -> (init xs, exp (last xs)) + betaV = LA.fromList betaPart + ll = logLikAFT dist x t delta betaV sigma + pure (Right AFTFit + { aftBeta = betaV + , aftScale = sigma + , aftLogLik = ll + , aftDistribution = dist + , aftIters = orIters res + }) + +-- | [日本語]: 期待寿命の予測 E[T | X] = exp(X β + σ² / 2) -- log-normal の場合 +-- Weibull AFT: E[T] = exp(X β) · Γ(1 + σ) +-- LogLogistic: E[T] = exp(X β) · π σ / sin(π σ) (σ < 1) +-- Exponential: E[T] = exp(X β) +-- [English]: Predicts expected lifetime E[T | X] = exp(X β + σ² / 2) -- +-- for log-normal. +-- Weibull AFT: E[T] = exp(X β) · Γ(1 + σ). +-- LogLogistic: E[T] = exp(X β) · π σ / sin(π σ) (σ < 1). +-- Exponential: E[T] = exp(X β). +predictAFT :: AFTFit -> LA.Matrix Double -> LA.Vector Double +predictAFT fit xNew = + let linPred = xNew LA.#> aftBeta fit + sigma = aftScale fit + adjust = case aftDistribution fit of + AFTWeibull -> gammaApprox (1 + sigma) + AFTLogNormal -> exp (sigma * sigma / 2) + AFTLogLogistic -> + if sigma < 1 && sigma > 0 + then pi * sigma / sin (pi * sigma) + else 1 / 0 -- 平均が発散 + AFTExponential -> 1 + in LA.cmap (\lp -> exp lp * adjust) linPred + +-- =========================================================================== +-- 内部 helpers +-- =========================================================================== + +-- | [日本語]: 対数尤度。 censored は log S(t)、 observed は log f(t)。 +-- [English]: The log-likelihood. Censored uses log S(t); observed uses +-- log f(t). +logLikAFT + :: AFTDistribution + -> LA.Matrix Double -> LA.Vector Double -> V.Vector Bool + -> LA.Vector Double -> Double + -> Double +logLikAFT dist x t delta beta sigma + | sigma <= 0 = -1e15 + | otherwise = + let n = LA.rows x + eta = x LA.#> beta -- length n + logT = LA.cmap log t -- length n + zs = LA.cmap (/ sigma) (logT - eta) + in sum + [ let z = LA.atIndex zs i + lt = LA.atIndex logT i + obs = delta V.! i + in if obs + then logPDF dist sigma lt z + else logS dist z + | i <- [0 .. n - 1] ] + +-- | [日本語]: log f(t) = log f_ε(z) − log σ − log t +-- [English]: log f(t) = log f_ε(z) − log σ − log t. +logPDF :: AFTDistribution -> Double -> Double -> Double -> Double +logPDF dist sigma logT z = + let body = case dist of + AFTWeibull -> z - exp z + AFTExponential -> z - exp z + AFTLogNormal -> -0.5 * z * z - 0.5 * log (2 * pi) + AFTLogLogistic -> z - 2 * log1p (exp z) + in body - log (max 1e-300 sigma) - logT + +-- | [日本語]: log S(t) = log S_ε(z) +-- [English]: log S(t) = log S_ε(z). +logS :: AFTDistribution -> Double -> Double +logS dist z = case dist of + AFTWeibull -> -exp z + AFTExponential -> -exp z + AFTLogNormal -> log (max 1e-300 (1 - SD.cumulative ND.standard z)) + AFTLogLogistic -> -log1p (exp z) + +log1p :: Double -> Double +log1p x + | abs x < 1e-4 = x - x * x / 2 + x * x * x / 3 + | otherwise = log (1 + x) + +-- | [日本語]: Stirling 近似による Γ(x) (x > 0)。 AFT の平均補正で使うだけなので簡易版。 +-- [English]: Γ(x) (x > 0) via Stirling's approximation. A simplified +-- version, since it is only used for the AFT mean correction. +gammaApprox :: Double -> Double +gammaApprox x + | x <= 0 = 1 / 0 + | x < 1 = gammaApprox (x + 1) / x + | otherwise = + let n = floor (x - 1) :: Int + frac = x - fromIntegral n - 1 + base = gammaStirling (1 + frac) + in base * fromIntegral (product [1 .. n]) + where + gammaStirling y = + sqrt (2 * pi / y) * (y / exp 1) ** y + * (1 + 1/(12*y) + 1/(288*y*y)) diff --git a/src/Hanalyze/Model/Cluster.hs b/src/Hanalyze/Model/Cluster.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Cluster.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.Cluster +-- Description : クラスタリングアルゴリズム (k-means / silhouette / inertia) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Clustering algorithms. +-- +-- Implements: +-- +-- - 'kMeans' (Lloyd / Forgy / k-means++ initialisation, multi-restart) +-- - 'silhouette' (cluster quality metric) +-- - 'inertia' (within-cluster sum of squared distances) +-- +-- Hierarchical and DBSCAN are deferred to a follow-up phase. +module Hanalyze.Model.Cluster + ( -- * K-means + KMeansConfig (..) + , KMeansInit (..) + , KMeansResult (..) + , defaultKMeans + , kMeans + , kMeansPure + -- * Quality metrics + , silhouette + , inertia + -- * Helpers (exposed for advanced use) + , assignLabels + , updateCentroids + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Stat.KernelDist as KD +import qualified System.Random.MWC as MWC +import Control.Monad (forM_, foldM) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.ST (ST, runST) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as MVU +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import Data.List (minimumBy) +import Data.Ord (comparing) +import Data.Word (Word32) + +-- --------------------------------------------------------------------------- +-- K-means +-- --------------------------------------------------------------------------- + +-- | Initialisation strategy. +data KMeansInit + = Forgy -- ^ Pick k random data points. + | KMeansPlus -- ^ k-means++ (Arthur & Vassilvitskii 2007). + deriving (Show, Eq) + +-- | K-means configuration. +data KMeansConfig = KMeansConfig + { kmK :: !Int + , kmInit :: !KMeansInit + , kmMaxIter :: !Int + , kmTol :: !Double + , kmRestarts :: !Int + } deriving (Show, Eq) + +-- | Default: k-means++, 300 iters, tol 1e-4, 10 restarts. +defaultKMeans :: Int -> KMeansConfig +defaultKMeans k = KMeansConfig + { kmK = k + , kmInit = KMeansPlus + , kmMaxIter = 300 + , kmTol = 1e-4 + , kmRestarts = 10 + } + +-- | K-means result. +data KMeansResult = KMeansResult + { kmrCentroids :: !(LA.Matrix Double) + , kmrLabels :: ![Int] + , kmrInertia :: !Double + , kmrIters :: !Int + , kmrConverged :: !Bool + } deriving (Show) + +-- | [日本語]: 'kmRestarts' 回の独立再実行を行い、 最も慣性の低い解を保持して +-- K-means をフィットする。 +-- IO ラッパ。 ロジックは 'PrimMonad' 汎用の 'kMeansM' (mwc は 'PrimMonad' +-- 汎用ゆえ ST/IO で同コードを共有) をそのまま IO に特殊化したもの。 +-- [English]: Fit K-means; runs 'kmRestarts' independent restarts and +-- keeps the lowest-inertia solution. +-- IO wrapper. The logic is 'kMeansM', generic over 'PrimMonad' (mwc is +-- generic over 'PrimMonad', so the same code is shared between ST\/IO), +-- specialized directly to IO. +kMeans :: KMeansConfig -> LA.Matrix Double -> MWC.GenIO -> IO KMeansResult +kMeans = kMeansM + +-- | [日本語]: 純粋・決定的な K-means。 同じ @seed@ なら必ず同じ 'KMeansResult' を +-- 返す (同 seed → ビット同一・IO 不要)。 'kMeansM' を @ST@ で走らせ 'runST' で +-- 閉じる ([[phase-50-mcmc-purification-status]] の @nutsPure@ と同方針)。 +-- [English]: Pure, deterministic K-means. The same @seed@ always returns +-- the same 'KMeansResult' (same seed → bit-identical, no IO required). +-- Runs 'kMeansM' in @ST@ and closes it with 'runST' (the same approach as +-- @nutsPure@ in [[phase-50-mcmc-purification-status]]). +kMeansPure :: KMeansConfig -> LA.Matrix Double -> Word32 -> KMeansResult +kMeansPure cfg x seed = + runST (MWC.initialize (V.singleton seed) >>= kMeansM cfg x) + +-- | [日本語]: 'PrimMonad' 汎用の K-means 本体。 'kMeans' (IO) / @kMeansPure@ (ST) が共有。 +-- [English]: The K-means core, generic over 'PrimMonad', shared by +-- 'kMeans' (IO) and @kMeansPure@ (ST). +kMeansM :: PrimMonad m + => KMeansConfig -> LA.Matrix Double -> MWC.Gen (PrimState m) + -> m KMeansResult +kMeansM cfg x gen = do + results <- mapM (\_ -> kMeansSingleRunM cfg x gen) [1 .. kmRestarts cfg] + pure (minimumBy (comparing kmrInertia) results) + +kMeansSingleRunM :: PrimMonad m + => KMeansConfig -> LA.Matrix Double -> MWC.Gen (PrimState m) + -> m KMeansResult +kMeansSingleRunM cfg x gen = do + initC <- case kmInit cfg of + Forgy -> forgyInitM (kmK cfg) x gen + KMeansPlus -> kmppInitM (kmK cfg) x gen + -- Hot loop: keep labels as 'VU.Vector Int' to avoid the per-iteration + -- list↔Vector roundtrip the previous version paid via 'assignLabels' + -- + 'updateCentroids' on @[Int]@. + let loop !iter !centroids + | iter >= kmMaxIter cfg = pure (centroids, iter, False) + | otherwise = do + let labelsV = assignLabelsV x centroids + newC = updateCentroidsV x labelsV (kmK cfg) + shift = LA.norm_2 (LA.flatten (newC - centroids)) + if shift < kmTol cfg + then pure (newC, iter + 1, True) + else loop (iter + 1) newC + (finalC, iters, conv) <- loop 0 initC + let labelsV = assignLabelsV x finalC + pure KMeansResult + { kmrCentroids = finalC + , kmrLabels = VU.toList labelsV + , kmrInertia = inertiaV x finalC labelsV + , kmrIters = iters + , kmrConverged = conv + } + +-- | Forgy initialisation: pick k random rows. +forgyInitM :: PrimMonad m + => Int -> LA.Matrix Double -> MWC.Gen (PrimState m) + -> m (LA.Matrix Double) +forgyInitM k x gen = do + let n = LA.rows x + xRowsV = V.fromList (LA.toRows x) -- O(1) row access + idxs <- pickKDistinctM k n gen + pure (LA.fromRows [xRowsV V.! i | i <- idxs]) + +-- | k-means++ initialisation: 1st centroid uniform random, subsequent +-- centroids weighted by squared distance to nearest existing centroid. +-- +-- /Implementation/. Maintain @bestDist[i] = min_c ‖x_i − c‖²@ across +-- the centroids picked so far. Adding a new centroid is +-- __one BLAS GEMV__ + element-wise min, not a per-row Vector subtract / dot. +-- +-- The previous version paid @n@ separate @LA.Vector@ allocations and +-- @n@ BLAS @ddot@ dispatches per centroid update (e.g. for +-- @n = 2000, k = 5@ that was ~10 000 length-@p@ allocations and +-- ~10 000 BLAS calls per kMeans run, ×10 restarts ≈ 100 000 allocs). +-- The fused-BLAS form below uses pre-computed row sq-norms and a +-- single matrix-vector multiply per centroid — O(np) work for the +-- whole sweep instead of O(n) per row. +kmppInitM :: PrimMonad m + => Int -> LA.Matrix Double -> MWC.Gen (PrimState m) + -> m (LA.Matrix Double) +kmppInitM k x gen = do + let n = LA.rows x + -- Pre-compute row squared norms once: ‖x_i‖² for all rows + -- (length-n vector via @(X ⊙ X) · 1@). + normsX = KD.rowSqNorms x + + -- Pick the first centroid. + i0 <- MWC.uniformR (0, n - 1) gen + -- bestDist[i] = ‖x_i − x_{i0}‖² in BLAS form: + -- = ‖x_i‖² + ‖x_{i0}‖² − 2 x_iᵀ x_{i0} + -- via @cross = X · x_{i0}@ (one GEMV), reusing 'normsX'. + let initBest = sqDistsToRow x normsX i0 + + pickWeighted total bdv = + if total <= 0 + then pure 0 + else do + u <- MWC.uniformR (0, total) gen + -- Linear scan of the cumulative weights via VS.unsafeIndex. + let go !acc !i + | i >= n - 1 = pure i + | otherwise = do + let !nxt = acc + bdv `VS.unsafeIndex` i + if u <= nxt + then pure i + else go nxt (i + 1) + go 0 0 + + -- IORef を foldM で純粋に畳む (純粋化のため・乱数列順は不変ゆえ + -- 旧 IORef 版とビット同一)。 state = (bestDist, 逆順 centroid idx)。 + step (bd, acc) _ = do + let !total = VS.sum bd + pickIdx <- pickWeighted total bd + -- One GEMV → length-n @sq dist to new centroid@; element-wise + -- min with @bestDist@ in a single Storable Vector pass. + let !newDist = sqDistsToRow x normsX pickIdx + !updated = VS.zipWith min bd newDist + pure (updated, pickIdx : acc) + + (_, idxsRev) <- foldM step (initBest, [i0]) [2 .. k] + -- Build the @k × p@ centroid matrix from row indices in one shot. + let xRowsV = V.fromList (LA.toRows x) + pure (LA.fromRows [xRowsV V.! i | i <- reverse idxsRev]) + +-- | Squared distance from every row of @X@ (n × p) to @X[i, :]@, +-- via the BLAS identity +-- @‖x_a − x_i‖² = ‖x_a‖² + ‖x_i‖² − 2 x_aᵀ x_i@. +-- +-- Cost: 1 GEMV (@O(np)@) plus one length-@n@ element-wise pass. +-- Used by @kmppInit@ to avoid per-row Vector subtract/dot. +sqDistsToRow + :: LA.Matrix Double -- ^ Data matrix @X@ (@n × p@). + -> LA.Vector Double -- ^ Pre-computed row squared norms. + -> Int -- ^ Reference row index @i@. + -> LA.Vector Double -- ^ Length-@n@ squared distances. +sqDistsToRow xMat normsX i = + let xi = LA.flatten (xMat LA.?? (LA.Pos (LA.idxs [i]), LA.All)) + ni = normsX `LA.atIndex` i + cross = xMat LA.#> xi -- length n, GEMV + d = normsX + LA.scalar ni - LA.scale 2 cross + in LA.cmap (max 0) d -- numerical-noise floor at 0 + +-- | Pick k distinct indices in [0, n) via Fisher-Yates partial. +pickKDistinctM :: PrimMonad m + => Int -> Int -> MWC.Gen (PrimState m) -> m [Int] +pickKDistinctM k n gen = do + v <- V.thaw (V.fromList [0 .. n - 1]) + forM_ [0 .. min k n - 1] $ \i -> do + j <- MWC.uniformR (i, n - 1) gen + a <- VM.read v i + b <- VM.read v j + VM.write v i b + VM.write v j a + V.toList . V.take k <$> V.freeze v + +-- | Assign each row to its nearest centroid (Euclidean) — public API. +assignLabels :: LA.Matrix Double -> LA.Matrix Double -> [Int] +assignLabels x cs = VU.toList (assignLabelsV x cs) + +-- | Vector version of 'assignLabels'. Internal hot path; the public +-- @assignLabels@ wraps with @VU.toList@ at the boundary. +-- +-- /Implementation/. The full @n × k@ squared-distance matrix is +-- /not/ materialised. Instead we use the BLAS identity +-- +-- @‖x_i − c_j‖² = ‖x_i‖² + ‖c_j‖² − 2 x_iᵀ c_j@ +-- +-- of which only the cross term @cross = X · Cᵀ@ depends on @j@ +-- per-row, so the row-wise argmin is equivalent to +-- +-- @argmin_j (‖c_j‖² − 2 cross[i, j])@ +-- +-- (the @‖x_i‖²@ term is constant across @j@). Replaces the previous +-- @KD.pairwiseSqDistXY x cs@ + scan pipeline, which built a full +-- @n × k@ Storable matrix only to read every cell once. Now: one +-- BLAS GEMM (@O(npk)@) plus a length-@nk@ argmin scan with a small +-- per-row constant — half the writes, lower cache pressure. +assignLabelsV :: LA.Matrix Double -> LA.Matrix Double -> VU.Vector Int +assignLabelsV x cs = + let n = LA.rows x + k = LA.rows cs + normsC = KD.rowSqNorms cs -- length k + cross = x LA.<> LA.tr cs -- n × k, single GEMM + flatXC = LA.flatten cross + in runST $ do + lab <- MVU.new n + let scanRow !i + | i >= n = pure () + | otherwise = do + let !base = i * k + -- argmin_j of (‖c_j‖² − 2 X·Cᵀ[i, j]). + pickArg !j !bestJ !bestVal + | j >= k = bestJ + | otherwise = + let !v = (normsC `VS.unsafeIndex` j) + - 2 * (flatXC `VS.unsafeIndex` (base + j)) + in if v < bestVal + then pickArg (j + 1) j v + else pickArg (j + 1) bestJ bestVal + !v0 = (normsC `VS.unsafeIndex` 0) + - 2 * (flatXC `VS.unsafeIndex` base) + !bestJ0 = pickArg 1 0 v0 + MVU.unsafeWrite lab i bestJ0 + scanRow (i + 1) + scanRow 0 + VU.unsafeFreeze lab + +-- | Recompute centroids — public API. Wraps @updateCentroidsV@. +updateCentroids :: LA.Matrix Double -> [Int] -> Int -> LA.Matrix Double +updateCentroids x labels k = updateCentroidsV x (VU.fromList labels) k + +-- | Vector version of 'updateCentroids'. Internal hot path. +-- +-- Single-pass scatter-add: traverse the @n × p@ data matrix once, +-- accumulating each row into its assigned cluster's running sum and +-- bumping that cluster's count. Centroids are then @sum / count@. +-- Replaces the previous @[ [r | (r,l) ← zip rows labels, l == c] +-- | c ← [0..k-1] ]@ which scanned the whole label list once /per/ +-- cluster — @O(n k)@ per call vs the new @O(n p)@. +updateCentroidsV + :: LA.Matrix Double -> VU.Vector Int -> Int -> LA.Matrix Double +updateCentroidsV x labels k = + let n = LA.rows x + p = LA.cols x + flat = LA.flatten x -- length n*p, row-major + out = runST $ do + -- VSM.replicate avoids the explicit init forM_ loops. + sumBuf <- VSM.replicate (k * p) (0 :: Double) + cntBuf <- MVU.replicate k (0 :: Int) + :: ST s (MVU.STVector s Int) + -- Single pass over all rows. Tail-recursive Int loops keep the + -- whole pass list-free; the previous @forM_ [0..n-1]@ + + -- @forM_ [0..p-1]@ relied on GHC's list-fusion rewrite, which + -- adds Haskell-level monadic-bind overhead for very small + -- inner @p@. + let goRow !i + | i >= n = pure () + | otherwise = do + let !l = labels `VU.unsafeIndex` i + !off = i * p + !sof = l * p + goCol !j + | j >= p = pure () + | otherwise = do + old <- VSM.unsafeRead sumBuf (sof + j) + VSM.unsafeWrite sumBuf (sof + j) + (old + flat `VS.unsafeIndex` (off + j)) + goCol (j + 1) + goCol 0 + c0 <- MVU.unsafeRead cntBuf l + MVU.unsafeWrite cntBuf l (c0 + 1) + goRow (i + 1) + goRow 0 + -- Divide each cluster's sum by its count. + let goNorm !c + | c >= k = pure () + | otherwise = do + cnt <- MVU.unsafeRead cntBuf c + let !invN = if cnt == 0 then 0 + else 1 / fromIntegral cnt + !sof = c * p + goScale !j + | j >= p = pure () + | otherwise = do + v <- VSM.unsafeRead sumBuf (sof + j) + VSM.unsafeWrite sumBuf (sof + j) (v * invN) + goScale (j + 1) + goScale 0 + goNorm (c + 1) + goNorm 0 + VS.unsafeFreeze sumBuf + in LA.reshape p out + +-- | Sum of squared Euclidean distances — public API. +inertia :: LA.Matrix Double -> LA.Matrix Double -> [Int] -> Double +inertia x cs labels = inertiaV x cs (VU.fromList labels) + +-- | Vector version. Single pass over the @n × p@ data matrix and the +-- @k × p@ centroid matrix, accumulating @‖x_i − c_{l_i}‖²@ via flat +-- indexing — no @LA.toRows@ list, no @cRows !! l@ list-index per row. +inertiaV + :: LA.Matrix Double -> LA.Matrix Double -> VU.Vector Int -> Double +inertiaV x cs labels = + let n = LA.rows x + p = LA.cols x + flatX = LA.flatten x + flatC = LA.flatten cs + go !i !acc + | i >= n = acc + | otherwise = + let l = labels VU.! i + !off = i * p + !cof = l * p + rowSq !j !s + | j >= p = s + | otherwise = + let !d = (flatX `VS.unsafeIndex` (off + j)) + - (flatC `VS.unsafeIndex` (cof + j)) + in rowSq (j + 1) (s + d * d) + in go (i + 1) (acc + rowSq 0 0) + in go 0 0 + +-- --------------------------------------------------------------------------- +-- Quality +-- --------------------------------------------------------------------------- + +-- | Silhouette coefficient. Mean over samples of +-- @(b − a) / max(a, b)@ where @a@ is the mean distance to other points +-- in the same cluster and @b@ is the mean distance to the closest +-- other cluster. Range @[-1, 1]@; higher is better. +silhouette :: LA.Matrix Double -> [Int] -> Double +silhouette x labels = + let n = LA.rows x + d2 = KD.pairwiseSqDist x + d = LA.cmap sqrt d2 + lvec = V.fromList labels + uniqL = V.toList (V.fromList (foldr (\l acc -> + if l `elem` acc then acc else l:acc) [] labels)) + meanD i js + | null js = 0 + | otherwise = sum [LA.atIndex d (i, j) | j <- js] + / fromIntegral (length js) + sIof i = + let li = lvec V.! i + ai = meanD i [j | j <- [0..n-1], j /= i, lvec V.! j == li] + otherClusters = filter (/= li) uniqL + bi = if null otherClusters then 0 + else minimum [meanD i [j | j <- [0..n-1], lvec V.! j == c] + | c <- otherClusters] + in if max ai bi == 0 then 0 else (bi - ai) / max ai bi + in if n == 0 then 0 else sum [sIof i | i <- [0..n-1]] / fromIntegral n diff --git a/src/Hanalyze/Model/CompetingRisks.hs b/src/Hanalyze/Model/CompetingRisks.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/CompetingRisks.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.CompetingRisks +-- Description : 競合リスク生存解析 (累積発生関数 CIF 推定) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Competing-risks survival analysis. +-- +-- Extends 'Hanalyze.Model.Survival' to settings with multiple, mutually +-- exclusive failure causes. Implements the non-parametric Cumulative +-- Incidence Function (CIF) estimator (Kalbfleisch & Prentice 1980): +-- +-- @ +-- F̂_k(t) = Σ_{t_i ≤ t} Ŝ(t_i⁻) · (d_{k,i} / n_i) +-- @ +-- +-- where @Ŝ@ is the overall Kaplan-Meier survival treating *any* cause as +-- an event, @d_{k,i}@ is the number of failures from cause @k@ at time +-- @t_i@, and @n_i@ is the size of the risk set just before @t_i@. +-- +-- The naïve approach of taking @1 - KM@ on cause-specific data ignores +-- competing events and biases the cumulative incidence upward; this +-- estimator is the canonical correction. +-- +-- @ +-- import Hanalyze.Model.CompetingRisks +-- +-- let samples = [ CRSample 1.2 1, CRSample 2.5 2, CRSample 3.0 0, … ] +-- fit = fitCompetingRisks samples +-- @ +-- +-- == Implemented +-- +-- * 'fitCompetingRisks' (per-cause CIF on the distinct event grid) +module Hanalyze.Model.CompetingRisks + ( CRSample (..) + , CRFit (..) + , fitCompetingRisks + ) where + +import qualified Numeric.LinearAlgebra as LA +import Data.List (sort, nub, sortBy) +import Data.Ord (comparing) + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +-- | A single observation with cause-of-failure indicator. +-- @crCause = 0@ ↔ right-censored, @crCause ≥ 1@ ↔ failure from that cause. +data CRSample = CRSample + { crTime :: !Double + , crCause :: !Int + } deriving (Show, Eq) + +-- | Fitted competing-risks estimator: cumulative incidence per cause, +-- evaluated on the distinct event times (causes 1, …, K combined). +data CRFit = CRFit + { crfCauses :: ![Int] -- ^ Cause labels (sorted). + , crfTimes :: !(LA.Vector Double) -- ^ Distinct event times. + , crfCIF :: ![(Int, LA.Vector Double)] -- ^ Per-cause CIF values + -- on @crfTimes@. + , crfOverallSurvival :: !(LA.Vector Double) -- ^ Overall KM survival + -- on @crfTimes@. + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- Fitting +-- --------------------------------------------------------------------------- + +-- | Estimate the cumulative incidence function for each observed cause. +-- Inputs need not be sorted; ties at the same time are handled jointly. +fitCompetingRisks :: [CRSample] -> CRFit +fitCompetingRisks samples = + let sorted = sortBy (comparing crTime) samples + causes = sort (nub [ c | CRSample _ c <- sorted, c > 0 ]) + eventTimes = sort (nub [ crTime s | s <- sorted, crCause s > 0 ]) + -- Number at risk just before time t: #{s | crTime s >= t}. + atRisk t = length [ s | s <- sorted, crTime s >= t ] + atTime t = [ s | s <- sorted, crTime s == t ] + -- Per-event-time row: (S(t⁻) before update, n at risk, total d, per-cause d) + step !sPrev t = + let here = atTime t + events = [ c | CRSample _ c <- here, c > 0 ] + dTot = length events + n = atRisk t + sNew = sPrev * (1 - fromIntegral dTot / fromIntegral n) + incs = [ ( k + , sPrev * fromIntegral (length [ c | c <- events, c == k ]) + / fromIntegral n ) + | k <- causes ] + in (sNew, incs) + walk _ [] = ([], []) + walk !sPrev (t : ts) = + let (sNew, incs) = step sPrev t + (ss, incss) = walk sNew ts + in (sNew : ss, incs : incss) + (survList, incList) = walk 1.0 eventTimes + sVec = LA.fromList survList + -- Cumulate increments per cause across the event-time grid. + cumulate inc = scanl1 (+) inc + cifByCause k = + let perTimeInc = [ snd (head [ (k', v) | (k', v) <- row, k' == k ]) + | row <- incList ] + in LA.fromList (cumulate perTimeInc) + cifs = [ (k, cifByCause k) | k <- causes ] + in CRFit + { crfCauses = causes + , crfTimes = LA.fromList eventTimes + , crfCIF = cifs + , crfOverallSurvival = sVec + } diff --git a/src/Hanalyze/Model/DAG.hs b/src/Hanalyze/Model/DAG.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/DAG.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.DAG +-- Description : DAG (有向非巡回グラフ) の共通表現 (重み付き隣接行列) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Directed Acyclic Graph (DAG) の共通表現。 +-- +-- 因果探索 (LiNGAM 系) / 将来の SEM / Bayesian Network の出力型を統一する。 +-- 内部表現は __重み付き隣接行列__ で、 hmatrix の線形代数操作との親和性を保つ。 +-- +-- ## 規約 +-- +-- 重み行列 W (p × p) の要素 W[i, j] は __エッジ j → i の重み__ を表す。 +-- これは構造方程式 X_i = Σ_j W[i, j] · X_j + e_i に対応する自然な向きで、 +-- LiNGAM の B 行列と完全一致する。 W[i, i] = 0 (self-loop 禁止)。 +-- +-- ## DAG 判定 +-- +-- 'isAcyclic' は W の非零パターンから到達可能性を見て循環を検出する。 +-- 浮動小数閾値の影響を避けるため、 判定は 'dagW' の __絶対値 > 0__ マスク +-- に対して実施。 ノイズで小さな非零が出る場合は事前に 'pruneByThreshold' +-- でクリーンナップする。 +-- +-- [English]: A common representation for Directed Acyclic Graphs +-- (DAGs). +-- +-- Unifies the output type for causal discovery (LiNGAM family) \/ +-- future SEM \/ Bayesian Network. The internal representation is a +-- __weighted adjacency matrix__, which stays compatible with hmatrix's +-- linear-algebra operations. +-- +-- ## Convention +-- +-- Element W[i, j] of the weight matrix W (p × p) represents +-- __the weight of the edge j → i__. This is the natural direction +-- corresponding to the structural equation +-- X_i = Σ_j W[i, j] · X_j + e_i, and matches LiNGAM's B matrix exactly. +-- W[i, i] = 0 (self-loops are forbidden). +-- +-- ## DAG check +-- +-- 'isAcyclic' detects cycles by looking at reachability over W's +-- nonzero pattern. To avoid the influence of floating-point noise, the +-- check is performed against a mask of 'dagW''s __absolute value > 0__. +-- If noise produces small nonzero values, clean them up beforehand with +-- 'pruneByThreshold'. +module Hanalyze.Model.DAG + ( DAG (..) + , Edge (..) + -- 構築 + , mkDAG + , fromAdjacency + , fromBMatrix + , withNames + -- 操作 + , pruneByThreshold + -- 問合せ + , dagEdges + , dagParents + , dagChildren + , dagNodeName + , topoSort + , isAcyclic + , dagReachable + -- 出力 + , toDOT + ) where + +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA +import Data.Text (Text) +import Data.List (foldl') + +-- =========================================================================== +-- 型 +-- =========================================================================== + +data DAG = DAG + { dagN :: !Int + -- ^ [日本語]: ノード数。 [English]: The number of nodes. + , dagNames :: !(Maybe (V.Vector Text)) + -- ^ [日本語]: ノード名 (任意)。 'Nothing' なら "x0".."x(n-1)" を使う。 + -- [English]: Node names (optional). If 'Nothing', uses + -- "x0".."x(n-1)". + , dagW :: !(LA.Matrix Double) + -- ^ [日本語]: 重み付き隣接行列 (p × p)。 W[i, j] = エッジ j → i の重み。 + -- [English]: The weighted adjacency matrix (p × p). + -- W[i, j] = the weight of the edge j → i. + } deriving (Show) + +data Edge = Edge + { edgeFrom :: !Int + , edgeTo :: !Int + , edgeWeight :: !Double + } deriving (Show, Eq) + +-- =========================================================================== +-- 構築 +-- =========================================================================== + +-- | [日本語]: 重み付き隣接行列から DAG を作る。 ノード数は W の行数。 W が +-- p × p でない場合は呼出側のバグ (here で error)。 +-- [English]: Builds a DAG from a weighted adjacency matrix. The node +-- count is W's row count. If W is not p × p, that is a caller bug +-- (raises an error here). +mkDAG :: LA.Matrix Double -> DAG +mkDAG w + | LA.rows w /= LA.cols w = + error "Hanalyze.Model.DAG.mkDAG: W は p × p 正方行列でなければならない" + | otherwise = DAG + { dagN = LA.rows w + , dagNames = Nothing + , dagW = w + } + +-- | [日本語]: 0/1 隣接行列から DAG。 重みはエッジ存在を 1 として保持。 +-- [English]: Builds a DAG from a 0/1 adjacency matrix. The weight +-- holds 1 for edge presence. +fromAdjacency :: LA.Matrix Double -> DAG +fromAdjacency = mkDAG + +-- | [日本語]: LiNGAM B 行列 + threshold から DAG を構築。 |B[i, j]| ≤ thr の +-- エッジは刈り取る。 対角要素は常に 0。 +-- [English]: Builds a DAG from a LiNGAM B matrix + threshold. Edges +-- with |B[i, j]| ≤ thr are pruned. Diagonal elements are always 0. +fromBMatrix :: Double -> LA.Matrix Double -> DAG +fromBMatrix thr b = mkDAG (pruned b) + where + pruned m = + let p = LA.rows m + f i j + | i == j = 0 + | abs (LA.atIndex m (i, j)) <= thr = 0 + | otherwise = LA.atIndex m (i, j) + in LA.build (p, p) (\i j -> f (round i) (round j) :: Double) + +-- | [日本語]: ノード名を付与する (length 不一致は呼出側のバグ)。 +-- [English]: Attaches node names (a length mismatch is a caller bug). +withNames :: V.Vector Text -> DAG -> DAG +withNames ns g + | V.length ns /= dagN g = + error "Hanalyze.Model.DAG.withNames: ノード数と名前数が不一致" + | otherwise = g { dagNames = Just ns } + +-- =========================================================================== +-- 操作 +-- =========================================================================== + +-- | [日本語]: |W[i, j]| ≤ thr のエッジを 0 に。 自己ループは常に 0。 +-- [English]: Zeroes out edges with |W[i, j]| ≤ thr. Self-loops are +-- always 0. +pruneByThreshold :: Double -> DAG -> DAG +pruneByThreshold thr g = g { dagW = pruned } + where + p = dagN g + f i j + | i == j = 0 + | abs (LA.atIndex (dagW g) (i, j)) <= thr = 0 + | otherwise = LA.atIndex (dagW g) (i, j) + pruned = LA.build (p, p) (\i j -> f (round i) (round j) :: Double) + +-- =========================================================================== +-- 問合せ +-- =========================================================================== + +-- | [日本語]: 全エッジを (from, to, weight) のリストで返す (非零重みのみ)。 +-- [English]: Returns all edges as a list of (from, to, weight) +-- (nonzero weights only). +dagEdges :: DAG -> [Edge] +dagEdges g = + let p = dagN g + w = dagW g + in [ Edge j i (LA.atIndex w (i, j)) + | i <- [0 .. p - 1] + , j <- [0 .. p - 1] + , i /= j + , LA.atIndex w (i, j) /= 0 + ] + +-- | [日本語]: ノード i に直接影響を与えるノード集合 (W[i, j] ≠ 0 となる j のリスト)。 +-- [English]: The set of nodes that directly influence node i (the +-- list of j with W[i, j] ≠ 0). +dagParents :: DAG -> Int -> [Int] +dagParents g i = + [ j | j <- [0 .. dagN g - 1] + , j /= i + , LA.atIndex (dagW g) (i, j) /= 0 ] + +-- | [日本語]: ノード i から直接影響を受けるノード集合 (W[k, i] ≠ 0 となる k のリスト)。 +-- [English]: The set of nodes directly influenced by node i (the +-- list of k with W[k, i] ≠ 0). +dagChildren :: DAG -> Int -> [Int] +dagChildren g i = + [ k | k <- [0 .. dagN g - 1] + , k /= i + , LA.atIndex (dagW g) (k, i) /= 0 ] + +-- | [日本語]: ノード名取得 ('dagNames' が Nothing なら "x{idx}")。 +-- [English]: Gets a node name (if 'dagNames' is Nothing, "x{idx}"). +dagNodeName :: DAG -> Int -> Text +dagNodeName g i = case dagNames g of + Just ns | i >= 0 && i < V.length ns -> ns V.! i + _ -> T.pack ("x" <> show i) + +-- | [日本語]: 到達可能性: from から to へ DAG エッジを辿って到達可能か。 +-- [English]: Reachability: whether to is reachable from from by +-- following DAG edges. +dagReachable :: DAG -> Int -> Int -> Bool +dagReachable g from to = go S.empty [from] + where + go _ [] = False + go seen (x:xs) + | x == to = True + | x `S.member` seen = go seen xs + | otherwise = + let !seen' = S.insert x seen + kids = dagChildren g x + in go seen' (kids ++ xs) + +-- | [日本語]: 循環を含まないか。 全ノード対 (i, j) について 「j から i へ到達可能か +-- つ i → j のエッジが存在する」 ならば循環。 +-- [English]: Whether the graph contains no cycle. For every node +-- pair (i, j), if "i is reachable from j, and an edge i → j exists" +-- then it is a cycle. +isAcyclic :: DAG -> Bool +isAcyclic g = + let !p = dagN g + cyclePair i j = + i /= j + && LA.atIndex (dagW g) (j, i) /= 0 + && dagReachable g j i + in not $ or [ cyclePair i j | i <- [0 .. p - 1], j <- [0 .. p - 1] ] + +-- | [日本語]: topological sort: 根 (parents なし) から葉までの並び。 +-- 循環を検出した場合は 'Nothing'。 Kahn のアルゴリズム (Pure 版)。 +-- [English]: Topological sort: an ordering from the roots (no +-- parents) to the leaves. Returns 'Nothing' if a cycle is detected. +-- Kahn's algorithm (a pure version). +topoSort :: DAG -> Maybe [Int] +topoSort g = + let !p = dagN g + inDeg0 = V.fromList [ length (dagParents g i) | i <- [0 .. p - 1] ] + go acc inDeg remaining + | null remaining = Just (reverse acc) + | otherwise = + case findRoot remaining inDeg of + Nothing -> Nothing -- 循環 + Just r -> + let kids = dagChildren g r + inDegN = V.imap + (\idx v -> if idx `elem` kids then v - 1 else v) + inDeg + in go (r : acc) inDegN (filter (/= r) remaining) + in go [] inDeg0 [0 .. p - 1] + where + findRoot xs inDeg = + case filter (\i -> (inDeg V.! i) == 0) xs of + [] -> Nothing + (h:_) -> Just h + +-- =========================================================================== +-- 出力 +-- =========================================================================== + +-- | [日本語]: Graphviz DOT 形式で出力。 シェル経由で +-- @echo "..." | dot -Tpng -o dag.png@ で可視化可能。 +-- [English]: Outputs the graph in Graphviz DOT format. Can be +-- visualized via the shell with +-- @echo "..." | dot -Tpng -o dag.png@. +toDOT :: DAG -> Text +toDOT g = + let header = T.pack "digraph G {\n rankdir=LR;\n" + footer = T.pack "}\n" + nodes = T.concat + [ T.pack " " <> sanitize (dagNodeName g i) + <> T.pack " [label=\"" <> dagNodeName g i <> T.pack "\"];\n" + | i <- [0 .. dagN g - 1] ] + edges = T.concat + [ T.pack " " <> sanitize (dagNodeName g (edgeFrom e)) + <> T.pack " -> " <> sanitize (dagNodeName g (edgeTo e)) + <> T.pack " [label=\"" + <> T.pack (showWeight (edgeWeight e)) + <> T.pack "\"];\n" + | e <- dagEdges g ] + in header <> nodes <> edges <> footer + where + sanitize = T.replace (T.pack " ") (T.pack "_") + . T.replace (T.pack "-") (T.pack "_") + showWeight w = let r = round (w * 1000) :: Int + in show (fromIntegral r / 1000 :: Double) diff --git a/src/Hanalyze/Model/DecisionTree.hs b/src/Hanalyze/Model/DecisionTree.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/DecisionTree.hs @@ -0,0 +1,552 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.DecisionTree +-- Description : 決定木分類器 (CART, classification) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Decision tree classifier (CART, classification). +-- +-- Pairs with the existing regression-oriented 'Hanalyze.Model.RandomForest'; +-- this module focuses on classification. Splits use Gini impurity as +-- the criterion (matches sklearn default). +-- +-- @ +-- import Hanalyze.Model.DecisionTree +-- +-- let cfg = defaultDecisionTree +-- tree = fitDT cfg xs ys -- xs :: [[Double]], ys :: [Int] +-- yhat = map (predictDT tree) xs +-- @ +-- +-- /Performance/: the primary fit API is now 'fitDTV', which takes a +-- contiguous 'LA.Matrix' of features and an unboxed 'VU.Vector' of +-- labels. The classic 'fitDT' over @[[Double]]@ / @[Int]@ is preserved +-- as a backwards-compatible wrapper that converts at the boundary. +-- The internal representation keeps a single shared feature matrix +-- and recurses on row-index permutations, so building a tree is +-- @O(p · n log n · depth)@ rather than the old @O(p · n² · depth)@. +module Hanalyze.Model.DecisionTree + ( -- * Tree types + DTree (..) + , DTFit (..) + , DTConfig (..) + , defaultDecisionTree + -- * Fit / predict + , fitDT + , fitDTV + , predictDT + , predictDTProbs + -- * Text export (R @print.rpart@ 相当) + , printRpart + , printRpartRaw + -- * Helpers + , giniImpurity + ) where + +import qualified Data.Map.Strict as Map +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import qualified Data.Vector.Algorithms.Intro as Intro +import qualified Numeric.LinearAlgebra as LA +import Control.Monad.ST (runST) +import Data.List (foldl') +import Data.Text (Text) +import qualified Data.Text as T +import Numeric (showFFloat) + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +-- | [日本語]: 決定木。 各ノードに __サンプル数 n / gini 不純度 / クラス分布 / 多数決クラス__ +-- を保持する (rpart.plot / sklearn plot_tree 水準の樹形図・ルールテキスト出力のため)。 +-- 予測 (predict) の数値は不変。 +-- [English]: A classification decision tree node. Each node holds the +-- __sample count n / Gini impurity / class distribution / majority class__ +-- (for rpart.plot \/ sklearn plot_tree-level tree diagrams and rule-text +-- output). The predicted values are unaffected. +data DTree + = DLeaf + { dlClassProbs :: !(Map.Map Int Double) -- ^ [日本語]: クラス割合。 [English]: The class proportions. + , dlMajority :: !Int -- ^ [日本語]: 多数決クラス (予測)。 [English]: The majority class (the prediction). + , dlN :: !Int -- ^ [日本語]: このノードのサンプル数。 [English]: The sample count at this node. + , dlImpurity :: !Double -- ^ [日本語]: gini 不純度。 [English]: The Gini impurity. + } + | DNode + { dnFeature :: !Int + , dnThr :: !Double + , dnLeft :: !DTree + , dnRight :: !DTree + , dnN :: !Int -- ^ [日本語]: このノードのサンプル数。 [English]: The sample count at this node. + , dnImpurity :: !Double -- ^ [日本語]: 分割前の gini 不純度。 [English]: The Gini impurity before the split. + , dnProbs :: !(Map.Map Int Double) -- ^ [日本語]: 分割前のクラス割合。 [English]: The class proportions before the split. + , dnMajority :: !Int -- ^ [日本語]: 分割前の多数決クラス。 [English]: The majority class before the split. + } + deriving (Show) + +-- | [日本語]: 学習済み決定木 + 表示メタ (特徴量名・クラス名)。 高レベル @df |-> decisionTree@ +-- ('Hanalyze.Fit') が fit 時に手元の実列名とクラス列の levels を載せて返す +-- ('RandomForestClassifier.RFClassifierFit' と同型のラッパ)。 これにより @treePlot@ / +-- @printRpart@ は名前を手渡しせず @DTFit@ 一つで済む。 クラス番号 (0..K-1) は +-- @dtClassNames !! k@ で名前が引ける。 +-- [English]: A fitted decision tree + display metadata (feature names, +-- class names). The high-level @df |-> decisionTree@ ('Hanalyze.Fit') +-- returns the actual column names and the class column's levels at fit +-- time (a wrapper isomorphic to 'RandomForestClassifier.RFClassifierFit'). +-- This lets @treePlot@ \/ @printRpart@ work with a single @DTFit@ instead +-- of passing names separately. The name for class index (0..K-1) can be +-- looked up via @dtClassNames !! k@. +data DTFit = DTFit + { dtTree :: !DTree -- ^ [日本語]: 学習済み木。 [English]: The fitted tree. + , dtFeatureNames :: ![Text] -- ^ [日本語]: 特徴量名 (fit に使った列順)。 [English]: The feature names (in the column order used for fitting). + , dtClassNames :: ![Text] -- ^ [日本語]: クラス名 (label 0..K-1 に対応する levels)。 [English]: The class names (the levels corresponding to labels 0..K-1). + } deriving (Show) + +-- | Decision tree configuration. +data DTConfig = DTConfig + { dtMaxDepth :: !(Maybe Int) + , dtMinSamplesSplit :: !Int + , dtMinSamplesLeaf :: !Int + , dtMinImpurity :: !Double + } deriving (Show, Eq) + +-- | Defaults (sklearn-compatible): unlimited depth, min split 2, +-- min leaf 1, min impurity 0. +defaultDecisionTree :: DTConfig +defaultDecisionTree = DTConfig + { dtMaxDepth = Nothing + , dtMinSamplesSplit = 2 + , dtMinSamplesLeaf = 1 + , dtMinImpurity = 0 + } + +-- --------------------------------------------------------------------------- +-- Fit (Vector-based primary API) +-- --------------------------------------------------------------------------- + +-- | Fit a decision tree from a row-major feature matrix and unboxed +-- label vector. This is the high-performance path; 'fitDT' is a +-- list-based backwards-compatibility wrapper. +fitDTV :: DTConfig -> LA.Matrix Double -> VU.Vector Int -> DTree +fitDTV cfg x y = + let !n = VU.length y + !idx = VU.enumFromN 0 n + in buildNodeV cfg x y idx 0 + +-- | Backwards-compatible list-based fit. +fitDT :: DTConfig -> [[Double]] -> [Int] -> DTree +fitDT cfg xs ys + | null xs = DLeaf Map.empty 0 0 0 + | otherwise = fitDTV cfg (LA.fromLists xs) (VU.fromList ys) + +-- --------------------------------------------------------------------------- +-- Recursive build over row-index permutations +-- --------------------------------------------------------------------------- + +buildNodeV + :: DTConfig + -> LA.Matrix Double -- ^ Shared feature matrix (n × p). + -> VU.Vector Int -- ^ Shared label vector (length n). + -> VU.Vector Int -- ^ Row indices in this subtree. + -> Int -- ^ Current depth. + -> DTree +buildNodeV cfg x y idx depth = + let !nIdx = VU.length idx + !sublabs = VU.map (y VU.!) idx + !probs = classProbsV sublabs + !gini = giniFromCounts probs + !majority = argMaxClass probs + leaf = DLeaf probs majority nIdx gini + + depthLimit = case dtMaxDepth cfg of + Just d -> depth >= d + Nothing -> False + stop = depthLimit + || nIdx < dtMinSamplesSplit cfg + || gini < dtMinImpurity cfg + || allSameV sublabs + in if stop + then leaf + else case bestSplitV cfg x y idx of + Nothing -> leaf + Just (fIdx, thr, _gain) -> + let (lIdx, rIdx) = partitionVIdx x idx fIdx thr + in if VU.length lIdx < dtMinSamplesLeaf cfg + || VU.length rIdx < dtMinSamplesLeaf cfg + then leaf + else DNode + { dnFeature = fIdx + , dnThr = thr + , dnLeft = buildNodeV cfg x y lIdx (depth + 1) + , dnRight = buildNodeV cfg x y rIdx (depth + 1) + , dnN = nIdx + , dnImpurity = gini + , dnProbs = probs + , dnMajority = majority + } + +-- | Partition row indices by a feature threshold. +partitionVIdx + :: LA.Matrix Double + -> VU.Vector Int + -> Int + -> Double + -> (VU.Vector Int, VU.Vector Int) +partitionVIdx x idx feat thr = + let pred_ i = LA.atIndex x (i, feat) <= thr + in VU.partition pred_ idx + +-- --------------------------------------------------------------------------- +-- Class probabilities and Gini on subsets +-- --------------------------------------------------------------------------- + +-- | Class probability map (class → fraction). +classProbsV :: VU.Vector Int -> Map.Map Int Double +classProbsV ys = + let !n = fromIntegral (VU.length ys) :: Double + counts = VU.foldl' + (\m c -> Map.insertWith (+) c (1 :: Double) m) + Map.empty ys + in Map.map (/ n) counts + +allSameV :: VU.Vector Int -> Bool +allSameV ys + | VU.null ys = True + | otherwise = + let !y0 = VU.unsafeHead ys + in VU.all (== y0) (VU.unsafeTail ys) + +giniFromCounts :: Map.Map Int Double -> Double +giniFromCounts ps = 1 - foldl' (\acc p -> acc + p * p) 0 (Map.elems ps) + +-- | Backwards-compatible Gini on @[Int]@. +giniImpurity :: [Int] -> Double +giniImpurity [] = 0 +giniImpurity ys = + let !n = fromIntegral (length ys) :: Double + counts = foldl' (\m c -> Map.insertWith (+) c (1 :: Double) m) + Map.empty ys + in 1 - foldl' (\acc c -> acc + (c / n) ^ (2 :: Int)) 0 (Map.elems counts) + +-- | [日本語]: 多数決 (予測) クラス = 確率最大のクラス。 同点は __最小クラス index__ を選ぶ +-- (rpart / sklearn 慣例)。 @Map.toList@ は昇順 key なので、 @foldl'@ で「厳密に +-- 大きい確率でだけ更新」すれば先勝ち = 最小 index の同点タイブレークになる。 +-- +-- ⚠ 旧 @sortByValDescV@ は名前に反して昇順を返し (@reverse . 降順ソート@)、 +-- @head@ が __最小確率クラス (argmin)__ を拾っていた。 深さ無制限で葉が純粋な間は +-- 露見しないが、 depth/min_samples で止まった混在葉で予測が少数派に化ける実バグ +-- だった (樹形図を目視して発覚・修正)。 +-- +-- [English]: The majority (predicted) class = the class with the highest +-- probability. Ties are broken by choosing the __smallest class index__ +-- (rpart \/ sklearn convention). Since @Map.toList@ has ascending keys, +-- @foldl'@ that "updates only on a strictly larger probability" gives a +-- first-wins tiebreak = the smallest index among ties wins. +-- +-- ⚠ The old @sortByValDescV@, despite its name, returned an ascending +-- order (@reverse . descending sort@), so @head@ picked up the +-- __smallest-probability class (argmin)__. This went unnoticed while +-- depth was unlimited and leaves stayed pure, but was a real bug in which +-- predictions for mixed leaves stopped by depth\/min_samples flipped to +-- the minority class (discovered and fixed by visually inspecting a tree +-- diagram). +argMaxClass :: Map.Map Int Double -> Int +argMaxClass m = case Map.toList m of + [] -> 0 + (x : xs) -> fst (foldl' better x xs) + where + better acc@(_, av) cur@(_, cv) + | cv > av = cur -- 厳密に大きい確率のときだけ更新。 + | otherwise = acc -- 同点は据置き = 昇順 key で先に来た小さい index が勝つ。 + +-- --------------------------------------------------------------------------- +-- Best split: per-feature O(n log n) sweep with running counts +-- --------------------------------------------------------------------------- + +bestSplitV + :: DTConfig + -> LA.Matrix Double + -> VU.Vector Int + -> VU.Vector Int + -> Maybe (Int, Double, Double) +bestSplitV _cfg x y idx + | VU.length idx < 2 = Nothing + | otherwise = + let !p = LA.cols x + best = foldr step Nothing [0 .. p - 1] + step i acc = + case bestSplitFeature x y idx i of + Nothing -> acc + Just (thr, g) -> + case acc of + Nothing -> Just (i, thr, g) + Just (_, _, gPrev) | g > gPrev -> Just (i, thr, g) + | otherwise -> acc + in best + +-- | Per-feature best split on the index subset. Returns @Just (thr, +-- gain)@ where @gain@ is the impurity reduction (parent − weighted +-- children); negative or zero means no useful split was found. +bestSplitFeature + :: LA.Matrix Double + -> VU.Vector Int + -> VU.Vector Int + -> Int + -> Maybe (Double, Double) +bestSplitFeature x y idx feat = runST $ do + let !n = VU.length idx + -- Build (value, label) pairs for this subset and sort by value. + let valOf i = LA.atIndex x (i, feat) + lab i = y VU.! i + pairs <- VUM.new n + let fill !k + | k == n = pure () + | otherwise = do + let !i = VU.unsafeIndex idx k + VUM.unsafeWrite pairs k (valOf i, lab i) + fill (k + 1) + fill 0 + Intro.sortBy (\a b -> compare (fst a) (fst b)) pairs + pairsF <- VU.unsafeFreeze pairs + + -- Determine the number of distinct classes within this subset. + let labels = VU.map snd pairsF + let !numClasses = 1 + VU.maximum labels -- labels are non-negative + + -- Right counts start with all labels. + rightCounts <- VUM.replicate numClasses (0 :: Int) + let initRight !k + | k == n = pure () + | otherwise = do + let !c = VU.unsafeIndex labels k + old <- VUM.unsafeRead rightCounts c + VUM.unsafeWrite rightCounts c (old + 1) + initRight (k + 1) + initRight 0 + leftCounts <- VUM.replicate numClasses (0 :: Int) + + let parentImp = giniFromIntCountsRO numClasses (VU.toList (VU.map snd pairsF)) + + -- Sweep through sorted pairs, moving sample i to the left side and + -- evaluating split between i and i+1 only when value changes. + let sweep !k !bestThr !bestGain + | k >= n - 1 = pure (bestThr, bestGain) + | otherwise = do + let (v_k, c_k) = VU.unsafeIndex pairsF k + (v_k1, _) = VU.unsafeIndex pairsF (k + 1) + -- Move sample k to left. + lOld <- VUM.unsafeRead leftCounts c_k + VUM.unsafeWrite leftCounts c_k (lOld + 1) + rOld <- VUM.unsafeRead rightCounts c_k + VUM.unsafeWrite rightCounts c_k (rOld - 1) + -- Skip threshold if values equal — splitting equal + -- samples is meaningless. + if v_k == v_k1 + then sweep (k + 1) bestThr bestGain + else do + let !thr = (v_k + v_k1) / 2 + !nL = k + 1 + !nR = n - nL + gL <- giniMutable leftCounts numClasses nL + gR <- giniMutable rightCounts numClasses nR + let !nD = fromIntegral n :: Double + !child = (fromIntegral nL * gL + fromIntegral nR * gR) / nD + !gain = parentImp - child + if gain > bestGain + then sweep (k + 1) thr gain + else sweep (k + 1) bestThr bestGain + (thr, gain) <- sweep 0 0 (negate (1.0 / 0.0)) + pure $ if gain == negate (1.0 / 0.0) + then Nothing + else Just (thr, gain) + where + -- Compute Gini from a mutable Int counts vector + total n. + giniMutable counts numClasses nTot + | nTot == 0 = pure 0 + | otherwise = do + let !nD = fromIntegral nTot :: Double + loop !i !acc + | i == numClasses = pure (1 - acc) + | otherwise = do + c <- VUM.unsafeRead counts i + let !p = fromIntegral c / nD + loop (i + 1) (acc + p * p) + loop 0 0 + +-- | Read-only Gini from a list of class labels (used once per node +-- for the parent impurity baseline). +giniFromIntCountsRO :: Int -> [Int] -> Double +giniFromIntCountsRO numClasses labels = + let !n = fromIntegral (length labels) :: Double + counts = foldl' (\m c -> Map.insertWith (+) c (1 :: Double) m) + Map.empty labels + _ = numClasses -- silence unused + in 1 - sum [ (c / n) ^ (2 :: Int) | c <- Map.elems counts ] + +-- --------------------------------------------------------------------------- +-- Predict +-- --------------------------------------------------------------------------- + +-- | Predict the majority class label for one sample. +predictDT :: DTree -> [Double] -> Int +predictDT DLeaf{dlMajority = m} _ = m +predictDT DNode{dnFeature = i, dnThr = thr, dnLeft = l, dnRight = r} x + | x !! i <= thr = predictDT l x + | otherwise = predictDT r x + +-- | Predict class probabilities for one sample. +predictDTProbs :: DTree -> [Double] -> Map.Map Int Double +predictDTProbs DLeaf{dlClassProbs = p} _ = p +predictDTProbs DNode{dnFeature = i, dnThr = thr, dnLeft = l, dnRight = r} x + | x !! i <= thr = predictDTProbs l x + | otherwise = predictDTProbs r x + +-- --------------------------------------------------------------------------- +-- Text export (R print.rpart 相当) +-- --------------------------------------------------------------------------- + +-- | [日本語]: 決定木のルールを R @print.rpart@ 形式のテキストで出力する。 +-- +-- R の rpart オブジェクトを @print@ したときと同じ体裁: +-- +-- @ +-- n= <total> +-- +-- node), split, n, loss, yval, (yprob) +-- * denotes terminal node +-- +-- 1) root 12 8 setosa (0.3333 0.3333 0.3333) +-- 2) petal_width< 0.80 4 0 setosa (1.0000 0.0000 0.0000) * +-- 3) petal_width>=0.80 8 4 versicolor (0.0000 0.5000 0.5000) +-- 6) petal_width< 1.65 4 0 versicolor (0.0000 1.0000 0.0000) * +-- 7) petal_width>=1.65 4 0 virginica (0.0000 0.0000 1.0000) * +-- @ +-- +-- 各行 = @<node#>) <split> <n> <loss> <yval> (<yprob…>) [*]@。 +-- ノード番号は R 同様 root=1・子は @2k@/@2k+1@。 @loss@ = 誤分類数 +-- (n − 多数決クラス件数)、 @yval@ = 予測クラス、 @yprob@ = 木に現れる全クラスの +-- 確率 (クラス index 昇順)、 @*@ = 終端 (葉)。 分岐は R の固定幅表記に忠実に +-- 左 = @name< thr@ (≤・条件成立)、 右 = @name>=thr@ とする (dtreeToDag と同じ +-- 左 ≤ / 右 > 慣例)。 +-- +-- 第 1 引数 = 特徴量名、 第 2 引数 = クラス名 (yval に使う factor 水準)。 +-- いずれも index に対し長さ不足・空文字なら @f{i}@ / 生の整数へフォールバックする +-- (行列 fit で名無しの木でも動く)。 各ノードに載せた n / gini / クラス分布 +-- から純粋計算し、 予測 (predict) の数値には非依存。 +-- +-- 高レベル版 — 'DTFit' からノード規則テキストを出す ('df |-> decisionTree' の返り値 +-- をそのまま渡せる)。 名前を手渡ししたい低レベルは 'printRpartRaw'。 +-- +-- [English]: Outputs a decision tree's rules as text in R @print.rpart@ +-- format. +-- +-- The same layout as when an R rpart object is @print@-ed: +-- +-- @ +-- n= <total> +-- +-- node), split, n, loss, yval, (yprob) +-- * denotes terminal node +-- +-- 1) root 12 8 setosa (0.3333 0.3333 0.3333) +-- 2) petal_width< 0.80 4 0 setosa (1.0000 0.0000 0.0000) * +-- 3) petal_width>=0.80 8 4 versicolor (0.0000 0.5000 0.5000) +-- 6) petal_width< 1.65 4 0 versicolor (0.0000 1.0000 0.0000) * +-- 7) petal_width>=1.65 4 0 virginica (0.0000 0.0000 1.0000) * +-- @ +-- +-- Each line = @<node#>) <split> <n> <loss> <yval> (<yprob…>) [*]@. +-- Node numbers follow R's convention: root=1, children @2k@\/@2k+1@. @loss@ +-- = the misclassification count (n − the majority class count), @yval@ = +-- the predicted class, @yprob@ = the probabilities of all classes appearing +-- in the tree (ascending class index), @*@ = terminal (leaf). Splits follow +-- R's fixed-width notation faithfully: left = @name< thr@ (≤, condition +-- holds), right = @name>=thr@ (the same left ≤ \/ right > convention as +-- dtreeToDag). +-- +-- The first argument = feature names, the second = class names (the factor +-- levels used for yval). For both, an index with insufficient length or an +-- empty string falls back to @f{i}@ \/ the raw integer (works even for a +-- tree with no names from a matrix fit). Computed purely from the n \/ gini +-- \/ class distribution carried at each node, independent of the predicted +-- (predict) values. +-- +-- The high-level version — outputs node rule text from a 'DTFit' (the +-- return value of @df |-> decisionTree@ can be passed directly). The +-- low-level version for passing names explicitly is 'printRpartRaw'. +printRpart :: DTFit -> Text +printRpart (DTFit tree feats classes) = printRpartRaw feats classes tree + +-- | [日本語]: 行列 fit 用の低レベル版 — 特徴量名・クラス名を明示的に渡す。 +-- [English]: The low-level version for matrix fits — passes feature names +-- and class names explicitly. +printRpartRaw :: [Text] -> [Text] -> DTree -> Text +printRpartRaw featNames classNames tree = + T.intercalate "\n" (header ++ go 1 0 "root" tree) + where + classes = Map.keys (labelSet tree) -- 木に現れる全クラス (昇順)。 + header = + [ "n= " <> tShow (nodeN tree) + , "" + , "node), split, n, loss, yval, (yprob)" + , " * denotes terminal node" + , "" ] + + go :: Int -> Int -> Text -> DTree -> [Text] + go num d split node = + let n = nodeN node + probs = nodeProbs node + maj = nodeMajority node + loss = n - round (Map.findWithDefault 0 maj probs * fromIntegral n) :: Int + yprob = "(" <> T.intercalate " " + [ fmt4 (Map.findWithDefault 0 c probs) | c <- classes ] <> ")" + term = case node of DLeaf{} -> " *"; _ -> "" + line = T.concat (replicate d " ") <> tShow num <> ") " <> split + <> " " <> tShow n <> " " <> tShow loss <> " " <> classLabel maj + <> " " <> yprob <> term + in case node of + DLeaf{} -> [line] + DNode f thr l r _ _ _ _ -> + let fn = featName f + lb = fn <> "< " <> fmt2 thr + rb = fn <> ">=" <> fmt2 thr + in line : go (2 * num) (d + 1) lb l ++ go (2 * num + 1) (d + 1) rb r + + featName i = pick i featNames ("f" <> tShow i) + classLabel i = pick i classNames (tShow i) + pick i xs dflt = case drop i xs of + (nm : _) | not (T.null nm) -> nm + _ -> dflt + + tShow = T.pack . show + fmt2 x = T.pack (showFFloat (Just 2) x "") + fmt4 x = T.pack (showFFloat (Just 4) x "") + +-- | [日本語]: 木に現れる全クラス label を集めた集合 (値は () のダミー)。 'Map.keys' で昇順。 +-- [English]: The set of all class labels appearing in the tree (values are +-- a dummy @()@). Ascending via 'Map.keys'. +labelSet :: DTree -> Map.Map Int () +labelSet (DLeaf p m _ _) = Map.insert m () (() <$ p) +labelSet (DNode _ _ l r _ _ p m) = + Map.unions [Map.insert m () (() <$ p), labelSet l, labelSet r] + +-- ノードアクセサ (葉 / 分岐 共通)。 +nodeN :: DTree -> Int +nodeN (DLeaf _ _ n _) = n +nodeN (DNode _ _ _ _ n _ _ _) = n + +nodeProbs :: DTree -> Map.Map Int Double +nodeProbs (DLeaf p _ _ _) = p +nodeProbs (DNode _ _ _ _ _ _ p _) = p + +nodeMajority :: DTree -> Int +nodeMajority (DLeaf _ m _ _) = m +nodeMajority (DNode _ _ _ _ _ _ _ m) = m + +-- Silence unused-import warning for V (keeps import slot for future +-- variants without re-touching imports). +_unused :: V.Vector Int -> Int +_unused = V.length diff --git a/src/Hanalyze/Model/Discriminant.hs b/src/Hanalyze/Model/Discriminant.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Discriminant.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.Discriminant +-- Description : 判別分析 (Linear / Quadratic Discriminant Analysis) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 判別分析 (Linear / Quadratic Discriminant Analysis)。 +-- +-- 連続説明変数で複数クラスを判別する古典的手法。 +-- +-- - 'LDA': 全クラスで共分散行列を共通 (pooled) と仮定 → 線形決定境界 +-- - 'QDA': クラスごとに共分散行列が異なる → 二次決定境界 +-- +-- 予測は class-conditional 密度 × prior の対数 (log-posterior) を比較。 +-- 数値安定化のため Cholesky 分解経由で log-determinant + Mahalanobis 距離を +-- 計算する。 hmatrix Vector / Matrix 演算で完結 (list 化禁止)。 +-- +-- [English]: Discriminant analysis (Linear \/ Quadratic Discriminant +-- Analysis). +-- +-- Classic methods for discriminating between multiple classes using +-- continuous predictors. +-- +-- - 'LDA': assumes a common (pooled) covariance matrix across all +-- classes → a linear decision boundary +-- - 'QDA': allows a different covariance matrix per class → a +-- quadratic decision boundary +-- +-- Prediction compares the log of class-conditional density × prior +-- (log-posterior). For numerical stability, the log-determinant and +-- Mahalanobis distance are computed via Cholesky decomposition. Stays +-- entirely within hmatrix Vector \/ Matrix operations (no list conversion). +module Hanalyze.Model.Discriminant + ( DiscriminantMethod (..) + , DiscriminantFit (..) + , fitLDA + , fitQDA + , predictDiscriminant + ) where + +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA +import Data.List (nub, sort) +import Data.Text (Text) +import qualified Data.Text as T + +-- =========================================================================== +-- 型 +-- =========================================================================== + +data DiscriminantMethod = LDA | QDA deriving (Show, Eq) + +data DiscriminantFit = DiscriminantFit + { dfMeans :: !(LA.Matrix Double) + -- ^ [日本語]: K × p、 各クラスの平均ベクトル + -- [English]: K × p, each class's mean vector + , dfCovariance :: !(LA.Matrix Double) + -- ^ [日本語]: LDA: pooled covariance (p × p)、 QDA: 空 (使わず、 dfCovariances を見る) + -- [English]: LDA: the pooled covariance (p × p); QDA: empty (unused, see dfCovariances) + , dfCovariances :: ![LA.Matrix Double] + -- ^ [日本語]: QDA: クラス別 covariance (K matrices)、 LDA: 空 + -- [English]: QDA: per-class covariance (K matrices); LDA: empty + , dfPriors :: !(LA.Vector Double) + -- ^ [日本語]: クラス事前確率 (length K、 sum = 1) + -- [English]: Class prior probabilities (length K, sum = 1) + , dfClasses :: !(LA.Vector Double) + -- ^ [日本語]: クラス label (sorted、 length K、 Int を Double で保持) + -- [English]: Class labels (sorted, length K, Int held as Double) + , dfMethod :: !DiscriminantMethod + } deriving (Show) + +-- =========================================================================== +-- 公開関数 +-- =========================================================================== + +-- | [日本語]: LDA fit: pooled covariance、 線形判別。 +-- [English]: LDA fit: pooled covariance, linear discrimination. +fitLDA :: LA.Matrix Double -- ^ [日本語]: X (n × p) [English]: X (n × p) + -> V.Vector Int -- ^ [日本語]: y (n)、 整数クラスラベル [English]: y (n), integer class labels + -> Either Text DiscriminantFit +fitLDA x y + | LA.rows x /= V.length y = + Left "fitLDA: X rows and y length mismatch" + | LA.rows x < 2 = + Left "fitLDA: need at least 2 observations" + | length classIds < 2 = + Left "fitLDA: need at least 2 distinct classes" + | otherwise = + let (means, sigmaP, priors) = pooledStats x y classIds + in Right DiscriminantFit + { dfMeans = means + , dfCovariance = sigmaP + , dfCovariances = [] + , dfPriors = priors + , dfClasses = LA.fromList (map fromIntegral classIds) + , dfMethod = LDA + } + where + classIds = sort (nub (V.toList y)) + +-- | [日本語]: QDA fit: クラス別 covariance。 +-- [English]: QDA fit: per-class covariance. +fitQDA :: LA.Matrix Double -> V.Vector Int -> Either Text DiscriminantFit +fitQDA x y + | LA.rows x /= V.length y = + Left "fitQDA: X rows and y length mismatch" + | LA.rows x < 2 = + Left "fitQDA: need at least 2 observations" + | length classIds < 2 = + Left "fitQDA: need at least 2 distinct classes" + | minimum classCounts < LA.cols x + 1 = + Left (T.pack ("fitQDA: each class needs ≥ p+1 = " + <> show (LA.cols x + 1) <> " observations (got min " + <> show (minimum classCounts) <> ")")) + | otherwise = + let (means, covs, priors) = perClassStats x y classIds + in Right DiscriminantFit + { dfMeans = means + , dfCovariance = LA.fromLists [[]] + , dfCovariances = covs + , dfPriors = priors + , dfClasses = LA.fromList (map fromIntegral classIds) + , dfMethod = QDA + } + where + classIds = sort (nub (V.toList y)) + classCounts = [length [i | i <- [0 .. V.length y - 1], y V.! i == c] + | c <- classIds] + +-- | [日本語]: 予測。 返り値 = (予測ラベル長 m, posterior 行列 m × K)。 +-- [English]: Prediction. Returns (predicted labels, length m; posterior +-- matrix, m × K). +predictDiscriminant + :: DiscriminantFit + -> LA.Matrix Double -- ^ [日本語]: X_new (m × p) [English]: X_new (m × p) + -> (V.Vector Int, LA.Matrix Double) +predictDiscriminant fit xNew = + let m = LA.rows xNew + k = LA.size (dfPriors fit) + classLabels = LA.toList (dfClasses fit) + -- 各サンプル × 各クラスの log-posterior を計算 + logPostMat = LA.fromLists + [ [ logPosterior fit (LA.flatten (xNew LA.? [i])) j + | j <- [0 .. k - 1] ] + | i <- [0 .. m - 1] ] + -- 各行で argmax → ラベル予測 + predLabels = V.fromList + [ let row = LA.toList (logPostMat LA.! i) + maxIdx = snd (maximum (zip row [0 ..])) + in round (classLabels !! maxIdx :: Double) :: Int + | i <- [0 .. m - 1] ] + -- posterior = exp(log-post) / Σ exp(log-post) (各行で normalize) + posteriorMat = LA.fromLists + [ let row = LA.toList (logPostMat LA.! i) + maxLP = maximum row + expRow = map (\x -> exp (x - maxLP)) row + s = sum expRow + in if s > 0 then map (/ s) expRow else expRow + | i <- [0 .. m - 1] ] + in (predLabels, posteriorMat) + +-- =========================================================================== +-- 内部 helper +-- =========================================================================== + +-- | [日本語]: log p(class=j) + log f(x | class=j) +-- - LDA: − 0.5 (x − μ_j)ᵀ Σ_p⁻¹ (x − μ_j) + log π_j (定数項を省略) +-- - QDA: − 0.5 log |Σ_j| − 0.5 (x − μ_j)ᵀ Σ_j⁻¹ (x − μ_j) + log π_j +-- [English]: log p(class=j) + log f(x | class=j) +-- - LDA: − 0.5 (x − μ_j)ᵀ Σ_p⁻¹ (x − μ_j) + log π_j (omitting the constant term) +-- - QDA: − 0.5 log |Σ_j| − 0.5 (x − μ_j)ᵀ Σ_j⁻¹ (x − μ_j) + log π_j +logPosterior :: DiscriminantFit -> LA.Vector Double -> Int -> Double +logPosterior fit x j = + let mu_j = LA.flatten (dfMeans fit LA.? [j]) + diff = x - mu_j + logPi = log (LA.atIndex (dfPriors fit) j) + in case dfMethod fit of + LDA -> + let sigInvDiff = case LA.linearSolve (dfCovariance fit) + (LA.asColumn diff) of + Just m -> LA.flatten m + Nothing -> diff -- singular fallback + mahal = LA.sumElements (diff * sigInvDiff) + in -0.5 * mahal + logPi + QDA -> + let sigma_j = dfCovariances fit !! j + logDet = log (max 1e-300 (LA.det sigma_j)) + sigInvDiff = case LA.linearSolve sigma_j (LA.asColumn diff) of + Just m -> LA.flatten m + Nothing -> diff + mahal = LA.sumElements (diff * sigInvDiff) + in -0.5 * logDet - 0.5 * mahal + logPi + +-- | [日本語]: 各クラスの平均と pooled covariance + prior を計算。 +-- [English]: Compute each class's mean along with the pooled covariance + prior. +pooledStats + :: LA.Matrix Double -> V.Vector Int -> [Int] + -> (LA.Matrix Double, LA.Matrix Double, LA.Vector Double) +pooledStats x y classIds = + let n = LA.rows x + p = LA.cols x + nD = fromIntegral n :: Double + classRows c = [i | i <- [0 .. n - 1], y V.! i == c] + classN c = fromIntegral (length (classRows c)) :: Double + means = LA.fromRows + [ let rs = classRows c + xc = x LA.? rs + n_c = fromIntegral (length rs) :: Double + colSum j = LA.sumElements (xc LA.¿ [j]) + in LA.fromList [ colSum j / n_c | j <- [0 .. p - 1] ] + | c <- classIds ] + -- pooled covariance: Σ_p = Σ_c (n_c - 1) S_c / (n - K) + sigmaP = + let k = length classIds + sumS = foldr (+) (LA.konst 0 (p, p)) + [ let rs = classRows c + xc = x LA.? rs + mu = LA.flatten (means LA.? [idx]) + centered = xc - LA.fromRows (replicate (length rs) mu) + in LA.tr centered LA.<> centered -- (n_c - 1) S_c + | (idx, c) <- zip [0 ..] classIds ] + in LA.scale (1 / fromIntegral (n - k)) sumS + priors = LA.fromList [ classN c / nD | c <- classIds ] + in (means, sigmaP, priors) + +-- | [日本語]: クラス別 mean + cov + prior。 +-- [English]: Per-class mean + covariance + prior. +perClassStats + :: LA.Matrix Double -> V.Vector Int -> [Int] + -> (LA.Matrix Double, [LA.Matrix Double], LA.Vector Double) +perClassStats x y classIds = + let n = LA.rows x + p = LA.cols x + nD = fromIntegral n :: Double + classRows c = [i | i <- [0 .. n - 1], y V.! i == c] + means = LA.fromRows + [ let rs = classRows c + xc = x LA.? rs + n_c = fromIntegral (length rs) :: Double + colSum j = LA.sumElements (xc LA.¿ [j]) + in LA.fromList [ colSum j / n_c | j <- [0 .. p - 1] ] + | c <- classIds ] + covs = + [ let rs = classRows c + xc = x LA.? rs + n_c = fromIntegral (length rs) :: Double + mu = LA.flatten (means LA.? [idx]) + centered = xc - LA.fromRows (replicate (length rs) mu) + in LA.scale (1 / (n_c - 1)) (LA.tr centered LA.<> centered) + | (idx, c) <- zip [0 ..] classIds ] + priors = LA.fromList + [ fromIntegral (length (classRows c)) / nD | c <- classIds ] + _ = p -- silence + in (means, covs, priors) diff --git a/src/Hanalyze/Model/FDA.hs b/src/Hanalyze/Model/FDA.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/FDA.hs @@ -0,0 +1,299 @@ +-- | +-- Module : Hanalyze.Model.FDA +-- Description : 関数データ解析 (Functional Data Analysis, FDA) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Functional Data Analysis (FDA)。 +-- +-- センサ / プロセス時系列を __1 観測 = 1 関数__として扱う Ramsay-Silverman +-- FDA の基礎機能。 個別の生時系列ではなく、 関数空間上の主成分 / 回帰を +-- 直接扱う。 +-- +-- ## 構成 +-- +-- - 'smoothBasis': 各サンプルを B-spline basis + 二階差分 (P-spline) penalty +-- で smooth fit → 'FunctionalSample' (basis 係数表現) +-- - 'functionalPCA': basis 係数行列の covariance に PCA、 関数主成分 +-- - 'fLM': functional linear regression @y_i = α + ∫ x_i(t) β(t) dt + ε@ +-- +-- 既存 'Hanalyze.Model.Spline' の @bsplineBasis@ を basis 生成として再利用。 +-- Fourier basis は将来拡張 (現状は対象外)。 +-- +-- Reference: Ramsay & Silverman (2005) "Functional Data Analysis" 2nd ed. +-- Eilers-Marx (1996) "Flexible smoothing with B-splines and penalties" — +-- P-spline 二階差分 penalty。 +-- +-- [English]: Functional Data Analysis (FDA). +-- +-- Basic Ramsay-Silverman FDA functionality that treats sensor\/process +-- time series as __one observation = one function__. Rather than +-- individual raw time series, it works directly with principal components +-- \/ regression over function space. +-- +-- == Structure +-- +-- - 'smoothBasis': smooth-fits each sample with a B-spline basis + a +-- second-difference (P-spline) penalty → 'FunctionalSample' (basis +-- coefficient representation) +-- - 'functionalPCA': PCA on the covariance of the basis coefficient +-- matrix, giving functional principal components +-- - 'fLM': functional linear regression @y_i = α + ∫ x_i(t) β(t) dt + ε@ +-- +-- Reuses the existing 'Hanalyze.Model.Spline''s @bsplineBasis@ for +-- basis generation. A Fourier basis is a future extension (out of scope +-- for now). +-- +-- Reference: Ramsay & Silverman (2005) "Functional Data Analysis" 2nd ed. +-- Eilers-Marx (1996) "Flexible smoothing with B-splines and penalties" — +-- the P-spline second-difference penalty. +module Hanalyze.Model.FDA + ( Basis (..) + , FunctionalSample (..) + , smoothBasis + , evalFunctional + -- * FPCA + , FunctionalPCA (..) + , functionalPCA + -- * Functional Linear Regression + , FLMResult (..) + , fLM + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified Data.Vector as V +import qualified Hanalyze.Model.Spline as Sp + +-- --------------------------------------------------------------------------- +-- 基底 +-- --------------------------------------------------------------------------- + +-- | [日本語]: basis 種別。 現在は B-spline のみ実装、 Fourier は将来拡張。 +-- [English]: Basis kind. Currently only B-spline is implemented; Fourier +-- is a future extension. +data Basis + = BSpline !Int ![Double] -- ^ [日本語]: (degree, interior knots、 境界含む) [English]: (degree, interior knots, including boundary) + deriving (Show) + +-- | [日本語]: smooth した関数表現 (basis 係数 + 元 grid)。 +-- [English]: A smoothed functional representation (basis coefficients + original grid). +data FunctionalSample = FunctionalSample + { fsCoef :: !(LA.Vector Double) -- ^ [日本語]: basis 係数 [English]: Basis coefficients + , fsBasis :: !Basis + , fsGrid :: !(LA.Vector Double) -- ^ [日本語]: 元の時間 grid (eval 用) [English]: The original time grid (for evaluation) + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- 33-A1: smoothBasis (P-spline) +-- --------------------------------------------------------------------------- + +-- | [日本語]: 複数サンプルを basis + roughness penalty で smooth fit。 +-- +-- 解: @c = (BᵀB + λ DᵀD)⁻¹ Bᵀy@ (= P-spline、 D は二階差分作用素)。 +-- @λ → 0@ で interpolate、 @λ → ∞@ で over-smooth (≈ 一次関数)。 +-- +-- 入力 @y@ は @n_samples × n_grid@、 各行が 1 サンプル。 +-- +-- [English]: Smooth-fit multiple samples with a basis + roughness penalty. +-- +-- Solution: @c = (BᵀB + λ DᵀD)⁻¹ Bᵀy@ (a P-spline, where D is the +-- second-difference operator). @λ → 0@ interpolates; @λ → ∞@ over-smooths +-- (≈ a linear function). +-- +-- Input @y@ is @n_samples × n_grid@, with each row a single sample. +smoothBasis + :: Basis -- ^ [日本語]: basis (B-spline) [English]: The basis (B-spline) + -> Double -- ^ [日本語]: roughness penalty @λ@ [English]: Roughness penalty @λ@ + -> LA.Vector Double -- ^ [日本語]: 時間 grid @t@ (長さ @n_grid@) [English]: Time grid @t@ (length @n_grid@) + -> LA.Matrix Double -- ^ [日本語]: 観測 @y@ (@n_samples × n_grid@) [English]: Observations @y@ (@n_samples × n_grid@) + -> [FunctionalSample] +smoothBasis basis@(BSpline deg intKnots) lambda tGrid yMat = + let tV = V.fromList (LA.toList tGrid) + bMat = Sp.bsplineBasis deg intKnots tV -- n_grid × d + d = LA.cols bMat + btb = LA.tr bMat LA.<> bMat + penalty = diff2Penalty d + reg = btb + LA.scale lambda penalty + -- 各行 (= 1 サンプル) について解く: c = (BᵀB+λΩ)⁻¹ Bᵀy_i + btY = LA.tr bMat LA.<> LA.tr yMat -- d × n_samples + cMat = reg LA.<\> btY -- d × n_samples + n = LA.rows yMat + in [ FunctionalSample + { fsCoef = LA.flatten (cMat LA.¿ [i]) + , fsBasis = basis + , fsGrid = tGrid + } + | i <- [0 .. n - 1] ] + +-- | [日本語]: smooth した関数を任意 grid で評価。 +-- [English]: Evaluate the smoothed function on an arbitrary grid. +evalFunctional :: FunctionalSample -> LA.Vector Double -> LA.Vector Double +evalFunctional fs tNew = + case fsBasis fs of + BSpline deg intKnots -> + let tV = V.fromList (LA.toList tNew) + bM = Sp.bsplineBasis deg intKnots tV + in bM LA.#> fsCoef fs + +-- | [日本語]: 二階差分 penalty 行列 @DᵀD@ (= 連続二階微分の量を有限差分で近似)。 +-- @D@ は @(d-2) × d@、 @D_{i,j} = 1 if j=i、 -2 if j=i+1、 1 if j=i+2@。 +-- +-- [English]: The second-difference penalty matrix @DᵀD@ (approximating +-- the continuous second derivative via finite differences). @D@ is +-- @(d-2) × d@, with @D_{i,j} = 1 if j=i, -2 if j=i+1, 1 if j=i+2@. +diff2Penalty :: Int -> LA.Matrix Double +diff2Penalty d + | d <= 2 = LA.konst 0 (d, d) + | otherwise = + let dM = LA.fromLists + [ [ if j == i then 1 + else if j == i + 1 then -2 + else if j == i + 2 then 1 + else 0 + | j <- [0 .. d - 1] ] + | i <- [0 .. d - 3] ] + in LA.tr dM LA.<> dM + +-- --------------------------------------------------------------------------- +-- 33-A2: Functional PCA +-- --------------------------------------------------------------------------- + +data FunctionalPCA = FunctionalPCA + { fpcaScores :: !(LA.Matrix Double) -- ^ [日本語]: n × K (各サンプルの主成分得点) [English]: n × K (each sample's principal-component scores) + , fpcaEigenfn :: !(LA.Matrix Double) -- ^ [日本語]: K × n_grid (主成分関数を grid 上で評価) [English]: K × n_grid (principal-component functions evaluated on the grid) + , fpcaEigenvalues :: !(LA.Vector Double) -- ^ [日本語]: length K (降順) [English]: length K (descending) + , fpcaMeanFn :: !(LA.Vector Double) -- ^ [日本語]: length n_grid (平均関数) [English]: length n_grid (mean function) + } deriving (Show) + +-- | [日本語]: basis 係数行列の covariance に PCA。 簡略実装として basis 係数空間で +-- PCA を行い、 主成分関数を grid 上で評価して返す (= basis が直交近似で +-- ある前提)。 厳密版は basis mass matrix @J = ∫ B B^T@ で重み付き SVD が +-- 必要だが、 B-spline + dense grid なら直交近似で十分実用に耐える。 +-- +-- [English]: PCA on the covariance of the basis coefficient matrix. As a +-- simplified implementation, this runs PCA in the basis coefficient +-- space and evaluates the principal-component functions on the grid +-- (assuming the basis is approximately orthogonal). An exact version +-- would need a weighted SVD using the basis mass matrix @J = ∫ B B^T@, +-- but for B-spline + a dense grid the orthogonal approximation is +-- accurate enough for practical use. +functionalPCA + :: Int -- ^ [日本語]: 主成分数 K [English]: Number of principal components K + -> [FunctionalSample] + -> FunctionalPCA +functionalPCA k samples = + let cMat = LA.fromColumns (map fsCoef samples) -- d × n + n = LA.cols cMat + d = LA.rows cMat + mu = LA.scale (1 / fromIntegral n) + (cMat LA.#> LA.konst 1 n) + cCentered = cMat - LA.asColumn mu -- d × n + cov = LA.scale (1 / fromIntegral (max 1 (n - 1))) + (cCentered LA.<> LA.tr cCentered) -- d × d + (eigVals, eigVecs) = LA.eigSH (LA.trustSym cov) + -- hmatrix eigSH は降順で返す + kEff = min k d + topVecs = eigVecs LA.¿ [0 .. kEff - 1] -- d × K + topVals = LA.subVector 0 kEff eigVals + -- score: K × n、 各列 = 係数空間での座標 + scoresT = LA.tr topVecs LA.<> cCentered + -- 主成分関数を grid 上で評価 + sampleBasis = fsBasis (head samples) + tGrid = fsGrid (head samples) + eigFn = case sampleBasis of + BSpline deg intKnots -> + let bM = Sp.bsplineBasis deg intKnots + (V.fromList (LA.toList tGrid)) -- n_grid × d + in LA.tr (bM LA.<> topVecs) -- K × n_grid + meanFn = case sampleBasis of + BSpline deg intKnots -> + let bM = Sp.bsplineBasis deg intKnots + (V.fromList (LA.toList tGrid)) + in bM LA.#> mu + in FunctionalPCA + { fpcaScores = LA.tr scoresT + , fpcaEigenfn = eigFn + , fpcaEigenvalues = topVals + , fpcaMeanFn = meanFn + } + +-- --------------------------------------------------------------------------- +-- 33-A3: Functional Linear Regression +-- --------------------------------------------------------------------------- + +data FLMResult = FLMResult + { flmAlpha :: !Double -- ^ [日本語]: intercept [English]: Intercept + , flmBetaFn :: !(LA.Vector Double) -- ^ [日本語]: β(t) を共通 grid 上で評価 [English]: β(t) evaluated on the common grid + , flmFitted :: !(LA.Vector Double) -- ^ [日本語]: ŷ_i (length n) [English]: ŷ_i (length n) + , flmR2 :: !Double + } deriving (Show) + +-- | [日本語]: Functional linear regression: @y_i = α + ∫ x_i(t) β(t) dt + ε@. +-- +-- @β(t)@ を同じ basis で展開: @β(t) = B(t)^T γ@。 すると +-- @∫ x_i(t) β(t) dt = c_i^T J γ@ ここで @J = ∫ B(t) B(t)^T dt@ (mass matrix)。 +-- 設計行列 @[1, c_i^T J]@ で OLS + 任意の roughness penalty。 +-- +-- mass matrix @J@ は trapezoidal 積分で近似: +-- @J ≈ Δt · B^T diag(w) B@ where @w@ は等間隔積分重み (端点 0.5、 内点 1)。 +-- +-- [English]: Functional linear regression: @y_i = α + ∫ x_i(t) β(t) dt + ε@. +-- +-- Expand @β(t)@ in the same basis: @β(t) = B(t)^T γ@. Then +-- @∫ x_i(t) β(t) dt = c_i^T J γ@ where @J = ∫ B(t) B(t)^T dt@ (the mass +-- matrix). Runs OLS on the design matrix @[1, c_i^T J]@ plus an optional +-- roughness penalty. +-- +-- The mass matrix @J@ is approximated by trapezoidal integration: +-- @J ≈ Δt · B^T diag(w) B@ where @w@ is the evenly-spaced integration +-- weight (0.5 at the endpoints, 1 at interior points). +fLM + :: [FunctionalSample] -- ^ [日本語]: X_i(t) [English]: X_i(t) + -> LA.Vector Double -- ^ [日本語]: y (n samples) [English]: y (n samples) + -> Double -- ^ [日本語]: λ (β(t) の二階差分 penalty) [English]: λ (second-difference penalty on β(t)) + -> FLMResult +fLM samples y lambda = + let sample0 = head samples + basis@(BSpline deg intKnots) = fsBasis sample0 + tGrid = fsGrid sample0 + tV = V.fromList (LA.toList tGrid) + bM = Sp.bsplineBasis deg intKnots tV + nGrid = LA.size tGrid + -- trapezoidal 重み + dt = if nGrid >= 2 + then (LA.atIndex tGrid (nGrid - 1) - LA.atIndex tGrid 0) + / fromIntegral (nGrid - 1) + else 1 + wVec = LA.fromList + ([0.5] ++ replicate (max 0 (nGrid - 2)) 1.0 ++ [0.5]) + wScaled = LA.scale dt wVec + -- mass matrix J = B^T diag(w) B (d × d) + jMat = LA.tr bM LA.<> (LA.asColumn wScaled * bM) + -- 設計行列: 各 i 行 = [1, c_i^T J] (length 1 + d) + cMat = LA.fromRows (map fsCoef samples) -- n × d + ciJ = cMat LA.<> jMat -- n × d + n = LA.rows cMat + xDes = LA.fromColumns + (LA.konst 1 n : LA.toColumns ciJ) -- n × (1 + d) + -- penalty: intercept は 0、 γ には二階差分 penalty + d = LA.cols cMat + pen = diff2Penalty d + penFull = LA.diagBlock [LA.scalar 0, LA.scale lambda pen] + reg = LA.tr xDes LA.<> xDes + penFull + xty = LA.tr xDes LA.#> y + coefs = LA.flatten (reg LA.<\> LA.asColumn xty) + alpha = LA.atIndex coefs 0 + gamma = LA.subVector 1 d coefs + yHat = xDes LA.#> coefs + resid = y - yHat + yMean = LA.sumElements y / fromIntegral n + ssTot = LA.sumElements ((y - LA.scalar yMean) ^ (2 :: Int)) + ssRes = LA.sumElements (resid ^ (2 :: Int)) + r2 = if ssTot == 0 then 0 else 1 - ssRes / ssTot + betaFn = bM LA.#> gamma + in FLMResult + { flmAlpha = alpha + , flmBetaFn = betaFn + , flmFitted = yHat + , flmR2 = r2 + } diff --git a/src/Hanalyze/Model/FitYByX.hs b/src/Hanalyze/Model/FitYByX.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/FitYByX.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.FitYByX +-- Description : JMP "Fit Y by X" platform 相当の自動 dispatch wrapper +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: JMP \"Fit Y by X\" platform 相当の wrapper。 +-- +-- X / Y それぞれが連続 (Continuous) か カテゴリ (Categorical) かで +-- 適切な解析を自動 dispatch する: +-- +-- @ +-- X \\ Y | Continuous | Categorical +-- --------+----------------------+--------------------- +-- Cont | 単回帰 (LM) | logistic GLM +-- Cat | one-way ANOVA | chi-square independence +-- @ +-- +-- canvas frontend で 「変数 2 つドラッグ → 自動分析」 を支える backend wrapper。 +-- +-- [English]: A wrapper equivalent to JMP's \"Fit Y by X\" platform. +-- +-- Automatically dispatches to the appropriate analysis depending on +-- whether X \/ Y are each continuous or categorical: +-- +-- @ +-- X \\ Y | Continuous | Categorical +-- --------+----------------------+--------------------- +-- Cont | simple regression (LM) | logistic GLM +-- Cat | one-way ANOVA | chi-square independence +-- @ +-- +-- The backend wrapper behind the canvas frontend's "drag 2 variables → +-- auto-analyze". +module Hanalyze.Model.FitYByX + ( VarType (..) + , FitYByXResult (..) + , fitYByX + ) where + +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA +import Data.List (nub, sort) +import Data.Text (Text) + +import qualified Hanalyze.Model.Core as Core +import qualified Hanalyze.Model.LM as LM +import qualified Hanalyze.Model.GLM as GLM +import qualified Hanalyze.Stat.Test as ST + +-- =========================================================================== +-- 型 +-- =========================================================================== + +data VarType + = Continuous + | Categorical + deriving (Show, Eq) + +data FitYByXResult + = FitContCont !Core.FitResult + -- ^ [日本語]: 単回帰: y = β₀ + β₁ x。 [English]: Simple regression: y = β₀ + β₁ x. + | FitCatCont !ST.TestResult ![Double] + -- ^ one-way ANOVA + group means (group order = sort.nub of x) + | FitContCat !Core.FitResult + -- ^ logistic GLM: P(Y=1) = sigmoid(β₀ + β₁ x) + | FitCatCat !ST.TestResult + -- ^ chi-square independence + deriving (Show) + +-- =========================================================================== +-- 公開 API +-- =========================================================================== + +-- | [日本語]: X / Y の型に応じて適切な解析を dispatch する。 +-- 入力は両方とも Double Vector。 Categorical の場合は整数値を Double 化 +-- して渡す前提 (例: 0, 1, 2, ...)。 +-- [English]: Dispatches to the appropriate analysis depending on the +-- types of X \/ Y. Both inputs are Double Vectors; for Categorical, +-- integer values are assumed to be passed converted to Double (e.g. +-- 0, 1, 2, ...). +fitYByX + :: VarType -> VarType + -> LA.Vector Double -- ^ X + -> LA.Vector Double -- ^ Y + -> Either Text FitYByXResult +fitYByX xt yt x y + | LA.size x /= LA.size y = + Left "fitYByX: X and Y must have the same length" + | LA.size x < 2 = + Left "fitYByX: need at least 2 observations" + | otherwise = case (xt, yt) of + (Continuous, Continuous) -> + let xMat = LA.fromColumns [LA.fromList (replicate (LA.size x) 1), x] + in Right (FitContCont (LM.fitLMVec xMat y)) + + (Categorical, Continuous) -> + let levels = sort (nub (LA.toList x)) + groups = [ LA.fromList + [ LA.atIndex y i + | i <- [0 .. LA.size x - 1] + , LA.atIndex x i == lvl ] + | lvl <- levels ] + tr = ST.anovaOneWay groups + means = [ LA.sumElements g / fromIntegral (LA.size g) + | g <- groups ] + in if any ((< 1) . LA.size) groups + then Left "fitYByX (cat × cont): some groups are empty" + else Right (FitCatCont tr means) + + (Continuous, Categorical) -> + -- Y must be binary 0/1 for logistic + let ys = LA.toList y + in if not (all (\v -> v == 0 || v == 1) ys) + then Left "fitYByX (cont × cat): Y must be binary 0/1 for logistic GLM" + else + let xMat = LA.fromColumns + [LA.fromList (replicate (LA.size x) 1), x] + in Right (FitContCat (GLM.fitGLM GLM.Binomial xMat y)) + + (Categorical, Categorical) -> + let xLevels = sort (nub (LA.toList x)) + yLevels = sort (nub (LA.toList y)) + cell xl yl = fromIntegral $ length + [ () | i <- [0 .. LA.size x - 1] + , LA.atIndex x i == xl + , LA.atIndex y i == yl ] + tbl = LA.fromLists + [ [ cell xl yl | yl <- yLevels ] | xl <- xLevels ] + in if length xLevels < 2 || length yLevels < 2 + then Left "fitYByX (cat × cat): need at least 2 levels per axis" + else Right (FitCatCat (ST.chiSquareIndep tbl)) + where + _ = V.length :: V.Vector Int -> Int -- silence warn diff --git a/src/Hanalyze/Model/Formula.hs b/src/Hanalyze/Model/Formula.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Formula.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Hanalyze.Model.Formula +-- Description : Formula DSL 正本 front-end (独自・明示係数構文) の parser と AST +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Formula DSL — 正本 front-end (独自・明示係数構文) の parser と AST。 +-- +-- このモジュールの責務は「文字列 → 構文木 (Formula AST)」 のみ。 +-- AST が真の正本で、 R/patsy front-end も同じ AST に落とす。 +-- 意味論的分類 (Ref がデータ変数かパラメータか・factor 添字・基底展開) は +-- data と突合する後段 (ModelFrame / designMatrixF) に委ねる。 +-- ゆえに本モジュールは plot 非依存・portable (upstream hanalyze cherry-pick 候補)。 +-- +-- 構文 (例): @"y x group = b0 + b1*x + b2*log x + bg ! group"@ +-- - 左辺 @y x group@ で 応答=y / データ変数=x,group を宣言。 +-- - 右辺の自由名 (左辺に無い名前) = 推定パラメータ。 +-- - @+@ @-@ @*@ @/@ @^@ は常に本物の算術 (R formula の「項追加」 ではない)。 +-- - 添字 @bg ! group@ = 係数ベクトル × factor 水準 (@!@ は Haskell 正規の添字演算子)。 +-- - 交互作用は型で分解: 連続×連続 @b*x*z@ / factor×連続 @bg ! group * x@ / +-- factor×factor @b ! x ! z@ (@!@ 連鎖 = 2 次元添字)。 +-- - 適用 @log x@ / @exp(-b*x)@ / @bspline(x,k)@ (空白並置・括弧引数どちらも App)。 +-- +-- [English]: Formula DSL — the parser and AST for the canonical +-- front-end (its own, explicit-coefficient syntax). +-- +-- This module's sole responsibility is "string → syntax tree (Formula +-- AST)". The AST is the true source of truth, and the R/patsy +-- front-end also lowers into the same AST. Semantic classification +-- (whether a Ref is a data variable or a parameter, factor +-- subscripting, basis expansion) is deferred to the later stage that +-- cross-references it against the data (ModelFrame \/ designMatrixF). +-- Hence this module is plot-independent and portable (a candidate for +-- cherry-picking into the upstream hanalyze). +-- +-- Syntax (example): @"y x group = b0 + b1*x + b2*log x + bg ! group"@ +-- - The left-hand side @y x group@ declares response=y \/ data +-- variables=x,group. +-- - Free names on the right-hand side (names not on the left) are +-- estimated parameters. +-- - @+@ @-@ @*@ @/@ @^@ are always real arithmetic (not R formula's +-- "term addition"). +-- - Subscript @bg ! group@ = coefficient vector × factor level (@!@ +-- is Haskell's ordinary indexing operator). +-- - Interactions are decomposed by type: continuous×continuous +-- @b*x*z@ \/ factor×continuous @bg ! group * x@ \/ +-- factor×factor @b ! x ! z@ (chained @!@ = 2-dimensional +-- subscripting). +-- - Application @log x@ \/ @exp(-b*x)@ \/ @bspline(x,k)@ (both +-- whitespace juxtaposition and parenthesized arguments are App). +module Hanalyze.Model.Formula + ( -- * AST (真の正本) + Formula (..) + , Term (..) + , BinOp (..) + -- * Parse (正本 front-end = 独自構文) + , parseFormula + -- * Pretty (round-trip 検証用・正規形) + , prettyFormula + , prettyTerm + ) where + +import Control.Monad.Combinators.Expr (Operator (..), makeExprParser) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char (alphaNumChar, char, letterChar, + space1) +import qualified Text.Megaparsec.Char.Lexer as L + +-- ============================================================================ +-- AST — parse 結果の構文木 (意味論的分類は後段) +-- ============================================================================ + +-- | [日本語]: 二項算術演算子 (すべて本物の算術)。 +-- [English]: Binary arithmetic operators (all real arithmetic). +data BinOp = Add | Sub | Mul | Div | Pow + deriving (Eq, Show) + +-- | [日本語]: 右辺の式木。 Ref がデータ変数かパラメータかは 'Formula' の LHS +-- 宣言で決まる。 +-- [English]: The expression tree for the right-hand side. Whether a +-- Ref is a data variable or a parameter is decided by the LHS +-- declaration in 'Formula'. +data Term + = Lit Double -- ^ [日本語]: 数値リテラル (非負。 負号は 'Neg' が担う)。 [English]: A numeric literal (non-negative; the sign is handled by 'Neg'). + | Ref Text -- ^ [日本語]: 識別子参照 (x / b1 / group)。 [English]: An identifier reference (x / b1 / group). + | App Text [Term] -- ^ [日本語]: 関数適用 log x / exp(-b*x) / bspline(x,k)。 [English]: Function application: log x / exp(-b*x) / bspline(x,k). + | Index Term Term -- ^ [日本語]: 添字 bg ! group (連鎖 b!x!z = Index (Index (Ref b) (Ref x)) (Ref z))。 [English]: Subscripting bg ! group (chained b!x!z = Index (Index (Ref b) (Ref x)) (Ref z)). + | Neg Term -- ^ [日本語]: 単項マイナス -x。 [English]: Unary minus -x. + | Bin BinOp Term Term -- ^ [日本語]: 二項算術。 [English]: Binary arithmetic. + deriving (Eq, Show) + +-- | [日本語]: formula 全体。 左辺で応答 + データ変数を宣言、 右辺が式。 +-- [English]: The whole formula. The left-hand side declares the +-- response plus data variables, and the right-hand side is the +-- expression. +data Formula = Formula + { formResponse :: Text -- ^ [日本語]: 応答変数 y。 [English]: The response variable y. + , formDataVars :: [Text] -- ^ [日本語]: データ変数宣言 (x, group, …)。 右辺の自由名でこれに無い名前 = パラメータ。 [English]: Data-variable declarations (x, group, …). Free names on the right-hand side not in this list are parameters. + , formRHS :: Term -- ^ [日本語]: 右辺式。 [English]: The right-hand-side expression. + } + deriving (Eq, Show) + +-- ============================================================================ +-- Parser (megaparsec) — 字句 / 優先順位 / formula 全体 +-- ============================================================================ + +type Parser = Parsec Void Text + +-- | [日本語]: 空白消費 (コメントは持たない)。 +-- [English]: Consumes whitespace (has no comment support). +sc :: Parser () +sc = L.space space1 empty empty + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +symbol :: Text -> Parser Text +symbol = L.symbol sc + +-- | [日本語]: 識別子: 英字/_ 始まり、 英数/_ 継続。 +-- [English]: An identifier: starts with a letter or @_@, continues +-- with letters/digits/@_@. +identifier :: Parser Text +identifier = lexeme $ do + c <- letterChar <|> char '_' + cs <- many (alphaNumChar <|> char '_') + pure (T.pack (c : cs)) + +-- | [日本語]: 数値リテラル (非負)。 float 優先 (0.5)、 無ければ整数 (2)。 +-- [English]: A numeric literal (non-negative). Tries float first +-- (0.5), falling back to integer (2). +number :: Parser Double +number = lexeme (try L.float <|> (fromIntegral <$> (L.decimal :: Parser Integer))) + +-- | [日本語]: 括弧でくくった部分式 (grouping)。 +-- [English]: A subexpression wrapped in parentheses (grouping). +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +-- | [日本語]: atom = 数値 | 括弧グループ | 識別子参照。 +-- [English]: atom = number | parenthesized group | identifier +-- reference. +pAtom :: Parser Term +pAtom = + (Lit <$> number) + <|> parens pExpr + <|> (Ref <$> identifier) + +-- | [日本語]: 適用項。 識別子の直後に +-- - 括弧引数 @f(a, b, …)@ が来れば多引数 App、 +-- - 空白並置 atom @log x@ が来れば単/多引数 App、 +-- どちらも無ければただの atom。 +-- [English]: An application term. Immediately after an identifier: +-- - if parenthesized arguments @f(a, b, …)@ follow, a multi-arg App; +-- - if a whitespace-juxtaposed atom @log x@ follows, a single-\/ +-- multi-arg App; +-- if neither, just the atom. +pApp :: Parser Term +pApp = do + h <- pAtom + case h of + Ref f -> do + mcall <- optional (parens (pExpr `sepBy1` symbol ",")) + case mcall of + Just args -> pure (App f args) -- f(a, b) + Nothing -> do + xs <- many pAtom -- log x (空白並置) + pure (if null xs then h else App f xs) + _ -> pure h + +-- | [日本語]: 式 (優先順位付き)。 高→低: @!@ 添字 > @^@ > 単項@-@ > @* /@ > @+ -@。 +-- [English]: An expression (with precedence). Highest to lowest: +-- @!@ subscript > @^@ > unary @-@ > @* /@ > @+ -@. +pExpr :: Parser Term +pExpr = makeExprParser pApp opTable + +opTable :: [[Operator Parser Term]] +opTable = + [ [ InfixL (Index <$ symbol "!") ] -- 添字 (左結合・最高位) + , [ InfixR (Bin Pow <$ symbol "^") ] -- べき (右結合) + , [ Prefix (Neg <$ symbol "-") ] -- 単項マイナス (^ より下) + , [ InfixL (Bin Mul <$ symbol "*") + , InfixL (Bin Div <$ symbol "/") ] + , [ InfixL (Bin Add <$ symbol "+") + , InfixL (Bin Sub <$ symbol "-") ] + ] + +-- | [日本語]: formula 全体: @LHS変数列 = RHS式@。 +-- [English]: The whole formula: @LHS variable list = RHS expression@. +pFormula :: Parser Formula +pFormula = do + sc + vars <- some identifier + _ <- symbol "=" + rhs <- pExpr + eof + case vars of + (y : ds) -> pure (Formula y ds rhs) + [] -> fail "左辺に応答変数がありません" + +-- | [日本語]: 文字列 → 'Formula'。 失敗時は人間可読なエラーメッセージ。 +-- [English]: Parses a string into a 'Formula'. On failure, produces a +-- human-readable error message. +parseFormula :: Text -> Either String Formula +parseFormula t = + case parse pFormula "" t of + Left err -> Left (errorBundlePretty err) + Right f -> Right f + +-- ============================================================================ +-- Pretty — round-trip の正規形 (App は常に括弧形式で曖昧性ゼロ) +-- ============================================================================ + +-- | [日本語]: 'Formula' を正規形文字列に。 @parseFormula (prettyFormula f) == +-- Right f@ を満たす。 +-- [English]: Renders a 'Formula' to its canonical-form string. +-- Satisfies @parseFormula (prettyFormula f) == Right f@. +prettyFormula :: Formula -> Text +prettyFormula (Formula y ds rhs) = + T.unwords (y : ds) <> " = " <> prettyTerm rhs + +-- | [日本語]: 右辺式を正規形に (優先順位に応じ最小限の括弧)。 +-- [English]: Renders the right-hand-side expression to canonical form +-- (minimal parentheses according to precedence). +prettyTerm :: Term -> Text +prettyTerm = go 0 + where + -- prec: 親文脈の結合度。 子の演算子優先度が親より緩ければ括弧。 + go :: Int -> Term -> Text + go _ (Lit d) = prettyNum d + go _ (Ref x) = x + go _ (App f as) = f <> "(" <> T.intercalate ", " (map (go 0) as) <> ")" + go p (Index a b) = paren (p > 6) (go 6 a <> " ! " <> go 7 b) + -- operand は prec 5 で描く: 連続前置 (Neg (Neg …) = "-(-…)") も括弧化され parse 可能に。 + go p (Neg a) = paren (p > 4) ("-" <> go 5 a) + go p (Bin op a b) = + let pr = binPrec op + (lp, rp) = case op of + Pow -> (pr + 1, pr) -- 右結合 + _ -> (pr, pr + 1) -- 左結合 + in paren (p > pr) (go lp a <> " " <> binSym op <> " " <> go rp b) + + paren True s = "(" <> s <> ")" + paren False s = s + +binPrec :: BinOp -> Int +binPrec Add = 1 +binPrec Sub = 1 +binPrec Mul = 2 +binPrec Div = 2 +binPrec Pow = 5 + +binSym :: BinOp -> Text +binSym Add = "+" +binSym Sub = "-" +binSym Mul = "*" +binSym Div = "/" +binSym Pow = "^" + +-- | [日本語]: 整数値は小数点無しで (round-trip 安定)。 +-- [English]: Integer-valued numbers are rendered without a decimal +-- point (for round-trip stability). +prettyNum :: Double -> Text +prettyNum d + | d == fromIntegral n = T.pack (show n) + | otherwise = T.pack (show d) + where n = round d :: Integer diff --git a/src/Hanalyze/Model/Formula/Design.hs b/src/Hanalyze/Model/Formula/Design.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Formula/Design.hs @@ -0,0 +1,559 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Hanalyze.Model.Formula.Design +-- Description : Formula DSL の設計行列組み立て (designMatrixF) + 線形性/識別性検出 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Formula DSL — designMatrixF + 線形性検出 + 識別性 (A17)。 +-- 'ModelFrame' から OLS 用の設計行列を組み立て、 線形モデルなら 'fitLMF' で fit する。 +-- +-- ★中核の考え方: +-- - 右辺を加法項に分解し、 各項を乗法葉 (param / factor 添字 / data 式) に分類。 +-- - __線形 OLS では parameter 名自体は fit に効かない__ (各設計列に 1 係数が付くだけ)。 +-- param 名が効くのは ① 報告 ② 非線形検出。 → param が data 式の内側に現れたら +-- 「非線形 (OLS 不可)」 として Left を返す = 線形性検出を兼ねる。 +-- - factor は __使われ方 (! 添字)__ で展開 ('ModelFrame' が既に判定済)。 識別性は +-- treatment contrast: 切片があれば参照水準 (=第1水準, 昇順先頭) を drop して満ランク化。 +-- - 交互作用は専用演算子を持たず、 連続×連続=積・factor×連続=水準別列・factor×factor= +-- 添字連鎖の grid 展開、 として加法項ごとに独立に列生成。 +-- +-- ★検証原理 (parameterization 不変): ŷ と R² は contrast の取り方に依らない。 +-- 飽和 factor×factor の ŷ = セル平均、 という Python 非依存オラクルで正しさを確認できる。 +-- +-- spline/poly 基底展開 (@bs ! bspline(x,k)@) は本 sub では未対応 (明示エラー)。 後続で配線。 +-- +-- [English]: Formula DSL — designMatrixF + linearity detection + +-- identifiability (A17). +-- Builds the OLS design matrix from a 'ModelFrame', and fits it with +-- 'fitLMF' if the model is linear. +-- +-- ★Core idea: +-- - Decompose the right-hand side into additive terms, and classify +-- each term's multiplicative leaves (param \/ factor subscript \/ +-- data expression). +-- - In __linear OLS the parameter name itself has no effect on the fit__ +-- (each design column just gets one coefficient). The param +-- name matters only for ① reporting and ② nonlinearity detection — +-- if a param appears inside a data expression, this returns Left as +-- "nonlinear (OLS not applicable)", which doubles as linearity +-- detection. +-- - A factor is expanded according to __how it is used (! subscript)__ +-- (already determined by 'ModelFrame'). Identifiability uses +-- treatment contrast: if there is an intercept, the reference level +-- (= the first level in ascending order) is dropped to obtain full +-- rank. +-- - Interactions have no dedicated operator; continuous×continuous = +-- product, factor×continuous = per-level columns, and +-- factor×factor = a grid expansion of the subscript chain, with +-- columns generated independently per additive term. +-- +-- ★Validation principle (parameterization-invariant): ŷ and R² do not +-- depend on the choice of contrast. Correctness can be checked against +-- a Python-independent oracle: for a saturated factor×factor model, +-- ŷ = the cell means. +-- +-- Spline\/poly basis expansion (@bs ! bspline(x,k)@) is not supported in +-- this sub (an explicit error is raised); wiring is planned for later. +module Hanalyze.Model.Formula.Design + ( designMatrixF + , fitLMF + , responseVec + , linearityCheck + -- * Contrast coding (A2) + , ContrastCoding (..) + , contrastMatrix + , parseContrast + -- * weights / offset = WLS (A3) + , WLSConfig (..) + , defaultWLS + , fitWLSF + ) where + +import Data.Maybe (catMaybes, isNothing) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA + +import Hanalyze.DataIO.Convert (getDoubleVec) +import Hanalyze.DataIO.Preprocess (dropMissingRows) +import Hanalyze.Model.Core (FitResult) +import Hanalyze.Model.LM (fitLM) +import Hanalyze.Model.Spline (bsplineBasis, quantileKnots) +import Hanalyze.Model.Formula (BinOp (..), Formula (..), Term (..), + prettyTerm) +import Hanalyze.Model.Formula.Frame +import qualified DataFrame.Internal.DataFrame as DX + +-- ============================================================================ +-- 加法 / 乗法への分解 +-- ============================================================================ + +-- | [日本語]: 加法項に分解。 符号 (Sub/Neg) は係数に吸収され ŷ に効かないので Add 扱い。 +-- [English]: Decomposes into additive terms. Sign (Sub/Neg) is absorbed +-- into the coefficient and does not affect ŷ, so it is treated as Add. +flattenAdd :: Term -> [Term] +flattenAdd (Bin Add a b) = flattenAdd a ++ flattenAdd b +flattenAdd (Bin Sub a b) = flattenAdd a ++ flattenAdd b +flattenAdd (Neg a) = flattenAdd a +flattenAdd t = [t] + +-- | [日本語]: 乗法葉に分解。 +-- [English]: Decomposes into multiplicative leaves. +mulLeaves :: Term -> [Term] +mulLeaves (Bin Mul a b) = mulLeaves a ++ mulLeaves b +mulLeaves (Neg a) = mulLeaves a +mulLeaves t = [t] + +-- | [日本語]: Index spine: 入れ子添字を (base 項, [添字項]) に。 base が Ref でなければ +-- Nothing。 +-- [English]: Index spine: unnests nested subscripts into (base term, +-- [subscript terms]). Returns Nothing if the base is not a Ref. +indexSpine :: Term -> Maybe (Term, [Term]) +indexSpine (Index a b) = do (base, ixs) <- indexSpine a; pure (base, ixs ++ [b]) +indexSpine t = Just (t, []) + +-- ============================================================================ +-- 乗法葉の分類 +-- ============================================================================ + +data Leaf + = LParam Text -- ^ [日本語]: パラメータ単独 (係数。 OLS 列は持たない)。 [English]: A bare parameter (a coefficient; has no OLS column). + | LFactor [(Text, ContrastCoding)] -- ^ [日本語]: factor 添字 + contrast (1 個=主効果 / 複数=交互作用)。 [English]: Factor subscript(s) + contrast (one = main effect / multiple = interaction). + | LBasis Text [Term] -- ^ [日本語]: 基底展開 (bs ! bspline(x,n) / bp ! poly(x,n))。 [English]: Basis expansion (bs ! bspline(x,n) / bp ! poly(x,n)). + | LData Term -- ^ [日本語]: データ式 (連続変数・Lit・単項関数・算術)。 [English]: A data expression (continuous variable, Lit, unary function, arithmetic). + +-- | [日本語]: 基底関数名 (! の右に App として現れたら factor でなく基底展開)。 +-- [English]: Basis function names (if it appears as an App to the right +-- of !, it is a basis expansion rather than a factor). +basisFns :: [Text] +basisFns = ["poly", "opoly", "bspline"] + +classify :: ModelFrame -> Term -> Either String Leaf +classify mf leaf = + case indexSpine leaf of + Just (Ref _, [App f args]) | f `elem` basisFns -> Right (LBasis f args) + Just (Ref _, ixs@(_:_)) -> LFactor <$> mapM ixName ixs + _ -> case leaf of + Ref x + | x `elem` mfParams mf -> Right (LParam x) + -- 裸の factor = 主効果 (R 意味論 A17b: @y ~ … + g@ の @g@ が factor 列なら treatment + -- contrast の主効果列。 @!@ 添字版 @bg!g@ と同一の LFactor に落とす)。 + | isFactor x -> Right (LFactor [(x, Treatment)]) + _ -> Right (LData leaf) + where + -- 添字 → (factor 名, contrast)。 @Ref g@ = 無注釈 treatment、 + -- @C(g, coding)@ = contrast 注釈、 @C(g)@ = treatment。 + ixName (Ref x) + | isFactor x = Right (x, Treatment) + | otherwise = Left $ "添字 '" <> T.unpack x <> "' は factor でなければなりません" + ixName (App "C" (Ref x : rest)) + | isFactor x = (\c -> (x, c)) <$> codingOf rest + | otherwise = Left $ "C(...) の '" <> T.unpack x <> "' は factor でなければなりません" + ixName (App f _) = Left $ "基底 '" <> T.unpack f + <> "' は factor 添字と混在できません (基底項は単独で)" + ixName _ = Left "添字は変数名でなければなりません" + codingOf [] = Right Treatment + codingOf (Ref c : _) = parseContrast c + codingOf _ = Left "C(g, coding) の coding は名前でなければなりません" + isFactor x = case lookup x (mfRoles mf) of + Just (RoleFactor _ _) -> True + _ -> False + +-- ============================================================================ +-- データ式の評価 (パラメータが内側に出たら非線形) +-- ============================================================================ + +evalData :: ModelFrame -> Term -> Either String (V.Vector Double) +evalData mf t = case t of + Lit d -> Right (V.replicate n d) + Ref x -> case lookup x (mfRoles mf) of + Just (RoleContinuous v) -> Right v + Just (RoleResponse _) -> Left $ "応答 '" <> T.unpack x <> "' をデータ式に使えません" + Just (RoleFactor _ _) -> Left $ "factor '" <> T.unpack x + <> "' は ! で添字してください" + Nothing + | x `elem` mfParams mf -> Left $ "非線形: パラメータ '" <> T.unpack x + <> "' がデータ式の内側に現れます (線形モデルでありません)" + | otherwise -> Left $ "未知の変数 '" <> T.unpack x <> "'" + Neg a -> V.map negate <$> evalData mf a + App f [a] + | Just fn <- lookup f unaryFns -> V.map fn <$> evalData mf a + App f _ -> Left $ "未対応の関数 '" <> T.unpack f + <> "' (A17 は log/exp/sqrt/sin/cos/tan/abs の単項のみ)" + Bin op a b -> V.zipWith (binFn op) <$> evalData mf a <*> evalData mf b + Index _ _ -> Left "添字項はデータ式に直接置けません (係数として扱われます)" + where n = mfNRows mf + +unaryFns :: [(Text, Double -> Double)] +unaryFns = + [ ("log", log), ("exp", exp), ("sqrt", sqrt) + , ("sin", sin), ("cos", cos), ("tan", tan), ("abs", abs) ] + +binFn :: BinOp -> (Double -> Double -> Double) +binFn Add = (+) +binFn Sub = (-) +binFn Mul = (*) +binFn Div = (/) +binFn Pow = (**) + +-- ============================================================================ +-- 加法項 → 設計列 +-- ============================================================================ + +-- | [日本語]: 切片項か (data も factor も無く param のみ → 1 の列)。 +-- [English]: Whether this is an intercept term (no data or factor, only a +-- param → a column of 1s). +isInterceptTerm :: ModelFrame -> Term -> Bool +isInterceptTerm mf term = + case mapM (classify mf) (mulLeaves term) of + Right leaves -> not (null leaves) + && all isParam leaves + _ -> False + where isParam (LParam _) = True + isParam _ = False + +-- | [日本語]: 加法項 1 つの設計列群 (列ラベル, 列ベクトル)。 +-- [English]: The design columns for a single additive term (column label, +-- column vector). +termColumns :: Bool -> ModelFrame -> Term -> Either String [(Text, V.Vector Double)] +termColumns hasInt mf term = do + leaves <- mapM (classify mf) (mulLeaves term) + let factorNames = concat [ fs | LFactor fs <- leaves ] + dataLeaves = [ d | LData d <- leaves ] + basisLeaves = [ (f, a) | LBasis f a <- leaves ] + case basisLeaves of + [(f, a)] + | null factorNames && null dataLeaves -> basisColumns hasInt mf f a + | otherwise -> Left "基底項は単独で記述してください (factor/データ式との積は未対応)" + (_ : _ : _) -> Left "1 項に複数の基底は未対応" + [] -> do + dataVec <- case dataLeaves of + [] -> Right (V.replicate (mfNRows mf) 1) + ts -> foldr1 (V.zipWith (*)) <$> mapM (evalData mf) ts + let dataLabel | null dataLeaves = Nothing + | otherwise = Just (T.intercalate "*" (map prettyTerm dataLeaves)) + case factorNames of + [] -> Right [ (prettyTerm term, dataVec) ] + fs -> factorColumns hasInt mf fs dataVec dataLabel + +-- | [日本語]: 基底展開列。 +-- - @poly(x,n)@ = x¹..xⁿ (n 列・定数なし。 切片は b0 が担う → polyDesignMatrix と同 span)。 +-- - @bspline(x,n)@ = degree-3 clamped B-spline、 knots = quantileKnots n x +-- (= fitSpline (BSpline 3) (quantileKnots n x) と同一基底)。 既定 degree=3、 +-- @bspline(x,n,k)@ で degree 指定可。 B-spline 基底は partition of unity ゆえ切片と +-- 共線 → 切片併用時 (hasInt) は先頭基底列を drop して満ランク化 (R splines::bs 既定と同様)。 +-- [English]: Basis-expansion columns. +-- - @poly(x,n)@ = x¹..xⁿ (n columns, no constant; the intercept is carried +-- by b0, so this has the same span as polyDesignMatrix). +-- - @bspline(x,n)@ = a degree-3 clamped B-spline with knots = +-- quantileKnots n x (the same basis as +-- fitSpline (BSpline 3) (quantileKnots n x)). Default degree=3; +-- @bspline(x,n,k)@ lets you specify the degree. Because the B-spline +-- basis is a partition of unity, it is collinear with the intercept, so +-- when an intercept is present (hasInt) the first basis column is +-- dropped to obtain full rank (as with R's splines::bs default). +basisColumns :: Bool -> ModelFrame -> Text -> [Term] + -> Either String [(Text, V.Vector Double)] +basisColumns hasInt mf fname args = case (fname, args) of + ("poly", [xe, Lit nd]) -> do + xv <- evalData mf xe + let deg = round nd :: Int + pure [ (lbl xe ("^" <> tshow j), V.map (^ j) xv) | j <- [1 .. deg] ] + -- opoly(x,n) = 実測値の直交多項式 (R poly 既定・raw=FALSE と同 span)。 + -- Vandermonde [1, x, …, xⁿ] を QR 直交化し、 定数列を落とした 1..n 列を返す。 + -- raw poly と違い列が相互直交 (不等間隔でも linear ⊥ quadratic) ゆえ効果検定が独立。 + -- ŷ は raw poly と同一 (span 不変・parameterization のみ差)。 + ("opoly", [xe, Lit nd]) -> do + xv <- evalData mf xe + let deg = round nd :: Int + xs = V.toList xv + vand = LA.fromLists [ [ x ^ p | p <- [0 .. deg] ] | x <- xs ] + (q, _) = LA.qr vand + qcols = take deg (drop 1 (LA.toColumns q)) -- 定数列を除いた orthogonal 基底 (1..deg) + pure [ (lbl xe ("^" <> tshow j), V.fromList (LA.toList c)) + | (j, c) <- zip [1 :: Int ..] qcols ] + ("bspline", [xe, Lit nk]) -> bspl xe (round nk) 3 + ("bspline", [xe, Lit nk, Lit kk]) -> bspl xe (round nk) (round kk) + _ -> Left $ "基底 '" <> T.unpack fname + <> "' の引数形が不正 (poly(x,n) / bspline(x,n) / bspline(x,n,k))" + where + bspl xe nKnots deg = do + xv <- evalData mf xe + let mat = bsplineBasis deg (quantileKnots nKnots xv) xv + colsAll = map (V.fromList . LA.toList) (LA.toColumns mat) + cols = if hasInt then drop 1 colsAll else colsAll + pure [ (lbl xe ("_" <> tshow j), c) | (j, c) <- zip [(1 :: Int) ..] cols ] + lbl xe suf = fname <> "(" <> prettyTerm xe <> ")" <> suf + tshow = T.pack . show + +-- | [日本語]: factor (1 個=主効果 / 複数=交互作用) を contrast 符号化で展開 (A2 一般化)。 +-- ★各 factor の __contrast 行列 C__ (k×m) で行を符号化する。 交互作用列は factor ごとの +-- contrast 列の __Kronecker 積__ (各行で contrast 値の積) を取り、 data ベクトルを掛ける。 +-- ★符号化の縮約は __指示列のとき (dataLabel == Nothing) のみ__: 指示列は合計が切片 (1s) +-- と共線ゆえ contrast 行列 (k×(k-1)) で 1 列落として満ランク化する。 一方 factor×連続 +-- (dataLabel == Just、 masked データ列) は切片と共線でない → __full coding (k×k 単位行列)__ +-- = 全水準保持で per-level の傾きを持つ (masked 列罠を踏襲。 落とすと参照群の +-- 傾きが 0 固定で自由度を失う = statsmodels の C(g):x と不一致)。 full coding では単位行列 +-- ゆえ contrast の選択は ŷ に影響しない (= parameterization 不変)。 +-- [English]: Expands a factor (one = main effect / multiple = interaction) +-- via contrast coding (A2 generalization). +-- ★Each factor's rows are coded with its __contrast matrix C__ (k×m). +-- Interaction columns are formed by taking the __Kronecker product__ of the +-- per-factor contrast columns (the product of contrast values in each row) +-- and multiplying by the data vector. +-- ★The coding is reduced __only for indicator columns__ (dataLabel == +-- Nothing): indicator columns sum to the intercept (1s) and are +-- collinear with it, so one column is dropped via the (k×(k-1)) contrast +-- matrix to obtain full rank. Factor×continuous (dataLabel == Just, a +-- masked data column), on the other hand, is not collinear with the +-- intercept, so it uses __full coding (a k×k identity matrix)__ — keeping +-- all levels and giving each level its own slope (following the masked +-- column trap: dropping a level would fix the reference group's slope at +-- 0 and lose a degree of freedom, disagreeing with statsmodels' +-- C(g):x). With full coding, the identity matrix means the choice of +-- contrast does not affect ŷ (parameterization-invariant). +factorColumns :: Bool -> ModelFrame -> [(Text, ContrastCoding)] -> V.Vector Double -> Maybe Text + -> Either String [(Text, V.Vector Double)] +factorColumns hasInt mf fcs dataVec dataLabel = do + facs <- mapM getFac fcs + let reduced = hasInt && isNothing dataLabel + facCols = [ factorContrastCols reduced f | f <- facs ] -- factor ごとの [(列ラベル, 行ベクトル)] + combos = cartesian facCols -- 交互作用 = 列の直積 + pure [ mkCol picks | picks <- combos ] + where + getFac (name, coding) = case lookup name (mfRoles mf) of + Just (RoleFactor lev idx) -> Right (name, lev, idx, coding) + _ -> Left $ "factor '" <> T.unpack name <> "' が ModelFrame にありません" + mkCol picks = + let prodVec = foldr1 (V.zipWith (*)) (map snd picks) -- 各 factor の contrast 値の積 + col = V.zipWith (*) prodVec dataVec + lbl = T.intercalate ":" (map fst picks ++ maybe [] (: []) dataLabel) + in (lbl, col) + +-- | [日本語]: 1 factor の contrast 列群。 reduced=True で contrast 行列 (k×(k-1))、 False で +-- full coding (k×k 単位行列 = 指示変数)。 各列は行ごとの contrast 値ベクトル。 +-- [English]: The contrast columns for a single factor. When reduced=True, +-- the (k×(k-1)) contrast matrix is used; when False, full coding (a k×k +-- identity matrix, i.e. indicator variables) is used. Each column is a +-- per-row contrast value vector. +factorContrastCols :: Bool -> (Text, [Text], V.Vector Int, ContrastCoding) + -> [(Text, V.Vector Double)] +factorContrastCols reduced (nm, lev, idx, coding) = + let k = length lev + cmat = if reduced then contrastMatrix coding k else LA.ident k + m = LA.cols cmat + colVec j = V.map (\l -> cmat `LA.atIndex` (l, j)) idx + lbl j + | not reduced = nm <> "=" <> (lev !! j) -- full = 水準名 (指示) + | coding == Treatment = nm <> "=" <> (lev !! (j + 1)) -- 参照 (水準0) を除く + | otherwise = nm <> "[" <> codingTag coding <> "." <> tshow j <> "]" + in [ (lbl j, colVec j) | j <- [0 .. m - 1] ] + where tshow = T.pack . show + +cartesian :: [[a]] -> [[a]] +cartesian [] = [[]] +cartesian (xs:rest) = [ x : r | x <- xs, r <- cartesian rest ] + +-- ============================================================================ +-- Contrast coding (A2) +-- ============================================================================ + +-- | [日本語]: factor 符号化方式。 切片併用時に満ランク化する contrast。 +-- [English]: Factor coding scheme. A contrast that yields full rank when +-- used with an intercept. +data ContrastCoding + = Treatment + -- ^ [日本語]: 参照水準 (昇順先頭) を 0 に、 他を指示 (既定・R 既定 contr.treatment)。 + -- [English]: Sets the reference level (first in ascending order) to + -- 0 and indicates the others (default; R's default contr.treatment). + | Sum + -- ^ [日本語]: sum-to-zero (最終水準 = −Σ others、 R contr.sum)。 + -- [English]: Sum-to-zero coding (last level = −Σ others; R's + -- contr.sum). + | Helmert + -- ^ [日本語]: 各水準 vs それ以前の平均 (R contr.helmert)。 + -- [English]: Each level vs. the mean of the preceding levels (R's + -- contr.helmert). + | Polynomial + -- ^ [日本語]: ordered factor 用の直交多項式 (R contr.poly)。 + -- [English]: Orthogonal polynomials for ordered factors (R's + -- contr.poly). + | CustomContrast (LA.Matrix Double) + -- ^ [日本語]: ユーザ指定の k×(k-1) contrast 行列。 + -- [English]: A user-specified k×(k-1) contrast matrix. + deriving (Eq, Show) + +-- | [日本語]: contrast 名 (C(g, name) の name) を解釈。 +-- [English]: Parses a contrast name (the name in C(g, name)). +parseContrast :: Text -> Either String ContrastCoding +parseContrast t = case T.toLower t of + "treatment" -> Right Treatment + "sum" -> Right Sum + "helmert" -> Right Helmert + "poly" -> Right Polynomial + "polynomial" -> Right Polynomial + _ -> Left $ "未知の contrast '" <> T.unpack t + <> "' (Treatment/Sum/Helmert/Polynomial)" + +-- | [日本語]: 列ラベル用の短いタグ。 +-- [English]: A short tag for use in column labels. +codingTag :: ContrastCoding -> Text +codingTag Treatment = "T" +codingTag Sum = "S" +codingTag Helmert = "H" +codingTag Polynomial = "P" +codingTag (CustomContrast _) = "C" + +-- | [日本語]: k 水準の contrast 行列 (k×(k-1))。 切片併用時の満ランク符号化。 +-- 行 = 水準 (昇順 index)、 列 = contrast。 行 l の値が水準 l の設計行寄与。 +-- [English]: The (k×(k-1)) contrast matrix for k levels. Full-rank coding +-- for use with an intercept. Rows = levels (ascending index), columns = +-- contrasts. Row l's values are level l's design-row contribution. +contrastMatrix :: ContrastCoding -> Int -> LA.Matrix Double +contrastMatrix coding k = case coding of + Treatment -> + LA.fromLists [ [ if l == j + 1 then 1 else 0 | j <- [0 .. k - 2] ] | l <- [0 .. k - 1] ] + Sum -> + LA.fromLists [ sumRow l | l <- [0 .. k - 1] ] + Helmert -> + LA.fromLists [ [ helmert l j | j <- [0 .. k - 2] ] | l <- [0 .. k - 1] ] + Polynomial -> polyContrast k + CustomContrast m -> m + where + sumRow l | l == k - 1 = replicate (k - 1) (-1) + | otherwise = [ if l == j then 1 else 0 | j <- [0 .. k - 2] ] + helmert l j | l <= j = -1 + | l == j + 1 = fromIntegral (j + 1) + | otherwise = 0 + +-- | [日本語]: 直交多項式 contrast (k×(k-1))。 中心化水準スコアの Vandermonde を QR 分解し +-- 定数列を落とした直交基底 (R contr.poly と同 span。 符号差は ŷ 不変ゆえ無害)。 +-- [English]: Orthogonal polynomial contrast (k×(k-1)). QR-decomposes the +-- Vandermonde matrix of centered level scores and drops the constant +-- column to obtain an orthogonal basis (the same span as R's contr.poly; +-- sign differences are harmless since ŷ is invariant). +polyContrast :: Int -> LA.Matrix Double +polyContrast k = + let xs = map fromIntegral [1 .. k] :: [Double] + xbar = sum xs / fromIntegral k + vand = LA.fromLists [ [ (x - xbar) ^ p | p <- [0 .. k - 1] ] | x <- xs ] + (q, _) = LA.qr vand + in LA.fromColumns (drop 1 (LA.toColumns q)) + +-- ============================================================================ +-- designMatrixF / fitLMF / linearityCheck +-- ============================================================================ + +-- | [日本語]: 'Formula' + 'ModelFrame' → 設計行列 (n×p) と列ラベル。 非線形なら Left。 +-- [English]: 'Formula' + 'ModelFrame' → the (n×p) design matrix and column +-- labels. Returns Left if nonlinear. +designMatrixF :: Formula -> ModelFrame -> Either String (LA.Matrix Double, [Text]) +designMatrixF (Formula _ _ rhs) mf = do + let terms = flattenAdd rhs + hasInt = any (isInterceptTerm mf) terms + colss <- mapM (termColumns hasInt mf) terms + let cols = concat colss + labels = map fst cols + if null cols + then Left "空のモデル (設計列がありません)" + else Right ( LA.fromColumns (map (LA.fromList . V.toList . snd) cols) + , labels ) + +-- | [日本語]: 線形モデルを OLS で fit。 設計列ラベルも返す。 非線形なら Left。 +-- [English]: Fits a linear model with OLS. Also returns the design column +-- labels. Returns Left if nonlinear. +fitLMF :: Formula -> DX.DataFrame -> Either String (FitResult, [Text]) +fitLMF f df = do + mf <- modelFrame f df + (x, labels) <- designMatrixF f mf + yv <- responseVec mf + let y = LA.asColumn (LA.fromList (V.toList yv)) + Right (fitLM x y, labels) + +-- | [日本語]: 応答ベクトル取り出し。 +-- [English]: Extracts the response vector. +responseVec :: ModelFrame -> Either String (V.Vector Double) +responseVec mf = case mfRoles mf of + ((_, RoleResponse v) : _) -> Right v + _ -> Left "ModelFrame に応答列がありません" + +-- ============================================================================ +-- weights / offset = WLS (A3) +-- ============================================================================ + +-- | [日本語]: 重み付き最小二乗 + offset の設定。 statsmodels @smf.wls(formula, data, weights=…)@ +-- に倣い、 weights/offset は __列名で渡す__ (R でも weights は formula 外)。 +-- [English]: Configuration for weighted least squares + offset. Following +-- statsmodels' @smf.wls(formula, data, weights=…)@, weights/offset are +-- __passed by column name__ (in R too, weights are outside the formula). +data WLSConfig = WLSConfig + { wcWeights :: Maybe Text + -- ^ [日本語]: 重み列名 (WLS。 'Nothing' = 等重み OLS)。 + -- [English]: The weight column name (for WLS; 'Nothing' = equal-weight + -- OLS). + , wcOffset :: Maybe Text + -- ^ [日本語]: offset 列名 (η への固定加算。 線形では @y* = y − offset@ を fit)。 + -- [English]: The offset column name (a fixed addition to η; for + -- linear models this fits @y* = y − offset@). + } + deriving (Eq, Show) + +-- | [日本語]: 既定 (重みなし・offset なし = OLS、 'fitLMF' と等価)。 +-- [English]: The default (no weights, no offset = OLS; equivalent to +-- 'fitLMF'). +defaultWLS :: WLSConfig +defaultWLS = WLSConfig Nothing Nothing + +-- | [日本語]: weights / offset 付きで線形モデルを fit。 +-- +-- ★行整列: 'modelFrame' は欠損 policy で行を落とし得るので、 weights/offset 列が frame と +-- ずれないよう __formula 関与列 ∪ weights ∪ offset をまとめて 'dropMissingRows'__ してから +-- frame を組み、 weights/offset も同じ DataFrame から取り出す。 +-- ★WLS = @√w@ で X/y を行スケール (@X' = diag(√w) X@, @y' = √w ⊙ y@) し OLS に帰着。 +-- ★offset = η への固定加算ゆえ線形では @y − offset@ を解けばよい (GLM offset は別経路・未対応)。 +-- [English]: Fits a linear model with weights \/ offset. +-- +-- ★Row alignment: because 'modelFrame' can drop rows under the missing +-- policy, so the weights\/offset columns stay aligned with the frame, +-- we first call __'dropMissingRows' on the column union__ (the formula's +-- columns ∪ weights ∪ offset) before building the frame, and take +-- weights\/offset from the same DataFrame. +-- ★WLS reduces to OLS by row-scaling X\/y with @√w@ (@X' = diag(√w) X@, +-- @y' = √w ⊙ y@). +-- ★Since offset is a fixed addition to η, for linear models it suffices +-- to solve @y − offset@ (GLM offset takes a different path and is not +-- supported). +fitWLSF :: WLSConfig -> Formula -> DX.DataFrame -> Either String (FitResult, [Text]) +fitWLSF cfg f@(Formula resp dvars _) df0 = do + let extra = catMaybes [wcWeights cfg, wcOffset cfg] + df = dropMissingRows (resp : dvars ++ extra) df0 -- 整列のため一括 drop + mf <- modelFrame f df + (x, labels) <- designMatrixF f mf + yv0 <- responseVec mf + yv <- case wcOffset cfg of + Nothing -> Right yv0 + Just oc -> do ov <- col df oc; Right (V.zipWith (-) yv0 ov) + case wcWeights cfg of + Nothing -> Right (fitLM x (asCol yv), labels) + Just wc -> do + wv <- col df wc + let swv = LA.fromList (map sqrt (V.toList wv)) -- √w + xw = LA.fromColumns [ swv * c | c <- LA.toColumns x ] -- diag(√w) X + yw = swv * LA.fromList (V.toList yv) -- √w ⊙ y + Right (fitLM xw (LA.asColumn yw), labels) + where + col d name = maybe (Left $ "WLS 列 '" <> T.unpack name <> "' が数値列として見つかりません") + Right (getDoubleVec name d) + asCol v = LA.asColumn (LA.fromList (V.toList v)) + +-- | [日本語]: 線形性チェック (designMatrixF が通れば線形)。 メッセージ付き Either。 +-- [English]: Checks linearity (linear if designMatrixF succeeds). An +-- Either with a message. +linearityCheck :: Formula -> DX.DataFrame -> Either String () +linearityCheck f df = do + mf <- modelFrame f df + _ <- designMatrixF f mf + Right () diff --git a/src/Hanalyze/Model/Formula/Frame.hs b/src/Hanalyze/Model/Formula/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Formula/Frame.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Hanalyze.Model.Formula.Frame +-- Description : Formula DSL の ModelFrame (変数役割割り当て + パラメータ分離) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Formula DSL — ModelFrame (A16)。 'Formula' AST + @DataFrame@ を突合し、 +-- 各名前に役割 (応答 / 連続データ変数 / factor) を割り当て、 推定パラメータを分離する。 +-- +-- ★設計の要点 (実測で確定): 「factor かどうか」 は __formula 内の使われ方__ で決まる +-- (列の型ではない)。 すなわち @bg ! group@ のように Index の右オペランドに現れた +-- データ変数を factor とみなす (numeric コードの factor も拾える)。 算術中にのみ現れる +-- データ変数は連続。 左辺で宣言されていない右辺の自由名 = 推定パラメータ。 +-- +-- 基底展開 (@bs ! bspline(x,k)@) の設計行列化や係数ベクトル長の確定は A17 +-- (@designMatrixF@) に委ねる。 本モジュールは「役割の割り当てとパラメータ抽出」 まで。 +-- DataFrame 依存ゆえ Formula.hs (純 AST) とは分離 (portable 区分は維持)。 +-- +-- [English]: Formula DSL — ModelFrame (A16). Matches the 'Formula' AST +-- against a @DataFrame@, assigns each name a role (response \/ continuous +-- data variable \/ factor), and separates out the parameters to be +-- estimated. +-- +-- ★Key design point (confirmed empirically): whether something is a factor +-- is determined by __how it is used inside the formula__ (not by the +-- column's type). Namely, a data variable that appears as the right +-- operand of an Index, such as @bg ! group@, is treated as a factor (this +-- also catches factors coded as numerics). A data variable that appears +-- only inside arithmetic is continuous. Free names on the right-hand side +-- that are not declared on the left-hand side are the parameters to be +-- estimated. +-- +-- Building the design matrix for basis expansions (@bs ! bspline(x,k)@) +-- and fixing the coefficient vector length is left to A17 +-- (@designMatrixF@). This module only goes as far as "role assignment and +-- parameter extraction." Because it depends on DataFrame, it is kept +-- separate from Formula.hs (the pure AST) (the portable\/non-portable +-- split is preserved). +module Hanalyze.Model.Formula.Frame + ( VarRole (..) + , ModelFrame (..) + , MissingPolicy (..) + , ImputeKind (..) + , modelFrame + , modelFrameWith + -- * 内部 (テスト用に公開) + , refNames + , indexedVars + ) where + +import Control.Applicative ((<|>)) +import Data.List (foldl', nub, sort) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified DataFrame.Internal.DataFrame as DX + +import Hanalyze.DataIO.Convert (getDoubleVec, getTextVec) +import Hanalyze.DataIO.Preprocess (Value (..), countMissing, deriveText, + dropMissingRows, imputeMean, + imputeMedian, isNAString) +import Hanalyze.Model.Formula (Formula (..), Term (..)) + +-- ============================================================================ +-- 役割付き列と ModelFrame +-- ============================================================================ + +-- | [日本語]: データ変数 (応答含む) の役割。 +-- [English]: The role of a data variable (including the response). +data VarRole + = RoleResponse (V.Vector Double) -- ^ [日本語]: 応答 y (数値)。 [English]: Response y (numeric). + | RoleContinuous (V.Vector Double) -- ^ [日本語]: 連続説明変数 (数値)。 [English]: Continuous predictor (numeric). + | RoleFactor [Text] (V.Vector Int) -- ^ [日本語]: factor: 水準ラベル (昇順) + 行ごとの水準 index。 [English]: Factor: level labels (ascending) plus a per-row level index. + deriving (Eq, Show) + +-- | [日本語]: AST + data を突合した結果。 +-- [English]: The result of matching the AST against the data. +data ModelFrame = ModelFrame + { mfRoles :: [(Text, VarRole)] -- ^ [日本語]: 応答 + データ変数 → 役割 (応答が先頭、 以降は宣言順)。 [English]: Response + data variables → roles (response first, then declaration order). + , mfParams :: [Text] -- ^ [日本語]: 推定パラメータ (右辺自由名 − データ変数、 出現順)。 [English]: Parameters to estimate (right-hand-side free names minus data variables, in order of appearance). + , mfNRows :: Int -- ^ [日本語]: 行数 (応答列の長さ)。 [English]: Row count (the response column's length). + } + deriving (Eq, Show) + +-- | [日本語]: 欠損値の扱い方。 NA 検出・除去・補完は ModelFrame の __単一責務点__ (spec §2.2)。 +-- policy で整形した DataFrame を 'buildFrame' に通すことで、 各 fit 関数に +-- NA 検出を散らさず一元化する。 +-- [English]: How missing values are handled. NA detection\/removal\/imputation +-- is ModelFrame's __single point of responsibility__ (spec §2.2). Feeding +-- the DataFrame shaped by the policy into 'buildFrame' centralizes NA +-- detection instead of scattering it across each fit function. +data MissingPolicy + = DropRows -- ^ [日本語]: NA を含む行を全関与列から除外 (listwise deletion、 既定・後方互換)。 [English]: Excludes rows containing NA across all involved columns (listwise deletion; default, for backward compatibility). + | Pairwise -- ^ [日本語]: 線形 OLS では設計行列が成立しないので DropRows に縮退する + -- (相関等の別用途のために policy 値としては保持。 @fitLMF@ 等は警告)。 + -- [English]: For linear OLS the design matrix cannot be formed, so this + -- degrades to DropRows (kept as a policy value for other uses such as + -- correlation; @fitLMF@ etc. warn). + | Impute ImputeKind -- ^ [日本語]: 連続説明変数を平均/中央値で補完。 応答・factor の NA は + -- 別 policy 併用が要る (Impute では埋めない)。 + -- [English]: Imputes continuous predictors with the mean\/median. NA in + -- the response\/factors needs a combined additional policy (Impute does + -- not fill them). + | TreatAsCategory -- ^ [日本語]: factor 列の NA を独立水準 @""@ として扱う。 [English]: Treats NA in factor columns as its own level, @""@. + | ErrorOnMissing -- ^ [日本語]: 関与列に NA があれば 'Left' (列名 + 件数つき)。 [English]: 'Left' (with column name and count) if any involved column has NA. + deriving (Eq, Show) + +-- | [日本語]: 'Impute' の補完方式。 +-- [English]: The imputation method for 'Impute'. +data ImputeKind = ImputeMean | ImputeMedian + deriving (Eq, Show) + +-- ============================================================================ +-- 解析ヘルパ (AST 走査) +-- ============================================================================ + +-- | [日本語]: 右辺に現れる全 Ref 名 (出現順、 重複あり)。 +-- contrast 注釈 @C(g, Sum)@ は __factor 名 g のみ__ を拾う (coding 名 "Sum" は +-- 推定パラメータでもデータ変数でもないので除外)。 +-- [English]: All Ref names appearing on the right-hand side (in order of +-- appearance, with duplicates). For a contrast annotation @C(g, Sum)@, +-- only the __factor name g__ is picked up (the coding name "Sum" is +-- excluded since it is neither a parameter to estimate nor a data +-- variable). +refNames :: Term -> [Text] +refNames t = case t of + Ref x -> [x] + Lit _ -> [] + App "C" (Ref x : _) -> [x] -- contrast 注釈: factor 名のみ + App _ as -> concatMap refNames as -- 関数名 (App の Text) はパラメータでない + Index a b -> refNames a ++ refNames b + Neg a -> refNames a + Bin _ a b -> refNames a ++ refNames b + +-- | [日本語]: Index の右オペランドに factor として現れた名前 (= factor 候補)。 +-- 右が @Ref g@ (無注釈 = treatment) または @C(g, coding)@ (contrast 注釈) なら g を拾う。 +-- 右が基底展開 App (bspline / poly 等) の場合は factor でない (A17 が扱う) ので拾わない。 +-- [English]: Names appearing as factors in the right operand of an Index +-- (= factor candidates). If the right side is @Ref g@ (unannotated = +-- treatment) or @C(g, coding)@ (contrast annotation), g is picked up. If +-- the right side is a basis-expansion App (bspline \/ poly etc.), it is +-- not a factor (handled by A17) so it is not picked up. +indexedVars :: Term -> [Text] +indexedVars = nub . go + where + go t = case t of + Index a b -> rightRef b ++ go a ++ go b + App _ as -> concatMap go as + Neg a -> go a + Bin _ a b -> go a ++ go b + _ -> [] + rightRef (Ref x) = [x] + rightRef (App "C" (Ref x : _)) = [x] -- C(g, coding) → factor g + rightRef _ = [] + +-- ============================================================================ +-- modelFrame +-- ============================================================================ + +-- | [日本語]: 既定 policy ('DropRows') で 'ModelFrame' を構築する (後方互換: NA 無しデータでは不変)。 +-- [English]: Builds a 'ModelFrame' with the default policy ('DropRows') +-- (backward compatible: unchanged for data with no NA). +modelFrame :: Formula -> DX.DataFrame -> Either String ModelFrame +modelFrame = modelFrameWith DropRows + +-- | [日本語]: 欠損 'MissingPolicy' を指定して 'ModelFrame' を構築する。 +-- policy で整形した DataFrame を 'buildFrame' に通す (NA 検出・除去・補完を一元化)。 +-- [English]: Builds a 'ModelFrame' with a given 'MissingPolicy' for +-- missing values. The DataFrame shaped by the policy is fed into +-- 'buildFrame' (centralizing NA detection\/removal\/imputation). +modelFrameWith :: MissingPolicy -> Formula -> DX.DataFrame -> Either String ModelFrame +modelFrameWith policy fml@(Formula resp dvars rhs) df = do + let involved = resp : dvars + factors = filter (`elem` dvars) (indexedVars rhs) + conts = filter (`notElem` factors) dvars -- 連続説明変数 (factor 以外) + naOf d c = maybe 0 id (lookup c (countMissing d)) -- 列 c の NA 件数 + df' <- case policy of + DropRows -> Right (dropMissingRows involved df) + Pairwise -> Right (dropMissingRows involved df) -- 単一 frame では DropRows と同義 + ErrorOnMissing -> + let bad = [ (T.unpack c, naOf df c) | c <- involved, naOf df c > 0 ] + in if null bad then Right df + else Left $ "ErrorOnMissing: 欠損のある関与列 " <> show bad + Impute kind -> do + df1 <- imputeCols kind conts df + let stillBad = [ T.unpack c | c <- resp : factors, naOf df1 c > 0 ] + if null stillBad then Right df1 + else Left $ "Impute は連続説明変数のみ補完します。 応答/factor の欠損 " + <> show stillBad <> " は DropRows か TreatAsCategory を併用してください" + TreatAsCategory -> + let df1 = foldl' (flip naToCategory) df factors + stillBad = [ T.unpack c | c <- resp : conts, naOf df1 c > 0 ] + in if null stillBad then Right df1 + else Left $ "TreatAsCategory は factor 列のみ扱います。 応答/連続の欠損 " + <> show stillBad <> " は DropRows か Impute を併用してください" + buildFrame fml df' + +-- | [日本語]: 連続列群を平均/中央値で補完。 数値列でなければ 'Left'。 +-- [English]: Imputes a set of continuous columns with the mean\/median. +-- 'Left' if a column is not numeric. +imputeCols :: ImputeKind -> [Text] -> DX.DataFrame -> Either String DX.DataFrame +imputeCols kind = go + where + impute1 c = case kind of { ImputeMean -> imputeMean c; ImputeMedian -> imputeMedian c } + go [] d = Right d + go (c:cs) d = case impute1 c d of + Just d' -> go cs d' + Nothing -> Left $ "連続変数 '" <> T.unpack c <> "' を数値列として補完できません" + +-- | [日本語]: factor 列の NA を独立水準 @""@ に置換した Text 列で上書きする。 +-- 非 NA 値は 'showNum' で文字列化 ('columnAsText' の数値→文字列と同形)。 +-- [English]: Overwrites a factor column with a Text column where NA has +-- been replaced by its own level, @""@. Non-NA values are stringified +-- with 'showNum' (the same form as the numeric-to-string conversion in +-- 'columnAsText'). +naToCategory :: Text -> DX.DataFrame -> DX.DataFrame +naToCategory c = deriveText c toLbl + where + toLbl row = case Map.lookup c row of + Just (VText t) | not (isNAString t) -> t + Just (VNum d) -> T.pack (showNum d) + _ -> "" + +-- | [日本語]: 'Formula' と (policy 適用済) @DataFrame@ を突合して 'ModelFrame' を構築する。 +-- [English]: Matches a 'Formula' against a (policy-applied) @DataFrame@ to +-- build a 'ModelFrame'. +buildFrame :: Formula -> DX.DataFrame -> Either String ModelFrame +buildFrame (Formula resp dvars rhs) df = do + -- 応答列 (数値必須) + yv <- maybe (Left $ "応答変数 '" <> T.unpack resp <> "' が数値列として見つかりません") + Right (getDoubleVec resp df) + let n = V.length yv + indexed = filter (`elem` dvars) (indexedVars rhs) + -- R 意味論 (A17b): @!@ 添字が無くても **非数値 (Text) 列は factor** として扱う + -- (character→factor 自動判定)。 数値列は連続のまま (numeric-coded factor は従来どおり + -- @!@ 添字必須) なので、 従来 error だった「Text 列を裸で置いた」場合だけが factor 化する。 + autoFac = [ v | v <- dvars, v `notElem` indexed, nonNumericText v ] + factors = indexed ++ autoFac + params = refNames rhs `minus` (resp : dvars) + nonNumericText v = case getDoubleVec v df of + Just _ -> False + Nothing -> case getTextVec v df of + Just _ -> True + Nothing -> False + -- 各データ変数の役割を解決 + varRoles <- mapM (resolveVar factors df) dvars + pure ModelFrame + { mfRoles = (resp, RoleResponse yv) : zip dvars varRoles + , mfParams = params + , mfNRows = n + } + +-- | [日本語]: データ変数 1 つを役割に解決する。 factors に含まれれば factor、 さもなくば連続。 +-- [English]: Resolves a single data variable to its role. Factor if it is +-- in factors, otherwise continuous. +resolveVar :: [Text] -> DX.DataFrame -> Text -> Either String VarRole +resolveVar factors df name + | name `elem` factors = factorRole name df + | otherwise = + maybe (Left $ "連続変数 '" <> T.unpack name <> "' が数値列として見つかりません") + (Right . RoleContinuous) (getDoubleVec name df) + +-- | [日本語]: factor 列を水準ラベル (昇順) + 行ごとの水準 index に。 +-- text 列を優先、 無ければ数値列を文字列化 (numeric コードの factor)。 +-- [English]: Turns a factor column into level labels (ascending) plus a +-- per-row level index. Prefers a text column; if absent, stringifies a +-- numeric column (factors coded as numerics). +factorRole :: Text -> DX.DataFrame -> Either String VarRole +factorRole name df = + case columnAsText name df of + Nothing -> Left $ "factor 変数 '" <> T.unpack name <> "' が列として見つかりません" + Just col -> + let levels = sort (nub (V.toList col)) -- 昇順 = treatment contrast の参照=第1水準 + idxOf v = length (takeWhile (/= v) levels) -- levels 内の位置 + idx = V.map idxOf col + in Right (RoleFactor levels idx) + +-- | [日本語]: 列を [Text] 表現で取得 (factor 水準列挙用)。 text 列優先、 無ければ数値を文字列化。 +-- [English]: Gets a column as a [Text] representation (for enumerating +-- factor levels). Prefers a text column; if absent, stringifies the +-- numeric values. +columnAsText :: Text -> DX.DataFrame -> Maybe (V.Vector Text) +columnAsText name df = + getTextVec name df + <|> (V.map (T.pack . showNum) <$> getDoubleVec name df) + +-- | [日本語]: 数値を factor 水準ラベル用に文字列化 (整数は小数点なし)。 +-- [English]: Stringifies a number for use as a factor level label +-- (integers have no decimal point). +showNum :: Double -> String +showNum d + | d == fromIntegral i = show i + | otherwise = show d + where i = round d :: Integer + +-- | [日本語]: リスト差 (左の出現順を保ち、 右に含まれる要素を除く)。 +-- [English]: List difference (preserves the left list's order of +-- appearance, removing elements contained in the right list). +minus :: Eq a => [a] -> [a] -> [a] +minus xs ys = foldl' (\acc x -> if x `elem` ys || x `elem` acc then acc else acc ++ [x]) [] xs diff --git a/src/Hanalyze/Model/Formula/Mixed.hs b/src/Hanalyze/Model/Formula/Mixed.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Formula/Mixed.hs @@ -0,0 +1,292 @@ +-- | +-- Module : Hanalyze.Model.Formula.Mixed +-- Description : Formula DSL の混合効果モデル (random effect) 接続層 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Formula DSL — 混合効果モデル (random effect) の接続層。 +-- +-- lme4 流の @(1|g)@ / @(x|g)@ / @(1+x|g)@ を Formula DSL に追加し、 +-- 'Hanalyze.Model.GLMM' の一般ランダム効果フィット ('fitLMEGeneral' / +-- 'fitGLMMGeneral') へ route する。 +-- +-- ★設計判断: random 項を AST の @Term@ 構成子として持たせず、 +-- __字句プリパスで @(…|g)@ ブロックを抽出__ する方式を採る。 理由は +-- @Term@ に構成子を足すと 'Hanalyze.Model.Formula' 系 5 モジュールの網羅 +-- pattern match が全て破壊されるため (計画のリスク注記)。 本方式なら +-- @Term@/'Formula' は不変で、 固定効果は既存の 'parseModel'/'designMatrixF' +-- 経路をそのまま使え、 random 項の解釈は本モジュールに閉じる。 +-- +-- frequentist GLMM ゆえ random 効果に prior 宣言は不要 (分散 G は推定対象)。 +-- +-- [English]: Formula DSL — connection layer for mixed-effects models +-- (random effects). +-- +-- Adds lme4-style @(1|g)@ \/ @(x|g)@ \/ @(1+x|g)@ to the Formula DSL and +-- routes to 'Hanalyze.Model.GLMM''s general random-effects fitters +-- ('fitLMEGeneral' \/ 'fitGLMMGeneral'). +-- +-- ★__Design decision__: rather than giving random terms their own +-- @Term@ constructor, this module __extracts @(…|g)@ blocks in a lexical pre-pass__. +-- The reason: adding a constructor to @Term@ would break the +-- exhaustive pattern matches across the 5 modules of the +-- 'Hanalyze.Model.Formula' family (noted as a risk in the plan). This +-- approach leaves @Term@\/'Formula' unchanged — fixed effects still go +-- through the existing 'parseModel'\/'designMatrixF' path, and random-term +-- interpretation stays contained in this module. +-- +-- Since this is frequentist GLMM, random effects need no prior declaration +-- (the variance G is estimated). +module Hanalyze.Model.Formula.Mixed + ( RandomSpec (..) + , extractRandom + , fitMixedF + , fitMixedLME + , fitMixedGLMM + ) where + +import Control.Monad (unless, when) +import Data.Char (isSpace) +import Data.List (intercalate) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA + +import qualified DataFrame.Internal.DataFrame as DXD +import Hanalyze.DataIO.Convert (getDoubleVec, getTextVec) +import Hanalyze.DataIO.Preprocess (dropMissingRows) +import Hanalyze.Model.Formula (Formula (..)) +import Hanalyze.Model.Formula.Design (designMatrixF, responseVec) +import Hanalyze.Model.Formula.Frame (modelFrame) +import Hanalyze.Model.Formula.RFormula (parseModel) +import Hanalyze.Model.GLM (Family (..), LinkFn (..)) +import Hanalyze.Model.GLMM (GLMMResultRE, buildGroups, + fitGLMMGeneral, fitLMEGeneral) + +-- ============================================================================ +-- random 項の表現 +-- ============================================================================ + +-- | [日本語]: 1 つの @(…|g)@ ブロックの解釈結果。 +-- 例: @(1+x|g)@ → @RandomSpec True ["x"] "g"@ / @(0+x|g)@ → @RandomSpec False ["x"] "g"@. +-- [English]: The parsed result of a single @(…|g)@ block. +-- Example: @(1+x|g)@ → @RandomSpec True ["x"] "g"@ \/ @(0+x|g)@ → @RandomSpec False ["x"] "g"@. +data RandomSpec = RandomSpec + { rsIntercept :: Bool -- ^ [日本語]: random intercept を含むか (@1@ あり or 既定 True、 @0@/@-1@ で抑制)。 [English]: Whether a random intercept is included (present via @1@ or default True; suppressed by @0@\/@-1@). + , rsSlopes :: [Text] -- ^ [日本語]: random slope の変数名 (左辺の @1@/@0@/@-1@ 以外)。 [English]: Random-slope variable names (excluding @1@\/@0@\/@-1@ on the left-hand side). + , rsGroup :: Text -- ^ [日本語]: grouping 変数名 (@|@ の右)。 [English]: Grouping variable name (right of @|@). + } deriving (Eq, Show) + +-- ============================================================================ +-- 字句プリパス: (…|g) ブロックの抽出 +-- ============================================================================ + +-- | [日本語]: formula 文字列から random 項 @(…|g)@ を抽出し、 (固定効果 formula, [RandomSpec]) +-- を返す。 LHS (@~@ or @=@) は保持し、 RHS から random ブロックを取り除く。 +-- +-- - R 構文: @"y ~ x + (1+x|g)"@ → (@"y ~ x"@, [RandomSpec True ["x"] "g"]) +-- - 独自構文: @"y x = b0 + b1*x + (1|g)"@ → (@"y x = b0 + b1*x"@, [RandomSpec True [] "g"]) +-- +-- 固定効果側に項が残らない場合 (例 @"y ~ (1|g)"@) は intercept @"1"@ を補う。 +-- [English]: Extracts random terms @(…|g)@ from a formula string and +-- returns (fixed-effects formula, [RandomSpec]). The LHS (@~@ or @=@) is +-- kept as-is; random blocks are stripped from the RHS. +-- +-- - R syntax: @"y ~ x + (1+x|g)"@ → (@"y ~ x"@, [RandomSpec True ["x"] "g"]) +-- - Custom syntax: @"y x = b0 + b1*x + (1|g)"@ → (@"y x = b0 + b1*x"@, [RandomSpec True [] "g"]) +-- +-- If no terms remain on the fixed-effects side (e.g. @"y ~ (1|g)"@), an +-- intercept @"1"@ is added. +extractRandom :: Text -> Either String (Text, [RandomSpec]) +extractRandom t = + let s = T.unpack t + (lhs, sep, rhs) = splitLHS s + in do + tokens <- pure (splitTopPlus rhs) + (fixedToks, specStrs) <- partitionTokens tokens + specs <- mapM parseBlock specStrs + let fixedRHS = case map trimStr (filter (not . all isSpace) fixedToks) of + [] -> "1" + ts -> intercalate " + " ts + fixedFormula = case sep of + "" -> fixedRHS -- LHS 無し (RHS のみ) + _ -> trimStr lhs ++ " " ++ sep ++ " " ++ fixedRHS + Right (T.pack fixedFormula, specs) + +-- | [日本語]: LHS と RHS を @~@ (R) または @=@ (独自) で分割。 区切りが無ければ ("", "", whole)。 +-- [English]: Splits into LHS and RHS on @~@ (R) or @=@ (custom). If no +-- separator is found, returns ("", "", whole). +splitLHS :: String -> (String, String, String) +splitLHS s + | Just (l, r) <- breakTop '~' s = (l, "~", r) + | Just (l, r) <- breakTop '=' s = (l, "=", r) + | otherwise = ("", "", s) + +-- | [日本語]: top-level (括弧外) の最初の区切り文字で 1 回分割。 +-- [English]: Splits once at the first top-level (outside parentheses) +-- separator character. +breakTop :: Char -> String -> Maybe (String, String) +breakTop target = go (0 :: Int) [] + where + go _ _ [] = Nothing + go d acc (c:cs) + | c == '(' = go (d+1) (c:acc) cs + | c == ')' = go (d-1) (c:acc) cs + | c == target && d == 0 = Just (reverse acc, cs) + | otherwise = go d (c:acc) cs + +-- | [日本語]: top-level の @+@ で分割 (括弧内の @+@ は分割しない)。 +-- [English]: Splits on top-level @+@ (does not split on @+@ inside +-- parentheses). +splitTopPlus :: String -> [String] +splitTopPlus = go (0 :: Int) [] [] + where + go _ cur acc [] = reverse (reverse cur : acc) + go d cur acc (c:cs) + | c == '(' = go (d+1) (c:cur) acc cs + | c == ')' = go (d-1) (c:cur) acc cs + | c == '+' && d == 0 = go d [] (reverse cur : acc) cs + | otherwise = go d (c:cur) acc cs + +-- | [日本語]: 各トークンを固定効果トークンか random ブロック (中身) に振り分ける。 +-- random ブロック = trim 後 @(…)@ で囲まれ、 内部 top-level に @|@ を持つもの。 +-- [English]: Sorts each token into either a fixed-effects token or a +-- random block (its contents). A random block is one that, after +-- trimming, is enclosed in @(…)@ and contains a top-level @|@ inside. +partitionTokens :: [String] -> Either String ([String], [String]) +partitionTokens = go [] [] + where + go fixed rand [] = Right (reverse fixed, reverse rand) + go fixed rand (tok:rest) = + case asRandomBlock (trimStr tok) of + Just inner -> go fixed (inner : rand) rest + Nothing -> go (tok : fixed) rand rest + +-- | [日本語]: トークンが @(…|…)@ なら内部文字列を返す。 +-- [English]: If the token is @(…|…)@, returns the inner string. +asRandomBlock :: String -> Maybe String +asRandomBlock tok = + case tok of + ('(':rest) | not (null rest), last rest == ')' -> + let inner = init rest + in if hasTopPipe inner then Just inner else Nothing + _ -> Nothing + +-- | [日本語]: top-level に @|@ を含むか。 +-- [English]: Whether it contains a top-level @|@. +hasTopPipe :: String -> Bool +hasTopPipe = go (0 :: Int) + where + go _ [] = False + go d (c:cs) + | c == '(' = go (d+1) cs + | c == ')' = go (d-1) cs + | c == '|' && d == 0 = True + | otherwise = go d cs + +-- | [日本語]: @"1 + x | g"@ → 'RandomSpec'。 +-- [English]: @"1 + x | g"@ → 'RandomSpec'. +parseBlock :: String -> Either String RandomSpec +parseBlock inner = + case breakTop '|' inner of + Nothing -> Left "random ブロックに '|' がありません" + Just (lhs, rhs) -> + let grp = trimStr rhs + terms = map trimStr (splitTopPlus lhs) + isSup t = t == "0" || t == "-1" + isOne t = t == "1" + hasSup = any isSup terms + slopes = [ T.pack t | t <- terms, not (isSup t), not (isOne t), not (null t) ] + in if null grp + then Left "random ブロックの grouping 変数 (| の右) が空です" + else Right RandomSpec + { rsIntercept = not hasSup -- 0/-1 が無ければ intercept あり + , rsSlopes = slopes + , rsGroup = T.pack grp + } + +trimStr :: String -> String +trimStr = f . f where f = reverse . dropWhile isSpace + +-- ============================================================================ +-- route 入口: 固定/random を分離し GLMM 一般フィットへ +-- ============================================================================ + +-- | [日本語]: 混合効果モデルを DataFrame からフィットする。 @Nothing@ = Gaussian LME +-- ('fitLMEGeneral')、 @Just (family, link)@ = 非 Gaussian GLMM ('fitGLMMGeneral')。 +-- 戻り値は (結果, 固定効果係数名)。 +-- +-- ★現状は __単一 grouping factor__ のみ対応 ((1|g) / (x|g) / (1+x|g))。 複数の +-- @(…|g1) + (…|g2)@ は block-diagonal Z が要るため未対応 (明示エラー)。 +-- +-- TODO (follow-up): +-- - 複数 grouping factor @(…|g1) + (…|g2)@ — 群ごと Z ブロックを block-diagonal に +-- 積み、 fitLMEGeneral/fitGLMMGeneral を multi-grouping 一般化する。 +-- - GLMM offset (Poisson log-exposure 等) — 現状は線形 offset のみ (@fitWLSF@)。 +-- - REML 推定 — 現状の EM/Laplace は ML。 REML は固定効果 df 補正付き。 +-- [English]: Fits a mixed-effects model from a DataFrame. @Nothing@ = +-- Gaussian LME ('fitLMEGeneral'), @Just (family, link)@ = non-Gaussian GLMM +-- ('fitGLMMGeneral'). Returns (result, fixed-effect coefficient names). +-- +-- ★Currently supports only a __single grouping factor__ ((1|g) \/ (x|g) \/ +-- (1+x|g)). Multiple @(…|g1) + (…|g2)@ is not supported yet, since it +-- would require a block-diagonal Z (raises an explicit error). +-- +-- TODO (follow-up): +-- - Multiple grouping factors @(…|g1) + (…|g2)@ — stack per-group Z +-- blocks block-diagonally and generalize fitLMEGeneral\/fitGLMMGeneral +-- to multi-grouping. +-- - GLMM offset (e.g. Poisson log-exposure) — currently only linear +-- offset is supported (@fitWLSF@). +-- - REML estimation — the current EM\/Laplace is ML. REML would add a +-- fixed-effect df correction. +fitMixedF + :: Maybe (Family, LinkFn) + -> Text -> DXD.DataFrame + -> Either String (GLMMResultRE, [Text]) +fitMixedF mfam formulaText df0 = do + (fixedText, specs) <- extractRandom formulaText + spec <- case specs of + [s] -> Right s + [] -> Left "random effect 項 (…|g) がありません (固定効果のみなら fitLMF を使用)" + _ -> Left "複数の grouping factor は未対応 (単一の (…|g) のみ)" + f@(Formula resp dvars _) <- parseModel fixedText + let slopeVars = rsSlopes spec + grp = rsGroup spec + -- 行整列: fixedWLF と同じく formula 関与列 ∪ slope ∪ group を一括 drop + df = dropMissingRows (resp : dvars ++ slopeVars ++ [grp]) df0 + mf <- modelFrame f df + (x, labels) <- designMatrixF f mf + yv <- responseVec mf + let n = V.length yv + slopeCols <- mapM (\v -> + maybe (Left $ "random slope 列 '" <> T.unpack v <> "' が数値列として見つかりません") + Right (getDoubleVec v df)) slopeVars + let interceptCol = [ V.replicate n 1.0 | rsIntercept spec ] + zCols = interceptCol ++ slopeCols + when (null zCols) $ Left "random effect の設計列が空です ((0|g) のみは不可)" + unless (all ((== n) . V.length) zCols) $ + Left "random slope 列の長さが応答と一致しません" + gv <- maybe (Left $ "grouping 列 '" <> T.unpack grp <> "' が見つかりません") + Right (getTextVec grp df) + let z = LA.fromColumns (map (LA.fromList . V.toList) zCols) + y = LA.fromList (V.toList yv) + (glabels, idx, _sizes) = buildGroups gv + res = case mfam of + Nothing -> fitLMEGeneral x z y idx glabels + Just (fam, link) -> fitGLMMGeneral fam link x z y idx glabels + Right (res, labels) + +-- | [日本語]: Gaussian 線形混合効果モデル (LME)。 @fitMixedLME "y ~ x + (1+x|g)" df@。 +-- [English]: Gaussian linear mixed-effects model (LME). +-- @fitMixedLME "y ~ x + (1+x|g)" df@. +fitMixedLME :: Text -> DXD.DataFrame -> Either String (GLMMResultRE, [Text]) +fitMixedLME = fitMixedF Nothing + +-- | [日本語]: 非 Gaussian GLMM。 @fitMixedGLMM Binomial Logit "y ~ x + (1|g)" df@。 +-- [English]: Non-Gaussian GLMM. +-- @fitMixedGLMM Binomial Logit "y ~ x + (1|g)" df@. +fitMixedGLMM :: Family -> LinkFn -> Text -> DXD.DataFrame + -> Either String (GLMMResultRE, [Text]) +fitMixedGLMM fam link = fitMixedF (Just (fam, link)) diff --git a/src/Hanalyze/Model/Formula/Nonlinear.hs b/src/Hanalyze/Model/Formula/Nonlinear.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Formula/Nonlinear.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Hanalyze.Model.Formula.Nonlinear +-- Description : Formula DSL の非線形最小二乗 (NLS) fit +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Formula DSL — 非線形最小二乗 (NLS)。 +-- 現状 @a*exp(-b*x)@ のように __パラメータがデータ式の内側に現れる式__ (@designMatrixF@ +-- は線形でないとして 'Left') を、 parse 済 AST を評価関数化して既存の最適化器 +-- ('Hanalyze.Optim.NelderMead') で SSR を最小化し fit する。 +-- +-- ★考え方: 線形 OLS と違い param 名が ŷ に効く。 @evalNL@ が「params 表 + ModelFrame」 から +-- 右辺式を __行ごとの ŷ ベクトル__ に評価する (param は定数、 連続データ変数は列ベクトル)。 +-- 目的関数 @SSR(θ) = Σ(y − ŷ(θ))²@ を Nelder-Mead で最小化。 +-- ★初期値はユーザ必須 (NLS は初期値依存)。 factor 添字は非対応 (線形側で扱う)。 +-- ★最適化器は IO を返すが決定論的ゆえ 'unsafePerformIO' で pure 化 (Convert.hs 同方針)。 +-- +-- plot 非依存・portable。 +-- +-- [English]: Formula DSL — nonlinear least squares (NLS). +-- Fits expressions like @a*exp(-b*x)@, where +-- __parameters appear inside the data expression itself__ (so +-- @designMatrixF@ considers them non-linear and returns 'Left'), by +-- turning the parsed AST into an evaluation function and minimizing +-- SSR with the existing optimizer ('Hanalyze.Optim.NelderMead'). +-- +-- ★ Concept: unlike linear OLS, parameter names affect ŷ. @evalNL@ +-- evaluates the right-hand-side expression into a __per-row ŷ vector__ +-- from "the params table + ModelFrame" (params are constants, +-- continuous data variables are column vectors). The objective +-- @SSR(θ) = Σ(y − ŷ(θ))²@ is minimized with Nelder-Mead. +-- ★ Initial values are required from the user (NLS depends on them). +-- Factor indexing is not supported (handled on the linear side). +-- ★ The optimizer returns IO but is deterministic, so it is purified +-- with 'unsafePerformIO' (same policy as Convert.hs). +-- +-- Independent of plot; portable. +module Hanalyze.Model.Formula.Nonlinear + ( NLSResult (..) + , fitNLS + , evalNL + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import System.IO.Unsafe (unsafePerformIO) + +import Hanalyze.Model.Formula (BinOp (..), Formula (..), Term (..)) +import Hanalyze.Model.Formula.Frame +import Hanalyze.Optim.Common (OptimResult (..)) +import Hanalyze.Optim.NelderMead (runNelderMead) +import qualified DataFrame.Internal.DataFrame as DX + +-- | [日本語]: 非線形 fit の結果。 +-- [English]: The result of a nonlinear fit. +data NLSResult = NLSResult + { nlsParams :: [(Text, Double)] -- ^ [日本語]: 推定パラメータ (名前つき) [English]: Estimated parameters (named) + , nlsFitted :: V.Vector Double -- ^ [日本語]: ŷ [English]: ŷ + , nlsResidual :: V.Vector Double -- ^ [日本語]: y − ŷ [English]: y − ŷ + , nlsSSR :: Double -- ^ [日本語]: 残差平方和 [English]: Residual sum of squares + , nlsConverged :: Bool -- ^ [日本語]: 最適化器が許容誤差で停止したか [English]: Whether the optimizer stopped within tolerance + } + deriving (Eq, Show) + +-- | [日本語]: 右辺式を __行ごとの値ベクトル__ に評価する。 params は表から定数、 連続データ変数は +-- ModelFrame の列、 factor / 応答は 'Left'。 (線形の @evalData@ と違い param を許す。) +-- [English]: Evaluates the right-hand-side expression into a +-- __per-row value vector__. Params are constants from the table, +-- continuous data variables are ModelFrame columns, and factor \/ +-- response give 'Left'. +-- (Unlike the linear @evalData@, this allows params.) +evalNL :: [(Text, Double)] -> ModelFrame -> Term -> Either String (V.Vector Double) +evalNL pm mf = go + where + n = mfNRows mf + go t = case t of + Lit d -> Right (V.replicate n d) + Ref x -> case lookup x (mfRoles mf) of + Just (RoleContinuous v) -> Right v + Just (RoleResponse _) -> Left $ "応答 '" <> T.unpack x <> "' をデータ式に使えません" + Just (RoleFactor _ _) -> Left $ "非線形フィットは factor '" <> T.unpack x + <> "' を扱えません" + Nothing -> case lookup x pm of + Just d -> Right (V.replicate n d) + Nothing -> Left $ "未知の変数 '" <> T.unpack x <> "'" + Neg a -> V.map negate <$> go a + App f [a] | Just fn <- lookup f unaryFns -> V.map fn <$> go a + App f _ -> Left $ "未対応の関数 '" <> T.unpack f + <> "' (log/exp/sqrt/sin/cos/tan/abs の単項のみ)" + Bin op a b -> V.zipWith (binFn op) <$> go a <*> go b + Index _ _ -> Left "非線形フィットは factor 添字を扱えません" + +unaryFns :: [(Text, Double -> Double)] +unaryFns = + [ ("log", log), ("exp", exp), ("sqrt", sqrt) + , ("sin", sin), ("cos", cos), ("tan", tan), ("abs", abs) ] + +binFn :: BinOp -> (Double -> Double -> Double) +binFn Add = (+) +binFn Sub = (-) +binFn Mul = (*) +binFn Div = (/) +binFn Pow = (**) + +-- | [日本語]: 非線形最小二乗。 @inits@ = 各パラメータの初期値 (mfParams を網羅する必要がある)。 +-- SSR を Nelder-Mead で最小化する。 不正値 (NaN) を出すパラメータ域は +∞ で罰する。 +-- [English]: Nonlinear least squares. @inits@ is the initial value for +-- each parameter (must cover all of mfParams). Minimizes SSR with +-- Nelder-Mead. Parameter regions producing invalid values (NaN) are +-- penalized with +∞. +fitNLS :: Formula -> DX.DataFrame -> [(Text, Double)] -> Either String NLSResult +fitNLS f@(Formula _ _ rhs) df inits = do + mf <- modelFrame f df + yv <- case mfRoles mf of + ((_, RoleResponse v) : _) -> Right v + _ -> Left "ModelFrame に応答列がありません" + let pnames = map fst inits + missing = filter (`notElem` pnames) (mfParams mf) + if not (null missing) + then Left $ "初期値が無いパラメータ: " <> show (map T.unpack missing) + else do + _ <- evalNL inits mf rhs -- 評価可能性を先に検証 + let sse yhat = V.sum (V.map (\e -> e * e) (V.zipWith (-) yv yhat)) + ssrAt vals = case evalNL (zip pnames vals) mf rhs of + Right yhat -> let s = sse yhat in if isNaN s then 1 / 0 else s + Left _ -> 1 / 0 + res = unsafePerformIO (runNelderMead ssrAt (map snd inits)) + pm = zip pnames (orBest res) + yhat <- evalNL pm mf rhs + let resid = V.zipWith (-) yv yhat + Right NLSResult + { nlsParams = pm + , nlsFitted = yhat + , nlsResidual = resid + , nlsSSR = sse yhat + , nlsConverged = orConverged res + } diff --git a/src/Hanalyze/Model/Formula/RFormula.hs b/src/Hanalyze/Model/Formula/RFormula.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Formula/RFormula.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Hanalyze.Model.Formula.RFormula +-- Description : Formula DSL の R/patsy 互換 front-end (@y ~ x + C(g)@ 構文) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Formula DSL — R/patsy front-end (A18)。 @y ~ x + C(g)@ 形式を +-- __同じ 'Formula' AST__ に落とす (サブ front-end)。 正本は独自構文 (A15)、 +-- 本モジュールは互換・オラクル用途。 +-- +-- ★dispatch: 文字列に @~@ が含まれれば R、 無ければ独自 ('parseModel')。 @~@ と @=@ は +-- 字句的に分離ゆえ曖昧性ゼロ。 +-- +-- ★R formula 意味論 → 我々の AST: +-- - @~@ で 応答 / 予測子 を分離。 予測子は @+@ 区切り (これは「項追加」、 算術でない)。 +-- - 暗黙の切片あり。 @-1@ / @0@ で切片除去。 +-- - 連続変数 @x@ → @b*x@ (本物の積)。 ★categorical は __@C(g)@__ で明示 +-- (patsy 同様。 data 無しで parse するため列型推論はしない)。 +-- - @a:b@ = 交互作用のみ、 @a*b@ = @a + b + a:b@ (crossing)。 +-- - @I(expr)@ = 算術 (@x**2@/@x^2@ 等)、 @log(x)@ = 関数変換、 @poly(x,n)@/@bs(x,n)@ = 基底。 +-- ★パラメータ名は合成 (@_p0,_p1,…@)。 線形 OLS では係数名は fit に無関係ゆえ問題なし。 +-- ★data 変数は RHS に現れた変数名 (合成パラメータ以外) を収集。 +-- +-- plot 非依存・portable (AST のみ依存)。 +-- +-- [English]: Formula DSL — R\/patsy front-end (A18). Compiles the +-- @y ~ x + C(g)@ form down to the __same 'Formula' AST__ (a sub +-- front-end). The canonical syntax is the original one (A15); this module +-- is for compatibility\/oracle use. +-- +-- ★Dispatch: if the string contains @~@, use R; otherwise use the +-- original ('parseModel'). @~@ and @=@ are lexically distinct, so there is +-- zero ambiguity. +-- +-- ★R formula semantics → our AST: +-- - @~@ separates the response \/ predictors. Predictors are @+@ +-- separated (this is "term addition," not arithmetic). +-- - There is an implicit intercept. @-1@ \/ @0@ removes the intercept. +-- - A continuous variable @x@ → @b*x@ (a genuine product). ★categorical +-- is made explicit with __@C(g)@__ (as in patsy; since parsing happens +-- without data, there is no column-type inference). +-- - @a:b@ = interaction only, @a*b@ = @a + b + a:b@ (crossing). +-- - @I(expr)@ = arithmetic (@x**2@\/@x^2@ etc.), @log(x)@ = function +-- transform, @poly(x,n)@\/@bs(x,n)@ = basis. +-- ★Parameter names are synthesized (@_p0,_p1,…@). For linear OLS the +-- coefficient names are irrelevant to the fit, so this is not a problem. +-- ★Data variables are collected from the variable names appearing on the +-- RHS (excluding synthesized parameters). +-- +-- Plot-independent, portable (depends only on the AST). +module Hanalyze.Model.Formula.RFormula + ( parseRFormula + , parseModel + ) where + +import Control.Monad.Combinators.Expr (Operator (..), makeExprParser) +import Data.List (isPrefixOf, nub, subsequences) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char (alphaNumChar, char, letterChar, + space1) +import qualified Text.Megaparsec.Char.Lexer as L + +import Hanalyze.Model.Formula (BinOp (..), Formula (..), + Term (..), parseFormula) + +-- ============================================================================ +-- dispatch +-- ============================================================================ + +-- | [日本語]: front-end 自動判別: @~@ を含めば R、 さもなくば独自構文。 +-- [English]: Automatic front-end detection: R if it contains @~@, +-- otherwise the original syntax. +parseModel :: Text -> Either String Formula +parseModel t + | T.any (== '~') t = parseRFormula t + | otherwise = parseFormula t + +-- ============================================================================ +-- 字句 +-- ============================================================================ + +type P = Parsec Void Text + +sc :: P () +sc = L.space space1 empty empty + +lexeme :: P a -> P a +lexeme = L.lexeme sc + +symbol :: Text -> P Text +symbol = L.symbol sc + +ident :: P Text +ident = lexeme $ do + c <- letterChar <|> char '_' + cs <- many (alphaNumChar <|> char '_' <|> char '.') + pure (T.pack (c : cs)) + +intLit :: P Int +intLit = lexeme (L.signed (pure ()) L.decimal) + +numLit :: P Double +numLit = lexeme (try (L.signed (pure ()) L.float) + <|> (fromIntegral <$> L.signed (pure ()) (L.decimal :: P Integer))) + +parens :: P a -> P a +parens = between (symbol "(") (symbol ")") + +-- ============================================================================ +-- 中間表現 (R 項) +-- ============================================================================ + +-- | [日本語]: R 項の因子。 +-- [English]: A factor within an R term. +data RFactor + = RVar Text -- ^ [日本語]: 連続変数 x。 [English]: Continuous variable x. + | RCat Text (Maybe Text) -- ^ [日本語]: C(g) / C(g, Sum) categorical (+ contrast 名)。 [English]: C(g) \/ C(g, Sum) categorical (with an optional contrast name). + | RFun Text Term -- ^ [日本語]: log(x) 等の関数変換 (1 引数)。 [English]: A function transform such as log(x) (1 argument). + | RI Term -- ^ [日本語]: I(expr) 算術。 [English]: I(expr) arithmetic. + | RPoly Text Int -- ^ [日本語]: poly(x, n) 生べき (x¹..xⁿ)。 [English]: poly(x, n), raw powers (x¹..xⁿ). + | ROPoly Text Int -- ^ [日本語]: opoly(x, n) 実測値の直交多項式 (R poly 既定と同じ)。 [English]: opoly(x, n), orthogonal polynomials on the observed values (same as R's poly default). + | RBs Text Int -- ^ [日本語]: bs(x, n)。 [English]: bs(x, n). + +-- | [日本語]: R 項: 数値 (0/1) か、 因子の積 (hasStar=True なら crossing 展開)。 +-- [English]: An R term: either a number (0\/1) or a product of factors +-- (crossing expansion when hasStar=True). +data RComp = RNum Int | RProd Bool [RFactor] + +-- ============================================================================ +-- パーサ +-- ============================================================================ + +-- | [日本語]: @lhs ~ rhs@。 +-- [English]: @lhs ~ rhs@. +pRFormula :: P Formula +pRFormula = do + sc + lhs <- ident + _ <- symbol "~" + comps <- pRHS + eof + buildFormula lhs comps + +-- | [日本語]: RHS = 符号付き項の並び。 戻り値 = (符号, 項)。 +-- [English]: RHS = a sequence of signed terms. Return value = (sign, term). +pRHS :: P [(Int, RComp)] +pRHS = do + s0 <- option 1 sign + c0 <- pComp + rest <- many ((,) <$> sign <*> pComp) + pure ((s0, c0) : rest) + where sign = (1 <$ symbol "+") <|> ((-1) <$ symbol "-") + +-- | [日本語]: 1 項 (数値 or 因子の積)。 +-- [English]: A single term (a number or a product of factors). +pComp :: P RComp +pComp = + try (RNum <$> lexeme L.decimal) + <|> pProduct + +-- | [日本語]: 因子を @*@ / @:@ で結んだ積。 @*@ が 1 つでもあれば crossing。 +-- [English]: A product of factors joined by @*@ \/ @:@. Crossing if there +-- is at least one @*@. +pProduct :: P RComp +pProduct = do + f0 <- pFactor + rest <- many ((,) <$> ((True <$ symbol "*") <|> (False <$ symbol ":")) <*> pFactor) + let hasStar = any fst rest + facs = f0 : map snd rest + pure (RProd hasStar facs) + +pFactor :: P RFactor +pFactor = + try (symbol "C" *> parens pCatArgs) + <|> try (RI <$> (symbol "I" *> parens pArith)) + <|> try (ROPoly <$> (symbol "opoly" *> symbol "(" *> ident) <*> (symbol "," *> intLit <* symbol ")")) + <|> try (RPoly <$> (symbol "poly" *> symbol "(" *> ident) <*> (symbol "," *> intLit <* symbol ")")) + <|> try (RBs <$> (symbol "bs" *> symbol "(" *> ident) <*> (symbol "," *> intLit <* symbol ")")) + <|> try pFunOrVar + +-- | [日本語]: @C(g)@ / @C(g, Sum)@ の中身: factor 名 + 省略可能な contrast 名。 +-- [English]: The contents of @C(g)@ \/ @C(g, Sum)@: a factor name plus an +-- optional contrast name. +pCatArgs :: P RFactor +pCatArgs = do + g <- ident + mcode <- optional (symbol "," *> ident) + pure (RCat g mcode) + +-- | [日本語]: @log(x)@ のような関数変換、 または裸の変数。 +-- [English]: A function transform like @log(x)@, or a bare variable. +pFunOrVar :: P RFactor +pFunOrVar = do + nm <- ident + margs <- optional (parens pArith) + pure $ case margs of + Just a -> RFun nm a + Nothing -> RVar nm + +-- | [日本語]: I(...) 内の算術式 (@+ - * / ^ **@・関数適用・括弧)。 +-- [English]: The arithmetic expression inside I(...) (@+ - * / ^ **@, +-- function application, parentheses). +pArith :: P Term +pArith = makeExprParser pArithApp + [ [ InfixR (Bin Pow <$ (symbol "**" <|> symbol "^")) ] + , [ Prefix (Neg <$ symbol "-") ] + , [ InfixL (Bin Mul <$ symbol "*"), InfixL (Bin Div <$ symbol "/") ] + , [ InfixL (Bin Add <$ symbol "+"), InfixL (Bin Sub <$ symbol "-") ] + ] + +pArithApp :: P Term +pArithApp = do + h <- pArithAtom + case h of + Ref f -> do + margs <- optional (parens (pArith `sepBy1` symbol ",")) + pure $ maybe h (App f) margs + _ -> pure h + +pArithAtom :: P Term +pArithAtom = + (Lit <$> numLit) + <|> parens pArith + <|> (Ref <$> ident) + +-- ============================================================================ +-- 構築 (中間表現 → Formula AST) +-- ============================================================================ + +buildFormula :: Text -> [(Int, RComp)] -> P Formula +buildFormula lhs comps = do + let removeInt = any (\(s, c) -> case c of + RNum 0 -> s == 1 -- + 0 + RNum 1 -> s == (-1) -- - 1 + _ -> False) comps + prods = [ p | (_, RProd star fs) <- comps, p <- expand star fs ] + terms = (if removeInt then [] else [const1]) ++ map prodToTerm prods + if null terms + then fail "R formula: 項がありません" + else do + let named = zipWith (\i mk -> mk (synth i)) [0 :: Int ..] terms + rhs = foldr1 (Bin Add) named + dvars = nub (filter (not . isSynth) (refNamesT rhs)) + pure (Formula lhs dvars rhs) + where + synth i = T.pack ("_p" ++ show i) + const1 p = Ref p -- 切片 (定数項) + +-- | [日本語]: crossing 展開: @*@ なら全非空部分集合 (R の a*b = a + b + a:b)、 @:@ なら +-- 単一交互作用。 列の順序は fit (ŷ) に無関係ゆえ 'subsequences' の順序で可。 +-- [English]: Crossing expansion: for @*@, all non-empty subsets (R's +-- a*b = a + b + a:b); for @:@, a single interaction. Since column order is +-- irrelevant to the fit (ŷ), the order from 'subsequences' is fine as-is. +expand :: Bool -> [RFactor] -> [[RFactor]] +expand False fs = [fs] +expand True fs = filter (not . null) (subsequences fs) + +-- | [日本語]: 1 つの積 (因子リスト) → パラメータ名を取って Term を作る関数。 +-- [English]: A single product (a list of factors) → a function that takes +-- a parameter name and produces a Term. +prodToTerm :: [RFactor] -> (Text -> Term) +prodToTerm facs p = + let cats = [ (nm, mc) | RCat nm mc <- facs ] + polys = [ (nm, n) | RPoly nm n <- facs ] + opolys = [ (nm, n) | ROPoly nm n <- facs ] + bss = [ (nm, n) | RBs nm n <- facs ] + datums = concatMap factorData facs + in case (polys, opolys, bss) of + ((nm, n) : _, _, _) -> Index (Ref p) (App "poly" [Ref nm, Lit (fromIntegral n)]) + (_, (nm, n) : _, _) -> Index (Ref p) (App "opoly" [Ref nm, Lit (fromIntegral n)]) + (_, _, (nm, n) : _) -> Index (Ref p) (App "bspline" [Ref nm, Lit (fromIntegral n)]) + _ -> + let base = foldl (\acc (nm, mc) -> Index acc (catTerm nm mc)) (Ref p) cats + in case datums of + [] -> base -- 切片 or 純 factor + (d:ds) -> Bin Mul base (foldl (Bin Mul) d ds) + +-- | [日本語]: categorical 添字項を AST に: @C(g)@ → @Ref g@ (無注釈 treatment)、 +-- @C(g, Sum)@ → @App "C" [Ref g, Ref Sum]@ (contrast 注釈・正本 AST と同形)。 +-- [English]: Turns a categorical index term into the AST: @C(g)@ → +-- @Ref g@ (unannotated treatment), @C(g, Sum)@ → +-- @App "C" [Ref g, Ref Sum]@ (contrast annotation, same shape as the +-- canonical AST). +catTerm :: Text -> Maybe Text -> Term +catTerm nm Nothing = Ref nm +catTerm nm (Just c) = App "C" [Ref nm, Ref c] + +-- | [日本語]: 因子のデータ式部分 (連続/関数/I)。 factor/basis はここに出さない。 +-- [English]: The data-expression part of a factor (continuous \/ +-- function \/ I). Factor\/basis are not emitted here. +factorData :: RFactor -> [Term] +factorData (RVar x) = [Ref x] +factorData (RFun f a) = [App f [a]] +factorData (RI t) = [t] +factorData _ = [] + +-- | [日本語]: 合成パラメータ名か。 +-- [English]: Whether this is a synthesized parameter name. +isSynth :: Text -> Bool +isSynth n = "_p" `isPrefixOf` T.unpack n + +-- | [日本語]: Term 中の Ref 名 (data 変数収集用)。 +-- [English]: Ref names within a Term (for collecting data variables). +refNamesT :: Term -> [Text] +refNamesT t = case t of + Ref x -> [x] + Lit _ -> [] + App "C" (Ref x : _) -> [x] -- contrast 注釈: factor 名のみ (coding 名は除外) + App _ as -> concatMap refNamesT as + Index a b -> refNamesT a ++ refNamesT b + Neg a -> refNamesT a + Bin _ a b -> refNamesT a ++ refNamesT b + +-- | [日本語]: 文字列 → 'Formula' (R front-end)。 +-- [English]: String → 'Formula' (R front-end). +parseRFormula :: Text -> Either String Formula +parseRFormula txt = case parse pRFormula "" txt of + Left e -> Left (errorBundlePretty e) + Right f -> Right f diff --git a/src/Hanalyze/Model/GAM.hs b/src/Hanalyze/Model/GAM.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/GAM.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.GAM +-- Description : 一般化加法モデル (Generalized Additive Model, GAM) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 一般化加法モデル (Generalized Additive Model, GAM)。 +-- +-- @y = β₀ + Σ_j s_j(x_j) + ε@ で、 各平滑項 @s_j(x_j) = B_j(x_j) γ_j@ は +-- 任意の基底 @B_j@ (B-spline / 自然3次 / 多項式 / Fourier / RBF) について +-- __係数について線形__ である。 そのため基底は 'GAMBasis' として抽象化され、 +-- fit・predict・成分ごとの経路は、 いずれも訓練 @x@ から学習された実体化済み +-- 基底 ('BasisRealized') に基づいて分岐する。 これにより新しい点での予測は +-- __同一の基底行列__ を再構築する。 +-- +-- 設計: +-- +-- - 各予測子 @x_j@ について、 'GAMBasis' に従って基底行列 @B_j@ (@n × m_j@) +-- を構築する。 +-- - 単一の設計行列 @X = [1 | B_1 | B_2 | ... | B_p]@ (@1 + Σ m_j@ 列) に +-- 結合する。 +-- - Ridge 正則化 OLS: +-- @β = (XᵀX + λ P)⁻¹ Xᵀ y@、 @P = diag(0,1,…,1)@ (切片は免除)。 +-- 同一の @λ@ が全基底の平滑度を安定化する。 +-- - @λ@ は固定 ('FixedL') か、 GCV ('GCV') により基底の実体化から選ぶかを +-- 選択できる。 +-- - 予測: 各特徴の寄与 @s_j(x_j)@ は個別に抽出でき、 各因子の効果の可視化に +-- 使える。 +-- +-- 注: 識別性のため、各基底は中央化 (列平均を引く) する。 +-- これで β₀ は y の平均、s_j は変動成分のみを表す。 +-- +-- [English]: Generalized Additive Model (GAM). +-- +-- @y = β₀ + Σ_j s_j(x_j) + ε@ where each smooth term @s_j(x_j) = B_j(x_j) γ_j@ +-- is __linear in its coefficients__ for *any* basis @B_j@ (B-spline / natural +-- cubic / polynomial / Fourier / RBF). The basis is therefore abstracted as +-- 'GAMBasis'; the fit, predict, and per-component paths all dispatch on the +-- realized basis ('BasisRealized') learned from the training @x@, so +-- prediction at new points rebuilds the __same__ basis matrix. +-- +-- Design: +-- +-- - For each predictor @x_j@, build a basis matrix @B_j@ (@n × m_j@) per +-- 'GAMBasis'. +-- - Stack into a single design matrix +-- @X = [1 | B_1 | B_2 | ... | B_p]@ (@1 + Σ m_j@ columns). +-- - Ridge-regularized OLS: +-- @β = (XᵀX + λ P)⁻¹ Xᵀ y@ with @P = diag(0,1,…,1)@ (intercept exempt). +-- The same @λ@ stabilizes every basis (smoothness regularization). +-- - @λ@ may be fixed ('FixedL') or chosen by GCV ('GCV') from the realized +-- basis. +-- - Prediction: the per-feature contribution @s_j(x_j)@ can be extracted +-- individually for visualization of each factor's effect. +-- +-- Note: for identifiability, each basis is centered (column means +-- subtracted). This makes β₀ the mean of y, and each s_j purely the +-- variation component. +module Hanalyze.Model.GAM + ( -- * 基底の抽象化 + GAMBasis (..) + , BasisRealized (..) + , GAMLambda (..) + -- * フィット結果 + , GAMFit (..) + -- * フィット + , fitGAM + , fitGAMWith + , fitGAMAuto + -- * 予測 + , predictGAM + , predictGAMSE + , predictGAMComponent + ) where + +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA +import Hanalyze.Model.Spline (bsplineBasis, naturalSplineBasis, equalSpacedKnots) + +-- --------------------------------------------------------------------------- +-- 基底の抽象化 +-- --------------------------------------------------------------------------- + +-- | [日本語]: 平滑項 @s_j(x_j)@ の基底の種類 (係数について線形なものを列挙)。 +-- 各々 @x → 基底行列 (n × m)@ を与える。 +-- [English]: The kind of basis for the smooth term @s_j(x_j)@ (enumerates +-- those linear in their coefficients). Each gives @x → basis matrix (n × m)@. +data GAMBasis + = BSplineB Int Int -- ^ [日本語]: @BSplineB degree nKnots@: degree 次 B-spline (内部ノット @nKnots@)。 [English]: @BSplineB degree nKnots@: a degree-th order B-spline (with @nKnots@ interior knots). + | NaturalCubicB Int -- ^ [日本語]: @NaturalCubicB nKnots@: 自然3次回帰スプライン (内部ノット @nKnots@)。 [English]: @NaturalCubicB nKnots@: a natural cubic regression spline (with @nKnots@ interior knots). + | PolyB Int -- ^ [日本語]: @PolyB degree@: 直交化なしの多項式 (@[t,t²,…,t^degree]@・@t∈[-1,1]@ にスケール)。 [English]: @PolyB degree@: an unorthogonalized polynomial (@[t,t²,…,t^degree]@; scaled to @t∈[-1,1]@). + | FourierB Int -- ^ [日本語]: @FourierB nHarmonics@: Fourier 基底 (@sin/cos@ を @nHarmonics@ 次まで)。 [English]: @FourierB nHarmonics@: a Fourier basis (@sin/cos@ up to order @nHarmonics@). + | RBFB Int Double -- ^ [日本語]: @RBFB nCenters bandwidthRel@: ガウス RBF (等間隔中心・帯域 = 中心間隔×bandwidthRel)。 [English]: @RBFB nCenters bandwidthRel@: a Gaussian RBF (equally spaced centers; bandwidth = center spacing × bandwidthRel). + deriving (Show, Eq) + +-- | [日本語]: 学習済み基底。 訓練 @x@ から決まる具体パラメタ (ノット/中心/レンジ) を保持し、 +-- 任意の新 @x@ に対し同一の基底行列を再構築できる ('evalBasis')。 +-- [English]: A fitted basis. Holds the concrete parameters (knots/centers/ +-- range) determined from the training @x@, so the same basis matrix can be +-- rebuilt for any new @x@ ('evalBasis'). +data BasisRealized + = RBSpline Int [Double] -- ^ [日本語]: degree, 内部ノット列。 [English]: degree, list of interior knots. + | RNaturalCubic [Double] -- ^ [日本語]: ノット列。 [English]: list of knots. + | RPoly Int Double Double -- ^ [日本語]: degree, xmin, xmax (@t = 2(x−lo)/(hi−lo)−1@ にスケール)。 [English]: degree, xmin, xmax (scaled as @t = 2(x−lo)/(hi−lo)−1@). + | RFourier Int Double Double -- ^ [日本語]: nHarmonics, xmin, period (@t = (x−lo)/period@)。 [English]: nHarmonics, xmin, period (@t = (x−lo)/period@). + | RRBF [Double] Double -- ^ [日本語]: 中心列, 帯域 (絶対値)。 [English]: list of centers, bandwidth (absolute value). + deriving (Show) + +-- | [日本語]: @λ@ の決め方。 'FixedL' は固定値、 'GCV' は一般化交差検証で 1 次元探索する。 +-- [English]: How @λ@ is chosen. 'FixedL' is a fixed value; 'GCV' performs a +-- 1-D search via generalized cross-validation. +data GAMLambda + = FixedL Double -- ^ [日本語]: 固定 @λ@ (@0@ で罰則なし)。 [English]: A fixed @λ@ (@0@ disables the penalty). + | GCV -- ^ [日本語]: GCV @λ* = argmin_λ n·RSS(λ)/(n−edf(λ))²@ を log グリッド探索。 [English]: Searches a log grid for GCV @λ* = argmin_λ n·RSS(λ)/(n−edf(λ))²@. + deriving (Show, Eq) + +-- | [日本語]: 'GAMBasis' を訓練 @x@ で実体化する。 +-- [English]: Realizes a 'GAMBasis' at the training @x@. +realizeBasis :: GAMBasis -> V.Vector Double -> BasisRealized +realizeBasis b xs = + let lo = if V.null xs then 0 else V.minimum xs + hi = if V.null xs then 1 else V.maximum xs + in case b of + BSplineB deg nK -> RBSpline deg (equalSpacedKnots (nK + 2) lo hi) + -- 自然3次は基底に ≥3 ノット必要 (端2 + 内部)。 等間隔で nK+2 点 (両端含む)。 + NaturalCubicB nK -> RNaturalCubic (equalSpacedKnots (max 3 (nK + 2)) lo hi) + PolyB deg -> RPoly (max 1 deg) lo hi + FourierB h -> RFourier (max 1 h) lo (let p = hi - lo in if p <= 0 then 1 else p) + RBFB c bwRel -> + let nc = max 2 c + centers = equalSpacedKnots nc lo hi + spacing = if nc < 2 then 1 else (hi - lo) / fromIntegral (nc - 1) + bw = (if spacing <= 0 then 1 else spacing) * (if bwRel <= 0 then 1 else bwRel) + in RRBF centers bw + +-- | [日本語]: 学習済み基底で新 @x@ の基底行列 (@n × m@・__未中央化__) を作る。 +-- [English]: Builds the basis matrix (@n × m@; __not centered__) for a new +-- @x@ from the fitted basis. +evalBasis :: BasisRealized -> V.Vector Double -> LA.Matrix Double +evalBasis br xs = case br of + RBSpline deg knots -> bsplineBasis deg knots xs + -- naturalSplineBasis は先頭に定数列を含む → GAM は別途切片を持つので落とす。 + RNaturalCubic knots -> + let m = naturalSplineBasis knots xs + in if LA.cols m <= 1 then m else m LA.?? (LA.All, LA.Drop 1) + RPoly deg lo hi -> + let denom = hi - lo + t x = if denom <= 0 then 0 else 2 * (x - lo) / denom - 1 + row x = [ t x ^^ k | k <- [1 .. deg] ] + in LA.fromLists [ row x | x <- V.toList xs ] + RFourier h lo period -> + let t x = (x - lo) / period + row x = concat [ [ sin (2 * pi * fromIntegral k * t x) + , cos (2 * pi * fromIntegral k * t x) ] + | k <- [1 .. h] ] + in LA.fromLists [ row x | x <- V.toList xs ] + RRBF centers bw -> + let row x = [ exp (negate 0.5 * ((x - c) / bw) ^ (2 :: Int)) | c <- centers ] + in LA.fromLists [ row x | x <- V.toList xs ] + +-- --------------------------------------------------------------------------- +-- 型 +-- --------------------------------------------------------------------------- + +-- | GAM fit result. +data GAMFit = GAMFit + { gamDegree :: Int -- ^ [日本語]: (後方互換) 先頭 B-spline 項の degree。非 B-spline は 0。 [English]: (Backward compatibility) The degree of the leading B-spline term. 0 for non-B-spline bases. + , gamKnots :: [[Double]] -- ^ [日本語]: (後方互換) 項ごとのノット列。ノットを持たない基底は @[]@。 [English]: (Backward compatibility) The knot list per term. @[]@ for bases without knots. + , gamBases :: [BasisRealized] -- ^ [日本語]: __評価の正典__: 項ごとの学習済み基底。 [English]: The __canonical source for evaluation__: the fitted basis per term. + , gamBetas :: [LA.Vector Double] -- ^ Per-feature spline coefficients @γ_j@. + , gamColMeans :: [LA.Vector Double] -- ^ Per-feature column means of @B_j@ (for centering). + , gamIntercept :: Double -- ^ Intercept @β₀@. + , gamYHat :: LA.Vector Double -- ^ Fitted values. + , gamResid :: LA.Vector Double -- ^ Residuals. + , gamR2 :: Double -- ^ R². + , gamLambda :: Double -- ^ [日本語]: Ridge penalty @λ@ used (GCV のときは選ばれた値)。 [English]: The ridge penalty @λ@ used (the value chosen by GCV, when applicable). + , gamEdf :: Double -- ^ [日本語]: 有効自由度 @tr(S_λ)@ (GCV 用)。 [English]: The effective degrees of freedom @tr(S_λ)@ (used by GCV). + , gamCov :: LA.Matrix Double -- ^ [日本語]: 係数共分散 @Vβ = (XᵀX+λP)⁻¹·φ̂@ + -- (mgcv 流 Bayesian CI 用・@φ̂ = RSS/(n−edf)@)。 + -- [English]: Coefficient covariance @Vβ = (XᵀX+λP)⁻¹·φ̂@ + -- (for mgcv-style Bayesian CIs; @φ̂ = RSS/(n−edf)@). + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- フィット +-- --------------------------------------------------------------------------- + +-- | [日本語]: Fit a GAM (B-spline 基底固定の薄ラッパ・後方互換)。 +-- [English]: Fits a GAM (a thin wrapper fixed to a B-spline basis, kept for +-- backward compatibility). +fitGAM :: Int -- ^ B-spline degree (3 = cubic recommended). + -> Int -- ^ Number of interior knots (e.g. 5). + -> Double -- ^ Ridge penalty @λ@ (0 disables regularization). + -> [V.Vector Double] -- ^ Predictors @[x₁, x₂, …]@. + -> V.Vector Double -- ^ Response @y@. + -> GAMFit +fitGAM degree nKnots lambda xss = + fitGAMWith [ BSplineB degree nKnots | _ <- xss ] lambda xss + +-- | [日本語]: Fit a GAM with per-term基底を明示 + 固定 @λ@。 +-- [English]: Fits a GAM with an explicit per-term basis and a fixed @λ@. +fitGAMWith :: [GAMBasis] -- ^ [日本語]: 項ごとの基底 (長さ = 予測子数)。 [English]: The basis per term (length = number of predictors). + -> Double -- ^ Ridge penalty @λ@. + -> [V.Vector Double] -- ^ Predictors. + -> V.Vector Double -- ^ Response @y@. + -> GAMFit +fitGAMWith bases lambda xss y = + let realized = zipWith realizeBasis bases xss + in fitCore realized lambda xss y + +-- | [日本語]: Fit a GAM choosing @λ@ via 'GAMLambda' (FixedL / GCV)。 +-- [English]: Fits a GAM, choosing @λ@ via 'GAMLambda' (FixedL / GCV). +fitGAMAuto :: [GAMBasis] -> GAMLambda -> [V.Vector Double] -> V.Vector Double -> GAMFit +fitGAMAuto bases lam xss y = + let realized = zipWith realizeBasis bases xss + in case lam of + FixedL l -> fitCore realized l xss y + GCV -> + let grid = [ 10 ** e | e <- [(-4.0), (-3.5) .. 4.0 :: Double] ] + score l = gamGCV (fitCore realized l xss y) + best = snd (minimum [ (score l, l) | l <- grid ]) + in fitCore realized best xss y + +-- | [日本語]: GCV 値 @n·RSS/(n−edf)²@ (小さいほど良い)。 +-- [English]: The GCV value @n·RSS/(n−edf)²@ (smaller is better). +gamGCV :: GAMFit -> Double +gamGCV fit = + let n = fromIntegral (LA.size (gamResid fit)) :: Double + rss = LA.sumElements (LA.cmap (^ (2 :: Int)) (gamResid fit)) + den = n - gamEdf fit + in if den <= 1e-9 then 1/0 else n * rss / (den * den) + +-- | [日本語]: 学習済み基底列 + 固定 @λ@ で最小二乗を解く中核。 +-- [English]: The core solver that fits least squares from a list of fitted +-- bases and a fixed @λ@. +fitCore :: [BasisRealized] -> Double -> [V.Vector Double] -> V.Vector Double -> GAMFit +fitCore realized lambda xss y = + let n = V.length y + -- 各 B_j (n × m_j) を構築 + 列平均で中央化 + basisRaw = zipWith evalBasis realized xss + colMeans = [ LA.fromList + [ LA.sumElements (LA.flatten (b LA.¿ [j])) / fromIntegral n + | j <- [0 .. LA.cols b - 1] ] + | b <- basisRaw ] + basisCent = zipWith centerCols basisRaw colMeans + + -- 統合計画行列 X = [1 | B_1 | B_2 | ...] + ones = LA.asColumn (LA.konst 1 n) + x = foldl1 (LA.|||) (ones : basisCent) + yLA = LA.fromList (V.toList y) + p = LA.cols x + + -- Ridge: β = (XᵀX + λ I')⁻¹ Xᵀ y (intercept 列はペナルティ免除) + pen = LA.diag (LA.fromList (0 : replicate (p - 1) lambda)) + xtx = LA.tr x LA.<> x + lhs = xtx + pen + lhsInv = LA.inv lhs -- (XᵀX+λP)⁻¹ (edf と Vβ で共用) + xty = LA.tr x LA.#> yLA + beta = lhsInv LA.#> xty + + -- 有効自由度 edf = tr(S_λ) = tr((XᵀX+λP)⁻¹ XᵀX) + edf = sumDiag (lhsInv LA.<> xtx) + + -- intercept = β[0]、各特徴の γ_j を切り出す + mSizes = [ LA.cols b | b <- basisRaw ] + starts = scanl (+) 1 mSizes -- intercept は 0 + betas = [ LA.subVector (starts !! j) (mSizes !! j) beta + | j <- [0 .. length xss - 1] ] + intercept = beta LA.! 0 + + yhat = x LA.#> beta + resid = yLA - yhat + yMean = LA.sumElements yLA / fromIntegral n + tss = LA.sumElements (LA.cmap (\v -> (v - yMean) ^ (2 :: Int)) yLA) + rss = LA.sumElements (LA.cmap (^ (2 :: Int)) resid) + r2 = if tss < 1e-12 then 0 else 1 - rss / tss + -- CI 用係数共分散 Vβ = (XᵀX+λP)⁻¹·φ̂ (mgcv 流 Bayesian・φ̂ = RSS/(n−edf))。 + dfRes = fromIntegral n - edf + phi = if dfRes > 1e-9 then rss / dfRes else rss + cov = LA.scale phi lhsInv + in GAMFit + { gamDegree = case realized of { (RBSpline d _ : _) -> d; _ -> 0 } + , gamKnots = map knotsOf realized + , gamBases = realized + , gamBetas = betas + , gamColMeans = colMeans + , gamIntercept = intercept + , gamYHat = yhat + , gamResid = resid + , gamR2 = r2 + , gamLambda = lambda + , gamEdf = edf + , gamCov = cov + } + where + -- 列平均を引いて中央化 + centerCols :: LA.Matrix Double -> LA.Vector Double -> LA.Matrix Double + centerCols m mu = + let cols = LA.toColumns m + centered = zipWith (\c muVal -> LA.cmap (\v -> v - muVal) c) + cols (LA.toList mu) + in LA.fromColumns centered + sumDiag :: LA.Matrix Double -> Double + sumDiag = LA.sumElements . LA.takeDiag + knotsOf :: BasisRealized -> [Double] + knotsOf (RBSpline _ k) = k + knotsOf (RNaturalCubic k) = k + knotsOf _ = [] + +-- --------------------------------------------------------------------------- +-- 予測 +-- --------------------------------------------------------------------------- + +-- | Predict at new predictors. +predictGAM :: GAMFit -> [V.Vector Double] -> V.Vector Double +predictGAM fit xss = + let n = if null xss then 0 else V.length (head xss) + contributions = zipWith4 componentVec + (gamBases fit) (gamBetas fit) (gamColMeans fit) xss + total = foldl' (V.zipWith (+)) (V.replicate n (gamIntercept fit)) + contributions + in total + where + foldl' f z [] = z + foldl' f z (a:as) = let !z' = f z a in foldl' f z' as + componentVec :: BasisRealized -> LA.Vector Double -> LA.Vector Double + -> V.Vector Double -> V.Vector Double + componentVec br gamma mu xs = + let b = evalBasis br xs + n' = LA.rows b + ys = b LA.#> gamma + shiftV = LA.dot mu gamma + in V.fromList [ ys LA.! i - shiftV | i <- [0 .. n' - 1] ] + +-- | [日本語]: Predict + 各評価点の __pointwise standard error__ を返す (CI 帯用)。 +-- +-- 評価点設計行列 @Xeval = [1 | (B_j − colMean_j) | …]@ を fit と同じ中央化で組み、 +-- @se_i = √(b_i Vβ b_iᵀ)@ ('gamCov' = @Vβ@)。 中心 @μ̂@ は 'predictGAM' と一致する。 +-- 信頼水準 → 臨界値 (t) の掛け算は呼び出し側 (描画層) が行う。 +-- +-- [English]: Predicts and returns the __pointwise standard error__ at each +-- evaluation point (for CI bands). +-- +-- Builds the evaluation design matrix @Xeval = [1 | (B_j − colMean_j) | …]@ +-- with the same centering as the fit, giving @se_i = √(b_i Vβ b_iᵀ)@ +-- ('gamCov' = @Vβ@). The center @μ̂@ matches 'predictGAM'. Multiplying by the +-- critical value (t) for a confidence level is left to the caller (the +-- plotting layer). +predictGAMSE :: GAMFit -> [V.Vector Double] -> (V.Vector Double, V.Vector Double) +predictGAMSE fit xss = + let nEval = if null xss then 0 else V.length (head xss) + mu = predictGAM fit xss + basisRaw = zipWith evalBasis (gamBases fit) xss + basisCent = zipWith subtractColMeans basisRaw (gamColMeans fit) + ones = LA.asColumn (LA.konst 1 nEval) + xEval = foldl1 (LA.|||) (ones : basisCent) -- nEval × p + m1 = xEval LA.<> gamCov fit -- nEval × p + varVec = [ LA.dot rM rX | (rM, rX) <- zip (LA.toRows m1) (LA.toRows xEval) ] + se = map (sqrt . max 0) varVec + in (mu, V.fromList se) + +-- | [日本語]: 各列から学習時の列平均を引く (評価点を fit と同じ中央化にする)。 +-- [English]: Subtracts the training-time column mean from each column +-- (applies the same centering to the evaluation points as the fit). +subtractColMeans :: LA.Matrix Double -> LA.Vector Double -> LA.Matrix Double +subtractColMeans m mu = + LA.fromColumns (zipWith (\c muVal -> LA.cmap (subtract muVal) c) + (LA.toColumns m) (LA.toList mu)) + +-- | The contribution @s_j(x)@ from feature @j@ only (without the intercept). +predictGAMComponent :: GAMFit -> Int -> V.Vector Double -> V.Vector Double +predictGAMComponent fit j xs + | j < 0 || j >= length (gamBetas fit) = V.empty + | otherwise = + let b = evalBasis (gamBases fit !! j) xs + gamma = gamBetas fit !! j + mu = gamColMeans fit !! j + ys = b LA.#> gamma + shiftV = LA.dot mu gamma + n = LA.rows b + in V.fromList [ ys LA.! i - shiftV | i <- [0 .. n - 1] ] + +-- 4-引数 zipWith (base に無いので局所定義)。 +zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] +zipWith4 f (a:as) (b:bs) (c:cs) (d:ds) = f a b c d : zipWith4 f as bs cs ds +zipWith4 _ _ _ _ _ = [] diff --git a/src/Hanalyze/Model/GARCH.hs b/src/Hanalyze/Model/GARCH.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/GARCH.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.GARCH +-- Description : GARCH(1,1) 条件付き分散モデル (Generalized AutoRegressive Conditional Heteroskedasticity) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- GARCH(1,1) — Generalized AutoRegressive Conditional Heteroskedasticity. +-- +-- Bollerslev (1986). Models time-varying conditional variance for a +-- (de-meaned) return series: +-- +-- @ +-- y_t = μ + ε_t, ε_t = σ_t · z_t, z_t ~ N(0, 1) +-- σ²_t = ω + α · ε²_{t-1} + β · σ²_{t-1} +-- @ +-- +-- Constraints: @ω > 0, α ≥ 0, β ≥ 0, α + β < 1@ (stationarity). +-- +-- Estimation by quasi-MLE under Gaussian innovations, optimized with +-- L-BFGS using numeric gradients. The constraints are enforced via a +-- reparametrization (softplus for ω, a stick-breaking sigmoid pair for +-- α and β capped at @0.999@). +-- +-- @ +-- import Hanalyze.Model.GARCH +-- +-- let fit = fitGARCH ys -- GARCH(1,1) on the series +-- vh = forecastGARCH fit 10 -- 10-step ahead σ² forecast +-- @ +-- +-- == Implemented +-- +-- * 'fitGARCH' (GARCH(1,1) Gaussian QMLE) +-- * 'forecastGARCH' (h-step-ahead conditional variance) +module Hanalyze.Model.GARCH + ( GARCHFit (..) + , fitGARCH + , forecastGARCH + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Optim.LBFGS as LBFGS +import qualified Hanalyze.Optim.Common as OC +import System.IO.Unsafe (unsafePerformIO) + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +-- | Fitted GARCH(1,1) model. +data GARCHFit = GARCHFit + { gOmega :: !Double -- ^ Unconditional variance offset @ω@. + , gAlpha :: !Double -- ^ ARCH coefficient @α@. + , gBeta :: !Double -- ^ GARCH coefficient @β@. + , gMu :: !Double -- ^ Mean of @y_t@. + , gSigma2 :: !(LA.Vector Double) -- ^ In-sample conditional variance @σ²_t@. + , gResiduals :: !(LA.Vector Double) -- ^ In-sample residuals @ε_t = y_t - μ@. + , gLogLik :: !Double -- ^ Maximized Gaussian log-likelihood. + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- Reparametrization helpers +-- --------------------------------------------------------------------------- + +softplus :: Double -> Double +softplus x + | x > 50 = x + | x < -50 = exp x + | otherwise = log1p (exp x) + where log1p z = log (1 + z) + +sigmoid :: Double -> Double +sigmoid x + | x > 500 = 1 + | x < -500 = 0 + | otherwise = 1 / (1 + exp (-x)) + +-- | Map unconstrained @(θω, θα, θβ)@ to @(ω, α, β)@. +unpackParams :: Double -> Double -> Double -> (Double, Double, Double) +unpackParams t0 t1 t2 = + let w = softplus t0 + s = sigmoid t1 -- total persistence ∈ (0, 1) + sab = s * 0.999 -- α + β strictly < 1 + r = sigmoid t2 -- α-share of total ∈ (0, 1) + a = sab * r + b = sab * (1 - r) + in (w, a, b) + +-- Inverse of 'unpackParams' for warm-starting from a feasible point. +packParams :: Double -> Double -> Double -> (Double, Double, Double) +packParams w a b = + let !sab = a + b + !t0 = invSoftplus w + !t1 = invSigmoid (sab / 0.999) + !r = if sab > 0 then a / sab else 0.5 + !t2 = invSigmoid r + in (t0, t1, t2) + where + invSoftplus y + | y > 50 = y + | otherwise = log (exp y - 1) + invSigmoid p = + let pc = min 0.99999 (max 1e-5 p) + in log (pc / (1 - pc)) + +-- --------------------------------------------------------------------------- +-- Recursion +-- --------------------------------------------------------------------------- + +-- | Run the GARCH(1,1) σ² recursion. @σ²_0@ is initialized to the sample +-- variance of @ε@ (a standard QMLE starting choice; alternatives such as +-- the unconditional variance @ω/(1-α-β)@ are equivalent in the limit). +recurseSigma2 + :: Double -- ^ ω. + -> Double -- ^ α. + -> Double -- ^ β. + -> LA.Vector Double -- ^ ε. + -> LA.Vector Double -- ^ σ² of same length as ε. +recurseSigma2 !w !a !b eps = + let n = LA.size eps + var0 = LA.dot eps eps / fromIntegral n + sig0 = max 1e-12 var0 + step !s2Prev !ePrev = w + a * ePrev * ePrev + b * s2Prev + go !i !s2Prev acc + | i >= n = reverse acc + | otherwise = + let !s2 = if i == 0 + then sig0 + else step s2Prev (LA.atIndex eps (i - 1)) + in go (i + 1) s2 (s2 : acc) + in LA.fromList (go 0 0 []) + +-- | Negative Gaussian log-likelihood (to be minimized). +negLL + :: LA.Vector Double -- ^ ε. + -> Double -- ^ ω. + -> Double -- ^ α. + -> Double -- ^ β. + -> Double +negLL eps w a b = + let s2 = recurseSigma2 w a b eps + n = LA.size eps + ll = sum [ let s = max 1e-12 (LA.atIndex s2 i) + e = LA.atIndex eps i + in log (2 * pi * s) + e * e / s + | i <- [0 .. n - 1] ] + in 0.5 * ll + +-- --------------------------------------------------------------------------- +-- Fitting +-- --------------------------------------------------------------------------- + +-- | Fit a GARCH(1,1) model to @y@ by Gaussian QMLE. The mean @μ@ is +-- estimated as the sample mean; ω/α/β are jointly optimized by L-BFGS +-- with numeric gradients in an unconstrained reparametrization. +-- +-- Starting values: @α = 0.05@, @β = 0.90@, @ω = (1 - α - β) · Var(ε)@ +-- (so that the unconditional variance matches the sample variance). +fitGARCH :: LA.Vector Double -> GARCHFit +fitGARCH y = + let n = LA.size y + mu = LA.sumElements y / fromIntegral n + eps = y - LA.scalar mu + var0 = LA.dot eps eps / fromIntegral n + a0 = 0.05 + b0 = 0.90 + w0 = max 1e-8 ((1 - a0 - b0) * var0) + (t00, t10, t20) = packParams w0 a0 b0 + objL [t0, t1, t2] = + let (w, a, b) = unpackParams t0 t1 t2 + in negLL eps w a b + objL _ = error "fitGARCH: expected 3 parameters" + cfg = LBFGS.defaultLBFGSConfig + res = unsafePerformIO (LBFGS.runLBFGSNumeric cfg objL [t00, t10, t20]) + [t0, t1, t2] = OC.orBest res + (w, a, b) = unpackParams t0 t1 t2 + s2 = recurseSigma2 w a b eps + in GARCHFit + { gOmega = w + , gAlpha = a + , gBeta = b + , gMu = mu + , gSigma2 = s2 + , gResiduals = eps + , gLogLik = negate (OC.orValue res) + } + +-- --------------------------------------------------------------------------- +-- Forecasting +-- --------------------------------------------------------------------------- + +-- | @h@-step-ahead conditional variance forecast. The recursion is +-- +-- @ +-- σ²_{T+1} = ω + α · ε²_T + β · σ²_T +-- σ²_{T+k} = ω + (α + β) · σ²_{T+k-1} (k ≥ 2) +-- @ +-- +-- so that the forecast converges to the unconditional variance +-- @ω / (1 - α - β)@. +forecastGARCH :: GARCHFit -> Int -> LA.Vector Double +forecastGARCH fit h + | h <= 0 = LA.fromList [] + | otherwise = + let w = gOmega fit + a = gAlpha fit + b = gBeta fit + s2 = gSigma2 fit + eps = gResiduals fit + n = LA.size s2 + sT = LA.atIndex s2 (n - 1) + eT = LA.atIndex eps (n - 1) + s1 = w + a * eT * eT + b * sT + go !k !prev + | k > h = [] + | k == 1 = s1 : go 2 s1 + | otherwise = + let !nxt = w + (a + b) * prev + in nxt : go (k + 1) nxt + in LA.fromList (go 1 0) diff --git a/src/Hanalyze/Model/GLM.hs b/src/Hanalyze/Model/GLM.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/GLM.hs @@ -0,0 +1,719 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.GLM +-- Description : IRLS による一般化線形モデル (Generalized Linear Models) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Generalized Linear Models fit by Iteratively Reweighted Least Squares. +-- +-- Provides Gaussian, Binomial and Poisson families with identity, log, +-- logit and sqrt link functions. 'runIRLS' returns both a 'FitResult' and +-- the inverse Fisher information @(XᵀWX)⁻¹@ used for standard errors and +-- predictive intervals. The multi-output variant 'fitGLMMulti' shares the +-- family / link across response columns and runs IRLS column-wise. +module Hanalyze.Model.GLM + ( Family (..) + , parseFamily + , LinkFn (..) + , parseLink + , canonicalLink + , GLMSolver (..) + , fitGLM + , fitGLMFull + , fitGLMWith + , fitGLMWithSmooth + , runIRLS + , runLBFGS_GLM + -- * Multi-output (per-column IRLS; Family/Link shared) + , GLMFitMulti (..) + , fitGLMMulti + -- * Diagnostic primitives (新規 export, request/090-CD) + , Link + , linkFnOf + , glmDeviance + , glmLogLik + , glmVariance + -- * Residuals + predict SE (request/090-AB) + , glmPearsonResiduals + , glmDevianceResiduals + , GlmPredictCI (..) + , predictGlmEtaWithSE + , predictGlmMuWithCI + ) where + +import qualified DataFrame.Internal.DataFrame as DXD +import Hanalyze.DataIO.Convert (getDoubleVec) +import Hanalyze.Model.Core +import Hanalyze.Model.LM (multiPolyDesignMatrix, linspace, SmoothFit (..)) + +import Data.Text (Text) +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Stat.Cholesky as Chol +import qualified Hanalyze.Optim.LBFGS as LBFGS +import qualified Hanalyze.Optim.Common as OC +import System.IO.Unsafe (unsafePerformIO) +import Statistics.Distribution (quantile) +import Statistics.Distribution.Normal (normalDistr) +import Statistics.Distribution.StudentT (studentT) + +-- --------------------------------------------------------------------------- +-- Family (response distribution) +-- --------------------------------------------------------------------------- + +-- | GLM exponential-family distribution. +data Family = Gaussian | Binomial | Poisson + deriving (Show, Eq) + +-- | Parse a 'Family' name (case-sensitive). +parseFamily :: String -> Either String Family +parseFamily "gaussian" = Right Gaussian +parseFamily "binomial" = Right Binomial +parseFamily "poisson" = Right Poisson +parseFamily s = Left ("Unknown distribution '" ++ s ++ "'. Use: gaussian | binomial | poisson") + +-- --------------------------------------------------------------------------- +-- Link function +-- --------------------------------------------------------------------------- + +-- | GLM link function. +data LinkFn = Identity | Log | Logit | Sqrt + deriving (Show, Eq) + +-- | Parse a 'LinkFn' name. +parseLink :: String -> Either String LinkFn +parseLink "identity" = Right Identity +parseLink "log" = Right Log +parseLink "logit" = Right Logit +parseLink "sqrt" = Right Sqrt +parseLink s = Left ("Unknown link '" ++ s ++ "'. Use: identity | log | logit | sqrt") + +-- | The canonical link function for a given family. +canonicalLink :: Family -> LinkFn +canonicalLink Gaussian = Identity +canonicalLink Binomial = Logit +canonicalLink Poisson = Log + +-- Internal triple: (g, g⁻¹, g') +type Link = (Double -> Double, Double -> Double, Double -> Double) + +-- | Resolve a 'LinkFn' to its triple @(g, g⁻¹, g')@. +linkFnOf :: LinkFn -> Link +linkFnOf Identity = (id, id, const 1.0) +linkFnOf Log = (log, exp, recip) +linkFnOf Logit = ( \x -> log (x / (1 - x)) + , \eta -> 1 / (1 + exp (-eta)) + , \mu -> 1.0 / (mu * (1 - mu)) + ) +linkFnOf Sqrt = (sqrt, \eta -> eta * eta, \mu -> 0.5 / sqrt (max 1e-10 mu)) + +-- | Variance function @V(μ)@ for the given family. +varOf :: Family -> Double -> Double +varOf Gaussian _ = 1.0 +varOf Binomial mu = mu * (1 - mu) +varOf Poisson mu = mu + +-- | Public alias for the family variance @V(μ)@; see @varOf@. Exposed +-- so HPotfire diagnostics can compute Pearson-style standardisations +-- without re-implementing the family table. +glmVariance :: Family -> Double -> Double +glmVariance = varOf + +-- | Clamp @μ@ to its valid range, avoiding boundary singularities. +safeMu :: Family -> LA.Vector Double -> LA.Vector Double +safeMu Binomial = LA.cmap (max 1e-8 . min (1 - 1e-8)) +safeMu Poisson = LA.cmap (max 1e-8) +safeMu Gaussian = id + +-- | Fused @safeMu (gInv eta)@ for canonical-link GLMs — single +-- @VS.map@ pass instead of @gInv@ followed by @safeMu@. +-- +-- P36 (2026-05-07): the Poisson IRLS loop did +-- @safeMu (VS.map (exp . min 500) eta)@ each iteration, which is two +-- passes over an @n@-vector and two allocations. Most iterations +-- spend the bulk of time in 'irlsStep' BLAS calls anyway, but on the +-- @n=10000@ Poisson bench this fused form trims ~10% off per-iter μ +-- compute. For non-canonical links callers fall back to the generic +-- @safeMu . VS.map gInv@ path. +-- +-- Currently only used for the Poisson canonical link — Binomial +-- empirically regresses under fusion (GHC inlines the two-pass split +-- form better on the logit bench) so it stays on the +-- @safeMu . VS.map gInv@ path. +muCanonical :: Family -> LA.Vector Double -> LA.Vector Double +muCanonical Poisson = + VS.map (\e -> max 1e-8 (exp (min 500 e))) +muCanonical f = + -- Generic fallback: callers should normally not hit this for + -- Binomial / Gaussian; defined for totality. + safeMu f +{-# INLINE muCanonical #-} + +-- --------------------------------------------------------------------------- +-- IRLS +-- --------------------------------------------------------------------------- + +maxIter :: Int +maxIter = 100 + +tol :: Double +tol = 1e-8 + +-- | Per-observation log-likelihood for the canonical-link GLMs we +-- support. Used for the IRLS log-likelihood-based early termination +-- (see 'runIRLS'). +-- +-- - Gaussian: @-½ (y − μ)²@ (constant terms dropped, harmless for the +-- ratio-based stopping rule). +-- - Binomial: @y log μ + (1 − y) log (1 − μ)@. +-- - Poisson : @y log μ − μ@ (Stirling term dropped). +-- +-- List-based zipWith/sum accounted for 11.3% of time + 8.3% of +-- allocation on the n=10k logit profile. Replaced with vector-native +-- zipVectorWith + sumElements (no list materialization, single +-- BLAS-friendly pass). The family is dispatched once at the top-level +-- let-binding so the inner zipVectorWith sees a fully monomorphic +-- Double -> Double -> Double closure that GHC can specialize. +glmLogLik :: Family -> LA.Vector Double -> LA.Vector Double -> Double +glmLogLik family y mu = VS.sum (VS.zipWith f y mu) + where + f = case family of + Gaussian -> \yi mi -> -0.5 * (yi - mi) ** 2 + Binomial -> \yi mi -> + let m' = max 1e-12 (min (1 - 1e-12) mi) + in yi * log m' + (1 - yi) * log (1 - m') + Poisson -> \yi mi -> + let m' = max 1e-12 mi + in yi * log m' - m' + +initBeta :: Family -> LinkFn -> LA.Vector Double -> Int -> LA.Vector Double +initBeta family linkFn y p = + let (g, _, _) = linkFnOf linkFn + yMean = LA.sumElements y / fromIntegral (LA.size y) + yC = case family of + Binomial -> max 1e-6 (min (1 - 1e-6) yMean) + Poisson -> max 1e-6 yMean + Gaussian -> yMean + in LA.fromList (g yC : replicate (p - 1) 0.0) + +-- | One IRLS step. Returns the updated @β@ together with the +-- corresponding @μ@ and the log-likelihood at the /input/ @β@. +-- +-- Returning @μ_old@ and @ll_old@ here lets the convergence loop in +-- 'runIRLS' avoid an extra @x #> beta@ + @gInv μ@ + 'glmLogLik' pass +-- per iteration that the old API forced (see glmbench §1). +irlsStep :: Link -> (Double -> Double) + -> (Family -> LA.Vector Double -> LA.Vector Double) + -> Family -> LA.Matrix Double -> LA.Vector Double -> LA.Vector Double + -> (LA.Vector Double, LA.Vector Double, Double) +irlsStep (_, gInv, gDeriv) varFn clamp family x y beta = + -- Phase 12a (2026-05-06): replaced massiv-based map/zipWith3 with + -- pure VS.{map,zipWith3}. Profile (Phase 11) showed + -- @trivialScheduler_@ (massiv) consumed 9.8% of GLM IRLS time — + -- pure overhead since 'compFor' was always 'Seq'. The replacement + -- is single-pass, allocation-equivalent, and avoids the + -- hmatrix↔massiv round trip. + -- + -- P36 (2026-05-07): for Poisson canonical link, fuse @gInv@ and + -- @safeMu@ into a single VS.map. Empirically Binomial regresses + -- under the same fusion (GHC inlines the two-pass split better), + -- so it stays on the generic path. The family pattern-match is + -- hot-loop constant and gets specialized away by GHC. + let eta = x LA.#> beta + mu = case family of + Poisson -> muCanonical Poisson eta + _ -> clamp family (VS.map gInv eta) + llHere = glmLogLik family y mu + ws = VS.map (\m -> max 1e-10 + (1.0 / (gDeriv m ^ (2 :: Int) * varFn m))) + mu + zs = VS.zipWith3 (\ei yi mi -> ei + (yi - mi) * gDeriv mi) + eta y mu + -- Normal-equations form: solve (Xᵀ W X) β = Xᵀ W z via SPD Cholesky. + -- Faster than solving (√W X) β = (√W z) with the general LSQ + -- (dgels) when n ≫ p, which is the common GLM regime. + wxT = LA.tr x * LA.asRow ws -- p × n with column scaling + gMat = wxT LA.<> x -- p × p (SPD) + bRhs = LA.asColumn (wxT LA.#> zs) -- p × 1 + betaNew = LA.flatten (Chol.cholSolveJitter gMat bRhs) + in (betaNew, mu, llHere) + +-- --------------------------------------------------------------------------- +-- Solver selection +-- --------------------------------------------------------------------------- + +-- | GLM solver back-end. +-- +-- - 'IRLS' — Iteratively Re-weighted Least Squares. Each iteration +-- builds and solves the SPD normal equations @XᵀWX β = XᵀWz@ via +-- 'Hanalyze.Stat.Cholesky.cholSolveJitter'. Quadratic convergence (= a full +-- Newton step every iteration); each iteration is @O(np²)@. +-- - 'LBFGS' — direct L-BFGS minimization of the negative +-- log-likelihood with the analytic gradient @Xᵀ(μ − y)@ (canonical +-- link). Per-iteration cost is @O(np)@. This is what @sklearn@ +-- uses, and is the better choice in @n ≫ p²@ regimes once the +-- 'Hanalyze.Optim.LBFGS' inner loop is moved off Haskell-list operations. +-- +-- Default solver: 'IRLS'. In the current bench regime (@n ≤ 10000@, +-- @p ≤ 20@), IRLS-with-Cholesky beats the pure-Haskell-list L-BFGS +-- because @O(np²)@ on small @p@ is dominated by hmatrix's BLAS calls +-- whereas the L-BFGS path pays per-step Haskell overhead. Switch to +-- 'LBFGS' for problems with @p > 50@ or when 'Hanalyze.Optim.LBFGS' itself is +-- vectorized. +data GLMSolver + = IRLS + | LBFGS + deriving (Eq, Show) + +defaultGLMSolver :: GLMSolver +defaultGLMSolver = IRLS + +-- --------------------------------------------------------------------------- +-- L-BFGS direct GLM +-- --------------------------------------------------------------------------- + +-- | Negative log-likelihood @-ℓ(β)@ for a canonical-link GLM. +glmNegLogLik :: Family -> LA.Matrix Double -> LA.Vector Double + -> LA.Vector Double -> Double +glmNegLogLik family x y beta = negate (glmLogLik family y mu) + where + eta = x LA.#> beta + mu = case family of + Gaussian -> eta + Binomial -> LA.cmap (\e -> 1 / (1 + exp (-e))) eta + Poisson -> LA.cmap (\e -> exp (min 500 e)) eta + +-- | Gradient of @-ℓ(β)@ for a canonical-link GLM: +-- +-- @∇(-ℓ) = Xᵀ (μ - y)@ +-- +-- This identity holds for /every/ exponential-family GLM with the +-- canonical link, which is why L-BFGS is so attractive here — no +-- per-family branching is needed inside the gradient. +glmGrad :: Family -> LA.Matrix Double -> LA.Vector Double + -> LA.Vector Double -> LA.Vector Double +glmGrad family x y beta = + let eta = x LA.#> beta + mu = case family of + Gaussian -> eta + Binomial -> LA.cmap (\e -> 1 / (1 + exp (-e))) eta + Poisson -> LA.cmap (\e -> exp (min 500 e)) eta + in LA.tr x LA.#> (mu - y) + +-- | Fit a canonical-link GLM by minimizing the negative log-likelihood +-- with L-BFGS. This is the path that 'sklearn.linear_model.\*' uses +-- internally for logistic and Poisson regression and is markedly +-- faster than IRLS when @n ≫ p@ because each L-BFGS iteration costs +-- only @O(np)@ versus IRLS's @O(np²)@ for the @XᵀWX@ build. +-- +-- Returns the same @(FitResult, fisherInv)@ pair as 'runIRLS'; the +-- Fisher information is computed once at the converged β via the same +-- Cholesky path used by IRLS, so downstream uses (CIs, WAIC, …) are +-- identical. +runLBFGS_GLM :: Family -> LA.Matrix Double -> LA.Vector Double + -> (FitResult, LA.Matrix Double) +runLBFGS_GLM family x y = + -- Only canonical-link GLMs are supported here (the simple gradient + -- formula above relies on the canonical link). For non-canonical + -- links (e.g. probit, sqrt link) the caller should use 'runIRLS'. + let p = LA.cols x + beta0 = initBeta family (canonicalLink family) y p + -- Vector-native objective and gradient (no list conversion per + -- L-BFGS step, which used to dominate runtime when @p ≈ 20@). + fV b = glmNegLogLik family x y b + gV b = glmGrad family x y b + cfg = LBFGS.defaultLBFGSConfig + { LBFGS.lbStop = OC.defaultStopCriteria + { OC.stMaxIter = 200 + , OC.stTolFun = 1e-10 + , OC.stTolX = 1e-10 } } + result = unsafePerformIO $ + LBFGS.runLBFGSWithV cfg fV gV beta0 + betaF = LA.fromList (OC.orBest result) + mu = safeMu family $ case family of + Gaussian -> x LA.#> betaF + Binomial -> LA.cmap (\e -> 1 / (1 + exp (-e))) (x LA.#> betaF) + Poisson -> LA.cmap (\e -> exp (min 500 e)) (x LA.#> betaF) + resid = y - mu + r2 = pseudoR2 family y mu + fitR = FitResult (LA.asColumn betaF) + (LA.asColumn mu) + (LA.asColumn resid) + (LA.fromList [r2]) + -- Fisher information at convergence (same path as IRLS). + ws = VS.map (\m -> max 1e-10 (1.0 / (gDeriv m ^ (2::Int) + * varOf family m))) + mu + wxT = LA.tr x * LA.asRow ws + gMat = wxT LA.<> x + fisher = Chol.cholSolveJitter gMat (LA.ident p) + in (fitR, fisher) + where + (_, _, gDeriv) = linkFnOf (canonicalLink family) + +-- --------------------------------------------------------------------------- + +-- | Run IRLS to fit a single-output GLM. Returns both the fit result +-- and the inverse Fisher information @(XᵀWX)⁻¹@ used for standard +-- errors and credible/predictive intervals. +runIRLS :: Family -> LinkFn -> LA.Matrix Double -> LA.Vector Double + -> (FitResult, LA.Matrix Double) +runIRLS family linkFn x y = (mkResult betaFinal muFinal, fisherInvFromMu muFinal) + where + link@(_, gInv, _) = linkFnOf linkFn + step = irlsStep link (varOf family) safeMu family x y + beta0 = initBeta family linkFn y (LA.cols x) + isCanonicalLink = linkFn == canonicalLink family + + -- Mu at convergence boundary: mirror 'irlsStep' Poisson fusion + -- when on the canonical link. + muOf beta + | isCanonicalLink && family == Poisson + = muCanonical Poisson (x LA.#> beta) + | otherwise = safeMu family (VS.map gInv (x LA.#> beta)) + + -- 'converge' tracks β and the /previous/ iteration's log-likelihood. + -- 'irlsStep' returns @(β_{k+1}, μ_at_β_k, ll_at_β_k)@: the updated β + -- plus the current iter's μ + ll, all free side-products of the + -- IRLS step itself. We pass @ll_at_β_k@ forward as the next iter's + -- @llP@, eliminating the dedicated O(np) @llOf β@ pass per iter + -- that the previous code performed (glmbench §1). + -- + -- Convergence is checked on β-norm or relative ll change. The ll + -- comparison is between ll(β_k) and ll(β_{k-1}) — one iteration + -- lagged from the standard ll(β_{k+1}) vs ll(β_k) form, which is + -- equivalent in steady state and avoids any extra μ pass in the + -- inner loop. + (betaFinal, muFinal) = converge maxIter True beta0 (glmLogLik family y (muOf beta0)) + + -- ★初回反復だけ dLL 判定を無効化する: 'irlsStep' が返す @llHere@ は入力 β での + -- @ll(β_k)@ なので、 初回は seed @llP = ll(β0)@ と一致し @dLL = 0 < tol@ で + -- IRLS が 1 ステップで早期停止してしまう (= 28d1feb7 の per-iter ll 再利用 + -- リライトで混入した回帰)。 dB (β-norm) 判定は初回も正しいので残し、 dLL は + -- 2 反復目以降 @ll(β_k) vs ll(β_{k-1})@ が揃ってから使う。 + converge 0 _ beta _ = (beta, muOf beta) + converge n first beta llP = + let (betaNew, _muHere, llHere) = step beta + in if any notFinite (LA.toList betaNew) + then (beta, muOf beta) -- divergence; keep last good β + else + let dB = LA.norm_2 (betaNew - beta) + dLL = abs (llHere - llP) / max (abs llP) 1 + in if dB < tol || (not first && dLL < tol) + then (betaNew, muOf betaNew) -- final μ pass once + else converge (n - 1) False betaNew llHere + + notFinite b = isNaN b || isInfinite b + + mkResult beta mu = + let resid = y - mu + r2 = pseudoR2 family y mu + in FitResult (LA.asColumn beta) + (LA.asColumn mu) + (LA.asColumn resid) + (LA.fromList [r2]) + + fisherInvFromMu mu = + let (_, _, gDeriv) = link + ws = VS.map (\m -> max 1e-10 + (1.0 / (gDeriv m ^ (2::Int) * varOf family m))) + mu + wxT = LA.tr x * LA.asRow ws -- p × n + gMat = wxT LA.<> x -- p × p (SPD) + p = LA.cols x + in Chol.cholSolveJitter gMat (LA.ident p) + +-- --------------------------------------------------------------------------- +-- Public API +-- --------------------------------------------------------------------------- + +-- | Fit a GLM with the canonical link, returning just the 'FitResult'. +-- Uses @defaultGLMSolver@ (currently 'IRLS'). +fitGLM :: Family -> LA.Matrix Double -> LA.Vector Double -> FitResult +fitGLM family x y = + fst (fitGLMWith defaultGLMSolver family (canonicalLink family) x y) + +-- | Like 'fitGLM' but also returns the inverse Fisher information +-- (Laplace-approximate posterior covariance). Used by the WAIC / LOO-CV +-- posterior-sampling helpers. +-- +-- Routes through 'fitGLMWith' with @defaultGLMSolver@. When the +-- supplied 'LinkFn' is /not/ the canonical link of the family, the +-- 'LBFGS' solver is unsupported and the function silently falls back +-- to 'IRLS' so existing call sites that pass non-canonical links keep +-- working. +fitGLMFull :: Family -> LinkFn -> LA.Matrix Double -> LA.Vector Double + -> (FitResult, LA.Matrix Double) +fitGLMFull family linkFn x y + | linkFn == canonicalLink family = fitGLMWith defaultGLMSolver family linkFn x y + | otherwise = runIRLS family linkFn x y + +-- | Pick the solver explicitly. The 'LBFGS' path is only valid for the +-- canonical link of the family; non-canonical links transparently fall +-- back to 'IRLS'. +fitGLMWith + :: GLMSolver -> Family -> LinkFn + -> LA.Matrix Double -> LA.Vector Double + -> (FitResult, LA.Matrix Double) +fitGLMWith IRLS family linkFn x y = runIRLS family linkFn x y +fitGLMWith LBFGS family linkFn x y + | linkFn == canonicalLink family = runLBFGS_GLM family x y + | otherwise = runIRLS family linkFn x y + +-- | Fit GLM with specified distribution and link function. +-- Accepts multiple x columns with per-column polynomial degrees. +-- Returns SmoothFit only when there is exactly one x column (for scatter plot). +-- For PI with non-Gaussian families, falls back to CI (warn at call site). +fitGLMWithSmooth + :: Family + -> LinkFn + -> [(Text, Int)] -- ^ [(x column name, polynomial degree)] + -> Band -- ^ uncertainty band specification + -> Int -- ^ grid resolution for smooth curve + -> DXD.DataFrame + -> Text -- ^ y column + -> Maybe (FitResult, Maybe SmoothFit) +fitGLMWithSmooth family linkFn colDegs band nGrid df yCol = do + xVecs <- mapM (flip getDoubleVec df . fst) colDegs + yVec <- getDoubleVec yCol df + + let degrees = map snd colDegs + dm = multiPolyDesignMatrix (zip xVecs degrees) + y = LA.fromList (V.toList yVec) + (res, fisher) = runIRLS family linkFn dm y + (_, gInv, _) = linkFnOf linkFn + beta = coefficientsV res + n = LA.rows dm + p = LA.cols dm + + -- PI falls back to CI for non-Gaussian (caller should warn) + effectiveBand = case (band, family) of + (PI lvl, Gaussian) -> PI lvl + (PI lvl, _) -> CI lvl + (b, _) -> b + + mSmooth = case (xVecs, degrees) of + ([xVec], [deg]) -> Just (makeSmoothFit xVec deg) + _ -> Nothing + + makeSmoothFit xVec deg = + let xLa = LA.fromList (V.toList xVec) + xMin = LA.minElement xLa + xMax = LA.maxElement xLa + span' = max 1e-8 (xMax - xMin) + xGrid = V.fromList (linspace (xMin - 0.5*span') (xMax + 0.5*span') nGrid) + dmG = multiPolyDesignMatrix [(xGrid, deg)] + etaG = dmG LA.#> beta + yGrid = map gInv (LA.toList etaG) + gRows = LA.toRows dmG + in case effectiveBand of + NoBand -> + SmoothFit (V.toList xGrid) yGrid yGrid yGrid False + CI level -> + let qVal = ciQuantile level + halfW xi = qVal * sqrt (max 0 (xi `LA.dot` (fisher LA.#> xi))) + etaL = LA.toList etaG + lowers = zipWith (\eta xi -> gInv (eta - halfW xi)) etaL gRows + uppers = zipWith (\eta xi -> gInv (eta + halfW xi)) etaL gRows + in SmoothFit (V.toList xGrid) yGrid lowers uppers True + PI level -> + -- Gaussian only: add s²·1 term to CI variance + let dfStat = fromIntegral (n - p) :: Double + etaL = LA.toList etaG + -- df<=0 (飽和) は s²=0/0・studentT が例外 → 帯を線に潰す (lo=hi=ĝ⁻¹(η))。 + in if dfStat <= 0 + then SmoothFit (V.toList xGrid) yGrid (map gInv etaL) (map gInv etaL) True + else + let s2 = let resV = residualsV res + in (resV `LA.dot` resV) / dfStat + tVal = quantile (studentT dfStat) ((1 + level) / 2) + xtxi = LA.inv (LA.tr dm LA.<> dm) + halfW xi = tVal * sqrt (s2 * (1 + xi `LA.dot` (xtxi LA.#> xi))) + lowers = zipWith (\eta xi -> gInv (eta - halfW xi)) etaL gRows + uppers = zipWith (\eta xi -> gInv (eta + halfW xi)) etaL gRows + in SmoothFit (V.toList xGrid) yGrid lowers uppers True + + ciQuantile level = case family of + -- 飽和 (df=n-p<=0) は studentT が例外 → 分位点 0 = CI 幅ゼロ (帯を線に潰す)。 + Gaussian | n - p <= 0 -> 0 + | otherwise -> quantile (studentT (fromIntegral (n - p))) ((1 + level) / 2) + _ -> quantile (normalDistr 0 1) ((1 + level) / 2) + + return (res, mSmooth) + +-- --------------------------------------------------------------------------- +-- Goodness of fit +-- --------------------------------------------------------------------------- + +-- | McFadden-style pseudo-R² for GLMs. +pseudoR2 :: Family -> LA.Vector Double -> LA.Vector Double -> Double +pseudoR2 Gaussian y mu = + let resid = y - mu + yMean = LA.sumElements y / fromIntegral (LA.size y) + dev = LA.cmap (subtract yMean) y + in 1 - (resid `LA.dot` resid) / (dev `LA.dot` dev) +pseudoR2 family y mu = + let yMean = LA.sumElements y / fromIntegral (LA.size y) + muNull = LA.konst yMean (LA.size y) + dFit = glmDeviance family y mu + dNull = glmDeviance family y muNull + in if dNull == 0 then 1 else 1 - dFit / dNull + +-- | GLM deviance: @D(y, μ̂) = 2 (ℓ_sat − ℓ_model)@. +glmDeviance :: Family -> LA.Vector Double -> LA.Vector Double -> Double +glmDeviance Gaussian y mu = + let r = y - mu in r `LA.dot` r +glmDeviance Binomial y mu = + let muC = LA.cmap (max 1e-15 . min (1 - 1e-15)) mu + term = VS.zipWith + (\yi mui -> xlogy yi (yi / mui) + + xlogy (1 - yi) ((1 - yi) / (1 - mui))) + y muC + in 2 * VS.sum term +glmDeviance Poisson y mu = + let muC = LA.cmap (max 1e-15) mu + term = VS.zipWith + (\yi mui -> xlogy yi (yi / mui) - (yi - mui)) + y muC + in 2 * VS.sum term + +xlogy :: Double -> Double -> Double +xlogy 0 _ = 0 +xlogy x y = x * log y + +-- --------------------------------------------------------------------------- +-- 090-A: Residuals (request/090-AB) +-- --------------------------------------------------------------------------- + +-- | Pearson residuals @(y - μ) / sqrt(V(μ))@. +glmPearsonResiduals + :: Family + -> LA.Vector Double -- ^ Observations @y@. + -> LA.Vector Double -- ^ Fitted means @μ@. + -> LA.Vector Double +glmPearsonResiduals family y mu = + VS.zipWith (\yi mui -> + let v = varOf family mui + in if v <= 0 then 0 else (yi - mui) / sqrt v) + y mu + +-- | Deviance residuals @sign(y - μ) · sqrt(d_i)@ where @d_i@ is the +-- per-observation contribution to the deviance @D = Σ d_i@. +glmDevianceResiduals + :: Family + -> LA.Vector Double + -> LA.Vector Double + -> LA.Vector Double +glmDevianceResiduals family y mu = + let perObs = pointwiseDeviance family y mu + in VS.zipWith3 (\yi mui di -> signum (yi - mui) * sqrt (max 0 di)) + y mu perObs + where + pointwiseDeviance Gaussian ys ms = + VS.zipWith (\yi mui -> let r = yi - mui in r * r) ys ms + pointwiseDeviance Binomial ys ms = + VS.zipWith + (\yi mui -> + let muC = max 1e-15 (min (1 - 1e-15) mui) + in 2 * ( xlogy yi (yi / muC) + + xlogy (1 - yi) ((1 - yi) / (1 - muC)) )) + ys ms + pointwiseDeviance Poisson ys ms = + VS.zipWith + (\yi mui -> + let muC = max 1e-15 mui + in 2 * (xlogy yi (yi / muC) - (yi - muC))) + ys ms + +-- --------------------------------------------------------------------------- +-- 090-B: Predict + SE (request/090-AB) +-- --------------------------------------------------------------------------- + +-- | Prediction with Wald confidence interval on the response (μ) scale. +data GlmPredictCI = GlmPredictCI + { gpMu :: !Double + , gpLo :: !Double + , gpHi :: !Double + } deriving (Show) + +-- | Linear-predictor prediction @η = xᵀβ@ with @SE = sqrt(xᵀ Σ x)@, +-- where @Σ@ is @(XᵀWX)⁻¹@ from 'fitGLMFull'. The intercept must be +-- present in @x@. +predictGlmEtaWithSE + :: LA.Vector Double + -> LA.Matrix Double + -> LA.Vector Double + -> (Double, Double) +predictGlmEtaWithSE beta sigma x = + let eta = x `LA.dot` beta + sigX = sigma LA.#> x + seEta = sqrt (max 0 (x `LA.dot` sigX)) + in (eta, seEta) + +-- | Wald CI on the response scale: build CI in @η@ space then transform +-- both endpoints through the inverse link. +predictGlmMuWithCI + :: LinkFn + -> Double + -> LA.Vector Double + -> LA.Matrix Double + -> LA.Vector Double + -> GlmPredictCI +predictGlmMuWithCI link level beta sigma x = + let (eta, se) = predictGlmEtaWithSE beta sigma x + z = waldZ level + (_, gInv, _) = linkFnOf link + mu = gInv eta + lo = gInv (eta - z * se) + hi = gInv (eta + z * se) + in GlmPredictCI { gpMu = mu, gpLo = min lo hi, gpHi = max lo hi } + +-- | Two-sided Wald z: @z = √2 · erf⁻¹(level)@ (so @level=0.95@ → +-- @1.95996…@). Uses Winitzki's rational approximation of @erf⁻¹@ +-- (~1e-3 accuracy) to keep @statistics@ out of this module. +waldZ :: Double -> Double +waldZ lvl + | lvl <= 0 || lvl >= 1 = + error "predictGlmMuWithCI: confidence level must lie in (0, 1)" + | otherwise = sqrt 2 * inverfApprox lvl + +inverfApprox :: Double -> Double +inverfApprox x = + let a = 0.147 + ln1 = log (1 - x * x) + term1 = 2 / (pi * a) + ln1 / 2 + in signum x * sqrt (sqrt (term1 * term1 - ln1 / a) - term1) + +-- --------------------------------------------------------------------------- +-- 多出力 GLM (列ごと IRLS) +-- --------------------------------------------------------------------------- + +-- | Multi-output GLM result. The same family and link function are +-- used for all @q@ output columns; IRLS is run column-wise. +data GLMFitMulti = GLMFitMulti + { gfmFamily :: Family + , gfmLinkFn :: LinkFn + , gfmFits :: [FitResult] -- ^ [日本語]: 列ごと FitResult [English]: Per-column FitResult + , gfmFisher :: [LA.Matrix Double] -- ^ [日本語]: 列ごと (XᵀWX)⁻¹ [English]: Per-column (XᵀWX)⁻¹ + , gfmBeta :: LA.Matrix Double -- ^ [日本語]: 係数行列 p × q [English]: Coefficient matrix, p × q + , gfmFitted :: LA.Matrix Double -- ^ [日本語]: 予測 n × q [English]: Fitted values, n × q + , gfmResid :: LA.Matrix Double -- ^ [日本語]: 残差 n × q [English]: Residuals, n × q + } deriving (Show) + +-- | Fit a multi-output GLM. @Y@ has shape @n × q@; family and link +-- function are shared across all columns. +fitGLMMulti :: Family -> LinkFn -> LA.Matrix Double -> LA.Matrix Double + -> GLMFitMulti +fitGLMMulti family linkFn x y = + let q = LA.cols y + perCol j = runIRLS family linkFn x (LA.flatten (y LA.¿ [j])) + pairs = [perCol j | j <- [0 .. q - 1]] + fits = map fst pairs + fishs = map snd pairs + betaM = LA.fromColumns [LA.flatten (coefficients f) | f <- fits] + fitM = LA.fromColumns [LA.flatten (fitted f) | f <- fits] + resM = LA.fromColumns [LA.flatten (residuals f) | f <- fits] + in GLMFitMulti family linkFn fits fishs betaM fitM resM diff --git a/src/Hanalyze/Model/GLMM.hs b/src/Hanalyze/Model/GLMM.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/GLMM.hs @@ -0,0 +1,823 @@ +-- | +-- Module : Hanalyze.Model.GLMM +-- Description : 線形/一般化線形混合効果モデル (random intercept/slope) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Linear and generalized linear mixed-effects models. +-- +-- 'fitLME' / 'fitGLMM' fit a __random-intercept__ mixed model: a single +-- scalar random effect per group (variance @σ²_u@, scalar BLUP @û_j@). +-- 'fitLME' is Gaussian via exact EM; 'fitGLMM' is non-Gaussian via Laplace. +-- +-- 'fitLMEGeneral' / 'fitGLMMGeneral' generalise to +-- __vector random effects__ (random intercept + slopes): a per-group design block +-- @Z_j@ with an @r×r@ covariance matrix @G@ and a vector BLUP @b̂_j@. With +-- @r = 1@ (intercept only) they reduce exactly to 'fitLME' / 'fitGLMM'. +-- +-- The multi-output variants ('fitLMEMulti', 'fitGLMMMulti') run the +-- random-intercept algorithm independently per response column. +module Hanalyze.Model.GLMM + ( GLMMResult (..) + , fitLME + , fitGLMM + , fitLMEDataFrame + , fitGLMMDataFrame + -- * General random effects (intercept + slope) + , GLMMResultRE (..) + , fitLMEGeneral + , fitGLMMGeneral + -- * Multi-output (per-column EM/Laplace; Family/Link shared) + , GLMMResultMulti (..) + , fitLMEMulti + , fitGLMMMulti + -- * Standard errors (request/100) + , glmmFixedSE + , glmmBLUPSE + -- * Group helper (shared with Formula.Mixed) + , buildGroups + ) where + +import qualified DataFrame.Internal.DataFrame as DXD +import Hanalyze.DataIO.Convert (getDoubleVec, getTextVec) +import Hanalyze.Model.Core (FitResult (..)) +import Hanalyze.Model.GLM (Family (..), LinkFn (..)) +import Hanalyze.Model.LM (multiPolyDesignMatrix) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA + +-- --------------------------------------------------------------------------- +-- Result type +-- --------------------------------------------------------------------------- + +-- | Fit result for a random-intercept mixed model. +-- +-- * LME (Gaussian): @y = Xβ + Zu + ε@, @u_j ~ N(0, σ²_u)@, +-- @ε_i ~ N(0, σ²)@. +-- * GLMM (non-Gaussian): @g(E[y|u]) = Xβ + Zu@, @u_j ~ N(0, σ²_u)@. +data GLMMResult = GLMMResult + { glmmFixed :: FitResult -- ^ Fixed-effect fit (β, conditional + -- fitted values, residuals, R²). + , glmmRandVar :: Double -- ^ Random-intercept variance @σ²_u@. + , glmmResidVar :: Double -- ^ Residual variance @σ²@ (1.0 for non-Gaussian families). + , glmmBLUPs :: V.Vector Double -- ^ Best linear unbiased predictions + -- @û_j@, aligned with 'glmmGroups'. + , glmmGroups :: V.Vector Text -- ^ Sorted unique group labels. + , glmmICC :: Double -- ^ Intraclass correlation (exact + -- for Gaussian; link-scale + -- approximation otherwise). + } deriving (Show) + +-- | Fit result for a __general__ mixed model with vector random effects +-- (random intercept + slopes). +-- +-- * LME (Gaussian): @y_j = X_j β + Z_j b_j + ε_j@, @b_j ~ N(0, G)@, +-- @ε_i ~ N(0, σ²)@, where @Z_j@ is the per-group random-effect design +-- block (@n_j × r@) and @G@ is the @r×r@ random-effect covariance. +-- * GLMM (non-Gaussian): @g(E[y|b]) = X_j β + Z_j b_j@, @b_j ~ N(0, G)@. +-- +-- With @r = 1@ and an intercept-only @Z@ this reduces exactly to the +-- scalar 'GLMMResult' (@reRandCov = [[σ²_u]]@, @reBLUPs@ a single column). +data GLMMResultRE = GLMMResultRE + { reFixed :: FitResult -- ^ Fixed-effect fit (β, conditional + -- fitted values, residuals, R²). + , reRandCov :: LA.Matrix Double -- ^ Random-effect covariance @G@ (@r×r@). + , reResidVar :: Double -- ^ Residual variance @σ²@ (1.0 for + -- non-Gaussian families). + , reBLUPs :: LA.Matrix Double -- ^ BLUPs @b̂@ as a @q×r@ matrix (row j = + -- group j, aligned with 'reGroups'). + , reGroups :: V.Vector Text -- ^ Sorted unique group labels (length q). + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- Group helpers (shared by LME and GLMM) +-- --------------------------------------------------------------------------- + +-- | Parse grouping vector into (sorted unique labels, per-obs index, per-group sizes). +buildGroups :: V.Vector Text -> (V.Vector Text, V.Vector Int, V.Vector Int) +buildGroups gvec = + -- Phase 11b (2026-05-14): Set-based dedup + sort, O(n log n) instead of + -- the O(n²) 'nub'. Important for grouping vectors with thousands of IDs. + let labels = V.fromList . Set.toAscList . Set.fromList . V.toList $ gvec + q = V.length labels + labelMap = Map.fromList (zip (V.toList labels) ([0..] :: [Int])) + idx = V.map (\g -> Map.findWithDefault 0 g labelMap) gvec + szMap = Map.fromListWith (+) (V.toList (V.map (\j -> (j, 1 :: Int)) idx)) + sizes = V.fromList [ Map.findWithDefault 0 j szMap | j <- [0..q-1] ] + in (labels, idx, sizes) + +-- | Group sums: (Zᵀv)_j = Σ_{i in group j} v_i +zGroupSums :: V.Vector Int -> V.Vector Double -> Int -> V.Vector Double +zGroupSums idx v q = + let smap = Map.fromListWith (+) (V.toList (V.zipWith (,) idx v)) + in V.fromList [ Map.findWithDefault 0.0 j smap | j <- [0..q-1] ] + +-- | Scatter random effects to observations: (Zu)_i = u_{g(i)} +zuScatter :: V.Vector Int -> V.Vector Double -> V.Vector Double +zuScatter idx u = V.map (u V.!) idx + +-- --------------------------------------------------------------------------- +-- EM algorithm for LME (Gaussian, exact) +-- --------------------------------------------------------------------------- + +maxEmIter :: Int +maxEmIter = 500 + +emTol :: Double +emTol = 1e-8 + +-- | Fit a random-intercept LME via EM (ML). +-- The E-step exploits the diagonal structure of the precision matrix for random intercepts: +-- P_jj = 1 / (1/σ²_u + n_j/σ²) +-- The M-step updates β by OLS on partial residuals; σ²_u and σ² analytically. +fitLME + :: LA.Matrix Double -- X (design matrix, must include intercept column) + -> LA.Vector Double -- y + -> V.Vector Int -- per-observation group index (0-based) + -> V.Vector Text -- sorted group labels (length q) + -> V.Vector Int -- per-group observation counts (length q) + -> GLMMResult +fitLME x y idx labels sizes = + let n = LA.rows x + q = V.length labels + + beta0 = LA.flatten (x LA.<\> LA.asColumn y) + yMean = LA.sumElements y / fromIntegral n + yDev = y - LA.konst yMean n + ssTot = yDev `LA.dot` yDev + varY = ssTot / fromIntegral n + su2_0 = varY / 2 + s2_0 = varY / 2 + + emStep (beta, su2, s2) = + let pDiag = V.fromList [ 1.0 / (1.0/su2 + fromIntegral (sizes V.! j) / s2) + | j <- [0..q-1] ] + r0 = V.fromList . LA.toList $ y - x LA.#> beta + ztR = zGroupSums idx r0 q + utilde = V.zipWith (\pj sj -> pj * sj / s2) pDiag ztR + zuU = LA.fromList . V.toList $ zuScatter idx utilde + betaNew = LA.flatten (x LA.<\> LA.asColumn (y - zuU)) + trP = V.sum pDiag + su2New = max 1e-8 $ (trP + V.sum (V.map (\u -> u*u) utilde)) / fromIntegral q + r1 = y - x LA.#> betaNew - zuU + trZPZt = V.sum (V.zipWith (\nj pj -> fromIntegral nj * pj) sizes pDiag) + s2New = max 1e-8 $ (r1 `LA.dot` r1 + trZPZt) / fromIntegral n + in (betaNew, su2New, s2New) + + converge 0 st = st + converge k st@(b, su, s) = + let st'@(b', su', s') = emStep st + in if LA.norm_2 (b' - b) < emTol + && abs (su' - su) < emTol + && abs (s' - s) < emTol + then st' + else converge (k-1) st' + + (betaF, su2F, s2F) = converge maxEmIter (beta0, su2_0, s2_0) + + pDiagF = V.fromList [ 1.0 / (1.0/su2F + fromIntegral (sizes V.! j) / s2F) + | j <- [0..q-1] ] + r0F = V.fromList . LA.toList $ y - x LA.#> betaF + ztRF = zGroupSums idx r0F q + uF = V.zipWith (\pj sj -> pj * sj / s2F) pDiagF ztRF + zuF = LA.fromList . V.toList $ zuScatter idx uF + fittedV = x LA.#> betaF + zuF + residV = y - fittedV + ssResF = residV `LA.dot` residV + r2 = if ssTot == 0 then 1.0 else 1.0 - ssResF / ssTot + icc = su2F / (su2F + s2F) + fitRes = FitResult (LA.asColumn betaF) + (LA.asColumn fittedV) + (LA.asColumn residV) + (LA.fromList [r2]) + + in GLMMResult fitRes su2F s2F uF labels icc + +-- --------------------------------------------------------------------------- +-- General random effects (intercept + slope): vector EM for Gaussian LME +-- --------------------------------------------------------------------------- + +-- | Fit a Gaussian LME with __vector__ random effects via EM (ML). +-- +-- Per group @j@ the model is @y_j = X_j β + Z_j b_j + ε_j@ with +-- @b_j ~ N(0, G)@ (@G@ is @r×r@) and @ε ~ N(0, σ²I)@. The @Z@ argument holds +-- the raw random-effect design columns (usually a sub-block of @X@, e.g. the +-- intercept column plus the slope column for @(1+x|g)@); rows align with @X@. +-- +-- EM (Laird-Ware), each step given @(β, G, σ²)@: +-- +-- * E-step (per group, @r×r@): @P_j = (G⁻¹ + Z_jᵀZ_j/σ²)⁻¹@, +-- @b̂_j = P_j Z_jᵀ r_j / σ²@ with @r_j = y_j − X_j β@. +-- * M-step: @β = (XᵀX)⁻¹Xᵀ(y − Zb̂)@, +-- @G = (1/q) Σ_j (P_j + b̂_j b̂_jᵀ)@, +-- @σ² = (1/n)[Σ‖y_j − X_j β − Z_j b̂_j‖² + Σ tr(Z_jᵀZ_j P_j)]@. +-- +-- With @r = 1@ and an intercept-only @Z@ this reproduces 'fitLME' exactly. +-- All linear algebra is hmatrix-native (no list-based fallbacks). +-- +-- TODO (Phase 48 follow-up): this is ML; a REML variant would correct the +-- variance estimates for the fixed-effect degrees of freedom. +fitLMEGeneral + :: LA.Matrix Double -- ^ X (fixed-effect design, must include intercept) + -> LA.Matrix Double -- ^ Z (random-effect design, @n × r@; rows align with X) + -> LA.Vector Double -- ^ y + -> V.Vector Int -- ^ per-observation group index (0-based) + -> V.Vector Text -- ^ sorted group labels (length q) + -> GLMMResultRE +fitLMEGeneral x z y idx labels = + let n = LA.rows x + q = V.length labels + r = LA.cols z + members = precompMembers idx q n + zRows = V.fromList (LA.toRows z) -- O(1) per-row access for scatter + + -- per-group X_j, Z_j, y_j (and Z_jᵀZ_j) precomputed once + groupBlk j = + let mem = members V.! j + xj = x LA.? mem + zj = z LA.? mem + yj = LA.fromList [ y `LA.atIndex` i | i <- mem ] + ztz = LA.tr zj LA.<> zj + in (xj, zj, yj, ztz) + blocks = V.fromList [ groupBlk j | j <- [0..q-1] ] + + -- initial values: OLS fixed fit, residual variance split intercept/resid + beta0 = LA.flatten (x LA.<\> LA.asColumn y) + yMean = LA.sumElements y / fromIntegral n + yDev = y - LA.konst yMean n + ssTot = yDev `LA.dot` yDev + varY = ssTot / fromIntegral n + g0 = LA.scale (varY / 2) (LA.ident r) + s20 = varY / 2 + + -- scatter (Zb̂)_i = Z_i · b̂_{g(i)} + scatterZb bhats = + LA.fromList [ (zRows V.! i) `LA.dot` (bhats V.! (idx V.! i)) | i <- [0..n-1] ] + + emStep (beta, gMat, s2) = + let gInv = LA.inv gMat + -- E-step: posterior cov P_j and mean b̂_j per group + pbs = V.map (\(xj, zj, yj, ztz) -> + let rj = yj - xj LA.#> beta + pj = LA.inv (gInv + LA.scale (1/s2) ztz) + bj = LA.scale (1/s2) (pj LA.#> (LA.tr zj LA.#> rj)) + in (pj, bj, ztz)) blocks + bhats = V.map (\(_, bj, _) -> bj) pbs + zb = scatterZb bhats + -- M-step β + betaN = LA.flatten (x LA.<\> LA.asColumn (y - zb)) + -- M-step G = (1/q) Σ (P_j + b̂_j b̂_jᵀ) + gAcc = V.foldl' (\acc (pj, bj, _) -> acc + pj + LA.outer bj bj) + (LA.konst 0 (r, r)) pbs + gN = LA.scale (1 / fromIntegral q) gAcc + -- M-step σ²: conditional residuals (using updated β) + trace term + zbN = scatterZb bhats + r1 = y - x LA.#> betaN - zbN + trc = V.sum (V.map (\(pj, _, ztz) -> LA.sumElements (ztz * pj)) pbs) + s2N = max 1e-10 $ (r1 `LA.dot` r1 + trc) / fromIntegral n + in (betaN, gN, s2N) + + converge 0 st = st + converge k st@(b, gM, s) = + let st'@(b', gM', s') = emStep st + in if LA.norm_2 (b' - b) < emTol + && LA.norm_2 (LA.flatten (gM' - gM)) < emTol + && abs (s' - s) < emTol + then st' + else converge (k-1) st' + + (betaF, gF, s2F) = converge maxEmIter (beta0, g0, s20) + + -- final BLUPs and conditional fit + gInvF = LA.inv gF + bhatsF = V.map (\(xj, zj, yj, ztz) -> + let rj = yj - xj LA.#> betaF + pj = LA.inv (gInvF + LA.scale (1/s2F) ztz) + in LA.scale (1/s2F) (pj LA.#> (LA.tr zj LA.#> rj))) blocks + zbF = scatterZb bhatsF + fittedV = x LA.#> betaF + zbF + residV = y - fittedV + ssResF = residV `LA.dot` residV + r2 = if ssTot == 0 then 1.0 else 1.0 - ssResF / ssTot + fitRes = FitResult (LA.asColumn betaF) + (LA.asColumn fittedV) + (LA.asColumn residV) + (LA.fromList [r2]) + blupMat = LA.fromRows (V.toList bhatsF) -- q×r + + in GLMMResultRE fitRes gF s2F blupMat labels + +-- --------------------------------------------------------------------------- +-- Laplace approximation for non-Gaussian GLMM +-- --------------------------------------------------------------------------- + +-- | Inverse link: μ = g⁻¹(η) +glmmInvLink :: LinkFn -> Double -> Double +glmmInvLink Identity η = η +glmmInvLink Log η = exp (min 500 η) +glmmInvLink Logit η = 1.0 / (1.0 + exp (-η)) +glmmInvLink Sqrt η = η * η + +-- | Forward link: η = g(μ) +glmmFwdLink :: LinkFn -> Double -> Double +glmmFwdLink Identity μ = μ +glmmFwdLink Log μ = log (max 1e-10 μ) +glmmFwdLink Logit μ = let c = max 1e-8 (min (1-1e-8) μ) in log (c / (1 - c)) +glmmFwdLink Sqrt μ = sqrt (max 0 μ) + +-- | Link derivative: g'(μ) +glmmLinkDeriv :: LinkFn -> Double -> Double +glmmLinkDeriv Identity _ = 1.0 +glmmLinkDeriv Log μ = 1.0 / max 1e-10 μ +glmmLinkDeriv Logit μ = let c = max 1e-8 (min (1-1e-8) μ) in 1.0 / (c * (1 - c)) +glmmLinkDeriv Sqrt μ = 0.5 / sqrt (max 1e-10 μ) + +-- | GLM variance function: V(μ) +glmmVarFn :: Family -> Double -> Double +glmmVarFn Gaussian _ = 1.0 +glmmVarFn Binomial μ = let c = max 1e-8 (min (1-1e-8) μ) in c * (1 - c) +glmmVarFn Poisson μ = max 1e-8 μ + +-- | Clamp μ to numerically safe range. +glmmClampMu :: Family -> Double -> Double +glmmClampMu Binomial = max 1e-8 . min (1 - 1e-8) +glmmClampMu Poisson = max 1e-8 +glmmClampMu Gaussian = id + +-- | IRLS weight: w_i = 1 / (g'(μ)² V(μ)) +glmmWeight :: Family -> LinkFn -> Double -> Double +glmmWeight family link μ = + let d = glmmLinkDeriv link μ + in max 1e-10 (1.0 / (d * d * glmmVarFn family μ)) + +-- | Score contribution: s_i = (y_i − μ_i) / (g'(μ_i) V(μ_i)) +glmmScore :: Family -> LinkFn -> Double -> Double -> Double +glmmScore family link y μ = + (y - μ) / (glmmLinkDeriv link μ * glmmVarFn family μ) + +-- | ICC approximation for non-Gaussian models (on the link scale). +-- Binomial/logit: π²/3 is the variance of the standard logistic distribution. +-- Poisson/log: 1 is the log-scale residual variance (approximation). +iccApprox :: Family -> Double -> Double +iccApprox Gaussian su2 = su2 / (su2 + 1.0) -- placeholder; LME gives exact ICC +iccApprox Binomial su2 = su2 / (su2 + pi*pi/3.0) +iccApprox Poisson su2 = su2 / (su2 + 1.0) + +-- | Precompute group member index lists (O(n) preprocessing). +precompMembers :: V.Vector Int -> Int -> Int -> V.Vector [Int] +precompMembers idx q n = + let mmap = Map.fromListWith (++) [ (idx V.! i, [i]) | i <- [0..n-1] ] + in V.fromList [ Map.findWithDefault [] j mmap | j <- [0..q-1] ] + +maxNRIter :: Int +maxNRIter = 50 + +nrTol :: Double +nrTol = 1e-10 + +-- | Inner Newton-Raphson: find conditional mode û_j for one group. +-- Maximises Q_j(u) = Σ log p(y_i | g⁻¹(ηᵢ + u)) − u²/(2σ²_u) +-- NR step: u ← u + grad/hess where +-- grad = Σ s_i − u/σ²_u, hess = Σ w_i + 1/σ²_u +nrOneGroup :: Family -> LinkFn -> Double -> [Double] -> [Double] -> Double -> Double +nrOneGroup family link su2 etaFixed ys = go maxNRIter + where + clamp = glmmClampMu family + gInv = glmmInvLink link + + go 0 u = u + go k u = + let mus = map (clamp . gInv . (+ u)) etaFixed + grad = sum (zipWith (glmmScore family link) ys mus) - u / su2 + hess = sum (map (glmmWeight family link) mus) + 1.0 / su2 + delta = grad / hess + u' = u + delta + in if abs delta < nrTol then u' else go (k-1) u' + +maxGLMMIter :: Int +maxGLMMIter = 200 + +glmmTol :: Double +glmmTol = 1e-7 + +-- | One outer GLMM iteration: +-- 1. NR(û) — find conditional modes given current β and σ²_u +-- 2. IRLS(β) — one IRLS step with random effects as offset +-- 3. EM(σ²_u) — Laplace-approximated posterior variance update +glmmStep + :: Family -> LinkFn + -> LA.Matrix Double -- X + -> LA.Vector Double -- y + -> V.Vector Int -- per-obs group index + -> V.Vector [Int] -- per-group member index lists (precomputed) + -> (LA.Vector Double, Double, V.Vector Double) + -> (LA.Vector Double, Double, V.Vector Double) +glmmStep family link x y idx members (beta, su2, u) = + let q = V.length u + clamp = glmmClampMu family + gInv = glmmInvLink link + gD = glmmLinkDeriv link + + xBeta = x LA.#> beta + etaFixedV = V.fromList (LA.toList xBeta) + yV = V.fromList (LA.toList y) + + -- 1. Inner NR: update û_j for each group j + uNew = V.fromList + [ nrOneGroup family link su2 + [ etaFixedV V.! i | i <- members V.! j ] + [ yV V.! i | i <- members V.! j ] + (u V.! j) + | j <- [0..q-1] ] + + -- 2. IRLS step for β (offset = Zû) + -- z_adj_i = (y_i − μ_i) g'(μ_i) + (Xβ)_i (WLS target without offset) + uScatter = LA.fromList . V.toList $ zuScatter idx uNew + etaFull = xBeta + uScatter + musV = V.map (clamp . gInv) (V.fromList (LA.toList etaFull)) + wsV = V.map (glmmWeight family link) musV + xBetaV = V.fromList (LA.toList xBeta) + zAdjV = V.zipWith3 (\yi mui xbi -> (yi - mui) * gD mui + xbi) yV musV xBetaV + sqrtW = LA.diag (LA.fromList . V.toList $ V.map sqrt wsV) + zAdj = LA.fromList (V.toList zAdjV) + betaNew = LA.flatten $ + (sqrtW LA.<> x) LA.<\> LA.asColumn (sqrtW LA.#> zAdj) + + -- 3. EM-like σ²_u update using Laplace-approximated posterior variance + -- ṽ_j = 1 / (Σ_{i∈j} w_i + 1/σ²_u) ≈ Var(u_j | y) + -- σ²_u_new = Σ_j (ṽ_j + û_j²) / q + etaNew = x LA.#> betaNew + uScatter + musNewV = V.map (clamp . gInv) (V.fromList (LA.toList etaNew)) + wsNewV = V.map (glmmWeight family link) musNewV + wSumsV = zGroupSums idx wsNewV q + su2New = max 1e-8 $ + V.sum (V.zipWith (\ws uj -> 1.0/(ws + 1.0/su2) + uj*uj) wSumsV uNew) + / fromIntegral q + + in (betaNew, su2New, uNew) + +-- | Fit a non-Gaussian GLMM (random intercept) via Laplace approximation. +-- For Gaussian/Identity, prefer fitLMEDataFrame which uses exact EM. +fitGLMM + :: Family -> LinkFn + -> LA.Matrix Double + -> LA.Vector Double + -> V.Vector Int -- per-obs group index + -> V.Vector Text -- sorted group labels + -> V.Vector Int -- per-group sizes (unused; kept for API symmetry with fitLME) + -> GLMMResult +fitGLMM family link x y idx labels _sizes = + let n = LA.rows x + p = LA.cols x + q = V.length labels + + members = precompMembers idx q n + + -- Initialise: β₀ = g(ȳ_safe), rest 0; û = 0; σ²_u = half total variance + yMean = LA.sumElements y / fromIntegral n + ySafe = case family of + Binomial -> max 1e-6 (min (1-1e-6) yMean) + Poisson -> max 1e-6 yMean + Gaussian -> yMean + beta0 = LA.fromList (glmmFwdLink link ySafe : replicate (p - 1) 0.0) + u0 = V.replicate q 0.0 + yDev = y - LA.konst yMean n + su2_0 = max 1e-4 ((yDev `LA.dot` yDev) / fromIntegral n / 2) + + norm2V v = sqrt $ V.foldl' (\acc d -> acc + d*d) 0.0 v + + converge 0 st = st + converge k st@(b, su, u') = + let st'@(b', su', u'') = glmmStep family link x y idx members st + in if LA.norm_2 (b' - b) < glmmTol + && abs (su' - su) < glmmTol + && norm2V (V.zipWith (-) u'' u') < glmmTol + then st' + else converge (k-1) st' + + (betaF, su2F, uF) = converge maxGLMMIter (beta0, su2_0, u0) + + -- Final conditional fitted values and statistics + uScatterF = LA.fromList . V.toList $ zuScatter idx uF + fittedLA = LA.cmap (glmmClampMu family . glmmInvLink link) (x LA.#> betaF + uScatterF) + residLA = y - fittedLA + ssTot = yDev `LA.dot` yDev + ssRes = residLA `LA.dot` residLA + r2 = if ssTot == 0 then 1.0 else 1.0 - ssRes / ssTot + icc = iccApprox family su2F + fitRes = FitResult (LA.asColumn betaF) + (LA.asColumn fittedLA) + (LA.asColumn residLA) + (LA.fromList [r2]) + + in GLMMResult fitRes su2F 1.0 uF labels icc + +-- --------------------------------------------------------------------------- +-- General random effects (intercept + slope): vector Laplace for GLMM +-- --------------------------------------------------------------------------- + +-- | Multivariate inner Newton-Raphson: find the conditional mode @b̂_j@ of one +-- group and return @(b̂_j, P_j)@ where @P_j = (Σ_i w_i z_i z_iᵀ + G⁻¹)⁻¹@ is +-- the Laplace posterior covariance at the mode. +-- +-- Maximises @Q_j(b) = Σ_i log p(y_i | g⁻¹(η_i + z_iᵀ b)) − ½ bᵀ G⁻¹ b@. +-- Newton step solves @H δ = grad@ with +-- @grad = Σ_i s_i z_i − G⁻¹ b@, @H = Σ_i w_i z_i z_iᵀ + G⁻¹@. +nrOneGroupVec + :: Family -> LinkFn + -> LA.Matrix Double -- ^ G⁻¹ (r×r) + -> [LA.Vector Double] -- ^ z_i rows for this group (each length r) + -> [Double] -- ^ etaFixed_i = (X_i β) + -> [Double] -- ^ y_i + -> LA.Vector Double -- ^ initial b (length r) + -> (LA.Vector Double, LA.Matrix Double) +nrOneGroupVec family link gInv zs etaFixed ys = go maxNRIter + where + clamp = glmmClampMu family + gInvL = glmmInvLink link + r = LA.rows gInv + + -- negative Hessian (= posterior precision) at b: Σ_i w_i z_i z_iᵀ + G⁻¹ + hessAt b = + let etas = zipWith (\z ef -> ef + z `LA.dot` b) zs etaFixed + mus = map (clamp . gInvL) etas + ws = map (glmmWeight family link) mus + in foldr (\(w, z) acc -> acc + LA.scale w (LA.outer z z)) gInv (zip ws zs) + + go 0 b = (b, LA.inv (hessAt b)) + go k b = + let etas = zipWith (\z ef -> ef + z `LA.dot` b) zs etaFixed + mus = map (clamp . gInvL) etas + ss = zipWith (glmmScore family link) ys mus + ws = map (glmmWeight family link) mus + grad = foldr (\(s, z) acc -> acc + LA.scale s z) (LA.konst 0 r) (zip ss zs) + - (gInv LA.#> b) + hess = foldr (\(w, z) acc -> acc + LA.scale w (LA.outer z z)) gInv (zip ws zs) + delta = LA.flatten (hess LA.<\> LA.asColumn grad) + b' = b + delta + in if LA.norm_2 delta < nrTol then (b', LA.inv hess) else go (k-1) b' + +-- | Fit a non-Gaussian GLMM with __vector__ random effects via Laplace +-- approximation. Per group @j@: @g(E[y|b]) = X_j β + Z_j b_j@, +-- @b_j ~ N(0, G)@ (@G@ is @r×r@). Outer loop: multivariate NR for the modes +-- @b̂_j@ (with Laplace posterior cov @P_j@), one IRLS step for @β@ (random +-- effects as offset), and an EM update @G = (1/q) Σ_j (P_j + b̂_j b̂_jᵀ)@. +-- +-- With @r = 1@ and an intercept-only @Z@ this matches 'fitGLMM'. Supports the +-- same families/links as 'fitGLMM' (Binomial/Logit, Poisson/Log). +fitGLMMGeneral + :: Family -> LinkFn + -> LA.Matrix Double -- ^ X (fixed-effect design, must include intercept) + -> LA.Matrix Double -- ^ Z (random-effect design, @n × r@; rows align with X) + -> LA.Vector Double -- ^ y + -> V.Vector Int -- ^ per-observation group index (0-based) + -> V.Vector Text -- ^ sorted group labels (length q) + -> GLMMResultRE +fitGLMMGeneral family link x z y idx labels = + let n = LA.rows x + p = LA.cols x + q = V.length labels + r = LA.cols z + members = precompMembers idx q n + zRows = V.fromList (LA.toRows z) + yV = V.fromList (LA.toList y) + + groupZs = V.fromList [ [ zRows V.! i | i <- members V.! j ] | j <- [0..q-1] ] + groupYs = V.fromList [ [ yV V.! i | i <- members V.! j ] | j <- [0..q-1] ] + + clamp = glmmClampMu family + gInvL = glmmInvLink link + gD = glmmLinkDeriv link + + yMean = LA.sumElements y / fromIntegral n + ySafe = case family of + Binomial -> max 1e-6 (min (1-1e-6) yMean) + Poisson -> max 1e-6 yMean + Gaussian -> yMean + beta0 = LA.fromList (glmmFwdLink link ySafe : replicate (p - 1) 0.0) + b0 = V.replicate q (LA.konst 0 r) + yDev = y - LA.konst yMean n + su2_0 = max 1e-4 ((yDev `LA.dot` yDev) / fromIntegral n / 2) + g0 = LA.scale su2_0 (LA.ident r) + + scatterZb bs = + LA.fromList [ (zRows V.! i) `LA.dot` (bs V.! (idx V.! i)) | i <- [0..n-1] ] + + step (beta, gMat, bs) = + let gInv = LA.inv gMat + xBeta = x LA.#> beta + etaFixedV = V.fromList (LA.toList xBeta) + results = V.fromList + [ nrOneGroupVec family link gInv (groupZs V.! j) + [ etaFixedV V.! i | i <- members V.! j ] + (groupYs V.! j) + (bs V.! j) + | j <- [0..q-1] ] + bsNew = V.map fst results + pjs = V.map snd results + -- IRLS β with random offset Zb̂ held fixed + zb = scatterZb bsNew + etaF = xBeta + zb + musV = V.map (clamp . gInvL) (V.fromList (LA.toList etaF)) + wsV = V.map (glmmWeight family link) musV + xBetaV = V.fromList (LA.toList xBeta) + zAdjV = V.zipWith3 (\yi mui xbi -> (yi - mui) * gD mui + xbi) yV musV xBetaV + sqrtW = LA.diag (LA.fromList . V.toList $ V.map sqrt wsV) + zAdj = LA.fromList (V.toList zAdjV) + betaN = LA.flatten $ (sqrtW LA.<> x) LA.<\> LA.asColumn (sqrtW LA.#> zAdj) + -- EM update G = (1/q) Σ (P_j + b̂_j b̂_jᵀ) + gAcc = V.foldl' (\acc (pj, bj) -> acc + pj + LA.outer bj bj) + (LA.konst 0 (r, r)) (V.zip pjs bsNew) + gN = LA.scale (1 / fromIntegral q) gAcc + in (betaN, gN, bsNew) + + bsDiff a b = V.sum (V.zipWith (\u v -> LA.norm_2 (u - v)) a b) + converge 0 st = st + converge k st@(beta, gM, bs) = + let st'@(beta', gM', bs') = step st + in if LA.norm_2 (beta' - beta) < glmmTol + && LA.norm_2 (LA.flatten (gM' - gM)) < glmmTol + && bsDiff bs' bs < glmmTol + then st' + else converge (k-1) st' + + (betaF, gF, bsF) = converge maxGLMMIter (beta0, g0, b0) + + zbF = scatterZb bsF + fittedV = LA.cmap (clamp . gInvL) (x LA.#> betaF + zbF) + residV = y - fittedV + ssTot = yDev `LA.dot` yDev + ssRes = residV `LA.dot` residV + r2 = if ssTot == 0 then 1.0 else 1.0 - ssRes / ssTot + fitRes = FitResult (LA.asColumn betaF) + (LA.asColumn fittedV) + (LA.asColumn residV) + (LA.fromList [r2]) + blupMat = LA.fromRows (V.toList bsF) + + in GLMMResultRE fitRes gF 1.0 blupMat labels + +-- --------------------------------------------------------------------------- +-- DataFrame-level API +-- --------------------------------------------------------------------------- + +-- | Fit a random-intercept LME from a DataFrame (Gaussian, exact EM). +fitLMEDataFrame + :: [(Text, Int)] -- ^ x column specs + -> Text -- ^ grouping column (text/categorical) + -> Text -- ^ response column + -> DXD.DataFrame + -> Maybe GLMMResult +fitLMEDataFrame colDegs groupCol yCol df = do + xVecs <- mapM (\(col, _) -> getDoubleVec col df) colDegs + yVec <- getDoubleVec yCol df + gVec <- getTextVec groupCol df + let degrees = map snd colDegs + dm = multiPolyDesignMatrix (zip xVecs degrees) + y = LA.fromList (V.toList yVec) + (labels, idx, sizes) = buildGroups gVec + return (fitLME dm y idx labels sizes) + +-- | Fit a non-Gaussian GLMM from a DataFrame (Laplace approximation). +-- Supports Binomial/Logit and Poisson/Log; for Gaussian/Identity prefer fitLMEDataFrame. +fitGLMMDataFrame + :: Family -> LinkFn + -> [(Text, Int)] -- ^ x column specs + -> Text -- ^ grouping column (text/categorical) + -> Text -- ^ response column + -> DXD.DataFrame + -> Maybe GLMMResult +fitGLMMDataFrame family link colDegs groupCol yCol df = do + xVecs <- mapM (\(col, _) -> getDoubleVec col df) colDegs + yVec <- getDoubleVec yCol df + gVec <- getTextVec groupCol df + let degrees = map snd colDegs + dm = multiPolyDesignMatrix (zip xVecs degrees) + y = LA.fromList (V.toList yVec) + (labels, idx, sizes) = buildGroups gVec + return (fitGLMM family link dm y idx labels sizes) + +-- --------------------------------------------------------------------------- +-- Multi-output GLMM (per-column EM/Laplace; grouping shared across columns) +-- --------------------------------------------------------------------------- + +-- | Multi-output GLMM/LME fit result. +data GLMMResultMulti = GLMMResultMulti + { glmmFits :: [GLMMResult] -- ^ Per-column fit results. + , glmmGrpsM :: V.Vector Text -- ^ Sorted group labels (shared across columns). + } deriving (Show) + +-- | Multi-output Gaussian LME. @Y@ has shape @n × q@; 'fitLME' is run +-- independently on each column. +fitLMEMulti :: LA.Matrix Double -> LA.Matrix Double + -> V.Vector Int -> V.Vector Text -> V.Vector Int + -> GLMMResultMulti +fitLMEMulti x y idx labels sizes = + let q = LA.cols y + yCol j = LA.flatten (y LA.¿ [j]) + fits = [fitLME x (yCol j) idx labels sizes | j <- [0 .. q - 1]] + in GLMMResultMulti fits labels + +-- | Multi-output non-Gaussian GLMM. @Y@ has shape @n × q@; 'fitGLMM' is +-- run independently on each column. +fitGLMMMulti :: Family -> LinkFn + -> LA.Matrix Double -> LA.Matrix Double + -> V.Vector Int -> V.Vector Text -> V.Vector Int + -> GLMMResultMulti +fitGLMMMulti family link x y idx labels sizes = + let q = LA.cols y + yCol j = LA.flatten (y LA.¿ [j]) + fits = [fitGLMM family link x (yCol j) idx labels sizes + | j <- [0 .. q - 1]] + in GLMMResultMulti fits labels + +-- --------------------------------------------------------------------------- +-- Standard errors (request/100) +-- --------------------------------------------------------------------------- + +-- | Standard errors of the fixed-effect coefficients @β@. +-- +-- For LME (Gaussian, Identity link) this is /exact/: it inverts +-- @Xᵀ V⁻¹ X@ where @V = σ² I + σ²_u Z Zᵀ@ is the marginal covariance +-- under the random-intercept model. The block structure of @V@ is +-- exploited so this stays @O(n p² + q p²)@ instead of forming a +-- dense @n × n@ matrix: +-- +-- > Xᵀ V⁻¹ X = (1/σ²) Xᵀ X − Σ_j (α_j / σ²) s_j s_jᵀ +-- > α_j = σ²_u / (σ² + n_j σ²_u) +-- > s_j = Σ_{i ∈ group j} x_i (column sums of X within group j) +-- +-- For non-Gaussian families this returns a Gaussian-approximation +-- (treats @σ² = 1@) — adequate for /relative/ ordering of coefficients +-- but absolute values are off; matching lme4-style non-Gaussian SE +-- requires the converged IRLS weights which are not currently exposed +-- by 'fitGLMM'. +glmmFixedSE + :: LA.Matrix Double -- ^ Design matrix @X@ (n × p, intercept inclusive). + -> V.Vector Int -- ^ Group index per observation (length n; same as + -- the @idx@ produced by @buildGroups@). + -> GLMMResult + -> LA.Vector Double -- ^ Length @p@; coefficient SEs in column order. +glmmFixedSE x groupIdx res = + let n = LA.rows x + p = LA.cols x + sig2u = glmmRandVar res + sig2RAW = glmmResidVar res + sig2 = if sig2RAW > 0 then sig2RAW else 1.0 -- non-Gaussian fallback + q = V.length (glmmGroups res) + + -- per-group n_j + nj :: Map.Map Int Int + nj = V.foldl' (\acc j -> Map.insertWith (+) j 1 acc) Map.empty groupIdx + + -- per-group column sum s_j = Σ_{i ∈ group j} x_i (length p) + groupSum :: Map.Map Int (LA.Vector Double) + groupSum = + V.foldl' (\acc i -> + let j = groupIdx V.! i + xi = LA.flatten (x LA.? [i]) + in Map.insertWith (+) j xi acc) + Map.empty + (V.enumFromN 0 n) + + xtxFull = LA.tr x LA.<> x + + correction :: LA.Matrix Double + correction = + Map.foldlWithKey' + (\acc j s -> + let nj_j = Map.findWithDefault 0 j nj + alpha = sig2u / (sig2 + fromIntegral nj_j * sig2u) + in acc + LA.scale alpha (LA.outer s s)) + (LA.konst 0 (p, p)) + groupSum + + xvtinvX = LA.scale (1 / sig2) (xtxFull - correction) + cov = LA.inv xvtinvX + _ = q -- kept to make q's role explicit in the docstring + in LA.fromList [ sqrt (max 0 (LA.atIndex cov (i, i))) | i <- [0 .. p - 1] ] + +-- | Posterior standard errors of the BLUPs @û_j@ under the +-- random-intercept model: +-- +-- > Var(u_j | data) = (1 / σ²_u + n_j / σ²)⁻¹ +-- +-- (For non-Gaussian families this uses @σ² = 1@; same caveat as +-- 'glmmFixedSE'.) Length matches 'glmmGroups'. +glmmBLUPSE :: V.Vector Int -> GLMMResult -> V.Vector Double +glmmBLUPSE groupIdx res = + let q = V.length (glmmGroups res) + sig2u = glmmRandVar res + sig2RAW = glmmResidVar res + sig2 = if sig2RAW > 0 then sig2RAW else 1.0 + njMap = V.foldl' (\acc j -> Map.insertWith (+) j 1 acc) + Map.empty groupIdx + ng j = Map.findWithDefault 0 j njMap + in V.generate q (\j -> + let nDouble = fromIntegral (ng j) :: Double + varInv = 1.0 / sig2u + nDouble / sig2 + in sqrt (1.0 / varInv)) diff --git a/src/Hanalyze/Model/GP.hs b/src/Hanalyze/Model/GP.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/GP.hs @@ -0,0 +1,938 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.GP +-- Description : ガウス過程回帰 (Gaussian-process regression) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: ガウス過程回帰 (Gaussian-process regression)。 +-- +-- カーネルを選び、 訓練データに fit して、 任意のテスト点での事後予測を得る。 +-- ハイパーパラメータは対数周辺尤度の最大化で自動調整できる。 +-- +-- @ +-- import Hanalyze.Model.GP +-- +-- -- 訓練データ +-- let xs = [0, 0.5 .. 5] +-- ys = map (\x -> sin x + 0.1 * noise) xs +-- +-- -- ハイパーパラメータをデータから初期化し最適化 +-- let p0 = initParamsFromData xs ys +-- opt = optimizeGP RBF xs ys p0 +-- res = fitGP (GPModel RBF opt) xs ys testXs +-- +-- -- gpMean res, gpLower res, gpUpper res で結果を取得 +-- @ +-- +-- [English]: Gaussian-process regression. +-- +-- Pick a kernel, fit it to training data and obtain the posterior +-- predictive at arbitrary test points. Hyperparameters can be tuned +-- automatically by maximizing the log marginal likelihood. +-- +-- @ +-- import Hanalyze.Model.GP +-- +-- -- training data +-- let xs = [0, 0.5 .. 5] +-- ys = map (\x -> sin x + 0.1 * noise) xs +-- +-- -- initialize the hyperparameters from the data and optimize them +-- let p0 = initParamsFromData xs ys +-- opt = optimizeGP RBF xs ys p0 +-- res = fitGP (GPModel RBF opt) xs ys testXs +-- +-- -- retrieve the results via gpMean res, gpLower res, gpUpper res +-- @ +module Hanalyze.Model.GP + ( -- * カーネル型 (re-export from "Hanalyze.Model.Kernel") + Kernel (..) + , kernelName + , KernelParams (..) + , defaultKernelParams + -- * Hyperparameters + , GPParams (..) + , defaultGPParams + , gpKernelParams + , initParamsFromData + , initParamsFromDataMV + -- * Model and result + , GPModel (..) + , GPResult (..) + -- * Kernel computation + , kernelFn + , kEvalMV + , buildKernelMatrix + -- * Inference + , logMarginalLikelihood + , fitGP + , fitGPMulti + , optimizeGP + , gramLOOCV + , autoCVHyperGP + , autoCVHyperGPMV + -- * Data for interactive prediction + , GPPredData (..) + , gpPredData + -- * Multi-input (primary API; X is @n × p@, Y is @n × q@) + , GPResultMV (..) + , buildKernelMatrixMV + , noiseKernelMV + , logMarginalLikelihoodMV + , fitGPMV + , fitGPMVMulti + , optimizeGPMV + , optimizeGPMVCached + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Optim.LBFGS as LBFGS +import qualified Hanalyze.Optim.Common as OC +import qualified Hanalyze.Stat.KernelDist as KD +import qualified Hanalyze.Stat.Cholesky as Chol +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import Control.Monad.ST (runST) +import System.IO.Unsafe (unsafePerformIO) +-- 共有カーネル語彙は 'Model.Kernel' (Phase 75.18 で分離)。 GP は後方互換のため +-- 'Kernel'/'KernelParams'/評価関数を re-export する。 +import Hanalyze.Model.Kernel + ( Kernel (..), kernelName, KernelParams (..), defaultKernelParams + , kernelFn, buildKernelMatrix, applyKernel, kernelOfParams + , ardScaleXY, buildKernelMatrixMV, kEvalMV ) + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- +-- +-- NB: 'Kernel' / 'kernelName' / 'KernelParams' と評価関数群は Phase 75.18 で +-- 'Hanalyze.Model.Kernel' へ分離。 GP は後方互換のため re-export する +-- (上の import 参照)。 + +-- | [日本語]: GP hyperparameters (= 'KernelParams' + 観測ノイズ σ_n²)。 +-- +-- カーネル系フィールド (ℓ / σ_f² / period / ARD) は 'gpKernelParams' で +-- 'KernelParams' へ射影でき、 カーネル評価関数 ('kernelFn' / 'kEvalMV' / +-- 'buildKernelMatrix' 等) はその 'KernelParams' を取る。 +-- +-- [English]: GP hyperparameters (= 'KernelParams' + the observation noise +-- σ_n²). +-- +-- The kernel-related fields (ℓ \/ σ_f² \/ period \/ ARD) can be projected onto +-- a 'KernelParams' with 'gpKernelParams', and the kernel evaluation functions +-- ('kernelFn' \/ 'kEvalMV' \/ 'buildKernelMatrix' etc.) take that +-- 'KernelParams'. +data GPParams = GPParams + { gpLengthScale :: Double + -- ^ Isotropic length scale @ℓ@; larger means smoother. Used unless + -- 'gpLengthScales' is 'Just' (= ARD), in which case the per-dim + -- vector overrides this for multi-input kernel evaluation. + , gpSignalVar :: Double + -- ^ Signal variance @σ_f²@; the variability of the function values. + , gpNoiseVar :: Double + -- ^ Observation noise variance @σ_n²@; near 0 interpolates, larger + -- smooths. + , gpPeriod :: Double + -- ^ Period @p@ (only used by the @Periodic@ kernel). + , gpLengthScales :: Maybe (LA.Vector Double) + -- ^ Per-dim length scales for ARD (Automatic Relevance + -- Determination). When 'Just' v, the multi-input kernel uses + -- @D_ARD[i,j] = Σ_d (X[i,d] − X'[j,d])² / ℓ_d²@ instead of the + -- isotropic distance / ℓ². Has no effect on the 1D 'kernelFn' / + -- 'fitGP' path. 'Nothing' = isotropic (default). + } deriving (Show) + +-- | Default hyperparameters: @ℓ = σ_f² = p = 1@, @σ_n² = 0.1@. +defaultGPParams :: GPParams +defaultGPParams = GPParams 1.0 1.0 0.1 1.0 Nothing + +-- | [日本語]: 'GPParams' のカーネル系ハイパーパラメータを 'KernelParams' へ +-- 射影する (観測ノイズ σ_n² は落とす)。 カーネル評価関数へ +-- 渡す際に使う。 +-- +-- [English]: Project the kernel hyperparameters of a 'GPParams' onto a +-- 'KernelParams' (drops the observation noise σ_n²). Used when passing them +-- to the kernel evaluation functions. +gpKernelParams :: GPParams -> KernelParams +gpKernelParams p = KernelParams + { kpLengthScale = gpLengthScale p + , kpSignalVar = gpSignalVar p + , kpPeriod = gpPeriod p + , kpLengthScales = gpLengthScales p + } + +-- | Build a sensible initial 'GPParams' from data statistics, suitable +-- as a starting point for optimization. +initParamsFromData :: [Double] -> [Double] -> GPParams +initParamsFromData xs ys = GPParams + { gpLengthScale = max 0.01 ((xMax - xMin) / 4) + , gpSignalVar = max 0.01 yVar + , gpNoiseVar = max 1e-4 (yVar * 0.05) + , gpPeriod = max 0.01 (xMax - xMin) + , gpLengthScales = Nothing + } + where + xMin = minimum xs + xMax = maximum xs + yMean = sum ys / fromIntegral (length ys) + yVar = sum (map (\y -> (y - yMean) ^ (2 :: Int)) ys) / fromIntegral (length ys) + +-- | Multi-input variant of 'initParamsFromData'. Computes the length +-- scale from the /average/ per-dimension range of @X@ rather than +-- collapsing the @n × p@ matrix into a flat list (which the previous +-- @MultiGP@ call site did via @concat (toLists trainX)@ — yielding +-- nonsensical @xMin/xMax@ statistics, a poor length-scale init, and +-- in turn slow LBFGS convergence). +initParamsFromDataMV :: LA.Matrix Double -> LA.Vector Double -> GPParams +initParamsFromDataMV trainX y = + let p = LA.cols trainX + cols = LA.toColumns trainX -- p column vectors + ranges = [ LA.maxElement c - LA.minElement c | c <- cols ] + avgRng = if null ranges then 1.0 + else sum ranges / fromIntegral (length ranges) + ys = LA.toList y + yMean = LA.sumElements y / fromIntegral (LA.size y) + yVar = sum (map (\v -> (v - yMean) ^ (2 :: Int)) ys) + / fromIntegral (LA.size y) + _ = p + in GPParams + { gpLengthScale = max 0.01 (avgRng / 4) + , gpSignalVar = max 0.01 yVar + , gpNoiseVar = max 1e-4 (yVar * 0.05) + , gpPeriod = max 0.01 avgRng + , gpLengthScales = Nothing + } + +-- | A GP model: a kernel paired with its hyperparameters. +data GPModel = GPModel + { gpKernel :: Kernel + , gpParams :: GPParams + } deriving (Show) + +-- | GP posterior-predictive result. +data GPResult = GPResult + { gpTestX :: [Double] -- ^ Test points @x_*@. + , gpMean :: [Double] -- ^ Posterior mean @μ(x_*)@. + , gpVar :: [Double] -- ^ Posterior variance @σ²(x_*)@. + , gpLower :: [Double] -- ^ @mean − 2σ@ (≈ 95 % credible-interval lower). + , gpUpper :: [Double] -- ^ @mean + 2σ@ (≈ 95 % credible-interval upper). + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- Inference +-- --------------------------------------------------------------------------- + +-- ノイズ付きカーネル行列 K_y = K(X,X) + σ_n² I を構築する（最小ジッター付き）。 +noiseKernel :: Kernel -> GPParams -> [Double] -> LA.Matrix Double +noiseKernel ker p xs = + let n = length xs + k = buildKernelMatrix ker (gpKernelParams p) xs xs + jitter = max (gpNoiseVar p) 1e-6 + in k `LA.add` LA.scale jitter (LA.ident n) + +-- | Log marginal likelihood @log p(y | X, θ)@. Used as the objective +-- when optimizing GP hyperparameters. +-- +-- @log p = −½ yᵀ Ky⁻¹ y − ½ log|Ky| − n/2 log(2π)@. +-- +-- When the parameters are pathological (e.g. very small length scales) +-- and Cholesky fails, returns the penalty value @-10³⁰@ so the +-- optimizer steers away from that region. +logMarginalLikelihood :: [Double] -> [Double] -> Kernel -> GPParams -> Double +logMarginalLikelihood trainX trainY ker params = + let n = length trainX + ky = noiseKernel ker params trainX + y = LA.fromList trainY + mR = case Chol.cholFactor ky of + Just r -> Just (r, ky) + Nothing -> + -- jitter を追加して再試行 + let kyJ = ky `LA.add` LA.scale 1e-4 (LA.ident n) + in case Chol.cholFactor kyJ of + Just r -> Just (r, kyJ) + Nothing -> Nothing + in case mR of + Nothing -> -1e30 + Just (r, _kyUsed) -> + let logDet = 2 * sum (map log (LA.toList (LA.takeDiag r))) + -- Reuse the already-computed Cholesky factor (avoids a + -- second factorization in the inner GP HP loop). + alpha = LA.flatten + (Chol.cholSolveWithFactor r (LA.asColumn y)) + dataFit = LA.dot y alpha + in -0.5 * dataFit - 0.5 * logDet - fromIntegral n / 2 * log (2 * pi) + +-- | [日本語]: @testX@ における単出力 GP の事後予測。 +-- 多出力 'fitGPMulti' に y を 1 列行列化して委譲、列 0 を取り出す。 +-- +-- 事後平均: μ_* = K_*ᵀ Ky⁻¹ y +-- 事後分散: σ²_i = k(x*_i, x*_i) − K_*[i] Ky⁻¹ K_*[i]ᵀ +-- +-- [English]: Single-output GP posterior prediction at @testX@. +-- Delegates to the multi-output 'fitGPMulti' by turning y into a +-- single-column matrix, and extracts column 0. +-- +-- Posterior mean: μ_* = K_*ᵀ Ky⁻¹ y +-- Posterior variance: σ²_i = k(x*_i, x*_i) − K_*[i] Ky⁻¹ K_*[i]ᵀ +fitGP :: GPModel -> [Double] -> [Double] -> [Double] -> GPResult +fitGP model trainX trainY testX = + let yMat = LA.asColumn (LA.fromList trainY) + (meanMat, varList) = fitGPMulti model trainX yMat testX + mu = LA.toList (LA.flatten (meanMat LA.¿ [0])) + stdList = map sqrt varList + in GPResult + { gpTestX = testX + , gpMean = mu + , gpVar = varList + , gpLower = zipWith (\m s -> m - 2 * s) mu stdList + , gpUpper = zipWith (\m s -> m + 2 * s) mu stdList + } + +-- | [日本語]: 多出力 GP の事後予測。 @Y@ は @n × q@ (出力タスクごとに 1 列) で、 +-- 単一のカーネルと +-- ハイパーパラメータを共有する (Cholesky / Ky⁻¹ も共有)。 +-- +-- 戻り値: (事後平均行列 m × q, 事後分散ベクトル 長さ m)。 +-- 分散は y に依らないため q 出力で共通。 +-- +-- [English]: Multi-output GP posterior prediction. @Y@ has shape @n × q@ (one +-- column per output task) and shares a single kernel and one set of +-- hyperparameters (the Cholesky factor \/ Ky⁻¹ are shared as well). +-- +-- Returns: (the m × q posterior mean matrix, the length-m posterior variance +-- vector). The variance does not depend on y, so it is common to all q +-- outputs. +fitGPMulti :: GPModel -> [Double] -> LA.Matrix Double -> [Double] + -> (LA.Matrix Double, [Double]) +fitGPMulti model trainX trainY testX = + let ker = gpKernel model + params = gpParams model + ky = noiseKernel ker params trainX + kStar = buildKernelMatrix ker (gpKernelParams params) testX trainX -- (m × n) + -- α = Ky⁻¹ Y via SPD Cholesky (n × q) + alpha = Chol.cholSolveJitter ky trainY + meanMt = kStar LA.<> alpha -- (m × q) + -- v = Ky⁻¹ K_*ᵀ via the same Cholesky factor (n × m). + -- Then var_i = k(x*_i, x*_i) − K_*[i,:] · v[:,i]. + v = Chol.cholSolveJitter ky (LA.tr kStar) + diagKss = [kernelFn ker (gpKernelParams params) x x | x <- testX] + -- F1: vectorise diag(kStar · v). + kStarDotV = LA.toList (KD.diagAB kStar v) + varList = zipWith (\d kv -> max 0 (d - kv)) diagKss kStarDotV + in (meanMt, varList) + +-- --------------------------------------------------------------------------- +-- Hyperparameter optimisation +-- --------------------------------------------------------------------------- + +-- | Optimize GP hyperparameters by maximizing the log marginal likelihood. +-- +-- Operates in log-space on @(ℓ, σ_f², σ_n²)@ using L-BFGS (numerical +-- central-difference gradients, no user-provided gradient required). +-- +-- Typically 5-10× faster than the older @Hanalyze.Optim.GradAscent@ + numeric +-- gradient path, and less sensitive to the initial point. +-- Internally uses 'System.IO.Unsafe.unsafePerformIO', but L-BFGS is +-- deterministic so the result is referentially transparent. +optimizeGP :: Kernel -> [Double] -> [Double] -> GPParams -> GPParams +optimizeGP ker trainX trainY p0 = + let u0 = [log (gpLengthScale p0), log (gpSignalVar p0), log (gpNoiseVar p0)] + -- L-BFGS は最小化なので、log-mlik を最大化したいときは Maximize 指定 + cfg = LBFGS.defaultLBFGSConfig + { LBFGS.lbDir = OC.Maximize + , LBFGS.lbStop = OC.defaultStopCriteria + { OC.stMaxIter = 200, OC.stTolFun = 1e-8 } + } + result = unsafePerformIO $ LBFGS.runLBFGSNumeric cfg obj u0 + uOpt = OC.orBest result + in p0 + { gpLengthScale = exp (uOpt !! 0) + , gpSignalVar = exp (uOpt !! 1) + , gpNoiseVar = exp (uOpt !! 2) + } + where + toParams u = p0 + { gpLengthScale = exp (u !! 0) + , gpSignalVar = exp (u !! 1) + , gpNoiseVar = exp (u !! 2) + } + obj u = logMarginalLikelihood trainX trainY ker (toParams u) + +-- --------------------------------------------------------------------------- +-- LOOCV hyperparameter selection (exact / Gram path) — Phase 70.5 項目 E +-- --------------------------------------------------------------------------- + +-- | Leave-one-out CV (PRESS) for exact kernel-ridge / GP-mean prediction +-- from a /noiseless/ Gram matrix @K@. Closed form +-- @PRESS = (1/n) Σ ((yᵢ − ŷᵢ)/(1 − Hᵢᵢ))²@ with @H = K (K + λI)⁻¹@ and +-- @ŷ = H y@ (no @n@-fold refit). This is the Gram-space analogue of +-- 'Hanalyze.Model.RFF.loocvFromPhi' (identical PRESS algebra, but +-- in the @n@-dim Gram space instead of the @D@-dim RFF feature space). +-- KRR ≡ GP posterior mean with @λ = σ_n²@, so the same routine selects +-- @λ@ for both the @Ridge@ and @Gp@ quadrants of the unified @gp@ spec. +gramLOOCV :: LA.Matrix Double -- ^ Noiseless Gram matrix @K@ (@n × n@). + -> LA.Vector Double -- ^ Targets @y@ (length @n@). + -> Double -- ^ Ridge penalty @λ@ (= @σ_n²@). + -> Double +gramLOOCV k y lam = + let n = LA.rows k + regK = addToDiag lam k -- K + λI (SPD) + -- H = K (K+λI)⁻¹ = (regK⁻¹ K)ᵀ (K, regK symmetric). Solve once. + h = LA.tr (regK LA.<\> k) + yhat = h LA.#> y + hDiag = LA.takeDiag h + oneMinusH = LA.cmap (\hh -> max 1e-12 (1 - hh)) hDiag + resid = y - yhat + ratios = zipWith (/) (LA.toList resid) (LA.toList oneMinusH) + in sum [ r * r | r <- ratios ] / fromIntegral (max 1 n) + +-- | Pick GP/KRR hyperparameters by minimizing leave-one-out CV (PRESS) +-- over a log-spaced @(ℓ, λ)@ grid. @σ_f@ is fixed at @std(y)@ (mirroring +-- 'Hanalyze.Model.RFF.gridSearchLOOCVRBFMV', where @σ_f@ and @λ@ +-- are degenerate and @λ@ absorbs the scale). Returns 'GPParams' with the +-- selected @ℓ*@, @σ_f² = std(y)²@ and @σ_n² = λ*@ (KRR ≡ GP mean with +-- @λ = σ_n²@). Used by the @AutoCV@ @HyperStrategy@ for the exact +-- (@Gp@/@Ridge@) quadrants. +autoCVHyperGP :: Kernel -> [Double] -> [Double] -> GPParams +autoCVHyperGP ker xs ys = + let p0 = initParamsFromData xs ys + yStd = max 1e-9 (sqrt (varOfList ys)) + ell0 = gpLengthScale p0 + ellGrid = logSpaceList (ell0 * 0.1) (ell0 * 10) 10 + lamGrid = logSpaceList (yStd * 1e-6) (yStd * 10) 20 + yV = LA.fromList ys + score ell lam = + let pk = p0 { gpLengthScale = ell, gpSignalVar = yStd * yStd } + k = buildKernelMatrix ker (gpKernelParams pk) xs xs + in gramLOOCV k yV lam + cands = [ (ell, lam, score ell lam) | ell <- ellGrid, lam <- lamGrid ] + (bEll, bLam, _) = + foldr1 (\a@(_,_,sa) b@(_,_,sb) -> if sa <= sb then a else b) cands + in p0 { gpLengthScale = bEll, gpSignalVar = yStd * yStd, gpNoiseVar = bLam } + +-- | Multi-input analogue of 'autoCVHyperGP'. Same log-spaced @(ℓ, λ)@ +-- Gram-LOOCV search but builds the kernel from an @n × p@ training +-- matrix via 'buildKernelMatrixMV' (isotropic; ℓ shared across inputs). +autoCVHyperGPMV :: Kernel -> LA.Matrix Double -> LA.Vector Double -> GPParams +autoCVHyperGPMV ker trainX y = + let p0 = initParamsFromDataMV trainX y + yStd = max 1e-9 (sqrt (varOfList (LA.toList y))) + ell0 = gpLengthScale p0 + ellGrid = logSpaceList (ell0 * 0.1) (ell0 * 10) 8 + lamGrid = logSpaceList (yStd * 1e-6) (yStd * 10) 16 + score ell lam = + let pk = p0 { gpLengthScale = ell, gpSignalVar = yStd * yStd } + k = buildKernelMatrixMV ker (gpKernelParams pk) trainX trainX + in gramLOOCV k y lam + cands = [ (ell, lam, score ell lam) | ell <- ellGrid, lam <- lamGrid ] + (bEll, bLam, _) = + foldr1 (\a@(_,_,sa) b@(_,_,sb) -> if sa <= sb then a else b) cands + in p0 { gpLengthScale = bEll, gpSignalVar = yStd * yStd, gpNoiseVar = bLam } + +-- | Population variance of a list (LOOCV σ_f init). +varOfList :: [Double] -> Double +varOfList zs = + let n = fromIntegral (length zs) + m = sum zs / n + in if n <= 0 then 0 else sum [ (z - m) ^ (2 :: Int) | z <- zs ] / n + +-- | @n@ points log-spaced in @[lo, hi]@ (inclusive). @lo,hi > 0@. +logSpaceList :: Double -> Double -> Int -> [Double] +logSpaceList lo hi n + | n <= 1 = [lo] + | otherwise = [ exp (logLo + (logHi - logLo) * fromIntegral i / fromIntegral (n - 1)) + | i <- [0 .. n - 1] ] + where logLo = log lo + logHi = log hi + +-- --------------------------------------------------------------------------- +-- Interactive prediction data (for Hanalyze.Viz.GPReport) +-- --------------------------------------------------------------------------- + +-- | [日本語]: JavaScript 対話予測に必要な内部データ。 +-- Ky⁻¹ と α = Ky⁻¹ y を事前に計算して保持する。 +-- +-- [English]: The internal data required for interactive prediction in +-- JavaScript. Pre-computes and stores Ky⁻¹ and α = Ky⁻¹ y. +data GPPredData = GPPredData + { pdTrainX :: [Double] -- ^ [日本語]: 訓練点 X [English]: The training points X. + , pdAlpha :: [Double] -- ^ [日本語]: α = Ky⁻¹ y (長さ n) [English]: α = Ky⁻¹ y (length n). + , pdKyInv :: [[Double]] -- ^ [日本語]: Ky⁻¹ を行リストで表現 (n × n) [English]: Ky⁻¹ represented as a list of rows (n × n). + } deriving (Show) + +-- | [日本語]: 訓練データから GPPredData を計算する。 +-- [English]: Computes a GPPredData from the training data. +gpPredData :: GPModel -> [Double] -> [Double] -> GPPredData +gpPredData model trainX trainY = + let ker = gpKernel model + params = gpParams model + n = length trainX + k = buildKernelMatrix ker (gpKernelParams params) trainX trainX + jitter = max (gpNoiseVar params) 1e-6 + ky = addToDiag jitter k + -- SPD: solve via Cholesky rather than 'LA.inv'. Equivalent to + -- 'kyInv = Ky⁻¹' (used to project the JS-side prediction + -- formula); the explicit inverse is fine here because @n@ is + -- typically small for the interactive viewer and the inverse is + -- consumed downstream. Cholesky is more accurate than LU. + kyInv = Chol.cholSolveJitter ky (LA.ident n) + alpha = LA.toList (kyInv LA.#> LA.fromList trainY) + in GPPredData trainX alpha (map LA.toList (LA.toRows kyInv)) + +-- --------------------------------------------------------------------------- +-- Multi-input (multivariate X) API +-- +-- The kernel of every supported family ('RBF', 'Matern52', 'Periodic') is a +-- function of the Euclidean distance @r = ‖x − x'‖@, so the multi-input +-- version reduces to building the @n × n@ pairwise distance matrix once +-- (via 'Hanalyze.Stat.KernelDist.pairwiseSqDist') and applying the kernel function +-- element-wise via 'LA.cmap'. +-- +-- A single shared length scale @ℓ@ is used across every input dimension. +-- For axis-specific length scales, scale columns of @X@ by @1 / ℓ_d@ +-- before calling these functions. +-- --------------------------------------------------------------------------- + +-- | Multi-input GP posterior result. Mirrors 'GPResult' but stores the +-- @m × p@ test-point matrix instead of a 1D list. +data GPResultMV = GPResultMV + { gpmvTestX :: LA.Matrix Double -- ^ Test points (@m × p@). + , gpmvMean :: LA.Vector Double -- ^ Posterior mean (length @m@). + , gpmvVar :: LA.Vector Double -- ^ Posterior variance (length @m@). + , gpmvLower :: LA.Vector Double -- ^ @mean − 2σ@. + , gpmvUpper :: LA.Vector Double -- ^ @mean + 2σ@. + } deriving (Show) + +-- | Add a scalar @c@ to the diagonal of a square matrix in one pass. +-- +-- Replaces the @M + c·I@ pattern (which allocates a fresh @n × n@ +-- identity scaled by @c@). With @runST@ + flat-index update, this +-- is one allocation of the result and an in-place fill — significant +-- in 'noiseKernelMV', which is on every log-marginal-likelihood +-- evaluation. +addToDiag :: Double -> LA.Matrix Double -> LA.Matrix Double +addToDiag c m = + let n = LA.rows m + flat = LA.flatten m + out = runST $ do + v <- VSM.new (n * n) + let go i + | i >= n * n = pure () + | otherwise = do + VSM.unsafeWrite v i (flat `VS.unsafeIndex` i) + go (i + 1) + go 0 + let goDiag i + | i >= n = pure () + | otherwise = do + let !idx = i * n + i + d <- VSM.unsafeRead v idx + VSM.unsafeWrite v idx (d + c) + goDiag (i + 1) + goDiag 0 + VS.unsafeFreeze v + in LA.reshape n out + +-- | Build the noise-augmented kernel matrix @K + jitter·I@ in a single +-- pass over the squared-distance matrix. +-- +-- Replaces the previous @applyKernel d2 |> addToDiag jitter@ pipeline, +-- which allocated /two/ @n × n@ Storable vectors per evaluation: one +-- for the kernel-applied output, one for the diagonal-augmented copy. +-- This fused version emits a single @n²@ allocation and writes each +-- cell exactly once, branching on @i == j@ to fold the jitter into the +-- diagonal write. A @noiseKernelMVCached@ call profile fraction was +-- 35.3% of @optimizeGPMV@; halving its allocation footprint translates +-- to a measurable wall-time reduction in the LBFGS hot loop. +mkNoiseKernelFromD2 + :: Kernel -> KernelParams -> Double -> LA.Matrix Double -> LA.Matrix Double +mkNoiseKernelFromD2 ker p jitter d2 = + let n = LA.rows d2 + flatD = LA.flatten d2 + kFn = kernelOfParams ker p + out = runST $ do + v <- VSM.new (n * n) + let go i j + | i >= n = pure () + | j >= n = go (i + 1) 0 + | otherwise = do + let !idx = i * n + j + !s = flatD `VS.unsafeIndex` idx + !kij = kFn s + !val = if i == j then kij + jitter else kij + VSM.unsafeWrite v idx val + go i (j + 1) + go 0 0 + VS.unsafeFreeze v + in LA.reshape n out + +-- | Multi-input @K + σ_n² I@. Uses the fused @mkNoiseKernelFromD2@ so +-- that the kernel evaluation and jitter-on-diagonal write happen in a +-- single @n²@ pass rather than two. +noiseKernelMV :: Kernel -> GPParams -> LA.Matrix Double -> LA.Matrix Double +noiseKernelMV ker p x = + let (xs, _, p') = ardScaleXY ker (gpKernelParams p) x x + d2 = KD.pairwiseSqDist xs + jitter = max (gpNoiseVar p) 1e-6 + in mkNoiseKernelFromD2 ker p' jitter d2 + +-- | Like 'noiseKernelMV' but reuses a pre-computed pairwise squared +-- distance matrix @D = pairwiseSqDist trainX@. Valid only when no ARD +-- scaling is applied (isotropic kernel) — the kernel is then a +-- function of @D@ alone, independent of length scale. Single-pass +-- (kernel + jitter fused). +noiseKernelMVCached + :: Kernel -> GPParams -> LA.Matrix Double -> LA.Matrix Double +noiseKernelMVCached ker p d2 = + let jitter = max (gpNoiseVar p) 1e-6 + in mkNoiseKernelFromD2 ker (gpKernelParams p) jitter d2 + +-- | D-cached version of 'logMarginalLikelihoodMV' — accepts a +-- pre-computed @D = pairwiseSqDist trainX@ instead of recomputing it +-- each call. Used by 'optimizeGPMV' in the isotropic case where @D@ +-- is independent of the optimization variables. +logMarginalLikelihoodMVCached + :: LA.Matrix Double -- ^ Pre-computed @D@ (@n × n@). + -> LA.Vector Double -- ^ Training @y@ (length @n@). + -> Kernel -> GPParams -> Double +logMarginalLikelihoodMVCached d2 y ker params = + let n = LA.rows d2 + ky = noiseKernelMVCached ker params d2 + mR = case Chol.cholFactor ky of + Just r -> Just (r, ky) + Nothing -> + let kyJ = addToDiag 1e-4 ky + in case Chol.cholFactor kyJ of + Just r -> Just (r, kyJ) + Nothing -> Nothing + in case mR of + Nothing -> -1e30 + Just (r, _kyUsed) -> + let logDet = 2 * VS.sum (VS.map log (LA.takeDiag r)) + alpha = LA.flatten + (Chol.cholSolveWithFactor r (LA.asColumn y)) + dataFit = LA.dot y alpha + in -0.5 * dataFit - 0.5 * logDet + - fromIntegral n / 2 * log (2 * pi) + +-- | Multi-input log marginal likelihood. +logMarginalLikelihoodMV + :: LA.Matrix Double -- ^ Training @X@ (@n × p@). + -> LA.Vector Double -- ^ Training @y@ (length @n@). + -> Kernel -> GPParams -> Double +logMarginalLikelihoodMV trainX y ker params = + let n = LA.rows trainX + ky = noiseKernelMV ker params trainX + mR = case Chol.cholFactor ky of + Just r -> Just (r, ky) + Nothing -> + let kyJ = addToDiag 1e-4 ky + in case Chol.cholFactor kyJ of + Just r -> Just (r, kyJ) + Nothing -> Nothing + in case mR of + Nothing -> -1e30 + Just (r, _kyUsed) -> + let logDet = 2 * VS.sum (VS.map log (LA.takeDiag r)) + alpha = LA.flatten + (Chol.cholSolveWithFactor r (LA.asColumn y)) + dataFit = LA.dot y alpha + in -0.5 * dataFit - 0.5 * logDet + - fromIntegral n / 2 * log (2 * pi) + +-- | Multi-input single-output GP posterior prediction. +fitGPMV + :: GPModel + -> LA.Matrix Double -- ^ Training @X@ (@n × p@). + -> LA.Vector Double -- ^ Training @y@ (length @n@). + -> LA.Matrix Double -- ^ Test @X_*@ (@m × p@). + -> GPResultMV +fitGPMV model trainX y testX = + let yMat = LA.asColumn y + (meanMat, varVec) = fitGPMVMulti model trainX yMat testX + mu = LA.flatten (meanMat LA.¿ [0]) + stdVec = LA.cmap sqrt varVec + in GPResultMV + { gpmvTestX = testX + , gpmvMean = mu + , gpmvVar = varVec + , gpmvLower = mu - LA.scale 2 stdVec + , gpmvUpper = mu + LA.scale 2 stdVec + } + +-- | Multi-input multi-output GP posterior prediction. @Y@ has shape +-- @n × q@ (one column per output task). The variance does not depend on +-- @y@, so a single length-@m@ vector is shared by every output. +fitGPMVMulti + :: GPModel + -> LA.Matrix Double -- ^ Training @X@ (@n × p@). + -> LA.Matrix Double -- ^ Training @Y@ (@n × q@). + -> LA.Matrix Double -- ^ Test @X_*@ (@m × p@). + -> (LA.Matrix Double, LA.Vector Double) +fitGPMVMulti model trainX trainY testX = + let ker = gpKernel model + params = gpParams model + ky = noiseKernelMV ker params trainX + kStar = buildKernelMatrixMV ker (gpKernelParams params) testX trainX -- m × n + -- α = Ky⁻¹ Y via SPD Cholesky (reused for v below by passing both + -- right-hand sides through the same factorization). + rhs = trainY LA.||| LA.tr kStar -- n × (q + m) + sol = Chol.cholSolveJitter ky rhs -- n × (q + m) + q = LA.cols trainY + alpha = sol LA.?? (LA.All, LA.Take q) -- n × q + v = sol LA.?? (LA.All, LA.Drop q) -- n × m + meanMt = kStar LA.<> alpha -- m × q + sf = gpSignalVar params + diagKss = LA.konst sf (LA.rows testX) -- k(x*, x*) = σ_f² + -- F1: diagonal of (kStar · v) without forming the m×m product. + -- 'KD.diagAB' = element-wise (kStar ⊙ vᵀ) · ones. + varVec = LA.cmap (max 0) (diagKss - KD.diagAB kStar v) + -- Tested split-solve (alpha and v separately via cholFactor + + -- cholSolveWithFactor, avoiding the concat allocation) but the + -- saving is dwarfed by the @O(n² · (q+m))@ triangular-solve + -- work itself. Keep the simpler concatenated form. + in (meanMt, varVec) + +-- | Multi-input GP hyperparameter optimization. Mirrors 'optimizeGP' but +-- accepts a multi-input training matrix. +-- +-- When @gpLengthScales p0 = Just v@, optimizes per-dim length scales +-- (ARD): the parameter vector becomes +-- @[log ℓ_1, …, log ℓ_p, log σ_f², log σ_n²]@. Otherwise optimises the +-- isotropic @[log ℓ, log σ_f², log σ_n²]@. +optimizeGPMV + :: Kernel -> LA.Matrix Double -> LA.Vector Double -> GPParams -> GPParams +optimizeGPMV ker trainX y p0 = + optimizeGPMVCached ker Nothing trainX y p0 + +-- | Like 'optimizeGPMV' but accepts a /pre-computed/ pairwise squared +-- distance matrix. Used by 'Hanalyze.Model.MultiGP' to share @D = pairwiseSqDist +-- trainX@ across all @q@ outputs (the same @trainX@ is used for every +-- output, so re-computing @D@ inside each per-output optimisation is +-- pure waste). For ARD the cache is ignored (the kernel depends on +-- per-feature length scales and @D@ varies with the optimisation +-- variables). +optimizeGPMVCached + :: Kernel + -> Maybe (LA.Matrix Double) -- ^ Pre-computed @D = pairwiseSqDist trainX@. + -> LA.Matrix Double + -> LA.Vector Double + -> GPParams + -> GPParams +optimizeGPMVCached ker mPreD trainX y p0 + -- Analytic-gradient fast path for the isotropic non-ARD case under + -- the RBF kernel. Replaces the central-difference numeric gradient + -- (which costs 6 × the Cholesky-based log-marginal-likelihood + -- evaluation per LBFGS step) with a closed-form formula that re-uses + -- a single explicit @Ky⁻¹@ for all three parameters. See + -- 'optimizeRBFAnalytic'. + | ker == RBF && not (isARDOf p0 (LA.cols trainX)) = + optimizeRBFAnalytic mPreD trainX y p0 + | otherwise = + let cfg = LBFGS.defaultLBFGSConfig + { LBFGS.lbDir = OC.Maximize + , LBFGS.lbStop = OC.defaultStopCriteria + { OC.stMaxIter = 200, OC.stTolFun = 1e-8 } + } + u0v = LA.fromList initU + -- Vector-native objective: takes the LBFGS state Vector directly. + -- Saves the list conversion that 'runLBFGSNumeric' / 'runLBFGSWith' + -- do on every objective and gradient call. + objV uv = obj (LA.toList uv) + -- Central-difference gradient on the Vector representation. We + -- experimented with forward differences (half the evaluations + -- per gradient) but L-BFGS needed more iterations to converge + -- under the looser O(h) error, giving a net wall-time regression. + h = 1e-5 :: Double + gradV uv = + let n = LA.size uv + in LA.fromList + [ let plus = uv VS.// [(i, uv VS.! i + h)] + minus = uv VS.// [(i, uv VS.! i - h)] + in (objV plus - objV minus) / (2 * h) + | i <- [0 .. n - 1] ] + result = unsafePerformIO $ LBFGS.runLBFGSWithV cfg objV gradV u0v + uOpt = OC.orBest result + in toParams uOpt + where + p = LA.cols trainX + isARD = case gpLengthScales p0 of + Just v | LA.size v == p && p > 0 -> True + _ -> False + -- Pre-compute the pairwise squared distance matrix for the + -- isotropic case. The kernel of every supported family is a + -- function of @D@ alone (length scale enters via @applyKernel@), + -- so the LBFGS log-marginal-likelihood loop reuses @D@ instead of + -- recomputing 'pairwiseSqDist' on every evaluation. Profile + -- (see bench/results/) showed 'pairwiseSqDist' was 26.8% of + -- 'optimizeGPMV' wall time before this cache. + -- For ARD, the per-dim length scales rescale columns of @X@, so + -- @D@ depends on the optimization variables and cannot be cached. + cachedD :: Maybe (LA.Matrix Double) + cachedD + | isARD = Nothing + | otherwise = case mPreD of + Just d -> Just d -- caller-supplied + Nothing -> Just (KD.pairwiseSqDist trainX) -- compute now + initU + | isARD = case gpLengthScales p0 of + Just v -> + let ls = LA.toList v + in map log ls + ++ [log (gpSignalVar p0), log (gpNoiseVar p0)] + Nothing -> + -- Cannot happen: isARD already requires Just. + [ log (gpLengthScale p0) + , log (gpSignalVar p0) + , log (gpNoiseVar p0) ] + | otherwise = [ log (gpLengthScale p0) + , log (gpSignalVar p0) + , log (gpNoiseVar p0) ] + toParams u + | isARD = + let lsV = LA.fromList (map exp (take p u)) + in p0 + { gpLengthScales = Just lsV + , gpSignalVar = exp (u !! p) + , gpNoiseVar = exp (u !! (p + 1)) + } + | otherwise = p0 + { gpLengthScale = exp (u !! 0) + , gpSignalVar = exp (u !! 1) + , gpNoiseVar = exp (u !! 2) + } + -- For ARD, add a weak log-normal prior on each ℓ_d centred at the + -- initial value (Gaussian in log-space, σ_prior = 1.5 ≈ ratio 4.5). + -- Without it, log marginal likelihood with only 30 BO points and + -- many ℓ_d's tends to drive ℓ_d to extreme values (over-fit). The + -- prior is informative enough to keep ℓ_d within ~one order of + -- magnitude of the init while still letting individual dims relax. + obj u + | isARD = + case gpLengthScales p0 of + Just v0 -> + let lml = logMarginalLikelihoodMV trainX y ker (toParams u) + logL0 = map log (LA.toList v0) + sig2 = 1.5 * 1.5 + prior = sum [ -0.5 * (l - l0) ^ (2 :: Int) / sig2 + | (l, l0) <- zip (take p u) logL0 ] + in lml + prior + Nothing -> + -- Cannot happen by isARD construction; fall back to + -- the un-prior-ed ARD likelihood. + logMarginalLikelihoodMV trainX y ker (toParams u) + | otherwise = + case cachedD of + Just d2 -> logMarginalLikelihoodMVCached d2 y ker (toParams u) + Nothing -> logMarginalLikelihoodMV trainX y ker (toParams u) + +-- | Whether the given 'GPParams' / input dimension imply ARD. +isARDOf :: GPParams -> Int -> Bool +isARDOf p0 p = case gpLengthScales p0 of + Just v | LA.size v == p && p > 0 -> True + _ -> False + +-- | Analytic-gradient L-BFGS for the isotropic RBF GP marginal +-- likelihood. Replaces the central-difference numeric gradient (6 extra +-- evaluations per LBFGS step) with a closed-form formula that re-uses +-- a single explicit @Ky⁻¹@ across all three parameters +-- @[log ℓ, log σ_f², log σ_n²]@. +-- +-- For RBF, @∂Ky/∂(log θ_k)@ is: +-- +-- * @log ℓ@: @K ⊙ (D / ℓ²)@ +-- * @log σ_f²@: @K@ (linear in @σ_f²@) +-- * @log σ_n²@: @σ_n² · I@ +-- +-- and the gradient contribution is +-- @½ tr((α αᵀ − Ky⁻¹) ∂Ky/∂(log θ_k))@. We form @Ky⁻¹@ once per LBFGS +-- step (@O(n³)@ via @cholSolveJitter ky I@) and assemble each +-- coordinate of the gradient via element-wise sums (@O(n²)@). Total +-- work per step: roughly @n³/2 + O(n²)@ vs the numeric path's +-- @≈ n³ + O(n²)@, plus L-BFGS converges in fewer iterations when fed +-- exact gradients. +optimizeRBFAnalytic + :: Maybe (LA.Matrix Double) -> LA.Matrix Double -> LA.Vector Double + -> GPParams -> GPParams +optimizeRBFAnalytic mPreD trainX y p0 = + let n = LA.rows trainX + d2 = case mPreD of + Just d -> d + Nothing -> KD.pairwiseSqDist trainX + cfg = LBFGS.defaultLBFGSConfig + { LBFGS.lbDir = OC.Maximize + , LBFGS.lbStop = OC.defaultStopCriteria + { OC.stMaxIter = 200 + , OC.stTolFun = 1e-8 } + } + u0v = LA.fromList + [ log (gpLengthScale p0) + , log (gpSignalVar p0) + , log (gpNoiseVar p0) ] + + -- Build the kernel matrix and noise-augmented matrix from + -- params (re-using the precomputed @D@). + buildK uv = + let !ll = exp (uv VS.! 0) -- length scale ℓ + !sf2 = exp (uv VS.! 1) -- σ_f² + !sn2 = exp (uv VS.! 2) -- σ_n² + !inv2L2 = 1 / (2 * ll * ll) + !kMat = LA.cmap (\s -> sf2 * exp (- s * inv2L2)) d2 + !ky = addToDiag sn2 kMat + in (ll, sf2, sn2, kMat, ky) + + -- Objective only (used by L-BFGS line search). + objV uv = + let (_, _, _, _, ky) = buildK uv + in case Chol.cholFactor ky of + Nothing -> -1e30 + Just r -> + let logDet = 2 * VS.sum (VS.map log (LA.takeDiag r)) + alpha = LA.flatten + (Chol.cholSolveWithFactor r (LA.asColumn y)) + dataFit = LA.dot y alpha + in -0.5 * dataFit - 0.5 * logDet + - fromIntegral n / 2 * log (2 * pi) + + -- Analytic gradient. + gradV uv = + let (ll, _sf2, sn2, kMat, ky) = buildK uv + in case Chol.cholFactor ky of + Nothing -> LA.fromList [0, 0, 0] -- bail out at singular Ky + Just r -> + let alpha = LA.flatten + (Chol.cholSolveWithFactor r (LA.asColumn y)) + -- Explicit @Ky⁻¹@ (n × n). 'cholSolveWithFactor' + -- against the n×n identity is an @O(n³)@ pair of + -- triangular solves but only happens once per LBFGS + -- gradient call. + kyInv = Chol.cholSolveWithFactor r (LA.ident n) + -- Q = α αᵀ − Ky⁻¹. We don't materialise this + -- separately; instead each gradient component is + -- computed as @α^T V α − tr(Ky⁻¹ V)@ inline. + -- + -- ∂Ky/∂(log ℓ) = K ⊙ (D / ℓ²) + !invL2 = 1 / (ll * ll) + !vL = LA.scale invL2 (kMat * d2) + !aT_vL = LA.dot alpha (vL LA.#> alpha) + !tr_KyInv_vL = LA.sumElements (kyInv * vL) + !gLogL = 0.5 * (aT_vL - tr_KyInv_vL) + -- ∂Ky/∂(log σ_f²) = K + !aT_K = LA.dot alpha (kMat LA.#> alpha) + !tr_KyInv_K = LA.sumElements (kyInv * kMat) + !gLogSf = 0.5 * (aT_K - tr_KyInv_K) + -- ∂Ky/∂(log σ_n²) = σ_n² I + !aT_a = LA.dot alpha alpha + !tr_KyInv = LA.sumElements (LA.takeDiag kyInv) + !gLogSn = 0.5 * sn2 * (aT_a - tr_KyInv) + in LA.fromList [gLogL, gLogSf, gLogSn] + + result = unsafePerformIO $ LBFGS.runLBFGSWithV cfg objV gradV u0v + uOpt = OC.orBest result + in p0 + { gpLengthScale = exp (uOpt !! 0) + , gpSignalVar = exp (uOpt !! 1) + , gpNoiseVar = exp (uOpt !! 2) + } diff --git a/src/Hanalyze/Model/GPRobust.hs b/src/Hanalyze/Model/GPRobust.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/GPRobust.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.GPRobust +-- Description : ロバストガウス過程 (重尾観測尤度: Student-t / Cauchy) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: ロバスト GP (重尾観測尤度)。 +-- +-- 閉形式の Gaussian 尤度 GP は外れ値に敏感である。 本モジュールは観測尤度を +-- Student-t または Cauchy に置き換え、 IRLS 形式のスキーム (variational EM / +-- Laplace の安定な変種) を反復して MAP 推定を得る。 +-- +-- アルゴリズム: +-- +-- 1. @f ← 0@ (GP 事前平均)。 +-- 2. 収束するまで反復: +-- a. 残差 @r = y − f@。 +-- b. 観測ごとの重みを計算: +-- - Student-t @(ν, σ)@: @w_i = (ν + 1) / (ν + (r_i/σ)²)@。 +-- - Cauchy @(γ)@: @w_i = 2 / (1 + (r_i/γ)²)@。 +-- c. 各点の有効ノイズ分散 σ²/w_i (heteroscedastic) +-- d. f ← K (K + σ² W⁻¹)⁻¹ y +-- 3. 予測点 x* で: +-- mean = k_*ᵀ (K + σ² W⁻¹)⁻¹ y +-- var = k(x*,x*) − k_*ᵀ (K + σ² W⁻¹)⁻¹ k_* +-- +-- カーネル関連 ('Kernel', 'GPParams', 'kernelFn') は 'Hanalyze.Model.GP' を再利用。 +-- +-- [English]: Robust GP (heavy-tailed observation likelihoods). +-- +-- A closed-form Gaussian-likelihood GP is sensitive to outliers. This +-- module replaces the observation likelihood with Student-t or Cauchy and +-- iterates an IRLS-style scheme (a stable variant of variational EM / +-- Laplace) to obtain a MAP estimate. +-- +-- Algorithm: +-- +-- 1. @f ← 0@ (GP prior mean). +-- 2. Iterate until convergence: +-- a. Residual @r = y − f@. +-- b. Compute the per-observation weight: +-- - Student-t @(ν, σ)@: @w_i = (ν + 1) / (ν + (r_i/σ)²)@. +-- - Cauchy @(γ)@: @w_i = 2 / (1 + (r_i/γ)²)@. +-- c. Each point's effective noise variance σ²/w_i (heteroscedastic). +-- d. f ← K (K + σ² W⁻¹)⁻¹ y. +-- 3. At a test point x*: +-- mean = k_*ᵀ (K + σ² W⁻¹)⁻¹ y +-- var = k(x*,x*) − k_*ᵀ (K + σ² W⁻¹)⁻¹ k_* +-- +-- Kernel-related items ('Kernel', 'GPParams', 'kernelFn') are reused from +-- 'Hanalyze.Model.GP'. +module Hanalyze.Model.GPRobust + ( -- * 観測尤度 + RobustLikelihood (..) + , -- * フィット結果と推論 + RobustGPFit (..) + , fitGPRobust + , predictGPRobust + -- * Multi-output (primary API) + , RobustGPFitMulti (..) + , fitGPRobustMulti + , predictGPRobustMulti + -- * Multi-input (primary API; X is @n × p@, Y is @n × q@) + , RobustGPFitMV (..) + , fitGPRobustMV + , predictGPRobustMV + , RobustGPFitMVMulti (..) + , fitGPRobustMVMulti + , predictGPRobustMVMulti + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Stat.Cholesky as Chol +import qualified Hanalyze.Stat.KernelDist as KD +import Hanalyze.Model.GP + ( Kernel + , GPParams (..) + , gpKernelParams + , kernelFn + , buildKernelMatrix + , buildKernelMatrixMV + ) + +-- --------------------------------------------------------------------------- +-- 観測尤度 +-- --------------------------------------------------------------------------- + +-- | Heavy-tailed observation likelihood. +data RobustLikelihood + = RGaussian Double -- ^ Gaussian @(σ_n)@ — equivalent to a + -- standard GP (sanity-check baseline). + | RStudentT Double Double -- ^ Student-t @(df=ν, scale=σ)@; smaller + -- @ν@ means heavier tails. + | RCauchy Double -- ^ Cauchy @(scale=γ)@, equivalent to + -- @StudentT(1, γ)@. + deriving (Show, Eq) + +-- | IRLS weight @w(r)@ for residual @r@. The effective noise variance is +-- @σ_eff² / w_i@ at each step. +likelihoodWeight :: RobustLikelihood -> Double -> Double +likelihoodWeight (RGaussian _) _ = 1.0 +likelihoodWeight (RStudentT nu sigma) r = + let z = r / sigma + in (nu + 1) / (nu + z * z) +likelihoodWeight (RCauchy gamma) r = + let z = r / gamma + in 2 / (1 + z * z) + +-- | Reference variance @σ_eff²@ used to scale the IRLS weights. +likelihoodScale2 :: RobustLikelihood -> Double +likelihoodScale2 (RGaussian s) = s * s +likelihoodScale2 (RStudentT _ s) = s * s +likelihoodScale2 (RCauchy g) = g * g + +-- --------------------------------------------------------------------------- +-- フィット結果 +-- --------------------------------------------------------------------------- + +-- | Robust GP fit result. +data RobustGPFit = RobustGPFit + { rgpKernel :: Kernel + , rgpParams :: GPParams + , rgpLik :: RobustLikelihood + , rgpTrainX :: [Double] -- ^ Training inputs. + , rgpTrainY :: [Double] -- ^ Training targets. + , rgpAlpha :: LA.Vector Double -- ^ @α = (K + σ² W⁻¹)⁻¹ y@. + , rgpKyInv :: LA.Matrix Double -- ^ @(K + σ² W⁻¹)⁻¹@ at convergence. + , rgpWeights :: LA.Vector Double -- ^ IRLS weights at convergence. + , rgpIters :: Int -- ^ Number of IRLS iterations executed. + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- フィット +-- --------------------------------------------------------------------------- + +-- | Compute the MAP of a robust GP via IRLS iteration. At most 50 +-- iterations; convergence when @‖f_new − f‖∞ < 10⁻⁶@. +fitGPRobust + :: Kernel + -> GPParams -- ^ Kernel hyperparameters (held fixed — + -- optimize them separately). + -> RobustLikelihood + -> [Double] -- ^ Training @X@. + -> [Double] -- ^ Training @Y@. + -> RobustGPFit +fitGPRobust ker params lik trainX trainY = + let n = length trainX + kMatrix = buildKernelMatrix ker (gpKernelParams params) trainX trainX -- K (n×n) + yV = LA.fromList trainY + sigEff2 = likelihoodScale2 lik + -- 1 反復: f, w を更新 + step (f, w, _iter) = + let r = LA.toList (yV - f) + wNew' = [ max 1e-8 (likelihoodWeight lik ri) + | ri <- r ] + wNewVec = LA.fromList wNew' + wInvDiag = LA.diag (LA.fromList [ sigEff2 / wi | wi <- wNew' ]) + ky = kMatrix `LA.add` wInvDiag + -- α = (K + σ²W⁻¹)⁻¹ y via SPD Cholesky (replaces inv + matvec). + alpha = LA.flatten + (Chol.cholSolveJitter ky (LA.asColumn yV)) + fNew = kMatrix LA.#> alpha + delta = LA.maxElement (LA.cmap abs (fNew - f)) + in (fNew, wNewVec, delta) + + maxIters = 50 + tol = 1e-6 :: Double + + loop f w iter + | iter >= maxIters = (f, w, iter) + | otherwise = + let (fNew, wNew, delta) = step (f, w, iter) + in if delta < tol + then (fNew, wNew, iter + 1) + else loop fNew wNew (iter + 1) + + f0 = LA.fromList (replicate n 0.0) + w0 = LA.fromList (replicate n 1.0) + (_fOpt, wOpt, iters) = loop f0 w0 0 + + -- 最終 K_y, α, K_y⁻¹ を再計算 (収束後の重みで)。 + -- kyInv は予測時の分散計算で必要なため陽に保持する。 + wInvDiag' = LA.diag (LA.cmap (\wi -> sigEff2 / max 1e-8 wi) wOpt) + ky' = kMatrix `LA.add` wInvDiag' + kyInv' = Chol.cholSolveJitter ky' (LA.ident n) + alpha' = LA.flatten + (Chol.cholSolveJitter ky' (LA.asColumn yV)) + in RobustGPFit + { rgpKernel = ker + , rgpParams = params + , rgpLik = lik + , rgpTrainX = trainX + , rgpTrainY = trainY + , rgpAlpha = alpha' + , rgpKyInv = kyInv' + , rgpWeights = wOpt + , rgpIters = iters + } + +-- --------------------------------------------------------------------------- +-- 予測 +-- --------------------------------------------------------------------------- + +-- | Predictive mean and variance of @f@ at the given test points. +-- mean = k_*ᵀ α, var = k(x*,x*) − k_*ᵀ K_y⁻¹ k_* +predictGPRobust :: RobustGPFit -> [Double] -> [(Double, Double)] +predictGPRobust fit testX = + let ker = rgpKernel fit + params = rgpParams fit + trainX = rgpTrainX fit + kStar = buildKernelMatrix ker (gpKernelParams params) testX trainX -- (m, n) + means = LA.toList (kStar LA.#> rgpAlpha fit) + kyInv = rgpKyInv fit + diagKss = [ kernelFn ker (gpKernelParams params) x x | x <- testX ] + ws = kStar LA.<> kyInv -- (m, n) + -- F1: vectorise per-row dots. + rowDots = LA.toList (KD.rowDotsAB kStar ws) + varList = zipWith (\d kw -> max 0 (d - kw)) diagKss rowDots + in zip means varList + +-- --------------------------------------------------------------------------- +-- 多出力 (列ごと IRLS、カーネル行列を共有) +-- --------------------------------------------------------------------------- + +-- | [日本語]: 多出力ロバスト GP の結果。q 出力ぶんの 'RobustGPFit' を保持し、 +-- カーネル / ハイパラ / 尤度は共通。 +-- [English]: The result of a multi-output robust GP. Holds a +-- 'RobustGPFit' per output (q of them); the kernel \/ hyperparameters \/ +-- likelihood are shared. +data RobustGPFitMulti = RobustGPFitMulti + { rgmKernel :: Kernel + , rgmParams :: GPParams + , rgmLik :: RobustLikelihood + , rgmTrainX :: [Double] + , rgmFits :: [RobustGPFit] -- ^ [日本語]: 列ごとの単出力 fit [English]: Per-column single-output fit + } deriving (Show) + +-- | [日本語]: 多出力ロバスト GP fit。Y は n × q、各列ごとに IRLS (重みは出力依存)。 +-- [English]: Multi-output robust GP fit. Y has shape n × q; IRLS runs +-- per column (weights depend on the output). +fitGPRobustMulti + :: Kernel + -> GPParams + -> RobustLikelihood + -> [Double] -- ^ [日本語]: 訓練 X [English]: Training X + -> LA.Matrix Double -- ^ [日本語]: Y (n × q) [English]: Y (n × q) + -> RobustGPFitMulti +fitGPRobustMulti ker params lik trainX yMat = + let q = LA.cols yMat + yCols = [ LA.toList (LA.flatten (yMat LA.¿ [j])) | j <- [0 .. q - 1] ] + fits = [ fitGPRobust ker params lik trainX y | y <- yCols ] + in RobustGPFitMulti ker params lik trainX fits + +-- | [日本語]: 多出力ロバスト GP 予測。戻り値: (mean 行列 m × q, 列ごとの分散リスト)。 +-- [English]: Multi-output robust GP prediction. Returns (mean matrix +-- m × q, per-column variance lists). +predictGPRobustMulti :: RobustGPFitMulti -> [Double] + -> (LA.Matrix Double, [[Double]]) +predictGPRobustMulti mf testX = + let preds = [ predictGPRobust f testX | f <- rgmFits mf ] + meansCols = map (map fst) preds + varsCols = map (map snd) preds + meansMat = LA.fromColumns [ LA.fromList col | col <- meansCols ] + in (meansMat, varsCols) + +-- --------------------------------------------------------------------------- +-- Multi-input (multivariate X) API +-- --------------------------------------------------------------------------- + +-- | Robust GP fit with multivariate input. Mirrors 'RobustGPFit' but +-- stores @X@ as an @n × p@ matrix and @y@ as a 'LA.Vector'. +data RobustGPFitMV = RobustGPFitMV + { rgpmvKernel :: Kernel + , rgpmvParams :: GPParams + , rgpmvLik :: RobustLikelihood + , rgpmvTrainX :: LA.Matrix Double -- ^ @n × p@. + , rgpmvTrainY :: LA.Vector Double -- ^ length @n@. + , rgpmvAlpha :: LA.Vector Double + , rgpmvKyInv :: LA.Matrix Double + , rgpmvWeights :: LA.Vector Double + , rgpmvIters :: Int + } deriving (Show) + +-- | Compute the MAP of a multi-input robust GP via the same IRLS scheme +-- as 'fitGPRobust'. @X@ is @n × p@; @y@ has length @n@. +fitGPRobustMV + :: Kernel + -> GPParams + -> RobustLikelihood + -> LA.Matrix Double -- ^ Training @X@ (@n × p@). + -> LA.Vector Double -- ^ Training @y@ (length @n@). + -> RobustGPFitMV +fitGPRobustMV ker params lik trainX yV = + let n = LA.rows trainX + kMatrix = buildKernelMatrixMV ker (gpKernelParams params) trainX trainX + sigEff2 = likelihoodScale2 lik + step (f, w, _iter) = + let r = LA.toList (yV - f) + wNew' = [ max 1e-8 (likelihoodWeight lik ri) | ri <- r ] + wNewVec = LA.fromList wNew' + wInvDiag = LA.diag (LA.fromList [ sigEff2 / wi | wi <- wNew' ]) + ky = kMatrix `LA.add` wInvDiag + -- α = (K + σ²W⁻¹)⁻¹ y via SPD Cholesky. + alpha = LA.flatten + (Chol.cholSolveJitter ky (LA.asColumn yV)) + fNew = kMatrix LA.#> alpha + delta = LA.maxElement (LA.cmap abs (fNew - f)) + in (fNew, wNewVec, delta) + + maxIters = 50 + tol = 1e-6 :: Double + + loop f w iter + | iter >= maxIters = (f, w, iter) + | otherwise = + let (fNew, wNew, delta) = step (f, w, iter) + in if delta < tol + then (fNew, wNew, iter + 1) + else loop fNew wNew (iter + 1) + + f0 = LA.fromList (replicate n 0.0) + w0 = LA.fromList (replicate n 1.0) + (_fOpt, wOpt, iters) = loop f0 w0 0 + + wInvDiag' = LA.diag (LA.cmap (\wi -> sigEff2 / max 1e-8 wi) wOpt) + ky' = kMatrix `LA.add` wInvDiag' + kyInv' = Chol.cholSolveJitter ky' (LA.ident n) + alpha' = LA.flatten + (Chol.cholSolveJitter ky' (LA.asColumn yV)) + in RobustGPFitMV + { rgpmvKernel = ker + , rgpmvParams = params + , rgpmvLik = lik + , rgpmvTrainX = trainX + , rgpmvTrainY = yV + , rgpmvAlpha = alpha' + , rgpmvKyInv = kyInv' + , rgpmvWeights = wOpt + , rgpmvIters = iters + } + +-- | Predictive mean and variance at multi-input test points (@m × p@). +predictGPRobustMV + :: RobustGPFitMV -> LA.Matrix Double + -> (LA.Vector Double, LA.Vector Double) +predictGPRobustMV fit testX = + let ker = rgpmvKernel fit + params = rgpmvParams fit + trainX = rgpmvTrainX fit + kStar = buildKernelMatrixMV ker (gpKernelParams params) testX trainX -- m × n + means = kStar LA.#> rgpmvAlpha fit + kyInv = rgpmvKyInv fit + sf = gpSignalVar params + diagKss = LA.konst sf (LA.rows testX) + ws = kStar LA.<> kyInv -- m × n + -- F1: vectorise per-row dots. + vars = LA.cmap (max 0) (diagKss - KD.rowDotsAB kStar ws) + in (means, vars) + +-- | Multi-input multi-output robust GP. Per-column IRLS (weights are +-- output-specific), but the kernel matrix @K@ is shared. +data RobustGPFitMVMulti = RobustGPFitMVMulti + { rgmvKernel :: Kernel + , rgmvParams :: GPParams + , rgmvLik :: RobustLikelihood + , rgmvTrainX :: LA.Matrix Double + , rgmvFits :: [RobustGPFitMV] + } deriving (Show) + +-- | Fit a multi-input multi-output robust GP. @Y@ has shape @n × q@. +fitGPRobustMVMulti + :: Kernel + -> GPParams + -> RobustLikelihood + -> LA.Matrix Double -- ^ Training @X@ (@n × p@). + -> LA.Matrix Double -- ^ Training @Y@ (@n × q@). + -> RobustGPFitMVMulti +fitGPRobustMVMulti ker params lik trainX yMat = + let q = LA.cols yMat + cols = [ LA.flatten (yMat LA.¿ [j]) | j <- [0 .. q - 1] ] + fits = [ fitGPRobustMV ker params lik trainX y | y <- cols ] + in RobustGPFitMVMulti ker params lik trainX fits + +-- | Multi-input multi-output robust GP prediction. Returns the @m × q@ +-- mean matrix and a per-column variance vector. +predictGPRobustMVMulti + :: RobustGPFitMVMulti -> LA.Matrix Double + -> (LA.Matrix Double, [LA.Vector Double]) +predictGPRobustMVMulti mf testX = + let preds = [ predictGPRobustMV f testX | f <- rgmvFits mf ] + meanCs = map fst preds + varCs = map snd preds + meanMat = LA.fromColumns meanCs + in (meanMat, varCs) diff --git a/src/Hanalyze/Model/GradientBoosting.hs b/src/Hanalyze/Model/GradientBoosting.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/GradientBoosting.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.GradientBoosting +-- Description : 勾配ブースティング (Gradient Boosting Machine、 回帰 + 二値分類) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Gradient Boosting Machine (回帰 + 二値分類)。 +-- +-- 弱学習器は 'Hanalyze.Model.RandomForest' の回帰木 ('RF.Tree' / +-- 'RF.buildTreeV') を流用 (bootstrap 無 + mtry = d で full-data / +-- 全特徴を使う通常の GBM 木に縮約)。 +-- +-- @ +-- import qualified Hanalyze.Model.GradientBoosting as GB +-- gb <- GB.fitGBRegressor GB.defaultGBM x y +-- let yhat = GB.predictGBR gb x +-- @ +-- +-- 損失: +-- +-- - 回帰: 二乗誤差 (negative gradient = 残差) +-- - 分類 (binary): log-loss (negative gradient = y - sigmoid(F)) +-- +-- [English]: Gradient Boosting Machine (regression + binary classification). +-- +-- The weak learner reuses the regression tree from +-- 'Hanalyze.Model.RandomForest' ('RF.Tree' \/ 'RF.buildTreeV'), +-- reduced to an ordinary GBM tree that uses full data \/ all features (no +-- bootstrap, mtry = d). +-- +-- @ +-- import qualified Hanalyze.Model.GradientBoosting as GB +-- gb <- GB.fitGBRegressor GB.defaultGBM x y +-- let yhat = GB.predictGBR gb x +-- @ +-- +-- Loss: +-- +-- - Regression: squared error (negative gradient = the residual). +-- - Classification (binary): log-loss (negative gradient = +-- y - sigmoid(F)). +module Hanalyze.Model.GradientBoosting + ( GBConfig (..) + , defaultGBM + , GBRegressor (..) + , GBClassifier (..) + , fitGBRegressor + , fitGBClassifier + , predictGBR + , predictGBRRow + , predictGBC + , predictGBCProbs + ) where + +import qualified Data.Vector.Unboxed as VU +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Model.RandomForest as RF + +-- --------------------------------------------------------------------------- +-- Config +-- --------------------------------------------------------------------------- + +-- | [日本語]: GBM 設定。 +-- [English]: The GBM configuration. +data GBConfig = GBConfig + { gbNRounds :: !Int -- ^ [日本語]: ブースティング回数 M。 [English]: The number of boosting rounds M. + , gbMaxDepth :: !Int -- ^ [日本語]: 各弱学習器の最大深さ (典型 3-5)。 [English]: The maximum depth of each weak learner (typically 3-5). + , gbMinSamples :: !Int -- ^ [日本語]: 葉最小サンプル数。 [English]: The minimum number of samples per leaf. + , gbLearnRate :: !Double -- ^ [日本語]: 学習率 η (typ 0.1)。 [English]: The learning rate η (typically 0.1). + } deriving (Show) + +defaultGBM :: GBConfig +defaultGBM = GBConfig + { gbNRounds = 100 + , gbMaxDepth = 3 + , gbMinSamples = 2 + , gbLearnRate = 0.1 + } + +-- | [日本語]: 弱学習器設定 (full-data / 全特徴利用、 木の深さは gbMaxDepth)。 +-- [English]: The weak-learner configuration (uses full data \/ all +-- features; tree depth is gbMaxDepth). +weakRFCfg :: Int -> GBConfig -> RF.RFConfig +weakRFCfg d cfg = RF.RFConfig + { RF.rfTrees = 1 + , RF.rfMaxDepth = gbMaxDepth cfg + , RF.rfMinSamples = gbMinSamples cfg + , RF.rfMtry = Just d + , RF.rfBootstrap = False + } + +-- --------------------------------------------------------------------------- +-- Regressor +-- --------------------------------------------------------------------------- + +-- | [日本語]: 回帰 GBM。 予測 = init + η · Σ tree_m(x)。 +-- [English]: A regression GBM. Prediction = init + η · Σ tree_m(x). +data GBRegressor = GBRegressor + { gbrInit :: !Double + , gbrTrees :: ![RF.Tree] + , gbrLR :: !Double + } deriving (Show) + +fitGBRegressor :: GBConfig + -> LA.Matrix Double -- ^ [日本語]: X (n × d)。 [English]: X (n × d). + -> VU.Vector Double -- ^ [日本語]: y (n)。 [English]: y (n). + -> GBRegressor +fitGBRegressor cfg x y = + let !n = VU.length y + !d = LA.cols x + !cfgW = weakRFCfg d cfg + !lr = gbLearnRate cfg + !f0 = VU.sum y / fromIntegral n + !preds0 = VU.replicate n f0 + idx = VU.enumFromN 0 n + + step (!preds, !trees) _ = + let !res = VU.zipWith (-) y preds + !t = RF.buildTreeV cfgW x res idx 0 + !upd = VU.map (\i -> lr * RF.predictTree t (rowList x i)) + (VU.enumFromN 0 n) + !preds' = VU.zipWith (+) preds upd + in (preds', t : trees) + + (_, treesRev) = foldl step (preds0, []) [1 .. gbNRounds cfg] + in GBRegressor f0 (reverse treesRev) lr + +-- | [日本語]: 1 行を [Double] 化 (predictTree のための一時変換)。 +-- [English]: Converts a single row to [Double] (a temporary conversion +-- for predictTree). +rowList :: LA.Matrix Double -> Int -> [Double] +rowList x i = LA.toList (LA.flatten (x LA.? [i])) + +-- | [日本語]: 1 サンプルの予測。 +-- [English]: Predicts a single sample. +predictGBRRow :: GBRegressor -> [Double] -> Double +predictGBRRow gb xs = + gbrInit gb + + gbrLR gb * sum [ RF.predictTree t xs | t <- gbrTrees gb ] + +-- | [日本語]: 行列入力に対する予測 (n)。 +-- [English]: Predicts for matrix input (n). +predictGBR :: GBRegressor -> LA.Matrix Double -> VU.Vector Double +predictGBR gb x = + let !n = LA.rows x + in VU.generate n (\i -> predictGBRRow gb (rowList x i)) + +-- --------------------------------------------------------------------------- +-- Classifier (binary) +-- --------------------------------------------------------------------------- + +-- | [日本語]: 二値分類 GBM (logit + log-loss)。 ラベルは 0/1。 +-- [English]: A binary-classification GBM (logit + log-loss). Labels are +-- 0\/1. +data GBClassifier = GBClassifier + { gbcInit :: !Double -- ^ [日本語]: logit(p̂_0)。 [English]: logit(p̂_0). + , gbcTrees :: ![RF.Tree] + , gbcLR :: !Double + } deriving (Show) + +sigmoid :: Double -> Double +sigmoid z = 1 / (1 + exp (negate z)) + +clamp :: Double -> Double -> Double -> Double +clamp lo hi v = max lo (min hi v) + +fitGBClassifier :: GBConfig + -> LA.Matrix Double -- ^ [日本語]: X (n × d)。 [English]: X (n × d). + -> VU.Vector Int -- ^ [日本語]: y ∈ {0,1} (n)。 [English]: y ∈ {0,1} (n). + -> GBClassifier +fitGBClassifier cfg x y = + let !n = VU.length y + !d = LA.cols x + !cfgW = weakRFCfg d cfg + !lr = gbLearnRate cfg + !yD = VU.map fromIntegral y :: VU.Vector Double + !p0 = clamp 1e-6 (1 - 1e-6) (VU.sum yD / fromIntegral n) + !f0 = log (p0 / (1 - p0)) + !logits0 = VU.replicate n f0 + idx = VU.enumFromN 0 n + + step (!logits, !trees) _ = + let !grad = VU.zipWith (\yi z -> yi - sigmoid z) yD logits + !t = RF.buildTreeV cfgW x grad idx 0 + !upd = VU.map (\i -> lr * RF.predictTree t (rowList x i)) + (VU.enumFromN 0 n) + !logits' = VU.zipWith (+) logits upd + in (logits', t : trees) + + (_, treesRev) = foldl step (logits0, []) [1 .. gbNRounds cfg] + in GBClassifier f0 (reverse treesRev) lr + +-- | [日本語]: クラス確率 p(y=1 | x) を返す。 +-- [English]: Returns the class probability p(y=1 | x). +predictGBCProbs :: GBClassifier -> LA.Matrix Double -> VU.Vector Double +predictGBCProbs gb x = + let !n = LA.rows x + logit xs = gbcInit gb + + gbcLR gb * sum [ RF.predictTree t xs | t <- gbcTrees gb ] + in VU.generate n (\i -> sigmoid (logit (rowList x i))) + +-- | [日本語]: クラス予測 (閾値 0.5)。 +-- [English]: Predicts the class (threshold 0.5). +predictGBC :: GBClassifier -> LA.Matrix Double -> VU.Vector Int +predictGBC gb x = + VU.map (\p -> if p >= 0.5 then 1 else 0) (predictGBCProbs gb x) diff --git a/src/Hanalyze/Model/HierarchicalCluster.hs b/src/Hanalyze/Model/HierarchicalCluster.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/HierarchicalCluster.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.HierarchicalCluster +-- Description : 凝集型階層クラスタリング (Agglomerative Hierarchical Clustering) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 凝集型階層クラスタリング (Agglomerative Hierarchical Clustering)。 +-- +-- Lance-Williams update formula による O(n²) アルゴリズム。 +-- 各ステップで最近接クラスタ対をマージし、 新クラスタへの距離を再計算する。 +-- +-- 対応 linkage: +-- +-- - 'Single' : d(i∪j, k) = min(d(i,k), d(j,k)) +-- - 'Complete' : d(i∪j, k) = max(d(i,k), d(j,k)) +-- - 'Average' : (|i|·d(i,k) + |j|·d(j,k)) / (|i|+|j|) +-- - 'Ward' : Lance-Williams 係数で分散最小化 +-- +-- 距離は Euclidean のみサポート (X の各行をサンプルとして二乗ユークリッド距離)。 +-- +-- [English]: Agglomerative Hierarchical Clustering. +-- +-- An O(n²) algorithm using the Lance-Williams update formula. At each step, +-- the nearest pair of clusters is merged and the distances to the new +-- cluster are recomputed. +-- +-- Supported linkages: +-- +-- - 'Single' : d(i∪j, k) = min(d(i,k), d(j,k)) +-- - 'Complete' : d(i∪j, k) = max(d(i,k), d(j,k)) +-- - 'Average' : (|i|·d(i,k) + |j|·d(j,k)) / (|i|+|j|) +-- - 'Ward' : minimizes variance via the Lance-Williams coefficients +-- +-- Only Euclidean distance is supported (squared Euclidean distance treating +-- each row of X as a sample). +module Hanalyze.Model.HierarchicalCluster + ( Linkage (..) + , HClusterFit (..) + , fitHierarchical + , cutTree + ) where + +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Unboxed.Mutable as MU +import qualified Numeric.LinearAlgebra as LA +import Control.Monad (forM_, when) +import Control.Monad.ST (runST) +import Data.STRef (newSTRef, readSTRef, writeSTRef, + modifySTRef') +import Data.List (foldl') + +-- =========================================================================== +-- 型 +-- =========================================================================== + +data Linkage = Single | Complete | Average | Ward + deriving (Show, Eq) + +data HClusterFit = HClusterFit + { hcMerges :: ![(Int, Int)] -- ^ [日本語]: マージ列 (n-1 個)。 ID は 0..n-1 が元サンプル、 + -- 以降 n, n+1, ... が新クラスタ。 [English]: The + -- merge sequence (n-1 entries). IDs 0..n-1 are the + -- original samples; n, n+1, ... onward are new clusters. + , hcHeights :: ![Double] -- ^ [日本語]: マージ時点での距離 (linkage に応じた値)。 + -- [English]: The distance at the time of each merge + -- (a value dependent on the linkage). + , hcLinkage :: !Linkage + , hcNumOriginals :: !Int -- ^ [日本語]: n_samples。 [English]: n_samples. + } deriving (Show) + +-- =========================================================================== +-- fit +-- =========================================================================== + +-- | [日本語]: 階層クラスタリングを fit する。 X は n × p 行列、 各行が 1 サンプル。 +-- [English]: Fits hierarchical clustering. X is an n × p matrix, with each +-- row a sample. +fitHierarchical :: Linkage -> LA.Matrix Double -> HClusterFit +fitHierarchical link xs = + let n = LA.rows xs + d0 = initialDistance link xs + in agglomerate link n d0 + +-- | [日本語]: 樹形図を K クラスタに切り、 各サンプルのクラスタ ID を返す。 +-- K = 1 → 全サンプル ID 0; K = n → 全サンプル別 ID。 +-- [English]: Cuts the dendrogram into K clusters and returns each sample's +-- cluster ID. K = 1 → all samples get ID 0; K = n → every sample gets a +-- distinct ID. +cutTree :: HClusterFit -> Int -> V.Vector Int +cutTree fit k + | k <= 0 = V.replicate (hcNumOriginals fit) 0 + | k >= n = V.generate n id + | otherwise = + let nMerges = n - k -- K クラスタにするには n-K 回マージを適用 + mergesUsed = take nMerges (hcMerges fit) + -- union-find 風: parent[i] = root cluster representative + parents = runST $ do + arr <- MV.replicate (2 * n) (-1 :: Int) + forM_ [0 .. n - 1] $ \i -> MV.write arr i i + forM_ (zip [n ..] mergesUsed) $ \(newId, (a, b)) -> do + ra <- findRoot arr a + rb <- findRoot arr b + MV.write arr ra newId + MV.write arr rb newId + MV.write arr newId newId + V.generateM n (findRoot arr) + uniqRoots = foldr (\r acc -> if r `elem` acc then acc else r:acc) [] (V.toList parents) + roots = zip uniqRoots [0 ..] + lookupId r = case lookup r roots of + Just i -> i + Nothing -> 0 + in V.map lookupId parents + where + n = hcNumOriginals fit + findRoot arr i = do + p <- MV.read arr i + if p == i then pure i else findRoot arr p + +-- =========================================================================== +-- 内部: 距離行列の構築 +-- =========================================================================== + +-- | [日本語]: 初期距離行列 (n × n)。 二乗ユークリッド距離。 +-- Ward は二乗距離を使うのが定義どおり。 他 linkage は √ を取って通常距離にする。 +-- [English]: The initial distance matrix (n × n). Squared Euclidean +-- distance. Ward uses the squared distance as defined; other linkages +-- take the √ to get the ordinary distance. +initialDistance :: Linkage -> LA.Matrix Double -> LA.Matrix Double +initialDistance link xs = + let n = LA.rows xs + sqDist i j = + let r = LA.flatten (xs LA.? [i]) - LA.flatten (xs LA.? [j]) + in LA.sumElements (r * r) + raw = LA.build (n, n) + (\i j -> sqDist (round i) (round j) :: Double) + in case link of + Ward -> raw -- squared + _ -> LA.cmap sqrt raw + +-- =========================================================================== +-- 内部: 凝集アルゴリズム +-- =========================================================================== + +agglomerate :: Linkage -> Int -> LA.Matrix Double -> HClusterFit +agglomerate link n d0 = runST $ do + -- Phase 17.2 改善: + -- * 距離行列を MU (Unboxed Mutable Vector Double) で flat 配列に + -- * active set を Unboxed Mutable Vector Int でコンパクトに保持 + -- (毎ステップ tail 切詰めの代わりに、 in-place で a,b 位置を最後と入替え) + -- * unsafeRead / unsafeWrite で境界チェック排除 + -- * inner loop の STRef 更新を local accumulator (Int * 2 + Double) で減らす + let !totalIds = 2 * n - 1 + dist <- MU.unsafeNew (totalIds * totalIds) + -- 初期化: ∞ + forM_ [0 .. totalIds * totalIds - 1] $ \k -> MU.unsafeWrite dist k (1/0 :: Double) + sizes <- MU.replicate totalIds (1 :: Int) + forM_ [0 .. n - 1] $ \i -> + forM_ [0 .. n - 1] $ \j -> + when (i /= j) $ + MU.unsafeWrite dist (i * totalIds + j) (LA.atIndex d0 (i, j)) + -- active: 先頭 `activeLen` 要素が active な ID + active <- MU.unsafeNew totalIds + forM_ [0 .. n - 1] $ \i -> MU.unsafeWrite active i i + activeLenRef <- newSTRef n + mergesRef <- newSTRef ([] :: [(Int, Int)]) + heightsRef <- newSTRef ([] :: [Double]) + forM_ [0 .. n - 2] $ \step -> do + let !nextId = n + step + !alen <- readSTRef activeLenRef + -- find argmin。 active[0 .. alen-1] のペアを直接走査 + bestRef <- newSTRef ((-1) :: Int, (-1) :: Int, 1/0 :: Double, (-1) :: Int, (-1) :: Int) + -- (a, b, bestDist, posA, posB) posA/posB は active 内の位置 + forM_ [0 .. alen - 2] $ \pi_ -> do + !i <- MU.unsafeRead active pi_ + forM_ [pi_ + 1 .. alen - 1] $ \pj -> do + !j <- MU.unsafeRead active pj + !d <- MU.unsafeRead dist (i * totalIds + j) + (_, _, !best, _, _) <- readSTRef bestRef + when (d < best) $ writeSTRef bestRef (i, j, d, pi_, pj) + (!a, !b, !h, !pa, !pb) <- readSTRef bestRef + modifySTRef' mergesRef ((a, b) :) + modifySTRef' heightsRef ((reportHeight link h) :) + !na <- MU.unsafeRead sizes a + !nb <- MU.unsafeRead sizes b + MU.unsafeWrite sizes nextId (na + nb) + -- active から a, b を削除し nextId を追加: pb を末尾と swap で除去、 + -- 同様に pa を新末尾と swap、 alen 減 2、 末尾に nextId を入れて alen 増 1 + -- ※ pa < pb 不変 (内側 loop が pj > pi) + !lastPos <- pure (alen - 1) + !valLast <- MU.unsafeRead active lastPos + MU.unsafeWrite active pb valLast + !secondLast <- pure (alen - 2) + !valSecond <- MU.unsafeRead active secondLast + -- pa の位置は pb と入替えで動いていない (pa < pb なので) + MU.unsafeWrite active pa valSecond + MU.unsafeWrite active secondLast nextId + writeSTRef activeLenRef (alen - 1) -- 2 削除 + 1 追加 = -1 + !alenNew <- readSTRef activeLenRef + -- Lance-Williams update: active[0 .. alenNew - 1] (末尾は nextId) + let !nextRow = nextId * totalIds + forM_ [0 .. alenNew - 2] $ \pk -> do + !k <- MU.unsafeRead active pk + !dak <- MU.unsafeRead dist (a * totalIds + k) + !dbk <- MU.unsafeRead dist (b * totalIds + k) + !nk <- MU.unsafeRead sizes k + let !dNew = lanceWilliams link (na, nb, nk) dak dbk h + MU.unsafeWrite dist (nextRow + k) dNew + MU.unsafeWrite dist (k * totalIds + nextId) dNew + merges <- reverse <$> readSTRef mergesRef + heights <- reverse <$> readSTRef heightsRef + pure HClusterFit + { hcMerges = merges + , hcHeights = heights + , hcLinkage = link + , hcNumOriginals = n + } + where + reportHeight Ward h = sqrt (max 0 h) + reportHeight _ h = h + +-- | [日本語]: Lance-Williams recurrence: +-- d(i∪j, k) = α_i d(i,k) + α_j d(j,k) + β d(i,j) + γ |d(i,k) − d(j,k)| +-- [English]: The Lance-Williams recurrence: +-- d(i∪j, k) = α_i d(i,k) + α_j d(j,k) + β d(i,j) + γ |d(i,k) − d(j,k)| +lanceWilliams :: Linkage + -> (Int, Int, Int) -- sizes (n_a, n_b, n_k) + -> Double -- d(a, k) + -> Double -- d(b, k) + -> Double -- d(a, b) + -> Double +lanceWilliams link (na, nb, nk) dak dbk dab = + case link of + Single -> min dak dbk + Complete -> max dak dbk + Average -> + let naD = fromIntegral na; nbD = fromIntegral nb + in (naD * dak + nbD * dbk) / (naD + nbD) + Ward -> + let naD = fromIntegral na; nbD = fromIntegral nb + nkD = fromIntegral nk + tot = naD + nbD + nkD + in ((naD + nkD) * dak + (nbD + nkD) * dbk - nkD * dab) / tot diff --git a/src/Hanalyze/Model/KNN.hs b/src/Hanalyze/Model/KNN.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/KNN.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.KNN +-- Description : k近傍法 (k-Nearest Neighbours、 回帰 + 分類、 brute force ユークリッド距離) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: k-Nearest Neighbours (回帰 + 分類、 brute force ユークリッド距離). +-- +-- @ +-- import qualified Hanalyze.Model.KNN as KNN +-- let knnR = KNN.fitKNNR 5 xTrain yTrain +-- yR = KNN.predictKNNR knnR xTest +-- @ +-- +-- /Complexity/: O(n_test · n_train · d)。 KD-tree は scope 外。 +-- +-- [English]: k-Nearest Neighbours (regression + classification, brute-force +-- Euclidean distance). +-- +-- @ +-- import qualified Hanalyze.Model.KNN as KNN +-- let knnR = KNN.fitKNNR 5 xTrain yTrain +-- yR = KNN.predictKNNR knnR xTest +-- @ +-- +-- /Complexity/: O(n_test · n_train · d). A KD-tree is out of scope. +module Hanalyze.Model.KNN + ( KNNRegressor (..) + , KNNClassifier (..) + , fitKNNR + , fitKNNC + , predictKNNR + , predictKNNC + , predictKNNCProbs + ) where + +import qualified Data.Vector.Unboxed as VU +import qualified Numeric.LinearAlgebra as LA +import qualified Data.Map.Strict as Map +import Data.List (foldl', sortBy, nub, sort) +import Data.Ord (comparing) +import Data.Text (Text) + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +data KNNRegressor = KNNRegressor + { knnRK :: !Int + , knnRX :: !(LA.Matrix Double) + , knnRY :: !(VU.Vector Double) + } deriving (Show) + +data KNNClassifier = KNNClassifier + { knnCK :: !Int + , knnCX :: !(LA.Matrix Double) + , knnCY :: !(VU.Vector Int) + , knnCClasses :: ![Int] + , knnCClassNames :: ![Text] -- ^ [日本語]: クラス名 (df|-> が levels 注入・空=数値表示)。 [English]: Class names (injected as levels by df|->; empty = displayed numerically). + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- Fit +-- --------------------------------------------------------------------------- + +fitKNNR :: Int -> LA.Matrix Double -> VU.Vector Double -> KNNRegressor +fitKNNR k x y = KNNRegressor k x y + +fitKNNC :: Int -> LA.Matrix Double -> VU.Vector Int -> KNNClassifier +fitKNNC k x y = KNNClassifier + { knnCK = k + , knnCX = x + , knnCY = y + , knnCClasses = sort (nub (VU.toList y)) + , knnCClassNames = [] -- df|-> 経路が reqLabelWithLevels で後から注入。 + } + +-- --------------------------------------------------------------------------- +-- Predict helpers +-- --------------------------------------------------------------------------- + +rowVec :: LA.Matrix Double -> Int -> LA.Vector Double +rowVec x i = LA.flatten (x LA.? [i]) + +-- | [日本語]: クエリ点に対し、 訓練データ各行までの距離 (二乗) と元 index のペア +-- を返す。 +-- [English]: For a query point, returns pairs of the (squared) distance to +-- each training-data row and the original index. +distancesSq :: LA.Matrix Double -> LA.Vector Double -> [(Int, Double)] +distancesSq xTrain q = + let !n = LA.rows xTrain + in [ (i, let v = rowVec xTrain i - q in LA.dot v v) + | i <- [0 .. n - 1] ] + +kNearest :: Int -> LA.Matrix Double -> LA.Vector Double -> [Int] +kNearest k xTrain q = + let ds = sortBy (comparing snd) (distancesSq xTrain q) + in map fst (take k ds) + +-- --------------------------------------------------------------------------- +-- Predict (regression) +-- --------------------------------------------------------------------------- + +predictKNNR :: KNNRegressor -> LA.Matrix Double -> VU.Vector Double +predictKNNR knn xTest = + let !nT = LA.rows xTest + !k = knnRK knn + !xT = knnRX knn + !yT = knnRY knn + pred1 i = + let q = rowVec xTest i + ids = kNearest k xT q + ys = [ yT VU.! j | j <- ids ] + in sum ys / fromIntegral (length ys) + in VU.generate nT pred1 + +-- --------------------------------------------------------------------------- +-- Predict (classification) +-- --------------------------------------------------------------------------- + +predictKNNCProbs :: KNNClassifier + -> LA.Matrix Double + -> [Map.Map Int Double] +predictKNNCProbs knn xTest = + let !nT = LA.rows xTest + !k = knnCK knn + !xT = knnCX knn + !yT = knnCY knn + counts1 i = + let q = rowVec xTest i + ids = kNearest k xT q + cs = [ yT VU.! j | j <- ids ] + !nk = fromIntegral (length cs) :: Double + mp = foldl' (\m c -> Map.insertWith (+) c 1 m) + Map.empty cs + in Map.map (/ nk) mp + in [ counts1 i | i <- [0 .. nT - 1] ] + +predictKNNC :: KNNClassifier -> LA.Matrix Double -> VU.Vector Int +predictKNNC knn xTest = + let probs = predictKNNCProbs knn xTest + majority m = + case sortBy (flip (comparing snd)) (Map.toList m) of + ((c, _) : _) -> c + [] -> 0 + in VU.fromList (map majority probs) diff --git a/src/Hanalyze/Model/Kernel.hs b/src/Hanalyze/Model/Kernel.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Kernel.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.Kernel +-- Description : GP/SVM/カーネル法で共通のカーネル語彙 (RBF/Matern52/Periodic/Linear/Poly) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 共有カーネル語彙 (GP / SVM / カーネル法で共通)。 'Model.GP' から分離した。 +-- +-- GP 族の定常/内積カーネル ('RBF' / 'Matern52' / 'Periodic' / 'Linear' / 'Poly') と +-- そのハイパーパラメータ 'KernelParams' (ℓ / σ_f² / period / ARD per-dim ℓ) を集約する。 +-- @GPParams@ (= 'KernelParams' + 観測ノイズ σ_n²) に依存しないので、 SVM 等 +-- ノイズを持たないカーネル法はこのモジュールだけを import すればよい +-- ('Model.GP' を import しない)。 +-- +-- 評価関数: +-- +-- - 'kernelFn' — 1D 入力の @k(x, x')@。 +-- - 'buildKernelMatrix' — 1D の Gram 行列 @K(xs, xs')@。 +-- - 'applyKernel' — 二乗距離行列 → カーネル行列 (距離カーネル専用)。 +-- - 'kernelOfParams' — 固定パラメータの @s ↦ k(s)@ (距離カーネル専用・INLINE)。 +-- - 'ardScaleXY' — ARD 列スケーリング。 +-- - 'buildKernelMatrixMV' — 多入力 Gram 行列 (全カーネル)。 +-- - 'kEvalMV' — 多入力の点対点評価 @k(a, b)@ (全カーネル・SVM 等の汎用経路)。 +-- +-- 距離カーネル (RBF/Matern52/Periodic) は二乗距離から、 内積カーネル +-- (Linear/Poly) は内積から評価する。 'applyKernel' / 'kernelOfParams' は距離専用で、 +-- 内積カーネルを渡すと error (multi-input gram は 'buildKernelMatrixMV' が内積経路へ +-- 分岐するためそこには到達しない)。 +-- +-- [English]: Shared kernel vocabulary (common to GP \/ SVM \/ kernel +-- methods). Split out from 'Model.GP'. +-- +-- Gathers the GP family's stationary\/dot-product kernels ('RBF' \/ +-- 'Matern52' \/ 'Periodic' \/ 'Linear' \/ 'Poly') and their hyperparameters +-- 'KernelParams' (ℓ \/ σ_f² \/ period \/ per-dim ARD ℓ). This module does +-- not depend on @GPParams@ (= 'KernelParams' + observation noise σ_n²), so +-- noise-free kernel methods such as SVM only need to import this module +-- (and not 'Model.GP'). +-- +-- Evaluation functions: +-- +-- - 'kernelFn' — @k(x, x')@ for 1D inputs. +-- - 'buildKernelMatrix' — the 1D Gram matrix @K(xs, xs')@. +-- - 'applyKernel' — squared-distance matrix → kernel matrix +-- (distance kernels only). +-- - 'kernelOfParams' — @s ↦ k(s)@ for fixed parameters (distance +-- kernels only, INLINE). +-- - 'ardScaleXY' — ARD column scaling. +-- - 'buildKernelMatrixMV' — multi-input Gram matrix (all kernels). +-- - 'kEvalMV' — point-to-point multi-input evaluation +-- @k(a, b)@ (all kernels; the generic path used by SVM etc.). +-- +-- Distance kernels (RBF\/Matern52\/Periodic) are evaluated from squared +-- distance; dot-product kernels (Linear\/Poly) are evaluated from the dot +-- product. 'applyKernel' \/ 'kernelOfParams' are distance-only and error +-- if given a dot-product kernel (the multi-input gram path never reaches +-- them, since 'buildKernelMatrixMV' branches to the dot-product path +-- first). +module Hanalyze.Model.Kernel + ( -- * カーネル型 + Kernel (..) + , kernelName + -- * カーネルハイパーパラメータ + , KernelParams (..) + , defaultKernelParams + -- * 評価 + , kernelFn + , buildKernelMatrix + , applyKernel + , kernelOfParams + , ardScaleXY + , buildKernelMatrixMV + , kEvalMV + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Stat.KernelDist as KD +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import Control.Monad.ST (runST) + +-- --------------------------------------------------------------------------- +-- 型 +-- --------------------------------------------------------------------------- + +-- | [日本語]: GP / SVM 族のカーネル種別。 +-- [English]: Kernel variants for the GP\/SVM family. +data Kernel + = RBF + -- ^ Squared exponential: @k(x,x') = σ_f² exp(−r²/(2ℓ²))@. + -- Best for smooth functions; the most commonly used kernel. + | Matern52 + -- ^ Matérn 5/2: @k(x,x') = σ_f²(1+√5 r/ℓ+5r²/(3ℓ²)) exp(−√5 r/ℓ)@. + -- Slightly rougher than RBF; common in physical systems. + | Periodic + -- ^ Periodic: @k(x,x') = σ_f² exp(−2 sin²(π r/p)/ℓ²)@. + -- For periodic patterns; set 'kpPeriod' appropriately. + | Linear + -- ^ Linear (dot-product): @k(x,x') = σ_f² (x·x')@. A non-stationary + -- kernel; with SVM gives a linear decision boundary. + | Poly !Int + -- ^ Polynomial of degree @d@: @k(x,x') = (γ (x·x') + 1)^d@ with + -- @γ = 1/(2ℓ²)@ (shared with the SVM γ convention). A + -- non-stationary kernel. + deriving (Show, Eq) + +-- | Display name of a kernel. +kernelName :: Kernel -> Text +kernelName RBF = "RBF" +kernelName Matern52 = "Mat\xe9rn 5/2" +kernelName Periodic = "Periodic" +kernelName Linear = "Linear" +kernelName (Poly d) = "Poly(" <> T.pack (show d) <> ")" + +-- | [日本語]: カーネルハイパーパラメータ (観測ノイズ σ_n² は含まない)。 +-- [English]: Kernel hyperparameters (does not include the observation +-- noise σ_n²). +data KernelParams = KernelParams + { kpLengthScale :: Double + -- ^ Isotropic length scale @ℓ@; larger means smoother. Used unless + -- 'kpLengthScales' is 'Just' (= ARD), in which case the per-dim + -- vector overrides this for multi-input kernel evaluation. + , kpSignalVar :: Double + -- ^ Signal variance @σ_f²@; the variability of the function values. + , kpPeriod :: Double + -- ^ Period @p@ (only used by the @Periodic@ kernel). + , kpLengthScales :: Maybe (LA.Vector Double) + -- ^ Per-dim length scales for ARD (Automatic Relevance + -- Determination). When 'Just' v, the multi-input kernel uses + -- @D_ARD[i,j] = Σ_d (X[i,d] − X'[j,d])² / ℓ_d²@ instead of the + -- isotropic distance / ℓ². Has no effect on the 1D 'kernelFn' + -- path. 'Nothing' = isotropic (default). + } deriving (Show) + +-- | Default kernel hyperparameters: @ℓ = σ_f² = p = 1@, isotropic. +defaultKernelParams :: KernelParams +defaultKernelParams = KernelParams 1.0 1.0 1.0 Nothing + +-- --------------------------------------------------------------------------- +-- 1D 評価 +-- --------------------------------------------------------------------------- + +-- | Evaluate the kernel function @k(x, x')@ for scalar inputs. +kernelFn :: Kernel -> KernelParams -> Double -> Double -> Double +kernelFn RBF p x x' = + let d = x - x' + l = kpLengthScale p + in kpSignalVar p * exp (-(d * d) / (2 * l * l)) +kernelFn Matern52 p x x' = + let d = abs (x - x') + l = kpLengthScale p + s = sqrt 5 * d / l + in kpSignalVar p * (1 + s + s * s / 3) * exp (-s) +kernelFn Periodic p x x' = + let d = abs (x - x') + l = kpLengthScale p + s = sin (pi * d / kpPeriod p) + in kpSignalVar p * exp (-2 * s * s / (l * l)) +kernelFn Linear p x x' = + -- 内積カーネル: 1D では x·x' = x*x'。 + kpSignalVar p * (x * x') +kernelFn (Poly d) p x x' = + -- (γ x·x' + 1)^d, γ = 1/(2ℓ²)。1D では x·x' = x*x'。 + let l = kpLengthScale p + g = 1 / (2 * l * l) + in (g * (x * x') + 1) ^^ d + +-- | Build the kernel matrix @K(xs, xs')@ of shape @|xs| × |xs'|@. +-- +-- Fills a flat 'Storable.Vector' via @runST + MVector@ instead of +-- materialising the @|xs|·|xs'|@ lazy @[Double]@ list (one allocation per +-- kernel call). 'kernelFn' itself is unchanged so 'Periodic' +-- (signed-difference dependent) keeps working. +buildKernelMatrix :: Kernel -> KernelParams -> [Double] -> [Double] -> LA.Matrix Double +buildKernelMatrix ker p xs xs' = + let xv = VS.fromList xs + yv = VS.fromList xs' + n = VS.length xv + m = VS.length yv + out = runST $ do + v <- VSM.unsafeNew (n * m) + let go !i !j + | i >= n = pure () + | j >= m = go (i + 1) 0 + | otherwise = do + let xi = VS.unsafeIndex xv i + yj = VS.unsafeIndex yv j + VSM.unsafeWrite v (i * m + j) (kernelFn ker p xi yj) + go i (j + 1) + go 0 0 + VS.unsafeFreeze v + in LA.reshape m out + +-- --------------------------------------------------------------------------- +-- 多入力 (multivariate) 評価 +-- --------------------------------------------------------------------------- + +-- | [日本語]: 二乗距離行列 (@m × n@) にカーネル関数を適用する。 +-- 距離カーネル (RBF/Matern52/Periodic) 専用。 内積カーネル (Linear/Poly) は +-- 二乗距離から復元できないため error (multi-input gram は 'buildKernelMatrixMV' +-- が内積経路へ分岐するためここには到達しない)。 +-- [English]: Apply the kernel function to an @m × n@ matrix of squared +-- distances. Distance kernels (RBF\/Matern52\/Periodic) only. +-- Dot-product kernels (Linear\/Poly) cannot be recovered from the +-- squared distance and error out (the multi-input gram path never +-- reaches here, since 'buildKernelMatrixMV' branches to the +-- dot-product path first). +applyKernel :: Kernel -> KernelParams -> LA.Matrix Double -> LA.Matrix Double +applyKernel RBF p d2 = + let l2 = kpLengthScale p ** 2 + sf = kpSignalVar p + in KD.mapMatrix (\s -> sf * exp (- s / (2 * l2))) d2 +applyKernel Matern52 p d2 = + let l = kpLengthScale p + sf = kpSignalVar p + in KD.mapMatrix (\s -> let r = sqrt (max 0 s) + u = sqrt 5 * r / l + in sf * (1 + u + u * u / 3) * exp (- u)) d2 +applyKernel Periodic p d2 = + let l = kpLengthScale p + sf = kpSignalVar p + pr = kpPeriod p + in KD.mapMatrix (\s -> let r = sqrt (max 0 s) + ss = sin (pi * r / pr) + in sf * exp (- 2 * ss * ss / (l * l))) d2 +applyKernel Linear _ _ = error "applyKernel: Linear は内積カーネル。buildKernelMatrixMV/kEvalMV を使うこと" +applyKernel (Poly _) _ _ = error "applyKernel: Poly は内積カーネル。buildKernelMatrixMV/kEvalMV を使うこと" + +-- | Apply ARD scaling to (X, X') if 'kpLengthScales' is 'Just'. Returns +-- the (possibly rescaled) matrices and a 'KernelParams' with @ℓ = 1@ so +-- that 'applyKernel' divides by 1 (the per-dim ℓ_d already absorbed into +-- the column scaling). 'Nothing' = isotropic, returns inputs and params +-- unchanged. The 'Periodic' kernel does not support ARD. +ardScaleXY + :: Kernel -> KernelParams -> LA.Matrix Double -> LA.Matrix Double + -> (LA.Matrix Double, LA.Matrix Double, KernelParams) +ardScaleXY Periodic p x y = (x, y, p) +ardScaleXY _ p x y = case kpLengthScales p of + Nothing -> (x, y, p) + Just ls -> + let p_ = LA.cols x + lsExt = if LA.size ls == p_ + then ls + else LA.konst (kpLengthScale p) p_ -- safety fallback + invL = LA.cmap (1 /) lsExt -- 1 / ℓ_d + scaleCols m = m LA.<> LA.diag invL + x' = scaleCols x + y' = scaleCols y + p' = p { kpLengthScale = 1.0 } + in (x', y', p') + +-- | Build the kernel matrix @K(X, X')@ of shape @|X| × |X'|@ from +-- multi-input matrices. @X@ is @n × p@; @X'@ is @m × p@. +-- +-- When 'kpLengthScales' is 'Just', uses ARD: each input dimension is +-- scaled by @1 / ℓ_d@ before computing pairwise squared distances. +buildKernelMatrixMV + :: Kernel -> KernelParams -> LA.Matrix Double -> LA.Matrix Double + -> LA.Matrix Double +buildKernelMatrixMV Linear p x x' = + -- 内積カーネル: K = σ_f² X X'ᵀ (距離経路を通さない)。 + LA.scale (kpSignalVar p) (x LA.<> LA.tr x') +buildKernelMatrixMV (Poly d) p x x' = + -- (γ X X'ᵀ + 1)^d, γ = 1/(2ℓ²)。 + let l = kpLengthScale p + g = 1 / (2 * l * l) + in LA.cmap (\ip -> (g * ip + 1) ^^ d) (x LA.<> LA.tr x') +buildKernelMatrixMV ker p x x' = + let (xs, ys, p') = ardScaleXY ker p x x' + in applyKernel ker p' (KD.pairwiseSqDistXY xs ys) + +-- | [日本語]: 多入力カーネル評価 @k(a, b)@ (全カーネル対応・SVM 等の汎用経路)。 +-- 距離カーネル (RBF/Matern52/Periodic) は二乗距離、 内積カーネル (Linear/Poly) +-- は内積から評価する。 +-- [English]: Multi-input kernel evaluation @k(a, b)@ (supports all +-- kernels; the generic path used by SVM etc.). Distance kernels +-- (RBF\/Matern52\/Periodic) are evaluated from squared distance, +-- dot-product kernels (Linear\/Poly) from the dot product. +kEvalMV :: Kernel -> KernelParams -> LA.Vector Double -> LA.Vector Double -> Double +kEvalMV Linear p a b = kpSignalVar p * (a LA.<.> b) +kEvalMV (Poly d) p a b = + let l = kpLengthScale p + g = 1 / (2 * l * l) + in (g * (a LA.<.> b) + 1) ^^ d +kEvalMV ker p a b = + let d = a - b + in kernelOfParams ker p (d LA.<.> d) -- 距離カーネル: s = ‖a−b‖² + +-- | [日本語]: 固定パラメータ集合に対する特殊化カーネル関数。 GHC が +-- 'Model.GP' の @mkNoiseKernelFromD2@ 内側ループに密にインライン化できる +-- 単相 @Double -> Double@ を返す。 距離カーネル専用。 +-- [English]: Specialized kernel function for a fixed parameter set, +-- returning a monomorphic @Double -> Double@ that GHC can inline tightly +-- into the @mkNoiseKernelFromD2@ inner loop (in 'Model.GP'). Distance +-- kernels only. +{-# INLINE kernelOfParams #-} +kernelOfParams :: Kernel -> KernelParams -> (Double -> Double) +kernelOfParams RBF p = + let !l2 = kpLengthScale p ** 2 + !sf = kpSignalVar p + !inv2L2 = 1 / (2 * l2) + in \s -> sf * exp (- s * inv2L2) +kernelOfParams Matern52 p = + let !l = kpLengthScale p + !sf = kpSignalVar p + !invL = sqrt 5 / l + in \s -> let r = sqrt (max 0 s) + u = invL * r + in sf * (1 + u + u * u / 3) * exp (- u) +kernelOfParams Periodic p = + let !l = kpLengthScale p + !sf = kpSignalVar p + !pr = kpPeriod p + !invL2 = 1 / (l * l) + !invPr = pi / pr + in \s -> let r = sqrt (max 0 s) + ss = sin (invPr * r) + in sf * exp (- 2 * ss * ss * invL2) +kernelOfParams Linear _ = error "kernelOfParams: Linear は内積カーネル。kEvalMV を使うこと" +kernelOfParams (Poly _) _ = error "kernelOfParams: Poly は内積カーネル。kEvalMV を使うこと" diff --git a/src/Hanalyze/Model/KernelRegression.hs b/src/Hanalyze/Model/KernelRegression.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/KernelRegression.hs @@ -0,0 +1,507 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.KernelRegression +-- Description : カーネル回帰 (Nadaraya-Watson / kernel ridge regression) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Kernel regression — Nadaraya-Watson and kernel ridge regression. +-- +-- - 'Kernel' — RBF / Matérn / triangular / Epanechnikov kernel +-- functions. +-- - 'nwRegression' — Nadaraya-Watson (kernel-weighted moving average). +-- - 'kernelRidge' — kernel ridge regression +-- @ŷ(x*) = k(x*)ᵀ (K + λI)⁻¹ y@. +-- +-- Both are non-parametric smooth nonlinear regressors. Unlike 'Hanalyze.Model.GP', +-- they do not produce uncertainty estimates. +-- +-- NB: この 'Kernel' は回帰スムージング用 (Gaussian/Epanechnikov/…)。 +-- GP/SVM 族の共有カーネル (RBF/Matérn5/2/Periodic/Linear/Poly) は別モジュール +-- 'Hanalyze.Model.Kernel' として分離されている。 +-- +-- [English]: Kernel regression — Nadaraya-Watson and kernel ridge +-- regression. +-- +-- - 'Kernel' — RBF / Matérn / triangular / Epanechnikov kernel +-- functions. +-- - 'nwRegression' — Nadaraya-Watson (kernel-weighted moving average). +-- - 'kernelRidge' — kernel ridge regression +-- @ŷ(x*) = k(x*)ᵀ (K + λI)⁻¹ y@. +-- +-- Both are non-parametric smooth nonlinear regressors. Unlike +-- 'Hanalyze.Model.GP', they do not produce uncertainty estimates. +-- +-- NB: this 'Kernel' is for regression smoothing (Gaussian \/ Epanechnikov \/ +-- …). The shared kernel family used by the GP\/SVM group (RBF \/ Matérn5\/2 \/ +-- Periodic \/ Linear \/ Poly) has been split out into a separate module, +-- 'Hanalyze.Model.Kernel'. +module Hanalyze.Model.KernelRegression + ( Kernel (..) + , kernelEval + , kernelFromSqDist + , nwRegression + , nwRegressionMulti + , KernelRidgeFit (..) + , kernelRidge + , predictKernelRidge + , gridSearchBandwidth + , autoBandwidthBrent + -- * Multi-output (1D input, multiple Y columns) + , KernelRidgeFitMulti (..) + , kernelRidgeMulti + , predictKernelRidgeMulti + , fittedKernelRidgeMulti + , r2Multi + , autoTuneKernelRidgeMulti + , defaultHGrid + , defaultLamGrid + -- * Multi-input (primary API; X is @n × p@, Y is @n × q@) + , gramMatrixMV + , gramMatrixMVXY + , KernelRidgeFitMV (..) + , kernelRidgeMV + , predictKernelRidgeMV + , fittedKernelRidgeMV + , nwRegressionMV + ) where + +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Optim.LineSearch as LS +import qualified Hanalyze.Optim.Common as OC +import qualified Hanalyze.Stat.KernelDist as KD +import qualified Hanalyze.Stat.Cholesky as Chol + +-- --------------------------------------------------------------------------- +-- カーネル関数 +-- --------------------------------------------------------------------------- + +-- | Supported kernels. The bandwidth @h@ is passed separately at the +-- call site. +data Kernel + = Gaussian -- ^ @exp(-u²/2)@ (= RBF, infinite support). + | Epanechnikov -- ^ @0.75 (1-u²)@ on @|u| ≤ 1@. + | Triangular -- ^ @1 - |u|@ on @|u| ≤ 1@. + | Uniform -- ^ @0.5@ on @|u| ≤ 1@ (coarsest). + | TriCube -- ^ @(1-|u|³)³@ on @|u| ≤ 1@. + deriving (Show, Eq) + +-- | Evaluate the kernel at scaled squared distance @s = ‖x − x'‖² / h²@. +-- Generalizes 'kernelEval' to multivariate inputs: every supported +-- kernel is radially symmetric, so the kernel value depends only on +-- @‖x − x'‖ / h@. +-- +-- For the Gaussian kernel this avoids the redundant @sqrt@; for kernels +-- with bounded support (Epanechnikov / Triangular / Uniform / TriCube) +-- the boundary check uses @s ≤ 1@. +kernelFromSqDist :: Kernel -> Double -> Double +kernelFromSqDist k s = case k of + Gaussian -> exp (-0.5 * s) / sqrt (2 * pi) + Epanechnikov -> if s <= 1 then 0.75 * (1 - s) else 0 + Triangular -> if s <= 1 then 1 - sqrt s else 0 + Uniform -> if s <= 1 then 0.5 else 0 + TriCube -> if s <= 1 + then let u = sqrt s + t = 1 - u * u * u + in t * t * t + else 0 + +-- | Evaluate the kernel at @u = (x - x_i) / h@. +kernelEval :: Kernel -> Double -> Double +kernelEval k u = case k of + Gaussian -> exp (-0.5 * u * u) / sqrt (2 * pi) + Epanechnikov -> if abs u <= 1 then 0.75 * (1 - u * u) else 0 + Triangular -> if abs u <= 1 then 1 - abs u else 0 + Uniform -> if abs u <= 1 then 0.5 else 0 + TriCube -> if abs u <= 1 + then let t = 1 - (abs u)^(3::Int) + in t * t * t + else 0 + +-- --------------------------------------------------------------------------- +-- Nadaraya-Watson +-- --------------------------------------------------------------------------- + +-- | Single-output Nadaraya-Watson kernel regression. +-- +-- @ŷ(x*) = Σᵢ K_h(x* - xᵢ) yᵢ / Σᵢ K_h(x* - xᵢ)@ +-- +-- Delegates to 'nwRegressionMulti' by promoting @y@ to a one-column +-- matrix. +nwRegression :: Kernel + -> Double -- ^ Bandwidth @h@ (@> 0@). + -> V.Vector Double -- ^ Training inputs. + -> V.Vector Double -- ^ Training targets. + -> V.Vector Double -- ^ Prediction inputs. + -> V.Vector Double -- ^ Predictions. +nwRegression kern h xs ys xNew = + let yMat = LA.asColumn (LA.fromList (V.toList ys)) + mat = nwRegressionMulti kern h xs yMat xNew + in V.fromList (LA.toList (LA.flatten (mat LA.¿ [0]))) + +-- | Multi-output Nadaraya-Watson: reuse the same weight matrix across +-- every output column. With @W@ of shape @m × n@ and @Y@ of shape +-- @n × q@, the result is the row-normalized product @W · Y@ of shape +-- @m × q@. +nwRegressionMulti :: Kernel + -> Double -- ^ Bandwidth @h@. + -> V.Vector Double -- ^ Training inputs (length @n@). + -> LA.Matrix Double -- ^ Training response @Y@ (@n × q@). + -> V.Vector Double -- ^ Prediction inputs (length @m@). + -> LA.Matrix Double -- ^ Predictions (@m × q@). +nwRegressionMulti kern h xs ys xNew = + let n = V.length xs + m = V.length xNew + q = LA.cols ys + wMat = LA.fromLists + [ [ kernelEval kern ((xStar - xi) / h) + | xi <- V.toList xs ] + | xStar <- V.toList xNew ] -- (m × n) + num = wMat LA.<> ys -- (m × q) + dens = LA.toList (wMat LA.#> LA.konst 1 n) + rows = [ if d == 0 then replicate q 0 + else [ (num `LA.atIndex` (i, j)) / d | j <- [0 .. q - 1] ] + | (i, d) <- zip [0 .. m - 1] dens ] + in LA.fromLists rows + +-- --------------------------------------------------------------------------- +-- Kernel Ridge regression +-- --------------------------------------------------------------------------- + +-- | Kernel ridge regression fit; carries everything needed to predict. +data KernelRidgeFit = KernelRidgeFit + { krKernel :: Kernel + , krH :: Double + , krLambda :: Double + , krXs :: V.Vector Double -- ^ Training inputs. + , krAlpha :: LA.Vector Double -- ^ Solution @α = (K + λI)⁻¹ y@. + } deriving (Show) + +-- | Build the Gram matrix @K_{ij} = K_h(x_i - x_j)@. +gramMatrix :: Kernel -> Double -> V.Vector Double -> LA.Matrix Double +gramMatrix kern h xs = + let n = V.length xs + xv = V.toList xs + in (n LA.>< n) + [ kernelEval kern ((xi - xj) / h) + | xi <- xv, xj <- xv ] + +-- | Single-output kernel ridge regression. Delegates to +-- 'kernelRidgeMulti' by promoting @y@ to a one-column matrix and taking +-- column 0 of the resulting @α@ matrix. +kernelRidge :: Kernel + -> Double -- ^ Bandwidth @h@. + -> Double -- ^ Ridge penalty @λ@. + -> V.Vector Double -- ^ Training inputs. + -> V.Vector Double -- ^ Training targets. + -> KernelRidgeFit +kernelRidge kern h lam xs ys = + let yMat = LA.asColumn (LA.fromList (V.toList ys)) + mf = kernelRidgeMulti kern h lam xs yMat + a = LA.flatten (krmAlpha mf LA.¿ [0]) + in KernelRidgeFit kern h lam xs a + +-- | Predict at new inputs from a 'KernelRidgeFit'. +predictKernelRidge :: KernelRidgeFit -> V.Vector Double -> V.Vector Double +predictKernelRidge fit xNew = + V.map predict xNew + where + xs = krXs fit + h = krH fit + kern = krKernel fit + alpha = krAlpha fit + predict xStar = + let kVec = LA.fromList + [ kernelEval kern ((xStar - xi) / h) + | xi <- V.toList xs ] + in kVec LA.<.> alpha + +-- --------------------------------------------------------------------------- +-- Bandwidth selection +-- --------------------------------------------------------------------------- + +-- | Pick the bandwidth @h@ by leave-one-out cross-validation. Simple +-- grid search: returns the candidate with the smallest LOO RMSE. +gridSearchBandwidth + :: Kernel + -> V.Vector Double -- ^ Training inputs. + -> V.Vector Double -- ^ Training targets. + -> [Double] -- ^ Candidate bandwidths. + -> (Double, Double) -- ^ @(best h, best LOO RMSE)@. +gridSearchBandwidth kern xs ys hs = + let results = [(h, looErrNW kern xs ys h) | h <- hs] + best = head [ pair | pair <- results + , snd pair == minimum (map snd results) ] + in best + +-- | NW LOO-CV loss as a continuous function of @h@; shared with +-- 'autoBandwidthBrent'. +looErrNW :: Kernel -> V.Vector Double -> V.Vector Double -> Double -> Double +looErrNW kern xs ys h = + let n = V.length xs + yPred = V.imap + (\i _ -> + let xs' = V.ifilter (\j _ -> j /= i) xs + ys' = V.ifilter (\j _ -> j /= i) ys + xi = xs V.! i + pred = nwRegression kern h xs' ys' (V.singleton xi) + in V.head pred) + xs + err = V.zipWith (\y yh -> (y - yh)^(2::Int)) ys yPred + in sqrt (V.sum err / fromIntegral n) + +-- | Continuously optimize the bandwidth @h@ with Brent's method +-- (minimizing the LOO-CV loss). Assumes the bracket @[h_lo, h_hi]@ is +-- unimodal. Avoids enumerating discrete candidates the way +-- 'gridSearchBandwidth' does. +-- +-- Returns @(best h, best LOO RMSE)@. +autoBandwidthBrent + :: Kernel + -> V.Vector Double -- ^ Training inputs. + -> V.Vector Double -- ^ Training targets. + -> Double -- ^ Lower bound @h_lo@. + -> Double -- ^ Upper bound @h_hi@. + -> (Double, Double) +autoBandwidthBrent kern xs ys hLo hHi = + let cfg = LS.defaultBrentConfig { LS.bcMaxIter = 80, LS.bcTol = 1e-6 } + result = LS.brent cfg (\[h] -> looErrNW kern xs ys h) hLo hHi + hStar = head (OC.orBest result) + in (hStar, OC.orValue result) + +-- --------------------------------------------------------------------------- +-- 多出力 Kernel Ridge (Phase T2) +-- --------------------------------------------------------------------------- + +-- | Multi-output kernel ridge regression. With @Y@ of shape @n × q@, +-- solves each column independently but shares the Gram matrix @K@. +data KernelRidgeFitMulti = KernelRidgeFitMulti + { krmKernel :: Kernel + , krmH :: Double + , krmLambda :: Double + , krmXs :: V.Vector Double + , krmAlpha :: LA.Matrix Double -- α (n × q) + } deriving (Show) + +-- | Solve @(K + λI)⁻¹ Y@ once and reuse for every column (fast). +kernelRidgeMulti :: Kernel -> Double -> Double + -> V.Vector Double -> LA.Matrix Double + -> KernelRidgeFitMulti +kernelRidgeMulti kern h lam xs ys = + let n = V.length xs + kMat = gramMatrix kern h xs + regK = kMat + LA.scale lam (LA.ident n) + -- regK is SPD (K is PSD, λI is PD). Use Cholesky-based solve; + -- jitter retry handles ill-conditioned bandwidths. + alpha = Chol.cholSolveJitter regK ys + in KernelRidgeFitMulti kern h lam xs alpha + +-- | Predict @Ŷ@ for new inputs from a 'KernelRidgeFitMulti'. +predictKernelRidgeMulti :: KernelRidgeFitMulti -> V.Vector Double + -> LA.Matrix Double +predictKernelRidgeMulti fit xNew = + let xs = krmXs fit + h = krmH fit + kern = krmKernel fit + alpha = krmAlpha fit + kMat = LA.fromLists + [ [ kernelEval kern ((xStar - xi) / h) + | xi <- V.toList xs ] + | xStar <- V.toList xNew ] + in kMat LA.<> alpha + +-- | Fitted values at the training inputs (= @ŷ_train@). +fittedKernelRidgeMulti :: KernelRidgeFitMulti -> LA.Matrix Double +fittedKernelRidgeMulti fit = predictKernelRidgeMulti fit (krmXs fit) + +-- | Multi-output R² returned as a length-@q@ vector. @Y@ observed and +-- @Ŷ@ predicted both have shape @n × q@. +r2Multi :: LA.Matrix Double -> LA.Matrix Double -> V.Vector Double +r2Multi ys yhat = + let n = LA.rows ys + q = LA.cols ys + colR2 j = + let yc = LA.toList (LA.flatten (ys LA.¿ [j])) + yhc = LA.toList (LA.flatten (yhat LA.¿ [j])) + mu = sum yc / fromIntegral n + sst = sum [(y - mu)^(2::Int) | y <- yc] + sse = sum [(y - p)^(2::Int) | (y, p) <- zip yc yhc] + in if sst == 0 then 0 else 1 - sse / sst + in V.fromList [ colR2 j | j <- [0 .. q - 1] ] + +-- | [日本語]: @(h, λ)@ の joint grid search を closed-form LOOCV で行う。 +-- 各 (h, λ) 候補につき hat 行列の対角を 1 回だけ計算し、 全 q 出力の LOO 残差を +-- 一括評価する。 +-- +-- 戻り値: (best fit, best h, best λ, best mean LOO MSE) +-- [English]: A joint @(h, λ)@ grid search using the closed-form LOOCV. +-- Computes the hat-matrix diagonal once per (h, λ) candidate and evaluates +-- the LOO residuals for all q outputs in one batch. +-- +-- Returns: (best fit, best h, best λ, best mean LOO MSE) +autoTuneKernelRidgeMulti + :: Kernel + -> V.Vector Double -- xs (n) + -> LA.Matrix Double -- ys (n × q) + -> [Double] -- h candidates + -> [Double] -- λ candidates + -> (KernelRidgeFitMulti, Double, Double, Double) +autoTuneKernelRidgeMulti kern xs ys hs lams = + let n = V.length xs + q = LA.cols ys + tot = fromIntegral (n * q) :: Double + score h lam = + let kMat = gramMatrix kern h xs + regK = kMat + LA.scale lam (LA.ident n) + ainv = LA.inv regK + hat = kMat LA.<> ainv -- (n × n) + diagH = LA.takeDiag hat + yhat = hat LA.<> ys -- (n × q) + res = ys - yhat -- (n × q) + -- LOO 残差: r_i / (1 - H_ii)、列方向ブロードキャスト + denom = LA.cmap (\h_ii -> 1 - h_ii) diagH + invDenom = LA.cmap (\d -> if abs d < 1e-10 then 0 else 1/d) denom + scaler = LA.fromColumns (replicate q invDenom) + looR = res * scaler + sse = LA.sumElements (looR * looR) + in sse / tot + grid = [ (h, lam, score h lam) | h <- hs, lam <- lams ] + best@(bestH, bestL, bestS) = head [ p | p@(_,_,s) <- grid + , s == minimum (map (\(_,_,x) -> x) grid) ] + _ = best + fit = kernelRidgeMulti kern bestH bestL xs ys + in (fit, bestH, bestL, bestS) + +-- | Log-spaced bandwidth candidates. @defaultHGrid xs@ produces 30 +-- candidates spanning the range of @xs@. +defaultHGrid :: V.Vector Double -> [Double] +defaultHGrid xs = + let xv = V.toList xs + mn = minimum xv + mx = maximum xv + rng = mx - mn + lo = max 1e-3 (rng / 100) + hi = max (lo * 10) rng + n = 30 + lLo = log lo + lHi = log hi + step = (lHi - lLo) / fromIntegral (n - 1) + in [ exp (lLo + fromIntegral i * step) | i <- [0 .. n - 1 :: Int] ] + +-- | Log-spaced ridge-penalty candidates (10 values from 1e-6 to 1). +defaultLamGrid :: [Double] +defaultLamGrid = + let n = 10 + lLo = log 1e-6 + lHi = log 1e0 + step = (lHi - lLo) / fromIntegral (n - 1) + in [ exp (lLo + fromIntegral i * step) | i <- [0 .. n - 1 :: Int] ] + +-- --------------------------------------------------------------------------- +-- Multi-input (multivariate X) API +-- +-- These functions take @X@ as an @n × p@ matrix (rows = samples) and use a +-- single shared bandwidth @h@ across every input dimension. Distance +-- matrices are computed via 'Hanalyze.Stat.KernelDist' (BLAS GEMM) and the kernel +-- function is applied element-wise via 'LA.cmap'; no list traversals over +-- the @O(n²)@ pair set. +-- +-- For axis-specific bandwidths, scale columns of @X@ by @1 / h_d@ before +-- calling these functions. +-- --------------------------------------------------------------------------- + +-- | Multi-input Gram matrix @K[i, j] = κ(‖X[i,:] − X[j,:]‖ / h)@. +gramMatrixMV :: Kernel -> Double -> LA.Matrix Double -> LA.Matrix Double +gramMatrixMV kern h x = + let h2 = h * h + d2 = KD.pairwiseSqDist x + in LA.cmap (\s -> kernelFromSqDist kern (s / h2)) d2 + +-- | Multi-input cross Gram matrix @K[i, j] = κ(‖X[i,:] − Y[j,:]‖ / h)@. +gramMatrixMVXY + :: Kernel -> Double + -> LA.Matrix Double -- ^ Query @X_*@ (@m × p@). + -> LA.Matrix Double -- ^ Training @X@ (@n × p@). + -> LA.Matrix Double -- ^ Result (@m × n@). +gramMatrixMVXY kern h xs ts = + let h2 = h * h + d2 = KD.pairwiseSqDistXY xs ts + in LA.cmap (\s -> kernelFromSqDist kern (s / h2)) d2 + +-- | Multi-input kernel ridge fit. Holds the training matrix and the +-- solution coefficients; @α@ has shape @n × q@. +data KernelRidgeFitMV = KernelRidgeFitMV + { krmvKernel :: Kernel + , krmvH :: Double + , krmvLambda :: Double + , krmvXs :: LA.Matrix Double -- ^ Training inputs (@n × p@). + , krmvAlpha :: LA.Matrix Double -- ^ @(K + λI)⁻¹ Y@ (@n × q@). + } deriving (Show) + +-- | Multi-input multi-output kernel ridge regression. +-- +-- @α = (K + λI)⁻¹ Y@ with @K = gramMatrixMV kern h X@. Solving once and +-- reusing across the @q@ output columns. +kernelRidgeMV + :: Kernel + -> Double -- ^ Bandwidth @h@. + -> Double -- ^ Ridge penalty @λ@. + -> LA.Matrix Double -- ^ Training inputs @X@ (@n × p@). + -> LA.Matrix Double -- ^ Training response @Y@ (@n × q@). + -> KernelRidgeFitMV +kernelRidgeMV kern h lam x y = + let n = LA.rows x + kMat = gramMatrixMV kern h x + regK = kMat + LA.scale lam (LA.ident n) + -- SPD: K + λI. Use Cholesky-based solve. + alpha = Chol.cholSolveJitter regK y + in KernelRidgeFitMV kern h lam x alpha + +-- | Predict @Ŷ = K_* α@ for new query inputs (@m × p@). Output shape is +-- @m × q@. +predictKernelRidgeMV :: KernelRidgeFitMV -> LA.Matrix Double -> LA.Matrix Double +predictKernelRidgeMV fit xNew = + gramMatrixMVXY (krmvKernel fit) (krmvH fit) xNew (krmvXs fit) + LA.<> krmvAlpha fit + +-- | Fitted values at the training inputs. +fittedKernelRidgeMV :: KernelRidgeFitMV -> LA.Matrix Double +fittedKernelRidgeMV fit = predictKernelRidgeMV fit (krmvXs fit) + +-- | Multi-input multi-output Nadaraya-Watson regression. +-- +-- @ŷ(x*) = (Σⱼ K_h(x* − xⱼ) yⱼ) / Σⱼ K_h(x* − xⱼ)@, computed for every +-- query row in one pass via @W = K(X_*, X)@ then @W Y / row-sums@. +nwRegressionMV + :: Kernel + -> Double -- ^ Bandwidth @h@. + -> LA.Matrix Double -- ^ Training inputs @X@ (@n × p@). + -> LA.Matrix Double -- ^ Training response @Y@ (@n × q@). + -> LA.Matrix Double -- ^ Query inputs @X_*@ (@m × p@). + -> LA.Matrix Double -- ^ Predictions (@m × q@). +nwRegressionMV kern h xs ys xNew = + -- P35a (2026-05-07): replace @LA.diag safe LA.<> num@ (m×m dense + -- diag matrix + GEMM) with broadcast outer product → elementwise. + -- + -- P35b explored further: fusing the @num@ and @denom@ GEMVs into a + -- single GEMM via @yAug = [ys | onesN]@ to traverse the 8 MB + -- weight matrix only once (it exceeds typical L3). It /regressed/ + -- at q=1 (33.8 → 37 ms) because (a) @LA.|||@ allocates a fresh + -- 8 MB matrix, and (b) BLAS GEMM with k=2 RHS columns has higher + -- block-tiling overhead than two GEMV calls. For q ≫ 1 the fusion + -- would win, but the bench is q=1 so the unfused form stays. + -- + -- The remaining bottleneck is @LA.cmap kernelFromSqDist@ over the + -- 1M-cell weight matrix — a per-element Haskell function call per + -- exp(). FFI'd vectorized exp (libmvec / SLEEF) would close the + -- 3.6× gap to sklearn but is out of scope here. + let !wMat = gramMatrixMVXY kern h xNew xs -- m × n + !num = wMat LA.<> ys -- m × q + !onesN = LA.konst 1 (LA.cols wMat) :: LA.Vector Double + !denom = wMat LA.#> onesN -- m + !safe = LA.cmap (\d -> if d == 0 then 1 else 1 / d) denom + !onesQ = LA.konst 1 (LA.cols num) :: LA.Vector Double + !safeBc = LA.outer safe onesQ -- m × q + in safeBc * num diff --git a/src/Hanalyze/Model/LM.hs b/src/Hanalyze/Model/LM.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/LM.hs @@ -0,0 +1,314 @@ +-- | +-- Module : Hanalyze.Model.LM +-- Description : 最小二乗法による線形回帰の fit・予測・信頼/予測区間 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 最小二乗法による線形回帰の fit・予測・信頼/予測区間。 +-- +-- hmatrix の @\\\\@ (LAPACK) を使って @β = (XᵀX)⁻¹ Xᵀ y@ を解く。 +-- @t × √(s² xᵢᵀ(XᵀX)⁻¹xᵢ)@ による信頼区間・予測区間、 CLI やレポート +-- ビルダーから使うための @DataFrame@ の便利アダプタを提供する。 +-- +-- [English]: Fitting, prediction, and confidence\/prediction intervals for +-- ordinary linear regression by least squares. +-- +-- Solves @β = (XᵀX)⁻¹ Xᵀ y@ via hmatrix's @\\\\@ (LAPACK). Provides +-- confidence and prediction bands using +-- @t × √(s² xᵢᵀ(XᵀX)⁻¹xᵢ)@ and convenient adapters from a +-- @DataFrame@ for use from the CLI and report builder. +module Hanalyze.Model.LM + ( LinearModel (..) + , CIBand (..) + , SmoothFit (..) + -- * Matrix-canonical fit + , fitLM + , predictLM + -- * Vector wrapper (1-output convenience) + , fitLMVec + , predictLMVec + -- * Design matrices + , designMatrix + , polyDesignMatrix + , multiPolyDesignMatrix + , linspace + -- * DataFrame helpers + , fitDataFrameLM + , confidenceBand + , confidenceBandAt + , predictionBandAt + , fitWithCI + , fitPolyWithSmooth + ) where + +import qualified DataFrame.Internal.DataFrame as DXD +import Hanalyze.DataIO.Convert (getDoubleVec) +import Hanalyze.Model.Core (FitResult (..), Model (..), Band (..), + coefficientsV, residualsV) + +import Data.Text (Text) +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA +import Statistics.Distribution (quantile) +import Statistics.Distribution.StudentT (studentT) + +data LinearModel = LinearModel + deriving (Show) + +instance Model LinearModel where + fit _ = fitLM + predict _ = predictLM + +-- | [日本語]: Ordinary Least Squares (Matrix canonical、 多出力対応): +-- B = (XᵀX)⁻¹ Xᵀ Y、各列を独立に解く。 +-- [English]: Ordinary Least Squares (matrix-canonical form, supports +-- multiple outputs): B = (XᵀX)⁻¹ Xᵀ Y, solving each column independently. +fitLM :: LA.Matrix Double -> LA.Matrix Double -> FitResult +fitLM x y = + let beta = x LA.<\> y -- p × q + yHat = x LA.<> beta -- n × q + resid = y - yHat + r2 = computeR2Multi y yHat + in FitResult beta yHat resid r2 + +predictLM :: LA.Matrix Double -> LA.Matrix Double -> LA.Matrix Double +predictLM beta xNew = xNew LA.<> beta + +-- | [日本語]: 単一出力 (Vector y) の便利ラッパ。@asColumn@ で 1 列行列に変換。 +-- [English]: Convenience wrapper for a single output (Vector y). Converts +-- to a 1-column matrix with @asColumn@. +fitLMVec :: LA.Matrix Double -> LA.Vector Double -> FitResult +fitLMVec x y = fitLM x (LA.asColumn y) + +-- | [日本語]: 1 出力での予測 (β は Vector)。 +-- [English]: Prediction for a single output (β is a Vector). +predictLMVec :: LA.Vector Double -> LA.Matrix Double -> LA.Vector Double +predictLMVec beta xNew = xNew LA.#> beta + +-- | Build intercept + single predictor design matrix [1, x]. +designMatrix :: V.Vector Double -> LA.Matrix Double +designMatrix xs = LA.fromColumns + [ LA.konst 1.0 n + , LA.fromList (V.toList xs) + ] + where n = V.length xs + +-- | Convenience: fit a simple LM directly from a DataFrame. +fitDataFrameLM :: DXD.DataFrame -> Text -> Text -> Maybe FitResult +fitDataFrameLM df xCol yCol = do + xVec <- getDoubleVec xCol df + yVec <- getDoubleVec yCol df + let dm = designMatrix xVec + y = LA.fromList (V.toList yVec) + return (fitLMVec dm y) + +data CIBand = CIBand + { lowerBound :: [Double] + , upperBound :: [Double] + , ciLevel :: Double + } deriving (Show) + +-- | [日本語]: Pointwise confidence band for the mean response (1 出力前提)。 +-- Formula: ŷᵢ ± t_{α/2, n−p} × sqrt(s² × xᵢᵀ (XᵀX)⁻¹ xᵢ) +-- +-- 訓練設計行列上で評価する版 (= 各点の中心は fitted)。 grid 評価が要るときは +-- @confidenceBandAt@ を使う。 +-- [English]: Pointwise confidence band for the mean response (assumes a +-- single output). Formula: ŷᵢ ± t_{α/2, n−p} × sqrt(s² × xᵢᵀ (XᵀX)⁻¹ xᵢ). +-- +-- The variant evaluated on the training design matrix (= each point's +-- center is the fitted value). Use @confidenceBandAt@ when grid +-- evaluation is needed. +confidenceBand :: LA.Matrix Double -> FitResult -> Double -> CIBand +confidenceBand x res level = confidenceBandAt x res level x + +-- | [日本語]: 訓練設計行列 @xTrain@ で推定した分散核 (s², (XᵀX)⁻¹, t 値) を、 別の +-- 評価点設計行列 @xEval@ の各行で band 化する。 中心は @xEval·β@、 半幅は +-- @t × √(s² × x₀ᵀ (XᵀX)⁻¹ x₀)@。 自由度・s² は訓練データで決まる。 +-- +-- ★grid 評価の核: 訓練点ではなく等間隔 grid の設計行列を @xEval@ に渡すと、 +-- 回帰曲線・CI 帯が滑らかになる (= 疎・不均一データのガタつき解消)。 訓練点を +-- そのまま渡せば @confidenceBand@ と一致する (LM では @xTrain·β = fitted@)。 +-- [English]: Takes the variance core (s², (XᵀX)⁻¹, t value) estimated on +-- the training design matrix @xTrain@ and turns each row of a separate +-- evaluation-point design matrix @xEval@ into a band. The center is +-- @xEval·β@, and the half-width is @t × √(s² × x₀ᵀ (XᵀX)⁻¹ x₀)@. The +-- degrees of freedom and s² are determined by the training data. +-- +-- ★The core of grid evaluation: passing an evenly-spaced grid's design +-- matrix (instead of the training points) as @xEval@ smooths out the +-- regression curve and CI band (= removes jaggedness from sparse\/uneven +-- data). Passing the training points directly reproduces +-- @confidenceBand@ (for LM, @xTrain·β = fitted@). +confidenceBandAt + :: LA.Matrix Double -- ^ [日本語]: 訓練設計行列 X (分散核の推定元)。 [English]: The training design matrix X (source of the variance core). + -> FitResult -- ^ [日本語]: fit 結果 (β / 残差)。 [English]: The fit result (β \/ residuals). + -> Double -- ^ [日本語]: 信頼水準 (例 0.95)。 [English]: The confidence level (e.g. 0.95). + -> LA.Matrix Double -- ^ [日本語]: 評価点設計行列 X₀ (band を評価する行)。 [English]: The evaluation-point design matrix X₀ (rows at which the band is evaluated). + -> CIBand +confidenceBandAt xTrain res level xEval = + let df = fromIntegral (LA.rows xTrain - LA.cols xTrain) + beta = coefficientsV res + rs = LA.toRows xEval + yHats = [ xi `LA.dot` beta | xi <- rs ] + -- df<=0 (飽和・過剰指定) は s²=0/0・studentT が例外 → CI 定義不能。 + -- 幅ゼロ帯 (lo=hi=ŷ) を返し、 帯は線に潰す (呼び元は線のみ描く)。 + in if df <= 0 + then CIBand yHats yHats level + else + let resV = residualsV res + s2 = (resV `LA.dot` resV) / df + xtxi = LA.inv (LA.tr xTrain LA.<> xTrain) + tVal = quantile (studentT df) ((1.0 + level) / 2.0) + se xi = tVal * sqrt (s2 * (xi `LA.dot` (xtxi LA.#> xi))) + los = zipWith (\yh xi -> yh - se xi) yHats rs + his = zipWith (\yh xi -> yh + se xi) yHats rs + in CIBand los his level + +-- | [日本語]: 予測区間 (prediction interval) 版の @confidenceBandAt@。 半幅に +-- __観測分散__ @σ̂²@ を 1 つ加える: @t × √(s² × (1 + x₀ᵀ (XᵀX)⁻¹ x₀))@ +-- (CI には @1 +@ が無い)。 = 新規観測 1 点が入る区間 (平均の信頼区間より広い)。 +-- statsmodels の @get_prediction().summary_frame()['obs_ci_lower/upper']@ +-- と一致する。 +-- [English]: The prediction-interval version of @confidenceBandAt@. Adds +-- one unit of __observation variance__ @σ̂²@ to the half-width: +-- @t × √(s² × (1 + x₀ᵀ (XᵀX)⁻¹ x₀))@ (the CI has no @1 +@ term). This is +-- the interval that contains a single new observation (wider than the +-- confidence interval for the mean). Matches statsmodels' +-- @get_prediction().summary_frame()['obs_ci_lower/upper']@. +-- (hanalyze-portable) +predictionBandAt + :: LA.Matrix Double -- ^ [日本語]: 訓練設計行列 X (分散核の推定元)。 [English]: The training design matrix X (source of the variance core). + -> FitResult -- ^ [日本語]: fit 結果 (β / 残差)。 [English]: The fit result (β \/ residuals). + -> Double -- ^ [日本語]: 信頼水準 (例 0.95)。 [English]: The confidence level (e.g. 0.95). + -> LA.Matrix Double -- ^ [日本語]: 評価点設計行列 X₀ (band を評価する行)。 [English]: The evaluation-point design matrix X₀ (rows at which the band is evaluated). + -> CIBand +predictionBandAt xTrain res level xEval = + let df = fromIntegral (LA.rows xTrain - LA.cols xTrain) + beta = coefficientsV res + rs = LA.toRows xEval + yHats = [ xi `LA.dot` beta | xi <- rs ] + -- df<=0 は CI/PI 定義不能 → 幅ゼロ帯 (線のみ)。 @confidenceBandAt@ と同方針。 + in if df <= 0 + then CIBand yHats yHats level + else + let resV = residualsV res + s2 = (resV `LA.dot` resV) / df + xtxi = LA.inv (LA.tr xTrain LA.<> xTrain) + tVal = quantile (studentT df) ((1.0 + level) / 2.0) + se xi = tVal * sqrt (s2 * (1 + xi `LA.dot` (xtxi LA.#> xi))) -- ★CI との差は (1 +) + los = zipWith (\yh xi -> yh - se xi) yHats rs + his = zipWith (\yh xi -> yh + se xi) yHats rs + in CIBand los his level + +-- | Fit LM and compute confidence band in one step. +fitWithCI :: Double -> DXD.DataFrame -> Text -> Text -> Maybe (FitResult, CIBand) +fitWithCI level df xCol yCol = do + xVec <- getDoubleVec xCol df + yVec <- getDoubleVec yCol df + let dm = designMatrix xVec + y = LA.fromList (V.toList yVec) + res = fitLMVec dm y + return (res, confidenceBand dm res level) + +-- | Polynomial design matrix [1, x, x², …, xᵈ]. +polyDesignMatrix :: Int -> V.Vector Double -> LA.Matrix Double +polyDesignMatrix degree xs = LA.fromColumns + [ LA.fromList [ x ^ k | x <- V.toList xs ] + | k <- [0 .. degree] + ] + +-- | Multi-column polynomial design matrix. +-- Builds [1, x1, x1², …, x1^d1, x2, …, x2^d2, …] from a list of (column, degree) pairs. +multiPolyDesignMatrix :: [(V.Vector Double, Int)] -> LA.Matrix Double +multiPolyDesignMatrix [] = error "multiPolyDesignMatrix: empty predictor list" +multiPolyDesignMatrix colDegs@((firstXs, _) : _) = + LA.fromColumns (intercept : concatMap polyExpand colDegs) + where + n = V.length firstXs + intercept = LA.konst 1.0 n + polyExpand (xs, deg) = + [ LA.fromList [ x ^ k | x <- V.toList xs ] | k <- [1 .. deg] ] + +-- | Grid of evenly spaced values from lo to hi. +linspace :: Double -> Double -> Int -> [Double] +linspace lo hi n + | n <= 1 = [lo] + | otherwise = [ lo + fromIntegral i * (hi - lo) / fromIntegral (n - 1) + | i <- [0 .. n - 1] ] + +-- | Pre-computed smooth curve data for plotting (evaluated on a fine grid). +data SmoothFit = SmoothFit + { sfX :: [Double] + , sfFit :: [Double] + , sfLower :: [Double] + , sfUpper :: [Double] + , sfHasBand :: Bool + } deriving (Show) + +-- | Fit polynomial LM of given degree and compute a smooth curve with optional band +-- on a fine grid of nGrid points for clean visualisation. +fitPolyWithSmooth + :: Band + -> Int + -> DXD.DataFrame + -> Text + -> Text + -> Maybe (FitResult, SmoothFit) +fitPolyWithSmooth band nGrid df xCol yCol = do + xVec <- getDoubleVec xCol df + yVec <- getDoubleVec yCol df + let degree = 1 + dm = polyDesignMatrix degree xVec + y = LA.fromList (V.toList yVec) + res = fitLMVec dm y + beta = coefficientsV res + + xLa = LA.fromList (V.toList xVec) + xGrid = V.fromList (linspace (LA.minElement xLa) (LA.maxElement xLa) nGrid) + dmG = polyDesignMatrix degree xGrid + yGrid = LA.toList (dmG LA.#> beta) + + dfStat = fromIntegral (LA.rows dm - LA.cols dm) :: Double + resV = residualsV res + s2 = (resV `LA.dot` resV) / dfStat + xtxi = LA.inv (LA.tr dm LA.<> dm) + gRows = LA.toRows dmG + + computeBand level isPI + -- df<=0 (飽和) は s²=0/0・studentT が例外 → 帯を線に潰す (lo=hi=yGrid)。 + | dfStat <= 0 = (yGrid, yGrid) + | otherwise = + let tVal = quantile (studentT dfStat) ((1.0 + level) / 2.0) + extra = if isPI then 1.0 else 0.0 + halfW xi = tVal * sqrt (s2 * (extra + xi `LA.dot` (xtxi LA.#> xi))) + los = zipWith (\yh xi -> yh - halfW xi) yGrid gRows + his = zipWith (\yh xi -> yh + halfW xi) yGrid gRows + in (los, his) + + case band of + NoBand -> + return (res, SmoothFit (V.toList xGrid) yGrid yGrid yGrid False) + CI level -> + let (los, his) = computeBand level False + in return (res, SmoothFit (V.toList xGrid) yGrid los his True) + PI level -> + let (los, his) = computeBand level True + in return (res, SmoothFit (V.toList xGrid) yGrid los his True) + +-- | [日本語]: 各列ごとに R² を計算 (多出力対応)。 +-- [English]: Computes R² for each column (supports multiple outputs). +computeR2Multi :: LA.Matrix Double -> LA.Matrix Double -> LA.Vector Double +computeR2Multi y yHat = + let q = LA.cols y + in LA.fromList + [ let yj = LA.flatten (y LA.¿ [j]) + yhj = LA.flatten (yHat LA.¿ [j]) + resid = yj - yhj + yMean = LA.sumElements yj / fromIntegral (LA.size yj) + dev = LA.cmap (subtract yMean) yj + ssRes = resid `LA.dot` resid + ssTot = dev `LA.dot` dev + in if ssTot == 0 then 0 + else 1.0 - ssRes / ssTot + | j <- [0 .. q - 1] ] diff --git a/src/Hanalyze/Model/LM/Diagnostics.hs b/src/Hanalyze/Model/LM/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/LM/Diagnostics.hs @@ -0,0 +1,278 @@ +-- | +-- Module : Hanalyze.Model.LM.Diagnostics +-- Description : 線形回帰の推論統計量 (標準誤差・t/p 値・F 統計量・AIC/BIC・レバレッジ・Cook's distance) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Inference and residual diagnostics for ordinary linear regression. +-- +-- Provides standard errors, t / p-values, F-statistic, information +-- criteria (AIC / BIC), leverage / hat-diagonal, standardised +-- residuals, and Cook's distance. All multi-output operators +-- (@q@ output columns) follow the @Matrix p × q@ canonical convention, +-- with @Vector p@ wrappers for the @q = 1@ case. +module Hanalyze.Model.LM.Diagnostics + ( -- * t-quantile + ciTValue + -- * Per-coefficient inference (Multi-output canonical) + , CoefStats (..) + , lmSigmaSqMulti + , lmCovarianceMulti + , lmStdErrorsMulti + , lmCoefStatsMulti + -- * 1-output convenience wrappers + , lmStdErrors + , lmCoefStats + -- * Whole-model F-statistic + , FStat (..) + , lmFStatistic + -- * Information criteria + , ICs (..) + , lmInformationCriteria + , lmInformationCriteriaMulti + -- * Residual diagnostics + , hatDiagonal + , standardizedResiduals + , cooksDistance + -- * Predictor utilities + , predictorStdDevs + ) where + +import Hanalyze.Model.Core (FitResult (..)) +import qualified Numeric.LinearAlgebra as LA +import qualified Statistics.Distribution as SD +import qualified Statistics.Distribution.FDistribution as FD +import Statistics.Distribution.StudentT (studentT) + +-- --------------------------------------------------------------------------- +-- t-quantile +-- --------------------------------------------------------------------------- + +-- | Two-sided Student-t quantile @t_{α/2, df}@ at confidence +-- @level@ (e.g. @0.95@) and degrees of freedom @df@. +ciTValue :: Double -> Int -> Double +ciTValue level df = + SD.quantile (studentT (fromIntegral df)) ((1.0 + level) / 2.0) + +-- --------------------------------------------------------------------------- +-- Helpers shared across diagnostics +-- --------------------------------------------------------------------------- + +-- | Per-output residual variance @σ²_k = RSS_k / (n − p)@. Returns a +-- length-@q@ vector. +lmSigmaSqMulti :: FitResult -> LA.Vector Double +lmSigmaSqMulti res = + let r = residuals res + n = LA.rows r + p = LA.rows (coefficients res) + df = fromIntegral (n - p) :: Double + cols = LA.toColumns r + ssRes c = c `LA.dot` c + in LA.fromList [ ssRes c / df | c <- cols ] + +-- | Per-output coefficient covariance matrices. Returns a list of +-- @q@ symmetric @p × p@ matrices, one per output column: +-- @Cov_k = σ²_k × (XᵀX)⁻¹@. +lmCovarianceMulti :: LA.Matrix Double -> FitResult -> [LA.Matrix Double] +lmCovarianceMulti x res = + let xtxi = LA.inv (LA.tr x LA.<> x) + sig2s = LA.toList (lmSigmaSqMulti res) + in [ LA.scale s2 xtxi | s2 <- sig2s ] + +-- --------------------------------------------------------------------------- +-- Standard errors +-- --------------------------------------------------------------------------- + +-- | Per-coefficient, per-output standard errors as a @p × q@ matrix: +-- @SE_{jk} = √(diag(Cov_k)_j)@. +lmStdErrorsMulti :: LA.Matrix Double -> FitResult -> LA.Matrix Double +lmStdErrorsMulti x res = + let covs = lmCovarianceMulti x res + cols = [ LA.cmap sqrt (LA.takeDiag c) | c <- covs ] + in LA.fromColumns cols + +-- | 1-output convenience: standard errors as a length-@p@ vector. +lmStdErrors :: LA.Matrix Double -> FitResult -> LA.Vector Double +lmStdErrors x res = LA.flatten (lmStdErrorsMulti x res) + +-- --------------------------------------------------------------------------- +-- Coefficient stats (SE / t / two-sided p) +-- --------------------------------------------------------------------------- + +-- | Per-coefficient inference triple: standard error, Wald @t@ value, +-- and two-sided @p@ value @2 × (1 − F_t(|t|; df))@. +data CoefStats = CoefStats + { csSE :: !Double + , csTValue :: !Double + , csPValue :: !Double + } deriving (Show, Eq) + +-- | Per-output 'CoefStats' for every coefficient. Returns a list of +-- @q@ lists, each of length @p@. +lmCoefStatsMulti :: LA.Matrix Double -> FitResult -> [[CoefStats]] +lmCoefStatsMulti x res = + let n = LA.rows x + p = LA.cols x + df = fromIntegral (n - p) :: Double + tDist = studentT df + betaCs = LA.toColumns (coefficients res) + seCs = LA.toColumns (lmStdErrorsMulti x res) + pair beta se = + zipWith + (\b s -> + let t = if s == 0 then 0 else b / s + pv = 2.0 * (1.0 - SD.cumulative tDist (abs t)) + in CoefStats s t pv) + (LA.toList beta) (LA.toList se) + in zipWith pair betaCs seCs + +-- | 1-output convenience: 'CoefStats' for every coefficient. +lmCoefStats :: LA.Matrix Double -> FitResult -> [CoefStats] +lmCoefStats x res = head (lmCoefStatsMulti x res) + +-- --------------------------------------------------------------------------- +-- F-statistic (whole-model) +-- --------------------------------------------------------------------------- + +-- | Whole-model F-statistic and its right-tail @p@ value: +-- @F = ((TSS − RSS)/(p − 1)) / (RSS/(n − p))@, +-- @F ~ F(p − 1, n − p)@. +data FStat = FStat + { fsValue :: !Double + , fsPValue :: !Double + , fsDf1 :: !Int + , fsDf2 :: !Int + } deriving (Show, Eq) + +-- | Whole-model F-statistic per output column. The first design-matrix +-- column is assumed to be the intercept (so the effective number of +-- predictors is @p − 1@). For @p ≤ 1@ or @n ≤ p@ returns @F = 0@, +-- @p = 1@. +lmFStatistic :: LA.Matrix Double -> FitResult -> [FStat] +lmFStatistic x res = + let n = LA.rows x + p = LA.cols x + df1 = p - 1 + df2 = n - p + yMat = fitted res + residuals res + yCs = LA.toColumns yMat + rCs = LA.toColumns (residuals res) + go yj rj = + if df1 <= 0 || df2 <= 0 + then FStat 0 1 (max df1 0) (max df2 0) + else + let yMean = LA.sumElements yj / fromIntegral (LA.size yj) + dev = LA.cmap (subtract yMean) yj + tss = dev `LA.dot` dev + rss = rj `LA.dot` rj + ess = tss - rss + fVal = (ess / fromIntegral df1) / (rss / fromIntegral df2) + pVal = if rss == 0 + then 0 + else SD.complCumulative + (FD.fDistribution df1 df2) fVal + in FStat fVal pVal df1 df2 + in zipWith go yCs rCs + +-- --------------------------------------------------------------------------- +-- Information criteria (Gaussian LM) +-- --------------------------------------------------------------------------- + +-- | Gaussian log-likelihood, AIC, and BIC under the standard +-- @ε ~ N(0, σ²)@ assumption. +data ICs = ICs + { icLogLik :: !Double + , icAIC :: !Double + , icBIC :: !Double + } deriving (Show, Eq) + +-- | Per-output information criteria. +-- +-- @ +-- logLik = −n/2 × (log(2π) + log(RSS/n) + 1) +-- AIC = 2k − 2 × logLik (k = p + 1, σ² counted) +-- BIC = k × log(n) − 2 × logLik +-- @ +lmInformationCriteriaMulti :: FitResult -> [ICs] +lmInformationCriteriaMulti res = + let r = residuals res + n = LA.rows r + p = LA.rows (coefficients res) + k = fromIntegral (p + 1) :: Double + nD = fromIntegral n :: Double + cols = LA.toColumns r + go c = + let rss = c `LA.dot` c + logLik = -nD / 2.0 * + (log (2.0 * pi) + log (rss / nD) + 1.0) + aic = 2.0 * k - 2.0 * logLik + bic = k * log nD - 2.0 * logLik + in ICs logLik aic bic + in map go cols + +-- | 1-output convenience. +lmInformationCriteria :: FitResult -> ICs +lmInformationCriteria = head . lmInformationCriteriaMulti + +-- --------------------------------------------------------------------------- +-- Residual diagnostics +-- --------------------------------------------------------------------------- + +-- | Hat-matrix diagonal @h_ii = xᵢᵀ (XᵀX)⁻¹ xᵢ@. Returns a length-@n@ +-- vector independent of the response. +hatDiagonal :: LA.Matrix Double -> LA.Vector Double +hatDiagonal x = + let xtxi = LA.inv (LA.tr x LA.<> x) + rows = LA.toRows x + in LA.fromList [ xi `LA.dot` (xtxi LA.#> xi) | xi <- rows ] + +-- | Internally studentised residual @r̃_i = r_i / (σ × √(1 − h_ii))@. +-- 1-output only (multi-output leverage is the same; the standardisation +-- divides by per-column @σ@). Returns a length-@n@ vector. +standardizedResiduals :: LA.Matrix Double -> FitResult -> LA.Vector Double +standardizedResiduals x res = + let n = LA.rows x + p = LA.cols x + rj = LA.flatten (residuals res) -- assumes q = 1 + rss = rj `LA.dot` rj + sigma = sqrt (rss / fromIntegral (n - p)) + h = hatDiagonal x + one h_ = max 0.0 (1.0 - h_) + in LA.fromList + [ if sigma == 0 || one hi == 0 + then 0 + else ri / (sigma * sqrt (one hi)) + | (ri, hi) <- zip (LA.toList rj) (LA.toList h) ] + +-- | Cook's distance @D_i = (r̃_i² / p) × (h_ii / (1 − h_ii))@. +-- 1-output only. Returns a length-@n@ vector. +cooksDistance :: LA.Matrix Double -> FitResult -> LA.Vector Double +cooksDistance x res = + let p = fromIntegral (LA.cols x) :: Double + h = hatDiagonal x + rTil = standardizedResiduals x res + in LA.fromList + [ let denom = max 0.0 (1.0 - hi) + in if denom == 0 + then 0 + else (rTi * rTi / p) * (hi / denom) + | (rTi, hi) <- zip (LA.toList rTil) (LA.toList h) ] + +-- --------------------------------------------------------------------------- +-- Predictor utilities +-- --------------------------------------------------------------------------- + +-- | Per-column sample standard deviation of the design matrix +-- (length @p@). Useful for standardised contribution +-- @|β_j × sd(x_j)| / Σ|β_k × sd(x_k)|@. The intercept column is +-- typically constant, so its entry is @0@. +predictorStdDevs :: LA.Matrix Double -> LA.Vector Double +predictorStdDevs x = + let n = fromIntegral (LA.rows x) :: Double + cs = LA.toColumns x + sd c = + let mu = LA.sumElements c / n + dev = LA.cmap (subtract mu) c + v = (dev `LA.dot` dev) / max 1.0 (n - 1.0) + in sqrt v + in LA.fromList (map sd cs) diff --git a/src/Hanalyze/Model/LatentClassAnalysis.hs b/src/Hanalyze/Model/LatentClassAnalysis.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/LatentClassAnalysis.hs @@ -0,0 +1,212 @@ +-- | +-- Module : Hanalyze.Model.LatentClassAnalysis +-- Description : EM アルゴリズムによる潜在クラス分析 (LCA、R poLCA 相当) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Latent Class Analysis (LCA) via EM algorithm。 +-- +-- カテゴリ変数の潜在クラスクラスタリング。 @K@ 個の潜在クラスを仮定し、 +-- 各クラスでの各 categorical 特徴の条件付き分布 @P(X_j | class)@ を推定する。 +-- R @poLCA@ 相当。 +-- +-- ## モデル +-- +-- @ +-- P(X_i) = Σ_k π_k · Π_j ρ_{k, j, X_{i,j}} +-- @ +-- +-- ここで @π_k@ はクラス混合重み、 @ρ_{k,j,l}@ はクラス @k@ で特徴 @j@ が +-- 水準 @l@ を取る確率。 +-- +-- ## EM +-- +-- - __E-step__: posterior @γ_{i,k} = π_k Π_j ρ_{k,j,X_{i,j}} / Σ_{k'} (...)@ +-- - __M-step__: @π_k ← (1/n) Σ_i γ_{i,k}@、 +-- @ρ_{k,j,l} ← Σ_i γ_{i,k} [X_{i,j} = l] / Σ_i γ_{i,k}@ +-- +-- Reference: Linzer-Lewis (2011) "poLCA: An R package for polytomous +-- variable latent class analysis". J Stat Softw 42(10). +-- +-- [English]: Latent Class Analysis (LCA) via the EM algorithm. +-- +-- Latent-class clustering of categorical variables. Assumes @K@ +-- latent classes, and estimates the conditional distribution +-- @P(X_j | class)@ of each categorical feature within each class. +-- Equivalent to R's @poLCA@. +-- +-- ## Model +-- +-- @ +-- P(X_i) = Σ_k π_k · Π_j ρ_{k, j, X_{i,j}} +-- @ +-- +-- where @π_k@ is the class mixing weight and @ρ_{k,j,l}@ is the +-- probability that feature @j@ takes level @l@ in class @k@. +-- +-- ## EM +-- +-- - __E-step__: posterior @γ_{i,k} = π_k Π_j ρ_{k,j,X_{i,j}} / Σ_{k'} (...)@ +-- - __M-step__: @π_k ← (1/n) Σ_i γ_{i,k}@, +-- @ρ_{k,j,l} ← Σ_i γ_{i,k} [X_{i,j} = l] / Σ_i γ_{i,k}@ +-- +-- Reference: Linzer-Lewis (2011) "poLCA: An R package for polytomous +-- variable latent class analysis". J Stat Softw 42(10). +module Hanalyze.Model.LatentClassAnalysis + ( LCAFit (..) + , fitLCA + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified System.Random.MWC as MWC +import Control.Monad (replicateM) + +-- --------------------------------------------------------------------------- +-- 型 +-- --------------------------------------------------------------------------- + +data LCAFit = LCAFit + { lcaPi :: !(LA.Vector Double) -- ^ class mixing weights (length K) + , lcaRho :: ![LA.Matrix Double] -- ^ per feature: K × L (length J) + , lcaResponsibilities :: !(LA.Matrix Double) -- ^ posterior γ (n × K) + , lcaIterations :: !Int + , lcaConverged :: !Bool + , lcaLogLik :: !Double + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- fitLCA +-- --------------------------------------------------------------------------- + +-- | [日本語]: @K@ クラス、 @L@ 水準の LCA を EM で fit。 入力 @X@ は @n@ 行 @J@ 列の +-- 0-indexed カテゴリ値 (`[[Int]]`、 全要素 ∈ @[0, L-1]@)。 +-- +-- 初期化はランダム (Dirichlet(1) ≈ uniform-on-simplex の近似で MWC を使う)。 +-- 同じ seed で再現性あり。 +-- +-- [English]: Fits an LCA with @K@ classes and @L@ levels via EM. The +-- input @X@ is 0-indexed category values with @n@ rows and @J@ columns +-- (`[[Int]]`, all elements ∈ @[0, L-1]@). +-- +-- Initialization is random (using MWC as an approximation of +-- Dirichlet(1) ≈ uniform-on-simplex). Reproducible for the same seed. +fitLCA + :: Int -- ^ K (classes) + -> Int -- ^ L (levels per feature) + -> [[Int]] -- ^ X (n × J) + -> Int -- ^ max EM iterations + -> Double -- ^ tolerance on log-likelihood diff + -> MWC.GenIO + -> IO LCAFit +fitLCA k l xRaw maxIter tol gen = do + let n = length xRaw + j = if n > 0 then length (head xRaw) else 0 + -- 初期化 + pi0 <- randomSimplex k gen + rho0 <- replicateM j (randomRowStochastic k l gen) + let xMat = LA.fromLists [map fromIntegral row | row <- xRaw] + go !it !pVec !rhoList !prevLL = do + let (gamma, ll) = eStep xMat pVec rhoList l + (pNew, rhoNew) = mStep xMat gamma l + converged = abs (ll - prevLL) < tol + if it >= maxIter || converged + then pure (pVec, rhoList, gamma, it, converged, ll) + else go (it + 1) pNew rhoNew ll + -- 初期 ll は -inf で 1 回目は必ず更新される + (pFinal, rhoFinal, gamFinal, iters, conv, llFinal) <- + go 0 pi0 rho0 (-1 / 0) + pure LCAFit + { lcaPi = pFinal + , lcaRho = rhoFinal + , lcaResponsibilities = gamFinal + , lcaIterations = iters + , lcaConverged = conv + , lcaLogLik = llFinal + } + +-- | [日本語]: E-step: per-row posterior @γ_{i,k}@ と log-likelihood。 +-- log-space で stable: @log P(X_i | k) = Σ_j log ρ_{k, j, X_{i,j}}@ +-- +-- [English]: E-step: the per-row posterior @γ_{i,k}@ and the +-- log-likelihood. Stable in log-space: +-- @log P(X_i | k) = Σ_j log ρ_{k, j, X_{i,j}}@. +eStep + :: LA.Matrix Double -- ^ [日本語]: X (n × J)、 0/1/.../L-1 を Double で。 [English]: X (n × J), with 0/1/.../L-1 as Double. + -> LA.Vector Double -- ^ π + -> [LA.Matrix Double] -- ^ [日本語]: ρ (J 個の K × L)。 [English]: ρ (J instances of K × L). + -> Int -- ^ L + -> (LA.Matrix Double, Double) +eStep xMat pVec rhoList _ = + let n = LA.rows xMat + k = LA.size pVec + logPi = LA.cmap (\p -> log (max 1e-300 p)) pVec + logPx_ik i kk = + sum [ log (max 1e-300 + (LA.atIndex (rhoList !! jj) + (kk, floor (LA.atIndex xMat (i, jj))))) + | jj <- [0 .. length rhoList - 1] ] + logUnnormRow i = LA.fromList + [ LA.atIndex logPi kk + logPx_ik i kk | kk <- [0 .. k - 1] ] + rows = [logUnnormRow i | i <- [0 .. n - 1]] + logSumExpV v = + let mx = LA.maxElement v + in mx + log (LA.sumElements (LA.cmap (\x -> exp (x - mx)) v)) + perRowLL = [logSumExpV r | r <- rows] + gammaRows = + [ LA.cmap (\x -> exp (x - lse)) r + | (r, lse) <- zip rows perRowLL ] + gamma = LA.fromRows gammaRows + ll = sum perRowLL + in (gamma, ll) + +-- | [日本語]: M-step: γ から π / ρ を更新。 +-- [English]: M-step: updates π \/ ρ from γ. +mStep + :: LA.Matrix Double -- ^ X (n × J) + -> LA.Matrix Double -- ^ γ (n × K) + -> Int -- ^ L + -> (LA.Vector Double, [LA.Matrix Double]) +mStep xMat gamma l = + let n = LA.rows xMat + j = LA.cols xMat + k = LA.cols gamma + ones = LA.konst 1 n :: LA.Vector Double + gSum = LA.tr gamma LA.#> ones -- length K = Σ_i γ_{i,k} + pNew = LA.scale (1 / fromIntegral n) gSum + -- 各特徴 j の ρ (K × L) を再推定 + rhoFor jj = + let countMat = LA.fromLists + [ [ sum [ LA.atIndex gamma (i, kk) + | i <- [0 .. n - 1] + , floor (LA.atIndex xMat (i, jj)) == ll ] + | ll <- [0 .. l - 1] ] + | kk <- [0 .. k - 1] ] + denom = LA.cmap (\g -> max 1e-300 g) gSum + in LA.fromColumns + [ LA.flatten (countMat LA.¿ [c]) / denom + | c <- [0 .. l - 1] ] + rhoNew = [rhoFor jj | jj <- [0 .. j - 1]] + in (pNew, rhoNew) + +-- --------------------------------------------------------------------------- +-- 初期化ヘルパ +-- --------------------------------------------------------------------------- + +-- | [日本語]: 長さ @k@ の simplex 上の uniform ランダム vector (= Dir(1) 近似)。 +-- 単純に @k@ 個の uniform を引いて正規化。 +-- +-- [English]: A uniform random vector on the length-@k@ simplex (an +-- approximation of Dir(1)). Simply draws @k@ uniforms and normalizes. +randomSimplex :: Int -> MWC.GenIO -> IO (LA.Vector Double) +randomSimplex k gen = do + rs <- replicateM k (MWC.uniformR (1e-3, 1.0 :: Double) gen) + let s = sum rs + pure (LA.fromList (map (/ s) rs)) + +-- | [日本語]: K × L 行 stochastic matrix のランダム生成。 各行を randomSimplex。 +-- [English]: Randomly generates a K × L row-stochastic matrix. Each +-- row via randomSimplex. +randomRowStochastic :: Int -> Int -> MWC.GenIO -> IO (LA.Matrix Double) +randomRowStochastic k l gen = do + rows <- replicateM k (randomSimplex l gen) + pure (LA.fromRows rows) diff --git a/src/Hanalyze/Model/LiNGAM/Bootstrap.hs b/src/Hanalyze/Model/LiNGAM/Bootstrap.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/LiNGAM/Bootstrap.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.LiNGAM.Bootstrap +-- Description : BootstrapLiNGAM (エッジ出現頻度・平均係数・符号一致率による DAG confidence 診断) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: BootstrapLiNGAM: @DirectLiNGAM@ を B 個の bootstrap サンプルに対し fit し、 +-- エッジ毎の出現頻度 (confidence) と平均係数を出す。 +-- +-- ## アルゴリズム +-- +-- 1. B 回の bootstrap サンプル (行を with-replacement で n 個抽出) を生成 +-- 2. 各サンプルで @fitDirectLiNGAM@ を呼ぶ +-- 3. エッジ (j → i) ごとに: +-- - 出現頻度 = (|B[i, j]| > threshold となった bootstrap の数) / B +-- - 平均係数 = 出現した bootstrap での B[i, j] の平均 +-- - 符号一致率 = sign の合致率 (符号の不安定性を診断) +-- +-- ## 出力 +-- +-- 'BootstrapResult' は @edgeProbability@ / @edgeMeanWeight@ / @signConsistency@ +-- の 3 つの p × p 行列を保持。 これらを使って 「確からしい因果関係 のみ +-- 採用する DAG」 を構築できる。 +-- +-- ## リファレンス +-- +-- Shimizu (2014) "Bayesian estimation of causal direction in acyclic structural +-- equation models with individual-specific confounder variables and +-- non-Gaussian distributions" (BootstrapLiNGAM の運用紹介)。 +-- Python 実装は cdt15/lingam の `lingam/bootstrap.py`。 +-- +-- [English]: BootstrapLiNGAM: fits @DirectLiNGAM@ to B bootstrap samples, +-- and produces the per-edge occurrence frequency (confidence) and mean +-- coefficient. +-- +-- ## Algorithm +-- +-- 1. Generate B bootstrap samples (draw n rows with replacement). +-- 2. Call @fitDirectLiNGAM@ on each sample. +-- 3. For each edge (j → i): +-- - occurrence frequency = (the number of bootstraps where +-- |B[i, j]| > threshold) / B. +-- - mean coefficient = the mean of B[i, j] over the bootstraps where it +-- occurred. +-- - sign consistency = the sign-agreement rate (diagnoses sign +-- instability). +-- +-- ## Output +-- +-- 'BootstrapResult' holds three p × p matrices: @edgeProbability@ \/ +-- @edgeMeanWeight@ \/ @signConsistency@. These can be used to build a "DAG +-- that adopts only sufficiently confident causal relations". +-- +-- ## Reference +-- +-- Shimizu (2014) "Bayesian estimation of causal direction in acyclic +-- structural equation models with individual-specific confounder +-- variables and non-Gaussian distributions" (introduces the +-- BootstrapLiNGAM procedure). The Python implementation is +-- cdt15/lingam's `lingam/bootstrap.py`. +module Hanalyze.Model.LiNGAM.Bootstrap + ( BootstrapConfig (..) + , BootstrapResult (..) + , defaultBootstrapConfig + , fitBootstrapLiNGAM + , fitBootstrapLiNGAMPure + , confidenceDAG + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified System.Random.MWC as MWC +import Control.Monad (replicateM) +import Control.Monad.ST (runST) +import qualified Data.Vector as V + +import qualified Hanalyze.Model.LiNGAM.Direct as DL +import qualified Hanalyze.Model.DAG as DAG + +-- =========================================================================== +-- 設定 +-- =========================================================================== + +data BootstrapConfig = BootstrapConfig + { bcNumBootstraps :: !Int + -- ^ [日本語]: B (resample 回数)、 default 100。 + -- [English]: B (the number of resamples), default 100. + , bcDirectCfg :: !DL.DirectLiNGAMConfig + -- ^ [日本語]: 各 bootstrap で使う DirectLiNGAM 設定。 + -- [English]: The DirectLiNGAM configuration used for each bootstrap. + , bcEdgeThreshold :: !Double + -- ^ [日本語]: |B[i, j]| > thr のとき「エッジあり」 と数える、 default 0.05。 + -- [English]: Counted as "edge present" when |B[i, j]| > thr, default + -- 0.05. + , bcSeed :: !(Maybe Int) + } deriving (Show) + +defaultBootstrapConfig :: BootstrapConfig +defaultBootstrapConfig = BootstrapConfig + { bcNumBootstraps = 100 + , bcDirectCfg = DL.defaultDirectLiNGAMConfig + , bcEdgeThreshold = 0.05 + , bcSeed = Just 42 + } + +-- =========================================================================== +-- 結果 +-- =========================================================================== + +data BootstrapResult = BootstrapResult + { brEdgeProbability :: !(LA.Matrix Double) + -- ^ [日本語]: p × p、 (i, j) = エッジ j → i の出現頻度 (0..1)。 + -- [English]: p × p; (i, j) = the occurrence frequency of edge j → i + -- (0..1). + , brEdgeMeanWeight :: !(LA.Matrix Double) + -- ^ [日本語]: p × p、 (i, j) = エッジが出現した bootstrap における B[i, j] の平均。 + -- [English]: p × p; (i, j) = the mean of B[i, j] over the bootstraps + -- where the edge occurred. + , brSignConsistency :: !(LA.Matrix Double) + -- ^ [日本語]: p × p、 (i, j) = エッジが出現した bootstrap での符号合致率 + -- (1.0 = 全部同符号、 0.5 = 半々)。 + -- [English]: p × p; (i, j) = the sign-agreement rate over the + -- bootstraps where the edge occurred (1.0 = all the same sign, 0.5 = + -- evenly split). + , brNumBootstraps :: !Int + } deriving (Show) + +-- =========================================================================== +-- 主実装 +-- =========================================================================== + +fitBootstrapLiNGAM :: BootstrapConfig -> LA.Matrix Double -> IO BootstrapResult +fitBootstrapLiNGAM cfg xs = do + let !n = LA.rows xs + !p = LA.cols xs + !b = bcNumBootstraps cfg + !thr = bcEdgeThreshold cfg + gen <- case bcSeed cfg of + Just s -> MWC.initialize (V.fromList [fromIntegral s]) + Nothing -> MWC.createSystemRandom + -- 各 bootstrap の B 行列を集める + bMats <- replicateM b $ do + idxs <- V.replicateM n (MWC.uniformR (0, n - 1) gen) + let !resample = xs LA.? V.toList idxs + !fit = DL.fitDirectLiNGAM (bcDirectCfg cfg) resample + pure (DL.dlB fit) + let !probMat = computeEdgeProbability thr p bMats + !meanMat = computeEdgeMeanWeight thr p bMats + !signMat = computeSignConsistency thr p bMats + pure BootstrapResult + { brEdgeProbability = probMat + , brEdgeMeanWeight = meanMat + , brSignConsistency = signMat + , brNumBootstraps = b + } + +-- | [日本語]: 'fitBootstrapLiNGAM' の __seed 純粋版__ (@df |->@ 用)。 @bcSeed@ (既定 42・ +-- 'Nothing' は 42 fallback) で 'runST'+MWC。 同 seed で IO 版とビット一致 (乱数列は monad 非依存)。 +-- [English]: The __seed-pure version__ of 'fitBootstrapLiNGAM' (for +-- @df |->@). Runs 'runST'+MWC with @bcSeed@ (default 42; 'Nothing' falls +-- back to 42). Bit-identical to the IO version for the same seed (the +-- random sequence is monad-independent). +fitBootstrapLiNGAMPure :: BootstrapConfig -> LA.Matrix Double -> BootstrapResult +fitBootstrapLiNGAMPure cfg xs = runST $ do + let !n = LA.rows xs + !p = LA.cols xs + !b = bcNumBootstraps cfg + !thr = bcEdgeThreshold cfg + gen <- MWC.initialize (V.fromList [fromIntegral (maybe 42 id (bcSeed cfg))]) + bMats <- replicateM b $ do + idxs <- V.replicateM n (MWC.uniformR (0, n - 1) gen) + let !resample = xs LA.? V.toList idxs + pure (DL.dlB (DL.fitDirectLiNGAM (bcDirectCfg cfg) resample)) + pure BootstrapResult + { brEdgeProbability = computeEdgeProbability thr p bMats + , brEdgeMeanWeight = computeEdgeMeanWeight thr p bMats + , brSignConsistency = computeSignConsistency thr p bMats + , brNumBootstraps = b + } + +-- | [日本語]: 「出現頻度 ≥ probThreshold かつ符号合致率 ≥ signThreshold」 のエッジだけ +-- 採用した DAG を構築。 重みは 'brEdgeMeanWeight' を使う。 +-- [English]: Builds a DAG that adopts only edges with "occurrence +-- frequency ≥ probThreshold and sign consistency ≥ signThreshold". Uses +-- 'brEdgeMeanWeight' for the weights. +confidenceDAG + :: Double -- 出現頻度閾値 (例 0.7) + -> Double -- 符号合致率閾値 (例 0.8) + -> BootstrapResult + -> DAG.DAG +confidenceDAG probThr signThr res = + let !p = LA.rows (brEdgeProbability res) + f i j + | i == j = 0 + | LA.atIndex (brEdgeProbability res) (i, j) < probThr = 0 + | LA.atIndex (brSignConsistency res) (i, j) < signThr = 0 + | otherwise = LA.atIndex (brEdgeMeanWeight res) (i, j) + w = LA.build (p, p) (\i j -> f (round i) (round j) :: Double) + in DAG.mkDAG w + +-- =========================================================================== +-- 内部: 集計 +-- =========================================================================== + +computeEdgeProbability :: Double -> Int -> [LA.Matrix Double] -> LA.Matrix Double +computeEdgeProbability thr p bMats = + let !n = fromIntegral (length bMats) :: Double + f i j + | i == j = 0 + | otherwise = + let !cnt = length [ () | b <- bMats + , abs (LA.atIndex b (i, j)) > thr ] + in fromIntegral cnt / n + in LA.build (p, p) (\i j -> f (round i) (round j) :: Double) + +computeEdgeMeanWeight :: Double -> Int -> [LA.Matrix Double] -> LA.Matrix Double +computeEdgeMeanWeight thr p bMats = + let f i j + | i == j = 0 + | otherwise = + let vs = [ LA.atIndex b (i, j) + | b <- bMats + , abs (LA.atIndex b (i, j)) > thr ] + in if null vs then 0 else sum vs / fromIntegral (length vs) + in LA.build (p, p) (\i j -> f (round i) (round j) :: Double) + +computeSignConsistency :: Double -> Int -> [LA.Matrix Double] -> LA.Matrix Double +computeSignConsistency thr p bMats = + let f i j + | i == j = 0 + | otherwise = + let vs = [ LA.atIndex b (i, j) + | b <- bMats + , abs (LA.atIndex b (i, j)) > thr ] + in if null vs then 0 + else let !nPos = length (filter (> 0) vs) + !nNeg = length (filter (< 0) vs) + !tot = nPos + nNeg + in if tot == 0 then 0 + else fromIntegral (max nPos nNeg) / fromIntegral tot + in LA.build (p, p) (\i j -> f (round i) (round j) :: Double) diff --git a/src/Hanalyze/Model/LiNGAM/Direct.hs b/src/Hanalyze/Model/LiNGAM/Direct.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/LiNGAM/Direct.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.LiNGAM.Direct +-- Description : DirectLiNGAM (Shimizu 2011) による線形非ガウシアン因果探索 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: DirectLiNGAM (Shimizu et al. 2011) による線形非ガウシアン因果探索。 +-- +-- ## 前提モデル +-- +-- 観測 X ∈ ℝ^(n×p) が __線形 + acyclic + 非ガウシアン独立 noise__ な構造方程式 +-- モデル X = B X + e に従う (B は適切な行/列順列で下三角化可能、 e の各成分は +-- 互いに独立かつ非ガウシアン)。 このとき DirectLiNGAM は ICA を経由せず、 +-- 残差独立性 (差分相互情報量) の最大化で因果順序を 1 変数ずつ確定する。 +-- +-- ## アルゴリズム概要 +-- +-- 1. 候補集合 U = {0..p-1}、 因果順序 K = [] +-- 2. p 回 loop: +-- a. searchCausalOrder で M(m) = -Σ_{j∈U,j≠m} min(0, ΔMI(x_m,x_j,r_{mj},r_{jm}))² +-- を最大化する m を選ぶ +-- b. U の各 i ≠ m について x_i ← residual(x_i, x_m) (m で残差化) +-- c. K に m を追加、 U から m を除く +-- 3. K から B 行列を OLS で組み上げる (causal order に従い順に回帰) +-- +-- ## ΔMI (差分相互情報量) +-- +-- 標準化後の x_i, x_j と残差 r_{ij}, r_{ji} (互いに片方を片方で回帰した残差) +-- に対し: +-- +-- > ΔMI(x_i, x_j, r_{ij}, r_{ji}) = [H(x_j) + H(r_{ij}/σ_{r_{ij}})] +-- > - [H(x_i) + H(r_{ji}/σ_{r_{ji}})] +-- +-- H は Hyvärinen (1998) の maximum entropy 近似: +-- +-- > H(u) = (1 + log 2π)/2 - k1·(E[log cosh u] - γ)² - k2·(E[u·exp(-u²/2)])² +-- > k1 = 79.047, k2 = 7.4129, γ = 0.37457 +-- +-- ## リファレンス +-- +-- Shimizu et al. (2011) "DirectLiNGAM: A direct method for learning a linear +-- non-Gaussian structural equation model", JMLR 12. Python 実装は +-- cdt15/lingam の `lingam/direct_lingam.py` で動作対応を確認した。 +-- +-- ## 落とし穴メモ +-- +-- - 観測変数が __完全ガウシアン__ だと ΔMI ≈ 0 となり順序が一意決まらない。 +-- ガウシアン応答には causal inference (介入効果) や PC algorithm 等の +-- 別手法を使う +-- - __n < 100__ だと entropy の sample 推定が不安定。 n ≥ 200 推奨 +-- - 行列 B は __causal order の根本変数を 0 行目__ に置く慣習。 出力の +-- dlB[K[j], K[i]] = β_i (i < j) で表される (= 影響先 ← 影響元 規約) +-- +-- [English]: Linear non-Gaussian causal discovery via DirectLiNGAM (Shimizu +-- et al. 2011). +-- +-- ## Assumed model +-- +-- The observations X ∈ ℝ^(n×p) follow a structural equation model X = B X + e that is __linear and acyclic with independent non-Gaussian noise__ +-- (B can be made lower-triangular by an appropriate row\/column +-- permutation; each component of e is mutually independent and +-- non-Gaussian). DirectLiNGAM then determines the causal order one variable +-- at a time by maximizing residual independence (differential mutual +-- information), without going through ICA. +-- +-- ## Algorithm overview +-- +-- 1. Candidate set U = {0..p-1}, causal order K = [] +-- 2. Loop p times: +-- a. In searchCausalOrder, pick the m that maximizes +-- M(m) = -Σ_{j∈U,j≠m} min(0, ΔMI(x_m,x_j,r_{mj},r_{jm}))² +-- b. For each i ≠ m in U, x_i ← residual(x_i, x_m) (residualize on m) +-- c. Append m to K, remove m from U +-- 3. Assemble the B matrix from K via OLS (regress in causal-order sequence) +-- +-- ## ΔMI (differential mutual information) +-- +-- For standardized x_i, x_j and residuals r_{ij}, r_{ji} (each regressed on +-- the other): +-- +-- > ΔMI(x_i, x_j, r_{ij}, r_{ji}) = [H(x_j) + H(r_{ij}/σ_{r_{ij}})] +-- > - [H(x_i) + H(r_{ji}/σ_{r_{ji}})] +-- +-- H is Hyvärinen's (1998) maximum entropy approximation: +-- +-- > H(u) = (1 + log 2π)/2 - k1·(E[log cosh u] - γ)² - k2·(E[u·exp(-u²/2)])² +-- > k1 = 79.047, k2 = 7.4129, γ = 0.37457 +-- +-- ## Reference +-- +-- Shimizu et al. (2011) "DirectLiNGAM: A direct method for learning a linear +-- non-Gaussian structural equation model", JMLR 12. Behavior was checked +-- against the Python implementation in cdt15/lingam's +-- `lingam/direct_lingam.py`. +-- +-- ## Pitfall notes +-- +-- - If the observed variables are __perfectly Gaussian__, ΔMI ≈ 0 and the +-- order is not uniquely determined. For Gaussian responses, use a +-- different technique such as causal inference (intervention effects) or +-- the PC algorithm. +-- - __n < 100__ makes the sample estimate of entropy unstable. n ≥ 200 is +-- recommended. +-- - By convention, matrix B is arranged so that __row 0 is the causal order's root variable__. +-- In the output, dlB[K[j], K[i]] = β_i (i < j) (= "influenced ← influencer" convention). +module Hanalyze.Model.LiNGAM.Direct + ( DirectLiNGAMConfig (..) + , DirectLiNGAMFit (..) + , defaultDirectLiNGAMConfig + , fitDirectLiNGAM + , dlDAG + -- helpers (re-export 不要時は internal だが、 単体テスト用に公開) + , entropyApprox + , diffMutualInfo + , olsResidual + , standardize + ) where + +import qualified Numeric.LinearAlgebra as LA +import Data.List (foldl') + +import qualified Hanalyze.Model.DAG as DAG + +-- =========================================================================== +-- 公開型 +-- =========================================================================== + +-- | [日本語]: DirectLiNGAM の設定。 +-- [English]: DirectLiNGAM configuration. +data DirectLiNGAMConfig = DirectLiNGAMConfig + { dlcPruneThr :: !Double + -- ^ [日本語]: |B_ij| < 'dlcPruneThr' は隣接行列で 0 と扱う。 default 0.05。 + -- [English]: |B_ij| < 'dlcPruneThr' is treated as 0 in the adjacency + -- matrix. Default 0.05. + } deriving (Show) + +defaultDirectLiNGAMConfig :: DirectLiNGAMConfig +defaultDirectLiNGAMConfig = DirectLiNGAMConfig + { dlcPruneThr = 0.05 + } + +-- | [日本語]: DirectLiNGAM の推定結果。 +-- [English]: The estimation result of DirectLiNGAM. +data DirectLiNGAMFit = DirectLiNGAMFit + { dlOrder :: ![Int] + -- ^ [日本語]: 推定 causal order (topological)。 K[0] が最も外生的、 K[p-1] が + -- 最も末端 (どの変数からも影響を受ける可能性のある変数)。 + -- [English]: The estimated causal order (topological). K[0] is the + -- most exogenous, K[p-1] the most terminal (the variable most likely + -- to be influenced by other variables). + , dlB :: !(LA.Matrix Double) + -- ^ [日本語]: 構造方程式係数行列 (p × p)。 X_i = Σ_j dlB[i, j] · X_j + e_i。 + -- causal order に従い適切な行/列順列で下三角化可能。 + -- [English]: The structural-equation coefficient matrix (p × p). + -- X_i = Σ_j dlB[i, j] · X_j + e_i. Can be made lower-triangular by an + -- appropriate row\/column permutation following the causal order. + , dlAdjacency :: !(LA.Matrix Double) + -- ^ [日本語]: |dlB| > dlcPruneThr の 0/1 マスク。 [English]: A 0\/1 mask + -- for |dlB| > dlcPruneThr. + , dlResiduals :: !(LA.Matrix Double) + -- ^ [日本語]: 各サンプルの推定残差 e_i (n × p)。 独立性検定の事後評価に使う。 + -- [English]: The estimated residuals e_i per sample (n × p). Used for + -- post-hoc independence-test evaluation. + } deriving (Show) + +-- =========================================================================== +-- 主アルゴリズム +-- =========================================================================== + +-- | [日本語]: DirectLiNGAM を fit する。 X は n × p 行列 (各列 = 1 変数)。 +-- [English]: Fits DirectLiNGAM. X is an n × p matrix (each column = 1 +-- variable). +-- +-- 計算量: 因果順序探索 O(p² · n) per iteration × p iterations = O(p³ · n) +-- (entropy 評価 + 残差化が dominant)。 +-- | [日本語]: @DirectLiNGAMFit@ を 'Hanalyze.Model.DAG.DAG' 表現に変換 (threshold は +-- 元の 'dlcPruneThr' を再利用)。 +-- [English]: Converts a @DirectLiNGAMFit@ to an +-- 'Hanalyze.Model.DAG.DAG' representation (reusing the original +-- 'dlcPruneThr' as the threshold). +dlDAG :: DirectLiNGAMConfig -> DirectLiNGAMFit -> DAG.DAG +dlDAG cfg fit = DAG.fromBMatrix (dlcPruneThr cfg) (dlB fit) + +fitDirectLiNGAM :: DirectLiNGAMConfig -> LA.Matrix Double -> DirectLiNGAMFit +fitDirectLiNGAM cfg xs = + let !p = LA.cols xs + !n = LA.rows xs + -- 各列を Vector に分解した可変リスト (residualize 用) + cols0 :: [LA.Vector Double] + cols0 = [ LA.flatten (xs LA.¿ [j]) | j <- [0 .. p - 1] ] + -- 主 loop: cols / activeU / order を順次更新 + (order, _finalCols) = causalOrderLoop cols0 [0 .. p - 1] [] + -- 元の X から causal order に従い B 行列を OLS で組み立て + bMat = estimateB xs order + adjMat = buildAdjacency (dlcPruneThr cfg) bMat + -- 残差: e = X - X·B^T (行ベクトル view、 単純な線形変換) + resid = xs - xs LA.<> LA.tr bMat + _ = n -- shadow warn 防止 + in DirectLiNGAMFit + { dlOrder = order + , dlB = bMat + , dlAdjacency = adjMat + , dlResiduals = resid + } + +-- | [日本語]: causal order を 1 つずつ確定する主ループ。 +-- 引数: +-- cols : 現在の (残差化された) 列ベクトルのリスト (length p、 元 index で並ぶ) +-- activeU : まだ確定していない元 index のリスト +-- orderRev: これまでに確定した順序 (逆順、 後で reverse) +-- [English]: The main loop that fixes the causal order one entry at a +-- time. +-- Arguments: +-- cols : the current (residualized) list of column vectors (length +-- p, ordered by original index) +-- activeU : the list of original indices not yet fixed +-- orderRev: the order fixed so far (reversed; reversed again later) +causalOrderLoop + :: [LA.Vector Double] -- 現状の列ベクトル + -> [Int] -- active 集合 + -> [Int] -- 確定済 (逆順) + -> ([Int], [LA.Vector Double]) +causalOrderLoop cols activeU orderRev + | null activeU = (reverse orderRev, cols) + | length activeU == 1 = + (reverse (head activeU : orderRev), cols) + | otherwise = + let !m = searchCausalOrder cols activeU + xm = cols !! m + -- m 以外の active で残差化 + colsNew = [ if j `elem` activeU && j /= m + then olsResidual (cols !! j) xm + else cols !! j + | j <- [0 .. length cols - 1] ] + activeNew = [ j | j <- activeU, j /= m ] + in causalOrderLoop colsNew activeNew (m : orderRev) + +-- | [日本語]: 候補集合 activeU から、 「最も外生的 (= 他から残差化された後の独立性が +-- 崩れにくい)」 index を 1 つ返す。 +-- M(m) = -Σ_{j∈U, j≠m} min(0, ΔMI(x_m,x_j,r_{mj},r_{jm}))² を最大化。 +-- [English]: From the candidate set activeU, returns the index that is +-- "most exogenous" (= its independence holds up best after being +-- residualized against the others). +-- Maximizes M(m) = -Σ_{j∈U, j≠m} min(0, ΔMI(x_m,x_j,r_{mj},r_{jm}))². +searchCausalOrder :: [LA.Vector Double] -> [Int] -> Int +searchCausalOrder cols activeU = + let !scores = [ (m, score m) | m <- activeU ] + score m = + let xm = cols !! m + xmStd = standardize xm + contribs = + [ let xj = cols !! j + xjStd = standardize xj + rmj = olsResidual xmStd xjStd -- xm を xj で残差化 + rjm = olsResidual xjStd xmStd -- xj を xm で残差化 + dmi = diffMutualInfo xmStd xjStd rmj rjm + in min 0 dmi ** 2 + | j <- activeU, j /= m ] + in negate (sum contribs) + in fst (foldl' pickMax (head scores) (tail scores)) + where + pickMax acc@(_, s0) cur@(_, s1) + | s1 > s0 = cur + | otherwise = acc + +-- | [日本語]: 差分相互情報量 ΔMI = [H(xj) + H(rij/σ)] - [H(xi) + H(rji/σ)]。 +-- 入力 xi/xj は標準化済、 rij/rji は __標準化前__ の残差。 +-- [English]: The differential mutual information +-- ΔMI = [H(xj) + H(rij/σ)] - [H(xi) + H(rji/σ)]. The inputs xi\/xj are +-- already standardized; rij\/rji are residuals __before standardization__. +diffMutualInfo + :: LA.Vector Double -- xi (標準化済) + -> LA.Vector Double -- xj (標準化済) + -> LA.Vector Double -- rij = xi - β xj 残差 + -> LA.Vector Double -- rji = xj - β xi 残差 + -> Double +diffMutualInfo xi xj rij rji = + let !hxi = entropyApprox xi + !hxj = entropyApprox xj + !srij = stdSafe rij + !srji = stdSafe rji + !hrij = entropyApprox (LA.scale (1 / srij) rij) + !hrji = entropyApprox (LA.scale (1 / srji) rji) + in (hxj + hrij) - (hxi + hrji) + where + stdSafe v = + let s = LA.norm_2 (v - LA.scalar (LA.sumElements v / fromIntegral (LA.size v))) + / sqrt (fromIntegral (LA.size v)) + in if s > 1e-12 then s else 1.0 + +-- | [日本語]: Hyvärinen (1998) maximum entropy 近似: +-- H(u) = (1 + log 2π)/2 - k1·(E[log cosh u] - γ)² - k2·(E[u·exp(-u²/2)])² +-- u は事前に標準化されていることが前提。 +-- [English]: Hyvärinen's (1998) maximum entropy approximation: +-- H(u) = (1 + log 2π)/2 - k1·(E[log cosh u] - γ)² - k2·(E[u·exp(-u²/2)])². +-- Assumes u has already been standardized. +entropyApprox :: LA.Vector Double -> Double +entropyApprox u = + let !k1 = 79.047 + !k2 = 7.4129 + !gamma = 0.37457 + !n = fromIntegral (LA.size u) :: Double + !logCosh = LA.sumElements (LA.cmap (\v -> log (cosh v)) u) / n + !uExp = LA.sumElements (u * LA.cmap (\v -> exp (-v * v / 2)) u) / n + in (1 + log (2 * pi)) / 2 + - k1 * (logCosh - gamma) ** 2 + - k2 * uExp ** 2 + +-- | [日本語]: OLS による残差: r = xi - (Cov(xi,xj) / Var(xj)) · xj +-- [English]: The OLS residual: r = xi - (Cov(xi,xj) \/ Var(xj)) · xj. +olsResidual :: LA.Vector Double -> LA.Vector Double -> LA.Vector Double +olsResidual xi xj = + let !n = fromIntegral (LA.size xi) :: Double + !mxi = LA.sumElements xi / n + !mxj = LA.sumElements xj / n + !ci = xi - LA.scalar mxi + !cj = xj - LA.scalar mxj + !cov = ci `LA.dot` cj / n + !var = cj `LA.dot` cj / n + !beta = if var > 1e-12 then cov / var else 0 + in xi - LA.scale beta xj + +-- | [日本語]: 中心化 + 標準偏差で割る (zero-mean, unit-variance)。 +-- [English]: Centers and divides by the standard deviation (zero-mean, +-- unit-variance). +standardize :: LA.Vector Double -> LA.Vector Double +standardize v = + let !n = fromIntegral (LA.size v) :: Double + !mu = LA.sumElements v / n + !c = v - LA.scalar mu + !s = sqrt (c `LA.dot` c / n) + !sd = if s > 1e-12 then s else 1.0 + in LA.scale (1 / sd) c + +-- =========================================================================== +-- B 行列 + 隣接行列 +-- =========================================================================== + +-- | [日本語]: causal order に従い B 行列を OLS で組み立てる。 +-- B[K[j], K[i]] = OLS 回帰 X[:,K[j]] ~ X[:,K[0..j-1]] の i 番目係数。 +-- [English]: Assembles the B matrix via OLS following the causal order. +-- B[K[j], K[i]] = the i-th coefficient of the OLS regression +-- X[:,K[j]] ~ X[:,K[0..j-1]]. +estimateB :: LA.Matrix Double -> [Int] -> LA.Matrix Double +estimateB xs order = + let !p = LA.cols xs + bRows = [ buildRow j | j <- [0 .. p - 1] ] + buildRow j = + let kj = order !! j + -- 影響元候補: order の j より前 + parents = take j order + in if null parents + then LA.fromList (replicate p 0) + else + let parentMat = LA.fromColumns + [ LA.flatten (xs LA.¿ [pIdx]) | pIdx <- parents ] + target = LA.flatten (xs LA.¿ [kj]) + beta = olsBeta parentMat target + coefVec = replicate p 0 + -- beta を parent 位置に散布 + updates = zip parents (LA.toList beta) + filled = foldl' (\acc (idx, v) -> setAt acc idx v) coefVec updates + in LA.fromList filled + -- 行は K の順序、 列は元 variable index。 + -- bRows[j] は variable K[j] の行ベクトル → reorder で元 variable index 順に + origOrderMat = LA.fromRows + [ bRows !! posInOrder i | i <- [0 .. p - 1] ] + posInOrder i = case lookup i (zip order [0 ..]) of + Just k -> k + Nothing -> 0 -- unreachable + in origOrderMat + +-- | [日本語]: OLS 係数: β = (XᵀX)⁻¹ Xᵀy +-- [English]: The OLS coefficients: β = (XᵀX)⁻¹ Xᵀy. +olsBeta :: LA.Matrix Double -> LA.Vector Double -> LA.Vector Double +olsBeta x y = + let xtx = LA.tr x LA.<> x + xty = LA.tr x LA.#> y + in LA.flatten (LA.linearSolveLS xtx (LA.asColumn xty)) + +setAt :: [a] -> Int -> a -> [a] +setAt xs i v = take i xs ++ [v] ++ drop (i + 1) xs + +-- | [日本語]: |B_ij| > threshold で 1、 以外 0 の隣接行列。 対角は 0 に固定。 +-- [English]: The adjacency matrix: 1 when |B_ij| > threshold, otherwise 0. +-- The diagonal is fixed at 0. +buildAdjacency :: Double -> LA.Matrix Double -> LA.Matrix Double +buildAdjacency thr b = + let !p = LA.rows b + f i j + | i == j = 0 + | abs (LA.atIndex b (i, j)) > thr = 1 + | otherwise = 0 + in LA.build (p, p) (\i j -> f (round i) (round j) :: Double) diff --git a/src/Hanalyze/Model/LiNGAM/ICA.hs b/src/Hanalyze/Model/LiNGAM/ICA.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/LiNGAM/ICA.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.LiNGAM.ICA +-- Description : ICA-LiNGAM (Shimizu 2006、原典版) by FastICA + Hungarian 順列 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: ICA-LiNGAM (Shimizu et al. 2006、 LiNGAM の原典版) by FastICA。 +-- +-- ## アルゴリズム +-- +-- 1. 観測 X (n × p) に対し FastICA で __分離行列 W__ (= ICA unmixing) を求める +-- (元座標、 'Hanalyze.Math.ICA.icaUnmixing') +-- 2. __A = pinv(W)__ を計算 (X = S · Aᵀ + mean) +-- 3. __行/列順列で下三角化__: +-- a. A の絶対値の __逆数__ をコスト行列とし、 行・列順列で対角要素を +-- 絶対値最大に揃える Hungarian-like (本実装は近似貪欲) +-- b. 順列適用後の A を対角要素で正規化、 B = I - A_perm⁻¹ +-- c. B の下三角化のための __行順列__ を別途決定 (= causal order) +-- 4. B 行列を pruning して隣接行列を返す +-- +-- ## DirectLiNGAM との違い +-- +-- DirectLiNGAM は ICA 不要で残差独立性 + 1 変数ずつ確定。 ICA-LiNGAM は ICA +-- (FastICA) で全成分を同時推定 → 順列で因果順序を後付けで決める。 ICA の +-- 収束性に依存するが、 因子数が多いときは並列度で有利な場合がある。 +-- +-- 行/列順列は __Hungarian (Kuhn-Munkres, O(p³))__ で大域最適化する +-- ('Hanalyze.Math.Hungarian')。 cdt15/lingam の Python 実装は +-- @scipy.optimize.linear_sum_assignment(1 / |W|)@ で同等のことをしており、 +-- コスト関数も @1 / (|W| + ε)@ で揃えている。 旧来の貪欲版 ('greedyAssignRows') +-- は @ilcUseHungarian = False@ で復元可能 (回帰確認・ベンチ比較用)。 +-- +-- ## リファレンス +-- +-- Shimizu et al. (2006) "A Linear Non-Gaussian Acyclic Model for Causal +-- Discovery", JMLR 7. Python 実装は cdt15/lingam の `lingam/ica_lingam.py`。 +-- +-- [English]: ICA-LiNGAM (Shimizu et al. 2006, the original LiNGAM +-- formulation) via FastICA. +-- +-- ## Algorithm +-- +-- 1. For observations X (n × p), obtain the __separating matrix W__ +-- (= ICA unmixing) by FastICA, in the original coordinates +-- ('Hanalyze.Math.ICA.icaUnmixing'). +-- 2. Compute __A = pinv(W)__ (X = S · Aᵀ + mean). +-- 3. __Lower-triangularize by row\/column permutation__: +-- a. Use the __reciprocal__ of |A| as the cost matrix and align the +-- diagonal entries to the largest absolute values by row\/column +-- permutation, Hungarian-like (this implementation is an approximate +-- greedy one). +-- b. Normalize the permuted A by its diagonal entries, B = I - A_perm⁻¹. +-- c. Separately determine the __row permutation__ that lower-triangularizes +-- B (= the causal order). +-- 4. Prune the B matrix and return the adjacency matrix. +-- +-- ## Difference from DirectLiNGAM +-- +-- DirectLiNGAM needs no ICA and fixes one variable at a time via residual +-- independence. ICA-LiNGAM estimates all components simultaneously by ICA +-- (FastICA) and then decides the causal order afterwards by permutation. It +-- depends on the convergence of ICA, but can be advantageous in parallelism +-- when the number of factors is large. +-- +-- The row\/column permutation is globally optimized by +-- __Hungarian (Kuhn-Munkres, O(p³))__ ('Hanalyze.Math.Hungarian'). +-- The Python implementation in cdt15\/lingam does the equivalent with +-- @scipy.optimize.linear_sum_assignment(1 / |W|)@, and the cost function is +-- matched here as @1 / (|W| + ε)@. The legacy greedy version +-- ('greedyAssignRows') can be restored with @ilcUseHungarian = False@ (for +-- regression checks and benchmark comparison). +-- +-- ## References +-- +-- Shimizu et al. (2006) "A Linear Non-Gaussian Acyclic Model for Causal +-- Discovery", JMLR 7. The Python implementation is `lingam/ica_lingam.py` +-- in cdt15\/lingam. +module Hanalyze.Model.LiNGAM.ICA + ( ICALiNGAMConfig (..) + , ICALiNGAMFit (..) + , fitICALiNGAMPure + , defaultICALiNGAMConfig + , fitICALiNGAM + , ilDAG + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified Data.Vector.Unboxed as VU +import Data.List (sortBy) +import Data.Ord (comparing, Down (..)) + +import qualified Hanalyze.Math.ICA as ICA +import qualified Hanalyze.Math.Hungarian as Hung +import qualified Hanalyze.Model.DAG as DAG + +-- =========================================================================== +-- 設定 / 結果 +-- =========================================================================== + +data ICALiNGAMConfig = ICALiNGAMConfig + { ilcPruneThr :: !Double + , ilcICACfg :: !ICA.ICAConfig + , ilcUseHungarian :: !Bool + -- ^ [日本語]: True: 行順列を Hungarian (O(p³)) で大域最適化 (default、 推奨)。 + -- False: 旧来の貪欲版を使う (回帰比較・ベンチ用)。 + -- [English]: True: globally optimize the row permutation with Hungarian + -- (O(p³)) (default, recommended). False: use the legacy greedy version + -- (for regression comparison and benchmarking). + } deriving (Show) + +defaultICALiNGAMConfig :: ICALiNGAMConfig +defaultICALiNGAMConfig = ICALiNGAMConfig + { ilcPruneThr = 0.05 + , ilcICACfg = ICA.defaultICAConfig + , ilcUseHungarian = True + } + +data ICALiNGAMFit = ICALiNGAMFit + { ilOrder :: ![Int] + , ilB :: !(LA.Matrix Double) + , ilAdjacency :: !(LA.Matrix Double) + , ilICAResult :: !ICA.ICAResult + } deriving (Show) + +-- =========================================================================== +-- 主実装 +-- =========================================================================== + +fitICALiNGAM :: ICALiNGAMConfig -> LA.Matrix Double -> IO ICALiNGAMFit +fitICALiNGAM cfg x = do + ica <- ICA.fitICA (ilcICACfg cfg) x + pure (assembleICALiNGAM cfg ica) + +-- | [日本語]: 'fitICALiNGAM' の __seed 純粋版__ (@df |->@ 用)。 @fitICAPure@ (seed) で +-- FastICA を回す。 同 seed で IO 版とビット一致。 +-- [English]: The __seed-based pure version__ of 'fitICALiNGAM' (for +-- @df |->@). Runs FastICA via @fitICAPure@ (seed). Bit-identical to the IO +-- version for the same seed. +fitICALiNGAMPure :: ICALiNGAMConfig -> LA.Matrix Double -> ICALiNGAMFit +fitICALiNGAMPure cfg x = assembleICALiNGAM cfg (ICA.fitICAPure (ilcICACfg cfg) x) + +-- | [日本語]: ICA 結果 → 'ICALiNGAMFit' の純粋組み立て (行順列 → 正規化 → 下三角化 → adjacency)。 +-- [English]: Pure assembly of an 'ICALiNGAMFit' from an ICA result (row +-- permutation → normalization → lower-triangularization → adjacency). +assembleICALiNGAM :: ICALiNGAMConfig -> ICA.ICAResult -> ICALiNGAMFit +assembleICALiNGAM cfg ica = + let !w = ICA.icaUnmixing ica -- (p × p) + !p = LA.rows w + -- step 3a: 対角絶対値最大化の行順列を決定。 Hungarian は大域最適、 + -- 貪欲は p > 10 でしばしば劣化する (cdt15/lingam も Hungarian 採用)。 + !rowPerm = if ilcUseHungarian cfg + then hungarianAssignRows w + else greedyAssignRows w + !wPerm1 = permuteRows w rowPerm + -- step 3b: 各行を対角で正規化 + !wNorm = normalizeDiag wPerm1 + -- B' = I - W_norm + !bPrime = LA.ident p - wNorm + -- step 3c: bPrime の行順列を causal order に並べる + -- 下三角化: 順列の絶対値和が下三角寄りになるよう貪欲に並べ替え + !causal = causalOrderFromTriangle bPrime + -- causal order で再順列した B を返す + !bReorder = permuteRowsCols bPrime causal causal + -- 元 variable index に戻す + -- bPrime[i, j] は permuted index 上の値、 rowPerm を逆引きする必要あり + !bFinal = restoreOriginalIndex p bPrime rowPerm causal + !adj = adjMatrix (ilcPruneThr cfg) bFinal + _ = bReorder -- 内部debug 用、 未使用 + in ICALiNGAMFit + { ilOrder = mapPerm causal rowPerm + , ilB = bFinal + , ilAdjacency = adj + , ilICAResult = ica + } + +-- | [日本語]: DAG への変換 +-- [English]: Conversion to a DAG. +ilDAG :: ICALiNGAMConfig -> ICALiNGAMFit -> DAG.DAG +ilDAG cfg fit = DAG.fromBMatrix (ilcPruneThr cfg) (ilB fit) + +-- =========================================================================== +-- 内部: 順列ヘルパ +-- =========================================================================== + +-- | [日本語]: Hungarian による行順列決定。 コスト C[i, j] = 1 / (|W[i, j]| + ε) で +-- 'Hung.hungarianMin' を呼び、 row i → col j の割当を得てから +-- perm[j] = i に反転する (col j に row i を置く)。 +-- cdt15/lingam の Python 実装 (scipy linear_sum_assignment(1/|W|)) と同型。 +-- [English]: Determines the row permutation by the Hungarian algorithm. +-- Calls 'Hung.hungarianMin' with cost C[i, j] = 1 / (|W[i, j]| + ε), obtains +-- the assignment row i → col j, and then inverts it into perm[j] = i (place +-- row i at col j). Isomorphic to the Python implementation in cdt15\/lingam +-- (scipy linear_sum_assignment(1/|W|)). +hungarianAssignRows :: LA.Matrix Double -> [Int] +hungarianAssignRows w = + let p = LA.rows w + eps = 1.0e-12 + cost = LA.build (p, p) + (\i j -> 1.0 / (abs (LA.atIndex w (round i, round j)) + eps) + :: Double) + assign = Hung.hungarianMin cost -- assign[i] = j (row i → col j) + pairs = sortBy (comparing fst) + [ (assign VU.! i, i) | i <- [0 .. p - 1] ] + -- (col j, row i) + in map snd pairs -- perm[j] = i + +-- | [日本語]: 行順列の貪欲決定: 各列の絶対値最大要素を見て、 行と列を 1-1 対応させる +-- greedy assignment (Hungarian の近似版)。 戻り値 perm の意味: +-- 「permuted index j に元 row index perm[j] を持ってくる」 (= rows ordering)。 +-- [English]: Greedy determination of the row permutation: a greedy +-- assignment that matches rows and columns one-to-one by looking at the +-- largest-magnitude entry of each column (an approximation of Hungarian). +-- The returned perm means "bring the original row index perm[j] to permuted +-- index j" (= rows ordering). +greedyAssignRows :: LA.Matrix Double -> [Int] +greedyAssignRows w = + let p = LA.rows w + -- 候補を (元 row i, 元 col j, abs value) として絶対値降順に並べる + candidates :: [((Int, Int), Double)] + candidates = sortBy (comparing (Down . snd)) + [ ((i, j), abs (LA.atIndex w (i, j))) + | i <- [0 .. p - 1], j <- [0 .. p - 1] ] + -- 貪欲: row と col を使用済にしながら (col j に row i を割当て) + assign :: [Int] -> [Int] -> [((Int, Int), Double)] -> [(Int, Int)] + assign _ _ [] = [] + assign usedRows usedCols (((i, j), _):rest) + | i `elem` usedRows || j `elem` usedCols = assign usedRows usedCols rest + | otherwise = (j, i) : assign (i:usedRows) (j:usedCols) rest + pairs = assign [] [] candidates -- (col j, row i) のペア + sortedPairs = sortBy (comparing fst) pairs -- col 昇順 + perm = map snd sortedPairs -- perm[j] = i + in if length perm == p + then perm + else [0 .. p - 1] -- fallback + +-- | [日本語]: 行を perm で並べ替える (perm[i] = 元 index)。 +-- [English]: Reorders the rows by perm (perm[i] = the original index). +permuteRows :: LA.Matrix Double -> [Int] -> LA.Matrix Double +permuteRows m perm = m LA.? perm + +-- | [日本語]: 各行を対角要素で正規化する (W → W / diag(W))。 +-- [English]: Normalizes each row by its diagonal entry (W → W / diag(W)). +normalizeDiag :: LA.Matrix Double -> LA.Matrix Double +normalizeDiag w = + let p = LA.rows w + diags = [ LA.atIndex w (i, i) | i <- [0 .. p - 1] ] + f i j = + let d = diags !! i + v = LA.atIndex w (i, j) + in if abs d > 1e-12 then v / d else v + in LA.build (p, p) (\i j -> f (round i) (round j) :: Double) + +-- | [日本語]: B から下三角化のための行順列を貪欲に決める。 +-- 各行の非零要素数が少ない行 (根) を先に置く戦略。 +-- [English]: Greedily determines the row permutation that +-- lower-triangularizes B. The strategy places rows with fewer nonzero +-- entries (the roots) first. +causalOrderFromTriangle :: LA.Matrix Double -> [Int] +causalOrderFromTriangle b = + let p = LA.rows b + scoreRow i = + sum [ abs (LA.atIndex b (i, j)) + | j <- [0 .. p - 1], j /= i ] + sorted = sortBy (comparing snd) + [ (i, scoreRow i) | i <- [0 .. p - 1] ] + in map fst sorted + +-- | [日本語]: 行と列を同じ perm で並び替え (DAG 構造を保つ)。 +-- [English]: Reorders rows and columns by the same perm (preserving the DAG +-- structure). +permuteRowsCols :: LA.Matrix Double -> [Int] -> [Int] -> LA.Matrix Double +permuteRowsCols m rp cp = + let mR = m LA.? rp + mTr = LA.tr mR LA.? cp + in LA.tr mTr + +-- | [日本語]: 元の variable index に戻す。 +-- permuted index 上での B → original index 上での B。 +-- [English]: Restores the original variable indices. B on permuted indices +-- → B on original indices. +restoreOriginalIndex + :: Int + -> LA.Matrix Double -- B_prime (permuted index 上) + -> [Int] -- rowPerm: permuted_i ← original_rowPerm[i] + -> [Int] -- causal: permuted index 上での causal order + -> LA.Matrix Double +restoreOriginalIndex p bPrime rowPerm _causal = + -- bPrime は rowPerm で permuted されている。 inverse perm で元に戻す。 + let invPerm = invertPerm rowPerm + f i j = LA.atIndex bPrime (invPerm !! i, invPerm !! j) + in LA.build (p, p) (\i j -> f (round i) (round j) :: Double) + +invertPerm :: [Int] -> [Int] +invertPerm perm = + let p = length perm + pairs = zip perm [0 ..] + sorted = sortBy (comparing fst) pairs + in map snd sorted ++ replicate (p - length sorted) 0 + +-- | [日本語]: original index 上での causal order (= permuted causal を rowPerm で戻す) +-- [English]: The causal order on original indices (= mapping the permuted +-- causal order back through rowPerm). +mapPerm :: [Int] -> [Int] -> [Int] +mapPerm causal rowPerm = map (rowPerm !!) causal + +-- | [日本語]: adjacency 行列 (|B| > thr のマスク) +-- [English]: The adjacency matrix (the mask of |B| > thr). +adjMatrix :: Double -> LA.Matrix Double -> LA.Matrix Double +adjMatrix thr b = + let p = LA.rows b + f i j + | i == j = 0 + | abs (LA.atIndex b (i, j)) > thr = 1 + | otherwise = 0 + in LA.build (p, p) (\i j -> f (round i) (round j) :: Double) diff --git a/src/Hanalyze/Model/LiNGAM/MultiGroup.hs b/src/Hanalyze/Model/LiNGAM/MultiGroup.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/LiNGAM/MultiGroup.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.LiNGAM.MultiGroup +-- Description : MultiGroupLiNGAM (Shimizu 2012、群間で共通 DAG 構造・係数値のみ異なる LiNGAM 拡張) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: MultiGroupLiNGAM (Shimizu 2012): 複数群 (group) で __共通の DAG 構造__ を +-- 仮定し、 群間で係数値は異なる可能性を許す LiNGAM 拡張。 +-- +-- ## モデル +-- +-- 群 g = 1..G について、 観測 X^(g) は同じ causal order に従う SEM: +-- +-- > X^(g) = B^(g) · X^(g) + e^(g) +-- +-- 各 B^(g) の非零パターン (= DAG 構造) は __全群共通__ を仮定するが、 値は +-- 群ごとに異なってよい。 これは半導体現場の「異なる工場 / 装置号機 / 世代で +-- 同じ因果構造、 効き量だけ違う」 という想定とマッチする。 +-- +-- ## アルゴリズム +-- +-- 1. 各群 X^(g) について @fitDirectLiNGAM@ を独立に実行 → B^(g)、 K^(g) +-- 2. 全群の K^(g) を集約して __多数決で共通 causal order__ を確定 +-- (本実装: 各位置 j の頻度最大ノードを選び、 不一致時は位置 j の総合的 +-- 平均スコアを再計算) +-- 3. 共通 order に従い、 各群で再度 OLS で B^(g) を組み直す +-- 4. __共通 adjacency__: 各群で |B^(g)[i, j]| > thr となるエッジ数が +-- 全群のうち過半数なら採用 +-- +-- ## リファレンス +-- +-- Shimizu (2012) "Joint estimation of linear non-Gaussian acyclic models", +-- Neurocomputing 81. Python 実装は cdt15/lingam の `lingam/multi_group_lingam.py`。 +-- +-- [English]: MultiGroupLiNGAM (Shimizu 2012): a LiNGAM extension that assumes +-- a __common DAG structure__ across multiple groups while allowing the +-- coefficient values to differ between groups. +-- +-- ## Model +-- +-- For each group g = 1..G, the observations X^(g) follow the same SEM under +-- a common causal order: +-- +-- > X^(g) = B^(g) · X^(g) + e^(g) +-- +-- The non-zero pattern of each B^(g) (= DAG structure) is assumed to be +-- __common to all groups__, but the values may differ per group. This +-- matches the semiconductor-fab scenario of "different factories \/ tool +-- numbers \/ generations sharing the same causal structure but differing +-- only in effect magnitude." +-- +-- ## Algorithm +-- +-- 1. Run @fitDirectLiNGAM@ independently on each group's X^(g) → B^(g), K^(g) +-- 2. Aggregate all groups' K^(g) to determine the __common causal order by majority vote__ +-- (this implementation: pick the most frequent node at +-- each position j, and on ties recompute the overall average score for +-- position j) +-- 3. Refit B^(g) for each group by OLS again, following the common order +-- 4. __Common adjacency__: adopt an edge if the count of groups where +-- |B^(g)[i, j]| > thr exceeds the majority threshold across all groups +-- +-- ## Reference +-- +-- Shimizu (2012) "Joint estimation of linear non-Gaussian acyclic models", +-- Neurocomputing 81. The Python implementation is cdt15/lingam's +-- `lingam/multi_group_lingam.py`. +module Hanalyze.Model.LiNGAM.MultiGroup + ( MultiGroupConfig (..) + , MultiGroupFit (..) + , defaultMultiGroupConfig + , fitMultiGroupLiNGAM + , mgCommonDAG + ) where + +import qualified Numeric.LinearAlgebra as LA +import Data.List (foldl', sort, group, sortBy) +import Data.Ord (comparing, Down (..)) + +import qualified Hanalyze.Model.LiNGAM.Direct as DL +import qualified Hanalyze.Model.DAG as DAG + +-- =========================================================================== +-- 設定 / 結果 +-- =========================================================================== + +data MultiGroupConfig = MultiGroupConfig + { mgcDirectCfg :: !DL.DirectLiNGAMConfig + , mgcMajority :: !Double + -- ^ [日本語]: adjacency 多数決閾値 (0..1)、 default 0.5。 [English]: Adjacency + -- majority-vote threshold (0..1), default 0.5. + } deriving (Show) + +defaultMultiGroupConfig :: MultiGroupConfig +defaultMultiGroupConfig = MultiGroupConfig + { mgcDirectCfg = DL.defaultDirectLiNGAMConfig + , mgcMajority = 0.5 + } + +data MultiGroupFit = MultiGroupFit + { mgGroupFits :: ![DL.DirectLiNGAMFit] + -- ^ [日本語]: 各群独立 fit 結果。 [English]: Independent fit results per group. + , mgCommonOrder :: ![Int] + -- ^ [日本語]: 多数決で確定した共通 causal order。 [English]: The common + -- causal order determined by majority vote. + , mgGroupBMats :: ![LA.Matrix Double] + -- ^ [日本語]: 共通 order で再 fit した各群 B 行列。 [English]: Each group's B + -- matrix, refit under the common order. + , mgCommonAdj :: !(LA.Matrix Double) + -- ^ [日本語]: 多数決による共通 adjacency マスク (0/1)。 [English]: The common + -- adjacency mask (0\/1) determined by majority vote. + } deriving (Show) + +-- =========================================================================== +-- 主実装 +-- =========================================================================== + +fitMultiGroupLiNGAM :: MultiGroupConfig -> [LA.Matrix Double] -> MultiGroupFit +fitMultiGroupLiNGAM cfg groups = + let !groupFits = [ DL.fitDirectLiNGAM (mgcDirectCfg cfg) g | g <- groups ] + !p = if null groupFits then 0 else LA.cols (DL.dlB (head groupFits)) + !commonOrd = majorityOrder p (map DL.dlOrder groupFits) + -- 共通 order に従って各群で B を再度 OLS で組み立てる + !commonBs = [ refitWithOrder commonOrd g | g <- groups ] + !commonAdj = majorityAdjacency + (mgcMajority cfg) + (DL.dlcPruneThr (mgcDirectCfg cfg)) + commonBs + in MultiGroupFit + { mgGroupFits = groupFits + , mgCommonOrder = commonOrd + , mgGroupBMats = commonBs + , mgCommonAdj = commonAdj + } + +-- | [日本語]: 共通 adjacency に基づく DAG 表現。 重みは全群 B の平均を使う。 +-- [English]: A DAG representation based on the common adjacency. The +-- weights use the average of all groups' B. +mgCommonDAG :: MultiGroupFit -> DAG.DAG +mgCommonDAG fit = + let !bs = mgGroupBMats fit + !adj = mgCommonAdj fit + !p = LA.rows adj + !g = fromIntegral (length bs) :: Double + !meanB = LA.scale (1 / g) (foldl' (+) (LA.konst 0 (p, p)) bs) + f i j + | i == j = 0 + | LA.atIndex adj (i, j) == 0 = 0 + | otherwise = LA.atIndex meanB (i, j) + w = LA.build (p, p) (\i j -> f (round i) (round j) :: Double) + in DAG.mkDAG w + +-- =========================================================================== +-- 内部 +-- =========================================================================== + +-- | [日本語]: 多数決で共通 causal order を決める。 各位置 j で最頻 node を取り、 +-- 重複が出たら未確定 node を残りから追加する fallback。 +-- [English]: Determines the common causal order by majority vote. Takes the +-- most frequent node at each position j, and falls back to adding an +-- undetermined node from the remainder when a duplicate occurs. +majorityOrder :: Int -> [[Int]] -> [Int] +majorityOrder p orders + | null orders = [0 .. p - 1] + | otherwise = + let posCount j = [ ord !! j | ord <- orders, length ord > j ] + mostFreq xs = + let !grouped = sortBy (comparing (Down . length)) + (group (sort xs)) + in case grouped of + ((h:_):_) -> h + _ -> 0 + go acc unused j + | j >= p = reverse acc + | otherwise = + let !cand = mostFreq (posCount j) + in if cand `elem` unused + then go (cand : acc) (filter (/= cand) unused) (j + 1) + else + -- fallback: 残りから一番低 index + case unused of + [] -> reverse acc + (h : _) -> + go (h : acc) (filter (/= h) unused) (j + 1) + in go [] [0 .. p - 1] 0 + +-- | [日本語]: 指定 causal order に従い X から B を OLS で組み立て直す。 +-- [English]: Rebuilds B from X by OLS, following the given causal order. +refitWithOrder :: [Int] -> LA.Matrix Double -> LA.Matrix Double +refitWithOrder order x = + let !p = LA.cols x + mkRow j = + let kj = order !! j + parents = take j order + in if null parents + then LA.fromList (replicate p 0) + else + let pm = LA.fromColumns + [ LA.flatten (x LA.¿ [pIdx]) | pIdx <- parents ] + y = LA.flatten (x LA.¿ [kj]) + beta = LA.flatten + (LA.linearSolveLS (LA.tr pm LA.<> pm) + (LA.asColumn (LA.tr pm LA.#> y))) + updates = zip parents (LA.toList beta) + coefV = replicate p 0 + filled = foldl' (\acc (i, v) -> set acc i v) coefV updates + in LA.fromList filled + bRows = [ mkRow j | j <- [0 .. p - 1] ] + pos i = case lookup i (zip order [0 ..]) of + Just k -> k + Nothing -> 0 + origOrderMat = LA.fromRows [ bRows !! pos i | i <- [0 .. p - 1] ] + in origOrderMat + where + set xs i v = take i xs ++ [v] ++ drop (i + 1) xs + +-- | [日本語]: 多数決による共通 adjacency: |B^(g)[i, j]| > thr が 全群中 majorityRatio +-- 以上の比率で起こったら 1。 +-- [English]: Common adjacency by majority vote: 1 if |B^(g)[i, j]| > thr +-- occurs at a rate at or above majorityRatio across all groups. +majorityAdjacency + :: Double -- majority ratio (0..1) + -> Double -- B threshold + -> [LA.Matrix Double] + -> LA.Matrix Double +majorityAdjacency majRatio thr bs = + let !p = LA.rows (head bs) + !g = fromIntegral (length bs) :: Double + f i j + | i == j = 0 + | otherwise = + let cnt = length [ () | b <- bs + , abs (LA.atIndex b (i, j)) > thr ] + rate = fromIntegral cnt / g + in if rate >= majRatio then 1 else 0 + in LA.build (p, p) (\i j -> f (round i) (round j) :: Double) diff --git a/src/Hanalyze/Model/LiNGAM/Pairwise.hs b/src/Hanalyze/Model/LiNGAM/Pairwise.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/LiNGAM/Pairwise.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.LiNGAM.Pairwise +-- Description : Pairwise LiNGAM (Hyvärinen-Smith 2013、2 変数間の因果方向推定) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Pairwise LiNGAM: 2 変数間の因果方向 (x → y か y → x か) 推定。 +-- +-- ## アルゴリズム (Hyvärinen-Smith 2013) +-- +-- 標準化された (x, y) について、 非ガウシアン独立性に基づき: +-- +-- R(x → y) = - Cov(x³, y) · sign(Cov(x, y)) + Cov(x, y³) +-- +-- の符号で方向を決定する近似的測度 (LIM, likelihood ratio approximation)。 +-- +-- - R > 0 → x → y +-- - R < 0 → y → x +-- - |R| 小 → 判定不能 (ガウシアン近接 or 弱依存) +-- +-- 軽量で 2 変数の方向推定に直接使える。 3 変数以上には @DirectLiNGAM@ を使う。 +-- +-- ## リファレンス +-- +-- Hyvärinen, A. & Smith, S. M. (2013) "Pairwise likelihood ratios for +-- estimation of non-Gaussian structural equation models", JMLR 14. +-- Python 実装は cdt15/lingam の `lingam/lim.py` (LIM = Likelihood-based +-- Independence Measure)。 +-- +-- [English]: Pairwise LiNGAM: estimates the causal direction between two +-- variables (x → y or y → x). +-- +-- ## Algorithm (Hyvärinen-Smith 2013) +-- +-- For standardized (x, y), based on non-Gaussian independence: +-- +-- R(x → y) = - Cov(x³, y) · sign(Cov(x, y)) + Cov(x, y³) +-- +-- is an approximate measure (LIM, likelihood ratio approximation) whose +-- sign determines direction. +-- +-- - R > 0 → x → y. +-- - R < 0 → y → x. +-- - |R| small → inconclusive (near-Gaussian or weak dependence). +-- +-- Lightweight and usable directly for two-variable direction estimation. +-- Use @DirectLiNGAM@ for three or more variables. +-- +-- ## Reference +-- +-- Hyvärinen, A. & Smith, S. M. (2013) "Pairwise likelihood ratios for +-- estimation of non-Gaussian structural equation models", JMLR 14. The +-- Python implementation is cdt15/lingam's `lingam/lim.py` (LIM = +-- Likelihood-based Independence Measure). +module Hanalyze.Model.LiNGAM.Pairwise + ( PairwiseDirection (..) + , PairwiseResult (..) + , pairwiseLiNGAM + , pairwiseScore + ) where + +import qualified Numeric.LinearAlgebra as LA + +-- =========================================================================== +-- 型 +-- =========================================================================== + +data PairwiseDirection + = XtoY -- ^ [日本語]: x → y。 [English]: x → y. + | YtoX -- ^ [日本語]: y → x。 [English]: y → x. + | Inconclusive -- ^ [日本語]: |score| < threshold。 [English]: |score| < threshold. + deriving (Show, Eq) + +data PairwiseResult = PairwiseResult + { prScore :: !Double -- ^ [日本語]: R(x → y) の値、 符号で方向決定。 [English]: The value of R(x → y); its sign determines the direction. + , prDirection :: !PairwiseDirection + , prMagnitude :: !Double -- ^ [日本語]: |score|、 confidence の代理。 [English]: |score|, a proxy for confidence. + } deriving (Show) + +-- =========================================================================== +-- 実装 +-- =========================================================================== + +-- | [日本語]: Pairwise LiNGAM の主関数。 threshold 未満は Inconclusive。 +-- [English]: The main Pairwise LiNGAM function. Below the threshold, +-- returns Inconclusive. +pairwiseLiNGAM + :: Double -- threshold (default 0.0 = 符号だけで判定) + -> LA.Vector Double -- x + -> LA.Vector Double -- y + -> PairwiseResult +pairwiseLiNGAM thr x y = + let !s = pairwiseScore x y + !mag = abs s + !dir + | mag < thr = Inconclusive + | s > 0 = XtoY + | otherwise = YtoX + in PairwiseResult { prScore = s, prDirection = dir, prMagnitude = mag } + +-- | [日本語]: スコア R = -Cov(x³, y)·sign(Cov(x,y)) + Cov(x, y³) +-- x, y は内部で標準化される (zero-mean、 unit-variance)。 +-- [English]: The score R = -Cov(x³, y)·sign(Cov(x,y)) + Cov(x, y³). x, y +-- are standardized internally (zero-mean, unit-variance). +pairwiseScore :: LA.Vector Double -> LA.Vector Double -> Double +pairwiseScore xRaw yRaw = + let !x = standardize xRaw + !y = standardize yRaw + !x3 = x * x * x + !y3 = y * y * y + !cov_x_y = covar x y + !cov_x3_y = covar x3 y + !cov_x_y3 = covar x y3 + !sgn = if cov_x_y >= 0 then 1.0 else (-1.0 :: Double) + in - cov_x3_y * sgn + cov_x_y3 + +-- =========================================================================== +-- 内部 +-- =========================================================================== + +standardize :: LA.Vector Double -> LA.Vector Double +standardize v = + let !n = fromIntegral (LA.size v) :: Double + !mu = LA.sumElements v / n + !c = v - LA.scalar mu + !s = sqrt (c `LA.dot` c / n) + !sd = if s > 1e-12 then s else 1.0 + in LA.scale (1 / sd) c + +covar :: LA.Vector Double -> LA.Vector Double -> Double +covar a b = + let !n = fromIntegral (LA.size a) :: Double + !ma = LA.sumElements a / n + !mb = LA.sumElements b / n + !ca = a - LA.scalar ma + !cb = b - LA.scalar mb + in ca `LA.dot` cb / n diff --git a/src/Hanalyze/Model/LiNGAM/Parce.hs b/src/Hanalyze/Model/LiNGAM/Parce.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/LiNGAM/Parce.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.LiNGAM.Parce +-- Description : ParceLiNGAM (Tashiro 2014、潜在交絡に頑健な bottom-up + HSIC LiNGAM 拡張) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: ParceLiNGAM (Tashiro et al. 2014): +-- __潜在交絡 (unobserved confounders) に頑健な__ LiNGAM 拡張。 +-- +-- ## モデル +-- +-- 通常の LiNGAM は @X = B X + e@ で e の各成分独立を要求する。 潜在交絡が +-- ある場合、 観測 X だけ見ると e が独立に見えず DirectLiNGAM は誤った因果 +-- 順序を出すことがある。 ParceLiNGAM は: +-- +-- > X = B X + Λ · f + e +-- +-- ここで f が潜在交絡変数。 +-- +-- ## アルゴリズム (v0.2、 bottom-up + HSIC、 cdt15/lingam 準拠) +-- +-- cdt15/lingam の `lingam/bottom_up_parce_lingam.py` を参照実装とする +-- bottom-up 探索: +-- +-- 1. 候補集合 U = {0, .., p-1} を初期化 +-- 2. 各候補 j ∈ U について、 残り @U \\ {j}@ の変数で x_j を OLS 回帰した +-- 残差 R を作る。 「x_j が最も下流 (sink)」 ならば +-- @{x_i : i ∈ U \\ {j}}@ と R は独立になるはず +-- 3. 独立度を @hsicAggregate (x_{U \\ {j}}, R)@ で測る (HSIC 総和)。 +-- 最小のものを最も下流の候補 j* として選ぶ +-- 4. その HSIC 集約値が threshold @pcAcceptThr@ を下回れば j* を順序末尾に +-- 追加して U から削除。 そうでなければ探索停止 +-- 5. 未確定の変数群は __unresolved group__ ('pcUnresolvedGroup') として +-- まとめて返す (潜在交絡で順序が同定不能) +-- +-- v0.1 (per-pair OLS + Pairwise LiNGAM) は __削除__ した。 v0.2 は +-- リファレンス実装と同じ「集合 vs 単変量残差」 の依存判定に切替。 +-- +-- ## 独立性判定の妥協点 +-- +-- cdt15/lingam では HSIC を gamma 近似で p 値化し Fisher 法で合成する。 +-- v0.2 では HSIC __統計量の総和__ を直接スコアとして使い、 閾値で判定する +-- (実装軽量化、 p 値の校正は将来課題)。 相対比較 (どの候補が最も独立か) +-- は機能する。 absolute threshold はサンプル数 / 分散依存なので、 ユーザは +-- @pcAcceptThr@ をデータに合わせて調整する想定。 +-- +-- ## リファレンス +-- +-- Tashiro et al. (2014) "ParceLiNGAM: A causal ordering method robust against +-- latent confounders", Neural Computation 26(1). +-- cdt15/lingam の `lingam/bottom_up_parce_lingam.py`。 +-- +-- [English]: ParceLiNGAM (Tashiro et al. 2014): a LiNGAM extension +-- __robust to latent confounders (unobserved confounders)__. +-- +-- ## Model +-- +-- Ordinary LiNGAM, @X = B X + e@, requires each component of e to be +-- independent. When latent confounders are present, e may not appear +-- independent when looking only at the observed X, and DirectLiNGAM can +-- produce an incorrect causal order. ParceLiNGAM instead assumes: +-- +-- > X = B X + Λ · f + e +-- +-- where f is the latent confounding variable. +-- +-- ## Algorithm (v0.2, bottom-up + HSIC, follows cdt15/lingam) +-- +-- A bottom-up search whose reference implementation is cdt15/lingam's +-- `lingam/bottom_up_parce_lingam.py`: +-- +-- 1. Initialize the candidate set U = {0, .., p-1} +-- 2. For each candidate j ∈ U, build the residual R from OLS-regressing +-- x_j on the remaining variables @U \\ {j}@. If "x_j is the most +-- downstream (sink)", then @{x_i : i ∈ U \\ {j}}@ and R should be +-- independent +-- 3. Measure independence via @hsicAggregate (x_{U \\ {j}}, R)@ (the +-- HSIC sum). Pick the candidate j* with the smallest value as the +-- most downstream +-- 4. If that HSIC aggregate falls below the threshold @pcAcceptThr@, +-- append j* to the end of the order and remove it from U. Otherwise +-- stop the search +-- 5. Any undetermined variables are returned together as an +-- __unresolved group__ ('pcUnresolvedGroup') (order could not be +-- identified due to latent confounders) +-- +-- v0.1 (per-pair OLS + Pairwise LiNGAM) was __removed__. v0.2 switched +-- to the same "set vs univariate residual" dependence test as the +-- reference implementation. +-- +-- ## Compromise on the independence test +-- +-- cdt15/lingam converts HSIC into p-values via a gamma approximation +-- and combines them with Fisher's method. v0.2 uses the +-- __sum of the HSIC statistic__ directly as the score and thresholds it (a +-- lighter-weight implementation; calibrating p-values is future work). +-- Relative comparison (which candidate is most independent) works +-- fine. Since the absolute threshold depends on sample size \/ +-- variance, the user is expected to tune @pcAcceptThr@ to their data. +-- +-- ## References +-- +-- Tashiro et al. (2014) "ParceLiNGAM: A causal ordering method robust +-- against latent confounders", Neural Computation 26(1). +-- cdt15/lingam's `lingam/bottom_up_parce_lingam.py`. +module Hanalyze.Model.LiNGAM.Parce + ( ParceConfig (..) + , ParceFit (..) + , defaultParceConfig + , fitParceLiNGAM + , parceDAG + ) where + +import qualified Numeric.LinearAlgebra as LA +import Data.List (foldl', sortBy) +import Data.Ord (comparing) + +import qualified Hanalyze.Math.HSIC as HSIC +import qualified Hanalyze.Model.DAG as DAG + +-- =========================================================================== +-- 設定 / 結果 +-- =========================================================================== + +data ParceConfig = ParceConfig + { pcRelRatio :: !Double + -- ^ [日本語]: 受理判定の相対比閾値。 best 候補の HSIC 集約値が 2 番目候補の値の + -- pcRelRatio 倍未満なら sink として受理。 default 0.5 + -- (best が 2nd の半分未満で「明瞭に独立」 と判断)。 + -- + -- 絶対 HSIC の値はサンプル数 / 分散 / median bandwidth に強く依存する + -- ため、 v0.2 では絶対閾値を捨て __相対比のみ__ で判定する。 集合サイズ |U| + -- = 2 のときは 2 候補のうち小さい方/大きい方が pcRelRatio 未満 + -- なら受理 (= 自然な「明瞭差」 検出)。 + -- + -- [English]: The relative-ratio threshold for the acceptance + -- test. Accepted as a sink if the best candidate's HSIC aggregate + -- is under pcRelRatio times the second candidate's value. Default + -- 0.5 (judged "clearly independent" if the best is under half the + -- 2nd). + -- + -- Because the absolute HSIC value depends strongly on sample + -- size \/ variance \/ median bandwidth, v0.2 discards the + -- absolute threshold and judges by __relative ratio only__. When + -- |U| = 2, it is accepted if the smaller\/larger of the two + -- candidates is under pcRelRatio (= a natural detector of a + -- "clear gap"). + , pcPruneThr :: !Double + -- ^ [日本語]: B 行列 pruning 閾値、 default 0.05。 [English]: The B-matrix pruning threshold, default 0.05. + } deriving (Show) + +defaultParceConfig :: ParceConfig +defaultParceConfig = ParceConfig + { pcRelRatio = 0.5 + , pcPruneThr = 0.05 + } + +data ParceFit = ParceFit + { pcOrder :: ![Int] + -- ^ [日本語]: 確定できた causal order (sink → source の順で逆に並んだものを + -- さらに反転 → source → sink の順)。 unresolved group があるときは + -- その後ろに連結 (Spec 互換のため任意順で末尾追加)。 + -- [English]: The determined causal order (found in sink → source + -- order, then reversed → source → sink order). If there is an + -- unresolved group, it is concatenated after (appended at the end + -- in arbitrary order for spec compatibility). + , pcB :: !(LA.Matrix Double) + -- ^ [日本語]: 構造方程式係数行列。 unresolved 群内の係数は OLS で仮置きされる + -- (確定的順序が無いので解釈は控えめに)。 + -- [English]: The structural-equation coefficient matrix. The + -- coefficients within the unresolved group are provisionally set + -- via OLS (interpret with caution since there is no definite + -- order). + , pcAdjacency :: !(LA.Matrix Double) + , pcUnresolvedGroup :: ![Int] + -- ^ [日本語]: 潜在交絡で順序が同定不能と判定された変数群 (空ならば全変数確定)。 + -- [English]: The group of variables judged unidentifiable in + -- order due to latent confounders (empty if all variables are + -- determined). + } deriving (Show) + +-- =========================================================================== +-- 主実装 +-- =========================================================================== + +fitParceLiNGAM :: ParceConfig -> LA.Matrix Double -> ParceFit +fitParceLiNGAM cfg x = + let !p = LA.cols x + (sinkList, leftover) = bottomUpSearch cfg x [0 .. p - 1] + -- sinkList は新しく見つけた順に **prepend** しているので、 + -- 自然と「upstream → downstream」 (source → sink) の順に並ぶ。 + -- leftover (確定できなかった残り) を先頭に置く: 長さ 1 なら単なる + -- source、 長さ ≥ 2 なら **潜在交絡で順序不能** のグループ。 + !fullOrder = leftover ++ sinkList + !unresolved = if length leftover > 1 then leftover else [] + !bMat = buildBFromOrder p x fullOrder + !adjMat = adjFromB (pcPruneThr cfg) bMat + in ParceFit + { pcOrder = fullOrder + , pcB = bMat + , pcAdjacency = adjMat + , pcUnresolvedGroup = unresolved + } + +-- | [日本語]: DAG 表現を返す。 +-- [English]: Returns the DAG representation. +parceDAG :: ParceConfig -> ParceFit -> DAG.DAG +parceDAG cfg fit = DAG.fromBMatrix (pcPruneThr cfg) (pcB fit) + +-- =========================================================================== +-- bottom-up 探索 +-- =========================================================================== + +-- | [日本語]: 候補集合 U から sink を 1 つずつ削り出す。 +-- 戻り値: (確定した sink を upstream→downstream の順で並べたリスト、 +-- 残り未確定 U)。 ※ prepend で蓄積するため、 最後に見つけたもの +-- (=最も upstream に近い) が先頭、 最初に見つけたもの (=最も downstream) +-- が末尾、 つまり自然な source → sink 順。 +-- [English]: Peels off sinks one at a time from the candidate set U. +-- Returns: (the list of determined sinks in upstream→downstream +-- order, the remaining undetermined U). Note: since it accumulates +-- via prepend, the last one found (= closest to upstream) is at the +-- head, and the first one found (= most downstream) is at the tail — +-- i.e. the natural source → sink order. +bottomUpSearch + :: ParceConfig + -> LA.Matrix Double + -> [Int] -- 初期 U (全変数 index) + -> ([Int], [Int]) +bottomUpSearch cfg x = go [] + where + go !sinks u + | length u <= 1 = (sinks, u) -- 1 個以下なら確定済とみなす + | otherwise = + let scored = sortBy (comparing snd) + [ (j, scoreSink x u j) | j <- u ] + (jStar, sB) = head scored + sNext = snd (scored !! 1) + accept = sB < pcRelRatio cfg * sNext + in if accept + then go (jStar : sinks) (filter (/= jStar) u) + else (sinks, u) -- 明瞭な sink が無い → halt + +-- | [日本語]: 候補 j を sink と仮定したときの「他変数 U\\{j} ⊥ R_j」 の HSIC 集約値。 +-- R_j = x_j を x_{U\\{j}} で OLS 回帰した残差。 +-- [English]: The HSIC aggregate of "other variables U\\{j} ⊥ R_j" +-- under the assumption that candidate j is the sink. R_j is the +-- residual of x_j OLS-regressed on x_{U\\{j}}. +scoreSink :: LA.Matrix Double -> [Int] -> Int -> Double +scoreSink x u j = + let others = filter (/= j) u + xj = LA.flatten (x LA.¿ [j]) + xRest = LA.fromColumns [ LA.flatten (x LA.¿ [k]) | k <- others ] + r = partialResidual xj xRest + in HSIC.hsicAggregate xRest r + +-- =========================================================================== +-- 内部ヘルパ +-- =========================================================================== + +-- | [日本語]: y を Z (n × q 行列) に OLS 回帰した残差。 +-- [English]: The residual of OLS-regressing y on Z (an n × q matrix). +partialResidual :: LA.Vector Double -> LA.Matrix Double -> LA.Vector Double +partialResidual y z = + let xtx = LA.tr z LA.<> z + xty = LA.tr z LA.#> y + beta = LA.flatten (LA.linearSolveLS xtx (LA.asColumn xty)) + in y - z LA.#> beta + +-- | [日本語]: causal order に従い OLS で B 行列を構築 (DirectLiNGAM と同手順)。 +-- [English]: Builds the B matrix via OLS following the causal order +-- (same procedure as DirectLiNGAM). +buildBFromOrder :: Int -> LA.Matrix Double -> [Int] -> LA.Matrix Double +buildBFromOrder p x order = + let mkRow j = + let kj = order !! j + parents = take j order + in if null parents + then LA.fromList (replicate p 0) + else + let pm = LA.fromColumns + [ LA.flatten (x LA.¿ [pi_]) | pi_ <- parents ] + y = LA.flatten (x LA.¿ [kj]) + xtx = LA.tr pm LA.<> pm + xty = LA.tr pm LA.#> y + beta = LA.flatten + (LA.linearSolveLS xtx (LA.asColumn xty)) + updates = zip parents (LA.toList beta) + coefV = replicate p 0 + filled = foldl' (\acc (i, v) -> set acc i v) coefV updates + in LA.fromList filled + bRows = [ mkRow j | j <- [0 .. p - 1] ] + pos i = case lookup i (zip order [0 ..]) of + Just k -> k + Nothing -> 0 + in LA.fromRows [ bRows !! pos i | i <- [0 .. p - 1] ] + where + set xs i v = take i xs ++ [v] ++ drop (i + 1) xs + +adjFromB :: Double -> LA.Matrix Double -> LA.Matrix Double +adjFromB thr b = + let p = LA.rows b + f i j + | i == j = 0 + | abs (LA.atIndex b (i, j)) > thr = 1 + | otherwise = 0 + in LA.build (p, p) (\i j -> f (round i) (round j) :: Double) diff --git a/src/Hanalyze/Model/LiNGAM/VAR.hs b/src/Hanalyze/Model/LiNGAM/VAR.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/LiNGAM/VAR.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.LiNGAM.VAR +-- Description : VAR-LiNGAM (Hyvärinen et al. 2010) — 時系列データに対する LiNGAM 拡張 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: VAR-LiNGAM (Hyvärinen et al. 2010): 時系列データに対する LiNGAM 拡張。 +-- +-- ## モデル +-- +-- 観測時系列 Y_t ∈ ℝ^K は以下の SVAR (構造 VAR) に従う: +-- +-- > Y_t = Σ_{l=1..p} A_l^* · Y_{t-l} + B_0 · Y_t + e_t +-- +-- ここで B_0 は同時刻因果 (contemporaneous causal effect、 acyclic + LiNGAM)、 +-- e_t は非ガウシアン独立 noise。 通常の reduced-form VAR(p) と関係: +-- +-- > Y_t = Σ_l A_l · Y_{t-l} + u_t, u_t = (I - B_0)⁻¹ · e_t +-- +-- なので u_t に LiNGAM を適用すれば B_0 が求まり、 A_l^* も A_l と B_0 から +-- 回収できる。 +-- +-- ## アルゴリズム +-- +-- 1. 'Hanalyze.Model.VAR.fitVAR' で reduced-form VAR(p) を fit +-- 2. 残差 u_t (= @varResiduals@) に @fitDirectLiNGAM@ を適用 → B_0 と +-- causal order を取得 +-- 3. 構造 lag 行列を A_l^* = (I - B_0) · A_l で復元 (l=1..p) +-- +-- ## リファレンス +-- +-- Hyvärinen et al. (2010) "Estimation of a Structural Vector Autoregression +-- Model Using Non-Gaussianity", JMLR 11. Python 実装は cdt15/lingam の +-- `lingam/var_lingam.py`。 +-- +-- [English]: VAR-LiNGAM (Hyvärinen et al. 2010): a LiNGAM extension for +-- time-series data. +-- +-- ## Model +-- +-- The observed time series Y_t ∈ ℝ^K follows the SVAR (structural VAR) +-- below: +-- +-- > Y_t = Σ_{l=1..p} A_l^* · Y_{t-l} + B_0 · Y_t + e_t +-- +-- where B_0 is the contemporaneous causal effect (acyclic + LiNGAM), +-- and e_t is non-Gaussian independent noise. Related to the ordinary +-- reduced-form VAR(p): +-- +-- > Y_t = Σ_l A_l · Y_{t-l} + u_t, u_t = (I - B_0)⁻¹ · e_t +-- +-- so applying LiNGAM to u_t recovers B_0, and A_l^* can also be +-- recovered from A_l and B_0. +-- +-- ## Algorithm +-- +-- 1. Fit the reduced-form VAR(p) with 'Hanalyze.Model.VAR.fitVAR' +-- 2. Apply @fitDirectLiNGAM@ to the residuals u_t (= @varResiduals@) → +-- obtain B_0 and the causal order +-- 3. Recover the structural lag matrices as A_l^* = (I - B_0) · A_l +-- (l=1..p) +-- +-- ## References +-- +-- Hyvärinen et al. (2010) "Estimation of a Structural Vector +-- Autoregression Model Using Non-Gaussianity", JMLR 11. The Python +-- implementation is cdt15/lingam's `lingam/var_lingam.py`. +module Hanalyze.Model.LiNGAM.VAR + ( VARLiNGAMConfig (..) + , VARLiNGAMFit (..) + , defaultVARLiNGAMConfig + , fitVARLiNGAM + , vlDAG + ) where + +import qualified Numeric.LinearAlgebra as LA + +import qualified Hanalyze.Model.VAR as V +import qualified Hanalyze.Model.LiNGAM.Direct as DL +import qualified Hanalyze.Model.DAG as DAG + +-- =========================================================================== +-- 設定 / 結果 +-- =========================================================================== + +data VARLiNGAMConfig = VARLiNGAMConfig + { vlcLagOrder :: !Int + -- ^ [日本語]: VAR の lag 数 p (≥ 1)。 [English]: The VAR lag count p (≥ 1). + , vlcDirectCfg :: !DL.DirectLiNGAMConfig + } deriving (Show) + +defaultVARLiNGAMConfig :: VARLiNGAMConfig +defaultVARLiNGAMConfig = VARLiNGAMConfig + { vlcLagOrder = 1 + , vlcDirectCfg = DL.defaultDirectLiNGAMConfig + } + +data VARLiNGAMFit = VARLiNGAMFit + { vlVARFit :: !V.VARFit + -- ^ [日本語]: reduced-form VAR(p) fit 結果。 [English]: The reduced-form VAR(p) fit result. + , vlContempLiNGAM :: !DL.DirectLiNGAMFit + -- ^ [日本語]: 残差 u_t に対する DirectLiNGAM 結果 (= 同時刻因果 B_0)。 [English]: The DirectLiNGAM result on the residuals u_t (= the contemporaneous causal effect B_0). + , vlB0 :: !(LA.Matrix Double) + -- ^ [日本語]: 同時刻因果係数 (K × K)、 = vlContempLiNGAM の dlB。 [English]: The contemporaneous causal coefficients (K × K), = vlContempLiNGAM's dlB. + , vlStructuralLags :: ![LA.Matrix Double] + -- ^ [日本語]: 構造 lag 行列 A_l^* = (I - B_0) · A_l (length = p)。 [English]: The structural lag matrices A_l^* = (I - B_0) · A_l (length = p). + , vlContempOrder :: ![Int] + } deriving (Show) + +-- =========================================================================== +-- 主実装 +-- =========================================================================== + +fitVARLiNGAM :: VARLiNGAMConfig -> LA.Matrix Double -> VARLiNGAMFit +fitVARLiNGAM cfg y = + let !varFit = V.fitVAR (vlcLagOrder cfg) y + !resid = V.varResiduals varFit + !lgFit = DL.fitDirectLiNGAM (vlcDirectCfg cfg) resid + !b0 = DL.dlB lgFit + !k = V.varK varFit + !iMinusB0 = LA.ident k - b0 + !structLags = + [ iMinusB0 LA.<> al | al <- V.varCoefs varFit ] + in VARLiNGAMFit + { vlVARFit = varFit + , vlContempLiNGAM = lgFit + , vlB0 = b0 + , vlStructuralLags = structLags + , vlContempOrder = DL.dlOrder lgFit + } + +-- | [日本語]: 同時刻因果 (B_0) の DAG 表現を返す。 lag 部分は含まない (時間方向は別の +-- 表現が必要、 v0.1 では同時刻のみ DAG 化)。 +-- [English]: Returns the DAG representation of the contemporaneous +-- causal effect (B_0). Does not include the lag part (the time +-- direction needs a separate representation; v0.1 only DAG-izes the +-- contemporaneous part). +vlDAG :: VARLiNGAMConfig -> VARLiNGAMFit -> DAG.DAG +vlDAG cfg fit = DAG.fromBMatrix (DL.dlcPruneThr (vlcDirectCfg cfg)) (vlB0 fit) diff --git a/src/Hanalyze/Model/MDS.hs b/src/Hanalyze/Model/MDS.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/MDS.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.MDS +-- Description : MDS (多次元尺度構成法) の高レベルモデル型 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: MDS の高レベルモデル型。 +-- +-- 低レベルの行列カーネル (@mdsClassical@ / 'mdsSammon' / @euclideanDist@) は +-- 'Hanalyze.Stat.MDS' に置き、 ここは @df |-> mds cfg cols@ で使う +-- __モデル型__ 'MDSResult' (= 'Hanalyze.Model.PCA.PCAResult' と同格) と +-- その設定 'MDSConfig' を提供する。 +-- +-- MDS (多次元尺度構成法) = サンプル間の __距離 (非類似度) を保ったまま__ 高次元 +-- データを 2D へ配置する可視化・次元圧縮。 'MDSClassical' (Torgerson・ユークリッド +-- 距離なら PCA と等価) と 'MDSSammon' (小距離重視の非線形版) を選べる。 結果は +-- 埋め込み (MDS1/MDS2) に加え __元データ (群色付け用の列を含む)__ を保持し、 +-- plot 側で @toPlot m@ (単色散布) / @toPlot (mdsView m <> mdsGroupBy \"g\")@ (群色) に使う。 +-- +-- [English]: A high-level MDS model type. +-- +-- The low-level matrix kernels (@mdsClassical@ \/ 'mdsSammon' \/ +-- @euclideanDist@) live in 'Hanalyze.Stat.MDS'; this module provides +-- the __model type__ 'MDSResult' (on par with +-- 'Hanalyze.Model.PCA.PCAResult') used with @df |-> mds cfg cols@, +-- along with its configuration 'MDSConfig'. +-- +-- MDS (multidimensional scaling) is a visualization \/ dimensionality +-- reduction technique that places high-dimensional data in 2D +-- __while preserving the distances (dissimilarities) between samples__. +-- You can +-- choose between 'MDSClassical' (Torgerson; equivalent to PCA for +-- Euclidean distance) and 'MDSSammon' (a nonlinear variant that +-- emphasizes small distances). The result holds the embedding (MDS1/MDS2) +-- plus the __source data (including columns for group coloring)__, used on +-- the plot side via @toPlot m@ (single-color scatter) \/ +-- @toPlot (mdsView m <> mdsGroupBy \"g\")@ (group coloring). +module Hanalyze.Model.MDS + ( -- * 手法と設定 + MDSMethod (..) + , MDSConfig (..) + , defaultMDS + -- ** 再 export (Sammon パラメータ) + , SammonConfig (..) + , defaultSammonConfig + -- * モデル型 + , MDSResult (..) + , runMDS + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA +import qualified DataFrame.Internal.DataFrame as DX + +import Hanalyze.DataIO.Convert (getDoubleVec) +import qualified Hanalyze.Stat.MDS as S +import Hanalyze.Stat.MDS (SammonConfig (..), defaultSammonConfig) + +-- =========================================================================== +-- 手法と設定 +-- =========================================================================== + +-- | [日本語]: MDS の手法選択。 'MDSClassical' = 古典 MDS (Torgerson・固有分解)、 +-- 'MDSSammon' = Sammon 写像 (小距離重視の非線形・勾配降下)。 +-- [English]: The MDS method choice. 'MDSClassical' = classical MDS +-- (Torgerson; eigendecomposition); 'MDSSammon' = Sammon mapping (a +-- nonlinear variant emphasizing small distances; gradient descent). +data MDSMethod = MDSClassical | MDSSammon + deriving (Show, Eq) + +-- | [日本語]: MDS の設定。 手法 ('mdsMethod') と、 'MDSSammon' 選択時に使う Sammon +-- パラメータ ('mdsSammon') を持つ (他の config 同様レコード型・裸の直和を +-- spec 引数にしない)。 k=2 固定・距離はユークリッドのみ (現状実装どおり)。 +-- [English]: The MDS configuration. Holds the method ('mdsMethod') and the +-- Sammon parameters ('mdsSammon') used when 'MDSSammon' is chosen (as with +-- other configs, this is a record type rather than a bare sum type as the +-- spec argument). k=2 is fixed, and the distance is Euclidean only (as +-- currently implemented). +data MDSConfig = MDSConfig + { mdsMethod :: !MDSMethod -- ^ [日本語]: 古典 / Sammon。 [English]: Classical \/ Sammon. + , mdsSammon :: !SammonConfig -- ^ [日本語]: 'MDSSammon' 選択時の勾配降下パラメータ。 [English]: The gradient-descent parameters used when 'MDSSammon' is chosen. + } deriving (Show) + +-- | [日本語]: 既定設定: 古典 MDS・Sammon パラメータは既定。 +-- [English]: The default configuration: classical MDS, default Sammon +-- parameters. +defaultMDS :: MDSConfig +defaultMDS = MDSConfig MDSClassical defaultSammonConfig + +-- =========================================================================== +-- モデル型 +-- =========================================================================== + +-- | [日本語]: 学習済 MDS。 2D 埋め込み (MDS1/MDS2) に加え、 __元データ ('mdsSourceFrame')__ を +-- 保持して plot 側の群色付け (@mdsGroupBy@) に使う。 'Hanalyze.Model.PCA.PCAResult' +-- と同格のモデル型 (df 型ではない)。 +-- [English]: A fitted MDS. Holds the 2D embedding (MDS1/MDS2) plus the +-- __source data ('mdsSourceFrame')__, used for group coloring +-- (@mdsGroupBy@) on the plot side. A model type on par with +-- 'Hanalyze.Model.PCA.PCAResult' (not a df type). +data MDSResult = MDSResult + { mdsMethodUsed :: !MDSMethod -- ^ [日本語]: 使った手法。 [English]: The method used. + , mdsEmbedding :: !(LA.Matrix Double) -- ^ [日本語]: 埋め込み (n × 2)。 [English]: The embedding (n × 2). + , mdsFeatures :: ![Text] -- ^ [日本語]: 入力に使った特徴列名。 [English]: The feature column names used as input. + , mdsSourceFrame :: !DX.DataFrame -- ^ [日本語]: 元データ (群色付け用に保持)。 [English]: The source data (kept for group coloring). + } + +-- | [日本語]: @runMDS cfg frame cols@ — frame の特徴列 @cols@ を行列化し、 ユークリッド +-- 距離 → 古典 / Sammon MDS で 2D 埋め込みを得る。 列が無い / 長さ不揃いなら 'Left'。 +-- [English]: @runMDS cfg frame cols@ — matrixizes frame's feature columns +-- @cols@, and obtains a 2D embedding via Euclidean distance → classical \/ +-- Sammon MDS. Returns 'Left' if columns are missing \/ of mismatched +-- length. +runMDS :: MDSConfig -> DX.DataFrame -> [Text] -> Either String MDSResult +runMDS _ _ [] = Left "MDS: 特徴列が空です (1 列以上必要)" +runMDS cfg frame cols = do + colVecs <- mapM getCol cols + let lens = map length colVecs + if not (allEq lens) + then Left ("MDS: 特徴列の長さが不揃いです: " <> show lens) + else do + let n = head lens + xMat = LA.fromLists [ [ v !! i | v <- colVecs ] | i <- [0 .. n - 1] ] + d = S.euclideanDist xMat + emb = case mdsMethod cfg of + MDSClassical -> S.mdsClassical d 2 + MDSSammon -> S.mdsSammon (mdsSammon cfg) d 2 + Right MDSResult + { mdsMethodUsed = mdsMethod cfg + , mdsEmbedding = emb + , mdsFeatures = cols + , mdsSourceFrame = frame + } + where + getCol c = case V.toList <$> getDoubleVec c frame of + Just vs -> Right vs + Nothing -> Left ("MDS: 数値列が見つかりません: " <> T.unpack c) + allEq [] = True + allEq (x:xs) = all (== x) xs diff --git a/src/Hanalyze/Model/MultiGP.hs b/src/Hanalyze/Model/MultiGP.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/MultiGP.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.MultiGP +-- Description : Multi-output Gaussian processes (共有 HP / per-output 独立 HP の 2 戦略) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Multi-output Gaussian processes. +-- +-- Two strategies are offered; pick by how outputs should share +-- hyperparameters: +-- +-- * __Shared-HP (default)__ — @fitMultiGP@ / @fitMultiGPMV@. +-- RBF only. A /single/ HP optimisation maximises the pooled marginal +-- likelihood @Σ_q log p(y_q | θ)@, and the resulting Cholesky factor +-- of @Ky@ is reused for every output's posterior solve. Mirrors +-- scikit-learn's @GaussianProcessRegressor.fit(X, Y::(n,q))@. About +-- @q@-fold faster than the per-output variant when @q > 1@. +-- +-- * __Per-output independent HPs__ — @fitMultiGPIndep@ / +-- @fitMultiGPMVIndep@. Supports any 'Kernel' kind. Each output +-- runs its own LBFGS HP fit, so per-task flexibility is preserved +-- at @q × O(LBFGS)@ cost. +-- +-- Both treat outputs as independent likelihoods (@B = I@ in the +-- Intrinsic Coregionalization Model). Co-kriging / LMC kernels with +-- learned cross-output correlations are not implemented. +module Hanalyze.Model.MultiGP + ( MultiGPModel (..) + -- * Default (shared-HP, RBF only) + , MultiGPResult (..) + , mgpStd + , fitMultiGP + , predictMultiGP + , MultiGPResultMV (..) + , fitMultiGPMV + -- * Per-output independent HPs (any kernel) + , fitMultiGPIndep + , fitMultiGPMVIndep + ) where + +import qualified Numeric.LinearAlgebra as LA +import Hanalyze.Model.GP (Kernel (..), GPModel (..), GPParams (..), + GPResult (..), + fitGP, optimizeGP, initParamsFromData, initParamsFromDataMV, + GPResultMV (..), fitGPMV, optimizeGPMVCached) +import qualified Hanalyze.Stat.KernelDist as KD +import qualified Hanalyze.Stat.Cholesky as Chol +import qualified Hanalyze.Optim.LBFGS as LBFGS +import qualified Hanalyze.Optim.Common as OC +import System.IO.Unsafe (unsafePerformIO) + +-- | Multi-output GP model with a per-output set of hyperparameters. +-- All outputs share the same kernel /type/ for simplicity; their +-- length-scales etc. are still optimized independently. +data MultiGPModel = MultiGPModel + { mgpKernel :: Kernel + , mgpParams :: [GPParams] -- ^ Hyperparameters per output. + } deriving (Show) + +-- | Per-output GP fit results. +data MultiGPResult = MultiGPResult + { mgpMean :: [[Double]] -- ^ Predictive means, one list per output (length @q@). + , mgpLower :: [[Double]] -- ^ 95 % lower band (@mean − 2σ@) per output. + , mgpUpper :: [[Double]] -- ^ 95 % upper band (@mean + 2σ@) per output. + , mgpModels :: [GPModel] -- ^ Underlying per-output 'GPModel's. + } deriving (Show) + +-- | Recover the per-output predictive standard deviation @σ@ from the +-- @mean@ / @upper@ bands. +mgpStd :: MultiGPResult -> [[Double]] +mgpStd r = zipWith (zipWith (\m u -> (u - m) / 2)) (mgpMean r) (mgpUpper r) + +-- | Fit a multi-output GP with shared RBF hyperparameters (default API). +-- +-- This is the 1D-input wrapper around 'fitMultiGPMV'. A single HP set +-- is learned by maximising the pooled marginal likelihood over all +-- @q@ outputs, then one Cholesky factor of @Ky = K + σ_n² I@ is +-- reused for each output's posterior solve. +-- +-- For per-output independent HPs (any kernel kind), use +-- 'fitMultiGPIndep'. +fitMultiGP :: [Double] -- ^ Training inputs (1D). + -> [[Double]] -- ^ Per-output training values (length @q@). + -> [Double] -- ^ Test inputs. + -> MultiGPResult +fitMultiGP trainX trainYs testX = + let xMat = LA.asColumn (LA.fromList trainX) + tMat = LA.asColumn (LA.fromList testX) + yVecs = map LA.fromList trainYs + r = fitMultiGPMV xMat yVecs tMat + in MultiGPResult + { mgpMean = map LA.toList (mgpmvMean r) + , mgpLower = map LA.toList (mgpmvLower r) + , mgpUpper = map LA.toList (mgpmvUpper r) + , mgpModels = mgpmvModels r + } + +-- | Fit a multi-output GP with per-output independent hyperparameters. +-- +-- Each output runs its own 'optimizeGP' LBFGS loop, then is predicted +-- at @testX@. Supports any 'Kernel' kind. Use this when outputs need +-- distinct length-scales / noise levels. +-- +-- For sklearn-style shared-HP behaviour (RBF, single HP optimisation, +-- much faster when @q > 1@), use 'fitMultiGP'. +fitMultiGPIndep :: Kernel -- ^ Kernel kind shared by every output. + -> [Double] -- ^ Training inputs (1D). + -> [[Double]] -- ^ Per-output training values (length @q@). + -> [Double] -- ^ Test inputs. + -> MultiGPResult +fitMultiGPIndep kern trainX trainYs testX = + let perOutput :: [Double] -> (GPModel, GPResult) + perOutput trainY = + let p0 = initParamsFromData trainX trainY + pOpt = optimizeGP kern trainX trainY p0 + mdl = GPModel kern pOpt + res = fitGP mdl trainX trainY testX + in (mdl, res) + pairs = map perOutput trainYs + models = map fst pairs + results = map snd pairs + in MultiGPResult + { mgpMean = map gpMean results + , mgpLower = map gpLower results + , mgpUpper = map gpUpper results + , mgpModels = models + } + +-- | Re-predict an existing 'MultiGPModel' at new test inputs (no +-- re-fitting). +predictMultiGP :: MultiGPModel + -> [Double] -- ^ Training inputs. + -> [[Double]] -- ^ Per-output training values. + -> [Double] -- ^ Test inputs. + -> MultiGPResult +predictMultiGP mgp trainX trainYs testX = + let kern = mgpKernel mgp + models = zipWith (\p _ -> GPModel kern p) (mgpParams mgp) trainYs + results = zipWith3 (\m _ ty -> fitGP m trainX ty testX) + models trainYs trainYs + in MultiGPResult + { mgpMean = map gpMean results + , mgpLower = map gpLower results + , mgpUpper = map gpUpper results + , mgpModels = models + } + +-- --------------------------------------------------------------------------- +-- Multi-input (multivariate X) API +-- --------------------------------------------------------------------------- + +-- | Multi-input multi-output GP fit result. Per-output mean / band +-- vectors (length @m@), with the optimized 'GPModel' that produced them. +data MultiGPResultMV = MultiGPResultMV + { mgpmvMean :: [LA.Vector Double] + , mgpmvLower :: [LA.Vector Double] + , mgpmvUpper :: [LA.Vector Double] + , mgpmvModels :: [GPModel] + } deriving (Show) + +-- | Multi-output GP fit with multivariate input and /shared/ RBF +-- hyperparameters (default API). +-- +-- Mirrors @sklearn.gaussian_process.GaussianProcessRegressor@'s +-- @fit(X, Y::(n,q))@ behaviour: one HP optimisation against the +-- pooled marginal likelihood @Σ_q log p(y_q | θ)@, then a single +-- Cholesky factor of @Ky = K + σ_n² I@ reused for every output's +-- posterior solve. Roughly @q@-fold faster than 'fitMultiGPMVIndep' +-- when @q > 1@. +-- +-- RBF only. For other kernels (Matérn 5/2, periodic) or per-output +-- length-scales, use 'fitMultiGPMVIndep'. +fitMultiGPMV + :: LA.Matrix Double -- ^ Training @X@ (@n × p@). + -> [LA.Vector Double] -- ^ Per-output training values (length @q@). + -> LA.Matrix Double -- ^ Test inputs (@m × p@). + -> MultiGPResultMV +fitMultiGPMV trainX trainYs testX = + let q = length trainYs + yMat = LA.fromColumns trainYs -- n × q + sharedD = KD.pairwiseSqDist trainX + -- Use the first output as the reference for HP initial values + -- (any output works; the result of the joint optimisation is + -- the same). + p0 = case trainYs of + (y0 : _) -> initParamsFromDataMV trainX y0 + [] -> error "fitMultiGPMV: no outputs" + pOpt = optimizeRBFAnalyticMulti sharedD trainX yMat p0 + mdl = GPModel RBF pOpt + results = [ fitGPMV mdl trainX yi testX | yi <- trainYs ] + in MultiGPResultMV + { mgpmvMean = map gpmvMean results + , mgpmvLower = map gpmvLower results + , mgpmvUpper = map gpmvUpper results + , mgpmvModels = replicate q mdl -- shared model + } + +-- | Like 'Hanalyze.Model.GP.optimizeRBFAnalytic' but the marginal likelihood is +-- the /sum/ over @q@ outputs sharing one kernel — single HP fit. +-- +-- Internally factor Ky once per LBFGS step, solve @α = Ky⁻¹ Y@ as one +-- @n × q@ RHS, and assemble the gradient via +-- @∇L = ½ tr((α αᵀ − q Ky⁻¹) ∂Ky/∂θ)@. +optimizeRBFAnalyticMulti + :: LA.Matrix Double -- ^ Pre-computed @D = pairwiseSqDist trainX@. + -> LA.Matrix Double -- ^ Training @X@ (used only for shape; actual + -- computations go through @D@). + -> LA.Matrix Double -- ^ @Y@ (@n × q@), one column per output. + -> GPParams -- ^ Initial params. + -> GPParams +optimizeRBFAnalyticMulti d2 trainX yMat p0 = + let n = LA.rows trainX + q = LA.cols yMat + qD = fromIntegral q :: Double + cfg = optimizerConfig + u0v = LA.fromList + [ log (gpLengthScale p0) + , log (gpSignalVar p0) + , log (gpNoiseVar p0) ] + + buildK uv = + let !ll = exp (uv `LA.atIndex` 0) + !sf2 = exp (uv `LA.atIndex` 1) + !sn2 = exp (uv `LA.atIndex` 2) + !inv2L2 = 1 / (2 * ll * ll) + !kMat = LA.cmap (\s -> sf2 * exp (- s * inv2L2)) d2 + !kyM = kMat + LA.scale sn2 (LA.ident n) + in (ll, sf2, sn2, kMat, kyM) + + objV uv = + let (_, _, _, _, kyM) = buildK uv + in case Chol.cholFactor kyM of + Nothing -> -1e30 + Just r -> + let logDet = 2 * sum (map log (LA.toList (LA.takeDiag r))) + alpha = Chol.cholSolveWithFactor r yMat -- n × q + -- Σ_q y_qᵀ α_q = trace(Yᵀ α) = elementwise sum (Y ⊙ α) + dataFit = LA.sumElements (yMat * alpha) + in -0.5 * dataFit - 0.5 * qD * logDet + - fromIntegral n * qD / 2 * log (2 * pi) + + gradV uv = + let (ll, _sf2, sn2, kMat, kyM) = buildK uv + in case Chol.cholFactor kyM of + Nothing -> LA.fromList [0, 0, 0] + Just r -> + let alpha = Chol.cholSolveWithFactor r yMat -- n × q + kyInv = Chol.cholSolveWithFactor r (LA.ident n) + -- Σ_q (α_qᵀ V α_q) = elementwise sum of (α ⊙ (V α)) + sumAVA v = + let vAlpha = v LA.<> alpha -- n × q + in LA.sumElements (alpha * vAlpha) + -- ∂Ky/∂(log ℓ) + !invL2 = 1 / (ll * ll) + !vL = LA.scale invL2 (kMat * d2) + !aVa_L = sumAVA vL + !tr_L = LA.sumElements (kyInv * vL) + !gLogL = 0.5 * (aVa_L - qD * tr_L) + -- ∂Ky/∂(log σ_f²) = K + !aVa_K = sumAVA kMat + !tr_K = LA.sumElements (kyInv * kMat) + !gLogSf = 0.5 * (aVa_K - qD * tr_K) + -- ∂Ky/∂(log σ_n²) = σ_n² I + !aVa_I = LA.sumElements (alpha * alpha) -- ‖α‖²_F + !tr_I = LA.sumElements (LA.takeDiag kyInv) + !gLogSn = 0.5 * sn2 * (aVa_I - qD * tr_I) + in LA.fromList [gLogL, gLogSf, gLogSn] + + result = unsafePerformIO $ LBFGS.runLBFGSWithV cfg objV gradV u0v + uOpt = OC.orBest result + in p0 + { gpLengthScale = exp (uOpt !! 0) + , gpSignalVar = exp (uOpt !! 1) + , gpNoiseVar = exp (uOpt !! 2) + } + where + optimizerConfig = + LBFGS.defaultLBFGSConfig + { LBFGS.lbDir = OC.Maximize + , LBFGS.lbStop = OC.defaultStopCriteria + { OC.stMaxIter = 200, OC.stTolFun = 1e-8 } + } + +-- | Multi-output GP fit with multivariate input and /independent/ +-- per-output hyperparameters. +-- +-- Each output column runs its own LBFGS HP optimisation via +-- @optimizeGPMVCached@. Supports any 'Kernel' kind (RBF / Matérn 5/2 +-- / periodic). Costs @q × O(LBFGS)@; use 'fitMultiGPMV' (shared HP) +-- for a roughly @q@-fold speed-up when outputs are homogeneous. +-- +-- The pairwise distance matrix @D = pairwiseSqDist X@ is shared +-- across the @q@ per-output optimisations to save @(q − 1) × O(n²)@ +-- work. +fitMultiGPMVIndep + :: Kernel + -> LA.Matrix Double -- ^ Training @X@ (@n × p@). + -> [LA.Vector Double] -- ^ Per-output training values (length @q@). + -> LA.Matrix Double -- ^ Test inputs (@m × p@). + -> MultiGPResultMV +fitMultiGPMVIndep kern trainX trainYs testX = + let -- @D = pairwiseSqDist trainX@ is shared across all q outputs + -- (trainX is the same input matrix), so we compute it once and + -- pass it into 'optimizeGPMVCached'. Each output's HP loop then + -- re-uses the same @D@ instead of recomputing it inside its own + -- per-output cache. Saves @(q − 1) × O(n²)@ work for kernel that + -- uses the isotropic length scale. + sharedD = KD.pairwiseSqDist trainX + perOutput :: LA.Vector Double -> (GPModel, GPResultMV) + perOutput trainY = + let p0 = initParamsFromDataMV trainX trainY + pOpt = optimizeGPMVCached kern (Just sharedD) trainX trainY p0 + mdl = GPModel kern pOpt + res = fitGPMV mdl trainX trainY testX + in (mdl, res) + pairs = map perOutput trainYs + models = map fst pairs + results = map snd pairs + in MultiGPResultMV + { mgpmvMean = map gpmvMean results + , mgpmvLower = map gpmvLower results + , mgpmvUpper = map gpmvUpper results + , mgpmvModels = models + } diff --git a/src/Hanalyze/Model/MultiLM.hs b/src/Hanalyze/Model/MultiLM.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/MultiLM.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.MultiLM +-- Description : Multivariate (multi-output) linear regression — 列別 OLS + 残差共分散推定 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Multivariate (multi-output) linear regression. +-- +-- @Y = XB + E@ with @Y@ of shape @n × q@ (@q@ outputs), @X@ of shape +-- @n × p@, @B@ of shape @p × q@ and @E@ of shape @n × q@. +-- +-- Solves each column independently by OLS (column-wise OLS) and +-- additionally estimates the residual covariance matrix @Σ@, which is +-- used for joint multi-output predictive intervals. +-- +-- The API matches 'Hanalyze.Model.LM', so @fitLM@ can be called directly; this +-- module merely exposes the additional multi-output information +-- (@Σ@, correlation matrix). +module Hanalyze.Model.MultiLM + ( MultiFit (..) + , fitMultiLM + , predictMultiLM + , residualCovariance + , residualCorrelation + ) where + +import qualified Numeric.LinearAlgebra as LA +import Hanalyze.Model.Core (FitResult (..)) +import qualified Hanalyze.Model.LM as LM + +-- | Augmented result for multi-output linear regression. +data MultiFit = MultiFit + { mfFit :: FitResult -- ^ Underlying matrix-based fit. + , mfResidCov :: LA.Matrix Double -- ^ Residual covariance @Σ@ (@q × q@). + , mfResidCor :: LA.Matrix Double -- ^ Residual correlation matrix (@q × q@). + , mfNumOutputs :: Int -- ^ Number of responses @q@. + , mfNumPredict :: Int -- ^ Number of predictors @p@. + , mfNumSamples :: Int -- ^ Number of observations @n@. + } deriving (Show) + +-- | Multi-output linear regression: @Y = XB + E@. +-- Delegates to 'LM.fitLM' and additionally returns the residual +-- covariance. +fitMultiLM :: LA.Matrix Double -- ^ Design matrix @X@ (@n × p@). + -> LA.Matrix Double -- ^ Response @Y@ (@n × q@). + -> MultiFit +fitMultiLM x y = + let fit = LM.fitLM x y + res = residuals fit + n = LA.rows y + q = LA.cols y + p = LA.cols x + df = max 1 (n - p) -- 自由度補正 + -- Σ = (1/(n-p)) * Eᵀ E + sigma = LA.scale (1 / fromIntegral df) + (LA.tr res LA.<> res) + -- 相関行列: D⁻¹ Σ D⁻¹ where D = diag(sqrt(diag(Σ))) + diagS = [ sqrt (sigma `LA.atIndex` (i, i)) + | i <- [0 .. q - 1] ] + corr = LA.fromLists + [ [ if di == 0 || dj == 0 then 0 + else (sigma `LA.atIndex` (i, j)) / (di * dj) + | j <- [0 .. q - 1] + , let dj = diagS !! j ] + | i <- [0 .. q - 1] + , let di = diagS !! i ] + in MultiFit fit sigma corr q p n + +-- | Predict @Ŷ@ (@m × q@) for new inputs @X_new@ (@m × p@). A thin +-- wrapper around 'LM.predictLM'. +predictMultiLM :: MultiFit -> LA.Matrix Double -> LA.Matrix Double +predictMultiLM mf xNew = + LM.predictLM (coefficients (mfFit mf)) xNew + +-- | Residual covariance matrix (alias for 'mfResidCov'). +residualCovariance :: MultiFit -> LA.Matrix Double +residualCovariance = mfResidCov + +-- | Residual correlation matrix. +residualCorrelation :: MultiFit -> LA.Matrix Double +residualCorrelation = mfResidCor diff --git a/src/Hanalyze/Model/MultiOutput.hs b/src/Hanalyze/Model/MultiOutput.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/MultiOutput.hs @@ -0,0 +1,85 @@ +-- | +-- Module : Hanalyze.Model.MultiOutput +-- Description : Common foundation for multi-output regression (単出力 ↔ 多出力変換 + 評価指標) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Common foundation for multi-output regression. +-- +-- Design policy: +-- +-- * Each model's /primary/ API takes the response @Y@ as +-- @LA.Matrix Double@ (@n × q@) and returns a matrix; the @q = 1@ case +-- is a specialization. +-- * The single-output API (@V.Vector Double@) is a thin wrapper that +-- promotes the response to a one-column matrix via 'asMultiY' / +-- 'fromMultiY' and reuses the multi-output implementation. +-- * Per-output evaluation metrics (R² etc.) are collected here. +module Hanalyze.Model.MultiOutput + ( -- * 単出力 ↔ 多出力 変換 + asMultiY + , fromMultiY + , asMultiYV + -- * Multi-output evaluation metrics + , rmseMulti + , r2Multi + , mseMulti + ) where + +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA + +-- --------------------------------------------------------------------------- +-- 変換 +-- --------------------------------------------------------------------------- + +-- | Promote a 1D 'V.Vector' to an @n × 1@ matrix. +-- +-- >>> import qualified Data.Vector as V +-- >>> LA.rows (asMultiY (V.fromList [1.0, 2.0, 3.0])) +-- 3 +-- >>> LA.cols (asMultiY (V.fromList [1.0, 2.0, 3.0])) +-- 1 +asMultiY :: V.Vector Double -> LA.Matrix Double +asMultiY = LA.asColumn . LA.fromList . V.toList + +-- | Promote an hmatrix 'LA.Vector' to an @n × 1@ matrix. +asMultiYV :: LA.Vector Double -> LA.Matrix Double +asMultiYV = LA.asColumn + +-- | Convert an @n × 1@ matrix back to a 1D vector. When @q ≠ 1@, returns +-- the first column. +fromMultiY :: LA.Matrix Double -> V.Vector Double +fromMultiY m + | LA.cols m == 0 = V.empty + | otherwise = V.fromList (LA.toList (LA.flatten (m LA.¿ [0]))) + +-- --------------------------------------------------------------------------- +-- 評価指標 +-- --------------------------------------------------------------------------- + +-- | Whole-matrix MSE: sum-of-squares divided by @n × q@. +mseMulti :: LA.Matrix Double -> LA.Matrix Double -> Double +mseMulti ys yhat = + let n = LA.rows ys + q = LA.cols ys + r = ys - yhat + in LA.sumElements (r * r) / fromIntegral (n * q) + +-- | Whole-matrix RMSE. +rmseMulti :: LA.Matrix Double -> LA.Matrix Double -> Double +rmseMulti ys yhat = sqrt (mseMulti ys yhat) + +-- | Per-column R² (vector of length @q@). +r2Multi :: LA.Matrix Double -> LA.Matrix Double -> V.Vector Double +r2Multi ys yhat = + let n = LA.rows ys + q = LA.cols ys + colR2 j = + let yc = LA.toList (LA.flatten (ys LA.¿ [j])) + yhc = LA.toList (LA.flatten (yhat LA.¿ [j])) + mu = sum yc / fromIntegral n + sst = sum [(y - mu)^(2::Int) | y <- yc] + sse = sum [(y - p)^(2::Int) | (y, p) <- zip yc yhc] + in if sst == 0 then 0 else 1 - sse / sst + in V.fromList [ colR2 j | j <- [0 .. q - 1] ] diff --git a/src/Hanalyze/Model/Multivariate.hs b/src/Hanalyze/Model/Multivariate.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Multivariate.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.Multivariate +-- Description : Specialized multivariate regression — Reduced-Rank Regression / PLS / CCA +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Specialized multivariate regression: Reduced-Rank Regression, PLS, +-- and CCA. +-- +-- These all express the relationship between a multi-response @Y@ +-- (@n × q@) and multi-predictor @X@ (@n × p@) via a low-rank structure. +-- +-- * 'reducedRankRegression' — @B = U_r V_rᵀ@ (rank-@r@ constraint). +-- * 'pls' — extracts directions of maximum +-- @X@-@Y@ covariance one at a time. +-- * 'cca' — canonical pairs maximizing @X@-@Y@ +-- correlation. +module Hanalyze.Model.Multivariate + ( -- * Reduced Rank Regression + RRRFit (..) + , reducedRankRegression + , predictRRR + -- * Partial Least Squares + , PLSFit (..) + , pls + , predictPLS + -- * Canonical Correlation Analysis + , CCAFit (..) + , cca + ) where + +import qualified Numeric.LinearAlgebra as LA + +-- --------------------------------------------------------------------------- +-- Reduced Rank Regression +-- --------------------------------------------------------------------------- + +-- | Reduced-Rank Regression result. The coefficient matrix @B@ is +-- constrained to rank @r@. +data RRRFit = RRRFit + { rrrBeta :: LA.Matrix Double -- ^ @B@ of shape @p × q@ (rank @≤ r@). + , rrrU :: LA.Matrix Double -- ^ Left factor (@p × r@). + , rrrV :: LA.Matrix Double -- ^ Right factor (@q × r@). + , rrrRank :: Int -- ^ Effective rank. + } deriving (Show) + +-- | Reduced-Rank Regression: @B = U Vᵀ@ with rank @r@. +-- +-- The OLS estimate @B̂@ is SVD-truncated to its top @r@ singular values: +-- @B̂_RRR = U_r Σ_r V_rᵀ@. +reducedRankRegression :: Int -- ^ Target rank @r@. + -> LA.Matrix Double -- ^ Design matrix @X@ (@n × p@). + -> LA.Matrix Double -- ^ Response @Y@ (@n × q@). + -> RRRFit +reducedRankRegression r x y = + let bOLS = x LA.<\> y -- OLS: p × q + (u, sv, vt) = LA.svd bOLS + r' = min r (LA.size sv) + uR = u LA.?? (LA.All, LA.Take r') + sR = LA.subVector 0 r' sv + vR = (LA.tr vt) LA.?? (LA.All, LA.Take r') + bRRR = uR LA.<> LA.diag sR LA.<> LA.tr vR + in RRRFit bRRR uR vR r' + +-- | Predict @Ŷ@ for new inputs from a 'RRRFit'. +predictRRR :: RRRFit -> LA.Matrix Double -> LA.Matrix Double +predictRRR fit xNew = xNew LA.<> rrrBeta fit + +-- --------------------------------------------------------------------------- +-- Partial Least Squares (NIPALS algorithm) +-- --------------------------------------------------------------------------- + +-- | PLS fit result. +data PLSFit = PLSFit + { plsBeta :: LA.Matrix Double -- ^ Regression coefficients (@p × q@). + , plsW :: LA.Matrix Double -- ^ Weights (@p × k@). + , plsT :: LA.Matrix Double -- ^ Scores (@n × k@). + , plsP :: LA.Matrix Double -- ^ Loadings (@p × k@). + , plsQ :: LA.Matrix Double -- ^ Y-loadings (@q × k@). + , plsK :: Int -- ^ Number of components extracted. + } deriving (Show) + +-- | NIPALS-PLS (Wold 1975). Extracts @k@ components sequentially. +-- +-- For each component: +-- +-- 1. @w = Xᵀ Y u / ‖Xᵀ Y u‖@ — the X-side weight (@u@ is the Y direction). +-- 2. @t = X w@. +-- 3. @p = Xᵀ t / (tᵀ t)@. +-- 4. @q = Yᵀ t / (tᵀ t)@. +-- 5. Deflate: @X ← X − t pᵀ@, @Y ← Y − t qᵀ@. +pls :: Int -- ^ Number of components @k@. + -> LA.Matrix Double -- ^ Design matrix @X@ (@n × p@). + -> LA.Matrix Double -- ^ Response @Y@ (@n × q@). + -> PLSFit +pls k x0 y0 = + let p = LA.cols x0 + q = LA.cols y0 + n = LA.rows x0 + _ = n + go' iter xCur yCur ws ts ps qs + | iter >= k = (reverse ws, reverse ts, reverse ps, reverse qs) + | otherwise = + let u = LA.flatten (yCur LA.¿ [0]) + xtyu = LA.tr xCur LA.#> u + w = if LA.norm_2 xtyu > 1e-12 + then LA.scale (1 / LA.norm_2 xtyu) xtyu + else LA.fromList (replicate p 0) + t = xCur LA.#> w + tt = max 1e-12 (LA.dot t t) + pVec = LA.scale (1/tt) (LA.tr xCur LA.#> t) + qVec = LA.scale (1/tt) (LA.tr yCur LA.#> t) + xNew = xCur - LA.outer t pVec + yNew = yCur - LA.outer t qVec + in go' (iter + 1) xNew yNew (w:ws) (t:ts) (pVec:ps) (qVec:qs) + (wsL, tsL, psL, qsL) = go' 0 x0 y0 [] [] [] [] + wM = LA.fromColumns wsL -- p × k + tM = LA.fromColumns tsL -- n × k + pM = LA.fromColumns psL -- p × k + qM = LA.fromColumns qsL -- q × k + -- 回帰係数: B = W (PᵀW)⁻¹ Qᵀ (Wold formula) + ptw = LA.tr pM LA.<> wM -- k × k + bMat = wM LA.<> LA.inv ptw LA.<> LA.tr qM -- p × q + _ = q + in PLSFit bMat wM tM pM qM k + +-- | Predict @Ŷ@ for new inputs from a 'PLSFit'. +predictPLS :: PLSFit -> LA.Matrix Double -> LA.Matrix Double +predictPLS fit xNew = xNew LA.<> plsBeta fit + +-- --------------------------------------------------------------------------- +-- Canonical Correlation Analysis +-- --------------------------------------------------------------------------- + +-- | CCA fit result. +data CCAFit = CCAFit + { ccaA :: LA.Matrix Double -- ^ X-side basis (@p × r@). + , ccaB :: LA.Matrix Double -- ^ Y-side basis (@q × r@). + , ccaCorr :: LA.Vector Double -- ^ Canonical correlations (length @r@). + , ccaScoresX :: LA.Matrix Double -- ^ X scores (@n × r@). + , ccaScoresY :: LA.Matrix Double -- ^ Y scores (@n × r@). + } deriving (Show) + +-- | Canonical Correlation Analysis: find basis pairs @(a_k, b_k)@ that +-- maximize the correlation between @X@ and @Y@. +-- +-- Algorithm: +-- +-- 1. Compute @C_xx = XᵀX/(n-1)@, @C_yy@, @C_xy@. +-- 2. SVD of @M = C_xx^{−1/2} C_xy C_yy^{−1/2}@: @M = U Σ Vᵀ@. +-- 3. @a = C_xx^{−1/2} U@, @b = C_yy^{−1/2} V@, correlations = @Σ@. +cca :: LA.Matrix Double -> LA.Matrix Double -> CCAFit +cca x y = + let n = fromIntegral (LA.rows x) :: Double + _p = LA.cols x + _q = LA.cols y + -- 中心化 + meanCol m = LA.fromList [LA.sumElements (LA.flatten (m LA.¿ [j])) / n + | j <- [0 .. LA.cols m - 1]] + mxs = meanCol x + mys = meanCol y + cx0 i = LA.flatten (x LA.¿ [i]) - LA.scalar (mxs LA.! i) + cy0 i = LA.flatten (y LA.¿ [i]) - LA.scalar (mys LA.! i) + xC = LA.fromColumns [cx0 i | i <- [0 .. LA.cols x - 1]] + yC = LA.fromColumns [cy0 i | i <- [0 .. LA.cols y - 1]] + -- 共分散 + cxx = LA.scale (1 / (n - 1)) (LA.tr xC LA.<> xC) + cyy = LA.scale (1 / (n - 1)) (LA.tr yC LA.<> yC) + cxy = LA.scale (1 / (n - 1)) (LA.tr xC LA.<> yC) + -- 平方根逆行列 (固有値分解で計算) + invSqrt sym = + let (eigs, evec) = LA.eigSH (LA.sym sym) + invSqrtVals = LA.fromList + [ if v > 1e-12 then 1 / sqrt v else 0 + | v <- LA.toList eigs ] + in evec LA.<> LA.diag invSqrtVals LA.<> LA.tr evec + cxxIS = invSqrt cxx + cyyIS = invSqrt cyy + mMat = cxxIS LA.<> cxy LA.<> cyyIS + (uM, sM, vtM) = LA.svd mMat + aMat = cxxIS LA.<> uM + bMat = cyyIS LA.<> LA.tr vtM + scoresX = xC LA.<> aMat + scoresY = yC LA.<> bMat + in CCAFit aMat bMat sM scoresX scoresY diff --git a/src/Hanalyze/Model/NaiveBayes.hs b/src/Hanalyze/Model/NaiveBayes.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/NaiveBayes.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.NaiveBayes +-- Description : Naive Bayes 分類 (Gaussian + Multinomial) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Naive Bayes 分類 (Gaussian + Multinomial). +-- +-- @ +-- import qualified Hanalyze.Model.NaiveBayes as NB +-- let nb = NB.fitGNB x y -- 連続特徴: Gaussian +-- yhat = NB.predictNB nb x +-- +-- let mnb = NB.fitMNB 1.0 xCounts yCount -- カウント特徴: Multinomial (Laplace α) +-- @ +-- +-- [English]: Naive Bayes classification (Gaussian + Multinomial). +-- +-- @ +-- import qualified Hanalyze.Model.NaiveBayes as NB +-- let nb = NB.fitGNB x y -- continuous features: Gaussian +-- yhat = NB.predictNB nb x +-- +-- let mnb = NB.fitMNB 1.0 xCounts yCount -- count features: Multinomial (Laplace α) +-- @ +module Hanalyze.Model.NaiveBayes + ( -- * Gaussian NB + GaussianNB (..) + , fitGNB + -- * Multinomial NB + , MultinomialNB (..) + , fitMNB + -- * Predict (両対応) + , NBModel (..) + , predictNB + , predictNBLogProbs + ) where + +import qualified Data.Vector.Unboxed as VU +import qualified Numeric.LinearAlgebra as LA +import Data.Text (Text) +import Data.List (nub, sort, foldl') + +-- --------------------------------------------------------------------------- +-- Gaussian NB +-- --------------------------------------------------------------------------- + +-- | [日本語]: クラスごとに各特徴を独立 Gaussian と仮定。 +-- [English]: Assumes each feature is an independent Gaussian within each +-- class. +data GaussianNB = GaussianNB + { gnbClasses :: ![Int] + , gnbLogPrior :: ![Double] -- ^ [日本語]: log π_c (classes 順) [English]: log π_c (in class order). + , gnbMeans :: ![LA.Vector Double] -- ^ [日本語]: 各クラスの μ (length d) [English]: The μ of each class (length d). + , gnbVars :: ![LA.Vector Double] -- ^ [日本語]: 各クラスの σ² (length d)、 var smoothing 済 [English]: The σ² of each class (length d), var-smoothed. + , gnbClassNames :: ![Text] -- ^ [日本語]: クラス名 (df|-> が levels 注入・空=数値表示)。 [English]: Class names (df|-> injects the levels; empty means numeric display). + } deriving (Show) + +-- | [日本語]: sklearn 互換の var smoothing (最大 var の 1e-9 倍を全 var に加算)。 +-- [English]: sklearn-compatible var smoothing (adds 1e-9 times the maximum +-- variance to every variance). +varSmoothing :: Double +varSmoothing = 1e-9 + +fitGNB :: LA.Matrix Double -> VU.Vector Int -> GaussianNB +fitGNB x y = + let !n = VU.length y + !d = LA.cols x + classes = sort (nub (VU.toList y)) + rows c = [ i | i <- [0 .. n - 1], y VU.! i == c ] + meanV ids = + let m = LA.fromRows [ LA.flatten (x LA.? [i]) | i <- ids ] + nc = fromIntegral (length ids) :: Double + in LA.scale (1 / nc) (LA.fromList (map LA.sumElements (LA.toColumns m))) + varV ids mu = + let nc = fromIntegral (length ids) :: Double + sq i = let r = LA.flatten (x LA.? [i]) - mu + in r * r + sumSq = sum (map sq ids) + in LA.scale (1 / nc) sumSq + mus = [ meanV (rows c) | c <- classes ] + vrs0 = zipWith (\c mu -> varV (rows c) mu) classes mus + maxVar = maximum (map (LA.maxElement . LA.cmap abs) vrs0) + eps = varSmoothing * maxVar + 1e-300 + vrs = map (LA.cmap (+ eps)) vrs0 + priors = [ log (fromIntegral (length (rows c)) / fromIntegral n) + | c <- classes ] + _ = d -- d は使わない (内部で LA.size に頼る) + in GaussianNB classes priors mus vrs [] + +-- | log p(x | c) = -1/2 Σ_j [ log(2π σ²_j) + (x_j - μ_j)² / σ²_j ] +gnbLogLik :: GaussianNB -> LA.Vector Double -> [Double] +gnbLogLik nb xv = + [ let r = xv - mu + rsq = r * r + logT = LA.sumElements (LA.cmap log (LA.scale (2 * pi) vr)) + chiT = LA.sumElements (rsq / vr) + in -0.5 * (logT + chiT) + | (mu, vr) <- zip (gnbMeans nb) (gnbVars nb) ] + +-- --------------------------------------------------------------------------- +-- Multinomial NB +-- --------------------------------------------------------------------------- + +-- | [日本語]: テキスト分類等のカウント特徴用。 ラプラス平滑化 α (典型 1.0)。 +-- [English]: For count features such as in text classification. Laplace +-- smoothing α (typically 1.0). +data MultinomialNB = MultinomialNB + { mnbClasses :: ![Int] + , mnbLogPrior :: ![Double] + , mnbLogFeat :: ![LA.Vector Double] -- ^ log p(feature_j | c) + , mnbClassNames :: ![Text] -- ^ [日本語]: クラス名 (df|-> が levels 注入・空=数値表示)。 [English]: Class names (df|-> injects the levels; empty means numeric display). + } deriving (Show) + +fitMNB :: Double -- ^ Laplace α + -> LA.Matrix Double -- ^ [日本語]: 非負カウント (n × d) [English]: Non-negative counts (n × d). + -> VU.Vector Int -- ^ y + -> MultinomialNB +fitMNB alpha x y = + let !n = VU.length y + !d = LA.cols x + classes = sort (nub (VU.toList y)) + rows c = [ i | i <- [0 .. n - 1], y VU.! i == c ] + sumRows ids = + foldl' (+) (LA.konst 0 d) + [ LA.flatten (x LA.? [i]) | i <- ids ] + featLog c = + let s = sumRows (rows c) + !sNum = LA.cmap (+ alpha) s + !tot = LA.sumElements sNum + in LA.cmap log (LA.scale (1 / tot) sNum) + priors = [ log (fromIntegral (length (rows c)) / fromIntegral n) + | c <- classes ] + in MultinomialNB classes priors [ featLog c | c <- classes ] [] + +mnbLogLik :: MultinomialNB -> LA.Vector Double -> [Double] +mnbLogLik nb xv = + [ LA.dot xv lf | lf <- mnbLogFeat nb ] + +-- --------------------------------------------------------------------------- +-- 共通インターフェース +-- --------------------------------------------------------------------------- + +data NBModel = NBGaussian GaussianNB | NBMultinomial MultinomialNB + deriving (Show) + +nbClasses :: NBModel -> [Int] +nbClasses (NBGaussian m) = gnbClasses m +nbClasses (NBMultinomial m) = mnbClasses m + +nbLogPriorAndLik :: NBModel -> LA.Vector Double -> ([Double], [Double]) +nbLogPriorAndLik (NBGaussian m) xv = (gnbLogPrior m, gnbLogLik m xv) +nbLogPriorAndLik (NBMultinomial m) xv = (mnbLogPrior m, mnbLogLik m xv) + +predictNBLogProbs :: NBModel -> LA.Matrix Double -> [[Double]] +predictNBLogProbs nb x = + let !n = LA.rows x + row i = LA.flatten (x LA.? [i]) + logits xv = + let (lp, ll) = nbLogPriorAndLik nb xv + in zipWith (+) lp ll + -- log-sum-exp 正規化 + lse zs = + let !mx = maximum zs + in mx + log (sum [ exp (z - mx) | z <- zs ]) + one i = + let zs = logits (row i) + z = lse zs + in [ k - z | k <- zs ] + in [ one i | i <- [0 .. n - 1] ] + +predictNB :: NBModel -> LA.Matrix Double -> VU.Vector Int +predictNB nb x = + let probs = predictNBLogProbs nb x + classes = nbClasses nb + pick zs = + let (cMax, _) = foldr1 + (\(c, v) (c', v') -> if v >= v' then (c, v) else (c', v')) + (zip classes zs) + in cMax + in VU.fromList (map pick probs) diff --git a/src/Hanalyze/Model/NeuralNetwork.hs b/src/Hanalyze/Model/NeuralNetwork.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/NeuralNetwork.hs @@ -0,0 +1,543 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.NeuralNetwork +-- Description : Multi-Layer Perceptron (MLP) — feedforward neural network (mini-batch SGD + Adam) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Multi-Layer Perceptron (MLP) — feedforward neural network。 +-- +-- Mini-batch SGD + 自前 Adam で学習。 hmatrix Matrix/Vector で全演算。 +-- +-- 対応: +-- +-- - 'fitMLPRegressor': 出力 1 次元の回帰 (MSE loss) +-- - 'fitMLPClassifier': 多クラス分類 (cross-entropy + softmax 出力) +-- - 'predictMLP': forward 推論 +-- +-- 隠れ層の活性化は ReLU 既定、 出力層は task に応じて自動 (回帰=Identity、 +-- 分類=Softmax)。 +-- +-- [English]: Multi-Layer Perceptron (MLP) — a feedforward neural network. +-- +-- Trained with mini-batch SGD + a self-contained Adam implementation. +-- All operations use hmatrix Matrix\/Vector. +-- +-- Supports: +-- +-- - 'fitMLPRegressor': single-output regression (MSE loss) +-- - 'fitMLPClassifier': multiclass classification (cross-entropy + +-- softmax output) +-- - 'predictMLP': forward inference +-- +-- Hidden-layer activation defaults to ReLU; the output layer is chosen +-- automatically based on the task (regression=Identity, +-- classification=Softmax). +module Hanalyze.Model.NeuralNetwork + ( Activation (..) + , MLPConfig (..) + , defaultMLP + , Layer (..) + , MLPFit (..) + , MLPEpochEvent (..) + , fitMLPRegressor + , fitMLPRegressorWithCallback + , fitMLPRegressorPure + , fitMLPClassifier + , fitMLPClassifierWithCallback + , fitMLPClassifierPure + , predictMLP + , predictMLPClass + ) where + +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import Data.Text (Text) +import qualified Numeric.LinearAlgebra as LA +import Control.Monad (forM_) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.ST (runST) +import Data.Primitive.MutVar (newMutVar, readMutVar, writeMutVar, + modifyMutVar') +import Data.Word (Word32) +import qualified System.Random.MWC as MWC +import System.Random.MWC (initialize) +import System.Random.MWC.Distributions (standard) + +-- =========================================================================== +-- 型 +-- =========================================================================== + +data Activation = ReLU | Sigmoid | Tanh | Identity | Softmax + deriving (Show, Eq) + +data Layer = Layer + { lyrW :: !(LA.Matrix Double) -- (in × out) + , lyrB :: !(LA.Vector Double) -- (out) + , lyrAct :: !Activation + } deriving (Show) + +data MLPConfig = MLPConfig + { mlpHidden :: ![Int] + , mlpActHidden :: !Activation + , mlpLR :: !Double + , mlpEpochs :: !Int + , mlpBatch :: !Int + , mlpL2 :: !Double + , mlpStandardize :: !Bool + -- ^ [日本語]: True で X を z-score 標準化してから学習 (predict 時は同じ + -- mean/std で逆変換)。 default True。 + -- [English]: When True, z-score standardizes X before training + -- (predict inverts using the same mean\/std). Default True. + } deriving (Show) + +defaultMLP :: MLPConfig +defaultMLP = MLPConfig + { mlpHidden = [16] + , mlpActHidden = ReLU + , mlpLR = 0.01 + , mlpEpochs = 200 + , mlpBatch = 16 + , mlpL2 = 0 + , mlpStandardize = True + } + +data MLPFit = MLPFit + { mlpLayers :: ![Layer] + , mlpLossHist :: ![Double] + , mlpClasses :: ![Int] + -- ^ [日本語]: 分類器の場合の class label 順 (sorted)。 回帰時は空。 + -- [English]: Class label order (sorted), for a classifier. Empty for regression. + , mlpClassNames :: ![Text] + -- ^ [日本語]: クラス名 (df|-> が levels 注入・空=数値表示/回帰時は空)。 + -- [English]: Class names (injected as levels by df|->; empty means + -- numeric display, or empty for regression). + , mlpXMean :: !(LA.Vector Double) + -- ^ [日本語]: X 標準化に使った列平均 (標準化 off なら length 0) + -- [English]: Column means used for X standardization (length 0 if standardization is off) + , mlpXStd :: !(LA.Vector Double) + , mlpYMean :: !Double + -- ^ [日本語]: regressor の場合の y 平均 (標準化 off なら 0) + -- [English]: y mean, for a regressor (0 if standardization is off) + , mlpYStd :: !Double + } deriving (Show) + +-- =========================================================================== +-- 活性化 +-- =========================================================================== + +applyAct :: Activation -> LA.Matrix Double -> LA.Matrix Double +applyAct ReLU = LA.cmap (\v -> max 0 v) +applyAct Sigmoid = LA.cmap (\v -> 1 / (1 + exp (-v))) +applyAct Tanh = LA.cmap tanh +applyAct Identity = id +applyAct Softmax = softmaxRows + +actGrad :: Activation -> LA.Matrix Double -> LA.Matrix Double -> LA.Matrix Double +actGrad ReLU pre _ = LA.cmap (\v -> if v > 0 then 1 else 0) pre +actGrad Sigmoid _ out = out * (1 - out) +actGrad Tanh _ out = 1 - out * out +actGrad Identity _ _ = LA.fromLists [[1 :: Double]] +actGrad Softmax _ _ = LA.fromLists [[1 :: Double]] + +softmaxRows :: LA.Matrix Double -> LA.Matrix Double +softmaxRows m = LA.fromRows + [ let r = LA.flatten (m LA.? [i]) + mx = LA.maxElement r + ex = LA.cmap (\v -> exp (v - mx)) r + s = LA.sumElements ex + in LA.scale (1 / s) ex + | i <- [0 .. LA.rows m - 1] ] + +-- =========================================================================== +-- 初期化 +-- =========================================================================== + +initLayers :: PrimMonad m + => MWC.Gen (PrimState m) -> Int -> Int -> [Int] -> Activation -> Activation -> m [Layer] +initLayers gen inDim outDim hidden hidAct outAct = do + let sizes = inDim : hidden ++ [outDim] + pairs = zip sizes (tail sizes) + acts = replicate (length hidden) hidAct ++ [outAct] + mapM (\((nin, nout), act) -> do + let scale = sqrt (2 / fromIntegral nin) + ws <- mapM (\_ -> standard gen) [1 .. nin * nout] + let w = LA.scale scale + (LA.fromLists (chunksOf nout ws)) + b = LA.fromList (replicate nout 0) + pure (Layer w b act)) + (zip pairs acts) + where + chunksOf _ [] = [] + chunksOf n xs = take n xs : chunksOf n (drop n xs) + +-- =========================================================================== +-- Forward pass +-- =========================================================================== + +forward :: [Layer] -> LA.Matrix Double -> [(LA.Matrix Double, LA.Matrix Double)] +forward layers x = go x layers [] + where + go _ [] acc = reverse acc + go inp (l:ls) acc = + let pre = addBias (inp LA.<> lyrW l) (lyrB l) + out = applyAct (lyrAct l) pre + in go out ls ((pre, out) : acc) + +-- | Add bias vector (length = out) to every row of the (n × out) matrix. +addBias :: LA.Matrix Double -> LA.Vector Double -> LA.Matrix Double +addBias m b = m + LA.fromRows (replicate (LA.rows m) b) + +-- =========================================================================== +-- Backprop (回帰 MSE) +-- =========================================================================== + +-- | Backprop with MSE for regression OR cross-entropy with softmax for +-- classification. Output gradient at last layer differs by task: +-- reg: dL/dz_out = (yhat - y) / n (with Identity output) +-- class: dL/dz_out = (yhat - yOH) / n (softmax + CE simplification) +backprop + :: [Layer] + -> LA.Matrix Double -- x (n × in) + -> LA.Matrix Double -- y (n × out) target + -> Bool -- True = classification (softmax+CE) + -> Double -- L2 weight + -> [(LA.Matrix Double, LA.Vector Double)] -- gradients (dW, dB) per layer +backprop layers x y isClass l2 = + let cache = forward layers x -- list of (pre, out) per layer + n = fromIntegral (LA.rows x) :: Double + out_ = snd (last cache) + dPre_last + | isClass = LA.scale (1/n) (out_ - y) + | otherwise = LA.scale (1/n) (out_ - y) -- Identity output, same shape + -- walk backward + walk !dPre [] _ acc = acc + walk !dPre (l:ls) (c:cs) acc = + let -- input to layer l = (previous out) or x if first + inpToL = case cs of + [] -> x + (cPrev:_) -> snd cPrev + (preL, _) = c + dW = LA.tr inpToL LA.<> dPre + LA.scale l2 (lyrW l) + dB = LA.fromList [ LA.sumElements (dPre LA.¿ [j]) + | j <- [0 .. LA.cols dPre - 1] ] + -- propagate to previous layer + dOutPrev = dPre LA.<> LA.tr (lyrW l) + dPrePrev = + case ls of + [] -> dOutPrev -- unused + (lPrev:_) -> + let (prePrev, outPrev) = head cs + g = actGrad (lyrAct lPrev) prePrev outPrev + in dOutPrev * g + in walk dPrePrev ls cs ((dW, dB) : acc) + grads = walk dPre_last (reverse layers) (reverse cache) [] + in grads + +-- =========================================================================== +-- 学習ループ (Adam) +-- =========================================================================== + +-- | [日本語]: 'fitMLPRegressorWithCallback' / 'fitMLPClassifierWithCallback' +-- が発行する epoch ごとのイベント。 +-- [English]: Per-epoch event emitted by 'fitMLPRegressorWithCallback' \/ +-- 'fitMLPClassifierWithCallback'. +data MLPEpochEvent = MLPEpochEvent + { meEpoch :: !Int + -- ^ [日本語]: 0-based epoch index (0..epochs-1) [English]: 0-based epoch index (0..epochs-1) + , meTrainLoss :: !Double + -- ^ [日本語]: epoch 終端での full-batch training loss [English]: Full-batch training loss at the end of the epoch + , meValLoss :: !(Maybe Double) + -- ^ [日本語]: validation split loss。 v1 では常に 'Nothing' (= reserved for future) + -- [English]: Validation-split loss. Always 'Nothing' in v1 (reserved for future use). + , meCurrentLR :: !Double + -- ^ [日本語]: そのときの学習率 (現在は constant scheduler のみ、 将来 LR scheduler + -- 実装で意味が出る) + -- [English]: The learning rate at that point (currently only a + -- constant scheduler is implemented; this becomes meaningful once a + -- future LR scheduler is implemented). + } deriving (Show) + +trainMLP + :: PrimMonad m + => MWC.Gen (PrimState m) -> MLPConfig + -> LA.Matrix Double -> LA.Matrix Double + -> Bool -- isClass + -> (MLPEpochEvent -> m ()) -- per-epoch callback (no-op で旧挙動) + -> m ([Layer], [Double]) +trainMLP gen cfg x y isClass onEpoch = do + let inDim = LA.cols x + outDim = LA.cols y + outAct = if isClass then Softmax else Identity + layers0 <- initLayers gen inDim outDim (mlpHidden cfg) (mlpActHidden cfg) outAct + -- Adam state per layer (mW, vW, mB, vB) + let zeroLike w = LA.scale 0 w + zeroLikeV v = LA.scale 0 v + state <- mapM (\l -> do + mw <- newMutVar (zeroLike (lyrW l)) + vw <- newMutVar (zeroLike (lyrW l)) + mb <- newMutVar (zeroLikeV (lyrB l)) + vb <- newMutVar (zeroLikeV (lyrB l)) + pure (mw, vw, mb, vb)) layers0 + layersRef <- newMutVar layers0 + lossRef <- newMutVar ([] :: [Double]) + let n = LA.rows x + lr = mlpLR cfg + b1 = 0.9 + b2 = 0.999 + eps = 1e-8 + tRef <- newMutVar (0 :: Int) + forM_ [0 .. mlpEpochs cfg - 1] $ \epochIdx -> do + -- shuffle indices + idx <- fisherYates gen [0 .. n - 1] + let batches = chunksOf (mlpBatch cfg) idx + forM_ batches $ \batch -> do + let xb = x LA.? batch + yb = y LA.? batch + ls0 <- readMutVar layersRef + let grads = backprop ls0 xb yb isClass (mlpL2 cfg) + modifyMutVar' tRef (+1) + t <- readMutVar tRef + let tD = fromIntegral t :: Double + c1 = 1 - b1 ** tD + c2 = 1 - b2 ** tD + newLayers <- + mapM (\(l, (dW, dB), (mwR, vwR, mbR, vbR)) -> do + mw <- readMutVar mwR + vw <- readMutVar vwR + mb <- readMutVar mbR + vb <- readMutVar vbR + let mw' = LA.scale b1 mw + LA.scale (1 - b1) dW + vw' = LA.scale b2 vw + LA.scale (1 - b2) (dW * dW) + mb' = LA.scale b1 mb + LA.scale (1 - b1) dB + vb' = LA.scale b2 vb + LA.scale (1 - b2) (dB * dB) + mwHat = LA.scale (1 / c1) mw' + vwHat = LA.scale (1 / c2) vw' + mbHat = LA.scale (1 / c1) mb' + vbHat = LA.scale (1 / c2) vb' + wNew = lyrW l - LA.scale lr + (mwHat / LA.cmap (\v -> sqrt v + eps) vwHat) + bNew = lyrB l - LA.scale lr + (mbHat / LA.cmap (\v -> sqrt v + eps) vbHat) + writeMutVar mwR mw' + writeMutVar vwR vw' + writeMutVar mbR mb' + writeMutVar vbR vb' + pure l { lyrW = wNew, lyrB = bNew }) + (zip3 ls0 grads state) + writeMutVar layersRef newLayers + -- record epoch loss + per-epoch callback (Phase 21) + lsFinal <- readMutVar layersRef + let cache = forward lsFinal x + out_ = snd (last cache) + loss = if isClass + then crossEntropyLoss out_ y + else mseLoss out_ y + modifyMutVar' lossRef (loss :) + onEpoch MLPEpochEvent + { meEpoch = epochIdx + , meTrainLoss = loss + , meValLoss = Nothing + , meCurrentLR = lr + } + finalLayers <- readMutVar layersRef + losses <- readMutVar lossRef + pure (finalLayers, reverse losses) + +mseLoss :: LA.Matrix Double -> LA.Matrix Double -> Double +mseLoss yhat y = + let d = yhat - y + in LA.sumElements (d * d) / fromIntegral (LA.rows y * LA.cols y) + +crossEntropyLoss :: LA.Matrix Double -> LA.Matrix Double -> Double +crossEntropyLoss yhat y = + let safe = LA.cmap (\v -> log (max 1e-15 v)) yhat + in - LA.sumElements (y * safe) / fromIntegral (LA.rows y) + +-- =========================================================================== +-- 公開 API +-- =========================================================================== + +-- | [日本語]: X の列ごと平均と標準偏差 (n-1)。 +-- [English]: Per-column mean and standard deviation of X (n-1). +standardizeStats :: LA.Matrix Double -> (LA.Vector Double, LA.Vector Double) +standardizeStats x = + let n = LA.rows x + nD = fromIntegral n :: Double + mean_ = LA.fromList + [ LA.sumElements (x LA.¿ [j]) / nD | j <- [0 .. LA.cols x - 1] ] + std_ = if n < 2 + then LA.fromList (replicate (LA.cols x) 1) + else LA.fromList + [ let c = LA.flatten (x LA.¿ [j]) - LA.scalar (mean_ `LA.atIndex` j) + v = (c `LA.dot` c) / (nD - 1) + s = sqrt v + in if s > 1e-12 then s else 1 + | j <- [0 .. LA.cols x - 1] ] + in (mean_, std_) + +applyStandardize :: LA.Vector Double -> LA.Vector Double -> LA.Matrix Double + -> LA.Matrix Double +applyStandardize mean_ std_ x = + let n = LA.rows x + mRow = LA.fromRows (replicate n mean_) + sRow = LA.fromRows (replicate n std_) + in (x - mRow) / sRow + +fitMLPRegressor + :: MLPConfig -> LA.Matrix Double -> LA.Vector Double + -> MWC.GenIO -> IO MLPFit +fitMLPRegressor cfg x y gen = + fitMLPRegressorWithCallback cfg x y gen (\_ -> pure ()) + +-- | [日本語]: epoch 終端ごとに 'MLPEpochEvent' を渡す callback 付き +-- regressor 学習。 既存 'fitMLPRegressor' は no-op callback で本関数を呼ぶ +-- 薄い wrapper として保持される。 +-- [English]: Regressor training with a callback that is passed an +-- 'MLPEpochEvent' at the end of every epoch. The existing +-- 'fitMLPRegressor' is kept as a thin wrapper that calls this function +-- with a no-op callback. +fitMLPRegressorWithCallback + :: PrimMonad m + => MLPConfig -> LA.Matrix Double -> LA.Vector Double + -> MWC.Gen (PrimState m) + -> (MLPEpochEvent -> m ()) + -> m MLPFit +fitMLPRegressorWithCallback cfg x y gen onEpoch = do + let (xMean, xStd) = if mlpStandardize cfg + then standardizeStats x + else (LA.fromList [], LA.fromList []) + xUse = if mlpStandardize cfg then applyStandardize xMean xStd x else x + yMat = LA.asColumn y + (layers, losses) <- trainMLP gen cfg xUse yMat False onEpoch + pure MLPFit + { mlpLayers = layers + , mlpLossHist = losses + , mlpClasses = [] + , mlpClassNames = [] + , mlpXMean = xMean + , mlpXStd = xStd + , mlpYMean = 0 + , mlpYStd = 1 + } + +fitMLPClassifier + :: MLPConfig -> LA.Matrix Double -> VU.Vector Int + -> MWC.GenIO -> IO MLPFit +fitMLPClassifier cfg x y gen = + fitMLPClassifierWithCallback cfg x y gen (\_ -> pure ()) + +-- | [日本語]: 'fitMLPRegressorWithCallback' の classifier 版。 +-- [English]: The classifier counterpart of 'fitMLPRegressorWithCallback'. +fitMLPClassifierWithCallback + :: PrimMonad m + => MLPConfig -> LA.Matrix Double -> VU.Vector Int + -> MWC.Gen (PrimState m) + -> (MLPEpochEvent -> m ()) + -> m MLPFit +fitMLPClassifierWithCallback cfg x y gen onEpoch = do + let classes = uniqueSort (VU.toList y) + k = length classes + n = VU.length y + classIdx c = case lookup c (zip classes [0 ..]) of + Just i -> i + Nothing -> 0 + yOH = LA.fromLists + [ [ if j == classIdx (y VU.! i) then 1 else 0 + | j <- [0 .. k - 1] ] + | i <- [0 .. n - 1] ] + (xMean, xStd) = if mlpStandardize cfg + then standardizeStats x + else (LA.fromList [], LA.fromList []) + xUse = if mlpStandardize cfg then applyStandardize xMean xStd x else x + (layers, losses) <- trainMLP gen cfg xUse yOH True onEpoch + pure MLPFit + { mlpLayers = layers + , mlpLossHist = losses + , mlpClasses = classes + , mlpClassNames = [] + , mlpXMean = xMean + , mlpXStd = xStd + , mlpYMean = 0 + , mlpYStd = 1 + } + +-- | [日本語]: 'fitMLPRegressor' の純粋版。 Word32 seed から @runST@ + MWC で重み初期化・ +-- shuffle を決定的に閉じる (@fitRFVPure@/@nutsPure@ と同方針・同 seed → ビット同一)。 +-- IO 版は進捗 callback 用に残る。 +-- [English]: A pure version of 'fitMLPRegressor'. Closes weight +-- initialization and shuffling over @runST@ + MWC from a Word32 seed, +-- deterministically (same policy as @fitRFVPure@\/@nutsPure@: same seed +-- → bit-identical). The IO version remains for progress callbacks. +fitMLPRegressorPure :: MLPConfig -> LA.Matrix Double -> LA.Vector Double -> Word32 -> MLPFit +fitMLPRegressorPure cfg x y seed = + runST (initialize (V.singleton seed) + >>= \gen -> fitMLPRegressorWithCallback cfg x y gen (\_ -> pure ())) + +-- | [日本語]: 'fitMLPClassifier' の純粋版。 seed から @runST@ で決定的に学習。 +-- [English]: A pure version of 'fitMLPClassifier'. Trains +-- deterministically via @runST@ from a seed. +fitMLPClassifierPure :: MLPConfig -> LA.Matrix Double -> VU.Vector Int -> Word32 -> MLPFit +fitMLPClassifierPure cfg x y seed = + runST (initialize (V.singleton seed) + >>= \gen -> fitMLPClassifierWithCallback cfg x y gen (\_ -> pure ())) + +predictMLP :: MLPFit -> LA.Matrix Double -> LA.Matrix Double +predictMLP fit xNew = + let xUse = if LA.size (mlpXMean fit) > 0 + then applyStandardize (mlpXMean fit) (mlpXStd fit) xNew + else xNew + cache = forward (mlpLayers fit) xUse + raw = snd (last cache) + -- regressor の場合、 y も標準化して学習しているので戻す + in if null (mlpClasses fit) && mlpYStd fit /= 1 + then LA.cmap (\v -> v * mlpYStd fit + mlpYMean fit) raw + else raw + +predictMLPClass :: MLPFit -> LA.Matrix Double -> V.Vector Int +predictMLPClass fit xNew = + let probs = predictMLP fit xNew + classes = mlpClasses fit + in V.generate (LA.rows probs) $ \i -> + let row = LA.toList (LA.flatten (probs LA.? [i])) + (best, _) = foldr1 (\(j, p) (jb, pb) -> + if p > pb then (j, p) else (jb, pb)) + (zip [0 ..] row) + in classes !! best + +-- =========================================================================== +-- helpers +-- =========================================================================== + +uniqueSort :: Ord a => [a] -> [a] +uniqueSort = uniqAdj . sortL + where + sortL xs = foldr insertSorted [] xs + insertSorted x [] = [x] + insertSorted x ys@(y:rest) + | x < y = x : ys + | x == y = ys + | otherwise = y : insertSorted x rest + uniqAdj [] = [] + uniqAdj [a] = [a] + uniqAdj (a:b:rest) + | a == b = uniqAdj (b : rest) + | otherwise = a : uniqAdj (b : rest) + +chunksOf :: Int -> [a] -> [[a]] +chunksOf _ [] = [] +chunksOf n xs = take n xs : chunksOf n (drop n xs) + +fisherYates :: PrimMonad m => MWC.Gen (PrimState m) -> [a] -> m [a] +fisherYates gen xs = + let v0 = V.fromList xs + in go v0 (V.length v0 - 1) + where + go v 0 = pure (V.toList v) + go v i = do + j <- MWC.uniformR (0, i) gen + let vi = v V.! i + vj = v V.! j + v' = v V.// [(i, vj), (j, vi)] + go v' (i - 1) diff --git a/src/Hanalyze/Model/PCA.hs b/src/Hanalyze/Model/PCA.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/PCA.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.PCA +-- Description : Principal Component Analysis (PCA) and related dimensionality reduction +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Principal Component Analysis (PCA) and related dimensionality +-- reduction. +-- +-- @ +-- import Hanalyze.Model.PCA +-- +-- let pcaRes = pca True x -- center + scale +-- loadings = pcaComponents pcaRes +-- scores = pcaTransform pcaRes x -- project x onto components +-- @ +-- +-- * 'pca' fits PCA to a centred (and optionally scaled) feature matrix. +-- * 'pcaTransform' projects new data onto the learned components. +-- * 'pcaInverse' reconstructs from scores back to feature space. +-- * @screePlot@ / @biplot@ integration via @Viz@ (separate module). +module Hanalyze.Model.PCA + ( -- * PCA + PCAResult (..) + , PCAStandardize (..) + , pca + , pcaTransform + , pcaInverse + , pcaCumExplained + -- * Helpers + , standardizeFeatures + ) where + +import qualified Numeric.LinearAlgebra as LA + +-- | Standardisation mode for input features before SVD. +data PCAStandardize + = NoStandardize + -- ^ Do not center or scale (only useful when columns already have + -- zero mean and comparable units). + | Center + -- ^ Subtract column means (default behaviour for PCA). + | CenterScale + -- ^ Subtract means and divide by sample standard deviations + -- (= standardised PCA, AKA correlation-matrix PCA). + deriving (Show, Eq) + +-- | Result of fitting PCA. All matrices share the same number of +-- components @k@; if the user passed @k = Nothing@ then +-- @k = min(n, p)@. +data PCAResult = PCAResult + { pcaMean :: !(LA.Vector Double) + -- ^ Per-column mean of the training data (length @p@). + , pcaScale :: !(LA.Vector Double) + -- ^ Per-column standard deviation (length @p@). All ones when + -- 'pcaStandardize' is 'NoStandardize' / 'Center'. + , pcaStandardize :: !PCAStandardize + , pcaComponents :: !(LA.Matrix Double) + -- ^ Principal axes (@loadings@), shape @k × p@. Rows are unit + -- vectors; PC@i@ corresponds to row @i@. + , pcaSingularValues :: !(LA.Vector Double) + -- ^ Singular values @σ_i@, length @k@. Sorted descending. + , pcaExplainedVar :: !(LA.Vector Double) + -- ^ Variance of each component (= σ_i² / (n − 1)). Length @k@. + , pcaExplainedRatio :: !(LA.Vector Double) + -- ^ Fraction of total variance explained by each component, length + -- @k@. Sums to ≤ 1; equals 1 when k = rank(X). + , pcaNSamples :: !Int + , pcaNFeatures :: !Int + } deriving (Show) + +-- | Center (and optionally scale) a feature matrix. Returns the +-- transformed matrix along with the column means and per-column +-- standard deviations. +standardizeFeatures + :: PCAStandardize + -> LA.Matrix Double -- ^ X (n × p) + -> (LA.Matrix Double, LA.Vector Double, LA.Vector Double) + -- ^ (Z, μ, σ). +standardizeFeatures std x = + let n = LA.rows x + p = LA.cols x + ones = LA.konst 1 n :: LA.Vector Double + mu = LA.scale (1 / fromIntegral n) (ones LA.<# x) + xC = x - LA.fromRows (replicate n mu) + in case std of + NoStandardize -> + (x, LA.konst 0 p, LA.konst 1 p) + Center -> + (xC, mu, LA.konst 1 p) + CenterScale -> + let sd2 = LA.scale (1 / fromIntegral (n - 1)) + (LA.konst 1 n LA.<# (xC * xC)) + sd = LA.cmap (\v -> if v < 1e-12 then 1 else sqrt v) sd2 + z = xC LA.<> LA.diag (LA.cmap (1 /) sd) + in (z, mu, sd) + +-- | Fit PCA on a feature matrix. +-- +-- Internally uses thin SVD on the (centred / scaled) matrix so the +-- cost is @O(min(n²p, np²))@. The first @k@ rows of @Vᵀ@ are the +-- principal axes; the singular values @σ@ give component magnitudes. +pca + :: PCAStandardize + -> Maybe Int -- ^ k (number of components to keep). Nothing = all. + -> LA.Matrix Double -- ^ X (n × p) + -> PCAResult +pca std mK x = + let (z, mu, sd) = standardizeFeatures std x + n = LA.rows z + p = LA.cols z + -- Thin SVD: z = U S Vᵀ, where U is n×r, S is r-vector, V is p×r. + (u, s, vT) = LA.thinSVD z + _ = u + kMax = min (LA.rows z) (LA.cols z) + k = min kMax (maybe kMax id mK) + -- Keep first k components. + sK = LA.subVector 0 k s + -- 'thinSVD' returns Vᵀ as p × min(n,p); we want first k rows of + -- Vᵀ (= first k columns of V transposed). + vTk = vT LA.?? (LA.All, LA.Take k) + components = LA.tr vTk -- k × p + -- Variance per component = σ² / (n − 1). + varK = LA.cmap (\sv -> sv * sv / fromIntegral (max 1 (n - 1))) sK + totalVar = LA.sumElements + (LA.cmap (\sv -> sv * sv / fromIntegral (max 1 (n - 1))) s) + ratio = if totalVar > 0 + then LA.scale (1 / totalVar) varK + else LA.konst 0 k + in PCAResult + { pcaMean = mu + , pcaScale = sd + , pcaStandardize = std + , pcaComponents = components + , pcaSingularValues = sK + , pcaExplainedVar = varK + , pcaExplainedRatio = ratio + , pcaNSamples = n + , pcaNFeatures = p + } + +-- | Project new data onto the learned principal components. +-- Returns scores of shape @m × k@ where @m@ is the number of new +-- samples. +pcaTransform :: PCAResult -> LA.Matrix Double -> LA.Matrix Double +pcaTransform r x = + let m = LA.rows x + mu = pcaMean r + sd = pcaScale r + xC = x - LA.fromRows (replicate m mu) + z = case pcaStandardize r of + NoStandardize -> x + Center -> xC + CenterScale -> xC LA.<> LA.diag (LA.cmap (1 /) sd) + in z LA.<> LA.tr (pcaComponents r) -- m × k + +-- | Reconstruct from scores back to feature space (approximation when +-- not all components are kept). Inverse of 'pcaTransform' modulo +-- truncation error. +pcaInverse :: PCAResult -> LA.Matrix Double -> LA.Matrix Double +pcaInverse r scores = + let m = LA.rows scores + mu = pcaMean r + sd = pcaScale r + zRecon = scores LA.<> pcaComponents r -- m × p + xRecon = case pcaStandardize r of + NoStandardize -> zRecon + Center -> zRecon + LA.fromRows (replicate m mu) + CenterScale -> + let unscaled = zRecon LA.<> LA.diag sd + in unscaled + LA.fromRows (replicate m mu) + in xRecon + +-- | Cumulative explained variance ratio (length k). +pcaCumExplained :: PCAResult -> LA.Vector Double +pcaCumExplained r = + let ratio = LA.toList (pcaExplainedRatio r) + cum = scanl1 (+) ratio + in LA.fromList cum diff --git a/src/Hanalyze/Model/PLS.hs b/src/Hanalyze/Model/PLS.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/PLS.hs @@ -0,0 +1,440 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.PLS +-- Description : PLS (Partial Least Squares) — 応答 Y との共分散を最大化する低ランク回帰 (NIPALS) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Partial Least Squares (PLS) — chemometrics 標準の応答連動低ランク回帰。 +-- +-- PCA (`Hanalyze.Model.PCA`) は応答無視の分散最大化、 PLS は +-- __応答 Y と X の共分散を最大化する__低ランク射影。 多変量分光分析 / 材料設計の +-- 予測 + 変数選択を 1 モデルで実現する。 +-- +-- アルゴリズム: +-- +-- - 'NIPALS' (default): 反復的 power iteration、 sklearn @PLSRegression@ と +-- 数値一致しやすい +-- - 'SIMPLS' (追加予定): de Jong 1993、 SVD ベース、 multi-Y で +-- 直接的 +-- +-- 内部実装は hmatrix Matrix / Vector 演算で完結 (list 化しない)。 +-- +-- [English]: Partial Least Squares (PLS) — the chemometrics-standard +-- response-linked low-rank regression. +-- +-- Whereas PCA (`Hanalyze.Model.PCA`) is response-agnostic variance +-- maximization, PLS is a low-rank projection that +-- __maximizes the covariance between the response Y and X__. It delivers +-- prediction + variable selection for multivariate spectroscopy \/ +-- materials design in a single model. +-- +-- Algorithms: +-- +-- - 'NIPALS' (default): iterative power iteration, which tends to match +-- sklearn's @PLSRegression@ numerically. +-- - 'SIMPLS' (planned addition): de Jong 1993, SVD-based, direct for +-- multi-Y. +-- +-- The internal implementation is self-contained in hmatrix +-- Matrix \/ Vector operations (never converts to lists). +module Hanalyze.Model.PLS + ( -- * Config + PLSAlgorithm (..) + , PLSConfig (..) + , defaultPLS + -- * Fit / predict + , PLSFit (..) + , fitPLS + , fitPLS1 + , predictPLS + , predictPLS1 + -- * CV による component 数選択 + , PLSLambdaSelection (..) + , selectPLSComponentsCV + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified System.Random.MWC as MWC +import Data.List (sortBy) +import Data.Ord (comparing) +import Data.Text (Text) +import qualified Data.Text as T + +import qualified Hanalyze.Stat.CV as HCV + +-- =========================================================================== +-- Config +-- =========================================================================== + +data PLSAlgorithm + = NIPALS -- ^ [日本語]: 反復的 power iteration (default)。 [English]: Iterative power iteration (default). + | SIMPLS -- ^ [日本語]: de Jong 1993 (追加予定)。 [English]: de Jong 1993 (a planned addition). + deriving (Show, Eq) + +data PLSConfig = PLSConfig + { plsN_Components :: !Int + , plsAlgorithm :: !PLSAlgorithm + , plsScale :: !Bool -- ^ [日本語]: True で X, Y を column-wise に標準化。 [English]: When True, standardizes X and Y column-wise. + , plsTol :: !Double -- ^ [日本語]: NIPALS 収束許容誤差。 [English]: The NIPALS convergence tolerance. + , plsMaxIter :: !Int -- ^ [日本語]: NIPALS 最大反復。 [English]: The NIPALS maximum iteration count. + } deriving (Show) + +defaultPLS :: PLSConfig +defaultPLS = PLSConfig + { plsN_Components = 2 + , plsAlgorithm = NIPALS + , plsScale = True + , plsTol = 1e-8 + , plsMaxIter = 500 + } + +-- =========================================================================== +-- 結果型 +-- =========================================================================== + +data PLSFit = PLSFit + { plsScoresT :: !(LA.Matrix Double) -- ^ [日本語]: T (n × K) X scores。 [English]: T (n × K), the X scores. + , plsLoadingsP :: !(LA.Matrix Double) -- ^ [日本語]: P (p × K) X loadings。 [English]: P (p × K), the X loadings. + , plsLoadingsQ :: !(LA.Matrix Double) -- ^ [日本語]: Q (q × K) Y loadings。 [English]: Q (q × K), the Y loadings. + , plsWeightsW :: !(LA.Matrix Double) -- ^ [日本語]: W (p × K) X weights。 [English]: W (p × K), the X weights. + , plsCoef :: !(LA.Matrix Double) + -- ^ [日本語]: β (p × q) 回帰係数 (元スケール)。 @Ŷ = (X - X̄) · β + Ȳ@。 + -- [English]: β (p × q), the regression coefficients (original scale). + -- @Ŷ = (X - X̄) · β + Ȳ@. + , plsXMean :: !(LA.Vector Double) -- ^ [日本語]: X 列平均。 [English]: The X column means. + , plsXStd :: !(LA.Vector Double) -- ^ [日本語]: X 列標準偏差 (plsScale=True なら、 そうでなければ 1)。 [English]: The X column standard deviations (when plsScale=True; otherwise 1). + , plsYMean :: !(LA.Vector Double) -- ^ [日本語]: Y 列平均。 [English]: The Y column means. + , plsYStd :: !(LA.Vector Double) -- ^ [日本語]: Y 列標準偏差 (plsScale=True なら、 そうでなければ 1)。 [English]: The Y column standard deviations (when plsScale=True; otherwise 1). + , plsR2X :: !(LA.Vector Double) -- ^ [日本語]: 各 component の X 説明分散率。 [English]: The fraction of X variance explained by each component. + , plsR2Y :: !(LA.Vector Double) -- ^ [日本語]: 各 component の Y 説明分散率。 [English]: The fraction of Y variance explained by each component. + , plsVIP :: !(LA.Vector Double) -- ^ [日本語]: 変数重要度 (Variable Importance in Projection)。 [English]: Variable importance (Variable Importance in Projection). + , plsConfig :: !PLSConfig + } deriving (Show) + +-- =========================================================================== +-- 公開関数 +-- =========================================================================== + +-- | [日本語]: PLS fit (multi-output Y、 q ≥ 1)。 +-- [English]: PLS fit (multi-output Y, q ≥ 1). +fitPLS :: PLSConfig + -> LA.Matrix Double -- ^ [日本語]: X (n × p)。 [English]: X (n × p). + -> LA.Matrix Double -- ^ [日本語]: Y (n × q)。 [English]: Y (n × q). + -> Either Text PLSFit +fitPLS cfg x y + | LA.rows x /= LA.rows y = + Left "fitPLS: X and Y must have the same number of rows" + | LA.rows x < 2 = + Left "fitPLS: need at least 2 observations" + | plsN_Components cfg < 1 = + Left "fitPLS: n_components must be ≥ 1" + | plsN_Components cfg > min (LA.rows x - 1) (LA.cols x) = + Left (T.pack ("fitPLS: n_components (" <> show (plsN_Components cfg) <> + ") exceeds min(n-1, p)")) + | otherwise = + case plsAlgorithm cfg of + NIPALS -> Right (nipalsFit cfg x y) + SIMPLS -> Left "fitPLS: SIMPLS not yet implemented (Phase 9.5)" + +-- | [日本語]: 単出力 Y ショートカット (q = 1)。 +-- [English]: A single-output Y shortcut (q = 1). +fitPLS1 :: PLSConfig -> LA.Matrix Double -> LA.Vector Double -> Either Text PLSFit +fitPLS1 cfg x y = fitPLS cfg x (LA.asColumn y) + +-- | [日本語]: 予測 (multi-output)。 `plsCoef` は元スケールの回帰係数なので、 +-- X を中央化するだけで予測可能 (= scaling は不要、 coef が吸収済)。 +-- [English]: Predicts (multi-output). Since `plsCoef` is the regression +-- coefficient on the original scale, prediction only requires +-- centering X (no scaling needed — it is already absorbed into coef). +predictPLS :: PLSFit -> LA.Matrix Double -> LA.Matrix Double +predictPLS fit xNew = + let nRow = LA.rows xNew + xCentered = xNew - LA.fromRows (replicate nRow (plsXMean fit)) + yCentered = xCentered LA.<> plsCoef fit + in yCentered + LA.fromRows (replicate nRow (plsYMean fit)) + +predictPLS1 :: PLSFit -> LA.Matrix Double -> LA.Vector Double +predictPLS1 fit xNew = LA.flatten (predictPLS fit xNew) + +-- =========================================================================== +-- NIPALS 実装 +-- =========================================================================== + +-- | [日本語]: NIPALS 内部実装。 中央化 + (option で) 標準化 → component loop → 後処理。 +-- [English]: The internal NIPALS implementation: centering + (optionally) +-- standardization → the component loop → post-processing. +nipalsFit :: PLSConfig -> LA.Matrix Double -> LA.Matrix Double -> PLSFit +nipalsFit cfg xRaw yRaw = + let !n = LA.rows xRaw + !p = LA.cols xRaw + !q = LA.cols yRaw + k = plsN_Components cfg + + -- 列平均 + xMean = LA.scale (1 / fromIntegral n) (LA.fromList + [ LA.sumElements (xRaw LA.¿ [j]) | j <- [0 .. p - 1] ]) + yMean = LA.scale (1 / fromIntegral n) (LA.fromList + [ LA.sumElements (yRaw LA.¿ [j]) | j <- [0 .. q - 1] ]) + + xCentered = xRaw - LA.fromRows (replicate n xMean) + yCentered = yRaw - LA.fromRows (replicate n yMean) + + -- 列標準偏差 (n-1 分母、 plsScale=False なら 1 ベクトル) + -- Bug fix (Phase 17.1): 旧実装 LA.sumElements (c LA.<> LA.tr c) は + -- n×n 行列 c_i c_j を生成 → sumElements で (Σ c)² になっていた。 + -- 正しくは Σ c_i² = c `LA.dot` c。 + colSD m mean_ + | LA.rows m < 2 = LA.fromList (replicate (LA.cols m) 1) + | otherwise = + let nm = fromIntegral (LA.rows m - 1) :: Double + centered = m - LA.fromRows (replicate (LA.rows m) mean_) + sqSum = LA.fromList + [ let c = LA.flatten (centered LA.¿ [j]) + in c `LA.dot` c + | j <- [0 .. LA.cols m - 1] ] + in LA.cmap (\v -> let s = sqrt (v / nm) in if s > 1e-12 then s else 1) sqSum + + xStd = if plsScale cfg then colSD xRaw xMean else LA.fromList (replicate p 1) + yStd = if plsScale cfg then colSD yRaw yMean else LA.fromList (replicate q 1) + + xScaled = if plsScale cfg + then xCentered / LA.fromRows (replicate n xStd) + else xCentered + yScaled = if plsScale cfg + then yCentered / LA.fromRows (replicate n yStd) + else yCentered + + -- component loop: 各 component で deflate しながら w, t, p, q を取り出す + (wMat, tMat, pMat, qMat) = nipalsLoop cfg k xScaled yScaled + + -- 回帰係数 β = W (Pᵀ W)⁻¹ Qᵀ (centered/scaled 空間) + ptw = LA.tr pMat LA.<> wMat -- K × K + ptwInv = case LA.linearSolve ptw (LA.ident k) of + Just inv -> inv + Nothing -> LA.scale 0 (LA.ident k) -- singular なら 0 + betaScaled = wMat LA.<> ptwInv LA.<> LA.tr qMat -- p × q + + -- R²X, R²Y を component 別に計算 + ssTotalX = LA.sumElements (xScaled * xScaled) + ssTotalY = LA.sumElements (yScaled * yScaled) + r2X = LA.fromList + [ let tk = tMat LA.¿ [j] + pk = pMat LA.¿ [j] + recon = tk LA.<> LA.tr pk + ss = LA.sumElements (recon * recon) + in if ssTotalX > 0 then ss / ssTotalX else 0 + | j <- [0 .. k - 1] ] + r2Y = LA.fromList + [ let tk = tMat LA.¿ [j] + qk = qMat LA.¿ [j] + recon = tk LA.<> LA.tr qk + ss = LA.sumElements (recon * recon) + in if ssTotalY > 0 then ss / ssTotalY else 0 + | j <- [0 .. k - 1] ] + + -- VIP: VIP_j = sqrt( p · Σ_k (W²_jk · SS_Y_k) / Σ_k SS_Y_k ) + ssYPerComp = LA.fromList + [ let tk = tMat LA.¿ [j] + qk = qMat LA.¿ [j] + recon = tk LA.<> LA.tr qk + in LA.sumElements (recon * recon) + | j <- [0 .. k - 1] ] + ssYTotal = LA.sumElements ssYPerComp + vip = if ssYTotal > 0 + then LA.fromList + [ let wj = LA.flatten (LA.tr wMat LA.¿ [j]) -- length K + contribs = (wj * wj) * ssYPerComp + total = LA.sumElements contribs + in sqrt (fromIntegral p * total / ssYTotal) + | j <- [0 .. p - 1] ] + else LA.fromList (replicate p 0) + + -- 元スケールの coef + coefOrig = + if plsScale cfg + then let xStdInv = LA.cmap (1 /) xStd + yStdDiag = LA.diag yStd + xStdDiagInv = LA.diag xStdInv + in xStdDiagInv LA.<> betaScaled LA.<> yStdDiag + else betaScaled + + in PLSFit + { plsScoresT = tMat + , plsLoadingsP = pMat + , plsLoadingsQ = qMat + , plsWeightsW = wMat + , plsCoef = coefOrig + , plsXMean = xMean + , plsXStd = xStd + , plsYMean = yMean + , plsYStd = yStd + , plsR2X = r2X + , plsR2Y = r2Y + , plsVIP = vip + , plsConfig = cfg + } + +-- | [日本語]: NIPALS 反復ループ: scaled X, Y から K components を抽出。 +-- [English]: The NIPALS iteration loop: extracts K components from +-- scaled X, Y. +nipalsLoop + :: PLSConfig + -> Int -- K + -> LA.Matrix Double -- X_scaled (n × p) + -> LA.Matrix Double -- Y_scaled (n × q) + -> ( LA.Matrix Double -- W (p × K) + , LA.Matrix Double -- T (n × K) + , LA.Matrix Double -- P (p × K) + , LA.Matrix Double -- Q (q × K) + ) +nipalsLoop cfg k x0 y0 = go 0 x0 y0 [] [] [] [] + where + go !i !x !y wAcc tAcc pAcc qAcc + | i >= k = + ( LA.fromColumns (reverse wAcc) + , LA.fromColumns (reverse tAcc) + , LA.fromColumns (reverse pAcc) + , LA.fromColumns (reverse qAcc) + ) + | otherwise = + let (w, t, ploading, qloading) = nipalsOneComponent cfg x y + -- Deflate: E = E - t pᵀ, F = F - t qᵀ + x' = x - LA.asColumn t LA.<> LA.asRow ploading + y' = y - LA.asColumn t LA.<> LA.asRow qloading + in go (i + 1) x' y' (w : wAcc) (t : tAcc) (ploading : pAcc) (qloading : qAcc) + +-- | [日本語]: NIPALS の 1 component 抽出。 power iteration で w, t, p, q を得る。 +-- [English]: Extracts a single NIPALS component. Obtains w, t, p, q via +-- power iteration. +nipalsOneComponent + :: PLSConfig + -> LA.Matrix Double + -> LA.Matrix Double + -> ( LA.Vector Double -- w (p) + , LA.Vector Double -- t (n) + , LA.Vector Double -- p loading (p) + , LA.Vector Double -- q loading (q) + ) +nipalsOneComponent cfg x y = + let -- 初期 u: Y の最初の列 + u0 = LA.flatten (y LA.¿ [0]) + (uFinal, _iter) = iterate' cfg x y u0 0 + -- 最終 w 計算 (deflate 前の x, y で) + xtu = LA.tr x LA.#> uFinal + normXtu = sqrt (LA.sumElements (xtu * xtu)) + w = if normXtu > 1e-12 then LA.scale (1 / normXtu) xtu + else xtu + t = x LA.#> w + tt = LA.sumElements (t * t) + qy = if tt > 1e-12 then LA.scale (1 / tt) (LA.tr y LA.#> t) + else LA.tr y LA.#> t + pload = if tt > 1e-12 then LA.scale (1 / tt) (LA.tr x LA.#> t) + else LA.tr x LA.#> t + in (w, t, pload, qy) + +-- | [日本語]: NIPALS の収束反復。 u を更新し続け、 |u_new - u| < tol で終了。 +-- [English]: The NIPALS convergence iteration. Keeps updating u, and +-- terminates when |u_new - u| < tol. +iterate' + :: PLSConfig + -> LA.Matrix Double + -> LA.Matrix Double + -> LA.Vector Double -- u + -> Int -- iter count + -> (LA.Vector Double, Int) +iterate' cfg x y u !i + | i >= plsMaxIter cfg = (u, i) + | otherwise = + let xtu = LA.tr x LA.#> u + normXtu = sqrt (LA.sumElements (xtu * xtu)) + w = if normXtu > 1e-12 then LA.scale (1 / normXtu) xtu else xtu + t = x LA.#> w + tt = LA.sumElements (t * t) + ytt = LA.tr y LA.#> t + q = if tt > 1e-12 then LA.scale (1 / tt) ytt else ytt + fq = y LA.#> q + normFq = sqrt (LA.sumElements (fq * fq)) + uNew = if normFq > 1e-12 then LA.scale (1 / normFq) fq else fq + diff = uNew - u + err = sqrt (LA.sumElements (diff * diff)) + in if err < plsTol cfg + then (uNew, i + 1) + else iterate' cfg x y uNew (i + 1) + +-- =========================================================================== +-- CV による component 数選択 +-- =========================================================================== + +data PLSLambdaSelection = PLSLambdaSelection + { plsBestK :: !Int + , plsCVMSEs :: ![Double] + , plsCVSDs :: ![Double] + , plsOneSeK :: !Int + } deriving (Show) + +-- | [日本語]: k-fold CV で component 数を 1..maxK の中から選ぶ。 +-- [English]: Selects the number of components from 1..maxK via k-fold CV. +selectPLSComponentsCV + :: Int -- ^ [日本語]: k-fold の k。 [English]: The k in k-fold. + -> Int -- ^ [日本語]: maxK (component 数上限)。 [English]: maxK (the upper bound on the number of components). + -> LA.Matrix Double -- ^ [日本語]: X。 [English]: X. + -> LA.Matrix Double -- ^ [日本語]: Y。 [English]: Y. + -> MWC.GenIO + -> IO PLSLambdaSelection +selectPLSComponentsCV kFold maxK xMat yMat gen = do + let n = LA.rows xMat + folds <- HCV.kFold kFold n gen + let perK kk = + let cfg = defaultPLS { plsN_Components = kk } + scores = + [ mseForFold cfg xMat yMat trainIdx testIdx + | (trainIdx, testIdx) <- folds, not (null testIdx) + ] + !nFolds = fromIntegral (length scores) :: Double + meanMSE = sum scores / nFolds + varN = sum [(s - meanMSE) ** 2 | s <- scores] / max 1 (nFolds - 1) + !se = sqrt (varN / nFolds) + in (meanMSE, se) + ks = [1 .. maxK] + stats = map perK ks + mses = map fst stats + ses = map snd stats + indexedMSEs = zip3 ks mses ses + sortedAsc = sortBy (comparing (\(_, m, _) -> m)) indexedMSEs + (bestK_, bestMSE, bestSE) = + case sortedAsc of + (h:_) -> h + [] -> (1, 0, 0) + threshold = bestMSE + bestSE + -- 1-SE rule: 最も sparse な K (= 最小 K) で best MSE + 1·SE 以内 + oneSe = case [k | (k, m, _) <- indexedMSEs, m <= threshold] of + [] -> bestK_ + xs -> minimum xs + pure PLSLambdaSelection + { plsBestK = bestK_ + , plsCVMSEs = mses + , plsCVSDs = ses + , plsOneSeK = oneSe + } + +mseForFold + :: PLSConfig + -> LA.Matrix Double + -> LA.Matrix Double + -> [Int] + -> [Int] + -> Double +mseForFold cfg xMat yMat trainIdx testIdx = + let xTr = xMat LA.? trainIdx + yTr = yMat LA.? trainIdx + xTe = xMat LA.? testIdx + yTe = yMat LA.? testIdx + in case fitPLS cfg xTr yTr of + Left _ -> 1/0 + Right fit -> + let yHat = predictPLS fit xTe + resid = yTe - yHat + nTe = fromIntegral (length testIdx) :: Double + in LA.sumElements (resid * resid) / nTe diff --git a/src/Hanalyze/Model/PartialDependence.hs b/src/Hanalyze/Model/PartialDependence.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/PartialDependence.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.PartialDependence +-- Description : 任意モデル対応の Partial Dependence / ICE 純粋計算エンジン (model 非依存・非ゲート層) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 部分従属 (Partial Dependence) / ICE の純粋計算エンジン — 任意モデル対応。 +-- +-- R @pdp::partial@ / sklearn @sklearn.inspection.partial_dependence@ 相当。 学習済モデルの +-- predict を「注目特徴を grid で振り、 他の特徴は訓練データの観測分布のまま」評価し、 全観測 +-- 行で平均したものが PDP、 行ごとの曲線が ICE (individual conditional expectation)。 +-- +-- model 非依存 (predict 閉包のみを受ける) ゆえ __非ゲート層__ に置き、 図化は +-- 別パッケージ @hanalyze-plot@ の 'Hanalyze.Plot.ML' +-- (@cabal build --project-file=cabal.project.plot@ で build) が担う。 +-- +-- @ +-- import Hanalyze.Model.PartialDependence +-- +-- -- 任意モデルの predict 閉包を渡す (R pdp の pred.fun 流)。 +-- let r = partialDependence trainX (\\m -> map (predictRF rf) (LA.toLists m)) 0 40 +-- in (pdpGrid r, pdpMean r) -- 特徴 0 の PDP 曲線 +-- @ +-- +-- [English]: A pure computation engine for Partial Dependence / ICE — +-- supports arbitrary models. +-- +-- Equivalent to R's @pdp::partial@ \/ sklearn's +-- @sklearn.inspection.partial_dependence@. Evaluates a fitted model's +-- predict by "sweeping the feature of interest over a grid while +-- keeping the other features at their observed distribution in the +-- training data"; the average over all observation rows is the PDP, +-- and the per-row curves are the ICE (individual conditional +-- expectation). +-- +-- Since it is model-independent (it only takes a predict closure), it +-- lives in the __non-gated layer__; visualization is handled by +-- 'Hanalyze.Plot.ML' in the separate @hanalyze-plot@ +-- package (built via @cabal build --project-file=cabal.project.plot@). +-- +-- @ +-- import Hanalyze.Model.PartialDependence +-- +-- -- Pass an arbitrary model's predict closure (in the style of R +-- -- pdp's pred.fun). +-- let r = partialDependence trainX (\\m -> map (predictRF rf) (LA.toLists m)) 0 40 +-- in (pdpGrid r, pdpMean r) -- The PDP curve for feature 0 +-- @ +module Hanalyze.Model.PartialDependence + ( -- * 結果型 + PDPResult (..) + -- * 計算 + , partialDependence + , partialDependenceGrid + -- * 変換 + , centerICE + ) where + +import qualified Numeric.LinearAlgebra as LA +import Data.List (transpose) + +-- =========================================================================== +-- 結果型 +-- =========================================================================== + +-- | [日本語]: 部分従属の計算結果。 grid・PDP 平均曲線・ICE 個体曲線群をまとめて返す。 +-- [English]: The result of a partial-dependence computation. Returns +-- the grid, the PDP mean curve, and the group of ICE individual +-- curves together. +data PDPResult = PDPResult + { pdpGrid :: ![Double] -- ^ [日本語]: 注目特徴の grid 値 (長さ = grid 数)。 [English]: The grid values for the feature of interest (length = grid count). + , pdpMean :: ![Double] -- ^ [日本語]: PDP: 各 grid 値で全観測行の予測を平均 (長さ = grid 数)。 [English]: PDP: the average prediction across all observation rows at each grid value (length = grid count). + , pdpIce :: ![[Double]] -- ^ [日本語]: ICE: 観測行ごとの曲線 (n 本・各長さ = grid 数)。 [English]: ICE: one curve per observation row (n curves, each of length = grid count). + } deriving (Eq, Show) + +-- =========================================================================== +-- 計算 +-- =========================================================================== + +-- | [日本語]: 注目特徴 j の観測 @[min,max]@ を等間隔 grid にして PDP/ICE を計算する。 +-- grid 数 <2 は 2 に切り上げ。 空データ・列外 index は空結果 ('PDPResult' [] [] [])。 +-- [English]: Computes PDP\/ICE by turning the observed @[min,max]@ of +-- feature j into an evenly-spaced grid. A grid count <2 is rounded up +-- to 2. Empty data or an out-of-range column index yields an empty +-- result ('PDPResult' [] [] []). +partialDependence + :: LA.Matrix Double -- ^ [日本語]: 訓練特徴行列 X (n 行 × p 列)。 [English]: The training feature matrix X (n rows × p columns). + -> (LA.Matrix Double -> [Double]) -- ^ [日本語]: predict: 行列の各行 → 予測値 (長さ = 行数)。 [English]: predict: each row of the matrix → a predicted value (length = row count). + -> Int -- ^ [日本語]: 注目特徴の列 index j (0 始まり)。 [English]: The column index j of the feature of interest (0-based). + -> Int -- ^ [日本語]: grid 数。 [English]: The grid count. + -> PDPResult +partialDependence x predict j n + | LA.rows x == 0 || j < 0 || j >= LA.cols x = PDPResult [] [] [] + | otherwise = + let col = LA.toList (LA.toColumns x !! j) + lo = minimum col + hi = maximum col + m = max 2 n + grid = [ lo + (hi - lo) * fromIntegral i / fromIntegral (m - 1) + | i <- [0 .. m - 1] ] + in partialDependenceGrid x predict j grid + +-- | [日本語]: grid を明示指定する版。 分位点 grid や任意評価点を渡したいときに使う。 +-- 空 grid・空データ・列外 index は空結果。 +-- [English]: The variant that explicitly specifies the grid. Use it +-- when passing a quantile grid or arbitrary evaluation points. An +-- empty grid, empty data, or an out-of-range column index yields an +-- empty result. +partialDependenceGrid + :: LA.Matrix Double + -> (LA.Matrix Double -> [Double]) + -> Int + -> [Double] -- ^ [日本語]: 注目特徴の評価 grid。 [English]: The evaluation grid for the feature of interest. + -> PDPResult +partialDependenceGrid x predict j grid + | LA.rows x == 0 || j < 0 || j >= LA.cols x || null grid = PDPResult [] [] [] + | otherwise = + let nrows = LA.rows x + cols = LA.toColumns x + -- 各 grid 値 g で X の j 列を定数 g に置換 → 全行 predict (長さ nrows)。 + predsAtG g = + let xg = LA.fromColumns + [ if c == j then LA.konst g nrows else col + | (c, col) <- zip [0 ..] cols ] + in predict xg + byGrid = [ predsAtG g | g <- grid ] -- grid × n + means = [ sum ps / fromIntegral nrows | ps <- byGrid ] + ice = transpose byGrid -- n × grid (行ごとの曲線) + in PDPResult grid means ice + +-- =========================================================================== +-- 変換 +-- =========================================================================== + +-- | [日本語]: 中心化 ICE (c-ICE)。 各 ICE 曲線を __左端 (grid[0]) の値が 0__ に +-- なるよう平行移動し、 PDP 平均も中心化後の ICE から取り直す。 個体間の傾き差を +-- 見やすくする (sklearn @centered=True@ / R @ice()@ centered 相当)。 空結果はそのまま。 +-- [English]: Centered ICE (c-ICE). Shifts each ICE curve so that +-- __the value at the left end (grid[0]) is 0__, and re-derives the +-- PDP mean from the centered ICE. Makes differences in slope between +-- individuals easier to see (equivalent to sklearn's +-- @centered=True@ \/ R's @ice()@ centered). An empty result passes +-- through unchanged. +centerICE :: PDPResult -> PDPResult +centerICE r + | null (pdpGrid r) || null (pdpIce r) = r + | otherwise = + let ice' = [ case curve of + (c0 : _) -> map (subtract c0) curve + [] -> curve + | curve <- pdpIce r ] + nrows = length ice' + means' = case ice' of + [] -> [] + _ -> map (\col -> sum col / fromIntegral nrows) (transpose ice') + in r { pdpMean = means', pdpIce = ice' } diff --git a/src/Hanalyze/Model/Quantile.hs b/src/Hanalyze/Model/Quantile.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Quantile.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.Quantile +-- Description : Quantile regression — Hunter & Lange (2000) MM 法による条件付き τ-分位点回帰 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Quantile regression. +-- +-- Whereas OLS fits the conditional /mean/, quantile regression fits the +-- conditional @τ@-quantile (with @τ ∈ (0, 1)@). @τ = 0.5@ gives outlier- +-- robust median regression; @τ = 0.1 / 0.9@ estimate lower / upper +-- quantiles, useful for predictive intervals and heteroscedastic data. +-- +-- Loss function (pinball / check loss): +-- +-- > ρ_τ(u) = u (τ - 𝟙[u < 0]) = τ u if u ≥ 0 +-- > (τ-1) u if u < 0 +-- +-- Algorithm: Hunter & Lange (2000) Majorization-Minimization. Locally +-- approximate @|u|@ by a quadratic and iterate weighted least squares: +-- +-- [日本語]: +-- +-- 1. β₀ = OLS 解で初期化 +-- 2. 反復 k: +-- - r = y - X β_k +-- - w_i = 1 / (2 max(|r_i|, ε)) +-- - y'_i = y_i + (τ - ½) / w_i +-- - β_{k+1} = (Xᵀ W X)⁻¹ Xᵀ W y' +-- 3. ||β_{k+1} - β_k|| < tol で停止 (max 100 iter)。 +-- +-- 評価指標 (Koenker-Machado 1999): R¹_τ = 1 - V̂_τ(model) / V̂_τ(intercept-only) +-- where V̂_τ(m) = Σ ρ_τ(r_i^m)。 +-- +-- [English]: +-- +-- 1. Initialize β₀ with the OLS solution. +-- 2. Iteration k: +-- - r = y - X β_k +-- - w_i = 1 / (2 max(|r_i|, ε)) +-- - y'_i = y_i + (τ - ½) / w_i +-- - β_{k+1} = (Xᵀ W X)⁻¹ Xᵀ W y' +-- 3. Stop when ||β_{k+1} - β_k|| < tol (max 100 iterations). +-- +-- Evaluation metric (Koenker-Machado 1999): R¹_τ = 1 - V̂_τ(model) / V̂_τ(intercept-only) +-- where V̂_τ(m) = Σ ρ_τ(r_i^m). +module Hanalyze.Model.Quantile + ( QRFit (..) + , fitQuantile + , predictQuantile + , pinballLoss + , pseudoR1 + ) where + +import qualified Data.List as L +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Stat.Cholesky as Chol + +-- --------------------------------------------------------------------------- +-- 型 +-- --------------------------------------------------------------------------- + +-- | Quantile-regression fit result. +data QRFit = QRFit + { qfTau :: Double -- ^ Quantile level @τ ∈ (0, 1)@. + , qfBeta :: LA.Vector Double -- ^ Coefficients. + , qfYHat :: LA.Vector Double -- ^ Fitted values @X β@. + , qfResid :: LA.Vector Double -- ^ Residuals @y − X β@. + , qfPinball :: Double -- ^ Total pinball loss @V̂_τ@. + , qfR1 :: Double -- ^ Koenker-Machado pseudo @R¹_τ@. + , qfIters :: Int -- ^ Number of iterations executed. + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- フィット +-- --------------------------------------------------------------------------- + +-- | Fit a @τ@-quantile regression by Majorization-Minimization IRLS. +fitQuantile :: Double -- ^ Quantile level @τ ∈ (0, 1)@. + -> LA.Matrix Double -- ^ Design matrix @X@ (must include the intercept column). + -> LA.Vector Double -- ^ Response @y@. + -> QRFit +fitQuantile tau x y + | tau <= 0 || tau >= 1 = error "fitQuantile: tau must be in (0, 1)" + | otherwise = + let !beta0 = x LA.<\> y -- OLS 初期値 + !eps = 1e-6 + !maxIter = 100 :: Int + !tol = 1e-7 + !p = LA.cols x + !onesP = LA.konst 1 p :: LA.Vector Double + (betaF, k) = loop beta0 0 + loop b iter + | iter >= maxIter = (b, iter) + | otherwise = + let !r = y - x LA.#> b + -- w_i = 1 / (2 max(|r_i|, eps)) + !wVec = LA.cmap (\v -> 1 / (2 * max eps (abs v))) r + -- y' = y + (tau - 0.5) / w + !yp = y + LA.cmap (\wi -> (tau - 0.5) / wi) wVec + -- W^{1/2}. + !sqW = LA.cmap sqrt wVec + -- B10a (2026-05-06): row-scaling of X via outer + -- product (broadcast sqW across columns) instead + -- of the previous "@LA.toRows x !! i@" + "@diag@" + -- combination, which was @O(n² p)@ per iteration + -- (76× slower than statsmodels on n=10k p=20). + -- Now @O(n p)@ per iteration — single elementwise + -- multiply with a fully-allocated outer product. + !sqWBcast = LA.outer sqW onesP -- n × p + !xScaled = sqWBcast * x -- n × p + !yScaled = sqW * yp -- length n + -- Solve the SPD normal equations + -- (X^T W X) β = X^T W y' + -- via Cholesky rather than the general LSQ path + -- '@LA.<\>@' (QR/dgels). For @p ≪ n@ the @p × p@ + -- @aMat@ is tiny and dpotrf is faster than dgels + -- on the @n × p@ @xScaled@ matrix; this is the + -- same trick GLM IRLS already uses. + !aMat = LA.tr xScaled LA.<> xScaled + !rhs = LA.asColumn (LA.tr xScaled LA.#> yScaled) + !bNew = LA.flatten (Chol.cholSolveJitter aMat rhs) + !delta = LA.norm_2 (bNew - b) + in if delta < tol then (bNew, iter + 1) + else loop bNew (iter + 1) + yhat = x LA.#> betaF + resid = y - yhat + loss = pinballLoss tau (LA.toList resid) + -- baseline: intercept-only model with τ-quantile of y + ys = LA.toList y + baseQ = quantile tau ys + baseR = [ yi - baseQ | yi <- ys ] + baseLoss = pinballLoss tau baseR + r1 = if baseLoss <= 1e-12 then 0 + else 1 - loss / baseLoss + in QRFit + { qfTau = tau + , qfBeta = betaF + , qfYHat = yhat + , qfResid = resid + , qfPinball = loss + , qfR1 = r1 + , qfIters = k + } + +-- | Predict at new inputs. +predictQuantile :: QRFit -> LA.Matrix Double -> LA.Vector Double +predictQuantile fit xNew = xNew LA.#> qfBeta fit + +-- --------------------------------------------------------------------------- +-- 補助関数 +-- --------------------------------------------------------------------------- + +-- | Total pinball / check loss: @Σ ρ_τ(r_i)@. +pinballLoss :: Double -> [Double] -> Double +pinballLoss tau rs = + sum [ if r >= 0 then tau * r else (tau - 1) * r | r <- rs ] + +-- | Empirical @τ@-quantile (simple linear-interpolation style). +quantile :: Double -> [Double] -> Double +quantile p xs + | null xs = 0 + | otherwise = + -- Phase 11b (2026-05-14): replaced naive list quicksort with + -- 'Data.List.sort' (mergesort, O(n log n), O(n) space). Pivot-bias + -- could push the old version to O(n²) space. + let sorted = L.sort xs + n = length sorted + ix = p * fromIntegral (n - 1) + lo = floor ix :: Int + hi = min (n - 1) (lo + 1) + frac = ix - fromIntegral lo + in (1 - frac) * (sorted !! lo) + frac * (sorted !! hi) + +-- | [日本語]: Pseudo R¹_τ を別途計算 (model loss と baseline loss から)。 +-- [English]: Compute the pseudo R¹_τ separately (from the model loss +-- and baseline loss). +pseudoR1 :: Double -- ^ model V̂_τ + -> Double -- ^ baseline (intercept-only) V̂_τ + -> Double +pseudoR1 modelV baseV + | baseV <= 1e-12 = 0 + | otherwise = 1 - modelV / baseV diff --git a/src/Hanalyze/Model/RFF.hs b/src/Hanalyze/Model/RFF.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/RFF.hs @@ -0,0 +1,1193 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.RFF +-- Description : Random Fourier Features (RFF) — Bochner の定理に基づく kernel の明示的特徴写像近似 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Random Fourier Features (RFF) — kernel 近似。 +-- +-- Bochner の定理により、 定常カーネル +-- @k(x, x') = ∫ p(ω) e^{iω(x-x')} dω@ は、 @p(ω)@ からサンプリングした @D@ 個の +-- 周波数 @ω_j@ と一様位相 @b_j@ を介した明示的な特徴写像を持つ: +-- +-- @ +-- φ(x) = σ_f √(2/D) [cos(ω_j x + b_j)]_{j=1..D} +-- @ +-- +-- これにより @k(x, x') ≈ φ(x)·φ(x')@ となる (Rahimi & Recht 2007)。 +-- +-- 利点: +-- +-- - @O(n³)@ の kernel 計算が @O(n D + D³)@ に削減される — @n@ について線形。 +-- - Ridge 回帰と GP 事後分布が @D@ 次元の線形代数になる。 +-- +-- 本モジュールは単変量・多変量入力の両方 (@MV@ 接尾辞の API) をサポートする。 +-- - 'sampleRFFRBF': RBF カーネル (ω ~ N(0, 1/ℓ²)) +-- - 'sampleRFFMatern52': Matérn 5/2 (ω ~ scaled t with df = 5) +-- - 'rffFeatures': 特徴行列 Φ を構築 (n × D) +-- - 'rffRidge': RFF + Ridge 回帰 (=O(n³) Kernel Ridge の近似) +-- - 'rffGP': RFF + ベイズ線形回帰 = GP 事後の近似 (mean + variance) +-- +-- [English]: Random Fourier Features (RFF) — kernel approximation. +-- +-- By Bochner's theorem, a stationary kernel +-- @k(x, x') = ∫ p(ω) e^{iω(x-x')} dω@ admits an explicit feature map +-- defined via @D@ frequencies @ω_j@ sampled from @p(ω)@ and uniform +-- phases @b_j@: +-- +-- @ +-- φ(x) = σ_f √(2/D) [cos(ω_j x + b_j)]_{j=1..D} +-- @ +-- +-- so that @k(x, x') ≈ φ(x)·φ(x')@ (Rahimi & Recht 2007). +-- +-- Benefits: +-- +-- - @O(n³)@ kernel computation reduces to @O(n D + D³)@ — linear in @n@. +-- - Ridge regression and GP posterior become @D@-dimensional linear +-- algebra. +-- +-- This module supports both univariate and multivariate inputs (the +-- @MV@-suffixed APIs). +-- - 'sampleRFFRBF': RBF kernel (ω ~ N(0, 1/ℓ²)) +-- - 'sampleRFFMatern52': Matérn 5/2 (ω ~ scaled t with df = 5) +-- - 'rffFeatures': builds the feature matrix Φ (n × D) +-- - 'rffRidge': RFF + Ridge regression (= approximation of O(n³) Kernel Ridge) +-- - 'rffGP': RFF + Bayesian linear regression = approximation of the GP posterior (mean + variance) +module Hanalyze.Model.RFF + ( RFFKernel (..) + , RFFFeatures (..) + , rffDim + -- * Feature generation + , sampleRFFRBF + , sampleRFFMatern52 + , sampleRFFRBFPure + , sampleRFFMatern52Pure + , rffFeatures + , rffApproxKernel + -- * RFF ridge regression (primary API: multi-output) + , RFFRidgeFit (..) + , rffRidge + , predictRFFRidge + , RFFRidgeFitMulti (..) + , rffRidgeMulti + , predictRFFRidgeMulti + -- * RFF GP (posterior mean + variance) + , RFFGPFit (..) + , rffGP + , predictRFFGP + -- * Multivariate input (@p@ dimensions) + , RFFFeaturesMV (..) + , sampleRFFRBFMV + , sampleRFFMatern52MV + , sampleRFFRBFMVPure + , sampleRFFMatern52MVPure + , rffFeaturesMV + , RFFRidgeFitMV (..) + , rffRidgeMV + , predictRFFRidgeMV + , RFFGPFitMV (..) + , rffGPMV + , predictRFFGPMV + , RFFRidgeFitMVMO (..) + , rffRidgeMVMulti + , predictRFFRidgeMVMulti + -- * Marginal-likelihood maximization (auto-tune ℓ, σ_f, σ_n) + , logMarginalLikRBFMV + , maximizeMarginalLikRBFMV + , maximizeMarginalLikRBFMV_DE + , MLikResult (..) + -- * LOOCV closed form (faster HP auto-tuning) + , loocvFromPhi + , loocvRFFRidgeMV + , gridSearchLOOCVRBFMV + , gridSearchLOOCVRBFMV_DE + , bayesOptLOOCVRBFMV + , lbfgsLOOCVRBFMV + , LOOCVResult (..) + ) where + +import Control.Exception (SomeException, try, evaluate) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Data.Word (Word32) +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import Control.Monad.ST (runST) +import qualified Numeric.LinearAlgebra as LA +import qualified System.IO.Unsafe +import System.IO.Unsafe (unsafePerformIO) +import qualified System.Random.MWC +import System.Random.MWC (GenIO, Gen, uniformR, initialize) +import qualified System.Random.MWC.Distributions as MWCD +import qualified Hanalyze.Optim.DifferentialEvolution as DEM +import qualified Hanalyze.Optim.Common as OCM +import qualified Hanalyze.Optim.BayesOpt as BO +import qualified Hanalyze.Optim.LBFGS as LBFGS +import qualified Hanalyze.Stat.Cholesky as Chol +import qualified Hanalyze.Stat.KernelDist as KD +import qualified Data.Vector.Algorithms.Intro as Intro + +-- --------------------------------------------------------------------------- +-- 型 +-- --------------------------------------------------------------------------- + +-- | Supported kernels for RFF approximation. +data RFFKernel = RFFRBF | RFFMatern52 + deriving (Show, Eq) + +-- | All the information needed to evaluate an RFF feature map. +data RFFFeatures = RFFFeatures + { rffKernel :: RFFKernel + , rffOmegas :: V.Vector Double -- ^ Random frequencies @ω_j@ (length @D@). + , rffBs :: V.Vector Double -- ^ Random phases @b_j ∈ [0, 2π)@. + , rffSigmaF :: Double -- ^ Signal standard deviation @σ_f@. + , rffLengthScale :: Double -- ^ Length scale @ℓ@. + } deriving (Show) + +-- | Number of features @D@. +rffDim :: RFFFeatures -> Int +rffDim = V.length . rffOmegas + +-- --------------------------------------------------------------------------- +-- 周波数サンプリング +-- --------------------------------------------------------------------------- + +-- | [日本語]: RBF カーネル用の RFF 特徴をサンプリングする: +-- @ω_j ~ N(0, 1/ℓ²)@、 @b_j ~ U(0, 2π)@。 +-- +-- 'PrimMonad' 汎用 (mwc は 'PrimMonad' 汎用ゆえ ST/IO 両経路で同コード)。 +-- IO 呼び出しは @GenIO = Gen (PrimState IO)@ ゆえ従来どおり。 純粋 (seed) 経路は +-- 'sampleRFFRBFPure' (@gp@ spec の RFF 近似象限を pure @fitWith@ で完結 +-- させるため・[[kMeansPure]]/[[fitRFVPure]] と一貫)。 +-- [English]: Sample RFF features for the RBF kernel: @ω_j ~ N(0, 1/ℓ²)@, +-- @b_j ~ U(0, 2π)@. +-- +-- Generic over 'PrimMonad' (mwc is generic over 'PrimMonad', so the same +-- code serves both the ST and IO paths). IO calls use +-- @GenIO = Gen (PrimState IO)@ as before. The pure (seed) path is +-- 'sampleRFFRBFPure' (a bridge letting the @gp@ spec's RFF-approximation +-- quadrant be completed with a pure @fitWith@, consistent with +-- [[kMeansPure]]\/[[fitRFVPure]]). +sampleRFFRBF :: PrimMonad m + => Int -- ^ Feature dimension @D@. + -> Double -- ^ Length scale @ℓ@. + -> Double -- ^ Signal SD @σ_f@. + -> Gen (PrimState m) -> m RFFFeatures +sampleRFFRBF d ell sf gen = do + ws <- V.replicateM d (MWCD.normal 0 (1/ell) gen) + bs <- V.replicateM d (uniformR (0, 2*pi) gen) + return RFFFeatures + { rffKernel = RFFRBF + , rffOmegas = ws + , rffBs = bs + , rffSigmaF = sf + , rffLengthScale = ell + } + +-- | Sample RFF features for the Matérn 5/2 kernel: +-- @ω = z/√u@ where @z ~ N(0, 1/ℓ²)@ and @u ~ Gamma(ν, ν)@ with @ν = 5/2@. +-- This is a scaled @df = 5@ Student-t distribution, matching the +-- spectral density. +sampleRFFMatern52 :: PrimMonad m + => Int -> Double -> Double -> Gen (PrimState m) -> m RFFFeatures +sampleRFFMatern52 d ell sf gen = do + let nu = 2.5 :: Double + ws <- V.replicateM d $ do + z <- MWCD.normal 0 (1/ell) gen + -- mwc-random-distributions の gamma は (shape, scale) 渡し → mean = shape * scale + -- Gamma(ν, 1/ν) で mean = 1 + u <- MWCD.gamma nu (1/nu) gen + return (z / sqrt u) + bs <- V.replicateM d (uniformR (0, 2*pi) gen) + return RFFFeatures + { rffKernel = RFFMatern52 + , rffOmegas = ws + , rffBs = bs + , rffSigmaF = sf + , rffLengthScale = ell + } + +-- | [日本語]: 純粋 (seed) 版 'sampleRFFRBF'。 同 seed → 同 'RFFFeatures' +-- (ST\/IO ビット一致)。 @gp@ spec の @GpRff@\/@RidgeRff@ 象限を pure +-- @fitWith@ で完結させる継ぎ目。 +-- [English]: Pure (seed) version of 'sampleRFFRBF'. The same seed yields +-- the same 'RFFFeatures' (bit-identical across ST\/IO). The bridge that +-- lets the @gp@ spec's @GpRff@\/@RidgeRff@ quadrant be completed with a +-- pure @fitWith@. +sampleRFFRBFPure :: Int -> Double -> Double -> Word32 -> RFFFeatures +sampleRFFRBFPure d ell sf seed = + runST (initialize (V.singleton seed) >>= sampleRFFRBF d ell sf) + +-- | [日本語]: 純粋 (seed) 版 'sampleRFFMatern52'。 +-- [English]: Pure (seed) version of 'sampleRFFMatern52'. +sampleRFFMatern52Pure :: Int -> Double -> Double -> Word32 -> RFFFeatures +sampleRFFMatern52Pure d ell sf seed = + runST (initialize (V.singleton seed) >>= sampleRFFMatern52 d ell sf) + +-- --------------------------------------------------------------------------- +-- 特徴写像 +-- --------------------------------------------------------------------------- + +-- | Feature matrix @Φ ∈ ℝ^{n×D}@. +-- @φ(x) = σ_f √(2/D) [cos(ω_j x + b_j)]_{j=1..D}@. +-- +-- Single-pass 'runST' implementation: avoids the @[Double]@ +-- list-comprehension @(n × D)@ + 'LA.fromList' round-trip the +-- previous version performed. +rffFeatures :: RFFFeatures -> [Double] -> LA.Matrix Double +rffFeatures rff xs = + let d = rffDim rff + sf = rffSigmaF rff + coef = sf * sqrt (2 / fromIntegral d) + -- Convert input list / boxed Vectors to Storable for fast access. + xsV = VS.fromList xs + n = VS.length xsV + ws = VS.fromList (V.toList (rffOmegas rff)) + bs = VS.fromList (V.toList (rffBs rff)) + out = runST $ do + v <- VSM.new (n * d) + let go i j + | i >= n = pure () + | j >= d = go (i + 1) 0 + | otherwise = do + let !x_ = xsV `VS.unsafeIndex` i + !w_ = ws `VS.unsafeIndex` j + !b_ = bs `VS.unsafeIndex` j + !val = coef * cos (w_ * x_ + b_) + VSM.unsafeWrite v (i * d + j) val + go i (j + 1) + go 0 0 + VS.unsafeFreeze v + in LA.reshape d out + +-- | Kernel matrix approximated by RFF: @K[i,j] ≈ k(x_i, x_j) = φ(x_i)·φ(x_j)@. +rffApproxKernel :: RFFFeatures -> [Double] -> LA.Matrix Double +rffApproxKernel rff xs = + let phi = rffFeatures rff xs + in phi LA.<> LA.tr phi + +-- --------------------------------------------------------------------------- +-- RFF Ridge 回帰 +-- --------------------------------------------------------------------------- + +-- | Single-output RFF ridge fit. +data RFFRidgeFit = RFFRidgeFit + { rffrFeatures :: RFFFeatures + , rffrWeights :: LA.Vector Double -- ^ Weight vector (length @D@). + , rffrLambda :: Double -- ^ Ridge penalty @λ@. + } deriving (Show) + +-- | Single-output RFF ridge regression. Delegates to 'rffRidgeMulti' by +-- promoting @y@ to a one-column matrix. +rffRidge :: RFFFeatures -> [Double] -> [Double] -> Double -> RFFRidgeFit +rffRidge rff xs ys lam = + let yMat = LA.asColumn (LA.fromList ys) + mf = rffRidgeMulti rff xs yMat lam + w = LA.flatten (rffrmWeights mf LA.¿ [0]) + in RFFRidgeFit rff w lam + +-- | Predict at new inputs from a 'RFFRidgeFit'. +predictRFFRidge :: RFFRidgeFit -> [Double] -> [Double] +predictRFFRidge fit xNew = + let phi = rffFeatures (rffrFeatures fit) xNew + yhat = phi LA.#> rffrWeights fit + in LA.toList yhat + +-- | Multi-output RFF ridge fit (1D inputs). @Y@ is @n × q@, weights @W@ +-- are @D × q@. +data RFFRidgeFitMulti = RFFRidgeFitMulti + { rffrmFeatures :: RFFFeatures + , rffrmWeights :: LA.Matrix Double -- ^ Weight matrix (@D × q@). + , rffrmLambda :: Double -- ^ Ridge penalty @λ@. + } deriving (Show) + +-- | Multi-output RFF ridge regression: @W = (ΦᵀΦ + λI)⁻¹ Φᵀ Y@. +-- SPD system; solved via Cholesky with diagonal regularizer applied +-- in place (@addToDiagRFF@). +rffRidgeMulti :: RFFFeatures -> [Double] -> LA.Matrix Double -> Double + -> RFFRidgeFitMulti +rffRidgeMulti rff xs ys lam = + let phi = rffFeatures rff xs -- n × D + gram = LA.tr phi LA.<> phi -- D × D (SPD) + regK = addToDiagRFF lam gram + rhs = LA.tr phi LA.<> ys -- D × q + w = Chol.cholSolveJitter regK rhs + in RFFRidgeFitMulti rff w lam + +-- | Multi-output prediction at new inputs from a 'RFFRidgeFitMulti'. +predictRFFRidgeMulti :: RFFRidgeFitMulti -> [Double] -> LA.Matrix Double +predictRFFRidgeMulti fit xNew = + let phi = rffFeatures (rffrmFeatures fit) xNew + in phi LA.<> rffrmWeights fit + +-- --------------------------------------------------------------------------- +-- RFF GP (ベイズ線形回帰 with prior w ~ N(0, I)) +-- --------------------------------------------------------------------------- + +-- | Bayesian linear regression on RFF features (a Gaussian-process +-- approximation). +-- +-- Prior: @w ~ N(0, I)@ (the @σ_f@ amplitude is already in the features). +-- +-- Likelihood: @y = φᵀ w + ε@, @ε ~ N(0, σ_n²)@. +-- +-- Posterior: @Σ⁻¹ = ΦᵀΦ / σ_n² + I@, @μ = Σ Φᵀ y / σ_n²@. +data RFFGPFit = RFFGPFit + { rffgpFeatures :: RFFFeatures + , rffgpSigma :: LA.Matrix Double -- ^ Posterior covariance @Σ@ (@D × D@). + , rffgpMean :: LA.Vector Double -- ^ Posterior mean @μ@ (length @D@). + , rffgpSigmaN :: Double -- ^ Observation noise SD @σ_n@. + } deriving (Show) + +-- | Fit an RFF-based Bayesian linear-regression GP. +rffGP :: RFFFeatures -> [Double] -> [Double] -> Double -> RFFGPFit +rffGP rff xs ys sigmaN = + let phi = rffFeatures rff xs + d = rffDim rff + sigN2 = sigmaN ^ (2 :: Int) + yV = LA.fromList ys + sigInv = LA.scale (1 / sigN2) (LA.tr phi LA.<> phi) + `LA.add` LA.ident d + sigma = LA.inv sigInv + mu = sigma LA.#> LA.scale (1 / sigN2) (LA.tr phi LA.#> yV) + in RFFGPFit + { rffgpFeatures = rff + , rffgpSigma = sigma + , rffgpMean = mu + , rffgpSigmaN = sigmaN + } + +-- | Per-test-point @(mean, variance of f)@. The observation-noise term +-- @σ_n²@ is /not/ added. +-- +-- @mean = φ(x*)ᵀ μ@, @var = φ(x*)ᵀ Σ φ(x*)@. +predictRFFGP :: RFFGPFit -> [Double] -> [(Double, Double)] +predictRFFGP fit xNew = + let rff = rffgpFeatures fit + phi = rffFeatures rff xNew -- n_new × D + mu = rffgpMean fit + sigma = rffgpSigma fit + means = LA.toList (phi LA.#> mu) + vars = [ max 0 (LA.dot phi_i (sigma LA.#> phi_i)) + | phi_i <- LA.toRows phi ] + in zip means vars + +-- --------------------------------------------------------------------------- +-- 多変量入力 (p 次元) 対応 (Phase B-RFF) +-- --------------------------------------------------------------------------- + +-- | Multivariate RFF feature-generation parameters. 'rffmvOmegas' is a +-- @p × D@ matrix; each column is one frequency vector @ω_j ∈ ℝ^p@. +data RFFFeaturesMV = RFFFeaturesMV + { rffmvKernel :: RFFKernel + , rffmvDim :: Int -- ^ Input dimension @p@. + , rffmvOmegas :: LA.Matrix Double -- ^ Frequencies (@p × D@). + , rffmvBs :: V.Vector Double -- ^ Phases @b_j@ (length @D@). + , rffmvSigmaF :: Double -- ^ Signal SD @σ_f@. + , rffmvLengthScale :: Double -- ^ Shared length scale @ℓ@ + -- (no ARD support yet). + } deriving (Show) + +-- | Sample multivariate RFF features for the RBF kernel. +-- Each component @ω_j[k] ~ N(0, 1/ℓ²)@ independently. +sampleRFFRBFMV + :: PrimMonad m + => Int -> Int -> Double -> Double -> Gen (PrimState m) -> m RFFFeaturesMV +sampleRFFRBFMV p d ell sf gen = do + let total = p * d + ws <- V.replicateM total (MWCD.normal 0 (1/ell) gen) + bs <- V.replicateM d (uniformR (0, 2*pi) gen) + let omegaMat = LA.reshape d (LA.fromList (V.toList ws)) + return RFFFeaturesMV + { rffmvKernel = RFFRBF + , rffmvDim = p + , rffmvOmegas = omegaMat + , rffmvBs = bs + , rffmvSigmaF = sf + , rffmvLengthScale = ell + } + +-- | Sample multivariate RFF features for the Matérn 5/2 kernel. +sampleRFFMatern52MV + :: PrimMonad m + => Int -> Int -> Double -> Double -> Gen (PrimState m) -> m RFFFeaturesMV +sampleRFFMatern52MV p d ell sf gen = do + let nu = 2.5 :: Double + ws <- V.replicateM (p * d) $ do + z <- MWCD.normal 0 (1/ell) gen + u <- MWCD.gamma nu (1/nu) gen + return (z / sqrt u) + bs <- V.replicateM d (uniformR (0, 2*pi) gen) + return RFFFeaturesMV + { rffmvKernel = RFFMatern52 + , rffmvDim = p + , rffmvOmegas = LA.reshape d (LA.fromList (V.toList ws)) + , rffmvBs = bs + , rffmvSigmaF = sf + , rffmvLengthScale = ell + } + +-- | [日本語]: 純粋 (seed) 版 'sampleRFFRBFMV'。 +-- [English]: Pure (seed) version of 'sampleRFFRBFMV'. +sampleRFFRBFMVPure :: Int -> Int -> Double -> Double -> Word32 -> RFFFeaturesMV +sampleRFFRBFMVPure p d ell sf seed = + runST (initialize (V.singleton seed) >>= sampleRFFRBFMV p d ell sf) + +-- | [日本語]: 純粋 (seed) 版 'sampleRFFMatern52MV'。 +-- [English]: Pure (seed) version of 'sampleRFFMatern52MV'. +sampleRFFMatern52MVPure :: Int -> Int -> Double -> Double -> Word32 -> RFFFeaturesMV +sampleRFFMatern52MVPure p d ell sf seed = + runST (initialize (V.singleton seed) >>= sampleRFFMatern52MV p d ell sf) + +-- | Multivariate feature matrix: @X (n × p) → Φ (n × D)@. +-- @φ_j(x) = σ_f √(2/D) cos(ω_jᵀ x + b_j)@. +-- +-- Implementation: a single fused @runST + MVector@ pass writes the +-- @n × D@ output. The previous version went through +-- @LA.toRows xo + list comp (r + bs) + LA.fromRows + LA.cmap cos + +-- LA.scale coef@, allocating four @n × D@ intermediates and one list +-- of @n@ row vectors per call. This single-pass version emits one +-- @n × D@ allocation and computes +-- @coef · cos(xoFlat[i,j] + bs[j])@ in place. +rffFeaturesMV :: RFFFeaturesMV -> LA.Matrix Double -> LA.Matrix Double +rffFeaturesMV rff x = + let d = LA.cols (rffmvOmegas rff) + sf = rffmvSigmaF rff + coef = sf * sqrt (2 / fromIntegral d) + -- X @ Ω → n × D (BLAS GEMM, kept). + xo = x LA.<> rffmvOmegas rff + n = LA.rows xo + xoFlat = LA.flatten xo + -- Phases as a Storable Vector (length D) for O(1) indexing. + bs = VS.fromList (V.toList (rffmvBs rff)) + out = runST $ do + v <- VSM.new (n * d) + let go i j + | i >= n = pure () + | j >= d = go (i + 1) 0 + | otherwise = do + let !idx = i * d + j + !z = (xoFlat `VS.unsafeIndex` idx) + + (bs `VS.unsafeIndex` j) + !val = coef * cos z + VSM.unsafeWrite v idx val + go i (j + 1) + go 0 0 + VS.unsafeFreeze v + in LA.reshape d out + +-- | Multivariate RFF ridge fit. +data RFFRidgeFitMV = RFFRidgeFitMV + { rffrmvFeatures :: RFFFeaturesMV + , rffrmvWeights :: LA.Vector Double -- ^ Weights (length @D@). + , rffrmvLambda :: Double -- ^ Ridge penalty @λ@. + } deriving (Show) + +-- | Single-output multivariate RFF ridge regression. Delegates to +-- 'rffRidgeMVMulti' by promoting @y@ to a one-column matrix. +rffRidgeMV :: RFFFeaturesMV -> LA.Matrix Double -> [Double] -> Double + -> RFFRidgeFitMV +rffRidgeMV rff x ys lam = + let yMat = LA.asColumn (LA.fromList ys) + mf = rffRidgeMVMulti rff x yMat lam + w = LA.flatten (rffrmvmWeights mf LA.¿ [0]) + in RFFRidgeFitMV rff w lam + +-- | Predict at new inputs from a 'RFFRidgeFitMV'. +predictRFFRidgeMV :: RFFRidgeFitMV -> LA.Matrix Double -> [Double] +predictRFFRidgeMV fit xNew = + let phi = rffFeaturesMV (rffrmvFeatures fit) xNew + in LA.toList (phi LA.#> rffrmvWeights fit) + +-- | Multivariate-input RFF GP (Bayesian linear regression on RFF features). +-- The multi-input analogue of 'rffGP': same posterior algebra +-- (@Σ⁻¹ = ΦᵀΦ/σ_n² + I@, @μ = Σ Φᵀy/σ_n²@) but @Φ@ comes from +-- 'rffFeaturesMV'. Used by the @GpRff@ quadrant of the unified @gpMulti@ +-- spec to provide a posterior-variance band under RFF approximation. +data RFFGPFitMV = RFFGPFitMV + { rffgpmvFeatures :: RFFFeaturesMV + , rffgpmvSigma :: LA.Matrix Double -- ^ Posterior covariance @Σ@ (@D × D@). + , rffgpmvMean :: LA.Vector Double -- ^ Posterior mean @μ@ (length @D@). + , rffgpmvSigmaN :: Double -- ^ Observation noise SD @σ_n@. + } deriving (Show) + +-- | Fit a multivariate-input RFF Bayesian-linear-regression GP. +rffGPMV :: RFFFeaturesMV -> LA.Matrix Double -> [Double] -> Double -> RFFGPFitMV +rffGPMV rff x ys sigmaN = + let phi = rffFeaturesMV rff x + d = LA.cols (rffmvOmegas rff) + sigN2 = sigmaN ^ (2 :: Int) + yV = LA.fromList ys + sigInv = LA.scale (1 / sigN2) (LA.tr phi LA.<> phi) `LA.add` LA.ident d + sigma = LA.inv sigInv + mu = sigma LA.#> LA.scale (1 / sigN2) (LA.tr phi LA.#> yV) + in RFFGPFitMV + { rffgpmvFeatures = rff + , rffgpmvSigma = sigma + , rffgpmvMean = mu + , rffgpmvSigmaN = sigmaN + } + +-- | Per-test-point @(mean, variance of f)@ for an 'RFFGPFitMV'. The +-- observation-noise term @σ_n²@ is /not/ added (matching 'predictRFFGP'). +predictRFFGPMV :: RFFGPFitMV -> LA.Matrix Double -> [(Double, Double)] +predictRFFGPMV fit xNew = + let phi = rffFeaturesMV (rffgpmvFeatures fit) xNew + mu = rffgpmvMean fit + sigma = rffgpmvSigma fit + means = LA.toList (phi LA.#> mu) + vars = [ max 0 (LA.dot p (sigma LA.#> p)) | p <- LA.toRows phi ] + in zip means vars + +-- | Multivariate-input multi-output RFF ridge fit. @X@ is @n × p@, +-- @Y@ is @n × q@, weights @W@ are @D × q@. +data RFFRidgeFitMVMO = RFFRidgeFitMVMO + { rffrmvmFeatures :: RFFFeaturesMV + , rffrmvmWeights :: LA.Matrix Double -- ^ D × q + , rffrmvmLambda :: Double + } deriving (Show) + +-- | Multivariate-input multi-output RFF ridge regression: +-- @W = (ΦᵀΦ + λI)⁻¹ Φᵀ Y@. +-- +-- The system is SPD by construction, so we solve via Cholesky rather +-- than the general LSQ path '(LA.<\>)'. The diagonal regularizer is +-- applied via @addToDiagRFF@ (in-place runST update) instead of +-- @gram + LA.scale lam (LA.ident d)@ which would allocate a fresh +-- @D × D@ identity. +rffRidgeMVMulti :: RFFFeaturesMV -> LA.Matrix Double -> LA.Matrix Double + -> Double -> RFFRidgeFitMVMO +rffRidgeMVMulti rff x ys lam = + let phi = rffFeaturesMV rff x -- n × D + gram = LA.tr phi LA.<> phi -- D × D (SPD) + regK = addToDiagRFF lam gram -- D × D + rhs = LA.tr phi LA.<> ys -- D × q + w = Chol.cholSolveJitter regK rhs + in RFFRidgeFitMVMO rff w lam + +-- | Add a scalar to the diagonal of a square matrix in a single +-- 'runST' pass (no fresh @D × D@ identity allocation). Mirrors +-- 'Hanalyze.Model.GP.addToDiag'; duplicated here to keep the modules +-- decoupled. +addToDiagRFF :: Double -> LA.Matrix Double -> LA.Matrix Double +addToDiagRFF c m = + let d = LA.rows m + flat = LA.flatten m + out = runST $ do + v <- VSM.new (d * d) + let copy i + | i >= d * d = pure () + | otherwise = do + VSM.unsafeWrite v i (flat `VS.unsafeIndex` i) + copy (i + 1) + copy 0 + let bumpDiag i + | i >= d = pure () + | otherwise = do + let !idx = i * d + i + d_old <- VSM.unsafeRead v idx + VSM.unsafeWrite v idx (d_old + c) + bumpDiag (i + 1) + bumpDiag 0 + VS.unsafeFreeze v + in LA.reshape d out + +-- | Multi-output prediction at new inputs from a 'RFFRidgeFitMVMO'. +predictRFFRidgeMVMulti :: RFFRidgeFitMVMO -> LA.Matrix Double -> LA.Matrix Double +predictRFFRidgeMVMulti fit xNew = + let phi = rffFeaturesMV (rffrmvmFeatures fit) xNew + in phi LA.<> rffrmvmWeights fit + +-- --------------------------------------------------------------------------- +-- 周辺尤度最大化 (RFF GP 流の HP チューニング、Phase 2) +-- --------------------------------------------------------------------------- + +-- | [日本語]: 多変量入力 @X@ (@n × p@) と観測 @y@ に対する、 RBF カーネル下での +-- 周辺対数尤度。 +-- +-- K_ij = σ_f² · exp(-‖x_i - x_j‖² / (2 ℓ²)) +-- y | θ ~ N(0, K + σ_n² I) +-- +-- log p(y|θ) = -½ yᵀ (K+σ_n² I)⁻¹ y - ½ log|K+σ_n² I| - n/2 log(2π) +-- +-- Cholesky 分解で安定計算。 ℓ が極小で K が特異化したら -∞ 近似値を返す。 +-- [English]: Log marginal likelihood under the RBF kernel for multivariate +-- input @X@ (@n × p@) and observations @y@. +-- +-- K_ij = σ_f² · exp(-‖x_i - x_j‖² / (2 ℓ²)) +-- y | θ ~ N(0, K + σ_n² I) +-- +-- log p(y|θ) = -½ yᵀ (K+σ_n² I)⁻¹ y - ½ log|K+σ_n² I| - n/2 log(2π) +-- +-- Computed stably via Cholesky decomposition. If @ℓ@ is extremely small +-- and @K@ becomes singular, an approximate value of -∞ is returned. +logMarginalLikRBFMV + :: LA.Matrix Double -- ^ X (n × p) + -> LA.Vector Double -- ^ y (n) + -> Double -- ^ ℓ + -> Double -- ^ σ_f + -> Double -- ^ σ_n + -> Double +logMarginalLikRBFMV x y ell sf sn = + let n = LA.rows x + kMat = rbfKernelMat x ell sf + cMat = kMat + LA.scale (sn * sn) (LA.ident n) + -- Cholesky: cMat = Rᵀ R (R 上三角)。失敗時は jitter を加えて再試行。 + tryChol c = + let result = unsafePerformIO $ try (evaluate (LA.chol (LA.sym c))) :: Either SomeException (LA.Matrix Double) + in case result of + Right r -> Just r + Left _ -> Nothing + mR = case tryChol cMat of + Just r -> Just r + Nothing -> tryChol (cMat + LA.scale 1e-6 (LA.ident n)) + in case mR of + Nothing -> -1e30 -- 特異 → ペナルティ + Just r -> + let logDet = 2 * sum (map log (LA.toList (LA.takeDiag r))) + alpha = cMat LA.<\> y + dataFit = LA.dot y alpha + in -0.5 * dataFit - 0.5 * logDet + - fromIntegral n / 2 * log (2 * pi) + +-- | RBF kernel matrix for inputs @X@ (@n × p@): +-- @K[i,j] = σ_f² · exp(−‖x_i − x_j‖² / (2ℓ²))@. +rbfKernelMat :: LA.Matrix Double -> Double -> Double -> LA.Matrix Double +rbfKernelMat x ell sf = + let sf2 = sf * sf + twol2 = 2 * ell * ell + d2 = KD.pairwiseSqDist x + in LA.cmap (\v -> sf2 * exp (negate v / twol2)) d2 + +-- | Marginal-likelihood maximization result. +data MLikResult = MLikResult + { mlEll :: !Double + , mlSigmaF :: !Double + , mlSigmaN :: !Double + , mlLogMlik :: !Double + , mlGridPts :: !Int -- ^ [日本語]: 評価したグリッド点数 (debug 用)。 [English]: The number of grid points evaluated (for debugging). + } deriving (Show) + +-- | [日本語]: @(ℓ, σ_f, σ_n)@ に対するグリッドサーチで周辺尤度を最大化する。 +-- +-- 戦略: +-- +-- 1. ℓ は median pairwise distance を中心に log 等間隔で n_ℓ 点 +-- 2. σ_f は std(y) を中心に log で n_σf 点 +-- 3. σ_n は std(y)·{0.001..0.5} の log 等間隔で n_σn 点 +-- 4. 全 n_ℓ × n_σf × n_σn 点で log-mlik を評価し最良を取る +-- 5. 最良点周辺で 1/3 の幅で同点数のグリッドを再探索 (1 段の coarse-to-fine) +-- +-- デフォルトは (20, 8, 8) = 1280 点。 最終的に 2560 点 (再探索込)。 +-- n=200 までは数秒。 +-- [English]: Maximize the marginal likelihood by grid search over +-- @(ℓ, σ_f, σ_n)@. +-- +-- Strategy: +-- +-- 1. @ℓ@: n_ℓ log-evenly-spaced points centered on the median pairwise +-- distance +-- 2. @σ_f@: n_σf log-spaced points centered on std(y) +-- 3. @σ_n@: n_σn log-evenly-spaced points over std(y)·{0.001..0.5} +-- 4. Evaluate log-mlik at all n_ℓ × n_σf × n_σn points and take the best +-- 5. Re-search a grid of the same size within 1\/3 of the width around +-- the best point (one stage of coarse-to-fine) +-- +-- The default is (20, 8, 8) = 1280 points, 2560 points total (including +-- the re-search). Takes a few seconds up to n=200. +maximizeMarginalLikRBFMV + :: LA.Matrix Double + -> LA.Vector Double + -> Maybe (Int, Int, Int) -- ^ (n_ℓ, n_σf, n_σn). Default (20,8,8) + -> MLikResult +maximizeMarginalLikRBFMV x y mGrid = + let (nL, nSF, nSN) = case mGrid of + Just g -> g + Nothing -> (20, 8, 8) + yStd = sampleStd (LA.toList y) + ellM = max 1e-3 (medianPairwiseDist x) + sfM = max 1e-6 yStd + -- Stage 1: 広めグリッド + ellGrid1 = logSpace (ellM * 0.05) (ellM * 20) nL + sfGrid1 = logSpace (sfM * 0.25) (sfM * 4) nSF + snGrid1 = logSpace (yStd * 1e-3) (yStd * 0.5) nSN + stage1 = bestOver x y ellGrid1 sfGrid1 snGrid1 + -- Stage 2: 最良点周辺で 1/3 幅 + (ell1, sf1, sn1, _) = stage1 + ellGrid2 = logSpace (ell1 / 3) (ell1 * 3) nL + sfGrid2 = logSpace (sf1 / 2) (sf1 * 2) nSF + snGrid2 = logSpace (sn1 / 3) (sn1 * 3) nSN + stage2 = bestOver x y ellGrid2 sfGrid2 snGrid2 + (ell2, sf2, sn2, ml2) = stage2 + in MLikResult ell2 sf2 sn2 ml2 + (nL * nSF * nSN * 2) + +-- | [日本語]: 'maximizeMarginalLikRBFMV' の Differential-Evolution 版。 +-- +-- coarse stage を Differential Evolution +-- (`Hanalyze.Optim.DifferentialEvolution`) で行い、 fine stage は +-- 従来通りグリッド。 +-- +-- DE の探索空間は log 空間 (log_ℓ, log_σ_f, log_σ_n) の 3 次元。 評価予算は +-- generations 引数で制御 (典型 30-100 で集団 30、 合計 900-3000 評価)。 +-- グリッド版より広範囲を効率的に探索でき、 log-mlik の局所解にハマりにくい。 +-- [English]: Differential-Evolution variant of 'maximizeMarginalLikRBFMV'. +-- +-- The coarse stage uses Differential Evolution +-- (`Hanalyze.Optim.DifferentialEvolution`); the fine stage remains +-- grid-based as before. +-- +-- DE's search space is the 3-dimensional log space (log_ℓ, log_σ_f, +-- log_σ_n). The evaluation budget is controlled by the generations +-- argument (typically 30-100 with a population of 30, for a total of +-- 900-3000 evaluations). It searches a wider range more efficiently than +-- the grid version and is less prone to getting stuck in local optima of +-- log-mlik. +maximizeMarginalLikRBFMV_DE + :: LA.Matrix Double + -> LA.Vector Double + -> Int -- ^ DE generations + -> System.Random.MWC.GenIO + -> IO MLikResult +maximizeMarginalLikRBFMV_DE x y nGen gen = do + let yStd = sampleStd (LA.toList y) + ellM = max 1e-3 (medianPairwiseDist x) + sfM = max 1e-6 yStd + -- log 空間の bounds (元の logSpace 範囲と一致) + bounds = + [ (log (ellM * 0.05), log (ellM * 20)) -- log ℓ + , (log (sfM * 0.25), log (sfM * 4)) -- log σ_f + , (log (yStd * 1e-3), log (yStd * 0.5)) -- log σ_n + ] + -- 目的関数: log-mlik を最大化 → DE は最小化なので negate + obj [le, lsf, lsn] = negate (logMarginalLikRBFMV x y (exp le) (exp lsf) (exp lsn)) + obj _ = 1e30 + let cfg = (DEM.defaultDEConfig bounds) + { DEM.deStop = OCM.defaultStopCriteria { OCM.stMaxIter = nGen } } + r <- DEM.runDEWith cfg obj gen + let [le, lsf, lsn] = OCM.orBest r + ell0 = exp le + sf0 = exp lsf + sn0 = exp lsn + -- Stage 2 (fine grid) for refinement + ellGrid2 = logSpace (ell0 / 3) (ell0 * 3) 8 + sfGrid2 = logSpace (sf0 / 2) (sf0 * 2) 6 + snGrid2 = logSpace (sn0 / 3) (sn0 * 3) 6 + (ell2, sf2, sn2, ml2) = bestOver x y ellGrid2 sfGrid2 snGrid2 + totalEvals = OCM.orIters r * DEM.dePopSize cfg + 8 * 6 * 6 + return $ MLikResult ell2 sf2 sn2 ml2 totalEvals + +-- | Best @log p@ over the full Cartesian product of @(ellGrid, sfGrid, snGrid)@. +bestOver + :: LA.Matrix Double -> LA.Vector Double + -> [Double] -> [Double] -> [Double] + -> (Double, Double, Double, Double) +bestOver x y ells sfs sns = + let evaluations = + [ (ell, sf, sn, logMarginalLikRBFMV x y ell sf sn) + | ell <- ells, sf <- sfs, sn <- sns ] + best = foldr1 (\a@(_,_,_,la) b@(_,_,_,lb) -> + if la >= lb then a else b) evaluations + in best + +-- | Log-spaced @n@ points between @lo@ and @hi@. +logSpace :: Double -> Double -> Int -> [Double] +logSpace lo hi n + | n <= 1 = [lo] + | lo <= 0 = logSpace 1e-9 hi n -- 安全フォールバック + | otherwise = + let lLo = log lo + lHi = log hi + step = (lHi - lLo) / fromIntegral (n - 1) + in [ exp (lLo + fromIntegral i * step) | i <- [0 .. n - 1] ] + +-- | Median pairwise distance between rows (the standard median heuristic +-- for an RBF length scale). +-- | Rewritten to use BLAS gram matrix +-- ('KD.pairwiseSqDist') + 'Intro.sort' on a flat 'VS.Vector'. The previous +-- implementation built an @O(n²)@ list of pair distances with @rows !! i@ +-- (each @O(i)@) and ran a naive list quicksort, which exploded space to +-- @O(n²)@..@O(n³)@ thunks and OOM-killed WSL2 around @n=768@. +medianPairwiseDist :: LA.Matrix Double -> Double +medianPairwiseDist x = + let n = LA.rows x in + if n < 2 then 1.0 else + let d2 = KD.pairwiseSqDist x -- n × n via BLAS GEMM + d2f = LA.flatten d2 + m = n * (n - 1) `div` 2 + ds = runST $ do + v <- VSM.unsafeNew m + let go !k !i !j + | i >= n - 1 = pure () + | j >= n = go k (i + 1) (i + 2) + | otherwise = do + let s = VS.unsafeIndex d2f (i * n + j) + VSM.unsafeWrite v k (sqrt (max 0 s)) + go (k + 1) i (j + 1) + go 0 0 1 + Intro.sort v + VS.unsafeFreeze v + in if VS.null ds then 1.0 else VS.unsafeIndex ds (m `div` 2) + +sampleStd :: [Double] -> Double +sampleStd xs + | length xs <= 1 = 1.0 + | otherwise = + let n = fromIntegral (length xs) + m = sum xs / n + v = sum [ (x - m) * (x - m) | x <- xs ] / (n - 1) + in if v <= 0 then 1.0 else sqrt v + + +-- --------------------------------------------------------------------------- +-- LOOCV 解析解 (Phase 3 — Ridge の closed-form leave-one-out cross-validation) +-- --------------------------------------------------------------------------- + +-- | Result of LOOCV-based hyperparameter search. +data LOOCVResult = LOOCVResult + { lcEll :: !Double + , lcSigmaF :: !Double -- ^ [日本語]: 信号 sd (= std(y) を使う簡易版)。 [English]: Signal SD (a simplified version using std(y)). + , lcLambda :: !Double -- ^ [日本語]: Ridge 正則化。 [English]: Ridge regularization. + , lcLOOCV :: !Double -- ^ LOOCV(λ) = mean square LOO residual + , lcGridPts :: !Int + } deriving (Show) + +-- | [日本語]: Cholesky 分解とハット行列の対角を使った、 RFF ridge 回帰の +-- closed-form LOOCV。 +-- +-- H = Φ (ΦᵀΦ + λI)⁻¹ Φᵀ +-- ŷ = H y +-- LOOCV(λ) = (1/n) Σᵢ ((y_i - ŷ_i) / (1 - H_ii))² +-- +-- 本関数は与えられた特徴行列 @feats@ (= 既に ω/b/σ_f が決まったもの) と +-- Ridge λ に対して LOOCV を返す。 グリッドサーチ側ではこれを多数の λ で +-- 呼び出すが、 Φ は 1 度だけ計算すれば良いので外側でキャッシュする。 +-- [English]: Closed-form LOOCV for RFF ridge regression using a Cholesky +-- factorization plus the hat-matrix diagonal. +-- +-- H = Φ (ΦᵀΦ + λI)⁻¹ Φᵀ +-- ŷ = H y +-- LOOCV(λ) = (1/n) Σᵢ ((y_i - ŷ_i) / (1 - H_ii))² +-- +-- This function returns the LOOCV for a given feature matrix @feats@ +-- (with ω\/b\/σ_f already fixed) and Ridge λ. The grid-search side calls +-- this repeatedly for many λ values, so Φ only needs to be computed once +-- and is cached by the caller. +loocvRFFRidgeMV + :: RFFFeaturesMV + -> LA.Matrix Double -- ^ X (n × p) + -> LA.Vector Double -- ^ y (n) + -> Double -- ^ λ + -> Double +loocvRFFRidgeMV feats x y lam = + let phi = rffFeaturesMV feats x -- n × D + in loocvFromPhi phi y lam + +-- | [日本語]: Φ から LOOCV を計算する内部実装 (グリッドサーチでキャッシュ用)。 +-- Cholesky ベース (Φ_ridge = Φᵀ Φ + λI、 A = chol(Φ_ridge))。 +-- H = Φ Φ_ridge⁻¹ Φᵀ +-- T = Φ Φ_ridge⁻¹ → diag(H) = row-sum(T ⊙ Φ) +-- [English]: Internal implementation that computes the LOOCV from Φ +-- (for caching on the grid-search side). Cholesky-based +-- (Φ_ridge = Φᵀ Φ + λI, A = chol(Φ_ridge)). +-- H = Φ Φ_ridge⁻¹ Φᵀ +-- T = Φ Φ_ridge⁻¹ → diag(H) = row-sum(T ⊙ Φ) +loocvFromPhi :: LA.Matrix Double -> LA.Vector Double -> Double -> Double +loocvFromPhi phi y lam = + let n = LA.rows phi + d = LA.cols phi + gram = LA.tr phi LA.<> phi -- D × D + regK = gram + LA.scale lam (LA.ident d) + -- 解析解: w = regK⁻¹ Φᵀ y + w = regK LA.<\> (LA.tr phi LA.#> y) + yhat = phi LA.#> w + -- diag(H) = diag(Φ M Φᵀ) where M = regK⁻¹ + -- T = Φ M (n × D)。Φ M Φᵀ の対角 = row(T) · row(Φ) + tMat = LA.tr (regK LA.<\> LA.tr phi) -- T = Φ M、n × D + hDiag = LA.fromList + [ LA.dot (LA.flatten (tMat LA.? [i])) + (LA.flatten (phi LA.? [i])) + | i <- [0 .. n - 1] ] + -- 1 - H_ii の極小ガード + oneMinusH = LA.cmap (\h -> max 1e-12 (1 - h)) hDiag + resid = y - yhat + ratios = LA.toList resid `divList` LA.toList oneMinusH + sse = sum [ r * r | r <- ratios ] + in sse / fromIntegral (max 1 n) + where + divList xs ys = zipWith (/) xs ys + +-- | [日本語]: log 等間隔の @(ℓ, λ)@ グリッドを探索し、 最小の LOOCV を求める。 +-- +-- ℓ ごとに ω を新規サンプリングするため IO。 グリッドサイズ default (8, 20): +-- ℓ 8 点 × λ 20 点 = 160 fit。 各 fit O(n D + D³) で n=545, D=200 程度なら +-- 全体で数秒程度。 +-- +-- σ_f は std(y) 固定 (Ridge ↔ GP 等価では σ_f は ω 分散と一緒に動くべきだが、 +-- λ で吸収できるので簡易化)。 +-- [English]: Search a log-spaced @(ℓ, λ)@ grid for the smallest LOOCV. +-- +-- IO because @ω@ is resampled for each @ℓ@. Default grid size (8, 20): +-- 8 points for @ℓ@ × 20 points for @λ@ = 160 fits. With each fit costing +-- O(n D + D³), the whole search takes a few seconds for n=545, D=200 or +-- so. +-- +-- @σ_f@ is fixed to std(y) (under the Ridge ↔ GP equivalence, @σ_f@ +-- should ideally move together with the @ω@ variance, but it can be +-- absorbed by @λ@, so this is simplified). +gridSearchLOOCVRBFMV + :: Int -- ^ [日本語]: p (入力次元)。 [English]: p (input dimension). + -> Int -- ^ [日本語]: D (特徴次元)。 [English]: D (feature dimension). + -> LA.Matrix Double -- ^ X + -> LA.Vector Double -- ^ y + -> Maybe (Int, Int) -- ^ (n_ℓ, n_λ) default (8, 20) + -> GenIO + -> IO LOOCVResult +gridSearchLOOCVRBFMV p d x y mGrid gen = do + let (nL, nLam) = case mGrid of { Just g -> g; Nothing -> (8, 20) } + yStd = sampleStd (LA.toList y) + sf = max 1e-9 yStd + ellM = max 1e-3 (medianPairwiseDist x) + ellGrid = logSpace (ellM * 0.05) (ellM * 20) nL + lamGrid = logSpace (yStd * 1e-6) (yStd * 10) nLam + -- 各 ℓ について 1 度サンプリングしてから λ ループ + evals <- mapM (\ell -> do + feats <- sampleRFFRBFMV p d ell sf gen + let phi = rffFeaturesMV feats x + let scoresAtLam = [ (ell, sf, lam, loocvFromPhi phi y lam) + | lam <- lamGrid ] + return scoresAtLam) + ellGrid + let evaluations = concat evals + best = foldr1 (\a@(_,_,_,la) b@(_,_,_,lb) -> + if la <= lb then a else b) evaluations + (bEll, bSf, bLam, bL) = best + return LOOCVResult + { lcEll = bEll + , lcSigmaF = bSf + , lcLambda = bLam + , lcLOOCV = bL + , lcGridPts = nL * nLam + } + +-- | [日本語]: 'gridSearchLOOCVRBFMV' の Differential-Evolution 版。 +-- +-- (log_ℓ, log_λ) の 2 次元空間を Differential Evolution で探索。 +-- ω は ℓ ごとに新規サンプリング (RFF の特性上避けられない) のでコストは +-- グリッド版と同程度。 グリッドの離散性が問題になる場合に有効。 +-- [English]: Differential-Evolution variant of 'gridSearchLOOCVRBFMV'. +-- +-- Searches the 2-dimensional space (log_ℓ, log_λ) with Differential +-- Evolution. @ω@ is resampled for each @ℓ@ (unavoidable given RFF's +-- nature), so the cost is comparable to the grid version. Useful when +-- the discreteness of the grid is a problem. +gridSearchLOOCVRBFMV_DE + :: Int -- ^ [日本語]: p (入力次元)。 [English]: p (input dimension). + -> Int -- ^ [日本語]: D (特徴次元)。 [English]: D (feature dimension). + -> LA.Matrix Double -- ^ X + -> LA.Vector Double -- ^ y + -> Int -- ^ DE generations + -> System.Random.MWC.GenIO + -> IO LOOCVResult +gridSearchLOOCVRBFMV_DE p d x y nGen gen = do + let yStd = sampleStd (LA.toList y) + sf = max 1e-9 yStd + ellM = max 1e-3 (medianPairwiseDist x) + bounds = + [ (log (ellM * 0.05), log (ellM * 20)) -- log ℓ + , (log (yStd * 1e-6), log (yStd * 10)) -- log λ + ] + -- 目的関数: log-space で受けた (log_ell, log_lam) で LOOCV を返す。 + -- ω サンプリングは IO を含むため `unsafePerformIO` を使うが、決定的シードを + -- 内部で固定しないと毎回違う値が出る。簡略化のため: ℓ ごとに 1 度だけ + -- サンプリングしたかったが、純粋関数化のため IO Ref キャッシュは省略。 + -- 各 DE 評価で feats を再サンプル (ノイズが入るが、実用上は最終 best 周辺で + -- 十分平均化される)。 + -- + -- 評価をプリ計算: 候補集団のサイズ × generations 回 fresh sample。 + let cfg = (DEM.defaultDEConfig bounds) + { DEM.deStop = OCM.defaultStopCriteria { OCM.stMaxIter = nGen } } + -- ω サンプリング用の固定シード生成器を別途準備 + -- (DE 内のランダムは gen を共有、評価用の ω は新たに引く) + obj <- pure $ \[le, llam] -> + System.IO.Unsafe.unsafePerformIO $ do + let ell = exp le + lam = exp llam + feats <- sampleRFFRBFMV p d ell sf gen + let phi = rffFeaturesMV feats x + pure (loocvFromPhi phi y lam) + r <- DEM.runDEWith cfg obj gen + let [le, llam] = OCM.orBest r + bestEll = exp le + bestLam = exp llam + bestL = OCM.orValue r + return LOOCVResult + { lcEll = bestEll + , lcSigmaF = sf + , lcLambda = bestLam + , lcLOOCV = bestL + , lcGridPts = OCM.orIters r * DEM.dePopSize cfg + } + +-- | [日本語]: 'gridSearchLOOCVRBFMV' のベイズ最適化版 +-- (金子流: 初期点 + GP 代理モデル + 獲得関数で評価回数を削減)。 +-- +-- グリッドの 160 点 (8 ℓ × 20 λ) に対し、 既定 30 評価 (init 8 + iter 22) で +-- 同等の @(ℓ, λ)@ を (log ℓ, log λ) の 2 次元 BO ('BO.bayesOptND') で求める。 +-- +-- __RFF + BO の肝__: RFF の周波数 ω~N(0, 1/ℓ) はランダムなので、 同じ @(ℓ,λ)@ +-- でも引き直すと LOOCV が変わる (stochastic)。 BO は決定的目的関数を仮定する +-- ため、 ここでは __基底 ω₀~N(0,1) と bias b を 1 度だけ引いて固定__し、 ℓ +-- ごとに @ω = ω₀ / ℓ@ とスケールする。 これで LOOCV(ℓ,λ) は ℓ の決定的関数 +-- になり、 GP 代理が綺麗に乗る。 ℓ ごとに ω を引き直す grid \/ DE 版 (上記) より +-- MC ノイズが小さく __むしろ安定__。 D を上げるほど RFF の分散は減る。 +-- [English]: Bayesian-optimization variant of 'gridSearchLOOCVRBFMV' +-- (Kaneko-style: reduces the number of evaluations with initial points + +-- a GP surrogate model + an acquisition function). +-- +-- For the 160-point grid (8 @ℓ@ × 20 @λ@), the equivalent @(ℓ, λ)@ is +-- found with a default of 30 evaluations (init 8 + iter 22) via a +-- 2-dimensional BO over (log ℓ, log λ) ('BO.bayesOptND'). +-- +-- __The key to RFF + BO__: because the RFF frequencies ω~N(0, 1/ℓ) are +-- random, resampling changes the LOOCV even for the same @(ℓ,λ)@ +-- (stochastic). Since BO assumes a deterministic objective function, +-- here the __base ω₀~N(0,1) and bias b are drawn once and fixed__, and +-- scaled per @ℓ@ as @ω = ω₀ / ℓ@. This makes LOOCV(ℓ,λ) a deterministic +-- function of @ℓ@, letting the GP surrogate fit cleanly. This has less +-- MC noise — __in fact it is more stable__ — than the grid \/ DE +-- versions above that resample @ω@ per @ℓ@. The larger @D@ is, the +-- smaller the RFF variance becomes. +bayesOptLOOCVRBFMV + :: Int -- ^ [日本語]: p (入力次元)。 [English]: p (input dimension). + -> Int -- ^ [日本語]: D (特徴次元)。 [English]: D (feature dimension). + -> LA.Matrix Double -- ^ X + -> LA.Vector Double -- ^ y + -> Maybe (Int, Int) -- ^ [日本語]: (initPoints, iterations) default (8, 22) = 30 評価。 [English]: (initPoints, iterations), default (8, 22) = 30 evaluations. + -> System.Random.MWC.GenIO + -> IO LOOCVResult +bayesOptLOOCVRBFMV p d x y mBudget gen = do + let (nInit, nIter) = case mBudget of { Just b -> b; Nothing -> (8, 22) } + yStd = sampleStd (LA.toList y) + sf = max 1e-9 yStd + ellM = max 1e-3 (medianPairwiseDist x) + bounds = + [ (log (ellM * 0.05), log (ellM * 20)) -- log ℓ + , (log (yStd * 1e-6), log (yStd * 10)) -- log λ + ] + -- 基底周波数 ω₀~N(0,1) + bias b を 1 度だけ引いて固定 (= 決定的目的関数化)。 + ws0 <- V.replicateM (p * d) (MWCD.normal 0 1 gen) + bs <- V.replicateM d (uniformR (0, 2 * pi) gen) + let omega0 = LA.reshape d (LA.fromList (V.toList ws0)) -- p × d (ℓ=1 相当) + featsAt ell = + RFFFeaturesMV + { rffmvKernel = RFFRBF + , rffmvDim = p + , rffmvOmegas = LA.scale (1 / ell) omega0 -- ω = ω₀ / ℓ + , rffmvBs = bs + , rffmvSigmaF = sf + , rffmvLengthScale = ell + } + objective [le, llam] = + let ell = exp le + lam = exp llam + phi = rffFeaturesMV (featsAt ell) x + in pure (loocvFromPhi phi y lam) + objective _ = pure (1 / 0) -- 次元不一致は +∞ (起き得ないが total に) + cfg = BO.defaultBayesOptConfig + { BO.boInitPoints = nInit, BO.boIterations = nIter } + (_history, (bestXs, bestL)) <- BO.bayesOptND cfg 8 objective bounds gen + let (bestEll, bestLam) = case bestXs of + (le : llam : _) -> (exp le, exp llam) + _ -> (ellM, yStd * 1e-3) + return LOOCVResult + { lcEll = max 1e-6 bestEll + , lcSigmaF = sf + , lcLambda = max 1e-8 bestLam + , lcLOOCV = bestL + , lcGridPts = nInit + nIter + } + +-- | [日本語]: 'gridSearchLOOCVRBFMV' の L-BFGS 版 (固定基底 + 数値勾配 L-BFGS の +-- 多始点)。 +-- +-- 'bayesOptLOOCVRBFMV' と同じく __基底 ω₀~N(0,1) を 1 度引いて固定__し ℓ で +-- スケールすることで LOOCV(log ℓ, log λ) を決定的・微分可能化し、 数値勾配 +-- L-BFGS ('LBFGS.runLBFGSNumeric'、 GP の @optimizeGP@ と同じ engine) を複数 +-- 始点から回して LOOCV 最小を採る。 GP の多始点 L-BFGS の RFF 版で、 評価は +-- O(D³) なので大 n でもスケーラブル (厳密 GP marginal likelihood の O(n³) を +-- 回避)。 grid の離散性も BO の粗いサロゲートも避け、 連続最適化で (ℓ,λ) を +-- 精密に当てる。 +-- [English]: L-BFGS variant of 'gridSearchLOOCVRBFMV' (fixed basis + +-- multi-start numerical-gradient L-BFGS). +-- +-- As with 'bayesOptLOOCVRBFMV', __the base ω₀~N(0,1) is drawn once and fixed__, +-- then scaled by ℓ, making LOOCV(log ℓ, log λ) deterministic and +-- differentiable. Numerical-gradient L-BFGS +-- ('LBFGS.runLBFGSNumeric', the same engine as GP's @optimizeGP@) is run +-- from multiple starting points to find the LOOCV minimum. This is the +-- RFF analogue of GP's multi-start L-BFGS; evaluation is O(D³), so it +-- scales even for large n (avoiding the O(n³) of the exact GP marginal +-- likelihood). It avoids both grid discreteness and BO's coarse +-- surrogate, pinpointing @(ℓ,λ)@ via continuous optimization. +lbfgsLOOCVRBFMV + :: Int -- ^ [日本語]: p (入力次元)。 [English]: p (input dimension). + -> Int -- ^ [日本語]: D (特徴次元)。 [English]: D (feature dimension). + -> LA.Matrix Double -- ^ X + -> LA.Vector Double -- ^ y + -> Maybe Int -- ^ [日本語]: multi-start 数 (default 4)。 [English]: Number of multi-starts (default 4). + -> System.Random.MWC.GenIO + -> IO LOOCVResult +lbfgsLOOCVRBFMV p d x y mStarts gen = do + let nStarts = max 1 (case mStarts of { Just n -> n; Nothing -> 3 }) + yStd = sampleStd (LA.toList y) + sf = max 1e-9 yStd + ellM = max 1e-3 (medianPairwiseDist x) + logEll0 = log ellM + logLam0 = log (max 1e-12 (yStd * 1e-3)) + -- 基底 ω₀ + bias を 1 度だけ引いて固定 (= 決定的・微分可能化)。 + ws0 <- V.replicateM (p * d) (MWCD.normal 0 1 gen) + bs <- V.replicateM d (uniformR (0, 2 * pi) gen) + let omega0 = LA.reshape d (LA.fromList (V.toList ws0)) + featsAt ell = + RFFFeaturesMV + { rffmvKernel = RFFRBF + , rffmvDim = p + , rffmvOmegas = LA.scale (1 / ell) omega0 + , rffmvBs = bs + , rffmvSigmaF = sf + , rffmvLengthScale = ell + } + -- LOOCV (最小化対象、 lbDir 既定 = Minimize)。 + obj [le, llam] = loocvFromPhi (rffFeaturesMV (featsAt (exp le)) x) y (exp llam) + obj _ = 1 / 0 + -- 2D 目的なので maxIter は控えめで十分収束 (数値勾配が高 D で高コストなため + -- 評価数を抑える)。 multi-start で局所性をカバー。 + cfg = LBFGS.defaultLBFGSConfig + { LBFGS.lbStop = OCM.defaultStopCriteria + { OCM.stMaxIter = 40, OCM.stTolFun = 1e-8 } } + -- 多始点: base + (nStarts-1) ランダム摂動 (log 空間 正規)。 + perturbs <- mapM (\_ -> do + ze <- MWCD.normal 0 1.5 gen + zl <- MWCD.normal 0 2.0 gen + pure [logEll0 + ze, logLam0 + zl]) + [1 .. nStarts - 1] + results <- mapM (LBFGS.runLBFGSNumeric cfg obj) ([logEll0, logLam0] : perturbs) + let isFin v = not (isNaN v || isInfinite v) + scored = [ (OCM.orBest r, OCM.orValue r) | r <- results, isFin (OCM.orValue r) ] + (bestX, bestVal) = case scored of + [] -> ([logEll0, logLam0], obj [logEll0, logLam0]) + _ -> foldr1 (\a b -> if snd a <= snd b then a else b) scored + (bLe, bLlam) = case bestX of + (a : b : _) -> (a, b) + _ -> (logEll0, logLam0) + return LOOCVResult + { lcEll = max 1e-6 (exp bLe) + , lcSigmaF = sf + , lcLambda = max 1e-8 (exp bLlam) + , lcLOOCV = bestVal + , lcGridPts = nStarts + } diff --git a/src/Hanalyze/Model/RandomForest.hs b/src/Hanalyze/Model/RandomForest.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/RandomForest.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.RandomForest +-- Description : 回帰用 Random Forest (CART + bagging + random feature subset、行インデックス置換方式) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Random forest for regression (CART + bagging + random feature subset). +-- +-- /Performance/: this module was ported in B9b from a list-based +-- implementation to a row-index permutation scheme, mirroring the +-- 'Hanalyze.Model.DecisionTree' refactor: +-- +-- * Single shared @LA.Matrix Double@ feature matrix. +-- * @VU.Vector Int@ row indices recurse through subtrees. +-- * Per-feature best split via 'Data.Vector.Algorithms.Intro' sort +-- and incremental sum / sum-of-squares sweep. +-- * Bootstrap = random index Vector (no row data copied). +-- +-- The classic 'fitRF' over @[[Double]] / [Double]@ is preserved as a +-- backwards-compatibility wrapper that calls 'fitRFV'. +module Hanalyze.Model.RandomForest + ( -- * Single regression tree + Tree (..) + , RFConfig (..) + , defaultRandomForest + , buildTree + , buildTreeV + , predictTree + -- * Forest + , RandomForest (..) + , fitRF + , fitRFV + , fitRFPure + , fitRFVPure + , predictRF + , featureImportance + , rfPermutationImportance + , defaultFeatureNames + ) where + +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import qualified Data.Vector.Algorithms.Intro as Intro +import qualified Numeric.LinearAlgebra as LA +import qualified System.Random.MWC as MWC +import Control.Monad (replicateM) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.ST (runST) +import Data.Word (Word32) +import Data.Text (Text) +import qualified Data.Text as T + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +-- | A regression tree node. +data Tree + = Leaf !Double + | Node !Int !Double !Tree !Tree + deriving (Show) + +-- | Random-forest configuration. +data RFConfig = RFConfig + { rfTrees :: !Int + , rfMaxDepth :: !Int + , rfMinSamples :: !Int + , rfMtry :: !(Maybe Int) + , rfBootstrap :: !Bool + } deriving (Show) + +defaultRandomForest :: RFConfig +defaultRandomForest = RFConfig + { rfTrees = 100 + , rfMaxDepth = 12 + , rfMinSamples = 3 + , rfMtry = Nothing + , rfBootstrap = True + } + +data RandomForest = RandomForest + { rfTreesV :: ![Tree] + , rfNFeatures :: !Int + , rfImportance :: !(V.Vector Double) -- ^ [日本語]: impurity/split ベース (MDI 相当・R IncNodePurity)。 [English]: Impurity\/split-based importance (equivalent to MDI; R's IncNodePurity). + , rfPermImportance :: !(V.Vector Double) -- ^ [日本語]: permutation ベース (MSE 増加・R %IncMSE・sklearn permutation_importance)。 [English]: Permutation-based importance (MSE increase; R's %IncMSE, sklearn's permutation_importance). + , rfFeatureNames :: ![Text] -- ^ [日本語]: 特徴列名。 df|-> 経路が実列名を設定、 低レベル行列 fit は 'defaultFeatureNames' ("f1"..)。 [English]: Feature column names. The df|-> path sets the real column names; low-level matrix fits use 'defaultFeatureNames' ("f1"..). + } deriving (Show) + +-- | [日本語]: 名前を持たない行列入力の既定特徴名 ("f1", "f2", …・1 始まり = R/sklearn 慣例)。 +-- [English]: Default feature names for unnamed matrix input ("f1", "f2", +-- …; 1-indexed, following R\/sklearn convention). +defaultFeatureNames :: Int -> [Text] +defaultFeatureNames d = [ "f" <> T.pack (show k) | k <- [1 .. d] ] + +-- --------------------------------------------------------------------------- +-- Vector-based fit (primary) +-- --------------------------------------------------------------------------- + +-- | [日本語]: IO ラッパ。 ロジックは 'PrimMonad' 汎用の 'fitRFVM' を共有 +-- (mwc は 'PrimMonad' 汎用ゆえ ST/IO 両経路で同コード)。 +-- [English]: An IO wrapper. The logic is shared with the 'PrimMonad'-generic +-- 'fitRFVM' (since mwc is 'PrimMonad'-generic, both the ST and IO paths +-- share the same code). +fitRFV :: RFConfig + -> LA.Matrix Double + -> VU.Vector Double + -> MWC.GenIO + -> IO RandomForest +fitRFV = fitRFVM + +-- | [日本語]: 'PrimMonad' 汎用の forest 本体。 'fitRFV' (IO) / @fitRFVPure@ (ST) が共有。 +-- 乱数 (gen) は bootstrap index のみで使う。 木構築 'buildTreeV' と feature +-- importance は純粋ゆえ ST/IO でビット同一。 +-- [English]: The 'PrimMonad'-generic forest core, shared by 'fitRFV' (IO) +-- and @fitRFVPure@ (ST). The random generator (gen) is used only for the +-- bootstrap index. Tree building ('buildTreeV') and feature importance are +-- pure, so ST and IO give bit-identical results. +fitRFVM :: PrimMonad m + => RFConfig + -> LA.Matrix Double + -> VU.Vector Double + -> MWC.Gen (PrimState m) + -> m RandomForest +fitRFVM cfg x y gen = do + let !n = VU.length y + !d = LA.cols x + trees <- replicateM (rfTrees cfg) $ do + !idx <- if rfBootstrap cfg + then bootstrapIdxM n gen + else pure (VU.enumFromN 0 n) + pure $! buildTreeV cfg x y idx 0 + -- permutation importance は列シャッフルに gen を使う (bootstrap の後・seed 決定的)。 + !perm <- permImportanceRegM x y trees gen + pure RandomForest + { rfTreesV = trees + , rfNFeatures = d + , rfImportance = importanceOf d trees + , rfPermImportance = perm + , rfFeatureNames = defaultFeatureNames d + } + +-- | Backwards-compatible list-based fit. +fitRF :: RFConfig -> [[Double]] -> [Double] -> MWC.GenIO -> IO RandomForest +fitRF cfg xs ys gen + | null xs = pure emptyForest + | otherwise = fitRFV cfg (LA.fromLists xs) (VU.fromList ys) gen + +-- | [日本語]: 純粋・決定的な行列入力 forest。 同じ @seed@ なら必ず同じ 'RandomForest'。 +-- 'fitRFVM' を @ST@ で走らせ 'runST' で閉じる +-- ([[phase-50-mcmc-purification-status]] の @nutsPure@ と同方針)。 +-- [English]: A pure, deterministic matrix-input forest. The same @seed@ +-- always yields the same 'RandomForest'. Runs 'fitRFVM' in @ST@ and closes +-- it with 'runST' (the same approach as @nutsPure@ in +-- [[phase-50-mcmc-purification-status]]). +fitRFVPure :: RFConfig + -> LA.Matrix Double + -> VU.Vector Double + -> Word32 + -> RandomForest +fitRFVPure cfg x y seed = + runST (MWC.initialize (V.singleton seed) >>= fitRFVM cfg x y) + +-- | [日本語]: 純粋・決定的な list 入力 forest (list 版 'fitRF' の seed 純粋版)。 +-- [English]: A pure, deterministic list-input forest (the seed-pure +-- version of the list-based 'fitRF'). +fitRFPure :: RFConfig -> [[Double]] -> [Double] -> Word32 -> RandomForest +fitRFPure cfg xs ys seed + | null xs = emptyForest + | otherwise = fitRFVPure cfg (LA.fromLists xs) (VU.fromList ys) seed + +-- | [日本語]: 空データ時の forest (全フィールド空)。 +-- [English]: The forest for empty data (all fields empty). +emptyForest :: RandomForest +emptyForest = RandomForest [] 0 V.empty V.empty [] + +-- | Single-tree builder kept for the symmetry of the old API. Most +-- callers should use 'fitRFV'. +buildTree :: RFConfig -> [[Double]] -> [Double] -> MWC.GenIO -> IO Tree +buildTree cfg rows ys gen + | null rows = pure (Leaf 0) + | otherwise = do + let !x = LA.fromLists rows + !y = VU.fromList ys + !n = VU.length y + idx <- if rfBootstrap cfg + then bootstrapIdxM n gen + else pure (VU.enumFromN 0 n) + pure (buildTreeV cfg x y idx 0) + +bootstrapIdxM :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m (VU.Vector Int) +bootstrapIdxM n gen = + VU.replicateM n (MWC.uniformR (0, n - 1) gen) + +-- --------------------------------------------------------------------------- +-- Recursive build +-- --------------------------------------------------------------------------- + +buildTreeV :: RFConfig + -> LA.Matrix Double + -> VU.Vector Double + -> VU.Vector Int + -> Int + -> Tree +buildTreeV cfg x y idx depth = + let !n = VU.length idx + !subY = VU.map (y VU.!) idx + !meanY = if n == 0 then 0 + else VU.sum subY / fromIntegral n + !varY = varianceUS subY + in if n <= rfMinSamples cfg + || depth >= rfMaxDepth cfg + || varY < 1e-12 + then Leaf meanY + else + let !d = LA.cols x + !mtry = case rfMtry cfg of + Just m -> max 1 (min d m) + Nothing -> max 1 (d `div` 3) + !featIxs = pickFeats d mtry depth n + !mBest = bestSplitVRF featIxs x y idx + in case mBest of + Nothing -> Leaf meanY + Just (j, thr, _) -> + let (lIdx, rIdx) = partitionByFeat x idx j thr + in if VU.null lIdx || VU.null rIdx + then Leaf meanY + else Node j thr + (buildTreeV cfg x y lIdx (depth + 1)) + (buildTreeV cfg x y rIdx (depth + 1)) + +-- | Deterministic pseudo-random feature subset using an LCG seeded by +-- @(depth, n)@. Different nodes typically see different subsets, +-- which is the decorrelation that random forests need at split time. +-- Tree-level randomness comes from @bootstrapIdx@, which threads +-- through 'MWC.GenIO'. +pickFeats :: Int -> Int -> Int -> Int -> VU.Vector Int +pickFeats d mtry depth n + | mtry >= d = VU.enumFromN 0 d + | otherwise = + let seed0 = depth * 1009 + n * 31 + 1 + step !s = (s * 1103515245 + 12345) `mod` (2 ^ (31 :: Int)) + go !s !chosen !left + | left == 0 = chosen + | otherwise = + let !s' = step s + !i = s' `mod` d + in if i `VU.elem` chosen + then go s' chosen left + else go s' (chosen `VU.snoc` i) (left - 1) + in go seed0 VU.empty mtry + +partitionByFeat :: LA.Matrix Double + -> VU.Vector Int + -> Int + -> Double + -> (VU.Vector Int, VU.Vector Int) +partitionByFeat x idx feat thr = + let pred_ i = LA.atIndex x (i, feat) <= thr + in VU.partition pred_ idx + +-- --------------------------------------------------------------------------- +-- Best split +-- --------------------------------------------------------------------------- + +bestSplitVRF :: VU.Vector Int + -> LA.Matrix Double + -> VU.Vector Double + -> VU.Vector Int + -> Maybe (Int, Double, Double) +bestSplitVRF featIxs x y idx + | VU.length idx < 2 = Nothing + | otherwise = + let go best j = + case bestSplitFeatureRF x y idx j of + Nothing -> best + Just (thr, g) -> + case best of + Nothing -> Just (j, thr, g) + Just (_, _, gPrev) | g > gPrev -> Just (j, thr, g) + | otherwise -> best + in VU.foldl' go Nothing featIxs + +-- | Per-feature best split for regression: maximise variance reduction +-- via single sort + linear sweep with running sum / sum-of-squares. +bestSplitFeatureRF :: LA.Matrix Double + -> VU.Vector Double + -> VU.Vector Int + -> Int + -> Maybe (Double, Double) +bestSplitFeatureRF x y idx feat = runST $ do + let !n = VU.length idx + pairs <- VUM.new n + let valOf i = LA.atIndex x (i, feat) + yOf i = y VU.! i + fill !k + | k == n = pure () + | otherwise = do + let !i = VU.unsafeIndex idx k + VUM.unsafeWrite pairs k (valOf i, yOf i) + fill (k + 1) + fill 0 + Intro.sortBy (\a b -> compare (fst a) (fst b)) pairs + pairsF <- VU.unsafeFreeze pairs + + let !sumY = VU.sum (VU.map snd pairsF) + !sumY2 = VU.sum (VU.map (\(_, v) -> v * v) pairsF) + !nD = fromIntegral n :: Double + !parentSS = sumY2 - sumY * sumY / nD + + let sweep !k !sumYL !sumY2L !bestThr !bestGain + | k >= n - 1 = pure (bestThr, bestGain) + | otherwise = do + let (v_k, yk) = VU.unsafeIndex pairsF k + (v_k1, _) = VU.unsafeIndex pairsF (k + 1) + !sumYL' = sumYL + yk + !sumY2L' = sumY2L + yk * yk + if v_k == v_k1 + then sweep (k + 1) sumYL' sumY2L' bestThr bestGain + else do + let !nL = fromIntegral (k + 1) :: Double + !nR = nD - nL + !sumYR = sumY - sumYL' + !sumY2R = sumY2 - sumY2L' + !ssL = sumY2L' - sumYL' * sumYL' / nL + !ssR = sumY2R - sumYR * sumYR / nR + !gain = parentSS - ssL - ssR + !thr = (v_k + v_k1) / 2 + if gain > bestGain + then sweep (k + 1) sumYL' sumY2L' thr gain + else sweep (k + 1) sumYL' sumY2L' bestThr bestGain + (thr, gain) <- sweep 0 0 0 0 (negate (1.0 / 0.0)) + pure $ if gain == negate (1.0 / 0.0) + then Nothing + else Just (thr, gain) + +-- --------------------------------------------------------------------------- +-- Variance helper +-- --------------------------------------------------------------------------- + +varianceUS :: VU.Vector Double -> Double +varianceUS v + | VU.length v <= 1 = 0 + | otherwise = + let !n = fromIntegral (VU.length v) :: Double + !mu = VU.sum v / n + in VU.foldl' (\acc x -> acc + (x - mu) ^ (2 :: Int)) 0 v / n + +-- --------------------------------------------------------------------------- +-- Predict +-- --------------------------------------------------------------------------- + +predictTree :: Tree -> [Double] -> Double +predictTree (Leaf v) _ = v +predictTree (Node j thr l r) xs = + if (xs !! j) <= thr then predictTree l xs else predictTree r xs + +predictRF :: RandomForest -> [Double] -> Double +predictRF rf xs = + let preds = map (`predictTree` xs) (rfTreesV rf) + n = length preds + in if n == 0 then 0 else sum preds / fromIntegral n + +featureImportance :: RandomForest -> V.Vector Double +featureImportance rf = + let raw = rfImportance rf + tot = V.sum raw + in if tot <= 0 then raw else V.map (/ tot) raw + +-- | [日本語]: Permutation importance (= 列を無作為置換したときの MSE 増加) を正の総和で +-- 正規化して返す。 全て非正なら raw のまま (負 = その特徴が予測に無寄与)。 +-- R @randomForest %IncMSE@ / sklearn @permutation_importance@ 同方式。 +-- [English]: Returns permutation importance (= the MSE increase when a +-- column is randomly permuted), normalized by the sum of the positive +-- values. If all values are non-positive, returns the raw values unchanged +-- (negative = that feature contributes nothing to prediction). The same +-- method as R's @randomForest %IncMSE@ \/ sklearn's +-- @permutation_importance@. +rfPermutationImportance :: RandomForest -> V.Vector Double +rfPermutationImportance rf = + let raw = rfPermImportance rf + tot = V.sum (V.filter (> 0) raw) + in if tot <= 0 then raw else V.map (/ tot) raw + +-- --------------------------------------------------------------------------- +-- Permutation importance (MSE 増加ベース) +-- --------------------------------------------------------------------------- + +-- | [日本語]: 各特徴列を無作為置換し、 forest の MSE 増加量を測る (純粋・'PrimMonad')。 +-- gen は列シャッフルにのみ使う。 同 seed → ビット同一。 +-- [English]: Randomly permutes each feature column and measures the +-- forest's MSE increase (pure, 'PrimMonad'-generic). gen is used only for +-- column shuffling; the same seed gives bit-identical results. +permImportanceRegM :: PrimMonad m + => LA.Matrix Double -> VU.Vector Double -> [Tree] + -> MWC.Gen (PrimState m) -> m (V.Vector Double) +permImportanceRegM x y trees gen + | LA.rows x == 0 || null trees = pure (V.replicate (LA.cols x) 0) + | otherwise = do + let !base = forestMSE x y trees + scores <- mapM (\j -> do + xp <- permuteColM j x gen + pure $! forestMSE xp y trees - base) + [0 .. LA.cols x - 1] + pure (V.fromList scores) + +-- | [日本語]: forest の平均二乗誤差 (行毎に木予測を平均)。 +-- [English]: The forest's mean squared error (averages the per-tree +-- predictions per row). +forestMSE :: LA.Matrix Double -> VU.Vector Double -> [Tree] -> Double +forestMSE x y trees = + let !n = LA.rows x + !k = length trees + rowPred i = + let row = LA.toList (LA.flatten (x LA.? [i])) + preds = map (`predictTree` row) trees + in if k == 0 then 0 else sum preds / fromIntegral k + sse = sum [ (rowPred i - y VU.! i) ^ (2 :: Int) | i <- [0 .. n - 1] ] + in if n == 0 then 0 else sse / fromIntegral n + +-- | [日本語]: 列 j を Fisher-Yates で置換した行列を返す (他列は不変)。 +-- [English]: Returns the matrix with column j permuted via Fisher-Yates +-- (the other columns are unchanged). +permuteColM :: PrimMonad m + => Int -> LA.Matrix Double -> MWC.Gen (PrimState m) -> m (LA.Matrix Double) +permuteColM j x gen = do + let cols0 = LA.toColumns x + colj = VU.fromList (LA.toList (cols0 !! j)) + shuf <- fisherYatesM gen colj + let newCols = [ if kk == j then LA.fromList (VU.toList shuf) else cols0 !! kk + | kk <- [0 .. length cols0 - 1] ] + pure (LA.fromColumns newCols) + +-- | [日本語]: 可変ベクトル上の Fisher-Yates シャッフル ('PrimMonad'・gen 決定的)。 +-- [English]: A Fisher-Yates shuffle over a mutable vector ('PrimMonad' +-- -generic; deterministic given gen). +fisherYatesM :: PrimMonad m + => MWC.Gen (PrimState m) -> VU.Vector Double -> m (VU.Vector Double) +fisherYatesM gen v0 = do + mv <- VU.thaw v0 + let go i | i <= 0 = pure () + | otherwise = do + j <- MWC.uniformR (0, i) gen + VUM.swap mv i j + go (i - 1) + go (VUM.length mv - 1) + VU.freeze mv + +-- --------------------------------------------------------------------------- +-- Importance accumulation (per split, simple count) +-- --------------------------------------------------------------------------- + +-- | [日本語]: 全木の split 特徴を 1 回の可変ベクトル走査で集計 (純粋)。 旧 @IORef@ +-- 版を 'runST' + 可変ベクトルへ置換 (count の和は可換ゆえ木順不問で同値)。 +-- [English]: Tallies the split features across all trees in a single +-- mutable-vector pass (pure). Replaces the old @IORef@-based version with +-- 'runST' + a mutable vector (since summing counts is commutative, this is +-- equivalent regardless of tree order). +importanceOf :: Int -> [Tree] -> V.Vector Double +importanceOf d trees = runST $ do + v <- VM.replicate d 0.0 + let walk (Leaf _) = pure () + walk (Node j _ l r) = do + VM.modify v (+ 1.0) j + walk l + walk r + mapM_ walk trees + V.freeze v diff --git a/src/Hanalyze/Model/RandomForestClassifier.hs b/src/Hanalyze/Model/RandomForestClassifier.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/RandomForestClassifier.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.RandomForestClassifier +-- Description : Random Forest 分類版 — DecisionTree の bootstrap aggregation + OOB error + permutation importance +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Random Forest __分類版__。 +-- +-- bootstrap aggregation of 'Hanalyze.Model.DecisionTree' (CART 分類)。 +-- OOB (Out-of-Bag) error と permutation importance を併せて返す。 +-- +-- [English]: Random Forest, __classification version__. +-- +-- Bootstrap aggregation of 'Hanalyze.Model.DecisionTree' (CART +-- classification). Also returns OOB (Out-of-Bag) error and permutation +-- importance. +module Hanalyze.Model.RandomForestClassifier + ( RFCConfig (..) + , defaultRFCConfig + , RFClassifierFit (..) + , fitRFClassifier + , fitRFClassifierPure + , predictRFClassifier + ) where + +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Numeric.LinearAlgebra as LA +import qualified Data.Map.Strict as Map +import Data.List (nub, sort, group, sortBy, foldl') +import Data.Ord (comparing, Down (..)) +import Data.Text (Text) +import Data.Word (Word32) +import qualified System.Random.MWC as MWC +import Control.Monad (forM, replicateM) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.ST (runST) + +import qualified Hanalyze.Model.DecisionTree as DT +import Hanalyze.Model.RandomForest (defaultFeatureNames) + +-- =========================================================================== +-- 型 +-- =========================================================================== + +data RFCConfig = RFCConfig + { rfcNTrees :: !Int + , rfcMaxDepth :: !(Maybe Int) + , rfcMinSplit :: !Int + } deriving (Show) + +defaultRFCConfig :: RFCConfig +defaultRFCConfig = RFCConfig + { rfcNTrees = 100 + , rfcMaxDepth = Just 10 + , rfcMinSplit = 2 + } + +data RFClassifierFit = RFClassifierFit + { rfcTrees :: ![DT.DTree] + , rfcOOBSamples :: ![[Int]] + , rfcClasses :: ![Int] + , rfcOOBError :: !Double + , rfcImportance :: !(LA.Vector Double) -- ^ [日本語]: permutation importance (OOB accuracy 低下)。 [English]: Permutation importance (drop in OOB accuracy). + , rfcGiniImportance :: !(LA.Vector Double) -- ^ [日本語]: MDI (mean decrease in gini・木構造から純粋計算・sklearn feature_importances_ 同方式)。 [English]: MDI (mean decrease in Gini; computed purely from the tree structure; same approach as sklearn's feature_importances_). + , rfcFeatureNames :: ![Text] -- ^ [日本語]: 特徴列名。 行列 fit は 'defaultFeatureNames' ("f1"..)。 実列名は df|-> 化 (後続) で。 [English]: Feature column names. Matrix fits use 'defaultFeatureNames' ("f1"..); real column names come via df|-> integration (subsequent work). + , rfcConfig :: !RFCConfig + } deriving (Show) + +-- =========================================================================== +-- fit +-- =========================================================================== + +-- | [日本語]: IO ラッパ。 ロジックは 'PrimMonad' 汎用の 'fitRFClassifierM' を共有。 +-- [English]: An IO wrapper. Shares its logic with the 'PrimMonad'-generic 'fitRFClassifierM'. +fitRFClassifier + :: RFCConfig + -> LA.Matrix Double + -> VU.Vector Int + -> MWC.GenIO + -> IO RFClassifierFit +fitRFClassifier = fitRFClassifierM + +-- | [日本語]: 純粋・決定的な forest 分類器 (同 @seed@ → ビット同一)。 回帰の @fitRFVPure@ と同方針 +-- ([[phase-50-mcmc-purification-status]])。 df|-> ('Fit RFCSpec') 経路が使う。 +-- [English]: A pure, deterministic forest classifier (same @seed@ → +-- bit-identical). Follows the same policy as the regression +-- @fitRFVPure@ ([[phase-50-mcmc-purification-status]]). Used by the +-- df|-> ('Fit RFCSpec') path. +fitRFClassifierPure + :: RFCConfig -> LA.Matrix Double -> VU.Vector Int -> Word32 -> RFClassifierFit +fitRFClassifierPure cfg x y seed = + runST (MWC.initialize (V.singleton seed) >>= fitRFClassifierM cfg x y) + +-- | [日本語]: 'PrimMonad' 汎用の forest 分類器本体。 gen は bootstrap index と permutation の +-- 列シャッフルにのみ使う (木構築・OOB・gini は純粋ゆえ ST/IO でビット同一)。 +-- [English]: The 'PrimMonad'-generic forest classifier body. @gen@ is +-- used only for bootstrap indices and permutation column shuffling +-- (tree construction, OOB, and Gini are pure, so ST\/IO give bit-identical results). +fitRFClassifierM + :: PrimMonad m + => RFCConfig + -> LA.Matrix Double + -> VU.Vector Int + -> MWC.Gen (PrimState m) + -> m RFClassifierFit +fitRFClassifierM cfg x y gen = do + let n = LA.rows x + p = LA.cols x + classes = sort (nub (VU.toList y)) + dtCfg = DT.defaultDecisionTree + { DT.dtMaxDepth = rfcMaxDepth cfg + , DT.dtMinSamplesSplit = rfcMinSplit cfg + } + results <- forM [1 .. rfcNTrees cfg] $ \_ -> do + idxs <- replicateM n (MWC.uniformR (0, n - 1) gen) + let x' = x LA.? idxs + y' = VU.fromList [ y VU.! i | i <- idxs ] + tree = DT.fitDTV dtCfg x' y' + oob = filter (`notElem` idxs) [0 .. n - 1] + pure (tree, oob) + let trees = [ t | (t, _) <- results ] + oobLists = [ o | (_, o) <- results ] + oobErr = computeOOB x y trees oobLists + -- permutation importance: fixed-seed gen for reproducibility per feature + imp <- permImportance gen x y trees + pure RFClassifierFit + { rfcTrees = trees + , rfcOOBSamples = oobLists + , rfcClasses = classes + , rfcOOBError = oobErr + , rfcImportance = imp + , rfcGiniImportance = giniImportance p trees + , rfcFeatureNames = defaultFeatureNames p + , rfcConfig = cfg + } + +-- | [日本語]: 各サンプルを多数決で予測。 +-- [English]: Predict each sample by majority vote. +predictRFClassifier :: RFClassifierFit -> LA.Matrix Double -> V.Vector Int +predictRFClassifier fit xNew = + V.generate (LA.rows xNew) $ \i -> + let row = LA.toList (LA.flatten (xNew LA.? [i])) + in majority [ DT.predictDT t row | t <- rfcTrees fit ] + +-- =========================================================================== +-- 内部 +-- =========================================================================== + +computeOOB + :: LA.Matrix Double -> VU.Vector Int -> [DT.DTree] -> [[Int]] -> Double +computeOOB x y trees oobLists = + let n = LA.rows x + voteFor s = + let voters = [ t | (t, oob) <- zip trees oobLists, s `elem` oob ] + in if null voters then Nothing + else + let row = LA.toList (LA.flatten (x LA.? [s])) + in Just (majority [ DT.predictDT t row | t <- voters ]) + voted = [ (s, p) | s <- [0 .. n - 1] + , Just p <- [voteFor s] ] + nTotal = length voted + nErr = length [ () | (s, p) <- voted, p /= (y VU.! s) ] + in if nTotal == 0 then 0 else fromIntegral nErr / fromIntegral nTotal + +majority :: [Int] -> Int +majority xs = + let grouped = map (\g -> (head g, length g)) (group (sort xs)) + in case sortBy (comparing (Down . snd)) grouped of + ((c, _) : _) -> c + [] -> 0 + +-- | [日本語]: Mean Decrease in Impurity (gini) per feature, summed over all trees +-- (sklearn @feature_importances_@ 同方式・木構造から純粋計算)。 各内部ノードの +-- 重み付き gini 減少 @n·(imp − (nL/n)·impL − (nR/n)·impR)@ を分割特徴に加算し、 +-- 全木ぶん合計 → 合計 1 に正規化。 'DT.DTree' の拡張フィールド (dnN/dnImpurity) を使う。 +-- [English]: Mean Decrease in Impurity (Gini) per feature, summed over +-- all trees (the same approach as sklearn's @feature_importances_@; +-- computed purely from the tree structure). Adds the weighted Gini +-- decrease at each internal node, +-- @n·(imp − (nL/n)·impL − (nR/n)·impR)@, to its split feature, sums +-- over all trees, then normalizes to sum to 1. Uses 'DT.DTree''s +-- extension fields (dnN\/dnImpurity). +giniImportance :: Int -> [DT.DTree] -> LA.Vector Double +giniImportance p trees = + let m0 = Map.fromList [ (j, 0 :: Double) | j <- [0 .. p - 1] ] + go m (DT.DLeaf{}) = m + go m (DT.DNode { DT.dnFeature = j, DT.dnLeft = l, DT.dnRight = r + , DT.dnN = nn, DT.dnImpurity = imp }) = + let n = fromIntegral nn :: Double + nL = fromIntegral (nodeN l) + nR = fromIntegral (nodeN r) + dec = if n <= 0 then 0 + else n * (imp - (nL / n) * nodeImp l - (nR / n) * nodeImp r) + m' = Map.insertWith (+) j dec m + in go (go m' l) r + accM = foldl' go m0 trees + raw = [ Map.findWithDefault 0 j accM | j <- [0 .. p - 1] ] + tot = sum raw + in LA.fromList (if tot <= 0 then raw else map (/ tot) raw) + +-- | [日本語]: ノードのサンプル数 / gini 不純度 (葉・内部で共通アクセス)。 +-- [English]: A node's sample count \/ Gini impurity (uniform access for leaf and internal nodes). +nodeN :: DT.DTree -> Int +nodeN (DT.DLeaf{ DT.dlN = n }) = n +nodeN (DT.DNode{ DT.dnN = n }) = n + +nodeImp :: DT.DTree -> Double +nodeImp (DT.DLeaf{ DT.dlImpurity = i }) = i +nodeImp (DT.DNode{ DT.dnImpurity = i }) = i + +permImportance + :: PrimMonad m + => MWC.Gen (PrimState m) -> LA.Matrix Double -> VU.Vector Int -> [DT.DTree] + -> m (LA.Vector Double) +permImportance gen x y trees = do + let p = LA.cols x + baseAcc = forestAccuracy x y trees + scores <- forM [0 .. p - 1] $ \j -> do + xPerm <- permuteColumn j gen x + let acc = forestAccuracy xPerm y trees + pure (baseAcc - acc) + pure (LA.fromList scores) + +forestAccuracy :: LA.Matrix Double -> VU.Vector Int -> [DT.DTree] -> Double +forestAccuracy x y trees = + let n = LA.rows x + preds = + [ let row = LA.toList (LA.flatten (x LA.? [i])) + in majority [ DT.predictDT t row | t <- trees ] + | i <- [0 .. n - 1] ] + correct = length [ () | (p_, i) <- zip preds [0 ..] + , p_ == (y VU.! i) ] + in fromIntegral correct / fromIntegral n + +permuteColumn :: PrimMonad m + => Int -> MWC.Gen (PrimState m) -> LA.Matrix Double -> m (LA.Matrix Double) +permuteColumn j gen x = do + let col = LA.toList (LA.flatten (x LA.¿ [j])) + shuf <- fisherYates gen col + let newCol = LA.fromList shuf + cols = [ if k == j then newCol else LA.flatten (x LA.¿ [k]) + | k <- [0 .. LA.cols x - 1] ] + pure (LA.fromColumns cols) + +fisherYates :: PrimMonad m => MWC.Gen (PrimState m) -> [a] -> m [a] +fisherYates gen xs = + let v0 = V.fromList xs + in go v0 (V.length v0 - 1) + where + go v 0 = pure (V.toList v) + go v i = do + j <- MWC.uniformR (0, i) gen + let vi = v V.! i + vj = v V.! j + v' = v V.// [(i, vj), (j, vi)] + go v' (i - 1) diff --git a/src/Hanalyze/Model/Regularized.hs b/src/Hanalyze/Model/Regularized.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Regularized.hs @@ -0,0 +1,764 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Hanalyze.Model.Regularized +-- Description : 正則化回帰 (Ridge / Lasso / Elastic Net) を単一 API に統合したモジュール +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 正則化回帰 (Ridge / Lasso / Elastic Net) を単一モジュールに統合。 +-- +-- ペナルティは合成型 'Penalty' として符号化され、 'fitRegularized' が +-- 以下の 4 モデルすべてを扱う: +-- +-- > NoPen -- 通常の OLS +-- > L2 lambda -- Ridge 回帰 +-- > L1 lambda -- Lasso 回帰 +-- > ElasticNet lambda1 lambda2 -- Elastic Net (L1 + L2) +-- +-- Ridge は閉形式解を持つ。 Lasso と Elastic Net は座標降下法を用いる。 +-- +-- 注意: Lasso / Elastic Net は X の列スケールに敏感。事前に +-- standardize (各列を平均 0、分散 1 に) しておくのが一般的。 +-- +-- [English]: Regularized regression (Ridge / Lasso / Elastic Net) in one +-- module. +-- +-- The penalty is encoded as the sum type 'Penalty', and 'fitRegularized' +-- handles all four models: +-- +-- > NoPen -- ordinary OLS +-- > L2 lambda -- Ridge regression +-- > L1 lambda -- Lasso regression +-- > ElasticNet lambda1 lambda2 -- Elastic Net (L1 + L2) +-- +-- Ridge has a closed form; Lasso and Elastic Net use coordinate descent. +-- +-- Note: Lasso / Elastic Net are sensitive to the column scale of X; it +-- is common practice to standardize (each column to mean 0, variance 1) +-- beforehand. +module Hanalyze.Model.Regularized + ( Penalty (..) + , RegFit (..) + , fitRegularized + , fitRidge + , fitElasticNet + , predictRegularized + , standardize + , unstandardizeBeta + -- * Multi-output (primary API) + , RegFitMulti (..) + , fitRegularizedMulti + , fitRegularizedMultiWith + , predictRegularizedMulti + , regFitFromMulti + -- * Convergence-controlled API + , fitRegularizedWith + -- * Regularization path + , regularizationPath + + -- * λ 自動選択 (Phase 4.4、 request/150) + , PenaltyKind (..) + , LambdaSelection (..) + , selectLambdaCV + , selectLambdaCVPure + + -- * Phase 31: CD 内部プリミティブの再利用 (RegularizedAdvanced 用) + , softThreshold + , cdLoop + , mkRegFit + , fitOLS + , fitLasso + ) where + +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import qualified Numeric.LinearAlgebra as LA +import Control.Monad (forM_, when) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.ST (runST) +import Data.List (foldl', sortBy) +import Data.Ord (comparing) +import Data.Word (Word32) +import System.IO.Unsafe (unsafePerformIO) +import qualified System.Random.MWC as MWC +import qualified Hanalyze.Stat.CV as HCV + +-- --------------------------------------------------------------------------- +-- ペナルティ型 +-- --------------------------------------------------------------------------- + +-- | Regularization penalty. +data Penalty + = NoPen -- ^ Ordinary OLS (@λ = 0@). + | L2 Double -- ^ Ridge: @0.5 λ ‖β‖₂²@. + | L1 Double -- ^ Lasso: @λ ‖β‖₁@. + | ElasticNet Double Double -- ^ Elastic Net: @λ₁ ‖β‖₁ + 0.5 λ₂ ‖β‖₂²@. + deriving (Show, Eq) + +-- | Regularized-regression fit result. +data RegFit = RegFit + { rfBeta :: LA.Vector Double + , rfYHat :: LA.Vector Double + , rfResid :: LA.Vector Double + , rfR2 :: Double + , rfPenalty :: Penalty + , rfNonZero :: Int -- ^ Number of @|β_j| > 1e-8@ (Lasso sparsity). + , rfIters :: Int -- ^ Iteration count (coordinate descent; + -- 0 for closed-form solvers). + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- メイン API +-- --------------------------------------------------------------------------- + +-- | Single-output regularized-regression fit (sklearn-compatible +-- defaults @maxIter = 1000@, @tol = 1e-4@). Delegates to +-- 'fitRegularizedMulti' by promoting @y@ to a one-column matrix and +-- returns column 0 as a 'RegFit'. +fitRegularized :: Penalty -> LA.Matrix Double -> LA.Vector Double -> RegFit +fitRegularized pen x y = + regFitFromMulti 0 (fitRegularizedMulti pen x (LA.asColumn y)) + +-- | Single-output regularized-regression fit with explicit convergence +-- controls (only meaningful for Lasso / Elastic Net). +fitRegularizedWith + :: Int -> Double -> Penalty -> LA.Matrix Double -> LA.Vector Double + -> RegFit +fitRegularizedWith maxIter tol pen x y = + regFitFromMulti 0 + (fitRegularizedMultiWith maxIter tol pen x (LA.asColumn y)) + +-- | Single-output prediction. +predictRegularized :: RegFit -> LA.Matrix Double -> LA.Vector Double +predictRegularized fit xNew = xNew LA.#> rfBeta fit + +-- --------------------------------------------------------------------------- +-- OLS (NoPen) +-- --------------------------------------------------------------------------- + +-- | Plain ordinary-least-squares fit (no penalty). +fitOLS :: LA.Matrix Double -> LA.Vector Double -> RegFit +fitOLS x y = + let beta = LA.flatten (x LA.<\> LA.asColumn y) + yHat = x LA.#> beta + r = y - yHat + in mkRegFit beta yHat r y NoPen 0 + +-- --------------------------------------------------------------------------- +-- Ridge (closed form) +-- --------------------------------------------------------------------------- + +-- | Ridge regression: @β = (XᵀX + λI)⁻¹ Xᵀy@. +fitRidge :: Double -> LA.Matrix Double -> LA.Vector Double -> RegFit +fitRidge lambda x y = + let p = LA.cols x + xtx = LA.tr x LA.<> x + reg = xtx + LA.scale lambda (LA.ident p) + xty = LA.tr x LA.#> y + beta = LA.flatten (reg LA.<\> LA.asColumn xty) + yHat = x LA.#> beta + r = y - yHat + in mkRegFit beta yHat r y (L2 lambda) 0 + +-- --------------------------------------------------------------------------- +-- Lasso (Coordinate Descent + Soft-thresholding) +-- --------------------------------------------------------------------------- + +-- | Soft-threshold operator: @S(z, γ) = sign(z) × max(|z| − γ, 0)@. +softThreshold :: Double -> Double -> Double +softThreshold z gamma + | z > gamma = z - gamma + | z < -gamma = z + gamma + | otherwise = 0 + +-- | Lasso regression: @β = argmin (1/2n) ‖y − Xβ‖² + λ ‖β‖₁@. +-- +-- Solved by coordinate descent (one update per @β_j@): +-- +-- @ +-- r = y − X β +-- ρ_j = (1/n) X_jᵀ r + β_j × (1/n) ‖X_j‖² +-- β_j ← S(ρ_j, λ) / ((1/n) ‖X_j‖²) +-- @ +fitLasso :: Double -- ^ Penalty @λ@. + -> LA.Matrix Double -- ^ Design matrix @X@. + -> LA.Vector Double -- ^ Response @y@. + -> Int -- ^ Maximum CD iterations. + -> Double -- ^ Convergence tolerance. + -> RegFit +fitLasso lambda x y maxIter tol = + let (betaFinal, iters) = cdLoop x y maxIter tol + (\rho cSq -> softThreshold rho lambda / cSq) + yHat = x LA.#> betaFinal + r = y - yHat + in mkRegFit betaFinal yHat r y (L1 lambda) iters + +-- --------------------------------------------------------------------------- +-- Elastic Net (Coordinate Descent) +-- --------------------------------------------------------------------------- + +-- | Elastic-Net regression: +-- @β = argmin (1/2n) ‖y − Xβ‖² + λ₁ ‖β‖₁ + 0.5 λ₂ ‖β‖²@. +-- +-- Coordinate descent update: +-- @β_j ← S(ρ_j, λ₁) / ((1/n) ‖X_j‖² + λ₂)@. +fitElasticNet :: Double -> Double -> LA.Matrix Double -> LA.Vector Double + -> Int -> Double -> RegFit +fitElasticNet lambda1 lambda2 x y maxIter tol = + let (betaFinal, iters) = cdLoop x y maxIter tol + (\rho cSq -> softThreshold rho lambda1 + / (cSq + lambda2)) + yHat = x LA.#> betaFinal + r = y - yHat + in mkRegFit betaFinal yHat r y (ElasticNet lambda1 lambda2) iters + +-- --------------------------------------------------------------------------- +-- Shared CD loop with incremental residual maintenance +-- --------------------------------------------------------------------------- + +-- | Coordinate descent loop shared by 'fitLasso' and 'fitElasticNet'. +-- +-- The caller supplies a /closed-form coordinate update/ @upd ρ_j cSq_j@ +-- that returns @β_j_new@ given the partial-residual correlation @ρ_j@ +-- and the column-norm @cSq_j = ‖X_j‖²/n@. +-- +-- Implementation (R2): the inner sweep runs in 'IO' on +-- 'Data.Vector.Storable.Mutable' buffers. Both @β@ and the residual +-- @r = y − Xβ@ are updated in place, and the columns of @X@ are looked +-- up through a boxed 'Data.Vector.Vector' for @O(1)@ indexing (the +-- previous list-based @cols !! j@ paid @O(p)@ per coordinate). This is +-- the moral equivalent of sklearn's Cython coordinate-descent inner +-- loop; the user-visible behaviour is identical to the prior Vector +-- implementation up to floating-point rounding. +cdLoop + :: LA.Matrix Double -- X (n × p) + -> LA.Vector Double -- y + -> Int -- max iterations + -> Double -- tolerance on |Δβ|₂ + -> (Double -> Double -> Double) -- (ρ, cSq) → β_j_new + -> (LA.Vector Double, Int) +cdLoop x y maxIter tol upd + | LA.rows x >= 4 * LA.cols x = + cdLoopGram x y maxIter tol upd -- n ≫ p: Gram precompute + | otherwise = cdLoopResidual x y maxIter tol upd + +-- | Coordinate descent maintaining the @n@-dimensional residual +-- @r = y − Xβ@. Best when @n@ is small (the residual update is +-- @O(n)@ per coord; the alternative 'cdLoopGram' keeps a length-@p@ +-- prediction vector and pays @O(p)@ per coord). +cdLoopResidual + :: LA.Matrix Double -> LA.Vector Double -> Int -> Double + -> (Double -> Double -> Double) + -> (LA.Vector Double, Int) +cdLoopResidual x y maxIter tol upd = unsafePerformIO $ do + let nRows = LA.rows x + n = fromIntegral nRows :: Double + p = LA.cols x + colsB = V.fromList (LA.toColumns x) -- O(1) indexing + -- F1: per-column squared sum via 1 GEMV instead of p + -- 'sumElements (c*c)' calls. ones_n^T (X⊙X) gives length-p + -- vector of column sums; divide by n. + onesN = LA.konst 1 nRows :: LA.Vector Double + colSqN = LA.scale (1 / n) (onesN LA.<# (x * x)) + + -- Mutable buffer for β (single-index updates each coordinate step). + bMut <- VS.thaw (LA.konst 0 p :: LA.Vector Double) + + -- The residual r is kept as an /immutable/ 'LA.Vector Double' between + -- coordinate updates so that @r ← r − d · x_j@ can use BLAS axpy + -- (a single optimized call) rather than a per-element Haskell loop. + let sweep r = do + beforeSnap <- VS.freeze bMut + let stepCoord rCur j = do + let xj = colsB V.! j + cSq = colSqN `LA.atIndex` j + bjOld <- VSM.unsafeRead bMut j + let rho = (xj LA.<.> rCur) / n + bjOld * cSq + bjNew = upd rho cSq + d = bjNew - bjOld + if d == 0 + then return rCur + else do + VSM.unsafeWrite bMut j bjNew + -- BLAS axpy: r' = r - d * x_j. Tried fusing via + -- 'VS.zipWith' (one alloc instead of two) but it + -- was 1.6× slower — hmatrix's @(-)@ + @LA.scale@ + -- chain dispatches to BLAS @daxpy@/@dscal@ which + -- are SIMD-vectorised at the C level, beating any + -- pure Haskell per-element loop on n ≥ 1000. + return (rCur - LA.scale d xj) + rEnd <- foldM' stepCoord r [0 .. p - 1] + afterSnap <- VS.freeze bMut + return (beforeSnap, afterSnap, rEnd) + + let go k r = do + if k >= maxIter + then return k + else do + (before, after, r') <- sweep r + let diff = LA.norm_2 (after - before) + if diff < tol then return (k + 1) else go (k + 1) r' + + iters <- go 0 y -- initial residual = y (since β₀ = 0) + betaFinal <- VS.freeze bMut + return (betaFinal, iters) + where + -- Strict foldM that discards no intermediate results (folds an + -- accumulator @r@ through @f@). + foldM' :: Monad m => (b -> a -> m b) -> b -> [a] -> m b + foldM' _ acc [] = return acc + foldM' f acc (z:zs) = do + acc' <- f acc z + acc' `seq` foldM' f acc' zs + +-- | Coordinate descent with /precomputed/ Gram matrix +-- @G = XᵀX@ (p × p) and @v = Xᵀy@ (length p). +-- +-- For @n ≫ p@ this is dramatically faster than 'cdLoopResidual' +-- because each coordinate update touches a length-@p@ prediction +-- vector @q = G β@ rather than the length-@n@ residual. With +-- @n = 10000, p = 50@ the per-coord work goes from @O(n)@ to +-- @O(p)@ — roughly 200× less arithmetic per inner step. Mirrors +-- sklearn's @Lasso(precompute=True)@. +-- +-- Setup cost: forming @G@ is @O(np²)@ (one BLAS GEMM / +-- @LA.tr x \<\> x@); for the @p × p = 50 × 50@ Gram matrix at +-- @n = 10k@ that's ~25 million flops, amortised over the inner +-- coordinate-descent sweeps. +cdLoopGram + :: LA.Matrix Double -> LA.Vector Double -> Int -> Double + -> (Double -> Double -> Double) + -> (LA.Vector Double, Int) +cdLoopGram x y maxIter tol upd = unsafePerformIO $ do + let nRows = LA.rows x + nD = fromIntegral nRows :: Double + p = LA.cols x + gMat = LA.tr x LA.<> x -- p × p (SPD) + vVec = LA.tr x LA.#> y -- length p + diagG = LA.takeDiag gMat -- length p (= ‖X_j‖²) + -- Per-column views of @G@ for the @q = G β@ rank-1 update. + gCols = V.fromList (LA.toColumns gMat) -- O(1) column access + + bMut <- VS.thaw (LA.konst 0 p :: LA.Vector Double) + -- @q[k] = (G β)[k]@. Maintained incrementally: a coord update + -- @β_j ← β_j + d@ shifts @q ← q + d · G[:, j]@. + qMut <- VS.thaw (LA.konst 0 p :: LA.Vector Double) + + let stepCoord !maxDelta j = do + bjOld <- VSM.unsafeRead bMut j + qj <- VSM.unsafeRead qMut j + let !cSq = (diagG `LA.atIndex` j) / nD + -- ρ_j = (X_jᵀ r) / n + β_j cSq, where + -- X_jᵀ r = X_jᵀ y − X_jᵀ X β = v_j − q_j (linear in β) + !rho = (vVec `LA.atIndex` j - qj) / nD + bjOld * cSq + !bjNew = upd rho cSq + !d = bjNew - bjOld + !ad = abs d + !newMax = if ad > maxDelta then ad else maxDelta + if d == 0 + then return newMax + else do + VSM.unsafeWrite bMut j bjNew + -- BLAS axpy on @q@: @q ← q + d · G[:, j]@ via a short + -- mutable loop (p elements; for typical p ≤ 100 the + -- BLAS dispatch overhead would dominate). + let gCol = gCols V.! j + let go !k + | k >= p = pure () + | otherwise = do + qk <- VSM.unsafeRead qMut k + VSM.unsafeWrite qMut k + (qk + d * (gCol `VS.unsafeIndex` k)) + go (k + 1) + go 0 + return newMax + + let sweep = do + let go !mx !j + | j >= p = pure mx + | otherwise = do + mx' <- stepCoord mx j + go mx' (j + 1) + go 0 0 + + let loop !k = do + if k >= maxIter + then return k + else do + mxDelta <- sweep + -- Convergence on max |Δβ_j| (sklearn's default test). + -- Avoids the per-sweep @before/after freeze + norm_2@ that + -- 'cdLoopResidual' performs. + if mxDelta < tol then return (k + 1) else loop (k + 1) + + iters <- loop 0 + betaFinal <- VS.freeze bMut + return (betaFinal, iters) + +-- --------------------------------------------------------------------------- +-- 共通ヘルパ +-- --------------------------------------------------------------------------- + +mkRegFit :: LA.Vector Double -> LA.Vector Double -> LA.Vector Double + -> LA.Vector Double -> Penalty -> Int -> RegFit +mkRegFit beta yHat r y pen iters = + let mu = LA.sumElements y / fromIntegral (LA.size y) + ssT = LA.sumElements ((y - LA.scalar mu) ^ (2 :: Int)) + ssR = LA.sumElements (r ^ (2 :: Int)) + r2 = if ssT == 0 then 0 else 1 - ssR / ssT + nz = length [v | v <- LA.toList beta, abs v > 1e-8] + in RegFit beta yHat r r2 pen nz iters + +-- --------------------------------------------------------------------------- +-- Standardization +-- --------------------------------------------------------------------------- + +-- | Standardize each column to mean 0 and standard deviation 1. +-- +-- Returns @(X_std, column means, column sds)@. The transformation is +-- @X_std = (X − μ) / σ@; use 'unstandardizeBeta' to map coefficients +-- back to the original scale. +standardize :: LA.Matrix Double + -> (LA.Matrix Double, V.Vector Double, V.Vector Double) +standardize x = + let n = LA.rows x + p = LA.cols x + means = V.fromList + [ LA.sumElements (LA.flatten (x LA.¿ [j])) / fromIntegral n + | j <- [0 .. p - 1] ] + sds = V.fromList + [ let c = LA.flatten (x LA.¿ [j]) + mu = means V.! j + var = LA.sumElements ((c - LA.scalar mu) ^ (2 :: Int)) + / fromIntegral (n - 1) + in sqrt var + | j <- [0 .. p - 1] ] + cols' = [ let c = LA.flatten (x LA.¿ [j]) + mu = means V.! j + sd = sds V.! j + in (c - LA.scalar mu) / LA.scalar (if sd == 0 then 1 else sd) + | j <- [0 .. p - 1] ] + xStd = LA.fromColumns cols' + in (xStd, means, sds) + +-- | Map coefficients fitted in standardized space back to the original +-- scale: @β_orig_j = β_std_j / σ_j@. The intercept must be adjusted +-- separately, outside this helper. +unstandardizeBeta :: V.Vector Double -> LA.Vector Double -> LA.Vector Double +unstandardizeBeta sds betaStd = + let p = LA.size betaStd + in LA.fromList + [ (betaStd `LA.atIndex` j) / (sds V.! j) + | j <- [0 .. p - 1] ] + +-- --------------------------------------------------------------------------- +-- 多出力対応 (主 API) +-- --------------------------------------------------------------------------- + +-- | [日本語]: 多出力正則化回帰の fit 結果。 +-- Y は n × q、係数 B は p × q、予測 Ŷ = X B。 +-- 'rfmFits' は列ごとの単出力 'RegFit' (R²、|β|>0 の数、反復回数を提供)。 +-- [English]: Multi-output regularized-regression fit result. +-- Y is n x q, the coefficients B are p x q, and predictions are +-- Ŷ = X B. 'rfmFits' holds the per-column single-output 'RegFit' +-- (provides R², the count of |β|>0, and the iteration count). +data RegFitMulti = RegFitMulti + { rfmFits :: [RegFit] -- ^ [日本語]: 列ごとの単出力 fit。 [English]: Per-column single-output fit. + , rfmBeta :: LA.Matrix Double -- ^ p × q + , rfmYHat :: LA.Matrix Double -- ^ n × q + , rfmResid :: LA.Matrix Double -- ^ n × q + , rfmR2 :: [Double] -- ^ [日本語]: 列ごとの R²。 [English]: Per-column R². + , rfmPenalty :: Penalty + } deriving (Show) + +-- | [日本語]: sklearn 互換の既定収束パラメータ (@maxIter = 1000@, +-- @tol = 1e-4@) を使う多出力正則化回帰。 上書きするには +-- 'fitRegularizedMultiWith' を使う。 +-- +-- - OLS / Ridge: 行列形式 1 回の線形求解で全 q 列を一括処理 (高速)。 +-- - Lasso / Elastic Net: 列ごと座標降下 (列間に依存なし、独立並列可)。 +-- +-- [English]: Multi-output regularized regression with sklearn-compatible +-- default convergence parameters (@maxIter = 1000@, @tol = 1e-4@). Use +-- 'fitRegularizedMultiWith' to override. +-- +-- - OLS / Ridge: all q columns are handled in one batch via a single +-- matrix-form linear solve (fast). +-- - Lasso / Elastic Net: per-column coordinate descent (no dependency +-- between columns, so independently parallelizable). +fitRegularizedMulti :: Penalty -> LA.Matrix Double -> LA.Matrix Double + -> RegFitMulti +fitRegularizedMulti = fitRegularizedMultiWith 1000 1e-4 + +-- | Multi-output regularized regression with explicit convergence +-- controls (@maxIter@, @tol@). Affects only Lasso / Elastic Net (the +-- iterative coordinate-descent paths). OLS / Ridge are direct solves +-- and ignore these parameters. +fitRegularizedMultiWith + :: Int -- ^ Maximum CD iterations (default 1000). + -> Double -- ^ Convergence tolerance @|Δβ|₂@ (default 1e-4). + -> Penalty + -> LA.Matrix Double -> LA.Matrix Double + -> RegFitMulti +fitRegularizedMultiWith maxIter tol pen x y = case pen of + NoPen -> fitOLSMulti x y + L2 lambda -> fitRidgeMulti lambda x y + L1 lambda -> fitColumnwise (fitLasso lambda) maxIter tol pen x y + ElasticNet l1 l2 -> fitColumnwise (fitElasticNet l1 l2) maxIter tol pen x y + +-- | Multi-output prediction. +predictRegularizedMulti :: RegFitMulti -> LA.Matrix Double -> LA.Matrix Double +predictRegularizedMulti mf xNew = xNew LA.<> rfmBeta mf + +-- | Extract column @j@ of a 'RegFitMulti' as a 'RegFit'. +regFitFromMulti :: Int -> RegFitMulti -> RegFit +regFitFromMulti j mf + | j < length (rfmFits mf) = rfmFits mf !! j + | otherwise = error ("regFitFromMulti: column " ++ show j ++ " out of range") + +-- | Matrix-form OLS: @B = X \\ Y@ in a single LAPACK call. +fitOLSMulti :: LA.Matrix Double -> LA.Matrix Double -> RegFitMulti +fitOLSMulti x y = + let beta = x LA.<\> y + in mkRegFitMulti beta x y NoPen (replicate (LA.cols y) 0) + +-- | [日本語]: 行列形式の Ridge: B = (XᵀX + λI)⁻¹ XᵀY (1 回の Cholesky/LU)。 +-- [English]: Matrix-form Ridge: B = (XᵀX + λI)⁻¹ XᵀY (a single +-- Cholesky/LU solve). +fitRidgeMulti :: Double -> LA.Matrix Double -> LA.Matrix Double -> RegFitMulti +fitRidgeMulti lambda x y = + let p = LA.cols x + reg = LA.tr x LA.<> x + LA.scale lambda (LA.ident p) + xty = LA.tr x LA.<> y + beta = reg LA.<\> xty + in mkRegFitMulti beta x y (L2 lambda) (replicate (LA.cols y) 0) + +-- | [日本語]: 列ごと CD (Lasso / Elastic Net 用)。 +-- +-- @maxIter@ / @tol@ は呼び元から指定する (旧版は 1000 / 1e-7 を +-- hardcoded していたが、 これは sklearn の規定値 1000 / 1e-4 より tol +-- 側が 1000× 厳しく、 bench 比較が不公平だったため明示パラメタ化)。 +-- +-- [English]: Per-column CD (for Lasso / Elastic Net). +-- +-- @maxIter@ / @tol@ are supplied by the caller (an earlier version +-- hardcoded 1000 / 1e-7, but that tol was 1000x stricter than +-- sklearn's default of 1000 / 1e-4, making bench comparisons unfair; +-- hence explicit parameterization). +fitColumnwise + :: (LA.Matrix Double -> LA.Vector Double -> Int -> Double -> RegFit) + -> Int -- ^ @maxIter@ + -> Double -- ^ @tol@ + -> Penalty + -> LA.Matrix Double -> LA.Matrix Double + -> RegFitMulti +fitColumnwise fitCol maxIter tol pen x y = + let q = LA.cols y + fits = [ fitCol x (LA.flatten (y LA.¿ [j])) maxIter tol + | j <- [0 .. q - 1] ] + bMat = LA.fromColumns [rfBeta f | f <- fits] + yHat = LA.fromColumns [rfYHat f | f <- fits] + res = LA.fromColumns [rfResid f | f <- fits] + r2s = [rfR2 f | f <- fits] + in RegFitMulti fits bMat yHat res r2s pen + +-- | [日本語]: 共通: B 行列から RegFitMulti を組み立て。各列の R² と非零係数数も計算。 +-- [English]: Shared: assembles a RegFitMulti from the B matrix. Also +-- computes each column's R² and nonzero-coefficient count. +mkRegFitMulti :: LA.Matrix Double -> LA.Matrix Double -> LA.Matrix Double + -> Penalty -> [Int] -> RegFitMulti +mkRegFitMulti beta x y pen iters = + let yHat = x LA.<> beta + res = y - yHat + q = LA.cols y + colFit j = + let b = LA.flatten (beta LA.¿ [j]) + yh = LA.flatten (yHat LA.¿ [j]) + rj = LA.flatten (res LA.¿ [j]) + yj = LA.flatten (y LA.¿ [j]) + in mkRegFit b yh rj yj pen (iters !! j) + fits = [colFit j | j <- [0 .. q - 1]] + in RegFitMulti fits beta yHat res [rfR2 f | f <- fits] pen + +-- --------------------------------------------------------------------------- +-- Regularization path +-- --------------------------------------------------------------------------- + +-- | [日本語]: 与えられた λ の系列に対して係数推移を計算する +-- (regularization path)。 戻り値: 各 λ に対する係数ベクトル。 +-- +-- 利用例 (Ridge): +-- +-- @ +-- let lams = [10 ** (-4 + 0.1 * i) | i <- [0..60]] +-- path = regularizationPath L2 lams xMat yVec +-- -- path :: [(Double, [Double])] -- (λ, [β₀, β₁, ...]) +-- @ +-- +-- [English]: Computes the coefficient trajectory +-- (regularization path) over a given sequence of λ. Returns the +-- coefficient vector for each λ. +-- +-- Usage example (Ridge): +-- +-- @ +-- let lams = [10 ** (-4 + 0.1 * i) | i <- [0..60]] +-- path = regularizationPath L2 lams xMat yVec +-- -- path :: [(Double, [Double])] -- (λ, [β₀, β₁, ...]) +-- @ +regularizationPath + :: (Double -> Penalty) -- ^ λ → Penalty (e.g. @L2@, @L1@, + -- @\\l -> ElasticNet (l*α) (l*(1-α))@) + -> [Double] -- ^ [日本語]: λ 系列。 [English]: The λ sequence. + -> LA.Matrix Double -- ^ [日本語]: X (intercept 列付き)。 [English]: X (with an intercept column). + -> LA.Vector Double -- ^ y + -> [(Double, [Double])] -- ^ [日本語]: [(λ, 係数ベクトル)]。 [English]: [(λ, coefficient vector)]. +regularizationPath mkPen lambdas x y = + [ (lam, LA.toList (rfBeta (fitRegularized (mkPen lam) x y))) + | lam <- lambdas ] + + +-- =========================================================================== +-- λ 自動選択 (Phase 4.4、 request/150) +-- =========================================================================== + +-- | [日本語]: Penalty の "形" (λ 抜き)。 'selectLambdaCV' の grid 探索で λ を +-- 変化させる際の penalty family を指定する。 +-- [English]: The "shape" of a Penalty (without λ). Specifies the +-- penalty family to vary λ over during 'selectLambdaCV''s grid search. +data PenaltyKind + = KindRidge -- ^ Ridge (= 'L2' λ) + | KindLasso -- ^ Lasso (= 'L1' λ) + | KindElasticNet !Double -- ^ [日本語]: ElasticNet。 @α@ = L1 比率 (0 ≤ α ≤ 1)。 + -- total penalty = λ·(α·L1 + (1-α)/2·L2)、 内部で + -- 'ElasticNet' (α·λ) ((1-α)·λ) に展開。 + -- [English]: ElasticNet. @α@ = L1 ratio + -- (0 ≤ α ≤ 1). total penalty = + -- λ·(α·L1 + (1-α)/2·L2), expanded + -- internally into 'ElasticNet' (α·λ) + -- ((1-α)·λ). + deriving (Show, Eq) + +-- | [日本語]: λ 自動選択の結果。 +-- [English]: The result of automatic λ selection. +data LambdaSelection = LambdaSelection + { lsBestLambda :: !Double -- ^ [日本語]: CV MSE が最小の λ。 [English]: The λ with the smallest CV MSE. + , lsLambdas :: ![Double] -- ^ [日本語]: 検証した λ 値 (入力順)。 [English]: The λ values tested (in input order). + , lsCVScores :: ![Double] -- ^ [日本語]: 各 λ の CV MSE (lsLambdas と対応)。 [English]: Each λ's CV MSE (corresponds to lsLambdas). + , lsCVScoreSE :: ![Double] -- ^ [日本語]: 各 λ の CV MSE の標準誤差 (fold 間 SD)。 [English]: The standard error of each λ's CV MSE (SD across folds). + , lsOneSeLambda :: !Double -- ^ [日本語]: 1-SE rule の λ (best ± 1·SE 範囲内で + -- 最大スパース = 最大 λ)。 + -- [English]: The λ from the 1-SE rule + -- (the largest λ, i.e. the sparsest, + -- within best ± 1 SE). + , lsKind :: !PenaltyKind -- ^ [日本語]: 入力 PenaltyKind を保持 (canvas 側参照用)。 [English]: Retains the input PenaltyKind (for reference by the canvas side). + } deriving (Show) + +-- | [日本語]: k-fold CV で λ を自動選択。 +-- +-- 入力 'PenaltyKind' に従って λ grid を Ridge/Lasso/EN の 'Penalty' に展開し、 +-- 各 λ について k-fold CV を実行、 fold 平均 MSE を計算する。 +-- +-- 返り値の 'lsBestLambda' は MSE 最小の λ、 'lsOneSeLambda' は 1-SE rule +-- (= best MSE から 1·SE 以内で最大スパースな λ) の λ。 +-- +-- [English]: Automatically selects λ via k-fold CV. +-- +-- Expands the λ grid into Ridge\/Lasso\/EN 'Penalty' values according +-- to the input 'PenaltyKind', runs k-fold CV for each λ, and computes +-- the fold-averaged MSE. +-- +-- The returned 'lsBestLambda' is the λ with the smallest MSE; +-- 'lsOneSeLambda' is the λ from the 1-SE rule (the sparsest λ within +-- 1 SE of the best MSE). +selectLambdaCV + :: PrimMonad m + => Int -- ^ [日本語]: k-fold の k (≥ 2)。 [English]: The k of k-fold (≥ 2). + -> PenaltyKind -- ^ Ridge / Lasso / ElasticNet + -> [Double] -- ^ [日本語]: 検証する λ grid (log-spaced 推奨)。 [English]: The λ grid to validate (log-spaced recommended). + -> LA.Matrix Double -- ^ X (n × p) + -> LA.Vector Double -- ^ y (n) + -> MWC.Gen (PrimState m) -- ^ [日本語]: shuffle 用 (ST/IO 両用)。 [English]: For shuffling (works with both ST/IO). + -> m LambdaSelection +selectLambdaCV k kind lambdas xMat yVec gen = do + let n = LA.rows xMat + folds <- HCV.kFold k n gen + let perLambda lam = + let scores = + [ mseForFold (penaltyOf kind lam) xMat yVec trainIdx testIdx + | (trainIdx, testIdx) <- folds, not (null testIdx) + ] + !nFolds = fromIntegral (length scores) :: Double + mean = sum scores / nFolds + varN = sum [(s - mean) ** 2 | s <- scores] / max 1 (nFolds - 1) + !se = sqrt (varN / nFolds) + in (mean, se) + stats = map perLambda lambdas + mses = map fst stats + ses = map snd stats + indexedMSEs = zip3 lambdas mses ses + sortedAsc = sortBy (comparing (\(_, m, _) -> m)) indexedMSEs + (bestL, bestMSE, bestSE) = + case sortedAsc of + (h:_) -> h + [] -> (0, 0, 0) + threshold = bestMSE + bestSE + -- 1-SE λ: best から 1·SE 以内の λ のうち最大 (= 最大スパース) + oneSe = + let cands = [ lam | (lam, m, _) <- indexedMSEs, m <= threshold ] + in if null cands then bestL else maximum cands + pure LambdaSelection + { lsBestLambda = bestL + , lsLambdas = lambdas + , lsCVScores = mses + , lsOneSeLambda = oneSe + , lsCVScoreSE = ses + , lsKind = kind + } + +-- | [日本語]: 純粋 (seed) 版 'selectLambdaCV'。 同 seed → 同 λ 選択 (ST/IO +-- ビット一致)。 罰則回帰の高レベル spec (`df |-> lasso …`) を pure +-- @fitWith@ で完結させる継ぎ目 (GP の @AutoCV@ / @kMeansPure@ / +-- @fitRFVPure@ と一貫)。 +-- [English]: Pure (seed) variant of 'selectLambdaCV'. Same seed → +-- same λ selection (bit-identical across ST/IO). This is the seam +-- that lets the high-level spec for regularized regression +-- (`df |-> lasso …`) be completed with a pure @fitWith@ (consistent +-- with GP's @AutoCV@ \/ @kMeansPure@ \/ @fitRFVPure@). +selectLambdaCVPure + :: Int -> PenaltyKind -> [Double] -> LA.Matrix Double -> LA.Vector Double + -> Word32 -> LambdaSelection +selectLambdaCVPure k kind lambdas xMat yVec seed = + runST (MWC.initialize (V.singleton seed) >>= selectLambdaCV k kind lambdas xMat yVec) + +-- | [日本語]: 内部 helper: PenaltyKind と λ から具体 'Penalty' を組み立てる。 +-- [English]: Internal helper: builds a concrete 'Penalty' from a +-- PenaltyKind and λ. +penaltyOf :: PenaltyKind -> Double -> Penalty +penaltyOf KindRidge lam = L2 lam +penaltyOf KindLasso lam = L1 lam +penaltyOf (KindElasticNet a) lam = ElasticNet (a * lam) ((1 - a) * lam) + +-- | [日本語]: 1 fold の MSE を返す。 train index で fit、 test index で +-- predict + 残差²平均。 +-- [English]: Returns the MSE for one fold. Fits on the train index, +-- predicts on the test index, then averages the squared residuals. +mseForFold + :: Penalty + -> LA.Matrix Double + -> LA.Vector Double + -> [Int] -- train 行 index + -> [Int] -- test 行 index + -> Double +mseForFold pen xMat yVec trainIdx testIdx = + let xTr = xMat LA.? trainIdx + yTr = LA.fromList [ yVec LA.! i | i <- trainIdx ] + xTe = xMat LA.? testIdx + yTe = LA.fromList [ yVec LA.! i | i <- testIdx ] + fit = fitRegularized pen xTr yTr + yHat = predictRegularized fit xTe + resid = yTe - yHat + nTe = fromIntegral (length testIdx) :: Double + in LA.sumElements (resid * resid) / nTe diff --git a/src/Hanalyze/Model/RegularizedAdvanced.hs b/src/Hanalyze/Model/RegularizedAdvanced.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/RegularizedAdvanced.hs @@ -0,0 +1,376 @@ +-- | +-- Module : Hanalyze.Model.RegularizedAdvanced +-- Description : 高度な罰則項回帰 — Adaptive Lasso / MCP / SCAD / Group Lasso +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 高度な罰則項回帰: Adaptive Lasso / MCP / SCAD / Group Lasso。 +-- +-- 既存 'Hanalyze.Model.Regularized' (Lasso/Ridge/Elastic Net + CV λ 選択) +-- を補完する変数選択型の罰則項群。 JMP "Generalized +-- Regression" platform / R @ncvreg@ / @grpreg@ / @glmnet@ (adaptive オプション) +-- 相当。 +-- +-- ## 共通の前提 +-- +-- - 罰則項は Lasso 同様 X の列スケールに敏感。 呼び出し側で +-- 'Hanalyze.Model.Regularized.standardize' しておく +-- - 内部 CD は 'Hanalyze.Model.Regularized.cdLoop' を流用 (Adaptive Lasso は +-- 列再重み付け、 MCP / SCAD は per-coord non-convex threshold) +-- - Group Lasso は block CD で別ループ (Yuan-Lin 2006 algorithm) +-- +-- Reference: +-- Zou (2006), Zhang (2010), Fan-Li (2001), Yuan-Lin (2006), +-- Breheny-Huang (2011) "Coordinate descent algorithms for non-convex +-- penalized regression". Ann. Appl. Stat. 5:232-253. +-- +-- [English]: Advanced penalized regression: Adaptive Lasso \/ MCP \/ SCAD \/ +-- Group Lasso. +-- +-- A family of variable-selection penalties that complements the existing +-- 'Hanalyze.Model.Regularized' (Lasso\/Ridge\/Elastic Net + CV λ +-- selection). Equivalent to JMP's "Generalized Regression" platform \/ R's +-- @ncvreg@ \/ @grpreg@ \/ @glmnet@ (adaptive option). +-- +-- ## Shared assumptions +-- +-- - Like Lasso, these penalties are sensitive to the column scale of X. +-- Callers should apply 'Hanalyze.Model.Regularized.standardize' +-- first +-- - The inner CD reuses 'Hanalyze.Model.Regularized.cdLoop' (Adaptive +-- Lasso via column reweighting, MCP \/ SCAD via per-coord non-convex +-- thresholding) +-- - Group Lasso uses a separate loop with block CD (Yuan-Lin 2006 algorithm) +-- +-- Reference: +-- Zou (2006), Zhang (2010), Fan-Li (2001), Yuan-Lin (2006), +-- Breheny-Huang (2011) "Coordinate descent algorithms for non-convex +-- penalized regression". Ann. Appl. Stat. 5:232-253. +module Hanalyze.Model.RegularizedAdvanced + ( -- * Adaptive Lasso (Zou 2006) + fitAdaptiveLasso + , adaptiveWeightsFromOLS + -- * MCP (Zhang 2010) + , fitMCP + -- * SCAD (Fan-Li 2001) + , fitSCAD + -- * Group Lasso (Yuan-Lin 2006) + , fitGroupLasso + ) where + +import qualified Numeric.LinearAlgebra as LA +import Hanalyze.Model.Regularized + (RegFit (..), Penalty (..), softThreshold, cdLoop, + mkRegFit, fitOLS, fitLasso) + +-- --------------------------------------------------------------------------- +-- 31-A1: Adaptive Lasso +-- --------------------------------------------------------------------------- + +-- | [日本語]: Adaptive Lasso (Zou 2006): @argmin (1/2n)|y - Xβ|² + λ Σ w_j |β_j|@。 +-- +-- 解法: column reweighting trick — @x_j' = x_j / w_j@ で変形すると標準 +-- Lasso になり、 解 @β_j' = β_j · w_j@ から @β_j = β_j' / w_j@ で復元できる。 +-- 既存 'fitLasso' をそのまま流用するので追加 CD ループ不要。 +-- +-- @w_j@ は典型的に OLS pilot 推定値から構築する ('adaptiveWeightsFromOLS')。 +-- +-- 注意: @w_j = 0@ は "罰則ゼロ" ではなく実装上 "@β_j = 0@ 強制" として扱う +-- (列 j を 0 vector に潰すため)。 罰則ゼロにしたい場合は @w_j@ を非常に +-- 小さい正値にする。 +-- +-- [English]: Adaptive Lasso (Zou 2006): @argmin (1/2n)|y - Xβ|² + λ Σ w_j |β_j|@. +-- +-- Solved via the column reweighting trick — transforming with +-- @x_j' = x_j / w_j@ turns it into standard Lasso, and the original-space +-- solution @β_j = β_j' / w_j@ is recovered from @β_j' = β_j · w_j@. Since +-- this reuses the existing 'fitLasso' directly, no extra CD loop is needed. +-- +-- @w_j@ is typically built from an OLS pilot estimate ('adaptiveWeightsFromOLS'). +-- +-- Note: @w_j = 0@ is not treated as "zero penalty" but rather, in this +-- implementation, as "force @β_j = 0@" (since it collapses column j to a +-- zero vector). To get a truly zero penalty, use a very small positive +-- value for @w_j@ instead. +fitAdaptiveLasso + :: Double -- ^ @λ@ + -> LA.Vector Double -- ^ [日本語]: weights @w@ (length @p@、 全 @≥ 0@)。 [English]: weights @w@ (length @p@, all @≥ 0@). + -> LA.Matrix Double -- ^ X (n × p) + -> LA.Vector Double -- ^ y + -> Int -- ^ max CD iterations + -> Double -- ^ tolerance + -> RegFit +fitAdaptiveLasso lambda w x y maxIter tol = + let invW = LA.cmap (\wj -> if wj <= 0 then 0 else 1 / wj) w + xRew = x LA.<> LA.diag invW + lassoF = fitLasso lambda xRew y maxIter tol + -- 変形空間の解 β' を元の空間の β = β' / w に戻す + betaP = rfBeta lassoF + beta = invW * betaP + yHat = x LA.#> beta + r = y - yHat + in mkRegFit beta yHat r y (L1 lambda) (rfIters lassoF) + +-- | [日本語]: OLS pilot 推定値から Adaptive Lasso 重み @w_j = 1 / |β̂_j^OLS|^γ@ を構築。 +-- 典型値 @γ = 1@。 OLS が定義できないケース (@n < p@) では事前に Ridge pilot +-- に切り替えるなど呼び出し側で工夫する。 0 除算回避のため @|β̂| ≤ 1e-8@ の +-- 場合は floor @1e-8@ を使う。 +-- +-- [English]: Builds Adaptive Lasso weights @w_j = 1 / |β̂_j^OLS|^γ@ from an +-- OLS pilot estimate. Typical value @γ = 1@. When OLS is undefined +-- (@n < p@), it's up to the caller to work around it, e.g. by switching to +-- a Ridge pilot beforehand. To avoid division by zero, a floor of @1e-8@ is +-- applied when @|β̂| ≤ 1e-8@. +adaptiveWeightsFromOLS + :: Double -- ^ @γ@ (typical 1.0) + -> LA.Matrix Double -> LA.Vector Double -> LA.Vector Double +adaptiveWeightsFromOLS gamma x y = + let beta0 = rfBeta (fitOLS x y) + in LA.cmap (\b -> 1 / (max 1e-8 (abs b) ** gamma)) beta0 + +-- --------------------------------------------------------------------------- +-- 31-A2: MCP (Minimax Concave Penalty、 Zhang 2010) +-- --------------------------------------------------------------------------- + +-- | [日本語]: MCP non-convex 罰則: +-- +-- @ +-- p_{λ,γ}(β) = λ |β| - β²/(2γ) if |β| ≤ γλ +-- = γλ²/2 if |β| > γλ +-- @ +-- +-- @γ → ∞@ で Lasso に縮退、 @γ → 1@ で hard-threshold 寄りになる。 典型値 +-- @γ ∈ [2, 5]@。 +-- +-- Coordinate descent 更新 (Breheny-Huang 2011, with column-norm @cSq@): +-- +-- @ +-- z = ρ_j +-- β_j = S(z, λ) / (cSq - 1/γ) if |z| ≤ γλ·cSq +-- = z / cSq if |z| > γλ·cSq +-- @ +-- +-- 前提: @cSq > 1/γ@ (= 罰則項の凹性を局所凸性が上回る)。 標準化 @X@ (cSq ≈ 1) +-- で @γ > 1@ なら自動的に満たす。 違反時は inner CD が発散する可能性があり、 +-- 呼び出し側で @standardize@ + @γ ≥ 3@ を推奨。 +-- +-- [English]: MCP non-convex penalty: +-- +-- @ +-- p_{λ,γ}(β) = λ |β| - β²/(2γ) if |β| ≤ γλ +-- = γλ²/2 if |β| > γλ +-- @ +-- +-- As @γ → ∞@ it degenerates to Lasso; as @γ → 1@ it leans toward +-- hard-thresholding. Typical value @γ ∈ [2, 5]@. +-- +-- Coordinate descent update (Breheny-Huang 2011, with column-norm @cSq@): +-- +-- @ +-- z = ρ_j +-- β_j = S(z, λ) / (cSq - 1/γ) if |z| ≤ γλ·cSq +-- = z / cSq if |z| > γλ·cSq +-- @ +-- +-- Assumes @cSq > 1/γ@ (i.e. local convexity outweighs the penalty's +-- concavity). With standardized @X@ (cSq ≈ 1), this is automatically +-- satisfied when @γ > 1@. If violated, the inner CD may diverge; callers +-- are recommended to use @standardize@ + @γ ≥ 3@. +fitMCP + :: Double -- ^ @λ@ + -> Double -- ^ [日本語]: @γ@ (concavity、 推奨 @≥ 3@)。 [English]: @γ@ (concavity; recommended @≥ 3@). + -> LA.Matrix Double -- ^ X + -> LA.Vector Double -- ^ y + -> Int -- ^ max CD iterations + -> Double -- ^ tolerance + -> RegFit +fitMCP lambda gamma x y maxIter tol = + let upd rho cSq = + let z = rho + thresh = gamma * lambda * cSq + in if abs z <= thresh + then + let denom = cSq - 1 / gamma + in if denom <= 0 + then z / cSq -- 非凸時は OLS 解で fallback + else softThreshold z lambda / denom + else z / cSq + (betaFinal, iters) = cdLoop x y maxIter tol upd + yHat = x LA.#> betaFinal + r = y - yHat + in mkRegFit betaFinal yHat r y (L1 lambda) iters + +-- --------------------------------------------------------------------------- +-- 31-A3: SCAD (Smoothly Clipped Absolute Deviation、 Fan-Li 2001) +-- --------------------------------------------------------------------------- + +-- | [日本語]: SCAD non-convex 罰則 (区分三次): +-- +-- @ +-- p'_{λ,a}(|β|) = λ if |β| ≤ λ +-- = (aλ - |β|)/(a-1) if λ < |β| ≤ aλ +-- = 0 if |β| > aλ +-- @ +-- +-- 典型値 @a = 3.7@ (Fan-Li 2001 推奨)。 +-- +-- Coordinate descent 更新 (Breheny-Huang 2011): +-- +-- @ +-- z = ρ_j +-- if |z| ≤ λ·(1 + cSq) : β_j = S(z, λ) / cSq -- Lasso 領域 +-- elif |z| ≤ a·λ·cSq : β_j = S(z, aλ/(a-1)) / (cSq - 1/(a-1)) +-- else : β_j = z / cSq -- OLS 領域 +-- @ +-- +-- [English]: SCAD non-convex penalty (piecewise cubic): +-- +-- @ +-- p'_{λ,a}(|β|) = λ if |β| ≤ λ +-- = (aλ - |β|)/(a-1) if λ < |β| ≤ aλ +-- = 0 if |β| > aλ +-- @ +-- +-- Typical value @a = 3.7@ (recommended by Fan-Li 2001). +-- +-- Coordinate descent update (Breheny-Huang 2011): +-- +-- @ +-- z = ρ_j +-- if |z| ≤ λ·(1 + cSq) : β_j = S(z, λ) / cSq -- Lasso region +-- elif |z| ≤ a·λ·cSq : β_j = S(z, aλ/(a-1)) / (cSq - 1/(a-1)) +-- else : β_j = z / cSq -- OLS region +-- @ +fitSCAD + :: Double -- ^ @λ@ + -> Double -- ^ [日本語]: @a@ (= 3.7 推奨)。 [English]: @a@ (recommended @= 3.7@). + -> LA.Matrix Double + -> LA.Vector Double + -> Int -> Double + -> RegFit +fitSCAD lambda a x y maxIter tol = + let upd rho cSq = + let z = rho + absZ = abs z + in if absZ <= lambda * (1 + cSq) + then softThreshold z lambda / cSq + else if absZ <= a * lambda * cSq + then + let denom = cSq - 1 / (a - 1) + thr = a * lambda / (a - 1) + in if denom <= 0 + then z / cSq + else softThreshold z thr / denom + else z / cSq + (betaFinal, iters) = cdLoop x y maxIter tol upd + yHat = x LA.#> betaFinal + r = y - yHat + in mkRegFit betaFinal yHat r y (L1 lambda) iters + +-- --------------------------------------------------------------------------- +-- 31-A4: Group Lasso (Yuan-Lin 2006) +-- --------------------------------------------------------------------------- + +-- | [日本語]: Group Lasso: @argmin (1/2n)|y - Xβ|² + λ Σ_g √|g| · |β_g|₂@ +-- (group ごと L2 ノルムの和で penalize、 group 全体を 0 / non-0 にする)。 +-- +-- 解法: block coordinate descent。 各 group @g@ について部分残差 +-- @r_g = r + X_g β_g@ を作り、 group 更新 +-- +-- @ +-- z_g = X_gᵀ r_g / n +-- β_g_new = (1 - λ √|g| / |z_g|₂)_+ · z_g / cSq_g +-- @ +-- +-- ここで @cSq_g = |X_g|² / n@ (group 内列ノルム合計、 簡易には 1 を仮定)、 +-- @(·)_+@ は max(·, 0)。 Yuan-Lin 2006 の uncorrelated-within-group 想定で +-- 動く simplified version。 +-- +-- @groups@ は @[[Int]]@ で、 各内側リストが列 index の集合 (重複・順不同可)。 +-- 列 index が複数 group に現れた場合は最初の group のみ扱われる。 +-- +-- [English]: Group Lasso: @argmin (1/2n)|y - Xβ|² + λ Σ_g √|g| · |β_g|₂@ +-- (penalizes the sum of L2 norms per group, driving whole groups to 0 or +-- non-0). +-- +-- Solved via block coordinate descent. For each group @g@, a partial +-- residual @r_g = r + X_g β_g@ is formed, and the group is updated as +-- +-- @ +-- z_g = X_gᵀ r_g / n +-- β_g_new = (1 - λ √|g| / |z_g|₂)_+ · z_g / cSq_g +-- @ +-- +-- where @cSq_g = |X_g|² / n@ (sum of within-group column norms, assumed +-- @1@ in the simplified case) and @(·)_+@ is max(·, 0). This is the +-- simplified version that works under Yuan-Lin 2006's +-- uncorrelated-within-group assumption. +-- +-- @groups@ is @[[Int]]@, where each inner list is a set of column indices +-- (duplicates \/ any order allowed). If a column index appears in multiple +-- groups, only the first group is used. +fitGroupLasso + :: Double -- ^ @λ@ + -> [[Int]] -- ^ [日本語]: group 分割 (列 index)。 [English]: group partitioning (column indices). + -> LA.Matrix Double -- ^ X (n × p) + -> LA.Vector Double -- ^ y + -> Int -- ^ max iterations + -> Double -- ^ tolerance + -> RegFit +fitGroupLasso lambda groups x y maxIter tol = + let n = LA.rows x + nD = fromIntegral n :: Double + p = LA.cols x + -- group ごとに前計算する design submatrix と column-norm sum + gPrep = [ (gValid, x LA.¿ gValid, gSize gValid) + | g <- groups + , let gValid = [j | j <- g, j >= 0, j < p] + , not (null gValid) ] + gSize g = sqrt (fromIntegral (length g)) -- √|g| + -- 反復: β_g を block 更新 + step beta resid = + foldl + (\(bAcc, rAcc) (gIdx, xG, gW) -> + let -- 部分残差 r_g = r + X_g β_g + bG = LA.fromList [ LA.atIndex bAcc j | j <- gIdx ] + rG = rAcc + xG LA.#> bG + z = LA.tr xG LA.#> rG / LA.scalar nD + zNorm = LA.norm_2 z + cSqG = LA.sumElements (xG * xG) / nD + thr = lambda * gW + bGnew = if zNorm <= thr || cSqG <= 0 + then LA.konst 0 (LA.size z) + else LA.scale ((1 - thr / zNorm) / cSqG) z + -- 残差を新 β_g で更新: r ← r - X_g (β_g_new - β_g) + rNew = rG - xG LA.#> bGnew + bAcc' = updateIndices bAcc gIdx (LA.toList bGnew) + in (bAcc', rNew)) + (beta, resid) gPrep + loop !k !beta !resid = + if k >= maxIter + then (beta, k) + else + let (betaNew, residNew) = step beta resid + diff = LA.norm_2 (betaNew - beta) + in if diff < tol + then (betaNew, k + 1) + else loop (k + 1) betaNew residNew + beta0 = LA.konst 0 p + (betaFinal, iters) = loop 0 beta0 y + yHat = x LA.#> betaFinal + r = y - yHat + in mkRegFit betaFinal yHat r y (L1 lambda) iters + +-- | [日本語]: Vector の特定 index 群を新値で置き換える (immutable 経由)。 Group Lasso +-- 専用のため module 内部 helper。 +-- [English]: Replaces a specific set of vector indices with new values (via +-- an immutable copy). An internal helper dedicated to Group Lasso. +updateIndices :: LA.Vector Double -> [Int] -> [Double] -> LA.Vector Double +updateIndices v idx vals = + let xs = LA.toList v + m = zip idx vals + n = length xs + lookupNew j = case lookup j m of + Just nv -> nv + Nothing -> xs !! j + in LA.fromList [ lookupNew j | j <- [0 .. n - 1] ] diff --git a/src/Hanalyze/Model/Reliability.hs b/src/Hanalyze/Model/Reliability.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Reliability.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Hanalyze.Model.Reliability +-- Description : 信頼性解析 — 加速寿命試験モデル群 (Arrhenius / Eyring / Inverse Power Law) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 信頼性解析: 加速寿命試験のモデル群。 +-- +-- ストレス変数 (温度 / 電圧 / 湿度等) と寿命の関係を回帰し、 使用条件下での +-- 寿命予測や加速係数を計算する。 +-- +-- 提供するモデル: +-- +-- - 'fitArrhenius' — 温度ストレス: @t = A · exp(Ea / (k_B · T))@ +-- - 'fitEyring' — 温度 + 1 ストレス: 半導体 EM 等 +-- - 'fitInversePower' — 電圧 / 機械応力: @t = A · S^(-n)@ +-- +-- いずれも対数寿命を線形モデルとして fit する (古典的アプローチ)。 +-- 寿命分布の指定が必要な場合は 'Hanalyze.Model.Weibull' の MLE 結果を +-- 入力として渡すバリアント (本モジュールの提供外、 別フェーズで検討)。 +-- +-- [English]: Reliability analysis: a family of accelerated life-testing +-- models. +-- +-- Regresses the relationship between stress variables (temperature \/ +-- voltage \/ humidity, etc.) and lifetime, computing lifetime predictions +-- under use conditions and acceleration factors. +-- +-- Models provided: +-- +-- - 'fitArrhenius' — temperature stress: @t = A · exp(Ea / (k_B · T))@ +-- - 'fitEyring' — temperature + 1 stress: semiconductor EM etc. +-- - 'fitInversePower' — voltage \/ mechanical stress: @t = A · S^(-n)@ +-- +-- All of these fit log-lifetime as a linear model (the classical approach). +-- A variant that takes MLE results from 'Hanalyze.Model.Weibull' as +-- input, for cases where the lifetime distribution must be specified, is +-- out of scope for this module (to be considered in a separate phase). +module Hanalyze.Model.Reliability + ( -- * Arrhenius + ArrheniusFit (..) + , fitArrhenius + , accelerationFactor + -- * Eyring + , EyringFit (..) + , fitEyring + -- * Inverse Power Law + , InversePowerFit (..) + , fitInversePower + -- * 共通定数 + , kBoltzmann + ) where + +import qualified Numeric.LinearAlgebra as LA +import Data.Text (Text) + +-- =========================================================================== +-- 共通定数 +-- =========================================================================== + +-- | [日本語]: Boltzmann 定数 (eV/K)。 Arrhenius / Eyring で温度ストレスに使う。 +-- [English]: The Boltzmann constant (eV\/K). Used for temperature stress +-- in Arrhenius \/ Eyring. +kBoltzmann :: Double +kBoltzmann = 8.617333262145e-5 + +-- =========================================================================== +-- Arrhenius モデル +-- =========================================================================== + +-- | [日本語]: Arrhenius fit: @t = A · exp(Ea / (k_B · T))@ +-- [English]: Arrhenius fit: @t = A · exp(Ea / (k_B · T))@. +data ArrheniusFit = ArrheniusFit + { afA :: !Double -- ^ [日本語]: 前指数因子 A。 [English]: The pre-exponential factor A. + , afEa :: !Double -- ^ [日本語]: 活性化エネルギー Ea (eV)。 [English]: The activation energy Ea (eV). + , afLogLik :: !Double -- ^ [日本語]: 対数尤度 (Gaussian residual 仮定)。 [English]: The log-likelihood (assuming Gaussian residuals). + , afN :: !Int -- ^ [日本語]: 観測 (温度 × 寿命) 数。 [English]: The number of observations (temperature × lifetime). + } deriving (Show) + +-- | [日本語]: Arrhenius モデルの fit。 +-- +-- 入力: @[(temperature_K, [lifetimes])]@ の対、 温度ごとに複数寿命を観測。 +-- 解法: log t = log A + Ea/k_B · (1/T) を OLS で解く (= 線形回帰)。 +-- 戻り値: @A@ と @Ea (eV)@ の点推定、 log-likelihood (Gaussian residual 仮定)。 +-- +-- 失敗条件: +-- +-- - 入力が空または全観測 0 個 → Left +-- - 温度水準が 1 種類しかない (= 傾き決定不能) → Left +-- - 任意の温度 ≤ 0 や寿命 ≤ 0 → Left (log 取得不能) +-- +-- [English]: Fits the Arrhenius model. +-- +-- Input: pairs of @[(temperature_K, [lifetimes])]@, with multiple lifetimes +-- observed per temperature. +-- Method: solves log t = log A + Ea/k_B · (1/T) via OLS (= linear +-- regression). +-- Returns: point estimates of @A@ and @Ea (eV)@, plus the log-likelihood +-- (assuming Gaussian residuals). +-- +-- Failure conditions: +-- +-- - Input is empty or has zero observations overall → Left +-- - Only one distinct temperature level (= slope cannot be determined) → +-- Left +-- - Any temperature ≤ 0 or lifetime ≤ 0 → Left (log cannot be taken) +fitArrhenius :: [(Double, [Double])] -> Either Text ArrheniusFit +fitArrhenius input = do + () <- if null input then Left "fitArrhenius: empty input" else Right () + let allPairs = + [ (t, life) + | (t, lives) <- input + , life <- lives + ] + () <- if null allPairs + then Left "fitArrhenius: no lifetime observations across all temperatures" + else Right () + () <- if any (\(t, l) -> t <= 0 || l <= 0) allPairs + then Left "fitArrhenius: temperatures and lifetimes must all be > 0" + else Right () + let distinctTemps = length (nubByDouble (map fst allPairs)) + () <- if distinctTemps < 2 + then Left "fitArrhenius: need at least 2 distinct temperatures" + else Right () + -- (x, y) = (1/T, log t) + let xs = map (\(t, _) -> 1 / t) allPairs + ys = map (\(_, l) -> log l) allPairs + n = length allPairs + meanX = sum xs / fromIntegral n + meanY = sum ys / fromIntegral n + sxx = sum [ (x - meanX) ** 2 | x <- xs ] + sxy = sum [ (x - meanX) * (y - meanY) | (x, y) <- zip xs ys ] + () <- if sxx <= 0 + then Left "fitArrhenius: zero variance in 1/T (numerical issue)" + else Right () + let b1 = sxy / sxx -- slope = Ea / k_B + b0 = meanY - b1 * meanX -- intercept = log A + a = exp b0 + ea = b1 * kBoltzmann + yHat = [ b0 + b1 * x | x <- xs ] + sse = sum [ (y - yh) ** 2 | (y, yh) <- zip ys yHat ] + sigma2 = if n > 2 then sse / fromIntegral (n - 2) else sse / fromIntegral n + ll = -0.5 * fromIntegral n * (log (2 * pi * sigma2) + 1) + Right ArrheniusFit + { afA = a + , afEa = ea + , afLogLik = ll + , afN = n + } + +-- | [日本語]: 重複除去 (浮動小数点許容なし、 完全一致のみ)。 +-- [English]: Deduplication (no floating-point tolerance, exact match +-- only). +nubByDouble :: [Double] -> [Double] +nubByDouble = go [] + where + go acc [] = reverse acc + go acc (x:xs) | x `elem` acc = go acc xs + | otherwise = go (x : acc) xs + +-- | [日本語]: 加速係数 AF = exp(Ea/k_B · (1/T_use - 1/T_test)) +-- [English]: The acceleration factor AF = exp(Ea/k_B · (1/T_use - +-- 1/T_test)). +accelerationFactor :: ArrheniusFit -> Double -> Double -> Double +accelerationFactor fit tUse tTest = + exp (afEa fit / kBoltzmann * (1/tUse - 1/tTest)) + +-- =========================================================================== +-- Eyring モデル (Phase 2.6) +-- =========================================================================== + +-- | [日本語]: Eyring fit: @t = A · T^(-1) · exp(Ea / (k_B · T)) · exp(B · S)@ +-- (温度 T と 1 ストレス変数 S) +-- [English]: Eyring fit: @t = A · T^(-1) · exp(Ea / (k_B · T)) · +-- exp(B · S)@ (temperature T and 1 stress variable S). +data EyringFit = EyringFit + { efA :: !Double + , efEa :: !Double + , efB :: !Double -- ストレス係数 + , efLogLik :: !Double + , efN :: !Int + } deriving (Show) + +-- | [日本語]: Eyring モデルの fit。 +-- +-- モデル: @t · T = A · exp(Ea / (k_B · T)) · exp(B · S)@ +-- 等価に: @log t = log A − log T + Ea/(k_B · T) + B · S@ +-- +-- 入力: @[(temperature_K, stress, [lifetimes])]@。 各 (T, S) 組合せで複数寿命可。 +-- 解法: y = log t + log T を (1/T, S) の 2 変量 OLS で fit (intercept 含む)。 +-- β0 = log A、 β1 = Ea / k_B、 β2 = B +-- +-- [English]: Fits the Eyring model. +-- +-- Model: @t · T = A · exp(Ea / (k_B · T)) · exp(B · S)@ +-- Equivalently: @log t = log A − log T + Ea/(k_B · T) + B · S@ +-- +-- Input: @[(temperature_K, stress, [lifetimes])]@. Multiple lifetimes are +-- allowed per (T, S) combination. +-- Method: fits y = log t + log T via bivariate OLS on (1/T, S) (including +-- an intercept). +-- β0 = log A, β1 = Ea / k_B, β2 = B +fitEyring :: [(Double, Double, [Double])] -> Either Text EyringFit +fitEyring input = do + () <- if null input then Left "fitEyring: empty input" else Right () + let pairs = + [ (t, s, life) + | (t, s, lives) <- input + , life <- lives + ] + () <- if null pairs + then Left "fitEyring: no lifetime observations" + else Right () + () <- if any (\(t, _, l) -> t <= 0 || l <= 0) pairs + then Left "fitEyring: temperatures and lifetimes must be > 0" + else Right () + let distinctTS = nubByPair [ (t, s) | (t, s, _) <- pairs ] + () <- if length distinctTS < 3 + then Left "fitEyring: need at least 3 distinct (T, S) combinations" + else Right () + let xRows = [ [1, 1 / t, s] | (t, s, _) <- pairs ] + ys = [ log l + log t | (t, _, l) <- pairs ] + xMat = LA.fromLists xRows :: LA.Matrix Double + yVec = LA.fromList ys :: LA.Vector Double + -- normal equations: β = (XᵀX)⁻¹ Xᵀy + xt = LA.tr xMat + xtx = xt LA.<> xMat + xty = xt LA.#> yVec + betaList <- case LA.linearSolve xtx (LA.asColumn xty) of + Just m -> Right (LA.toList (LA.flatten m)) + Nothing -> Left "fitEyring: design matrix is singular (collinear T/S?)" + case betaList of + [b0, b1, b2] -> do + let n = length pairs + a = exp b0 + ea = b1 * kBoltzmann + bCoef = b2 + yHat = LA.toList (xMat LA.#> LA.fromList [b0, b1, b2]) + sse = sum [ (y - yh) ** 2 | (y, yh) <- zip ys yHat ] + dof = max 1 (n - 3) + sigma2 = sse / fromIntegral dof + ll = -0.5 * fromIntegral n * (log (2 * pi * sigma2) + 1) + Right EyringFit + { efA = a + , efEa = ea + , efB = bCoef + , efLogLik = ll + , efN = n + } + _ -> Left "fitEyring: linearSolve returned unexpected length" + +-- | [日本語]: (T, S) ペアの重複除去。 +-- [English]: Deduplicates (T, S) pairs. +nubByPair :: [(Double, Double)] -> [(Double, Double)] +nubByPair = go [] + where + go acc [] = reverse acc + go acc (p:ps) | p `elem` acc = go acc ps + | otherwise = go (p : acc) ps + +-- =========================================================================== +-- Inverse Power Law モデル (Phase 2.6) +-- =========================================================================== + +-- | [日本語]: Inverse Power Law fit: @t = A · S^(-n)@ +-- [English]: Inverse Power Law fit: @t = A · S^(-n)@. +data InversePowerFit = InversePowerFit + { ipfA :: !Double + , ipfN :: !Double -- パワー指数 + , ipfLogLik :: !Double + , ipfNobs :: !Int + } deriving (Show) + +-- | [日本語]: Inverse Power Law モデルの fit。 +-- +-- モデル: @t = A · S^(-n)@ +-- log 変換: @log t = log A − n · log S@ +-- +-- 入力: @[(stress, [lifetimes])]@。 stress > 0、 lifetime > 0 必須。 +-- 解法: y = log t を log S の単変量 OLS で fit。 傾き = -n。 +-- +-- [English]: Fits the Inverse Power Law model. +-- +-- Model: @t = A · S^(-n)@ +-- Log transform: @log t = log A − n · log S@ +-- +-- Input: @[(stress, [lifetimes])]@. Requires stress > 0 and lifetime > 0. +-- Method: fits y = log t via univariate OLS on log S. Slope = -n. +fitInversePower :: [(Double, [Double])] -> Either Text InversePowerFit +fitInversePower input = do + () <- if null input then Left "fitInversePower: empty input" else Right () + let pairs = + [ (s, life) + | (s, lives) <- input + , life <- lives + ] + () <- if null pairs + then Left "fitInversePower: no lifetime observations" + else Right () + () <- if any (\(s, l) -> s <= 0 || l <= 0) pairs + then Left "fitInversePower: stress and lifetimes must be > 0" + else Right () + let distinctS = length (nubByDouble (map fst pairs)) + () <- if distinctS < 2 + then Left "fitInversePower: need at least 2 distinct stress levels" + else Right () + let xs = map (\(s, _) -> log s) pairs + ys = map (\(_, l) -> log l) pairs + n = length pairs + meanX = sum xs / fromIntegral n + meanY = sum ys / fromIntegral n + sxx = sum [ (x - meanX) ** 2 | x <- xs ] + sxy = sum [ (x - meanX) * (y - meanY) | (x, y) <- zip xs ys ] + () <- if sxx <= 0 + then Left "fitInversePower: zero variance in log S" + else Right () + let slope = sxy / sxx -- = -n + b0 = meanY - slope * meanX + a = exp b0 + nExp = - slope + yHat = [ b0 + slope * x | x <- xs ] + sse = sum [ (y - yh) ** 2 | (y, yh) <- zip ys yHat ] + sigma2 = if n > 2 then sse / fromIntegral (n - 2) else sse / fromIntegral n + ll = -0.5 * fromIntegral n * (log (2 * pi * sigma2) + 1) + Right InversePowerFit + { ipfA = a + , ipfN = nExp + , ipfLogLik = ll + , ipfNobs = n + } diff --git a/src/Hanalyze/Model/ReliabilityBlockDiagram.hs b/src/Hanalyze/Model/ReliabilityBlockDiagram.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/ReliabilityBlockDiagram.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Hanalyze.Model.ReliabilityBlockDiagram +-- Description : 信頼性ブロック図 (RBD) の直列/並列/k-out-of-n 再帰合成による系全体信頼度計算 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Reliability Block Diagram (RBD). +-- +-- Computes system reliability from a structural composition of components +-- with known individual reliabilities. The three primitive combinators +-- are the textbook ones (e.g. O'Connor & Kleyner, /Practical Reliability +-- Engineering/): +-- +-- * Series (every block must work): +-- @R = ∏ Rᵢ@ +-- * Parallel (any block working suffices): +-- @R = 1 − ∏ (1 − Rᵢ)@ +-- * k-out-of-n (at least @k@ of @n@ blocks must work): +-- @R = Σ_{i = k}^{n} P(exactly i succeed)@ +-- computed by Poisson-binomial DP — works with heterogeneous block +-- reliabilities (the binomial closed form is the homogeneous +-- special case). +-- +-- Blocks can be arbitrarily nested. Failure independence between blocks +-- is assumed (the standard RBD assumption). +-- +-- @ +-- import Hanalyze.Model.ReliabilityBlockDiagram +-- +-- -- Two-out-of-three redundancy of three series strings: +-- let sys = KofN 2 [ Series [Leaf 0.95, Leaf 0.99] +-- , Series [Leaf 0.95, Leaf 0.99] +-- , Series [Leaf 0.95, Leaf 0.99] ] +-- r = reliabilityOf sys +-- @ +-- +-- == Implemented +-- +-- * 'RBDBlock' — composable tree of components. +-- * 'reliabilityOf' — recursive evaluation. +module Hanalyze.Model.ReliabilityBlockDiagram + ( RBDBlock (..) + , reliabilityOf + ) where + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +-- | A block in a reliability diagram. @Leaf p@ is a single component with +-- reliability @p ∈ [0, 1]@; the other constructors compose sub-blocks. +data RBDBlock + = Leaf !Double + | Series ![RBDBlock] + | Parallel ![RBDBlock] + | KofN !Int ![RBDBlock] + deriving (Show, Eq) + +-- --------------------------------------------------------------------------- +-- Evaluation +-- --------------------------------------------------------------------------- + +-- | System reliability of a block, in @[0, 1]@. Component reliabilities +-- are assumed independent (the standard RBD assumption). +reliabilityOf :: RBDBlock -> Double +reliabilityOf (Leaf p) = p +reliabilityOf (Series bs) = product (map reliabilityOf bs) +reliabilityOf (Parallel bs) = 1 - product [ 1 - reliabilityOf b | b <- bs ] +reliabilityOf (KofN k bs) + | k <= 0 = 1 -- always satisfied + | k > length bs = 0 -- impossible + | otherwise = + let ps = map reliabilityOf bs + n = length ps + -- Poisson-binomial DP: pmf!!i = P(exactly i blocks work). + pmf = foldr step [1.0] ps + where + step pi acc = + -- acc = pmf of current partial product (length = current j + 1). + let len = length acc + in [ let aPrev = if i - 1 >= 0 then acc !! (i - 1) else 0 + aHere = if i < len then acc !! i else 0 + in pi * aPrev + (1 - pi) * aHere + | i <- [0 .. len] ] + in sum (drop k pmf) diff --git a/src/Hanalyze/Model/Robust.hs b/src/Hanalyze/Model/Robust.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Robust.hs @@ -0,0 +1,304 @@ +-- | +-- Module : Hanalyze.Model.Robust +-- Description : IRLS による Huber / Tukey biweight ロバスト回帰 (M-estimator) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: IRLS による Huber / Tukey biweight ロバスト回帰 (M-estimator)。 +-- +-- 外れ値を含むデータに対する線形回帰。 OLS の二乗損失を bounded influence +-- 関数 (Huber / Tukey biweight) に置き換え、 Iteratively Reweighted Least +-- Squares で β を求める。 JMP "Fit Model > Personality: Robust Fit"、 +-- R `MASS::rlm` 相当。 +-- +-- ## アルゴリズム +-- +-- 1. β を OLS で初期化 +-- 2. 残差 @r_i = y_i - x_i^T β@ を計算 +-- 3. ロバストスケール推定 @σ̂ = MAD(r) / 0.6745@ +-- 4. 影響関数から重み @w_i@ を計算 ('huberWeight' / 'tukeyWeight') +-- 5. 加重 LS で β を更新: @β ← (X^T W X)^{-1} X^T W y@ +-- 6. 収束まで 2-5 を繰り返す +-- +-- ## 推定子の選択 +-- +-- - __Huber__ (@k=1.345@、 95% 効率): 線形 + 線形クリップ、 滑らか、 標準 +-- - __Tukey biweight__ (@c=4.685@、 95% 効率): 完全棄却閾値付き、 外れ値の +-- 影響を 0 に落とす、 だが多峰目的関数 (OLS 初期化が重要) +-- +-- Reference: +-- Huber (1964) "Robust estimation of a location parameter". +-- Tukey (1977) biweight、 Rousseeuw-Leroy (1987) 教科書。 +-- +-- [English]: Huber \/ Tukey biweight robust regression (M-estimator) via IRLS. +-- +-- Linear regression for data containing outliers. Replaces OLS's squared +-- loss with a bounded-influence function (Huber \/ Tukey biweight) and +-- solves for β with Iteratively Reweighted Least Squares. Equivalent to +-- JMP's "Fit Model > Personality: Robust Fit" or R's @MASS::rlm@. +-- +-- ## Algorithm +-- +-- 1. Initialize β with OLS +-- 2. Compute residuals @r_i = y_i - x_i^T β@ +-- 3. Estimate robust scale @σ̂ = MAD(r) / 0.6745@ +-- 4. Compute weights @w_i@ from the influence function ('huberWeight' \/ 'tukeyWeight') +-- 5. Update β via weighted LS: @β ← (X^T W X)^{-1} X^T W y@ +-- 6. Repeat 2-5 until convergence +-- +-- ## Choice of estimator +-- +-- - __Huber__ (@k=1.345@, 95% efficiency): linear + linear clipping, smooth, standard +-- - __Tukey biweight__ (@c=4.685@, 95% efficiency): has a hard rejection +-- threshold, drives the influence of outliers to 0, but has a multimodal +-- objective function (OLS initialization matters) +-- +-- Reference: +-- Huber (1964) "Robust estimation of a location parameter". +-- Tukey (1977) biweight, Rousseeuw-Leroy (1987) textbook. +module Hanalyze.Model.Robust + ( RobustEstimator (..) + , RobustFit (..) + , defaultHuberK + , defaultTukeyC + , fitRobustLM + , huberWeight + , tukeyWeight + , psiFn + , psiDerivFn + , robustCovBeta + ) where + +import qualified Numeric.LinearAlgebra as LA +import Data.List (sort) + +-- --------------------------------------------------------------------------- +-- 型 +-- --------------------------------------------------------------------------- + +-- | [日本語]: M-estimator の選択。 LTS (Least Trimmed Squares) は非凸組合せ +-- 最適化なので、 別途候補として今後の対応課題とする (regression-advanced 系 +-- の後続検討 §RR3 参照)。 +-- [English]: Choice of M-estimator. LTS (Least Trimmed Squares) is a +-- non-convex combinatorial optimization problem, so it remains a future +-- candidate for later work (see the follow-up discussion in the +-- regression-advanced material, §RR3). +data RobustEstimator + = Huber !Double -- ^ [日本語]: @k@ (= 1.345 で 95% 効率、 = 'defaultHuberK')。 [English]: @k@ (= 1.345 for 95% efficiency, = 'defaultHuberK'). + | Tukey !Double -- ^ [日本語]: @c@ (= 4.685 で 95% 効率、 = 'defaultTukeyC')。 [English]: @c@ (= 4.685 for 95% efficiency, = 'defaultTukeyC'). + deriving (Show, Eq) + +data RobustFit = RobustFit + { rfCoef :: !(LA.Vector Double) -- ^ [日本語]: 係数 β̂。 [English]: Coefficients β̂. + , rfScale :: !Double -- ^ [日本語]: ロバストスケール σ̂ (MAD-based)。 [English]: Robust scale σ̂ (MAD-based). + , rfWeights :: !(LA.Vector Double) -- ^ [日本語]: 最終 IRLS 重み (≤ 1)。 [English]: Final IRLS weights (≤ 1). + , rfFitted :: !(LA.Vector Double) -- ^ [日本語]: ŷ = Xβ̂。 [English]: ŷ = Xβ̂. + , rfResiduals :: !(LA.Vector Double) -- ^ [日本語]: y - ŷ。 [English]: y - ŷ. + , rfIterations :: !Int -- ^ [日本語]: IRLS 反復回数。 [English]: Number of IRLS iterations. + , rfConverged :: !Bool -- ^ [日本語]: tol 内収束したか。 [English]: Whether it converged within tol. + , rfEstimator :: !RobustEstimator -- ^ [日本語]: 使用した estimator。 [English]: The estimator used. + } deriving (Show) + +-- | [日本語]: Huber の標準値 (95% Gaussian 効率): @k = 1.345@。 +-- [English]: Huber's standard value (95% Gaussian efficiency): @k = 1.345@. +defaultHuberK :: Double +defaultHuberK = 1.345 + +-- | [日本語]: Tukey biweight の標準値 (95% Gaussian 効率): @c = 4.685@。 +-- [English]: Tukey biweight's standard value (95% Gaussian efficiency): @c = 4.685@. +defaultTukeyC :: Double +defaultTukeyC = 4.685 + +-- --------------------------------------------------------------------------- +-- 重み関数 (= ψ(u)/u where ψ is the influence function) +-- --------------------------------------------------------------------------- + +-- | [日本語]: Huber 重み: @w(u) = 1@ if @|u| ≤ k@、 @k/|u|@ otherwise。 +-- ここで @u = r / σ@ (標準化残差)。 +-- [English]: Huber weight: @w(u) = 1@ if @|u| ≤ k@, @k/|u|@ otherwise. +-- Here @u = r / σ@ (the standardized residual). +huberWeight :: Double -> Double -> Double +huberWeight k u + | absU <= k = 1 + | absU == 0 = 1 + | otherwise = k / absU + where absU = abs u + +-- | [日本語]: Tukey biweight 重み: @w(u) = (1 - (u/c)²)²@ if @|u| ≤ c@、 @0@ otherwise。 +-- [English]: Tukey biweight weight: @w(u) = (1 - (u/c)²)²@ if @|u| ≤ c@, @0@ otherwise. +tukeyWeight :: Double -> Double -> Double +tukeyWeight c u + | absU >= c = 0 + | otherwise = let t = u / c + s = 1 - t * t + in s * s + where absU = abs u + +-- --------------------------------------------------------------------------- +-- 影響関数 ψ とその導関数 ψ' (M 推定量の漸近共分散に使う) +-- ψ(u) = w(u)·u (重み × 標準化残差)。 +-- --------------------------------------------------------------------------- + +-- | [日本語]: 影響関数 @ψ(u) = w(u)·u@ (= 標準化残差に重みを掛けたスコア)。 +-- Huber: @u@ (|u|≤k) / @k·sign u@ (それ以外)。 Tukey: @u(1-(u/c)²)²@ (|u|≤c) / 0。 +-- [English]: Influence function @ψ(u) = w(u)·u@ (= the score obtained by +-- weighting the standardized residual). Huber: @u@ (|u|≤k) / @k·sign u@ +-- (otherwise). Tukey: @u(1-(u/c)²)²@ (|u|≤c) / 0. +psiFn :: RobustEstimator -> Double -> Double +psiFn (Huber k) u = huberWeight k u * u +psiFn (Tukey c) u = tukeyWeight c u * u + +-- | [日本語]: ψ の導関数 @ψ'(u)@ (M 推定量サンドイッチ分散の分母項)。 +-- Huber: @1@ (|u|≤k) / @0@。 Tukey: @(1-(u/c)²)(1-5(u/c)²)@ (|u|≤c) / 0。 +-- [English]: Derivative of ψ, @ψ'(u)@ (the denominator term of the +-- M-estimator's sandwich variance). Huber: @1@ (|u|≤k) / @0@. Tukey: +-- @(1-(u/c)²)(1-5(u/c)²)@ (|u|≤c) / 0. +psiDerivFn :: RobustEstimator -> Double -> Double +psiDerivFn (Huber k) u = if abs u <= k then 1 else 0 +psiDerivFn (Tukey c) u + | abs u >= c = 0 + | otherwise = let t2 = (u / c) * (u / c) + in (1 - t2) * (1 - 5 * t2) + +-- --------------------------------------------------------------------------- +-- M 推定量の漸近共分散 (サンドイッチ・statsmodels RLM cov="H1") +-- --------------------------------------------------------------------------- + +-- | [日本語]: M 推定量 β̂ の漸近共分散行列。 statsmodels @RLM@ 既定 (cov="H1") に一致: +-- +-- @ +-- u_i = r_i / σ̂ (標準化残差) +-- m = mean ψ'(u_i) +-- K = 1 + (p\/n)·Var(ψ')\/m² (自由度補正) +-- cov = K²·(σ̂²·Σψ(u_i)²\/(n−p))\/m² · (XᵀX)⁻¹ +-- @ +-- +-- SE は @sqrt (diag cov)@、 β̂±z·SE が Wald 信頼区間 (RLM は正規分布で z)。 +-- [English]: The asymptotic covariance matrix of the M-estimator β̂. +-- Matches statsmodels @RLM@'s default (cov="H1"): +-- +-- @ +-- u_i = r_i / σ̂ (standardized residual) +-- m = mean ψ'(u_i) +-- K = 1 + (p\/n)·Var(ψ')\/m² (degrees-of-freedom correction) +-- cov = K²·(σ̂²·Σψ(u_i)²\/(n−p))\/m² · (XᵀX)⁻¹ +-- @ +-- +-- The SE is @sqrt (diag cov)@; β̂±z·SE gives the Wald confidence interval +-- (RLM uses z from the normal distribution). +robustCovBeta + :: RobustEstimator -- ^ [日本語]: 使用した estimator (ψ/ψ' を決める)。 [English]: The estimator used (determines ψ\/ψ'). + -> Double -- ^ [日本語]: ロバストスケール σ̂ ('rfScale')。 [English]: The robust scale σ̂ ('rfScale'). + -> LA.Vector Double -- ^ [日本語]: 残差 r = y − ŷ ('rfResiduals')。 [English]: Residuals r = y − ŷ ('rfResiduals'). + -> LA.Matrix Double -- ^ [日本語]: 設計行列 X (intercept 列付き)。 [English]: The design matrix X (with an intercept column). + -> LA.Matrix Double -- ^ [日本語]: β̂ の共分散 (p × p)。 [English]: The covariance of β̂ (p × p). +robustCovBeta est scale resid x = + let n = LA.rows x + p = LA.cols x + u = LA.cmap (/ scale) resid + pderiv = LA.cmap (psiDerivFn est) u + m = meanV pderiv + varpp = meanV (LA.cmap (\v -> (v - m) * (v - m)) pderiv) -- 母分散 (ddof=0) + kcorr = 1 + (fromIntegral p / fromIntegral n) * varpp / (m * m) + sspsi = LA.sumElements (LA.cmap (\v -> let pv = psiFn est v in pv * pv) u) + xtxInv = LA.inv (LA.tr x LA.<> x) + factor = kcorr * kcorr + * (sspsi * scale * scale / fromIntegral (n - p)) / (m * m) + in LA.scale factor xtxInv + where + meanV v = LA.sumElements v / fromIntegral (LA.size v) + +-- --------------------------------------------------------------------------- +-- IRLS +-- --------------------------------------------------------------------------- + +-- | [日本語]: M-estimator IRLS で線形回帰を fit。 +-- +-- @X@ は @n × p@ (intercept 列は呼び出し側で付加)、 @y@ は長さ @n@。 +-- @maxIter@ デフォルト 50、 @tol@ デフォルト 1e-6。 +-- [English]: Fits a linear regression via M-estimator IRLS. +-- +-- @X@ is @n × p@ (the caller appends the intercept column); @y@ has length +-- @n@. @maxIter@ defaults to 50, @tol@ defaults to 1e-6. +fitRobustLM + :: RobustEstimator + -> LA.Matrix Double -- ^ [日本語]: X。 [English]: X. + -> LA.Vector Double -- ^ [日本語]: y。 [English]: y. + -> Int -- ^ [日本語]: max IRLS iterations。 [English]: Maximum number of IRLS iterations. + -> Double -- ^ [日本語]: @|Δβ|₂@ に対する許容誤差。 [English]: Tolerance on @|Δβ|₂@. + -> RobustFit +fitRobustLM est x y maxIter tol = + let -- 初期 β: OLS + beta0 = LA.flatten (x LA.<\> LA.asColumn y) + step beta = + let yHat = x LA.#> beta + resid = y - yHat + sigma = madScale resid + sigma' = if sigma < 1e-12 then 1e-12 else sigma + uVec = LA.cmap (/ sigma') resid + wVec = case est of + Huber k -> LA.cmap (huberWeight k) uVec + Tukey c -> LA.cmap (tukeyWeight c) uVec + -- 加重 LS: β ← (X^T W X)^{-1} X^T W y + wDiag = wVec + xtWx = LA.tr x LA.<> (x * LA.asColumn wDiag) + xtWy = LA.tr x LA.#> (wDiag * y) + betaN = LA.flatten (xtWx LA.<\> LA.asColumn xtWy) + in (betaN, sigma', wVec) + loop !k !beta + | k >= maxIter = (beta, k, False) + | otherwise = + let (betaN, _, _) = step beta + diff = LA.norm_2 (betaN - beta) + in if diff < tol + then (betaN, k + 1, True) + else loop (k + 1) betaN + (betaFinal, iters, converged) = loop 0 beta0 + yHatF = x LA.#> betaFinal + residF = y - yHatF + sigmaF = max 1e-12 (madScale residF) + uF = LA.cmap (/ sigmaF) residF + wF = case est of + Huber k -> LA.cmap (huberWeight k) uF + Tukey c -> LA.cmap (tukeyWeight c) uF + in RobustFit + { rfCoef = betaFinal + , rfScale = sigmaF + , rfWeights = wF + , rfFitted = yHatF + , rfResiduals = residF + , rfIterations = iters + , rfConverged = converged + , rfEstimator = est + } + +-- --------------------------------------------------------------------------- +-- ロバストスケール (Median Absolute Deviation) +-- --------------------------------------------------------------------------- + +-- | [日本語]: MAD ベースのロバストスケール推定: +-- @σ̂ = median(|r_i - median(r)|) / 0.6745@ (Gaussian 整合性)。 +-- ロバストスケール σ̂ = median(|r|) / Φ⁻¹(0.75)。 残差 r は intercept で中心化済 +-- ゆえ __中心 0__ で MAD を取る (= statsmodels RLM の @mad(resid, center=0)@ と一致。 +-- median 中心化は二重中心化になり scale が過小になる)。 定数は Φ⁻¹(0.75)=0.674489…。 +-- [English]: MAD-based robust scale estimate: +-- @σ̂ = median(|r_i - median(r)|) / 0.6745@ (for Gaussian consistency). +-- The robust scale σ̂ = median(|r|) / Φ⁻¹(0.75). Since the residuals r are +-- already centered by the intercept, the MAD is taken __around 0__ (matching +-- statsmodels RLM's @mad(resid, center=0)@; centering on the median again +-- would double-center and understate the scale). The constant is +-- Φ⁻¹(0.75)=0.674489…. +madScale :: LA.Vector Double -> Double +madScale v = + let dev = map abs (LA.toList v) -- 中心 0 (statsmodels RLM 準拠) + mad = medianList dev + in mad / 0.6744897501960817 + +medianList :: [Double] -> Double +medianList [] = 0 +medianList xs = + let s = sort xs + n = length s + in if odd n + then s !! (n `div` 2) + else 0.5 * (s !! (n `div` 2 - 1) + s !! (n `div` 2)) diff --git a/src/Hanalyze/Model/SVM.hs b/src/Hanalyze/Model/SVM.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/SVM.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Hanalyze.Model.SVM +-- Description : SMO ソルバによる双対形カーネル SVM (C-SVC) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: カーネル SVM (双対形・SMO ソルバ)。 +-- +-- 双対 C-SVC (hinge 損失) を SMO (Platt 1998) で解き、 共有カーネル語彙 +-- ('Hanalyze.Model.Kernel': Linear/Poly/RBF/Matern52/Periodic) と +-- __スパースな真のサポートベクタ__ (α>0 の点) を提供する。 既定カーネルは Linear で、 +-- 線形 SVM が必要なら kernel=Linear・非線形は RBF/Poly を選ぶ (R `e1071::svm` の kernel= 流)。 +-- +-- カーネルハイパラは 'KernelParams' (ℓ/σ_f²/period) を持つ。 GP の観測ノイズ σ_n² は +-- SVM には不要なので @GPParams@ でなく 'KernelParams' のみに依存する。 +-- +-- 双対問題: max_α Σα_i − ½ ΣΣ α_i α_j y_i y_j K(x_i,x_j) +-- s.t. 0 ≤ α_i ≤ C, Σ α_i y_i = 0 +-- +-- SMO は 2 変数 (α_i, α_j) ずつ解析更新する。 第 1 変数 = KKT 違反点、 +-- 第 2 変数 = @|E_i − E_j|@ 最大 (Platt の 2nd heuristic)。 +-- __乱数不使用ゆえ純粋・決定的__ (簡易 SMO の +-- ランダム j 選択は使わない)。 予測は Σ_{SV} α_i y_i K(x_i, x) + b (SV のみで決まる)。 +-- +-- カーネル評価は 'kEvalMV'(距離カーネルは ‖a−b‖²、 内積カーネル Linear/Poly は a·b、 +-- Poly の γ は 'kpLengthScale' から γ=1/(2ℓ²)・Linear の倍率は σ_f²)で共有する。 +-- +-- [English]: Kernel SVM (dual form, SMO solver). +-- +-- Solves the dual C-SVC (hinge loss) with SMO (Platt 1998), providing the +-- shared kernel vocabulary ('Hanalyze.Model.Kernel': +-- Linear\/Poly\/RBF\/Matern52\/Periodic) and +-- __truly sparse support vectors__ (points with α>0). The default +-- kernel is Linear; pick kernel=Linear for a linear SVM or RBF\/Poly for a nonlinear one +-- (following R's `e1071::svm` kernel= convention). +-- +-- Kernel hyperparameters live in 'KernelParams' (ℓ\/σ_f²\/period). Since +-- SVM has no need for the GP observation noise σ_n², it depends only on +-- 'KernelParams' rather than @GPParams@. +-- +-- Dual problem: max_α Σα_i − ½ ΣΣ α_i α_j y_i y_j K(x_i,x_j) +-- s.t. 0 ≤ α_i ≤ C, Σ α_i y_i = 0 +-- +-- SMO analytically updates two variables (α_i, α_j) at a time. The first +-- variable is the KKT-violating point; the second is chosen to maximize +-- @|E_i − E_j|@ (Platt's 2nd heuristic). +-- __Uses no randomness, hence pure and deterministic__ (unlike the +-- simplified SMO's random j selection). +-- Prediction is Σ_{SV} α_i y_i K(x_i, x) + b (determined only by the SVs). +-- +-- Kernel evaluation is shared via 'kEvalMV' (distance kernels use +-- ‖a−b‖²; inner-product kernels Linear\/Poly use a·b; Poly's γ is derived +-- from 'kpLengthScale' as γ=1/(2ℓ²); Linear's scale is σ_f²). +module Hanalyze.Model.SVM + ( SVMConfig (..) + , defaultSVM + , SVM (..) + , SVMMulti (..) + , fitSVM + , fitSVMMulti + , predictSVMScore + , predictSVM + , predictSVMMulti + , numSupportVectors + -- * 自動最適化 (k-fold CV グリッド探索・config に畳む) + , SVMHyper (..) + , SVMTuneGrid (..) + , defaultSVMTuneGrid + , tuneSVM + ) where + +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Numeric.LinearAlgebra as LA +import Data.Text (Text) +import Data.List (nub, sort, maximumBy) +import Data.Ord (comparing) +import Control.Monad.ST (runST) +import qualified System.Random.MWC as MWC +import Hanalyze.Stat.CV (Fold, kFold) +import Hanalyze.Model.Kernel (Kernel (..), KernelParams (..), defaultKernelParams, kEvalMV) + +-- =========================================================================== +-- カーネル (共有 'Kernel' + 'KernelParams' を使う) +-- =========================================================================== + +-- | [日本語]: Gram 行列 K (n×n)。 K_ij = kEvalMV ker params (row i) (row j)。 +-- [English]: The Gram matrix K (n×n). K_ij = kEvalMV ker params (row i) (row j). +kGram :: Kernel -> KernelParams -> LA.Matrix Double -> LA.Matrix Double +kGram ker p x = + let rv = V.fromList (LA.toRows x) -- boxed Vector of 行ベクトル (O(1) 添字) + n = V.length rv + in LA.build (n, n) (\i j -> kEvalMV ker p (rv V.! round i) (rv V.! round j)) + -- NB: LA.build の i,j は Double。 round で Int 添字に戻す (整数値ゆえ安全)。 + +-- =========================================================================== +-- 設定 / モデル +-- =========================================================================== + +data SVMConfig = SVMConfig + { svmC :: !Double -- ^ [日本語]: 正則化 C (0 ≤ α ≤ C)。 [English]: Regularization C (0 ≤ α ≤ C). + , svmKernel :: !Kernel -- ^ [日本語]: 共有カーネル (既定 'Linear')。 [English]: The shared kernel (default 'Linear'). + , svmParams :: !KernelParams -- ^ [日本語]: カーネルハイパラ (ℓ→γ=1/2ℓ²、 σ_f²=Linear 倍率)。 [English]: Kernel hyperparameters (ℓ→γ=1/2ℓ²; σ_f²=Linear scale). + , svmTol :: !Double -- ^ [日本語]: KKT 許容 (E の許容)。 [English]: KKT tolerance (tolerance on E). + , svmMaxPasses :: !Int -- ^ [日本語]: 変化が無いパスの連続上限 (収束判定)。 [English]: Maximum consecutive no-change passes (convergence check). + , svmMaxIter :: !Int -- ^ [日本語]: 総パス数の上限 (安全弁)。 [English]: Upper bound on the total number of passes (safety valve). + , svmHyper :: !SVMHyper -- ^ [日本語]: ハイパラの決め方 (固定 or CV グリッド探索)。 GP の + -- @HyperStrategy@ と同型: 調整は config に畳み動詞は @svmCls@ 一本。 + -- [English]: How hyperparameters are decided (fixed, or CV grid + -- search). Mirrors GP's @HyperStrategy@: tuning is folded into + -- the config, and there is a single verb @svmCls@. + } deriving (Show) + +defaultSVM :: SVMConfig +defaultSVM = SVMConfig + { svmC = 1.0, svmKernel = Linear, svmParams = defaultKernelParams + , svmTol = 1e-3, svmMaxPasses = 5, svmMaxIter = 1000 + , svmHyper = SVMFixed } + +-- | [日本語]: 学習済カーネル SVM。 __α>0 のサポートベクタのみ__保持 (スパース)。 +-- [English]: A fitted kernel SVM. Retains +-- __only the support vectors with α>0__ (sparse). +data SVM = SVM + { svmSVx :: !(LA.Matrix Double) -- ^ [日本語]: サポートベクタ (n_sv × d)。 [English]: Support vectors (n_sv × d). + , svmSVy :: !(VU.Vector Double) -- ^ [日本語]: その符号ラベル ±1。 [English]: Their sign labels ±1. + , svmSVa :: !(VU.Vector Double) -- ^ [日本語]: 双対係数 α (>0)。 [English]: Dual coefficients α (>0). + , svmB :: !Double -- ^ [日本語]: バイアス。 [English]: Bias. + , svmKern :: !Kernel -- ^ [日本語]: 共有カーネル。 [English]: The shared kernel. + , svmKParams :: !KernelParams -- ^ [日本語]: カーネルハイパラ (予測時に再利用)。 [English]: Kernel hyperparameters (reused at prediction time). + } deriving (Show) + +-- | [日本語]: サポートベクタ数 (= α>0 の点数)。 +-- [English]: Number of support vectors (= the count of points with α>0). +numSupportVectors :: SVM -> Int +numSupportVectors = LA.rows . svmSVx + +-- =========================================================================== +-- SMO (双対・2 クラス {0,1} → ±1) +-- =========================================================================== + +-- | [日本語]: 2 クラス C-SVC を SMO で学習 (y ∈ {0,1})。 決定的 (乱数不使用)。 +-- [English]: Fit a binary C-SVC via SMO (y ∈ {0,1}). Deterministic (no randomness). +fitSVM :: SVMConfig -> LA.Matrix Double -> VU.Vector Int -> SVM +fitSVM cfg x yInt = + let !n = LA.rows x + ys = VU.generate n (\i -> if yInt VU.! i == 0 then -1 else 1) :: VU.Vector Double + gram = kGram (svmKernel cfg) (svmParams cfg) x + cC = svmC cfg + tol = svmTol cfg + kij i j = gram `LA.atIndex` (i, j) + -- 決定関数 f(i) = Σ_j α_j y_j K_ij + b + decision al b i = b + sum [ al VU.! j * ys VU.! j * kij i j | j <- [0 .. n - 1] ] + -- 1 パス: 全 i を走査し KKT 違反点を見つけ第 2 変数を選んで更新。 + onePass (!al0, !b0) = + let step (al, b, changed) i = + let ei = decision al b i - ys VU.! i + ai = al VU.! i; yi = ys VU.! i + viol = (yi * ei < negate tol && ai < cC) || (yi * ei > tol && ai > 0) + in if not viol then (al, b, changed) + else + -- 第 2 変数 j = |E_i − E_j| 最大 (j /= i)。 + let es = [ (j, decision al b j - ys VU.! j) | j <- [0 .. n - 1], j /= i ] + (j, ej) = maximumBy (comparing (\(_, e) -> abs (ei - e))) es + aj = al VU.! j; yj = ys VU.! j + (lo, hi) = if yi /= yj + then (max 0 (aj - ai), min cC (cC + aj - ai)) + else (max 0 (ai + aj - cC), min cC (ai + aj)) + eta = 2 * kij i j - kij i i - kij j j + in if lo >= hi || eta >= 0 then (al, b, changed) + else + let ajNew0 = aj - yj * (ei - ej) / eta + ajNew = min hi (max lo ajNew0) + in if abs (ajNew - aj) < 1e-5 then (al, b, changed) + else + let aiNew = ai + yi * yj * (aj - ajNew) + al' = al VU.// [(i, aiNew), (j, ajNew)] + b1 = b - ei - yi * (aiNew - ai) * kij i i + - yj * (ajNew - aj) * kij i j + b2 = b - ej - yi * (aiNew - ai) * kij i j + - yj * (ajNew - aj) * kij j j + bNew | aiNew > 0 && aiNew < cC = b1 + | ajNew > 0 && ajNew < cC = b2 + | otherwise = (b1 + b2) / 2 + in (al', bNew, changed + 1) + in foldl step (al0, b0, 0 :: Int) [0 .. n - 1] + -- パスを回す: 変化無しが maxPasses 連続 or maxIter 到達で停止。 + loop !al !b !passes !iter + | passes >= svmMaxPasses cfg || iter >= svmMaxIter cfg = (al, b) + | otherwise = + let (al', b', changed) = onePass (al, b) + in if changed == 0 then loop al' b' (passes + 1) (iter + 1) + else loop al' b' 0 (iter + 1) + (alphaF, bF) = loop (VU.replicate n 0) 0 0 0 + -- α>0 のみ保持 (スパース SV)。 + svIdx = [ i | i <- [0 .. n - 1], alphaF VU.! i > 1e-8 ] + svX = LA.fromRows [ LA.toRows x !! i | i <- svIdx ] + svY = VU.fromList [ ys VU.! i | i <- svIdx ] + svA = VU.fromList [ alphaF VU.! i | i <- svIdx ] + in SVM { svmSVx = svX, svmSVy = svY, svmSVa = svA + , svmB = bF, svmKern = svmKernel cfg + , svmKParams = svmParams cfg } + +-- | [日本語]: 決定値 f(x) = Σ_{SV} α_i y_i K(x_i, x) + b (各行)。 +-- [English]: Decision value f(x) = Σ_{SV} α_i y_i K(x_i, x) + b (per row). +predictSVMScore :: SVM -> LA.Matrix Double -> VU.Vector Double +predictSVMScore m x = + let svRows = LA.toRows (svmSVx m) + nsv = length svRows + ker = svmKern m + kp = svmKParams m + score xr = svmB m + + sum [ svmSVa m VU.! s * svmSVy m VU.! s * kEvalMV ker kp (svRows !! s) xr + | s <- [0 .. nsv - 1] ] + in VU.fromList (map score (LA.toRows x)) + +-- | [日本語]: 予測ラベル {0,1} (score ≥ 0 → 1)。 +-- [English]: Predicted label {0,1} (score ≥ 0 → 1). +predictSVM :: SVM -> LA.Matrix Double -> VU.Vector Int +predictSVM m x = VU.map (\s -> if s >= 0 then 1 else 0) (predictSVMScore m x) + +-- =========================================================================== +-- 多クラス (one-vs-rest) +-- =========================================================================== + +data SVMMulti = SVMMulti + { svmmClasses :: ![Int] + , svmmBinaries :: ![SVM] -- ^ [日本語]: クラス順に 1-vs-rest。 [English]: One-vs-rest binaries, in class order. + , svmmClassNames :: ![Text] -- ^ [日本語]: クラス名 (df|-> が levels 注入・空=数値表示)。 [English]: Class names (injected as levels by df|->; empty means numeric display). + } deriving (Show) + +-- | [日本語]: 多クラス C-SVC (one-vs-rest・各 binary は 'fitSVM'・決定的)。 +-- [English]: Multiclass C-SVC (one-vs-rest; each binary uses 'fitSVM'; deterministic). +fitSVMMulti :: SVMConfig -> LA.Matrix Double -> VU.Vector Int -> SVMMulti +fitSVMMulti cfg x y = + let classes = sort (nub (VU.toList y)) + bins = [ fitSVM cfg x (VU.map (\yi -> if yi == c then 1 else 0) y) + | c <- classes ] + in SVMMulti { svmmClasses = classes, svmmBinaries = bins, svmmClassNames = [] } + +-- | [日本語]: 各クラスの score 最大で分類。 +-- [English]: Classify by the maximum score across classes. +predictSVMMulti :: SVMMulti -> LA.Matrix Double -> VU.Vector Int +predictSVMMulti m x = + let classes = svmmClasses m + scores = [ VU.toList (predictSVMScore b x) | b <- svmmBinaries m ] + n = LA.rows x + pick i = let col = [ (classes !! k, scores !! k !! i) | k <- [0 .. length classes - 1] ] + in fst (maximumBy (comparing snd) col) + in VU.fromList [ pick i | i <- [0 .. n - 1] ] + +-- =========================================================================== +-- 自動最適化 (k-fold CV グリッド探索) +-- +-- SVM は確率モデルでないため GP の周辺尤度最適化は使えない。 代わりに +-- **k-fold 交差検証の accuracy を最大化**する格子探索 (sklearn @GridSearchCV@ / +-- R `e1071::tune.svm` 相当)。 SMO は乱数不使用・fold 分割も固定 seed の +-- 'Hanalyze.Stat.CV.kFold' を 'runST' で回すため **完全に決定的**。 +-- =========================================================================== + +-- | [日本語]: ハイパラの決め方 (GP の @HyperStrategy@ と同型)。 固定値をそのまま使うか、 +-- CV グリッドを探索して最良を選ぶか。 'SVMConfig' の @svmHyper@ に持たせ、 動詞 @svmCls@ が +-- これを見て分岐する (別動詞 @svmClsTuned@ は作らない)。 +-- [English]: How hyperparameters are decided (mirrors GP's +-- @HyperStrategy@). Either use the fixed values as-is, or search a CV +-- grid and pick the best. Held in 'SVMConfig' as @svmHyper@, and the +-- verb @svmCls@ branches on it (no separate @svmClsTuned@ verb is made). +data SVMHyper + = SVMFixed -- ^ [日本語]: 'SVMConfig' の C/kernel/params をそのまま使う。 [English]: Use 'SVMConfig''s C/kernel/params as-is. + | SVMTuneCV SVMTuneGrid -- ^ [日本語]: グリッドを k-fold CV で探索し最良ハイパラで再学習。 [English]: Search the grid via k-fold CV and refit with the best hyperparameters. + deriving (Show) + +-- | [日本語]: SVM ハイパラ探索グリッド。 候補は C × kernel × ℓ の直積。 +-- 'Linear' カーネルは ℓ を使わないので ℓ 軸は無視する (重複評価を避ける)。 +-- [English]: SVM hyperparameter search grid. Candidates are the product +-- of C × kernel × ℓ. Since the 'Linear' kernel does not use ℓ, the ℓ +-- axis is ignored for it (to avoid duplicate evaluations). +data SVMTuneGrid = SVMTuneGrid + { svmtCs :: ![Double] -- ^ [日本語]: 正則化 C 候補 (0 < C)。 [English]: Regularization C candidates (0 < C). + , svmtKernels :: ![Kernel] -- ^ [日本語]: カーネル候補。 [English]: Kernel candidates. + , svmtLengths :: ![Double] -- ^ [日本語]: 長さスケール ℓ 候補 (距離カーネル/Poly の γ=1/2ℓ²)。 [English]: Length-scale ℓ candidates (γ=1/2ℓ² for distance kernels/Poly). + , svmtFolds :: !Int -- ^ [日本語]: CV fold 数 k (2 以上)。 [English]: Number of CV folds k (2 or more). + } deriving (Show) + +-- | [日本語]: 既定グリッド: C ∈ {0.1,1,10,100} × RBF × ℓ ∈ {0.25,0.5,1,2,4}・5-fold。 +-- [English]: Default grid: C ∈ {0.1,1,10,100} × RBF × ℓ ∈ {0.25,0.5,1,2,4}, 5-fold. +defaultSVMTuneGrid :: SVMTuneGrid +defaultSVMTuneGrid = SVMTuneGrid + { svmtCs = [0.1, 1, 10, 100] + , svmtKernels = [RBF] + , svmtLengths = [0.25, 0.5, 1, 2, 4] + , svmtFolds = 5 + } + +-- | [日本語]: グリッドの 1 点に対応する 'SVMConfig' を作る (base から C/kernel/ℓ を差し替え)。 +-- [English]: Build the 'SVMConfig' for one grid point (swaps C/kernel/ℓ from base). +tuneCandidate :: SVMConfig -> Double -> Kernel -> Double -> SVMConfig +tuneCandidate base c ker l = + base { svmC = c, svmKernel = ker + , svmParams = (svmParams base) { kpLengthScale = l } } + +-- | [日本語]: グリッドの全候補 'SVMConfig' (Linear は ℓ 軸を畳む)。 +-- [English]: All candidate 'SVMConfig's from the grid (Linear collapses the ℓ axis). +tuneCandidates :: SVMConfig -> SVMTuneGrid -> [SVMConfig] +tuneCandidates base grid = + [ tuneCandidate base c ker l + | c <- svmtCs grid + , ker <- svmtKernels grid + , l <- lengthsFor ker ] + where + lengthsFor Linear = take 1 (svmtLengths grid ++ [1.0]) -- ℓ 無関係 → 1 点 + lengthsFor _ = svmtLengths grid + +-- | [日本語]: 行添字リストで行列の行とラベルを抜き出す。 +-- [English]: Extract matrix rows and labels by a list of row indices. +sliceRows :: V.Vector (LA.Vector Double) -> VU.Vector Int -> [Int] + -> (LA.Matrix Double, VU.Vector Int) +sliceRows rows y idx = + ( LA.fromRows [ rows V.! i | i <- idx ] + , VU.fromList [ y VU.! i | i <- idx ] ) + +-- | [日本語]: 1 候補の平均 CV accuracy。 各 fold で train に学習し test の正解率を測る。 +-- [English]: Average CV accuracy for one candidate. Fits on train and +-- measures test accuracy for each fold. +cvAccuracy :: SVMConfig -> [Fold] + -> V.Vector (LA.Vector Double) -> VU.Vector Int -> Double +cvAccuracy cfg folds rows y = + let accs = [ foldAcc tr te | (tr, te) <- folds, not (null te) ] + foldAcc trIdx teIdx = + let (xTr, yTr) = sliceRows rows y trIdx + (xTe, yTe) = sliceRows rows y teIdx + model = fitSVMMulti cfg xTr yTr + pred = predictSVMMulti model xTe + nTe = VU.length yTe + ok = length [ () | i <- [0 .. nTe - 1], pred VU.! i == yTe VU.! i ] + in fromIntegral ok / fromIntegral nTe + in if null accs then 0 else sum accs / fromIntegral (length accs) + +-- | [日本語]: k-fold CV で SVM のハイパラ (C × kernel × ℓ) を調律する。 CV accuracy を +-- 最大化する 'SVMConfig' と、 その平均 CV accuracy を返す。 __決定的__ (固定 seed の +-- fold 分割・SMO は乱数不使用)。 sklearn @GridSearchCV@ / R `tune.svm` 相当。 +-- [English]: Tune the SVM hyperparameters (C × kernel × ℓ) via k-fold CV. +-- Returns the 'SVMConfig' that maximizes CV accuracy along with its mean +-- CV accuracy. __Deterministic__ (fixed-seed fold splits; SMO uses no +-- randomness). Equivalent to sklearn's @GridSearchCV@ \/ R's `tune.svm`. +tuneSVM :: SVMConfig -> SVMTuneGrid -> LA.Matrix Double -> VU.Vector Int + -> (SVMConfig, Double) +tuneSVM base grid x y = + let n = LA.rows x + rows = V.fromList (LA.toRows x) + k = max 2 (min (svmtFolds grid) n) + -- 固定 seed の k-fold (決定的・再現可能)。 + folds = runST $ do + gen <- MWC.initialize (V.singleton 42) + kFold k n gen + scored = [ (cfg, cvAccuracy cfg folds rows y) + | cfg <- tuneCandidates base grid ] + in maximumBy (comparing snd) scored diff --git a/src/Hanalyze/Model/Spline.hs b/src/Hanalyze/Model/Spline.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Spline.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Hanalyze.Model.Spline +-- Description : B-spline / 自然三次スプライン回帰 (Cox-de Boor 基底 + LM フィット) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- B-spline and natural cubic-spline regression. +-- +-- Builds a design matrix @B@ from spline basis functions and solves +-- ordinary least squares for the coefficients @β@: +-- +-- @ +-- y_i = Σ_j β_j B_j(x_i) + ε_i +-- @ +-- +-- * @bsplineBasis@ — degree-@k@ B-spline basis via the Cox-de Boor +-- recursion. +-- * 'naturalSplineBasis' — natural cubic spline (linear outside the +-- boundary). +-- * 'fitSpline' — fit using the basis matrix + LM. +-- * 'predictSpline' — predict at new @x@ values. +module Hanalyze.Model.Spline + ( SplineKind (..) + , SplineFit (..) + , SplineFitMulti (..) + , bsplineBasis + , naturalSplineBasis + , fitSpline + , fitSplineMulti + , predictSpline + , predictSplineMulti + , equalSpacedKnots + , quantileKnots + ) where + +import qualified Data.Vector as V +import qualified Numeric.LinearAlgebra as LA +import Data.List (sort) +import Hanalyze.Model.Core (FitResult (..)) +import Hanalyze.Model.LM (fitLM) + +-- | Spline kind. +data SplineKind + = BSpline Int -- ^ B-spline of degree @k@ (3 = cubic is typical). + | NaturalCubic -- ^ Natural cubic spline. + deriving (Show, Eq) + +-- | Spline fit result, with everything needed to reproduce predictions. +data SplineFit = SplineFit + { sfKind :: SplineKind + , sfKnots :: [Double] -- ^ Interior knots (boundaries included). + , sfBeta :: LA.Vector Double -- ^ Basis-coefficient vector. + , sfResult :: FitResult -- ^ Underlying linear-model fit. + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- B-spline basis (Cox-de Boor recursion) +-- --------------------------------------------------------------------------- + +-- | Evaluate every B-spline basis function at a single point. +-- +-- Inputs: degree @k@, extended knot sequence @t@ (length +-- @n_basis + k + 1@), and the evaluation point @x@. Returns +-- @[B_0(x), B_1(x), ..., B_{n_basis-1}(x)]@. +bsplineEval :: Int -> [Double] -> Double -> [Double] +bsplineEval k tKnots x = + let nBasis = length tKnots - k - 1 + -- Order 0 (= k=0): 1 if x in [t_i, t_{i+1}), else 0 + -- 端点処理: 右端 x == hi は **hi で終わる最後の正幅区間** [ti, hi) に含める。 + -- clamped ノットは hi を k+1 回重複させるため、 単純に「最後の区間 index を右閉」 + -- にすると退化区間 [hi, hi] を選んでしまい、 高次 Cox-de Boor 再帰で d2=0 となって + -- 基底が全ゼロ化する (= partition of unity 崩壊。 計測で確認: x=hi で sum=0)。 + hiKnot = last tKnots + order0 i = + let ti = tKnots !! i + ti1 = tKnots !! (i + 1) + atRightEnd = x >= ti1 && ti1 == hiKnot && ti < ti1 + in if (x >= ti && x < ti1) || atRightEnd + then 1.0 else 0.0 + -- 高次: Cox-de Boor + go p prev = + let n_p = length prev - 1 -- prev の長さは n + p + in [ let ti = tKnots !! i + tipk = tKnots !! (i + p) + ti1 = tKnots !! (i + 1) + ti1pk = tKnots !! (i + p + 1) + d1 = tipk - ti + d2 = ti1pk - ti1 + a = if d1 == 0 then 0 + else (x - ti) / d1 * (prev !! i) + b = if d2 == 0 then 0 + else (ti1pk - x) / d2 * (prev !! (i + 1)) + in a + b + | i <- [0 .. n_p - 1] ] + step p prev | p > k = prev + | otherwise = step (p + 1) (go p prev) + ord0 = [order0 i | i <- [0 .. length tKnots - 2]] + in take nBasis (step 1 ord0) + +-- | B-spline basis matrix. +-- +-- Inputs: +-- +-- * @k@ — degree (3 typical). +-- * @intKnots@ — interior knots (boundaries included; assumed sorted). +-- * @xs@ — evaluation points. +-- +-- The output matrix has shape @n × n_basis@ where +-- @n_basis = length intKnots + k - 1@. The extended knot sequence is +-- built by replicating each boundary @k+1@ times (clamped B-spline). +bsplineBasis :: Int -> [Double] -> V.Vector Double -> LA.Matrix Double +bsplineBasis k intKnots xs = + let knots = sort intKnots + lo = head knots + hi = last knots + tExt = replicate (k + 1) lo + ++ tail (init knots) -- 内部ノット + ++ replicate (k + 1) hi + -- 上で tExt の長さは (k+1) + (length knots - 2) + (k+1) = length knots + 2k + -- n_basis = length knots + 2k - k - 1 = length knots + k - 1 + rows = [ bsplineEval k tExt x | x <- V.toList xs ] + in LA.fromLists rows + +-- --------------------------------------------------------------------------- +-- Natural cubic spline basis +-- --------------------------------------------------------------------------- + +-- | [日本語]: 自然三次スプライン基底 (両端点で 2 階微分が 0・境界外では線形)。 +-- +-- ノット K1 < K2 < ... < KN に対して、N 個の基底関数: +-- N_1(x) = 1 +-- N_2(x) = x +-- N_{k+2}(x) = d_k(x) - d_{N-1}(x) for k = 1..N-2 +-- where +-- d_k(x) = [(x - K_k)_+^3 - (x - K_N)_+^3] / (K_N - K_k) +-- +-- 出力: 行列 (n × N)。 +-- +-- [English]: Natural cubic-spline basis (zero second derivative at the +-- boundaries; linear outside the boundary). +-- +-- For knots K1 < K2 < ... < KN, N basis functions: +-- N_1(x) = 1 +-- N_2(x) = x +-- N_{k+2}(x) = d_k(x) - d_{N-1}(x) for k = 1..N-2 +-- where +-- d_k(x) = [(x - K_k)_+^3 - (x - K_N)_+^3] / (K_N - K_k) +-- +-- Output: a matrix (n × N). +naturalSplineBasis :: [Double] -> V.Vector Double -> LA.Matrix Double +naturalSplineBasis knots xs = + let ks = sort knots + n = length ks + kN = last ks + kNm1 = ks !! (n - 2) + pos3 v = if v <= 0 then 0 else v ^ (3 :: Int) + d k x = + let kk = ks !! k + in (pos3 (x - kk) - pos3 (x - kN)) / (kN - kk) + basis x = + [1.0, x] ++ + [ d k x - d (n - 2) x | k <- [0 .. n - 3] ] + in LA.fromLists [basis xv | xv <- V.toList xs] + +-- --------------------------------------------------------------------------- +-- Fit / predict +-- --------------------------------------------------------------------------- + +-- | Single-output spline regression. Delegates to 'fitSplineMulti' by +-- promoting @y@ to a one-column matrix. +fitSpline :: SplineKind -> [Double] -> V.Vector Double -> V.Vector Double -> SplineFit +fitSpline kind knots xs ys = + let yMat = LA.asColumn (LA.fromList (V.toList ys)) + mf = fitSplineMulti kind knots xs yMat + beta = LA.flatten (smfBeta mf LA.¿ [0]) + in SplineFit kind knots beta (smfResult mf) + +-- | Predict at new @x@ values from a 'SplineFit'. +predictSpline :: SplineFit -> V.Vector Double -> V.Vector Double +predictSpline fit xsNew = + let dm = case sfKind fit of + BSpline k -> bsplineBasis k (sfKnots fit) xsNew + NaturalCubic -> naturalSplineBasis (sfKnots fit) xsNew + yPred = dm LA.#> sfBeta fit + in V.fromList (LA.toList yPred) + +-- | Multi-output spline regression: fit @q@ outputs jointly on the same +-- @x@ grid. Internally a basis matrix plus a multi-output LM. +data SplineFitMulti = SplineFitMulti + { smfKind :: SplineKind + , smfKnots :: [Double] + , smfBeta :: LA.Matrix Double -- ^ Basis coefficients (@basis_dim × q@). + , smfResult :: FitResult + } deriving (Show) + +-- | Fit a multi-output spline. @Y@ has shape @n × q@; columns share the +-- basis but are otherwise fit independently. +fitSplineMulti :: SplineKind + -> [Double] -- ^ Knots. + -> V.Vector Double -- ^ Inputs @xs@ (length @n@). + -> LA.Matrix Double -- ^ Response @Y@ (@n × q@). + -> SplineFitMulti +fitSplineMulti kind knots xs ys = + let dm = case kind of + BSpline k -> bsplineBasis k knots xs + NaturalCubic -> naturalSplineBasis knots xs + r = fitLM dm ys + in SplineFitMulti kind knots (coefficients r) r + +-- | Predict @Ŷ@ at new inputs from a 'SplineFitMulti'. +predictSplineMulti :: SplineFitMulti -> V.Vector Double -> LA.Matrix Double +predictSplineMulti fit xsNew = + let dm = case smfKind fit of + BSpline k -> bsplineBasis k (smfKnots fit) xsNew + NaturalCubic -> naturalSplineBasis (smfKnots fit) xsNew + in dm LA.<> smfBeta fit + +-- --------------------------------------------------------------------------- +-- Knot helpers +-- --------------------------------------------------------------------------- + +-- | Equal-spaced knots (both endpoints included, @n@ points total). +equalSpacedKnots :: Int -> Double -> Double -> [Double] +equalSpacedKnots n lo hi + | n < 2 = [lo, hi] + | otherwise = [lo + fromIntegral i * (hi - lo) / fromIntegral (n - 1) + | i <- [0 .. n - 1]] + +-- | Quantile-based knots (boundaries at min/max, interior knots at +-- evenly-spaced sample quantiles). +quantileKnots :: Int -> V.Vector Double -> [Double] +quantileKnots n xs + | n < 2 = [V.minimum xs, V.maximum xs] + | otherwise = + let sorted = sort (V.toList xs) + m = length sorted + qAt p = sorted !! min (m - 1) (max 0 (floor (p * fromIntegral m) :: Int)) + ps = [fromIntegral i / fromIntegral (n - 1) | i <- [0 .. n - 1] :: [Int]] + in map qAt ps diff --git a/src/Hanalyze/Model/StateSpace.hs b/src/Hanalyze/Model/StateSpace.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/StateSpace.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Hanalyze.Model.StateSpace +-- Description : 線形ガウス状態空間モデルの Kalman Filter / RTS Smoother +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 線形ガウス状態空間モデル (Linear Gaussian State Space Model) + +-- Kalman Filter / RTS Smoother。 +-- +-- モデル: +-- +-- @ +-- x_t = F x_{t-1} + w_t, w_t ~ N(0, Q) +-- y_t = H x_t + v_t, v_t ~ N(0, R) +-- @ +-- +-- - 'kalmanFilter' は前向きフィルタリングで filtered mean / cov を計算し、 +-- 同時に innovation 系列の対数尤度 (= モデル尤度) を返す。 +-- - 'kalmanSmoother' は RTS (Rauch-Tung-Striebel) で smoothed mean / cov を +-- 後ろ向きに計算。 入力に既にフィルタ済の 'KalmanResult' を渡す。 +-- +-- すべて hmatrix Vector / Matrix で実装 (list 化禁止)。 +-- +-- [English]: The Linear Gaussian State Space Model plus a Kalman Filter \/ +-- RTS Smoother. +-- +-- Model: +-- +-- @ +-- x_t = F x_{t-1} + w_t, w_t ~ N(0, Q) +-- y_t = H x_t + v_t, v_t ~ N(0, R) +-- @ +-- +-- - 'kalmanFilter' computes the filtered mean \/ covariance via forward +-- filtering, and simultaneously returns the log-likelihood of the +-- innovation sequence (= the model likelihood). +-- - 'kalmanSmoother' computes the smoothed mean \/ covariance backward via +-- RTS (Rauch-Tung-Striebel). It takes an already-filtered 'KalmanResult' +-- as input. +-- +-- Implemented entirely with hmatrix Vector \/ Matrix (converting to lists is +-- forbidden). +module Hanalyze.Model.StateSpace + ( StateSpaceModel (..) + , KalmanResult (..) + , kalmanFilter + , kalmanSmoother + ) where + +import qualified Numeric.LinearAlgebra as LA + +-- =========================================================================== +-- 型 +-- =========================================================================== + +data StateSpaceModel = StateSpaceModel + { ssF :: !(LA.Matrix Double) -- ^ [日本語]: 状態遷移行列 F (n_x × n_x)。 [English]: The state transition matrix F (n_x × n_x). + , ssH :: !(LA.Matrix Double) -- ^ [日本語]: 観測行列 H (n_y × n_x)。 [English]: The observation matrix H (n_y × n_x). + , ssQ :: !(LA.Matrix Double) -- ^ [日本語]: プロセスノイズ共分散 Q (n_x × n_x)。 [English]: The process noise covariance Q (n_x × n_x). + , ssR :: !(LA.Matrix Double) -- ^ [日本語]: 観測ノイズ共分散 R (n_y × n_y)。 [English]: The observation noise covariance R (n_y × n_y). + , ssX0 :: !(LA.Vector Double) -- ^ [日本語]: 初期状態 (n_x)。 [English]: The initial state (n_x). + , ssP0 :: !(LA.Matrix Double) -- ^ [日本語]: 初期共分散 (n_x × n_x)。 [English]: The initial covariance (n_x × n_x). + } deriving (Show) + +data KalmanResult = KalmanResult + { krFilteredMean :: ![LA.Vector Double] + , krFilteredCov :: ![LA.Matrix Double] + , krSmoothedMean :: ![LA.Vector Double] + -- ^ [日本語]: 'kalmanFilter' のみ呼んだ場合は空。 'kalmanSmoother' を通すと埋まる。 + -- [English]: Empty if only 'kalmanFilter' was called. Populated once + -- passed through 'kalmanSmoother'. + , krSmoothedCov :: ![LA.Matrix Double] + , krLogLik :: !Double -- ^ [日本語]: Σ log p(y_t | y_{1:t-1})。 [English]: Σ log p(y_t | y_{1:t-1}). + } deriving (Show) + +-- =========================================================================== +-- Kalman Filter (forward pass) +-- =========================================================================== + +-- | [日本語]: 観測系列 ys (各列が 1 時点の観測ベクトル) からフィルタリング。 +-- ys の行 = 観測次元 n_y、 列 = 時点数 T。 +-- [English]: Filters from an observation sequence ys (each column is one +-- time point's observation vector). ys's rows = observation dimension +-- n_y, columns = number of time points T. +kalmanFilter :: StateSpaceModel -> LA.Matrix Double -> KalmanResult +kalmanFilter ssm ys = + let nY = LA.rows ys + _ = nY :: Int + tT = LA.cols ys + f = ssF ssm + h = ssH ssm + q = ssQ ssm + r = ssR ssm + step (x, p, accM, accP, ll) t = + let yt = LA.flatten (ys LA.¿ [t]) + -- predict + xPred = f LA.#> x + pPred = f LA.<> p LA.<> LA.tr f + q + -- update + yPred = h LA.#> xPred + sInn = h LA.<> pPred LA.<> LA.tr h + r + -- guard against singular S + sInv = LA.inv sInn + gain = pPred LA.<> LA.tr h LA.<> sInv + inn = yt - yPred + xNew = xPred + gain LA.#> inn + pNew = pPred - gain LA.<> h LA.<> pPred + -- log-likelihood contribution + nY_ = fromIntegral (LA.size inn) :: Double + detS = LA.det sInn + quad = inn `LA.dot` (sInv LA.#> inn) + lt = -0.5 * (nY_ * log (2 * pi) + log (max 1e-300 detS) + quad) + in (xNew, pNew, accM ++ [xNew], accP ++ [pNew], ll + lt) + (_, _, ms, ps, llTotal) = + foldl step (ssX0 ssm, ssP0 ssm, [], [], 0) [0 .. tT - 1] + in KalmanResult + { krFilteredMean = ms + , krFilteredCov = ps + , krSmoothedMean = [] + , krSmoothedCov = [] + , krLogLik = llTotal + } + +-- =========================================================================== +-- RTS Smoother (backward pass) +-- =========================================================================== + +-- | [日本語]: RTS smoother。 'kalmanFilter' の出力を受け取り smoothed * を埋めて返す。 +-- [English]: The RTS smoother. Takes the output of 'kalmanFilter' and +-- returns it with the smoothed * fields filled in. +kalmanSmoother :: StateSpaceModel -> KalmanResult -> KalmanResult +kalmanSmoother ssm kr = + let f = ssF ssm + q = ssQ ssm + ms = krFilteredMean kr + ps = krFilteredCov kr + tT = length ms + -- 末尾は filtered と smoothed が同じ + mTLast = last ms + pTLast = last ps + -- 後ろから前へ走査 + step (smMs, smPs) i = + let mFilt = ms !! i + pFilt = ps !! i + mPred = f LA.#> mFilt + pPred = f LA.<> pFilt LA.<> LA.tr f + q + mNext = head smMs + pNext = head smPs + g = pFilt LA.<> LA.tr f LA.<> LA.inv pPred + mNew = mFilt + g LA.#> (mNext - mPred) + pNew = pFilt + g LA.<> (pNext - pPred) LA.<> LA.tr g + in (mNew : smMs, pNew : smPs) + (smMsFinal, smPsFinal) = + foldl step ([mTLast], [pTLast]) (reverse [0 .. tT - 2]) + in kr { krSmoothedMean = smMsFinal + , krSmoothedCov = smPsFinal + } diff --git a/src/Hanalyze/Model/Survival.hs b/src/Hanalyze/Model/Survival.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Survival.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Hanalyze.Model.Survival +-- Description : 打ち切りを伴う生存時間解析 (Kaplan-Meier / Nelson-Aalen / log-rank / Cox PH) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Survival analysis. +-- +-- Time-to-event analysis under right censoring. Implements: +-- +-- * 'kaplanMeier' — non-parametric survival function estimator. +-- * 'nelsonAalen' — non-parametric cumulative hazard estimator. +-- * 'logRankTest' — compare survival between groups. +-- * 'coxPH' — Cox proportional hazards regression. +-- +-- == Convention +-- +-- A "survival" sample is @(time, event)@ where @time@ is duration and +-- @event ∈ {0, 1}@: @1@ = event observed (death, failure, etc.), +-- @0@ = censored (still alive at study end / dropout). All functions +-- accept the convention via @SurvSample@ records. +module Hanalyze.Model.Survival + ( -- * Common types + SurvSample (..) + , Event (..) + -- * Non-parametric estimators + , KMResult (..) + , kaplanMeier + , NAResult (..) + , nelsonAalen + -- * Hypothesis tests + , LogRankResult (..) + , logRankTest + -- * Cox proportional hazards + , CoxFit (..) + , coxPH + , coxBaselineHazard + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified Statistics.Distribution as SD +import qualified Statistics.Distribution.ChiSquared as ChiSq +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Storable as VS +import Data.List (sort, sortBy, group) +import Data.Ord (comparing) + +-- --------------------------------------------------------------------------- +-- Common types +-- --------------------------------------------------------------------------- + +-- | Event indicator. +data Event = Censored | Observed deriving (Show, Eq, Ord) + +-- | A single observation: @(time, event)@. +data SurvSample = SurvSample + { ssTime :: !Double + , ssEvent :: !Event + } deriving (Show, Eq) + +-- --------------------------------------------------------------------------- +-- Kaplan-Meier +-- --------------------------------------------------------------------------- + +-- | Kaplan-Meier survival function estimator. +data KMResult = KMResult + { kmrTimes :: ![Double] -- ^ Distinct event times. + , kmrSurvival :: ![Double] -- ^ Ŝ(t) at each event time. + , kmrAtRisk :: ![Int] -- ^ Number at risk just before t_i. + , kmrEvents :: ![Int] -- ^ Number of events at t_i. + , kmrCensored :: ![Int] -- ^ Number censored at t_i. + } deriving (Show) + +-- | Compute the Kaplan-Meier estimator. +-- +-- @Ŝ(t_i) = Π_{j ≤ i} (1 − d_j / n_j)@ where @d_j@ is events at @t_j@ +-- and @n_j@ is the number at risk just before @t_j@. +-- +-- B9c: rewritten with a single sorted-vector pass + linear run-length +-- grouping (no @[s | s <- ss, ssTime s == t]@ filter for each time, +-- which was @O(n × distinct_times)@). On the n=2000 bench this drops +-- KM from ~33 ms to a few ms. +kaplanMeier :: [SurvSample] -> KMResult +kaplanMeier samples = + let !sorted = sortBy (comparing ssTime) samples + !n0 = length sorted + groups = runLengthGroups sorted + -- 累積生存は **先頭から** 積む: Ŝ(tᵢ) = ∏_{j ≤ i} (1 − dⱼ/nⱼ)。 + -- (旧実装は rest を先に再帰して右から積んでおり、 最終時点の (1−dⱼ/nⱼ)=0 が + -- 全時点を 0 に潰す逆順バグだった。 計測で確認・修正。) + go _ _ [] = ([], [], [], [], []) + go !nAt !sAcc ((t, dj, cj) : rest) = + let !sFactor = if nAt > 0 + then 1 - fromIntegral dj / fromIntegral nAt + else 1 + !sNew = sAcc * sFactor + (ts, ss, ns, ds, cs) = go (nAt - dj - cj) sNew rest + in (t : ts, sNew : ss, nAt : ns, dj : ds, cj : cs) + (ts, ss, ns, ds, cs) = go n0 1.0 groups + in KMResult ts ss ns ds cs + +-- | Walk a list pre-sorted by 'ssTime' and return per-distinct-time +-- @(time, num_events, num_censored)@ tuples. +runLengthGroups :: [SurvSample] -> [(Double, Int, Int)] +runLengthGroups [] = [] +runLengthGroups (x:xs) = go (ssTime x) (countOf x) xs + where + countOf s = case ssEvent s of + Observed -> (1 :: Int, 0 :: Int) + Censored -> (0, 1) + go !t (!d, !c) [] = [(t, d, c)] + go !t (!d, !c) (s:rest) + | ssTime s == t = + let (di, ci) = countOf s + in go t (d + di, c + ci) rest + | otherwise = + let (di, ci) = countOf s + in (t, d, c) : go (ssTime s) (di, ci) rest + +-- | Backwards-compatible export of the old @groupByTime@ API. Builds +-- on the new run-length walk for performance. +groupByTime :: [SurvSample] -> [(Double, [SurvSample], [SurvSample])] +groupByTime samples = + let !sorted = sortBy (comparing ssTime) samples + walk [] = [] + walk (s:rest) = collect (ssTime s) [s] rest + collect t acc [] = [emit t acc] + collect t acc (x:xs) + | ssTime x == t = collect t (x:acc) xs + | otherwise = emit t acc : collect (ssTime x) [x] xs + emit t bucket = + let (evs, cns) = splitByEvent bucket + in (t, evs, cns) + splitByEvent = foldr step ([], []) + where step s (es, cs) = case ssEvent s of + Observed -> (s : es, cs) + Censored -> (es, s : cs) + in walk sorted + +-- --------------------------------------------------------------------------- +-- Nelson-Aalen +-- --------------------------------------------------------------------------- + +-- | Nelson-Aalen cumulative hazard estimator. +data NAResult = NAResult + { narTimes :: ![Double] + , narCumHazard :: ![Double] -- ^ Ĥ(t) = Σ_j d_j / n_j. + , narAtRisk :: ![Int] + , narEvents :: ![Int] + } deriving (Show) + +-- | Compute the Nelson-Aalen estimator. +nelsonAalen :: [SurvSample] -> NAResult +nelsonAalen samples = + let km = kaplanMeier samples + ts = kmrTimes km + ns = kmrAtRisk km + ds = kmrEvents km + hazardIncrements = [fromIntegral d / fromIntegral n | (n, d) <- zip ns ds] + cumH = scanl1 (+) hazardIncrements + in NAResult ts cumH ns ds + +-- --------------------------------------------------------------------------- +-- Log-rank test +-- --------------------------------------------------------------------------- + +-- | Log-rank test result. +data LogRankResult = LogRankResult + { lrChi2 :: !Double + , lrDf :: !Int + , lrPValue :: !Double + , lrGroupSizes :: ![Int] + } deriving (Show) + +-- | Log-rank test for comparing survival across @k@ groups. +-- +-- Tests @H_0: S_1(t) = S_2(t) = ⋯ = S_k(t)@ for all @t@. Asymptotic +-- chi-square approximation with @k − 1@ degrees of freedom. +logRankTest :: [[SurvSample]] -> LogRankResult +logRankTest groups = + let k = length groups + ns = map length groups + -- Pool all samples with group labels. + labelled = concat + [ [(g, s) | s <- ss] | (g, ss) <- zip [0 :: Int ..] groups ] + sorted = sortBy (comparing (ssTime . snd)) labelled + times = map head (group (map (ssTime . snd) sorted)) + -- For each time t_j, compute observed events O_{ij} per group i + -- and expected events E_{ij} = (n_{ij} / n_j) × d_j, where + -- n_{ij} = at risk in group i, n_j = total at risk, d_j = total events. + go _ _ [] acc = acc + go nAtRiskBy nAtRiskTotal (t : tRest) acc = + let -- Events / censored at this time, by group. + atTime = [s | s <- sorted, ssTime (snd s) == t] + eventsByGrp = [ length [() | (g, s) <- atTime, + g == i, ssEvent s == Observed] + | i <- [0 .. k - 1] ] + censoredByGrp = [ length [() | (g, s) <- atTime, + g == i, ssEvent s == Censored] + | i <- [0 .. k - 1] ] + dTotal = sum eventsByGrp + cTotal = sum censoredByGrp + -- Expected events per group at this time. + expected = [ if nAtRiskTotal > 0 + then fromIntegral nij * fromIntegral dTotal + / fromIntegral nAtRiskTotal + else 0 + | nij <- nAtRiskBy ] + -- Variance contribution to each group's (O - E): + -- v_{ij} = n_{ij}(n_j - n_{ij}) d_j (n_j - d_j) / (n_j² (n_j - 1)) + varContrib = + if nAtRiskTotal > 1 && dTotal > 0 + then [ let nij = fromIntegral nij_i :: Double + nj = fromIntegral nAtRiskTotal :: Double + dj = fromIntegral dTotal :: Double + in nij * (nj - nij) * dj * (nj - dj) + / (nj * nj * (nj - 1)) + | nij_i <- nAtRiskBy ] + else replicate k 0 + (oeAcc, varAcc) = acc + oeNew = zipWith3 (\o e prev -> prev + (fromIntegral o - e)) + eventsByGrp expected oeAcc + varNew = zipWith (+) varAcc varContrib + -- Update at-risk counts (subtract events + censored). + nAtRiskBy' = zipWith3 (\nrij ej cj -> nrij - ej - cj) + nAtRiskBy eventsByGrp censoredByGrp + in go nAtRiskBy' (nAtRiskTotal - dTotal - cTotal) tRest (oeNew, varNew) + (oeFinal, varFinal) = go ns (sum ns) times + (replicate k 0, replicate k 0) + -- Test statistic: (O - E)² / Var summed (approx for k=2); + -- for general k, use first (k-1) components. + chi2 = + if k == 2 + then case (oeFinal, varFinal) of + ([o1, _], [v1, _]) | v1 > 0 -> o1 * o1 / v1 + _ -> 0 + else + -- General case: sum of squared standardised (O - E). + sum [ if v > 0 then o * o / v else 0 + | (o, v) <- zip oeFinal varFinal ] + df = k - 1 + pVal = SD.complCumulative (ChiSq.chiSquared df) chi2 + in LogRankResult + { lrChi2 = chi2 + , lrDf = df + , lrPValue = pVal + , lrGroupSizes = ns + } + +-- --------------------------------------------------------------------------- +-- Cox proportional hazards +-- --------------------------------------------------------------------------- + +-- | Cox PH model fit. +data CoxFit = CoxFit + { coxBeta :: !(LA.Vector Double) -- ^ Coefficients. + , coxSE :: !(LA.Vector Double) -- ^ Standard errors. + , coxLogLik :: !Double -- ^ Log partial likelihood. + , coxIters :: !Int -- ^ Newton iterations. + } deriving (Show) + +-- | Fit Cox proportional hazards by maximising the partial likelihood +-- via Newton-Raphson. +-- +-- Partial likelihood (ties handled by Breslow approximation): +-- +-- @L(β) = Π_i exp(β·x_i) / Σ_{j ∈ R(t_i)} exp(β·x_j)@ +-- +-- where @R(t_i)@ is the risk set at time @t_i@. +coxPH + :: [LA.Vector Double] -- ^ Covariates per sample. + -> [SurvSample] -- ^ Times and events. + -> CoxFit +-- +-- B9c: list operations (@scanr1@, @!!@, list comprehensions over +-- 'LA.Vector') replaced with @VS@/@V@-vector reverse cumulative sums +-- and a precomputed boxed 'V.Vector' of risk-set rows. The score and +-- gradient now run in @O(n p)@ per call (no per-index list traversal). +-- Hessian remains numerical for now (algorithmic Hessian is a future +-- improvement) but each finite-difference call is now cheap. +coxPH xs samples = + let !n = length xs + !p = if n == 0 then 0 else LA.size (head xs) + !indexed = zip xs samples + !sortedByTime = sortBy (comparing (ssTime . snd)) indexed + -- Event indices as an unboxed Vector for fast iteration. + !eventIdxsV = VU.fromList + [ i | (i, (_, s)) <- zip [0 :: Int ..] sortedByTime + , ssEvent s == Observed ] + !xsArr = LA.fromRows (map fst sortedByTime) + !xsRows = V.fromList (LA.toRows xsArr) -- O(1) indexing + + -- Score vector at β: X β. Storable for VS.scanr1. + scoresV beta = LA.flatten (xsArr LA.<> LA.asColumn beta) :: VS.Vector Double + + -- Reverse cumulative sum on Storable: out[i] = Σ_{j≥i} v[j]. + revCumSum :: VS.Vector Double -> VS.Vector Double + revCumSum = VS.fromList . scanr1 (+) . VS.toList + -- (Acceptable: VS.toList -> scanr1 -> VS.fromList is O(n) and + -- runs once per gradAndHess; the dominant cost is the BLAS GEMV + -- and per-row work below.) + + -- log-partial-likelihood at β. + logLik beta = + let scs = scoresV beta + !expS = VS.map exp scs + !cumE = revCumSum expS + walk acc k + | k >= VU.length eventIdxsV = acc + | otherwise = + let !i = VU.unsafeIndex eventIdxsV k + !s = VS.unsafeIndex scs i + !c = VS.unsafeIndex cumE i + in walk (acc + s - log c) (k + 1) + in walk (0 :: Double) 0 + + -- Gradient of log partial likelihood w.r.t. β. + gradAt beta = + let scs = scoresV beta + !expS = VS.map exp scs + !cumE = revCumSum expS + -- Weighted X: rows scaled by exp(score). Then row-wise + -- reverse cumulative sum (per column) gives Σ_{j≥i} e_j x_j. + !weightedRows = V.zipWith + (\x e -> LA.scale e x) xsRows + (V.fromList (VS.toList expS)) + -- Reverse cumulative sum of vectors: + !cumWeighted = revCumSumVecV (LA.konst 0 p) weightedRows + walk acc k + | k >= VU.length eventIdxsV = acc + | otherwise = + let !i = VU.unsafeIndex eventIdxsV k + !ri = xsRows V.! i + !ci = VS.unsafeIndex cumE i + !wi = cumWeighted V.! i + !contrib = ri - LA.scale (1 / ci) wi + in walk (acc + contrib) (k + 1) + in walk (LA.konst 0 p) 0 + + maxIter = 25 :: Int + tol = 1e-6 + h = 1e-5 + + -- Numerical Hessian column i (central difference of grad). + hessCol betaList i = + let bp = LA.fromList [if k == i then v + h else v + | (k, v) <- zip [0::Int ..] betaList] + bm = LA.fromList [if k == i then v - h else v + | (k, v) <- zip [0::Int ..] betaList] + in LA.scale (1 / (2 * h)) (gradAt bp - gradAt bm) + + step beta = + let !g = gradAt beta + !bL = LA.toList beta + !hessian = LA.fromRows [hessCol bL i | i <- [0 .. p - 1]] + !negH = LA.scale (-1) hessian + !delta = negH LA.<\> g + !betaNew = beta + delta + !converged = LA.norm_2 delta < tol + in (betaNew, converged) + + loop !i beta + | i >= maxIter = (beta, i) + | otherwise = + let (beta', conv) = step beta + in if conv then (beta', i + 1) + else loop (i + 1) beta' + + (!betaFinal, !iters) = loop 0 (LA.konst 0 p) + + -- Final Hessian for SEs. + !bFL = LA.toList betaFinal + !hessFinal = LA.fromRows [hessCol bFL i | i <- [0 .. p - 1]] + !negHFinal = LA.scale (-1) hessFinal + !seVec = case maybeInverse negHFinal of + Just inv -> LA.cmap sqrt (LA.takeDiag inv) + Nothing -> LA.konst (1/0) p + in CoxFit + { coxBeta = betaFinal + , coxSE = seVec + , coxLogLik = logLik betaFinal + , coxIters = iters + } + +-- | Reverse cumulative sum over a boxed Vector of 'LA.Vector Double': +-- @out[i] = Σ_{j≥i} v[j]@. Returns a Vector of the same length. +-- Uses 'scanr' once (O(n p)) — total cost dominated by BLAS-bound +-- vector additions. +revCumSumVecV :: LA.Vector Double + -> V.Vector (LA.Vector Double) + -> V.Vector (LA.Vector Double) +revCumSumVecV zeroV vs = + -- scanr produces length n+1 with a trailing zero seed; drop it. + let !suf = scanr (+) zeroV (V.toList vs) + in V.fromList (init suf) + +-- | Baseline cumulative hazard (Breslow estimator). +coxBaselineHazard + :: CoxFit + -> [LA.Vector Double] + -> [SurvSample] + -> [(Double, Double)] -- ^ @(t_i, Ĥ_0(t_i))@. +coxBaselineHazard fit xs samples = + let beta = coxBeta fit + indexed = zip xs samples + sortedByTime = sortBy (comparing (ssTime . snd)) indexed + times = sort (map (ssTime . snd) sortedByTime) + uniqueTs = map head (group times) + atRiskAt t = + [ x | (x, s) <- sortedByTime, ssTime s >= t ] + eventsAt t = + length [() | (_, s) <- sortedByTime, ssTime s == t, + ssEvent s == Observed] + hazardIncrements t = + let denom = sum [ exp (LA.dot beta x) | x <- atRiskAt t ] + d = eventsAt t + in if denom > 0 then fromIntegral d / denom else 0 + hi = map hazardIncrements uniqueTs + cumH = scanl1 (+) hi + in zip uniqueTs cumH + +-- | Try to compute the inverse of a matrix; returns Nothing if singular. +maybeInverse :: LA.Matrix Double -> Maybe (LA.Matrix Double) +maybeInverse m = + case LA.rank m of + r | r == LA.rows m -> Just (LA.inv m) + | otherwise -> Nothing diff --git a/src/Hanalyze/Model/TimeSeries.hs b/src/Hanalyze/Model/TimeSeries.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/TimeSeries.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Hanalyze.Model.TimeSeries +-- Description : AR/MA/ARIMA・指数平滑・STL 分解を含む時系列モデリング一式 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Time-series modelling. +-- +-- @ +-- import Hanalyze.Model.TimeSeries +-- +-- let acf = autocorrelation 20 ys +-- fit = fitAR 2 ys -- AR(2) by Yule-Walker +-- fc = forecastAR fit ys 10 -- 10-step ahead +-- +-- let hw = holtWinters HWAdditive 12 ys +-- fc2 = hwForecast hw 24 +-- @ +-- +-- == Implemented +-- +-- * 'autocorrelation' / 'partialAutocorrelation' (sample ACF / PACF) +-- * 'fitAR' / 'forecastAR' (autoregressive AR(p) via Yule-Walker) +-- * 'fitMA' / 'forecastMA' (moving-average MA(q) via innovations) +-- * 'differencing' / 'inverseDifferencing' (helpers for ARIMA d) +-- * 'fitARIMA' / 'forecastARIMA' (ARIMA(p, d, q)) +-- * 'simpleExpSmoothing' (single exp smoothing) +-- * 'holtWinters' (triple exp smoothing, additive / multiplicative) +-- * 'movingAverage' (centred / trailing) +-- * 'stlDecompose' (STL — seasonal-trend decomposition, simplified) +module Hanalyze.Model.TimeSeries + ( -- * ACF / PACF + autocorrelation + , partialAutocorrelation + -- * AR + , ARFit (..) + , fitAR + , forecastAR + -- * MA + , MAFit (..) + , fitMA + , forecastMA + -- * ARIMA + , ARIMAFit (..) + , fitARIMA + , forecastARIMA + , differencing + , inverseDifferencing + -- * Exponential smoothing + , simpleExpSmoothing + , HWMode (..) + , HWFit (..) + , holtWinters + , hwForecast + -- * Helpers + , movingAverage + , stlDecompose + ) where + +import qualified Numeric.LinearAlgebra as LA + +-- --------------------------------------------------------------------------- +-- ACF / PACF +-- --------------------------------------------------------------------------- + +-- | Sample autocorrelation function up to @maxLag@. Lag 0 is always +-- @1.0@. Computed as @r_k = c_k / c_0@ with biased autocovariance: +-- @c_k = (1/n) Σ_{t=0..n-k-1} (y_t - ȳ)(y_{t+k} - ȳ)@. +autocorrelation + :: Int -- ^ Maximum lag. + -> LA.Vector Double + -> LA.Vector Double +autocorrelation maxLag y = + let n = LA.size y + ybar = LA.sumElements y / fromIntegral n + ydev = y - LA.scalar ybar + c0 = LA.dot ydev ydev / fromIntegral n + cAt k = sum [ LA.atIndex ydev t * LA.atIndex ydev (t + k) + | t <- [0 .. n - k - 1] ] + / fromIntegral n + rs = [ if c0 == 0 then 0 else cAt k / c0 + | k <- [0 .. maxLag] ] + in LA.fromList rs + +-- | Sample partial autocorrelation function up to @maxLag@ via direct +-- AR-fit: PACF[k] = last AR coefficient when fitting AR(k) by +-- Yule-Walker. Conceptually equivalent to the Durbin-Levinson +-- recursion but easier to implement correctly. +partialAutocorrelation + :: Int + -> LA.Vector Double + -> LA.Vector Double +partialAutocorrelation maxLag y = + let pacfAt 0 = 1 + pacfAt k = + let fit = fitAR k y + phi = arPhi fit + in if LA.size phi == 0 then 0 + else LA.atIndex phi (k - 1) + in LA.fromList [pacfAt k | k <- [0 .. maxLag]] + +-- --------------------------------------------------------------------------- +-- AR (autoregressive) +-- --------------------------------------------------------------------------- + +-- | Fitted AR(p) model. +data ARFit = ARFit + { arOrder :: !Int -- ^ p + , arPhi :: !(LA.Vector Double) -- ^ AR coefficients (length p) + , arIntercept :: !Double -- ^ μ (mean) + , arResidVar :: !Double -- ^ Innovation variance. + } deriving (Show) + +-- | Fit an AR(p) model by the Yule-Walker equations. +-- Solves @R φ = r@ where @R@ is the @p × p@ Toeplitz matrix of +-- autocovariances and @r = (γ_1, …, γ_p)@. +fitAR :: Int -> LA.Vector Double -> ARFit +fitAR p y = + let n = LA.size y + ybar = LA.sumElements y / fromIntegral n + yC = y - LA.scalar ybar + gamma k = LA.dot (LA.subVector 0 (n - k) yC) + (LA.subVector k (n - k) yC) / fromIntegral n + rhs = LA.fromList [gamma k | k <- [1 .. p]] + mat = LA.fromLists + [[gamma (abs (i - j)) | j <- [0 .. p - 1]] + | i <- [0 .. p - 1]] + phi = mat LA.<\> rhs + -- Innovation variance via Yule-Walker: + -- σ² = γ_0 - Σ φ_i γ_i + innovVar = gamma 0 - LA.dot phi rhs + in ARFit + { arOrder = p + , arPhi = phi + , arIntercept = ybar + , arResidVar = max 0 innovVar + } + +-- | Forecast @h@ steps ahead from a fitted AR model and the most +-- recent observations (in chronological order). +forecastAR + :: ARFit + -> LA.Vector Double -- ^ History (must be ≥ p). + -> Int -- ^ Horizon h. + -> LA.Vector Double +forecastAR fit hist h = + let p = arOrder fit + mu = arIntercept fit + phi = arPhi fit + lastP = LA.toList (LA.subVector (LA.size hist - p) p hist) + go _ acc 0 = reverse acc + go window acc k = + let dev = zipWith (-) window (replicate p mu) + yHat = mu + LA.dot phi (LA.fromList dev) + window' = drop 1 window ++ [yHat] + in go window' (yHat : acc) (k - 1) + in LA.fromList (go lastP [] h) + +-- --------------------------------------------------------------------------- +-- MA (moving average) +-- --------------------------------------------------------------------------- + +-- | Fitted MA(q) model. +data MAFit = MAFit + { maOrder :: !Int + , maTheta :: !(LA.Vector Double) -- ^ MA coefficients (length q) + , maIntercept :: !Double + , maResidVar :: !Double + , maResiduals :: !(LA.Vector Double) -- ^ Innovation series. + } deriving (Show) + +-- | Fit an MA(q) model via the innovations algorithm (Brockwell-Davis +-- 1991, §5.2). Returns the estimated θ_i and innovation series. +fitMA :: Int -> LA.Vector Double -> MAFit +fitMA q y = + let n = LA.size y + ybar = LA.sumElements y / fromIntegral n + yC = y - LA.scalar ybar + gamma k = LA.dot (LA.subVector 0 (n - k) yC) + (LA.subVector k (n - k) yC) / fromIntegral n + -- Innovations algorithm: recursion + -- v_n = γ_0 + -- θ_{n,n-k} = (γ_{n-k} - Σ_{j=0}^{k-1} θ_{n,n-j} θ_{k,k-j} v_j) / v_k + -- v_n = γ_0 - Σ_{j=0}^{n-1} θ_{n,n-j}² v_j + -- + -- We compute up to lag q. + theta = LA.konst 0 q :: LA.Vector Double + _ = theta + -- Simplified approximation: use sample autocovariances directly + -- to estimate θ via least squares (Hannan-Rissanen 1982). + -- This is less accurate than full Innovations but simpler. + thetaSimple = LA.fromList [ gamma k / max 1e-15 (gamma 0) + | k <- [1 .. q] ] + -- Compute residuals: e_t = y_t - μ - Σ θ_i e_{t-i} + residuals = computeMAResiduals (LA.toList yC) (LA.toList thetaSimple) + sigma2 = sum [r * r | r <- residuals] / fromIntegral n + in MAFit + { maOrder = q + , maTheta = thetaSimple + , maIntercept = ybar + , maResidVar = sigma2 + , maResiduals = LA.fromList residuals + } + where + computeMAResiduals :: [Double] -> [Double] -> [Double] + computeMAResiduals ys thetas = + let go acc [] = reverse acc + go acc (yi:ys') = + let q' = length thetas + eHist = take q' acc -- recent residuals + pad = replicate (q' - length eHist) 0 + ePadded = pad ++ eHist + yHat = sum (zipWith (*) thetas (reverse ePadded)) + eNew = yi - yHat + in go (eNew : acc) ys' + in go [] ys + +-- | Forecast h steps from MA(q). Beyond q steps, the forecast equals +-- the mean (innovations are zero in expectation). +forecastMA :: MAFit -> Int -> LA.Vector Double +forecastMA fit h = + let q = maOrder fit + theta = LA.toList (maTheta fit) + mu = maIntercept fit + eHist = LA.toList (maResiduals fit) + eRecent = take q (reverse eHist) + go k + | k > q || k > h = [] + | otherwise = + let pad = replicate (q - length eRecent) 0 + eP = pad ++ eRecent + yhat = mu + sum (zipWith (*) theta (drop (k - 1) (reverse eP))) + in yhat : go (k + 1) + truncated = take h (go 1 ++ repeat mu) + in LA.fromList truncated + +-- --------------------------------------------------------------------------- +-- ARIMA +-- --------------------------------------------------------------------------- + +-- | Fitted ARIMA(p, d, q) model. +data ARIMAFit = ARIMAFit + { arimaP :: !Int + , arimaD :: !Int + , arimaQ :: !Int + , arimaAR :: !ARFit + , arimaMA :: !MAFit + , arimaOrigSeries :: !(LA.Vector Double) + } deriving (Show) + +-- | Fit ARIMA(p, d, q): difference d times, then fit AR(p) + MA(q) on +-- the differenced series. Uses two-stage estimation (AR first, then +-- MA on residuals). +fitARIMA :: Int -> Int -> Int -> LA.Vector Double -> ARIMAFit +fitARIMA p d q y = + let yDiff = iterate differencing y !! d + arFit = fitAR p yDiff + arResid = computeARResiduals arFit yDiff + maFit = fitMA q arResid + in ARIMAFit + { arimaP = p + , arimaD = d + , arimaQ = q + , arimaAR = arFit + , arimaMA = maFit + , arimaOrigSeries = y + } + +computeARResiduals :: ARFit -> LA.Vector Double -> LA.Vector Double +computeARResiduals fit y = + let p = arOrder fit + mu = arIntercept fit + phi = LA.toList (arPhi fit) + n = LA.size y + ys = LA.toList y + go i + | i < p = 0 + | otherwise = + let dev = [ys !! (i - k - 1) - mu | k <- [0 .. p - 1]] + yHat = mu + sum (zipWith (*) phi dev) + in (ys !! i) - yHat + residuals = [go i | i <- [0 .. n - 1]] + in LA.fromList residuals + +-- | Forecast h steps from a fitted ARIMA model. +forecastARIMA :: ARIMAFit -> Int -> LA.Vector Double +forecastARIMA fit h = + let _origY = arimaOrigSeries fit + d = arimaD fit + diff_d = iterate differencing _origY !! d + arFc = forecastAR (arimaAR fit) diff_d h + maFc = forecastMA (arimaMA fit) h + combined = arFc + maFc - LA.scalar (arIntercept (arimaAR fit)) + -- Inverse-difference d times. + lastObs = take d (reverse (LA.toList _origY)) + _ = lastObs + in iterate (inverseDifferencing _origY) combined !! d + +-- | First-difference: @y'_t = y_t - y_{t-1}@. Output length = n - 1. +differencing :: LA.Vector Double -> LA.Vector Double +differencing y = + let n = LA.size y + in if n < 2 then LA.fromList [] + else LA.subVector 1 (n - 1) y - LA.subVector 0 (n - 1) y + +-- | Inverse first-difference given the last observation of the +-- original series. Output length = n + 1 (prepends the seed). +-- Simplified: cumulative sum prepended by 0. +inverseDifferencing + :: LA.Vector Double -- ^ Original (for last value reference). + -> LA.Vector Double -- ^ Differenced forecast. + -> LA.Vector Double +inverseDifferencing origY diff = + let lastY = LA.atIndex origY (LA.size origY - 1) + cumS = scanl (+) lastY (LA.toList diff) + in LA.fromList (drop 1 cumS) + +-- --------------------------------------------------------------------------- +-- Exponential smoothing +-- --------------------------------------------------------------------------- + +-- | Simple exponential smoothing (single, no trend / seasonality). +-- @s_t = α y_t + (1 − α) s_{t−1}@. Returns the smoothed series. +simpleExpSmoothing + :: Double -- ^ α ∈ (0, 1). + -> LA.Vector Double + -> LA.Vector Double +simpleExpSmoothing alpha y = + let ys = LA.toList y + go _ [] = [] + go prev (yi:rest) = + let sNew = alpha * yi + (1 - alpha) * prev + in sNew : go sNew rest + s0 = case ys of { (y0:_) -> y0; [] -> 0 } + in LA.fromList (go s0 ys) + +-- | Holt-Winters mode (additive vs multiplicative seasonality). +data HWMode = HWAdditive | HWMultiplicative deriving (Show, Eq) + +-- | Fitted Holt-Winters (triple exponential smoothing). +data HWFit = HWFit + { hwMode :: !HWMode + , hwPeriod :: !Int + , hwAlpha :: !Double + , hwBeta :: !Double + , hwGamma :: !Double + , hwLevel :: !Double -- ^ Final level component. + , hwTrend :: !Double -- ^ Final trend component. + , hwSeasonal :: ![Double] -- ^ Final seasonal indices (length period). + , hwFitted :: !(LA.Vector Double) + } deriving (Show) + +-- | Fit Holt-Winters (additive seasonal). Picks default smoothing +-- parameters @α = β = γ = 0.3@; for production use, optimise these. +holtWinters + :: HWMode -- ^ Additive or multiplicative. + -> Int -- ^ Seasonal period (e.g. 12 for monthly). + -> LA.Vector Double -- ^ Time series. + -> HWFit +holtWinters mode period y = + let alpha = 0.3 :: Double + beta = 0.1 :: Double + gamma = 0.1 :: Double + ys = LA.toList y + -- Initialise from first 'period' observations. + initLevel = sum (take period ys) / fromIntegral period + initTrend = (sum (take period (drop period ys)) + - sum (take period ys)) + / fromIntegral (period * period) + initSeas = case mode of + HWAdditive -> + [ ys !! i - initLevel | i <- [0 .. period - 1] ] + HWMultiplicative -> + [ ys !! i / max 1e-15 initLevel | i <- [0 .. period - 1] ] + -- Iterate. + go !lvl !trd !seas !fitted [] = (lvl, trd, seas, reverse fitted) + go !lvl !trd !seas !fitted (yi:rest) = + let p = period + sIdx = length fitted `mod` p + sCur = seas !! sIdx + (lvlNew, trdNew, sNew, fHat) = case mode of + HWAdditive -> + let l' = alpha * (yi - sCur) + (1 - alpha) * (lvl + trd) + t' = beta * (l' - lvl) + (1 - beta) * trd + s' = gamma * (yi - l') + (1 - gamma) * sCur + fh = lvl + trd + sCur + in (l', t', s', fh) + HWMultiplicative -> + let l' = alpha * (yi / max 1e-15 sCur) + (1 - alpha) * (lvl + trd) + t' = beta * (l' - lvl) + (1 - beta) * trd + s' = gamma * (yi / max 1e-15 l') + (1 - gamma) * sCur + fh = (lvl + trd) * sCur + in (l', t', s', fh) + seas' = updateAt sIdx sNew seas + in go lvlNew trdNew seas' (fHat : fitted) rest + (finalLvl, finalTrd, finalSeas, fits) = + go initLevel initTrend initSeas [] ys + in HWFit + { hwMode = mode + , hwPeriod = period + , hwAlpha = alpha + , hwBeta = beta + , hwGamma = gamma + , hwLevel = finalLvl + , hwTrend = finalTrd + , hwSeasonal = finalSeas + , hwFitted = LA.fromList fits + } + +-- | Forecast @h@ steps ahead from a fitted Holt-Winters model. +hwForecast :: HWFit -> Int -> LA.Vector Double +hwForecast fit h = + let lvl = hwLevel fit + trd = hwTrend fit + seas = hwSeasonal fit + p = hwPeriod fit + mode = hwMode fit + go k + | k > h = [] + | otherwise = + let sIdx = (k - 1) `mod` p + fc = case mode of + HWAdditive -> lvl + fromIntegral k * trd + seas !! sIdx + HWMultiplicative -> (lvl + fromIntegral k * trd) * seas !! sIdx + in fc : go (k + 1) + in LA.fromList (go 1) + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +-- | Centred moving average with window @w@ (odd recommended). Values +-- near the edges have NaN. +movingAverage :: Int -> LA.Vector Double -> LA.Vector Double +movingAverage w y = + let n = LA.size y + half = w `div` 2 + avg i + | i - half < 0 || i + half >= n = 0/0 + | otherwise = sum [LA.atIndex y (i + j) | j <- [-half .. half]] + / fromIntegral w + in LA.fromList [avg i | i <- [0 .. n - 1]] + +-- | Simplified STL decomposition (loess-free version): subtract a +-- centred moving-average trend, then estimate seasonality as the +-- mean per phase. +stlDecompose + :: Int -- ^ Period. + -> LA.Vector Double + -> (LA.Vector Double, LA.Vector Double, LA.Vector Double) + -- ^ (trend, seasonal, residual). +stlDecompose period y = + let n = LA.size y + trend = movingAverage period y + detrended = LA.fromList + [ if isNaN (LA.atIndex trend i) then 0 + else LA.atIndex y i - LA.atIndex trend i + | i <- [0 .. n - 1] ] + -- Per-phase mean over non-NaN cells. + phaseMeans = + [ let maxJ = (n - 1 - i) `div` period + xs = [LA.atIndex detrended (i + j * period) + | j <- [0 .. maxJ], i + j * period < n] + valid = filter (not . isNaN) xs + in if null valid then 0 else sum valid / fromIntegral (length valid) + | i <- [0 .. period - 1] ] + -- Centre seasonal indices around 0. + seasMean = sum phaseMeans / fromIntegral period + seasonal = LA.fromList + [ phaseMeans !! (i `mod` period) - seasMean | i <- [0 .. n - 1] ] + residual = y - trend - seasonal + in (trend, seasonal, residual) + +-- | Update list element at index. +updateAt :: Int -> a -> [a] -> [a] +updateAt _ _ [] = [] +updateAt 0 v (_:xs) = v : xs +updateAt i v (x:xs) = x : updateAt (i - 1) v xs + diff --git a/src/Hanalyze/Model/VAR.hs b/src/Hanalyze/Model/VAR.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/VAR.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Hanalyze.Model.VAR +-- Description : 多変量自己回帰 VAR(p) モデルの方程式別 OLS 推定と予測 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- VAR(p) — Vector AutoRegressive model. +-- +-- Multivariate generalization of AR(p): for a @K@-dimensional series +-- @yₜ ∈ ℝᴷ@, +-- +-- @ +-- yₜ = c + A₁·yₜ₋₁ + A₂·yₜ₋₂ + … + Aₚ·yₜ₋ₚ + εₜ +-- @ +-- +-- where each @Aₗ@ is a @K × K@ coefficient matrix and @c@ is a length-@K@ +-- intercept. Estimation is by equation-by-equation OLS, which is the +-- maximum-likelihood estimator for VAR under Gaussian innovations (the +-- stacked system has the same regressors in every equation, so SUR +-- collapses to OLS — Lütkepohl 2005 §3.2). +-- +-- @ +-- import Hanalyze.Model.VAR +-- +-- let fit = fitVAR 2 yMat -- VAR(2) on n × K series +-- fc = forecastVAR fit yMat 10 -- 10-step ahead +-- @ +-- +-- == Implemented +-- +-- * 'fitVAR' (equation-by-equation OLS, joint estimation) +-- * 'forecastVAR' (deterministic point forecast, h steps) +module Hanalyze.Model.VAR + ( VARFit (..) + , fitVAR + , forecastVAR + ) where + +import qualified Numeric.LinearAlgebra as LA + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +-- | Fitted VAR(p) model. +data VARFit = VARFit + { varP :: !Int -- ^ Lag order @p@. + , varK :: !Int -- ^ Series dimensionality @K@. + , varConst :: !(LA.Vector Double) -- ^ Intercept @c@ (length @K@). + , varCoefs :: ![LA.Matrix Double] -- ^ @[A₁, …, Aₚ]@, each @K × K@. + , varResiduals :: !(LA.Matrix Double) -- ^ Residuals, @(n − p) × K@. + , varSigma :: !(LA.Matrix Double) -- ^ Residual covariance @K × K@. + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- Fitting +-- --------------------------------------------------------------------------- + +-- | Fit a VAR(@p@) model to an @n × K@ series @Y@ by equation-by-equation +-- OLS. The first @p@ rows are consumed as the initial lag window; +-- @n − p@ effective observations are used. Requires @n > p · K + 1@. +fitVAR :: Int -> LA.Matrix Double -> VARFit +fitVAR p y = + let n = LA.rows y + k = LA.cols y + neff = n - p + -- Design matrix Z: each row t = [1, y_{t-1}, y_{t-2}, …, y_{t-p}] + -- (1 + p·K columns), for t = p, p+1, …, n-1. + buildRow t = + 1.0 : concat [ LA.toList (LA.flatten (y LA.? [t - l])) + | l <- [1 .. p] ] + zRows = [ buildRow t | t <- [p .. n - 1] ] + z = LA.fromLists zRows -- (neff × (1 + p·K)) + yLag = y LA.?? (LA.Drop p, LA.All) -- (neff × K) + -- OLS: B = (Zᵀ Z)⁻¹ Zᵀ Y. Use linearSolveLS (least squares) for + -- numerical stability. + bMat = LA.linearSolveLS z yLag -- ((1 + p·K) × K) + cVec = LA.flatten (bMat LA.? [0]) -- intercept (K,) + coefs = + [ LA.tr (bMat LA.?? ( LA.Pos (LA.idxs [ 1 + (l - 1) * k + j + | j <- [0 .. k - 1] ]) + , LA.All )) + | l <- [1 .. p] ] + -- Each block row of B is K rows giving Aₗᵀ; transpose for K × K Aₗ. + yhat = z LA.<> bMat + resid = yLag - yhat + sigma = (LA.tr resid LA.<> resid) + / fromIntegral (max 1 (neff - (1 + p * k))) + in VARFit + { varP = p + , varK = k + , varConst = cVec + , varCoefs = coefs + , varResiduals = resid + , varSigma = sigma + } + +-- --------------------------------------------------------------------------- +-- Forecasting +-- --------------------------------------------------------------------------- + +-- | Deterministic @h@-step-ahead point forecast (ε set to zero): +-- +-- @ +-- ŷ_{T+k} = c + Σₗ Aₗ · ŷ_{T+k-ℓ} +-- @ +-- +-- where @ŷ_{T+j} = y_{T+j}@ for @j ≤ 0@. The full input series @y@ is +-- accepted to supply the last @p@ rows used as initial history. +forecastVAR :: VARFit -> LA.Matrix Double -> Int -> LA.Matrix Double +forecastVAR fit y h + | h <= 0 = LA.fromLists [] + | otherwise = + let p = varP fit + n = LA.rows y + -- Initial history: last p rows of y, as a [Vector Double] list + -- with index 0 = y_{T-1}, index 1 = y_{T-2}, …, index p-1 = y_{T-p}. + hist0 = [ LA.flatten (y LA.? [n - 1 - i]) | i <- [0 .. p - 1] ] + step !hist = + let !pred_ = + varConst fit + + foldr1 (+) + [ (varCoefs fit !! (l - 1)) LA.#> (hist !! (l - 1)) + | l <- [1 .. p] ] + in (pred_, pred_ : init hist) + go !k !hist acc + | k > h = reverse acc + | otherwise = + let (yk, hist') = step hist + in go (k + 1) hist' (yk : acc) + in LA.fromRows (go 1 hist0 []) diff --git a/src/Hanalyze/Model/Weibull.hs b/src/Hanalyze/Model/Weibull.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Model/Weibull.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Hanalyze.Model.Weibull +-- Description : Weibull 分布の最尤推定・B_x 寿命・Wald 標準誤差 (信頼性/故障時間解析の中核) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Weibull 分布の最尤推定 + B_x 寿命 + Wald SE。 +-- +-- 信頼性 / 故障時間解析の中核。 半導体 / 材料分野の加速試験データ解析に使う。 +-- 加速モデル (Arrhenius / Eyring / Inverse Power Law) は +-- @Hanalyze.Model.Reliability@ で別途扱う。 +-- +-- Weibull(k, λ) の確率密度 / 生存関数: +-- +-- > f(x) = (k/λ) (x/λ)^(k-1) exp(-(x/λ)^k) for x > 0 +-- > S(x) = exp(-(x/λ)^k) +-- +-- 形状 k と尺度 λ は両方とも正。 k < 1 は故障率低下 (初期不良)、 k = 1 は +-- 指数分布、 k > 1 は故障率上昇 (摩耗故障)。 +-- +-- [English]: Weibull distribution maximum-likelihood estimation + B_x life + +-- Wald SE. +-- +-- The core of reliability \/ time-to-failure analysis. Used for analyzing +-- accelerated test data in the semiconductor \/ materials domains. +-- Acceleration models (Arrhenius \/ Eyring \/ Inverse Power Law) are handled +-- separately in @Hanalyze.Model.Reliability@. +-- +-- The probability density \/ survival function of Weibull(k, λ): +-- +-- > f(x) = (k/λ) (x/λ)^(k-1) exp(-(x/λ)^k) for x > 0 +-- > S(x) = exp(-(x/λ)^k) +-- +-- Both the shape k and scale λ are positive. k < 1 means decreasing failure +-- rate (early failures/infant mortality), k = 1 is the exponential +-- distribution, and k > 1 means increasing failure rate (wear-out failures). +module Hanalyze.Model.Weibull + ( -- * 結果型 + WeibullFit (..) + -- * MLE fit + , fitWeibullMLE + , fitWeibullCensored + -- * 派生量 + , bxLife + , bxLifeCI + , weibullParameterSE + , weibullParameterCovariance + -- * 数値ユーティリティ + , quantileNormal + ) where + +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as V + +-- =========================================================================== +-- 型定義 +-- =========================================================================== + +-- | [日本語]: Weibull MLE 結果。 +-- [English]: A Weibull MLE result. +data WeibullFit = WeibullFit + { wfShape :: !Double -- ^ [日本語]: k (形状パラメータ、 > 0) [English]: k (the shape parameter, > 0) + , wfScale :: !Double -- ^ [日本語]: λ (尺度パラメータ、 > 0) [English]: λ (the scale parameter, > 0) + , wfLogLik :: !Double -- ^ [日本語]: 対数尤度の MLE 値 [English]: The log-likelihood at the MLE + , wfN :: !Int -- ^ [日本語]: 観測総数 (打ち切り含む) [English]: The total number of observations (including censored) + , wfRObs :: !Int -- ^ [日本語]: 観測 failure 数 (打ち切り除く) [English]: The number of observed failures (excluding censored) + , wfFisher :: !(Double, Double, Double) + -- ^ [日本語]: Fisher 情報行列 2x2 を上三角 (I_kk, I_kλ, I_λλ) で保持。 + -- Wald SE 計算で逆行列を取る。 + -- [English]: Holds the upper triangle of the 2x2 Fisher information + -- matrix (I_kk, I_kλ, I_λλ). Its inverse is taken for the Wald SE + -- calculation. + } deriving (Show) + +-- =========================================================================== +-- 内部ヘルパ +-- =========================================================================== + +-- | [日本語]: 観測値リストの sanity check (全て正で非空)。 +-- [English]: A sanity check on the observation list (all positive and +-- non-empty). +validatePositive :: Vector Double -> Either Text () +validatePositive xs + | V.null xs = Left "fitWeibull: empty observation series" + | V.any (<= 0) xs = Left "fitWeibull: all observations must be positive" + | otherwise = Right () + +-- | [日本語]: A(k) = Σ x_i^k log x_i (failures のみ加算する版は censored 用)。 +-- [English]: A(k) = Σ x_i^k log x_i (the variant summing only failures is +-- for the censored case). +weightedLog :: Double -> Vector Double -> Double +weightedLog k xs = V.sum (V.map (\x -> x ** k * log x) xs) + +-- | [日本語]: B(k) = Σ x_i^k。 censored 含む場合は加算範囲を呼び出し側で制御する。 +-- [English]: B(k) = Σ x_i^k. When censored observations are included, the +-- caller controls the summation range. +sumPow :: Double -> Vector Double -> Double +sumPow k xs = V.sum (V.map (** k) xs) + +-- | [日本語]: g(k) = A(k)/B(k) − (1/r)·Σ_{failures} log x − 1/k = 0 +-- r = failure 数。 単調増加なので bisection で root を取れる。 +-- [English]: g(k) = A(k)/B(k) − (1/r)·Σ_{failures} log x − 1/k = 0, +-- where r = the number of failures. Since it is monotonically increasing, +-- the root can be found via bisection. +scoreG :: Double -> Vector Double -> Vector Double -> Int -> Double +scoreG k allXs failuresXs r = + let bk = sumPow k allXs + ak = weightedLog k allXs + meanLogFail = V.sum (V.map log failuresXs) / fromIntegral r + in ak / bk - meanLogFail - 1 / k + +-- | [日本語]: 単調増加関数の root を bisection で。 区間 [lo, hi] で g(lo) < 0 < g(hi) を仮定。 +-- [English]: Finds the root of a monotonically increasing function via +-- bisection. Assumes g(lo) < 0 < g(hi) over the interval [lo, hi]. +bisect + :: (Double -> Double) -- 単調増加 g + -> Double -- lo + -> Double -- hi + -> Double -- 許容誤差 + -> Int -- 最大反復 + -> Either Text Double +bisect g lo0 hi0 tol maxIter = go lo0 hi0 0 + where + go !lo !hi !i + | i >= maxIter = Left "Weibull MLE: bisection did not converge" + | (hi - lo) < tol = Right ((lo + hi) / 2) + | otherwise = + let mid = (lo + hi) / 2 + gm = g mid + in if gm > 0 + then go lo mid (i + 1) + else go mid hi (i + 1) + +-- | [日本語]: 区間を「拡張 + 縮小」 でブラケットを取る。 +-- 関数 g は単調増加。 g(start_lo) ≥ 0 や g(start_hi) ≤ 0 の場合は範囲を広げる。 +-- [English]: Brackets the root by "expanding + shrinking" the interval. +-- g is monotonically increasing; the range is widened when g(start_lo) ≥ 0 +-- or g(start_hi) ≤ 0. +findBracket + :: (Double -> Double) + -> Double -- 初期 lo (>0) + -> Double -- 初期 hi + -> Int -- 最大拡張回数 + -> Either Text (Double, Double) +findBracket g lo0 hi0 maxExp = go lo0 hi0 0 + where + go !lo !hi !i + | i >= maxExp = Left "Weibull MLE: failed to bracket root" + | otherwise = + let glo = g lo + ghi = g hi + in if glo <= 0 && ghi >= 0 + then Right (lo, hi) + else if glo > 0 -- root より大きすぎる + then go (lo / 4) hi (i + 1) + else if ghi < 0 -- root より小さすぎる + then go lo (hi * 4) (i + 1) + else Right (lo, hi) + +-- | [日本語]: 全観測 failure 仮定で MLE を解く中核ロジック。 +-- xs (failure 時間) + xsAll (全観測; censored 含む) を分けるのは、 打ち切りに +-- 対応するため。 +-- [English]: The core logic solving the MLE, assuming all observations are +-- failures. Splitting xs (failure times) from xsAll (all observations, +-- including censored) is to support censoring. +solveWeibull + :: Vector Double -- failures (時間) + -> Vector Double -- 全観測 (失敗 + 打ち切り) + -> Int -- failure 数 r + -> Either Text WeibullFit +solveWeibull failuresXs allXs r = do + let g k = scoreG k allXs failuresXs r + (lo, hi) <- findBracket g 0.1 10.0 30 + k <- bisect g lo hi 1e-10 200 + let bk = sumPow k allXs + lam = (bk / fromIntegral r) ** (1 / k) + -- log-likelihood at MLE (failures contribution + censored survival) + n = V.length allXs + sumLogFailures = V.sum (V.map log failuresXs) + sumScaled = V.sum (V.map (\x -> (x / lam) ** k) allXs) + ll = fromIntegral r * (log k - k * log lam) + + (k - 1) * sumLogFailures + - sumScaled + -- 観測 Fisher 情報 (uncensored 公式; censored ではバイアスあり) + -- I_kk ≈ r / k^2 + Σ (x/λ)^k (log(x/λ))^2 + -- I_λλ ≈ k^2 · (Σ (x/λ)^k) / λ^2 − r k / λ^2 ... 簡素化: + -- 厳密 expected information を Phase 2.4 で詰める。 ここでは + -- observed information (負 Hessian) の対角成分を返す。 + iKK = fromIntegral r / (k * k) + + V.sum (V.map (\x -> (x / lam) ** k * (log (x / lam))**2) allXs) + iLL = (k * k / (lam * lam)) * V.sum (V.map (\x -> (x / lam) ** k) allXs) + - fromIntegral r * k / (lam * lam) + 2 * k * fromIntegral r / (lam * lam) + -- 教科書: I_λλ = r·k² / λ² (uncensored at MLE は Σ (x/λ)^k = r) + -- censored の場合は上の Σ がそのまま入る。 + iKL = V.sum (V.map (\x -> (x / lam) ** k * log (x / lam)) allXs) + * (k / lam) + - fromIntegral r / lam + pure WeibullFit + { wfShape = k + , wfScale = lam + , wfLogLik = ll + , wfN = n + , wfRObs = r + , wfFisher = (iKK, iKL, iLL) + } + +-- =========================================================================== +-- 公開関数 +-- =========================================================================== + +-- | [日本語]: Weibull MLE (打ち切り無し)。 +-- +-- 入力: 全て観測済の故障時間 (> 0)。 +-- 解法: score equation @1/k = A(k)/B(k) − (1/n)·Σ log x@ を 1D bisection で +-- 解き、 λ = (Σ x^k / n)^(1/k)。 +-- +-- [English]: Weibull MLE (no censoring). +-- +-- Input: fully observed failure times (> 0). +-- Method: solves the score equation @1/k = A(k)/B(k) − (1/n)·Σ log x@ via +-- 1-D bisection, then λ = (Σ x^k / n)^(1/k). +fitWeibullMLE :: Vector Double -> Either Text WeibullFit +fitWeibullMLE xs = do + _ <- validatePositive xs + if V.length xs < 2 + then Left "fitWeibullMLE: need at least 2 observations" + else + let logs = V.map log xs + maxL = V.maximum logs + meanL = V.sum logs / fromIntegral (V.length xs) + in if abs (maxL - meanL) < 1e-12 + then Left "fitWeibullMLE: data is constant (degenerate)" + else solveWeibull xs xs (V.length xs) + +-- | [日本語]: Weibull MLE (右打ち切り対応)。 +-- +-- 第 2 引数の @True@ = failure observed、 @False@ = right-censored。 +-- 同じ score equation @1/k = A_all(k)/B_all(k) − (1/r)·Σ_{δ=1} log x@ を解くが、 +-- @A@, @B@ は 全観測 (failure + 打ち切り) で加算し、 log-sum は failure のみ。 +-- @r@ は failure 数。 +-- +-- [English]: Weibull MLE (supports right censoring). +-- +-- The second argument's @True@ = failure observed, @False@ = right-censored. +-- Solves the same score equation +-- @1/k = A_all(k)/B_all(k) − (1/r)·Σ_{δ=1} log x@, but @A@ and @B@ sum over +-- all observations (failures + censored), while the log-sum is over failures +-- only. @r@ is the number of failures. +fitWeibullCensored :: Vector Double -> Vector Bool -> Either Text WeibullFit +fitWeibullCensored xs deltas = do + _ <- validatePositive xs + if V.length xs /= V.length deltas + then Left "fitWeibullCensored: times and delta indicators differ in length" + else + let failuresXs = V.ifilter (\i _ -> deltas V.! i) xs + r = V.length failuresXs + in if r < 2 + then Left "fitWeibullCensored: need at least 2 observed failures" + else + let logsFail = V.map log failuresXs + maxL = V.maximum logsFail + meanL = V.sum logsFail / fromIntegral r + in if abs (maxL - meanL) < 1e-12 + then Left "fitWeibullCensored: failure data is constant (degenerate)" + else solveWeibull failuresXs xs r + +-- | [日本語]: B_p 寿命: F^{-1}(p) = λ · (−ln(1−p))^(1/k)。 +-- +-- 典型用途: @bxLife 0.10 fit@ → B_10 (10%故障時間)、 +-- @bxLife 0.50 fit@ → B_50 (中央寿命)。 +-- +-- [English]: B_p life: F^{-1}(p) = λ · (−ln(1−p))^(1/k). +-- +-- Typical usage: @bxLife 0.10 fit@ → B_10 (the 10% failure time), +-- @bxLife 0.50 fit@ → B_50 (the median life). +bxLife :: Double -> WeibullFit -> Double +bxLife p _ | p <= 0 || p >= 1 = error "bxLife: probability must be in (0, 1)" +bxLife p fit = + let k = wfShape fit + lam = wfScale fit + in lam * (- log (1 - p)) ** (1 / k) + +-- | [日本語]: (k_SE, λ_SE) — Fisher 情報行列の逆行列の対角の平方根。 +-- +-- 2x2 逆行列: var(k) = I_λλ / det、 var(λ) = I_kk / det、 det = I_kk·I_λλ − I_kλ² +-- +-- [English]: (k_SE, λ_SE) — the square root of the diagonal of the inverse +-- Fisher information matrix. +-- +-- 2x2 inverse: var(k) = I_λλ / det, var(λ) = I_kk / det, +-- det = I_kk·I_λλ − I_kλ². +weibullParameterSE :: WeibullFit -> (Double, Double) +weibullParameterSE fit = + let (vK, _, vL) = weibullParameterCovariance fit + in (sqrt (max 0 vK), sqrt (max 0 vL)) + +-- | [日本語]: (Var(k), Cov(k, λ), Var(λ))。 Fisher 情報行列の 2x2 逆行列。 +-- 非正定値の場合は (0, 0, 0) を返す (canvas 側で警告するための signal)。 +-- [English]: (Var(k), Cov(k, λ), Var(λ)). The 2x2 inverse of the Fisher +-- information matrix. Returns (0, 0, 0) when not positive-definite (a +-- signal for the canvas side to warn about). +weibullParameterCovariance :: WeibullFit -> (Double, Double, Double) +weibullParameterCovariance fit = + let (iKK, iKL, iLL) = wfFisher fit + det = iKK * iLL - iKL * iKL + in if det <= 0 + then (0, 0, 0) + else (iLL / det, -iKL / det, iKK / det) + +-- | [日本語]: B_p 寿命の Wald 信頼区間 (delta method)。 +-- +-- @bxLifeCI p α fit@ で「故障時間が確率 p に達する時刻」 の +-- 信頼度 @1 − α@ 信頼区間 (例: α = 0.05 で 95% CI) を返す。 +-- +-- delta method: +-- +-- > Var(B_p) ≈ (∂B_p/∂k)² Var(k) + (∂B_p/∂λ)² Var(λ) + 2 (∂B_p/∂k)(∂B_p/∂λ) Cov(k,λ) +-- > ∂B_p/∂λ = B_p / λ +-- > ∂B_p/∂k = −B_p · log(−log(1−p)) / k² +-- +-- 戻り値: @(estimate, lower, upper)@。 lower は max(0, ...) で 0 にクリップ +-- (寿命は非負)。 共分散が非正定値で SE 計算不能の場合は @(estimate, estimate, estimate)@。 +-- +-- 注: α は両側で考えるので 95% CI なら z = 1.96 を内部使用。 +-- +-- [English]: The Wald confidence interval for B_p life (delta method). +-- +-- @bxLifeCI p α fit@ returns the @1 − α@ confidence interval (e.g. α = 0.05 +-- for a 95% CI) for "the time at which the failure probability reaches p". +-- +-- Delta method: +-- +-- > Var(B_p) ≈ (∂B_p/∂k)² Var(k) + (∂B_p/∂λ)² Var(λ) + 2 (∂B_p/∂k)(∂B_p/∂λ) Cov(k,λ) +-- > ∂B_p/∂λ = B_p / λ +-- > ∂B_p/∂k = −B_p · log(−log(1−p)) / k² +-- +-- Return value: @(estimate, lower, upper)@. lower is clipped to 0 via +-- max(0, ...) (life is non-negative). When the covariance is not +-- positive-definite and the SE cannot be computed, returns +-- @(estimate, estimate, estimate)@. +-- +-- Note: since α is considered two-sided, a 95% CI uses z = 1.96 internally. +bxLifeCI :: Double -> Double -> WeibullFit -> (Double, Double, Double) +bxLifeCI p alpha fit = + let bp = bxLife p fit + k = wfShape fit + lam = wfScale fit + (vK, cKL, vL) = weibullParameterCovariance fit + logArg = log (- log (1 - p)) + dbdL = bp / lam + dbdK = - bp * logArg / (k * k) + varBp = dbdK * dbdK * vK + dbdL * dbdL * vL + 2 * dbdK * dbdL * cKL + seBp = if varBp > 0 then sqrt varBp else 0 + z = quantileNormal (1 - alpha / 2) + lo = max 0 (bp - z * seBp) + hi = bp + z * seBp + in (bp, lo, hi) + +-- | [日本語]: 標準正規分布の分位点 (近似)。 95% CI で z = 1.959964…。 +-- Acklam 高精度近似 (12 桁) を採用。 +-- [English]: The quantile of the standard normal distribution +-- (approximate). z = 1.959964… for a 95% CI. Uses Acklam's +-- high-precision approximation (12 digits). +quantileNormal :: Double -> Double +quantileNormal q + | q <= 0 || q >= 1 = error "quantileNormal: q must be in (0, 1)" + | q < pLow = let qn = sqrt (-2 * log q) in + (((((cN1 * qn + cN2) * qn + cN3) * qn + cN4) * qn + cN5) * qn + cN6) + / ((((dN1 * qn + dN2) * qn + dN3) * qn + dN4) * qn + 1) + | q <= pHigh = let qn = q - 0.5; r = qn * qn in + ((((((aN1 * r + aN2) * r + aN3) * r + aN4) * r + aN5) * r + aN6) * qn) + / (((((bN1 * r + bN2) * r + bN3) * r + bN4) * r + bN5) * r + 1) + | otherwise = let qn = sqrt (-2 * log (1 - q)) in + negate $ + (((((cN1 * qn + cN2) * qn + cN3) * qn + cN4) * qn + cN5) * qn + cN6) + / ((((dN1 * qn + dN2) * qn + dN3) * qn + dN4) * qn + 1) + where + pLow = 0.02425 + pHigh = 1 - pLow + aN1 = -3.969683028665376e1; aN2 = 2.209460984245205e2 + aN3 = -2.759285104469687e2; aN4 = 1.383577518672690e2 + aN5 = -3.066479806614716e1; aN6 = 2.506628277459239e0 + bN1 = -5.447609879822406e1; bN2 = 1.615858368580409e2 + bN3 = -1.556989798598866e2; bN4 = 6.680131188771972e1 + bN5 = -1.328068155288572e1 + cN1 = -7.784894002430293e-3; cN2 = -3.223964580411365e-1 + cN3 = -2.400758277161838e0; cN4 = -2.549732539343734e0 + cN5 = 4.374664141464968e0; cN6 = 2.938163982698783e0 + dN1 = 7.784695709041462e-3; dN2 = 3.224671290700398e-1 + dN3 = 2.445134137142996e0; dN4 = 3.754408661907416e0 diff --git a/src/Hanalyze/Optim/BayesOpt.hs b/src/Hanalyze/Optim/BayesOpt.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Optim/BayesOpt.hs @@ -0,0 +1,800 @@ +-- | +-- Module : Hanalyze.Optim.BayesOpt +-- Description : ベイズ最適化ループ (GP フィット + 獲得関数最大化) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Bayesian Optimization loop. +-- +-- Single-objective procedure: +-- +-- 1. Evaluate initial points (Latin hypercube or random). +-- 2. Fit a Gaussian process to the observations. +-- 3. Maximize an acquisition function to choose the next @x@. +-- 4. Evaluate @x@ and append to the observed sequence. +-- 5. Repeat steps 2-4 for @T@ iterations. +{-# LANGUAGE StrictData #-} +{-# LANGUAGE OverloadedStrings #-} +module Hanalyze.Optim.BayesOpt + ( BayesOptConfig (..) + , defaultBayesOptConfig + , BOIterEvent (..) + , bayesOpt + , bayesOptWithCallback + , bayesOptND + , bayesOptScalarMO + , bayesOptMOWithNSGA + -- * GP HP optimization helpers + , optimizeGPMVRestart + , optimizeHPMultiRestart + ) where + +import Control.Exception (SomeException, try, evaluate) +import Control.Monad (forM, replicateM) +import Data.List (minimumBy, maximumBy, sortBy) +import Data.Ord (comparing) +import System.IO.Unsafe (unsafePerformIO) +import System.Random.MWC (GenIO, uniform) + +import Hanalyze.Model.GP (Kernel (..), GPModel (..), GPResult (..), GPParams (..), + gpKernelParams, + fitGP, optimizeGP, initParamsFromData, + GPResultMV (..), fitGPMV, optimizeGPMV, + logMarginalLikelihoodMV, + buildKernelMatrixMV, noiseKernelMV) +import qualified Hanalyze.Stat.Cholesky as Chol +import qualified Hanalyze.Stat.KernelDist as KD +import Hanalyze.Optim.Acquisition (ei, ucb, pi_, parEGO) +import Hanalyze.Optim.NSGA (NSGAConfig (..), defaultNSGAConfig, + Solution (..), nsga2) +import Hanalyze.Optim.Common (Bounds) +import qualified Hanalyze.Optim.LineSearch as LS +import qualified Hanalyze.Optim.LBFGS as LBFGS +import qualified Hanalyze.Optim.Common as OC +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Stat.QuasiRandom as QR +import qualified Hanalyze.Stat.Standardize as Std +import Statistics.Distribution (cumulative, density) +import Statistics.Distribution.Normal (standard) + +-- | Bayesian Optimization configuration. +data BayesOptConfig = BayesOptConfig + { boIterations :: Int -- ^ Evaluation budget (excluding initial points). + , boInitPoints :: Int -- ^ Number of initial sample points. + , boKernel :: Kernel -- ^ GP kernel. + , boUCBBeta :: Double -- ^ @β@ for UCB. + , boGridSize :: Int -- ^ Inner-optimization grid density (1D). + } deriving (Show) + +-- | Default configuration: 30 iterations, 5 initial points, +-- __Matérn 5/2 kernel__, @β = 2.0@ for UCB, grid size 200 for 1D +-- inner optimization. +-- +-- Matérn 5/2 is the recommended default for general-purpose BO +-- (matches scikit-optimize's defaults). RBF is too smooth for many +-- real-world objective surfaces; Matérn captures the @C²@ regularity +-- typical of engineering / black-box functions and is what the BO +-- literature converged on. +defaultBayesOptConfig :: BayesOptConfig +defaultBayesOptConfig = BayesOptConfig + { boIterations = 30 + , boInitPoints = 5 + , boKernel = Matern52 + , boUCBBeta = 2.0 + , boGridSize = 200 + } + +-- | Single-objective Bayesian Optimization (1D simplified entry point). +-- +-- Returns @(observations, best)@: the full @(x, y)@ history and the best +-- @(x*, y*)@. +-- | [日本語]: BO の各 iteration 末端で発火するイベント。 +-- [English]: The event fired at the end of each BO iteration. +data BOIterEvent = BOIterEvent + { boeIter :: !Int -- ^ [日本語]: 0-based iteration index。 [English]: 0-based iteration index. + , boeProposedX :: !Double -- ^ [日本語]: acquisition が選んだ新点。 [English]: The new point chosen by the acquisition function. + , boeProposedY :: !Double -- ^ [日本語]: そこでの f 値。 [English]: The f value at that point. + , boeCurrentBest :: !(Double, Double) -- ^ [日本語]: (x*, y*) これまで。 [English]: The best (x*, y*) so far. + } deriving (Show) + +bayesOpt :: BayesOptConfig + -> (Double -> IO Double) -- ^ Objective (1D, minimized). + -> (Double, Double) -- ^ Search bounds. + -> GenIO + -> IO ([(Double, Double)], (Double, Double)) +bayesOpt cfg f bounds gen = + bayesOptWithCallback cfg f bounds gen (\_ -> pure ()) + +-- | [日本語]: BO iteration ごとに 'BOIterEvent' を渡す callback 付き版。 +-- 既存 'bayesOpt' は no-op callback の wrapper として保持される。 +-- [English]: A version with a callback that passes a 'BOIterEvent' on +-- every BO iteration. The existing 'bayesOpt' is kept as a wrapper around a +-- no-op callback. +bayesOptWithCallback + :: BayesOptConfig + -> (Double -> IO Double) + -> (Double, Double) + -> GenIO + -> (BOIterEvent -> IO ()) + -> IO ([(Double, Double)], (Double, Double)) +bayesOptWithCallback cfg f (lo, hi) gen onIter = do + -- 初期点 (uniform random, 簡易) + initX <- replicateM (boInitPoints cfg) (do + u <- uniform gen :: IO Double + return (lo + u * (hi - lo))) + initY <- mapM f initX + let history0 = zip initX initY + totalIter = boIterations cfg + + -- BO ループ + -- 内側 acquisition 最大化は **Brent 法** (1D 単峰超線形収束)。 + -- 旧 grid (boGridSize 点) は seeding として併用、Brent の bracket を作る。 + let loop t hist + | t == 0 = return hist + | otherwise = do + let xs = map fst hist + ys = map snd hist + yBest = minimum ys + p0 = initParamsFromData xs ys + pOpt = optimizeGP (boKernel cfg) xs ys p0 + model = GPModel (boKernel cfg) pOpt + + -- 1 点での負 EI (Brent は最小化、引数は [Double] で受ける) + -- Cholesky / SVD 失敗時はペナルティ +1e30 を返す。 + -- gpMean / gpUpper は遅延フィールドなので evaluate で強制してから返す。 + negEI [x] = unsafePerformIO $ do + let computed = do + let res = fitGP model xs ys [x] + mu = head (gpMean res) + sg = (head (gpUpper res) - mu) / 2 + _ <- evaluate mu + _ <- evaluate sg + pure (negate (ei yBest 0.01 (mu, sg))) + r <- try computed :: IO (Either SomeException Double) + case r of + Left _ -> pure 1e30 + Right v -> pure v + negEI _ = error "negEI: 1D" + + -- 粗グリッドで bracket を作る + gridN = max 16 (boGridSize cfg `div` 4) + grid = [lo + fromIntegral i * (hi - lo) + / fromIntegral (gridN - 1) + | i <- [0 .. gridN - 1]] + gridV = [(x, negEI [x]) | x <- grid] + bestG = minimumBy (comparing snd) gridV + bestX = fst bestG + idxBest = case [i | (i, (gx, _)) <- zip [0::Int ..] gridV, gx == bestX] of + (k:_) -> k; [] -> 0 + ax = fst (gridV !! max 0 (idxBest - 1)) + bx = fst (gridV !! min (gridN - 1) (idxBest + 1)) + -- Brent で局所最大 (= 負の最小) + bRes = LS.brent (LS.defaultBrentConfig { LS.bcMaxIter = 80 + , LS.bcTol = 1e-7 }) + negEI (min ax bx) (max ax bx) + xNext = head (OC.orBest bRes) + + yNext <- f xNext + let newHist = hist ++ [(xNext, yNext)] + bestPair = head [pair | pair@(_, y) <- newHist + , y == minimum (map snd newHist)] + iterIdx = totalIter - t -- 0-based + onIter BOIterEvent + { boeIter = iterIdx + , boeProposedX = xNext + , boeProposedY = yNext + , boeCurrentBest = bestPair + } + loop (t - 1) newHist + + finalHist <- loop totalIter history0 + let bestPair = head [pair | pair@(_, y) <- finalHist + , y == minimum (map snd finalHist)] + return (finalHist, bestPair) + +-- --------------------------------------------------------------------------- +-- GP HP optimization with multiple random restarts +-- --------------------------------------------------------------------------- + +-- | Optimize a GP's hyperparameters with multiple random restarts and +-- pick the best (highest marginal likelihood). One restart corresponds +-- to a single 'optimizeGPMV' call from a perturbed initial point. +-- +-- Critical for BO performance: the marginal-likelihood surface is +-- multi-modal, so a single fixed init is not robust. scikit-optimize +-- defaults to @n_restarts_optimizer = 0@ (= 1 fit) but its kernel has +-- the prior baked in; for our wider search we use 5 restarts. +optimizeGPMVRestart + :: Int -- ^ Number of restarts. + -> Kernel + -> LA.Matrix Double -- ^ Training X (n × p). + -> LA.Vector Double -- ^ Training y (length n). + -> GenIO + -> IO GPParams +optimizeGPMVRestart n kern x y gen = do + let p0base = initParamsFromData (concat (LA.toLists x)) (LA.toList y) + -- generate n random initial points: log-spaced perturbation of p0base + -- to cover several orders of magnitude. + let scaleVar = sqrt . max 1e-6 + inits <- forM [1 .. n] $ \_ -> do + u1 <- uniform gen :: IO Double + u2 <- uniform gen :: IO Double + u3 <- uniform gen :: IO Double + -- log-uniform multipliers in [0.1, 10] + let m1 = exp ((u1 - 0.5) * 2 * log 10) + m2 = exp ((u2 - 0.5) * 2 * log 10) + m3 = exp ((u3 - 0.5) * 2 * log 10) + pure $ p0base + { gpLengthScale = max 1e-3 (gpLengthScale p0base * m1) + , gpSignalVar = max 1e-6 (scaleVar (gpSignalVar p0base) * m2) + , gpNoiseVar = max 1e-6 (gpNoiseVar p0base * m3) + } + let runOne p0 = do + let pOpt = optimizeGPMV kern x y p0 + ll = logMarginalLikelihoodMV x y kern pOpt + pure (pOpt, ll) + results <- mapM runOne inits + let (best, _) = head [ r | r@(_, ll) <- results + , ll == maximum (map snd results) ] + pure best + +-- | [日本語]: N-dimensional single-objective Bayesian Optimization。 +-- 内側 acquisition 最大化を __L-BFGS multi-start__ で行う: +-- bounds 範囲内で nStarts 個の初期点を一様乱数で生成、各点から L-BFGS で +-- 負 EI を最小化、最良点を採用。 +-- [English]: N-dimensional single-objective Bayesian Optimization. +-- The inner acquisition maximization is done via __L-BFGS multi-start__: +-- generate nStarts initial points via uniform random sampling within the +-- bounds, minimize the negative EI from each with L-BFGS, and take the best +-- point. +bayesOptND :: BayesOptConfig + -> Int -- ^ [日本語]: multi-start 数 (典型 5-20)。 [English]: The number of multi-starts (typically 5-20). + -> ([Double] -> IO Double) -- ^ [日本語]: 目的関数 (N 次元、最小化)。 [English]: The objective function (N-dimensional, minimized). + -> Bounds -- ^ [日本語]: 各次元 (lo, hi)。 [English]: The (lo, hi) bounds for each dimension. + -> GenIO + -> IO ([([Double], Double)], ([Double], Double)) +bayesOptND cfg nStarts f bounds gen = do + let dim = length bounds + kern = boKernel cfg + -- Initial design: low-discrepancy Halton sequence (better + -- coverage of the box than iid uniform random for the small @n@ + -- typical of BO initial designs). + initX = QR.haltonSequenceIn (boInitPoints cfg) bounds + sampleX = forM bounds $ \(lo, hi) -> do + u <- uniform gen :: IO Double + return (lo + u * (hi - lo)) + initY <- mapM f initX + let history0 = zip initX initY + + -- BO2: per-dim X scaling — map every dim to [0, 1] using its (lo, hi) + -- bound. After this, a single isotropic ℓ in the GP equates to per-dim + -- length scales = ℓ × (hi - lo) in the original space, i.e. ARD with + -- weights tied to the box width. skopt's "transform=normalize" + -- preprocessing achieves the same effect. + let scaleX :: [Double] -> [Double] + scaleX xs = [ if hi > lo then (v - lo) / (hi - lo) else v + | ((lo, hi), v) <- zip bounds xs ] + unitBounds = replicate dim (0, 1) + -- Phase B (GP-Hedge, Hoffman 2011): maintain online "gains" for + -- {EI, LCB, PI}. Each iteration each acquisition proposes its best + -- candidate via L-BFGS multi-start; one is selected by softmax over + -- gains, evaluated, and gains are updated using the GP's predicted + -- μ at every proposal (lower μ = higher reward for minimisation). + -- This protects against any single acquisition's pathological + -- behaviour on a given problem (e.g. EI's exploitation bias on + -- multi-modal Branin). + let hedgeEta = 1.0 :: Double + pickAcq gains gen0 = do + let m = maximum gains + ws = map (\g -> exp (hedgeEta * (g - m))) gains + tot = sum ws + ps = map (/ tot) ws + u <- uniform gen0 :: IO Double + let cum = scanl1 (+) ps + pure (length (takeWhile (< u) cum)) + let loop t hist gains + | t == 0 = return hist + | otherwise = do + let xss = map fst hist + ys = map snd hist + -- BO2: scale X to [0,1]^d for the GP only (history is + -- still kept in raw units for f). + xssScl = map scaleX xss + xMat = LA.fromLists xssScl + yVec0 = LA.fromList ys + -- BO1: z-score y so HP optimization is scale-free + -- (skopt normalize_y=True equivalent). Both GP fitting + -- and EI run in normalized space; the next-x choice is + -- scale-equivariant. + stdr = Std.fitStandardizer (LA.asColumn yVec0) + yVec = LA.flatten + (Std.applyStandardizer stdr (LA.asColumn yVec0)) + yBest = LA.minElement yVec + -- After BO2 scaling, X lives on [0, 1]^d. The natural ℓ + -- grows as √d (mean pairwise distance scales that way), + -- so start L-BFGS from ℓ = 0.25 √d to keep correlations + -- meaningful as input dimension grows. + -- + -- Phase A (true ARD): the per-dim ℓ_d API is implemented + -- in 'Hanalyze.Model.GP.GPParams.gpLengthScales' but disabled in + -- the BO loop because with only ~30 evaluations the + -- per-dim L-BFGS over-fits noise and underperforms + -- isotropic on both Branin and Hartmann6. Future tuning + -- (e.g. tighter ℓ_d prior, isotropic-warm-start) can + -- re-enable it by setting 'gpLengthScales = Just v'. + p0Base = initParamsFromData (concat xssScl) (LA.toList yVec) + ell0 = 0.25 * sqrt (fromIntegral dim) + p0 = p0Base { gpLengthScale = ell0 } + pOpt = optimizeGPMV kern xMat yVec p0 + params = pOpt + -- BO core fix: precompute Cholesky factor (R) and + -- α = Ky⁻¹ y ONCE per BO iteration. The negEI callback + -- reuses them via 'predictFast' below; this replaces the + -- old fitGPMV-per-call which factorised Ky on every + -- L-BFGS step (O(n³) wasted per evaluation). + kyMat = noiseKernelMV kern params xMat + rChol = case Chol.cholFactor kyMat of + Just r -> r + Nothing -> + -- Jitter and try again. + let n = LA.rows xMat + kyJ = kyMat + + LA.scale 1e-4 (LA.ident n) + in case Chol.cholFactor kyJ of + Just r -> r + Nothing -> error "BO: chol failed" + alpha = LA.flatten + (Chol.cholSolveWithFactor rChol + (LA.asColumn yVec)) + sf = gpSignalVar params + + -- Predict (μ, σ, k_star, vstar) at a single x via the + -- cached factor. vstar = Ky⁻¹ k_star is reused for both + -- the variance and its gradient. + predictAt xVec = + let xScl = LA.fromList (scaleX xVec) + xRow = LA.asRow xScl + kStarV = LA.flatten + (buildKernelMatrixMV kern (gpKernelParams params) xRow xMat) + mu = LA.dot kStarV alpha + vstar = LA.flatten + (Chol.cholSolveWithFactor rChol + (LA.asColumn kStarV)) + varV = max 0 (sf - LA.dot kStarV vstar) + in (mu, sqrt varV, kStarV, vstar) + + predictMuSig xVec = let (m, s, _, _) = predictAt xVec in (m, s) + + -- Batch predict (μ, σ) at m candidate rows simultaneously. + -- Single GEMM for K_*, single triangular solve for V, + -- elementwise σ². Replaces m sequential predicts (m + -- BLAS-dispatch overheads) with O(1) BLAS calls. + predictBatchScaled + :: LA.Matrix Double -- ^ Scaled X candidates (m × p) + -> (LA.Vector Double, LA.Vector Double) + predictBatchScaled xCand = + let kStar = buildKernelMatrixMV kern (gpKernelParams params) xCand xMat -- m × n + mus = kStar LA.#> alpha -- m + vMat = Chol.cholSolveWithFactor rChol (LA.tr kStar) -- n × m + -- F1: diag(kStar · vMat) without forming m×m. + kStarDotV = KD.diagAB kStar vMat + sigmas = LA.cmap (\v -> sqrt (max 0 (sf - v))) kStarDotV + in (mus, sigmas) + + -- Phase C (BO4 analytic gradient): per-input partial + -- derivatives of μ and σ w.r.t. x. Avoids the 2(p+1) + -- function-call overhead of central differences inside + -- the inner L-BFGS. Periodic kernel falls back to the + -- numeric path (gradient unsupported). + -- + -- diffs[i, d] = scaleX(x)_d − xMat[i, d] + -- factor_i = ∂k_i/∂(diffs_i,d) / diffs_i,d (kernel-specific) + -- ∂μ/∂x_scaled_d = (factor ⊙ α)ᵀ · diffs[:, d] + -- ∂σ/∂x_scaled_d = −(1/σ) · (factor ⊙ vstar)ᵀ · diffs[:, d] + -- Chain back to raw x_d via 1/(hi - lo) factor (BO2). + gradMuSig xVec = + let xScl = LA.fromList (scaleX xVec) + diffs = LA.fromRows + [ xScl - xRow | xRow <- LA.toRows xMat ] + sqd = LA.fromList + [ d `LA.dot` d | d <- LA.toRows diffs ] + l = gpLengthScale params + l2 = l * l + kStarV = LA.flatten + (buildKernelMatrixMV kern (gpKernelParams params) + (LA.asRow xScl) xMat) + factor = case kern of + RBF -> + LA.scale (-1 / l2) kStarV + Matern52 -> + let r = LA.cmap (\s -> + sqrt (max 0 s) * sqrt 5 / l) sqd + ef = LA.cmap exp (LA.scale (-1) r) + c = LA.scale (-5 / (3 * l2)) + (sf `LA.scale` + (ef * (LA.cmap (1 +) r))) + in c + _ -> + LA.konst 0 (LA.size kStarV) -- Periodic/Linear/Poly: numeric fallback + vstar = LA.flatten + (Chol.cholSolveWithFactor rChol + (LA.asColumn kStarV)) + mu = LA.dot kStarV alpha + varV = max 0 (sf - LA.dot kStarV vstar) + sg = sqrt varV + -- ∇μ in scaled coordinates: diffsᵀ · (α ⊙ factor) + gradMuS = LA.tr diffs LA.#> (alpha * factor) + -- ∇σ in scaled coordinates: −(1/σ) · diffsᵀ · (vstar ⊙ factor) + gradSgS + | sg < 1e-12 = LA.konst 0 (LA.cols xMat) + | otherwise = LA.scale (-1 / sg) + (LA.tr diffs LA.#> (vstar * factor)) + -- Chain back through scaleX: ∂scaledX/∂x = 1/(hi-lo) + invSpan = LA.fromList + [ if hi > lo then 1 / (hi - lo) else 1 + | (lo, hi) <- bounds ] + gradMu = LA.toList (gradMuS * invSpan) + gradSg = LA.toList (gradSgS * invSpan) + in (mu, sg, gradMu, gradSg) + + -- Build (negAcq, gradNegAcq) pair for each acquisition. + -- ∂EI/∂(μ,σ) = (-Φ(z), φ(z)) so ∇EI = -Φ(z) ∇μ + φ(z) ∇σ. + -- ∂PI/∂(μ,σ) = (-φ(z)/σ, -z·φ(z)/σ) so + -- ∇PI = -φ(z)/σ · ∇μ - z·φ(z)/σ · ∇σ. + -- LCB is linear: ∇LCB = ∇μ − β ∇σ. + wrapAcqGrad + :: ((Double, Double) -> Double) -- acq value + -> ((Double, Double) -> (Double, Double)) -- (∂/∂μ, ∂/∂σ) of acq + -> ([Double] -> Double, [Double] -> [Double]) + wrapAcqGrad acqFn dAcq = + let fn xVec = unsafePerformIO $ do + r <- try (evaluate + (negate (acqFn (let (m, s) = predictMuSig xVec + in (m, s))))) + :: IO (Either SomeException Double) + case r of { Left _ -> pure 1e30; Right v -> pure v } + gn xVec = unsafePerformIO $ do + r <- try (evaluate + (let (mu, sg, gMu, gSg) = gradMuSig xVec + (dM, dS) = dAcq (mu, sg) + in [ - (dM * gm + dS * gs) + | (gm, gs) <- zip gMu gSg ])) + :: IO (Either SomeException [Double]) + case r of + Left _ -> pure (replicate (length xVec) 0) + Right v -> pure v + in (fn, gn) + + eiGrad (mu, sg) + | sg <= 1e-12 = (0, 0) + | otherwise = + let z = (yBest - mu - 0.01) / sg + phi = density standard z + cdf = cumulative standard z + in (-cdf, phi) + piGrad (mu, sg) + | sg <= 1e-12 = (0, 0) + | otherwise = + let z = (yBest - mu - 0.01) / sg + phi = density standard z + in (-phi / sg, -z * phi / sg) + lcbGrad _ = (1, -2.0) -- ∂(μ - 2σ)/∂μ = 1, ∂/∂σ = -2 + + (negEI, gNegEI) = wrapAcqGrad (ei yBest 0.01) eiGrad + (negPI, gNegPI) = wrapAcqGrad (pi_ yBest 0.01) piGrad + -- For LCB we want to minimise μ - βσ. Wrap as the value + -- itself (acq = -LCB), so negate(acq) = LCB. + (negLCB, gNegLCB) = + wrapAcqGrad (negate . ucb 2.0) + (\ms -> let (a, b) = lcbGrad ms in (-a, -b)) + _ = unitBounds + + -- Inner acquisition optimization: original 20 Halton starts + -- (kept for diversity; preselection via batch eval was tried + -- in D2 but consistently regressed Hartmann6 — even with + -- diversity injection — to a -1.83 local mode that the broad + -- Halton scan avoids). Maxiter is reduced from 100 → 50 as + -- a speed compromise (Branin and Hartmann6 still solid). + haltonStarts <- pure (QR.haltonSequenceIn nStarts bounds) + starts <- forM haltonStarts $ \xs -> + forM (zip bounds xs) $ \((lo, hi), v) -> do + u <- uniform gen :: IO Double + let span_ = hi - lo + jit = (u - 0.5) * 0.05 * span_ + pure (max lo (min hi (v + jit))) + let useAnalytic = case kern of + RBF -> True + Matern52 -> True + _ -> False -- Periodic/Linear/Poly は数値勾配 + runMSG objFn gradFn = mapM (\x0 -> + LBFGS.runLBFGSWith + (LBFGS.defaultLBFGSConfig + { LBFGS.lbStop = OC.defaultStopCriteria + { OC.stMaxIter = 50 } }) + objFn gradFn x0) starts + runMS objFn = mapM (\x0 -> + LBFGS.runLBFGSNumeric + (LBFGS.defaultLBFGSConfig + { LBFGS.lbStop = OC.defaultStopCriteria + { OC.stMaxIter = 50 } }) + objFn x0) starts + pickXNext rs = + let best = minimumBy (comparing OC.orValue) rs + xRaw = OC.orBest best + in zipWith (\(lo, hi) v -> max lo (min hi v)) bounds xRaw + xEI <- pickXNext <$> if useAnalytic + then runMSG negEI gNegEI + else runMS negEI + xLCB <- pickXNext <$> if useAnalytic + then runMSG negLCB gNegLCB + else runMS negLCB + xPI <- pickXNext <$> if useAnalytic + then runMSG negPI gNegPI + else runMS negPI + let candidates = [xEI, xLCB, xPI] + -- GP-Hedge selection. + k <- pickAcq gains gen + let kSafe = max 0 (min 2 k) + xNext = candidates !! kSafe + yNext <- f xNext + -- Update gains: reward = -μ at each candidate (we want low μ). + let mus = map (fst . predictMuSig) candidates + gains' = zipWith (\g m -> g - m) gains mus + loop (t - 1) (hist ++ [(xNext, yNext)]) gains' + + finalHist <- loop (boIterations cfg) history0 [0, 0, 0] + let bestPair = minimumBy (comparing snd) finalHist + return (finalHist, bestPair) + +-- --------------------------------------------------------------------------- +-- Phase E1: bounded multi-restart HP optimisation +-- --------------------------------------------------------------------------- + +-- | Bounded multi-restart kernel HP optimization for use inside the BO +-- loop. Mirrors skopt's @cook_estimator@ + @n_restarts_optimizer=2@: +-- runs L-BFGS-B from @n@ random log-uniform inits in +-- @log ℓ ∈ [log 0.01, log 100]@, picks the maximum-LML solution. +-- +-- Compared to a single-init 'optimizeGPMV' this is significantly more +-- robust on multi-modal log-marginal-likelihood surfaces (Branin, where +-- the 3 global mins demand a sharp ℓ but the LML basin near a broad ℓ +-- is also locally optimal). +-- +-- The first init is the user-provided @p0@; subsequent inits are +-- log-uniform perturbations of @p0@ over [0.01, 100]. +optimizeHPMultiRestart + :: Int -- ^ Total restarts (≥ 1) + -> Kernel + -> LA.Matrix Double -- ^ Training X (n × p) + -> LA.Vector Double -- ^ Training y (length n) + -> GPParams -- ^ Initial guess (first restart) + -> GPParams +optimizeHPMultiRestart nRestarts kern trainX y p0 = + let pdim = LA.cols trainX + isARD = case gpLengthScales p0 of + Just v | LA.size v == pdim && pdim > 0 -> True + _ -> False + -- log-space bounds: skopt の length_scale_bounds=(0.01, 100) + logLo = log 0.01 + logHi = log 100 + -- σ_f² and σ_n² の bounds は緩めに (kernel HP より広い) + logVarLo = log 1e-6 + logVarHi = log 1e6 + -- LBFGS bounds for HP vector + hpBounds + | isARD = replicate pdim (logLo, logHi) + ++ [(logVarLo, logVarHi), (logVarLo, logVarHi)] + | otherwise = [(logLo, logHi), (logVarLo, logVarHi) + , (logVarLo, logVarHi)] + -- Pack/unpack between [Double] (LBFGS state) and GPParams + paramsToVec p + | isARD = let Just v = gpLengthScales p + ls = LA.toList v + in map log ls + ++ [log (gpSignalVar p), log (gpNoiseVar p)] + | otherwise = [ log (gpLengthScale p) + , log (gpSignalVar p) + , log (gpNoiseVar p) ] + vecToParams u + | isARD = + let lsV = LA.fromList (map exp (take pdim u)) + in p0 + { gpLengthScales = Just lsV + , gpSignalVar = exp (u !! pdim) + , gpNoiseVar = exp (u !! (pdim + 1)) + } + | otherwise = p0 + { gpLengthScale = exp (u !! 0) + , gpSignalVar = exp (u !! 1) + , gpNoiseVar = exp (u !! 2) + } + -- Negative LML to minimise (LBFGS minimises by default). + negLML u = - logMarginalLikelihoodMV trainX y kern (vecToParams u) + -- Build restart inits: keep σ_f²/σ_n² at p0, vary ℓ over a few + -- fixed log-spaced points (Branin needs sharp ℓ near 0.1, others + -- benefit from broad ℓ near 1-10). + p0Vec = paramsToVec p0 + sigfLog = p0Vec !! pdim -- (paramsToVec layout) for ARD + signLog = p0Vec !! (pdim + 1) + sigfLogIso = p0Vec !! 1 + signLogIso = p0Vec !! 2 + ellGrid = take (max 0 (nRestarts - 1)) [log 0.1, log 1.0, log 10.0] + mkInit ll + | isARD = replicate pdim ll ++ [sigfLog, signLog] + | otherwise = [ll, sigfLogIso, signLogIso] + inits = p0Vec : map mkInit ellGrid + cfg = LBFGS.defaultLBFGSConfig + { LBFGS.lbStop = OC.defaultStopCriteria + { OC.stMaxIter = 50, OC.stTolFun = 1e-7 } + , LBFGS.lbBounds = Just hpBounds + } + runOne u0 = unsafePerformIO $ LBFGS.runLBFGSNumeric cfg negLML u0 + results = map runOne inits + -- Pick the lowest-negLML result (= highest LML) + best = minimumBy (comparing OC.orValue) results + in vecToParams (OC.orBest best) + +-- | [日本語]: Multi-objective BO using __scalarization__ (ParEGO-style)。 +-- 各反復で random 重み w で Tchebycheff scalarize し、単目的 BO の 1 ステップ +-- (L-BFGS multi-start で acquisition 最大化) を実行する。 +-- NSGA 版より高速、acquisition 計算コストが軽い問題に向く。 +-- [English]: Multi-objective BO using __scalarization__ (ParEGO-style). +-- Each iteration performs a Tchebycheff scalarization with a random weight +-- w, then executes a single-objective BO step (maximizing acquisition via +-- L-BFGS multi-start). Faster than the NSGA version; suited to problems +-- where acquisition evaluation is cheap. +bayesOptScalarMO :: Int -- iter + -> Int -- nInit + -> Int -- nStarts (multi-start) + -> Kernel + -> ([Double] -> IO [Double]) + -> Bounds + -> GenIO + -> IO [([Double], [Double])] +bayesOptScalarMO nIter nInit nStarts kern f bounds gen = do + initX <- replicateM nInit (forM bounds $ \(lo, hi) -> do + u <- uniform gen :: IO Double + return (lo + u * (hi - lo))) + initY <- mapM f initX + let history0 = zip initX initY + + step hist = do + let xss = map fst hist + ysAll = map snd hist + qDim = length (head ysAll) + xsFlat = map head xss -- 1D 入力前提の簡易版 + ysCol j = [y !! j | y <- ysAll] + -- random scalarization weight + wsRaw <- replicateM qDim (uniform gen :: IO Double) + let wSum = sum wsRaw + ws = map (/ wSum) wsRaw + -- 各目的の GP fit (1D 入力) + modelFor j = + let trainY = ysCol j + p0 = initParamsFromData xsFlat trainY + pOpt = optimizeGP kern xsFlat trainY p0 + in GPModel kern pOpt + models = [(modelFor j, ysCol j) | j <- [0 .. qDim - 1]] + -- Tchebycheff: max_j w_j (μ_j - z*_j) — z*_j は最良観測 + zStars = [minimum (ysCol j) | j <- [0 .. qDim - 1]] + scalarLcb xVec = unsafePerformIO $ do + let xkey = head xVec + computeOne j = do + let (m, ty) = models !! j + r = fitGP m xsFlat ty [xkey] + mu = head (gpMean r) + sg = (head (gpUpper r) - mu) / 2 + lcb = mu - 2.0 * sg + _ <- evaluate mu; _ <- evaluate sg + pure ((ws !! j) * (lcb - (zStars !! j))) + safe j = do + res <- try (computeOne j) :: IO (Either SomeException Double) + case res of { Left _ -> pure 1e30; Right v -> pure v } + perJ <- mapM safe [0 .. qDim - 1] + pure (maximum perJ) + -- L-BFGS multi-start で scalarLcb 最小化 + starts <- replicateM nStarts (forM bounds $ \(lo, hi) -> do + u <- uniform gen :: IO Double + return (lo + u * (hi - lo))) + results <- mapM (\x0 -> + LBFGS.runLBFGSNumeric + (LBFGS.defaultLBFGSConfig + { LBFGS.lbStop = OC.defaultStopCriteria { OC.stMaxIter = 60 } }) + scalarLcb x0) starts + let best = minimumBy (comparing OC.orValue) results + xNextRaw = OC.orBest best + xNext = zipWith (\(lo, hi) v -> max lo (min hi v)) bounds xNextRaw + yNext <- f xNext + return (hist ++ [(xNext, yNext)]) + + loop t h + | t == 0 = return h + | otherwise = step h >>= loop (t - 1) + + loop nIter history0 + +argmax :: Ord a => [a] -> Int +argmax xs = snd (maximum (zip xs [0..])) + +-- --------------------------------------------------------------------------- +-- 多目的 BO with NSGA-II (Phase V4) +-- --------------------------------------------------------------------------- + +-- | Multi-objective BO using NSGA-II to optimize the acquisition function. +-- +-- Internally fits a @MultiGP@ to obtain per-objective @(μ, σ)@, then +-- runs NSGA-II to find the Pareto front in @(μ_1, μ_2, ...)@ space; one +-- point from that front is chosen and evaluated. +-- +-- A deliberately simple implementation; an EHVI-based variant is left +-- for future extension. +bayesOptMOWithNSGA + :: Int -- ^ Number of BO iterations. + -> Int -- ^ Number of initial samples. + -> Kernel + -> ([Double] -> IO [Double]) -- ^ Multi-objective function. + -> Bounds + -> GenIO + -> IO [([Double], [Double])] -- ^ Sequence of @(x, y)@ pairs. +bayesOptMOWithNSGA nIter nInit kern f bounds gen = do + -- 初期点 + initX <- replicateM nInit (do + vs <- forM bounds $ \(lo, hi) -> do + u <- uniform gen :: IO Double + return (lo + u * (hi - lo)) + return vs) + initY <- mapM f initX + let history0 = zip initX initY + + let loop t hist + | t == 0 = return hist + | otherwise = do + -- 各目的に GP を fit (1D 入力前提の簡易版) + -- 多次元入力の場合は MultiGP を別途準備 + -- ここでは bounds の最初の次元のみ使う簡易動作 + let xsFlat = map head (map fst hist) -- 1D 入力前提 + ysAll = map snd hist + qDim = length (head ysAll) + ysCol j = [y !! j | y <- ysAll] + + -- 各目的 j の GP モデルを fit + let modelFor j = + let trainY = ysCol j + p0 = initParamsFromData xsFlat trainY + pOpt = optimizeGP kern xsFlat trainY p0 + in GPModel kern pOpt + + models = [modelFor j | j <- [0 .. qDim - 1]] + + -- NSGA-II で Pareto front を探索 (acquisition surface 上) + -- 各目的: μ - β σ (LCB) を最小化 + acqObjective xVec = + [ unsafePerformIO $ do + let computed = do + let trainY = ysCol j + m = models !! j + gpRes = fitGP m xsFlat trainY [head xVec] + mu = head (gpMean gpRes) + sg = (head (gpUpper gpRes) - mu) / 2 + _ <- evaluate mu; _ <- evaluate sg + pure (ucbToMin mu sg) + r <- try computed :: IO (Either SomeException Double) + case r of { Left _ -> pure 1e30; Right v -> pure v } + | j <- [0 .. qDim - 1] ] + + ucbToMin :: Double -> Double -> Double + ucbToMin mu sigma = mu - 2.0 * sigma -- LCB + + -- NSGA-II で Pareto front を 1 ステップ探索 + front <- nsga2 (defaultNSGAConfig { nsgaPopSize = 30 + , nsgaGenerations = 30 }) + acqObjective bounds gen + + -- front から random 選択 + idx <- uniform gen :: IO Double + let i = floor (idx * fromIntegral (length front)) + xNext = solDecision (front !! min i (length front - 1)) + yNext <- f xNext + loop (t - 1) (hist ++ [(xNext, yNext)]) + + loop nIter history0 diff --git a/src/Hanalyze/Stat/Causal/CATE.hs b/src/Hanalyze/Stat/Causal/CATE.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Stat/Causal/CATE.hs @@ -0,0 +1,224 @@ +-- | +-- Module : Hanalyze.Stat.Causal.CATE +-- Description : Künzel et al. (2019) の S/T/X-Learner による CATE meta-learner 実装 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Conditional Average Treatment Effect (CATE) meta-learners。 +-- +-- Künzel et al. (2019) の 3 meta-learner を実装: +-- +-- - 'SLearner': 単一モデル @μ̂(X, T)@、 @τ̂(X) = μ̂(X, 1) - μ̂(X, 0)@ +-- - 'TLearner': 2 モデル @μ̂_1(X)@ / @μ̂_0(X)@、 @τ̂(X) = μ̂_1(X) - μ̂_0(X)@ +-- - 'XLearner': T-learner の残差を再帰回帰、 PS で重み付け平均 +-- +-- base learner は 'CATELM' (= 'Hanalyze.Model.LM') と 'CATERF' (= +-- 'Hanalyze.Model.RandomForest') から選択。 将来 Causal Forest 等を追加する +-- ときは新 constructor を加える。 +-- +-- ## 使い方 +-- +-- @ +-- gen <- MWC.create +-- r <- fitCATE TLearner CATELM x t y gen +-- print (cateATE r) -- average of cateEstimates +-- @ +-- +-- Reference: +-- Künzel, Sekhon, Bickel, Yu (2019) "Metalearners for estimating +-- heterogeneous treatment effects using machine learning". +-- PNAS 116:4156-4165. +-- +-- [English]: Conditional Average Treatment Effect (CATE) meta-learners. +-- +-- Implements the 3 meta-learners from Künzel et al. (2019): +-- +-- - 'SLearner': a single model @μ̂(X, T)@, @τ̂(X) = μ̂(X, 1) - μ̂(X, 0)@ +-- - 'TLearner': two models @μ̂_1(X)@ \/ @μ̂_0(X)@, @τ̂(X) = μ̂_1(X) - μ̂_0(X)@ +-- - 'XLearner': regresses the T-learner's residuals again, then averages +-- with propensity-score weighting +-- +-- The base learner is chosen from 'CATELM' (= 'Hanalyze.Model.LM') +-- and 'CATERF' (= 'Hanalyze.Model.RandomForest'). When adding +-- Causal Forest or similar in the future, add a new constructor. +-- +-- ## Usage +-- +-- @ +-- gen <- MWC.create +-- r <- fitCATE TLearner CATELM x t y gen +-- print (cateATE r) -- average of cateEstimates +-- @ +-- +-- Reference: +-- Künzel, Sekhon, Bickel, Yu (2019) "Metalearners for estimating +-- heterogeneous treatment effects using machine learning". +-- PNAS 116:4156-4165. +module Hanalyze.Stat.Causal.CATE + ( CATEBaseLearner (..) + , CATELearner (..) + , CATEResult (..) + , fitCATE + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import qualified Hanalyze.Model.LM as LM +import qualified Hanalyze.Model.RandomForest as RF +import Hanalyze.Model.Core (coefficientsV) +import Hanalyze.Stat.Causal.PropensityScore + (PropensityScore (..), propensityScore, trimPropensity) +import Hanalyze.Stat.Causal.IPW (defaultPSTrim) +import qualified System.Random.MWC as MWC + +-- --------------------------------------------------------------------------- +-- 型 +-- --------------------------------------------------------------------------- + +-- | [日本語]: base learner 選択。 LM は OLS、 RF は Random Forest。 +-- [English]: Base learner selection. LM is OLS, RF is Random Forest. +data CATEBaseLearner = CATELM | CATERF RF.RFConfig + deriving (Show) + +-- | [日本語]: meta-learner 選択。 [English]: Meta-learner selection. +data CATELearner = SLearner | TLearner | XLearner + deriving (Show, Eq) + +data CATEResult = CATEResult + { cateEstimates :: !(LA.Vector Double) -- ^ τ̂(X_i) for each unit + , cateMethod :: !CATELearner + , cateATE :: !Double -- ^ mean of cateEstimates + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- Base learner abstraction +-- --------------------------------------------------------------------------- + +-- | Train a base learner on (X, y) and return a predictor for new X. +-- Random forest path threads through @MWC.GenIO@; LM is pure but is +-- wrapped in @IO@ for uniform signature. +fitPredict :: CATEBaseLearner + -> LA.Matrix Double -> LA.Vector Double -> MWC.GenIO + -> IO (LA.Matrix Double -> LA.Vector Double) +fitPredict CATELM x y _ = do + let beta = coefficientsV (LM.fitLMVec x y) + pure (\xNew -> LM.predictLMVec beta xNew) +fitPredict (CATERF cfg) x y gen = do + rf <- RF.fitRFV cfg x (VS.convert y :: VU.Vector Double) + gen + pure (\xNew -> + let rows = LA.toRows xNew + in LA.fromList [RF.predictRF rf (LA.toList r) | r <- rows]) + +-- --------------------------------------------------------------------------- +-- fitCATE +-- --------------------------------------------------------------------------- + +fitCATE :: CATELearner -> CATEBaseLearner + -> LA.Matrix Double -> LA.Vector Double -> LA.Vector Double + -> MWC.GenIO -> IO CATEResult +fitCATE method base x t y gen = case method of + SLearner -> sLearner base x t y gen + TLearner -> tLearner base x t y gen + XLearner -> xLearner base x t y gen + +-- --------------------------------------------------------------------------- +-- S-learner: 単一モデル on (X, T) +-- --------------------------------------------------------------------------- + +sLearner :: CATEBaseLearner + -> LA.Matrix Double -> LA.Vector Double -> LA.Vector Double + -> MWC.GenIO -> IO CATEResult +sLearner base x t y gen = do + let xt = LA.fromBlocks [[x, LA.asColumn t]] + n = LA.rows x + x1 = LA.fromBlocks [[x, LA.asColumn (LA.fromList (replicate n 1))]] + x0 = LA.fromBlocks [[x, LA.asColumn (LA.fromList (replicate n 0))]] + predict <- fitPredict base xt y gen + let mu1 = predict x1 + mu0 = predict x0 + tauHat = mu1 - mu0 + pure CATEResult + { cateEstimates = tauHat + , cateMethod = SLearner + , cateATE = LA.sumElements tauHat / fromIntegral n + } + +-- --------------------------------------------------------------------------- +-- T-learner: 2 モデル、 群別 fit +-- --------------------------------------------------------------------------- + +tLearner :: CATEBaseLearner + -> LA.Matrix Double -> LA.Vector Double -> LA.Vector Double + -> MWC.GenIO -> IO CATEResult +tLearner base x t y gen = do + let n = LA.rows x + idx1 = filterIdx (== 1.0) t + idx0 = filterIdx (== 0.0) t + x1 = x LA.? idx1 + y1 = LA.fromList [LA.atIndex y i | i <- idx1] + x0 = x LA.? idx0 + y0 = LA.fromList [LA.atIndex y i | i <- idx0] + pred1 <- fitPredict base x1 y1 gen + pred0 <- fitPredict base x0 y0 gen + let mu1 = pred1 x + mu0 = pred0 x + tauHat = mu1 - mu0 + pure CATEResult + { cateEstimates = tauHat + , cateMethod = TLearner + , cateATE = LA.sumElements tauHat / fromIntegral n + } + +-- --------------------------------------------------------------------------- +-- X-learner: 残差再回帰 + PS 重み付け +-- --------------------------------------------------------------------------- + +xLearner :: CATEBaseLearner + -> LA.Matrix Double -> LA.Vector Double -> LA.Vector Double + -> MWC.GenIO -> IO CATEResult +xLearner base x t y gen = do + let n = LA.rows x + idx1 = filterIdx (== 1.0) t + idx0 = filterIdx (== 0.0) t + x1 = x LA.? idx1 + y1 = LA.fromList [LA.atIndex y i | i <- idx1] + x0 = x LA.? idx0 + y0 = LA.fromList [LA.atIndex y i | i <- idx0] + -- Step 1: T-learner と同じ outcome models + pred1 <- fitPredict base x1 y1 gen + pred0 <- fitPredict base x0 y0 gen + -- Step 2: imputed treatment effects + -- For T=1 units: D̃_1 = Y - μ̂_0(X) + -- For T=0 units: D̃_0 = μ̂_1(X) - Y + let mu0_at_x1 = pred0 x1 + mu1_at_x0 = pred1 x0 + dTilde1 = y1 - mu0_at_x1 + dTilde0 = mu1_at_x0 - y0 + -- Step 3: τ̂_1(X) を D̃_1 ~ X_{T=1} で fit、 τ̂_0(X) は D̃_0 ~ X_{T=0} + tau1Pred <- fitPredict base x1 dTilde1 gen + tau0Pred <- fitPredict base x0 dTilde0 gen + let tau1At = tau1Pred x + tau0At = tau0Pred x + -- Step 4: PS 重み付け平均 + -- τ̂(X) = p̂(X) · τ̂_0(X) + (1 - p̂(X)) · τ̂_1(X) + -- (treated が少ない領域では τ̂_0 を信頼、 control が少ない領域では τ̂_1) + (lo, hi) = defaultPSTrim + let ps = trimPropensity lo hi (propensityScore x t) + p = psScores ps + one = LA.scalar 1 + tauHat = p * tau0At + (one - p) * tau1At + pure CATEResult + { cateEstimates = tauHat + , cateMethod = XLearner + , cateATE = LA.sumElements tauHat / fromIntegral n + } + +-- --------------------------------------------------------------------------- +-- ヘルパ +-- --------------------------------------------------------------------------- + +filterIdx :: (Double -> Bool) -> LA.Vector Double -> [Int] +filterIdx pr v = + [ i | i <- [0 .. LA.size v - 1], pr (LA.atIndex v i) ] diff --git a/src/Hanalyze/Stat/Causal/DoublyRobust.hs b/src/Hanalyze/Stat/Causal/DoublyRobust.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Stat/Causal/DoublyRobust.hs @@ -0,0 +1,127 @@ +-- | +-- Module : Hanalyze.Stat.Causal.DoublyRobust +-- Description : Doubly Robust / Augmented IPW (AIPW) 推定量 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Doubly Robust / Augmented IPW (AIPW) 推定量。 +-- +-- 結果モデル @μ̂_1(X)@ / @μ̂_0(X)@ と傾向スコア @p̂(X)@ の両方を使い、 +-- どちらか一方が正しく指定されていれば一致性を持つ推定量: +-- +-- @ +-- ATE_AIPW = (1/n) Σ [ μ̂_1(X_i) - μ̂_0(X_i) +-- + T_i (Y_i - μ̂_1(X_i)) / p̂_i +-- - (1-T_i) (Y_i - μ̂_0(X_i)) / (1 - p̂_i) ] +-- @ +-- +-- 結果モデルは 'Hanalyze.Model.LM.fitLM' を流用 (= OLS、 線形)。 非線形が +-- 必要な場合は呼び出し側で X を拡張するか CATE module を使う。 +-- +-- Reference: +-- Robins, Rotnitzky, Zhao (1994) "Estimation of Regression Coefficients +-- When Some Regressors Are Not Always Observed". JASA 89:846-866. +-- +-- [English]: The Doubly Robust \/ Augmented IPW (AIPW) estimator. +-- +-- Uses both the outcome models @μ̂_1(X)@ \/ @μ̂_0(X)@ and the propensity +-- score @p̂(X)@; consistent if either one is correctly specified: +-- +-- @ +-- ATE_AIPW = (1/n) Σ [ μ̂_1(X_i) - μ̂_0(X_i) +-- + T_i (Y_i - μ̂_1(X_i)) / p̂_i +-- - (1-T_i) (Y_i - μ̂_0(X_i)) / (1 - p̂_i) ] +-- @ +-- +-- The outcome model reuses 'Hanalyze.Model.LM.fitLM' (= OLS, +-- linear). If nonlinearity is needed, the caller should expand X or +-- use the CATE module. +-- +-- Reference: +-- Robins, Rotnitzky, Zhao (1994) "Estimation of Regression +-- Coefficients When Some Regressors Are Not Always Observed". +-- JASA 89:846-866. +module Hanalyze.Stat.Causal.DoublyRobust + ( DoublyRobustResult (..) + , doublyRobust + , doublyRobustWith + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Model.LM as LM +import Hanalyze.Model.Core (coefficientsV) +import Hanalyze.Stat.Causal.PropensityScore + (PropensityScore (..), propensityScore, trimPropensity) +import Hanalyze.Stat.Causal.IPW (defaultPSTrim) + +-- --------------------------------------------------------------------------- +-- 型 +-- --------------------------------------------------------------------------- + +data DoublyRobustResult = DoublyRobustResult + { drATE :: !Double + , drMu1Predicted :: !(LA.Vector Double) -- ^ μ̂_1(X_i) for all i + , drMu0Predicted :: !(LA.Vector Double) -- ^ μ̂_0(X_i) for all i + , drPropensity :: !PropensityScore + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- AIPW +-- --------------------------------------------------------------------------- + +-- | [日本語]: 共変量 @X@ (intercept 列を含む)、 二値処置 @T@、 結果 @Y@ から AIPW ATE +-- を推定。 内部で 'propensityScore' + 'defaultPSTrim' を適用、 outcome +-- model は OLS で群別 fit。 +-- +-- [English]: Estimates the AIPW ATE from covariates @X@ (including an +-- intercept column), binary treatment @T@, and outcome @Y@. Internally +-- applies 'propensityScore' + 'defaultPSTrim'; the outcome model is +-- fit via OLS per group. +doublyRobust :: LA.Matrix Double -> LA.Vector Double -> LA.Vector Double + -> DoublyRobustResult +doublyRobust x t y = + let (lo, hi) = defaultPSTrim + ps = trimPropensity lo hi (propensityScore x t) + in doublyRobustWith ps x t y + +-- | [日本語]: 既存 PS を再利用する版。 PS と outcome model の組み合わせを変えて +-- 二重ロバスト性を検証したい場合に有用。 +-- [English]: A variant that reuses an existing propensity score. Useful when +-- verifying double robustness by varying the combination of the propensity +-- score and the outcome model. +doublyRobustWith :: PropensityScore -> LA.Matrix Double -> LA.Vector Double + -> LA.Vector Double -> DoublyRobustResult +doublyRobustWith ps x t y = + let n = fromIntegral (LA.size t) :: Double + one = LA.scalar 1 + p = psScores ps + -- 群別 OLS: T=1 部分集合 / T=0 部分集合 + idx1 = filterIdx (== 1.0) t + idx0 = filterIdx (== 0.0) t + x1 = x LA.? idx1 + y1 = LA.fromList [LA.atIndex y i | i <- idx1] + x0 = x LA.? idx0 + y0 = LA.fromList [LA.atIndex y i | i <- idx0] + beta1 = coefficientsV (LM.fitLMVec x1 y1) + beta0 = coefficientsV (LM.fitLMVec x0 y0) + mu1 = LM.predictLMVec beta1 x + mu0 = LM.predictLMVec beta0 x + -- AIPW contribution per unit + contrib = (mu1 - mu0) + + t * (y - mu1) / p + - (one - t) * (y - mu0) / (one - p) + ateHat = LA.sumElements contrib / n + in DoublyRobustResult + { drATE = ateHat + , drMu1Predicted = mu1 + , drMu0Predicted = mu0 + , drPropensity = ps + } + +-- --------------------------------------------------------------------------- +-- ヘルパ +-- --------------------------------------------------------------------------- + +filterIdx :: (Double -> Bool) -> LA.Vector Double -> [Int] +filterIdx pr v = + [ i | i <- [0 .. LA.size v - 1], pr (LA.atIndex v i) ] diff --git a/src/Hanalyze/Stat/Causal/IPW.hs b/src/Hanalyze/Stat/Causal/IPW.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Stat/Causal/IPW.hs @@ -0,0 +1,135 @@ +-- | +-- Module : Hanalyze.Stat.Causal.IPW +-- Description : Inverse Probability Weighting (IPW) による ATE / ATT 推定 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Inverse Probability Weighting (IPW) による ATE / ATT 推定。 +-- +-- Hajek 正規化推定量 (finite-sample で stable、 Horvitz-Thompson より低分散): +-- +-- @ +-- ATE = Σ(T·Y/p) / Σ(T/p) - Σ((1-T)·Y/(1-p)) / Σ((1-T)/(1-p)) +-- ATT = Σ(T·Y) / Σ T - Σ((1-T)·(p/(1-p))·Y) / Σ((1-T)·(p/(1-p))) +-- @ +-- +-- ここで @p_i@ は 'PropensityScore' で推定した P(T=1 | X_i)。 重みは +-- @PropensityScore.ipwWeights@ / @attWeights@ で hmatrix Vector 演算で計算。 +-- +-- ## 使い方 +-- +-- @ +-- let r = ipw xConf treat outcome -- 共変量から PS 推定 + trim も内部で実施 +-- print (ipwATE r, ipwATT r) +-- +-- -- 既に PS を計算済 / カスタム trim したい場合: +-- let ps' = trimPropensity 0.05 0.95 (propensityScore x t) +-- r' = ipwWith ps' t y +-- @ +-- +-- [English]: ATE\/ATT estimation via Inverse Probability Weighting (IPW). +-- +-- Hajek-normalized estimator (stable in finite samples, lower variance +-- than Horvitz-Thompson): +-- +-- @ +-- ATE = Σ(T·Y/p) / Σ(T/p) - Σ((1-T)·Y/(1-p)) / Σ((1-T)/(1-p)) +-- ATT = Σ(T·Y) / Σ T - Σ((1-T)·(p/(1-p))·Y) / Σ((1-T)·(p/(1-p))) +-- @ +-- +-- Here @p_i@ is P(T=1 | X_i) estimated by 'PropensityScore'. The weights +-- are computed with hmatrix Vector operations via +-- @PropensityScore.ipwWeights@ \/ @attWeights@. +-- +-- ## Usage +-- +-- @ +-- let r = ipw xConf treat outcome -- estimates PS from covariates + trims internally +-- print (ipwATE r, ipwATT r) +-- +-- -- If the PS is already computed \/ a custom trim is wanted: +-- let ps' = trimPropensity 0.05 0.95 (propensityScore x t) +-- r' = ipwWith ps' t y +-- @ +-- +-- Reference: +-- Horvitz & Thompson (1952) "A Generalization of Sampling Without +-- Replacement from a Finite Universe". JASA 47:663-685. +module Hanalyze.Stat.Causal.IPW + ( IPWResult (..) + , ipw + , ipwWith + , defaultPSTrim + ) where + +import qualified Numeric.LinearAlgebra as LA +import Hanalyze.Stat.Causal.PropensityScore + (PropensityScore (..), propensityScore, trimPropensity, + ipwWeights, attWeights) + +-- --------------------------------------------------------------------------- +-- 型 +-- --------------------------------------------------------------------------- + +data IPWResult = IPWResult + { ipwATE :: !Double + , ipwATT :: !Double + , ipwWeightsATE :: !(LA.Vector Double) + , ipwWeightsATT :: !(LA.Vector Double) + , ipwPropensity :: !PropensityScore + } deriving (Show) + +-- | [日本語]: 既定の PS trim 範囲 @(0.01, 0.99)@ (Rosenbaum 慣例)。 +-- [English]: Default PS trim range @(0.01, 0.99)@ (Rosenbaum convention). +defaultPSTrim :: (Double, Double) +defaultPSTrim = (0.01, 0.99) + +-- --------------------------------------------------------------------------- +-- 推定 +-- --------------------------------------------------------------------------- + +-- | [日本語]: 共変量 @X@、 二値処置 @T@、 結果 @Y@ から ATE / ATT を IPW で推定。 +-- 内部で 'propensityScore' + 'defaultPSTrim' を適用。 +-- [English]: Estimate ATE\/ATT via IPW from covariates @X@, binary +-- treatment @T@, and outcome @Y@. Applies 'propensityScore' + +-- 'defaultPSTrim' internally. +ipw :: LA.Matrix Double -> LA.Vector Double -> LA.Vector Double -> IPWResult +ipw x t y = + let (lo, hi) = defaultPSTrim + ps = trimPropensity lo hi (propensityScore x t) + in ipwWith ps t y + +-- | [日本語]: 既に算出 (+trim) 済の PropensityScore を再利用する版。 同じ X から +-- ATE / ATT を複数バリアントで比べたい場合に有用。 +-- [English]: A variant that reuses an already-computed (+trimmed) +-- PropensityScore. Useful for comparing ATE\/ATT across multiple +-- variants from the same X. +ipwWith :: PropensityScore -> LA.Vector Double -> LA.Vector Double -> IPWResult +ipwWith ps t y = + let p = psScores ps + one = LA.scalar 1 + wATE = ipwWeights ps t + wATT = attWeights ps t + -- ATE (Hajek 正規化): 各群の重み付き平均の差 + -- μ̂_1 = Σ (T/p)·Y / Σ (T/p) + -- μ̂_0 = Σ ((1-T)/(1-p))·Y / Σ ((1-T)/(1-p)) + w1 = t / p + w0 = (one - t) / (one - p) + mu1Hat = safeDiv (LA.sumElements (w1 * y)) (LA.sumElements w1) + mu0Hat = safeDiv (LA.sumElements (w0 * y)) (LA.sumElements w0) + ateHat = mu1Hat - mu0Hat + -- ATT (Hajek 正規化): treated 平均と、 p/(1-p) で再重み付けした control 平均の差 + wt1 = t -- treated indicator + wt0 = (one - t) * (p / (one - p)) + attMu1 = safeDiv (LA.sumElements (wt1 * y)) (LA.sumElements wt1) + attMu0 = safeDiv (LA.sumElements (wt0 * y)) (LA.sumElements wt0) + attHat = attMu1 - attMu0 + in IPWResult + { ipwATE = ateHat + , ipwATT = attHat + , ipwWeightsATE = wATE + , ipwWeightsATT = wATT + , ipwPropensity = ps + } + where + safeDiv num den = if abs den < 1e-12 then 0 else num / den diff --git a/src/Hanalyze/Stat/Causal/PropensityScore.hs b/src/Hanalyze/Stat/Causal/PropensityScore.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Stat/Causal/PropensityScore.hs @@ -0,0 +1,120 @@ +-- | +-- Module : Hanalyze.Stat.Causal.PropensityScore +-- Description : logistic regression による Propensity Score P(T=1|X) の推定 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: Propensity Score の推定。 +-- +-- @p_i = P(T = 1 | X_i)@ を logistic regression (GLM Binomial+Logit) で +-- 推定する。 観測研究での因果効果推定 (IPW / AIPW / CATE) の前提となる +-- 共変量バランス指標。 +-- +-- ## 使い方 +-- +-- @ +-- let ps = propensityScore xConf treat +-- ps' = trimPropensity 0.01 0.99 ps -- 重み発散防止 +-- w = ipwWeights ps' treat -- t/p + (1-t)/(1-p) +-- @ +-- +-- Reference: +-- Rosenbaum & Rubin (1983) "The Central Role of the Propensity Score in +-- Observational Studies for Causal Effects". Biometrika 70:41-55. +-- +-- [English]: Estimation of the Propensity Score. +-- +-- Estimates @p_i = P(T = 1 | X_i)@ via logistic regression (GLM +-- Binomial+Logit). This is the covariate-balance measure that underlies +-- causal-effect estimation in observational studies (IPW \/ AIPW \/ CATE). +-- +-- ## Usage +-- +-- @ +-- let ps = propensityScore xConf treat +-- ps' = trimPropensity 0.01 0.99 ps -- prevent weight divergence +-- w = ipwWeights ps' treat -- t/p + (1-t)/(1-p) +-- @ +-- +-- Reference: +-- Rosenbaum & Rubin (1983) "The Central Role of the Propensity Score in +-- Observational Studies for Causal Effects". Biometrika 70:41-55. +module Hanalyze.Stat.Causal.PropensityScore + ( PropensityScore (..) + , propensityScore + , trimPropensity + , ipwWeights + , attWeights + ) where + +import qualified Numeric.LinearAlgebra as LA +import qualified Hanalyze.Model.GLM as GLM +import Hanalyze.Model.Core (coefficientsV, fittedV) + +-- --------------------------------------------------------------------------- +-- 型 +-- --------------------------------------------------------------------------- + +data PropensityScore = PropensityScore + { psScores :: !(LA.Vector Double) -- ^ [日本語]: @p_i = P(T=1|X_i)@、 長さ @n@。 [English]: @p_i = P(T=1|X_i)@, length @n@. + , psBeta :: !(LA.Vector Double) -- ^ [日本語]: logistic coefficients。 [English]: The logistic coefficients. + , psN :: !Int -- ^ [日本語]: サンプル数。 [English]: The sample count. + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- 推定 +-- --------------------------------------------------------------------------- + +-- | [日本語]: 共変量行列 @X@ (intercept 列は呼び出し側で付加) と二値処置 @T ∈ {0,1}@ +-- から logistic regression で傾向スコアを推定。 +-- +-- @X@ は @n × p@、 @T@ は長さ @n@ の 0/1 vector。 intercept が欲しい場合は +-- @1@ 列を先頭に prepend して渡す。 +-- [English]: Estimates the propensity score via logistic regression from +-- a covariate matrix @X@ (the intercept column must be added by the +-- caller) and a binary treatment @T ∈ {0,1}@. +-- +-- @X@ is @n × p@, @T@ is a length-@n@ 0\/1 vector. If an intercept is +-- desired, prepend a @1@ column and pass that in. +propensityScore :: LA.Matrix Double -> LA.Vector Double -> PropensityScore +propensityScore x t = + let (fit, _) = GLM.fitGLMFull GLM.Binomial GLM.Logit x t + in PropensityScore + { psScores = fittedV fit + , psBeta = coefficientsV fit + , psN = LA.size t + } + +-- | [日本語]: @[lo, hi]@ に clip。 @p_i@ が 0 / 1 に張り付くと IPW 重みが発散する +-- ので必須。 推奨値: @lo = 0.01@, @hi = 0.99@。 +-- [English]: Clips to @[lo, hi]@. Necessary because IPW weights diverge +-- when @p_i@ sticks to 0 \/ 1. Recommended values: @lo = 0.01@, @hi = 0.99@. +trimPropensity :: Double -> Double -> PropensityScore -> PropensityScore +trimPropensity lo hi ps = + ps { psScores = LA.cmap (clamp lo hi) (psScores ps) } + where + clamp a b v = max a (min b v) + +-- --------------------------------------------------------------------------- +-- 重み (hmatrix Vector 演算) +-- --------------------------------------------------------------------------- + +-- | [日本語]: ATE 用の Horvitz-Thompson 重み: @w_i = t_i/p_i + (1-t_i)/(1-p_i)@ +-- [English]: The Horvitz-Thompson weight for ATE: +-- @w_i = t_i/p_i + (1-t_i)/(1-p_i)@. +ipwWeights :: PropensityScore -> LA.Vector Double -> LA.Vector Double +ipwWeights ps t = + let p = psScores ps + one = LA.scalar 1 + in t / p + (one - t) / (one - p) + +-- | [日本語]: ATT 用の重み: @w_i = t_i + (1-t_i) · p_i/(1-p_i)@ +-- (treated は重み 1、 control は odds ratio で再重み付け) +-- [English]: The weight for ATT: @w_i = t_i + (1-t_i) · p_i/(1-p_i)@ +-- (treated units get weight 1; control units are reweighted by the odds +-- ratio). +attWeights :: PropensityScore -> LA.Vector Double -> LA.Vector Double +attWeights ps t = + let p = psScores ps + one = LA.scalar 1 + in t + (one - t) * p / (one - p) diff --git a/src/Hanalyze/Stat/ModelSelect.hs b/src/Hanalyze/Stat/ModelSelect.hs new file mode 100644 --- /dev/null +++ b/src/Hanalyze/Stat/ModelSelect.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +-- | +-- Module : Hanalyze.Stat.ModelSelect +-- Description : MCMC ベースのモデル比較基準 (WAIC / PSIS-LOO / pseudo-BMA) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- MCMC-based model comparison criteria. +-- +-- Provides WAIC (Widely Applicable Information Criterion) and PSIS-LOO +-- (Pareto-Smoothed Importance Sampling LOO-CV), plus a @pm.compare@-style +-- weighting facility (pseudo-BMA / stacking). +-- +-- References: +-- +-- - Watanabe (2010) — WAIC. +-- - Vehtari, Gelman, Gabry (2017) — PSIS-LOO. +-- - Hosking & Wallis (1987) — generalized Pareto moment estimator. +-- +-- @ +-- let logLikMat = chainLogLikMatrix model chain -- [[Double]] +-- print (waic logLikMat) +-- print (loo logLikMat) +-- @ +module Hanalyze.Stat.ModelSelect + ( -- * WAIC + WAICResult (..) + , waic + , chainWAIC + -- * LOO-CV (PSIS) + , LOOResult (..) + , loo + , chainLOO + -- * Utilities + , chainLogLikMatrix + -- * LM / GLM posterior sampling (for WAIC / LOO-CV) + , lmPosteriorLogLiks + , glmPosteriorLogLiks + , lmePosteriorLogLiks + -- * Model-comparison weights (PyMC @pm.compare@ analogue) + , CompareEntry (..) + , CompareResult (..) + , compareModels + ) where + +import Control.Monad (replicateM) +import Data.List (sort, transpose) +import qualified Numeric.LinearAlgebra as LA +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Algorithms.Intro as VAI +import System.Random.MWC (GenIO) +import System.Random.MWC.Distributions (normal) + +import Hanalyze.Model.Core (FitResult (..), coefficientsV, residualsV) +import Hanalyze.Model.GLM (Family (..), LinkFn (..)) +import Hanalyze.Model.HBM (ModelP, perObsLogLiks) +import Hanalyze.MCMC.Core (Chain, chainSamples) +import qualified Hanalyze.Stat.Distribution as Dist + +-- --------------------------------------------------------------------------- +-- 結果型 +-- --------------------------------------------------------------------------- + +-- | WAIC result. +data WAICResult = WAICResult + { waicValue :: Double -- ^ @WAIC = −2(lppd − p_waic)@; smaller is better. + , waicLppd :: Double -- ^ Log pointwise predictive density. + , waicPwaic :: Double -- ^ Effective number of parameters @p_waic@. + , waicSE :: Double -- ^ Estimated standard error of @WAIC@. + } deriving (Show) + +-- | PSIS-LOO result. +data LOOResult = LOOResult + { looValue :: Double -- ^ @−2 × elpd_loo@; smaller is better. + , looElpd :: Double -- ^ @Σᵢ elpd_i@ (expected log predictive density). + , looSE :: Double -- ^ Standard error of @looValue@. + , looKHat :: [Double] -- ^ Per-observation Pareto @k̂@; @< 0.5@ good, + -- @0.5–0.7@ acceptable, @> 0.7@ flag. + , looKHatBad :: Int -- ^ Number of observations with @k̂ > 0.7@. + } deriving (Show) + +-- --------------------------------------------------------------------------- +-- WAIC +-- --------------------------------------------------------------------------- + +-- | Compute WAIC from a log-likelihood matrix. +-- +-- @logLikMat !! s !! i = log p(y_i | θ^s)@: rows are @S@ posterior +-- samples, columns are @N@ observations. +-- +-- Internally builds an @S × N@ hmatrix matrix once and computes the +-- per-column @logSumExp@ and sample variance via Storable-Vector +-- folds. Replaces the previous @transpose [[Double]] + map@ +-- formulation, which allocated @S × N@ list cells just to flip the +-- shape. +waic :: [[Double]] -> WAICResult +waic [] = WAICResult 0 0 0 0 +waic logLikMat = + let mat = LA.fromLists logLikMat -- S × N + sN = LA.rows mat + s = fromIntegral sN :: Double + cols = LA.toColumns mat -- N storable vectors of length S + n = length cols + + lppd_i = map (\c -> logSumExpVS c - log s) cols + lppd = sum lppd_i + pwaic_i = map sampleVarVS cols + pwaic = sum pwaic_i + waicVal = -2 * (lppd - pwaic) + + contrib = zipWith (\l p -> -2 * (l - p)) lppd_i pwaic_i + se = sqrt (fromIntegral n * sampleVar contrib) + + in WAICResult waicVal lppd pwaic se + -- Note: tested 'LA.tr mat + LA.toRows' to get contiguous Storable + -- slices for per-row (= per-observation) folds, but the transpose + -- allocation outweighed the cache benefit at @S=1000, N=200@. The + -- 'toColumns' path stays ~12 ms; transpose path measured ~13.4 ms. + -- arviz's @az.waic@ at 6.3 ms benefits from numpy axis-reductions + -- and SIMD @exp@ that we cannot match without FFI. + +-- | logSumExp over a Storable Vector. @m + log Σ exp(x - m)@ for +-- numerical stability. +logSumExpVS :: LA.Vector Double -> Double +logSumExpVS v + | VS.null v = -1/0 + | otherwise = + let m = VS.maximum v + in m + log (VS.sum (VS.map (\x -> exp (x - m)) v)) + +-- | Sample variance (divisor @n - 1@) over a Storable Vector. +sampleVarVS :: LA.Vector Double -> Double +sampleVarVS v + | VS.length v < 2 = 0 + | otherwise = + let nD = fromIntegral (VS.length v) :: Double + mu = VS.sum v / nD + ss = VS.sum (VS.map (\x -> (x - mu) * (x - mu)) v) + in ss / (nD - 1) + +-- --------------------------------------------------------------------------- +-- LOO-CV (PSIS) +-- --------------------------------------------------------------------------- + +-- | Compute PSIS-LOO from a log-likelihood matrix. +-- +-- For each observation, importance weights are smoothed by a Pareto +-- distribution; this returns the truncated-IS LOO estimate together with +-- the diagnostic Pareto @k̂@. +loo :: [[Double]] -> LOOResult +loo [] = LOOResult 0 0 0 [] 0 +loo logLikMat = + -- Mirrors 'waic': @S × N@ hmatrix matrix once, then per-column + -- 'psisElpdV' on Storable Vectors. Avoids the @transpose [[Double]]@ + -- (S × N list-cell allocation) and the per-column list ops in the + -- old 'psisElpd'. + let mat = LA.fromLists logLikMat -- S × N + s = LA.rows mat + cols = LA.toColumns mat + n = length cols + results = map (psisElpdV s) cols + elpd_i = map fst results + khat_i = map snd results + elpd = sum elpd_i + looVal = -2 * elpd + se = sqrt (fromIntegral n * sampleVar elpd_i) + nBad = length (filter (> 0.7) khat_i) + in LOOResult looVal elpd se khat_i nBad + +-- | PSIS estimate for a single observation: @(elpd_i, k̂_i)@. +-- +-- Algorithm: +-- +-- 1. Compute log importance weights @log r_i^s = −log p(y_i|θ^s)@. +-- 2. Fit a Pareto @k̂@ to the top @M = min(S/5, 3√S)@ values. +-- 3. Truncate weights at @log √S@ and renormalize for stability. +-- 4. @elpd_i = logSumExp(log W_s + log p(y_i|θ^s))@. +psisElpd :: Int -> [Double] -> (Double, Double) +psisElpd s colLL = psisElpdV s (VS.fromList colLL) + +-- | Storable-Vector version of 'psisElpd'. Internal hot path used by +-- 'loo'. All steps stay on @VS.Vector Double@: no @[Double]@ +-- intermediates, sort via 'Data.Vector.Algorithms.Intro' on a +-- mutable Storable buffer. +psisElpdV :: Int -> VS.Vector Double -> (Double, Double) +psisElpdV s colLL = + let logR = VS.map negate colLL + m = max 5 (min (s `div` 5) + (floor (3 * sqrt (fromIntegral s :: Double)))) + sortedLogR = VS.modify VAI.sort logR -- ascending + topM = VS.drop (s - m) sortedLogR + khat = paretoKhatV topM + + logCap = 0.5 * log (fromIntegral s :: Double) + capped = VS.map (min logCap) logR + logZ = logSumExpVS capped + logW = VS.map (\r -> r - logZ) capped + + elpdi = logSumExpVS (VS.zipWith (+) logW colLL) + in (elpdi, khat) + +-- | Estimate the Pareto shape @k̂@ from the top-@M@ log-weights +-- (ascending). +-- +-- Uses the Hosking-Wallis (1987) moment estimator: +-- +-- @ +-- excess = exp(r − u) − 1 (u = lower threshold) +-- k̂ = 0.5 × (1 − μ² / s²) where μ = mean excess, s² = Var excess +-- @ +paretoKhat :: [Double] -> Double +paretoKhat topM = paretoKhatV (VS.fromList topM) + +-- | Storable-Vector version of 'paretoKhat'. +paretoKhatV :: VS.Vector Double -> Double +paretoKhatV topM + | VS.length topM < 5 = 0 + | otherwise = + let u = topM VS.! 0 + excess = VS.map (\r -> exp (r - u) - 1) topM + mu = VS.sum excess / fromIntegral (VS.length excess) + var = sampleVarVS excess + in if var <= 0 || mu <= 0 then 0 + else 0.5 * (1 - mu ^ (2 :: Int) / var) + +-- --------------------------------------------------------------------------- +-- Chain との連携 +-- --------------------------------------------------------------------------- + +-- | Build a log-likelihood matrix from a model and a chain. +-- Rows are post-burnin samples, columns are observations. +chainLogLikMatrix :: ModelP r -> Chain -> [[Double]] +chainLogLikMatrix model chain = map (perObsLogLiks model) (chainSamples chain) + +-- | Compute WAIC directly from a model and chain. +chainWAIC :: ModelP r -> Chain -> WAICResult +chainWAIC model = waic . chainLogLikMatrix model + +-- | Compute PSIS-LOO directly from a model and chain. +chainLOO :: ModelP r -> Chain -> LOOResult +chainLOO model = loo . chainLogLikMatrix model + +-- --------------------------------------------------------------------------- +-- LM / GLM 事後サンプリング (WAIC/LOO-CV 用) +-- --------------------------------------------------------------------------- + +-- | Generate an @S × N@ log-likelihood matrix from a flat-prior LM +-- posterior. +-- +-- Sampling scheme: +-- +-- @ +-- σ² ~ InvGamma((n−p)/2, RSS/2) (drawn as RSS / χ²_{n-p}) +-- β ~ MVN(β̂, σ² (X'X)⁻¹) +-- log p(y_i | β^s, σ^s) = log N(y_i; x_i·β^s, σ^s) +-- @ +lmPosteriorLogLiks + :: LA.Matrix Double -- ^ Design matrix @X@ (@n×p@). + -> LA.Vector Double -- ^ Response @y@ (length @n@). + -> FitResult -- ^ OLS fit result. + -> Int -- ^ Number of posterior samples @S@. + -> GenIO + -> IO [[Double]] +lmPosteriorLogLiks x y fr s gen = do + let n = LA.rows x + p = LA.cols x + df' = n - p + beta0 = coefficientsV fr + rss = let resV = residualsV fr in LA.dot resV resV + xtxInv = LA.inv (LA.tr x LA.<> x) + rChol = LA.chol (LA.trustSym xtxInv) + lChol = LA.tr rChol + replicateM s $ do + chi2Vals <- replicateM df' (normal 0 1 gen) + let chi2 = sum (map (^(2::Int)) chi2Vals) + sigma = sqrt (rss / chi2) + zVec <- fmap LA.fromList (replicateM p (normal 0 1 gen)) + let betaSamp = beta0 + LA.scale sigma (lChol LA.#> zVec) + yHat = x LA.#> betaSamp + -- Phase 12c: VS.zipWith fuses on Storable Vectors and avoids the + -- two LA.toList allocations + Haskell list zip (cf. Phase 11c + -- glmLogLik change). + return (VS.toList (VS.zipWith (\yi yhi -> logNormDensity yi yhi sigma) + y yHat)) + +-- | Generate an @S × N@ log-likelihood matrix from a Laplace-approximate +-- GLM posterior. For Gaussian-family models prefer 'lmPosteriorLogLiks'. +-- +-- @ +-- β ~ MVN(β̂, Fisher⁻¹) +-- log p(y_i | β^s) = family-specific log-density +-- @ +glmPosteriorLogLiks + :: Family + -> LinkFn + -> LA.Matrix Double -- ^ Design matrix @X@. + -> LA.Vector Double -- ^ Response @y@. + -> LA.Matrix Double -- ^ Inverse Fisher information. + -> FitResult + -> Int -- ^ Number of posterior samples @S@. + -> GenIO + -> IO [[Double]] +glmPosteriorLogLiks family linkFn x y fisherInv fr s gen = do + let p = LA.rows fisherInv + beta0 = coefficientsV fr + rChol = LA.chol (LA.trustSym fisherInv) + lChol = LA.tr rChol + replicateM s $ do + zVec <- fmap LA.fromList (replicateM p (normal 0 1 gen)) + let betaSamp = beta0 + lChol LA.#> zVec + eta = x LA.#> betaSamp + -- Phase 12c: same VS.zipWith / no toList pattern as + -- 'lmPosteriorLogLiks'. + return (VS.toList (VS.zipWith (glmLogDensity family linkFn) y eta)) + +-- | Log-likelihood matrix for the __conditional__ WAIC of a Gaussian +-- LME (random intercepts). +-- +-- This is not a fully marginal GLMM posterior. It conditions on a point +-- estimate of the BLUPs @û@ and posterior-samples @(β, σ²)@ as if from +-- a residualized LM: +-- +-- - @y' := y − Z·û@ (response with BLUP offset removed). +-- - @σ² ~ InvGamma((n−p)/2, RSS_cond/2)@ where @RSS_cond@ is the LME +-- conditional residual sum of squares. +-- - @β ~ MVN(β̂, σ² (X'X)⁻¹)@. +-- - @log p(y_i | β^s, û_{j(i)}, σ^s) = log N(y_i; X_iβ^s + û_{j(i)}, σ^s)@. +-- +-- Because @u@ is held fixed, @p_WAIC@ tends to be smaller than the true +-- value; this is still useful for comparing fixed-effect structures on +-- the same data (see Gelman, Hwang & Vehtari 2014, §3.3). +lmePosteriorLogLiks + :: LA.Matrix Double -- ^ Fixed-effect design matrix @X@ (@n×p@). + -> LA.Vector Double -- ^ Response @y@ (length @n@). + -> [Double] -- ^ Per-observation BLUP offset @û_{j(i)}@ (length @n@). + -> FitResult -- ^ Fixed-effect LME fit result. + -> Int -- ^ Number of posterior samples @S@. + -> GenIO + -> IO [[Double]] +lmePosteriorLogLiks x y offsets fr s gen = do + let n = LA.rows x + p = LA.cols x + df' = n - p + beta0 = coefficientsV fr + rss = let resV = residualsV fr in LA.dot resV resV + xtxInv = LA.inv (LA.tr x LA.<> x) + rChol = LA.chol (LA.trustSym xtxInv) + lChol = LA.tr rChol + replicateM s $ do + chi2Vals <- replicateM df' (normal 0 1 gen) + let chi2 = sum (map (^(2::Int)) chi2Vals) + sigSamp = sqrt (rss / chi2) + zVec <- fmap LA.fromList (replicateM p (normal 0 1 gen)) + let betaSamp = beta0 + LA.scale sigSamp (lChol LA.#> zVec) + yFix = LA.toList (x LA.#> betaSamp) + yCond = zipWith (+) yFix offsets + ys = LA.toList y + return [ logNormDensity yi yhi sigSamp | (yi, yhi) <- zip ys yCond ] + +logNormDensity :: Double -> Double -> Double -> Double +logNormDensity y mu sig + | sig <= 0 = -1/0 + | otherwise = let d = (y - mu) / sig + in -0.5 * log (2 * pi) - log sig - 0.5 * d * d + +glmLogDensity :: Family -> LinkFn -> Double -> Double -> Double +glmLogDensity family linkFn y eta = + let mu = case linkFn of + Identity -> eta + Log -> exp eta + Logit -> 1 / (1 + exp (-eta)) + Sqrt -> eta * eta + in case family of + Gaussian -> logNormDensity y mu 1.0 + Poisson -> Dist.logDensity (Dist.Poisson (max 1e-10 mu)) y + Binomial -> Dist.logDensity (Dist.Binomial 1 (max 1e-8 (min (1-1e-8) mu))) y + +-- --------------------------------------------------------------------------- +-- 数値ユーティリティ +-- --------------------------------------------------------------------------- + +logSumExp :: [Double] -> Double +logSumExp [] = -1/0 +logSumExp xs = + let m = maximum xs + in m + log (sum (map (\x -> exp (x - m)) xs)) + +mean :: [Double] -> Double +mean [] = 0 +mean xs = sum xs / fromIntegral (length xs) + +-- | [日本語]: 標本分散 (n-1 で割る) +-- [English]: Sample variance (divides by n-1). +sampleVar :: [Double] -> Double +sampleVar xs + | length xs < 2 = 0 + | otherwise = + let mu = mean xs + in sum (map (\x -> (x - mu) ^ (2::Int)) xs) + / fromIntegral (length xs - 1) + +-- --------------------------------------------------------------------------- +-- モデル比較の重み (Pseudo-BMA, ArviZ.compare 相当) +-- --------------------------------------------------------------------------- + +-- | One candidate model for comparison: label and log-likelihood matrix. +data CompareEntry = CompareEntry + { ceLabel :: String -- ^ Model label. + , ceLogLikMat :: [[Double]] -- ^ @S × N@ log-likelihood matrix. + } deriving (Show) + +-- | Per-model comparison result. +data CompareResult = CompareResult + { crLabel :: String -- ^ Model label. + , crWAIC :: Double -- ^ WAIC (smaller is better). + , crLOO :: Double -- ^ LOO (smaller is better). + , crDeltaWAIC :: Double -- ^ @ΔWAIC@ vs the best model. + , crDeltaLOO :: Double -- ^ @ΔLOO@ vs the best model. + , crSE :: Double -- ^ Standard error of @WAIC@. + , crKHatBad :: Int -- ^ Number of observations with @k̂ > 0.7@. + , crWeight :: Double -- ^ Pseudo-BMA weight (sums to 1 over models). + } deriving (Show) + +-- | [日本語]: 複数モデルを WAIC / LOO で比較し、 Pseudo-BMA 重みを計算する。 +-- +-- アルゴリズム: +-- +-- - 各モデルの WAIC と LOO を計算する。 +-- - 最良 (最小) のモデルを @ΔWAIC@ / @ΔLOO@ の基準とする。 +-- - Pseudo-BMA 重み: @w_i = exp(elpd_i) / Σ exp(elpd_j)@。 +-- (実用的には Δ から計算: w_i ∝ exp(-Δelpd_i)) +-- +-- [English]: Compare several models by WAIC / LOO and compute +-- Pseudo-BMA weights. +-- +-- Algorithm: +-- +-- - Compute WAIC and LOO for each model. +-- - Use the best (minimum) model as baseline for @ΔWAIC@ / @ΔLOO@. +-- - Pseudo-BMA weight: @w_i = exp(elpd_i) / Σ exp(elpd_j)@. +-- (in practice, computed from Δ: w_i ∝ exp(-Δelpd_i)) +compareModels :: [CompareEntry] -> [CompareResult] +compareModels entries = + let waicResults = map (\e -> (ceLabel e, waic (ceLogLikMat e))) entries + looResults = map (\e -> (ceLabel e, loo (ceLogLikMat e))) entries + waicVals = map (waicValue . snd) waicResults + looVals = map (looValue . snd) looResults + -- elpd_loo (= -looValue / 2) 基準で Pseudo-BMA 重みを計算 + elpds = map (\v -> -v / 2) looVals + maxElpd = maximum elpds + unnorm = map (\e -> exp (e - maxElpd)) elpds + total = sum unnorm + weights = map (/ total) unnorm + bestWaic = minimum waicVals + bestLoo = minimum looVals + in zipWith4 mkRow entries waicResults looResults weights + where + mkRow entry (lbl, w) (_, l) wt = CompareResult + { crLabel = lbl + , crWAIC = waicValue w + , crLOO = looValue l + , crDeltaWAIC = waicValue w - minimum (map (\e -> waicValue (waic (ceLogLikMat e))) entries) + , crDeltaLOO = looValue l - minimum (map (\e -> looValue (loo (ceLogLikMat e))) entries) + , crSE = waicSE w + , crKHatBad = looKHatBad l + , crWeight = wt + } + zipWith4 f as bs cs ds = case (as, bs, cs, ds) of + (a:as', b:bs', c:cs', d:ds') -> f a b c d : zipWith4 f as' bs' cs' ds' + _ -> []