packages feed

hanalyze-models (empty) → 0.2.0.1

raw patch · 70 files changed

+22507/−0 lines, 70 filesdep +basedep +containersdep +dataframe-core

Dependencies added: base, containers, dataframe-core, hanalyze-bayes, hanalyze-core, hanalyze-frame, hmatrix, megaparsec, mwc-random, parser-combinators, primitive, statistics, text, vector, vector-algorithms

Files

+ README.ja.md view
@@ -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)
+ README.md view
@@ -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)
+ hanalyze-models.cabal view
@@ -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
+ src/Hanalyze/Model/AFT.hs view
@@ -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))
+ src/Hanalyze/Model/Cluster.hs view
@@ -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
+ src/Hanalyze/Model/CompetingRisks.hs view
@@ -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+       }
+ src/Hanalyze/Model/DAG.hs view
@@ -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)
+ src/Hanalyze/Model/DecisionTree.hs view
@@ -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= &lt;total&gt;+--+-- 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) *+-- @+--+-- 各行 = @&lt;node#&gt;) &lt;split&gt; &lt;n&gt; &lt;loss&gt; &lt;yval&gt; (&lt;yprob…&gt;) [*]@。+-- ノード番号は R 同様 root=1・子は @2k@/@2k+1@。 @loss@ = 誤分類数+-- (n − 多数決クラス件数)、 @yval@ = 予測クラス、 @yprob@ = 木に現れる全クラスの+-- 確率 (クラス index 昇順)、 @*@ = 終端 (葉)。 分岐は R の固定幅表記に忠実に+-- 左 = @name&lt; thr@ (≤・条件成立)、 右 = @name&gt;=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= &lt;total&gt;+--+-- 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 = @&lt;node#&gt;) &lt;split&gt; &lt;n&gt; &lt;loss&gt; &lt;yval&gt; (&lt;yprob…&gt;) [*]@.+-- 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&lt; thr@ (≤, condition+-- holds), right = @name&gt;=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
+ src/Hanalyze/Model/Discriminant.hs view
@@ -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)
+ src/Hanalyze/Model/FDA.hs view
@@ -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+       }
+ src/Hanalyze/Model/FitYByX.hs view
@@ -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
+ src/Hanalyze/Model/Formula.hs view
@@ -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 "<formula>" 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
+ src/Hanalyze/Model/Formula/Design.hs view
@@ -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 ()
+ src/Hanalyze/Model/Formula/Frame.hs view
@@ -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 を独立水準 @"<NA>"@ として扱う。 [English]: Treats NA in factor columns as its own level, @"<NA>"@.+  | 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 を独立水準 @"<NA>"@ に置換した Text 列で上書きする。+--   非 NA 値は 'showNum' で文字列化 ('columnAsText' の数値→文字列と同形)。+--   [English]: Overwrites a factor column with a Text column where NA has+--   been replaced by its own level, @"<NA>"@. 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)+      _                                   -> "<NA>"++-- | [日本語]: '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
+ src/Hanalyze/Model/Formula/Mixed.hs view
@@ -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))
+ src/Hanalyze/Model/Formula/Nonlinear.hs view
@@ -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+        }
+ src/Hanalyze/Model/Formula/RFormula.hs view
@@ -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 "<r-formula>" txt of+  Left e  -> Left (errorBundlePretty e)+  Right f -> Right f
+ src/Hanalyze/Model/GAM.hs view
@@ -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 _ _ _ _ _ = []
+ src/Hanalyze/Model/GARCH.hs view
@@ -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)
+ src/Hanalyze/Model/GLM.hs view
@@ -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
+ src/Hanalyze/Model/GLMM.hs view
@@ -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))
+ src/Hanalyze/Model/GP.hs view
@@ -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)+       }
+ src/Hanalyze/Model/GPRobust.hs view
@@ -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)
+ src/Hanalyze/Model/GradientBoosting.hs view
@@ -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)
+ src/Hanalyze/Model/HierarchicalCluster.hs view
@@ -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
+ src/Hanalyze/Model/KNN.hs view
@@ -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)
+ src/Hanalyze/Model/Kernel.hs view
@@ -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 を使うこと"
+ src/Hanalyze/Model/KernelRegression.hs view
@@ -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
+ src/Hanalyze/Model/LM.hs view
@@ -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] ]
+ src/Hanalyze/Model/LM/Diagnostics.hs view
@@ -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)
+ src/Hanalyze/Model/LatentClassAnalysis.hs view
@@ -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)
+ src/Hanalyze/Model/LiNGAM/Bootstrap.hs view
@@ -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)
+ src/Hanalyze/Model/LiNGAM/Direct.hs view
@@ -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)
+ src/Hanalyze/Model/LiNGAM/ICA.hs view
@@ -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)
+ src/Hanalyze/Model/LiNGAM/MultiGroup.hs view
@@ -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)
+ src/Hanalyze/Model/LiNGAM/Pairwise.hs view
@@ -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
+ src/Hanalyze/Model/LiNGAM/Parce.hs view
@@ -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)
+ src/Hanalyze/Model/LiNGAM/VAR.hs view
@@ -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)
+ src/Hanalyze/Model/MDS.hs view
@@ -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
+ src/Hanalyze/Model/MultiGP.hs view
@@ -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+       }
+ src/Hanalyze/Model/MultiLM.hs view
@@ -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
+ src/Hanalyze/Model/MultiOutput.hs view
@@ -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] ]
+ src/Hanalyze/Model/Multivariate.hs view
@@ -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
+ src/Hanalyze/Model/NaiveBayes.hs view
@@ -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)
+ src/Hanalyze/Model/NeuralNetwork.hs view
@@ -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)
+ src/Hanalyze/Model/PCA.hs view
@@ -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
+ src/Hanalyze/Model/PLS.hs view
@@ -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
+ src/Hanalyze/Model/PartialDependence.hs view
@@ -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' }
+ src/Hanalyze/Model/Quantile.hs view
@@ -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
+ src/Hanalyze/Model/RFF.hs view
@@ -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+    }
+ src/Hanalyze/Model/RandomForest.hs view
@@ -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
+ src/Hanalyze/Model/RandomForestClassifier.hs view
@@ -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)
+ src/Hanalyze/Model/Regularized.hs view
@@ -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
+ src/Hanalyze/Model/RegularizedAdvanced.hs view
@@ -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] ]
+ src/Hanalyze/Model/Reliability.hs view
@@ -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+    }
+ src/Hanalyze/Model/ReliabilityBlockDiagram.hs view
@@ -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)
+ src/Hanalyze/Model/Robust.hs view
@@ -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))
+ src/Hanalyze/Model/SVM.hs view
@@ -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
+ src/Hanalyze/Model/Spline.hs view
@@ -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
+ src/Hanalyze/Model/StateSpace.hs view
@@ -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+        }
+ src/Hanalyze/Model/Survival.hs view
@@ -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
+ src/Hanalyze/Model/TimeSeries.hs view
@@ -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+
+ src/Hanalyze/Model/VAR.hs view
@@ -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 [])
+ src/Hanalyze/Model/Weibull.hs view
@@ -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
+ src/Hanalyze/Optim/BayesOpt.hs view
@@ -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
+ src/Hanalyze/Stat/Causal/CATE.hs view
@@ -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) ]
+ src/Hanalyze/Stat/Causal/DoublyRobust.hs view
@@ -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) ]
+ src/Hanalyze/Stat/Causal/IPW.hs view
@@ -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
+ src/Hanalyze/Stat/Causal/PropensityScore.hs view
@@ -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)
+ src/Hanalyze/Stat/ModelSelect.hs view
@@ -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'+      _ -> []