diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog for `hgg-analyze-bridge` + +## 0.1.0.0 — 2026-07-18 + +First public release on Hackage. + +- Bridge from hanalyze: draw fitted models (`toPlot` / `statLm`) and HBM `ModelGraph` DAGs directly. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +BSD 3-Clause License + +Copyright (c) 2026, Toshiaki Honda +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/examples/StatInDemo.hs b/examples/StatInDemo.hs new file mode 100644 --- /dev/null +++ b/examples/StatInDemo.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | 系統 B (ggplot 風スタット・イン) デモ (Phase 16)。 +-- +-- df を 1 回参照し、 stat layer (statLm / statSmooth) を通常 geom と同じく @<>@ で重ねる。 +-- 描画は 'saveSVGBoundStats' = bpResolver で resolveStats してから SVG 保存 (回帰計算は +-- hanalyze に委譲、 = ggplot @geom_smooth(method="lm")@ 相当)。 装飾も通常 geom と同じ。 +-- 出力 = design/stat-in/*.svg (gitignore 想定)。 rsvg で PNG 化して目視。 +module Main where + +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Vector as V + +import Graphics.Hgg.Bridge.Stat (saveSVGBoundStats) +import Graphics.Hgg.Frame ((|>>)) +import Graphics.Hgg.Spec (ColData (..), color, colorBy, fromHex, + layer, scatter, statLm, statLmLevel, + statPoly, statResid, statSmooth, + statSmoothCI, stroke, title) +import System.Directory (createDirectoryIfMissing) + +-- 線形データ: y = 2x + 3 + 軽いノイズ。 +linX, linY :: V.Vector Double +linX = V.fromList [1 .. 30] +linY = V.fromList [ 2 * x + 3 + noise i | (i, x) <- zip [0 ..] [1 .. 30] ] + where noise i = 2.5 * sin (fromIntegral (i :: Int) * 1.3) + +-- 非線形データ: y = sin(x) 波形 + ノイズ (smooth 用)。 +smX, smY :: V.Vector Double +smX = V.fromList [ fromIntegral i * 0.3 | i <- [0 .. 40 :: Int] ] +smY = V.fromList [ sin (fromIntegral i * 0.3) + 0.15 * c i | i <- [0 .. 40 :: Int] ] + where c i = sin (fromIntegral i * 2.7) + +-- 二次データ: y = 0.5x² - 4x + 10 + ノイズ (poly 用)。 +quX, quY :: V.Vector Double +quX = V.fromList [ fromIntegral i * 0.5 | i <- [0 .. 30 :: Int] ] +quY = V.fromList [ 0.5 * x * x - 4 * x + 10 + 3 * sin (fromIntegral i * 1.7) + | (i, x) <- zip [0 :: Int ..] [ fromIntegral j * 0.5 | j <- [0 .. 30 :: Int] ] ] + +-- 2 群データ (B2 group 別 fit 用): g="A" 傾き 1.5 / g="B" 傾き 3.5、 各 20 点。 +grpX, grpY :: V.Vector Double +grpG :: V.Vector Text +grpX = V.fromList (xa ++ xa) where xa = [1 .. 20] +grpY = V.fromList (map (\x -> 1.5 * x + 2 + nz x) xa + ++ map (\x -> 3.5 * x + 2 + nz x) xa) + where xa = [1 .. 20]; nz x = 2.0 * sin (x * 1.9) +grpG = V.fromList (replicate 20 "A" ++ replicate 20 "B") + +main :: IO () +main = do + createDirectoryIfMissing True "design/stat-in" + + -- (1) lm: 散布図 + 回帰線 + 95% 信頼帯。 df 1 回参照・装飾込み (ggplot geom_smooth(method="lm") 相当) + let dfLin = M.fromList [ ("x", NumData linX), ("y", NumData linY) ] :: M.Map Text ColData + saveSVGBoundStats "design/stat-in/lm-stat-in.svg" $ + dfLin |>> ( layer (scatter "x" "y") + <> layer (statLm "x" "y" <> color (fromHex "#d62728") <> stroke 2) + <> title "stat-in: lm (df 1 回・装飾込み)" ) + + -- (2) smooth: 散布図 + B-spline 平滑曲線 (帯なし) + let dfSm = M.fromList [ ("x", NumData smX), ("y", NumData smY) ] :: M.Map Text ColData + saveSVGBoundStats "design/stat-in/smooth-stat-in.svg" $ + dfSm |>> ( layer (scatter "x" "y") + <> layer (statSmooth "x" "y" 6 <> color (fromHex "#1f77b4") <> stroke 2) + <> title "stat-in: smooth (B-spline)" ) + + -- (3) B1: statLmLevel 0.99 = 信頼水準を可変に (帯が 95% より広い) + saveSVGBoundStats "design/stat-in/lm-level99-stat-in.svg" $ + dfLin |>> ( layer (scatter "x" "y") + <> layer (statLmLevel "x" "y" 0.99 <> color (fromHex "#d62728") <> stroke 2) + <> title "stat-in: statLmLevel 0.99 (帯が広い)" ) + + -- (4) B1: statSmoothCI = B-spline 平滑 + 信頼帯 (statSmooth は帯なし) + saveSVGBoundStats "design/stat-in/smooth-ci-stat-in.svg" $ + dfSm |>> ( layer (scatter "x" "y") + <> layer (statSmoothCI "x" "y" 6 <> color (fromHex "#1f77b4") <> stroke 2) + <> title "stat-in: statSmoothCI (B-spline + 帯)" ) + + -- (5) B3: statPoly = 多項式回帰 (deg=2) + 信頼帯 + let dfQu = M.fromList [ ("x", NumData quX), ("y", NumData quY) ] :: M.Map Text ColData + saveSVGBoundStats "design/stat-in/poly-stat-in.svg" $ + dfQu |>> ( layer (scatter "x" "y") + <> layer (statPoly "x" "y" 2 <> color (fromHex "#2ca02c") <> stroke 2) + <> title "stat-in: statPoly deg=2 (二次回帰 + 帯)" ) + + -- (6) B3: statResid = 残差 vs fitted 診断散布 (= base R plot(lm) #1) + saveSVGBoundStats "design/stat-in/resid-stat-in.svg" $ + dfQu |>> ( layer (statResid "x" "y" <> color (fromHex "#9467bd")) + <> title "stat-in: statResid (残差 vs fitted)" ) + + -- (7) B2: group 別 fit = statLm <> colorBy "g" (群ごとに回帰線+帯を ggplotHue で色分け) + let dfGrp = M.fromList [ ("x", NumData grpX), ("y", NumData grpY) + , ("g", TxtData grpG) ] :: M.Map Text ColData + saveSVGBoundStats "design/stat-in/group-lm-stat-in.svg" $ + dfGrp |>> ( layer (scatter "x" "y" <> colorBy "g") + <> layer (statLm "x" "y" <> colorBy "g" <> stroke 2) + <> title "stat-in: group 別 lm (statLm <> colorBy g)" ) + + putStrLn "wrote design/stat-in/*.svg (7 files incl group-lm)" diff --git a/examples/ThreeRoutesDemo.hs b/examples/ThreeRoutesDemo.hs new file mode 100644 --- /dev/null +++ b/examples/ThreeRoutesDemo.hs @@ -0,0 +1,102 @@ +-- | Phase 2 A6: 3 ルート並列出力 demo。 +-- +-- 同じ 'ModelGraph' を 3 種類の出力ルート (Mermaid HTML / Graphviz DOT / +-- hgg SVG) で同時生成し、 ユーザが用途別に比較できるようにする。 +-- +-- @ +-- cabal run three-routes-demo +-- @ +-- → @design/three-routes/@ に下記 3 形式 × 3 model (= 計 9 ファイル) を出力。 +-- +-- Demo モデル: 単純 LM / 階層 LM (= 2 plate) / nested plate (= 多重所属) の 3 種。 +-- +-- 注: 本 demo は analyze 自体に置けない (= analyze は hgg に依存しない、 +-- 計画 §4.1 依存方向規律)。 bridge package 内 demo として配置。 +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import System.Directory (createDirectoryIfMissing) + +import Hanalyze.Model.HBM (ModelGraph (..), Node (..), + NodeKind (..)) +import qualified Hanalyze.Viz.ModelGraph as Mermaid +import qualified Hanalyze.Viz.ModelGraphDot as Dot + +import Graphics.Hgg.Bridge.Analyze + (renderModelGraphSVG) + +-- =========================================================================== +-- Demo モデル (= A2 test fixture と同じ、 再利用) +-- =========================================================================== + +simpleLM :: ModelGraph +simpleLM = ModelGraph + { mgNodes = + [ Node "alpha" LatentN "Normal" Set.empty [] + , Node "beta" LatentN "Normal" Set.empty [] + , Node "y" (ObservedN 100) "Normal" Set.empty [] + ] + , mgEdges = [("alpha", "y"), ("beta", "y")] + , mgPlates = Map.empty + } + +hierLM :: ModelGraph +hierLM = ModelGraph + { mgNodes = + [ Node "mu_g" LatentN "Normal" Set.empty [] + , Node "sig_g" LatentN "HalfCauchy" Set.empty [] + , Node "mu" LatentN "Normal" Set.empty ["group"] + , Node "y" (ObservedN 200) "Normal" Set.empty ["record"] + ] + , mgEdges = [("mu_g", "mu"), ("sig_g", "mu"), ("mu", "y")] + , mgPlates = Map.fromList [("group", 5), ("record", 200)] + } + +nestedPlate :: ModelGraph +nestedPlate = ModelGraph + { mgNodes = + [ Node "mu" LatentN "Normal" Set.empty [] + , Node "mu_c" LatentN "Normal" Set.empty ["condition"] + , Node "y" (ObservedN 200) "Normal" Set.empty ["record", "condition"] + ] + , mgEdges = [("mu", "mu_c"), ("mu_c", "y")] + , mgPlates = Map.fromList [("record", 200), ("condition", 3)] + } + +-- =========================================================================== +-- Runner +-- =========================================================================== + +main :: IO () +main = do + let outDir = "design/three-routes" + createDirectoryIfMissing True outDir + mapM_ (renderAllRoutes outDir) + [ ("simple-lm", "Simple LM (= 3 node、 plate 無し)", simpleLM) + , ("hier-lm", "Hierarchical LM (= 2 plate、 disjoint)", hierLM) + , ("nested-plate","Nested plate (= y が 2 plate に属す)", nestedPlate) + ] + putStrLn "" + putStrLn $ "Wrote 9 files to " <> outDir <> "/" + putStrLn " *-mermaid.html (= Mermaid CDN 経由ブラウザ描画)" + putStrLn " *-graphviz.dot (= dot CLI で SVG/PNG 化用)" + putStrLn " *-hgg.svg (= hgg 直 SVG、 依存ゼロ)" + +renderAllRoutes :: FilePath -> (String, T.Text, ModelGraph) -> IO () +renderAllRoutes outDir (slug, titleTxt, mg) = do + let base = outDir <> "/" <> slug + + -- Route 1: Mermaid HTML + Mermaid.renderModelGraph (base <> "-mermaid.html") titleTxt mg + + -- Route 2: Graphviz DOT (= .dot 中間 text) + TIO.writeFile (base <> "-graphviz.dot") (Dot.renderModelGraphDot mg) + + -- Route 3: hgg SVG (= 依存ゼロの直描画) + renderModelGraphSVG (base <> "-hgg.svg") titleTxt mg + + putStrLn $ " " <> slug <> ": 3 形式 出力 (mermaid.html / graphviz.dot / hgg.svg)" diff --git a/hgg-analyze-bridge.cabal b/hgg-analyze-bridge.cabal new file mode 100644 --- /dev/null +++ b/hgg-analyze-bridge.cabal @@ -0,0 +1,88 @@ +cabal-version: 3.0 +name: hgg-analyze-bridge +version: 0.1.0.0 +extra-doc-files: CHANGELOG.md +synopsis: Bridge from hanalyze (Hanalyze.Model.HBM.ModelGraph) to hgg DAG rendering +description: + Renders hanalyze's HBM ModelGraph directly to SVG / PNG / PDF via hgg. + No graphviz CLI or Mermaid CDN dependency, which makes it suitable for + embedding in production applications and for offline batch use. + . + The existing Mermaid HTML (Hanalyze.Viz.ModelGraph) and Graphviz DOT + (Hanalyze.Viz.ModelGraphDot) routes in hanalyze remain available; + choose whichever fits the use case. +license: BSD-3-Clause +homepage: https://github.com/frenzieddoll/hgg +license-file: LICENSE +author: Toshiaki Honda +maintainer: frenzieddoll@gmail.com +copyright: 2026 Aelysce Project (Toshiaki Honda) +category: Graphics +build-type: Simple + +common warnings + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields + -Wredundant-constraints + +library + import: warnings + exposed-modules: Graphics.Hgg.Bridge.Analyze + Graphics.Hgg.Bridge.Analyze.Internal + Graphics.Hgg.Bridge.Stat + hs-source-dirs: src + build-depends: base >= 4.17 && < 5 + , text >= 2.0 && < 2.2 + , containers >= 0.6 && < 0.8 + , vector >= 0.12 && < 0.14 + , dataframe-core ^>= 1.1 + , hgg-core ^>= 0.1 + , hgg-frame ^>= 0.1 + , hgg-svg ^>= 0.1 + , hanalyze >= 0.2 && < 0.3 + , hmatrix >= 0.20 && < 0.21 + default-language: Haskell2010 + +executable three-routes-demo + import: warnings + main-is: ThreeRoutesDemo.hs + hs-source-dirs: examples + build-depends: base + , text + , containers + , directory + , hgg-analyze-bridge + , hanalyze >= 0.2 && < 0.3 + default-language: Haskell2010 + +executable stat-in-demo + import: warnings + main-is: StatInDemo.hs + hs-source-dirs: examples + build-depends: base + , vector >= 0.12 && < 0.14 + , containers + , text + , directory + , hgg-analyze-bridge + , hgg-core + , hgg-frame + , hgg-svg + default-language: Haskell2010 + +test-suite hgg-analyze-bridge-tests + import: warnings + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + build-depends: base + , text + , containers + , vector >= 0.12 && < 0.14 + , dataframe-core ^>= 1.1 + , hgg-analyze-bridge + , hgg-core + , hgg-frame + , hanalyze >= 0.2 && < 0.3 + , hspec >= 2.10 && < 2.12 + default-language: Haskell2010 diff --git a/src/Graphics/Hgg/Bridge/Analyze.hs b/src/Graphics/Hgg/Bridge/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Bridge/Analyze.hs @@ -0,0 +1,175 @@ +-- | +-- Module : Graphics.Hgg.Bridge.Analyze +-- Description : hanalyze ModelGraph → hgg SVG/PNG/PDF 直描画 bridge +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- hanalyze の 'Hanalyze.Model.HBM.ModelGraph' を、 hgg 経由で +-- 直接 SVG / PNG / PDF に描画する公開 API。 graphviz CLI / Mermaid CDN 依存なし。 +-- +-- == 3 ルートの選び方 +-- +-- 同じ 'ModelGraph' を出力する 3 種類のルートがある。 用途に応じて使い分け: +-- +-- +---------------+---------------------------------------------+--------------------+-----------------------+ +-- | ルート | 場所 | 出力 / 描画依存 | 推奨用途 | +-- +===============+=============================================+====================+=======================+ +-- | Mermaid HTML | @Hanalyze.Viz.ModelGraph.renderModelGraph@ | .html + CDN script | GitHub README、 ノート | +-- +---------------+---------------------------------------------+--------------------+-----------------------+ +-- | Graphviz DOT | @Hanalyze.Viz.ModelGraphDot.toDot@ | .dot text + dot CLI| graphviz 連携、 加工 | +-- +---------------+---------------------------------------------+--------------------+-----------------------+ +-- | 本 module | 'renderModelGraphSVG' (= A3 完了) | 依存ゼロ | production、 offline | +-- | | 'renderModelGraphPNG' / 'renderModelGraphPDF' (= A4 stub、 backend 待ち) | | | +-- +---------------+---------------------------------------------+--------------------+-----------------------+ +-- +-- 3 ルートとも同じ 'ModelGraph' 構造 (= node / edge / plate) を表現する。 +-- visual layout は実装ごとに異なる: 本ルートは graphviz dot 70-80% 同等品質 +-- (Phase 1 §10.1)。 +-- +-- == 使用例 (= A3 で 'renderModelGraphSVG' 公開予定) +-- +-- @ +-- import Graphics.Hgg.Bridge.Analyze (modelGraphToDAGSpec) +-- import Hanalyze.Model.HBM (buildModelGraph) +-- +-- main = do +-- let mg = buildModelGraph myModel +-- (nodes, edges, plates) = modelGraphToDAGSpec mg +-- -- → A3 で renderModelGraphSVG file title mg として 1 行で完結予定 +-- @ +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Bridge.Analyze + ( -- * ModelGraph → DAGSpec 変換 (Phase 2 A2) + modelGraphToDAGSpec + , modelGraphToDAGNodes + , modelGraphToDAGEdges + , modelGraphToDAGPlates + -- * 直描画 API (Phase 2 A3 SVG) + , renderModelGraphSVG + , renderModelGraphSVGBytes + , modelGraphToVisualSpec + -- * 直描画 API (Phase 2 A4 PNG / PDF、 backend 未実装の stub) + , renderModelGraphPNG + , renderModelGraphPDF + ) where + +import Data.Text (Text) +import qualified Data.Text.IO as TIO + +import qualified Graphics.Hgg.Backend.SVG as SVGBackend +import qualified Graphics.Hgg.DAG as DAG +import qualified Graphics.Hgg.Easy as Easy +import qualified Graphics.Hgg.Spec as Spec +import Hanalyze.Model.HBM (ModelGraph) + +import qualified Graphics.Hgg.Bridge.Analyze.Internal as I + +-- | 'ModelGraph' を ('[DAGNode]', '[DAGEdge]', '[DAGPlate]') の triple に変換。 +-- 各要素は 'Graphics.Hgg.Spec.dagFromListsWithPlates' に渡せる形になっている。 +modelGraphToDAGSpec + :: ModelGraph -> ([Spec.DAGNode], [Spec.DAGEdge], [Spec.DAGPlate]) +modelGraphToDAGSpec = I.toDAGTriple + +-- | 'modelGraphToDAGSpec' の node 部分のみ。 +modelGraphToDAGNodes :: ModelGraph -> [Spec.DAGNode] +modelGraphToDAGNodes = I.toDAGNodes + +-- | 'modelGraphToDAGSpec' の edge 部分のみ (= dePath は 'Nothing'、 layout で埋まる)。 +modelGraphToDAGEdges :: ModelGraph -> [Spec.DAGEdge] +modelGraphToDAGEdges = I.toDAGEdges + +-- | 'modelGraphToDAGSpec' の plate 部分のみ (= plate label は @"\ (N=\)"@)。 +modelGraphToDAGPlates :: ModelGraph -> [Spec.DAGPlate] +modelGraphToDAGPlates = I.toDAGPlates + +-- =========================================================================== +-- Phase 2 A3: SVG 直描画 API +-- =========================================================================== + +-- | 'ModelGraph' を Phase 1 完了の DAG layout (= Sugiyama framework + plate-aware +-- ordering + Catmull-Rom spline + port snap) でレンダリングし、 'VisualSpec' に +-- 包んで返す。 ユーザは title / theme / size 等を追加合成可能。 +-- +-- @ +-- let spec = modelGraphToVisualSpec mg +-- \<\> title \"My HBM\" +-- \<\> theme ThemeDark +-- \<\> widthMm 1200 \<\> heightMm 800 +-- @ +modelGraphToVisualSpec :: ModelGraph -> Spec.VisualSpec +modelGraphToVisualSpec mg = + let (nodes, edges, plates) = modelGraphToDAGSpec mg + -- Phase 1 layout pipeline を直接適用 (= Graph rebuild ではなく [DAGNode] + [DAGEdge] 経由) + -- これで isolated node + 多重所属 plate も保たれ、 O(N) で済む + (positioned, routed) = + DAG.layoutHierarchicalFullWithPlates nodes edges plates + dagSpec = Spec.dagFromListsWithPlates + positioned routed Spec.LayoutHierarchical plates + in Easy.purePlot <> Easy.layer (dagSpec <> Easy.size 22) + +-- | 'ModelGraph' を SVG ファイルに直描画。 title は plot 上部に表示。 +-- size / theme 等を細かく指定したい場合は 'modelGraphToVisualSpec' + 'plot' を使う。 +-- +-- @ +-- renderModelGraphSVG \"out\/dag.svg\" \"My HBM\" mg +-- @ +renderModelGraphSVG :: FilePath -> Text -> ModelGraph -> IO () +renderModelGraphSVG path titleTxt mg = + let spec = modelGraphToVisualSpec mg + <> Easy.title titleTxt + <> Easy.theme Easy.ThemeLight + <> Easy.widthMm 900 + <> Easy.heightMm 700 + in SVGBackend.saveSVG path spec + +-- | 'renderModelGraphSVG' の ByteString 版 (= ファイル書き出さず Text で返す)。 +-- web server / pipeline で SVG を直接他経路に流したいときに使う。 +renderModelGraphSVGBytes :: Text -> ModelGraph -> Text +renderModelGraphSVGBytes titleTxt mg = + let spec = modelGraphToVisualSpec mg + <> Easy.title titleTxt + <> Easy.theme Easy.ThemeLight + <> Easy.widthMm 900 + <> Easy.heightMm 700 + in SVGBackend.renderSVG spec + +-- 上記 helper 群は OverloadedStrings + qualified imports で標準的に書ける形。 +-- 内部実装の細かい調整 (= サイズ default / theme) は今後の利用で feedback ベースで変える。 +_unusedTextIO :: FilePath -> Text -> IO () +_unusedTextIO = TIO.writeFile + +-- =========================================================================== +-- Phase 2 A4: PNG / PDF 直描画 API (= backend 未実装の stub) +-- =========================================================================== + +-- | __現状 stub__: hgg-rasterific backend は未実装の placeholder +-- (= 実行すると @error \"not implemented yet\"@)。 本 API は signature を先に +-- 公開しておき、 backend 実装後に自動的に動くようにする。 +-- +-- 暫定的に PNG が必要なら 'renderModelGraphSVG' で SVG を出力し、 別 tool +-- (= @inkscape@ / @rsvg-convert@ 等) で PNG 化する経路を推奨。 +renderModelGraphPNG :: FilePath -> Text -> ModelGraph -> IO () +renderModelGraphPNG _path _titleTxt _mg = + error $ unlines + [ "renderModelGraphPNG: hgg-rasterific backend が未実装の placeholder です。" + , " 暫定回避: renderModelGraphSVG で SVG を出力し、 別 tool で PNG 化してください。" + , " 例: rsvg-convert input.svg -o output.png" + , " inkscape input.svg --export-png=output.png" + , " 本 API は backend 実装後に自動的に動作します (= signature 安定)。" + ] + +-- | __現状 stub__: hgg-pdf backend は未実装の placeholder +-- (= 実行すると @error \"not implemented yet\"@)。 本 API は signature を先に +-- 公開しておき、 backend 実装後に自動的に動くようにする。 +-- +-- 暫定的に PDF が必要なら 'renderModelGraphSVG' で SVG を出力し、 別 tool +-- (= @rsvg-convert -f pdf@ / @inkscape --export-pdf@ 等) で PDF 化する経路を推奨。 +renderModelGraphPDF :: FilePath -> Text -> ModelGraph -> IO () +renderModelGraphPDF _path _titleTxt _mg = + error $ unlines + [ "renderModelGraphPDF: hgg-pdf backend が未実装の placeholder です。" + , " 暫定回避: renderModelGraphSVG で SVG を出力し、 別 tool で PDF 化してください。" + , " 例: rsvg-convert -f pdf input.svg -o output.pdf" + , " inkscape input.svg --export-pdf=output.pdf" + , " 本 API は backend 実装後に自動的に動作します (= signature 安定)。" + ] diff --git a/src/Graphics/Hgg/Bridge/Analyze/Internal.hs b/src/Graphics/Hgg/Bridge/Analyze/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Bridge/Analyze/Internal.hs @@ -0,0 +1,105 @@ +-- | +-- Module : Graphics.Hgg.Bridge.Analyze.Internal +-- Description : ModelGraph → DAGSpec 変換 (= 公開 API は Bridge.Analyze) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- 本 module は internal。 直接利用は推奨しない (= API 安定保証なし)。 +-- 公開 helper は @Graphics.Hgg.Bridge.Analyze@ に。 +-- +-- Phase 2 A2: 'toDAGNodes' / 'toDAGEdges' / 'toDAGPlates' / 'toDAGTriple' の +-- 変換関数群。 NodeKind / Distribution / Plate stack の mapping を担当。 +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Bridge.Analyze.Internal + ( -- * 変換 + toDAGNodes + , toDAGEdges + , toDAGPlates + , toDAGTriple + -- * 内部 helper (= test 用に export) + , mapNodeKind + , plateLabel + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T + +import qualified Graphics.Hgg.Spec as Spec +import Hanalyze.Model.HBM (ModelGraph (..), Node (..), + NodeKind (..)) + +-- =========================================================================== +-- 変換層 +-- =========================================================================== + +-- | 全体変換: 'ModelGraph' → ('[DAGNode]', '[DAGEdge]', '[DAGPlate]')。 +-- 公開 API 側で 'Graphics.Hgg.DAG.dagPlotWithPlates' に渡す形に成形する。 +toDAGTriple :: ModelGraph -> ([Spec.DAGNode], [Spec.DAGEdge], [Spec.DAGPlate]) +toDAGTriple mg = + ( toDAGNodes mg + , toDAGEdges mg + , toDAGPlates mg + ) + +-- | 'mgNodes' を 'DAGNode' に変換。 dnX / dnY は 0 (= layout 計算で埋まる)、 +-- dnDist には分布名を 'Just' で入れる (= 空文字列なら 'Nothing' に正規化)。 +toDAGNodes :: ModelGraph -> [Spec.DAGNode] +toDAGNodes mg = + [ Spec.DAGNode + { Spec.dnId = nodeName n + , Spec.dnLabel = nodeName n + , Spec.dnKind = mapNodeKind (nodeKind n) + , Spec.dnDist = nonEmpty (nodeDist n) + , Spec.dnX = 0 + , Spec.dnY = 0 + } + | n <- mgNodes mg + ] + where + nonEmpty t = if T.null t then Nothing else Just t + +-- | 'mgEdges' (= (parent, child) 列) を 'DAGEdge' に。 dePath = Nothing +-- (= layout 計算で routing される)。 deRoute = Nothing (= 未 bake・layout で確定)。 +toDAGEdges :: ModelGraph -> [Spec.DAGEdge] +toDAGEdges mg = [ Spec.DAGEdge p c Nothing Nothing | (p, c) <- mgEdges mg ] + +-- | 'mgPlates' (= plate 名 → サイズ N) を 'DAGPlate' に。 +-- 各 plate の dpNodeIds は @nodePlates@ に当該 plate 名を含む node を列挙。 +-- dpLabel は @"\ (N=\)"@ の形式 (= dot / PyMC 慣例に近い)。 +toDAGPlates :: ModelGraph -> [Spec.DAGPlate] +toDAGPlates mg = + let nodesInPlate :: Text -> [Text] + nodesInPlate pname = + [ nodeName n | n <- mgNodes mg, pname `elem` nodePlates n ] + in [ Spec.DAGPlate + { Spec.dpLabel = plateLabel pname size + , Spec.dpNodeIds = nodesInPlate pname + } + | (pname, size) <- Map.toAscList (mgPlates mg) + ] + +-- =========================================================================== +-- Helpers +-- =========================================================================== + +-- | analyze の 'NodeKind' を hgg の 'DAGNodeKind' に。 +-- +-- * 'LatentN' → 'Spec.NodeLatent' (= 楕円、 stochastic latent) +-- * 'ObservedN _' → 'Spec.NodeObserved' (= 楕円 + 灰塗、 観測) +mapNodeKind :: NodeKind -> Spec.DAGNodeKind +mapNodeKind LatentN = Spec.NodeLatent +mapNodeKind (ObservedN _) = Spec.NodeObserved + +-- | plate label を @"\ (N=\)"@ の形式で生成。 +-- analyze の Mermaid / Graphviz DOT 出力と同じ形式。 +plateLabel :: Text -> Int -> Text +plateLabel name size = name <> " (N=" <> T.pack (show size) <> ")" + +-- =========================================================================== +-- 未使用警告抑止 +-- =========================================================================== + +_unused :: Map Text Int -> Int +_unused = Map.size diff --git a/src/Graphics/Hgg/Bridge/Stat.hs b/src/Graphics/Hgg/Bridge/Stat.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Bridge/Stat.hs @@ -0,0 +1,296 @@ +-- | +-- Module : Graphics.Hgg.Bridge.Stat +-- Description : ggplot 風 stat-in (statLm/statSmooth) の回帰計算を hanalyze に委譲して解決 (Phase 16) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- 系統 B (ggplot 風スタット・イン) の解決ロジック (Phase 16)。 +-- +-- ggplot の @geom_smooth(method="lm")@ / @stat_smooth@ に相当。 ユーザは plot-core の +-- __stat layer__ (@statLm@ / @statSmooth@) を通常 geom と同じく @<>@ で重ねる: +-- +-- @ +-- df |>> ( layer (scatter "x" "y") +-- <> layer (statLm "x" "y" <> colorStatic "red" <> stroke 2) -- 装飾も通常 geom と同じ +-- <> title "fit" ) +-- @ +-- +-- stat layer (@MStatLM@/@MStatSmooth@) は plot-core が持つ純タグで、 描画前に本モジュールの +-- 'resolveStats' が **回帰計算を hanalyze に委譲**して具体 layer (band + line) に展開する。 +-- +-- ★依存方向 (最重要): @plot-core@ は analyze 非依存のまま (タグを持つだけ)。 回帰 fit は +-- @plot → analyze@ の逆エッジゆえ本 opt-in 隔離 package (`hgg-analyze-bridge`) のみで行う。 +-- +-- ★使い方: バインド後に 'saveSVGBoundStats' / 'renderBoundStats' を使えば、 bpResolver で +-- 自動的に 'resolveStats' してから描画する (df は 1 回参照)。 +-- +-- ★委譲の内訳: @statLm@ = §3.6 @parseModel "y ~ x"@ + @fitLMF@ で fit + LM @confidenceBand@ で +-- 信頼帯 (設計行列は @designMatrix@、 fitLMF と同一 [1,x] 設計)。 @statSmooth@ = @y ~ bs(x,n)@ の +-- fitLMF (B-spline、 曲線のみ・帯なし)。 stat layer の装飾 (color/stroke/alpha) は展開後の +-- band/line に引き継がれる。 +{-# LANGUAGE OverloadedStrings #-} + +module Graphics.Hgg.Bridge.Stat + ( resolveStats + , saveSVGBoundStats + , renderBoundStats + ) where + +import Data.List (sortOn, zip4) +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified DataFrame.Internal.Column as DX +import qualified DataFrame.Internal.DataFrame as DX + +import Graphics.Hgg.Backend.SVG (renderBound, saveSVGBound) +import Graphics.Hgg.Frame (BoundPlot (..)) +import Graphics.Hgg.Palette (ggplotHue) +import Graphics.Hgg.Spec (ColRef (..), ColorEnc (..), Layer (..), + MarkKind (..), Resolver, ThemeName (..), + VisualSpec (..), alpha, band, + orderedCats, + line, scatter, stroke, resolveNum, resolveTxt, + themeSeriesPalette) +import Graphics.Hgg.Unit (mm, (*~)) +import Data.Maybe (fromMaybe) +import Hanalyze.Model.Core (FitResult, fittedList) +import Hanalyze.Model.Formula.Design (designMatrixF, fitLMF) +import Hanalyze.Model.Formula.Frame (modelFrame) +import Hanalyze.Model.Formula.RFormula (parseModel) +import qualified Hanalyze.Model.LM as LM +import qualified Numeric.LinearAlgebra as LA + +-- =========================================================================== +-- resolveStats: VisualSpec 中の未解決 stat layer を band+line に展開 +-- =========================================================================== + +-- | 'VisualSpec' の各 layer を走査し、 未解決の stat layer (@MStatLM@/@MStatSmooth@) を +-- @Resolver@ でデータ解決 → hanalyze で fit → 具体 layer (band+line / line) に置換する。 +-- それ以外の layer は不変。 解決/fit に失敗した stat layer は黙って除去 (描画を妨げない)。 +resolveStats :: Resolver -> VisualSpec -> VisualSpec +resolveStats r vs = vs { vsLayers = concatMap (expandLayer pal r) (vsLayers vs) } + where pal = statPalette vs + +-- | B2 群色の元になる categorical palette。 ★Layout の catPalRaw と同じ規律で求める +-- (spec.palette 明示 > theme 既定 series)。 これで group 別 stat 線の色が ColorByCol +-- scatter (renderer は lpCategoricalPalette を index 参照) と一致する。 +-- ggplot hue sentinel (["__ggplot_hue__"]) は群数依存ゆえ 'resolveGrouped' で展開する。 +statPalette :: VisualSpec -> [Text] +statPalette vs = + let themeDefaultPal = themeSeriesPalette (fromMaybe ThemeDefault (getLast (vsTheme vs))) + in fromMaybe themeDefaultPal (getLast (vsPalette vs)) + +expandLayer :: [Text] -> Resolver -> Layer -> [Layer] +expandLayer pal r ly = case getFirst (lyKind ly) of + Just MStatLM -> grouped resolveLM + Just MStatSmooth -> grouped resolveSmooth + Just MStatPoly -> grouped resolvePoly + Just MStatResid -> grouped resolveResid + _ -> [ly] + where grouped f = either (const []) id (resolveGrouped pal r ly f) + +-- | 単群 stat resolver の型。 装飾/オプションは 'Layer'、 データは xs/ys で受ける +-- (Resolver からの解決は 'resolveGrouped' が一度だけ行う)。 +type StatFn = Layer -> V.Vector Double -> V.Vector Double -> Either String [Layer] + +-- =========================================================================== +-- B2: group 別 fit (= ggplot geom_smooth(aes(color=g))) +-- =========================================================================== + +-- | stat layer の color encoding が群列 ('ColorByCol') を指すなら、 群ごとに分割 fit し +-- 群色 (ggplotHue) で複数 line/band を重畳する。 群指定が無ければ単群で 1 回 fit (B1/B3 同等)。 +resolveGrouped :: [Text] -> Resolver -> Layer -> StatFn -> Either String [Layer] +resolveGrouped palRaw r ly f = do + xs0 <- colOf r (lyEncX ly) + ys0 <- colOf r (lyEncY ly) + -- ★ NaN (= Maybe 列の Nothing / 欠損) を持つ行を fit から落とす (mark の na.rm と同じ挙動)。 + -- x/y どちらかが NaN の点を除外し、 群列も同じ有効行に整列させる。 + let n0 = min (V.length xs0) (V.length ys0) + valid = V.fromList [ i | i <- [0 .. n0 - 1] + , not (isNaN (xs0 V.! i)), not (isNaN (ys0 V.! i)) ] + xs = V.map (xs0 V.!) valid + ys = V.map (ys0 V.!) valid + case groupColumn r ly of + Nothing -> f ly xs ys -- 単群 (B1/B3) + Just gs0 -> do + let gs = V.map (gs0 V.!) valid -- 群列を有効行に整列 + groups = orderedCats (V.toList gs) -- Phase 28: ggplot factor 既定 = アルファベット順 + -- ★ColorByCol scatter と同色: hue sentinel は群数で展開、 他は spec/theme palette を index 参照 + palette | palRaw == ["__ggplot_hue__"] = ggplotHue (length groups) + | otherwise = palRaw + gv = V.toList gs + perGroup (i, g) = + let idxs = [ j | (j, gg) <- zip [0 ..] gv, gg == g ] + gx = V.fromList [ xs V.! j | j <- idxs ] + gy = V.fromList [ ys V.! j | j <- idxs ] + col = palette !! (i `mod` max 1 (length palette)) + -- 群色で上書き (内部 palette は Text 経路ゆえ ColorStatic 直構築で温存。 + -- Last 後勝ち → band/line/scatter に伝播)。 + ly' = ly <> mempty { lyColor = Last (Just (ColorStatic col)) } + in either (const []) id (f ly' gx gy) + Right (concatMap perGroup (zip [0 ..] groups)) + +-- | lyColor が 'ColorByCol' なら群列を Resolver で文字ベクタに解決 (= 群分割キー)。 +groupColumn :: Resolver -> Layer -> Maybe (V.Vector Text) +groupColumn r ly = case getLast (lyColor ly) of + Just (ColorByCol cr) -> resolveTxt r cr + _ -> Nothing + +-- | 出現順を保つ distinct (= Render.nubKeep 同等。 群の色対応を安定させる)。 +nubKeepOrd :: Eq a => [a] -> [a] +nubKeepOrd = go [] + where go seen [] = reverse seen + go seen (x:xs) + | x `elem` seen = go seen xs + | otherwise = go (x : seen) xs + +-- | geom_smooth / stat_lm の回帰線の既定線幅 (Phase 34 A1: ggplot geom_smooth は +-- @linewidth = 2 × 既定線@ = 0.753mm)。@decoOf ly@ (= user 指定 stroke) が後置で +-- 上書きするので、user が 'stroke' を明示した場合はそちらが優先される。 +smoothLineDefault :: Layer +smoothLineDefault = stroke (0.753 *~ mm) + +-- | 装飾だけを抜き出した Layer (lyKind/encoding は持たない)。 band/line に @<>@ で合成すると +-- color/stroke/alpha/linetype が引き継がれ、 band/line 自身の lyKind は保たれる (First Monoid)。 +decoOf :: Layer -> Layer +decoOf ly = mempty + { lyColor = lyColor ly + , lyStroke = lyStroke ly + , lyAlpha = lyAlpha ly + , lyLinetype = lyLinetype ly + } + +-- | stat layer の encoding 列を Resolver で数値ベクタに解決。 +colOf :: Resolver -> Last ColRef -> Either String (V.Vector Double) +colOf r lc = case getLast lc >>= resolveNum r of + Just v -> Right v + Nothing -> Left "stat layer の x/y 列を数値として解決できません" + +-- | lm: 回帰線 + 95% 信頼帯。 帯は半透明 (alpha 既定 0.2)、 線は装飾引き継ぎ。 +resolveLM :: StatFn +resolveLM ly xs ys = do + (fr, _) <- fitFormula "y ~ x" xs ys + let lvl = fromMaybe 0.95 (getLast (lyStatLevel ly)) -- B1: statLmLevel で可変、 既定 0.95 + dm = LM.designMatrix xs -- [1, x] = fitLMF "y~x" と同一設計 + cib = LM.confidenceBand dm fr lvl + rows = sortOn (\(x, _, _, _) -> x) + (zip4 (V.toList xs) (fittedList fr) + (LM.lowerBound cib) (LM.upperBound cib)) + sx = V.fromList [ x | (x, _, _, _) <- rows ] + syh = V.fromList [ y | (_, y, _, _) <- rows ] + slo = V.fromList [ l | (_, _, l, _) <- rows ] + shi = V.fromList [ h | (_, _, _, h) <- rows ] + bandLy = band (ColNum sx) (ColNum slo) (ColNum shi) + <> mempty { lyColor = lyColor ly } + <> maybe (alpha 0.2) alpha (getLast (lyAlpha ly)) + lineLy = line (ColNum sx) (ColNum syh) <> smoothLineDefault <> decoOf ly + Right [ bandLy -- 帯を先に (背面) + , lineLy ] -- 線を後に (前面) + +-- | smooth: B-spline 平滑。 knot 数は lyBinCount (既定 6)。 +-- B1: 'lyStatLevel' が Just (= 'statSmoothCI') なら bs 設計行列の 'LM.confidenceBand' で +-- 信頼帯 (band) + 曲線 (line)、 Nothing (= 'statSmooth') なら曲線のみ。 +resolveSmooth :: StatFn +resolveSmooth ly xs ys = do + let n = maybe 6 id (getLast (lyBinCount ly)) + formula = "y ~ bs(x," <> T.pack (show n) <> ")" + (fr, _) <- fitFormula formula xs ys + case getLast (lyStatLevel ly) of + Nothing -> do + let rows = sortOn fst (zip (V.toList xs) (fittedList fr)) + sx = V.fromList (map fst rows) + syh = V.fromList (map snd rows) + Right [ line (ColNum sx) (ColNum syh) <> smoothLineDefault <> decoOf ly ] + Just lvl -> do + dm <- designFor formula xs ys -- bs 基底設計行列 (= fitLMF と同一) + let cib = LM.confidenceBand dm fr lvl + rows = sortOn (\(x, _, _, _) -> x) + (zip4 (V.toList xs) (fittedList fr) + (LM.lowerBound cib) (LM.upperBound cib)) + sx = V.fromList [ x | (x, _, _, _) <- rows ] + syh = V.fromList [ y | (_, y, _, _) <- rows ] + slo = V.fromList [ l | (_, _, l, _) <- rows ] + shi = V.fromList [ h | (_, _, _, h) <- rows ] + bandLy = band (ColNum sx) (ColNum slo) (ColNum shi) + <> mempty { lyColor = lyColor ly } + <> maybe (alpha 0.2) alpha (getLast (lyAlpha ly)) + lineLy = line (ColNum sx) (ColNum syh) <> smoothLineDefault <> decoOf ly + Right [ bandLy -- 帯を先に (背面) + , lineLy ] -- 線を後に (前面) + +-- | poly: 多項式回帰 (= ggplot stat_smooth(method="lm", formula=y~poly(x,deg)))。 +-- 次数 deg は lyBinCount (既定 2)。 poly 設計行列の confidenceBand で band+line に展開。 +resolvePoly :: StatFn +resolvePoly ly xs ys = do + let deg = maybe 2 id (getLast (lyBinCount ly)) + lvl = fromMaybe 0.95 (getLast (lyStatLevel ly)) + formula = "y ~ poly(x," <> T.pack (show deg) <> ")" + (fr, _) <- fitFormula formula xs ys + dm <- designFor formula xs ys + let cib = LM.confidenceBand dm fr lvl + rows = sortOn (\(x, _, _, _) -> x) + (zip4 (V.toList xs) (fittedList fr) + (LM.lowerBound cib) (LM.upperBound cib)) + sx = V.fromList [ x | (x, _, _, _) <- rows ] + syh = V.fromList [ y | (_, y, _, _) <- rows ] + slo = V.fromList [ l | (_, _, l, _) <- rows ] + shi = V.fromList [ h | (_, _, _, h) <- rows ] + bandLy = band (ColNum sx) (ColNum slo) (ColNum shi) + <> mempty { lyColor = lyColor ly } + <> maybe (alpha 0.2) alpha (getLast (lyAlpha ly)) + lineLy = line (ColNum sx) (ColNum syh) <> smoothLineDefault <> decoOf ly + Right [ bandLy -- 帯を先に (背面) + , lineLy ] -- 線を後に (前面) + +-- | resid: 残差 vs fitted 診断散布 (= base R plot(lm) #1)。 y~x で fit し、 +-- 各点を (fitted, residual=y-fitted) に写した scatter に展開する (装飾は scatter に引き継ぐ)。 +resolveResid :: StatFn +resolveResid ly xs ys = do + (fr, _) <- fitFormula "y ~ x" xs ys + let fitted = fittedList fr + resid = zipWith (-) (V.toList ys) fitted + fx = V.fromList fitted + ry = V.fromList resid + Right [ scatter (ColNum fx) (ColNum ry) <> decoOf ly ] + +-- | x/y の 2 列 DataFrame を組み、 formula を parse → fitLMF (回帰計算を analyze に委譲)。 +-- 列名は内部固定 ("x"/"y") で、 formula も "x"/"y" を参照する。 +fitFormula :: Text -> V.Vector Double -> V.Vector Double + -> Either String (FitResult, [Text]) +fitFormula formula xs ys = do + f <- parseModel formula + fitLMF f (xyFrame xs ys) + +-- | formula の設計行列 (= confidenceBand 用)。 fitLMF と同じ modelFrame→designMatrixF 経路を +-- 通すので、 bs(x,n) 等の基底展開も fit と完全一致する。 +designFor :: Text -> V.Vector Double -> V.Vector Double + -> Either String (LA.Matrix Double) +designFor formula xs ys = do + f <- parseModel formula + mf <- modelFrame f (xyFrame xs ys) + (dm, _) <- designMatrixF f mf + Right dm + +-- | x/y 2 列の内部 DataFrame。 +xyFrame :: V.Vector Double -> V.Vector Double -> DX.DataFrame +xyFrame xs ys = DX.fromNamedColumns + [ ("x", DX.fromList (V.toList xs)) + , ("y", DX.fromList (V.toList ys)) ] + +-- =========================================================================== +-- BoundPlot 向けの描画ラッパ (df 1 回参照・自動解決) +-- =========================================================================== + +-- | バインド済プロットの spec を、 自分が持つ resolver で 'resolveStats' する。 +resolveBound :: BoundPlot -> BoundPlot +resolveBound bp = bp { bpSpec = resolveStats (bpResolver bp) (bpSpec bp) } + +-- | stat を解決してから SVG 保存 (= ggplot2 の geom_smooth 込み図を 1 回の df 参照で)。 +saveSVGBoundStats :: FilePath -> BoundPlot -> IO () +saveSVGBoundStats path = saveSVGBound path . resolveBound + +-- | stat を解決してから SVG 文字列を返す。 +renderBoundStats :: BoundPlot -> Text +renderBoundStats = renderBound . resolveBound diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,344 @@ +-- | Phase 2 A2 test: ModelGraph → DAGSpec 変換の round-trip 保存。 +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Monoid +import qualified Data.Text + +import qualified Graphics.Hgg.Spec as Spec +import Graphics.Hgg.Palette (ggplotHue) +import Hanalyze.Model.HBM (ModelGraph (..), Node (..), + NodeKind (..)) + +import Graphics.Hgg.Bridge.Analyze + (modelGraphToDAGEdges, + modelGraphToDAGNodes, + modelGraphToDAGPlates, + modelGraphToDAGSpec, + modelGraphToVisualSpec, + renderModelGraphPDF, + renderModelGraphPNG, + renderModelGraphSVG, + renderModelGraphSVGBytes) +import qualified Graphics.Hgg.Bridge.Analyze.Internal as I + +import Graphics.Hgg.Bridge.Stat (resolveStats) +import Graphics.Hgg.Frame ((|>>), bpSpec, bpResolver) +import qualified Data.Vector as V +import qualified DataFrame.Internal.Column as DX +import qualified DataFrame.Internal.DataFrame as DX +import qualified Hanalyze.Model.LM as LM +import Hanalyze.Model.Core (fittedList) +import Data.List (sortOn) +import Data.Monoid (getFirst, getLast) + +import Test.Hspec + +-- =========================================================================== +-- 代表 ModelGraph fixture +-- =========================================================================== + +-- | 単純 LM 風: alpha (latent) + beta (latent) → y (observed, N=100) +simpleLM :: ModelGraph +simpleLM = ModelGraph + { mgNodes = + [ Node "alpha" LatentN "Normal" Set.empty [] + , Node "beta" LatentN "Normal" Set.empty [] + , Node "y" (ObservedN 100) "Normal" Set.empty [] + ] + , mgEdges = [("alpha", "y"), ("beta", "y")] + , mgPlates = Map.empty + } + +-- | 階層 LM 風: mu_g + sigma_g → mu (group plate G=5) → y (record plate R=200) +hierLM :: ModelGraph +hierLM = ModelGraph + { mgNodes = + [ Node "mu_g" LatentN "Normal" Set.empty [] + , Node "sig_g" LatentN "HalfCauchy" Set.empty [] + , Node "mu" LatentN "Normal" Set.empty ["group"] + , Node "y" (ObservedN 200) "Normal" Set.empty ["record"] + ] + , mgEdges = [("mu_g", "mu"), ("sig_g", "mu"), ("mu", "y")] + , mgPlates = Map.fromList [("group", 5), ("record", 200)] + } + +-- | nested plate (= record 内に condition plate がある): +-- mu → mu_c (= condition plate C=3、 record plate 外側) → y (record N=200 + condition) +nestedPlate :: ModelGraph +nestedPlate = ModelGraph + { mgNodes = + [ Node "mu" LatentN "Normal" Set.empty [] + , Node "mu_c" LatentN "Normal" Set.empty ["condition"] + , Node "y" (ObservedN 200) "Normal" Set.empty ["record", "condition"] + ] + , mgEdges = [("mu", "mu_c"), ("mu_c", "y")] + , mgPlates = Map.fromList [("record", 200), ("condition", 3)] + } + +-- =========================================================================== +-- Tests +-- =========================================================================== + +main :: IO () +main = hspec $ do + + describe "Phase 16 系統 B (resolveStats = stat-in 委譲)" $ do + let xs = V.fromList [1,2,3,4,5,6,7,8] :: V.Vector Double + ys = V.fromList [2.1,3.9,6.2,7.8,10.1,12.0,13.8,16.2] :: V.Vector Double + r name + | name == ("x" :: Data.Text.Text) = Just (Spec.NumData xs) + | name == "y" = Just (Spec.NumData ys) + | otherwise = Nothing + -- df 1 回参照: scatter + statLm を <> で重ね resolveStats で展開 + specLM = Spec.layer (Spec.scatter "x" "y") <> Spec.layer (Spec.statLm "x" "y") + specSm = Spec.layer (Spec.scatter "x" "y") <> Spec.layer (Spec.statSmooth "x" "y" 4) + + it "statLm: scatter + 回帰線 + 信頼帯 = 3 layer に展開" $ + length (Spec.vsLayers (resolveStats r specLM)) `shouldBe` 3 + it "statSmooth: scatter + 曲線 = 2 layer (帯なし)" $ + length (Spec.vsLayers (resolveStats r specSm)) `shouldBe` 2 + it "解決できない列の stat は除去 (scatter のみ残る)" $ + let bad = Spec.layer (Spec.scatter "x" "y") <> Spec.layer (Spec.statLm "x" "z") + in length (Spec.vsLayers (resolveStats r bad)) `shouldBe` 1 + it "未解決 stat は resolveStats 後に残らない (全て band/line に展開)" $ + let kinds = [ getFirst (Spec.lyKind l) | l <- Spec.vsLayers (resolveStats r specLM) ] + in (Just Spec.MStatLM `elem` kinds) `shouldBe` False + + it "回帰線の ŷ が analyze fitWithCI (= fitLM 直呼び) と一致 (委譲の証跡)" $ do + let df = DX.fromNamedColumns + [ ("x", DX.fromList (V.toList xs)) + , ("y", DX.fromList (V.toList ys)) ] + Just (frRef, _) = LM.fitWithCI 0.95 df "x" "y" + refSorted = map snd (sortOn fst (zip (V.toList xs) (fittedList frRef))) + resolved = Spec.vsLayers (resolveStats r (Spec.layer (Spec.statLm "x" "y"))) + lineLayer = resolved !! 1 -- [band, line] + Just (Spec.ColNum gotV) = getLast (Spec.lyEncY lineLayer) + and (zipWith (\a b -> abs (a - b) < 1e-9) (V.toList gotV) refSorted) + `shouldBe` True + + it "装飾 (stroke) が展開後の回帰線に引き継がれる" $ do + let styled = Spec.layer (Spec.statLm "x" "y" <> Spec.stroke 3) + resolved = Spec.vsLayers (resolveStats r styled) + lineLayer = resolved !! 1 + getLast (Spec.lyStroke lineLayer) `shouldBe` Just 3 + + it "df 1 回参照 (|>> の bpResolver を resolveStats に渡す)" $ do + let df = Map.fromList [ ("x", Spec.NumData xs), ("y", Spec.NumData ys) ] + :: Map.Map Data.Text.Text Spec.ColData + bound = df |>> (Spec.layer (Spec.scatter "x" "y") <> Spec.layer (Spec.statLm "x" "y")) + spec = resolveStats (bpResolver bound) (bpSpec bound) + length (Spec.vsLayers spec) `shouldBe` 3 + + -- B1: 信頼水準可変 + smooth 帯版 + it "statLmLevel: statLm 同様 3 layer (band+line) に展開" $ + length (Spec.vsLayers (resolveStats r + (Spec.layer (Spec.statLmLevel "x" "y" 0.99)))) `shouldBe` 2 + it "statLmLevel 0.99 の帯は 0.95 より広い (band 半幅で確認)" $ do + let halfWidth lvl = + let resolved = Spec.vsLayers (resolveStats r (Spec.layer lvl)) + bandLy = head resolved -- [band, line] + Just (Spec.ColNum lo) = getLast (Spec.lyEncY bandLy) + Just (Spec.ColNum hi) = getLast (Spec.lyEncY2 bandLy) + in V.sum (V.zipWith (\h l -> h - l) hi lo) + halfWidth (Spec.statLmLevel "x" "y" 0.99) + `shouldSatisfy` (> halfWidth (Spec.statLm "x" "y")) + it "statSmoothCI: scatter なしでも band+line = 2 layer (帯あり)" $ + length (Spec.vsLayers (resolveStats r + (Spec.layer (Spec.statSmoothCI "x" "y" 4)))) `shouldBe` 2 + it "statSmooth (帯なし) は 1 layer・statSmoothCI (帯あり) は 2 layer" $ do + length (Spec.vsLayers (resolveStats r (Spec.layer (Spec.statSmooth "x" "y" 4)))) `shouldBe` 1 + length (Spec.vsLayers (resolveStats r (Spec.layer (Spec.statSmoothCI "x" "y" 4)))) `shouldBe` 2 + + -- B3: statPoly / statResid + it "statPoly: band+line = 2 layer に展開" $ + length (Spec.vsLayers (resolveStats r (Spec.layer (Spec.statPoly "x" "y" 2)))) `shouldBe` 2 + it "statResid: scatter 1 layer (残差 vs fitted)" $ + length (Spec.vsLayers (resolveStats r (Spec.layer (Spec.statResid "x" "y")))) `shouldBe` 1 + it "statResid の y = 残差 (= y - fitted、 委譲先 fitLM と一致)" $ do + let df = DX.fromNamedColumns + [ ("x", DX.fromList (V.toList xs)) + , ("y", DX.fromList (V.toList ys)) ] + Just (frRef, _) = LM.fitWithCI 0.95 df "x" "y" + residRef = zipWith (-) (V.toList ys) (fittedList frRef) + resolved = Spec.vsLayers (resolveStats r (Spec.layer (Spec.statResid "x" "y"))) + Just (Spec.ColNum gotV) = getLast (Spec.lyEncY (head resolved)) + and (zipWith (\a b -> abs (a - b) < 1e-9) (V.toList gotV) residRef) + `shouldBe` True + it "statPoly deg=1 の ŷ は statLm と一致 (poly(x,1) = 線形)" $ do + let polyY = let resolved = Spec.vsLayers (resolveStats r (Spec.layer (Spec.statPoly "x" "y" 1))) + Just (Spec.ColNum v) = getLast (Spec.lyEncY (resolved !! 1)) + in V.toList v + lmY = let resolved = Spec.vsLayers (resolveStats r (Spec.layer (Spec.statLm "x" "y"))) + Just (Spec.ColNum v) = getLast (Spec.lyEncY (resolved !! 1)) + in V.toList v + and (zipWith (\a b -> abs (a - b) < 1e-7) polyY lmY) `shouldBe` True + + describe "Phase 16 B2 (group 別 fit = geom_smooth(aes(color=g)))" $ do + -- 2 群: g="a" (傾き 1) / g="b" (傾き 3)。 g 列は TxtData で解決。 + let n = 6 :: Int + xa = [1 .. fromIntegral n] + xs = V.fromList (xa ++ xa) :: V.Vector Double + ys = V.fromList (map (\x -> 1 * x + 0.5) xa + ++ map (\x -> 3 * x + 0.5) xa) :: V.Vector Double + gs = V.fromList (replicate n "a" ++ replicate n "b") :: V.Vector Data.Text.Text + rg name + | name == ("x" :: Data.Text.Text) = Just (Spec.NumData xs) + | name == "y" = Just (Spec.NumData ys) + | name == "g" = Just (Spec.TxtData gs) + | otherwise = Nothing + + it "色なし statLm は単群 (band+line = 2 layer)" $ + length (Spec.vsLayers (resolveStats rg (Spec.layer (Spec.statLm "x" "y")))) `shouldBe` 2 + it "color g つき statLm は 2 群 (band+line ×2 = 4 layer)" $ + length (Spec.vsLayers (resolveStats rg + (Spec.layer (Spec.statLm "x" "y" <> Spec.colorBy "g")))) `shouldBe` 4 + it "群色 = 既定 theme series palette (= ColorByCol scatter と一致)" $ do + let resolved = Spec.vsLayers (resolveStats rg + (Spec.layer (Spec.statLm "x" "y" <> Spec.colorBy "g"))) + -- line layer は index 1, 3 (各群の [band, line]) + colorOf l = getLast (Spec.lyColor l) + -- ★Phase 28: 既定 series palette (themeSeriesPalette ThemeDefault) は具体色でなく + -- hue sentinel ["__ggplot_hue__"] を返し、 renderer (Layout.catPal) / + -- Bridge.resolveGrouped が群数 n で 'ggplotHue' n に展開する。 ここは 2 群なので + -- 群色は ggplotHue 2 (= ColorByCol scatter と同じ) と一致しなければならない。 + defPal = ggplotHue 2 + colorOf (resolved !! 1) `shouldBe` Just (Spec.ColorStatic (defPal !! 0)) + colorOf (resolved !! 3) `shouldBe` Just (Spec.ColorStatic (defPal !! 1)) + it "群別 fit の傾きが分離 (b 群の ŷ が a 群より急 = 末尾で大)" $ do + let resolved = Spec.vsLayers (resolveStats rg + (Spec.layer (Spec.statLm "x" "y" <> Spec.colorBy "g"))) + lastY l = let Just (Spec.ColNum v) = getLast (Spec.lyEncY l) in V.last v + -- a 群 line (idx1) の末尾 ŷ ≈ 6.5、 b 群 line (idx3) ≈ 18.5 + (lastY (resolved !! 3) > lastY (resolved !! 1)) `shouldBe` True + + describe "Phase 2 A2 mapNodeKind" $ do + it "LatentN → NodeLatent" $ + I.mapNodeKind LatentN `shouldBe` Spec.NodeLatent + it "ObservedN _ → NodeObserved (= 観測数は捨てる、 描画では使わない)" $ do + I.mapNodeKind (ObservedN 1) `shouldBe` Spec.NodeObserved + I.mapNodeKind (ObservedN 200) `shouldBe` Spec.NodeObserved + + describe "Phase 2 A2 plateLabel" $ do + it "name + size を \" (N=)\" に整形" $ + I.plateLabel "group" 5 `shouldBe` "group (N=5)" + it "size 0 / 大きい数も整形できる" $ do + I.plateLabel "" 0 `shouldBe` " (N=0)" + I.plateLabel "x" 9999 `shouldBe` "x (N=9999)" + + describe "Phase 2 A2 modelGraphToDAGNodes" $ do + it "simpleLM: node 数 = 元 mgNodes と一致 (= round-trip)" $ + length (modelGraphToDAGNodes simpleLM) `shouldBe` length (mgNodes simpleLM) + it "simpleLM: node 名・ kind・ dist が正しく mapping" $ do + let ns = modelGraphToDAGNodes simpleLM + byId i = head [n | n <- ns, Spec.dnId n == i] + Spec.dnKind (byId "alpha") `shouldBe` Spec.NodeLatent + Spec.dnKind (byId "y") `shouldBe` Spec.NodeObserved + Spec.dnDist (byId "alpha") `shouldBe` Just "Normal" + Spec.dnLabel (byId "y") `shouldBe` "y" + it "空 distribution は dnDist = Nothing に正規化" $ + let mg = simpleLM { mgNodes = [ Node "n" LatentN "" Set.empty [] ] } + (n:_) = modelGraphToDAGNodes mg + in Spec.dnDist n `shouldBe` Nothing + + describe "Phase 2 A2 modelGraphToDAGEdges" $ do + it "simpleLM: edge 数 = 元 mgEdges と一致" $ + length (modelGraphToDAGEdges simpleLM) `shouldBe` length (mgEdges simpleLM) + it "edge from/to が保存、 dePath は Nothing default" $ do + let es = modelGraphToDAGEdges simpleLM + e = head es + Spec.dePath e `shouldBe` Nothing + (Spec.deFrom e, Spec.deTo e) `shouldBe` ("alpha", "y") + + describe "Phase 2 A2 modelGraphToDAGPlates" $ do + it "plate 無し: 結果も空リスト" $ + modelGraphToDAGPlates simpleLM `shouldBe` [] + + it "hierLM 2 plate: dpLabel に N=、 dpNodeIds に該当 node 名" $ do + let ps = modelGraphToDAGPlates hierLM + length ps `shouldBe` 2 + let labels = map Spec.dpLabel ps + memberss = map Spec.dpNodeIds ps + "group (N=5)" `elem` labels `shouldBe` True + "record (N=200)" `elem` labels `shouldBe` True + -- 各 plate の member が正しい + let groupPlate = head [p | p <- ps, Spec.dpLabel p == "group (N=5)"] + recordPlate = head [p | p <- ps, Spec.dpLabel p == "record (N=200)"] + Spec.dpNodeIds groupPlate `shouldBe` ["mu"] + Spec.dpNodeIds recordPlate `shouldBe` ["y"] + -- 全 plate の memberss 連結が空でない + concat memberss `shouldNotBe` [] + + it "nested plate: 1 node が 2 plate に属するケースを正しく扱う" $ do + let ps = modelGraphToDAGPlates nestedPlate + -- y は record + condition の両方に member + let recordP = head [p | p <- ps, Spec.dpLabel p == "record (N=200)"] + conditionP = head [p | p <- ps, Spec.dpLabel p == "condition (N=3)"] + Spec.dpNodeIds recordP `shouldBe` ["y"] + ("y" `elem` Spec.dpNodeIds conditionP) `shouldBe` True + + describe "Phase 2 A2 modelGraphToDAGSpec round-trip" $ do + it "simpleLM: (nodes, edges, plates) の length が ModelGraph 各要素数と一致" $ do + let (ns, es, ps) = modelGraphToDAGSpec simpleLM + length ns `shouldBe` length (mgNodes simpleLM) + length es `shouldBe` length (mgEdges simpleLM) + length ps `shouldBe` Map.size (mgPlates simpleLM) + it "hierLM: 同上" $ do + let (ns, es, ps) = modelGraphToDAGSpec hierLM + length ns `shouldBe` length (mgNodes hierLM) + length es `shouldBe` length (mgEdges hierLM) + length ps `shouldBe` Map.size (mgPlates hierLM) + it "nestedPlate: 同上 (= 多重所属 node も誤って数えない)" $ do + let (ns, es, ps) = modelGraphToDAGSpec nestedPlate + length ns `shouldBe` length (mgNodes nestedPlate) + length es `shouldBe` length (mgEdges nestedPlate) + length ps `shouldBe` Map.size (mgPlates nestedPlate) + + describe "Phase 2 A3 modelGraphToVisualSpec + renderModelGraphSVG" $ do + it "simpleLM: VisualSpec が空でない layer を含む (= layout 適用された)" $ do + let spec = modelGraphToVisualSpec simpleLM + length (Spec.vsLayers spec) `shouldBe` 1 + + it "hierLM: layout 適用済 (= dnX / dnY が 0 以外に埋まる)" $ do + let spec = modelGraphToVisualSpec hierLM + -- layer の DAGSpec から positioned nodes を取出し + dagLayer = head (Spec.vsLayers spec) + Just ds = Data.Monoid.getLast (Spec.lyDAG dagLayer) + ns = Spec.dsNodes ds + allXs = map Spec.dnX ns + allYs = map Spec.dnY ns + -- LayoutHierarchical 経由なら少なくとも 1 つは ≠ 0 (= layout 計算済) + any (/= 0) allXs `shouldBe` True + any (/= 0) allYs `shouldBe` True + + it "renderModelGraphSVG: ファイル書出し + 内容が SVG header を含む" $ do + let tmpFile = "/tmp/hgg-analyze-bridge-test.svg" + renderModelGraphSVG tmpFile "Test HBM" simpleLM + contents <- readFile tmpFile + take 4 contents `shouldBe` "