LA.Matrix Double -- ^ 埋め込み (n × k)。
+ -> Double
+sammonStress d y =
+ let !n = LA.rows d
+ row i = LA.flatten (y LA.? [i])
+ pairs = [ (i, j) | i <- [0 .. n - 1], j <- [i + 1 .. n - 1] ]
+ delta i j = LA.atIndex d (i, j)
+ dij i j = LA.norm_2 (row i - row j)
+ cTot = sum [ delta i j | (i, j) <- pairs ]
+ num = sum [ let !del = delta i j
+ !dd = dij i j
+ in if del > 0 then (del - dd)^(2 :: Int) / del
+ else 0
+ | (i, j) <- pairs ]
+ in if cTot > 0 then num / cTot else 0
+
+-- | Sammon MDS。 古典 MDS を初期値にして勾配降下。
+mdsSammon :: SammonConfig
+ -> LA.Matrix Double -- ^ 距離行列 D (n × n)。
+ -> Int -- ^ 目的次元 k。
+ -> LA.Matrix Double -- ^ 埋め込み (n × k)。
+mdsSammon cfg d k =
+ let !y0 = mdsClassical d k
+ loop !y !iter !prevE
+ | iter >= sammonMaxIter cfg = y
+ | otherwise =
+ let !grad = sammonGrad d y
+ !y' = y - LA.scale (sammonLR cfg) grad
+ !e' = sammonStress d y'
+ in if abs (prevE - e') < sammonTol cfg
+ then y'
+ else loop y' (iter + 1) e'
+ in loop y0 0 (sammonStress d y0)
+
+-- | Sammon stress の勾配 (n × k)。
+sammonGrad :: LA.Matrix Double -> LA.Matrix Double -> LA.Matrix Double
+sammonGrad d y =
+ let !n = LA.rows d
+ !k = LA.cols y
+ row i = LA.flatten (y LA.? [i])
+ delta i j = LA.atIndex d (i, j)
+ cTot = sum [ delta i j | i <- [0 .. n - 1]
+ , j <- [i + 1 .. n - 1] ]
+ scl = if cTot > 0 then 2 / cTot else 0
+ gradRow i =
+ let yi = row i
+ contribs = [ let yj = row j
+ dij = LA.norm_2 (yi - yj)
+ del = delta i j
+ in if del > 0 && dij > 0
+ then LA.scale ((del - dij) / (del * dij))
+ (yi - yj)
+ else LA.konst 0 k
+ | j <- [0 .. n - 1], j /= i ]
+ in LA.scale (negate scl) (sum contribs)
+ in LA.fromRows [ gradRow i | i <- [0 .. n - 1] ]
diff --git a/src/Hanalyze/Stat/ModelSelect.hs b/src/Hanalyze/Stat/ModelSelect.hs
--- a/src/Hanalyze/Stat/ModelSelect.hs
+++ b/src/Hanalyze/Stat/ModelSelect.hs
@@ -1,6 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
--- | MCMC-based model comparison criteria.
+-- |
+-- 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
diff --git a/src/Hanalyze/Stat/MultipleTesting.hs b/src/Hanalyze/Stat/MultipleTesting.hs
--- a/src/Hanalyze/Stat/MultipleTesting.hs
+++ b/src/Hanalyze/Stat/MultipleTesting.hs
@@ -1,5 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
--- | Multiple-testing correction.
+-- |
+-- Module : Hanalyze.Stat.MultipleTesting
+-- Description : 多重比較補正 (FWER: Bonferroni/Holm、 FDR: BH/BY)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
+-- Multiple-testing correction.
--
-- Adjusts a list of p-values to control either:
--
diff --git a/src/Hanalyze/Stat/NumberFormat.hs b/src/Hanalyze/Stat/NumberFormat.hs
--- a/src/Hanalyze/Stat/NumberFormat.hs
+++ b/src/Hanalyze/Stat/NumberFormat.hs
@@ -1,5 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
--- | Number-formatting helpers for reports and CLI output.
+-- |
+-- Module : Hanalyze.Stat.NumberFormat
+-- Description : レポート/CLI 出力向けの数値フォーマット helper (桁数に応じた固定/指数表記の自動選択)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
+-- Number-formatting helpers for reports and CLI output.
--
-- A single function chooses fixed-point or exponential notation based on
-- magnitude:
diff --git a/src/Hanalyze/Stat/PosteriorPredictive.hs b/src/Hanalyze/Stat/PosteriorPredictive.hs
--- a/src/Hanalyze/Stat/PosteriorPredictive.hs
+++ b/src/Hanalyze/Stat/PosteriorPredictive.hs
@@ -1,6 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
--- | Prior- and posterior-predictive sampling (analogous to PyMC's
+-- |
+-- Module : Hanalyze.Stat.PosteriorPredictive
+-- Description : 事前/事後予測サンプリング (PyMC の sample_prior/posterior_predictive 相当)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
+-- Prior- and posterior-predictive sampling (analogous to PyMC's
-- @sample_prior_predictive@ / @sample_posterior_predictive@).
--
-- @
diff --git a/src/Hanalyze/Stat/QuasiRandom.hs b/src/Hanalyze/Stat/QuasiRandom.hs
--- a/src/Hanalyze/Stat/QuasiRandom.hs
+++ b/src/Hanalyze/Stat/QuasiRandom.hs
@@ -1,5 +1,11 @@
--- | Quasi-random number sequences with low discrepancy.
+-- |
+-- Module : Hanalyze.Stat.QuasiRandom
+-- Description : 低不一致準乱数列 (Halton 列・LHS) — ベイズ最適化の初期設計に利用
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
--
+-- Quasi-random number sequences with low discrepancy.
+--
-- These sequences cover a multi-dimensional unit hyper-cube more
-- evenly than independent uniform-random samples and are the
-- recommended way to seed Bayesian-optimization initial designs and
@@ -15,6 +21,7 @@
, haltonSequence
, haltonSequenceIn
, haltonMatrix
+ , radicalInverse
, primes
-- * Latin Hypercube Sampling
, lhsSamples
diff --git a/src/Hanalyze/Stat/SPC.hs b/src/Hanalyze/Stat/SPC.hs
new file mode 100644
--- /dev/null
+++ b/src/Hanalyze/Stat/SPC.hs
@@ -0,0 +1,749 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BangPatterns #-}
+-- |
+-- Module : Hanalyze.Stat.SPC
+-- Description : 統計的工程管理 (SPC) — 管理図 (X̄-R/I-MR/p/np/c/u) + 判定ルール
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
+-- 統計的工程管理 (Statistical Process Control) — 管理図 + 判定ルール。
+--
+-- 変数管理図 (X̄-R / I-MR) と属性管理図 (p / np / c / u) を共通 API で扱う。
+-- 判定ルール (Western Electric / Nelson) は fit と分離した pure 関数。
+--
+-- === 公開 API
+--
+-- * 'SPCChart' / 'SPCInput' / 'SPCChartResult'
+-- * 'fitSPC'
+-- * 'westernElectricRules' / 'nelsonRules' / 'checkRules'
+--
+-- === 典型的な使い方
+--
+-- > case fitSPC XR (VarSubgroups subs) of
+-- > Left err -> ...
+-- > Right [xbar, rChart] -> do
+-- > let viols = checkRules westernElectricRules xbar
+-- > ...
+module Hanalyze.Stat.SPC
+ ( -- * chart 種別
+ SPCChart (..)
+ , SPCInput (..)
+ , SPCChartResult (..)
+ -- * fit
+ , fitSPC
+ -- * 判定ルール
+ , SPCRule (..)
+ , SPCViolation (..)
+ , westernElectricRules
+ , nelsonRules
+ , checkRules
+ ) where
+
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import Data.Text (Text)
+import Data.Vector (Vector)
+
+-- ===========================================================================
+-- 型定義
+-- ===========================================================================
+
+-- | 管理図の種別。
+data SPCChart
+ = XR -- ^ X̄-R chart (subgroup 平均 + range)
+ | IMR -- ^ I-MR chart (individual + moving range)
+ | P -- ^ p chart (不良率、 subgroup size 可変)
+ | NP -- ^ np chart (不良数、 subgroup size 一定)
+ | C -- ^ c chart (単位あたり欠陥数、 unit size 一定)
+ | U -- ^ u chart (単位あたり欠陥率、 unit size 可変)
+ | EWMAChart -- ^ EWMA (Exponentially Weighted Moving Average) chart (Phase 11)
+ | CUSUMChart -- ^ CUSUM (Cumulative Sum) chart 両側 (Phase 11)
+ deriving (Show, Eq)
+
+-- | 管理図入力。 chart 種別に対応した構成のみ受け付ける。
+data SPCInput
+ = -- | 変数管理図 (X̄-R) 用。 各 subgroup の観測値ベクトル。
+ -- subgroup サイズ (内側 Vector の長さ) は全 subgroup で同一であること。
+ VarSubgroups !(Vector (Vector Double))
+ | -- | I-MR 用。 個別観測値の系列。
+ VarIndividual !(Vector Double)
+ | -- | p chart 用。 (不良数, sample size) の系列。
+ AttrProportion !(Vector Int) !(Vector Int)
+ | -- | np chart 用。 (不良数の系列, 一定 sample size)。
+ AttrCount !(Vector Int) !Int
+ | -- | c chart 用。 欠陥数の系列 (unit size は一定と仮定)。
+ AttrDefects !(Vector Int)
+ | -- | u chart 用。 (欠陥数, unit size) の系列。
+ AttrDefectRate !(Vector Int) !(Vector Int)
+ | -- | EWMA 用。 (個別観測値 xs, λ ∈ (0,1], L (sigma 倍数), μ₀ target, σ₀ baseline σ)。
+ -- σ₀ ≤ 0 を渡すと xs の標本標準偏差で代用。
+ EWMAInput !(Vector Double) !Double !Double !Double !Double
+ | -- | CUSUM 用。 (個別観測値 xs, μ₀ target, σ₀ baseline σ, k (allowance, σ単位), h (decision interval, σ単位))。
+ -- σ₀ ≤ 0 を渡すと xs の標本標準偏差で代用。 両側 CUSUM (C+, C-) を返す。
+ CUSUMInput !(Vector Double) !Double !Double !Double !Double
+ deriving (Show, Eq)
+
+-- | 1 つの管理図の fit 結果。 X̄-R / I-MR では 2 つ並んで返る。
+--
+-- 不変条件:
+--
+-- * @V.length spcPoints == V.length spcUCL == V.length spcLCL@
+-- * 固定 limit chart (X̄-R / I-MR / np / c) では UCL/LCL は全要素同値
+-- * 変動 limit chart (p / u) では UCL/LCL が点ごとに異なる
+data SPCChartResult = SPCChartResult
+ { spcPoints :: !(Vector Double)
+ -- ^ 点ごとにプロットする統計量 (X̄、 R、 個別値、 MR、 p̂、 np、 c、 u 等)
+ , spcCenter :: !Double
+ -- ^ 中心線 (CL)
+ , spcUCL :: !(Vector Double)
+ -- ^ 上方管理限界 (点ごと)
+ , spcLCL :: !(Vector Double)
+ -- ^ 下方管理限界 (点ごと)
+ , spcSigma :: !Double
+ -- ^ 推定 σ (rule 判定用、 zone A/B/C の境界を計算するのに使う)
+ , spcChartName :: !Text
+ -- ^ "X-bar" / "R" / "I" / "MR" / "p" / "np" / "c" / "u"
+ } deriving (Show)
+
+-- ===========================================================================
+-- Montgomery 定数 (n = 2..15)
+-- ===========================================================================
+
+-- | 出典: Montgomery, "Introduction to Statistical Quality Control" 9th ed.
+-- Appendix VI。 @(A2, D3, D4, d2)@。
+-- subgroup size 範囲外の @n@ では 'Nothing'。
+subgroupConst :: Int -> Maybe (Double, Double, Double, Double)
+subgroupConst n = case n of
+ 2 -> Just (1.880, 0.000, 3.267, 1.128)
+ 3 -> Just (1.023, 0.000, 2.574, 1.693)
+ 4 -> Just (0.729, 0.000, 2.282, 2.059)
+ 5 -> Just (0.577, 0.000, 2.115, 2.326)
+ 6 -> Just (0.483, 0.000, 2.004, 2.534)
+ 7 -> Just (0.419, 0.076, 1.924, 2.704)
+ 8 -> Just (0.373, 0.136, 1.864, 2.847)
+ 9 -> Just (0.337, 0.184, 1.816, 2.970)
+ 10 -> Just (0.308, 0.223, 1.777, 3.078)
+ 11 -> Just (0.285, 0.256, 1.744, 3.173)
+ 12 -> Just (0.266, 0.283, 1.717, 3.258)
+ 13 -> Just (0.249, 0.307, 1.693, 3.336)
+ 14 -> Just (0.235, 0.328, 1.672, 3.407)
+ 15 -> Just (0.223, 0.347, 1.653, 3.472)
+ _ -> Nothing
+
+-- ===========================================================================
+-- 内部ヘルパ
+-- ===========================================================================
+
+vmean :: Vector Double -> Double
+vmean v
+ | V.null v = 0
+ | otherwise = V.sum v / fromIntegral (V.length v)
+
+vrange :: Vector Double -> Double
+vrange v
+ | V.null v = 0
+ | otherwise = V.maximum v - V.minimum v
+
+-- | 単一値で埋めた長さ @n@ の Vector。
+vconst :: Int -> Double -> Vector Double
+vconst n x = V.replicate n x
+
+tshow :: Show a => a -> Text
+tshow = T.pack . show
+
+chartTag :: SPCChart -> Text
+chartTag XR = "XR"
+chartTag IMR = "IMR"
+chartTag P = "P"
+chartTag NP = "NP"
+chartTag C = "C"
+chartTag U = "U"
+chartTag EWMAChart = "EWMA"
+chartTag CUSUMChart = "CUSUM"
+
+inputTag :: SPCInput -> Text
+inputTag VarSubgroups{} = "VarSubgroups"
+inputTag VarIndividual{} = "VarIndividual"
+inputTag AttrProportion{} = "AttrProportion"
+inputTag AttrCount{} = "AttrCount"
+inputTag AttrDefects{} = "AttrDefects"
+inputTag AttrDefectRate{} = "AttrDefectRate"
+inputTag EWMAInput{} = "EWMAInput"
+inputTag CUSUMInput{} = "CUSUMInput"
+
+-- ===========================================================================
+-- 公開関数
+-- ===========================================================================
+
+-- | 管理図を fit する。 X̄-R / I-MR は 2 chart を返す
+-- (順に X̄ chart / R chart、 I chart / MR chart)。
+-- chart 種別と入力の組合せが不正な場合 'Left' を返す。
+fitSPC :: SPCChart -> SPCInput -> Either Text [SPCChartResult]
+fitSPC XR (VarSubgroups subs) = fitXR subs
+fitSPC IMR (VarIndividual xs) = fitIMR xs
+fitSPC P (AttrProportion ds ns) = fitP ds ns
+fitSPC NP (AttrCount ds n) = fitNP ds n
+fitSPC C (AttrDefects ds) = fitC ds
+fitSPC U (AttrDefectRate ds ns) = fitU ds ns
+fitSPC EWMAChart (EWMAInput xs lam ll mu0 s0) = fitEWMA xs lam ll mu0 s0
+fitSPC CUSUMChart (CUSUMInput xs mu0 s0 k h) = fitCUSUM xs mu0 s0 k h
+fitSPC chart inp =
+ Left $ "Hanalyze.Stat.SPC.fitSPC: chart kind "
+ <> chartTag chart
+ <> " does not match input "
+ <> inputTag inp
+
+-- ---------------------------------------------------------------------------
+-- X̄-R chart
+-- ---------------------------------------------------------------------------
+
+-- | X̄-R chart:
+--
+-- * X̄ chart: CL = X̿、 UCL = X̿ + A2·R̄、 LCL = X̿ − A2·R̄、 σ̂ = R̄ / d2
+-- * R chart: CL = R̄、 UCL = D4·R̄、 LCL = D3·R̄
+fitXR :: Vector (Vector Double) -> Either Text [SPCChartResult]
+fitXR subs
+ | V.null subs = Left "fitSPC XR: empty subgroup list"
+ | otherwise =
+ let !n = V.length (V.head subs)
+ !k = V.length subs
+ sizesOk = V.all (\s -> V.length s == n) subs
+ in if not sizesOk
+ then Left "fitSPC XR: subgroup sizes are not uniform"
+ else case subgroupConst n of
+ Nothing -> Left $ "fitSPC XR: subgroup size n=" <> tshow n
+ <> " is outside supported range (2..15)"
+ Just (a2, d3, d4, d2c) ->
+ let means = V.map vmean subs
+ ranges = V.map vrange subs
+ xBarBar = vmean means
+ rBar = vmean ranges
+ sigma = rBar / d2c
+ uclX = xBarBar + a2 * rBar
+ lclX = xBarBar - a2 * rBar
+ uclR = d4 * rBar
+ lclR = d3 * rBar
+ xChart = SPCChartResult
+ { spcPoints = means
+ , spcCenter = xBarBar
+ , spcUCL = vconst k uclX
+ , spcLCL = vconst k lclX
+ , spcSigma = sigma
+ , spcChartName = "X-bar"
+ }
+ rChart = SPCChartResult
+ { spcPoints = ranges
+ , spcCenter = rBar
+ , spcUCL = vconst k uclR
+ , spcLCL = vconst k lclR
+ , spcSigma = sigma
+ , spcChartName = "R"
+ }
+ in Right [xChart, rChart]
+
+-- ---------------------------------------------------------------------------
+-- I-MR chart
+-- ---------------------------------------------------------------------------
+
+-- | I-MR chart:
+--
+-- * MR_i = |x_i − x_{i−1}| for i = 1..N−1
+-- * I chart: CL = x̄、 σ̂ = MR̄ / d2(n=2) = MR̄ / 1.128、 UCL/LCL = x̄ ± 3σ̂
+-- * MR chart: CL = MR̄、 UCL = D4(2)·MR̄ = 3.267·MR̄、 LCL = D3(2)·MR̄ = 0
+fitIMR :: Vector Double -> Either Text [SPCChartResult]
+fitIMR xs
+ | V.length xs < 2 = Left "fitSPC IMR: need at least 2 individual observations"
+ | otherwise =
+ let !n = V.length xs
+ xBar = vmean xs
+ mr = V.generate (n - 1) (\i -> abs (xs V.! (i + 1) - xs V.! i))
+ mrBar = vmean mr
+ (_, d3, d4, d2c) = case subgroupConst 2 of
+ Just t -> t
+ Nothing -> (0, 0, 0, 1.128) -- 到達不能
+ sigma = mrBar / d2c
+ uclI = xBar + 3 * sigma
+ lclI = xBar - 3 * sigma
+ uclMR = d4 * mrBar
+ lclMR = d3 * mrBar
+ iChart = SPCChartResult
+ { spcPoints = xs
+ , spcCenter = xBar
+ , spcUCL = vconst n uclI
+ , spcLCL = vconst n lclI
+ , spcSigma = sigma
+ , spcChartName = "I"
+ }
+ mrChart = SPCChartResult
+ { spcPoints = mr
+ , spcCenter = mrBar
+ , spcUCL = vconst (n - 1) uclMR
+ , spcLCL = vconst (n - 1) lclMR
+ , spcSigma = sigma
+ , spcChartName = "MR"
+ }
+ in Right [iChart, mrChart]
+
+-- ---------------------------------------------------------------------------
+-- p chart (proportion defective, variable subgroup size)
+-- ---------------------------------------------------------------------------
+
+-- | p chart:
+--
+-- * p̂_i = d_i / n_i
+-- * p̄ = Σ d_i / Σ n_i
+-- * CL = p̄
+-- * UCL_i = p̄ + 3·sqrt(p̄(1−p̄)/n_i)、 LCL_i = max(0, …)
+--
+-- σ̂ は **平均 n** に基づく代表値 (rule 判定用)。
+fitP :: Vector Int -> Vector Int -> Either Text [SPCChartResult]
+fitP ds ns
+ | V.length ds /= V.length ns
+ = Left "fitSPC P: defectives and sample-size series differ in length"
+ | V.null ds = Left "fitSPC P: empty series"
+ | V.any (< 0) ds = Left "fitSPC P: defectives must be non-negative"
+ | V.any (<= 0) ns = Left "fitSPC P: sample sizes must be positive"
+ | V.or (V.zipWith (>) ds ns) = Left "fitSPC P: defectives exceed sample size"
+ | otherwise =
+ let k = V.length ds
+ totalD = sum (V.toList ds) :: Int
+ totalN = sum (V.toList ns) :: Int
+ pBar = fromIntegral totalD / fromIntegral totalN
+ phat = V.zipWith (\d n -> fromIntegral d / fromIntegral n) ds ns
+ ucl = V.map (\ni -> pBar + 3 * sqrt (pBar * (1 - pBar) /
+ fromIntegral ni)) ns
+ lcl = V.map (\ni -> max 0 $ pBar - 3 * sqrt (pBar * (1 - pBar) /
+ fromIntegral ni)) ns
+ nMean = fromIntegral totalN / fromIntegral k :: Double
+ sigma = sqrt (pBar * (1 - pBar) / nMean)
+ in Right [SPCChartResult
+ { spcPoints = phat
+ , spcCenter = pBar
+ , spcUCL = ucl
+ , spcLCL = lcl
+ , spcSigma = sigma
+ , spcChartName = "p"
+ }]
+
+-- ---------------------------------------------------------------------------
+-- np chart (count defective, constant subgroup size n)
+-- ---------------------------------------------------------------------------
+
+-- | np chart (n は全 subgroup で一定):
+--
+-- * CL = n·p̄ = 平均不良数
+-- * σ̂ = sqrt(n·p̄·(1−p̄))
+-- * UCL = n·p̄ + 3·σ̂、 LCL = max(0, …)
+fitNP :: Vector Int -> Int -> Either Text [SPCChartResult]
+fitNP ds n
+ | V.null ds = Left "fitSPC NP: empty defectives series"
+ | n <= 0 = Left "fitSPC NP: sample size n must be positive"
+ | V.any (< 0) ds = Left "fitSPC NP: defectives must be non-negative"
+ | V.any (> n) ds = Left "fitSPC NP: defectives exceed sample size"
+ | otherwise =
+ let k = V.length ds
+ totalD = sum (V.toList ds) :: Int
+ pBar = fromIntegral totalD / fromIntegral (n * k) :: Double
+ cl = fromIntegral n * pBar
+ sigma = sqrt (fromIntegral n * pBar * (1 - pBar))
+ ucl = cl + 3 * sigma
+ lcl = max 0 (cl - 3 * sigma)
+ pts = V.map fromIntegral ds :: Vector Double
+ in Right [SPCChartResult
+ { spcPoints = pts
+ , spcCenter = cl
+ , spcUCL = vconst k ucl
+ , spcLCL = vconst k lcl
+ , spcSigma = sigma
+ , spcChartName = "np"
+ }]
+
+-- ---------------------------------------------------------------------------
+-- c chart (count of defects, constant unit size)
+-- ---------------------------------------------------------------------------
+
+-- | c chart:
+--
+-- * CL = c̄ = 平均欠陥数
+-- * σ̂ = sqrt(c̄)
+-- * UCL = c̄ + 3·sqrt(c̄)、 LCL = max(0, …)
+fitC :: Vector Int -> Either Text [SPCChartResult]
+fitC ds
+ | V.null ds = Left "fitSPC C: empty defects series"
+ | V.any (< 0) ds = Left "fitSPC C: defects must be non-negative"
+ | otherwise =
+ let k = V.length ds
+ cBar = fromIntegral (sum (V.toList ds)) / fromIntegral k :: Double
+ sigma = sqrt cBar
+ ucl = cBar + 3 * sigma
+ lcl = max 0 (cBar - 3 * sigma)
+ pts = V.map fromIntegral ds :: Vector Double
+ in Right [SPCChartResult
+ { spcPoints = pts
+ , spcCenter = cBar
+ , spcUCL = vconst k ucl
+ , spcLCL = vconst k lcl
+ , spcSigma = sigma
+ , spcChartName = "c"
+ }]
+
+-- ---------------------------------------------------------------------------
+-- u chart (defect rate, variable unit size)
+-- ---------------------------------------------------------------------------
+
+-- | u chart:
+--
+-- * u_i = d_i / n_i
+-- * ū = Σ d_i / Σ n_i
+-- * CL = ū
+-- * UCL_i = ū + 3·sqrt(ū/n_i)、 LCL_i = max(0, …)
+fitU :: Vector Int -> Vector Int -> Either Text [SPCChartResult]
+fitU ds ns
+ | V.length ds /= V.length ns
+ = Left "fitSPC U: defects and unit-size series differ in length"
+ | V.null ds = Left "fitSPC U: empty series"
+ | V.any (< 0) ds = Left "fitSPC U: defects must be non-negative"
+ | V.any (<= 0) ns = Left "fitSPC U: unit sizes must be positive"
+ | otherwise =
+ let k = V.length ds
+ totalD = fromIntegral (sum (V.toList ds)) :: Double
+ totalN = fromIntegral (sum (V.toList ns)) :: Double
+ uBar = totalD / totalN
+ us = V.zipWith (\d n -> fromIntegral d / fromIntegral n) ds ns
+ ucl = V.map (\ni -> uBar + 3 * sqrt (uBar / fromIntegral ni)) ns
+ lcl = V.map (\ni -> max 0 (uBar - 3 * sqrt (uBar / fromIntegral ni))) ns
+ nMean = totalN / fromIntegral k
+ sigma = sqrt (uBar / nMean)
+ in Right [SPCChartResult
+ { spcPoints = us
+ , spcCenter = uBar
+ , spcUCL = ucl
+ , spcLCL = lcl
+ , spcSigma = sigma
+ , spcChartName = "u"
+ }]
+
+-- ===========================================================================
+-- 判定ルール (Phase 1.4 / 1.5 で実装)
+-- ===========================================================================
+
+-- | 判定ルール 1 個。
+data SPCRule = SPCRule
+ { ruleName :: !Text -- ^ "Western Electric 1" / "Nelson 1" 等
+ , ruleNumber :: !Int -- ^ ルール番号 (1..8)
+ , ruleCheck :: SPCChartResult -> [Int] -- ^ 違反点の 0-origin index list
+ }
+
+-- | ルール違反 1 件。
+data SPCViolation = SPCViolation
+ { vRuleName :: !Text
+ , vRuleNumber :: !Int
+ , vPointIndex :: !Int
+ , vChartName :: !Text -- ^ どの chart で違反したか (X-bar / R / 等)
+ } deriving (Show, Eq)
+
+-- ---------------------------------------------------------------------------
+-- 内部パターン検出 (rule 共通)
+-- ---------------------------------------------------------------------------
+
+-- $patternDetectors
+-- ゾーン境界は CL ± k·σ で定義 (σ は 'spcSigma' フィールド)。
+-- 可変 limit chart (p / u) では σ は代表値 (平均 n から算出) なので、
+-- ゾーン判定はやや近似となる (canvas display 用途では実用上問題なし)。
+
+-- | k·σ の絶対値を超えた点の index (0-origin)。 chart 種別非依存。
+beyondSigma :: Double -> SPCChartResult -> [Int]
+beyondSigma k r =
+ let cl = spcCenter r
+ sigma = spcSigma r
+ pts = V.toList (spcPoints r)
+ in [ i | (i, x) <- zip [0..] pts
+ , abs (x - cl) > k * sigma ]
+
+-- | k·σ を超える点について「+ なら +1、 − なら −1、 ゾーン内なら 0」。
+sideAtSigma :: Double -> SPCChartResult -> [Int]
+sideAtSigma k r =
+ let cl = spcCenter r
+ sigma = spcSigma r
+ pts = V.toList (spcPoints r)
+ classify x
+ | x - cl > k * sigma = 1
+ | x - cl < -k * sigma = -1
+ | otherwise = 0
+ in map classify pts
+
+-- | CL に対する符号 (上 = +1, 下 = -1, 上 = 0)。
+sideOfCenter :: SPCChartResult -> [Int]
+sideOfCenter r =
+ let cl = spcCenter r
+ pts = V.toList (spcPoints r)
+ classify x
+ | x > cl = 1
+ | x < cl = -1
+ | otherwise = 0
+ in map classify pts
+
+-- | N 個連続で同符号 (CL の同じ側) になっている末尾点の index を返す。
+-- 例: 8 連続 → 連続区間の 8 点目以降を全部 violation として返す。
+runSameSide :: Int -> SPCChartResult -> [Int]
+runSameSide n r = go 0 0 0 (sideOfCenter r) []
+ where
+ go !i !curSide !runLen ss acc = case ss of
+ [] -> reverse acc
+ (s:xs) ->
+ let (curSide', runLen')
+ | s == 0 = (0, 0)
+ | s == curSide = (curSide, runLen + 1)
+ | otherwise = (s, 1)
+ acc' | runLen' >= n = i : acc
+ | otherwise = acc
+ in go (i + 1) curSide' runLen' xs acc'
+
+-- | N 個連続で単調 (全て上昇 or 全て下降) のパターンの末尾 index。
+trendMono :: Int -> SPCChartResult -> [Int]
+trendMono n r = go 0 0 0 (V.toList (spcPoints r)) []
+ where
+ -- direction: +1 = increasing, -1 = decreasing, 0 = none yet
+ go _ _ _ [] acc = reverse acc
+ go _ _ _ [_] acc = reverse acc
+ go !i !dir !runLen (x : ys@(y : _)) acc =
+ let d | y > x = 1
+ | y < x = -1
+ | otherwise = 0
+ (dir', runLen')
+ | d == 0 = (0, 0)
+ | d == dir = (dir, runLen + 1)
+ | otherwise = (d, 2) -- 始まり: 2 点で run=2
+ -- 違反 = runLen が n 以上、 i+1 (現在の y) の index を記録
+ acc' | runLen' >= n = (i + 1) : acc
+ | otherwise = acc
+ in go (i + 1) dir' runLen' ys acc'
+
+-- | N 個連続で交互上下のパターンの末尾 index。
+alternating :: Int -> SPCChartResult -> [Int]
+alternating n r = go 0 0 0 (V.toList (spcPoints r)) []
+ where
+ go _ _ _ [] acc = reverse acc
+ go _ _ _ [_] acc = reverse acc
+ go !i !lastDir !runLen (x : ys@(y : _)) acc =
+ let d | y > x = 1
+ | y < x = -1
+ | otherwise = 0
+ (lastDir', runLen')
+ | d == 0 = (0, 0)
+ | lastDir == 0 = (d, 2)
+ | d == negate lastDir = (d, runLen + 1)
+ | otherwise = (d, 2)
+ acc' | runLen' >= n = (i + 1) : acc
+ | otherwise = acc
+ in go (i + 1) lastDir' runLen' ys acc'
+
+-- | k 個連続で σ 倍の絶対値以内 (= ゾーン C 内のみ) の末尾 index。
+-- stratification (W-E rule 6 / Nelson 7)。
+withinSigma :: Int -> Double -> SPCChartResult -> [Int]
+withinSigma n k r =
+ let cl = spcCenter r
+ sigma = spcSigma r
+ pts = V.toList (spcPoints r)
+ flags = map (\x -> abs (x - cl) <= k * sigma) pts
+ in collectRun n flags
+
+-- | k 個連続で σ 倍の絶対値より外 (= ゾーン A or B、 中央線の同/異側問わず) の末尾 index。
+-- mixture (W-E rule 7 / Nelson 8)。
+beyondSigmaEither :: Int -> Double -> SPCChartResult -> [Int]
+beyondSigmaEither n k r =
+ let cl = spcCenter r
+ sigma = spcSigma r
+ pts = V.toList (spcPoints r)
+ flags = map (\x -> abs (x - cl) > k * sigma) pts
+ in collectRun n flags
+
+-- | True が n 個以上連続するパターンの末尾 index 集合。
+collectRun :: Int -> [Bool] -> [Int]
+collectRun n = go 0 0 []
+ where
+ go _ _ acc [] = reverse acc
+ go !i !rn acc (f : fs) =
+ let rn' = if f then rn + 1 else 0
+ acc' | rn' >= n = i : acc
+ | otherwise = acc
+ in go (i + 1) rn' acc' fs
+
+-- | 「直近 m 点のうち k 点以上が k·σ を **同じ側** で超えている」 末尾 index。
+-- Western Electric 2 / 3 用 (m, k, σ係数)。
+kOfMBeyondSameSide :: Int -> Int -> Double -> SPCChartResult -> [Int]
+kOfMBeyondSameSide kth m sigK r = go 0 (sideAtSigma sigK r) []
+ where
+ go _ ss acc | length ss < m = reverse acc
+ go !i ss acc =
+ let window = take m ss
+ posCount = length (filter (== 1) window)
+ negCount = length (filter (== -1) window)
+ hit = posCount >= kth || negCount >= kth
+ -- 違反 index は window の末尾 (= i + m - 1)
+ acc' | hit = (i + m - 1) : acc
+ | otherwise = acc
+ in case ss of
+ [] -> reverse acc'
+ (_:xs) -> go (i + 1) xs acc'
+
+-- ---------------------------------------------------------------------------
+-- Western Electric rules (WECO 8 rules)
+-- ---------------------------------------------------------------------------
+
+-- | Western Electric Company (WECO) rules。 8 rules。
+--
+-- (Western Electric Statistical Quality Control Handbook 1956 +
+-- 一般的な 8-rule 拡張)
+--
+-- * Rule 1: 1 点が 3σ 超
+-- * Rule 2: 3 点中 2 点が同じ側で 2σ 超
+-- * Rule 3: 5 点中 4 点が同じ側で 1σ 超
+-- * Rule 4: 8 点連続で CL の同じ側
+-- * Rule 5: 6 点連続で単調 (上昇 or 下降)
+-- * Rule 6: 15 点連続で 1σ 以内 (stratification)
+-- * Rule 7: 8 点連続で 1σ 外 (mixture; どちら側でも可)
+-- * Rule 8: 14 点連続で交互上下
+westernElectricRules :: [SPCRule]
+westernElectricRules =
+ [ SPCRule "Western Electric 1" 1 (beyondSigma 3)
+ , SPCRule "Western Electric 2" 2 (kOfMBeyondSameSide 2 3 2)
+ , SPCRule "Western Electric 3" 3 (kOfMBeyondSameSide 4 5 1)
+ , SPCRule "Western Electric 4" 4 (runSameSide 8)
+ , SPCRule "Western Electric 5" 5 (trendMono 6)
+ , SPCRule "Western Electric 6" 6 (withinSigma 15 1)
+ , SPCRule "Western Electric 7" 7 (beyondSigmaEither 8 1)
+ , SPCRule "Western Electric 8" 8 (alternating 14)
+ ]
+
+-- ---------------------------------------------------------------------------
+-- Nelson rules (1984、 8 rules)
+-- ---------------------------------------------------------------------------
+
+-- | Nelson rules (Nelson, L.S. 1984, J. Qual. Tech.)。 8 rules。
+--
+-- WE 8 rules と多くが重複するが、 ルール番号と一部の N が異なる:
+--
+-- * Rule 1: 1 点が 3σ 超 (= WE 1)
+-- * Rule 2: 9 点連続で CL の同じ側 (WE 4 は 8 点)
+-- * Rule 3: 6 点連続で単調 (= WE 5)
+-- * Rule 4: 14 点連続で交互上下 (= WE 8)
+-- * Rule 5: 3 点中 2 点が同じ側で 2σ 超 (= WE 2)
+-- * Rule 6: 5 点中 4 点が同じ側で 1σ 超 (= WE 3)
+-- * Rule 7: 15 点連続で 1σ 以内 (= WE 6)
+-- * Rule 8: 8 点連続で 1σ 外 (どちら側でも可) (= WE 7)
+--
+-- 検出ロジックは [[westernElectricRules]] と同じヘルパを再利用。
+nelsonRules :: [SPCRule]
+nelsonRules =
+ [ SPCRule "Nelson 1" 1 (beyondSigma 3)
+ , SPCRule "Nelson 2" 2 (runSameSide 9)
+ , SPCRule "Nelson 3" 3 (trendMono 6)
+ , SPCRule "Nelson 4" 4 (alternating 14)
+ , SPCRule "Nelson 5" 5 (kOfMBeyondSameSide 2 3 2)
+ , SPCRule "Nelson 6" 6 (kOfMBeyondSameSide 4 5 1)
+ , SPCRule "Nelson 7" 7 (withinSigma 15 1)
+ , SPCRule "Nelson 8" 8 (beyondSigmaEither 8 1)
+ ]
+
+-- | 指定したルール集合で違反点を検出する。
+checkRules :: [SPCRule] -> SPCChartResult -> [SPCViolation]
+checkRules rs r =
+ [ SPCViolation (ruleName ru) (ruleNumber ru) i (spcChartName r)
+ | ru <- rs
+ , i <- ruleCheck ru r
+ ]
+
+-- ---------------------------------------------------------------------------
+-- EWMA chart (Phase 11)
+-- ---------------------------------------------------------------------------
+
+-- | EWMA chart:
+--
+-- * 再帰: @z_i = λ x_i + (1 − λ) z_{i−1}@, @z_0 = μ₀@
+-- * 時変管理限界: @μ₀ ± L σ √(λ/(2−λ) · (1 − (1−λ)^{2i}))@
+-- * σ₀ ≤ 0 のとき xs の標本標準偏差で代用。
+--
+-- 入力検証: 0 < λ ≤ 1, L > 0, |xs| ≥ 1。
+fitEWMA :: Vector Double -> Double -> Double -> Double -> Double
+ -> Either Text [SPCChartResult]
+fitEWMA xs lam ll mu0 s0In
+ | V.null xs = Left "fitSPC EWMA: empty input"
+ | not (lam > 0 && lam <= 1) = Left "fitSPC EWMA: λ must be in (0, 1]"
+ | ll <= 0 = Left "fitSPC EWMA: L must be > 0"
+ | otherwise =
+ let !n = V.length xs
+ !sigma = if s0In > 0 then s0In else sampleSD xs
+ zs = V.scanl' (\z x -> lam * x + (1 - lam) * z) mu0 xs
+ -- scanl' includes initial → drop the seed
+ zsTail = V.tail zs
+ ucl = V.generate n (\i ->
+ let i1 = fromIntegral (i + 1) :: Double
+ factor = lam / (2 - lam) * (1 - (1 - lam) ** (2 * i1))
+ in mu0 + ll * sigma * sqrt factor)
+ lcl = V.generate n (\i ->
+ let i1 = fromIntegral (i + 1) :: Double
+ factor = lam / (2 - lam) * (1 - (1 - lam) ** (2 * i1))
+ in mu0 - ll * sigma * sqrt factor)
+ in Right [ SPCChartResult
+ { spcPoints = zsTail
+ , spcCenter = mu0
+ , spcUCL = ucl
+ , spcLCL = lcl
+ , spcSigma = sigma
+ , spcChartName = "EWMA"
+ } ]
+
+-- ---------------------------------------------------------------------------
+-- CUSUM chart (Phase 11)
+-- ---------------------------------------------------------------------------
+
+-- | CUSUM (両側) chart:
+--
+-- * @C⁺_i = max(0, x_i − (μ₀ + k σ) + C⁺_{i−1})@, @C⁺_0 = 0@
+-- * @C⁻_i = max(0, (μ₀ − k σ) − x_i + C⁻_{i−1})@, @C⁻_0 = 0@
+-- * 決定限界: @H = h σ@ (上側のみ、 下側は @−H@ として描画用に @-1 × C⁻@ を返す)
+--
+-- 返り値: [C⁺ chart, C⁻ chart]。 C⁻ chart は points が負方向に出るよう
+-- @spcPoints = − C⁻@ として表現し、 LCL = −H、 UCL = 0 とする。
+fitCUSUM :: Vector Double -> Double -> Double -> Double -> Double
+ -> Either Text [SPCChartResult]
+fitCUSUM xs mu0 s0In k h
+ | V.null xs = Left "fitSPC CUSUM: empty input"
+ | k < 0 = Left "fitSPC CUSUM: k must be ≥ 0"
+ | h <= 0 = Left "fitSPC CUSUM: h must be > 0"
+ | otherwise =
+ let !n = V.length xs
+ !sigma = if s0In > 0 then s0In else sampleSD xs
+ kAbs = k * sigma
+ hAbs = h * sigma
+ cPos = V.scanl' (\c x -> max 0 (c + (x - mu0) - kAbs)) 0 xs
+ cNeg = V.scanl' (\c x -> max 0 (c + (mu0 - x) - kAbs)) 0 xs
+ cPosT = V.tail cPos
+ cNegT = V.tail cNeg
+ chartPos = SPCChartResult
+ { spcPoints = cPosT
+ , spcCenter = 0
+ , spcUCL = vconst n hAbs
+ , spcLCL = vconst n 0
+ , spcSigma = sigma
+ , spcChartName = "CUSUM+"
+ }
+ chartNeg = SPCChartResult
+ { spcPoints = V.map negate cNegT
+ , spcCenter = 0
+ , spcUCL = vconst n 0
+ , spcLCL = vconst n (-hAbs)
+ , spcSigma = sigma
+ , spcChartName = "CUSUM-"
+ }
+ in Right [chartPos, chartNeg]
+
+-- | 標本標準偏差 (n-1 補正)。 EWMA/CUSUM の σ₀ デフォルト用。
+sampleSD :: Vector Double -> Double
+sampleSD xs
+ | V.length xs < 2 = 0
+ | otherwise =
+ let m = vmean xs
+ ss = V.sum (V.map (\x -> (x - m) ** 2) xs)
+ in sqrt (ss / fromIntegral (V.length xs - 1))
diff --git a/src/Hanalyze/Stat/Standardize.hs b/src/Hanalyze/Stat/Standardize.hs
--- a/src/Hanalyze/Stat/Standardize.hs
+++ b/src/Hanalyze/Stat/Standardize.hs
@@ -1,5 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
--- | Input-feature standardization (z-score) utilities.
+-- |
+-- Module : Hanalyze.Stat.Standardize
+-- Description : 入力特徴量の標準化 (z-score) ユーティリティ
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
+-- Input-feature standardization (z-score) utilities.
--
-- Use cases:
--
diff --git a/src/Hanalyze/Stat/Summary.hs b/src/Hanalyze/Stat/Summary.hs
--- a/src/Hanalyze/Stat/Summary.hs
+++ b/src/Hanalyze/Stat/Summary.hs
@@ -1,6 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
--- | Posterior-distribution summary statistics.
+-- |
+-- Module : Hanalyze.Stat.Summary
+-- Description : 事後分布の要約統計 (ArviZ az.summary 相当)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
--
+-- Posterior-distribution summary statistics.
+--
-- Provides 'SummaryRow' and 'posteriorSummary', mirroring the columns of
-- ArviZ's @az.summary@ (mean, sd, HDI, ESS, R-hat). Originally lived in
-- @Hanalyze.Viz.MCMC@; moved to the statistics layer to decouple it from the
@@ -16,7 +22,7 @@
import Data.Text (Text)
import Hanalyze.MCMC.Core (Chain, chainVals)
-import Hanalyze.Stat.MCMC (ess, hdi, rhat)
+import Hanalyze.Stat.MCMC (essBulk, hdi, rhat)
-- | One row of posterior summary statistics for a single parameter.
data SummaryRow = SummaryRow
@@ -25,14 +31,15 @@
, srSD :: Double -- ^ Posterior standard deviation.
, srHdiLo :: Double -- ^ Lower bound of the 94% HDI.
, srHdiHi :: Double -- ^ Upper bound of the 94% HDI.
- , srEssV :: Double -- ^ Effective sample size.
+ , srEssV :: Double -- ^ Effective sample size (rank-normalized bulk ESS, ArviZ @ess_bulk@ 互換).
, srRhat :: Maybe Double -- ^ Split-R-hat (only for multi-chain runs).
} deriving (Show)
-- | Compute posterior summaries for the named parameters across one or
-- more chains. With a single chain @R-hat@ is 'Nothing'; with multiple
--- chains, mean / SD / HDI / ESS are computed on the pooled samples and
--- split-R-hat is computed across chains.
+-- chains, mean / SD / HDI are computed on the pooled samples, while ESS
+-- (bulk ESS, ArviZ @ess_bulk@ 互換 = Phase 100 で旧 pooled 'ess' から切替) and
+-- split-R-hat are computed across chains.
posteriorSummary :: [Text] -> [Chain] -> [SummaryRow]
posteriorSummary params chains =
let multi = length chains > 1
@@ -46,7 +53,7 @@
else sqrt (sum [(x - mu) ^ (2::Int) | x <- allVals]
/ fromIntegral (n - 1))
(lo, hi) = hdi 0.94 allVals
- essV = ess allVals
+ essV = essBulk perChain
rh = if multi then rhat perChain else Nothing
in SummaryRow p mu sd_ lo hi essV rh
in map mkRow params
diff --git a/src/Hanalyze/Stat/Test.hs b/src/Hanalyze/Stat/Test.hs
--- a/src/Hanalyze/Stat/Test.hs
+++ b/src/Hanalyze/Stat/Test.hs
@@ -1,7 +1,13 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
--- | Hypothesis tests with a unified result format.
+-- |
+-- Module : Hanalyze.Stat.Test
+-- Description : 統一結果形式を持つ仮説検定群 (パラメトリック/ノンパラ/適合度/正規性/分散)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
--
+-- Hypothesis tests with a unified result format.
+--
-- Most tests delegate to the @statistics@ package internals
-- (@Statistics.Test.*@) and add hanalyze-specific niceties: a single
-- 'TestResult' record, effect sizes, confidence intervals, and a
@@ -25,12 +31,16 @@
, tTest1Sample
, tTestPaired
, tTestWelch
+ , tostWelch
, tTestStudent
, anovaOneWay
-- * Non-parametric (location / rank)
, mannWhitneyU
, wilcoxonSignedRank
, kruskalWallis
+ , friedmanTest
+ , MultiCompareResult (..)
+ , dunnTest
-- * Goodness-of-fit / independence
, chiSquareGOF
, chiSquareIndep
@@ -42,6 +52,10 @@
, leveneTest
, bartlettTest
, fTestVariance
+ -- * Multivariate (Phase 4.3、 request/140)
+ , hotellingsT2
+ , hotellingsT2TwoSample
+ , manova
) where
import qualified Data.List as L
@@ -202,6 +216,58 @@
Nothing
t
+-- | TOST (Two One-Sided Tests) for equivalence using Welch's degrees of freedom.
+--
+-- Tests whether @|μ_A − μ_B| < Δ@ (i.e. the two groups are equivalent within
+-- the margin Δ). Implements two one-sided t-tests:
+--
+-- * Lower: @H₀: μ_A − μ_B ≤ −Δ@ vs @H₁: μ_A − μ_B > −Δ@
+-- * Upper: @H₀: μ_A − μ_B ≥ +Δ@ vs @H₁: μ_A − μ_B < +Δ@
+--
+-- @p_TOST = max(p_lower, p_upper)@. Equivalence is concluded at level α if
+-- @p_TOST < α@. The returned 'trCI' is the @(1 − 2α)@ confidence interval
+-- (here α = 0.05 → 90% CI), which is the standard TOST CI convention.
+tostWelch
+ :: LA.Vector Double -- ^ Sample A
+ -> LA.Vector Double -- ^ Sample B
+ -> Double -- ^ Equivalence margin Δ (must be > 0)
+ -> TestResult
+tostWelch xs ys delta
+ | delta <= 0 =
+ noResultTRR "TOST (Welch)" TwoSided "delta must be > 0"
+ | LA.size xs < 2 || LA.size ys < 2 =
+ noResultTRR "TOST (Welch)" TwoSided "insufficient samples"
+ | otherwise =
+ let n1 = fromIntegral (LA.size xs) :: Double
+ n2 = fromIntegral (LA.size ys) :: Double
+ m1 = LA.sumElements xs / n1
+ m2 = LA.sumElements ys / n2
+ v1 = LA.sumElements ((xs - LA.scalar m1) ^ (2 :: Int)) / (n1 - 1)
+ v2 = LA.sumElements ((ys - LA.scalar m2) ^ (2 :: Int)) / (n2 - 1)
+ se = sqrt (v1 / n1 + v2 / n2)
+ diff = m1 - m2
+ df = (v1/n1 + v2/n2) ^ (2 :: Int)
+ / ((v1/n1)^(2::Int)/(n1-1) + (v2/n2)^(2::Int)/(n2-1))
+ tDist = StuT.studentT df
+ tLower = (diff - (-delta)) / se -- want > 0 (upper-tail rejects H0_lower)
+ tUpper = (diff - delta) / se -- want < 0 (lower-tail rejects H0_upper)
+ pLower = pFromT TRight tLower tDist
+ pUpper = pFromT TLeft tUpper tDist
+ pTost = max pLower pUpper
+ -- 90% CI (α = 0.05 each side)
+ tCrit = SD.quantile tDist 0.95
+ ci = (diff - tCrit * se, diff + tCrit * se)
+ in TestResult
+ { trMethod = "TOST (Welch)"
+ , trStatistic = min (abs tLower) (abs tUpper)
+ , trDf = Just (df, Nothing)
+ , trPValue = pTost
+ , trEffect = Just ("Delta", delta)
+ , trCI = Just ci
+ , trAlternative = TwoSided
+ , trNote = Just "Equivalence demonstrated if p < alpha"
+ }
+
-- | Student's two-sample t-test (assumes equal variance).
tTestStudent
:: LA.Vector Double
@@ -338,6 +404,118 @@
, trNote = Just "chi-square approximation"
}
+-- | Friedman test — non-parametric two-way ANOVA without replication.
+--
+-- 入力: n × k 行列。 行 = block (被験者)、 列 = treatment。
+-- 各 block 内で treatment を順位付け (1..k) し、 列ごとの平均順位の分散から
+-- 検定統計量 Q を構成 (χ²(k-1) 近似)。
+friedmanTest :: LA.Matrix Double -> TestResult
+friedmanTest mat
+ | LA.rows mat < 2 || LA.cols mat < 2 =
+ noResultTRR "Friedman" TwoSided "need ≥ 2 blocks × ≥ 2 treatments"
+ | otherwise =
+ let n = LA.rows mat
+ k = LA.cols mat
+ nD = fromIntegral n :: Double
+ kD = fromIntegral k :: Double
+ -- 各行を順位化 (tie は midrank)
+ rankedRows =
+ [ midrank (LA.toList (LA.flatten (mat LA.? [i])))
+ | i <- [0 .. n - 1] ]
+ colSums = [ sum [ rankedRows !! i !! j | i <- [0 .. n - 1] ]
+ | j <- [0 .. k - 1] ]
+ q = (12 / (nD * kD * (kD + 1)))
+ * sum [ s * s | s <- colSums ]
+ - 3 * nD * (kD + 1)
+ df = kD - 1
+ p = SD.complCumulative (ChiSq.chiSquared (k - 1)) q
+ in TestResult
+ { trMethod = "Friedman"
+ , trStatistic = q
+ , trDf = Just (df, Nothing)
+ , trPValue = p
+ , trEffect = Nothing
+ , trCI = Nothing
+ , trAlternative = TwoSided
+ , trNote = Just "chi-square approximation"
+ }
+
+-- | 多重比較の結果。 ペアごとの z 値と raw / adjusted p-value。
+data MultiCompareResult = MultiCompareResult
+ { mcrPairs :: ![(Int, Int)]
+ , mcrZ :: ![Double]
+ , mcrPRaw :: ![Double]
+ , mcrPAdj :: ![Double] -- Holm correction
+ } deriving (Show)
+
+-- | Dunn 多重比較 (Kruskal-Wallis post-hoc)。
+-- 各グループの平均順位 R̄_i / R̄_j の差を SE で標準化:
+--
+-- z_{ij} = (R̄_i - R̄_j) / √( (N(N+1)/12) (1/n_i + 1/n_j) )
+--
+-- p_raw = 2 (1 - Φ(|z|))、 Holm 補正で族別 p_adj。
+dunnTest :: [LA.Vector Double] -> MultiCompareResult
+dunnTest groups =
+ let k = length groups
+ sizes = map LA.size groups
+ allRanks = midrank (concatMap LA.toList groups)
+ -- 各グループの平均順位
+ starts = scanl (+) 0 sizes
+ grpRanks = [ take (sizes !! i)
+ (drop (starts !! i) allRanks)
+ | i <- [0 .. k - 1] ]
+ meanR i = sum (grpRanks !! i) / fromIntegral (sizes !! i)
+ n = sum sizes
+ nD = fromIntegral n :: Double
+ se i j =
+ sqrt (nD * (nD + 1) / 12
+ * (1 / fromIntegral (sizes !! i) + 1 / fromIntegral (sizes !! j)))
+ pairs = [ (i, j) | i <- [0 .. k - 2], j <- [i + 1 .. k - 1] ]
+ zs = [ (meanR i - meanR j) / se i j | (i, j) <- pairs ]
+ pRaw = [ 2 * (1 - SD.cumulative Normal.standard (abs z)) | z <- zs ]
+ pAdj = holmAdjust pRaw
+ in MultiCompareResult
+ { mcrPairs = pairs
+ , mcrZ = zs
+ , mcrPRaw = pRaw
+ , mcrPAdj = pAdj
+ }
+
+-- | Holm-Bonferroni p-value adjustment.
+holmAdjust :: [Double] -> [Double]
+holmAdjust ps =
+ let m = length ps
+ idx = zip [0 ..] ps
+ sorted = L.sortBy (comparing snd) idx
+ stepwise = zipWith
+ (\rank (origIdx, p) ->
+ (origIdx, min 1 (p * fromIntegral (m - rank))))
+ [0 ..] sorted
+ -- monotone increasing enforcement
+ mono = scanl1 (\(_, prev) (i, p) -> (i, max prev p)) stepwise
+ in map snd (L.sortBy (comparing fst) mono)
+
+-- | midrank: 同順位は順位平均。 入力: list of values, 出力: 同 length の rank list。
+midrank :: [Double] -> [Double]
+midrank xs =
+ let indexed = zip [0 :: Int ..] xs
+ sorted = L.sortBy (comparing snd) indexed
+ n = length xs
+ -- グループ化: 同値を 1 グループに
+ go _ [] = []
+ go pos (g:gs) =
+ let len = length g
+ avgRank = fromIntegral (sum [pos .. pos + len - 1]) / fromIntegral len + 1
+ in [(i, avgRank) | (i, _) <- g] ++ go (pos + len) gs
+ grouped = groupBy (\(_, a) (_, b) -> a == b) sorted
+ ranked = go 0 grouped
+ in map snd (L.sortBy (comparing fst) ranked)
+ where
+ groupBy _ [] = []
+ groupBy eq (x:xs') =
+ let (same, rest) = span (eq x) xs'
+ in (x : same) : groupBy eq rest
+
-- ---------------------------------------------------------------------------
-- Goodness-of-fit / independence
-- ---------------------------------------------------------------------------
@@ -728,4 +906,217 @@
Less -> SD.cumulative Normal.standard z
Greater -> SD.complCumulative Normal.standard z
in (wPlus, wMinus, p)
+
+-- ===========================================================================
+-- 多変量検定 (Phase 4.3、 request/140)
+-- ===========================================================================
+
+-- | 1 サンプル Hotelling T² 検定 (H_0: μ = μ_0)。
+--
+-- 入力:
+--
+-- * X (n × p): 各行が 1 観測の多変量ベクトル
+-- * μ_0 (長さ p): 仮説の平均
+--
+-- 統計量と分布:
+--
+-- > T² = n · (μ̂ − μ_0)ᵀ S⁻¹ (μ̂ − μ_0)
+-- > F = ((n − p) / ((n − 1) · p)) · T², df = (p, n − p)
+--
+-- 戻り値の 'trStatistic' は F 値、 'trEffect' に @("T²", T²)@ を格納。
+hotellingsT2 :: LA.Matrix Double -> LA.Vector Double -> TestResult
+hotellingsT2 x mu0
+ | n < 2 = noResultTRR "Hotelling T² (1-sample)" TwoSided "need ≥ 2 observations"
+ | p < 1 = noResultTRR "Hotelling T² (1-sample)" TwoSided "need ≥ 1 variable"
+ | LA.size mu0 /= p =
+ noResultTRR "Hotelling T² (1-sample)" TwoSided "μ_0 length mismatch"
+ | n <= p =
+ noResultTRR "Hotelling T² (1-sample)" TwoSided "need n > p (covariance singular)"
+ | otherwise =
+ let nD = fromIntegral n :: Double
+ pD = fromIntegral p :: Double
+ xMean = columnMeans x
+ diff = xMean - mu0
+ sCov = sampleCovariance x
+ maybeT2 = do
+ sInv <- LA.linearSolve sCov (LA.asColumn diff)
+ return $! nD * LA.sumElements (diff * LA.flatten sInv)
+ in case maybeT2 of
+ Nothing -> noResultTRR "Hotelling T² (1-sample)" TwoSided
+ "covariance matrix singular"
+ Just t2 ->
+ let df1 = pD
+ df2 = nD - pD
+ fStat = (df2 / ((nD - 1) * pD)) * t2
+ pVal = SD.complCumulative
+ (FDist.fDistribution (round df1) (round df2))
+ fStat
+ in TestResult
+ { trMethod = "Hotelling T² (1-sample)"
+ , trStatistic = fStat
+ , trDf = Just (df1, Just df2)
+ , trPValue = pVal
+ , trEffect = Just ("T²", t2)
+ , trCI = Nothing
+ , trAlternative = TwoSided
+ , trNote = Nothing
+ }
+ where
+ n = LA.rows x
+ p = LA.cols x
+
+-- | 2 サンプル Hotelling T² 検定 (等分散仮定、 H_0: μ_X = μ_Y)。
+--
+-- 入力: X (n_1 × p)、 Y (n_2 × p)。 両標本の次元 p は一致が必要。
+--
+-- 統計量:
+--
+-- > T² = (n_1·n_2 / (n_1+n_2)) · (μ̂_1 − μ̂_2)ᵀ S_p⁻¹ (μ̂_1 − μ̂_2)
+-- > F = ((n_1+n_2−p−1) / ((n_1+n_2−2)·p)) · T², df = (p, n_1+n_2−p−1)
+hotellingsT2TwoSample :: LA.Matrix Double -> LA.Matrix Double -> TestResult
+hotellingsT2TwoSample x y
+ | n1 < 2 || n2 < 2 =
+ noResultTRR "Hotelling T² (2-sample)" TwoSided "each group needs ≥ 2 observations"
+ | LA.cols x /= LA.cols y =
+ noResultTRR "Hotelling T² (2-sample)" TwoSided "dimension mismatch (p_X ≠ p_Y)"
+ | n1 + n2 - p - 1 <= 0 =
+ noResultTRR "Hotelling T² (2-sample)" TwoSided "need n_1 + n_2 > p + 1"
+ | otherwise =
+ let n1D = fromIntegral n1 :: Double
+ n2D = fromIntegral n2 :: Double
+ pD = fromIntegral p :: Double
+ m1 = columnMeans x
+ m2 = columnMeans y
+ s1 = sampleCovariance x
+ s2 = sampleCovariance y
+ sP = LA.scale ((n1D - 1) / (n1D + n2D - 2)) s1
+ + LA.scale ((n2D - 1) / (n1D + n2D - 2)) s2
+ diff = m1 - m2
+ maybeT2 = do
+ sInv <- LA.linearSolve sP (LA.asColumn diff)
+ return $! (n1D * n2D / (n1D + n2D))
+ * LA.sumElements (diff * LA.flatten sInv)
+ in case maybeT2 of
+ Nothing -> noResultTRR "Hotelling T² (2-sample)" TwoSided
+ "pooled covariance singular"
+ Just t2 ->
+ let df1 = pD
+ df2 = n1D + n2D - pD - 1
+ fStat = (df2 / ((n1D + n2D - 2) * pD)) * t2
+ pVal = SD.complCumulative
+ (FDist.fDistribution (round df1) (round df2))
+ fStat
+ in TestResult
+ { trMethod = "Hotelling T² (2-sample)"
+ , trStatistic = fStat
+ , trDf = Just (df1, Just df2)
+ , trPValue = pVal
+ , trEffect = Just ("T²", t2)
+ , trCI = Nothing
+ , trAlternative = TwoSided
+ , trNote = Nothing
+ }
+ where
+ n1 = LA.rows x
+ n2 = LA.rows y
+ p = LA.cols x
+
+-- | 1 元配置 MANOVA (H_0: 全群の μ が等しい)。
+--
+-- 入力: 各群の観測行列リスト @[X_1, X_2, ..., X_k]@、 各 X_i は @n_i × p@。
+--
+-- 統計量: Wilks' Λ = det(W) / det(W + B)。
+-- B = between-group SSCP、 W = within-group SSCP。
+-- p-value は Rao の F 近似:
+--
+-- > s = sqrt((p²·q² − 4) / (p² + q² − 5)) (q = k − 1)
+-- > m = N − 1 − (p + q + 1) / 2
+-- > df1 = p · q, df2 = m·s − (p·q − 2) / 2
+-- > F = ((1 − Λ^(1/s)) / Λ^(1/s)) · (df2 / df1)
+--
+-- 'trStatistic' に F 値、 'trEffect' に @("Wilks Λ", Λ)@。
+manova :: [LA.Matrix Double] -> TestResult
+manova groups
+ | k < 2 = noResultTRR "MANOVA (one-way)" TwoSided "need ≥ 2 groups"
+ | any (\g -> LA.rows g < 2) groups =
+ noResultTRR "MANOVA (one-way)" TwoSided "each group needs ≥ 2 observations"
+ | not (all ((== p) . LA.cols) groups) =
+ noResultTRR "MANOVA (one-way)" TwoSided "dimension mismatch across groups"
+ | otherwise =
+ let nis = map (fromIntegral . LA.rows) groups :: [Double]
+ totalN = sum nis
+ pD = fromIntegral p :: Double
+ q = fromIntegral (k - 1) :: Double
+ groupMs = map columnMeans groups
+ allMean = LA.scale (1 / totalN)
+ (foldr1 (+) (zipWith LA.scale nis groupMs))
+ mkOuter v = LA.outer v v
+ bMat = foldr1 (+)
+ [ LA.scale ni (mkOuter (m - allMean))
+ | (ni, m) <- zip nis groupMs ]
+ wMat = foldr1 (+) [ withinSSCP g (groupMs !! i)
+ | (i, g) <- zip [0 ..] groups ]
+ detW = LA.det wMat
+ detTot = LA.det (wMat + bMat)
+ in if detTot == 0
+ then noResultTRR "MANOVA (one-way)" TwoSided
+ "W+B is singular"
+ else
+ let wilks = detW / detTot
+ -- Rao F approximation
+ numS = pD*pD * q*q - 4
+ denS = pD*pD + q*q - 5
+ s | denS > 0 && numS > 0 = sqrt (numS / denS)
+ | otherwise = 1
+ mAdj = totalN - 1 - (pD + q + 1) / 2
+ df1 = pD * q
+ df2 = mAdj * s - (pD * q - 2) / 2
+ lam1s = wilks ** (1 / s)
+ fStat = ((1 - lam1s) / lam1s) * (df2 / df1)
+ df1i = max 1 (round df1)
+ df2i = max 1 (round df2)
+ pVal = if df2 > 0 && fStat > 0
+ then SD.complCumulative
+ (FDist.fDistribution df1i df2i) fStat
+ else 1.0
+ in TestResult
+ { trMethod = "MANOVA (one-way, Wilks' Λ)"
+ , trStatistic = fStat
+ , trDf = Just (df1, Just df2)
+ , trPValue = pVal
+ , trEffect = Just ("Wilks Λ", wilks)
+ , trCI = Nothing
+ , trAlternative = TwoSided
+ , trNote = Nothing
+ }
+ where
+ k = length groups
+ p = if null groups then 0 else LA.cols (head groups)
+
+-- ---------------------------------------------------------------------------
+-- 多変量 helper
+-- ---------------------------------------------------------------------------
+
+-- | 列ごとの平均 (= サンプル平均ベクトル)。
+columnMeans :: LA.Matrix Double -> LA.Vector Double
+columnMeans m =
+ let n = fromIntegral (LA.rows m) :: Double
+ in LA.scale (1 / n) (LA.fromList [ LA.sumElements (m LA.¿ [j])
+ | j <- [0 .. LA.cols m - 1] ])
+
+-- | 標本共分散行列 (n - 1 分母)。
+sampleCovariance :: LA.Matrix Double -> LA.Matrix Double
+sampleCovariance m =
+ let n = fromIntegral (LA.rows m) :: Double
+ means = columnMeans m
+ meanRow = LA.asRow means
+ centered = m - LA.fromRows (replicate (LA.rows m) means)
+ _ = meanRow -- silence unused warning
+ in LA.scale (1 / (n - 1)) (LA.tr centered LA.<> centered)
+
+-- | 群内 SSCP: Σ (x_{ij} − x̄_i)(x_{ij} − x̄_i)ᵀ
+withinSSCP :: LA.Matrix Double -> LA.Vector Double -> LA.Matrix Double
+withinSSCP g groupMean =
+ let centered = g - LA.fromRows (replicate (LA.rows g) groupMean)
+ in LA.tr centered LA.<> centered
diff --git a/src/Hanalyze/Stat/VI.hs b/src/Hanalyze/Stat/VI.hs
--- a/src/Hanalyze/Stat/VI.hs
+++ b/src/Hanalyze/Stat/VI.hs
@@ -1,6 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
--- | Variational inference (ADVI — Automatic Differentiation Variational
+-- |
+-- Module : Hanalyze.Stat.VI
+-- Description : 変分推論 (ADVI: Automatic Differentiation Variational Inference)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
+-- Variational inference (ADVI — Automatic Differentiation Variational
-- Inference).
--
-- Implements the mean-field normal VI of Kucukelbir et al. (2017). Uses
@@ -31,11 +37,13 @@
( VIConfig (..)
, defaultVIConfig
, VIResult (..)
+ , VIMethod (..)
, advi
+ , fullRankAdvi
) where
import Control.DeepSeq (force)
-import Control.Monad (forM, forM_, replicateM)
+import Control.Monad (forM, forM_, replicateM, when)
import Data.IORef
import qualified Data.Map.Strict as Map
import System.Random.MWC (GenIO)
@@ -80,14 +88,21 @@
-- 結果
-- ---------------------------------------------------------------------------
--- | ADVI result.
+-- | VI 近似法。 mean-field (`advi`) と full-rank (`fullRankAdvi`) を区別する。
+data VIMethod = MeanField | FullRank
+ deriving (Show, Eq)
+
+-- | ADVI result. mean-field と full-rank の両方が返す。 full-rank では
+-- @viCovU@ に @n×n@ 下三角 Cholesky 因子 @L@ (unconstrained 空間) が入る。
data VIResult = VIResult
- { viPostMeans :: Params -- ^ Posterior means (constrained space, sample mean).
- , viPostSDs :: Params -- ^ Posterior SDs (constrained space).
- , viMuU :: [Double] -- ^ Variational mean @μ@ (unconstrained).
- , viSigmaU :: [Double] -- ^ Variational SD @σ@ (unconstrained).
- , viElboHistory :: [Double] -- ^ ELBO trajectory (for convergence inspection).
- , viDraws :: [Params] -- ^ Posterior draws in the constrained space (length 'viNumDraws').
+ { viPostMeans :: Params -- ^ Posterior means (constrained space, sample mean).
+ , viPostSDs :: Params -- ^ Posterior SDs (constrained space).
+ , viMuU :: [Double] -- ^ Variational mean @μ@ (unconstrained).
+ , viSigmaU :: [Double] -- ^ Variational SD @σ@ (unconstrained、 mean-field の場合は対角要素、 full-rank なら L_ii)。
+ , viCovU :: Maybe [[Double]] -- ^ Full-rank ADVI: 下三角 Cholesky 因子 @L@ ([row][col])、 @LLᵀ = Σ@。 mean-field では @Nothing@。
+ , viMethod :: VIMethod -- ^ どちらの近似法か。
+ , viElboHistory :: [Double] -- ^ ELBO trajectory (for convergence inspection).
+ , viDraws :: [Params] -- ^ Posterior draws in the constrained space (length 'viNumDraws').
} deriving (Show)
-- ---------------------------------------------------------------------------
@@ -216,9 +231,192 @@
, viPostSDs = postSDs
, viMuU = muFinal
, viSigmaU = sigmaFinal
+ , viCovU = Nothing
+ , viMethod = MeanField
, viElboHistory = elboHistory
, viDraws = draws
}
+
+-- ---------------------------------------------------------------------------
+-- Full-rank ADVI (Phase 37-A5)
+-- ---------------------------------------------------------------------------
+
+-- | Full-rank ADVI: 共分散を含めた変分近似 @q(u) = N(μ, LLᵀ)@ を最適化する。
+--
+-- 平均場 'advi' との違い:
+--
+-- * 変分パラメータは @μ@ (n-vector) と @L@ (下三角 n×n、 対角は log で
+-- parameterize して正値保証)
+-- * @u = μ + L·ε@ の reparameterization で勾配を取り、 ELBO の補正項は
+-- @log|L| = Σ log L_ii = Σ ω_i@
+-- * 推定共分散 @Σ = LLᵀ@ は @viCovU@ に入る (下三角 @L@ そのもの)
+--
+-- 平均場と比べて posterior の相関を捉えられるが、 パラメタ数 @O(n²)@、
+-- 計算量も @O(n² S)@ per iteration なので n が大きいモデルでは重い。
+-- 平均場が「SD を過小評価」 する hierarchical model で特に有用。
+fullRankAdvi :: ModelP r -> VIConfig -> Params -> GenIO -> IO VIResult
+fullRankAdvi model cfg initP gen = do
+ let names = sampleNames model
+ transforms = getTransforms model
+ n = length names
+ initU = paramsToVec names (toUnconstrainedParams transforms initP)
+
+ logJ :: [Double] -> Double
+ logJ uVec = logJointU model transforms (vecToParams names uVec)
+
+ h = viGradStep cfg
+ numGrad :: [Double] -> [Double]
+ numGrad uVec =
+ [ let ui = uVec !! i
+ lp = logJ (replaceAt i (ui + h) uVec)
+ lm = logJ (replaceAt i (ui - h) uVec)
+ raw = (lp - lm) / (2 * h)
+ in if isNaN raw || isInfinite raw then 0 else raw
+ | i <- [0 .. n-1]
+ ]
+
+ -- 変分パラメータ: μ (n-vector)、 ω (n-vector、 ω_i = log L_ii)、
+ -- offdiag (下三角の i > j 要素を行優先で並べた長さ n(n-1)/2 のリスト)
+ muRef <- newIORef initU
+ omegaRef <- newIORef (replicate n 0.0) -- L_ii = exp(0) = 1
+ let nOff = n * (n - 1) `div` 2
+ offRef <- newIORef (replicate nOff 0.0) -- off-diag は 0 で初期化
+
+ -- Adam モーメント (μ / ω / offdiag それぞれ)
+ m1MuRef <- newIORef (replicate n 0.0)
+ m2MuRef <- newIORef (replicate n 0.0)
+ m1OmRef <- newIORef (replicate n 0.0)
+ m2OmRef <- newIORef (replicate n 0.0)
+ m1OffRef <- newIORef (replicate nOff 0.0)
+ m2OffRef <- newIORef (replicate nOff 0.0)
+
+ elboRef <- newIORef []
+
+ let b1 = viBeta1 cfg
+ b2 = viBeta2 cfg
+ eps_ = viEpsilon cfg
+ alpha = viLearningRate cfg
+ sNum = viSamples cfg
+
+ forM_ [1 .. viIterations cfg] $ \t -> do
+ mu <- readIORef muRef
+ omega <- readIORef omegaRef
+ offdg <- readIORef offRef
+ let lMat = buildL n omega offdg -- 下三角 L
+
+ -- MC 勾配
+ mcResults <- forM [1 .. sNum] $ \_ -> do
+ epsilons <- replicateM n (standard gen)
+ let uVec = vecAdd mu (matVec lMat epsilons)
+ lj = logJ uVec
+ gU = numGrad uVec -- ∂lp/∂u_i, length n
+ dMu = gU -- ∂ELBO/∂μ_i = gU_i
+ -- ∂ELBO/∂ω_i = ε_i × L_ii × gU_i + 1 (entropy +1)
+ dOm = [ epsilons !! i
+ * (lMat !! i !! i)
+ * (gU !! i) + 1
+ | i <- [0 .. n-1] ]
+ -- ∂ELBO/∂L_ij (i > j) = ε_j × gU_i (no entropy contribution)
+ dOff = [ (epsilons !! j) * (gU !! i)
+ | i <- [1 .. n-1], j <- [0 .. i-1] ]
+ return (lj, dMu, dOm, dOff)
+
+ let sD = fromIntegral sNum :: Double
+ !ljMC = sum (map (\(l,_,_,_) -> l) mcResults) / sD
+ -- ELBO = E[logJointU] + log|L| + n/2 (1 + log 2π)
+ !elboV = ljMC + sum omega + fromIntegral n * 0.5 * (1 + log (2*pi))
+ !gMu = force (map (/ sD) $ foldr1 (zipWith (+))
+ (map (\(_,g,_,_) -> g) mcResults))
+ !gOm = force (map (/ sD) $ foldr1 (zipWith (+))
+ (map (\(_,_,g,_) -> g) mcResults))
+ !gOff = if nOff == 0
+ then []
+ else force (map (/ sD) $ foldr1 (zipWith (+))
+ (map (\(_,_,_,g) -> g) mcResults))
+
+ modifyIORef' elboRef (elboV :)
+
+ -- Adam で μ
+ m1Mu <- readIORef m1MuRef
+ m2Mu <- readIORef m2MuRef
+ let (m1Mu', m2Mu', dxMu) = adamStep b1 b2 eps_ alpha t m1Mu m2Mu gMu
+ writeIORef m1MuRef (force m1Mu')
+ writeIORef m2MuRef (force m2Mu')
+ writeIORef muRef (force (zipWith (+) mu dxMu))
+
+ -- Adam で ω
+ m1Om <- readIORef m1OmRef
+ m2Om <- readIORef m2OmRef
+ let (m1Om', m2Om', dxOm) = adamStep b1 b2 eps_ alpha t m1Om m2Om gOm
+ writeIORef m1OmRef (force m1Om')
+ writeIORef m2OmRef (force m2Om')
+ writeIORef omegaRef (force (zipWith (+) omega dxOm))
+
+ -- Adam で off-diagonal (n=1 のときは空)
+ when (nOff > 0) $ do
+ m1Off <- readIORef m1OffRef
+ m2Off <- readIORef m2OffRef
+ let (m1Off', m2Off', dxOff) = adamStep b1 b2 eps_ alpha t m1Off m2Off gOff
+ writeIORef m1OffRef (force m1Off')
+ writeIORef m2OffRef (force m2Off')
+ writeIORef offRef (force (zipWith (+) offdg dxOff))
+
+ -- 収束後
+ muFinal <- readIORef muRef
+ omegaFinal <- readIORef omegaRef
+ offFinal <- readIORef offRef
+ let lFinal = buildL n omegaFinal offFinal
+ lDiag = [ lFinal !! i !! i | i <- [0 .. n-1] ]
+
+ draws <- forM [1 .. viNumDraws cfg] $ \_ -> do
+ epsilons <- replicateM n (standard gen)
+ let uVec = vecAdd muFinal (matVec lFinal epsilons)
+ return (fromUnconstrainedParams transforms (vecToParams names uVec))
+
+ let nD = fromIntegral (viNumDraws cfg) :: Double
+ getVals p = map (Map.findWithDefault 0 p) draws
+ muP p = let vs = getVals p in sum vs / nD
+ sdP p = let vs = getVals p
+ mu = muP p
+ in sqrt (sum (map (\v -> (v - mu) ^ (2::Int)) vs) / nD)
+ postMeans = Map.fromList [(nm, muP nm) | nm <- names]
+ postSDs = Map.fromList [(nm, sdP nm) | nm <- names]
+
+ elboHistory <- fmap reverse (readIORef elboRef)
+
+ return VIResult
+ { viPostMeans = postMeans
+ , viPostSDs = postSDs
+ , viMuU = muFinal
+ , viSigmaU = lDiag
+ , viCovU = Just lFinal
+ , viMethod = FullRank
+ , viElboHistory = elboHistory
+ , viDraws = draws
+ }
+
+-- | 下三角 L を構築。 @omega@ は対角 (L_ii = exp ω_i)、
+-- @offdg@ は (i, j) for i > j を行優先 (i 昇順、 同 i 内で j 昇順) で
+-- 並べたリスト。 結果は @n × n@ 行列、 上三角は 0。
+buildL :: Int -> [Double] -> [Double] -> [[Double]]
+buildL n omega offdg =
+ let -- offdg をインデックス map に変換
+ offMap = Map.fromList (zip pairs offdg)
+ pairs = [ (i, j) | i <- [1 .. n-1], j <- [0 .. i-1] ]
+ diag i = exp (omega !! i)
+ row i = [ if j < i then Map.findWithDefault 0 (i, j) offMap
+ else if j == i then diag i
+ else 0
+ | j <- [0 .. n-1] ]
+ in [ row i | i <- [0 .. n-1] ]
+
+-- | 行列・ベクトル積 @y = M·x@。
+matVec :: [[Double]] -> [Double] -> [Double]
+matVec mat x = [ sum (zipWith (*) row x) | row <- mat ]
+
+-- | ベクトル足し算。
+vecAdd :: [Double] -> [Double] -> [Double]
+vecAdd = zipWith (+)
-- ---------------------------------------------------------------------------
-- 補助関数
diff --git a/src/Hanalyze/Viz/AnalysisReport.hs b/src/Hanalyze/Viz/AnalysisReport.hs
--- a/src/Hanalyze/Viz/AnalysisReport.hs
+++ b/src/Hanalyze/Viz/AnalysisReport.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.AnalysisReport
+-- Description : 【非推奨】 LM/GLM/GLMM/GP/HBM 専用の sum-type ベース HTML レポート (ReportBuilder に移行済)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | __DEPRECATED__ — sum-type-based HTML report dedicated to
-- LM / GLM / GLMM / GP / HBM (~2000 lines). Superseded by
@@ -54,7 +60,7 @@
import qualified Data.Vector as V
import qualified Numeric.LinearAlgebra as LA
-import qualified DataFrame as DX
+import qualified DataFrame.Operations.Core as DX
import qualified DataFrame.Internal.DataFrame as DXD
import Hanalyze.DataIO.Convert (getDoubleVec, getTextVec)
import Hanalyze.MCMC.Core (Chain, chainSamples, chainAccepted, chainTotal)
@@ -966,6 +972,14 @@
[ " Periodic カーネル
"
, " k(x, x') = σ²_f · exp( −2 sin²(π|x−x'|/p) / ℓ² )
"
]
+ kernelDesc Linear =
+ [ " Linear (内積) カーネル
"
+ , " k(x, x') = σ²_f · (x·x')
"
+ ]
+ kernelDesc (Poly d) =
+ [ " Polynomial カーネル (次数 " <> T.pack (show d) <> ")
"
+ , " k(x, x') = (γ·(x·x') + 1)^" <> T.pack (show d) <> " (γ = 1/(2ℓ²))
"
+ ]
lmAppendix :: Text -> Text
lmAppendix link = T.unlines
@@ -1270,6 +1284,8 @@
jsKernelId RBF = "rbf"
jsKernelId Matern52 = "matern52"
jsKernelId Periodic = "periodic"
+jsKernelId Linear = "linear"
+jsKernelId (Poly _) = "poly"
jsGPParams :: Kernel -> GPParams -> Text
jsGPParams ker p =
diff --git a/src/Hanalyze/Viz/Assets.hs b/src/Hanalyze/Viz/Assets.hs
--- a/src/Hanalyze/Viz/Assets.hs
+++ b/src/Hanalyze/Viz/Assets.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.Assets
+-- Description : オフライン HTML レポート用に Vega/Vega-Lite/Vega-Embed の JS 本体を同梱する自動生成モジュール
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- Auto-generated from assets/ — do not edit by hand.
-- Bundles Vega v5, Vega-Lite v5, Vega-Embed v6 for offline HTML reports.
diff --git a/src/Hanalyze/Viz/Bar.hs b/src/Hanalyze/Viz/Bar.hs
--- a/src/Hanalyze/Viz/Bar.hs
+++ b/src/Hanalyze/Viz/Bar.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.Bar
+-- Description : 棒グラフ (縦・横・積み上げ・グループ化) の可視化
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Bar-chart visualizations.
--
diff --git a/src/Hanalyze/Viz/Core.hs b/src/Hanalyze/Viz/Core.hs
--- a/src/Hanalyze/Viz/Core.hs
+++ b/src/Hanalyze/Viz/Core.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.Core
+-- Description : 全 Viz.* モジュール共有の I/O ヘルパ (writeSpec / openInBrowser / vlJson 等)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Core visualization I/O helpers shared by every @Viz.*@ module.
--
diff --git a/src/Hanalyze/Viz/GP.hs b/src/Hanalyze/Viz/GP.hs
--- a/src/Hanalyze/Viz/GP.hs
+++ b/src/Hanalyze/Viz/GP.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.GP
+-- Description : ガウス過程回帰結果 (訓練データ・事後平均・信用区間) の可視化
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Visualization of Gaussian-process regression results.
--
diff --git a/src/Hanalyze/Viz/GPReport.hs b/src/Hanalyze/Viz/GPReport.hs
--- a/src/Hanalyze/Viz/GPReport.hs
+++ b/src/Hanalyze/Viz/GPReport.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.GPReport
+-- Description : GP 回帰用の統合 HTML レポート (データ特性・モデル比較・回帰結果・対話予測・付録)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Comprehensive HTML report for GP regression.
--
@@ -540,6 +546,16 @@
, " k(x, x') = σ²_f · exp( −2 sin²(π|x−x'|/p) / ℓ² )
"
, " 周期 p の周期的パターンを持つ関数をモデル化します。
"
]
+ kernelDesc Linear =
+ [ " Linear (内積) カーネル
"
+ , " k(x, x') = σ²_f · (x·x')
"
+ , " 線形な関数をモデル化する非定常カーネル。
"
+ ]
+ kernelDesc (Poly d) =
+ [ " Polynomial カーネル (次数 " <> T.pack (show d) <> ")
"
+ , " k(x, x') = (γ·(x·x') + 1)^" <> T.pack (show d) <> " (γ = 1/(2ℓ²))
"
+ , " 多項式の決定境界をモデル化する非定常カーネル。
"
+ ]
appendixHyperparams :: Text
appendixHyperparams = T.unlines
@@ -687,6 +703,8 @@
jsKernelId RBF = "rbf"
jsKernelId Matern52 = "matern52"
jsKernelId Periodic = "periodic"
+jsKernelId Linear = "linear"
+jsKernelId (Poly _) = "poly"
jsParams :: Kernel -> GPParams -> Text
jsParams ker p = "{ell:" <> fmtJS (gpLengthScale p)
diff --git a/src/Hanalyze/Viz/Histogram.hs b/src/Hanalyze/Viz/Histogram.hs
--- a/src/Hanalyze/Viz/Histogram.hs
+++ b/src/Hanalyze/Viz/Histogram.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.Histogram
+-- Description : ヒストグラム描画 (基本ヒストグラム + 理論分布密度の重ね描き)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Histogram plotting.
--
diff --git a/src/Hanalyze/Viz/MCMC.hs b/src/Hanalyze/Viz/MCMC.hs
--- a/src/Hanalyze/Viz/MCMC.hs
+++ b/src/Hanalyze/Viz/MCMC.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.MCMC
+-- Description : Vega-Lite ベースの MCMC 診断プロット (トレース・事後密度・自己相関・forest/energy 等)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | MCMC diagnostic plots (built on Vega-Lite).
--
@@ -37,7 +43,7 @@
import Graphics.Vega.VegaLite
import Hanalyze.MCMC.Core (Chain (..), chainVals)
-import Hanalyze.Stat.MCMC (autocorr, hdi, kde, bfmi)
+import Hanalyze.Stat.MCMC (autocorr, hdi, kde, bfmi, rankHist)
import Hanalyze.Stat.Summary (SummaryRow (..), posteriorSummary)
import Data.List (sortBy)
import Data.Maybe (fromMaybe)
@@ -578,7 +584,7 @@
header = T.unlines
[ " "
, " | Parameter | Mean | SD | "
- , " HDI 3% | HDI 97% | ESS | " <> rhatHeader
+ , " HDI 3% | HDI 97% | ESS (bulk) | " <> rhatHeader
, "
"
]
in T.unlines
@@ -615,27 +621,27 @@
let rows = posteriorSummary params chains
multi = any (\r -> case srRhat r of Just _ -> True; _ -> False) rows
hdr | multi =
- printf "%-12s %10s %10s %10s %10s %6s %6s\n"
+ printf "%-12s %10s %10s %10s %10s %8s %6s\n"
("Parameter" :: String) ("mean" :: String) ("sd" :: String)
("hdi_3%" :: String) ("hdi_97%" :: String)
- ("ess" :: String) ("r_hat" :: String)
+ ("ess_bulk" :: String) ("r_hat" :: String)
| otherwise =
- printf "%-12s %10s %10s %10s %10s %6s\n"
+ printf "%-12s %10s %10s %10s %10s %8s\n"
("Parameter" :: String) ("mean" :: String) ("sd" :: String)
("hdi_3%" :: String) ("hdi_97%" :: String)
- ("ess" :: String)
+ ("ess_bulk" :: String)
pr r
| multi =
let rh = case srRhat r of Just v -> printf "%.3f" v; Nothing -> "—" :: String
- in printf "%-12s %10.4f %10.4f %10.4f %10.4f %6d %6s\n"
+ in printf "%-12s %10.4f %10.4f %10.4f %10.4f %8d %6s\n"
(T.unpack (srName r)) (srMean r) (srSD r)
(srHdiLo r) (srHdiHi r) (round (srEssV r) :: Int) rh
| otherwise =
- printf "%-12s %10.4f %10.4f %10.4f %10.4f %6d\n"
+ printf "%-12s %10.4f %10.4f %10.4f %10.4f %8d\n"
(T.unpack (srName r)) (srMean r) (srSD r)
(srHdiLo r) (srHdiHi r) (round (srEssV r) :: Int)
hdr
- putStrLn (replicate (if multi then 79 else 72) '-')
+ putStrLn (replicate (if multi then 81 else 74) '-')
mapM_ pr rows
-- ---------------------------------------------------------------------------
@@ -656,31 +662,14 @@
nChains = length chains
panel pname =
let perChain = map (chainVals pname) chains
- flat = [ (cid, v)
- | (cid, vs) <- zip [(1 :: Int) ..] perChain
- , v <- vs ]
- n = length flat
- -- 順位 (1..n) を value 昇順に割り当てる
- indexed = zip [(0 :: Int) ..] flat
- sorted = sortBy (\(_, (_, a)) (_, (_, b)) -> compare a b) indexed
- ranked = zipWith (\rk (origIdx, _) -> (origIdx, rk))
- [(1 :: Int) ..] sorted
- rankBy = sortBy (\(a,_) (b,_) -> compare a b) ranked
- ranks = map snd rankBy -- 元 (chain, value) 順序の rank 列
- chainSeq = map fst flat
- binSize = max 1 (n `div` nBins)
- binOf r = min (nBins - 1) ((r - 1) `div` binSize)
- counts = [ ((cid, b), 1 :: Int)
- | (cid, r) <- zip chainSeq ranks
- , let b = binOf r ]
- -- (chain, bin) ごとに集計
- tally = groupAndCount counts
- xs = [ fromIntegral b :: Double
- | (_, b) <- map fst tally ]
- ys = [ fromIntegral c :: Double
- | (_, c) <- tally ]
- chainIds = [ T.pack (show cid)
- | ((cid, _), _) <- tally ]
+ -- rank 正規化ヒストグラムは Stat.MCMC.rankHist に一元化 (Plot 経路と共有)。
+ hists = rankHist nBins perChain -- [chain][bin] (chain は 0-based)
+ triples = [ (cid, b, c)
+ | (cid, cnts) <- zip [(1 :: Int) ..] hists -- 表示は 1-based chain
+ , (b, c) <- zip [(0 :: Int) ..] cnts ]
+ xs = [ fromIntegral b :: Double | (_, b, _) <- triples ]
+ ys = [ fromIntegral c :: Double | (_, _, c) <- triples ]
+ chainIds = [ T.pack (show cid) | (cid, _, _) <- triples ]
in asSpec
[ dataFromColumns []
. dataColumn "bin" (Numbers xs)
@@ -702,16 +691,6 @@
, width (max 60 (plotWidth cfg / fromIntegral nChains))
, height 100
]
-
- groupAndCount :: [((Int, Int), Int)] -> [((Int, Int), Int)]
- groupAndCount xs =
- let mp = foldr (\(k, v) acc -> insertWith (+) k v acc) [] xs
- in mp
- where
- insertWith f k v ((k', v'):rest)
- | k == k' = (k', f v v') : rest
- | otherwise = (k', v') : insertWith f k v rest
- insertWith _ k v [] = [(k, v)]
rankPlotFile :: OutputFormat -> FilePath -> PlotConfig
-> Int -> [Text] -> [Chain] -> IO ()
diff --git a/src/Hanalyze/Viz/ModelGraph.hs b/src/Hanalyze/Viz/ModelGraph.hs
--- a/src/Hanalyze/Viz/ModelGraph.hs
+++ b/src/Hanalyze/Viz/ModelGraph.hs
@@ -1,9 +1,45 @@
+-- |
+-- Module : Hanalyze.Viz.ModelGraph
+-- Description : モデル DAG の Mermaid.js 可視化 (ModelGraph → HTML)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Mermaid.js visualization of model DAGs.
--
-- Renders the 'ModelGraph' that 'Hanalyze.Model.HBM.buildModelGraph' derives
-- automatically from a polymorphic model into an HTML file (displayed
-- in the browser via the Mermaid CDN).
+--
+-- == 3 ルートの選び方 (= hgg Phase 2 で 3 ルート併存方針確立)
+--
+-- 同じ 'Hanalyze.Model.HBM.ModelGraph' を可視化する 3 種類のルート:
+--
+-- +---------------+--------------------------------------------------+---------------------+-----------------------+
+-- | ルート | 場所 | 出力 / 描画依存 | 推奨用途 |
+-- +===============+==================================================+=====================+=======================+
+-- | __本 module__ | 'renderModelGraph' (= Mermaid HTML) | .html + CDN script | GitHub README、 ノート |
+-- +---------------+--------------------------------------------------+---------------------+-----------------------+
+-- | Graphviz DOT | "Hanalyze.Viz.ModelGraphDot".renderModelGraphDot | .dot + dot CLI 別途 | graphviz 連携、 加工 |
+-- +---------------+--------------------------------------------------+---------------------+-----------------------+
+-- | hgg | @Hgg.Plot.Bridge.Analyze.renderModelGraphSVG@| .svg (依存ゼロ) | production、 offline |
+-- | | (= @hgg-analyze-bridge@ package) | | |
+-- +---------------+--------------------------------------------------+---------------------+-----------------------+
+--
+-- 3 ルートとも同じ 'Hanalyze.Model.HBM.ModelGraph' 構造 (= node / edge / plate)
+-- を表現する。 visual layout は実装ごとに異なる。 本ルート (= Mermaid) の利点:
+--
+-- * GitHub / GitLab README で render される (= 添付画像不要、 文字列で済む)
+-- * ノート系 tool (= Notion 等) に貼り付けやすい
+-- * 軽量 (= .html 1 ファイル、 ~5KB)
+--
+-- 弱点 (= 上記表の他ルートで補える):
+--
+-- * ブラウザ + ネット必須 (= offline 不可)
+-- * production アプリ組込みには不向き (= hgg ルート推奨)
+-- * 高度な layout (= graphviz dot 流) には不向き (= ModelGraphDot 推奨)
+--
+-- __本 module は撤廃されません__。 OSS 利用者の既存ワークフローを尊重して 3 ルート併存。
module Hanalyze.Viz.ModelGraph
( renderModelGraph
, buildMermaid
@@ -13,6 +49,9 @@
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.Set as Set
+import qualified Data.Map.Strict as Map
+import Data.List (groupBy, sortOn)
+import Data.Function (on)
import Hanalyze.Model.HBM (ModelGraph (..), Node (..), NodeKind (..))
@@ -65,10 +104,12 @@
-- ---------------------------------------------------------------------------
-- | Build the Mermaid @flowchart TD@ source for a 'ModelGraph'.
+-- Phase 40: plate に属するノードは @subgraph plate_[" × N"]@
+-- で囲まれる。 nested plate も入れ子で出力。
buildMermaid :: ModelGraph -> Text
buildMermaid mg = T.unlines $
[ "flowchart TD" ] ++
- map mkNodeLine (mgNodes mg) ++
+ renderNodesGrouped 1 [] (mgNodes mg) (mgPlates mg) ++
[ "" ] ++
map mkEdgeLine (mgEdges mg) ++
[ "" ] ++
@@ -76,6 +117,44 @@
[ " classDef observed fill:#DD8844,color:#fff,stroke:#b06020,stroke-width:1.5px" ] ++
classAssignLines mg
+-- | nodePlates のスタックに沿って nodes をグルーピングし、 nested
+-- subgraph を出力する。 'depth' はインデント用。 'curPath' は現在
+-- 出力中の plate path (外→内)。
+renderNodesGrouped :: Int -> [Text] -> [Node] -> Map.Map Text Int -> [Text]
+renderNodesGrouped depth curPath ns plateSizes =
+ let ind = T.replicate (depth * 4) " "
+ -- 現位置に属する (= nodePlates == curPath) ノードを直接出力
+ hereNodes = [n | n <- ns, nodePlates n == curPath]
+ -- このスコープより内側 (= nodePlates が curPath で始まる かつ より長い) を集める
+ innerNodes = [n | n <- ns, isStrictPrefix curPath (nodePlates n)]
+ -- innerNodes を「curPath の直後の plate 名」 でグループ化
+ keyOf n = (nodePlates n) !! length curPath
+ sortedInner = sortOn keyOf innerNodes
+ grouped = groupBy ((==) `on` keyOf) sortedInner
+ hereLines = map (\n -> ind <> mkNodeLine n) hereNodes
+ innerLines = concatMap (renderPlateGroup depth curPath plateSizes) grouped
+ in hereLines ++ innerLines
+
+renderPlateGroup :: Int -> [Text] -> Map.Map Text Int -> [Node] -> [Text]
+renderPlateGroup _ _ _ [] = []
+renderPlateGroup depth curPath plateSizes ns@(n0:_) =
+ let plateName = (nodePlates n0) !! length curPath
+ sz = Map.findWithDefault 0 plateName plateSizes
+ ind = T.replicate (depth * 4) " "
+ header = ind <> "subgraph plate_" <> sanitize plateName
+ <> "[\"" <> plateName <> " × " <> T.pack (show sz) <> "\"]"
+ footer = ind <> "end"
+ inner = renderNodesGrouped (depth + 1) (curPath ++ [plateName])
+ ns plateSizes
+ in [header] ++ inner ++ [footer]
+
+isStrictPrefix :: Eq a => [a] -> [a] -> Bool
+isStrictPrefix prefix xs =
+ length prefix < length xs && take (length prefix) xs == prefix
+
+sanitize :: Text -> Text
+sanitize = T.map (\c -> if c `elem` (" -.+*/" :: String) then '_' else c)
+
mkNodeLine :: Node -> Text
mkNodeLine n = " " <> nid <> shapeOpen <> escaped <> shapeClose
where
@@ -87,10 +166,16 @@
else " (deps: " <> T.intercalate "," (Set.toList (nodeDeps n)) <> ")")
ObservedN k -> nodeName n <> "\\n" <> nodeDist n
<> " (n=" <> T.pack (show k) <> ")"
+ -- Phase 60.4: DeterministicN は従来非網羅 (deterministic を含むモデルで
+ -- crash・ModelGraphDot の Phase 59.2 と同類) だったのを同時修正。
+ DeterministicN -> nodeName n <> "\\n" <> nodeDist n
+ DataN k -> nodeName n <> "\\n(n=" <> T.pack (show k) <> ")"
escaped = T.replace "\"" """ label
(shapeOpen, shapeClose) = case nodeKind n of
LatentN -> ("[\"", "\"]")
ObservedN _ -> ("([\"", "\"])")
+ DeterministicN -> ("[\"", "\"]")
+ DataN _ -> ("(\"", "\")")
mkEdgeLine :: (Text, Text) -> Text
mkEdgeLine (from, to) = " " <> nodeId from <> " --> " <> nodeId to
diff --git a/src/Hanalyze/Viz/ModelGraphDot.hs b/src/Hanalyze/Viz/ModelGraphDot.hs
new file mode 100644
--- /dev/null
+++ b/src/Hanalyze/Viz/ModelGraphDot.hs
@@ -0,0 +1,166 @@
+-- |
+-- Module : Hanalyze.Viz.ModelGraphDot
+-- Description : モデル DAG の Graphviz DOT 出力 (PyMC model_to_graphviz 同等の plate 描画)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
+{-# LANGUAGE OverloadedStrings #-}
+-- | Graphviz DOT 出力 (Phase 40-A3、 PyMC @pm.model_to_graphviz@ 同等の plate 描画)。
+--
+-- 'Hanalyze.Model.HBM.buildModelGraph' が出す 'ModelGraph' を DOT
+-- ソースに変換する。 plate は @subgraph cluster_@ + @label=" × N"@
+-- (右下サイズ数字) で囲まれ、 PyMC 流の角丸長方形描画になる。
+--
+-- 使い方:
+--
+-- > let g = HBM.buildModelGraph m
+-- > let dot = renderModelGraphDot g
+-- > T.writeFile "model.dot" dot
+-- > -- graphviz CLI で PNG / SVG 化:
+-- > -- $ dot -Tpng model.dot -o model.png
+--
+-- == 3 ルートの選び方 (= hgg Phase 2 で 3 ルート併存方針確立)
+--
+-- 同じ 'Hanalyze.Model.HBM.ModelGraph' を可視化する 3 種類のルート:
+--
+-- +---------------+--------------------------------------------------+---------------------+-----------------------+
+-- | ルート | 場所 | 出力 / 描画依存 | 推奨用途 |
+-- +===============+==================================================+=====================+=======================+
+-- | Mermaid HTML | "Hanalyze.Viz.ModelGraph".renderModelGraph | .html + CDN script | GitHub README、 ノート |
+-- +---------------+--------------------------------------------------+---------------------+-----------------------+
+-- | __本 module__ | 'renderModelGraphDot' (= Graphviz DOT) | .dot + dot CLI 別途 | graphviz 連携、 加工 |
+-- +---------------+--------------------------------------------------+---------------------+-----------------------+
+-- | hgg | @Hgg.Plot.Bridge.Analyze.renderModelGraphSVG@| .svg (依存ゼロ) | production、 offline |
+-- | | (= @hgg-analyze-bridge@ package) | | |
+-- +---------------+--------------------------------------------------+---------------------+-----------------------+
+--
+-- 3 ルートとも同じ 'Hanalyze.Model.HBM.ModelGraph' 構造 (= node / edge / plate)
+-- を表現する。 visual layout は実装ごとに異なる。 本ルート (= Graphviz DOT) の利点:
+--
+-- * graphviz dot の高品質 layout (= Sugiyama framework 本家、 数十年の蓄積)
+-- * @-Tpng@ @-Tsvg@ @-Tpdf@ @-Tps@ 等 多 format 出力
+-- * @rank=same@ @constraint=false@ @cluster@ 等 dot 固有 directive で細かい制御
+-- * 既存 graphviz エコシステム (= xdot、 gephi 等) と連携
+--
+-- 弱点 (= 上記表の他ルートで補える):
+--
+-- * @dot@ CLI が install 済必須 (= production 配布で外部依存)
+-- * 出力は .dot text 中間ファイル (= 描画は別 step、 pipeline 化必要)
+--
+-- __本 module は撤廃されません__。 OSS 利用者の既存ワークフローを尊重して 3 ルート併存。
+module Hanalyze.Viz.ModelGraphDot
+ ( renderModelGraphDot
+ , writeModelGraphDot
+ ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import qualified Data.Set as Set
+import qualified Data.Map.Strict as Map
+import Data.List (groupBy, sortOn)
+import Data.Function (on)
+
+import Hanalyze.Model.HBM (ModelGraph (..), Node (..), NodeKind (..))
+
+-- ---------------------------------------------------------------------------
+-- Public API
+-- ---------------------------------------------------------------------------
+
+-- | 'ModelGraph' を Graphviz DOT 形式の 'Text' に変換する。
+renderModelGraphDot :: ModelGraph -> Text
+renderModelGraphDot mg = T.unlines $
+ [ "digraph G {"
+ , " rankdir=TB;"
+ , " node [fontname=\"sans-serif\", fontsize=10];"
+ , " edge [arrowsize=0.7];"
+ , ""
+ ] ++
+ renderNodesGrouped 1 [] (mgNodes mg) (mgPlates mg) ++
+ [ "" ] ++
+ map mkEdgeLine (mgEdges mg) ++
+ [ "}" ]
+
+-- | DOT をファイルに書き出す利便 helper。
+writeModelGraphDot :: FilePath -> ModelGraph -> IO ()
+writeModelGraphDot path mg = TIO.writeFile path (renderModelGraphDot mg)
+
+-- ---------------------------------------------------------------------------
+-- Node grouping by plate (nested cluster)
+-- ---------------------------------------------------------------------------
+
+renderNodesGrouped :: Int -> [Text] -> [Node] -> Map.Map Text Int -> [Text]
+renderNodesGrouped depth curPath ns plateSizes =
+ let ind = T.replicate (depth * 4) " "
+ hereNodes = [n | n <- ns, nodePlates n == curPath]
+ innerNodes = [n | n <- ns, isStrictPrefix curPath (nodePlates n)]
+ keyOf n = (nodePlates n) !! length curPath
+ sortedInner = sortOn keyOf innerNodes
+ grouped = groupBy ((==) `on` keyOf) sortedInner
+ hereLines = map (\n -> ind <> mkNodeLine n) hereNodes
+ innerLines = concatMap (renderPlateGroup depth curPath plateSizes) grouped
+ in hereLines ++ innerLines
+
+renderPlateGroup :: Int -> [Text] -> Map.Map Text Int -> [Node] -> [Text]
+renderPlateGroup _ _ _ [] = []
+renderPlateGroup depth curPath plateSizes ns@(n0:_) =
+ let plateName = (nodePlates n0) !! length curPath
+ sz = Map.findWithDefault 0 plateName plateSizes
+ ind = T.replicate (depth * 4) " "
+ header = ind <> "subgraph cluster_" <> sanitize plateName <> " {"
+ label = ind <> " label=\"" <> plateName <> " × "
+ <> T.pack (show sz) <> "\";"
+ style = ind <> " style=\"rounded\";"
+ labelloc = ind <> " labelloc=\"b\";" -- 下に表示 (PyMC 流)
+ footer = ind <> "}"
+ inner = renderNodesGrouped (depth + 1) (curPath ++ [plateName])
+ ns plateSizes
+ in [header, label, style, labelloc] ++ inner ++ [footer]
+
+isStrictPrefix :: Eq a => [a] -> [a] -> Bool
+isStrictPrefix prefix xs =
+ length prefix < length xs && take (length prefix) xs == prefix
+
+-- ---------------------------------------------------------------------------
+-- Node / Edge rendering
+-- ---------------------------------------------------------------------------
+
+mkNodeLine :: Node -> Text
+mkNodeLine n =
+ let nid = nodeId (nodeName n)
+ label = case nodeKind n of
+ LatentN -> nodeName n <> "\\n" <> nodeDist n
+ ObservedN k -> nodeName n <> "\\n" <> nodeDist n
+ <> "\\n(n=" <> T.pack (show k) <> ")"
+ DeterministicN -> nodeName n <> "\\n" <> nodeDist n
+ -- Phase 60.4: データ slot は名前 + 長さのみ (分布を持たない)
+ DataN k -> nodeName n <> "\\n(n=" <> T.pack (show k) <> ")"
+ escaped = T.replace "\"" """ label
+ attrs = case nodeKind n of
+ -- 潜在: 楕円・白塗り
+ LatentN -> "label=\"" <> escaped <> "\", shape=ellipse"
+ -- 観測: 楕円・灰色塗り (PyMC 流)
+ ObservedN _ -> "label=\"" <> escaped <> "\", shape=ellipse, "
+ <> "style=filled, fillcolor=lightgray"
+ -- 決定的変換: 四角・白塗り (PyMC の Deterministic 流)
+ DeterministicN -> "label=\"" <> escaped <> "\", shape=box"
+ -- データ slot (pm.Data 相当): 角丸四角・灰塗り (PyMC ConstantData 流)
+ DataN _ -> "label=\"" <> escaped <> "\", shape=box, "
+ <> "style=\"rounded,filled\", fillcolor=lightgray"
+ in nid <> " [" <> attrs <> "];"
+
+mkEdgeLine :: (Text, Text) -> Text
+mkEdgeLine (from, to) = " " <> nodeId from <> " -> " <> nodeId to <> ";"
+
+-- ---------------------------------------------------------------------------
+-- Helpers
+-- ---------------------------------------------------------------------------
+
+nodeId :: Text -> Text
+nodeId = T.map (\c -> if c `elem` (" -.+*/" :: String) then '_' else c)
+
+sanitize :: Text -> Text
+sanitize = nodeId
+
+_unused :: Set.Set Text -> Set.Set Text
+_unused = id
diff --git a/src/Hanalyze/Viz/Pareto.hs b/src/Hanalyze/Viz/Pareto.hs
--- a/src/Hanalyze/Viz/Pareto.hs
+++ b/src/Hanalyze/Viz/Pareto.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.Pareto
+-- Description : パレートフロント可視化 (散布・pairs・parallel coordinates・hypervolume 推移・比較)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Pareto-front visualizations (130 規約: PlotData ベース).
--
diff --git a/src/Hanalyze/Viz/PlotConfig.hs b/src/Hanalyze/Viz/PlotConfig.hs
--- a/src/Hanalyze/Viz/PlotConfig.hs
+++ b/src/Hanalyze/Viz/PlotConfig.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.PlotConfig
+-- Description : 全 Viz.* モジュール共有のプロット設定 (PlotConfig / defaultConfig) を定義
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Common plot configuration shared by every @Hanalyze.Viz.*@ module.
--
diff --git a/src/Hanalyze/Viz/PlotData.hs b/src/Hanalyze/Viz/PlotData.hs
--- a/src/Hanalyze/Viz/PlotData.hs
+++ b/src/Hanalyze/Viz/PlotData.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.PlotData
+-- Description : プロットデータの入力元非依存な中間表現 (PlotData / ToPlotData)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Source-agnostic intermediate representation for plot data.
--
diff --git a/src/Hanalyze/Viz/PlotData/DataFrame.hs b/src/Hanalyze/Viz/PlotData/DataFrame.hs
--- a/src/Hanalyze/Viz/PlotData/DataFrame.hs
+++ b/src/Hanalyze/Viz/PlotData/DataFrame.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.PlotData.DataFrame
+-- Description : Hackage dataframe 用の ToPlotData インスタンス (数値/テキスト列を PlotData に変換)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | 'ToPlotData' instance for Hackage @dataframe@.
@@ -20,7 +26,7 @@
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Vector as V
-import qualified DataFrame as DX
+import qualified DataFrame.Internal.DataFrame as DX
import Hanalyze.DataIO.Convert (getDoubleVec, getTextVec)
import Hanalyze.Viz.PlotData (PlotData (..), ToPlotData (..),
diff --git a/src/Hanalyze/Viz/Report.hs b/src/Hanalyze/Viz/Report.hs
--- a/src/Hanalyze/Viz/Report.hs
+++ b/src/Hanalyze/Viz/Report.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.Report
+-- Description : MCMC 結果の統合 HTML レポート (モデル DAG・事後要約表・診断プロット・pairs 散布図)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Integrated HTML report for MCMC results.
--
@@ -28,7 +34,6 @@
import Hanalyze.Model.HBM (ModelGraph)
import Hanalyze.MCMC.Core (Chain (..), chainVals, posteriorMean, posteriorSD, posteriorQuantile)
-import Hanalyze.Stat.MCMC (ess, rhat)
import Hanalyze.Stat.Summary (SummaryRow (..), posteriorSummary)
import Hanalyze.Viz.Assets (vegaJS, vegaLiteJS, vegaEmbedJS)
import Hanalyze.Viz.MCMC (mcmcDiagnostics, mcmcDiagnosticsMulti, autocorrPlot, pairScatter)
@@ -262,7 +267,7 @@
, " "
, " "
, " | Parameter | Mean | SD | "
- , " HDI 3% | HDI 97% | ESS | " <> rhatHeader
+ , " HDI 3% | HDI 97% | ESS (bulk) | " <> rhatHeader
, "
"
, " "
, T.concat (map tableRow rows)
diff --git a/src/Hanalyze/Viz/ReportBuilder.hs b/src/Hanalyze/Viz/ReportBuilder.hs
--- a/src/Hanalyze/Viz/ReportBuilder.hs
+++ b/src/Hanalyze/Viz/ReportBuilder.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.ReportBuilder
+-- Description : 全モデル/解析種別共通の合成型 HTML レポートビルダー (ReportSection / Reportable)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Compositional HTML report builder.
--
@@ -116,7 +122,7 @@
import qualified Data.Vector as V
import Text.Printf (printf)
-import qualified DataFrame as DX
+import qualified DataFrame.Operations.Core as DX
import qualified DataFrame.Internal.DataFrame as DXD
import Hanalyze.DataIO.Convert (getDoubleVec, getTextVec)
import Hanalyze.MCMC.Core (Chain)
diff --git a/src/Hanalyze/Viz/ReportInstances.hs b/src/Hanalyze/Viz/ReportInstances.hs
--- a/src/Hanalyze/Viz/ReportInstances.hs
+++ b/src/Hanalyze/Viz/ReportInstances.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.ReportInstances
+-- Description : 各種フィット結果型に対する Reportable インスタンス集
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | 'Hanalyze.Viz.ReportBuilder.Reportable' instances for the various fit types.
@@ -19,7 +25,7 @@
-- 提供されるインスタンス:
-- - 'RegFit' (Hanalyze.Model.Regularized) — 正則化線形回帰
-- - 'SplineFit' (Hanalyze.Model.Spline) — B-spline / Natural cubic
--- - 'KernelRidgeFit' (Hanalyze.Model.Kernel) — Kernel Ridge regression
+-- - 'KernelRidgeFit' (Hanalyze.Model.KernelRegression) — Kernel Ridge regression
-- - 'RFFRidgeFit' (Hanalyze.Model.RFF) — Random Fourier Features Ridge
-- - 'RobustGPFit' (Hanalyze.Model.GPRobust) — ロバスト GP
--
@@ -56,7 +62,7 @@
import Hanalyze.Model.GLM (Family (..), LinkFn (..))
import Hanalyze.Model.Regularized (RegFit (..), Penalty (..), predictRegularized)
import Hanalyze.Model.Spline (SplineFit (..), SplineKind (..), predictSpline, sfBeta)
-import Hanalyze.Model.Kernel (KernelRidgeFit (..), predictKernelRidge)
+import Hanalyze.Model.KernelRegression (KernelRidgeFit (..), predictKernelRidge)
import Hanalyze.Model.RFF (RFFRidgeFit (..), predictRFFRidge, rffrFeatures,
rffSigmaF, rffLengthScale, rffOmegas,
RFFRidgeFitMV (..), RFFFeaturesMV (..),
diff --git a/src/Hanalyze/Viz/Scatter.hs b/src/Hanalyze/Viz/Scatter.hs
--- a/src/Hanalyze/Viz/Scatter.hs
+++ b/src/Hanalyze/Viz/Scatter.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.Scatter
+-- Description : 散布図とその重ね描き (回帰直線/平滑化・グループ別・予測 vs 実測)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | Scatter plots and overlays.
--
diff --git a/src/Hanalyze/Viz/Taguchi.hs b/src/Hanalyze/Viz/Taguchi.hs
--- a/src/Hanalyze/Viz/Taguchi.hs
+++ b/src/Hanalyze/Viz/Taguchi.hs
@@ -1,3 +1,9 @@
+-- |
+-- Module : Hanalyze.Viz.Taguchi
+-- Description : 田口メソッド解析結果の HTML レポート (SN 比・主効果・最適水準)
+-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
+-- License : BSD-3-Clause
+--
{-# LANGUAGE OverloadedStrings #-}
-- | HTML report for Taguchi-method analysis.
--
diff --git a/test/Hanalyze/Data/FactorSpec.hs b/test/Hanalyze/Data/FactorSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Data/FactorSpec.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Hanalyze.Data.Factor の HSpec (Phase 28 Ch16 "Factors")。
+-- R4DS Ch16 / forcats の挙動を一次根拠に Factor 型の生成・参照を固定する。
+module Hanalyze.Data.FactorSpec (spec) where
+
+import Test.Hspec
+import qualified Data.List
+import qualified Data.Vector.Unboxed as VU
+import Hanalyze.Data.Factor
+
+spec :: Spec
+spec = describe "Data.Factor (A2: 生成 / 参照)" $ do
+
+ describe "factor (R factor() 既定 = ソート済 unique)" $ do
+ it "水準は値のソート済 unique" $
+ levels (factor ["Dec", "Apr", "Jan", "Mar"]) `shouldBe` ["Apr", "Dec", "Jan", "Mar"]
+ it "重複は 1 水準に畳む" $
+ levels (factor ["a", "b", "a", "c", "b"]) `shouldBe` ["a", "b", "c"]
+ it "コードは 0 始まりで水準 index を指す" $
+ facCodes (factor ["b", "a", "b"]) `shouldBe` VU.fromList [1, 0, 1]
+
+ describe "factorWith (水準明示)" $ do
+ it "指定 levels の順序を保つ (sort しない)" $ do
+ let f = factorWith ["Jan", "Feb", "Mar"] ["Mar", "Jan", "Mar"]
+ levels f `shouldBe` ["Jan", "Feb", "Mar"]
+ facCodes f `shouldBe` VU.fromList [2, 0, 2]
+ it "levels に無い値は NA (naCode)" $
+ facCodes (factorWith ["a", "b"] ["a", "z", "b"]) `shouldBe` VU.fromList [0, naCode, 1]
+
+ describe "fct (forcats fct() = 出現順 unique)" $
+ it "水準は出現順 (factor() の sort と異なる)" $
+ levels (fct ["Dec", "Apr", "Jan", "Mar"]) `shouldBe` ["Dec", "Apr", "Jan", "Mar"]
+
+ describe "ordered (R ordered())" $ do
+ it "順序付きフラグが立つ" $
+ isOrdered (ordered ["lo", "mid", "hi"] ["mid", "hi"]) `shouldBe` True
+ it "factor は既定で非順序" $
+ isOrdered (factor ["a", "b"]) `shouldBe` False
+
+ describe "asTexts / asTextsMaybe (as.character())" $ do
+ it "コードをラベルに復元" $
+ asTexts (factorWith ["a", "b", "c"] ["c", "a", "b"]) `shouldBe` ["c", "a", "b"]
+ it "NA は asTexts で \"\"・asTextsMaybe で Nothing" $ do
+ let f = factorWith ["a", "b"] ["a", "z"]
+ asTexts f `shouldBe` ["a", ""]
+ asTextsMaybe f `shouldBe` [Just "a", Nothing]
+
+ describe "fctCount (dplyr count())" $ do
+ it "水準順に頻度・0 件水準も含む" $
+ fctCount (factorWith ["a", "b", "c"] ["a", "a", "c"])
+ `shouldBe` [("a", 2), ("b", 0), ("c", 1)]
+ it "NA は集計から除外" $
+ fctCount (factorWith ["a", "b"] ["a", "z", "b", "a"])
+ `shouldBe` [("a", 2), ("b", 1)]
+
+ -- A3: 順序操作 (16.4) ----------------------------------------------------
+ describe "fctReorder (fct_reorder = x の集約値で昇順)" $ do
+ it "各水準の x 集約値の昇順に並べ替える (観測は不変)" $ do
+ -- a→[3], b→[1], c→[2] : 集約 (median 相当=identity) 昇順は b,c,a
+ let f = factorWith ["a", "b", "c"] ["a", "b", "c"]
+ f' = fctReorder medianD f [3, 1, 2]
+ levels f' `shouldBe` ["b", "c", "a"]
+ -- どの観測がどの水準かは保存される
+ asTexts f' `shouldBe` ["a", "b", "c"]
+ it "1 水準に複数値があれば集約関数を適用" $
+ levels (fctReorder medianD (factorWith ["a", "b"] ["a", "a", "b"]) [10, 20, 5])
+ `shouldBe` ["b", "a"] -- a の median 15 > b の 5
+
+ describe "fctRelevel (fct_relevel = 指定水準を先頭)" $ do
+ it "指定水準を先頭へ・残りは相対順序保持" $
+ levels (fctRelevel ["c"] (factorWith ["a", "b", "c", "d"] []))
+ `shouldBe` ["c", "a", "b", "d"]
+ it "複数指定は指定順で先頭に並ぶ" $
+ levels (fctRelevel ["d", "b"] (factorWith ["a", "b", "c", "d"] []))
+ `shouldBe` ["d", "b", "a", "c"]
+ it "存在しない水準名は無視" $
+ levels (fctRelevel ["z", "b"] (factorWith ["a", "b", "c"] []))
+ `shouldBe` ["b", "a", "c"]
+
+ describe "fctReorder2 (fct_reorder2 = 最大 x での y で降順)" $
+ it "各水準の最大 x に対応する y の降順" $ do
+ -- a: x=[1,3] y=[9,1] → max x=3 の y=1 ; b: x=[2] y=[5] → 5
+ let f = factorWith ["a", "b"] ["a", "a", "b"]
+ levels (fctReorder2 f [1, 3, 2] [9, 1, 5]) `shouldBe` ["b", "a"]
+
+ describe "fctInfreq (fct_infreq = 頻度降順)" $ do
+ it "出現頻度の降順" $
+ levels (fctInfreq (factorWith ["a", "b", "c"] ["a", "b", "b", "c", "c", "c"]))
+ `shouldBe` ["c", "b", "a"]
+ it "同頻度は元の水準順を保つ (安定)" $
+ levels (fctInfreq (factorWith ["a", "b", "c"] ["a", "b", "c"]))
+ `shouldBe` ["a", "b", "c"]
+
+ describe "fctRev (fct_rev = 水準逆順)" $
+ it "水準を逆順にする (観測は不変)" $ do
+ let f' = fctRev (factorWith ["a", "b", "c"] ["a", "c"])
+ levels f' `shouldBe` ["c", "b", "a"]
+ asTexts f' `shouldBe` ["a", "c"]
+
+ -- A4: 水準操作 (16.5) ----------------------------------------------------
+ describe "fctRecode (fct_recode = ラベル改名)" $ do
+ it "ラベルを改名・未言及は不変・順序保持" $ do
+ let f' = fctRecode [("A", "a"), ("C", "c")] (factorWith ["a", "b", "c"] ["a", "b", "c"])
+ levels f' `shouldBe` ["A", "b", "C"]
+ asTexts f' `shouldBe` ["A", "b", "C"]
+ it "複数の旧を同じ新に向けると併合される" $ do
+ let f' = fctRecode [("X", "a"), ("X", "b")] (factorWith ["a", "b", "c"] ["a", "b", "c", "a"])
+ levels f' `shouldBe` ["X", "c"]
+ asTexts f' `shouldBe` ["X", "X", "c", "X"]
+
+ describe "fctCollapse (fct_collapse = 複数水準を併合)" $
+ it "(新,[旧]) で併合・未言及は残す" $ do
+ let f' = fctCollapse [("other", ["b", "c"])] (factorWith ["a", "b", "c", "d"] ["a", "b", "c", "d"])
+ levels f' `shouldBe` ["a", "other", "d"]
+ asTexts f' `shouldBe` ["a", "other", "other", "d"]
+
+ describe "fctLumpN (fct_lump_n = 上位 n 残し他を Other)" $ do
+ it "上位 n 水準を残し他を Other (末尾)" $ do
+ -- 頻度: a=3,b=2,c=1,d=1 → 上位2 = a,b
+ let f = factorWith ["a", "b", "c", "d"] ["a", "a", "a", "b", "b", "c", "d"]
+ f' = fctLumpN 2 f
+ levels f' `shouldBe` ["a", "b", "Other"]
+ fctCount f' `shouldBe` [("a", 3), ("b", 2), ("Other", 2)]
+ it "n が水準数以上なら Other を作らない" $
+ levels (fctLumpN 9 (factorWith ["a", "b"] ["a", "b"])) `shouldBe` ["a", "b"]
+
+ describe "fctLumpMin (fct_lump_min = 回数 10 で cut=1、b,c,d を Other(=10<100)
+ let f = factorWith ["a", "b", "c", "d"]
+ (replicate 100 "a" ++ replicate 5 "b" ++ replicate 3 "c" ++ replicate 2 "d")
+ f' = fctLumpLowfreq f
+ levels f' `shouldBe` ["a", "Other"]
+ fctCount f' `shouldBe` [("a", 100), ("Other", 10)]
+
+-- | テスト用 median (偶数個は中央 2 値平均)。
+medianD :: [Double] -> Double
+medianD xs =
+ let s = Data.List.sort xs
+ n = length s
+ in if odd n then s !! (n `div` 2)
+ else (s !! (n `div` 2 - 1) + s !! (n `div` 2)) / 2
diff --git a/test/Hanalyze/Data/StringsSpec.hs b/test/Hanalyze/Data/StringsSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Data/StringsSpec.hs
@@ -0,0 +1,219 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Hanalyze.Data.Strings の HSpec (Phase 28 Ch14)。
+-- R4DS Ch14 の例を一次根拠に str_* の挙動を固定する。
+module Hanalyze.Data.StringsSpec (spec) where
+
+import Test.Hspec
+import Control.Exception (evaluate)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified DataFrame.Internal.Column as DF
+import qualified DataFrame.Internal.DataFrame as DF
+import qualified DataFrame.Operations.Core as DF
+import Hanalyze.Data.Strings
+import Hanalyze.DataIO.Convert (getMaybeTextVec)
+
+-- | 純粋値を spine + 要素まで強制して error を IO に持ち上げる (deepseq 非依存)。
+forceStrs :: [a] -> (a -> Int) -> IO Int
+forceStrs xs f = evaluate (sum (map f xs))
+
+-- | DataFrame の列を @[Maybe Text]@ で読み戻す (テスト検証用)。
+colMT :: Text -> DF.DataFrame -> [Maybe Text]
+colMT c d = maybe (error ("no col " ++ T.unpack c)) V.toList (getMaybeTextVec c d)
+
+spec :: Spec
+spec = do
+ describe "strLength / strSub (str_length / str_sub)" $ do
+ it "strLength = 文字数" $ do
+ strLength "Apple" `shouldBe` 5
+ strLength "" `shouldBe` 0
+ it "strSub: 1 始まり両端含む" $
+ strSub 1 3 "Apple" `shouldBe` "App"
+ it "strSub: 負 index は末尾から" $ do
+ strSub (-3) (-1) "Apple" `shouldBe` "ple"
+ strSub (-1) (-1) "Apple" `shouldBe` "e" -- last char (R4DS 14.5.2)
+ strSub 1 1 "Apple" `shouldBe` "A" -- first char
+ it "strSub: 範囲外はクリップ・逆転は空" $ do
+ strSub 1 100 "Pear" `shouldBe` "Pear"
+ strSub 3 2 "Pear" `shouldBe` ""
+
+ describe "strC / strCMaybe (str_c・recycling + NA)" $ do
+ it "リテラル + 列の recycling" $
+ strC [["Hello "], ["Flora","David","Terra"], ["!"]]
+ `shouldBe` ["Hello Flora!","Hello David!","Hello Terra!"]
+ it "NA 伝播 (R4DS 14.3.1: NA を含む name)" $
+ strCMaybe [[Just "Hello "], [Just "Flora", Nothing, Just "Terra"], [Just "!"]]
+ `shouldBe` [Just "Hello Flora!", Nothing, Just "Hello Terra!"]
+ it "長さ不整合は error" $
+ forceStrs (strC [["a","b"], ["x","y","z"]]) strLength `shouldThrow` anyErrorCall
+
+ describe "strFlatten (str_flatten)" $
+ it "collapse で結合" $
+ strFlatten ", " ["a","b","c"] `shouldBe` "a, b, c"
+
+ describe "strGlue (str_glue)" $ do
+ it "{key} を列で置換 (R4DS 14.3.2)" $
+ strGlue "Hello {name}!" [("name", ["Flora","David"])]
+ `shouldBe` ["Hello Flora!","Hello David!"]
+ it "複数 placeholder + リテラル" $
+ strGlue "{a}-{b}" [("a",["1","2"]),("b",["x","y"])]
+ `shouldBe` ["1-x","2-y"]
+ it "{{ }} はリテラル波括弧" $
+ strGlue "{{x}}" [] `shouldBe` ["{x}"]
+ it "未知 key は error" $
+ forceStrs (strGlue "{z}" [("a",["1"])]) strLength `shouldThrow` anyErrorCall
+
+ describe "strToUpper / strSort" $ do
+ it "大文字化" $
+ strToUpper "abc" `shouldBe` "ABC"
+ it "既定 (コードポイント) 昇順" $
+ strSort ["banana","apple","cherry"] `shouldBe` ["apple","banana","cherry"]
+
+ describe "separateLongerDelim / separateLongerPosition (§14.4.1)" $ do
+ let df = DF.fromNamedColumns
+ [ ("x", DF.fromList ["a,b,c","d,e","f" :: Text])
+ , ("id", DF.fromList ["r1","r2","r3" :: Text]) ]
+ it "delim: 1 行→複数行に展開し他列を複製 (R4DS df1)" $ do
+ let out = separateLongerDelim "x" "," df
+ DF.dimensions out `shouldBe` (6, 2)
+ colMT "x" out `shouldBe` map Just ["a","b","c","d","e","f"]
+ colMT "id" out `shouldBe` map Just ["r1","r1","r1","r2","r2","r3"]
+ it "delim: NA (Nothing) は分割せず 1 行保持" $ do
+ let dfn = DF.fromNamedColumns
+ [("x", DF.fromList [Just "a,b", Nothing, Just "c" :: Maybe Text])]
+ out = separateLongerDelim "x" "," dfn
+ DF.dimensions out `shouldBe` (4, 1)
+ colMT "x" out `shouldBe` [Just "a", Just "b", Nothing, Just "c"]
+ it "position: width=1 で各文字を 1 行に (R4DS df3)" $ do
+ let df3 = DF.fromNamedColumns [("x", DF.fromList ["1211","131","21" :: Text])]
+ out = separateLongerPosition "x" 1 df3
+ DF.dimensions out `shouldBe` (9, 1)
+ colMT "x" out `shouldBe` map (Just . T.singleton) "121113121"
+ it "position: width=2 で 2 文字塊・端数は短い塊" $ do
+ let df4 = DF.fromNamedColumns [("x", DF.fromList ["abcde","fg" :: Text])]
+ out = separateLongerPosition "x" 2 df4
+ colMT "x" out `shouldBe` map Just ["ab","cd","e","fg"]
+
+ describe "strEqual / charToRaw (§14.6 Non-English Text)" $ do
+ it "strEqual: 合成 ü と 基底+結合 ü は NFC で等価 (R4DS 14.6.2)" $ do
+ -- u = c("ü", "ü")
+ let u1 = "\x00fc"; u2 = "u\x0308"
+ (u1 == u2) `shouldBe` False -- 素の比較は不一致
+ strEqual u1 u2 `shouldBe` True -- str_equal は一致
+ strLength u1 `shouldBe` 1 -- 14.6.2: 長さは 1
+ strLength u2 `shouldBe` 2 -- と 2 で違う
+ it "strEqual: 異なる文字は不一致" $
+ strEqual "a" "b" `shouldBe` False
+ it "charToRaw: UTF-8 バイト列 (R4DS 14.6.1: Hadley)" $
+ charToRaw "Hadley" `shouldBe` [0x48,0x61,0x64,0x6c,0x65,0x79]
+
+ describe "separateWiderDelim / separateWiderPosition (§14.4.2-3)" $ do
+ it "delim + names: 1 セル→複数列 (R4DS df3)" $ do
+ let df3 = DF.fromNamedColumns
+ [("x", DF.fromList ["a10.1.2022","b10.2.2011","e15.1.2015" :: Text])]
+ out = separateWiderDelim "x" "." [Just "code", Just "edition", Just "year"] df3
+ DF.dimensions out `shouldBe` (3, 3)
+ colMT "code" out `shouldBe` map Just ["a10","b10","e15"]
+ colMT "edition" out `shouldBe` map Just ["1","2","1"]
+ colMT "year" out `shouldBe` map Just ["2022","2011","2015"]
+ it "delim + names に NA: その piece を捨てる (R4DS)" $ do
+ let df3 = DF.fromNamedColumns
+ [("x", DF.fromList ["a10.1.2022","b10.2.2011","e15.1.2015" :: Text])]
+ out = separateWiderDelim "x" "." [Just "code", Nothing, Just "year"] df3
+ DF.columnNames out `shouldMatchList` ["code","year"]
+ colMT "code" out `shouldBe` map Just ["a10","b10","e15"]
+ colMT "year" out `shouldBe` map Just ["2022","2011","2015"]
+ it "position widths: 固定幅で列分割 (R4DS df4)" $ do
+ let df4 = DF.fromNamedColumns
+ [("x", DF.fromList ["202215TX","202122LA","202325CA" :: Text])]
+ out = separateWiderPosition "x" [("year",4),("age",2),("state",2)] df4
+ colMT "year" out `shouldBe` map Just ["2022","2021","2023"]
+ colMT "age" out `shouldBe` map Just ["15","22","25"]
+ colMT "state" out `shouldBe` map Just ["TX","LA","CA"]
+
+ -- §14.4.3 診断 df: a = c("1-1-1","1-1-2","1-3","1-3-2","1")
+ let dfA = DF.fromNamedColumns
+ [("a", DF.fromList ["1-1-1","1-1-2","1-3","1-3-2","1" :: Text])]
+ nm = [Just "x", Just "y", Just "z"]
+ it "too_few = align_start: 不足は右を NA (R4DS)" $ do
+ let out = separateWiderDelimWith "a" "-" nm AlignStart TooManyError dfA
+ colMT "x" out `shouldBe` map Just ["1","1","1","1","1"]
+ colMT "y" out `shouldBe` [Just "1", Just "1", Just "3", Just "3", Nothing]
+ colMT "z" out `shouldBe` [Just "1", Just "2", Nothing, Just "2", Nothing]
+ it "too_few = align_end: 不足は左を NA" $ do
+ let out = separateWiderDelimWith "a" "-" nm AlignEnd TooManyError dfA
+ colMT "x" out `shouldBe` [Just "1", Just "1", Nothing, Just "1", Nothing]
+ colMT "y" out `shouldBe` [Just "1", Just "1", Just "1", Just "3", Nothing]
+ colMT "z" out `shouldBe` [Just "1", Just "2", Just "3", Just "2", Just "1"]
+ it "too_few = error: 不足があれば error" $
+ forceStrs [DF.dimensions (separateWiderDelimWith "a" "-" nm TooFewError TooManyError dfA)] fst
+ `shouldThrow` anyErrorCall
+
+ -- §14.4.3 too_many df: a = c("1-1-1","1-1-2","1-3-5-6","1-3-2","1-3-5-7-9")
+ let dfM = DF.fromNamedColumns
+ [("a", DF.fromList ["1-1-1","1-1-2","1-3-5-6","1-3-2","1-3-5-7-9" :: Text])]
+ it "too_many = drop: 余剰は捨てる (R4DS)" $ do
+ let out = separateWiderDelimWith "a" "-" nm AlignStart DropExtra dfM
+ colMT "x" out `shouldBe` map Just ["1","1","1","1","1"]
+ colMT "y" out `shouldBe` map Just ["1","1","3","3","3"]
+ colMT "z" out `shouldBe` map Just ["1","2","5","2","5"]
+ it "too_many = merge: 余剰を最終列に再結合 (R4DS)" $ do
+ let out = separateWiderDelimWith "a" "-" nm AlignStart MergeExtra dfM
+ colMT "x" out `shouldBe` map Just ["1","1","1","1","1"]
+ colMT "y" out `shouldBe` map Just ["1","1","3","3","3"]
+ colMT "z" out `shouldBe` map Just ["1","2","5-6","2","5-7-9"]
+ it "debug: 診断列 _ok / _pieces / _remainder を付与" $ do
+ let out = separateWiderDelimWith "a" "-" nm TooFewError TooManyDebug dfM
+ DF.columnNames out `shouldMatchList`
+ ["x","y","z","a_ok","a_pieces","a_remainder"]
+ colMT "a_remainder" out `shouldBe`
+ [Just "", Just "", Just "6", Just "", Just "7-9"]
+
+ describe "正規表現 (§15 Regular expressions・regex-tdfa)" $ do
+ it "strDetect: 基本マッチ + \\d 変換 + \\b 単語境界" $ do
+ strDetect "an" "banana" `shouldBe` True
+ strDetect "z" "banana" `shouldBe` False
+ strDetect "\\d" "a1b" `shouldBe` True -- \d → [[:digit:]]
+ strDetect "\\d" "abc" `shouldBe` False
+ strDetect "[[:digit:]]" "a1b" `shouldBe` True
+ strDetect "\\bcat\\b" "the cat sat" `shouldBe` True
+ strDetect "\\bcat\\b" "category" `shouldBe` False
+ it "strDetectWith: ignore_case (§15.5)" $ do
+ strDetect "ABC" "xabcy" `shouldBe` False
+ strDetectWith True "ABC" "xabcy" `shouldBe` True
+ it "strCount: マッチ回数" $
+ strCount "a" "banana" `shouldBe` 3
+ it "strSubset / strWhich" $ do
+ strSubset "^a" ["apple","banana","avocado"] `shouldBe` ["apple","avocado"]
+ strWhich "a" ["xyz","cat","dog"] `shouldBe` [2]
+ it "strExtract / strExtractAll (\\d+)" $ do
+ strExtract "\\d+" "abc123def45" `shouldBe` Just "123"
+ strExtractAll "\\d+" "abc123def45" `shouldBe` ["123","45"]
+ strExtract "\\d+" "no digits" `shouldBe` Nothing
+ it "strMatch: capture groups (whole + groups)" $
+ strMatch "([a-z])-([0-9])" "x-5" `shouldBe`
+ [Just "x-5", Just "x", Just "5"]
+ it "strReplace / strReplaceAll + backref \\1\\2 (§15.3.3 swap)" $ do
+ strReplace "a" "_" "banana" `shouldBe` "b_nana"
+ strReplaceAll "a" "_" "banana" `shouldBe` "b_n_n_"
+ strReplaceAll "([a-z])([a-z])" "\\2\\1" "abcd" `shouldBe` "badc"
+ it "strRemove / strRemoveAll" $ do
+ strRemove "a" "banana" `shouldBe` "bnana"
+ strRemoveAll "a" "banana" `shouldBe` "bnn"
+ it "strSplit (delim + \\s+)" $ do
+ strSplit "," "a,b,c" `shouldBe` ["a","b","c"]
+ strSplit "\\s+" "a b c" `shouldBe` ["a","b","c"]
+ it "strLocate: 1 始まり両端含む" $ do
+ strLocate "an" "banana" `shouldBe` Just (2,3)
+ strLocate "z" "banana" `shouldBe` Nothing
+ it "strEscape: メタ文字をエスケープ" $
+ strEscape "a.b+c" `shouldBe` "a\\.b\\+c"
+ it "separateWiderRegex: 名前付きグループで列分割 (§15.3.4)" $ do
+ let dfR = DF.fromNamedColumns [("x", DF.fromList ["1-2","3-4" :: Text])]
+ out = separateWiderRegex "x"
+ [(Just "a", "\\d+"), (Nothing, "-"), (Just "b", "\\d+")] dfR
+ DF.columnNames out `shouldMatchList` ["a","b"]
+ colMT "a" out `shouldBe` [Just "1", Just "3"]
+ colMT "b" out `shouldBe` [Just "2", Just "4"]
diff --git a/test/Hanalyze/Data/TransformSpec.hs b/test/Hanalyze/Data/TransformSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Data/TransformSpec.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | 'Hanalyze.Data.Transform' のテスト (Phase 66)。
+-- dplyr/base R の対応関数と数値・配置一致を確認する。 参照値は R 4.x。
+module Hanalyze.Data.TransformSpec (spec) where
+
+import Test.Hspec
+import Data.Ord (Down (..))
+import qualified Hanalyze.Data.Transform as T
+
+spec :: Spec
+spec = describe "Hanalyze.Data.Transform" $ do
+
+ describe "順位 (dplyr ranking)" $ do
+ -- x <- c(1, 5, 5, 17, 22)
+ let x = [1, 5, 5, 17, 22] :: [Int]
+ it "minRank (1,2,2,4,5)" $ T.minRank x `shouldBe` [1,2,2,4,5]
+ it "denseRank (1,2,2,3,4)" $ T.denseRank x `shouldBe` [1,2,2,3,4]
+ it "rowNumber (1,2,3,4,5)" $ T.rowNumber x `shouldBe` [1,2,3,4,5]
+ it "percentRank (0,.25,.25,.75,1)" $
+ T.percentRank x `shouldBe` [0, 0.25, 0.25, 0.75, 1]
+ it "cumeDist (.2,.6,.6,.8,1)" $
+ T.cumeDist x `shouldBe` [0.2, 0.6, 0.6, 0.8, 1.0]
+ it "minRank desc (= Down): 5,3,3,2,1" $
+ T.minRank (map Down x) `shouldBe` [5,3,3,2,1]
+
+ describe "順位 NA 保持 (R x=c(1,5,5,17,22,NA))" $ do
+ let xs = [Just 1, Just 5, Just 5, Just 17, Just 22, Nothing] :: [Maybe Int]
+ it "minRankNA" $
+ T.minRankNA xs `shouldBe` [Just 1, Just 2, Just 2, Just 4, Just 5, Nothing]
+ it "denseRankNA" $
+ T.denseRankNA xs `shouldBe` [Just 1, Just 2, Just 2, Just 3, Just 4, Nothing]
+ it "percentRankNA" $
+ T.percentRankNA xs `shouldBe` [Just 0, Just 0.25, Just 0.25, Just 0.75, Just 1, Nothing]
+
+ describe "オフセット" $ do
+ -- x <- c(2, 5, 11, 11, 19, 35)
+ let x = [2, 5, 11, 11, 19, 35] :: [Int]
+ it "lag 1 (先頭 default)" $
+ T.lag 1 (-1) x `shouldBe` [-1, 2, 5, 11, 11, 19]
+ it "lead 1 (末尾 default)" $
+ T.lead 1 (-1) x `shouldBe` [5, 11, 11, 19, 35, -1]
+ it "lag 2" $ T.lag 2 0 x `shouldBe` [0, 0, 2, 5, 11, 11]
+ it "lag n>=length = 全 default" $ T.lag 10 0 x `shouldBe` [0,0,0,0,0,0]
+
+ describe "累積" $ do
+ it "cumsum 1:10" $ T.cumsum [1..10 :: Int] `shouldBe` [1,3,6,10,15,21,28,36,45,55]
+ it "cumprod" $ T.cumprod [1,2,3,4 :: Int] `shouldBe` [1,2,6,24]
+ it "cummin" $ T.cummin [5,3,4,1,2 :: Int] `shouldBe` [5,3,3,1,1]
+ it "cummax" $ T.cummax [1,3,2,5,4 :: Int] `shouldBe` [1,3,3,5,5]
+ it "cummean" $ T.cummean [2,4,6] `shouldBe` [2,3,4]
+
+ describe "区間化 (cut・right=TRUE)" $ do
+ -- x <- c(1,2,5,10,15,20); cut(x, breaks=c(0,5,10,15,20))
+ -- → (0,5] (0,5] (0,5] (5,10] (10,15] (15,20] = bin 1,1,1,2,3,4
+ let x = [1,2,5,10,15,20]
+ it "cut bin index" $
+ T.cut [0,5,10,15,20] x `shouldBe` [Just 1, Just 1, Just 1, Just 2, Just 3, Just 4]
+ it "範囲外 → Nothing" $
+ T.cut [0,5,10,15,20] [-10, 5, 10, 30] `shouldBe` [Nothing, Just 1, Just 2, Nothing]
+ it "ラベル付き" $
+ T.cutLabels (["sm","md","lg","xl"] :: [String]) [0,5,10,15,20] x
+ `shouldBe` [Just "sm", Just "sm", Just "sm", Just "md", Just "lg", Just "xl"]
+
+ describe "連続識別子 (consecutive_id)" $ do
+ -- x <- c("a","a","a","b","c","c","d","e","a","a","b","b")
+ it "値が変わるたび +1" $
+ T.consecutiveId (["a","a","a","b","c","c","d","e","a","a","b","b"] :: [String])
+ `shouldBe` [1,1,1,2,3,3,4,5,6,6,7,7]
diff --git a/test/Hanalyze/Data/WrangleSpec.hs b/test/Hanalyze/Data/WrangleSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Data/WrangleSpec.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+-- | 'Hanalyze.Data.Wrangle' のテスト (Phase 67)。
+-- dplyr summarise/mutate/group_by 相当の出力一致を確認する。
+module Hanalyze.Data.WrangleSpec (spec) where
+
+import Test.Hspec
+import Data.Text (Text)
+import qualified DataFrame.Internal.Column as DF
+import qualified DataFrame.Internal.DataFrame as DF
+import qualified DataFrame.Operations.Core as DF
+import qualified DataFrame.Operators as DF
+import qualified DataFrame.Internal.Column as DFC
+import DataFrame.Operators ((|>))
+import Hanalyze.Data.Wrangle
+
+near :: Double -> Double -> Bool
+near a b = abs (a - b) < 1e-9
+
+-- g = c(a,a,b,b,b), x = c(1,2,3,5,7)
+df :: DF.DataFrame
+df = DF.fromNamedColumns
+ [ ("g", DF.fromList (["a","a","b","b","b"] :: [Text]))
+ , ("x", DF.fromList ([1,2,3,5,7] :: [Double])) ]
+
+col :: forall a. DFC.Columnable a => Text -> DF.DataFrame -> [a]
+col n = DF.columnAsList (DF.col @a n)
+
+spec :: Spec
+spec = describe "Hanalyze.Data.Wrangle" $ do
+
+ describe "summarise (ungrouped・1 行)" $ do
+ let r = df |> summarise [ "mean" =: meanOf "x"
+ , "q75" =: quantileOf 0.75 "x"
+ , "n" =: nOf ]
+ it "1 行" $ fst (DF.dimensions r) `shouldBe` 1
+ it "mean(x) = 3.6" $ head (col @Double "mean" r) `shouldSatisfy` near 3.6
+ it "q75(x) = 5" $ head (col @Double "q75" r) `shouldSatisfy` near 5
+ it "n = 5 (Int 列)" $ col @Int "n" r `shouldBe` [5]
+
+ describe "groupBy + summarise (キー昇順)" $ do
+ let r = summarise [ "mean" =: meanOf "x", "n" =: nOf ] (groupBy ["g"] df)
+ it "2 群" $ fst (DF.dimensions r) `shouldBe` 2
+ it "キー昇順 a,b" $ col @Text "g" r `shouldBe` ["a","b"]
+ it "群 mean = [1.5, 5]" $
+ (col @Double "mean" r) `shouldSatisfy` (\ms -> near (ms!!0) 1.5 && near (ms!!1) 5)
+ it "群 n = [2,3]" $ col @Int "n" r `shouldBe` [2,3]
+
+ describe "mutate (元列温存 + 新列)" $ do
+ let r = df |> mutate [ "rank" =: minRankOf "x", "lag1" =: lagOf 1 "x" ]
+ it "元列 x 温存" $ col @Double "x" r `shouldBe` [1,2,3,5,7]
+ it "rank = 1..5" $ col @(Maybe Double) "rank" r
+ `shouldBe` [Just 1, Just 2, Just 3, Just 4, Just 5]
+ it "lag1 先頭 NA" $ col @(Maybe Double) "lag1" r
+ `shouldBe` [Nothing, Just 1, Just 2, Just 3, Just 5]
diff --git a/test/Hanalyze/DataIO/CSVSpec.hs b/test/Hanalyze/DataIO/CSVSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/DataIO/CSVSpec.hs
@@ -0,0 +1,228 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.DataIO.CSVSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import qualified DataFrame.Operations.Core as DX
+import qualified Hanalyze.DataIO.Preprocess as Pp
+import qualified Hanalyze.DataIO.Log as Log
+import qualified Hanalyze.DataIO.CSV as CSV
+import qualified Hanalyze.DataIO.Clean as Clean
+import qualified Hanalyze.DataIO.Convert as Conv2
+import qualified Hanalyze.Stat.AdaptiveGrid as AG
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.DataIO.CSV.loadAutoSafe" $ do
+ it "Empty file → Left, no exception" $
+ withSystemTempFile "ha-empty.csv" $ \fp h -> do
+ hPutStr h ""
+ hClose h
+ r <- CSV.loadAutoSafe fp
+ case r of
+ Left msg -> T.isInfixOf "Empty" (T.pack msg) `shouldBe` True
+ Right _ -> expectationFailure "expected Left for empty file"
+ it "Header-only file → Left" $
+ withSystemTempFile "ha-hdr.csv" $ \fp h -> do
+ hPutStr h "x,y,z\n"
+ hClose h
+ r <- CSV.loadAutoSafe fp
+ case r of
+ Left msg -> T.isInfixOf "header" (T.pack msg) `shouldBe` True
+ Right _ -> expectationFailure "expected Left for header-only file"
+ it "Valid CSV → Right with empty log by default" $
+ withSystemTempFile "ha-ok.csv" $ \fp h -> do
+ hPutStr h "x,y\n1,2\n3,4\n"
+ hClose h
+ r <- CSV.loadAutoSafe fp
+ case r of
+ Left msg -> expectationFailure ("unexpected Left: " ++ msg)
+ Right (_, lg) -> Log.entries lg `shouldBe` []
+
+ describe "Hanalyze.DataIO.CSV.loadAutoSafeWith" $ do
+ it "--no-header: 先頭行をデータ行として扱い col0... を生成" $
+ withSystemTempFile "ha-noh.csv" $ \fp h -> do
+ hPutStr h "1,2\n3,4\n5,6\n"
+ hClose h
+ r <- CSV.loadAutoSafeWith
+ (CSV.defaultLoadOpts { CSV.loNoHeader = True }) fp
+ case r of
+ Left e -> expectationFailure ("unexpected Left: " ++ e)
+ Right (df, lg) -> do
+ let cols = DX.columnNames df
+ cols `shouldBe` ["col0", "col1"]
+ map Log.lgCode (Log.entries lg) `shouldContain` ["I012"]
+ it "--skip 2: 先頭 2 行を skip" $
+ withSystemTempFile "ha-skip.csv" $ \fp h -> do
+ hPutStr h "# c1\n# c2\nx,y\n1,2\n3,4\n"
+ hClose h
+ r <- CSV.loadAutoSafeWith
+ (CSV.defaultLoadOpts { CSV.loSkip = 2 }) fp
+ case r of
+ Left e -> expectationFailure ("unexpected Left: " ++ e)
+ Right (df, _) -> DX.columnNames df `shouldBe` ["x", "y"]
+ it "sniff: ヘッダ無し CSV を自動推論で col0... に変える" $
+ withSystemTempFile "ha-sniff-noh.csv" $ \fp h -> do
+ hPutStr h "1.0,2.0\n3.0,4.0\n"
+ hClose h
+ r <- CSV.loadAutoSafeWith CSV.defaultLoadOpts fp
+ case r of
+ Left e -> expectationFailure ("unexpected Left: " ++ e)
+ Right (df, lg) -> do
+ DX.columnNames df `shouldBe` ["col0", "col1"]
+ map Log.lgCode (Log.entries lg) `shouldContain` ["I013"]
+ it "sniff: コメント行 # を skip 推論" $
+ withSystemTempFile "ha-sniff-skip.csv" $ \fp h -> do
+ hPutStr h "# comment 1\n# comment 2\nx,y\n1,2\n3,4\n"
+ hClose h
+ r <- CSV.loadAutoSafeWith CSV.defaultLoadOpts fp
+ case r of
+ Left e -> expectationFailure ("unexpected Left: " ++ e)
+ Right (df, _) -> DX.columnNames df `shouldBe` ["x", "y"]
+ it "sniff: セミコロン区切りを自動検出" $
+ withSystemTempFile "ha-sniff-semi.csv" $ \fp h -> do
+ hPutStr h "a;b;c\n1;2;3\n4;5;6\n"
+ hClose h
+ r <- CSV.loadAutoSafeWith CSV.defaultLoadOpts fp
+ case r of
+ Left e -> expectationFailure ("unexpected Left: " ++ e)
+ Right (df, _) -> DX.columnNames df `shouldBe` ["a", "b", "c"]
+ it "sniff: --no-sniff で自動推論を切れる" $
+ withSystemTempFile "ha-no-sniff.csv" $ \fp h -> do
+ hPutStr h "1.0,2.0\n3.0,4.0\n"
+ hClose h
+ r <- CSV.loadAutoSafeWith
+ (CSV.defaultLoadOpts { CSV.loSniff = False }) fp
+ case r of
+ Left e -> expectationFailure ("unexpected Left: " ++ e)
+ Right (df, lg) -> do
+ -- ヘッダ無しの自動修復は走らないので col0 にはならない
+ DX.columnNames df `shouldBe` ["1.0", "2.0"]
+ -- 代わりに W001 が出る
+ map Log.lgCode (Log.entries lg) `shouldContain` ["W001"]
+
+ it "Clean.stripUnitsCol: 12.3kg → 12.3" $ do
+ let df0 = DX.insertColumn "w"
+ (DX.fromList (["12.3kg", "11.5cm", "10kg"] :: [T.Text]))
+ $ DX.empty
+ (df1, lg) = Clean.applyRule Clean.StripUnits "w" df0
+ map Log.lgCode (Log.entries lg) `shouldContain` ["I100"]
+ case Conv2.getDoubleVec "w" df1 of
+ Just v -> V.toList v `shouldBe` [12.3, 11.5, 10.0]
+ Nothing -> expectationFailure "expected numeric column"
+ it "Clean.parseCurrencyCol: $1,234.56 → 1234.56" $ do
+ let df0 = DX.insertColumn "p"
+ (DX.fromList (["$1,234.56", "$2,500.00"] :: [T.Text]))
+ $ DX.empty
+ (df1, _) = Clean.applyRule Clean.ParseCurrency "p" df0
+ case Conv2.getDoubleVec "p" df1 of
+ Just v -> V.toList v `shouldBe` [1234.56, 2500.0]
+ Nothing -> expectationFailure "expected numeric column"
+ it "Clean.coerceNumericCol: 混在パターンを最大限拾う" $ do
+ let df0 = DX.insertColumn "x"
+ (DX.fromList (["12.3", "12.3kg", "$1,000"] :: [T.Text]))
+ $ DX.empty
+ (df1, _) = Clean.applyRule Clean.CoerceNumeric "x" df0
+ case Conv2.getDoubleVec "x" df1 of
+ Just v -> V.toList v `shouldBe` [12.3, 12.3, 1000.0]
+ Nothing -> expectationFailure "expected all-success column"
+ it "Preprocess.meltLonger: wide → long、NA セルは除外、列名を Double に parse" $ do
+ let df0 = DX.insertColumn "id" (DX.fromList (["a", "b"] :: [T.Text]))
+ $ DX.insertColumn "1" (DX.fromList ([Just 10.0, Nothing] :: [Maybe Double]))
+ $ DX.insertColumn "2" (DX.fromList ([Just 20.0, Just 30.0] :: [Maybe Double]))
+ $ DX.insertColumn "3" (DX.fromList ([Nothing, Just 60.0] :: [Maybe Double]))
+ $ DX.empty
+ df1 = Pp.meltLonger ["id"] ["1", "2", "3"] "t" "y" True df0
+ (nrows, ncols) = DX.dimensions df1
+ nrows `shouldBe` 4 -- a,1=10; a,2=20; b,2=30; b,3=60
+ ncols `shouldBe` 3 -- id, t, y
+ DX.columnNames df1 `shouldMatchList` ["id", "t", "y"]
+ case Conv2.getDoubleVec "y" df1 of
+ Just v -> sort (V.toList v) `shouldBe` [10, 20, 30, 60]
+ Nothing -> expectationFailure "expected y as numeric"
+ case Conv2.getDoubleVec "t" df1 of
+ Just v -> sort (V.toList v) `shouldBe` [1, 2, 2, 3]
+ Nothing -> expectationFailure "expected t parsed as numeric"
+
+ it "Preprocess.regridLong: ZIntersection モードで全 id が共通範囲に収まる" $ do
+ -- id=a: z=0..3, id=b: z=1..4 → intersection は (1, 3)
+ let df0 = DX.insertColumn "id" (DX.fromList (["a","a","a","a","b","b","b","b"] :: [T.Text]))
+ $ DX.insertColumn "z" (DX.fromList ([0,1,2,3,1,2,3,4] :: [Double]))
+ $ DX.insertColumn "y" (DX.fromList ([0,1,4,9,1,4,9,16] :: [Double]))
+ $ DX.empty
+ opts = Pp.defaultRegridOpts
+ { Pp.roN = 5, Pp.roZBoundsMode = Pp.ZIntersection
+ , Pp.roGridKind = AG.Uniform }
+ rr = Pp.regridLong "id" "z" "y" opts df0
+ Pp.rrZMin rr `shouldBe` 1.0
+ Pp.rrZMax rr `shouldBe` 3.0
+ length (Pp.rrZGrid rr) `shouldBe` 5
+ length (Pp.rrIds rr) `shouldBe` 2
+
+ it "Preprocess.regridLong: ZUnion モードで [min,max] が和集合になる" $ do
+ let df0 = DX.insertColumn "id" (DX.fromList (["a","a","b","b"] :: [T.Text]))
+ $ DX.insertColumn "z" (DX.fromList ([0,2,1,3] :: [Double]))
+ $ DX.insertColumn "y" (DX.fromList ([0,4,1,9] :: [Double]))
+ $ DX.empty
+ opts = Pp.defaultRegridOpts
+ { Pp.roN = 4, Pp.roZBoundsMode = Pp.ZUnion
+ , Pp.roGridKind = AG.Uniform }
+ rr = Pp.regridLong "id" "z" "y" opts df0
+ Pp.rrZMin rr `shouldBe` 0.0
+ Pp.rrZMax rr `shouldBe` 3.0
+ -- 外挿が記録される (id=a の上端 0..2、共通 0..3 → above=1)
+ let stat_a = head [s | s <- Pp.rrPerIdStats rr, Pp.piId s == "a"]
+ Pp.piExtrapAbove stat_a `shouldBe` 1.0
+
+ it "Clean.cleanPipeline: 複数列を一括変換" $ do
+ let df0 = DX.insertColumn "p"
+ (DX.fromList (["$10", "$20"] :: [T.Text]))
+ $ DX.insertColumn "w"
+ (DX.fromList (["1kg", "2kg"] :: [T.Text]))
+ $ DX.empty
+ rules = [("p", Clean.ParseCurrency), ("w", Clean.StripUnits)]
+ (df1, lg) = Clean.cleanPipeline rules df0
+ codes = map Log.lgCode (Log.entries lg)
+ codes `shouldContain` ["I101"]
+ codes `shouldContain` ["I100"]
+ Conv2.getDoubleVec "p" df1 `shouldSatisfy` \mv ->
+ case mv of { Just v -> V.toList v == [10, 20]; Nothing -> False }
+
+ it "--strict + 警告ありデータ (sniff off) → Left" $
+ withSystemTempFile "ha-strict.csv" $ \fp h -> do
+ hPutStr h "1.0,2.0\n3.0,4.0\n" -- ヘッダ無し疑い W001
+ hClose h
+ -- sniff を切ると W001 が残るので strict が短絡する
+ r <- CSV.loadAutoSafeWith
+ (CSV.defaultLoadOpts { CSV.loStrict = True
+ , CSV.loSniff = False }) fp
+ case r of
+ Left _ -> return ()
+ Right _ -> expectationFailure "expected Left under --strict --no-sniff"
+
+ -- ===========================================================================
+ -- 多出力 API の q=1 等価性 (M1〜M8)
+ -- ===========================================================================
diff --git a/test/Hanalyze/DataIO/ConvertSpec.hs b/test/Hanalyze/DataIO/ConvertSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/DataIO/ConvertSpec.hs
@@ -0,0 +1,51 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.DataIO.ConvertSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Hanalyze.DataIO.CSV as CSV
+import qualified Hanalyze.DataIO.Convert as Conv
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.DataIO.Convert deep-eval" $ do
+ it "getMaybeTextVec on text column with mixed NA strings returns Just" $
+ withSystemTempFile "ha-na.csv" $ \fp h -> do
+ -- 複数 NA 表現を混ぜると Hackage は Maybe Text 列として保持する。
+ -- ヘッダ判定で n/a / null は欠損扱い → null bitmap が立つ。
+ hPutStr h "id,score\n1,A\n2,n/a\n3,null\n4,B\n5,-\n"
+ hClose h
+ r <- CSV.loadAutoSafe fp
+ case r of
+ Right (df, _) -> case Conv.getMaybeTextVec "score" df of
+ Just v -> length (V.toList v) `shouldBe` 5
+ Nothing -> expectationFailure "getMaybeTextVec returned Nothing"
+ Left msg -> expectationFailure ("load failed: " ++ msg)
+ it "getDoubleVec returns Nothing without crashing on NA-mixed numeric column" $
+ withSystemTempFile "ha-na2.csv" $ \fp h -> do
+ hPutStr h "id,score\n1,85\n2,NA\n3,92\n"
+ hClose h
+ r <- CSV.loadAutoSafe fp
+ case r of
+ Right (df, _) -> Conv.getDoubleVec "score" df `shouldBe` Nothing
+ Left msg -> expectationFailure ("load failed: " ++ msg)
diff --git a/test/Hanalyze/DataIO/HealthSpec.hs b/test/Hanalyze/DataIO/HealthSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/DataIO/HealthSpec.hs
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.DataIO.HealthSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import qualified Hanalyze.DataIO.Log as Log
+import qualified Hanalyze.DataIO.Health as Health
+import qualified Data.ByteString as BS
+import qualified Hanalyze.Stat.BridgeSampling as BS
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.DataIO.Health" $ do
+ it "W001: ヘッダ無し疑い (列名が全て数値)" $ do
+ let df = DX.insertColumn "1.0" (DX.fromList ([2.0, 4.0] :: [Double]))
+ $ DX.insertColumn "2.0" (DX.fromList ([4.1, 8.0] :: [Double]))
+ $ DX.empty
+ codes = map Log.lgCode (Log.entries (Health.detectHeaderless df))
+ codes `shouldContain` ["W001"]
+ it "W001 は通常ヘッダでは発火しない" $ do
+ let df = DX.insertColumn "x" (DX.fromList ([1.0, 2.0] :: [Double]))
+ $ DX.empty
+ Log.entries (Health.detectHeaderless df) `shouldBe` []
+ it "W002: コメント行 (# 始まり) を検出" $ do
+ let preview = "# header comment\n# more comment\nx,y\n1,2\n"
+ codes = map Log.lgCode (Log.entries (Health.detectCommentLines preview))
+ codes `shouldContain` ["W002"]
+ it "W005: 1 列 DataFrame + プレビューにタブ → delimiter ミスマッチ" $ do
+ let df = DX.insertColumn "x\ty" (DX.fromList ([1.0] :: [Double]))
+ $ DX.empty
+ preview = "x\ty\n1\t2\n3\t4\n"
+ codes = map Log.lgCode
+ (Log.entries (Health.detectDelimiterMismatch preview df))
+ codes `shouldContain` ["W005"]
+ it "W008: 通貨記号付き列を検出" $ do
+ let df = DX.insertColumn "price"
+ (DX.fromList (["$1,234.56", "$2,500.00", "$3,000.00", "$4,000"] :: [T.Text]))
+ $ DX.empty
+ codes = map Log.lgCode (Log.entries (Health.detectThousandsCurrency df))
+ codes `shouldContain` ["W008"]
+ -- BS インポートを使う何かのスモーク (未使用 warning 防止)
+ it "preview is non-empty for typical use" $
+ BS.length "x,y\n1,2" `shouldSatisfy` (> 0)
diff --git a/test/Hanalyze/DataIO/LogSpec.hs b/test/Hanalyze/DataIO/LogSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/DataIO/LogSpec.hs
@@ -0,0 +1,60 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.DataIO.LogSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Hanalyze.DataIO.Log as Log
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.DataIO.Log" $ do
+ it "Monoid: noLog <> r == r" $ do
+ let r = Log.logReport (Log.mkWarn "W001" "msg" Nothing)
+ Log.entries (Log.noLog <> r) `shouldBe` Log.entries r
+ Log.entries (r <> Log.noLog) `shouldBe` Log.entries r
+ it "addEntry appends" $ do
+ let r0 = Log.logReport (Log.mkInfo "I001" "first" Nothing)
+ r1 = Log.addEntry (Log.mkWarn "W001" "second" (Just "ヒント")) r0
+ length (Log.entries r1) `shouldBe` 2
+ Log.lgSev (last (Log.entries r1)) `shouldBe` Log.Warn
+ Log.lgHint (last (Log.entries r1)) `shouldBe` Just "ヒント"
+ it "hasErrors / hasWarnings detect severity" $ do
+ let rW = Log.logReport (Log.mkWarn "W" "w" Nothing)
+ rE = Log.logReport (Log.mkErr "E" "e" Nothing)
+ Log.hasWarnings rW `shouldBe` True
+ Log.hasErrors rW `shouldBe` False
+ Log.hasErrors (rW <> rE) `shouldBe` True
+ it "severityCount counts each level" $ do
+ let r = Log.logReport (Log.mkInfo "I" "i" Nothing)
+ <> Log.logReport (Log.mkWarn "W1" "w" Nothing)
+ <> Log.logReport (Log.mkWarn "W2" "w" Nothing)
+ <> Log.logReport (Log.mkErr "E" "e" Nothing)
+ Log.severityCount Log.Info r `shouldBe` 1
+ Log.severityCount Log.Warn r `shouldBe` 2
+ Log.severityCount Log.Err r `shouldBe` 1
+ it "prettyEntry: includes code, message, hint" $ do
+ let s = Log.prettyEntry (Log.mkWarn "W042" "壊れている" (Just "助言"))
+ T.isInfixOf "[WARN]" s `shouldBe` True
+ T.isInfixOf "W042" s `shouldBe` True
+ T.isInfixOf "壊れている" s `shouldBe` True
+ T.isInfixOf "助言" s `shouldBe` True
diff --git a/test/Hanalyze/DataIO/PreprocessSpec.hs b/test/Hanalyze/DataIO/PreprocessSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/DataIO/PreprocessSpec.hs
@@ -0,0 +1,145 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.DataIO.PreprocessSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import qualified DataFrame.Operations.Core as DX
+import qualified DataFrame.Operators as DX
+import qualified Hanalyze.DataIO.Preprocess as Pp
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.DataIO.Preprocess" $ do
+ let dfNA = DX.fromNamedColumns
+ [ ("group", DX.fromList (["A","B","A","B","C"] :: [T.Text]))
+ , ("x", DX.fromList (["1","NA","3","","5"] :: [T.Text]))
+ , ("y", DX.fromList ([10, 20, 30, 40, 50] :: [Double]))
+ ]
+
+ it "isNAString detects standard NA strings" $ do
+ Pp.isNAString "NA" `shouldBe` True
+ Pp.isNAString "N/A" `shouldBe` True
+ Pp.isNAString "null" `shouldBe` True
+ Pp.isNAString "" `shouldBe` True
+ Pp.isNAString " " `shouldBe` True
+ Pp.isNAString "valid" `shouldBe` False
+
+ it "countMissing counts NAs in Text columns; numeric is 0" $ do
+ let counts = Pp.countMissing dfNA
+ lookup "x" counts `shouldBe` Just 2
+ lookup "y" counts `shouldBe` Just 0
+ lookup "group" counts `shouldBe` Just 0
+
+ it "dropMissingRows removes rows with NA in target columns" $ do
+ let df' = Pp.dropMissingRows ["x"] dfNA
+ (n, _) = DX.dimensions df'
+ n `shouldBe` 3 -- only rows with x ∈ {"1","3","5"} remain
+
+ it "imputeMean converts Text/NA column to Double with mean fill" $ do
+ case Pp.imputeMean "x" dfNA of
+ Just df' -> do
+ let xs = DX.columnAsList (DX.col @Double "x") df'
+ length xs `shouldBe` 5
+ -- mean of [1, 3, 5] = 3
+ (xs !! 1) `shouldBe` 3.0 -- was "NA"
+ (xs !! 3) `shouldBe` 3.0 -- was ""
+ Nothing -> expectationFailure "imputeMean failed"
+
+ it "selectColumns retains only listed columns" $ do
+ let df' = Pp.selectColumns ["y", "group"] dfNA
+ DX.columnNames df' `shouldMatchList` ["y", "group"]
+
+ it "filterRowsByNumeric filters numeric column" $ do
+ let df' = Pp.filterRowsByNumeric "y" (>= 30) dfNA
+ (n, _) = DX.dimensions df'
+ n `shouldBe` 3
+
+ it "mapNumeric applies a unary function" $ do
+ let df' = Pp.mapNumeric "y" (* 2) dfNA
+ xs = DX.columnAsList (DX.col @Double "y") df'
+ xs `shouldBe` [20, 40, 60, 80, 100]
+
+ -- ─────────────────────────────────────────────────────────────────────
+
+ describe "Hanalyze.DataIO.Preprocess (groupBy)" $ do
+ let dfGrp = DX.fromNamedColumns
+ [ ("group", DX.fromList (["A","B","A","B","A","C"] :: [T.Text]))
+ , ("y", DX.fromList ([1, 4, 3, 6, 5, 10] :: [Double]))
+ ]
+
+ it "groupByMean computes per-group mean" $ do
+ case Pp.groupByMean "group" "y" dfGrp of
+ Just df' -> do
+ let (n, _) = DX.dimensions df'
+ n `shouldBe` 3
+ let gs = DX.columnAsList (DX.col @T.Text "group") df'
+ vs = DX.columnAsList (DX.col @Double "y") df'
+ pairs = zip gs vs
+ lookup "A" pairs `shouldBe` Just 3.0 -- (1+3+5)/3
+ lookup "B" pairs `shouldBe` Just 5.0 -- (4+6)/2
+ lookup "C" pairs `shouldBe` Just 10.0
+ Nothing -> expectationFailure "groupByMean failed"
+
+ it "groupBySum computes per-group sum" $ do
+ case Pp.groupBySum "group" "y" dfGrp of
+ Just df' -> do
+ let gs = DX.columnAsList (DX.col @T.Text "group") df'
+ vs = DX.columnAsList (DX.col @Double "y") df'
+ pairs = zip gs vs
+ lookup "A" pairs `shouldBe` Just 9.0
+ lookup "B" pairs `shouldBe` Just 10.0
+ Nothing -> expectationFailure "groupBySum failed"
+
+ it "groupByCount counts rows per group" $ do
+ case Pp.groupByCount "group" dfGrp of
+ Just df' -> do
+ let gs = DX.columnAsList (DX.col @T.Text "group") df'
+ vs = DX.columnAsList (DX.col @Double "count") df'
+ pairs = zip gs vs
+ lookup "A" pairs `shouldBe` Just 3.0
+ lookup "B" pairs `shouldBe` Just 2.0
+ lookup "C" pairs `shouldBe` Just 1.0
+ Nothing -> expectationFailure "groupByCount failed"
+
+ it "groupByMin/Max return correct extremes" $ do
+ case Pp.groupByMin "group" "y" dfGrp of
+ Just dfMin -> do
+ let gs = DX.columnAsList (DX.col @T.Text "group") dfMin
+ vs = DX.columnAsList (DX.col @Double "y") dfMin
+ pairs = zip gs vs
+ lookup "A" pairs `shouldBe` Just 1.0
+ lookup "B" pairs `shouldBe` Just 4.0
+ Nothing -> expectationFailure "groupByMin failed"
+
+ case Pp.groupByMax "group" "y" dfGrp of
+ Just dfMax -> do
+ let gs = DX.columnAsList (DX.col @T.Text "group") dfMax
+ vs = DX.columnAsList (DX.col @Double "y") dfMax
+ pairs = zip gs vs
+ lookup "A" pairs `shouldBe` Just 5.0
+ lookup "B" pairs `shouldBe` Just 6.0
+ Nothing -> expectationFailure "groupByMax failed"
+
+ -- ─────────────────────────────────────────────────────────────────────
diff --git a/test/Hanalyze/DataIO/ReshapeSpec.hs b/test/Hanalyze/DataIO/ReshapeSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/DataIO/ReshapeSpec.hs
@@ -0,0 +1,72 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.DataIO.ReshapeSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import qualified Hanalyze.DataIO.Reshape as Reshape
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.DataIO.Reshape" $ do
+ it "lagColumn(1): 先頭が NaN、残りは 1 つずれる" $ do
+ let df = DX.fromNamedColumns
+ [("x", DX.fromList [1.0, 2.0, 3.0, 4.0, 5.0 :: Double])]
+ df' = Reshape.lagColumn 1 "x" "x_lag1" df
+ -- Lagged column should exist
+ "x_lag1" `elem` DX.columnNames df' `shouldBe` True
+
+ it "leadColumn(1): 末尾が NaN、残りは 1 つ前進" $ do
+ let df = DX.fromNamedColumns
+ [("x", DX.fromList [1.0, 2.0, 3.0, 4.0, 5.0 :: Double])]
+ df' = Reshape.leadColumn 1 "x" "x_lead1" df
+ "x_lead1" `elem` DX.columnNames df' `shouldBe` True
+
+ it "rollingMean(3): 最初 2 つが NaN、3 番目以降は窓内平均" $ do
+ let df = DX.fromNamedColumns
+ [("x", DX.fromList [1.0, 2.0, 3.0, 4.0, 5.0 :: Double])]
+ df' = Reshape.rollingMean 3 "x" "x_rmean3" df
+ "x_rmean3" `elem` DX.columnNames df' `shouldBe` True
+
+ it "oneHot: text 列を indicator 列に展開" $ do
+ let df = DX.fromNamedColumns
+ [ ("id", DX.fromList [1, 2, 3, 4, 5 :: Int])
+ , ("category", DX.fromList ["A", "B", "A", "C", "B" :: T.Text])
+ ]
+ df' = Reshape.oneHot False "category" df
+ let cols = DX.columnNames df'
+ "category" `elem` cols `shouldBe` False -- 元列削除
+ "category_A" `elem` cols `shouldBe` True
+ "category_B" `elem` cols `shouldBe` True
+ "category_C" `elem` cols `shouldBe` True
+
+ it "oneHot dropFirst=True: 1 列分減る" $ do
+ let df = DX.fromNamedColumns
+ [("c", DX.fromList ["X", "Y", "Z" :: T.Text])]
+ df' = Reshape.oneHot True "c" df
+ length (DX.columnNames df') `shouldBe` 2 -- Y, Z (X drop)
+
+ -- ===========================================================================
+ -- Hanalyze.Stat.Effect (Phase 9)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Design/ConstraintSpec.hs b/test/Hanalyze/Design/ConstraintSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/ConstraintSpec.hs
@@ -0,0 +1,72 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.ConstraintSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Design.Optimal as OPT
+import qualified Hanalyze.Design.Constraint as DCons
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Constraint (Phase 23-b)" $ do
+ let cands =
+ [ [1, x1, x2] | x1 <- [-1, 0, 1], x2 <- [-1, 0, 1] ]
+ it "checkRow: LinearConstraint x1 + x2 <= 1 を判定" $ do
+ let c = DCons.LinearConstraint [0, 1, 1] DCons.CLeq 1
+ DCons.checkRow [c] [1, -1, -1] `shouldBe` True
+ DCons.checkRow [c] [1, 1, 1] `shouldBe` False
+ DCons.checkRow [c] [1, 0, 1] `shouldBe` True
+ it "checkRow: ForbiddenCombination で完全一致を弾く" $ do
+ let c = DCons.ForbiddenCombination [1, 1, 1]
+ DCons.checkRow [c] [1, 1, 1] `shouldBe` False
+ DCons.checkRow [c] [1, 0, 1] `shouldBe` True
+ it "checkRow: 浮動小数 tolerance (1e-9) で ForbiddenCombination 判定" $ do
+ let c = DCons.ForbiddenCombination [1, 1]
+ DCons.checkRow [c] [1, 1 + 1e-11] `shouldBe` False -- tol 内 = 一致 = 違反
+ DCons.checkRow [c] [1, 1 + 1e-6 ] `shouldBe` True -- tol 外 = OK
+ it "checkDesign: 違反 row index を列挙" $ do
+ let c = DCons.LinearConstraint [0, 1, 1] DCons.CLeq 1
+ mat = LA.fromLists [[1,-1,-1],[1,1,1],[1,0,1],[1,1,0.5]]
+ DCons.checkDesign [c] mat `shouldBe` [1, 3]
+ it "filterCandidates: x1 + x2 <= 1 で 9 候補 → 8 候補 (排除: (1,1))" $ do
+ let c = DCons.LinearConstraint [0, 1, 1] DCons.CLeq 1
+ fc = DCons.filterCandidates [c] cands
+ length fc `shouldBe` 8
+ it "filterCandidates 後の候補で dOptimal が動作 (5 行抽出)" $ do
+ let c = DCons.LinearConstraint [0, 1, 1] DCons.CLeq 1
+ fc = DCons.filterCandidates [c] cands
+ (idxs, des) = OPT.dOptimal fc 5 42
+ length idxs `shouldBe` 5
+ length des `shouldBe` 5
+ it "より厳しい制約 x1 + x2 <= 0 で 9 候補 → 6 候補に縮約" $ do
+ -- 排除: (0,1)=1、 (1,0)=1、 (1,1)=2 の 3 件
+ let c = DCons.LinearConstraint [0, 1, 1] DCons.CLeq 0
+ fc = DCons.filterCandidates [c] cands
+ length fc `shouldBe` 6
+ it "CEq / CGeq 判定" $ do
+ let cEq = DCons.LinearConstraint [0, 1, 1] DCons.CEq 0
+ cGeq = DCons.LinearConstraint [0, 1, 1] DCons.CGeq 1
+ DCons.checkRow [cEq] [1, -1, 1] `shouldBe` True
+ DCons.checkRow [cEq] [1, 1, 1] `shouldBe` False
+ DCons.checkRow [cGeq] [1, 1, 1] `shouldBe` True
+ DCons.checkRow [cGeq] [1, -1, 0] `shouldBe` False
diff --git a/test/Hanalyze/Design/Custom/AugmentSpec.hs b/test/Hanalyze/Design/Custom/AugmentSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/Custom/AugmentSpec.hs
@@ -0,0 +1,130 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.Custom.AugmentSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.ClassMetrics as CM
+import qualified Hanalyze.Design.Optimal as OPT
+import qualified Hanalyze.Design.Custom.Factor as CF
+import qualified Hanalyze.Design.Custom.Model as CM
+import qualified Hanalyze.Design.Custom.Coordinate as CX
+import qualified Hanalyze.Design.Custom.Augment as CAUG
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Custom.Augment (Phase 25-6/7/8)" $ do
+ let f1a = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ f2a = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ fcA = CF.Factor "cat" (CF.Categorical ["A","B"]) CF.Controllable
+ modelA = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ rawExisting = LA.fromLists [[-1,-1],[1,-1],[-1,1],[1,1]]
+ baseSpec = CX.CustomDesignSpec
+ { CX.cdsFactors = [f1a, f2a]
+ , CX.cdsModel = modelA
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 4
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = CX.defaultBudget
+ , CX.cdsSeed = Just 0
+ , CX.cdsInitial = Just rawExisting
+
+ , CX.cdsDJConvention = False
+ }
+ it "cdsInitial = Nothing で Left" $ do
+ let s = baseSpec { CX.cdsInitial = Nothing }
+ r <- CAUG.augmentMenu s (CAUG.Replicate 1)
+ case r of Left _ -> pure (); Right _ -> expectationFailure "expected Left"
+ it "Replicate 2: 既存 4 行を 2 回複製、 合計 12 行" $ do
+ Right r <- CAUG.augmentMenu baseSpec (CAUG.Replicate 2)
+ LA.rows (CAUG.amrMatrix r) `shouldBe` 12
+ CAUG.amrAdded r `shouldBe` 8
+ CAUG.amrMethod r `shouldBe` "Replicate"
+ it "AddCenter 3: 中心 3 行追加 (全 0)" $ do
+ Right r <- CAUG.augmentMenu baseSpec (CAUG.AddCenter 3)
+ LA.rows (CAUG.amrMatrix r) `shouldBe` 7
+ let lastRows = drop 4 (LA.toLists (CAUG.amrMatrix r))
+ all (all (== 0)) lastRows `shouldBe` True
+ it "AddAxial α=1.5: 連続 2 因子 → 4 axial 点追加 (2 * 2 factors)" $ do
+ Right r <- CAUG.augmentMenu baseSpec (CAUG.AddAxial 1.5 False)
+ LA.rows (CAUG.amrMatrix r) `shouldBe` 8
+ CAUG.amrAdded r `shouldBe` 4
+ let axial = drop 4 (LA.toLists (CAUG.amrMatrix r))
+ -- 各 axial 行は 1 因子だけ ±1.5、 残り 0
+ all (\row -> length (filter (\v -> abs v > 1e-9) row) == 1) axial `shouldBe` True
+ it "Phase 28-10 AddAxial rawUnits=True: Continuous (500, 560) で center 530 ± α·30" $ do
+ let fT = CF.Factor "T" (CF.Continuous 500 560) CF.Controllable
+ rawExisting' = LA.fromLists [[500], [560]]
+ spec' = CX.CustomDesignSpec
+ { CX.cdsFactors = [fT]
+ , CX.cdsModel = CM.Model [CM.TIntercept, CM.TMain "T"] CM.NCoded
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 2
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = CX.defaultBudget
+ , CX.cdsSeed = Just 1
+ , CX.cdsInitial = Just rawExisting'
+ , CX.cdsDJConvention = False
+ }
+ Right r <- CAUG.augmentMenu spec' (CAUG.AddAxial 1.4 True)
+ let axial = drop 2 (LA.toLists (CAUG.amrMatrix r))
+ -- center=530、 half-range=30、 axial = 530 ± 1.4·30 = 530 ± 42 = [488, 572]
+ axial `shouldBe` [[572], [488]]
+ it "AddRuns 2: 候補集合から 2 行追加" $ do
+ Right r <- CAUG.augmentMenu baseSpec (CAUG.AddRuns 2)
+ LA.rows (CAUG.amrMatrix r) `shouldBe` 6
+ CAUG.amrAdded r `shouldBe` 2
+ it "Phase 28-7 Foldover CategoricalSwap: cat 因子 A→B / B→A を swap した行追加" $ do
+ let fc = CF.Factor "c" (CF.Categorical ["A","B","C"]) CF.Controllable
+ fx = CF.Factor "x" (CF.Continuous (-1) 1) CF.Controllable
+ existing = LA.fromLists [[0, -1], [1, 1], [2, 0]] -- c=A/B/C、 x=-1/1/0
+ spec' = CX.CustomDesignSpec
+ { CX.cdsFactors = [fc, fx]
+ , CX.cdsModel = CM.Model [CM.TIntercept] CM.NCoded
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 3
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = CX.defaultBudget
+ , CX.cdsSeed = Just 1
+ , CX.cdsInitial = Just existing
+ , CX.cdsDJConvention = False
+ }
+ Right r <- CAUG.augmentMenu spec'
+ (CAUG.Foldover (CAUG.CategoricalSwap [("c", [("A","B"),("B","A")])]))
+ let swapped = drop 3 (LA.toLists (CAUG.amrMatrix r))
+ -- 期待: A(0) → B(1)、 B(1) → A(0)、 C(2) はそのまま
+ -- x 列はそのまま
+ swapped `shouldBe` [[1, -1], [0, 1], [2, 0]]
+ it "Foldover Full: 連続 2 因子 → 全部の符号 flip した 4 行追加" $ do
+ Right r <- CAUG.augmentMenu baseSpec (CAUG.Foldover CAUG.FullFoldover)
+ LA.rows (CAUG.amrMatrix r) `shouldBe` 8
+ let flipped = drop 4 (LA.toLists (CAUG.amrMatrix r))
+ flipped `shouldBe` [[1,1],[-1,1],[1,-1],[-1,-1]]
+ it "Foldover Partial [x1]: x1 のみ flip" $ do
+ Right r <- CAUG.augmentMenu baseSpec
+ (CAUG.Foldover (CAUG.PartialFoldover ["x1"]))
+ let flipped = drop 4 (LA.toLists (CAUG.amrMatrix r))
+ flipped `shouldBe` [[1,-1],[-1,-1],[1,1],[-1,1]]
+ it "Replicate 0 は Left" $ do
+ r <- CAUG.augmentMenu baseSpec (CAUG.Replicate 0)
+ case r of Left _ -> pure (); Right _ -> expectationFailure "expected Left"
diff --git a/test/Hanalyze/Design/Custom/BayesianSpec.hs b/test/Hanalyze/Design/Custom/BayesianSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/Custom/BayesianSpec.hs
@@ -0,0 +1,145 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.Custom.BayesianSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.ClassMetrics as CM
+import qualified Hanalyze.Design.Optimal as OPT
+import qualified Hanalyze.Design.Custom.Factor as CF
+import qualified Hanalyze.Design.Custom.Model as CM
+import qualified Hanalyze.Design.Custom.Coordinate as CX
+import qualified Hanalyze.Design.Custom.Compare as CCMP
+import qualified Hanalyze.Design.Custom.Bayesian as CB
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Custom.Bayesian (Phase 26 BayesianD)" $ do
+ let f1b = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ f2b = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ modelRSM = CM.Model
+ [ CM.TIntercept, CM.TMain "x1", CM.TMain "x2"
+ , CM.TInter ["x1","x2"]
+ , CM.TPower "x1" 2, CM.TPower "x2" 2
+ ] CM.NCoded
+ it "priorPrecisionDefault: intercept / 主効果 = 0、 2fi / 二乗 = τ²" $ do
+ let pp = CB.priorPrecisionDefault [f1b, f2b] modelRSM 1.5
+ km = LA.fromLists (CB.precisionToMatrix pp)
+ LA.rows km `shouldBe` 6
+ LA.cols km `shouldBe` 6
+ -- 対角: [0 (intercept), 0 (x1), 0 (x2), 1.5 (x1*x2), 1.5 (x1²), 1.5 (x2²)]
+ LA.toList (LA.takeDiag km) `shouldBe` [0, 0, 0, 1.5, 1.5, 1.5]
+ it "bayesianDValueM: K = 0 で classic D に縮退" $ do
+ let pp = CB.PriorPrecision (LA.konst 0 (3, 3))
+ x = LA.fromLists [[1,-1,-1],[1,1,-1],[1,-1,1],[1,1,1]]
+ -- |X'X| = 64
+ CB.bayesianDValueM pp x `shouldBe` 64
+ it "bayesianDValueM: K > 0 で det(X'X + K) > det(X'X)" $ do
+ let x = LA.fromLists [[1,-1,-1],[1,1,-1],[1,-1,1],[1,1,1]]
+ k0 = CB.PriorPrecision (LA.konst 0 (3, 3))
+ k1 = CB.PriorPrecision (LA.diagl [0, 1, 1])
+ let d0 = CB.bayesianDValueM k0 x
+ d1 = CB.bayesianDValueM k1 x
+ d1 `shouldSatisfy` (> d0)
+ it "OptCriterion.BayesianD: coordinateExchange で動作 (連続 2 因子)" $ do
+ let pp = CB.priorPrecisionDefault [f1b, f2b] modelRSM 1.0
+ spec = CX.CustomDesignSpec
+ { CX.cdsFactors = [f1b, f2b]
+ , CX.cdsModel = modelRSM
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 10
+ , CX.cdsCriterion = OPT.BayesianD (CB.precisionToMatrix pp)
+ , CX.cdsBudget = CX.defaultBudget
+ { CX.dbRestarts = 3, CX.dbMaxIter = 20 }
+ , CX.cdsSeed = Just 77
+ , CX.cdsInitial = Nothing
+
+ , CX.cdsDJConvention = False
+ }
+ r <- CX.coordinateExchange spec
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right cd -> do
+ LA.rows (CX.cdMatrix cd) `shouldBe` 10
+ -- criterion 値が finite + 0 より小さい (= - det > 0)
+ CX.crCriterionValue (CX.cdReport cd) `shouldSatisfy` (< 0)
+ it "Phase 28-12a djTransformColumns: paper §2.2 例 (x²→x²-0.5、 x³→(x³-0.85x)/0.6) と一致" $ do
+ let fx = CF.Factor "x" (CF.Continuous (-1) 1) CF.Controllable
+ m = CM.Model
+ [CM.TIntercept, CM.TMain "x", CM.TPower "x" 2, CM.TPower "x" 3]
+ CM.NCoded
+ -- 候補集合: {-1, -0.5, 0, 0.5, 1} (paper §2.2 の前提)
+ cand = LA.fromLists [[-1],[-0.5],[0],[0.5],[1]]
+ -- 同じ点を「設計」 として渡す (full grid)
+ design = cand
+ nearly a b = abs (a - b) < 1e-9
+ case CM.expandDesignMatrix [fx] m design of
+ Left e -> expectationFailure (T.unpack e)
+ Right x0 ->
+ case CB.djTransformColumns [fx] m cand x0 of
+ Left e -> expectationFailure (T.unpack e)
+ Right xT -> do
+ -- 列順: [Intercept, x, x², x³] → 変換後: [1, x, x²−0.5, (x³−0.85x)/0.6]
+ LA.cols xT `shouldBe` 4
+ -- 行 0: x = -1 → [1, -1, 1-0.5=0.5, (-1+0.85)/0.6 = -0.25]
+ (xT `LA.atIndex` (0, 2)) `shouldSatisfy` nearly 0.5
+ (xT `LA.atIndex` (0, 3)) `shouldSatisfy` nearly (-0.25)
+ -- 行 1: x = -0.5 → [1, -0.5, 0.25-0.5=-0.25, (-0.125+0.425)/0.6 = 0.5]
+ (xT `LA.atIndex` (1, 2)) `shouldSatisfy` nearly (-0.25)
+ (xT `LA.atIndex` (1, 3)) `shouldSatisfy` nearly 0.5
+ -- 行 2: x = 0 → [1, 0, -0.5, 0]
+ (xT `LA.atIndex` (2, 2)) `shouldSatisfy` nearly (-0.5)
+ (xT `LA.atIndex` (2, 3)) `shouldSatisfy` nearly 0
+ -- 行 3: x = 0.5 → [1, 0.5, -0.25, -0.5]
+ (xT `LA.atIndex` (3, 2)) `shouldSatisfy` nearly (-0.25)
+ (xT `LA.atIndex` (3, 3)) `shouldSatisfy` nearly (-0.5)
+ -- 行 4: x = 1 → [1, 1, 0.5, 0.25]
+ (xT `LA.atIndex` (4, 2)) `shouldSatisfy` nearly 0.5
+ (xT `LA.atIndex` (4, 3)) `shouldSatisfy` nearly 0.25
+ -- primary 列 (0, 1) はそのまま
+ (xT `LA.atIndex` (3, 0)) `shouldSatisfy` nearly 1
+ (xT `LA.atIndex` (3, 1)) `shouldSatisfy` nearly 0.5
+ it "Phase 28-12a djFitTransform: primary/potential 分類が defaultClassifier と整合" $ do
+ let fx = CF.Factor "x" (CF.Continuous (-1) 1) CF.Controllable
+ fy = CF.Factor "y" (CF.Continuous (-1) 1) CF.Controllable
+ m = CM.Model
+ [ CM.TIntercept, CM.TMain "x", CM.TMain "y"
+ , CM.TInter ["x","y"], CM.TPower "x" 2 ]
+ CM.NCoded
+ cand = LA.fromLists [[a,b] | a <- [-1, 0, 1], b <- [-1, 0, 1]]
+ case CB.djFitTransform [fx, fy] m cand of
+ Left e -> expectationFailure (T.unpack e)
+ Right t -> do
+ -- expand 後の列: [Intercept(0), x(1), y(2), x:y(3), x²(4)]
+ -- primary: 0,1,2、 potential: 3,4
+ CB.djtPrimaryIdx t `shouldBe` [0, 1, 2]
+ CB.djtPotentialIdx t `shouldBe` [3, 4]
+ it "Compound 重み正規化: 負を 0、 合計 = 1" $ do
+ let ws = [(0.7, OPT.DOpt), (0.5, OPT.AOpt), (-0.1, OPT.IOpt)]
+ ws' = CCMP.normalizeCompoundWeights ws
+ total = sum (map fst ws')
+ abs (total - 1.0) `shouldSatisfy` (< 1e-9)
+ (fst (ws' !! 2)) `shouldBe` 0
+ it "Compound 重み合計 ≤ 0 は no-op" $ do
+ let ws = [(-1, OPT.DOpt), (-2, OPT.AOpt)]
+ CCMP.normalizeCompoundWeights ws `shouldBe` ws
diff --git a/test/Hanalyze/Design/Custom/CompareSpec.hs b/test/Hanalyze/Design/Custom/CompareSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/Custom/CompareSpec.hs
@@ -0,0 +1,285 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.Custom.CompareSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.ClassMetrics as CM
+import qualified Hanalyze.Design.Optimal as OPT
+import qualified Hanalyze.Design.Custom.Factor as CF
+import qualified Hanalyze.Design.Custom.Model as CM
+import qualified Hanalyze.Design.Custom.Constraint as CC
+import qualified Hanalyze.Design.Custom.RegionMoment as RM
+import qualified Hanalyze.Design.Custom.Coordinate as CX
+import qualified Hanalyze.Design.Custom.Compare as CCMP
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Custom.Compare (Phase 24-7 Design Evaluation)" $ do
+ -- 2² factorial 設計 (4 行) を手動で構築、 main effects model で評価
+ let f1' = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ f2' = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ modelMain = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ modelFull2fi = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"
+ , CM.TInter ["x1","x2"]] CM.NCoded
+ rawFact = LA.fromLists
+ [[-1,-1],[1,-1],[-1,1],[1,1]]
+ cdFact = CX.CustomDesign
+ { CX.cdMatrix = rawFact
+ , CX.cdFactors = [f1', f2']
+ , CX.cdModel = modelMain
+ , CX.cdReport = CX.CustomDesignReport
+ { CX.crCriterion = OPT.DOpt
+ , CX.crCriterionValue = -64
+ , CX.crIterations = 0
+ , CX.crRestarts = 0
+ , CX.crConverged = True
+ , CX.crSeed = Nothing
+ }
+ }
+ cdFull = cdFact { CX.cdModel = modelFull2fi }
+ -- 非直交な 3 行設計 (主効果と 2fi が confound): aliasNormOf > 0 を出すための材料
+ rawUnbal = LA.fromLists [[-1,-1],[1,-1],[-1,1]]
+ cdUnbalMain = cdFact { CX.cdMatrix = rawUnbal, CX.cdModel = modelMain }
+ cdUnbalFull = cdFact { CX.cdMatrix = rawUnbal, CX.cdModel = modelFull2fi }
+ it "compareDesigns: 2² factorial で D-eff ≈ 1.0 / 4 列 (D/A/G/I)" $ do
+ let dc = CCMP.compareDesigns [("F2", cdFact)]
+ LA.rows (CCMP.dcEffTable dc) `shouldBe` 1
+ LA.cols (CCMP.dcEffTable dc) `shouldBe` 4
+ (CCMP.dcEffTable dc `LA.atIndex` (0, 0)) `shouldSatisfy` (> 0.99)
+ it "fdsVector: 長さ 500 ・昇順 sort" $ do
+ let v = CCMP.fdsVector cdFact
+ LA.size v `shouldBe` 500
+ let vs = LA.toList v
+ and (zipWith (<=) vs (tail vs)) `shouldBe` True
+ it "aliasNormOf: 完全直交 2² factorial + main-only モデルで 2fi 部分 alias = 0、 二乗項 部分は > 0 (Phase 28-6 で Z 拡張)" $ do
+ -- 2² factorial では 2fi (x1·x2) と main は orthogonal だが、
+ -- x1² = 1 (constant) で intercept と完全 alias、 Phase 28-6 拡張 Z で
+ -- alias_norm > 0 が正しい新動作
+ CCMP.aliasNormOf cdFact `shouldSatisfy` (> 0)
+ it "aliasNormOf: 非直交 3 行設計 + main-only で alias norm > 0" $ do
+ CCMP.aliasNormOf cdUnbalMain `shouldSatisfy` (> 0)
+ it "aliasNormOf: 2fi 含むモデル + Phase 28-6 で Z は二乗項のみ。 2² factorial で x1²=1 alias > 0" $ do
+ -- Phase 28-6 拡張で Z に TPower x1 2 / TPower x2 2 が残る (model に
+ -- 含まれない)、 2² factorial で x1² = 1 = intercept で完全 alias
+ CCMP.aliasNormOf cdFull `shouldSatisfy` (> 0)
+ -- cdUnbalFull は 3 行 × 4 列 full2fi で singular → NaN
+ CCMP.aliasNormOf cdUnbalFull `shouldSatisfy` isNaN
+ it "Phase 28-6 aliasNormOf: 完全 quadratic モデル (Z = 空) で alias = 0" $ do
+ -- Intercept + main + 2fi + 二乗項 全部入れれば Z = 空 → alias = 0
+ -- 3² 完全 factorial 9 行で X (9×6) を full rank に
+ let modelFullQuad = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"
+ , CM.TInter ["x1","x2"]
+ , CM.TPower "x1" 2, CM.TPower "x2" 2]
+ CM.NCoded
+ raw3by3 = LA.fromLists [[a, b] | a <- [-1, 0, 1], b <- [-1, 0, 1]]
+ cdQuad = cdFact { CX.cdMatrix = raw3by3, CX.cdModel = modelFullQuad }
+ CCMP.aliasNormOf cdQuad `shouldBe` 0
+ it "compareDesigns: main-only vs full2fi で main 側は alias > 0、 full 側は singular (NaN) (Phase 28-6 拡張 Z で挙動変化)" $ do
+ let dc = CCMP.compareDesigns
+ [("unbalMain", cdUnbalMain), ("unbalFull", cdUnbalFull)]
+ map fst (CCMP.dcFDS dc) `shouldBe` ["unbalMain", "unbalFull"]
+ map fst (CCMP.dcAliasNorm dc) `shouldBe` ["unbalMain", "unbalFull"]
+ -- 3 行 main-only: x1²/x2² と直交化されない → alias > 0
+ snd (CCMP.dcAliasNorm dc !! 0) `shouldSatisfy` (> 0)
+ -- 3 行 full2fi (4 列): X は singular (rank 3) → 0/0 = NaN
+ snd (CCMP.dcAliasNorm dc !! 1) `shouldSatisfy` isNaN
+ it "Phase 28-8 compareDesignsWithResponses: design + response から MCp/MCpk 計算" $ do
+ let f1' = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ mFull = CM.Model [CM.TIntercept, CM.TMain "x1"] CM.NCoded
+ raw = LA.fromLists [[-1],[1],[-1],[1]]
+ cd = CX.CustomDesign
+ { CX.cdMatrix = raw, CX.cdFactors = [f1'], CX.cdModel = mFull
+ , CX.cdReport = CX.CustomDesignReport
+ { CX.crCriterion = OPT.DOpt, CX.crCriterionValue = 0
+ , CX.crIterations = 0, CX.crRestarts = 0
+ , CX.crConverged = True, CX.crSeed = Nothing }
+ }
+ -- 2 応答変数 (y1, y2) 4 観測、 仕様 (LSL=-3, USL=3) で十分余裕あり
+ y = LA.fromLists [[0.1, 0.5], [-0.2, 0.4], [0.3, -0.1], [-0.4, 0.2]]
+ specs = [(-3, 3), (-3, 3)]
+ let res = CCMP.compareDesignsWithResponses [("d1", cd, y, specs)]
+ length (CCMP.dceMCp res) `shouldBe` 1
+ case snd (head (CCMP.dceMCp res)) of
+ Right v -> v `shouldSatisfy` (> 0)
+ Left e -> expectationFailure (T.unpack e)
+ it "Phase 28-9 compoundGeometric: 重み 0.5/0.5 で 2 つの efficiency の幾何平均" $ do
+ let comp = CCMP.compoundGeometric [(1.0, 0.8), (1.0, 0.5)]
+ -- 期待値: sqrt(0.8 · 0.5) = sqrt(0.4) ≈ 0.6324555
+ abs (comp - sqrt 0.4) < 1e-9 `shouldBe` True
+ it "Phase 28-9 compoundGeometric: efficiency が 0 を含めば 0" $ do
+ CCMP.compoundGeometric [(1.0, 0.8), (1.0, 0.0)] `shouldBe` 0
+ it "Phase 28-9 dEfficiency / aEfficiency: 2² factorial main-only" $ do
+ -- X = [[1,-1,-1],[1,1,-1],[1,-1,1],[1,1,1]] expand → 4×3、 X'X = 4·I_3
+ -- D-eff = (det(4·I_3) / 4^3)^(1/3) = (64/64)^(1/3) = 1.0
+ -- A-eff = 3 / (4 · trace((4·I_3)⁻¹)) = 3 / (4 · 3/4) = 1.0
+ let x = LA.fromLists [[1,-1,-1],[1,1,-1],[1,-1,1],[1,1,1]]
+ abs (CCMP.dEfficiency x - 1.0) < 1e-9 `shouldBe` True
+ abs (CCMP.aEfficiency x - 1.0) < 1e-9 `shouldBe` True
+ it "Phase 28-5 designEffs: BayesianD criterion 時に D 列が Bayesian D-eff に切替" $ do
+ -- 同じ設計行列に対し、 cdReport.crCriterion を DOpt vs BayesianD(K) で
+ -- 切り替えると、 D 列 (eff[0]) が変わる
+ let f1' = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ f2' = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ mFull = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2", CM.TInter ["x1","x2"]]
+ CM.NCoded
+ raw = LA.fromLists [[-1,-1],[1,-1],[-1,1],[1,1]]
+ cdBase = CX.CustomDesign
+ { CX.cdMatrix = raw
+ , CX.cdFactors = [f1', f2']
+ , CX.cdModel = mFull
+ , CX.cdReport = CX.CustomDesignReport
+ { CX.crCriterion = OPT.DOpt
+ , CX.crCriterionValue = 0
+ , CX.crIterations = 0
+ , CX.crRestarts = 0
+ , CX.crConverged = True
+ , CX.crSeed = Nothing
+ }
+ }
+ kBayes = [[0,0,0,0],[0,0,0,0],[0,0,0,0],[0,0,0,1.0]] -- K_jj=1 on 2fi only
+ cdBayes = cdBase
+ { CX.cdReport = (CX.cdReport cdBase)
+ { CX.crCriterion = OPT.BayesianD kBayes } }
+ let dcD = CCMP.compareDesigns [("d", cdBase)]
+ dcB = CCMP.compareDesigns [("b", cdBayes)]
+ dEffD = CCMP.dcEffTable dcD `LA.atIndex` (0, 0)
+ dEffB = CCMP.dcEffTable dcB `LA.atIndex` (0, 0)
+ -- DOpt 側 = 古典 D-eff (= 1.0 for 2² factorial)
+ -- BayesianD 側 = (det(X'X + K)/n^p)^(1/p) > 古典 D-eff (K_jj=1 を足したので det 増)
+ dEffB `shouldSatisfy` (> dEffD)
+
+ describe "Hanalyze.Design.Custom.Compare (Phase 28-4a regionMomentMatrixAnalytic)" $ do
+ -- 連続因子 z ∈ U[-1, 1]、 categorical K 水準等確率の解析積分
+ let fc1 = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ fc2 = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ fcat = CF.Factor "c" (CF.Categorical ["A","B","C"]) CF.Controllable
+ nearly a b = abs (a - b) < 1e-12
+ it "TIntercept のみ: M_R = [[1]]" $ do
+ let m = CM.Model [CM.TIntercept] CM.NCoded
+ case CCMP.regionMomentMatrixAnalytic [fc1] m of
+ Right mr -> do
+ LA.rows mr `shouldBe` 1
+ LA.cols mr `shouldBe` 1
+ (mr `LA.atIndex` (0,0)) `shouldSatisfy` nearly 1
+ Left e -> expectationFailure (show e)
+ it "Intercept + 連続 main: E[1]=1, E[x]=0, E[x²]=1/3" $ do
+ let m = CM.Model [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ case CCMP.regionMomentMatrixAnalytic [fc1, fc2] m of
+ Right mr -> do
+ (mr `LA.atIndex` (0,0)) `shouldSatisfy` nearly 1
+ (mr `LA.atIndex` (0,1)) `shouldSatisfy` nearly 0
+ (mr `LA.atIndex` (0,2)) `shouldSatisfy` nearly 0
+ (mr `LA.atIndex` (1,1)) `shouldSatisfy` nearly (1/3)
+ (mr `LA.atIndex` (2,2)) `shouldSatisfy` nearly (1/3)
+ (mr `LA.atIndex` (1,2)) `shouldSatisfy` nearly 0
+ Left e -> expectationFailure (show e)
+ it "TInter [x1,x2]: E[x1·x2]=0, E[(x1·x2)²]=1/9" $ do
+ let m = CM.Model [CM.TIntercept, CM.TInter ["x1","x2"]] CM.NCoded
+ case CCMP.regionMomentMatrixAnalytic [fc1, fc2] m of
+ Right mr -> do
+ (mr `LA.atIndex` (0,1)) `shouldSatisfy` nearly 0
+ (mr `LA.atIndex` (1,1)) `shouldSatisfy` nearly (1/9)
+ Left e -> expectationFailure (show e)
+ it "TPower x1 2: E[x1²]=1/3, E[(x1²)²]=1/5" $ do
+ let m = CM.Model [CM.TIntercept, CM.TPower "x1" 2] CM.NCoded
+ case CCMP.regionMomentMatrixAnalytic [fc1] m of
+ Right mr -> do
+ (mr `LA.atIndex` (0,1)) `shouldSatisfy` nearly (1/3)
+ (mr `LA.atIndex` (1,1)) `shouldSatisfy` nearly (1/5)
+ Left e -> expectationFailure (show e)
+ it "Categorical 3 水準 main: E[I_l]=1/3, E[I_l²]=1/3, E[I_l·I_m]=0 (l≠m)" $ do
+ let m = CM.Model [CM.TIntercept, CM.TMain "c"] CM.NCoded
+ case CCMP.regionMomentMatrixAnalytic [fcat] m of
+ Right mr -> do
+ LA.rows mr `shouldBe` 3 -- Intercept + 2 indicator cols
+ (mr `LA.atIndex` (0,1)) `shouldSatisfy` nearly (1/3)
+ (mr `LA.atIndex` (1,1)) `shouldSatisfy` nearly (1/3)
+ (mr `LA.atIndex` (2,2)) `shouldSatisfy` nearly (1/3)
+ (mr `LA.atIndex` (1,2)) `shouldSatisfy` nearly 0
+ Left e -> expectationFailure (show e)
+ it "Mixture 因子は Left (Phase 28-4a 非対応)" $ do
+ let fm = CF.Factor "w" (CF.Mixture 0 1) CF.Controllable
+ m = CM.Model [CM.TIntercept, CM.TMain "w"] CM.NCoded
+ case CCMP.regionMomentMatrixAnalytic [fm] m of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Mixture should be rejected"
+ it "Phase 28-4c regionMomentMatrixMC: 制約無しなら analytic とほぼ一致" $ do
+ let m = CM.Model [CM.TIntercept, CM.TMain "x1", CM.TPower "x1" 2] CM.NCoded
+ case (CCMP.regionMomentMatrixAnalytic [fc1] m,
+ RM.regionMomentMatrixMC 5000 [fc1] m []) of
+ (Right mA, Right mC) -> do
+ let diff i j = abs (mA `LA.atIndex` (i, j) - mC `LA.atIndex` (i, j))
+ maximum [diff i j | i <- [0..2], j <- [0..2]] `shouldSatisfy` (< 0.05)
+ _ -> expectationFailure "analytic or MC failed"
+ it "Phase 28-4c regionMomentMatrixMC: 制約 (x1 ≥ 0) で M_R が変化" $ do
+ let m = CM.Model [CM.TIntercept, CM.TMain "x1"] CM.NCoded
+ cons = [CC.LinearIneq [("x1", 1)] CC.CGeq 0]
+ case RM.regionMomentMatrixMC 5000 [fc1] m cons of
+ Right mC -> do
+ -- 制約 x1 ≥ 0 下で coded [0, 1] uniform → E[x1] = 0.5
+ (mC `LA.atIndex` (0, 1)) `shouldSatisfy` (> 0.4)
+ (mC `LA.atIndex` (0, 1)) `shouldSatisfy` (< 0.6)
+ Left e -> expectationFailure (T.unpack e)
+ it "iValueRegionM: 2² factorial main-only で p/n と異なる値 (= 縮退脱却)" $ do
+ let m = CM.Model [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ raw = LA.fromLists [[-1,-1],[1,-1],[-1,1],[1,1]]
+ case (CCMP.regionMomentMatrixAnalytic [fc1, fc2] m,
+ CM.expandDesignMatrix [fc1, fc2] m raw) of
+ (Right mr, Right x) -> do
+ let v = CCMP.iValueRegionM mr x
+ -- self-moment 版は p/n = 3/4 = 0.75。 region 版は trace(I) where
+ -- 期待される値: I = (1/n) · trace((X'X)⁻¹ · M_R)? 違う、 Iは trace((X'X)⁻¹ M_R)
+ -- 2² factorial で X'X = 4·I_3 → (X'X)⁻¹ = (1/4) I_3
+ -- M_R = diag(1, 1/3, 1/3) → trace = (1/4)·(1 + 1/3 + 1/3) = (1/4)·(5/3) = 5/12 ≈ 0.4167
+ v `shouldSatisfy` nearly (5/12)
+ _ -> expectationFailure "expand or moment failed"
+
+ describe "Hanalyze.Design.Custom.Compare (Phase 28-4b designEffs I-eff region)" $ do
+ let f1' = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ f2' = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ mMain = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ rawFact = LA.fromLists [[-1,-1],[1,-1],[-1,1],[1,1]]
+ cdFact = CX.CustomDesign
+ { CX.cdMatrix = rawFact
+ , CX.cdFactors = [f1', f2']
+ , CX.cdModel = mMain
+ , CX.cdReport = CX.CustomDesignReport
+ { CX.crCriterion = OPT.IOpt
+ , CX.crCriterionValue = 0
+ , CX.crIterations = 0
+ , CX.crRestarts = 0
+ , CX.crConverged = True
+ , CX.crSeed = Nothing
+ }
+ }
+ it "compareDesigns: I-eff (4列目) = 1/(n·trace) = 1/(4·5/12) = 0.6 (region 版)" $ do
+ let dc = CCMP.compareDesigns [("F2", cdFact)]
+ iE = CCMP.dcEffTable dc `LA.atIndex` (0, 3)
+ -- 旧 self-moment 版なら 1/p = 1/3 ≈ 0.333、 region 版は 0.6
+ abs (iE - 0.6) < 1e-9 `shouldBe` True
diff --git a/test/Hanalyze/Design/Custom/CoordinateSpec.hs b/test/Hanalyze/Design/Custom/CoordinateSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/Custom/CoordinateSpec.hs
@@ -0,0 +1,268 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.Custom.CoordinateSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Unboxed as VU
+import qualified Hanalyze.Stat.ClassMetrics as CM
+import qualified Hanalyze.Design.Optimal as OPT
+import qualified Hanalyze.Design.Custom.Factor as CF
+import qualified Hanalyze.Design.Custom.Model as CM
+import qualified Hanalyze.Design.Custom.Constraint as CC
+import qualified Hanalyze.Design.Custom.Coordinate as CX
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Custom.Coordinate (Phase 24-3 Coordinate Exchange)" $ do
+ let fx1 = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ fx2 = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ fCat = CF.Factor "cat" (CF.Categorical ["A","B"]) CF.Controllable
+ modelMain2 = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ budget = CX.defaultBudget
+ { CX.dbRestarts = 3
+ , CX.dbMaxIter = 30
+ , CX.dbCxStepGrid = 11
+ }
+ baseSpec = CX.CustomDesignSpec
+ { CX.cdsFactors = [fx1, fx2]
+ , CX.cdsModel = modelMain2
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 6
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = budget
+ , CX.cdsSeed = Just 42
+ , CX.cdsInitial = Nothing
+
+ , CX.cdsDJConvention = False
+ }
+ it "gridForBudget: 21 点 grid は [-1, 1] の等間隔" $ do
+ let g = CX.gridForBudget CX.defaultBudget
+ VU.length g `shouldBe` 21
+ g VU.! 0 `shouldBe` (-1)
+ g VU.! 20 `shouldBe` 1
+ g VU.! 10 `shouldBe` 0
+ it "factorGrid: Continuous は dbCxStepGrid 点 / Categorical は [0..K-1]" $ do
+ let gCont = CX.factorGrid CX.defaultBudget fx1
+ gCat = CX.factorGrid CX.defaultBudget fCat -- K=2
+ VU.length gCont `shouldBe` 21
+ VU.toList gCat `shouldBe` [0, 1]
+ it "dbRestarts < 1 は Left" $ do
+ let spec = baseSpec { CX.cdsBudget = budget { CX.dbRestarts = 0 } }
+ r <- CX.coordinateExchange spec
+ case r of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+ it "D-opt: 連続 2 因子 main-effect モデルで factorial 2² 設計に近い |det| を得る" $ do
+ r <- CX.coordinateExchange baseSpec
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right cd -> do
+ -- 戻り値の整合
+ LA.rows (CX.cdMatrix cd) `shouldBe` 6
+ LA.cols (CX.cdMatrix cd) `shouldBe` 2
+ -- raw matrix は [-1, 1] grid 内
+ let vs = concat (LA.toLists (CX.cdMatrix cd))
+ all (\v -> v >= -1.0001 && v <= 1.0001) vs `shouldBe` True
+ -- D 値 = −critValue (最小化方向)
+ let dval = - (CX.crCriterionValue (CX.cdReport cd))
+ dval `shouldSatisfy` (> 0)
+ -- 6 点で main+intercept (3 列) なら |X'X| は概ね 6^3 = 216 付近が上限
+ -- (各列ノルム² ≤ 6、 直交時に等号)。 0.7 倍 = 151.2 以上を要求。
+ dval `shouldSatisfy` (> 150)
+ it "D-opt: ランダム単 start より multi-start が同等以上の D 値" $ do
+ let spec1 = baseSpec { CX.cdsBudget = budget { CX.dbRestarts = 1 }
+ , CX.cdsSeed = Just 7 }
+ spec5 = baseSpec { CX.cdsBudget = budget { CX.dbRestarts = 5 }
+ , CX.cdsSeed = Just 7 }
+ r1 <- CX.coordinateExchange spec1
+ r5 <- CX.coordinateExchange spec5
+ case (r1, r5) of
+ (Right cd1, Right cd5) -> do
+ let d1 = - CX.crCriterionValue (CX.cdReport cd1)
+ d5 = - CX.crCriterionValue (CX.cdReport cd5)
+ (d5 + 1e-9) `shouldSatisfy` (>= d1)
+ _ -> expectationFailure "both runs should return Right"
+ it "critValueM (DOpt): D 値が古典 dValue と一致" $ do
+ let x = LA.fromLists [[1, -1, -1], [1, 1, -1], [1, -1, 1], [1, 1, 1]]
+ c = CX.critValueM OPT.DOpt x
+ c `shouldBe` (-64) -- |X'X| = 4 * 4 * 4 = 64
+ -- Phase 24-4 hybrid: continuous + categorical 混合
+ it "hybrid: x1 (連続) + cat (K=2) の D-opt 設計、 cat 列は 0/1 のみ" $ do
+ let modelMix = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "cat"] CM.NCoded
+ spec = baseSpec
+ { CX.cdsFactors = [fx1, fCat]
+ , CX.cdsModel = modelMix
+ , CX.cdsNRuns = 8
+ , CX.cdsSeed = Just 100
+ }
+ r <- CX.coordinateExchange spec
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right cd -> do
+ let m = CX.cdMatrix cd
+ LA.rows m `shouldBe` 8
+ LA.cols m `shouldBe` 2
+ -- cat 列 (index 1) は integer level index ∈ {0, 1}
+ let catCol = LA.toList (LA.flatten (LA.subMatrix (0, 1) (8, 1) m))
+ all (`elem` [0, 1]) (map round catCol :: [Int]) `shouldBe` True
+ all (\v -> abs (v - fromIntegral (round v :: Int)) < 1e-9) catCol
+ `shouldBe` True
+ -- 両 level が少なくとも 1 回ずつ出現 (= balanced に近い)
+ (0 `elem` map round catCol :: Bool) `shouldBe` True
+ (1 `elem` (map round catCol :: [Int])) `shouldBe` True
+ -- x1 列は [-1, 1]
+ let x1Col = LA.toList (LA.flatten (LA.subMatrix (0, 0) (8, 1) m))
+ all (\v -> v >= -1.0001 && v <= 1.0001) x1Col `shouldBe` True
+ -- D > 0 (full rank)
+ let dval = - CX.crCriterionValue (CX.cdReport cd)
+ dval `shouldSatisfy` (> 0)
+ -- Phase 24-5 制約統合
+ it "LinearIneq (x1 + x2 <= 1): 全 row が制約を満たす" $ do
+ let modelMain2 = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ spec = baseSpec
+ { CX.cdsFactors = [fx1, fx2]
+ , CX.cdsModel = modelMain2
+ , CX.cdsConstraints =
+ [CC.LinearIneq [("x1", 1), ("x2", 1)] CC.CLeq 1]
+ , CX.cdsNRuns = 6
+ , CX.cdsSeed = Just 21
+ }
+ r <- CX.coordinateExchange spec
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right cd -> do
+ let rows = LA.toLists (CX.cdMatrix cd)
+ ok [a, b] = a + b <= 1 + 1e-6
+ ok _ = False
+ all ok rows `shouldBe` True
+ it "Forbidden (cat=A, x1=1): 該当組合せが出現しない" $ do
+ let modelMix = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "cat"] CM.NCoded
+ spec = baseSpec
+ { CX.cdsFactors = [fx1, fCat]
+ , CX.cdsModel = modelMix
+ , CX.cdsConstraints =
+ [CC.Forbidden [("cat", CC.FVText "A"), ("x1", CC.FVDouble 1)]]
+ , CX.cdsNRuns = 8
+ , CX.cdsSeed = Just 33
+ }
+ r <- CX.coordinateExchange spec
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right cd -> do
+ let rows = LA.toLists (CX.cdMatrix cd)
+ bad [x1, c]
+ | round c == (0 :: Int) && abs (x1 - 1) < 1e-9 = True
+ | otherwise = False
+ bad _ = False
+ any bad rows `shouldBe` False
+ it "実現不能制約 (x1 >= 2): Left" $ do
+ let modelMain1 = CM.Model
+ [CM.TIntercept, CM.TMain "x1"] CM.NCoded
+ spec = baseSpec
+ { CX.cdsFactors = [fx1]
+ , CX.cdsModel = modelMain1
+ , CX.cdsConstraints =
+ [CC.LinearIneq [("x1", 1)] CC.CGeq 2] -- x1 >= 2 は [-1,1] grid で実現不能
+ , CX.cdsNRuns = 4
+ , CX.cdsSeed = Just 1
+ }
+ r <- CX.coordinateExchange spec
+ case r of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for infeasible constraint"
+
+ it "hybrid: 3 水準 categorical のみで level 全て出現可能" $ do
+ let fCat3 = CF.Factor "k" (CF.Categorical ["A","B","C"]) CF.Controllable
+ modelCat = CM.Model
+ [CM.TIntercept, CM.TMain "k"] CM.NCoded
+ spec = baseSpec
+ { CX.cdsFactors = [fCat3]
+ , CX.cdsModel = modelCat
+ , CX.cdsNRuns = 9
+ , CX.cdsSeed = Just 11
+ }
+ r <- CX.coordinateExchange spec
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right cd -> do
+ let col = LA.toList (LA.flatten (CX.cdMatrix cd))
+ idxs = map round col :: [Int]
+ all (`elem` [0, 1, 2]) idxs `shouldBe` True
+ -- D-opt なら 9 runs で各 level 3 回ずつが理論最適。
+ -- 3 level 全部出現するはず。
+ length (filter (== 0) idxs) `shouldSatisfy` (> 0)
+ length (filter (== 1) idxs) `shouldSatisfy` (> 0)
+ length (filter (== 2) idxs) `shouldSatisfy` (> 0)
+
+ -- Phase 78.M M1: IO→ST pure 化。同一 seed で純粋版が IO 版とビット一致
+ -- (アルゴリズム不変の回帰保証) + 純粋版の参照透過性を検証。
+ describe "Phase 78.M M1: coordinateExchangePure (seed 決定的 pure)" $ do
+ let fx1 = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ fx2 = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ fCat3 = CF.Factor "k" (CF.Categorical ["A","B","C"]) CF.Controllable
+ budget = CX.defaultBudget
+ { CX.dbRestarts = 3, CX.dbMaxIter = 30, CX.dbCxStepGrid = 11 }
+ mkSpec fs md nruns seed = CX.CustomDesignSpec
+ { CX.cdsFactors = fs, CX.cdsModel = md, CX.cdsConstraints = []
+ , CX.cdsNRuns = nruns, CX.cdsCriterion = OPT.DOpt, CX.cdsBudget = budget
+ , CX.cdsSeed = seed, CX.cdsInitial = Nothing, CX.cdsDJConvention = False }
+ model2 = CM.Model [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ modelCat = CM.Model [CM.TIntercept, CM.TMain "k"] CM.NCoded
+
+ it "純粋版は IO 版と同 seed でビット一致 (連続 2 因子・RSM)" $ do
+ let spec = mkSpec [fx1, fx2] model2 6 (Just 42)
+ io <- CX.coordinateExchange spec
+ let pu = CX.coordinateExchangePure spec
+ case (io, pu) of
+ (Right cdIO, Right cdPu) -> do
+ LA.toLists (CX.cdMatrix cdIO) `shouldBe` LA.toLists (CX.cdMatrix cdPu)
+ CX.crCriterionValue (CX.cdReport cdIO)
+ `shouldBe` CX.crCriterionValue (CX.cdReport cdPu)
+ _ -> expectationFailure "expected Right from both IO and pure"
+
+ it "純粋版は IO 版と同 seed でビット一致 (categorical 因子)" $ do
+ let spec = mkSpec [fCat3] modelCat 9 (Just 11)
+ io <- CX.coordinateExchange spec
+ case (io, CX.coordinateExchangePure spec) of
+ (Right cdIO, Right cdPu) ->
+ LA.toLists (CX.cdMatrix cdIO) `shouldBe` LA.toLists (CX.cdMatrix cdPu)
+ _ -> expectationFailure "expected Right from both IO and pure"
+
+ it "純粋版は参照透過 (同 spec を 2 回呼んで同結果)" $ do
+ let spec = mkSpec [fx1, fx2] model2 6 (Just 7)
+ case (CX.coordinateExchangePure spec, CX.coordinateExchangePure spec) of
+ (Right a, Right b) ->
+ LA.toLists (CX.cdMatrix a) `shouldBe` LA.toLists (CX.cdMatrix b)
+ _ -> expectationFailure "expected Right from both pure calls"
+
+ it "seed が Nothing でも純粋版は全域 (defaultPureSeed で決定的)" $ do
+ let spec = mkSpec [fx1, fx2] model2 6 Nothing
+ case (CX.coordinateExchangePure spec, CX.coordinateExchangePure spec) of
+ (Right a, Right b) ->
+ LA.toLists (CX.cdMatrix a) `shouldBe` LA.toLists (CX.cdMatrix b)
+ _ -> expectationFailure "expected Right (total) even with Nothing seed"
diff --git a/test/Hanalyze/Design/Custom/FactorSpec.hs b/test/Hanalyze/Design/Custom/FactorSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/Custom/FactorSpec.hs
@@ -0,0 +1,172 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.Custom.FactorSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.ClassMetrics as CM
+import qualified Hanalyze.Design.Custom.Factor as CF
+import qualified Hanalyze.Design.Custom.Model as CM
+import qualified Hanalyze.Design.Custom.Constraint as CC
+import qualified Data.Map.Strict as M
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Custom.Factor / Model / Constraint (Phase 24-1 skeleton)" $ do
+ let f1 = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ f2 = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ fCat = CF.Factor "cat" (CF.Categorical ["A","B","C"]) CF.Controllable
+ factors = [f1, f2]
+ raw = LA.fromLists [[-1,-1],[1,-1],[-1,1],[1,1]]
+ modelMain = CM.Model [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ modelFull = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"
+ , CM.TInter ["x1","x2"], CM.TPower "x1" 2] CM.NCoded
+ it "Factor.factorIsContinuous / factorDimension" $ do
+ CF.factorIsContinuous f1 `shouldBe` True
+ CF.factorIsContinuous fCat `shouldBe` False
+ CF.factorDimension f1 `shouldBe` 1
+ CF.factorDimension fCat `shouldBe` 2 -- treatment coding: levels - 1
+ it "expandDesignMatrix: 主効果のみ 2² で 4×3 (intercept + x1 + x2)" $ do
+ case CM.expandDesignMatrix factors modelMain raw of
+ Left e -> expectationFailure (T.unpack e)
+ Right m -> do
+ LA.rows m `shouldBe` 4
+ LA.cols m `shouldBe` 3
+ LA.toLists m `shouldBe`
+ [[1,-1,-1],[1,1,-1],[1,-1,1],[1,1,1]]
+ it "expandDesignMatrix: 交互作用 + 二乗を含むフルモデル" $ do
+ case CM.expandDesignMatrix factors modelFull raw of
+ Left e -> expectationFailure (T.unpack e)
+ Right m -> do
+ LA.cols m `shouldBe` 5
+ -- 各 row の最後の 2 列を確認: x1*x2、 x1^2
+ let rows = LA.toLists m
+ lastTwo = map (drop 3) rows
+ lastTwo `shouldBe` [[1,1],[-1,1],[-1,1],[1,1]]
+ it "expandDesignMatrix: 列数不一致は Left" $ do
+ case CM.expandDesignMatrix factors modelMain (LA.fromLists [[1]]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+ it "expandDesignMatrix: 未知因子参照は Left" $ do
+ let m = CM.Model [CM.TMain "x9"] CM.NCoded
+ case CM.expandDesignMatrix factors m raw of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+ it "expandDesignMatrix: Categorical TMain は treatment coding で K-1 列 (Phase 24-2)" $ do
+ let fs = [fCat]
+ m = CM.Model [CM.TIntercept, CM.TMain "cat"] CM.NCoded
+ rawCat = LA.fromLists [[0],[1],[2],[0],[1]]
+ case CM.expandDesignMatrix fs m rawCat of
+ Left e -> expectationFailure (T.unpack e)
+ Right d -> do
+ LA.rows d `shouldBe` 5
+ LA.cols d `shouldBe` 3 -- intercept + (3-1) treatment cols
+ LA.toLists d `shouldBe`
+ [ [1, 0, 0] -- ref (A)
+ , [1, 1, 0] -- B
+ , [1, 0, 1] -- C
+ , [1, 0, 0]
+ , [1, 1, 0]
+ ]
+ it "expandDesignMatrix: Categorical × 連続 TInter は (K-1) 列" $ do
+ let fs = [f1, fCat]
+ m = CM.Model [CM.TInter ["x1","cat"]] CM.NCoded
+ rawMix = LA.fromLists [[-1, 0], [1, 1], [-1, 2], [1, 0]]
+ case CM.expandDesignMatrix fs m rawMix of
+ Left e -> expectationFailure (T.unpack e)
+ Right d -> do
+ LA.cols d `shouldBe` 2
+ LA.toLists d `shouldBe`
+ [ [(-1) * 0, (-1) * 0] -- cat = A → 両 indicator 0
+ , [1 * 1, 1 * 0] -- cat = B
+ , [(-1) * 0, (-1) * 1] -- cat = C
+ , [1 * 0, 1 * 0] -- cat = A
+ ]
+ it "expandDesignMatrix: Categorical raw が非整数なら Left" $ do
+ let fs = [fCat]
+ m = CM.Model [CM.TMain "cat"] CM.NCoded
+ case CM.expandDesignMatrix fs m (LA.fromLists [[0.5]]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for non-integer level index"
+ it "expandDesignMatrix: Categorical raw が範囲外なら Left" $ do
+ let fs = [fCat]
+ m = CM.Model [CM.TMain "cat"] CM.NCoded
+ case CM.expandDesignMatrix fs m (LA.fromLists [[3]]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for out-of-range index"
+ it "expandDesignMatrix: TPower を Categorical に適用すると Left" $ do
+ let fs = [fCat]
+ m = CM.Model [CM.TPower "cat" 2] CM.NCoded
+ case CM.expandDesignMatrix fs m (LA.fromLists [[0]]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for TPower on categorical"
+ it "Phase 28-1 TNested: A within B で K_B × (K_A - 1) 列、 indicator I[B=b]·I[A=a]" $ do
+ -- B = {b0,b1} (2 levels)、 A = {a0,a1,a2} (3 levels) → 2 × 2 = 4 列
+ let fA = CF.Factor "A" (CF.Categorical ["a0","a1","a2"]) CF.Controllable
+ fB = CF.Factor "B" (CF.Categorical ["b0","b1"]) CF.Controllable
+ fs = [fA, fB]
+ m = CM.Model [CM.TNested "A" "B"] CM.NCoded
+ -- 6 行: 全 (B, A) 組合せ + B=0,A=0 / B=1,A=2 を 1 行ずつ
+ raw = LA.fromLists
+ [[0, 0] -- A=a0, B=b0 → all 4 cols = 0 (a=0 は reference)
+ ,[1, 0] -- A=a1, B=b0 → col (b0, a1) = 1
+ ,[2, 0] -- A=a2, B=b0 → col (b0, a2) = 1
+ ,[0, 1] -- A=a0, B=b1 → all = 0
+ ,[1, 1] -- A=a1, B=b1 → col (b1, a1) = 1
+ ,[2, 1] -- A=a2, B=b1 → col (b1, a2) = 1
+ ]
+ case CM.expandDesignMatrix fs m raw of
+ Left e -> expectationFailure (T.unpack e)
+ Right x -> do
+ LA.rows x `shouldBe` 6
+ LA.cols x `shouldBe` 4 -- K_B(2) × (K_A-1)(2) = 4
+ -- 列順 (b, a) = (0,1), (0,2), (1,1), (1,2)
+ LA.toLists x `shouldBe`
+ [[0,0,0,0] -- A=0, B=0
+ ,[1,0,0,0] -- A=1, B=0 → col (0,1) = 1
+ ,[0,1,0,0] -- A=2, B=0 → col (0,2) = 1
+ ,[0,0,0,0] -- A=0, B=1
+ ,[0,0,1,0] -- A=1, B=1 → col (1,1) = 1
+ ,[0,0,0,1] -- A=2, B=1 → col (1,2) = 1
+ ]
+ it "modelNumColumns: Categorical を含むモデルで K-1 を考慮" $ do
+ let m = CM.Model [CM.TIntercept, CM.TMain "x1", CM.TMain "cat"
+ , CM.TInter ["x1","cat"]] CM.NCoded
+ -- 1 (intercept) + 1 (x1) + 2 (cat K-1) + 2 (x1 * cat K-1) = 6
+ CM.modelNumColumns [f1, fCat] m `shouldBe` 6
+ it "Constraint.LinearIneq 評価" $ do
+ let row = CC.compileRowFromFactors ["x1","x2"] [0.4, 0.4]
+ c = CC.LinearIneq [("x1", 1), ("x2", 1)] CC.CLeq 1
+ CC.checkRowAgainst row c `shouldBe` True
+ let row2 = CC.compileRowFromFactors ["x1","x2"] [0.7, 0.7]
+ CC.checkRowAgainst row2 c `shouldBe` False
+ it "Constraint.Forbidden + Conditional 評価" $ do
+ let row = M.fromList [("cat", CC.FVText "A"), ("temp", CC.FVDouble 90)]
+ forb = CC.Forbidden [("cat", CC.FVText "A"), ("temp", CC.FVDouble 90)]
+ cond = CC.Conditional
+ (CC.GuardEq "cat" (CC.FVText "A"))
+ [CC.RangeBound "temp" 0 80]
+ CC.checkRowAgainst row forb `shouldBe` False -- forbidden 一致 = 違反
+ CC.checkRowAgainst row cond `shouldBe` False -- cat=A の時 temp ≤ 80 を要求、 90 は違反
diff --git a/test/Hanalyze/Design/Custom/GoldenSpec.hs b/test/Hanalyze/Design/Custom/GoldenSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/Custom/GoldenSpec.hs
@@ -0,0 +1,137 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.Custom.GoldenSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.ClassMetrics as CM
+import qualified Hanalyze.Design.Optimal as OPT
+import qualified Hanalyze.Design.Custom.Factor as CF
+import qualified Hanalyze.Design.Custom.Model as CM
+import qualified Hanalyze.Design.Custom.Constraint as CC
+import qualified Hanalyze.Design.Custom.Coordinate as CX
+import qualified Hanalyze.Design.Custom.Compare as CCMP
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Custom Design ゴールデン例題 (Phase 24-9)" $ do
+ -- Example 1: 2 因子 2nd-order RSM (full quadratic、 p_terms = 6)
+ it "golden ex1: 2 factor + 2nd-order RSM、 D-eff > 0、 全 grid 内" $ do
+ let f1g = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ f2g = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ modelRSM = CM.Model
+ [ CM.TIntercept
+ , CM.TMain "x1", CM.TMain "x2"
+ , CM.TInter ["x1","x2"]
+ , CM.TPower "x1" 2, CM.TPower "x2" 2
+ ] CM.NCoded
+ spec = CX.CustomDesignSpec
+ { CX.cdsFactors = [f1g, f2g]
+ , CX.cdsModel = modelRSM
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 12
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = CX.defaultBudget
+ , CX.cdsSeed = Just 42
+ , CX.cdsInitial = Nothing
+
+ , CX.cdsDJConvention = False
+ }
+ r <- CX.coordinateExchange spec
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right cd -> do
+ LA.rows (CX.cdMatrix cd) `shouldBe` 12
+ LA.cols (CX.cdMatrix cd) `shouldBe` 2
+ let vs = concat (LA.toLists (CX.cdMatrix cd))
+ all (\v -> v >= -1.0001 && v <= 1.0001) vs `shouldBe` True
+ -- D 値 > 0 (非特異)
+ let dval = - CX.crCriterionValue (CX.cdReport cd)
+ dval `shouldSatisfy` (> 0)
+ -- D-eff via Compare も 0 より大きい
+ let dc = CCMP.compareDesigns [("rsm", cd)]
+ (CCMP.dcEffTable dc `LA.atIndex` (0, 0)) `shouldSatisfy` (> 0.4)
+ -- Example 2: 1 連続 + 1 categorical(3) + main + interaction
+ it "golden ex2: 1 cont + 1 cat(3) + main+int model、 各 cat level 出現" $ do
+ let fc = CF.Factor "x" (CF.Continuous (-1) 1) CF.Controllable
+ fk = CF.Factor "k" (CF.Categorical ["A","B","C"]) CF.Controllable
+ model = CM.Model
+ [ CM.TIntercept
+ , CM.TMain "x", CM.TMain "k"
+ , CM.TInter ["x","k"]
+ ] CM.NCoded
+ spec = CX.CustomDesignSpec
+ { CX.cdsFactors = [fc, fk]
+ , CX.cdsModel = model
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 12
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = CX.defaultBudget
+ , CX.cdsSeed = Just 100
+ , CX.cdsInitial = Nothing
+
+ , CX.cdsDJConvention = False
+ }
+ r <- CX.coordinateExchange spec
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right cd -> do
+ LA.rows (CX.cdMatrix cd) `shouldBe` 12
+ let kCol = LA.toList (LA.flatten (LA.subMatrix (0, 1) (12, 1) (CX.cdMatrix cd)))
+ ks = map (round :: Double -> Int) kCol
+ all (`elem` [0, 1, 2]) ks `shouldBe` True
+ -- D-opt なら全 3 level が出現するはず (= balanced 設計の必要条件)
+ length (filter (== 0) ks) `shouldSatisfy` (> 0)
+ length (filter (== 1) ks) `shouldSatisfy` (> 0)
+ length (filter (== 2) ks) `shouldSatisfy` (> 0)
+ -- Example 3: LinearIneq 制約 + 2 factor main
+ it "golden ex3: LinearIneq (x1+x2 <= 0.5) で全 row が制約満足" $ do
+ let f1g = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ f2g = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ modelMain = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ spec = CX.CustomDesignSpec
+ { CX.cdsFactors = [f1g, f2g]
+ , CX.cdsModel = modelMain
+ , CX.cdsConstraints =
+ [CC.LinearIneq [("x1", 1), ("x2", 1)] CC.CLeq 0.5]
+ , CX.cdsNRuns = 8
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = CX.defaultBudget
+ , CX.cdsSeed = Just 21
+ , CX.cdsInitial = Nothing
+
+ , CX.cdsDJConvention = False
+ }
+ r <- CX.coordinateExchange spec
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right cd -> do
+ LA.rows (CX.cdMatrix cd) `shouldBe` 8
+ let rows = LA.toLists (CX.cdMatrix cd)
+ ok [a, b] = a + b <= 0.5 + 1e-6
+ ok _ = False
+ all ok rows `shouldBe` True
+ -- D 値 > 0 (非特異)
+ let dval = - CX.crCriterionValue (CX.cdReport cd)
+ dval `shouldSatisfy` (> 0)
diff --git a/test/Hanalyze/Design/Custom/PowerSpec.hs b/test/Hanalyze/Design/Custom/PowerSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/Custom/PowerSpec.hs
@@ -0,0 +1,80 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.Custom.PowerSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.ClassMetrics as CM
+import qualified Hanalyze.Design.Optimal as OPT
+import qualified Hanalyze.Design.Custom.Factor as CF
+import qualified Hanalyze.Design.Custom.Model as CM
+import qualified Hanalyze.Design.Custom.Coordinate as CX
+import qualified Hanalyze.Design.Custom.Power as CPW
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Custom.Power (Phase 24-8 designPower)" $ do
+ -- Phase 24-7 で使った 2² factorial 設計 cdFact を再利用
+ let f1p = CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ f2p = CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable
+ mp = CM.Model
+ [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"
+ , CM.TInter ["x1","x2"]] CM.NCoded
+ rawFact2 = LA.fromLists
+ [[-1,-1],[1,-1],[-1,1],[1,1]
+ ,[-1,-1],[1,-1],[-1,1],[1,1]] -- 8 行 (n - p = 8 - 4 = 4 で df2 > 0)
+ cdPow = CX.CustomDesign
+ { CX.cdMatrix = rawFact2
+ , CX.cdFactors = [f1p, f2p]
+ , CX.cdModel = mp
+ , CX.cdReport = CX.CustomDesignReport
+ { CX.crCriterion = OPT.DOpt
+ , CX.crCriterionValue = -1, CX.crIterations = 0
+ , CX.crRestarts = 0, CX.crConverged = True, CX.crSeed = Nothing
+ }
+ }
+ it "termName: 各 ADT が canonical 名に変換される" $ do
+ CPW.termName CM.TIntercept `shouldBe` "(Intercept)"
+ CPW.termName (CM.TMain "x1") `shouldBe` "x1"
+ CPW.termName (CM.TInter ["x1","x2"]) `shouldBe` "x1:x2"
+ CPW.termName (CM.TPower "x1" 2) `shouldBe` "x1^2"
+ it "termColumnIndices: 連続のみで各 term が単一 column" $ do
+ let m = CM.Model [CM.TIntercept, CM.TMain "x1", CM.TMain "x2"] CM.NCoded
+ CPW.termColumnIndices [f1p, f2p] m
+ `shouldBe` [("(Intercept)", [0]), ("x1", [1]), ("x2", [2])]
+ it "designPower: effect 大 → power 増加 (x1 main)" $ do
+ let p1 = CPW.designPower cdPow 1.0 [("x1", 0.5)] 0.05
+ p2 = CPW.designPower cdPow 1.0 [("x1", 2.0)] 0.05
+ length p1 `shouldBe` 1
+ length p2 `shouldBe` 1
+ CPW.dpPower (head p2) `shouldSatisfy` (> CPW.dpPower (head p1))
+ it "designPower: effect 0 で power ≈ α" $ do
+ let p = CPW.designPower cdPow 1.0 [("x1", 0)] 0.05
+ CPW.dpPower (head p) `shouldSatisfy` (\v -> v >= 0 && v <= 0.10)
+ it "designPower: 未知 term は power = 0" $ do
+ let p = CPW.designPower cdPow 1.0 [("xnope", 1.0)] 0.05
+ CPW.dpPower (head p) `shouldBe` 0
+ it "designPower: alpha / effect / term が結果に保存される" $ do
+ let [r] = CPW.designPower cdPow 1.0 [("x1", 1.5)] 0.01
+ CPW.dpTerm r `shouldBe` "x1"
+ CPW.dpEffect r `shouldBe` 1.5
+ CPW.dpAlpha r `shouldBe` 0.01
diff --git a/test/Hanalyze/Design/Custom/SplitPlotSpec.hs b/test/Hanalyze/Design/Custom/SplitPlotSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/Custom/SplitPlotSpec.hs
@@ -0,0 +1,215 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.Custom.SplitPlotSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.ClassMetrics as CM
+import qualified Hanalyze.Design.Optimal as OPT
+import qualified Hanalyze.Design.Custom.Factor as CF
+import qualified Hanalyze.Design.Custom.Model as CM
+import qualified Hanalyze.Design.Custom.Coordinate as CX
+import qualified Hanalyze.Design.Custom.SplitPlot as CSP
+import qualified Data.Vector.Storable as VS
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Custom.SplitPlot (Phase 25-3/4)" $ do
+ let fWP = CF.Factor "temp" (CF.Continuous (-1) 1) CF.HardToChange
+ fSP = CF.Factor "rate" (CF.Continuous (-1) 1) CF.Controllable
+ modelSP = CM.Model
+ [CM.TIntercept, CM.TMain "temp", CM.TMain "rate"
+ , CM.TInter ["temp","rate"]] CM.NCoded
+ spec = CX.CustomDesignSpec
+ { CX.cdsFactors = [fWP, fSP]
+ , CX.cdsModel = modelSP
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 8
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = CX.defaultBudget
+ { CX.dbRestarts = 3, CX.dbMaxIter = 30 }
+ , CX.cdsSeed = Just 50
+ , CX.cdsInitial = Nothing
+
+ , CX.cdsDJConvention = False
+ }
+ cfg = CSP.defaultSplitPlotConfig 4 -- 4 WP × 2 runs = 8
+ it "wholePlotIndicator: 8 行 / 4 WP で [0,0,1,1,2,2,3,3]" $ do
+ VS.toList (CSP.wholePlotIndicator 8 4) `shouldBe` [0,0,1,1,2,2,3,3]
+ it "whichRoleIsWP: HardToChange 因子の index を返す" $ do
+ CSP.whichRoleIsWP [fWP, fSP] `shouldBe` [0]
+ CSP.whichRoleIsWP [fSP, fWP] `shouldBe` [1]
+ it "HardToChange 因子なしで Left" $ do
+ let s = spec { CX.cdsFactors = [fSP, fSP] }
+ r <- CSP.generateSplitPlot s cfg
+ case r of Left _ -> pure (); Right _ -> expectationFailure "expected Left"
+ it "spcNWhole < 1 で Left" $ do
+ r <- CSP.generateSplitPlot spec (CSP.SplitPlotConfig 0 1.0 Nothing)
+ case r of Left _ -> pure (); Right _ -> expectationFailure "expected Left"
+ it "Phase 28-2 generateSplitPlot: strip-plot (VeryHardToChange) 因子は strip 内で constant" $ do
+ let fWP = CF.Factor "wp" (CF.Continuous (-1) 1) CF.HardToChange
+ fStrip = CF.Factor "strip" (CF.Continuous (-1) 1) CF.VeryHardToChange
+ fSP = CF.Factor "sp" (CF.Continuous (-1) 1) CF.Controllable
+ specStrip = CX.CustomDesignSpec
+ { CX.cdsFactors = [fWP, fStrip, fSP]
+ , CX.cdsModel = CM.Model
+ [CM.TIntercept, CM.TMain "wp", CM.TMain "strip", CM.TMain "sp"] CM.NCoded
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 12 -- 4 WP × 3 strip
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = (CX.defaultBudget)
+ { CX.dbRestarts = 1, CX.dbMaxIter = 5 }
+ , CX.cdsSeed = Just 3
+ , CX.cdsInitial = Nothing
+ , CX.cdsDJConvention = False
+ }
+ cfgStrip = CSP.SplitPlotConfig 4 1.0 (Just 3)
+ r <- CSP.generateSplitPlot specStrip cfgStrip
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right spd -> do
+ let n = 12
+ wpId = CSP.spdWholePlotId spd
+ stripId = case CSP.spdSubPlotId spd of
+ Just s -> s
+ Nothing -> error "stripId should be Just in 28-2 strip-plot"
+ wpCol = LA.toList (LA.flatten (LA.subMatrix (0, 0) (n, 1) (CSP.spdMatrix spd)))
+ stripCol = LA.toList (LA.flatten (LA.subMatrix (0, 1) (n, 1) (CSP.spdMatrix spd)))
+ wpConstantInWP w =
+ let vs = [wpCol !! i | i <- [0 .. n-1], wpId VS.! i == w]
+ in all (\x -> abs (x - head vs) < 1e-9) vs
+ stripConstantInStrip s =
+ let vs = [stripCol !! i | i <- [0 .. n-1], stripId VS.! i == s]
+ in all (\x -> abs (x - head vs) < 1e-9) vs
+ all wpConstantInWP [0..3] `shouldBe` True
+ all stripConstantInStrip [0..2] `shouldBe` True
+ it "Phase 28-3 generateSplitPlot: Categorical WP 因子 (machine) も WP 内で constant" $ do
+ let fMachine = CF.Factor "machine" (CF.Categorical ["A","B"]) CF.HardToChange
+ fX = CF.Factor "x" (CF.Continuous (-1) 1) CF.Controllable
+ specCat = CX.CustomDesignSpec
+ { CX.cdsFactors = [fMachine, fX]
+ , CX.cdsModel = CM.Model
+ [CM.TIntercept, CM.TMain "machine", CM.TMain "x"] CM.NCoded
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 8
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = (CX.defaultBudget)
+ { CX.dbRestarts = 1, CX.dbMaxIter = 5 }
+ , CX.cdsSeed = Just 7
+ , CX.cdsInitial = Nothing
+ , CX.cdsDJConvention = False
+ }
+ cfgCat = CSP.SplitPlotConfig 4 1.0 Nothing
+ r <- CSP.generateSplitPlot specCat cfgCat
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right spd -> do
+ let wpId = CSP.spdWholePlotId spd
+ machineCol = LA.toList (LA.flatten (LA.subMatrix (0, 0) (8, 1) (CSP.spdMatrix spd)))
+ perWP w = [ machineCol !! i | i <- [0 .. 7], wpId VS.! i == w ]
+ constant xs = all (\x -> abs (x - head xs) < 1e-9) xs
+ all constant [perWP w | w <- [0..3]] `shouldBe` True
+ it "generateSplitPlot: WP 因子 (temp) は WP 内で constant" $ do
+ r <- CSP.generateSplitPlot spec cfg
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right spd -> do
+ LA.rows (CSP.spdMatrix spd) `shouldBe` 8
+ let wpId = CSP.spdWholePlotId spd
+ wpCol = LA.toList (LA.flatten (LA.subMatrix (0, 0) (8, 1) (CSP.spdMatrix spd)))
+ -- 各 WP 内で temp 値が一致しているか
+ let perWP w = [ wpCol !! i | i <- [0 .. 7], wpId VS.! i == w ]
+ constant xs = all (\x -> abs (x - head xs) < 1e-9) xs
+ all constant [perWP w | w <- [0..3]] `shouldBe` True
+
+ describe "Phase 27-2 pinned: Jones-Goos (2012) Table 2 D-criterion regression" $ do
+ -- 一次根拠: Jones & Goos (2012) "I-optimal versus D-optimal split-plot
+ -- response surface designs" (U Antwerp Research Paper 2012-002) Table 2、
+ -- 20-run split-plot D-Optimal design (4 WP × 5 SP、 1 WP w + 1 SP s、
+ -- full quadratic、 η=1)。 Phase 27-2 で hanalyze の SplitPlot
+ -- D-opt 結果が同じ D-criterion (= 2684.444...) に到達することを確認済。
+ -- 本テストは regression 防止 (CI 常時検証)。 bench/custom-design/REPORT.md
+ -- §Phase 27-2 参照。
+ let factorsJG =
+ [ CF.Factor "w" (CF.Continuous (-1) 1) CF.HardToChange
+ , CF.Factor "s" (CF.Continuous (-1) 1) CF.Controllable
+ ]
+ modelJG = CM.Model
+ [ CM.TIntercept
+ , CM.TMain "w", CM.TMain "s"
+ , CM.TInter ["w","s"]
+ , CM.TPower "w" 2, CM.TPower "s" 2
+ ] CM.NCoded
+ specJG = CX.CustomDesignSpec
+ { CX.cdsFactors = factorsJG
+ , CX.cdsModel = modelJG
+ , CX.cdsConstraints = []
+ , CX.cdsNRuns = 20
+ , CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = CX.defaultBudget
+ , CX.cdsSeed = Just 42
+ , CX.cdsInitial = Nothing
+
+ , CX.cdsDJConvention = False
+ }
+ cfgJG = CSP.SplitPlotConfig
+ { CSP.spcNWhole = 4, CSP.spcVarRatio = 1.0, CSP.spcNStrip = Nothing }
+ it "Jones-Goos golden: SplitPlot D-opt の det(X' M⁻¹ X) ≥ 2684.0" $ do
+ r <- CSP.generateSplitPlot specJG cfgJG
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right sp -> do
+ -- spdGEFFEst = -det(X' M⁻¹ X)、 文献値 2684.4444...
+ let dval = - CSP.spdGEFFEst sp
+ dval `shouldSatisfy` (>= 2684.0)
+ -- 0.05% 以内で文献値と一致 (現状実測 1.0000、 retry 余地 0.0005)
+ abs (dval - 2684.4444444444) `shouldSatisfy` (< 1.5)
+
+ -- Phase 78.M M1: IO→ST pure 化。純粋版が IO 版とビット一致 (アルゴリズム不変)。
+ describe "Phase 78.M M1: generateSplitPlotPure (seed 決定的 pure)" $ do
+ let fWP = CF.Factor "temp" (CF.Continuous (-1) 1) CF.HardToChange
+ fSP = CF.Factor "rate" (CF.Continuous (-1) 1) CF.Controllable
+ modelSP = CM.Model
+ [CM.TIntercept, CM.TMain "temp", CM.TMain "rate"
+ , CM.TInter ["temp","rate"]] CM.NCoded
+ specSP = CX.CustomDesignSpec
+ { CX.cdsFactors = [fWP, fSP], CX.cdsModel = modelSP
+ , CX.cdsConstraints = [], CX.cdsNRuns = 8, CX.cdsCriterion = OPT.DOpt
+ , CX.cdsBudget = CX.defaultBudget { CX.dbRestarts = 3, CX.dbMaxIter = 30 }
+ , CX.cdsSeed = Just 50, CX.cdsInitial = Nothing, CX.cdsDJConvention = False }
+ cfgSP = CSP.defaultSplitPlotConfig 4
+
+ it "純粋版は IO 版と同 seed でビット一致 (split-plot)" $ do
+ io <- CSP.generateSplitPlot specSP cfgSP
+ case (io, CSP.generateSplitPlotPure specSP cfgSP) of
+ (Right a, Right b) -> do
+ LA.toLists (CSP.spdMatrix a) `shouldBe` LA.toLists (CSP.spdMatrix b)
+ CSP.spdGEFFEst a `shouldBe` CSP.spdGEFFEst b
+ VS.toList (CSP.spdWholePlotId a) `shouldBe` VS.toList (CSP.spdWholePlotId b)
+ _ -> expectationFailure "expected Right from both IO and pure"
+
+ it "純粋版は参照透過 (同 spec を 2 回で同結果)" $ do
+ case (CSP.generateSplitPlotPure specSP cfgSP, CSP.generateSplitPlotPure specSP cfgSP) of
+ (Right a, Right b) ->
+ LA.toLists (CSP.spdMatrix a) `shouldBe` LA.toLists (CSP.spdMatrix b)
+ _ -> expectationFailure "expected Right from both pure calls"
diff --git a/test/Hanalyze/Design/DSDSpec.hs b/test/Hanalyze/Design/DSDSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/DSDSpec.hs
@@ -0,0 +1,117 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.DSDSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Design.DSD as DSD
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.DSD (Phase 6.2)" $ do
+ it "sanity: k < 2 は Left" $ do
+ case DSD.dsdDesign 0 of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for k=0"
+ case DSD.dsdDesign 1 of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for k=1"
+
+ it "k=4: verified DSD (Jones-Nachtsheim conference matrix 由来)" $
+ case DSD.dsdDesign 4 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ DSD.dsdNFactors r `shouldBe` 4
+ DSD.dsdNRuns r `shouldBe` 9 -- = 2*4 + 1
+ DSD.dsdHasOptimal r `shouldBe` True
+ LA.rows (DSD.dsdMatrix r) `shouldBe` 9
+ LA.cols (DSD.dsdMatrix r) `shouldBe` 4
+
+ it "k=4: row 0 (center) は全 0" $
+ case DSD.dsdDesign 4 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ let row0 = LA.toList (LA.flatten (LA.tr (DSD.dsdMatrix r) LA.¿ [0]))
+ row0 `shouldBe` replicate 4 0.0
+
+ it "k=4: 各 row (center 除く) は値域 {-1, 0, +1}" $
+ case DSD.dsdDesign 4 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r ->
+ all (\v -> v == -1 || v == 0 || v == 1)
+ (LA.toList (LA.flatten (DSD.dsdMatrix r))) `shouldBe` True
+
+ it "k=4: 各 row (center 除く) に 0 が ちょうど 1 個" $
+ case DSD.dsdDesign 4 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ let rs = LA.toLists (DSD.dsdMatrix r)
+ nonCenter = tail rs -- skip row 0
+ zeroCount row = length (filter (== 0) row)
+ all (\row -> zeroCount row == 1) nonCenter `shouldBe` True
+
+ it "k=4: foldover 構造 (row i+k = -row i for i in 1..k)" $
+ case DSD.dsdDesign 4 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ let rs = LA.toLists (DSD.dsdMatrix r)
+ -- rows 1..4 と rows 5..8 が foldover ペア
+ forward = take 4 (drop 1 rs)
+ backward = take 4 (drop 5 rs)
+ negated = map (map negate) forward
+ backward `shouldBe` negated
+
+ it "k=4: conference matrix 検証 C·Cᵀ = (n-1)·I (verified DSD のみ)" $
+ case DSD.dsdDesign 4 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ -- conference matrix = rows 1..4 of dsdMatrix
+ let cMat = (DSD.dsdMatrix r) LA.? [1, 2, 3, 4]
+ prod = cMat LA.<> LA.tr cMat
+ -- (n-1) * I_4 should be diag(3, 3, 3, 3)
+ expected = LA.scale 3 (LA.ident 4)
+ diff = prod - expected
+ LA.maxElement (LA.cmap abs diff) `shouldSatisfy` (< 1e-12)
+
+ it "k=6: structural DSD (Hadamard-like 近似)" $
+ case DSD.dsdDesign 6 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ DSD.dsdNFactors r `shouldBe` 6
+ DSD.dsdNRuns r `shouldBe` 13 -- = 2*6 + 1
+ DSD.dsdHasOptimal r `shouldBe` False -- conference matrix では無い
+ let rs = LA.toLists (DSD.dsdMatrix r)
+ -- center + 2k=12 rows
+ length rs `shouldBe` 13
+ -- 各非中心行に 0 が 1 個
+ all (\row -> length (filter (== 0) row) == 1) (tail rs) `shouldBe` True
+
+ it "structural DSD の foldover 構造維持" $
+ case DSD.dsdDesign 8 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ DSD.dsdNRuns r `shouldBe` 17
+ let rs = LA.toLists (DSD.dsdMatrix r)
+ forward = take 8 (drop 1 rs)
+ backward = take 8 (drop 9 rs)
+ backward `shouldBe` map (map negate) forward
diff --git a/test/Hanalyze/Design/DiagnosticsSpec.hs b/test/Hanalyze/Design/DiagnosticsSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/DiagnosticsSpec.hs
@@ -0,0 +1,68 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.DiagnosticsSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Design.Diagnostics as DDiag
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Diagnostics (Phase 14)" $ do
+ let -- 直交設計 (full factorial 2² + intercept)
+ xOrth = LA.fromLists
+ [ [1, -1, -1]
+ , [1, 1, -1]
+ , [1, -1, 1]
+ , [1, 1, 1]
+ ]
+ -- multicollinear: 列 2 = 列 1 + 微小ノイズ
+ xCollin = LA.fromLists
+ [ [1, -1, -0.999]
+ , [1, 1, 1.001]
+ , [1, -1, -1.001]
+ , [1, 1, 0.999]
+ ]
+ it "diagnostics: 直交設計で全 efficiency が >= 0" $ do
+ let dd = DDiag.diagnostics xOrth
+ DDiag.ddDEff dd `shouldSatisfy` (> 0)
+ DDiag.ddAEff dd `shouldSatisfy` (> 0)
+ DDiag.ddGEff dd `shouldSatisfy` (> 0)
+ it "VIF: 直交設計で全列の VIF ≈ 1" $ do
+ let dd = DDiag.diagnostics xOrth
+ v = DDiag.ddVIF dd
+ LA.atIndex v 0 `shouldSatisfy` (\x -> abs (x - 1) < 1e-6)
+ LA.atIndex v 1 `shouldSatisfy` (\x -> abs (x - 1) < 1e-6)
+ LA.atIndex v 2 `shouldSatisfy` (\x -> abs (x - 1) < 1e-6)
+ it "VIF: 多重共線設計で列 1/2 の VIF が大きい" $ do
+ let dd = DDiag.diagnostics xCollin
+ v = DDiag.ddVIF dd
+ LA.atIndex v 1 `shouldSatisfy` (> 10)
+ it "diagnostics: D-efficiency は直交 > collinear" $ do
+ let dOrth = DDiag.ddDEff (DDiag.diagnostics xOrth)
+ dCol = DDiag.ddDEff (DDiag.diagnostics xCollin)
+ dOrth `shouldSatisfy` (> dCol)
+ it "aliasMatrix: 直交設計 vs 平方項で形状確認" $ do
+ let z = LA.fromLists [[1], [1], [1], [1]] -- 例: 全 1 (intercept alias)
+ a = DDiag.aliasMatrix xOrth z
+ LA.rows a `shouldBe` 3
+ LA.cols a `shouldBe` 1
diff --git a/test/Hanalyze/Design/GaugeRRSpec.hs b/test/Hanalyze/Design/GaugeRRSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/GaugeRRSpec.hs
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.GaugeRRSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Hanalyze.Design.GaugeRR as GRR
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.GaugeRR (Phase 10)" $ do
+ -- 3 parts × 2 operators × 2 reps = 12 obs
+ -- 部品 0/1/2 で本来 ばらつき、 操作者間は小さい
+ let crossedData =
+ let parts = V.fromList (concat (replicate 4 [0, 1, 2])) -- 12 obs total
+ ops = V.fromList (concat
+ [ [0, 0, 0] -- part rep 1 ops
+ , [0, 0, 0] -- part rep 2 ops
+ , [1, 1, 1]
+ , [1, 1, 1]
+ ])
+ -- Each part has 4 obs (2 ops × 2 reps), part effect strong
+ ys = V.fromList
+ [10.0, 20.0, 30.0, -- part 0/1/2 by op 0 rep 1
+ 10.1, 20.2, 29.9, -- ... rep 2
+ 10.2, 20.1, 30.1, -- op 1 rep 1
+ 9.9, 19.9, 30.0] -- op 1 rep 2
+ in (ops, parts, ys)
+
+ it "gaugeRRCrossed: 部品支配ばらつき → grrPctPart 高い" $ do
+ let (ops, parts, ys) = crossedData
+ case GRR.gaugeRRCrossed ops parts ys of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ -- 部品 0/1/2 の平均がそれぞれ 10/20/30 で大きく異なる → 部品分散支配
+ GRR.grrPctPart r `shouldSatisfy` (> 90)
+ GRR.grrTotalVar r `shouldSatisfy` (> 0)
+
+ it "gaugeRRCrossed: 入力長 mismatch は Left" $
+ case GRR.gaugeRRCrossed
+ (V.fromList [0, 1])
+ (V.fromList [0, 1, 2])
+ (V.fromList [1, 2, 3]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
diff --git a/test/Hanalyze/Design/MixtureSpec.hs b/test/Hanalyze/Design/MixtureSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/MixtureSpec.hs
@@ -0,0 +1,105 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.MixtureSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Design.Mixture as Mix
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Mixture (Phase 7.1)" $ do
+ let sumsToOne row = abs (sum row - 1.0) < 1e-12
+
+ it "sanity: m < 2 は Left" $ do
+ case Mix.mixtureDesign Mix.SimplexCentroid 1 of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for m=1"
+ case Mix.mixtureDesign (Mix.SimplexLattice 2) 0 of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for m=0"
+
+ it "sanity: SimplexLattice d < 1 は Left" $
+ case Mix.mixtureDesign (Mix.SimplexLattice 0) 3 of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for d=0"
+
+ it "SimplexLattice {3, 2}: 6 点、 全行の合計が 1" $
+ case Mix.mixtureDesign (Mix.SimplexLattice 2) 3 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ Mix.mdNComponents r `shouldBe` 3
+ Mix.mdNRuns r `shouldBe` 6 -- C(3+2-1, 2) = C(4, 2) = 6
+ LA.rows (Mix.mdMatrix r) `shouldBe` 6
+ LA.cols (Mix.mdMatrix r) `shouldBe` 3
+ let rows = LA.toLists (Mix.mdMatrix r)
+ all sumsToOne rows `shouldBe` True
+ -- 各点の値は {0, 0.5, 1.0} のみ
+ all (\v -> v == 0.0 || v == 0.5 || v == 1.0)
+ (LA.toList (LA.flatten (Mix.mdMatrix r))) `shouldBe` True
+
+ it "SimplexLattice {3, 3}: 10 点 (C(5,3)=10)、 値は {0, 1/3, 2/3, 1}" $
+ case Mix.mixtureDesign (Mix.SimplexLattice 3) 3 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ Mix.mdNRuns r `shouldBe` 10
+ let rows = LA.toLists (Mix.mdMatrix r)
+ all sumsToOne rows `shouldBe` True
+ -- 各値は {0, 1/3, 2/3, 1} に近い
+ let expectedVals = [0.0, 1/3, 2/3, 1.0]
+ isClose v = any (\e -> abs (v - e) < 1e-12) expectedVals
+ all isClose (LA.toList (LA.flatten (Mix.mdMatrix r))) `shouldBe` True
+
+ it "SimplexCentroid (3): 7 点 (= 2^3 - 1)" $
+ case Mix.mixtureDesign Mix.SimplexCentroid 3 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ Mix.mdNRuns r `shouldBe` 7
+ let rows = LA.toLists (Mix.mdMatrix r)
+ all sumsToOne rows `shouldBe` True
+ -- 単体頂点 (1, 0, 0), (0, 1, 0), (0, 0, 1) 全て含む
+ [1, 0, 0] `elem` rows `shouldBe` True
+ [0, 1, 0] `elem` rows `shouldBe` True
+ [0, 0, 1] `elem` rows `shouldBe` True
+
+ it "SimplexCentroid (3) は全体重心 (1/3, 1/3, 1/3) を含む" $
+ case Mix.mixtureDesign Mix.SimplexCentroid 3 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ let centroid = [1/3, 1/3, 1/3]
+ rows = LA.toLists (Mix.mdMatrix r)
+ isClose pt = abs (sum (zipWith (\a b -> abs (a - b)) pt centroid)) < 1e-12
+ any isClose rows `shouldBe` True
+
+ it "SimplexCentroid (4): 15 点 (= 2^4 - 1)" $
+ case Mix.mixtureDesign Mix.SimplexCentroid 4 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> Mix.mdNRuns r `shouldBe` 15
+
+ it "SimplexLattice {3, 1}: 3 点 (= 単体頂点のみ)" $
+ case Mix.mixtureDesign (Mix.SimplexLattice 1) 3 of
+ Left e -> expectationFailure (T.unpack e)
+ Right r -> do
+ Mix.mdNRuns r `shouldBe` 3
+ let rows = LA.toLists (Mix.mdMatrix r)
+ rows `shouldMatchList` [[1,0,0],[0,1,0],[0,0,1]]
diff --git a/test/Hanalyze/Design/OptimalSpec.hs b/test/Hanalyze/Design/OptimalSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/OptimalSpec.hs
@@ -0,0 +1,123 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.OptimalSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Design.Optimal as OPT
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Optimal.augmentDesign (Phase 5)" $ do
+ -- 2 因子の二次応答曲面候補 (intercept + x1 + x2 + x1² + x2² + x1x2)
+ -- = quadraticCandidates 2 3 → 9 候補 (3×3 grid)
+ let cands2 = OPT.quadraticCandidates 2 3
+ -- 既存 4 行 design (適当に factorial corner を 3 個 + 中心)
+ existing4 =
+ [ [1.0, -1.0, -1.0, 1.0, 1.0, 1.0]
+ , [1.0, 1.0, -1.0, 1.0, 1.0, -1.0]
+ , [1.0, -1.0, 1.0, 1.0, 1.0, -1.0]
+ , [1.0, 0.0, 0.0, 0.0, 0.0, 0.0]
+ ]
+
+ it "N=0 や 候補不足は空の new で返す" $ do
+ let r0 = OPT.augmentDesign OPT.DOpt existing4 0 cands2 42
+ r1 = OPT.augmentDesign OPT.DOpt existing4 1000 (take 1 cands2) 42
+ OPT.arNewIndices r0 `shouldBe` []
+ OPT.arNewIndices r1 `shouldBe` []
+ OPT.arFullDesign r0 `shouldBe` existing4
+ OPT.arFullDesign r1 `shouldBe` existing4
+
+ it "N=2 追加で arNewRows の長さは 2、 arFullDesign は existing ++ new" $ do
+ let r = OPT.augmentDesign OPT.DOpt existing4 2 cands2 42
+ length (OPT.arNewIndices r) `shouldBe` 2
+ length (OPT.arNewRows r) `shouldBe` 2
+ length (OPT.arFullDesign r) `shouldBe` length existing4 + 2
+ take 4 (OPT.arFullDesign r) `shouldBe` existing4 -- 順序保存
+
+ it "augment 後の |XᵀX| が augment 前 以上 (実質単調増加)" $ do
+ let r = OPT.augmentDesign OPT.DOpt existing4 3 cands2 42
+ -- arInitialCrit は existing 単独の |XᵀX|、 arFinalCrit は augment 後
+ -- D-opt なので大きい方が良い
+ OPT.arFinalCrit r `shouldSatisfy` (>= OPT.arInitialCrit r)
+
+ it "異なる seed でも arNewRows 長さは一定、 |XᵀX| 改善は保つ" $ do
+ let r1 = OPT.augmentDesign OPT.DOpt existing4 3 cands2 1
+ r2 = OPT.augmentDesign OPT.DOpt existing4 3 cands2 99
+ length (OPT.arNewRows r1) `shouldBe` 3
+ length (OPT.arNewRows r2) `shouldBe` 3
+ OPT.arFinalCrit r1 `shouldSatisfy` (>= OPT.arInitialCrit r1)
+ OPT.arFinalCrit r2 `shouldSatisfy` (>= OPT.arInitialCrit r2)
+
+ it "空 existing でも augment は機能 (= 通常の optimal design 相当)" $ do
+ let r = OPT.augmentDesign OPT.DOpt [] 5 cands2 42
+ length (OPT.arNewRows r) `shouldBe` 5
+ OPT.arInitialCrit r `shouldBe` 0 -- 空 existing は singular扱い
+ OPT.arFinalCrit r `shouldSatisfy` (> 0)
+
+ it "選ばれた追加点は候補集合の subset" $ do
+ let r = OPT.augmentDesign OPT.DOpt existing4 3 cands2 42
+ newSet = OPT.arNewRows r
+ candSet = cands2
+ all (`elem` candSet) newSet `shouldBe` True
+
+ describe "Hanalyze.Design.Optimal I/E-optimal (Phase 14)" $ do
+ let candidates =
+ [ [1, x1, x2] | x1 <- [-1, 0, 1], x2 <- [-1, 0, 1] ]
+ it "iOptimal: 9 候補から 5 設計を抽出、 fullrank" $ do
+ let (idxs, des) = OPT.iOptimal candidates 5 42
+ length idxs `shouldBe` 5
+ length des `shouldBe` 5
+ it "eOptimal: 9 候補から 5 設計を抽出" $ do
+ let (idxs, _) = OPT.eOptimal candidates 5 42
+ length idxs `shouldBe` 5
+
+ describe "Hanalyze.Design.Optimal GOpt / Compound (Phase 23-a)" $ do
+ let candidates =
+ [ [1, x1, x2] | x1 <- [-1, 0, 1], x2 <- [-1, 0, 1] ]
+ it "gOptimal: 9 候補から 5 設計を抽出 (max leverage 最小化)" $ do
+ let (idxs, des) = OPT.gOptimal candidates 5 42
+ length idxs `shouldBe` 5
+ length des `shouldBe` 5
+ it "Compound [(1, DOpt)] は DOpt と同じ design を返す" $ do
+ let (idxsD, _) = OPT.dOptimal candidates 5 42
+ (idxsC, _) = OPT.optimalDesign (OPT.Compound [(1.0, OPT.DOpt)]) candidates 5 42
+ idxsC `shouldBe` idxsD
+ it "Compound [(0.5, DOpt), (0.5, AOpt)] が n 行を選択して動作" $ do
+ let (idxs, _) =
+ OPT.optimalDesign
+ (OPT.Compound [(0.5, OPT.DOpt), (0.5, OPT.AOpt)])
+ candidates 5 42
+ length idxs `shouldBe` 5
+
+ -- Phase 78.I: n > 候補点数 のとき点の反復を許し、 きっちり n 点を返す (頭打ちしない)。
+ it "optimalDesign: n > 候補点数 は点を反復して n 点を返す" $ do
+ let (idxs, des) = OPT.optimalDesign OPT.DOpt candidates 12 42 -- 候補 9・n=12
+ length idxs `shouldBe` 12 -- 頭打ちせず 12 点
+ length des `shouldBe` 12
+ length (nub idxs) < length idxs `shouldBe` True -- 少なくとも 1 点は反復
+ all (`elem` [0 .. length candidates - 1]) idxs `shouldBe` True -- 全て候補 index
+ -- distinct が一意に D-最適な場合 (linear 2 因子・n=4 = 4 隅) は反復しない。
+ -- ※真の exact D-最適ゆえ、 反復が D を上げる場合 (linear の n=5 等) は n<=nC でも反復し得る。
+ it "optimalDesign: distinct が最適なら反復しない (linear n=4 = 4 隅)" $ do
+ let (idxs, _) = OPT.optimalDesign OPT.DOpt candidates 4 42
+ length idxs `shouldBe` 4
+ length (nub idxs) `shouldBe` 4 -- 4 隅・反復なし
diff --git a/test/Hanalyze/Design/OrthogonalSpec.hs b/test/Hanalyze/Design/OrthogonalSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/OrthogonalSpec.hs
@@ -0,0 +1,133 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.OrthogonalSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Design.Orthogonal as OA
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Orthogonal" $ do
+ it "L4 has 4 runs and 3 columns" $ do
+ OA.oaRuns OA.l4 `shouldBe` 4
+ OA.oaFactors OA.l4 `shouldBe` 3
+ length (OA.oaTable OA.l4) `shouldBe` 4
+
+ it "L8 has 8 runs and 7 columns" $ do
+ OA.oaRuns OA.l8 `shouldBe` 8
+ OA.oaFactors OA.l8 `shouldBe` 7
+
+ it "L9 has 9 runs and 4 columns at 3 levels each" $ do
+ OA.oaRuns OA.l9 `shouldBe` 9
+ OA.oaFactors OA.l9 `shouldBe` 4
+ OA.oaLevels OA.l9 `shouldBe` [3, 3, 3, 3]
+
+ it "L18 has 18 runs and 8 columns (1×2 + 7×3)" $ do
+ OA.oaRuns OA.l18 `shouldBe` 18
+ OA.oaLevels OA.l18 `shouldBe` 2 : replicate 7 3
+
+ it "L27 has 27 runs and 13 columns at 3 levels each" $ do
+ OA.oaRuns OA.l27 `shouldBe` 27
+ OA.oaFactors OA.l27 `shouldBe` 13
+ OA.oaLevels OA.l27 `shouldBe` replicate 13 3
+
+ it "L27 columns are balanced (each level appears 9 times)" $ do
+ let table = OA.oaTable OA.l27
+ colJ j = [ row !! j | row <- table ]
+ mapM_ (\j -> mapM_ (\l ->
+ length (filter (== l) (colJ j)) `shouldBe` 9) [1,2,3]) [0 .. 12]
+
+ it "L27 column pairs are strength-2 orthogonal (each of 9 combos appears 3 times)" $ do
+ let table = OA.oaTable OA.l27
+ colJ j = [ row !! j | row <- table ]
+ pairCount j1 j2 a b =
+ length (filter id (zipWith (\x y -> x == a && y == b)
+ (colJ j1) (colJ j2)))
+ mapM_ (\(j1, j2) -> mapM_ (\(a, b) ->
+ pairCount j1 j2 a b `shouldBe` 3)
+ [ (a, b) | a <- [1,2,3], b <- [1,2,3] ])
+ [ (j1, j2) | j1 <- [0 .. 12], j2 <- [j1 + 1 .. 12] ]
+
+ it "lookupOA finds L27" $
+ OA.oaName <$> OA.lookupOA "L27" `shouldBe` Just "L27(3^13)"
+
+ it "L8 columns are balanced (each level appears 4 times)" $ do
+ let table = OA.oaTable OA.l8
+ colJ j = [ row !! j | row <- table ]
+ mapM_ (\j -> do
+ let cs = colJ j
+ length (filter (== 1) cs) `shouldBe` 4
+ length (filter (== 2) cs) `shouldBe` 4) [0 .. 6]
+
+ it "L8 column pairs are pairwise orthogonal" $ do
+ let table = OA.oaTable OA.l8
+ colJ j = [ row !! j | row <- table ]
+ pairCount j1 j2 a b =
+ length (filter id (zipWith (\x y -> x == a && y == b)
+ (colJ j1) (colJ j2)))
+ -- For 2-level orthogonality: each pair (1,1)/(1,2)/(2,1)/(2,2) must appear equally
+ mapM_ (\(j1, j2) -> do
+ pairCount j1 j2 1 1 `shouldBe` 2
+ pairCount j1 j2 1 2 `shouldBe` 2
+ pairCount j1 j2 2 1 `shouldBe` 2
+ pairCount j1 j2 2 2 `shouldBe` 2)
+ [(0,1),(0,2),(0,3),(1,2),(1,3),(2,3)]
+
+ it "lookupOA finds standard arrays case-insensitively" $ do
+ OA.oaName <$> OA.lookupOA "L9" `shouldBe` Just "L9(3^4)"
+ OA.oaName <$> OA.lookupOA "l9" `shouldBe` Just "L9(3^4)"
+ OA.oaName <$> OA.lookupOA "L99" `shouldBe` Nothing
+
+ it "assignFactors fills levels correctly for L4" $ do
+ let specs = [ OA.FactorSpec "A" [OA.LText "lo", OA.LText "hi"]
+ , OA.FactorSpec "B" [OA.LNumeric 0, OA.LNumeric 1]
+ ]
+ case OA.assignFactors OA.l4 specs of
+ Right ad -> do
+ length (OA.adRows ad) `shouldBe` 4
+ map length (OA.adRows ad) `shouldBe` [2, 2, 2, 2]
+ Left e -> expectationFailure (show e)
+
+ it "assignFactors rejects too many factors" $ do
+ let specs = replicate 5 (OA.FactorSpec "X" [OA.LNumeric 1, OA.LNumeric 2])
+ OA.assignFactors OA.l4 specs `shouldSatisfy`
+ \r -> case r of { Left _ -> True; Right _ -> False }
+
+ it "assignFactors rejects level count mismatch" $ do
+ let specs = [ OA.FactorSpec "A" [OA.LText "x"] ] -- only 1 level, L4 needs 2
+ OA.assignFactors OA.l4 specs `shouldSatisfy`
+ \r -> case r of { Left _ -> True; Right _ -> False }
+
+ -- ─────────────────────────────────────────────────────────────────────
+
+ describe "Hanalyze.Design.Orthogonal.listArraysWithSize" $ do
+ it "returns one entry per standard array" $
+ length OA.listArraysWithSize `shouldBe` length OA.standardArrays
+
+ it "L9 entry exposes runs / factors / levels" $ do
+ let l9meta = head [ m | m <- OA.listArraysWithSize
+ , OA.omName m == OA.oaName OA.l9 ]
+ OA.omRuns l9meta `shouldBe` 9
+ OA.omFactors l9meta `shouldBe` 4
+ OA.omLevels l9meta `shouldBe` [3, 3, 3, 3]
+
+ -- ─────────────────────────────────────────────────────────────────────
diff --git a/test/Hanalyze/Design/QualitySpec.hs b/test/Hanalyze/Design/QualitySpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/QualitySpec.hs
@@ -0,0 +1,121 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.QualitySpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Design.Quality as Quality
+import qualified Hanalyze.Model.Weibull as WB
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Quality.processCapability" $ do
+ it "centred process with σ=1, USL=6, LSL=−6 → Cp ≈ 2.0, Cpk ≈ 2.0" $ do
+ -- 11-point symmetric sample around 0 with σ=1 (population)
+ let xs = LA.fromList [-1.5, -1.0, -0.5, 0.5, 1.0, 1.5,
+ 1.5, 1.0, 0.5, -0.5, -1.0, -1.5]
+ cap = Quality.processCapability (-6) 6 xs
+ Quality.capCp cap `shouldSatisfy` (> 0)
+ -- For a centred sample, Cp == Cpk by symmetry.
+ abs (Quality.capCp cap - Quality.capCpk cap)
+ `shouldSatisfy` (< 1e-2)
+
+ it "shifted process: Cpk < Cp" $ do
+ let xs = LA.fromList [4.0, 4.5, 4.2, 4.8, 4.3, 4.6, 4.4, 4.7]
+ cap = Quality.processCapability 0 6 xs
+ Quality.capCp cap `shouldSatisfy` (> Quality.capCpk cap)
+
+ it "processCapabilityUpper: only USL → Cp == Cpk" $ do
+ let xs = LA.fromList [1.0, 1.2, 0.9, 1.1, 1.05, 0.95]
+ cap = Quality.processCapabilityUpper 2.0 xs
+ Quality.capCp cap `shouldBe` Quality.capCpk cap
+
+ describe "Hanalyze.Design.Quality 非正規 (Phase 13.3)" $ do
+ it "processCapabilityWeibull: 形状 k=2 の Weibull で Cp 計算が finite" $ do
+ let wf = WB.WeibullFit 2.0 100.0 0 10 10 (0, 0, 0)
+ cap = Quality.processCapabilityWeibull wf 10 300
+ Quality.capCp cap `shouldSatisfy` (> 0)
+ Quality.capCp cap `shouldSatisfy` (\v -> not (isNaN v))
+ it "processCapabilityLogNormal: 対称 spec で Cpk = Cp の上下" $ do
+ let mu = 0
+ sigma = 0.3
+ med = exp mu
+ cap = Quality.processCapabilityLogNormal mu sigma (med * 0.5) (med * 2.0)
+ Quality.capCp cap `shouldSatisfy` (> 0)
+ Quality.capCpk cap `shouldSatisfy` (<= Quality.capCp cap + 1e-9)
+ it "processCapabilityLogNormal: spec を 0 spread にすると Cp = 0" $ do
+ let cap = Quality.processCapabilityLogNormal 0 0.3 1.0 1.0
+ Quality.capCp cap `shouldSatisfy` (\v -> v <= 0)
+
+ describe "Hanalyze.Design.Quality 非正規 Gamma + 統一エントリ (Phase 23-c)" $ do
+ it "processCapabilityGamma: shape=2 scale=50 で Cp 計算が finite + 正" $ do
+ let cap = Quality.processCapabilityGamma 2.0 50.0 5 400
+ Quality.capCp cap `shouldSatisfy` (> 0)
+ Quality.capCp cap `shouldSatisfy` (not . isNaN)
+ it "processCapabilityGamma: spec の spread を 0 にすると Cp ≤ 0" $ do
+ let cap = Quality.processCapabilityGamma 2.0 50.0 100 100
+ Quality.capCp cap `shouldSatisfy` (<= 0)
+ it "processCapabilityNonNormal: Weibull dispatch が個別関数と一致" $ do
+ let wf = WB.WeibullFit 2.0 100.0 0 10 10 (0, 0, 0)
+ capA = Quality.processCapabilityNonNormal (Quality.NNFWeibull wf) 10 300
+ capB = Quality.processCapabilityWeibull wf 10 300
+ Quality.capCp capA `shouldBe` Quality.capCp capB
+ Quality.capCpk capA `shouldBe` Quality.capCpk capB
+ it "processCapabilityNonNormal: LogNormal dispatch が個別関数と一致" $ do
+ let capA = Quality.processCapabilityNonNormal (Quality.NNFLogNormal 0 0.3) 0.5 2.0
+ capB = Quality.processCapabilityLogNormal 0 0.3 0.5 2.0
+ Quality.capCp capA `shouldBe` Quality.capCp capB
+ it "processCapabilityNonNormal: Gamma dispatch が個別関数と一致" $ do
+ let capA = Quality.processCapabilityNonNormal (Quality.NNFGamma 2.0 50.0) 5 400
+ capB = Quality.processCapabilityGamma 2.0 50.0 5 400
+ Quality.capCp capA `shouldBe` Quality.capCp capB
+
+ describe "Hanalyze.Design.Quality 多変量 Cp (Phase 23-d)" $ do
+ let -- 中心 (5, 10)、 各軸 σ ≈ 1 の擬似 2 変数データ (8 点)
+ dat = LA.fromLists
+ [ [4, 9], [5, 10], [6, 11], [5, 10]
+ , [4, 11], [6, 9], [5, 11], [5, 9] ]
+ specs = [(2, 8), (7, 13)] -- 各軸 ±3 中心、 spread = 6
+ it "processCapabilityMultivariate: 基本動作、 MCp 正・finite" $ do
+ case Quality.processCapabilityMultivariate dat specs of
+ Left e -> expectationFailure (show e)
+ Right mc -> do
+ Quality.mcNVars mc `shouldBe` 2
+ Quality.mcMCp mc `shouldSatisfy` (> 0)
+ Quality.mcMCp mc `shouldSatisfy` (not . isNaN)
+ Quality.mcInSpecRate mc `shouldBe` 1.0
+ it "MCpk ≤ MCp (中心オフセット penalty で抑制)" $ do
+ case Quality.processCapabilityMultivariate dat specs of
+ Left e -> expectationFailure (show e)
+ Right mc -> Quality.mcMCpk mc `shouldSatisfy` (<= Quality.mcMCp mc + 1e-9)
+ it "specs 長さ不一致は Left" $ do
+ case Quality.processCapabilityMultivariate dat [(0, 1)] of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+ it "n=1 (観測 1 件) は Left" $ do
+ case Quality.processCapabilityMultivariate (LA.fromLists [[1, 2]]) specs of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+ it "InSpecRate: spec を厳しくすると内包率が下がる" $ do
+ case Quality.processCapabilityMultivariate dat [(4.5, 5.5), (9.5, 10.5)] of
+ Left e -> expectationFailure (show e)
+ Right mc -> Quality.mcInSpecRate mc `shouldSatisfy` (< 1.0)
diff --git a/test/Hanalyze/Design/SequentialSpec.hs b/test/Hanalyze/Design/SequentialSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/SequentialSpec.hs
@@ -0,0 +1,89 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.SequentialSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Design.Sequential as Seq
+import qualified Hanalyze.Design.RSM as RSMd
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Sequential (Phase 7.2)" $ do
+ it "steepestAscent: ascent 方向 = +b / |b|" $ do
+ let sa = Seq.steepestAscent True [0, 0] [3, 4] 1.0 5
+ d = LA.toList (Seq.sarDirection sa)
+ -- (3, 4) の単位ベクトル = (0.6, 0.8)
+ abs (d !! 0 - 0.6) `shouldSatisfy` (< 1e-12)
+ abs (d !! 1 - 0.8) `shouldSatisfy` (< 1e-12)
+ length (Seq.sarStepPoints sa) `shouldBe` 6 -- nSteps + 1
+ Seq.sarStepPoints sa !! 0 `shouldBe` [0, 0]
+ -- step 1 = center + 1 * (0.6, 0.8) = (0.6, 0.8)
+ abs (Seq.sarStepPoints sa !! 1 !! 0 - 0.6) `shouldSatisfy` (< 1e-12)
+
+ it "steepestAscent: descent 方向 = -b / |b|" $ do
+ let sa = Seq.steepestAscent False [10, 10] [1, 0] 0.5 3
+ Seq.sarMaximize sa `shouldBe` False
+ let d = LA.toList (Seq.sarDirection sa)
+ -- (1, 0) の単位ベクトル = (1, 0)、 descent なので -1, 0
+ abs (d !! 0 - (-1.0)) `shouldSatisfy` (< 1e-12)
+ abs (d !! 1) `shouldSatisfy` (< 1e-12)
+ -- step 2 = (10, 10) + 2 * 0.5 * (-1, 0) = (9, 10)
+ abs (Seq.sarStepPoints sa !! 2 !! 0 - 9.0) `shouldSatisfy` (< 1e-12)
+ abs (Seq.sarStepPoints sa !! 2 !! 1 - 10.0) `shouldSatisfy` (< 1e-12)
+
+ it "steepestAscent: |b| = 0 なら方向 0、 全点 center" $ do
+ let sa = Seq.steepestAscent True [5, 5, 5] [0, 0, 0] 1.0 3
+ d = LA.toList (Seq.sarDirection sa)
+ all (== 0) d `shouldBe` True
+ all (== [5,5,5]) (Seq.sarStepPoints sa) `shouldBe` True
+
+ it "steepestAscentFromQuad: QuadFit から第一階係数を抽出" $ do
+ -- 2 因子の簡単な response surface y = 1 + 2*x1 + 3*x2 + ...
+ let xs = [[-1,-1], [1,-1], [-1,1], [1,1], [0,0]]
+ ys = [ 1 + 2*x1 + 3*x2 | [x1, x2] <- xs ]
+ qf = RSMd.fitQuadratic xs ys
+ sa = Seq.steepestAscentFromQuad True [0, 0] qf 0.1 4
+ -- 第一階係数 (2, 3) → 単位ベクトル (2, 3)/sqrt(13)
+ let expectedX = 2 / sqrt 13
+ expectedY = 3 / sqrt 13
+ d = LA.toList (Seq.sarDirection sa)
+ abs (d !! 0 - expectedX) `shouldSatisfy` (< 0.05) -- numerical fit tolerance
+ abs (d !! 1 - expectedY) `shouldSatisfy` (< 0.05)
+
+ it "sequentialCCD: 新中心 + span で coded / real 両方返す" $ do
+ let res = Seq.sequentialCCD [10, 20] 2.0 2 RSMd.CCF 1
+ Seq.sccdCenter res `shouldBe` [10, 20]
+ Seq.sccdSpan res `shouldBe` 2.0
+ -- coded は -1, 0, +1 の組合せ (FaceCentered なので axial も ±1)
+ length (Seq.sccdCoded res) `shouldBe` length (Seq.sccdReal res)
+ -- real の各行 = center + span * coded
+ let checkRow (coded, real) =
+ real == zipWith (\c x -> c + 2.0 * x) [10, 20] coded
+ all checkRow (zip (Seq.sccdCoded res) (Seq.sccdReal res)) `shouldBe` True
+
+ it "sequentialCCD: factorial part は ±span 周辺" $ do
+ let res = Seq.sequentialCCD [50, 50] 5.0 2 RSMd.CCF 1
+ realRows = Seq.sccdReal res
+ -- 角点は (45,45), (55,45), (45,55), (55,55) を含むはず
+ [45, 45] `elem` realRows `shouldBe` True
+ [55, 55] `elem` realRows `shouldBe` True
diff --git a/test/Hanalyze/Design/SpaceFillingSpec.hs b/test/Hanalyze/Design/SpaceFillingSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/SpaceFillingSpec.hs
@@ -0,0 +1,90 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.SpaceFillingSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Design.SpaceFilling as SF
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.SpaceFilling (Phase 6.1)" $ do
+ let inUnitBox m =
+ all (\v -> v >= 0 && v < 1) (LA.toList (LA.flatten m))
+
+ it "latinHypercube: n × d 行列、 [0,1) 内、 minDist > 0" $ do
+ gen <- MWC.create
+ des <- SF.latinHypercube 20 3 gen
+ SF.sfdNPoints des `shouldBe` 20
+ SF.sfdNDims des `shouldBe` 3
+ LA.rows (SF.sfdMatrix des) `shouldBe` 20
+ LA.cols (SF.sfdMatrix des) `shouldBe` 3
+ inUnitBox (SF.sfdMatrix des) `shouldBe` True
+ SF.sfdMinDist des `shouldSatisfy` (> 0)
+ SF.sfdMethod des `shouldBe` "LHS"
+
+ it "latinHypercube: 各列の stratification (n セルに 1 点ずつ)" $ do
+ gen <- MWC.create
+ des <- SF.latinHypercube 10 2 gen
+ let mat = SF.sfdMatrix des
+ col0 = LA.toList (LA.flatten (mat LA.¿ [0]))
+ cellOf x = floor (x * 10) :: Int
+ cells0 = map cellOf col0
+ length (Data.List.nub cells0) `shouldBe` 10 -- 全 10 セル使用
+
+ it "latinHypercubeMaximin: minDist ≥ plain LHS minDist (LHS から始まる)" $ do
+ gen1 <- MWC.create
+ gen2 <- MWC.create
+ lhs <- SF.latinHypercube 15 3 gen1
+ mxmn <- SF.latinHypercubeMaximin 15 3 200 gen2
+ SF.sfdMethod mxmn `shouldBe` "MaximinLHS"
+ -- maximin は LHS の swap 局所探索なので、 同 seed では LHS と
+ -- 同等以上の minDist を期待。 異 seed でも壊滅的に悪くはならないはず:
+ -- 「max(LHS, MaximinLHS) ≥ LHS の半分」 程度の緩い検証で OK
+ SF.sfdMinDist mxmn `shouldSatisfy` (>= SF.sfdMinDist lhs / 2)
+
+ it "haltonDesign: 決定的 (= 同じ n, d で同じ結果)" $ do
+ let d1 = SF.haltonDesign 10 3
+ d2 = SF.haltonDesign 10 3
+ SF.sfdMatrix d1 `shouldBe` SF.sfdMatrix d2
+ SF.sfdMethod d1 `shouldBe` "Halton"
+ inUnitBox (SF.sfdMatrix d1) `shouldBe` True
+ SF.sfdMinDist d1 `shouldSatisfy` (> 0)
+
+ it "designMinDistance: 既知 2 点 design で正しい距離" $ do
+ let m = LA.fromLists [[0.0, 0.0], [3.0, 4.0]] -- 距離 = 5
+ abs (SF.designMinDistance m - 5.0) `shouldSatisfy` (< 1e-12)
+
+ it "designMinDistance: 行数 < 2 で 0" $ do
+ let m0 = (0 LA.>< 0) []
+ m1 = LA.fromLists [[1.0, 2.0]]
+ SF.designMinDistance m0 `shouldBe` 0
+ SF.designMinDistance m1 `shouldBe` 0
+
+ it "n=0 or d=0 で安全に empty design" $ do
+ gen <- MWC.create
+ des0 <- SF.latinHypercube 0 3 gen
+ SF.sfdNPoints des0 `shouldBe` 0
+ let halt0 = SF.haltonDesign 0 3
+ SF.sfdNPoints halt0 `shouldBe` 0
diff --git a/test/Hanalyze/Design/TaguchiSpec.hs b/test/Hanalyze/Design/TaguchiSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/TaguchiSpec.hs
@@ -0,0 +1,108 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Design.TaguchiSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Design.Orthogonal as OA
+import qualified Hanalyze.Design.Taguchi as TG
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Design.Taguchi" $ do
+ it "smaller-the-better SN: lower y → higher η" $ do
+ let etaSmall = TG.snRatio TG.SmallerBetter [0.5, 0.5, 0.5]
+ etaLarge = TG.snRatio TG.SmallerBetter [5.0, 5.0, 5.0]
+ etaSmall `shouldSatisfy` (> etaLarge)
+
+ it "larger-the-better SN: higher y → higher η" $ do
+ let etaLarge = TG.snRatio TG.LargerBetter [10, 10, 10]
+ etaSmall = TG.snRatio TG.LargerBetter [1, 1, 1]
+ etaLarge `shouldSatisfy` (> etaSmall)
+
+ it "nominal-the-best SN: high mean / low var → high η" $ do
+ let highSN = TG.snRatio TG.NominalBest [10, 10.01, 9.99, 10]
+ lowSN = TG.snRatio TG.NominalBest [1, 4, 7, 10]
+ highSN `shouldSatisfy` (> lowSN)
+
+ it "nominal-target SN: closer to target → higher η" $ do
+ let closer = TG.snRatio (TG.NominalBestTarget 5) [4.9, 5.0, 5.1]
+ farther = TG.snRatio (TG.NominalBestTarget 5) [3, 5, 7]
+ closer `shouldSatisfy` (> farther)
+
+ it "snRatio on empty list is 0" $
+ TG.snRatio TG.SmallerBetter [] `shouldBe` 0
+
+ it "snRatioRows produces same length as input" $ do
+ let yMatrix = [[1.0, 2.0], [3.0, 4.0], [5.0, 6.0]]
+ length (TG.snRatioRows TG.SmallerBetter yMatrix) `shouldBe` 3
+
+ it "analyzeSN gives one FactorEffect per assigned factor" $ do
+ let specs = [ OA.FactorSpec "A" [OA.LText "lo", OA.LText "hi"]
+ , OA.FactorSpec "B" [OA.LText "lo", OA.LText "hi"]
+ , OA.FactorSpec "C" [OA.LText "lo", OA.LText "hi"]
+ ]
+ Right ad = OA.assignFactors OA.l4 specs
+ fes = TG.analyzeSN ad [10, 20, 30, 40]
+ length fes `shouldBe` 3
+ map TG.feFactor fes `shouldBe` ["A", "B", "C"]
+ mapM_ (\fe -> length (TG.feSNByLevel fe) `shouldBe` 2) fes
+
+ it "optimalLevels picks max-SN level per factor" $ do
+ let specs = [ OA.FactorSpec "A" [OA.LText "lo", OA.LText "hi"]
+ , OA.FactorSpec "B" [OA.LText "lo", OA.LText "hi"]
+ , OA.FactorSpec "C" [OA.LText "lo", OA.LText "hi"]
+ ]
+ Right ad = OA.assignFactors OA.l4 specs
+ -- L4 row 1 ("hi" for A,B,C) has SN=100; others 0
+ sns = [0, 0, 0, 100]
+ fes = TG.analyzeSN ad sns
+ opts = TG.optimalLevels fes
+ length opts `shouldBe` 3
+ -- Row 4 has all "hi" by L4 structure (2,2,1) — verify each factor's best
+ mapM_ (\(_, _, eta) -> eta `shouldSatisfy` (>= 0)) opts
+
+ -- ─────────────────────────────────────────────────────────────────────
+
+ describe "Hanalyze.Design.Taguchi extras" $ do
+ it "snRatioWithDetails: SmallerBetter on [1, 2, 3]" $ do
+ let d = TG.snRatioWithDetails TG.SmallerBetter [1.0, 2.0, 3.0]
+ TG.sdN d `shouldBe` 3
+ TG.sdMean d `shouldSatisfy` (\v -> abs (v - 2.0) < 1e-12)
+ TG.sdVariance d `shouldSatisfy` (\v -> abs (v - 1.0) < 1e-12)
+ -- η = -10 log10((1+4+9)/3) = -10 log10(14/3) ≈ -6.690
+ TG.sdSN d `shouldSatisfy` (\v -> abs (v - (-6.690)) < 1e-2)
+
+ it "factorEffectsTable: contributions sum to 1" $ do
+ let specs = [ OA.FactorSpec "A" [OA.LText "lo", OA.LText "hi"]
+ , OA.FactorSpec "B" [OA.LNumeric 0, OA.LNumeric 1]
+ ]
+ case OA.assignFactors OA.l4 specs of
+ Right ad -> do
+ let sns = [10.0, 12.0, 11.0, 13.0]
+ ext = TG.factorEffectsTable ad sns
+ length ext `shouldBe` 2
+ let totalC = sum (map TG.feeContribution ext)
+ totalC `shouldSatisfy` (\v -> abs (v - 1.0) < 1e-12)
+ all ((>= 0) . TG.feeRange) ext `shouldBe` True
+ Left e -> expectationFailure (show e)
+
+ -- ─────────────────────────────────────────────────────────────────────
diff --git a/test/Hanalyze/Design/WorkflowSpec.hs b/test/Hanalyze/Design/WorkflowSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Design/WorkflowSpec.hs
@@ -0,0 +1,1241 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Phase 78.A/B: DOE ワークフロー (設計オブジェクト + runsheet + designModel)。
+--
+-- 大半は standalone (flag plot-integration off・upstream portable) で build/run できるが、
+-- 一部の診断テスト (tracesOf / MultiVarModel の事後予測帯) は plot 連携層
+-- (Hanalyze.Plot.*) に依存するため @PLOT_INTEGRATION@ CPP で囲む
+-- (= flag plot-integration on のときだけ compile)。
+module Hanalyze.Design.WorkflowSpec (spec) where
+
+import qualified Data.Text as T
+import Data.List (findIndex, isInfixOf, nub)
+import Data.Maybe (isJust)
+import Control.Exception (evaluate, ErrorCall (..))
+import System.CPUTime (getCPUTime)
+import System.IO (hPutStrLn, stderr)
+import System.IO.Temp (withSystemTempDirectory)
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector as V
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import Test.Hspec
+import Hanalyze.Design.Workflow
+import Hanalyze.Fit (designModel, designModelGP, defaultGP, gpMulti, GPConfig (..), (|->), ranIntercept, ranSlope, designHBMProgram, designModelHBM, DesignHBMFit (..), multiOutput, modelFor)
+#ifdef PLOT_INTEGRATION
+import Hanalyze.Plot.Bayes (tracesOf)
+#endif
+import Hanalyze.Model.HBM (sampleNames, ModelP)
+import Hanalyze.Model.Wrappers (MultiLMModel (..), GPRegModelN (..), GPMethod (..), HyperStrategy (..), defaultHBM, HBMConfig (..))
+#ifdef PLOT_INTEGRATION
+-- ModelFrame/VarRole は MultiVarModel 事後予測帯テスト (guarded) 専用ゆえ一緒に囲む。
+import Hanalyze.Model.Formula.Frame (ModelFrame (..), VarRole (..))
+import Hanalyze.Plot.Core (MultiVarModel (..))
+import Hanalyze.Plot.ML () -- instance MultiVarModel DesignHBMFit
+#endif
+import Hanalyze.Model.GP (GPParams (..), Kernel (..))
+import Hanalyze.Model.Core (rSquared1)
+import Hanalyze.Model.Formula.RFormula (parseRFormula)
+import Hanalyze.Model.Formula.Mixed (RandomSpec (..))
+import qualified Hanalyze.Design.Custom.Model as CMd
+import qualified Hanalyze.Design.Custom.Factor as CF
+import qualified Hanalyze.Design.Custom.Structured as ST
+import qualified Data.Vector.Storable as VS
+import Hanalyze.DataIO.Convert (getDoubleVec)
+
+spec :: Spec
+spec = do
+ describe "Design.Workflow (Phase 78.A/B)" $ do
+ let planF = factorialDesign [contFactor "temp" (150, 180), contFactor "time" (10, 20)]
+
+ it "factorialDesign: formula = 全交互作用" $
+ designFormula planF "y" `shouldBe` "y ~ temp * time"
+
+ it "factorialDesign: runsheet は 2^k row・uncoded 実値・run 番号列" $ do
+ let rs = designTable planF
+ lookup "temp" rs `shouldBe` Just [150, 150, 180, 180]
+ lookup "time" rs `shouldBe` Just [10, 20, 10, 20]
+ lookup "run" rs `shouldBe` Just [1, 2, 3, 4]
+ designFactorNames planF `shouldBe` ["temp", "time"]
+
+ it "centralCompositeDesign: formula = 2 次モデル (交互作用 + 平方項)" $
+ designFormula (centralCompositeDesign [contFactor "x1" (150, 180), contFactor "x2" (10, 20)]) "y"
+ `shouldBe` "y ~ x1 + x2 + x1:x2 + I(x1^2) + I(x2^2)"
+
+ it "centralCompositeDesign: CCD (factorial + 軸点 + 中心点) の run 数 > 2^k" $ do
+ let rs = designTable (centralCompositeDesign [contFactor "x1" (0, 1), contFactor "x2" (0, 1)])
+ length (maybe [] id (lookup "x1" rs)) `shouldSatisfy` (> 4) -- 2^2=4 より多い
+
+ it "designModel: 真モデル由来データを飽和当てはめ (R^2 ~ 1)" $ do
+ let rs = designTable planF
+ temps = maybe [] id (lookup "temp" rs)
+ times = maybe [] id (lookup "time" rs)
+ ys = zipWith (\t d -> 5 + 2 * t + 3 * d + 0.01 * t * d) temps times
+ m = (("y", ys) : rs) |-> designModel planF "y"
+ -- 2^2 factorial × 交互作用モデル = 飽和 (4 param / 4 点) → 完全再現
+ rSquared1 (mlmResult m) `shouldSatisfy` (> 0.999)
+
+ -- Phase 78.G-e: FRR/HBM 化 (v1 = GP/RFF)。designModel の非 LM 版。
+ it "designModelGP: 連続因子で GP を当てはめ・予測子名を plan から保持" $ do
+ let rs = designTable planF
+ temps = maybe [] id (lookup "temp" rs)
+ times = maybe [] id (lookup "time" rs)
+ ys = zipWith (\t d -> 5 + 2 * t + 3 * d) temps times
+ m = (("y", ys) : rs) |-> designModelGP defaultGP planF "y"
+ gprnNames m `shouldBe` ["temp", "time"]
+
+ it "designModelGP: カテゴリ因子混在は error (連続専用)" $ do
+ let planMix = factorialDesign [contFactor "temp" (150, 180), catFactor "cat" ["a", "b"]]
+ df = [("y", [1, 2, 3, 4]), ("temp", [150, 150, 180, 180])] :: [(T.Text, [Double])]
+ evaluate (gprnNames (df |-> designModelGP defaultGP planMix "y")) `shouldThrow` anyErrorCall
+
+ -- GP/GpRff 象限は帯 (事後予測分散) を出す。 Krr/KrrRff (mean-only) は帯なし。
+ it "designModelGP: GpRff 象限は帯 (予測分散 Just) を出す = RFF 開通" $ do
+ let rs = designTable planF
+ temps = maybe [] id (lookup "temp" rs)
+ times = maybe [] id (lookup "time" rs)
+ ys = zipWith (\t d -> 5 + 2 * t + 3 * d) temps times
+ cfgRff = GPConfig RBF (GpRff 128 7) AutoMarginalLik
+ mRff = (("y", ys) : rs) |-> designModelGP cfgRff planF "y"
+ snd (gprnPredict mRff (LA.fromLists [[165, 15]])) `shouldSatisfy` isJust
+
+ it "designModelGP: Krr 象限は帯なし (mean-only・var=Nothing)" $ do
+ let rs = designTable planF
+ temps = maybe [] id (lookup "temp" rs)
+ times = maybe [] id (lookup "time" rs)
+ ys = zipWith (\t d -> 5 + 2 * t + 3 * d) temps times
+ cfgKrr = GPConfig RBF Krr AutoMarginalLik
+ mKrr = (("y", ys) : rs) |-> designModelGP cfgKrr planF "y"
+ snd (gprnPredict mKrr (LA.fromLists [[165, 15]])) `shouldBe` Nothing
+
+ -- Phase 78.G-e 回帰: GP のハイパラ自動調整 (AutoMarginalLik) が退化しないこと。
+ -- かつて LBFGS の初回ステップが未スケール最急降下方向に α=1 を打ち、勾配の
+ -- 大きい GP 周辺尤度で巨大オーバーシュートして ℓ が真の峰 (≈105) を越え 1e12 に
+ -- 飛び、予測が水平化していた (spread=0)。LBFGS.hs の初回 α₀=min(1,1/‖g‖₁) 修正で
+ -- sklearn 一致の大域最適 (ℓ≈105・LML=-35.77) に到達する。ここでは既知の 2 次応答で
+ -- 予測レンジ (spread) が真値に一致し ℓ が有限であることを担保する。
+ it "GP (AutoMarginalLik) が退化せず既知応答を当てる (LBFGS 初回ステップ回帰)" $ do
+ let respf t d = 50 + 0.6 * t - 0.02 * (t - 165) * (t - 165) + 1.5 * d
+ noise = cycle [0.6, -0.5, 0.4, -0.3, 0.2, -0.1]
+ planG = centralCompositeDesign [contFactor "temp" (150, 180), contFactor "time" (10, 20)]
+ rs = designTable planG
+ temps = maybe [] id (lookup "temp" rs)
+ times = maybe [] id (lookup "time" rs)
+ ys = zipWith3 (\t d e -> respf t d + e) temps times noise
+ dat = ("y", ys) : rs
+ predAt m t d = head (fst (gprnPredict m (LA.fromLists [[t, d]])))
+ trueSpread = respf 180 15 - respf 150 15 -- = 18
+ spreadOf m = predAt m 180 15 - predAt m 150 15
+ -- (a) 高レベル DOE 経路 (designModelGP) (b) 汎用 gpMulti (uncoded 素通し)
+ mDoe = dat |-> designModelGP defaultGP planG "y"
+ mGp = dat |-> gpMulti defaultGP ["temp", "time"] "y"
+ -- 退化なら spread≈0。真値 18 に十分近い (±2) こと・ℓ が有限で妥当 (<1e6)。
+ spreadOf mDoe `shouldSatisfy` (\s -> abs (s - trueSpread) < 2)
+ spreadOf mGp `shouldSatisfy` (\s -> abs (s - trueSpread) < 2)
+ gpLengthScale (gprnParams mGp) `shouldSatisfy` (< 1e6)
+
+ it "designModel: 同じ plan を別データ (sim/実物想定) に使い回せる" $ do
+ let rs = designTable planF
+ temps = maybe [] id (lookup "temp" rs)
+ times = maybe [] id (lookup "time" rs)
+ ysA = zipWith (\t d -> 1 + t + d) temps times -- 「sim」
+ ysB = zipWith (\t d -> 9 + 2 * t - d) temps times -- 「実物」
+ mA = (("y", ysA) : rs) |-> designModel planF "y"
+ mB = (("y", ysB) : rs) |-> designModel planF "y"
+ rSquared1 (mlmResult mA) `shouldSatisfy` (> 0.99)
+ rSquared1 (mlmResult mB) `shouldSatisfy` (> 0.99)
+
+ -- Phase 78.G-f: 型付きランダム効果項 (designModelHBM 用の smart constructor)。
+ it "ranIntercept は (1|g) 相当の RandomSpec" $
+ ranIntercept "lot" `shouldBe` RandomSpec True [] "lot"
+ it "ranSlope は intercept 込みの (1+s|g)" $
+ ranSlope ["temp"] "lot" `shouldBe` RandomSpec True ["temp"] "lot"
+
+ it "designHBMProgram は betaNames と群効果を含む ModelP を組む" $ do
+ let x = [[1,0],[1,1],[1,0],[1,1]] -- intercept + temp
+ bn = ["b0","temp"]
+ res = [([0,0,1,1], 2, [])] -- lot: 行0,1=群0 / 行2,3=群1 (切片のみ)
+ ys = [1.0, 2.0, 1.1, 2.2]
+ prog :: ModelP ()
+ prog = designHBMProgram x bn res ys
+ nms = sampleNames prog
+ nms `shouldContain` ["b0"]
+ nms `shouldContain` ["temp"]
+ nms `shouldContain` ["u_g0_0"]
+
+ -- Phase 78.G-f: designModelHBM 本体 (df → designHBMProgram → hbm → 事後 draw)。
+ -- temp∈{-1,1}・lot∈{A,B} の 2 群、 lot 差 (切片ずれ) を仕込んだ合成データで
+ -- 固定効果係数 temp の事後平均が真値 3 に近く収束することを確認する。
+ -- ('|->' は失敗を error に落とすので、 ここでは happy-path のみ検証する。)
+ it "designModelHBM は lot 群込みで固定効果を回復する" $ do
+ let mean0 xs = sum xs / fromIntegral (length xs)
+ -- ★designMatrixF (R formula 経路) は列ラベルを合成パラメータ込みの項全体
+ -- (例 "_p1 * temp") で付ける (Wrappers.hs の additiveFormula と同じ命名規約)。
+ -- ここでは変数名の suffix 一致で該当列を探す。
+ drawsFor nm m = case findIndex (T.isSuffixOf nm) (dhfBetaNames m) of
+ Just i -> map (!! i) (dhfBetaDraws m)
+ Nothing -> []
+ -- y = 2 + 3*temp + lotShift + small noise (固定値・シード不要)。
+ temps = [-1, 1, -1, 1, -1, 1, -1, 1, -1, 1, -1, 1] :: [Double]
+ lots = ["A","A","A","A","A","A","B","B","B","B","B","B"] :: [T.Text]
+ noise = [0.05, -0.03, 0.02, -0.04, 0.01, -0.02, 0.03, -0.01, 0.04, -0.05, 0.02, -0.03]
+ lotShift l = if l == "A" then (-1.0) else 1.0
+ ys = [ 2 + 3 * t + lotShift l + e
+ | (t, l, e) <- zip3 temps lots noise ]
+ mkFrameHBM = DX.insertColumn "lot" (DX.fromList lots)
+ $ DX.insertColumn "temp" (DX.fromList temps)
+ $ DX.insertColumn "y" (DX.fromList ys)
+ $ DX.empty
+ plan = factorialDesign [contFactor "temp" (-1, 1)]
+ m = mkFrameHBM |-> designModelHBM defaultHBM plan [ranIntercept "lot"] "y"
+ bTemp = mean0 (drawsFor "temp" m)
+ bTemp `shouldSatisfy` (\b -> abs (b - 3) < 1.0)
+
+#ifdef PLOT_INTEGRATION
+ -- Phase 78.J: designModelHBM の学習済 HBM を dhfModel で露出し、 診断抽出子
+ -- (tracesOf / dagOf 等) に渡せる (DesignHBMFit から診断が出せる)。
+ -- ※ tracesOf は plot 連携層 (Hanalyze.Plot.Bayes)・plot-integration 限定。
+ it "designModelHBM: dhfModel で診断 (tracesOf) が出せる" $ do
+ let temps = [-1, 1, -1, 1, -1, 1, -1, 1] :: [Double]
+ lots = ["A","A","A","A","B","B","B","B"] :: [T.Text]
+ ys = [ 2 + 3 * t + (if l == "A" then -1 else 1) | (t, l) <- zip temps lots ]
+ df = DX.insertColumn "lot" (DX.fromList lots)
+ $ DX.insertColumn "temp" (DX.fromList temps)
+ $ DX.insertColumn "y" (DX.fromList ys)
+ $ DX.empty
+ plan = factorialDesign [contFactor "temp" (-1, 1)]
+ m = df |-> designModelHBM defaultHBM plan [ranIntercept "lot"] "y"
+ length (tracesOf (dhfModel m)) `shouldSatisfy` (> 0) -- param ごとの trace が出る
+#endif
+
+ -- Phase 78.G-f 回帰: NA 行 drop と群 idx の行ずれ (code review 指摘)。
+ -- 'modelFrame' (DropRows) は formula 関与列 (temp/y) に NA を含む行を落として
+ -- designX/ys を作るが、 群 idx (prepRE) が raw df (NA 除去前・行数不変) から
+ -- 作られていると、 designX/ys (post-drop・行数 -k) と 1:1 対応しなくなる。
+ -- lot を A,A,B,B の 2 行ブロック周期にし、 4 行 (temp) を NA にすると
+ -- 「raw 先頭 n 行を機械的に使う」 バグ実装では postDrop の並びに対して行ずれが
+ -- 生じ、 複数箇所で A/B が入れ替わって群対応が壊れる (単純な A↔B 一括入替では
+ -- 吸収できない不整合・実測: バグ版 bTemp ≈ 1.96 = |b-3| ≈ 1.04 > 1.0 で検出可)。
+ -- lot 差 (±50、 通常の ±1 より大きめ) を仕込むことで群対応の誤りが固定効果
+ -- temp の事後平均に十分な偏りとして現れるようにしてある。
+ -- fix 後は "同じ post-drop 行集合" から群 idx を作るので、 NA 行があっても
+ -- 固定効果 temp は真値 3 近辺へ回復する。
+ it "designModelHBM: NA 行があっても群 idx が post-drop 行と正しく対応する (行ずれ回帰)" $ do
+ let mean0 xs = sum xs / fromIntegral (length xs)
+ drawsFor nm m = case findIndex (T.isSuffixOf nm) (dhfBetaNames m) of
+ Just i -> map (!! i) (dhfBetaDraws m)
+ Nothing -> []
+ -- lot は 2 行ブロック周期 (A,A,B,B の繰り返し) — 複数 NA drop で生じる
+ -- 「先頭 n 行 raw vs post-drop」 のオフセットが単純な A/B 一括入替に
+ -- 縮退しない配置 (境界が複数あるので relabeling で吸収できない)。
+ n = 16 :: Int
+ lots = take n (cycle ["A", "A", "B", "B"]) :: [T.Text]
+ tempsRaw = take n (cycle [-1, 1]) :: [Double]
+ noise = take n (cycle [0.05, -0.03, 0.02, -0.04, 0.01, -0.02, 0.03, -0.01])
+ lotShift l = if l == "A" then (-50.0) else 50.0
+ ysRaw = [ 2 + 3 * t + lotShift l + e
+ | (t, l, e) <- zip3 tempsRaw lots noise ]
+ -- 行 0,2,4,6 (temp) を NA にする — dropMissingRows で 4 行落ちる。
+ naIdxs = [0, 2, 4, 6] :: [Int]
+ tempsNA = [ if i `elem` naIdxs then Nothing else Just t
+ | (i, t) <- zip [0 :: Int ..] tempsRaw ] :: [Maybe Double]
+ mkFrameHBM = DX.insertColumn "lot" (DX.fromList lots)
+ $ DX.insertColumn "temp" (DX.fromList tempsNA)
+ $ DX.insertColumn "y" (DX.fromList ysRaw)
+ $ DX.empty
+ plan = factorialDesign [contFactor "temp" (-1, 1)]
+ m = mkFrameHBM |-> designModelHBM defaultHBM plan [ranIntercept "lot"] "y"
+ bTemp = mean0 (drawsFor "temp" m)
+ bTemp `shouldSatisfy` (\b -> abs (b - 3) < 1.0)
+
+ -- Phase 78.G-f2: 相関ランダム傾き (1+temp|lot)。 lot ごとに temp の傾きが
+ -- 異なるデータ (A の傾き 5・B の傾き 1・平均 3) を作る。 変量傾きを捉えられれば
+ -- 残差 σ は仕込んだ noise 水準 (~0.05) まで縮む。 切片のみ (ranIntercept) では
+ -- 傾き差 (±2·temp) を残差に押し込むため σ が ~2 に膨らむ = 判別可能。
+ -- 固定効果 temp は両群平均の 3 近辺へ回復する。
+ -- Phase 80.2b で相関 RE を非中心化 (a) vecIR 化 (funnel 撤去) したため再有効化。
+ -- 非中心化パラメタ化で funnel が消え defaultHBM でも収束する。
+ it "designModelHBM: 相関ランダム傾き (ranSlope) は群別の傾き差を捉え σ を縮める" $ do
+ let mean0 xs = sum xs / fromIntegral (length xs)
+ drawsFor nm mm = case findIndex (T.isSuffixOf nm) (dhfBetaNames mm) of
+ Just i -> map (!! i) (dhfBetaDraws mm)
+ Nothing -> []
+ temps = [-1, 1, -1, 1, -1, 1, -1, 1, -1, 1, -1, 1] :: [Double]
+ lots = ["A","A","A","A","A","A","B","B","B","B","B","B"] :: [T.Text]
+ noise = [0.05, -0.03, 0.02, -0.04, 0.01, -0.02, 0.03, -0.01, 0.04, -0.05, 0.02, -0.03]
+ -- lot A: y = 2 + 5·temp、 lot B: y = 2 + 1·temp (傾き差を仕込む)。
+ slopeOf l = if l == "A" then 5.0 else 1.0
+ ys = [ 2 + slopeOf l * t + e
+ | (t, l, e) <- zip3 temps lots noise ]
+ mkFrameHBM = DX.insertColumn "lot" (DX.fromList lots)
+ $ DX.insertColumn "temp" (DX.fromList temps)
+ $ DX.insertColumn "y" (DX.fromList ys)
+ $ DX.empty
+ plan = factorialDesign [contFactor "temp" (-1, 1)]
+ m = mkFrameHBM |-> designModelHBM defaultHBM plan [ranSlope ["temp"] "lot"] "y"
+ bTemp = mean0 (drawsFor "temp" m)
+ sigBar = mean0 (dhfSigmaDraws m)
+ bTemp `shouldSatisfy` (\b -> abs (b - 3) < 1.0) -- 平均傾き 3 を回復
+ sigBar `shouldSatisfy` (< 1.0) -- 変量傾きで σ が縮む (切片のみなら ~2)
+
+ -- ===== PROFILE: ボトルネック切り分け (壁時計 + iter スケーリング) =====
+ -- 同一データ・同一軽量 config で「相関 (per-obs observe = full ad 疑い) vs
+ -- 切片のみ (compiled observeLMR)」の壁時計を測り、 さらに相関を 2 倍 iter で
+ -- 測って線形性 (per-eval 支配 vs tree-depth 増大) を見る。
+ let mkFrameP slopeOf =
+ let temps = [-1, 1, -1, 1, -1, 1, -1, 1, -1, 1, -1, 1] :: [Double]
+ lots = ["A","A","A","A","A","A","B","B","B","B","B","B"] :: [T.Text]
+ noise = [0.05,-0.03,0.02,-0.04,0.01,-0.02,0.03,-0.01,0.04,-0.05,0.02,-0.03]
+ ys = [ 2 + slopeOf l * t + e | (t,l,e) <- zip3 temps lots noise ]
+ in DX.insertColumn "lot" (DX.fromList lots)
+ $ DX.insertColumn "temp" (DX.fromList temps)
+ $ DX.insertColumn "y" (DX.fromList ys) DX.empty
+ planP = factorialDesign [contFactor "temp" (-1, 1)]
+ tinyCfg n = defaultHBM { hbmChains = 1, hbmWarmup = n, hbmSamples = n }
+ timeFit label fit = do
+ t0 <- getCPUTime
+ s <- evaluate (sum (dhfSigmaDraws fit))
+ t1 <- getCPUTime
+ hPutStrLn stderr ("[PROFILE] " <> label <> ": "
+ <> show (fromIntegral (t1 - t0) / 1e12 :: Double) <> " s (Σσ=" <> show s <> ")")
+ -- Phase 79 用の perf 診断 (pending)。 手動計測時のみ xit→it に戻して回す。
+ xit "PROFILE 切片のみ 50iter" $ do
+ timeFit "intercept 1x50"
+ (mkFrameP (\l -> if l=="A" then 3 else 3)
+ |-> designModelHBM (tinyCfg 50) planP [ranIntercept "lot"] "y")
+ True `shouldBe` True
+ xit "PROFILE 相関 50iter" $ do
+ timeFit "correlated 1x50"
+ (mkFrameP (\l -> if l=="A" then 5 else 1)
+ |-> designModelHBM (tinyCfg 50) planP [ranSlope ["temp"] "lot"] "y")
+ True `shouldBe` True
+ xit "PROFILE 相関 100iter" $ do
+ timeFit "correlated 1x100"
+ (mkFrameP (\l -> if l=="A" then 5 else 1)
+ |-> designModelHBM (tinyCfg 100) planP [ranSlope ["temp"] "lot"] "y")
+ True `shouldBe` True
+
+#ifdef PLOT_INTEGRATION
+ -- Phase 78.G-f Task 4: profiler/contour が designModelHBM に載る事後予測帯。
+ -- designMatrixF (dhfFormula m) ef を直接叩き、 fit 時と同じ列順の設計行列を作る
+ -- ( evalFrameAt 相当の helper は無いので eval ModelFrame を手組みする)。
+ -- ★mfParams (合成パラメータ名 "_p0"/"_p1"…) は formula 内部表現なので手で推測せず、
+ -- 訓練済 'dhfFrame' (= mvFrame m) を土台に mfRoles/mfNRows だけ差し替える
+ -- (本番の Core.hs evalFrame と同じ据え置き方)。
+ -- ※ MultiVarModel (mvFrame/mvEvalFrame) は plot 連携層・plot-integration 限定。
+ it "MultiVarModel DesignHBMFit は事後予測帯を返す" $ do
+ let temps = [-1, 1, -1, 1, -1, 1, -1, 1, -1, 1, -1, 1] :: [Double]
+ lots = ["A","A","A","A","A","A","B","B","B","B","B","B"] :: [T.Text]
+ noise = [0.05, -0.03, 0.02, -0.04, 0.01, -0.02, 0.03, -0.01, 0.04, -0.05, 0.02, -0.03]
+ lotShift l = if l == "A" then (-1.0) else 1.0
+ ys = [ 2 + 3 * t + lotShift l + e
+ | (t, l, e) <- zip3 temps lots noise ]
+ mkFrameHBM = DX.insertColumn "lot" (DX.fromList lots)
+ $ DX.insertColumn "temp" (DX.fromList temps)
+ $ DX.insertColumn "y" (DX.fromList ys)
+ $ DX.empty
+ plan = factorialDesign [contFactor "temp" (-1, 1)]
+ m = mkFrameHBM |-> designModelHBM defaultHBM plan [ranIntercept "lot"] "y"
+ ef = (mvFrame m)
+ { mfRoles = [ ("y", RoleResponse (V.fromList [0, 0, 0]))
+ , ("temp", RoleContinuous (V.fromList [-1, 0, 1]))
+ ]
+ , mfNRows = 3
+ }
+ (mu, band) = mvEvalFrame m 0.95 ef
+ length mu `shouldBe` 3
+ band `shouldSatisfy` isJust
+ -- 中心 μ は temp とともに増加 (真の傾き ≈ 3)。
+ (last mu - head mu) `shouldSatisfy` (> 3)
+#endif
+
+ -- Phase 78.G-f Task 5: multiOutput が designModelHBM とも対称に使えること
+ -- (LM/GP と同じ「カレー化 spec (Text -> spec) を渡せば複数応答へ一括適用」 が
+ -- 効くか) の確認。 designModelHBM :: HBMConfig -> Design -> [RandomSpec] -> Text -> spec
+ -- は y が最終引数なので、 部分適用した @designModelHBM defaultHBM plan [ranIntercept "lot"]@
+ -- は @Text -> DesignModelHBMSpec@ となり multiOutput にそのまま渡せる。
+ it "multiOutput で designModelHBM を複数応答に適用できる" $ do
+ let temps = [-1, 1, -1, 1, -1, 1, -1, 1, -1, 1, -1, 1] :: [Double]
+ lots = ["A","A","A","A","A","A","B","B","B","B","B","B"] :: [T.Text]
+ noise = [0.05, -0.03, 0.02, -0.04, 0.01, -0.02, 0.03, -0.01, 0.04, -0.05, 0.02, -0.03]
+ lotShift l = if l == "A" then (-1.0) else 1.0
+ -- y1: 傾き 3、 y2: 傾き -2 (符号違いの別応答 → 2 fit が実際に異なることの傍証)。
+ y1s = [ 2 + 3 * t + lotShift l + e | (t, l, e) <- zip3 temps lots noise ]
+ y2s = [ 5 + (-2) * t + lotShift l + e | (t, l, e) <- zip3 temps lots noise ]
+ mkFrameHBM2 = DX.insertColumn "lot" (DX.fromList lots)
+ $ DX.insertColumn "temp" (DX.fromList temps)
+ $ DX.insertColumn "y1" (DX.fromList y1s)
+ $ DX.insertColumn "y2" (DX.fromList y2s)
+ $ DX.empty
+ plan = factorialDesign [contFactor "temp" (-1, 1)]
+ ms = mkFrameHBM2 |-> multiOutput ["y1", "y2"] (designModelHBM defaultHBM plan [ranIntercept "lot"])
+ map fst ms `shouldBe` ["y1", "y2"]
+
+ -- Phase 78.J: modelFor で multiOutput 結果 [(Text,m)] から応答名でモデルを取り出せる
+ -- (contourOf / surfaceOf に snd (head …) でなく応答名で渡すための selector)。
+ it "modelFor: 応答名でモデルを取り出す (無い名前は error)" $ do
+ modelFor "b" [("a", 1), ("b", 2)] `shouldBe` (2 :: Int)
+ evaluate (modelFor "z" [("a", 1)] :: Int) `shouldThrow` anyErrorCall
+
+ -- Phase 78.G-d: 応答曲面 解析 (自然単位で報告)。 coded 空間に既知の最適点を仕込んだ
+ -- 応答から、 停留点が **自然単位** で復元されること・canonical で性質判定されること・
+ -- steepest ascent 経路が自然単位で出ることを検証する。
+ describe "Design.Workflow RSM 解析 (Phase 78.G-d)" $ do
+ let planR = centralCompositeDesign [contFactor "x1" (150, 180), contFactor "x2" (10, 20)]
+ -- runsheet (自然単位) → coded へ逆変換 (c = (x-center)/half)。
+ codedOf = do
+ let rs = designTable planR
+ temps = maybe [] id (lookup "x1" rs)
+ times = maybe [] id (lookup "x2" rs)
+ c1s = map (\t -> (t - 165) / 15) temps
+ c2s = map (\d -> (d - 15) / 5) times
+ (c1s, c2s)
+ approx tol a b = abs (a - b) < tol
+ stat name rep = maybe (1/0) id (lookup name (rsmStationary rep))
+
+ it "rsmAnalysis: coded 原点が最大の曲面 → 停留点は自然単位の中心・RMaximum" $ do
+ let (c1s, c2s) = codedOf
+ ys = zipWith (\a b -> 100 - (a*a + b*b)) c1s c2s -- coded max at (0,0)
+ rep = rsmAnalysis planR ys
+ rsmNature rep `shouldBe` RMaximum
+ rsmInRegion rep `shouldBe` True
+ stat "x1" rep `shouldSatisfy` approx 1e-6 165 -- 中心 (自然単位)
+ stat "x2" rep `shouldSatisfy` approx 1e-6 15
+ rsmPredicted rep `shouldSatisfy` approx 1e-6 100
+ rsmR2 rep `shouldSatisfy` (> 0.999)
+ all ((< 0) . fst) (rsmCanonical rep) `shouldBe` True -- 全固有値 < 0
+
+ it "rsmAnalysis: coded (0.5,-0.5) が最大 → 停留点が対応する自然単位へ decode" $ do
+ let (c1s, c2s) = codedOf
+ ys = zipWith (\a b -> 50 - ((a-0.5)^(2::Int) + (b+0.5)^(2::Int))) c1s c2s
+ rep = rsmAnalysis planR ys
+ rsmNature rep `shouldBe` RMaximum
+ stat "x1" rep `shouldSatisfy` approx 1e-6 172.5 -- 165 + 0.5*15
+ stat "x2" rep `shouldSatisfy` approx 1e-6 12.5 -- 15 + (-0.5)*5
+
+ it "rsmAnalysis: c1² - c2² は鞍点 (固有値 混在) → RSaddle" $ do
+ let (c1s, c2s) = codedOf
+ ys = zipWith (\a b -> a*a - b*b) c1s c2s
+ rep = rsmAnalysis planR ys
+ rsmNature rep `shouldBe` RSaddle
+ any ((> 0) . fst) (rsmCanonical rep) `shouldBe` True
+ any ((< 0) . fst) (rsmCanonical rep) `shouldBe` True
+
+ it "steepestAscentNatural: 線形上昇 (coded x1 方向) の経路が自然単位で出る" $ do
+ let (c1s, c2s) = codedOf
+ ys = zipWith (\a _ -> a) c1s c2s -- coded 勾配 = (1, 0)
+ path = steepestAscentNatural True planR ys 0.5 2
+ x1s = map (maybe (1/0) id . lookup "x1") path
+ x2s = map (maybe (1/0) id . lookup "x2") path
+ length path `shouldBe` 3 -- nSteps + 1
+ and (zipWith (approx 1e-6) x1s [165, 172.5, 180]) `shouldBe` True
+ all (approx 1e-6 15) x2s `shouldBe` True -- x2 は動かない
+
+ it "rsmAnalysis: カテゴリ因子を含む設計は error (連続専用)" $ do
+ let planCat = factorialDesign [contFactor "x1" (0,1), catFactor "g" ["a","b"]]
+ evaluate (rsmNature (rsmAnalysis planCat [1,2,3,4])) `shouldThrow` anyException
+
+ -- Phase 78.G: Box-Behnken 応答曲面計画 (k = 3,4,5・±α なし・2 次モデル)。
+ describe "Design.Workflow Box-Behnken (Phase 78.G)" $ do
+ let planBB = boxBehnkenDesign [contFactor "t" (150,180), contFactor "p" (1,3), contFactor "c" (5,15)]
+
+ it "boxBehnkenDesign: k=3 は 12 corner + 中心点 (= CCD より少なめ・±α なし)" $ do
+ let rs = designTable planBB
+ n = length (maybe [] id (lookup "t" rs))
+ n `shouldBe` (12 + 3) -- corner 12 + nC=k=3
+
+ it "boxBehnkenDesign: 各因子は -1/0/+1 の 3 水準に収まる (±α を持たない)" $ do
+ let rs = designTable planBB
+ -- t: center 165・half 15 → 実値は 150/165/180 のみ (coded -1/0/+1)
+ tvals = maybe [] id (lookup "t" rs)
+ -- CCD の軸点 (143.8.. 等) のような立方体外の値が無いことを確認
+ all (`elem` [150,165,180]) tvals `shouldBe` True
+
+ it "boxBehnkenDesign: RSM ゆえ formula = 2 次モデル" $
+ designFormula planBB "y" `shouldBe`
+ "y ~ t + p + c + t:p + t:c + p:c + I(t^2) + I(p^2) + I(c^2)"
+
+ it "boxBehnkenDesign: designModel で 2 次モデルを当てられる (真モデル再現)" $ do
+ let rs = designTable planBB
+ tv = maybe [] id (lookup "t" rs)
+ pv = maybe [] id (lookup "p" rs)
+ cv = maybe [] id (lookup "c" rs)
+ ys = zipWith3 (\t p c -> 10 + 0.1*t + 2*p - 0.5*c + 0.01*t*p) tv pv cv
+ m = (("y", ys) : rs) |-> designModel planBB "y"
+ rSquared1 (mlmResult m) `shouldSatisfy` (> 0.99)
+
+ -- Phase 78.G: 一部実施要因 (fractional factorial・run 削減)。
+ describe "Design.Workflow fractional (Phase 78.G)" $ do
+ let specs7 = [ contFactor (T.pack [c]) (0, 1) | c <- "abcdefg" ] -- 7 因子
+
+ -- ★カタログ自己検証: 各 generator の解像度が表のラベルと一致するか (誤り混入ガード)。
+ it "fractionalCatalog: 全エントリの generator 解像度がラベルと一致 (fracResolution 照合)" $
+ [ (k, n, resNum r, fracResolution k gens)
+ | k <- [3..16], (n, r, gens) <- fractionalCatalog k
+ , resNum r /= fracResolution k gens ]
+ `shouldBe` []
+
+ it "fractionalCatalog: run 数 = 2^(k - p) (p = generator 数)" $
+ [ (k, n, 2 ^ (k - length gens))
+ | k <- [3..16], (n, _, gens) <- fractionalCatalog k
+ , n /= 2 ^ (k - length gens) ]
+ `shouldBe` []
+
+ -- Phase 78.G-c k>7 拡張: 16/32-run 追加設計 (NIST 標準表)。
+ let mkN n = [ contFactor (T.pack [c]) (0,1) | c <- take n ['a' ..] ]
+
+ it "fractionalCatalog: k=8 は 16-run Res IV を持つ (NIST 2^(8-4))" $
+ [ (n, resNum r) | (n, r, _) <- fractionalCatalog 8, n == 16 ]
+ `shouldBe` [(16, 4)]
+
+ it "fractionalDesign: 8 因子 ResIV は 16 run" $
+ length (dsCoded (fractionalDesign (mkN 8) ResIV)) `shouldBe` 16
+
+ it "fractionalDesign: 9 因子 ResIV は 32 run (16-run では ResIII しか出ない)" $
+ length (dsCoded (fractionalDesign (mkN 9) ResIV)) `shouldBe` 32
+
+ it "fractionalDesign: 11 因子 ResIV は 32 run" $
+ length (dsCoded (fractionalDesign (mkN 11) ResIV)) `shouldBe` 32
+
+ it "fractionalDesign: 15 因子 (16-run 飽和 ResIII) は 16 run" $
+ length (dsCoded (fractionalDesign (mkN 15) ResIII)) `shouldBe` 16
+
+ it "fractionalDesign: 追加設計も主効果が直交 (k=9 ResIV 32-run・k=15 16-run)" $ do
+ let orthogonal plan =
+ let k = length (dsFactors plan)
+ cols = [ [ row !! j | row <- dsCoded plan ] | j <- [0 .. k - 1] ]
+ dot a b = sum (zipWith (*) a b)
+ in all (\c -> abs (sum c) < 1e-9) cols
+ && and [ abs (dot (cols!!i) (cols!!j)) < 1e-9
+ | i <- [0..k-1], j <- [i+1..k-1] ]
+ orthogonal (fractionalDesign (mkN 9) ResIV) `shouldBe` True
+ orthogonal (fractionalDesign (mkN 15) ResIII) `shouldBe` True
+
+ it "fractionalDesign: 7 因子 ResIII は 8 run (完全要因 128 から大幅削減)" $ do
+ let plan = fractionalDesign specs7 ResIII
+ rs = designTable plan
+ length (maybe [] id (lookup "a" rs)) `shouldBe` 8
+
+ it "fractionalDesign: 解像度指定は「以上」で最小 run を選ぶ (5 因子 ResV = 16 run)" $ do
+ let plan = fractionalDesign [ contFactor (T.pack [c]) (0,1) | c <- "abcde" ] ResV
+ length (dsCoded plan) `shouldBe` 16
+
+ it "fractionalDesign: formula は主効果のみ (交互作用なし)" $
+ designFormula (fractionalDesign specs7 ResIII) "y"
+ `shouldBe` "y ~ a + b + c + d + e + f + g"
+
+ it "fractionalDesign: 主効果は直交 (列同士の内積 = 0)・各列は平衡 (和 = 0)" $ do
+ let plan = fractionalDesign specs7 ResIII
+ cols = [ [ row !! j | row <- dsCoded plan ] | j <- [0 .. 6] ]
+ dot a b = sum (zipWith (*) a b)
+ all (\c -> abs (sum c) < 1e-9) cols `shouldBe` True -- 平衡
+ and [ abs (dot (cols!!i) (cols!!j)) < 1e-9
+ | i <- [0..6], j <- [i+1..6] ] `shouldBe` True -- 直交
+
+ it "fractionalDesignGen: generator 明示 (D=ABC の 2^(4-1)) は 8 run・主効果直交" $ do
+ let plan = fractionalDesignGen [ contFactor (T.pack [c]) (0,1) | c <- "abcd" ] [[1,2,3]]
+ length (dsCoded plan) `shouldBe` 8
+
+ it "fractionalDesign: 削減設計でも主効果 LM を当てられる (主効果 DGP を再現)" $ do
+ let plan = fractionalDesign specs7 ResIII
+ rs = designTable plan
+ cols = map (\c -> maybe [] id (lookup (T.pack [c]) rs)) "abcdefg"
+ ys = foldr1 (zipWith (+))
+ (zipWith (\w col -> map (* w) col) [2,3,-1,4,-2,1,0.5] cols)
+ m = (("y", ys) : rs) |-> designModel plan "y"
+ rSquared1 (mlmResult m) `shouldSatisfy` (> 0.99)
+
+ -- Phase 78.G-c: alias 構造 + clear 2FI formula (fractionalDesignInter/Gen)。
+ let mkS cs = [ contFactor (T.pack [c]) (0,1) | c <- cs ]
+ nInter = T.count ":" -- 2FI 項数 = formula 中の ":" 数
+
+ it "fractionalDesignGenInter: Res V (k=5, I=ABCDE) は全 2FI (C(5,2)=10) を足す" $
+ nInter (designFormula (fractionalDesignGenInter (mkS "abcde") [[1,2,3,4]]) "y")
+ `shouldBe` 10
+
+ it "fractionalDesignGenInter: Res IV (k=4, D=ABC) は交絡群ごと代表 1 個 = 3 個" $
+ nInter (designFormula (fractionalDesignGenInter (mkS "abcd") [[1,2,3]]) "y")
+ `shouldBe` 3
+
+ it "fractionalDesignGenInter: Res III (k=3, C=AB) は 2FI が全て主効果と交絡 → 0 個" $
+ designFormula (fractionalDesignGenInter (mkS "abc") [[1,2]]) "y"
+ `shouldBe` "y ~ a + b + c"
+
+ it "aliasStructure: Res IV (k=4, D=ABC) で a:b は c:d と交絡" $ do
+ let plan = fractionalDesignGenInter (mkS "abcd") [[1,2,3]]
+ fmap (elem "c:d") (lookup "a:b" (aliasStructure plan)) `shouldBe` Just True
+
+ it "fractionalDesignInter: 主効果 + 交互作用 DGP を飽和当てはめ (k=4 ResIV・p=8・R^2~1)" $ do
+ let plan = fractionalDesignGenInter (mkS "abcd") [[1,2,3]] -- 8 run
+ rs = designTable plan
+ col c = maybe [] id (lookup (T.pack [c]) rs)
+ [a,b,cc,d] = map col "abcd"
+ -- 主効果 + 3 交互作用 (交絡群の代表) の DGP。
+ ys = [ 2 + 3*(a!!i) - (b!!i) + 2*(cc!!i) + 0.5*(d!!i)
+ + 1.5*(a!!i * b!!i) - 0.8*(a!!i * cc!!i) + 0.6*(a!!i * d!!i)
+ | i <- [0 .. length a - 1] ]
+ m = (("y", ys) : rs) |-> designModel plan "y"
+ snd (LA.size (mlmDesign m)) `shouldBe` 8 -- 切片 + 4 主効果 + 3 2FI
+ rSquared1 (mlmResult m) `shouldSatisfy` (> 0.999)
+
+ it "fractionalDesignInter: 解像度自動 (k=5 ResV) は 16 run + 全 2FI" $ do
+ let plan = fractionalDesignInter (mkS "abcde") ResV
+ length (dsCoded plan) `shouldBe` 16
+ nInter (designFormula plan "y") `shouldBe` 10
+
+ -- Phase 78.G-a: Taguchi 直交表 (2 水準スクリーニング)。
+ describe "Design.Workflow taguchi (Phase 78.G-a)" $ do
+ let mkSpecs cs = [ contFactor (T.pack [c]) (0, 1) | c <- cs ]
+
+ it "taguchiDesign: 最小 OA 自動選択 (3→L4/7→L8/11→L12/15→L16 run)" $
+ [ length (dsCoded (taguchiDesign (mkSpecs cs)))
+ | cs <- [take n ['a'..] | n <- [3, 7, 11, 15]] ]
+ `shouldBe` [4, 8, 12, 16]
+
+ it "taguchiDesign: 列数境界で次の表へ繰り上がる (4 因子→L8・8 因子→L12)" $
+ [ length (dsCoded (taguchiDesign (mkSpecs (take n ['a'..]))))
+ | n <- [4, 8] ]
+ `shouldBe` [8, 12]
+
+ it "taguchiDesign: coded は ±1 のみ" $
+ all (`elem` [-1, 1]) (concat (dsCoded (taguchiDesign (mkSpecs "abcde"))))
+ `shouldBe` True
+
+ it "taguchiDesign: formula は主効果のみ (交互作用なし)" $
+ designFormula (taguchiDesign (mkSpecs "abcde")) "y"
+ `shouldBe` "y ~ a + b + c + d + e"
+
+ it "taguchiDesign: 各列は平衡 (和 = 0)・列同士は直交 (内積 = 0)" $ do
+ let plan = taguchiDesign (mkSpecs "abcde") -- L8 の先頭 5 列
+ k = 5
+ cols = [ [ row !! j | row <- dsCoded plan ] | j <- [0 .. k - 1] ]
+ dot a b = sum (zipWith (*) a b)
+ all (\c -> abs (sum c) < 1e-9) cols `shouldBe` True
+ and [ abs (dot (cols !! i) (cols !! j)) < 1e-9
+ | i <- [0 .. k - 1], j <- [i + 1 .. k - 1] ] `shouldBe` True
+
+ it "taguchiDesignOA: L12 は 11 因子/12 run のスクリーニング (Plackett-Burman)" $ do
+ let plan = taguchiDesignOA L12 (mkSpecs "abcdefghijk")
+ length (dsCoded plan) `shouldBe` 12
+ length (dsFactors plan) `shouldBe` 11
+
+ it "taguchiDesignOA: 列挙型 OATable で表を明示できる (L8 = 8 run)" $
+ length (dsCoded (taguchiDesignOA L8 (mkSpecs "abc")))
+ `shouldBe` 8
+
+ it "taguchiDesign: L12 で主効果 LM を当てられる (11 因子・主効果 DGP を再現)" $ do
+ let plan = taguchiDesignOA L12 (mkSpecs "abcdefghijk")
+ rs = designTable plan
+ cols = map (\c -> maybe [] id (lookup (T.pack [c]) rs)) "abcdefghijk"
+ ws = [2, 3, -1, 4, -2, 1, 0.5, -3, 2.5, -1.5, 0.8]
+ ys = foldr1 (zipWith (+))
+ (zipWith (\w col -> map (* w) col) ws cols)
+ m = (("y", ys) : rs) |-> designModel plan "y"
+ rSquared1 (mlmResult m) `shouldSatisfy` (> 0.99)
+
+ -- Phase 78.G-a2: 3 水準/混合直交表 (L9/L18/L27)・数値 (opoly) / カテゴリ (contrast)。
+ describe "Design.Workflow taguchi 3水準/混合 (Phase 78.G-a2)" $ do
+ let cats4 = [ catFactor (T.pack [c]) ["lo","mid","hi"] | c <- "abcd" ]
+ nums4 = [ numFactor (T.pack [c]) [1, 2, 3] | c <- "abcd" ]
+
+ it "taguchiDesign: 3 水準カテゴリ 4 因子 → L9 (9 run)" $
+ length (dsCoded (taguchiDesign cats4)) `shouldBe` 9
+
+ it "taguchiDesign: 3 水準数値 4 因子 → L9 (9 run)" $
+ length (dsCoded (taguchiDesign nums4)) `shouldBe` 9
+
+ it "taguchiDesign: 数値 3 水準の formula は opoly (直交多項式 2 自由度)" $
+ designFormula (taguchiDesign [ numFactor "temp" [150,165,180]
+ , numFactor "time" [10,20,30] ]) "y"
+ `shouldBe` "y ~ opoly(temp,2) + opoly(time,2)"
+
+ it "taguchiDesign: カテゴリ 3 水準の formula は主効果名 (contrast は engine 任せ)" $
+ designFormula (taguchiDesign [ catFactor "cat" ["A","B","C"]
+ , catFactor "mat" ["X","Y","Z"] ]) "y"
+ `shouldBe` "y ~ cat + mat"
+
+ it "designTable: 数値 3 水準因子は実水準値の Double 列 (index→実値)" $ do
+ -- L9 の先頭列 (level code 1/2/3) が実値 150/165/180 に写る。 Num は numeric ゆえ
+ -- designTable (numeric runsheet) に載る (Cat と違い error にならない)。
+ let rs = designTable (taguchiDesign [ numFactor "temp" [150,165,180] ])
+ col = maybe [] id (lookup "temp" rs)
+ (length col, all (`elem` [150,165,180]) col) `shouldBe` (9, True)
+
+ it "designFrame: 数値 3 水準因子の列を持つ" $
+ DX.columnNames (designFrame (taguchiDesign [ numFactor "temp" [150,165,180] ]))
+ `shouldContain` ["temp"]
+
+ it "taguchiDesign: 混合 (連続 1 + カテゴリ 3水準 2) → L18 (18 run)" $
+ length (dsCoded (taguchiDesign [ contFactor "p" (0, 1)
+ , catFactor "q" ["a","b","c"]
+ , catFactor "r" ["x","y","z"] ]))
+ `shouldBe` 18
+
+ it "taguchiDesignOA: L9 を明示し 3 水準因子を割り当てられる" $
+ length (dsCoded (taguchiDesignOA L9 nums4)) `shouldBe` 9
+
+ it "taguchiDesign: 数値 3 水準で加法 2 次 DGP を designModel で再現 (R^2 ~ 1)" $ do
+ let plan = taguchiDesign [ numFactor "a" [1,2,3], numFactor "b" [1,2,3] ]
+ rs = designTable plan
+ as = maybe [] id (lookup "a" rs)
+ bs = maybe [] id (lookup "b" rs)
+ ys = zipWith (\a b -> 2 + 3*a - 0.5*a*a + 1*b + 0.2*b*b) as bs
+ m = (("y", ys) : rs) |-> designModel plan "y"
+ rSquared1 (mlmResult m) `shouldSatisfy` (> 0.999)
+
+ -- Phase 78.G-b1: 最適計画 (D/A/I/E/G-最適・カスタム formula・連続因子)。
+ describe "Design.Workflow optimal (Phase 78.G-b1)" $ do
+ let mkSpecs cs = [ contFactor (T.pack [c]) (-1, 1) | c <- cs ]
+
+ it "optimalDesign: run 数 = 指定 n" $
+ length (dsCoded (optimalDesign (mkSpecs "abc") (mainEffects ["a","b","c"]) 6))
+ `shouldBe` 6
+
+ -- Phase 78.I: 候補点数 (2 因子 quadratic = 3×3 = 9) を超える n も点を反復して satisfy する。
+ it "optimalDesign: n が候補点数を超えても run 数 = n (点を反復)" $
+ length (dsCoded (optimalDesign (mkSpecs "ab") (quadratic ["a","b"]) 12))
+ `shouldBe` 12
+
+ it "optimalDesign: 主効果モデル既定は 2 水準候補 (coded ∈ {-1,+1})" $
+ all (`elem` [-1, 1])
+ (concat (dsCoded (optimalDesign (mkSpecs "ab") (mainEffects ["a","b"]) 4)))
+ `shouldBe` True
+
+ it "optimalDesign: 2 次項ありモデル既定は 3 水準候補 (coded ∈ {-1,0,+1})" $
+ all (`elem` [-1, 0, 1])
+ (concat (dsCoded (optimalDesign (mkSpecs "ab") (quadratic ["a","b"]) 8)))
+ `shouldBe` True
+
+ it "optimalDesignLevels: 水準数を明示できる (3 水準グリッド)" $
+ all (`elem` [-1, 0, 1])
+ (concat (dsCoded (optimalDesignLevels 3 (mkSpecs "ab") (mainEffects ["a","b"]) 5)))
+ `shouldBe` True
+
+ it "optimalDesign: 主効果 n=2^k は全格子 = 直交・平衡な full factorial を選ぶ" $ do
+ let plan = optimalDesign (mkSpecs "ab") (mainEffects ["a","b"]) 4
+ cols = [ [ row !! j | row <- dsCoded plan ] | j <- [0, 1] ]
+ dot a b = sum (zipWith (*) a b)
+ all (\c -> abs (sum c) < 1e-9) cols `shouldBe` True -- 平衡
+ abs (dot (cols !! 0) (cols !! 1)) < 1e-9 `shouldBe` True -- 直交
+
+ it "optimalDesign: KCustom formula を焼き込む (designFormula に応答名が入る)" $
+ designFormula (optimalDesign (mkSpecs "ab") (twoWay ["a","b"]) 4) "yield"
+ `shouldSatisfy` T.isPrefixOf "yield "
+
+ it "optimalDesign: n < p (パラメータ数) は error" $
+ -- quadratic 2 因子 = p=6・n=4 < 6
+ evaluate (length (dsCoded (optimalDesign (mkSpecs "ab") (quadratic ["a","b"]) 4)))
+ `shouldThrow` anyErrorCall
+
+ it "optimalDesign: designModel で当てられ・列数 p が formula と一致 (quadratic 2 因子 = 6)" $ do
+ let plan = optimalDesign [contFactor "t" (150,180), contFactor "p" (1,5)] (quadratic ["t","p"]) 9
+ rs = designTable plan
+ tv = maybe [] id (lookup "t" rs)
+ pv = maybe [] id (lookup "p" rs)
+ ys = zipWith (\t p -> 2 + 0.1*t - 0.5*p + 0.01*(t-165)^(2::Int) + 0.02*p*p) tv pv
+ m = (("y", ys) : rs) |-> designModel plan "y"
+ snd (LA.size (mlmDesign m)) `shouldBe` 6 -- 切片+t+p+t:p+t^2+p^2
+ rSquared1 (mlmResult m) `shouldSatisfy` (> 0.99) -- 真 2 次 DGP を再現
+
+ it "optimalDesign: parseRFormula 文字列でモデル指定できる" $ do
+ case (either (const Nothing) Just (parseRFormula "y ~ a + b + a:b")) of
+ Nothing -> expectationFailure "parseRFormula 失敗"
+ Just fml ->
+ length (dsCoded (optimalDesign (mkSpecs "ab") fml 4)) `shouldBe` 4
+
+ -- Phase 78.G-b2: カテゴリ因子 (DesignFactor の FactorKind 和型化・型手術)。
+ describe "Design.Workflow categorical (Phase 78.G-b2)" $ do
+ -- 連続1 (temp) × カテゴリ3水準 (cat) の完全要因 = 2×3 = 6 run。
+ let planMix = factorialDesign
+ [ contFactor "temp" (150, 180)
+ , catFactor "cat" ["A", "B", "C"] ]
+
+ it "factorialDesign: 連続×カテゴリ混合は各水準総当り (2×3 = 6 run)" $
+ length (dsCoded planMix) `shouldBe` 6
+
+ it "factorialDesign: 単一カテゴリ3水準は 3 run (水準数ぶん)" $
+ length (dsCoded (factorialDesign [catFactor "cat" ["A","B","C"]]))
+ `shouldBe` 3
+
+ it "designFrame: カテゴリ列は水準名 (Text)・連続列と run 列を持つ" $ do
+ let df = designFrame planMix
+ DX.columnNames df `shouldContain` ["cat"]
+ DX.columnNames df `shouldContain` ["temp"]
+ DX.columnNames df `shouldContain` ["run"]
+
+ it "designTable: カテゴリ因子を含むと error (designFrame へ誘導)" $
+ evaluate (length (designTable planMix)) `shouldThrow` anyErrorCall
+
+ it "designModel: カテゴリを contrast 展開して当てられる (factor×factor 飽和 → p=6・R^2~1)" $ do
+ -- 純カテゴリ 2 因子 (3水準×2水準 = 6 run) の完全要因 y ~ cat * grp。 treatment contrast で
+ -- 列数 = Kcat*Kgrp = 6 (切片+cat 2+grp 1+cat:grp 2)・6 点 = 飽和 → R^2~1 (DesignSpec 検証点①と同型)。
+ let planCC = factorialDesign [ catFactor "cat" ["A","B","C"], catFactor "grp" ["X","Y"] ]
+ coded = dsCoded planCC
+ catEff i = [0, 5, -3] !! (round i :: Int) :: Double
+ grpEff j = [0, 4] !! (round j :: Int) :: Double
+ ys = [ 10 + catEff (row !! 0) + grpEff (row !! 1) | row <- coded ] :: [Double]
+ df = DX.insertColumn "y" (DX.fromList ys) (designFrame planCC)
+ m = df |-> designModel planCC "y"
+ snd (LA.size (mlmDesign m)) `shouldBe` 6 -- 切片+cat(2)+grp(1)+cat:grp(2)
+ rSquared1 (mlmResult m) `shouldSatisfy` (> 0.999)
+
+ it "centralCompositeDesign: カテゴリ因子は error (連続専用・±α 軸点ゆえ)" $
+ evaluate (length (dsCoded (centralCompositeDesign [contFactor "x" (0,1), catFactor "c" ["A","B"]])))
+ `shouldThrow` anyErrorCall
+
+ it "taguchiDesign: 連続 + binary カテゴリ (共に 2 水準) → L4 (G-a2 で受理)" $
+ -- G-a2 以降 taguchi はカテゴリを受ける。 連続(2)+binary(2) = 2 因子とも 2 水準 → L4。
+ length (dsCoded (taguchiDesign [contFactor "x" (0,1), catFactor "c" ["A","B"]]))
+ `shouldBe` 4
+
+ it "fractionalDesign: 2 水準 (binary) カテゴリは許容 (coded ±1 に写す)" $ do
+ -- 連続5 + binary カテゴリ2 = 7 因子・ResIII = 8 run。
+ let specs = [ contFactor (T.pack [c]) (0,1) | c <- "abcde" ]
+ ++ [ catFactor "cat1" ["lo","hi"], catFactor "cat2" ["off","on"] ]
+ length (dsCoded (fractionalDesign specs ResIII)) `shouldBe` 8
+
+ it "fractionalDesign: 3 水準以上のカテゴリは error (binary のみ対応)" $
+ evaluate (length (dsCoded
+ (fractionalDesign
+ ([ contFactor (T.pack [c]) (0,1) | c <- "abc" ]
+ ++ [ catFactor "cat" ["A","B","C"] ]) ResIII)))
+ `shouldThrow` anyErrorCall
+
+ it "optimalDesign: カテゴリ因子を候補展開して選べる (run 数 = n)" $
+ length (dsCoded
+ (optimalDesign
+ [ contFactor "x" (-1,1), catFactor "cat" ["A","B"] ]
+ (mainEffects ["x","cat"]) 4))
+ `shouldBe` 4
+
+ -- Phase 78.K: 設計の保存 (CSV) と DataFrame からの復元 (planFromFrame)。
+ describe "Design.Workflow save / planFromFrame (Phase 78.K)" $ do
+ let approxRows a b =
+ length a == length b
+ && and (zipWith (\r s -> length r == length s
+ && and (zipWith (\x y -> abs (x - y) < 1e-9) r s)) a b)
+
+ it "planFromFrame: designFrame の逆で coded を復元 (連続・round-trip)" $ do
+ let facs = [ contFactor "temp" (150, 180), contFactor "time" (10, 20) ]
+ plan = centralCompositeDesign facs
+ plan2 = planFromFrame facs (quadratic ["temp", "time"]) (designFrame plan)
+ approxRows (dsCoded plan2) (dsCoded plan) `shouldBe` True
+
+ it "planFromFrame: カテゴリ混在も復元し designModel で当たる" $ do
+ let facs = [ contFactor "temp" (150, 180), catFactor "cat" ["A", "B", "C"] ]
+ plan = factorialDesign facs
+ df = designFrame plan
+ plan2 = planFromFrame facs (mainEffects ["temp", "cat"]) df
+ length (dsCoded plan2) `shouldBe` length (dsCoded plan) -- run 数一致
+ -- 応答を足して fit できる (formula = 主効果・p = 切片+temp+cat(2) = 4)
+ let ys = map fromIntegral [1 .. length (dsCoded plan)] :: [Double]
+ m = DX.insertColumn "y" (DX.fromList ys) df |-> designModel plan2 "y"
+ snd (LA.size (mlmDesign m)) `shouldBe` 4
+
+ it "planFromFrame: 因子列が df に無いと error" $ do
+ let df = designFrame (factorialDesign [contFactor "temp" (150, 180)])
+ evaluate (length (dsCoded
+ (planFromFrame [contFactor "NOPE" (0, 1)] (mainEffects ["NOPE"]) df)))
+ `shouldThrow` anyErrorCall
+
+ it "saveDesign: runsheet を CSV に書ける (header + N run 行)" $
+ withSystemTempDirectory "doe-save" $ \dir -> do
+ let plan = centralCompositeDesign [contFactor "temp" (150, 180), contFactor "time" (10, 20)]
+ path = dir ++ "/runsheet.csv"
+ saveDesign path plan
+ content <- readFile path
+ let ls = filter (not . null) (lines content)
+ length ls `shouldBe` (1 + length (dsCoded plan)) -- header + 10 run
+ head ls `shouldSatisfy` (\h -> all (`isInfixOf` h) ["run", "temp", "time"])
+
+ -- Phase 79: 因子は純粋に因子 (役割 dfRole は撤去・階層は Structure が名前で持つ)。
+ describe "Phase 79: 因子の smart ctor (dfName/dfKind)" $ do
+ it "smart ctor の dfName/dfKind (連続 / 数値順序 / カテゴリ)" $ do
+ dfName (contFactor "temp" (150, 180)) `shouldBe` "temp"
+ dfKind (contFactor "temp" (150, 180)) `shouldBe` Cont 150 180 SLinear
+ dfKind (contFactorLog "conc" (0.01, 10)) `shouldBe` Cont 0.01 10 SLog
+ dfKind (numFactor "t" [150, 165, 180]) `shouldBe` Num [150, 165, 180]
+ dfKind (catFactor "cat" ["A", "B"]) `shouldBe` Cat ["A", "B"]
+
+ -- Phase 78.M M3: Formula (効果DSL) → Custom.Model 変換。
+ describe "Phase 78.M M3: formulaToCustomModel" $ do
+ let names = ["a", "b"]
+ terms f = fmap CMd.mTerms (formulaToCustomModel names f)
+ it "mainEffects → 切片 + 各主効果 (TIntercept/TMain)" $
+ terms (mainEffects names)
+ `shouldBe` Right [CMd.TIntercept, CMd.TMain "a", CMd.TMain "b"]
+
+ it "twoWay → 主効果 + 2 因子交互作用 (TInter)" $
+ terms (twoWay names)
+ `shouldBe` Right [CMd.TIntercept, CMd.TMain "a", CMd.TMain "b", CMd.TInter ["a", "b"]]
+
+ it "quadratic → 主効果 + 交互作用 + 2 次項 (TPower)" $
+ terms (quadratic names)
+ `shouldBe` Right
+ [ CMd.TIntercept, CMd.TMain "a", CMd.TMain "b"
+ , CMd.TInter ["a", "b"], CMd.TPower "a" 2, CMd.TPower "b" 2 ]
+
+ it "正規化は NCoded (optimalDesign と同じ coded 規約)" $
+ fmap CMd.mNorm (formulaToCustomModel names (quadratic names))
+ `shouldBe` Right CMd.NCoded
+
+ it "基底関数など未対応項は Left" $ do
+ let f = either (error "parse") id (parseRFormula "_y ~ opoly(a, 2)")
+ case formulaToCustomModel ["a"] f of
+ Left _ -> pure ()
+ Right m -> expectationFailure ("expected Left, got " ++ show (CMd.mTerms m))
+
+ -- Phase 79: 完全カスタムデザインエンジン (CustomSpec / Structure)。
+ describe "Phase 79: customDesign (CustomSpec)" $ do
+ it "CRD: n run の Design を返す (KStructured [])" $ do
+ let plan = customDesign (customSpec
+ [contFactor "temp" (150, 180), contFactor "time" (10, 20)]
+ (quadratic ["temp", "time"]) 10 42)
+ length (dsCoded plan) `shouldBe` 10
+ case dsKind plan of
+ KStructured [] _ -> pure () -- CRD = 群列なし
+ k -> expectationFailure ("expected KStructured [] , got " ++ show k)
+
+ it "CRD: seed 決定的 (2 回同結果・pure)" $ do
+ let mk = customDesign (customSpec [contFactor "a" (-1, 1), contFactor "b" (-1, 1)]
+ (twoWay ["a", "b"]) 8 7)
+ dsCoded mk `shouldBe` dsCoded mk
+
+ it "customSpec の既定は CRD・DOpt・制約なし" $ do
+ let cs = customSpec [contFactor "a" (-1, 1)] (mainEffects ["a"]) 4 1
+ csStructure cs `shouldBe` CRD
+ csCriterion cs `shouldBe` DOpt
+ csConstraints cs `shouldBe` []
+
+ it "制約つき CRD: 線形制約 x1+x2<=0.5 (coded) を全 run が満たす" $ do
+ let cons = [ LinearIneq [("x1", 1), ("x2", 1)] CLeq 0.5 ]
+ plan = customDesign (customSpec
+ [contFactor "x1" (-1, 1), contFactor "x2" (-1, 1)]
+ (twoWay ["x1", "x2"]) 8 42) { csConstraints = cons }
+ sums = map sum (dsCoded plan) -- coded x1 + x2
+ length (dsCoded plan) `shouldBe` 8
+ all (<= 0.5 + 1e-9) sums `shouldBe` True -- 制約違反 (例 [1,1]=2.0) が出ない
+
+ it "csConstraints=[] は制約なし既定と同結果 (回帰)" $ do
+ let fs = [contFactor "x1" (-1, 1), contFactor "x2" (-1, 1)]
+ base = customSpec fs (twoWay ["x1", "x2"]) 8 42
+ dsCoded (customDesign base)
+ `shouldBe` dsCoded (customDesign base { csConstraints = [] })
+
+ it "CRD: Num 因子 (数値順序) も使える — dsCoded は水準 index" $ do
+ let plan = customDesign (customSpec
+ [numFactor "temp" [150, 165, 180], contFactor "time" (10, 20)]
+ (quadratic ["temp", "time"]) 9 3)
+ length (dsCoded plan) `shouldBe` 9
+ -- temp (列 0) は水準 index {0,1,2} (numLevelAt が実値へ戻す規約)
+ let tempIdx = map (round . head) (dsCoded plan) :: [Int]
+ all (`elem` [0, 1, 2]) tempIdx `shouldBe` True
+ -- designFrame は temp を実水準値 {150,165,180} に decode する (round-trip)
+ let tempVals = case getDoubleVec "temp" (designFrame plan) of
+ Just v -> V.toList v
+ Nothing -> error "temp 列が無い"
+ all (`elem` [150, 165, 180]) tempVals `shouldBe` True
+
+ -- Phase 79.2: SplitPlot 構造 (群単位ムーブ + GLS 基準)。
+ it "SplitPlot: KStructured [(wholePlot, ids)]・群 ID が n 個・nWhole 群" $ do
+ let plan = customDesign (customSpec
+ [contFactor "temp" (150, 180), contFactor "rate" (10, 20)]
+ (twoWay ["temp", "rate"]) 8 50) { csStructure = splitPlot ["temp"] 4 }
+ length (dsCoded plan) `shouldBe` 8
+ case dsKind plan of
+ KStructured [("wholePlot", ids)] _ -> do
+ length ids `shouldBe` 8
+ length (nub ids) `shouldBe` 4 -- 4 whole-plot
+ k -> expectationFailure ("expected KStructured [(wholePlot,_)], got " ++ show k)
+
+ it "SplitPlot: whole-plot 因子 (temp) は群内で一定" $ do
+ let plan = customDesign (customSpec
+ [contFactor "temp" (150, 180), contFactor "rate" (10, 20)]
+ (twoWay ["temp", "rate"]) 8 50) { csStructure = splitPlot ["temp"] 4 }
+ case dsKind plan of
+ KStructured [("wholePlot", ids)] _ -> do
+ let tempCol = [ row !! 0 | row <- dsCoded plan ] -- temp = 列 0
+ byGroup g = [ t | (t, i) <- zip tempCol ids, i == g ]
+ all (\g -> let vs = byGroup g in all (== head vs) vs) (nub ids)
+ `shouldBe` True
+ _ -> expectationFailure "expected KStructured [(wholePlot,_)]"
+
+ it "SplitPlot: seed 決定的 (2 回同結果・pure)" $ do
+ let mk = customDesign (customSpec
+ [contFactor "temp" (150, 180), contFactor "rate" (10, 20)]
+ (twoWay ["temp", "rate"]) 8 50) { csStructure = splitPlot ["temp"] 4 }
+ dsCoded mk `shouldBe` dsCoded mk
+
+ -- Jones-Goos (2012) Table 2 golden を高レベル API へ移植: 20-run split-plot
+ -- (4 WP × 5 SP・full quadratic・η=1) の D-criterion det(Xᵀ M⁻¹ X) が文献値 2684.44 に到達。
+ -- 低レベル golden (Custom.SplitPlotSpec) と同じ math を新エンジンで再確認する。
+ it "SplitPlot golden: det(Xᵀ M⁻¹ X) が Jones-Goos 2012 文献値 ≥ 2684" $ do
+ let fs = [contFactor "w" (-1, 1), contFactor "s" (-1, 1)]
+ plan = customDesign (customSpec fs (quadratic ["w", "s"]) 20 42)
+ { csStructure = splitPlot ["w"] 4 }
+ case dsKind plan of
+ KStructured [("wholePlot", ids)] _ -> do
+ let raw = LA.fromLists (dsCoded plan)
+ cfW = [ CF.Factor "w" (CF.Continuous (-1) 1) CF.Controllable
+ , CF.Factor "s" (CF.Continuous (-1) 1) CF.Controllable ]
+ model = either (error . T.unpack) id
+ (formulaToCustomModel ["w", "s"] (quadratic ["w", "s"]))
+ mInv = ST.buildMInvFromGroups 20 [(1.0, VS.fromList ids)]
+ case CMd.expandDesignMatrix cfW model raw of
+ Left e -> expectationFailure (T.unpack e)
+ Right x -> do
+ let dval = LA.det (LA.tr x LA.<> (mInv LA.<> x))
+ dval `shouldSatisfy` (>= 2684.0)
+ k -> expectationFailure ("expected KStructured [(wholePlot,_)], got " ++ show k)
+
+ -- Phase 79.3: StripPlot (交差 2 階層・whole-plot × strip)。
+ it "StripPlot: 2 群列 (wholePlot, strip)・n = nWhole × nStrip" $ do
+ let plan = customDesign (customSpec
+ [ contFactor "wp" (-1, 1), contFactor "st" (-1, 1), contFactor "sp" (-1, 1) ]
+ (mainEffects ["wp", "st", "sp"]) 12 7)
+ { csStructure = stripPlot ["wp"] 4 ["st"] 3 }
+ length (dsCoded plan) `shouldBe` 12
+ case dsKind plan of
+ KStructured [("wholePlot", wpIds), ("strip", stIds)] _ -> do
+ length wpIds `shouldBe` 12
+ length stIds `shouldBe` 12
+ length (nub wpIds) `shouldBe` 4
+ length (nub stIds) `shouldBe` 3
+ k -> expectationFailure ("expected KStructured [(wholePlot,_),(strip,_)], got " ++ show k)
+
+ it "StripPlot: whole-plot 因子は WP 群内で一定・strip 因子は strip 群内で一定" $ do
+ let plan = customDesign (customSpec
+ [ contFactor "wp" (-1, 1), contFactor "st" (-1, 1), contFactor "sp" (-1, 1) ]
+ (mainEffects ["wp", "st", "sp"]) 12 7)
+ { csStructure = stripPlot ["wp"] 4 ["st"] 3 }
+ case dsKind plan of
+ KStructured [("wholePlot", wpIds), ("strip", stIds)] _ -> do
+ let colOf j = [ row !! j | row <- dsCoded plan ]
+ constIn ids col = all (\g -> let vs = [ c | (c, i) <- zip col ids, i == g ]
+ in all (== head vs) vs) (nub ids)
+ constIn wpIds (colOf 0) `shouldBe` True -- wp (列 0) は WP 群内で一定
+ constIn stIds (colOf 1) `shouldBe` True -- st (列 1) は strip 群内で一定
+ _ -> expectationFailure "expected KStructured [(wholePlot,_),(strip,_)]"
+
+ it "StripPlot: n ≠ nWhole × nStrip は error" $ do
+ let bad = customDesign (customSpec
+ [ contFactor "wp" (-1, 1), contFactor "st" (-1, 1) ]
+ (mainEffects ["wp", "st"]) 10 7)
+ { csStructure = stripPlot ["wp"] 4 ["st"] 3 } -- 4×3=12 ≠ 10
+ evaluate (length (dsCoded bad)) `shouldThrow` anyErrorCall
+
+ -- Phase 79.4: Blocked (ランダムブロック)。 全因子はブロック内で自由・block は run 割付のみ。
+ it "Blocked: KStructured [(block, ids)]・n run・nBlocks 群・因子列は block を含まない" $ do
+ let plan = customDesign (customSpec
+ [ contFactor "x1" (-1, 1), contFactor "x2" (-1, 1) ]
+ (twoWay ["x1", "x2"]) 12 5) { csStructure = blocked 3 }
+ length (dsCoded plan) `shouldBe` 12
+ map length (dsCoded plan) `shouldSatisfy` all (== 2) -- 因子は 2 列 (block は列でない)
+ case dsKind plan of
+ KStructured [("block", ids)] _ -> do
+ length ids `shouldBe` 12
+ length (nub ids) `shouldBe` 3
+ k -> expectationFailure ("expected KStructured [(block,_)], got " ++ show k)
+
+ it "Blocked: det(Xᵀ M⁻¹ X) > 0 (非特異・full-rank 設計) + seed 決定的" $ do
+ let fs = [ contFactor "x1" (-1, 1), contFactor "x2" (-1, 1) ]
+ plan = customDesign (customSpec fs (twoWay ["x1", "x2"]) 12 5)
+ { csStructure = blocked 3 }
+ dsCoded plan `shouldBe` dsCoded plan -- pure
+ case dsKind plan of
+ KStructured [("block", ids)] _ -> do
+ let raw = LA.fromLists (dsCoded plan)
+ cfs = [ CF.Factor "x1" (CF.Continuous (-1) 1) CF.Controllable
+ , CF.Factor "x2" (CF.Continuous (-1) 1) CF.Controllable ]
+ model = either (error . T.unpack) id
+ (formulaToCustomModel ["x1", "x2"] (twoWay ["x1", "x2"]))
+ mInv = ST.buildMInvFromGroups 12 [(1.0, VS.fromList ids)]
+ case CMd.expandDesignMatrix cfs model raw of
+ Left e -> expectationFailure (T.unpack e)
+ Right x -> LA.det (LA.tr x LA.<> (mInv LA.<> x)) `shouldSatisfy` (> 0)
+ _ -> expectationFailure "expected KStructured [(block,_)]"
+
+ -- Phase 79.5: 制約 × 構造。 78.M では customDesign (制約) と splitPlotDesign (階層) が
+ -- 別関数で両立不可だった本命ギャップ。 whole-plot 群内一定 かつ 制約満足を同時に満たす。
+ it "SplitPlot + 線形制約: whole-plot 群内一定 かつ rate<=0.5 (coded) を全 run が満たす" $ do
+ let cons = [ LinearIneq [("rate", 1)] CLeq 0.5 ]
+ plan = customDesign (customSpec
+ [contFactor "temp" (150, 180), contFactor "rate" (-1, 1)]
+ (twoWay ["temp", "rate"]) 8 50)
+ { csStructure = splitPlot ["temp"] 4, csConstraints = cons }
+ length (dsCoded plan) `shouldBe` 8
+ case dsKind plan of
+ KStructured [("wholePlot", ids)] _ -> do
+ let tempCol = [ row !! 0 | row <- dsCoded plan ] -- temp = 列 0 (whole-plot)
+ rateCol = [ row !! 1 | row <- dsCoded plan ] -- rate = 列 1 (sub-plot)
+ -- (a) 制約: 全 run の rate <= 0.5
+ all (<= 0.5 + 1e-9) rateCol `shouldBe` True
+ -- (b) 階層: temp が whole-plot 群内で一定
+ let byGroup g = [ t | (t, i) <- zip tempCol ids, i == g ]
+ all (\g -> let vs = byGroup g in all (== head vs) vs) (nub ids)
+ `shouldBe` True
+ k -> expectationFailure ("expected KStructured [(wholePlot,_)], got " ++ show k)
+
+ it "SplitPlot + 制約: seed 決定的 (pure)" $ do
+ let cons = [ LinearIneq [("rate", 1)] CLeq 0.5 ]
+ mk = customDesign (customSpec
+ [contFactor "temp" (150, 180), contFactor "rate" (-1, 1)]
+ (twoWay ["temp", "rate"]) 8 50)
+ { csStructure = splitPlot ["temp"] 4, csConstraints = cons }
+ dsCoded mk `shouldBe` dsCoded mk
+
+ -- Phase 79.6: 複数群列 → 複数 ranIntercept の HBM round-trip。 StripPlot は 2 群列
+ -- (wholePlot, strip) を designFrame に Text ラベルで出すので、 そのまま階層モデルに乗る。
+ it "round-trip: StripPlot → designFrame に 2 群列 (Text)・両方 ranIntercept が当たる" $ do
+ let plan = customDesign (customSpec
+ [ contFactor "wp" (-1, 1), contFactor "st" (-1, 1), contFactor "sp" (-1, 1) ]
+ (mainEffects ["wp", "st", "sp"]) 12 7)
+ { csStructure = stripPlot ["wp"] 4 ["st"] 3 }
+ n = length (dsCoded plan)
+ ys = [ 100 + 2 * fromIntegral i | i <- [1 .. n] ] :: [Double]
+ df = DX.insertColumn "y" (DX.fromList ys) (designFrame plan)
+ m = df |-> designModelHBM defaultHBM plan
+ [ranIntercept "wholePlot", ranIntercept "strip"] "y"
+ -- 固定効果 beta が取り出せれば 2 階層 round-trip は地続きに成立 (happy-path 構造検証)
+ length (dhfBetaNames m) `shouldSatisfy` (> 0)
+
+ -- Phase 82: 自然単位の制約 (natLeq / natGeq / natForbid)。 実単位で書いた制約が
+ -- customDesign 入口で coded へ正規化され、 designFrame の実値がその実単位境界を守る。
+ describe "Phase 82: 自然単位の線形制約 (natLeq/natForbid)" $ do
+ it "natLeq temp<=160 (Cont 150..180): designFrame の temp が全 run <= 160" $ do
+ let plan = customDesign (customSpec
+ [contFactor "temp" (150, 180), contFactor "time" (10, 20)]
+ (mainEffects ["temp", "time"]) 8 42)
+ { csNatConstraints = [natLeq [("temp", 1)] 160] }
+ temps = maybe (error "temp 列なし") V.toList (getDoubleVec "temp" (designFrame plan))
+ length temps `shouldBe` 8
+ all (<= 160 + 1e-9) temps `shouldBe` True
+
+ it "natLeq temp+time<=175 (実単位和): 全 run で temp+time <= 175" $ do
+ let plan = customDesign (customSpec
+ [contFactor "temp" (150, 180), contFactor "time" (10, 20)]
+ (mainEffects ["temp", "time"]) 8 42)
+ { csNatConstraints = [natLeq [("temp", 1), ("time", 1)] 175] }
+ df = designFrame plan
+ ts = maybe (error "temp") V.toList (getDoubleVec "temp" df)
+ tm = maybe (error "time") V.toList (getDoubleVec "time" df)
+ all (<= 175 + 1e-9) (zipWith (+) ts tm) `shouldBe` True
+
+ it "natForbid: Num 因子を実水準値 (180) で禁止 → designFrame に 180 が出ない" $ do
+ let plan = customDesign (customSpec
+ [numFactor "temp" [150, 165, 180], contFactor "time" (10, 20)]
+ (mainEffects ["temp", "time"]) 8 42)
+ { csNatConstraints = [natForbid [("temp", FVDouble 180)]] }
+ temps = maybe (error "temp") V.toList (getDoubleVec "temp" (designFrame plan))
+ notElem 180 temps `shouldBe` True
+ all (`elem` [150, 165]) temps `shouldBe` True
+
+ it "natLeq がカテゴリ因子を参照するとエラー (順序なし)" $ do
+ let plan = customDesign (customSpec
+ [catFactor "cat" ["A", "B"], contFactor "x" (0, 1)]
+ (mainEffects ["cat", "x"]) 4 1)
+ { csNatConstraints = [natLeq [("cat", 1)] 0.5] }
+ evaluate (length (dsCoded plan)) `shouldThrow` anyErrorCall
+
+ -- Phase 82.2: 離散数値 (Num) 因子の実値閾値。 単一項 natLeq/natGeq/natEq は
+ -- 「閾値を満たさない水準を除外」に展開される (半空間でなく水準フィルタ)。
+ describe "Phase 82.2: 離散数値因子の実値閾値フィルタ (natLeq/natGeq Num)" $ do
+ it "natLeq temp<=160 (Num 150/165/180): 全 run が 160 以下 (= 150 のみ残る)" $ do
+ let plan = customDesign (customSpec
+ [numFactor "temp" [150, 165, 180], contFactor "time" (10, 20)]
+ (mainEffects ["temp", "time"]) 8 42)
+ { csNatConstraints = [natLeq [("temp", 1)] 160] }
+ temps = maybe (error "temp") V.toList (getDoubleVec "temp" (designFrame plan))
+ all (<= 160 + 1e-9) temps `shouldBe` True
+ all (== 150) temps `shouldBe` True
+
+ it "natGeq temp>=165 (Num): 165/180 のみ残り 150 は消える" $ do
+ let plan = customDesign (customSpec
+ [numFactor "temp" [150, 165, 180], contFactor "time" (10, 20)]
+ (mainEffects ["temp", "time"]) 8 42)
+ { csNatConstraints = [natGeq [("temp", 1)] 165] }
+ temps = maybe (error "temp") V.toList (getDoubleVec "temp" (designFrame plan))
+ notElem 150 temps `shouldBe` True
+ all (`elem` [165, 180]) temps `shouldBe` True
+
+ it "係数付き natLeq 2·temp<=330 (Num): 実値換算で 165 以下 (150/165 が残る)" $ do
+ let plan = customDesign (customSpec
+ [numFactor "temp" [150, 165, 180], contFactor "time" (10, 20)]
+ (mainEffects ["temp", "time"]) 8 42)
+ { csNatConstraints = [natLeq [("temp", 2)] 330] }
+ temps = maybe (error "temp") V.toList (getDoubleVec "temp" (designFrame plan))
+ notElem 180 temps `shouldBe` True
+ all (`elem` [150, 165]) temps `shouldBe` True
+
+ it "Num 因子を他因子と線形結合するとエラー (単一項のみ)" $ do
+ let plan = customDesign (customSpec
+ [numFactor "temp" [150, 165, 180], contFactor "time" (10, 20)]
+ (mainEffects ["temp", "time"]) 8 42)
+ { csNatConstraints = [natLeq [("temp", 1), ("time", 1)] 175] }
+ evaluate (length (dsCoded plan)) `shouldThrow` anyErrorCall
+
+ it "どの水準も満たさない閾値はエラー (temp<=100・水準 150..180)" $ do
+ let plan = customDesign (customSpec
+ [numFactor "temp" [150, 165, 180], contFactor "time" (10, 20)]
+ (mainEffects ["temp", "time"]) 8 42)
+ { csNatConstraints = [natLeq [("temp", 1)] 100] }
+ evaluate (length (dsCoded plan)) `shouldThrow` anyErrorCall
+
+ -- Phase 82.3: 対数スケール連続因子 (contFactorLog)。 coded [-1,1] は不変だが自然単位へは
+ -- 幾何的 (10^…) に写す。 中心点が幾何平均・自然単位制約も log 空間で載る。
+ describe "Phase 82.3: 対数スケール連続因子 (contFactorLog)" $ do
+ it "幾何 decode: 中心点 conc が幾何平均 (10^-0.5≈0.316)・算術平均 (5.005) でない" $ do
+ let plan = customDesign (customSpec
+ [contFactorLog "conc" (0.01, 10), contFactor "t" (10, 20)]
+ (quadratic ["conc", "t"]) 12 7)
+ concs = maybe (error "conc 列なし") V.toList (getDoubleVec "conc" (designFrame plan))
+ geoM = 10 ** (-0.5) -- 幾何平均
+ -- 全 conc が範囲内 [0.01, 10]
+ all (\x -> x >= 0.01 - 1e-9 && x <= 10 + 1e-9) concs `shouldBe` True
+ -- 中心点は幾何平均 (0.316…) が現れ、 算術平均 (5.005) は現れない
+ any (\x -> abs (x - geoM) < 1e-6) concs `shouldBe` True
+ all (\x -> abs (x - 5.005) > 1e-3) concs `shouldBe` True
+
+ it "natLeq conc<=0.1 (log因子・単一境界): 全 conc <= 0.1" $ do
+ let plan = customDesign (customSpec
+ [contFactorLog "conc" (0.01, 10), contFactor "t" (10, 20)]
+ (mainEffects ["conc", "t"]) 8 7)
+ { csNatConstraints = [natLeq [("conc", 1)] 0.1] }
+ concs = maybe (error "conc") V.toList (getDoubleVec "conc" (designFrame plan))
+ all (<= 0.1 + 1e-9) concs `shouldBe` True
+
+ it "自然単位の線形結合に log 因子が混ざるとエラー (非線形)" $ do
+ let plan = customDesign (customSpec
+ [contFactorLog "conc" (0.01, 10), contFactor "t" (10, 20)]
+ (mainEffects ["conc", "t"]) 8 7)
+ { csNatConstraints = [natLeq [("conc", 1), ("t", 1)] 15] }
+ evaluate (length (dsCoded plan)) `shouldThrow` anyErrorCall
+
+ it "実行不能エラーは有効な制約と因子範囲を実単位で添える" $ do
+ -- temp∈[150,180] に temp<=100 は両立不能。 エラーに実単位の制約と範囲が出る。
+ let plan = customDesign (customSpec
+ [contFactor "temp" (150, 180), contFactor "t" (10, 20)]
+ (mainEffects ["temp", "t"]) 6 1)
+ { csNatConstraints = [natLeq [("temp", 1)] 100] }
+ evaluate (length (dsCoded plan)) `shouldThrow`
+ (\(ErrorCall m) -> "1.0·temp ≤ 100.0" `isInfixOf` m
+ && "temp ∈ [150.0, 180.0]" `isInfixOf` m)
+
+ -- designFrameRound: runsheet の桁数調整 (CCD 軸点の長い小数を丸める)。
+ describe "designFrameRound (runsheet 桁数調整)" $ do
+ it "連続因子の実値を小数第 n 位に丸める (CCD ±α 軸点)" $ do
+ let plan = centralCompositeDesign
+ [contFactor "temp" (150, 180), contFactor "time" (10, 20)]
+ df = designFrameRound 2 plan
+ temps = maybe (error "temp 列なし") V.toList (getDoubleVec "temp" df)
+ -- 軸点 143.78679… / 186.21320… が第 2 位に丸まる
+ (143.79 `elem` temps) `shouldBe` True
+ (186.21 `elem` temps) `shouldBe` True
+ -- 全値が小数第 2 位以内 (x*100 が整数)
+ all (\x -> abs (x * 100 - fromIntegral (round (x * 100) :: Integer)) < 1e-9) temps
+ `shouldBe` True
+
+ it "run 数は designFrame と同じ (丸めのみ・行は増減しない)" $ do
+ let plan = centralCompositeDesign [contFactor "temp" (150, 180), contFactor "time" (10, 20)]
+ nrun df = maybe 0 V.length (getDoubleVec "run" df)
+ nrun (designFrameRound 3 plan) `shouldBe` nrun (designFrame plan)
diff --git a/test/Hanalyze/MCMC/BayesianTestSpec.hs b/test/Hanalyze/MCMC/BayesianTestSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/MCMC/BayesianTestSpec.hs
@@ -0,0 +1,74 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.MCMC.BayesianTestSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.MCMC.NUTS as NUTS
+import qualified Hanalyze.MCMC.BayesianTest as BAB
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.MCMC.BayesianTest (Phase 8)" $ do
+ -- HDI helper の単体テスト
+ it "highestDensityInterval: 単純な uniform で expected width" $ do
+ let xs = [fromIntegral i / 99 | i <- [0..99 :: Int]] -- 0, 1/99, ..., 1
+ (lo, hi) = BAB.highestDensityInterval 0.90 xs
+ -- 90% HDI は約 [0, 0.9]、 width ≈ 0.9
+ (hi - lo) `shouldSatisfy` (\w -> w >= 0.85 && w <= 0.95)
+
+ it "highestDensityInterval: 0 元素で (0, 0)" $
+ BAB.highestDensityInterval 0.95 [] `shouldBe` (0, 0)
+
+ -- classifyROPE の単体テスト (HDI 形状で)
+ it "ROPE 完全外: RejectH0" $ do
+ let cfg = BAB.defaultBayesianABConfig
+ { BAB.babCredible = 0.95
+ , BAB.babRule = BAB.ROPEDecision (-0.1) 0.1
+ , BAB.babNUTS = (BAB.babNUTS BAB.defaultBayesianABConfig)
+ { NUTS.nutsIterations = 300, NUTS.nutsBurnIn = 200 }
+ }
+ -- 明確に異なる 2 群
+ ysA = [10 + 0.1 * fromIntegral i | i <- [1..30 :: Int]]
+ ysB = [20 + 0.1 * fromIntegral i | i <- [1..30 :: Int]]
+ gen <- MWC.create
+ res <- BAB.bayesianAB cfg ysA ysB gen
+ BAB.babDecision res `shouldBe` BAB.RejectH0
+ BAB.babMeanDiff res `shouldSatisfy` (> 5) -- 強く正
+ BAB.babProbDiffPos res `shouldSatisfy` (> 0.95)
+
+ it "HDIOnly: NoRuleApplied" $ do
+ let cfg = BAB.defaultBayesianABConfig
+ { BAB.babNUTS = (BAB.babNUTS BAB.defaultBayesianABConfig)
+ { NUTS.nutsIterations = 200, NUTS.nutsBurnIn = 100 }
+ }
+ ysA = [1, 2, 3, 4, 5 :: Double]
+ ysB = [3, 4, 5, 6, 7 :: Double]
+ gen <- MWC.create
+ res <- BAB.bayesianAB cfg ysA ysB gen
+ BAB.babDecision res `shouldBe` BAB.NoRuleApplied
+ -- HDI は finite + lo ≤ hi
+ let (lo, hi) = BAB.babHDI res
+ lo `shouldSatisfy` (<= hi)
+ -- posterior サンプルが期待数
+ length (BAB.babPosteriorDiff res) `shouldBe` 200
diff --git a/test/Hanalyze/MCMC/NUTSSpec.hs b/test/Hanalyze/MCMC/NUTSSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/MCMC/NUTSSpec.hs
@@ -0,0 +1,162 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.MCMC.NUTSSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Map.Strict as M
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Core as Core
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.MCMC.NUTS as NUTS
+import qualified Hanalyze.MCMC.Core as Core
+import qualified Hanalyze.Model.HBM as HBM
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.MCMC.NUTS.nutsStream" $ do
+ let smallCfg = NUTS.defaultNUTSConfig
+ { NUTS.nutsIterations = 20
+ , NUTS.nutsBurnIn = 10
+ , NUTS.nutsAdaptStepSize = False
+ , NUTS.nutsAdaptMass = False
+ }
+ -- Trivial model: mu ~ Normal(0, 1), observe one data point.
+ model :: HBM.ModelP ()
+ model = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 1)
+ HBM.observe "y" (HBM.Normal mu 1) [0.5]
+
+ it "callback が iterations + burnIn 回呼ばれる" $ do
+ eventsRef <- newIORef []
+ gen <- MWC.create
+ _ <- NUTS.nutsStream model smallCfg (M.fromList [("mu", 0)]) gen $ \ev ->
+ modifyIORef' eventsRef (ev :)
+ events <- reverse <$> readIORef eventsRef
+ length events `shouldBe`
+ (NUTS.nutsBurnIn smallCfg + NUTS.nutsIterations smallCfg)
+
+ it "seIter は 0..total-1 で順番に並ぶ" $ do
+ eventsRef <- newIORef []
+ gen <- MWC.create
+ _ <- NUTS.nutsStream model smallCfg (M.fromList [("mu", 0)]) gen $ \ev ->
+ modifyIORef' eventsRef (ev :)
+ events <- reverse <$> readIORef eventsRef
+ map NUTS.seIter events
+ `shouldBe`
+ [0 .. NUTS.nutsBurnIn smallCfg + NUTS.nutsIterations smallCfg - 1]
+
+ it "seIsBurnIn は 先頭 burnIn 個だけ True" $ do
+ eventsRef <- newIORef []
+ gen <- MWC.create
+ _ <- NUTS.nutsStream model smallCfg (M.fromList [("mu", 0)]) gen $ \ev ->
+ modifyIORef' eventsRef (ev :)
+ events <- reverse <$> readIORef eventsRef
+ length (filter NUTS.seIsBurnIn events)
+ `shouldBe` NUTS.nutsBurnIn smallCfg
+
+ it "既存 nuts は nutsStream の wrapper として同一結果(同じ seed)" $ do
+ gen1 <- MWC.create
+ chain1 <- NUTS.nuts model smallCfg (M.fromList [("mu", 0)]) gen1
+ gen2 <- MWC.create
+ chain2 <- NUTS.nutsStream model smallCfg (M.fromList [("mu", 0)])
+ gen2 (\_ -> pure ())
+ -- 同じ seed (MWC.create は決定的) なので chain length 一致
+ length (Core.chainSamples chain1)
+ `shouldBe` length (Core.chainSamples chain2)
+
+ describe "Hanalyze.MCMC.NUTS 純粋版 (Phase 50.3 nutsPure / nutsChainsPure)" $ do
+ let cfg = NUTS.defaultNUTSConfig
+ { NUTS.nutsIterations = 30, NUTS.nutsBurnIn = 20
+ , NUTS.nutsAdaptStepSize = False, NUTS.nutsAdaptMass = False }
+ model :: HBM.ModelP ()
+ model = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ HBM.observe "y" (HBM.Normal mu 1) (replicate 8 5.0)
+ initC = M.fromList [("mu", 0)]
+
+ it "nutsPure: 同 seed なら chainSamples がビット同一 (再現性)" $ do
+ let c1 = NUTS.nutsPure model cfg initC 12345
+ c2 = NUTS.nutsPure model cfg initC 12345
+ Core.chainSamples c1 `shouldBe` Core.chainSamples c2
+
+ it "nutsPure: 別 seed なら chainSamples が異なる" $ do
+ let c1 = NUTS.nutsPure model cfg initC 1
+ c2 = NUTS.nutsPure model cfg initC 2
+ (Core.chainSamples c1 == Core.chainSamples c2) `shouldBe` False
+
+ it "nutsPure: IO nuts と同 seed でビット同一 (ST/IO 等価)" $ do
+ gen <- MWC.initialize (V.singleton 777)
+ ioChain <- NUTS.nuts model cfg initC gen
+ let pureChain = NUTS.nutsPure model cfg initC 777
+ Core.chainSamples pureChain `shouldBe` Core.chainSamples ioChain
+
+ it "nutsChainsPure: numChains 本・各 chain は iterations 長・再現性あり" $ do
+ let chains = NUTS.nutsChainsPure model cfg 3 initC 99
+ length chains `shouldBe` 3
+ map (length . Core.chainSamples) chains
+ `shouldBe` replicate 3 (NUTS.nutsIterations cfg)
+ -- 同 seed で全 chain がビット同一 (parList は決定性に影響しない)
+ map Core.chainSamples (NUTS.nutsChainsPure model cfg 3 initC 99)
+ `shouldBe` map Core.chainSamples chains
+
+ it "nutsChainsPure: 子 seed が分かれ chain 同士は異なる" $ do
+ let chains = NUTS.nutsChainsPure model cfg 2 initC 55
+ case chains of
+ [a, b] -> (Core.chainSamples a == Core.chainSamples b) `shouldBe` False
+ _ -> expectationFailure "expected 2 chains"
+
+ -- Phase 94 A4-2: init jitter。 既定 (nutsInitJitter=0) は従来と完全一致
+ -- (RNG stream を消費しない = 既存全テストの再現性を保つ)。 jitter>0 は
+ -- 初期位置を散らして結果が変わるが、 同 seed なら決定的に再現。
+ it "nutsInitJitter=0 は jitter 無指定 (従来) とビット同一" $ do
+ let c0 = NUTS.nutsPure model cfg initC 2024
+ cJ0 = NUTS.nutsPure model cfg { NUTS.nutsInitJitter = 0 } initC 2024
+ Core.chainSamples cJ0 `shouldBe` Core.chainSamples c0
+
+ it "nutsInitJitter>0 は結果を変える (init を散らす) が同 seed で再現" $ do
+ let c0 = NUTS.nutsPure model cfg initC 2024
+ cJ = NUTS.nutsPure model cfg { NUTS.nutsInitJitter = 1.0 } initC 2024
+ cJ' = NUTS.nutsPure model cfg { NUTS.nutsInitJitter = 1.0 } initC 2024
+ (Core.chainSamples cJ == Core.chainSamples c0) `shouldBe` False
+ Core.chainSamples cJ `shouldBe` Core.chainSamples cJ'
+
+ -- Phase 61.1: IO 経路 (nutsChainsStream) は chainSeeds 共有 + ST/IO 等価
+ -- (Phase 50 実証) により pure 経路とビット一致するのが設計の柱。
+ it "nutsChainsStream: no-op callback で nutsChainsPure とビット一致" $ do
+ ioChains <- NUTS.nutsChainsStream model cfg 3 initC 99 (\_ _ -> pure ())
+ let pureChains = NUTS.nutsChainsPure model cfg 3 initC 99
+ map Core.chainSamples ioChains
+ `shouldBe` map Core.chainSamples pureChains
+
+ it "nutsChainsStream: callback が chain ごとに total 回 (burnIn 込み) 呼ばれる" $ do
+ countsRef <- newIORef (M.empty :: M.Map Int Int)
+ _ <- NUTS.nutsChainsStream model cfg 2 initC 7
+ (\i _ -> modifyIORef' countsRef (M.insertWith (+) i 1))
+ counts <- readIORef countsRef
+ let total = NUTS.nutsBurnIn cfg + NUTS.nutsIterations cfg
+ counts `shouldBe` M.fromList [(0, total), (1, total)]
+
+ -- Phase 53: gradADU の正しさを中心差分 (ground truth) で検証。
+ -- ★前進/逆 AD どちらでも勾配は数学的に同一ゆえ、 reverse 化の前後で
+ -- 同じテストが通る = 切替が正しさを保存することの担保。
diff --git a/test/Hanalyze/MCMC/ProgressSpec.hs b/test/Hanalyze/MCMC/ProgressSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/MCMC/ProgressSpec.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Hanalyze.MCMC.Progress の純粋部 (formatProgress) のテスト (Phase 61.2)。
+module Hanalyze.MCMC.ProgressSpec (spec) where
+
+import Test.Hspec
+import Hanalyze.MCMC.Progress
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.MCMC.Progress.formatProgress" $ do
+ it "warmup 中: 計画 md の例どおりの 1 行" $
+ formatProgress (ProgressSnapshot 4 2 3400 8000 True 12 380.0)
+ `shouldBe` "chains 2/4 done | draw 3400/8000 (warmup) | div 12 | 380.0 it/s"
+
+ it "warmup 後: (warmup) タグが消える" $
+ formatProgress (ProgressSnapshot 4 4 8000 8000 False 0 95.25)
+ `shouldBe` "chains 4/4 done | draw 8000/8000 | div 0 | 95.2 it/s"
diff --git a/test/Hanalyze/MCMC/SMCSpec.hs b/test/Hanalyze/MCMC/SMCSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/MCMC/SMCSpec.hs
@@ -0,0 +1,71 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.MCMC.SMCSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Map.Strict as M
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Core as Core
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.MCMC.SMC as SMC
+import qualified Hanalyze.MCMC.Core as Core
+import qualified Hanalyze.Model.HBM as HBM
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.MCMC.SMC (Phase 29-A1 tempered Sequential Monte Carlo)" $ do
+ -- Simple Gaussian model: μ ~ N(0, 10)、 y ~ N(μ, 1)、 obs y = 5.0 (n=10)
+ -- Analytic posterior: μ | y ~ N(μ_post, σ_post²)、
+ -- σ_post² = 1 / (1/100 + 10/1) = 1/10.01 ≈ 0.0999
+ -- μ_post = σ_post² · (0/100 + 10·5/1) = 0.0999·50 ≈ 4.995
+ -- 解析解との比較 (5% tolerance)
+ let modelSMC :: HBM.ModelP ()
+ modelSMC = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ HBM.observe "y" (HBM.Normal mu 1) (replicate 10 5.0)
+ cfg = (SMC.defaultSMCConfig ["mu"])
+ { SMC.smcNParticles = 500
+ , SMC.smcNSteps = 15
+ , SMC.smcMHIterations = 8
+ , SMC.smcMHStepSize = M.fromList [("mu", 0.5)]
+ , SMC.smcInitJitter = 5.0
+ }
+ it "SMC: 粒子数 = N、 log marginal が finite" $ do
+ gen <- MWC.create
+ res <- SMC.smc modelSMC cfg (M.fromList [("mu", 0)]) gen
+ length (Core.chainSamples (SMC.smcChain res)) `shouldBe` 500
+ SMC.smcLogMarginal res `shouldSatisfy` (not . isInfinite)
+ SMC.smcLogMarginal res `shouldSatisfy` (not . isNaN)
+ it "SMC: posterior mean が解析解 (4.995) と 5% 以内一致" $ do
+ gen <- MWC.create
+ res <- SMC.smc modelSMC cfg (M.fromList [("mu", 0)]) gen
+ case Core.posteriorMean "mu" (SMC.smcChain res) of
+ Just mu -> abs (mu - 4.995) `shouldSatisfy` (< 0.25) -- 5% of 5
+ Nothing -> expectationFailure "posterior mean not available"
+ it "SMC: posterior SD が解析解 (0.316) と妥当範囲内" $ do
+ gen <- MWC.create
+ res <- SMC.smc modelSMC cfg (M.fromList [("mu", 0)]) gen
+ case Core.posteriorSD "mu" (SMC.smcChain res) of
+ -- 真値 sqrt(0.0999) ≈ 0.316、 SMC の N=500 サンプリング誤差で 50% tol
+ Just sd -> sd `shouldSatisfy` (\s -> s > 0.15 && s < 0.6)
+ Nothing -> expectationFailure "posterior SD not available"
diff --git a/test/Hanalyze/MCMC/SamplersPureSpec.hs b/test/Hanalyze/MCMC/SamplersPureSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/MCMC/SamplersPureSpec.hs
@@ -0,0 +1,95 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.MCMC.SamplersPureSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Map.Strict as M
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Core as Core
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.MCMC.SMC as SMC
+import qualified Hanalyze.MCMC.MH as MH
+import qualified Hanalyze.MCMC.Slice as Slice
+import qualified Hanalyze.MCMC.HMC as HMC
+import qualified Hanalyze.MCMC.Gibbs as Gibbs
+import qualified Hanalyze.MCMC.Core as Core
+import qualified Hanalyze.Model.HBM as HBM
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "他サンプラ純粋版 (Phase 50.6-50.10: MH/Slice/HMC/Gibbs/SMC)" $ do
+ let model :: HBM.ModelP ()
+ model = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ HBM.observe "y" (HBM.Normal mu 1) (replicate 8 5.0)
+ initC = M.fromList [("mu", 0)]
+ samp = Core.chainSamples
+
+ it "metropolisPure: 同 seed ビット同一 / IO 版と ST 等価" $ do
+ let c = MH.defaultMCMCConfig ["mu"]
+ cfg = c { MH.mcmcIterations = 40, MH.mcmcBurnIn = 20 }
+ samp (MH.metropolisPure model cfg initC 11)
+ `shouldBe` samp (MH.metropolisPure model cfg initC 11)
+ gen <- MWC.initialize (V.singleton 11)
+ ioC <- MH.metropolis model cfg initC gen
+ samp (MH.metropolisPure model cfg initC 11) `shouldBe` samp ioC
+
+ it "metropolisChainsPure: 3 本・再現性・子 seed で相異" $ do
+ let cfg = (MH.defaultMCMCConfig ["mu"]) { MH.mcmcIterations = 30, MH.mcmcBurnIn = 10 }
+ chains = MH.metropolisChainsPure model cfg 3 initC 7
+ length chains `shouldBe` 3
+ map samp (MH.metropolisChainsPure model cfg 3 initC 7) `shouldBe` map samp chains
+
+ it "slicePure: 同 seed ビット同一 / IO 版と ST 等価" $ do
+ let cfg = (Slice.defaultSliceConfig ["mu"])
+ { Slice.sliceIterations = 30, Slice.sliceBurnIn = 10 }
+ samp (Slice.slicePure model cfg initC 22)
+ `shouldBe` samp (Slice.slicePure model cfg initC 22)
+ gen <- MWC.initialize (V.singleton 22)
+ ioC <- Slice.slice model cfg initC gen
+ samp (Slice.slicePure model cfg initC 22) `shouldBe` samp ioC
+
+ it "hmcPure: 同 seed ビット同一 / IO 版と ST 等価" $ do
+ let cfg = HMC.defaultHMCConfig { HMC.hmcIterations = 30, HMC.hmcBurnIn = 10 }
+ samp (HMC.hmcPure model cfg initC 33)
+ `shouldBe` samp (HMC.hmcPure model cfg initC 33)
+ gen <- MWC.initialize (V.singleton 33)
+ ioC <- HMC.hmc model cfg initC gen
+ samp (HMC.hmcPure model cfg initC 33) `shouldBe` samp ioC
+
+ it "gibbsBetaBinomialPure: 同 seed ビット同一 / IO 版と ST 等価" $ do
+ let cfg = Gibbs.defaultGibbsConfig { Gibbs.gibbsIterations = 50, Gibbs.gibbsBurnIn = 10 }
+ samp (Gibbs.gibbsBetaBinomialPure "p" 2 2 10 7 cfg 44)
+ `shouldBe` samp (Gibbs.gibbsBetaBinomialPure "p" 2 2 10 7 cfg 44)
+ gen <- MWC.initialize (V.singleton 44)
+ ioC <- Gibbs.gibbsBetaBinomial "p" 2 2 10 7 cfg gen
+ samp (Gibbs.gibbsBetaBinomialPure "p" 2 2 10 7 cfg 44) `shouldBe` samp ioC
+
+ it "smcPure: 同 seed で SMCResult (chain) ビット同一" $ do
+ let cfg = (SMC.defaultSMCConfig ["mu"])
+ { SMC.smcNParticles = 100, SMC.smcNSteps = 5, SMC.smcMHIterations = 3 }
+ r1 = SMC.smcPure model cfg initC 9
+ r2 = SMC.smcPure model cfg initC 9
+ samp (SMC.smcChain r1) `shouldBe` samp (SMC.smcChain r2)
+ SMC.smcLogMarginal r1 `shouldBe` SMC.smcLogMarginal r2
diff --git a/test/Hanalyze/Math/HSICSpec.hs b/test/Hanalyze/Math/HSICSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Math/HSICSpec.hs
@@ -0,0 +1,43 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Math.HSICSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.QuasiRandom as QR
+import qualified Hanalyze.Math.HSIC as HSIC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Math.HSIC" $ do
+ it "完全従属 (X = Y) で独立データより HSIC が大きい" $ do
+ let halton b k = QR.radicalInverse b k - 0.5
+ xs = LA.asColumn (LA.fromList [halton 2 i | i <- [1..200]])
+ ys = LA.asColumn (LA.fromList [halton 7 i | i <- [1..200]])
+ dep = HSIC.hsicBiased xs xs -- 同データ = 完全従属
+ ind = HSIC.hsicBiased xs ys -- 異独立データ
+ dep `shouldSatisfy` (> ind)
+ ind `shouldSatisfy` (< 0.05)
+
+ it "medianBandwidth は正値" $ do
+ let xs = LA.asColumn (LA.fromList [QR.radicalInverse 2 i | i <- [1..50]])
+ HSIC.medianBandwidth xs `shouldSatisfy` (> 0)
diff --git a/test/Hanalyze/Math/HungarianSpec.hs b/test/Hanalyze/Math/HungarianSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Math/HungarianSpec.hs
@@ -0,0 +1,58 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Math.HungarianSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Unboxed as VU
+import qualified Hanalyze.Math.Hungarian as Hung
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Math.Hungarian" $ do
+ it "4×4 既知最適: 対角コスト最小割当を当てる" $ do
+ -- C[i,j] = 0 (i == j)、 それ以外は 1。 最適は assignment[i] = i、 cost 0。
+ let c = LA.build (4, 4) (\i j ->
+ if (round i :: Int) == (round j :: Int) then 0.0 else 1.0)
+ a = Hung.hungarianMin c
+ total = sum [ LA.atIndex c (i, a VU.! i) | i <- [0 .. 3] ]
+ VU.toList a `shouldBe` [0, 1, 2, 3]
+ total `shouldBe` 0.0
+
+ it "順列が必要な行列でも全単射な最適解を返す" $ do
+ -- 既知最適: assignment = [3, 2, 1, 0]、 cost 4。
+ let rows = [ [9, 9, 9, 1]
+ , [9, 9, 1, 9]
+ , [9, 1, 9, 9]
+ , [1, 9, 9, 9]
+ ]
+ c = LA.fromLists rows :: LA.Matrix Double
+ a = Hung.hungarianMin c
+ total = sum [ LA.atIndex c (i, a VU.! i) | i <- [0 .. 3] ]
+ VU.toList a `shouldBe` [3, 2, 1, 0]
+ total `shouldBe` 4.0
+ -- 全単射 (重複なし)
+ length (VU.toList a) `shouldBe` length (nub (VU.toList a))
+
+ it "1×1 と空行列の境界" $ do
+ VU.toList (Hung.hungarianMin (LA.fromLists [[42.0]])) `shouldBe` [0]
+ VU.toList (Hung.hungarianMin ((0 LA.>< 0) [])) `shouldBe` []
diff --git a/test/Hanalyze/Model/AFTSpec.hs b/test/Hanalyze/Model/AFTSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/AFTSpec.hs
@@ -0,0 +1,64 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.AFTSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.AFT as AFT
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.AFT (Phase 12)" $ do
+ let ts = LA.fromList [exp 1.5, exp 1.8, exp 2.0, exp 2.1, exp 2.3,
+ exp 1.9, exp 2.05, exp 2.15, exp 1.95, exp 2.2]
+ delta = V.replicate 10 True
+ x1 = LA.fromColumns [LA.fromList (replicate 10 1.0)]
+ it "fitAFT LogNormal intercept-only: β₀ ≈ mean(log t)" $ do
+ r <- AFT.fitAFT AFT.AFTLogNormal x1 ts delta
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right fit -> do
+ let b0 = LA.atIndex (AFT.aftBeta fit) 0
+ meanLogT = LA.sumElements (LA.cmap log ts) / fromIntegral (LA.size ts)
+ abs (b0 - meanLogT) `shouldSatisfy` (< 0.05)
+ it "fitAFT Weibull: 打ち切り混在で動く" $ do
+ let delta2 = V.fromList [True, True, False, True, True,
+ True, False, True, True, True]
+ r <- AFT.fitAFT AFT.AFTWeibull x1 ts delta2
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right fit -> AFT.aftScale fit `shouldSatisfy` (> 0)
+ it "fitAFT 入力長 mismatch は Left" $ do
+ r <- AFT.fitAFT AFT.AFTLogNormal x1 (LA.fromList [1, 2]) delta
+ case r of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+ it "predictAFT Exponential: E[T] = exp(X β)" $ do
+ r <- AFT.fitAFT AFT.AFTExponential x1 ts delta
+ case r of
+ Left e -> expectationFailure (T.unpack e)
+ Right fit -> do
+ let preds = AFT.predictAFT fit x1
+ b0 = LA.atIndex (AFT.aftBeta fit) 0
+ abs (LA.atIndex preds 0 - exp b0) `shouldSatisfy` (< 1e-6)
diff --git a/test/Hanalyze/Model/ClusterSpec.hs b/test/Hanalyze/Model/ClusterSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/ClusterSpec.hs
@@ -0,0 +1,69 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.ClusterSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.Cluster as Cl
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Cluster" $ do
+ it "kMeans: 2 つの離れたクラスタで正しく分類" $ do
+ gen <- MWC.createSystemRandom
+ -- Cluster 1: around (0, 0); cluster 2: around (10, 10)
+ let xs = LA.fromLists $
+ [[0.1*x, 0.1*y] | x <- [-3..3], y <- [-3..3]] ++
+ [[10 + 0.1*x, 10 + 0.1*y] | x <- [-3..3], y <- [-3..3]]
+ cfg = Cl.defaultKMeans 2
+ r <- Cl.kMeans cfg xs gen
+ LA.rows (Cl.kmrCentroids r) `shouldBe` 2
+ -- 全 49 points がクラスタ 1、49 が クラスタ 2
+ let labels = Cl.kmrLabels r
+ (c0, c1) = (length (filter (== 0) labels), length (filter (== 1) labels))
+ (min c0 c1) `shouldBe` 49
+ (max c0 c1) `shouldBe` 49
+
+ it "silhouette: well-separated clusters で > 0.5" $ do
+ gen <- MWC.createSystemRandom
+ let xs = LA.fromLists $
+ [[0.1*x, 0.1*y] | x <- [-3..3], y <- [-3..3]] ++
+ [[20 + 0.1*x, 20 + 0.1*y] | x <- [-3..3], y <- [-3..3]]
+ cfg = Cl.defaultKMeans 2
+ r <- Cl.kMeans cfg xs gen
+ let s = Cl.silhouette xs (Cl.kmrLabels r)
+ s `shouldSatisfy` (> 0.7)
+
+ it "kMeans: inertia は monotone non-increasing in iter" $ do
+ gen <- MWC.createSystemRandom
+ let xs = LA.fromLists [[fromIntegral i, fromIntegral j]
+ | i <- [0..9::Int], j <- [0..9::Int]]
+ cfg = (Cl.defaultKMeans 4) { Cl.kmRestarts = 5 }
+ r <- Cl.kMeans cfg xs gen
+ Cl.kmrInertia r `shouldSatisfy` (>= 0)
+ Cl.kmrConverged r `shouldBe` True
+
+ -- ===========================================================================
+ -- Hanalyze.Stat.MultipleTesting (Phase 6)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Model/CompetingRisksSpec.hs b/test/Hanalyze/Model/CompetingRisksSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/CompetingRisksSpec.hs
@@ -0,0 +1,64 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.CompetingRisksSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.CompetingRisks as CR
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.CompetingRisks (Phase 35-A3)" $ do
+ -- 簡単な手計算例: 5 サンプル、 2 causes、 censoring 含む
+ -- t=1 (cause 1), t=2 (cause 2), t=3 (cause 1), t=4 (censored), t=5 (cause 2)
+ let samples = [ CR.CRSample 1.0 1, CR.CRSample 2.0 2, CR.CRSample 3.0 1
+ , CR.CRSample 4.0 0, CR.CRSample 5.0 2 ]
+ fit = CR.fitCompetingRisks samples
+ it "fitCompetingRisks: 検出された causes" $ do
+ CR.crfCauses fit `shouldBe` [1, 2]
+ it "fitCompetingRisks: event times (censored 除外)" $ do
+ LA.toList (CR.crfTimes fit) `shouldBe` [1.0, 2.0, 3.0, 5.0]
+ it "fitCompetingRisks: 全 CIF の和 + 全生存 ≈ 1 (各 event time で)" $ do
+ let s = LA.toList (CR.crfOverallSurvival fit)
+ cifs = [ LA.toList v | (_, v) <- CR.crfCIF fit ]
+ n = length s
+ totAt i = sum [ cif !! i | cif <- cifs ] + (s !! i)
+ and [ abs (totAt i - 1.0) < 1e-9 | i <- [0 .. n - 1] ]
+ `shouldBe` True
+ it "fitCompetingRisks: CIF は単調非減少" $ do
+ let nonDec xs = and (zipWith (<=) xs (tail xs))
+ and [ nonDec (LA.toList v) | (_, v) <- CR.crfCIF fit ]
+ `shouldBe` True
+ it "fitCompetingRisks: t=1 で F̂_1 = 1/5 (cause 1、 n=5, d=1)" $ do
+ let Just cif1 = lookup 1 (CR.crfCIF fit)
+ abs (LA.atIndex cif1 0 - 0.2) `shouldSatisfy` (< 1e-9)
+ it "fitCompetingRisks: cause 2 だけのケースは KM 1-S と一致" $ do
+ -- 単一 cause なら CIF = 1 - S (overall) と一致するはず
+ let s2 = [ CR.CRSample 1.0 1, CR.CRSample 2.0 1, CR.CRSample 3.0 0
+ , CR.CRSample 4.0 1 ]
+ fit2 = CR.fitCompetingRisks s2
+ Just cif = lookup 1 (CR.crfCIF fit2)
+ sv = CR.crfOverallSurvival fit2
+ oneMinusS = [ 1 - x | x <- LA.toList sv ]
+ and [ abs (a - b) < 1e-9
+ | (a, b) <- zip (LA.toList cif) oneMinusS ]
+ `shouldBe` True
diff --git a/test/Hanalyze/Model/DAGSpec.hs b/test/Hanalyze/Model/DAGSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/DAGSpec.hs
@@ -0,0 +1,51 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.DAGSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.DAG as DAG
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.DAG (Phase 36-LiNGAM 共通基盤)" $ do
+ it "fromBMatrix + topoSort: 3 ノード DAG の順序" $ do
+ let b = LA.fromLists [[0, 0, 0]
+ ,[0.8, 0, 0]
+ ,[0.4, 0.6, 0]]
+ g = DAG.fromBMatrix 0.05 b
+ DAG.topoSort g `shouldBe` Just [0, 1, 2]
+ it "isAcyclic: DAG は True、 cycle 入りなら False" $ do
+ let acyc = DAG.fromBMatrix 0.05
+ (LA.fromLists [[0,0,0]
+ ,[0.5,0,0]
+ ,[0,0.5,0]])
+ cyc = DAG.fromBMatrix 0.05
+ (LA.fromLists [[0,0.5,0]
+ ,[0,0,0.5]
+ ,[0.5,0,0]])
+ DAG.isAcyclic acyc `shouldBe` True
+ DAG.isAcyclic cyc `shouldBe` False
+ it "dagEdges: エッジ数が非零要素数と一致" $ do
+ let b = LA.fromLists [[0,0,0],[0.5,0,0],[0.3,0.4,0]]
+ g = DAG.fromBMatrix 0.05 b
+ length (DAG.dagEdges g) `shouldBe` 3
diff --git a/test/Hanalyze/Model/DecisionTreeSpec.hs b/test/Hanalyze/Model/DecisionTreeSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/DecisionTreeSpec.hs
@@ -0,0 +1,113 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.DecisionTreeSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Model.DecisionTree as DT
+import qualified Data.Text as T
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.DecisionTree" $ do
+ it "fitDT: 線形分離可能なデータで perfect train accuracy" $ do
+ -- y = 0 if x[0] < 5, else 1
+ let xs = [[fromIntegral x] | x <- [1..10::Int]]
+ ys = [if x < 5 then 0 else 1 | x <- [1..10::Int]]
+ tree = DT.fitDT DT.defaultDecisionTree xs ys
+ preds = map (DT.predictDT tree) xs
+ preds `shouldBe` ys
+
+ it "fitDT: 2D XOR-like パターン" $ do
+ let xs = [[0, 0], [0, 1], [1, 0], [1, 1]]
+ ys = [0, 1, 1, 0] -- XOR
+ tree = DT.fitDT DT.defaultDecisionTree xs ys
+ preds = map (DT.predictDT tree) xs
+ preds `shouldBe` ys
+
+ it "predictDT: 混在葉は多数派 (argmax) を予測する (argmin 回帰バグ防止)" $ do
+ -- depth=0 に制限し root 自身を混在葉にする。 x に依らずクラス 1 が多数 (7:3)。
+ -- 旧バグ (argmin) だと少数派クラス 0 を返していた。
+ let cfg = DT.defaultDecisionTree { DT.dtMaxDepth = Just 0 }
+ xs = [[fromIntegral i] | i <- [1..10::Int]]
+ ys = [0,0,0, 1,1,1,1,1,1,1] -- class 1 が 7、 class 0 が 3。
+ tree = DT.fitDT cfg xs ys
+ map (DT.predictDT tree) xs `shouldBe` replicate 10 1
+ let xs = [[1.0], [2.0], [3.0]]
+ ys = [0, 0, 1]
+ tree = DT.fitDT DT.defaultDecisionTree xs ys
+ probs = DT.predictDTProbs tree [1.5]
+ -- x=1.5 should reach a leaf where most samples are class 0
+ probs `shouldSatisfy` (\m -> length m >= 1)
+
+ it "giniImpurity: 純粋クラスで 0、均等で 0.5 (2 クラス)" $ do
+ DT.giniImpurity [0, 0, 0, 0] `shouldBe` 0.0
+ DT.giniImpurity [1, 1, 1, 1] `shouldBe` 0.0
+ DT.giniImpurity [0, 0, 1, 1] `shouldBe` 0.5
+
+ it "maxDepth=1: shallow tree、underfit に近い" $ do
+ let cfg = DT.defaultDecisionTree { DT.dtMaxDepth = Just 1 }
+ xs = [[fromIntegral x, fromIntegral y]
+ | x <- [1..5::Int], y <- [1..5::Int]]
+ ys = [if x + y > 5 then 1 else 0
+ | x <- [1..5::Int], y <- [1..5::Int]]
+ tree = DT.fitDT cfg xs ys
+ -- maxDepth=1 → 1 split, root = decision node
+ case tree of
+ DT.DNode {} -> True `shouldBe` True
+ _ -> expectationFailure "Expected DNode at root"
+
+ it "printRpart: R print.rpart 形式 (node#/split/n/loss/yval/yprob/*)" $ do
+ -- 3 クラス・特徴 1 (petal_width 風) で完全分離する木。
+ let xs = [[1.4,0.2],[1.3,0.2],[1.5,0.2],[1.4,0.3]
+ ,[4.5,1.5],[4.7,1.4],[4.9,1.5],[4.0,1.3]
+ ,[6.0,2.5],[5.8,2.2],[6.3,1.8],[5.5,2.1]]
+ ys = [0,0,0,0, 1,1,1,1, 2,2,2,2]
+ tree = DT.fitDT DT.defaultDecisionTree xs ys
+ out = DT.printRpartRaw ["petal_length","petal_width"]
+ ["setosa","versicolor","virginica"] tree
+ ls = lines (T.unpack out)
+ -- ヘッダ (n= / legend / * denotes)。
+ ls `shouldContain` ["n= 12"]
+ ls `shouldContain` ["node), split, n, loss, yval, (yprob)"]
+ -- root は node# 1・split=root・n=12・loss=8・yval=setosa (全クラス同数の tie)。
+ ls `shouldContain` ["1) root 12 8 setosa (0.3333 0.3333 0.3333)"]
+ -- 左枝 (≤・条件成立) = "name< thr"・終端 * 付き・純粋クラス確率。
+ ls `shouldContain`
+ [" 2) petal_width< 0.80 4 0 setosa (1.0000 0.0000 0.0000) *"]
+ -- 右枝 = "name>=thr"・内部ノード (* 無し)。
+ ls `shouldContain` [" 3) petal_width>=0.80 8 4 versicolor (0.0000 0.5000 0.5000)"]
+ -- node# は R 慣例 root=1・子 2k/2k+1 → node 3 の子は 6/7。
+ ls `shouldContain` [" 6) petal_width< 1.65 4 0 versicolor (0.0000 1.0000 0.0000) *"]
+ ls `shouldContain` [" 7) petal_width>=1.65 4 0 virginica (0.0000 0.0000 1.0000) *"]
+
+ it "printRpart: 列名・クラス名なしは f{i}/整数へフォールバック" $ do
+ let xs = [[1.4,0.2],[1.3,0.2],[4.5,1.5],[4.7,1.4]]
+ ys = [0,0,1,1]
+ tree = DT.fitDT DT.defaultDecisionTree xs ys
+ out = DT.printRpartRaw [] [] tree
+ -- 特徴 index 1 → f1、 クラス → 整数のまま。
+ out `shouldSatisfy` \t -> "f" `T.isInfixOf` t
+ && "root 4 2 0" `T.isInfixOf` t
+
+ -- ===========================================================================
+ -- Hanalyze.Model.TimeSeries (Phase 11)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Model/DiscriminantSpec.hs b/test/Hanalyze/Model/DiscriminantSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/DiscriminantSpec.hs
@@ -0,0 +1,90 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.DiscriminantSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Discriminant as LDA
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Discriminant (Phase 10 LDA/QDA)" $ do
+ -- 2 クラス × 2 特徴量、 明確に分離
+ let classData :: IO (LA.Matrix Double, V.Vector Int)
+ classData = do
+ gen <- MWC.create
+ xs0 <- sequence
+ [ sequence [MWC.uniformR (0, 1) gen, MWC.uniformR (0, 1) gen]
+ | _ <- [1..20 :: Int] ]
+ xs1 <- sequence
+ [ sequence [MWC.uniformR (3, 4) gen, MWC.uniformR (3, 4) gen]
+ | _ <- [1..20 :: Int] ]
+ pure ( LA.fromLists (xs0 ++ xs1)
+ , V.fromList (replicate 20 0 ++ replicate 20 1)
+ )
+
+ it "fitLDA: 2 クラスで fit、 shape 整合" $ do
+ (xs, ys) <- classData
+ case LDA.fitLDA xs ys of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ LA.rows (LDA.dfMeans f) `shouldBe` 2
+ LA.cols (LDA.dfMeans f) `shouldBe` 2
+ LDA.dfMethod f `shouldBe` LDA.LDA
+ LA.size (LDA.dfPriors f) `shouldBe` 2
+
+ it "fitLDA + predict: 訓練データで自己判別精度 = 100%" $ do
+ (xs, ys) <- classData
+ case LDA.fitLDA xs ys of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ let (preds, _) = LDA.predictDiscriminant f xs
+ matches = V.length (V.filter id (V.zipWith (==) preds ys))
+ matches `shouldBe` V.length ys
+
+ it "fitQDA: 2 クラスで fit、 dfCovariances 長さ = K" $ do
+ (xs, ys) <- classData
+ case LDA.fitQDA xs ys of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ LDA.dfMethod f `shouldBe` LDA.QDA
+ length (LDA.dfCovariances f) `shouldBe` 2
+
+ it "predictDiscriminant: posterior は行ごとに sum = 1" $ do
+ (xs, ys) <- classData
+ case LDA.fitLDA xs ys of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ let (_, posts) = LDA.predictDiscriminant f xs
+ rowSums = [LA.sumElements (posts LA.! i) | i <- [0 .. LA.rows posts - 1]]
+ all (\s -> abs (s - 1) < 1e-9) rowSums `shouldBe` True
+
+ it "fitLDA: 単一クラスは Left" $ do
+ let xs = LA.fromLists [[1,1],[2,2],[3,3]]
+ ys = V.fromList [0, 0, 0 :: Int]
+ case LDA.fitLDA xs ys of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for single class"
diff --git a/test/Hanalyze/Model/FDASpec.hs b/test/Hanalyze/Model/FDASpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/FDASpec.hs
@@ -0,0 +1,137 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.FDASpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Storable as VS
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.FDA as FDA
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.FDA (Phase 33 Functional Data Analysis)" $ do
+ -- 共通: t grid [0, 1] を 50 点、 内部 knots 8 点で B-spline degree=3
+ let nGrid = 50
+ tList = [fromIntegral i / fromIntegral (nGrid - 1)
+ | i <- [0 .. nGrid - 1]]
+ tGrid = LA.fromList tList
+ -- bsplineBasis は境界も含むノット列を期待 (Spline.hs §bsplineBasis 注釈)
+ intKnots = [fromIntegral i / 11 | i <- [0 .. 11]]
+ basis = FDA.BSpline 3 intKnots
+ it "smoothBasis: noisy sinusoid を 12% RMSE 以内で復元 (Phase 33-A1)" $ do
+ gen <- MWC.create
+ let trueFn t = sin (2 * pi * t)
+ nSamp = 5
+ -- 同じ true 関数 + 異なる noise の 5 sample
+ noisyRows <- mapM (\_ -> do
+ ns <- VS.replicateM nGrid (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.1 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ pure (zipWith (\t e -> trueFn t + e) tList (VS.toList ns)))
+ [1 .. nSamp]
+ let yMat = LA.fromLists noisyRows
+ fits = FDA.smoothBasis basis 1e-3 tGrid yMat
+ length fits `shouldBe` nSamp
+ -- 復元値と真値の RMSE
+ let evals = [LA.toList (FDA.evalFunctional fit tGrid) | fit <- fits]
+ trueVals = map trueFn tList
+ rmse vs = sqrt (sum [(v - tv)^(2::Int) | (v, tv) <- zip vs trueVals]
+ / fromIntegral nGrid)
+ all (\v -> rmse v < 0.12) evals `shouldBe` True
+ it "smoothBasis: 大 λ で over-smooth (= 直線近似)、 小 λ で interpolate" $ do
+ -- データ自体に二次的な変動が必要、 小 λ では当てはまる、 大 λ では潰す
+ let trueFn t = sin (4 * pi * t)
+ yRow = map trueFn tList
+ yMat = LA.fromLists [yRow]
+ fitSmall = head (FDA.smoothBasis basis 1e-6 tGrid yMat)
+ fitBig = head (FDA.smoothBasis basis 1e8 tGrid yMat)
+ residSmall = sum [(v - r)^(2::Int)
+ | (v, r) <- zip (LA.toList (FDA.evalFunctional fitSmall tGrid)) yRow]
+ residBig = sum [(v - r)^(2::Int)
+ | (v, r) <- zip (LA.toList (FDA.evalFunctional fitBig tGrid)) yRow]
+ -- 小 λ の方が残差小、 大 λ は明確に大きい
+ residSmall `shouldSatisfy` (< residBig / 10)
+ it "functionalPCA: 2 成分で分散 90% 以上 + 主成分関数の符号一致 (Phase 33-A2)" $ do
+ gen <- MWC.create
+ let nSamp = 80
+ -- DGP: x_i(t) = c1_i · sin(2πt) + c2_i · cos(2πt) + small noise
+ -- c1, c2 ~ N(0, 1) 独立
+ curves <- mapM (\_ -> do
+ u1a <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2a <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ u1b <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2b <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ let c1 = sqrt (-2 * log u1a) * cos (2 * pi * u2a)
+ c2 = sqrt (-2 * log u1b) * cos (2 * pi * u2b)
+ ns <- VS.replicateM nGrid (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.05 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ pure [ c1 * sin (2 * pi * t) + c2 * cos (2 * pi * t) + e
+ | (t, e) <- zip tList (VS.toList ns) ])
+ [1 .. nSamp]
+ let yMat = LA.fromLists curves
+ fits = FDA.smoothBasis basis 1e-4 tGrid yMat
+ pca = FDA.functionalPCA 5 fits
+ vals = LA.toList (FDA.fpcaEigenvalues pca)
+ length vals `shouldSatisfy` (>= 2)
+ -- 上位 2 成分が分散 90% 以上を説明
+ let top2 = sum (take 2 vals)
+ total = sum vals
+ (top2 / total) `shouldSatisfy` (> 0.9)
+ -- 主成分関数を grid 上で取り、 sin / cos との相関を見る
+ LA.rows (FDA.fpcaEigenfn pca) `shouldSatisfy` (>= 2)
+ it "fLM: 既知 β(t) = sin(2πt) を回復 (R² > 0.85、 Phase 33-A3)" $ do
+ gen <- MWC.create
+ let nSamp = 60
+ alphaTrue = 0.5
+ betaFn t = sin (2 * pi * t)
+ dt = head tList - head (tail tList) -- not used; trapezoidal は内部
+ -- x_i(t) = s1·sin(2πt) + s2·cos(2πt) (β と s1 が orthogonal でない設計)
+ -- → ∫x_i β dt = s1·∫sin²(2πt) dt + 0 = 0.5·s1
+ curves <- mapM (\_ -> do
+ u1a <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2a <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ u1b <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2b <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ let s1 = sqrt (-2 * log u1a) * cos (2 * pi * u2a)
+ s2 = sqrt (-2 * log u1b) * cos (2 * pi * u2b)
+ pure [s1 * sin (2 * pi * t) + s2 * cos (2 * pi * t) | t <- tList])
+ [1 .. nSamp]
+ ns <- VS.replicateM nSamp (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.05 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let dtVal = 1.0 / fromIntegral (nGrid - 1)
+ intXBeta xs = dtVal *
+ sum [ x * betaFn t | (x, t) <- zip xs tList ] -- 簡易 trap
+ ys = LA.fromList [alphaTrue + intXBeta x + e
+ | (x, e) <- zip curves (VS.toList ns)]
+ yMat = LA.fromLists curves
+ fits = FDA.smoothBasis basis 1e-4 tGrid yMat
+ flm = FDA.fLM fits ys 1e-3
+ FDA.flmR2 flm `shouldSatisfy` (> 0.85)
+ abs (FDA.flmAlpha flm - alphaTrue) `shouldSatisfy` (< 0.2)
+ LA.size (FDA.flmBetaFn flm) `shouldBe` nGrid
diff --git a/test/Hanalyze/Model/FitYByXSpec.hs b/test/Hanalyze/Model/FitYByXSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/FitYByXSpec.hs
@@ -0,0 +1,70 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.FitYByXSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.Test as ST
+import qualified Hanalyze.Model.FitYByX as FXY
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.FitYByX (Phase 13.4)" $ do
+ let xCont = LA.fromList [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
+ yCont = LA.fromList [2.1, 4.0, 5.9, 8.1, 10.0, 11.9, 14.1, 16.0, 18.0, 20.1]
+ xCat = LA.fromList [0, 0, 0, 1, 1, 1, 2, 2, 2]
+ yByCat = LA.fromList [1, 2, 1.5, 10, 11, 10.5, 20, 21, 20.5]
+ xCat2 = LA.fromList [0, 0, 1, 1, 0, 1]
+ yCat2 = LA.fromList [0, 0, 1, 1, 0, 1]
+ xBin = LA.fromList [1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0]
+ yBin = LA.fromList [0, 0, 0, 0, 1, 1, 1, 1]
+ it "FitContCont: y ≈ 2x で線形" $ do
+ case FXY.fitYByX FXY.Continuous FXY.Continuous xCont yCont of
+ Left e -> expectationFailure (T.unpack e)
+ Right (FXY.FitContCont _) -> pure ()
+ Right _ -> expectationFailure "wrong variant"
+ it "FitCatCont: 3 group ANOVA で強く有意" $ do
+ case FXY.fitYByX FXY.Categorical FXY.Continuous xCat yByCat of
+ Left e -> expectationFailure (T.unpack e)
+ Right (FXY.FitCatCont tr means) -> do
+ ST.trPValue tr `shouldSatisfy` (< 0.001)
+ length means `shouldBe` 3
+ Right _ -> expectationFailure "wrong variant"
+ it "FitCatCat: 完全相関で chi-square 棄却" $ do
+ case FXY.fitYByX FXY.Categorical FXY.Categorical xCat2 yCat2 of
+ Left e -> expectationFailure (T.unpack e)
+ Right (FXY.FitCatCat tr) -> ST.trPValue tr `shouldSatisfy` (< 0.05)
+ Right _ -> expectationFailure "wrong variant"
+ it "FitContCat: binary y で logistic GLM 動作" $ do
+ case FXY.fitYByX FXY.Continuous FXY.Categorical xBin yBin of
+ Left e -> expectationFailure (T.unpack e)
+ Right (FXY.FitContCat _) -> pure ()
+ Right _ -> expectationFailure "wrong variant"
+ it "FitContCat: y が 0/1 でないと Left" $ do
+ case FXY.fitYByX FXY.Continuous FXY.Categorical xBin yByCat of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+ it "長さ mismatch は Left" $ do
+ case FXY.fitYByX FXY.Continuous FXY.Continuous xCont (LA.fromList [1, 2]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
diff --git a/test/Hanalyze/Model/Formula/ContrastSpec.hs b/test/Hanalyze/Model/Formula/ContrastSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/Formula/ContrastSpec.hs
@@ -0,0 +1,92 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.Formula.ContrastSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import qualified Hanalyze.Model.Core as Core
+import qualified Hanalyze.MCMC.Core as Core
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Contrast coding (Phase 47 A2)" $ do
+ let frm s = case parseFormula s of Right f -> f; Left e -> error e
+ gs = ["A","A","A","B","B","B","C","C","C"] :: [T.Text]
+ xs = [1,2,3, 1,2,3, 1,2,3] :: [Double]
+ ys = [10,11,12, 20,22,24, 5,6,7] :: [Double]
+ df = DX.fromNamedColumns
+ [ ("y", DX.fromList ys), ("g", DX.fromList gs), ("x", DX.fromList xs) ]
+ fitOf s = case fitLMF (frm s) df of Right (fr, _) -> fr; Left e -> error e
+ yhat = Core.fittedList
+ close a b = and (zipWith (\p q -> abs (p - q) < 1e-9) a b)
+
+ describe "parameterization 不変 (ŷ/R² は contrast 非依存 = Python 非依存オラクル)" $ do
+ let trt = fitOf "y g = b0 + bg ! g"
+ sm = fitOf "y g = b0 + bg ! C(g, Sum)"
+ hel = fitOf "y g = b0 + bg ! C(g, Helmert)"
+ pol = fitOf "y g = b0 + bg ! C(g, Poly)"
+ it "Treatment と Sum で ŷ 一致" $ close (yhat trt) (yhat sm) `shouldBe` True
+ it "Treatment と Helmert で ŷ 一致" $ close (yhat trt) (yhat hel) `shouldBe` True
+ it "Treatment と Polynomial で ŷ 一致" $ close (yhat trt) (yhat pol) `shouldBe` True
+ it "Treatment と Sum で R² 一致" $
+ abs (Core.rSquared1 trt - Core.rSquared1 sm) < 1e-9 `shouldBe` True
+ it "ŷ = 群平均 (主効果のみ)" $ do
+ let mean zs = sum zs / fromIntegral (length zs)
+ gm = [ mean [v | (g', v) <- zip gs ys, g' == g] | g <- gs ]
+ close (yhat trt) gm `shouldBe` True
+
+ describe "列数 / 識別性" $ do
+ let dmOf s = case modelFrame (frm s) df >>= designMatrixF (frm s) of
+ Right (x, _) -> x; Left e -> error e
+ it "切片あり主効果 (Sum) = 切片1 + contrast(k-1)=2 = 3 列" $
+ LA.cols (dmOf "y g = b0 + bg ! C(g, Sum)") `shouldBe` 3
+ it "Sum は満ランク" $
+ LA.rank (dmOf "y g = b0 + bg ! C(g, Sum)") `shouldBe` 3
+
+ describe "contrastMatrix (構造)" $ do
+ it "Treatment k=3: 参照行 (水準0) = [0,0]" $
+ LA.toLists (contrastMatrix Treatment 3) `shouldBe` [[0,0],[1,0],[0,1]]
+ it "Sum k=3: 最終行 = [-1,-1] (sum-to-zero)" $
+ LA.toLists (contrastMatrix Sum 3) `shouldBe` [[1,0],[0,1],[-1,-1]]
+ it "Polynomial k=3: 列直交 (QᵀQ = I)" $ do
+ let m = contrastMatrix Polynomial 3
+ g = LA.tr m LA.<> m
+ and [ abs (g `LA.atIndex` (i, j) - (if i == j then 1 else 0)) < 1e-9
+ | i <- [0, 1], j <- [0, 1] ] `shouldBe` True
+
+ describe "factor×連続 (masked 列は full coding ゆえ contrast 非依存・ŷ 不変)" $ do
+ let trt = fitOf "y g x = b0 + bg ! g + bx ! g * x"
+ sm = fitOf "y g x = b0 + bg ! C(g, Sum) + bx ! C(g, Sum) * x"
+ it "Treatment と Sum で ŷ 一致" $ close (yhat trt) (yhat sm) `shouldBe` True
+
+ describe "R front-end C(g, Sum) は正本構文と等価" $ do
+ let nat = fitOf "y g = b0 + bg ! C(g, Sum)"
+ rfit = case parseModel "y ~ C(g, Sum)" >>= \f -> fitLMF f df of
+ Right (fr, _) -> fr; Left e -> error e
+ it "ŷ 一致" $ close (yhat nat) (yhat rfit) `shouldBe` True
+
+ -- ----------------------------------------------------------------------------
+ -- A3 (Phase 47) weights / offset = WLS
+ -- ----------------------------------------------------------------------------
diff --git a/test/Hanalyze/Model/Formula/DesignSpec.hs b/test/Hanalyze/Model/Formula/DesignSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/Formula/DesignSpec.hs
@@ -0,0 +1,127 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.Formula.DesignSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import qualified Hanalyze.Model.Spline as Sp
+import qualified Hanalyze.Model.Core as Core
+import qualified Hanalyze.MCMC.Core as Core
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Formula.Design (A17 designMatrixF/fitLMF)" $ do
+ let frm s = case parseFormula s of Right f -> f; Left e -> error e
+
+ describe "検証点①: factor×factor 飽和モデル (ŷ = セル平均・満ランク)" $ do
+ let gs = ["A","A","B","B","C","C","A","A","B","B","C","C"] :: [T.Text]
+ ts = ["P","Q","P","Q","P","Q","P","Q","P","Q","P","Q"] :: [T.Text]
+ ys = [10,20,30,40,50,60,12,22,34,44,52,62] :: [Double]
+ df = DX.fromNamedColumns
+ [ ("y", DX.fromList ys)
+ , ("g", DX.fromList gs)
+ , ("t", DX.fromList ts) ]
+ Right (fr, lbls) = fitLMF (frm "y g t = b0 + bg!g + bt!t + bgt!g!t") df
+ cellMean a b = let zs = [v | (gi,ti,v) <- zip3 gs ts ys, gi==a, ti==b]
+ in sum zs / fromIntegral (length zs)
+ expected = [cellMean a b | (a,b) <- zip gs ts]
+ Right mf = modelFrame (frm "y g t = b0 + bg!g + bt!t + bgt!g!t") df
+ Right (x, _) = designMatrixF (frm "y g t = b0 + bg!g + bt!t + bgt!g!t") mf
+ it "列数 = Kg*Kt = 6 (treatment contrast)" $
+ length lbls `shouldBe` 6
+ it "設計行列が満ランク (制約後)" $
+ LA.rank x `shouldBe` 6
+ it "ŷ = セル平均" $
+ and (zipWith (\p q -> abs (p - q) < 1e-9) (Core.fittedList fr) expected)
+ `shouldBe` True
+
+ describe "線形連続 (既存 OLS と一致)" $ do
+ let df = DX.fromNamedColumns
+ [ ("y", DX.fromList ([2.1,3.9,6.1,7.9,10.1] :: [Double]))
+ , ("x", DX.fromList ([1,2,3,4,5] :: [Double])) ]
+ Right (fr, _) = fitLMF (frm "y x = b0 + b1*x") df
+ coefs = LA.toList (Core.coefficientsV fr)
+ it "切片≈0・傾き≈2" $ do
+ abs (coefs !! 0 - 0.02) `shouldSatisfy` (< 1e-6)
+ abs (coefs !! 1 - 2.0) `shouldSatisfy` (< 1e-6)
+
+ describe "factor×連続 (水準別傾き) は列が水準分" $ do
+ let df = DX.fromNamedColumns
+ [ ("y", DX.fromList ([1,2,3,4,5,6] :: [Double]))
+ , ("x", DX.fromList ([1,2,3,4,5,6] :: [Double]))
+ , ("g", DX.fromList (["A","A","B","B","C","C"] :: [T.Text])) ]
+ Right (_, lbls) = fitLMF (frm "y g x = b0 + bg!g + bs!g*x") df
+ it "切片 + g 主効果2 + g×x 傾き3 (連続 interaction は全水準保持) = 6 列" $
+ length lbls `shouldBe` 6
+
+ describe "線形性検出" $ do
+ let df = DX.fromNamedColumns
+ [ ("y", DX.fromList ([1,2,3] :: [Double]))
+ , ("x", DX.fromList ([1,2,3] :: [Double])) ]
+ it "a*exp(-b*x) は非線形ゆえ Left" $
+ fitLMF (frm "y x = a*exp(-b*x)") df `shouldSatisfy` isLeftE
+ it "b0 + b1*x + b2*log x は線形ゆえ Right" $
+ linearityCheck (frm "y x = b0 + b1*x + b2*log x") df `shouldSatisfy` isRightE
+
+ describe "検証点②: 基底展開 (Python 非依存オラクル)" $ do
+ let xs = [0.2,0.5,0.9,1.4,2.0,2.6,3.1,3.7,4.2,4.8] :: [Double]
+ ys = map (\x -> sin x + 0.1*x) xs
+ df = DX.fromNamedColumns
+ [ ("y", DX.fromList ys), ("x", DX.fromList xs) ]
+ it "poly(x,2) は二次を厳密再現 (y=1+2x+3x² で R²≈1)" $ do
+ let yq = map (\x -> 1 + 2*x + 3*x*x) xs
+ dfq = DX.fromNamedColumns [ ("y", DX.fromList yq), ("x", DX.fromList xs) ]
+ Right (fr, _) = fitLMF (frm "y x = b0 + bp ! poly(x,2)") dfq
+ and (zipWith (\p q -> abs (p - q) < 1e-9) (Core.fittedList fr) yq)
+ `shouldBe` True
+ it "opoly(x,2) は不等間隔でも設計列が直交 (linear ⊥ quadratic・raw poly と別)" $ do
+ -- 不等間隔 3 点。 raw poly(x,2) なら x·x² = 1·1+2·4+5·25 = 134 ≠ 0 で共線だが、
+ -- opoly は実測値を QR 直交化するので linear 列 ⊥ quadratic 列 (内積 ≈ 0)。
+ let xsu = [1.0, 2.0, 5.0] :: [Double]
+ dfu = DX.fromNamedColumns
+ [ ("y", DX.fromList [0,0,0 :: Double]), ("x", DX.fromList xsu) ]
+ frmR s = case parseRFormula s of Right f -> f; Left e -> error e
+ fR = frmR "y ~ opoly(x,2)"
+ Right mfu = modelFrame fR dfu
+ Right (xmat, _) = designMatrixF fR mfu
+ cols = LA.toColumns xmat
+ [c1, c2] = drop (length cols - 2) cols -- opoly の 2 列 (切片を除く)
+ abs (LA.dot c1 c2) `shouldSatisfy` (< 1e-9)
+ it "opoly(x,2) は二次を厳密再現 (raw poly と同 span・ŷ 一致)" $ do
+ let xsu = [1.0, 2.0, 5.0, 7.0, 8.0] :: [Double]
+ yq = map (\x -> 1 + 2*x + 3*x*x) xsu
+ dfq2 = DX.fromNamedColumns [ ("y", DX.fromList yq), ("x", DX.fromList xsu) ]
+ frmR s = case parseRFormula s of Right f -> f; Left e -> error e
+ Right (fr, _) = fitLMF (frmR "y ~ opoly(x,2)") dfq2
+ and (zipWith (\p q -> abs (p - q) < 1e-9) (Core.fittedList fr) yq)
+ `shouldBe` True
+ it "bspline(x,4) (切片なし) の ŷ = fitSpline (BSpline 3, quantileKnots 4)" $ do
+ let Right (fr, _) = fitLMF (frm "y x = bs ! bspline(x,4)") df
+ sf = Sp.fitSpline (Sp.BSpline 3) (Sp.quantileKnots 4 (V.fromList xs))
+ (V.fromList xs) (V.fromList ys)
+ yhatSpline = V.toList (Sp.predictSpline sf (V.fromList xs))
+ and (zipWith (\p q -> abs (p - q) < 1e-9) (Core.fittedList fr) yhatSpline)
+ `shouldBe` True
diff --git a/test/Hanalyze/Model/Formula/FrameSpec.hs b/test/Hanalyze/Model/Formula/FrameSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/Formula/FrameSpec.hs
@@ -0,0 +1,119 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.Formula.FrameSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Formula.Frame (A16 ModelFrame)" $ do
+ let dfLM = DX.fromNamedColumns
+ [ ("x", DX.fromList ([1,2,3,4, 1,2,3,4, 1,2,3,4] :: [Double]))
+ , ("y", DX.fromList ([7,6,7,7, 5,4,5,5, 3,2,3,3] :: [Double]))
+ , ("group", DX.fromList (["A","A","A","A","B","B","B","B","C","C","C","C"] :: [T.Text])) ]
+ Right f1 = parseFormula "y x group = b0 + b1*x + bg ! group"
+ Right mf1 = modelFrame f1 dfLM
+
+ it "連続 + factor: パラメータ分離" $
+ mfParams mf1 `shouldBe` ["b0", "b1", "bg"]
+ it "行数 = 応答列長" $
+ mfNRows mf1 `shouldBe` 12
+ it "factor は使われ方 (! の右) で検出・水準は昇順・index 付き" $
+ lookup "group" (mfRoles mf1)
+ `shouldBe` Just (RoleFactor ["A", "B", "C"]
+ (V.fromList [0,0,0,0, 1,1,1,1, 2,2,2,2]))
+ it "算術中の変数は連続" $
+ lookup "x" (mfRoles mf1)
+ `shouldBe` Just (RoleContinuous (V.fromList [1,2,3,4, 1,2,3,4, 1,2,3,4]))
+
+ describe "factor×factor (検証点① の前段)" $ do
+ let dfGT = DX.fromNamedColumns
+ [ ("y", DX.fromList ([1,2,3,4,5,6] :: [Double]))
+ , ("g", DX.fromList (["A","A","B","B","C","C"] :: [T.Text]))
+ , ("t", DX.fromList (["P","Q","P","Q","P","Q"] :: [T.Text])) ]
+ Right fGT = parseFormula "y g t = b0 + bg!g + bt!t + bgt!g!t"
+ Right mfGT = modelFrame fGT dfGT
+ it "g, t とも factor・パラメータは b0/bg/bt/bgt" $ do
+ mfParams mfGT `shouldBe` ["b0", "bg", "bt", "bgt"]
+ indexedVars (formRHS fGT) `shouldBe` ["g", "t"]
+
+ describe "error" $ do
+ it "応答列が無ければ Left" $
+ modelFrame f1 (DX.fromNamedColumns
+ [ ("x", DX.fromList ([1,2] :: [Double])) ]) `shouldSatisfy` isLeftE
+ it "連続変数が無ければ Left" $ do
+ let Right fNo = parseFormula "y q = b0 + b1*q"
+ modelFrame fNo dfLM `shouldSatisfy` isLeftE
+
+ describe "MissingPolicy (Phase 47 A1)" $ do
+ let dfNA = DX.fromNamedColumns
+ [ ("x", DX.fromList ([Just 1, Just 2, Nothing, Just 4] :: [Maybe Double]))
+ , ("y", DX.fromList ([10,20,30,40] :: [Double]))
+ , ("g", DX.fromList (["A","B","A","B"] :: [T.Text])) ]
+ Right fNA = parseFormula "y x g = b0 + b1*x + bg ! g"
+ contOf mf = case lookup "x" (mfRoles mf) of
+ Just (RoleContinuous v) -> V.toList v
+ _ -> []
+
+ it "DropRows: NA 行を除外" $ do
+ let Right mf = modelFrameWith DropRows fNA dfNA
+ mfNRows mf `shouldBe` 3
+ contOf mf `shouldBe` [1,2,4]
+ it "modelFrame は DropRows 既定 (後方互換)" $
+ modelFrame fNA dfNA `shouldBe` modelFrameWith DropRows fNA dfNA
+ it "ErrorOnMissing: NA があれば Left" $
+ modelFrameWith ErrorOnMissing fNA dfNA `shouldSatisfy` isLeftE
+ it "Impute ImputeMean: 連続説明変数を平均補完 (行数不変)" $ do
+ let Right mf = modelFrameWith (Impute ImputeMean) fNA dfNA
+ mfNRows mf `shouldBe` 4
+ (contOf mf !! 2) `shouldSatisfy` (\v -> abs (v - 7/3) < 1e-9) -- mean [1,2,4]
+ it "Impute: 応答の欠損は Left に誘導" $ do
+ let dfYNA = DX.fromNamedColumns
+ [ ("x", DX.fromList ([1,2,3,4] :: [Double]))
+ , ("y", DX.fromList ([Just 10, Nothing, Just 30, Just 40] :: [Maybe Double]))
+ , ("g", DX.fromList (["A","B","A","B"] :: [T.Text])) ]
+ modelFrameWith (Impute ImputeMean) fNA dfYNA `shouldSatisfy` isLeftE
+
+ describe "TreatAsCategory" $ do
+ let dfFNA = DX.fromNamedColumns
+ [ ("y", DX.fromList ([10,20,30,40] :: [Double]))
+ , ("x", DX.fromList ([1,2,3,4] :: [Double]))
+ , ("g", DX.fromList (["A","B","NA","B"] :: [T.Text])) ] -- "NA" = 欠損文字列
+ it "factor の NA を独立水準 として保持 (行数不変・水準は昇順)" $ do
+ let Right mf = modelFrameWith TreatAsCategory fNA dfFNA
+ mfNRows mf `shouldBe` 4
+ lookup "g" (mfRoles mf)
+ `shouldBe` Just (RoleFactor ["","A","B"] (V.fromList [1,2,0,2]))
+ it "連続列の欠損は TreatAsCategory では埋めず Left に誘導" $ do
+ let dfXFNA = DX.fromNamedColumns
+ [ ("y", DX.fromList ([10,20,30,40] :: [Double]))
+ , ("x", DX.fromList ([Just 1, Nothing, Just 3, Just 4] :: [Maybe Double]))
+ , ("g", DX.fromList (["A","B","A","B"] :: [T.Text])) ]
+ modelFrameWith TreatAsCategory fNA dfXFNA `shouldSatisfy` isLeftE
+
+ -- ----------------------------------------------------------------------------
+ -- A17 designMatrixF / fitLMF — 基底展開 (factor) + 線形性検出 + 識別性
+ -- ----------------------------------------------------------------------------
diff --git a/test/Hanalyze/Model/Formula/MixedSpec.hs b/test/Hanalyze/Model/Formula/MixedSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/Formula/MixedSpec.hs
@@ -0,0 +1,106 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.Formula.MixedSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Formula.Mixed (Phase 48 A3/A4)" $ do
+ let approxG tol a b = abs (a - b) < tol
+
+ describe "extractRandom: (…|g) ブロック抽出" $ do
+ it "(1|g) = random intercept" $
+ extractRandom "y ~ x + (1|g)"
+ `shouldBe` Right ("y ~ x", [RandomSpec True [] "g"])
+ it "(1+x|g) = random intercept + slope" $
+ extractRandom "y ~ x + (1+x|g)"
+ `shouldBe` Right ("y ~ x", [RandomSpec True ["x"] "g"])
+ it "(0+x|g) = random slope のみ (intercept 抑制)" $
+ extractRandom "y ~ x + (0+x|g)"
+ `shouldBe` Right ("y ~ x", [RandomSpec False ["x"] "g"])
+ it "(1|g) のみ → 固定は intercept 補完" $
+ extractRandom "y ~ (1|g)"
+ `shouldBe` Right ("y ~ 1", [RandomSpec True [] "g"])
+ it "random 項なし → 空リスト" $
+ extractRandom "y ~ x"
+ `shouldBe` Right ("y ~ x", [])
+ it "独自構文 y x = b0 + b1*x + (1|g)" $
+ extractRandom "y x = b0 + b1*x + (1|g)"
+ `shouldBe` Right ("y x = b0 + b1*x", [RandomSpec True [] "g"])
+
+ -- e2e: 3 群 × 4 obs (GLMM describe と同データ)。 (1|group) は
+ -- fitLMEDataFrame の random intercept と同一結果になるはず。
+ let dfL = DX.fromNamedColumns
+ [ ("x", DX.fromList ([1,2,3,4, 1,2,3,4, 1,2,3,4] :: [Double]))
+ , ("y", DX.fromList ([7.1,6.9,7.0,7.0, 5.0,4.9,5.1,5.0, 3.0,2.9,3.1,3.0] :: [Double]))
+ , ("group", DX.fromList (["A","A","A","A","B","B","B","B","C","C","C","C"] :: [T.Text])) ]
+
+ describe "fitMixedLME: random intercept (1|group)" $ do
+ let resE = fitMixedLME "y ~ x + (1|group)" dfL
+ ref = fitLMEDataFrame [("x", 1)] "group" "y" dfL
+ it "returns Right" $
+ resE `shouldSatisfy` either (const False) (const True)
+ it "G is 1×1 and matches fitLMEDataFrame σ²_u" $
+ case (resE, ref) of
+ (Right (r, _), Just rd) ->
+ LA.atIndex (reRandCov r) (0,0) `shouldSatisfy` approxG 1e-6 (glmmRandVar rd)
+ _ -> expectationFailure "expected Right + Just"
+ it "BLUPs match fitLMEDataFrame (random intercept equivalence)" $
+ case (resE, ref) of
+ (Right (r, _), Just rd) ->
+ LA.toList (LA.flatten (reBLUPs r))
+ `shouldSatisfy` (\bs -> and (zipWith (approxG 1e-6) bs (V.toList (glmmBLUPs rd))))
+ _ -> expectationFailure "expected Right + Just"
+ it "fixed coef labels include intercept + x" $
+ case resE of
+ Right (_, labels) -> length labels `shouldBe` 2
+ _ -> expectationFailure "expected Right"
+
+ describe "fitMixedLME: random slope (1+x|group)" $ do
+ let resE = fitMixedLME "y ~ x + (1+x|group)" dfL
+ it "returns Right with 2×2 G and q×2 BLUPs" $
+ case resE of
+ Right (r, _) -> do
+ LA.size (reRandCov r) `shouldBe` (2, 2)
+ LA.size (reBLUPs r) `shouldBe` (3, 2)
+ _ -> expectationFailure "expected Right"
+
+ describe "error paths" $ do
+ it "random 項なしは Left" $
+ fitMixedLME "y ~ x" dfL `shouldSatisfy` either (const True) (const False)
+ it "存在しない grouping 列は Left" $
+ fitMixedLME "y ~ x + (1|nosuch)" dfL `shouldSatisfy` either (const True) (const False)
+
+ describe "fitMixedGLMM: Binomial (1|group)" $ do
+ let dfB = DX.fromNamedColumns
+ [ ("dose", DX.fromList ([1,2,3,4,5, 1,2,3,4,5, 1,2,3,4,5] :: [Double]))
+ , ("success", DX.fromList ([1,1,1,1,1, 1,1,0,1,0, 0,0,0,1,0] :: [Double]))
+ , ("hospital", DX.fromList (["A","A","A","A","A","B","B","B","B","B","C","C","C","C","C"] :: [T.Text])) ]
+ it "returns Right" $
+ fitMixedGLMM Binomial Logit "success ~ dose + (1|hospital)" dfB
+ `shouldSatisfy` either (const False) (const True)
diff --git a/test/Hanalyze/Model/Formula/NonlinearSpec.hs b/test/Hanalyze/Model/Formula/NonlinearSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/Formula/NonlinearSpec.hs
@@ -0,0 +1,58 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.Formula.NonlinearSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "非線形フィット NLS (Phase 47 A4)" $ do
+ let frm s = case parseFormula s of Right f -> f; Left e -> error e
+ xs = [0,0.5,1,1.5,2,2.5,3,3.5,4,4.5,5] :: [Double]
+ a0 = 3.0; b0 = 0.5
+ ys = map (\x -> a0 * exp (negate b0 * x)) xs -- ノイズなし → 完全 recovery 可
+ df = DX.fromNamedColumns [ ("y", DX.fromList ys), ("x", DX.fromList xs) ]
+ f = frm "y x = a * exp(-b * x)"
+ lookupP k pm = maybe (0/0) id (lookup k pm)
+
+ it "a*exp(-b*x) のパラメータ復元 (ノイズなし、 init a=1 b=1)" $ do
+ let Right r = fitNLS f df [("a",1),("b",1)]
+ pm = nlsParams r
+ (abs (lookupP "a" pm - a0) < 1e-2 && abs (lookupP "b" pm - b0) < 1e-2)
+ `shouldBe` True
+ it "ノイズなしで SSR ≈ 0 かつ収束" $ do
+ let Right r = fitNLS f df [("a",1),("b",1)]
+ (nlsSSR r < 1e-6 && nlsConverged r) `shouldBe` True
+ it "初期値が無いパラメータは Left" $
+ fitNLS f df [("a",1)] `shouldSatisfy` isLeftE
+ it "factor 添字は NLS 非対応 (Left)" $ do
+ let dfg = DX.fromNamedColumns
+ [ ("y", DX.fromList ([1,2,3,4]::[Double]))
+ , ("g", DX.fromList (["A","B","A","B"]::[T.Text])) ]
+ fitNLS (frm "y g = a * bg ! g") dfg [("a",1),("bg",1)] `shouldSatisfy` isLeftE
+
+ -- ----------------------------------------------------------------------------
+ -- A18 R/patsy front-end — 同 AST へ + クロス front-end 等価 (検証点④ の Python 非依存半分)
+ -- ----------------------------------------------------------------------------
diff --git a/test/Hanalyze/Model/Formula/RFormulaSpec.hs b/test/Hanalyze/Model/Formula/RFormulaSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/Formula/RFormulaSpec.hs
@@ -0,0 +1,68 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.Formula.RFormulaSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import qualified Hanalyze.Model.Core as Core
+import qualified Hanalyze.MCMC.Core as Core
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Formula.RFormula (A18 R front-end)" $ do
+ let gs = ["A","A","B","B","C","C","A","A","B","B","C","C"] :: [T.Text]
+ ts = ["P","Q","P","Q","P","Q","P","Q","P","Q","P","Q"] :: [T.Text]
+ ys = [10,20,30,40,50,60,12,22,34,44,52,62] :: [Double]
+ xs = [1,2,3,4,5,6,1,2,3,4,5,6] :: [Double]
+ df = DX.fromNamedColumns
+ [ ("y", DX.fromList ys), ("g", DX.fromList gs)
+ , ("t", DX.fromList ts), ("x", DX.fromList xs) ]
+ yhat s = case parseModel s >>= \f -> fitLMF f df of
+ Right (fr, _) -> Right (Core.fittedList fr)
+ Left e -> Left e
+ equiv rsyn usyn = case (yhat rsyn, yhat usyn) of
+ (Right a, Right b) -> and (zipWith (\p q -> abs (p - q) < 1e-9) a b)
+ _ -> False
+
+ describe "dispatch: ~ を含めば R・無ければ独自" $ do
+ it "y ~ x → 応答 y / データ変数 x" $
+ case parseModel "y ~ x" of
+ Right (Formula r dv _) -> (r, dv) `shouldBe` ("y", ["x"])
+ Left e -> expectationFailure e
+ it "独自構文 (= 区切り) も同 dispatch で通る" $
+ parseModel "y x = b0 + b1*x" `shouldSatisfy` isRightE
+
+ describe "クロス front-end 等価 (R 構文 vs 独自構文 → 同 ŷ)" $ do
+ it "linear: y~x ≡ y x = b0+b1*x" $
+ equiv "y ~ x" "y x = b0 + b1*x" `shouldBe` True
+ it "factor×factor: y~C(g)*C(t) ≡ 飽和" $
+ equiv "y ~ C(g)*C(t)" "y g t = b0 + bg!g + bt!t + bgt!g!t" `shouldBe` True
+ it "factor×連続: y~C(g)+C(g):x ≡ 水準別傾き" $
+ equiv "y ~ C(g) + C(g):x" "y g x = b0 + bg!g + bs!g*x" `shouldBe` True
+ it "I(x**2): y~x+I(x**2) ≡ b0+b1*x+b2*x^2" $
+ equiv "y ~ x + I(x**2)" "y x = b0 + b1*x + b2*x^2" `shouldBe` True
+ it "poly: y~poly(x,2) ≡ b0+bp!poly(x,2)" $
+ equiv "y ~ poly(x,2)" "y x = b0 + bp ! poly(x,2)" `shouldBe` True
+
+ -- round-trip 用の任意 Formula 生成 (識別子は固定プール・Lit は非負整数)。
diff --git a/test/Hanalyze/Model/Formula/WLSSpec.hs b/test/Hanalyze/Model/Formula/WLSSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/Formula/WLSSpec.hs
@@ -0,0 +1,69 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.Formula.WLSSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import qualified Hanalyze.Model.Core as Core
+import qualified Hanalyze.MCMC.Core as Core
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "weights / offset = WLS (Phase 47 A3)" $ do
+ let frm s = case parseFormula s of Right f -> f; Left e -> error e
+ xs = [1,2,3,4,5,6,7,8] :: [Double]
+ ys = [2.1,3.9,6.2,7.8,10.1,12.2,13.8,16.1] :: [Double]
+ ws = [1,1,2,2,3,3,4,4] :: [Double]
+ df = DX.fromNamedColumns
+ [ ("y", DX.fromList ys), ("x", DX.fromList xs), ("w", DX.fromList ws) ]
+ f = frm "y x = b0 + b1*x"
+ coefOf = LA.toList . Core.coefficientsV
+ close a b = and (zipWith (\p q -> abs (p - q) < 1e-8) a b)
+
+ it "w≡1 (重みなし) は OLS = fitLMF と一致" $ do
+ let Right (a, _) = fitWLSF defaultWLS f df
+ Right (b, _) = fitLMF f df
+ close (coefOf a) (coefOf b) `shouldBe` True
+
+ it "WLS 係数 = 閉形式 (XᵀWX)⁻¹XᵀWy (hmatrix 直計算オラクル)" $ do
+ let Right (r, _) = fitWLSF defaultWLS { wcWeights = Just "w" } f df
+ x = LA.fromLists [ [1, xi] | xi <- xs ]
+ w = LA.diag (LA.fromList ws)
+ y = LA.asColumn (LA.fromList ys)
+ beta = LA.flatten (LA.inv (LA.tr x LA.<> w LA.<> x) LA.<> LA.tr x LA.<> w LA.<> y)
+ close (coefOf r) (LA.toList beta) `shouldBe` True
+
+ it "offset: y を offset z 付きで fit = (y−z) を素の fit と一致" $ do
+ let zs = [0.5,1.0,1.5,2.0,2.5,3.0,3.5,4.0] :: [Double]
+ dfO = DX.fromNamedColumns
+ [ ("y", DX.fromList ys), ("x", DX.fromList xs), ("z", DX.fromList zs) ]
+ dfM = DX.fromNamedColumns
+ [ ("y", DX.fromList (zipWith (-) ys zs)), ("x", DX.fromList xs) ]
+ Right (ro, _) = fitWLSF defaultWLS { wcOffset = Just "z" } f dfO
+ Right (rm, _) = fitLMF f dfM
+ close (coefOf ro) (coefOf rm) `shouldBe` True
+
+ -- ----------------------------------------------------------------------------
+ -- A4 (Phase 47) 非線形フィット NLS
+ -- ----------------------------------------------------------------------------
diff --git a/test/Hanalyze/Model/FormulaSpec.hs b/test/Hanalyze/Model/FormulaSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/FormulaSpec.hs
@@ -0,0 +1,55 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.FormulaSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Formula (A15 parser)" $ do
+ describe "golden: 入力 → 期待 AST (優先順位・結合の固定)" $ do
+ let g src expect = it (T.unpack src) $ parseFormula src `shouldBe` Right expect
+ g "y x = b1*x"
+ (Formula "y" ["x"] (Bin Mul (Ref "b1") (Ref "x")))
+ g "y x = b0 + b1*x"
+ (Formula "y" ["x"] (Bin Add (Ref "b0") (Bin Mul (Ref "b1") (Ref "x"))))
+ g "y g t = b ! g ! t"
+ (Formula "y" ["g", "t"] (Index (Index (Ref "b") (Ref "g")) (Ref "t")))
+ g "y g x = bg ! g * x" -- ! は * より高優先 (factor×連続 = 水準別傾き)
+ (Formula "y" ["g", "x"] (Bin Mul (Index (Ref "bg") (Ref "g")) (Ref "x")))
+ g "y x = a*exp(-b*x)" -- 単項 - は * より高優先 ゆえ -b*x = (-b)*x
+ (Formula "y" ["x"] (Bin Mul (Ref "a") (App "exp" [Bin Mul (Neg (Ref "b")) (Ref "x")])))
+ g "y x = b0 + b1*x^2" -- ^ は * より高優先
+ (Formula "y" ["x"] (Bin Add (Ref "b0") (Bin Mul (Ref "b1") (Bin Pow (Ref "x") (Lit 2)))))
+ g "y x = log (x+1)" -- 空白並置適用
+ (Formula "y" ["x"] (App "log" [Bin Add (Ref "x") (Lit 1)]))
+
+ describe "error: 不正入力は Left" $ do
+ let bad src = it (T.unpack src) $ parseFormula src `shouldSatisfy` isLeftE
+ bad "y x = " -- 右辺なし
+ bad "y x b1*x" -- = なし
+ bad "= b0 + b1*x" -- 左辺なし
+
+ describe "round-trip: parse . pretty == id (QuickCheck)" $
+ prop "任意 Formula で round-trip" $ \f ->
+ parseFormula (prettyFormula f) === Right f
diff --git a/test/Hanalyze/Model/GARCHSpec.hs b/test/Hanalyze/Model/GARCHSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/GARCHSpec.hs
@@ -0,0 +1,89 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.GARCHSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.GARCH as GARCH
+import qualified System.Random.MWC.Distributions as MWCD
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.GARCH (Phase 35-A1)" $ do
+ -- GARCH(1,1) からのサンプル生成: y_t = σ_t · z_t, z_t ~ N(0,1)
+ -- σ²_t = ω + α ε²_{t-1} + β σ²_{t-1}
+ let simulateGARCH gen omega alpha beta n = do
+ let unc = omega / (1 - alpha - beta)
+ loop !i !s2Prev !ePrev acc
+ | i >= n = pure (reverse acc)
+ | otherwise = do
+ z <- MWCD.standard gen
+ let !s2 = if i == 0 then unc
+ else omega + alpha * ePrev * ePrev + beta * s2Prev
+ !sigma = sqrt s2
+ !e = sigma * z
+ loop (i + 1) s2 e (e : acc)
+ es <- loop 0 0 0 []
+ pure (LA.fromList es)
+ it "fitGARCH: ω/α/β > 0、 α + β < 1" $ do
+ gen <- MWC.create
+ ys <- simulateGARCH gen (0.05 :: Double) 0.10 0.85 1000
+ let fit = GARCH.fitGARCH ys
+ GARCH.gOmega fit `shouldSatisfy` (> 0)
+ GARCH.gAlpha fit `shouldSatisfy` (>= 0)
+ GARCH.gBeta fit `shouldSatisfy` (>= 0)
+ (GARCH.gAlpha fit + GARCH.gBeta fit) `shouldSatisfy` (< 1)
+ it "fitGARCH: 真値 (ω=0.05, α=0.10, β=0.85) を概ね回復" $ do
+ gen <- MWC.create
+ ys <- simulateGARCH gen (0.05 :: Double) 0.10 0.85 2000
+ let fit = GARCH.fitGARCH ys
+ ab = GARCH.gAlpha fit + GARCH.gBeta fit
+ -- α+β (persistence) は推定が安定しやすい
+ ab `shouldSatisfy` (> 0.80)
+ ab `shouldSatisfy` (< 1.00)
+ -- 無条件分散 ω/(1-α-β) はサンプル分散に近い
+ let n = LA.size ys
+ var_y = LA.dot ys ys / fromIntegral n
+ uncV = GARCH.gOmega fit / (1 - ab)
+ abs (uncV - var_y) / var_y `shouldSatisfy` (< 0.5)
+ it "fitGARCH: gSigma2 の長さ = 入力長" $ do
+ gen <- MWC.create
+ ys <- simulateGARCH gen (0.1 :: Double) 0.05 0.90 500
+ let fit = GARCH.fitGARCH ys
+ LA.size (GARCH.gSigma2 fit) `shouldBe` 500
+ it "forecastGARCH: 長期予測が無条件分散 ω/(1-α-β) に収束" $ do
+ gen <- MWC.create
+ ys <- simulateGARCH gen (0.05 :: Double) 0.10 0.85 1000
+ let fit = GARCH.fitGARCH ys
+ fc = GARCH.forecastGARCH fit 200
+ ab = GARCH.gAlpha fit + GARCH.gBeta fit
+ unc = GARCH.gOmega fit / (1 - ab)
+ fLast = LA.atIndex fc 199
+ abs (fLast - unc) / unc `shouldSatisfy` (< 0.05)
+ it "forecastGARCH: 長さ = h" $ do
+ gen <- MWC.create
+ ys <- simulateGARCH gen (0.05 :: Double) 0.10 0.85 200
+ let fit = GARCH.fitGARCH ys
+ fc = GARCH.forecastGARCH fit 12
+ LA.size fc `shouldBe` 12
diff --git a/test/Hanalyze/Model/GLMMSpec.hs b/test/Hanalyze/Model/GLMMSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/GLMMSpec.hs
@@ -0,0 +1,316 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.GLMMSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified DataFrame.Internal.Column as DX
+import qualified DataFrame.Internal.DataFrame as DX
+import qualified Hanalyze.Model.Core as Core
+import qualified Hanalyze.MCMC.Core as Core
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.GLMM" $ do
+ -- Dataset: 3 groups × 4 obs, strong between-group signal, weak within-group noise.
+ -- True: β₀≈5, β₁≈0, u_A≈2, u_B≈0, u_C≈-2, σ²_u≈4, σ²≈small → ICC≈high.
+ let df = DX.fromNamedColumns
+ [ ("x", DX.fromList ([1,2,3,4, 1,2,3,4, 1,2,3,4] :: [Double]))
+ , ("y", DX.fromList ([7.1,6.9,7.0,7.0, 5.0,4.9,5.1,5.0, 3.0,2.9,3.1,3.0] :: [Double]))
+ , ("group", DX.fromList (["A","A","A","A","B","B","B","B","C","C","C","C"] :: [T.Text])) ]
+ res = fitLMEDataFrame [("x", 1)] "group" "y" df
+
+ it "returns Just for valid input" $
+ res `shouldSatisfy` (\r -> case r of { Just _ -> True; Nothing -> False })
+
+ it "ICC is in [0, 1]" $
+ maybe (expectationFailure "expected Just") (\r ->
+ glmmICC r `shouldSatisfy` (\v -> v >= 0 && v <= 1)) res
+
+ it "ICC is high for strongly grouped data" $
+ maybe (expectationFailure "expected Just") (\r ->
+ glmmICC r `shouldSatisfy` (> 0.9)) res
+
+ it "random variance is positive" $
+ maybe (expectationFailure "expected Just") (\r ->
+ glmmRandVar r `shouldSatisfy` (> 0)) res
+
+ it "residual variance is positive" $
+ maybe (expectationFailure "expected Just") (\r ->
+ glmmResidVar r `shouldSatisfy` (> 0)) res
+
+ it "BLUP count equals number of groups" $
+ maybe (expectationFailure "expected Just") (\r ->
+ V.length (glmmBLUPs r) `shouldBe` 3) res
+
+ it "group labels are sorted" $
+ case res of
+ Just r -> glmmGroups r `shouldBe` V.fromList ["A","B","C"]
+ Nothing -> expectationFailure "expected Just"
+
+ it "returns Nothing for missing column" $
+ fitLMEDataFrame [("x", 1)] "group" "missing" df
+ `shouldSatisfy` (\r -> case r of { Nothing -> True; Just _ -> False })
+
+ describe "Hanalyze.Model.GLMM general random effects (Phase 48)" $ do
+ let approxG tol a b = abs (a - b) < tol
+ buildG gvec =
+ let lbls = V.fromList . sort
+ . foldr (\x acc -> if x `elem` acc then acc else x:acc) []
+ $ V.toList gvec
+ idxF x = maybe 0 id (V.elemIndex x lbls)
+ in (lbls, V.map idxF gvec)
+
+ -- (1) r=1, intercept-only Z must reproduce scalar fitLME exactly.
+ describe "reduces to fitLME for intercept-only random effect (r=1)" $ do
+ let xMat = LA.fromLists
+ [[1,1],[1,2],[1,3],[1,4],
+ [1,1],[1,2],[1,3],[1,4],
+ [1,1],[1,2],[1,3],[1,4]] :: LA.Matrix Double
+ zOne = LA.fromLists (replicate 12 [1.0]) :: LA.Matrix Double
+ y = LA.fromList [7.1,6.9,7.0,7.0, 5.0,4.9,5.1,5.0, 3.0,2.9,3.1,3.0]
+ gv = V.fromList (["A","A","A","A","B","B","B","B","C","C","C","C"] :: [T.Text])
+ (lbls, idx) = buildG gv
+ sizes = V.fromList [ V.length (V.filter (== j) idx) | j <- [0..V.length lbls - 1] ]
+ scal = fitLME xMat y idx lbls sizes
+ gen = fitLMEGeneral xMat zOne y idx lbls
+
+ it "random variance matches glmmRandVar" $
+ LA.atIndex (reRandCov gen) (0,0) `shouldSatisfy` approxG 1e-6 (glmmRandVar scal)
+ it "residual variance matches glmmResidVar" $
+ reResidVar gen `shouldSatisfy` approxG 1e-6 (glmmResidVar scal)
+ it "fixed-effect β matches glmmFixed" $
+ LA.toList (Core.coefficientsV (reFixed gen))
+ `shouldSatisfy` (\bs -> and (zipWith (approxG 1e-6) bs
+ (LA.toList (Core.coefficientsV (glmmFixed scal)))))
+ it "BLUPs match glmmBLUPs (q×1 column)" $
+ LA.toList (LA.flatten (reBLUPs gen))
+ `shouldSatisfy` (\bs -> and (zipWith (approxG 1e-6) bs (V.toList (glmmBLUPs scal))))
+ it "group labels preserved" $
+ reGroups gen `shouldBe` V.fromList ["A","B","C"]
+
+ -- (2) random slope: 4 groups with known per-group intercept+slope deviations.
+ -- Fixed mean β=[2,3]; group lines differ in both intercept and slope.
+ describe "recovers random slope structure (r=2)" $ do
+ let oneGrp = [[1,0],[1,1],[1,2],[1,3],[1,4]] :: [[Double]]
+ xMat = LA.fromLists (concat (replicate 4 oneGrp)) :: LA.Matrix Double
+ zMat = xMat -- (1 + x | g)
+ -- A: 3+3.5x B: 1+2.5x C: 2.5+2.7x D: 1.5+3.3x (+tiny noise)
+ y = LA.fromList
+ [ 3.01, 6.49, 10.01, 13.49, 17.00 -- A
+ , 1.01, 3.49, 6.01, 8.49, 11.00 -- B
+ , 2.51, 5.19, 7.91, 10.59, 13.30 -- C
+ , 1.51, 4.79, 8.11, 11.39, 14.70 ] -- D
+ gv = V.fromList (concatMap (replicate 5) (["A","B","C","D"] :: [T.Text]))
+ (lbls, idx) = buildG gv
+ gen = fitLMEGeneral xMat zMat y idx lbls
+ beta = LA.toList (Core.coefficientsV (reFixed gen))
+
+ it "covariance G is 2×2" $
+ LA.size (reRandCov gen) `shouldBe` (2, 2)
+ it "BLUP matrix is q×2 (4 groups × intercept+slope)" $
+ LA.size (reBLUPs gen) `shouldBe` (4, 2)
+ it "residual variance positive" $
+ reResidVar gen `shouldSatisfy` (> 0)
+ it "G diagonal (variances) positive" $
+ (LA.atIndex (reRandCov gen) (0,0) > 0 && LA.atIndex (reRandCov gen) (1,1) > 0)
+ `shouldBe` True
+ it "fixed-effect β recovers population mean [2, 3]" $
+ beta `shouldSatisfy` (\b -> approxG 0.3 (b !! 0) 2.0 && approxG 0.3 (b !! 1) 3.0)
+ it "BLUP intercept ordering: A > B" $
+ (LA.atIndex (reBLUPs gen) (0,0) > LA.atIndex (reBLUPs gen) (1,0)) `shouldBe` True
+ it "BLUP slope ordering: A > B" $
+ (LA.atIndex (reBLUPs gen) (0,1) > LA.atIndex (reBLUPs gen) (1,1)) `shouldBe` True
+
+ describe "Hanalyze.Model.GLMM general random effects non-Gaussian (Phase 48 A2)" $ do
+ let approxG tol a b = abs (a - b) < tol
+ buildG gvec =
+ let lbls = V.fromList . sort
+ . foldr (\x acc -> if x `elem` acc then acc else x:acc) []
+ $ V.toList gvec
+ idxF x = maybe 0 id (V.elemIndex x lbls)
+ in (lbls, V.map idxF gvec)
+
+ -- (1) r=1, intercept-only Z reproduces scalar fitGLMM (same MLE fixed point).
+ describe "reduces to fitGLMM for intercept-only random effect (r=1)" $ do
+ let xMat = LA.fromLists (concatMap (\d -> [[1,d]]) ([1,2,3,4,5] ++ [1,2,3,4,5] ++ [1,2,3,4,5]))
+ :: LA.Matrix Double
+ zOne = LA.fromLists (replicate 15 [1.0]) :: LA.Matrix Double
+ gv = V.fromList (["A","A","A","A","A","B","B","B","B","B","C","C","C","C","C"] :: [T.Text])
+ (lbls, idx) = buildG gv
+ sizes = V.fromList [ V.length (V.filter (== j) idx) | j <- [0..V.length lbls - 1] ]
+
+ describe "Binomial / Logit" $ do
+ let y = LA.fromList [1,1,1,1,1, 1,1,0,1,0, 0,0,0,1,0]
+ scal = fitGLMM Binomial Logit xMat y idx lbls sizes
+ gen = fitGLMMGeneral Binomial Logit xMat zOne y idx lbls
+ it "random variance matches glmmRandVar" $
+ LA.atIndex (reRandCov gen) (0,0) `shouldSatisfy` approxG 1e-4 (glmmRandVar scal)
+ it "fixed-effect β matches glmmFixed" $
+ LA.toList (Core.coefficientsV (reFixed gen))
+ `shouldSatisfy` (\bs -> and (zipWith (approxG 1e-4) bs
+ (LA.toList (Core.coefficientsV (glmmFixed scal)))))
+ it "BLUPs match glmmBLUPs" $
+ LA.toList (LA.flatten (reBLUPs gen))
+ `shouldSatisfy` (\bs -> and (zipWith (approxG 1e-4) bs (V.toList (glmmBLUPs scal))))
+ it "residual variance is 1.0 (non-Gaussian convention)" $
+ reResidVar gen `shouldSatisfy` approxG 1e-12 1.0
+
+ describe "Poisson / Log" $ do
+ let y = LA.fromList [15,18,22,20,25, 7,9,8,10,11, 2,3,2,4,3]
+ scal = fitGLMM Poisson Log xMat y idx lbls sizes
+ gen = fitGLMMGeneral Poisson Log xMat zOne y idx lbls
+ it "random variance matches glmmRandVar" $
+ LA.atIndex (reRandCov gen) (0,0) `shouldSatisfy` approxG 1e-4 (glmmRandVar scal)
+ it "fixed-effect β matches glmmFixed" $
+ LA.toList (Core.coefficientsV (reFixed gen))
+ `shouldSatisfy` (\bs -> and (zipWith (approxG 1e-4) bs
+ (LA.toList (Core.coefficientsV (glmmFixed scal)))))
+
+ -- (2) random slope (r=2): structure + finiteness sanity for a Poisson GLMM.
+ describe "random slope structure (r=2, Poisson)" $ do
+ let oneGrp = [[1,0],[1,1],[1,2],[1,3],[1,4]] :: [[Double]]
+ xMat = LA.fromLists (concat (replicate 3 oneGrp)) :: LA.Matrix Double
+ zMat = xMat
+ -- region X: steep growth, Y: moderate, Z: flat (slope differs by group)
+ y = LA.fromList [ 3, 5, 9, 16, 28 -- X (steep)
+ , 4, 6, 8, 11, 15 -- Y (moderate)
+ , 5, 5, 6, 6, 7 ] -- Z (flat)
+ gv = V.fromList (concatMap (replicate 5) (["X","Y","Z"] :: [T.Text]))
+ (lbls, idx) = buildG gv
+ gen = fitGLMMGeneral Poisson Log xMat zMat y idx lbls
+ it "covariance G is 2×2" $
+ LA.size (reRandCov gen) `shouldBe` (2, 2)
+ it "BLUP matrix is q×2 (3 groups × intercept+slope)" $
+ LA.size (reBLUPs gen) `shouldBe` (3, 2)
+ it "G diagonal variances positive" $
+ (LA.atIndex (reRandCov gen) (0,0) > 0 && LA.atIndex (reRandCov gen) (1,1) > 0)
+ `shouldBe` True
+ it "fixed-effect β finite" $
+ LA.toList (Core.coefficientsV (reFixed gen))
+ `shouldSatisfy` all (not . isNaN)
+ it "BLUP slope ordering: X (steep) > Z (flat)" $
+ (LA.atIndex (reBLUPs gen) (0,1) > LA.atIndex (reBLUPs gen) (2,1)) `shouldBe` True
+
+ describe "Hanalyze.Model.GLMM (non-Gaussian)" $ do
+ -- Binomial GLMM: 3 hospitals, binary outcome (treatment success)
+ -- Strong hospital effect; within each hospital, dose → higher success rate.
+ -- True: u_A ≈ +1, u_B ≈ 0, u_C ≈ -1 (on logit scale)
+ let dfBin = DX.fromNamedColumns
+ [ ("dose", DX.fromList ([1,2,3,4,5, 1,2,3,4,5, 1,2,3,4,5] :: [Double]))
+ , ("success", DX.fromList ([1,1,1,1,1, 1,1,0,1,0, 0,0,0,1,0] :: [Double]))
+ , ("hospital", DX.fromList (["A","A","A","A","A","B","B","B","B","B","C","C","C","C","C"] :: [T.Text])) ]
+ resBin = fitGLMMDataFrame Binomial Logit [("dose", 1)] "hospital" "success" dfBin
+
+ it "Binomial GLMM returns Just" $
+ resBin `shouldSatisfy` (\r -> case r of { Just _ -> True; Nothing -> False })
+
+ it "Binomial ICC in [0, 1]" $
+ maybe (expectationFailure "expected Just") (\r ->
+ glmmICC r `shouldSatisfy` (\v -> v >= 0 && v <= 1)) resBin
+
+ it "Binomial σ²_u is positive" $
+ maybe (expectationFailure "expected Just") (\r ->
+ glmmRandVar r `shouldSatisfy` (> 0)) resBin
+
+ -- Poisson GLMM: 3 regions, count outcome (events per month)
+ -- True: β₀ on log scale ≈ 2 (≈7 events baseline), u differs by region.
+ let dfPois = DX.fromNamedColumns
+ [ ("time", DX.fromList ([1,2,3,4,5, 1,2,3,4,5, 1,2,3,4,5] :: [Double]))
+ , ("count", DX.fromList ([15,18,22,20,25, 7,9,8,10,11, 2,3,2,4,3] :: [Double]))
+ , ("region", DX.fromList (["X","X","X","X","X","Y","Y","Y","Y","Y","Z","Z","Z","Z","Z"] :: [T.Text])) ]
+ resPois = fitGLMMDataFrame Poisson Log [("time", 1)] "region" "count" dfPois
+
+ it "Poisson GLMM returns Just" $
+ resPois `shouldSatisfy` (\r -> case r of { Just _ -> True; Nothing -> False })
+
+ it "Poisson σ²_u is positive" $
+ maybe (expectationFailure "expected Just") (\r ->
+ glmmRandVar r `shouldSatisfy` (> 0)) resPois
+
+ it "Poisson ICC in [0, 1]" $
+ maybe (expectationFailure "expected Just") (\r ->
+ glmmICC r `shouldSatisfy` (\v -> v >= 0 && v <= 1)) resPois
+
+ -- ─────────────────────────────────────────────────────────────────────
+
+ describe "Hanalyze.Model.GLMM SE (request/100)" $ do
+ -- Same fixture as the GLMM tests above (3 groups × 4 obs).
+ -- design X = [1, x] over the same 12 rows.
+ let xMat12 = LA.matrix 2
+ ( concatMap (\v -> [1, v])
+ [1,2,3,4,1,2,3,4,1,2,3,4 :: Double] )
+ yVec12 = LA.fromList
+ [7.1,6.9,7.0,7.0, 5.0,4.9,5.1,5.0, 3.0,2.9,3.1,3.0]
+ gVec12 = V.fromList
+ ["A","A","A","A","B","B","B","B","C","C","C","C" :: T.Text]
+ -- Inline group construction (mirrors Hanalyze.Model.GLMM.buildGroups
+ -- which is currently internal).
+ gLabels12 = V.fromList ["A", "B", "C"] :: V.Vector T.Text
+ gIdx12 = V.map
+ (\g -> case V.elemIndex g gLabels12 of
+ Just i -> i
+ Nothing -> 0)
+ gVec12
+ gSizes12 = V.fromList [4, 4, 4]
+ glmmRes = fitLME xMat12 yVec12 gIdx12 gLabels12 gSizes12
+ idx12 = gIdx12
+
+ it "glmmFixedSE: returns one SE per coefficient (length p)" $ do
+ let ses = glmmFixedSE xMat12 idx12 glmmRes
+ LA.size ses `shouldBe` LA.cols xMat12
+
+ it "glmmFixedSE: all SEs are positive" $ do
+ let ses = glmmFixedSE xMat12 idx12 glmmRes
+ mapM_ (\v -> v `shouldSatisfy` (> 0)) (LA.toList ses)
+
+ it "glmmFixedSE: σ_u → 0 reduces to OLS SE within tolerance" $ do
+ -- Force σ²_u to 0 (no random effects → OLS).
+ let resOLS = glmmRes { glmmRandVar = 0 }
+ sesG = glmmFixedSE xMat12 idx12 resOLS
+ -- Reference OLS SE from σ² (XᵀX)⁻¹.
+ xtx = LA.tr xMat12 LA.<> xMat12
+ covOLS = LA.scale (glmmResidVar resOLS) (LA.inv xtx)
+ sesOLS = LA.fromList
+ [ sqrt (LA.atIndex covOLS (i, i))
+ | i <- [0 .. LA.cols xMat12 - 1] ]
+ LA.norm_Inf (sesG - sesOLS) `shouldSatisfy` (< 1e-9)
+
+ it "glmmBLUPSE: one entry per group, all positive" $ do
+ let ses = glmmBLUPSE idx12 glmmRes
+ V.length ses `shouldBe` V.length (glmmGroups glmmRes)
+ mapM_ (\v -> v `shouldSatisfy` (> 0)) (V.toList ses)
+
+ it "glmmBLUPSE: shrinkage formula (1/σ²_u + n_j/σ²)⁻¹^½" $ do
+ let ses = glmmBLUPSE idx12 glmmRes
+ sig2u = glmmRandVar glmmRes
+ sig2 = glmmResidVar glmmRes
+ -- Group sizes: A=4, B=4, C=4 (balanced design)
+ expected = sqrt (1.0 / (1.0 / sig2u + 4.0 / sig2))
+ mapM_ (\(_, v) -> abs (v - expected) `shouldSatisfy` (< 1e-9))
+ (zip [0 :: Int ..] (V.toList ses))
+
+ -- ========================================================================
+ -- NUTS streaming callback (Phase 9.1a)
+ -- ========================================================================
diff --git a/test/Hanalyze/Model/GLMSpec.hs b/test/Hanalyze/Model/GLMSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/GLMSpec.hs
@@ -0,0 +1,112 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.GLMSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.Core as Core
+import qualified Hanalyze.Model.GLM as GLM
+import qualified Hanalyze.MCMC.Core as Core
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.GLM IRLS 収束 (28d1feb7 回帰の防止)" $ do
+ -- ★かつて runIRLS の converge が初回 dLL=0 (seed llP=ll(β0) と llHere=ll(β0) が一致)
+ -- で IRLS を 1 ステップで早期停止し、 μ̂ が系統的に過大だった (28d1feb7 perf リライトの
+ -- 回帰)。 真の MLE はスコア方程式 Xᵀ(y-μ̂)=0 を満たすので、 それを外部非依存オラクル
+ -- として検証する (statsmodels の β とも突合)。
+ let xsP = [1,2,3,4,5,6,7,8] :: [Double]
+ ysP = [1,1,3,4,7,10,15,22] :: [Double]
+ xMatP = LA.matrix 2 (concatMap (\x -> [1, x]) xsP)
+ yVecP = LA.fromList ysP
+ (frP, _) = GLM.fitGLMFull GLM.Poisson GLM.Log xMatP yVecP
+ betaP = LA.toList (head (LA.toColumns (Core.coefficients frP)))
+ muP = head (LA.toColumns (Core.fitted frP))
+
+ it "Poisson/Log: スコア方程式 Xᵀ(y-μ̂)=0 (真の MLE に収束)" $ do
+ let score = LA.tr xMatP LA.#> (yVecP - muP)
+ LA.norm_Inf score `shouldSatisfy` (< 1e-6)
+
+ it "Poisson/Log: 係数が statsmodels GLM と一致 (-0.33398, 0.43288)" $ do
+ abs (betaP !! 0 - (-0.33397763)) `shouldSatisfy` (< 1e-4)
+ abs (betaP !! 1 - 0.43287516) `shouldSatisfy` (< 1e-4)
+
+ it "Binomial/Logit: スコア方程式 Xᵀ(y-μ̂)=0 (分離しない data で MLE)" $ do
+ let xsB = [0,1,2,3,4,5,6,7,8,9] :: [Double]
+ ysB = [0,0,0,0,1,0,1,1,1,1] :: [Double]
+ xMatB = LA.matrix 2 (concatMap (\x -> [1, x]) xsB)
+ yVecB = LA.fromList ysB
+ (frB, _) = GLM.fitGLMFull GLM.Binomial GLM.Logit xMatB yVecB
+ muB = head (LA.toColumns (Core.fitted frB))
+ score = LA.tr xMatB LA.#> (yVecB - muB)
+ LA.norm_Inf score `shouldSatisfy` (< 1e-6)
+
+ describe "Hanalyze.Model.GLM diagnostics (request/090-AB)" $ do
+ let xsG = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] :: [Double]
+ ysG = [1.1, 2.9, 5.2, 6.8, 9.1, 11.0, 13.2, 14.8, 17.0, 19.1] :: [Double]
+ xMatG = LA.matrix 2 (concatMap (\x -> [1, x]) xsG)
+ yVecG = LA.fromList ysG
+ (frG, sigmaG) = GLM.fitGLMFull GLM.Gaussian GLM.Identity xMatG yVecG
+ betaG = head (LA.toColumns (Core.coefficients frG))
+ muVG = head (LA.toColumns (Core.fitted frG))
+
+ it "glmPearsonResiduals (Gaussian, V=1) == raw residuals" $ do
+ let pr = GLM.glmPearsonResiduals GLM.Gaussian yVecG muVG
+ rr = yVecG - muVG
+ LA.norm_2 (pr - rr) `shouldSatisfy` (< 1e-9)
+
+ it "glmDevianceResiduals (Gaussian) == sign(y-μ)·|y-μ|" $ do
+ let dr = GLM.glmDevianceResiduals GLM.Gaussian yVecG muVG
+ ref = LA.fromList
+ [ signum (y - m) * abs (y - m)
+ | (y, m) <- zip ysG (LA.toList muVG) ]
+ LA.norm_2 (dr - ref) `shouldSatisfy` (< 1e-9)
+
+ it "glmVariance: Binomial μ(1-μ); Poisson μ" $ do
+ GLM.glmVariance GLM.Binomial 0.3 `shouldBe` 0.3 * 0.7
+ GLM.glmVariance GLM.Poisson 4.0 `shouldBe` 4.0
+
+ it "predictGlmEtaWithSE: η = xᵀβ, SE > 0" $ do
+ let xNew = LA.fromList [1, 5.0]
+ (eta, se) = GLM.predictGlmEtaWithSE betaG sigmaG xNew
+ eta `shouldSatisfy` (\e -> abs (e - (1 + 2 * 5.0)) < 0.5)
+ se `shouldSatisfy` (> 0)
+ se `shouldSatisfy` (< 1)
+
+ it "predictGlmMuWithCI (Identity): half-width ≈ 1.96·SE" $ do
+ let xNew = LA.fromList [1, 4.5]
+ ci = GLM.predictGlmMuWithCI GLM.Identity 0.95 betaG sigmaG xNew
+ (_, se) = GLM.predictGlmEtaWithSE betaG sigmaG xNew
+ halfW = (GLM.gpHi ci - GLM.gpLo ci) / 2
+ abs (halfW - 1.96 * se) `shouldSatisfy` (< 1e-2)
+
+ it "predictGlmMuWithCI (Logit): CI stays in (0,1)" $ do
+ let xs2 = LA.matrix 2 (concatMap (\i -> [1, fromIntegral (i :: Int)]) [0..9])
+ ys2 = LA.fromList [0,1,0,1,0,1,0,1,0,1]
+ (_, sigma2) = GLM.fitGLMFull GLM.Binomial GLM.Logit xs2 ys2
+ beta2 = LA.fromList [0.0, 0.05]
+ xNew = LA.fromList [1, 5.0]
+ ci = GLM.predictGlmMuWithCI GLM.Logit 0.95 beta2 sigma2 xNew
+ GLM.gpMu ci `shouldSatisfy` (\v -> v > 0 && v < 1)
+ GLM.gpLo ci `shouldSatisfy` (\v -> v >= 0)
+ GLM.gpHi ci `shouldSatisfy` (\v -> v <= 1)
+ GLM.gpLo ci `shouldSatisfy` (< GLM.gpHi ci)
diff --git a/test/Hanalyze/Model/GPRobustSpec.hs b/test/Hanalyze/Model/GPRobustSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/GPRobustSpec.hs
@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.GPRobustSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Model.GP as GP
+import qualified Hanalyze.Model.GPRobust as GPR
+import qualified Hanalyze.Model.GP as GP
+import qualified Hanalyze.Model.GPRobust as GPR
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.GPRobust" $ do
+ it "Cauchy GP is more accurate than Gaussian GP under outliers" $ do
+ let trueF x = sin x
+ xs = [0.0, 0.5 .. 6.0]
+ cleanY = map trueF xs
+ -- Inject outlier at index 5
+ ys = zipWith (\i y -> if i == 5 then y + 5 else y)
+ [0::Int ..] cleanY
+ hp = GP.GPParams 1.0 1.0 0.05 1.0 Nothing
+ gpRes = GP.fitGP (GP.GPModel GP.RBF hp) xs ys xs
+ gaussRMSE = sqrt (sum [ (a - b) ^ (2::Int)
+ | (a, b) <- zip cleanY (GP.gpMean gpRes) ]
+ / fromIntegral (length xs))
+ cauchyFit = GPR.fitGPRobust GP.RBF hp (GPR.RCauchy 0.5) xs ys
+ cauchyPred = GPR.predictGPRobust cauchyFit xs
+ cauchyRMSE = sqrt (sum [ (a - b) ^ (2::Int)
+ | (a, (b, _)) <- zip cleanY cauchyPred ]
+ / fromIntegral (length xs))
+ cauchyRMSE `shouldSatisfy` (< gaussRMSE)
+
+ it "IRLS converges in finite iterations" $ do
+ let xs = [0.0, 1.0, 2.0, 3.0, 4.0]
+ ys = [0.1, 1.05, 1.95, 2.9, 4.1]
+ hp = GP.GPParams 1.0 1.0 0.1 1.0 Nothing
+ fit = GPR.fitGPRobust GP.RBF hp (GPR.RStudentT 4 0.5) xs ys
+ GPR.rgpIters fit `shouldSatisfy` (\n -> n > 0 && n <= 50)
diff --git a/test/Hanalyze/Model/GradientBoostingSpec.hs b/test/Hanalyze/Model/GradientBoostingSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/GradientBoostingSpec.hs
@@ -0,0 +1,64 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.GradientBoostingSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Unboxed as VU
+import qualified Hanalyze.Model.GradientBoosting as GB
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.GradientBoosting (Phase 34-A1)" $ do
+ let xs = [[fromIntegral i / 5 - 1] | i <- [0 :: Int .. 19]]
+ xMat = LA.fromLists xs
+ ys = VU.fromList [2 * (fromIntegral i / 5 - 1) + 1
+ | i <- [0 :: Int .. 19]]
+ -- 二値分類: x < 0 → 0, x >= 0 → 1
+ yCls = VU.fromList ([0,0,0,0,0,0,0,0,0,0,
+ 1,1,1,1,1,1,1,1,1,1] :: [Int])
+ it "fitGBRegressor: 線形データに収束 (MSE 低)" $ do
+ let cfg = GB.defaultGBM { GB.gbNRounds = 100
+ , GB.gbMaxDepth = 3
+ , GB.gbLearnRate = 0.1 }
+ gb = GB.fitGBRegressor cfg xMat ys
+ yhat = GB.predictGBR gb xMat
+ mse = VU.sum (VU.zipWith (\a b -> (a - b)^(2::Int)) yhat ys)
+ / fromIntegral (VU.length ys)
+ mse `shouldSatisfy` (< 0.05)
+ it "fitGBRegressor: gbrTrees の長さ = gbNRounds" $ do
+ let cfg = GB.defaultGBM { GB.gbNRounds = 20 }
+ gb = GB.fitGBRegressor cfg xMat ys
+ length (GB.gbrTrees gb) `shouldBe` 20
+ it "fitGBClassifier: 線形分離可能データで訓練精度 100%" $ do
+ let cfg = GB.defaultGBM { GB.gbNRounds = 50
+ , GB.gbMaxDepth = 2 }
+ gb = GB.fitGBClassifier cfg xMat yCls
+ yhat = GB.predictGBC gb xMat
+ correct = VU.length (VU.filter id
+ (VU.zipWith (==) yhat yCls))
+ correct `shouldBe` VU.length yCls
+ it "predictGBCProbs: 全行 [0,1] 範囲" $ do
+ let cfg = GB.defaultGBM { GB.gbNRounds = 20 }
+ gb = GB.fitGBClassifier cfg xMat yCls
+ ps = GB.predictGBCProbs gb xMat
+ VU.all (\p -> p >= 0 && p <= 1) ps `shouldBe` True
diff --git a/test/Hanalyze/Model/HBM/InterpSpec.hs b/test/Hanalyze/Model/HBM/InterpSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/HBM/InterpSpec.hs
@@ -0,0 +1,467 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.HBM.InterpSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Map.Strict as M
+import qualified Hanalyze.Model.HBM as HBM
+import qualified Hanalyze.Model.HBM.Interp as HI
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.HBM.Interp categorical 列 (Phase 41)" $ do
+ it "colDoubles: Numeric はそのまま、 Factor は code を Double 化" $ do
+ HI.colDoubles (HI.Numeric [1.0, 2.5]) `shouldBe` [1.0, 2.5]
+ HI.colDoubles (HI.Factor ["a", "b"] [0, 1, 0]) `shouldBe` [0.0, 1.0, 0.0]
+ it "colLevels: Factor は level 辞書、 Numeric は Nothing" $ do
+ HI.colLevels (HI.Factor ["a", "b"] [0, 1]) `shouldBe` Just ["a", "b"]
+ HI.colLevels (HI.Numeric [1.0]) `shouldBe` Nothing
+ it "groupSuffixFor: 安全な level は可読 suffix '_versicolor'" $
+ HI.groupSuffixFor (Just (HI.Factor ["setosa", "versicolor"] [0, 1])) 1
+ `shouldBe` "_versicolor"
+ it "groupSuffixFor: 不安全な level (空白/記号) は数値 code に fallback" $
+ HI.groupSuffixFor (Just (HI.Factor ["A/B", "C D"] [0, 1])) 0 `shouldBe` "_0"
+ it "groupSuffixFor: 数値先頭 level も識別子規則違反で fallback" $
+ HI.groupSuffixFor (Just (HI.Factor ["1cat", "2dog"] [0, 1])) 0 `shouldBe` "_0"
+ it "groupSuffixFor: Numeric / Nothing は従来の数値 suffix" $ do
+ HI.groupSuffixFor (Just (HI.Numeric [0, 1, 2])) 2 `shouldBe` "_2"
+ HI.groupSuffixFor Nothing 3 `shouldBe` "_3"
+ it "groupSuffixFor: 範囲外 code は数値 fallback" $
+ HI.groupSuffixFor (Just (HI.Factor ["a"] [0])) 5 `shouldBe` "_5"
+
+ describe "Hanalyze.Model.HBM.Interp categorical observe (Phase 41.5)" $ do
+ -- 2 値応答列 outcome = yes/no を出現順 code (yes=0, no=1) で持つ factor。
+ let dmF = M.fromList [("outcome", HI.Factor ["yes", "no"] [0, 1, 0, 1])]
+ -- do { p <- Beta 1 1; observe "y" (Bernoulli p) 'outcome' }
+ beta11 = EApp (EApp (EVar "Beta") (ELit (LNumber 1))) (ELit (LNumber 1))
+ bern = EApp (EVar "Bernoulli") (EVar "p")
+ observeOn col = EApp (EApp (EApp (EVar "observe") (ELit (LText "y"))) bern) (ECol col)
+ modelOn col = EDo [ DoBind "p" beta11, DoExpr (observeOn col) ]
+ (EApp (EVar "pure") (ELit (LNumber 0)))
+ isRight' = either (const False) (const True)
+ it "factor 観測列の値は code として渡る (= 2 値 0/1)" $
+ HI.lookupDoubles "outcome" dmF `shouldBe` [0.0, 1.0, 0.0, 1.0]
+ it "validateAst は factor 列の Bernoulli observe を受理する" $
+ HI.validateAst [] (modelOn "outcome") dmF `shouldSatisfy` isRight'
+ it "validateAst は存在しない観測列は弾く (factor も例外でない)" $
+ HI.validateAst [] (modelOn "nope") dmF `shouldSatisfy` (not . isRight')
+
+ describe "Hanalyze.Model.HBM.Interp 多値 categorical 応答 (Phase 42)" $ do
+ let emptyEnv = M.empty :: HI.EnvA Double
+ emptyDM = M.empty :: HI.DataMap
+ evalD e = HI.evalDist emptyEnv emptyDM Nothing e :: Err (HBM.Distribution Double)
+ evalV e = HI.evalValue emptyEnv emptyDM Nothing e :: Err (HI.Value Double)
+ num d = ELit (LNumber d)
+ -- Categorical [0.2, 0.3, 0.5]
+ catE = EApp (EVar "Categorical") (EList [num 0.2, num 0.3, num 0.5])
+ -- OrderedLogistic 0.0 [-1, 1]
+ olE = EApp (EApp (EVar "OrderedLogistic") (num 0.0))
+ (EList [ENeg (num 1), num 1])
+ isRight' = either (const False) (const True)
+ it "evalValue: EList を VList に評価する (Phase 42 list 引数の土台)" $
+ (case evalV (EList [num 1, num 2, num 3]) of
+ Right (HI.VList xs) -> length xs == 3
+ _ -> False) `shouldBe` True
+ it "asList: VList は要素列を返し、 非 list はエラー" $ do
+ isRight' (HI.asList (HI.VList [HI.VNum (1 :: Double), HI.VNum 2])) `shouldBe` True
+ isRight' (HI.asList (HI.VNum (1 :: Double))) `shouldBe` False
+ it "evalDist: Categorical [probs] を構築する" $
+ show (evalD catE)
+ `shouldBe` show (Right (HBM.Categorical [0.2, 0.3, 0.5])
+ :: Err (HBM.Distribution Double))
+ it "evalDist: OrderedLogistic eta [cuts] を構築する" $
+ show (evalD olE)
+ `shouldBe` show (Right (HBM.OrderedLogistic 0.0 [-1, 1])
+ :: Err (HBM.Distribution Double))
+ it "evalDist: Categorical の probs に非リスト (スカラ) を渡すとエラー" $
+ evalD (EApp (EVar "Categorical") (num 0.5)) `shouldSatisfy` (not . isRight')
+
+ -- 3 水準 factor 応答列 grade = A/B/C を出現順 code (A=0,B=1,C=2) で観測。
+ let dm3 = M.fromList [("grade", HI.Factor ["A", "B", "C"] [0, 1, 2, 0, 1, 2])]
+ normal01 = EApp (EApp (EVar "Normal") (num 0)) (num 1)
+ olObs = EApp (EApp (EVar "OrderedLogistic") (EVar "eta"))
+ (EList [ENeg (num 1), num 1])
+ observeOL col = EApp (EApp (EApp (EVar "observe") (ELit (LText "y"))) olObs) (ECol col)
+ modelOL col = EDo [ DoBind "eta" normal01, DoExpr (observeOL col) ]
+ (EApp (EVar "pure") (num 0))
+ it "validateAst: 3 水準 factor 列の OrderedLogistic observe を受理する" $
+ HI.validateAst [] (modelOL "grade") dm3 `shouldSatisfy` isRight'
+
+ describe "Hanalyze.Model.HBM.Interp list 値 latent (Phase 43)" $ do
+ let num d = ELit (LNumber d)
+ isRight' = either (const False) (const True)
+ -- 全ノード名 (kind 問わず): combinator 内部 latent が実際に Model に
+ -- 登録されたかの証明に使う。
+ allNames g = sort [ HBM.nodeName n | n <- HBM.mgNodes g ]
+ -- 3 水準 factor 応答列。
+ dm = M.fromList
+ [ ("grade", HI.Factor ["A", "B", "C"] [0, 1, 2, 0, 1, 2])
+ , ("choice", HI.Factor ["x", "y", "z"] [0, 1, 2, 0, 1, 2])
+ ]
+ -- orderedCuts "cut" 2 (-2) 1
+ ocE = EApp (EApp (EApp (EApp (EVar "orderedCuts") (ELit (LText "cut")))
+ (num 2)) (ENeg (num 2))) (num 1)
+ -- dirichlet "pi" [1, 1, 1]
+ dirE = EApp (EApp (EVar "dirichlet") (ELit (LText "pi")))
+ (EList [num 1, num 1, num 1])
+ normal05 = EApp (EApp (EVar "Normal") (num 0)) (num 5)
+ olD = EApp (EApp (EVar "OrderedLogistic") (EVar "alpha")) (EVar "cuts")
+ catD = EApp (EVar "Categorical") (EVar "probs")
+ observeE nm dist col =
+ EApp (EApp (EApp (EVar "observe") (ELit (LText nm))) dist) (ECol col)
+ -- alpha <- Normal 0 5; cuts <- orderedCuts "cut" 2 (-2) 1;
+ -- observe "y" (OrderedLogistic alpha cuts) 'grade'
+ modelCuts = EDo [ DoBind "alpha" normal05
+ , DoBind "cuts" ocE
+ , DoExpr (observeE "y" olD "grade") ]
+ (EApp (EVar "pure") (num 0))
+ -- probs <- dirichlet "pi" [1,1,1]; observe "z" (Categorical probs) 'choice'
+ modelDir = EDo [ DoBind "probs" dirE
+ , DoExpr (observeE "z" catD "choice") ]
+ (EApp (EVar "pure") (num 0))
+
+ -- Phase 43.1: latent cuts つき OrderedLogistic
+ it "validateAst: cuts <- orderedCuts の list 値 bind を受理する" $
+ HI.validateAst [] modelCuts dm `shouldSatisfy` isRight'
+ it "interpStmts: orderedCuts が Model モナドで走り内部 latent cut_d_2 が出る" $ do
+ let Right stmts = HI.validateAst [] modelCuts dm
+ g = HBM.buildModelGraph (HI.interpStmts [] dm stmts)
+ -- orderedCuts "cut" 2 …: cut_c_1/cut_c_2 (det) + cut_d_2 (HalfNormal latent)。
+ -- cut_d_2 の存在が combinator 実行の証明 (固定リテラルでは出ない)。
+ ("cut_d_2" `elem` allNames g) `shouldBe` True
+ ("alpha" `elem` allNames g) `shouldBe` True
+ it "validateAst: orderedCuts のカット数が非リテラル (変数) ならエラー" $ do
+ let bad = EApp (EApp (EApp (EApp (EVar "orderedCuts") (ELit (LText "cut")))
+ (EVar "k")) (ENeg (num 2))) (num 1)
+ m = EDo [ DoBind "cuts" bad, DoExpr (observeE "y" olD "grade") ]
+ (EApp (EVar "pure") (num 0))
+ HI.validateAst [] m dm `shouldSatisfy` (not . isRight')
+
+ -- Phase 43.2: Dirichlet prior つき Categorical
+ it "validateAst: probs <- dirichlet の list 値 bind を受理する" $
+ HI.validateAst [] modelDir dm `shouldSatisfy` isRight'
+ it "interpStmts: dirichlet が Model モナドで走り内部 latent pi_b0/pi_b1 が出る" $ do
+ let Right stmts = HI.validateAst [] modelDir dm
+ g = HBM.buildModelGraph (HI.interpStmts [] dm stmts)
+ -- dirichlet "pi" [1,1,1]: stick-breaking で pi_b0/pi_b1 (Beta latent) +
+ -- pi_0/pi_1/pi_2 (det π)。 pi_b0 の存在が combinator 実行の証明。
+ ("pi_b0" `elem` allNames g) `shouldBe` True
+ ("pi_b1" `elem` allNames g) `shouldBe` True
+ it "validateAst: dirichlet の α が長さ 1 ([..]) ならエラー" $ do
+ let bad = EApp (EApp (EVar "dirichlet") (ELit (LText "pi"))) (EList [num 1])
+ m = EDo [ DoBind "probs" bad, DoExpr (observeE "z" catD "choice") ]
+ (EApp (EVar "pure") (num 0))
+ HI.validateAst [] m dm `shouldSatisfy` (not . isRight')
+
+ -- Phase 43.3: softmax 多項ロジット
+ let evalV2 e = HI.evalValue (M.empty :: HI.EnvA Double) (M.empty :: HI.DataMap) Nothing e
+ smx es = EApp (EVar "softmax") (EList es)
+ nums r = case r of Right (HI.VList xs) -> [ x | HI.VNum x <- xs ]; _ -> []
+ catSmx = EApp (EVar "Categorical") (smx [num 0, EVar "b1", EVar "b2"])
+ mlModel = EDo [ DoBind "b1" normal05, DoBind "b2" normal05
+ , DoExpr (observeE "y" catSmx "grade") ]
+ (EApp (EVar "pure") (num 0))
+ it "softmax: 確率に正規化される (総和 ≈ 1)" $
+ (abs (sum (nums (evalV2 (smx [num 0, num 1, num 2]))) - 1) < 1e-9) `shouldBe` True
+ it "softmax: 一様入力 [0,0,0] は各クラス 1/3" $
+ all (\x -> abs (x - 1/3) < 1e-9) (nums (evalV2 (smx [num 0, num 0, num 0]))) `shouldBe` True
+ it "softmax: 大きな入力でも overflow しない (安定版 [1000,1000] → [0.5,0.5])" $
+ nums (evalV2 (smx [num 1000, num 1000]))
+ `shouldSatisfy` (\ys -> length ys == 2 && all (\y -> abs (y - 0.5) < 1e-9) ys)
+ it "softmax: 空リスト ([]) はエラー" $
+ isRight' (evalV2 (smx [])) `shouldBe` False
+ it "validateAst: Categorical (softmax [0,b1,b2]) 多項ロジットを受理する" $
+ HI.validateAst [] mlModel dm `shouldSatisfy` isRight'
+ it "interpStmts: softmax 多項ロジットが Model を構築し b1/b2 が latent に出る" $ do
+ let Right stmts = HI.validateAst [] mlModel dm
+ g = HBM.buildModelGraph (HI.interpStmts [] dm stmts)
+ (("b1" `elem` allNames g) && ("b2" `elem` allNames g)) `shouldBe` True
+
+ -- WAIC/PPC 再評価: combinator 由来 latent vector を posterior sample から
+ -- 再構築する (= NaN fallback でなく実分布が組める)。
+ it "computeObsDists: orderedCuts の cuts を sample (cut_d_2) から再構築" $ do
+ let Right stmts = HI.validateAst [] modelCuts dm
+ -- posterior 1 sample: sampled latent のみ (alpha/beta/cut_d_2)。
+ sample = M.fromList [("alpha", 0.5), ("beta", 1.0), ("cut_d_2", 2.0)]
+ dists = concat (concatMap HI.odsDists (HI.computeObsDists [] stmts dm [sample]))
+ isOL d = case d of
+ HBM.OrderedLogistic _ cs -> length cs == 2 && all (not . isNaN) cs
+ _ -> False
+ (not (null dists) && all isOL dists) `shouldBe` True
+ it "computeObsDists: dirichlet の probs を stick-breaking 再構築 (Σπ≈1)" $ do
+ let Right stmts = HI.validateAst [] modelDir dm
+ -- b0=0.3, b1=0.5 → π=[0.3, 0.35, 0.35]、 総和 1。
+ sample = M.fromList [("pi_b0", 0.3), ("pi_b1", 0.5)]
+ dists = concat (concatMap HI.odsDists (HI.computeObsDists [] stmts dm [sample]))
+ isCat d = case d of
+ HBM.Categorical ps -> length ps == 3 && abs (sum ps - 1) < 1e-9
+ _ -> False
+ (not (null dists) && all isCat dists) `shouldBe` True
+
+ describe "Hanalyze.Model.HBM.Interp MvNormal multi-column observe (Phase 44)" $ do
+ let num d = ELit (LNumber d)
+ isRight' = either (const False) (const True)
+ allNames g = sort [ HBM.nodeName n | n <- HBM.mgNodes g ]
+ -- 2 列の連続観測 (y1, y2)。 行長は 4 で揃える。
+ dm = M.fromList
+ [ ("y1", HI.Numeric [1.0, 2.0, 3.0, 4.0])
+ , ("y2", HI.Numeric [1.5, 2.5, 2.0, 3.5]) ]
+ emptyEnv = M.empty :: HI.EnvA Double
+ evalD e = HI.evalDist emptyEnv dm Nothing e :: Err (HBM.Distribution Double)
+ normal10 = EApp (EApp (EVar "Normal") (num 0)) (num 10)
+ -- MvNormal [mu1, mu2] [[1, 0.5], [0.5, 1]]
+ mvE muRow = EApp (EApp (EVar "MvNormal") muRow)
+ (EList [ EList [num 1, num 0.5], EList [num 0.5, num 1] ])
+ mvLit = mvE (EList [num 0, num 0])
+ -- observeMV "y" (MvNormal …) ['y1', 'y2']
+ observeMvE dist colE = EApp (EApp (EApp (EVar "observeMV") (ELit (LText "y"))) dist) colE
+ cols2 = EList [ECol "y1", ECol "y2"]
+ -- latent μ + 固定 cov の最短モデル
+ mvModel = EDo [ DoBind "mu1" normal10, DoBind "mu2" normal10
+ , DoExpr (observeMvE (mvE (EList [EVar "mu1", EVar "mu2"])) cols2) ]
+ (EApp (EVar "pure") (num 0))
+
+ -- Phase 44.2: evalDist MvNormal
+ it "evalDist: MvNormal [mu] [[cov]] を構築する" $
+ show (evalD mvLit)
+ `shouldBe` show (Right (HBM.MvNormal [0, 0] [[1, 0.5], [0.5, 1]])
+ :: Err (HBM.Distribution Double))
+ it "evalDist: 非正方 cov はエラー (2×3)" $
+ evalD (EApp (EApp (EVar "MvNormal") (EList [num 0, num 0]))
+ (EList [ EList [num 1, num 0, num 0], EList [num 0, num 1, num 0] ]))
+ `shouldSatisfy` (not . isRight')
+ it "evalDist: μ 長と cov 次元の不一致はエラー (μ=3, cov=2×2)" $
+ evalD (mvE (EList [num 0, num 0, num 0])) `shouldSatisfy` (not . isRight')
+
+ -- Phase 44.1: observeMV 機構
+ it "asMatrix: VList-of-VList を [[a]] に落とす + 行長不一致はエラー" $ do
+ isRight' (HI.asMatrix (HI.VList [ HI.VList [HI.VNum (1::Double), HI.VNum 2]
+ , HI.VList [HI.VNum 3, HI.VNum 4] ])) `shouldBe` True
+ isRight' (HI.asMatrix (HI.VList [ HI.VList [HI.VNum (1::Double)]
+ , HI.VList [HI.VNum 3, HI.VNum 4] ])) `shouldBe` False
+ it "validateAst: latent μ + 固定 cov の observeMV を受理する" $
+ HI.validateAst [] mvModel dm `shouldSatisfy` isRight'
+ it "interpStmts: observeMV が Model を構築し latent mu1/mu2 が出る" $ do
+ let Right stmts = HI.validateAst [] mvModel dm
+ g = HBM.buildModelGraph (HI.interpStmts [] dm stmts)
+ (("mu1" `elem` allNames g) && ("mu2" `elem` allNames g)) `shouldBe` True
+ it "validateAst: observeMV の観測列が 1 列ならエラー (scalar observe を使うべき)" $ do
+ let m = EDo [ DoBind "mu1" normal10
+ , DoExpr (observeMvE (mvE (EList [EVar "mu1"])) (EList [ECol "y1"])) ]
+ (EApp (EVar "pure") (num 0))
+ HI.validateAst [] m dm `shouldSatisfy` (not . isRight')
+ it "validateAst: observeMV の観測列が欠落しているとエラー" $ do
+ let m = EDo [ DoBind "mu1" normal10, DoBind "mu2" normal10
+ , DoExpr (observeMvE (mvE (EList [EVar "mu1", EVar "mu2"]))
+ (EList [ECol "y1", ECol "nope"])) ]
+ (EApp (EVar "pure") (num 0))
+ HI.validateAst [] m dm `shouldSatisfy` (not . isRight')
+ it "validateAst: observeMV に scalar 分布 (Normal) を渡すと親切エラー" $ do
+ let m = EDo [ DoBind "mu1" normal10
+ , DoExpr (observeMvE normal10 cols2) ]
+ (EApp (EVar "pure") (num 0))
+ HI.validateAst [] m dm `shouldSatisfy` (not . isRight')
+
+ -- Phase 44.3: MvNormalChol 分布 + lkjCorrCholesky 行列値 bind (latent Σ)
+ let halfN1 = EApp (EVar "HalfNormal") (num 1)
+ -- lkjCorrCholesky "L" 2 2.0
+ lkjE k = EApp (EApp (EApp (EVar "lkjCorrCholesky") (ELit (LText "L")))
+ (num (fromIntegral (k :: Int)))) (num 2.0)
+ -- MvNormalChol [mu1,mu2] [s1,s2] L
+ mvcE muRow sigRow lRef =
+ EApp (EApp (EApp (EVar "MvNormalChol") muRow) sigRow) lRef
+ -- L <- lkjCorrCholesky "L" 2 2.0; s1/s2 <- HalfNormal 1;
+ -- mu1/mu2 <- Normal 0 10; observeMV "y" (MvNormalChol [mu1,mu2] [s1,s2] L) ['y1','y2']
+ mvcModel = EDo [ DoBind "L" (lkjE 2)
+ , DoBind "s1" halfN1, DoBind "s2" halfN1
+ , DoBind "mu1" normal10, DoBind "mu2" normal10
+ , DoExpr (observeMvE
+ (mvcE (EList [EVar "mu1", EVar "mu2"])
+ (EList [EVar "s1", EVar "s2"]) (EVar "L")) cols2) ]
+ (EApp (EVar "pure") (num 0))
+ -- 相関 Cholesky L (ρ=0.5) + σ=[2,3] → M=diag σ·L、 Σ=M Mᵀ=[[4,3],[3,9]]。
+ it "mvNormalCholLogDensity: full-Σ 版 (mvNormalLogDensity) と Σ=M Mᵀ で数値一致" $ do
+ let lCorr = [[1, 0], [0.5, sqrt 0.75]] :: [[Double]]
+ sig = [2, 3] :: [Double]
+ mu = [0, 0] :: [Double]
+ y = [1, 2] :: [Double]
+ cov = [[4, 3], [3, 9]] :: [[Double]] -- = (diag σ·L)(diag σ·L)ᵀ
+ a = HBM.mvNormalCholLogDensity mu sig lCorr y
+ b = HBM.mvNormalLogDensity mu cov y
+ abs (a - b) < 1e-9 `shouldBe` True
+ it "evalDist: MvNormalChol [mu] [sigma] [[L]] を構築する" $
+ show (evalD (mvcE (EList [num 0, num 0]) (EList [num 1, num 1])
+ (EList [EList [num 1, num 0], EList [num 0, num 1]])))
+ `shouldBe` show (Right (HBM.MvNormalChol [0,0] [1,1] [[1,0],[0,1]])
+ :: Err (HBM.Distribution Double))
+ it "validateAst: lkjCorrCholesky bind + MvNormalChol observe を受理する" $
+ HI.validateAst [] mvcModel dm `shouldSatisfy` isRight'
+ it "interpStmts: lkjCorrCholesky が Model で走り内部 latent L_u1_0 が出る" $ do
+ let Right stmts = HI.validateAst [] mvcModel dm
+ g = HBM.buildModelGraph (HI.interpStmts [] dm stmts)
+ -- lkjCorrCholesky "L" 2 …: L_u1_0 (Beta latent) + L_pc1_0 (det)。
+ -- L_u1_0 の存在が combinator 実行の証明 (固定リテラルでは出ない)。
+ (("L_u1_0" `elem` allNames g) && ("mu1" `elem` allNames g)) `shouldBe` True
+ it "validateAst: lkjCorrCholesky の次元が 1 (k<2) ならエラー" $ do
+ let m = EDo [ DoBind "L" (lkjE 1)
+ , DoBind "mu1" normal10, DoBind "mu2" normal10
+ , DoExpr (observeMvE
+ (mvcE (EList [EVar "mu1", EVar "mu2"])
+ (EList [num 1, num 1]) (EVar "L")) cols2) ]
+ (EApp (EVar "pure") (num 0))
+ HI.validateAst [] m dm `shouldSatisfy` (not . isRight')
+ it "evalDist: MvNormalChol の σ 長と μ 長の不一致はエラー" $
+ evalD (mvcE (EList [num 0, num 0]) (EList [num 1])
+ (EList [EList [num 1, num 0], EList [num 0, num 1]]))
+ `shouldSatisfy` (not . isRight')
+
+ -- Phase 44.4: WAIC/PPC 再評価 (observeMV 専用並行経路)
+ let finiteAll = all (all (\x -> not (isNaN x || isInfinite x)))
+ it "reconstructMatrixComb: L_u1_0=0.5 (pc=0) から単位 Cholesky を再構築" $ do
+ let sm = M.fromList [("L_u1_0", 0.5 :: Double)] -- pc = 2*0.5-1 = 0
+ Just l = HI.reconstructMatrixComb sm (HI.LkjCholSpec "L" 2)
+ (length l == 2 && abs ((l !! 0 !! 0) - 1) < 1e-9 && abs (l !! 1 !! 0) < 1e-9
+ && abs ((l !! 1 !! 1) - 1) < 1e-9) `shouldBe` True
+ it "reconstructMatrixComb: pc=0.5 → L=[[1,0],[0.5,√0.75]] (相関 0.5)" $ do
+ let sm = M.fromList [("L_u1_0", 0.75 :: Double)] -- pc = 2*0.75-1 = 0.5
+ Just l = HI.reconstructMatrixComb sm (HI.LkjCholSpec "L" 2)
+ (abs (l !! 1 !! 0 - 0.5) < 1e-9 && abs (l !! 1 !! 1 - sqrt 0.75) < 1e-9) `shouldBe` True
+ it "computeMvObsDists: literal cov observeMV を sample から MvNormal に再評価" $ do
+ let Right stmts = HI.validateAst [] mvModel dm
+ sample = M.fromList [("mu1", 0.0), ("mu2", 0.0)]
+ sets = HI.computeMvObsDists [] stmts dm [sample]
+ isMv d = case d of HBM.MvNormal mu _ -> length mu == 2; _ -> False
+ (not (null sets) && all isMv (concat (HI.mvodsDists (head sets)))) `shouldBe` True
+ it "pointwiseLogLikMv: literal cov の log-lik が非空・有限" $ do
+ let Right stmts = HI.validateAst [] mvModel dm
+ sample = M.fromList [("mu1", 0.0), ("mu2", 0.0)]
+ ll = HI.pointwiseLogLikMv (HI.computeMvObsDists [] stmts dm [sample])
+ (not (null ll) && not (null (head ll)) && finiteAll ll) `shouldBe` True
+ it "computeMvObsDists+LogLik: latent Σ を L_u1_0 から MvNormalChol に再評価 (有限)" $ do
+ let Right stmts = HI.validateAst [] mvcModel dm
+ sample = M.fromList [ ("mu1", 0.0), ("mu2", 0.0), ("s1", 1.0), ("s2", 1.0)
+ , ("L_u1_0", 0.75) ]
+ sets = HI.computeMvObsDists [] stmts dm [sample]
+ isChol d = case d of HBM.MvNormalChol mu _ _ -> length mu == 2; _ -> False
+ ll = HI.pointwiseLogLikMv sets
+ (not (null sets) && all isChol (concat (HI.mvodsDists (head sets)))
+ && finiteAll ll) `shouldBe` True
+
+ describe "Hanalyze.Model.HBM.Interp Mixture 分布リスト引数 (Phase 45)" $ do
+ let num d = ELit (LNumber d)
+ isRight' = either (const False) (const True)
+ allNames g = sort [ HBM.nodeName n | n <- HBM.mgNodes g ]
+ -- 二峰性の連続観測列 (混合の主用途)。
+ dm = M.fromList [("value", HI.Numeric [1.0, 1.5, 8.0, 9.0])]
+ emptyEnv = M.empty :: HI.EnvA Double
+ evalD e = HI.evalDist emptyEnv dm Nothing e :: Err (HBM.Distribution Double)
+ normalE m s = EApp (EApp (EVar "Normal") m) s
+ catE probs = EApp (EVar "Categorical") (EList probs)
+ -- Mixture weights comps
+ mixE w c = EApp (EApp (EVar "Mixture") w) c
+ -- Mixture [0.3, 0.7] [Normal 0 1, Normal 5 1]
+ mixLit = mixE (EList [num 0.3, num 0.7])
+ (EList [normalE (num 0) (num 1), normalE (num 5) (num 1)])
+
+ -- Phase 45.1: evalDist Mixture 節 (literal weights + 再帰 evalDist)
+ it "evalDist: Mixture [w1,w2] [Normal,Normal] を構築する" $
+ show (evalD mixLit)
+ `shouldBe` show (Right (HBM.Mixture [0.3, 0.7] [HBM.Normal 0 1, HBM.Normal 5 1])
+ :: Err (HBM.Distribution Double))
+ it "evalDist: 第 2 引数の各成分を再帰 evalDist する (Categorical 成分のネスト)" $
+ show (evalD (mixE (EList [num 0.5, num 0.5])
+ (EList [catE [num 0.2, num 0.8], catE [num 0.6, num 0.4]])))
+ `shouldBe` show (Right (HBM.Mixture [0.5, 0.5]
+ [HBM.Categorical [0.2, 0.8], HBM.Categorical [0.6, 0.4]])
+ :: Err (HBM.Distribution Double))
+ it "evalDist: 成分分布が空 (Mixture [] []) はエラー" $
+ evalD (mixE (EList []) (EList [])) `shouldSatisfy` (not . isRight')
+ it "evalDist: 重み数 ≠ 成分数 (2 vs 1) はエラー" $
+ evalD (mixE (EList [num 0.3, num 0.7])
+ (EList [normalE (num 0) (num 1)])) `shouldSatisfy` (not . isRight')
+ it "logDensity: 構築した Mixture は有限な対数密度を返す" $ do
+ let Right d = evalD mixLit
+ ld = HBM.logDensity d (4.0 :: Double)
+ (not (isNaN ld || isInfinite ld)) `shouldBe` True
+
+ -- literal weights + latent component mean の最短モデル
+ let normal010 = normalE (num 0) (num 10)
+ halfN2 = EApp (EVar "HalfNormal") (num 2)
+ observeE nm dist col =
+ EApp (EApp (EApp (EVar "observe") (ELit (LText nm))) dist) (ECol col)
+ -- Mixture [0.3,0.7] [Normal mu1 sigma, Normal mu2 sigma]
+ mixD = mixE (EList [num 0.3, num 0.7])
+ (EList [ normalE (EVar "mu1") (EVar "sigma")
+ , normalE (EVar "mu2") (EVar "sigma") ])
+ -- mu1/mu2 <- Normal 0 10; sigma <- HalfNormal 2;
+ -- observe "y" (Mixture …) 'value'
+ mixModel = EDo [ DoBind "mu1" normal010, DoBind "mu2" normal010
+ , DoBind "sigma" halfN2
+ , DoExpr (observeE "y" mixD "value") ]
+ (EApp (EVar "pure") (num 0))
+ it "validateAst: literal weights Mixture observe を受理する" $
+ HI.validateAst [] mixModel dm `shouldSatisfy` isRight'
+ it "interpStmts: Mixture observe が Model を構築し latent mu1/mu2 が出る" $ do
+ let Right stmts = HI.validateAst [] mixModel dm
+ g = HBM.buildModelGraph (HI.interpStmts [] dm stmts)
+ (("mu1" `elem` allNames g) && ("mu2" `elem` allNames g)) `shouldBe` True
+ it "computeObsDists+LogLik: literal weights Mixture を sample から再評価 (有限)" $ do
+ let Right stmts = HI.validateAst [] mixModel dm
+ sample = M.fromList [("mu1", 1.0), ("mu2", 8.0), ("sigma", 1.0)]
+ sets = HI.computeObsDists [] stmts dm [sample]
+ ll = HI.pointwiseLogLik sets
+ (not (null sets) && not (null ll) && not (null (head ll))
+ && all (all (\x -> not (isNaN x || isInfinite x))) ll) `shouldBe` True
+
+ -- Phase 45.2: Dirichlet latent weights 経路 (Phase 43 dirichlet bind を流用)。
+ -- pi <- dirichlet "pi" [1,1]; mu1/mu2 <- Normal 0 10; sigma <- HalfNormal 2;
+ -- observe "y" (Mixture pi [Normal mu1 sigma, Normal mu2 sigma]) 'value'
+ let dirE = EApp (EApp (EVar "dirichlet") (ELit (LText "pi"))) (EList [num 1, num 1])
+ mixDirD = mixE (EVar "pi")
+ (EList [ normalE (EVar "mu1") (EVar "sigma")
+ , normalE (EVar "mu2") (EVar "sigma") ])
+ mixDirModel = EDo [ DoBind "pi" dirE
+ , DoBind "mu1" normal010, DoBind "mu2" normal010
+ , DoBind "sigma" halfN2
+ , DoExpr (observeE "y" mixDirD "value") ]
+ (EApp (EVar "pure") (num 0))
+ it "validateAst: Dirichlet latent 重み Mixture observe を受理する" $
+ HI.validateAst [] mixDirModel dm `shouldSatisfy` isRight'
+ it "interpStmts: dirichlet が走り内部 latent pi_b0 + mu1/mu2 が出る" $ do
+ let Right stmts = HI.validateAst [] mixDirModel dm
+ g = HBM.buildModelGraph (HI.interpStmts [] dm stmts)
+ (("pi_b0" `elem` allNames g) && ("mu1" `elem` allNames g)) `shouldBe` True
+ it "computeObsDists+LogLik: 重み pi を pi_b0 から再構築し Mixture 再評価 (有限)" $ do
+ -- combinator 内部 latent pi_b0 から reconstructComb が π を復元し、
+ -- Mixture の重みとして解決される (新規再構築コード不要 = scalar 経路流用)。
+ let Right stmts = HI.validateAst [] mixDirModel dm
+ sample = M.fromList [("pi_b0", 0.5), ("mu1", 1.0), ("mu2", 8.0), ("sigma", 1.0)]
+ sets = HI.computeObsDists [] stmts dm [sample]
+ ll = HI.pointwiseLogLik sets
+ isMix d = case d of HBM.Mixture ws _ -> length ws == 2; _ -> False
+ (not (null sets) && all isMix (concat (HI.odsDists (head sets)))
+ && not (null ll) && all (all (\x -> not (isNaN x || isInfinite x))) ll) `shouldBe` True
+
+-- ============================================================================
+-- Hanalyze.Model.Formula (Phase 46/15 §3.6 A15) — parser / AST / round-trip
+-- ============================================================================
diff --git a/test/Hanalyze/Model/HBM/LogpSpec.hs b/test/Hanalyze/Model/HBM/LogpSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/HBM/LogpSpec.hs
@@ -0,0 +1,1728 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.HBM.LogpSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub, mapAccumL, zip4)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.AD.Mode.Reverse.Double as RevD
+import qualified Data.Map.Strict as M
+import qualified Data.Set as Set
+import qualified Hanalyze.Model.HBM as HBM
+import Hanalyze.Fit (designHBMProgram)
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Phase 53: gradADU 勾配の正しさ (中心差分 ground truth)" $ do
+ let centralGrad m names trans us =
+ let h = 1e-5
+ f vs = HBM.logJointUnconstrained m names trans
+ (M.fromList (zip names vs))
+ bump i d = [ if j == i then u + d else u
+ | (j, u) <- zip [(0 :: Int) ..] us ]
+ in [ (f (bump i h) - f (bump i (-h))) / (2 * h)
+ | i <- [0 .. length us - 1] ]
+ closeVec tol a b =
+ length a == length b &&
+ and [ abs (x - y) <= tol * (1 + abs y) | (x, y) <- zip a b ]
+
+ it "M1 pooled 回帰 (latent 3: Normal×2 + Exp): gradADU ≈ 中心差分" $ do
+ let xs = [-1.0, -0.4, 0.2, 0.8, 1.5] :: [Double]
+ ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ m :: HBM.ModelP ()
+ m = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal (a + b * realToFrac x) s) [y])
+ (zip [0 ..] (zip xs ys))
+ names = HBM.sampleNames m
+ tmap = HBM.getTransforms m
+ trans = [ tmap M.! n | n <- names ]
+ us = [0.3, -0.2, 0.1]
+ closeVec 1e-4 (HBM.gradADU m names trans us) (centralGrad m names trans us)
+ `shouldBe` True
+
+ it "M2 random intercept GLMM (latent 6: HalfNormal/Exp 含む): gradADU ≈ 中心差分" $ do
+ let xRows = [ [1.0, -0.5], [1.0, 0.3], [1.0, 1.2]
+ , [1.0, -0.8], [1.0, 0.6], [1.0, 0.1] ]
+ gids = [0, 0, 0, 1, 1, 1]
+ ys = [0.2, 0.9, 1.8, 0.5, 1.3, 1.0] :: [Double]
+ m :: HBM.ModelP ()
+ m = HBM.glmmRandomIntercept HBM.GlmmGaussian xRows gids ys
+ names = HBM.sampleNames m
+ tmap = HBM.getTransforms m
+ trans = [ tmap M.! n | n <- names ]
+ us = take (length names) [0.1, -0.2, 0.15, 0.05, -0.1, 0.2, 0.3, 0.0]
+ closeVec 1e-4 (HBM.gradADU m names trans us) (centralGrad m names trans us)
+ `shouldBe` True
+
+ it "GP-RBF (MvNormalGpRBF・Phase 95 B-dsl 閉形式随伴): gradADU ≈ 中心差分" $ do
+ -- gp_pois_regr データ (N=11)。 gradADU → compileGradUV → gpRBFAnalyticVG
+ -- (Cholesky を AD tape に載せない閉形式随伴) が真の密度の中心差分と一致するか。
+ let xs = [-10,-8,-6,-4,-2,0,2,4,6,8,10] :: [Double]
+ ys = [ 4.75906, 1.59423, 2.99548, 5.27501, 1.66472, 2.24347
+ , 2.8914, 4.08681, 4.60588, 0.802364, 3.92136 ] :: [Double]
+ m :: HBM.ModelP ()
+ m = do
+ rho <- HBM.sample "rho" (HBM.Gamma 25 4)
+ alpha <- HBM.sample "alpha" (HBM.HalfNormal 2)
+ sigma <- HBM.sample "sigma" (HBM.HalfNormal 1)
+ HBM.observeMV "y"
+ (HBM.MvNormalGpRBF (map realToFrac xs) alpha rho sigma) [ys]
+ names = HBM.sampleNames m
+ tmap = HBM.getTransforms m
+ trans = [ tmap M.! n | n <- names ]
+ us = [1.8, 0.88, 0.59] -- exp(u) ≈ posterior 近傍 (ρ6,α2.4,σ1.8)
+ closeVec 1e-4 (HBM.gradADU m names trans us) (centralGrad m names trans us)
+ `shouldBe` True
+
+ it "HMM (HmmForwardNormal・Phase 92 A2 forward-backward 閉形式随伴): gradADU ≈ 中心差分" $ do
+ -- 14-hmm-example と同構造 (mu_2=mu_1+gap の順序制約 + dirichlet 遷移行)。
+ -- gradADU → gradValPlan → hmmAnalyticVG (forward-backward・AD tape ゼロ) が
+ -- 真の密度 (obsLogSum = hmmForwardLogLik) の中心差分と一致するか。
+ let ys = [0.5, 3.2, 9.8, 10.1, 2.7, 9.5, 0.1, 10.4] :: [Double]
+ kk = 2 :: Int
+ m :: HBM.ModelP ()
+ m = do
+ mu1 <- HBM.sample "mu_1" (HBM.Normal 3 1)
+ gap <- HBM.sample "gap" (HBM.HalfNormal 5)
+ mu2 <- HBM.deterministic "mu_2" (mu1 + gap)
+ HBM.potential "mu2_prior"
+ (HBM.logDensity (HBM.Normal 10 1) mu2
+ - HBM.logDensity (HBM.HalfNormal 5) gap)
+ th1 <- HBM.dirichlet "theta1" (replicate kk 1)
+ th2 <- HBM.dirichlet "theta2" (replicate kk 1)
+ HBM.observeMV "y_seq"
+ (HBM.HmmForwardNormal (replicate kk 1) [th1, th2] [mu1, mu2] 1) [ys]
+ names = HBM.sampleNames m
+ tmap = HBM.getTransforms m
+ trans = [ tmap M.! n | n <- names ]
+ us = [0.4, 0.9, 0.3, -0.5] -- mu_1, gap(log), theta1_b0(logit), theta2_b0(logit)
+ closeVec 1e-4 (HBM.gradADU m names trans us) (centralGrad m names trans us)
+ `shouldBe` True
+
+ it "HmmForwardNormal 密度 = 従来 potential (hmmForwardLogLik) 書きと一致 (Phase 92 A2)" $ do
+ -- 同一パラメータ点で logJointUnconstrained が旧書き方と一致 (移行の同値性)。
+ let ys = [0.5, 3.2, 9.8, 10.1, 2.7, 9.5, 0.1, 10.4] :: [Double]
+ kk = 2 :: Int
+ mNew :: HBM.ModelP ()
+ mNew = do
+ mu1 <- HBM.sample "mu_1" (HBM.Normal 3 1)
+ gap <- HBM.sample "gap" (HBM.HalfNormal 5)
+ _mu2 <- HBM.deterministic "mu_2" (mu1 + gap)
+ th1 <- HBM.dirichlet "theta1" (replicate kk 1)
+ th2 <- HBM.dirichlet "theta2" (replicate kk 1)
+ HBM.observeMV "y_seq"
+ (HBM.HmmForwardNormal (replicate kk 1) [th1, th2] [mu1, mu1 + gap] 1) [ys]
+ mOld :: HBM.ModelP ()
+ mOld = do
+ mu1 <- HBM.sample "mu_1" (HBM.Normal 3 1)
+ gap <- HBM.sample "gap" (HBM.HalfNormal 5)
+ _mu2 <- HBM.deterministic "mu_2" (mu1 + gap)
+ th1 <- HBM.dirichlet "theta1" (replicate kk 1)
+ th2 <- HBM.dirichlet "theta2" (replicate kk 1)
+ let emit = [ [ HBM.logDensity (HBM.Normal mu 1) (realToFrac y)
+ | mu <- [mu1, mu1 + gap] ] | y <- ys ]
+ HBM.potential "hmm_loglik"
+ (HBM.hmmForwardLogLik (replicate kk 1) [th1, th2] emit)
+ names = HBM.sampleNames mNew
+ tmap = HBM.getTransforms mNew
+ trans = [ tmap M.! n | n <- names ]
+ us = M.fromList (zip names ([0.4, 0.9, 0.3, -0.5] :: [Double]))
+ abs (HBM.logJointUnconstrained mNew names trans us
+ - HBM.logJointUnconstrained mOld names trans us)
+ `shouldSatisfy` (< 1e-10)
+
+ it "ARMA(1,1) (ArmaNormal・Phase 101 A2 逆向き随伴の閉形式): gradADU ≈ 中心差分" $ do
+ -- 22-arma と同構造 (μ/φ/θ Normal prior + σ HalfCauchy)。gradADU →
+ -- gradValPlan → armaAnalyticVG (逆向き随伴再帰・AD tape ゼロ) が
+ -- 真の密度 (obsLogSum = err 再帰) の中心差分と一致するか。
+ let ys = [0.5, 0.8, 0.2, -0.4, 0.9, 1.3, 0.1, -0.7, 0.4, 0.6] :: [Double]
+ m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ phi <- HBM.sample "phi" (HBM.Normal 0 2)
+ theta <- HBM.sample "theta" (HBM.Normal 0 2)
+ sigma <- HBM.sample "sigma" (HBM.HalfCauchy 2.5)
+ HBM.observeMV "y_seq" (HBM.ArmaNormal mu phi theta sigma) [ys]
+ names = HBM.sampleNames m
+ tmap = HBM.getTransforms m
+ trans = [ tmap M.! n | n <- names ]
+ us = [0.3, 0.7, -0.2, -0.4] -- mu, phi, theta, sigma(log)
+ closeVec 1e-4 (HBM.gradADU m names trans us) (centralGrad m names trans us)
+ `shouldBe` True
+
+ it "ArmaNormal 密度 = 従来 mapAccumL + potential 書きと一致 (Phase 101 A2)" $ do
+ -- 同一パラメータ点で logJointUnconstrained が旧書き方と一致 (移行の同値性)。
+ let ys = [0.5, 0.8, 0.2, -0.4, 0.9, 1.3, 0.1, -0.7, 0.4, 0.6] :: [Double]
+ mNew :: HBM.ModelP ()
+ mNew = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ phi <- HBM.sample "phi" (HBM.Normal 0 2)
+ theta <- HBM.sample "theta" (HBM.Normal 0 2)
+ sigma <- HBM.sample "sigma" (HBM.HalfCauchy 2.5)
+ HBM.observeMV "y_seq" (HBM.ArmaNormal mu phi theta sigma) [ys]
+ mOld :: HBM.ModelP ()
+ mOld = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ phi <- HBM.sample "phi" (HBM.Normal 0 2)
+ theta <- HBM.sample "theta" (HBM.Normal 0 2)
+ sigma <- HBM.sample "sigma" (HBM.HalfCauchy 2.5)
+ let (y1 : rest) = map realToFrac ys
+ e1 = y1 - (mu + phi * mu)
+ step (prevY, prevErr) yt =
+ let err = yt - (mu + phi * prevY + theta * prevErr)
+ in ((yt, err), err)
+ errs = e1 : snd (mapAccumL step (y1, e1) rest)
+ HBM.potential "arma_loglik"
+ (sum [ HBM.logDensity (HBM.Normal 0 sigma) e | e <- errs ])
+ names = HBM.sampleNames mNew
+ tmap = HBM.getTransforms mNew
+ trans = [ tmap M.! n | n <- names ]
+ us = M.fromList (zip names ([0.3, 0.7, -0.2, -0.4] :: [Double]))
+ abs (HBM.logJointUnconstrained mNew names trans us
+ - HBM.logJointUnconstrained mOld names trans us)
+ `shouldSatisfy` (< 1e-10)
+
+ it "graded response IRT (GradedResponseIrt・Phase 101 A3 解析勾配): gradADU ≈ 中心差分" $ do
+ -- 20-bones と同構造 (theta のみ latent・delta/gamma/ncat は定数 data・
+ -- 欠測 −1 スキップ込)。gradADU → gradValPlan → gradedIrtAnalyticVG
+ -- (dQ/dθ = δ·Q(1−Q) の隣接差・AD tape ゼロ) が真の密度の中心差分と一致するか。
+ let ncats = [3, 2] :: [Int]
+ deltas = [1.2, 0.7] :: [Double]
+ gammas = [[-0.5, 0.8], [0.1]] :: [[Double]]
+ grades = [1, 2, 3, -1, 2, 1] :: [Double] -- 3 child × 2 item 行優先 (−1 = 欠測)
+ m :: HBM.ModelP ()
+ m = do
+ ths <- mapM (\i -> HBM.sample (T.pack ("theta_" ++ show (i :: Int)))
+ (HBM.Normal 0 6)) [0 .. 2]
+ HBM.observeMV "grades" (HBM.GradedResponseIrt ths ncats deltas gammas) [grades]
+ names = HBM.sampleNames m
+ tmap = HBM.getTransforms m
+ trans = [ tmap M.! n | n <- names ]
+ us = [0.4, -0.8, 1.1]
+ closeVec 1e-4 (HBM.gradADU m names trans us) (centralGrad m names trans us)
+ `shouldBe` True
+
+ it "GradedResponseIrt 密度 = 従来 logCatProb + potential 書きと一致 (Phase 101 A3)" $ do
+ -- 同一パラメータ点で logJointUnconstrained が旧書き方と一致 (移行の同値性)。
+ let ncats = [3, 2] :: [Int]
+ deltas = [1.2, 0.7] :: [Double]
+ gammas = [[-0.5, 0.8], [0.1]] :: [[Double]]
+ grades = [1, 2, 3, -1, 2, 1] :: [Double]
+ logCatProb th nc dl gm gr =
+ let kMax = nc - 1
+ qs = [ 1 / (1 + exp (negate (realToFrac dl * (th - realToFrac (gm !! (kk - 1))))))
+ | kk <- [1 .. kMax :: Int] ]
+ ps = [ if k == 1 then 1 - head qs
+ else if k == nc then qs !! (kMax - 1)
+ else (qs !! (k - 2)) - (qs !! (k - 1))
+ | k <- [1 .. nc] ]
+ in log (ps !! (gr - 1))
+ mNew :: HBM.ModelP ()
+ mNew = do
+ ths <- mapM (\i -> HBM.sample (T.pack ("theta_" ++ show (i :: Int)))
+ (HBM.Normal 0 6)) [0 .. 2]
+ HBM.observeMV "grades" (HBM.GradedResponseIrt ths ncats deltas gammas) [grades]
+ mOld :: HBM.ModelP ()
+ mOld = do
+ ths <- mapM (\i -> HBM.sample (T.pack ("theta_" ++ show (i :: Int)))
+ (HBM.Normal 0 6)) [0 .. 2]
+ let rows = [ take 2 grades, take 2 (drop 2 grades), drop 4 grades ]
+ terms = [ logCatProb th nc dl gm (round gr)
+ | (th, row) <- zip ths rows
+ , (nc, dl, gm, gr) <- zip4 ncats deltas gammas row
+ , gr /= -1 ]
+ HBM.potential "bones_loglik" (sum terms)
+ names = HBM.sampleNames mNew
+ tmap = HBM.getTransforms mNew
+ trans = [ tmap M.! n | n <- names ]
+ us = M.fromList (zip names ([0.4, -0.8, 1.1] :: [Double]))
+ abs (HBM.logJointUnconstrained mNew names trans us
+ - HBM.logJointUnconstrained mOld names trans us)
+ `shouldSatisfy` (< 1e-10)
+
+ it "irt-2pl 型 (LogNormal-latent-scale 解析勾配・Phase 98 A3): gradADU ≈ 中心差分" $ do
+ -- Bernoulli-logit 積尤度 (a_i·theta_j) で vecIR 経路に載り、a_i~LogNormal(0,σ_a)
+ -- (σ_a latent) が 'gradLogNormalIx' で解析勾配に載る (reverse-AD tape 全廃)。
+ -- theta は Normal 族で arena 吸収・σ 群は constPrior。真の密度の中心差分と一致確認。
+ let ys = [1,0,1, 0,1,0] :: [Double] -- 2 item × 3 person の (i,j) 行優先
+ m :: HBM.ModelP ()
+ m = do
+ sigTheta <- HBM.sample "sigma_theta" (HBM.HalfCauchy 2)
+ th <- mapM (\j -> HBM.sample (T.pack ("theta_" ++ show (j :: Int)))
+ (HBM.Normal 0 sigTheta)) [0 .. 2]
+ sigA <- HBM.sample "sigma_a" (HBM.HalfCauchy 2)
+ as <- mapM (\i -> HBM.sample (T.pack ("a_" ++ show (i :: Int)))
+ (HBM.LogNormal 0 sigA)) [0 .. 1]
+ mapM_ (\((i, j), y) ->
+ let logit = (as !! i) * (th !! j)
+ in HBM.observe (T.pack ("y_" ++ show i ++ "_" ++ show j))
+ (HBM.Bernoulli (1 / (1 + exp (negate logit)))) [y])
+ (zip [ (i, j) | i <- [0 .. 1], j <- [0 .. 2] ] ys)
+ names = HBM.sampleNames m
+ tmap = HBM.getTransforms m
+ trans = [ tmap M.! n | n <- names ]
+ us = [0.2, 0.3, -0.1, 0.25, 0.15, 0.4, -0.2] -- 7 latent (σθ,θ0-2,σa,a0-1)
+ closeVec 1e-4 (HBM.gradADU m names trans us) (centralGrad m names trans us)
+ `shouldBe` True
+
+ -- Phase 54.1: 構造化線形予測子 observe (ObserveLM)。 設計行列 X と β 名を
+ -- 分離保持する観測ブロックが、 per-obs observe を N 回呼ぶのと数値等価かを担保。
+ -- (54.2 で Gaussian-恒等リンクの suff-stat collapse に乗せる前提テスト)
+
+ describe "Phase 54.1: ObserveLM が per-obs observe と数値等価" $ do
+ let centralGrad m names trans us =
+ let h = 1e-5
+ f vs = HBM.logJointUnconstrained m names trans
+ (M.fromList (zip names vs))
+ bump i d = [ if j == i then u + d else u
+ | (j, u) <- zip [(0 :: Int) ..] us ]
+ in [ (f (bump i h) - f (bump i (-h))) / (2 * h)
+ | i <- [0 .. length us - 1] ]
+ closeVec tol a b =
+ length a == length b &&
+ and [ abs (x - y) <= tol * (1 + abs y) | (x, y) <- zip a b ]
+ xs = [-1.0, -0.4, 0.2, 0.8, 1.5] :: [Double]
+ designX = [ [1.0, x] | x <- xs ] -- intercept + slope
+
+ it "Gaussian-identity: logJoint/gradADU が per-obs observe と一致 + 中心差分" $ do
+ let ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ mObs, mLM :: HBM.ModelP ()
+ mObs = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal (a + b * realToFrac x) s) [y])
+ (zip [0 ..] (zip xs ys))
+ mLM = do
+ _ <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ _ <- HBM.sample "sigma" (HBM.Exponential 1)
+ HBM.observeLM "y" ["a", "b"] designX (HBM.LMGaussian "sigma") ys
+ names = HBM.sampleNames mLM
+ tmap = HBM.getTransforms mLM
+ trans = [ tmap M.! n | n <- names ]
+ us = [0.3, -0.2, 0.1]
+ -- Phase 60.7: TrackTag (非標準クラス) が defaulting を止めるので明示
+ ps = M.fromList [("a", 0.4), ("b", 1.5), ("sigma", 0.6)]
+ :: M.Map T.Text Double
+ -- sampleNames は ObserveLM が latent を増やさず一致
+ names `shouldBe` ["a", "b", "sigma"]
+ -- logJoint が per-obs と一致
+ closeVec 1e-9 [HBM.logJoint mLM ps] [HBM.logJoint mObs ps] `shouldBe` True
+ -- gradADU が per-obs と一致
+ closeVec 1e-7 (HBM.gradADU mLM names trans us)
+ (HBM.gradADU mObs names trans us) `shouldBe` True
+ -- gradADU が中心差分 ground truth と一致
+ closeVec 1e-4 (HBM.gradADU mLM names trans us)
+ (centralGrad mLM names trans us) `shouldBe` True
+
+ it "Poisson (log link): ObserveLM が per-obs observe と logJoint 一致" $ do
+ let ys = [1.0, 0.0, 3.0, 2.0, 5.0] :: [Double]
+ mObs, mLM :: HBM.ModelP ()
+ mObs = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Poisson (exp (a + b * realToFrac x))) [y])
+ (zip [0 ..] (zip xs ys))
+ mLM = do
+ _ <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ HBM.observeLM "y" ["a", "b"] designX HBM.LMPoisson ys
+ ps = M.fromList [("a", 0.2), ("b", 0.5)] :: M.Map T.Text Double
+ closeVec 1e-9 [HBM.logJoint mLM ps] [HBM.logJoint mObs ps] `shouldBe` True
+
+ it "Bernoulli (logit link): ObserveLM が per-obs observe と logJoint 一致" $ do
+ let ys = [1.0, 0.0, 1.0, 1.0, 0.0] :: [Double]
+ logistic z = 1 / (1 + exp (negate z))
+ mObs, mLM :: HBM.ModelP ()
+ mObs = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Bernoulli (logistic (a + b * realToFrac x))) [y])
+ (zip [0 ..] (zip xs ys))
+ mLM = do
+ _ <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ HBM.observeLM "y" ["a", "b"] designX HBM.LMBernoulli ys
+ ps = M.fromList [("a", -0.3), ("b", 0.8)] :: M.Map T.Text Double
+ closeVec 1e-9 [HBM.logJoint mLM ps] [HBM.logJoint mObs ps] `shouldBe` True
+
+ it "extractDeps: ObserveLM は観測 1 ノード・親 = β + σ" $ do
+ let ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ mLM :: HBM.ModelP ()
+ mLM = do
+ _ <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ _ <- HBM.sample "sigma" (HBM.Exponential 1)
+ HBM.observeLM "y" ["a", "b"] designX (HBM.LMGaussian "sigma") ys
+ (nodes, _) = HBM.extractDeps mLM
+ yNode = head [ n | n <- nodes, HBM.nodeName n == "y" ]
+ HBM.nodeKind yNode `shouldBe` HBM.ObservedN (length ys)
+ HBM.nodeDeps yNode `shouldBe` Set.fromList ["a", "b", "sigma"]
+
+ it "observeLMR (REff gather): random intercept が per-obs observe と一致 + 中心差分" $ do
+ -- random intercept: η_i = a + b·x_i + u_{g(i)}、 g = [0,0,1,1,0]
+ let ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ gids = [0, 0, 1, 1, 0] :: [Int]
+ mObs, mLMR :: HBM.ModelP ()
+ mObs = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ tu <- HBM.sample "tau_u" (HBM.HalfNormal 5)
+ u0 <- HBM.sample "u_0" (HBM.Normal 0 tu)
+ u1 <- HBM.sample "u_1" (HBM.Normal 0 tu)
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ let us = [u0, u1]
+ mapM_ (\(i, (x, g, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal (a + b * realToFrac x + us !! g) s) [y])
+ (zip [0 ..] (zip3 xs gids ys))
+ mLMR = do
+ _ <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ tu <- HBM.sample "tau_u" (HBM.HalfNormal 5)
+ _ <- HBM.sample "u_0" (HBM.Normal 0 tu)
+ _ <- HBM.sample "u_1" (HBM.Normal 0 tu)
+ _ <- HBM.sample "sigma" (HBM.Exponential 1)
+ HBM.observeLMR "y" ["a", "b"] designX [HBM.REff ["u_0", "u_1"] gids Nothing Nothing Nothing]
+ (HBM.LMGaussian "sigma") ys
+ names = HBM.sampleNames mLMR
+ tmap = HBM.getTransforms mLMR
+ trans = [ tmap M.! n | n <- names ]
+ us = [0.3, -0.2, 0.1, 0.4, -0.3, 0.0]
+ ps = M.fromList
+ [ ("a", 0.4), ("b", 1.5), ("tau_u", 0.7)
+ , ("u_0", 0.2), ("u_1", -0.3), ("sigma", 0.6) ]
+ :: M.Map T.Text Double
+ names `shouldBe` ["a", "b", "tau_u", "u_0", "u_1", "sigma"]
+ -- logJoint が per-obs と一致
+ closeVec 1e-9 [HBM.logJoint mLMR ps] [HBM.logJoint mObs ps] `shouldBe` True
+ -- gradADU (ハイブリッド vec-tape) が per-obs ad と一致
+ closeVec 1e-7 (HBM.gradADU mLMR names trans us)
+ (HBM.gradADU mObs names trans us) `shouldBe` True
+ -- gradADU が中心差分 ground truth と一致
+ closeVec 1e-4 (HBM.gradADU mLMR names trans us)
+ (centralGrad mLMR names trans us) `shouldBe` True
+ -- extractDeps: 親 = β + u + σ
+ let (nodes, _) = HBM.extractDeps mLMR
+ yNode = head [ n | n <- nodes, HBM.nodeName n == "y" ]
+ HBM.nodeDeps yNode `shouldBe`
+ Set.fromList ["a", "b", "u_0", "u_1", "sigma"]
+
+ it "reNormal/at (Phase 54.4c): 解析 prior 勾配が ad 経路・中心差分と一致" $ do
+ -- 第一級ランダム効果 (reNormal/at) で組んだモデル mNew は u-prior 勾配を
+ -- 解析計算 + u_j Sample を ad から除外する。 文字列 REff (Nothing) で組んだ
+ -- mAd は prior を従来 ad で計算する。 両者は数値的に等価でなければならない。
+ let ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ gids = [0, 0, 1, 1, 0] :: [Int]
+ mAd, mNew :: HBM.ModelP ()
+ mAd = do
+ _ <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ tu <- HBM.sample "tau_u" (HBM.HalfNormal 5)
+ _ <- HBM.sample "u_0" (HBM.Normal 0 tu)
+ _ <- HBM.sample "u_1" (HBM.Normal 0 tu)
+ _ <- HBM.sample "sigma" (HBM.Exponential 1)
+ HBM.observeLMR "y" ["a", "b"] designX [HBM.REff ["u_0", "u_1"] gids Nothing Nothing Nothing]
+ (HBM.LMGaussian "sigma") ys
+ mNew = do
+ _ <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ tau <- HBM.sample "tau_u" (HBM.HalfNormal 5)
+ u <- HBM.reNormal "u" 2 "tau_u" tau
+ _ <- HBM.sample "sigma" (HBM.Exponential 1)
+ HBM.observeNormalLM "y" designX ["a", "b"] [u `HBM.at` gids] "sigma" ys
+ names = HBM.sampleNames mNew
+ tmap = HBM.getTransforms mNew
+ trans = [ tmap M.! n | n <- names ]
+ us = [0.3, -0.2, 0.1, 0.4, -0.3, 0.0]
+ -- mAd の prior には tau に依存する u_j prior が ad で入る。 mNew では u_j prior
+ -- を解析計算するが、 値は同一なので両勾配は一致するはず。
+ names `shouldBe` ["a", "b", "tau_u", "u_0", "u_1", "sigma"]
+ closeVec 1e-7 (HBM.gradADU mNew names trans us)
+ (HBM.gradADU mAd names trans us) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mNew names trans us)
+ (centralGrad mNew names trans us) `shouldBe` True
+
+ it "compileLogPU (Phase 54.4d): 値評価が logJointUnconstrained と一致 (3 経路)" $ do
+ -- (1) 解析経路 (reNormal/at = Just scale) / (2) Nothing REff (LM vec のみ) /
+ -- (3) Gaussian LM 無し (scalar fallback)。 いずれも従来 walk 評価と一致すること。
+ let ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ gids = [0, 0, 1, 1, 0] :: [Int]
+ mAna, mPlain, mScalar :: HBM.ModelP ()
+ mAna = do
+ _ <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ tau <- HBM.sample "tau_u" (HBM.HalfNormal 5)
+ u <- HBM.reNormal "u" 2 "tau_u" tau
+ _ <- HBM.sample "sigma" (HBM.Exponential 1)
+ HBM.observeNormalLM "y" designX ["a", "b"] [u `HBM.at` gids] "sigma" ys
+ mPlain = do
+ _ <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ tu <- HBM.sample "tau_u" (HBM.HalfNormal 5)
+ _ <- HBM.sample "u_0" (HBM.Normal 0 tu)
+ _ <- HBM.sample "u_1" (HBM.Normal 0 tu)
+ _ <- HBM.sample "sigma" (HBM.Exponential 1)
+ HBM.observeLMR "y" ["a", "b"] designX [HBM.REff ["u_0", "u_1"] gids Nothing Nothing Nothing]
+ (HBM.LMGaussian "sigma") ys
+ mScalar = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ s <- HBM.sample "s" (HBM.Exponential 1)
+ HBM.observe "y" (HBM.Normal mu s) ys
+ checkEq :: HBM.ModelP () -> [Double] -> Expectation
+ checkEq mdl uvals = do
+ let nms = HBM.sampleNames mdl
+ tmap = HBM.getTransforms mdl
+ trs = [ tmap M.! n | n <- nms ]
+ pU = M.fromList (zip nms uvals)
+ HBM.compileLogPU mdl nms trs uvals
+ `shouldSatisfy` (\v -> abs (v - HBM.logJointUnconstrained mdl nms trs pU) < 1e-9)
+ checkEq mAna [0.3, -0.2, 0.1, 0.4, -0.3, 0.0]
+ checkEq mPlain [0.3, -0.2, 0.1, 0.4, -0.3, 0.0]
+ checkEq mScalar [0.7, -0.1]
+
+ it "54.4e fallback: LM ブロック + scalar observe 混在 (residual 非空) で ad/中心差分一致" $ do
+ -- β/σ は定数パラメタ prior (解析勾配) だが scalar observe "z" が residual に
+ -- 残るので ad 経路も併用される。 値・勾配とも従来 walk / 中心差分と一致すること。
+ let ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ mMix :: HBM.ModelP ()
+ mMix = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ _ <- HBM.sample "sigma" (HBM.Exponential 1)
+ HBM.observe "z" (HBM.Normal a 2) [0.5, 0.9] -- residual に残る scalar observe
+ HBM.observeLM "y" ["a", "b"] designX (HBM.LMGaussian "sigma") ys
+ names = HBM.sampleNames mMix
+ tmap = HBM.getTransforms mMix
+ trans = [ tmap M.! n | n <- names ]
+ us = [0.3, -0.2, 0.1]
+ pU = M.fromList (zip names us)
+ names `shouldBe` ["a", "b", "sigma"]
+ abs (HBM.compileLogPU mMix names trans us
+ - HBM.logJointUnconstrained mMix names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mMix names trans us)
+ (centralGrad mMix names trans us) `shouldBe` True
+
+ it "synthGaussLMBlocks (Phase 54.8): M1 per-obs 手書きが自動合成され値/勾配一致" $ do
+ -- per-obs scalar observe 手書きの pooled 回帰 (bench M1 形)。 affine 追跡で
+ -- ObserveLM ブロックに自動合成され、 全 Observe が吸収されること +
+ -- 値/勾配が従来 walk・中心差分と一致すること。
+ let ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ mM1 :: HBM.ModelP ()
+ mM1 = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal (a + b * realToFrac x) s) [y])
+ (zip [0 ..] (zip xs ys))
+ (blocks, absorbed) = HBM.synthGaussLMBlocks mM1
+ names = HBM.sampleNames mM1
+ tmap = HBM.getTransforms mM1
+ trans = [ tmap M.! n | n <- names ]
+ us = [0.3, -0.2, 0.1]
+ pU = M.fromList (zip names us)
+ [ (bs, xs', re, sn, ys') | (_, bs, xs', re, sn, ys') <- blocks ]
+ `shouldBe` [ (["a", "b"], designX, [], "sigma", ys) ]
+ Set.toList absorbed
+ `shouldBe` [ T.pack ("y_" ++ show i) | i <- [0 .. 4 :: Int] ]
+ abs (HBM.compileLogPU mM1 names trans us
+ - HBM.logJointUnconstrained mM1 names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mM1 names trans us)
+ (centralGrad mM1 names trans us) `shouldBe` True
+
+ it "synthGaussLMBlocks (Phase 54.8): 階層 per-obs 手書きで one-hot 族が REff gather 化" $ do
+ -- m2Scalar 形: 係数常 1 の u_0/u_1 (prior = Normal(0, tau_u)) が dense 列で
+ -- なく REff gather (Just tau_u = 解析 prior 経路) に昇格すること。
+ let gids = [0, 0, 1, 1, 0] :: [Int]
+ ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ mH :: HBM.ModelP ()
+ mH = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ tau <- HBM.sample "tau_u" (HBM.HalfNormal 5)
+ uvs <- mapM (\j -> HBM.sample (T.pack ("u_" ++ show (j :: Int)))
+ (HBM.Normal 0 tau)) [0, 1]
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ mapM_ (\(i, ((x, g), y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal (a + b * realToFrac x + uvs !! g) s) [y])
+ (zip [0 ..] (zip (zip xs gids) ys))
+ (blocks, _) = HBM.synthGaussLMBlocks mH
+ names = HBM.sampleNames mH
+ tmap = HBM.getTransforms mH
+ trans = [ tmap M.! n | n <- names ]
+ uv = [0.3, -0.2, 0.1, 0.4, -0.3, 0.0]
+ pU = M.fromList (zip names uv)
+ [ (bs, re) | (_, bs, _, re, _, _) <- blocks ]
+ `shouldBe` [ (["a", "b"], [HBM.REff ["u_0", "u_1"] gids (Just "tau_u") Nothing Nothing]) ]
+ abs (HBM.compileLogPU mH names trans uv
+ - HBM.logJointUnconstrained mH names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mH names trans uv)
+ (centralGrad mH names trans uv) `shouldBe` True
+
+ it "synthGaussLMBlocks (Phase 54.8): 値依存分岐は合成せず fallback (値/勾配は従来経路)" $ do
+ -- μ に値依存分岐 (if a > 0) を含むモデル。 AffV の Ord poison →
+ -- try/force 捕捉で合成全体が fallback し、 値/勾配は従来 ad 経路で正しいこと。
+ let mBr :: HBM.ModelP ()
+ mBr = do
+ a <- HBM.sample "a" (HBM.Normal 0 1)
+ s <- HBM.sample "s" (HBM.Exponential 1)
+ let mu = if a > 0 then a else negate a
+ HBM.observe "y" (HBM.Normal mu s) [0.5, 1.0]
+ (blocks, absorbed) = HBM.synthGaussLMBlocks mBr
+ names = HBM.sampleNames mBr
+ tmap = HBM.getTransforms mBr
+ trans = [ tmap M.! n | n <- names ]
+ uv = [0.7, -0.1]
+ pU = M.fromList (zip names uv)
+ null blocks `shouldBe` True
+ Set.null absorbed `shouldBe` True
+ abs (HBM.compileLogPU mBr names trans uv
+ - HBM.logJointUnconstrained mBr names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mBr names trans uv)
+ (centralGrad mBr names trans uv) `shouldBe` True
+
+ it "synthGaussLMBlocks (Phase 54.10): random slope (係数付き) も u/v 二重族で REff 化" $ do
+ -- M3 形: u_g (係数 1) と v_g (係数 x_i) が、 ともに REff gather に昇格する
+ -- こと (v 族は per-row 重み = x・u 族は重み Nothing)。 β (b0/b1) は dense
+ -- 列のまま。 値/勾配は従来 walk・中心差分と一致。
+ let gids = [0, 0, 1, 1, 0] :: [Int]
+ ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ mRS :: HBM.ModelP ()
+ mRS = do
+ b0 <- HBM.sample "b0" (HBM.Normal 0 5)
+ b1 <- HBM.sample "b1" (HBM.Normal 0 5)
+ tu <- HBM.sample "tau_u" (HBM.HalfNormal 5)
+ tv <- HBM.sample "tau_v" (HBM.HalfNormal 5)
+ uvs <- mapM (\j -> HBM.sample (T.pack ("u_" ++ show (j :: Int)))
+ (HBM.Normal 0 tu)) [0, 1]
+ vvs <- mapM (\j -> HBM.sample (T.pack ("v_" ++ show (j :: Int)))
+ (HBM.Normal 0 tv)) [0, 1]
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ mapM_ (\(i, ((x, g), y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal (b0 + b1 * realToFrac x + uvs !! g
+ + (vvs !! g) * realToFrac x) s) [y])
+ (zip [0 ..] (zip (zip xs gids) ys))
+ (blocks, absorbed) = HBM.synthGaussLMBlocks mRS
+ names = HBM.sampleNames mRS
+ tmap = HBM.getTransforms mRS
+ trans = [ tmap M.! n | n <- names ]
+ uv = [0.3, -0.2, 0.1, 0.4, -0.3, 0.2, 0.15, -0.25, 0.0]
+ pU = M.fromList (zip names uv)
+ [ (bs, re) | (_, bs, _, re, _, _) <- blocks ]
+ `shouldBe` [ (["b0", "b1"],
+ [ HBM.REff ["u_0", "u_1"] gids (Just "tau_u") Nothing Nothing
+ , HBM.REff ["v_0", "v_1"] gids (Just "tau_v") (Just xs) Nothing ]) ]
+ Set.size absorbed `shouldBe` 5
+ abs (HBM.compileLogPU mRS names trans uv
+ - HBM.logJointUnconstrained mRS names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mRS names trans uv)
+ (centralGrad mRS names trans uv) `shouldBe` True
+
+ it "observeLMR (Phase 54.10): 明示の重み付き REff が per-obs 手書きと値一致" $ do
+ -- 重み付き gather (η_i += w_i·v_{g_i}) を Nothing スケール (汎用 walk 経路)
+ -- で明示構築し、 同じモデルの per-obs 手書きと logJointUnconstrained が
+ -- 一致すること (lmReffEta の重み対応の直接検証)。
+ let gids = [0, 0, 1, 1, 0] :: [Int]
+ ys = [0.3, 1.1, 2.4, 3.0, 4.2] :: [Double]
+ mW, mHand :: HBM.ModelP ()
+ mW = do
+ _ <- HBM.sample "a" (HBM.Normal 0 10)
+ _ <- HBM.sample "b" (HBM.Normal 0 10)
+ tv <- HBM.sample "tau_v" (HBM.HalfNormal 5)
+ _ <- HBM.sample "v_0" (HBM.Normal 0 tv)
+ _ <- HBM.sample "v_1" (HBM.Normal 0 tv)
+ _ <- HBM.sample "sigma" (HBM.Exponential 1)
+ HBM.observeLMR "y" ["a", "b"] designX
+ [HBM.REff ["v_0", "v_1"] gids Nothing (Just xs) Nothing]
+ (HBM.LMGaussian "sigma") ys
+ mHand = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ tv <- HBM.sample "tau_v" (HBM.HalfNormal 5)
+ vvs <- mapM (\j -> HBM.sample (T.pack ("v_" ++ show (j :: Int)))
+ (HBM.Normal 0 tv)) [0, 1]
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ mapM_ (\(i, ((x, g), y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal (a + b * realToFrac x
+ + (vvs !! g) * realToFrac x) s) [y])
+ (zip [0 ..] (zip (zip xs gids) ys))
+ names = HBM.sampleNames mW
+ tmap = HBM.getTransforms mW
+ trans = [ tmap M.! n | n <- names ]
+ uv = [0.3, -0.2, 0.1, 0.4, -0.3, 0.0]
+ pU = M.fromList (zip names uv)
+ names `shouldBe` HBM.sampleNames mHand
+ abs (HBM.logJointUnconstrained mW names trans pU
+ - HBM.logJointUnconstrained mHand names trans pU) < 1e-9 `shouldBe` True
+ abs (HBM.compileLogPU mW names trans uv
+ - HBM.logJointUnconstrained mW names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mW names trans uv)
+ (centralGrad mW names trans uv) `shouldBe` True
+
+ -- Phase 54.11 共通: 従来 ad の unconstrained 勾配 (fFull 相当) を参照値に。
+ let adGradRef :: HBM.ModelP () -> [T.Text] -> [Transform] -> [Double] -> [Double]
+ adGradRef mm nms trs uvs =
+ RevD.grad
+ (\uv' -> HBM.logJoint mm
+ (M.fromList (zip nms (zipWith HBM.invTransformF trs uv')))
+ + sum (zipWith HBM.logJacF trs uv'))
+ uvs
+
+ it "synthVecIR (Phase 54.11): M5 形 (非線形 μ) がベクトル式 IR 化され値/勾配一致" $ do
+ -- μ_i = a·exp(-b·x_i) + c (bench M5 形)。 affine 合成 (54.8) は不成立、
+ -- ベクトル式 IR が全 Observe を吸収し、 値/勾配が従来 ad・中心差分と一致。
+ let ys = [2.1, 1.7, 1.4, 1.2, 1.0] :: [Double]
+ m5 :: HBM.ModelP ()
+ m5 = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.HalfNormal 2)
+ c <- HBM.sample "c" (HBM.Normal 0 10)
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal (a * exp (negate b * realToFrac x) + c) s) [y])
+ (zip [0 ..] (zip xs ys))
+ names = HBM.sampleNames m5
+ tmap = HBM.getTransforms m5
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.8, log 0.9, 0.3, log 0.4]
+ pU = M.fromList (zip names uvs)
+ null (fst (HBM.synthGaussLMBlocks m5)) `shouldBe` True
+ case HBM.synthVecIR m5 of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.toList sObs `shouldBe`
+ [ T.pack ("y_" ++ show i) | i <- [0 .. 4 :: Int] ]
+ abs (HBM.compileLogPU m5 names trans uvs
+ - HBM.logJointUnconstrained m5 names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU m5 names trans uvs)
+ (adGradRef m5 names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU m5 names trans uvs)
+ (centralGrad m5 names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 54.11): M6 形 (階層×非線形) で族 prior も IR に乗り値/勾配一致" $ do
+ -- μ_i = a_{g(i)}·exp(-b·x_i)、 a_g ~ Normal(μ_a, τ_a) (bench M6 形)。
+ -- a_g 族が gather + ベクトル化 prior として IR に乗ること。
+ let gids = [0, 0, 1, 1, 0] :: [Int]
+ ys = [2.1, 1.7, 1.4, 1.2, 1.0] :: [Double]
+ m6 :: HBM.ModelP ()
+ m6 = do
+ muA <- HBM.sample "mu_a" (HBM.Normal 0 10)
+ tauA <- HBM.sample "tau_a" (HBM.HalfNormal 2)
+ as <- mapM (\j -> HBM.sample (T.pack ("a_" ++ show (j :: Int)))
+ (HBM.Normal muA tauA)) [0, 1]
+ b <- HBM.sample "b" (HBM.HalfNormal 2)
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ mapM_ (\(i, ((x, g), y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal ((as !! g) * exp (negate b * realToFrac x)) s) [y])
+ (zip [0 ..] (zip (zip xs gids) ys))
+ names = HBM.sampleNames m6
+ tmap = HBM.getTransforms m6
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [1.5, log 0.6, 1.8, 1.6, log 0.9, log 0.4]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR m6 of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, _) -> do
+ length gs `shouldBe` 1
+ [ ms | (ms, _, _) <- fams ] `shouldBe` [["a_0", "a_1"]]
+ abs (HBM.compileLogPU m6 names trans uvs
+ - HBM.logJointUnconstrained m6 names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU m6 names trans uvs)
+ (adGradRef m6 names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU m6 names trans uvs)
+ (centralGrad m6 names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 54.11): 値依存分岐 (非線形) は合成せず fallback" $ do
+ -- μ に値依存分岐を含む非線形モデル。 SExp の Ord poison → try/force 捕捉で
+ -- IR 合成全体が fallback し、 値/勾配は従来 ad 経路で正しいこと。
+ let mBr :: HBM.ModelP ()
+ mBr = do
+ a <- HBM.sample "a" (HBM.Normal 0 1)
+ s <- HBM.sample "s" (HBM.Exponential 1)
+ let mu = if a > 0 then exp a else negate a
+ HBM.observe "y" (HBM.Normal mu s) [0.5, 1.0]
+ names = HBM.sampleNames mBr
+ tmap = HBM.getTransforms mBr
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.7, -0.1]
+ pU = M.fromList (zip names uvs)
+ (case HBM.synthVecIR mBr of Nothing -> True; Just _ -> False)
+ `shouldBe` True
+ abs (HBM.compileLogPU mBr names trans uvs
+ - HBM.logJointUnconstrained mBr names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mBr names trans uvs)
+ (centralGrad mBr names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 54.11→55.2): 式形混在 σ グループも指紋サブグループ化で全吸収" $ do
+ -- σ グループ s1 は同型非線形・s2 は行ごとに式の形が違う。 Phase 55.2 の
+ -- (σ名, μ式形指紋) サブグループ化により z_0/z_1 も**それぞれ独立の
+ -- グループとして吸収**される (54.11 時点では s2 丸ごと residual だった)。
+ let mMix :: HBM.ModelP ()
+ mMix = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.HalfNormal 2)
+ s1 <- HBM.sample "s1" (HBM.Exponential 1)
+ s2 <- HBM.sample "s2" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y1_" ++ show (i :: Int)))
+ (HBM.Normal (a * exp (negate b * realToFrac x)) s1) [y])
+ (zip [0 ..] (zip xs [2.1, 1.7, 1.4, 1.2, 1.0 :: Double]))
+ HBM.observe "z_0" (HBM.Normal (exp a) s2) [1.3]
+ HBM.observe "z_1" (HBM.Normal (a * a) s2) [0.9]
+ names = HBM.sampleNames mMix
+ tmap = HBM.getTransforms mMix
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.5, log 0.8, log 0.6, log 0.7]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mMix of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, _, sObs) -> do
+ length gs `shouldBe` 3
+ Set.member "y1_0" sObs `shouldBe` True
+ Set.member "z_0" sObs `shouldBe` True
+ Set.member "z_1" sObs `shouldBe` True
+ abs (HBM.compileLogPU mMix names trans uvs
+ - HBM.logJointUnconstrained mMix names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mMix names trans uvs)
+ (adGradRef mMix names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mMix names trans uvs)
+ (centralGrad mMix names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 55.2): 同一 σ 下 2 形 (複数行ずつ) を両方吸収 + 非対応分布は residual" $ do
+ -- 同一 σ 下に exp a 群と a*a 群 (各 2 行) → 形指紋で 2 グループに割れて
+ -- 両方吸収。 AsymmetricLaplace 観測は対象外で residual walk に残る
+ -- (部分吸収の継続。 55.4 時点は StudentT だったが 56.3 で吸収対象化)。
+ let mShapes :: HBM.ModelP ()
+ mShapes = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ s <- HBM.sample "s" (HBM.Exponential 1)
+ mapM_ (\(i, y) ->
+ HBM.observe (T.pack ("p_" ++ show (i :: Int)))
+ (HBM.Normal (exp a) s) [y])
+ (zip [0 ..] [1.3, 1.1 :: Double])
+ mapM_ (\(i, y) ->
+ HBM.observe (T.pack ("q_" ++ show (i :: Int)))
+ (HBM.Normal (a * a) s) [y])
+ (zip [0 ..] [0.9, 0.7 :: Double])
+ HBM.observe "r" (HBM.AsymmetricLaplace s 1 a) [0.2]
+ names = HBM.sampleNames mShapes
+ tmap = HBM.getTransforms mShapes
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.6, log 0.5]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mShapes of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 2
+ length fams `shouldBe` 0
+ Set.toList sObs `shouldBe` ["p_0", "p_1", "q_0", "q_1"]
+ abs (HBM.compileLogPU mShapes names trans uvs
+ - HBM.logJointUnconstrained mShapes names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mShapes names trans uvs)
+ (adGradRef mShapes names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mShapes names trans uvs)
+ (centralGrad mShapes names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 80.2): 非中心化相関 RE μ(L×z) が (a) 経路に載り値/勾配一致" $ do
+ -- 2 群・k=2 (切片 + 傾き 1)・群あたり 3 obs = 6 obs。 非中心化:
+ -- b_g^0 = τ0·z0_g, b_g^1 = τ1·(pc·z0_g + √(1-pc²)·z1_g), pc = 2u-1
+ -- μ_i = β + b_{g(i)}^0 + b_{g(i)}^1·w_i, y_i ~ Normal(μ_i, σ)
+ -- μ に latent×latent 積 (τ·z, L·z) が入る非 affine 形。 Phase 80.2 で probe を
+ -- ドメイン対応化する前は、 pcu (Beta ∈ (0,1)) が固定 probe 点 base=1.3 で
+ -- 域外 (pcu=1.74 → √(1-pc²)=NaN) となり誤 fallback していた。 unify/gather/
+ -- 族 prior は元から成立しており、 IR は数値的に忠実。
+ let gids = [0,0,0,1,1,1] :: [Int]
+ ws = [-1.0, 0.0, 1.0, -0.5, 0.5, 1.5] :: [Double]
+ ys = [0.2, 0.5, 1.1, -0.3, 0.4, 1.2] :: [Double]
+ m :: HBM.ModelP ()
+ m = do
+ beta <- HBM.sample "beta" (HBM.Normal 0 10)
+ sig <- HBM.sample "sigma" (HBM.HalfNormal 5)
+ tau0 <- HBM.sample "tau0" (HBM.HalfNormal 5)
+ tau1 <- HBM.sample "tau1" (HBM.HalfNormal 5)
+ u <- HBM.sample "pcu" (HBM.Beta 2 2)
+ let pc = 2 * u - 1
+ l11 = sqrt (1 - pc * pc)
+ z0 <- mapM (\g -> HBM.sample (T.pack ("z0_" ++ show (g :: Int)))
+ (HBM.Normal 0 1)) [0, 1]
+ z1 <- mapM (\g -> HBM.sample (T.pack ("z1_" ++ show (g :: Int)))
+ (HBM.Normal 0 1)) [0, 1]
+ let b0 g = tau0 * (z0 !! g)
+ b1 g = tau1 * (pc * (z0 !! g) + l11 * (z1 !! g))
+ mu i = beta + b0 (gids !! i) + b1 (gids !! i) * realToFrac (ws !! i)
+ mapM_ (\i -> HBM.observe (T.pack ("y_" ++ show i))
+ (HBM.Normal (mu i) sig) [ys !! i])
+ [0 .. 5 :: Int]
+ names = HBM.sampleNames m
+ tmap = HBM.getTransforms m
+ trans = [ tmap M.! n | n <- names ]
+ -- unconstrained probe (変換で Beta→(0,1)・HalfNormal→(0,∞) に写り NaN 無し)。
+ uvs = [ 0.15 + 0.07 * fromIntegral i | i <- [0 .. length names - 1] ]
+ pU = M.fromList (zip names uvs)
+ -- (b) affine 合成には載らない (latent×latent) が、 (a) vecIR には載る。
+ null (fst (HBM.synthGaussLMBlocks m)) `shouldBe` True
+ case HBM.synthVecIR m of
+ Nothing -> expectationFailure "synthVecIR: expected Just (probe ドメイン対応後)"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ Set.fromList [ ms | (ms, _, _) <- fams ]
+ `shouldBe` Set.fromList [["z0_0", "z0_1"], ["z1_0", "z1_1"]]
+ Set.toList sObs `shouldBe` [ T.pack ("y_" ++ show i) | i <- [0 .. 5 :: Int] ]
+ -- 値: compiled IR ≈ 従来 walk。
+ abs (HBM.compileLogPU m names trans uvs
+ - HBM.logJointUnconstrained m names trans pU) < 1e-9 `shouldBe` True
+ -- 勾配: IR ≈ 従来 ad (1e-9) ≈ 中心差分 (finite-diff 1e-6)。
+ closeVec 1e-9 (HBM.gradADU m names trans uvs)
+ (adGradRef m names trans uvs) `shouldBe` True
+ closeVec 1e-6 (HBM.gradADU m names trans uvs)
+ (centralGrad m names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 80.2b): 実 designHBMProgram (相関傾き) が非中心化 (a) に載る" $ do
+ -- Phase 80.2b: Fit.hs:designHBMProgram の相関傾き branch を非中心化へ改修した後、
+ -- 実コードが吐く ModelP が (b) affine には載らず (a) vecIR に載ることを担保。
+ -- 2 群・k=2 (切片 + 傾き 1)・群あたり 3 obs = 6 obs。 spike (Phase 80.2) と
+ -- 同型だが、 lkjCorrCholesky / deterministic b を経由する **実コード経路**を検証。
+ let gids = [0,0,0,1,1,1] :: [Int]
+ ws = [-1.0, 0.0, 1.0, -0.5, 0.5, 1.5] :: [Double]
+ ys = [0.2, 0.5, 1.1, -0.3, 0.4, 1.2] :: [Double]
+ designX = [ [1.0, w] | w <- ws ] -- (Intercept) + temp
+ betaNames = ["(Intercept)", "temp"]
+ res = [(gids, 2, [ws])] -- 1 RE 群・傾き列 = temp
+ m :: HBM.ModelP ()
+ m = designHBMProgram designX betaNames res ys
+ names = HBM.sampleNames m
+ tmap = HBM.getTransforms m
+ trans = [ tmap M.! n | n <- names ]
+ -- unconstrained probe (変換で Beta→(0,1)/HalfNormal→(0,∞) に写り NaN 無し)。
+ uvs = [ 0.1 + 0.05 * fromIntegral i | i <- [0 .. length names - 1] ]
+ pU = M.fromList (zip names uvs)
+ -- (b) affine 合成には載らない (latent×latent = τ·L·z)。
+ null (fst (HBM.synthGaussLMBlocks m)) `shouldBe` True
+ -- (a) vecIR に載る (6 観測)。
+ case HBM.synthVecIR m of
+ Nothing -> expectationFailure "synthVecIR: expected Just (非中心化相関 RE が (a) に載る)"
+ Just (_gs, _fams, sObs) -> Set.size sObs `shouldBe` 6
+ -- 値: compiled IR ≈ 従来 walk。
+ abs (HBM.compileLogPU m names trans uvs
+ - HBM.logJointUnconstrained m names trans pU) < 1e-9 `shouldBe` True
+ -- 勾配: IR ≈ 従来 ad (1e-9) ≈ 中心差分 (finite-diff 1e-6)。
+ closeVec 1e-9 (HBM.gradADU m names trans uvs)
+ (adGradRef m names trans uvs) `shouldBe` True
+ closeVec 1e-6 (HBM.gradADU m names trans uvs)
+ (centralGrad m names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 55.3): σ がスカラ式 (定数倍 2·s) でも吸収され値/勾配一致" $ do
+ -- σ = 2*s は 54.11 の「σ = 単一 latent」 条件を満たさず residual 落ち
+ -- していた形。 55.3 で σ 位置が任意 SExp に拡張され吸収される。
+ let mScale :: HBM.ModelP ()
+ mScale = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.HalfNormal 2)
+ s <- HBM.sample "s" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal (a * exp (negate b * realToFrac x)) (2 * s))
+ [y])
+ (zip [0 ..] (zip xs [2.1, 1.7, 1.4, 1.2, 1.0 :: Double]))
+ names = HBM.sampleNames mScale
+ tmap = HBM.getTransforms mScale
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.5, log 0.7, log 0.6]
+ pU = M.fromList (zip names uvs)
+ null (fst (HBM.synthGaussLMBlocks mScale)) `shouldBe` True
+ case HBM.synthVecIR mScale of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, _, sObs) -> do
+ length gs `shouldBe` 1
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mScale names trans uvs
+ - HBM.logJointUnconstrained mScale names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mScale names trans uvs)
+ (adGradRef mScale names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mScale names trans uvs)
+ (centralGrad mScale names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 55.3): heteroscedastic σ_i = exp(g0+g1·z_i) がベクトル密度で吸収" $ do
+ -- σ が行依存 (z_i はデータ定数)。 名前付き σ 指紋で 1 グループに揃い、
+ -- UC 列を含む σ IR → ベクトル版密度 -Σlogσ_i - Σr_i²/(2σ_i²) (値/tape 両方)。
+ let zs = [0.2, -0.5, 1.0, 0.4, -1.2] :: [Double]
+ mHet :: HBM.ModelP ()
+ mHet = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ g0 <- HBM.sample "g0" (HBM.Normal 0 2)
+ g1 <- HBM.sample "g1" (HBM.Normal 0 2)
+ mapM_ (\(i, (z, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Normal a (exp (g0 + g1 * realToFrac z))) [y])
+ (zip [0 ..] (zip zs [1.4, 0.8, 1.9, 1.1, 0.5 :: Double]))
+ names = HBM.sampleNames mHet
+ tmap = HBM.getTransforms mHet
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.9, -0.3, 0.4]
+ pU = M.fromList (zip names uvs)
+ null (fst (HBM.synthGaussLMBlocks mHet)) `shouldBe` True
+ case HBM.synthVecIR mHet of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mHet names trans uvs
+ - HBM.logJointUnconstrained mHet names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mHet names trans uvs)
+ (adGradRef mHet names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mHet names trans uvs)
+ (centralGrad mHet names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 55.4): M7 形 (Poisson 回帰 log link) が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Poisson(exp(a + b·x_i))。 非 Gaussian 観測の IR 化 (本丸)。
+ -- Σlog y_i! は compile 時前計算 (勾配に寄与しない)。
+ let ysP = [1, 0, 3, 2, 5] :: [Double]
+ m7 :: HBM.ModelP ()
+ m7 = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Poisson (exp (a + b * realToFrac x))) [y])
+ (zip [0 ..] (zip xs ysP))
+ names = HBM.sampleNames m7
+ tmap = HBM.getTransforms m7
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.4, 0.7]
+ pU = M.fromList (zip names uvs)
+ null (fst (HBM.synthGaussLMBlocks m7)) `shouldBe` True
+ case HBM.synthVecIR m7 of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU m7 names trans uvs
+ - HBM.logJointUnconstrained m7 names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU m7 names trans uvs)
+ (adGradRef m7 names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU m7 names trans uvs)
+ (centralGrad m7 names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 55.4): M8 形 (logistic 回帰) が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Bernoulli(invLogit(a + b·x_i))。 y ∈ {0,1} は定数係数化。
+ let ysB = [1, 0, 1, 1, 0] :: [Double]
+ m8 :: HBM.ModelP ()
+ m8 = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Bernoulli
+ (1 / (1 + exp (negate (a + b * realToFrac x))))) [y])
+ (zip [0 ..] (zip xs ysB))
+ names = HBM.sampleNames m8
+ tmap = HBM.getTransforms m8
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.2, 1.1]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR m8 of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU m8 names trans uvs
+ - HBM.logJointUnconstrained m8 names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU m8 names trans uvs)
+ (adGradRef m8 names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU m8 names trans uvs)
+ (centralGrad m8 names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 55.4): 階層 GLM 形 (Poisson + 群 intercept) で族 prior も IR に乗る" $ do
+ -- y_i ~ Poisson(exp(b0 + u_{g(i)}))、 u_g ~ Normal(0, τ)。 λ 式中の
+ -- 族 gather + 族 prior が既存機構のまま乗ること (M6 の Poisson 版)。
+ let gids = [0, 0, 1, 1, 0] :: [Int]
+ ysP = [2, 1, 4, 3, 2] :: [Double]
+ mG :: HBM.ModelP ()
+ mG = do
+ b0 <- HBM.sample "b0" (HBM.Normal 0 5)
+ tau <- HBM.sample "tau" (HBM.HalfNormal 2)
+ us <- mapM (\j -> HBM.sample (T.pack ("u_" ++ show (j :: Int)))
+ (HBM.Normal 0 tau)) [0, 1]
+ mapM_ (\(i, (g, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Poisson (exp (b0 + us !! g))) [y])
+ (zip [0 ..] (zip gids ysP))
+ names = HBM.sampleNames mG
+ tmap = HBM.getTransforms mG
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.5, log 0.8, 0.3, -0.2]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mG of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ [ ms | (ms, _, _) <- fams ] `shouldBe` [["u_0", "u_1"]]
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mG names trans uvs
+ - HBM.logJointUnconstrained mG names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mG names trans uvs)
+ (adGradRef mG names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mG names trans uvs)
+ (centralGrad mG names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 55.4): 非対応分布 (AsymmetricLaplace obs のみ) は従来どおり fallback" $ do
+ -- 55.4 時点は StudentT で確認していたが 56.3 で吸収対象になったため、
+ -- 引き続き非対応の AsymmetricLaplace に差し替え。
+ let mT :: HBM.ModelP ()
+ mT = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ s <- HBM.sample "s" (HBM.Exponential 1)
+ HBM.observe "y" (HBM.AsymmetricLaplace s 1 a) [0.5, 1.0, -0.2]
+ names = HBM.sampleNames mT
+ tmap = HBM.getTransforms mT
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.3, -0.1]
+ pU = M.fromList (zip names uvs)
+ (case HBM.synthVecIR mT of Nothing -> True; Just _ -> False)
+ `shouldBe` True
+ abs (HBM.compileLogPU mT names trans uvs
+ - HBM.logJointUnconstrained mT names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mT names trans uvs)
+ (centralGrad mT names trans uvs) `shouldBe` True
+
+ it "digamma (Phase 56.1): 既知値 + 漸化式 + lgammaApprox 中心差分一致" $ do
+ let gammaE = 0.5772156649015329 :: Double
+ -- 既知値: ψ(1) = -γ, ψ(1/2) = -γ - 2 ln 2
+ abs (HBM.digamma 1.0 - negate gammaE) < 1e-9 `shouldBe` True
+ abs (HBM.digamma 0.5 - (negate gammaE - 2 * log 2)) < 1e-9 `shouldBe` True
+ -- 漸化式 ψ(x+1) = ψ(x) + 1/x (構成上ほぼ厳密)
+ mapM_ (\x -> abs (HBM.digamma (x + 1) - HBM.digamma x - 1 / x) < 1e-12
+ `shouldBe` True)
+ [0.3, 1.7, 5.5, 20.0 :: Double]
+ -- 実際に使う lgammaApprox の数値微分 (中心差分 h=1e-5) と 1e-8 一致。
+ -- ⚠ x は整数を避ける: x±h が lgammaApprox の再帰段数境界 (x+k=12) を
+ -- 跨ぐと打切り誤差ジャンプ ~1e-9 が /2h 増幅され FD 自体が壊れる
+ -- (lgammaApprox の性質・digamma の問題ではない)。
+ let h = 1e-5
+ cd x = (HBM.lgammaApprox (x + h) - HBM.lgammaApprox (x - h)) / (2 * h)
+ mapM_ (\x -> abs (cd x - HBM.digamma x) < 1e-8 `shouldBe` True)
+ [0.7, 2.3, 8.1, 15.3, 40.2 :: Double]
+
+ it "synthVecIR (Phase 56.3): StudentT (ν=SC) robust 回帰形が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ StudentT(4, a + b·x_i, σ)。 ν=SC 定数 → lgamma 項は compile 時
+ -- 定数化され密度は初等演算のみ (外れ値 8.0 入りの robust 回帰形)。
+ let ysT = [2.1, 1.7, 1.4, 1.2, 8.0] :: [Double]
+ mSt :: HBM.ModelP ()
+ mSt = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.StudentT 4 (a + b * realToFrac x) s) [y])
+ (zip [0 ..] (zip xs ysT))
+ names = HBM.sampleNames mSt
+ tmap = HBM.getTransforms mSt
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [1.4, -0.6, log 0.5]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mSt of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mSt names trans uvs
+ - HBM.logJointUnconstrained mSt names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mSt names trans uvs)
+ (adGradRef mSt names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mSt names trans uvs)
+ (centralGrad mSt names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.3): StudentT の ν latent は fallback (計画 scope どおり)" $ do
+ -- ν を latent にすると lgamma(ν) 項が定数化できず収集対象外 →
+ -- IR 合成されず従来 ad 経路で値/勾配が正しいこと。
+ let mNu :: HBM.ModelP ()
+ mNu = do
+ nu <- HBM.sample "nu" (HBM.Exponential 0.1)
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ s <- HBM.sample "s" (HBM.Exponential 1)
+ HBM.observe "y" (HBM.StudentT nu a s) [0.5, 1.0, -0.2]
+ names = HBM.sampleNames mNu
+ tmap = HBM.getTransforms mNu
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [log 4, 0.3, log 0.7]
+ pU = M.fromList (zip names uvs)
+ (case HBM.synthVecIR mNu of Nothing -> True; Just _ -> False)
+ `shouldBe` True
+ abs (HBM.compileLogPU mNu names trans uvs
+ - HBM.logJointUnconstrained mNu names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mNu names trans uvs)
+ (centralGrad mNu names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.3): Cauchy robust 回帰形が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Cauchy(a + b·x_i, γ)。 logp = -n·logπ - Σlogγ - Σlog(1+z²)。
+ let ysC = [2.1, 1.7, 1.4, 1.2, 8.0] :: [Double]
+ mC :: HBM.ModelP ()
+ mC = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ g <- HBM.sample "gamma" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Cauchy (a + b * realToFrac x) g) [y])
+ (zip [0 ..] (zip xs ysC))
+ names = HBM.sampleNames mC
+ tmap = HBM.getTransforms mC
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [1.4, -0.6, log 0.5]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mC of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mC names trans uvs
+ - HBM.logJointUnconstrained mC names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mC names trans uvs)
+ (adGradRef mC names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mC names trans uvs)
+ (centralGrad mC names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.3): Logistic 回帰形が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Logistic(a + b·x_i, s)。 logp = -Σz - Σlog s - 2·Σlog(1+exp(-z))。
+ let ysL = [2.1, 1.7, 1.4, 1.2, 1.0] :: [Double]
+ mL :: HBM.ModelP ()
+ mL = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ s <- HBM.sample "s" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Logistic (a + b * realToFrac x) s) [y])
+ (zip [0 ..] (zip xs ysL))
+ names = HBM.sampleNames mL
+ tmap = HBM.getTransforms mL
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [1.4, -0.6, log 0.5]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mL of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mL names trans uvs
+ - HBM.logJointUnconstrained mL names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mL names trans uvs)
+ (adGradRef mL names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mL names trans uvs)
+ (centralGrad mL names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.3): Logistic heteroscedastic s_i = exp(g0+g1·x_i) もベクトル密度で吸収" $ do
+ -- scale 行依存 → Σlog s_i のベクトル分岐 ('sumLogScale' の RUSum 側) カバー。
+ let ysL = [2.1, 1.7, 1.4, 1.2, 1.0] :: [Double]
+ mLh :: HBM.ModelP ()
+ mLh = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ g0 <- HBM.sample "g0" (HBM.Normal 0 2)
+ g1 <- HBM.sample "g1" (HBM.Normal 0 2)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Logistic a (exp (g0 + g1 * realToFrac x))) [y])
+ (zip [0 ..] (zip xs ysL))
+ names = HBM.sampleNames mLh
+ tmap = HBM.getTransforms mLh
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [1.4, -0.3, 0.2]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mLh of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mLh names trans uvs
+ - HBM.logJointUnconstrained mLh names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mLh names trans uvs)
+ (adGradRef mLh names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mLh names trans uvs)
+ (centralGrad mLh names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.3): Gumbel 回帰形が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Gumbel(a + b·x_i, β)。 logp = -Σlogβ - Σz - Σexp(-z) (極値回帰形)。
+ let ysG = [2.5, 2.0, 1.8, 1.5, 3.2] :: [Double]
+ mGu :: HBM.ModelP ()
+ mGu = do
+ a <- HBM.sample "a" (HBM.Normal 0 10)
+ b <- HBM.sample "b" (HBM.Normal 0 10)
+ be <- HBM.sample "beta" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Gumbel (a + b * realToFrac x) be) [y])
+ (zip [0 ..] (zip xs ysG))
+ names = HBM.sampleNames mGu
+ tmap = HBM.getTransforms mGu
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [1.8, -0.4, log 0.6]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mGu of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mGu names trans uvs
+ - HBM.logJointUnconstrained mGu names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mGu names trans uvs)
+ (adGradRef mGu names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mGu names trans uvs)
+ (centralGrad mGu names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.4): Exponential 生存形 (rate=exp(η)) が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Exponential(exp(a + b·x_i))。 logp = Σlog rate - Σ rate·y。
+ let ysE = [0.8, 1.5, 0.3, 2.1, 0.6] :: [Double]
+ mE :: HBM.ModelP ()
+ mE = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Exponential (exp (a + b * realToFrac x))) [y])
+ (zip [0 ..] (zip xs ysE))
+ names = HBM.sampleNames mE
+ tmap = HBM.getTransforms mE
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.4, -0.3]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mE of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mE names trans uvs
+ - HBM.logJointUnconstrained mE names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mE names trans uvs)
+ (adGradRef mE names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mE names trans uvs)
+ (centralGrad mE names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.4): 定義域外 y (負値) を含むグループは収集拒否で fallback" $ do
+ -- Exponential 観測に y < 0 が混在 → グループ丸ごと吸収しない
+ -- (walk の -∞ 縮退をそのまま残す安全方向・55.4 の Poisson と同じ規律)。
+ let mNeg :: HBM.ModelP ()
+ mNeg = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ HBM.observe "y" (HBM.Exponential (exp a)) [0.8, -0.5, 1.2]
+ (case HBM.synthVecIR mNeg of Nothing -> True; Just _ -> False)
+ `shouldBe` True
+
+ it "synthVecIR (Phase 56.4): Weibull 生存形 (k latent, λ=exp(η)) が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Weibull(k, exp(a + b·x_i))。 (y/λ)^k = exp(k·(log y - log λ)) の
+ -- 初等化で k も latent のまま吸収 (lgamma 不要)。
+ let ysW = [0.8, 1.5, 0.3, 2.1, 0.6] :: [Double]
+ mW :: HBM.ModelP ()
+ mW = do
+ k <- HBM.sample "k" (HBM.Exponential 1)
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Weibull k (exp (a + b * realToFrac x))) [y])
+ (zip [0 ..] (zip xs ysW))
+ names = HBM.sampleNames mW
+ tmap = HBM.getTransforms mW
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [log 1.3, 0.4, -0.3]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mW of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mW names trans uvs
+ - HBM.logJointUnconstrained mW names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mW names trans uvs)
+ (adGradRef mW names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mW names trans uvs)
+ (centralGrad mW names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.4): LogNormal 回帰形が Gaussian ノード再利用で IR 吸収され値/勾配一致" $ do
+ -- y_i ~ LogNormal(a + b·x_i, σ)。 log y 前計算 → VOGauss densityIR
+ -- 再利用 + 定数 -Σlog y (新密度ノード無し・計画どおり)。
+ let ysLn = [0.8, 1.5, 0.3, 2.1, 0.6] :: [Double]
+ mLn :: HBM.ModelP ()
+ mLn = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ s <- HBM.sample "sigma" (HBM.Exponential 1)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.LogNormal (a + b * realToFrac x) s) [y])
+ (zip [0 ..] (zip xs ysLn))
+ names = HBM.sampleNames mLn
+ tmap = HBM.getTransforms mLn
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.2, -0.4, log 0.7]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mLn of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mLn names trans uvs
+ - HBM.logJointUnconstrained mLn names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mLn names trans uvs)
+ (adGradRef mLn names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mLn names trans uvs)
+ (centralGrad mLn names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.4): Gamma 回帰形 (α latent, rate=exp(η)) が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Gamma(α, exp(a + b·x_i))。 lgammaΓ(α) は SLgammaO
+ -- (値 lgammaApprox / 導関数 digamma) — α latent の勾配も記号微分で自動。
+ let ysG = [0.8, 1.5, 0.3, 2.1, 0.6] :: [Double]
+ mGa :: HBM.ModelP ()
+ mGa = do
+ al <- HBM.sample "alpha" (HBM.Exponential 1)
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Gamma al (exp (a + b * realToFrac x))) [y])
+ (zip [0 ..] (zip xs ysG))
+ names = HBM.sampleNames mGa
+ tmap = HBM.getTransforms mGa
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [log 1.6, 0.4, -0.3]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mGa of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mGa names trans uvs
+ - HBM.logJointUnconstrained mGa names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mGa names trans uvs)
+ (adGradRef mGa names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mGa names trans uvs)
+ (centralGrad mGa names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.4): Beta 回帰形 (α=μφ, β=(1-μ)φ, μ=invLogit(η)) が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Beta(μ_i·φ, (1-μ_i)·φ)。 両パラメタとも行依存式 + lgammaΓ 3 項。
+ -- ⚠ φ は整数を避ける (φ=3.0 だと α+β の lgammaApprox 再帰が x+k=12 整数
+ -- 境界に乗り中心差分が壊れる・56.1 で記録済みの FD 罠を実測で再確認)。
+ let ysB = [0.3, 0.6, 0.4, 0.7, 0.5] :: [Double]
+ mBe :: HBM.ModelP ()
+ mBe = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ ph <- HBM.sample "phi" (HBM.Exponential 0.5)
+ mapM_ (\(i, (x, y)) ->
+ let muI = 1 / (1 + exp (negate (a + b * realToFrac x)))
+ in HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Beta (muI * ph) ((1 - muI) * ph)) [y])
+ (zip [0 ..] (zip xs ysB))
+ names = HBM.sampleNames mBe
+ tmap = HBM.getTransforms mBe
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.4, -0.3, log 3.3]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mBe of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mBe names trans uvs
+ - HBM.logJointUnconstrained mBe names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mBe names trans uvs)
+ (adGradRef mBe names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mBe names trans uvs)
+ (centralGrad mBe names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.5): Binomial グループ形 (n=10, p=invLogit(η)) が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Binomial(10, invLogit(a + b·x_i))。 Bernoulli の 0/1 係数を
+ -- k/n-k に一般化 + ΣlogC(n,k) は compile 時定数。
+ let ysK = [3, 7, 5, 8, 2] :: [Double]
+ mBi :: HBM.ModelP ()
+ mBi = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Binomial 10
+ (1 / (1 + exp (negate (a + b * realToFrac x))))) [y])
+ (zip [0 ..] (zip xs ysK))
+ names = HBM.sampleNames mBi
+ tmap = HBM.getTransforms mBi
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.3, 0.8]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mBi of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mBi names trans uvs
+ - HBM.logJointUnconstrained mBi names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mBi names trans uvs)
+ (adGradRef mBi names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mBi names trans uvs)
+ (centralGrad mBi names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 94): 行ごとに n が異なる Binomial が 1 group に merge され値/勾配一致" $ do
+ -- Phase 94 の核心。 seeds (11-seeds) 型 = 各行の試行数 n_i が異なる。
+ -- 修正前は n を group key に含めていたため n 別に分裂 (ここでは 5 行全て
+ -- 相異なる n → 5 group)。 n を行対応 Vector 化し key から除外することで
+ -- 1 group に merge される (= per-eval の 17→1 group 化と同じ改修)。
+ let nsB = [10, 12, 8, 15, 6] :: [Double] -- 全て相異なる n
+ ysK = [3, 7, 5, 8, 2] :: [Double] -- 0 ≤ y_i ≤ n_i
+ mBn :: HBM.ModelP ()
+ mBn = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ mapM_ (\(i, (x, (nn, y))) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Binomial (round nn)
+ (1 / (1 + exp (negate (a + b * realToFrac x))))) [y])
+ (zip [0 ..] (zip xs (zip nsB ysK)))
+ names = HBM.sampleNames mBn
+ tmap = HBM.getTransforms mBn
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.3, 0.8]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mBn of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1 -- ★Phase 94: n 別分裂が解消され 1 group
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mBn names trans uvs
+ - HBM.logJointUnconstrained mBn names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mBn names trans uvs)
+ (adGradRef mBn names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mBn names trans uvs)
+ (centralGrad mBn names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.5): Geometric 回帰形 (p=invLogit(η)) が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ Geometric(invLogit(a + b·x_i))。 logp = Σ(k-1)·log(1-p) + Σlog p。
+ let ysG = [2, 1, 4, 3, 1] :: [Double]
+ mGe :: HBM.ModelP ()
+ mGe = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Geometric
+ (1 / (1 + exp (negate (a + b * realToFrac x))))) [y])
+ (zip [0 ..] (zip xs ysG))
+ names = HBM.sampleNames mGe
+ tmap = HBM.getTransforms mGe
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [-0.2, 0.5]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mGe of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mGe names trans uvs
+ - HBM.logJointUnconstrained mGe names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mGe names trans uvs)
+ (adGradRef mGe names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mGe names trans uvs)
+ (centralGrad mGe names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 56.5): NegBin 回帰形 (μ=exp(η), α latent) が IR 吸収され値/勾配一致" $ do
+ -- y_i ~ NegativeBinomial(exp(a + b·x_i), α)。 lgammaΓ(k_i+α) は SLgammaO の
+ -- elementwise 適用・lgammaΓ(k_i+1) は compile 時定数 (56.5 本命)。
+ -- ⚠ α は整数を避ける (lgammaApprox x+k=12 境界の FD 罠)。
+ let ysN = [2, 0, 5, 3, 1] :: [Double]
+ mNb :: HBM.ModelP ()
+ mNb = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ al <- HBM.sample "alpha" (HBM.Exponential 0.5)
+ mapM_ (\(i, (x, y)) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.NegativeBinomial
+ (exp (a + b * realToFrac x)) al) [y])
+ (zip [0 ..] (zip xs ysN))
+ names = HBM.sampleNames mNb
+ tmap = HBM.getTransforms mNb
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.6, -0.3, log 2.3]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mNb of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mNb names trans uvs
+ - HBM.logJointUnconstrained mNb names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mNb names trans uvs)
+ (adGradRef mNb names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mNb names trans uvs)
+ (centralGrad mNb names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 94): 行ごとに n が異なる ZeroInflatedBinomial が 1 group に merge され値/勾配一致" $ do
+ -- Phase 94 で SDZIBinom も n を行対応 Vector 化 (SDBinom と同型)。
+ -- y=0 行を含めて branch0 (仮想 y=0 密度 = 行ごとの n を使う) を発火させる。
+ let nsB = [10, 12, 8, 15, 6] :: [Double] -- 全て相異なる n
+ ysZ = [0, 7, 0, 8, 2] :: [Double] -- y=0 行 2 つで branch0 を経由
+ mZb :: HBM.ModelP ()
+ mZb = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ b <- HBM.sample "b" (HBM.Normal 0 5)
+ c <- HBM.sample "c" (HBM.Normal 0 5)
+ mapM_ (\(i, (x, (nn, y))) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.ZeroInflatedBinomial (round nn)
+ (1 / (1 + exp (negate c))) -- ψ = invLogit(c)
+ (1 / (1 + exp (negate (a + b * realToFrac x))))) [y])
+ (zip [0 ..] (zip xs (zip nsB ysZ)))
+ names = HBM.sampleNames mZb
+ tmap = HBM.getTransforms mZb
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [0.3, 0.8, -0.5]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mZb of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, fams, sObs) -> do
+ length gs `shouldBe` 1 -- ★Phase 94: n 別分裂が解消され 1 group
+ length fams `shouldBe` 0
+ Set.size sObs `shouldBe` 5
+ abs (HBM.compileLogPU mZb names trans uvs
+ - HBM.logJointUnconstrained mZb names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mZb names trans uvs)
+ (adGradRef mZb names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mZb names trans uvs)
+ (centralGrad mZb names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 90 A10): raw potential (同型 Σ チェーン) が VGPot 吸収され値/勾配一致" $ do
+ -- BYM2 ミニ形 (13-traffic の縮小同型): Poisson 尤度 + icar ペア差分
+ -- potential (12 項 ≥ potSumThreshold) + ソフトゼロ和 potential (内部
+ -- Σφ = 10 項)。 両 potential が USum ベクトル化で VGPot に吸収され
+ -- 残差 ad ゼロ。 値/勾配が従来 ad・中心差分と一致。
+ let nA = 10 :: Int
+ edges = [ (i, i + 1) | i <- [0 .. 8] ] ++ [(0, 5), (2, 7), (4, 9)]
+ ysB = [1, 0, 2, 1, 3, 0, 1, 2, 1, 0] :: [Double]
+ mB :: HBM.ModelP ()
+ mB = do
+ b0 <- HBM.sample "b0" (HBM.Normal 0 1)
+ sg <- HBM.sample "sg" (HBM.HalfNormal 1)
+ phis <- mapM (\i -> HBM.sample (T.pack ("phi_" ++ show (i :: Int)))
+ (HBM.Normal 0 10)) [0 .. nA - 1]
+ mapM_ (\(i, y) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Poisson (exp (b0 + (phis !! i) * sg))) [y])
+ (zip [0 ..] ysB)
+ HBM.potential "icar" (negate 0.5 * sum
+ [ (phis !! a - phis !! b) * (phis !! a - phis !! b)
+ | (a, b) <- edges ])
+ HBM.potential "szero"
+ (HBM.logDensity (HBM.Normal 0 0.01) (sum phis))
+ names = HBM.sampleNames mB
+ tmap = HBM.getTransforms mB
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [ 0.05 + 0.03 * fromIntegral i
+ | i <- [0 .. length names - 1] ]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mB of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, _fams, sObs) -> do
+ length gs `shouldBe` 3 -- Poisson 群 + VGPot ×2
+ ("icar" `Set.member` sObs) `shouldBe` True
+ ("szero" `Set.member` sObs) `shouldBe` True
+ abs (HBM.compileLogPU mB names trans uvs
+ - HBM.logJointUnconstrained mB names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mB names trans uvs)
+ (adGradRef mB names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mB names trans uvs)
+ (centralGrad mB names trans uvs) `shouldBe` True
+
+ it "synthVecIR (Phase 90 A10): unify 不能な大チェーン potential は残差 ad に残り値/勾配一致" $ do
+ -- 項の形が交互に違う (φa·φb と (φa-φb)²) 12 項チェーン → unifyManyD
+ -- 失敗 → その potential は吸収されず残差 ad が担う (安全方向)。
+ -- Poisson 群は吸収されたまま・二重計上/脱落なく値/勾配一致。
+ let nA = 10 :: Int
+ edges = [ (i, i + 1) | i <- [0 .. 8] ] ++ [(0, 5), (2, 7), (4, 9)]
+ ysB = [1, 0, 2, 1, 3, 0, 1, 2, 1, 0] :: [Double]
+ mB :: HBM.ModelP ()
+ mB = do
+ b0 <- HBM.sample "b0" (HBM.Normal 0 1)
+ sg <- HBM.sample "sg" (HBM.HalfNormal 1)
+ phis <- mapM (\i -> HBM.sample (T.pack ("phi_" ++ show (i :: Int)))
+ (HBM.Normal 0 10)) [0 .. nA - 1]
+ mapM_ (\(i, y) ->
+ HBM.observe (T.pack ("y_" ++ show (i :: Int)))
+ (HBM.Poisson (exp (b0 + (phis !! i) * sg))) [y])
+ (zip [0 ..] ysB)
+ HBM.potential "mixpot" (negate 0.5 * sum
+ [ if even k
+ then (phis !! a) * (phis !! b)
+ else (phis !! a - phis !! b) * (phis !! a - phis !! b)
+ | (k, (a, b)) <- zip [0 :: Int ..] edges ])
+ names = HBM.sampleNames mB
+ tmap = HBM.getTransforms mB
+ trans = [ tmap M.! n | n <- names ]
+ uvs = [ 0.05 + 0.03 * fromIntegral i
+ | i <- [0 .. length names - 1] ]
+ pU = M.fromList (zip names uvs)
+ case HBM.synthVecIR mB of
+ Nothing -> expectationFailure "synthVecIR: expected Just"
+ Just (gs, _fams, sObs) -> do
+ length gs `shouldBe` 1 -- Poisson 群のみ (VGPot 無し)
+ ("mixpot" `Set.member` sObs) `shouldBe` False
+ abs (HBM.compileLogPU mB names trans uvs
+ - HBM.logJointUnconstrained mB names trans pU) < 1e-9 `shouldBe` True
+ closeVec 1e-9 (HBM.gradADU mB names trans uvs)
+ (adGradRef mB names trans uvs) `shouldBe` True
+ closeVec 1e-4 (HBM.gradADU mB names trans uvs)
+ (centralGrad mB names trans uvs) `shouldBe` True
diff --git a/test/Hanalyze/Model/HBMSpec.hs b/test/Hanalyze/Model/HBMSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/HBMSpec.hs
@@ -0,0 +1,1601 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.HBMSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Data.Map.Strict as M
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Core as Core
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.MCMC.NUTS as NUTS
+import qualified Hanalyze.MCMC.Core as Core
+import qualified Hanalyze.Model.HBM as HBM
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.HBM Distribution (Phase 37-A2: 連続 4 分布)" $ do
+ let isClose eps a b = abs (a - b) < eps
+ --
+ -- SkewNormal: α=0 で標準正規一致、 α>0 で右側に質量
+ --
+ it "SkewNormal(0,1,0) は Normal(0,1) と一致する (α=0、 erfA 近似誤差 ~1e-9)" $ do
+ let p = HBM.logDensity (HBM.SkewNormal 0 1 0 :: HBM.Distribution Double) 0
+ isClose 1e-8 p (-0.9189385332046727) `shouldBe` True
+ it "SkewNormal(0,1,5) は x=+1 で x=-1 より大きい (右側に歪み)" $ do
+ let pPos = HBM.logDensity (HBM.SkewNormal 0 1 5 :: HBM.Distribution Double) 1
+ pNeg = HBM.logDensity (HBM.SkewNormal 0 1 5 :: HBM.Distribution Double) (-1)
+ (pPos > pNeg) `shouldBe` True
+ it "SkewNormal(0,1,0) の sample 1000 個で 0 付近に集中" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.SkewNormal 0 1 0) gen) [1..1000::Int]
+ let mean = sum xs / 1000
+ isClose 0.1 mean 0 `shouldBe` True
+ --
+ -- Logistic: μ=0, s=1 で logpdf(0) = -log 4、 CDF(0) = 0.5
+ --
+ it "Logistic(0,1) logDensity(0) = -log 4" $ do
+ let p = HBM.logDensity (HBM.Logistic 0 1 :: HBM.Distribution Double) 0
+ isClose 1e-9 p (- log 4) `shouldBe` True
+ it "Logistic(0,1) CDF(0) = 0.5" $ do
+ case HBM.distCDF (HBM.Logistic 0 1 :: HBM.Distribution Double) 0 of
+ Just c -> isClose 1e-9 c 0.5 `shouldBe` True
+ Nothing -> expectationFailure "distCDF returned Nothing"
+ it "Logistic sample 1000 個で平均が μ=2 近傍" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.Logistic 2 1) gen) [1..1000::Int]
+ let mean = sum xs / 1000
+ isClose 0.2 mean 2 `shouldBe` True
+ --
+ -- Gumbel: μ=0, β=1 で logpdf(0) = -1、 CDF(0) = exp(-1)
+ --
+ it "Gumbel(0,1) logDensity(0) = -1" $ do
+ let p = HBM.logDensity (HBM.Gumbel 0 1 :: HBM.Distribution Double) 0
+ isClose 1e-9 p (-1) `shouldBe` True
+ it "Gumbel(0,1) CDF(0) = exp(-1)" $ do
+ case HBM.distCDF (HBM.Gumbel 0 1 :: HBM.Distribution Double) 0 of
+ Just c -> isClose 1e-9 c (exp (-1)) `shouldBe` True
+ Nothing -> expectationFailure "distCDF returned Nothing"
+ it "Gumbel(0,1) sample 2000 個で平均が μ + β·γ ≈ 0.5772 近傍" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.Gumbel 0 1) gen) [1..2000::Int]
+ let mean = sum xs / 2000
+ -- オイラー定数 γ ≈ 0.5772、 サンプル誤差 ~ β·π/√(6·n) ≈ 0.029
+ isClose 0.15 mean 0.5772156649 `shouldBe` True
+ --
+ -- AsymmetricLaplace: κ=1 で対称ラプラス、 logpdf(0) = -log 2、 CDF(0) = 0.5
+ --
+ it "AsymmetricLaplace(1,1,0) は対称ラプラス" $ do
+ let p1 = HBM.logDensity (HBM.AsymmetricLaplace 1 1 0 :: HBM.Distribution Double) 1
+ pN1 = HBM.logDensity (HBM.AsymmetricLaplace 1 1 0 :: HBM.Distribution Double) (-1)
+ isClose 1e-9 p1 pN1 `shouldBe` True
+ it "AsymmetricLaplace(1,1,0) logDensity(0) = -log 2" $ do
+ let p = HBM.logDensity (HBM.AsymmetricLaplace 1 1 0 :: HBM.Distribution Double) 0
+ isClose 1e-9 p (- log 2) `shouldBe` True
+ it "AsymmetricLaplace(1,1,0) CDF(0) = 0.5 (κ=1 で対称)" $ do
+ case HBM.distCDF (HBM.AsymmetricLaplace 1 1 0 :: HBM.Distribution Double) 0 of
+ Just c -> isClose 1e-9 c 0.5 `shouldBe` True
+ Nothing -> expectationFailure "distCDF returned Nothing"
+ it "AsymmetricLaplace(1,2,0) は右側裾長 (κ=2 で正側に長い尾)" $ do
+ -- κ=2 で正の x の方が log density 高いが、 大きい値で右側が遅く減衰
+ let p_3pos = HBM.logDensity (HBM.AsymmetricLaplace 1 2 0 :: HBM.Distribution Double) 3
+ p_3neg = HBM.logDensity (HBM.AsymmetricLaplace 1 2 0 :: HBM.Distribution Double) (-3)
+ -- x=+3 では -b·κ·3 = -6、 x=-3 では (b/κ)·(-3) = -1.5
+ -- → x=-3 の方が log density 高い (左側裾は短く局在)
+ (p_3neg > p_3pos) `shouldBe` True
+ it "AsymmetricLaplace(1,1,5) sample 2000 個で平均が μ=5 近傍" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.AsymmetricLaplace 1 1 5) gen) [1..2000::Int]
+ let mean = sum xs / 2000
+ isClose 0.2 mean 5 `shouldBe` True
+
+ describe "Hanalyze.Model.HBM Distribution (Phase 37-A3: 離散 5 分布)" $ do
+ let isClose eps a b = abs (a - b) < eps
+ --
+ -- OrderedLogistic: K=3 (cuts=[c1, c2]) で 3 カテゴリ
+ --
+ it "OrderedLogistic(η=0, cuts=[-1,1]) は 3 カテゴリの確率総和 1" $ do
+ let d = HBM.OrderedLogistic 0 [-1, 1] :: HBM.Distribution Double
+ p0 = exp (HBM.logDensityObs d 0)
+ p1 = exp (HBM.logDensityObs d 1)
+ p2 = exp (HBM.logDensityObs d 2)
+ isClose 1e-9 (p0 + p1 + p2) 1 `shouldBe` True
+ it "OrderedLogistic(η=0, cuts=[-1,1]) は対称 (P(0) = P(2))" $ do
+ let d = HBM.OrderedLogistic 0 [-1, 1] :: HBM.Distribution Double
+ p0 = exp (HBM.logDensityObs d 0)
+ p2 = exp (HBM.logDensityObs d 2)
+ isClose 1e-9 p0 p2 `shouldBe` True
+ it "OrderedLogistic(η=2, cuts=[-1,1]) は P(2) > P(0) (η 増 → 高カテゴリ寄り)" $ do
+ let d = HBM.OrderedLogistic 2 [-1, 1] :: HBM.Distribution Double
+ p0 = exp (HBM.logDensityObs d 0)
+ p2 = exp (HBM.logDensityObs d 2)
+ (p2 > p0) `shouldBe` True
+ --
+ -- DiscreteUniform: 0..9 で logpmf = -log 10
+ --
+ it "DiscreteUniform(0,9) logpmf(5) = -log 10" $ do
+ let p = HBM.logDensityObs (HBM.DiscreteUniform 0 9 :: HBM.Distribution Double) 5
+ isClose 1e-9 p (- log 10) `shouldBe` True
+ it "DiscreteUniform(0,9) range 外で logpmf = -∞" $ do
+ let p = HBM.logDensityObs (HBM.DiscreteUniform 0 9 :: HBM.Distribution Double) 10
+ isInfinite p && p < 0 `shouldBe` True
+ it "DiscreteUniform(0,9) sample 1000 個で全カテゴリが現れる" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.DiscreteUniform 0 9) gen) [1..1000::Int]
+ let unique = length (foldr (\x acc -> if x `elem` acc then acc else x:acc) [] xs)
+ (unique >= 9) `shouldBe` True
+ --
+ -- Geometric: PyMC 慣例 (support 1, 2, ...)
+ --
+ it "Geometric(0.5) logpmf(1) = log 0.5" $ do
+ let p = HBM.logDensityObs (HBM.Geometric 0.5 :: HBM.Distribution Double) 1
+ isClose 1e-9 p (log 0.5) `shouldBe` True
+ it "Geometric(0.5) logpmf(3) = 3 log 0.5" $ do
+ let p = HBM.logDensityObs (HBM.Geometric 0.5 :: HBM.Distribution Double) 3
+ isClose 1e-9 p (3 * log 0.5) `shouldBe` True
+ it "Geometric(0.5) sample 2000 個の平均が 1/p = 2 近傍" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.Geometric 0.5) gen) [1..2000::Int]
+ let mean = sum xs / 2000
+ isClose 0.2 mean 2 `shouldBe` True
+ --
+ -- HyperGeometric(N=10, K=5, n=3): k=2 で scipy ≈ 0.4167
+ -- C(5,2)*C(5,1)/C(10,3) = 10 * 5 / 120 = 50/120 = 0.4167
+ --
+ it "HyperGeometric(10,5,3) pmf(2) ≈ 0.4167" $ do
+ let p = exp (HBM.logDensityObs (HBM.HyperGeometric 10 5 3 :: HBM.Distribution Double) 2)
+ isClose 1e-6 p (50 / 120) `shouldBe` True
+ it "HyperGeometric(10,5,3) pmf 0..3 総和 = 1" $ do
+ let d = HBM.HyperGeometric 10 5 3 :: HBM.Distribution Double
+ tot = sum [exp (HBM.logDensityObs d (realToFrac k)) | k <- [0..3 :: Int]]
+ isClose 1e-9 tot 1 `shouldBe` True
+ --
+ -- ZeroInflatedNegativeBinomial: ψ=0 で NegBin と一致
+ --
+ it "ZeroInflatedNegativeBinomial(0, 5, 2) は NegativeBinomial(5,2) と一致 (ψ=0)" $ do
+ let d1 = HBM.ZeroInflatedNegativeBinomial 0 5 2 :: HBM.Distribution Double
+ d2 = HBM.NegativeBinomial 5 2 :: HBM.Distribution Double
+ p1 = HBM.logDensityObs d1 3
+ p2 = HBM.logDensityObs d2 3
+ isClose 1e-9 p1 p2 `shouldBe` True
+ it "ZeroInflatedNegativeBinomial(0.3, 5, 2) は P(y=0) が NegBin より大きい" $ do
+ let d1 = HBM.ZeroInflatedNegativeBinomial 0.3 5 2 :: HBM.Distribution Double
+ d2 = HBM.NegativeBinomial 5 2 :: HBM.Distribution Double
+ p1 = exp (HBM.logDensityObs d1 0)
+ p2 = exp (HBM.logDensityObs d2 0)
+ (p1 > p2) `shouldBe` True
+ it "ZeroInflatedNegativeBinomial(0.3, 3, 2) sample 2000 個で 0 比率 ≈ 0.3 + (1-0.3)·NegBin(0)" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.ZeroInflatedNegativeBinomial 0.3 3 2) gen) [1..2000::Int]
+ let zeros = length (filter (== 0) xs)
+ rate0 = realToFrac zeros / 2000
+ -- 期待される P(0): 0.3 + 0.7 * (2/(2+3))^2 = 0.3 + 0.7 * 0.16 = 0.412
+ expectedP0 = 0.3 + 0.7 * (2 / 5) ** 2
+ (abs (rate0 - expectedP0) < 0.05) `shouldBe` True
+
+ describe "Hanalyze.Model.HBM Distribution (Phase 37-A4: 多変量 2 分布)" $ do
+ let isClose eps a b = abs (a - b) < eps
+ --
+ -- MvStudentT(ν=10, μ=[0,0], Σ=I) at y=[0,0]: scipy ≈ -1.8379
+ --
+ it "MvStudentT(ν=10, μ=[0,0], Σ=I) logpdf([0,0]) ≈ -1.8379 (scipy)" $ do
+ let p = HBM.mvStudentTLogDensity 10
+ ([0, 0] :: [Double])
+ [[1, 0], [0, 1]]
+ [0, 0]
+ isClose 1e-3 p (-1.8379) `shouldBe` True
+ it "MvStudentT(ν=1000) は MvNormal に漸近 (logpdf at [0,0] ≈ −log(2π))" $ do
+ let pT = HBM.mvStudentTLogDensity 1000
+ ([0, 0] :: [Double])
+ [[1, 0], [0, 1]]
+ [0, 0]
+ pN = HBM.mvNormalLogDensity
+ ([0, 0] :: [Double])
+ [[1, 0], [0, 1]]
+ [0, 0]
+ -- ν=1000 で diff ~ 1e-3 オーダ
+ (abs (pT - pN) < 0.01) `shouldBe` True
+ it "MvStudentT は中心で density が周辺より大きい" $ do
+ let pCenter = HBM.mvStudentTLogDensity 5
+ ([0, 0] :: [Double])
+ [[1, 0], [0, 1]]
+ [0, 0]
+ pEdge = HBM.mvStudentTLogDensity 5
+ ([0, 0] :: [Double])
+ [[1, 0], [0, 1]]
+ [3, 3]
+ (pCenter > pEdge) `shouldBe` True
+ --
+ -- DirichletMultinomial(n=2, α=[1,1,1]) at counts=[1,1,0]: scipy = log(1/6) ≈ -1.7918
+ --
+ it "DirichletMultinomial(n=2, α=[1,1,1]) pmf([1,1,0]) = 1/6" $ do
+ let p = HBM.dirichletMultinomialLogDensity 2
+ ([1, 1, 1] :: [Double])
+ [1, 1, 0]
+ isClose 1e-9 p (log (1/6)) `shouldBe` True
+ it "DirichletMultinomial(n=2, α=[1,1,1]) は全 6 種類の組合せ確率総和 = 1" $ do
+ let combos = [[2,0,0],[0,2,0],[0,0,2],[1,1,0],[1,0,1],[0,1,1]]
+ tot = sum [ exp (HBM.dirichletMultinomialLogDensity 2
+ ([1, 1, 1] :: [Double]) c)
+ | c <- combos ]
+ isClose 1e-9 tot 1 `shouldBe` True
+ it "DirichletMultinomial(n=3, α=[1,1,1,1]) total prob = 1 (10 種)" $ do
+ let combos = [ [c0, c1, c2, c3]
+ | c0 <- [0..3], c1 <- [0..3-c0]
+ , c2 <- [0..3-c0-c1]
+ , let c3 = 3 - c0 - c1 - c2
+ , c3 >= 0 ]
+ tot = sum [ exp (HBM.dirichletMultinomialLogDensity 3
+ ([1, 1, 1, 1] :: [Double]) c)
+ | c <- combos ]
+ isClose 1e-9 tot 1 `shouldBe` True
+ --
+ -- obsLogSum 経由で MvStudentT が k 次元 chunk として処理されることを確認
+ --
+ it "obsLogSum (MvStudentT) は 2 観測 (k=2、 flat 4 要素) を 2 個の log と一致" $ do
+ let dist = HBM.MvStudentT 10 ([0, 0] :: [Double]) [[1, 0], [0, 1]]
+ flat = [0, 0, 1, 1]
+ summed = HBM.obsLogSum dist flat
+ p1 = HBM.mvStudentTLogDensity 10 [0,0] [[1,0],[0,1]] [0,0]
+ p2 = HBM.mvStudentTLogDensity 10 [0,0] [[1,0],[0,1]] [1,1]
+ isClose 1e-9 summed (p1 + p2) `shouldBe` True
+
+ describe "Hanalyze.Model.HBM Distribution (Phase 39-A1: 連続 3 + 離散 1)" $ do
+ let isClose eps a b = abs (a - b) < eps
+ --
+ -- Triangular: lower=0, c=0.5, upper=1
+ -- pdf(0.5) = 2/(1·0.5) = 4 -> logpdf = log 4
+ -- CDF closed-form via inverse sample test (平均 ≈ (lo+c+hi)/3)
+ --
+ it "Triangular(0,0.5,1) logDensity(0.5) = log 2 (peak pdf = 2/(hi-lo))" $ do
+ let p = HBM.logDensity (HBM.Triangular 0 0.5 1 :: HBM.Distribution Double) 0.5
+ isClose 1e-9 p (log 2) `shouldBe` True
+ it "Triangular(0,0.5,1) は範囲外 (-0.1) で −∞" $ do
+ let p = HBM.logDensity (HBM.Triangular 0 0.5 1 :: HBM.Distribution Double) (-0.1)
+ (p < -1e10) `shouldBe` True
+ it "Triangular(0,0.5,1) sample 2000 個で平均 ≈ 0.5 (= (0+0.5+1)/3)" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.Triangular 0 0.5 1) gen) [1..2000::Int]
+ let mean = sum xs / 2000
+ isClose 0.05 mean 0.5 `shouldBe` True
+ --
+ -- Kumaraswamy(a=1, b=1) は uniform(0,1)
+ -- logpdf(0.5) = log 1 + log 1 + 0 + 0 = 0
+ --
+ it "Kumaraswamy(1,1) は Uniform(0,1) (logDensity = 0)" $ do
+ let p = HBM.logDensity (HBM.Kumaraswamy 1 1 :: HBM.Distribution Double) 0.5
+ isClose 1e-9 p 0 `shouldBe` True
+ it "Kumaraswamy(2,2) logDensity(0.5)" $ do
+ -- pdf(0.5) = 2*2*0.5*(1-0.25) = 4*0.5*0.75 = 1.5
+ let p = HBM.logDensity (HBM.Kumaraswamy 2 2 :: HBM.Distribution Double) 0.5
+ isClose 1e-9 p (log 1.5) `shouldBe` True
+ it "Kumaraswamy(2,2) sample 2000 個で平均が ~0.5 近傍" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.Kumaraswamy 2 2) gen) [1..2000::Int]
+ let mean = sum xs / 2000
+ -- E[X] = b * B(1+1/a, b) = 2 * B(1.5, 2) = 2 * Γ(1.5)Γ(2)/Γ(3.5)
+ -- = 2 * 0.8862269 * 1 / 3.3233509 = 0.5333...
+ isClose 0.05 mean 0.5333333 `shouldBe` True
+ --
+ -- Rice(ν=0, σ) は Rayleigh(σ)、 pdf(x) = (x/σ²) exp(-x²/(2σ²))
+ -- x=σ=1: logpdf = log 1 - 0 - 0.5 + logI0(0) = -0.5
+ --
+ it "Rice(0,1) logDensity(1) = -0.5 (Rayleigh、 I0(0)=1)" $ do
+ let p = HBM.logDensity (HBM.Rice 0 1 :: HBM.Distribution Double) 1
+ isClose 1e-7 p (-0.5) `shouldBe` True
+ it "Rice(0,1) sample 2000 個で平均 ≈ σ·√(π/2) ≈ 1.2533 (Rayleigh 平均)" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.Rice 0 1) gen) [1..2000::Int]
+ let mean = sum xs / 2000
+ isClose 0.05 mean 1.2533141 `shouldBe` True
+ it "Rice(2,1) sample 2000 個で平均 > Rice(0,1) 平均 (ν>0 で右シフト)" $ do
+ gen <- MWC.create
+ xs0 <- mapM (\_ -> HBM.sampleDist (HBM.Rice 0 1) gen) [1..2000::Int]
+ xs2 <- mapM (\_ -> HBM.sampleDist (HBM.Rice 2 1) gen) [1..2000::Int]
+ (sum xs2 > sum xs0) `shouldBe` True
+ --
+ -- DiscreteWeibull(q=0.5, β=1) は Geometric(p=0.5) (PyMC 慣例の {0,1,...})
+ -- pmf(0) = q^0 - q^1 = 1 - 0.5 = 0.5
+ -- pmf(1) = q^1 - q^4 (β=1) で q^1 - q^2 = 0.5 - 0.25 = 0.25
+ --
+ it "DiscreteWeibull(0.5, 1) pmf(0) = 0.5" $ do
+ let p = exp (HBM.logDensityObs (HBM.DiscreteWeibull 0.5 1 :: HBM.Distribution Double) 0)
+ isClose 1e-9 p 0.5 `shouldBe` True
+ it "DiscreteWeibull(0.5, 1) pmf(1) = 0.25" $ do
+ let p = exp (HBM.logDensityObs (HBM.DiscreteWeibull 0.5 1 :: HBM.Distribution Double) 1)
+ isClose 1e-9 p 0.25 `shouldBe` True
+ it "DiscreteWeibull(0.5, 1) pmf 0..30 総和 ≈ 1" $ do
+ let d = HBM.DiscreteWeibull 0.5 1 :: HBM.Distribution Double
+ tot = sum [exp (HBM.logDensityObs d (realToFrac k)) | k <- [0..30::Int]]
+ isClose 1e-6 tot 1 `shouldBe` True
+ it "DiscreteWeibull(0.5, 1) sample 2000 個で整数 (≥0) のみ" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.DiscreteWeibull 0.5 1) gen) [1..2000::Int]
+ (all (\x -> x >= 0 && x == fromIntegral (round x :: Int)) xs) `shouldBe` True
+ --
+ -- DAG: distDepsT は Phase 38 で確立した「新分布追加 4 箇所」 規律で網羅
+ --
+ it "Triangular の buildModelGraph: lo, c, hi → y の 3 edges" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ lo <- HBM.sample "lo" (HBM.Normal 0 1)
+ c <- HBM.sample "c" (HBM.Normal 0 1)
+ hi <- HBM.sample "hi" (HBM.Normal 0 1)
+ HBM.observe "y" (HBM.Triangular lo c hi) [0.5]
+ let g = HBM.buildModelGraph m
+ edges = HBM.mgEdges g
+ length [() | (s, t) <- edges, t == "y", s `elem` ["lo", "c", "hi"]] `shouldBe` 3
+ it "Rice の buildModelGraph: ν, σ → y の 2 edges" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ nu <- HBM.sample "nu" (HBM.HalfNormal 1)
+ sig <- HBM.sample "sig" (HBM.HalfNormal 1)
+ HBM.observe "y" (HBM.Rice nu sig) [1.0]
+ let g = HBM.buildModelGraph m
+ edges = HBM.mgEdges g
+ length [() | (s, t) <- edges, t == "y", s `elem` ["nu", "sig"]] `shouldBe` 2
+
+ describe "Hanalyze.Model.HBM Distribution (Phase 39-A2: Wishart)" $ do
+ let isClose eps a b = abs (a - b) < eps
+ --
+ -- Wishart(ν=3, V=I_2) at W=I_2:
+ -- logpdf = -3 log 2 - log(π/2) - 1 ≈ -3.5310
+ --
+ it "Wishart(3, I_2) logpdf(I_2) ≈ -3.531 (scipy.stats.wishart 同等)" $ do
+ let p = HBM.wishartLogDensity 3
+ ([[1, 0], [0, 1]] :: [[Double]])
+ [1, 0, 0, 1] -- W = I_2 flatten
+ isClose 1e-4 p (-2 * log 2 - log pi - 1) `shouldBe` True
+ --
+ -- ν < k で degenerate (-∞)
+ --
+ it "Wishart(ν=0) は degenerate (logpdf = -∞)" $ do
+ let p = HBM.wishartLogDensity 0
+ ([[1, 0], [0, 1]] :: [[Double]])
+ [1, 0, 0, 1]
+ (p < -1e10) `shouldBe` True
+ --
+ -- V≠I のスケール変換: V = 2I で logpdf がシフトする
+ -- logpdf = -3 log 2 - (3/2) log|2I| - log Γ_2(3/2) - (1/2) tr((2I)⁻¹ I)
+ -- = -3 log 2 - (3/2)(2 log 2) - log(π/2) - 0.5
+ -- = -3 log 2 - 3 log 2 - log(π/2) - 0.5
+ -- = -6 log 2 - log π + log 2 - 0.5
+ -- = -5 log 2 - log π - 0.5
+ --
+ it "Wishart(3, 2·I_2) logpdf(I_2) で V スケール反映" $ do
+ let p = HBM.wishartLogDensity 3
+ ([[2, 0], [0, 2]] :: [[Double]])
+ [1, 0, 0, 1]
+ isClose 1e-4 p (-5 * log 2 - log pi - 0.5) `shouldBe` True
+ --
+ -- obsLogSum 経由: 2 観測 (k=2、 flat 8 要素) を 2 個の log と一致
+ --
+ it "obsLogSum (Wishart) は 2 観測 (flat 8 要素) を 2 個の log と一致" $ do
+ let dist = HBM.Wishart 3 ([[1, 0], [0, 1]] :: [[Double]])
+ flat = [1, 0, 0, 1, 2, 0, 0, 2]
+ summed = HBM.obsLogSum dist flat
+ p1 = HBM.wishartLogDensity 3 [[1,0],[0,1]] [1, 0, 0, 1]
+ p2 = HBM.wishartLogDensity 3 [[1,0],[0,1]] [2, 0, 0, 2]
+ isClose 1e-9 summed (p1 + p2) `shouldBe` True
+ --
+ -- DAG: ν, V → y のエッジ
+ --
+ it "Wishart の buildModelGraph: ν, V 各要素 → y のエッジ" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ nu <- HBM.sample "nu" (HBM.HalfNormal 5)
+ v00 <- HBM.sample "v00" (HBM.HalfNormal 1)
+ v11 <- HBM.sample "v11" (HBM.HalfNormal 1)
+ HBM.observeMV "y"
+ (HBM.Wishart nu [[v00, 0], [0, v11]])
+ [[1, 0, 0, 1]]
+ let g = HBM.buildModelGraph m
+ edges = HBM.mgEdges g
+ length [() | (s, t) <- edges, t == "y", s `elem` ["nu", "v00", "v11"]] `shouldBe` 3
+
+ describe "Hanalyze.Model.HBM Distribution (Phase 39-A3: Bound + OrderedProbit)" $ do
+ let isClose eps a b = abs (a - b) < eps
+ --
+ -- Bound = Truncated と同等
+ --
+ it "Bound(Normal(0,1), 0, +∞) は Truncated と同じ logDensity" $ do
+ let p1 = HBM.logDensity (HBM.Bound (HBM.Normal 0 1) (Just 0) Nothing :: HBM.Distribution Double) 1
+ p2 = HBM.logDensity (HBM.Truncated (HBM.Normal 0 1) (Just 0) Nothing :: HBM.Distribution Double) 1
+ isClose 1e-12 p1 p2 `shouldBe` True
+ it "Bound(Normal(0,1), 0, ∞) は範囲外 (-1) で −∞" $ do
+ let p = HBM.logDensity (HBM.Bound (HBM.Normal 0 1) (Just 0) Nothing :: HBM.Distribution Double) (-1)
+ (p < -1e10) `shouldBe` True
+ it "Bound sample (rejection) は範囲内に収まる" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.Bound (HBM.Normal 0 1) (Just 0) (Just 2)) gen) [1..500::Int]
+ (all (\x -> x >= 0 && x <= 2) xs) `shouldBe` True
+ --
+ -- OrderedProbit: K=3 (cuts=[c1, c2]) で 3 カテゴリの確率総和 1
+ --
+ it "OrderedProbit(η=0, cuts=[-1,1]) は 3 カテゴリの確率総和 1" $ do
+ let d = HBM.OrderedProbit 0 [-1, 1] :: HBM.Distribution Double
+ p0 = exp (HBM.logDensityObs d 0)
+ p1 = exp (HBM.logDensityObs d 1)
+ p2 = exp (HBM.logDensityObs d 2)
+ isClose 1e-9 (p0 + p1 + p2) 1 `shouldBe` True
+ it "OrderedProbit(η=0, cuts=[-1,1]) は中央カテゴリの確率最大 (対称)" $ do
+ let d = HBM.OrderedProbit 0 [-1, 1] :: HBM.Distribution Double
+ p0 = exp (HBM.logDensityObs d 0)
+ p1 = exp (HBM.logDensityObs d 1)
+ p2 = exp (HBM.logDensityObs d 2)
+ (p1 > p0 && p1 > p2) `shouldBe` True
+ it "OrderedProbit(η=2, cuts=[-1,1]) は最大カテゴリ寄り (右シフト)" $ do
+ -- η=2: P(y=2) = 1 - Φ(1 - 2) = 1 - Φ(-1) ≈ 0.841
+ let d = HBM.OrderedProbit 2 [-1, 1] :: HBM.Distribution Double
+ p2 = exp (HBM.logDensityObs d 2)
+ isClose 0.01 p2 0.8413 `shouldBe` True
+ it "OrderedProbit sample 2000 個で全カテゴリ {0,1,2} に分布" $ do
+ gen <- MWC.create
+ xs <- mapM (\_ -> HBM.sampleDist (HBM.OrderedProbit 0 [-1, 1]) gen) [1..2000::Int]
+ let cats = [ length (filter (== fromIntegral k) xs) | k <- [0..2 :: Int]]
+ (all (> 0) cats) `shouldBe` True
+ --
+ -- DAG
+ --
+ it "OrderedProbit の buildModelGraph: η, cuts → y" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ eta <- HBM.sample "eta" (HBM.Normal 0 1)
+ c1 <- HBM.sample "c1" (HBM.Normal 0 1)
+ c2 <- HBM.sample "c2" (HBM.Normal 0 1)
+ HBM.observe "y" (HBM.OrderedProbit eta [c1, c2]) [0, 1, 2]
+ let g = HBM.buildModelGraph m
+ edges = HBM.mgEdges g
+ length [() | (s, t) <- edges, t == "y", s `elem` ["eta", "c1", "c2"]] `shouldBe` 3
+
+ describe "Hanalyze.Model.HBM.orderedCuts (Phase 39-A6)" $ do
+ --
+ -- orderedCuts は increasing 列を deterministic で生成
+ --
+ it "orderedCuts: K-1=3 で長さ 3 の Track 列、 d_i は latent として登録" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ cs <- HBM.orderedCuts "cuts" 3 (-1) 1
+ -- 観測なし (構造のみ確認)
+ HBM.observe "y" (HBM.OrderedLogistic 0 cs) [0, 1, 2, 3]
+ let g = HBM.buildModelGraph m
+ nodes = HBM.mgNodes g
+ nodeNames = map HBM.nodeName nodes
+ -- 期待: cuts_c_1, cuts_d_2, cuts_c_2, cuts_d_3, cuts_c_3, y
+ elem "cuts_c_1" nodeNames `shouldBe` True
+ elem "cuts_d_2" nodeNames `shouldBe` True
+ elem "cuts_c_2" nodeNames `shouldBe` True
+ elem "cuts_d_3" nodeNames `shouldBe` True
+ elem "cuts_c_3" nodeNames `shouldBe` True
+ it "orderedCuts: cuts は y の親に並ぶ (DAG-safe helper)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ cs <- HBM.orderedCuts "cuts" 2 0 1
+ HBM.observe "y" (HBM.OrderedLogistic 0 cs) [0, 1, 2]
+ let g = HBM.buildModelGraph m
+ edges = HBM.mgEdges g
+ -- y の親に cuts_c_1, cuts_c_2 が含まれる
+ elem ("cuts_c_1", "y") edges `shouldBe` True
+ elem ("cuts_c_2", "y") edges `shouldBe` True
+ it "orderedCuts は sample 時に c_min から増加する列を返す" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ cs <- HBM.orderedCuts "cuts" 3 (-2) 0.5
+ -- 戻り値をそのまま使うため observe で形だけ束縛 (drift 防止に gen=()
+ -- は使わず deterministic 確認は sampleNames 経由)
+ HBM.observe "y" (HBM.OrderedLogistic 0 cs) [0]
+ -- buildModelGraph 経由で deterministic ノード数を数える
+ let g = HBM.buildModelGraph m
+ dets = filter (\n -> HBM.nodeDist n == "Deterministic") (HBM.mgNodes g)
+ length dets `shouldBe` 3 -- c_1, c_2, c_3
+
+ describe "Hanalyze.Model.HBM.dpStickBreaking (Phase 39-A5)" $ do
+ --
+ -- T=5 で β_1..β_4 latent + stick_1..stick_5 det + pi_1..pi_5 det
+ --
+ it "dpStickBreaking T=5 α=1: β_1..β_4 + stick + π ノードが揃う" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ pis <- HBM.dpStickBreaking "dp" 5 1
+ HBM.observe "y" (HBM.Categorical pis) [0, 1, 2, 3, 4]
+ let g = HBM.buildModelGraph m
+ ns = map HBM.nodeName (HBM.mgNodes g)
+ all (`elem` ns) ["dp_b_1", "dp_b_2", "dp_b_3", "dp_b_4"] `shouldBe` True
+ all (`elem` ns) ["dp_pi_1", "dp_pi_2", "dp_pi_3", "dp_pi_4", "dp_pi_5"] `shouldBe` True
+ it "dpStickBreaking π の和は 1 (構造的、 任意 β で成立)" $ do
+ -- Track 経由のテスト: β_k = 0.5 固定で π_k の和を計算
+ -- stick_1 = 1
+ -- π_1 = 0.5 * 1 = 0.5
+ -- stick_2 = 1 * 0.5 = 0.5
+ -- π_2 = 0.5 * 0.5 = 0.25
+ -- stick_3 = 0.5 * 0.5 = 0.25
+ -- π_3 = 0.5 * 0.25 = 0.125
+ -- stick_4 = 0.25 * 0.5 = 0.125
+ -- π_4 = stick_4 = 0.125 (last)
+ -- 和: 0.5 + 0.25 + 0.125 + 0.125 = 1.0
+ let pis = let beta = 0.5
+ stk1 = 1
+ stk2 = stk1 * (1 - beta)
+ stk3 = stk2 * (1 - beta)
+ stk4 = stk3 * (1 - beta)
+ p1 = beta * stk1
+ p2 = beta * stk2
+ p3 = beta * stk3
+ p4 = stk4
+ in [p1, p2, p3, p4 :: Double]
+ sum pis `shouldBe` 1.0
+ it "dpStickBreaking T=3: pi_3 が y の親に含まれる (DAG-safe)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ pis <- HBM.dpStickBreaking "dp" 3 2
+ HBM.observe "y" (HBM.Categorical pis) [0, 1, 2]
+ let g = HBM.buildModelGraph m
+ edges = HBM.mgEdges g
+ elem ("dp_pi_1", "y") edges `shouldBe` True
+ elem ("dp_pi_2", "y") edges `shouldBe` True
+ elem ("dp_pi_3", "y") edges `shouldBe` True
+
+ describe "Hanalyze.Model.HBM.hmmForwardLogLik (Phase 39-A4)" $ do
+ let isClose eps a b = abs (a - b) < eps
+ --
+ -- 手計算確認 K=2, T=2:
+ -- π_0 = [0.6, 0.4]、 T = [[0.7, 0.3], [0.4, 0.6]]
+ -- emit (y_1=0, y_2=1): emit = [[log 0.5, log 0.1], [log 0.4, log 0.5]]
+ -- 直接列挙: Σ_{s0,s1} π_0[s0] e_0[s0] T[s0][s1] e_1[s1]
+ -- 0,0: 0.6 * 0.5 * 0.7 * 0.4 = 0.084
+ -- 0,1: 0.6 * 0.5 * 0.3 * 0.5 = 0.045
+ -- 1,0: 0.4 * 0.1 * 0.4 * 0.4 = 0.0064
+ -- 1,1: 0.4 * 0.1 * 0.6 * 0.5 = 0.012
+ -- sum = 0.1474 → log ≈ -1.9143
+ --
+ it "K=2, T=2 の周辺対数尤度が直接列挙と一致 (-1.9143)" $ do
+ let pi0 = [0.6, 0.4] :: [Double]
+ trans = [[0.7, 0.3], [0.4, 0.6]]
+ emit = [[log 0.5, log 0.1], [log 0.4, log 0.5]]
+ ll = HBM.hmmForwardLogLik pi0 trans emit
+ isClose 1e-9 ll (log 0.1474) `shouldBe` True
+ --
+ -- T=1 の自明ケース: log P(y_1) = logSumExp(log π_0[k] + emit[0][k])
+ --
+ it "T=1 で周辺対数尤度 = logSumExp(log π_0 + emit)" $ do
+ let pi0 = [0.7, 0.3] :: [Double]
+ tr = [[0.5, 0.5], [0.5, 0.5]]
+ emit = [[log 0.8, log 0.2]]
+ ll = HBM.hmmForwardLogLik pi0 tr emit
+ expected = log (0.7 * 0.8 + 0.3 * 0.2)
+ isClose 1e-9 ll expected `shouldBe` True
+ --
+ -- T=0 (観測なし) は 0
+ --
+ it "T=0 (空観測) は logLik = 0" $ do
+ let pi0 = [0.5, 0.5] :: [Double]
+ tr = [[0.5, 0.5], [0.5, 0.5]]
+ ll = HBM.hmmForwardLogLik pi0 tr ([] :: [[Double]])
+ ll `shouldBe` 0
+ --
+ -- 恒等遷移 (T = I) は各時刻独立: log P(y) = log Σ_k π_0[k] Π_t e_t[k]
+ --
+ it "恒等遷移 (絶対吸収) で π_0 と emission の積が正しく入る" $ do
+ let pi0 = [1.0, 0.0] :: [Double] -- 確実に状態 0 開始
+ tr = [[1.0, 0.0], [0.0, 1.0]] -- 状態固定
+ emit = [[log 0.5, log 0.9], [log 0.4, log 0.8]]
+ ll = HBM.hmmForwardLogLik pi0 tr emit
+ -- 状態 0 確定: P = 0.5 * 0.4 = 0.2
+ expected = log 0.2
+ isClose 1e-9 ll expected `shouldBe` True
+ --
+ -- 大 T (T=200) で underflow しない (log-space の効用)
+ --
+ it "T=200 で underflow せず有限値を返す (log-space)" $ do
+ let pi0 = [0.5, 0.5] :: [Double]
+ tr = [[0.9, 0.1], [0.1, 0.9]]
+ emit = replicate 200 [log 0.3, log 0.5]
+ ll = HBM.hmmForwardLogLik pi0 tr emit
+ -- 期待値ではなく「有限かつ負」 を確認
+ (ll < 0 && not (isInfinite ll) && not (isNaN ll)) `shouldBe` True
+
+ describe "Hanalyze.Model.HBM.hmmLatent (Phase 39-A4)" $ do
+ --
+ -- K=2 で pi0 + 2 trans rows = 3 Dirichlet が立つ
+ --
+ it "hmmLatent K=2 α=1: pi0 + trans_0, trans_1 の Dirichlet が立つ" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ (pi0, trans) <- HBM.hmmLatent "hmm" 2 1
+ -- emit の dummy 計算 (実用では emission 毎時刻で別々)
+ let emit = [[log (pi0 !! 0), log (pi0 !! 1)]]
+ tr = trans
+ HBM.potential "lik" (HBM.hmmForwardLogLik pi0 tr emit)
+ let g = HBM.buildModelGraph m
+ ns = map HBM.nodeName (HBM.mgNodes g)
+ -- pi0: hmm_pi0_0, hmm_pi0_1 (Dirichlet 内部の det)
+ elem "hmm_pi0_0" ns `shouldBe` True
+ elem "hmm_pi0_1" ns `shouldBe` True
+ -- trans: hmm_trans_0_0, hmm_trans_0_1, hmm_trans_1_0, hmm_trans_1_1
+ elem "hmm_trans_0_0" ns `shouldBe` True
+ elem "hmm_trans_1_1" ns `shouldBe` True
+ it "hmmLatent K=3 α=1: 3 + 9 = 12 個の π det ノード" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ (pi0, trans) <- HBM.hmmLatent "hmm" 3 1
+ let emit = [[log p | p <- pi0]]
+ HBM.potential "lik" (HBM.hmmForwardLogLik pi0 trans emit)
+ let g = HBM.buildModelGraph m
+ ns = map HBM.nodeName (HBM.mgNodes g)
+ -- 各 dirichlet は内部に β_b latent も持つので、 π det は
+ -- 末尾が数字のみ (β は _b 形)
+ isPiDet base n =
+ base `T.isPrefixOf` n
+ && case T.stripPrefix base n of
+ Just rest -> T.all (`elem` ("0123456789" :: String)) rest
+ Nothing -> False
+ piCnt = length [n | n <- ns, isPiDet "hmm_pi0_" n]
+ trCnt = sum
+ [ length [n | n <- ns, isPiDet ("hmm_trans_" <> T.pack (show i) <> "_") n]
+ | i <- [0..2 :: Int] ]
+ piCnt `shouldBe` 3 -- π_0[0..2]
+ trCnt `shouldBe` 9 -- 3 行 × 3 列
+
+ describe "Hanalyze.Model.HBM.plate (Phase 40-A1/A2)" $ do
+ --
+ -- 8-schools: plate "school" 8 で eta_j を囲う、 mu/tau は plate 外
+ --
+ let eightSchools :: HBM.ModelP ()
+ eightSchools = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 5)
+ tau <- HBM.sample "tau" (HBM.HalfCauchy 5)
+ _ <- HBM.plate "school" 8 $ forM [0..7 :: Int] $ \j -> do
+ eta <- HBM.sample ("eta_" <> T.pack (show j)) (HBM.Normal 0 1)
+ HBM.observe ("y_" <> T.pack (show j))
+ (HBM.Normal (mu + tau * eta) 1) [realToFrac j]
+ return ()
+ it "8-schools: mgPlates に \"school\" → 8 が入る" $ do
+ let g = HBM.buildModelGraph eightSchools
+ M.lookup "school" (HBM.mgPlates g) `shouldBe` Just 8
+ it "8-schools: mu / tau は nodePlates が空 (plate 外)" $ do
+ let g = HBM.buildModelGraph eightSchools
+ nByName nm = filter (\n -> HBM.nodeName n == nm) (HBM.mgNodes g)
+ case nByName "mu" of
+ [n] -> HBM.nodePlates n `shouldBe` []
+ _ -> expectationFailure "mu not found"
+ case nByName "tau" of
+ [n] -> HBM.nodePlates n `shouldBe` []
+ _ -> expectationFailure "tau not found"
+ it "8-schools: eta_j / y_j は nodePlates = [\"school\"]" $ do
+ let g = HBM.buildModelGraph eightSchools
+ nByName nm = filter (\n -> HBM.nodeName n == nm) (HBM.mgNodes g)
+ case nByName "eta_3" of
+ [n] -> HBM.nodePlates n `shouldBe` ["school"]
+ _ -> expectationFailure "eta_3 not found"
+ case nByName "y_5" of
+ [n] -> HBM.nodePlates n `shouldBe` ["school"]
+ _ -> expectationFailure "y_5 not found"
+ --
+ -- plateI 糖衣の動作確認
+ --
+ it "plateI helper: plate name n (forM [0..n-1] f) と同等" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ _ <- HBM.plateI "g" 3 $ \j ->
+ HBM.sample ("x_" <> T.pack (show j)) (HBM.Normal 0 1)
+ return ()
+ let g = HBM.buildModelGraph m
+ xPlate = [HBM.nodePlates n | n <- HBM.mgNodes g, HBM.nodeName n == "x_1"]
+ xPlate `shouldBe` [["g"]]
+ M.lookup "g" (HBM.mgPlates g) `shouldBe` Just 3
+ --
+ -- plateI_ 糖衣の動作確認 (返り値破棄版・plateForM_ name [0..n-1] と同等)
+ --
+ it "plateI_ helper: plate name n (forM_ [0..n-1] f) と同等" $ do
+ let m :: HBM.ModelP ()
+ m = HBM.plateI_ "g" 3 $ \j ->
+ HBM.sample ("x" HBM..# j) (HBM.Normal 0 1)
+ let g = HBM.buildModelGraph m
+ xPlate = [HBM.nodePlates n | n <- HBM.mgNodes g, HBM.nodeName n == "x_1"]
+ xPlate `shouldBe` [["g"]]
+ M.lookup "g" (HBM.mgPlates g) `shouldBe` Just 3
+ --
+ -- nested plate: outer "school" 3 内に inner "student" 2
+ --
+ it "nested plate: nodePlates が [\"school\", \"student\"] (外→内)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ _ <- HBM.plate "school" 3 $ forM_ [0..2 :: Int] $ \j ->
+ HBM.plate "student" 2 $ forM_ [0..1 :: Int] $ \i ->
+ HBM.sample ("y_" <> T.pack (show j) <> "_" <> T.pack (show i))
+ (HBM.Normal 0 1)
+ return ()
+ let g = HBM.buildModelGraph m
+ yNode = filter (\n -> HBM.nodeName n == "y_1_0") (HBM.mgNodes g)
+ case yNode of
+ [n] -> HBM.nodePlates n `shouldBe` ["school", "student"]
+ _ -> expectationFailure "y_1_0 not found"
+ M.lookup "school" (HBM.mgPlates g) `shouldBe` Just 3
+ M.lookup "student" (HBM.mgPlates g) `shouldBe` Just 2
+ --
+ -- 既存 helper (plate 未使用) との regression: nodePlates は空
+ --
+ it "既存モデル (plate 未使用) の nodePlates は空 (regression なし)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 1)
+ HBM.observe "y" (HBM.Normal mu 1) [0, 1, 2]
+ let g = HBM.buildModelGraph m
+ all (null . HBM.nodePlates) (HBM.mgNodes g) `shouldBe` True
+ M.null (HBM.mgPlates g) `shouldBe` True
+
+ describe "Hanalyze.Model.HBM ノード名ヘルパ (indexed / .#)" $ do
+ it "indexed はアンダースコア付きインデックス名を作る" $ do
+ HBM.indexed "theta" 1 `shouldBe` ("theta_1" :: T.Text)
+ HBM.indexed "y" 0 `shouldBe` ("y_0" :: T.Text)
+ it ".# は indexed の中置版 (= 同じ結果)" $
+ ("theta" HBM..# 3) `shouldBe` HBM.indexed "theta" 3
+ it "sample 名に使うと sampleNames に反映される" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 5)
+ _ <- HBM.sample (HBM.indexed "theta" 1) (HBM.Normal mu 1)
+ _ <- HBM.sample ("theta" HBM..# 2) (HBM.Normal mu 1)
+ pure ()
+ sort (HBM.sampleNames m) `shouldBe` sort ["mu", "theta_1", "theta_2"]
+
+ describe "Hanalyze.Model.HBM plate 罠 6 件 (Phase 40-A4)" $ do
+ --
+ -- 罠 1: 非中心化 (nonCentered) + plate
+ -- raw eta_raw + det eta が両方 plate "school" に属するべき
+ --
+ it "罠 1: nonCenteredNormal を plate 内で使うと raw + det 両方 plate" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 5)
+ tau <- HBM.sample "tau" (HBM.HalfCauchy 5)
+ _ <- HBM.plate "school" 4 $ forM_ [0..3 :: Int] $ \j -> do
+ eta <- HBM.nonCenteredNormal ("eta_" <> T.pack (show j)) mu tau
+ HBM.observe ("y_" <> T.pack (show j)) (HBM.Normal eta 1)
+ [realToFrac j]
+ return ()
+ let g = HBM.buildModelGraph m
+ nByName nm = filter (\n -> HBM.nodeName n == nm) (HBM.mgNodes g)
+ case nByName "eta_2_raw" of
+ [n] -> HBM.nodePlates n `shouldBe` ["school"]
+ _ -> expectationFailure "eta_2_raw not found"
+ case nByName "eta_2" of
+ [n] -> HBM.nodePlates n `shouldBe` ["school"]
+ _ -> expectationFailure "eta_2 not found"
+ --
+ -- 罠 2: 入れ子 plate (multi-level: school × student) は A2 で確認済
+ -- ここでは edge が境界を超えても plate 構造を壊さないことを確認
+ --
+ it "罠 2: nested plate で内側 edge は内 plate のまま" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ _ <- HBM.plate "school" 2 $ forM_ [0..1 :: Int] $ \j -> do
+ theta <- HBM.sample ("theta_" <> T.pack (show j))
+ (HBM.Normal 0 1)
+ _ <- HBM.plate "student" 2 $ forM_ [0..1 :: Int] $ \i ->
+ HBM.observe ("y_" <> T.pack (show j) <> "_" <> T.pack (show i))
+ (HBM.Normal theta 1) [realToFrac i]
+ return ()
+ return ()
+ let g = HBM.buildModelGraph m
+ nByName nm = filter (\n -> HBM.nodeName n == nm) (HBM.mgNodes g)
+ -- theta は school plate のみ
+ case nByName "theta_0" of
+ [n] -> HBM.nodePlates n `shouldBe` ["school"]
+ _ -> expectationFailure "theta_0 not found"
+ -- y_0_0 は school + student 両 plate
+ case nByName "y_0_0" of
+ [n] -> HBM.nodePlates n `shouldBe` ["school", "student"]
+ _ -> expectationFailure "y_0_0 not found"
+ --
+ -- 罠 3: クロス plate (subject × time): 重ならない 2 plate を別個に書く
+ -- (PyMC でも完全な交差は描けないので、 2 plate 並列のみ確認)
+ --
+ it "罠 3: crossed plate は 2 つの別々 plate として記録される" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ -- subject ごとの効果 (plate "subject" 3)
+ _ <- HBM.plate "subject" 3 $ forM_ [0..2 :: Int] $ \s ->
+ HBM.sample ("u_" <> T.pack (show s)) (HBM.Normal 0 1)
+ -- time ごとの効果 (plate "time" 2、 別 plate)
+ _ <- HBM.plate "time" 2 $ forM_ [0..1 :: Int] $ \t ->
+ HBM.sample ("v_" <> T.pack (show t)) (HBM.Normal 0 1)
+ return ()
+ let g = HBM.buildModelGraph m
+ M.lookup "subject" (HBM.mgPlates g) `shouldBe` Just 3
+ M.lookup "time" (HBM.mgPlates g) `shouldBe` Just 2
+ --
+ -- 罠 4: plate 外から plate 内 への edge (mu → eta_j × 8 本)
+ -- → mu の plate は [] / eta は plate ['school'] / edge は数本残る
+ --
+ it "罠 4: plate 外 mu から plate 内 eta_j への edge が複数本記録される" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 5)
+ _ <- HBM.plate "school" 3 $ forM_ [0..2 :: Int] $ \j ->
+ HBM.sample ("eta_" <> T.pack (show j)) (HBM.Normal mu 1)
+ return ()
+ let g = HBM.buildModelGraph m
+ edges = HBM.mgEdges g
+ muEdges = [() | (s, t) <- edges, s == "mu",
+ T.isPrefixOf "eta_" t]
+ length muEdges `shouldBe` 3
+ --
+ -- 罠 5: plate 内同士の edge (eta_j → y_j 同 plate)
+ --
+ it "罠 5: plate 内同士の edge (eta_j → y_j) が記録される" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ _ <- HBM.plate "school" 3 $ forM_ [0..2 :: Int] $ \j -> do
+ eta <- HBM.sample ("eta_" <> T.pack (show j))
+ (HBM.Normal 0 1)
+ HBM.observe ("y_" <> T.pack (show j)) (HBM.Normal eta 1)
+ [realToFrac j]
+ return ()
+ let g = HBM.buildModelGraph m
+ edges = HBM.mgEdges g
+ elem ("eta_0", "y_0") edges `shouldBe` True
+ elem ("eta_1", "y_1") edges `shouldBe` True
+ elem ("eta_2", "y_2") edges `shouldBe` True
+ --
+ -- 罠 6: observe の自動 merge と plate の整合
+ -- 同名 observe を統合する mergeByName は plate 内でも動く
+ -- (個別名 y_0..y_7 を使えば衝突なし)
+ --
+ it "罠 6: 同名 observe \"y\" の自動 merge と plate の整合" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 1)
+ -- plate 内で同じ "y" を 3 回 observe (mergeByName が 1 ノードに統合)
+ _ <- HBM.plate "obs" 3 $ forM_ [0..2 :: Int] $ \_ ->
+ HBM.observe "y" (HBM.Normal mu 1) [0]
+ return ()
+ let g = HBM.buildModelGraph m
+ ys = filter (\n -> HBM.nodeName n == "y") (HBM.mgNodes g)
+ length ys `shouldBe` 1
+ -- merge された y は最初の plate 状態を維持 (= ["obs"])
+ case ys of
+ [n] -> HBM.nodePlates n `shouldBe` ["obs"]
+ _ -> expectationFailure "y not found"
+
+ describe "既存 helper (dirichlet / glmm / ar1Latent) を plate で包む (Phase 40-A5)" $ do
+ --
+ -- B2 plate は既存 helper をそのまま囲うだけで plate-aware 化できる
+ -- (新規 helper 追加なし)。 これがメリット。
+ --
+ it "dirichlet を plate で包むと β / π すべてが plate メンバ" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ _ <- HBM.plate "K" 3 $ HBM.dirichlet "pi" [1, 1, 1]
+ return ()
+ let g = HBM.buildModelGraph m
+ ns = HBM.mgNodes g
+ piNodes = filter (\n -> "pi_" `T.isPrefixOf` HBM.nodeName n) ns
+ all (\n -> HBM.nodePlates n == ["K"]) piNodes `shouldBe` True
+ M.lookup "K" (HBM.mgPlates g) `shouldBe` Just 3
+ it "ar1Latent を plate で包むと x_raw_t / x_t すべてが plate メンバ" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ _ <- HBM.plate "T" 4 $ HBM.ar1Latent "x" 4 0.5 1
+ return ()
+ let g = HBM.buildModelGraph m
+ ns = HBM.mgNodes g
+ xNodes = filter (\n -> "x_" `T.isPrefixOf` HBM.nodeName n) ns
+ all (\n -> HBM.nodePlates n == ["T"]) xNodes `shouldBe` True
+ it "plate 入れ子で glmmRandomIntercept を使うと u_j のみ plate" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ -- glmmRandomIntercept は内部で複数 sample/observe を出すので、
+ -- plate "subject" J で包むと全てが plate メンバになる
+ let xs = [[1.0], [1.0], [1.0]] :: [[Double]]
+ gids = [0, 1, 0] :: [Int]
+ ys = [0.5, 1.0, 0.7] :: [Double]
+ _ <- HBM.plate "subject" 2 $
+ HBM.glmmRandomIntercept HBM.GlmmGaussian xs gids ys
+ return ()
+ let g = HBM.buildModelGraph m
+ ns = HBM.mgNodes g
+ uNodes = filter (\n -> "u_" `T.isPrefixOf` HBM.nodeName n) ns
+ -- u_j は全て plate "subject"
+ all (\n -> HBM.nodePlates n == ["subject"]) uNodes `shouldBe` True
+ -- 結論: 既存 helper 無変更で plate で包めば自動的に DAG にも plate 反映
+
+ describe "Hanalyze.Model.HBM.collapseIndexedPlateNodes (Phase 40-A8: PyMC 同等)" $ do
+ --
+ -- 8-schools collapse: eta_0..eta_7 → eta、 y_0..y_7 → y (n=8)
+ --
+ it "8-schools: collapse 後ノード数 = 4 (mu, tau, eta, y)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 5)
+ tau <- HBM.sample "tau" (HBM.HalfCauchy 5)
+ _ <- HBM.plate "school" 8 $ forM_ [0..7 :: Int] $ \j -> do
+ eta <- HBM.sample ("eta_" <> T.pack (show j)) (HBM.Normal 0 1)
+ HBM.observe ("y_" <> T.pack (show j))
+ (HBM.Normal (mu + tau * eta) 1) [realToFrac j]
+ return ()
+ let g = HBM.buildModelGraph m
+ gc = HBM.collapseIndexedPlateNodes g
+ names = map HBM.nodeName (HBM.mgNodes gc)
+ length (HBM.mgNodes gc) `shouldBe` 4
+ all (`elem` names) ["mu", "tau", "eta", "y"] `shouldBe` True
+ it "8-schools: 集約後 y の観測数 = 8" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ _ <- HBM.plate "school" 8 $ forM_ [0..7 :: Int] $ \j ->
+ HBM.observe ("y_" <> T.pack (show j)) (HBM.Normal 0 1)
+ [realToFrac j]
+ return ()
+ let gc = HBM.collapseIndexedPlateNodes (HBM.buildModelGraph m)
+ yNode = filter (\n -> HBM.nodeName n == "y") (HBM.mgNodes gc)
+ case yNode of
+ [n] -> HBM.nodeKind n `shouldBe` HBM.ObservedN 8
+ _ -> expectationFailure "y not found"
+ it "8-schools: 集約後 edges 3 本 (eta→y, mu→y, tau→y)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 5)
+ tau <- HBM.sample "tau" (HBM.HalfCauchy 5)
+ _ <- HBM.plate "school" 8 $ forM_ [0..7 :: Int] $ \j -> do
+ eta <- HBM.sample ("eta_" <> T.pack (show j)) (HBM.Normal 0 1)
+ HBM.observe ("y_" <> T.pack (show j))
+ (HBM.Normal (mu + tau * eta) 1) [realToFrac j]
+ return ()
+ let gc = HBM.collapseIndexedPlateNodes (HBM.buildModelGraph m)
+ length (HBM.mgEdges gc) `shouldBe` 3
+ elem ("eta", "y") (HBM.mgEdges gc) `shouldBe` True
+ elem ("mu", "y") (HBM.mgEdges gc) `shouldBe` True
+ elem ("tau", "y") (HBM.mgEdges gc) `shouldBe` True
+ --
+ -- nested multilevel: 不動点で 2 段集約
+ --
+ it "nested multilevel: 集約後 y は n=6 (J=3 × K=2)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ _ <- HBM.plate "school" 3 $ forM_ [0..2 :: Int] $ \j -> do
+ theta <- HBM.sample ("theta_" <> T.pack (show j))
+ (HBM.Normal 0 1)
+ _ <- HBM.plate "student" 2 $ forM_ [0..1 :: Int] $ \i ->
+ HBM.observe ("y_" <> T.pack (show j) <> "_" <> T.pack (show i))
+ (HBM.Normal theta 1) [realToFrac i]
+ return ()
+ return ()
+ let gc = HBM.collapseIndexedPlateNodes (HBM.buildModelGraph m)
+ yNode = filter (\n -> HBM.nodeName n == "y") (HBM.mgNodes gc)
+ case yNode of
+ [n] -> HBM.nodeKind n `shouldBe` HBM.ObservedN 6
+ _ -> expectationFailure "y not found"
+ it "idempotent: collapse 2 回適用しても結果不変" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ _ <- HBM.plate "g" 5 $ forM_ [0..4 :: Int] $ \j ->
+ HBM.sample ("x_" <> T.pack (show j)) (HBM.Normal 0 1)
+ return ()
+ let g = HBM.buildModelGraph m
+ gc1 = HBM.collapseIndexedPlateNodes g
+ gc2 = HBM.collapseIndexedPlateNodes gc1
+ length (HBM.mgNodes gc1) `shouldBe` length (HBM.mgNodes gc2)
+ length (HBM.mgEdges gc1) `shouldBe` length (HBM.mgEdges gc2)
+ --
+ -- 非集約ケース: 単独 / heterogeneous な分布
+ --
+ it "非 indexed RV は触らない (mu / tau はそのまま)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 1)
+ _ <- HBM.sample "tau" (HBM.HalfNormal 1)
+ HBM.observe "y" (HBM.Normal mu 1) [0]
+ return ()
+ let gc = HBM.collapseIndexedPlateNodes (HBM.buildModelGraph m)
+ names = map HBM.nodeName (HBM.mgNodes gc)
+ sort names `shouldBe` sort ["mu", "tau", "y"]
+ it "命名規則違いは集約しない: eta_0 / phi_1 は別名で残る" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ _ <- HBM.plate "g" 2 $ do
+ _ <- HBM.sample "eta_0" (HBM.Normal 0 1)
+ _ <- HBM.sample "phi_1" (HBM.Normal 0 1)
+ return ()
+ return ()
+ let gc = HBM.collapseIndexedPlateNodes (HBM.buildModelGraph m)
+ names = map HBM.nodeName (HBM.mgNodes gc)
+ sort names `shouldBe` sort ["eta_0", "phi_1"]
+
+ describe "Hanalyze.Model.HBM.glmmRandomIntercept (Phase 37-A6)" $ do
+ -- 3 群、 切片のみの GLMM (X = [[1], [1], ...]、 つまり全観測で 1 列)
+ let xRows = replicate 9 [1.0] -- intercept only
+ gids = [0, 0, 0, 1, 1, 1, 2, 2, 2] -- 3 群、 各 3 観測
+ ysGauss = [1.0, 0.8, 1.3, 4.9, 5.2, 4.7, 8.9, 9.0, 8.7]
+ modelGauss :: HBM.ModelP ()
+ modelGauss = HBM.glmmRandomIntercept HBM.GlmmGaussian xRows gids ysGauss
+ modelBin :: HBM.ModelP ()
+ modelBin = HBM.glmmRandomIntercept HBM.GlmmBinomial xRows gids
+ [1, 0, 1, 0, 0, 1, 1, 1, 0]
+ modelPois :: HBM.ModelP ()
+ modelPois = HBM.glmmRandomIntercept HBM.GlmmPoisson xRows gids
+ [2, 1, 3, 5, 6, 4, 8, 9, 7]
+ --
+ it "GlmmGaussian は beta_0 / tau_u / u_0..u_2 / sigma を sample 名に持つ" $ do
+ let ns = HBM.sampleNames modelGauss
+ ns `shouldContain` ["beta_0"]
+ ns `shouldContain` ["tau_u"]
+ ns `shouldContain` ["u_0", "u_1", "u_2"]
+ ns `shouldContain` ["sigma"]
+ it "GlmmBinomial は sigma を含まない (残差不要)" $ do
+ let ns = HBM.sampleNames modelBin
+ ns `shouldContain` ["beta_0"]
+ ns `shouldNotContain` ["sigma"]
+ it "GlmmPoisson は sigma を含まない (残差不要)" $ do
+ let ns = HBM.sampleNames modelPois
+ let containsSigma = "sigma" `elem` ns
+ containsSigma `shouldBe` False
+ it "GlmmGaussian で短い NUTS が収束し u_2 > u_0 を回復" $ do
+ gen <- MWC.create
+ let cfg = NUTS.defaultNUTSConfig
+ { NUTS.nutsIterations = 200
+ , NUTS.nutsBurnIn = 100
+ , NUTS.nutsStepSize = 0.05
+ }
+ initP = M.fromList
+ [ ("beta_0", 5), ("tau_u", 3), ("sigma", 0.3)
+ , ("u_0", -4), ("u_1", 0), ("u_2", 4)
+ ]
+ ch <- NUTS.nuts modelGauss cfg initP gen
+ let u0 = case Core.posteriorMean "u_0" ch of Just v -> v; Nothing -> 0
+ u2 = case Core.posteriorMean "u_2" ch of Just v -> v; Nothing -> 0
+ (u2 > u0) `shouldBe` True
+
+ describe "Hanalyze.Model.HBM.buildModelGraph (Phase 38: 簡単 6 例)" $ do
+ let latentsOf g = sort [ HBM.nodeName n
+ | n <- HBM.mgNodes g
+ , HBM.nodeKind n == HBM.LatentN ]
+ obsOf g = sort [ (HBM.nodeName n, k)
+ | n <- HBM.mgNodes g
+ , HBM.ObservedN k <- [HBM.nodeKind n] ]
+ edgesOf g = sort (HBM.mgEdges g)
+ --
+ -- 簡単 1: Normal(μ, σ既知) + observe
+ --
+ it "簡単 1: Normal(μ, σ既知) で 1 latent / 1 obs / 1 edge" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ HBM.observe "y" (HBM.Normal mu 1) [0, 1, 2]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` ["mu"]
+ obsOf g `shouldBe` [("y", 3)]
+ edgesOf g `shouldBe` [("mu", "y")]
+ --
+ -- 簡単 2: Normal(μ, σ) + observe (両方 latent)
+ --
+ it "簡単 2: Normal(μ, σ) で 2 latent / 1 obs / 2 edges" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ sigma <- HBM.sample "sigma" (HBM.HalfNormal 1)
+ HBM.observe "y" (HBM.Normal mu sigma) [0, 1, 2, 3]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` ["mu", "sigma"]
+ obsOf g `shouldBe` [("y", 4)]
+ edgesOf g `shouldBe` [("mu", "y"), ("sigma", "y")]
+ --
+ -- 簡単 3: Beta-Binomial A/B (2 群独立)
+ --
+ it "簡単 3: Beta-Binomial A/B で 2 latent / 2 obs / 2 edges" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ pC <- HBM.sample "p_ctrl" (HBM.Beta 1 1)
+ pT <- HBM.sample "p_trt" (HBM.Beta 1 1)
+ HBM.observe "y_ctrl" (HBM.Binomial 100 pC) [60]
+ HBM.observe "y_trt" (HBM.Binomial 100 pT) [72]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` ["p_ctrl", "p_trt"]
+ obsOf g `shouldBe` [("y_ctrl", 1), ("y_trt", 1)]
+ edgesOf g `shouldBe` [("p_ctrl", "y_ctrl"), ("p_trt", "y_trt")]
+ --
+ -- 簡単 4: SkewNormal (Phase 37-A2 + 38 補修で distDepsT 追加)
+ --
+ it "簡単 4: SkewNormal で μ, σ, α → y の 3 edges" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 1)
+ sigma <- HBM.sample "sigma" (HBM.HalfNormal 1)
+ alpha <- HBM.sample "alpha" (HBM.Normal 0 1)
+ HBM.observe "y" (HBM.SkewNormal mu sigma alpha) [0, 1, 2]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` ["alpha", "mu", "sigma"]
+ obsOf g `shouldBe` [("y", 3)]
+ edgesOf g `shouldBe` [("alpha", "y"), ("mu", "y"), ("sigma", "y")]
+ --
+ -- 簡単 5: OrderedLogistic (cuts もすべて latent として親に出る)
+ --
+ it "簡単 5: OrderedLogistic で η, c_1, c_2 → y の 3 edges" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ eta <- HBM.sample "eta" (HBM.Normal 0 1)
+ c1 <- HBM.sample "c_1" (HBM.Normal (-1) 1)
+ c2 <- HBM.sample "c_2" (HBM.Normal 1 1)
+ HBM.observe "y" (HBM.OrderedLogistic eta [c1, c2]) [0, 1, 2]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` ["c_1", "c_2", "eta"]
+ obsOf g `shouldBe` [("y", 3)]
+ edgesOf g `shouldBe` [("c_1", "y"), ("c_2", "y"), ("eta", "y")]
+ --
+ -- 簡単 6: MvStudentT (ν と μ vector は latent、 Σ は定数行列)
+ --
+ it "簡単 6: MvStudentT で ν, μ_1, μ_2 → y の 3 edges (Σ=I 定数)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ nu <- HBM.sample "nu" (HBM.Gamma 2 0.1)
+ mu1 <- HBM.sample "mu_1" (HBM.Normal 0 1)
+ mu2 <- HBM.sample "mu_2" (HBM.Normal 0 1)
+ HBM.observe "y"
+ (HBM.MvStudentT nu [mu1, mu2] [[1, 0], [0, 1]])
+ [0, 0, 1, 1]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` ["mu_1", "mu_2", "nu"]
+ obsOf g `shouldBe` [("y", 4)]
+ edgesOf g `shouldBe` [("mu_1", "y"), ("mu_2", "y"), ("nu", "y")]
+
+ describe "Hanalyze.Model.HBM.buildModelGraph (Phase 38: 代表 9 例)" $ do
+ let latentsOf g = sort [ HBM.nodeName n
+ | n <- HBM.mgNodes g
+ , HBM.nodeKind n == HBM.LatentN ]
+ -- LatentN + DeterministicN (Phase 52.A15 で det は DeterministicN に
+ -- 分類。 latent + 派生量が全て graph に出ることを見るテスト用)。
+ latDetOf g = sort [ HBM.nodeName n
+ | n <- HBM.mgNodes g
+ , HBM.nodeKind n `elem` [HBM.LatentN, HBM.DeterministicN] ]
+ obsOf g = sort [ (HBM.nodeName n, k)
+ | n <- HBM.mgNodes g
+ , HBM.ObservedN k <- [HBM.nodeKind n] ]
+ edgesOf g = sort (HBM.mgEdges g)
+ containsAll xs ys = all (`elem` xs) ys
+ --
+ -- 代表 1: 形式 A (per-group data、 群 J=3、 θ_j を unroll)
+ --
+ it "代表 1: 形式 A で μ, τ → θ_j → y_j の 2 段階層 (J=3)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ tau <- HBM.sample "tau" (HBM.HalfNormal 5)
+ t1 <- HBM.sample "theta_1" (HBM.Normal mu tau)
+ t2 <- HBM.sample "theta_2" (HBM.Normal mu tau)
+ t3 <- HBM.sample "theta_3" (HBM.Normal mu tau)
+ HBM.observe "y_1" (HBM.Normal t1 1) [1.0, 1.2]
+ HBM.observe "y_2" (HBM.Normal t2 1) [5.0, 5.3]
+ HBM.observe "y_3" (HBM.Normal t3 1) [9.0, 9.2]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort ["mu", "tau", "theta_1", "theta_2", "theta_3"]
+ obsOf g `shouldBe` sort [("y_1", 2), ("y_2", 2), ("y_3", 2)]
+ edgesOf g `shouldBe` sort
+ [ ("mu", "theta_1"), ("tau", "theta_1"), ("theta_1", "y_1")
+ , ("mu", "theta_2"), ("tau", "theta_2"), ("theta_2", "y_2")
+ , ("mu", "theta_3"), ("tau", "theta_3"), ("theta_3", "y_3") ]
+ --
+ -- 代表 2: 形式 B (long-format、 forM で展開)
+ -- Track 透過性: forM 経由でも親集合が伝わることを確認
+ --
+ it "代表 2: 形式 B (forM long-format) で形式 A と同じ DAG" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ tau <- HBM.sample "tau" (HBM.HalfNormal 5)
+ thetas <- forM [1 :: Int, 2, 3] $ \j ->
+ HBM.sample (T.pack ("theta_" ++ show j)) (HBM.Normal mu tau)
+ forM_ (zip [1 :: Int, 2, 3] thetas) $ \(j, th) ->
+ HBM.observe (T.pack ("y_" ++ show j)) (HBM.Normal th 1) [1.0]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort ["mu", "tau", "theta_1", "theta_2", "theta_3"]
+ obsOf g `shouldBe` sort [("y_1", 1), ("y_2", 1), ("y_3", 1)]
+ edgesOf g `shouldBe` sort
+ [ ("mu", "theta_1"), ("tau", "theta_1"), ("theta_1", "y_1")
+ , ("mu", "theta_2"), ("tau", "theta_2"), ("theta_2", "y_2")
+ , ("mu", "theta_3"), ("tau", "theta_3"), ("theta_3", "y_3") ]
+ --
+ -- 代表 3: 形式 C (non-centered、 raw + deterministic 2 段)
+ -- nonCenteredNormal は raw (Normal(0,1)) + det (loc + scale * raw) に展開
+ --
+ it "代表 3: 形式 C (non-centered) で raw → det theta_j → y_j" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ tau <- HBM.sample "tau" (HBM.HalfNormal 5)
+ thetas <- forM [1 :: Int, 2, 3] $ \j ->
+ HBM.nonCenteredNormal (T.pack ("theta_" ++ show j)) mu tau
+ forM_ (zip [1 :: Int, 2, 3] thetas) $ \(j, th) ->
+ HBM.observe (T.pack ("y_" ++ show j)) (HBM.Normal th 1) [1.0]
+ g = HBM.buildModelGraph m
+ -- raw (Normal(0,1) 由来・LatentN) と det theta_j (DeterministicN) の
+ -- 両方が graph に現れる (Phase 52.A15 で det は DeterministicN)
+ latDetOf g `shouldBe` sort
+ [ "mu", "tau"
+ , "theta_1_raw", "theta_2_raw", "theta_3_raw"
+ , "theta_1", "theta_2", "theta_3" ]
+ obsOf g `shouldBe` sort [("y_1", 1), ("y_2", 1), ("y_3", 1)]
+ -- raw は Normal(0,1) なので親なし、 det theta_j は mu, tau, theta_j_raw が親
+ containsAll (HBM.mgEdges g)
+ [ ("mu", "theta_1"), ("tau", "theta_1"), ("theta_1_raw", "theta_1")
+ , ("theta_1", "y_1") ] `shouldBe` True
+ containsAll (HBM.mgEdges g)
+ [ ("mu", "theta_3"), ("tau", "theta_3"), ("theta_3_raw", "theta_3")
+ , ("theta_3", "y_3") ] `shouldBe` True
+ -- raw は親なし
+ [ p | (p, c) <- HBM.mgEdges g, c == "theta_1_raw" ] `shouldBe` []
+ --
+ -- 代表 4: Random slope (per-group α_j, β_j、 J=2)
+ --
+ it "代表 4: Random slope で μ_α, τ_α, μ_β, τ_β → α_j, β_j → y_j" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mua <- HBM.sample "mu_a" (HBM.Normal 0 5)
+ taa <- HBM.sample "tau_a" (HBM.HalfNormal 1)
+ mub <- HBM.sample "mu_b" (HBM.Normal 0 5)
+ tab <- HBM.sample "tau_b" (HBM.HalfNormal 1)
+ a1 <- HBM.sample "alpha_1" (HBM.Normal mua taa)
+ a2 <- HBM.sample "alpha_2" (HBM.Normal mua taa)
+ b1 <- HBM.sample "beta_1" (HBM.Normal mub tab)
+ b2 <- HBM.sample "beta_2" (HBM.Normal mub tab)
+ HBM.observe "y_1" (HBM.Normal (a1 + b1 * 1.0) 1) [1.0]
+ HBM.observe "y_2" (HBM.Normal (a2 + b2 * 1.0) 1) [2.0]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort
+ [ "mu_a", "tau_a", "mu_b", "tau_b"
+ , "alpha_1", "alpha_2", "beta_1", "beta_2" ]
+ obsOf g `shouldBe` sort [("y_1", 1), ("y_2", 1)]
+ containsAll (HBM.mgEdges g)
+ [ ("mu_a", "alpha_1"), ("tau_a", "alpha_1")
+ , ("mu_b", "beta_1"), ("tau_b", "beta_1")
+ , ("alpha_1", "y_1"), ("beta_1", "y_1")
+ , ("alpha_2", "y_2"), ("beta_2", "y_2") ] `shouldBe` True
+ --
+ -- 代表 5: Multi-level (3-level: μ → δ_d → θ_{d,s} → y_{d,s})、 D=2, S=2
+ --
+ it "代表 5: 3 階層 (μ → δ_d → θ_{d,s} → y_{d,s})" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 5)
+ tDd <- HBM.sample "tau_d" (HBM.HalfNormal 1)
+ tSs <- HBM.sample "tau_s" (HBM.HalfNormal 1)
+ d1 <- HBM.sample "delta_1" (HBM.Normal mu tDd)
+ d2 <- HBM.sample "delta_2" (HBM.Normal mu tDd)
+ t11 <- HBM.sample "theta_1_1" (HBM.Normal d1 tSs)
+ t12 <- HBM.sample "theta_1_2" (HBM.Normal d1 tSs)
+ t21 <- HBM.sample "theta_2_1" (HBM.Normal d2 tSs)
+ t22 <- HBM.sample "theta_2_2" (HBM.Normal d2 tSs)
+ HBM.observe "y_1_1" (HBM.Normal t11 1) [1.0]
+ HBM.observe "y_1_2" (HBM.Normal t12 1) [1.0]
+ HBM.observe "y_2_1" (HBM.Normal t21 1) [1.0]
+ HBM.observe "y_2_2" (HBM.Normal t22 1) [1.0]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort
+ [ "mu", "tau_d", "tau_s"
+ , "delta_1", "delta_2"
+ , "theta_1_1", "theta_1_2", "theta_2_1", "theta_2_2" ]
+ length (obsOf g) `shouldBe` 4
+ containsAll (HBM.mgEdges g)
+ [ ("mu", "delta_1"), ("tau_d", "delta_1")
+ , ("delta_1", "theta_1_1"), ("tau_s", "theta_1_1")
+ , ("theta_1_1", "y_1_1")
+ , ("mu", "delta_2"), ("tau_d", "delta_2")
+ , ("delta_2", "theta_2_2"), ("tau_s", "theta_2_2")
+ , ("theta_2_2", "y_2_2") ] `shouldBe` True
+ --
+ -- 代表 6: Crossed (subject × time、 S=2, T=2)
+ --
+ it "代表 6: Crossed (α_s + γ_t → y_{s,t})" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mua <- HBM.sample "mu_a" (HBM.Normal 0 5)
+ taa <- HBM.sample "tau_a" (HBM.HalfNormal 1)
+ tag <- HBM.sample "tau_g" (HBM.HalfNormal 1)
+ a1 <- HBM.sample "alpha_1" (HBM.Normal mua taa)
+ a2 <- HBM.sample "alpha_2" (HBM.Normal mua taa)
+ g1 <- HBM.sample "gamma_1" (HBM.Normal 0 tag)
+ g2 <- HBM.sample "gamma_2" (HBM.Normal 0 tag)
+ HBM.observe "y_1_1" (HBM.Normal (a1 + g1) 1) [1.0]
+ HBM.observe "y_1_2" (HBM.Normal (a1 + g2) 1) [1.0]
+ HBM.observe "y_2_1" (HBM.Normal (a2 + g1) 1) [1.0]
+ HBM.observe "y_2_2" (HBM.Normal (a2 + g2) 1) [1.0]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort
+ [ "mu_a", "tau_a", "tau_g"
+ , "alpha_1", "alpha_2", "gamma_1", "gamma_2" ]
+ length (obsOf g) `shouldBe` 4
+ containsAll (HBM.mgEdges g)
+ [ ("mu_a", "alpha_1"), ("tau_a", "alpha_1")
+ , ("tau_g", "gamma_1")
+ , ("alpha_1", "y_1_1"), ("gamma_1", "y_1_1")
+ , ("alpha_2", "y_2_2"), ("gamma_2", "y_2_2") ] `shouldBe` True
+ --
+ -- 代表 7: GLMM helper (glmmRandomIntercept GlmmGaussian、 nG=3, n=6)
+ --
+ it "代表 7: glmmRandomIntercept Gaussian で β_0/τ_u/σ/u_j → y (単一ブロック)" $ do
+ let xRows = replicate 6 [1.0]
+ gids = [0, 0, 1, 1, 2, 2]
+ ys = [1, 1.1, 4.9, 5.0, 8.9, 9.0]
+ m :: HBM.ModelP ()
+ m = HBM.glmmRandomIntercept HBM.GlmmGaussian xRows gids ys
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort
+ ["beta_0", "tau_u", "sigma", "u_0", "u_1", "u_2"]
+ -- Phase 54.4a: 観測は単一の observeLMR ブロック "y" (PyMC/Stan 同様の
+ -- ベクトル化観測ノード。 旧実装は per-obs y_0..y_5 を 6 個展開)。
+ obsOf g `shouldBe` [("y", 6)]
+ -- τ_u → u_j が伝わる (centered パラメタ化)
+ containsAll (HBM.mgEdges g)
+ [ ("tau_u", "u_0"), ("tau_u", "u_1"), ("tau_u", "u_2") ]
+ `shouldBe` True
+ -- 単一観測ブロック "y" の親 = β + 全群効果 u + σ
+ let parentsOf nm = sort [ p | (p, c) <- HBM.mgEdges g, c == nm ]
+ parentsOf "y" `shouldBe`
+ sort ["beta_0", "sigma", "u_0", "u_1", "u_2"]
+ --
+ -- 代表 8: nonCenteredNormal 単体の derived 関係 (raw → det)
+ --
+ it "代表 8: nonCenteredNormal で raw (親なし) + name (deterministic)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ tau <- HBM.sample "tau" (HBM.HalfNormal 1)
+ th <- HBM.nonCenteredNormal "theta" mu tau
+ HBM.observe "y" (HBM.Normal th 1) [1, 2, 3]
+ g = HBM.buildModelGraph m
+ latDetOf g `shouldBe` sort ["mu", "tau", "theta_raw", "theta"]
+ obsOf g `shouldBe` [("y", 3)]
+ -- theta_raw は Normal(0,1) なので親なし
+ [ p | (p, c) <- HBM.mgEdges g, c == "theta_raw" ] `shouldBe` []
+ -- theta (det) の親 = {mu, tau, theta_raw}
+ sort [ p | (p, c) <- HBM.mgEdges g, c == "theta" ]
+ `shouldBe` sort ["mu", "tau", "theta_raw"]
+ -- theta → y
+ [ p | (p, c) <- HBM.mgEdges g, c == "y" ] `shouldBe` ["theta"]
+ --
+ -- 代表 9: dirichlet stick-breaking (K=3、 β_k latent + π_k deterministic)
+ --
+ it "代表 9: dirichlet K=3 で β_b (2 個) + π_ (3 個) det" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ pis <- HBM.dirichlet "p" [1, 1, 1]
+ HBM.observe "y" (HBM.Categorical pis) [0, 1, 2]
+ g = HBM.buildModelGraph m
+ -- K=3 → β は p_b0, p_b1 (2 個)、 π は p_0, p_1, p_2 (3 個 deterministic)
+ latDetOf g `shouldBe` sort ["p_b0", "p_b1", "p_0", "p_1", "p_2"]
+ obsOf g `shouldBe` [("y", 3)]
+ -- π_0 = β_0、 π_1 = β_1 (1 - β_0)、 π_2 = (1 - β_0)(1 - β_1)
+ sort [ p | (p, c) <- HBM.mgEdges g, c == "p_0" ]
+ `shouldBe` ["p_b0"]
+ sort [ p | (p, c) <- HBM.mgEdges g, c == "p_1" ]
+ `shouldBe` sort ["p_b0", "p_b1"]
+ sort [ p | (p, c) <- HBM.mgEdges g, c == "p_2" ]
+ `shouldBe` sort ["p_b0", "p_b1"]
+ -- y の親 = π_0, π_1, π_2 (Categorical の引数すべて)
+ sort [ p | (p, c) <- HBM.mgEdges g, c == "y" ]
+ `shouldBe` sort ["p_0", "p_1", "p_2"]
+
+ describe "Hanalyze.Model.HBM.buildModelGraph (Phase 38: 複雑 9 例)" $ do
+ let latentsOf g = sort [ HBM.nodeName n
+ | n <- HBM.mgNodes g
+ , HBM.nodeKind n == HBM.LatentN ]
+ -- LatentN + DeterministicN。 Phase 52.A15 で deterministic は
+ -- DeterministicN に分類されたので、 「latent + 派生量が全て graph に
+ -- 出る」 を見るテストはこちらを使う (latentsOf は sampler latent のみ)。
+ latDetOf g = sort [ HBM.nodeName n
+ | n <- HBM.mgNodes g
+ , HBM.nodeKind n `elem` [HBM.LatentN, HBM.DeterministicN] ]
+ obsOf g = sort [ (HBM.nodeName n, k)
+ | n <- HBM.mgNodes g
+ , HBM.ObservedN k <- [HBM.nodeKind n] ]
+ parentsOf g nm = sort [ p | (p, c) <- HBM.mgEdges g, c == nm ]
+ --
+ -- 複雑 1: ZIN-NegBin GLMM (ψ, β_0, τ_u, α 群効果 + 過分散ゼロ過剰)
+ --
+ it "複雑 1: ZIN-NegBin GLMM で ψ, β_0, α, u_j → y_i" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ b0 <- HBM.sample "beta_0" (HBM.Normal 0 5)
+ tau <- HBM.sample "tau_u" (HBM.HalfNormal 5)
+ psi <- HBM.sample "psi" (HBM.Beta 1 1)
+ al <- HBM.sample "alpha" (HBM.Gamma 2 1)
+ u0 <- HBM.sample "u_0" (HBM.Normal 0 tau)
+ u1 <- HBM.sample "u_1" (HBM.Normal 0 tau)
+ HBM.observe "y_0"
+ (HBM.ZeroInflatedNegativeBinomial psi (exp (b0 + u0)) al)
+ [3, 0]
+ HBM.observe "y_1"
+ (HBM.ZeroInflatedNegativeBinomial psi (exp (b0 + u1)) al)
+ [0, 5]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort
+ ["beta_0", "tau_u", "psi", "alpha", "u_0", "u_1"]
+ obsOf g `shouldBe` sort [("y_0", 2), ("y_1", 2)]
+ parentsOf g "u_0" `shouldBe` ["tau_u"]
+ parentsOf g "u_1" `shouldBe` ["tau_u"]
+ parentsOf g "y_0" `shouldBe` sort ["alpha", "beta_0", "psi", "u_0"]
+ parentsOf g "y_1" `shouldBe` sort ["alpha", "beta_0", "psi", "u_1"]
+ --
+ -- 複雑 2: 階層 OrderedLogistic (cuts 共通、 η は群別)
+ --
+ it "複雑 2: 階層 OrderedLogistic で μ/τ → η_j、 cuts は y 親に共有" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 1)
+ tau <- HBM.sample "tau" (HBM.HalfNormal 1)
+ c1 <- HBM.sample "c_1" (HBM.Normal (-1) 1)
+ c2 <- HBM.sample "c_2" (HBM.Normal 1 1)
+ e1 <- HBM.sample "eta_1" (HBM.Normal mu tau)
+ e2 <- HBM.sample "eta_2" (HBM.Normal mu tau)
+ HBM.observe "y_1" (HBM.OrderedLogistic e1 [c1, c2]) [0, 1, 2]
+ HBM.observe "y_2" (HBM.OrderedLogistic e2 [c1, c2]) [0, 1, 2]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort
+ ["mu", "tau", "c_1", "c_2", "eta_1", "eta_2"]
+ parentsOf g "eta_1" `shouldBe` sort ["mu", "tau"]
+ parentsOf g "y_1" `shouldBe` sort ["c_1", "c_2", "eta_1"]
+ parentsOf g "y_2" `shouldBe` sort ["c_1", "c_2", "eta_2"]
+ --
+ -- 複雑 3: Hierarchical mixture (mu_1, mu_2 が共通 hyper から)
+ --
+ it "複雑 3: Hierarchical mixture で μ_g/τ_g → μ_k → y" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ w <- HBM.sample "w" (HBM.Beta 1 1)
+ mug <- HBM.sample "mu_g" (HBM.Normal 0 5)
+ tag <- HBM.sample "tau_g" (HBM.HalfNormal 1)
+ m1 <- HBM.sample "mu_1" (HBM.Normal mug tag)
+ m2 <- HBM.sample "mu_2" (HBM.Normal mug tag)
+ HBM.observe "y"
+ (HBM.Mixture [w, 1 - w] [HBM.Normal m1 1, HBM.Normal m2 1])
+ [0, 1, 2, 3]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort ["w", "mu_g", "tau_g", "mu_1", "mu_2"]
+ parentsOf g "mu_1" `shouldBe` sort ["mu_g", "tau_g"]
+ parentsOf g "mu_2" `shouldBe` sort ["mu_g", "tau_g"]
+ parentsOf g "y" `shouldBe` sort ["mu_1", "mu_2", "w"]
+ --
+ -- 複雑 4: Gaussian + potential 制約 (mu_1 ≈ mu_2 ペナルティ)
+ -- potential は LatentN "Potential" として親集合付きで出る
+ --
+ it "複雑 4: Gaussian + potential 制約で constr ノードが mu_1, mu_2 親" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ m1 <- HBM.sample "mu_1" (HBM.Normal 0 5)
+ m2 <- HBM.sample "mu_2" (HBM.Normal 0 5)
+ HBM.potential "constr" (negate ((m1 - m2) ** 2))
+ HBM.observe "y" (HBM.Normal m1 1) [1, 2, 3]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort ["mu_1", "mu_2", "constr"]
+ obsOf g `shouldBe` [("y", 3)]
+ parentsOf g "constr" `shouldBe` sort ["mu_1", "mu_2"]
+ parentsOf g "y" `shouldBe` ["mu_1"]
+ --
+ -- 複雑 5: Multi-output (mu 共有、 sigma 個別)
+ --
+ it "複雑 5: Multi-output (mu 共有, sigma_k 個別) で 3 obs、 mu 共有親" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 5)
+ s1 <- HBM.sample "sigma_1" (HBM.HalfNormal 1)
+ s2 <- HBM.sample "sigma_2" (HBM.HalfNormal 1)
+ s3 <- HBM.sample "sigma_3" (HBM.HalfNormal 1)
+ HBM.observe "y_1" (HBM.Normal mu s1) [0, 1, 2]
+ HBM.observe "y_2" (HBM.Normal mu s2) [3, 4, 5]
+ HBM.observe "y_3" (HBM.Normal mu s3) [6, 7, 8]
+ g = HBM.buildModelGraph m
+ latentsOf g `shouldBe` sort ["mu", "sigma_1", "sigma_2", "sigma_3"]
+ parentsOf g "y_1" `shouldBe` sort ["mu", "sigma_1"]
+ parentsOf g "y_2" `shouldBe` sort ["mu", "sigma_2"]
+ parentsOf g "y_3" `shouldBe` sort ["mu", "sigma_3"]
+ --
+ -- 複雑 6: Random slope + nonCentered (形式 C + slope の組合せ)
+ --
+ it "複雑 6: Random slope + nonCenteredNormal で raw + det 2 軸" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mua <- HBM.sample "mu_a" (HBM.Normal 0 5)
+ taa <- HBM.sample "tau_a" (HBM.HalfNormal 1)
+ mub <- HBM.sample "mu_b" (HBM.Normal 0 5)
+ tab <- HBM.sample "tau_b" (HBM.HalfNormal 1)
+ a1 <- HBM.nonCenteredNormal "alpha_1" mua taa
+ a2 <- HBM.nonCenteredNormal "alpha_2" mua taa
+ b1 <- HBM.nonCenteredNormal "beta_1" mub tab
+ b2 <- HBM.nonCenteredNormal "beta_2" mub tab
+ HBM.observe "y_1" (HBM.Normal (a1 + b1) 1) [1.0]
+ HBM.observe "y_2" (HBM.Normal (a2 + b2) 1) [2.0]
+ g = HBM.buildModelGraph m
+ latDetOf g `shouldBe` sort
+ [ "mu_a", "tau_a", "mu_b", "tau_b"
+ , "alpha_1_raw", "alpha_2_raw", "beta_1_raw", "beta_2_raw"
+ , "alpha_1", "alpha_2", "beta_1", "beta_2" ]
+ parentsOf g "alpha_1_raw" `shouldBe` []
+ parentsOf g "alpha_1" `shouldBe` sort ["mu_a", "tau_a", "alpha_1_raw"]
+ parentsOf g "beta_2" `shouldBe` sort ["mu_b", "tau_b", "beta_2_raw"]
+ parentsOf g "y_1" `shouldBe` sort ["alpha_1", "beta_1"]
+ parentsOf g "y_2" `shouldBe` sort ["alpha_2", "beta_2"]
+ --
+ -- 複雑 7: Dirichlet mixture (K=3 有限近似)
+ --
+ it "複雑 7: Dirichlet mixture K=3 で β/π/μ_k → y" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ pis <- HBM.dirichlet "p" [1, 1, 1]
+ m1 <- HBM.sample "mu_1" (HBM.Normal 0 5)
+ m2 <- HBM.sample "mu_2" (HBM.Normal 0 5)
+ m3 <- HBM.sample "mu_3" (HBM.Normal 0 5)
+ HBM.observe "y"
+ (HBM.Mixture pis
+ [HBM.Normal m1 1, HBM.Normal m2 1, HBM.Normal m3 1])
+ [0, 1, 2]
+ g = HBM.buildModelGraph m
+ latDetOf g `shouldBe` sort
+ ["p_b0", "p_b1", "p_0", "p_1", "p_2", "mu_1", "mu_2", "mu_3"]
+ parentsOf g "p_0" `shouldBe` ["p_b0"]
+ parentsOf g "y" `shouldBe` sort
+ ["mu_1", "mu_2", "mu_3", "p_0", "p_1", "p_2"]
+ --
+ -- 複雑 8: AR(1) latent 時系列 (ar1Latent helper、 nT=3)
+ -- plate-style 期待: x_raw_t → x_t (det)、 x_{t-1} → x_t (t≥1)、 x_2 → y
+ --
+ it "複雑 8: ar1Latent nT=3 で x_raw_t + det x_t chain + x_2 → y" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ xs <- HBM.ar1Latent "x" 3 0.8 0.3
+ HBM.observe "y" (HBM.Normal (xs !! 2) 1) [1.0]
+ g = HBM.buildModelGraph m
+ latDetOf g `shouldBe` sort
+ ["x_raw0", "x_raw1", "x_raw2", "x_0", "x_1", "x_2"]
+ -- raw は親なし
+ parentsOf g "x_raw0" `shouldBe` []
+ parentsOf g "x_raw1" `shouldBe` []
+ parentsOf g "x_raw2" `shouldBe` []
+ -- x_0 の親は x_raw0 のみ (定数 phi/sigma は trackConst で deps 空)
+ parentsOf g "x_0" `shouldBe` ["x_raw0"]
+ -- x_1 の親は x_0 と x_raw1
+ parentsOf g "x_1" `shouldBe` sort ["x_0", "x_raw1"]
+ -- x_2 の親は x_1 と x_raw2
+ parentsOf g "x_2" `shouldBe` sort ["x_1", "x_raw2"]
+ -- y の親は x_2 のみ
+ parentsOf g "y" `shouldBe` ["x_2"]
+ --
+ -- 複雑 9: sampleNames と buildModelGraph の latent 名一致確認
+ -- (Phase 37-A5 fullRankAdvi 等の推論側で出る latent 名と DAG が整合)
+ --
+ it "複雑 9: sampleNames m と graph latent (det/potential 除く) が一致" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 5)
+ tau <- HBM.sample "tau" (HBM.HalfNormal 1)
+ th <- HBM.nonCenteredNormal "theta" mu tau
+ HBM.observe "y" (HBM.Normal th 1) [1, 2, 3]
+ g = HBM.buildModelGraph m
+ -- buildModelGraph の latent から Deterministic を除いたもの
+ pureLatents = sort
+ [ HBM.nodeName n
+ | n <- HBM.mgNodes g
+ , HBM.nodeKind n == HBM.LatentN
+ , HBM.nodeDist n /= "Deterministic"
+ , HBM.nodeDist n /= "Potential" ]
+ sampled = sort (HBM.sampleNames m)
+ sampled `shouldBe` pureLatents
+ -- 具体的に: mu, tau, theta_raw が sample されている (theta は det)
+ sampled `shouldBe` sort ["mu", "tau", "theta_raw"]
diff --git a/test/Hanalyze/Model/HBMSummarySpec.hs b/test/Hanalyze/Model/HBMSummarySpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/HBMSummarySpec.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+-- | Phase 103: HBM 事後要約の一発 API (hbmSummary / hbmSummaryNames) の spec。
+--
+-- fixture は A1 probe (experiments/phase103-hbm-summary-df-helpers/) と同型の
+-- 決定的 fit (hbmModelPure = 既定 seed 42)。固定する配線:
+-- * hbmSummary = posteriorSummary (latent+deterministic 名) (augment 済 chain)
+-- の手繋ぎ直呼びと完全一致 (一発 API が既存経路の糖衣であること)
+-- * deterministic 派生量 (mu) が既定で要約に含まれる (A1 確定の設計)
+-- * deterministicNames は宣言順・runDeterministics の key 集合と一致
+module Hanalyze.Model.HBMSummarySpec (spec) where
+
+import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes)
+import qualified DataFrame.Internal.DataFrame as DX
+import Test.Hspec
+
+import qualified Hanalyze.Data.Wrangle as W
+import Hanalyze.DataIO.Preprocess (readMaybeDoubleColumn)
+import Hanalyze.MCMC.Core (chainVals)
+import qualified Hanalyze.Model.HBM as HBM
+import Hanalyze.Model.Wrappers (HBMModel (..), HBMConfig (..), defaultHBM,
+ hbmModelPure, hbmSummary, hbmSummaryNames,
+ hbmSummaryDf, hbmDrawsDf)
+import Hanalyze.Stat.Summary (SummaryRow (..), posteriorSummary)
+
+-- | A1 probe と同型の最小モデル (latent 2 + deterministic 1)。
+model :: HBM.ModelP ()
+model = do
+ xs <- HBM.dataNamed "x" [1, 2, 3]
+ ys <- HBM.dataNamedObs "y" [2, 4, 6]
+ b <- HBM.sample "b" (HBM.Normal 0 1)
+ s <- HBM.sample "s" (HBM.HalfNormal 1)
+ mu <- HBM.deterministic "mu" (b * head xs)
+ HBM.observe "y" (HBM.Normal mu s) ys
+
+-- | deterministic 無しモデル (augment 迂回パスの確認用)。
+modelNoDet :: HBM.ModelP ()
+modelNoDet = do
+ ys <- HBM.dataNamedObs "y" [2, 4, 6]
+ b <- HBM.sample "b" (HBM.Normal 0 1)
+ HBM.observe "y" (HBM.Normal b 1) ys
+
+-- | 決定的 fit (seed 42 既定・test 速度優先の小 iteration)。
+fitted :: HBMModel
+fitted = hbmModelPure (defaultHBM { hbmChains = 2, hbmWarmup = 100, hbmSamples = 100 })
+ model []
+
+rowKey :: SummaryRow -> (String, Double, Double, Double, Double, Double, Maybe Double)
+rowKey r = (show (srName r), srMean r, srSD r, srHdiLo r, srHdiHi r, srEssV r, srRhat r)
+
+spec :: Spec
+spec = do
+ describe "hbmSummaryNames (Phase 103)" $ do
+ it "latent 宣言順 → deterministic 宣言順の連結" $
+ hbmSummaryNames fitted `shouldBe` ["b", "s", "mu"]
+
+ it "deterministicNames = runDeterministics の key 集合 (順序のみ宣言順)" $ do
+ let spec' :: HBM.ModelP ()
+ spec' = hbmModelSpec fitted
+ ks = Map.keys (HBM.runDeterministics spec' (Map.fromList [("b", 1), ("s", 1)]))
+ HBM.deterministicNames spec' `shouldMatchList` ks
+
+ describe "hbmSummary (Phase 103)" $ do
+ it "posteriorSummary 直呼び (augment 手繋ぎ) と完全一致" $ do
+ let spec' :: HBM.ModelP ()
+ spec' = hbmModelSpec fitted
+ names = HBM.sampleNames spec' ++ HBM.deterministicNames spec'
+ chains = map (HBM.augmentChainWithDeterministic spec') (hbmChainsR fitted)
+ direct = posteriorSummary names chains
+ map rowKey (hbmSummary fitted) `shouldBe` map rowKey direct
+
+ it "deterministic 派生量 mu が既定で要約に含まれ有限値を持つ" $ do
+ let rows = hbmSummary fitted
+ mus = [r | r <- rows, srName r == "mu"]
+ length mus `shouldBe` 1
+ all (\r -> not (isNaN (srMean r))) mus `shouldBe` True
+
+ it "multi-chain fit では r_hat が Just" $
+ all (\r -> srRhat r /= Nothing) (hbmSummary fitted) `shouldBe` True
+
+ it "deterministic 無しモデルでも成立 (augment 迂回パス)" $ do
+ let m = hbmModelPure (defaultHBM { hbmChains = 1, hbmWarmup = 50, hbmSamples = 50 })
+ modelNoDet []
+ rows = hbmSummary m
+ map srName rows `shouldBe` ["b"]
+ -- 単 chain は r_hat 無し (posteriorSummary の既存挙動に一致)
+ map srRhat rows `shouldBe` [Nothing]
+
+ describe "hbmSummaryDf (Phase 103)" $ do
+ it "multi-chain: 列 = param/mean/sd/hdi_lo/hdi_hi/ess_bulk/r_hat・行 = 全パラメタ" $ do
+ let df = hbmSummaryDf fitted
+ DX.columnNames df `shouldBe`
+ ["param", "mean", "sd", "hdi_lo", "hdi_hi", "ess_bulk", "r_hat"]
+ let Just means = readMaybeDoubleColumn "mean" df
+ catMaybes means `shouldBe` map srMean (hbmSummary fitted)
+
+ it "単 chain: r_hat 列が付かない (printPosteriorSummary の列規約と同じ)" $ do
+ let m = hbmModelPure (defaultHBM { hbmChains = 1, hbmWarmup = 50, hbmSamples = 50 })
+ modelNoDet []
+ df = hbmSummaryDf m
+ DX.columnNames df `shouldBe`
+ ["param", "mean", "sd", "hdi_lo", "hdi_hi", "ess_bulk"]
+
+ describe "hbmDrawsDf (Phase 103)" $ do
+ it "1 パラメタ = 1 列 (deterministic 込み)・全 chain 連結の draw 数" $ do
+ let df = hbmDrawsDf fitted
+ DX.columnNames df `shouldBe` ["b", "s", "mu"]
+ let Just mus = readMaybeDoubleColumn "mu" df
+ length (catMaybes mus) `shouldBe` 200 -- 2 chain x 100 draw
+
+ it "draw 値 = augment 済 chain の chainVals 連結 (chain 順)" $ do
+ let spec' :: HBM.ModelP ()
+ spec' = hbmModelSpec fitted
+ direct = concatMap (chainVals "mu")
+ (map (HBM.augmentChainWithDeterministic spec') (hbmChainsR fitted))
+ Just mus = readMaybeDoubleColumn "mu" (hbmDrawsDf fitted)
+ catMaybes mus `shouldBe` direct
+
+ it "Wrangle summarise (meanOf) がそのまま効く" $ do
+ let df = hbmDrawsDf fitted
+ out = W.summarise ["m" W.=: W.meanOf "mu"] df
+ Just [Just m] = readMaybeDoubleColumn "m" out
+ Just mus = readMaybeDoubleColumn "mu" df
+ xs = catMaybes mus
+ abs (m - sum xs / fromIntegral (length xs)) `shouldSatisfy` (< 1e-9)
diff --git a/test/Hanalyze/Model/HierarchicalClusterSpec.hs b/test/Hanalyze/Model/HierarchicalClusterSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/HierarchicalClusterSpec.hs
@@ -0,0 +1,51 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.HierarchicalClusterSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.HierarchicalCluster as HC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.HierarchicalCluster (Phase 12)" $ do
+ let blob = LA.fromLists
+ [ [0,0], [0.1,0], [0,0.1] -- cluster A
+ , [5,5], [5.1,5], [5,5.1] -- cluster B
+ ]
+ it "fitHierarchical Ward: 6 サンプルで 5 マージ" $ do
+ let fit = HC.fitHierarchical HC.Ward blob
+ length (HC.hcMerges fit) `shouldBe` 5
+ length (HC.hcHeights fit) `shouldBe` 5
+ it "cutTree K=2 で 2 ブロブが分離" $ do
+ let fit = HC.fitHierarchical HC.Ward blob
+ ids = HC.cutTree fit 2
+ half = V.length (V.filter (== V.head ids) ids)
+ half `shouldBe` 3
+ it "Single linkage でも 5 マージ系列" $ do
+ let fit = HC.fitHierarchical HC.Single blob
+ length (HC.hcMerges fit) `shouldBe` 5
+ it "Complete linkage 高さは Single 以上" $ do
+ let fS = HC.fitHierarchical HC.Single blob
+ fC = HC.fitHierarchical HC.Complete blob
+ last (HC.hcHeights fC) `shouldSatisfy` (>= last (HC.hcHeights fS) - 1e-9)
diff --git a/test/Hanalyze/Model/KNNSpec.hs b/test/Hanalyze/Model/KNNSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/KNNSpec.hs
@@ -0,0 +1,56 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.KNNSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Map.Strict as M
+import qualified Hanalyze.Model.KNN as KNN
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.KNN (Phase 34-A4)" $ do
+ let xTrain = LA.fromLists [[fromIntegral i] | i <- [0 :: Int .. 9]]
+ yTrainR = VU.fromList [fromIntegral i * 2 | i <- [0 :: Int .. 9]]
+ yTrainC = VU.fromList ([0,0,0,0,0,1,1,1,1,1] :: [Int])
+ xTest = LA.fromLists [[2.0], [7.5]]
+ it "fitKNNR + predictKNNR: k=3 で局所平均" $ do
+ let knn = KNN.fitKNNR 3 xTrain yTrainR
+ ys = KNN.predictKNNR knn xTest
+ VU.length ys `shouldBe` 2
+ -- x=2 → 近傍 {1,2,3} の y= {2,4,6} → 平均 4
+ abs (ys VU.! 0 - 4.0) `shouldSatisfy` (< 1e-9)
+ it "fitKNNC + predictKNNC: 分類で多数決" $ do
+ let knn = KNN.fitKNNC 3 xTrain yTrainC
+ ys = KNN.predictKNNC knn xTest
+ ys VU.! 0 `shouldBe` 0
+ ys VU.! 1 `shouldBe` 1
+ it "fitKNNC: knnCClasses は sorted unique" $ do
+ let knn = KNN.fitKNNC 3 xTrain yTrainC
+ KNN.knnCClasses knn `shouldBe` [0, 1]
+ it "predictKNNCProbs: 確率は和 1" $ do
+ let knn = KNN.fitKNNC 3 xTrain yTrainC
+ ps = KNN.predictKNNCProbs knn xTest
+ and [ abs (sum (M.elems m) - 1.0) < 1e-10 | m <- ps ]
+ `shouldBe` True
diff --git a/test/Hanalyze/Model/KernelSpec.hs b/test/Hanalyze/Model/KernelSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/KernelSpec.hs
@@ -0,0 +1,138 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.KernelSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.KernelRegression as Kn
+import qualified Hanalyze.Model.GP as GP
+import qualified Hanalyze.Model.GPRobust as GPR
+import qualified Hanalyze.Model.GP as GP
+import qualified Hanalyze.Model.GPRobust as GPR
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.KernelRegression multi-input (MV)" $ do
+ -- 2D regression target: y = sin(x1) + 0.5 cos(x2)
+ let n = 60
+ h = 0.5
+ lam = 1e-4
+ f x1 x2 = sin x1 + 0.5 * cos x2
+ xs = LA.fromLists
+ [ [ fromIntegral i / 10
+ , fromIntegral (n - i) / 10
+ ]
+ | i <- [0 .. n - 1] ]
+ ys = LA.asColumn $ LA.fromList
+ [ f (xs `LA.atIndex` (i, 0)) (xs `LA.atIndex` (i, 1))
+ | i <- [0 .. n - 1] ]
+ fit = Kn.kernelRidgeMV Kn.Gaussian h lam xs ys
+ yhat = Kn.fittedKernelRidgeMV fit
+ ssErr = LA.sumElements ((ys - yhat) ** 2)
+ ssTot = let muY = LA.sumElements ys / fromIntegral n
+ in LA.sumElements ((ys - LA.konst muY (n, 1)) ** 2)
+ r2 = 1 - ssErr / ssTot
+
+ it "achieves R² > 0.95 on a 2D smooth target" $
+ r2 > 0.95 `shouldBe` True
+
+ it "predict at training points equals fitted" $ do
+ let p = Kn.predictKernelRidgeMV fit xs
+ LA.norm_Inf (p - yhat) < 1e-9 `shouldBe` True
+
+ it "gramMatrixMV matches kernelFromSqDist by element" $ do
+ let xS = LA.fromLists [[0.0, 0.0], [1.0, 0.0], [0.5, 0.5]] :: LA.Matrix Double
+ gMV = Kn.gramMatrixMV Kn.Gaussian 1.0 xS
+ rs = LA.toRows xS
+ ref = LA.fromLists
+ [ [ let d = rs !! i - rs !! j
+ s = (d `LA.dot` d) / (1.0 * 1.0)
+ in Kn.kernelFromSqDist Kn.Gaussian s
+ | j <- [0 .. 2] ]
+ | i <- [0 .. 2] ]
+ LA.norm_Inf (gMV - ref) < 1e-12 `shouldBe` True
+
+ it "Hanalyze.Model.GP MV: 1D input matches legacy 1D fitGP within 1e-6" $ do
+ let xL = [fromIntegral i / 5 | i <- [0 .. 19 :: Int]]
+ yL = map sin xL
+ tL = [0.5, 1.5, 2.5]
+ mdl = GP.GPModel GP.RBF (GP.GPParams 1.0 1.0 0.05 1.0 Nothing)
+ legacy = GP.fitGP mdl xL yL tL
+ xMV = LA.fromLists (map (:[]) xL) :: LA.Matrix Double
+ yMV = LA.fromList yL
+ tMV = LA.fromLists (map (:[]) tL) :: LA.Matrix Double
+ mv = GP.fitGPMV mdl xMV yMV tMV
+ dMu = LA.norm_Inf
+ (GP.gpmvMean mv - LA.fromList (GP.gpMean legacy))
+ dVr = LA.norm_Inf
+ (GP.gpmvVar mv - LA.fromList (GP.gpVar legacy))
+ (dMu < 1e-6) `shouldBe` True
+ (dVr < 1e-6) `shouldBe` True
+
+ it "Hanalyze.Model.GP MV: 2D RBF reaches R² > 0.95 with optimized HP" $ do
+ let nN = 50
+ gx = [(fromIntegral i / 10, fromIntegral (nN - i) / 10)
+ | i <- [0 .. nN - 1 :: Int]]
+ ftn (x1, x2) = sin x1 + 0.5 * cos x2
+ xMV = LA.fromLists [ [a, b] | (a, b) <- gx ] :: LA.Matrix Double
+ yMV = LA.fromList [ ftn p | p <- gx ]
+ p0 = GP.GPParams 1.0 1.0 0.01 1.0 Nothing
+ po = GP.optimizeGPMV GP.RBF xMV yMV p0
+ mdl = GP.GPModel GP.RBF po
+ res = GP.fitGPMV mdl xMV yMV xMV
+ mu = GP.gpmvMean res
+ y = yMV
+ ss = LA.sumElements ((y - mu) ** 2)
+ mY = LA.sumElements y / fromIntegral nN
+ st = LA.sumElements ((y - LA.konst mY nN) ** 2)
+ r2 = 1 - ss / st
+ (r2 > 0.95) `shouldBe` True
+
+ it "Hanalyze.Model.GPRobust MV: 1D input matches legacy fitGPRobust" $ do
+ let xL = [fromIntegral i / 5 | i <- [0 .. 14 :: Int]]
+ yL = map sin xL
+ tL = [0.5, 1.5, 2.5]
+ ker = GP.RBF
+ ps = GP.GPParams 1.0 1.0 0.05 1.0 Nothing
+ lik = GPR.RGaussian 0.1
+ legFit = GPR.fitGPRobust ker ps lik xL yL
+ legacy = GPR.predictGPRobust legFit tL
+ legM = LA.fromList (map fst legacy)
+ xMV = LA.fromLists (map (:[]) xL) :: LA.Matrix Double
+ yMV = LA.fromList yL
+ tMV = LA.fromLists (map (:[]) tL) :: LA.Matrix Double
+ mvFit = GPR.fitGPRobustMV ker ps lik xMV yMV
+ (mvM, _) = GPR.predictGPRobustMV mvFit tMV
+ LA.norm_Inf (mvM - legM) < 1e-6 `shouldBe` True
+
+ it "MV gramMatrix on a single-column input agrees with kernelFromSqDist" $ do
+ let xs1 = LA.fromLists [[fromIntegral i / 5] | i <- [0 .. 19 :: Int]]
+ :: LA.Matrix Double
+ gMV2 = Kn.gramMatrixMV Kn.Gaussian 0.4 xs1
+ ref = LA.fromLists
+ [ [ let xi = xs1 `LA.atIndex` (i, 0)
+ xj = xs1 `LA.atIndex` (j, 0)
+ d = xi - xj
+ in Kn.kernelFromSqDist Kn.Gaussian (d * d / (0.4 * 0.4))
+ | j <- [0 .. 19] ]
+ | i <- [0 .. 19] ]
+ LA.norm_Inf (gMV2 - ref) < 1e-12 `shouldBe` True
diff --git a/test/Hanalyze/Model/LM/DiagnosticsSpec.hs b/test/Hanalyze/Model/LM/DiagnosticsSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/LM/DiagnosticsSpec.hs
@@ -0,0 +1,116 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.LM.DiagnosticsSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.LM as LM
+import qualified Hanalyze.Model.LM.Diagnostics as LMD
+import SpecHelper
+
+spec :: Spec
+spec = do
+ -- Phase 82: 飽和 fit (df = n−p <= 0) で CI/PI 帯が Student-t 例外を出さず、
+ -- 幅ゼロ帯 (lo=hi=ŷ) に潰れること。 profiler が飽和モデルで落ちないための保証。
+ describe "LM CI/PI band: 飽和 (df<=0) ガード (Phase 82)" $ do
+ let xSat = LA.fromColumns [ LA.konst 1.0 2, LA.fromList [1.0, 2.0] ] -- 2×2 = 2 param
+ ySat = LA.fromList [3.0, 5.0]
+ fitS = LM.fitLMVec xSat ySat -- df = 2 − 2 = 0
+ it "confidenceBandAt: df=0 は例外なし・幅ゼロ (lo=hi)" $ do
+ let b = LM.confidenceBandAt xSat fitS 0.95 xSat
+ LM.lowerBound b `shouldBe` LM.upperBound b
+ it "predictionBandAt: df=0 は例外なし・幅ゼロ (lo=hi)" $ do
+ let b = LM.predictionBandAt xSat fitS 0.95 xSat
+ LM.lowerBound b `shouldBe` LM.upperBound b
+ it "df>0 では通常どおり幅を持つ (回帰・帯が線でない)" $ do
+ let x3 = LA.fromColumns [ LA.konst 1.0 3, LA.fromList [1.0, 2.0, 3.0] ]
+ y3 = LA.fromList [3.0, 5.2, 6.9]
+ b = LM.confidenceBandAt x3 (LM.fitLMVec x3 y3) 0.95 x3
+ LM.lowerBound b `shouldNotBe` LM.upperBound b
+
+ describe "Hanalyze.Model.LM.Diagnostics (vs statsmodels OLS)" $ do
+ let xRaw = [1.0, 2, 3, 4, 5, 6, 7, 8, 9, 10]
+ yRaw = [3.7, 5.2, 6.8, 8.5, 9.9, 11.3, 13.1, 14.4, 15.8, 17.2]
+ x = LA.fromColumns
+ [ LA.konst 1.0 (length xRaw)
+ , LA.fromList xRaw
+ ]
+ y = LA.fromList yRaw
+ fit = LM.fitLMVec x y
+
+ approx tol a b = abs (a - b) < tol
+ approxV tol expected actual =
+ length expected == LA.size actual &&
+ and (zipWith (approx tol) expected (LA.toList actual))
+
+ it "ciTValue: 95% / df=8 ≈ 2.306" $
+ LMD.ciTValue 0.95 8 `shouldSatisfy` approx 1e-3 2.306
+
+ it "lmStdErrors matches statsmodels (intercept, slope)" $
+ LMD.lmStdErrors x fit `shouldSatisfy`
+ approxV 1e-5 [0.09602188, 0.01547533]
+
+ it "lmCoefStats t / p match statsmodels" $ do
+ let cs = LMD.lmCoefStats x fit
+ length cs `shouldBe` 2
+ LMD.csTValue (head cs) `shouldSatisfy` approx 1e-3 23.8834
+ LMD.csTValue (cs !! 1) `shouldSatisfy` approx 1e-3 97.4768
+ LMD.csPValue (head cs) `shouldSatisfy` approx 1e-9 1.0062e-8
+ LMD.csPValue (cs !! 1) `shouldSatisfy` approx 1e-13 1.3699e-13
+
+ it "lmFStatistic matches statsmodels (F, p, df1, df2)" $ do
+ let fs = head (LMD.lmFStatistic x fit)
+ LMD.fsValue fs `shouldSatisfy` approx 1e-1 9501.7193
+ LMD.fsPValue fs `shouldSatisfy` approx 1e-13 1.3699e-13
+ LMD.fsDf1 fs `shouldBe` 1
+ LMD.fsDf2 fs `shouldBe` 8
+
+ it "lmInformationCriteria (R lm() convention, k = p + 1 with σ)" $ do
+ let ic = LMD.lmInformationCriteria fit
+ LMD.icLogLik ic `shouldSatisfy` approx 1e-5 6.547424
+ LMD.icAIC ic `shouldSatisfy` approx 1e-5 (-7.094848)
+ LMD.icBIC ic `shouldSatisfy` approx 1e-5 (-6.187093)
+
+ it "hatDiagonal matches statsmodels leverage" $
+ LMD.hatDiagonal x `shouldSatisfy`
+ approxV 1e-6
+ [ 0.34545455, 0.24848485, 0.17575758, 0.12727273, 0.10303030
+ , 0.10303030, 0.12727273, 0.17575758, 0.24848485, 0.34545455 ]
+
+ it "standardizedResiduals match statsmodels (resid_studentized_internal)" $
+ LMD.standardizedResiduals x fit `shouldSatisfy`
+ approxV 1e-5
+ [ -0.89534127, -0.90521501, -0.14722564, 1.31539084, 0.48257654
+ , -0.33234045, 1.88308584, 0.30394970, -0.57197652, -1.56684722 ]
+
+ it "cooksDistance matches statsmodels" $
+ LMD.cooksDistance x fit `shouldSatisfy`
+ approxV 1e-5
+ [ 0.21154283, 0.13546767, 0.00231098, 0.12616429, 0.01337487
+ , 0.00634342, 0.25856339, 0.00984992, 0.05408646, 0.64784992 ]
+
+ it "predictorStdDevs: intercept col=0, x col≈3.0277" $ do
+ let sds = LMD.predictorStdDevs x
+ LA.size sds `shouldBe` 2
+ (LA.toList sds !! 0) `shouldSatisfy` approx 1e-12 0
+ (LA.toList sds !! 1) `shouldSatisfy` approx 1e-6 3.027650
+
+ -- ─────────────────────────────────────────────────────────────────────
diff --git a/test/Hanalyze/Model/LatentClassAnalysisSpec.hs b/test/Hanalyze/Model/LatentClassAnalysisSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/LatentClassAnalysisSpec.hs
@@ -0,0 +1,75 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.LatentClassAnalysisSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.LatentClassAnalysis as LCA
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.LatentClassAnalysis (Phase 32-A2 EM)" $ do
+ -- DGP: 2 クラス、 4 二値特徴、 各 n=400
+ -- class 0: 各特徴 ρ_{0,j,1} = 0.9 (= "1" 多)
+ -- class 1: 各特徴 ρ_{1,j,1} = 0.1 (= "0" 多)
+ -- π = [0.5, 0.5]
+ it "fitLCA: 2 クラス分離 DGP で π / ρ を回復 (label switch 許容)" $ do
+ gen <- MWC.create
+ let nL = 400
+ jL = 4
+ drawObs :: Int -> IO [Int]
+ drawObs cls = mapM (\_ -> do
+ u <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ let pOne = if cls == 0 then 0.9 else 0.1
+ pure (if u < pOne then 1 else 0))
+ [0 .. jL - 1]
+ rows <- mapM (\i -> do
+ cls <- if i < nL `div` 2 then pure 0 else pure 1
+ drawObs cls)
+ [0 .. nL - 1]
+ fit <- LCA.fitLCA 2 2 rows 100 1e-4 gen
+ let pis = LA.toList (LCA.lcaPi fit)
+ length pis `shouldBe` 2
+ -- 両クラスとも 0.5 ± 0.1
+ all (\p -> abs (p - 0.5) < 0.1) pis `shouldBe` True
+ -- ρ: 各特徴のクラス間で「1 を取る確率」 が極端 (0.1 / 0.9 付近)
+ -- label switch 対応: クラス 0 / 1 の (1 を取る確率) を取り出し sort
+ let p1OfClass k =
+ map (\rho -> LA.atIndex rho (k, 1)) (LCA.lcaRho fit)
+ c0 = p1OfClass 0
+ c1 = p1OfClass 1
+ (hiSet, loSet) = if sum c0 > sum c1 then (c0, c1) else (c1, c0)
+ all (> 0.7) hiSet `shouldBe` True
+ all (< 0.3) loSet `shouldBe` True
+ it "fitLCA: 単一クラス (K=1) は trivial、 ρ がデータ周辺分布と一致" $ do
+ gen <- MWC.create
+ let rows = replicate 100 [0, 1] ++ replicate 100 [1, 0]
+ fit <- LCA.fitLCA 1 2 rows 50 1e-6 gen
+ LA.toList (LCA.lcaPi fit) `shouldBe` [1.0]
+ -- K=1 で feature 0: P(0)=0.5, P(1)=0.5
+ let rho0_row0 = LA.toList (LA.flatten ((head (LCA.lcaRho fit)) LA.? [0]))
+ rho0_row0 `shouldSatisfy`
+ (\xs -> length xs == 2
+ && abs ((xs !! 0) - 0.5) < 0.01
+ && abs ((xs !! 1) - 0.5) < 0.01)
diff --git a/test/Hanalyze/Model/LiNGAM/BootstrapSpec.hs b/test/Hanalyze/Model/LiNGAM/BootstrapSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/LiNGAM/BootstrapSpec.hs
@@ -0,0 +1,62 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.LiNGAM.BootstrapSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.QuasiRandom as QR
+import qualified Hanalyze.Model.LiNGAM.Bootstrap as LNGB
+import qualified Hanalyze.Model.DAG as DAG
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.LiNGAM.Bootstrap (Phase 36 A2)" $ do
+ let mkDataN n =
+ let halton b k = QR.radicalInverse b k - 0.5
+ e0s = [halton 2 i | i <- [1..n]]
+ e1s = [halton 3 i | i <- [1..n]]
+ e2s = [halton 5 i | i <- [1..n]]
+ x0s = e0s
+ x1s = zipWith (\a b -> 0.8 * a + b) x0s e1s
+ x2s = zipWith3 (\a b c -> 0.4 * a + 0.6 * b + c) x0s x1s e2s
+ in LA.fromColumns [LA.fromList x0s, LA.fromList x1s, LA.fromList x2s]
+ it "fitBootstrapLiNGAM: 真エッジの出現頻度が高 (>= 0.7)、 偽エッジは低" $ do
+ let cfg = LNGB.defaultBootstrapConfig { LNGB.bcNumBootstraps = 30 }
+ res <- LNGB.fitBootstrapLiNGAM cfg (mkDataN 400)
+ -- 真エッジ: x1 ← x0、 x2 ← x0、 x2 ← x1
+ let probMat = LNGB.brEdgeProbability res
+ LA.atIndex probMat (1, 0) `shouldSatisfy` (>= 0.7)
+ LA.atIndex probMat (2, 1) `shouldSatisfy` (>= 0.7)
+ -- 偽エッジ: 逆方向 x0 ← x1 等は低頻度
+ LA.atIndex probMat (0, 1) `shouldSatisfy` (<= 0.3)
+ it "confidenceDAG: 高頻度エッジのみ採用、 acyclic 維持" $ do
+ let cfg = LNGB.defaultBootstrapConfig { LNGB.bcNumBootstraps = 30 }
+ res <- LNGB.fitBootstrapLiNGAM cfg (mkDataN 400)
+ let g = LNGB.confidenceDAG 0.7 0.8 res
+ DAG.isAcyclic g `shouldBe` True
+ it "signConsistency: 真エッジは符号合致率高い" $ do
+ let cfg = LNGB.defaultBootstrapConfig { LNGB.bcNumBootstraps = 30 }
+ res <- LNGB.fitBootstrapLiNGAM cfg (mkDataN 400)
+ let sigMat = LNGB.brSignConsistency res
+ -- 真エッジは符号合致率 1 に近い
+ LA.atIndex sigMat (1, 0) `shouldSatisfy` (>= 0.9)
+ LA.atIndex sigMat (2, 1) `shouldSatisfy` (>= 0.9)
diff --git a/test/Hanalyze/Model/LiNGAM/DirectSpec.hs b/test/Hanalyze/Model/LiNGAM/DirectSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/LiNGAM/DirectSpec.hs
@@ -0,0 +1,88 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.LiNGAM.DirectSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.QuasiRandom as QR
+import qualified Hanalyze.Model.LiNGAM.Direct as LNG
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.LiNGAM.Direct (Phase 36 A1)" $ do
+ -- 既知 DAG: x0 → x1 → x2, x0 → x2、 非ガウシアン noise (uniform)
+ -- 合成データを deterministic に作って causal order と B 行列を確認
+ let mkSyntheticData :: Int -> LA.Matrix Double
+ mkSyntheticData n =
+ let -- low-discrepancy 列由来の非ガウシアン noise (uniform-like)
+ halton b k = QR.radicalInverse b k - 0.5 -- 平均 0、 ~[-0.5,0.5]
+ e0s = [ halton 2 i | i <- [1..n] ]
+ e1s = [ halton 3 i | i <- [1..n] ]
+ e2s = [ halton 5 i | i <- [1..n] ]
+ -- 真の SEM: x0 = e0、 x1 = 0.8 x0 + e1、 x2 = 0.4 x0 + 0.6 x1 + e2
+ x0s = e0s
+ x1s = zipWith (\x0 e1 -> 0.8 * x0 + e1) x0s e1s
+ x2s = zipWith3 (\x0 x1 e2 -> 0.4 * x0 + 0.6 * x1 + e2)
+ x0s x1s e2s
+ in LA.fromColumns [LA.fromList x0s, LA.fromList x1s, LA.fromList x2s]
+ it "fitDirectLiNGAM 3 変数 SEM: 因果順序を [0,1,2] と推定" $ do
+ let xs = mkSyntheticData 500
+ fit = LNG.fitDirectLiNGAM LNG.defaultDirectLiNGAMConfig xs
+ LNG.dlOrder fit `shouldBe` [0, 1, 2]
+ it "B 行列の非ゼロ要素が真の構造と一致 (x1←x0, x2←x0, x2←x1)" $ do
+ let xs = mkSyntheticData 500
+ fit = LNG.fitDirectLiNGAM LNG.defaultDirectLiNGAMConfig xs
+ b = LNG.dlB fit
+ -- B[1,0] ≈ 0.8 (x1 ← 0.8 x0)
+ abs (LA.atIndex b (1, 0) - 0.8) `shouldSatisfy` (< 0.1)
+ -- B[2,1] ≈ 0.6 (x2 ← 0.6 x1)
+ abs (LA.atIndex b (2, 1) - 0.6) `shouldSatisfy` (< 0.1)
+ -- B[0,1] = 0 (x0 は x1 から影響受けない、 acyclic 構造のため)
+ abs (LA.atIndex b (0, 1)) `shouldSatisfy` (< 0.1)
+ it "Adjacency: 因果関係エッジ 3 本のみ True (threshold 0.05)" $ do
+ let xs = mkSyntheticData 500
+ fit = LNG.fitDirectLiNGAM LNG.defaultDirectLiNGAMConfig xs
+ adj = LNG.dlAdjacency fit
+ -- |B| > 0.05 のエッジ数
+ edges = sum [ round (LA.atIndex adj (i, j)) :: Int
+ | i <- [0..2], j <- [0..2], i /= j ]
+ edges `shouldBe` 3
+ it "entropyApprox: 標準正規分布の entropy ≈ (1+log 2π)/2 ≈ 1.419" $ do
+ -- u が標準ガウシアン近似 (大数 + 中心極限) なら H ≈ 1.4189
+ let n = 1000
+ us = LA.fromList
+ [ let u = QR.radicalInverse 2 i
+ v = QR.radicalInverse 3 i
+ in sqrt (-2 * log (u + 1e-12)) * cos (2 * pi * v)
+ | i <- [1..n] ]
+ uStd = LNG.standardize us
+ h = LNG.entropyApprox uStd
+ -- ガウシアンの真値は 1.4189385、 サンプル + 近似誤差で多少ズレ
+ abs (h - 1.4189) `shouldSatisfy` (< 0.05)
+ it "olsResidual: 完全相関時に残差 ≈ 0" $ do
+ let x = LA.fromList [1..10 :: Double]
+ y = LA.scale 2 x + LA.scalar 1 -- y = 2x + 1
+ r = LNG.olsResidual y x -- y を x で回帰した残差は constant 部分のみ
+ -- residual の標準偏差 ≈ 0 (定数 1 は intercept 込み回帰で吸収されるが
+ -- 本実装は no-intercept なので constant 1 が残る → variance 0 のみ)
+ v = LA.norm_2 (r - LA.scalar (LA.sumElements r / 10))
+ v `shouldSatisfy` (< 1e-9)
diff --git a/test/Hanalyze/Model/LiNGAM/ICASpec.hs b/test/Hanalyze/Model/LiNGAM/ICASpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/LiNGAM/ICASpec.hs
@@ -0,0 +1,79 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.LiNGAM.ICASpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.QuasiRandom as QR
+import qualified Hanalyze.Model.LiNGAM.ICA as LNGI
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.LiNGAM.ICA (Phase 36 A4)" $ do
+ -- 2 変数 SEM: x0 → x1 (係数 0.8)、 非ガウシアン noise
+ let mkData2 n =
+ let halton b k = QR.radicalInverse b k - 0.5
+ e0s = [halton 2 i | i <- [1..n]]
+ e1s = [halton 3 i | i <- [1..n]]
+ x0s = e0s
+ x1s = zipWith (\a b -> 0.8 * a + b) x0s e1s
+ in LA.fromColumns [LA.fromList x0s, LA.fromList x1s]
+ it "fitICALiNGAM: 2 変数 SEM の order を推定" $ do
+ let x = mkData2 500
+ fit <- LNGI.fitICALiNGAM LNGI.defaultICALiNGAMConfig x
+ -- ICA の符号曖昧性 + 順列貪欲のため、 厳密な order ではなく adjacency
+ -- に 1 つのエッジが立つことを確認
+ let adj = LNGI.ilAdjacency fit
+ edges = sum [ round (LA.atIndex adj (i, j)) :: Int
+ | i <- [0, 1], j <- [0, 1], i /= j ]
+ edges `shouldSatisfy` (>= 1)
+
+ describe "Hanalyze.Model.LiNGAM.ICA: Hungarian 化 (p=8)" $ do
+ -- 8 変数 chain SEM: x_0 → x_1 → ... → x_7、 係数 0.6、 非ガウシアン noise。
+ -- Hungarian/greedy のどちらでも fit が走ることだけ確認 (adjacency >= 1)。
+ -- 純粋なアルゴリズム妥当性は Hungarian テストで担保。
+ let mkChain n p0 =
+ let halton b k = QR.radicalInverse b k - 0.5
+ primes = take p0 [2, 3, 5, 7, 11, 13, 17, 19, 23, 29]
+ es = [ [halton b i | i <- [1..n]] | b <- primes ]
+ go acc [] = reverse acc
+ go [] (e:rs) = go [e] rs
+ go (prev:rest) (e:rs) =
+ let cur = zipWith (\a b -> 0.6 * a + b) prev e
+ in go (cur : prev : rest) rs
+ cols = case es of
+ [] -> []
+ (e0:r) -> go [e0] r
+ in LA.fromColumns (map LA.fromList cols)
+ it "Hungarian 化: 8 変数 chain で adjacency が立つ" $ do
+ let x = mkChain 400 8
+ cfg = LNGI.defaultICALiNGAMConfig { LNGI.ilcUseHungarian = True }
+ fit <- LNGI.fitICALiNGAM cfg x
+ let adj = LNGI.ilAdjacency fit
+ edges = sum [ round (LA.atIndex adj (i, j)) :: Int
+ | i <- [0 .. 7], j <- [0 .. 7], i /= j ]
+ edges `shouldSatisfy` (>= 1)
+ it "貪欲版も同じ shape で動く (ilcUseHungarian = False、 回帰確認)" $ do
+ let x = mkChain 400 8
+ cfg = LNGI.defaultICALiNGAMConfig { LNGI.ilcUseHungarian = False }
+ fit <- LNGI.fitICALiNGAM cfg x
+ LA.rows (LNGI.ilAdjacency fit) `shouldBe` 8
diff --git a/test/Hanalyze/Model/LiNGAM/MultiGroupSpec.hs b/test/Hanalyze/Model/LiNGAM/MultiGroupSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/LiNGAM/MultiGroupSpec.hs
@@ -0,0 +1,46 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.LiNGAM.MultiGroupSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.QuasiRandom as QR
+import qualified Hanalyze.Model.LiNGAM.MultiGroup as LNGM
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.LiNGAM.MultiGroup (Phase 36 A6)" $ do
+ -- 共通構造 x0 → x1 → x2 を 2 群分作成 (係数は群ごとに微小差)
+ let mkGroup n c1 c2 =
+ let halton b k = QR.radicalInverse b k - 0.5
+ e0s = [halton 2 i | i <- [1..n]]
+ e1s = [halton 3 i | i <- [1..n]]
+ e2s = [halton 5 i | i <- [1..n]]
+ x0s = e0s
+ x1s = zipWith (\a b -> c1 * a + b) x0s e1s
+ x2s = zipWith3 (\a b c -> c2 * b + c) x0s x1s e2s
+ in LA.fromColumns [LA.fromList x0s, LA.fromList x1s, LA.fromList x2s]
+ it "2 群の共通 causal order を [0,1,2] と推定" $ do
+ let g1 = mkGroup 400 0.8 0.6
+ g2 = mkGroup 400 0.7 0.5
+ fit = LNGM.fitMultiGroupLiNGAM LNGM.defaultMultiGroupConfig [g1, g2]
+ LNGM.mgCommonOrder fit `shouldBe` [0, 1, 2]
diff --git a/test/Hanalyze/Model/LiNGAM/PairwiseSpec.hs b/test/Hanalyze/Model/LiNGAM/PairwiseSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/LiNGAM/PairwiseSpec.hs
@@ -0,0 +1,46 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.LiNGAM.PairwiseSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.QuasiRandom as QR
+import qualified Hanalyze.Model.LiNGAM.Pairwise as LNGP
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.LiNGAM.Pairwise (Phase 36 A3)" $ do
+ -- x → y、 noise は uniform 由来非ガウシアン
+ let mkPair n =
+ let halton b k = QR.radicalInverse b k - 0.5
+ xs = LA.fromList [halton 2 i | i <- [1..n]]
+ es = LA.fromList [halton 3 i | i <- [1..n]]
+ ys = LA.scale 0.8 xs + es
+ in (xs, ys)
+ it "x → y を XtoY と判定" $ do
+ let (x, y) = mkPair 500
+ r = LNGP.pairwiseLiNGAM 0 x y
+ LNGP.prDirection r `shouldBe` LNGP.XtoY
+ it "y → x を YtoX と判定 (入力順を逆転)" $ do
+ let (x, y) = mkPair 500
+ r = LNGP.pairwiseLiNGAM 0 y x
+ LNGP.prDirection r `shouldBe` LNGP.YtoX
diff --git a/test/Hanalyze/Model/LiNGAM/ParceSpec.hs b/test/Hanalyze/Model/LiNGAM/ParceSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/LiNGAM/ParceSpec.hs
@@ -0,0 +1,68 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.LiNGAM.ParceSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.QuasiRandom as QR
+import qualified Hanalyze.Model.LiNGAM.Parce as LNGPa
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.LiNGAM.Parce (Phase 36 A7)" $ do
+ -- 同 SEM データで ParceLiNGAM が DirectLiNGAM と同等の結果を出すか確認
+ let mkData n =
+ let halton b k = QR.radicalInverse b k - 0.5
+ e0s = [halton 2 i | i <- [1..n]]
+ e1s = [halton 3 i | i <- [1..n]]
+ e2s = [halton 5 i | i <- [1..n]]
+ x0s = e0s
+ x1s = zipWith (\a b -> 0.8 * a + b) x0s e1s
+ x2s = zipWith3 (\a b c -> 0.4 * a + 0.6 * b + c) x0s x1s e2s
+ in LA.fromColumns [LA.fromList x0s, LA.fromList x1s, LA.fromList x2s]
+ it "fitParceLiNGAM: 潜在交絡なしのデータで causal order を [0,1,2] と推定" $ do
+ let x = mkData 500
+ fit = LNGPa.fitParceLiNGAM LNGPa.defaultParceConfig x
+ LNGPa.pcOrder fit `shouldBe` [0, 1, 2]
+ LNGPa.pcUnresolvedGroup fit `shouldBe` []
+
+ -- 潜在交絡: hidden h が x0, x1 を駆動、 x2 は両者の sink
+ -- h ~ 非ガウシアン、 x0 = 0.7 h + e0、 x1 = 0.6 h + e1、 x2 = 0.5 x0 + 0.4 x1 + e2
+ -- 観測 X = [x0, x1, x2] のみ。 v0.2 は x2 を sink と同定、 x0/x1 は
+ -- 独立性が満たされないため unresolved group に入る想定。
+ let mkLatent n =
+ let halton b k = QR.radicalInverse b k - 0.5
+ hs = [halton 2 i | i <- [1..n]]
+ e0s = [halton 3 i | i <- [1..n]]
+ e1s = [halton 5 i | i <- [1..n]]
+ e2s = [halton 7 i | i <- [1..n]]
+ x0s = zipWith (\h e -> 0.7 * h + e) hs e0s
+ x1s = zipWith (\h e -> 0.6 * h + e) hs e1s
+ x2s = zipWith3 (\a b c -> 0.5 * a + 0.4 * b + c) x0s x1s e2s
+ in LA.fromColumns [LA.fromList x0s, LA.fromList x1s, LA.fromList x2s]
+ it "fitParceLiNGAM v0.2: 潜在交絡シナリオで unresolved group に x0/x1 が残る" $ do
+ let x = mkLatent 500
+ fit = LNGPa.fitParceLiNGAM LNGPa.defaultParceConfig x
+ -- x2 は sink として確定 (末尾)
+ last (LNGPa.pcOrder fit) `shouldBe` 2
+ -- x0, x1 は順序確定できず unresolved group に入る (順序問わず)
+ sort (LNGPa.pcUnresolvedGroup fit) `shouldBe` [0, 1]
diff --git a/test/Hanalyze/Model/LiNGAM/VARSpec.hs b/test/Hanalyze/Model/LiNGAM/VARSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/LiNGAM/VARSpec.hs
@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.LiNGAM.VARSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.QuasiRandom as QR
+import qualified Hanalyze.Model.LiNGAM.VAR as LNGV
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.LiNGAM.VAR (Phase 36 A5)" $ do
+ -- VAR(1) + contemporaneous LiNGAM の合成データ
+ -- Y_t = A · Y_{t-1} + u_t、 u_t は 2 変数 (x0 → x1) の LiNGAM 構造
+ let mkSeries n =
+ let halton b k = QR.radicalInverse b k - 0.5
+ e0s = [halton 2 i | i <- [1..n]]
+ e1s = [halton 3 i | i <- [1..n]]
+ -- u_t (同時刻): u0 = e0、 u1 = 0.7 u0 + e1
+ u0s = e0s
+ u1s = zipWith (\a b -> 0.7 * a + b) u0s e1s
+ -- VAR(1): Y_t = 0.3 Y_{t-1} + u_t (両変数とも自己回帰)
+ go [_, _] _ _ acc = reverse acc
+ go (u0:u1:rest) y0Prev y1Prev acc =
+ let y0 = 0.3 * y0Prev + u0
+ y1 = 0.3 * y1Prev + u1
+ in go rest y0 y1 ((y0, y1) : acc)
+ go _ _ _ acc = reverse acc
+ pairs = go (interleave u0s u1s) 0 0 []
+ ys = take (n - 1) (map fst pairs)
+ y1ss = take (n - 1) (map snd pairs)
+ interleave (a:as) (b:bs) = a : b : interleave as bs
+ interleave xs _ = xs
+ in LA.fromColumns [LA.fromList ys, LA.fromList y1ss]
+ it "fitVARLiNGAM: 同時刻 contemporaneous order を推定" $ do
+ let y = mkSeries 500
+ fit = LNGV.fitVARLiNGAM LNGV.defaultVARLiNGAMConfig y
+ LNGV.vlContempOrder fit `shouldBe` [0, 1]
diff --git a/test/Hanalyze/Model/MultiOutputSpec.hs b/test/Hanalyze/Model/MultiOutputSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/MultiOutputSpec.hs
@@ -0,0 +1,185 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.MultiOutputSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.GP as GP
+import qualified Hanalyze.Model.GPRobust as GPR
+import qualified Hanalyze.Model.GP as GP
+import qualified Hanalyze.Model.GPRobust as GPR
+import qualified Hanalyze.Model.RFF as RFF
+import qualified Hanalyze.Model.Regularized as Reg
+import qualified Hanalyze.Model.Spline as Sp
+import qualified Hanalyze.Model.KernelRegression as K
+import qualified Hanalyze.Model.Core as Core
+import qualified Hanalyze.Model.GLM as GLM
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.MCMC.Core as Core
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Multi-output equivalence (q=1)" $ do
+ let xs = LA.fromLists [[1,1.0], [1,2.0], [1,3.0], [1,4.0], [1,5.0]] :: LA.Matrix Double
+ yV = LA.fromList [2.1, 3.9, 6.0, 8.1, 10.0] :: LA.Vector Double
+ yM = LA.asColumn yV
+ approx tol a b = abs (a - b) < tol
+ approxList tol as bs = length as == length bs &&
+ all (uncurry (approx tol)) (zip as bs)
+ buildGroupsLocal gvec =
+ let lbls = V.fromList . sort . foldr (\x acc -> if x `elem` acc then acc else x:acc) [] $ V.toList gvec
+ qN = V.length lbls
+ idxFor x = case V.elemIndex x lbls of
+ Just i -> i
+ Nothing -> 0
+ idx = V.map idxFor gvec
+ sz = V.fromList [ V.length (V.filter (== j) idx) | j <- [0 .. qN - 1] ]
+ in (lbls, idx, sz)
+
+ it "M1 Regularized Ridge: fitRegularized == fitRegularizedMulti col 0" $ do
+ let single = Reg.fitRegularized (Reg.L2 0.1) xs yV
+ multi = Reg.fitRegularizedMulti (Reg.L2 0.1) xs yM
+ extr = Reg.regFitFromMulti 0 multi
+ approxList 1e-9 (LA.toList (Reg.rfBeta single))
+ (LA.toList (Reg.rfBeta extr))
+ `shouldBe` True
+
+ it "M1 Regularized Lasso: q=1 一致" $ do
+ let single = Reg.fitRegularized (Reg.L1 0.05) xs yV
+ multi = Reg.fitRegularizedMulti (Reg.L1 0.05) xs yM
+ extr = Reg.regFitFromMulti 0 multi
+ approxList 1e-9 (LA.toList (Reg.rfBeta single))
+ (LA.toList (Reg.rfBeta extr))
+ `shouldBe` True
+
+ it "M2 Spline: fitSpline == fitSplineMulti col 0" $ do
+ let xv = V.fromList [1,2,3,4,5,6,7,8,9,10] :: V.Vector Double
+ yv = V.fromList (map (\x -> sin (x/2) + 0.01*x) (V.toList xv))
+ knots = [1,3,5,7,10]
+ single = Sp.fitSpline (Sp.BSpline 3) knots xv yv
+ ymat = LA.asColumn (LA.fromList (V.toList yv))
+ multi = Sp.fitSplineMulti (Sp.BSpline 3) knots xv ymat
+ colS = LA.toList (Sp.sfBeta single)
+ colM = LA.toList (LA.flatten (Sp.smfBeta multi LA.¿ [0]))
+ approxList 1e-9 colS colM `shouldBe` True
+
+ it "bsplineBasis: partition of unity が右端 x=hi でも成立 (= 1)" $ do
+ -- clamped ノットで hi が重複するため、 退化区間 [hi,hi] を右閉にすると
+ -- 高次再帰で基底全ゼロ化する欠陥があった (計測で確認・修正済)。 内点と
+ -- 端点の両方で行和 = 1 を要求する回帰テスト。
+ let knots = [0,2,4,6,8] :: [Double]
+ xs = V.fromList [0, 4, 7.99, 8.0] -- 左端 / 内点 / 端近傍 / 右端
+ basis = Sp.bsplineBasis 3 knots xs
+ sums = map sum (LA.toLists basis)
+ approxList 1e-9 sums [1,1,1,1] `shouldBe` True
+
+ it "fitSpline: 右端 x=hi のフィット値が崩れない (基底全ゼロ化の回帰)" $ do
+ -- y=x² を 3 次 B-spline で fit。 右端の fitted が 0 に落ちず原値に近いこと。
+ let xv = V.fromList [0,1,2,3,4,5,6,7,8] :: V.Vector Double
+ yv = V.map (\x -> x*x) xv
+ fit = Sp.fitSpline (Sp.BSpline 3) [0,2,4,6,8] xv yv
+ yhatLast = V.last (Sp.predictSpline fit (V.fromList [8.0]))
+ yhatLast `shouldSatisfy` (\v -> abs (v - 64) < 5) -- 64 = 8² 近傍 (0 でない)
+
+ it "M3 Kernel Ridge: kernelRidge == kernelRidgeMulti col 0" $ do
+ let xv = V.fromList [0.0,1,2,3,4,5,6,7,8,9] :: V.Vector Double
+ yv = V.fromList [0.0, 0.5, 1.0, 1.4, 1.7, 1.9, 2.0, 2.0, 1.95, 1.8]
+ single = K.kernelRidge K.Gaussian 1.0 0.01 xv yv
+ ymat = LA.asColumn (LA.fromList (V.toList yv))
+ multi = K.kernelRidgeMulti K.Gaussian 1.0 0.01 xv ymat
+ approxList 1e-9 (LA.toList (K.krAlpha single))
+ (LA.toList (LA.flatten (K.krmAlpha multi LA.¿ [0])))
+ `shouldBe` True
+
+ it "M3 Kernel NW: nwRegression == nwRegressionMulti col 0" $ do
+ let xv = V.fromList [0.0,1,2,3,4,5,6,7,8,9] :: V.Vector Double
+ yv = V.fromList [0.1, 0.3, 0.7, 1.0, 1.5, 1.9, 2.0, 1.95, 1.8, 1.5]
+ xn = V.fromList [0.5, 2.5, 5.5, 8.5]
+ single = K.nwRegression K.Gaussian 1.0 xv yv xn
+ ymat = LA.asColumn (LA.fromList (V.toList yv))
+ multi = K.nwRegressionMulti K.Gaussian 1.0 xv ymat xn
+ colM = LA.toList (LA.flatten (multi LA.¿ [0]))
+ approxList 1e-9 (V.toList single) colM `shouldBe` True
+
+ it "M4 RFF Ridge: rffRidge == rffRidgeMulti col 0" $ do
+ gen <- MWC.create
+ rff <- RFF.sampleRFFRBF 16 1.0 1.0 gen
+ let xList = [0.0, 1, 2, 3, 4, 5]
+ yList = [0.1, 0.5, 1.0, 1.4, 1.7, 1.9]
+ single = RFF.rffRidge rff xList yList 0.01
+ ymat = LA.asColumn (LA.fromList yList)
+ multi = RFF.rffRidgeMulti rff xList ymat 0.01
+ approxList 1e-9 (LA.toList (RFF.rffrWeights single))
+ (LA.toList (LA.flatten (RFF.rffrmWeights multi LA.¿ [0])))
+ `shouldBe` True
+
+ it "M5 GP: fitGP mean == fitGPMulti col 0" $ do
+ let model = GP.GPModel GP.RBF GP.defaultGPParams
+ trX = [0.0, 1, 2, 3, 4, 5]
+ trY = [0.1, 0.4, 0.9, 1.3, 1.6, 1.8]
+ tsX = [0.5, 2.5, 4.5]
+ single = GP.fitGP model trX trY tsX
+ ymat = LA.asColumn (LA.fromList trY)
+ (mMat, _) = GP.fitGPMulti model trX ymat tsX
+ approxList 1e-9 (GP.gpMean single)
+ (LA.toList (LA.flatten (mMat LA.¿ [0])))
+ `shouldBe` True
+
+ it "M5 GPRobust: fitGPRobust α == fitGPRobustMulti col 0" $ do
+ let params = GP.defaultGPParams
+ trX = [0.0, 1, 2, 3, 4, 5]
+ trY = [0.1, 0.4, 5.0, 1.3, 1.6, 1.8] -- 1 outlier at idx 2
+ single = GPR.fitGPRobust GP.RBF params (GPR.RStudentT 4 0.3) trX trY
+ ymat = LA.asColumn (LA.fromList trY)
+ multi = GPR.fitGPRobustMulti GP.RBF params (GPR.RStudentT 4 0.3) trX ymat
+ firstFit = head (GPR.rgmFits multi)
+ approxList 1e-9 (LA.toList (GPR.rgpAlpha single))
+ (LA.toList (GPR.rgpAlpha firstFit))
+ `shouldBe` True
+
+ it "M6 GLM Gaussian: fitGLM == fitGLMMulti col 0" $ do
+ let single = GLM.fitGLM GLM.Gaussian xs yV
+ multi = GLM.fitGLMMulti GLM.Gaussian GLM.Identity xs yM
+ colM = LA.toList (LA.flatten (GLM.gfmBeta multi LA.¿ [0]))
+ colS = LA.toList (LA.flatten (Core.coefficients single))
+ approxList 1e-7 colS colM `shouldBe` True
+
+ it "M7 LME: fitLME == fitLMEMulti col 0" $ do
+ let xMat = LA.fromLists
+ [[1,1],[1,2],[1,3],[1,4],
+ [1,1],[1,2],[1,3],[1,4],
+ [1,1],[1,2],[1,3],[1,4]] :: LA.Matrix Double
+ y1 = LA.fromList [7.1,6.9,7.0,7.0, 5.0,4.9,5.1,5.0, 3.0,2.9,3.1,3.0]
+ ym = LA.asColumn y1
+ gv = V.fromList (["A","A","A","A","B","B","B","B","C","C","C","C"] :: [T.Text])
+ (lbls, idx, sz) = buildGroupsLocal gv
+ single = fitLME xMat y1 idx lbls sz
+ multi = fitLMEMulti xMat ym idx lbls sz
+ firstM = head (glmmFits multi)
+ glmmRandVar firstM `shouldSatisfy` approx 1e-9 (glmmRandVar single)
+
+ -- ===========================================================================
+ -- 単目的オプティマイザ (Hanalyze.Optim.NelderMead)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Model/NaiveBayesSpec.hs b/test/Hanalyze/Model/NaiveBayesSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/NaiveBayesSpec.hs
@@ -0,0 +1,59 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.NaiveBayesSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Unboxed as VU
+import qualified Hanalyze.Model.NaiveBayes as NB
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.NaiveBayes (Phase 34-A5)" $ do
+ -- Gaussian: 2 つの正規分布
+ let xG = LA.fromLists $
+ [[-2.0, -2.0], [-1.5, -1.8], [-2.1, -1.9], [-1.9, -2.2]] ++
+ [[ 2.0, 2.0], [ 1.8, 2.1], [ 2.2, 1.9], [ 1.7, 2.3]]
+ yG = VU.fromList ([0,0,0,0, 1,1,1,1] :: [Int])
+ it "fitGNB + predictNB: 2 ガウス分離で訓練精度 100%" $ do
+ let nb = NB.NBGaussian (NB.fitGNB xG yG)
+ ys = NB.predictNB nb xG
+ correct = VU.length (VU.filter id (VU.zipWith (==) ys yG))
+ correct `shouldBe` VU.length yG
+ it "fitGNB: gnbMeans の長さ = クラス数" $ do
+ let nb = NB.fitGNB xG yG
+ length (NB.gnbMeans nb) `shouldBe` 2
+ NB.gnbClasses nb `shouldBe` [0, 1]
+ it "predictNBLogProbs: 正規化済 (exp 和 = 1)" $ do
+ let nb = NB.NBGaussian (NB.fitGNB xG yG)
+ lps = NB.predictNBLogProbs nb xG
+ and [ abs (sum [ exp z | z <- row ] - 1) < 1e-10 | row <- lps ]
+ `shouldBe` True
+ it "fitMNB + predictNB: カウント特徴 (Multinomial)" $ do
+ -- クラス 0 は feature 0 中心、 クラス 1 は feature 1 中心
+ let xM = LA.fromLists [[5,1,0],[6,0,1],[4,2,0],
+ [0,1,5],[1,0,6],[0,2,4]]
+ yM = VU.fromList ([0,0,0, 1,1,1] :: [Int])
+ nb = NB.NBMultinomial (NB.fitMNB 1.0 xM yM)
+ ys = NB.predictNB nb xM
+ correct = VU.length (VU.filter id (VU.zipWith (==) ys yM))
+ correct `shouldBe` VU.length yM
diff --git a/test/Hanalyze/Model/NeuralNetworkSpec.hs b/test/Hanalyze/Model/NeuralNetworkSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/NeuralNetworkSpec.hs
@@ -0,0 +1,88 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.NeuralNetworkSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Unboxed as VU
+import qualified Hanalyze.Model.NeuralNetwork as NN
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.NeuralNetwork (Phase 16)" $ do
+ let -- 線形 y = 2x + 1 + ノイズ なし
+ xReg = LA.fromColumns
+ [LA.fromList [fromIntegral i / 5 - 1 | i <- [0 :: Int .. 9]]]
+ yReg = LA.fromList [2 * (fromIntegral i / 5 - 1) + 1
+ | i <- [0 :: Int .. 9]]
+ -- 2 クラス分類: x < 0 → 0、 x >= 0 → 1
+ xCls = LA.fromColumns
+ [LA.fromList [fromIntegral i - 5 | i <- [0 :: Int .. 9]]]
+ yCls = VU.fromList [0, 0, 0, 0, 0, 1, 1, 1, 1, 1]
+ it "fitMLPRegressor: 線形データに学習収束" $ do
+ gen <- MWC.createSystemRandom
+ let cfg = NN.defaultMLP
+ { NN.mlpHidden = [8]
+ , NN.mlpEpochs = 500
+ , NN.mlpBatch = 5
+ , NN.mlpLR = 0.05
+ }
+ fit <- NN.fitMLPRegressor cfg xReg yReg gen
+ let preds = LA.flatten (NN.predictMLP fit xReg)
+ mse = LA.sumElements ((preds - yReg) ^ (2 :: Int))
+ / fromIntegral (LA.size yReg)
+ mse `shouldSatisfy` (< 0.3)
+ it "fitMLPRegressor: loss history が単調減少 (大局的)" $ do
+ gen <- MWC.createSystemRandom
+ let cfg = NN.defaultMLP { NN.mlpEpochs = 100 }
+ fit <- NN.fitMLPRegressor cfg xReg yReg gen
+ let losses = NN.mlpLossHist fit
+ length losses `shouldBe` 100
+ last losses `shouldSatisfy` (< head losses)
+ it "fitMLPClassifier: 1-D 線形分離で訓練精度 100%" $ do
+ gen <- MWC.createSystemRandom
+ let cfg = NN.defaultMLP
+ { NN.mlpHidden = [4]
+ , NN.mlpEpochs = 300
+ , NN.mlpBatch = 5
+ , NN.mlpLR = 0.1
+ }
+ fit <- NN.fitMLPClassifier cfg xCls yCls gen
+ let preds = NN.predictMLPClass fit xCls
+ correct = length [ () | i <- [0 .. VU.length yCls - 1]
+ , preds V.! i == yCls VU.! i ]
+ correct `shouldSatisfy` (>= 9)
+ it "fitMLPClassifier: mlpClasses は sorted unique label" $ do
+ gen <- MWC.createSystemRandom
+ let cfg = NN.defaultMLP { NN.mlpEpochs = 5 }
+ fit <- NN.fitMLPClassifier cfg xCls yCls gen
+ NN.mlpClasses fit `shouldBe` [0, 1]
+ it "predictMLP: 出力 shape が (n × out)" $ do
+ gen <- MWC.createSystemRandom
+ let cfg = NN.defaultMLP { NN.mlpEpochs = 5 }
+ fit <- NN.fitMLPRegressor cfg xReg yReg gen
+ let out = NN.predictMLP fit xReg
+ LA.rows out `shouldBe` 10
+ LA.cols out `shouldBe` 1
diff --git a/test/Hanalyze/Model/PCASpec.hs b/test/Hanalyze/Model/PCASpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/PCASpec.hs
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.PCASpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.PCA as PCA
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.PCA" $ do
+ it "PCA on rank-1 matrix: 1st component explains ~100% var" $ do
+ let -- Rank-1: each row = scalar × [1, 2, 3]
+ ks = [1.0, 2.0, 3.0, 4.0, 5.0, 6.0]
+ xs = LA.fromLists [[k, 2 * k, 3 * k] | k <- ks]
+ r = PCA.pca PCA.Center Nothing xs
+ head (LA.toList (PCA.pcaExplainedRatio r))
+ `shouldSatisfy` (> 0.999)
+
+ it "pcaTransform + pcaInverse は Center mode で全成分なら復元 ≈ x" $ do
+ let xs = LA.fromLists [[1, 2, 3], [4, 5, 6], [7, 8, 9], [2, 1, 0]]
+ r = PCA.pca PCA.Center Nothing xs
+ scores = PCA.pcaTransform r xs
+ recon = PCA.pcaInverse r scores
+ diff = LA.norm_2 (LA.flatten (xs - recon))
+ diff `shouldSatisfy` (< 1e-9)
+
+ it "pcaCumExplained は monotone increasing で max ≤ 1" $ do
+ let xs = LA.fromLists [[k, 2*k+1, k*k]
+ | k <- [1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0]]
+ r = PCA.pca PCA.Center Nothing xs
+ cum = LA.toList (PCA.pcaCumExplained r)
+ last cum `shouldSatisfy` (<= 1.0001)
+ and (zipWith (<=) cum (tail cum)) `shouldBe` True
+
+ it "CenterScale で各列の SD が 1 に正規化される" $ do
+ let xs = LA.fromLists [[1, 100, 0.1], [2, 200, 0.2],
+ [3, 300, 0.3], [4, 400, 0.4]]
+ r = PCA.pca PCA.CenterScale Nothing xs
+ -- SD は元データの per-col SD で保存される
+ LA.size (PCA.pcaScale r) `shouldBe` 3
+ all (> 0) (LA.toList (PCA.pcaScale r)) `shouldBe` True
+
+ -- ===========================================================================
+ -- Hanalyze.Stat.ClassMetrics (Phase 3)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Model/PLSSpec.hs b/test/Hanalyze/Model/PLSSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/PLSSpec.hs
@@ -0,0 +1,105 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.PLSSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.PLS as PLS
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.PLS (Phase 9)" $ do
+ -- 合成データ: y = 2 x1 + 1 x2 + 0 x3 (3 features) + noise
+ let synthData :: IO (LA.Matrix Double, LA.Vector Double, LA.Vector Double)
+ synthData = do
+ gen <- MWC.create
+ let n = 100; p = 5
+ xs <- LA.fromLists <$> sequence
+ [ sequence [ MWC.uniformR (-1, 1) gen | _ <- [1..p] ]
+ | _ <- [1..n] ]
+ let trueB = LA.fromList [2.0, 1.0, 0.0, 0.0, 0.0] :: LA.Vector Double
+ y0 = xs LA.#> trueB
+ noise <- LA.fromList <$> sequence
+ [ MWC.uniformR (-0.1, 0.1) gen | _ <- [1..n] ]
+ pure (xs, y0 + noise, trueB)
+
+ it "fitPLS1: n_components=2 で fit、 shape 整合性" $ do
+ (xs, y, _) <- synthData
+ let cfg = PLS.defaultPLS { PLS.plsN_Components = 2 }
+ case PLS.fitPLS1 cfg xs y of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ LA.rows (PLS.plsScoresT f) `shouldBe` 100
+ LA.cols (PLS.plsScoresT f) `shouldBe` 2
+ LA.rows (PLS.plsLoadingsP f) `shouldBe` 5
+ LA.cols (PLS.plsLoadingsP f) `shouldBe` 2
+ LA.size (PLS.plsVIP f) `shouldBe` 5
+ LA.size (PLS.plsR2X f) `shouldBe` 2
+
+ it "predictPLS1: 合成データで真値に近い予測" $ do
+ (xs, y, _) <- synthData
+ let cfg = PLS.defaultPLS { PLS.plsN_Components = 3 }
+ case PLS.fitPLS1 cfg xs y of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ let yHat = PLS.predictPLS1 f xs
+ resid = y - yHat
+ n = LA.size y :: Int
+ mse = LA.sumElements (resid * resid) / fromIntegral n
+ mse `shouldSatisfy` (< 0.05)
+
+ it "VIP: 強い変数 (x1, x2) は VIP > 1、 ノイズ変数は VIP < 1 に近い" $ do
+ (xs, y, _) <- synthData
+ let cfg = PLS.defaultPLS { PLS.plsN_Components = 3 }
+ case PLS.fitPLS1 cfg xs y of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ let vip = LA.toList (PLS.plsVIP f)
+ -- VIP[0] (x1) は最大級
+ (vip !! 0) `shouldSatisfy` (> 1.0)
+ -- VIP[1] (x2) も 1 超え
+ (vip !! 1) `shouldSatisfy` (> 0.5)
+
+ it "n_components が n-1 超えで Left" $ do
+ (xs, y, _) <- synthData
+ let cfg = PLS.defaultPLS { PLS.plsN_Components = 200 }
+ case PLS.fitPLS1 cfg xs y of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for too many components"
+
+ it "SIMPLS は現状未実装で Left" $ do
+ (xs, y, _) <- synthData
+ let cfg = PLS.defaultPLS { PLS.plsAlgorithm = PLS.SIMPLS }
+ case PLS.fitPLS1 cfg xs y of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for SIMPLS (not implemented)"
+
+ it "selectPLSComponentsCV: best K が grid 内" $ do
+ (xs, y, _) <- synthData
+ gen <- MWC.create
+ sel <- PLS.selectPLSComponentsCV 5 4 xs (LA.asColumn y) gen
+ PLS.plsBestK sel `shouldSatisfy` (\k -> k >= 1 && k <= 4)
+ length (PLS.plsCVMSEs sel) `shouldBe` 4
+ PLS.plsOneSeK sel `shouldSatisfy` (<= PLS.plsBestK sel)
diff --git a/test/Hanalyze/Model/PartialDependenceSpec.hs b/test/Hanalyze/Model/PartialDependenceSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/PartialDependenceSpec.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | 部分従属 (PDP) / ICE 純粋エンジンのテスト (Phase 75.27)。
+-- 既知の predict 関数で PDP の解析値・ICE 本数・grid 端点・中心化を検証する。
+module Hanalyze.Model.PartialDependenceSpec (spec) where
+
+import Test.Hspec
+import qualified Numeric.LinearAlgebra as LA
+import Hanalyze.Model.PartialDependence
+
+-- 3 行 × 2 列の小さな訓練行列。 列 0 = {0,1,2}, 列 1 = {10,20,30}。
+trainX :: LA.Matrix Double
+trainX = LA.fromLists [ [0, 10], [1, 20], [2, 30] ]
+
+spec :: Spec
+spec =
+ describe "Hanalyze.Model.PartialDependence" $ do
+
+ it "線形 predict f = 2*x_j: PDP は grid をそのまま 2 倍 (他列に非依存)" $ do
+ let predict m = [ 2 * (row LA.! 0) | row <- LA.toRows m ] -- 列 0 のみ使う
+ r = partialDependence trainX predict 0 3
+ pdpGrid r `shouldBe` [0, 1, 2]
+ pdpMean r `shouldBe` [0, 2, 4]
+
+ it "加法 f = 3*x0 + 5*x1: 特徴 0 の PDP 傾きは 3, 切片は 5*mean(x1)" $ do
+ let predict m = [ 3 * (row LA.! 0) + 5 * (row LA.! 1) | row <- LA.toRows m ]
+ r = partialDependence trainX predict 0 3
+ -- x1 平均 = 20 → 定数寄与 100。 PDP = 3*grid + 100。
+ pdpMean r `shouldBe` [100, 103, 106]
+
+ it "ICE: 曲線本数 = 行数、 各曲線の長さ = grid 数" $ do
+ let predict m = [ row LA.! 0 + row LA.! 1 | row <- LA.toRows m ]
+ r = partialDependence trainX predict 0 4
+ length (pdpIce r) `shouldBe` 3
+ map length (pdpIce r) `shouldBe` [4, 4, 4]
+
+ it "grid 端点は注目列の観測 min/max" $ do
+ let predict m = replicate (LA.rows m) 0
+ r = partialDependence trainX predict 1 5 -- 列 1 = {10,20,30}
+ head (pdpGrid r) `shouldBe` 10
+ last (pdpGrid r) `shouldBe` 30
+
+ it "PDP = ICE 群の各 grid 列平均に一致" $ do
+ let predict m = [ 2 * (row LA.! 0) + (row LA.! 1) | row <- LA.toRows m ]
+ r = partialDependence trainX predict 0 3
+ colMeans = map (\k -> sum [ c !! k | c <- pdpIce r ] / 3) [0, 1, 2]
+ pdpMean r `shouldBe` colMeans
+
+ it "centerICE: 各 ICE 曲線が左端で 0 になる" $ do
+ let predict m = [ 3 * (row LA.! 0) + (row LA.! 1) | row <- LA.toRows m ]
+ r = centerICE (partialDependence trainX predict 0 3)
+ map head (pdpIce r) `shouldBe` [0, 0, 0]
+ -- 中心化後の PDP も左端 0。
+ head (pdpMean r) `shouldBe` 0
+
+ it "空行列・列外 index は空結果" $ do
+ let predict m = replicate (LA.rows m) 0
+ partialDependence (LA.fromLists []) predict 0 5 `shouldBe` PDPResult [] [] []
+ partialDependence trainX predict 9 5 `shouldBe` PDPResult [] [] []
diff --git a/test/Hanalyze/Model/RFFSpec.hs b/test/Hanalyze/Model/RFFSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/RFFSpec.hs
@@ -0,0 +1,143 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.RFFSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Numeric.LinearAlgebra as LA
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.RFF as RFF
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.RFF (multivariate, Phase B-RFF)" $ do
+ it "logMarginalLikRBFMV: 既知 ℓ で最大化される (合成データで)" $ do
+ -- y = sin(x) (1D) で ℓ をスキャンし、データの z-score 後の長さスケールに
+ -- 近い値で marg-lik が最大になることを確認。
+ let xs = [0.0, 0.3 .. 6.0]
+ ys = map sin xs
+ xMat = LA.fromLists [[x] | x <- xs]
+ yV = LA.fromList ys
+ ells = [0.05, 0.2, 0.5, 1.0, 2.0, 5.0]
+ mliks = [ RFF.logMarginalLikRBFMV xMat yV ell 1.0 0.05 | ell <- ells ]
+ best = snd (maximum (zip mliks ells))
+ best `shouldSatisfy` (\b -> b >= 0.2 && b <= 2.0)
+ it "loocvRFFRidgeMV: λ → ∞ で残差ベース LOOCV が増える、適度な λ で最小" $ do
+ let xs = [0.0, 0.3 .. 6.0]
+ ys = map sin xs
+ xMat = LA.fromLists [[x] | x <- xs]
+ yV = LA.fromList ys
+ gen <- MWC.createSystemRandom
+ feats <- RFF.sampleRFFRBFMV 1 64 0.5 1.0 gen
+ let lamSmall = RFF.loocvRFFRidgeMV feats xMat yV 1e-2
+ lamHuge = RFF.loocvRFFRidgeMV feats xMat yV 1e6
+ lamSmall `shouldSatisfy` (< lamHuge)
+ it "gridSearchLOOCVRBFMV: ℓ/λ を自動探索して LOOCV が小さくなる" $ do
+ let xs = [0.0, 0.5 .. 10.0]
+ ys = [ sin (x/2) | x <- xs ]
+ xMat = LA.fromLists [[x] | x <- xs]
+ yV = LA.fromList ys
+ gen <- MWC.createSystemRandom
+ res <- RFF.gridSearchLOOCVRBFMV 1 100 xMat yV (Just (4, 8)) gen
+ RFF.lcLOOCV res `shouldSatisfy` (< 1.0)
+ RFF.lcEll res `shouldSatisfy` (> 0)
+ it "maximizeMarginalLikRBFMV: 雑音ありデータで mlik が改善する" $ do
+ let xs = [0.0, 0.5 .. 10.0]
+ ys = [ sin (x/2) + 0.05 * (fromIntegral i / 21) - 0.025
+ | (i, x) <- zip [0::Int ..] xs ]
+ xMat = LA.fromLists [[x] | x <- xs]
+ yV = LA.fromList ys
+ res = RFF.maximizeMarginalLikRBFMV xMat yV (Just (8, 4, 4))
+ -- 最適 mlik > 任意の "ヘンな" 値 (ℓ=100, σ_n=10) より高い
+ weak = RFF.logMarginalLikRBFMV xMat yV 100 1.0 10.0
+ RFF.mlLogMlik res `shouldSatisfy` (> weak)
+ RFF.mlEll res `shouldSatisfy` (> 0)
+ RFF.mlSigmaN res `shouldSatisfy` (> 0)
+
+ it "rffRidgeMV: y = x1 * t を完全にフィット" $ do
+ let xs = [(x1, t) | x1 <- [1, 2, 3, 5, 7], t <- [1..10]]
+ xss = [[x1, t] | (x1, t) <- xs]
+ ys = [x1 * t | (x1, t) <- xs]
+ xMat = LA.fromLists xss
+ gen <- MWC.createSystemRandom
+ feats <- RFF.sampleRFFRBFMV 2 256 1.0 1.0 gen
+ let fit = RFF.rffRidgeMV feats xMat ys 0.001
+ yhat = RFF.predictRFFRidgeMV fit xMat
+ rmse = sqrt (sum (zipWith (\a b -> (a-b)*(a-b)) ys yhat)
+ / fromIntegral (length ys))
+ rmse `shouldSatisfy` (< 1.0)
+
+ describe "Hanalyze.Model.RFF" $ do
+ it "feature matrix has correct shape" $ do
+ gen <- MWC.createSystemRandom
+ feats <- RFF.sampleRFFRBF 50 1.0 1.0 gen
+ RFF.rffDim feats `shouldBe` 50
+ let phi = RFF.rffFeatures feats [0.0, 1.0, 2.0]
+ -- phi is n × D = 3 × 50
+ V.length (V.fromList [0::Int]) `shouldBe` 1 -- placeholder for typing
+ -- We can't easily check matrix shape without hmatrix import here,
+ -- so just ensure the function doesn't crash.
+ length (RFF.rffOmegas feats) `shouldSatisfy` (== 50)
+ let _ = phi
+ return ()
+
+ it "RFF Ridge fits y ≈ x reasonably" $ do
+ gen <- MWC.createSystemRandom
+ feats <- RFF.sampleRFFRBF 100 1.0 1.0 gen
+ let xs = [0.0, 0.1 .. 1.0]
+ ys = map (\x -> 2 * x + 0.5) xs
+ fit = RFF.rffRidge feats xs ys 0.001
+ yhat = RFF.predictRFFRidge fit xs
+ rmse = sqrt (sum [ (y - yh) ^ (2 :: Int)
+ | (y, yh) <- zip ys yhat ]
+ / fromIntegral (length ys))
+ rmse `shouldSatisfy` (< 0.5)
+
+ -- ─────────────────────────────────────────────────────────────────────
+
+ describe "Hanalyze.Model.RFF DE-based auto-HP" $ do
+ it "maximizeMarginalLikRBFMV_DE: y = sin x + noise で妥当な ℓ" $ do
+ gen <- MWC.create
+ let n = 30
+ xs = [ fromIntegral i / 5 | i <- [0 .. n - 1] ] :: [Double]
+ ys = [ sin x + 0.05 * cos (3 * x) | x <- xs ]
+ xMat = LA.fromColumns [LA.fromList xs]
+ yVec = LA.fromList ys
+ r <- RFF.maximizeMarginalLikRBFMV_DE xMat yVec 30 gen
+ -- ℓ が極端に小さくない (>1e-2) ことだけ確認
+ RFF.mlEll r `shouldSatisfy` (> 1e-2)
+
+ it "gridSearchLOOCVRBFMV_DE: LOOCV が有限値、ℓ が探索範囲内" $ do
+ gen <- MWC.create
+ let n = 25
+ xs = [ fromIntegral i / 4 | i <- [0 .. n - 1] ] :: [Double]
+ ys = [ x + 0.1 * sin (2 * x) | x <- xs ]
+ xMat = LA.fromColumns [LA.fromList xs]
+ yVec = LA.fromList ys
+ r <- RFF.gridSearchLOOCVRBFMV_DE 1 50 xMat yVec 20 gen
+ RFF.lcLOOCV r `shouldSatisfy` (\v -> not (isNaN v) && v >= 0)
+ RFF.lcEll r `shouldSatisfy` (> 1e-3)
+
+ -- ===========================================================================
+ -- Hanalyze.Viz.ReportBuilder.secInterpolation (Phase G4)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Model/RandomForestClassifierSpec.hs b/test/Hanalyze/Model/RandomForestClassifierSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/RandomForestClassifierSpec.hs
@@ -0,0 +1,74 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.RandomForestClassifierSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.RandomForestClassifier as RFC
+import qualified Data.Vector.Unboxed as VU
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.RandomForestClassifier (Phase 13.5)" $ do
+ it "fitRFClassifier: 線形分離可能 2 クラスで OOB error 低い" $ do
+ gen <- MWC.createSystemRandom
+ let n = 60
+ half = n `div` 2
+ x = LA.fromColumns
+ [ LA.fromList
+ (replicate half 0 ++ replicate half 1)
+ , LA.fromList
+ (replicate half 0 ++ replicate half 1)
+ ]
+ y = VU.fromList (replicate half 0 ++ replicate half 1)
+ fit <- RFC.fitRFClassifier
+ (RFC.defaultRFCConfig { RFC.rfcNTrees = 30 })
+ x y gen
+ RFC.rfcOOBError fit `shouldSatisfy` (< 0.1)
+ RFC.rfcClasses fit `shouldBe` [0, 1]
+ it "predictRFClassifier: 訓練データで自己分類精度高い" $ do
+ gen <- MWC.createSystemRandom
+ let x = LA.fromColumns [LA.fromList [0,0,0,1,1,1,2,2,2]]
+ y = VU.fromList [0,0,0,1,1,1,2,2,2]
+ fit <- RFC.fitRFClassifier
+ (RFC.defaultRFCConfig { RFC.rfcNTrees = 20 })
+ x y gen
+ let pred_ = RFC.predictRFClassifier fit x
+ correct = length [ () | i <- [0 .. VU.length y - 1]
+ , pred_ V.! i == y VU.! i ]
+ correct `shouldSatisfy` (>= 8)
+ it "permutation importance: ノイズ列 < 真の列" $ do
+ gen <- MWC.createSystemRandom
+ let n = 80
+ half = n `div` 2
+ xCol1 = LA.fromList (replicate half 0 ++ replicate half 1)
+ xCol2 = LA.fromList [ sin (fromIntegral i) | i <- [0 .. n - 1] ]
+ x = LA.fromColumns [xCol1, xCol2]
+ y = VU.fromList (replicate half 0 ++ replicate half 1)
+ fit <- RFC.fitRFClassifier
+ (RFC.defaultRFCConfig { RFC.rfcNTrees = 30 })
+ x y gen
+ let imp = RFC.rfcImportance fit
+ LA.atIndex imp 0 `shouldSatisfy` (>= LA.atIndex imp 1)
diff --git a/test/Hanalyze/Model/RegularizedAdvanced/AdaptiveLassoSpec.hs b/test/Hanalyze/Model/RegularizedAdvanced/AdaptiveLassoSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/RegularizedAdvanced/AdaptiveLassoSpec.hs
@@ -0,0 +1,77 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.RegularizedAdvanced.AdaptiveLassoSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Storable as VS
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Regularized as Reg
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.RegularizedAdvanced as RegA
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.RegularizedAdvanced.AdaptiveLasso (Phase 31-A1)" $ do
+ -- Sparse 合成: β_true = [3, 1.5, 0, 0, 2, 0, 0, 0]、 n=200、 p=8
+ -- Y = X β + N(0, 0.1)
+ -- Adaptive Lasso (OLS pilot 重み + γ=1) は zero 係数を完全 0 に潰す傾向
+ -- が Lasso より強い。
+ it "fitAdaptiveLasso: zero 係数を Lasso 同等以上に潰せる + non-zero は回復" $ do
+ gen <- MWC.create
+ let nA = 200
+ pA = 8
+ betaTrue = [3.0, 1.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.0] :: [Double]
+ xVals <- VS.replicateM (nA * pA) (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ noisesA <- VS.replicateM nA (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.1 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let xMat = LA.reshape pA (LA.fromList (VS.toList xVals))
+ bt = LA.fromList betaTrue
+ yClean = xMat LA.#> bt
+ yVec = yClean + LA.fromList (VS.toList noisesA)
+ -- OLS pilot 重み (γ=1)
+ w = RegA.adaptiveWeightsFromOLS 1.0 xMat yVec
+ fit = RegA.fitAdaptiveLasso 0.1 w xMat yVec 1000 1e-5
+ beta = LA.toList (Reg.rfBeta fit)
+ -- True zero (index 2,3,5,6,7) はほぼ 0、 non-zero (0,1,4) は |β| > 0.5
+ length beta `shouldBe` pA
+ [beta !! i | i <- [0, 1, 4]] `shouldSatisfy` all (\b -> abs b > 0.5)
+ [beta !! i | i <- [2, 3, 5, 6, 7]] `shouldSatisfy` all (\b -> abs b < 0.3)
+ -- 推定 β が真値の 30% 以内 (non-zero に限る)
+ let nonZeroOK = and
+ [ abs (beta !! i - betaTrue !! i) < 0.3 * abs (betaTrue !! i)
+ | i <- [0, 1, 4] ]
+ nonZeroOK `shouldBe` True
+ it "adaptiveWeightsFromOLS: OLS 推定値が大きい列は重み小、 小は重み大" $ do
+ -- 2 column X、 β_true = [5, 0]、 noise 0 → OLS β̂ ≈ [5, 0]
+ -- → w ≈ [1/5, 1/1e-8] = [0.2, 1e8] (列 2 を強く罰)
+ let x = LA.fromLists [[1, 0], [1, 0], [0, 1], [0, 1]]
+ y = LA.fromList [5, 5, 0, 0]
+ w = RegA.adaptiveWeightsFromOLS 1.0 x y
+ ws = LA.toList w
+ ws !! 0 `shouldSatisfy` (\v -> v > 0.15 && v < 0.25) -- ≈ 1/5
+ ws !! 1 `shouldSatisfy` (> 1e6) -- floor 1e-8 経由
diff --git a/test/Hanalyze/Model/RegularizedAdvanced/GroupLassoSpec.hs b/test/Hanalyze/Model/RegularizedAdvanced/GroupLassoSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/RegularizedAdvanced/GroupLassoSpec.hs
@@ -0,0 +1,74 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.RegularizedAdvanced.GroupLassoSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Storable as VS
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Regularized as Reg
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.RegularizedAdvanced as RegA
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.RegularizedAdvanced.GroupLasso (Phase 31-A4)" $ do
+ -- 3 group: G1 = [0,1,2] (active)、 G2 = [3,4,5] (inactive)、 G3 = [6,7] (active)
+ -- β_true = [3, 1, 2, 0, 0, 0, 1.5, -1]
+ -- Y = X β + N(0, 0.1)
+ it "fitGroupLasso: 不活性 group の全係数を 0、 活性 group は回復" $ do
+ gen <- MWC.create
+ let nG = 300
+ pG = 8
+ betaTrue = [3.0, 1.0, 2.0, 0.0, 0.0, 0.0, 1.5, -1.0] :: [Double]
+ groups = [[0, 1, 2], [3, 4, 5], [6, 7]]
+ xVals <- VS.replicateM (nG * pG) (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ noisesG <- VS.replicateM nG (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.1 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let xMat = LA.reshape pG (LA.fromList (VS.toList xVals))
+ bt = LA.fromList betaTrue
+ yVec = xMat LA.#> bt + LA.fromList (VS.toList noisesG)
+ fit = RegA.fitGroupLasso 0.05 groups xMat yVec 1000 1e-5
+ beta = LA.toList (Reg.rfBeta fit)
+ length beta `shouldBe` pG
+ -- G2 (index 3,4,5) は全て 0 近く
+ [beta !! i | i <- [3, 4, 5]] `shouldSatisfy` all (\b -> abs b < 0.1)
+ -- G1 / G3 は活性
+ [beta !! i | i <- [0, 1, 2, 6, 7]] `shouldSatisfy` any (\b -> abs b > 0.5)
+ it "fitGroupLasso: 大 λ で全 group を 0" $ do
+ gen <- MWC.create
+ let nG = 100
+ pG = 4
+ groups = [[0, 1], [2, 3]]
+ xVals <- VS.replicateM (nG * pG) (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let xMat = LA.reshape pG (LA.fromList (VS.toList xVals))
+ yVec = LA.fromList [fromIntegral (i `mod` 3) | i <- [0 .. nG - 1]]
+ fit = RegA.fitGroupLasso 100.0 groups xMat yVec 1000 1e-5
+ LA.toList (Reg.rfBeta fit) `shouldSatisfy` all (\b -> abs b < 0.05)
diff --git a/test/Hanalyze/Model/RegularizedAdvanced/MCPSpec.hs b/test/Hanalyze/Model/RegularizedAdvanced/MCPSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/RegularizedAdvanced/MCPSpec.hs
@@ -0,0 +1,74 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.RegularizedAdvanced.MCPSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Storable as VS
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Regularized as Reg
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.RegularizedAdvanced as RegA
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.RegularizedAdvanced.MCP (Phase 31-A2)" $ do
+ -- 同 sparse DGP を共有: β_true = [3, 1.5, 0, 0, 2, 0, 0, 0]、 n=200、 p=8
+ -- 標準化済 X (各列 N(0,1)) なので γ ≥ 3 で凸性条件満たす
+ let mkSparseData :: MWC.GenIO -> IO (LA.Matrix Double, LA.Vector Double, [Double])
+ mkSparseData gen = do
+ let nMCP = 200
+ pMCP = 8
+ betaTrue = [3.0, 1.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.0] :: [Double]
+ xVals <- VS.replicateM (nMCP * pMCP) (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ noisesMCP <- VS.replicateM nMCP (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.1 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let xMat = LA.reshape pMCP (LA.fromList (VS.toList xVals))
+ bt = LA.fromList betaTrue
+ yVec = xMat LA.#> bt + LA.fromList (VS.toList noisesMCP)
+ pure (xMat, yVec, betaTrue)
+ it "fitMCP: γ=3、 中 λ で sparse 回復 + zero 係数を Lasso より強く潰す" $ do
+ gen <- MWC.create
+ (x, y, betaTrue) <- mkSparseData gen
+ let fit = RegA.fitMCP 0.1 3.0 x y 1000 1e-5
+ beta = LA.toList (Reg.rfBeta fit)
+ length beta `shouldBe` 8
+ [beta !! i | i <- [0, 1, 4]] `shouldSatisfy` all (\b -> abs b > 0.5)
+ [beta !! i | i <- [2, 3, 5, 6, 7]] `shouldSatisfy` all (\b -> abs b < 0.2)
+ -- non-zero は真値の 20% 以内 (MCP は Lasso より bias 小)
+ and [ abs (beta !! i - betaTrue !! i) < 0.2 * abs (betaTrue !! i)
+ | i <- [0, 1, 4] ] `shouldBe` True
+ it "fitMCP: 大 λ で全 β を 0、 小 λ で OLS 近似 (連続スペクトル)" $ do
+ gen <- MWC.create
+ (x, y, _) <- mkSparseData gen
+ let bigFit = RegA.fitMCP 100.0 3.0 x y 1000 1e-5
+ smallFit = RegA.fitMCP 1e-4 3.0 x y 1000 1e-5
+ -- 大 λ: 全係数 ≈ 0
+ LA.toList (Reg.rfBeta bigFit) `shouldSatisfy` all (\b -> abs b < 0.05)
+ -- 小 λ: 真の non-zero 係数を回復
+ let smallB = LA.toList (Reg.rfBeta smallFit)
+ [smallB !! i | i <- [0, 1, 4]] `shouldSatisfy` all (\b -> abs b > 1.0)
diff --git a/test/Hanalyze/Model/RegularizedAdvanced/SCADSpec.hs b/test/Hanalyze/Model/RegularizedAdvanced/SCADSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/RegularizedAdvanced/SCADSpec.hs
@@ -0,0 +1,69 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.RegularizedAdvanced.SCADSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Storable as VS
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Regularized as Reg
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.RegularizedAdvanced as RegA
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.RegularizedAdvanced.SCAD (Phase 31-A3)" $ do
+ let mkSparseSCAD :: MWC.GenIO -> IO (LA.Matrix Double, LA.Vector Double, [Double])
+ mkSparseSCAD gen = do
+ let nS = 200
+ pS = 8
+ betaTrue = [3.0, 1.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.0] :: [Double]
+ xVals <- VS.replicateM (nS * pS) (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ noisesS <- VS.replicateM nS (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.1 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let xMat = LA.reshape pS (LA.fromList (VS.toList xVals))
+ bt = LA.fromList betaTrue
+ yVec = xMat LA.#> bt + LA.fromList (VS.toList noisesS)
+ pure (xMat, yVec, betaTrue)
+ it "fitSCAD: a=3.7、 中 λ で sparse 回復 + non-zero 真値の 20% 以内" $ do
+ gen <- MWC.create
+ (x, y, betaTrue) <- mkSparseSCAD gen
+ let fit = RegA.fitSCAD 0.1 3.7 x y 1000 1e-5
+ beta = LA.toList (Reg.rfBeta fit)
+ length beta `shouldBe` 8
+ [beta !! i | i <- [0, 1, 4]] `shouldSatisfy` all (\b -> abs b > 0.5)
+ [beta !! i | i <- [2, 3, 5, 6, 7]] `shouldSatisfy` all (\b -> abs b < 0.2)
+ and [ abs (beta !! i - betaTrue !! i) < 0.2 * abs (betaTrue !! i)
+ | i <- [0, 1, 4] ] `shouldBe` True
+ it "fitSCAD: 3 領域 thresholding が連続 (λ → 0 で OLS、 λ 大で 0)" $ do
+ gen <- MWC.create
+ (x, y, _) <- mkSparseSCAD gen
+ let smallFit = RegA.fitSCAD 1e-4 3.7 x y 1000 1e-5
+ bigFit = RegA.fitSCAD 100.0 3.7 x y 1000 1e-5
+ LA.toList (Reg.rfBeta bigFit) `shouldSatisfy` all (\b -> abs b < 0.05)
+ let sb = LA.toList (Reg.rfBeta smallFit)
+ [sb !! i | i <- [0, 1, 4]] `shouldSatisfy` all (\b -> abs b > 1.0)
diff --git a/test/Hanalyze/Model/RegularizedSpec.hs b/test/Hanalyze/Model/RegularizedSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/RegularizedSpec.hs
@@ -0,0 +1,84 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.RegularizedSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Regularized as Reg
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Regularized.selectLambdaCV (Phase 4.4)" $ do
+ -- 合成データ: y = 2 x_1 + 1 x_2 + noise (x_3..x_5 は無関係)
+ let synthData :: IO (LA.Matrix Double, LA.Vector Double)
+ synthData = do
+ gen <- MWC.create
+ let n = 50; p = 5
+ xs <- LA.fromLists <$> sequence
+ [ sequence [ MWC.uniformR (-1, 1) gen | _ <- [1..p] ]
+ | _ <- [1..n] ]
+ let trueB = LA.fromList [2.0, 1.0, 0.0, 0.0, 0.0] :: LA.Vector Double
+ y0 = xs LA.#> trueB
+ noise <- LA.fromList <$> sequence
+ [ MWC.uniformR (-0.1, 0.1) gen | _ <- [1..n] ]
+ pure (xs, y0 + noise)
+
+ it "Ridge: 全 λ で CV MSE が finite、 best λ が grid 内" $ do
+ (xs, y) <- synthData
+ let lambdas = [0.001, 0.01, 0.1, 1.0, 10.0]
+ gen <- MWC.create
+ sel <- Reg.selectLambdaCV 5 Reg.KindRidge lambdas xs y gen
+ Reg.lsLambdas sel `shouldBe` lambdas
+ length (Reg.lsCVScores sel) `shouldBe` length lambdas
+ all (\v -> not (isNaN v) && not (isInfinite v) && v >= 0)
+ (Reg.lsCVScores sel) `shouldBe` True
+ Reg.lsBestLambda sel `shouldSatisfy` (`elem` lambdas)
+ Reg.lsOneSeLambda sel `shouldSatisfy` (>= Reg.lsBestLambda sel)
+ Reg.lsKind sel `shouldBe` Reg.KindRidge
+
+ it "Lasso: best λ は grid 内、 各 fold で MSE finite" $ do
+ (xs, y) <- synthData
+ let lambdas = [0.001, 0.01, 0.05, 0.1, 0.5]
+ gen <- MWC.create
+ sel <- Reg.selectLambdaCV 5 Reg.KindLasso lambdas xs y gen
+ Reg.lsBestLambda sel `shouldSatisfy` (`elem` lambdas)
+ length (Reg.lsCVScores sel) `shouldBe` length lambdas
+ all (\v -> not (isNaN v) && not (isInfinite v) && v >= 0)
+ (Reg.lsCVScores sel) `shouldBe` True
+
+ it "ElasticNet α=0.5: PenaltyKind が結果に反映される" $ do
+ (xs, y) <- synthData
+ let lambdas = [0.01, 0.1, 1.0]
+ gen <- MWC.create
+ sel <- Reg.selectLambdaCV 5 (Reg.KindElasticNet 0.5) lambdas xs y gen
+ Reg.lsKind sel `shouldBe` Reg.KindElasticNet 0.5
+ length (Reg.lsCVScores sel) `shouldBe` length lambdas
+
+ it "1-SE rule: lsOneSeLambda ≥ lsBestLambda" $ do
+ (xs, y) <- synthData
+ gen <- MWC.create
+ sel <- Reg.selectLambdaCV 5 Reg.KindRidge
+ [0.001, 0.01, 0.1, 1.0, 10.0, 100.0]
+ xs y gen
+ Reg.lsOneSeLambda sel `shouldSatisfy` (>= Reg.lsBestLambda sel)
diff --git a/test/Hanalyze/Model/ReliabilityBlockDiagramSpec.hs b/test/Hanalyze/Model/ReliabilityBlockDiagramSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/ReliabilityBlockDiagramSpec.hs
@@ -0,0 +1,61 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.ReliabilityBlockDiagramSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Model.ReliabilityBlockDiagram as RBD
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.ReliabilityBlockDiagram (Phase 35-A4)" $ do
+ it "Leaf: そのまま返す" $ do
+ RBD.reliabilityOf (RBD.Leaf 0.9) `shouldBe` 0.9
+ it "Series: 2 個直列 = 積" $ do
+ let r = RBD.reliabilityOf (RBD.Series [RBD.Leaf 0.9, RBD.Leaf 0.8])
+ abs (r - 0.72) `shouldSatisfy` (< 1e-12)
+ it "Parallel: 2 個並列 = 1 - (1-p₁)(1-p₂)" $ do
+ let r = RBD.reliabilityOf (RBD.Parallel [RBD.Leaf 0.9, RBD.Leaf 0.8])
+ abs (r - (1 - 0.1 * 0.2)) `shouldSatisfy` (< 1e-12)
+ it "KofN k=1 ≡ Parallel" $ do
+ let bs = [RBD.Leaf 0.7, RBD.Leaf 0.6, RBD.Leaf 0.5]
+ rK = RBD.reliabilityOf (RBD.KofN 1 bs)
+ rP = RBD.reliabilityOf (RBD.Parallel bs)
+ abs (rK - rP) `shouldSatisfy` (< 1e-12)
+ it "KofN k=n ≡ Series" $ do
+ let bs = [RBD.Leaf 0.7, RBD.Leaf 0.6, RBD.Leaf 0.5]
+ rK = RBD.reliabilityOf (RBD.KofN 3 bs)
+ rS = RBD.reliabilityOf (RBD.Series bs)
+ abs (rK - rS) `shouldSatisfy` (< 1e-12)
+ it "KofN 2-of-3 (同質 p=0.9): C(3,2)p²(1-p) + p³ = 0.972" $ do
+ let r = RBD.reliabilityOf
+ (RBD.KofN 2 [RBD.Leaf 0.9, RBD.Leaf 0.9, RBD.Leaf 0.9])
+ abs (r - 0.972) `shouldSatisfy` (< 1e-12)
+ it "ネスト: Parallel[Series[…], Series[…]]" $ do
+ let s1 = RBD.Series [RBD.Leaf 0.9, RBD.Leaf 0.95]
+ s2 = RBD.Series [RBD.Leaf 0.8, RBD.Leaf 0.85]
+ r = RBD.reliabilityOf (RBD.Parallel [s1, s2])
+ r1 = 0.9 * 0.95
+ r2 = 0.8 * 0.85
+ abs (r - (1 - (1 - r1) * (1 - r2))) `shouldSatisfy` (< 1e-12)
+ it "KofN k > n: 0、 k ≤ 0: 1" $ do
+ RBD.reliabilityOf (RBD.KofN 5 [RBD.Leaf 0.9, RBD.Leaf 0.9]) `shouldBe` 0
+ RBD.reliabilityOf (RBD.KofN 0 [RBD.Leaf 0.9, RBD.Leaf 0.9]) `shouldBe` 1
diff --git a/test/Hanalyze/Model/ReliabilitySpec.hs b/test/Hanalyze/Model/ReliabilitySpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/ReliabilitySpec.hs
@@ -0,0 +1,152 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.ReliabilitySpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Hanalyze.Model.Reliability as Rel
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Reliability.fitArrhenius (Phase 2.5)" $ do
+ it "sanity: 空入力は Left" $
+ case Rel.fitArrhenius [] of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for empty"
+
+ it "sanity: 1 温度のみは Left" $
+ case Rel.fitArrhenius [(300.0, [1000, 1100, 950])] of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for single temperature"
+
+ it "sanity: 非正の温度 / 寿命は Left" $ do
+ case Rel.fitArrhenius [(300.0, [1000]), (350.0, [-500])] of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for negative lifetime"
+ case Rel.fitArrhenius [(0.0, [1000]), (350.0, [500])] of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for T=0"
+
+ it "正確データでパラメータが復元される (真 A=1e-6 s, Ea=0.7 eV)" $ do
+ let trueA = 1e-6
+ trueEa = 0.7 -- eV
+ predict t = trueA * exp (trueEa / Rel.kBoltzmann / t)
+ temps = [298.15, 323.15, 348.15, 373.15, 398.15] -- K
+ input = [ (t, [predict t]) | t <- temps ]
+ case Rel.fitArrhenius input of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ -- 完全データなので E_a がぴったり一致
+ abs (Rel.afEa f - trueEa) `shouldSatisfy` (< 1e-9)
+ -- A は exp(b0) で recover; 数値誤差は < 0.1%
+ abs (Rel.afA f - trueA) / trueA `shouldSatisfy` (< 1e-6)
+ Rel.afN f `shouldBe` length temps
+
+ it "ノイズあり 5 温度 × 3 replicate で Ea が真値の ±15% に入る" $ do
+ let trueA = 1e-8
+ trueEa = 0.5 -- eV
+ predict t = trueA * exp (trueEa / Rel.kBoltzmann / t)
+ temps = [298.15, 323.15, 348.15, 373.15, 398.15]
+ -- 乗法ノイズ: ±10% を確定的に振る
+ noises = [0.95, 1.0, 1.05]
+ input = [ (t, [predict t * f | f <- noises]) | t <- temps ]
+ case Rel.fitArrhenius input of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ abs (Rel.afEa f - trueEa) / trueEa `shouldSatisfy` (< 0.15)
+ Rel.afN f `shouldBe` length temps * length noises
+
+ it "accelerationFactor: 試験温度の方が高ければ AF > 1" $ do
+ let trueA = 1e-6
+ trueEa = 0.7
+ predict t = trueA * exp (trueEa / Rel.kBoltzmann / t)
+ input = [ (t, [predict t]) | t <- [298.15, 348.15, 398.15] ]
+ case Rel.fitArrhenius input of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ -- 試験 125°C で使用 25°C
+ let af = Rel.accelerationFactor f 298.15 398.15
+ af `shouldSatisfy` (> 1)
+ -- 同じ温度なら AF = 1
+ abs (Rel.accelerationFactor f 350 350 - 1) `shouldSatisfy` (< 1e-12)
+
+ describe "Hanalyze.Model.Reliability.fitEyring (Phase 2.6)" $ do
+ it "sanity: 空入力は Left" $
+ case Rel.fitEyring [] of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+
+ it "sanity: 3 (T, S) ペア未満は Left" $
+ case Rel.fitEyring [(300.0, 1.0, [1000, 1100]), (350.0, 1.0, [500])] of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for < 3 distinct (T, S)"
+
+ it "正確データでパラメータ復元 (A=1e-6, Ea=0.7 eV, B=0.5)" $ do
+ let trueA = 1e-6
+ trueEa = 0.7
+ trueB = 0.5
+ predict t s = trueA / t * exp (trueEa / Rel.kBoltzmann / t) * exp (trueB * s)
+ tsPairs = [(t, s) | t <- [298.15, 348.15, 398.15], s <- [0.5, 1.0, 1.5]]
+ input = [ (t, s, [predict t s]) | (t, s) <- tsPairs ]
+ case Rel.fitEyring input of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ abs (Rel.efEa f - trueEa) `shouldSatisfy` (< 1e-9)
+ abs (Rel.efB f - trueB) `shouldSatisfy` (< 1e-9)
+ abs (Rel.efA f - trueA) / trueA `shouldSatisfy` (< 1e-6)
+ Rel.efN f `shouldBe` length tsPairs
+
+ describe "Hanalyze.Model.Reliability.fitInversePower (Phase 2.6)" $ do
+ it "sanity: 空入力 / 1 stress / 非正値は Left" $ do
+ case Rel.fitInversePower [] of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for empty"
+ case Rel.fitInversePower [(10.0, [1000, 1100])] of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for single stress"
+ case Rel.fitInversePower [(10.0, [1000]), (20.0, [-100])] of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for negative lifetime"
+
+ it "正確データでパラメータ復元 (A=1e6, n=2)" $ do
+ let trueA = 1e6
+ trueN = 2.0
+ predict s = trueA * s ** (- trueN)
+ stresses = [10, 20, 50, 100, 200]
+ input = [ (s, [predict s]) | s <- stresses ]
+ case Rel.fitInversePower input of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ abs (Rel.ipfN f - trueN) `shouldSatisfy` (< 1e-9)
+ abs (Rel.ipfA f - trueA) / trueA `shouldSatisfy` (< 1e-6)
+ Rel.ipfNobs f `shouldBe` length stresses
+
+ it "ノイズあり ±5% で n が真値の ±10% 内" $ do
+ let trueA = 1e6
+ trueN = 2.0
+ predict s = trueA * s ** (- trueN)
+ stresses = [10, 20, 50, 100, 200]
+ noises = [0.95, 1.0, 1.05]
+ input = [ (s, [predict s * f | f <- noises]) | s <- stresses ]
+ case Rel.fitInversePower input of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> abs (Rel.ipfN f - trueN) / trueN `shouldSatisfy` (< 0.10)
diff --git a/test/Hanalyze/Model/RobustSpec.hs b/test/Hanalyze/Model/RobustSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/RobustSpec.hs
@@ -0,0 +1,81 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.RobustSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Storable as VS
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.Robust as Rob
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Robust (Phase 31-A5 Huber/Tukey IRLS)" $ do
+ -- 合成データ: y = 2 + 1.5·x + ε、 ε ~ N(0, 0.5)
+ -- 5% を巨大 outlier に置換 (y += 30)。 OLS は biased、 Huber/Tukey が回復
+ let mkOutlierData :: MWC.GenIO -> IO (LA.Matrix Double, LA.Vector Double)
+ mkOutlierData gen = do
+ let nR = 200
+ xs <- VS.replicateM nR (MWC.uniformR (-3.0, 3.0 :: Double) gen)
+ noisesR <- VS.replicateM nR (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.5 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let yClean = VS.zipWith (\x e -> 2.0 + 1.5 * x + e) xs noisesR
+ -- 先頭 5% を outlier (y += 30)
+ nOut = nR `div` 20
+ yWithOut = VS.imap
+ (\i v -> if i < nOut then v + 30.0 else v) yClean
+ xMat = LA.fromColumns
+ [ LA.fromList (replicate nR 1.0)
+ , LA.fromList (VS.toList xs) ]
+ yVec = LA.fromList (VS.toList yWithOut)
+ pure (xMat, yVec)
+ it "Huber: 5% outlier 混入で intercept / slope を真値の 15% 以内回復" $ do
+ gen <- MWC.create
+ (x, y) <- mkOutlierData gen
+ let fit = Rob.fitRobustLM (Rob.Huber Rob.defaultHuberK) x y 50 1e-6
+ [b0, b1] = LA.toList (Rob.rfCoef fit)
+ abs (b0 - 2.0) `shouldSatisfy` (< 0.15 * 2.0)
+ abs (b1 - 1.5) `shouldSatisfy` (< 0.15 * 1.5)
+ Rob.rfConverged fit `shouldBe` True
+ it "Tukey biweight: 同 outlier で Huber 同等以上の精度 (5% 以内)" $ do
+ gen <- MWC.create
+ (x, y) <- mkOutlierData gen
+ let fit = Rob.fitRobustLM (Rob.Tukey Rob.defaultTukeyC) x y 50 1e-6
+ [b0, b1] = LA.toList (Rob.rfCoef fit)
+ abs (b0 - 2.0) `shouldSatisfy` (< 0.05 * 2.0)
+ abs (b1 - 1.5) `shouldSatisfy` (< 0.05 * 1.5)
+ -- outlier に重み 0 が付く (Tukey の特徴)
+ let ws = LA.toList (Rob.rfWeights fit)
+ nOut = length ws `div` 20
+ take nOut ws `shouldSatisfy` all (< 0.1)
+ it "huberWeight / tukeyWeight: 単体関数の境界挙動" $ do
+ -- |u| < k で w = 1
+ Rob.huberWeight 1.345 0.5 `shouldBe` 1.0
+ -- |u| > k で w = k/|u|
+ abs (Rob.huberWeight 1.345 3.0 - 1.345 / 3.0) `shouldSatisfy` (< 1e-12)
+ -- Tukey: u = 0 で w = 1、 |u| ≥ c で w = 0
+ Rob.tukeyWeight 4.685 0.0 `shouldBe` 1.0
+ Rob.tukeyWeight 4.685 5.0 `shouldBe` 0.0
+ Rob.tukeyWeight 4.685 (-5.0) `shouldBe` 0.0
diff --git a/test/Hanalyze/Model/SVMSpec.hs b/test/Hanalyze/Model/SVMSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/SVMSpec.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hanalyze.Model.SVMSpec (spec) where
+
+import Test.Hspec
+import qualified Data.Vector.Unboxed as VU
+import qualified Numeric.LinearAlgebra as LA
+import Hanalyze.Model.SVM
+import Hanalyze.Model.Kernel (Kernel (..), KernelParams (..), defaultKernelParams)
+
+-- 線形分離可能な 2 クラス (左下 vs 右上)。
+linData :: (LA.Matrix Double, VU.Vector Int)
+linData =
+ ( LA.fromLists [[0,0],[0,1],[1,0],[4,4],[4,5],[5,4]]
+ , VU.fromList [0,0,0,1,1,1] )
+
+-- 同心 (XOR 風)・線形非分離: 内側 1 クラス・外側 1 クラス。
+ringData :: (LA.Matrix Double, VU.Vector Int)
+ringData =
+ ( LA.fromLists [ [0,0],[0.3,0.2],[-0.2,0.1] -- 内側 (class 0)
+ , [3,0],[-3,0],[0,3],[0,-3],[2.1,2.1],[-2.1,-2.1] ] -- 外側 (class 1)
+ , VU.fromList [0,0,0, 1,1,1,1,1,1] )
+
+trainAcc :: SVM -> LA.Matrix Double -> VU.Vector Int -> Double
+trainAcc m x y =
+ let pred = predictSVM m x
+ n = VU.length y
+ ok = length [ () | i <- [0 .. n - 1], pred VU.! i == y VU.! i ]
+ in fromIntegral ok / fromIntegral n
+
+-- γ=1/(2ℓ²) ゆえ γ を ℓ に変換する (共有 Kernel は ℓ ベース・Phase 75.15)。
+rbfParams :: Double -> KernelParams
+rbfParams gamma = defaultKernelParams { kpLengthScale = sqrt (1 / (2 * gamma)) }
+
+spec :: Spec
+spec = describe "Hanalyze.Model.SVM (Phase 75.11/75.15)" $ do
+ let (xl, yl) = linData
+ (xr, yr) = ringData
+
+ it "Linear カーネル: 線形分離データを訓練精度 100%" $ do
+ let m = fitSVM defaultSVM { svmKernel = Linear } xl yl
+ trainAcc m xl yl `shouldBe` 1.0
+
+ it "RBF カーネル: 同心 (線形非分離) を訓練精度 100%" $ do
+ let m = fitSVM defaultSVM
+ { svmKernel = RBF, svmParams = rbfParams 0.5, svmC = 10 } xr yr
+ trainAcc m xr yr `shouldBe` 1.0
+
+ it "サポートベクタはスパース (α>0 の点 < 全点数)" $ do
+ let m = fitSVM defaultSVM
+ { svmKernel = RBF, svmParams = rbfParams 0.5 } xr yr
+ numSupportVectors m `shouldSatisfy` (< LA.rows xr)
+ numSupportVectors m `shouldSatisfy` (> 0)
+
+ it "決定的 (同入力で 2 回 fit して SV 数一致)" $ do
+ let cfg = defaultSVM { svmKernel = RBF, svmParams = rbfParams 0.5 }
+ m1 = fitSVM cfg xr yr
+ m2 = fitSVM cfg xr yr
+ numSupportVectors m1 `shouldBe` numSupportVectors m2
+
+ it "多クラス (one-vs-rest): 3 クラスを訓練上で正しく分類" $ do
+ let x3 = LA.fromLists [[0,0],[0.2,0.1],[5,0],[5,0.3],[0,5],[0.1,5]]
+ y3 = VU.fromList [0,0,1,1,2,2]
+ mm = fitSVMMulti defaultSVM
+ { svmKernel = RBF, svmParams = rbfParams 0.3, svmC = 10 } x3 y3
+ pr = predictSVMMulti mm x3
+ VU.toList pr `shouldBe` VU.toList y3
+
+ -- Phase 75.20: k-fold CV グリッド自動調律 (tuneSVM)。
+ describe "tuneSVM (CV グリッド自動最適化・決定的)" $ do
+ -- 同心 2 クラスを十分なサンプルで生成 (CV に必要な点数を確保)。
+ let ringBig =
+ ( LA.fromLists $ inner ++ outer
+ , VU.fromList (replicate (length inner) 0 ++ replicate (length outer) 1) )
+ inner = [ [0.3 * cos t, 0.3 * sin t] | t <- angles ]
+ outer = [ [3.0 * cos t, 3.0 * sin t] | t <- angles ]
+ angles = [ 2 * pi * fromIntegral i / 12 | i <- [0 .. 11 :: Int] ]
+ (xb, yb) = ringBig
+ grid = defaultSVMTuneGrid { svmtCs = [1, 10], svmtLengths = [0.5, 1, 2], svmtFolds = 3 }
+
+ it "決定的: 同入力で 2 回呼んで同じ config/score" $ do
+ let (c1, s1) = tuneSVM defaultSVM grid xb yb
+ (c2, s2) = tuneSVM defaultSVM grid xb yb
+ svmC c1 `shouldBe` svmC c2
+ kpLengthScale (svmParams c1) `shouldBe` kpLengthScale (svmParams c2)
+ s1 `shouldBe` s2
+
+ it "非線形 (同心) で CV accuracy が高い (> 0.8) 構成を選ぶ" $ do
+ let (_best, score) = tuneSVM defaultSVM grid xb yb
+ score `shouldSatisfy` (> 0.8)
+
+ it "選ばれた config で全データ再学習すると訓練精度 100%" $ do
+ let (best, _) = tuneSVM defaultSVM grid xb yb
+ m = fitSVMMulti best xb yb
+ pr = predictSVMMulti m xb
+ VU.toList pr `shouldBe` VU.toList yb
diff --git a/test/Hanalyze/Model/StateSpaceSpec.hs b/test/Hanalyze/Model/StateSpaceSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/StateSpaceSpec.hs
@@ -0,0 +1,78 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.StateSpaceSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.StateSpace as SS
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.StateSpace (Phase 15)" $ do
+ let -- 1次元 random walk: x_t = x_{t-1} + w, y_t = x_t + v
+ rwModel = SS.StateSpaceModel
+ { SS.ssF = LA.fromLists [[1]]
+ , SS.ssH = LA.fromLists [[1]]
+ , SS.ssQ = LA.fromLists [[0.1]]
+ , SS.ssR = LA.fromLists [[1.0]]
+ , SS.ssX0 = LA.fromList [0]
+ , SS.ssP0 = LA.fromLists [[1.0]]
+ }
+ -- 真の状態 0, 0.1, 0.3, 0.5, ... + ノイズ込み観測
+ obs = LA.fromLists [[0.1, 0.2, 0.4, 0.6, 0.7, 0.9, 1.1]]
+ it "kalmanFilter: T 時点で filtered list 長 = T" $ do
+ let kr = SS.kalmanFilter rwModel obs
+ length (SS.krFilteredMean kr) `shouldBe` 7
+ length (SS.krFilteredCov kr) `shouldBe` 7
+ it "kalmanFilter: 共分散が正定値 (対角 > 0)" $ do
+ let kr = SS.kalmanFilter rwModel obs
+ all (\p -> LA.atIndex p (0, 0) > 0) (SS.krFilteredCov kr) `shouldBe` True
+ it "kalmanFilter: 観測列が長くなるほど 共分散は減少 (情報蓄積)" $ do
+ let kr = SS.kalmanFilter rwModel obs
+ covs = SS.krFilteredCov kr
+ c0 = LA.atIndex (head covs) (0, 0)
+ cT = LA.atIndex (last covs) (0, 0)
+ cT `shouldSatisfy` (< c0)
+ it "kalmanFilter: 観測トレンドに状態が追随" $ do
+ let kr = SS.kalmanFilter rwModel obs
+ last_x = LA.atIndex (last (SS.krFilteredMean kr)) 0
+ last_x `shouldSatisfy` (> 0.3) -- 観測が 1 近辺に上がっている
+ it "kalmanFilter: 対数尤度が有限" $ do
+ let kr = SS.kalmanFilter rwModel obs
+ SS.krLogLik kr `shouldSatisfy` (\v -> not (isNaN v) && not (isInfinite v))
+ it "kalmanSmoother: smoothed list 長 = T" $ do
+ let kr = SS.kalmanSmoother rwModel (SS.kalmanFilter rwModel obs)
+ length (SS.krSmoothedMean kr) `shouldBe` 7
+ length (SS.krSmoothedCov kr) `shouldBe` 7
+ it "kalmanSmoother: 末尾は filtered と一致" $ do
+ let kr = SS.kalmanFilter rwModel obs
+ ks = SS.kalmanSmoother rwModel kr
+ abs (LA.atIndex (last (SS.krSmoothedMean ks)) 0
+ - LA.atIndex (last (SS.krFilteredMean ks)) 0)
+ `shouldSatisfy` (< 1e-9)
+ it "kalmanSmoother: 中間点 smoothed 共分散 ≤ filtered" $ do
+ let kr = SS.kalmanFilter rwModel obs
+ ks = SS.kalmanSmoother rwModel kr
+ mid = 3
+ covF = LA.atIndex (SS.krFilteredCov ks !! mid) (0, 0)
+ covS = LA.atIndex (SS.krSmoothedCov ks !! mid) (0, 0)
+ covS `shouldSatisfy` (<= covF + 1e-9)
diff --git a/test/Hanalyze/Model/SurvivalSpec.hs b/test/Hanalyze/Model/SurvivalSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/SurvivalSpec.hs
@@ -0,0 +1,88 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.SurvivalSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.Survival as Surv
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Survival" $ do
+ it "kaplanMeier: 全 event observed で S(t) は単調減少" $ do
+ let samples = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
+ km = Surv.kaplanMeier samples
+ length (Surv.kmrTimes km) `shouldBe` 5
+ let ss = Surv.kmrSurvival km
+ and (zipWith (>=) ss (tail ss)) `shouldBe` True
+
+ it "kaplanMeier: S(t) は前向き累積積の実値と一致 (逆順バグの回帰)" $ do
+ -- n=5・各時刻 1 event: S = [4/5, 3/4, 2/3, 1/2, 0] の累積。
+ -- 旧実装は右から積んで最終 factor 0 が全時点を 0 に潰していた。
+ let samples = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
+ ss = Surv.kmrSurvival (Surv.kaplanMeier samples)
+ expected = [0.8, 0.6, 0.4, 0.2, 0.0]
+ and (zipWith (\a b -> abs (a - b) < 1e-9) ss expected) `shouldBe` True
+
+ it "kaplanMeier: censored data でも非負の生存確率" $ do
+ let samples = [ Surv.SurvSample 1 Surv.Observed
+ , Surv.SurvSample 2 Surv.Censored
+ , Surv.SurvSample 3 Surv.Observed
+ , Surv.SurvSample 4 Surv.Observed
+ , Surv.SurvSample 5 Surv.Censored
+ ]
+ km = Surv.kaplanMeier samples
+ all (>= 0) (Surv.kmrSurvival km) `shouldBe` True
+ all (<= 1) (Surv.kmrSurvival km) `shouldBe` True
+
+ it "nelsonAalen: 累積ハザードは monotone non-decreasing" $ do
+ let samples = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
+ na = Surv.nelsonAalen samples
+ h = Surv.narCumHazard na
+ and (zipWith (<=) h (tail h)) `shouldBe` True
+
+ it "logRankTest: 同一分布で p > 0.05" $ do
+ let g1 = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
+ g2 = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
+ lr = Surv.logRankTest [g1, g2]
+ Surv.lrPValue lr `shouldSatisfy` (> 0.05)
+
+ it "logRankTest: 異なる分布で p < 0.05" $ do
+ let g1 = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
+ g2 = [ Surv.SurvSample t Surv.Observed | t <- [10, 11, 12, 13, 14] ]
+ lr = Surv.logRankTest [g1, g2]
+ Surv.lrPValue lr `shouldSatisfy` (< 0.05)
+
+ it "coxPH: 共変量と event 時間に強い相関で β > 0" $ do
+ -- x が大きい個体が早く event を起こす想定の合成データ
+ let n = 30
+ xs = [ LA.fromList [fromIntegral i / fromIntegral n :: Double]
+ | i <- [1 .. n] ]
+ times = [ 30 - i | i <- [1 .. n] ] -- x 大きいほど early
+ samples = [ Surv.SurvSample (fromIntegral t) Surv.Observed
+ | t <- times ]
+ fit = Surv.coxPH xs samples
+ LA.atIndex (Surv.coxBeta fit) 0 `shouldSatisfy` (> 0)
+
+ -- ===========================================================================
+ -- Hanalyze.Stat.Interpret (Phase 13)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Model/TimeSeriesSpec.hs b/test/Hanalyze/Model/TimeSeriesSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/TimeSeriesSpec.hs
@@ -0,0 +1,95 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.TimeSeriesSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.TimeSeries as TS
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.TimeSeries" $ do
+ it "autocorrelation: lag 0 = 1.0" $ do
+ let y = LA.fromList [1.0, 2.0, 1.5, 2.5, 1.8]
+ acf = TS.autocorrelation 5 y
+ LA.atIndex acf 0 `shouldBe` 1.0
+
+ it "autocorrelation: 周期 4 の sin 系列で lag 4 が高い" $ do
+ let y = LA.fromList [sin (2*pi*fromIntegral t / 4) | t <- [0..40::Int]]
+ acf = TS.autocorrelation 8 y
+ LA.atIndex acf 4 `shouldSatisfy` (> 0.5)
+
+ it "fitAR(1) on quasi-AR(1) data: φ̂ in (0, 1)" $ do
+ -- Quasi-AR(1) with φ=0.7 + small deterministic perturbation
+ let phi = 0.7
+ go _ 0 = []
+ go prev n =
+ let yi = phi * prev + 0.01 * sin (fromIntegral n :: Double)
+ in yi : go yi (n - 1)
+ ys = take 100 (drop 50 (go 1.0 200)) -- burn-in 50
+ y = LA.fromList ys
+ fit = TS.fitAR 1 y
+ let phiHat = LA.atIndex (TS.arPhi fit) 0
+ -- AR(1) coefficient should be in (0, 1) for stationary positive AR
+ phiHat `shouldSatisfy` (\p -> p > 0 && p < 1)
+
+ it "forecastAR: h-step forecast 同 size" $ do
+ let y = LA.fromList [1.0, 1.5, 2.0, 2.5, 3.0, 2.5, 2.0, 1.5, 1.0, 1.5,
+ 2.0, 2.5, 3.0, 2.5, 2.0]
+ fit = TS.fitAR 2 y
+ fc = TS.forecastAR fit y 5
+ LA.size fc `shouldBe` 5
+
+ it "differencing: y' length = n - 1" $ do
+ let y = LA.fromList [1.0, 3.0, 2.0, 5.0, 4.0]
+ d1 = TS.differencing y
+ LA.size d1 `shouldBe` 4
+ LA.toList d1 `shouldBe` [2.0, -1.0, 3.0, -1.0]
+
+ it "simpleExpSmoothing: α=1 で原系列、α=0 で初期値固定" $ do
+ let y = LA.fromList [1.0, 2.0, 3.0, 4.0, 5.0]
+ s1 = TS.simpleExpSmoothing 1.0 y -- α=1
+ s0 = TS.simpleExpSmoothing 0.0 y -- α=0
+ LA.toList s1 `shouldBe` LA.toList y -- exact
+ all (== 1.0) (LA.toList s0) `shouldBe` True
+
+ it "holtWinters: 線形 trend + 周期 4 を再現" $ do
+ let -- y_t = t + 5 sin(2πt/4)
+ ys = [ fromIntegral t + 3 * sin (2 * pi * fromIntegral t / 4)
+ | t <- [0 .. 39 :: Int] ]
+ y = LA.fromList ys
+ fit = TS.holtWinters TS.HWAdditive 4 y
+ fc = TS.hwForecast fit 4
+ LA.size fc `shouldBe` 4
+ -- Forecast at t=40,41,42,43 should be roughly 40 + sin pattern
+ LA.atIndex fc 0 `shouldSatisfy` (> 35)
+
+ it "stlDecompose: 周期成分が period 倍で繰り返す" $ do
+ let ys = [ fromIntegral t / 10 + 2 * sin (2 * pi * fromIntegral t / 4)
+ | t <- [0 .. 39 :: Int] ]
+ y = LA.fromList ys
+ (_trend, seasonal, _resid) = TS.stlDecompose 4 y
+ LA.size seasonal `shouldBe` LA.size y
+
+ -- ===========================================================================
+ -- Hanalyze.Model.Survival (Phase 12)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Model/VARSpec.hs b/test/Hanalyze/Model/VARSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/VARSpec.hs
@@ -0,0 +1,86 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.VARSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.VAR as VAR
+import qualified System.Random.MWC.Distributions as MWCD
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.VAR (Phase 35-A2)" $ do
+ -- 既知の VAR(1) からシミュレーション。 真の A₁ = [[0.5, 0.1], [0.2, 0.4]]
+ let simulateVAR1 gen a11 a12 a21 a22 c1 c2 n = do
+ let loop !i !y1Prev !y2Prev acc
+ | i >= n = pure (reverse acc)
+ | otherwise = do
+ z1 <- MWCD.standard gen
+ z2 <- MWCD.standard gen
+ let !y1 = c1 + a11 * y1Prev + a12 * y2Prev + 0.1 * z1
+ !y2 = c2 + a21 * y1Prev + a22 * y2Prev + 0.1 * z2
+ loop (i + 1) y1 y2 ([y1, y2] : acc)
+ rows <- loop 0 0 0 []
+ pure (LA.fromLists rows)
+ it "fitVAR: 真の係数 (A₁) を概ね回復" $ do
+ gen <- MWC.create
+ yMat <- simulateVAR1 gen (0.5 :: Double) 0.1 0.2 0.4 0.05 (-0.03) 500
+ let fit = VAR.fitVAR 1 yMat
+ a1 = head (VAR.varCoefs fit)
+ -- 各要素 ±0.05 以内
+ abs (LA.atIndex a1 (0, 0) - 0.5) `shouldSatisfy` (< 0.1)
+ abs (LA.atIndex a1 (0, 1) - 0.1) `shouldSatisfy` (< 0.1)
+ abs (LA.atIndex a1 (1, 0) - 0.2) `shouldSatisfy` (< 0.1)
+ abs (LA.atIndex a1 (1, 1) - 0.4) `shouldSatisfy` (< 0.1)
+ it "fitVAR: varP / varK / 係数行列の数とサイズ" $ do
+ gen <- MWC.create
+ yMat <- simulateVAR1 gen (0.5 :: Double) 0.1 0.2 0.4 0 0 300
+ let fit = VAR.fitVAR 2 yMat
+ VAR.varP fit `shouldBe` 2
+ VAR.varK fit `shouldBe` 2
+ length (VAR.varCoefs fit) `shouldBe` 2
+ LA.size (VAR.varConst fit) `shouldBe` 2
+ mapM_ (\m -> LA.size m `shouldBe` (2, 2)) (VAR.varCoefs fit)
+ it "fitVAR: 残差行列 = (n - p) × K" $ do
+ gen <- MWC.create
+ yMat <- simulateVAR1 gen (0.5 :: Double) 0.1 0.2 0.4 0 0 200
+ let fit = VAR.fitVAR 3 yMat
+ LA.size (VAR.varResiduals fit) `shouldBe` (200 - 3, 2)
+ it "forecastVAR: 長さ × 次元" $ do
+ gen <- MWC.create
+ yMat <- simulateVAR1 gen (0.5 :: Double) 0.1 0.2 0.4 0 0 200
+ let fit = VAR.fitVAR 2 yMat
+ fc = VAR.forecastVAR fit yMat 5
+ LA.size fc `shouldBe` (5, 2)
+ it "forecastVAR: 定常 VAR(1) で長期予測が平均 (≈ (I - A)⁻¹·c) に収束" $ do
+ gen <- MWC.create
+ yMat <- simulateVAR1 gen (0.5 :: Double) 0.1 0.2 0.4 0.05 (-0.03) 1000
+ let fit = VAR.fitVAR 1 yMat
+ fc = VAR.forecastVAR fit yMat 100
+ a1 = head (VAR.varCoefs fit)
+ iK = LA.ident 2
+ mu = (iK - a1) LA.<\> VAR.varConst fit
+ fLast = LA.flatten (fc LA.? [99])
+ abs (LA.atIndex fLast 0 - LA.atIndex mu 0) `shouldSatisfy` (< 0.05)
+ abs (LA.atIndex fLast 1 - LA.atIndex mu 1) `shouldSatisfy` (< 0.05)
diff --git a/test/Hanalyze/Model/WeibullSpec.hs b/test/Hanalyze/Model/WeibullSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Model/WeibullSpec.hs
@@ -0,0 +1,191 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Model.WeibullSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Hanalyze.Model.Weibull as Wei
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Model.Weibull.fitWeibullMLE (Phase 2.2)" $ do
+ let -- generate Weibull(k, λ) samples deterministically via inverse CDF
+ -- x_i = λ · (−log(1 − u_i))^(1/k), u_i uniform on (0, 1)
+ invCDFWeibull k lam u = lam * (- log (1 - u)) ** (1 / k)
+ uniforms n = [ (fromIntegral i - 0.5) / fromIntegral n | i <- [1..n] ]
+
+ it "sanity: 入力が空または非正なら Left" $ do
+ case Wei.fitWeibullMLE V.empty of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for empty"
+ case Wei.fitWeibullMLE (V.fromList [1.0, -2.0, 3.0]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for negative input"
+ case Wei.fitWeibullMLE (V.fromList [1.0]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for n=1"
+ case Wei.fitWeibullMLE (V.fromList [2.0, 2.0, 2.0]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for constant data"
+
+ it "k=2, λ=10 の合成データから MLE が真値の ±10% に入る" $ do
+ let trueK = 2.0
+ trueL = 10.0
+ xs = V.fromList [ invCDFWeibull trueK trueL u | u <- uniforms 200 ]
+ case Wei.fitWeibullMLE xs of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ Wei.wfShape f `shouldSatisfy` (\k -> abs (k - trueK) / trueK < 0.10)
+ Wei.wfScale f `shouldSatisfy` (\l -> abs (l - trueL) / trueL < 0.10)
+ Wei.wfRObs f `shouldBe` V.length xs
+ Wei.wfN f `shouldBe` V.length xs
+
+ it "k=1 (指数分布相当)、 λ=5 の合成データでも収束" $ do
+ let trueK = 1.0
+ trueL = 5.0
+ xs = V.fromList [ invCDFWeibull trueK trueL u | u <- uniforms 300 ]
+ case Wei.fitWeibullMLE xs of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ Wei.wfShape f `shouldSatisfy` (\k -> abs (k - trueK) / trueK < 0.10)
+ Wei.wfScale f `shouldSatisfy` (\l -> abs (l - trueL) / trueL < 0.10)
+
+ it "bxLife: 真値 (k=2, λ=10) で B_10 ≈ λ · (−ln 0.9)^(1/k)" $ do
+ let trueK = 2.0
+ trueL = 10.0
+ xs = V.fromList [ invCDFWeibull trueK trueL u | u <- uniforms 200 ]
+ expectedB10 = trueL * (- log 0.9) ** (1 / trueK)
+ case Wei.fitWeibullMLE xs of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> Wei.bxLife 0.10 f
+ `shouldSatisfy` (\b -> abs (b - expectedB10) / expectedB10 < 0.15)
+
+ it "weibullParameterSE: 両 SE > 0 で finite" $ do
+ let trueK = 2.0
+ trueL = 10.0
+ xs = V.fromList [ invCDFWeibull trueK trueL u | u <- uniforms 200 ]
+ case Wei.fitWeibullMLE xs of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ let (seK, seL) = Wei.weibullParameterSE f
+ seK `shouldSatisfy` (\v -> v > 0 && not (isNaN v) && not (isInfinite v))
+ seL `shouldSatisfy` (\v -> v > 0 && not (isNaN v) && not (isInfinite v))
+
+ describe "Hanalyze.Model.Weibull.fitWeibullCensored (Phase 2.3)" $ do
+ let invCDFWeibull k lam u = lam * (- log (1 - u)) ** (1 / k)
+ uniforms n = [ (fromIntegral i - 0.5) / fromIntegral n | i <- [1..n] ]
+
+ it "sanity: 時間と delta の長さ mismatch は Left" $
+ case Wei.fitWeibullCensored
+ (V.fromList [1.0, 2.0, 3.0])
+ (V.fromList [True, False]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for length mismatch"
+
+ it "sanity: failure 数が 2 未満は Left" $
+ case Wei.fitWeibullCensored
+ (V.fromList [1.0, 2.0, 3.0])
+ (V.fromList [True, False, False]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for r < 2"
+
+ it "全 failure (打ち切り無し) は fitWeibullMLE と同一結果" $ do
+ let trueK = 2.0
+ trueL = 10.0
+ xs = V.fromList [ invCDFWeibull trueK trueL u | u <- uniforms 100 ]
+ ds = V.replicate (V.length xs) True
+ case (Wei.fitWeibullMLE xs, Wei.fitWeibullCensored xs ds) of
+ (Right f1, Right f2) -> do
+ abs (Wei.wfShape f1 - Wei.wfShape f2) `shouldSatisfy` (< 1e-8)
+ abs (Wei.wfScale f1 - Wei.wfScale f2) `shouldSatisfy` (< 1e-8)
+ _ -> expectationFailure "both fits should succeed"
+
+ it "Type-II 打ち切り (大きい時間を打ち切り) で λ̂ が真値に近い" $ do
+ let trueK = 2.0
+ trueL = 10.0
+ -- 200 サンプル中、 上位 30% を打ち切りに
+ allXs = [ invCDFWeibull trueK trueL u | u <- uniforms 200 ]
+ sortedXs = V.fromList (sort allXs)
+ cutoff = V.length sortedXs * 70 `div` 100
+ deltas = V.generate (V.length sortedXs) (\i -> i < cutoff)
+ -- 打ち切られた点は打ち切り時刻 = cutoff 時刻
+ censorTime = sortedXs V.! (cutoff - 1)
+ xs = V.imap (\i x -> if i < cutoff then x else censorTime) sortedXs
+ case Wei.fitWeibullCensored xs deltas of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ Wei.wfRObs f `shouldBe` cutoff
+ Wei.wfN f `shouldBe` V.length xs
+ -- 打ち切り 30% の loss は MLE バイアス小、 ±20% 内に収まる
+ Wei.wfShape f `shouldSatisfy` (\k -> abs (k - trueK) / trueK < 0.20)
+ Wei.wfScale f `shouldSatisfy` (\l -> abs (l - trueL) / trueL < 0.20)
+
+ it "打ち切り混在: failure < n だが r ≥ 2 で fit 成立" $ do
+ -- 故障時間 [1, 2, 3, 4]、 打ち切り時間 [5, 5] (右打ち切り)
+ let xs = V.fromList [1.0, 2.0, 3.0, 4.0, 5.0, 5.0]
+ deltas = V.fromList [True, True, True, True, False, False]
+ case Wei.fitWeibullCensored xs deltas of
+ Left e -> expectationFailure (T.unpack e)
+ Right f -> do
+ Wei.wfRObs f `shouldBe` 4
+ Wei.wfN f `shouldBe` 6
+ Wei.wfShape f `shouldSatisfy` (> 0)
+ Wei.wfScale f `shouldSatisfy` (> 0)
+
+ describe "Hanalyze.Model.Weibull.bxLifeCI + covariance (Phase 2.4)" $ do
+ let invCDFWeibull k lam u = lam * (- log (1 - u)) ** (1 / k)
+ uniforms n = [ (fromIntegral i - 0.5) / fromIntegral n | i <- [1..n] ]
+ synthFit = case Wei.fitWeibullMLE
+ (V.fromList [ invCDFWeibull 2.0 10.0 u | u <- uniforms 200 ]) of
+ Right f -> f
+ Left e -> error (T.unpack e)
+
+ it "weibullParameterCovariance: var > 0、 cov is finite" $ do
+ let (vK, cKL, vL) = Wei.weibullParameterCovariance synthFit
+ vK `shouldSatisfy` (> 0)
+ vL `shouldSatisfy` (> 0)
+ cKL `shouldSatisfy` (\v -> not (isNaN v) && not (isInfinite v))
+
+ it "weibullParameterSE と Covariance の対角 sqrt が一致" $ do
+ let (vK, _, vL) = Wei.weibullParameterCovariance synthFit
+ (sK, sL) = Wei.weibullParameterSE synthFit
+ abs (sK - sqrt vK) `shouldSatisfy` (< 1e-12)
+ abs (sL - sqrt vL) `shouldSatisfy` (< 1e-12)
+
+ it "bxLifeCI: estimate は bxLife と一致、 lower ≤ estimate ≤ upper" $ do
+ let (est, lo, hi) = Wei.bxLifeCI 0.10 0.05 synthFit
+ bp = Wei.bxLife 0.10 synthFit
+ abs (est - bp) `shouldSatisfy` (< 1e-12)
+ lo `shouldSatisfy` (<= est)
+ est `shouldSatisfy` (<= hi)
+ lo `shouldSatisfy` (>= 0) -- lifetimes are non-negative
+
+ it "bxLifeCI: 95% CI が 99% CI より狭い" $ do
+ let (_, lo95, hi95) = Wei.bxLifeCI 0.10 0.05 synthFit
+ (_, lo99, hi99) = Wei.bxLifeCI 0.10 0.01 synthFit
+ (hi95 - lo95) `shouldSatisfy` (< hi99 - lo99)
+
+ it "bxLifeCI: 真値 B_10 が 95% CI に入る (200 サンプル)" $ do
+ let trueB10 = 10.0 * (- log 0.9) ** (1 / 2.0)
+ (_, lo, hi) = Wei.bxLifeCI 0.10 0.05 synthFit
+ trueB10 `shouldSatisfy` (\b -> b >= lo && b <= hi)
diff --git a/test/Hanalyze/Optim/BayesOptSpec.hs b/test/Hanalyze/Optim/BayesOptSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/BayesOptSpec.hs
@@ -0,0 +1,46 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.BayesOptSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Optim.BayesOpt as BO
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.BayesOpt (acquisition optimizer swap)" $ do
+ it "bayesOpt 1D: Brent 内側で簡単な凸関数 (x-1.5)^2 を見つける" $ do
+ gen <- MWC.create
+ let cfg = BO.defaultBayesOptConfig
+ { BO.boIterations = 8
+ , BO.boInitPoints = 4
+ , BO.boGridSize = 32
+ }
+ target x = pure ((x - 1.5)^(2::Int) :: Double)
+ (_, (xb, _)) <- BO.bayesOpt cfg target (0, 3) gen
+ -- 8 反復では精度は緩めに。3.0 範囲のうち 0.5 以内に収束を期待
+ abs (xb - 1.5) `shouldSatisfy` (< 0.5)
+
+ -- ===========================================================================
+ -- RFF HP 自動チューニングの DE 版 (Phase O9)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Optim/CMAESSpec.hs b/test/Hanalyze/Optim/CMAESSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/CMAESSpec.hs
@@ -0,0 +1,66 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.CMAESSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Optim.CMAES as CMAES
+import qualified Hanalyze.Optim.CMAESFull as CMAESF
+import qualified Hanalyze.Optim.Common as OC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.CMAES" $ do
+ let sphere xs = sum [x*x | x <- xs]
+ l2 a b = sqrt (sum (zipWith (\x y -> (x-y)^(2::Int)) a b))
+
+ it "CMA-ES: sphere 5D を最小化、原点近傍に到達" $ do
+ gen <- MWC.create
+ let cfg = CMAES.defaultCMAESConfig
+ { CMAES.cmStop = OC.defaultStopCriteria { OC.stMaxIter = 200 }
+ , CMAES.cmSigma0 = 1.0 }
+ r <- CMAES.runCMAESWith cfg sphere [3, -2, 1, 0.5, -1.5] gen
+ l2 (OC.orBest r) [0,0,0,0,0] `shouldSatisfy` (< 0.5)
+
+ it "CMA-ES Full: sphere 5D で 1e-3 以内に到達" $ do
+ gen <- MWC.create
+ let cfg = CMAESF.defaultCMAESFConfig
+ { CMAESF.cmfStop = OC.defaultStopCriteria { OC.stMaxIter = 300 }
+ , CMAESF.cmfSigma0 = 1.0 }
+ r <- CMAESF.runCMAESFullWith cfg sphere [3, -2, 1, 0.5, -1.5] gen
+ OC.orValue r `shouldSatisfy` (< 1e-3)
+
+ it "CMA-ES Full: Rosenbrock 2D で (1,1) に 0.1 以内" $ do
+ gen <- MWC.create
+ let cfg = CMAESF.defaultCMAESFConfig
+ { CMAESF.cmfStop = OC.defaultStopCriteria { OC.stMaxIter = 500 }
+ , CMAESF.cmfSigma0 = 0.5
+ , CMAESF.cmfLambda = Just 20 }
+ rosen [x, y] = (1-x)^(2::Int) + 100 * (y - x*x)^(2::Int)
+ rosen _ = error "2D"
+ r <- CMAESF.runCMAESFullWith cfg rosen [-1.2, 1.0] gen
+ l2 (OC.orBest r) [1, 1] `shouldSatisfy` (< 0.1)
+
+ -- ===========================================================================
+ -- メタヒューリスティック (Tier 2: Simulated Annealing, PSO)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Optim/CommonSpec.hs b/test/Hanalyze/Optim/CommonSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/CommonSpec.hs
@@ -0,0 +1,82 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.CommonSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Optim.NelderMead as NM
+import qualified Hanalyze.Optim.LBFGS as LBFGS
+import qualified Hanalyze.Optim.CMAES as CMAES
+import qualified Hanalyze.Optim.CMAESFull as CMAESF
+import qualified Hanalyze.Optim.Common as OC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.Common box constraints" $ do
+ it "clipToBounds: 範囲外を反射、範囲内はそのまま" $ do
+ OC.clipToBounds [(0,10)] [5] `shouldBe` [5]
+ OC.clipToBounds [(0,10)] [-2] `shouldBe` [2] -- 反射
+ OC.clipToBounds [(0,10)] [12] `shouldBe` [8]
+
+ it "boundsPenalty: 範囲内 0、範囲外で大きい正値" $ do
+ OC.boundsPenalty (Just [(0,10)]) [5] `shouldBe` 0
+ OC.boundsPenalty Nothing [-99] `shouldBe` 0
+ OC.boundsPenalty (Just [(0,10)]) [-1] `shouldSatisfy` (> 1e5)
+
+ it "NelderMead: nmBounds で box 内に解が収まる" $ do
+ let f xs = (head xs - 5)^(2::Int) -- 真の最小は x=5
+ cfg = NM.defaultNMConfig { NM.nmBounds = Just [(0, 2)] }
+ r <- NM.runNelderMeadWith cfg f [1.0]
+ head (OC.orBest r) `shouldSatisfy` (\v -> v >= -0.1 && v <= 2.1)
+
+ it "LBFGS: lbBounds で box 内に解が収まる" $ do
+ let f xs = (head xs - 5)^(2::Int)
+ cfg = LBFGS.defaultLBFGSConfig { LBFGS.lbBounds = Just [(0, 2)] }
+ r <- LBFGS.runLBFGSNumeric cfg f [1.0]
+ head (OC.orBest r) `shouldSatisfy` (\v -> v >= -0.1 && v <= 2.1)
+
+ it "CMAES (簡易版): cmBounds で box 内サンプル" $ do
+ gen <- MWC.create
+ let f xs = sum [x*x | x <- xs]
+ cfg = CMAES.defaultCMAESConfig
+ { CMAES.cmBounds = Just [(-1, 1), (-1, 1)]
+ , CMAES.cmStop = (CMAES.cmStop CMAES.defaultCMAESConfig)
+ { OC.stMaxIter = 80 }
+ }
+ r <- CMAES.runCMAESWith cfg f [0.5, 0.5] gen
+ all (\v -> v >= -1.05 && v <= 1.05) (OC.orBest r) `shouldBe` True
+
+ it "CMAESFull: cmfBounds で box 内サンプル" $ do
+ gen <- MWC.create
+ let f xs = sum [x*x | x <- xs]
+ cfg = CMAESF.defaultCMAESFConfig
+ { CMAESF.cmfBounds = Just [(-1, 1), (-1, 1)]
+ , CMAESF.cmfStop = (CMAESF.cmfStop CMAESF.defaultCMAESFConfig)
+ { OC.stMaxIter = 80 }
+ }
+ r <- CMAESF.runCMAESFullWith cfg f [0.5, 0.5] gen
+ all (\v -> v >= -1.05 && v <= 1.05) (OC.orBest r) `shouldBe` True
+
+ -- ===========================================================================
+ -- Bayesian Optimization 内部最適化の差し替え (Hanalyze.Optim.BayesOpt)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Optim/ConstrainedSpec.hs b/test/Hanalyze/Optim/ConstrainedSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/ConstrainedSpec.hs
@@ -0,0 +1,75 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.ConstrainedSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Optim.Constrained as Con
+import qualified Hanalyze.Optim.Common as OC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.Constrained" $ do
+ it "Augmented Lagrangian: min x1²+x2² s.t. x1+x2=1 → (0.5, 0.5)" $ do
+ let f xs = (head xs)^(2::Int) + (xs !! 1)^(2::Int)
+ cs = Con.ConstraintSet
+ { Con.csEq = [\xs -> head xs + xs !! 1 - 1]
+ , Con.csIneq = []
+ }
+ (r, viol) <- Con.runAugmentedLagrangian
+ Con.defaultConstrainedConfig f cs [0, 0]
+ let [x1, x2] = OC.orBest r
+ abs (x1 - 0.5) `shouldSatisfy` (< 0.05)
+ abs (x2 - 0.5) `shouldSatisfy` (< 0.05)
+ viol `shouldSatisfy` (< 1e-3)
+
+ it "Augmented Lagrangian: 不等式 x ≥ 1 (h(x)=1-x≤0) で min x²" $ do
+ let f xs = (head xs)^(2::Int)
+ cs = Con.ConstraintSet
+ { Con.csEq = []
+ , Con.csIneq = [\xs -> 1 - head xs] -- 1 - x ≤ 0 ⇔ x ≥ 1
+ }
+ (r, viol) <- Con.runAugmentedLagrangian
+ Con.defaultConstrainedConfig f cs [0]
+ let [x] = OC.orBest r
+ x `shouldSatisfy` (\v -> v >= 1 - 0.01)
+ viol `shouldSatisfy` (< 1e-3)
+
+ it "Penalty method: 等式 x1+x2=1 (簡易版)" $ do
+ let f xs = (head xs)^(2::Int) + (xs !! 1)^(2::Int)
+ cs = Con.ConstraintSet
+ { Con.csEq = [\xs -> head xs + xs !! 1 - 1]
+ , Con.csIneq = []
+ }
+ (r, _) <- Con.penaltyMethod Con.defaultConstrainedConfig f cs [0, 0]
+ let [x1, x2] = OC.orBest r
+ abs (x1 + x2 - 1) `shouldSatisfy` (< 0.05)
+
+ it "boxToIneq: bounds [(1,5)] を不等式 2 本に展開、x=3 で両方満たす" $ do
+ let ineqs = Con.boxToIneq [(1.0, 5.0)]
+ length ineqs `shouldBe` 2
+ all (\h -> h [3.0] <= 0) ineqs `shouldBe` True
+ any (\h -> h [0.0] > 0) ineqs `shouldBe` True -- 下限違反
+ any (\h -> h [6.0] > 0) ineqs `shouldBe` True -- 上限違反
+
+ -- ===========================================================================
+ -- box 制約 (Bounds) 統一インターフェース (Hanalyze.Optim.Common)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Optim/DifferentialEvolutionSpec.hs b/test/Hanalyze/Optim/DifferentialEvolutionSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/DifferentialEvolutionSpec.hs
@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.DifferentialEvolutionSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Optim.DifferentialEvolution as DE
+import qualified Hanalyze.Optim.Common as OC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.DifferentialEvolution" $ do
+ let sphere xs = sum [x*x | x <- xs]
+ rastrigin xs =
+ 10 * fromIntegral (length xs) +
+ sum [x*x - 10 * cos (2 * pi * x) | x <- xs]
+ l2 a b = sqrt (sum (zipWith (\x y -> (x-y)^(2::Int)) a b))
+
+ it "DE: sphere 5D が原点付近に到達" $ do
+ gen <- MWC.create
+ let bs = replicate 5 (-5, 5)
+ cfg = (DE.defaultDEConfig bs)
+ { DE.deStop = OC.defaultStopCriteria { OC.stMaxIter = 200 } }
+ r <- DE.runDEWith cfg sphere gen
+ OC.orValue r `shouldSatisfy` (< 1e-3)
+
+ it "DE: Rastrigin 3D の大域最小 (原点) を見つける" $ do
+ gen <- MWC.create
+ let bs = replicate 3 (-5.12, 5.12)
+ cfg = (DE.defaultDEConfig bs)
+ { DE.deStop = OC.defaultStopCriteria { OC.stMaxIter = 400 } }
+ r <- DE.runDEWith cfg rastrigin gen
+ l2 (OC.orBest r) [0, 0, 0] `shouldSatisfy` (< 0.5)
+
+ -- ===========================================================================
+ -- 大域オプティマイザ (Hanalyze.Optim.CMAES、簡易対角版)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Optim/LBFGSSpec.hs b/test/Hanalyze/Optim/LBFGSSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/LBFGSSpec.hs
@@ -0,0 +1,58 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.LBFGSSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Optim.LBFGS as LBFGS
+import qualified Hanalyze.Optim.Common as OC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.LBFGS" $ do
+ let l2 :: [Double] -> [Double] -> Double
+ l2 a b = sqrt (sum (zipWith (\x y -> (x-y)^(2::Int)) a b))
+ sphere xs = sum [x*x | x <- xs]
+ sphereGrad xs = [2*x | x <- xs]
+ rosen [x, y] = (1-x)^(2::Int) + 100*(y - x*x)^(2::Int)
+ rosen _ = error "rosen: 2D"
+ rosenGrad [x, y] =
+ [ -2*(1-x) - 400*x*(y - x*x), 200*(y - x*x) ]
+ rosenGrad _ = error "rosenGrad: 2D"
+
+ it "minimises sphere 5D with analytic grad to ~0" $ do
+ r <- LBFGS.runLBFGS sphere sphereGrad [3, -2, 1, 0.5, -1.5]
+ OC.orValue r `shouldSatisfy` (< 1e-8)
+
+ it "minimises Rosenbrock 2D within 0.01 of (1,1)" $ do
+ let cfg = LBFGS.defaultLBFGSConfig
+ { LBFGS.lbStop = OC.defaultStopCriteria { OC.stMaxIter = 500 } }
+ r <- LBFGS.runLBFGSWith cfg rosen rosenGrad [-1.2, 1.0]
+ l2 (OC.orBest r) [1, 1] `shouldSatisfy` (< 0.01)
+
+ it "numeric gradient: sphere 30D converges" $ do
+ let x0 = take 30 (cycle [1.5, -2.0, 0.5])
+ r <- LBFGS.runLBFGSNumeric LBFGS.defaultLBFGSConfig sphere x0
+ OC.orValue r `shouldSatisfy` (< 1e-4)
+
+ -- ===========================================================================
+ -- 1D オプティマイザ (Hanalyze.Optim.LineSearch)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Optim/LineSearchSpec.hs b/test/Hanalyze/Optim/LineSearchSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/LineSearchSpec.hs
@@ -0,0 +1,61 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.LineSearchSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Hanalyze.Model.KernelRegression as K
+import qualified Hanalyze.Optim.LineSearch as LS
+import qualified Hanalyze.Optim.Common as OC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.LineSearch" $ do
+ let parabola [x] = (x - 2.5)^(2::Int) + 1.0
+ parabola _ = error "1D"
+ cosBowl [x] = cos x + 0.1 * x * x -- 単峰、最小 ≈ 1.428 付近
+ cosBowl _ = error "1D"
+
+ it "Brent: parabola minimum at x = 2.5" $ do
+ let r = LS.brent LS.defaultBrentConfig parabola 0 5
+ abs (head (OC.orBest r) - 2.5) `shouldSatisfy` (< 1e-5)
+ OC.orValue r `shouldSatisfy` (\v -> abs (v - 1) < 1e-8)
+
+ it "Brent: cos x + 0.1 x² minimum (verified by GS)" $ do
+ let rB = LS.brent LS.defaultBrentConfig cosBowl 0 4
+ rG = LS.goldenSection OC.Minimize cosBowl 0 4 1e-8 200
+ abs (head (OC.orBest rB) - head (OC.orBest rG)) `shouldSatisfy` (< 1e-3)
+
+ it "GoldenSection: parabola minimum at x = 2.5" $ do
+ let r = LS.goldenSection OC.Minimize parabola 0 5 1e-7 200
+ abs (head (OC.orBest r) - 2.5) `shouldSatisfy` (< 1e-3)
+
+ it "Kernel.autoBandwidthBrent: 同じ最適 h を grid 法とほぼ一致" $ do
+ let xs = V.fromList [0.0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
+ ys = V.map (\x -> sin x + 0.1 * x) xs
+ (hG, _) = K.gridSearchBandwidth K.Gaussian xs ys [0.5, 0.8, 1.0, 1.5, 2.0, 3.0]
+ (hB, _) = K.autoBandwidthBrent K.Gaussian xs ys 0.3 4.0
+ abs (hB - hG) `shouldSatisfy` (< 1.0) -- グリッドと近い領域
+
+ -- ===========================================================================
+ -- 大域オプティマイザ (Hanalyze.Optim.DifferentialEvolution)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Optim/NSGASpec.hs b/test/Hanalyze/Optim/NSGASpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/NSGASpec.hs
@@ -0,0 +1,212 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.NSGASpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Optim.NSGA as NSGAP3
+import qualified Hanalyze.Optim.NSGA as NSGA
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.NSGA building blocks" $ do
+ let mkSol obj = NSGA.Solution
+ { NSGA.solDecision = obj -- decision unused here
+ , NSGA.solObjectives = obj
+ , NSGA.solViolation = 0
+ }
+ s00 = mkSol [0.0, 0.0] -- dominated by no one
+ s11 = mkSol [1.0, 1.0] -- dominated by s00
+ s05 = mkSol [0.5, 0.5]
+ sa = mkSol [0.0, 1.0] -- non-comparable with sb
+ sb = mkSol [1.0, 0.0]
+
+ it "dominates: zero-violation pair uses paretoDominates" $ do
+ NSGA.dominates s00 s11 `shouldBe` True
+ NSGA.dominates s11 s00 `shouldBe` False
+ NSGA.dominates sa sb `shouldBe` False
+ NSGA.dominates sb sa `shouldBe` False
+
+ it "nonDominatedSort: 3-point chain returns 3 fronts" $ do
+ -- s00 ≻ s05 ≻ s11
+ let fronts = NSGA.nonDominatedSort [s11, s05, s00]
+ length fronts `shouldBe` 3
+ length (head fronts) `shouldBe` 1 -- F_1 = {s00}
+
+ it "crowdingDistance: 2-point front keeps both (≤2 → ∞)" $
+ length (NSGA.crowdingDistance [sa, sb]) `shouldBe` 2
+
+ it "crowdingDistance: 3-point front returns all 3 (∞ endpoints + 1 mid)" $ do
+ let f3 = [mkSol [0.0, 1.0], mkSol [0.5, 0.5], mkSol [1.0, 0.0]]
+ sorted = NSGA.crowdingDistance f3
+ length sorted `shouldBe` 3
+
+ it "dominationMatrix matches per-pair dominates on a 3-individual pop" $ do
+ let s00 = NSGA.Solution [0, 0] [0.0, 0.0] 0 -- best
+ s11 = NSGA.Solution [1, 1] [1.0, 1.0] 0 -- worst
+ s05 = NSGA.Solution [0.5, 0.5] [0.5, 0.5] 0 -- middle
+ pop = [s00, s05, s11]
+ pm = NSGA.fromSolutions pop
+ mDom = NSGA.dominationMatrix pm
+ n = length pop
+ ref = LA.fromLists
+ [ [ if i == j then 0
+ else if NSGA.dominates (pop !! i) (pop !! j) then 1
+ else if NSGA.dominates (pop !! j) (pop !! i) then -1
+ else 0
+ | j <- [0 .. n - 1] ]
+ | i <- [0 .. n - 1] ]
+ :: LA.Matrix Double
+ LA.norm_Inf (mDom - ref) `shouldBe` 0
+
+ it "polynomialMutation: respects bounds and pMut=0 keeps x" $ do
+ gen <- MWC.createSystemRandom
+ let bs = [(0, 1), (0, 1), (0, 1)] :: [(Double, Double)]
+ x' <- NSGA.polynomialMutation 20 0 bs [0.5, 0.5, 0.5] gen
+ x' `shouldBe` [0.5, 0.5, 0.5]
+ y' <- NSGA.polynomialMutation 20 1.0 bs [0.5, 0.5, 0.5] gen
+ all (\(z, (lo, hi)) -> z >= lo && z <= hi) (zip y' bs)
+ `shouldBe` True
+
+ describe "Hanalyze.Optim.NSGA.nsga2AllFronts (Phase 3.2)" $ do
+ -- ZDT1 (2D decision): f1 = x1、 g = 1 + 9·x2、 f2 = g·(1 − √(f1/g))。
+ -- x2 > 0 が dominated 解を生む → rank ≥ 1 を確実に残せる。
+ let zdt1 :: [Double] -> [Double]
+ zdt1 xs = case xs of
+ [x1, x2] ->
+ let g = 1 + 9 * x2
+ f1 = x1
+ f2 = g * (1 - sqrt (max 1e-12 (f1 / g)))
+ in [f1, f2]
+ _ -> [0, 0]
+ bounds2 = [(0.0, 1.0), (0.0, 1.0)]
+ cfg = NSGAP3.defaultNSGAConfig
+ { NSGAP3.nsgaPopSize = 40
+ , NSGAP3.nsgaGenerations = 5 -- 少世代で dominated 解を残す
+ }
+
+ it "nsga2AllFronts は最低 1 front (rank 0) を返す" $ do
+ gen <- MWC.create
+ fronts <- NSGAP3.nsga2AllFronts cfg zdt1 bounds2 gen
+ length fronts `shouldSatisfy` (>= 1)
+ head fronts `shouldSatisfy` (not . null)
+
+ it "front の総 Solution 数 = 母集団サイズ" $ do
+ gen <- MWC.create
+ fronts <- NSGAP3.nsga2AllFronts cfg zdt1 bounds2 gen
+ sum (map length fronts) `shouldBe` NSGAP3.nsgaPopSize cfg
+
+ it "既存 nsga2 の結果と nsga2AllFronts の rank 0 が同一 (同じ seed)" $ do
+ gen1 <- MWC.create
+ front0_legacy <- NSGAP3.nsga2 cfg zdt1 bounds2 gen1
+ gen2 <- MWC.create
+ fronts_new <- NSGAP3.nsga2AllFronts cfg zdt1 bounds2 gen2
+ map NSGAP3.solDecision front0_legacy
+ `shouldBe` map NSGAP3.solDecision (head fronts_new)
+
+ it "rank ≥ 1 にアクセスできる (ZDT1 で dominated 解が必ず残る)" $ do
+ gen <- MWC.create
+ fronts <- NSGAP3.nsga2AllFronts cfg zdt1 bounds2 gen
+ length fronts `shouldSatisfy` (>= 2)
+
+ it "take (k+1) fronts で rank フィルタ" $ do
+ gen <- MWC.create
+ fronts <- NSGAP3.nsga2AllFronts cfg zdt1 bounds2 gen
+ let top2 = take 2 fronts
+ length top2 `shouldSatisfy` (<= 2)
+ length top2 `shouldSatisfy` (>= 1)
+
+ it "constrained 版 nsga2AllFrontsWithConstraints も動作" $ do
+ gen <- MWC.create
+ let constraint xs = case xs of
+ [a, b] -> max 0 (a + b - 1.5)
+ _ -> 0
+ fronts <- NSGAP3.nsga2AllFrontsWithConstraints cfg zdt1 constraint bounds2 gen
+ length fronts `shouldSatisfy` (>= 1)
+ head fronts `shouldSatisfy` (not . null)
+
+ describe "Hanalyze.Optim.NSGA.nsga2WithProgress (Phase 3.3)" $ do
+ let zdt1 :: [Double] -> [Double]
+ zdt1 xs = case xs of
+ [x1, x2] ->
+ let g = 1 + 9 * x2
+ f1 = x1
+ f2 = g * (1 - sqrt (max 1e-12 (f1 / g)))
+ in [f1, f2]
+ _ -> [0, 0]
+ bounds2 = [(0.0, 1.0), (0.0, 1.0)]
+ cfg = NSGAP3.defaultNSGAConfig
+ { NSGAP3.nsgaPopSize = 30
+ , NSGAP3.nsgaGenerations = 8
+ }
+
+ it "callback が ngpTotal 回呼ばれる" $ do
+ eventsRef <- newIORef []
+ gen <- MWC.create
+ _ <- NSGAP3.nsga2WithProgress cfg zdt1 bounds2
+ (\p -> modifyIORef' eventsRef (p :)) gen
+ events <- reverse <$> readIORef eventsRef
+ length events `shouldBe` NSGAP3.nsgaGenerations cfg
+
+ it "ngpGeneration は 0..total-1 で順番に並ぶ" $ do
+ eventsRef <- newIORef []
+ gen <- MWC.create
+ _ <- NSGAP3.nsga2WithProgress cfg zdt1 bounds2
+ (\p -> modifyIORef' eventsRef (p :)) gen
+ events <- reverse <$> readIORef eventsRef
+ map NSGAP3.ngpGeneration events
+ `shouldBe` [0 .. NSGAP3.nsgaGenerations cfg - 1]
+
+ it "ngpTotal は全 event で同値" $ do
+ eventsRef <- newIORef []
+ gen <- MWC.create
+ _ <- NSGAP3.nsga2WithProgress cfg zdt1 bounds2
+ (\p -> modifyIORef' eventsRef (p :)) gen
+ events <- readIORef eventsRef
+ length (nub (map NSGAP3.ngpTotal events)) `shouldBe` 1
+ head (map NSGAP3.ngpTotal events) `shouldBe` NSGAP3.nsgaGenerations cfg
+
+ it "ngpParetoSize > 0 (= rank 0 が常に非空)" $ do
+ eventsRef <- newIORef []
+ gen <- MWC.create
+ _ <- NSGAP3.nsga2WithProgress cfg zdt1 bounds2
+ (\p -> modifyIORef' eventsRef (p :)) gen
+ events <- readIORef eventsRef
+ all ((> 0) . NSGAP3.ngpParetoSize) events `shouldBe` True
+
+ it "ngpBestObjs の length = 目的次元数 (= 2 for ZDT1)" $ do
+ eventsRef <- newIORef []
+ gen <- MWC.create
+ _ <- NSGAP3.nsga2WithProgress cfg zdt1 bounds2
+ (\p -> modifyIORef' eventsRef (p :)) gen
+ events <- readIORef eventsRef
+ all ((== 2) . length . NSGAP3.ngpBestObjs) events `shouldBe` True
+
+ it "既存 nsga2 と nsga2WithProgress (no-op callback) は同じ Pareto を返す" $ do
+ gen1 <- MWC.create
+ front_legacy <- NSGAP3.nsga2 cfg zdt1 bounds2 gen1
+ gen2 <- MWC.create
+ front_prog <- NSGAP3.nsga2WithProgress cfg zdt1 bounds2 (\_ -> pure ()) gen2
+ map NSGAP3.solDecision front_legacy
+ `shouldBe` map NSGAP3.solDecision front_prog
diff --git a/test/Hanalyze/Optim/NelderMeadSpec.hs b/test/Hanalyze/Optim/NelderMeadSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/NelderMeadSpec.hs
@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.NelderMeadSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Optim.NelderMead as NM
+import qualified Hanalyze.Optim.Common as OC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.NelderMead" $ do
+ let l2 :: [Double] -> [Double] -> Double
+ l2 a b = sqrt (sum (zipWith (\x y -> (x-y)^(2::Int)) a b))
+ sphere xs = sum [x*x | x <- xs]
+ rosenbrock [x, y] = (1 - x)^(2::Int) + 100 * (y - x*x)^(2::Int)
+ rosenbrock _ = error "rosenbrock: 2D only"
+
+ it "minimises sphere f(x)=Σx² to ~0 from x0=[3,-2,1]" $ do
+ r <- NM.runNelderMead sphere [3, -2, 1]
+ OC.orValue r `shouldSatisfy` (< 1e-6)
+
+ it "minimises Rosenbrock 2D to (1,1) within 0.05" $ do
+ let cfg = NM.defaultNMConfig
+ { NM.nmStop = OC.defaultStopCriteria { OC.stMaxIter = 5000 } }
+ r <- NM.runNelderMeadWith cfg rosenbrock [-1.2, 1.0]
+ l2 (OC.orBest r) [1, 1] `shouldSatisfy` (< 0.05)
+
+ it "Maximize: -sphere has optimum 0 at origin" $ do
+ let cfg = NM.defaultNMConfig { NM.nmDir = OC.Maximize }
+ r <- NM.runNelderMeadWith cfg (\xs -> negate (sphere xs)) [3, -2, 1]
+ -- Maximize: orValue は元尺度 (= negate sphere の最大値、すなわち 0 に近い)
+ OC.orValue r `shouldSatisfy` (\v -> v > -1e-6)
+ -- 最良点は原点近傍
+ l2 (OC.orBest r) [0, 0, 0] `shouldSatisfy` (< 1e-2)
+
+ -- ===========================================================================
+ -- 単目的オプティマイザ (Hanalyze.Optim.LBFGS)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Optim/ParticleSwarmSpec.hs b/test/Hanalyze/Optim/ParticleSwarmSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/ParticleSwarmSpec.hs
@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.ParticleSwarmSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Optim.ParticleSwarm as PSO
+import qualified Hanalyze.Optim.Common as OC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.ParticleSwarm" $ do
+ it "PSO: sphere 5D で原点近傍 (0.5 以内)" $ do
+ gen <- MWC.create
+ let bs = replicate 5 (-5, 5)
+ cfg = (PSO.defaultPSOConfig bs)
+ { PSO.psoStop = OC.defaultStopCriteria { OC.stMaxIter = 200 }
+ , PSO.psoNum = 30 }
+ sphere xs = sum [x*x | x <- xs]
+ r <- PSO.runPSOWith cfg sphere gen
+ OC.orValue r `shouldSatisfy` (< 0.5)
+
+ it "PSO: Rastrigin 3D の大域最小に近い" $ do
+ gen <- MWC.create
+ let bs = replicate 3 (-5.12, 5.12)
+ cfg = (PSO.defaultPSOConfig bs)
+ { PSO.psoStop = OC.defaultStopCriteria { OC.stMaxIter = 300 }
+ , PSO.psoNum = 40 }
+ rastrigin xs =
+ 10 * fromIntegral (length xs) +
+ sum [x*x - 10 * cos (2 * pi * x) | x <- xs]
+ r <- PSO.runPSOWith cfg rastrigin gen
+ OC.orValue r `shouldSatisfy` (< 5.0) -- 大域近傍 (10 程度の局所有り)
+
+ -- ===========================================================================
+ -- 制約付き最適化 (Augmented Lagrangian)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Optim/SimulatedAnnealingSpec.hs b/test/Hanalyze/Optim/SimulatedAnnealingSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Optim/SimulatedAnnealingSpec.hs
@@ -0,0 +1,42 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Optim.SimulatedAnnealingSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Optim.SimulatedAnnealing as SA
+import qualified Hanalyze.Optim.Common as OC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Optim.SimulatedAnnealing" $ do
+ it "SA: sphere 5D で sufficient annealing" $ do
+ gen <- MWC.create
+ let bs = replicate 5 (-3, 3)
+ cfg = (SA.defaultSAConfig bs)
+ { SA.saStop = OC.defaultStopCriteria { OC.stMaxIter = 5000 }
+ , SA.saInitTemp = 2.0
+ , SA.saSchedule = SA.Geometric 0.997 }
+ sphere xs = sum [x*x | x <- xs]
+ r <- SA.runSAWith cfg sphere [2, -1.5, 1, 0.5, -0.7] gen
+ OC.orValue r `shouldSatisfy` (< 0.5)
diff --git a/test/Hanalyze/Stat/AdaptiveGridSpec.hs b/test/Hanalyze/Stat/AdaptiveGridSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/AdaptiveGridSpec.hs
@@ -0,0 +1,56 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.AdaptiveGridSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Stat.AdaptiveGrid as AG
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.AdaptiveGrid" $ do
+ it "uniformGrid: 端点を含み等間隔" $ do
+ let g = AG.uniformGrid 5 0 4
+ g `shouldBe` [0, 1, 2, 3, 4]
+
+ it "Adaptive: 急激な変化付近に grid が集中する (step 関数)" $ do
+ -- y は z=0..1 でほぼ平坦、z=1..2 で急激に変化、z=2..3 で再び平坦
+ let pts1 = [(z, if z < 1 then 0 else if z < 2 then 10*(z-1) else 10) | z <- [0, 0.1 .. 3]]
+ spec = (AG.defaultGridSpec 30) { AG.gsKind = AG.Adaptive }
+ g = AG.makeGrid [pts1] (0, 3) spec
+ -- 中央領域 [1, 2] にある grid 点数 vs 端領域 [0,1] の grid 点数
+ midN = length (filter (\z -> z >= 1 && z <= 2) g)
+ edgeN = length (filter (\z -> z < 1) g)
+ length g `shouldBe` 30
+ midN `shouldSatisfy` (> edgeN)
+
+ it "Uniform: 端点 + 等間隔" $ do
+ let g = AG.makeGrid [] (0, 1) ((AG.defaultGridSpec 6) { AG.gsKind = AG.Uniform })
+ length g `shouldBe` 6
+ head g `shouldBe` 0
+ last g `shouldBe` 1
+
+ it "N < 10 で adaptive 指定でも uniform にフォールバック" $ do
+ let pts1 = [(z, sin z) | z <- [0, 0.1 .. 3]]
+ spec = (AG.defaultGridSpec 5) { AG.gsKind = AG.Adaptive }
+ g = AG.makeGrid [pts1] (0, 3) spec
+ gU = AG.uniformGrid 5 0 3
+ g `shouldBe` gU
diff --git a/test/Hanalyze/Stat/BayesFactorSpec.hs b/test/Hanalyze/Stat/BayesFactorSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/BayesFactorSpec.hs
@@ -0,0 +1,73 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.BayesFactorSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Map.Strict as M
+import qualified System.Random.MWC as MWC
+import qualified Data.ByteString as BS
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.MCMC.NUTS as NUTS
+import qualified Hanalyze.Stat.BridgeSampling as BS
+import qualified Hanalyze.Stat.BayesFactor as BF
+import qualified Hanalyze.Model.HBM as HBM
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.BayesFactor (Phase 29-A3 via Bridge Sampling)" $ do
+ -- M_0: μ ~ N(0, 1) (= 強い prior、 データ y=5 から離れている)
+ -- M_1: μ ~ N(0, 10) (= 弱い prior、 データに近い μ が許容される)
+ -- データ y_i = 5 (n=10)
+ -- → M_1 が事実上 favored、 BF_{10} > 1 が期待
+ let m0 :: HBM.ModelP ()
+ m0 = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 1)
+ HBM.observe "y" (HBM.Normal mu 1) (replicate 10 5.0)
+ m1 :: HBM.ModelP ()
+ m1 = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ HBM.observe "y" (HBM.Normal mu 1) (replicate 10 5.0)
+ nutsCfg = NUTS.defaultNUTSConfig
+ { NUTS.nutsIterations = 2000
+ , NUTS.nutsBurnIn = 500
+ , NUTS.nutsAdaptStepSize = True
+ }
+ it "Bayes Factor: BF_{10} > 1 (= log_e BF > 0)、 M_1 が favored" $ do
+ gen0 <- MWC.create
+ ch0 <- NUTS.nuts m0 nutsCfg (M.fromList [("mu", 5)]) gen0
+ gen1 <- MWC.create
+ ch1 <- NUTS.nuts m1 nutsCfg (M.fromList [("mu", 5)]) gen1
+ gen2 <- MWC.create
+ r <- BF.bayesFactor m0 ch0 m1 ch1 BS.defaultBridgeConfig gen2
+ BF.bfLogE r `shouldSatisfy` (> 0)
+ -- 解釈: log_e BF > 5 (very strong) を期待 (= 強 prior vs 弱 prior の差)
+ BF.bfLogE r `shouldSatisfy` (> 5)
+ BF.interpretBF (BF.bfLogE r) `shouldBe` BF.BFVeryStrong
+ BF.bfConverged0 r `shouldBe` True
+ BF.bfConverged1 r `shouldBe` True
+ it "interpretBF: Kass-Raftery 解釈閾値" $ do
+ BF.interpretBF 0.5 `shouldBe` BF.BFNegligible
+ BF.interpretBF 2.0 `shouldBe` BF.BFPositive
+ BF.interpretBF 4.0 `shouldBe` BF.BFStrong
+ BF.interpretBF 6.0 `shouldBe` BF.BFVeryStrong
+ BF.interpretBF (-4.0) `shouldBe` BF.BFStrong -- 符号反転にも対応
diff --git a/test/Hanalyze/Stat/BayesianModelAveragingSpec.hs b/test/Hanalyze/Stat/BayesianModelAveragingSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/BayesianModelAveragingSpec.hs
@@ -0,0 +1,83 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.BayesianModelAveragingSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Map.Strict as M
+import qualified System.Random.MWC as MWC
+import qualified Data.ByteString as BS
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.MCMC.NUTS as NUTS
+import qualified Hanalyze.Stat.BridgeSampling as BS
+import qualified Hanalyze.Stat.BayesianModelAveraging as BMA
+import qualified Hanalyze.Model.HBM as HBM
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.BayesianModelAveraging (Phase 29-A4)" $ do
+ it "bayesianModelAveraging: 同じ log marginal で uniform weights、 prior 省略" $ do
+ let r = BMA.bayesianModelAveraging [-10, -10, -10] Nothing
+ BMA.bmaWeights r `shouldBe` [1/3, 1/3, 1/3]
+ it "bayesianModelAveraging: 大きい log marginal が高い weight、 softmax stable" $ do
+ let r = BMA.bayesianModelAveraging [-100, -98, -102] Nothing
+ -- 真ん中 (-98) が最大、 隣接で 1 / e^2 ≈ 0.135 倍
+ let ws = BMA.bmaWeights r
+ sum ws `shouldSatisfy` (\s -> abs (s - 1.0) < 1e-9)
+ (ws !! 1) `shouldSatisfy` (> ws !! 0)
+ (ws !! 1) `shouldSatisfy` (> ws !! 2)
+ it "averagePredictions: weighted sum of vectors" $ do
+ let r = BMA.bayesianModelAveraging [log 0.7, log 0.3] Nothing
+ v1 = LA.fromList [1, 2, 3]
+ v2 = LA.fromList [4, 5, 6]
+ avg = BMA.averagePredictions r [v1, v2]
+ -- 0.7·[1,2,3] + 0.3·[4,5,6] = [1.9, 2.9, 3.9]
+ LA.toList avg `shouldSatisfy`
+ (\xs -> length xs == 3 && all (\(a,b) -> abs (a - b) < 1e-9)
+ (zip xs [1.9, 2.9, 3.9]))
+ it "BMA 統合: Bridge 経由の log marginal で 2 モデル比較" $ do
+ let m0 :: HBM.ModelP ()
+ m0 = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 1)
+ HBM.observe "y" (HBM.Normal mu 1) (replicate 10 5.0)
+ m1 :: HBM.ModelP ()
+ m1 = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ HBM.observe "y" (HBM.Normal mu 1) (replicate 10 5.0)
+ nutsCfg = NUTS.defaultNUTSConfig
+ { NUTS.nutsIterations = 2000
+ , NUTS.nutsBurnIn = 500
+ , NUTS.nutsAdaptStepSize = True
+ }
+ gen0 <- MWC.create
+ ch0 <- NUTS.nuts m0 nutsCfg (M.fromList [("mu", 5)]) gen0
+ gen1 <- MWC.create
+ ch1 <- NUTS.nuts m1 nutsCfg (M.fromList [("mu", 5)]) gen1
+ gen2 <- MWC.create
+ r0 <- BS.bridgeSampling m0 BS.defaultBridgeConfig ch0 gen2
+ gen3 <- MWC.create
+ r1 <- BS.bridgeSampling m1 BS.defaultBridgeConfig ch1 gen3
+ let bma = BMA.bayesianModelAveraging
+ [BS.brLogMarginal r0, BS.brLogMarginal r1] Nothing
+ -- M_1 (= 弱 prior) が dominant weight (> 0.9 想定)
+ (BMA.bmaWeights bma !! 1) `shouldSatisfy` (> 0.9)
diff --git a/test/Hanalyze/Stat/BootstrapSpec.hs b/test/Hanalyze/Stat/BootstrapSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/BootstrapSpec.hs
@@ -0,0 +1,56 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.BootstrapSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.Bootstrap as Boot
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Bootstrap" $ do
+ it "bootstrapCI on N(0,1) sample: 0 が 95% CI 内" $ do
+ gen <- MWC.createSystemRandom
+ let xs = LA.fromList [-1.0, -0.5, 0.0, 0.5, 1.0,
+ -0.3, 0.3, -0.7, 0.7, 0.0]
+ (lo, hi) <- Boot.bootstrapCI 2000 0.95 Boot.sampleMean xs gen
+ lo `shouldSatisfy` (< 0.5)
+ hi `shouldSatisfy` (> -0.5)
+
+ it "permutationTest: 異なる平均で p < 0.05" $ do
+ gen <- MWC.createSystemRandom
+ let xs = LA.fromList [1.0, 2.0, 3.0, 4.0, 5.0, 6.0]
+ ys = LA.fromList [10.0, 11.0, 12.0, 13.0, 14.0, 15.0]
+ (_diff, p) <- Boot.permutationTest 2000 xs ys gen
+ p `shouldSatisfy` (< 0.05)
+
+ it "sampleMean / sampleVar / sampleMedian の整合性" $ do
+ let v = LA.fromList [1.0, 2.0, 3.0, 4.0, 5.0]
+ Boot.sampleMean v `shouldBe` 3.0
+ Boot.sampleVar v `shouldBe` 2.5 -- variance of 1..5 (unbiased)
+ Boot.sampleMedian v `shouldBe` 3.0
+
+ -- ===========================================================================
+ -- Hanalyze.DataIO.Reshape (Phase 8)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Stat/BridgeSamplingSpec.hs b/test/Hanalyze/Stat/BridgeSamplingSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/BridgeSamplingSpec.hs
@@ -0,0 +1,63 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.BridgeSamplingSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Map.Strict as M
+import qualified System.Random.MWC as MWC
+import qualified Data.ByteString as BS
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.MCMC.NUTS as NUTS
+import qualified Hanalyze.Stat.BridgeSampling as BS
+import qualified Hanalyze.Model.HBM as HBM
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.BridgeSampling (Phase 29-A2 Meng-Wong)" $ do
+ -- Gaussian × Gaussian model: μ ~ N(0, σ_p=10)、 y ~ N(μ, σ_y=1)、 n=10、 y=5.0
+ -- 解析的 log marginal (Python で検算): log p(y) ≈ -12.7686
+ -- 算出法: log p(y) = log p(y|μ*) + log p(μ*) - log p(μ*|y) at μ* = posterior mean
+ -- μ_post = 4.99500、 σ_post² = 0.0999、 ȳ = 5.0
+ let modelBS :: HBM.ModelP ()
+ modelBS = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 10)
+ HBM.observe "y" (HBM.Normal mu 1) (replicate 10 5.0)
+ nutsCfg = NUTS.defaultNUTSConfig
+ { NUTS.nutsIterations = 2000
+ , NUTS.nutsBurnIn = 500
+ , NUTS.nutsAdaptStepSize = True
+ }
+ it "Bridge Sampling: log marginal が解析解 (-12.77) と 0.5 以内一致" $ do
+ gen <- MWC.create
+ chain <- NUTS.nuts modelBS nutsCfg (M.fromList [("mu", 5)]) gen
+ gen2 <- MWC.create
+ r <- BS.bridgeSampling modelBS BS.defaultBridgeConfig chain gen2
+ let analytic = (-12.7686)
+ BS.brLogMarginal r `shouldSatisfy` (\x -> abs (x - analytic) < 0.5)
+ BS.brConverged r `shouldBe` True
+ it "Bridge Sampling: 反復が tolerance 内で収束 (< 50 iter)" $ do
+ gen <- MWC.create
+ chain <- NUTS.nuts modelBS nutsCfg (M.fromList [("mu", 5)]) gen
+ gen2 <- MWC.create
+ r <- BS.bridgeSampling modelBS BS.defaultBridgeConfig chain gen2
+ BS.brIterations r `shouldSatisfy` (< 50)
diff --git a/test/Hanalyze/Stat/CVSpec.hs b/test/Hanalyze/Stat/CVSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/CVSpec.hs
@@ -0,0 +1,74 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.CVSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Hanalyze.Stat.CV as CV
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.CV" $ do
+ it "kFold(5, 100): 5 fold で全 100 行を test に使用、重複なし" $ do
+ gen <- MWC.createSystemRandom
+ folds <- CV.kFold 5 100 gen
+ length folds `shouldBe` 5
+ let allTest = concatMap snd folds
+ length allTest `shouldBe` 100
+ length (V.toList (V.fromList allTest)) `shouldBe` 100 -- 重複なし
+
+ it "kFold: train + test = total samples per fold" $ do
+ gen <- MWC.createSystemRandom
+ folds <- CV.kFold 5 100 gen
+ mapM_ (\(tr, te) -> length tr + length te `shouldBe` 100) folds
+
+ it "leaveOneOut(10): 10 folds、test set size 1 each" $ do
+ folds <- CV.leaveOneOut 10
+ length folds `shouldBe` 10
+ mapM_ (\(_, te) -> length te `shouldBe` 1) folds
+
+ it "stratifiedKFold(3): クラスバランスがほぼ保持される" $ do
+ gen <- MWC.createSystemRandom
+ let labels = replicate 30 0 ++ replicate 30 1 ++ replicate 30 2
+ folds <- CV.stratifiedKFold 3 labels gen
+ length folds `shouldBe` 3
+ -- 各 fold の test set には各クラスの ~10 が含まれる
+ mapM_ (\(_, te) -> length te `shouldSatisfy` (\n -> n >= 27 && n <= 33)) folds
+
+ it "shuffleSplit: 反復回数とテストサイズが正しい" $ do
+ gen <- MWC.createSystemRandom
+ folds <- CV.shuffleSplit 5 0.2 100 gen
+ length folds `shouldBe` 5
+ mapM_ (\(_, te) -> length te `shouldBe` 20) folds
+
+ it "timeSeriesSplit: forward-chaining で過去のみで学習" $ do
+ let folds = CV.timeSeriesSplit 50 10 100 -- initial=50, step=10, n=100
+ length folds `shouldBe` 5 -- (100-50)/10 = 5 folds
+ -- 全 fold で train indices < min(test indices)
+ mapM_ (\(tr, te) ->
+ (maximum tr < minimum te) `shouldBe` True) folds
+
+ -- ===========================================================================
+ -- Hanalyze.Model.Cluster (Phase 5)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Stat/Causal/CATESpec.hs b/test/Hanalyze/Stat/Causal/CATESpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/Causal/CATESpec.hs
@@ -0,0 +1,125 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.Causal.CATESpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Model.RandomForest as RF
+import qualified Data.Vector.Storable as VS
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Stat.Causal.CATE as CCATE
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Causal.CATE (Phase 30-A4 meta-learners)" $ do
+ -- 異質 treatment effect DGP:
+ -- X1, X2 ~ N(0,1)、 T ~ Bern(σ(0.5·X1))
+ -- Y = 1 + 0.5·X1 + 0.3·X2 + (1 + X1)·T + N(0, 0.5)
+ -- 真の τ(X) = 1 + X1、 ATE = E[τ] = 1.0
+ -- LM base learner では: T-learner / X-learner は τ(X) を線形回復、
+ -- S-learner は単純な intercept-shift で ATE のみ近似 (interaction 無し)。
+ it "CATE: T-learner と X-learner が ATE を 20% 以内回復、 X1 と単調" $ do
+ gen <- MWC.create
+ let nC = 2000
+ trueATE = 1.0 :: Double
+ x1s <- VS.replicateM nC (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ x2s <- VS.replicateM nC (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ noises <- VS.replicateM nC (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.5 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let sigC z = 1.0 / (1.0 + exp (-z))
+ us <- VS.replicateM nC (MWC.uniformR (0.0, 1.0 :: Double) gen)
+ let ps0 = VS.map (\a -> sigC (0.5 * a)) x1s
+ tsV = VS.zipWith (\p u -> if u < p then 1.0 else 0.0) ps0 us
+ ysV = VS.zipWith4 (\x1 x2 tt e ->
+ 1.0 + 0.5 * x1 + 0.3 * x2 + (1.0 + x1) * tt + e)
+ x1s x2s tsV noises
+ x1List = VS.toList x1s
+ xMatC = LA.fromColumns
+ [ LA.fromList (replicate nC 1)
+ , LA.fromList x1List
+ , LA.fromList (VS.toList x2s) ]
+ tVecC = LA.fromList (VS.toList tsV)
+ yVecC = LA.fromList (VS.toList ysV)
+ tR <- CCATE.fitCATE CCATE.TLearner CCATE.CATELM xMatC tVecC yVecC gen
+ sR <- CCATE.fitCATE CCATE.SLearner CCATE.CATELM xMatC tVecC yVecC gen
+ xR <- CCATE.fitCATE CCATE.XLearner CCATE.CATELM xMatC tVecC yVecC gen
+ -- ATE 回復: T / X-learner は 20% 以内
+ CCATE.cateATE tR `shouldSatisfy` (\v -> abs (v - trueATE) < 0.2)
+ CCATE.cateATE xR `shouldSatisfy` (\v -> abs (v - trueATE) < 0.2)
+ -- S-learner は constant CATE のため ATE ≈ 1 を 30% 以内
+ CCATE.cateATE sR `shouldSatisfy` (\v -> abs (v - trueATE) < 0.3)
+ -- 長さ一致
+ LA.size (CCATE.cateEstimates tR) `shouldBe` nC
+ LA.size (CCATE.cateEstimates sR) `shouldBe` nC
+ LA.size (CCATE.cateEstimates xR) `shouldBe` nC
+ -- T-learner τ̂(X) は X1 と単調 (= rank correlation > 0.5)
+ let tauT = LA.toList (CCATE.cateEstimates tR)
+ rankCorr as bs =
+ let pairs = zip as bs
+ concCount = sum
+ [ 1 :: Int
+ | (i, (ai, bi)) <- zip [0..] pairs
+ , (j, (aj, bj)) <- zip [0..] pairs
+ , i < j
+ , (ai - aj) * (bi - bj) > 0 ]
+ discCount = sum
+ [ 1 :: Int
+ | (i, (ai, bi)) <- zip [0..] pairs
+ , (j, (aj, bj)) <- zip [0..] pairs
+ , i < j
+ , (ai - aj) * (bi - bj) < 0 ]
+ tot = concCount + discCount
+ in if tot == 0
+ then 0.0
+ else fromIntegral (concCount - discCount)
+ / fromIntegral tot
+ -- 速度のため先頭 200 サンプルだけで rank correlation を概算
+ rc = rankCorr (take 200 tauT) (take 200 x1List)
+ rc `shouldSatisfy` (> 0.5)
+ it "CATE: RF base learner で T-learner が ATE を 30% 以内回復 (smoke test)" $ do
+ gen <- MWC.create
+ let nSmall = 400
+ trueATE = 1.0 :: Double
+ x1s <- VS.replicateM nSmall (MWC.uniformR (-2.0, 2.0 :: Double) gen)
+ us <- VS.replicateM nSmall (MWC.uniformR (0.0, 1.0 :: Double) gen)
+ let sigC z = 1.0 / (1.0 + exp (-z))
+ ps0 = VS.map (\a -> sigC (0.5 * a)) x1s
+ tsV = VS.zipWith (\p u -> if u < p then 1.0 else 0.0) ps0 us
+ ysV = VS.zipWith (\x1 tt -> 1.0 + 0.5 * x1 + (1.0 + x1) * tt)
+ x1s tsV
+ xMatS = LA.fromColumns [LA.fromList (VS.toList x1s)]
+ tVecS = LA.fromList (VS.toList tsV)
+ yVecS = LA.fromList (VS.toList ysV)
+ rfCfg = RF.defaultRandomForest { RF.rfTrees = 30, RF.rfMaxDepth = 6 }
+ r <- CCATE.fitCATE CCATE.TLearner (CCATE.CATERF rfCfg)
+ xMatS tVecS yVecS gen
+ CCATE.cateATE r `shouldSatisfy` (\v -> abs (v - trueATE) < 0.3)
+ LA.size (CCATE.cateEstimates r) `shouldBe` nSmall
diff --git a/test/Hanalyze/Stat/Causal/DoublyRobustSpec.hs b/test/Hanalyze/Stat/Causal/DoublyRobustSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/Causal/DoublyRobustSpec.hs
@@ -0,0 +1,83 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.Causal.DoublyRobustSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Storable as VS
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Stat.Causal.PropensityScore as PS
+import qualified Hanalyze.Stat.Causal.DoublyRobust as CDR
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Causal.DoublyRobust (Phase 30-A3 AIPW)" $ do
+ -- IPW と同じ合成データ (真の ATE = 2.0)、 共通 helper にすると
+ -- IO の流れが複雑になるので 1 つの it 内で 4 ケースまとめて検証。
+ it "AIPW: 二重ロバスト性 (正しい outcome / 誤った PS でも 15% 以内回復)" $ do
+ gen <- MWC.create
+ let nC = 2000
+ trueTau = 2.0 :: Double
+ x1s <- VS.replicateM nC (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ x2s <- VS.replicateM nC (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ noises <- VS.replicateM nC (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.5 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let sigC z = 1.0 / (1.0 + exp (-z))
+ us <- VS.replicateM nC (MWC.uniformR (0.0, 1.0 :: Double) gen)
+ let ps0 = VS.zipWith (\a b -> sigC (0.8 * a + 0.4 * b)) x1s x2s
+ tsV = VS.zipWith (\p u -> if u < p then 1.0 else 0.0) ps0 us
+ ysV = VS.zipWith4 (\x1 x2 tt e ->
+ 1.0 + 0.5 * x1 + 0.3 * x2 + trueTau * tt + e)
+ x1s x2s tsV noises
+ xMatC = LA.fromColumns
+ [ LA.fromList (replicate nC 1)
+ , LA.fromList (VS.toList x1s)
+ , LA.fromList (VS.toList x2s) ]
+ tVecC = LA.fromList (VS.toList tsV)
+ yVecC = LA.fromList (VS.toList ysV)
+ -- (a) 両方正しい: DR は τ=2 を 10% 以内
+ let drR = CDR.doublyRobust xMatC tVecC yVecC
+ CDR.drATE drR `shouldSatisfy` (\v -> abs (v - trueTau) < 0.1 * trueTau)
+ LA.size (CDR.drMu1Predicted drR) `shouldBe` nC
+ LA.size (CDR.drMu0Predicted drR) `shouldBe` nC
+ -- (b) PS misspecified (= 全て 0.5、 = "RCT 想定"): outcome model が正しい
+ -- ので DR は 15% 以内に補正される (二重ロバスト性の片側)
+ let psBad = PS.PropensityScore
+ (LA.fromList (replicate nC 0.5))
+ (LA.fromList [0]) nC
+ drBadPS = CDR.doublyRobustWith psBad xMatC tVecC yVecC
+ CDR.drATE drBadPS `shouldSatisfy` (\v -> abs (v - trueTau) < 0.15 * trueTau)
+ -- (c) PS は正しく、 outcome model は intercept-only (= misspecified):
+ -- DR は IPW 相当に縮退し、 PS が正しいので 15% 以内
+ let xIntOnly = LA.fromColumns [LA.fromList (replicate nC 1)]
+ psGood = PS.trimPropensity 0.01 0.99 (PS.propensityScore xMatC tVecC)
+ drBadOut = CDR.doublyRobustWith psGood xIntOnly tVecC yVecC
+ CDR.drATE drBadOut `shouldSatisfy` (\v -> abs (v - trueTau) < 0.15 * trueTau)
diff --git a/test/Hanalyze/Stat/Causal/IPWSpec.hs b/test/Hanalyze/Stat/Causal/IPWSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/Causal/IPWSpec.hs
@@ -0,0 +1,88 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.Causal.IPWSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Storable as VS
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Stat.Causal.PropensityScore as PS
+import qualified Hanalyze.Stat.Causal.IPW as CIPW
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Causal.IPW (Phase 30-A2)" $ do
+ -- 合成データ (真の ATE = 2.0):
+ -- X1 ~ N(0, 1)、 X2 ~ N(0, 1)、 T ~ Bern(σ(0.8·X1 + 0.4·X2))
+ -- Y = 1.0 + 0.5·X1 + 0.3·X2 + 2.0·T + N(0, 0.5)
+ -- → naive E[Y|T=1] - E[Y|T=0] は X1/X2 経由の交絡で真値より上、
+ -- IPW で正しく τ=2 に補正されるはず。
+ let trueTau = 2.0 :: Double
+ it "ipw: ATE が真値 2.0 の 10% 以内 (MWC 合成、 n=2000)" $ do
+ gen <- MWC.createSystemRandom >> MWC.create -- 固定 seed
+ let nC = 2000
+ x1s <- VS.replicateM nC (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ x2s <- VS.replicateM nC (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ noises <- VS.replicateM nC (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (0.5 * sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let sigC z = 1.0 / (1.0 + exp (-z))
+ us <- VS.replicateM nC (MWC.uniformR (0.0, 1.0 :: Double) gen)
+ let ps0 = VS.zipWith (\a b -> sigC (0.8 * a + 0.4 * b)) x1s x2s
+ tsV = VS.zipWith (\p u -> if u < p then 1.0 else 0.0) ps0 us
+ ysV = VS.zipWith4 (\x1 x2 tt e ->
+ 1.0 + 0.5 * x1 + 0.3 * x2 + trueTau * tt + e)
+ x1s x2s tsV noises
+ xMatC = LA.fromColumns
+ [ LA.fromList (replicate nC 1)
+ , LA.fromList (VS.toList x1s)
+ , LA.fromList (VS.toList x2s) ]
+ tVecC = LA.fromList (VS.toList tsV)
+ yVecC = LA.fromList (VS.toList ysV)
+ ipwR = CIPW.ipw xMatC tVecC yVecC
+ CIPW.ipwATE ipwR `shouldSatisfy` (\v -> abs (v - trueTau) < 0.1 * trueTau)
+ -- 定数効果なので ATT も同程度の精度
+ CIPW.ipwATT ipwR `shouldSatisfy` (\v -> abs (v - trueTau) < 0.15 * trueTau)
+ -- 重み長さ + 非負
+ LA.size (CIPW.ipwWeightsATE ipwR) `shouldBe` nC
+ LA.toList (CIPW.ipwWeightsATE ipwR) `shouldSatisfy` all (>= 0)
+ -- defaultPSTrim 適用済
+ LA.toList (PS.psScores (CIPW.ipwPropensity ipwR)) `shouldSatisfy`
+ all (\p -> p >= 0.01 && p <= 0.99)
+ it "ipwWith: 既存 PS 再利用、 別 trim と組み合わせ可能" $ do
+ -- 簡単な手書きデータ: T=1 → Y=12, T=0 → Y=10、 PS = 0.5
+ -- → ATE = 2、 重み均等
+ let ps = PS.PropensityScore (LA.fromList [0.5, 0.5, 0.5, 0.5])
+ (LA.fromList [0]) 4
+ tv = LA.fromList [1, 0, 1, 0]
+ yv = LA.fromList [12, 10, 12, 10]
+ r = CIPW.ipwWith ps tv yv
+ CIPW.ipwATE r `shouldSatisfy` (\v -> abs (v - 2) < 1e-9)
+ CIPW.ipwATT r `shouldSatisfy` (\v -> abs (v - 2) < 1e-9)
diff --git a/test/Hanalyze/Stat/Causal/PropensityScoreSpec.hs b/test/Hanalyze/Stat/Causal/PropensityScoreSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/Causal/PropensityScoreSpec.hs
@@ -0,0 +1,87 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.Causal.PropensityScoreSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.Causal.PropensityScore as PS
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Causal.PropensityScore (Phase 30-A1)" $ do
+ -- 合成データ: x ~ uniform[-2, 2]、 T ~ Bernoulli(σ(x))
+ -- 真の logit: logit(p) = x、 intercept ≈ 0、 slope ≈ 1
+ let n = 500
+ xs = [(-2.0) + 4.0 * fromIntegral i / fromIntegral (n - 1) | i <- [0 .. n - 1]]
+ sigmoid z = 1.0 / (1.0 + exp (-z))
+ -- 決定的 0/1 割り当て (= 並べ替え逆数で疑似 Bernoulli): σ(x) > 閾値
+ -- → 安定したテストのため、 各 x で T = 1 if σ(x) > i_norm else 0
+ -- i_norm を [0,1] 等差にすることで rate ≈ σ(x) を実現
+ -- 閾値は i に対し x と無相関になるよう golden ratio low-discrepancy で散らす
+ frac z = z - fromIntegral (floor z :: Int)
+ thrs = [ frac (fromIntegral i * 0.6180339887498949) | i <- [0 .. n - 1] ]
+ ts = [ if sigmoid x > thr then 1.0 else 0.0
+ | (x, thr) <- zip xs thrs ]
+ xMat = LA.fromColumns [LA.fromList (replicate n 1), LA.fromList xs] -- intercept + x
+ tVec = LA.fromList ts
+ psR = PS.propensityScore xMat tVec
+ it "propensityScore: psN がサンプル数と一致" $
+ PS.psN psR `shouldBe` n
+ it "propensityScore: psScores が [0,1] に収まる + ベクトル長一致" $ do
+ LA.size (PS.psScores psR) `shouldBe` n
+ LA.toList (PS.psScores psR) `shouldSatisfy`
+ all (\p -> p >= 0 && p <= 1)
+ it "propensityScore: logistic slope > 0 (真値 +1 の符号と一致)" $ do
+ let beta = LA.toList (PS.psBeta psR)
+ length beta `shouldBe` 2
+ (beta !! 1) `shouldSatisfy` (> 0.3) -- slope 正、 強く回復しなくても符号は必須
+ it "trimPropensity: [0.01, 0.99] にクリップ" $ do
+ let ps0 = PS.PropensityScore (LA.fromList [0.0, 0.5, 1.0])
+ (LA.fromList [0, 0]) 3
+ ps1 = PS.trimPropensity 0.01 0.99 ps0
+ LA.toList (PS.psScores ps1) `shouldBe` [0.01, 0.5, 0.99]
+ it "ipwWeights: t/p + (1-t)/(1-p) を要素ごとに計算" $ do
+ let ps0 = PS.PropensityScore (LA.fromList [0.2, 0.8])
+ (LA.fromList [0]) 2
+ t0 = LA.fromList [1.0, 0.0]
+ ws = LA.toList (PS.ipwWeights ps0 t0)
+ -- 期待: [1/0.2, 1/0.2] = [5.0, 5.0]
+ ws `shouldSatisfy` (\xs -> length xs == 2
+ && abs (xs !! 0 - 5.0) < 1e-9
+ && abs (xs !! 1 - 5.0) < 1e-9)
+ it "attWeights: t + (1-t)·p/(1-p) を要素ごとに計算" $ do
+ let ps0 = PS.PropensityScore (LA.fromList [0.25, 0.75])
+ (LA.fromList [0]) 2
+ t0 = LA.fromList [1.0, 0.0]
+ ws = LA.toList (PS.attWeights ps0 t0)
+ -- 期待: [1.0, 0.75/0.25] = [1.0, 3.0]
+ ws `shouldSatisfy` (\xs -> length xs == 2
+ && abs (xs !! 0 - 1.0) < 1e-9
+ && abs (xs !! 1 - 3.0) < 1e-9)
+ it "trim 後の重みが有限 (発散しない)" $ do
+ -- p = 0 / 1 を含むケースを作り、 trim 前後で max weight を比較
+ let ps0 = PS.PropensityScore (LA.fromList [0.001, 0.5, 0.999])
+ (LA.fromList [0]) 3
+ ps1 = PS.trimPropensity 0.01 0.99 ps0
+ t0 = LA.fromList [1.0, 1.0, 0.0]
+ ws1 = LA.toList (PS.ipwWeights ps1 t0)
+ ws1 `shouldSatisfy` all (\w -> not (isInfinite w) && w < 200)
diff --git a/test/Hanalyze/Stat/CholeskySpec.hs b/test/Hanalyze/Stat/CholeskySpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/CholeskySpec.hs
@@ -0,0 +1,55 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.CholeskySpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.Cholesky as Chol
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Cholesky" $ do
+ let aSPD = LA.fromLists [[4, 2, 1], [2, 5, 3], [1, 3, 6]]
+ :: LA.Matrix Double
+ b = LA.asColumn (LA.fromList [1.0, 2.0, 3.0])
+
+ it "cholSolve agrees with LA.<\\> on a 3x3 SPD system (1e-9)" $ do
+ let xC = Chol.cholSolve aSPD b
+ xR = aSPD LA.<\> b
+ case xC of
+ Nothing -> expectationFailure "cholSolve returned Nothing on SPD"
+ Just xc -> LA.norm_Inf (xc - xR) < 1e-9 `shouldBe` True
+
+ it "cholSolveJitter falls back gracefully on a singular matrix" $ do
+ let aSing = LA.fromLists [[1, 0, 0], [0, 0, 0], [0, 0, 1]]
+ :: LA.Matrix Double
+ bSing = LA.asColumn (LA.fromList [1.0, 0.0, 1.0])
+ x = Chol.cholSolveJitter aSing bSing
+ LA.rows x `shouldBe` 3 -- did not crash; whatever LSQ gives is fine
+
+ it "cholFactor returns Just for SPD and Nothing for non-SPD" $ do
+ Chol.cholFactor aSPD `shouldSatisfy` (\m -> case m of
+ Just _ -> True
+ Nothing -> False)
+ let aNeg = LA.fromLists [[1, 2], [2, 1]] :: LA.Matrix Double
+ -- eigenvalues 3 and -1 → not SPD
+ Chol.cholFactor aNeg `shouldBe` Nothing
diff --git a/test/Hanalyze/Stat/ClassMetricsSpec.hs b/test/Hanalyze/Stat/ClassMetricsSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/ClassMetricsSpec.hs
@@ -0,0 +1,76 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.ClassMetricsSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Stat.ClassMetrics as CM
+import qualified Hanalyze.Design.Custom.Model as CM
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.ClassMetrics" $ do
+ it "confusionMatrix: 完全一致で TP/TN のみ" $ do
+ let c = CM.confusionMatrix [1, 0, 1, 0, 1] [1, 0, 1, 0, 1]
+ CM.confTP c `shouldBe` 3
+ CM.confTN c `shouldBe` 2
+ CM.confFP c `shouldBe` 0
+ CM.confFN c `shouldBe` 0
+ CM.accuracy c `shouldBe` 1.0
+ CM.f1Score c `shouldBe` 1.0
+
+ it "precision/recall/f1: 不均衡な誤分類" $ do
+ let c = CM.confusionMatrix [1, 1, 1, 0, 0] [1, 1, 0, 1, 0]
+ -- TP=2, FN=1, FP=1, TN=1
+ CM.precision c `shouldBe` 2/3 -- 2/(2+1)
+ CM.recall c `shouldBe` 2/3 -- 2/(2+1)
+ CM.f1Score c `shouldBe` 2/3
+
+ it "AUC: 完全分離で 1.0、ランダムスコアで ~0.5" $ do
+ let ys = [0, 0, 0, 1, 1, 1]
+ perfectScores = [0.1, 0.2, 0.3, 0.7, 0.8, 0.9]
+ aucPerfect = CM.auc ys perfectScores
+ aucPerfect `shouldBe` 1.0
+
+ it "logLoss: 自信ある正解で小、自信ある誤りで大" $ do
+ let lossGood = CM.logLoss [1, 0, 1, 0] [0.99, 0.01, 0.99, 0.01]
+ lossBad = CM.logLoss [1, 0, 1, 0] [0.01, 0.99, 0.01, 0.99]
+ lossGood `shouldSatisfy` (< 0.05)
+ lossBad `shouldSatisfy` (> 4.0)
+
+ it "brierScore: 完全予測で 0、最悪予測で 1" $ do
+ let bsGood = CM.brierScore [1, 0, 1, 0] [1.0, 0.0, 1.0, 0.0]
+ bsBad = CM.brierScore [1, 0, 1, 0] [0.0, 1.0, 0.0, 1.0]
+ bsGood `shouldSatisfy` (< 1e-10)
+ bsBad `shouldBe` 1.0
+
+ it "MCC: 完全一致で 1、ランダムで 0 付近" $ do
+ let cGood = CM.confusionMatrix [1, 0, 1, 0, 1] [1, 0, 1, 0, 1]
+ CM.matthewsCorr cGood `shouldBe` 1.0
+
+ it "macroF1 (multi-class): 完全分類で 1.0" $ do
+ let cm = CM.confusionMulti [0, 1, 2, 0, 1, 2] [0, 1, 2, 0, 1, 2]
+ CM.accuracyMulti cm `shouldBe` 1.0
+ CM.macroF1 cm `shouldBe` 1.0
+
+ -- ===========================================================================
+ -- Hanalyze.Stat.CV (Phase 4)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Stat/CorrelationNetworkSpec.hs b/test/Hanalyze/Stat/CorrelationNetworkSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/CorrelationNetworkSpec.hs
@@ -0,0 +1,89 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.CorrelationNetworkSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Data.Vector.Storable as VS
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Stat.CorrelationNetwork as CN
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.CorrelationNetwork (Phase 32-A1 Graphical Lasso)" $ do
+ -- 真の precision matrix:
+ -- Θ = [[ 2.0, -0.8, 0.0, 0.0],
+ -- [-0.8, 2.0, -0.6, 0.0],
+ -- [ 0.0, -0.6, 2.0, 0.0],
+ -- [ 0.0, 0.0, 0.0, 2.0]]
+ -- → 非零 off-diag: (0,1), (1,2)。 (0,2), (0,3), (1,3), (2,3) はゼロ
+ -- Σ = Θ⁻¹ を計算してから X ~ N(0, Σ) をサンプリング
+ it "graphicalLasso: sparse 構造を回復 (中 λ で 0 を維持 + non-zero 検出)" $ do
+ gen <- MWC.create
+ let theta = LA.fromLists
+ [ [ 2.0, -0.8, 0.0, 0.0]
+ , [-0.8, 2.0, -0.6, 0.0]
+ , [ 0.0, -0.6, 2.0, 0.0]
+ , [ 0.0, 0.0, 0.0, 2.0] ]
+ sigma = LA.inv theta
+ -- Cholesky 因子から N(0, Σ) サンプル
+ chol = LA.chol (LA.trustSym sigma)
+ nGL = 500
+ pGL = 4
+ zs <- VS.replicateM (nGL * pGL) (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let zMat = LA.reshape pGL (LA.fromList (VS.toList zs))
+ xMat = zMat LA.<> chol -- N(0, chol^T chol) = N(0, Σ)
+ fit = CN.graphicalLasso xMat 0.05 100 1e-4
+ thetaHat = CN.glPrecision fit
+ -- 真の非零位置 (0,1), (1,2) を検出
+ abs (LA.atIndex thetaHat (0, 1)) `shouldSatisfy` (> 0.1)
+ abs (LA.atIndex thetaHat (1, 2)) `shouldSatisfy` (> 0.1)
+ -- 真のゼロ位置は十分小さい
+ abs (LA.atIndex thetaHat (0, 3)) `shouldSatisfy` (< 0.15)
+ abs (LA.atIndex thetaHat (2, 3)) `shouldSatisfy` (< 0.15)
+ CN.glConverged fit `shouldBe` True
+ it "graphicalLasso: λ=0 に近いとほぼ S⁻¹、 λ 大で対角優位 (連続性)" $ do
+ gen <- MWC.create
+ let nGL = 200
+ pGL = 3
+ zs <- VS.replicateM (nGL * pGL) (do
+ u1 <- MWC.uniformR (1e-9, 1.0 :: Double) gen
+ u2 <- MWC.uniformR (0.0, 1.0 :: Double) gen
+ pure (sqrt (-2 * log u1) * cos (2 * pi * u2)))
+ let x = LA.reshape pGL (LA.fromList (VS.toList zs))
+ fitBig = CN.graphicalLasso x 5.0 100 1e-4
+ thetaBig = CN.glPrecision fitBig
+ -- 大 λ: off-diag がほぼ 0 に潰される
+ CN.nonZeroPrecision 0.05 thetaBig `shouldBe` 0
+ it "empiricalCov: 中央化後の (1/(n-1)) X^T X" $ do
+ let x = LA.fromLists [[1, 2], [2, 4], [3, 6], [4, 8]]
+ s = CN.empiricalCov x
+ -- 共分散: var(col1) = var([1,2,3,4]) = 5/3 ≈ 1.6667
+ -- var(col2) = 4·var(col1) = 6.6667
+ -- cov(col1, col2) = 2·var(col1) = 3.3333
+ abs (LA.atIndex s (0, 0) - 5/3) `shouldSatisfy` (< 1e-9)
+ abs (LA.atIndex s (1, 1) - 20/3) `shouldSatisfy` (< 1e-9)
+ abs (LA.atIndex s (0, 1) - 10/3) `shouldSatisfy` (< 1e-9)
diff --git a/test/Hanalyze/Stat/DescriptiveSpec.hs b/test/Hanalyze/Stat/DescriptiveSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/DescriptiveSpec.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | 'Hanalyze.Stat.Descriptive' のテスト。
+-- R の @mean@/@median@/@var@/@sd@/@IQR@/@quantile(type=7)@ と数値一致を確認する
+-- (Phase 65)。 参照値は R 4.x で算出。
+module Hanalyze.Stat.DescriptiveSpec (spec) where
+
+import Test.Hspec
+import qualified Data.Vector.Storable as VS
+import qualified Hanalyze.Stat.Descriptive as D
+
+-- 近似一致
+near :: Double -> Double -> Bool
+near a b = abs (a - b) < 1e-9
+
+spec :: Spec
+spec = describe "Hanalyze.Stat.Descriptive" $ do
+ -- x <- c(1,2,3,5,7,11,13); R: mean=6, median=5, var=22.66667, sd=4.760953, IQR=7
+ let x = VS.fromList [1,2,3,5,7,11,13] :: VS.Vector Double
+ xl = [1,2,3,5,7,11,13] :: [Double]
+
+ describe "中心" $ do
+ it "mean" $ D.mean x `shouldSatisfy` near 6
+ it "median (奇数長)" $ D.median x `shouldSatisfy` near 5
+ it "median (偶数長 = 中央 2 点平均)" $
+ D.median (VS.fromList [1,2,3,4] :: VS.Vector Double) `shouldSatisfy` near 2.5
+
+ describe "散布 (R var/sd = n-1)" $ do
+ -- R: var(x) = 21 (= 126/6・偏差平方和 126), sd = 4.582576
+ it "variance (不偏・n-1)" $ D.variance x `shouldSatisfy` near 21
+ it "sd" $ D.sd x `shouldSatisfy` near (sqrt 21)
+ it "range'" $ D.range' x `shouldSatisfy` near 12
+
+ describe "分位点 (R type-7)" $ do
+ -- R quantile(x, c(0,.25,.5,.75,.95,1), type=7):
+ -- 0% 1 / 25% 2.5 / 50% 5 / 75% 9 / 95% 12.4 / 100% 13
+ it "p=0 → 最小" $ D.quantile 0 x `shouldSatisfy` near 1
+ it "p=.25 → 2.5" $ D.quantile 0.25 x `shouldSatisfy` near 2.5
+ it "p=.5 → median" $ D.quantile 0.5 x `shouldSatisfy` near 5
+ it "p=.75 → 9" $ D.quantile 0.75 x `shouldSatisfy` near 9
+ it "p=.95 → 12.4" $ D.quantile 0.95 x `shouldSatisfy` near 12.4
+ it "p=1 → 最大" $ D.quantile 1 x `shouldSatisfy` near 13
+ it "IQR = q75 - q25 = 6.5" $ D.iqr x `shouldSatisfy` near 6.5
+ it "percentile 95 = quantile 0.95" $
+ D.percentile 95 x `shouldSatisfy` near (D.quantile 0.95 x)
+
+ describe "[Double] wrapper" $ do
+ it "meanL ≡ mean" $ D.meanL xl `shouldSatisfy` near (D.mean x)
+ it "quantileL ≡ quantile" $ D.quantileL 0.95 xl `shouldSatisfy` near 12.4
+
+ describe "空・単一要素" $ do
+ let e = VS.empty :: VS.Vector Double
+ it "mean 空 = NaN" $ isNaN (D.mean e) `shouldBe` True
+ it "variance 単一 = NaN" $ isNaN (D.variance (VS.fromList [3])) `shouldBe` True
+ it "quantile 単一 = その値" $ D.quantile 0.7 (VS.fromList [42]) `shouldSatisfy` near 42
diff --git a/test/Hanalyze/Stat/EffectSpec.hs b/test/Hanalyze/Stat/EffectSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/EffectSpec.hs
@@ -0,0 +1,95 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.EffectSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.Effect as Eff
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Effect" $ do
+ it "cohenD: 同じ分布で 0、平均差 1 SD で ~1" $ do
+ let xs = LA.fromList [1, 2, 3, 4, 5] :: LA.Vector Double
+ ys = LA.fromList [1, 2, 3, 4, 5] :: LA.Vector Double
+ Eff.cohenD xs ys `shouldBe` 0.0
+
+ let zs = LA.fromList [2, 3, 4, 5, 6] :: LA.Vector Double -- shifted
+ d2 = Eff.cohenD zs xs
+ d2 `shouldSatisfy` (> 0.5)
+
+ it "hedgesG ≤ |cohenD| (small-sample correction)" $ do
+ let xs = LA.fromList [1, 2, 3, 4, 5] :: LA.Vector Double
+ ys = LA.fromList [3, 4, 5, 6, 7] :: LA.Vector Double
+ d = Eff.cohenD xs ys
+ g = Eff.hedgesG xs ys
+ abs g `shouldSatisfy` (<= abs d + 1e-9)
+
+ it "eta2: 完全分離で大、同分布で 0" $ do
+ let g1 = LA.fromList [1, 2, 3] :: LA.Vector Double
+ g2 = LA.fromList [10, 11, 12] :: LA.Vector Double
+ g3 = LA.fromList [20, 21, 22] :: LA.Vector Double
+ Eff.eta2 [g1, g2, g3] `shouldSatisfy` (> 0.9)
+
+ it "powerTTest: d = 0 で α 付近 (= ~0.05)" $ do
+ let p = Eff.powerTTest 30 0.05 0.0
+ p `shouldSatisfy` (\x -> abs (x - 0.05) < 0.01)
+
+ it "powerTTest: 大きい d で高い power" $ do
+ let p = Eff.powerTTest 30 0.05 0.8
+ p `shouldSatisfy` (> 0.85)
+
+ it "sampleSizeTTest: 小 d ほど大 n が必要" $ do
+ let n1 = Eff.sampleSizeTTest 0.80 0.05 0.2 -- small effect
+ n2 = Eff.sampleSizeTTest 0.80 0.05 0.5 -- medium
+ n3 = Eff.sampleSizeTTest 0.80 0.05 0.8 -- large
+ n1 `shouldSatisfy` (> n2)
+ n2 `shouldSatisfy` (> n3)
+
+ it "cramerV: 2×2 完全独立で ~0、強従属で大" $ do
+ Eff.cramerV 0 100 2 2 `shouldBe` 0.0
+ Eff.cramerV 50 100 2 2 `shouldSatisfy` (> 0.5)
+
+ -- ===========================================================================
+ -- Hanalyze.Model.DecisionTree (Phase 10)
+ -- ===========================================================================
+
+ describe "Hanalyze.Stat.Effect CI (Phase 13.2)" $ do
+ it "cohenDCI: 大効果 d ≈ 2 で CI が 0 を含まない" $ do
+ let xs = LA.fromList [0, 0.1, -0.1, 0.2, -0.2, 0.05, -0.05, 0.15, -0.15, 0.0]
+ ys = LA.fromList [2, 2.1, 1.9, 2.2, 1.8, 2.05, 1.95, 2.15, 1.85, 2.0]
+ (d, (lo, hi)) = Eff.cohenDCI xs ys 0.05
+ d `shouldSatisfy` (< 0)
+ hi `shouldSatisfy` (< 0)
+ lo `shouldSatisfy` (< hi)
+ it "cohenDCI: 同分布で CI が 0 を含む" $ do
+ let xs = LA.fromList [1, 2, 3, 2, 1, 2, 3, 2, 1, 2]
+ ys = LA.fromList [1.1, 2.1, 2.9, 2.05, 1.05, 1.95, 3.05, 2.1, 0.95, 2.0]
+ (_, (lo, hi)) = Eff.cohenDCI xs ys 0.05
+ lo `shouldSatisfy` (< 0)
+ hi `shouldSatisfy` (> 0)
+ it "eta2CI: 大 F で点推定が 0 より十分大きい" $ do
+ let (eta, _) = Eff.eta2CI 50.0 (2, 27) 0.05
+ eta `shouldSatisfy` (> 0.5)
+ it "eta2CI: 小 F で CI 下端が 0 に近い" $ do
+ let (_, (lo, _)) = Eff.eta2CI 0.1 (2, 27) 0.05
+ lo `shouldSatisfy` (< 0.01)
diff --git a/test/Hanalyze/Stat/GroupComparisonSpec.hs b/test/Hanalyze/Stat/GroupComparisonSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/GroupComparisonSpec.hs
@@ -0,0 +1,94 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.GroupComparisonSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Hanalyze.Stat.GroupComparison as GC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.GroupComparison.goodVsBad (Phase 4.2)" $ do
+ it "sanity: 空変数 / 空ラベル / 長さ mismatch は Left" $ do
+ case GC.goodVsBad [] (V.fromList [True, False]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for empty vars"
+ case GC.goodVsBad [("a", V.fromList [1.0, 2.0])] V.empty of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for empty labels"
+ case GC.goodVsBad
+ [("a", V.fromList [1.0, 2.0, 3.0])]
+ (V.fromList [True, False]) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for length mismatch"
+
+ it "sanity: 群サイズ < 2 は Left" $
+ case GC.goodVsBad
+ [("a", V.fromList [1.0, 2.0, 3.0])]
+ (V.fromList [True, False, False]) of -- nG=1
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for nG<2"
+
+ it "差が無いデータでは effect ≈ 0、 p-value 高い" $ do
+ let labels = V.fromList (concat (replicate 5 [True, False]))
+ -- 両群同じ分布 (微小ばらつきあり)
+ vals = V.fromList [1.0, 1.1, 0.9, 1.0, 1.1, 1.0, 1.0, 0.9, 1.1, 1.0]
+ case GC.goodVsBad [("x", vals)] labels of
+ Left e -> expectationFailure (T.unpack e)
+ Right [r] -> do
+ abs (GC.gcrEffect r) `shouldSatisfy` (< 1.0) -- 小さい effect
+ GC.gcrPValue r `shouldSatisfy` (> 0.1) -- 有意ではない
+ Right _ -> expectationFailure "expected single result"
+
+ it "大きな差のデータでは |effect| が大きい、 p-value 小さい" $ do
+ let labels = V.fromList (replicate 10 True ++ replicate 10 False)
+ vals = V.fromList ([1, 1, 2, 2, 1, 1, 2, 2, 1, 2]
+ ++ [10, 11, 12, 10, 11, 12, 10, 11, 12, 11])
+ case GC.goodVsBad [("x", vals)] labels of
+ Left e -> expectationFailure (T.unpack e)
+ Right [r] -> do
+ abs (GC.gcrEffect r) `shouldSatisfy` (> 3.0) -- huge effect
+ GC.gcrPValue r `shouldSatisfy` (< 1e-6)
+ GC.gcrMeanG r `shouldSatisfy` (\v -> v < 2.0)
+ GC.gcrMeanB r `shouldSatisfy` (\v -> v > 9.0)
+ GC.gcrNG r `shouldBe` 10
+ GC.gcrNB r `shouldBe` 10
+ Right _ -> expectationFailure "expected single result"
+
+ it "複数変数の場合、 効果量絶対値降順でソート" $ do
+ let labels = V.fromList (replicate 10 True ++ replicate 10 False)
+ -- v1: large diff (Good ≈ 1、 Bad ≈ 10)
+ v1 = V.fromList ([1, 1.1, 0.9, 1, 1.1, 1, 0.9, 1, 1.1, 1]
+ ++ [10, 10.1, 9.9, 10, 10.1, 10, 9.9, 10, 10.1, 10])
+ -- v2: medium diff (Good ≈ 1、 Bad ≈ 3)
+ v2 = V.fromList ([1, 1.1, 0.9, 1, 1.1, 1, 0.9, 1, 1.1, 1]
+ ++ [3, 3.1, 2.9, 3, 3.1, 3, 2.9, 3, 3.1, 3])
+ -- v3: no diff (両群同じ分布)
+ v3 = V.fromList ([1, 1.1, 0.9, 1, 1.1, 1, 0.9, 1, 1.1, 1]
+ ++ [1, 1.1, 0.9, 1, 1.1, 1, 0.9, 1, 1.1, 1])
+ case GC.goodVsBad [("v3", v3), ("v1", v1), ("v2", v2)] labels of
+ Left e -> expectationFailure (T.unpack e)
+ Right rs -> do
+ length rs `shouldBe` 3
+ -- 並び順は v1 → v2 → v3
+ map GC.gcrVarName rs `shouldBe` ["v1", "v2", "v3"]
diff --git a/test/Hanalyze/Stat/InterpolateSpec.hs b/test/Hanalyze/Stat/InterpolateSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/InterpolateSpec.hs
@@ -0,0 +1,54 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.InterpolateSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Stat.Interpolate as Interp
+import qualified Hanalyze.Stat.Interpret as Interp
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Interpolate" $ do
+ let pts = [(0,0), (1,1), (2,4), (3,9), (4,16)] -- y = x^2
+ it "Linear: 観測点で原値を厳密に再現" $ do
+ let f = Interp.interp1d Interp.Linear pts
+ mapM_ (\(x, y) -> abs (f x - y) `shouldSatisfy` (< 1e-12)) pts
+
+ it "NaturalSpline: 観測点で原値を厳密に再現、中間点で線形より精度高い" $ do
+ let fl = Interp.interp1d Interp.Linear pts
+ fs = Interp.interp1d Interp.NaturalSpline pts
+ true x = x * x
+ xMid = 1.5
+ errL = abs (fl xMid - true xMid)
+ errS = abs (fs xMid - true xMid)
+ mapM_ (\(x, y) -> abs (fs x - y) `shouldSatisfy` (< 1e-9)) pts
+ errS `shouldSatisfy` (< errL)
+
+ it "PCHIP: 単調データ ([0,1,2,4,8,16]) で出力も単調" $ do
+ let mp = [(0,0), (1,1), (2,2), (3,4), (4,8), (5,16)]
+ fp = Interp.interp1d Interp.PCHIP mp
+ ys = map fp [0, 0.1 .. 5]
+ and (zipWith (<=) ys (tail ys)) `shouldBe` True
+
+ it "PCHIP: 観測点で原値を厳密に再現" $ do
+ let fp = Interp.interp1d Interp.PCHIP pts
+ mapM_ (\(x, y) -> abs (fp x - y) `shouldSatisfy` (< 1e-9)) pts
diff --git a/test/Hanalyze/Stat/InterpretSpec.hs b/test/Hanalyze/Stat/InterpretSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/InterpretSpec.hs
@@ -0,0 +1,69 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.InterpretSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Stat.Interpolate as Interp
+import qualified Hanalyze.Stat.Interpret as Interp
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Interpret" $ do
+ it "permutationImportance: 重要 feature が高 importance" $ do
+ gen <- MWC.createSystemRandom
+ -- y = x_0 のみに依存、x_1 は無関係
+ let xs = [[fromIntegral i, fromIntegral (i * i)]
+ | i <- [1 .. 20 :: Int]]
+ ys = [head row | row <- xs]
+ predict zs = [head row | row <- zs]
+ score yt yp =
+ let mse = sum [(yt !! i - yp !! i) ^ (2 :: Int)
+ | i <- [0 .. length yt - 1]]
+ in negate mse -- higher (= 0) is better
+ cfg = (Interp.defaultPermutationConfig)
+ { Interp.pcNRepeats = 5 }
+ r <- Interp.permutationImportance cfg predict score xs ys gen
+ let imps = Interp.piMeanImportance r
+ -- 0番目 feature の importance が高いはず (重要)
+ head imps `shouldSatisfy` (> 0.5 * (imps !! 1))
+
+ it "partialDependence: y = x[0] で PDP が grid に追従" $ do
+ let xs = [[fromIntegral i, 0.0] | i <- [1..10::Int]]
+ predict zs = [head row | row <- zs]
+ grid = [1.0, 5.0, 10.0]
+ pdp = Interp.partialDependence predict xs 0 grid
+ -- 各 grid 点での PD は値そのもの (= grid 値)
+ Interp.pdpMeanPredict pdp `shouldBe` grid
+
+ it "icePlot: 全 sample について curve を返す" $ do
+ let xs = [[1.0, 2.0], [3.0, 4.0], [5.0, 6.0]]
+ predict zs = [sum row | row <- zs]
+ grid = [0.0, 1.0, 2.0]
+ ice = Interp.icePlot predict xs 0 grid
+ length (Interp.iceCurves ice) `shouldBe` 3
+ length (Interp.iceFeatureValues ice) `shouldBe` 3
+ -- iceMean should equal partial dependence
+ length (Interp.iceMean ice) `shouldBe` 3
+
+ -- ─────────────────────────────────────────────────────────────────────
diff --git a/test/Hanalyze/Stat/KernelDistSpec.hs b/test/Hanalyze/Stat/KernelDistSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/KernelDistSpec.hs
@@ -0,0 +1,59 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.KernelDistSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.KernelDist as KD
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.KernelDist" $ do
+ let xs = LA.fromLists [[0, 0], [3, 4], [1, 1]] :: LA.Matrix Double
+ d = KD.pairwiseSqDist xs
+ -- naive reference
+ naive m =
+ let rows = LA.toRows m
+ n = length rows
+ in (n LA.>< n)
+ [ let r = rows !! i - rows !! j in r `LA.dot` r
+ | i <- [0 .. n - 1], j <- [0 .. n - 1] ]
+ ref = naive xs
+
+ it "returns an n x n matrix with zero diagonal" $ do
+ LA.rows d `shouldBe` 3
+ LA.cols d `shouldBe` 3
+ LA.toList (LA.takeDiag d) `shouldBe` [0, 0, 0]
+
+ it "matches the naive reference within 1e-9" $
+ LA.norm_Inf (d - ref) < 1e-9 `shouldBe` True
+
+ it "pairwiseSqDistXY matches reference for cross-matrix" $ do
+ let ys = LA.fromLists [[0, 0], [1, 0]] :: LA.Matrix Double
+ dXY = KD.pairwiseSqDistXY xs ys
+ rxs = LA.toRows xs
+ rys = LA.toRows ys
+ ref' = (LA.rows xs LA.>< LA.rows ys)
+ [ let r = rxs !! i - rys !! j in r `LA.dot` r
+ | i <- [0 .. LA.rows xs - 1]
+ , j <- [0 .. LA.rows ys - 1] ]
+ LA.norm_Inf (dXY - ref') < 1e-9 `shouldBe` True
diff --git a/test/Hanalyze/Stat/MCMCSpec.hs b/test/Hanalyze/Stat/MCMCSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/MCMCSpec.hs
@@ -0,0 +1,68 @@
+-- | Hanalyze.Stat.MCMC の spec (Phase 92 B4: essBulk の arviz 互換性)。
+--
+-- golden 値は arviz (pymc312 venv・2026-07-17) の @az.ess(method="bulk")@ で
+-- 採取した。テストデータは整数 LCG + AR(1) フィルタで生成する —
+-- 整数演算 + IEEE の積和のみなので Python 側と **bit 一致** し、rank が
+-- 言語間で入れ替わらないことを保証できる (sin 等の libm 依存を避ける)。
+-- 再採取手順は本 spec 末尾のコメント参照。
+module Hanalyze.Stat.MCMCSpec (spec) where
+
+import Test.Hspec
+
+import Hanalyze.Stat.MCMC (ess, essBulk)
+
+-- | glibc 系数の LCG (mod 2^31)・[-0.5, 0.5) 一様。Integer 演算なので厳密。
+lcg :: Int -> Int -> [Double]
+lcg seed n = take n (map toU (drop 1 (iterate step (fromIntegral seed))))
+ where
+ step x = (1103515245 * x + 12345) `mod` (2 ^ (31 :: Int)) :: Integer
+ toU x = fromIntegral x / 2 ^ (31 :: Int) - 0.5
+
+-- | AR(1): y_i = phi*y_{i-1} + u_i (y_0 起点 0)。積和 2 op のみで言語間 bit 一致。
+ar1 :: Int -> Int -> Double -> [Double]
+ar1 seed n phi = drop 1 (scanl (\prev u -> phi * prev + u) 0 (lcg seed n))
+
+relClose :: Double -> Double -> Double -> Bool
+relClose tol expected actual = abs (actual - expected) <= tol * abs expected
+
+spec :: Spec
+spec = do
+ describe "essBulk (arviz az.ess(method=\"bulk\") 互換)" $ do
+ it "4 chain x 300 (AR(1) phi=0.9) で arviz golden に一致" $ do
+ let chains = [ ar1 (c + 1) 300 0.9 | c <- [0 .. 3] ]
+ essBulk chains `shouldSatisfy` relClose 1e-6 84.42798772749184
+
+ it "2 chain x 100 (AR(1) phi=0.3) で arviz golden に一致" $ do
+ let chains = [ ar1 (c + 10) 100 0.3 | c <- [0 .. 1] ]
+ essBulk chains `shouldSatisfy` relClose 1e-6 94.75370782074775
+
+ it "奇数長 3 chain x 101 (split の中央落ち) で arviz golden に一致" $ do
+ let chains = [ ar1 (c + 5) 101 0.5 | c <- [0 .. 2] ]
+ essBulk chains `shouldSatisfy` relClose 1e-6 126.38779986541799
+
+ it "定数 chain (分散 0) は総 draw 数へフォールバック" $
+ essBulk [replicate 50 1.0, replicate 50 1.0] `shouldBe` 100
+
+ it "短すぎる chain (split 後 4 draw 未満) は元の総 draw 数を返す" $
+ essBulk [[1, 2, 3]] `shouldBe` 3
+
+ it "独立標本 (iid 一様 4 chain x 500) で arviz golden に一致" $ do
+ -- 独立標本では総 draw 数 2000 を多少超える (arviz と同挙動)
+ let chains = [ lcg (c + 100) 500 | c <- [0 .. 3] ]
+ essBulk chains `shouldSatisfy` relClose 1e-6 2190.946800658338
+
+ describe "ess (既存・単 chain Geyer IMSE)" $
+ it "essBulk 導入後も従来挙動 (tau 下限 1 で n 頭打ち) を維持" $ do
+ let xs = lcg 7 200
+ ess xs `shouldSatisfy` (<= 200.000001)
+
+-- golden 再採取 (pymc312 venv):
+-- def lcg(seed,n):
+-- x=seed; out=[]
+-- for _ in range(n): x=(1103515245*x+12345)%(2**31); out.append(x/2**31-0.5)
+-- return out
+-- def ar1(seed,n,phi):
+-- u=lcg(seed,n); p=0.0; y=[]
+-- for ui in u: p=phi*p+ui; y.append(p)
+-- return y
+-- az.ess(az.convert_to_dataset({"x": np.array([ar1(c+1,300,0.9) for c in range(4)])}), method="bulk")
diff --git a/test/Hanalyze/Stat/MDSSpec.hs b/test/Hanalyze/Stat/MDSSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/MDSSpec.hs
@@ -0,0 +1,55 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.MDSSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.MDS as MDS
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.MDS (Phase 34-A3)" $ do
+ -- 2-D 配列 → 距離行列 → 2-D 再構成で距離保存を確認
+ let pts2d = LA.fromLists [[0, 0], [1, 0], [0, 1], [1, 1], [2, 0.5]]
+ d = MDS.euclideanDist pts2d
+ it "mdsClassical: 2-D データを 2-D 復元すると距離が保たれる" $ do
+ let emb = MDS.mdsClassical d 2
+ d2 = MDS.euclideanDist emb
+ err = LA.maxElement (LA.cmap abs (d - d2))
+ err `shouldSatisfy` (< 1e-8)
+ it "mdsClassical: 出力 shape は (n × k)" $ do
+ let emb = MDS.mdsClassical d 2
+ LA.rows emb `shouldBe` 5
+ LA.cols emb `shouldBe` 2
+ it "euclideanDist: 対角は 0、 対称" $ do
+ let n = 5
+ and [ abs (LA.atIndex d (i, i)) < 1e-10 | i <- [0 .. n - 1] ]
+ `shouldBe` True
+ and [ abs (LA.atIndex d (i, j) - LA.atIndex d (j, i)) < 1e-10
+ | i <- [0 .. n - 1], j <- [0 .. n - 1] ]
+ `shouldBe` True
+ it "mdsSammon: stress が古典 MDS より同等以下" $ do
+ let embC = MDS.mdsClassical d 2
+ embS = MDS.mdsSammon MDS.defaultSammonConfig d 2
+ sC = MDS.sammonStress d embC
+ sS = MDS.sammonStress d embS
+ sS `shouldSatisfy` (<= sC + 1e-8)
diff --git a/test/Hanalyze/Stat/MultipleTestingSpec.hs b/test/Hanalyze/Stat/MultipleTestingSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/MultipleTestingSpec.hs
@@ -0,0 +1,58 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.MultipleTestingSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Stat.MultipleTesting as MT
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.MultipleTesting" $ do
+ it "Bonferroni: p × m, capped at 1" $ do
+ let ps = [0.01, 0.04, 0.05, 0.10]
+ adj = MT.bonferroni ps
+ adj `shouldBe` [0.04, 0.16, 0.20, 0.40]
+
+ it "Holm: 単調 + Bonferroni より緩い" $ do
+ let ps = [0.01, 0.02, 0.03, 0.04]
+ adj = MT.holm ps
+ -- 各 adj ≥ 元 p、最初は p × m = 0.04
+ head adj `shouldBe` 0.04
+ and (zipWith (<=) ps adj) `shouldBe` True
+
+ it "BH: monotonic non-decreasing in sorted p order" $ do
+ let ps = [0.01, 0.04, 0.03, 0.05]
+ adj = MT.benjaminiHochberg ps
+ length adj `shouldBe` 4
+ all (<= 1.0) adj `shouldBe` True
+ all (>= 0.0) adj `shouldBe` True
+
+ it "BY: BH より conservative" $ do
+ let ps = [0.01, 0.02, 0.03, 0.04, 0.05]
+ bh = MT.benjaminiHochberg ps
+ by = MT.benjaminiYekutieli ps
+ -- BY は cumulative harmonic factor を掛けるので大きい
+ and (zipWith (>=) by bh) `shouldBe` True
+
+ -- ===========================================================================
+ -- Hanalyze.Stat.Bootstrap (Phase 7)
+ -- ===========================================================================
diff --git a/test/Hanalyze/Stat/NumberFormatSpec.hs b/test/Hanalyze/Stat/NumberFormatSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/NumberFormatSpec.hs
@@ -0,0 +1,47 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.NumberFormatSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Stat.NumberFormat as NF
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.NumberFormat" $ do
+ it "0 → '0.00'" $ NF.fmtNum 0 `shouldBe` "0.00"
+ it "中域 (0.01..999) は固定小数点 2 桁" $ do
+ NF.fmtNum 0.91 `shouldBe` "0.91"
+ NF.fmtNum 12.34 `shouldBe` "12.34"
+ NF.fmtNum 998.7 `shouldBe` "998.70"
+ it "巨大値は指数表記" $ do
+ NF.fmtNum 1.10e13 `shouldBe` "1.10E+13"
+ NF.fmtNum 1234.5 `shouldBe` "1.23E+3"
+ it "極小値は指数表記" $ do
+ NF.fmtNum 3.057e-24 `shouldBe` "3.06E-24"
+ NF.fmtNum 0.0099 `shouldBe` "9.90E-3"
+ it "負の値" $ do
+ NF.fmtNum (-12.34) `shouldBe` "-12.34"
+ NF.fmtNum (-1.5e10) `shouldBe` "-1.50E+10"
+ it "非有限値" $ do
+ NF.fmtNum (0/0) `shouldBe` "NaN"
+ NF.fmtNum (1/0) `shouldBe` "+Inf"
+ NF.fmtNum (-1/0) `shouldBe` "-Inf"
diff --git a/test/Hanalyze/Stat/QuasiRandomSpec.hs b/test/Hanalyze/Stat/QuasiRandomSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/QuasiRandomSpec.hs
@@ -0,0 +1,71 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.QuasiRandomSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Stat.QuasiRandom as QR
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.QuasiRandom (Halton)" $ do
+ it "haltonSequence 10 1 lies in [0, 1) and is a permutation" $ do
+ let pts = QR.haltonSequence 10 1
+ length pts `shouldBe` 10
+ all (\[u] -> u >= 0 && u < 1) pts `shouldBe` True
+
+ it "haltonSequence 16 2 covers a 4x4 grid better than random" $ do
+ -- For n = 16, d = 2 the Halton points should cover all 16
+ -- 0.25-bins; an iid uniform usually misses some.
+ let pts = QR.haltonSequence 16 2
+ binIdx p = (floor (4 * head p) :: Int,
+ floor (4 * (p !! 1)) :: Int)
+ unique = length (foldr (\b acc -> if b `elem` acc then acc
+ else b : acc) [] (map binIdx pts))
+ unique `shouldSatisfy` (>= 14) -- Halton normally hits ≥ 14 / 16
+
+ it "haltonSequenceIn rescales into the supplied bounds" $ do
+ let bs = [(-2, 2), (10, 20)] :: [(Double, Double)]
+ pts = QR.haltonSequenceIn 5 bs
+ all (\[a, b] -> a >= -2 && a < 2
+ && b >= 10 && b < 20) pts `shouldBe` True
+
+ it "lhsSamples 10 3 lies in [0,1)^3 and fills every per-dim cell" $ do
+ gen <- MWC.createSystemRandom
+ pts <- QR.lhsSamples 10 3 gen
+ length pts `shouldBe` 10
+ all (\xs -> all (\u -> u >= 0 && u < 1) xs) pts `shouldBe` True
+ -- For each dim, the 10 points should occupy 10 distinct cells
+ -- (= floor(10 * u) is a permutation of [0..9]).
+ let cellsAlong k = map (\xs -> floor (10 * (xs !! k)) :: Int) pts
+ ok k = sort (cellsAlong k) == [0 .. 9]
+ ok 0 `shouldBe` True
+ ok 1 `shouldBe` True
+ ok 2 `shouldBe` True
+
+ it "lhsSamplesIn rescales into bounds" $ do
+ gen <- MWC.createSystemRandom
+ let bs = [(-1, 1), (5, 10)] :: [(Double, Double)]
+ pts <- QR.lhsSamplesIn 8 bs gen
+ all (\[a, b] -> a >= -1 && a < 1
+ && b >= 5 && b < 10) pts `shouldBe` True
diff --git a/test/Hanalyze/Stat/SPCSpec.hs b/test/Hanalyze/Stat/SPCSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/SPCSpec.hs
@@ -0,0 +1,485 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.SPCSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Hanalyze.Stat.SPC as SPC
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.SPC X-bar / R chart (Phase 1.2)" $ do
+ -- Montgomery 9th ed. Example 6.1 (Piston Ring): n=5, k=25
+ -- Here we use a small synthetic but consistent set so we can check
+ -- the algebra exactly.
+ let -- 5 subgroups, each of size 4
+ subs :: V.Vector (V.Vector Double)
+ subs = V.fromList $ map V.fromList
+ [ [10.0, 10.4, 10.2, 9.8] -- mean 10.10 range 0.6
+ , [9.9, 10.1, 10.3, 10.0] -- mean 10.075 range 0.4
+ , [10.2, 9.9, 10.0, 10.3] -- mean 10.10 range 0.4
+ , [9.8, 10.0, 10.1, 9.9] -- mean 9.95 range 0.3
+ , [10.1, 10.2, 10.0, 10.4] -- mean 10.175 range 0.4
+ ]
+ -- Hand-computed: X̿ = mean of means; R̄ = mean of ranges
+ expectedXBarBar = (10.10 + 10.075 + 10.10 + 9.95 + 10.175) / 5
+ expectedRBar = (0.6 + 0.4 + 0.4 + 0.3 + 0.4) / 5
+ -- For n=4: A2 = 0.729, D3 = 0, D4 = 2.282, d2 = 2.059
+ a2_4 = 0.729 :: Double
+ d3_4 = 0.000 :: Double
+ d4_4 = 2.282 :: Double
+ d2_4 = 2.059 :: Double
+
+ it "fitSPC XR returns 2 charts (X-bar then R)" $
+ case SPC.fitSPC SPC.XR (SPC.VarSubgroups subs) of
+ Left e -> expectationFailure (T.unpack e)
+ Right xs -> do
+ length xs `shouldBe` 2
+ SPC.spcChartName (xs !! 0) `shouldBe` "X-bar"
+ SPC.spcChartName (xs !! 1) `shouldBe` "R"
+
+ it "X-bar chart の center, UCL, LCL が Montgomery 公式と一致" $
+ case SPC.fitSPC SPC.XR (SPC.VarSubgroups subs) of
+ Left e -> expectationFailure (T.unpack e)
+ Right (x:_:_) -> do
+ SPC.spcCenter x `shouldSatisfy` (\v -> abs (v - expectedXBarBar) < 1e-9)
+ let uclX = expectedXBarBar + a2_4 * expectedRBar
+ lclX = expectedXBarBar - a2_4 * expectedRBar
+ V.head (SPC.spcUCL x) `shouldSatisfy` (\v -> abs (v - uclX) < 1e-9)
+ V.head (SPC.spcLCL x) `shouldSatisfy` (\v -> abs (v - lclX) < 1e-9)
+ Right _ -> expectationFailure "expected 2 charts"
+
+ it "R chart の center, UCL, LCL が Montgomery 公式と一致" $
+ case SPC.fitSPC SPC.XR (SPC.VarSubgroups subs) of
+ Left e -> expectationFailure (T.unpack e)
+ Right (_:r:_) -> do
+ SPC.spcCenter r `shouldSatisfy` (\v -> abs (v - expectedRBar) < 1e-9)
+ let uclR = d4_4 * expectedRBar
+ lclR = d3_4 * expectedRBar
+ V.head (SPC.spcUCL r) `shouldSatisfy` (\v -> abs (v - uclR) < 1e-9)
+ V.head (SPC.spcLCL r) `shouldSatisfy` (\v -> abs (v - lclR) < 1e-9)
+ Right _ -> expectationFailure "expected 2 charts"
+
+ it "推定 σ = R̄ / d2(n) (両 chart で同値)" $
+ case SPC.fitSPC SPC.XR (SPC.VarSubgroups subs) of
+ Left e -> expectationFailure (T.unpack e)
+ Right (x:r:_) -> do
+ let expectedSigma = expectedRBar / d2_4
+ SPC.spcSigma x `shouldSatisfy` (\v -> abs (v - expectedSigma) < 1e-9)
+ SPC.spcSigma r `shouldBe` SPC.spcSigma x
+ Right _ -> expectationFailure "expected 2 charts"
+
+ it "subgroup size が不揃いだと Left" $
+ case SPC.fitSPC SPC.XR (SPC.VarSubgroups (V.fromList
+ [ V.fromList [1, 2, 3]
+ , V.fromList [4, 5] -- size mismatch
+ ])) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for mismatched subgroup sizes"
+
+ it "subgroup size が 範囲外 (1 or >15) だと Left" $ do
+ case SPC.fitSPC SPC.XR (SPC.VarSubgroups (V.fromList
+ [ V.fromList [1]
+ , V.fromList [2]
+ ])) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for n=1"
+ case SPC.fitSPC SPC.XR (SPC.VarSubgroups (V.fromList
+ [ V.fromList (replicate 16 1)
+ , V.fromList (replicate 16 2)
+ ])) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for n=16"
+
+ it "chart kind と入力の不一致は Left" $
+ case SPC.fitSPC SPC.XR (SPC.VarIndividual (V.fromList [1, 2, 3])) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for XR + VarIndividual"
+
+ describe "Hanalyze.Stat.SPC I-MR chart (Phase 1.2)" $ do
+ let xs = V.fromList [10.0, 10.2, 9.8, 10.1, 9.9, 10.3, 10.0, 9.7, 10.2, 10.1]
+ -- moving range:
+ -- |0.2|, |0.4|, |0.3|, |0.2|, |0.4|, |0.3|, |0.3|, |0.5|, |0.1|
+ -- MR̄ = 2.7 / 9 = 0.3
+ -- x̄ = sum(xs)/10 = 100.3 / 10 = 10.03
+ expectedXBar = 10.03
+ expectedMRBar = 0.3
+ -- For n=2: d2 = 1.128, D4 = 3.267, D3 = 0
+ d2_2 = 1.128 :: Double
+ d4_2 = 3.267 :: Double
+ expectedSigma = expectedMRBar / d2_2
+ expectedUCLI = expectedXBar + 3 * expectedSigma
+ expectedLCLI = expectedXBar - 3 * expectedSigma
+ expectedUCLMR = d4_2 * expectedMRBar
+
+ it "fitSPC IMR は I chart と MR chart を返す" $
+ case SPC.fitSPC SPC.IMR (SPC.VarIndividual xs) of
+ Left e -> expectationFailure (T.unpack e)
+ Right [iCh, mr] -> do
+ SPC.spcChartName iCh `shouldBe` "I"
+ SPC.spcChartName mr `shouldBe` "MR"
+ Right _ -> expectationFailure "expected 2 charts"
+
+ it "I chart の CL / UCL / LCL が MR̄/d2(2)·3 公式と一致" $
+ case SPC.fitSPC SPC.IMR (SPC.VarIndividual xs) of
+ Left e -> expectationFailure (T.unpack e)
+ Right (iCh:_) -> do
+ SPC.spcCenter iCh `shouldSatisfy` (\v -> abs (v - expectedXBar) < 1e-9)
+ V.head (SPC.spcUCL iCh) `shouldSatisfy` (\v -> abs (v - expectedUCLI) < 1e-9)
+ V.head (SPC.spcLCL iCh) `shouldSatisfy` (\v -> abs (v - expectedLCLI) < 1e-9)
+ V.length (SPC.spcPoints iCh) `shouldBe` V.length xs
+ Right _ -> expectationFailure "expected at least 1 chart"
+
+ it "MR chart の CL / UCL / LCL" $
+ case SPC.fitSPC SPC.IMR (SPC.VarIndividual xs) of
+ Left e -> expectationFailure (T.unpack e)
+ Right (_:mr:_) -> do
+ SPC.spcCenter mr `shouldSatisfy` (\v -> abs (v - expectedMRBar) < 1e-9)
+ V.head (SPC.spcUCL mr) `shouldSatisfy` (\v -> abs (v - expectedUCLMR) < 1e-9)
+ V.head (SPC.spcLCL mr) `shouldBe` 0
+ V.length (SPC.spcPoints mr) `shouldBe` V.length xs - 1
+ Right _ -> expectationFailure "expected 2 charts"
+
+ it "観測 1 個以下だと Left" $ do
+ case SPC.fitSPC SPC.IMR (SPC.VarIndividual (V.fromList [1.0])) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for n=1"
+ case SPC.fitSPC SPC.IMR (SPC.VarIndividual V.empty) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left for empty"
+
+ describe "Hanalyze.Stat.SPC attribute charts: p / np / c / u (Phase 1.3)" $ do
+
+ --------------------------------------------------------------------- p
+ it "p chart: 一定 n では p̂ = d/n、 p̄ = Σd/Σn、 UCL/LCL は ±3·sqrt(p̄q̄/n)" $ do
+ -- 全 subgroup n=100、 不良数 [5, 6, 4, 7, 3]
+ let ds = V.fromList [5,6,4,7,3]
+ ns = V.fromList [100,100,100,100,100]
+ pBar = (5+6+4+7+3) / 500.0 :: Double -- = 0.05
+ se = sqrt (pBar*(1-pBar)/100)
+ ucl0 = pBar + 3*se
+ lcl0 = max 0 (pBar - 3*se)
+ case SPC.fitSPC SPC.P (SPC.AttrProportion ds ns) of
+ Left e -> expectationFailure (T.unpack e)
+ Right [ch] -> do
+ SPC.spcChartName ch `shouldBe` "p"
+ SPC.spcCenter ch `shouldSatisfy` (\v -> abs (v - pBar) < 1e-12)
+ V.head (SPC.spcUCL ch) `shouldSatisfy` (\v -> abs (v - ucl0) < 1e-12)
+ V.head (SPC.spcLCL ch) `shouldSatisfy` (\v -> abs (v - lcl0) < 1e-12)
+ -- p̂_0 = 5/100 = 0.05
+ V.head (SPC.spcPoints ch) `shouldSatisfy` (\v -> abs (v - 0.05) < 1e-12)
+ Right _ -> expectationFailure "expected single chart"
+
+ it "p chart: 可変 n では UCL_i が point ごとに違う" $
+ case SPC.fitSPC SPC.P
+ (SPC.AttrProportion (V.fromList [5,5,5]) (V.fromList [100,200,400])) of
+ Left e -> expectationFailure (T.unpack e)
+ Right [ch] -> do
+ let ucls = V.toList (SPC.spcUCL ch)
+ -- n が増えるほど UCL は CL に近づく (狭まる)
+ (ucls !! 0) `shouldSatisfy` (> (ucls !! 1))
+ (ucls !! 1) `shouldSatisfy` (> (ucls !! 2))
+ Right _ -> expectationFailure "expected single chart"
+
+ it "p chart: 不良数 > sample size は Left" $
+ case SPC.fitSPC SPC.P
+ (SPC.AttrProportion (V.fromList [10,3]) (V.fromList [5,5])) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+
+ --------------------------------------------------------------------- np
+ it "np chart: CL = n·p̄, σ̂ = sqrt(n·p̄·(1−p̄)), UCL/LCL = ±3σ̂" $ do
+ let ds = V.fromList [5,6,4,7,3]
+ n = 100
+ pBar = 25 / 500.0 :: Double -- = 0.05
+ cl = fromIntegral n * pBar -- = 5.0
+ sigma = sqrt (fromIntegral n * pBar * (1 - pBar))
+ ucl = cl + 3 * sigma
+ lcl = max 0 (cl - 3 * sigma)
+ case SPC.fitSPC SPC.NP (SPC.AttrCount ds n) of
+ Left e -> expectationFailure (T.unpack e)
+ Right [ch] -> do
+ SPC.spcChartName ch `shouldBe` "np"
+ SPC.spcCenter ch `shouldSatisfy` (\v -> abs (v - cl) < 1e-12)
+ V.head (SPC.spcUCL ch) `shouldSatisfy` (\v -> abs (v - ucl) < 1e-12)
+ V.head (SPC.spcLCL ch) `shouldSatisfy` (\v -> abs (v - lcl) < 1e-12)
+ SPC.spcSigma ch `shouldSatisfy` (\v -> abs (v - sigma) < 1e-12)
+ Right _ -> expectationFailure "expected single chart"
+
+ it "np chart: d > n は Left" $
+ case SPC.fitSPC SPC.NP (SPC.AttrCount (V.fromList [3, 11, 2]) 10) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+
+ --------------------------------------------------------------------- c
+ it "c chart: CL = c̄, σ̂ = sqrt(c̄), UCL = c̄ + 3·sqrt(c̄)" $ do
+ let ds = V.fromList [4,5,3,6,2,5,4]
+ cBar = (4+5+3+6+2+5+4) / 7.0 :: Double -- = 29/7 ≈ 4.142857
+ sigma = sqrt cBar
+ ucl = cBar + 3 * sigma
+ case SPC.fitSPC SPC.C (SPC.AttrDefects ds) of
+ Left e -> expectationFailure (T.unpack e)
+ Right [ch] -> do
+ SPC.spcChartName ch `shouldBe` "c"
+ SPC.spcCenter ch `shouldSatisfy` (\v -> abs (v - cBar) < 1e-12)
+ V.head (SPC.spcUCL ch) `shouldSatisfy` (\v -> abs (v - ucl) < 1e-12)
+ SPC.spcSigma ch `shouldSatisfy` (\v -> abs (v - sigma) < 1e-12)
+ Right _ -> expectationFailure "expected single chart"
+
+ it "c chart: c̄ が小さければ LCL = 0 にクリップ" $
+ case SPC.fitSPC SPC.C (SPC.AttrDefects (V.fromList [0,1,0,1,0])) of
+ Left e -> expectationFailure (T.unpack e)
+ Right [ch] -> V.head (SPC.spcLCL ch) `shouldBe` 0
+ Right _ -> expectationFailure "expected single chart"
+
+ --------------------------------------------------------------------- u
+ it "u chart: u_i = d_i/n_i, ū = Σd/Σn, UCL_i 可変" $ do
+ let ds = V.fromList [10, 8, 12, 6]
+ ns = V.fromList [50, 40, 60, 30]
+ uBar = (10+8+12+6) / fromIntegral (50+40+60+30) :: Double -- = 36/180 = 0.2
+ case SPC.fitSPC SPC.U (SPC.AttrDefectRate ds ns) of
+ Left e -> expectationFailure (T.unpack e)
+ Right [ch] -> do
+ SPC.spcChartName ch `shouldBe` "u"
+ SPC.spcCenter ch `shouldSatisfy` (\v -> abs (v - uBar) < 1e-12)
+ -- u_0 = 10/50 = 0.2
+ V.head (SPC.spcPoints ch) `shouldSatisfy` (\v -> abs (v - 0.2) < 1e-12)
+ -- UCL_i が異なる n に対して異なる
+ let ucls = V.toList (SPC.spcUCL ch)
+ length (filter (== head ucls) ucls) `shouldSatisfy` (< length ucls)
+ Right _ -> expectationFailure "expected single chart"
+
+ it "u chart: 系列長 mismatch は Left" $
+ case SPC.fitSPC SPC.U
+ (SPC.AttrDefectRate (V.fromList [1,2,3]) (V.fromList [10,20])) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+
+ describe "Hanalyze.Stat.SPC Western Electric rules (Phase 1.4)" $ do
+ -- 8 rules を持っているか
+ it "westernElectricRules は 8 rules" $
+ length SPC.westernElectricRules `shouldBe` 8
+ it "rule 番号は 1..8" $
+ map SPC.ruleNumber SPC.westernElectricRules `shouldBe` [1..8]
+
+ -- 合成 chart 結果でルール個別検証
+ let mkChart :: [Double] -> SPC.SPCChartResult
+ mkChart pts = SPC.SPCChartResult
+ { SPC.spcPoints = V.fromList pts
+ , SPC.spcCenter = 0
+ , SPC.spcUCL = V.fromList (map (const 3.0) pts)
+ , SPC.spcLCL = V.fromList (map (const (-3.0)) pts)
+ , SPC.spcSigma = 1
+ , SPC.spcChartName = "test"
+ }
+ weRule n = SPC.westernElectricRules !! (n - 1)
+
+ it "Rule 1 (>3σ): 4.0 だけ違反、 2.0 や 0 は違反しない" $
+ SPC.ruleCheck (weRule 1) (mkChart [0, 1, 2.9, 4.0, -3.5, 2.0])
+ `shouldBe` [3, 4]
+
+ it "Rule 2 (3点中2点が同側>2σ): window 末尾で違反 (overlap window 各回検出)" $ do
+ -- [0, +1, +1, 0]: window i=0..2 (2 positive) → index 2、
+ -- window i=1..3 (2 positive) → index 3
+ SPC.ruleCheck (weRule 2) (mkChart [0, 2.5, 2.5, 0])
+ `shouldBe` [2, 3]
+ -- 隔てパターン: window 1..3 のみ hit
+ SPC.ruleCheck (weRule 2) (mkChart [0, 2.5, 0, 2.5])
+ `shouldBe` [3]
+
+ it "Rule 3 (5点中4点が同側>1σ): 1.5,1.5,0,1.5,1.5 で末尾違反" $
+ SPC.ruleCheck (weRule 3) (mkChart [1.5, 1.5, 0, 1.5, 1.5])
+ `shouldBe` [4]
+
+ it "Rule 4 (8点連続同側): 8 連続 +1 → index 7 から違反、 4 連続では無し" $ do
+ SPC.ruleCheck (weRule 4) (mkChart (replicate 8 1.0))
+ `shouldBe` [7]
+ SPC.ruleCheck (weRule 4) (mkChart (replicate 4 1.0))
+ `shouldBe` []
+
+ it "Rule 5 (6点連続単調): 0..5 → index 5 から違反" $
+ SPC.ruleCheck (weRule 5) (mkChart [0,1,2,3,4,5])
+ `shouldBe` [5]
+
+ it "Rule 6 (15点連続 1σ 以内): すべて 0.5 → index 14 以降違反" $
+ take 1 (SPC.ruleCheck (weRule 6) (mkChart (replicate 15 0.5)))
+ `shouldBe` [14]
+
+ it "Rule 7 (8点連続 1σ 外): 1.5,1.5,...,1.5 8 点 → index 7" $
+ SPC.ruleCheck (weRule 7) (mkChart (replicate 8 1.5))
+ `shouldBe` [7]
+
+ it "Rule 8 (14点連続交互): 交互系列で末尾違反" $
+ SPC.ruleCheck (weRule 8)
+ (mkChart [0,1,0,1,0,1,0,1,0,1,0,1,0,1])
+ `shouldBe` [13]
+
+ it "checkRules: 全ルール適用で SPCViolation list を返す" $ do
+ -- 4σ 単発点 + 8 連続正側 → Rule 1 と Rule 4 と (1σ 外連続なので) Rule 7 が hit
+ let ch = mkChart (4.0 : replicate 8 1.5)
+ vs = SPC.checkRules SPC.westernElectricRules ch
+ -- Rule 1 (index 0) は確実に含まれる
+ (1 `elem` map SPC.vRuleNumber vs) `shouldBe` True
+ -- Rule 4 (index 8, 8 連続同側 +1.5) も
+ (4 `elem` map SPC.vRuleNumber vs) `shouldBe` True
+ -- vChartName は元の chart の名前を保持
+ all ((== "test") . SPC.vChartName) vs `shouldBe` True
+
+ it "全 in-control データには違反が出ない" $ do
+ let ch = mkChart [0.1, -0.2, 0.3, -0.1, 0.2, -0.3, 0.1, 0.0, 0.2, -0.2]
+ SPC.checkRules SPC.westernElectricRules ch `shouldBe` []
+
+ describe "Hanalyze.Stat.SPC Nelson rules (Phase 1.5)" $ do
+ let mkChart' :: [Double] -> SPC.SPCChartResult
+ mkChart' pts = SPC.SPCChartResult
+ { SPC.spcPoints = V.fromList pts
+ , SPC.spcCenter = 0
+ , SPC.spcUCL = V.fromList (map (const 3.0) pts)
+ , SPC.spcLCL = V.fromList (map (const (-3.0)) pts)
+ , SPC.spcSigma = 1
+ , SPC.spcChartName = "test"
+ }
+ nelsonRule n = SPC.nelsonRules !! (n - 1)
+
+ it "nelsonRules は 8 rules、 番号 1..8" $ do
+ length SPC.nelsonRules `shouldBe` 8
+ map SPC.ruleNumber SPC.nelsonRules `shouldBe` [1..8]
+
+ it "Rule 1 (>3σ) = WE 1 と同じ検出" $
+ SPC.ruleCheck (nelsonRule 1) (mkChart' [0, 4.0, 2.0, -3.5])
+ `shouldBe` [1, 3]
+
+ it "Rule 2 (9点連続同側): 8 点では未検出、 9 点目で検出" $ do
+ SPC.ruleCheck (nelsonRule 2) (mkChart' (replicate 8 1.0))
+ `shouldBe` []
+ SPC.ruleCheck (nelsonRule 2) (mkChart' (replicate 9 1.0))
+ `shouldBe` [8]
+
+ it "Rule 2 ≠ WE 4 (8 vs 9 連続)" $ do
+ -- 同じデータ (8 点連続同側) で WE 4 は hit、 Nelson 2 は miss
+ let ch = mkChart' (replicate 8 1.0)
+ SPC.ruleCheck (SPC.westernElectricRules !! 3) ch `shouldBe` [7]
+ SPC.ruleCheck (nelsonRule 2) ch `shouldBe` []
+
+ it "Rule 3 (6点連続単調) = WE 5" $
+ SPC.ruleCheck (nelsonRule 3) (mkChart' [0,1,2,3,4,5])
+ `shouldBe` [5]
+
+ it "Rule 4 (14点連続交互) = WE 8" $
+ SPC.ruleCheck (nelsonRule 4)
+ (mkChart' [0,1,0,1,0,1,0,1,0,1,0,1,0,1])
+ `shouldBe` [13]
+
+ it "Rule 5 (3点中2点>2σ同側) = WE 2" $
+ SPC.ruleCheck (nelsonRule 5) (mkChart' [0, 2.5, 0, 2.5])
+ `shouldBe` [3]
+
+ it "Rule 6 (5点中4点>1σ同側) = WE 3" $
+ SPC.ruleCheck (nelsonRule 6) (mkChart' [1.5, 1.5, 0, 1.5, 1.5])
+ `shouldBe` [4]
+
+ it "Rule 7 (15点連続 1σ 以内) = WE 6" $
+ take 1 (SPC.ruleCheck (nelsonRule 7) (mkChart' (replicate 15 0.5)))
+ `shouldBe` [14]
+
+ it "Rule 8 (8点連続 1σ 外) = WE 7" $
+ SPC.ruleCheck (nelsonRule 8) (mkChart' (replicate 8 1.5))
+ `shouldBe` [7]
+
+ it "in-control データに対しては Nelson も violation 0" $ do
+ let ch = mkChart' [0.1, -0.2, 0.3, -0.1, 0.2, -0.3, 0.1, 0.0, 0.2, -0.2]
+ SPC.checkRules SPC.nelsonRules ch `shouldBe` []
+
+ it "checkRules: Nelson rule で違反した点はルール名 \"Nelson N\"" $ do
+ let ch = mkChart' (replicate 9 1.0) -- Rule 2 確実 hit (9 点同側)
+ vs = SPC.checkRules SPC.nelsonRules ch
+ (2 `elem` map SPC.vRuleNumber vs) `shouldBe` True
+ -- 違反 record の名前が "Nelson 2" 含む
+ any (\v -> SPC.vRuleName v == "Nelson 2") vs `shouldBe` True
+
+ describe "Hanalyze.Stat.SPC EWMA / CUSUM (Phase 11)" $ do
+ let inControl = V.fromList [10.1, 9.9, 10.05, 9.95, 10.02, 9.98, 10.0, 10.03, 9.97, 10.01]
+ shifted = V.fromList [10.0, 10.1, 9.9, 10.05, 11.5, 11.6, 11.8, 11.7, 11.9, 12.0]
+ it "EWMA: in-control 系列で λ=0.2 L=3 ですべての点が管理限界内" $
+ case SPC.fitSPC SPC.EWMAChart (SPC.EWMAInput inControl 0.2 3.0 10.0 0.1) of
+ Left e -> expectationFailure (T.unpack e)
+ Right [c] -> do
+ V.length (SPC.spcPoints c) `shouldBe` V.length inControl
+ let zs = SPC.spcPoints c
+ ucls = SPC.spcUCL c
+ lcls = SPC.spcLCL c
+ inLim = V.izipWith
+ (\i z _ ->
+ z <= V.unsafeIndex ucls i + 1e-9
+ && z >= V.unsafeIndex lcls i - 1e-9)
+ zs zs
+ V.and inLim `shouldBe` True
+ Right _ -> expectationFailure "expected single chart"
+ it "EWMA: 平均シフト系列で後半に管理限界超過点あり" $
+ case SPC.fitSPC SPC.EWMAChart (SPC.EWMAInput shifted 0.2 3.0 10.0 0.1) of
+ Left _ -> expectationFailure "expected Right"
+ Right [c] -> do
+ let zs = SPC.spcPoints c
+ ucls = SPC.spcUCL c
+ anyOut = V.any id $ V.izipWith
+ (\i z _ -> z > V.unsafeIndex ucls i) zs zs
+ anyOut `shouldBe` True
+ Right _ -> expectationFailure "expected single chart"
+ it "EWMA: λ ∉ (0,1] は Left" $
+ case SPC.fitSPC SPC.EWMAChart (SPC.EWMAInput inControl 1.5 3.0 10.0 0.1) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
+ it "EWMA: 漸近的に limit が μ₀ ± L σ √(λ/(2−λ)) に収束" $
+ case SPC.fitSPC SPC.EWMAChart
+ (SPC.EWMAInput (V.replicate 200 10.0) 0.2 3.0 10.0 0.1) of
+ Right [c] -> do
+ let lambda = 0.2
+ ll = 3.0
+ s = 0.1
+ asym = ll * s * sqrt (lambda / (2 - lambda))
+ uclLast = V.last (SPC.spcUCL c)
+ abs (uclLast - (10 + asym)) `shouldSatisfy` (< 1e-6)
+ _ -> expectationFailure "expected single chart"
+
+ it "CUSUM: in-control で両側とも限界内" $
+ case SPC.fitSPC SPC.CUSUMChart (SPC.CUSUMInput inControl 10.0 0.1 0.5 4.0) of
+ Left e -> expectationFailure (T.unpack e)
+ Right [cp, cn] -> do
+ SPC.spcChartName cp `shouldBe` "CUSUM+"
+ SPC.spcChartName cn `shouldBe` "CUSUM-"
+ let hAbs = 4.0 * 0.1
+ cpPts = SPC.spcPoints cp
+ cnPts = SPC.spcPoints cn -- already negated
+ V.all (<= hAbs + 1e-9) cpPts `shouldBe` True
+ V.all (>= negate hAbs - 1e-9) cnPts `shouldBe` True
+ Right _ -> expectationFailure "expected 2 charts"
+ it "CUSUM: 上方シフトで C+ が h σ を超える点あり" $
+ case SPC.fitSPC SPC.CUSUMChart (SPC.CUSUMInput shifted 10.0 0.1 0.5 4.0) of
+ Right [cp, _] -> do
+ let hAbs = 4.0 * 0.1
+ V.any (> hAbs) (SPC.spcPoints cp) `shouldBe` True
+ _ -> expectationFailure "expected 2 charts"
+ it "CUSUM: h ≤ 0 は Left" $
+ case SPC.fitSPC SPC.CUSUMChart (SPC.CUSUMInput inControl 10.0 0.1 0.5 0) of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "expected Left"
diff --git a/test/Hanalyze/Stat/StandardizeSpec.hs b/test/Hanalyze/Stat/StandardizeSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/StandardizeSpec.hs
@@ -0,0 +1,61 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.StandardizeSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.Standardize as Std
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Standardize" $ do
+ let xMat = LA.fromLists [[1, 100], [2, 200], [3, 300], [4, 400], [5, 500]] :: LA.Matrix Double
+ s = Std.fitStandardizer xMat
+ it "fit: 各列の μ が一致" $
+ Std.stMu s `shouldSatisfy`
+ (\ms -> length ms == 2
+ && abs (ms !! 0 - 3) < 1e-9
+ && abs (ms !! 1 - 300) < 1e-9)
+ it "fit: 各列の σ が不偏分散の平方根 (n-1 正規化)" $
+ Std.stSd s `shouldSatisfy`
+ (\ss -> length ss == 2
+ && abs (ss !! 0 - sqrt 2.5) < 1e-9
+ && abs (ss !! 1 - sqrt 25000) < 1e-9)
+ it "apply 後は各列 mean≈0, std≈1" $ do
+ let x' = Std.applyStandardizer s xMat
+ c0 = LA.toColumns x' !! 0
+ c1 = LA.toColumns x' !! 1
+ mn v = LA.sumElements v / fromIntegral (LA.size v)
+ abs (mn c0) `shouldSatisfy` (< 1e-9)
+ abs (mn c1) `shouldSatisfy` (< 1e-9)
+ it "unapply で元の値に戻る" $ do
+ let x' = Std.applyStandardizer s xMat
+ x'' = Std.unapplyStandardizer s x'
+ d = LA.norm_2 (xMat - x'') :: Double
+ d `shouldSatisfy` (< 1e-9)
+ it "定数列 (std=0) は std=1 にフォールバック (中央化のみ)" $ do
+ let constMat = LA.fromLists [[7, 1], [7, 2], [7, 3]] :: LA.Matrix Double
+ s2 = Std.fitStandardizer constMat
+ abs (Std.stSd s2 !! 0 - 1.0) `shouldSatisfy` (< 1e-12)
+ let x' = Std.applyStandardizer s2 constMat
+ c0 = LA.toColumns x' !! 0
+ abs (LA.sumElements c0) `shouldSatisfy` (< 1e-9)
diff --git a/test/Hanalyze/Stat/SummarySpec.hs b/test/Hanalyze/Stat/SummarySpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/SummarySpec.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Hanalyze.Stat.Summary の spec (Phase 100: 表示系 ESS の essBulk 統一)。
+--
+-- posteriorSummary の srEssV が旧 pooled 'ess' ではなく chain 構造を渡した
+-- 'essBulk' (arviz ess_bulk 互換・MCMCSpec の golden で検証済) と一致する
+-- 配線を固定する。データは MCMCSpec と同じ決定的 LCG+AR(1)。
+module Hanalyze.Stat.SummarySpec (spec) where
+
+import qualified Data.Map.Strict as Map
+import Test.Hspec
+
+import Hanalyze.MCMC.Core (Chain (..))
+import Hanalyze.Stat.MCMC (essBulk)
+import Hanalyze.Stat.Summary (SummaryRow (..), posteriorSummary)
+
+-- | glibc 系数の LCG (mod 2^31)・[-0.5, 0.5) 一様。Integer 演算なので厳密。
+lcg :: Int -> Int -> [Double]
+lcg seed n = take n (map toU (drop 1 (iterate step (fromIntegral seed))))
+ where
+ step x = (1103515245 * x + 12345) `mod` (2 ^ (31 :: Int)) :: Integer
+ toU x = fromIntegral x / 2 ^ (31 :: Int) - 0.5
+
+-- | AR(1): y_i = phi*y_{i-1} + u_i (y_0 起点 0)。
+ar1 :: Int -> Int -> Double -> [Double]
+ar1 seed n phi = drop 1 (scanl (\prev u -> phi * prev + u) 0 (lcg seed n))
+
+mkChain :: [Double] -> Chain
+mkChain vs = Chain
+ { chainSamples = [Map.singleton "x" v | v <- vs]
+ , chainAccepted = 0
+ , chainTotal = 0
+ , chainEnergy = []
+ , chainDivergences = []
+ , chainTreeDepths = []
+ }
+
+relClose :: Double -> Double -> Double -> Bool
+relClose tol expected actual = abs (actual - expected) <= tol * abs expected
+
+spec :: Spec
+spec = do
+ describe "posteriorSummary の ESS (Phase 100: essBulk 統一)" $ do
+ it "多 chain: srEssV = essBulk perChain (arviz golden 84.428・旧 pooled ess 86.804 ではない)" $ do
+ let perChain = [ar1 (c + 1) 300 0.9 | c <- [0 .. 3 :: Int]]
+ [row] = posteriorSummary ["x"] (map mkChain perChain)
+ srEssV row `shouldBe` essBulk perChain
+ srEssV row `shouldSatisfy` relClose 1e-6 84.42798772749184
+
+ it "単一 chain でも essBulk (split 2 sub-chain) を返す" $ do
+ let vs = ar1 42 300 0.5
+ [row] = posteriorSummary ["x"] [mkChain vs]
+ srEssV row `shouldBe` essBulk [vs]
+ srRhat row `shouldBe` Nothing
diff --git a/test/Hanalyze/Stat/TestSpec.hs b/test/Hanalyze/Stat/TestSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/TestSpec.hs
@@ -0,0 +1,210 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.TestSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Numeric.LinearAlgebra as LA
+import qualified Hanalyze.Stat.Test as ST
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.Test" $ do
+ it "tTest1Sample: μ₀=0 で同分布なら p > 0.05" $ do
+ let xs = LA.fromList [0.1, -0.2, 0.3, 0.0, 0.15, -0.1, 0.05, 0.2]
+ tr = ST.tTest1Sample xs 0 ST.TwoSided
+ ST.trPValue tr `shouldSatisfy` (> 0.05)
+
+ it "tTestWelch: 明らかにずれた 2 群で p < 0.05" $ do
+ let xs = LA.fromList [1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0]
+ ys = LA.fromList [10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0]
+ tr = ST.tTestWelch xs ys ST.TwoSided
+ ST.trPValue tr `shouldSatisfy` (< 0.05)
+
+ it "anovaOneWay: 3 群が異なる平均なら有意" $ do
+ let g1 = LA.fromList [1.0, 2.0, 3.0]
+ g2 = LA.fromList [4.0, 5.0, 6.0]
+ g3 = LA.fromList [7.0, 8.0, 9.0]
+ tr = ST.anovaOneWay [g1, g2, g3]
+ ST.trStatistic tr `shouldSatisfy` (> 1)
+ ST.trPValue tr `shouldSatisfy` (< 0.05)
+
+ it "chiSquareIndep: 強い独立で p > 0.05" $ do
+ let tbl = LA.matrix 2 [25, 25, 25, 25] -- 完全独立
+ tr = ST.chiSquareIndep tbl
+ ST.trPValue tr `shouldSatisfy` (> 0.5)
+
+ it "chiSquareIndep: 強い従属で p < 0.05" $ do
+ let tbl = LA.matrix 2 [40, 10, 10, 40] -- 高 chi2
+ tr = ST.chiSquareIndep tbl
+ ST.trPValue tr `shouldSatisfy` (< 0.05)
+
+ it "leveneTest: 分散が大きく異なれば p < 0.05" $ do
+ let g1 = LA.fromList [1, 1.1, 0.9, 1.05, 0.95, 1.02, 0.98, 1.03]
+ g2 = LA.fromList [10, 20, 5, 25, 8, 30, 3, 22] -- much larger var
+ tr = ST.leveneTest [g1, g2]
+ ST.trPValue tr `shouldSatisfy` (< 0.05)
+
+ it "shapiroWilk: roughly-normal 系列で p > 0.05" $ do
+ let xs = LA.fromList [-1.5, -0.5, 0.0, 0.3, 0.8, 1.2, -0.3, 0.5, 1.0, -1.0]
+ tr = ST.shapiroWilk xs
+ ST.trPValue tr `shouldSatisfy` (> 0.05)
+
+ it "mannWhitneyU: 明らかにずれた 2 群で p < 0.05" $ do
+ let xs = LA.fromList [1, 2, 3, 4, 5, 6]
+ ys = LA.fromList [11, 12, 13, 14, 15, 16]
+ tr = ST.mannWhitneyU xs ys ST.TwoSided
+ ST.trPValue tr `shouldSatisfy` (< 0.05)
+
+ it "fisherExact2x2: 強い偏りで p < 0.05" $ do
+ let tr = ST.fisherExact2x2 ((20, 5), (5, 20)) ST.TwoSided
+ ST.trPValue tr `shouldSatisfy` (< 0.05)
+
+ -- ===========================================================================
+ -- Hanalyze.Model.PCA (Phase 2)
+ -- ===========================================================================
+
+ describe "Hanalyze.Stat.Test multivariate (Phase 4.3, request/140)" $ do
+ -- 1-sample Hotelling T² 既知ケース: 平均 μ̂ = (1, 2) と仮説 μ_0 を比較
+ it "hotellingsT2 (1-sample): 仮説と異なる平均で有意" $ do
+ -- X = 10 観測の 2 次元 (mean ≈ [5, 5])
+ let xs = LA.fromLists
+ [ [4.8, 5.1], [5.1, 5.2], [4.9, 4.8], [5.0, 5.0], [5.2, 5.1]
+ , [4.7, 4.9], [5.1, 5.0], [5.0, 5.3], [4.9, 4.7], [5.3, 5.2]
+ ]
+ mu0 = LA.fromList [0.0, 0.0]
+ tr = ST.hotellingsT2 xs mu0
+ ST.trPValue tr `shouldSatisfy` (< 1e-6)
+ case ST.trEffect tr of
+ Just ("T²", t2) -> t2 `shouldSatisfy` (> 100)
+ _ -> expectationFailure "expected T² effect"
+
+ it "hotellingsT2 (1-sample): 仮説と一致する μ_0 で有意でない" $ do
+ let xs = LA.fromLists
+ [ [4.8, 5.1], [5.1, 5.2], [4.9, 4.8], [5.0, 5.0], [5.2, 5.1]
+ , [4.7, 4.9], [5.1, 5.0], [5.0, 5.3], [4.9, 4.7], [5.3, 5.2]
+ ]
+ mu0 = LA.fromList [5.0, 5.0]
+ tr = ST.hotellingsT2 xs mu0
+ ST.trPValue tr `shouldSatisfy` (> 0.05)
+
+ it "hotellingsT2 sanity: μ_0 長さ mismatch、 n ≤ p は trNote" $ do
+ let xs = LA.fromLists [[1,2],[3,4],[5,6]]
+ ST.trMethod (ST.hotellingsT2 xs (LA.fromList [0])) `shouldSatisfy`
+ (\m -> T.isPrefixOf "Hotelling" m)
+ ST.trMethod (ST.hotellingsT2 (LA.fromLists [[1,2,3],[4,5,6]])
+ (LA.fromList [0,0,0]))
+ `shouldSatisfy` (\m -> T.isPrefixOf "Hotelling" m)
+
+ it "hotellingsT2TwoSample: 異なる中心の 2 群で有意" $ do
+ let xs = LA.fromLists
+ [ [4.8, 5.1], [5.1, 5.2], [4.9, 4.8], [5.0, 5.0], [5.2, 5.1]
+ , [4.7, 4.9], [5.1, 5.0], [5.0, 5.3], [4.9, 4.7], [5.3, 5.2]
+ ]
+ ys = LA.fromLists
+ [ [8.8, 9.1], [9.1, 9.2], [8.9, 8.8], [9.0, 9.0], [9.2, 9.1]
+ , [8.7, 8.9], [9.1, 9.0], [9.0, 9.3], [8.9, 8.7], [9.3, 9.2]
+ ]
+ tr = ST.hotellingsT2TwoSample xs ys
+ ST.trPValue tr `shouldSatisfy` (< 1e-6)
+
+ it "hotellingsT2TwoSample: 同じ中心の 2 群で有意でない" $ do
+ let xs = LA.fromLists
+ [ [4.8, 5.1], [5.1, 5.2], [4.9, 4.8], [5.0, 5.0], [5.2, 5.1]
+ , [4.7, 4.9], [5.1, 5.0], [5.0, 5.3], [4.9, 4.7], [5.3, 5.2]
+ ]
+ ys = LA.fromLists
+ [ [5.1, 4.9], [4.9, 5.0], [5.0, 5.1], [4.8, 4.9], [5.2, 5.0]
+ , [4.9, 5.2], [5.1, 4.8], [4.8, 5.1], [5.0, 4.7], [5.2, 5.1]
+ ]
+ tr = ST.hotellingsT2TwoSample xs ys
+ ST.trPValue tr `shouldSatisfy` (> 0.05)
+
+ it "manova: 3 群 で平均が大きく異なる場合に有意" $ do
+ let g1 = LA.fromLists
+ [ [4.8, 5.1], [5.1, 5.2], [4.9, 4.8], [5.0, 5.0], [5.2, 5.1]
+ , [4.7, 4.9], [5.1, 5.0], [5.0, 5.3]
+ ]
+ g2 = LA.fromLists
+ [ [8.8, 9.1], [9.1, 9.2], [8.9, 8.8], [9.0, 9.0], [9.2, 9.1]
+ , [8.7, 8.9], [9.1, 9.0], [9.0, 9.3]
+ ]
+ g3 = LA.fromLists
+ [ [12.8, 13.1], [13.1, 13.2], [12.9, 12.8], [13.0, 13.0]
+ , [13.2, 13.1], [12.7, 12.9], [13.1, 13.0], [13.0, 13.3]
+ ]
+ tr = ST.manova [g1, g2, g3]
+ ST.trPValue tr `shouldSatisfy` (< 1e-6)
+ case ST.trEffect tr of
+ Just ("Wilks Λ", w) -> w `shouldSatisfy` (\v -> v >= 0 && v <= 1)
+ _ -> expectationFailure "expected Wilks Λ effect"
+
+ it "manova: 1 群しか無い場合は trNote (= 検定不能)" $ do
+ let g1 = LA.fromLists [[1,2],[3,4]]
+ tr = ST.manova [g1]
+ ST.trMethod tr `shouldSatisfy` (\m -> T.isPrefixOf "MANOVA" m)
+
+ describe "Hanalyze.Stat.Test TOST (Phase 12)" $ do
+ let near1 = LA.fromList [9.95, 10.05, 10.0, 10.1, 9.9, 10.02]
+ near2 = LA.fromList [10.02, 9.98, 10.05, 9.93, 10.07, 10.01]
+ far1 = LA.fromList [9.9, 10.0, 10.1, 9.95, 10.05]
+ far2 = LA.fromList [12.0, 12.1, 11.9, 12.05, 11.95]
+ it "TOST: 平均差小 + Δ=0.5 → equivalence (p < 0.05)" $ do
+ let r = ST.tostWelch near1 near2 0.5
+ ST.trPValue r `shouldSatisfy` (< 0.05)
+ it "TOST: 平均差大 → not equivalent (p ≥ 0.05)" $ do
+ let r = ST.tostWelch far1 far2 0.5
+ ST.trPValue r `shouldSatisfy` (>= 0.05)
+ it "TOST: delta ≤ 0 は note 付きで返る" $ do
+ let r = ST.tostWelch near1 near2 0
+ ST.trNote r `shouldSatisfy` maybe False (\n -> T.isInfixOf "delta" n)
+
+ describe "Hanalyze.Stat.Test Friedman + Dunn (Phase 13.1)" $ do
+ it "friedmanTest: 全 block 全 cell 同値 → Q ≈ 0、 p ≈ 1" $ do
+ -- 全 cell が同一なら treatment 間に差が無い → Q ≈ 0
+ let m = LA.fromLists
+ [ [1,1,1], [1,1,1], [1,1,1], [1,1,1] ]
+ r = ST.friedmanTest m
+ ST.trPValue r `shouldSatisfy` (> 0.5)
+ it "friedmanTest: 完全 treatment 効果あり (列ごと一定差) → 強い棄却" $ do
+ let m = LA.fromLists
+ [ [1, 2, 3], [2, 3, 4], [1.5, 2.5, 3.5], [1.2, 2.2, 3.2],
+ [1.1, 2.1, 3.1], [1.3, 2.3, 3.3] ]
+ r = ST.friedmanTest m
+ ST.trPValue r `shouldSatisfy` (< 0.05)
+ it "friedmanTest: 1 行のみは Left (note 付き)" $ do
+ let m = LA.fromLists [[1, 2, 3]]
+ r = ST.friedmanTest m
+ ST.trNote r `shouldSatisfy` maybe False (T.isInfixOf "need")
+ it "dunnTest: 3 group、 強分離で全 p_adj < 0.10" $ do
+ let g1 = LA.fromList [1, 2, 1.5, 1.2, 1.8, 0.5, 1.3, 1.6]
+ g2 = LA.fromList [5, 6, 5.5, 5.2, 5.8, 4.5, 5.3, 5.6]
+ g3 = LA.fromList [10, 11, 10.5, 10.2, 10.8, 9.5, 10.3, 10.6]
+ r = ST.dunnTest [g1, g2, g3]
+ length (ST.mcrPairs r) `shouldBe` 3
+ all (< 0.10) (ST.mcrPAdj r) `shouldBe` True
+ it "dunnTest: 同分布の 2 group は p_adj 高い" $ do
+ let g1 = LA.fromList [1.0, 1.5, 2.0, 1.2, 1.8]
+ g2 = LA.fromList [1.1, 1.4, 2.1, 1.3, 1.9]
+ r = ST.dunnTest [g1, g2]
+ length (ST.mcrPairs r) `shouldBe` 1
+ head (ST.mcrPAdj r) `shouldSatisfy` (> 0.3)
diff --git a/test/Hanalyze/Stat/VISpec.hs b/test/Hanalyze/Stat/VISpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Stat/VISpec.hs
@@ -0,0 +1,87 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Stat.VISpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Map.Strict as M
+import qualified System.Random.MWC as MWC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.HBM as HBM
+import qualified Hanalyze.Stat.VI as VI
+import qualified Data.Map.Strict as M
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Stat.VI.fullRankAdvi (Phase 37-A5)" $ do
+ -- 相関のある事後を持つ簡単な 2 次元モデル
+ -- mu1 ~ Normal(0, 5), mu2 ~ Normal(0, 5)
+ -- y_i ~ Normal(mu1 + mu2, 0.3) を 10 件観測 → mu1 + mu2 の事後はタイトだが
+ -- mu1 単独 / mu2 単独 は逆相関 (sum が決まると個別は trade-off)
+ let model :: HBM.ModelP ()
+ model = do
+ mu1 <- HBM.sample "mu1" (HBM.Normal 0 5)
+ mu2 <- HBM.sample "mu2" (HBM.Normal 0 5)
+ HBM.observe "y" (HBM.Normal (mu1 + mu2) 0.3)
+ (replicate 10 6.0)
+ cfg = VI.defaultVIConfig
+ { VI.viIterations = 300
+ , VI.viSamples = 5
+ , VI.viLearningRate = 0.1
+ , VI.viNumDraws = 200
+ }
+ initP = M.fromList [("mu1", 3.0), ("mu2", 3.0)]
+ --
+ it "fullRankAdvi は viCovU = Just と viMethod = FullRank を返す" $ do
+ gen <- MWC.create
+ res <- VI.fullRankAdvi model cfg initP gen
+ VI.viMethod res `shouldBe` VI.FullRank
+ (case VI.viCovU res of Just _ -> True; Nothing -> False) `shouldBe` True
+ it "mean-field advi は viCovU = Nothing と viMethod = MeanField" $ do
+ gen <- MWC.create
+ res <- VI.advi model cfg initP gen
+ VI.viMethod res `shouldBe` VI.MeanField
+ (case VI.viCovU res of Just _ -> False; Nothing -> True) `shouldBe` True
+ it "fullRankAdvi の L は下三角 (上三角は 0)" $ do
+ gen <- MWC.create
+ res <- VI.fullRankAdvi model cfg initP gen
+ case VI.viCovU res of
+ Just l ->
+ let n = length l
+ upperZero = and [ (l !! i !! j) == 0
+ | i <- [0 .. n-1]
+ , j <- [i+1 .. n-1] ]
+ in upperZero `shouldBe` True
+ Nothing -> expectationFailure "viCovU should be Just"
+ it "fullRankAdvi は相関を学習 (L の off-diagonal が非ゼロ)" $ do
+ gen <- MWC.create
+ res <- VI.fullRankAdvi model cfg initP gen
+ case VI.viCovU res of
+ Just l | length l >= 2 ->
+ -- L[1][0] が非ゼロ = 相関を捉えている
+ (abs (l !! 1 !! 0) > 0.01) `shouldBe` True
+ _ -> expectationFailure "viCovU must be at least 2×2"
+ it "fullRankAdvi 事後平均が mu1+mu2 ≈ 6 を回復 (合計が観測値)" $ do
+ gen <- MWC.create
+ res <- VI.fullRankAdvi model cfg initP gen
+ let m1 = M.findWithDefault 0 "mu1" (VI.viPostMeans res)
+ m2 = M.findWithDefault 0 "mu2" (VI.viPostMeans res)
+ (abs (m1 + m2 - 6) < 0.5) `shouldBe` True
diff --git a/test/Hanalyze/Viz/ModelGraphSpec.hs b/test/Hanalyze/Viz/ModelGraphSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Viz/ModelGraphSpec.hs
@@ -0,0 +1,272 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Viz.ModelGraphSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Data.Text as T
+import qualified Hanalyze.Viz.ModelGraph as VMG
+import qualified Hanalyze.Viz.ModelGraphDot as VMGD
+import qualified Hanalyze.Model.HBM as HBM
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Viz.ModelGraph + ModelGraphDot (Phase 40-A3)" $ do
+ let m :: HBM.ModelP ()
+ m = do
+ mu <- HBM.sample "mu" (HBM.Normal 0 5)
+ _ <- HBM.plate "g" 4 $ forM [0..3 :: Int] $ \j ->
+ HBM.sample ("x_" <> T.pack (show j)) (HBM.Normal mu 1)
+ return ()
+ --
+ -- Mermaid plate 出力
+ --
+ it "buildMermaid: plate 内ノードが subgraph で囲まれる" $ do
+ let g = HBM.buildModelGraph m
+ src = VMG.buildMermaid g
+ T.isInfixOf "subgraph plate_g[\"g × 4\"]" src `shouldBe` True
+ T.isInfixOf "end" src `shouldBe` True
+ it "buildMermaid: plate 外ノード mu は subgraph の外" $ do
+ let g = HBM.buildModelGraph m
+ src = VMG.buildMermaid g
+ -- "subgraph plate_g" の前に mu が現れるか後か
+ beforeSub = T.takeWhile (\_ -> True) (T.takeWhile (/= 's') src)
+ -- 大雑把: mu は src の前半に出現
+ muIdx = T.length (fst (T.breakOn "mu" src))
+ subIdx = T.length (fst (T.breakOn "subgraph plate_g" src))
+ (muIdx < subIdx) `shouldBe` True
+ -- beforeSub だけ使う体裁を維持
+ T.length beforeSub `shouldSatisfy` (>= 0)
+ --
+ -- Graphviz DOT 出力
+ --
+ it "renderModelGraphDot: 出力が digraph G { で始まり } で終わる" $ do
+ let g = HBM.buildModelGraph m
+ src = VMGD.renderModelGraphDot g
+ T.isPrefixOf "digraph G {" src `shouldBe` True
+ T.isSuffixOf "}\n" src `shouldBe` True
+ it "renderModelGraphDot: plate が cluster_g { label=\"g × 4\" } で囲まれる" $ do
+ let g = HBM.buildModelGraph m
+ src = VMGD.renderModelGraphDot g
+ T.isInfixOf "subgraph cluster_g {" src `shouldBe` True
+ T.isInfixOf "label=\"g × 4\";" src `shouldBe` True
+ T.isInfixOf "labelloc=\"b\";" src `shouldBe` True
+ it "renderModelGraphDot: edge は arrow (->) で出力" $ do
+ let g = HBM.buildModelGraph m
+ src = VMGD.renderModelGraphDot g
+ T.isInfixOf "mu -> x_0;" src `shouldBe` True
+ --
+ -- DeterministicN ノード (Phase 59.2 回帰: mkNodeLine が LatentN/ObservedN
+ -- のみで non-exhaustive crash していた。 request/255 §1 の最小再現)
+ --
+ it "renderModelGraphDot: deterministic ノードで crash せず box 形状で出力" $ do
+ let dm :: HBM.ModelP ()
+ dm = do
+ a <- HBM.sample "a" (HBM.Normal 0 1)
+ mu <- HBM.deterministic "mu" (2 * a)
+ HBM.observe "y" (HBM.Normal mu 1) [0.5]
+ let g = HBM.buildModelGraph dm
+ src = VMGD.renderModelGraphDot g
+ T.isInfixOf "mu [label=\"mu\\nDeterministic\", shape=box];" src `shouldBe` True
+ T.isInfixOf "a -> mu;" src `shouldBe` True
+ T.isInfixOf "mu -> y;" src `shouldBe` True
+ --
+ -- Phase 60.4: データ slot (dataNamed/dataNamedIx) の DAG ノード化
+ -- (pm.Data 相当・既定 ON)。 label/attrs 両 case + 回帰 test を同時に
+ -- (Phase 59.2 の non-exhaustive crash の教訓)。
+ --
+ it "renderModelGraphDot: data slot が角丸灰色 box + x→mu エッジ (60.4)" $ do
+ let xm :: HBM.ModelP ()
+ xm = do
+ xs <- HBM.dataNamed "x" [1, 2, 3]
+ ys <- HBM.dataNamedObs "y" [2, 4, 6]
+ _gs <- HBM.dataNamedIx "g" [0, 1, 0]
+ b <- HBM.sample "b" (HBM.Normal 0 1)
+ mu <- HBM.deterministic "mu" (b * head xs)
+ HBM.observe "y" (HBM.Normal mu 1) ys
+ let g = HBM.buildModelGraph xm
+ src = VMGD.renderModelGraphDot g
+ -- ノード種: x/g は DataN、 y は observe に吸収され ObservedN
+ -- (dataNamedObs "y" + observe "y" の docs 慣例・PyMC で observed RV が
+ -- data 容器を内包するのと同型)
+ [ HBM.nodeKind n | n <- HBM.mgNodes g, HBM.nodeName n == "x" ]
+ `shouldBe` [HBM.DataN 3]
+ [ HBM.nodeKind n | n <- HBM.mgNodes g, HBM.nodeName n == "g" ]
+ `shouldBe` [HBM.DataN 3]
+ [ HBM.nodeKind n | n <- HBM.mgNodes g, HBM.nodeName n == "y" ]
+ `shouldBe` [HBM.ObservedN 3]
+ -- エッジ: x→mu (dataNamed の dep タグ)・mu→y。 g ([Int]) はエッジなし
+ HBM.mgEdges g `shouldSatisfy` (("x", "mu") `elem`)
+ HBM.mgEdges g `shouldSatisfy` (("mu", "y") `elem`)
+ [ e | e@(f, _) <- HBM.mgEdges g, f == "g" ] `shouldBe` []
+ -- DOT: 角丸灰色 box (PyMC ConstantData 流)・crash しない
+ T.isInfixOf "x [label=\"x\\n(n=3)\", shape=box, style=\"rounded,filled\", fillcolor=lightgray];" src
+ `shouldBe` True
+ T.isInfixOf "x -> mu;" src `shouldBe` True
+
+ it "dataNamedIx + (!!!) で slot→利用先エッジが出る (60.7)" $ do
+ let im :: HBM.ModelP ()
+ im = do
+ gs <- HBM.dataNamedIx "g" [0, 1, 0]
+ ys <- HBM.dataNamedObs "yv" [1, 2, 3]
+ m0 <- HBM.sample "m0" (HBM.Normal 0 5)
+ m1 <- HBM.sample "m1" (HBM.Normal 0 5)
+ s <- HBM.sample "s" (HBM.HalfNormal 1)
+ let ms = [m0, m1]
+ HBM.plateForM_ "obs" (zip gs ys) $ \(g, y) -> do
+ mu <- HBM.deterministic "mu" (ms HBM.!!! g)
+ HBM.observe "y" (HBM.Normal mu s) [y]
+ let g = HBM.buildModelGraph im
+ -- (!!!) の Track 解釈で g→mu エッジ (PyMC の b0[gid] 同型)
+ HBM.mgEdges g `shouldSatisfy` (("g", "mu") `elem`)
+ -- index 由来でない親 (m0/m1) も従来通り
+ HBM.mgEdges g `shouldSatisfy` (("m0", "mu") `elem`)
+
+ -- Phase 62: REff 経路 (atIx = ObserveLM 構造化ブロック) でも slot→観測
+ -- ノードのエッジが出る (60.7 では「既知の制限」 だった残り半分)。
+ it "dataNamedIx + reNormal/atIx + observeLMR で slot→obs エッジが出る (62)" $ do
+ let rm :: HBM.ModelP ()
+ rm = do
+ gids <- HBM.dataNamedIx "g" [0, 1, 0, 1]
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ tau <- HBM.sample "tau_u" (HBM.HalfNormal 1)
+ u <- HBM.reNormal "u" 2 "tau_u" tau
+ _ <- pure a
+ HBM.observeNormalLM "y" [[1], [1], [1], [1]] ["a"]
+ [u `HBM.atIx` gids] "sigma" [1, 2, 3, 4]
+ rg = HBM.buildModelGraph rm
+ -- slot g → 観測ブロック y のエッジ (lmParents が slot 名を運ぶ)
+ HBM.mgEdges rg `shouldSatisfy` (("g", "y") `elem`)
+ -- 従来の親 (β=a / u_j / σ 名は sample が無くとも親集合に入る) も不変
+ HBM.mgEdges rg `shouldSatisfy` (("a", "y") `elem`)
+ HBM.mgEdges rg `shouldSatisfy` (("u_0", "y") `elem`)
+
+ it "at ([Int] 経路) は従来どおり slot エッジなし (62 非影響確認)" $ do
+ let rm :: HBM.ModelP ()
+ rm = do
+ a <- HBM.sample "a" (HBM.Normal 0 5)
+ tau <- HBM.sample "tau_u" (HBM.HalfNormal 1)
+ u <- HBM.reNormal "u" 2 "tau_u" tau
+ _ <- pure a
+ HBM.observeNormalLM "y" [[1], [1], [1], [1]] ["a"]
+ [u `HBM.at` [0, 1, 0, 1]] "sigma" [1, 2, 3, 4]
+ rg = HBM.buildModelGraph rm
+ [ e | e@(f, _) <- HBM.mgEdges rg, f == "g" ] `shouldBe` []
+ HBM.mgEdges rg `shouldSatisfy` (("u_1", "y") `elem`)
+
+ -- Phase 63.1: dataNamedObs の slot は observe の生 ys と値一致で
+ -- obs→slot エッジが張られ obs の子になる (PyMC make_compute_graph の
+ -- obs→y 同型。 従来はエッジゼロで source rank に浮遊し x と被っていた)。
+ it "dataNamedObs slot に obs→slot エッジが出る (63.1・構造化 observe)" $ do
+ let om :: HBM.ModelP ()
+ om = do
+ xs <- HBM.dataNamed "x" [1, 2, 3]
+ ys <- HBM.dataNamedObs "yv" [2, 4, 6]
+ b <- HBM.sample "b" (HBM.Normal 0 1)
+ mu <- HBM.deterministic "mu" (b * head xs)
+ HBM.observe "y" (HBM.Normal mu 1) ys
+ let g = HBM.buildModelGraph om
+ -- obs→slot (y が親・yv が子 = yv は y の下に描かれる)
+ HBM.mgEdges g `shouldSatisfy` (("y", "yv") `elem`)
+ -- x slot は従来どおり x→mu のみ (値が異なるので obs からのエッジなし)
+ HBM.mgEdges g `shouldSatisfy` (("x", "mu") `elem`)
+ [ e | e@(_, t) <- HBM.mgEdges g, t == "x" ] `shouldBe` []
+
+ it "per-point loop の observe も連結 ys で slot match する (63.1)" $ do
+ let lm :: HBM.ModelP ()
+ lm = do
+ xs <- HBM.dataNamed "x" [1, 2, 3]
+ ys <- HBM.dataNamedObs "yv" [2, 4, 6]
+ b <- HBM.sample "b" (HBM.Normal 0 1)
+ s <- HBM.sample "s" (HBM.HalfNormal 1)
+ HBM.plateForM_ "obs" (zip xs ys) $ \(x, y) -> do
+ mu <- HBM.deterministic "mu" (b * x)
+ HBM.observe "y" (HBM.Normal mu s) [y]
+ let g = HBM.buildModelGraph lm
+ HBM.mgEdges g `shouldSatisfy` (("y", "yv") `elem`)
+
+ it "dataNamedObs と observe が同名なら自己ループを張らない (63.1)" $ do
+ let sm :: HBM.ModelP ()
+ sm = do
+ ys <- HBM.dataNamedObs "y" [2, 4, 6]
+ mu <- HBM.sample "mu" (HBM.Normal 0 1)
+ HBM.observe "y" (HBM.Normal mu 1) ys
+ let g = HBM.buildModelGraph sm
+ [ e | e@(f, t) <- HBM.mgEdges g, f == t ] `shouldBe` []
+
+ it "data slot がデータ長 = plate サイズの一意 match で plate に入る (60.6 追補)" $ do
+ let pm :: HBM.ModelP ()
+ pm = do
+ xs <- HBM.dataNamed "x" [1, 2, 3]
+ ys <- HBM.dataNamedObs "yv" [2, 4, 6]
+ b <- HBM.sample "b" (HBM.Normal 0 1)
+ s <- HBM.sample "s" (HBM.HalfNormal 1)
+ HBM.plateForM_ "obs" (zip xs ys) $ \(x, y) -> do
+ mu <- HBM.deterministic "mu" (b * x)
+ HBM.observe "y" (HBM.Normal mu s) [y]
+ let g = HBM.buildModelGraph pm
+ platesOf nm = [ HBM.nodePlates n | n <- HBM.mgNodes g
+ , HBM.nodeName n == nm ]
+ -- 宣言は plate 外だが n=3 = plate "obs" (3) の一意 match → obs 内
+ platesOf "x" `shouldBe` [["obs"]]
+ platesOf "yv" `shouldBe` [["obs"]]
+ -- latent は従来通り plate 外
+ platesOf "b" `shouldBe` [[]]
+
+ it "data 長と一致する plate が複数なら据え置き (60.6 追補・曖昧 match)" $ do
+ let am :: HBM.ModelP ()
+ am = do
+ xs <- HBM.dataNamed "x" [1, 2]
+ b <- HBM.sample "b" (HBM.Normal 0 1)
+ _ <- HBM.plateForM "p1" [0, 1 :: Int] $ \j ->
+ HBM.sample ("a" HBM..# j) (HBM.Normal b 1)
+ _ <- HBM.plateForM "p2" [0, 1 :: Int] $ \j ->
+ HBM.sample ("c" HBM..# j) (HBM.Normal b 1)
+ HBM.observe "y" (HBM.Normal (head xs) 1) [0.5]
+ let g = HBM.buildModelGraph am
+ [ HBM.nodePlates n | n <- HBM.mgNodes g, HBM.nodeName n == "x" ]
+ `shouldBe` [[]]
+
+ it "describeModel: data slot が [data] 行で出る (60.4)" $ do
+ let xm :: HBM.ModelP ()
+ xm = do
+ xs <- HBM.dataNamed "x" [1, 2, 3]
+ b <- HBM.sample "b" (HBM.Normal 0 1)
+ HBM.observe "y" (HBM.Normal (b * head xs) 1) [0.5]
+ T.isInfixOf "[data]" (HBM.describeModel xm) `shouldBe` True
+
+ --
+ -- Nested plate: cluster の入れ子
+ --
+ it "renderModelGraphDot: nested plate で cluster が入れ子" $ do
+ let nm :: HBM.ModelP ()
+ nm = do
+ _ <- HBM.plate "school" 2 $ forM_ [0..1 :: Int] $ \j ->
+ HBM.plate "student" 2 $ forM_ [0..1 :: Int] $ \i ->
+ HBM.sample ("y_" <> T.pack (show j) <> "_" <> T.pack (show i))
+ (HBM.Normal 0 1)
+ return ()
+ let g = HBM.buildModelGraph nm
+ src = VMGD.renderModelGraphDot g
+ -- "school" cluster の中に "student" cluster
+ schoolIdx = T.length (fst (T.breakOn "cluster_school" src))
+ studentIdx = T.length (fst (T.breakOn "cluster_student" src))
+ (schoolIdx < studentIdx) `shouldBe` True
diff --git a/test/Hanalyze/Viz/ReportBuilderSpec.hs b/test/Hanalyze/Viz/ReportBuilderSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hanalyze/Viz/ReportBuilderSpec.hs
@@ -0,0 +1,60 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+module Hanalyze.Viz.ReportBuilderSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+import qualified Hanalyze.Viz.ReportBuilder as RB
+import SpecHelper
+
+spec :: Spec
+spec = do
+ describe "Hanalyze.Viz.ReportBuilder.secInterpolation" $ do
+ it "defaultInterpReport で renderReport まで通る (smoke)" $
+ withSystemTempFile "ha-interp.html" $ \fp h -> do
+ hClose h
+ let ir = RB.defaultInterpReport "test"
+ RB.renderReport fp (RB.defaultReportConfig "T") [RB.secInterpolation ir]
+ out <- readFile fp
+ length out `shouldSatisfy` (> 100)
+
+ it "InterpReport 全フィールド + extra で HTML に主要要素が含まれる" $
+ withSystemTempFile "ha-interp2.html" $ \fp h -> do
+ hClose h
+ let ir = (RB.defaultInterpReport "regrid")
+ { RB.irInterpKind = "PCHIP"
+ , RB.irGridKind = "Adaptive"
+ , RB.irN = 3
+ , RB.irPerIdObserved = [("a", [(0, 0), (1, 1)])]
+ , RB.irPerIdInterpY = [("a", [(0, 0), (0.5, 0.5), (1, 1)])]
+ , RB.irGrid = [0, 0.5, 1]
+ , RB.irDensity = [(0, 1), (0.5, 2), (1, 1)]
+ , RB.irPerIdSummary = [("a", 2, 0, 1, 0, 0, 0)]
+ , RB.irExtraEnabled = True
+ , RB.irPerIdYRange = [("a", 0, 1, 0, 1)]
+ }
+ RB.renderReport fp (RB.defaultReportConfig "T") [RB.secInterpolation ir]
+ out <- readFile fp
+ out `shouldContain` "Parameters"
+ out `shouldContain` "PCHIP"
+
+ -- ===========================================================================
+ -- Hanalyze.Stat.Test (Phase 1: hypothesis tests)
+ -- ===========================================================================
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,2417 +1,1 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
-module Main where
-
-import Test.Hspec
-import Hanalyze.Model.GLMM
-import Hanalyze.Model.GLM (Family (..), LinkFn (..))
-import qualified Data.Vector as V
-import qualified Data.Text as T
-import qualified Numeric.LinearAlgebra as LA
-import Data.List (sort)
-
-import qualified DataFrame as DX
-import qualified Hanalyze.Design.Orthogonal as OA
-import qualified Hanalyze.Design.Quality as Quality
-import qualified Hanalyze.Design.Taguchi as TG
-import qualified Hanalyze.Model.LM as LM
-import qualified Hanalyze.Model.LM.Diagnostics as LMD
-import qualified Hanalyze.DataIO.Preprocess as Pp
-import qualified Hanalyze.DataIO.Log as Log
-import qualified Hanalyze.DataIO.CSV as CSV
-import qualified Hanalyze.DataIO.Convert as Conv
-import qualified Hanalyze.DataIO.Health as Health
-import qualified Hanalyze.DataIO.Clean as Clean
-import qualified Hanalyze.DataIO.Convert as Conv2
-import qualified Hanalyze.Stat.Standardize as Std
-import qualified Hanalyze.Stat.NumberFormat as NF
-import qualified Hanalyze.Stat.Interpolate as Interp
-import qualified Hanalyze.Stat.AdaptiveGrid as AG
-import qualified Hanalyze.Stat.KernelDist as KD
-import qualified Hanalyze.Stat.Cholesky as Chol
-import qualified Hanalyze.Stat.QuasiRandom as QR
-import qualified Hanalyze.Stat.Test as ST
-import qualified Hanalyze.Stat.ClassMetrics as CM
-import qualified Hanalyze.Stat.CV as CV
-import qualified Hanalyze.Stat.MultipleTesting as MT
-import qualified Hanalyze.Stat.Bootstrap as Boot
-import qualified Hanalyze.Stat.Effect as Eff
-import qualified Hanalyze.Stat.Interpret as Interp
-import qualified Hanalyze.Model.PCA as PCA
-import qualified Hanalyze.Model.Cluster as Cl
-import qualified Hanalyze.Model.DecisionTree as DT
-import qualified Hanalyze.Model.TimeSeries as TS
-import qualified Hanalyze.Model.Survival as Surv
-import qualified Hanalyze.DataIO.Reshape as Reshape
-import qualified Hanalyze.Optim.NSGA as NSGA
-import qualified System.Random.MWC as MWC
-import qualified Hanalyze.Model.Kernel as Kn
-import qualified Hanalyze.Model.GP as GP
-import qualified Hanalyze.Model.GPRobust as GPR
-import qualified Hanalyze.Viz.ReportBuilder as RB
-import qualified Data.ByteString as BS
-import System.IO.Temp (withSystemTempFile)
-import System.IO (hPutStr, hClose)
-import qualified Hanalyze.Model.GP as GP
-import qualified Hanalyze.Model.GPRobust as GPR
-import qualified Hanalyze.Model.RFF as RFF
-import qualified Hanalyze.Model.Regularized as Reg
-import qualified Hanalyze.Model.Spline as Sp
-import qualified Hanalyze.Model.Kernel as K
-import qualified Hanalyze.Model.Core as Core
-import qualified Hanalyze.Model.GLM as GLM
-import qualified Hanalyze.Optim.NelderMead as NM
-import qualified Hanalyze.Optim.LBFGS as LBFGS
-import qualified Hanalyze.Optim.LineSearch as LS
-import qualified Hanalyze.Optim.DifferentialEvolution as DE
-import qualified Hanalyze.Optim.CMAES as CMAES
-import qualified Hanalyze.Optim.CMAESFull as CMAESF
-import qualified Hanalyze.Optim.SimulatedAnnealing as SA
-import qualified Hanalyze.Optim.ParticleSwarm as PSO
-import qualified Hanalyze.Optim.Constrained as Con
-import qualified Hanalyze.Optim.BayesOpt as BO
-import qualified Hanalyze.Optim.Common as OC
-import qualified System.Random.MWC as MWC
-
-main :: IO ()
-main = hspec $ do
- describe "Hanalyze.Stat.KernelDist" $ do
- let xs = LA.fromLists [[0, 0], [3, 4], [1, 1]] :: LA.Matrix Double
- d = KD.pairwiseSqDist xs
- -- naive reference
- naive m =
- let rows = LA.toRows m
- n = length rows
- in (n LA.>< n)
- [ let r = rows !! i - rows !! j in r `LA.dot` r
- | i <- [0 .. n - 1], j <- [0 .. n - 1] ]
- ref = naive xs
-
- it "returns an n x n matrix with zero diagonal" $ do
- LA.rows d `shouldBe` 3
- LA.cols d `shouldBe` 3
- LA.toList (LA.takeDiag d) `shouldBe` [0, 0, 0]
-
- it "matches the naive reference within 1e-9" $
- LA.norm_Inf (d - ref) < 1e-9 `shouldBe` True
-
- it "pairwiseSqDistXY matches reference for cross-matrix" $ do
- let ys = LA.fromLists [[0, 0], [1, 0]] :: LA.Matrix Double
- dXY = KD.pairwiseSqDistXY xs ys
- rxs = LA.toRows xs
- rys = LA.toRows ys
- ref' = (LA.rows xs LA.>< LA.rows ys)
- [ let r = rxs !! i - rys !! j in r `LA.dot` r
- | i <- [0 .. LA.rows xs - 1]
- , j <- [0 .. LA.rows ys - 1] ]
- LA.norm_Inf (dXY - ref') < 1e-9 `shouldBe` True
-
- describe "Hanalyze.Optim.NSGA building blocks" $ do
- let mkSol obj = NSGA.Solution
- { NSGA.solDecision = obj -- decision unused here
- , NSGA.solObjectives = obj
- , NSGA.solViolation = 0
- }
- s00 = mkSol [0.0, 0.0] -- dominated by no one
- s11 = mkSol [1.0, 1.0] -- dominated by s00
- s05 = mkSol [0.5, 0.5]
- sa = mkSol [0.0, 1.0] -- non-comparable with sb
- sb = mkSol [1.0, 0.0]
-
- it "dominates: zero-violation pair uses paretoDominates" $ do
- NSGA.dominates s00 s11 `shouldBe` True
- NSGA.dominates s11 s00 `shouldBe` False
- NSGA.dominates sa sb `shouldBe` False
- NSGA.dominates sb sa `shouldBe` False
-
- it "nonDominatedSort: 3-point chain returns 3 fronts" $ do
- -- s00 ≻ s05 ≻ s11
- let fronts = NSGA.nonDominatedSort [s11, s05, s00]
- length fronts `shouldBe` 3
- length (head fronts) `shouldBe` 1 -- F_1 = {s00}
-
- it "crowdingDistance: 2-point front keeps both (≤2 → ∞)" $
- length (NSGA.crowdingDistance [sa, sb]) `shouldBe` 2
-
- it "crowdingDistance: 3-point front returns all 3 (∞ endpoints + 1 mid)" $ do
- let f3 = [mkSol [0.0, 1.0], mkSol [0.5, 0.5], mkSol [1.0, 0.0]]
- sorted = NSGA.crowdingDistance f3
- length sorted `shouldBe` 3
-
- it "dominationMatrix matches per-pair dominates on a 3-individual pop" $ do
- let s00 = NSGA.Solution [0, 0] [0.0, 0.0] 0 -- best
- s11 = NSGA.Solution [1, 1] [1.0, 1.0] 0 -- worst
- s05 = NSGA.Solution [0.5, 0.5] [0.5, 0.5] 0 -- middle
- pop = [s00, s05, s11]
- pm = NSGA.fromSolutions pop
- mDom = NSGA.dominationMatrix pm
- n = length pop
- ref = LA.fromLists
- [ [ if i == j then 0
- else if NSGA.dominates (pop !! i) (pop !! j) then 1
- else if NSGA.dominates (pop !! j) (pop !! i) then -1
- else 0
- | j <- [0 .. n - 1] ]
- | i <- [0 .. n - 1] ]
- :: LA.Matrix Double
- LA.norm_Inf (mDom - ref) `shouldBe` 0
-
- it "polynomialMutation: respects bounds and pMut=0 keeps x" $ do
- gen <- MWC.createSystemRandom
- let bs = [(0, 1), (0, 1), (0, 1)] :: [(Double, Double)]
- x' <- NSGA.polynomialMutation 20 0 bs [0.5, 0.5, 0.5] gen
- x' `shouldBe` [0.5, 0.5, 0.5]
- y' <- NSGA.polynomialMutation 20 1.0 bs [0.5, 0.5, 0.5] gen
- all (\(z, (lo, hi)) -> z >= lo && z <= hi) (zip y' bs)
- `shouldBe` True
-
- describe "Hanalyze.Stat.QuasiRandom (Halton)" $ do
- it "haltonSequence 10 1 lies in [0, 1) and is a permutation" $ do
- let pts = QR.haltonSequence 10 1
- length pts `shouldBe` 10
- all (\[u] -> u >= 0 && u < 1) pts `shouldBe` True
-
- it "haltonSequence 16 2 covers a 4x4 grid better than random" $ do
- -- For n = 16, d = 2 the Halton points should cover all 16
- -- 0.25-bins; an iid uniform usually misses some.
- let pts = QR.haltonSequence 16 2
- binIdx p = (floor (4 * head p) :: Int,
- floor (4 * (p !! 1)) :: Int)
- unique = length (foldr (\b acc -> if b `elem` acc then acc
- else b : acc) [] (map binIdx pts))
- unique `shouldSatisfy` (>= 14) -- Halton normally hits ≥ 14 / 16
-
- it "haltonSequenceIn rescales into the supplied bounds" $ do
- let bs = [(-2, 2), (10, 20)] :: [(Double, Double)]
- pts = QR.haltonSequenceIn 5 bs
- all (\[a, b] -> a >= -2 && a < 2
- && b >= 10 && b < 20) pts `shouldBe` True
-
- it "lhsSamples 10 3 lies in [0,1)^3 and fills every per-dim cell" $ do
- gen <- MWC.createSystemRandom
- pts <- QR.lhsSamples 10 3 gen
- length pts `shouldBe` 10
- all (\xs -> all (\u -> u >= 0 && u < 1) xs) pts `shouldBe` True
- -- For each dim, the 10 points should occupy 10 distinct cells
- -- (= floor(10 * u) is a permutation of [0..9]).
- let cellsAlong k = map (\xs -> floor (10 * (xs !! k)) :: Int) pts
- ok k = sort (cellsAlong k) == [0 .. 9]
- ok 0 `shouldBe` True
- ok 1 `shouldBe` True
- ok 2 `shouldBe` True
-
- it "lhsSamplesIn rescales into bounds" $ do
- gen <- MWC.createSystemRandom
- let bs = [(-1, 1), (5, 10)] :: [(Double, Double)]
- pts <- QR.lhsSamplesIn 8 bs gen
- all (\[a, b] -> a >= -1 && a < 1
- && b >= 5 && b < 10) pts `shouldBe` True
-
- describe "Hanalyze.Stat.Cholesky" $ do
- let aSPD = LA.fromLists [[4, 2, 1], [2, 5, 3], [1, 3, 6]]
- :: LA.Matrix Double
- b = LA.asColumn (LA.fromList [1.0, 2.0, 3.0])
-
- it "cholSolve agrees with LA.<\\> on a 3x3 SPD system (1e-9)" $ do
- let xC = Chol.cholSolve aSPD b
- xR = aSPD LA.<\> b
- case xC of
- Nothing -> expectationFailure "cholSolve returned Nothing on SPD"
- Just xc -> LA.norm_Inf (xc - xR) < 1e-9 `shouldBe` True
-
- it "cholSolveJitter falls back gracefully on a singular matrix" $ do
- let aSing = LA.fromLists [[1, 0, 0], [0, 0, 0], [0, 0, 1]]
- :: LA.Matrix Double
- bSing = LA.asColumn (LA.fromList [1.0, 0.0, 1.0])
- x = Chol.cholSolveJitter aSing bSing
- LA.rows x `shouldBe` 3 -- did not crash; whatever LSQ gives is fine
-
- it "cholFactor returns Just for SPD and Nothing for non-SPD" $ do
- Chol.cholFactor aSPD `shouldSatisfy` (\m -> case m of
- Just _ -> True
- Nothing -> False)
- let aNeg = LA.fromLists [[1, 2], [2, 1]] :: LA.Matrix Double
- -- eigenvalues 3 and -1 → not SPD
- Chol.cholFactor aNeg `shouldBe` Nothing
-
- describe "Hanalyze.Model.Kernel multi-input (MV)" $ do
- -- 2D regression target: y = sin(x1) + 0.5 cos(x2)
- let n = 60
- h = 0.5
- lam = 1e-4
- f x1 x2 = sin x1 + 0.5 * cos x2
- xs = LA.fromLists
- [ [ fromIntegral i / 10
- , fromIntegral (n - i) / 10
- ]
- | i <- [0 .. n - 1] ]
- ys = LA.asColumn $ LA.fromList
- [ f (xs `LA.atIndex` (i, 0)) (xs `LA.atIndex` (i, 1))
- | i <- [0 .. n - 1] ]
- fit = Kn.kernelRidgeMV Kn.Gaussian h lam xs ys
- yhat = Kn.fittedKernelRidgeMV fit
- ssErr = LA.sumElements ((ys - yhat) ** 2)
- ssTot = let muY = LA.sumElements ys / fromIntegral n
- in LA.sumElements ((ys - LA.konst muY (n, 1)) ** 2)
- r2 = 1 - ssErr / ssTot
-
- it "achieves R² > 0.95 on a 2D smooth target" $
- r2 > 0.95 `shouldBe` True
-
- it "predict at training points equals fitted" $ do
- let p = Kn.predictKernelRidgeMV fit xs
- LA.norm_Inf (p - yhat) < 1e-9 `shouldBe` True
-
- it "gramMatrixMV matches kernelFromSqDist by element" $ do
- let xS = LA.fromLists [[0.0, 0.0], [1.0, 0.0], [0.5, 0.5]] :: LA.Matrix Double
- gMV = Kn.gramMatrixMV Kn.Gaussian 1.0 xS
- rs = LA.toRows xS
- ref = LA.fromLists
- [ [ let d = rs !! i - rs !! j
- s = (d `LA.dot` d) / (1.0 * 1.0)
- in Kn.kernelFromSqDist Kn.Gaussian s
- | j <- [0 .. 2] ]
- | i <- [0 .. 2] ]
- LA.norm_Inf (gMV - ref) < 1e-12 `shouldBe` True
-
- it "Hanalyze.Model.GP MV: 1D input matches legacy 1D fitGP within 1e-6" $ do
- let xL = [fromIntegral i / 5 | i <- [0 .. 19 :: Int]]
- yL = map sin xL
- tL = [0.5, 1.5, 2.5]
- mdl = GP.GPModel GP.RBF (GP.GPParams 1.0 1.0 0.05 1.0 Nothing)
- legacy = GP.fitGP mdl xL yL tL
- xMV = LA.fromLists (map (:[]) xL) :: LA.Matrix Double
- yMV = LA.fromList yL
- tMV = LA.fromLists (map (:[]) tL) :: LA.Matrix Double
- mv = GP.fitGPMV mdl xMV yMV tMV
- dMu = LA.norm_Inf
- (GP.gpmvMean mv - LA.fromList (GP.gpMean legacy))
- dVr = LA.norm_Inf
- (GP.gpmvVar mv - LA.fromList (GP.gpVar legacy))
- (dMu < 1e-6) `shouldBe` True
- (dVr < 1e-6) `shouldBe` True
-
- it "Hanalyze.Model.GP MV: 2D RBF reaches R² > 0.95 with optimized HP" $ do
- let nN = 50
- gx = [(fromIntegral i / 10, fromIntegral (nN - i) / 10)
- | i <- [0 .. nN - 1 :: Int]]
- ftn (x1, x2) = sin x1 + 0.5 * cos x2
- xMV = LA.fromLists [ [a, b] | (a, b) <- gx ] :: LA.Matrix Double
- yMV = LA.fromList [ ftn p | p <- gx ]
- p0 = GP.GPParams 1.0 1.0 0.01 1.0 Nothing
- po = GP.optimizeGPMV GP.RBF xMV yMV p0
- mdl = GP.GPModel GP.RBF po
- res = GP.fitGPMV mdl xMV yMV xMV
- mu = GP.gpmvMean res
- y = yMV
- ss = LA.sumElements ((y - mu) ** 2)
- mY = LA.sumElements y / fromIntegral nN
- st = LA.sumElements ((y - LA.konst mY nN) ** 2)
- r2 = 1 - ss / st
- (r2 > 0.95) `shouldBe` True
-
- it "Hanalyze.Model.GPRobust MV: 1D input matches legacy fitGPRobust" $ do
- let xL = [fromIntegral i / 5 | i <- [0 .. 14 :: Int]]
- yL = map sin xL
- tL = [0.5, 1.5, 2.5]
- ker = GP.RBF
- ps = GP.GPParams 1.0 1.0 0.05 1.0 Nothing
- lik = GPR.RGaussian 0.1
- legFit = GPR.fitGPRobust ker ps lik xL yL
- legacy = GPR.predictGPRobust legFit tL
- legM = LA.fromList (map fst legacy)
- xMV = LA.fromLists (map (:[]) xL) :: LA.Matrix Double
- yMV = LA.fromList yL
- tMV = LA.fromLists (map (:[]) tL) :: LA.Matrix Double
- mvFit = GPR.fitGPRobustMV ker ps lik xMV yMV
- (mvM, _) = GPR.predictGPRobustMV mvFit tMV
- LA.norm_Inf (mvM - legM) < 1e-6 `shouldBe` True
-
- it "MV gramMatrix on a single-column input agrees with kernelFromSqDist" $ do
- let xs1 = LA.fromLists [[fromIntegral i / 5] | i <- [0 .. 19 :: Int]]
- :: LA.Matrix Double
- gMV2 = Kn.gramMatrixMV Kn.Gaussian 0.4 xs1
- ref = LA.fromLists
- [ [ let xi = xs1 `LA.atIndex` (i, 0)
- xj = xs1 `LA.atIndex` (j, 0)
- d = xi - xj
- in Kn.kernelFromSqDist Kn.Gaussian (d * d / (0.4 * 0.4))
- | j <- [0 .. 19] ]
- | i <- [0 .. 19] ]
- LA.norm_Inf (gMV2 - ref) < 1e-12 `shouldBe` True
-
- describe "Hanalyze.Model.GLMM" $ do
- -- Dataset: 3 groups × 4 obs, strong between-group signal, weak within-group noise.
- -- True: β₀≈5, β₁≈0, u_A≈2, u_B≈0, u_C≈-2, σ²_u≈4, σ²≈small → ICC≈high.
- let df = DX.fromNamedColumns
- [ ("x", DX.fromList ([1,2,3,4, 1,2,3,4, 1,2,3,4] :: [Double]))
- , ("y", DX.fromList ([7.1,6.9,7.0,7.0, 5.0,4.9,5.1,5.0, 3.0,2.9,3.1,3.0] :: [Double]))
- , ("group", DX.fromList (["A","A","A","A","B","B","B","B","C","C","C","C"] :: [T.Text])) ]
- res = fitLMEDataFrame [("x", 1)] "group" "y" df
-
- it "returns Just for valid input" $
- res `shouldSatisfy` (\r -> case r of { Just _ -> True; Nothing -> False })
-
- it "ICC is in [0, 1]" $
- maybe (expectationFailure "expected Just") (\r ->
- glmmICC r `shouldSatisfy` (\v -> v >= 0 && v <= 1)) res
-
- it "ICC is high for strongly grouped data" $
- maybe (expectationFailure "expected Just") (\r ->
- glmmICC r `shouldSatisfy` (> 0.9)) res
-
- it "random variance is positive" $
- maybe (expectationFailure "expected Just") (\r ->
- glmmRandVar r `shouldSatisfy` (> 0)) res
-
- it "residual variance is positive" $
- maybe (expectationFailure "expected Just") (\r ->
- glmmResidVar r `shouldSatisfy` (> 0)) res
-
- it "BLUP count equals number of groups" $
- maybe (expectationFailure "expected Just") (\r ->
- V.length (glmmBLUPs r) `shouldBe` 3) res
-
- it "group labels are sorted" $
- case res of
- Just r -> glmmGroups r `shouldBe` V.fromList ["A","B","C"]
- Nothing -> expectationFailure "expected Just"
-
- it "returns Nothing for missing column" $
- fitLMEDataFrame [("x", 1)] "group" "missing" df
- `shouldSatisfy` (\r -> case r of { Nothing -> True; Just _ -> False })
-
- describe "Hanalyze.Model.GLMM (non-Gaussian)" $ do
- -- Binomial GLMM: 3 hospitals, binary outcome (treatment success)
- -- Strong hospital effect; within each hospital, dose → higher success rate.
- -- True: u_A ≈ +1, u_B ≈ 0, u_C ≈ -1 (on logit scale)
- let dfBin = DX.fromNamedColumns
- [ ("dose", DX.fromList ([1,2,3,4,5, 1,2,3,4,5, 1,2,3,4,5] :: [Double]))
- , ("success", DX.fromList ([1,1,1,1,1, 1,1,0,1,0, 0,0,0,1,0] :: [Double]))
- , ("hospital", DX.fromList (["A","A","A","A","A","B","B","B","B","B","C","C","C","C","C"] :: [T.Text])) ]
- resBin = fitGLMMDataFrame Binomial Logit [("dose", 1)] "hospital" "success" dfBin
-
- it "Binomial GLMM returns Just" $
- resBin `shouldSatisfy` (\r -> case r of { Just _ -> True; Nothing -> False })
-
- it "Binomial ICC in [0, 1]" $
- maybe (expectationFailure "expected Just") (\r ->
- glmmICC r `shouldSatisfy` (\v -> v >= 0 && v <= 1)) resBin
-
- it "Binomial σ²_u is positive" $
- maybe (expectationFailure "expected Just") (\r ->
- glmmRandVar r `shouldSatisfy` (> 0)) resBin
-
- -- Poisson GLMM: 3 regions, count outcome (events per month)
- -- True: β₀ on log scale ≈ 2 (≈7 events baseline), u differs by region.
- let dfPois = DX.fromNamedColumns
- [ ("time", DX.fromList ([1,2,3,4,5, 1,2,3,4,5, 1,2,3,4,5] :: [Double]))
- , ("count", DX.fromList ([15,18,22,20,25, 7,9,8,10,11, 2,3,2,4,3] :: [Double]))
- , ("region", DX.fromList (["X","X","X","X","X","Y","Y","Y","Y","Y","Z","Z","Z","Z","Z"] :: [T.Text])) ]
- resPois = fitGLMMDataFrame Poisson Log [("time", 1)] "region" "count" dfPois
-
- it "Poisson GLMM returns Just" $
- resPois `shouldSatisfy` (\r -> case r of { Just _ -> True; Nothing -> False })
-
- it "Poisson σ²_u is positive" $
- maybe (expectationFailure "expected Just") (\r ->
- glmmRandVar r `shouldSatisfy` (> 0)) resPois
-
- it "Poisson ICC in [0, 1]" $
- maybe (expectationFailure "expected Just") (\r ->
- glmmICC r `shouldSatisfy` (\v -> v >= 0 && v <= 1)) resPois
-
- -- ─────────────────────────────────────────────────────────────────────
- describe "Hanalyze.Design.Orthogonal" $ do
- it "L4 has 4 runs and 3 columns" $ do
- OA.oaRuns OA.l4 `shouldBe` 4
- OA.oaFactors OA.l4 `shouldBe` 3
- length (OA.oaTable OA.l4) `shouldBe` 4
-
- it "L8 has 8 runs and 7 columns" $ do
- OA.oaRuns OA.l8 `shouldBe` 8
- OA.oaFactors OA.l8 `shouldBe` 7
-
- it "L9 has 9 runs and 4 columns at 3 levels each" $ do
- OA.oaRuns OA.l9 `shouldBe` 9
- OA.oaFactors OA.l9 `shouldBe` 4
- OA.oaLevels OA.l9 `shouldBe` [3, 3, 3, 3]
-
- it "L18 has 18 runs and 8 columns (1×2 + 7×3)" $ do
- OA.oaRuns OA.l18 `shouldBe` 18
- OA.oaLevels OA.l18 `shouldBe` 2 : replicate 7 3
-
- it "L8 columns are balanced (each level appears 4 times)" $ do
- let table = OA.oaTable OA.l8
- colJ j = [ row !! j | row <- table ]
- mapM_ (\j -> do
- let cs = colJ j
- length (filter (== 1) cs) `shouldBe` 4
- length (filter (== 2) cs) `shouldBe` 4) [0 .. 6]
-
- it "L8 column pairs are pairwise orthogonal" $ do
- let table = OA.oaTable OA.l8
- colJ j = [ row !! j | row <- table ]
- pairCount j1 j2 a b =
- length (filter id (zipWith (\x y -> x == a && y == b)
- (colJ j1) (colJ j2)))
- -- For 2-level orthogonality: each pair (1,1)/(1,2)/(2,1)/(2,2) must appear equally
- mapM_ (\(j1, j2) -> do
- pairCount j1 j2 1 1 `shouldBe` 2
- pairCount j1 j2 1 2 `shouldBe` 2
- pairCount j1 j2 2 1 `shouldBe` 2
- pairCount j1 j2 2 2 `shouldBe` 2)
- [(0,1),(0,2),(0,3),(1,2),(1,3),(2,3)]
-
- it "lookupOA finds standard arrays case-insensitively" $ do
- OA.oaName <$> OA.lookupOA "L9" `shouldBe` Just "L9(3^4)"
- OA.oaName <$> OA.lookupOA "l9" `shouldBe` Just "L9(3^4)"
- OA.oaName <$> OA.lookupOA "L99" `shouldBe` Nothing
-
- it "assignFactors fills levels correctly for L4" $ do
- let specs = [ OA.FactorSpec "A" [OA.LText "lo", OA.LText "hi"]
- , OA.FactorSpec "B" [OA.LNumeric 0, OA.LNumeric 1]
- ]
- case OA.assignFactors OA.l4 specs of
- Right ad -> do
- length (OA.adRows ad) `shouldBe` 4
- map length (OA.adRows ad) `shouldBe` [2, 2, 2, 2]
- Left e -> expectationFailure (show e)
-
- it "assignFactors rejects too many factors" $ do
- let specs = replicate 5 (OA.FactorSpec "X" [OA.LNumeric 1, OA.LNumeric 2])
- OA.assignFactors OA.l4 specs `shouldSatisfy`
- \r -> case r of { Left _ -> True; Right _ -> False }
-
- it "assignFactors rejects level count mismatch" $ do
- let specs = [ OA.FactorSpec "A" [OA.LText "x"] ] -- only 1 level, L4 needs 2
- OA.assignFactors OA.l4 specs `shouldSatisfy`
- \r -> case r of { Left _ -> True; Right _ -> False }
-
- -- ─────────────────────────────────────────────────────────────────────
- describe "Hanalyze.Design.Taguchi" $ do
- it "smaller-the-better SN: lower y → higher η" $ do
- let etaSmall = TG.snRatio TG.SmallerBetter [0.5, 0.5, 0.5]
- etaLarge = TG.snRatio TG.SmallerBetter [5.0, 5.0, 5.0]
- etaSmall `shouldSatisfy` (> etaLarge)
-
- it "larger-the-better SN: higher y → higher η" $ do
- let etaLarge = TG.snRatio TG.LargerBetter [10, 10, 10]
- etaSmall = TG.snRatio TG.LargerBetter [1, 1, 1]
- etaLarge `shouldSatisfy` (> etaSmall)
-
- it "nominal-the-best SN: high mean / low var → high η" $ do
- let highSN = TG.snRatio TG.NominalBest [10, 10.01, 9.99, 10]
- lowSN = TG.snRatio TG.NominalBest [1, 4, 7, 10]
- highSN `shouldSatisfy` (> lowSN)
-
- it "nominal-target SN: closer to target → higher η" $ do
- let closer = TG.snRatio (TG.NominalBestTarget 5) [4.9, 5.0, 5.1]
- farther = TG.snRatio (TG.NominalBestTarget 5) [3, 5, 7]
- closer `shouldSatisfy` (> farther)
-
- it "snRatio on empty list is 0" $
- TG.snRatio TG.SmallerBetter [] `shouldBe` 0
-
- it "snRatioRows produces same length as input" $ do
- let yMatrix = [[1.0, 2.0], [3.0, 4.0], [5.0, 6.0]]
- length (TG.snRatioRows TG.SmallerBetter yMatrix) `shouldBe` 3
-
- it "analyzeSN gives one FactorEffect per assigned factor" $ do
- let specs = [ OA.FactorSpec "A" [OA.LText "lo", OA.LText "hi"]
- , OA.FactorSpec "B" [OA.LText "lo", OA.LText "hi"]
- , OA.FactorSpec "C" [OA.LText "lo", OA.LText "hi"]
- ]
- Right ad = OA.assignFactors OA.l4 specs
- fes = TG.analyzeSN ad [10, 20, 30, 40]
- length fes `shouldBe` 3
- map TG.feFactor fes `shouldBe` ["A", "B", "C"]
- mapM_ (\fe -> length (TG.feSNByLevel fe) `shouldBe` 2) fes
-
- it "optimalLevels picks max-SN level per factor" $ do
- let specs = [ OA.FactorSpec "A" [OA.LText "lo", OA.LText "hi"]
- , OA.FactorSpec "B" [OA.LText "lo", OA.LText "hi"]
- , OA.FactorSpec "C" [OA.LText "lo", OA.LText "hi"]
- ]
- Right ad = OA.assignFactors OA.l4 specs
- -- L4 row 1 ("hi" for A,B,C) has SN=100; others 0
- sns = [0, 0, 0, 100]
- fes = TG.analyzeSN ad sns
- opts = TG.optimalLevels fes
- length opts `shouldBe` 3
- -- Row 4 has all "hi" by L4 structure (2,2,1) — verify each factor's best
- mapM_ (\(_, _, eta) -> eta `shouldSatisfy` (>= 0)) opts
-
- -- ─────────────────────────────────────────────────────────────────────
- describe "Hanalyze.DataIO.Preprocess" $ do
- let dfNA = DX.fromNamedColumns
- [ ("group", DX.fromList (["A","B","A","B","C"] :: [T.Text]))
- , ("x", DX.fromList (["1","NA","3","","5"] :: [T.Text]))
- , ("y", DX.fromList ([10, 20, 30, 40, 50] :: [Double]))
- ]
-
- it "isNAString detects standard NA strings" $ do
- Pp.isNAString "NA" `shouldBe` True
- Pp.isNAString "N/A" `shouldBe` True
- Pp.isNAString "null" `shouldBe` True
- Pp.isNAString "" `shouldBe` True
- Pp.isNAString " " `shouldBe` True
- Pp.isNAString "valid" `shouldBe` False
-
- it "countMissing counts NAs in Text columns; numeric is 0" $ do
- let counts = Pp.countMissing dfNA
- lookup "x" counts `shouldBe` Just 2
- lookup "y" counts `shouldBe` Just 0
- lookup "group" counts `shouldBe` Just 0
-
- it "dropMissingRows removes rows with NA in target columns" $ do
- let df' = Pp.dropMissingRows ["x"] dfNA
- (n, _) = DX.dimensions df'
- n `shouldBe` 3 -- only rows with x ∈ {"1","3","5"} remain
-
- it "imputeMean converts Text/NA column to Double with mean fill" $ do
- case Pp.imputeMean "x" dfNA of
- Just df' -> do
- let xs = DX.columnAsList (DX.col @Double "x") df'
- length xs `shouldBe` 5
- -- mean of [1, 3, 5] = 3
- (xs !! 1) `shouldBe` 3.0 -- was "NA"
- (xs !! 3) `shouldBe` 3.0 -- was ""
- Nothing -> expectationFailure "imputeMean failed"
-
- it "selectColumns retains only listed columns" $ do
- let df' = Pp.selectColumns ["y", "group"] dfNA
- DX.columnNames df' `shouldMatchList` ["y", "group"]
-
- it "filterRowsByNumeric filters numeric column" $ do
- let df' = Pp.filterRowsByNumeric "y" (>= 30) dfNA
- (n, _) = DX.dimensions df'
- n `shouldBe` 3
-
- it "mapNumeric applies a unary function" $ do
- let df' = Pp.mapNumeric "y" (* 2) dfNA
- xs = DX.columnAsList (DX.col @Double "y") df'
- xs `shouldBe` [20, 40, 60, 80, 100]
-
- -- ─────────────────────────────────────────────────────────────────────
- describe "Hanalyze.DataIO.Preprocess (groupBy)" $ do
- let dfGrp = DX.fromNamedColumns
- [ ("group", DX.fromList (["A","B","A","B","A","C"] :: [T.Text]))
- , ("y", DX.fromList ([1, 4, 3, 6, 5, 10] :: [Double]))
- ]
-
- it "groupByMean computes per-group mean" $ do
- case Pp.groupByMean "group" "y" dfGrp of
- Just df' -> do
- let (n, _) = DX.dimensions df'
- n `shouldBe` 3
- let gs = DX.columnAsList (DX.col @T.Text "group") df'
- vs = DX.columnAsList (DX.col @Double "y") df'
- pairs = zip gs vs
- lookup "A" pairs `shouldBe` Just 3.0 -- (1+3+5)/3
- lookup "B" pairs `shouldBe` Just 5.0 -- (4+6)/2
- lookup "C" pairs `shouldBe` Just 10.0
- Nothing -> expectationFailure "groupByMean failed"
-
- it "groupBySum computes per-group sum" $ do
- case Pp.groupBySum "group" "y" dfGrp of
- Just df' -> do
- let gs = DX.columnAsList (DX.col @T.Text "group") df'
- vs = DX.columnAsList (DX.col @Double "y") df'
- pairs = zip gs vs
- lookup "A" pairs `shouldBe` Just 9.0
- lookup "B" pairs `shouldBe` Just 10.0
- Nothing -> expectationFailure "groupBySum failed"
-
- it "groupByCount counts rows per group" $ do
- case Pp.groupByCount "group" dfGrp of
- Just df' -> do
- let gs = DX.columnAsList (DX.col @T.Text "group") df'
- vs = DX.columnAsList (DX.col @Double "count") df'
- pairs = zip gs vs
- lookup "A" pairs `shouldBe` Just 3.0
- lookup "B" pairs `shouldBe` Just 2.0
- lookup "C" pairs `shouldBe` Just 1.0
- Nothing -> expectationFailure "groupByCount failed"
-
- it "groupByMin/Max return correct extremes" $ do
- case Pp.groupByMin "group" "y" dfGrp of
- Just dfMin -> do
- let gs = DX.columnAsList (DX.col @T.Text "group") dfMin
- vs = DX.columnAsList (DX.col @Double "y") dfMin
- pairs = zip gs vs
- lookup "A" pairs `shouldBe` Just 1.0
- lookup "B" pairs `shouldBe` Just 4.0
- Nothing -> expectationFailure "groupByMin failed"
-
- case Pp.groupByMax "group" "y" dfGrp of
- Just dfMax -> do
- let gs = DX.columnAsList (DX.col @T.Text "group") dfMax
- vs = DX.columnAsList (DX.col @Double "y") dfMax
- pairs = zip gs vs
- lookup "A" pairs `shouldBe` Just 5.0
- lookup "B" pairs `shouldBe` Just 6.0
- Nothing -> expectationFailure "groupByMax failed"
-
- -- ─────────────────────────────────────────────────────────────────────
- describe "Hanalyze.Stat.NumberFormat" $ do
- it "0 → '0.00'" $ NF.fmtNum 0 `shouldBe` "0.00"
- it "中域 (0.01..999) は固定小数点 2 桁" $ do
- NF.fmtNum 0.91 `shouldBe` "0.91"
- NF.fmtNum 12.34 `shouldBe` "12.34"
- NF.fmtNum 998.7 `shouldBe` "998.70"
- it "巨大値は指数表記" $ do
- NF.fmtNum 1.10e13 `shouldBe` "1.10E+13"
- NF.fmtNum 1234.5 `shouldBe` "1.23E+3"
- it "極小値は指数表記" $ do
- NF.fmtNum 3.057e-24 `shouldBe` "3.06E-24"
- NF.fmtNum 0.0099 `shouldBe` "9.90E-3"
- it "負の値" $ do
- NF.fmtNum (-12.34) `shouldBe` "-12.34"
- NF.fmtNum (-1.5e10) `shouldBe` "-1.50E+10"
- it "非有限値" $ do
- NF.fmtNum (0/0) `shouldBe` "NaN"
- NF.fmtNum (1/0) `shouldBe` "+Inf"
- NF.fmtNum (-1/0) `shouldBe` "-Inf"
-
- describe "Hanalyze.Stat.Standardize" $ do
- let xMat = LA.fromLists [[1, 100], [2, 200], [3, 300], [4, 400], [5, 500]] :: LA.Matrix Double
- s = Std.fitStandardizer xMat
- it "fit: 各列の μ が一致" $
- Std.stMu s `shouldSatisfy`
- (\ms -> length ms == 2
- && abs (ms !! 0 - 3) < 1e-9
- && abs (ms !! 1 - 300) < 1e-9)
- it "fit: 各列の σ が不偏分散の平方根 (n-1 正規化)" $
- Std.stSd s `shouldSatisfy`
- (\ss -> length ss == 2
- && abs (ss !! 0 - sqrt 2.5) < 1e-9
- && abs (ss !! 1 - sqrt 25000) < 1e-9)
- it "apply 後は各列 mean≈0, std≈1" $ do
- let x' = Std.applyStandardizer s xMat
- c0 = LA.toColumns x' !! 0
- c1 = LA.toColumns x' !! 1
- mn v = LA.sumElements v / fromIntegral (LA.size v)
- abs (mn c0) `shouldSatisfy` (< 1e-9)
- abs (mn c1) `shouldSatisfy` (< 1e-9)
- it "unapply で元の値に戻る" $ do
- let x' = Std.applyStandardizer s xMat
- x'' = Std.unapplyStandardizer s x'
- d = LA.norm_2 (xMat - x'') :: Double
- d `shouldSatisfy` (< 1e-9)
- it "定数列 (std=0) は std=1 にフォールバック (中央化のみ)" $ do
- let constMat = LA.fromLists [[7, 1], [7, 2], [7, 3]] :: LA.Matrix Double
- s2 = Std.fitStandardizer constMat
- abs (Std.stSd s2 !! 0 - 1.0) `shouldSatisfy` (< 1e-12)
- let x' = Std.applyStandardizer s2 constMat
- c0 = LA.toColumns x' !! 0
- abs (LA.sumElements c0) `shouldSatisfy` (< 1e-9)
-
- describe "Hanalyze.Stat.Interpolate" $ do
- let pts = [(0,0), (1,1), (2,4), (3,9), (4,16)] -- y = x^2
- it "Linear: 観測点で原値を厳密に再現" $ do
- let f = Interp.interp1d Interp.Linear pts
- mapM_ (\(x, y) -> abs (f x - y) `shouldSatisfy` (< 1e-12)) pts
-
- it "NaturalSpline: 観測点で原値を厳密に再現、中間点で線形より精度高い" $ do
- let fl = Interp.interp1d Interp.Linear pts
- fs = Interp.interp1d Interp.NaturalSpline pts
- true x = x * x
- xMid = 1.5
- errL = abs (fl xMid - true xMid)
- errS = abs (fs xMid - true xMid)
- mapM_ (\(x, y) -> abs (fs x - y) `shouldSatisfy` (< 1e-9)) pts
- errS `shouldSatisfy` (< errL)
-
- it "PCHIP: 単調データ ([0,1,2,4,8,16]) で出力も単調" $ do
- let mp = [(0,0), (1,1), (2,2), (3,4), (4,8), (5,16)]
- fp = Interp.interp1d Interp.PCHIP mp
- ys = map fp [0, 0.1 .. 5]
- and (zipWith (<=) ys (tail ys)) `shouldBe` True
-
- it "PCHIP: 観測点で原値を厳密に再現" $ do
- let fp = Interp.interp1d Interp.PCHIP pts
- mapM_ (\(x, y) -> abs (fp x - y) `shouldSatisfy` (< 1e-9)) pts
-
- describe "Hanalyze.Stat.AdaptiveGrid" $ do
- it "uniformGrid: 端点を含み等間隔" $ do
- let g = AG.uniformGrid 5 0 4
- g `shouldBe` [0, 1, 2, 3, 4]
-
- it "Adaptive: 急激な変化付近に grid が集中する (step 関数)" $ do
- -- y は z=0..1 でほぼ平坦、z=1..2 で急激に変化、z=2..3 で再び平坦
- let pts1 = [(z, if z < 1 then 0 else if z < 2 then 10*(z-1) else 10) | z <- [0, 0.1 .. 3]]
- spec = (AG.defaultGridSpec 30) { AG.gsKind = AG.Adaptive }
- g = AG.makeGrid [pts1] (0, 3) spec
- -- 中央領域 [1, 2] にある grid 点数 vs 端領域 [0,1] の grid 点数
- midN = length (filter (\z -> z >= 1 && z <= 2) g)
- edgeN = length (filter (\z -> z < 1) g)
- length g `shouldBe` 30
- midN `shouldSatisfy` (> edgeN)
-
- it "Uniform: 端点 + 等間隔" $ do
- let g = AG.makeGrid [] (0, 1) ((AG.defaultGridSpec 6) { AG.gsKind = AG.Uniform })
- length g `shouldBe` 6
- head g `shouldBe` 0
- last g `shouldBe` 1
-
- it "N < 10 で adaptive 指定でも uniform にフォールバック" $ do
- let pts1 = [(z, sin z) | z <- [0, 0.1 .. 3]]
- spec = (AG.defaultGridSpec 5) { AG.gsKind = AG.Adaptive }
- g = AG.makeGrid [pts1] (0, 3) spec
- gU = AG.uniformGrid 5 0 3
- g `shouldBe` gU
-
- describe "Hanalyze.Model.RFF (multivariate, Phase B-RFF)" $ do
- it "logMarginalLikRBFMV: 既知 ℓ で最大化される (合成データで)" $ do
- -- y = sin(x) (1D) で ℓ をスキャンし、データの z-score 後の長さスケールに
- -- 近い値で marg-lik が最大になることを確認。
- let xs = [0.0, 0.3 .. 6.0]
- ys = map sin xs
- xMat = LA.fromLists [[x] | x <- xs]
- yV = LA.fromList ys
- ells = [0.05, 0.2, 0.5, 1.0, 2.0, 5.0]
- mliks = [ RFF.logMarginalLikRBFMV xMat yV ell 1.0 0.05 | ell <- ells ]
- best = snd (maximum (zip mliks ells))
- best `shouldSatisfy` (\b -> b >= 0.2 && b <= 2.0)
- it "loocvRFFRidgeMV: λ → ∞ で残差ベース LOOCV が増える、適度な λ で最小" $ do
- let xs = [0.0, 0.3 .. 6.0]
- ys = map sin xs
- xMat = LA.fromLists [[x] | x <- xs]
- yV = LA.fromList ys
- gen <- MWC.createSystemRandom
- feats <- RFF.sampleRFFRBFMV 1 64 0.5 1.0 gen
- let lamSmall = RFF.loocvRFFRidgeMV feats xMat yV 1e-2
- lamHuge = RFF.loocvRFFRidgeMV feats xMat yV 1e6
- lamSmall `shouldSatisfy` (< lamHuge)
- it "gridSearchLOOCVRBFMV: ℓ/λ を自動探索して LOOCV が小さくなる" $ do
- let xs = [0.0, 0.5 .. 10.0]
- ys = [ sin (x/2) | x <- xs ]
- xMat = LA.fromLists [[x] | x <- xs]
- yV = LA.fromList ys
- gen <- MWC.createSystemRandom
- res <- RFF.gridSearchLOOCVRBFMV 1 100 xMat yV (Just (4, 8)) gen
- RFF.lcLOOCV res `shouldSatisfy` (< 1.0)
- RFF.lcEll res `shouldSatisfy` (> 0)
- it "maximizeMarginalLikRBFMV: 雑音ありデータで mlik が改善する" $ do
- let xs = [0.0, 0.5 .. 10.0]
- ys = [ sin (x/2) + 0.05 * (fromIntegral i / 21) - 0.025
- | (i, x) <- zip [0::Int ..] xs ]
- xMat = LA.fromLists [[x] | x <- xs]
- yV = LA.fromList ys
- res = RFF.maximizeMarginalLikRBFMV xMat yV (Just (8, 4, 4))
- -- 最適 mlik > 任意の "ヘンな" 値 (ℓ=100, σ_n=10) より高い
- weak = RFF.logMarginalLikRBFMV xMat yV 100 1.0 10.0
- RFF.mlLogMlik res `shouldSatisfy` (> weak)
- RFF.mlEll res `shouldSatisfy` (> 0)
- RFF.mlSigmaN res `shouldSatisfy` (> 0)
-
- it "rffRidgeMV: y = x1 * t を完全にフィット" $ do
- let xs = [(x1, t) | x1 <- [1, 2, 3, 5, 7], t <- [1..10]]
- xss = [[x1, t] | (x1, t) <- xs]
- ys = [x1 * t | (x1, t) <- xs]
- xMat = LA.fromLists xss
- gen <- MWC.createSystemRandom
- feats <- RFF.sampleRFFRBFMV 2 256 1.0 1.0 gen
- let fit = RFF.rffRidgeMV feats xMat ys 0.001
- yhat = RFF.predictRFFRidgeMV fit xMat
- rmse = sqrt (sum (zipWith (\a b -> (a-b)*(a-b)) ys yhat)
- / fromIntegral (length ys))
- rmse `shouldSatisfy` (< 1.0)
-
- describe "Hanalyze.Model.RFF" $ do
- it "feature matrix has correct shape" $ do
- gen <- MWC.createSystemRandom
- feats <- RFF.sampleRFFRBF 50 1.0 1.0 gen
- RFF.rffDim feats `shouldBe` 50
- let phi = RFF.rffFeatures feats [0.0, 1.0, 2.0]
- -- phi is n × D = 3 × 50
- V.length (V.fromList [0::Int]) `shouldBe` 1 -- placeholder for typing
- -- We can't easily check matrix shape without hmatrix import here,
- -- so just ensure the function doesn't crash.
- length (RFF.rffOmegas feats) `shouldSatisfy` (== 50)
- let _ = phi
- return ()
-
- it "RFF Ridge fits y ≈ x reasonably" $ do
- gen <- MWC.createSystemRandom
- feats <- RFF.sampleRFFRBF 100 1.0 1.0 gen
- let xs = [0.0, 0.1 .. 1.0]
- ys = map (\x -> 2 * x + 0.5) xs
- fit = RFF.rffRidge feats xs ys 0.001
- yhat = RFF.predictRFFRidge fit xs
- rmse = sqrt (sum [ (y - yh) ^ (2 :: Int)
- | (y, yh) <- zip ys yhat ]
- / fromIntegral (length ys))
- rmse `shouldSatisfy` (< 0.5)
-
- -- ─────────────────────────────────────────────────────────────────────
- describe "Hanalyze.Model.GPRobust" $ do
- it "Cauchy GP is more accurate than Gaussian GP under outliers" $ do
- let trueF x = sin x
- xs = [0.0, 0.5 .. 6.0]
- cleanY = map trueF xs
- -- Inject outlier at index 5
- ys = zipWith (\i y -> if i == 5 then y + 5 else y)
- [0::Int ..] cleanY
- hp = GP.GPParams 1.0 1.0 0.05 1.0 Nothing
- gpRes = GP.fitGP (GP.GPModel GP.RBF hp) xs ys xs
- gaussRMSE = sqrt (sum [ (a - b) ^ (2::Int)
- | (a, b) <- zip cleanY (GP.gpMean gpRes) ]
- / fromIntegral (length xs))
- cauchyFit = GPR.fitGPRobust GP.RBF hp (GPR.RCauchy 0.5) xs ys
- cauchyPred = GPR.predictGPRobust cauchyFit xs
- cauchyRMSE = sqrt (sum [ (a - b) ^ (2::Int)
- | (a, (b, _)) <- zip cleanY cauchyPred ]
- / fromIntegral (length xs))
- cauchyRMSE `shouldSatisfy` (< gaussRMSE)
-
- it "IRLS converges in finite iterations" $ do
- let xs = [0.0, 1.0, 2.0, 3.0, 4.0]
- ys = [0.1, 1.05, 1.95, 2.9, 4.1]
- hp = GP.GPParams 1.0 1.0 0.1 1.0 Nothing
- fit = GPR.fitGPRobust GP.RBF hp (GPR.RStudentT 4 0.5) xs ys
- GPR.rgpIters fit `shouldSatisfy` (\n -> n > 0 && n <= 50)
-
- describe "Hanalyze.DataIO.Log" $ do
- it "Monoid: noLog <> r == r" $ do
- let r = Log.logReport (Log.mkWarn "W001" "msg" Nothing)
- Log.entries (Log.noLog <> r) `shouldBe` Log.entries r
- Log.entries (r <> Log.noLog) `shouldBe` Log.entries r
- it "addEntry appends" $ do
- let r0 = Log.logReport (Log.mkInfo "I001" "first" Nothing)
- r1 = Log.addEntry (Log.mkWarn "W001" "second" (Just "ヒント")) r0
- length (Log.entries r1) `shouldBe` 2
- Log.lgSev (last (Log.entries r1)) `shouldBe` Log.Warn
- Log.lgHint (last (Log.entries r1)) `shouldBe` Just "ヒント"
- it "hasErrors / hasWarnings detect severity" $ do
- let rW = Log.logReport (Log.mkWarn "W" "w" Nothing)
- rE = Log.logReport (Log.mkErr "E" "e" Nothing)
- Log.hasWarnings rW `shouldBe` True
- Log.hasErrors rW `shouldBe` False
- Log.hasErrors (rW <> rE) `shouldBe` True
- it "severityCount counts each level" $ do
- let r = Log.logReport (Log.mkInfo "I" "i" Nothing)
- <> Log.logReport (Log.mkWarn "W1" "w" Nothing)
- <> Log.logReport (Log.mkWarn "W2" "w" Nothing)
- <> Log.logReport (Log.mkErr "E" "e" Nothing)
- Log.severityCount Log.Info r `shouldBe` 1
- Log.severityCount Log.Warn r `shouldBe` 2
- Log.severityCount Log.Err r `shouldBe` 1
- it "prettyEntry: includes code, message, hint" $ do
- let s = Log.prettyEntry (Log.mkWarn "W042" "壊れている" (Just "助言"))
- T.isInfixOf "[WARN]" s `shouldBe` True
- T.isInfixOf "W042" s `shouldBe` True
- T.isInfixOf "壊れている" s `shouldBe` True
- T.isInfixOf "助言" s `shouldBe` True
-
- describe "Hanalyze.DataIO.CSV.loadAutoSafe" $ do
- it "Empty file → Left, no exception" $
- withSystemTempFile "ha-empty.csv" $ \fp h -> do
- hPutStr h ""
- hClose h
- r <- CSV.loadAutoSafe fp
- case r of
- Left msg -> T.isInfixOf "Empty" (T.pack msg) `shouldBe` True
- Right _ -> expectationFailure "expected Left for empty file"
- it "Header-only file → Left" $
- withSystemTempFile "ha-hdr.csv" $ \fp h -> do
- hPutStr h "x,y,z\n"
- hClose h
- r <- CSV.loadAutoSafe fp
- case r of
- Left msg -> T.isInfixOf "header" (T.pack msg) `shouldBe` True
- Right _ -> expectationFailure "expected Left for header-only file"
- it "Valid CSV → Right with empty log by default" $
- withSystemTempFile "ha-ok.csv" $ \fp h -> do
- hPutStr h "x,y\n1,2\n3,4\n"
- hClose h
- r <- CSV.loadAutoSafe fp
- case r of
- Left msg -> expectationFailure ("unexpected Left: " ++ msg)
- Right (_, lg) -> Log.entries lg `shouldBe` []
-
- describe "Hanalyze.DataIO.Convert deep-eval" $ do
- it "getMaybeTextVec on text column with mixed NA strings returns Just" $
- withSystemTempFile "ha-na.csv" $ \fp h -> do
- -- 複数 NA 表現を混ぜると Hackage は Maybe Text 列として保持する。
- -- ヘッダ判定で n/a / null は欠損扱い → null bitmap が立つ。
- hPutStr h "id,score\n1,A\n2,n/a\n3,null\n4,B\n5,-\n"
- hClose h
- r <- CSV.loadAutoSafe fp
- case r of
- Right (df, _) -> case Conv.getMaybeTextVec "score" df of
- Just v -> length (V.toList v) `shouldBe` 5
- Nothing -> expectationFailure "getMaybeTextVec returned Nothing"
- Left msg -> expectationFailure ("load failed: " ++ msg)
- it "getDoubleVec returns Nothing without crashing on NA-mixed numeric column" $
- withSystemTempFile "ha-na2.csv" $ \fp h -> do
- hPutStr h "id,score\n1,85\n2,NA\n3,92\n"
- hClose h
- r <- CSV.loadAutoSafe fp
- case r of
- Right (df, _) -> Conv.getDoubleVec "score" df `shouldBe` Nothing
- Left msg -> expectationFailure ("load failed: " ++ msg)
-
- describe "Hanalyze.DataIO.Health" $ do
- it "W001: ヘッダ無し疑い (列名が全て数値)" $ do
- let df = DX.insertColumn "1.0" (DX.fromList ([2.0, 4.0] :: [Double]))
- $ DX.insertColumn "2.0" (DX.fromList ([4.1, 8.0] :: [Double]))
- $ DX.empty
- codes = map Log.lgCode (Log.entries (Health.detectHeaderless df))
- codes `shouldContain` ["W001"]
- it "W001 は通常ヘッダでは発火しない" $ do
- let df = DX.insertColumn "x" (DX.fromList ([1.0, 2.0] :: [Double]))
- $ DX.empty
- Log.entries (Health.detectHeaderless df) `shouldBe` []
- it "W002: コメント行 (# 始まり) を検出" $ do
- let preview = "# header comment\n# more comment\nx,y\n1,2\n"
- codes = map Log.lgCode (Log.entries (Health.detectCommentLines preview))
- codes `shouldContain` ["W002"]
- it "W005: 1 列 DataFrame + プレビューにタブ → delimiter ミスマッチ" $ do
- let df = DX.insertColumn "x\ty" (DX.fromList ([1.0] :: [Double]))
- $ DX.empty
- preview = "x\ty\n1\t2\n3\t4\n"
- codes = map Log.lgCode
- (Log.entries (Health.detectDelimiterMismatch preview df))
- codes `shouldContain` ["W005"]
- it "W008: 通貨記号付き列を検出" $ do
- let df = DX.insertColumn "price"
- (DX.fromList (["$1,234.56", "$2,500.00", "$3,000.00", "$4,000"] :: [T.Text]))
- $ DX.empty
- codes = map Log.lgCode (Log.entries (Health.detectThousandsCurrency df))
- codes `shouldContain` ["W008"]
- -- BS インポートを使う何かのスモーク (未使用 warning 防止)
- it "preview is non-empty for typical use" $
- BS.length "x,y\n1,2" `shouldSatisfy` (> 0)
-
- describe "Hanalyze.DataIO.CSV.loadAutoSafeWith" $ do
- it "--no-header: 先頭行をデータ行として扱い col0... を生成" $
- withSystemTempFile "ha-noh.csv" $ \fp h -> do
- hPutStr h "1,2\n3,4\n5,6\n"
- hClose h
- r <- CSV.loadAutoSafeWith
- (CSV.defaultLoadOpts { CSV.loNoHeader = True }) fp
- case r of
- Left e -> expectationFailure ("unexpected Left: " ++ e)
- Right (df, lg) -> do
- let cols = DX.columnNames df
- cols `shouldBe` ["col0", "col1"]
- map Log.lgCode (Log.entries lg) `shouldContain` ["I012"]
- it "--skip 2: 先頭 2 行を skip" $
- withSystemTempFile "ha-skip.csv" $ \fp h -> do
- hPutStr h "# c1\n# c2\nx,y\n1,2\n3,4\n"
- hClose h
- r <- CSV.loadAutoSafeWith
- (CSV.defaultLoadOpts { CSV.loSkip = 2 }) fp
- case r of
- Left e -> expectationFailure ("unexpected Left: " ++ e)
- Right (df, _) -> DX.columnNames df `shouldBe` ["x", "y"]
- it "sniff: ヘッダ無し CSV を自動推論で col0... に変える" $
- withSystemTempFile "ha-sniff-noh.csv" $ \fp h -> do
- hPutStr h "1.0,2.0\n3.0,4.0\n"
- hClose h
- r <- CSV.loadAutoSafeWith CSV.defaultLoadOpts fp
- case r of
- Left e -> expectationFailure ("unexpected Left: " ++ e)
- Right (df, lg) -> do
- DX.columnNames df `shouldBe` ["col0", "col1"]
- map Log.lgCode (Log.entries lg) `shouldContain` ["I013"]
- it "sniff: コメント行 # を skip 推論" $
- withSystemTempFile "ha-sniff-skip.csv" $ \fp h -> do
- hPutStr h "# comment 1\n# comment 2\nx,y\n1,2\n3,4\n"
- hClose h
- r <- CSV.loadAutoSafeWith CSV.defaultLoadOpts fp
- case r of
- Left e -> expectationFailure ("unexpected Left: " ++ e)
- Right (df, _) -> DX.columnNames df `shouldBe` ["x", "y"]
- it "sniff: セミコロン区切りを自動検出" $
- withSystemTempFile "ha-sniff-semi.csv" $ \fp h -> do
- hPutStr h "a;b;c\n1;2;3\n4;5;6\n"
- hClose h
- r <- CSV.loadAutoSafeWith CSV.defaultLoadOpts fp
- case r of
- Left e -> expectationFailure ("unexpected Left: " ++ e)
- Right (df, _) -> DX.columnNames df `shouldBe` ["a", "b", "c"]
- it "sniff: --no-sniff で自動推論を切れる" $
- withSystemTempFile "ha-no-sniff.csv" $ \fp h -> do
- hPutStr h "1.0,2.0\n3.0,4.0\n"
- hClose h
- r <- CSV.loadAutoSafeWith
- (CSV.defaultLoadOpts { CSV.loSniff = False }) fp
- case r of
- Left e -> expectationFailure ("unexpected Left: " ++ e)
- Right (df, lg) -> do
- -- ヘッダ無しの自動修復は走らないので col0 にはならない
- DX.columnNames df `shouldBe` ["1.0", "2.0"]
- -- 代わりに W001 が出る
- map Log.lgCode (Log.entries lg) `shouldContain` ["W001"]
-
- it "Clean.stripUnitsCol: 12.3kg → 12.3" $ do
- let df0 = DX.insertColumn "w"
- (DX.fromList (["12.3kg", "11.5cm", "10kg"] :: [T.Text]))
- $ DX.empty
- (df1, lg) = Clean.applyRule Clean.StripUnits "w" df0
- map Log.lgCode (Log.entries lg) `shouldContain` ["I100"]
- case Conv2.getDoubleVec "w" df1 of
- Just v -> V.toList v `shouldBe` [12.3, 11.5, 10.0]
- Nothing -> expectationFailure "expected numeric column"
- it "Clean.parseCurrencyCol: $1,234.56 → 1234.56" $ do
- let df0 = DX.insertColumn "p"
- (DX.fromList (["$1,234.56", "$2,500.00"] :: [T.Text]))
- $ DX.empty
- (df1, _) = Clean.applyRule Clean.ParseCurrency "p" df0
- case Conv2.getDoubleVec "p" df1 of
- Just v -> V.toList v `shouldBe` [1234.56, 2500.0]
- Nothing -> expectationFailure "expected numeric column"
- it "Clean.coerceNumericCol: 混在パターンを最大限拾う" $ do
- let df0 = DX.insertColumn "x"
- (DX.fromList (["12.3", "12.3kg", "$1,000"] :: [T.Text]))
- $ DX.empty
- (df1, _) = Clean.applyRule Clean.CoerceNumeric "x" df0
- case Conv2.getDoubleVec "x" df1 of
- Just v -> V.toList v `shouldBe` [12.3, 12.3, 1000.0]
- Nothing -> expectationFailure "expected all-success column"
- it "Preprocess.meltLonger: wide → long、NA セルは除外、列名を Double に parse" $ do
- let df0 = DX.insertColumn "id" (DX.fromList (["a", "b"] :: [T.Text]))
- $ DX.insertColumn "1" (DX.fromList ([Just 10.0, Nothing] :: [Maybe Double]))
- $ DX.insertColumn "2" (DX.fromList ([Just 20.0, Just 30.0] :: [Maybe Double]))
- $ DX.insertColumn "3" (DX.fromList ([Nothing, Just 60.0] :: [Maybe Double]))
- $ DX.empty
- df1 = Pp.meltLonger ["id"] ["1", "2", "3"] "t" "y" True df0
- (nrows, ncols) = DX.dimensions df1
- nrows `shouldBe` 4 -- a,1=10; a,2=20; b,2=30; b,3=60
- ncols `shouldBe` 3 -- id, t, y
- DX.columnNames df1 `shouldMatchList` ["id", "t", "y"]
- case Conv2.getDoubleVec "y" df1 of
- Just v -> sort (V.toList v) `shouldBe` [10, 20, 30, 60]
- Nothing -> expectationFailure "expected y as numeric"
- case Conv2.getDoubleVec "t" df1 of
- Just v -> sort (V.toList v) `shouldBe` [1, 2, 2, 3]
- Nothing -> expectationFailure "expected t parsed as numeric"
-
- it "Preprocess.regridLong: ZIntersection モードで全 id が共通範囲に収まる" $ do
- -- id=a: z=0..3, id=b: z=1..4 → intersection は (1, 3)
- let df0 = DX.insertColumn "id" (DX.fromList (["a","a","a","a","b","b","b","b"] :: [T.Text]))
- $ DX.insertColumn "z" (DX.fromList ([0,1,2,3,1,2,3,4] :: [Double]))
- $ DX.insertColumn "y" (DX.fromList ([0,1,4,9,1,4,9,16] :: [Double]))
- $ DX.empty
- opts = Pp.defaultRegridOpts
- { Pp.roN = 5, Pp.roZBoundsMode = Pp.ZIntersection
- , Pp.roGridKind = AG.Uniform }
- rr = Pp.regridLong "id" "z" "y" opts df0
- Pp.rrZMin rr `shouldBe` 1.0
- Pp.rrZMax rr `shouldBe` 3.0
- length (Pp.rrZGrid rr) `shouldBe` 5
- length (Pp.rrIds rr) `shouldBe` 2
-
- it "Preprocess.regridLong: ZUnion モードで [min,max] が和集合になる" $ do
- let df0 = DX.insertColumn "id" (DX.fromList (["a","a","b","b"] :: [T.Text]))
- $ DX.insertColumn "z" (DX.fromList ([0,2,1,3] :: [Double]))
- $ DX.insertColumn "y" (DX.fromList ([0,4,1,9] :: [Double]))
- $ DX.empty
- opts = Pp.defaultRegridOpts
- { Pp.roN = 4, Pp.roZBoundsMode = Pp.ZUnion
- , Pp.roGridKind = AG.Uniform }
- rr = Pp.regridLong "id" "z" "y" opts df0
- Pp.rrZMin rr `shouldBe` 0.0
- Pp.rrZMax rr `shouldBe` 3.0
- -- 外挿が記録される (id=a の上端 0..2、共通 0..3 → above=1)
- let stat_a = head [s | s <- Pp.rrPerIdStats rr, Pp.piId s == "a"]
- Pp.piExtrapAbove stat_a `shouldBe` 1.0
-
- it "Clean.cleanPipeline: 複数列を一括変換" $ do
- let df0 = DX.insertColumn "p"
- (DX.fromList (["$10", "$20"] :: [T.Text]))
- $ DX.insertColumn "w"
- (DX.fromList (["1kg", "2kg"] :: [T.Text]))
- $ DX.empty
- rules = [("p", Clean.ParseCurrency), ("w", Clean.StripUnits)]
- (df1, lg) = Clean.cleanPipeline rules df0
- codes = map Log.lgCode (Log.entries lg)
- codes `shouldContain` ["I101"]
- codes `shouldContain` ["I100"]
- Conv2.getDoubleVec "p" df1 `shouldSatisfy` \mv ->
- case mv of { Just v -> V.toList v == [10, 20]; Nothing -> False }
-
- it "--strict + 警告ありデータ (sniff off) → Left" $
- withSystemTempFile "ha-strict.csv" $ \fp h -> do
- hPutStr h "1.0,2.0\n3.0,4.0\n" -- ヘッダ無し疑い W001
- hClose h
- -- sniff を切ると W001 が残るので strict が短絡する
- r <- CSV.loadAutoSafeWith
- (CSV.defaultLoadOpts { CSV.loStrict = True
- , CSV.loSniff = False }) fp
- case r of
- Left _ -> return ()
- Right _ -> expectationFailure "expected Left under --strict --no-sniff"
-
- -- ===========================================================================
- -- 多出力 API の q=1 等価性 (M1〜M8)
- -- ===========================================================================
- describe "Multi-output equivalence (q=1)" $ do
- let xs = LA.fromLists [[1,1.0], [1,2.0], [1,3.0], [1,4.0], [1,5.0]] :: LA.Matrix Double
- yV = LA.fromList [2.1, 3.9, 6.0, 8.1, 10.0] :: LA.Vector Double
- yM = LA.asColumn yV
- approx tol a b = abs (a - b) < tol
- approxList tol as bs = length as == length bs &&
- all (uncurry (approx tol)) (zip as bs)
- buildGroupsLocal gvec =
- let lbls = V.fromList . sort . foldr (\x acc -> if x `elem` acc then acc else x:acc) [] $ V.toList gvec
- qN = V.length lbls
- idxFor x = case V.elemIndex x lbls of
- Just i -> i
- Nothing -> 0
- idx = V.map idxFor gvec
- sz = V.fromList [ V.length (V.filter (== j) idx) | j <- [0 .. qN - 1] ]
- in (lbls, idx, sz)
-
- it "M1 Regularized Ridge: fitRegularized == fitRegularizedMulti col 0" $ do
- let single = Reg.fitRegularized (Reg.L2 0.1) xs yV
- multi = Reg.fitRegularizedMulti (Reg.L2 0.1) xs yM
- extr = Reg.regFitFromMulti 0 multi
- approxList 1e-9 (LA.toList (Reg.rfBeta single))
- (LA.toList (Reg.rfBeta extr))
- `shouldBe` True
-
- it "M1 Regularized Lasso: q=1 一致" $ do
- let single = Reg.fitRegularized (Reg.L1 0.05) xs yV
- multi = Reg.fitRegularizedMulti (Reg.L1 0.05) xs yM
- extr = Reg.regFitFromMulti 0 multi
- approxList 1e-9 (LA.toList (Reg.rfBeta single))
- (LA.toList (Reg.rfBeta extr))
- `shouldBe` True
-
- it "M2 Spline: fitSpline == fitSplineMulti col 0" $ do
- let xv = V.fromList [1,2,3,4,5,6,7,8,9,10] :: V.Vector Double
- yv = V.fromList (map (\x -> sin (x/2) + 0.01*x) (V.toList xv))
- knots = [1,3,5,7,10]
- single = Sp.fitSpline (Sp.BSpline 3) knots xv yv
- ymat = LA.asColumn (LA.fromList (V.toList yv))
- multi = Sp.fitSplineMulti (Sp.BSpline 3) knots xv ymat
- colS = LA.toList (Sp.sfBeta single)
- colM = LA.toList (LA.flatten (Sp.smfBeta multi LA.¿ [0]))
- approxList 1e-9 colS colM `shouldBe` True
-
- it "M3 Kernel Ridge: kernelRidge == kernelRidgeMulti col 0" $ do
- let xv = V.fromList [0.0,1,2,3,4,5,6,7,8,9] :: V.Vector Double
- yv = V.fromList [0.0, 0.5, 1.0, 1.4, 1.7, 1.9, 2.0, 2.0, 1.95, 1.8]
- single = K.kernelRidge K.Gaussian 1.0 0.01 xv yv
- ymat = LA.asColumn (LA.fromList (V.toList yv))
- multi = K.kernelRidgeMulti K.Gaussian 1.0 0.01 xv ymat
- approxList 1e-9 (LA.toList (K.krAlpha single))
- (LA.toList (LA.flatten (K.krmAlpha multi LA.¿ [0])))
- `shouldBe` True
-
- it "M3 Kernel NW: nwRegression == nwRegressionMulti col 0" $ do
- let xv = V.fromList [0.0,1,2,3,4,5,6,7,8,9] :: V.Vector Double
- yv = V.fromList [0.1, 0.3, 0.7, 1.0, 1.5, 1.9, 2.0, 1.95, 1.8, 1.5]
- xn = V.fromList [0.5, 2.5, 5.5, 8.5]
- single = K.nwRegression K.Gaussian 1.0 xv yv xn
- ymat = LA.asColumn (LA.fromList (V.toList yv))
- multi = K.nwRegressionMulti K.Gaussian 1.0 xv ymat xn
- colM = LA.toList (LA.flatten (multi LA.¿ [0]))
- approxList 1e-9 (V.toList single) colM `shouldBe` True
-
- it "M4 RFF Ridge: rffRidge == rffRidgeMulti col 0" $ do
- gen <- MWC.create
- rff <- RFF.sampleRFFRBF 16 1.0 1.0 gen
- let xList = [0.0, 1, 2, 3, 4, 5]
- yList = [0.1, 0.5, 1.0, 1.4, 1.7, 1.9]
- single = RFF.rffRidge rff xList yList 0.01
- ymat = LA.asColumn (LA.fromList yList)
- multi = RFF.rffRidgeMulti rff xList ymat 0.01
- approxList 1e-9 (LA.toList (RFF.rffrWeights single))
- (LA.toList (LA.flatten (RFF.rffrmWeights multi LA.¿ [0])))
- `shouldBe` True
-
- it "M5 GP: fitGP mean == fitGPMulti col 0" $ do
- let model = GP.GPModel GP.RBF GP.defaultGPParams
- trX = [0.0, 1, 2, 3, 4, 5]
- trY = [0.1, 0.4, 0.9, 1.3, 1.6, 1.8]
- tsX = [0.5, 2.5, 4.5]
- single = GP.fitGP model trX trY tsX
- ymat = LA.asColumn (LA.fromList trY)
- (mMat, _) = GP.fitGPMulti model trX ymat tsX
- approxList 1e-9 (GP.gpMean single)
- (LA.toList (LA.flatten (mMat LA.¿ [0])))
- `shouldBe` True
-
- it "M5 GPRobust: fitGPRobust α == fitGPRobustMulti col 0" $ do
- let params = GP.defaultGPParams
- trX = [0.0, 1, 2, 3, 4, 5]
- trY = [0.1, 0.4, 5.0, 1.3, 1.6, 1.8] -- 1 outlier at idx 2
- single = GPR.fitGPRobust GP.RBF params (GPR.RStudentT 4 0.3) trX trY
- ymat = LA.asColumn (LA.fromList trY)
- multi = GPR.fitGPRobustMulti GP.RBF params (GPR.RStudentT 4 0.3) trX ymat
- firstFit = head (GPR.rgmFits multi)
- approxList 1e-9 (LA.toList (GPR.rgpAlpha single))
- (LA.toList (GPR.rgpAlpha firstFit))
- `shouldBe` True
-
- it "M6 GLM Gaussian: fitGLM == fitGLMMulti col 0" $ do
- let single = GLM.fitGLM GLM.Gaussian xs yV
- multi = GLM.fitGLMMulti GLM.Gaussian GLM.Identity xs yM
- colM = LA.toList (LA.flatten (GLM.gfmBeta multi LA.¿ [0]))
- colS = LA.toList (LA.flatten (Core.coefficients single))
- approxList 1e-7 colS colM `shouldBe` True
-
- it "M7 LME: fitLME == fitLMEMulti col 0" $ do
- let xMat = LA.fromLists
- [[1,1],[1,2],[1,3],[1,4],
- [1,1],[1,2],[1,3],[1,4],
- [1,1],[1,2],[1,3],[1,4]] :: LA.Matrix Double
- y1 = LA.fromList [7.1,6.9,7.0,7.0, 5.0,4.9,5.1,5.0, 3.0,2.9,3.1,3.0]
- ym = LA.asColumn y1
- gv = V.fromList (["A","A","A","A","B","B","B","B","C","C","C","C"] :: [T.Text])
- (lbls, idx, sz) = buildGroupsLocal gv
- single = fitLME xMat y1 idx lbls sz
- multi = fitLMEMulti xMat ym idx lbls sz
- firstM = head (glmmFits multi)
- glmmRandVar firstM `shouldSatisfy` approx 1e-9 (glmmRandVar single)
-
- -- ===========================================================================
- -- 単目的オプティマイザ (Hanalyze.Optim.NelderMead)
- -- ===========================================================================
- describe "Hanalyze.Optim.NelderMead" $ do
- let l2 :: [Double] -> [Double] -> Double
- l2 a b = sqrt (sum (zipWith (\x y -> (x-y)^(2::Int)) a b))
- sphere xs = sum [x*x | x <- xs]
- rosenbrock [x, y] = (1 - x)^(2::Int) + 100 * (y - x*x)^(2::Int)
- rosenbrock _ = error "rosenbrock: 2D only"
-
- it "minimises sphere f(x)=Σx² to ~0 from x0=[3,-2,1]" $ do
- r <- NM.runNelderMead sphere [3, -2, 1]
- OC.orValue r `shouldSatisfy` (< 1e-6)
-
- it "minimises Rosenbrock 2D to (1,1) within 0.05" $ do
- let cfg = NM.defaultNMConfig
- { NM.nmStop = OC.defaultStopCriteria { OC.stMaxIter = 5000 } }
- r <- NM.runNelderMeadWith cfg rosenbrock [-1.2, 1.0]
- l2 (OC.orBest r) [1, 1] `shouldSatisfy` (< 0.05)
-
- it "Maximize: -sphere has optimum 0 at origin" $ do
- let cfg = NM.defaultNMConfig { NM.nmDir = OC.Maximize }
- r <- NM.runNelderMeadWith cfg (\xs -> negate (sphere xs)) [3, -2, 1]
- -- Maximize: orValue は元尺度 (= negate sphere の最大値、すなわち 0 に近い)
- OC.orValue r `shouldSatisfy` (\v -> v > -1e-6)
- -- 最良点は原点近傍
- l2 (OC.orBest r) [0, 0, 0] `shouldSatisfy` (< 1e-2)
-
- -- ===========================================================================
- -- 単目的オプティマイザ (Hanalyze.Optim.LBFGS)
- -- ===========================================================================
- describe "Hanalyze.Optim.LBFGS" $ do
- let l2 :: [Double] -> [Double] -> Double
- l2 a b = sqrt (sum (zipWith (\x y -> (x-y)^(2::Int)) a b))
- sphere xs = sum [x*x | x <- xs]
- sphereGrad xs = [2*x | x <- xs]
- rosen [x, y] = (1-x)^(2::Int) + 100*(y - x*x)^(2::Int)
- rosen _ = error "rosen: 2D"
- rosenGrad [x, y] =
- [ -2*(1-x) - 400*x*(y - x*x), 200*(y - x*x) ]
- rosenGrad _ = error "rosenGrad: 2D"
-
- it "minimises sphere 5D with analytic grad to ~0" $ do
- r <- LBFGS.runLBFGS sphere sphereGrad [3, -2, 1, 0.5, -1.5]
- OC.orValue r `shouldSatisfy` (< 1e-8)
-
- it "minimises Rosenbrock 2D within 0.01 of (1,1)" $ do
- let cfg = LBFGS.defaultLBFGSConfig
- { LBFGS.lbStop = OC.defaultStopCriteria { OC.stMaxIter = 500 } }
- r <- LBFGS.runLBFGSWith cfg rosen rosenGrad [-1.2, 1.0]
- l2 (OC.orBest r) [1, 1] `shouldSatisfy` (< 0.01)
-
- it "numeric gradient: sphere 30D converges" $ do
- let x0 = take 30 (cycle [1.5, -2.0, 0.5])
- r <- LBFGS.runLBFGSNumeric LBFGS.defaultLBFGSConfig sphere x0
- OC.orValue r `shouldSatisfy` (< 1e-4)
-
- -- ===========================================================================
- -- 1D オプティマイザ (Hanalyze.Optim.LineSearch)
- -- ===========================================================================
- describe "Hanalyze.Optim.LineSearch" $ do
- let parabola [x] = (x - 2.5)^(2::Int) + 1.0
- parabola _ = error "1D"
- cosBowl [x] = cos x + 0.1 * x * x -- 単峰、最小 ≈ 1.428 付近
- cosBowl _ = error "1D"
-
- it "Brent: parabola minimum at x = 2.5" $ do
- let r = LS.brent LS.defaultBrentConfig parabola 0 5
- abs (head (OC.orBest r) - 2.5) `shouldSatisfy` (< 1e-5)
- OC.orValue r `shouldSatisfy` (\v -> abs (v - 1) < 1e-8)
-
- it "Brent: cos x + 0.1 x² minimum (verified by GS)" $ do
- let rB = LS.brent LS.defaultBrentConfig cosBowl 0 4
- rG = LS.goldenSection OC.Minimize cosBowl 0 4 1e-8 200
- abs (head (OC.orBest rB) - head (OC.orBest rG)) `shouldSatisfy` (< 1e-3)
-
- it "GoldenSection: parabola minimum at x = 2.5" $ do
- let r = LS.goldenSection OC.Minimize parabola 0 5 1e-7 200
- abs (head (OC.orBest r) - 2.5) `shouldSatisfy` (< 1e-3)
-
- it "Kernel.autoBandwidthBrent: 同じ最適 h を grid 法とほぼ一致" $ do
- let xs = V.fromList [0.0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
- ys = V.map (\x -> sin x + 0.1 * x) xs
- (hG, _) = K.gridSearchBandwidth K.Gaussian xs ys [0.5, 0.8, 1.0, 1.5, 2.0, 3.0]
- (hB, _) = K.autoBandwidthBrent K.Gaussian xs ys 0.3 4.0
- abs (hB - hG) `shouldSatisfy` (< 1.0) -- グリッドと近い領域
-
- -- ===========================================================================
- -- 大域オプティマイザ (Hanalyze.Optim.DifferentialEvolution)
- -- ===========================================================================
- describe "Hanalyze.Optim.DifferentialEvolution" $ do
- let sphere xs = sum [x*x | x <- xs]
- rastrigin xs =
- 10 * fromIntegral (length xs) +
- sum [x*x - 10 * cos (2 * pi * x) | x <- xs]
- l2 a b = sqrt (sum (zipWith (\x y -> (x-y)^(2::Int)) a b))
-
- it "DE: sphere 5D が原点付近に到達" $ do
- gen <- MWC.create
- let bs = replicate 5 (-5, 5)
- cfg = (DE.defaultDEConfig bs)
- { DE.deStop = OC.defaultStopCriteria { OC.stMaxIter = 200 } }
- r <- DE.runDEWith cfg sphere gen
- OC.orValue r `shouldSatisfy` (< 1e-3)
-
- it "DE: Rastrigin 3D の大域最小 (原点) を見つける" $ do
- gen <- MWC.create
- let bs = replicate 3 (-5.12, 5.12)
- cfg = (DE.defaultDEConfig bs)
- { DE.deStop = OC.defaultStopCriteria { OC.stMaxIter = 400 } }
- r <- DE.runDEWith cfg rastrigin gen
- l2 (OC.orBest r) [0, 0, 0] `shouldSatisfy` (< 0.5)
-
- -- ===========================================================================
- -- 大域オプティマイザ (Hanalyze.Optim.CMAES、簡易対角版)
- -- ===========================================================================
- describe "Hanalyze.Optim.CMAES" $ do
- let sphere xs = sum [x*x | x <- xs]
- l2 a b = sqrt (sum (zipWith (\x y -> (x-y)^(2::Int)) a b))
-
- it "CMA-ES: sphere 5D を最小化、原点近傍に到達" $ do
- gen <- MWC.create
- let cfg = CMAES.defaultCMAESConfig
- { CMAES.cmStop = OC.defaultStopCriteria { OC.stMaxIter = 200 }
- , CMAES.cmSigma0 = 1.0 }
- r <- CMAES.runCMAESWith cfg sphere [3, -2, 1, 0.5, -1.5] gen
- l2 (OC.orBest r) [0,0,0,0,0] `shouldSatisfy` (< 0.5)
-
- it "CMA-ES Full: sphere 5D で 1e-3 以内に到達" $ do
- gen <- MWC.create
- let cfg = CMAESF.defaultCMAESFConfig
- { CMAESF.cmfStop = OC.defaultStopCriteria { OC.stMaxIter = 300 }
- , CMAESF.cmfSigma0 = 1.0 }
- r <- CMAESF.runCMAESFullWith cfg sphere [3, -2, 1, 0.5, -1.5] gen
- OC.orValue r `shouldSatisfy` (< 1e-3)
-
- it "CMA-ES Full: Rosenbrock 2D で (1,1) に 0.1 以内" $ do
- gen <- MWC.create
- let cfg = CMAESF.defaultCMAESFConfig
- { CMAESF.cmfStop = OC.defaultStopCriteria { OC.stMaxIter = 500 }
- , CMAESF.cmfSigma0 = 0.5
- , CMAESF.cmfLambda = Just 20 }
- rosen [x, y] = (1-x)^(2::Int) + 100 * (y - x*x)^(2::Int)
- rosen _ = error "2D"
- r <- CMAESF.runCMAESFullWith cfg rosen [-1.2, 1.0] gen
- l2 (OC.orBest r) [1, 1] `shouldSatisfy` (< 0.1)
-
- -- ===========================================================================
- -- メタヒューリスティック (Tier 2: Simulated Annealing, PSO)
- -- ===========================================================================
- describe "Hanalyze.Optim.SimulatedAnnealing" $ do
- it "SA: sphere 5D で sufficient annealing" $ do
- gen <- MWC.create
- let bs = replicate 5 (-3, 3)
- cfg = (SA.defaultSAConfig bs)
- { SA.saStop = OC.defaultStopCriteria { OC.stMaxIter = 5000 }
- , SA.saInitTemp = 2.0
- , SA.saSchedule = SA.Geometric 0.997 }
- sphere xs = sum [x*x | x <- xs]
- r <- SA.runSAWith cfg sphere [2, -1.5, 1, 0.5, -0.7] gen
- OC.orValue r `shouldSatisfy` (< 0.5)
-
- describe "Hanalyze.Optim.ParticleSwarm" $ do
- it "PSO: sphere 5D で原点近傍 (0.5 以内)" $ do
- gen <- MWC.create
- let bs = replicate 5 (-5, 5)
- cfg = (PSO.defaultPSOConfig bs)
- { PSO.psoStop = OC.defaultStopCriteria { OC.stMaxIter = 200 }
- , PSO.psoNum = 30 }
- sphere xs = sum [x*x | x <- xs]
- r <- PSO.runPSOWith cfg sphere gen
- OC.orValue r `shouldSatisfy` (< 0.5)
-
- it "PSO: Rastrigin 3D の大域最小に近い" $ do
- gen <- MWC.create
- let bs = replicate 3 (-5.12, 5.12)
- cfg = (PSO.defaultPSOConfig bs)
- { PSO.psoStop = OC.defaultStopCriteria { OC.stMaxIter = 300 }
- , PSO.psoNum = 40 }
- rastrigin xs =
- 10 * fromIntegral (length xs) +
- sum [x*x - 10 * cos (2 * pi * x) | x <- xs]
- r <- PSO.runPSOWith cfg rastrigin gen
- OC.orValue r `shouldSatisfy` (< 5.0) -- 大域近傍 (10 程度の局所有り)
-
- -- ===========================================================================
- -- 制約付き最適化 (Augmented Lagrangian)
- -- ===========================================================================
- describe "Hanalyze.Optim.Constrained" $ do
- it "Augmented Lagrangian: min x1²+x2² s.t. x1+x2=1 → (0.5, 0.5)" $ do
- let f xs = (head xs)^(2::Int) + (xs !! 1)^(2::Int)
- cs = Con.ConstraintSet
- { Con.csEq = [\xs -> head xs + xs !! 1 - 1]
- , Con.csIneq = []
- }
- (r, viol) <- Con.runAugmentedLagrangian
- Con.defaultConstrainedConfig f cs [0, 0]
- let [x1, x2] = OC.orBest r
- abs (x1 - 0.5) `shouldSatisfy` (< 0.05)
- abs (x2 - 0.5) `shouldSatisfy` (< 0.05)
- viol `shouldSatisfy` (< 1e-3)
-
- it "Augmented Lagrangian: 不等式 x ≥ 1 (h(x)=1-x≤0) で min x²" $ do
- let f xs = (head xs)^(2::Int)
- cs = Con.ConstraintSet
- { Con.csEq = []
- , Con.csIneq = [\xs -> 1 - head xs] -- 1 - x ≤ 0 ⇔ x ≥ 1
- }
- (r, viol) <- Con.runAugmentedLagrangian
- Con.defaultConstrainedConfig f cs [0]
- let [x] = OC.orBest r
- x `shouldSatisfy` (\v -> v >= 1 - 0.01)
- viol `shouldSatisfy` (< 1e-3)
-
- it "Penalty method: 等式 x1+x2=1 (簡易版)" $ do
- let f xs = (head xs)^(2::Int) + (xs !! 1)^(2::Int)
- cs = Con.ConstraintSet
- { Con.csEq = [\xs -> head xs + xs !! 1 - 1]
- , Con.csIneq = []
- }
- (r, _) <- Con.penaltyMethod Con.defaultConstrainedConfig f cs [0, 0]
- let [x1, x2] = OC.orBest r
- abs (x1 + x2 - 1) `shouldSatisfy` (< 0.05)
-
- it "boxToIneq: bounds [(1,5)] を不等式 2 本に展開、x=3 で両方満たす" $ do
- let ineqs = Con.boxToIneq [(1.0, 5.0)]
- length ineqs `shouldBe` 2
- all (\h -> h [3.0] <= 0) ineqs `shouldBe` True
- any (\h -> h [0.0] > 0) ineqs `shouldBe` True -- 下限違反
- any (\h -> h [6.0] > 0) ineqs `shouldBe` True -- 上限違反
-
- -- ===========================================================================
- -- box 制約 (Bounds) 統一インターフェース (Hanalyze.Optim.Common)
- -- ===========================================================================
- describe "Hanalyze.Optim.Common box constraints" $ do
- it "clipToBounds: 範囲外を反射、範囲内はそのまま" $ do
- OC.clipToBounds [(0,10)] [5] `shouldBe` [5]
- OC.clipToBounds [(0,10)] [-2] `shouldBe` [2] -- 反射
- OC.clipToBounds [(0,10)] [12] `shouldBe` [8]
-
- it "boundsPenalty: 範囲内 0、範囲外で大きい正値" $ do
- OC.boundsPenalty (Just [(0,10)]) [5] `shouldBe` 0
- OC.boundsPenalty Nothing [-99] `shouldBe` 0
- OC.boundsPenalty (Just [(0,10)]) [-1] `shouldSatisfy` (> 1e5)
-
- it "NelderMead: nmBounds で box 内に解が収まる" $ do
- let f xs = (head xs - 5)^(2::Int) -- 真の最小は x=5
- cfg = NM.defaultNMConfig { NM.nmBounds = Just [(0, 2)] }
- r <- NM.runNelderMeadWith cfg f [1.0]
- head (OC.orBest r) `shouldSatisfy` (\v -> v >= -0.1 && v <= 2.1)
-
- it "LBFGS: lbBounds で box 内に解が収まる" $ do
- let f xs = (head xs - 5)^(2::Int)
- cfg = LBFGS.defaultLBFGSConfig { LBFGS.lbBounds = Just [(0, 2)] }
- r <- LBFGS.runLBFGSNumeric cfg f [1.0]
- head (OC.orBest r) `shouldSatisfy` (\v -> v >= -0.1 && v <= 2.1)
-
- it "CMAES (簡易版): cmBounds で box 内サンプル" $ do
- gen <- MWC.create
- let f xs = sum [x*x | x <- xs]
- cfg = CMAES.defaultCMAESConfig
- { CMAES.cmBounds = Just [(-1, 1), (-1, 1)]
- , CMAES.cmStop = (CMAES.cmStop CMAES.defaultCMAESConfig)
- { OC.stMaxIter = 80 }
- }
- r <- CMAES.runCMAESWith cfg f [0.5, 0.5] gen
- all (\v -> v >= -1.05 && v <= 1.05) (OC.orBest r) `shouldBe` True
-
- it "CMAESFull: cmfBounds で box 内サンプル" $ do
- gen <- MWC.create
- let f xs = sum [x*x | x <- xs]
- cfg = CMAESF.defaultCMAESFConfig
- { CMAESF.cmfBounds = Just [(-1, 1), (-1, 1)]
- , CMAESF.cmfStop = (CMAESF.cmfStop CMAESF.defaultCMAESFConfig)
- { OC.stMaxIter = 80 }
- }
- r <- CMAESF.runCMAESFullWith cfg f [0.5, 0.5] gen
- all (\v -> v >= -1.05 && v <= 1.05) (OC.orBest r) `shouldBe` True
-
- -- ===========================================================================
- -- Bayesian Optimization 内部最適化の差し替え (Hanalyze.Optim.BayesOpt)
- -- ===========================================================================
- describe "Hanalyze.Optim.BayesOpt (acquisition optimizer swap)" $ do
- it "bayesOpt 1D: Brent 内側で簡単な凸関数 (x-1.5)^2 を見つける" $ do
- gen <- MWC.create
- let cfg = BO.defaultBayesOptConfig
- { BO.boIterations = 8
- , BO.boInitPoints = 4
- , BO.boGridSize = 32
- }
- target x = pure ((x - 1.5)^(2::Int) :: Double)
- (_, (xb, _)) <- BO.bayesOpt cfg target (0, 3) gen
- -- 8 反復では精度は緩めに。3.0 範囲のうち 0.5 以内に収束を期待
- abs (xb - 1.5) `shouldSatisfy` (< 0.5)
-
- -- ===========================================================================
- -- RFF HP 自動チューニングの DE 版 (Phase O9)
- -- ===========================================================================
- describe "Hanalyze.Model.RFF DE-based auto-HP" $ do
- it "maximizeMarginalLikRBFMV_DE: y = sin x + noise で妥当な ℓ" $ do
- gen <- MWC.create
- let n = 30
- xs = [ fromIntegral i / 5 | i <- [0 .. n - 1] ] :: [Double]
- ys = [ sin x + 0.05 * cos (3 * x) | x <- xs ]
- xMat = LA.fromColumns [LA.fromList xs]
- yVec = LA.fromList ys
- r <- RFF.maximizeMarginalLikRBFMV_DE xMat yVec 30 gen
- -- ℓ が極端に小さくない (>1e-2) ことだけ確認
- RFF.mlEll r `shouldSatisfy` (> 1e-2)
-
- it "gridSearchLOOCVRBFMV_DE: LOOCV が有限値、ℓ が探索範囲内" $ do
- gen <- MWC.create
- let n = 25
- xs = [ fromIntegral i / 4 | i <- [0 .. n - 1] ] :: [Double]
- ys = [ x + 0.1 * sin (2 * x) | x <- xs ]
- xMat = LA.fromColumns [LA.fromList xs]
- yVec = LA.fromList ys
- r <- RFF.gridSearchLOOCVRBFMV_DE 1 50 xMat yVec 20 gen
- RFF.lcLOOCV r `shouldSatisfy` (\v -> not (isNaN v) && v >= 0)
- RFF.lcEll r `shouldSatisfy` (> 1e-3)
-
- -- ===========================================================================
- -- Hanalyze.Viz.ReportBuilder.secInterpolation (Phase G4)
- -- ===========================================================================
- describe "Hanalyze.Viz.ReportBuilder.secInterpolation" $ do
- it "defaultInterpReport で renderReport まで通る (smoke)" $
- withSystemTempFile "ha-interp.html" $ \fp h -> do
- hClose h
- let ir = RB.defaultInterpReport "test"
- RB.renderReport fp (RB.defaultReportConfig "T") [RB.secInterpolation ir]
- out <- readFile fp
- length out `shouldSatisfy` (> 100)
-
- it "InterpReport 全フィールド + extra で HTML に主要要素が含まれる" $
- withSystemTempFile "ha-interp2.html" $ \fp h -> do
- hClose h
- let ir = (RB.defaultInterpReport "regrid")
- { RB.irInterpKind = "PCHIP"
- , RB.irGridKind = "Adaptive"
- , RB.irN = 3
- , RB.irPerIdObserved = [("a", [(0, 0), (1, 1)])]
- , RB.irPerIdInterpY = [("a", [(0, 0), (0.5, 0.5), (1, 1)])]
- , RB.irGrid = [0, 0.5, 1]
- , RB.irDensity = [(0, 1), (0.5, 2), (1, 1)]
- , RB.irPerIdSummary = [("a", 2, 0, 1, 0, 0, 0)]
- , RB.irExtraEnabled = True
- , RB.irPerIdYRange = [("a", 0, 1, 0, 1)]
- }
- RB.renderReport fp (RB.defaultReportConfig "T") [RB.secInterpolation ir]
- out <- readFile fp
- out `shouldContain` "Parameters"
- out `shouldContain` "PCHIP"
-
- -- ===========================================================================
- -- Hanalyze.Stat.Test (Phase 1: hypothesis tests)
- -- ===========================================================================
- describe "Hanalyze.Stat.Test" $ do
- it "tTest1Sample: μ₀=0 で同分布なら p > 0.05" $ do
- let xs = LA.fromList [0.1, -0.2, 0.3, 0.0, 0.15, -0.1, 0.05, 0.2]
- tr = ST.tTest1Sample xs 0 ST.TwoSided
- ST.trPValue tr `shouldSatisfy` (> 0.05)
-
- it "tTestWelch: 明らかにずれた 2 群で p < 0.05" $ do
- let xs = LA.fromList [1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0]
- ys = LA.fromList [10.0, 11.0, 12.0, 13.0, 14.0, 15.0, 16.0, 17.0]
- tr = ST.tTestWelch xs ys ST.TwoSided
- ST.trPValue tr `shouldSatisfy` (< 0.05)
-
- it "anovaOneWay: 3 群が異なる平均なら有意" $ do
- let g1 = LA.fromList [1.0, 2.0, 3.0]
- g2 = LA.fromList [4.0, 5.0, 6.0]
- g3 = LA.fromList [7.0, 8.0, 9.0]
- tr = ST.anovaOneWay [g1, g2, g3]
- ST.trStatistic tr `shouldSatisfy` (> 1)
- ST.trPValue tr `shouldSatisfy` (< 0.05)
-
- it "chiSquareIndep: 強い独立で p > 0.05" $ do
- let tbl = LA.matrix 2 [25, 25, 25, 25] -- 完全独立
- tr = ST.chiSquareIndep tbl
- ST.trPValue tr `shouldSatisfy` (> 0.5)
-
- it "chiSquareIndep: 強い従属で p < 0.05" $ do
- let tbl = LA.matrix 2 [40, 10, 10, 40] -- 高 chi2
- tr = ST.chiSquareIndep tbl
- ST.trPValue tr `shouldSatisfy` (< 0.05)
-
- it "leveneTest: 分散が大きく異なれば p < 0.05" $ do
- let g1 = LA.fromList [1, 1.1, 0.9, 1.05, 0.95, 1.02, 0.98, 1.03]
- g2 = LA.fromList [10, 20, 5, 25, 8, 30, 3, 22] -- much larger var
- tr = ST.leveneTest [g1, g2]
- ST.trPValue tr `shouldSatisfy` (< 0.05)
-
- it "shapiroWilk: roughly-normal 系列で p > 0.05" $ do
- let xs = LA.fromList [-1.5, -0.5, 0.0, 0.3, 0.8, 1.2, -0.3, 0.5, 1.0, -1.0]
- tr = ST.shapiroWilk xs
- ST.trPValue tr `shouldSatisfy` (> 0.05)
-
- it "mannWhitneyU: 明らかにずれた 2 群で p < 0.05" $ do
- let xs = LA.fromList [1, 2, 3, 4, 5, 6]
- ys = LA.fromList [11, 12, 13, 14, 15, 16]
- tr = ST.mannWhitneyU xs ys ST.TwoSided
- ST.trPValue tr `shouldSatisfy` (< 0.05)
-
- it "fisherExact2x2: 強い偏りで p < 0.05" $ do
- let tr = ST.fisherExact2x2 ((20, 5), (5, 20)) ST.TwoSided
- ST.trPValue tr `shouldSatisfy` (< 0.05)
-
- -- ===========================================================================
- -- Hanalyze.Model.PCA (Phase 2)
- -- ===========================================================================
- describe "Hanalyze.Model.PCA" $ do
- it "PCA on rank-1 matrix: 1st component explains ~100% var" $ do
- let -- Rank-1: each row = scalar × [1, 2, 3]
- ks = [1.0, 2.0, 3.0, 4.0, 5.0, 6.0]
- xs = LA.fromLists [[k, 2 * k, 3 * k] | k <- ks]
- r = PCA.pca PCA.Center Nothing xs
- head (LA.toList (PCA.pcaExplainedRatio r))
- `shouldSatisfy` (> 0.999)
-
- it "pcaTransform + pcaInverse は Center mode で全成分なら復元 ≈ x" $ do
- let xs = LA.fromLists [[1, 2, 3], [4, 5, 6], [7, 8, 9], [2, 1, 0]]
- r = PCA.pca PCA.Center Nothing xs
- scores = PCA.pcaTransform r xs
- recon = PCA.pcaInverse r scores
- diff = LA.norm_2 (LA.flatten (xs - recon))
- diff `shouldSatisfy` (< 1e-9)
-
- it "pcaCumExplained は monotone increasing で max ≤ 1" $ do
- let xs = LA.fromLists [[k, 2*k+1, k*k]
- | k <- [1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0]]
- r = PCA.pca PCA.Center Nothing xs
- cum = LA.toList (PCA.pcaCumExplained r)
- last cum `shouldSatisfy` (<= 1.0001)
- and (zipWith (<=) cum (tail cum)) `shouldBe` True
-
- it "CenterScale で各列の SD が 1 に正規化される" $ do
- let xs = LA.fromLists [[1, 100, 0.1], [2, 200, 0.2],
- [3, 300, 0.3], [4, 400, 0.4]]
- r = PCA.pca PCA.CenterScale Nothing xs
- -- SD は元データの per-col SD で保存される
- LA.size (PCA.pcaScale r) `shouldBe` 3
- all (> 0) (LA.toList (PCA.pcaScale r)) `shouldBe` True
-
- -- ===========================================================================
- -- Hanalyze.Stat.ClassMetrics (Phase 3)
- -- ===========================================================================
- describe "Hanalyze.Stat.ClassMetrics" $ do
- it "confusionMatrix: 完全一致で TP/TN のみ" $ do
- let c = CM.confusionMatrix [1, 0, 1, 0, 1] [1, 0, 1, 0, 1]
- CM.confTP c `shouldBe` 3
- CM.confTN c `shouldBe` 2
- CM.confFP c `shouldBe` 0
- CM.confFN c `shouldBe` 0
- CM.accuracy c `shouldBe` 1.0
- CM.f1Score c `shouldBe` 1.0
-
- it "precision/recall/f1: 不均衡な誤分類" $ do
- let c = CM.confusionMatrix [1, 1, 1, 0, 0] [1, 1, 0, 1, 0]
- -- TP=2, FN=1, FP=1, TN=1
- CM.precision c `shouldBe` 2/3 -- 2/(2+1)
- CM.recall c `shouldBe` 2/3 -- 2/(2+1)
- CM.f1Score c `shouldBe` 2/3
-
- it "AUC: 完全分離で 1.0、ランダムスコアで ~0.5" $ do
- let ys = [0, 0, 0, 1, 1, 1]
- perfectScores = [0.1, 0.2, 0.3, 0.7, 0.8, 0.9]
- aucPerfect = CM.auc ys perfectScores
- aucPerfect `shouldBe` 1.0
-
- it "logLoss: 自信ある正解で小、自信ある誤りで大" $ do
- let lossGood = CM.logLoss [1, 0, 1, 0] [0.99, 0.01, 0.99, 0.01]
- lossBad = CM.logLoss [1, 0, 1, 0] [0.01, 0.99, 0.01, 0.99]
- lossGood `shouldSatisfy` (< 0.05)
- lossBad `shouldSatisfy` (> 4.0)
-
- it "brierScore: 完全予測で 0、最悪予測で 1" $ do
- let bsGood = CM.brierScore [1, 0, 1, 0] [1.0, 0.0, 1.0, 0.0]
- bsBad = CM.brierScore [1, 0, 1, 0] [0.0, 1.0, 0.0, 1.0]
- bsGood `shouldSatisfy` (< 1e-10)
- bsBad `shouldBe` 1.0
-
- it "MCC: 完全一致で 1、ランダムで 0 付近" $ do
- let cGood = CM.confusionMatrix [1, 0, 1, 0, 1] [1, 0, 1, 0, 1]
- CM.matthewsCorr cGood `shouldBe` 1.0
-
- it "macroF1 (multi-class): 完全分類で 1.0" $ do
- let cm = CM.confusionMulti [0, 1, 2, 0, 1, 2] [0, 1, 2, 0, 1, 2]
- CM.accuracyMulti cm `shouldBe` 1.0
- CM.macroF1 cm `shouldBe` 1.0
-
- -- ===========================================================================
- -- Hanalyze.Stat.CV (Phase 4)
- -- ===========================================================================
- describe "Hanalyze.Stat.CV" $ do
- it "kFold(5, 100): 5 fold で全 100 行を test に使用、重複なし" $ do
- gen <- MWC.createSystemRandom
- folds <- CV.kFold 5 100 gen
- length folds `shouldBe` 5
- let allTest = concatMap snd folds
- length allTest `shouldBe` 100
- length (V.toList (V.fromList allTest)) `shouldBe` 100 -- 重複なし
-
- it "kFold: train + test = total samples per fold" $ do
- gen <- MWC.createSystemRandom
- folds <- CV.kFold 5 100 gen
- mapM_ (\(tr, te) -> length tr + length te `shouldBe` 100) folds
-
- it "leaveOneOut(10): 10 folds、test set size 1 each" $ do
- folds <- CV.leaveOneOut 10
- length folds `shouldBe` 10
- mapM_ (\(_, te) -> length te `shouldBe` 1) folds
-
- it "stratifiedKFold(3): クラスバランスがほぼ保持される" $ do
- gen <- MWC.createSystemRandom
- let labels = replicate 30 0 ++ replicate 30 1 ++ replicate 30 2
- folds <- CV.stratifiedKFold 3 labels gen
- length folds `shouldBe` 3
- -- 各 fold の test set には各クラスの ~10 が含まれる
- mapM_ (\(_, te) -> length te `shouldSatisfy` (\n -> n >= 27 && n <= 33)) folds
-
- it "shuffleSplit: 反復回数とテストサイズが正しい" $ do
- gen <- MWC.createSystemRandom
- folds <- CV.shuffleSplit 5 0.2 100 gen
- length folds `shouldBe` 5
- mapM_ (\(_, te) -> length te `shouldBe` 20) folds
-
- it "timeSeriesSplit: forward-chaining で過去のみで学習" $ do
- let folds = CV.timeSeriesSplit 50 10 100 -- initial=50, step=10, n=100
- length folds `shouldBe` 5 -- (100-50)/10 = 5 folds
- -- 全 fold で train indices < min(test indices)
- mapM_ (\(tr, te) ->
- (maximum tr < minimum te) `shouldBe` True) folds
-
- -- ===========================================================================
- -- Hanalyze.Model.Cluster (Phase 5)
- -- ===========================================================================
- describe "Hanalyze.Model.Cluster" $ do
- it "kMeans: 2 つの離れたクラスタで正しく分類" $ do
- gen <- MWC.createSystemRandom
- -- Cluster 1: around (0, 0); cluster 2: around (10, 10)
- let xs = LA.fromLists $
- [[0.1*x, 0.1*y] | x <- [-3..3], y <- [-3..3]] ++
- [[10 + 0.1*x, 10 + 0.1*y] | x <- [-3..3], y <- [-3..3]]
- cfg = Cl.defaultKMeansConfig 2
- r <- Cl.kMeans cfg xs gen
- LA.rows (Cl.kmrCentroids r) `shouldBe` 2
- -- 全 49 points がクラスタ 1、49 が クラスタ 2
- let labels = Cl.kmrLabels r
- (c0, c1) = (length (filter (== 0) labels), length (filter (== 1) labels))
- (min c0 c1) `shouldBe` 49
- (max c0 c1) `shouldBe` 49
-
- it "silhouette: well-separated clusters で > 0.5" $ do
- gen <- MWC.createSystemRandom
- let xs = LA.fromLists $
- [[0.1*x, 0.1*y] | x <- [-3..3], y <- [-3..3]] ++
- [[20 + 0.1*x, 20 + 0.1*y] | x <- [-3..3], y <- [-3..3]]
- cfg = Cl.defaultKMeansConfig 2
- r <- Cl.kMeans cfg xs gen
- let s = Cl.silhouette xs (Cl.kmrLabels r)
- s `shouldSatisfy` (> 0.7)
-
- it "kMeans: inertia は monotone non-increasing in iter" $ do
- gen <- MWC.createSystemRandom
- let xs = LA.fromLists [[fromIntegral i, fromIntegral j]
- | i <- [0..9::Int], j <- [0..9::Int]]
- cfg = (Cl.defaultKMeansConfig 4) { Cl.kmRestarts = 5 }
- r <- Cl.kMeans cfg xs gen
- Cl.kmrInertia r `shouldSatisfy` (>= 0)
- Cl.kmrConverged r `shouldBe` True
-
- -- ===========================================================================
- -- Hanalyze.Stat.MultipleTesting (Phase 6)
- -- ===========================================================================
- describe "Hanalyze.Stat.MultipleTesting" $ do
- it "Bonferroni: p × m, capped at 1" $ do
- let ps = [0.01, 0.04, 0.05, 0.10]
- adj = MT.bonferroni ps
- adj `shouldBe` [0.04, 0.16, 0.20, 0.40]
-
- it "Holm: 単調 + Bonferroni より緩い" $ do
- let ps = [0.01, 0.02, 0.03, 0.04]
- adj = MT.holm ps
- -- 各 adj ≥ 元 p、最初は p × m = 0.04
- head adj `shouldBe` 0.04
- and (zipWith (<=) ps adj) `shouldBe` True
-
- it "BH: monotonic non-decreasing in sorted p order" $ do
- let ps = [0.01, 0.04, 0.03, 0.05]
- adj = MT.benjaminiHochberg ps
- length adj `shouldBe` 4
- all (<= 1.0) adj `shouldBe` True
- all (>= 0.0) adj `shouldBe` True
-
- it "BY: BH より conservative" $ do
- let ps = [0.01, 0.02, 0.03, 0.04, 0.05]
- bh = MT.benjaminiHochberg ps
- by = MT.benjaminiYekutieli ps
- -- BY は cumulative harmonic factor を掛けるので大きい
- and (zipWith (>=) by bh) `shouldBe` True
-
- -- ===========================================================================
- -- Hanalyze.Stat.Bootstrap (Phase 7)
- -- ===========================================================================
- describe "Hanalyze.Stat.Bootstrap" $ do
- it "bootstrapCI on N(0,1) sample: 0 が 95% CI 内" $ do
- gen <- MWC.createSystemRandom
- let xs = LA.fromList [-1.0, -0.5, 0.0, 0.5, 1.0,
- -0.3, 0.3, -0.7, 0.7, 0.0]
- (lo, hi) <- Boot.bootstrapCI 2000 0.95 Boot.sampleMean xs gen
- lo `shouldSatisfy` (< 0.5)
- hi `shouldSatisfy` (> -0.5)
-
- it "permutationTest: 異なる平均で p < 0.05" $ do
- gen <- MWC.createSystemRandom
- let xs = LA.fromList [1.0, 2.0, 3.0, 4.0, 5.0, 6.0]
- ys = LA.fromList [10.0, 11.0, 12.0, 13.0, 14.0, 15.0]
- (_diff, p) <- Boot.permutationTest 2000 xs ys gen
- p `shouldSatisfy` (< 0.05)
-
- it "sampleMean / sampleVar / sampleMedian の整合性" $ do
- let v = LA.fromList [1.0, 2.0, 3.0, 4.0, 5.0]
- Boot.sampleMean v `shouldBe` 3.0
- Boot.sampleVar v `shouldBe` 2.5 -- variance of 1..5 (unbiased)
- Boot.sampleMedian v `shouldBe` 3.0
-
- -- ===========================================================================
- -- Hanalyze.DataIO.Reshape (Phase 8)
- -- ===========================================================================
- describe "Hanalyze.DataIO.Reshape" $ do
- it "lagColumn(1): 先頭が NaN、残りは 1 つずれる" $ do
- let df = DX.fromNamedColumns
- [("x", DX.fromList [1.0, 2.0, 3.0, 4.0, 5.0 :: Double])]
- df' = Reshape.lagColumn 1 "x" "x_lag1" df
- -- Lagged column should exist
- "x_lag1" `elem` DX.columnNames df' `shouldBe` True
-
- it "leadColumn(1): 末尾が NaN、残りは 1 つ前進" $ do
- let df = DX.fromNamedColumns
- [("x", DX.fromList [1.0, 2.0, 3.0, 4.0, 5.0 :: Double])]
- df' = Reshape.leadColumn 1 "x" "x_lead1" df
- "x_lead1" `elem` DX.columnNames df' `shouldBe` True
-
- it "rollingMean(3): 最初 2 つが NaN、3 番目以降は窓内平均" $ do
- let df = DX.fromNamedColumns
- [("x", DX.fromList [1.0, 2.0, 3.0, 4.0, 5.0 :: Double])]
- df' = Reshape.rollingMean 3 "x" "x_rmean3" df
- "x_rmean3" `elem` DX.columnNames df' `shouldBe` True
-
- it "oneHot: text 列を indicator 列に展開" $ do
- let df = DX.fromNamedColumns
- [ ("id", DX.fromList [1, 2, 3, 4, 5 :: Int])
- , ("category", DX.fromList ["A", "B", "A", "C", "B" :: T.Text])
- ]
- df' = Reshape.oneHot False "category" df
- let cols = DX.columnNames df'
- "category" `elem` cols `shouldBe` False -- 元列削除
- "category_A" `elem` cols `shouldBe` True
- "category_B" `elem` cols `shouldBe` True
- "category_C" `elem` cols `shouldBe` True
-
- it "oneHot dropFirst=True: 1 列分減る" $ do
- let df = DX.fromNamedColumns
- [("c", DX.fromList ["X", "Y", "Z" :: T.Text])]
- df' = Reshape.oneHot True "c" df
- length (DX.columnNames df') `shouldBe` 2 -- Y, Z (X drop)
-
- -- ===========================================================================
- -- Hanalyze.Stat.Effect (Phase 9)
- -- ===========================================================================
- describe "Hanalyze.Stat.Effect" $ do
- it "cohenD: 同じ分布で 0、平均差 1 SD で ~1" $ do
- let xs = LA.fromList [1, 2, 3, 4, 5] :: LA.Vector Double
- ys = LA.fromList [1, 2, 3, 4, 5] :: LA.Vector Double
- Eff.cohenD xs ys `shouldBe` 0.0
-
- let zs = LA.fromList [2, 3, 4, 5, 6] :: LA.Vector Double -- shifted
- d2 = Eff.cohenD zs xs
- d2 `shouldSatisfy` (> 0.5)
-
- it "hedgesG ≤ |cohenD| (small-sample correction)" $ do
- let xs = LA.fromList [1, 2, 3, 4, 5] :: LA.Vector Double
- ys = LA.fromList [3, 4, 5, 6, 7] :: LA.Vector Double
- d = Eff.cohenD xs ys
- g = Eff.hedgesG xs ys
- abs g `shouldSatisfy` (<= abs d + 1e-9)
-
- it "eta2: 完全分離で大、同分布で 0" $ do
- let g1 = LA.fromList [1, 2, 3] :: LA.Vector Double
- g2 = LA.fromList [10, 11, 12] :: LA.Vector Double
- g3 = LA.fromList [20, 21, 22] :: LA.Vector Double
- Eff.eta2 [g1, g2, g3] `shouldSatisfy` (> 0.9)
-
- it "powerTTest: d = 0 で α 付近 (= ~0.05)" $ do
- let p = Eff.powerTTest 30 0.05 0.0
- p `shouldSatisfy` (\x -> abs (x - 0.05) < 0.01)
-
- it "powerTTest: 大きい d で高い power" $ do
- let p = Eff.powerTTest 30 0.05 0.8
- p `shouldSatisfy` (> 0.85)
-
- it "sampleSizeTTest: 小 d ほど大 n が必要" $ do
- let n1 = Eff.sampleSizeTTest 0.80 0.05 0.2 -- small effect
- n2 = Eff.sampleSizeTTest 0.80 0.05 0.5 -- medium
- n3 = Eff.sampleSizeTTest 0.80 0.05 0.8 -- large
- n1 `shouldSatisfy` (> n2)
- n2 `shouldSatisfy` (> n3)
-
- it "cramerV: 2×2 完全独立で ~0、強従属で大" $ do
- Eff.cramerV 0 100 2 2 `shouldBe` 0.0
- Eff.cramerV 50 100 2 2 `shouldSatisfy` (> 0.5)
-
- -- ===========================================================================
- -- Hanalyze.Model.DecisionTree (Phase 10)
- -- ===========================================================================
- describe "Hanalyze.Model.DecisionTree" $ do
- it "fitDT: 線形分離可能なデータで perfect train accuracy" $ do
- -- y = 0 if x[0] < 5, else 1
- let xs = [[fromIntegral x] | x <- [1..10::Int]]
- ys = [if x < 5 then 0 else 1 | x <- [1..10::Int]]
- tree = DT.fitDT DT.defaultDTConfig xs ys
- preds = map (DT.predictDT tree) xs
- preds `shouldBe` ys
-
- it "fitDT: 2D XOR-like パターン" $ do
- let xs = [[0, 0], [0, 1], [1, 0], [1, 1]]
- ys = [0, 1, 1, 0] -- XOR
- tree = DT.fitDT DT.defaultDTConfig xs ys
- preds = map (DT.predictDT tree) xs
- preds `shouldBe` ys
-
- it "predictDTProbs: leaf で確率 1.0、混合 leaf で fractional" $ do
- let xs = [[1.0], [2.0], [3.0]]
- ys = [0, 0, 1]
- tree = DT.fitDT DT.defaultDTConfig xs ys
- probs = DT.predictDTProbs tree [1.5]
- -- x=1.5 should reach a leaf where most samples are class 0
- probs `shouldSatisfy` (\m -> length m >= 1)
-
- it "giniImpurity: 純粋クラスで 0、均等で 0.5 (2 クラス)" $ do
- DT.giniImpurity [0, 0, 0, 0] `shouldBe` 0.0
- DT.giniImpurity [1, 1, 1, 1] `shouldBe` 0.0
- DT.giniImpurity [0, 0, 1, 1] `shouldBe` 0.5
-
- it "maxDepth=1: shallow tree、underfit に近い" $ do
- let cfg = DT.defaultDTConfig { DT.dtMaxDepth = Just 1 }
- xs = [[fromIntegral x, fromIntegral y]
- | x <- [1..5::Int], y <- [1..5::Int]]
- ys = [if x + y > 5 then 1 else 0
- | x <- [1..5::Int], y <- [1..5::Int]]
- tree = DT.fitDT cfg xs ys
- -- maxDepth=1 → 1 split, root = decision node
- case tree of
- DT.DNode {} -> True `shouldBe` True
- _ -> expectationFailure "Expected DNode at root"
-
- -- ===========================================================================
- -- Hanalyze.Model.TimeSeries (Phase 11)
- -- ===========================================================================
- describe "Hanalyze.Model.TimeSeries" $ do
- it "autocorrelation: lag 0 = 1.0" $ do
- let y = LA.fromList [1.0, 2.0, 1.5, 2.5, 1.8]
- acf = TS.autocorrelation 5 y
- LA.atIndex acf 0 `shouldBe` 1.0
-
- it "autocorrelation: 周期 4 の sin 系列で lag 4 が高い" $ do
- let y = LA.fromList [sin (2*pi*fromIntegral t / 4) | t <- [0..40::Int]]
- acf = TS.autocorrelation 8 y
- LA.atIndex acf 4 `shouldSatisfy` (> 0.5)
-
- it "fitAR(1) on quasi-AR(1) data: φ̂ in (0, 1)" $ do
- -- Quasi-AR(1) with φ=0.7 + small deterministic perturbation
- let phi = 0.7
- go _ 0 = []
- go prev n =
- let yi = phi * prev + 0.01 * sin (fromIntegral n :: Double)
- in yi : go yi (n - 1)
- ys = take 100 (drop 50 (go 1.0 200)) -- burn-in 50
- y = LA.fromList ys
- fit = TS.fitAR 1 y
- let phiHat = LA.atIndex (TS.arPhi fit) 0
- -- AR(1) coefficient should be in (0, 1) for stationary positive AR
- phiHat `shouldSatisfy` (\p -> p > 0 && p < 1)
-
- it "forecastAR: h-step forecast 同 size" $ do
- let y = LA.fromList [1.0, 1.5, 2.0, 2.5, 3.0, 2.5, 2.0, 1.5, 1.0, 1.5,
- 2.0, 2.5, 3.0, 2.5, 2.0]
- fit = TS.fitAR 2 y
- fc = TS.forecastAR fit y 5
- LA.size fc `shouldBe` 5
-
- it "differencing: y' length = n - 1" $ do
- let y = LA.fromList [1.0, 3.0, 2.0, 5.0, 4.0]
- d1 = TS.differencing y
- LA.size d1 `shouldBe` 4
- LA.toList d1 `shouldBe` [2.0, -1.0, 3.0, -1.0]
-
- it "simpleExpSmoothing: α=1 で原系列、α=0 で初期値固定" $ do
- let y = LA.fromList [1.0, 2.0, 3.0, 4.0, 5.0]
- s1 = TS.simpleExpSmoothing 1.0 y -- α=1
- s0 = TS.simpleExpSmoothing 0.0 y -- α=0
- LA.toList s1 `shouldBe` LA.toList y -- exact
- all (== 1.0) (LA.toList s0) `shouldBe` True
-
- it "holtWinters: 線形 trend + 周期 4 を再現" $ do
- let -- y_t = t + 5 sin(2πt/4)
- ys = [ fromIntegral t + 3 * sin (2 * pi * fromIntegral t / 4)
- | t <- [0 .. 39 :: Int] ]
- y = LA.fromList ys
- fit = TS.holtWinters TS.HWAdditive 4 y
- fc = TS.hwForecast fit 4
- LA.size fc `shouldBe` 4
- -- Forecast at t=40,41,42,43 should be roughly 40 + sin pattern
- LA.atIndex fc 0 `shouldSatisfy` (> 35)
-
- it "stlDecompose: 周期成分が period 倍で繰り返す" $ do
- let ys = [ fromIntegral t / 10 + 2 * sin (2 * pi * fromIntegral t / 4)
- | t <- [0 .. 39 :: Int] ]
- y = LA.fromList ys
- (_trend, seasonal, _resid) = TS.stlDecompose 4 y
- LA.size seasonal `shouldBe` LA.size y
-
- -- ===========================================================================
- -- Hanalyze.Model.Survival (Phase 12)
- -- ===========================================================================
- describe "Hanalyze.Model.Survival" $ do
- it "kaplanMeier: 全 event observed で S(t) は単調減少" $ do
- let samples = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
- km = Surv.kaplanMeier samples
- length (Surv.kmrTimes km) `shouldBe` 5
- let ss = Surv.kmrSurvival km
- and (zipWith (>=) ss (tail ss)) `shouldBe` True
-
- it "kaplanMeier: censored data でも非負の生存確率" $ do
- let samples = [ Surv.SurvSample 1 Surv.Observed
- , Surv.SurvSample 2 Surv.Censored
- , Surv.SurvSample 3 Surv.Observed
- , Surv.SurvSample 4 Surv.Observed
- , Surv.SurvSample 5 Surv.Censored
- ]
- km = Surv.kaplanMeier samples
- all (>= 0) (Surv.kmrSurvival km) `shouldBe` True
- all (<= 1) (Surv.kmrSurvival km) `shouldBe` True
-
- it "nelsonAalen: 累積ハザードは monotone non-decreasing" $ do
- let samples = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
- na = Surv.nelsonAalen samples
- h = Surv.narCumHazard na
- and (zipWith (<=) h (tail h)) `shouldBe` True
-
- it "logRankTest: 同一分布で p > 0.05" $ do
- let g1 = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
- g2 = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
- lr = Surv.logRankTest [g1, g2]
- Surv.lrPValue lr `shouldSatisfy` (> 0.05)
-
- it "logRankTest: 異なる分布で p < 0.05" $ do
- let g1 = [ Surv.SurvSample t Surv.Observed | t <- [1, 2, 3, 4, 5] ]
- g2 = [ Surv.SurvSample t Surv.Observed | t <- [10, 11, 12, 13, 14] ]
- lr = Surv.logRankTest [g1, g2]
- Surv.lrPValue lr `shouldSatisfy` (< 0.05)
-
- it "coxPH: 共変量と event 時間に強い相関で β > 0" $ do
- -- x が大きい個体が早く event を起こす想定の合成データ
- let n = 30
- xs = [ LA.fromList [fromIntegral i / fromIntegral n :: Double]
- | i <- [1 .. n] ]
- times = [ 30 - i | i <- [1 .. n] ] -- x 大きいほど early
- samples = [ Surv.SurvSample (fromIntegral t) Surv.Observed
- | t <- times ]
- fit = Surv.coxPH xs samples
- LA.atIndex (Surv.coxBeta fit) 0 `shouldSatisfy` (> 0)
-
- -- ===========================================================================
- -- Hanalyze.Stat.Interpret (Phase 13)
- -- ===========================================================================
- describe "Hanalyze.Stat.Interpret" $ do
- it "permutationImportance: 重要 feature が高 importance" $ do
- gen <- MWC.createSystemRandom
- -- y = x_0 のみに依存、x_1 は無関係
- let xs = [[fromIntegral i, fromIntegral (i * i)]
- | i <- [1 .. 20 :: Int]]
- ys = [head row | row <- xs]
- predict zs = [head row | row <- zs]
- score yt yp =
- let mse = sum [(yt !! i - yp !! i) ^ (2 :: Int)
- | i <- [0 .. length yt - 1]]
- in negate mse -- higher (= 0) is better
- cfg = (Interp.defaultPermutationConfig)
- { Interp.pcNRepeats = 5 }
- r <- Interp.permutationImportance cfg predict score xs ys gen
- let imps = Interp.piMeanImportance r
- -- 0番目 feature の importance が高いはず (重要)
- head imps `shouldSatisfy` (> 0.5 * (imps !! 1))
-
- it "partialDependence: y = x[0] で PDP が grid に追従" $ do
- let xs = [[fromIntegral i, 0.0] | i <- [1..10::Int]]
- predict zs = [head row | row <- zs]
- grid = [1.0, 5.0, 10.0]
- pdp = Interp.partialDependence predict xs 0 grid
- -- 各 grid 点での PD は値そのもの (= grid 値)
- Interp.pdpMeanPredict pdp `shouldBe` grid
-
- it "icePlot: 全 sample について curve を返す" $ do
- let xs = [[1.0, 2.0], [3.0, 4.0], [5.0, 6.0]]
- predict zs = [sum row | row <- zs]
- grid = [0.0, 1.0, 2.0]
- ice = Interp.icePlot predict xs 0 grid
- length (Interp.iceCurves ice) `shouldBe` 3
- length (Interp.iceFeatureValues ice) `shouldBe` 3
- -- iceMean should equal partial dependence
- length (Interp.iceMean ice) `shouldBe` 3
-
- -- ─────────────────────────────────────────────────────────────────────
- describe "Hanalyze.Model.LM.Diagnostics (vs statsmodels OLS)" $ do
- let xRaw = [1.0, 2, 3, 4, 5, 6, 7, 8, 9, 10]
- yRaw = [3.7, 5.2, 6.8, 8.5, 9.9, 11.3, 13.1, 14.4, 15.8, 17.2]
- x = LA.fromColumns
- [ LA.konst 1.0 (length xRaw)
- , LA.fromList xRaw
- ]
- y = LA.fromList yRaw
- fit = LM.fitLMVec x y
-
- approx tol a b = abs (a - b) < tol
- approxV tol expected actual =
- length expected == LA.size actual &&
- and (zipWith (approx tol) expected (LA.toList actual))
-
- it "ciTValue: 95% / df=8 ≈ 2.306" $
- LMD.ciTValue 0.95 8 `shouldSatisfy` approx 1e-3 2.306
-
- it "lmStdErrors matches statsmodels (intercept, slope)" $
- LMD.lmStdErrors x fit `shouldSatisfy`
- approxV 1e-5 [0.09602188, 0.01547533]
-
- it "lmCoefStats t / p match statsmodels" $ do
- let cs = LMD.lmCoefStats x fit
- length cs `shouldBe` 2
- LMD.csTValue (head cs) `shouldSatisfy` approx 1e-3 23.8834
- LMD.csTValue (cs !! 1) `shouldSatisfy` approx 1e-3 97.4768
- LMD.csPValue (head cs) `shouldSatisfy` approx 1e-9 1.0062e-8
- LMD.csPValue (cs !! 1) `shouldSatisfy` approx 1e-13 1.3699e-13
-
- it "lmFStatistic matches statsmodels (F, p, df1, df2)" $ do
- let fs = head (LMD.lmFStatistic x fit)
- LMD.fsValue fs `shouldSatisfy` approx 1e-1 9501.7193
- LMD.fsPValue fs `shouldSatisfy` approx 1e-13 1.3699e-13
- LMD.fsDf1 fs `shouldBe` 1
- LMD.fsDf2 fs `shouldBe` 8
-
- it "lmInformationCriteria (R lm() convention, k = p + 1 with σ)" $ do
- let ic = LMD.lmInformationCriteria fit
- LMD.icLogLik ic `shouldSatisfy` approx 1e-5 6.547424
- LMD.icAIC ic `shouldSatisfy` approx 1e-5 (-7.094848)
- LMD.icBIC ic `shouldSatisfy` approx 1e-5 (-6.187093)
-
- it "hatDiagonal matches statsmodels leverage" $
- LMD.hatDiagonal x `shouldSatisfy`
- approxV 1e-6
- [ 0.34545455, 0.24848485, 0.17575758, 0.12727273, 0.10303030
- , 0.10303030, 0.12727273, 0.17575758, 0.24848485, 0.34545455 ]
-
- it "standardizedResiduals match statsmodels (resid_studentized_internal)" $
- LMD.standardizedResiduals x fit `shouldSatisfy`
- approxV 1e-5
- [ -0.89534127, -0.90521501, -0.14722564, 1.31539084, 0.48257654
- , -0.33234045, 1.88308584, 0.30394970, -0.57197652, -1.56684722 ]
-
- it "cooksDistance matches statsmodels" $
- LMD.cooksDistance x fit `shouldSatisfy`
- approxV 1e-5
- [ 0.21154283, 0.13546767, 0.00231098, 0.12616429, 0.01337487
- , 0.00634342, 0.25856339, 0.00984992, 0.05408646, 0.64784992 ]
-
- it "predictorStdDevs: intercept col=0, x col≈3.0277" $ do
- let sds = LMD.predictorStdDevs x
- LA.size sds `shouldBe` 2
- (LA.toList sds !! 0) `shouldSatisfy` approx 1e-12 0
- (LA.toList sds !! 1) `shouldSatisfy` approx 1e-6 3.027650
-
- -- ─────────────────────────────────────────────────────────────────────
- describe "Hanalyze.Design.Orthogonal.listArraysWithSize" $ do
- it "returns one entry per standard array" $
- length OA.listArraysWithSize `shouldBe` length OA.standardArrays
-
- it "L9 entry exposes runs / factors / levels" $ do
- let l9meta = head [ m | m <- OA.listArraysWithSize
- , OA.omName m == OA.oaName OA.l9 ]
- OA.omRuns l9meta `shouldBe` 9
- OA.omFactors l9meta `shouldBe` 4
- OA.omLevels l9meta `shouldBe` [3, 3, 3, 3]
-
- -- ─────────────────────────────────────────────────────────────────────
- describe "Hanalyze.Design.Taguchi extras" $ do
- it "snRatioWithDetails: SmallerBetter on [1, 2, 3]" $ do
- let d = TG.snRatioWithDetails TG.SmallerBetter [1.0, 2.0, 3.0]
- TG.sdN d `shouldBe` 3
- TG.sdMean d `shouldSatisfy` (\v -> abs (v - 2.0) < 1e-12)
- TG.sdVariance d `shouldSatisfy` (\v -> abs (v - 1.0) < 1e-12)
- -- η = -10 log10((1+4+9)/3) = -10 log10(14/3) ≈ -6.690
- TG.sdSN d `shouldSatisfy` (\v -> abs (v - (-6.690)) < 1e-2)
-
- it "factorEffectsTable: contributions sum to 1" $ do
- let specs = [ OA.FactorSpec "A" [OA.LText "lo", OA.LText "hi"]
- , OA.FactorSpec "B" [OA.LNumeric 0, OA.LNumeric 1]
- ]
- case OA.assignFactors OA.l4 specs of
- Right ad -> do
- let sns = [10.0, 12.0, 11.0, 13.0]
- ext = TG.factorEffectsTable ad sns
- length ext `shouldBe` 2
- let totalC = sum (map TG.feeContribution ext)
- totalC `shouldSatisfy` (\v -> abs (v - 1.0) < 1e-12)
- all ((>= 0) . TG.feeRange) ext `shouldBe` True
- Left e -> expectationFailure (show e)
-
- -- ─────────────────────────────────────────────────────────────────────
- describe "Hanalyze.Design.Quality.processCapability" $ do
- it "centred process with σ=1, USL=6, LSL=−6 → Cp ≈ 2.0, Cpk ≈ 2.0" $ do
- -- 11-point symmetric sample around 0 with σ=1 (population)
- let xs = LA.fromList [-1.5, -1.0, -0.5, 0.5, 1.0, 1.5,
- 1.5, 1.0, 0.5, -0.5, -1.0, -1.5]
- cap = Quality.processCapability (-6) 6 xs
- Quality.capCp cap `shouldSatisfy` (> 0)
- -- For a centred sample, Cp == Cpk by symmetry.
- abs (Quality.capCp cap - Quality.capCpk cap)
- `shouldSatisfy` (< 1e-2)
-
- it "shifted process: Cpk < Cp" $ do
- let xs = LA.fromList [4.0, 4.5, 4.2, 4.8, 4.3, 4.6, 4.4, 4.7]
- cap = Quality.processCapability 0 6 xs
- Quality.capCp cap `shouldSatisfy` (> Quality.capCpk cap)
-
- it "processCapabilityUpper: only USL → Cp == Cpk" $ do
- let xs = LA.fromList [1.0, 1.2, 0.9, 1.1, 1.05, 0.95]
- cap = Quality.processCapabilityUpper 2.0 xs
- Quality.capCp cap `shouldBe` Quality.capCpk cap
-
- describe "Hanalyze.Model.GLM diagnostics (request/090-AB)" $ do
- let xsG = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] :: [Double]
- ysG = [1.1, 2.9, 5.2, 6.8, 9.1, 11.0, 13.2, 14.8, 17.0, 19.1] :: [Double]
- xMatG = LA.matrix 2 (concatMap (\x -> [1, x]) xsG)
- yVecG = LA.fromList ysG
- (frG, sigmaG) = GLM.fitGLMFull GLM.Gaussian GLM.Identity xMatG yVecG
- betaG = head (LA.toColumns (Core.coefficients frG))
- muVG = head (LA.toColumns (Core.fitted frG))
-
- it "glmPearsonResiduals (Gaussian, V=1) == raw residuals" $ do
- let pr = GLM.glmPearsonResiduals GLM.Gaussian yVecG muVG
- rr = yVecG - muVG
- LA.norm_2 (pr - rr) `shouldSatisfy` (< 1e-9)
-
- it "glmDevianceResiduals (Gaussian) == sign(y-μ)·|y-μ|" $ do
- let dr = GLM.glmDevianceResiduals GLM.Gaussian yVecG muVG
- ref = LA.fromList
- [ signum (y - m) * abs (y - m)
- | (y, m) <- zip ysG (LA.toList muVG) ]
- LA.norm_2 (dr - ref) `shouldSatisfy` (< 1e-9)
-
- it "glmVariance: Binomial μ(1-μ); Poisson μ" $ do
- GLM.glmVariance GLM.Binomial 0.3 `shouldBe` 0.3 * 0.7
- GLM.glmVariance GLM.Poisson 4.0 `shouldBe` 4.0
-
- it "predictGlmEtaWithSE: η = xᵀβ, SE > 0" $ do
- let xNew = LA.fromList [1, 5.0]
- (eta, se) = GLM.predictGlmEtaWithSE betaG sigmaG xNew
- eta `shouldSatisfy` (\e -> abs (e - (1 + 2 * 5.0)) < 0.5)
- se `shouldSatisfy` (> 0)
- se `shouldSatisfy` (< 1)
-
- it "predictGlmMuWithCI (Identity): half-width ≈ 1.96·SE" $ do
- let xNew = LA.fromList [1, 4.5]
- ci = GLM.predictGlmMuWithCI GLM.Identity 0.95 betaG sigmaG xNew
- (_, se) = GLM.predictGlmEtaWithSE betaG sigmaG xNew
- halfW = (GLM.gpHi ci - GLM.gpLo ci) / 2
- abs (halfW - 1.96 * se) `shouldSatisfy` (< 1e-2)
-
- it "predictGlmMuWithCI (Logit): CI stays in (0,1)" $ do
- let xs2 = LA.matrix 2 (concatMap (\i -> [1, fromIntegral (i :: Int)]) [0..9])
- ys2 = LA.fromList [0,1,0,1,0,1,0,1,0,1]
- (_, sigma2) = GLM.fitGLMFull GLM.Binomial GLM.Logit xs2 ys2
- beta2 = LA.fromList [0.0, 0.05]
- xNew = LA.fromList [1, 5.0]
- ci = GLM.predictGlmMuWithCI GLM.Logit 0.95 beta2 sigma2 xNew
- GLM.gpMu ci `shouldSatisfy` (\v -> v > 0 && v < 1)
- GLM.gpLo ci `shouldSatisfy` (\v -> v >= 0)
- GLM.gpHi ci `shouldSatisfy` (\v -> v <= 1)
- GLM.gpLo ci `shouldSatisfy` (< GLM.gpHi ci)
-
- describe "Hanalyze.Model.GLMM SE (request/100)" $ do
- -- Same fixture as the GLMM tests above (3 groups × 4 obs).
- -- design X = [1, x] over the same 12 rows.
- let xMat12 = LA.matrix 2
- ( concatMap (\v -> [1, v])
- [1,2,3,4,1,2,3,4,1,2,3,4 :: Double] )
- yVec12 = LA.fromList
- [7.1,6.9,7.0,7.0, 5.0,4.9,5.1,5.0, 3.0,2.9,3.1,3.0]
- gVec12 = V.fromList
- ["A","A","A","A","B","B","B","B","C","C","C","C" :: T.Text]
- -- Inline group construction (mirrors Hanalyze.Model.GLMM.buildGroups
- -- which is currently internal).
- gLabels12 = V.fromList ["A", "B", "C"] :: V.Vector T.Text
- gIdx12 = V.map
- (\g -> case V.elemIndex g gLabels12 of
- Just i -> i
- Nothing -> 0)
- gVec12
- gSizes12 = V.fromList [4, 4, 4]
- glmmRes = fitLME xMat12 yVec12 gIdx12 gLabels12 gSizes12
- idx12 = gIdx12
-
- it "glmmFixedSE: returns one SE per coefficient (length p)" $ do
- let ses = glmmFixedSE xMat12 idx12 glmmRes
- LA.size ses `shouldBe` LA.cols xMat12
-
- it "glmmFixedSE: all SEs are positive" $ do
- let ses = glmmFixedSE xMat12 idx12 glmmRes
- mapM_ (\v -> v `shouldSatisfy` (> 0)) (LA.toList ses)
-
- it "glmmFixedSE: σ_u → 0 reduces to OLS SE within tolerance" $ do
- -- Force σ²_u to 0 (no random effects → OLS).
- let resOLS = glmmRes { glmmRandVar = 0 }
- sesG = glmmFixedSE xMat12 idx12 resOLS
- -- Reference OLS SE from σ² (XᵀX)⁻¹.
- xtx = LA.tr xMat12 LA.<> xMat12
- covOLS = LA.scale (glmmResidVar resOLS) (LA.inv xtx)
- sesOLS = LA.fromList
- [ sqrt (LA.atIndex covOLS (i, i))
- | i <- [0 .. LA.cols xMat12 - 1] ]
- LA.norm_Inf (sesG - sesOLS) `shouldSatisfy` (< 1e-9)
-
- it "glmmBLUPSE: one entry per group, all positive" $ do
- let ses = glmmBLUPSE idx12 glmmRes
- V.length ses `shouldBe` V.length (glmmGroups glmmRes)
- mapM_ (\v -> v `shouldSatisfy` (> 0)) (V.toList ses)
-
- it "glmmBLUPSE: shrinkage formula (1/σ²_u + n_j/σ²)⁻¹^½" $ do
- let ses = glmmBLUPSE idx12 glmmRes
- sig2u = glmmRandVar glmmRes
- sig2 = glmmResidVar glmmRes
- -- Group sizes: A=4, B=4, C=4 (balanced design)
- expected = sqrt (1.0 / (1.0 / sig2u + 4.0 / sig2))
- mapM_ (\(_, v) -> abs (v - expected) `shouldSatisfy` (< 1e-9))
- (zip [0 :: Int ..] (V.toList ses))
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs
new file mode 100644
--- /dev/null
+++ b/test/SpecHelper.hs
@@ -0,0 +1,203 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+-- 全 Spec ファイル共通の helper / orphan Arbitrary instance。
+module SpecHelper where
+
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import qualified Numeric.AD.Mode.Reverse.Double as RevD
+import qualified Numeric.LinearAlgebra as LA
+-- (DataFrame の直接 import は未使用のため削除 = upstream decomp PR#2 移植の副産物調査で判明)
+import qualified Hanalyze.Design.Orthogonal as OA
+import qualified Hanalyze.Design.Quality as Quality
+import qualified Hanalyze.Design.Taguchi as TG
+import qualified Hanalyze.Model.LM as LM
+import qualified Hanalyze.Model.LM.Diagnostics as LMD
+import qualified Hanalyze.DataIO.Preprocess as Pp
+import qualified Hanalyze.DataIO.Log as Log
+import qualified Hanalyze.DataIO.CSV as CSV
+import qualified Hanalyze.DataIO.Convert as Conv
+import qualified Hanalyze.DataIO.Health as Health
+import qualified Hanalyze.DataIO.Clean as Clean
+import qualified Hanalyze.DataIO.Convert as Conv2
+import qualified Hanalyze.Stat.Standardize as Std
+import qualified Hanalyze.Stat.NumberFormat as NF
+import qualified Hanalyze.Stat.Interpolate as Interp
+import qualified Hanalyze.Stat.AdaptiveGrid as AG
+import qualified Hanalyze.Stat.KernelDist as KD
+import qualified Hanalyze.Stat.Cholesky as Chol
+import qualified Hanalyze.Stat.QuasiRandom as QR
+import qualified Hanalyze.Stat.Test as ST
+import qualified Hanalyze.Model.HierarchicalCluster as HC
+import qualified Hanalyze.Model.AFT as AFT
+import qualified Hanalyze.Model.RandomForestClassifier as RFC
+import qualified Hanalyze.Model.RandomForest as RF
+import qualified Hanalyze.Model.FitYByX as FXY
+import qualified Hanalyze.Model.Weibull as WB
+import qualified Data.Vector.Unboxed as VU
+import qualified Hanalyze.Stat.ClassMetrics as CM
+import qualified Hanalyze.Stat.CV as CV
+import qualified Hanalyze.Stat.MultipleTesting as MT
+import qualified Hanalyze.Stat.Bootstrap as Boot
+import qualified Hanalyze.Stat.Effect as Eff
+import qualified Hanalyze.Stat.Interpret as Interp
+import qualified Hanalyze.Stat.SPC as SPC
+import qualified Hanalyze.Model.Weibull as Wei
+import qualified Hanalyze.Model.Reliability as Rel
+import qualified Hanalyze.Optim.NSGA as NSGAP3
+import qualified Hanalyze.Stat.GroupComparison as GC
+import qualified Hanalyze.Design.Optimal as OPT
+import qualified Hanalyze.Design.Diagnostics as DDiag
+import qualified Hanalyze.Design.Constraint as DCons
+import qualified Hanalyze.Design.Custom.Factor as CF
+import qualified Hanalyze.Design.Custom.Model as CM
+import qualified Hanalyze.Design.Custom.Constraint as CC
+import qualified Hanalyze.Design.Custom.RegionMoment as RM
+import qualified Hanalyze.Design.Custom.Coordinate as CX
+import qualified Hanalyze.Design.Custom.Compare as CCMP
+import qualified Hanalyze.Design.Custom.Power as CPW
+import qualified Hanalyze.Design.Custom.Augment as CAUG
+import qualified Hanalyze.Design.Custom.SplitPlot as CSP
+import qualified Hanalyze.Design.Custom.Bayesian as CB
+import qualified Data.Vector.Storable as VS
+import qualified Data.Map.Strict as M
+import qualified Data.Set as Set
+import qualified Hanalyze.Model.StateSpace as SS
+import qualified Hanalyze.Model.NeuralNetwork as NN
+import qualified Hanalyze.Model.GradientBoosting as GB
+import qualified Hanalyze.Stat.MDS as MDS
+import qualified Hanalyze.Model.KNN as KNN
+import qualified Hanalyze.Model.NaiveBayes as NB
+import qualified Hanalyze.Model.GARCH as GARCH
+import qualified Hanalyze.Model.VAR as VAR
+import qualified Hanalyze.Model.CompetingRisks as CR
+import qualified Hanalyze.Model.ReliabilityBlockDiagram as RBD
+import qualified System.Random.MWC.Distributions as MWCD
+import qualified Hanalyze.Design.SpaceFilling as SF
+import qualified Hanalyze.Design.DSD as DSD
+import qualified Hanalyze.Design.Mixture as Mix
+import qualified Hanalyze.Design.Sequential as Seq
+import qualified Hanalyze.Design.RSM as RSMd
+import qualified Hanalyze.Model.PCA as PCA
+import qualified Hanalyze.Model.Cluster as Cl
+import qualified Hanalyze.Model.DecisionTree as DT
+import qualified Hanalyze.Model.TimeSeries as TS
+import qualified Hanalyze.Model.Survival as Surv
+import qualified Hanalyze.DataIO.Reshape as Reshape
+import qualified Hanalyze.Optim.NSGA as NSGA
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.Model.KernelRegression as Kn
+import qualified Hanalyze.Model.GP as GP
+import qualified Hanalyze.Model.GPRobust as GPR
+import qualified Hanalyze.Viz.ReportBuilder as RB
+import qualified Hanalyze.Viz.ModelGraph as VMG
+import qualified Hanalyze.Viz.ModelGraphDot as VMGD
+import qualified Data.ByteString as BS
+import qualified Hanalyze.Model.GP as GP
+import qualified Hanalyze.Model.GPRobust as GPR
+import qualified Hanalyze.Model.RFF as RFF
+import qualified Hanalyze.Model.Regularized as Reg
+import qualified Hanalyze.Model.Spline as Sp
+import qualified Hanalyze.Model.KernelRegression as K
+import qualified Hanalyze.Model.Core as Core
+import qualified Hanalyze.Model.GLM as GLM
+import qualified Hanalyze.Optim.NelderMead as NM
+import qualified Hanalyze.Optim.LBFGS as LBFGS
+import qualified Hanalyze.Optim.LineSearch as LS
+import qualified Hanalyze.Optim.DifferentialEvolution as DE
+import qualified Hanalyze.Optim.CMAES as CMAES
+import qualified Hanalyze.Optim.CMAESFull as CMAESF
+import qualified Hanalyze.Optim.SimulatedAnnealing as SA
+import qualified Hanalyze.Optim.ParticleSwarm as PSO
+import qualified Hanalyze.Optim.Constrained as Con
+import qualified Hanalyze.Optim.BayesOpt as BO
+import qualified Hanalyze.Optim.Common as OC
+import qualified System.Random.MWC as MWC
+import qualified Hanalyze.MCMC.NUTS as NUTS
+import qualified Hanalyze.MCMC.SMC as SMC
+import qualified Hanalyze.MCMC.MH as MH
+import qualified Hanalyze.MCMC.Slice as Slice
+import qualified Hanalyze.MCMC.HMC as HMC
+import qualified Hanalyze.MCMC.Gibbs as Gibbs
+import qualified Hanalyze.Stat.BridgeSampling as BS
+import qualified Hanalyze.Stat.BayesFactor as BF
+import qualified Hanalyze.Stat.BayesianModelAveraging as BMA
+import qualified Hanalyze.Stat.Causal.PropensityScore as PS
+import qualified Hanalyze.Stat.Causal.IPW as CIPW
+import qualified Hanalyze.Stat.Causal.DoublyRobust as CDR
+import qualified Hanalyze.Stat.Causal.CATE as CCATE
+import qualified Hanalyze.Model.RegularizedAdvanced as RegA
+import qualified Hanalyze.Model.Robust as Rob
+import qualified Hanalyze.Stat.CorrelationNetwork as CN
+import qualified Hanalyze.Model.LatentClassAnalysis as LCA
+import qualified Hanalyze.Model.FDA as FDA
+import qualified Hanalyze.Model.LiNGAM.Direct as LNG
+import qualified Hanalyze.Model.LiNGAM.Pairwise as LNGP
+import qualified Hanalyze.Model.LiNGAM.MultiGroup as LNGM
+import qualified Hanalyze.Model.LiNGAM.VAR as LNGV
+import qualified Hanalyze.Model.LiNGAM.Parce as LNGPa
+import qualified Hanalyze.Model.LiNGAM.Bootstrap as LNGB
+import qualified Hanalyze.Model.LiNGAM.ICA as LNGI
+import qualified Hanalyze.Math.Hungarian as Hung
+import qualified Hanalyze.Math.HSIC as HSIC
+import qualified Hanalyze.Model.DAG as DAG
+import qualified Hanalyze.MCMC.Core as Core
+import qualified Hanalyze.MCMC.BayesianTest as BAB
+import qualified Hanalyze.Model.PLS as PLS
+import qualified Hanalyze.Model.Discriminant as LDA
+import qualified Hanalyze.Design.GaugeRR as GRR
+import qualified Hanalyze.Model.HBM as HBM
+import qualified Hanalyze.Model.HBM.Interp as HI
+import qualified Hanalyze.Stat.VI as VI
+import qualified Data.Map.Strict as M
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck
+import Hanalyze.Model.Formula
+import Hanalyze.Model.Formula.Frame
+import Hanalyze.Model.Formula.Design
+import Hanalyze.Model.Formula.RFormula
+import Hanalyze.Model.Formula.Nonlinear
+import Hanalyze.Model.Formula.Mixed
+import Hanalyze.Model.GLMM
+import Hanalyze.Model.GLM (Family (..), LinkFn (..))
+import Hanalyze.Stat.Distribution (Transform)
+import Data.List (sort, nub)
+import Control.Monad (forM, forM_)
+import System.IO.Temp (withSystemTempFile)
+import System.IO (hPutStr, hClose)
+import Hanalyze.Model.HBM.Ast (Expr (..), Lit (..), DoStmt (..), Err)
+import Data.IORef (newIORef, readIORef, modifyIORef')
+
+isLeftE :: Either a b -> Bool
+isLeftE = either (const True) (const False)
+
+isRightE :: Either a b -> Bool
+isRightE = either (const False) (const True)
+
+genName :: Gen T.Text
+genName = elements ["a", "b", "c", "x", "y", "z", "g", "t", "b0", "b1", "bg"]
+
+genTerm :: Int -> Gen Term
+genTerm n
+ | n <= 1 = oneof
+ [ Lit . fromIntegral <$> (choose (0, 9) :: Gen Int)
+ , Ref <$> genName
+ ]
+ | otherwise = oneof
+ [ Lit . fromIntegral <$> (choose (0, 9) :: Gen Int)
+ , Ref <$> genName
+ , App <$> genName <*> (choose (1, 2) >>= \k -> vectorOf k (genTerm (n `div` 2)))
+ , Index <$> genTerm (n `div` 2) <*> genTerm (n `div` 2)
+ , Neg <$> genTerm (n - 1)
+ , Bin <$> elements [Add, Sub, Mul, Div, Pow]
+ <*> genTerm (n `div` 2) <*> genTerm (n `div` 2)
+ ]
+
+instance Arbitrary Formula where
+ arbitrary = do
+ nd <- choose (0, 2) :: Gen Int
+ vars <- vectorOf (nd + 1) genName
+ rhs <- sized genTerm
+ pure (Formula (head vars) (tail vars) rhs)