diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# Changelog for `hgg-core` + +## 0.1.0.0 — 2026-07-18 + +First public release on Hackage. + +- Backend-independent core: `VisualSpec` / layers / marks / encoding / scales / themes. +- Depends only on base / vector / text / containers. 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +# hgg-core + +The backend-independent core of [`hgg`](https://github.com/frenzieddoll/hgg) — +plot spec / data / layout / render primitives. + +Depends only on `base` / `vector` / `text` / `containers`. Backends +(SVG / PDF / Rasterific / LaTeX / ...) are implemented as separate packages. + +## Module structure + +| Module | Role | +|---|---| +| `Graphics.Hgg.Spec` | `VisualSpec` ADT (declarative spec for every chart kind) | +| `Graphics.Hgg.Data` | `PlotData` ADT (Vector-based, DataFrame-independent) | +| `Graphics.Hgg.Layout` | `computeLayout` pure function (viewport / scale / axis) | +| `Graphics.Hgg.Render` | `Primitive` ADT + `Renderer` class (backend interface) | +| `Graphics.Hgg.Easy` | matplotlib-style `scatter` / `bar` / `line` / `histogram` | + +See the [repository README](https://github.com/frenzieddoll/hgg) for a +gallery and getting-started guide. diff --git a/hgg-core.cabal b/hgg-core.cabal new file mode 100644 --- /dev/null +++ b/hgg-core.cabal @@ -0,0 +1,92 @@ +cabal-version: 3.0 +name: hgg-core +version: 0.1.0.0 +extra-doc-files: CHANGELOG.md +synopsis: Core of hgg: VisualSpec / PlotData / Layout / Render primitives +description: + The core of hgg, a backend-independent plotting library. Provides the + VisualSpec ADT, PlotData (Vector-based columns), pure-function layout + computation, and a Renderer abstraction that emits a list of drawing + Primitives. + . + Dependencies are kept to base / vector / text / containers only; + backends (SVG / PDF / Rasterific / LaTeX / ...) live in separate + packages. +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 +extra-source-files: README.md + +common warnings + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields + -Wredundant-constraints + +library + import: warnings + exposed-modules: Graphics.Hgg.Unit + Graphics.Hgg.Primitive + Graphics.Hgg.Spec + Graphics.Hgg.Spec.Axis + Graphics.Hgg.Spec.Bake + Graphics.Hgg.Spec.Column + Graphics.Hgg.Spec.Concat + Graphics.Hgg.Spec.Constructors + Graphics.Hgg.Spec.Layer + Graphics.Hgg.Spec.CustomMark + Graphics.Hgg.Spec.Decoration + Graphics.Hgg.Spec.Mark + Graphics.Hgg.Spec.Setters + Graphics.Hgg.Spec.Theme + Graphics.Hgg.Spec.Visual + Graphics.Hgg.Validate + Graphics.Hgg.Layout + Graphics.Hgg.Layout.RangeOf + Graphics.Hgg.Layout.Grid + Graphics.Hgg.Math.Griddata + Graphics.Hgg.Math.Special + Graphics.Hgg.Render + Graphics.Hgg.Render.Common + Graphics.Hgg.Render.Basic + Graphics.Hgg.Render.Distribution + Graphics.Hgg.Render.Statistical + Graphics.Hgg.Render.MCMC + Graphics.Hgg.Render.Special + Graphics.Hgg.Render.EdgeRoute + Graphics.Hgg.Render.Layer + Graphics.Hgg.Easy + Graphics.Hgg.DAG + Graphics.Hgg.DAG.Internal.Sugiyama + Graphics.Hgg.Palette + Graphics.Hgg.Color + Graphics.Hgg.Color.Named + hs-source-dirs: src + build-depends: base >= 4.17 && < 5 + , vector >= 0.13 && < 0.14 + , text >= 2.0 && < 2.2 + , containers >= 0.6 && < 0.8 + , aeson >= 2.0 && < 2.3 + , time >= 1.12 && < 1.15 + default-language: Haskell2010 + +test-suite hgg-core-tests + import: warnings + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + build-depends: base + , hgg-core + , vector + , text + , containers + , hspec >= 2.10 && < 2.12 + , aeson + , bytestring + , directory + , filepath + default-language: Haskell2010 diff --git a/src/Graphics/Hgg/Color.hs b/src/Graphics/Hgg/Color.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Color.hs @@ -0,0 +1,99 @@ +-- | +-- Module : Graphics.Hgg.Color +-- Description : 型安全な固定色 (RGB 全色を単一構成子で内包、Phase 30) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- RGB 全色 (256³ = 16,777,216) を単一構成子 @Color@ で連続的に内包し、 +-- 固定色のタイポをコンパイルエラーに落とす。 名前付き 657 色は +-- @Graphics.Hgg.Color.Named@ にトップレベル束縛として隔離する。 +-- +-- ★ワイヤ形式は従来通り Text: @ColorEnc@ の @ColorStatic !Text@ は据置で、 +-- 固定色 combinator が入口で 'toCss' 変換して格納する。 → Render / PS +-- canvas / JSON は無改修 (PS は Color 型を知らず解決済み Text のみ見る)。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Graphics.Hgg.Color + ( Color(..) + , rgb + , fromHex + , fromHexMaybe + , fromHexA + , fromHexAMaybe + , toCss + ) where + +import Data.Char (digitToInt, isHexDigit, toLower) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Word (Word8) +import GHC.Generics (Generic) +import Numeric (showHex) + +-- =========================================================================== +-- 型 +-- =========================================================================== + +-- | 固定色。 単一構成子で RGB 全色を張る (各成分 0–255・Word8 で範囲保証)。 +data Color = Color !Word8 !Word8 !Word8 + deriving (Show, Eq, Ord, Generic) + +-- =========================================================================== +-- 構築 / 変換 +-- =========================================================================== + +-- | RGB 成分から構築 ('Color' と同義の読みやすい別名)。 +rgb :: Word8 -> Word8 -> Word8 -> Color +rgb = Color + +-- | @"#rrggbb"@ / @"#rgb"@ (先頭 @#@ は省略可) を解釈。 不正は 'Nothing'。 +-- 3 桁省略形は各桁を 2 倍展開 (CSS 同様 @#f80@ → @#ff8800@)。 total 版。 +fromHexMaybe :: Text -> Maybe Color +fromHexMaybe raw = + case map toLower (T.unpack (T.dropWhile (== '#') (T.strip raw))) of + [r, g, b] + | all isHexDigit [r, g, b] -> Just (Color (dup r) (dup g) (dup b)) + [r1, r2, g1, g2, b1, b2] + | all isHexDigit [r1, r2, g1, g2, b1, b2] + -> Just (Color (byte r1 r2) (byte g1 g2) (byte b1 b2)) + _ -> Nothing + where + byte hi lo = fromIntegral (digitToInt hi * 16 + digitToInt lo) + dup c = byte c c + +-- | 'fromHexMaybe' の partial 版。 不正入力で 'error' (リテラル用途で簡潔)。 +fromHex :: Text -> Color +fromHex t = fromMaybe err (fromHexMaybe t) + where err = error ("Graphics.Hgg.Color.fromHex: invalid hex color " ++ show t) + +-- | @"#rrggbbaa"@ / @"#rgba"@ (RGBA・先頭 @#@ 省略可) を (色, 不透明度 0–1) に分解。 +-- 不透明度は @aa/255@ (CSS 8 桁 hex / 4 桁省略形)。 alpha を持たない 6/3 桁は +-- alpha = 1.0 で素通し ('fromHexMaybe' に委譲)。 不正は 'Nothing'。 total 版。 +-- ★'Color' は RGB のみゆえ alpha を分離して返す ('colorRGBA' が @color c <> alpha a@ に展開)。 +fromHexAMaybe :: Text -> Maybe (Color, Double) +fromHexAMaybe raw = + case map toLower (T.unpack (T.dropWhile (== '#') (T.strip raw))) of + [r, g, b, a] + | all isHexDigit [r, g, b, a] + -> Just (Color (dup r) (dup g) (dup b), alphaOf (dup a)) + [r1, r2, g1, g2, b1, b2, a1, a2] + | all isHexDigit [r1, r2, g1, g2, b1, b2, a1, a2] + -> Just (Color (byte r1 r2) (byte g1 g2) (byte b1 b2), alphaOf (byte a1 a2)) + _ -> (\c -> (c, 1.0)) <$> fromHexMaybe raw -- 6/3 桁 (alpha 無し) は不透明 + where + byte hi lo = fromIntegral (digitToInt hi * 16 + digitToInt lo) :: Word8 + dup c = byte c c + alphaOf w = fromIntegral w / 255 + +-- | 'fromHexAMaybe' の partial 版。 不正入力で 'error' (リテラル用途で簡潔)。 +fromHexA :: Text -> (Color, Double) +fromHexA t = fromMaybe err (fromHexAMaybe t) + where err = error ("Graphics.Hgg.Color.fromHexA: invalid hex color " ++ show t) + +-- | CSS 文字列 @"#rrggbb"@ に整形 (各成分 2 桁・小文字 hex)。 +toCss :: Color -> Text +toCss (Color r g b) = T.pack ('#' : pad r ++ pad g ++ pad b) + where + pad n = let s = showHex n "" in if length s == 1 then '0' : s else s diff --git a/src/Graphics/Hgg/Color/Named.hs b/src/Graphics/Hgg/Color/Named.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Color/Named.hs @@ -0,0 +1,1989 @@ +-- | +-- Module : Graphics.Hgg.Color.Named +-- Description : R colors() の 657 名前付き色 (機械生成、Phase 30) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- ★このファイルは機械生成物 (scripts/gen-named-colors.py)。 手で編集しない。 +-- 一次ソース = R src/library/grDevices/src/colors.c の ColorDataBase[] +-- (= R colors() の実体・657 色)。 値は捏造せず colors.c の hex から導出。 +-- +-- タイポは文字列ルックアップでなくトップレベル束縛ゆえコンパイルエラーで防げる。 +-- grey/gray の両綴り・連番 (grey0..grey100 等) も R に倣って保持。 +{-# LANGUAGE OverloadedStrings #-} + +module Graphics.Hgg.Color.Named where + +import Graphics.Hgg.Color (Color (..)) + + +white :: Color +white = Color 255 255 255 -- #FFFFFF + +aliceblue :: Color +aliceblue = Color 240 248 255 -- #F0F8FF + +antiquewhite :: Color +antiquewhite = Color 250 235 215 -- #FAEBD7 + +antiquewhite1 :: Color +antiquewhite1 = Color 255 239 219 -- #FFEFDB + +antiquewhite2 :: Color +antiquewhite2 = Color 238 223 204 -- #EEDFCC + +antiquewhite3 :: Color +antiquewhite3 = Color 205 192 176 -- #CDC0B0 + +antiquewhite4 :: Color +antiquewhite4 = Color 139 131 120 -- #8B8378 + +aquamarine :: Color +aquamarine = Color 127 255 212 -- #7FFFD4 + +aquamarine1 :: Color +aquamarine1 = Color 127 255 212 -- #7FFFD4 + +aquamarine2 :: Color +aquamarine2 = Color 118 238 198 -- #76EEC6 + +aquamarine3 :: Color +aquamarine3 = Color 102 205 170 -- #66CDAA + +aquamarine4 :: Color +aquamarine4 = Color 69 139 116 -- #458B74 + +azure :: Color +azure = Color 240 255 255 -- #F0FFFF + +azure1 :: Color +azure1 = Color 240 255 255 -- #F0FFFF + +azure2 :: Color +azure2 = Color 224 238 238 -- #E0EEEE + +azure3 :: Color +azure3 = Color 193 205 205 -- #C1CDCD + +azure4 :: Color +azure4 = Color 131 139 139 -- #838B8B + +beige :: Color +beige = Color 245 245 220 -- #F5F5DC + +bisque :: Color +bisque = Color 255 228 196 -- #FFE4C4 + +bisque1 :: Color +bisque1 = Color 255 228 196 -- #FFE4C4 + +bisque2 :: Color +bisque2 = Color 238 213 183 -- #EED5B7 + +bisque3 :: Color +bisque3 = Color 205 183 158 -- #CDB79E + +bisque4 :: Color +bisque4 = Color 139 125 107 -- #8B7D6B + +black :: Color +black = Color 0 0 0 -- #000000 + +blanchedalmond :: Color +blanchedalmond = Color 255 235 205 -- #FFEBCD + +blue :: Color +blue = Color 0 0 255 -- #0000FF + +blue1 :: Color +blue1 = Color 0 0 255 -- #0000FF + +blue2 :: Color +blue2 = Color 0 0 238 -- #0000EE + +blue3 :: Color +blue3 = Color 0 0 205 -- #0000CD + +blue4 :: Color +blue4 = Color 0 0 139 -- #00008B + +blueviolet :: Color +blueviolet = Color 138 43 226 -- #8A2BE2 + +brown :: Color +brown = Color 165 42 42 -- #A52A2A + +brown1 :: Color +brown1 = Color 255 64 64 -- #FF4040 + +brown2 :: Color +brown2 = Color 238 59 59 -- #EE3B3B + +brown3 :: Color +brown3 = Color 205 51 51 -- #CD3333 + +brown4 :: Color +brown4 = Color 139 35 35 -- #8B2323 + +burlywood :: Color +burlywood = Color 222 184 135 -- #DEB887 + +burlywood1 :: Color +burlywood1 = Color 255 211 155 -- #FFD39B + +burlywood2 :: Color +burlywood2 = Color 238 197 145 -- #EEC591 + +burlywood3 :: Color +burlywood3 = Color 205 170 125 -- #CDAA7D + +burlywood4 :: Color +burlywood4 = Color 139 115 85 -- #8B7355 + +cadetblue :: Color +cadetblue = Color 95 158 160 -- #5F9EA0 + +cadetblue1 :: Color +cadetblue1 = Color 152 245 255 -- #98F5FF + +cadetblue2 :: Color +cadetblue2 = Color 142 229 238 -- #8EE5EE + +cadetblue3 :: Color +cadetblue3 = Color 122 197 205 -- #7AC5CD + +cadetblue4 :: Color +cadetblue4 = Color 83 134 139 -- #53868B + +chartreuse :: Color +chartreuse = Color 127 255 0 -- #7FFF00 + +chartreuse1 :: Color +chartreuse1 = Color 127 255 0 -- #7FFF00 + +chartreuse2 :: Color +chartreuse2 = Color 118 238 0 -- #76EE00 + +chartreuse3 :: Color +chartreuse3 = Color 102 205 0 -- #66CD00 + +chartreuse4 :: Color +chartreuse4 = Color 69 139 0 -- #458B00 + +chocolate :: Color +chocolate = Color 210 105 30 -- #D2691E + +chocolate1 :: Color +chocolate1 = Color 255 127 36 -- #FF7F24 + +chocolate2 :: Color +chocolate2 = Color 238 118 33 -- #EE7621 + +chocolate3 :: Color +chocolate3 = Color 205 102 29 -- #CD661D + +chocolate4 :: Color +chocolate4 = Color 139 69 19 -- #8B4513 + +coral :: Color +coral = Color 255 127 80 -- #FF7F50 + +coral1 :: Color +coral1 = Color 255 114 86 -- #FF7256 + +coral2 :: Color +coral2 = Color 238 106 80 -- #EE6A50 + +coral3 :: Color +coral3 = Color 205 91 69 -- #CD5B45 + +coral4 :: Color +coral4 = Color 139 62 47 -- #8B3E2F + +cornflowerblue :: Color +cornflowerblue = Color 100 149 237 -- #6495ED + +cornsilk :: Color +cornsilk = Color 255 248 220 -- #FFF8DC + +cornsilk1 :: Color +cornsilk1 = Color 255 248 220 -- #FFF8DC + +cornsilk2 :: Color +cornsilk2 = Color 238 232 205 -- #EEE8CD + +cornsilk3 :: Color +cornsilk3 = Color 205 200 177 -- #CDC8B1 + +cornsilk4 :: Color +cornsilk4 = Color 139 136 120 -- #8B8878 + +cyan :: Color +cyan = Color 0 255 255 -- #00FFFF + +cyan1 :: Color +cyan1 = Color 0 255 255 -- #00FFFF + +cyan2 :: Color +cyan2 = Color 0 238 238 -- #00EEEE + +cyan3 :: Color +cyan3 = Color 0 205 205 -- #00CDCD + +cyan4 :: Color +cyan4 = Color 0 139 139 -- #008B8B + +darkblue :: Color +darkblue = Color 0 0 139 -- #00008B + +darkcyan :: Color +darkcyan = Color 0 139 139 -- #008B8B + +darkgoldenrod :: Color +darkgoldenrod = Color 184 134 11 -- #B8860B + +darkgoldenrod1 :: Color +darkgoldenrod1 = Color 255 185 15 -- #FFB90F + +darkgoldenrod2 :: Color +darkgoldenrod2 = Color 238 173 14 -- #EEAD0E + +darkgoldenrod3 :: Color +darkgoldenrod3 = Color 205 149 12 -- #CD950C + +darkgoldenrod4 :: Color +darkgoldenrod4 = Color 139 101 8 -- #8B6508 + +darkgray :: Color +darkgray = Color 169 169 169 -- #A9A9A9 + +darkgreen :: Color +darkgreen = Color 0 100 0 -- #006400 + +darkgrey :: Color +darkgrey = Color 169 169 169 -- #A9A9A9 + +darkkhaki :: Color +darkkhaki = Color 189 183 107 -- #BDB76B + +darkmagenta :: Color +darkmagenta = Color 139 0 139 -- #8B008B + +darkolivegreen :: Color +darkolivegreen = Color 85 107 47 -- #556B2F + +darkolivegreen1 :: Color +darkolivegreen1 = Color 202 255 112 -- #CAFF70 + +darkolivegreen2 :: Color +darkolivegreen2 = Color 188 238 104 -- #BCEE68 + +darkolivegreen3 :: Color +darkolivegreen3 = Color 162 205 90 -- #A2CD5A + +darkolivegreen4 :: Color +darkolivegreen4 = Color 110 139 61 -- #6E8B3D + +darkorange :: Color +darkorange = Color 255 140 0 -- #FF8C00 + +darkorange1 :: Color +darkorange1 = Color 255 127 0 -- #FF7F00 + +darkorange2 :: Color +darkorange2 = Color 238 118 0 -- #EE7600 + +darkorange3 :: Color +darkorange3 = Color 205 102 0 -- #CD6600 + +darkorange4 :: Color +darkorange4 = Color 139 69 0 -- #8B4500 + +darkorchid :: Color +darkorchid = Color 153 50 204 -- #9932CC + +darkorchid1 :: Color +darkorchid1 = Color 191 62 255 -- #BF3EFF + +darkorchid2 :: Color +darkorchid2 = Color 178 58 238 -- #B23AEE + +darkorchid3 :: Color +darkorchid3 = Color 154 50 205 -- #9A32CD + +darkorchid4 :: Color +darkorchid4 = Color 104 34 139 -- #68228B + +darkred :: Color +darkred = Color 139 0 0 -- #8B0000 + +darksalmon :: Color +darksalmon = Color 233 150 122 -- #E9967A + +darkseagreen :: Color +darkseagreen = Color 143 188 143 -- #8FBC8F + +darkseagreen1 :: Color +darkseagreen1 = Color 193 255 193 -- #C1FFC1 + +darkseagreen2 :: Color +darkseagreen2 = Color 180 238 180 -- #B4EEB4 + +darkseagreen3 :: Color +darkseagreen3 = Color 155 205 155 -- #9BCD9B + +darkseagreen4 :: Color +darkseagreen4 = Color 105 139 105 -- #698B69 + +darkslateblue :: Color +darkslateblue = Color 72 61 139 -- #483D8B + +darkslategray :: Color +darkslategray = Color 47 79 79 -- #2F4F4F + +darkslategray1 :: Color +darkslategray1 = Color 151 255 255 -- #97FFFF + +darkslategray2 :: Color +darkslategray2 = Color 141 238 238 -- #8DEEEE + +darkslategray3 :: Color +darkslategray3 = Color 121 205 205 -- #79CDCD + +darkslategray4 :: Color +darkslategray4 = Color 82 139 139 -- #528B8B + +darkslategrey :: Color +darkslategrey = Color 47 79 79 -- #2F4F4F + +darkturquoise :: Color +darkturquoise = Color 0 206 209 -- #00CED1 + +darkviolet :: Color +darkviolet = Color 148 0 211 -- #9400D3 + +deeppink :: Color +deeppink = Color 255 20 147 -- #FF1493 + +deeppink1 :: Color +deeppink1 = Color 255 20 147 -- #FF1493 + +deeppink2 :: Color +deeppink2 = Color 238 18 137 -- #EE1289 + +deeppink3 :: Color +deeppink3 = Color 205 16 118 -- #CD1076 + +deeppink4 :: Color +deeppink4 = Color 139 10 80 -- #8B0A50 + +deepskyblue :: Color +deepskyblue = Color 0 191 255 -- #00BFFF + +deepskyblue1 :: Color +deepskyblue1 = Color 0 191 255 -- #00BFFF + +deepskyblue2 :: Color +deepskyblue2 = Color 0 178 238 -- #00B2EE + +deepskyblue3 :: Color +deepskyblue3 = Color 0 154 205 -- #009ACD + +deepskyblue4 :: Color +deepskyblue4 = Color 0 104 139 -- #00688B + +dimgray :: Color +dimgray = Color 105 105 105 -- #696969 + +dimgrey :: Color +dimgrey = Color 105 105 105 -- #696969 + +dodgerblue :: Color +dodgerblue = Color 30 144 255 -- #1E90FF + +dodgerblue1 :: Color +dodgerblue1 = Color 30 144 255 -- #1E90FF + +dodgerblue2 :: Color +dodgerblue2 = Color 28 134 238 -- #1C86EE + +dodgerblue3 :: Color +dodgerblue3 = Color 24 116 205 -- #1874CD + +dodgerblue4 :: Color +dodgerblue4 = Color 16 78 139 -- #104E8B + +firebrick :: Color +firebrick = Color 178 34 34 -- #B22222 + +firebrick1 :: Color +firebrick1 = Color 255 48 48 -- #FF3030 + +firebrick2 :: Color +firebrick2 = Color 238 44 44 -- #EE2C2C + +firebrick3 :: Color +firebrick3 = Color 205 38 38 -- #CD2626 + +firebrick4 :: Color +firebrick4 = Color 139 26 26 -- #8B1A1A + +floralwhite :: Color +floralwhite = Color 255 250 240 -- #FFFAF0 + +forestgreen :: Color +forestgreen = Color 34 139 34 -- #228B22 + +gainsboro :: Color +gainsboro = Color 220 220 220 -- #DCDCDC + +ghostwhite :: Color +ghostwhite = Color 248 248 255 -- #F8F8FF + +gold :: Color +gold = Color 255 215 0 -- #FFD700 + +gold1 :: Color +gold1 = Color 255 215 0 -- #FFD700 + +gold2 :: Color +gold2 = Color 238 201 0 -- #EEC900 + +gold3 :: Color +gold3 = Color 205 173 0 -- #CDAD00 + +gold4 :: Color +gold4 = Color 139 117 0 -- #8B7500 + +goldenrod :: Color +goldenrod = Color 218 165 32 -- #DAA520 + +goldenrod1 :: Color +goldenrod1 = Color 255 193 37 -- #FFC125 + +goldenrod2 :: Color +goldenrod2 = Color 238 180 34 -- #EEB422 + +goldenrod3 :: Color +goldenrod3 = Color 205 155 29 -- #CD9B1D + +goldenrod4 :: Color +goldenrod4 = Color 139 105 20 -- #8B6914 + +gray :: Color +gray = Color 190 190 190 -- #BEBEBE + +gray0 :: Color +gray0 = Color 0 0 0 -- #000000 + +gray1 :: Color +gray1 = Color 3 3 3 -- #030303 + +gray2 :: Color +gray2 = Color 5 5 5 -- #050505 + +gray3 :: Color +gray3 = Color 8 8 8 -- #080808 + +gray4 :: Color +gray4 = Color 10 10 10 -- #0A0A0A + +gray5 :: Color +gray5 = Color 13 13 13 -- #0D0D0D + +gray6 :: Color +gray6 = Color 15 15 15 -- #0F0F0F + +gray7 :: Color +gray7 = Color 18 18 18 -- #121212 + +gray8 :: Color +gray8 = Color 20 20 20 -- #141414 + +gray9 :: Color +gray9 = Color 23 23 23 -- #171717 + +gray10 :: Color +gray10 = Color 26 26 26 -- #1A1A1A + +gray11 :: Color +gray11 = Color 28 28 28 -- #1C1C1C + +gray12 :: Color +gray12 = Color 31 31 31 -- #1F1F1F + +gray13 :: Color +gray13 = Color 33 33 33 -- #212121 + +gray14 :: Color +gray14 = Color 36 36 36 -- #242424 + +gray15 :: Color +gray15 = Color 38 38 38 -- #262626 + +gray16 :: Color +gray16 = Color 41 41 41 -- #292929 + +gray17 :: Color +gray17 = Color 43 43 43 -- #2B2B2B + +gray18 :: Color +gray18 = Color 46 46 46 -- #2E2E2E + +gray19 :: Color +gray19 = Color 48 48 48 -- #303030 + +gray20 :: Color +gray20 = Color 51 51 51 -- #333333 + +gray21 :: Color +gray21 = Color 54 54 54 -- #363636 + +gray22 :: Color +gray22 = Color 56 56 56 -- #383838 + +gray23 :: Color +gray23 = Color 59 59 59 -- #3B3B3B + +gray24 :: Color +gray24 = Color 61 61 61 -- #3D3D3D + +gray25 :: Color +gray25 = Color 64 64 64 -- #404040 + +gray26 :: Color +gray26 = Color 66 66 66 -- #424242 + +gray27 :: Color +gray27 = Color 69 69 69 -- #454545 + +gray28 :: Color +gray28 = Color 71 71 71 -- #474747 + +gray29 :: Color +gray29 = Color 74 74 74 -- #4A4A4A + +gray30 :: Color +gray30 = Color 77 77 77 -- #4D4D4D + +gray31 :: Color +gray31 = Color 79 79 79 -- #4F4F4F + +gray32 :: Color +gray32 = Color 82 82 82 -- #525252 + +gray33 :: Color +gray33 = Color 84 84 84 -- #545454 + +gray34 :: Color +gray34 = Color 87 87 87 -- #575757 + +gray35 :: Color +gray35 = Color 89 89 89 -- #595959 + +gray36 :: Color +gray36 = Color 92 92 92 -- #5C5C5C + +gray37 :: Color +gray37 = Color 94 94 94 -- #5E5E5E + +gray38 :: Color +gray38 = Color 97 97 97 -- #616161 + +gray39 :: Color +gray39 = Color 99 99 99 -- #636363 + +gray40 :: Color +gray40 = Color 102 102 102 -- #666666 + +gray41 :: Color +gray41 = Color 105 105 105 -- #696969 + +gray42 :: Color +gray42 = Color 107 107 107 -- #6B6B6B + +gray43 :: Color +gray43 = Color 110 110 110 -- #6E6E6E + +gray44 :: Color +gray44 = Color 112 112 112 -- #707070 + +gray45 :: Color +gray45 = Color 115 115 115 -- #737373 + +gray46 :: Color +gray46 = Color 117 117 117 -- #757575 + +gray47 :: Color +gray47 = Color 120 120 120 -- #787878 + +gray48 :: Color +gray48 = Color 122 122 122 -- #7A7A7A + +gray49 :: Color +gray49 = Color 125 125 125 -- #7D7D7D + +gray50 :: Color +gray50 = Color 127 127 127 -- #7F7F7F + +gray51 :: Color +gray51 = Color 130 130 130 -- #828282 + +gray52 :: Color +gray52 = Color 133 133 133 -- #858585 + +gray53 :: Color +gray53 = Color 135 135 135 -- #878787 + +gray54 :: Color +gray54 = Color 138 138 138 -- #8A8A8A + +gray55 :: Color +gray55 = Color 140 140 140 -- #8C8C8C + +gray56 :: Color +gray56 = Color 143 143 143 -- #8F8F8F + +gray57 :: Color +gray57 = Color 145 145 145 -- #919191 + +gray58 :: Color +gray58 = Color 148 148 148 -- #949494 + +gray59 :: Color +gray59 = Color 150 150 150 -- #969696 + +gray60 :: Color +gray60 = Color 153 153 153 -- #999999 + +gray61 :: Color +gray61 = Color 156 156 156 -- #9C9C9C + +gray62 :: Color +gray62 = Color 158 158 158 -- #9E9E9E + +gray63 :: Color +gray63 = Color 161 161 161 -- #A1A1A1 + +gray64 :: Color +gray64 = Color 163 163 163 -- #A3A3A3 + +gray65 :: Color +gray65 = Color 166 166 166 -- #A6A6A6 + +gray66 :: Color +gray66 = Color 168 168 168 -- #A8A8A8 + +gray67 :: Color +gray67 = Color 171 171 171 -- #ABABAB + +gray68 :: Color +gray68 = Color 173 173 173 -- #ADADAD + +gray69 :: Color +gray69 = Color 176 176 176 -- #B0B0B0 + +gray70 :: Color +gray70 = Color 179 179 179 -- #B3B3B3 + +gray71 :: Color +gray71 = Color 181 181 181 -- #B5B5B5 + +gray72 :: Color +gray72 = Color 184 184 184 -- #B8B8B8 + +gray73 :: Color +gray73 = Color 186 186 186 -- #BABABA + +gray74 :: Color +gray74 = Color 189 189 189 -- #BDBDBD + +gray75 :: Color +gray75 = Color 191 191 191 -- #BFBFBF + +gray76 :: Color +gray76 = Color 194 194 194 -- #C2C2C2 + +gray77 :: Color +gray77 = Color 196 196 196 -- #C4C4C4 + +gray78 :: Color +gray78 = Color 199 199 199 -- #C7C7C7 + +gray79 :: Color +gray79 = Color 201 201 201 -- #C9C9C9 + +gray80 :: Color +gray80 = Color 204 204 204 -- #CCCCCC + +gray81 :: Color +gray81 = Color 207 207 207 -- #CFCFCF + +gray82 :: Color +gray82 = Color 209 209 209 -- #D1D1D1 + +gray83 :: Color +gray83 = Color 212 212 212 -- #D4D4D4 + +gray84 :: Color +gray84 = Color 214 214 214 -- #D6D6D6 + +gray85 :: Color +gray85 = Color 217 217 217 -- #D9D9D9 + +gray86 :: Color +gray86 = Color 219 219 219 -- #DBDBDB + +gray87 :: Color +gray87 = Color 222 222 222 -- #DEDEDE + +gray88 :: Color +gray88 = Color 224 224 224 -- #E0E0E0 + +gray89 :: Color +gray89 = Color 227 227 227 -- #E3E3E3 + +gray90 :: Color +gray90 = Color 229 229 229 -- #E5E5E5 + +gray91 :: Color +gray91 = Color 232 232 232 -- #E8E8E8 + +gray92 :: Color +gray92 = Color 235 235 235 -- #EBEBEB + +gray93 :: Color +gray93 = Color 237 237 237 -- #EDEDED + +gray94 :: Color +gray94 = Color 240 240 240 -- #F0F0F0 + +gray95 :: Color +gray95 = Color 242 242 242 -- #F2F2F2 + +gray96 :: Color +gray96 = Color 245 245 245 -- #F5F5F5 + +gray97 :: Color +gray97 = Color 247 247 247 -- #F7F7F7 + +gray98 :: Color +gray98 = Color 250 250 250 -- #FAFAFA + +gray99 :: Color +gray99 = Color 252 252 252 -- #FCFCFC + +gray100 :: Color +gray100 = Color 255 255 255 -- #FFFFFF + +green :: Color +green = Color 0 255 0 -- #00FF00 + +green1 :: Color +green1 = Color 0 255 0 -- #00FF00 + +green2 :: Color +green2 = Color 0 238 0 -- #00EE00 + +green3 :: Color +green3 = Color 0 205 0 -- #00CD00 + +green4 :: Color +green4 = Color 0 139 0 -- #008B00 + +greenyellow :: Color +greenyellow = Color 173 255 47 -- #ADFF2F + +grey :: Color +grey = Color 190 190 190 -- #BEBEBE + +grey0 :: Color +grey0 = Color 0 0 0 -- #000000 + +grey1 :: Color +grey1 = Color 3 3 3 -- #030303 + +grey2 :: Color +grey2 = Color 5 5 5 -- #050505 + +grey3 :: Color +grey3 = Color 8 8 8 -- #080808 + +grey4 :: Color +grey4 = Color 10 10 10 -- #0A0A0A + +grey5 :: Color +grey5 = Color 13 13 13 -- #0D0D0D + +grey6 :: Color +grey6 = Color 15 15 15 -- #0F0F0F + +grey7 :: Color +grey7 = Color 18 18 18 -- #121212 + +grey8 :: Color +grey8 = Color 20 20 20 -- #141414 + +grey9 :: Color +grey9 = Color 23 23 23 -- #171717 + +grey10 :: Color +grey10 = Color 26 26 26 -- #1A1A1A + +grey11 :: Color +grey11 = Color 28 28 28 -- #1C1C1C + +grey12 :: Color +grey12 = Color 31 31 31 -- #1F1F1F + +grey13 :: Color +grey13 = Color 33 33 33 -- #212121 + +grey14 :: Color +grey14 = Color 36 36 36 -- #242424 + +grey15 :: Color +grey15 = Color 38 38 38 -- #262626 + +grey16 :: Color +grey16 = Color 41 41 41 -- #292929 + +grey17 :: Color +grey17 = Color 43 43 43 -- #2B2B2B + +grey18 :: Color +grey18 = Color 46 46 46 -- #2E2E2E + +grey19 :: Color +grey19 = Color 48 48 48 -- #303030 + +grey20 :: Color +grey20 = Color 51 51 51 -- #333333 + +grey21 :: Color +grey21 = Color 54 54 54 -- #363636 + +grey22 :: Color +grey22 = Color 56 56 56 -- #383838 + +grey23 :: Color +grey23 = Color 59 59 59 -- #3B3B3B + +grey24 :: Color +grey24 = Color 61 61 61 -- #3D3D3D + +grey25 :: Color +grey25 = Color 64 64 64 -- #404040 + +grey26 :: Color +grey26 = Color 66 66 66 -- #424242 + +grey27 :: Color +grey27 = Color 69 69 69 -- #454545 + +grey28 :: Color +grey28 = Color 71 71 71 -- #474747 + +grey29 :: Color +grey29 = Color 74 74 74 -- #4A4A4A + +grey30 :: Color +grey30 = Color 77 77 77 -- #4D4D4D + +grey31 :: Color +grey31 = Color 79 79 79 -- #4F4F4F + +grey32 :: Color +grey32 = Color 82 82 82 -- #525252 + +grey33 :: Color +grey33 = Color 84 84 84 -- #545454 + +grey34 :: Color +grey34 = Color 87 87 87 -- #575757 + +grey35 :: Color +grey35 = Color 89 89 89 -- #595959 + +grey36 :: Color +grey36 = Color 92 92 92 -- #5C5C5C + +grey37 :: Color +grey37 = Color 94 94 94 -- #5E5E5E + +grey38 :: Color +grey38 = Color 97 97 97 -- #616161 + +grey39 :: Color +grey39 = Color 99 99 99 -- #636363 + +grey40 :: Color +grey40 = Color 102 102 102 -- #666666 + +grey41 :: Color +grey41 = Color 105 105 105 -- #696969 + +grey42 :: Color +grey42 = Color 107 107 107 -- #6B6B6B + +grey43 :: Color +grey43 = Color 110 110 110 -- #6E6E6E + +grey44 :: Color +grey44 = Color 112 112 112 -- #707070 + +grey45 :: Color +grey45 = Color 115 115 115 -- #737373 + +grey46 :: Color +grey46 = Color 117 117 117 -- #757575 + +grey47 :: Color +grey47 = Color 120 120 120 -- #787878 + +grey48 :: Color +grey48 = Color 122 122 122 -- #7A7A7A + +grey49 :: Color +grey49 = Color 125 125 125 -- #7D7D7D + +grey50 :: Color +grey50 = Color 127 127 127 -- #7F7F7F + +grey51 :: Color +grey51 = Color 130 130 130 -- #828282 + +grey52 :: Color +grey52 = Color 133 133 133 -- #858585 + +grey53 :: Color +grey53 = Color 135 135 135 -- #878787 + +grey54 :: Color +grey54 = Color 138 138 138 -- #8A8A8A + +grey55 :: Color +grey55 = Color 140 140 140 -- #8C8C8C + +grey56 :: Color +grey56 = Color 143 143 143 -- #8F8F8F + +grey57 :: Color +grey57 = Color 145 145 145 -- #919191 + +grey58 :: Color +grey58 = Color 148 148 148 -- #949494 + +grey59 :: Color +grey59 = Color 150 150 150 -- #969696 + +grey60 :: Color +grey60 = Color 153 153 153 -- #999999 + +grey61 :: Color +grey61 = Color 156 156 156 -- #9C9C9C + +grey62 :: Color +grey62 = Color 158 158 158 -- #9E9E9E + +grey63 :: Color +grey63 = Color 161 161 161 -- #A1A1A1 + +grey64 :: Color +grey64 = Color 163 163 163 -- #A3A3A3 + +grey65 :: Color +grey65 = Color 166 166 166 -- #A6A6A6 + +grey66 :: Color +grey66 = Color 168 168 168 -- #A8A8A8 + +grey67 :: Color +grey67 = Color 171 171 171 -- #ABABAB + +grey68 :: Color +grey68 = Color 173 173 173 -- #ADADAD + +grey69 :: Color +grey69 = Color 176 176 176 -- #B0B0B0 + +grey70 :: Color +grey70 = Color 179 179 179 -- #B3B3B3 + +grey71 :: Color +grey71 = Color 181 181 181 -- #B5B5B5 + +grey72 :: Color +grey72 = Color 184 184 184 -- #B8B8B8 + +grey73 :: Color +grey73 = Color 186 186 186 -- #BABABA + +grey74 :: Color +grey74 = Color 189 189 189 -- #BDBDBD + +grey75 :: Color +grey75 = Color 191 191 191 -- #BFBFBF + +grey76 :: Color +grey76 = Color 194 194 194 -- #C2C2C2 + +grey77 :: Color +grey77 = Color 196 196 196 -- #C4C4C4 + +grey78 :: Color +grey78 = Color 199 199 199 -- #C7C7C7 + +grey79 :: Color +grey79 = Color 201 201 201 -- #C9C9C9 + +grey80 :: Color +grey80 = Color 204 204 204 -- #CCCCCC + +grey81 :: Color +grey81 = Color 207 207 207 -- #CFCFCF + +grey82 :: Color +grey82 = Color 209 209 209 -- #D1D1D1 + +grey83 :: Color +grey83 = Color 212 212 212 -- #D4D4D4 + +grey84 :: Color +grey84 = Color 214 214 214 -- #D6D6D6 + +grey85 :: Color +grey85 = Color 217 217 217 -- #D9D9D9 + +grey86 :: Color +grey86 = Color 219 219 219 -- #DBDBDB + +grey87 :: Color +grey87 = Color 222 222 222 -- #DEDEDE + +grey88 :: Color +grey88 = Color 224 224 224 -- #E0E0E0 + +grey89 :: Color +grey89 = Color 227 227 227 -- #E3E3E3 + +grey90 :: Color +grey90 = Color 229 229 229 -- #E5E5E5 + +grey91 :: Color +grey91 = Color 232 232 232 -- #E8E8E8 + +grey92 :: Color +grey92 = Color 235 235 235 -- #EBEBEB + +grey93 :: Color +grey93 = Color 237 237 237 -- #EDEDED + +grey94 :: Color +grey94 = Color 240 240 240 -- #F0F0F0 + +grey95 :: Color +grey95 = Color 242 242 242 -- #F2F2F2 + +grey96 :: Color +grey96 = Color 245 245 245 -- #F5F5F5 + +grey97 :: Color +grey97 = Color 247 247 247 -- #F7F7F7 + +grey98 :: Color +grey98 = Color 250 250 250 -- #FAFAFA + +grey99 :: Color +grey99 = Color 252 252 252 -- #FCFCFC + +grey100 :: Color +grey100 = Color 255 255 255 -- #FFFFFF + +honeydew :: Color +honeydew = Color 240 255 240 -- #F0FFF0 + +honeydew1 :: Color +honeydew1 = Color 240 255 240 -- #F0FFF0 + +honeydew2 :: Color +honeydew2 = Color 224 238 224 -- #E0EEE0 + +honeydew3 :: Color +honeydew3 = Color 193 205 193 -- #C1CDC1 + +honeydew4 :: Color +honeydew4 = Color 131 139 131 -- #838B83 + +hotpink :: Color +hotpink = Color 255 105 180 -- #FF69B4 + +hotpink1 :: Color +hotpink1 = Color 255 110 180 -- #FF6EB4 + +hotpink2 :: Color +hotpink2 = Color 238 106 167 -- #EE6AA7 + +hotpink3 :: Color +hotpink3 = Color 205 96 144 -- #CD6090 + +hotpink4 :: Color +hotpink4 = Color 139 58 98 -- #8B3A62 + +indianred :: Color +indianred = Color 205 92 92 -- #CD5C5C + +indianred1 :: Color +indianred1 = Color 255 106 106 -- #FF6A6A + +indianred2 :: Color +indianred2 = Color 238 99 99 -- #EE6363 + +indianred3 :: Color +indianred3 = Color 205 85 85 -- #CD5555 + +indianred4 :: Color +indianred4 = Color 139 58 58 -- #8B3A3A + +ivory :: Color +ivory = Color 255 255 240 -- #FFFFF0 + +ivory1 :: Color +ivory1 = Color 255 255 240 -- #FFFFF0 + +ivory2 :: Color +ivory2 = Color 238 238 224 -- #EEEEE0 + +ivory3 :: Color +ivory3 = Color 205 205 193 -- #CDCDC1 + +ivory4 :: Color +ivory4 = Color 139 139 131 -- #8B8B83 + +khaki :: Color +khaki = Color 240 230 140 -- #F0E68C + +khaki1 :: Color +khaki1 = Color 255 246 143 -- #FFF68F + +khaki2 :: Color +khaki2 = Color 238 230 133 -- #EEE685 + +khaki3 :: Color +khaki3 = Color 205 198 115 -- #CDC673 + +khaki4 :: Color +khaki4 = Color 139 134 78 -- #8B864E + +lavender :: Color +lavender = Color 230 230 250 -- #E6E6FA + +lavenderblush :: Color +lavenderblush = Color 255 240 245 -- #FFF0F5 + +lavenderblush1 :: Color +lavenderblush1 = Color 255 240 245 -- #FFF0F5 + +lavenderblush2 :: Color +lavenderblush2 = Color 238 224 229 -- #EEE0E5 + +lavenderblush3 :: Color +lavenderblush3 = Color 205 193 197 -- #CDC1C5 + +lavenderblush4 :: Color +lavenderblush4 = Color 139 131 134 -- #8B8386 + +lawngreen :: Color +lawngreen = Color 124 252 0 -- #7CFC00 + +lemonchiffon :: Color +lemonchiffon = Color 255 250 205 -- #FFFACD + +lemonchiffon1 :: Color +lemonchiffon1 = Color 255 250 205 -- #FFFACD + +lemonchiffon2 :: Color +lemonchiffon2 = Color 238 233 191 -- #EEE9BF + +lemonchiffon3 :: Color +lemonchiffon3 = Color 205 201 165 -- #CDC9A5 + +lemonchiffon4 :: Color +lemonchiffon4 = Color 139 137 112 -- #8B8970 + +lightblue :: Color +lightblue = Color 173 216 230 -- #ADD8E6 + +lightblue1 :: Color +lightblue1 = Color 191 239 255 -- #BFEFFF + +lightblue2 :: Color +lightblue2 = Color 178 223 238 -- #B2DFEE + +lightblue3 :: Color +lightblue3 = Color 154 192 205 -- #9AC0CD + +lightblue4 :: Color +lightblue4 = Color 104 131 139 -- #68838B + +lightcoral :: Color +lightcoral = Color 240 128 128 -- #F08080 + +lightcyan :: Color +lightcyan = Color 224 255 255 -- #E0FFFF + +lightcyan1 :: Color +lightcyan1 = Color 224 255 255 -- #E0FFFF + +lightcyan2 :: Color +lightcyan2 = Color 209 238 238 -- #D1EEEE + +lightcyan3 :: Color +lightcyan3 = Color 180 205 205 -- #B4CDCD + +lightcyan4 :: Color +lightcyan4 = Color 122 139 139 -- #7A8B8B + +lightgoldenrod :: Color +lightgoldenrod = Color 238 221 130 -- #EEDD82 + +lightgoldenrod1 :: Color +lightgoldenrod1 = Color 255 236 139 -- #FFEC8B + +lightgoldenrod2 :: Color +lightgoldenrod2 = Color 238 220 130 -- #EEDC82 + +lightgoldenrod3 :: Color +lightgoldenrod3 = Color 205 190 112 -- #CDBE70 + +lightgoldenrod4 :: Color +lightgoldenrod4 = Color 139 129 76 -- #8B814C + +lightgoldenrodyellow :: Color +lightgoldenrodyellow = Color 250 250 210 -- #FAFAD2 + +lightgray :: Color +lightgray = Color 211 211 211 -- #D3D3D3 + +lightgreen :: Color +lightgreen = Color 144 238 144 -- #90EE90 + +lightgrey :: Color +lightgrey = Color 211 211 211 -- #D3D3D3 + +lightpink :: Color +lightpink = Color 255 182 193 -- #FFB6C1 + +lightpink1 :: Color +lightpink1 = Color 255 174 185 -- #FFAEB9 + +lightpink2 :: Color +lightpink2 = Color 238 162 173 -- #EEA2AD + +lightpink3 :: Color +lightpink3 = Color 205 140 149 -- #CD8C95 + +lightpink4 :: Color +lightpink4 = Color 139 95 101 -- #8B5F65 + +lightsalmon :: Color +lightsalmon = Color 255 160 122 -- #FFA07A + +lightsalmon1 :: Color +lightsalmon1 = Color 255 160 122 -- #FFA07A + +lightsalmon2 :: Color +lightsalmon2 = Color 238 149 114 -- #EE9572 + +lightsalmon3 :: Color +lightsalmon3 = Color 205 129 98 -- #CD8162 + +lightsalmon4 :: Color +lightsalmon4 = Color 139 87 66 -- #8B5742 + +lightseagreen :: Color +lightseagreen = Color 32 178 170 -- #20B2AA + +lightskyblue :: Color +lightskyblue = Color 135 206 250 -- #87CEFA + +lightskyblue1 :: Color +lightskyblue1 = Color 176 226 255 -- #B0E2FF + +lightskyblue2 :: Color +lightskyblue2 = Color 164 211 238 -- #A4D3EE + +lightskyblue3 :: Color +lightskyblue3 = Color 141 182 205 -- #8DB6CD + +lightskyblue4 :: Color +lightskyblue4 = Color 96 123 139 -- #607B8B + +lightslateblue :: Color +lightslateblue = Color 132 112 255 -- #8470FF + +lightslategray :: Color +lightslategray = Color 119 136 153 -- #778899 + +lightslategrey :: Color +lightslategrey = Color 119 136 153 -- #778899 + +lightsteelblue :: Color +lightsteelblue = Color 176 196 222 -- #B0C4DE + +lightsteelblue1 :: Color +lightsteelblue1 = Color 202 225 255 -- #CAE1FF + +lightsteelblue2 :: Color +lightsteelblue2 = Color 188 210 238 -- #BCD2EE + +lightsteelblue3 :: Color +lightsteelblue3 = Color 162 181 205 -- #A2B5CD + +lightsteelblue4 :: Color +lightsteelblue4 = Color 110 123 139 -- #6E7B8B + +lightyellow :: Color +lightyellow = Color 255 255 224 -- #FFFFE0 + +lightyellow1 :: Color +lightyellow1 = Color 255 255 224 -- #FFFFE0 + +lightyellow2 :: Color +lightyellow2 = Color 238 238 209 -- #EEEED1 + +lightyellow3 :: Color +lightyellow3 = Color 205 205 180 -- #CDCDB4 + +lightyellow4 :: Color +lightyellow4 = Color 139 139 122 -- #8B8B7A + +limegreen :: Color +limegreen = Color 50 205 50 -- #32CD32 + +linen :: Color +linen = Color 250 240 230 -- #FAF0E6 + +magenta :: Color +magenta = Color 255 0 255 -- #FF00FF + +magenta1 :: Color +magenta1 = Color 255 0 255 -- #FF00FF + +magenta2 :: Color +magenta2 = Color 238 0 238 -- #EE00EE + +magenta3 :: Color +magenta3 = Color 205 0 205 -- #CD00CD + +magenta4 :: Color +magenta4 = Color 139 0 139 -- #8B008B + +maroon :: Color +maroon = Color 176 48 96 -- #B03060 + +maroon1 :: Color +maroon1 = Color 255 52 179 -- #FF34B3 + +maroon2 :: Color +maroon2 = Color 238 48 167 -- #EE30A7 + +maroon3 :: Color +maroon3 = Color 205 41 144 -- #CD2990 + +maroon4 :: Color +maroon4 = Color 139 28 98 -- #8B1C62 + +mediumaquamarine :: Color +mediumaquamarine = Color 102 205 170 -- #66CDAA + +mediumblue :: Color +mediumblue = Color 0 0 205 -- #0000CD + +mediumorchid :: Color +mediumorchid = Color 186 85 211 -- #BA55D3 + +mediumorchid1 :: Color +mediumorchid1 = Color 224 102 255 -- #E066FF + +mediumorchid2 :: Color +mediumorchid2 = Color 209 95 238 -- #D15FEE + +mediumorchid3 :: Color +mediumorchid3 = Color 180 82 205 -- #B452CD + +mediumorchid4 :: Color +mediumorchid4 = Color 122 55 139 -- #7A378B + +mediumpurple :: Color +mediumpurple = Color 147 112 219 -- #9370DB + +mediumpurple1 :: Color +mediumpurple1 = Color 171 130 255 -- #AB82FF + +mediumpurple2 :: Color +mediumpurple2 = Color 159 121 238 -- #9F79EE + +mediumpurple3 :: Color +mediumpurple3 = Color 137 104 205 -- #8968CD + +mediumpurple4 :: Color +mediumpurple4 = Color 93 71 139 -- #5D478B + +mediumseagreen :: Color +mediumseagreen = Color 60 179 113 -- #3CB371 + +mediumslateblue :: Color +mediumslateblue = Color 123 104 238 -- #7B68EE + +mediumspringgreen :: Color +mediumspringgreen = Color 0 250 154 -- #00FA9A + +mediumturquoise :: Color +mediumturquoise = Color 72 209 204 -- #48D1CC + +mediumvioletred :: Color +mediumvioletred = Color 199 21 133 -- #C71585 + +midnightblue :: Color +midnightblue = Color 25 25 112 -- #191970 + +mintcream :: Color +mintcream = Color 245 255 250 -- #F5FFFA + +mistyrose :: Color +mistyrose = Color 255 228 225 -- #FFE4E1 + +mistyrose1 :: Color +mistyrose1 = Color 255 228 225 -- #FFE4E1 + +mistyrose2 :: Color +mistyrose2 = Color 238 213 210 -- #EED5D2 + +mistyrose3 :: Color +mistyrose3 = Color 205 183 181 -- #CDB7B5 + +mistyrose4 :: Color +mistyrose4 = Color 139 125 123 -- #8B7D7B + +moccasin :: Color +moccasin = Color 255 228 181 -- #FFE4B5 + +navajowhite :: Color +navajowhite = Color 255 222 173 -- #FFDEAD + +navajowhite1 :: Color +navajowhite1 = Color 255 222 173 -- #FFDEAD + +navajowhite2 :: Color +navajowhite2 = Color 238 207 161 -- #EECFA1 + +navajowhite3 :: Color +navajowhite3 = Color 205 179 139 -- #CDB38B + +navajowhite4 :: Color +navajowhite4 = Color 139 121 94 -- #8B795E + +navy :: Color +navy = Color 0 0 128 -- #000080 + +navyblue :: Color +navyblue = Color 0 0 128 -- #000080 + +oldlace :: Color +oldlace = Color 253 245 230 -- #FDF5E6 + +olivedrab :: Color +olivedrab = Color 107 142 35 -- #6B8E23 + +olivedrab1 :: Color +olivedrab1 = Color 192 255 62 -- #C0FF3E + +olivedrab2 :: Color +olivedrab2 = Color 179 238 58 -- #B3EE3A + +olivedrab3 :: Color +olivedrab3 = Color 154 205 50 -- #9ACD32 + +olivedrab4 :: Color +olivedrab4 = Color 105 139 34 -- #698B22 + +orange :: Color +orange = Color 255 165 0 -- #FFA500 + +orange1 :: Color +orange1 = Color 255 165 0 -- #FFA500 + +orange2 :: Color +orange2 = Color 238 154 0 -- #EE9A00 + +orange3 :: Color +orange3 = Color 205 133 0 -- #CD8500 + +orange4 :: Color +orange4 = Color 139 90 0 -- #8B5A00 + +orangered :: Color +orangered = Color 255 69 0 -- #FF4500 + +orangered1 :: Color +orangered1 = Color 255 69 0 -- #FF4500 + +orangered2 :: Color +orangered2 = Color 238 64 0 -- #EE4000 + +orangered3 :: Color +orangered3 = Color 205 55 0 -- #CD3700 + +orangered4 :: Color +orangered4 = Color 139 37 0 -- #8B2500 + +orchid :: Color +orchid = Color 218 112 214 -- #DA70D6 + +orchid1 :: Color +orchid1 = Color 255 131 250 -- #FF83FA + +orchid2 :: Color +orchid2 = Color 238 122 233 -- #EE7AE9 + +orchid3 :: Color +orchid3 = Color 205 105 201 -- #CD69C9 + +orchid4 :: Color +orchid4 = Color 139 71 137 -- #8B4789 + +palegoldenrod :: Color +palegoldenrod = Color 238 232 170 -- #EEE8AA + +palegreen :: Color +palegreen = Color 152 251 152 -- #98FB98 + +palegreen1 :: Color +palegreen1 = Color 154 255 154 -- #9AFF9A + +palegreen2 :: Color +palegreen2 = Color 144 238 144 -- #90EE90 + +palegreen3 :: Color +palegreen3 = Color 124 205 124 -- #7CCD7C + +palegreen4 :: Color +palegreen4 = Color 84 139 84 -- #548B54 + +paleturquoise :: Color +paleturquoise = Color 175 238 238 -- #AFEEEE + +paleturquoise1 :: Color +paleturquoise1 = Color 187 255 255 -- #BBFFFF + +paleturquoise2 :: Color +paleturquoise2 = Color 174 238 238 -- #AEEEEE + +paleturquoise3 :: Color +paleturquoise3 = Color 150 205 205 -- #96CDCD + +paleturquoise4 :: Color +paleturquoise4 = Color 102 139 139 -- #668B8B + +palevioletred :: Color +palevioletred = Color 219 112 147 -- #DB7093 + +palevioletred1 :: Color +palevioletred1 = Color 255 130 171 -- #FF82AB + +palevioletred2 :: Color +palevioletred2 = Color 238 121 159 -- #EE799F + +palevioletred3 :: Color +palevioletred3 = Color 205 104 137 -- #CD6889 + +palevioletred4 :: Color +palevioletred4 = Color 139 71 93 -- #8B475D + +papayawhip :: Color +papayawhip = Color 255 239 213 -- #FFEFD5 + +peachpuff :: Color +peachpuff = Color 255 218 185 -- #FFDAB9 + +peachpuff1 :: Color +peachpuff1 = Color 255 218 185 -- #FFDAB9 + +peachpuff2 :: Color +peachpuff2 = Color 238 203 173 -- #EECBAD + +peachpuff3 :: Color +peachpuff3 = Color 205 175 149 -- #CDAF95 + +peachpuff4 :: Color +peachpuff4 = Color 139 119 101 -- #8B7765 + +peru :: Color +peru = Color 205 133 63 -- #CD853F + +pink :: Color +pink = Color 255 192 203 -- #FFC0CB + +pink1 :: Color +pink1 = Color 255 181 197 -- #FFB5C5 + +pink2 :: Color +pink2 = Color 238 169 184 -- #EEA9B8 + +pink3 :: Color +pink3 = Color 205 145 158 -- #CD919E + +pink4 :: Color +pink4 = Color 139 99 108 -- #8B636C + +plum :: Color +plum = Color 221 160 221 -- #DDA0DD + +plum1 :: Color +plum1 = Color 255 187 255 -- #FFBBFF + +plum2 :: Color +plum2 = Color 238 174 238 -- #EEAEEE + +plum3 :: Color +plum3 = Color 205 150 205 -- #CD96CD + +plum4 :: Color +plum4 = Color 139 102 139 -- #8B668B + +powderblue :: Color +powderblue = Color 176 224 230 -- #B0E0E6 + +purple :: Color +purple = Color 160 32 240 -- #A020F0 + +purple1 :: Color +purple1 = Color 155 48 255 -- #9B30FF + +purple2 :: Color +purple2 = Color 145 44 238 -- #912CEE + +purple3 :: Color +purple3 = Color 125 38 205 -- #7D26CD + +purple4 :: Color +purple4 = Color 85 26 139 -- #551A8B + +red :: Color +red = Color 255 0 0 -- #FF0000 + +red1 :: Color +red1 = Color 255 0 0 -- #FF0000 + +red2 :: Color +red2 = Color 238 0 0 -- #EE0000 + +red3 :: Color +red3 = Color 205 0 0 -- #CD0000 + +red4 :: Color +red4 = Color 139 0 0 -- #8B0000 + +rosybrown :: Color +rosybrown = Color 188 143 143 -- #BC8F8F + +rosybrown1 :: Color +rosybrown1 = Color 255 193 193 -- #FFC1C1 + +rosybrown2 :: Color +rosybrown2 = Color 238 180 180 -- #EEB4B4 + +rosybrown3 :: Color +rosybrown3 = Color 205 155 155 -- #CD9B9B + +rosybrown4 :: Color +rosybrown4 = Color 139 105 105 -- #8B6969 + +royalblue :: Color +royalblue = Color 65 105 225 -- #4169E1 + +royalblue1 :: Color +royalblue1 = Color 72 118 255 -- #4876FF + +royalblue2 :: Color +royalblue2 = Color 67 110 238 -- #436EEE + +royalblue3 :: Color +royalblue3 = Color 58 95 205 -- #3A5FCD + +royalblue4 :: Color +royalblue4 = Color 39 64 139 -- #27408B + +saddlebrown :: Color +saddlebrown = Color 139 69 19 -- #8B4513 + +salmon :: Color +salmon = Color 250 128 114 -- #FA8072 + +salmon1 :: Color +salmon1 = Color 255 140 105 -- #FF8C69 + +salmon2 :: Color +salmon2 = Color 238 130 98 -- #EE8262 + +salmon3 :: Color +salmon3 = Color 205 112 84 -- #CD7054 + +salmon4 :: Color +salmon4 = Color 139 76 57 -- #8B4C39 + +sandybrown :: Color +sandybrown = Color 244 164 96 -- #F4A460 + +seagreen :: Color +seagreen = Color 46 139 87 -- #2E8B57 + +seagreen1 :: Color +seagreen1 = Color 84 255 159 -- #54FF9F + +seagreen2 :: Color +seagreen2 = Color 78 238 148 -- #4EEE94 + +seagreen3 :: Color +seagreen3 = Color 67 205 128 -- #43CD80 + +seagreen4 :: Color +seagreen4 = Color 46 139 87 -- #2E8B57 + +seashell :: Color +seashell = Color 255 245 238 -- #FFF5EE + +seashell1 :: Color +seashell1 = Color 255 245 238 -- #FFF5EE + +seashell2 :: Color +seashell2 = Color 238 229 222 -- #EEE5DE + +seashell3 :: Color +seashell3 = Color 205 197 191 -- #CDC5BF + +seashell4 :: Color +seashell4 = Color 139 134 130 -- #8B8682 + +sienna :: Color +sienna = Color 160 82 45 -- #A0522D + +sienna1 :: Color +sienna1 = Color 255 130 71 -- #FF8247 + +sienna2 :: Color +sienna2 = Color 238 121 66 -- #EE7942 + +sienna3 :: Color +sienna3 = Color 205 104 57 -- #CD6839 + +sienna4 :: Color +sienna4 = Color 139 71 38 -- #8B4726 + +skyblue :: Color +skyblue = Color 135 206 235 -- #87CEEB + +skyblue1 :: Color +skyblue1 = Color 135 206 255 -- #87CEFF + +skyblue2 :: Color +skyblue2 = Color 126 192 238 -- #7EC0EE + +skyblue3 :: Color +skyblue3 = Color 108 166 205 -- #6CA6CD + +skyblue4 :: Color +skyblue4 = Color 74 112 139 -- #4A708B + +slateblue :: Color +slateblue = Color 106 90 205 -- #6A5ACD + +slateblue1 :: Color +slateblue1 = Color 131 111 255 -- #836FFF + +slateblue2 :: Color +slateblue2 = Color 122 103 238 -- #7A67EE + +slateblue3 :: Color +slateblue3 = Color 105 89 205 -- #6959CD + +slateblue4 :: Color +slateblue4 = Color 71 60 139 -- #473C8B + +slategray :: Color +slategray = Color 112 128 144 -- #708090 + +slategray1 :: Color +slategray1 = Color 198 226 255 -- #C6E2FF + +slategray2 :: Color +slategray2 = Color 185 211 238 -- #B9D3EE + +slategray3 :: Color +slategray3 = Color 159 182 205 -- #9FB6CD + +slategray4 :: Color +slategray4 = Color 108 123 139 -- #6C7B8B + +slategrey :: Color +slategrey = Color 112 128 144 -- #708090 + +snow :: Color +snow = Color 255 250 250 -- #FFFAFA + +snow1 :: Color +snow1 = Color 255 250 250 -- #FFFAFA + +snow2 :: Color +snow2 = Color 238 233 233 -- #EEE9E9 + +snow3 :: Color +snow3 = Color 205 201 201 -- #CDC9C9 + +snow4 :: Color +snow4 = Color 139 137 137 -- #8B8989 + +springgreen :: Color +springgreen = Color 0 255 127 -- #00FF7F + +springgreen1 :: Color +springgreen1 = Color 0 255 127 -- #00FF7F + +springgreen2 :: Color +springgreen2 = Color 0 238 118 -- #00EE76 + +springgreen3 :: Color +springgreen3 = Color 0 205 102 -- #00CD66 + +springgreen4 :: Color +springgreen4 = Color 0 139 69 -- #008B45 + +steelblue :: Color +steelblue = Color 70 130 180 -- #4682B4 + +steelblue1 :: Color +steelblue1 = Color 99 184 255 -- #63B8FF + +steelblue2 :: Color +steelblue2 = Color 92 172 238 -- #5CACEE + +steelblue3 :: Color +steelblue3 = Color 79 148 205 -- #4F94CD + +steelblue4 :: Color +steelblue4 = Color 54 100 139 -- #36648B + +tan :: Color +tan = Color 210 180 140 -- #D2B48C + +tan1 :: Color +tan1 = Color 255 165 79 -- #FFA54F + +tan2 :: Color +tan2 = Color 238 154 73 -- #EE9A49 + +tan3 :: Color +tan3 = Color 205 133 63 -- #CD853F + +tan4 :: Color +tan4 = Color 139 90 43 -- #8B5A2B + +thistle :: Color +thistle = Color 216 191 216 -- #D8BFD8 + +thistle1 :: Color +thistle1 = Color 255 225 255 -- #FFE1FF + +thistle2 :: Color +thistle2 = Color 238 210 238 -- #EED2EE + +thistle3 :: Color +thistle3 = Color 205 181 205 -- #CDB5CD + +thistle4 :: Color +thistle4 = Color 139 123 139 -- #8B7B8B + +tomato :: Color +tomato = Color 255 99 71 -- #FF6347 + +tomato1 :: Color +tomato1 = Color 255 99 71 -- #FF6347 + +tomato2 :: Color +tomato2 = Color 238 92 66 -- #EE5C42 + +tomato3 :: Color +tomato3 = Color 205 79 57 -- #CD4F39 + +tomato4 :: Color +tomato4 = Color 139 54 38 -- #8B3626 + +turquoise :: Color +turquoise = Color 64 224 208 -- #40E0D0 + +turquoise1 :: Color +turquoise1 = Color 0 245 255 -- #00F5FF + +turquoise2 :: Color +turquoise2 = Color 0 229 238 -- #00E5EE + +turquoise3 :: Color +turquoise3 = Color 0 197 205 -- #00C5CD + +turquoise4 :: Color +turquoise4 = Color 0 134 139 -- #00868B + +violet :: Color +violet = Color 238 130 238 -- #EE82EE + +violetred :: Color +violetred = Color 208 32 144 -- #D02090 + +violetred1 :: Color +violetred1 = Color 255 62 150 -- #FF3E96 + +violetred2 :: Color +violetred2 = Color 238 58 140 -- #EE3A8C + +violetred3 :: Color +violetred3 = Color 205 50 120 -- #CD3278 + +violetred4 :: Color +violetred4 = Color 139 34 82 -- #8B2252 + +wheat :: Color +wheat = Color 245 222 179 -- #F5DEB3 + +wheat1 :: Color +wheat1 = Color 255 231 186 -- #FFE7BA + +wheat2 :: Color +wheat2 = Color 238 216 174 -- #EED8AE + +wheat3 :: Color +wheat3 = Color 205 186 150 -- #CDBA96 + +wheat4 :: Color +wheat4 = Color 139 126 102 -- #8B7E66 + +whitesmoke :: Color +whitesmoke = Color 245 245 245 -- #F5F5F5 + +yellow :: Color +yellow = Color 255 255 0 -- #FFFF00 + +yellow1 :: Color +yellow1 = Color 255 255 0 -- #FFFF00 + +yellow2 :: Color +yellow2 = Color 238 238 0 -- #EEEE00 + +yellow3 :: Color +yellow3 = Color 205 205 0 -- #CDCD00 + +yellow4 :: Color +yellow4 = Color 139 139 0 -- #8B8B00 + +yellowgreen :: Color +yellowgreen = Color 154 205 50 -- #9ACD32 diff --git a/src/Graphics/Hgg/DAG.hs b/src/Graphics/Hgg/DAG.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/DAG.hs @@ -0,0 +1,429 @@ +-- | +-- Module : Graphics.Hgg.DAG +-- Description : algebraic-graphs 流 DAG builder + layout (Phase 26 §E-6) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- DAG (directed graph) を **polymorphic な Graph a + 代数演算** で構築し、 +-- Graphics.Hgg.Spec.DAGSpec に変換して描画 layer を作る。 algebraic-graphs +-- (Mokhov) と同じ思想: +-- +-- * 'overlay' / '(<>)' ─ graph を並置 (= 和集合) +-- * 'connect' / '(~>)' ─ 全 edge を貼る +-- * 'vertex' ─ 単一 node +-- * 'empty' ─ 何も無い +-- +-- 例: +-- +-- > hbmModel :: Graph Text +-- > hbmModel +-- > = "alpha" ~> "sigma" ~> "y" +-- > <> "beta" ~> "sigma" +-- > <> "alpha" ~> "y" +-- > <> "beta" ~> "y" +-- > +-- > spec :: VisualSpec +-- > spec = purePlot +-- > <> dagPlot hbmModel +-- > <> title "HBM model" +-- +-- node 属性 (= label / kind) は 'ToDAGNode' 型クラスで抽出。 'Text' は全 latent +-- default、 record や tuple で明示も可。 幽霊型 module (= 将来 +-- @Graphics.Hgg.DAG.Typed@) も instance 追加だけで対応。 +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.DAG + ( -- * Graph algebra + Graph(..) + , empty + , vertex + , overlay + , connect + , (~>) + , edges + , vertices + -- * Attribute extraction + , ToDAGNode(..) + -- * Layer + , dagPlot + , dagPlotWith + , dagPlotWithPlates + , dagPlotWithRankGroups + -- * Layout + , layoutHierarchical + , layoutHierarchicalFull + , layoutHierarchicalFullWithPlates + , layoutHierarchicalFullWithConstraints + -- * Inspection + , toVertices + , toEdges + ) where + +import Graphics.Hgg.DAG.Internal.Sugiyama + (LNode (..), LayoutGraph, + applyPlateConstraints, + assignCoords, auxSimplexCoordsW, + assignOrderFull, + assignRanksGrouped, lgNodes) +import Graphics.Hgg.Layout (dagNodeBaseHalfWidth) +import Graphics.Hgg.Spec (DAGEdge (..), DAGLayoutAlgorithm (..), + DAGNode (..), DAGNodeKind (..), + DAGPlate (..), Layer, dagFromLists, + dagFromListsWithPlates) +import Data.List (foldl', nub) +import qualified Data.Map.Strict as Map +import Data.Text (Text) + +-- =========================================================================== +-- Graph algebra (= algebraic-graphs / Mokhov) +-- =========================================================================== + +-- | 代数的 DAG。 'a' は vertex の identity (任意型)。 +-- +-- * 'Empty' ─ 空 +-- * 'Vertex' ─ 単一 node +-- * 'Overlay' ─ 2 graph を並置 (= 和集合、 edges もそのまま) +-- * 'Connect' ─ 2 graph の全ペアに edge を張る (= 第 1 の全 vertex から +-- 第 2 の全 vertex へ) +data Graph a + = Empty + | Vertex !a + | Overlay !(Graph a) !(Graph a) + | Connect !(Graph a) !(Graph a) + deriving (Show, Eq, Functor) + +instance Semigroup (Graph a) where (<>) = Overlay +instance Monoid (Graph a) where mempty = Empty + +empty :: Graph a +empty = Empty + +vertex :: a -> Graph a +vertex = Vertex + +overlay :: Graph a -> Graph a -> Graph a +overlay = Overlay + +connect :: Graph a -> Graph a -> Graph a +connect = Connect + +-- | edge を貼る軽量 operator。 `<>` (infixr 6) より tight に binding (= 7) して +-- `a ~> b <> c ~> d` が `(a ~> b) <> (c ~> d)` と parse される。 +infix 7 ~> +(~>) :: a -> a -> Graph a +a ~> b = Connect (Vertex a) (Vertex b) + +-- | edge リストから graph を作る (= 補助 helper、 既存パターンの移行用)。 +edges :: [(a, a)] -> Graph a +edges es = foldl' Overlay Empty [ Connect (Vertex f) (Vertex t) | (f, t) <- es ] + +-- | vertex 群を overlay。 +vertices :: [a] -> Graph a +vertices = foldl' Overlay Empty . map Vertex + +-- =========================================================================== +-- ToDAGNode (= attribute 抽出 type class) +-- =========================================================================== + +-- | Graph の vertex 型 'a' から (id, label, kind) を取り出す。 +-- ユーザ独自 newtype / 幽霊型でも instance 追加するだけで dagPlot に渡せる。 +class Ord a => ToDAGNode a where + toDAGNode :: a -> (Text, Text, DAGNodeKind) + +-- | 最小 case: Text を id 兼 label、 kind = NodeLatent (default)。 +instance ToDAGNode Text where + toDAGNode t = (t, t, NodeLatent) + +-- | (id, label, kind) tuple をそのまま。 +instance ToDAGNode (Text, Text, DAGNodeKind) where + toDAGNode = id + +-- | DAGNode を直接 vertex として渡す場合 (= 位置情報含む、 LayoutManual 用)。 +instance ToDAGNode DAGNode where + toDAGNode n = (dnId n, dnLabel n, dnKind n) + +-- =========================================================================== +-- Graph → Layer 変換 (= dagPlot) +-- =========================================================================== + +-- | algebraic graph を VisualSpec の Layer に。 layout は階層 (= 推奨 default)。 +-- +-- > dagPlot ("a" ~> "b" ~> "c" <> "a" ~> "c") +dagPlot :: ToDAGNode a => Graph a -> Layer +dagPlot g = dagPlotWith LayoutHierarchical g + +-- | layout algorithm を明示指定。 +dagPlotWith :: ToDAGNode a => DAGLayoutAlgorithm -> Graph a -> Layer +dagPlotWith algo g = + let vs = toVertices g + es = toEdges g + -- 重複排除 + 属性抽出 + nodeAttrs = nub [ toDAGNode v | v <- vs ] + nodeList = [ DAGNode i lbl k Nothing 0 0 | (i, lbl, k) <- nodeAttrs ] + edgeList = [ DAGEdge (fstId f) (fstId t) Nothing Nothing | (f, t) <- es ] + fstId v = let (i, _, _) = toDAGNode v in i + -- layout 適用 (= 位置を埋める) + (positioned, routedEdges) = case algo of + LayoutManual -> (nodeList, edgeList) -- そのまま、 dnX/dnY は 0 のまま、 path 無し + LayoutHierarchical -> layoutHierarchicalFull nodeList edgeList + in dagFromLists positioned routedEdges algo + +-- | Phase 1 A6: plate (= cluster) を伴う Graph DSL 用 helper。 +-- LayoutHierarchical で plate-aware ordering (= 同 plate メンバが rank 内で +-- contiguous) を適用する。 plates 順は外側 → 内側 (= nested plate 用)。 +dagPlotWithPlates :: ToDAGNode a => Graph a -> [DAGPlate] -> Layer +dagPlotWithPlates g plates = + let vs = toVertices g + es = toEdges g + nodeAttrs = nub [ toDAGNode v | v <- vs ] + nodeList = [ DAGNode i lbl k Nothing 0 0 | (i, lbl, k) <- nodeAttrs ] + edgeList = [ DAGEdge (fstId f) (fstId t) Nothing Nothing | (f, t) <- es ] + fstId v = let (i, _, _) = toDAGNode v in i + (positioned, routedEdges) = + layoutHierarchicalFullWithPlates nodeList edgeList plates + in dagFromListsWithPlates positioned routedEdges LayoutHierarchical plates + +-- | Phase 53 A3: rank group (= graphviz @rank=same@) を伴う Graph DSL 用 helper。 +-- 各 group の member id は同一 rank に置かれ、 group 内の edge は flat edge +-- (= 同 rank edge) として P3e 順序制約 (左→右) + P7b 水平/迂回 spline で描画される。 +-- rank group は layout 制約であり出力 DAGSpec には載らない (= 計画 md A3-1)。 +-- +-- > dagPlotWithRankGroups ("a" ~> "b" <> "a" ~> "c") [["b", "c"]] +dagPlotWithRankGroups :: ToDAGNode a => Graph a -> [[Text]] -> Layer +dagPlotWithRankGroups g rankGroups = + let vs = toVertices g + es = toEdges g + nodeAttrs = nub [ toDAGNode v | v <- vs ] + nodeList = [ DAGNode i lbl k Nothing 0 0 | (i, lbl, k) <- nodeAttrs ] + edgeList = [ DAGEdge (fstId f) (fstId t) Nothing Nothing | (f, t) <- es ] + fstId v = let (i, _, _) = toDAGNode v in i + (positioned, routedEdges) = + layoutHierarchicalFullWithConstraints nodeList edgeList [] rankGroups + in dagFromLists positioned routedEdges LayoutHierarchical + +-- | Graph 構造から vertex 列を抽出 (= 重複あり、 順序保持)。 +toVertices :: Graph a -> [a] +toVertices g = go g [] + where + go Empty acc = acc + go (Vertex a) acc = a : acc + go (Overlay x y) acc = go x (go y acc) + go (Connect x y) acc = go x (go y acc) + +-- | Graph 構造から edge 列を抽出 (= Connect が出すクロス積)。 +toEdges :: Graph a -> [(a, a)] +toEdges g = go g + where + go Empty = [] + go (Vertex _) = [] + go (Overlay x y) = go x <> go y + go (Connect x y) = + let lvs = toVertices x + rvs = toVertices y + in go x <> go y <> [(l, r) | l <- lvs, r <- rvs] + +-- =========================================================================== +-- Layout: 階層 (Sugiyama 簡易版) +-- =========================================================================== + +-- | 階層 layout (= Sugiyama framework、 Phase 1 で network simplex rank assignment に置換)。 +-- +-- 1. Step 2 'assignRanks' (= network simplex framework、 内部 'longestPathRanking' で初期解、 一様 δ=ω=1 では即時最適) で各 node の rank を決定 +-- 2. (Phase 1 未実装) Step 3 Order assignment、 Step 4 Coordinate assignment は今は alphabetical 等間隔 (= A3/A4 で置換予定) +-- 3. y は rank に比例 (= 上から下) +-- +-- domain 座標で返す (= 0..1 正規化)。 Render 側で scale 適用。 +layoutHierarchical :: [DAGNode] -> [DAGEdge] -> [DAGNode] +layoutHierarchical nodes es = fst (layoutHierarchicalFull nodes es) + +-- | 階層 layout の full 版 (= plate 無し)。 'layoutHierarchicalFullWithPlates' の薄 wrapper。 +layoutHierarchicalFull + :: [DAGNode] -> [DAGEdge] -> ([DAGNode], [DAGEdge]) +layoutHierarchicalFull nodes es = + layoutHierarchicalFullWithPlates nodes es [] + +-- | Phase 53 A3: rank group (= graphviz @rank=same@) も受ける full 版。 +-- rank group は**入力時 layout 制約**で出力 spec には載せない (layout は builder +-- 時のみ実行され、 JSON 復元後の再 layout 経路が無いことを実測済 = 計画 md A3-1)。 +layoutHierarchicalFullWithConstraints + :: [DAGNode] -> [DAGEdge] -> [DAGPlate] -> [[Text]] -> ([DAGNode], [DAGEdge]) +layoutHierarchicalFullWithConstraints nodes es plates rankGroups = + let StageRouted ns es' = + routeStage . coordStage . orderStage . rankStage $ + StageRaw nodes es plates rankGroups + in (ns, es') + +-- | Phase 1 A6 plate-aware: node の (x, y) 配置 + edge の 'dePath' を同時計算。 +-- 'plates' が空でなければ post-process で同 plate メンバを rank 内 contiguous に。 +-- 渡された plates 順を尊重 (= nested 用、 外側 → 内側)。 +-- +-- Phase 39 B1: 旧一枚岩 'let' を rank → order → coord → route の段階関数に分離。 +-- 各段の中身 (assignRanks 等の呼出) は不変、 段間は record の包み直しのみ +-- (= 出力ビット不変、 golden 回帰で担保)。 段階型 (= 'StageRaw' 〜 'StageRouted') +-- が「どの段で何が産出されるか」 (chainMap = order 段, coordMap = coord 段) を +-- 型に明示し、 B2 (routing module 独立) の入力契約の土台にする。 +layoutHierarchicalFullWithPlates + :: [DAGNode] -> [DAGEdge] -> [DAGPlate] -> ([DAGNode], [DAGEdge]) +layoutHierarchicalFullWithPlates nodes es plates = + layoutHierarchicalFullWithConstraints nodes es plates [] + +-- =========================================================================== +-- Phase 39 B1: layout pipeline の段階型と段階関数 +-- =========================================================================== + +-- | 段階0: 入力そのまま (rank 前)。 後段で nodes (= 最終配置) / es (= routedE・ +-- recenter) / plates (= banding・extent) を参照するため全段で保持する。 +data StageRaw = StageRaw + { srNodes :: [DAGNode] + , srEdges :: [DAGEdge] + , srPlates :: [DAGPlate] + , srRankGroups :: [[Text]] -- ^ Phase 53 A3: graphviz rank=same 相当の同 rank group + } + +-- | 段階1: rank 割当済 (tightenSourceRanks 反映済) LayoutGraph。 +data StageRanked = StageRanked + { rkInput :: StageRaw + , rkGraph :: LayoutGraph + } + +-- | 段階2: order 確定 + 元 edge → chain map (= skip edge routing 用) が産出される段。 +data StageOrdered = StageOrdered + { odInput :: StageRaw + , odGraph :: LayoutGraph + , odOrder :: Map.Map Int [Text] + , odChain :: Map.Map (Text, Text) [Text] + } + +-- | 段階3: x 座標確定 (route 前)。 coordMap (= banding + recenter 反映済) が産出される段。 +data StagePositioned = StagePositioned + { psInput :: StageRaw + , psChain :: Map.Map (Text, Text) [Text] + , psRankOf :: Map.Map Text Int + , psCoord :: Map.Map Text Double + } + +-- | 段階4: 最終 (配置済 node + dePath 埋め edge)。 +data StageRouted = StageRouted + { rtNodes :: [DAGNode] + , rtEdges :: [DAGEdge] + } + +-- | rank 段: longest-path / network simplex で rank 割当 → source 引き締め。 +-- +-- Phase 53 A3-2: 旧 breakCycles → assignRanks → tightenSourceRanks の直列は +-- 'assignRanksGrouped' に集約 (rank group 無しではビット一致、 test 担保)。 +-- rank group 有りでは group を代表 node に併合して rank 割当し、 group 内 edge が +-- flat edge (= 同 rank edge) として下流へ流れる。 +rankStage :: StageRaw -> StageRanked +rankStage raw = + let nodes = srNodes raw; es = srEdges raw; plates = srPlates raw + ids = map dnId nodes + lg0' = assignRanksGrouped (srRankGroups raw) (map dpNodeIds plates) + ids [ (deFrom e, deTo e) | e <- es ] + in StageRanked raw lg0' + +-- | order 段: dummy 挿入 + median heuristic + transpose、 元 edge → chain map 取得、 +-- plate 制約 post-process。 +orderStage :: StageRanked -> StageOrdered +orderStage (StageRanked raw lg0') = + let -- A3: dummy 挿入 + median heuristic + transpose、 元 edge → chain map も取得 + (lgFinal, orderMap0, chainMap) = assignOrderFull lg0' + -- A6: plate 制約 post-process (= 同 plate メンバを rank 内 contiguous に) + orderMap = applyPlateConstraints (map dpNodeIds (srPlates raw)) orderMap0 + in StageOrdered raw lgFinal orderMap chainMap + +-- | coord 段: P4a aux-graph network simplex で x 座標を解く。 +-- +-- Phase 39 Step8 (P8) A2: plate メンバ id を P4a simplex に渡し、 cluster border +-- 制約 (contain/keepout, graphviz @pos_clusters@・A1 実装) を x 座標へ直接反映する。 +-- これで box 分離が simplex 由来になったため、 従来の cosmetic post-process +-- ('applyPlateBands' = 帯分離 / 'recenterNonPlateRows' = 帯後の重心緩和) を**撤去** +-- した ([[feedback-remove-stopgaps-when-real-algo-lands]])。 +coordStage :: StageOrdered -> StagePositioned +coordStage (StageOrdered raw lgFinal orderMap chainMap) = + let plates = srPlates raw + -- ★ A4-3 EXPERIMENT (完全忠実): real-width simplex の **raw point 座標**を + -- 正規化せず直接使う (= graphviz の point 一貫 pipeline)。 wpt rescale を介さない。 + hwMap = Map.fromList + [ (dnId n, round (dagNodeBaseHalfWidth n) :: Int) | n <- srNodes raw ] + coordMap = auxSimplexCoordsW hwMap (map dpNodeIds plates) lgFinal orderMap + rankOf = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lgFinal ] + in StagePositioned raw chainMap rankOf coordMap + +-- | route 段: node 最終配置 (rank→y) + edge dePath (chain waypoint)。 +-- +-- Phase 39 Step8 (P8) A3: plate 箱迂回の応急処置 'routeLongEdgeDummies' (RLED) を +-- **撤去**した ([[feedback-remove-stopgaps-when-real-algo-lands]])。 撤去の根拠は +-- 二段構えの本実装が landing したこと: +-- +-- 1. layout 層 = A1 cluster border 制約 (@keepout_othernodes@) が plate 非メンバ +-- (long-edge dummy 含む) を simplex で箱外へ押し出す。 → guide 自体が箱外。 +-- 2. render 層 = 'Render.EdgeRoute.routeEdge' の box-channel + funnel が plate box +-- を障害物に取り、 guide を箱の外で taut spline へ整える。 → 幾何的に貫通しない。 +-- +-- 実測 (RLED 撤去 vs 存置): 実 HBM DAG (hbm-after) は **ビット不変**、 box を直線 +-- 貫通する合成ケース (plate-through/plate-cross) は RLED の「箱辺に張り付く」 bend +-- より funnel の方が箱から余裕を持って外迂回し改善。 RLED は箱辺密着の cosmetic +-- でしかなかったことが裏付けられた。 +routeStage :: StagePositioned -> StageRouted +routeStage (StagePositioned raw chainMap rankOf coordMap) = + let nodes = srNodes raw; es = srEdges raw + -- ★ A4-3 (完全忠実 point pipeline): y は **rank index** をそのまま返す。 + -- point 化 (× rankPitch = maxNodeH+ranksep) は radius が既知の render 側で行う + -- (x は simplex の raw point ゆえ layout で確定・y だけ render で pitch を被せる)。 + yOf r = fromIntegral r + posOf nid = + let x = Map.findWithDefault 0.5 nid coordMap + r = Map.findWithDefault 0 nid rankOf + in (x, yOf r) + positionedN = [ n { dnX = x, dnY = y } + | n <- nodes + , let (x, y) = posOf (dnId n) ] + -- A5: 元 edge の chain から control 点列を埋める。 長 edge は rank 単位 dummy + -- 経由 chain を返すのみ (= rank-level waypoint)。 plate box 回避の幾何 routing は + -- 障害物が pt で確定する Render 側 (pt 空間 routesplines・Phase 39 A2-8) に移譲。 + -- + -- P7b 最小 (Phase 53 A3-4): flat edge (= 同 rank edge、 rank group 由来)。 + -- 間に他 real node が無ければ dePath 無し = 水平直線 (side port 同士)。 + -- 間に node があれば rank の**上側 gap** (= r - 0.5、 graphviz make_flat_edge が + -- rank 上の空間へ逃がすのと同層) に waypoint を 1 点置き、 render 側の + -- box-channel / funnel / proutespline に迂回 spline を作らせる。 + flatPath e = + case (Map.lookup (deFrom e) rankOf, Map.lookup (deTo e) rankOf) of + (Just rf, Just rt) | rf == rt -> + let xF = Map.findWithDefault 0.5 (deFrom e) coordMap + xT = Map.findWithDefault 0.5 (deTo e) coordMap + (lo, hi) = (min xF xT, max xF xT) + blocked = or [ x > lo && x < hi + | n <- nodes + , dnId n /= deFrom e, dnId n /= deTo e + , Map.lookup (dnId n) rankOf == Just rf + , let x = Map.findWithDefault 0.5 (dnId n) coordMap ] + in if blocked + then Just [ (xF, yOf rf) + , ((xF + xT) / 2, yOf rf - 0.5) + , (xT, yOf rt) ] + else Nothing + _ -> Nothing + routedE = [ e { dePath = maybe (chainToPath e) Just (flatPath e) } | e <- es ] + -- P2a: layout で back-edge が反転されている場合 chainMap の key は (to,from)。 + -- 直接 key が無ければ反転 key を引き、 chain を反転して原方向 (from→to) に戻す。 + -- acyclic 入力では常に直接 key がヒットする (= 非破壊)。 + chainToPath e = case Map.lookup (deFrom e, deTo e) chainMap of + Just chain | length chain > 2 -> Just (map posOf chain) + _ -> case Map.lookup (deTo e, deFrom e) chainMap of + Just chain | length chain > 2 -> Just (map posOf (reverse chain)) + _ -> Nothing + in StageRouted positionedN routedE + +-- =========================================================================== +-- Phase 1 A2 以前の 'computeDepths' (= longest path 直接実装) は削除済。 +-- 同等処理は 'Graphics.Hgg.DAG.Internal.Sugiyama.longestPathRanking' に移動、 +-- 'assignRanks' (= network simplex framework) 経由で呼ばれる。 +-- =========================================================================== + +-- Phase 39 Step8 (P8) A3: long-edge dummy を plate 箱外へ bend する応急処置 +-- 'routeLongEdgeDummies' (RLED) は撤去した。 plate 箱迂回は A1 cluster border 制約 +-- (layout) + 'Render.EdgeRoute' box-channel/funnel (render) の二段で本実装済。 +-- 経緯と実測根拠は 'routeStage' の haddock を参照。 diff --git a/src/Graphics/Hgg/DAG/Internal/Sugiyama.hs b/src/Graphics/Hgg/DAG/Internal/Sugiyama.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/DAG/Internal/Sugiyama.hs @@ -0,0 +1,1215 @@ +-- | +-- Module : Graphics.Hgg.DAG.Internal.Sugiyama +-- Description : Sugiyama framework 中間表現 + Step 2 Rank + Step 3 Order (Phase 1 A2-A3) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Graphics.Hgg.DAG 内部で使う Sugiyama framework の中間表現と各 step 実装。 +-- 外向け Graph a / DAGSpec には漏らさない (= spec §10.3 dummy node 規律)。 +-- +-- 現状 (Phase 1 A2): +-- +-- * LNode / LEdge / LayoutGraph 中間型 +-- * Step 2 Rank assignment: network simplex (Gansner-Koutsofios-North-Vo 1993 §2.3) +-- * 全 edge の minimum length δ = 1、 weight ω = 1 が default +-- (= 現状 DAG.Graph の edge は属性無し、 将来 weight 拡張余地) +-- +-- 設計判断: 一様 δ=1 / ω=1 の場合、 longest-path ranking が既に Σ edge length +-- 最適解 (= 証明: edge 数固定で各 edge の最小 rank diff = 1)。 そのため network +-- simplex の **反復改善 phase は実質 no-op** になる。 ただし将来 weight / 異δ +-- 拡張に備えて framework として実装し、 初期解 = longest-path、 反復 = 負 cut +-- value 探索 (= 該当無し → 即終了) という構造で書く。 +-- +-- 計算量: +-- * 初期 longest-path: O(V + E) +-- * tight tree 構築: O(V + E) +-- * cut value 計算: O(V × E) (= 各 tree edge について非 tree edge を走査) +-- * 反復: 一様 ω では 0 回、 一般には worst O(V × E) per iteration × V iterations +-- +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.DAG.Internal.Sugiyama + ( -- * 中間表現 + LNode (..) + , LEdge (..) + , LayoutGraph (..) + , buildLayoutGraph + -- * Step 2-0 (P2a): acyclic 化 + , breakCycles + -- * Step 2: Rank assignment + , assignRanks + , assignRanksGrouped + , longestPathRanking + , tightTreeEdges + , tightenSourceRanks + -- * 汎用 network simplex (= P4a x 座標で使う共通ソルバ) + , networkSimplex + , networkSimplexBalanced + -- * Step 3: Order assignment (= median heuristic + transpose) + , OrderMap + , insertDummies + , insertDummiesWithChains + , initialOrder + , medianSweep + , transposeOrder + , flatReorder + , assignOrder + , assignOrderFull + , countCrossings + , bilayerCrossings + -- * Step 4: Coordinate assignment (= P4a aux graph network simplex) + , assignCoords + , assignCoordsW + , auxSimplexCoords + , auxSimplexCoordsW + , computeOneDir + -- * Step 5 (Phase 1 A6): Plate (= cluster) 制約 + , applyPlateConstraints + -- * Inspection (= test 用) + , edgeLengthSum + , isFeasible + ) where + +import Data.List (foldl', sort, sortBy) +import Data.Maybe (listToMaybe) +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T + +-- =========================================================================== +-- 中間表現 +-- =========================================================================== + +-- | 内部 node。 元の DAGNode から id を保持し、 rank を埋める。 +-- dummy node (= A3 で長 edge 中継用) は 'lnDummy' で区別。 +data LNode = LNode + { lnId :: !Text -- ^ 元 node id (dummy なら "__dummy_") + , lnRank :: !Int -- ^ Step 2 で割当てる rank + , lnDummy :: !Bool -- ^ A3 で長 edge を分割するために追加した dummy か + } deriving (Eq, Show) + +-- | 内部 edge。 weight / minimum length δ を持つ。 +-- Phase 1 A2 では全 edge weight=1, delta=1 だが将来拡張余地。 +data LEdge = LEdge + { leFrom :: !Text + , leTo :: !Text + , leDelta :: !Int -- ^ 最小 rank 差 (= δ)、 default 1 + , leWeight :: !Double -- ^ edge weight (= ω)、 default 1.0 + } deriving (Eq, Show) + +-- | Sugiyama framework の中間 graph。 +data LayoutGraph = LayoutGraph + { lgNodes :: ![LNode] + , lgEdges :: ![LEdge] + } deriving (Eq, Show) + +-- | 元 (id, parents) ペア群から LayoutGraph を組み立てる。 +-- すべての edge は δ=1 / ω=1 で初期化。 rank は未割当 (= 0)。 +buildLayoutGraph + :: [Text] -- ^ 全 node id (順序保持、 stable iteration 用) + -> [(Text, Text)] -- ^ edge list (from, to) + -> LayoutGraph +buildLayoutGraph ids es = + LayoutGraph + { lgNodes = [ LNode i 0 False | i <- ids ] + , lgEdges = [ LEdge f t 1 1.0 | (f, t) <- es ] + } + +-- =========================================================================== +-- Step 2-0 (P2a): acyclic 化 (= graphviz acyclic.c 相当) +-- =========================================================================== + +-- | DFS で back-edge を検出して反転し、 self-loop は rank 制約に寄与しないので +-- 除去する。 rank/order 用の acyclic edge 列を返す。 +-- +-- graphviz の 'acyclic.c' (decompose + break_cycles) と同じく「閉路を一時的に +-- 反転して DAG 化 → layout → 描画時に向きを戻す」 戦略の前半。 描画方向は呼出側 +-- (DAG.hs) が原 edge で保持し、 chain lookup は反転 key fallback で吸収する。 +-- +-- **非破壊性**: 入力が既に DAG なら back-edge は存在せず、 self-loop も無ければ +-- edge は順序保持で不変。 = 現行の acyclic テストケース (large/medium/small/ +-- isolated) には影響しない。 閉路入力でのみ rank が正しくなる +-- (従来は 'longestPathRanking' の「0 仮置き」 で誤った rank になっていた)。 +-- +-- DFS 着色: gray = 現在の stack 上、 black = 探索完了。 (u→v) で v が gray なら +-- back-edge。 起点は @ids@ 順に全 node を走査するので非連結成分も網羅する。 +breakCycles :: [Text] -> [(Text, Text)] -> [(Text, Text)] +breakCycles ids es = + let adj = Map.fromListWith (flip (++)) + [ (f, [t]) | (f, t) <- es, f /= t ] -- self-loop は隣接から除外 + dfs acc@(gray, black, rev) u + | Set.member u black = acc + | otherwise = + let gray1 = Set.insert u gray + outs = Map.findWithDefault [] u adj + step (g, b, r) v + | Set.member v g = (g, b, Set.insert (u, v) r) -- back-edge + | Set.member v b = (g, b, r) -- forward/cross + | otherwise = dfs (g, b, r) v + (gray2, black2, rev2) = foldl' step (gray1, black, rev) outs + in (Set.delete u gray2, Set.insert u black2, rev2) + (_, _, reversedSet) = + foldl' dfs (Set.empty, Set.empty, Set.empty) ids + orient (f, t) + | f == t = Nothing -- self-loop は除去 + | Set.member (f, t) reversedSet = Just (t, f) -- back-edge は反転 + | otherwise = Just (f, t) + in [ e | Just e <- map orient es ] + +-- =========================================================================== +-- Step 2: Rank assignment (= network simplex) +-- =========================================================================== + +-- | LayoutGraph の lnRank を埋める。 Phase 1 A2 採用 = network simplex。 +-- +-- 流れ (Gansner 1993 §2.3): +-- +-- 1. 'longestPathRanking' で初期 feasible ranking +-- 2. 'buildTightTree' で tight edge から spanning tree +-- 3. 'cutValues' で各 tree edge の cut value +-- 4. 負 cut value の tree edge があれば置換 (= 'pivotOnce')、 無ければ最適 +-- 5. 反復終了後 rank を 0-base に正規化 +-- +-- 一様 δ=1 / ω=1 では step 1 で最適解。 反復は no-op になる。 +assignRanks :: LayoutGraph -> LayoutGraph +assignRanks lg0 = + let lg1 = longestPathRanking lg0 + lg2 = iterateSimplex lg1 (length (lgNodes lg0) * 4) -- 上限 = 4V iteration + lg3 = normalizeRanks lg2 + in lg3 + +-- | Step 2-1: longest-path ranking (= 各 node に「source からの最長 path 長」 を割当)。 +-- 一様 δ=1 / ω=1 では Σ edge length 最適解。 +longestPathRanking :: LayoutGraph -> LayoutGraph +longestPathRanking lg = + let parents = Map.fromListWith (<>) + [ (leTo e, [(leFrom e, leDelta e)]) | e <- lgEdges lg ] + ids = [ lnId n | n <- lgNodes lg ] + go memo i = case Map.lookup i memo of + Just r -> (r, memo) + Nothing -> + let ps = Map.findWithDefault [] i parents + -- cycle 安全: 自分を 0 で仮置き + memo0 = Map.insert i 0 memo + (memo', rs) = foldl' + (\(m, acc) (p, d) -> + let (rp, m') = go m p + in (m', (rp + d) : acc)) + (memo0, []) + ps + r = if null rs then 0 else maximum rs + in (r, Map.insert i r memo') + finalMemo = foldl' (\m i -> snd (go m i)) Map.empty ids + newNodes = [ n { lnRank = Map.findWithDefault 0 (lnId n) finalMemo } + | n <- lgNodes lg ] + in lg { lgNodes = newNodes } + +-- | Step 2-2〜5: simplex 反復。 上限 iteration 内で負 cut value が無くなるまで pivot。 +-- 一様 δ=1 / ω=1 では即時終了 (= 負 cut value 無し)。 +iterateSimplex :: LayoutGraph -> Int -> LayoutGraph +iterateSimplex lg 0 = lg +iterateSimplex lg budget = + case pivotOnce lg of + Nothing -> lg -- 最適解到達 + Just lg' -> iterateSimplex lg' (budget - 1) + +-- | 1 回の pivot: 負 cut value の tree edge を非 tree edge と置換。 +-- 該当無しなら 'Nothing'。 +-- +-- **設計判断 (= Phase 1 A2 honest stub)**: +-- +-- 一様 δ=1 / ω=1 の場合、 longest-path ranking が既に Σ edge length 最適解 +-- (= 各 edge の length が ≥ δ=1 の制約下で全 edge 合計を最小化、 longest-path +-- は各 node を最深位置に置くので「圧縮余地ゼロ」)。 したがって全 tree edge の +-- cut value は ≥ 0 になることが保証され、 pivot は発生しない。 +-- +-- 本関数は **将来 weight / 異 δ 拡張に備えた framework hook**。 現状は常に +-- 'Nothing' を返し、 'iterateSimplex' は初期解で即終了する。 +-- +-- 拡張時の実装方針 (TODO Phase 1+): +-- +-- 1. 'tightTreeEdges' で tight edge から spanning tree 抽出 +-- 2. 各 tree edge を切ったときの head/tail 側 partition を BFS で求め +-- 3. 非 tree edge weight 差から cut value 計算 +-- 4. 最小 cut value < 0 なら非 tree edge の min slack で置換 +pivotOnce :: LayoutGraph -> Maybe LayoutGraph +pivotOnce _ = Nothing + +-- | tight tree edge (= rank(v) - rank(u) = δ(u,v) を満たす edge) を列挙。 +-- pivot 実装時の前段として用意。 現状未使用。 +tightTreeEdges :: LayoutGraph -> [LEdge] +tightTreeEdges lg = + let rankOf = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] + isTight e = case (Map.lookup (leFrom e) rankOf, Map.lookup (leTo e) rankOf) of + (Just ru, Just rv) -> rv - ru == leDelta e + _ -> False + in filter isTight (lgEdges lg) + +-- | rank を 0-base に正規化 (= 最小 rank を 0 に shift)。 +normalizeRanks :: LayoutGraph -> LayoutGraph +normalizeRanks lg = + case lgNodes lg of + [] -> lg + ns -> + let rmin = minimum (map lnRank ns) + newNodes = [ n { lnRank = lnRank n - rmin } | n <- ns ] + in lg { lgNodes = newNodes } + +-- | Phase 19 A4: rank 引き締め ('assignRanks' の後処理)。 +-- +-- ① **source 引き下げ**: in-edge 無し・out-edge 有りの node を +-- @min(rank(succ) − δ)@ へ。 longest-path ranking は source を rank 0 に +-- 固定するため、 深い消費者しか持たない source (data slot / sigma 等) の +-- edge が図を縦断し、 plate bbox (= メンバの bounding box) が縦に伸びる +-- (Σ edge length も非最適。 graphviz は source を消費者の直前 rank に置く)。 +-- 全 out-edge の rank 差 ≥ δ は min の取り方により維持される。 +-- ② **エッジ無し plate メンバの引き寄せ**: edge を一切持たない node が +-- plate メンバなら、 同 plate の (edge を持つ) メンバの最小 rank へ +-- (フローティング解消・analyze の DataIx データノードで顕在化)。 +-- +-- 最後に 0-base へ再正規化する。 plate 無し・深い source 無しのグラフでは +-- no-op (= 既存図はビット不変)。 +tightenSourceRanks :: [[Text]] -> LayoutGraph -> LayoutGraph +tightenSourceRanks plateMembers lg = + let nodes = lgNodes lg + edges = lgEdges lg + rankOf0 = Map.fromList [ (lnId n, lnRank n) | n <- nodes ] + hasIn = Set.fromList (map leTo edges) + hasOut = Set.fromList (map leFrom edges) + succOf = Map.fromListWith (<>) + [ (leFrom e, [(leTo e, leDelta e)]) | e <- edges ] + -- ① source 引き下げ + rank1 nid r + | nid `Set.member` hasIn = r + | Just ss <- Map.lookup nid succOf = + minimum [ Map.findWithDefault 0 v rankOf0 - d | (v, d) <- ss ] + | otherwise = r + rankOf1 = Map.mapWithKey rank1 rankOf0 + -- ② エッジ無し plate メンバ (plate は外側→内側順で渡される。 + -- 最初に見つかった所属 plate = 最内でなくてよい: メンバ rank の + -- min はどの所属 plate でも bbox を縮める方向) + edgeless nid = not (nid `Set.member` hasIn) && not (nid `Set.member` hasOut) + plateMin nid = + case [ rs | members <- plateMembers, nid `elem` members + , let rs = [ r | m <- members, m /= nid + , not (edgeless m) + , Just r <- [Map.lookup m rankOf1] ] + , not (null rs) ] of + (rs : _) -> Just (minimum rs) + [] -> Nothing + rank2 nid r + | edgeless nid, Just r' <- plateMin nid = r' + | otherwise = r + rankOf2 = Map.mapWithKey rank2 rankOf1 + newNodes = [ n { lnRank = Map.findWithDefault (lnRank n) (lnId n) rankOf2 } + | n <- nodes ] + in normalizeRanks lg { lgNodes = newNodes } + +-- =========================================================================== +-- Step 2-1 (P3e 前提・Phase 53 A3-2): rank=same 制約付き rank 割当 +-- =========================================================================== + +-- | graphviz @rank=same@ 相当: 同 rank group を代表 node に併合して rank 割当 +-- (= graphviz cluster collapse / @UF_union@) し、 member へ rank を展開する。 +-- +-- 戻り値の edge は rank 向きに正規化済: +-- +-- * rank(from) < rank(to) はそのまま、 逆なら反転 (= 'breakCycles' の back-edge +-- 反転と同値。 呼出側の chain lookup は既存の反転 key fallback で吸収) +-- * rank(from) == rank(to) (= **flat edge**、 group 内 edge のみで発生) は +-- 原方向のまま保持。 ranking 制約には寄与しない (併合で self-loop 化し除外) +-- * self-loop は除去 ('breakCycles' と同じ) +-- +-- @groups = []@ では rep = id で全経路が既存と一致し、 出力 LayoutGraph は +-- 従来の breakCycles → assignRanks → tightenSourceRanks とビット一致する +-- (orient は「back-edge 反転後の rank 差 ≥ 1」 の不変量により DFS 反転と同値。 +-- test で担保)。 +assignRanksGrouped + :: [[Text]] -- ^ 同 rank group 群 (member 共有 group は併合される) + -> [[Text]] -- ^ plate member 群 (= 'tightenSourceRanks' 用) + -> [Text] -- ^ 全 node id (順序保持) + -> [(Text, Text)] -- ^ 原 edge 列 (向き任意、 self-loop 可) + -> LayoutGraph +assignRanksGrouped groups plateIds ids es = + let -- group の併合 (member 共有 = 同値類)。 rep = ids 中で最初に現れる member + -- (= group の列挙順に依存しない決定論)。 + mergeSets = foldl' addGroup [] groups + addGroup acc g = + let gs = Set.fromList g + (hit, miss) = span' (\s -> not (Set.disjoint s gs)) acc + in Set.unions (gs : hit) : miss + span' p xs = (filter p xs, filter (not . p) xs) + idIx = Map.fromList (zip ids [0 :: Int ..]) + repOfSet s = case sortBy (\a b -> compare (idIx Map.! a) (idIx Map.! b)) + [ m | m <- Set.toList s, Map.member m idIx ] of + (r0 : _) -> [ (m, r0) | m <- Set.toList s ] + [] -> [] + repMap = Map.fromList (concatMap repOfSet mergeSets) + rep i = Map.findWithDefault i i repMap + -- 代表 graph で acyclic 化 + rank 割当 (group 内 edge は self-loop 化して落ちる。 + -- group 間の双方向 edge が作る閉路は breakCycles が反転処理) + repIds = dedupStable (map rep ids) + repEs = [ (rep f, rep t) | (f, t) <- es, rep f /= rep t ] + acyc = breakCycles repIds repEs + lgRep = tightenSourceRanks (map (map rep) plateIds) + (assignRanks (buildLayoutGraph repIds acyc)) + rkRep = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lgRep ] + rankOf i = Map.findWithDefault 0 (rep i) rkRep + -- 原 id へ展開 + edge を rank 向きに正規化 + orient (f, t) + | f == t = Nothing + | rankOf f <= rankOf t = Just (f, t) + | otherwise = Just (t, f) + nodes = [ LNode i (rankOf i) False | i <- ids ] + edges = [ LEdge f t 1 1.0 | Just (f, t) <- map orient es ] + in LayoutGraph nodes edges + +-- | 順序保持の重複除去 (= 最初の出現のみ残す)。 +dedupStable :: [Text] -> [Text] +dedupStable = go Set.empty + where + go _ [] = [] + go seen (x : xs) + | Set.member x seen = go seen xs + | otherwise = x : go (Set.insert x seen) xs + +-- =========================================================================== +-- Inspection (= test 用) +-- =========================================================================== + +-- | Σ ω(u,v) × (rank(v) - rank(u)) を返す (= rank assignment の目的関数)。 +-- longest-path / network simplex の検算用。 +edgeLengthSum :: LayoutGraph -> Double +edgeLengthSum lg = + let rankOf = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] + contrib e = case (Map.lookup (leFrom e) rankOf, Map.lookup (leTo e) rankOf) of + (Just ru, Just rv) -> leWeight e * fromIntegral (rv - ru) + _ -> 0 + in sum (map contrib (lgEdges lg)) + +-- | feasibility check: 全 edge で rank(v) - rank(u) ≥ δ(u,v)。 +isFeasible :: LayoutGraph -> Bool +isFeasible lg = + let rankOf = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] + check e = case (Map.lookup (leFrom e) rankOf, Map.lookup (leTo e) rankOf) of + (Just ru, Just rv) -> rv - ru >= leDelta e + _ -> True + in all check (lgEdges lg) + +-- =========================================================================== +-- 汎用 network simplex (Gansner-Koutsofios-North-Vo 1993 §2.3) +-- = graphviz の network simplex に相当する共通ソルバ。 node 集合と +-- (tail, head, δ, ω) edge 群を受け、 各 node に整数座標 r を割当て +-- Σ ω · (r_head − r_tail) +-- を制約 r_head − r_tail ≥ δ の下で最小化する。 +-- +-- graphviz では rank.c (rank 割当) と position.c (x 座標 = aux graph 上の +-- 同 simplex) の両方がこれを使う。 本実装では ranking は一様 δ=ω=1 で +-- longest-path が既に最適なため 'assignRanks' はそのまま据え置き、 本関数は +-- 主に P4a x 座標割当 (= Ω 1:2:8 + nodesep の非一様 aux graph) で使う。 +-- +-- 流れ: +-- 1. initRankNS : longest-path で feasible 初期解 (入力は DAG 前提) +-- 2. feasibleTreeNS : tight edge で spanning tree を成長 (min-slack で調整) +-- 3. tightRanksTree : tree を全 edge tight にする一意割当 (大域 shift 自由度 +-- を root=0 で固定) +-- 4. optimize : 負 cut value の tree edge を、 cut を逆向きに跨ぐ +-- min-slack 非 tree edge と交換し、 新 tree で再割当 +-- 5. normalizeNS : 最小 r を 0 に +-- +-- 非連結 graph は弱連結成分ごとに独立フレームで解く。 +-- =========================================================================== + +-- | 汎用 network simplex。 戻り値は全 node の整数座標 (= rank / x)。 +-- balance は行わない (= ranking 用・最適頂点を 1 つ返す)。 +networkSimplex :: [Text] -> [(Text, Text, Int, Double)] -> Map Text Int +networkSimplex = networkSimplexWith False + +-- | LR balance 付き network simplex (= graphviz position.c の @rank(g, 2)@ 相当)。 +-- 最適到達後、 cut value 0 の tree edge を slack の中央へ寄せて対称化する +-- (= x 座標割当 P4a 用。 free node を隣接の重心へ寄せ左右対称にする)。 +networkSimplexBalanced :: [Text] -> [(Text, Text, Int, Double)] -> Map Text Int +networkSimplexBalanced = networkSimplexWith True + +networkSimplexWith + :: Bool -> [Text] -> [(Text, Text, Int, Double)] -> Map Text Int +networkSimplexWith balance nodes edges = + Map.unions [ solveComponent balance cn ce | (cn, ce) <- weakComponents nodes edges ] + +-- | 弱連結成分に分解 (edge を無向視)。 edge を持たない孤立 node も 1 成分。 +weakComponents + :: [Text] -> [(Text, Text, Int, Double)] + -> [([Text], [(Text, Text, Int, Double)])] +weakComponents nodes edges = + let undirAdj = Map.fromListWith (<>) + (concat [ [(t, [h]), (h, [t])] | (t, h, _, _) <- edges ]) + bfs visited [] = visited + bfs visited (v : q) = + let ns = [ u | u <- Map.findWithDefault [] v undirAdj + , not (Set.member u visited) ] + in bfs (foldr Set.insert visited ns) (q ++ ns) + go (seen, acc) v + | Set.member v seen = (seen, acc) + | otherwise = + let comp = bfs (Set.singleton v) [v] + cn = [ u | u <- nodes, Set.member u comp ] + ce = [ e | e@(t, h, _, _) <- edges + , Set.member t comp, Set.member h comp ] + in (Set.union seen comp, acc ++ [(cn, ce)]) + (_, comps) = foldl' go (Set.empty, []) nodes + in comps + +-- | 連結成分 1 個を解く。 @balance@ なら最後に LR balance を掛ける。 +solveComponent + :: Bool -> [Text] -> [(Text, Text, Int, Double)] -> Map Text Int +solveComponent balance cnodes cedges + | null cnodes = Map.empty + | null cedges = Map.fromList [ (v, 0) | v <- cnodes ] + | otherwise = + let r0 = initRankNS cnodes cedges + tree0 = feasibleTreeNS cnodes cedges r0 + r1 = tightRanksTree cnodes cedges tree0 + budget = 2 * length cedges + length cnodes + (treeF, rF) = optimizeNS budget cnodes cedges tree0 r1 + rB = if balance then balanceLR cnodes cedges treeF rF else rF + in normalizeNS rB + +-- | longest-path feasible 初期 rank (各 node = source からの δ 重み最長 path)。 +initRankNS :: [Text] -> [(Text, Text, Int, Double)] -> Map Text Int +initRankNS cnodes cedges = + let parents = Map.fromListWith (<>) + [ (h, [(t, d)]) | (t, h, d, _) <- cedges ] + go memo v = case Map.lookup v memo of + Just r -> (r, memo) + Nothing -> + let ps = Map.findWithDefault [] v parents + memo0 = Map.insert v 0 memo -- cycle 安全 (本来 DAG) + (memo', rs) = foldl' + (\(m, acc) (p, d) -> let (rp, m') = go m p in (m', (rp + d) : acc)) + (memo0, []) ps + r = if null rs then 0 else maximum rs + in (r, Map.insert v r memo') + finalMemo = foldl' (\m v -> snd (go m v)) Map.empty cnodes + in Map.fromList [ (v, Map.findWithDefault 0 v finalMemo) | v <- cnodes ] + +-- | edge の slack = r_head − r_tail − δ (≥ 0 が feasible)。 +slackNS :: Map Text Int -> (Text, Text, Int, Double) -> Int +slackNS r (t, h, d, _) = + Map.findWithDefault 0 h r - Map.findWithDefault 0 t r - d + +-- | tight edge で spanning tree を成長させ tree edge index 集合を返す。 +-- spanning に満たない間は min-slack の incident 非 tree edge を選び tree を +-- 平行移動して tight 化し、 再成長する (Gansner93 feasible_tree)。 +feasibleTreeNS + :: [Text] -> [(Text, Text, Int, Double)] -> Map Text Int -> Set.Set Int +feasibleTreeNS cnodes cedges r0 = + let iedges = zip [0 :: Int ..] cedges + n = length cnodes + start = head cnodes + -- 現 rank での tight tree (1 edge ずつ追加して必ず tree を保つ)。 + tightTree r = + let step (tn, te) = + case [ (i, if Set.member t tn then h else t) + | (i, (t, h, d, _)) <- iedges + , not (Set.member i te) + , let inT = Set.member t tn + inH = Set.member h tn + , inT /= inH + , Map.findWithDefault 0 h r - Map.findWithDefault 0 t r - d == 0 ] of + [] -> (tn, te) + ((i, o) : _) -> step (Set.insert o tn, Set.insert i te) + in step (Set.singleton start, Set.empty) + loop r = + let (tn, te) = tightTree r + in if Set.size tn >= n + then te + else + let cands = [ (slackNS r e, Set.member h tn) + | (_, e@(t, h, _, _)) <- iedges + , let inT = Set.member t tn + inH = Set.member h tn + , inT /= inH ] + in case cands of + [] -> te -- 非連結 (理論上ここには来ない) → 現状で打切り + _ -> + let (sl, headInTree) = minimum cands + delta = if headInTree then negate sl else sl + r' = Map.mapWithKey + (\v x -> if Set.member v tn then x + delta else x) r + in loop r' + in loop r0 + +-- | spanning tree を全 edge tight にする一意 rank (root=start を 0 に固定)。 +tightRanksTree + :: [Text] -> [(Text, Text, Int, Double)] -> Set.Set Int -> Map Text Int +tightRanksTree cnodes cedges tree = + let start = head cnodes + -- tree edge を無向化: t→h は +d、 h→t は −d (r_head = r_tail + δ) + adj = Map.fromListWith (<>) $ concat + [ [(t, [(h, d)]), (h, [(t, negate d)])] + | (i, (t, h, d, _)) <- zip [0 :: Int ..] cedges, Set.member i tree ] + bfs visited rank [] = rank + bfs visited rank (v : q) = + let (visited', rank', new) = + foldl' (\(vs, rk, nw) (u, dd) -> + if Set.member u vs + then (vs, rk, nw) + else ( Set.insert u vs + , Map.insert u (Map.findWithDefault 0 v rk + dd) rk + , u : nw )) + (visited, rank, []) (Map.findWithDefault [] v adj) + in bfs visited' rank' (q ++ new) + ranked = bfs (Set.singleton start) (Map.singleton start 0) [start] + in Map.fromList [ (v, Map.findWithDefault 0 v ranked) | v <- cnodes ] + +-- | negative cut value の tree edge を解消するまで pivot。 +-- 戻り値 = (最終 spanning tree, rank)。 tree は balance で再利用する。 +optimizeNS + :: Int -> [Text] -> [(Text, Text, Int, Double)] + -> Set.Set Int -> Map Text Int -> (Set.Set Int, Map Text Int) +optimizeNS budget cnodes cedges tree rank + | budget <= 0 = (tree, rank) + | otherwise = + let iedges = zip [0 :: Int ..] cedges + edgeOf i = cedges !! i + -- tree edge le を外したときの tail 側成分 (= tail を含む node 集合) + tailSide le = + let (lt, _, _, _) = edgeOf le + tadj = Map.fromListWith (<>) $ concat + [ [(t, [h]), (h, [t])] + | (i, (t, h, _, _)) <- iedges, Set.member i tree, i /= le ] + bfs visited [] = visited + bfs visited (v : q) = + let ns = [ u | u <- Map.findWithDefault [] v tadj + , not (Set.member u visited) ] + in bfs (foldr Set.insert visited ns) (q ++ ns) + in bfs (Set.singleton lt) [lt] + cutValue le = + let tc = tailSide le + contrib (t, h, _, w) = + let tIn = Set.member t tc + hIn = Set.member h tc + in if tIn && not hIn then w + else if not tIn && hIn then negate w + else 0 + in (sum (map contrib cedges), tc) + negTreeEdges = + [ (le, tc) | le <- Set.toList tree + , let (cv, tc) = cutValue le, cv < -1e-9 ] + in case negTreeEdges of + [] -> (tree, rank) -- 最適到達 + ((le, tc) : _) -> + -- entering edge: cut を逆向き (head 側→tail 側) に跨ぐ min-slack 非 tree edge + let enters = [ (slackNS rank e, i) + | (i, e@(t, h, _, _)) <- iedges + , not (Set.member i tree) + , not (Set.member t tc) -- tail が head 側 + , Set.member h tc ] -- head が tail 側 + in case enters of + [] -> (tree, rank) -- 理論上来ない (cut<0 なら必ず存在) + _ -> + let (_, fe) = minimum enters + tree' = Set.insert fe (Set.delete le tree) + rank' = tightRanksTree cnodes cedges tree' + in optimizeNS (budget - 1) cnodes cedges tree' rank' + +-- | LR balance (graphviz ns.c @balance@, mode 2)。 cut value 0 の tree edge を +-- 列挙し、 その edge を逆向きに跨ぐ非 tree edge の slack δ (= 動かせる余地) の +-- 半分だけ tail 側成分を中央へ寄せる。 cost は不変 (cut=0 = 微分 0) なので最適性 +-- を保ったまま free node を対称化する。 single pass (graphviz と同様)。 +balanceLR + :: [Text] -> [(Text, Text, Int, Double)] + -> Set.Set Int -> Map Text Int -> Map Text Int +balanceLR _cnodes cedges tree rank0 = + let iedges = zip [0 :: Int ..] cedges + edgeOf i = cedges !! i + tailSide le = + let (lt, _, _, _) = edgeOf le + tadj = Map.fromListWith (<>) $ concat + [ [(t, [h]), (h, [t])] + | (i, (t, h, _, _)) <- iedges, Set.member i tree, i /= le ] + bfs visited [] = visited + bfs visited (v : q) = + let ns = [ u | u <- Map.findWithDefault [] v tadj + , not (Set.member u visited) ] + in bfs (foldr Set.insert visited ns) (q ++ ns) + in bfs (Set.singleton lt) [lt] + cutValue le tc = + sum [ if Set.member t tc && not (Set.member h tc) then w + else if not (Set.member t tc) && Set.member h tc then negate w + else 0 + | (t, h, _, w) <- cedges ] + step rank le = + let tc = tailSide le + in if abs (cutValue le tc) > 1e-9 + then rank -- cut ≠ 0 は動かせない + else + let enters = [ Map.findWithDefault 0 h rank + - Map.findWithDefault 0 t rank - d + | (i, (t, h, d, _)) <- iedges + , not (Set.member i tree) + , not (Set.member t tc), Set.member h tc ] + in case enters of + [] -> rank + _ -> let delta = minimum enters + in if delta < 2 then rank + else let half = delta `div` 2 + in Map.mapWithKey + (\v x -> if Set.member v tc then x - half else x) + rank + -- tail 側を持つ tree edge のみ対象 (LR/straightening 両方含む) + in foldl' step rank0 (Set.toList tree) + +-- | 最小座標を 0 に正規化。 +normalizeNS :: Map Text Int -> Map Text Int +normalizeNS m + | Map.null m = m + | otherwise = let mn = minimum (Map.elems m) in Map.map (subtract mn) m + +-- =========================================================================== +-- Step 3: Order assignment (Phase 1 A3) +-- Gansner-Koutsofios-North-Vo 1993 §3、 dot default 24 iteration の +-- median heuristic + transpose で同 rank 内の node 順を最適化。 +-- 長 edge (rank 差 > 1) は dummy node 経由の short edge 列に展開する。 +-- =========================================================================== + +-- | 各 rank の node 順 (= rank → 左から右の id 列)。 +type OrderMap = Map Int [Text] + +-- | 長 edge (= rank 差 > 1) を中間 rank の dummy node 経由の短 edge 列に展開。 +-- dummy node は 'lnDummy = True' で区別、 id は @"__dummy_"@。 +-- 元 edge は削除され、 同 weight の短 edge 列に置換される。 +insertDummies :: LayoutGraph -> LayoutGraph +insertDummies lg = fst (insertDummiesWithChains lg) + +-- | 'insertDummies' + 元 edge → 経由 chain (= 始点と終点を含む id 列) を返す。 +-- 短 edge (rank 差 1) も map に含まれ、 chain = [from, to] (= 2 要素)。 +-- Phase 1 A5 edge routing で、 元 edge を chain 経由の control 点列で描画するために使う。 +insertDummiesWithChains + :: LayoutGraph -> (LayoutGraph, Map (Text, Text) [Text]) +insertDummiesWithChains lg = + let rankOf = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] + step (accN, accE, accM, k) e = + case (Map.lookup (leFrom e) rankOf, Map.lookup (leTo e) rankOf) of + (Just ru, Just rv) | rv - ru > 1 -> + let nDum = rv - ru - 1 + names = [ T.pack ("__dummy_" ++ show (k + i)) + | i <- [0 .. nDum - 1] ] + dnodes = zipWith (\nm r -> LNode nm r True) names [ru + 1 ..] + chain = leFrom e : names ++ [leTo e] + newE = zipWith (\f t -> LEdge f t 1 (leWeight e)) + chain (tail chain) + in ( accN ++ dnodes + , accE ++ newE + , Map.insert (leFrom e, leTo e) chain accM + , k + nDum ) + _ -> + ( accN + , accE ++ [e] + , Map.insert (leFrom e, leTo e) [leFrom e, leTo e] accM + , k ) + (extra, newEdges, chainMap, _) = + foldl' step ([], [], Map.empty, 0 :: Int) (lgEdges lg) + in ( lg { lgNodes = lgNodes lg ++ extra, lgEdges = newEdges } + , chainMap ) + +-- | rank ごとの初期順序 (= ID 辞書順、 決定論性のため)。 +initialOrder :: LayoutGraph -> OrderMap +initialOrder lg = + let grouped = Map.fromListWith (<>) + [ (lnRank n, [lnId n]) | n <- lgNodes lg ] + in Map.map sort grouped + +-- | 2 隣接 rank 間の交差数 (naive O(E^2))。 +-- 'edges' は (u, v) ペア、 u は upper の id、 v は lower の id。 +bilayerCrossings :: [(Text, Text)] -> [Text] -> [Text] -> Int +bilayerCrossings edges upper lower = + let posU = Map.fromList (zip upper [0 :: Int ..]) + posL = Map.fromList (zip lower [0 :: Int ..]) + pairs = [ (pu, pl) + | (u, v) <- edges + , Just pu <- [Map.lookup u posU] + , Just pl <- [Map.lookup v posL] ] + go [] = 0 + go ((pu1, pl1):rest) = + let c = length [ () | (pu2, pl2) <- rest + , (pu1 < pu2 && pl1 > pl2) + || (pu1 > pu2 && pl1 < pl2) ] + in c + go rest + in go pairs + +-- | 全 rank pair の交差数合計。 +countCrossings :: LayoutGraph -> OrderMap -> Int +countCrossings lg om = + let rankMap = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] + edgesAt r = + [ (leFrom e, leTo e) + | e <- lgEdges lg + , Map.lookup (leFrom e) rankMap == Just r + , Map.lookup (leTo e) rankMap == Just (r + 1) ] + ranks = Map.keys om + maxR = if null ranks then 0 else maximum ranks + in sum [ bilayerCrossings (edgesAt r) + (Map.findWithDefault [] r om) + (Map.findWithDefault [] (r + 1) om) + | r <- [0 .. maxR - 1] ] + +-- | median: 偶数個なら 2 中央値の平均、 奇数個なら中央。 +medianOf :: [Double] -> Maybe Double +medianOf [] = Nothing +medianOf xs = + let s = sort xs + n = length s + mid = n `div` 2 + in Just $ if odd n + then s !! mid + else (s !! (mid - 1) + s !! mid) / 2 + +-- | 1 回 sweep (= median heuristic 1 pass)。 +-- 'topDown' True = rank 増加方向、 False = 減少方向。 +medianSweep :: LayoutGraph -> Bool -> OrderMap -> OrderMap +medianSweep lg topDown om0 = + let ranks = sort (Map.keys om0) + sweepDir = if topDown then ranks else reverse ranks + adjOf v td = + if td -- 上から下に sweep → 各 node の median は **predecessors (= 上の rank)** で決める + then [ leFrom e | e <- lgEdges lg, leTo e == v ] + else [ leTo e | e <- lgEdges lg, leFrom e == v ] + sweepOne r om' = + let adjRank = if topDown then r - 1 else r + 1 + adjList = Map.findWithDefault [] adjRank om' + posMap = Map.fromList (zip adjList [0 :: Int ..]) + posOf x = fromIntegral <$> Map.lookup x posMap + here = Map.findWithDefault [] r om' + tagged = + [ (i, v, medianOf [p | nb <- adjOf v topDown, Just p <- [posOf nb]]) + | (i, v) <- zip [0 :: Int ..] here ] + -- Nothing は元位置維持 (= stable sort) + cmp (i1, _, m1) (i2, _, m2) = case (m1, m2) of + (Just a, Just b) -> compare a b <> compare i1 i2 + (Just _, Nothing) -> LT + (Nothing, Just _) -> GT + (Nothing, Nothing) -> compare i1 i2 + sorted = sortBy cmp tagged + in Map.insert r [ v | (_, v, _) <- sorted ] om' + in foldl' (flip sweepOne) om0 sweepDir + +-- | transpose: 同 rank 内の隣接 pair を試し交換、 交差数が下がるなら採用。 +-- 上下 rank の edge を両方見て判定。 +transposeOrder :: LayoutGraph -> OrderMap -> OrderMap +transposeOrder lg om0 = + let rankMap = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] + edgesBetween r1 r2 = + [ (leFrom e, leTo e) + | e <- lgEdges lg + , Map.lookup (leFrom e) rankMap == Just r1 + , Map.lookup (leTo e) rankMap == Just r2 ] + tryRank r om' = + let here = Map.findWithDefault [] r om' + upper = Map.findWithDefault [] (r - 1) om' + lower = Map.findWithDefault [] (r + 1) om' + eUp = edgesBetween (r - 1) r + eDown = edgesBetween r (r + 1) + crossOf order = + bilayerCrossings eUp upper order + + bilayerCrossings eDown order lower + -- 隣接 pair を順に swap 試行、 交差数が減るなら採用 (= dot 流 transpose) + doSwap acc i = + if i + 1 >= length acc + then acc + else + let a = acc !! i + b = acc !! (i + 1) + swp = take i acc ++ [b, a] ++ drop (i + 2) acc + in if crossOf swp < crossOf acc + then doSwap swp (i + 1) + else doSwap acc (i + 1) + optimized = doSwap here 0 + in Map.insert r optimized om' + ranks = sort (Map.keys om0) + in foldl' (flip tryRank) om0 ranks + +-- | P3e (Phase 53 A3-3): flat edge (= 同 rank edge) の順序制約。 +-- graphviz @mincross.c@ の @flat_breakcycles@ + @flat_reorder@ 相当: +-- 各 rank 内で flat edge が左→右を向くよう、 現在順序への影響を最小にした +-- 安定 topological sort で並べ替える。 flat edge の閉路は 'breakCycles' +-- (現在順序で DFS) で決定論的に破る。 flat edge の無い rank は不変 +-- (= flat edge 無しの graph では全体が恒等、 既存図ビット不変)。 +flatReorder :: LayoutGraph -> OrderMap -> OrderMap +flatReorder lg om0 = + let rankMap = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] + flatAt r = [ (leFrom e, leTo e) + | e <- lgEdges lg + , Map.lookup (leFrom e) rankMap == Just r + , Map.lookup (leTo e) rankMap == Just r ] + tryRank r om' = case flatAt r of + [] -> om' + pairs -> + let here = Map.findWithDefault [] r om' + -- flat 閉路を現在順序の DFS で破る (= graphviz flat_breakcycles) + acyc = breakCycles here pairs + -- 安定 topo sort: indeg 0 の候補から現在 index 最小を選ぶ + -- (= 拘束の無い node の相対位置を保つ、 graphviz flat_reorder の趣旨) + ix = Map.fromList (zip here [0 :: Int ..]) + succs = Map.fromListWith (<>) [ (f, [t]) | (f, t) <- acyc ] + indeg0 = Map.fromListWith (+) + ([ (v, 0 :: Int) | v <- here ] + ++ [ (t, 1) | (_, t) <- acyc ]) + kahn indeg acc + | Map.null indeg = reverse acc + | otherwise = + let ready = [ v | (v, d) <- Map.toList indeg, d == 0 ] + in case sortBy (\a b -> compare (ix Map.! a) (ix Map.! b)) ready of + [] -> reverse acc ++ sortBy + (\a b -> compare (ix Map.! a) (ix Map.! b)) + (Map.keys indeg) -- 保険 (acyc 後は起きない) + (v : _) -> + let dec = Map.findWithDefault [] v succs + indeg' = foldl' (\m t -> Map.adjust (subtract 1) t m) + (Map.delete v indeg) dec + in kahn indeg' (v : acc) + in Map.insert r (kahn indeg0 []) om' + in foldl' (flip tryRank) om0 (sort (Map.keys om0)) + +-- | Step 3 メイン: dummy 挿入 + 24 iteration median sweep + transpose。 +-- 戻り値 = (拡張済 LayoutGraph、 OrderMap)。 OrderMap は dummy も含む。 +assignOrder :: LayoutGraph -> (LayoutGraph, OrderMap) +assignOrder lg0 = let (a, b, _) = assignOrderFull lg0 in (a, b) + +-- | 'assignOrder' + 元 edge → chain map (= A5 edge routing 用)。 +-- +-- P3e (Phase 53 A3-3): flat edge があれば初期順序と各 iteration 後に +-- 'flatReorder' を適用する (medianSweep / transpose は inter-rank edge しか +-- 見ないため、 flat 制約は都度回復させる)。 flat edge 交差は countCrossings の +-- 目的関数に**含めない** (graphviz は flat も ncross に数えるが、 現用途の flat は +-- group 内の少数 edge で左→右向きの保証が主目的。 差分は correspondence doc に記載)。 +assignOrderFull + :: LayoutGraph + -> (LayoutGraph, OrderMap, Map (Text, Text) [Text]) +assignOrderFull lg0 = + let (lg, chainMap) = insertDummiesWithChains lg0 + rankMap = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] + hasFlat = any (\e -> Map.lookup (leFrom e) rankMap + == Map.lookup (leTo e) rankMap) (lgEdges lg) + constrain = if hasFlat then flatReorder lg else id + ini = constrain (initialOrder lg) + iniCross = countCrossings lg ini + step (best, bestC) i = + let td = even (i :: Int) + swept = medianSweep lg td best + transposed = constrain (transposeOrder lg swept) + c = countCrossings lg transposed + in if c < bestC then (transposed, c) else (best, bestC) + (final, _) = foldl' step (ini, iniCross) [0 .. 23] + in (lg, final, chainMap) + +-- =========================================================================== +-- Step 4: Coordinate assignment +-- Phase 39 Step3 (P4a) で Brandes-Köpf 4-candidate から graphviz position.c +-- 忠実の aux graph network simplex ('auxSimplexCoordsW') に置換済。 +-- 旧 BK 実装 (brandesKopf / runBK / markType1 / verticalAlign / horizCompact / +-- bk 定数) は呼び出し元ゼロのまま残っていたため Phase 53 A4 で物理削除 +-- (実装は git 履歴参照)。 +-- =========================================================================== + +-- | Step 4 メイン: x 座標を割当て [0,1] 正規化。 +-- 結果は OrderMap に含まれる全 node id (= dummy 含む) → x ∈ [0,1]。 +-- +-- Phase 39 Step3 (P4a): graphviz position.c に倣い Brandes-Köpf から +-- **aux graph network simplex** ('auxSimplexCoords') へ置換。 BK には無かった +-- 「dummy chain 直線化重み (Ω 1:2:8)」 と 「隣接対 nodesep 強制」 を simplex の +-- 目的関数/制約として同時最適化するため、 長 edge の dummy 列が並走 node 列の +-- 外へ独立縦列として分離する (= large の funnel collapse の layout 層 主因を根治)。 +-- Phase 39 Step8 (P8): 'plates' (= cluster メンバ id 群) を P4a simplex に渡し、 +-- cluster border 制約 ('clusterAuxEdges') を反映した x を解く。 plate 無し ([]) は +-- 従来と完全同一。 +-- | 後方互換 wrapper (= 半幅情報なし = 全 real node 一律 'auxNodeHalfW')。 +-- test 群はこちらを使い構造的不変条件 (collinear / keepout / gap≥) を検証する。 +assignCoords :: [[Text]] -> LayoutGraph -> OrderMap -> Map Text Double +assignCoords = assignCoordsW Map.empty + +-- | Phase 39 P8 A4-2: size-aware 版。 @hwMap@ = real node id → 横半幅 (px, 整数) +-- ('dagNodeBaseHalfWidth' を round したもの・DAG.coordStage が供給)。 simplex の +-- node 間隔/cluster border 制約を実 node 幅で解く (= 兄弟 plate の box 重なり根治)。 +assignCoordsW :: Map Text Int -> [[Text]] -> LayoutGraph -> OrderMap -> Map Text Double +assignCoordsW hwMap plates lg om = + let raw = auxSimplexCoordsW hwMap plates lg om + vals = Map.elems raw + xMin = if null vals then 0 else minimum vals + xMax = if null vals then 1 else maximum vals + norm x = if xMax - xMin < 1e-9 then 0.5 + else (x - xMin) / (xMax - xMin) + in Map.map norm raw + +-- =========================================================================== +-- Step 4 (Phase 39 Step3 = P4a): aux graph network simplex で x 座標 +-- graphviz position.c の @dot_position@ = +-- create_aux_edges → rank(aux, 2 = LR balance) → remove_aux_edges +-- を移植。 補助グラフは +-- ① straightening: 各 layout edge (u,v) を aux node a_e + 2 本の minlen-0 +-- edge a_e→u, a_e→v (weight Ω) に変換。 a_e は min(x_u,x_v) へ浮き、 +-- cost = Ω·|x_u − x_v| (= 直線化)。 Ω は端点の種類で +-- real-real 1 : real-virtual 2 : virtual-virtual 8 +-- (dot 既定比。 dummy chain ほど強く直線に保つ)。 +-- ② LR 制約: 同 rank の隣接対 (l,r) に edge l→r、 minlen = nodesep、 weight 0 +-- (= 順序保持 + 最小間隔強制)。 dummy 絡みは間隔を詰める。 +-- この aux graph 上で 'networkSimplexBalanced' を解くと、 並走する実 node 列と +-- long-edge dummy 列が nodesep 以上離れた独立縦列になる。 +-- =========================================================================== + +-- | LR 制約の最小間隔 = graphviz make_LR_constraints の +-- @width = ND_rw(left) + ND_lw(right) + nodesep@ を移植。 +-- 各 node の **半幅** + nodesep の和を隣接間隔とする。 これにより +-- real node の隣に来る dummy は real の半幅ぶん外へ押し出され、 real node の +-- body 内側に潜り込まない (= long-edge dummy 列が並走 chain の node body の外に +-- 出る = funnel collapse の layout 層 主因を根治)。 +-- +-- 旧実装は dummy 絡みを一律に小間隔 (= 旧 BK bkDummySpacing 0.4) にしており、 +-- dummy が real node body の内側に入っていた (= 並走 chain を貫通) のが large の +-- 主因だった。 +-- +-- 値は **偶数**にする: 全 minlen 偶数 → 全 rank 偶数和 → LR balance の +-- @delta `div` 2@ が丸め無しで厳密中央化される。 +-- +-- Phase 39 P8 A4-2 (改訂): 半幅は **一様** ('auxNodeHalfW') に戻した。 size-aware +-- (per-node 幅) は非兄弟グラフの位置を動かし long-edge routing を折る回帰を生んだ +-- (実測 2026-06-24)。 兄弟 plate box の重なりは separate_subclust (normalized gap) +-- + render binding-pair (実幅は radius 既知の render で考慮) で解く。 +auxNodeHalfW, auxDummyHalfW, auxNodeSep :: Int +auxNodeHalfW = 4 -- real node の半幅 (hwMap 欠落時 fallback) +auxDummyHalfW = 0 -- dummy (virtual) node の半幅 (graphviz でも極小) +auxNodeSep = 18 -- ★ A4-3 EXPERIMENT: graphviz nodesep 既定 18pt (point 一貫) + +-- | Phase 39 Step8 (P8): cluster (= plate) box の margin。 graphviz @CL_OFFSET@=8pt。 +auxPlateMargin :: Int +auxPlateMargin = 8 + +-- | node a と b (= 同 rank で a が左・b が右隣) の最小間隔。 +-- @hwOf@ = 各 node の半幅 (px・dummy/欠落は内部 fallback 済)。 +auxSepOf :: (Text -> Int) -> Text -> Text -> Int +auxSepOf hwOf a b = hwOf a + hwOf b + auxNodeSep + +-- | P4a 本体: aux graph を構築し simplex で x (整数) を解いて Double で返す。 +-- 戻り値 = 実 node (dummy 含む・aux 除く) の raw x。 正規化は 'assignCoords' 側。 +-- +-- Phase 39 Step8 (P8): 'plates' (= cluster メンバ id リスト群) があれば +-- 'clusterAuxEdges' で graphviz position.c @pos_clusters@ 相当の cluster x 制約 +-- (border node + contain/keepout edge) を aux graph に追加する。 plate 無しは +-- 従来と完全同一 (= 図ビット不変)。 +auxSimplexCoords :: [[Text]] -> LayoutGraph -> OrderMap -> Map Text Double +auxSimplexCoords = auxSimplexCoordsW Map.empty + +-- | Phase 39 P8 A4-2: size-aware 版。 @hwMap@ = real node id → 横半幅 (px)。 +-- @hwOf@ は dummy を 'auxDummyHalfW'、 hwMap 欠落を 'auxNodeHalfW' へ fallback。 +auxSimplexCoordsW + :: Map Text Int -> [[Text]] -> LayoutGraph -> OrderMap -> Map Text Double +auxSimplexCoordsW hwMap plates lg om = + let dummySet = Set.fromList [ lnId n | n <- lgNodes lg, lnDummy n ] + isDum v = Set.member v dummySet + hwOf v = if isDum v then auxDummyHalfW + else Map.findWithDefault auxNodeHalfW v hwMap + omega u v + | isDum u && isDum v = 8 :: Int + | isDum u || isDum v = 2 + | otherwise = 1 + -- ① straightening: edge ごとに aux node + 2 本の minlen-0 edge。 + -- P3e (Phase 53 A3): flat edge (= 同 rank) は除外 — graphviz make_edge_pairs + -- も rank 差のある edge のみ対象で、 flat を入れると x(u)=x(v) への引き寄せが + -- 同 rank の LR 分離 (②) と拮抗する。 + rankOfL = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] + rankedEdges = [ e | e <- lgEdges lg + , Map.lookup (leFrom e) rankOfL + /= Map.lookup (leTo e) rankOfL ] + auxId i = "__auxpos_" <> T.pack (show (i :: Int)) + straightEdges = concat + [ let u = leFrom e; v = leTo e + w = fromIntegral (omega u v) * leWeight e + in [ (auxId i, u, 0, w), (auxId i, v, 0, w) ] + | (i, e) <- zip [0 ..] rankedEdges ] + -- ② LR 制約: 同 rank 隣接対に minlen = sep (= 半幅和 + nodesep), weight 0 + lrEdges = + [ (l, r, auxSepOf hwOf l r, 0) + | (_, layer) <- Map.toAscList om, (l, r) <- zip layer (drop 1 layer) ] + -- ③ P8 cluster 制約: border node + contain/keepout/separate (graphviz pos_clusters) + (clustNodes, clustEdges) = clusterAuxEdges hwOf om plates + auxNodes = [ auxId i | (i, _) <- zip [0 ..] rankedEdges ] + realKeys = [ lnId n | n <- lgNodes lg ] + allNodes = realKeys ++ auxNodes ++ clustNodes + xInt = networkSimplexBalanced allNodes + (straightEdges ++ lrEdges ++ clustEdges) + in Map.fromList + [ (v, fromIntegral (Map.findWithDefault 0 v xInt)) | v <- realKeys ] + +-- | Phase 39 Step8 (P8): graphviz @lib/dotgen/position.c@ の @pos_clusters@ +-- (= @create_aux_edges@ 内) が張る cluster x 制約を、 我々の aux graph network +-- simplex 用 edge として生成する。 一次ソースに忠実 (CL_OFFSET=8pt → 'auxPlateMargin'、 +-- border label 無し → border.x=0、 nested は A4 で別途)。 +-- +-- 各 plate p に左右 border virtual node @ln_p@ / @rn_p@ を立て (graphviz +-- @make_lrvn@ = SLACKNODE)、 以下を張る: +-- +-- * @contain_nodes@: 各 rank の最左 member へ @ln_p → 最左@ (minlen = +-- 半幅 + margin)、 最右 member から @最右 → rn_p@ (同)。 = 箱の左右端確定。 +-- * @contain_clustnodes@: @ln_p → rn_p@ (minlen 1, weight 128)。 = 箱を tight +-- に圧縮 (member を詰める強い重み)。 +-- * @keepout_othernodes@: 各 rank で member ブロックの外側最近接 **非メンバ** u に +-- @u → ln_p@ / @rn_p → u@ (minlen = margin + 半幅)。 = 非メンバを箱外へ排除。 +-- * @separate_subclust@: 同一 rank に並ぶ **兄弟** plate (= 互いに包含関係に無い) +-- の隣接 border 間に @rn_left → ln_right@ (minlen = CL_OFFSET)。 = 隣接箱の +-- margin ぶんの隙間を x 解に確保 (= P8 A4-2・兄弟 plate box 重なりの根治)。 +-- +-- ★ Phase 44.3: graphviz @pos_clusters@ にはもう一つ @contain_subclust@ +-- (nested 親子 plate に @ln_p → ln_c@ / @rn_c → rn_p@・minlen CL_OFFSET・weight 128 を +-- 直接の子へ張り、 親箱が子箱を margin ぶん外側で囲む) があるが、 **意図的に未実装**。 +-- 理由 (実測): 我々の plate box は 'plateBoxPt' が「直接 member glyph box ∪ **子 plate box +-- (再帰)** + 固定 margin」で描くため、 入れ子の clearance は **箱モデル側で既に保証**される。 +-- contain_subclust を試作して nested/deep/tri 図を再生成しても幾何変化はゼロ (末尾桁 FP +-- ノイズのみ・PNG はバイト一致) で、 border 制約は box 描画へ伝播しなかった。 = graphviz には +-- 在るが **我々の描画経路では非寄与**ゆえ採用しない (図再生成 FP ノイズの実コストだけが残る)。 +-- 将来 box を border node 由来へ変える場合はその文脈で再導入する。 +-- ([[feedback-graphviz-only-faithful-algos]] / 2026-06-26 実測)。 +-- +-- これにより plate が box として x 分離し、 cosmetic な 'applyPlateBands' / +-- 'recenterNonPlateRows' (帯分離) が不要になる (= Step8 で撤去済)。 +-- +-- Phase 39 P8 A4-2: 半幅は固定 'auxNodeHalfW' でなく @hwOf@ (= 'auxSimplexCoordsW' +-- が hwMap から作る per-node 実半幅) を使う。 dummy/欠落の fallback は hwOf 内で済。 +clusterAuxEdges + :: (Text -> Int) -> OrderMap -> [[Text]] + -> ([Text], [(Text, Text, Int, Double)]) +clusterAuxEdges hwOf om plates = + let lnOf i = "__plate_ln_" <> T.pack (show (i :: Int)) + rnOf i = "__plate_rn_" <> T.pack (show (i :: Int)) + msetAt i = Set.fromList (plates !! i) + perPlate (idx, members) + | null members = ([], []) + | otherwise = ([ln, rn], containE ++ clustE ++ keepoutE) + where + ln = lnOf idx + rn = rnOf idx + mset = Set.fromList members + isMem v = Set.member v mset + -- 各 rank での member ブロックと layer 全体 (keepout の隣接探索用) + rowsOf = + [ (layer, mem) + | (_, layer) <- Map.toAscList om + , let mem = filter isMem layer + , not (null mem) ] + -- contain_nodes: ln → 最左 / 最右 → rn + containE = concat + [ [ (ln, head mem, hwOf (head mem) + auxPlateMargin, 0) + , (last mem, rn, hwOf (last mem) + auxPlateMargin, 0) ] + | (_, mem) <- rowsOf ] + -- contain_clustnodes: ln → rn (tight 圧縮 weight 128) + clustE = [ (ln, rn, 1, 128) ] + -- keepout_othernodes: member ブロックの外側最近接非メンバを箱外へ + keepoutE = concat + [ [ (u, ln, auxPlateMargin + hwOf u, 0) | Just u <- [leftWall] ] + ++ [ (rn, u, auxPlateMargin + hwOf u, 0) | Just u <- [rightWall] ] + | (layer, _) <- rowsOf + , let memIdxs = [ i | (i, v) <- zip [0 ..] layer, isMem v ] + , not (null memIdxs) + , let lo = minimum memIdxs + hi = maximum memIdxs + leftWall = listToMaybe + [ layer !! i | i <- [lo - 1, lo - 2 .. 0], not (isMem (layer !! i)) ] + rightWall = listToMaybe + [ layer !! i | i <- [hi + 1 .. length layer - 1], not (isMem (layer !! i)) ] ] + perResults = map perPlate (zip [0 ..] plates) + -- separate_subclust: rank ごとに member を持つ plate を最左 member 位置で + -- 整列し、 隣接対が兄弟 (= 包含関係に無い) なら border 間に CL_OFFSET を張る。 + nested a b = let ma = msetAt a; mb = msetAt b + in ma == mb || Set.isSubsetOf ma mb || Set.isSubsetOf mb ma + sepEdges = concat + [ [ (rnOf a, lnOf b, auxPlateMargin, 0 :: Double) ] + | (_, layer) <- Map.toAscList om + , let present = [ (i, minimum idxs) + | i <- [0 .. length plates - 1] + , let idxs = [ k | (k, v) <- zip [0 ..] layer + , Set.member v (msetAt i) ] + , not (null idxs) ] + ordered = map fst (sortBy (\x y -> compare (snd x) (snd y)) present) + , (a, b) <- zip ordered (drop 1 ordered) + , not (nested a b) ] + in (concatMap fst perResults, concatMap snd perResults ++ sepEdges) + +-- =========================================================================== +-- Step 5 (Phase 1 A6): Plate (= cluster) 制約 +-- median sweep 後の OrderMap を post-process し、 同 plate に属する node が +-- 同 rank 内で連続するように再並べ替える。 各 plate の median 位置を維持して +-- 並べ替えるため、 crossing 増加を最小化する。 +-- +-- nested plate: 渡された 'plates' 順を尊重し、 外側 → 内側 の順で適用する +-- (= 最初に外側が contiguous 化、 次に内側がさらに細かく contiguous 化)。 +-- 多重所属 (= 1 node が 2 plate に属する) は spec §10.4 で禁止、 +-- plates 中で 後の plate が優先 (= 先のは無視) される簡略処理。 +-- =========================================================================== + +-- | 各 rank で plate メンバを contiguous にする。 plate id は plates 順の index +-- (= 後の plate が優先、 = nested plate の内側を後ろに置く運用を想定)。 +applyPlateConstraints :: [[Text]] -> OrderMap -> OrderMap +applyPlateConstraints [] om = om +applyPlateConstraints plates om = + let -- 各 node の plate id (= plates index、 後の plate が優先) + plateOf = foldl' (\m (pid, ns) -> + foldl' (\mm v -> Map.insert v pid mm) m ns) + Map.empty + (zip [0 :: Int ..] plates) + regroup order = + let n = length order + tagged = [ (i, v, Map.findWithDefault (negate (n + i + 1)) v plateOf) + | (i, v) <- zip [0 ..] order ] + -- 各 plate id の median 位置 (= 元順序内での中央 index) + byPid = Map.fromListWith (<>) + [ (pid, [i]) | (i, _, pid) <- tagged ] + medianOfPid pid = + let ps = sort (Map.findWithDefault [] pid byPid) + k = length ps + in if k == 0 then 0 + else fromIntegral (ps !! (k `div` 2)) :: Double + -- primary key: plate median 位置、 secondary: 元 index + cmp (i1, _, p1) (i2, _, p2) = + compare (medianOfPid p1) (medianOfPid p2) <> compare i1 i2 + sorted = sortBy cmp tagged + in [ v | (_, v, _) <- sorted ] + in Map.map regroup om + +-- | 1 方向 sweep。 'topDown' True なら上 rank の median を anchor、 False なら下 rank。 +-- 同 rank 内では A3 の order を尊重しつつ最小間隔を保証する。 +-- 隣接ペアの少なくとも片方が dummy node なら spacing を 'dummyMinSpacing' に縮める +-- (= dummy は描画されないので chain node と近接させて長 edge spline の遠回りを抑える)。 +computeOneDir :: Bool -> LayoutGraph -> OrderMap -> Map Text Double +computeOneDir topDown lg om = + let ranks = sort (Map.keys om) + sweep = if topDown then ranks else reverse ranks + adjOf v td = + if td then [ leFrom e | e <- lgEdges lg, leTo e == v ] + else [ leTo e | e <- lgEdges lg, leFrom e == v ] + dummySet = Set.fromList [ lnId n | n <- lgNodes lg, lnDummy n ] + isDum v = Set.member v dummySet + spacingFor a b = if isDum a || isDum b + then dummyMinSpacing + else minSpacing + step acc r = + let here = Map.findWithDefault [] r om + wantOf i v = + let nbs = adjOf v topDown + pxs = sort [ x | nb <- nbs, Just x <- [Map.lookup nb acc] ] + n = length pxs + in if n == 0 + then fromIntegral (i :: Int) * minSpacing + else pxs !! (n `div` 2) -- floor median + withWant = [ (v, wantOf i v) | (i, v) <- zip [0 ..] here ] + packL [] = [] + packL ((v0, x0) : rest) = + (v0, x0) : packR x0 v0 rest + packR _ _ [] = [] + packR prev prevV ((v, x) : xs) = + let x' = max x (prev + spacingFor prevV v) + in (v, x') : packR x' v xs + packed = packL withWant + in foldl' (\m (v, x) -> Map.insert v x m) acc packed + minSpacing = 1.0 :: Double + dummyMinSpacing = 0.4 :: Double -- dummy が絡む隣接は近接許可 + in foldl' step Map.empty sweep diff --git a/src/Graphics/Hgg/Easy.hs b/src/Graphics/Hgg/Easy.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Easy.hs @@ -0,0 +1,69 @@ +-- | +-- Module : Graphics.Hgg.Easy +-- Description : Layer 1 ─ 入門用 Easy API (= 値直接受け + overlay 既定) + Spec 再 export +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- 4 層 API 設計のうち **Easy 層**。 +-- grammar API (`Graphics.Hgg.Spec`) を**そのまま再 export** した上で、 +-- 「`inline` を書かずに `[Double]` を直接渡す」 専用ヘルパを足す (= 別名方式)。 +-- +-- @ +-- import Graphics.Hgg.Easy +-- import Graphics.Hgg.Quick (quickScatter) -- IO 保存は svg package 側 +-- +-- -- 1 行で散布図を保存 +-- main = quickScatter "q.svg" [1,2,3] [1,4,9] +-- +-- -- overlay を既定にした重畳 (footgun 回避: layer 包み不要) +-- fig = overlay [ points [1,2,3] [1,4,9] +-- , lineXY [1,2,3] [1,4,9] ] +-- @ +-- +-- 設計: Easy helper は 'Layer' を返す (grammar と同じ合成性)。 重畳は 'overlay' で +-- 包む (= 'scatter' '<>' 'line' の落とし穴を回避、 @design/monoid-semantics.md@ §1)。 +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Easy + ( -- * grammar API 全体 (再 export) + module Graphics.Hgg.Spec + -- * Easy 値直接受けヘルパ (= inline 不要) + , points + , lineXY + , bars + , hist + , plotY + -- * overlay (= 重畳を既定に) + , overlay + , plots + ) where + +import Graphics.Hgg.Spec + +-- | 散布図 (= 'scatter' の値直接受け版)。 @points xs ys@ は @scatter (inline xs) (inline ys)@。 +points :: [Double] -> [Double] -> Layer +points xs ys = scatter (inline xs) (inline ys) + +-- | 折れ線 (= 'line' の値直接受け版)。 +lineXY :: [Double] -> [Double] -> Layer +lineXY xs ys = line (inline xs) (inline ys) + +-- | 棒 (= 'bar' の値直接受け版)。 +bars :: [Double] -> [Double] -> Layer +bars xs ys = bar (inline xs) (inline ys) + +-- | ヒストグラム (= 'histogram' の値直接受け版)。 +hist :: [Double] -> Layer +hist xs = histogram (inline xs) + +-- | 片軸プロット: index (0,1,2,…) を x に取った散布図。 +plotY :: [Double] -> Layer +plotY ys = points (map fromIntegral [0 .. length ys - 1]) ys + +-- | layer 群を重ね合わせた 'VisualSpec' (= @foldMap layer@)。 入門者はこれで +-- 重畳を書く (`scatter <> line` の落とし穴を避ける)。 +overlay :: [Layer] -> VisualSpec +overlay = foldMap layer + +-- | 'overlay' の別名 (= 複数 plot を「並べる」 ニュアンスの短名)。 +plots :: [Layer] -> VisualSpec +plots = overlay diff --git a/src/Graphics/Hgg/Layout.hs b/src/Graphics/Hgg/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Layout.hs @@ -0,0 +1,1327 @@ +-- | +-- Module : Graphics.Hgg.Layout +-- Description : Layer 2 ─ Layout 計算 (Phase 26 §A-4 ColRef 対応版) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- 'VisualSpec' から viewport / scale / axis tick を計算する純粋関数群。 +-- col 名参照は 'Resolver' で Vector に解決した上で extent を求める。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Layout + ( Layout(..) + , ViewportSize(..) + , Rect(..) + , Scale(..) + , computeLayout + , scaleApply + -- ★ Phase 33 B3: 相対単位込み座標 'Pos' の pt 解決 (Layout の産物 = rect/scale + -- が相対単位の意味を決める ⇒ resolver は Layout 側に置く・Unit は型のみ)。 + , UCtx(..) + , resolvePosX + , resolvePosY + , niceTicks + , niceTicksLog + , extendedBreaks + , formatTicksGG + -- ★ Phase 8 A2 Step1: 描画側 (Render) と共有する margin 定数 / scale。 + , ggMarginScale + , ggHalfLine + , ggTickLen + , ggAxTextMar + , ggAxTitleMar + -- ★ Phase 35/38: 凡例メトリクス定数 + content-based 幅 (Render と共有)。 + , legendBaseSize + , legendKeyW + , legendKeyPitch + , isWideChar + , textWidthEm + , dagLabelFs + , dagNodeBaseHalfWidth + , legendGuideWidth + -- ★ Phase 38: 凡例ラベル収集 (Render/Layer から集約・予約と描画の単一情報源)。 + , numToText + , nubKeep + , findColorEnc + , effectiveLegendTitle + , allColorCategories + , LegendGuide(..) + , collectGuides + -- ★ Phase 8 C (gtable §E): 汎用 1 次元トラック割付 (ggplot gtable 忠実レイアウタの基盤)。 + , Track(..) + , solveTracks + -- ★ Phase 9 A-5: legend 配置 (PS と同一)。 予約 (computeLayout) と描画 (Render) で共有。 + , needsLegend + , effectiveLegendPos + , hasColorEncoding + -- ★ Phase 9 C: coord_flip 用の座標投影 helper (Render が共有)。 + , projectXY + , projectRectData + , projectBarRect + , catUnitPx + , resolutionOf + , AxisPlacement(..) + , coordXAxisPlacement + , coordYAxisPlacement + , coordXGridIsVertical + , coordOf + , isPolar + , polarCenter + , polarPoint + , domFrac + ) where + +import Graphics.Hgg.Layout.RangeOf (collectXY, extentsOrDefault, + histRawDomain) +import Graphics.Hgg.Palette (ggplotHue) +import Graphics.Hgg.Unit (lengthToPt, Pos (..)) +import Graphics.Hgg.Spec (AxisKind (..), AxisSpec (..), ColData (..), + DAGNode (..), DAGNodeKind (..), + ColRef, ColorEnc (..), FontSpec (..), Layer (..), + LegendPosition (..), LegendSpec (..), + MarkKind (..), Resolver, + ThemeName (..), Coord (..), + VisualSpec (..), YAxisSide (..), + applyDiscreteLimits, axisKindOf, ridgeAutoFlip, + axTickValsOf, axTickLabelsOf, axisRotateOf, distGroupRef, + compositeLanes, colRefName, + lgPosition, lyColor, lyColorCats, lyShapeBy, + lyEncX, lyEncY, lyKind, lyBinCount, + lyYAxisSide, orderedCats, resolveCol, + resolveNum, themeSeriesPalette, + HexCell (..), hexbinLayerCells) +import Graphics.Hgg.Primitive (Rect (..)) -- Phase 51: leaf へ移設・re-export +import Numeric (showFFloat) +import Data.Aeson (FromJSON, ToJSON) +import Data.List (foldl', nub, group, sort) +import Data.Monoid (First (..), Last (..), getFirst) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector (Vector) +import qualified Data.Vector as V +import GHC.Generics (Generic) + +data ViewportSize = ViewportSize { vsW :: !Int, vsH :: !Int } + deriving (Show, Eq, Generic) + +instance ToJSON ViewportSize +instance FromJSON ViewportSize + +-- Phase 51: 'Rect' は 'Graphics.Hgg.Primitive' (leaf) へ移設。 本 module は +-- import + export list で re-export し、 既存の @import Layout (Rect(..))@ を不変に保つ。 + +-- | Phase 26 §A-4: Linear のみ。 Log / Sqrt / Time / Ordinal / Band は後続。 +-- | Phase 26 §C-2 #1: PlotConfig.xLog / yLog 等価。 LinearScale に加えて +-- LogScale を追加 (= 自然対数 ln で線形化、 描画は底 10 で tick 表示)。 +data Scale + = LinearScale { lsDomainLo, lsDomainHi, lsRangeLo, lsRangeHi :: !Double } + | LogScale { lsDomainLo, lsDomainHi, lsRangeLo, lsRangeHi :: !Double } + -- | Sqrt scale (P15、 Phase 6 A6): forward = sqrt v (= 数値が非負の domain 限定、 + -- 負値は range 下端 clip)。 inverse は描画側で不要 (= tick は値域、 表示は元値)。 + | SqrtScale { lsDomainLo, lsDomainHi, lsRangeLo, lsRangeHi :: !Double } + -- | Time scale (P7、 Phase 6 A7): unix epoch (Double seconds) を Linear で扱う。 + -- tick は niceTimeTicks (= 1m / 1h / 1d / 1w / 1M / 1y candidates)。 + -- 表示 format は AxisFormat の AxisTimeFmt 経由 (= Render 側)。 + | TimeScale { lsDomainLo, lsDomainHi, lsRangeLo, lsRangeHi :: !Double } + deriving (Show, Eq) + +data Layout = Layout + { lpViewport :: !ViewportSize + , lpPlotArea :: !Rect + , lpXScale :: !Scale + , lpYScale :: !Scale + -- ★ Phase 9 C: coord_flip 用。 データ x を縦 px・データ y を横 px に写す scale。 + -- domain は lpXScale/lpYScale と同一 (= categorical ±0.6 / baseline / funnel を継承)、 + -- range のみ縦横入替。 常時算出するが Cartesian では未使用。 projectXY が参照。 + , lpXScaleFlipped :: !Scale -- データ x の domain、 range = 縦 px (Y と同じ反転 [rY+rH, rY]) + , lpYScaleFlipped :: !Scale -- データ y の domain、 range = 横 px [rX, rX+rW] + -- ★ Phase 10 A2: spec の座標系 (= coordOf spec)。 spec を持たない各 mark renderer が + -- projectXY/projectPoint で参照するため Layout に保持 (Cartesian は従来と bit 一致)。 + , lpCoord :: !Coord + -- ★ Phase 8 B22: dual Y 軸 (右側)。 vsYAxisRight が指定された / 右軸 layer が + -- ある場合のみ Just。 右軸 layer の y 値だけから独立に scale を作る (= 左軸とは + -- 別 domain)。 Nothing なら従来通り単一 Y 軸。 + , lpYScaleRight :: !(Maybe Scale) + , lpXTicks :: ![Double] + , lpYTicks :: ![Double] + , lpYTicksRight :: ![Double] -- ★ Phase 8 B22 右軸 tick (右軸無効なら []) + , lpCategoricalPalette :: ![T.Text] -- ★ P17 (= default hggMain F-3) + , lpContinuousPalette :: ![T.Text] -- ★ P17 (= default viridis5) + -- ★ Phase 11 A4-e: 色/サイズ scale 拡充 (spec 駆動、 colorVector/sizeVector が参照)。 + , lpColorManual :: ![(T.Text, T.Text)] -- scale_color_manual (空 = 無指定) + , lpColorGradient2 :: !(Maybe (T.Text, T.Text, T.Text, Double)) -- scale_color_gradient2 + , lpSizeRange :: !(Double, Double) -- scale_size range (default (3,10)) + -- ★ Phase 6+ case C-1: categorical x 軸の label (= ColTxt 由来)。 + -- 非空なら tick label として整数位置 0..n-1 の代わりにこれを使う。 + -- 空なら通常の numeric tick label。 + , lpXCategoryLabels :: ![T.Text] + , lpYCategoryLabels :: ![T.Text] + -- ★ Phase 11 A4-d: 明示 tick ラベル (= ggplot labels=)。 非空なら lpXTicks/lpYTicks と + -- 1:1 対応で formatTick を上書き。 空なら従来通り (numeric は値 format、 categorical は + -- lpXCategoryLabels)。 axTickLabels 指定時のみ非空。 + , lpXTickLabels :: ![T.Text] + , lpYTickLabels :: ![T.Text] + -- ★ Phase 8 B7: 全 histogram layer 共通の生 (pad なし) x domain (lo, hi)。 + -- render と y-range 計算が同じ bin 境界を使うため (= はみ出し防止)。 + , lpHistDomain :: !(Maybe (Double, Double)) + -- ★ Phase 8 A2 Step1: margin 縮小係数 (= ggMarginScale)。 描画オフセット + -- (tick/label/title) を computeLayout と同じ sc で算出するため Layout に保持。 + -- subplots は viewport を 0 に上書きするため viewport から再計算できない。 + , lpMarginScale :: !Double + -- ★ Phase 8 A2 Step1: 計算済み 4 辺マージン (px)。 描画 (title/軸タイトル) は + -- plotArea からこれだけ外側に配置する。 subplots panel は plotArea が cell 位置に + -- 平行移動されるが本値 (panel 自身の margin) を保持するので panel 端基準で配置できる。 + , lpMarginTop :: !Double + , lpMarginLeft :: !Double + , lpMarginBottom :: !Double + } deriving (Show, Eq) + +-- | 'VisualSpec' の全 layer から 'Resolver' で encX/encY を解決、 全 layer +-- 横断で extent を計算。 viewport は spec の width/height、 余白は固定 margin。 +computeLayout :: Resolver -> VisualSpec -> Layout +computeLayout r spec0 = + -- ★ Phase 18 A2: 離散 limits (scale{X,Y}DiscreteLimits) を先に解決 (冪等・ + -- 未指定なら完全 no-op)。 renderToPrimitives 側も同じ解決を通るので整合する。 + let spec = ridgeAutoFlip (applyDiscreteLimits r spec0) -- ★ B1c: ridge は coord_flip 自動付与 + -- ★ Phase 33 B4: layout は純 pt 空間 ([[Option 1]])。figure size を pt に解決 + -- (px 入力のみ dpi で pt 化)。既定 468×288pt = 6.5×4in (aspect 1.625・横長)。 + -- 横長はデータ図の相関構造が読みやすく R4DS 本文の chunk 比にも近い (B8 で確定)。 + -- raster backend が k=dpi/72 を掛けて device px にするのは B5 (backend 1 箇所)。 + -- dpi は px 入力解決にのみ使う。 + dpiVal = maybe 96 id (getLast (vsDpi spec)) + w = maybe 468 (lengthToPt dpiVal) (getLast (vsWidth spec)) + h = maybe 288 (lengthToPt dpiVal) (getLast (vsHeight spec)) + vp = ViewportSize (round w) (round h) + -- Phase 8 A2 Step1 (design §D): ggplot half_line マージンモデル。 固定 px (旧 + -- 60/40/40/50) を全廃し、 plot.margin(halfLine) + grob 実寸 (title/y目盛幅/tick長/ + -- 軸タイトル) を積み上げて算出。 sc は小 viewport (inset/pairs) 用の縮小係数 (下限 + -- 0.4)。 描画オフセット (Render tickMarks/labels) も同じ定数から導出する。 + sc = ggMarginScale w h + -- Phase 8 B22: 右 Y 軸がある場合は plotArea 右端を 40px 追加で空ける (= PS と同値)。 + hasRightY = case getLast (vsYAxisRight spec) of + Just _ -> True + Nothing -> any (\l -> getLast (lyYAxisSide l) == Just YAxisRight) (vsLayers spec) + rightAxisW = if hasRightY then 40 else 0 + -- フォント実寸 (spec 指定 > default)。 maxYTickW は y 目盛りラベルの最大文字幅 + -- (numeric は fmtNum で近似、 軸 format は width 推定では無視 = Step1 許容)。 + -- ★ Phase 34: 既定フォント実寸を ggplot theme_grey 較正値に合わせる + -- (Render.mkFontTS と同値。 旧 16/12/11 は margin 過大予約 → 軸タイトルが遠かった)。 + titleSize = fontSizeOf (vsTitleFont spec) 13.2 -- plot.title base×1.2 + axisLabelSize = fontSizeOf (vsAxisLabelFont spec) 11 -- axis.title base + tickSize = fontSizeOf (vsTickFont spec) 8.8 -- axis.text base×0.8 + -- 左 margin 用の y 目盛りラベル: 離散 limits (yCatLabels) > 明示ラベル + -- (axisBreaksLabeled = explicitYLabs) > numeric tick の順で採用する。 + -- (明示ラベルを測らないと長い category ラベルが軸外へ溢れる)。 + yTickLabelStrs + | not (null yCatLabels) = yCatLabels + | not (null explicitYLabs) = explicitYLabs + | otherwise = formatTicksGG yTicks + maxYTickW = if null yTickLabelStrs then 0 + else 0.6 * tickSize + * fromIntegral (maximum (map T.length yTickLabelStrs)) + hasTitle = case getLast (vsTitle spec) of Just _ -> True; _ -> False + hasXLabel = case getLast (vsXLabel spec) of Just _ -> True; _ -> False + hasYLabel = case getLast (vsYLabel spec) of Just _ -> True; _ -> False + -- ★ Phase 37 A1: subplots container は自分の軸を描かない。 軸目盛り/軸タイトル分の + -- マージン (tickLen/axTextMar/maxYTickW/軸タイトル) を予約せず、 plot.margin と + -- タイトル帯・凡例・caption のみにする (= 描画範囲を各 panel に明け渡す)。 + -- 従来は container が phantom 軸マージンを取り、 内側 panel が二重取りしていた。 + isContainer = not (null (vsSubplots spec)) + -- Phase 11 A5-a: labs (subtitle/caption/tag) の margin 予約。 未指定なら 0 で + -- 従来同一。 subtitle は top に積み増し、 caption は bottom、 tag は title/subtitle + -- が無い時のみ top (= 在る時は左寄せタグが title 帯に同居できる)。 + hasSubtitle = case getLast (vsSubtitle spec) of Just _ -> True; _ -> False + hasCaption = case getLast (vsCaption spec) of Just _ -> True; _ -> False + hasTag = case getLast (vsTag spec) of Just _ -> True; _ -> False + labsSubExtra = if hasSubtitle then 11 + sc * ggHalfLine else 0 + labsTagExtra = if hasTag && not (hasTitle || hasSubtitle) then 13 + sc * ggHalfLine else 0 + labsCapExtra = if hasCaption then 9 + sc * ggHalfLine else 0 + -- Phase 8 C (small-viewport text fix): 間隔定数 (halfLine/tickLen/axTextMar/ + -- axTitleMar) は sc 倍するが、 文字サイズ由来の項 (titleSize/tickSize/maxYTickW/ + -- axisLabelSize) は **等倍** (フォントは実寸描画で縮まないため)。 旧実装は全体を + -- sc 倍し、 小 viewport (subplots/pairs/inset) で数値が軸に被っていた。 sc=1 では + -- 新旧同値なので通常プロットは不変。 + tM = sc * ggHalfLine + (if hasTitle then titleSize + sc * ggHalfLine else 0) + + labsSubExtra + labsTagExtra + -- ★ x 目盛りラベルの回転 (axisRotate) 予約: 非回転は tickSize (従来) だが、 + -- 回転時はラベル**幅**が下方向に伸びる。 左 margin の maxYTickW と対称に、 + -- x 目盛りラベルの最大文字幅を回転角で投影して予約する (rotX=0 で従来同値)。 + xRot = axisRotateOf (vsXAxis spec) + xTickLabelStrs + | not (null xCatLabels) = xCatLabels + | not (null explicitXLabs) = explicitXLabs + | otherwise = [] -- numeric は短いので従来 tickSize 予約で足る + maxXTickW = if null xTickLabelStrs then 0 + else 0.6 * tickSize + * fromIntegral (maximum (map T.length xTickLabelStrs)) + -- Phase 50 A2: 回転 x ラベル (符号によらず rotX≠0) はラベル**幅**が下へ張り出すので、 + -- 左 margin の maxYTickW と対称に、 最大文字幅を回転角で投影して予約する + -- (rotX=0 で従来 tickSize と一致)。 ggplot の回転ラベル margin と同方針。 + xTickReserve + | xRot == 0 = tickSize + | otherwise = let rad = xRot * pi / 180 + in tickSize * abs (cos rad) + maxXTickW * abs (sin rad) + bM | isContainer = sc * ggHalfLine + legendH + labsCapExtra + | otherwise = sc * (ggHalfLine + ggTickLen + ggAxTextMar) + xTickReserve + + (if hasXLabel then sc * ggAxTitleMar + axisLabelSize else 0) + + legendH + labsCapExtra + lM | isContainer = sc * ggHalfLine + | otherwise = sc * (ggHalfLine + ggTickLen + ggAxTextMar) + maxYTickW + + (if hasYLabel then sc * ggAxTitleMar + axisLabelSize else 0) + -- Phase 9 A-5 (PS Layout と同一): 凡例ぶん plotArea を縮めて図内に収める (ggplot は + -- legend を gtable の一部として扱い panel を縮める)。 Inside/None は予約しない。 + -- ★ Phase 34: facet 時も右凡例を予約する (旧実装は facet で legendW=0 にして凡例を + -- 完全に落としていた = ggplot は facet でも凡例を出す)。 + legendPos = needsLegend spec (effectiveLegendPos (vsLegend spec)) + -- Phase 11 A5-c: nrow グリッドぶん予約を拡げる (default 1 で従来同一 = ゼロ diff)。 + -- ★ Phase 38: 右凡例は縦スタック (renderGuideBlock 単列) なので legNcol 予約は廃止。 + legNrow = max 1 (maybe 1 id (getLast (vsLegendNrow spec))) + -- ★ Phase 38: 右凡例幅を「最長ラベル」で算出 (固定 80/+70列 を撤去)。 renderGuideBlock の + -- 描画式に一致する 'legendGuideWidth' を全 guide に適用し、 縦スタックゆえ最大幅を予約。 + -- gap (panel→凡例 = 2*ggHalfLine) は renderLegendRight の x0 オフセットと一致。 + -- フォントは既定 (item=base×0.8 / title=base)。 override 無し時 render と一致 (旧固定80は + -- フォント完全無視だったので後退なし)。 + legItemF = legendBaseSize * 0.8 + legTitleF = legendBaseSize + shapeCats scr = case resolveCol r scr of + Just (TxtData v) -> orderedCats (V.toList v) + Just (NumData v) -> orderedCats (map numToText (V.toList v)) + _ -> [] + -- ★ 連続 colorbar の予約ラベルは renderGuideBlock (ColorByContinuous) の描画と + -- 同一 = Wilkinson extended breaks の範囲内 nice 値。 旧実装は生 min/mid/max を + -- 使っており、 LCG 等の長大桁データで予約幅 >> 実描画幅 になり凡例が無駄に広かった + -- (予約と描画は同一ラベル源にする不変条件・本 module 冒頭コメント参照)。 + contColorLabels cr = case resolveNum r cr of + Just nums | not (V.null nums) -> + let vMin = V.minimum nums; vMax = V.maximum nums + in case filter (\b -> b >= vMin && b <= vMax) (extendedBreaks 5 vMin vMax) of + [] -> [numToText vMin, numToText vMax] + bs -> map numToText bs + _ -> [] + guideWidth g = case g of + ColorGuide (ColorByCol _) -> + legendGuideWidth legItemF legTitleF (effectiveLegendTitle spec) (allColorCategories r (vsLayers spec)) + ColorGuide (ColorByContinuous cr) -> + legendGuideWidth legItemF legTitleF (effectiveLegendTitle spec) (contColorLabels cr) + ColorGuide (ColorStatic _) -> 0 + CountBarGuide lo hi -> + legendGuideWidth legItemF legTitleF "count" + (map numToText (filter (\b -> b >= lo && b <= hi) (extendedBreaks 5 lo hi))) + ShapeGuide scr -> + -- 見出しは render と同じく sentinel を空に潰してから幅を見積る。 + let nm = colRefName scr + t = if nm == "" || nm == "" then "" else nm + in legendGuideWidth legItemF legTitleF t (shapeCats scr) + legendGuidesW = maximum (0 : map guideWidth (collectGuides r spec)) + -- Phase 32 (re-apply): LegendRightCenter も右域に同じ幅を予約 (縦位置のみ違う)。 + legendW = if legendPos == LegendRight || legendPos == LegendRightCenter + then 2 * ggHalfLine + legendGuidesW else 0 + legendH = if legendPos == LegendBottom then 50 + fromIntegral (legNrow - 1) * 16 else 0 + rM = sc * ggHalfLine + rightAxisW + legendW + -- Phase 8 A2 Step2 (design §A-4): パネル本体は可用域 (margin を除いた残り) を取る。 + -- aspect 未指定 (Nothing) = ggplot Coord$aspect=NULL と同じく可用域を埋める。 + -- aspect 指定 (Just a, a>0) = 高/幅比 a を保つ最大 panel を可用域内に取り中央寄せ + -- (coord_fixed)。 panelW = min availW (availH/a)、 panelH = panelW*a。 + -- Phase 8 C: sc 撤廃で固定 pt margin になったため、 極小 viewport で panel が負/潰れ + -- ないよう下限を設ける (ggplot も極小時は軸が支配的になるが panel は非負)。 + -- Phase 8 C (gtable §E-2): パネル本体を solveTracks で算出。 横 = [Fixed lM, Null 1, + -- Fixed rM]、 縦 = [Fixed tM, Null 1, Fixed bM] の中央 Null トラックがパネル。 結果は + -- 従来の (lM,tM,w-lM-rM,h-tM-bM) と同値 (= 単一プロットは Null 1 個なので)。 + midTrack solve = case solve of (_ : m : _) -> m; _ -> (0, 0) + (panelX0, availW) = let (s, l) = midTrack (solveTracks 0 w [Fixed lM, Null 1, Fixed rM]) in (s, max 10 l) + (panelY0, availH) = let (s, l) = midTrack (solveTracks 0 h [Fixed tM, Null 1, Fixed bM]) in (s, max 10 l) + area = case getLast (vsAspect spec) of + Just a | a > 0 -> + let pw = min availW (availH / a) + ph = pw * a + in Rect (panelX0 + (availW - pw) / 2) (panelY0 + (availH - ph) / 2) pw ph + _ -> Rect panelX0 panelY0 availW availH + -- Phase 8 B22: 左軸 / 右軸で layer を分割。 x は全 layer 共有、 y は各軸の + -- layer のみから domain を作る (= 右軸が無ければ leftLayers == 全 layer なので + -- 従来挙動と完全一致)。 + leftLayers = filter (\l -> getLast (lyYAxisSide l) /= Just YAxisRight) (vsLayers spec) + rightLayers = filter (\l -> getLast (lyYAxisSide l) == Just YAxisRight) (vsLayers spec) + (xs, _) = collectXY r spec + (_, ys) = collectXY r spec { vsLayers = leftLayers } + (_, ysR) = collectXY r spec { vsLayers = rightLayers } + (xLo, xHi) = extentsOrDefault xs + (yLo, yHi) = extentsOrDefault ys + kindX = axisKindOf (vsXAxis spec) + kindY = axisKindOf (vsYAxis spec) + mkScale kind dLo dHi rLo rHi = case kind of + AxisLinear -> LinearScale dLo dHi rLo rHi + AxisLog -> LogScale dLo dHi rLo rHi + AxisSqrt -> SqrtScale dLo dHi rLo rHi + AxisTime -> TimeScale dLo dHi rLo rHi + -- Phase 8 C (§5 G3 + sqrt/time fix): tick は **データ範囲** (dLo,dHi) で計算し、 + -- expansion 後の範囲 (pLo,pHi) で censor (= ggplot の breaks→censor)。 linear だけ + -- でなく log/sqrt/time も同方式に統一 (time の粒度バグ = padded span/5 が 1 日を + -- 飛び越え 1 週になり tick 1 個に潰れる問題を解消)。 + mkTicks kind dLo dHi pLo pHi = + let ferr = abs (pHi - pLo) * 1e-9 + censor = filter (\t -> t >= min pLo pHi - ferr && t <= max pLo pHi + ferr) + in case kind of + AxisLinear -> censor (extendedBreaks 5 dLo dHi) + AxisLog -> censor (niceTicksLog 5 dLo dHi) + AxisSqrt -> censor (niceTicksSqrt 5 dLo dHi) + AxisTime -> censor (niceTimeTicks 5 dLo dHi) + -- categorical x labels (= ColTxt の distinct 値、 layer 横断) + -- Phase 36 B1b: distribution mark (box/violin/strip/swarm/raincloud) は群列を + -- encX が無くても colorBy 列から取る ('distGroupRef')。 scatter 等は従来どおり + -- lyEncX のみ (colorBy をカテゴリ x にしない)。 + distXAcc l = case getFirst (lyKind l) of + Just k | k `elem` [MBox, MViolin, MStrip, MSwarm, MRaincloud, MRidge] + -> Last (distGroupRef l) + _ -> lyEncX l + xCatLabelsRaw = collectCategoricalLabels distXAcc r spec (getLast (vsXDiscreteLimits spec)) + -- ★ Phase 36 D3: distCols (= 合成 Layer が複数の値列にまたがる) のとき x カテゴリは + -- 各 lane の値列名 (= 列名 slot)。 単一列 (raincloud) は対象外 (従来どおり)。 + distColsLayers = filter (\l -> length (compositeLanes l) > 1) (vsLayers spec) + isDistCols = not (null distColsLayers) + distColLabels = nub [ colRefName c | l <- distColsLayers, c <- compositeLanes l ] + -- Phase 7 A6: waterfall は末尾に合計 (Total) バーを足すため x category を 1 つ拡張。 + hasWaterfallLayer = any (\l -> getFirst (lyKind l) == Just MWaterfall) (vsLayers spec) + xCatLabels + | isDistCols = distColLabels + | hasWaterfallLayer && not (null xCatLabelsRaw) = xCatLabelsRaw ++ [T.pack "Total"] + | otherwise = xCatLabelsRaw + -- Phase 8 B23-fix: forest plot は先頭の研究を上に置くのが慣例 (= PS renderForest + -- と同方向)。 categorical y は position 0 が下端なので、 forest のときだけラベルを + -- 反転し position 0(下)= 末尾、 position n-1(上)= 先頭にする。 renderForest も + -- row i を position (n-1-i) に置く (両者で整合)。 + hasForestLayer = any (\l -> getFirst (lyKind l) == Just MForest) (vsLayers spec) + -- ★ Phase 36 B1c: ridge は群 baseline から density 山を伸ばすので、 最上段の山が + -- はみ出さないよう群カテゴリ軸 (ridge は coord_flip 済なので encX = 群) を成長方向へ + -- 1 スロット分 expand する (= ggridges の scale_y_discrete expand 相当)。 + hasRidgeLayer = any (\l -> getFirst (lyKind l) == Just MRidge) (vsLayers spec) + ridgeHeadroom = if hasRidgeLayer then 1.0 else 0.0 + yCatLabelsRaw = collectCategoricalLabels lyEncY r spec (getLast (vsYDiscreteLimits spec)) + yCatLabels = if hasForestLayer then reverse yCatLabelsRaw else yCatLabelsRaw + -- categorical の場合は range を [-0.5, n-0.5] に上書き。 + -- numeric padding は MarkKind 別 (Phase 7 A2b): + -- 0-base chart (bar / histogram / density / waterfall) のみ下端を 0 に固定し、 + -- 上端のみ 5% pad (= ggplot2 既定 expansion mult=0.05)。 それ以外 + -- (scatter / line / box / violin 等) は値が 0 でも symmetric 8% pad で軸接触を防ぐ。 + -- 旧実装は `lo == 0` を一律 0-base 判定にしていたため、 y に 0 を含む scatter 等が + -- 下軸に貼り付く副作用があった (= 値ベースの heuristic → MarkKind ベースへ)。 + layerKinds = [ k | l <- vsLayers spec, Just k <- [getFirst (lyKind l)] ] + hasYBaseline = any (`elem` [MBar, MHistogram, MDensity, MWaterfall]) layerKinds + hasXBaseline = any (`elem` [MAutocorr, MEss]) layerKinds + hasHistogram = MHistogram `elem` layerKinds + -- Phase 8 B3: funnel plot は y=SE。 SE=0 (最精密) を上端・SE 増加で下端へ置くのが + -- 慣例 (metafor::funnel)。 通常 y は反転 (lo→下/hi→上) だが、 funnel は y domain を + -- [0, maxSE+pad] とし range を非反転 (0→上端 rY, max→下端) にして上下を正す。 + hasFunnelLayer = MFunnel `elem` layerKinds + funnelYHi = let p = (yHi - yLo) * 0.05 in yHi + p + -- Phase 8 A2 Step4a (design §A-7, G1): 連続軸 expansion = ggplot 既定 mult=0.05 + -- (両側 5%)。 旧 8% から変更。 baseline (bar/hist/density/waterfall, lo==0) は + -- ggplot bar 既定 mult=c(0,0.05) と同じく下端 0 固定 + 上端のみ 5% (従来通り)。 + paddedRange baseline lo hi + | hi <= lo = (lo - 0.5, hi + 0.5) + | baseline && lo == 0 = (0, hi + (hi - lo) * 0.05) + | otherwise = let p = (hi - lo) * 0.05 in (lo - p, hi + p) + -- histogram の x 軸は ggplot 流に 5% expansion (= bin の外余白を控えめに)。 + paddedRangeX lo hi + | hi <= lo = (lo - 0.5, hi + 0.5) + | otherwise = let p = (hi - lo) * 0.05 in (lo - p, hi + p) + -- Phase 8 A2 Step4c 段階2 (design §A-7, G2): 離散軸 expansion = ggplot 既定 + -- expansion(add=0.6)。 位置 0..n-1 の両端に ±0.6 → [-0.6, (n-1)+0.6] = [-0.6, n-0.4]。 + -- 旧 ±0.5。 全 categorical geom はスケール経由 (Step4c 段階1) なので自動追従する。 + -- Phase 8 C (sqrt/log fix): sqrt/log 軸は対称 padding が domain 下端を負 + -- (sqrt) / 非正 (log) にすると scaleApply が中央 fallback して全 tick が潰れる。 + -- transformed space 相当に下端をクランプ (sqrt: ≥0、 log: >0 = データ下端の 0.9 倍)。 + clampDomKind kind dataLo (lo, hi) = case kind of + AxisSqrt -> (max 0 lo, hi) + AxisLog -> (if lo <= 0 + then (if dataLo > 0 then dataLo * 0.9 else abs hi * 1e-6) + else lo, hi) + _ -> (lo, hi) + -- Phase 11 A7-a: coord_cartesian(xlim,ylim) = データ非破棄 zoom。 numeric 軸 + -- (非 categorical・y は非 funnel) のときだけ scale domain を指定範囲に上書き。 + -- expand=FALSE 相当 (= 余白を足さず厳密に [lo,hi])。 stat は全データから計算済。 + coordXLim = getLast (vsCoordXLim spec) + coordYLim = getLast (vsCoordYLim spec) + -- ★ Phase 41: crossbar の箱 (中心 ±halfWidth の幅を x 方向に持つ) が連続 x で軸外へ + -- はみ出すのを防ぐため、 ドメインを半幅分広げる (categorical は add=0.6 で既に収まる)。 + -- 半幅 = 0.5 × markWidth(既定0.9) × resolution(x)。 errorbar の横 cap は小さく ggplot も + -- clip 任せ (scale を訓練しない) なので対象外 = crossbar のみ。 + xResData = resolutionOf [ v | v <- V.toList xs, not (isNaN v), not (isInfinite v) ] + widthGeomHalfData = + let relevant l = getFirst (lyKind l) == Just MCrossbar + halfOf l = 0.5 * maybe 0.9 id (getLast (lyMarkWidth l)) * xResData + in maximum (0 : [ halfOf l | l <- vsLayers spec, relevant l ]) + -- 箱の外縁 (xLo-half, xHi+half) を新たな「データ範囲」とみなし、 そこに連続軸既定の + -- 5% expansion を足す。 → 端の箱と軸の間に離散軸 (add=0.6) と同様の余白が出る + -- (箱がちょうど軸線に接触する窮屈さを解消)。 + widenForWidthGeom (lo, hi) + | widthGeomHalfData <= 0 = (lo, hi) + | otherwise = + let bLo = xLo - widthGeomHalfData + bHi = xHi + widthGeomHalfData + p = (bHi - bLo) * 0.05 + in (min lo (bLo - p), max hi (bHi + p)) + (xLo', xHi') = case coordXLim of + Just (a, b) | null xCatLabels -> (a, b) + _ -> if null xCatLabels + then clampDomKind kindX xLo $ widenForWidthGeom + (if hasHistogram + then paddedRangeX xLo xHi + else paddedRange hasXBaseline xLo xHi) + else (-0.6, fromIntegral (length xCatLabels) - 0.4 + ridgeHeadroom) + (yLo', yHi') = case coordYLim of + Just (a, b) | null yCatLabels && not hasFunnelLayer -> (a, b) + _ -> if null yCatLabels + then clampDomKind kindY yLo (paddedRange hasYBaseline yLo yHi) + else (-0.6, fromIntegral (length yCatLabels) - 0.4) + sx = mkScale kindX xLo' xHi' (rX area) (rX area + rW area) + -- y は通常反転 (lo→下端/hi→上端)。 funnel のみ SE=0 を上端に出すため非反転 (0→上端)。 + sy | hasFunnelLayer = mkScale kindY 0 funnelYHi (rY area) (rY area + rH area) + | otherwise = mkScale kindY yLo' yHi' (rY area + rH area) (rY area) + -- Phase 9 C: coord_flip 用 scale。 domain は sx/sy と同一 (= categorical/baseline 継承)、 + -- range のみ縦横入替。 sxF: データ x → 縦 px (Y と同じ反転で小値が下)。 + -- syF: データ y → 横 px。 funnel は flip 対象外なので非反転特例は写さない。 + sxF = mkScale kindX xLo' xHi' (rY area + rH area) (rY area) + syF = mkScale kindY yLo' yHi' (rX area) (rX area + rW area) + -- Phase 11 A4-a: 軸反転 (scale_x_reverse / scale_y_reverse)。 range を入替えるだけ。 + -- データ軸基準なので Cartesian/flip の両 scale に同じ向きで適用 (coord と独立)。 + revX = getLast (vsReverseX spec) == Just True + revY = getLast (vsReverseY spec) == Just True + applyRevX s = if revX then revScale s else s + applyRevY s = if revY then revScale s else s + -- Phase 8 B22: 右 Y 軸 scale。 右軸 layer の y 値 (ysR) だけから独立 domain。 + -- PS (findings §2 で正) に合わせ padding は付けない (extentsOrDefault そのまま)。 + kindYR = axisKindOf (vsYAxisRight spec) + (yLoR, yHiR) = extentsOrDefault ysR + syR = if hasRightY + then Just (mkScale kindYR yLoR yHiR (rY area + rH area) (rY area)) + else Nothing + yTicksR = if hasRightY then mkTicks kindYR yLoR yHiR yLoR yHiR else [] + -- 単一群の distribution mark (= 群列 (encX または colorBy) 無し box/violin/strip/ + -- swarm/raincloud layer のみ) は x tick を抑制。 Phase 36 B1b/B1c: colorBy 単体でも + -- 群分けされる ('distGroupRef') ので、 その場合は単一群扱いにせず x ラベル (群名) を出す。 + -- ★ Phase 36 D3: distCols は lane 名を x tick に出すので単一群抑制の対象外。 + isSingleGroupBoxOnly = not (null (vsLayers spec)) && not isDistCols && + all (\l -> case getFirst (lyKind l) of + Just k | k `elem` [MBox, MViolin, MStrip, MSwarm, MRaincloud] -> + case distGroupRef l of + Nothing -> True + Just _ -> False + _ -> False) (vsLayers spec) + -- ★ Phase 11 A4-d: 明示 break/label を (val,label) 対で censor し values/labels に分離。 + -- labels が空 (= breaks のみ指定) なら override label は [] にして render の formatTick に委ねる。 + explicitTicks pLo pHi vals labs = + let ferr = abs (pHi - pLo) * 1e-9 + keep t = t >= min pLo pHi - ferr && t <= max pLo pHi + ferr + in if null labs + then (filter keep vals, []) + else let kept = filter (keep . fst) + (zip vals (labs ++ repeat (T.pack ""))) + in (map fst kept, map snd kept) + explicitXVals = axTickValsOf (vsXAxis spec) + explicitXLabs = axTickLabelsOf (vsXAxis spec) + explicitYVals = axTickValsOf (vsYAxis spec) + explicitYLabs = axTickLabelsOf (vsYAxis spec) + (xTicksExp, xTickLabsExp) = explicitTicks xLo' xHi' explicitXVals explicitXLabs + (yTicksExp, yTickLabsExp) = explicitTicks yLo' yHi' explicitYVals explicitYLabs + useExplicitX = not (null explicitXVals) && null xCatLabels && not isSingleGroupBoxOnly + useExplicitY = not (null explicitYVals) && null yCatLabels && not hasFunnelLayer + -- Phase 11 A7-a: zoom 時は break 生成も zoom 範囲で行う (= データ範囲のまま + -- 生成して censor すると視野内 tick が疎になるため)。 未指定は従来 (データ範囲)。 + (xTickLo, xTickHi) = maybe (xLo, xHi) id coordXLim + (yTickLo, yTickHi) = maybe (yLo, yHi) id coordYLim + xTicks + | isSingleGroupBoxOnly = [] + | not (null xCatLabels) = map fromIntegral [0 .. length xCatLabels - 1] + | useExplicitX = xTicksExp + | otherwise = mkTicks kindX xTickLo xTickHi xLo' xHi' + yTicks + | hasFunnelLayer = mkTicks kindY 0 yHi 0 funnelYHi -- 0..maxSE (上→下) + | not (null yCatLabels) = map fromIntegral [0 .. length yCatLabels - 1] + | useExplicitY = yTicksExp + | otherwise = mkTicks kindY yTickLo yTickHi yLo' yHi' + xTickLabsOv = if useExplicitX then xTickLabsExp else [] + yTickLabsOv = if useExplicitY then yTickLabsExp else [] + -- P17: spec.palette > theme 既定 series (Phase 9 A-1: ブランドテーマは専用 series、 + -- ggplot 系 preset は従来の hggMain)。 palette 明示指定があればそれが最優先。 + themeDefaultPal = themeSeriesPalette (maybe ThemeDefault id (getLast (vsTheme spec))) + catPalRaw = maybe themeDefaultPal id (getLast (vsPalette spec)) + -- Phase 7 A6 / Phase 28: ggplot hue sentinel は群数 n で展開 (= hue_pal()(n))。 + -- 群数は (1) categorical color/fill aesthetic の水準数を最優先、 (2) 無ければ x + -- カテゴリ数 (violin/box/strip 等)、 (3) どちらも無ければ 8。 ★旧実装は連続 x + + -- 色分け (= R4DS Ch1 の散布図) で x カテゴリが空 → 常に 8 色版になり、 群数 3 でも + -- 8 色パレットの飛び石を拾って R4DS と色が食い違っていた。 + colorCatN = length (orderedCats (concat + [ V.toList v + | l <- vsLayers spec + , Just (ColorByCol cr) <- [getLast (lyColor l)] + , Just (TxtData v) <- [resolveCol r cr] ])) + catPalN | colorCatN > 0 = colorCatN + | not (null xCatLabels) = length xCatLabels + | otherwise = 8 + catPal = if catPalRaw == ["__ggplot_hue__"] + then ggplotHue catPalN + else catPalRaw + viridis5Default = ["#440154", "#3B528B", "#21918C", "#5EC962", "#FDE725"] + contPal = maybe viridis5Default id (getLast (vsContinuousPal spec)) + -- ★ Phase 11 A4-e: spec の色/サイズ scale を Layout へ (renderer が参照)。 + colorManual = maybe [] id (getLast (vsColorManual spec)) + colorGradient2 = getLast (vsColorGradient2 spec) + -- ★ Phase 34 A3: scale_size 範囲は **直径** pt (size=直径 統一)。既定 (6,20)pt + -- → 半径 3..10pt (= 旧 radius 範囲 (3,10) と同値・sizeBy 見た目を保存)。 + sizeRange = maybe (6, 20) id (getLast (vsSizeRange spec)) + in Layout + { lpViewport = vp + , lpPlotArea = area + , lpXScale = applyRevX sx + , lpYScale = applyRevY sy + , lpXScaleFlipped = applyRevX sxF + , lpYScaleFlipped = applyRevY syF + , lpCoord = coordOf spec + , lpYScaleRight = fmap applyRevY syR + , lpXTicks = xTicks + , lpYTicks = yTicks + , lpYTicksRight = yTicksR + , lpCategoricalPalette = catPal + , lpContinuousPalette = contPal + , lpColorManual = colorManual + , lpColorGradient2 = colorGradient2 + , lpSizeRange = sizeRange + , lpXCategoryLabels = xCatLabels + , lpYCategoryLabels = yCatLabels + , lpXTickLabels = xTickLabsOv + , lpYTickLabels = yTickLabsOv + , lpHistDomain = histRawDomain r (vsLayers spec) + , lpMarginScale = sc + , lpMarginTop = tM + , lpMarginLeft = lM + , lpMarginBottom = bM + } + +-- | Phase 8 C (ggplot 準拠): margin 縮小係数を撤廃 (常に 1)。 ggplot は文字・余白を +-- 固定 pt で扱い viewport サイズで縮めない (パネルが残りを埋めるだけ)。 旧実装は小 +-- viewport で sc<1 に縮小していたが、 grid は軸帯確保 (renderSubplots) で対応し、 単一 +-- 小 viewport (inset) も固定 pt で ggplot と同挙動にする。 panel が潰れないよう +-- computeLayout 側で availW/availH に下限を設ける。 シグネチャは互換のため温存。 +ggMarginScale :: Double -> Double -> Double +ggMarginScale _ _ = 1 + +-- =========================================================================== +-- Phase 8 C (gtable §E): 汎用 1 次元トラック割付 +-- =========================================================================== + +-- | gtable のトラック (行 or 列) サイズ種別。 ggplot の grid::unit に対応: +-- Fixed v = 固定 pt (= 軸テキスト/タイトル/strip/plot.margin の grob 実寸)、 +-- Null w = 伸縮トラック (= unit(w,"null")、 残りスペースを重み比で分配 = パネル本体)。 +data Track = Fixed !Double | Null !Double + deriving (Show, Eq) + +-- | Phase 8 C (§E-1): 1 次元トラック割付。 利用可能長 avail から Fixed 合計を先取りし、 +-- 残りを Null トラックに重み比で配分する (= ggplot gtable の「固定先取り → null 残り均等」)。 +-- 残りが負なら Null=0 (= パネルが潰れる、 ggplot と同挙動)。 パネル間 spacing は呼び出し側が +-- Fixed トラックとして明示挿入する。 戻り = 各トラックの (start, length) (start は absolute)。 +solveTracks :: Double -> Double -> [Track] -> [(Double, Double)] +solveTracks origin avail tracks = + let fixedSum = sum [ v | Fixed v <- tracks ] + weightSum = sum [ w | Null w <- tracks ] + remainder = max 0 (avail - fixedSum) + per = if weightSum <= 0 then 0 else remainder / weightSum + sizeOf (Fixed v) = v + sizeOf (Null w) = per * w + go _ [] = [] + go pos (t : ts) = let sz = sizeOf t in (pos, sz) : go (pos + sz) ts + in go origin tracks + +-- | Phase 8 A2 Step1 (design §D): ggplot half_line マージン定数 (pt, sc 適用前)。 +-- ★ Phase 33 B4: layout が純 pt 空間になり、これらは ggplot 由来の pt 値 (half_line= +-- base_size/2=5.5pt) そのものとして正しく pt 意味になる (値は不変・k は backend)。 +-- computeLayout の margin 計算と Render の描画オフセットで共有 (単一情報源)。 +ggHalfLine, ggTickLen, ggAxTextMar, ggAxTitleMar :: Double +ggHalfLine = 5.5 -- plot.margin 四辺 + title 下 margin +ggTickLen = 2.75 -- Phase 8 C: axis.ticks.length = half_line/2 (ggplot 忠実、 旧 5) +ggAxTextMar = 2.2 -- axis.text margin (0.8*halfLine/2) +ggAxTitleMar = 2.75 -- axis.title margin (halfLine/2) + +-- =========================================================================== +-- 凡例メトリクス (Phase 35 で導入・Phase 38 で Layout へ集約) +-- ★Layout (予約) と Render (描画) の単一情報源にするため最下層へ置く。 +-- Render/Layer は本モジュールから import する (旧: Render/Layer 内ローカル定義)。 +-- =========================================================================== + +-- | 凡例のベースフォント (pt)。 ggplot @base_size@ = 2 × half_line = 11pt。 +legendBaseSize :: Double +legendBaseSize = 2 * ggHalfLine + +-- | 凡例キーの 1 辺 (pt) = ggplot @legend.key.size = unit(1.2,"lines")@。 +-- ★R gtable トレース実測 = 17.34pt (base 11pt 時)。 grid の "lines" は行高 (= 1.2 × +-- base × lineheight) なので 1.2×base(=13.2) ではなくこの値。 = 1.2 × base × 1.3133。 +legendKeyW :: Double +legendKeyW = 1.2 * legendBaseSize * 1.3133 + +-- | 凡例キーの行ピッチ = keyW (= ggplot gtable のキー間 spacing 行 = 0pt = キーセル隣接)。 +legendKeyPitch :: Double +legendKeyPitch = legendKeyW + +-- --------------------------------------------------------------------------- +-- Phase 38: 凡例幅を「ラベル内容」に応じて算出する純関数。 +-- Layout の legendW (右予約) と Render の描画幅を**同一式**で駆動して食い違いを無くす。 +-- テキスト幅は字種別 advance 近似 ('charWidthEm'・全角=1.0em / Latin は字種別実測較正)。 +-- ★ggplot は実フォント advance で測るが、 backend 非依存・HS=PS byte parity を保つため +-- 本ライブラリは決定論的な等幅近似で一貫させる (全角を 1.0em にして日本語ラベルの +-- 過小評価=はみ出しを防ぐ・大小/はみ出し挙動を ggplot と整合)。 +-- --------------------------------------------------------------------------- + +-- | East Asian Width が全角 (F=Fullwidth / W=Wide) の文字か。 CJK 統合漢字・かな・ +-- 全角記号・ハングル等を 1.0em 扱いにする。 範囲は Unicode EAW (UAX #11) の W/F に対応する +-- 代表ブロックを網羅 (厳密 table でなく実用的な近似・凡例幅にのみ使用)。 +isWideChar :: Char -> Bool +isWideChar c = + let o = fromEnum c + in (o >= 0x1100 && o <= 0x115F) -- Hangul Jamo + || (o >= 0x2E80 && o <= 0x303E) -- CJK Radicals .. Kangxi .. CJK Symbols (一部) + || (o >= 0x3041 && o <= 0x33FF) -- Hiragana/Katakana/CJK 記号/互換等 + || (o >= 0x3400 && o <= 0x4DBF) -- CJK Ext A + || (o >= 0x4E00 && o <= 0x9FFF) -- CJK 統合漢字 + || (o >= 0xA000 && o <= 0xA4CF) -- Yi + || (o >= 0xAC00 && o <= 0xD7A3) -- Hangul 音節 + || (o >= 0xF900 && o <= 0xFAFF) -- CJK 互換漢字 + || (o >= 0xFE30 && o <= 0xFE4F) -- CJK 互換形 + || (o >= 0xFF00 && o <= 0xFF60) -- 全角 ASCII 変種 + || (o >= 0xFFE0 && o <= 0xFFE6) -- 全角記号 + || (o >= 0x1F300 && o <= 0x1FAFF) -- 絵文字 (W) + || (o >= 0x20000 && o <= 0x3FFFD) -- CJK Ext B 以降 + +-- | 1 文字の advance を em 単位で近似。 ★既定 sans (DejaVu) の実 advance を計測して +-- 字種別にバケット化 (2026-06-23・rsvg trim 実測。 例 i/l≈0.25・a/e≈0.56・M/W≈0.9)。 +-- 旧 flat 0.6 は細字主体ラベル (小文字+ハイフン等) で平均 ~0.49em/字を 0.6 と過大予約し +-- 右余白を生んでいた。 値は実測平均をやや上回る安全側に丸め 「切れない方向」 を維持。 +-- 全角は 'isWideChar' で 1.0em。 ★この表は HS=PS で完全一致させること (PS canvas も同値)。 +charWidthEm :: Char -> Double +charWidthEm c + | isWideChar c = 1.0 + | c `elem` ("iIl|.,;:'`!()[]{} " :: String) = 0.30 -- 細字・記号・空白 + | c `elem` ("jftr-/\\" :: String) = 0.42 -- やや細 + | c `elem` ("mwMW@" :: String) = 0.92 -- 幅広 + | c >= 'A' && c <= 'Z' = 0.70 -- 大文字 (M/W は上で処理済) + | otherwise = 0.58 -- 小文字・数字・その他 + +-- | 文字列の幅を em 単位で見積もる (字種別 'charWidthEm' の総和)。 実 pt 幅 = fontSize × この値。 +textWidthEm :: Text -> Double +textWidthEm = T.foldl' (\acc ch -> acc + charWidthEm ch) 0 + +-- | DAG node ラベルのフォントサイズ (pt)。 layout (Sugiyama の size-aware 横幅 +-- 見積り) と render ('nodeExtent') で共有する単一定義。 旧 Render.EdgeRoute から移管。 +dagLabelFs :: Double +dagLabelFs = 11 + +-- | DAG node の **radius 非依存** な横半幅 (px)。 = 'nodeExtent' の rx から +-- @max baseR@ の floor を除いた本体 (ラベル名 / 分布 sublabel 幅に由来)。 +-- +-- Phase 39 P8 A4-2: layout の size-aware simplex (Sugiyama 'auxSepOf' / +-- 'clusterAuxEdges') と render の 'nodeExtent' が **同一式**を共有することで、 +-- simplex が確保する node 間隔と描画箱の幅を整合させる (= 兄弟 plate の box +-- 重なりを根治)。 radius は layout 時に未知 (= render-time の lySize) ゆえ +-- floor 部分は render 側 ('nodeExtent') で適用する。 +dagNodeBaseHalfWidth :: DAGNode -> Double +dagNodeBaseHalfWidth n = + let showDist = case dnKind n of + NodeDeterministic -> False + _ -> maybe False (const True) (dnDist n) + nameEm = textWidthEm (dnLabel n) + distEm = case dnDist n of Just d | showDist -> textWidthEm d; _ -> 0 + maxEm = max 0.5 (max nameEm distEm) + in dagLabelFs * maxEm / 2 + 8 + +-- | 単一 guide (右凡例・縦1列) の必要幅 (pt)。 renderGuideBlock の描画式に厳密一致: +-- 列幅 = (key 1辺) + (key→label gap = half_line/2) + (最長ラベル幅) + (右パディング = half_line)。 +-- タイトルがそれより広ければタイトル幅。 引数: item フォント pt / title フォント pt / +-- タイトル文字列 / ラベル群。 +-- ★「最長」は文字数でなく 'textWidthEm' 最大 (全角混在で逆転し得るため幅で選ぶ)。 +legendGuideWidth :: Double -> Double -> Text -> [Text] -> Double +legendGuideWidth fItem fTitle title labels = max titleW colW + where + maxLabelEm = maximum (0 : map textWidthEm labels) + colW = legendKeyW + ggHalfLine / 2 + fItem * maxLabelEm + ggHalfLine + titleW = fTitle * textWidthEm title + +-- =========================================================================== +-- 凡例ラベル収集 (Phase 35 で導入・Phase 38 で Render/Layer から Layout へ集約)。 +-- ★Layout の legendW 予約と Render の renderGuideBlock 描画が**同一関数**でラベル文字列を +-- 得るための単一情報源。 別実装だとラベル文字列がズレ予約幅≠描画幅になる。 +-- =========================================================================== + +-- | 数値 → 表示文字列。 浮動小数点アーチファクト (0.1+0.2=0.300…04 等) を 12 桁 round で +-- 回避。 整数なら trailing zero / decimal point を除去。 (旧 Render.Common.numToText) +numToText :: Double -> Text +numToText v = + let rounded = fromIntegral (round (v * 1e12) :: Integer) / 1e12 + s = if rounded == fromIntegral (truncate rounded :: Integer) + then show (truncate rounded :: Integer) + else showFFloat Nothing rounded "" + in case T.pack s of + t -> case T.stripSuffix ".0" t of + Just t' -> t' + Nothing -> case T.stripSuffix "." t of + Just t' -> t' + Nothing -> t + +-- | 順序保存 nub (初出順)。 glyph 色 ('colorVector' の nub) / PS (Array.nub) と揃える。 +nubKeep :: [Text] -> [Text] +nubKeep = nub + +-- | 色 aesthetic を持つ最初のレイヤの ColorEnc (categorical / continuous)。 +findColorEnc :: [Layer] -> Maybe ColorEnc +findColorEnc ls = case [ ce | l <- ls + , Just ce <- [getLast (lyColor l)] + , isColorMap ce ] of + (ce : _) -> Just ce + [] -> Nothing + where + isColorMap (ColorByCol _) = True + isColorMap (ColorByContinuous _) = True + isColorMap _ = False + +-- | 明示凡例タイトル (vsLegendTitle = scale name / labs(color=))。 未指定なら ""。 +effectiveLegendTitle :: VisualSpec -> Text +effectiveLegendTitle spec = maybe "" id (getLast (vsLegendTitle spec)) + +-- | 全 ColorByCol レイヤのカテゴリを順序保存で union (= 凡例 swatch / glyph 色の正本)。 +-- 明示 'colorCats' があればそれを先頭に、 無ければデータ水準を 'orderedCats' 順で。 +allColorCategories :: Resolver -> [Layer] -> [Text] +allColorCategories r ls = + let dataCats = orderedCats $ concat + [ case resolveCol r cr of + Just (TxtData v) -> V.toList v + Just (NumData v) -> V.toList (V.map numToText v) + Nothing -> [] + | l <- ls + , Just (ColorByCol cr) <- [getLast (lyColor l)] ] + explicit = nubKeep (concatMap lyColorCats ls) + in if null explicit + then dataCats + else explicit ++ filter (`notElem` explicit) dataCats + +-- | 凡例 guide (色 / 形)。 描画 (renderGuideBlock) と予約 (legendW) が共有。 +data LegendGuide + = ColorGuide !ColorEnc -- 色 guide (categorical / continuous) + | ShapeGuide !ColRef -- 形 guide (色とは別列・または色無しのとき) + | CountBarGuide !Double !Double -- ★ Phase 40: 件数 colorbar (lo,hi)。 hexbin/bin2d-count 用 + -- (列でなく集計値ゆえ ColorByContinuous と別。 ラベル = "count") + +-- | spec から guide を ggplot 順 (color → shape) で収集。 形が色と同列なら統合し形 guide なし。 +collectGuides :: Resolver -> VisualSpec -> [LegendGuide] +collectGuides r spec = + let mEnc = findColorEnc (vsLayers spec) + colorG = maybe [] (\e -> [ColorGuide e]) mEnc + colorCol = case mEnc of + Just (ColorByCol cr) -> Just (colRefName cr) + _ -> Nothing + shapeG = case [ sc | l <- vsLayers spec, Just sc <- [getLast (lyShapeBy l)] ] of + (sc : _) | Just (colRefName sc) /= colorCol -> [ShapeGuide sc] + _ -> [] + -- ★ Phase 40: 色 enc が無い hexbin (件数) は count colorbar を出す。 + countG = case (mEnc, hexbinCountDomain r spec) of + (Nothing, Just (lo, hi)) -> [CountBarGuide lo hi] + _ -> [] + in colorG <> countG <> shapeG + +-- | Phase 40: spec 中の hexbin layer の件数域 (min,max)。 colorbar guide + needsLegend が使う。 +-- render (renderHexbin) と同じ 'hexbinLayerCells' で計算するので域が一致する。 +hexbinCountDomain :: Resolver -> VisualSpec -> Maybe (Double, Double) +hexbinCountDomain r spec = + case [ l | l <- vsLayers spec, getFirst (lyKind l) == Just MHexbin ] of + (l : _) -> case map hexCount (hexbinLayerCells r l) of + [] -> Nothing + cs -> Just (fromIntegral (minimum cs), fromIntegral (maximum cs)) + _ -> Nothing + +-- | spec の font slot から size を取り出す (未指定なら default)。 +fontSizeOf :: Last FontSpec -> Double -> Double +fontSizeOf lf def = case getLast lf of + Just fs -> maybe def id (getLast (fsSize fs)) + Nothing -> def + +-- | Phase 9 A-5 (PS Layout と同一): 凡例を実際に描画する位置 (= None なら凡例なし)。 +-- color encoding が無ければ位置指定があっても None。 予約 (computeLayout) / 描画 (Render) の +-- 両方がこれを使い、 「予約したのに描かれない / 描いたのに予約してない」 ズレを防ぐ。 +needsLegend :: VisualSpec -> LegendPosition -> LegendPosition +needsLegend spec pos + | pos == LegendNone = LegendNone + -- ★ Phase 35: 形のみ (shapeBy・色無し) でも凡例を出す (= ggplot shape guide)。 + -- ★ Phase 40: hexbin (件数 colorbar) も色 enc 無しで凡例を出す。 + | hasColorEncoding (vsLayers spec) + || hasShapeEncoding (vsLayers spec) + || hasHexbinCountGuide spec = pos + | otherwise = LegendNone + +-- | Phase 40: 色 enc を持たない hexbin layer (= 件数 colorbar 駆動) があるか (構造のみ)。 +hasHexbinCountGuide :: VisualSpec -> Bool +hasHexbinCountGuide spec = + not (hasColorEncoding (vsLayers spec)) + && any (\l -> getFirst (lyKind l) == Just MHexbin) (vsLayers spec) + +-- | layer 群に shape aesthetic (lyShapeBy) があるか。 +hasShapeEncoding :: [Layer] -> Bool +hasShapeEncoding = any (\l -> case getLast (lyShapeBy l) of + Just _ -> True + Nothing -> False) + +-- | vsLegend (Last LegendSpec) から有効 position を得る。 未指定 = LegendRight (ggplot auto)。 +effectiveLegendPos :: Last LegendSpec -> LegendPosition +effectiveLegendPos ls = case getLast ls of + Just l -> lgPosition l + Nothing -> LegendRightCenter -- Phase 43: 既定を ggplot legend.position="right" と同じ縦中央に + +-- | layer 群に color/fill aesthetic (ColorByCol / ColorByContinuous) があるか。 +hasColorEncoding :: [Layer] -> Bool +hasColorEncoding = any (\l -> case getLast (lyColor l) of + Just (ColorByCol _) -> True + Just (ColorByContinuous _) -> True + _ -> False) + +-- | Phase 34: 軸 tick ラベルを ggplot / base-R @format()@ 準拠で **ベクトル整形**する。 +-- ggplot の連続スケール既定 (@labels = waiver()@) は break ベクトル全体に base R +-- @format()@ を掛ける。 その挙動を再現: +-- +-- 1. 全 break で**小数桁を統一**する (末尾ゼロを残す)。 例 0,.25,.5 → "0.00","0.25","0.50" +-- (旧 numToText は単値ごとにゼロ削りして "0.5" になっていた)。 +-- 2. **固定小数 vs 指数**を「最大幅が短い方」で選ぶ (base R @scipen = 0@: 固定表記が +-- 指数表記より広いときだけ指数にする)。 例 density の 0..5e-4 は固定 "0.0005"(6字) > +-- 指数 "5e-04"(5字) ゆえ "0e+00".."5e-04"、 0..1 は固定 "0.50"(4字) ≤ 指数 "5e-01"(5字) +-- ゆえ "0.00".."1.00"。 +-- +-- R @ggplot_build@ 実測値と一致することを確認済 (density y / 0..1 比率 y / 3000..6000 x)。 +formatTicksGG :: [Double] -> [Text] +formatTicksGG [] = [] +formatTicksGG xs = + let dFixed = maximum (0 : map decimalsNeeded xs) + fixed = map (\v -> T.pack (showFFloat (Just dFixed) v "")) xs + dSci = maximum (0 : map (decimalsNeeded . fst . sciParts) xs) + sci = map (sciStr dSci) xs + wFixed = maximum (map T.length fixed) + wSci = maximum (map T.length sci) + in if wFixed > wSci then sci else fixed + +-- | v を誤差なく表すのに要する小数桁 (0..10)。 nice tick 前提で 10 桁上限。 +decimalsNeeded :: Double -> Int +decimalsNeeded v = go 0 + where + go k | k >= 10 = 10 + | abs (v - rounded k) <= 1e-9 * max 1 (abs v) = k + | otherwise = go (k + 1) + rounded k = let tk = 10 ^^ k :: Double + in fromIntegral (round (v * tk) :: Integer) / tk + +-- | v を仮数 m∈[1,10) と指数 e に正規化 (v = m * 10^e)。 0 は (0,0)。 +sciParts :: Double -> (Double, Int) +sciParts 0 = (0, 0) +sciParts v = + let e0 = floor (logBase 10 (abs v)) :: Int + m0 = v / (10 ^^ e0) + in norm m0 e0 + where + norm m e + | abs m >= 10 = norm (m / 10) (e + 1) + | abs m < 1 = norm (m * 10) (e - 1) + | otherwise = (m, e) + +-- | 指数表記 1 個 (仮数 d 桁 + "e±NN")。 +sciStr :: Int -> Double -> Text +sciStr d v = + let (m, e) = sciParts v + mant = showFFloat (Just d) m "" + sign = if e < 0 then "-" else "+" + ae = abs e + expt = (if ae < 10 then "0" else "") ++ show ae + in T.pack (mant ++ "e" ++ sign ++ expt) + +-- | Categorical axis labels (= ColTxt の distinct 値、 layer 横断)。 +-- どの encoding (encX / encY) を見るかは accessor 引数で指定。 +-- +-- Phase 28 (2026-06-14): 既定順を ggplot2 の factor 既定と同じ **アルファベット順** +-- ('orderedCats') にした (= R4DS と凡例・色・軸並びを一致させる)。 明示順が要るときは +-- @scale_x_discrete(limits=)@ 相当の discrete-limits override (第 4 引数) を渡す +-- (= fct_infreq / fct_reorder 相当)。 override 指定時はデータ内に在る水準だけを +-- その順で返す (applyDiscreteLimits がデータ側を既に filter/並べ替え済)。 +collectCategoricalLabels + :: (Layer -> Last ColRef) + -> Resolver -> VisualSpec -> Maybe [Text] -> [Text] +collectCategoricalLabels acc r spec mOverride = + let labels = concat + [ V.toList v + | l <- vsLayers spec + , Just cr <- [getLast (acc l)] + , Just (TxtData v) <- [resolveCol r cr] + ] + in case mOverride of + Just ws -> [ w | w <- ws, w `elem` labels ] -- 明示順 (= fct_infreq 等) + Nothing -> orderedCats labels -- 既定 = アルファベット順 + +-- | Phase 11 A4-a: scale の range (rLo/rHi) を入替えて軸反転。 domain は不変なので +-- tick (= domain 値) は scaleApply 経由で自動的に逆向き座標へ写る。 全 Scale variant が +-- lsRangeLo/lsRangeHi を共有するため record update 1 つで賄える。 +revScale :: Scale -> Scale +revScale s = s { lsRangeLo = lsRangeHi s, lsRangeHi = lsRangeLo s } + +scaleApply :: Scale -> Double -> Double +scaleApply (LinearScale dLo dHi rLo rHi) v + | dHi == dLo = (rLo + rHi) / 2 + | otherwise = rLo + (v - dLo) / (dHi - dLo) * (rHi - rLo) +scaleApply (LogScale dLo dHi rLo rHi) v + | dHi <= 0 || dLo <= 0 = (rLo + rHi) / 2 -- 不正 domain は中央 + | v <= 0 = rLo -- log 不能値は range 下端 clip + | dHi == dLo = (rLo + rHi) / 2 + | otherwise = + let lLo = log dLo; lHi = log dHi; lv = log v + in rLo + (lv - lLo) / (lHi - lLo) * (rHi - rLo) +scaleApply (SqrtScale dLo dHi rLo rHi) v + | dHi < 0 || dLo < 0 = (rLo + rHi) / 2 -- 負値 domain (= sqrt 不能) は中央 + | v < 0 = rLo -- 負値 input は range 下端 clip + | dHi == dLo = (rLo + rHi) / 2 + | otherwise = + let sLo = sqrt dLo; sHi = sqrt dHi; sv = sqrt v + in rLo + (sv - sLo) / (sHi - sLo) * (rHi - rLo) +scaleApply (TimeScale dLo dHi rLo rHi) v + -- Time scale は internal は Linear (= 値 = unix epoch seconds)。 + -- tick / 表示 format のみ別 (= 描画側で適用)。 + | dHi == dLo = (rLo + rHi) / 2 + | otherwise = rLo + (v - dLo) / (dHi - dLo) * (rHi - rLo) + +-- =========================================================================== +-- Phase 33 B3: 相対単位込み座標 'Pos' の pt 解決 +-- =========================================================================== +-- +-- native/npc の意味は panel rect / scale (= Layout の産物) が決める。よって +-- 解決は backend ではなく engine 内 (この層) で行う ([[Option 1]])。本 phase の +-- layout 出力は純 pt なので、UCtx も pt 空間で解く (dpi は PAbs の Px 入力解決だけ)。 + +-- | 'Pos' を pt 座標へ解決する context。panel rect と x/y scale を与える。 +data UCtx = UCtx + { uDpi :: !Double -- ^ PAbs の Px を pt 化する dpi。 + , uRect :: !Rect -- ^ panel rect (pt)。PNpc 解決に使う。 + , uXScale :: !Scale -- ^ PNative (x) 解決。 + , uYScale :: !Scale -- ^ PNative (y) 解決。 + } deriving (Show, Eq) + +-- | x 座標の 'Pos' を pt へ。PNpc 0=左端 (rX), 1=右端 (rX+rW)。 +resolvePosX :: UCtx -> Pos -> Double +resolvePosX c p = case p of + PAbs len -> rX (uRect c) + lengthToPt (uDpi c) len + PNpc t -> rX (uRect c) + t * rW (uRect c) + PNative v -> scaleApply (uXScale c) v + +-- | y 座標の 'Pos' を pt へ。device 座標は y 下向き (rY=上端) ゆえ +-- PNpc 1=上端 (rY), 0=下端 (rY+rH)。PNative は反転済 scale が処理。 +resolvePosY :: UCtx -> Pos -> Double +resolvePosY c p = case p of + PAbs len -> rY (uRect c) + lengthToPt (uDpi c) len + PNpc t -> rY (uRect c) + (1 - t) * rH (uRect c) + PNative v -> scaleApply (uYScale c) v + +-- =========================================================================== +-- Phase 9 C: coord_flip 用の座標投影 (= ggplot Coord の中間レイヤ) +-- =========================================================================== +-- +-- 各 renderer は `Point (sx x)(sy y)` の代わりに projectXY/projectRectData/ +-- projectBarRect を通す。 Cartesian は従来と bit 一致、 Flip は x/y を入替える。 +-- **Coord は位置だけ変換** (= テキスト anchor/font・点半径・bar 厚みは px のまま)。 + +-- | spec の座標系 (Nothing = Cartesian)。 +coordOf :: VisualSpec -> Coord +coordOf spec = maybe CoordCartesian id (getLast (vsCoord spec)) + +-- | データ空間 (dx, dy) → px (横, 縦)。 Cartesian は (sx dx, sy dy)、 Flip は +-- データ x を縦 px・データ y を横 px に (= 軸入替)。 +projectXY :: Coord -> Layout -> Double -> Double -> (Double, Double) +projectXY CoordCartesian l dx dy = + (scaleApply (lpXScale l) dx, scaleApply (lpYScale l) dy) +projectXY CoordFlip l dx dy = + (scaleApply (lpYScaleFlipped l) dy, scaleApply (lpXScaleFlipped l) dx) +-- Phase 11 A7-c: 極座標。 theta 軸 (PolarX=x / PolarY=y) を角度 (0..2π、 上始点・ +-- 時計回り)、 他軸を半径 (中心=domain 下端、 外周=domain 上端) に写す。 +projectXY CoordPolarX l dx dy = polarPoint l (domFrac (lpXScale l) dx) (domFrac (lpYScale l) dy) +projectXY CoordPolarY l dx dy = polarPoint l (domFrac (lpYScale l) dy) (domFrac (lpXScale l) dx) + +-- | scale の domain における正規化位置 [0,1] (= (v - dLo)/(dHi - dLo))。 極座標で +-- 角度/半径の比率を出すのに使う。 domain が退化していれば 0。 +domFrac :: Scale -> Double -> Double +domFrac s v = let lo = lsDomainLo s; hi = lsDomainHi s + in if hi == lo then 0 else (v - lo) / (hi - lo) + +-- | 極座標の中心と最大半径 (= panel に内接する円)。 +polarCenter :: Layout -> (Double, Double, Double) +polarCenter l = let a = lpPlotArea l + cx = rX a + rW a / 2 + cy = rY a + rH a / 2 + maxR = min (rW a) (rH a) / 2 + in (cx, cy, maxR) + +-- | (角度 frac, 半径 frac) → px。 角度 0 を上 (12 時) とし時計回り、 半径 frac=1 が外周。 +polarPoint :: Layout -> Double -> Double -> (Double, Double) +polarPoint l thetaFrac rFrac = + let (cx, cy, maxR) = polarCenter l + theta = thetaFrac * 2 * pi + r = rFrac * maxR + in (cx + r * sin theta, cy - r * cos theta) + +-- | データ空間の矩形 (x/y の min/max) → px Rect。 Flip では bbox が縦横転置される。 +-- 2 隅を projectXY して min/abs で正規化するだけ (= 向きに依らず正しい Rect)。 +projectRectData :: Coord -> Layout -> Double -> Double -> Double -> Double -> Rect +projectRectData c l xminD xmaxD yminD ymaxD = + let (x0, y0) = projectXY c l xminD yminD + (x1, y1) = projectXY c l xmaxD ymaxD + in Rect (min x0 x1) (min y0 y1) (abs (x1 - x0)) (abs (y1 - y0)) + +-- | bar/box 用: 中心線の data 座標 (centerD = x 群位置) と base..value の data 区間、 +-- 厚み thicknessPx (= px 単位の bar 幅) から px Rect を作る。 Cartesian では +-- 横位置 = centerD ± 厚み/2、 縦 = base..value。 Flip では縦位置 = centerD ± 厚み/2、 +-- 横 = base..value (= 厚みは常に px のまま = 軸スケールに依らない)。 +projectBarRect :: Coord -> Layout -> Double -> Double -> Double -> Double -> Rect +projectBarRect CoordCartesian l centerD baseD valueD thicknessPx = + let cx = scaleApply (lpXScale l) centerD + y0 = scaleApply (lpYScale l) baseD + y1 = scaleApply (lpYScale l) valueD + in Rect (cx - thicknessPx / 2) (min y0 y1) thicknessPx (abs (y1 - y0)) +projectBarRect CoordFlip l centerD baseD valueD thicknessPx = + let cy = scaleApply (lpXScaleFlipped l) centerD + x0 = scaleApply (lpYScaleFlipped l) baseD + x1 = scaleApply (lpYScaleFlipped l) valueD + in Rect (min x0 x1) (cy - thicknessPx / 2) (abs (x1 - x0)) thicknessPx +-- Phase 11 A7-c: 極座標の bar は wedge (扇形) で描くため Rect では表せない。 +-- renderBar が極座標を検出して PPath で arc を描く (= projectBarRect は使わない)。 +-- ここは totality 維持のための placeholder (Cartesian 同式・極座標 bar 経路では未使用)。 +projectBarRect CoordPolarX l centerD baseD valueD thicknessPx = + projectBarRect CoordCartesian l centerD baseD valueD thicknessPx +projectBarRect CoordPolarY l centerD baseD valueD thicknessPx = + projectBarRect CoordCartesian l centerD baseD valueD thicknessPx + +-- | Phase 10 A4-fix: categorical 1 スロットの cross 軸 px 幅 (bar/box 等の厚みに使う)。 +-- Cartesian は x 軸 (sx) の 1 単位、 Flip は category が縦に来るので flipped scale の +-- 縦 1 単位。 これを使わず常に (sx 1 - sx 0) を厚みにすると flip 時に縦スロットを超えて +-- bar が重なる。 Cartesian では (sx 1 - sx 0) と完全一致 (= ゼロ diff)。 +-- | Phase 41: ggplot @resolution(x)@ = ソート済み一意値の最小正間隔。 errorbar/crossbar の +-- cap 幅をデータ単位化する基準 (width = markWidth × resolution)。 一意値が 1 個以下なら 1 +-- (categorical = 整数位置 0,1,2… で間隔 1・単一点も 1)。 +resolutionOf :: [Double] -> Double +resolutionOf vs = + let us = map head . group . sort $ vs + gaps = filter (> 1e-12) (zipWith (-) (drop 1 us) us) + in case gaps of + [] -> 1 + gs -> minimum gs + +catUnitPx :: Coord -> Layout -> Double +catUnitPx CoordCartesian l = scaleApply (lpXScale l) 1 - scaleApply (lpXScale l) 0 +catUnitPx CoordFlip l = + abs (scaleApply (lpXScaleFlipped l) 1 - scaleApply (lpXScaleFlipped l) 0) +catUnitPx CoordPolarX l = scaleApply (lpXScale l) 1 - scaleApply (lpXScale l) 0 +catUnitPx CoordPolarY l = scaleApply (lpXScale l) 1 - scaleApply (lpXScale l) 0 + +-- | 軸が物理的にどの辺に来るか。 Cartesian: データ x=下・y=左。 Flip: データ x=左・y=下。 +-- 極座標は直交的な辺軸を持たない (Render の polar 分岐が独自に grid/軸を描く)。 +data AxisPlacement = AxisBottom | AxisLeft | AxisTop | AxisRight + deriving (Show, Eq) + +coordXAxisPlacement :: Coord -> AxisPlacement +coordXAxisPlacement CoordFlip = AxisLeft +coordXAxisPlacement _ = AxisBottom + +coordYAxisPlacement :: Coord -> AxisPlacement +coordYAxisPlacement CoordFlip = AxisBottom +coordYAxisPlacement _ = AxisLeft + +-- | データ x の grid line が縦線か (Cartesian) 横線か (Flip)。 +coordXGridIsVertical :: Coord -> Bool +coordXGridIsVertical CoordFlip = False +coordXGridIsVertical _ = True + +-- | 極座標か (= CoordPolarX / CoordPolarY)。 +isPolar :: Coord -> Bool +isPolar CoordPolarX = True +isPolar CoordPolarY = True +isPolar _ = False + +-- | D3 風 nice tick (= 1/2/5 × 10^k の刻み)。 +niceTicks :: Int -> Double -> Double -> [Double] +niceTicks n lo hi + | hi <= lo = [lo] + | n <= 0 = [] + | otherwise = + let span_ = hi - lo + rawStep = span_ / fromIntegral n + mag = 10 ** fromIntegral (floor (logBase 10 rawStep) :: Int) + norm = rawStep / mag + step + | norm < 1.5 = 1 * mag + | norm < 3.5 = 2 * mag + | norm < 7.5 = 5 * mag + | otherwise = 10 * mag + start = fromIntegral (ceiling (lo / step) :: Int) * step + go x | x > hi = [] + | otherwise = x : go (x + step) + in go start + +-- | Phase 8 C (§5 G3): R labeling::extended (Talbot, Lin & Hanrahan 2010 +-- "An Extension of Wilkinson's Algorithm…") の移植。 ggplot2 の既定 breaks +-- (`scales::extended_breaks(n)`) と同一: 候補刻み Q=[1,5,2,2.5,4,3]、 重み +-- w=[simplicity 0.25, coverage 0.2, density 0.5, legibility 0.05]、 only.loose=False、 +-- legibility は常に 1 (R 実装も placeholder)。 simplicity/coverage/density の重み付き +-- スコアを最大化する (lmin, lmax, lstep) を選び、 等間隔 break 列を返す。 +-- 入力 (dmin,dmax) は **expansion 前のデータ範囲**、 m は目標ラベル数。 旧 niceTicks +-- (1/2/5×10^k) を linear 軸で置換 (端点・本数が ggplot と一致する)。 +-- +-- j→q→k→z→start のネストループは R 実装をそのまま再現。 各段の上界 (simplicityMax / +-- densityMax / coverageMax) による枝刈りで停止するが、 浮動小数の保険として j/k/z に +-- 上限ガードを置く (実用域では枝刈りが先に効く)。 +data Best = Best + { bLmin :: !Double + , bLmax :: !Double + , bLstep :: !Double + , bScore :: !Double + } + +extendedBreaks :: Int -> Double -> Double -> [Double] +extendedBreaks m dmin0 dmax0 + | not (dmax - dmin >= eps) = [dmin] + | bScore best <= -2 = [dmin, dmax] -- 念のためのフォールバック + | otherwise = genSeq (bLmin best) (bLmax best) (bLstep best) + where + (dmin, dmax) = if dmin0 > dmax0 then (dmax0, dmin0) else (dmin0, dmax0) + eps = 2.220446049250313e-14 * 100 -- .Machine$double.eps * 100 + qs = [1, 5, 2, 2.5, 4, 3] :: [Double] + nD = 6 :: Double + mD = fromIntegral m :: Double + w1 = 0.25; w2 = 0.2; w3 = 0.5; w4 = 0.05 + qIdx q = go (1 :: Int) qs + where go i (x : xs) = if x == q then i else go (i + 1) xs + go i [] = i + fmod' a b = a - b * fromIntegral (floor (a / b) :: Integer) + simplicityMax q j = + (nD - fromIntegral (qIdx q)) / (nD - 1) + 1 - fromIntegral j + simplicity q j lmin lmax lstep = + let mlt = fmod' lmin lstep + v = if (mlt < eps || lstep - mlt < eps) && lmin <= 0 && lmax >= 0 + then 1 else 0 + in (nD - fromIntegral (qIdx q)) / (nD - 1) + v - fromIntegral j + coverage lmin lmax = + let rng = dmax - dmin + in 1 - 0.5 * ((dmax - lmax) ** 2 + (dmin - lmin) ** 2) / ((0.1 * rng) ** 2) + coverageMax spn = + let rng = dmax - dmin + in if spn > rng + then let half = (spn - rng) / 2 + in 1 - 0.5 * (half ** 2 + half ** 2) / ((0.1 * rng) ** 2) + else 1 + densityF k lmin lmax = + let r = (fromIntegral k - 1) / (lmax - lmin) + rt = (mD - 1) / (max lmax dmax - min dmin lmin) + in 2 - max (r / rt) (rt / r) + densityMax k = + if k >= m then 2 - (fromIntegral k - 1) / (mD - 1) else 1 + genSeq lo hi st + | st <= 0 = [lo] + | otherwise = let cnt = round ((hi - lo) / st) :: Int + in [ lo + fromIntegral i * st | i <- [0 .. cnt] ] + best = goJ 1 (Best 0 0 1 (-2)) + -- j ループ (skip amount)。 q ループが「全停止」 を返したら打ち切る。 + goJ j b + | j > 30 = b + | otherwise = case goQ qs j b of + (b', True) -> b' + (b', False) -> goJ (j + 1) b' + goQ [] _ b = (b, False) + goQ (q : qrest) j b = + let sm = simplicityMax q j + in if w1 * sm + w2 + w3 + w4 < bScore b + then (b, True) -- これ以降 score 改善不可 → 全停止 + else goQ qrest j (goK q sm j 2 b) + -- k ループ (tick 本数)。 + goK q sm j k b + | k > 2 * m + 6 = b + | otherwise = + let dm = densityMax k + in if w1 * sm + w2 + w3 * dm + w4 < bScore b + then b -- k ループ break + else + let delta = (dmax - dmin) / fromIntegral (k + 1) + / fromIntegral j / q + z0 = ceiling (logBase 10 delta) :: Int + in goK q sm j (k + 1) (goZ q sm j k dm (60 :: Int) z0 b) + -- z ループ (刻みの桁)。 + goZ q sm j k dm fuel z b + | fuel <= 0 = b + | otherwise = + let step = fromIntegral j * q * (10 ** fromIntegral z) + cm = coverageMax (step * fromIntegral (k - 1)) + in if w1 * sm + w2 * cm + w3 * dm + w4 < bScore b + then b -- z ループ break + else + let minStart = floor (dmax / step) * fromIntegral j + - fromIntegral ((k - 1) * j) + maxStart = ceiling (dmin / step) * fromIntegral j + b' = if minStart > maxStart + then b + else goStart q j k step minStart maxStart b + in goZ q sm j k dm (fuel - 1) (z + 1) b' + -- start ループ (label 列の起点)。 + goStart q j k step minStart maxStart b = + foldl' upd b [minStart .. maxStart] + where + unit = step / fromIntegral j + upd acc start = + let lmin = fromIntegral start * unit + lmax = lmin + step * fromIntegral (k - 1) + lstep = step + s = simplicity q j lmin lmax lstep + c = coverage lmin lmax + d = densityF k lmin lmax + score = w1 * s + w2 * c + w3 * d + w4 * 1 -- legibility = 1 + in if score > bScore acc + then Best lmin lmax lstep score + else acc + +-- | Log scale 用 tick (= 10^k グリッド)。 domain 内の整数 exponent を出す。 +niceTicksLog :: Int -> Double -> Double -> [Double] +niceTicksLog _n lo hi + | lo <= 0 || hi <= 0 || hi <= lo = [lo] + | otherwise = + let kLo = floor (logBase 10 lo) :: Int + kHi = ceiling (logBase 10 hi) :: Int + in [ 10 ** fromIntegral k | k <- [kLo .. kHi], let v = 10 ** fromIntegral k :: Double + , v >= lo, v <= hi ] + +-- | Sqrt scale 用 tick (Phase 6 A6): sqrt 後を niceTicks に通し、 二乗して戻す。 +-- domain が非負前提。 負値 lo は 0 にクランプ。 +niceTicksSqrt :: Int -> Double -> Double -> [Double] +niceTicksSqrt n lo hi + | hi <= lo = [max 0 lo] + | hi < 0 = [lo] + | otherwise = + let lo' = max 0 lo + sLo = sqrt lo' + sHi = sqrt hi + sTks = niceTicks n sLo sHi + in map (\t -> t * t) sTks + +-- | Time scale 用 tick (Phase 6 A7): unix epoch (= seconds since 1970) を入力に、 +-- 「綺麗な」 間隔 (= 1m / 1h / 1d / 1w / 1M / 1y) で tick を生成。 +-- 簡略実装: linear nice ticks を秒単位で取り、 1m / 1h / 1d / 1w 単位に丸め。 +-- 月 / 年単位の境界調整は将来。 +niceTimeTicks :: Int -> Double -> Double -> [Double] +niceTimeTicks n lo hi + | hi <= lo = [lo] + | otherwise = + let span_ = hi - lo + rawStep = span_ / fromIntegral n + -- 候補単位 (秒): 1s, 5s, 15s, 30s, 1m, 5m, 15m, 30m, 1h, 3h, 6h, 12h, 1d, 1w + candidates = + [ 1, 5, 15, 30 + , 60, 5*60, 15*60, 30*60 -- 分 + , 3600, 3*3600, 6*3600, 12*3600 -- 時 + , 86400, 7*86400 -- 日, 週 + , 30*86400, 91*86400, 365*86400 -- 月相当, 四半期, 年 + ] :: [Double] + step = head $ dropWhile (< rawStep) candidates ++ [last candidates] + start = fromIntegral (ceiling (lo / step) :: Int) * step + go x | x > hi = [] + | otherwise = x : go (x + step) + in go start diff --git a/src/Graphics/Hgg/Layout/Grid.hs b/src/Graphics/Hgg/Layout/Grid.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Layout/Grid.hs @@ -0,0 +1,126 @@ +-- | +-- Module : Graphics.Hgg.Layout.Grid +-- Description : subplots / <-> / <:> のネストを単一統一グリッドへ平坦化 (Phase 37 A2) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 37 A2: subplots / @<->@ / @<:>@ のネストを **単一の統一グリッド**へ +-- 平坦化する純関数。 patchwork 流 gtable 配置 (A3) の前段で、 任意の深さの +-- 入れ子を各 leaf パネルに @(rowStart, rowSpan, colStart, colSpan)@ を割り当てた +-- フラットなグリッドへ落とす。 描画 (Render/Layer) はこのグリッド 1 枚に対して +-- 「列ごと左右帯・行ごと上下帯」 を 1 回確保するだけになり、 ネスト境界をまたいだ +-- パネル本体の整列が保証される。 +-- +-- ★方針 (計画書 §設計): ツリーの寸法を整数グリッド単位で再帰計算する。 +-- * leaf : @w=1, h=1@ +-- * hbox (横並び) : @w=Σ child.w@, @h=max child.h@。 各 child は自分の幅 × +-- グループ高 (行) を span (縦を揃える)。 +-- * vbox (縦並び) : @h=Σ child.h@, @w=max child.w@。 各 child はグループ幅 (列) × +-- 自分の高さを span (横を揃える)。 +-- leaf を span 方向 (hbox なら縦・vbox なら横) いっぱいに伸ばすことで、 +-- @(a<->b<->c)<:>d@ の @d@ が上段 3 列を colSpan=3 で全幅 span し、 上段左端と +-- 下段左端が col0 で一致する。 +{-# LANGUAGE BangPatterns #-} + +module Graphics.Hgg.Layout.Grid + ( GridCell(..) + , GridPlacement(..) + , PTree(..) + , toPTree + , gridDims + , flattenSubplots + ) where + +import Graphics.Hgg.Spec (VisualSpec, selectedSubplots, vsSubplotCols) +import Data.List (mapAccumL) +import Data.Monoid (Last (..)) + +-- =========================================================================== +-- 型 +-- =========================================================================== + +-- | 統一グリッド上の 1 パネルの占有矩形 (整数セル単位)。 +data GridCell = GridCell + { gcRow :: !Int -- ^ 開始行 (0 始まり) + , gcRowSpan :: !Int -- ^ またぐ行数 (>= 1) + , gcCol :: !Int -- ^ 開始列 (0 始まり) + , gcColSpan :: !Int -- ^ またぐ列数 (>= 1) + } deriving (Eq, Show) + +-- | 平坦化結果。 グリッド総寸法 + leaf パネルとその占有セル。 +data GridPlacement = GridPlacement + { gpCols :: !Int -- ^ 統一グリッドの総列数 + , gpRows :: !Int -- ^ 統一グリッドの総行数 + , gpPanels :: ![(VisualSpec, GridCell)] -- ^ leaf パネル (描画対象) とセル + } + +-- | subplots ツリーの中間表現。 @<->@ は 'PH'、 @<:>@ は 'PV'、 単一プロットは 'PLeaf'。 +-- 汎用 subplots (cols が 1 でも要素数でもない wrap grid) は @PV [PH ...]@ へ正規化する。 +data PTree + = PLeaf VisualSpec + | PH [PTree] -- ^ 横並び (hconcat / @<->@) + | PV [PTree] -- ^ 縦並び (vconcat / @<:>@) + +-- =========================================================================== +-- VisualSpec → PTree +-- =========================================================================== + +-- | subplots ネストを 'PTree' へ。 cols でグループ方向を判定: +-- @cols<=1@ → 縦・@cols>=n@ → 横・それ以外 → cols 列の wrap grid (=縦に並ぶ横行)。 +-- 既定 cols は 'renderSubplots' と同じ @min n 3@ (parity 維持)。 +toPTree :: VisualSpec -> PTree +toPTree s = + case selectedSubplots s of + [] -> PLeaf s + subs -> + let n = length subs + cols = maybe (min n 3) id (getLast (vsSubplotCols s)) + kids = map toPTree subs + in if cols <= 1 then PV kids + else if cols >= n then PH kids + else PV [ PH chunk | chunk <- chunksOf cols kids ] + +-- | リストを長さ n ずつに分割 (最後は端数)。 +chunksOf :: Int -> [a] -> [[a]] +chunksOf n xs + | n <= 0 = [xs] + | null xs = [] + | otherwise = let (a, b) = splitAt n xs in a : chunksOf n b + +-- =========================================================================== +-- 寸法 (整数グリッド単位) と配置 +-- =========================================================================== + +-- | サブツリーのグリッド寸法 @(cols, rows)@。 +gridDims :: PTree -> (Int, Int) +gridDims (PLeaf _) = (1, 1) +gridDims (PH ts) = ( sum (map (fst . gridDims) ts) + , maximum (1 : map (snd . gridDims) ts) ) +gridDims (PV ts) = ( maximum (1 : map (fst . gridDims) ts) + , sum (map (snd . gridDims) ts) ) + +-- | @placeT availRows availCols row0 col0 tree@: +-- 左上 @(row0,col0)@ から @availRows × availCols@ の領域にツリーを配置し、 +-- leaf パネルとその占有セルを返す。 leaf は与えられた領域いっぱいを span する。 +placeT :: Int -> Int -> Int -> Int -> PTree -> [(VisualSpec, GridCell)] +placeT !ar !ac !r0 !c0 (PLeaf s) = + [(s, GridCell r0 ar c0 ac)] +placeT !ar _ !r0 !c0 (PH ts) = + -- 各 child は自分の幅 × グループ高 (= ar 行) を span。 列を順に消費。 + concat . snd $ mapAccumL + (\cAcc t -> let w = fst (gridDims t) + in (cAcc + w, placeT ar w r0 cAcc t)) + c0 ts +placeT _ !ac !r0 !c0 (PV ts) = + -- 各 child はグループ幅 (= ac 列) × 自分の高さ を span。 行を順に消費。 + concat . snd $ mapAccumL + (\rAcc t -> let h = snd (gridDims t) + in (rAcc + h, placeT h ac rAcc c0 t)) + r0 ts + +-- | VisualSpec の subplots ツリーを統一グリッドへ平坦化する。 +flattenSubplots :: VisualSpec -> GridPlacement +flattenSubplots s = + let t = toPTree s + (cols, rows) = gridDims t + in GridPlacement cols rows (placeT rows cols 0 0 t) diff --git a/src/Graphics/Hgg/Layout/RangeOf.hs b/src/Graphics/Hgg/Layout/RangeOf.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Layout/RangeOf.hs @@ -0,0 +1,598 @@ +-- | +-- Module : Graphics.Hgg.Layout.RangeOf +-- Description : Layer 2 ─ MarkKind 別 x/y axis range 寄与の計算 +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- 各 chart 種類 (MarkKind) は y/x domain の決め方が異なる: +-- +-- * scatter / line / errorbar / regression : encY = 値、 そのまま domain +-- * bar / waterfall : encY = 値、 domain は 0-base + max +-- * histogram / density : encY 無し、 domain は count / KDE peak +-- * box : domain は Tukey whisker 範囲 (outlier 除外) +-- * violin / strip / swarm / raincloud / ridge : encY = 値、 min-max +-- * autocorr : x = [0, maxLag]、 y = [-1, 1] +-- * ess : x = [0, nChain]、 y = [0, N/nChain] +-- +-- これらを 1 箇所 ('Graphics.Hgg.Layout' の旧 paddedRange) で吸収しようとすると +-- chart 横断の副作用が出る (Phase 7 §0)。 本 module は MarkKind 別の range 寄与を +-- 分離し、 'computeLayout' は各 layer の寄与を集めるだけにする足場を提供する。 +-- +-- Phase 7 A2a: まず既存 'Graphics.Hgg.Layout' から range 計算を「挙動不変」 で +-- 抽出 (= 出力 byte 一致)。 paddedRange 特例の除去は A2b で行う。 +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Layout.RangeOf + ( collectXY + , histogramYRange + , histRawDomain + , lagXRange + , lagYRange + , isLagAxis + , extentsOrDefault + , qqPoints + , invNormCdf + , ecdfPoints + ) where + +import Graphics.Hgg.Spec (ColData (..), ColorEnc (..), Layer (..), MarkKind (..), + Position (..), + Resolver, histBinning, lyBinCount, lyChain, lyColor, lyDensityNorm, + lyEncX, lyEncY, lyEncY2, lyErrorX, lyHistDensity, lyKind, + lyMaxLag, lyPosition, resolveCol, resolveNum, + vsLayers, VisualSpec) +import Data.List (nub, sort) +import Data.Monoid (First (..), Last (..), getFirst, getLast) +import qualified Data.Text as T +import Data.Vector (Vector) +import qualified Data.Vector as V + +-- =========================================================================== +-- 全 layer 横断の x/y range 収集 +-- =========================================================================== + +-- | 全 layer の encX / encY を resolve して連結。 +-- +-- Phase 6 A4/A5: MAutocorr / MEss は encX を「値ベクター」 として使うが、 +-- x 軸の domain は **lag** (= 0..maxLag) なので、 encX を x として使うと壊れる。 +-- 該当 mark を持つ layer は x = [0, maxLag]、 y = [-1, 1] (autocorr) or +-- y = ESS 範囲 (= encX の長さ近辺) を contribute する。 +collectXY :: Resolver -> VisualSpec -> (Vector Double, Vector Double) +collectXY r spec = + let -- ★ Phase 36 D3: 合成 Layer (base + overlay) を range 計算用に展開し、 各 overlay の値列も + -- y 範囲に含める (distCols は別列が別 slot ゆえ全列の値域和が要る)。 単一列 (raincloud) は + -- 同一列なので union 不変 = byte 不変。 + explodeOverlay l = l { lyOverlay = [] } : lyOverlay l + normalLayers = concatMap explodeOverlay (filter (not . isLagAxis) (vsLayers spec)) + lagLayers = filter isLagAxis (vsLayers spec) + -- Phase 28: histogram の x 範囲は生 encX 値ではなく **bin 外縁** を使う + -- (= sharedHistXRange)。 生値だと ggplot 流 origin (boundary=w/2) が data 下端 + -- より下から始まる / 最終 bin 端が上端を超える分だけ外側 bar がパネル外に + -- はみ出す (binwidth 大で顕著)。 y 軸が MHistogram を除外するのと同じ扱い。 + xsNormal = V.concat + [ v | l <- normalLayers + , not (isHistogram l) + , Just cr <- [getLast (lyEncX l)] + , Just v <- [resolveNum r cr] ] + -- y range は MarkKind ごとに別計算 (= box は Tukey、 density は KDE peak、 hist は count、 等) + -- - encY 経由値が意味ある chart: scatter / line / errorbar / regression 等 + -- - 自前計算: box / density / histogram / bar / waterfall (= histogramYRange に集約) + ysFromEncY l = case getFirst (lyKind l) of + Just MBox -> V.empty -- yRangeForMark (= histogramYRange) が Tukey 範囲を返す + Just MDensity -> V.empty + Just MHistogram -> V.empty + Just MBar -> V.empty + Just MWaterfall -> V.empty + Just MStream -> V.empty -- streamYRange が中心化積層 [-M/2, M/2] を返す + Just MEcdf -> V.fromList [0, 1] -- ECDF の y は確率 [0,1] (encY 無し) + _ -> case getLast (lyEncY l) of + Just cr -> maybe V.empty id (resolveNum r cr) + Nothing -> V.empty + ysNormal = V.concat (map ysFromEncY normalLayers) + -- Histogram の y 軸は count (= bins から得る)、 encY 経由ではない。 + -- MDensity / MBar / MWaterfall / MBox は従来通り layer 別。 MHistogram のみ + -- Phase 8 B7: 全 hist layer 共通 bin での maxCount を取る (= render が共通 bin で + -- 描くので range も共通 bin で計算しないと wide-form でバーが y 上端を超える)。 + nonHistY = V.concat (map (histogramYRange r) (filter (not . isHistogram) normalLayers)) + histYs = nonHistY V.++ sharedHistYRange r (filter isHistogram normalLayers) + -- Phase 11 A6-4b: linerange/pointrange/crossbar は y±err を range に含める + prYs = V.concat (map (rangeBarYRange r) normalLayers) + -- Phase 15 A8: MBand (area band) は encY=下境界 / encY2=上境界。 ysFromEncY は + -- 下境界しか拾わないので上境界を別途 range に含める (= 含めないと上側が + -- plotArea からはみ出しクリップ。 GLM の非対称 μ-CI 帯で露見)。 + bandYs = V.concat (map (bandYRange r) normalLayers) + -- Phase 52.D2: streamgraph は中心化積層なので各 x の群和の最大 M で [-M/2, M/2] + streamYs = V.concat (map (streamYRange r) normalLayers) + -- lag-axis (autocorr / ess) は x = [0, maxLag or chainCount] + -- y = [-1, 1] (autocorr) or [0, N] (ess、 簡略は N で十分) + lagXs = V.concat (map (lagXRange r) lagLayers) + lagYs = V.concat (map (lagYRange r) lagLayers) + -- Forest (Phase 8 B14): x = estimate ± error なので CI 端を range に含める + -- (= 含めないと CI 線が plotArea からはみ出す)。 中央 null line x=0 も含める。 + forestXs = V.concat (map (forestXRange r) normalLayers) + -- Q-Q plot (Phase 11 A6-2): x = 理論正規分位点 Φ⁻¹((i-0.5)/n) (列に無い算出値) + qqXs = V.concat (map (qqXRange r) normalLayers) + -- Phase 28: histogram の x 範囲 = 全 hist layer 共通 bin の外縁 (はみ出し fix) + histXs = sharedHistXRange r (filter isHistogram normalLayers) + -- nullable 列対応: NA は NaN で運ばれるので range 計算前に除く + -- (min/max が NaN で汚染されないように)。 有限データには no-op。 + finite = V.filter (not . isNaN) + xs = finite (xsNormal V.++ lagXs V.++ forestXs V.++ qqXs V.++ histXs) + ys = finite (ysNormal V.++ lagYs V.++ histYs V.++ prYs V.++ bandYs V.++ streamYs) + in (xs, ys) + +-- =========================================================================== +-- MarkKind 別 y axis range 寄与 +-- =========================================================================== + +-- | MHistogram layer か。 +isHistogram :: Layer -> Bool +isHistogram l = getFirst (lyKind l) == Just MHistogram + +-- | Phase 8 B7: 全 histogram layer 共通の生 (pad なし) x domain (lo, hi)。 +-- render (renderHistogram) と y-range 計算 (sharedHistYRange) が **同じ** bin 境界を +-- 使うための単一情報源。 これがズレると bin 幅が変わり count が食い違って +-- バーが y range を突き抜ける (Phase 8 B7 のはみ出しバグの原因)。 +histRawDomain :: Resolver -> [Layer] -> Maybe (Double, Double) +histRawDomain r histLayers = + let allXs = filter (not . isNaN) -- NA (NaN) を除く (nullable 列対応・有限には no-op) + $ concat [ V.toList v | l <- histLayers + , isHistogram l + , Just cr <- [getLast (lyEncX l)] + , Just v <- [resolveNum r cr] ] + in if null allXs then Nothing else Just (minimum allXs, maximum allXs) + +-- | Phase 8 B7: 全 histogram layer 共通 bin での maxCount を y range に。 +-- bin 境界は 'histRawDomain' (= 生 min/max) を単一情報源とし render と一致させる。 +-- density mode は count/(N*binW) に正規化。 戻り値は [0, 全層通じての maxY]。 +sharedHistYRange :: Resolver -> [Layer] -> Vector Double +sharedHistYRange r histLayers = case histRawDomain r histLayers of + Nothing -> V.empty + Just (lo, hi) -> + let xsPerLayer = [ filter (not . isNaN) (V.toList v) -- NA 除去 (render の vecOr と一致) + | l <- histLayers + , Just cr <- [getLast (lyEncX l)] + , Just v <- [resolveNum r cr] ] + isDensity l = case getLast (lyHistDensity l) of Just b -> b; Nothing -> False + -- Phase 28: bin 化は Spec.histBinning に一元化。 layer 毎に binWidth/binCount を + -- 解決し、 共有 domain (lo,hi) で counts を取る (render と同式)。 + layerMaxY l xs = + let (origin, binW, nB) = histBinning l (lo, hi) + binIx x = min (nB - 1) (max 0 (floor ((x - origin) / binW))) + cs = foldl (\acc x -> let i = binIx x + in take i acc <> [acc !! i + 1] <> drop (i+1) acc) + (replicate nB (0 :: Int)) xs + maxC = fromIntegral (maximum (0 : cs)) :: Double + totalN = fromIntegral (length xs) :: Double + in if isDensity l && totalN > 0 && binW > 0 + then maxC / (totalN * binW) + else maxC + maxY = maximum (0 : [ layerMaxY l xs | (l, xs) <- zip histLayers xsPerLayer ]) + in V.fromList [0, maxY] + +-- | Phase 28: 全 histogram layer 共通 bin の x 軸範囲 (= bin 外縁)。 +-- ggplot 流 origin (boundary = w/2) は data 下端より下から始まり、 最終 bin 端は +-- data 上端を超えうるので、 x domain を生 data min/max で取ると外側の bar が +-- パネル外にはみ出す (binwidth 大で顕著・binwidth 小でも潜在)。 render +-- (renderHistogram) と同じ 'histBinning' (共有 domain) で各 layer の +-- [origin, origin + nBin*binW] を求め、 その union を返す。 +sharedHistXRange :: Resolver -> [Layer] -> Vector Double +sharedHistXRange r histLayers = case histRawDomain r histLayers of + Nothing -> V.empty + Just (lo, hi) -> + let extents = [ (origin, origin + fromIntegral nB * binW) + | l <- histLayers + , let (origin, binW, nB) = histBinning l (lo, hi) ] + in case extents of + [] -> V.empty + _ -> V.fromList [ minimum (map fst extents) + , maximum (map snd extents) ] + +-- | MHistogram / MDensity / MBar / MWaterfall の y 軸 range 候補。 +-- bar 系 chart の bar base は y=0、 だから y domain は [0, max(value)] にする。 +-- (= matplotlib / seaborn 慣例) +histogramYRange :: Resolver -> Layer -> Vector Double +histogramYRange r l = case getFirst (lyKind l) of + -- Bar / Waterfall: encY の max + 0 を contribute (= base = 0、 上方が data max) + -- Phase 9 B: stack/fill は積み上げ後の高さで domain を取る。 fill は常に [0,1]、 + -- stack は x カテゴリごとの群和の最大値。 dodge/identity は従来 [lo, max(value)]。 + Just MBar -> + let pos = maybe PosIdentity id (getLast (lyPosition l)) + in case getLast (lyEncY l) of + Just cr -> case resolveNum r cr of + Just v | not (V.null v) -> case pos of + PosFill -> V.fromList [0, 1] + PosStack -> + let ys = V.toList v + xlabels = case getLast (lyEncX l) of + Just crX -> case resolveCol r crX of + Just (TxtData lb) -> map show (V.toList lb) + Just (NumData lb) -> map (show . (round :: Double -> Int)) (V.toList lb) + _ -> [] + Nothing -> [] + in if null xlabels + then V.fromList [0, V.maximum v] -- x ラベル無し → 単純 max + else let sums = [ sum [ y | (xl, y) <- zip xlabels ys, xl == xc ] + | xc <- nub xlabels ] + in V.fromList [0, maximum (0 : sums)] + _ -> + let mx = V.maximum v + mn = V.minimum v + -- 負値を含む場合は [min, max]、 通常は [0, max] + lo = if mn < 0 then mn else 0 + in V.fromList [lo, mx] + _ -> V.empty + Nothing -> V.empty + -- Box: encY = 値、 y domain = Tukey whisker 範囲 (outlier 除外、 matplotlib 流)。 + -- Phase 8 C (box-grouped fix): encX で群分けされる場合は **群ごと**に Tukey 髭を出し + -- その和集合を domain にする。 全群プールの髭だと高値群の髭が domain を超え枠外に + -- 出ていた (= ユーザ報告)。 renderBox も群ごとに髭を描くので両者整合。 + Just MBox -> case getLast (lyEncY l) of + Just cr -> case resolveNum r cr of + Just v | not (V.null v) -> + -- ★ NaN (= Maybe の Nothing) を群ラベルと整列したまま落とす (tukeyWhisker が + -- NaN を含むと whisker が NaN 化し値軸レンジが壊れる)。 renderBox と整合。 + let vals = V.toList v + groups = case getLast (lyEncX l) of + Just crX -> case resolveCol r crX of + Just (TxtData labels) -> + let paired = [ (lb, x) | (lb, x) <- zip (V.toList labels) vals, not (isNaN x) ] + in groupValsBy (map fst paired) (map snd paired) + Just (NumData labels) -> + let paired = [ (lb, x) | (lb, x) <- zip (map (show . (round :: Double -> Int)) (V.toList labels)) vals, not (isNaN x) ] + in groupValsBy (map fst paired) (map snd paired) + _ -> [filter (not . isNaN) vals] + Nothing -> [filter (not . isNaN) vals] + whiskersOf g = let (lo, hi) = tukeyWhisker g in [lo, hi] + in V.fromList (concatMap whiskersOf groups) + _ -> V.empty + Nothing -> V.empty + -- Violin / Strip / Swarm / Raincloud / Ridge も同じく encY = 値 + Just MViolin -> ifEncY l + Just MStrip -> ifEncY l + Just MSwarm -> ifEncY l + Just MRaincloud -> ifEncY l + Just MRidge -> ifEncY l + Just MWaterfall -> case getLast (lyEncY l) of + Just cr -> case resolveNum r cr of + Just v | not (V.null v) -> + -- waterfall は累積位置を考慮 (= scanl sum) + let xs = V.toList v + cumulative = scanl (+) 0 xs + hiW = maximum (0 : cumulative) + loW = minimum (0 : cumulative) + in V.fromList [loW, hiW] + _ -> V.empty + Nothing -> V.empty + Just MHistogram -> case getLast (lyEncX l) of + Just cr -> case resolveNum r cr of + Just v | not (V.null v) -> + let xs = V.toList v + -- Phase 28: bin 化は Spec.histBinning に一元化 (binWidth 優先)。 + (origin, binW, nB) = histBinning l (minimum xs, maximum xs) + isDensity = case getLast (lyHistDensity l) of + Just b -> b + Nothing -> False + binIx x = min (nB - 1) (max 0 (floor ((x - origin) / binW))) + counts = foldl (\acc x -> let i = binIx x + in take i acc <> [acc !! i + 1] <> drop (i+1) acc) + (replicate nB (0 :: Int)) xs + maxC :: Double + maxC = fromIntegral (maximum counts) + totalN = fromIntegral (V.length v) :: Double + maxY = if isDensity && totalN > 0 && binW > 0 + then maxC / (totalN * binW) + else maxC + in V.fromList [0, maxY] + _ -> V.empty + Nothing -> V.empty + -- Ch10 EDA (Phase 28): freqpoly は histogram と同じ bin で count を取り bin 中心を + -- 折れ線で結ぶ。 y domain = [0, max count]。 color 群分割時は群ごとに独立 bin count を + -- 取り maxY の最大を採る (= 描画 renderFreqPoly と整合・はみ出し防止)。 bin 境界は + -- 全 xs (= 群共通) で決める (ggplot geom_freqpoly 同様)。 density mode は群 N で正規化。 + Just MFreqPoly -> case getLast (lyEncX l) of + Just cr -> case resolveNum r cr of + Just v | not (V.null v) -> + let xs = V.toList v + (origin, binW, nB) = histBinning l (minimum xs, maximum xs) + isDensity = getLast (lyHistDensity l) == Just True + binIx x = min (nB - 1) (max 0 (floor ((x - origin) / binW))) + groups = case getLast (lyColor l) of + Just (ColorByCol gcr) -> + case fmap colDataKeys (resolveCol r gcr) of + Just ks | length ks == length xs -> map snd (orderedGroupsR ks xs) + _ -> [xs] + _ -> [xs] + groupMaxY g = + let cs = foldl (\acc x -> let i = binIx x + in take i acc <> [acc !! i + 1] <> drop (i+1) acc) + (replicate nB (0 :: Int)) g + maxC = fromIntegral (maximum (0 : cs)) :: Double + gN = fromIntegral (length g) :: Double + in if isDensity && gN > 0 && binW > 0 then maxC / (gN * binW) else maxC + maxY = maximum (0 : map groupMaxY groups) + in V.fromList [0, maxY] + _ -> V.empty + Nothing -> V.empty + -- Phase 8 B16: densityNorm (pairs 対角) は y 軸 = 値範囲 (= 行変数値)。 KDE は描画側で + -- panel 高さに独立正規化するので、 y range は値の min-max を返す。 + Just MDensity | getLast (lyDensityNorm l) == Just True -> + case getLast (lyEncX l) of + Just cr -> case resolveNum r cr of + Just v0 | let v = V.filter (not . isNaN) v0, not (V.null v) -> + V.fromList [V.minimum v, V.maximum v] + _ -> V.empty + Nothing -> V.empty + Just MDensity -> case getLast (lyEncX l) of + Just cr -> case resolveNum r cr of + Just v | not (V.null v) -> + -- 実 KDE を 50 grid で計算し peak を求める (= y domain = [0, peak])。 + -- 群別 density (lyColor = ColorByCol) なら各群を独立正規化して描くため、 + -- y domain は群ごとの peak の最大を採る (= はみ出し防止。 描画 renderDensity と整合)。 + -- ★ NaN (= Maybe の Nothing) は群キーと整列したまま落とす (resolveNum は NaN を含む)。 + let xsFull = V.toList v + groups = case getLast (lyColor l) of + Just (ColorByCol gcr) -> + case fmap colDataKeys (resolveCol r gcr) of + Just ks | length ks == length xsFull -> + let paired = [ (k, x) | (k, x) <- zip ks xsFull, not (isNaN x) ] + in [ [ x | (k', x) <- paired, k' == k ] | k <- nub (map fst paired) ] + _ -> [filter (not . isNaN) xsFull] + _ -> [filter (not . isNaN) xsFull] + peak = maximum (1e-12 : [ kdePeakR g | g <- groups, length g >= 2 ]) + in V.fromList [0, peak] + _ -> V.empty + Nothing -> V.empty + _ -> V.empty + where + -- ColData を群キー列 [Text] に (TxtData そのまま / NumData は show)。 + colDataKeys (TxtData vs) = V.toList vs + colDataKeys (NumData vs) = map (T.pack . show) (V.toList vs) + -- キー初出順で群化 (= Common.orderedGroups と同等・依存回避のため局所定義)。 + orderedGroupsR keys vals = + let paired = zip keys vals + in [ (k, [ x | (k', x) <- paired, k' == k ]) | k <- nub keys ] + -- 1 群分の KDE peak (= y domain の上端候補)。 Silverman bw・50 grid。 + kdePeakR xs = + let n = length xs + mu = sum xs / fromIntegral n + sd = sqrt (sum [(x - mu)^(2::Int) | x <- xs] / fromIntegral (max 1 (n - 1))) + bw = max (1.06 * sd * fromIntegral n ** (-0.2 :: Double)) 1e-9 + lo = minimum xs + hi = maximum xs + nGrid = 50 :: Int + step = if hi > lo then (hi - lo) / fromIntegral (nGrid - 1) else 1 + kdeAt x = sum [ exp (negate ((x - xi) ** 2) / (2 * bw ** 2)) + | xi <- xs ] / (fromIntegral n * bw * sqrt (2 * pi)) + in maximum [ kdeAt (lo + fromIntegral i * step) | i <- [0 .. nGrid - 1] ] + ifEncY layer = case getLast (lyEncY layer) of + Just cr -> case resolveNum r cr of + Just v | not (V.null v) -> V.fromList [V.minimum v, V.maximum v] + _ -> V.empty + Nothing -> V.empty + +-- =========================================================================== +-- lag 軸 (autocorr / ess) の x/y range 寄与 +-- =========================================================================== + +-- | autocorr / ess layer の x 軸 range 候補 (= [0, maxLag] or [0, nChain]) +lagXRange :: Resolver -> Layer -> Vector Double +lagXRange r l = case getFirst (lyKind l) of + Just MAutocorr -> + let maxLag = maybe 40 id (getLast (lyMaxLag l)) + in V.fromList [0, fromIntegral maxLag] + Just MEss -> + -- chain 列が指定されていれば distinct chain 数、 未指定なら 1 + let nChain = case getLast (lyChain l) of + Just cr -> case resolveCol r cr of + Just (TxtData v) -> length (uniqList (V.toList v)) + Just (NumData v) -> length (uniqList (V.toList v)) + Nothing -> 1 + Nothing -> 1 + in V.fromList [0, fromIntegral (max 1 nChain)] + _ -> V.empty + where + uniqList :: Eq a => [a] -> [a] + uniqList = foldr (\x acc -> if x `elem` acc then acc else x : acc) [] + +-- | autocorr / ess layer の y 軸 range 候補 +lagYRange :: Resolver -> Layer -> Vector Double +lagYRange r l = case getFirst (lyKind l) of + Just MAutocorr -> V.fromList [-1.0, 1.0] + Just MEss -> + -- ESS は理論上 [0, N] だが実用上 N/4 程度が上限 (= 強い autocorrelation で更に小)。 + -- chain 数があれば N/nChain を上限に。 + let n = case getLast (lyEncX l) of + Just cr -> case resolveNum r cr of + Just v -> V.length v + Nothing -> 1000 + Nothing -> 1000 + nChain = case getLast (lyChain l) of + Just cr -> case resolveCol r cr of + Just (TxtData v) -> max 1 (length (uniqList (V.toList v))) + Just (NumData v) -> max 1 (length (uniqList (V.toList v))) + Nothing -> 1 + Nothing -> 1 + upper = fromIntegral (n `div` nChain) + in V.fromList [0, upper] + _ -> V.empty + where + uniqList :: Eq a => [a] -> [a] + uniqList = foldr (\x acc -> if x `elem` acc then acc else x : acc) [] + +-- | Forest layer の x range 寄与 (= estimate ± error + 中央 null line x=0)。 +-- これを range に含めないと CI 線が plotArea からはみ出す (Phase 8 B14)。 +forestXRange :: Resolver -> Layer -> Vector Double +forestXRange r l = case getFirst (lyKind l) of + Just MForest -> + let ests = maybe V.empty id (getLast (lyEncX l) >>= resolveNum r) + errs = case getLast (lyErrorX l) of + Just cr -> maybe V.empty id (resolveNum r cr) + Nothing -> V.empty + los = V.zipWith (-) ests errs + his = V.zipWith (+) ests errs + in if V.null ests then V.empty + else V.fromList [0] V.++ los V.++ his -- null line x=0 も含める + _ -> V.empty + +-- | Phase 11 A6-4b: linerange / pointrange / crossbar の y 軸 range 寄与 = y ± errorY +-- (= forest の x ± err と同型)。 これが無いと区間 (y±err) が plotArea からはみ出す。 +rangeBarYRange :: Resolver -> Layer -> Vector Double +rangeBarYRange r l = case getFirst (lyKind l) of + Just k | k `elem` [MLineRange, MPointRange, MCrossbar] -> + let ys = maybe V.empty id (getLast (lyEncY l) >>= resolveNum r) + errs = case getLast (lyErrorY l) of + Just cr -> maybe V.empty id (resolveNum r cr) + Nothing -> V.empty + los = V.zipWith (-) ys errs + his = V.zipWith (+) ys errs + in if V.null ys then V.empty else los V.++ his + _ -> V.empty + +-- | Phase 15 A8: MBand (area band) の y 軸 range 寄与 = 上境界 encY2。 +-- 下境界 encY は collectXY の ysFromEncY が既に拾う。 上境界 encY2 はどこも拾わ +-- ないため、 これが無いと帯の上側が plotArea からはみ出してクリップされる +-- (GLM の非対称 μ-CI 帯で露見)。 +bandYRange :: Resolver -> Layer -> Vector Double +bandYRange r l = case getFirst (lyKind l) of + Just MBand -> + let los = maybe V.empty id (getLast (lyEncY l) >>= resolveNum r) + his = maybe V.empty id (getLast (lyEncY2 l) >>= resolveNum r) + in los V.++ his + _ -> V.empty + +-- | Phase 52.D2: streamgraph の y 軸 range 寄与。 各 x 値ごとに全系列の y を合算した +-- 総和 total(x) の最大 M を取り、 中心化 (silhouette: baseline=-Σy/2) ゆえ [-M/2, M/2] +-- を返す。 系列は color で分かれるが range には x ごとの総和だけが要る。 +streamYRange :: Resolver -> Layer -> Vector Double +streamYRange r l = case getFirst (lyKind l) of + Just MStream -> + let xs = maybe [] V.toList (getLast (lyEncX l) >>= resolveNum r) + ys = maybe [] V.toList (getLast (lyEncY l) >>= resolveNum r) + n = min (length xs) (length ys) + pts = take n (zip xs ys) + totals = [ sum [ y | (xx, y) <- pts, xx == ux ] | ux <- nub (map fst pts) ] + m = maximum (0 : totals) + in if n == 0 then V.empty else V.fromList [negate (m / 2), m / 2] + _ -> V.empty + +-- | Phase 11 A6-2: Q-Q plot の x 軸 range 寄与。 sample (encY) をソートして得る +-- order statistic に理論正規分位点 Φ⁻¹((i-0.5)/n) を割り当て、 その min/max を +-- x domain に contribute する (= 理論分位点は列に無いので forestXRange と同型で算出)。 +qqXRange :: Resolver -> Layer -> Vector Double +qqXRange r l = case getFirst (lyKind l) of + Just MQQ -> case getLast (lyEncY l) >>= resolveNum r of + Just v | not (V.null v) -> + let xs = map fst (qqPoints (V.toList v)) + in if null xs then V.empty else V.fromList [minimum xs, maximum xs] + _ -> V.empty + _ -> V.empty + +-- | Phase 11 A6-2: サンプルから Q-Q plot の点列 (理論分位点, order statistic) を作る。 +-- render と range が **同じ式** を使うための単一情報源 (= histRawDomain と同思想)。 +-- y_(i) = ソート済 sample の i 番目、 x_i = Φ⁻¹((i-0.5)/n) (= plotting position、 +-- ggplot stat_qq / R qqnorm の既定 (a=0.5 of Blom 近傍))。 +qqPoints :: [Double] -> [(Double, Double)] +qqPoints sample = + let ys = sort sample + n = length ys + in [ (invNormCdf ((fromIntegral i - 0.5) / fromIntegral n), y) + | (i, y) <- zip [(1 :: Int) ..] ys ] + +-- | Phase 11 A6-4: ECDF (= ggplot stat_ecdf) の階段ポリライン頂点。 render と x/y range が +-- 同じ式を使うための単一情報源。 右連続の階段 F(x)=#(≤x)/n を、 角点列で表す: +-- (x_1,0), (x_1,1/n), (x_2,1/n), (x_2,2/n), …, (x_n, n/n)。 空入力は []。 +ecdfPoints :: [Double] -> [(Double, Double)] +ecdfPoints sample = + let xs = sort sample + n = length xs + fn :: Int -> Double + fn i = fromIntegral i / fromIntegral n + in case xs of + [] -> [] + (x0:_) -> (x0, 0) + : concat [ (x, fn i) + : [ (xs !! i, fn i) | i < n ] -- 次の x まで水平 (最後は無し) + | (i, x) <- zip [(1 :: Int) ..] xs ] + +-- | 標準正規分布の逆累積分布関数 Φ⁻¹ (= probit / qnorm)。 Acklam の有理多項式近似 +-- (相対誤差 < 1.15e-9)。 p ∈ (0,1) を仮定 (端点は ±∞ を返すが qqPoints では (0.5/n) +-- 〜((n-0.5)/n) なので 0/1 には到達しない)。 +invNormCdf :: Double -> Double +invNormCdf p + | p <= 0 = -1 / 0 + | p >= 1 = 1 / 0 + | p < pLow = + let q = sqrt (-2 * log p) + in (((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) + / ((((d1*q+d2)*q+d3)*q+d4)*q+1) + | p <= pHigh = + let q = p - 0.5 + rr = q * q + in (((((a1*rr+a2)*rr+a3)*rr+a4)*rr+a5)*rr+a6)*q + / (((((b1*rr+b2)*rr+b3)*rr+b4)*rr+b5)*rr+1) + | otherwise = + let q = sqrt (-2 * log (1 - p)) + in -(((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) + / ((((d1*q+d2)*q+d3)*q+d4)*q+1) + where + pLow = 0.02425 + pHigh = 1 - pLow + a1 = -3.969683028665376e+01; a2 = 2.209460984245205e+02 + a3 = -2.759285104469687e+02; a4 = 1.383577518672690e+02 + a5 = -3.066479806614716e+01; a6 = 2.506628277459239e+00 + b1 = -5.447609879822406e+01; b2 = 1.615858368580409e+02 + b3 = -1.556989798598866e+02; b4 = 6.680131188771972e+01 + b5 = -1.328068155288572e+01 + c1 = -7.784894002430293e-03; c2 = -3.223964580411365e-01 + c3 = -2.400758277161838e+00; c4 = -2.549732539343734e+00 + c5 = 4.374664141464968e+00; c6 = 2.938163982698783e+00 + d1 = 7.784695709041462e-03; d2 = 3.224671290700398e-01 + d3 = 2.445134137142996e+00; d4 = 3.754408661907416e+00 + +-- | autocorr / ess は encX を「値」 としてではなく lag/chain 軸として扱う layer。 +isLagAxis :: Layer -> Bool +isLagAxis l = case getFirst (lyKind l) of + Just MAutocorr -> True + Just MEss -> True + _ -> False + +-- =========================================================================== +-- 共通 helper +-- =========================================================================== + +-- | Vector の (min, max)。 空なら default (0, 1)。 +extentsOrDefault :: Vector Double -> (Double, Double) +extentsOrDefault v + | V.null v = (0, 1) + | otherwise = (V.minimum v, V.maximum v) + +-- | Phase 8 C (box-grouped fix): ラベル列で値を群分け (出現順、 extent 用)。 +groupValsBy :: Eq a => [a] -> [Double] -> [[Double]] +groupValsBy labels vals = + let pairs = zip labels vals + uniq = foldr (\(k, _) acc -> if k `elem` acc then acc else k : acc) [] pairs + in [ [ x | (k, x) <- pairs, k == lab ] | lab <- uniq ] + +-- | Tukey 髭 (loV, hiV) = fence [Q1-1.5IQR, Q3+1.5IQR] 内の最小/最大データ点。 +-- renderBox の髭計算と同一式 (= 群ごとの箱と domain が整合)。 +tukeyWhisker :: [Double] -> (Double, Double) +tukeyWhisker xs0 = + let sorted = sort xs0 + n = length sorted + q p = + let pos = p * fromIntegral (n - 1) + lo' = floor pos :: Int + frac = pos - fromIntegral lo' + in case (atIdx sorted lo', atIdx sorted (lo' + 1)) of + (Just a, Just b) -> a + (b - a) * frac + (Just a, Nothing) -> a + _ -> 0 + atIdx xs i_ = if i_ < 0 || i_ >= length xs then Nothing else Just (xs !! i_) + q1 = q 0.25 + q3 = q 0.75 + iqr = q3 - q1 + loW = q1 - 1.5 * iqr + hiW = q3 + 1.5 * iqr + loV = case dropWhile (< loW) sorted of (x:_) -> x; [] -> q1 + hiV = case reverse (takeWhile (<= hiW) sorted) of (x:_) -> x; [] -> q3 + in (loV, hiV) diff --git a/src/Graphics/Hgg/Math/Griddata.hs b/src/Graphics/Hgg/Math/Griddata.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Math/Griddata.hs @@ -0,0 +1,146 @@ +-- | +-- Module : Graphics.Hgg.Math.Griddata +-- Description : 散布 (x,y,z) → 格子化 (Phase 24 A4・contour/surface 共用基盤) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- contour / filled contour / 3D surface が共有する「散布データの格子化」 核。 +-- +-- * 'detectGrid' — 入力が**規則 grid** (x の固有値 × y の固有値が全組存在) +-- なら補間せず**そのまま**格子に並べ替える (Phase 24 A4 バグ修正の本丸: +-- 旧実装は規則 grid 入力でも全点 IDW 再標本化して歪んでいた) +-- * 'resampleKNN' — 真の散布入力のみ **k 近傍 IDW** (逆距離加重・power 2) +-- で格子に補間する (旧実装の全点 IDW は遠方点まで重み付けされ +-- 全体平均へ潰れる + 隅に偽値が出る) +-- * 'gridOf' — 上記 2 つの自動切替 (検出成功 = 直入力、 失敗 = k 近傍補間) +-- * 'marchingSegments' / 'innerLevels' — 等高線 (isoline) 抽出核。 marching +-- squares で 1 level 分の線分群を data 座標で返す。 2D 'renderContour' と +-- 3D 床面投影 contour (Phase 24 A5) が**同一核を共有**する (parity 保全)。 +-- +-- 格子の向き規約: @zGrid !! j !! i = z(xNodes !! i, yNodes !! j)@ (行 = y)。 +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Math.Griddata + ( detectGrid + , resampleKNN + , gridOf + , marchingSegments + , innerLevels + ) where + +import Data.List (sort, sortOn) +import qualified Data.Map.Strict as Map +import qualified Data.Vector as V + +-- | 規則 grid の検出: x / y の固有値数の積が点数と一致し、 かつ全セルが +-- 埋まっていれば @Just (xNodes, yNodes, zGrid)@。 固有値は完全一致 (==) で +-- 集計する (計画格子・linspace 由来の座標は bit 一致する前提。 ノイズ入り +-- 座標は検出に落ちて 'resampleKNN' へ)。 重複座標 (反復測定) は後勝ち。 +detectGrid :: [(Double, Double, Double)] -> Maybe ([Double], [Double], [[Double]]) +detectGrid pts = + let xs = uniqSorted [x | (x, _, _) <- pts] + ys = uniqSorted [y | (_, y, _) <- pts] + m = Map.fromList [ ((x, y), z) | (x, y, z) <- pts ] + nCell = length xs * length ys + in if nCell == Map.size m && nCell > 0 + then + let rows = [ [ Map.lookup (x, y) m | x <- xs ] | y <- ys ] + in if all (all (/= Nothing)) rows + then Just (xs, ys, map (map unwrap) rows) + else Nothing + else Nothing + where + unwrap (Just v) = v + unwrap Nothing = 0 -- 到達しない (上で全 Just を確認済) + +uniqSorted :: [Double] -> [Double] +uniqSorted = dedup . sort + where + dedup (a : b : rest) | a == b = dedup (b : rest) + | otherwise = a : dedup (b : rest) + dedup xs = xs + +-- | k 近傍 IDW (逆距離加重・power 2) で nx×ny 格子に補間する。 +-- 旧実装 (全点 IDW) との違い = 各ノードで**最も近い k 点だけ**を重み付け +-- するため、 遠方の点に引っ張られて全体平均へ潰れない。 +resampleKNN :: Int -- ^ 近傍数 k (目安 8) + -> Int -- ^ x 方向ノード数 + -> Int -- ^ y 方向ノード数 + -> [(Double, Double, Double)] + -> ([Double], [Double], [[Double]]) +resampleKNN k nx ny pts = + let xLo = minimum [x | (x, _, _) <- pts]; xHi = maximum [x | (x, _, _) <- pts] + yLo = minimum [y | (_, y, _) <- pts]; yHi = maximum [y | (_, y, _) <- pts] + at lo hi n i | n <= 1 = lo + | otherwise = lo + (hi - lo) * fromIntegral i / fromIntegral (n - 1) + xNodes = [ at xLo xHi nx i | i <- [0 .. nx - 1] ] + yNodes = [ at yLo yHi ny j | j <- [0 .. ny - 1] ] + kEff = max 1 (min k (length pts)) + idw px py = + let near = take kEff (sortOn fst [ ((px-x)^(2::Int) + (py-y)^(2::Int), z) + | (x, y, z) <- pts ]) + ws = [ (1 / (d + 1e-9), z) | (d, z) <- near ] + sw = sum (map fst ws) + in sum [ w * z | (w, z) <- ws ] / sw + grid = [ [ idw px py | px <- xNodes ] | py <- yNodes ] + in (xNodes, yNodes, grid) + +-- | 自動切替: 規則 grid なら直入力 (補間なし)、 散布なら k=8 近傍 IDW で +-- n×n 格子化。 contour / filled contour / 床面投影が共有する入口。 +gridOf :: Int -- ^ 散布時の再標本ノード数 (各軸) + -> [(Double, Double, Double)] + -> ([Double], [Double], [[Double]]) +gridOf n pts = case detectGrid pts of + Just g -> g + Nothing -> resampleKNN 8 n n pts + +-- | marching squares: 1 つの等値 @level@ に対する等高線の線分群 (data 座標)。 +-- grid の向きは @grid !! j !! i = z(xNodes !! i, yNodes !! j)@ (行 = y)。 +-- セル走査順は @i (外)・j (内)@、 セル内の case 分岐は 2D 'renderContour' の +-- 旧インライン実装と完全一致 (= SVG ビット不変)。 2D contour と 3D 床面投影 +-- contour が共有する核 (Phase 24 A5)。 +marchingSegments + :: [Double] -- ^ xNodes (x 方向ノード) + -> [Double] -- ^ yNodes (y 方向ノード) + -> [[Double]] -- ^ grid (行 = y、 @grid!!j!!i@) + -> Double -- ^ level + -> [((Double, Double), (Double, Double))] +marchingSegments xNodes yNodes grid lv = + let nx = length xNodes + ny = length yNodes + xv = V.fromList xNodes + yv = V.fromList yNodes + gv = V.fromList (map V.fromList grid) + xAt i = xv V.! i + yAt j = yv V.! j + zAt i j = (gv V.! j) V.! i + cellSegs i j = + let x0 = xAt i; x1 = xAt (i+1); y0 = yAt j; y1 = yAt (j+1) + z00 = zAt i j; z10 = zAt (i+1) j + z11 = zAt (i+1) (j+1); z01 = zAt i (j+1) + b = (if z00 >= lv then 1 else 0 :: Int) + + (if z10 >= lv then 2 else 0) + + (if z11 >= lv then 4 else 0) + + (if z01 >= lv then 8 else 0) + interp a bb (ax,ay) (bx,by) = + let t = if bb == a then 0.5 else (lv - a) / (bb - a) + in (ax + t*(bx-ax), ay + t*(by-ay)) + eB = interp z00 z10 (x0,y0) (x1,y0) -- bottom + eR = interp z10 z11 (x1,y0) (x1,y1) -- right + eT = interp z01 z11 (x0,y1) (x1,y1) -- top + eL = interp z00 z01 (x0,y0) (x0,y1) -- left + in case b of + 1 -> [(eL,eB)]; 2 -> [(eB,eR)]; 3 -> [(eL,eR)] + 4 -> [(eR,eT)]; 5 -> [(eL,eT),(eB,eR)] + 6 -> [(eB,eT)]; 7 -> [(eL,eT)]; 8 -> [(eT,eL)] + 9 -> [(eT,eB)]; 10 -> [(eL,eB),(eT,eR)]; 11 -> [(eT,eR)] + 12 -> [(eL,eR)]; 13 -> [(eB,eR)]; 14 -> [(eL,eB)] + _ -> [] + in [ seg | i <- [0 .. nx - 2], j <- [0 .. ny - 2], seg <- cellSegs i j ] + +-- | 既定の等高線レベル: @(zmin, zmax)@ の**内側等間隔** @lv_k = zmin + +-- (zmax-zmin)·k/(n+1)@ (k = 1..n)。 端値ちょうどの退化等値線を避ける。 +-- 2D 'contourLevelsFor' の既定枝と 3D 床面投影が共有 (Phase 24 A5)。 +innerLevels :: Int -> Double -> Double -> [Double] +innerLevels nLev zmin zmax = + [ zmin + (zmax - zmin) * fromIntegral k / fromIntegral (nLev + 1) + | k <- [1 .. max 1 nLev] ] diff --git a/src/Graphics/Hgg/Math/Special.hs b/src/Graphics/Hgg/Math/Special.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Math/Special.hs @@ -0,0 +1,109 @@ +-- | +-- Module : Graphics.Hgg.Math.Special +-- Description : 特殊関数 (log-gamma / 正則化不完全ベータ / ベータ分位点) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- backend 非依存の数値特殊関数。 確率プロットの厳密 rank-based CI +-- (順序統計量 U_(i) ~ Beta(i, n-i+1)) などで必要になる: +-- +-- * 'logGamma' : ln Γ(x) (Lanczos 近似、 x > 0) +-- * 'regIncompleteBeta' : 正則化不完全ベータ I_x(a,b) (連分数 / Lentz 法) +-- * 'betaQuantile' : I_x(a,b) = q を満たす x (二分法による逆関数) +-- +-- アルゴリズムは Numerical Recipes の @gammln@ / @betai@ / @betacf@ に準ずる。 +-- core 内に他の特殊関数 (invNormCdf) は 'Graphics.Hgg.Layout.RangeOf' にあるが、 +-- ベータ系はサイズが大きいので本 module に分離する。 +module Graphics.Hgg.Math.Special + ( logGamma + , regIncompleteBeta + , betaQuantile + ) where + +-- =========================================================================== +-- log-gamma (Lanczos 近似、 g=5 / 6 係数) +-- =========================================================================== + +-- | ln Γ(x) (x > 0 を仮定)。 相対誤差 < 2e-10。 +-- Numerical Recipes @gammln@ と同一係数 (Lanczos, g=5)。 +logGamma :: Double -> Double +logGamma x = + let tmp0 = x + 5.5 + tmp = tmp0 - (x + 0.5) * log tmp0 + ser = 1.000000000190015 + + sum [ c / (x + fromIntegral j) | (j, c) <- zip [(1 :: Int) ..] cof ] + in -tmp + log (2.5066282746310005 * ser / x) + where + cof = [ 76.18009172947146, -86.50532032941677 + , 24.01409824083091, -1.231739572450155 + , 0.1208650973866179e-2, -0.5395239384953e-5 ] + +-- =========================================================================== +-- 正則化不完全ベータ I_x(a,b) +-- =========================================================================== + +-- | 正則化不完全ベータ関数 I_x(a,b) = B(x;a,b) / B(a,b) ∈ [0,1]。 +-- a,b > 0、 x ∈ [0,1]。 x < (a+1)/(a+b+2) で連分数を直接、 それ以外は +-- 対称性 I_x(a,b) = 1 - I_{1-x}(b,a) を使い収束を確保する。 +regIncompleteBeta :: Double -> Double -> Double -> Double +regIncompleteBeta a b x + | x <= 0 = 0 + | x >= 1 = 1 + | otherwise = + let bt = exp ( logGamma (a + b) - logGamma a - logGamma b + + a * log x + b * log (1 - x) ) + in if x < (a + 1) / (a + b + 2) + then bt * betacf a b x / a + else 1 - bt * betacf b a (1 - x) / b + +-- | I_x(a,b) の連分数展開 (Lentz の修正法)。 NR @betacf@ と同型。 +betacf :: Double -> Double -> Double -> Double +betacf a b x = go 1 h0 c0 d0 + where + fpmin = 1e-30 + eps = 3e-12 + maxit = 300 :: Int + qab = a + b + qap = a + 1 + qam = a - 1 + fix v = if abs v < fpmin then fpmin else v + d0 = 1 / fix (1 - qab * x / qap) + c0 = 1 + h0 = d0 + go m h c d + | m > maxit = h + | abs (del - 1) < eps = h2 + | otherwise = go (m + 1) h2 c2 d2 + where + m2 = fromIntegral (2 * m) :: Double + fm = fromIntegral m :: Double + -- 偶数ステップ + aa1 = fm * (b - fm) * x / ((qam + m2) * (a + m2)) + d1 = 1 / fix (1 + aa1 * d) + c1 = fix (1 + aa1 / c) + h1 = h * d1 * c1 + -- 奇数ステップ + aa2 = negate (a + fm) * (qab + fm) * x / ((a + m2) * (qap + m2)) + d2 = 1 / fix (1 + aa2 * d1) + c2 = fix (1 + aa2 / c1) + del = d2 * c2 + h2 = h1 * del + +-- =========================================================================== +-- ベータ分位点 (I_x(a,b) = q の逆関数) +-- =========================================================================== + +-- | I_x(a,b) = q を満たす x ∈ [0,1] を二分法で求める (= Beta(a,b) の q 分位点)。 +-- 'regIncompleteBeta' は x について単調増加なので二分法が確実に収束する。 +-- 80 反復で区間幅は 2^-80 (≈ 1e-24) になり double 精度では完全収束。 +betaQuantile :: Double -> Double -> Double -> Double +betaQuantile q a b + | q <= 0 = 0 + | q >= 1 = 1 + | otherwise = bisect 0 1 (80 :: Int) + where + bisect lo hi n + | n <= 0 = mid + | regIncompleteBeta a b mid < q = bisect mid hi (n - 1) + | otherwise = bisect lo mid (n - 1) + where mid = (lo + hi) / 2 diff --git a/src/Graphics/Hgg/Palette.hs b/src/Graphics/Hgg/Palette.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Palette.hs @@ -0,0 +1,295 @@ +-- | +-- Module : Graphics.Hgg.Palette +-- Description : Categorical / Sequential / Diverging palette カタログ +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- P17 (2026-05-26 改訂): +-- * default `hggMain` = F-3 Balanced Mix (= 中程度彩度で重み均等) +-- * sub `hggPastel` = F-2 Pastel Mix (= 淡色 secondary) +-- * 全色は 7 キャラ設定画 Color Palette セクションの公式 hex +{-# LANGUAGE OverloadedStrings #-} + +module Graphics.Hgg.Palette + ( CategoricalPalette + , SequentialPalette + , DivergingPalette + , okabeIto + , viridis5 + , spotfire -- 標準 UI default palette + , hggMain -- F-3 (default) + , hggMainVivid -- F-1 + , hggPastel -- F-2 + , ggplotHue -- ggplot2 hue_pal (= n 依存 HCL 等間隔) + , hggExtended + , whiteRabbit + , cheshireCat + , dormouse + , marchHare + , queenOfHearts + , whiteQueen + , redQueen + , whiteRabbitSeq + , cheshireCatSeq + , dormouseSeq + , marchHareSeq + , queenOfHeartsSeq + , whiteQueenSeq + , redQueenSeq + , hggBlueSeq + , hggRedSeq + , hggGoldSeq + , hggSageSeq + , hggSiennaSeq + , hggPurpleSeq + , hggRoseSeq + , hggDivQueens + , hggDivYellowPurple + , hggDivPinkGreen + , hggCyclical5 + , hggWarn + , hggHighlight + , hggSuccess + , hggInfo + -- * ColorBrewer 2.0 palette (Phase 6 A9、 P17) + -- $colorbrewer + -- ** Categorical (qualitative) + , brewerSet1 + , brewerSet2 + , brewerSet3 + , brewerPaired + , brewerDark2 + -- ** Diverging + , brewerRdYlBu + , brewerRdBu + , brewerSpectral + , brewerPuOr + , brewerBrBG + , brewerRdGy + , brewerPiYG + ) where + +import Data.Text (Text) + +type CategoricalPalette = [Text] +type SequentialPalette = [Text] +type DivergingPalette = [Text] + +okabeIto :: CategoricalPalette +okabeIto = + [ "#E69F00", "#56B4E9", "#009E73", "#F0E442" + , "#0072B2", "#D55E00", "#CC79A7", "#000000" ] + +viridis5 :: SequentialPalette +viridis5 = ["#440154", "#3B528B", "#21918C", "#5EC962", "#FDE725"] + +-- | Spotfire 風 (= 標準 UI default colorPalette と一致)。 +spotfire :: CategoricalPalette +spotfire = + [ "#93c5fd", "#fca5a5", "#fde047", "#86efac", "#f9a8d4" + , "#67e8f9", "#fdba74", "#e5e5e5" + , "#2563eb", "#dc2626", "#ca8a04", "#16a34a" + , "#db2777", "#0891b2", "#ea580c" + ] + +-- ★ F-3 Balanced (default) +hggMain :: CategoricalPalette +hggMain = + [ "#C9A968", "#7A5C92", "#B79DB8", "#3E6A6F" + , "#C7445D", "#B8C7D9", "#7E1F23" ] + +-- F-1 Vivid Main +hggMainVivid :: CategoricalPalette +hggMainVivid = + [ "#C9A968", "#5B2E7C", "#8A6B4F", "#2A4E54" + , "#A61E2A", "#C7D7E6", "#5D0F12" ] + +-- ★ F-2 Pastel Mix +hggPastel :: CategoricalPalette +hggPastel = + [ "#F0A5A0", "#C0B8E6", "#B79DB8", "#A7D7DE" + , "#D7A1A6", "#C7D7E6", "#A45353" ] + +-- | ggplot2 既定 discrete パレット (= @scales::hue_pal()@)。 +-- HCL 色空間で等間隔 hue (L=65, C=100, hue = seq(15,375,length=n+1)[1:n])。 +-- 色数 n に依存して hue が再配分されるため、 R @hue_pal()(n)@ の出力を n=1..8 で +-- テーブル化 (= 実行時 HCL→sRGB 変換を避ける)。 n>8 は 8 色版を循環、 n<1 は 8 色版。 +ggplotHue :: Int -> CategoricalPalette +ggplotHue n + | n <= 0 = ggplotHue8 + | n == 1 = ["#F8766D"] + | n == 2 = ["#F8766D", "#00BFC4"] + | n == 3 = ["#F8766D", "#00BA38", "#619CFF"] + | n == 4 = ["#F8766D", "#7CAE00", "#00BFC4", "#C77CFF"] + | n == 5 = ["#F8766D", "#A3A500", "#00BF7D", "#00B0F6", "#E76BF3"] + | n == 6 = ["#F8766D", "#B79F00", "#00BA38", "#00BFC4", "#619CFF", "#F564E3"] + | n == 7 = ["#F8766D", "#C49A00", "#53B400", "#00C094", "#00B6EB", "#A58AFF", "#FB61D7"] + | n == 8 = ggplotHue8 + | otherwise = take n (cycle ggplotHue8) + where + ggplotHue8 = + [ "#F8766D", "#CD9600", "#7CAE00", "#00BE67" + , "#00BFC4", "#00A9FF", "#C77CFF", "#FF61CC" ] + +hggExtended :: CategoricalPalette +hggExtended = + [ "#C9A968", "#2A3050", "#D63A4A" -- WR + , "#5B2E7C", "#C7A666", "#7A5C92" -- CC + , "#8A6B4F", "#B79DB8", "#F2E8C9" -- DM + , "#2A4E54", "#B08B4A", "#7A4A2E" -- MH + , "#A61E2A", "#C7A46A", "#3B263B" -- QH + , "#C7D7E6", "#B8C7D9", "#C9CDD3" -- WQ + , "#5D0F12", "#C3A46E", "#4A3322" -- RQ + ] + +-- 各キャラ 4 色 (= 公式 hex のみ) +whiteRabbit = [ "#C9A968", "#2A3050", "#D63A4A", "#F0A5A0" ] :: CategoricalPalette +cheshireCat = [ "#5B2E7C", "#C7A666", "#C0B8E6", "#7A5C92" ] :: CategoricalPalette +dormouse = [ "#8A6B4F", "#B79DB8", "#F2E8C9", "#C9A968" ] :: CategoricalPalette +marchHare = [ "#2A4E54", "#B08B4A", "#7A4A2E", "#A7D7DE" ] :: CategoricalPalette +queenOfHearts = [ "#A61E2A", "#C7A46A", "#3B263B", "#C7445D" ] :: CategoricalPalette +whiteQueen = [ "#C7D7E6", "#B8C7D9", "#C9CDD3", "#DDE8F2" ] :: CategoricalPalette +redQueen = [ "#5D0F12", "#C3A46E", "#4A3322", "#7E1F23" ] :: CategoricalPalette + +-- 各キャラ sequential (= 公式 hex 由来) +whiteRabbitSeq, cheshireCatSeq, dormouseSeq, marchHareSeq + , queenOfHeartsSeq, whiteQueenSeq, redQueenSeq :: SequentialPalette +whiteRabbitSeq = ["#F2E8D0", "#E8E5DD", "#C9A968", "#8B6F3A", "#2A3050"] +whiteQueenSeq = ["#FBFCFD", "#E6EEF6", "#DDE8F2", "#C9CDD3", "#B8C7D9"] +cheshireCatSeq = ["#E6E3EA", "#C0B8E6", "#C0C0F0", "#7A5C92", "#5B2E7C"] +dormouseSeq = ["#FBF6EE", "#F3E6C6", "#F2E8C9", "#C9A968", "#8A6B4F"] +marchHareSeq = ["#F8F6F1", "#F3E7D6", "#A7D7DE", "#3E6A6F", "#2A4E54"] +queenOfHeartsSeq = ["#F7F4F1", "#D7A1A6", "#C7445D", "#A61E2A", "#6E0F23"] +redQueenSeq = ["#F5EFE6", "#C3A46E", "#A45353", "#7E1F23", "#5D0F12"] + +-- 汎用 sequential (= ColorBrewer 風) +hggBlueSeq, hggRedSeq, hggGoldSeq, hggSageSeq + , hggSiennaSeq, hggPurpleSeq, hggRoseSeq :: SequentialPalette +hggBlueSeq = ["#C0C8D5", "#7A839A", "#2A3050", "#1A1F38", "#0F1424"] +hggRedSeq = ["#F4C7CD", "#E68390", "#D63A4A", "#A02838", "#6E1A28"] +hggGoldSeq = ["#F0E3BD", "#DDC68C", "#C9A968", "#8B6F3A", "#5A4520"] +hggSageSeq = ["#C8D3C0", "#92A689", "#5A7958", "#3D573D", "#253726"] +hggSiennaSeq = ["#F0C9AC", "#DD9B6F", "#C76A3A", "#8B4523", "#5A2A13"] +hggPurpleSeq = ["#C4B3CE", "#8E68A8", "#5B2E7C", "#3F1F58", "#25113A"] +hggRoseSeq = ["#F2C9D1", "#DD8A9B", "#C7445D", "#8E2D44", "#561A2A"] + +-- Diverging (= 公式 hex) +hggDivQueens :: DivergingPalette +hggDivQueens = + [ "#5D0F12", "#7E1F23", "#A45353" + , "#F5EFE6" + , "#DDE8F2", "#B8C7D9", "#C7D7E6" + ] + +hggDivYellowPurple :: DivergingPalette +hggDivYellowPurple = + [ "#C9A968", "#DDC68C", "#F0E3BD" + , "#F2E8D0" + , "#C4B3CE", "#8E68A8", "#5B2E7C" ] + +hggDivPinkGreen :: DivergingPalette +hggDivPinkGreen = + [ "#C7445D", "#DD8A9B", "#F2C9D1" + , "#F2E8D0" + , "#C8D3C0", "#92A689", "#5A7958" ] + +hggCyclical5 :: CategoricalPalette +hggCyclical5 = + [ "#C9A968", "#2A4E54", "#3A4A66", "#5B2E7C", "#5D0F12" ] + +hggWarn, hggHighlight, hggSuccess, hggInfo :: Text +hggWarn = "#D63A4A" +hggHighlight = "#F0A5A0" +hggSuccess = "#6BB07A" +hggInfo = "#8AA0BA" + +-- =========================================================================== +-- ColorBrewer 2.0 (= Cynthia Brewer、 Penn State、 Apache 2.0 license) +-- =========================================================================== + +-- $colorbrewer +-- ColorBrewer は地図・科学可視化向け 35 palette のセット。 +-- ここでは categorical 5 種 + diverging 7 種を import (= 9-class が中心)。 +-- 公式: +-- License: Apache 2.0 (= attribution required) + +-- | Categorical Set1 (9-class)。 強い primary 色、 区別性高い。 +brewerSet1 :: CategoricalPalette +brewerSet1 = + [ "#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00" + , "#FFFF33", "#A65628", "#F781BF", "#999999" ] + +-- | Categorical Set2 (8-class)。 やや pastel、 印刷に向く。 +brewerSet2 :: CategoricalPalette +brewerSet2 = + [ "#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3", "#A6D854" + , "#FFD92F", "#E5C494", "#B3B3B3" ] + +-- | Categorical Set3 (12-class)。 多 categorical に向く、 薄め。 +brewerSet3 :: CategoricalPalette +brewerSet3 = + [ "#8DD3C7", "#FFFFB3", "#BEBADA", "#FB8072", "#80B1D3" + , "#FDB462", "#B3DE69", "#FCCDE5", "#D9D9D9", "#BC80BD" + , "#CCEBC5", "#FFED6F" ] + +-- | Paired (12-class)。 light/dark のペア (= 2 グループ × 6 色)。 +brewerPaired :: CategoricalPalette +brewerPaired = + [ "#A6CEE3", "#1F78B4", "#B2DF8A", "#33A02C", "#FB9A99" + , "#E31A1C", "#FDBF6F", "#FF7F00", "#CAB2D6", "#6A3D9A" + , "#FFFF99", "#B15928" ] + +-- | Dark2 (8-class)。 dark 系、 強い contrast。 +brewerDark2 :: CategoricalPalette +brewerDark2 = + [ "#1B9E77", "#D95F02", "#7570B3", "#E7298A", "#66A61E" + , "#E6AB02", "#A6761D", "#666666" ] + +-- | Diverging RdYlBu (9-class、 中心 #FFFFBF)。 赤 ↔ 黄 ↔ 青。 +brewerRdYlBu :: DivergingPalette +brewerRdYlBu = + [ "#D73027", "#F46D43", "#FDAE61", "#FEE090" + , "#FFFFBF" + , "#E0F3F8", "#ABD9E9", "#74ADD1", "#4575B4" ] + +-- | Diverging RdBu (9-class)。 赤 ↔ 青、 中央 #F7F7F7。 +brewerRdBu :: DivergingPalette +brewerRdBu = + [ "#B2182B", "#D6604D", "#F4A582", "#FDDBC7" + , "#F7F7F7" + , "#D1E5F0", "#92C5DE", "#4393C3", "#2166AC" ] + +-- | Diverging Spectral (11-class)。 虹 (= 赤→橙→黄→緑→青→紫)、 中心 #FFFFBF。 +brewerSpectral :: DivergingPalette +brewerSpectral = + [ "#9E0142", "#D53E4F", "#F46D43", "#FDAE61", "#FEE08B" + , "#FFFFBF" + , "#E6F598", "#ABDDA4", "#66C2A5", "#3288BD", "#5E4FA2" ] + +-- | Diverging PuOr (9-class)。 紫 ↔ 橙、 中央 #F7F7F7。 +brewerPuOr :: DivergingPalette +brewerPuOr = + [ "#B35806", "#E08214", "#FDB863", "#FEE0B6" + , "#F7F7F7" + , "#D8DAEB", "#B2ABD2", "#8073AC", "#542788" ] + +-- | Diverging BrBG (9-class)。 茶 ↔ 緑、 中央 #F5F5F5。 +brewerBrBG :: DivergingPalette +brewerBrBG = + [ "#8C510A", "#BF812D", "#DFC27D", "#F6E8C3" + , "#F5F5F5" + , "#C7EAE5", "#80CDC1", "#35978F", "#01665E" ] + +-- | Diverging RdGy (9-class)。 赤 ↔ 灰、 中央 #FFFFFF。 +brewerRdGy :: DivergingPalette +brewerRdGy = + [ "#B2182B", "#D6604D", "#F4A582", "#FDDBC7" + , "#FFFFFF" + , "#E0E0E0", "#BABABA", "#878787", "#4D4D4D" ] + +-- | Diverging PiYG (9-class)。 ピンク ↔ 黄緑、 中央 #F7F7F7。 +brewerPiYG :: DivergingPalette +brewerPiYG = + [ "#C51B7D", "#DE77AE", "#F1B6DA", "#FDE0EF" + , "#F7F7F7" + , "#E6F5D0", "#B8E186", "#7FBC41", "#4D9221" ] diff --git a/src/Graphics/Hgg/Primitive.hs b/src/Graphics/Hgg/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Primitive.hs @@ -0,0 +1,143 @@ +-- | +-- Module : Graphics.Hgg.Primitive +-- Description : backend 非依存の描画 primitive・幾何・スタイルの基盤型 (leaf) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 51: 描画 primitive (Point/Rect/style/PathSegment/Transform/Primitive) を +-- Spec/Layout/Render に依存しない **leaf module** へ集約。 これらは元々 +-- 'Graphics.Hgg.Render.Common' (Spec/Layout を import する上位) に置かれていたため、 +-- 「'Spec.Layer' が draw closure (@RenderCtx -> [Primitive]@) を保持する」 拡張 (custom +-- mark) が **module 循環**で不能だった。 primitive は概念的に幾何 + Text のみに依存する +-- 基盤型ゆえ、 正しい層 (= 最下層 leaf) へ戻す。 挙動・出力は完全に不変 (純粋な型移動)。 +-- 'Graphics.Hgg.Render.Common' / 'Graphics.Hgg.Render' が本 module を re-export するので +-- 既存の import 経路は不変。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Primitive + ( -- * 幾何 + Point(..) + , Rect(..) + -- * スタイル + , LineStyle(..) + , solid + , FillStyle(..) + , StrokeStyle(..) + , TextStyle(..) + , TextAnchor(..) + , Transform(..) + , PathSegment(..) + -- * Primitive + , Primitive(..) + -- * pt→device scale (backend の唯一の dpi 適用点) + , scalePrimitives + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +-- =========================================================================== +-- 幾何 +-- =========================================================================== + +data Point = Point !Double !Double deriving (Show, Eq) + +-- | plot 領域や clip 矩形。 (x,y) 左上 + 幅高 (pt 空間)。 +data Rect = Rect { rX :: !Double, rY :: !Double, rW :: !Double, rH :: !Double } + deriving (Show, Eq, Generic) + +instance ToJSON Rect +instance FromJSON Rect + +-- =========================================================================== +-- スタイル +-- =========================================================================== + +-- | 線スタイル。 'lsDash' = SVG stroke-dasharray / Canvas setLineDash 用 px 配列。 +-- 既定 (= 実線) は空配列 []。 'solid' ヘルパで作ると常に実線 (Phase 11 A4-b 以前と同一)。 +data LineStyle = LineStyle { lsColor :: !Text, lsWidth :: !Double, lsDash :: ![Double] } deriving (Show, Eq) + +-- | Phase 11 A4-b: 実線 'LineStyle' の簡易構築 (= 旧 2 引数 LineStyle と同一)。 +-- dash を持たない既存呼出は全てこれに置換 (出力完全不変)。 +solid :: Text -> Double -> LineStyle +solid c w = LineStyle c w [] + +data FillStyle = FillStyle { fsColor :: !Text, fsOpacity :: !Double } deriving (Show, Eq) +data StrokeStyle = StrokeStyle { ssColor :: !Text, ssWidth :: !Double } deriving (Show, Eq) +data TextStyle = TextStyle + { tsColor :: !Text + , tsSize :: !Double + , tsFamily :: !Text + , tsAnchor :: !TextAnchor + , tsRotate :: !Double -- degrees **CCW** (canonical・R/ggplot 準拠)、 0 = 水平。 + -- device (SVG/canvas/rasterific=CW) への符号変換は各 backend emit で 1 回 (PDF=y-up ゆえ恒等)。 + , tsWeight :: !Text -- ★ TODO-10 (2026-05-29): "normal" / "bold" 等 + , tsItalic :: !Bool -- ★ TODO-10: italic on/off + } deriving (Show, Eq) + +data TextAnchor = AnchorStart | AnchorMiddle | AnchorEnd + deriving (Show, Eq) + +data Transform = TranslateT !Double !Double | ScaleT !Double !Double + deriving (Show, Eq) + +data PathSegment + = MoveTo !Point + | LineTo !Point + | CurveTo !Point !Point !Point + | ClosePath + deriving (Show, Eq) + +-- =========================================================================== +-- Primitive +-- =========================================================================== + +-- | backend 非依存の描画 primitive。 各 backend は drawPrimitives で +-- これを順に解釈するだけ。 +data Primitive + = PLine !Point !Point !LineStyle + | PRect !Rect !FillStyle (Maybe StrokeStyle) + -- | 'PCircle' は最終フィールドに optional hover label。 SVG backend は + -- 要素として埋め込み、 ブラウザ native の hover tooltip に。 + -- JS 不要。 + | PCircle !Point !Double !FillStyle (Maybe StrokeStyle) (Maybe Text) + | PPath ![PathSegment] !FillStyle (Maybe StrokeStyle) + | PText !Point !Text !TextStyle + | PClipPush !Rect + | PClipPop + | PTransformPush !Transform + | PTransformPop + deriving (Show, Eq) + +-- | Phase 33 B5: pt 空間の primitive を device 単位へ一括 scale (k = dpi/72)。 +-- ★ raster/vector backend で **唯一の dpi 適用点**。Layout/Render は +-- 純 pt を出力し、ここで一度だけ k を掛ける。PDF は k=1 (pt 直結・恒等) を渡す。 +-- 座標・サイズ・線幅・font size・dash 配列を全て k 倍する。'ScaleT' は比率ゆえ不変。 +scalePrimitives :: Double -> [Primitive] -> [Primitive] +scalePrimitives k + | k == 1 = id + | otherwise = map go + where + sp (Point x y) = Point (x * k) (y * k) + sr (Rect x y w h) = Rect (x * k) (y * k) (w * k) (h * k) + sl (LineStyle c w d) = LineStyle c (w * k) (map (* k) d) + sst (StrokeStyle c w) = StrokeStyle c (w * k) + sts ts = ts { tsSize = tsSize ts * k } + sseg seg = case seg of + MoveTo p -> MoveTo (sp p) + LineTo p -> LineTo (sp p) + CurveTo a b c -> CurveTo (sp a) (sp b) (sp c) + ClosePath -> ClosePath + str (TranslateT dx dy) = TranslateT (dx * k) (dy * k) + str t@(ScaleT _ _) = t + go p = case p of + PLine a b ls -> PLine (sp a) (sp b) (sl ls) + PRect r fs mss -> PRect (sr r) fs (fmap sst mss) + PCircle c rad fs mss t -> PCircle (sp c) (rad * k) fs (fmap sst mss) t + PPath segs fs mss -> PPath (map sseg segs) fs (fmap sst mss) + PText pt txt ts -> PText (sp pt) txt (sts ts) + PClipPush r -> PClipPush (sr r) + PClipPop -> PClipPop + PTransformPush tr -> PTransformPush (str tr) + PTransformPop -> PTransformPop diff --git a/src/Graphics/Hgg/Render.hs b/src/Graphics/Hgg/Render.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Render.hs @@ -0,0 +1,51 @@ +-- | +-- Module : Graphics.Hgg.Render +-- Description : Layer 1 ─ Renderer 抽象 (Phase 26 §A-5 Resolver 対応版) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- 'VisualSpec' + 'Resolver' + 'Layout' → backend 非依存 'Primitive' 列。 +-- 各 backend (SVG / PDF / Canvas / Rasterific) は 'drawPrimitives' のみ実装。 +-- +-- Phase 7 A4: 旧 3850 行モノリスを責務別 module に分割。 本 module は +-- 後方互換 shim = 従来の公開名を 'Render.Common' / 'Render.Special' / +-- 'Render.Layer' から re-export するのみ (出力中立・純粋移動)。 +-- * "Graphics.Hgg.Render.Common" — 型 / theme / projection / axis / color / shape / stat helper +-- * "Graphics.Hgg.Render.Basic" — scatter/line/bar/histogram/band/step/stem +-- * "Graphics.Hgg.Render.Distribution" — box/violin/strip/swarm/raincloud/ridge +-- * "Graphics.Hgg.Render.Statistical" — qq/ecdf/rangebar/heatmap/contour/regression/density/statline +-- * "Graphics.Hgg.Render.MCMC" — forest/funnel/autocorr/ess +-- * "Graphics.Hgg.Render.Special" — pie/waterfall/parallel/text/DAG +-- * "Graphics.Hgg.Render.Layer" — orchestration + renderLayer dispatch + facet/legend/inset/marginal +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Render + ( -- * Geometry / Style + Point(..) + , LineStyle(..) + , solid + , FillStyle(..) + , StrokeStyle(..) + , TextStyle(..) + , TextAnchor(..) + , Transform(..) + , PathSegment(..) + -- * Theme palette + , ThemePalette(..) + , themePalette + -- * Primitive + , Primitive(..) + -- * Phase 33 B5: pt→device scale (backend の唯一の dpi 適用点) + , scalePrimitives + -- * 変換 + , renderToPrimitives + -- * Backend interface + , Renderer(..) + -- * Phase 1 A7: edge port + , edgePortPoint + ) where + +import Graphics.Hgg.Primitive -- Phase 51: geometry/style/Primitive (leaf・re-export) +import Graphics.Hgg.Render.Common +import Graphics.Hgg.Render.Layer (renderToPrimitives) +import Graphics.Hgg.Render.EdgeRoute (edgePortPoint) diff --git a/src/Graphics/Hgg/Render/Basic.hs b/src/Graphics/Hgg/Render/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Render/Basic.hs @@ -0,0 +1,593 @@ +-- | +-- Module : Graphics.Hgg.Render.Basic +-- Description : 基本 mark (scatter/line/bar/histogram/band/step/stem) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +module Graphics.Hgg.Render.Basic where + +import Graphics.Hgg.Layout (numToText, + Layout (..), Rect (..), Scale (..), + ViewportSize (..), computeLayout, + ggAxTextMar, ggAxTitleMar, ggHalfLine, + ggTickLen, niceTicks, scaleApply, + Track (..), solveTracks, + needsLegend, effectiveLegendPos, + coordOf, isPolar, polarCenter, polarPoint, + domFrac, projectXY, projectRectData, + projectBarRect, catUnitPx, resolutionOf, + AxisPlacement (..), + coordXAxisPlacement, coordYAxisPlacement, + coordXGridIsVertical) +import Graphics.Hgg.Layout.RangeOf (qqPoints, ecdfPoints) -- Phase 11 A6-2/A6-4 +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Time.Format as Data.Time.Format +import Graphics.Hgg.Spec (Annotation (..), AxisFormat (..), + ColData (..), ColRef, + ColorEnc (..), ConnectSpec (..), + DAGEdge (..), DAGLayoutAlgorithm (..), + DAGNode (..), DAGNodeKind (..), + DAGPlate (..), DAGSpec (..), Layer (..), + LegendPosition (..), LegendSpec (..), + Inset (..), MarginalSpec (..), MarkKind (..), + MarkShape (..), ShapeMapEntry (..), + LineType (..), lineTypeDash, lineTypeForIndex, + ReferenceLine (..), Resolver, + Position (..), Coord (..), + FacetScales (..), freeScaleX, freeScaleY, + FacetSpace (..), freeSpaceX, freeSpaceY, + ThemeOverride (..), + VisualSpec (..), YAxisSide (..), axisFormatOf, + axisRotateOf, resolveAxisAngle, axisShowTicksOf, + axShowGrid, + FontSpec (..), histBinning, orderedCats, + colRefName, resolveCol, resolveNum) +import Data.Maybe (mapMaybe, isJust) +import Data.List (sortOn, foldl') +import qualified Data.Map.Strict as Map +import Data.List (dropWhile, elemIndex, groupBy, nub, + sort, takeWhile) +import qualified Graphics.Hgg.Spec +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Numeric (showEFloat, showFFloat) + +import Graphics.Hgg.Primitive +import Graphics.Hgg.Render.Common + + +-- | TODO-11 (2026-05-27): area band (= 信頼区間 / 予測帯)。 +-- | encX = 共通 x、 encY = 下境界、 encY2 = 上境界 +-- | PPath fill 1 枚 (= forward x-yLow + backward x-yHigh + close)。 +-- | alpha は layer modifier (default 0.2)。 +renderBand :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderBand r layout pal ly = + let xs = V.toList (vecOr (lyEncX ly) r) + yLo = V.toList (vecOr (lyEncY ly) r) + yHi = case getLast (lyEncY2 ly) of + Just c -> V.toList (vecOr (Last (Just c)) r) + Nothing -> [] + n = minimum [length xs, length yLo, length yHi] + c = staticColorOr ly (tpDefault pal) + a = doubleOr (lyAlpha ly) 0.2 + coord = lpCoord layout + pp = projectPoint coord layout + takeN k = take k + in if n < 2 then [] + else + let xsN = takeN n xs + loN = takeN n yLo + hiN = takeN n yHi + forwardPts = zipWith pp xsN loN + upperPts = zipWith pp xsN hiN + backwardPts = reverse upperPts + segs = case forwardPts of + [] -> [] + (h:tl) -> [MoveTo h] + <> map LineTo tl + <> map LineTo backwardPts + <> [ClosePath] + in if null segs then [] + else [ PPath segs (FillStyle c a) Nothing ] + +-- | Phase 52.D2: streamgraph (= 中心化積層 area、 ThemeRiver 風)。 color aes で系列分割し +-- (= 'renderBarGrouped' と同型の群キー取得)、 各 x 値で系列 y を積層、 baseline を +-- -(Σy)/2 から開始 (silhouette 中心化) して各系列を塗り polygon ('renderBand' と同型の +-- forward 下境界 + backward 上境界 + close) で描く。 wiggle 最小化 (ThemeRiver) は行わない。 +renderStream :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderStream r layout pal ly = + let xsAll = V.toList (vecOr (lyEncX ly) r) + ysAll = V.toList (vecOr (lyEncY ly) r) + rawKeys = case getLast (lyColor ly) of + Just (ColorByCol cr) -> case resolveCol r cr of + Just (TxtData v) -> V.toList v + Just (NumData v) -> map (T.pack . show . (round :: Double -> Int)) (V.toList v) + _ -> [] + _ -> [] + n = if null rawKeys + then min (length xsAll) (length ysAll) + else minimum [length xsAll, length ysAll, length rawKeys] + keys = if null rawKeys then replicate n "" else take n rawKeys + rows = zip3 (take n xsAll) keys (take n ysAll) + groups = let cats = lyColorCats ly in if null cats then orderedCats keys else cats + xUniq = sort (nub [ x | (x, _, _) <- rows ]) + a = doubleOr (lyAlpha ly) 0.8 + coord = lpCoord layout + pp = projectPoint coord layout + palArr = lpCategoricalPalette layout + colorG gi = if null palArr then tpDefault pal + else palArr !! (gi `mod` length palArr) + -- (x, group) セルの値 = 該当 row 群の和 (= 同一 (x,group) が複数 row のとき) + cellY x g = sum [ y | (xx, gk, y) <- rows, xx == x, gk == g ] + totalAt x = sum [ cellY x g | g <- groups ] + -- 系列 gi の x 点での下境界 = 中心化 baseline + 先行群の累積高さ + lowerAt x gi = negate (totalAt x / 2) + + sum [ cellY x (groups !! j) | j <- [0 .. gi - 1] ] + mkSeries gi = + let g = groups !! gi + forwardPts = [ pp x (lowerAt x gi) | x <- xUniq ] + backwardPts = reverse [ pp x (lowerAt x gi + cellY x g) | x <- xUniq ] + segs = case forwardPts of + [] -> [] + (h:tl) -> [MoveTo h] + <> map LineTo tl + <> map LineTo backwardPts + <> [ClosePath] + in if null segs then [] else [ PPath segs (FillStyle (colorG gi) a) Nothing ] + in if n < 2 || length xUniq < 2 || null groups then [] + else concat [ mkSeries gi | gi <- [0 .. length groups - 1] ] + +-- | Scatter: 各 (x, y) を PCircle に。 +renderScatter :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderScatter r layout pal ly = + -- NA 行を整列したまま落とすため vecOrFull (= 長さ保持) を使い、 点生成時に + -- NaN を skip する (色/サイズ vector との index 整列を保つ = ggplot 行単位 na.rm)。 + let xs = vecOrFull (lyEncX ly) r + ys = vecOrFull (lyEncY ly) r + n = min (V.length xs) (V.length ys) + cs = colorVector r layout pal ly n + a = doubleOr (lyAlpha ly) 0.85 + aVec = alphaVector r ly a n -- ★ Phase 30 A8: per-point alpha (lyAlphaBy) + szVec = sizeVector r layout ly n -- ★ TODO-3e: per-point size (lySizeBy) + coord = lpCoord layout + -- ★ TODO-3c (2026-05-29): P14 jitter (= PS Render port)。 + -- lyJitterX/Y は plotArea に対する比率 (0..1)。 hashRand で deterministic。 + jx = doubleOr (lyJitterX ly) 0.0 + jy = doubleOr (lyJitterY ly) 0.0 + area = lpPlotArea layout + jitterOffsetX i = if jx == 0.0 then 0.0 + else (hashRand (i * 2) - 0.5) * jx * rW area + jitterOffsetY i = if jy == 0.0 then 0.0 + else (hashRand (i * 2 + 1) - 0.5) * jy * rH area + -- error bar (= Phase 26 §C-2 #6) + errXVec = vecOr (lyErrorX ly) r + errYVec = vecOr (lyErrorY ly) r + -- ★ Phase 41: cap 横/縦長を ggplot 同様データ単位化 (width = markWidth × resolution)。 + -- cap 端点をデータ空間で作り projectXY に通すので flip も自動追従 (旧 px 固定を置換)。 + capWFactor = doubleOr (lyMarkWidth ly) 0.9 -- ggplot geom_errorbar 既定 width = 0.9 + finite v = not (isNaN v) && not (isInfinite v) + resX = resolutionOf (filter finite (V.toList xs)) + resY = resolutionOf (filter finite (V.toList ys)) + capHalfX = 0.5 * capWFactor * resX -- errorY の横 cap 半幅 (x データ単位) + capHalfY = 0.5 * capWFactor * resY -- errorX の縦 cap 半幅 (y データ単位) + mkErrX i = + let x = xs V.! i; y = ys V.! i + ex = errXVec V.!? i + in case ex of + Just dx -> + -- errorX (x 方向誤差) の cap は y 方向 (高さ) にデータ単位で伸びる。 + let pL = uncurry Point (projectXY coord layout (x - dx) y) + pR = uncurry Point (projectXY coord layout (x + dx) y) + cLlo = uncurry Point (projectXY coord layout (x - dx) (y - capHalfY)) + cLhi = uncurry Point (projectXY coord layout (x - dx) (y + capHalfY)) + cRlo = uncurry Point (projectXY coord layout (x + dx) (y - capHalfY)) + cRhi = uncurry Point (projectXY coord layout (x + dx) (y + capHalfY)) + in [ PLine pL pR (solid (tpAxis pal) 1.0) + , PLine cLlo cLhi (solid (tpAxis pal) 1.0) + , PLine cRlo cRhi (solid (tpAxis pal) 1.0) + ] + Nothing -> [] + mkErrY i = + let x = xs V.! i; y = ys V.! i + ey = errYVec V.!? i + in case ey of + Just dy -> + -- errorY (y 方向誤差) の cap は x 方向 (幅) にデータ単位で伸びる。 + let pLo = uncurry Point (projectXY coord layout x (y - dy)) + pHi = uncurry Point (projectXY coord layout x (y + dy)) + cLoL = uncurry Point (projectXY coord layout (x - capHalfX) (y - dy)) + cLoR = uncurry Point (projectXY coord layout (x + capHalfX) (y - dy)) + cHiL = uncurry Point (projectXY coord layout (x - capHalfX) (y + dy)) + cHiR = uncurry Point (projectXY coord layout (x + capHalfX) (y + dy)) + in [ PLine pLo pHi (solid (tpAxis pal) 1.0) + , PLine cLoL cLoR (solid (tpAxis pal) 1.0) + , PLine cHiL cHiR (solid (tpAxis pal) 1.0) + ] + Nothing -> [] + errorPrims = concatMap (\i -> mkErrX i <> mkErrY i) [0 .. n - 1] + -- connect 線 (= Phase 26 §C-2 #5) + connectPrims = case getLast (lyConnect ly) of + Nothing -> [] + Just cs_ -> renderConnect r layout pal ly cs_ xs ys n + pointZBefore = case getLast (lyConnect ly) of + Just cs_ | csBefore cs_ -> connectPrims + _ -> [] + pointZAfter = case getLast (lyConnect ly) of + Just cs_ | not (csBefore cs_) -> connectPrims + _ -> [] + hoverParts = + [ (colRefName cr, vecOr (Last (Just cr)) r) + | cr <- lyHover ly ] + -- ★ Phase 28/34: マーカー塗り・縁は 'markerFillFor'/'markerStrokeFor' に一本化 + -- (既定縁なし=塗り点 shape 19、 hollow=輪郭のみ、 edge 指定時のみ縁)。 + -- 凡例キー (Render.Layer) も同関数を使い、 plot と凡例の見た目を一致させる。 + -- ★ TODO-3c/3e/3f: jitter + sizeBy + shapeBy 反映 + circles = + [ shapeToPrim sh (Point (px + jitterOffsetX i) (py + jitterOffsetY i)) sz + (markerFillFor ly c ai) + (markerStrokeFor ly c) + (Just (mkLabel x y i)) + | i <- [0 .. n - 1] + , let x = xs V.! i + y = ys V.! i + , not (isNaN x), not (isNaN y) -- NA 点を落とす (行整列維持) + , let (px, py) = projectXY coord layout x y + c = cs V.! i + ai = aVec V.! i -- ★ Phase 30 A8: per-point alpha + sz = szVec V.! i + sh = pointShapeAt ly r i + mkLabel xv yv idx = + let base = T.concat [ "(", numToText xv, ", ", numToText yv, ")" ] + extra = T.intercalate ", " + [ T.concat [ name, ": ", numToText v ] + | (name, vec) <- hoverParts + , Just v <- [vec V.!? idx] ] + in if T.null extra then base else T.concat [base, " | ", extra] ] + in pointZBefore <> errorPrims <> circles <> pointZAfter + +-- =========================================================================== +-- Phase 26 A2: vector field (quiver) +-- =========================================================================== + +-- | 各 (x,y) に成分 (u,v) の矢印を描く (= matplotlib @quiver@)。 矢印長は +-- autoscale (= 最長矢印がデータ対角の 8%) に 'lyArrowScale' 倍を掛けた長さ。 +-- 'lyArrowMagnitude' で magnitude (√(u²+v²)) の連続色マップ (viridis)。 矢印は +-- 始点 (x,y) を根元に置く (pivot=tail・matplotlib 既定)。 magnitude 0 の矢印は +-- 退化して描かれない。 +renderQuiver :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderQuiver r layout pal ly = + let xs = vecOr (lyEncX ly) r + ys = vecOr (lyEncY ly) r + us = vecOr (lyEncU ly) r + vs = vecOr (lyEncV ly) r + n = minimum [V.length xs, V.length ys, V.length us, V.length vs] + coord = lpCoord layout + w = doubleOr (lyStroke ly) defaultLineWidth + userScale = doubleOr (lyArrowScale ly) 1.0 + magOn = case getLast (lyArrowMagnitude ly) of Just True -> True; _ -> False + idxs = [0 .. n - 1] + magAt i = let u = us V.! i; v = vs V.! i in sqrt (u * u + v * v) + mags = map magAt idxs + maxMag = if null mags then 0 else maximum mags + -- autoscale: 最長矢印 = データ対角の 8% (data 空間で tip = (x+s*u, y+s*v)) + spanOf vec = let ws = [vec V.! i | i <- idxs] + in if null ws then 1 + else let mx = maximum ws; mn = minimum ws + in if mx > mn then mx - mn else 1 + diag = sqrt (spanOf xs ** 2 + spanOf ys ** 2) + sAuto = if maxMag <= 0 then 0 else 0.08 * diag / maxMag + s = sAuto * userScale + -- 単色 (theme/lyColor) を colorVector から、 magnitude 時は viridis で上書き + cs = colorVector r layout pal ly n + colorAt i = if magOn && maxMag > 0 then viridis (magAt i / maxMag) + else cs V.! i + arrow i + | magAt i <= 0 = [] -- 零ベクトルは描かない + | otherwise = + let x = xs V.! i; y = ys V.! i; u = us V.! i; v = vs V.! i + (px0, py0) = projectXY coord layout x y + (px1, py1) = projectXY coord layout (x + s * u) (y + s * v) + in drawArrow2D (Point px0 py0) (Point px1 py1) (solid (colorAt i) w) + -- ★ Phase 36 A: 矢印は格子点から伸びて plotArea を超えうるので、 元レンジのまま + -- plotArea でクリップする (端の矢印は途切れる)。 = ドメイン拡張より自然。 + in PClipPush (lpPlotArea layout) : concatMap arrow idxs ++ [PClipPop] + +-- | Phase 26 A2: 始点 from → 終点 to の矢印 (本線 + 2 本の矢じり)。 矢じり形状は +-- 'AnnArrow' (Render/Layer.hs) と同じ (長さ 2.5mm・開き比 0.5)。 +drawArrow2D :: Point -> Point -> LineStyle -> [Primitive] +drawArrow2D (Point px1 py1) (Point px2 py2) ls = + let dx = px2 - px1; dy = py2 - py1 + len = sqrt (dx * dx + dy * dy) + (ux, uy) = if len == 0 then (0, 0) else (dx / len, dy / len) + ah = mmPt 2.5; aw = 0.5 + bx = px2 - ux * ah; by = py2 - uy * ah + lx = bx - uy * ah * aw; ly = by + ux * ah * aw + rx = bx + uy * ah * aw; ry = by - ux * ah * aw + in [ PLine (Point px1 py1) (Point px2 py2) ls + , PLine (Point px2 py2) (Point lx ly) ls + , PLine (Point px2 py2) (Point rx ry) ls ] + +renderLine :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderLine r layout pal ly = + -- NA 行を整列したまま落とすため vecOrFull (長さ保持) で取り、 seg で NaN 点を + -- 除いてから線分化する (= ggplot が NA で線を切らず詰める na.rm 既定相当)。 + let xs = V.toList $ vecOrFull (lyEncX ly) r + ys = V.toList $ vecOrFull (lyEncY ly) r + w = doubleOr (lyStroke ly) defaultLineWidth + coord = lpCoord layout + pp = projectPoint coord layout + -- Phase 11 A4-b: 固定 linetype (= ggplot linetype=)。 既定 Solid → [] = 実線。 + fixedDash = maybe [] lineTypeDash (getLast (lyLinetype ly)) + -- 連続点列を dash 付き線分群に (色は引数で指定)。 NaN (= NA) 点は除く。 + seg col dash pts = + let pts' = [ p | p@(x, y) <- pts, not (isNaN x), not (isNaN y) ] + in [ PLine (pp xa ya) (pp xb yb) (LineStyle col w dash) + | ((xa, ya), (xb, yb)) <- zip pts' (drop 1 pts') ] + in case getLast (lyColor ly) of + -- Phase 52.A10: ColorByCol は群ごとに色付き線 (= ggplot color=group)。 単一カテゴリ + -- (statLabel 1 本) なら 1 本を該当カテゴリ色で描く。 旧実装は ColorByCol を staticColorOr + -- が拾えず default 単色に潰れ、 異モデル重畳の色分けが効かなかった。 色は 'colorVector' + -- (scale_color_manual 辞書→palette index) を流用し各群代表点 (=同カテゴリゆえ同色) を採る。 + Just (ColorByCol cr) | Just keys <- groupKeysOf r cr -> + let cs = V.toList (colorVector r layout pal ly (length xs)) + groups = orderedGroups keys (zip3 xs ys cs) + lineFor (_, gpts) = + let col = case gpts of ((_, _, gc) : _) -> gc; [] -> tpDefault pal + pts = [ (gx, gy) | (gx, gy, _) <- gpts ] + in seg col fixedDash pts + in concatMap lineFor groups + _ -> + let c = staticColorOr ly (tpDefault pal) + in case getLast (lyLinetypeBy ly) >>= groupKeysOf r of + -- linetypeBy (= ggplot linetype=factor(g)): 群ごとに別 line。 dash は + -- 既定では群ごとに巡回するが、 固定 linetype (lyLinetype) があれば全群その dash。 + -- (= ggplot aes(group=g) 相当の「色も線種も変えない純粋な群分割」。 + -- 例: linetypeBy "track" <> linetype LtSolid で全曲を実線で群分割。) + Just keys -> + let dashFor i = maybe (lineTypeDash (lineTypeForIndex i)) lineTypeDash + (getLast (lyLinetype ly)) + in concat [ seg c (dashFor i) gpts + | (i, (_, gpts)) <- zip [0 ..] (orderedGroups keys (zip xs ys)) ] + Nothing -> seg c fixedDash (zip xs ys) + +-- | Phase 9 B: position adjustment 対応 dispatcher。 +-- 既定 (position identity) または群分け (color aesthetic) 無しは従来の単色 bar +-- ('renderBarSimple')。 dodge/stack/fill かつ categorical x かつ ColorByCol 群分けあり +-- のとき 'renderBarGrouped' で系列を並べる。 +renderBar :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderBar r layout pal ly = + let pos = maybe PosIdentity id (getLast (lyPosition ly)) + grpKeys = case getLast (lyColor ly) of + Just (ColorByCol cr) -> case resolveCol r cr of + Just (TxtData v) -> Just (V.toList v) + Just (NumData v) -> Just (map (T.pack . show . (round :: Double -> Int)) (V.toList v)) + _ -> Nothing + _ -> Nothing + isCat = not (null (lpXCategoryLabels layout)) + in case (pos, grpKeys) of + (PosIdentity, _) -> renderBarSimple r layout pal ly + (_, Just keys) | isCat -> renderBarGrouped pos keys r layout pal ly + _ -> renderBarSimple r layout pal ly + +-- | position identity / 群分けなしの bar。 ★Phase 19 A2: 色は 'colorVector' に +-- 委譲 (ColorByCol で per-bar 色分け = ggplot の identity + fill aesthetic 同型。 +-- ColorStatic / 色指定なしは colorVector が単色を返すので従来挙動不変)。 +renderBarSimple :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderBarSimple r layout pal ly = + -- categorical x: 各 row の label を xCats (= x 軸のカテゴリ列) の index へ。 + -- ★Phase 19 A2: 旧実装は row index (0..n-1) に置いており、 カテゴリ重複行が + -- x domain を超えて plot 域をはみ出していた (実測: 3 行 2 cat で 3 本目が + -- 右枠外)。 cat index 配置なら重複行は同 slot に重ね描き = ggplot identity + -- 同型。 重複なしデータは row index = cat index でビット不変。 + let xCats = lpXCategoryLabels layout + isCat = not (null xCats) + xsNum = vecOr (lyEncX ly) r + ys = vecOr (lyEncY ly) r + xs = if isCat + then case getLast (lyEncX ly) >>= resolveCol r of + Just (TxtData v) -> + V.map (\t -> maybe 0 fromIntegral (elemIndex t xCats)) v + _ -> V.fromList [ fromIntegral i | i <- [0 .. V.length ys - 1] ] + else xsNum + -- ★ Phase 34: fill geom (bar) の無指定既定は tpDefaultFill (ggplot grey35)。 + -- colorVector の fallback は tpDefault なので fill 色に差し替えた pal を渡す。 + cs = colorVector r layout (pal { tpDefault = tpDefaultFill pal }) ly (V.length ys) + a = doubleOr (lyAlpha ly) 1.0 -- ★ Phase 34: ggplot bar は不透明 + coord = lpCoord layout + sx = scaleApply (lpXScale layout) + -- Phase 8 B7: bar 境界線。 default False (= ggplot 流フラット)。 + border = case getLast (lyHistBorder ly) of + Just b -> if b then Just (StrokeStyle "#ffffff" 1.0) else Nothing + Nothing -> Nothing + -- bar 幅 (Phase 8 A2 Step4b/4c, design §A-6): categorical は ggplot 既定 = resolution*0.9。 + -- categorical の resolution=1 なので「1 データ単位の pixel 幅 (= sx 1 - sx 0)」 の 0.9。 + -- Step4c: 旧 rW/nBars (個数ベース) を unit ベース (xUnit) に変更。 ±0.5 expansion 下では + -- xUnit == rW/nBars だが、 ±0.6 で domain span が n→n+0.2 に変わっても棒が比例して縮み + -- 隣と接触しない (= 軸スケールに追従)。 numeric は resolution 未算出のため従来 60% 維持。 + area = lpPlotArea layout + nBars = max 1 (V.length xs) + -- Phase 10 A4-fix: 厚みは coord に応じた cross 軸単位 (flip では縦スロット幅)。 + xUnit = catUnitPx coord layout + bw = if isCat + then xUnit * 0.9 + else rW area / fromIntegral nBars * 0.6 + -- Phase 10 A3: bar は projectBarRect で flip 追従 (厚み bw は px のまま、 base=0..value)。 + -- Cartesian は Rect (sx x - bw/2)(min (sy y)(sy 0)) bw (abs (sy y - sy 0)) と bit 一致。 + -- Phase 11 A7-c: 極座標は扇形 (wedge) で描く。 PolarX = rose (角度帯×半径=値)、 + -- PolarY = 中心からの扇形 (角度=値×半径帯)。 厚みは frac 単位の角度/半径幅。 + spanX = lsDomainHi (lpXScale layout) - lsDomainLo (lpXScale layout) + hwFrac = if spanX == 0 then 0.5 else 0.45 / spanX + dfx = domFrac (lpXScale layout) + dfy = domFrac (lpYScale layout) + mkWedge x y = case coord of + CoordPolarY -> wedgeSegments layout (dfy 0) (dfy y) + (max 0 (dfx x - hwFrac)) (dfx x + hwFrac) + _ -> wedgeSegments layout (dfx x - hwFrac) (dfx x + hwFrac) + (dfy 0) (dfy y) + in if isPolar coord + then [ PPath (mkWedge x y) (FillStyle c a) border + | (x, y, c) <- zip3 (V.toList xs) (V.toList ys) (V.toList cs) ] + else [ PRect (projectBarRect coord layout x 0 y bw) + (FillStyle c a) border + | (x, y, c) <- zip3 (V.toList xs) (V.toList ys) (V.toList cs) ] + +-- | Phase 9 B: 群分け bar の position adjustment (dodge / stack / fill)。 +-- long-form データ (= 各 row が (x-cat, group, value)) を前提に、 x カテゴリ slot 内で +-- 系列 (= color/group aesthetic) を横並び (dodge) / 縦積み (stack) / 100% 正規化 (fill) する。 +-- 色は群 index → categorical palette (= 'colorVector' の ColorByCol と同一割当)。 +renderBarGrouped :: Position -> [Text] -> Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderBarGrouped pos keys r layout pal ly = + let xCats = lpXCategoryLabels layout + xLabels = case getLast (lyEncX ly) of + Just cr -> case resolveCol r cr of + Just (TxtData v) -> V.toList v + Just (NumData v) -> map (T.pack . show . (round :: Double -> Int)) (V.toList v) + _ -> [] + _ -> [] + ys = V.toList (vecOr (lyEncY ly) r) + groups = let cats = lyColorCats ly in if null cats then orderedCats keys else cats + nG = max 1 (length groups) + nX = max 1 (length xCats) + a = doubleOr (lyAlpha ly) 1.0 -- ★ Phase 34: ggplot bar は不透明 + border = case getLast (lyHistBorder ly) of + Just b -> if b then Just (StrokeStyle "#ffffff" 1.0) else Nothing + Nothing -> Nothing + coord = lpCoord layout + sx = scaleApply (lpXScale layout) + xUnit = catUnitPx coord layout -- Phase 10 A4-fix: flip では縦スロット幅 + slotW = xUnit * 0.9 + palArr = lpCategoricalPalette layout + colorG gi = if null palArr then tpDefault pal + else palArr !! (gi `mod` length palArr) + rows = zip3 xLabels keys ys + -- (xi, gi) セルの値 = 該当 row 群の和 (= 同一 (cat,group) が複数 row の場合) + cellY xi gi = sum [ y | (xl, gk, y) <- rows + , elemIndex xl xCats == Just xi + , elemIndex gk groups == Just gi ] + -- stack / fill 共通の縦積み (fill は各 cat 合計 1 に正規化してから積む) + stackCol xi = + let total = sum [ cellY xi gi | gi <- [0 .. nG - 1] ] + scaleV v = case pos of + PosFill -> if total == 0 then 0 else v / total + _ -> v + go _ [] = [] + go cum (gi : rest) = + let yv = scaleV (cellY xi gi) + top = cum + yv + -- Phase 10 A4: slot 中心 = data x=xi、 base..top を data 値で、 厚み slotW px。 + rect = PRect (projectBarRect coord layout (fromIntegral xi) cum top slotW) + (FillStyle (colorG gi) a) border + in (if yv /= 0 then [rect] else []) ++ go top rest + -- Phase 28: ggplot position_stack は凡例の逆順で積む (= 第 1 水準が一番上)。 + -- 群を逆順に積むと gi=0 (例: Adelie) が最上段に来て R4DS と一致する。 + in go 0 (reverse [0 .. nG - 1]) + in case pos of + PosDodge -> + let subW = slotW / fromIntegral nG + in [ PRect (projectBarRect coord layout centerD 0 yv subW) + (FillStyle (colorG gi) a) border + | xi <- [0 .. nX - 1], gi <- [0 .. nG - 1] + , let yv = cellY xi gi, yv /= 0 + -- Phase 10 A4: sub-bar 中心を data 空間で (= xi-0.45+(gi+0.5)*0.9/nG)。 + -- affine なので Cartesian px は旧 px-offset 版と一致。 + , let centerD = fromIntegral xi - 0.45 + + (fromIntegral gi + 0.5) * 0.9 / fromIntegral nG ] + _ -> concat [ stackCol xi | xi <- [0 .. nX - 1] ] + +renderHistogram :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderHistogram r layout pal ly = + let xs = V.toList $ vecOr (lyEncX ly) r + -- ★ Phase 34: histogram の無指定既定は tpDefaultFill (ggplot grey35)。 + c = staticColorOr ly (tpDefaultFill pal) + a = doubleOr (lyAlpha ly) 1.0 -- ★ Phase 34: ggplot histogram は不透明 + -- TODO-3a (2026-05-29): histDensity = True なら count を density に正規化 + -- (= count / (totalN * binW))。 SVG export でも density モードが動くように。 + isDensity = case getLast (lyHistDensity ly) of + Just b -> b + Nothing -> False + -- Phase 8 B7: bin 境界線 (= 白枠) を出すか。 default False (= ggplot 流フラット)。 + border = case getLast (lyHistBorder ly) of + Just b -> if b then Just (StrokeStyle "#ffffff" 1.0) else Nothing + Nothing -> Nothing + in if null xs then [] else + -- Phase 8 B7: bin 境界は lpHistDomain (= 全 histogram layer 共通の生 min/max) を + -- 単一情報源とする。 y-range 計算 (sharedHistYRange) と同じ domain なので bin 幅が + -- 一致し、 バーが y range を突き抜けない。 padded な x scale domain は使わない。 + let dom = case lpHistDomain layout of + Just d -> d + Nothing -> (minimum xs, maximum xs) + -- Phase 28: bin 化は Spec.histBinning に一元化 (binWidth 優先・ggplot 流 origin)。 + (origin, binW, nBin) = histBinning ly dom + binIx v = min (nBin - 1) (max 0 (floor ((v - origin) / binW))) + counts = foldl (\acc v -> let i = binIx v + in take i acc <> [acc !! i + 1] <> drop (i+1) acc) + (replicate nBin (0 :: Int)) xs + totalN = length xs + toY cnt = if isDensity && totalN > 0 && binW > 0 + then fromIntegral cnt / (fromIntegral totalN * binW) + else fromIntegral cnt + coord = lpCoord layout + -- Phase 10 A3: histogram bin は bin 幅が data 単位なので projectRectData (data bbox 転置)。 + -- Cartesian は従来の x [bin..bin+w] × y [0..toY] Rect と bit 一致。 + in [ PRect (projectRectData coord layout + (origin + fromIntegral i * binW) (origin + fromIntegral (i+1) * binW) + 0 (toY cnt)) + (FillStyle c a) border + | (i, cnt) <- zip [0..nBin-1] counts + , cnt > 0 -- 高さ 0 bin はスキップ (= 軸線 artifact 防止) + ] + +-- | Step plot (Phase 6+ C-3): lyEncX = x、 lyEncY = y、 階段折れ線。 +-- 各 segment は (x_i, y_i) → (x_{i+1}, y_i) → (x_{i+1}, y_{i+1})。 +renderStep :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderStep r layout pal ly = + let xs = V.toList (vecOr (lyEncX ly) r) + ys = V.toList (vecOr (lyEncY ly) r) + c = staticColorOr ly (tpDefault pal) + w = doubleOr (lyStroke ly) defaultLineWidth + coord = lpCoord layout + pp = projectPoint coord layout + pts = zip xs ys + dash = maybe [] lineTypeDash (getLast (lyLinetype ly)) -- Phase 11 A4-b + ls = LineStyle c w dash + mkSegs [] = [] + mkSegs [_] = [] + mkSegs ((x1, y1) : (x2, y2) : rest) = + [ PLine (pp x1 y1) (pp x2 y1) ls + , PLine (pp x2 y1) (pp x2 y2) ls + ] ++ mkSegs ((x2, y2) : rest) + in mkSegs pts + +-- | Stem / lollipop plot (Phase 6+ C-3): 縦棒 + 上端 circle marker。 +renderStem :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderStem r layout pal ly = + let xs = V.toList (vecOr (lyEncX ly) r) + ys = V.toList (vecOr (lyEncY ly) r) + c = staticColorOr ly (tpDefault pal) + w = doubleOr (lyStroke ly) defaultLineWidth + sz = doubleOr (lySize ly) defaultMarkerDiameter -- ★ Phase 34 A3: 直径 (PCircle で /2)・scatter と統一 + a = doubleOr (lyAlpha ly) 0.9 + coord = lpCoord layout + sy = scaleApply (lpYScale layout) + -- Phase 8 B23-fix: y=0 が plotArea 内ならそこを baseline、 そうでなければ下端に + -- clamp (= PS renderStem と同方式)。 全 y が正のとき sy 0 が枠下に出て棒が下軸を + -- 貫通するのを防ぐ。 + area = lpPlotArea layout + areaBottom = rY area + rH area + base0 = sy 0 + base = if base0 >= rY area && base0 <= areaBottom then base0 else areaBottom + -- Phase 10 A2: marker は projectPoint で flip 追従。 stem 線の baseline (base) は + -- clamp 済みの px 値軸基準のため Cartesian のまま (flip 時の baseline 入替は後段で対応)。 + mkOne x y = + let (px, py) = projectXY coord layout x y + in [ PLine (Point px base) (Point px py) (solid c w) + , PCircle (Point px py) (sz / 2) (FillStyle c a) + (Just (StrokeStyle c 1.0)) Nothing + ] + in concatMap (uncurry mkOne) (zip xs ys) diff --git a/src/Graphics/Hgg/Render/Common.hs b/src/Graphics/Hgg/Render/Common.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Render/Common.hs @@ -0,0 +1,1419 @@ +-- | +-- Module : Graphics.Hgg.Render.Common +-- Description : 共通基盤 (型・theme・projection・axis/grid/tick・color・shape・stat helper) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +module Graphics.Hgg.Render.Common where + +import Graphics.Hgg.Layout (numToText, + Layout (..), Rect (..), Scale (..), + ViewportSize (..), computeLayout, + ggAxTextMar, ggAxTitleMar, ggHalfLine, + ggTickLen, niceTicks, scaleApply, + formatTicksGG, + Track (..), solveTracks, + needsLegend, effectiveLegendPos, + coordOf, isPolar, polarCenter, polarPoint, + domFrac, projectXY, projectRectData, + projectBarRect, catUnitPx, AxisPlacement (..), + coordXAxisPlacement, coordYAxisPlacement, + coordXGridIsVertical, + UCtx (..), resolvePosX, resolvePosY) +import Graphics.Hgg.Unit (Pos (..), mmToPt) +import Graphics.Hgg.Primitive -- Phase 51: Point/Rect/style/Primitive/scalePrimitives (leaf) +import Graphics.Hgg.Layout.RangeOf (qqPoints, ecdfPoints) -- Phase 11 A6-2/A6-4 +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Time.Format as Data.Time.Format +import Graphics.Hgg.Spec (Annotation (..), AxisFormat (..), + ColData (..), ColRef, + ColorEnc (..), ConnectSpec (..), + DAGEdge (..), DAGLayoutAlgorithm (..), + DAGNode (..), DAGNodeKind (..), + DAGPlate (..), DAGSpec (..), Layer (..), + LegendPosition (..), LegendSpec (..), + Inset (..), MarginalSpec (..), MarkKind (..), + MarkShape (..), ShapeMapEntry (..), + LineType (..), lineTypeDash, lineTypeForIndex, + ReferenceLine (..), Resolver, + Position (..), Coord (..), + FacetScales (..), freeScaleX, freeScaleY, + FacetSpace (..), freeSpaceX, freeSpaceY, + ThemeOverride (..), + VisualSpec (..), YAxisSide (..), axisFormatOf, + axisRotateOf, resolveAxisAngle, axisShowTicksOf, + axShowGrid, + FontSpec (..), orderedCats, + colRefName, distGroupRef, distDodgeRef, + resolveCol, resolveNum) +import Data.Maybe (mapMaybe, isJust) +import Data.List (sortOn, foldl') +import qualified Data.Map.Strict as Map +import Data.List (dropWhile, elemIndex, groupBy, nub, + sort, takeWhile) +import qualified Graphics.Hgg.Spec +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Numeric (showEFloat, showFFloat) + + +-- Phase 51: Point/Rect/style/PathSegment/Transform/Primitive/solid/scalePrimitives は +-- 'Graphics.Hgg.Primitive' (leaf) へ移設 (循環回避)。 本 module は import 済 (下記)。 + +-- | TODO-10 (2026-05-29) PS port: どの font slot を引くか +-- (= spec の titleFont / axisLabelFont / tickFont / legendFont)。 +data FontKind = TitleF | AxisLabelF | TickF | LegendTitleF | LegendItemF + deriving (Show, Eq) + +-- | TODO-10 (2026-05-29) PS port: spec の font 設定 + theme default を merge して TextStyle を生成。 +-- spec を取れない場所 (= layer helper 内など) では Nothing を渡すと slot default に fallback。 +mkFontTS :: Maybe VisualSpec -> ThemePalette -> FontKind -> TextAnchor -> Double -> TextStyle +mkFontTS mSpec pal fk anchor rot = + let -- Phase 34: ggplot theme_grey の base_size + 相対比に較正 (R theme_grey() 実測)。 + -- 旧値 (Title16/Axis12/Tick11/LegTitle11/LegItem10) は ggplot より系統的に大きく、 + -- 特に目盛が base 11pt のままだった (ggplot は axis.text = base×0.8 = 8.8pt)。 + baseSize = 11 -- theme_grey base_size + defSize = case fk of + TitleF -> baseSize * 1.2 -- plot.title rel(1.2) = 13.2pt + AxisLabelF -> baseSize -- axis.title = base = 11pt + TickF -> baseSize * 0.8 -- axis.text rel(0.8) = 8.8pt + LegendTitleF -> baseSize -- legend.title= base = 11pt + LegendItemF -> baseSize * 0.8 -- legend.text rel(0.8) = 8.8pt + -- Phase 9 A-3: font setter (vs*Font) に theme override (to*Font) を上書き合成。 + -- `setter <> override` (Maybe FontSpec の Monoid) で override の Just field が優先 + -- → 優先順位は override > font setter > preset 既定 (= 下の defSize/tpText fallback)。 + mFont = case mSpec of + Nothing -> Nothing + Just spec -> + let setterF = case fk of + TitleF -> getLast (vsTitleFont spec) + AxisLabelF -> getLast (vsAxisLabelFont spec) + TickF -> getLast (vsTickFont spec) + LegendTitleF -> getLast (vsLegendFont spec) + LegendItemF -> getLast (vsLegendFont spec) + overrideF = case fk of + TitleF -> getLast (toTitleFont (vsThemeOverride spec)) + AxisLabelF -> getLast (toAxisLabelFont (vsThemeOverride spec)) + TickF -> getLast (toTickFont (vsThemeOverride spec)) + LegendTitleF -> getLast (toLegendFont (vsThemeOverride spec)) + LegendItemF -> getLast (toLegendFont (vsThemeOverride spec)) + in setterF <> overrideF + orElse l d = case getLast l of + Just v -> v + Nothing -> d + -- Phase 32 (re-apply): plot.title / axis.title は tpTitleColor を既定色に + -- (ggplot theme_grey は black)。 その他の文字 (tick/legend) は従来 tpText。 + defColor = case fk of + TitleF -> tpTitleColor pal + AxisLabelF -> tpTitleColor pal + _ -> tpText pal + in case mFont of + Nothing -> TextStyle defColor defSize "sans-serif" anchor rot "normal" False + Just fs -> TextStyle + { tsColor = orElse (Graphics.Hgg.Spec.fsColor fs) defColor + , tsSize = orElse (Graphics.Hgg.Spec.fsSize fs) defSize + , tsFamily = orElse (Graphics.Hgg.Spec.fsFamily fs) "sans-serif" + , tsAnchor = anchor + , tsRotate = rot + , tsWeight = orElse (Graphics.Hgg.Spec.fsWeight fs) "normal" + , tsItalic = orElse (Graphics.Hgg.Spec.fsItalic fs) False + } + +-- Phase 51: Transform / PathSegment / Primitive は 'Graphics.Hgg.Primitive' へ移設。 + +-- | mm → pt 変換 (Phase 33 B7)。 mark 既定 (point/line/半径/cap/矢じり) を物理 mm で +-- 書くためのヘルパ。 layout/Primitive は純 pt なので、 既定もここで pt に解決する。 +-- backend が dpi 係数 (k) を最後に一律適用する ('scalePrimitives')。 +mmPt :: Double -> Double +mmPt mm = mm * mmToPt + +-- | scatter / point マーカーの既定**直径** (pt)。Phase 34 A1 で ggplot +-- @geom_point@ 既定を実測した 1.65mm (= 半径 2.34pt) に較正 +-- (`phase-34-measurements/A1-results.md`)。size 意味論は「外接円の直径」 +-- (Phase 34 §2.1)。 +defaultMarkerDiameter :: Double +defaultMarkerDiameter = mmPt 1.65 + +-- | 線 (geom_line/path/step/segment) の既定**線幅** (pt)。Phase 34 A1 で ggplot +-- @linewidth 0.5@ の実描画幅 0.376mm に較正 (解析式 @nominal × .pt/96 × 25.4@ を +-- 太線 bbox 実測で検証)。 +defaultLineWidth :: Double +defaultLineWidth = mmPt 0.376 + +-- | geom_smooth 線の既定線幅 (pt)。ggplot は @linewidth = 2 × 既定@ なので line の +-- 2倍 (0.753mm)。Phase 34 A1。 +defaultSmoothWidth :: Double +defaultSmoothWidth = mmPt 0.753 + +-- | Theme 色 palette (= JSON serialize しないので Render module 内に閉じる)。 +-- Phase 9 A-1: 色に加え「panel 背景塗り / grid / border 有無フラグ」 を持つ。 +-- * tpPanelBg = panel (plotArea) 背景色。 tpShowPanel が True のとき塗る。 +-- * tpShowPanel = panel 矩形を塗るか (theme_grey / ブランドは True、 従来 preset は False)。 +-- * tpShowGrid = theme レベルの grid master (False で全 grid 抑制。 軸ごと axShowGrid と AND)。 +-- * tpShowBorder = axisFrame の 4 辺枠を描くか (従来 preset True、 panel 塗り系は False)。 +data ThemePalette = ThemePalette + { tpBackground :: !Text + , tpAxis :: !Text + , tpText :: !Text + , tpGrid :: !Text + , tpDefault :: !Text -- layer default color (point/line/density 等の線・点) + , tpDefaultFill :: !Text -- ★ Phase 34: fill geom (bar/histogram/area) の既定塗り色。 + -- ggplot は geom ごとに既定が違う (point/line=black, bar=grey35) + -- ので 2 値持つ。 brand/従来テーマは tpDefault と同値 (挙動不変)。 + , tpPanelBg :: !Text -- panel (plotArea) 背景色 + , tpShowPanel :: !Bool -- panel 矩形を塗るか + , tpShowGrid :: !Bool -- theme レベルの grid master + , tpShowBorder :: !Bool -- axisFrame の 4 辺枠を描くか + , tpShowAxisLine :: !Bool -- 下辺(x軸)+左辺(y軸)の 2 本軸線を描くか (theme_classic) + -- ★ Phase 32 (re-apply): ggplot theme_grey fidelity 用の追加 field。 + -- 既存テーマは既定値で挙動不変、 ThemeGrey のみ ggplot 厳密値を入れる。 + , tpTitleColor :: !Text -- plot.title / axis.title の文字色 (ggplot=black、 既定= tpText) + , tpTitleHjust :: !Double -- plot.title の水平揃え (0=左、 0.5=中央。 ggplot theme_grey=0) + , tpTickLineColor :: !Text -- 軸目盛線 (tick mark) の色 (ggplot=grey20、 既定= tpAxis) + , tpLegendKeyBg :: !Text -- legend.key 背景塗り色 ("" なら塗らない。 ggplot=grey95) + } deriving (Show, Eq) + +themePalette :: Graphics.Hgg.Spec.ThemeName -> ThemePalette +themePalette t = case t of + -- 従来 4 preset: 白(灰)背景・panel 塗り無し・4 辺枠あり (= G4 の白背景+薄 grid を温存)。 + Graphics.Hgg.Spec.ThemeDefault -> ThemePalette + { tpBackground = "#ffffff", tpAxis = "#444444", tpText = "#333333", tpGrid = "#dddddd" + , tpDefault = "#1f77b4", tpDefaultFill = "#1f77b4", tpPanelBg = "#ffffff" + , tpShowPanel = False, tpShowGrid = True, tpShowBorder = True, tpShowAxisLine = False + , tpTitleColor = "#333333", tpTitleHjust = 0.0, tpTickLineColor = "#444444", tpLegendKeyBg = "" } + Graphics.Hgg.Spec.ThemeMinimal -> ThemePalette + { tpBackground = "#ffffff", tpAxis = "#333333", tpText = "#333333", tpGrid = "#eeeeee" + , tpDefault = "#1f77b4", tpDefaultFill = "#1f77b4", tpPanelBg = "#ffffff" + , tpShowPanel = False, tpShowGrid = True, tpShowBorder = True, tpShowAxisLine = False + , tpTitleColor = "#333333", tpTitleHjust = 0.0, tpTickLineColor = "#333333", tpLegendKeyBg = "" } + Graphics.Hgg.Spec.ThemeLight -> ThemePalette + { tpBackground = "#fafafa", tpAxis = "#666666", tpText = "#444444", tpGrid = "#e0e0e0" + , tpDefault = "#3498db", tpDefaultFill = "#3498db", tpPanelBg = "#fafafa" + , tpShowPanel = False, tpShowGrid = True, tpShowBorder = True, tpShowAxisLine = False + , tpTitleColor = "#444444", tpTitleHjust = 0.0, tpTickLineColor = "#666666", tpLegendKeyBg = "" } + Graphics.Hgg.Spec.ThemeDark -> ThemePalette + { tpBackground = "#222222", tpAxis = "#cccccc", tpText = "#eeeeee", tpGrid = "#444444" + , tpDefault = "#5dade2", tpDefaultFill = "#5dade2", tpPanelBg = "#222222" + , tpShowPanel = False, tpShowGrid = True, tpShowBorder = True, tpShowAxisLine = False + , tpTitleColor = "#eeeeee", tpTitleHjust = 0.0, tpTickLineColor = "#cccccc", tpLegendKeyBg = "" } + -- ggplot 既定 theme_grey: 白 plot bg・灰 panel #EBEBEB・白 grid・枠なし・軸線なし。 + -- ★ Phase 34: geom 既定色を ggplot 厳密値に (point/line = black、 bar/hist = grey35)。 + Graphics.Hgg.Spec.ThemeGrey -> ThemePalette + { tpBackground = "#ffffff", tpAxis = "#4d4d4d", tpText = "#4d4d4d", tpGrid = "#ffffff" + , tpDefault = "#000000", tpDefaultFill = "#595959", tpPanelBg = "#ebebeb" + , tpShowPanel = True, tpShowGrid = True, tpShowBorder = False, tpShowAxisLine = False + -- ★ Phase 32: ggplot theme_grey 厳密値。 title=black/左寄せ・tick=grey20・legend.key=grey95。 + , tpTitleColor = "#000000", tpTitleHjust = 0.0, tpTickLineColor = "#333333", tpLegendKeyBg = "#f2f2f2" } + -- ブランド (panel 塗りあり・grid あり・枠なし、 series は themeSeriesPalette)。 + Graphics.Hgg.Spec.ThemeNoir -> ThemePalette + { tpBackground = "#16161e", tpAxis = "#5a6080", tpText = "#c8ccda", tpGrid = "#2a2e45" + , tpDefault = "#7aa2f7", tpDefaultFill = "#7aa2f7", tpPanelBg = "#1e2030" + , tpShowPanel = True, tpShowGrid = True, tpShowBorder = False, tpShowAxisLine = False + , tpTitleColor = "#c8ccda", tpTitleHjust = 0.0, tpTickLineColor = "#5a6080", tpLegendKeyBg = "" } + Graphics.Hgg.Spec.ThemeLumen -> ThemePalette + { tpBackground = "#ffffff", tpAxis = "#8a857e", tpText = "#2b2b33", tpGrid = "#e7e3db" + , tpDefault = "#4c5bd4", tpDefaultFill = "#4c5bd4", tpPanelBg = "#f7f5f1" + , tpShowPanel = True, tpShowGrid = True, tpShowBorder = False, tpShowAxisLine = False + , tpTitleColor = "#2b2b33", tpTitleHjust = 0.0, tpTickLineColor = "#8a857e", tpLegendKeyBg = "" } + -- Parchment 正式テーマ (明)。 panel=羊皮紙 cream-light #F8F5EE は据え置き、 + -- 外周 plot bg は白 #FFFFFF にして軸内 panel を額装的に強調 (2026-06-02 ユーザ確定)。 + Graphics.Hgg.Spec.ThemeParchment -> ThemePalette + { tpBackground = "#ffffff", tpAxis = "#8b6f3a", tpText = "#1a1620", tpGrid = "#e0d6c0" + , tpDefault = "#f0a5a0", tpDefaultFill = "#f0a5a0", tpPanelBg = "#f8f5ee" + , tpShowPanel = True, tpShowGrid = True, tpShowBorder = False, tpShowAxisLine = False + , tpTitleColor = "#1a1620", tpTitleHjust = 0.0, tpTickLineColor = "#8b6f3a", tpLegendKeyBg = "" } + -- 暗版 = Charcoal (中性炭、 Red Queen §4.8 Charcoal #2B2B2E 由来。 焦茶から変更 2026-06-02)。 + Graphics.Hgg.Spec.ThemeParchmentDark -> ThemePalette + { tpBackground = "#1e1e22", tpAxis = "#9aa0a8", tpText = "#d6d8dd", tpGrid = "#42424a" + , tpDefault = "#f0a5a0", tpDefaultFill = "#f0a5a0", tpPanelBg = "#2a2a30" + , tpShowPanel = True, tpShowGrid = True, tpShowBorder = False, tpShowAxisLine = False + , tpTitleColor = "#d6d8dd", tpTitleHjust = 0.0, tpTickLineColor = "#9aa0a8", tpLegendKeyBg = "" } + -- ggplot theme_bw: 白背景・薄グレー grid・黒灰の 4 辺枠 (軸線なし)。 + Graphics.Hgg.Spec.ThemeBW -> ThemePalette + { tpBackground = "#ffffff", tpAxis = "#333333", tpText = "#4d4d4d", tpGrid = "#ebebeb" + , tpDefault = "#353535", tpDefaultFill = "#353535", tpPanelBg = "#ffffff" + , tpShowPanel = False, tpShowGrid = True, tpShowBorder = True, tpShowAxisLine = False + , tpTitleColor = "#4d4d4d", tpTitleHjust = 0.0, tpTickLineColor = "#333333", tpLegendKeyBg = "" } + -- ggplot theme_classic: 白背景・grid なし・枠なし・下/左の 2 軸線あり。 + Graphics.Hgg.Spec.ThemeClassic -> ThemePalette + { tpBackground = "#ffffff", tpAxis = "#333333", tpText = "#4d4d4d", tpGrid = "#ffffff" + , tpDefault = "#353535", tpDefaultFill = "#353535", tpPanelBg = "#ffffff" + , tpShowPanel = False, tpShowGrid = False, tpShowBorder = False, tpShowAxisLine = True + , tpTitleColor = "#4d4d4d", tpTitleHjust = 0.0, tpTickLineColor = "#333333", tpLegendKeyBg = "" } + -- ggplot theme_void: 背景・grid・枠・軸線すべてなし (データのみ)。 + Graphics.Hgg.Spec.ThemeVoid -> ThemePalette + { tpBackground = "#ffffff", tpAxis = "#4d4d4d", tpText = "#4d4d4d", tpGrid = "#ffffff" + , tpDefault = "#353535", tpDefaultFill = "#353535", tpPanelBg = "#ffffff" + , tpShowPanel = False, tpShowGrid = False, tpShowBorder = False, tpShowAxisLine = False + , tpTitleColor = "#4d4d4d", tpTitleHjust = 0.0, tpTickLineColor = "#4d4d4d", tpLegendKeyBg = "" } + -- ggplot theme_linedraw: 白背景・黒寄り細 grid・黒の 4 辺枠。 + Graphics.Hgg.Spec.ThemeLinedraw -> ThemePalette + { tpBackground = "#ffffff", tpAxis = "#000000", tpText = "#1a1a1a", tpGrid = "#b3b3b3" + , tpDefault = "#000000", tpDefaultFill = "#000000", tpPanelBg = "#ffffff" + , tpShowPanel = False, tpShowGrid = True, tpShowBorder = True, tpShowAxisLine = False + , tpTitleColor = "#1a1a1a", tpTitleHjust = 0.0, tpTickLineColor = "#000000", tpLegendKeyBg = "" } + +-- | Phase 9 A-2: preset palette に ThemeOverride を合成 (element 単位上書き)。 +-- 各 override field が Just なら preset 値を差し替える。 描画は合成後の値のみ参照。 +resolveTheme :: Graphics.Hgg.Spec.ThemeName -> ThemeOverride -> ThemePalette +resolveTheme name ov = + let base = themePalette name + in base + { tpBackground = ovT toPlotBg (tpBackground base) + , tpPanelBg = ovT toPanelBg (tpPanelBg base) + , tpShowPanel = ovB toShowPanel (tpShowPanel base) + , tpGrid = ovT toGridColor (tpGrid base) + , tpShowGrid = ovB toShowGrid (tpShowGrid base) + , tpShowBorder = ovB toShowBorder (tpShowBorder base) + , tpShowAxisLine = ovB toShowAxisLine (tpShowAxisLine base) + , tpAxis = ovT toAxisColor (tpAxis base) + , tpText = ovT toTextColor (tpText base) + -- ★ Phase 43 A4: プリセット専用だった 4 項目の上書き合成。 + , tpTitleHjust = ovD toTitleHjust (tpTitleHjust base) + , tpTitleColor = ovT toTitleColor (tpTitleColor base) + , tpTickLineColor = ovT toTickLineColor (tpTickLineColor base) + , tpLegendKeyBg = ovT toLegendKeyBg (tpLegendKeyBg base) + } + where + ovT f d = fromMaybe d (getLast (f ov)) + ovB f d = fromMaybe d (getLast (f ov)) + ovD f d = fromMaybe d (getLast (f ov)) + +-- | spec の theme + override を解決して ThemePalette を得る (全 render 経路の入口)。 +specThemePalette :: VisualSpec -> ThemePalette +specThemePalette spec = + resolveTheme (fromMaybe Graphics.Hgg.Spec.ThemeDefault (getLast (vsTheme spec))) + (vsThemeOverride spec) + +-- | Phase 9 A-4: facet strip.background の (塗り色, 表示) を解決。 ggplot は殆どの preset で +-- 灰矩形 (grey85 #d9d9d9)、 theme_minimal / theme_void は strip 矩形なし。 panel 塗り系 +-- (dark/noir/canvas-dark) は panel より少し明るい/暗い帯。 override (toStripBg/toShowStrip) 優先。 +themeStripStyle :: VisualSpec -> (Text, Bool) +themeStripStyle spec = + let name = fromMaybe Graphics.Hgg.Spec.ThemeDefault (getLast (vsTheme spec)) + ov = vsThemeOverride spec + (dbg, dshow) = case name of + Graphics.Hgg.Spec.ThemeMinimal -> ("#d9d9d9", False) + Graphics.Hgg.Spec.ThemeVoid -> ("#ffffff", False) + Graphics.Hgg.Spec.ThemeLight -> ("#e0e0e0", True) + Graphics.Hgg.Spec.ThemeDark -> ("#3a3a3a", True) + Graphics.Hgg.Spec.ThemeNoir -> ("#2a2e45", True) + Graphics.Hgg.Spec.ThemeLumen -> ("#ece8e0", True) + Graphics.Hgg.Spec.ThemeParchment -> ("#ece0c8", True) + Graphics.Hgg.Spec.ThemeParchmentDark -> ("#3a3a42", True) + _ -> ("#d9d9d9", True) -- default/grey/bw/classic/linedraw + bg = fromMaybe dbg (getLast (toStripBg ov)) + shw = fromMaybe dshow (getLast (toShowStrip ov)) + in (bg, shw) + +-- | Scale の range (= pixel 出力域) を別 Rect に合わせて作り直す。 domain は不変。 +-- plot area を縮める時 (subplot / marginal) は plotArea だけでなく scale の range も +-- 必ず合わせないと、 mark の位置が古い枠基準のまま描かれて軸枠からはみ出す +-- (= ggplot で panel が動けば座標変換も追従するのと同じ原則)。 +scaleRetargetX :: Graphics.Hgg.Layout.Scale -> Rect -> Graphics.Hgg.Layout.Scale +scaleRetargetX scale rect = case scale of + LinearScale lo hi _ _ -> LinearScale lo hi (rX rect) (rX rect + rW rect) + LogScale lo hi _ _ -> LogScale lo hi (rX rect) (rX rect + rW rect) + SqrtScale lo hi _ _ -> SqrtScale lo hi (rX rect) (rX rect + rW rect) + TimeScale lo hi _ _ -> TimeScale lo hi (rX rect) (rX rect + rW rect) + +scaleRetargetY :: Graphics.Hgg.Layout.Scale -> Rect -> Graphics.Hgg.Layout.Scale +scaleRetargetY scale rect = case scale of + LinearScale lo hi _ _ -> LinearScale lo hi (rY rect + rH rect) (rY rect) + LogScale lo hi _ _ -> LogScale lo hi (rY rect + rH rect) (rY rect) + SqrtScale lo hi _ _ -> SqrtScale lo hi (rY rect + rH rect) (rY rect) + TimeScale lo hi _ _ -> TimeScale lo hi (rY rect + rH rect) (rY rect) + +-- | TODO-3b (2026-05-29): C-5 grid line 描画。 PS Render.purs:gridLines を +-- HS に port。 vsXAxis / vsYAxis の axShowGrid が True なら x/y tick 位置に +-- 薄い grid line を描く。 default false (= 旧 HS 挙動と互換)。 +gridLines :: Layout -> VisualSpec -> ThemePalette -> [Primitive] +gridLines layout spec pal = + let area = lpPlotArea layout + coord = coordOf spec + sx = scaleApply (lpXScale layout) + sy = scaleApply (lpYScale layout) + -- Phase 9 C: flip 時はデータ x が縦 px・データ y が横 px に写る。 + sxF = scaleApply (lpXScaleFlipped layout) + syF = scaleApply (lpYScaleFlipped layout) + majorStyle = solid (tpGrid pal) 1.0 + minorStyle = solid (tpGrid pal) 0.5 -- G4: minor は major の半分の太さ (ggplot 準拠) + -- Phase 8 C G4: ggplot theme は既定で grid 表示。 axShowGrid 未指定 (Nothing) は + -- 旧 False → True に (白背景 + 薄グレー major+minor grid = theme_bw/minimal 風)。 + showXGrid = case getLast (axShowGrid (axisOrDef (vsXAxis spec))) of + Just b -> b + Nothing -> True + showYGrid = case getLast (axShowGrid (axisOrDef (vsYAxis spec))) of + Just b -> b + Nothing -> True + xLo = rX area; xHi = rX area + rW area + yLo = rY area; yHi = rY area + rH area + withinX p = p >= min xLo xHi - 1e-6 && p <= max xLo xHi + 1e-6 + withinY p = p >= min yLo yHi - 1e-6 && p <= max yLo yHi + 1e-6 + -- categorical 軸は minor grid 無し (= ggplot 離散軸は major のみ)。 + catX = not (null (lpXCategoryLabels layout)) + catY = not (null (lpYCategoryLabels layout)) + -- Cartesian は現行と bit 一致。 Flip はデータ x grid を横線・データ y grid を縦線に。 + (majorX, minorX, majorY, minorY) = case coord of + CoordCartesian -> + ( [ PLine (Point (sx v) yLo) (Point (sx v) yHi) majorStyle | v <- lpXTicks layout ] + , if catX then [] + else [ PLine (Point (sx v) yLo) (Point (sx v) yHi) minorStyle + | v <- minorBreaksFor (lpXScale layout) (lpXTicks layout), withinX (sx v) ] + , [ PLine (Point xLo (sy v)) (Point xHi (sy v)) majorStyle | v <- lpYTicks layout ] + , if catY then [] + else [ PLine (Point xLo (sy v)) (Point xHi (sy v)) minorStyle + | v <- minorBreaksFor (lpYScale layout) (lpYTicks layout), withinY (sy v) ] ) + CoordFlip -> + ( [ PLine (Point xLo (sxF v)) (Point xHi (sxF v)) majorStyle | v <- lpXTicks layout ] + , if catX then [] + else [ PLine (Point xLo (sxF v)) (Point xHi (sxF v)) minorStyle + | v <- minorBreaksFor (lpXScale layout) (lpXTicks layout), withinY (sxF v) ] + , [ PLine (Point (syF v) yLo) (Point (syF v) yHi) majorStyle | v <- lpYTicks layout ] + , if catY then [] + else [ PLine (Point (syF v) yLo) (Point (syF v) yHi) minorStyle + | v <- minorBreaksFor (lpYScale layout) (lpYTicks layout), withinX (syF v) ] ) + -- Phase 11 A7-c: 極座標の grid は polarGrid (= 同心円 + 放射スポーク) が描く。 + _ -> ([], [], [], []) + -- minor を先に (= major が上に乗る)。 grid 全体は layer の下 (描画順は呼出側)。 + -- Phase 9 A-1: theme レベルの grid master (tpShowGrid) が False なら全 grid 抑制。 + gx = if tpShowGrid pal && showXGrid then minorX ++ majorX else [] + gy = if tpShowGrid pal && showYGrid then minorY ++ majorY else [] + in gx <> gy + where + axisOrDef la = case getLast la of + Just sp -> sp + Nothing -> mempty + -- Phase 9 A-5 fix: minor breaks を scale 別に算出。 旧実装は一様 step (b-a) 前提で、 + -- log/sqrt の非一様 major tick に当てると変な位置に線が出ていた。 + -- * Linear/Time : major tick 間の中点 + 両端 half-step (ggplot 既定 minor)。 + -- * Log : 各 decade の 2..9 ×10^n (= ggplot log minor grid)。 + -- * Sqrt : 連続 major 間の sqrt 空間中点 (((√a+√b)/2)²)。 + -- panel 外は呼出側 within* で除外。 + minorBreaksFor :: Scale -> [Double] -> [Double] + minorBreaksFor scale ts = case scale of + LogScale dLo dHi _ _ | dLo > 0, dHi > 0 -> + let lo = min dLo dHi; hi = max dLo dHi + in [ val | e <- [floor (logBase 10 lo) .. ceiling (logBase 10 hi)] + , k <- [2,3,4,5,6,7,8,9] :: [Double] + , let val = k * 10 ** fromIntegral (e :: Int) + , val >= lo, val <= hi ] + SqrtScale dLo dHi _ _ | dLo >= 0, dHi >= 0 -> + [ ((sqrt a + sqrt b) / 2) ** 2 | (a, b) <- zip ts (drop 1 ts) ] + _ -> uniformMid ts + uniformMid ts = case ts of + (a : b : _) -> let step = b - a in [ t - step / 2 | t <- ts ] ++ [ last ts + step / 2 ] + _ -> [] + +-- | Phase 11 A7-c: 極座標の grid + 軸 (= 直交 gridLines/axisFrame/tickMarks の代わり)。 +-- 半径方向 = 同心円 (rad tick ごと) + 中心からの r 軸ラベル (上スポーク沿い)。 +-- 角度方向 = 放射スポーク (theta tick ごと) + 外周の角度ラベル。 +-- theta 軸は PolarX なら x、 PolarY なら y。 +polarGrid :: VisualSpec -> Layout -> ThemePalette -> [Primitive] +polarGrid spec layout pal = + let coord = coordOf spec + (cx, cy, maxR) = polarCenter layout + gridCol = tpGrid pal + circleStyle = Just (StrokeStyle gridCol 0.5) + noFill = FillStyle gridCol 0.0 + spokeStyle = solid gridCol 0.5 + -- theta / radius を担う scale と tick / category ラベルを coord で選ぶ。 + (thetaScale, thetaTicks, thetaCats, radScale, radTicks) = case coord of + CoordPolarY -> ( lpYScale layout, lpYTicks layout, lpYCategoryLabels layout + , lpXScale layout, lpXTicks layout ) + _ -> ( lpXScale layout, lpXTicks layout, lpXCategoryLabels layout + , lpYScale layout, lpYTicks layout ) + inUnit f = f >= -1e-9 && f <= 1 + 1e-9 + -- 同心円 (半径 grid)。 domFrac が [0,1] のものだけ。 + circles = [ PCircle (Point cx cy) (domFrac radScale v * maxR) noFill circleStyle Nothing + | v <- radTicks, inUnit (domFrac radScale v) ] + -- 外周境界円。 + boundary = [ PCircle (Point cx cy) maxR noFill (Just (StrokeStyle (tpAxis pal) 1.0)) Nothing ] + -- 放射スポーク (角度 grid)。 中心→外周。 + spokes = [ PLine (Point cx cy) (uncurry Point (polarPointXY (domFrac thetaScale v) 1.0)) spokeStyle + | v <- thetaTicks ] + -- r 軸ラベル (上スポーク θ=0 沿い、 各 rad tick)。 + tsR = mkFontTS (Just spec) pal TickF AnchorEnd 0 + radLabels = [ PText (Point (cx - 4) (cy - domFrac radScale v * maxR + 4)) (numToText v) tsR + | v <- radTicks, inUnit (domFrac radScale v), domFrac radScale v > 1e-6 ] + -- θ 軸ラベル (外周のやや外、 各 theta tick)。 categorical なら群名、 でなければ値。 + tsT = mkFontTS (Just spec) pal TickF AnchorMiddle 0 + thetaLabelFor i v = if not (null thetaCats) && i < length thetaCats + then thetaCats !! i else numToText v + thetaLabels = [ let (lx, ly) = polarPointXY (domFrac thetaScale v) 1.12 + in PText (Point lx (ly + 4)) (thetaLabelFor i v) tsT + | (i, v) <- zip [0 ..] thetaTicks ] + polarPointXY tf rf = polarPoint layout tf rf + in if tpShowGrid pal then circles <> spokes <> boundary <> radLabels <> thetaLabels + else boundary <> radLabels <> thetaLabels + +-- | Phase 11 A7-c: 極座標の bar = 扇形 (annular sector)。 (角度 frac tf0..tf1、 半径 +-- frac rf0..rf1) を弧近似 (約 0.1 rad/seg) した閉路 PathSegment を返す。 pie (rf0=0) +-- は中心からの扇形、 rose (rf0=0, 角度帯) は円形棒。 HS/PS 同一。 +wedgeSegments :: Layout -> Double -> Double -> Double -> Double -> [PathSegment] +wedgeSegments l tf0 tf1 rf0 rf1 = + let dθ = abs (tf1 - tf0) * 2 * pi + nSeg = max 2 (ceiling (dθ / 0.1)) :: Int + steps = [ tf0 + (tf1 - tf0) * fromIntegral i / fromIntegral nSeg | i <- [0 .. nSeg] ] + mk t rf = uncurry Point (polarPoint l t rf) + outer = [ mk t rf1 | t <- steps ] + inner = [ mk t rf0 | t <- reverse steps ] + in case outer ++ inner of + (p0 : rest) -> MoveTo p0 : map LineTo rest ++ [ClosePath] + [] -> [] + +fromMaybe :: a -> Maybe a -> a +fromMaybe d Nothing = d +fromMaybe _ (Just v) = v + +-- --------------------------------------------------------------------------- +-- 軸 / tick +-- --------------------------------------------------------------------------- + +background :: Layout -> ThemePalette -> [Primitive] +background layout pal = + let ViewportSize w h = lpViewport layout + in [ PRect (Rect 0 0 (fromIntegral w) (fromIntegral h)) + (FillStyle (tpBackground pal) 1.0) + Nothing ] + +-- | Phase 9 A-1: panel (plotArea) 背景の塗り経路。 theme_grey / ブランドは灰/暗の +-- panel 矩形を塗り、 その上に白/淡色 grid を重ねる (ggplot theme_grey 構造)。 +-- tpShowPanel が False の preset では何も描かない (= 従来の白背景挙動を温存)。 +panelBackground :: Layout -> ThemePalette -> [Primitive] +panelBackground layout pal + | tpShowPanel pal = [ PRect (lpPlotArea layout) (FillStyle (tpPanelBg pal) 1.0) Nothing ] + | otherwise = [] + +-- | axisFrame: panel の 4 辺枠。 tpShowBorder が False の theme (grey / ブランド) では +-- 枠を描かない (= ggplot theme_grey は border なし)。 +-- axisLine (下辺=x軸 + 左辺=y軸 の 2 本) は theme_classic 用に tpShowAxisLine で出す。 +-- border と axisLine は排他ではないが、 classic は border なし + axisLine ありの組合せ。 +axisFrame :: Layout -> ThemePalette -> [Primitive] +axisFrame layout pal = border ++ axisLine + where + a = lpPlotArea layout + border | tpShowBorder pal = + [ PRect a (FillStyle (tpBackground pal) 0) (Just (StrokeStyle (tpAxis pal) 1.0)) ] + | otherwise = [] + axisLine | tpShowAxisLine pal = + [ PLine (Point (rX a) (rY a + rH a)) (Point (rX a + rW a) (rY a + rH a)) (solid (tpAxis pal) 1.0) + , PLine (Point (rX a) (rY a)) (Point (rX a) (rY a + rH a)) (solid (tpAxis pal) 1.0) ] + | otherwise = [] + +-- | TODO-3 (2026-05-29): axRotate / axShowTicks 対応 (= PS Render.tickMarksWithShow port)。 +-- TODO-10 (2026-05-29): mSpec を thread して tick font (= spec.tickFont) を反映。 +-- rotX/rotY は度数 (0 = 水平、 90 = 縦)。 showX/showY が False の軸は tick line + label を省略。 +tickMarks :: Maybe VisualSpec -> Layout -> ThemePalette + -> Maybe AxisFormat -> Maybe AxisFormat + -> Double -> Double -> Bool -> Bool -> [Primitive] +tickMarks mSpec layout pal fmtX fmtY rotX rotY showX showY = + let a = lpPlotArea layout + sx = lpXScale layout + sy = lpYScale layout + ts = mkFontTS mSpec pal TickF AnchorMiddle 0 + tsY = ts { tsAnchor = AnchorEnd } + -- ★ 回転 x ラベルの anchor は回転符号で決める (pivot = 軸直下)。 rotX は **CCW 正 canonical**。 + -- rotX>0 (CCW・下→上読み) = AnchorEnd で軸下へ垂れる (y 軸タイトルと同じ向き)。 + -- rotX<0 (CCW 負 = CW・上→下読み) = AnchorStart。 (Phase 50 A1: CCW 化で符号条件を反転) + tsXrot = ts { tsAnchor = if rotX < 0 then AnchorStart else AnchorEnd + , tsRotate = rotX } + tsYrot = tsY { tsRotate = rotY } + -- ★ Phase 8 A2 Step1: tick 線長 / ラベル位置を computeLayout と同じ sc・定数で + -- 算出 (design §D-3)。 tickSize は実フォント値、 gap は sc 倍してマージン予約に整合。 + sc = lpMarginScale layout + tickSize = tsSize ts + tkLen = ggTickLen * sc + tkGap = (ggTickLen + ggAxTextMar) * sc + -- Phase 32 (re-apply): 目盛線 (tick mark) は tpTickLineColor (ggplot=grey20)。 + -- 軸線/枠 (axisFrame) は tpAxis のままで別物。 + tickStyle = solid (tpTickLineColor pal) 1.0 + xCats = lpXCategoryLabels layout + yCats = lpYCategoryLabels layout + -- ★ Phase 11 A4-d: 明示ラベル override。 lpXTicks と 1:1 対応 (computeLayout で censor + -- 済) なので tick 値で lookup (exact Eq、 値は lpXTicks 由来で同一)。 + xLabsOv = lpXTickLabels layout + yLabsOv = lpYTickLabels layout + -- ★ Phase 34: AxisFormat 未指定の数値軸は break ベクトル全体を ggplot/base-R + -- format() 準拠で整形 (formatTicksGG)。 単値の formatTick (numToText) では + -- 小数桁が揃わず "0.5"/"0.50" 不整合・指数選択も無かった。 + xDefMap = zip (lpXTicks layout) (formatTicksGG (lpXTicks layout)) + yDefMap = zip (lpYTicks layout) (formatTicksGG (lpYTicks layout)) + defLabelX v = case fmtX of + Nothing -> maybe (formatTick fmtX v) id (lookup v xDefMap) + Just _ -> formatTick fmtX v + defLabelY v = case fmtY of + Nothing -> maybe (formatTick fmtY v) id (lookup v yDefMap) + Just _ -> formatTick fmtY v + -- categorical なら integer position v を category label にマップ。 override 優先。 + xLabel v + | not (null xLabsOv) = case lookup v (zip (lpXTicks layout) xLabsOv) of + Just l -> l + Nothing -> defLabelX v + | null xCats = defLabelX v + | otherwise = case lookup (round v :: Int) (zip [0..] xCats) of + Just l -> l + Nothing -> defLabelX v + yLabel v + | not (null yLabsOv) = case lookup v (zip (lpYTicks layout) yLabsOv) of + Just l -> l + Nothing -> defLabelY v + | null yCats = defLabelY v + | otherwise = case lookup (round v :: Int) (zip [0..] yCats) of + Just l -> l + Nothing -> defLabelY v + xMark v = + let px = scaleApply sx v + yb = rY a + rH a + in [ PLine (Point px yb) (Point px (yb + tkLen)) tickStyle + -- Phase 8 C (small-viewport text fix): フォント由来オフセット (tickSize*k) は + -- 等倍 (tkGap = sc*間隔 のみ scale)。 旧 *sc で小パネル時に数値が軸に被っていた。 + , if rotX == 0 + then PText (Point px (yb + tkGap + tickSize * 0.8)) (xLabel v) ts + else PText (Point px (yb + tkGap + tickSize * 0.4)) (xLabel v) tsXrot + ] + yMark v = + let py = scaleApply sy v + xl = rX a + in [ PLine (Point xl py) (Point (xl - tkLen) py) tickStyle + , PText (Point (xl - tkGap) (py + tickSize * 0.35)) (yLabel v) tsYrot ] + -- Phase 9 C flip: データ x 軸を左辺に (= yMark 風)、 データ y 軸を下辺に (= xMark 風)。 + -- ラベルは水平のまま (anchor のみ placement に対応)。 sxF=データ x→縦 px、 syF=データ y→横 px。 + coord = maybe CoordCartesian coordOf mSpec + sxF = lpXScaleFlipped layout + syF = lpYScaleFlipped layout + xMarkFlip v = + let py = scaleApply sxF v + xl = rX a + in [ PLine (Point xl py) (Point (xl - tkLen) py) tickStyle + , PText (Point (xl - tkGap) (py + tickSize * 0.35)) (xLabel v) tsY ] + yMarkFlip v = + let px = scaleApply syF v + yb = rY a + rH a + in [ PLine (Point px yb) (Point px (yb + tkLen)) tickStyle + , PText (Point px (yb + tkGap + tickSize * 0.8)) (yLabel v) ts ] + (xMarkF, yMarkF) = case coord of + CoordFlip -> (xMarkFlip, yMarkFlip) + _ -> (xMark, yMark) + -- Phase 11 A7-c: 極座標の tick は polarGrid が描く (= 直交辺の tick は出さない)。 + xPrims = if showX && not (isPolar coord) then concatMap xMarkF (lpXTicks layout) else [] + yPrims = if showY && not (isPolar coord) then concatMap yMarkF (lpYTicks layout) else [] + in xPrims <> yPrims + +-- | AxisFormat に応じて Double を表示文字列に。 Nothing = auto。 +-- +-- Phase 6 A7: 'AxisTimeFmt' は Double を unix epoch (= seconds since 1970 UTC) と +-- 解釈し、 Data.Time.formatTime で format 文字列を適用。 +formatTick :: Maybe AxisFormat -> Double -> Text +formatTick fmt v = case fmt of + Nothing -> numToText v + Just AxisIntegerFmt -> T.pack (show (round v :: Int)) + Just (AxisDecimalFmt n) -> T.pack (showFFloat (Just n) v "") + Just (AxisExponentFmt n) -> T.pack (showEFloat (Just n) v "") + Just (AxisTimeFmt pat) -> + let utc = posixSecondsToUTCTime (realToFrac v) + defLocale = Data.Time.Format.defaultTimeLocale + in T.pack (Data.Time.Format.formatTime defLocale (T.unpack pat) utc) + +labels :: Layout -> VisualSpec -> ThemePalette -> [Primitive] +labels layout spec pal = + let a = lpPlotArea layout + tsTitle = mkFontTS (Just spec) pal TitleF AnchorMiddle 0 + tsLabel = mkFontTS (Just spec) pal AxisLabelF AnchorMiddle 0 + tsLabelV = tsLabel { tsRotate = 90 } -- Phase 50 A1: CCW 正 canonical (y 軸タイトル = CCW 90 = 下→上) + cx = rX a + rW a / 2 + cy = rY a + rH a / 2 + -- ★ Phase 8 A2 Step1 (design §D-3): title/軸タイトルを viewport 端基準で配置。 + -- title は plot.margin(上) + ascent。 旧実装は plotArea 相対 (rY a -12) で、 + -- タイトルフォントを大きくすると上にはみ出していた (= A2 本丸)。 viewport 上端基準 + -- なので marginal-X 帯にも被らず B18 特例も不要に。 + sc = lpMarginScale layout + titleSize = tsSize tsTitle + labelSize = tsSize tsLabel + -- plotArea を基準にマージン箱の各辺を求める (subplots は viewport=0 でも panel 端で + -- 配置できるよう vpH/vpW ではなく plotArea ± lpMargin* を使う)。 + boxTop = rY a - lpMarginTop layout + boxBottom = rY a + rH a + lpMarginBottom layout + boxLeft = rX a - lpMarginLeft layout + hasTitle = case getLast (vsTitle spec) of Just _ -> True; _ -> False + titleBaseY = boxTop + sc * (ggHalfLine + titleSize * 0.8) + -- Phase 32 (re-apply): plot.title の水平揃え。 hjust=0 (ggplot theme_grey) は + -- panel 左端にアンカー開始、 それ以外 (既定 0.5) は従来通り中央。 + (titleX, tsTitle') = if tpTitleHjust pal <= 0.0 + then (rX a, tsTitle { tsAnchor = AnchorStart }) + else (cx, tsTitle) + titleP = case getLast (vsTitle spec) of + Just t -> [ PText (Point titleX titleBaseY) t tsTitle' ] + Nothing -> [] + -- x 軸タイトル = 最下要素。 baseline = 下 plot.margin の上 (= boxBottom - margin - descent)。 + xLP = case getLast (vsXLabel spec) of + Just t -> [ PText (Point cx (boxBottom - sc * (ggHalfLine + labelSize * 0.2))) t tsLabel ] + Nothing -> [] + -- y 軸タイトル = 最左要素 (rot -90)。 x = 左 plot.margin + ascent。 + yLP = case getLast (vsYLabel spec) of + Just t -> [ PText (Point (boxLeft + sc * (ggHalfLine + labelSize * 0.7)) cy) t tsLabelV ] + Nothing -> [] + -- ★ Phase 11 A5-a: subtitle (title 直下、 小フォント) / caption (図右下・ + -- 小フォント・右寄せ) / tag (左上隅・やや大・左寄せ太字)。 Layout の margin 予約 + -- ('hasSubtitle'/'hasCaption'/'hasTag') と座標を揃える。 + -- ★ subtitle の水平揃えは plot.title と同じ ('tpTitleHjust'): theme_grey は左寄せ。 + subSize = 11 :: Double + capSize = 9 :: Double + tagSize = 13 :: Double + tsSub = (mkFontTS (Just spec) pal AxisLabelF AnchorMiddle 0) { tsSize = subSize } + tsCap = (mkFontTS (Just spec) pal AxisLabelF AnchorEnd 0) { tsSize = capSize } + tsTag = (mkFontTS (Just spec) pal TitleF AnchorStart 0) { tsSize = tagSize, tsWeight = "bold" } + boxRight = rX a + rW a + -- subtitle baseline: title があればその下、 無ければ title 位置に置く。 + subBaseY = (if hasTitle then titleBaseY + sc * ggHalfLine + subSize * 0.8 + else boxTop + sc * (ggHalfLine + subSize * 0.8)) + -- plot.title と同じ hjust 規則: hjust=0 (theme_grey) は panel 左端アンカー開始。 + (subX, tsSub') = if tpTitleHjust pal <= 0.0 + then (rX a, tsSub { tsAnchor = AnchorStart }) + else (cx, tsSub) + subP = case getLast (vsSubtitle spec) of + Just t -> [ PText (Point subX subBaseY) t tsSub' ] + Nothing -> [] + capP = case getLast (vsCaption spec) of + Just t -> [ PText (Point boxRight (boxBottom - sc * ggHalfLine)) t tsCap ] + Nothing -> [] + tagP = case getLast (vsTag spec) of + Just t -> [ PText (Point boxLeft (boxTop + sc * ggHalfLine + tagSize * 0.8)) t tsTag ] + Nothing -> [] + in titleP <> subP <> xLP <> yLP <> capP <> tagP + +-- ★ Phase 38: numToText は Layout へ集約 (Layout import 経由で使用)。 + +-- | Phase 8 B22: lpYScaleRight が Just のとき plotArea 右端に Y 軸線 + tick を描画 +-- (= PS renderRightYAxis と同方式)。 Nothing なら何も描かない。 +renderRightYAxis :: Layout -> ThemePalette -> Maybe AxisFormat -> [Primitive] +renderRightYAxis layout pal fmtYR = case lpYScaleRight layout of + Nothing -> [] + Just sR -> + let a = lpPlotArea layout + xR = rX a + rW a + ts = mkFontTS Nothing pal TickF AnchorStart 0 + axisStyle = solid (tpAxis pal) 1.0 + axisLine = [ PLine (Point xR (rY a)) (Point xR (rY a + rH a)) axisStyle ] + tickPrim v = + let py = scaleApply sR v + in [ PLine (Point xR py) (Point (xR + 5) py) axisStyle + , PText (Point (xR + 8) (py + 4)) (formatTick fmtYR v) ts ] + in axisLine <> concatMap tickPrim (lpYTicksRight layout) + +-- | Phase 10 A2: データ空間 (dx, dy) を coord に従い px の 'Point' に写す薄いラッパ。 +-- projectXY は生 tuple を返す (Layout は Render の Point に依存できない) ので、 +-- mark renderer 側はこのラッパで Point に包む。 coord = lpCoord layout を渡す前提で、 +-- Cartesian では `Point (scaleApply (lpXScale l) dx) (scaleApply (lpYScale l) dy)` と +-- bit 一致する (= 従来の `Point (sx x) (sy y)` と同値 → ゼロ diff)。 +projectPoint :: Coord -> Layout -> Double -> Double -> Point +projectPoint c l dx dy = let (px, py) = projectXY c l dx dy in Point px py + +-- | Phase 11 A7-c: 極座標を解さない standalone renderer (ess/autocorr/forest/funnel/ +-- box/violin/strip/swarm/waterfall = 直交/flip 専用 2-way 分岐) 用に coord を +-- {Cartesian, Flip} に正規化する (= polar はそれらの mark では Cartesian 扱い)。 +-- polar は座標系として点/線/扇形 bar に意味があり、 これらの統計 mark には適用しない。 +flipOnly :: Coord -> Coord +flipOnly CoordFlip = CoordFlip +flipOnly _ = CoordCartesian + +mean :: [Double] -> Double +mean [] = 0 +mean xs = sum xs / fromIntegral (length xs) + +median :: [Double] -> Double +median [] = 0 +median xs = + let s = sort xs + n = length xs + in if odd n then s !! (n `div` 2) + else (s !! (n `div` 2 - 1) + s !! (n `div` 2)) / 2 + +-- | Phase 11 A4-b: categorical 列を群キー列 [Text] に解決 (linetypeBy 用)。 +groupKeysOf :: Resolver -> ColRef -> Maybe [Text] +groupKeysOf r cr = case resolveCol r cr of + Just (TxtData v) -> Just (V.toList v) + Just (NumData v) -> Just (map (T.pack . show) (V.toList v)) + _ -> Nothing + +-- | キー列と値列を zip し、 キー初出順を保ったまま群ごとにまとめる (= group split)。 +orderedGroups :: Eq a => [a] -> [b] -> [(a, [b])] +orderedGroups keys vals = + let paired = zip keys vals + in [ (k, [ v | (k', v) <- paired, k' == k ]) | k <- nub keys ] + +-- | Phase 26 §C-2 #5: scatter 上に「点を結ぶ線」 を生成。 group 列があれば +-- group 内のみで連結、 order 列があればソート後に連結。 +renderConnect :: Resolver -> Layout -> ThemePalette -> Layer -> ConnectSpec + -> V.Vector Double -> V.Vector Double -> Int -> [Primitive] +renderConnect r layout pal ly cs xs ys n = + let color = case getLast (csColor cs) of + Just c -> c + Nothing -> staticColorOr ly (tpDefault pal) + width = case getLast (csWidth cs) of + Just w -> w + Nothing -> 1.5 + ls = solid color width + coord = lpCoord layout + pp = projectPoint coord layout + -- order: 指定があれば 数値順 sort、 無ければ index 順 + orderKey i = case getLast (csOrder cs) >>= resolveNum r of + Just v -> v V.!? i + Nothing -> Just (fromIntegral i) + -- group: 文字列列で partition、 無ければ全点 1 group + groupKey i = case getLast (csGroup cs) >>= resolveTxt r of + Just v -> v V.!? i + Nothing -> Just (T.pack "") + where + resolveTxt res cr = case resolveCol res cr of + Just (TxtData v) -> Just v + _ -> Nothing + idxs = [0 .. n - 1] + groupedSorted = + let withKey = [(g, o, i) | i <- idxs + , Just g <- [groupKey i] + , Just o <- [orderKey i]] + byGroup = groupBy (\(g1,_,_) (g2,_,_) -> g1 == g2) + (sortOn (\(g,_,_) -> g) withKey) + in [ map (\(_,_,i) -> i) (sortOn (\(_,o,_) -> o) grp) + | grp <- byGroup ] + segsForGroup is = + [ PLine (pp (xs V.! a) (ys V.! a)) + (pp (xs V.! b) (ys V.! b)) ls + | (a, b) <- zip is (drop 1 is) ] + in concatMap segsForGroup groupedSorted + +-- | Phase 26 §C-2 #3: plot area 内に参照線 1 本を描画。 +-- domain (= scale の dLo/dHi) を直接見て 2 端点を計算。 +-- | ★ Phase 33 B6: 参照線も 'resolvePosX'/'resolvePosY' (UCtx) 経由に統一。 +-- 値は PNative、panel 端は PNpc 0/1 で表す (出力は旧実装と bit 一致)。dpi は +-- PAbs Px 用 (参照線は使わないが UCtx 一貫のため受ける)。 +renderRefLine :: Double -> Layout -> ThemePalette -> ReferenceLine -> [Primitive] +renderRefLine dpi layout pal rl = + let uc = UCtx dpi (lpPlotArea layout) (lpXScale layout) (lpYScale layout) + rxp = resolvePosX uc + ryp = resolvePosY uc + ls = solid (tpAxis pal) 1.5 + (xLo, xHi) = case lpXScale layout of + LinearScale lo hi _ _ -> (lo, hi) + LogScale lo hi _ _ -> (lo, hi) + (yLo, yHi) = case lpYScale layout of + LinearScale lo hi _ _ -> (lo, hi) + LogScale lo hi _ _ -> (lo, hi) + in case rl of + RefIdentity -> + -- y = x ─ 交差範囲 [max xLo yLo, min xHi yHi] の対角線 + let lo = max xLo yLo; hi = min xHi yHi + in [ PLine (Point (rxp (PNative lo)) (ryp (PNative lo))) + (Point (rxp (PNative hi)) (ryp (PNative hi))) ls ] + RefHorizontalAt y -> + [ PLine (Point (rxp (PNpc 0)) (ryp (PNative y))) + (Point (rxp (PNpc 1)) (ryp (PNative y))) ls ] + RefVerticalAt x -> + [ PLine (Point (rxp (PNative x)) (ryp (PNpc 1))) + (Point (rxp (PNative x)) (ryp (PNpc 0))) ls ] + RefLinear sl ic -> + [ PLine (Point (rxp (PNative xLo)) (ryp (PNative (sl * xLo + ic)))) + (Point (rxp (PNative xHi)) (ryp (PNative (sl * xHi + ic)))) ls ] + +-- --------------------------------------------------------------------------- +-- 共通 helper +-- --------------------------------------------------------------------------- + +-- | 列を数値 Vector に解決。 **NA (NaN) を落とす** (nullable 列対応・ggplot na.rm +-- 相当)。 単一列 geom (histogram/freqpoly/density/box/ecdf 等) はこれで欠損を内部処理。 +-- 非 NULL 列 (NaN を含まない) には no-op なので従来挙動と同一。 +vecOr :: Last ColRef -> Resolver -> V.Vector Double +vecOr lc = V.filter (not . isNaN) . vecOrFull lc + +-- | 'vecOr' の NaN 保持版 (= 長さを保つ)。 **多列 geom (scatter/line) が x/y を +-- 行整列したまま欠損対を落とす**ために使う (per-column drop だと x/y がズレるため)。 +vecOrFull :: Last ColRef -> Resolver -> V.Vector Double +vecOrFull lc r = case getLast lc of + Nothing -> V.empty + Just cr -> maybe V.empty id (resolveNum r cr) + +-- | Okabe-Ito 8 色 categorical palette (= 色覚多様性配慮)。 +okabeIto :: [Text] +okabeIto = + [ "#E69F00", "#56B4E9", "#009E73", "#F0E442" + , "#0072B2", "#D55E00", "#CC79A7", "#000000" ] + +-- | layer の color encoding を point 数 n の Vector に展開。 +-- * 'ColorStatic' → 全 point 同色 +-- * 'ColorByCol' → 列 (txt or num) を distinct 値ごとに palette index 割当 +-- * encoding 無し → theme の default 色 +colorVector :: Resolver -> Layout -> ThemePalette -> Layer -> Int -> V.Vector Text +colorVector r layout pal ly n = + case getLast (lyColor ly) of + Just (ColorStatic c) -> V.replicate n c + Just (ColorByCol cr) -> + let vals = case resolveCol r cr of + Just (TxtData v) -> V.toList v + -- ★Phase 19: show でなく numToText (凡例 allColorCategories / PS と + -- 同じキー。 show だと "1.0" vs 凡例 "1" で union 注入時に引けない) + Just (NumData v) -> map numToText (V.toList v) + Nothing -> [] + -- TODO-3d (2026-05-29): trellis 色一貫性 (= PS Render.colorVector port)。 + -- lyColorCats が非空ならその順序で index、 空なら filtered resolver の + -- nub vals で旧挙動。 facet panel ごとに同 cat → 同色 を保つため。 + distinct = let cats = lyColorCats ly + in if null cats then orderedCats vals else cats + palArr = lpCategoricalPalette layout + -- ★ A4-e: scale_color_manual の辞書を最優先 (= 該当カテゴリ名→指定色)。 + -- 未登録名は従来の positional palette にフォールバック。 + manual = lpColorManual layout + colorOf t = case lookup t manual of + Just c -> c + Nothing -> case elemIndex t distinct of + Just i -> palArr !! (i `mod` length palArr) + Nothing -> tpDefault pal + mapped = map colorOf vals + filled = mapped <> replicate (max 0 (n - length mapped)) (tpDefault pal) + in V.fromList (take n filled) + Just (ColorByContinuous cr) -> + case resolveNum r cr of + Nothing -> V.replicate n (tpDefault pal) + Just v -> + let lo = V.minimum v + hi = V.maximum v + norm x = if hi <= lo then 0.5 else (x - lo) / (hi - lo) + -- ★ A4-e: scale_color_gradient2 = midpoint を 0.5 に固定する発散 (diverging) 写像。 + -- lo..mid を [0,0.5]・mid..hi を [0.5,1] に個別正規化し 3-stop palette を補間。 + colorAt x = case lpColorGradient2 layout of + Just (cLo, cMid, cHi, mid) -> + let t | x <= mid = if mid <= lo then 0 else 0.5 * (x - lo) / (mid - lo) + | otherwise = if hi <= mid then 1 else 0.5 + 0.5 * (x - mid) / (hi - mid) + in continuousColor [cLo, cMid, cHi] t + Nothing -> continuousColor (lpContinuousPalette layout) (norm x) + filled = map (\i -> case v V.!? i of + Just x -> colorAt x + Nothing -> tpDefault pal) + [0 .. n - 1] + in V.fromList filled + Nothing -> V.replicate n (tpDefault pal) + +-- | Viridis 風 5-stop gradient (= 簡易版、 perceptually uniform に近い)。 +-- t in [0, 1]。 +viridis :: Double -> Text +viridis = continuousColor + ["#440154", "#3B528B", "#21918C", "#5EC962", "#FDE725"] + +-- | P17: 任意 hex 配列の N-stop palette を t ∈ [0,1] で線形補間。 +-- layout.lpContinuousPalette を渡せば spec 指定の sequential が反映される。 +continuousColor :: [Text] -> Double -> Text +continuousColor palArr t = + let n = length palArr + clamp01 x = max 0 (min 1 x) + tc = clamp01 t + parseHex hex = case T.length hex of + 7 -> let r = parseHexByte (T.take 2 (T.drop 1 hex)) + g = parseHexByte (T.take 2 (T.drop 3 hex)) + b = parseHexByte (T.take 2 (T.drop 5 hex)) + in (r, g, b) + _ -> (128, 128, 128) + in case n of + 0 -> "#777777" + 1 -> head palArr + _ -> + let segments = fromIntegral (n - 1) :: Double + pos = tc * segments + i = max 0 (min (n - 2) (floor pos)) + ratio = pos - fromIntegral i + c1 = palArr !! i + c2 = palArr !! (i + 1) + (r1, g1, b1) = parseHex c1 + (r2, g2, b2) = parseHex c2 + lerp a b = round (fromIntegral a + (fromIntegral b - fromIntegral a) * ratio :: Double) :: Int + in rgbToHex (lerp r1 r2) (lerp g1 g2) (lerp b1 b2) + +parseHexByte :: Text -> Int +parseHexByte s = + let go acc c = case c of + c' | c' >= '0' && c' <= '9' -> acc * 16 + (fromEnum c' - fromEnum '0') + | c' >= 'a' && c' <= 'f' -> acc * 16 + (fromEnum c' - fromEnum 'a' + 10) + | c' >= 'A' && c' <= 'F' -> acc * 16 + (fromEnum c' - fromEnum 'A' + 10) + | otherwise -> acc + in T.foldl go 0 s + +rgbToHex :: Int -> Int -> Int -> Text +rgbToHex r g b = T.pack ("#" <> hex r <> hex g <> hex b) + where + hex n = let s = showHex (max 0 (min 255 n)) "" + in if length s == 1 then '0':s else s + showHex = showHexBase + +showHexBase :: Int -> String -> String +showHexBase 0 acc = if null acc then "0" else acc +showHexBase n acc = + let (q, rem_) = n `divMod` 16 + ch = "0123456789abcdef" !! rem_ + in showHexBase q (ch : acc) + +doubleOr :: Last Double -> Double -> Double +doubleOr l d = case getLast l of Just v -> v; Nothing -> d + +staticColorOr :: Layer -> Text -> Text +staticColorOr ly defaultC = case getLast (lyColor ly) of + Just (ColorStatic c) -> c + _ -> defaultC + +-- --------------------------------------------------------------------------- +-- TODO-3c (2026-05-29): jitter / shape / sizeBy helpers (= PS Render port) +-- --------------------------------------------------------------------------- + +-- | P14 PS port: deterministic pseudo-random ∈ [0,1) from Int seed。 +-- sin-hash トリック (= classic JS shadertoy)。 同 seed で常に同値。 +hashRand :: Int -> Double +hashRand i = + let s = sin (fromIntegral i * 12.9898) * 43758.5453 + f = fromIntegral (floor s :: Int) + in s - f + +-- | C-6 PS port: shape を Primitive (PCircle or PPath) に変換。 +-- MShCircle は PCircle (= hover label 付き)、 他は PPath。 +shapeToPrim :: MarkShape -> Point -> Double -> FillStyle -> Maybe StrokeStyle + -> Maybe Text -> Primitive +shapeToPrim sh pt sz fs ms label = case sh of + MShCircle -> PCircle pt sz fs ms label + _ -> PPath (shapePath sh pt sz) fs ms + +-- | C-6 PS port: shape 別 path 構築 (= PathSegment 列、 bezier 近似含む)。 +shapePath :: MarkShape -> Point -> Double -> [PathSegment] +shapePath sh (Point cx cy) r = case sh of + MShCircle -> [] + MShSquare -> + [ MoveTo (Point (cx - r) (cy - r)) + , LineTo (Point (cx + r) (cy - r)) + , LineTo (Point (cx + r) (cy + r)) + , LineTo (Point (cx - r) (cy + r)) + , ClosePath ] + MShTriangle -> + [ MoveTo (Point cx (cy - r)) + , LineTo (Point (cx + r) (cy + r)) + , LineTo (Point (cx - r) (cy + r)) + , ClosePath ] + MShCross -> + let t = r * 0.4 + in [ MoveTo (Point (cx - t) (cy - r)) + , LineTo (Point (cx + t) (cy - r)) + , LineTo (Point (cx + t) (cy - t)) + , LineTo (Point (cx + r) (cy - t)) + , LineTo (Point (cx + r) (cy + t)) + , LineTo (Point (cx + t) (cy + t)) + , LineTo (Point (cx + t) (cy + r)) + , LineTo (Point (cx - t) (cy + r)) + , LineTo (Point (cx - t) (cy + t)) + , LineTo (Point (cx - r) (cy + t)) + , LineTo (Point (cx - r) (cy - t)) + , LineTo (Point (cx - t) (cy - t)) + , ClosePath ] + -- トランプのスーツ (独自拡張・ggplot に無い拡張)。 形は + -- htdebeer/SVG-cards (public domain) の vetted パスを移植し、 全 subpath を + -- 同一巻き方向 (CCW) に正規化 + bbox 正規化 (最大辺 ±1) して r 内に収めた。 + -- nonzero fill で複合パスが union=ベタになる (中央の穴/塗り規則依存を回避)。 + -- 座標は /tmp/suit_emit.py で生成 (HS=PS 同一リテラル → byte parity)。 + -- ダイヤは通常の菱形を廃しトランプ型のみ・ハートは上下反転 (ユーザ要望)。 + MShHeart -> -- ★ ユーザ要望 (2026-06-21): 上下反転 (尖りが上) + let p dx dy = Point (cx + dx * r) (cy + dy * r) + in + [ MoveTo (p (-0.9660) (-0.4940)) + , CurveTo (p (-0.9648) (-0.7734)) (p (-0.7483) (-1.0000)) (p (-0.4814) (-0.9987)) + , CurveTo (p (-0.2159) (-0.9987)) (p (-0.0006) (-0.7722)) (p (-0.0006) (-0.4915)) + , CurveTo (p (-0.0006) (-0.7709)) (p 0.2171 (-0.9962)) (p 0.4840 (-0.9962)) + , CurveTo (p 0.7495 (-0.9962)) (p 0.9660 (-0.7684)) (p 0.9648 (-0.4890)) + , CurveTo (p 0.9597 0.1038) (p 0.2159 0.5318) (p (-0.0044) 1.0000) + , CurveTo (p (-0.2222) 0.5305) (p (-0.9648) 0.0988) (p (-0.9660) (-0.4940)) + , ClosePath ] + MShDiamond -> -- ★ トランプのダイヤ (通常の菱形は廃止、 これが唯一のダイヤ) + let p dx dy = Point (cx + dx * r) (cy + dy * r) + in + [ MoveTo (p 0.0000 1.0000) + , CurveTo (p (-0.0018) 0.8736) (p (-0.0739) 0.7597) (p (-0.1426) 0.6584) + , CurveTo (p (-0.2897) 0.4572) (p (-0.4759) 0.2851) (p (-0.6748) 0.1351) + , CurveTo (p (-0.7634) 0.0762) (p (-0.8571) 0.0049) (p (-0.9673) 0.0000) + , CurveTo (p (-0.6448) 0.0000) (p (-0.3224) 0.0000) (p 0.0000 0.0000) + , MoveTo (p (-0.9673) 0.0000) + , CurveTo (p (-0.8275) (-0.0044)) (p (-0.7081) (-0.0934)) (p (-0.6015) (-0.1754)) + , CurveTo (p (-0.4132) (-0.3335)) (p (-0.2503) (-0.5215)) (p (-0.1127) (-0.7251)) + , CurveTo (p (-0.0622) (-0.8093)) (p (-0.0028) (-0.8986)) (p 0.0000 (-1.0000)) + , CurveTo (p 0.0000 (-0.6666)) (p 0.0000 (-0.3334)) (p 0.0000 0.0000) + , MoveTo (p 0.0000 (-1.0000)) + , CurveTo (p 0.0048 (-0.8511)) (p 0.0955 (-0.7222)) (p 0.1811 (-0.6071)) + , CurveTo (p 0.3338 (-0.4169)) (p 0.5146 (-0.2486)) (p 0.7136 (-0.1079)) + , CurveTo (p 0.7909 (-0.0597)) (p 0.8730 (-0.0023)) (p 0.9673 0.0000) + , CurveTo (p 0.6448 0.0000) (p 0.3224 0.0000) (p 0.0000 0.0000) + , MoveTo (p 0.9673 0.0000) + , CurveTo (p 0.8275 0.0044) (p 0.7081 0.0933) (p 0.6015 0.1753) + , CurveTo (p 0.4132 0.3335) (p 0.2503 0.5215) (p 0.1127 0.7251) + , CurveTo (p 0.0622 0.8093) (p 0.0028 0.8986) (p 0.0000 1.0000) + , CurveTo (p 0.0000 0.6666) (p 0.0000 0.3334) (p 0.0000 0.0000) ] + MShSpade -> + let p dx dy = Point (cx + dx * r) (cy + dy * r) + in + [ MoveTo (p 0.8512 0.1009) + , CurveTo (p 0.8512 0.3077) (p 0.6620 0.4754) (p 0.4262 0.4754) + , CurveTo (p 0.1904 0.4754) (p 0.0000 0.3077) (p 0.0000 0.1009) + , CurveTo (p 0.0000 0.3077) (p (-0.1904) 0.4754) (p (-0.4250) 0.4754) + , CurveTo (p (-0.6608) 0.4754) (p (-0.8512) 0.3077) (p (-0.8512) 0.1009) + , CurveTo (p (-0.8499) (-0.3354)) (p (-0.1929) (-0.6532)) (p 0.0000 (-1.0000)) + , CurveTo (p 0.1929 (-0.6545)) (p 0.8499 (-0.3367)) (p 0.8512 0.1009) + , ClosePath + , MoveTo (p 0.4943 1.0000) + , LineTo (p (-0.4968) 1.0000) + , CurveTo (p (-0.0757) 1.0000) (p (-0.0555) 0.1009) (p (-0.0555) 0.1009) + , LineTo (p 0.0517 0.1021) + , CurveTo (p 0.0517 0.1021) (p 0.0567 0.3266) (p 0.1148 0.5511) + , CurveTo (p 0.1728 0.7755) (p 0.2837 1.0000) (p 0.4943 1.0000) + , ClosePath ] + MShClub -> + let p dx dy = Point (cx + dx * r) (cy + dy * r) + in + [ MoveTo (p 0.4219 (-0.5869)) + , CurveTo (p 0.4219 (-0.3589)) (p 0.2317 (-0.1738)) (p (-0.0038) (-0.1738)) + , CurveTo (p (-0.2393) (-0.1738)) (p (-0.4295) (-0.3589)) (p (-0.4295) (-0.5869)) + , CurveTo (p (-0.4295) (-0.8149)) (p (-0.2393) (-1.0000)) (p (-0.0038) (-1.0000)) + , CurveTo (p 0.2317 (-1.0000)) (p 0.4219 (-0.8149)) (p 0.4219 (-0.5869)) + , ClosePath + , MoveTo (p 0.9710 0.1952) + , CurveTo (p 0.9710 0.4232) (p 0.7809 0.6083) (p 0.5453 0.6083) + , CurveTo (p 0.3098 0.6083) (p 0.1196 0.4232) (p 0.1196 0.1952) + , CurveTo (p 0.1196 (-0.0327)) (p 0.3098 (-0.2179)) (p 0.5453 (-0.2179)) + , CurveTo (p 0.7809 (-0.2179)) (p 0.9710 (-0.0327)) (p 0.9710 0.1952) + , ClosePath + , MoveTo (p (-0.1196) 0.1977) + , CurveTo (p (-0.1196) 0.2809) (p (-0.1448) 0.3589) (p (-0.1889) 0.4244) + , CurveTo (p (-0.2645) 0.5365) (p (-0.3967) 0.6108) (p (-0.5453) 0.6108) + , CurveTo (p (-0.7809) 0.6108) (p (-0.9710) 0.4257) (p (-0.9710) 0.1977) + , CurveTo (p (-0.9710) (-0.0302)) (p (-0.7809) (-0.2154)) (p (-0.5453) (-0.2154)) + , CurveTo (p (-0.3098) (-0.2154)) (p (-0.1196) (-0.0302)) (p (-0.1196) 0.1977) + , ClosePath + , MoveTo (p 0.4962 1.0000) + , LineTo (p (-0.4950) 1.0000) + , CurveTo (p (-0.0743) 0.9987) (p (-0.0542) 0.3149) (p (-0.0542) 0.3149) + , LineTo (p 0.0542 0.3149) + , CurveTo (p 0.0542 0.3149) (p 0.0592 0.4861) (p 0.1171 0.6574) + , CurveTo (p 0.1751 0.8287) (p 0.2859 1.0000) (p 0.4962 1.0000) + , ClosePath + , MoveTo (p 0.2872 (-0.2834)) + , CurveTo (p 0.0542 (-0.0504)) (p 0.0542 0.3161) (p 0.0542 0.3161) + , LineTo (p (-0.0529) 0.3149) + , CurveTo (p (-0.0529) 0.3149) (p (-0.0529) (-0.0441)) (p (-0.2922) (-0.2834)) + , ClosePath + , MoveTo (p (-0.2456) (-0.0945)) + , CurveTo (p (-0.0126) 0.1385) (p 0.3539 0.1385) (p 0.3539 0.1385) + , LineTo (p 0.3539 0.2456) + , CurveTo (p 0.3539 0.2456) (p (-0.0050) 0.2456) (p (-0.2443) 0.4849) + , ClosePath + , MoveTo (p 0.2355 0.4861) + , CurveTo (p (-0.0038) 0.2469) (p (-0.3627) 0.2469) (p (-0.3627) 0.2469) + , LineTo (p (-0.3627) 0.1398) + , CurveTo (p (-0.3627) 0.1398) (p 0.0038 0.1398) (p 0.2368 (-0.0932)) + , ClosePath ] + +-- | ggplot 同型のマーカー塗り (色 + alpha)。 hollow (中抜き) は透明・輪郭のみ。 +-- plot 点 (Render.Basic) と凡例キー (Render.Layer) で**同一の装飾規則**を使うための +-- 単一ソース (= 「凡例マークは plot と揃える」 規律)。 +markerFillFor :: Layer -> Text -> Double -> FillStyle +markerFillFor ly c ai + | getLast (lyHollow ly) == Just True = FillStyle c 0.0 + | otherwise = FillStyle c ai + +-- | ggplot 同型のマーカー縁 (stroke)。 既定は**縁なし** (= 塗り点 shape 19)。 +-- hollow → 点色で輪郭のみ (幅 'lyStroke'|1)。 'lyEdge' 指定時だけ縁を出す +-- (色 'lyEdgeColor'|点色、 幅 'lyEdgeWidth'|1)。 plot/凡例で共通。 +markerStrokeFor :: Layer -> Text -> Maybe StrokeStyle +markerStrokeFor ly c + | getLast (lyHollow ly) == Just True = Just (StrokeStyle c (doubleOr (lyStroke ly) 1.0)) + | getLast (lyEdge ly) == Just True = + Just (StrokeStyle (maybe c id (getLast (lyEdgeColor ly))) (doubleOr (lyEdgeWidth ly) 1.0)) + | otherwise = Nothing + +-- | C-6 PS port: scatter / strip 等の i 番目 data 点に対応する shape を取得。 +-- lyShapeBy 列値を data から resolve し、 cat → shape を引く。 明示の lyShapeMap が +-- あればそれを最優先、 無ければカテゴリ初出順の index で 'shapePalette' を巡回割当 +-- (= ggplot @aes(shape=factor(g))@ の自動 shape scale。 colorVector の色割当と同思想)。 +pointShapeAt :: Layer -> Resolver -> Int -> MarkShape +pointShapeAt ly r i = case getLast (lyShape ly) of + Just s -> s -- ★ Phase 30 A3: 固定 shape 最優先 + Nothing -> case getLast (lyShapeBy ly) of + Nothing -> MShCircle + Just cr -> case resolveCol r cr of + Just (TxtData v) -> resolveShape (V.toList v) (v V.!? i) + Just (NumData v) -> resolveShape (map numToText (V.toList v)) (fmap numToText (v V.!? i)) + Nothing -> MShCircle + where + resolveShape _ Nothing = MShCircle + resolveShape vals (Just cat) = + case [ s | ShapeMapEntry v s <- lyShapeMap ly, v == cat ] of + (s:_) -> s -- 明示マップ優先 + [] -> case elemIndex cat (orderedCats vals) of -- 自動割当 (アルファベット順で巡回) + Just k -> shapePalette !! (k `mod` length shapePalette) + Nothing -> MShCircle + +-- | 自動 shape scale の巡回パレット (ggplot 風: 丸→三角→四角→…)。 +shapePalette :: [MarkShape] +shapePalette = + [ MShCircle, MShSquare, MShTriangle, MShCross + , MShSpade, MShHeart, MShClub, MShDiamond ] + +-- | TODO-3e (2026-05-29): lySizeBy → 各点の半径 (px) Vector。 +-- lySizeBy 指定の列値 (= 要 numeric) を min..max → [szLo, szHi] px に線形 map。 +-- 指定無しなら lySize (or default 3.0) を全点に適用。 +-- | per-point マーカー**半径** (pt) Vector を返す。 +-- +-- ★ Phase 34 A3: 'size' 意味論を「マーカー外接円の**直径** (pt)」に統一 +-- (§2.1)。'lySize' は直径として解釈し、shapeToPrim が要求する半径 (= 直径/2) を返す。 +-- 既定直径は 'defaultMarkerDiameter' (= ggplot 実測 1.65mm)。 +-- sizeBy (連続 size mapping) の範囲 'lpSizeRange' も**直径**範囲 (= scale_size、 +-- 既定 (6,20)pt → 半径 3..10pt)。 +sizeVector :: Resolver -> Layout -> Layer -> Int -> V.Vector Double +sizeVector r layout ly n = + let baseDiam = doubleOr (lySize ly) defaultMarkerDiameter -- 直径 (pt) + baseRad = baseDiam / 2 -- shapeToPrim は半径を取る + (szLo, szHi) = lpSizeRange layout -- 直径範囲 (pt) + in case getLast (lySizeBy ly) of + Nothing -> V.replicate n baseRad + Just cr -> case resolveNum r cr of + Nothing -> V.replicate n baseRad + Just v -> + let lo = V.minimum v + hi = V.maximum v + diamOf x = if hi <= lo then baseDiam + else szLo + (x - lo) / (hi - lo) * (szHi - szLo) + in V.fromList [ case v V.!? i of + Just x -> diamOf x / 2 + Nothing -> baseRad + | i <- [0 .. n - 1] ] + +-- | Phase 30 A8: lyAlphaBy → 各点の alpha (不透明度) Vector。 +-- lyAlphaBy 指定の列値 (= 要 numeric) を min..max → alpha [0.1, 1.0] に線形 map +-- (= ggplot scale_alpha 既定 range)。 指定無しなら baseAlpha (固定 lyAlpha or 既定値) +-- を全点に適用。 +alphaVector :: Resolver -> Layer -> Double -> Int -> V.Vector Double +alphaVector r ly baseAlpha n = + case getLast (lyAlphaBy ly) of + Nothing -> V.replicate n baseAlpha + Just cr -> case resolveNum r cr of + Nothing -> V.replicate n baseAlpha + Just v -> + let lo = V.minimum v + hi = V.maximum v + (aLo, aHi) = (0.1, 1.0) -- ggplot scale_alpha 既定 range + alphaOf x = if hi <= lo then baseAlpha + else aLo + (x - lo) / (hi - lo) * (aHi - aLo) + in V.fromList [ case v V.!? i of + Just x -> alphaOf x + Nothing -> baseAlpha + | i <- [0 .. n - 1] ] + +-- =========================================================================== +-- Phase 6+ case C-2 ~ C-5: 基本 / 分布 chart の Render +-- =========================================================================== + +-- | カテゴリ名 (= ColTxt) を Layer から取得。 categorical bar / pie 等で labels に。 +catLabelsOf :: Resolver -> Layer -> [Text] +catLabelsOf r ly = case getLast (lyEncX ly) of + Just cr -> case resolveCol r cr of + Just (TxtData v) -> V.toList v + _ -> [] + Nothing -> [] + +-- =========================================================================== +-- 分布 chart (group × value) +-- =========================================================================== + +-- | group 列 (lyEncX ?? colorBy 列) と value 列 (lyEncY) を resolve。 group は +-- categorical (= ColTxt) が普通、 ColNum でも対応 (= ColNum を distinct 値で group)。 +-- 戻り値: [(group_label, [value])] +groupedValues :: Resolver -> Layer -> [(Text, [Double])] +groupedValues r ly = case distGroupRef ly of + Just crX -> case resolveCol r crX of + Just (TxtData labels) -> + -- ★ NaN (= Maybe 列の Nothing) を整列を保ったまま落とす: vecOrFull (長さ保持) で + -- ラベルと zip してから NaN 値の行を除く (vecOr で先に縮めると行がズレる)。 + let vals = V.toList (vecOrFull (lyEncY ly) r) + pairs = [ (l, v) | (l, v) <- zip (V.toList labels) vals, not (isNaN v) ] + -- foldr で畳むと既に出現順 (A,B,C)。 PS (uniqueOrdered) と一致させる + -- ため reverse しない (Phase 7 A6: R-2 群↔plot 対応の HS/PS 食違い解消)。 + orderedUniq = foldr (\(l, _) acc -> if l `elem` acc then acc else l : acc) [] pairs + in [ (l, [v | (lv, v) <- pairs, lv == l]) | l <- orderedUniq ] + Just (NumData labels) -> + let vals = V.toList (vecOrFull (lyEncY ly) r) + pairs = [ (l, v) | (l, v) <- zip (map (T.pack . show . (round :: Double -> Int)) (V.toList labels)) vals, not (isNaN v) ] + orderedUniq = foldr (\(l, _) acc -> if l `elem` acc then acc else l : acc) [] pairs + in [ (l, [v | (lv, v) <- pairs, lv == l]) | l <- orderedUniq ] + Nothing -> [] + Nothing -> [] + +-- | Phase 28: 'groupedValues' を x カテゴリ軸順 ('lpXCategoryLabels') に整列する。 +-- box / violin / strip / swarm / ridge は群を @zip [0..]@ で x 位置に並べるが、 +-- x 軸ラベルは 'lpXCategoryLabels' (既定アルファベット順 / discrete-limits override) +-- から来る。 両者の順を一致させないと「箱は Gentoo だがラベルは Chinstrap」 のような +-- ズレが出る (= categorical 既定をアルファベット順にした際の回帰)。 軸ラベルが無い +-- (数値 x 等) ときは 'groupedValues' の順をそのまま返す。 +groupedValuesOrdered :: Layout -> Resolver -> Layer -> [(Text, [Double])] +groupedValuesOrdered layout r ly = + let gv = groupedValues r ly + xls = lpXCategoryLabels layout + in if null xls then gv + else [ (g, vs) | g <- xls, Just vs <- [lookup g gv] ] + +-- | Phase 36 B1c: distribution mark (violin/strip/swarm/raincloud) の群リスト。 +-- 群列 ('distGroupRef' = encX ?? colorBy) があれば 'groupedValuesOrdered'、 無ければ +-- encY 全体を単一群 ("") にする (= boxplot の単一群挙動と統一)。 これにより 1 引数 +-- @violin "v"@ (群なし) でも空にならず 1 つ描ける。 +distGroupsOrdered :: Layout -> Resolver -> Layer -> [(Text, [Double])] +distGroupsOrdered layout r ly = case distGroupRef ly of + Just _ -> groupedValuesOrdered layout r ly + Nothing -> case V.toList (vecOr (lyEncY ly) r) of + [] -> [] + vs -> [("", vs)] + +-- --------------------------------------------------------------------------- +-- Phase 36 B2: dodge (位置列 × 色列の 2 階層) 共通ヘルパ +-- @groupBy "class" <> colorBy "drv"@ のように位置列と色列が別のとき、 各位置 +-- カテゴリ内に色サブグループを横並びにする (= ggplot @position_dodge@)。 +-- --------------------------------------------------------------------------- + +-- | dodge cell 化: (位置列, 色列) について各 (位置 index, 色 index) の値リストを作る。 +-- 戻り値: +-- positions = 位置カテゴリ ('lpXCategoryLabels' = 既定アルファベット順) +-- colorCats = 色カテゴリ ('lyColorCats' 優先、 無ければ色列の出現順 uniq) +-- cells = @[(posIx, colIx, [value])]@ (空セルは除外) +-- 値は encY、 NaN (= Maybe 列の Nothing) は行整列を保ったまま除外。 +dodgeCells :: Layout -> Resolver -> Layer -> ([Text], [Text], [(Int, Int, [Double])]) +dodgeCells layout r ly = case distDodgeRef ly of + Nothing -> ([], [], []) + Just (posC, colC) -> + let colLabelsOf cr = case resolveCol r cr of + Just (TxtData v) -> V.toList v + Just (NumData v) -> map (T.pack . show . (round :: Double -> Int)) (V.toList v) + _ -> [] + orderedUniqT = foldr (\l acc -> if l `elem` acc then acc else l : acc) [] + posLs = colLabelsOf posC + colLs = colLabelsOf colC + vals = V.toList (vecOrFull (lyEncY ly) r) + triples = [ (p, c, v) | (p, c, v) <- zip3 posLs colLs vals, not (isNaN v) ] + positions = let xls = lpXCategoryLabels layout + in if null xls then orderedUniqT [ p | (p, _, _) <- triples ] else xls + colorCats = if not (null (lyColorCats ly)) then lyColorCats ly + else orderedUniqT [ c | (_, c, _) <- triples ] + cellAt pix cix = [ v | (p, c, v) <- triples + , Just pix == elemIndex p positions + , Just cix == elemIndex c colorCats ] + cells = [ (pix, cix, vs) + | pix <- [0 .. length positions - 1] + , cix <- [0 .. length colorCats - 1] + , let vs = cellAt pix cix, not (null vs) ] + in (positions, colorCats, cells) + +-- | dodge sub-cell の data 空間中心 (= bar 'PosDodge' と同式)。 位置カテゴリ @pix@ の +-- slot (幅 0.9) を色数 @nColor@ で等分し、 @cix@ 番目の中心を data 座標で返す。 +dodgeCenterD :: Int -> Int -> Int -> Double +dodgeCenterD pix cix nColor = + fromIntegral pix - 0.45 + + (fromIntegral cix + 0.5) * 0.9 / fromIntegral (max 1 nColor) + +-- --------------------------------------------------------------------------- +-- 分布計算の共通 helper (Phase 8 B2: KDE / 四分位の重複を一元化) +-- raincloud / violin / box / density / ridge が共有する。 ggplot で言う +-- stat_density / stat_boxplot 相当を 1 箇所に集約 (= 各 geom が再利用)。 +-- --------------------------------------------------------------------------- + +-- | Gaussian KDE (Silverman bandwidth) を nGrid 点で評価し [(y, density)] を返す。 +-- 戻り値は y 昇順。 violin/raincloud/density/ridge が共有。 grid は vals の min..max。 +kdeGrid :: Int -> [Double] -> [(Double, Double)] +kdeGrid nGrid vals + | length vals < 2 = [] + | otherwise = kdeGridOver (minimum vals) (maximum vals) nGrid vals + +-- | Phase 8 B23-fix: grid 範囲を明示する版。 ridge は全群共通の値域 [gLo, gHi] で各群を +-- 評価し、 群データ端の外でも KDE 裾を滑らかに減衰させる (= 各群自前 min/max だと裾が +-- 打ち切られて横線にならない、 PS renderRidgeLayer と同方式)。 bw は群自身の vals から。 +kdeGridOver :: Double -> Double -> Int -> [Double] -> [(Double, Double)] +kdeGridOver gLo gHi nGrid vals + | length vals < 2 = [] + | otherwise = + let n = length vals + mu = sum vals / fromIntegral n + var = sum [(v - mu)^(2::Int) | v <- vals] / fromIntegral (max 1 (n - 1)) + sigma = sqrt var + bw = if sigma <= 0 then (gHi - gLo) / 20 + else 1.06 * sigma * fromIntegral n ** (-0.2 :: Double) + kdeAt v = sum [ exp (negate (((v - xi) / bw)^(2::Int)) / 2) | xi <- vals ] + / (fromIntegral n * bw * sqrt (2 * pi)) + stepG = (gHi - gLo) / fromIntegral nGrid + in [ (v, kdeAt v) | k <- [0..nGrid], let v = gLo + fromIntegral k * stepG ] + +-- | 5 数要約 (Tukey)。 q1/median/q3 + whisker 端 (1.5×IQR 内の最遠データ点)。 +-- box / raincloud が共有。 vals はソート不要 (内部で sort)。 +data FiveNum = FiveNum + { fnQ1 :: !Double, fnMed :: !Double, fnQ3 :: !Double + , fnLoW :: !Double, fnHiW :: !Double } + +fiveNum :: [Double] -> Maybe FiveNum +fiveNum [] = Nothing +fiveNum vals = + let sorted = sort vals + nq = length sorted + idx j = if j < 0 || j >= nq then Nothing else Just (sorted !! j) + q p = let pos = p * fromIntegral (nq - 1) + loI = floor pos :: Int + hiI = min (nq - 1) (loI + 1) + frac = pos - fromIntegral loI + in case (idx loI, idx hiI) of + (Just a', Just b') -> a' + (b' - a') * frac + _ -> 0 + q1 = q 0.25 + q2 = q 0.5 + q3 = q 0.75 + iqr = q3 - q1 + loV = case dropWhile (< q1 - 1.5 * iqr) sorted of (x:_) -> x; [] -> q1 + hiV = case reverse (takeWhile (<= q3 + 1.5 * iqr) sorted) of (x:_) -> x; [] -> q3 + in Just (FiveNum { fnQ1 = q1, fnMed = q2, fnQ3 = q3, fnLoW = loV, fnHiW = hiV }) + +-- | 細い箱ひげ (= raincloud 中央 / 単群 box 用)。 中心 x = cx、 半幅 hw px。 +-- 共通 'fiveNum' を使い whisker 足 + IQR 箱 + median 白線を返す。 +boxAt :: (Double -> Double) -> Double -> Double -> Text -> [Double] -> [Primitive] +boxAt sy cx hw color vals = case fiveNum vals of + Nothing -> [] + Just fn -> + let q1 = fnQ1 fn; q2 = fnMed fn; q3 = fnQ3 fn; loV = fnLoW fn; hiV = fnHiW fn + in [ PLine (Point cx (sy q3)) (Point cx (sy hiV)) (solid color 1.0) + , PLine (Point cx (sy q1)) (Point cx (sy loV)) (solid color 1.0) + , PLine (Point (cx - hw) (sy hiV)) (Point (cx + hw) (sy hiV)) (solid color 1.0) + , PLine (Point (cx - hw) (sy loV)) (Point (cx + hw) (sy loV)) (solid color 1.0) + , PRect (Rect (cx - hw) (sy q3) (2 * hw) (sy q1 - sy q3)) + (FillStyle color 0.7) (Just (StrokeStyle color 1.0)) + , PLine (Point (cx - hw) (sy q2)) (Point (cx + hw) (sy q2)) + (solid "#ffffff" 1.5) ] + +-- | Ridge 用 group 化: encX = 値 (numeric)、 encY = 群 (categorical)。 +-- groupedValues は encX を群とするため、 ridge では x/y を入れ替えた版が要る。 +ridgeGroups :: Resolver -> Layer -> [(Text, [Double])] +ridgeGroups r ly = case getLast (lyEncY ly) of + Just crG -> case resolveCol r crG of + Just (TxtData labels) -> + let vals = V.toList (vecOr (lyEncX ly) r) + pairs = zip (V.toList labels) vals + orderedUniq = foldr (\(l, _) acc -> if l `elem` acc then acc else l : acc) [] pairs + in [ (l, [v | (lv, v) <- pairs, lv == l]) | l <- orderedUniq ] + Just (NumData labels) -> + let vals = V.toList (vecOr (lyEncX ly) r) + pairs = zip (map (T.pack . show . (round :: Double -> Int)) (V.toList labels)) vals + orderedUniq = foldr (\(l, _) acc -> if l `elem` acc then acc else l : acc) [] pairs + in [ (l, [v | (lv, v) <- pairs, lv == l]) | l <- orderedUniq ] + Nothing -> [] + Nothing -> [] + +-- | Backend が実装する interface。 IO は canvas / file write のため。 +class Renderer rndr where + drawPrimitives :: rndr -> [Primitive] -> IO () + diff --git a/src/Graphics/Hgg/Render/Distribution.hs b/src/Graphics/Hgg/Render/Distribution.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Render/Distribution.hs @@ -0,0 +1,619 @@ +-- | +-- Module : Graphics.Hgg.Render.Distribution +-- Description : 分布 mark (box/violin/strip/swarm/raincloud/ridge) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +module Graphics.Hgg.Render.Distribution where + +import Graphics.Hgg.Layout (Layout (..), Rect (..), Scale (..), + ViewportSize (..), computeLayout, + ggAxTextMar, ggAxTitleMar, ggHalfLine, + ggTickLen, niceTicks, scaleApply, + Track (..), solveTracks, + needsLegend, effectiveLegendPos, + coordOf, isPolar, polarCenter, polarPoint, + domFrac, projectXY, projectRectData, + projectBarRect, catUnitPx, AxisPlacement (..), + coordXAxisPlacement, coordYAxisPlacement, + coordXGridIsVertical) +import Graphics.Hgg.Layout.RangeOf (qqPoints, ecdfPoints) -- Phase 11 A6-2/A6-4 +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Time.Format as Data.Time.Format +import Graphics.Hgg.Spec (Annotation (..), AxisFormat (..), + ColData (..), ColRef, + ColorEnc (..), ConnectSpec (..), + DAGEdge (..), DAGLayoutAlgorithm (..), + DAGNode (..), DAGNodeKind (..), + DAGPlate (..), DAGSpec (..), Layer (..), + LegendPosition (..), LegendSpec (..), + Inset (..), MarginalSpec (..), MarkKind (..), + MarkShape (..), ShapeMapEntry (..), + LineType (..), lineTypeDash, lineTypeForIndex, + ReferenceLine (..), Resolver, + Position (..), Coord (..), Side (..), + FacetScales (..), freeScaleX, freeScaleY, + FacetSpace (..), freeSpaceX, freeSpaceY, + ThemeOverride (..), + VisualSpec (..), YAxisSide (..), axisFormatOf, + axisRotateOf, resolveAxisAngle, axisShowTicksOf, + axShowGrid, + FontSpec (..), + colRefName, distGroupRef, distDodgeRef, + resolveCol, resolveNum) +import Data.Maybe (mapMaybe, isJust) +import Data.List (sortOn, foldl') +import qualified Data.Map.Strict as Map +import Data.List (dropWhile, elemIndex, groupBy, nub, + sort, takeWhile) +import qualified Graphics.Hgg.Spec +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Numeric (showEFloat, showFFloat) + +import Graphics.Hgg.Primitive +import Graphics.Hgg.Render.Common + + +-- | Phase 36 D3: 各群を 'lpXCategoryLabels' 内の **大域 index**(= 列名スロット)に置く。 +-- cats が空(単一群・非 categorical)なら局所順 @[0..]@。 既存の grouped 図は groups が cats と +-- 同順・全在ゆえ大域 = 局所で **byte 不変**。 distCols は各レーンが 1 群(自列名)= 大域 index。 +laneIndices :: Layout -> [(Text, a)] -> [Int] +laneIndices layout gs = + let xls = lpXCategoryLabels layout + in if null xls then [0 ..] + else [ maybe i id (elemIndex g xls) | (i, (g, _)) <- zip [0 ..] gs ] + +-- | Box plot (= 5-number summary)。 PS / HS で API 統一: lyEncY = 値、 lyEncX = 群 (optional)。 +-- 群指定なしなら単一 box を plot 中央に。 群指定ありなら各群について並列描画。 +-- 中央線 (median) + IQR 箱 + 髭 (min/max within 1.5*IQR)。 +-- | Phase 36 B2: box glyph を「cross 軸中心 (px) + box half 幅 (px)」 指定で描く共通部。 +-- value 軸変換 (Cartesian は @sy@、 flip は @valPxF@) と coord を受け、 fill/stroke/alpha +-- と外れ値ドットを適用。 normal path (群 = カテゴリ位置) と dodge path (sub-slot 中心) が共有。 +-- @sorted@ は昇順済みの値列。 'renderBox' の旧インライン mkBox と出力 byte 一致。 +boxGlyphPx :: Coord -> (Double -> Double) -> (Double -> Double) + -> Double -> Double -> Double -> [Double] -> Text -> Text -> [Primitive] +boxGlyphPx coord sy valPxF crossC half a sorted0 fill stroke = + let sorted = sort sorted0 + n = length sorted + q p = + let pos = p * fromIntegral (n - 1) + lo = floor pos :: Int + hi = min (n - 1) (lo + 1) + frac = pos - fromIntegral lo + in case (sorted !? lo, sorted !? hi) of + (Just a', Just b') -> a' + (b' - a') * frac + _ -> 0 + (!?) xs i_ = if i_ < 0 || i_ >= length xs then Nothing else Just (xs !! i_) + q1 = q 0.25; q2 = q 0.50; q3 = q 0.75 + iqr = q3 - q1 + loW = q1 - 1.5 * iqr + hiW = q3 + 1.5 * iqr + loV = case dropWhile (< loW) sorted of (v:_) -> v; [] -> q1 + hiV = case reverse (takeWhile (<= hiW) sorted) of (v:_) -> v; [] -> q3 + mkPt v off = case coord of + CoordCartesian -> Point (crossC + off) (sy v) + CoordFlip -> Point (valPxF v) (crossC + off) + _ -> Point (crossC + off) (sy v) + mkRect vLo vHi h = case coord of + CoordCartesian -> Rect (crossC - h) (min (sy vLo) (sy vHi)) (2 * h) (abs (sy vHi - sy vLo)) + CoordFlip -> Rect (min (valPxF vLo) (valPxF vHi)) (crossC - h) (abs (valPxF vHi - valPxF vLo)) (2 * h) + _ -> Rect (crossC - h) (min (sy vLo) (sy vHi)) (2 * h) (abs (sy vHi - sy vLo)) + outliers = filter (\v -> v < loW || v > hiW) sorted + outR = defaultMarkerDiameter / 2 + outlierPrims = + [ PCircle (mkPt v 0) outR (FillStyle stroke 1.0) (Just (StrokeStyle stroke 1.0)) Nothing + | v <- outliers ] + in [ PRect (mkRect q1 q3 half) (FillStyle fill a) (Just (StrokeStyle stroke 1.0)) + , PLine (mkPt q2 (-half)) (mkPt q2 half) (solid stroke 2.0) + , PLine (mkPt q1 0) (mkPt loV 0) (solid stroke 1.0) + , PLine (mkPt q3 0) (mkPt hiV 0) (solid stroke 1.0) + , PLine (mkPt loV (-half / 2)) (mkPt loV (half / 2)) (solid stroke 1.0) + , PLine (mkPt hiV (-half / 2)) (mkPt hiV (half / 2)) (solid stroke 1.0) + ] <> outlierPrims + +renderBox :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderBox r layout pal ly + | isJust (distDodgeRef ly) = renderBoxDodge r layout pal ly +renderBox r layout pal ly = + let groups = case distGroupRef ly of + -- group 列あり (encX または colorBy 列): PS と同じ groupedValues + Just _ -> [(g, sort vs) | (g, vs) <- groupedValuesOrdered layout r ly, not (null vs)] + -- group 列なし: 単一群 ("all") + Nothing -> case V.toList (vecOr (lyEncY ly) r) of + [] -> [] + vs -> [("", sort vs)] + -- ★ Phase 34: ggplot geom_boxplot 既定 = 枠 grey20・塗り white・不透明・外れ値ドット。 + -- user 明示色は枠色として優先 (ggplot aes(colour=) と同型)、 塗りは white 固定。 + c = staticColorOr ly "#333333" -- 枠/median/whisker = grey20 既定 + -- ★ 箱の塗り: colorBy (群色マップ) があれば群ごとに彩色 (violin/bar と統一・凡例と一致)、 + -- 無ければ ggplot 既定の white。 明示 color X は枠色 (c) として従来どおり優先。 + catPal = lpCategoricalPalette layout + hasColorBy = case getLast (lyColor ly) of + Just (ColorByCol _) -> True + _ -> False + boxFillFor i = if hasColorBy && not (null catPal) + then catPal !! (i `mod` length catPal) + else "#ffffff" + -- ★ Phase 36 C: hollow (= ggplot geom_boxplot(fill=NA)) は塗り透明・枠/median/whisker を + -- 群色 (colorBy 時) で描く。 colorBy 無しなら従来の c (grey20/明示色) のまま。 + isHollow = getLast (lyHollow ly) == Just True + strokeFor i = if isHollow && hasColorBy && not (null catPal) + then catPal !! (i `mod` length catPal) + else c + a = doubleOr (lyAlpha ly) 1.0 + sy = scaleApply (lpYScale layout) + sx = scaleApply (lpXScale layout) + area = lpPlotArea layout + nG = length groups + hasCats = not (null (lpXCategoryLabels layout)) + -- PS と同 box width 規約: box width = 1 スロットの 0.5。 Step4c: categorical は unit + -- (sx 1 - sx 0) 基準 (±0.5 で rW/nG 一致, ±0.6 で軸追従)。 単一群 (非 cat) は plotArea + -- 全幅基準のまま中央 1 本。 + step = rW area / fromIntegral (max 1 nG) + -- ★ Phase 36 D1: markWidth (占有率・既定 0.5) で box 幅、 nudge (slot 幅比) で slot 内 offset。 + mw = doubleOr (lyMarkWidth ly) 0.5 + -- ★ Phase 36 D2: no-cat (単一) は slot = plotArea ゆえ nudge 基準も rW area (strip/PS と統一)。 + nudgePx = doubleOr (lyNudge ly) 0 * (if hasCats then catUnitPx (lpCoord layout) layout else rW area) + bwFor = if hasCats then catUnitPx (lpCoord layout) layout * mw else step * mw + cxFor i = + (if hasCats then sx (fromIntegral i) + else rX area + rW area / 2) + nudgePx + -- Phase 10 A4: flip 時の cross 軸 (category=縦) 中心 + value 軸 (=横) スケール。 + coord = flipOnly (lpCoord layout) -- A7-c: box は polar 非対象 + valPxF = scaleApply (lpYScaleFlipped layout) + cyFor i = + (if hasCats then scaleApply (lpXScaleFlipped layout) (fromIntegral i) + else rY area + rH area / 2) + nudgePx + mkBox i (_lbl, sorted) = + let n = length sorted + -- R type 7 linear interpolation (= numpy/matplotlib/ggplot default) + q p = + let pos = p * fromIntegral (n - 1) + lo = floor pos :: Int + hi = min (n - 1) (lo + 1) + frac = pos - fromIntegral lo + in case (sorted !? lo, sorted !? hi) of + (Just a, Just b) -> a + (b - a) * frac + _ -> 0 + (!?) xs i_ = if i_ < 0 || i_ >= length xs then Nothing else Just (xs !! i_) + q1 = q 0.25 + q2 = q 0.50 + q3 = q 0.75 + iqr = q3 - q1 + loW = q1 - 1.5 * iqr + hiW = q3 + 1.5 * iqr + loV = case dropWhile (< loW) sorted of + (v:_) -> v + [] -> q1 + hiV = case reverse (takeWhile (<= hiW) sorted) of + (v:_) -> v + [] -> q3 + cx = cxFor i + cy = cyFor i + bw = bwFor + -- Phase 10 A4: value 軸 = y (Cartesian は縦・flip は横)、 cross 軸 = cx/cy。 + -- 厚み bw・cap は px のまま。 Cartesian 分岐は従来 AST と bit 一致。 + mkPt v off = case coord of + CoordCartesian -> Point (cx + off) (sy v) + CoordFlip -> Point (valPxF v) (cy + off) + mkRect vLo vHi half = case coord of + CoordCartesian -> Rect (cx - half) (min (sy vLo) (sy vHi)) (2 * half) (abs (sy vHi - sy vLo)) + CoordFlip -> Rect (min (valPxF vLo) (valPxF vHi)) (cy - half) (abs (valPxF vHi - valPxF vLo)) (2 * half) + -- ★ Phase 34: 1.5×IQR フェンス外を外れ値ドットで描画 (ggplot outlier、 既定径)。 + outliers = filter (\v -> v < loW || v > hiW) sorted + outR = defaultMarkerDiameter / 2 + sc = strokeFor i -- Phase 36 C: hollow 時は群色枠 + boxFill = if isHollow then FillStyle (boxFillFor i) 0.0 -- fill=NA (透明) + else FillStyle (boxFillFor i) a + outlierPrims = + [ PCircle (mkPt v 0) outR (FillStyle sc 1.0) (Just (StrokeStyle sc 1.0)) Nothing + | v <- outliers ] + in [ PRect (mkRect q1 q3 (bw / 2)) boxFill (Just (StrokeStyle sc 1.0)) + , PLine (mkPt q2 (-bw / 2)) (mkPt q2 (bw / 2)) (solid sc 2.0) + , PLine (mkPt q1 0) (mkPt loV 0) (solid sc 1.0) + , PLine (mkPt q3 0) (mkPt hiV 0) (solid sc 1.0) + , PLine (mkPt loV (-bw / 4)) (mkPt loV (bw / 4)) (solid sc 1.0) + , PLine (mkPt hiV (-bw / 4)) (mkPt hiV (bw / 4)) (solid sc 1.0) + ] <> outlierPrims + in concat (zipWith mkBox (laneIndices layout groups) groups) + +-- | Phase 36 B2: dodge box。 位置列 (@groupBy@) × 色列 (@colorBy@) で各位置カテゴリ内に +-- 色サブグループを横並び (= ggplot @position_dodge@)。 色 = colorBy 水準の categorical +-- palette、 枠 = grey20 既定 (明示 'color' があれば枠色優先)。 box 実幅 = sub-slot の 85%。 +renderBoxDodge :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderBoxDodge r layout _pal ly = + let (_positions, colorCats, cells) = dodgeCells layout r ly + nColor = max 1 (length colorCats) + catPal = lpCategoricalPalette layout + colorFor cix = if null catPal then "#333333" else catPal !! (cix `mod` length catPal) + stroke = staticColorOr ly "#333333" + -- ★ Phase 36 C: hollow は塗り透明・枠を群色 (= colorFor)。 非 hollow は従来 (枠 grey20)。 + isHollow = getLast (lyHollow ly) == Just True + a = doubleOr (lyAlpha ly) 1.0 + coord = flipOnly (lpCoord layout) + sy = scaleApply (lpYScale layout) + valPxF = scaleApply (lpYScaleFlipped layout) + unit = catUnitPx (lpCoord layout) layout + subW = unit * 0.9 / fromIntegral nColor -- sub-slot px 幅 + bw = subW * 0.85 -- box 実幅 (sub-slot の 85%) + crossScale d = case coord of + CoordFlip -> scaleApply (lpXScaleFlipped layout) d + _ -> scaleApply (lpXScale layout) d + in concat + [ boxGlyphPx coord sy valPxF (crossScale (dodgeCenterD pix cix nColor)) (bw / 2) + (if isHollow then 0.0 else a) (sort vs) + (colorFor cix) (if isHollow then colorFor cix else stroke) + | (pix, cix, vs) <- cells ] + +-- | Phase 36 B2: dodge violin。 位置列 × 色列で各位置内に色サブグループの violin を横並び。 +renderViolinDodge :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderViolinDodge r layout _ ly = + let (_positions, colorCats, cells) = dodgeCells layout r ly + nColor = max 1 (length colorCats) + catPal = lpCategoricalPalette layout + colorFor cix = if null catPal then "#3E6A6F" else catPal !! (cix `mod` length catPal) + a = doubleOr (lyAlpha ly) 0.5 + coord = flipOnly (lpCoord layout) + sy = scaleApply (lpYScale layout) + valPxF = scaleApply (lpYScaleFlipped layout) + unit = catUnitPx (lpCoord layout) layout + subW = unit * 0.9 / fromIntegral nColor + halfWidth = subW * 0.4 + crossScale d = case coord of + CoordFlip -> scaleApply (lpXScaleFlipped layout) d + _ -> scaleApply (lpXScale layout) d + mkPt cx off y = case coord of + CoordCartesian -> Point (cx + off) (sy y) + CoordFlip -> Point (valPxF y) (cx + off) + _ -> Point (cx + off) (sy y) + mkViolin (pix, cix, vals) = + let cx = crossScale (dodgeCenterD pix cix nColor) + color = colorFor cix + ds = kdeGrid 30 vals + maxD = if null ds then 1 else max 1e-9 (maximum (map snd ds)) + wScale d = halfWidth * d / maxD + rightPath = [ mkPt cx (wScale d) y | (y, d) <- ds ] + leftPath = [ mkPt cx (negate (wScale d)) y | (y, d) <- reverse ds ] + in case rightPath ++ leftPath of + [] -> PRect (Rect 0 0 0 0) (FillStyle color a) Nothing + (h':t) -> PPath (MoveTo h' : map LineTo t ++ [ClosePath]) + (FillStyle color a) (Just (StrokeStyle color 1.0)) + in map mkViolin cells + +-- | Violin (Phase 6+ C-4): group ごとに 縦方向 KDE shape 描画。 +renderViolin :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderViolin r layout pal ly + | isJust (distDodgeRef ly) = renderViolinDodge r layout pal ly +renderViolin r layout _ ly = + let groups = distGroupsOrdered layout r ly + a = doubleOr (lyAlpha ly) 0.5 + c = staticColorOr ly "#3E6A6F" + pal = lpCategoricalPalette layout + area = lpPlotArea layout + nG = length groups + sx = scaleApply (lpXScale layout) + sy = scaleApply (lpYScale layout) + -- ★ Phase 36 B1c: 群なし (= 単一 violin) は categorical 軸が無いので renderBox と + -- 同じく plotArea 中央に 1 本・幅も plotArea 基準にする (= 左寄り回帰の防止)。 + hasCats = not (null (lpXCategoryLabels layout)) + -- Phase 8 A2 Step4c: 1 スロット幅を unit (sx 1 - sx 0) 基準に。 ±0.5 では rW/nG と + -- 一致 (categorical span=nG) だが、 ±0.6 で span が変わっても軸スケールに追従する。 + -- ★ Phase 36 D1: markWidth (占有率・既定 0.7) で violin 幅、 nudge で slot 内 offset、 + -- side で片側化 (半 violin)。 + mwV = doubleOr (lyMarkWidth ly) 0.7 + -- ★ Phase 36 D2: no-cat (単一) では slot = plotArea ゆえ nudge 基準も rW area + -- (= strip / PS と統一・旧 catUnitPx 無条件は HS 内部不整合だった)。 + nudgePx = doubleOr (lyNudge ly) 0 * (if hasCats then catUnitPx coord layout else rW area) + sideV = maybe SideBoth id (getLast (lySide ly)) + halfWidth = (if hasCats then catUnitPx coord layout else rW area) * mwV / 2 + -- Phase 10 A4: value 軸 = y (Cartesian は縦・flip は横)、 cross = category i ± 幅 px。 + coord = flipOnly (lpCoord layout) -- A7-c: violin は polar 非対象 + valPxF = scaleApply (lpYScaleFlipped layout) + crossPx i = nudgePx + case coord of + CoordCartesian -> if hasCats then sx (fromIntegral i) else rX area + rW area / 2 + CoordFlip -> if hasCats then scaleApply (lpXScaleFlipped layout) (fromIntegral i) + else rY area + rH area / 2 + mkPt i off y = case coord of + CoordCartesian -> Point (crossPx i + off) (sy y) + CoordFlip -> Point (valPxF y) (crossPx i + off) + -- 各 group の violin shape (= 縦並び KDE、 共通 kdeGrid を左右対称展開) + mkViolin i (_label, vals) = + let color = pal !! (i `mod` length pal) + color' = case staticColorOr ly "" of + "" -> color + given -> given + _ = c -- silence + ds = kdeGrid 30 vals + maxD = if null ds then 1 else max 1e-9 (maximum (map snd ds)) + wScale d = halfWidth * d / maxD + rightPath = [ mkPt i (wScale d) y | (y, d) <- ds ] + leftPath = [ mkPt i (negate (wScale d)) y | (y, d) <- reverse ds ] + centerDown = [ mkPt i 0 y | (y, _) <- reverse ds ] -- 中心線 上→下 + centerUp = [ mkPt i 0 y | (y, _) <- ds ] -- 中心線 下→上 + -- side: 半 violin は片側 outline + 中心線で閉じる (raincloud の「雲」)。 + allPts = case sideV of + SideBoth -> rightPath ++ leftPath + SideRight -> rightPath ++ centerDown + SideLeft -> centerUp ++ leftPath + in case allPts of + [] -> PRect (Rect 0 0 0 0) (FillStyle color' a) Nothing + (h':t) -> PPath (MoveTo h' : map LineTo t ++ [ClosePath]) + (FillStyle color' a) (Just (StrokeStyle color' 1.0)) + in zipWith mkViolin (laneIndices layout groups) groups + +-- | Strip plot (Phase 8 B4): group ごとに 縦に scatter、 横 jitter で散らす +-- (= ggplot geom_jitter 流)。 jitter 幅は lyJitterX 指定 > 既定 (slot の 0.4)。 +-- | Phase 36 B2: dodge strip。 位置列 × 色列で各位置内に色サブグループの jitter を横並び +-- (= ggplot @position_jitterdodge@)。 jitter は sub-slot 幅基準。 +renderStripDodge :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderStripDodge r layout pal ly = + let (_positions, colorCats, cells) = dodgeCells layout r ly + nColor = max 1 (length colorCats) + catPal = lpCategoricalPalette layout + colorFor cix = if null catPal then tpDefault pal else catPal !! (cix `mod` length catPal) + a = doubleOr (lyAlpha ly) 0.7 + sz = doubleOr (lySize ly) (mmPt 1.25) + coord = flipOnly (lpCoord layout) + sy = scaleApply (lpYScale layout) + valPxF = scaleApply (lpYScaleFlipped layout) + unit = catUnitPx (lpCoord layout) layout + subW = unit * 0.9 / fromIntegral nColor + jw = subW * 0.6 + crossScale d = case coord of + CoordFlip -> scaleApply (lpXScaleFlipped layout) d + _ -> scaleApply (lpXScale layout) d + mkPt cx off v = case coord of + CoordCartesian -> Point (cx + off) (sy v) + CoordFlip -> Point (valPxF v) (cx + off) + _ -> Point (cx + off) (sy v) + mkPts (pix, cix, vals) = + let cx = crossScale (dodgeCenterD pix cix nColor) + color = colorFor cix + in [ PCircle (mkPt cx dx v) (sz/2) (FillStyle color a) Nothing Nothing + | (k, v) <- zip [0 :: Int ..] vals + , let dx = (hashRand ((pix * 17 + cix) * 131 + k * 71) - 0.5) * jw ] + in concatMap mkPts cells + +renderStrip :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderStrip r layout pal ly + | isJust (distDodgeRef ly) = renderStripDodge r layout pal ly +renderStrip r layout pal ly = + let groups = distGroupsOrdered layout r ly + nG = length groups + c0 = staticColorOr ly (tpDefault pal) + a = doubleOr (lyAlpha ly) 0.7 + sz = doubleOr (lySize ly) (mmPt 1.25) + sx = scaleApply (lpXScale layout) + sy = scaleApply (lpYScale layout) + area = lpPlotArea layout + cats = lpCategoricalPalette layout + -- ★ Phase 36 B1c: 群なし (単一 strip) は plotArea 中央・幅も plotArea 基準。 + hasCats = not (null (lpXCategoryLabels layout)) + -- jitter 幅 (px): lyJitterX 指定 (>0) があれば plotArea 比率、 なければ slot 幅の 0.4 + -- Phase 10 A4-fix: slot 幅は coord に応じた cross 軸単位 (flip では縦)。 + slotW = if hasCats then catUnitPx (lpCoord layout) layout else rW area + jx0 = doubleOr (lyJitterX ly) 0 + -- ★ Phase 36 D1: markWidth (jitter span・占有率・既定 0.4) で散らし幅、 nudge で slot 内 offset。 + mwS = doubleOr (lyMarkWidth ly) 0.4 + nudgePx = doubleOr (lyNudge ly) 0 * slotW + jw = if jx0 > 0 then jx0 * rW area else slotW * mwS + -- Phase 10 A4: value 軸 = y、 cross = category i ± jitter px。 + coord = flipOnly (lpCoord layout) -- A7-c: strip は polar 非対象 + valPxF = scaleApply (lpYScaleFlipped layout) + crossPx i = nudgePx + case coord of + CoordCartesian -> if hasCats then sx (fromIntegral i) else rX area + rW area / 2 + CoordFlip -> if hasCats then scaleApply (lpXScaleFlipped layout) (fromIntegral i) + else rY area + rH area / 2 + mkPt i off v = case coord of + CoordCartesian -> Point (crossPx i + off) (sy v) + CoordFlip -> Point (valPxF v) (crossPx i + off) + mkPts i (_, vals) = + let color = if c0 == tpDefault pal then cats !! (i `mod` length cats) else c0 + in [ PCircle (mkPt i dx v) (sz/2) + (FillStyle color a) Nothing Nothing + | (k, v) <- zip [0 :: Int ..] vals + , let dx = (hashRand (i * 131 + k * 71) - 0.5) * jw ] + in concat (zipWith mkPts (laneIndices layout groups) groups) + +-- | Beeswarm の横 offset 計算 (Phase 8 B5): 値を pixel y にマップ後、 点直径ごとに +-- y ビンを切り、 各ビン内で点を中央から左右対称に並べる (= 1,-1,2,-2,... 列)。 +-- N に対し安定で、 横幅は maxOff で clamp (= はみ出さない)。 戻り値は各点の dx (px)。 +-- HS/PS 共通アルゴリズム。 入力 ys は pixel y 値 (sy 適用後)。 +beeswarmOffsets :: Double -> Double -> [Double] -> [Double] +beeswarmOffsets diameter maxOff ysPix = + let binH = diameter + -- 各点に y ビン index を付与し、 同ビン内の出現順を数える + go _ [] = [] + go seen (y : rest) = + let b = floor (y / binH) :: Int + cnt = maybe 0 id (lookup b seen) + -- 中央から左右対称: 0, +1, -1, +2, -2, ... + slot = if even cnt then cnt `div` 2 else negate ((cnt + 1) `div` 2) + dxRaw = fromIntegral slot * diameter + dx = max (negate maxOff) (min maxOff dxRaw) + seen' = (b, cnt + 1) : filter ((/= b) . fst) seen + in dx : go seen' rest + in go [] ysPix + +-- | Swarm plot (Phase 8 B5): strip の衝突回避版 (beeswarm)。 値の近い点を +-- 横方向に左右対称へ押し出して重なりを避ける。 N 大でも横幅 clamp で破綻しない。 +-- | Phase 36 B2: dodge swarm。 位置列 × 色列で各位置内に色サブグループの beeswarm を横並び。 +renderSwarmDodge :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderSwarmDodge r layout pal ly = + let (_positions, colorCats, cells) = dodgeCells layout r ly + nColor = max 1 (length colorCats) + catPal = lpCategoricalPalette layout + colorFor cix = if null catPal then tpDefault pal else catPal !! (cix `mod` length catPal) + a = doubleOr (lyAlpha ly) 0.85 + sz = doubleOr (lySize ly) (mmPt 1.25) + coord = flipOnly (lpCoord layout) + sy = scaleApply (lpYScale layout) + valPxF = scaleApply (lpYScaleFlipped layout) + unit = catUnitPx (lpCoord layout) layout + subW = unit * 0.9 / fromIntegral nColor + maxOff = subW * 0.45 + valuePx v = case coord of CoordCartesian -> sy v; CoordFlip -> valPxF v; _ -> sy v + crossScale d = case coord of + CoordFlip -> scaleApply (lpXScaleFlipped layout) d + _ -> scaleApply (lpXScale layout) d + mkPt cx off v = case coord of + CoordCartesian -> Point (cx + off) (sy v) + CoordFlip -> Point (valPxF v) (cx + off) + _ -> Point (cx + off) (sy v) + mkPts (pix, cix, vals) = + let cx = crossScale (dodgeCenterD pix cix nColor) + color = colorFor cix + sortedVals = sort vals + ysPix = map valuePx sortedVals + offs = beeswarmOffsets sz maxOff ysPix + in [ PCircle (mkPt cx off v) (sz/2) (FillStyle color a) Nothing Nothing + | (v, off) <- zip sortedVals offs ] + in concatMap mkPts cells + +renderSwarm :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderSwarm r layout pal ly + | isJust (distDodgeRef ly) = renderSwarmDodge r layout pal ly +renderSwarm r layout pal ly = + let groups = distGroupsOrdered layout r ly + c0 = staticColorOr ly (tpDefault pal) + a = doubleOr (lyAlpha ly) 0.85 + sz = doubleOr (lySize ly) (mmPt 1.25) + sx = scaleApply (lpXScale layout) + sy = scaleApply (lpYScale layout) + area = lpPlotArea layout + -- ★ Phase 36 B1c: 群なし (単一 swarm) は plotArea 中央・押し出し幅も plotArea 基準。 + hasCats = not (null (lpXCategoryLabels layout)) + -- Phase 10 A4-fix: 押し出し幅は coord に応じた cross 軸単位 (flip では縦) の 0.4。 + -- ★ Phase 36 D1: markWidth (span・占有率・既定 0.8) で押し出し幅、 nudge で slot 内 offset。 + slotW = if hasCats then catUnitPx (lpCoord layout) layout else rW area + mwSw = doubleOr (lyMarkWidth ly) 0.8 + nudgePx = doubleOr (lyNudge ly) 0 * slotW + maxOff = slotW * mwSw / 2 + cats = lpCategoricalPalette layout + -- Phase 10 A4: value 軸 = y (Cartesian 縦 / flip 横)、 cross = category i ± beeswarm off px。 + -- beeswarm の binning は value 軸 px 上で行う (= flip 時は横軸 px)。 + coord = flipOnly (lpCoord layout) -- A7-c: swarm は polar 非対象 + valPxF = scaleApply (lpYScaleFlipped layout) + valuePx v = case coord of CoordCartesian -> sy v; CoordFlip -> valPxF v + crossPx i = nudgePx + case coord of + CoordCartesian -> if hasCats then sx (fromIntegral i) else rX area + rW area / 2 + CoordFlip -> if hasCats then scaleApply (lpXScaleFlipped layout) (fromIntegral i) + else rY area + rH area / 2 + mkPt i off v = case coord of + CoordCartesian -> Point (crossPx i + off) (sy v) + CoordFlip -> Point (valPxF v) (crossPx i + off) + mkPts i (_, vals) = + let color = if c0 == tpDefault pal then cats !! (i `mod` length cats) else c0 + sortedVals = sort vals + ysPix = map valuePx sortedVals + offs = beeswarmOffsets sz maxOff ysPix + in [ PCircle (mkPt i off v) (sz/2) + (FillStyle color a) Nothing Nothing + | (v, off) <- zip sortedVals offs ] + in concat (zipWith mkPts (laneIndices layout groups) groups) + +-- | Raincloud plot (Phase 8 B2): 群ごとに 右:half-violin + 中央:box + 左:jitter strip。 +-- 参照画像 (raincloud_ref.webp) 準拠。 ggplot 流に「3 つの geom を重ねる」 構成とし、 +-- KDE/四分位は共通 helper ('kdeGrid' / 'boxAt') を再利用 (= violin/box とロジック重複なし)。 +-- box は KDE の baseline (cx) と重ならないよう左にオフセットして配置。 +renderRaincloud :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderRaincloud r layout _ ly = + let groups = distGroupsOrdered layout r ly + area = lpPlotArea layout + nG = length groups + sx = scaleApply (lpXScale layout) + sy = scaleApply (lpYScale layout) + pal = lpCategoricalPalette layout + -- ★ Phase 36 B1c: 群なし (単一 raincloud) は plotArea 中央・幅も plotArea 基準。 + hasCats = not (null (lpXCategoryLabels layout)) + halfWidth = if hasCats then (sx 1 - sx 0) * 0.35 else rW area * 0.35 + sz = doubleOr (lySize ly) (mmPt 1.25) + jAlpha = doubleOr (lyAlpha ly) 0.6 + mkOne i (_label, vals) = + let cx = if hasCats then sx (fromIntegral i) else rX area + rW area / 2 + color = case staticColorOr ly "" of + "" -> pal !! (i `mod` length pal) + given -> given + -- (1) 右半身 violin (= 「雲」、 共通 kdeGrid を baseline cx から右へ) + grid = kdeGrid 30 vals + violinPrims = case grid of + [] -> [] + _ -> let dMax = max 1e-9 (maximum (map snd grid)) + rightPts = [ Point (cx + (d / dMax) * halfWidth) (sy v) | (v, d) <- grid ] + basePts = reverse [ Point cx (sy v) | (v, _) <- grid ] + in case rightPts ++ basePts of + (p0:rest) -> [ PPath (MoveTo p0 : map LineTo rest ++ [ClosePath]) + (FillStyle color 0.4) (Just (StrokeStyle color 1.0)) ] + [] -> [] + -- (2) box (= 共通 boxAt)。 KDE baseline (cx) と離すため左に halfWidth*0.32 寄せる + boxCx = cx - halfWidth * 0.32 + boxPrims = boxAt sy boxCx 3 color vals + -- (3) 左 jitter strip (= 「雨」、 box より更に左、 hashRand で deterministic) + stripCx = cx - halfWidth * 0.7 + stripPrims = [ PCircle (Point (stripCx + dx) (sy v)) (sz / 2) + (FillStyle color jAlpha) Nothing Nothing + | (k, v) <- zip [0 :: Int ..] vals + , let dx = (hashRand (i * 97 + k * 131) - 0.5) * halfWidth * 0.5 ] + in violinPrims ++ boxPrims ++ stripPrims + in concat (zipWith mkOne [0..] groups) + +-- | Ridge plot / joyplot。 群ごとに density 曲線を描き、 値方向に山を並べて少し重ねる。 +-- ★ Phase 36 B1c: 他 distribution mark と統一し encY=値・群=distGroupRef (encX ?? colorBy)。 +-- ridge は値→x・群→y の向きが要るため Layout が coord_flip を自動適用 ('ridgeAutoFlip')。 +-- よって値→x は 'lpYScaleFlipped'、 群→y baseline は 'lpXScaleFlipped' を使う (box-flip と同機構)。 +-- 軸/目盛/群ラベルは標準 path が描き、 ここは glyph (群ごと 1 PPath) のみ。 重なり headroom は +-- Layout が群 (= flip 後 y) カテゴリドメインを上方向へ expand して確保。 KDE は 'kdeGridOver' を共有。 +renderRidge :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderRidge r layout _thePal ly = + let vals = V.toList (vecOr (lyEncY ly) r) -- 値 (encY) + -- 群ラベル列 = distGroupRef (encX ?? colorBy)。 無ければ単一 ("") = density 風。 + grpLabels = case distGroupRef ly of + Just crG -> case resolveCol r crG of + Just (TxtData v) -> map Just (V.toList v) + Just (NumData v) -> map (Just . T.pack . show . (round :: Double -> Int)) (V.toList v) + _ -> [] + Nothing -> [] + hasGrp = not (null grpLabels) + pairs = if hasGrp then [ (g, v) | (Just g, v) <- zip grpLabels vals ] + else [ ("", v) | v <- vals ] + groups0 = let uniq = foldr (\(l, _) acc -> if l `elem` acc then acc else l : acc) [] pairs + in [ (l, [v | (lv, v) <- pairs, lv == l]) | l <- uniq ] + -- 群 (= flip 後 y) カテゴリ軸順 (lpXCategoryLabels) に整列して baseline と軸ラベルを一致。 + xls = lpXCategoryLabels layout + groups = if null xls then groups0 + else [ (g, vs) | g <- xls, Just vs <- [lookup g groups0] ] + a = doubleOr (lyAlpha ly) 0.8 + area = lpPlotArea layout + pal = lpCategoricalPalette layout + vx v = scaleApply (lpYScaleFlipped layout) v -- 値 → x (flip 済・連続) + gyc i = scaleApply (lpXScaleFlipped layout) (fromIntegral i) -- 群 index → y baseline + allVals = concatMap snd groups + (vLo, vHi) = if null allVals then (0, 1) else (minimum allVals, maximum allVals) + -- 山高さ = 群 1 スロット (px) の 0.95。 群なしは plotArea 全高 baseline=下端 (density 風)。 + slotY = if hasGrp then abs (gyc 1 - gyc 0) else rH area + ridgeH = if hasGrp then slotY * 0.95 else rH area * 0.9 + baseOf i = if hasGrp then gyc (fromIntegral i) else rY area + rH area + mkRidge i (_label, gvals) = + let color = pal !! (i `mod` length pal) + -- Phase 8 B23-fix: 全群共通の値域 (vLo, vHi) で評価し裾を滑らかに減衰させる。 + ds = kdeGridOver vLo vHi 60 gvals + maxD = if null ds then 1 else max 1e-9 (maximum (map snd ds)) + yBase = baseOf i + pts = [ Point (vx xv) (yBase - ridgeH * d / maxD) | (xv, d) <- ds ] + in case (pts, ds) of + (p0:rest, _) -> + let closure = [ Point (vx (fst (last ds))) yBase + , Point (vx (fst (head ds))) yBase ] + in [ PPath (MoveTo p0 : map LineTo (rest ++ closure) ++ [ClosePath]) + (FillStyle color a) (Just (StrokeStyle color 1.2)) ] + _ -> [] + -- 上の群 (index 大) を先に = 奥、 下 (index 0) を後 = 手前 (重なりの前後) + ordered = reverse (zip [0..] groups) + in concatMap (\(i, g) -> mkRidge i g) ordered diff --git a/src/Graphics/Hgg/Render/EdgeRoute.hs b/src/Graphics/Hgg/Render/EdgeRoute.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Render/EdgeRoute.hs @@ -0,0 +1,1075 @@ +-- | +-- Module : Graphics.Hgg.Render.EdgeRoute +-- Description : DAG edge の pt 空間 routing 幾何 (障害物回避・port・制御点列) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 39 B2: routing を描画 (Render.Special) から分離した純幾何 module。 +-- pt 空間で toScreen・radius・plate bbox (障害物) を受け、 edge の制御点列と +-- 描画 style ('EdgeRoute') を返す。 Primitive 生成や ThemePalette には依存しない +-- (= 描画は呼出側 'renderEdge' の責務)。 B1 の段階型と対になる「routing 入力契約」。 +-- +-- node 形状幾何 ('nodeExtent' / 'edgePortPoint') も routing が依存するため本 module に +-- 置き、 描画側 (renderNode 等) は本 module から import する (= 下位 = 幾何、 +-- 上位 = 描画 の層分け)。 +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Render.EdgeRoute + ( -- * routing 結果 + EdgeRoute (..) + , routeEdge + , spreadPorts + -- * 障害物モデル (A-1) + , Box (..) + , Obstacles (..) + , dagObstacles + , plateBoxPt + , plateChildrenOf + -- * channel + funnel (A-2 / A-3) + , buildChannel + , funnel + -- * box 拘束 Bézier fit (R3 = graphviz Proutespline) + , proutespline + , solve3 + -- * node 形状幾何 (port 交点) + , edgePortPoint + , nodeExtent + , nodeShowsDist + , dagLabelFs + ) where + +import Graphics.Hgg.Layout (dagLabelFs, dagNodeBaseHalfWidth) +import Graphics.Hgg.Primitive (Point (..)) +import Graphics.Hgg.Spec (DAGEdge (..), DAGNode (..), + DAGNodeKind (..), DAGPlate (..)) +import Data.Maybe (mapMaybe) +import Data.Text (Text) + +-- | edge routing の結果 = 制御点列 + 描画 style。 ThemePalette/Primitive 非依存。 +-- +-- * 'StraightArrow' = 単独 short edge (直線 + 矢印) +-- * 'SplinePath' = 並列 short / 長 edge 非迂回 (Catmull-Rom・呼出側で平滑化) +-- * 'BezierPath' = 長 edge の plate box 迂回 (箱角 waypoint を平滑化せず通す) +-- * 'CubicPath' = R3 (Step6 P7a): graphviz Proutespline の box 拘束 cubic Bézier +-- fit。 先頭 = 始点、 以後 3 点ずつ (制御点1, 制御点2, 終点) の +-- cubic segment 列。 +data EdgeRoute + = StraightArrow Point Point + | SplinePath [Point] + | BezierPath [Point] + | CubicPath [Point] + deriving (Show, Eq) + +-- | edge の制御点列と style を pt 空間で決定する純関数 (= 'renderEdge' から routing 部を抽出)。 +-- 並列 edge は perpendicular に offset、 長 edge は graphviz routesplines: +-- 障害物 ('Obstacles') から box-channel を作り (A-2)、 funnel 最短折れ線 (A-3) を通す。 +routeEdge + :: (Double -> Double -> Point) + -> Obstacles -- ^ A-1: node + plate 障害物 (pt 空間) + -> DAGNode -> DAGNode -> Maybe [(Double, Double)] + -> Double + -> Int -> Int -- ^ parIx, parCount + -> EdgeRoute +routeEdge toScreen obs from to mPath radius parIx parCount = + let fromCenter = toScreen (dnX from) (dnY from) + toCenter = toScreen (dnX to) (dnY to) + Point fx fy = fromCenter + Point tx ty = toCenter + edx = tx - fx; edy = ty - fy + elen = sqrt (edx * edx + edy * edy) + (perpx, perpy) = if elen > 1e-12 then (-edy / elen, edx / elen) else (0, 0) + offsetMag = + if parCount > 1 + then (fromIntegral parIx - fromIntegral (parCount - 1) / 2) + * (radius * 1.4) + else 0 + offsetP (Point px py) = + Point (px + perpx * offsetMag) (py + perpy * offsetMag) + in case mPath of + Just [_, wp, _] | abs (fy - ty) < 1e-9 -> + -- P7b 最小 (Phase 53 A3-4): flat edge (= 同 rank edge) の迂回 arc。 + -- chain は [from, gap-waypoint, to] の 3 点 (DAG.routeStage 産)。 + -- 'buildChannel' / 'funnel' は y 単調な rank 下り chain 前提で、 flat の + -- V 字 guide を潰して中間 node を貫通する (実測: flat5 a→b が m 中心を + -- 通過) ため通さず、 graphviz make_flat_edge と同じく rank 間 gap を + -- 通る arc を直接作る。 並列 flat edge は waypoint ごと perpendicular + -- offset で分離。 + let wpP = offsetP (let (wx, wy) = wp in toScreen wx wy) + fromPortS = edgePortPoint from fromCenter wpP radius + toPortS = edgePortPoint to toCenter wpP radius + in SplinePath [fromPortS, wpP, toPortS] + Just chain | length chain >= 2 -> + -- A-2/A-3: dummy chain を guide に box-channel を作り funnel で最短折れ線へ。 + -- 内部制御点は並列 spread 用に perpendicular bend を掛けてから guide にする。 + let inner = [ toScreen x y | (x, y) <- take (length chain - 2) (drop 1 chain) ] + innerOff = map offsetP inner + guide0 = fromCenter : innerOff ++ [toCenter] + -- A-1: この edge が避ける障害物 (= 端点を含む箱は除外)。 + eboxes = edgeBoxes obs from to fromCenter toCenter + -- ★ Phase 52 A7: guide (dummy lane) が box を貫くと 'buildChannel' の + -- portal が行ごとに反対側へ飛び (pushOut の側 flip)、 taut が box 内部を + -- 対角に横切って node に重なって描画される (実測: dense15 x4→x15 が + -- x13 box を貫通)。 guide 段階で貫通線分に迂回 corner を挿入して + -- channel を一貫させる (= graphviz P4a が dummy を box 外へ置くのと同層)。 + -- taut 段階の補正だと taut が barrier 上を沿走して fit が直角に縮退する。 + -- dedup 6pt は corner と旧 waypoint の近接 backtrack 掃除。 + guide = dedupTaut 6.0 (avoidBoxTaut eboxes guide0) + portals = buildChannel eboxes guide + taut = funnel portals -- src .. snk (端点含む taut 折れ線) + interior = drop 1 (initSafe taut) -- 端点を除く taut waypoint + -- A-5 (暫定): port は taut 経路の端 segment 方向へ取る (自然入射)。 + firstDir = case interior of (p:_) -> p; [] -> toCenter + lastDir = case reverse interior of (p:_) -> p; [] -> fromCenter + fromPortS = edgePortPoint from fromCenter firstDir radius + toPortS = edgePortPoint to toCenter lastDir radius + -- R3 (Step6 P7a): taut 折れ線 (port→port) に box 拘束 cubic Bézier を + -- graphviz Proutespline で fit。 channel 境界 = portal の左鎖 + 右鎖。 + tautPorts = fromPortS : interior ++ [toPortS] + barriers = channelBarriers portals + -- ★ A3.3 (2026-06-24): endpoint slope は taut の端 segment 方向 (= 自然な + -- port 入射方向) を渡す。graphviz の `±π/2 constrained` は **内部の + -- box-segment 境界** に適用される拘束であり、**実端点 (src/snk port) の接線は + -- port 方向 (斜め)**。一次実測: dot 14.1.5 の `edge src snk` gold は始点 + -- `(1.9076,2.3025)→(1.9989,2.2455)` = 接線 (+0.091,-0.057) で水平寄りの斜め + -- (垂直でない)。A3.1 は端点も垂直と誤って拘束し、A3.2 の y-sweep で taut が + -- 4 点クリーン化した後は **斜め近接 + 強制垂直の衝突で overshoot (内側 S)** を + -- 生んでいた。自然方向に戻すと S が消え単一 bow に (A3.1 の cusp も y-sweep で + -- taut が V でなくなったため再発しない)。 + ev0 = case tautPorts of + (a:b:_) -> vnorm (vsub b a) + _ -> Point 0 1 + ev1 = case reverse tautPorts of + (a:b:_) -> vnorm (vsub a b) + _ -> Point 0 1 + ctrl = proutespline barriers tautPorts ev0 ev1 + in CubicPath ctrl + _ | parCount > 1 -> + -- 並列 short edge: 中点 bend 1 点を挟む 3 点 spline で「並ぶ曲線」 を出す + let midRaw = Point ((fx + tx) / 2) ((fy + ty) / 2) + midBent = offsetP midRaw + fromPortS = edgePortPoint from fromCenter midBent radius + toPortS = edgePortPoint to toCenter midBent radius + pts = [fromPortS, midBent, toPortS] + in SplinePath pts + _ -> + -- 単独 short edge: 従来の直線 + 矢印 + let fromPort = edgePortPoint from fromCenter toCenter radius + toPort = edgePortPoint to toCenter fromCenter radius + in StraightArrow fromPort toPort + +initSafe :: [a] -> [a] +initSafe [] = [] +initSafe xs = init xs + +-- =========================================================================== +-- A-1: 障害物モデル (pt 空間の軸並行矩形) +-- =========================================================================== + +-- | pt 空間の軸並行矩形 (xlo ≤ xhi, ylo ≤ yhi)。 routing の障害物 / channel box 共用。 +data Box = Box !Double !Double !Double !Double -- ^ xlo ylo xhi yhi + deriving (Show, Eq) + +-- | routing 用障害物集合。 node glyph box (= id 付き・端点除外用) と plate box を分けて保持。 +-- +-- Phase 53 A4: 'obLanes' = 各 edge の dummy lane box 列 ((from, to) key 付き)。 +-- graphviz `make_regular_edge` の per-edge boxes は「rank order 上の左右隣接 +-- オブジェクト (**virtual node 含む**) で clip した回廊」 ('maximal_bbox')。 +-- 'buildChannel' の free 区間 clip は既に「最寄り crossing box = 隣接オブジェクト」 +-- なので、 他 edge の dummy lane を障害物に足せば channel がそのまま +-- 「自レーンの box 回廊」 になる (= 他 edge の dummy レーンに侵入不能)。 +data Obstacles = Obstacles + { obNodes :: [(Text, Box)] -- ^ node id → glyph box (clearance margin 込み) + , obPlates :: [Box] -- ^ plate 枠 box (clearance margin 込み) + , obLanes :: [((Text, Text), [Box])] + -- ^ A4: edge (from, to) → dummy lane box 列 (chain 内部 waypoint の virtual node box) + } deriving (Show, Eq) + +-- | clearance margin (= spline が箱に接しないための余白)。 graphviz: cluster 8pt。 +-- ★ Phase 52 A7 実測メモ (2026-07-08): node 4→8pt を試したが channel が狭まり +-- 分割接合の junction kink (157°/54°) が再発したため 4pt に据え置き +-- (routes CSV + analyze-kinks.py で確認)。 かすり対策は box 辺 barrier +-- ('boxBarriers') 側で行う。 +obNodeMargin, obPlateMargin :: Double +obNodeMargin = 4 +obPlateMargin = 8 + +-- | 全 node glyph box (+margin) と plate box (+margin) を pt 空間で構築する (A-1)。 +-- +-- Phase 53 A4: @edges@ から dummy lane box ('obLanes') も構築する。 chain 内部 +-- waypoint (= long-edge dummy) ごとに幅 'laneHalfW'、 高さ = その rank の band +-- (同 y の real node の最大 ry) の virtual node box を置く。 flat edge +-- (端点同 rank) の gap waypoint は rank line 上のオブジェクトではないため対象外。 +dagObstacles :: (Double -> Double -> Point) -> Double + -> [DAGNode] -> [(Text, DAGNode)] -> [DAGPlate] -> [DAGEdge] + -> Obstacles +dagObstacles toScreen radius nodes nodeMap plates edges = + Obstacles + { obNodes = + [ (dnId n, Box (cx - rx - obNodeMargin) (cy - ry - obNodeMargin) + (cx + rx + obNodeMargin) (cy + ry + obNodeMargin)) + | n <- nodes + , let Point cx cy = toScreen (dnX n) (dnY n) + , let (rx, ry) = nodeExtent n radius ] + , obPlates = + [ Box (xlo - obPlateMargin) (ylo - obPlateMargin) + (xhi + obPlateMargin) (yhi + obPlateMargin) + | p <- plates + , Just (xlo, ylo, xhi, yhi) <- [plateBoxPt toScreen radius nodeMap plates p] ] + , obLanes = + [ ((deFrom e, deTo e), laneBoxes chain) + | e <- edges + , Just chain <- [dePath e] + , length chain > 2 + , not (isFlatChain chain) ] + } + where + -- rank band の半高: 同 y (= 同 rank line) の real node の最大 ry。 real node の + -- 無い all-dummy rank は 1 行 node 相当へ fallback。 graphviz の virtual node box + -- が rank の band を占める (= 交差は rank 間 gap で起きる) のと同層。 + rankHalfH py = + case [ ry | n <- nodes + , let Point _ cy = toScreen (dnX n) (dnY n) + , abs (cy - py) < 1e-6 + , let (_, ry) = nodeExtent n radius ] of + [] -> max (radius * 0.7) ((dagLabelFs + 3) / 2 + 4) + rs -> maximum rs + isFlatChain chain = case (chain, reverse chain) of + ((_, y0) : _, (_, yn) : _) -> abs (y0 - yn) < 1e-9 + _ -> False + laneBoxes chain = + [ Box (px - laneHalfW) (py - hh) (px + laneHalfW) (py + hh) + | (x, y) <- take (length chain - 2) (drop 1 chain) + , let Point px py = toScreen x y + , let hh = rankHalfH py ] + +-- | dummy lane box の半幅 (pt) = nodesep/2 (auxNodeSep 18 の半分)。 +-- graphviz 'maximal_bbox' は隣接 virtual node との中点 (= 自 box 右端 + nodesep/2) +-- まで回廊を開くため、 隣接 lane の回廊同士はちょうど tile して重ならない。 +-- 半幅 9pt の lane 障害物で clip すると同じ境界になる。 +laneHalfW :: Double +laneHalfW = 9 + +-- | この edge が避けるべき障害物 box 群。 端点 (from/to) の node box と、 端点中心を +-- 内側に含む box (= 端点が属する plate 等) は除外する (= edge は正規にそこへ接続する)。 +-- +-- Phase 53 A4: 他 edge の dummy lane box ('obLanes') も避ける = per-edge box 回廊。 +-- 自 lane と、 同一端点対の並列 edge (chain 共有・perpendicular offset で分離済) の +-- lane は除外する。 +edgeBoxes :: Obstacles -> DAGNode -> DAGNode -> Point -> Point -> [Box] +edgeBoxes obs from to srcC snkC = + let nodeB = [ b | (i, b) <- obNodes obs, i /= dnId from, i /= dnId to ] + laneB = [ b | ((f, t), bs) <- obLanes obs + , not (f == dnId from && t == dnId to) + , not (f == dnId to && t == dnId from) + , b <- bs ] + allB = nodeB ++ obPlates obs ++ laneB + in [ b | b <- allB, not (boxContains b srcC), not (boxContains b snkC) ] + +-- | 点が box の interior にあるか (境界は外側扱い)。 +boxContains :: Box -> Point -> Bool +boxContains (Box xlo ylo xhi yhi) (Point x y) = + x > xlo && x < xhi && y > ylo && y < yhi + +-- =========================================================================== +-- A-2: box-channel 構築 (guide 折れ線 + 障害物 → portal 列) +-- =========================================================================== + +-- | guide 折れ線 (端点含む・y 単調を想定) と障害物から funnel 用 portal 列を作る。 +-- 各内部 guide 点の y 水平線上で、 guide の x を含む free 区間 (左右最寄り障害物に +-- clip) を求め、 (左点, 右点) の portal に。 端点 (src/snk) は退化 portal として両端に置く。 +-- free 区間が退化/逆転したら guide 点をそのまま通す退化 portal にフォールバック +-- (= その点は funnel の強制通過点になる。 'funnel' の退化 portal 扱いを参照)。 +-- +-- ★ R1 (Step6 P7a・2026-06-24): 片側に障害物が無いときの壁を **graph bbox 端 (有限値)** +-- に clip する (旧: ±Infinity)。graphviz `maximal_bbox` (dotsplines.c) は隣 node が無ければ +-- cluster/graph 境界へ clip するため壁は常に有限。旧 ±Inf は funnel の 'tri' 外積を +-- Infinity 化して符号崩壊 → 直線 collapse を招いていた (correspondence doc §4-B)。 +-- +-- ★ R2-fix (2026-06-24): portal を free 区間**全幅**でなく **dummy x まわりの狭い窓** +-- ([gx-w, gx+w] を free 区間で clip) にする。graphviz `maximal_bbox` は virtual node 自身の +-- 細い幅 (lw≈1pt) 基準で box を作るため box は dummy に密着する。旧実装は free 区間全幅を +-- portal にしていたため、端点が片寄ると funnel が dummy lane を無視して chain 寄りへ +-- shortcut し L 字 (角 1 個) になり、R3 の cubic fit が暴走 (bulge) していた。狭い窓に +-- すると funnel が collinear な dummy lane に沿い、graphviz と同じ滑らかな bow になる。 +buildChannel :: [Box] -> [Point] -> [(Point, Point)] +buildChannel boxes guide = case guide of + [] -> [] + [p] -> [(p, p)] + (p0@(Point _ y0) : rest) -> + let pn@(Point _ yn) = last rest + interiorGys = [ gy | Point _ gy <- initSafe rest ] -- dummy lane の y + -- R1: 有限フォールバック壁。 全 box edge + guide x の外側へ channelMargin だけ + -- 余白を取った graph bbox 端。 隣 box の無い側はここまで開く (= 拘束なし相当)。 + xsAll = [ x | Box xlo _ xhi _ <- boxes, x <- [xlo, xhi] ] + ++ [ gx | Point gx _ <- guide ] + gloX = minimum xsAll - channelMargin + ghiX = maximum xsAll + channelMargin + -- ★ A3.2 (2026-06-24): graphviz box-stack の rank 境界に相当する portal を + -- **障害物の上下エッジ y** で張る。矩形障害物の周りでは funnel がその上角・下角を + -- 2 つの waypoint として丸める (= graphviz Pshortestpath が cluster bbox 角を経由 + -- する忠実構造)。旧実装は dummy の y 1 点でしか portal を張らず waypoint が 1 個 → + -- taut が単一屈曲 V → Proutespline が splinefits 第一段 (polyLen 短縮) 棄却で dummy + -- 分割 → 各 2 点 forceflag 直線 → テント角になっていた。box の内側 epsY だけ寄せた + -- 高さで sample し (strict cross 判定に乗せる)、上下角を確実に waypoint 化する。 + yLo = min y0 yn; yHi = max y0 yn + boxEdgeYs = concat [ [ylo + epsY, yhi - epsY] | Box _ ylo _ yhi <- boxes ] + eventYs0 = filter (\y -> y > yLo + epsY && y < yHi - epsY) + (boxEdgeYs ++ interiorGys) + -- sweep 方向に整列・近接重複除去 (src→snk の y 単調順)。 + ascending = yn >= y0 + eventYs = dedupNear (if ascending then sortAsc eventYs0 + else reverse (sortAsc eventYs0)) + mkPortal gy = + let gx0 = guideXAt guide gy -- dummy lane の x (側の選択に使う) + crossing = [ b | b@(Box _ ylo _ yhi) <- boxes, ylo < gy, gy < yhi ] + -- ★ Phase 44.4: guide x が crossing box の **内部**にあると (= layout が + -- radius floor のズレで dummy を箱境界の内側に置いた場合)、box の左右どちらの + -- エッジも「正しい側」の clip 条件 (xhi ≤ gx / xlo ≥ gx) に乗らず free 区間が + -- 全開 (gloX, ghiX) に退化し、funnel が箱内を通って spline が箱を貫通する + -- (Phase 39 P8 A2 stopgap 撤去で露呈した回帰)。graphviz `routesplines` / + -- `maximal_bbox` は channel box を cluster と重ねず必ず外側へ clip するため、 + -- guide を内包する box の **近い辺** へ push し、その外側 free 区間で portal を + -- 張る (= 箱をハード障害物にして spline 全体を箱外に保つ)。 + pushOut x (Box xlo _ xhi _) + | xlo < x && x < xhi = if x - xlo <= xhi - x then xlo else xhi + | otherwise = x + gx = foldl pushOut gx0 crossing + -- 隣接 box (or graph 端) までの free 区間 (= maximal_bbox の隣接クリップ)。 + freeL = maximum (gloX : [ xhi | Box _ _ xhi _ <- crossing, xhi <= gx ]) + freeR = minimum (ghiX : [ xlo | Box xlo _ _ _ <- crossing, xlo >= gx ]) + in if freeL < freeR + then (Point freeL gy, Point freeR gy) -- (左点, 右点) + else (Point gx gy, Point gx gy) -- 退化: lane x を強制通過 + in (p0, p0) : map mkPortal eventYs ++ [(pn, pn)] + +-- | guide 折れ線 (y 単調を想定) の高さ @y@ における x を線形補間する。 +-- box-stack portal の「側」 (どの障害物が左/右か) を決めるのに使う。 +guideXAt :: [Point] -> Double -> Double +guideXAt pts y = go pts + where + go (Point x1 y1 : more@(Point x2 y2 : _)) + | inSeg y y1 y2 = + if abs (y2 - y1) < 1e-9 then x1 + else x1 + (x2 - x1) * (y - y1) / (y2 - y1) + | otherwise = go more + go [Point x _] = x + go _ = 0 + inSeg t a b = (t >= min a b - 1e-9) && (t <= max a b + 1e-9) + +-- | 昇順ソート (挿入ソート・小規模 event 列向け)。 +sortAsc :: [Double] -> [Double] +sortAsc = foldr ins [] + where + ins x [] = [x] + ins x (z : zs) | x <= z = x : z : zs + | otherwise = z : ins x zs + +-- | 近接した y を 1 つに畳む (portal の零高さセグメント除け)。 +dedupNear :: [Double] -> [Double] +dedupNear [] = [] +dedupNear (x : xs) = x : go x xs + where + go _ [] = [] + go prev (z : zs) | abs (z - prev) < epsY = go prev zs + | otherwise = z : go z zs + +-- | box 内側へ寄せて portal を sample する高さオフセット (pt)。 strict cross 判定に +-- 乗せ、box 上端・下端の角を確実に waypoint 化する。 近接 y の畳み込み閾値も兼ねる。 +epsY :: Double +epsY = 0.75 + +-- | R1 フォールバック壁の余白 (pt)。 graph bbox 端からさらに外へ取る隙間。 +channelMargin :: Double +channelMargin = 16 + +-- =========================================================================== +-- A-3: funnel (stringpulling) 最短折れ線 +-- =========================================================================== + +-- | portal 列 ((左点, 右点) の列・先頭=src 末尾=snk の退化 portal) を通る最短折れ線を +-- funnel アルゴリズムで求める。 戻り = src .. snk の折れ線 (端点含む)。 +-- +-- ★ R2 (Step6 P7a・2026-06-24): graphviz `Pshortestpath` (shortest.c の三角形分割 + +-- deque funnel + `ccw`) と **数学的に同一**な教科書的 Lee funnel +-- (Mononen "Simple Stupid Funnel Algorithm") に置換。box-stack polygon では三角形分割の +-- 対角線 = box 重なり portal なので portal-funnel = 三角形分割 funnel (= 新規アルゴでなく +-- Pshortestpath そのもの)。旧自前 apex-jump funnel は cone 不変条件違反で左右壁を交互 +-- 往復する zigzag を生んでいた (correspondence doc §4-C)。 +-- +-- 規約: portal.left = 小 x 側 / portal.right = 大 x 側、path は下方向 (y 増加)。 +-- 'triarea2' は canonical 定義 (bx*ay - ax*by)。right 壁が左へ寄ると triarea2 ≤ 0 で funnel が +-- 締まる (手計算検証済)。退化 portal (left==right) は 'vequal' 分岐で素通り。 +funnel :: [(Point, Point)] -> [Point] +funnel [] = [] +funnel ps + | n <= 1 = [apex0] + | otherwise = dedupConsec (go cap 1 apex0 0 apex0 0 apex0 0 [apex0]) + where + n = length ps + leftAt i = fst (ps !! i) + rightAt i = snd (ps !! i) + apex0 = fst (head ps) + goal = fst (ps !! (n - 1)) + -- funnel は線形 (Mononen で証明済) だが、不正 portal 列での無限 restart を防ぐ保険。 + cap = 8 * n + 64 :: Int + -- 状態: fuel / 走査 i / apex (idx ai) / 左壁 lp (idx li) / 右壁 rp (idx ri) / 逆順 acc + go fuel i apex ai lp li rp ri acc + | fuel <= 0 = reverse (goal : acc) -- 保険発火 (理論上到達せず) + | i >= n = reverse (goal : acc) + | otherwise = + let r = rightAt i + -- 右壁の更新 + in if triarea2 apex rp r <= 0 + then if vequal apex rp || triarea2 apex lp r > 0 + then stepLeft fuel i apex ai lp li r i acc -- 締める (rp:=r, ri:=i) + else go (fuel - 1) (li + 1) lp li lp li lp li (lp : acc) -- right が left 越え → left を確定 + else stepLeft fuel i apex ai lp li rp ri acc -- 右更新スキップ + -- 左壁の更新 (右更新を経た後・同 i) + stepLeft fuel i apex ai lp li rp ri acc = + let l = leftAt i + in if triarea2 apex lp l >= 0 + then if vequal apex lp || triarea2 apex rp l < 0 + then go (fuel - 1) (i + 1) apex ai l i rp ri acc -- 締める (lp:=l, li:=i) → i 前進 + else go (fuel - 1) (ri + 1) rp ri rp ri rp ri (rp : acc) -- left が right 越え → right を確定 + else go (fuel - 1) (i + 1) apex ai lp li rp ri acc -- 左更新スキップ → i 前進 + +-- | 連続する同一点 (vequal) を 1 つに畳む。 Mononen funnel は goal を末尾に必ず append +-- するため、 funnel が goal で collapse すると末尾が重複しうる。 R3 spline fit の零長 +-- セグメント除けも兼ねる。 +dedupConsec :: [Point] -> [Point] +dedupConsec [] = [] +dedupConsec (x : xs) = x : go x xs + where + go _ [] = [] + go prev (y : ys) + | vequal prev y = go prev ys + | otherwise = y : go y ys + +-- | 三角形 (a,b,c) の符号付き面積 ×2 (Mononen canonical: bx*ay - ax*by)。 +triarea2 :: Point -> Point -> Point -> Double +triarea2 (Point ax' ay') (Point bx' by') (Point cx' cy') = + let ax = bx' - ax'; ay = by' - ay' + bx = cx' - ax'; by = cy' - ay' + in bx * ay - ax * by + +vequal :: Point -> Point -> Bool +vequal (Point ax ay) (Point bx by) = + abs (ax - bx) < 1e-9 && abs (ay - by) < 1e-9 + +-- =========================================================================== +-- R3: box 拘束 cubic Bézier fit (graphviz Proutespline・route.c の忠実移植) +-- =========================================================================== +-- 一次根拠 = lib/pathplan/route.c (mkspline / splinefits / reallyroutespline / +-- splineisinside / splineintersectsline) + lib/pathplan/solvers.c (solve3)。 +-- taut 折れ線に cubic Bézier を 1 本 fit → channel 境界 (barrier 線分) を逸脱しなければ +-- 採用、 逸脱すれば最大偏差点で分割して再帰。 これで graphviz と同じ滑らかな迂回弧になる。 + +-- 簡易ベクトル演算 (Point を 2D ベクトルとして扱う)。 +vsub, vadd :: Point -> Point -> Point +vsub (Point ax ay) (Point bx by) = Point (ax - bx) (ay - by) +vadd (Point ax ay) (Point bx by) = Point (ax + bx) (ay + by) +vscale :: Double -> Point -> Point +vscale k (Point x y) = Point (k * x) (k * y) +vdot :: Point -> Point -> Double +vdot (Point ax ay) (Point bx by) = ax * bx + ay * by +vlen :: Point -> Double +vlen p = sqrt (vdot p p) +vdist :: Point -> Point -> Double +vdist a b = vlen (vsub a b) +vnorm :: Point -> Point +vnorm p = let l = vlen p in if l > 1e-12 then vscale (1 / l) p else p + +-- | Phase 52 A7: funnel 後の taut 補正。 'buildChannel' の portal は guide が box を +-- 貫く行で 'pushOut' により反対側へ飛ぶことがあり (側 flip)、 連続 portal 間の +-- channel 多角形が box をまたぐ → taut 線分が box 内部を対角に横切る +-- (実測: dense15 x4→x15 の taut (32.4,176)→(75.6,190.2) が x13 box を貫通)。 +-- box 内部を実質的に横切る線分 (貫通長 > 'boxCrossEps') に、 貫通側の box 角 +-- waypoint を挿入して外周へ迂回させる。 端点が box 境界上に乗るだけの接触は対象外。 +avoidBoxTaut :: [Box] -> [Point] -> [Point] +avoidBoxTaut boxes = go (8 :: Int) + where + go 0 pts = pts + go n pts = + let pts' = pass pts + in if length pts' == length pts then pts else go (n - 1) pts' + pass (a : b : rest) = case firstCross a b of + Just corners -> a : corners ++ pass (b : rest) + Nothing -> a : pass (b : rest) + pass xs = xs + firstCross a b = + case [ cs | bx <- boxes, Just cs <- [crossCorners bx a b] ] of + (cs : _) -> Just cs + [] -> Nothing + +-- | 線分 (a,b) が box 内部を横切るとき、 迂回に挿入する box 角列 (a→b 順)。 +-- Liang-Barsky で貫通区間を求め、 貫通長が 'boxCrossEps' 以下 (角の接触等) は無視。 +-- 迂回側 (上辺経由 / 下辺経由 / 左右) は総距離が短い方を選ぶ。 +crossCorners :: Box -> Point -> Point -> Maybe [Point] +crossCorners (Box xlo ylo xhi yhi) a@(Point ax ay) b@(Point bx by) = + let dx = bx - ax; dy = by - ay + -- Liang-Barsky clip + clip p q (t0, t1) + | abs p < 1e-12 = if q < 0 then Nothing else Just (t0, t1) + | otherwise = + let r = q / p + in if p < 0 + then if r > t1 then Nothing else Just (max t0 r, t1) + else if r < t0 then Nothing else Just (t0, min t1 r) + mtt = pure (0, 1) + >>= clip (-dx) (ax - xlo) >>= clip dx (xhi - ax) + >>= clip (-dy) (ay - ylo) >>= clip dy (yhi - ay) + in case mtt of + Just (t0, t1) + | (t1 - t0) * sqrt (dx * dx + dy * dy) > boxCrossEps -> + let entry = Point (ax + dx * t0) (ay + dy * t0) + exit_ = Point (ax + dx * t1) (ay + dy * t1) + -- 周回 corner 列 (時計回り): TL → TR → BR → BL。 + -- ★ corner は box 外側へ 'cornerClear' だけ斜めに逃がす: box 辺 + -- barrier 上に waypoint が正確に乗ると丸め fit が全て barrier 判定で + -- 棄却され forceflag 直角に縮退する (実測: junction 89.9°/45°)。 + c = cornerClear + tl = Point (xlo - c) (ylo - c); tr = Point (xhi + c) (ylo - c) + br = Point (xhi + c) (yhi + c); bl = Point (xlo - c) (yhi + c) + ring = [tl, tr, br, bl] + -- entry/exit が乗る辺 index (TL-TR=0, TR-BR=1, BR-BL=2, BL-TL=3) + edgeOf (Point x y) = + snd $ minimum + [ (abs (y - ylo), 0 :: Int), (abs (x - xhi), 1) + , (abs (y - yhi), 2), (abs (x - xlo), 3) ] + e0 = edgeOf entry; e1 = edgeOf exit_ + -- 辺 e0 から e1 へ時計回り / 反時計回りに渡る corner 列 + cw = [ ring !! ((i + 1) `mod` 4) | i <- takeWhile (/= e1) (iterate ((`mod` 4) . (+ 1)) e0) ] + ccw = [ ring !! (i `mod` 4) | i <- takeWhile (/= e1) (iterate ((`mod` 4) . (+ 3)) e0) ] + plen ps = polyLen (entry : ps ++ [exit_]) + in if e0 == e1 + then Nothing -- 同一辺内の接触 (貫通ではない) + else Just (if plen cw <= plen ccw then cw else ccw) + _ -> Nothing + +-- | box 貫通とみなす最小貫通長 (pt)。 角の接触・境界沿いを除外する。 +boxCrossEps :: Double +boxCrossEps = 2.0 + +-- | 迂回 corner waypoint を box から斜め外側へ逃がす量 (pt)。 spline の丸めが +-- box 辺 barrier に触れない余地を作る。 +cornerClear :: Double +cornerClear = 2.0 + +-- | 近接 taut 点の畳み込み (端点は保持)。 corner 挿入 ('avoidBoxTaut') で旧 waypoint と +-- 角が 1pt 未満で並ぶ backtrack を掃除し、 spline fit の零長セグメント荒れを防ぐ。 +dedupTaut :: Double -> [Point] -> [Point] +dedupTaut eps pts = case pts of + [] -> [] + [_] -> pts + (p0 : rest) -> + let lastP = last rest + mids = initSafe rest + step acc q = if vdist (head acc) q >= eps then q : acc else acc + kept = reverse (foldl step [p0] mids) + kept' = if length kept > 1 && vdist (last kept) lastP < eps + then initSafe kept else kept + in kept' ++ [lastP] + +-- (★ A7 試行メモ: box 4 辺を barrier に足す案は、 channel 壁 = box 辺ゆえ taut が +-- box 縁を沿走する正常区間まで「barrier 上のライド」 として fit 全棄却 → +-- forceflag 直角に縮退したため撤回。 貫通対策は 'avoidBoxTaut' の corner 挿入のみ。) + +-- | portal 列から channel 境界の barrier 線分群を作る。 左鎖 (portal.left を上→下に連結) +-- と右鎖 (portal.right を連結) の各隣接ペア。 spline はこの内側に留まる。 +channelBarriers :: [(Point, Point)] -> [(Point, Point)] +channelBarriers portals = + let lefts = map fst portals + rights = map snd portals + segs xs = filter (\(a, b) -> not (vequal a b)) (zip xs (drop 1 xs)) + in segs lefts ++ segs rights + +-- | graphviz Proutespline 入口。 barriers (channel 境界線分) + taut 折れ線 (端点含む) + +-- 端点接線方向 (ev0=始点, ev1=終点・**単位ベクトル**) から cubic Bézier 制御点列を返す。 +-- 戻り = [始点, c1, c2, 終点, c1, c2, 終点, ...] (= 先頭始点 + 3 点ずつの cubic segment)。 +-- +-- graphviz は endpoint slope を**呼出側 (dotsplines.c) が渡す**設計なので本 port も +-- ev0/ev1 を引数で受ける。 graphviz の @P->start.theta=-π/2 / P->end.theta=π/2 / +-- constrained@ は **内部の box-segment 境界** に適用される拘束で、 **実端点 (src/snk +-- port) の接線は port 方向 (斜め)** (一次実測: dot 14.1.5 gold は端点で斜め接線)。 +-- 呼出側 (routeEdge A3.3) は taut の端 segment 方向 = 自然 port 方向を渡す。 +-- (A3.1 で一時 rank 方向の垂直を渡したが、 これは narrow-portal 時代の symmetric V +-- taut への対症で、 A3.2 の y-sweep で taut が 4 点クリーン化した後は斜め近接 + +-- 強制垂直の衝突で内側 S を生むため A3.3 で自然方向へ戻した。) +proutespline :: [(Point, Point)] -> [Point] -> Point -> Point -> [Point] +proutespline _ [] _ _ = [] +proutespline _ [p] _ _ = [p] +proutespline barriers inps ev0 ev1 = + head inps : reallyroutespline barriers inps (vnorm ev0) (vnorm ev1) + +-- | route.c reallyroutespline。 1 本 fit を試み、 失敗なら最大偏差点で分割し再帰。 +-- 戻り = 3 点ずつの cubic segment 列 (始点は含まない)。 +reallyroutespline :: [(Point, Point)] -> [Point] -> Point -> Point -> [Point] +reallyroutespline barriers inps ev0 ev1 = + let (pa, va, pb, vb) = mkspline inps ev0 ev1 + in case splinefits barriers pa va pb vb inps of + Just cps -> cps + Nothing -> + let spliti = maxDevIndex inps + cip = inps !! spliti + v1 = vnorm (vsub cip (inps !! (spliti - 1))) + v2 = vnorm (vsub (inps !! (spliti + 1)) cip) + splitv = vnorm (vadd v1 v2) + in reallyroutespline barriers (take (spliti + 1) inps) ev0 splitv + ++ reallyroutespline barriers (drop spliti inps) splitv ev1 + +-- | route.c mkspline。 input 折れ線 + 端点単位方向 ev0/ev1 から、 端点接線の scale を +-- 最小二乗で解く。 戻り = (始点, 始点接線ベクトル, 終点, 終点接線ベクトル)。 +mkspline :: [Point] -> Point -> Point -> (Point, Point, Point, Point) +mkspline inps ev0 ev1 = + let p0 = head inps + p3 = last inps + -- 弦長パラメタ化 t ∈ [0,1] + cum = scanl (+) 0 (zipWith vdist inps (drop 1 inps)) + tot = last cum + ts = if tot > 1e-12 then map (/ tot) cum else map (const 0) cum + terms = + [ (a0, a1, tmp) + | (pt, t) <- zip inps ts + , let a0 = vscale (b1 t) ev0 + a1 = vscale (negate (b2 t)) ev1 + tmp = vsub pt (vadd (vscale (b01 t) p0) (vscale (b23 t) p3)) ] + c00 = sum [ vdot a0 a0 | (a0, _ , _ ) <- terms ] + c01 = sum [ vdot a0 a1 | (a0, a1, _ ) <- terms ] + c11 = sum [ vdot a1 a1 | (_ , a1, _ ) <- terms ] + x0 = sum [ vdot a0 tmp | (a0, _ , tmp) <- terms ] + x1 = sum [ vdot a1 tmp | (_ , a1, tmp) <- terms ] + det01 = c00 * c11 - c01 * c01 + s0d = (x0 * c11 - x1 * c01) / det01 -- detX1/det01 + s3d = (c00 * x1 - c01 * x0) / det01 -- det0X/det01 + d01 = vdist p0 p3 / 3 + (s0, s3) + | abs det01 < 1e-6 || s0d <= 0 || s3d <= 0 = (d01, d01) + | otherwise = (s0d, s3d) + in (p0, vscale s0 ev0, p3, vscale s3 ev1) + +-- | route.c splinefits。 mkspline の接線を a/3 倍 (a=4 から半減) しつつ control 点を作り、 +-- channel 内に収まる最大 (= 滑らかな) ものを採用。 inpn==2 は強制採用 (forceflag)。 +-- +-- ★ Phase 52 A2 (2026-07-08): channel 内でも control polygon が taut 比 +-- 'hairpinCap' 倍を超える候補は hairpin (接線暴走) として棄却する。 +-- 真因 (A1 実測 = design/phase52-kink/): taut が 3 点 + 屈曲が終端寄りだと +-- 'mkspline' の最小二乗が厳密解に退化し接線 scale が爆発 (kink 辺 = taut 比 +-- 2.18 倍超、 健全辺 ≤ ~1.3 倍)。 graphviz は box 列が taut を密に拘束するため +-- 顕在化しないが、 我々の channel は片側が graph bbox 端 (R1) まで開くことが +-- あり、 暴走 S 字が「channel 内」 と誤判定されていた。 棄却後は a 半減で +-- 平坦化 → それでも合わなければ従来どおり分割 (= graphviz と同じ収束先)。 +splinefits :: [(Point, Point)] -> Point -> Point -> Point -> Point -> [Point] -> Maybe [Point] +splinefits barriers pa va pb vb inps = goA 4 True + where + forceflag = length inps == 2 + inLen = polyLen inps + goA a first = + let s1 = vadd pa (vscale (a / 3) va) + s2 = vsub pb (vscale (a / 3) vb) + sps = [pa, s1, s2, pb] + in if first && polyLen sps < inLen - 1e-3 + then Nothing -- control polygon が短すぎ → 分割へ + else if splineisinside barriers sps && polyLen sps <= hairpinCap * inLen + then Just [s1, s2, pb] + else if a < 0.005 + then if forceflag then Just [s1, s2, pb] else Nothing + else goA (if a > 0.01 then a / 2 else 0) False + +-- | Phase 52 A2: hairpin 判定の control polygon 長 / taut 長 の上限比。 +-- A1 実測 (routes-before.csv): kink 5 辺 = 2.18〜2.6 倍 / 健全辺 ≤ ~1.3 倍。 +hairpinCap :: Double +hairpinCap = 1.5 + +-- | inps[0]..inps[n-1] の chord (始点-終点) から最も離れた内部点の index。 +maxDevIndex :: [Point] -> Int +maxDevIndex inps = + let p0 = head inps + pn = last inps + n = length inps + ds = [ (distToSeg (inps !! i) p0 pn, i) | i <- [1 .. n - 2] ] + in if null ds then 1 else snd (maximum ds) + +-- | 点 p から線分 (a,b) への距離。 +distToSeg :: Point -> Point -> Point -> Double +distToSeg p a b = + let ab = vsub b a + l2 = vdot ab ab + in if l2 < 1e-12 then vdist p a + else let t = max 0 (min 1 (vdot (vsub p a) ab / l2)) + in vdist p (vadd a (vscale t ab)) + +polyLen :: [Point] -> Double +polyLen ps = sum (zipWith vdist ps (drop 1 ps)) + +-- | route.c splineisinside。 cubic (sps=[P0,c1,c2,P3]) が barrier 線分のいずれかを +-- 内部交差すれば外 (False)。 +splineisinside :: [(Point, Point)] -> [Point] -> Bool +splineisinside barriers sps = not (any crosses barriers) + where + crosses bar = case splineIntersectsLine sps bar of + Left () -> False -- 退化 (4) は continue (= 非交差扱い) + Right roots -> any (\t -> t > 1e-3 && t < 1 - 1e-3) roots + +-- | route.c splineintersectsline。 cubic (sps) と線分 lps の交差 t (spline 側) を返す。 +-- Left () = 退化 (graphviz の rootn==4 = 直線が spline 上に乗る/解無限)。 +splineIntersectsLine :: [Point] -> (Point, Point) -> Either () [Double] +splineIntersectsLine sps (lp0@(Point l0x l0y), lp1@(Point l1x l1y)) + | vequal lp0 lp1 = Right [] -- 退化 barrier (点) は無視 + | xc1 == 0 && yc1 == 0 = Right [] -- (到達しない・上で除外済) + | xc1 == 0 = -- 垂直線 + case solve3 (sub0 cx xc0) of + Left () -> Left () + Right rs -> Right [ t | t <- rs, t >= 0, t <= 1 + , let sv = (evalCubic cy t - yc0) / yc1 + , sv >= 0, sv <= 1 ] + | otherwise = -- 一般線 + let rat = yc1 / xc1 + combo = ( c0y - rat * c0x + rat * xc0 - yc0 + , c1y - rat * c1x + , c2y - rat * c2x + , c3y - rat * c3x ) + in case solve3 combo of + Left () -> Left () + Right rs -> Right [ t | t <- rs, t >= 0, t <= 1 + , let sv = (evalCubic cx t - xc0) / xc1 + , sv >= 0, sv <= 1 ] + where + [Point p0x p0y, Point p1x p1y, Point p2x p2y, Point p3x p3y] = sps + cx@(c0x, c1x, c2x, c3x) = points2coeff p0x p1x p2x p3x + cy@(c0y, c1y, c2y, c3y) = points2coeff p0y p1y p2y p3y + xc0 = l0x; xc1 = l1x - l0x + yc0 = l0y; yc1 = l1y - l0y + sub0 (a, b, c, d) k = (a - k, b, c, d) + +-- | Bézier control 値 (1D) → power-basis 係数 (c0 + c1 t + c2 t² + c3 t³)。 +points2coeff :: Double -> Double -> Double -> Double -> (Double, Double, Double, Double) +points2coeff p0 p1 p2 p3 = + ( p0 + , 3 * (p1 - p0) + , 3 * (p0 - 2 * p1 + p2) + , p3 - 3 * p2 + 3 * p1 - p0 ) + +-- | power-basis cubic を t で評価。 +evalCubic :: (Double, Double, Double, Double) -> Double -> Double +evalCubic (a, b, c, d) t = a + t * (b + t * (c + t * d)) + +-- | 実 cubic 求解 (solvers.c solve3 相当)。 戻り Right = 実根列、 Left () = 退化 (恒等0)。 +-- 係数は power basis (c0 + c1 x + c2 x² + c3 x³)。 +solve3 :: (Double, Double, Double, Double) -> Either () [Double] +solve3 (c0, c1, c2, c3) + | abs c3 < tiny = solve2 (c0, c1, c2) + | otherwise = + let a = c2 / c3; b = c1 / c3; c = c0 / c3 + p = b - a * a / 3 + q = 2 * a * a * a / 27 - a * b / 3 + c + shift = - a / 3 + disc = q * q / 4 + p * p * p / 27 + in Right $ map (+ shift) $ + if disc > tiny + then [ cbrt (- q / 2 + sqrt disc) + cbrt (- q / 2 - sqrt disc) ] + else if disc < - tiny + then let m = 2 * sqrt (- p / 3) + th = acos (clampU ((3 * q) / (p * m))) / 3 + in [ m * cos (th - 2 * pi * fromIntegral k / 3) | k <- [0, 1, 2 :: Int] ] + else let u = cbrt (- q / 2) in [2 * u, - u] + where tiny = 1e-12 + +solve2 :: (Double, Double, Double) -> Either () [Double] +solve2 (c0, c1, c2) + | abs c2 < tiny = solve1 (c0, c1) + | otherwise = + let disc = c1 * c1 - 4 * c2 * c0 + in if disc < - tiny then Right [] + else if disc < tiny then Right [ - c1 / (2 * c2) ] + else let s = sqrt disc in Right [ (- c1 + s) / (2 * c2), (- c1 - s) / (2 * c2) ] + where tiny = 1e-12 + +solve1 :: (Double, Double) -> Either () [Double] +solve1 (c0, c1) + | abs c1 < tiny = if abs c0 < tiny then Left () else Right [] + | otherwise = Right [ - c0 / c1 ] + where tiny = 1e-12 + +cbrt :: Double -> Double +cbrt x = signum x * (abs x ** (1 / 3)) + +clampU :: Double -> Double +clampU = max (-1) . min 1 + +-- | Bernstein 基底 (b01 = B0+B1, b23 = B2+B3)。 mkspline 用。 +b1, b2, b01, b23 :: Double -> Double +b1 t = 3 * t * (1 - t) * (1 - t) +b2 t = 3 * t * t * (1 - t) +b01 t = (1 - t) ** 3 + b1 t +b23 t = b2 t + t ** 3 + +-- =========================================================================== +-- Phase 52 A6: port 分散 (同一 node の近接重複 port を境界に沿って扇状に) +-- =========================================================================== + +-- | route 端点の種別 (発 = 始点 / 着 = 終点)。 +data PortEnd = SrcEnd | SnkEnd deriving (Eq, Show) + +-- | Phase 52 A6: 同一 node を共有する複数 edge の port が近接重複 ('portClusterEps' +-- 以内) するとき、 node 境界に沿って 'portSep' 間隔の扇状に分散する post-pass。 +-- graphviz P6 sameports 段 (correspondence doc Step 5、 未実装) の実用版。 +-- route 全体は動かさず**端点 + 隣接制御点を同 delta 平行移動**するだけなので +-- 曲線形状は保たれる (delta は数 pt)。 bake ('dagBakeRoutes') と live +-- ('renderDAGStandalone') の両 pipeline が同順で呼ぶ (= HS/PS parity 維持)。 +spreadPorts + :: (Double -> Double -> Point) -> Double + -> [(DAGNode, DAGNode)] -- ^ 各 route の (from, to)。 routes と同順 + -> [EdgeRoute] -> [EdgeRoute] +spreadPorts toScreen radius ends routes = + let idx = zip [0 :: Int ..] (zip ends routes) + occs = concat + [ [ (dnId f, SrcEnd, i, f), (dnId t, SnkEnd, i, t) ] + | (i, ((f, t), _)) <- idx ] + nids = dedupTexts [ nid | (nid, _, _, _) <- occs ] + deltas = concatMap nodeDeltas nids + applyAll r i = + foldl (\acc (j, e, d) -> if j == i then adjustEnd e d acc else acc) r deltas + in [ applyAll r i | (i, (_, r)) <- idx ] + where + routeOf i = routes !! i + -- node ごとの port cluster を検出し、 各 member の (routeIx, End, delta) を返す + nodeDeltas nid = + let members = + [ (i, end, n) + | (i, (f, t)) <- zip [0 :: Int ..] ends + , (end, n) <- [(SrcEnd, f), (SnkEnd, t)] + , dnId n == nid ] + in case members of + ((_, _, n0) : _) | length members >= 2 -> + let center = toScreen (dnX n0) (dnY n0) + withGeo = + [ (i, end, n, port, ang (vsub adj center)) + | (i, end, n) <- members + , let r = routeOf i + , let port = endPoint end r + , let adj = adjPoint end r ] + -- port 角で整列 → 近接 (境界弧距離 < portClusterEps) を cluster 化 + sorted = sortOnD (\(_, _, _, p, _) -> ang (vsub p center)) withGeo + clusters = clusterBy + (\(_, _, _, p1, _) (_, _, _, p2, _) -> vdist p1 p2 < portClusterEps) + sorted + in concatMap (fanCluster center) clusters + _ -> [] + fanCluster center cl + | length cl < 2 = [] + | otherwise = + let k = length cl + -- 隣接点方向の角度順に並べ、 扇の並びと route の向きを一致させる + ordered = sortOnD (\(_, _, _, _, aAdj) -> aAdj) cl + rEff = maximum (1 : [ vdist p center | (_, _, _, p, _) <- cl ]) + dTh = portSep / rEff + phi0 = ang (vsub (avgP [ p | (_, _, _, p, _) <- cl ]) center) + in [ (i, end, vsub newPort port) + | (j, (i, end, n, port, _)) <- zip [0 :: Int ..] ordered + , let phi = phi0 + (fromIntegral j - fromIntegral (k - 1) / 2) * dTh + , let target = vadd center (Point (100 * cos phi) (100 * sin phi)) + , let newPort = edgePortPoint n center target radius ] + endPoint SrcEnd r = case samplePts r of (p : _) -> p; [] -> Point 0 0 + endPoint SnkEnd r = case reverse (samplePts r) of (p : _) -> p; [] -> Point 0 0 + -- 扇の並び順に使う「進入回廊」 点 = 端から弧長 'portBackDist' 手前の経路点。 + -- port 直近の制御点 (局所接線) だと近接方向の edge 対で順序が逆転し、 分散後に + -- 経路がクロスする (実測: corr6 chd 着の genetics/exercise が接線角 0.03rad 差で + -- 逆順 → 交差)。 回廊は経路サンプル折れ線を端から遡って取る。 + adjPoint end r = + let poly = case end of + SrcEnd -> samplePts r + SnkEnd -> reverse (samplePts r) + in walkBack portBackDist poly + walkBack _ [] = Point 0 0 + walkBack _ [p] = p + walkBack budget (p : q : rest) + | d >= budget = q + | otherwise = walkBack (budget - d) (q : rest) + where d = vdist p q + -- route を折れ線近似 (cubic は各セグメント 8 分割) + samplePts r = case r of + StraightArrow a b -> [a, b] + SplinePath ps -> ps + BezierPath ps -> ps + CubicPath (p0 : rest) -> p0 : concat + [ [ bezPt a c1 c2 b (fromIntegral k / 8) | k <- [1 .. 8 :: Int] ] + | (a, c1, c2, b) <- segsOf p0 rest ] + CubicPath [] -> [] + segsOf cur (c1 : c2 : p3 : more) = (cur, c1, c2, p3) : segsOf p3 more + segsOf _ _ = [] + bezPt (Point x0 y0) (Point x1 y1) (Point x2 y2) (Point x3 y3) t = + let mt = 1 - t + f a b c d' = mt*mt*mt*a + 3*mt*mt*t*b + 3*mt*t*t*c + t*t*t*d' + in Point (f x0 x1 x2 x3) (f y0 y1 y2 y3) + avgP ps = let n = fromIntegral (length ps) + in Point (sum [ x | Point x _ <- ps ] / n) (sum [ y | Point _ y <- ps ] / n) + ang (Point x y) = atan2 y x + +-- | route の端点 (+cubic は隣接制御点も) を delta 平行移動する。 +adjustEnd :: PortEnd -> Point -> EdgeRoute -> EdgeRoute +adjustEnd end d r = case (end, r) of + (SrcEnd, StraightArrow a b) -> StraightArrow (vadd a d) b + (SnkEnd, StraightArrow a b) -> StraightArrow a (vadd b d) + (SrcEnd, SplinePath (p : rest)) -> SplinePath (vadd p d : rest) + (SnkEnd, SplinePath ps) -> SplinePath (mapLast (`vadd` d) ps) + (SrcEnd, BezierPath (p : rest)) -> BezierPath (vadd p d : rest) + (SnkEnd, BezierPath ps) -> BezierPath (mapLast (`vadd` d) ps) + (SrcEnd, CubicPath (p0 : c1 : rest)) -> CubicPath (vadd p0 d : vadd c1 d : rest) + (SnkEnd, CubicPath ps) -> CubicPath (mapLast2 (`vadd` d) ps) + _ -> r + where + mapLast f xs = case reverse xs of + (z : zs) -> reverse (f z : zs) + [] -> xs + mapLast2 f xs = case reverse xs of + (z : y : zs) -> reverse (f z : f y : zs) + [z] -> [f z] + [] -> xs + +-- | port cluster 判定の近接閾値 (pt)。 これ未満の port 対は「重なって見える」。 +portClusterEps :: Double +portClusterEps = 4.0 + +-- | 分散後の port 間隔 (境界弧距離、 pt)。 矢印幅 (~8pt) が重ならない程度。 +portSep :: Double +portSep = 7.0 + +-- | 扇順序の「進入回廊」 を測る端からの弧長 (pt)。 局所接線より遠くで測ることで +-- 近接方向 edge 対の順序逆転 (= 分散後クロス) を防ぐ。 +portBackDist :: Double +portBackDist = 20.0 + +-- | 整列済みリストを隣接述語で連結 cluster に分割する。 +clusterBy :: (a -> a -> Bool) -> [a] -> [[a]] +clusterBy _ [] = [] +clusterBy eq (x : xs) = go [x] xs + where + go acc [] = [reverse acc] + go acc@(prev : _) (y : ys) + | eq prev y = go (y : acc) ys + | otherwise = reverse acc : go [y] ys + go [] _ = [] + +-- | 挿入ソート (射影キー・小規模用)。 +sortOnD :: Ord b => (a -> b) -> [a] -> [a] +sortOnD f = foldr ins [] + where + ins x [] = [x] + ins x (z : zs) | f x <= f z = x : z : zs + | otherwise = z : ins x zs + +-- | Text の重複除去 (順序保持・小規模用)。 +dedupTexts :: [Text] -> [Text] +dedupTexts = go [] + where + go _ [] = [] + go seen (x : xs) | x `elem` seen = go seen xs + | otherwise = x : go (x : seen) xs + +-- | Phase 1 A7: edge と node 形状の正確な交点を返す (= 矢印 port)。 +-- 'nodeAt' = node 中心 (screen 座標)、 'target' = edge 反対側 (= 方向決定用)、 +-- 'baseR' = node の size scale。 楕円 / 矩形いずれも中心から target 方向へ伸ばし、 +-- 形状境界との交点を解析的に計算。 +edgePortPoint :: DAGNode -> Point -> Point -> Double -> Point +edgePortPoint n (Point cx cy) (Point tx ty) baseR = + let (rx, ry) = nodeExtent n baseR -- ★A15-1: renderNode と同じ可変サイズを共有 + dx = tx - cx + dy = ty - cy + len = sqrt (dx * dx + dy * dy) + (ux, uy) = if len > 1e-12 then (dx / len, dy / len) else (1, 0) + t = case dnKind n of + NodeLatent -> ellipseT + NodeObserved -> ellipseT + NodeDeterministic -> rectT + NodeData -> rectT + NodeOther -> rectT + -- 楕円 (x/rx)^2 + (y/ry)^2 = 1 と方向 (ux, uy) の交点パラメタ + ellipseT = + let a = (ux / rx) ^ (2 :: Int) + (uy / ry) ^ (2 :: Int) + in if a > 0 then 1 / sqrt a else baseR + -- 矩形 |x| ≤ rx, |y| ≤ ry と方向の交点 (= 軸方向最小値) + rectT = + let txT = if abs ux > 1e-12 then rx / abs ux else 1 / 0 + tyT = if abs uy > 1e-12 then ry / abs uy else 1 / 0 + in min txT tyT + in Point (cx + ux * t) (cy + uy * t) + +-- | DAG ノードの半径 (rx, ry) を label 文字幅に合わせて算出 (Phase 52.A15-1)。 +-- 'renderNode' と 'edgePortPoint' が共有し、 形状端と edge port を一致させる。 +-- deterministic は dist sublabel を出さない (= 1 行)。 @baseR@ は最小サイズの下限。 +-- +-- Phase 39 P8 A4-2: 横半幅 rx の本体 (radius 非依存部) は layout と共有する +-- 'dagNodeBaseHalfWidth' に一本化した。 ここでは render-time に既知の baseR +-- (= radius) を floor として被せるだけ。 +nodeExtent :: DAGNode -> Double -> (Double, Double) +nodeExtent n baseR = + let showDist = nodeShowsDist n + rx = max baseR (dagNodeBaseHalfWidth n) + nLines = if showDist then 3 else 1 :: Int + lineH = dagLabelFs + 3 + ry = max (baseR * 0.7) (fromIntegral nLines * lineH / 2 + 4) + in (rx, ry) + +-- | dist sublabel (@~ Dist@) を描くか。 deterministic は派生量ゆえ分布を持たず name のみ (PyMC 慣例)。 +nodeShowsDist :: DAGNode -> Bool +nodeShowsDist n = case dnKind n of + NodeDeterministic -> False + _ -> case dnDist n of Just _ -> True; Nothing -> False + +-- | Phase 39 A2-8 / A4 (nested): plate 枠の **実 bbox (pt 空間)** = (xlo, boxTop, xhi, yhi)。 +-- label 帯を含む描画矩形そのもの。 'renderPlate' (描画) と pt 空間 edge router +-- (障害物判定) が共有する。 member が 1 つも無ければ Nothing。 +-- +-- A4 (nested plate): graphviz の cluster bbox 計算 (= 子 cluster box ∪ 直接 member +-- glyph box を union し、 自身の margin を 1 段ぶん足す) を **再帰** で忠実再現する。 +-- これにより nested plate の親枠が子枠の外側 margin (graphviz @CL_OFFSET@ 相当) に出る +-- (= 旧実装は親も子も member 極値から flat margin で再計算し境界が一致していた)。 +-- leaf plate (子無し) は @directIds = 全 member@ ・ @childBoxes = []@ で従来と完全同一 +-- (= 図ビット不変)。 自身の直接子は 'plateChildrenOf' で 'allPlates' の包含関係から復元。 +plateBoxPt :: (Double -> Double -> Point) -> Double + -> [(Text, DAGNode)] -> [DAGPlate] -> DAGPlate + -> Maybe (Double, Double, Double, Double) +plateBoxPt toScreen radius nodeMap allPlates plate = + let children = plateChildrenOf allPlates plate + childIds = concatMap dpNodeIds children + directIds = [ i | i <- dpNodeIds plate, i `notElem` childIds ] + included = mapMaybe (\i -> lookup i nodeMap) directIds + -- 直接 member の glyph box (= left, right, top, bottom) + memberBoxes = [ (x - gx, x + gx, y - gy, y + gy) + | n <- included + , let Point x y = toScreen (dnX n) (dnY n) + , let (gx, gy) = nodeExtent n radius ] + -- 子 plate の box (= 既に各自の margin + label 帯込み)。 (xlo, boxTop, xhi, yhi) + -- を本関数 tuple 規約 (left, right, top, bottom) に並べ替えて union 対象に混ぜる。 + childBoxes = [ (xlo, xhi, boxTop, yhi) + | c <- children + , Just (xlo, boxTop, xhi, yhi) + <- [plateBoxPt toScreen radius nodeMap allPlates c] ] + boxes = memberBoxes ++ childBoxes + in case boxes of + [] -> Nothing + _ -> + let margin = radius * 0.5 + labelH = 14 + xlo = minimum [a | (a, _, _, _) <- boxes] - margin + ylo = minimum [b | (_, _, b, _) <- boxes] - margin + xhi = maximum [a | (_, a, _, _) <- boxes] + margin + yhi = maximum [b | (_, _, _, b) <- boxes] + margin + -- label 帯は枠の **下** に確保する (graphviz labelloc=b 同型)。 box 下端を + -- labelH ぶん広げ、 box 上端は member の margin のみ。 + in Just (xlo, ylo, xhi, yhi + labelH) + +-- | A4: plate 'parent' の **直接の子** plate (= graphviz subcluster) 群。 +-- 子 = nodeIds が parent の真部分集合で、 間に別の plate を挟まない (= immediate) もの。 +-- graphviz は cluster をネスト木として保持するが、 我々は plate list の包含関係から +-- 復元する (= 内側 plate の member ⊊ 外側 plate の member、 という運用前提)。 +plateChildrenOf :: [DAGPlate] -> DAGPlate -> [DAGPlate] +plateChildrenOf allPlates parent = + let strictSub q p = + let qs = dpNodeIds q; ps = dpNodeIds p + in all (`elem` ps) qs && not (all (`elem` qs) ps) + cands = [ q | q <- allPlates, strictSub q parent ] + immediate q = not (any (\r -> strictSub q r && strictSub r parent) cands) + in filter immediate cands + +-- (routeAroundBoxes は Phase 52 A5 で削除: Phase 39 A2-8 の遺物で caller ゼロ、 +-- channel/funnel + Proutespline (A-2/A-3/R3) に置換済。 実装は git 履歴参照。) diff --git a/src/Graphics/Hgg/Render/Layer.hs b/src/Graphics/Hgg/Render/Layer.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Render/Layer.hs @@ -0,0 +1,1361 @@ +-- | +-- Module : Graphics.Hgg.Render.Layer +-- Description : orchestration + renderLayer dispatch + facet/subplot/legend/annotation/inset/marginal +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +module Graphics.Hgg.Render.Layer where + +import Graphics.Hgg.Layout (Layout (..), Rect (..), Scale (..), + ViewportSize (..), computeLayout, + UCtx (..), resolvePosX, resolvePosY, + ggAxTextMar, ggAxTitleMar, ggHalfLine, + ggTickLen, niceTicks, extendedBreaks, scaleApply, + Track (..), solveTracks, + needsLegend, effectiveLegendPos, + coordOf, isPolar, polarCenter, polarPoint, + domFrac, projectXY, projectRectData, + projectBarRect, catUnitPx, AxisPlacement (..), + coordXAxisPlacement, coordYAxisPlacement, + coordXGridIsVertical, + legendBaseSize, legendKeyW, legendKeyPitch, + textWidthEm, legendGuideWidth, + numToText, nubKeep, findColorEnc, + effectiveLegendTitle, allColorCategories, + LegendGuide(..), collectGuides) +import Graphics.Hgg.Layout.RangeOf (qqPoints, ecdfPoints) -- Phase 11 A6-2/A6-4 +import Graphics.Hgg.Layout.Grid (GridCell (..), GridPlacement (..), + flattenSubplots) -- Phase 37 A3 +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Time.Format as Data.Time.Format +import Graphics.Hgg.Spec (Annotation (..), AxisFormat (..), + ColData (..), ColRef, + ColorEnc (..), ConnectSpec (..), + DAGEdge (..), DAGLayoutAlgorithm (..), + DAGNode (..), DAGNodeKind (..), + DAGPlate (..), DAGSpec (..), Layer (..), + RenderCtx (..), CustomMark (..), + LegendPosition (..), LegendSpec (..), + Inset (..), MarginalSpec (..), MarkKind (..), + MarkShape (..), ShapeMapEntry (..), + LineType (..), lineTypeDash, lineTypeForIndex, + ReferenceLine (..), Resolver, + Position (..), Coord (..), + FacetScales (..), freeScaleX, freeScaleY, + FacetSpace (..), freeSpaceX, freeSpaceY, + ThemeOverride (..), + VisualSpec (..), YAxisSide (..), axisFormatOf, + applyDiscreteLimits, ridgeAutoFlip, selectedSubplots, + axisRotateOf, resolveAxisAngle, axisShowTicksOf, + axisTextAngleXOf, axisTextAngleYOf, + axShowGrid, + FontSpec (..), orderedCats, + colRefName, resolveCol, resolveNum, + compositeLanes, inlineCat) +import Data.Maybe (mapMaybe, isJust, listToMaybe) +import Data.List (sortOn, foldl') +import qualified Data.Map.Strict as Map +import Data.List (dropWhile, elemIndex, groupBy, nub, + sort, takeWhile) +import qualified Graphics.Hgg.Spec +import Graphics.Hgg.Unit (Length (..), LUnit (..)) +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Numeric (showEFloat, showFFloat) + +import Graphics.Hgg.Primitive +import Graphics.Hgg.Render.Common +import Graphics.Hgg.Render.Basic +import Graphics.Hgg.Render.Distribution +import Graphics.Hgg.Render.Statistical +import Graphics.Hgg.Render.MCMC +import Graphics.Hgg.Render.Special + + +-- | spec → primitive 列。 layer ごとに mark kind に応じた変換 + 背景 + +-- title / xLabel / yLabel + 軸 + tick + (Phase 26 §C-2 #12) facet panel grid。 +renderToPrimitives :: Resolver -> Layout -> VisualSpec -> [Primitive] +renderToPrimitives r layout spec0 + | isDAGOnly spec = renderDAGOnly layout spec -- ★ §E-6 DAG 専用 path + | isPieOnly spec = renderPieStandalone r layout spec -- ★ Phase 8 B1: 軸なし pie + -- ★ Phase 36 B1c: ridge は標準軸 (連続 x = 値・カテゴリ y = 群) に載せ替え、 専用 path を廃止。 + | isEssOnly spec = renderEssStandalone r layout spec -- ★ Phase 8 B13: ess 専用 + | isAutocorrOnly spec = renderAutocorrStandalone r layout spec -- ★ Phase 8 B12: autocorr 専用 + | hasSubplots = renderSubplots r layout spec + | hasFacetGrid = renderFacetGrid r layout spec + | otherwise = case getLast (vsFacet spec) of + Just facetCol -> renderFaceted r layout spec facetCol + Nothing -> renderSingle r layout spec + where + -- ★ Phase 18 A2: 離散 limits を解決 (computeLayout と同じ・冪等・未指定 no-op) + -- ★ Phase 19 A1: 凡例正本 (全 layer union) を glyph 側 lyColorCats へ注入 + spec = injectColorCats r (ridgeAutoFlip (applyDiscreteLimits r spec0)) -- ★ B1c: ridge→coord_flip + hasSubplots = not (null (vsSubplots spec)) + hasFacetGrid = isJust (getLast (vsFacetRow spec)) + || isJust (getLast (vsFacetCol spec)) + +-- | Pie 専用 spec か判定 (= 全 layer が MPie)。 +isPieOnly :: VisualSpec -> Bool +isPieOnly spec = case vsLayers spec of + [] -> False + ls -> all (\l -> case getFirst (lyKind l) of + Just MPie -> True + _ -> False) ls + +-- | Phase 8 B1: pie 専用描画 (= 軸 / tick / grid 無し、 PS renderPieOnly と同型)。 +-- 背景 + title だけ描き、 扇形 + 項目名ラベルは renderPie に委譲。 +renderPieStandalone :: Resolver -> Layout -> VisualSpec -> [Primitive] +renderPieStandalone r layout spec = + let pal = specThemePalette spec + in background layout pal + <> labels layout spec pal + <> concatMap (renderPie r layout pal) (vsLayers spec) + +-- | Ess 専用 spec か判定 (= 全 layer が MEss)。 +isEssOnly :: VisualSpec -> Bool +isEssOnly spec = case vsLayers spec of + [] -> False + ls -> all (\l -> case getFirst (lyKind l) of + Just MEss -> True + _ -> False) ls + +-- | Phase 8 B13: ess 専用描画。 x = 名前 (categorical) / y = ESS 値で軸が転置するため +-- Layout の tickMarks (x=値前提) を使わず、 renderESS が自前で軸 + y 目盛り + 名前を描く。 +renderEssStandalone :: Resolver -> Layout -> VisualSpec -> [Primitive] +renderEssStandalone r layout spec = + let pal = specThemePalette spec + in background layout pal + <> labels layout spec pal + <> concatMap (renderESS r layout pal) (vsLayers spec) + +-- | Autocorr 専用 spec か判定 (= 全 layer が MAutocorr)。 +isAutocorrOnly :: VisualSpec -> Bool +isAutocorrOnly spec = case vsLayers spec of + [] -> False + ls -> all (\l -> case getFirst (lyKind l) of + Just MAutocorr -> True + _ -> False) ls + +-- | Phase 8 B12: autocorr 専用描画。 x = lag / y = 相関で軸が転置するため Layout の +-- tickMarks (x=値前提) を使わず、 renderAutocorr が自前で軸 + lag/相関 を描く。 +renderAutocorrStandalone :: Resolver -> Layout -> VisualSpec -> [Primitive] +renderAutocorrStandalone r layout spec = + let pal = specThemePalette spec + in background layout pal + <> labels layout spec pal + <> concatMap (renderAutocorr r layout pal) (vsLayers spec) + +-- | Phase 6+ C-6: subplots layout (= 任意 spec を grid 並列)。 +-- ★ Phase 37 A3 (統一グリッド): vsSubplots / @<->@ / @<:>@ のネストを +-- 'flattenSubplots' で **単一グリッド**へ平坦化し、 各 leaf パネルに +-- @(rowStart,rowSpan,colStart,colSpan)@ を割り当てる。 旧実装は各 subplots レベルが +-- 独立に grid を組み、 ネストは renderToPrimitives で再帰描画していたため、 ネスト境界を +-- またいだパネル本体が整列しなかった。 平坦化により描画はこのグリッド 1 枚に対して +-- 「列ごと左右帯・行ごと上下帯」 を 1 回だけ確保するだけになり、 任意の深さで本体が整列する。 +-- +-- gtable 配置 (patchwork 流): 各 leaf を span を含む推定セル寸法で独立 computeLayout し、 +-- 必要マージンを得る。 列ごとに左右帯 = 最大マージン (始まり列 / 終わり列で集約)、 行ごとに +-- 上下帯 = 最大マージンを 1 回確保し、 残りをパネル本体として列/行で均等割り。 span パネルの +-- 本体はまたぐ列/行の本体 + 内側帯 + pad を内包する。 container 自身の phantom 軸マージンは +-- A1 で除去済 (Layout の isContainer 分岐)。 +-- +-- ★既知の制約: 平坦化は leaf のみを残すため、 ネスト中間の subplots ノードに付けた +-- title/theme は描かれない (operator チェーンの中間ノードは純粋な構造なので通常問題ない。 +-- 全体 theme は top spec から themeCtx で全 leaf に伝播する)。 +renderSubplots :: Resolver -> Layout -> VisualSpec -> [Primitive] +renderSubplots r parentLayout spec = + let pal = specThemePalette spec + -- 外側 theme を各 panel に伝播 (panel 自身の設定が優先 = 右辺勝ち)。 + -- これが無いと panel の文字色等が既定のままで、 暗テーマ panel に黒文字が乗る。 + themeCtx = mempty { vsTheme = vsTheme spec + , vsThemeOverride = vsThemeOverride spec + , vsTitleFont = vsTitleFont spec + , vsAxisLabelFont = vsAxisLabelFont spec + , vsTickFont = vsTickFont spec + , vsLegendFont = vsLegendFont spec } + -- ★ Phase 37 A3: 入れ子も含め単一の統一グリッドへ平坦化 (vsPanelSel も toPTree 内で適用)。 + gp = flattenSubplots spec + gcols = gpCols gp + grows = gpRows gp + panels = gpPanels gp -- [(leaf spec, GridCell)] + area = lpPlotArea parentLayout + -- Phase 8 A2 Step3 (design §A-5): panel 間 spacing = ggplot panel.spacing 既定 = half_line。 + pad = ggHalfLine * lpMarginScale parentLayout + -- 等分の単一セル寸法 (帯算出前の margin 推定用)。 + estColW = (rW area - pad * fromIntegral (gcols - 1)) / fromIntegral gcols + estRowH = (rH area - pad * fromIntegral (grows - 1)) / fromIntegral grows + -- span を含む panel の推定寸法 (= 本体 colSpan/rowSpan 個 + 内側 pad)。 + estWOf c = estColW * fromIntegral (gcColSpan c) + pad * fromIntegral (gcColSpan c - 1) + estHOf c = estRowH * fromIntegral (gcRowSpan c) + pad * fromIntegral (gcRowSpan c - 1) + computed = [ (sub, c, computeLayout r (themeCtx <> sub + { vsWidth = Last (Just (Length (estWOf c) Pt)) + , vsHeight = Last (Just (Length (estHOf c) Pt)) })) + | (sub, c) <- panels ] + mTopOf cl = lpMarginTop cl + mLeftOf cl = lpMarginLeft cl + mBotOf cl = lpMarginBottom cl + -- 右マージンは plotArea から導出 (lpMarginRight は保持されないため)。panel 推定幅基準。 + mRightOf c cl = estWOf c - lpMarginLeft cl - rW (lpPlotArea cl) + -- 列 j の左帯 = 列 j 始まりの panel の mLeft 最大、 右帯 = 列 j 終わりの panel の mRight 最大。 + -- span パネルは始まり列に左帯・終わり列に右帯だけ寄与 (またぐ内側列には軸が無い)。 + colLeft j = maximum (0 : [ mLeftOf cl | (_, c, cl) <- computed, gcCol c == j ]) + colRight j = maximum (0 : [ mRightOf c cl | (_, c, cl) <- computed, gcCol c + gcColSpan c - 1 == j ]) + rowTop i = maximum (0 : [ mTopOf cl | (_, c, cl) <- computed, gcRow c == i ]) + rowBot i = maximum (0 : [ mBotOf cl | (_, c, cl) <- computed, gcRow c + gcRowSpan c - 1 == i ]) + sumLR = sum [ colLeft j + colRight j | j <- [0 .. gcols - 1] ] + sumTB = sum [ rowTop i + rowBot i | i <- [0 .. grows - 1] ] + bodyW = max 1 ((rW area - sumLR - pad * fromIntegral (gcols - 1)) / fromIntegral gcols) + bodyH = max 1 ((rH area - sumTB - pad * fromIntegral (grows - 1)) / fromIntegral grows) + colBodyX j = rX area + sum [ colLeft k + bodyW + colRight k + pad | k <- [0 .. j - 1] ] + colLeft j + rowBodyY i = rY area + sum [ rowTop k + bodyH + rowBot k + pad | k <- [0 .. i - 1] ] + rowTop i + -- span panel の本体矩形: 開始列の本体左 〜 終了列の本体右 (内側帯 + pad を内包)。 + panelRectOf c = + let c0 = gcCol c; c1 = c0 + gcColSpan c - 1 + r0 = gcRow c; r1 = r0 + gcRowSpan c - 1 + x0 = colBodyX c0; x1 = colBodyX c1 + bodyW + y0 = rowBodyY r0; y1 = rowBodyY r1 + bodyH + in Rect x0 y0 (x1 - x0) (y1 - y0) + bg = background parentLayout pal + -- Phase 11 A5-a: subtitle/caption/tag も labels で描く (= title 同様に root レベル)。 + -- ★ 全体タイトル/subtitle/caption/tag は panel グリッドの bounding box (左端 = + -- 第1列 panel の y 軸 'colBodyX 0'、 右端 = 最終列本体右) に揃える。 親 plotArea の + -- 左端 (= キャンバス左マージン) 基準だと全体タイトルが各 panel の y 軸より左へ + -- 飛び出す (subplots / hbm 図のタイトル不揃い)。 通常図の「タイトル = y 軸線に揃う」 + -- と統一。 rY/rH は親のまま (= タイトルは上端・caption は下端のまま)。 + gridLeft = colBodyX 0 + gridRight = colBodyX (gcols - 1) + bodyW + titleLayout = parentLayout + { lpPlotArea = (lpPlotArea parentLayout) { rX = gridLeft, rW = gridRight - gridLeft } } + title = case ( getLast (vsTitle spec), getLast (vsSubtitle spec) + , getLast (vsCaption spec), getLast (vsTag spec) ) of + (Nothing, Nothing, Nothing, Nothing) -> [] + _ -> labels titleLayout spec pal + subPrims = concat + [ let panelRect = panelRectOf c + subSized = themeCtx <> sub { vsWidth = Last (Just (Length (estWOf c) Pt)) + , vsHeight = Last (Just (Length (estHOf c) Pt)) } + finalLayout = subLayoutComputed + { lpPlotArea = panelRect + , lpXScale = scaleRetargetX (lpXScale subLayoutComputed) panelRect + , lpYScale = scaleRetargetY (lpYScale subLayoutComputed) panelRect + -- Phase 10 A5 (罠5): flip scale も panel に retarget しないと flip 時 + -- 全 panel が親 baseArea 基準で重なる。 + , lpXScaleFlipped = scaleRetargetY (lpXScaleFlipped subLayoutComputed) panelRect + , lpYScaleFlipped = scaleRetargetX (lpYScaleFlipped subLayoutComputed) panelRect + -- Phase 8 B16: viewport を 0 にして panel の background (全画面塗り) を抑制。 + , lpViewport = ViewportSize 0 0 + } + -- leaf パネルを描画 (平坦化済みなので vsSubplots は空 = 再帰しない。 facet/mark はあり得る)。 + in renderToPrimitives r finalLayout subSized + | (sub, c, subLayoutComputed) <- computed + ] + in bg <> title <> subPrims + +-- | DAG 専用 spec か判定 (= 全 layer が MDAG)。 +isDAGOnly :: VisualSpec -> Bool +isDAGOnly spec = case vsLayers spec of + [] -> False + ls -> all (\l -> case getFirst (lyKind l) of + Just MDAG -> True + _ -> False) ls + +-- | DAG 専用描画。 ★Phase 52: 他のプロット ('renderSingle') と**同じ枠組み**に統一した。 +-- 'computeLayout' が確保した 'lpPlotArea' (= title 帯 + 軸目盛りマージンを引いた軸内領域) に +-- DAG を描き、 title も 'labels' で標準位置 (他パネルと同じ高さ) に描く。 ただし**軸・グリッド・ +-- 枠・目盛り・軸タイトルは一切描かない** (= DAG では常に非表示)。 'labels' は title のみ描く +-- (DAG spec は xLabel/yLabel を持たないので軸タイトルは出ない)。 +-- +-- これにより DAG パネルの title 位置・plot area 枠が他パネルと揃う (subplot セルでも同じ: +-- 'labels' は viewport でなく lpPlotArea ± margin 基準で配置するため・'lpPlotArea' は親が +-- panelRect に retarget 済)。 旧実装は viewport±pad で独自に area/title を作っており、 DAG +-- だけ title がずれ、 入れ子セルから漏れていた (旧 A11 の viewport 特例も本統一で不要に)。 +renderDAGOnly :: Layout -> VisualSpec -> [Primitive] +renderDAGOnly layout spec = + let pal = specThemePalette spec + in background layout pal + <> labels layout spec pal + <> concatMap (renderDAGStandalone (lpPlotArea layout) pal) (vsLayers spec) + +renderSingle :: Resolver -> Layout -> VisualSpec -> [Primitive] +renderSingle r layout spec = + let pal = specThemePalette spec + fmtX = axisFormatOf (vsXAxis spec) + fmtY = axisFormatOf (vsYAxis spec) + rotX = resolveAxisAngle (vsXAxis spec) (axisTextAngleXOf (vsThemeOverride spec)) + rotY = resolveAxisAngle (vsYAxis spec) (axisTextAngleYOf (vsThemeOverride spec)) + showX = axisShowTicksOf (vsXAxis spec) + showY = axisShowTicksOf (vsYAxis spec) + -- Phase 26 §C-2 #10: marginal histogram のため plot area を縮める + (mainLayout, marginalPrims) = applyMarginal r pal layout spec + -- ★ Phase 33 B6: 注釈/参照線の Pos 解決に dpi (PAbs Px 用)。layout は pt なので + -- dpi は px 入力の pt 化にだけ使う (既定 96)。 + annotDpi = maybe 96 id (getLast (Graphics.Hgg.Spec.vsDpi spec)) + -- Phase 11 A7-a: coord_cartesian zoom が有効なときだけ glyph を panel に clip + -- (= 範囲外データが panel 外にはみ出すのを防ぐ)。 未指定では従来同一 (ゼロ diff)。 + hasCoordLim = getLast (vsCoordXLim spec) /= Nothing + || getLast (vsCoordYLim spec) /= Nothing + coordClip prims + | hasCoordLim = PClipPush (lpPlotArea mainLayout) : prims ++ [PClipPop] + | otherwise = prims + -- Phase 11 A7-c: 極座標は直交 grid/枠/tick の代わりに polarGrid (同心円 + スポーク)。 + polar = isPolar (coordOf spec) + gridAxisPrims + | polar = polarGrid spec mainLayout pal + | otherwise = gridLines mainLayout spec pal + <> axisFrame mainLayout pal + <> tickMarks (Just spec) mainLayout pal fmtX fmtY rotX rotY showX showY + in background mainLayout pal + -- Phase 9 A-1: plot bg の上に panel 背景 (theme_grey/ブランド) → その上に grid。 + <> panelBackground mainLayout pal + -- TODO-3b (2026-05-29): grid line を axisFrame 直後 (= layer の下) に + -- 描いて、 mark / refLine が grid の上に乗る順にする (= PS と同順序)。 + <> gridAxisPrims + -- Phase 8 C (marginal fix): title/軸ラベルは marginal で縮小する前の元 layout 基準で + -- 描く (= PS と同一)。 mainLayout (縮小後) だと title が marginal 帯に食い込む。 + -- marginal は上端/右端のみ縮小し下端・左端は不変なので xLabel/yLabel も整合。 + <> labels layout spec pal + -- Phase 8 B22: 右 Y 軸対象 layer は yScale を右軸 scale に swap して描画。 + <> coordClip (concatMap (renderLayerDual r mainLayout pal) (vsLayers spec)) + <> renderRightYAxis mainLayout pal (axisFormatOf (vsYAxisRight spec)) + <> concatMap (renderRefLine annotDpi mainLayout pal) (vsRefLines spec) + <> concatMap (renderAnnotation annotDpi mainLayout pal) (vsAnnotations spec) + <> renderLegend r mainLayout pal spec + <> marginalPrims + -- Phase 8 B21: inset (図中図)。 HS は従来 vsInsets を全く描いていなかった。 + <> concatMap (renderInset r layout pal) (vsInsets spec) + +-- | Phase 26 §C-2 #10: scatter の周辺に X/Y histogram を sub-plot として配置。 +-- main plot area を縮めて余白に小さな histogram を描く。 +applyMarginal :: Resolver -> ThemePalette -> Layout -> VisualSpec -> (Layout, [Primitive]) +applyMarginal r pal layout spec = case getLast (vsMarginal spec) of + Nothing -> (layout, []) + Just ms -> + let baseArea = lpPlotArea layout + topH = if msShowX ms then 60 else 0 + rightW = if msShowY ms then 60 else 0 + gutter = if topH > 0 || rightW > 0 then 8 else 0 + mainArea = Rect (rX baseArea) + (rY baseArea + topH + (if topH > 0 then gutter else 0)) + (rW baseArea - rightW - (if rightW > 0 then gutter else 0)) + (rH baseArea - topH - (if topH > 0 then gutter else 0)) + -- ★ Phase 8 B18: plotArea を縮めるだけでなく xScale/yScale の range も mainArea に + -- 再ターゲットする。 さもないと mark (散布図点など) や marginalHist が元の大きい枠 + -- 基準で位置決めされ、 縮小した軸枠からはみ出す (= scale の range = 位置決め基準)。 + mainLayout = layout + { lpPlotArea = mainArea + , lpXScale = scaleRetargetX (lpXScale layout) mainArea + , lpYScale = scaleRetargetY (lpYScale layout) mainArea + -- Phase 10 A5 (罠5): flip scale も追従 (XFlipped=縦 range, YFlipped=横 range)。 + , lpXScaleFlipped = scaleRetargetY (lpXScaleFlipped layout) mainArea + , lpYScaleFlipped = scaleRetargetX (lpYScaleFlipped layout) mainArea + } + nBins = msBins ms + -- 最初の layer の encX/encY を marginal source として使う + firstLayer = case vsLayers spec of + (l:_) -> Just l + [] -> Nothing + xPrims = if msShowX ms + then case firstLayer >>= getLast . lyEncX of + Just cr -> + let topArea = Rect (rX mainArea) (rY baseArea) (rW mainArea) topH + sx = lpXScale mainLayout + in marginalHist r pal cr topArea sx nBins False + Nothing -> [] + else [] + yPrims = if msShowY ms + then case firstLayer >>= getLast . lyEncY of + Just cr -> + let rightArea = Rect (rX mainArea + rW mainArea + gutter) + (rY mainArea) rightW (rH mainArea) + sy = lpYScale mainLayout + in marginalHist r pal cr rightArea sy nBins True + Nothing -> [] + else [] + in (mainLayout, xPrims <> yPrims) + +-- | 単一 ColRef を histogram として与えられた area に描画。 +-- isVertical=False (= X marginal、 上に置く、 bar は縦)、 +-- isVertical=True (= Y marginal、 右に置く、 bar は横)。 +marginalHist :: Resolver -> ThemePalette -> ColRef -> Rect -> Graphics.Hgg.Layout.Scale -> Int -> Bool -> [Primitive] +marginalHist r pal cr area scaleAlong nBins isVertical = + case resolveNum r cr of + Nothing -> [] + Just v | V.null v -> [] + Just v -> + let xs = V.toList v + lo = minimum xs + hi = maximum xs + binW = (hi - lo) / fromIntegral nBins + binIx vx = min (nBins - 1) (max 0 (floor ((vx - lo) / binW))) + counts = foldl (\acc vx -> + let i = binIx vx + cur = acc !! i + in take i acc <> [cur + 1] <> drop (i + 1) acc) + (replicate nBins (0 :: Int)) xs + maxC = max 1 (maximum counts) + c = tpDefault pal + a = 0.6 + in [ let xPos = scaleApply scaleAlong (lo + fromIntegral i * binW) + xPos' = scaleApply scaleAlong (lo + fromIntegral (i + 1) * binW) + normH = fromIntegral cnt / fromIntegral maxC + in if isVertical + then -- Y marginal: 右領域、 bar は横 (left → right) + let barW = normH * rW area + in PRect (Rect (rX area) (min xPos xPos') barW (abs (xPos - xPos'))) + (FillStyle c a) (Just (StrokeStyle c 0.5)) + else -- X marginal: 上領域、 bar は縦 (bottom → top) + let barH = normH * rH area + in PRect (Rect (min xPos xPos') (rY area + rH area - barH) + (abs (xPos - xPos')) barH) + (FillStyle c a) (Just (StrokeStyle c 0.5)) + | (i, cnt) <- zip [0 .. nBins - 1] counts ] + +-- | Phase 26 §C-2 #12: facet 列の distinct 値ごとに plot area を grid 分割し、 +-- 各セルに「その facet 値だけの sub-resolver」 で sub-spec を描画。 +-- 簡易実装: 1 行 N 列 (= horizontal flow)、 各 panel は独立 axis (= shared +-- 軸の縮尺対応は後続)。 +renderFaceted :: Resolver -> Layout -> VisualSpec -> ColRef -> [Primitive] +renderFaceted r layout spec facetCol = + let pal = specThemePalette spec + -- Phase 28: facet panel 順も ggplot 同様アルファベット順 (= R4DS facet_wrap)。 + facetVals = case resolveCol r facetCol of + Just (TxtData v) -> orderedCats (V.toList v) + Just (NumData v) -> orderedCats (V.toList (V.map (T.pack . show) v)) + Nothing -> [] + nPanels = length facetVals + in if nPanels == 0 then renderSingle r layout spec + else + let baseArea = lpPlotArea layout + -- Phase 8 A2 Step3 (design §A-5): panel.spacing = half_line (sc 縮小)。 + gutter = ggHalfLine * lpMarginScale layout + headerH = 18 -- panel 上の strip label (群名) 用 + -- Phase 8 C G7: facet_wrap 複数行。 vsFacetNcol 未指定 = 1 行 N 列 (非破壊)、 + -- 指定 = n 列で nRows = ceil(nPanels/n) 行に折り返す。 軸 drop は ggplot 流に + -- 「同列の下に panel が無い (= 最下) panel のみ x 軸」「左端列のみ y 軸」。 + nCols = case getLast (vsFacetNcol spec) of + Just n | n > 0 -> min n nPanels + _ -> nPanels + nRows = (nPanels + nCols - 1) `div` nCols + -- Phase 8 C (gtable §E-3): 列/行を solveTracks トラックで割付。 列 = nCols 個の + -- Null + (nCols-1) gutter、 行 = 各行 [Fixed headerH(strip), Null panel] を gutter + -- 区切り。 Null トラックがパネル本体 (= 従来の cellW/cellH 均等割りと数値同値)。 + -- ★ A6: free y は各 panel が独立 y 軸を出すため、 panel 間 gutter に y 軸帯 + -- (lpMarginLeft 相当) を加算し、 目盛りラベルが左隣 panel に被るのを防ぐ。 + -- fixed (左端列のみ y 軸) は yBand=0 で従来不変。 + yBand = if freeY then lpMarginLeft layout else 0 + hTracks = concat [ if c == 0 then [Null 1] else [Fixed (gutter + yBand), Null 1] + | c <- [0 .. nCols - 1] ] + vTracks = concat [ (if rr == 0 then [] else [Fixed gutter]) + ++ [Fixed (fromIntegral headerH), Null 1] + | rr <- [0 .. nRows - 1] ] + nullSlots ts solved = [ sl | (Null _, sl) <- zip ts solved ] + hPanels = nullSlots hTracks (solveTracks (rX baseArea) (rW baseArea) hTracks) + vPanels = nullSlots vTracks (solveTracks (rY baseArea) (rH baseArea) vTracks) + fmtX = axisFormatOf (vsXAxis spec) + fmtY = axisFormatOf (vsYAxis spec) + rotX = resolveAxisAngle (vsXAxis spec) (toAxisTextAngle (vsThemeOverride spec)) + rotY = resolveAxisAngle (vsYAxis spec) (toAxisTextAngle (vsThemeOverride spec)) + showXt = axisShowTicksOf (vsXAxis spec) + showYt = axisShowTicksOf (vsYAxis spec) + -- Phase 8 B19: panel には title/軸ラベルを持たせない (= 全体で 1 回だけ描く)。 + specPanel = spec { vsFacet = Last Nothing, vsTitle = Last Nothing + , vsXLabel = Last Nothing, vsYLabel = Last Nothing + , vsSubtitle = Last Nothing, vsCaption = Last Nothing + , vsTag = Last Nothing } + (stripBg, showStrip) = themeStripStyle spec -- Phase 9 A-4 + -- ★ Phase 11 A7-b: facet free scales。 free な軸は panel ごとに sub-resolver で + -- computeLayout して独立 domain を得る (= subplots と同手法)、 fixed は従来通り + -- parent layout の scale を range だけ retarget。 + facetSc = maybe FacetFixed id (getLast (vsFacetScales spec)) + freeX = freeScaleX facetSc + freeY = freeScaleY facetSc + panelFor (idx, val) = + let col = idx `mod` nCols + row = idx `div` nCols + (cellX, cellW) = hPanels !! col + (panelTop, panelH) = vPanels !! row + -- ★ Phase 8 B19: plotArea だけでなく scale range も panelArea に再ターゲット + -- (= B18 marginal と同根。 これをしないと点が baseArea 全幅基準で描かれ、 + -- 全 panel が重なって左/中央が空に見える)。 + panelArea = Rect cellX panelTop cellW panelH + subResolver = filterResolver r facetCol val + -- free な軸の domain は panel 自身のデータで再計算 (fixed は parent layout)。 + panelDomLayout + | freeX || freeY = computeLayout subResolver specPanel + | otherwise = layout + xSrc = if freeX then panelDomLayout else layout + ySrc = if freeY then panelDomLayout else layout + subLayout = layout + { lpPlotArea = panelArea + , lpXScale = scaleRetargetX (lpXScale xSrc) panelArea + , lpYScale = scaleRetargetY (lpYScale ySrc) panelArea + -- Phase 10 A5 (罠5): flip scale も panel に retarget (XFlipped=縦, YFlipped=横)。 + , lpXScaleFlipped = scaleRetargetY (lpXScaleFlipped xSrc) panelArea + , lpYScaleFlipped = scaleRetargetX (lpYScaleFlipped ySrc) panelArea + -- free 軸は panel 固有の tick / categorical label / 明示 label を採用。 + , lpXTicks = lpXTicks xSrc + , lpYTicks = lpYTicks ySrc + , lpXCategoryLabels = lpXCategoryLabels xSrc + , lpYCategoryLabels = lpYCategoryLabels ySrc + , lpXTickLabels = lpXTickLabels xSrc + , lpYTickLabels = lpYTickLabels ySrc } + isLeft = col == 0 -- y tick は左端列のみ + isBottom = idx + nCols >= nPanels -- 同列の下に panel が無い = x 軸あり + -- Phase 10 A5 ②-fix: flip では tickMarks がデータ x を縦軸(左)・データ y を + -- 横軸(下)に転置するので、 内側軸 drop の gating も入替える (gateX=データ x 軸の + -- 可視判定、 gateY=データ y 軸の可視判定)。 入替えないと縦軸が全 panel に出て重なり、 + -- 横軸が左端 panel しか出ない (= ユーザ browser 報告と一致したバグ)。 + -- ★ A7-b: free 軸は各 panel が独立 scale を持つので全 panel に軸を表示。 + (baseGX, baseGY) = case lpCoord layout of + CoordFlip -> (isLeft, isBottom) + _ -> (isBottom, isLeft) + gateX = freeX || baseGX + gateY = freeY || baseGY + -- Phase 9 A-4: strip 背景帯 (灰矩形) を文字の背後に。 帯 = panel 上の headerH 分。 + stripRect = [ PRect (Rect cellX (panelTop - fromIntegral headerH) cellW (fromIntegral headerH)) + (FillStyle stripBg 1.0) Nothing + | showStrip ] + header = stripRect <> + [ PText + (Point (cellX + cellW / 2) (panelTop - 4)) + val + (mkFontTS (Just spec) pal TickF AnchorMiddle 0) ] + in header + <> panelBackground subLayout pal + <> axisFrame subLayout pal + <> gridLines subLayout specPanel pal + <> tickMarks (Just specPanel) subLayout pal fmtX fmtY rotX rotY + (showXt && gateX) (showYt && gateY) + <> concatMap (renderLayer subResolver subLayout pal) (vsLayers specPanel) + in background layout pal + <> labels layout spec pal + <> concatMap panelFor (zip [0..] facetVals) + -- ★ Phase 34: facet でも凡例を描画 (color/shape encoding 用)。予約は + -- computeLayout 側で行うので baseArea は既に凡例ぶん縮んでいる。 + <> renderLegend r layout pal spec + +-- | Phase 8 C G7 part-b: facet_grid(row ~ col)。 2 変数 cross 配置。 +-- row 変数の distinct levels で行、 col 変数の distinct levels で列を作り、 panel(r,c) は +-- 両条件 (row==rowVal && col==colVal) を満たす行のみで描く。 strip は上 (col 名・各列頭)・ +-- 右 (row 名・各行端、 縦書き)、 軸は最下行 x・左端列 y のみ (ggplot facet_grid 既定の内側 +-- 軸 drop)。 片方のみ指定なら 1 行 (col のみ) / 1 列 (row のみ) の grid。 +-- 全 panel は共通スケール (= renderFaceted 同様、 値比較可)。 +renderFacetGrid :: Resolver -> Layout -> VisualSpec -> [Primitive] +renderFacetGrid r layout spec = + let pal = specThemePalette spec + mRowCol = getLast (vsFacetRow spec) + mColCol = getLast (vsFacetCol spec) + distinctVals cr = case resolveCol r cr of -- Phase 28: facet_grid もアルファベット順 + Just (TxtData v) -> orderedCats (V.toList v) + Just (NumData v) -> orderedCats (V.toList (V.map (T.pack . show) v)) + Nothing -> [] + rowVals = maybe [""] distinctVals mRowCol + colVals = maybe [""] distinctVals mColCol + nRows = length rowVals + nCols = length colVals + in if nRows == 0 || nCols == 0 then renderSingle r layout spec + else + let baseArea = lpPlotArea layout + gutter = ggHalfLine * lpMarginScale layout + hasRowStrip = isJust mRowCol + hasColStrip = isJust mColCol + stripTopH = if hasColStrip then 18 else 0 + stripRightW = if hasRowStrip then 18 else 0 + -- ★ Phase 11 A7-b: facet_grid free scales + space。 free_x は **列ごと共有 x + -- domain** (列内の全行データ)、 free_y は **行ごと共有 y domain** (行内の全列 + -- データ)。 space free は track 重みを各列/行の data 範囲に比例配分する。 + facetSc = maybe FacetFixed id (getLast (vsFacetScales spec)) + freeX = freeScaleX facetSc + freeY = freeScaleY facetSc + facetSp = maybe SpaceFixed id (getLast (vsFacetSpace spec)) + spX = freeSpaceX facetSp + spY = freeSpaceY facetSp + colDomLayout c = let cv = colVals !! c + res = maybe r (\cc -> filterResolver r cc cv) mColCol + in computeLayout res specPanel + rowDomLayout rr = let rv = rowVals !! rr + res = maybe r (\rc -> filterResolver r rc rv) mRowCol + in computeLayout res specPanel + colXLayouts = [ colDomLayout c | c <- [0 .. nCols - 1] ] -- memoize + rowYLayouts = [ rowDomLayout rr | rr <- [0 .. nRows - 1] ] + spanX lay = abs (lsDomainHi (lpXScale lay) - lsDomainLo (lpXScale lay)) + spanY lay = abs (lsDomainHi (lpYScale lay) - lsDomainLo (lpYScale lay)) + colWeight c = if spX then max 1e-9 (spanX (colXLayouts !! c)) else 1 + rowWeight rr = if spY then max 1e-9 (spanY (rowYLayouts !! rr)) else 1 + -- gtable §E-3: 列 = nCols 個 Null (gutter 区切り) + 右 strip 帯、 + -- 行 = 上 strip 帯 + nRows 個 Null (gutter 区切り)。 space free 時は Null 重みを + -- data 範囲に比例 (= ggplot facet_grid(space=) と同じく単位長を揃える)。 + hTracks = concat [ [Null (colWeight c)] ++ (if c < nCols - 1 then [Fixed gutter] else []) + | c <- [0 .. nCols - 1] ] + ++ [Fixed stripRightW] + vTracks = [Fixed stripTopH] + ++ concat [ (if rr > 0 then [Fixed gutter] else []) ++ [Null (rowWeight rr)] + | rr <- [0 .. nRows - 1] ] + nullSlots ts solved = [ sl | (Null _, sl) <- zip ts solved ] + hPanels = nullSlots hTracks (solveTracks (rX baseArea) (rW baseArea) hTracks) + vPanels = nullSlots vTracks (solveTracks (rY baseArea) (rH baseArea) vTracks) + fmtX = axisFormatOf (vsXAxis spec) + fmtY = axisFormatOf (vsYAxis spec) + rotX = resolveAxisAngle (vsXAxis spec) (toAxisTextAngle (vsThemeOverride spec)) + rotY = resolveAxisAngle (vsYAxis spec) (toAxisTextAngle (vsThemeOverride spec)) + showXt = axisShowTicksOf (vsXAxis spec) + showYt = axisShowTicksOf (vsYAxis spec) + specPanel = spec { vsFacetRow = Last Nothing, vsFacetCol = Last Nothing + , vsTitle = Last Nothing + , vsXLabel = Last Nothing, vsYLabel = Last Nothing + , vsSubtitle = Last Nothing, vsCaption = Last Nothing + , vsTag = Last Nothing } + (stripBg, showStrip) = themeStripStyle spec -- Phase 9 A-4 + -- 上 strip (col 名): 各列頭に 1 つ。 中央 = panel 中心 x、 y = 上帯中央。 背景帯を背後に。 + colStrips = concat + [ [ PRect (Rect cellX (rY baseArea) cellW stripTopH) (FillStyle stripBg 1.0) Nothing + | showStrip ] + <> [ PText (Point (cellX + cellW / 2) (rY baseArea + stripTopH / 2)) + cv (mkFontTS (Just spec) pal TickF AnchorMiddle 0) ] + | hasColStrip + , (c, cv) <- zip [0..] colVals + , let (cellX, cellW) = hPanels !! c ] + -- 右 strip (row 名): 各行端に 1 つ。 縦書き (rotate 90)。 背景帯を背後に。 + rowStrips = concat + [ [ PRect (Rect (rX baseArea + rW baseArea - stripRightW) panelTop stripRightW panelH) + (FillStyle stripBg 1.0) Nothing + | showStrip ] + <> [ PText (Point (rX baseArea + rW baseArea - stripRightW / 2) + (panelTop + panelH / 2)) + rv (mkFontTS (Just spec) pal TickF AnchorMiddle (-90)) ] -- Phase 50 A1: CCW canonical (facet row strip 縦書き) + | hasRowStrip + , (rr, rv) <- zip [0..] rowVals + , let (panelTop, panelH) = vPanels !! rr ] + panelFor row col = + let rowVal = rowVals !! row + colVal = colVals !! col + (cellX, cellW) = hPanels !! col + (panelTop, panelH) = vPanels !! row + panelArea = Rect cellX panelTop cellW panelH + -- ★ A7-b: free_x は列 domain layout、 free_y は行 domain layout を scale 源に。 + xSrc = if freeX then colXLayouts !! col else layout + ySrc = if freeY then rowYLayouts !! row else layout + subLayout = layout + { lpPlotArea = panelArea + , lpXScale = scaleRetargetX (lpXScale xSrc) panelArea + , lpYScale = scaleRetargetY (lpYScale ySrc) panelArea + -- Phase 10 A5 (罠5): flip scale も panel に retarget (XFlipped=縦, YFlipped=横)。 + , lpXScaleFlipped = scaleRetargetY (lpXScaleFlipped xSrc) panelArea + , lpYScaleFlipped = scaleRetargetX (lpYScaleFlipped ySrc) panelArea + -- free 軸は列/行 固有の tick / categorical / 明示 label。 + , lpXTicks = lpXTicks xSrc + , lpYTicks = lpYTicks ySrc + , lpXCategoryLabels = lpXCategoryLabels xSrc + , lpYCategoryLabels = lpYCategoryLabels ySrc + , lpXTickLabels = lpXTickLabels xSrc + , lpYTickLabels = lpYTickLabels ySrc } + applyRow res = maybe res (\rc -> filterResolver res rc rowVal) mRowCol + applyCol res = maybe res (\cc -> filterResolver res cc colVal) mColCol + subResolver = applyCol (applyRow r) + isLeft = col == 0 -- y tick は左端列のみ + isBottom = row == nRows - 1 -- x tick は最下行のみ + -- Phase 10 A5 ②-fix: flip で軸転置に合わせ内側軸 drop の gating を入替 (renderFaceted と同様)。 + (gateX, gateY) = case lpCoord layout of + CoordFlip -> (isLeft, isBottom) + _ -> (isBottom, isLeft) + in panelBackground subLayout pal + <> axisFrame subLayout pal + <> gridLines subLayout specPanel pal + <> tickMarks (Just specPanel) subLayout pal fmtX fmtY rotX rotY + (showXt && gateX) (showYt && gateY) + <> concatMap (renderLayer subResolver subLayout pal) (vsLayers specPanel) + in background layout pal + <> labels layout spec pal + <> colStrips + <> rowStrips + <> concat [ panelFor row col | row <- [0 .. nRows - 1], col <- [0 .. nCols - 1] ] + +-- | resolver wrap: facet 列が val に一致する行のみ通すフィルタ。 +-- 他列も同じ index で抽出。 +filterResolver :: Resolver -> ColRef -> Text -> Resolver +filterResolver base facetCol val = \name -> + let facetVec = case resolveCol base facetCol of + Just (TxtData v) -> V.toList v + Just (NumData v) -> map (T.pack . show) (V.toList v) + Nothing -> [] + keepIdx = [i | (i, v) <- zip [0..] facetVec, v == val] + pickFrom vs = [vs !! i | i <- keepIdx, i < length vs] + in case base name of + Just (NumData v) -> Just (NumData (V.fromList (pickFrom (V.toList v)))) + Just (TxtData v) -> Just (TxtData (V.fromList (pickFrom (V.toList v)))) + Nothing -> Nothing + +-- --------------------------------------------------------------------------- +-- Layer 別 render +-- --------------------------------------------------------------------------- + +-- | Phase 8 B22: dual Y 軸対応の layer 描画。 layer が右軸 (lyYAxisSide = YAxisRight) +-- かつ右軸 scale が存在する場合のみ、 lpYScale を右軸 scale に差し替えて描画する +-- (= 右軸系列を独立 domain で位置決め)。 それ以外は通常の renderLayer。 +renderLayerDual :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderLayerDual r layout pal ly = + let effLayout = case (getLast (lyYAxisSide ly), lpYScaleRight layout) of + (Just YAxisRight, Just sR) -> layout { lpYScale = sR } + _ -> layout + in renderLayer r effLayout pal ly + +-- | ★ Phase 36 D2: 1 layer = 1 base mark + 任意個の重畳 sub-mark ('lyOverlay')。 +-- base を描いた後、 各 sub-mark を「親の群 (encX)・色 (colorBy)・値 (encY) 等を継承し、 +-- 自前の kind/nudge/markWidth/side で」 描く (= raincloud / 自作 composite)。 overlay が +-- 空 (= 既存の単一 mark layer) なら base のみ・出力は従来と byte 一致。 +renderLayer :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderLayer r layout pal ly + -- ★ Phase 36 D3: 合成が複数の値列にまたがる (= distCols) ときは、 各マークを「自分の値列名」 + -- スロットに置く。 単一列 (raincloud 等) は従来 (D2) どおり同 slot に重畳 (byte 不変)。 + | length (compositeLanes ly) > 1 = + concatMap (renderLaneMark r layout pal) (ly { lyOverlay = [] } : lyOverlay ly) + | otherwise = + renderLayerBase r layout pal ly + ++ concatMap (renderLayerBase r layout pal . inheritShared ly) (lyOverlay ly) + +-- | Phase 36 D3: distCols のレーン 1 マーク。 自分の値列名を inline カテゴリとして encX に与え、 +-- 分布 renderer がそれを「列名スロット」 として大域 index に置く。 ① 非分布 mark は描画 skip。 +renderLaneMark :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderLaneMark r layout pal m + | getFirst (lyKind m) `notElem` + map Just [MBox, MViolin, MStrip, MSwarm, MRaincloud] = [] -- ① render skip (案 A) + | otherwise = + let n = V.length (vecOr (lyEncY m) r) + nm = maybe "" colRefName (getLast (lyEncY m)) + m' = m { lyEncX = Last (Just (inlineCat (replicate n nm))) } + in renderLayerBase r layout pal m' + +-- | 親 layer の共有属性 (群・色・値・alpha 等) を sub-mark に継承させる。 kind と位置決めつまみ +-- (nudge/markWidth/side) と overlay 自身は親から引き継がず、 sub 側の指定を使う。 +inheritShared :: Layer -> Layer -> Layer +inheritShared parent sub = + let cleared = parent { lyKind = First Nothing + , lyNudge = mempty + , lyMarkWidth = mempty + , lySide = mempty + , lyOverlay = [] } + in cleared <> sub -- Last 系は sub が指定あれば勝ち・無ければ親を継承。 kind は sub (First)。 + +renderLayerBase :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderLayerBase r layout pal ly = + case getFirst (lyKind ly) of + Just MScatter -> renderScatter r layout pal ly + Just MQuiver -> renderQuiver r layout pal ly -- Phase 26 A2 vector field + Just MLine -> renderLine r layout pal ly + Just MTrace -> renderLine r layout pal ly -- = MLine 同等 + (Phase 26 §E-1) + Just MBar -> renderBar r layout pal ly + Just MHistogram -> renderHistogram r layout pal ly + Just MBox -> renderBox r layout pal ly + Just MDensity -> renderDensity r layout pal ly + Just MFreqPoly -> renderFreqPoly r layout pal ly -- Ch10 EDA (Phase 28) geom_freqpoly + Just MStatMean -> renderStatLine r layout pal ly mean + Just MStatMedian -> renderStatLine r layout pal ly median + Just MParallel -> renderParallel r layout pal ly + Just MDAG -> renderDAG layout pal ly + Just MBand -> renderBand r layout pal ly -- TODO-11 + Just MStream -> renderStream r layout pal ly -- Phase 52.D2 + Just MAutocorr -> renderAutocorr r layout pal ly -- Phase 6 A4 + Just MEss -> renderESS r layout pal ly -- Phase 6 A5 + Just MForest -> renderForest r layout pal ly -- Phase 6 A2 + Just MFunnel -> renderFunnel r layout pal ly -- Phase 6 A3 + Just MPie -> renderPie r layout pal ly -- Phase 6+ C-2 + Just MWaterfall -> renderWaterfall r layout pal ly -- Phase 6+ C-2 + Just MStep -> renderStep r layout pal ly -- Phase 6+ C-3 + Just MStem -> renderStem r layout pal ly -- Phase 6+ C-3 + Just MViolin -> renderViolin r layout pal ly -- Phase 6+ C-4 + Just MStrip -> renderStrip r layout pal ly -- Phase 6+ C-4 + Just MSwarm -> renderSwarm r layout pal ly -- Phase 6+ C-4 + Just MRaincloud -> renderRaincloud r layout pal ly -- Phase 6+ C-5 + Just MRidge -> renderRidge r layout pal ly -- Phase 6+ C-5 + Just MScatter3D -> [] -- ★ Phase 26 §C-2 #15 placeholder (実装は hgg-3d 別 Phase) + Just MText -> renderText r layout pal ly False -- Phase 11 A6 geom_text + Just MLabel -> renderText r layout pal ly True -- Phase 11 A6 geom_label (bg box) + Just MQQ -> renderQQ r layout pal ly -- Phase 11 A6-2 geom_qq + Just MHeatmap -> renderHeatmap r layout pal ly -- Phase 11 A6-3 heatmap + Just MCount -> renderCount r layout pal ly -- Phase 28 geom_count (stat_sum) + Just MContour -> renderContour r layout pal ly -- 等高線 (marching squares) + Just MContourFilled -> renderContourFilled r layout pal ly -- 等値帯塗り (Phase 24 A4) + Just MBin2d -> renderBin2d r layout pal ly -- binned heatmap (geom_bin2d) + Just MTile -> renderTile r layout pal ly -- Phase 60: 連続軸タイル塗り (geom_tile) + Just MHexbin -> renderHexbin r layout pal ly -- Phase 40 六角ビニング (geom_hex) + Just MEcdf -> renderEcdf r layout pal ly -- Phase 11 A6-4 stat_ecdf + Just MLineRange -> renderRangeBar r layout pal ly False False -- Phase 11 A6-4b + Just MPointRange -> renderRangeBar r layout pal ly True False -- 〃 + 中心点 + Just MCrossbar -> renderRangeBar r layout pal ly False True -- 〃 幅付き箱 + Just MStatLM -> [] -- Phase 16: 未解決 stat は描かない (bridge resolveStats が band+line に展開) + Just MStatSmooth -> [] -- 〃 + Just MStatPoly -> [] -- 〃 (B3) + Just MStatResid -> [] -- 〃 (B3) + Just MCustom -> renderCustom r layout pal ly -- ★ Phase 51: custom mark (closure) + _ -> [] -- 他 mark は §A-5 続きで段階追加 + +-- | ★ Phase 51: custom mark を描く。 'lyCustom' の draw closure に 'RenderCtx' を渡し、 +-- 返った 'Primitive' 列をそのまま emit する (HS は registry 不要 = closure が源)。 +-- 'lyCustom' が空なら no-op。 RenderCtx は scale 適用済 projection・plot 領域・resolver・ +-- theme 既定色を提供する (authoring API)。 +renderCustom :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderCustom r layout pal ly = + case getLast (lyCustom ly) of + Nothing -> [] + Just cm -> + let coord = lpCoord layout + ctx = RenderCtx + { rcProjectXY = projectXY coord layout + , rcPlotArea = lpPlotArea layout + , rcResolver = r + , rcColor = tpDefault pal + , rcFill = tpDefaultFill pal + , rcTextColor = tpText pal + , rcAxisColor = tpAxis pal + } + in cmDraw cm ctx + +-- =========================================================================== +-- Phase 6+ C-8: Legend render (= 簡略実装、 categorical color encoding 限定) +-- =========================================================================== + +-- | 凡例 (legend chip) を描画。 vsLegend が None なら空。 +-- 各 layer の lyColor が ColorByCol なら、 その列の distinct 値を chip として並べる。 +-- 位置は LegendPosition、 inside の場合は plotArea 内、 right/bottom は外側。 +-- | Phase 9 A-5: legend を PS と同一ロジックで描画 (配置を ggplot に揃える)。 +-- gating は 'needsLegend' (= color encoding があれば 'legend' 明示なしでも auto)。 位置別に +-- Right / Bottom / Inside の sub-renderer に dispatch。 Right/Bottom は予約域 (Layout legendW/H) +-- に収まり、 Inside は panel 内に bg box 付きで描く。 色/文字は theme 連動 (mkFontTS / pal)。 +renderLegend :: Resolver -> Layout -> ThemePalette -> VisualSpec -> [Primitive] +renderLegend r layout pal spec = + let pos = needsLegend spec (effectiveLegendPos (vsLegend spec)) + -- ★ Phase 35: LegendRight は collectGuides 経路 (色/形の複数 guide・色無し形のみも可)。 + -- Bottom/Inside は未 guide 化なので従来の単一 color enc 経路を維持。 + in case pos of + LegendNone -> [] + LegendRight -> renderLegendRight spec r layout pal False (ColorStatic "") -- enc は未使用 + LegendRightCenter -> renderLegendRight spec r layout pal True (ColorStatic "") -- 縦中央寄せ + _ -> case findColorEnc (vsLayers spec) of + Nothing -> [] + Just enc -> case pos of + LegendBottom -> renderLegendBottom spec r layout pal enc + LegendInsideTopRight -> renderLegendInside spec r layout pal enc 1 0 + LegendInsideTopLeft -> renderLegendInside spec r layout pal enc 0 0 + LegendInsideBottomRight -> renderLegendInside spec r layout pal enc 1 1 + LegendInsideBottomLeft -> renderLegendInside spec r layout pal enc 0 1 + _ -> [] + +-- | 最初に見つけた color encoding を凡例化 (= PS findColorEnc)。 +-- ★ Phase 38: findColorEnc / allColorCategories / effectiveLegendTitle / nubKeep / +-- LegendGuide / collectGuides は Layout へ集約 (予約と描画の単一情報源)。 +-- ここでは Layout から import して使う。 + +-- | Phase 19 A1: 凡例の正本 ('allColorCategories' union) を glyph 側へ注入する。 +-- 'lyColorCats' が空の ColorByCol レイヤにだけ union を詰める (ユーザ明示の +-- 'colorCats' は非空なので上書きしない・冪等)。 'colorVector' (TODO-3d 機構) が +-- この順序で palette index を引くため、 glyph と凡例 swatch が同じ正本を参照し +-- `<>` 重畳・facet panel でズレない。 単一 layer では union = layer 内 nub +-- (どちらも初出順) なので従来配色と一致する。 +injectColorCats :: Resolver -> VisualSpec -> VisualSpec +injectColorCats r spec = + case allColorCategories r (vsLayers spec) of + [] -> spec + cats -> spec { vsLayers = map inj (vsLayers spec) } + where + inj ly = case getLast (lyColor ly) of + Just (ColorByCol _) | null (lyColorCats ly) -> ly { lyColorCats = cats } + _ -> ly + +-- | Phase 9 A-5 fix: 凡例タイトル (= 変数名) は常に非表示。 gallery 等で spec を JSON 化 +-- (bakeSpec) すると color 列が inline 化され列名が失われ、 PS は構造的にタイトルを出せない。 +-- HS だけ live 名 ("group") を出すと HS/PS が食い違う (= ユーザ報告)。 両方 "" に揃える +-- (legend 項目ラベル自体が自己説明的)。 将来 name 保持 bake を入れたら復活させる。 +legendHeaderText :: ColRef -> Text +legendHeaderText _ = "" + +-- ★ Phase 38: effectiveLegendTitle / nubKeep は Layout へ集約 (import 済)。 + +-- | Phase 11 A5-c: 凡例キーの表示順。 (originalIndex, label) を返し、 色は originalIndex で +-- 引く (= reverse しても各キーの色は固定)。 vsLegendReverse=True で逆順。 +legendOrder :: VisualSpec -> [Text] -> [(Int, Text)] +legendOrder spec vals = + let ix = zip [0 ..] vals + in if getLast (vsLegendReverse spec) == Just True then reverse ix else ix + +-- | Phase 11 A5-c: 縦凡例の ncol (>=1)。 +legendNcolOf :: VisualSpec -> Int +legendNcolOf spec = max 1 (maybe 1 id (getLast (vsLegendNcol spec))) + +-- | Phase 11 A5-c: 横凡例の nrow (>=1)。 +legendNrowOf :: VisualSpec -> Int +legendNrowOf spec = max 1 (maybe 1 id (getLast (vsLegendNrow spec))) + +-- | 縦凡例グリッド: 表示 index k → (col, row)。 列優先 (column-major)、 nrows=ceil(n/ncol)。 +-- ncol=1 なら (0, k) で従来の単一列と一致。 +legendGridV :: Int -> Int -> Int -> (Int, Int) +legendGridV ncol n k = let nr = (n + ncol - 1) `div` ncol in (k `div` nr, k `mod` nr) + +-- | 横凡例グリッド: 行優先 (row-major)、 ncols=ceil(n/nrow)。 nrow=1 なら (k, 0)。 +legendGridH :: Int -> Int -> Int -> (Int, Int) +legendGridH nrow n k = let nc = (n + nrow - 1) `div` nrow in (k `mod` nc, k `div` nc) + +-- | i 番目の categorical 色 (palette 長で wrap、 空なら default)。 +legendColorAt :: Layout -> ThemePalette -> Int -> Text +legendColorAt layout pal i = + let catPal = lpCategoricalPalette layout + in if null catPal then tpDefault pal else catPal !! (i `mod` length catPal) + +-- | A4-e: legend chip 色。 scale_color_manual の辞書に該当ラベルがあれば優先 (= 凡例と +-- panel の色を一致させる)。 未登録は index ベースの 'legendColorAt'。 +legendColorFor :: Layout -> ThemePalette -> Int -> Text -> Text +legendColorFor layout pal i label = + case lookup label (lpColorManual layout) of + Just c -> c + Nothing -> legendColorAt layout pal i + +-- | Phase 9 A-5 fix: legend の color 凡例が point geom (= scatter) かどうか。 true なら +-- 色見本を panel と同じ円で描く (ggplot legend key は geom 形状に従う)。 それ以外は矩形。 +legendUsesPoint :: VisualSpec -> Bool +legendUsesPoint spec = case filter (\l -> case getLast (lyColor l) of + Just _ -> True; Nothing -> False) (vsLayers spec) of + (l : _) -> getFirst (lyKind l) == Just MScatter + [] -> False + +-- | legend の色見本 (left,top,key-size 指定)。 ★ Phase 34: ggplot @legend.key@ 同様 +-- 各キーに grey95 の背景四角を敷き、 その上にマーカーを描く。 point geom は円 +-- (shapeBy が color と同列なら per-category の ●▲■)、 他は色付き矩形。 マーカー径は +-- **プロット中の点と同径** (markerDiam = 解決済 lySize / 既定 1.65mm) にして凡例だけ +-- 大きくならないようにする。 +legendSwatch :: Maybe Layer -> Bool -> Maybe MarkShape -> Double -> ThemePalette + -> Double -> Double -> Double -> Text -> [Primitive] +legendSwatch mLayer usePoint mShape markerDiam pal left top sz col = + let keyBg = PRect (Rect left top sz sz) (FillStyle legendKeyBgColor 1.0) Nothing + in if usePoint + then let ctr = Point (left + sz / 2) (top + sz / 2) + r = markerDiam / 2 + -- plot 点と同じ装飾 (既定縁なし)。 旧 1pt 縁ハードコードを廃止。 + (fs, ms) = case mLayer of + Just ly -> (markerFillFor ly col 1.0, markerStrokeFor ly col) + Nothing -> (FillStyle col 1.0, Nothing) + marker = case mShape of + Just sh | sh /= MShCircle -> shapeToPrim sh ctr r fs ms Nothing + _ -> PCircle ctr r fs ms Nothing + in [ keyBg, marker ] + else [ keyBg + , PRect (Rect left top sz sz) (FillStyle col 1.0) (Just (StrokeStyle (tpAxis pal) 0.5)) ] + +-- | ggplot theme_grey の @legend.key@ 背景色 (grey95)。 +legendKeyBgColor :: Text +legendKeyBgColor = "#f2f2f2" + +-- ★ Phase 38: legendBaseSize / legendKeyW / legendKeyPitch は Layout へ集約 (単一情報源)。 +-- ここでは Layout から import して使う (定義は Graphics.Hgg.Layout)。 + +-- | Phase 35: top-align 凡例ブロックの上余白 (pt)。 ggplot は右凡例を縦中央寄せするため +-- 直接の対応 metric は無い。 ユーザ好み (上揃え) ゆえ half_line の倍数で定義 (= 11pt ≈ 10)。 +legendTopInset :: Double +legendTopInset = 2 * ggHalfLine + +-- | Phase 35: 凡例キーの描画スタイル (= ggplot draw_key 同型・geom 種で変わる)。 +data LegendKeyStyle + = KeyPoint !(Maybe MarkShape) -- scatter: point glyph (色塗り) + | KeyFilled -- bar/histogram: 色ベタ塗り矩形 + | KeyOutline !(Maybe Double) -- density/line: 色枠線矩形 (Just a = 内部を色@a 塗り / Nothing = 透明=灰背景が見える) + +-- | Phase 35: 凡例キー 1 個を (cx, cy) 中心に描く (キー灰背景は別途連続ブロックで描く)。 +-- | ★ 凡例キーの装飾は plot 点と揃える ('mLayer' = 当該 point レイヤ)。 KeyPoint の塗り・ +-- 縁は 'markerFillFor'/'markerStrokeFor' に一本化 (既定縁なし)。 旧実装は塗り同色の +-- 1pt 縁をハードコードしており、 精緻なスーツ形の凹みを潰していた (= plot と不一致)。 +legendKeyPrim :: Maybe Layer -> LegendKeyStyle -> Double -> ThemePalette -> Double -> Double -> Text -> [Primitive] +legendKeyPrim mLayer style markerDiam pal cx cy col = + -- ★ 矩形キー (bar/density) はセルより線幅 (lwd mm) 分**内側**に縮める + -- (= ggplot draw_key_polygon: rectGrob width = unit(1,"npc") - unit(lwd,"mm"))。 + -- 隣接セルとの間に lwd mm の隙間ができ、 ggplot 同様「隣接するが接しない」。 + let lwInset = mmPt 0.5 -- ggplot 既定 linewidth = 0.5mm + keyRect = Rect (cx - (legendKeyW - lwInset) / 2) (cy - (legendKeyPitch - lwInset) / 2) + (legendKeyW - lwInset) (legendKeyPitch - lwInset) + -- ★ Phase 32 (re-apply): legend.key 背景 (ggplot theme_grey = grey95 #F2F2F2)。 + -- symbol の背後にキーセル全体 (legendKeyW × legendKeyPitch) を塗る。 tpLegendKeyBg が + -- 空文字なら描かない (= 従来挙動)。 全 guide variant が legendKeyPrim 経由ゆえ 1 箇所で網羅。 + keyBg + | tpLegendKeyBg pal == "" = [] + | otherwise = [ PRect (Rect (cx - legendKeyW / 2) (cy - legendKeyPitch / 2) legendKeyW legendKeyPitch) + (FillStyle (tpLegendKeyBg pal) 1.0) Nothing ] + in (keyBg ++) $ case style of + KeyPoint mShape -> + let ctr = Point cx cy + r = markerDiam / 2 + -- plot 点と同じ装飾 (markerFillFor/markerStrokeFor)。 レイヤ不明時は縁なし既定。 + (fs, ms) = case mLayer of + Just ly -> (markerFillFor ly col 1.0, markerStrokeFor ly col) + Nothing -> (FillStyle col 1.0, Nothing) + in case mShape of + Just sh | sh /= MShCircle -> [ shapeToPrim sh ctr r fs ms Nothing ] + _ -> [ PCircle ctr r fs ms Nothing ] + KeyFilled -> + -- ★ 枠なしの塗り潰しチップ (bar/box/violin の見た目に合わせる)。 旧実装は + -- tpAxis の固定枠 (黒) で mark の塗りと不一致だった。 + [ PRect keyRect (FillStyle col 1.0) Nothing ] + KeyOutline mAlpha -> + let fs = case mAlpha of { Just a -> FillStyle col a; Nothing -> FillStyle col 0.0 } + in [ PRect keyRect fs (Just (StrokeStyle col 1.0)) ] + +-- | 凡例マーカーの径 (pt)。 最初の scatter レイヤの解決済 'lySize' (= プロット点と +-- 同径)、 無ければ既定 'defaultMarkerDiameter'。 +legendMarkerDiam :: VisualSpec -> Double +legendMarkerDiam spec = + case [ doubleOr (lySize l) defaultMarkerDiameter + | l <- vsLayers spec, getFirst (lyKind l) == Just MScatter ] of + (d : _) -> d + [] -> defaultMarkerDiameter + +-- | ★ Phase 34: 凡例エントリ k (= カテゴリ index) のマーカー形。 scatter レイヤが +-- color と shape を **同じ列** にマップしているとき (ggplot の統合凡例) のみ、 自動 +-- shape scale ('shapePalette') を k で巡回して返す。 色のみ・shape 別列 (= ggplot は +-- 2 凡例) のときは Nothing (= 従来の円) にして単一 color 凡例を保つ。 +legendShapeFor :: VisualSpec -> Int -> Maybe MarkShape +legendShapeFor spec k = + case [ () | ly <- vsLayers spec + , getFirst (lyKind ly) == Just MScatter + , Just (ColorByCol cc) <- [getLast (lyColor ly)] + , Just sc <- [getLast (lyShapeBy ly)] + , cc == sc ] of + (_ : _) -> Just (shapePalette !! (k `mod` length shapePalette)) + [] -> Nothing + +-- | Phase 35: 凡例 guide (= ggplot guides)。 aesthetic ごとに 1 guide、 同一列に +-- マップされた色+形は色 guide に統合 ('legendShapeFor' 経由) するので形 guide は作らない。 +-- ★ Phase 38: LegendGuide / collectGuides は Layout へ集約 (import 済)。 + +-- | Phase 35: 1 guide を原点 (ox, oy) から描き、 (prims, ブロック高さ) を返す。 +-- ブロック = [タイトル行 (凡例列名あり時)] + [エントリ行…]。 内部レイアウトは原点相対。 +renderGuideBlock :: VisualSpec -> Resolver -> Layout -> ThemePalette + -> Double -> Double -> Text -> LegendGuide -> ([Primitive], Double) +renderGuideBlock spec r layout pal ox oy title guide = + let tsTitle = mkFontTS (Just spec) pal LegendTitleF AnchorStart 0 + tsItem = mkFontTS (Just spec) pal LegendItemF AnchorStart 0 + -- pt メトリクス (ggplot 同型・マジック数を排す)。 半行 = ggHalfLine。 + itemDy = legendBaseSize * 0.8 * 0.32 -- item 文字をキー中心に縦揃え + titleH = if title == "" then 0 else legendBaseSize + ggHalfLine -- title 行高 (文字 + 下マージン) + header = if title == "" then [] else [ PText (Point ox (oy + legendBaseSize)) title tsTitle ] + firstCy = oy + titleH + legendKeyPitch / 2 -- 最初のキー中心 + labelX = ox + legendKeyW + ggHalfLine / 2 -- key → label gap = half_line/2 + cyAt k = firstCy + fromIntegral k * legendKeyPitch + -- ★ Phase 35: 点凡例は theme panel 色 (tpPanelBg) の連続背景ブロック (= ggplot + -- legend.key が縦に連結した灰色帯)。 + bgRect n = if n > 0 + then [ PRect (Rect ox (firstCy - legendKeyPitch / 2) legendKeyW (fromIntegral n * legendKeyPitch)) + (FillStyle (tpPanelBg pal) 1.0) Nothing ] + else [] + in case guide of + ColorGuide (ColorByCol _cr) -> + let vals = allColorCategories r (vsLayers spec) -- Phase 52.A10: 全レイヤ union + n = length vals + items = legendOrder spec vals + -- ★ Phase 35: 凡例キー形は色 aesthetic を持つレイヤの geom 種で決まる (ggplot draw_key)。 + colorLayer = listToMaybe [ l | l <- vsLayers spec, isColorMapLayer l ] + keyKind = maybe MScatter id (colorLayer >>= getFirst . lyKind) + -- density 等の塗り (densityFill) 有無 → 枠線キーの内部塗り alpha。 + mFillAlpha = case colorLayer of + Just l | getLast (lyDensityFill l) == Just True -> Just (doubleOr (lyAlpha l) 0.5) + _ -> Nothing + -- ★ Phase 36 C: hollow (= fill=NA) の塗り系 mark (box 等) は塗らないので枠線キー + -- (= density と同じ KeyOutline)。 凡例キーを「mark 種」でなく「塗るか否か」で選ぶ。 + colorLayerHollow = case colorLayer of + Just l -> getLast (lyHollow l) == Just True + _ -> False + styleFor origI = case keyKind of + MScatter -> KeyPoint (legendShapeFor spec origI) + k | k `elem` [MDensity, MLine, MFreqPoly, MStep] -> KeyOutline mFillAlpha + _ | colorLayerHollow -> KeyOutline Nothing + _ -> KeyFilled + chipFor k (origI, label) = + let cy = cyAt k + col = legendColorFor layout pal origI label + in legendKeyPrim colorLayer (styleFor origI) (legendMarkerDiam spec) pal (ox + legendKeyW / 2) cy col + <> [ PText (Point labelX (cy + itemDy)) label tsItem ] + in ( header <> bgRect n <> concat (zipWith chipFor [0 :: Int ..] items) + , titleH + fromIntegral n * legendKeyPitch ) + ColorGuide (ColorByContinuous cr) -> case resolveNum r cr of + Nothing -> ([], 0) + Just nums | V.null nums -> ([], 0) + | otherwise -> + let vMin = V.minimum nums + vMax = V.maximum nums + barW = legendKeyW; barH = 11 * legendBaseSize; barX = ox; barY = oy + titleH + nStop = 40 :: Int + step = barH / fromIntegral nStop + -- ★ A4-e: gradient2 指定時は発散 3-stop を bar に反映 (= 凡例も diverging palette)。 + legendPal = case lpColorGradient2 layout of + Just (cLo, cMid, cHi, _) -> [cLo, cMid, cHi] + Nothing -> lpContinuousPalette layout + stops = [ let t = fromIntegral i / fromIntegral (nStop - 1) + sy = barY + barH - fromIntegral i * step + in PRect (Rect barX (sy - step) barW (step + 0.5)) + (FillStyle (continuousColor legendPal t) 1.0) Nothing + | i <- [0 .. nStop - 1] ] + tickX = barX + barW + ggHalfLine / 2 + -- ggplot 同型: 連続凡例の目盛りは生 min/mid/max でなく Wilkinson extended + -- breaks (= 軸と同じ nice 値) を範囲内に置く。 生値の長大桁を避けラベルが短くなる。 + legBreaks = case filter (\b -> b >= vMin && b <= vMax) (extendedBreaks 5 vMin vMax) of + [] -> [vMin, vMax] + bs -> bs + yOfV v = if vMax > vMin then barY + barH * (vMax - v) / (vMax - vMin) + else barY + barH / 2 + ticks = [ PText (Point tickX (yOfV b + itemDy)) (numToText b) tsItem | b <- legBreaks ] + in (header <> stops <> ticks, titleH + barH) + -- ★ Phase 40: hexbin の件数 colorbar (列でなく集計値ゆえ域 lo/hi を直に持つ)。 + -- ColorByContinuous と同型の gradient bar + extended breaks 目盛り、 タイトルは "count"。 + CountBarGuide lo hi -> + let barTitle = "count" + titleH' = legendBaseSize + ggHalfLine + header' = [ PText (Point ox (oy + legendBaseSize)) barTitle tsTitle ] + vMin = lo; vMax = hi + barW = legendKeyW; barH = 11 * legendBaseSize; barX = ox; barY = oy + titleH' + nStop = 40 :: Int + step = barH / fromIntegral nStop + legendPal = lpContinuousPalette layout + stops = [ let t = fromIntegral i / fromIntegral (nStop - 1) + sy = barY + barH - fromIntegral i * step + in PRect (Rect barX (sy - step) barW (step + 0.5)) + (FillStyle (continuousColor legendPal t) 1.0) Nothing + | i <- [0 .. nStop - 1] ] + tickX = barX + barW + ggHalfLine / 2 + legBreaks = case filter (\b -> b >= vMin && b <= vMax) (extendedBreaks 5 vMin vMax) of + [] -> [vMin, vMax] + bs -> bs + yOfV v = if vMax > vMin then barY + barH * (vMax - v) / (vMax - vMin) + else barY + barH / 2 + ticks = [ PText (Point tickX (yOfV b + itemDy)) (numToText b) tsItem | b <- legBreaks ] + in (header' <> stops <> ticks, titleH' + barH) + ColorGuide (ColorStatic _) -> ([], 0) + ShapeGuide scr -> + -- 形 guide。 色は tpDefault (= 既定の ink・色未指定点の + -- フォールバック色)、 形は plot と同じ規則 (orderedCats の index で shapePalette 巡回)。 + let vals = case resolveCol r scr of + Just (TxtData v) -> orderedCats (V.toList v) + Just (NumData v) -> orderedCats (map numToText (V.toList v)) + _ -> [] + n = length vals + inkCol = tpDefault pal + chipFor k label = + let cy = cyAt k + sh = shapePalette !! (k `mod` length shapePalette) + in legendKeyPrim (legendPointLayer spec) (KeyPoint (Just sh)) (legendMarkerDiam spec) pal (ox + legendKeyW / 2) cy inkCol + <> [ PText (Point labelX (cy + itemDy)) label tsItem ] + in ( header <> bgRect n <> concat (zipWith chipFor [0..] vals) + , titleH + fromIntegral n * legendKeyPitch ) + +-- | Phase 35: レイヤが色マップ (ColorByCol/ColorByContinuous) を持つか (= 凡例を駆動)。 +isColorMapLayer :: Layer -> Bool +isColorMapLayer l = case getLast (lyColor l) of + Just (ColorByCol _) -> True + Just (ColorByContinuous _) -> True + _ -> False + +-- | Phase 35: 凡例キーの装飾 (縁・hollow) を決める「代表 point レイヤ」。 色マップ層を +-- 優先し、 無ければ最初の scatter 層。 これを 'legendKeyPrim'/'legendSwatch' に渡し、 +-- plot 点と同じ 'markerStrokeFor'/'markerFillFor' を凡例にも適用する。 +legendPointLayer :: VisualSpec -> Maybe Layer +legendPointLayer spec = listToMaybe + ( [ l | l <- vsLayers spec, isColorMapLayer l ] + ++ [ l | l <- vsLayers spec, getFirst (lyKind l) == Just MScatter ] ) + +-- | LegendRight: panel 右の予約域に guide を縦スタック (= PS renderLegendRight)。 +-- centered=True (LegendRightCenter) なら guide スタック全体を panel 高の縦中央に揃える +-- (ggplot 既定の legend.position="right")。 False は従来の上揃え (legendTopInset 起点)。 +renderLegendRight :: VisualSpec -> Resolver -> Layout -> ThemePalette -> Bool -> ColorEnc -> [Primitive] +renderLegendRight spec r layout pal centered _enc = + let area = lpPlotArea layout + x0 = rX area + rW area + 2 * ggHalfLine -- panel→凡例 gap = ggplot legend.box.spacing = 1 line + guideGap = 2 * ggHalfLine -- guide 間スペース = 1 line + guides = collectGuides r spec + -- shape 凡例の見出しは列名。 inline data に resolve され名前が失われた場合は + -- sentinel ("<inline-txt>" / "<inline-num>") を出さず空に潰す (= color 凡例と同じ規律)。 + titleOf g = case g of + ColorGuide _ -> effectiveLegendTitle spec + ShapeGuide cr -> let nm = colRefName cr + in if nm == "<inline-num>" || nm == "<inline-txt>" then "" else nm + CountBarGuide _ _ -> "" -- title は guide 側で "count" を出すので空 (= PS titleOf と同一) + -- ★ Phase 32 (re-apply): 縦中央寄せ用に guide スタックの総高を見積る (renderGuideBlock + -- は純粋ゆえ oy=0 で高さのみ取り出す)。 総高 = Σ block高 + gap*(n-1)。 + blockH g = snd (renderGuideBlock spec r layout pal x0 0 (titleOf g) g) + totalH = sum (map blockH guides) + guideGap * fromIntegral (max 0 (length guides - 1)) + -- ★ Phase 35 #1: 上揃え時はブロック上端を panel 上端 + legendTopInset に下げ、 凡例 + -- タイトルが panel/キャンバス上端に詰まるのを防ぐ (グラフタイトルの有無に依らない)。 + y0 | centered = rY area + max legendTopInset ((rH area - totalH) / 2) + | otherwise = rY area + legendTopInset + go _ [] = [] + go oy (g : gs) = + let (prims, h) = renderGuideBlock spec r layout pal x0 oy (titleOf g) g + in prims <> go (oy + h + guideGap) gs + in go y0 guides + +-- | LegendBottom: panel 下の予約域に横並び (= PS renderLegendBottom)。 +renderLegendBottom :: VisualSpec -> Resolver -> Layout -> ThemePalette -> ColorEnc -> [Primitive] +renderLegendBottom spec r layout pal enc = + let area = lpPlotArea layout + y0 = rY area + rH area + 50 + tsItem = mkFontTS (Just spec) pal LegendItemF AnchorStart 0 + tsTitle = mkFontTS (Just spec) pal LegendTitleF AnchorStart 0 + -- Phase 11 A4-c: タイトル指定時のみ先頭に表示し chip を右へずらす (未指定はゼロ diff)。 + titleStr = effectiveLegendTitle spec + -- ★ Phase 38: タイトル幅も字種別 'textWidthEm' で算出 (旧 0.6*len)。 + titleW = if titleStr == "" then 0 else tsSize tsTitle * textWidthEm titleStr + 12 + titlePrim = if titleStr == "" then [] + else [ PText (Point (rX area) (y0 + 2)) titleStr tsTitle ] + in case enc of + ColorByCol _cr -> + let vals = allColorCategories r (vsLayers spec) -- Phase 52.A10: 全レイヤ union + items = legendOrder spec vals + n = length items + -- Phase 11 A5-c: nrow グリッド + reverse。 nrow=1・非 reverse で従来同型。 + nrow = legendNrowOf spec + nc = max 1 ((n + nrow - 1) `div` nrow) -- 列数 (legendGridH と同式) + rowH = 16 + -- ★ Phase 38: 各アイテムの横送りをラベル内容で算出 (旧 chipW=80 固定 → content-based)。 + -- item 横幅 = swatch→label gap(14) + ラベル幅 + 列間 gap(ggHalfLine)。 + -- 列 (legendGridH の col) ごとに、 その列に入る全行アイテムの最大幅を採る。 + itemAdv lbl = 14 + tsSize tsItem * textWidthEm lbl + ggHalfLine + labelAt k = snd (items !! k) + colWidth c = maximum (0 : [ itemAdv (labelAt k) | k <- [0 .. n - 1], k `mod` nc == c ]) + -- colXs !! c = 第 c 列の左端 x (title 後を起点に列幅を累積)。 + colXs = scanl (+) (rX area + titleW) (map colWidth [0 .. nc - 1]) + chipFor k (origI, label) = + let (col, row) = legendGridH nrow n k + cx = colXs !! col + cy = y0 + fromIntegral row * rowH + in legendSwatch (legendPointLayer spec) (legendUsesPoint spec) (legendShapeFor spec origI) (legendMarkerDiam spec) pal cx (cy - 7) 10 (legendColorFor layout pal origI label) + <> [ PText (Point (cx + 14) (cy + 2)) label tsItem ] + in titlePrim <> concat (zipWith chipFor [0..] items) + _ -> [] + +-- | LegendInside: panel 内に bg box 付きで描く (= PS renderLegendInside)。 fracX/fracY は +-- 0=左/上、 1=右/下。 +renderLegendInside :: VisualSpec -> Resolver -> Layout -> ThemePalette -> ColorEnc + -> Double -> Double -> [Primitive] +renderLegendInside spec r layout pal enc fracX fracY = + let area = lpPlotArea layout + padB = 8 + tsTitle = mkFontTS (Just spec) pal LegendTitleF AnchorStart 0 + tsItem = mkFontTS (Just spec) pal LegendItemF AnchorStart 0 + itemH = max 16 (tsSize tsItem + 6) + chipSize = max 10 (tsSize tsItem * 0.75) + chipGap = 6 + in case enc of + ColorByCol _cr -> + let vals = allColorCategories r (vsLayers spec) -- Phase 52.A10: 全レイヤ union + nItems = length vals + titleStr = effectiveLegendTitle spec + hasTitleL = titleStr /= "" + titleH = if hasTitleL then tsSize tsTitle + 6 else 0 + maxItemLen = maximum (0 : map T.length vals) + titleLen = T.length titleStr + -- Phase 11 A5-c: ncol グリッド + reverse。 ncol=1・非 reverse で従来とゼロ diff。 + ncol = legendNcolOf spec + nrows = (nItems + ncol - 1) `div` ncol + colW = chipSize + chipGap + tsSize tsItem * 0.6 * fromIntegral maxItemLen + 12 + contentW = max (tsSize tsTitle * 0.6 * fromIntegral titleLen) + (fromIntegral ncol * colW - 12) + boxW = max 80 (contentW + 14) + boxH = titleH + 4 + fromIntegral nrows * itemH + 4 + x0 = if fracX >= 0.5 then rX area + rW area - boxW - padB else rX area + padB + y0 = if fracY >= 0.5 then rY area + rH area - boxH - padB else rY area + padB + bg = [ PRect (Rect (x0 - 4) (y0 - 4) (boxW + 8) (boxH + 4)) + (FillStyle (tpBackground pal) 0.85) + (Just (StrokeStyle (tpAxis pal) 0.5)) ] + header = if hasTitleL + then [ PText (Point x0 (y0 + tsSize tsTitle * 0.8)) titleStr tsTitle ] + else [] + items = legendOrder spec vals + chipFor k (origI, label) = + let (col, row) = legendGridV ncol nItems k + cx = x0 + fromIntegral col * colW + cy = y0 + titleH + 4 + fromIntegral row * itemH + itemH * 0.5 + in legendSwatch (legendPointLayer spec) (legendUsesPoint spec) (legendShapeFor spec origI) (legendMarkerDiam spec) pal cx (cy - chipSize / 2) chipSize (legendColorFor layout pal origI label) + <> [ PText (Point (cx + chipSize + chipGap) (cy + tsSize tsItem * 0.35)) label tsItem ] + in bg <> header <> concat (zipWith chipFor [0..] items) + _ -> [] + +-- =========================================================================== +-- Phase 6+ C-8: Annotation render +-- =========================================================================== + +-- | annotation 1 個を Primitive に変換。 ★ Phase 33 B6: 座標は 'Pos' で、 +-- 'resolvePosX'/'resolvePosY' (= UCtx 経由) で pt 化する。native/npc/絶対長を軸 +-- ごとに混在できる。dpi は PAbs Px 解決にのみ使う (layout は pt)。 +renderAnnotation :: Double -> Layout -> ThemePalette -> Annotation -> [Primitive] +renderAnnotation dpi layout pal ann = + let uc = UCtx dpi (lpPlotArea layout) (lpXScale layout) (lpYScale layout) + rx = resolvePosX uc + ry = resolvePosY uc + _ = pal + in case ann of + AnnText x y t col sz -> + let ts = TextStyle col sz "sans-serif" AnchorMiddle 0 "normal" False + in [ PText (Point (rx x) (ry y)) t ts ] + AnnArrow x1 y1 x2 y2 col w -> + -- Phase 8 B20: 終点に矢じり (= 2 本の短線) を付ける。 旧実装はただの線で + -- AnnLine と区別が付かなかった (PS は矢じりを描いており parity を取る)。 + let px1 = rx x1; py1 = ry y1; px2 = rx x2; py2 = ry y2 + dx = px2 - px1; dy = py2 - py1 + len = sqrt (dx * dx + dy * dy) + (ux, uy) = if len == 0 then (0, 0) else (dx / len, dy / len) + ah = mmPt 2.5 -- 矢じりの長さ (2.5mm) + aw = 0.5 -- 開き (直交方向の比率) + bx = px2 - ux * ah; by = py2 - uy * ah + lx = bx - uy * ah * aw; ly = by + ux * ah * aw + rx' = bx + uy * ah * aw; ry' = by - ux * ah * aw + ls = solid col w + in [ PLine (Point px1 py1) (Point px2 py2) ls + , PLine (Point px2 py2) (Point lx ly) ls + , PLine (Point px2 py2) (Point rx' ry') ls ] + AnnRect x1 y1 x2 y2 fill stroke sw fillOp -> + -- 2 隅の Pos を pt 化し、min/abs で正規矩形に (y は device 下向きで反転するため + -- min/abs 必須・旧 (x,y,w,h) 実装と bit 一致)。 + let ax1 = rx x1; ay1 = ry y1; ax2 = rx x2; ay2 = ry y2 + in [ PRect (Rect (min ax1 ax2) (min ay1 ay2) (abs (ax2 - ax1)) (abs (ay2 - ay1))) + (FillStyle fill fillOp) + (Just (StrokeStyle stroke sw)) ] + AnnLine x1 y1 x2 y2 col w -> + [ PLine (Point (rx x1) (ry y1)) (Point (rx x2) (ry y2)) (solid col w) ] + +-- | Phase 8 B21: inset (図中図)。 子 spec を inset サイズの sub-viewport で描画し、 +-- offsetPrim で plotArea 内の (inX, inY) 位置へシフトする (= PS renderInset と同方式)。 +-- inX/inY/inW/inH は plotArea に対する 0..1 の比率。 +renderInset :: Resolver -> Layout -> ThemePalette -> Inset -> [Primitive] +renderInset r layout pal ins = + let a = lpPlotArea layout + px = rX a + inX ins * rW a + py = rY a + inY ins * rH a + pw = inW ins * rW a + ph = inH ins * rH a + subSpec = (inSpec ins) { vsWidth = Last (Just (Length pw Pt)) + , vsHeight = Last (Just (Length ph Pt)) } + subLayout = computeLayout r subSpec + inner = map (offsetPrim px py) (renderToPrimitives r subLayout subSpec) + frame = [ PRect (Rect px py pw ph) + (FillStyle (tpBackground pal) 0.95) + (Just (StrokeStyle (tpAxis pal) 0.8)) ] + in frame <> inner + +-- | primitive を (dx, dy) 平行移動 (inset 配置用)。 +offsetPrim :: Double -> Double -> Primitive -> Primitive +offsetPrim dx dy p = case p of + PLine (Point x1 y1) (Point x2 y2) ls -> + PLine (Point (x1 + dx) (y1 + dy)) (Point (x2 + dx) (y2 + dy)) ls + PRect (Rect x y w h) f s -> PRect (Rect (x + dx) (y + dy) w h) f s + PCircle (Point x y) rr f s t -> PCircle (Point (x + dx) (y + dy)) rr f s t + PPath segs f s -> PPath (map offsetSeg segs) f s + PText (Point x y) t ts -> PText (Point (x + dx) (y + dy)) t ts + PClipPush (Rect x y w h) -> PClipPush (Rect (x + dx) (y + dy) w h) + other -> other + where + offsetSeg seg = case seg of + MoveTo (Point x y) -> MoveTo (Point (x + dx) (y + dy)) + LineTo (Point x y) -> LineTo (Point (x + dx) (y + dy)) + CurveTo (Point x1 y1) (Point x2 y2) (Point x3 y3) -> + CurveTo (Point (x1 + dx) (y1 + dy)) (Point (x2 + dx) (y2 + dy)) + (Point (x3 + dx) (y3 + dy)) + ClosePath -> ClosePath diff --git a/src/Graphics/Hgg/Render/MCMC.hs b/src/Graphics/Hgg/Render/MCMC.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Render/MCMC.hs @@ -0,0 +1,319 @@ +-- | +-- Module : Graphics.Hgg.Render.MCMC +-- Description : MCMC 診断 mark (forest/funnel/autocorr/ess) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +module Graphics.Hgg.Render.MCMC where + +import Graphics.Hgg.Layout (numToText, + Layout (..), Rect (..), Scale (..), + ViewportSize (..), computeLayout, + ggAxTextMar, ggAxTitleMar, ggHalfLine, + ggTickLen, niceTicks, scaleApply, + Track (..), solveTracks, + needsLegend, effectiveLegendPos, + coordOf, isPolar, polarCenter, polarPoint, + domFrac, projectXY, projectRectData, + projectBarRect, catUnitPx, AxisPlacement (..), + coordXAxisPlacement, coordYAxisPlacement, + coordXGridIsVertical) +import Graphics.Hgg.Layout.RangeOf (qqPoints, ecdfPoints) -- Phase 11 A6-2/A6-4 +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Time.Format as Data.Time.Format +import Graphics.Hgg.Spec (Annotation (..), AxisFormat (..), + ColData (..), ColRef, + ColorEnc (..), ConnectSpec (..), + DAGEdge (..), DAGLayoutAlgorithm (..), + DAGNode (..), DAGNodeKind (..), + DAGPlate (..), DAGSpec (..), Layer (..), + LegendPosition (..), LegendSpec (..), + Inset (..), MarginalSpec (..), MarkKind (..), + MarkShape (..), ShapeMapEntry (..), + LineType (..), lineTypeDash, lineTypeForIndex, + ReferenceLine (..), Resolver, + Position (..), Coord (..), + FacetScales (..), freeScaleX, freeScaleY, + FacetSpace (..), freeSpaceX, freeSpaceY, + ThemeOverride (..), + VisualSpec (..), YAxisSide (..), axisFormatOf, + axisRotateOf, resolveAxisAngle, axisShowTicksOf, + axShowGrid, + FontSpec (..), + colRefName, resolveCol, resolveNum) +import Data.Maybe (mapMaybe, isJust) +import Data.List (sortOn, foldl') +import qualified Data.Map.Strict as Map +import Data.List (dropWhile, elemIndex, groupBy, nub, + sort, takeWhile) +import qualified Graphics.Hgg.Spec +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Numeric (showEFloat, showFFloat) + +import Graphics.Hgg.Primitive +import Graphics.Hgg.Render.Common + + +-- =========================================================================== +-- Phase 6 A4: MCMC autocorrelation +-- =========================================================================== + +-- | autocorrelation plot (P19、 Phase 6 A4): 1 列の時系列から lag-k 自己相関 r(τ) +-- を計算 + bar chart。 ±1.96/√N の significance band も併せて。 +-- | Autocorrelation plot (Phase 8 B12): encX = 生サンプル列、 lyChain = chain (任意)。 +-- chain ごとに ACF ρ(k), k=0..maxLag を計算し、 lag を横軸に chain 別の細い棒で描く +-- (= bayesplot mcmc_acf_bar 流: ACF は plot 内で計算)。 x=lag/y=相関 で軸転置のため +-- Layout scale に頼らず自前マッピング。 +renderAutocorr :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderAutocorr r layout thePal ly = + let xs = V.toList (vecOr (lyEncX ly) r) + maxLag = maybe 40 id (getLast (lyMaxLag ly)) + area = lpPlotArea layout + pal = lpCategoricalPalette layout + -- chain 分け (lyChain、 無ければ単一群) + groups = case getLast (lyChain ly) of + Just cr -> case resolveCol r cr of + Just (TxtData cs) -> chainGroups (map T.unpack (V.toList cs)) xs + Just (NumData cs) -> chainGroups (map show (V.toList cs)) xs + Nothing -> [("all", xs)] + Nothing -> [("all", xs)] + nCh = max 1 (length groups) + -- 値 → pixel: x=lag (0..maxLag を plotArea 幅へ)、 y=相関 [-1,1] を高さへ + slotW = rW area / fromIntegral (maxLag + 1) + barW = max 1.5 (slotW / fromIntegral nCh * 0.7) + sy v = rY area + rH area - ((v - (-1)) / 2) * rH area + base = sy 0 + -- Phase 10 A4: value 軸 = 相関 [-1,1] (Cartesian 縦 sy / flip 横 valPxF)、 cross 軸 = lag + -- (Cartesian 横 slot / flip 縦 slot・lag0 を下端)。 自前マッピングのまま coord で辺を入替。 + coord = flipOnly (lpCoord layout) -- A7-c: autocorr は polar 非対象 + slotV = rH area / fromIntegral (maxLag + 1) + barWV = max 1.5 (slotV / fromIntegral nCh * 0.7) + valPxF v = rX area + ((v + 1) / 2) * rW area + baseF = valPxF 0 + mkBar k ci rk = case coord of + CoordCartesian -> + let slotCx = rX area + (fromIntegral k + 0.5) * slotW + cx = slotCx - slotW * 0.5 + (fromIntegral ci + 0.5) * (slotW / fromIntegral nCh) - barW/2 + in Rect cx (min (sy rk) base) barW (abs (sy rk - base)) + CoordFlip -> + let slotCy = rY area + rH area - (fromIntegral k + 0.5) * slotV + cyTop = slotCy - slotV * 0.5 + (fromIntegral ci + 0.5) * (slotV / fromIntegral nCh) - barWV/2 + in Rect (min (valPxF rk) baseF) cyTop (abs (valPxF rk - baseF)) barWV + drawChain ci (_lbl, vs) = + let col = pal !! (ci `mod` length pal) + rs = map (autocorrAt vs) [0 .. maxLag] + in [ PRect (mkBar k ci rk) (FillStyle col 0.85) (Just (StrokeStyle col 0.5)) + | (k, rk) <- zip [0 :: Int ..] rs ] + bars = concat (zipWith drawChain [0..] groups) + -- significance band ±1.96/sqrt(N) (= 95% null) + 0 線。 value=t の参照線 (cross 軸全長)。 + nTot = length xs + sg = if nTot < 2 then 0 else 1.96 / sqrt (fromIntegral nTot :: Double) + valRefLine t = case coord of + CoordCartesian -> (Point (rX area) (sy t), Point (rX area + rW area) (sy t)) + CoordFlip -> (Point (valPxF t) (rY area), Point (valPxF t) (rY area + rH area)) + sigBand = (let (z1, z2) = valRefLine 0 in [ PLine z1 z2 (solid (tpAxis thePal) 1.0) ]) + ++ concat [ [ PLine a1 a2 (solid "#888" 0.8), PLine b1 b2 (solid "#888" 0.8) ] + | sg > 0, let (a1, a2) = valRefLine sg, let (b1, b2) = valRefLine (negate sg) ] + -- value 軸目盛り (相関 -1..1。 Cartesian 左辺 / flip 下辺) + valAnchor = case coord of CoordCartesian -> AnchorEnd; CoordFlip -> AnchorMiddle + tsY = mkFontTS Nothing thePal TickF valAnchor 0 + yTicks = [ p | tv <- [-1.0, -0.5, 0, 0.5, 1.0] + , p <- case coord of + CoordCartesian -> + [ PLine (Point (rX area) (sy tv)) (Point (rX area - 5) (sy tv)) (solid (tpAxis thePal) 1.0) + , PText (Point (rX area - 8) (sy tv + 4)) (numToText tv) tsY ] + CoordFlip -> + [ PLine (Point (valPxF tv) (rY area + rH area)) (Point (valPxF tv) (rY area + rH area + 5)) (solid (tpAxis thePal) 1.0) + , PText (Point (valPxF tv) (rY area + rH area + 18)) (numToText tv) tsY ] ] + in axisFrame layout thePal ++ yTicks ++ sigBand ++ bars + where + chainGroups :: [String] -> [Double] -> [(String, [Double])] + chainGroups labels values = + let pairs = zip labels values + uniqLabels = foldr (\(l, _) acc -> if l `elem` acc then acc else l : acc) [] pairs + in [ (l, [v | (lv, v) <- pairs, lv == l]) | l <- uniqLabels ] + -- r(τ) = Σ(x_t - μ)(x_{t+τ} - μ) / Σ(x_t - μ)² + autocorrAt :: [Double] -> Int -> Double + autocorrAt vs k + | length vs <= k = 0 + | otherwise = + let mu = sum vs / fromIntegral (length vs) + centered = map (subtract mu) vs + denom = sum (map (^ (2 :: Int)) centered) + pairs = zip centered (drop k centered) + num = sum (map (uncurry (*)) pairs) + in if denom == 0 then 0 else num / denom + +-- =========================================================================== +-- Phase 6 A5: Effective Sample Size +-- =========================================================================== + +-- | ESS plot (Phase 8 B13): encX = パラメータ/chain 名、 encY = 計算済み ESS 値。 +-- ESS 計算は統計ライブラリの責務、 plot は値を棒にするだけ (= ggplot/bayesplot 流の +-- 計算と描画の分離)。 ESS 閾値 (100/400) で色分け (赤=低い/橙=中/緑=高い)。 +-- x=名前/y=ESS で軸が転置するため Layout scale に頼らず自前マッピング。 +renderESS :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderESS r layout thePal ly = + let names = catLabelsOf r ly + vals = V.toList (vecOr (lyEncY ly) r) + n = min (length names) (length vals) + pairs = take n (zip names vals) + area = lpPlotArea layout + yMax = maximum (100 : vals) -- 最低 100 まで (= 閾値が見える) + sy v = if yMax <= 0 then rY area + rH area + else rY area + rH area - v / yMax * rH area + nB = length pairs + step = if nB == 0 then 0 else rW area / fromIntegral nB + stepV = if nB == 0 then 0 else rH area / fromIntegral nB + barW = step * 0.6 + -- Phase 10 A4: value 軸 = ESS 値 (Cartesian 縦 sy / flip 横 valPxF)、 cross 軸 = 名前 + -- (Cartesian 横 cx / flip 縦 cy・先頭を下端に)。 自前マッピングのまま coord で辺を入替。 + coord = flipOnly (lpCoord layout) -- A7-c: ess は polar 非対象 + valPxF v = rX area + (if yMax <= 0 then 0 else v / yMax) * rW area + cxFor i = rX area + (fromIntegral i + 0.5) * step + cyFor i = rY area + rH area - (fromIntegral i + 0.5) * stepV + mkBarRect i v = case coord of + CoordCartesian -> Rect (cxFor i - barW/2) (sy v) barW (rY area + rH area - sy v) + CoordFlip -> Rect (rX area) (cyFor i - barW/2) (valPxF v - rX area) barW + valRefLine t = case coord of + CoordCartesian -> (Point (rX area) (sy t), Point (rX area + rW area) (sy t)) + CoordFlip -> (Point (valPxF t) (rY area), Point (valPxF t) (rY area + rH area)) + catAnchor = case coord of CoordCartesian -> AnchorMiddle; CoordFlip -> AnchorEnd + valAnchor = case coord of CoordCartesian -> AnchorEnd; CoordFlip -> AnchorMiddle + tsCat = mkFontTS Nothing thePal TickF catAnchor 0 + drawOne i (nm, v) = + let col | v < 100 = "#d9534f" -- 低い (要注意) + | v < 400 = "#f0ad4e" -- 中 + | otherwise = "#5cb85c" -- 良い + lblPt = case coord of + CoordCartesian -> Point (cxFor i) (rY area + rH area + 16) + CoordFlip -> Point (rX area - 6) (cyFor i + 4) + in [ PRect (mkBarRect i v) (FillStyle col 0.85) (Just (StrokeStyle col 0.5)) + , PText lblPt nm tsCat ] + -- ESS 閾値の参照線 (100 / 400) + refLines = + [ PLine p1 p2 (solid "#888888" 0.8) + | t <- [100, 400], t <= yMax, let (p1, p2) = valRefLine t ] + -- value 軸目盛り (Cartesian 左辺 / flip 下辺) + tsY = mkFontTS Nothing thePal TickF valAnchor 0 + yTicks = + [ p | tv <- niceTicks 5 0 yMax + , p <- case coord of + CoordCartesian -> + [ PLine (Point (rX area) (sy tv)) (Point (rX area - 5) (sy tv)) (solid (tpAxis thePal) 1.0) + , PText (Point (rX area - 8) (sy tv + 4)) (numToText tv) tsY ] + CoordFlip -> + [ PLine (Point (valPxF tv) (rY area + rH area)) (Point (valPxF tv) (rY area + rH area + 5)) (solid (tpAxis thePal) 1.0) + , PText (Point (valPxF tv) (rY area + rH area + 18)) (numToText tv) tsY ] ] + in axisFrame layout thePal ++ yTicks ++ refLines + ++ concatMap (uncurry drawOne) (zip [0..] pairs) + +-- =========================================================================== +-- Phase 6 A2: Forest plot +-- =========================================================================== + +-- | Forest plot (Phase 6 A2): 各 row が「label + 点推定 + CI」 の horizontal CI bar 群。 +-- encY = label index (= 0..n-1)、 encX = estimate、 errorX = ± 半幅。 中央 vertical 線。 +renderForest :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderForest r layout pal ly = + let ests = V.toList (vecOr (lyEncX ly) r) + errs = case getLast (lyErrorX ly) of + Just c -> V.toList (vecOr (Last (Just c)) r) + Nothing -> repeat 0 + n = length ests + -- Phase 8 B23-fix: row i を position (n-1-i) に置き、 先頭研究を上端へ (= PS と同方向)。 + -- Layout 側で forest の yCatLabels を反転済みなのでラベルとマーカーが整合する。 + ys = take n [n - 1, n - 2 ..] -- label y 位置 (= 上から先頭研究) + c = staticColorOr ly (tpDefault pal) + a = doubleOr (lyAlpha ly) 0.9 + ptSz = doubleOr (lySize ly) (mmPt 1.5) + sx = scaleApply (lpXScale layout) + nullX = maybe 0.0 (fromIntegral) (getLast (lyMaxLag ly)) -- 流用 + area = lpPlotArea layout + -- Phase 10 A4: glyph は projectPoint、 data-x の参照線は xRefLine で flip 追従。 + coord = flipOnly (lpCoord layout) -- A7-c: forest は polar 非対象 + pp = projectPoint coord layout + -- data x=v の参照線 (Cartesian は縦線 panel 全高、 flip は横線 panel 全幅)。 + xRefLine v = case coord of + CoordCartesian -> (Point (sx v) (rY area), Point (sx v) (rY area + rH area)) + CoordFlip -> let yp = scaleApply (lpXScaleFlipped layout) v + in (Point (rX area) yp, Point (rX area + rW area) yp) + -- 中央 null line + nullLine = let (p1, p2) = xRefLine nullX in [ PLine p1 p2 (solid "#888" 1.0) ] + -- 各 row: 水平 CI 線 + 点 marker + rowsP = concat + [ [ PLine (pp (e - err) yp) (pp (e + err) yp) (solid c 1.5) + , PCircle (pp e yp) (ptSz / 2) + (FillStyle c a) (Just (StrokeStyle c 1.0)) Nothing + ] + | (e, err, yp) <- zip3 ests errs (map fromIntegral ys) + ] + in nullLine <> rowsP + +-- =========================================================================== +-- Phase 6 A3: Funnel plot +-- =========================================================================== + +-- | Funnel plot (Phase 6 A3): 効果量 vs 標準誤差の散布図 + 95% envelope。 +-- encX = effect、 encY = SE。 envelope は y range の最大 SE まで diagonal で描画。 +renderFunnel :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderFunnel r layout pal ly = + let effects = V.toList (vecOr (lyEncX ly) r) + ses = V.toList (vecOr (lyEncY ly) r) + c = staticColorOr ly (tpDefault pal) + a = doubleOr (lyAlpha ly) 0.7 + ptSz = doubleOr (lySize ly) (mmPt 1.25) + sx = scaleApply (lpXScale layout) + n = length effects + mu = if n == 0 then 0 else sum effects / fromIntegral n + seMax = if null ses then 1 else maximum ses + area = lpPlotArea layout + -- Phase 10 A4: 点・envelope 端点は projectPoint、 mu 参照線は xRefLine で flip 追従。 + coord = flipOnly (lpCoord layout) -- A7-c: funnel は polar 非対象 + pp = projectPoint coord layout + xRefLine v = case coord of + CoordCartesian -> (Point (sx v) (rY area), Point (sx v) (rY area + rH area)) + CoordFlip -> let yp = scaleApply (lpXScaleFlipped layout) v + in (Point (rX area) yp, Point (rX area + rW area) yp) + points = [ PCircle (pp eff se) (ptSz / 2) + (FillStyle c a) (Just (StrokeStyle c 1.0)) Nothing + | (eff, se) <- zip effects ses ] + muLine = let (p1, p2) = xRefLine mu in [ PLine p1 p2 (solid "#888" 1.0) ] + -- diagonal envelope (= ±1.96 SE)、 plotArea 矩形に Liang-Barsky clip + clipLine (Point x1 y1) (Point x2 y2) = + let (xMin, xMax) = (rX area, rX area + rW area) + (yMin, yMax) = (rY area, rY area + rH area) + dx = x2 - x1 + dy = y2 - y1 + ts = foldl (\acc (p, q) -> if p == 0 + then (if q < 0 then Nothing else acc) + else case acc of + Nothing -> Nothing + Just (t0, t1) -> + let t = q / p + in if p < 0 + then if t > t1 then Nothing + else Just (max t0 t, t1) + else if t < t0 then Nothing + else Just (t0, min t1 t)) + (Just (0, 1)) + [(-dx, x1 - xMin), (dx, xMax - x1) + ,(-dy, y1 - yMin), (dy, yMax - y1)] + in case ts of + Just (t0, t1) | t0 < t1 -> + Just (Point (x1 + t0 * dx) (y1 + t0 * dy), + Point (x1 + t1 * dx) (y1 + t1 * dy)) + _ -> Nothing + envSeg from to = case clipLine from to of + Just (p1, p2) -> [PLine p1 p2 (solid "#888" 0.8)] + Nothing -> [] + envL = envSeg (pp mu 0) (pp (mu - 1.96 * seMax) seMax) + envR = envSeg (pp mu 0) (pp (mu + 1.96 * seMax) seMax) + in muLine <> envL <> envR <> points diff --git a/src/Graphics/Hgg/Render/Special.hs b/src/Graphics/Hgg/Render/Special.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Render/Special.hs @@ -0,0 +1,806 @@ +-- | +-- Module : Graphics.Hgg.Render.Special +-- Description : 特殊 mark (pie/waterfall/parallel/text/DAG) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +module Graphics.Hgg.Render.Special where + +import Graphics.Hgg.Layout (numToText, + Layout (..), Rect (..), Scale (..), + ViewportSize (..), computeLayout, + ggAxTextMar, ggAxTitleMar, ggHalfLine, + ggTickLen, niceTicks, scaleApply, + Track (..), solveTracks, + needsLegend, effectiveLegendPos, + coordOf, isPolar, polarCenter, polarPoint, + domFrac, projectXY, projectRectData, + projectBarRect, catUnitPx, AxisPlacement (..), + coordXAxisPlacement, coordYAxisPlacement, + coordXGridIsVertical, textWidthEm) +import Graphics.Hgg.Layout.RangeOf (qqPoints, ecdfPoints) -- Phase 11 A6-2/A6-4 +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Time.Format as Data.Time.Format +import Graphics.Hgg.Spec (Annotation (..), AxisFormat (..), + ColData (..), ColRef, + ColorEnc (..), ConnectSpec (..), + DAGEdge (..), DAGLayoutAlgorithm (..), + RoutedEdge (..), EdgeShapeKind (..), + DAGNode (..), DAGNodeKind (..), + DAGPlate (..), DAGSpec (..), Layer (..), + LegendPosition (..), LegendSpec (..), + Inset (..), MarginalSpec (..), MarkKind (..), + MarkShape (..), ShapeMapEntry (..), + LineType (..), lineTypeDash, lineTypeForIndex, + ReferenceLine (..), Resolver, + Position (..), Coord (..), + FacetScales (..), freeScaleX, freeScaleY, + FacetSpace (..), freeSpaceX, freeSpaceY, + ThemeOverride (..), + VisualSpec (..), YAxisSide (..), axisFormatOf, + axisRotateOf, resolveAxisAngle, axisShowTicksOf, + axShowGrid, + FontSpec (..), + colRefName, resolveCol, resolveNum) +import Data.Maybe (mapMaybe, isJust) +import Data.List (sortOn, foldl') +import qualified Data.Map.Strict as Map +import Data.List (dropWhile, elemIndex, groupBy, nub, + sort, takeWhile) +import qualified Graphics.Hgg.Spec +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Numeric (showEFloat, showFFloat) + +import Graphics.Hgg.Primitive +import Graphics.Hgg.Render.Common +import Graphics.Hgg.Render.EdgeRoute (EdgeRoute (..), routeEdge, + spreadPorts, + Obstacles, dagObstacles, + plateBoxPt, + edgePortPoint, nodeExtent, nodeShowsDist, + dagLabelFs) + + +-- | Phase 42 sub B: pt 空間への写像 'toScreen' (= node 実寸から graphviz 風自然 +-- アスペクトを算出)。 render と routing bake で共有する純関数。area 非依存。 +-- * LayoutHierarchical: dnX = raw point x、 dnY = rank index。 x は 1:1、 +-- y = rank index × rankPitch (= maxNodeH + ranksep)。 = 完全忠実 point pipeline。 +-- * LayoutManual: dnX/dnY は正規化 [0,1]²。 各 rank 内の最小 x gap から横潰れしない +-- wpt を逆算し wpt/hpt で point 空間へ展開 (graphviz 風)。 +-- 最終 'fitPrimsToArea' が両経路ともアスペクト保持で area へ一様 fit。 +dagToScreen :: Double -> [DAGNode] -> DAGLayoutAlgorithm -> (Double -> Double -> Point) +dagToScreen radius nodes algo = toScreen + where + nodeW n = let (rx, _) = nodeExtent n radius in 2 * rx + nodeH n = let (_, ry) = nodeExtent n radius in 2 * ry + maxNodeW = maximum (2 * radius : map nodeW nodes) + maxNodeH = maximum (2 * radius : map nodeH nodes) + ranksep = dagLabelFs * 2.0 + rankPitch = maxNodeH + ranksep + isManual = algo == LayoutManual + nodesep = maxNodeW * 0.25 + yLevels = nub (sort (map dnY nodes)) + rankCount = length yLevels + rowGaps = [ g | lvl <- yLevels + , let xs = sort [ dnX n | n <- nodes, dnY n == lvl ] + , g <- zipWith (\a b -> b - a) xs (drop 1 xs) + , g > 1e-6 ] + minGap = if null rowGaps then 1 else minimum rowGaps + wpt = (maxNodeW + nodesep) / minGap + hpt = fromIntegral (max 1 (rankCount - 1)) * (maxNodeH + ranksep) + toScreen x y + | isManual = Point (x * wpt) (y * hpt) + | otherwise = Point x (y * rankPitch) + +-- | Phase 42 sub B: layer の DAG edge に pt 空間 routing を焼き込む (= 'deRoute' 充填)。 +-- 'renderDAGStandalone' の edge routing pipeline (toScreen + obstacles + 並列 index + +-- routeEdge) と同一手順で計算するため、 baked route は live routing と byte-identical。 +-- size は layer の 'lySize' (既定 径11mm)。 端点ノードが無い edge は 'Nothing' のまま。 +-- 結果 spec を JSON 化すると PS が同 routing を描ける (= HS/PS parity)。 +dagBakeRoutes :: Layer -> Layer +dagBakeRoutes ly = case getLast (lyDAG ly) of + Nothing -> ly + Just (DAGSpec nodes es algo plates) -> + let radius = doubleOr (lySize ly) (mmPt 11) / 2 + toScreen = dagToScreen radius nodes algo + nodeMap = [ (dnId n, n) | n <- nodes ] + lookup_ k = case [ n | (i, n) <- nodeMap, i == k ] of + (n:_) -> Just n + [] -> Nothing + obs = dagObstacles toScreen radius nodes nodeMap plates es + parTotal = foldl' (\m (DAGEdge f t _ _) -> Map.insertWith (+) (f, t) (1 :: Int) m) + Map.empty es + -- 各 edge を (index, parIx) 付きで歩く (renderDAGStandalone と同順)。 + withIx = snd $ foldl' + (\(seen, acc) e@(DAGEdge f t _ _) -> + let k = (f, t) + ix = Map.findWithDefault 0 k seen + in (Map.insert k (ix + 1) seen, acc ++ [(e, ix)])) + (Map.empty, []) es + mkRoute (e@(DAGEdge f t _ _), ix) = + case (lookup_ f, lookup_ t) of + (Just from, Just to) -> + let tot = Map.findWithDefault 1 (f, t) parTotal + in Just (from, to, routeEdge toScreen obs from to (dePath e) radius ix tot) + _ -> Nothing + mrs = map mkRoute withIx + -- ★ Phase 52 A6: 全 route 確定後に port 分散 post-pass (live 側と同順) + rts = spreadPorts toScreen radius + [ (f, t) | Just (f, t, _) <- mrs ] + [ r | Just (_, _, r) <- mrs ] + stitch ((e, _) : rest) (Nothing : ms) rs = e : stitch rest ms rs + stitch ((e, _) : rest) (Just _ : ms) (r : rs) = + e { deRoute = Just (edgeRouteToRouted r) } : stitch rest ms rs + stitch _ _ _ = [] + es' = stitch withIx mrs rts + in ly { lyDAG = Last (Just (DAGSpec nodes es' algo plates)) } + +-- | Phase 42 sub B: 'VisualSpec' 内の全 DAG layer に 'dagBakeRoutes' を適用。 +-- HS で図を生成し PS 用 JSON を吐く直前に呼ぶ (= routing を spec へ焼き込む境界)。 +bakeDAGRoutesInSpec :: VisualSpec -> VisualSpec +bakeDAGRoutesInSpec vs = vs { vsLayers = map dagBakeRoutes (vsLayers vs) } + +-- | DAG 専用 (= axis 不要)。 0..1 domain 座標を area 内に直接 mapping。 +-- 描画順序: plate (= 背景) → edge → node。 +renderDAGStandalone :: Rect -> ThemePalette -> Layer -> [Primitive] +renderDAGStandalone area pal ly = case getLast (lyDAG ly) of + Nothing -> [] + Just (DAGSpec nodes es algo plates) -> + -- ★ Phase 39 A2-1: レイアウトは正規化 [0,1]² を返すが、 それを area の縦横へ + -- 独立に引き伸ばすと rank 数が少ないとき縦に間延びする (アスペクト = area 比に + -- 固定されてしまう)。 代わりに node の実寸 (pt) から graphviz 風の自然アスペクト + -- (Wpt × Hpt) を算出して pt 空間へ写し、 最後に 'fitPrimsToArea' がアスペクトを + -- 保ったまま area へフィット (= 縮小も拡大も) する。 これで rank 間隔/ノード間隔が + -- ノード寸法に対し一定比になり間延びが解消する。 + let radius = doubleOr (lySize ly) (mmPt 11) / 2 -- ★ Phase 34 A3: size=直径 統一 (既定 径11mm=半径5.5mm) + -- ★ Phase 42 sub B: pt 空間 toScreen は bake (dagBakeRoutes) と共有する純関数へ + -- 抽出した。 toScreen の入力契約 (hierarchical=x 1:1/y=rank×pitch、 manual=wpt/hpt) + -- は 'dagToScreen' を参照。 + toScreen = dagToScreen radius nodes algo + nodeMap = [ (dnId n, n) | n <- nodes ] + lookup_ k = case [n | (i, n) <- nodeMap, i == k] of + (n:_) -> Just n + [] -> Nothing + platePrims = concatMap (renderPlate toScreen radius pal nodeMap plates) plates + -- Phase 39 A-1: pt 空間の障害物 (node glyph box + plate box + A4 dummy lane)。 + -- long edge の box-channel + funnel routing に渡す。 + obs = dagObstacles toScreen radius nodes nodeMap plates es + -- 並列 edge (= 同 (from, to) ペアが N 本) を検出。 各 edge に group 内 index と + -- 総本数を付与して 'renderEdge' に渡し、 描画側で perpendicular にずらして + -- 重なりを避ける (= graphviz dot 同等の表現)。 + parTotal = foldl' (\m (DAGEdge f t _ _) -> Map.insertWith (+) (f, t) (1 :: Int) m) + Map.empty es + indexed = snd $ foldl' + (\(seen, acc) e@(DAGEdge f t _ _) -> + let k = (f, t) + ix = Map.findWithDefault 0 k seen + in (Map.insert k (ix + 1) seen, acc ++ [(e, ix)])) + (Map.empty, []) + es + -- ★ Phase 42 sub C: edge に baked 'deRoute' があればそれを描画 (HS/PS で同一)、 + -- 無ければ従来どおり live 'routeEdge' で routing。 baked は同 pipeline 産なので + -- HS 出力は byte-identical。 + -- ★ Phase 52 A6: 全 route 確定後に port 分散 ('spreadPorts')。 bake 済み route は + -- bake 時に分散済 → cluster を成さず no-op (= 冪等) なので二重適用しない。 + edgeItems = + [ (from, to, e, ix) + | (e@(DAGEdge f t _ _), ix) <- indexed + , Just from <- [lookup_ f] + , Just to <- [lookup_ t] ] + rawRoutes = + [ case deRoute e of + Just re -> routedToEdgeRoute re + Nothing -> + let tot = Map.findWithDefault 1 (deFrom e, deTo e) parTotal + in routeEdge toScreen obs from to (dePath e) radius ix tot + | (from, to, e, ix) <- edgeItems ] + routes = spreadPorts toScreen radius + [ (f, t) | (f, t, _, _) <- edgeItems ] rawRoutes + edgePrims = concatMap (drawEdgeRoute pal) routes + nodePrims = concatMap (renderNode toScreen radius pal) nodes + -- Phase 39 A1: plate 枠 / ラベル / ノード / 矢印を含む実 bbox を求め、 指定 area + -- 内に必ず収まるよう一括 scale+translate (graphviz `size`/`ratio=expand` 相当)。 + -- 縮小も拡大もし (一様スケール・中央寄せ)、 はみ出しゼロを最優先。 + in fitPrimsToArea area (platePrims <> edgePrims <> nodePrims) + +-- | Phase 39 A1: DAG プリミティブ全体の bounding box (xlo, ylo, xhi, yhi)。 +-- 'PText' は 'textWidthEm' × fontSize で幅、 fontSize で高さを見積もり anchor で +-- 左右配分する (実フォント計測は不可ゆえ凡例/タイトルと同じ近似を流用)。 +primsBBoxDAG :: [Primitive] -> Maybe (Double, Double, Double, Double) +primsBBoxDAG prims = + case concatMap extents prims of + [] -> Nothing + bxs -> Just ( minimum [a | (a, _, _, _) <- bxs] + , minimum [b | (_, b, _, _) <- bxs] + , maximum [c | (_, _, c, _) <- bxs] + , maximum [d | (_, _, _, d) <- bxs] ) + where + segPts seg = case seg of + MoveTo (Point x y) -> [(x, y)] + LineTo (Point x y) -> [(x, y)] + CurveTo (Point ax ay) (Point bx by) (Point cx cy) -> [(ax, ay), (bx, by), (cx, cy)] + ClosePath -> [] + boxOf ps = case ps of + [] -> [] + _ -> let xs = map fst ps; ys = map snd ps + in [(minimum xs, minimum ys, maximum xs, maximum ys)] + extents p = case p of + PLine (Point x1 y1) (Point x2 y2) _ -> + [(min x1 x2, min y1 y2, max x1 x2, max y1 y2)] + PRect (Rect x y w h) _ _ -> [(x, y, x + w, y + h)] + PCircle (Point x y) rad _ _ _ -> [(x - rad, y - rad, x + rad, y + rad)] + PPath segs _ _ -> boxOf (concatMap segPts segs) + PText (Point x y) t ts -> + let w = textWidthEm t * tsSize ts + asc = tsSize ts * 0.8 + dsc = tsSize ts * 0.25 + (xl, xr) = case tsAnchor ts of + AnchorStart -> (x, x + w) + AnchorMiddle -> (x - w / 2, x + w / 2) + AnchorEnd -> (x - w, x) + in [(xl, y - asc, xr, y + dsc)] + _ -> [] + +-- | Phase 39 A1: プリミティブ一式を指定 area 内に一括 scale+translate でフィット。 +-- アスペクト比を保つ一様スケール (= min ratio・中央寄せ)。 figure が area より小さければ +-- 拡大して余白を埋め (graphviz `ratio=expand` 相当)、 大きければ縮小する。 内側 pad を +-- 取りストロークやラベル端が縁に触れないようにする。 フォント/線幅も s 倍。 +fitPrimsToArea :: Rect -> [Primitive] -> [Primitive] +fitPrimsToArea area prims = case primsBBoxDAG prims of + Nothing -> prims + Just (xlo, ylo, xhi, yhi) -> + let w = xhi - xlo + h = yhi - ylo + pad = 4 + availW = max 1 (rW area - 2 * pad) + availH = max 1 (rH area - 2 * pad) + s = if w <= 1e-9 || h <= 1e-9 then 1 else min (availW / w) (availH / h) + newW = w * s + newH = h * s + tx = rX area + (rW area - newW) / 2 - xlo * s + ty = rY area + (rH area - newH) / 2 - ylo * s + in map (affinePrim s tx ty) prims + +-- | x' = s·x + tx, y' = s·y + ty。 座標・半径・線幅・font size を一様に s 倍する +-- ('scalePrimitives' の dpi スケールに translate を加えた DAG fit 専用版)。 +affinePrim :: Double -> Double -> Double -> Primitive -> Primitive +affinePrim s tx ty = go + where + pt (Point x y) = Point (s * x + tx) (s * y + ty) + rect (Rect x y w h) = Rect (s * x + tx) (s * y + ty) (s * w) (s * h) + sst (StrokeStyle c w) = StrokeStyle c (w * s) + sls (LineStyle c w d) = LineStyle c (w * s) (map (* s) d) + sts t = t { tsSize = tsSize t * s } + seg sg = case sg of + MoveTo p -> MoveTo (pt p) + LineTo p -> LineTo (pt p) + CurveTo a b c -> CurveTo (pt a) (pt b) (pt c) + ClosePath -> ClosePath + go p = case p of + PLine a b ls -> PLine (pt a) (pt b) (sls ls) + PRect r fs mss -> PRect (rect r) fs (fmap sst mss) + PCircle c rad fs mss l -> PCircle (pt c) (rad * s) fs (fmap sst mss) l + PPath segs fs mss -> PPath (map seg segs) fs (fmap sst mss) + PText q t ts -> PText (pt q) t (sts ts) + PClipPush r -> PClipPush (rect r) + PClipPop -> PClipPop + PTransformPush tr -> PTransformPush tr + PTransformPop -> PTransformPop + +-- | Phase 1 A5/A7/parallel: dePath で straight / spline 切替、 端点は A7 で node 形状との +-- 正確な交点へ snap、 'parIx' / 'parCount' で並列 edge の perpendicular bend を付与。 +-- +-- * 'parCount' = 1: 通常描画 (= bend 無し) +-- * 'parCount' > 1: 各 edge を ((parIx - (N-1)/2) * spacing) perpendicular ずらして +-- 重ならない曲線群にする (= graphviz dot の parallel edge 表現) +renderEdge + :: (Double -> Double -> Point) + -> Obstacles -- ^ Phase 39 A-1: node + plate 障害物 (pt) + -> DAGNode -> DAGNode -> DAGEdge + -> Double -> ThemePalette + -> Int -> Int -- ^ parIx, parCount + -> [Primitive] +renderEdge toScreen obs from to e radius pal parIx parCount = + -- Phase 39 B2 / 42 sub C: routing 幾何は baked 'deRoute' があればそれを使い、 + -- 無ければ live 'routeEdge' (Render.EdgeRoute) で決定。 ここは制御点列 + style を + -- ThemePalette 付きで描画 primitive へ落とすだけ。 + drawEdgeRoute pal $ case deRoute e of + Just re -> routedToEdgeRoute re + Nothing -> routeEdge toScreen obs from to (dePath e) radius parIx parCount + +-- | Phase 42 sub C: 'EdgeRoute' (制御点列 + 形状) を描画 primitive へ。 +drawEdgeRoute :: ThemePalette -> EdgeRoute -> [Primitive] +drawEdgeRoute pal route = case route of + StraightArrow a b -> arrowEdgeFromPorts a b pal + SplinePath pts -> splineEdgeFromPorts pts pal + -- 迂回経路は箱角 waypoint をそのまま通すため corner-cutting を掛けない + -- (smoothInterior は棚緩和用で、 箱角を中央へ引き戻すと貫通する)。 + BezierPath pts -> bezierThroughPorts pts pal + -- R3 (Step6 P7a): graphviz Proutespline の cubic Bézier 制御点列 (始点 + 3 点ずつ)。 + CubicPath ctrl -> cubicEdgeFromControls ctrl pal + +-- | Phase 42 sub B/C: 焼き込んだ 'RoutedEdge' を 'EdgeRoute' へ復元 (pt 空間)。 +routedToEdgeRoute :: RoutedEdge -> EdgeRoute +routedToEdgeRoute (RoutedEdge k ps) = + let pts = [ Point x y | (x, y) <- ps ] + in case k of + EShStraight -> case pts of + (a : b : _) -> StraightArrow a b + _ -> SplinePath pts -- 退化時の安全側 + EShSpline -> SplinePath pts + EShBezier -> BezierPath pts + EShCubic -> CubicPath pts + +-- | Phase 42 sub B/C: 'EdgeRoute' を spec 焼き込み用 'RoutedEdge' (pt 空間) へ。 +edgeRouteToRouted :: EdgeRoute -> RoutedEdge +edgeRouteToRouted route = case route of + StraightArrow a b -> RoutedEdge EShStraight (map p2 [a, b]) + SplinePath pts -> RoutedEdge EShSpline (map p2 pts) + BezierPath pts -> RoutedEdge EShBezier (map p2 pts) + CubicPath ctrl -> RoutedEdge EShCubic (map p2 ctrl) + where p2 (Point x y) = (x, y) + +-- | 1 node を kind に応じた形状で描画 + label (+ 分布名 sub-label)。 +-- ★A15: サイズは label に合わせ可変 ('nodeExtent')。 形状は PyMC 慣例 = latent/observed は楕円、 +-- deterministic/data/other は四角。 deterministic は name のみ (dist 非表示)。 +renderNode :: (Double -> Double -> Point) -> Double -> ThemePalette + -> DAGNode -> [Primitive] +renderNode toScreen radius pal n = + let Point cx cy = toScreen (dnX n) (dnY n) + (rx, ry) = nodeExtent n radius + showDist = nodeShowsDist n + ts = mkFontTS Nothing pal TickF AnchorMiddle 0 + tsSmall = ts { tsSize = 9 } + fill = case dnKind n of + NodeLatent -> "#ffffff" + NodeObserved -> "#cfcfcf" -- 灰色 fill = observed (PyMC 慣例) + NodeDeterministic -> "#ffffff" -- 白四角 = deterministic (PyMC 慣例) + NodeData -> "#cfcfcf" -- 灰 = ConstantData (PyMC 慣例) + NodeOther -> "#dddddd" + stroke_ = StrokeStyle (tpAxis pal) 1.2 + -- shape: latent/observed = 楕円、 deterministic/data/other = 四角 (PyMC 慣例) + ellipseShape = PPath (ellipsePath cx cy rx ry) (FillStyle fill 1.0) (Just stroke_) + rectShape = PRect (Rect (cx - rx) (cy - ry) (2 * rx) (2 * ry)) + (FillStyle fill 1.0) (Just stroke_) + shape = case dnKind n of + NodeLatent -> ellipseShape + NodeObserved -> ellipseShape + NodeDeterministic -> rectShape + NodeData -> rectShape + NodeOther -> rectShape + -- label: dist を持つ stochastic は 3 行 (name / ~ / dist)、 それ以外は name のみ 1 行。 + -- Phase 39 A2-7: 行を cy 中心に対称配置。 baseAdj は baseline→glyph 視覚中心の + -- 補正 (≈ 0.34×fs)。 旧 (-8/+4/+16) は補正なしで block が約 2px 下寄りだった。 + baseAdj = tsSize ts * 0.34 + lineGap = 12 + textPrims = case dnDist n of + Just dist | showDist -> + [ PText (Point cx (cy - lineGap + baseAdj)) (dnLabel n) ts + , PText (Point cx (cy + baseAdj)) (T.pack "~") tsSmall + , PText (Point cx (cy + lineGap + baseAdj)) dist tsSmall + ] + _ -> + [ PText (Point cx (cy + baseAdj)) (dnLabel n) ts ] + in shape : textPrims + +-- | 楕円を Bezier 近似で path に。 +ellipsePath :: Double -> Double -> Double -> Double -> [PathSegment] +ellipsePath cx cy rx ry = + let k = 0.5522847498 -- magic for circle approximation + kx = rx * k + ky = ry * k + in [ MoveTo (Point (cx - rx) cy) + , CurveTo (Point (cx - rx) (cy - ky)) (Point (cx - kx) (cy - ry)) (Point cx (cy - ry)) + , CurveTo (Point (cx + kx) (cy - ry)) (Point (cx + rx) (cy - ky)) (Point (cx + rx) cy) + , CurveTo (Point (cx + rx) (cy + ky)) (Point (cx + kx) (cy + ry)) (Point cx (cy + ry)) + , CurveTo (Point (cx - kx) (cy + ry)) (Point (cx - rx) (cy + ky)) (Point (cx - rx) cy) + , ClosePath + ] + +-- | plate を node 群の bounding box + label で描画。 +-- +-- Phase 23: bbox はノード中心でなく **glyph bbox (中心 ± 'nodeExtent')**。 +-- 固定 pad (radius*1.6) だと label の長いノード (rx > pad) が plate の +-- 水平端で枠を超える (analyze Phase 63.2 で実測確定)。 +renderPlate :: (Double -> Double -> Point) -> Double -> ThemePalette + -> [(Text, DAGNode)] -> [DAGPlate] -> DAGPlate -> [Primitive] +renderPlate toScreen radius pal nodeMap allPlates plate = + case plateBoxPt toScreen radius nodeMap allPlates plate of + Nothing -> [] + Just (xlo, boxTop, xhi, yhi) -> + let rw = xhi - xlo + -- label を枠の **下端・右寄せ** に置く (graphviz labelloc=b labeljust=r 同型)。 + -- label 帯は 'plateBoxPt' が box 下端に labelH ぶん確保済。 + rh = yhi - boxTop + labelTS = mkFontTS Nothing pal LegendItemF AnchorEnd 0 + in [ PRect (Rect xlo boxTop rw rh) + (FillStyle "#ffffff" 0) + (Just (StrokeStyle (tpAxis pal) 1.0)) + , PText (Point (xhi - 5) (yhi - 4)) + (dpLabel plate) labelTS + ] + +-- | Phase 1 A7: 端点が既に node 形状端に snap 済の前提で直線 + 矢印ヘッド描画。 +arrowEdgeFromPorts :: Point -> Point -> ThemePalette -> [Primitive] +arrowEdgeFromPorts (Point sx sy) (Point ex ey) pal = + let dx = ex - sx; dy = ey - sy + len = sqrt (dx * dx + dy * dy) + ux = if len > 0 then dx / len else 0 + uy = if len > 0 then dy / len else 0 + -- 矢じり: graphviz 較正 (長 10 × 底辺 7 = headWid*2)。 旧 headWid=5 は底辺 10 で + -- graphviz より太かった (Phase1A5 の未較正定数・Phase 39 で較正)。 + headLen = 10.0 + headWid = 3.5 + px = -uy; py = ux + bx = ex - ux * headLen + by = ey - uy * headLen + -- ★ Phase 44.8: 線は **鏃の底辺 (bx,by) で止める** (tip まで引かない)。 線を tip + -- まで引くと塗り三角の内部を線が貫通し「線＋三角を重ねた」見た目になり矢印に + -- 見えない (ユーザ指摘 2026-06-26)。 graphviz も線を鏃底辺で止め tip は鏃が担う。 + line_ = PLine (Point sx sy) (Point bx by) (solid (tpAxis pal) 1.5) + h1 = Point (bx + px * headWid) (by + py * headWid) + h2 = Point (bx - px * headWid) (by - py * headWid) + headPath = PPath + [ MoveTo (Point ex ey), LineTo h1, LineTo h2, ClosePath ] + (FillStyle (tpAxis pal) 1.0) Nothing + in [line_, headPath] + +-- | Phase 1 A5+A7: 始終点 snap 済 control 点列を Catmull-Rom spline + 矢印で描画。 +-- 中間制御点には corner-cutting smoothing (= 内部点を隣接 3 点の (1,2,1)/4 平均で置換) を +-- 2 pass 適用してから Catmull-Rom に渡す。 これで dummy 経由の「棚 / 2 山」 を緩和し、 +-- 真の B-spline に近い視覚を直線パスのまま得る。 端点は保持されるので port snap は崩れない。 +-- +-- Phase 39 A2-4: ただし内部点が **1 個だけ** (= 制御点 3 個、 dummy 1 個の短い skip) +-- の場合は smoothing を掛けない。 2-pass 平均は唯一の内部点を始終点の中点へ強く +-- 引き戻すため、 routeLongEdgeDummies が plate 箱の外へ出した bulge が潰れて edge が +-- 箱へ再侵入してしまう。 棚は内部点 2 個以上 (長い chain) でしか生じないので、 +-- 短い chain では bulge をそのまま活かす。 +-- | Phase 39 A2-8: 制御点列を **そのまま** Catmull-Rom で通す (= 平滑化なし)。 +-- 箱角 waypoint を中央へ引き戻さないため、 迂回経路の描画に使う。 +bezierThroughPorts :: [Point] -> ThemePalette -> [Primitive] +bezierThroughPorts = drawCatmullRom + +splineEdgeFromPorts :: [Point] -> ThemePalette -> [Primitive] +splineEdgeFromPorts ptsRaw pal = + let pts = if length ptsRaw >= 4 then smoothInterior 2 ptsRaw else ptsRaw + in drawCatmullRom pts pal + +-- | Catmull-Rom spline + 矢印ヘッドを制御点列から描画 (平滑化は呼出側責務)。 +drawCatmullRom :: [Point] -> ThemePalette -> [Primitive] +drawCatmullRom pts pal = + let n = length pts + in if n < 2 then [] else + let p0 = head pts + (trimmed, basePt, apex, u) = trimLastCubic dagHeadLen p0 (catmullRomToBezier pts) + edgePath = PPath (MoveTo p0 : trimmed) + (FillStyle "#000000" 0) + (Just (StrokeStyle (tpAxis pal) 1.5)) + in [edgePath, arrowHeadPrim basePt apex u pal] + +-- | 矢じり寸法 (graphviz 較正: 長 10 × 底辺 7 = headWid*2)。 全 edge 描画で共有。 +dagHeadLen, dagHeadWid :: Double +dagHeadLen = 10.0 +dagHeadWid = 3.5 + +-- | 鏃 (塗り三角) primitive。 base = 底辺中心 (= 線の終端・曲線上)、 apex = 元終点 +-- (= ノード port = tip)、 u = tip 方向単位ベクトル。 ★ Phase 44.8。 +arrowHeadPrim :: Point -> Point -> (Double, Double) -> ThemePalette -> Primitive +arrowHeadPrim (Point bx by) apex (ux, uy) pal = + let (perpx, perpy) = (-uy, ux) + h1 = Point (bx + perpx * dagHeadWid) (by + perpy * dagHeadWid) + h2 = Point (bx - perpx * dagHeadWid) (by - perpy * dagHeadWid) + in PPath [ MoveTo apex, LineTo h1, LineTo h2, ClosePath ] + (FillStyle (tpAxis pal) 1.0) Nothing + +-- | 描画パス末尾の cubic セグメントを **終点側へ弧長 ~headLen 分 de Casteljau 分割**し、 +-- 線を曲線上の base 点で滑らかに止める (= 鏃が tip を担う)。 終点だけ差し替えると +-- 制御点据え置きで曲線が変形し base で折れるため、 正しく分割して曲線形状を保つ +-- (graphviz の arrow clip と同型)。 戻り = (分割後セグ列, base 点(曲線上), +-- apex(=元終点), 単位 tip 方向)。 ★ Phase 44.8。 +trimLastCubic + :: Double -> Point -> [PathSegment] + -> ([PathSegment], Point, Point, (Double, Double)) +trimLastCubic headLen p0 segs = case reverse segs of + (CurveTo c1 c2 e : restR) -> + let ini = reverse restR + segStart = if null ini then p0 else segEndOf (last ini) + cub = (segStart, c1, c2, e) + t = trimParamForLen headLen cub + unit m = let Point mx my = m; Point ex ey = e + dx = ex - mx; dy = ey - my + l = sqrt (dx * dx + dy * dy) + in if l > 1e-9 then (dx / l, dy / l) else (0, 1) + in if t <= 1e-6 + then (ini, segStart, e, unit segStart) -- 末尾セグ全体が鏃より短い + else let (_, a, d, m) = splitCubicLeft t cub + in (ini ++ [CurveTo a d m], m, e, unit m) + _ -> (segs, p0, p0, (0, 1)) + where + segEndOf (LineTo q) = q + segEndOf (CurveTo _ _ q) = q + segEndOf (MoveTo q) = q + segEndOf ClosePath = p0 + +-- | cubic (p0,c1,c2,p3) を媒介変数 t で de Casteljau 分割し、 左半分の制御点を返す。 +splitCubicLeft :: Double -> (Point, Point, Point, Point) -> (Point, Point, Point, Point) +splitCubicLeft t (p0, c1, c2, p3) = + let lp (Point ax ay) (Point bx by) = Point (ax + (bx - ax) * t) (ay + (by - ay) * t) + a = lp p0 c1; b = lp c1 c2; c = lp c2 p3 + d = lp a b; e = lp b c + m = lp d e + in (p0, a, d, m) + +-- | cubic 上の点 B(t)。 +cubicAt :: Double -> (Point, Point, Point, Point) -> Point +cubicAt t cub = let (_, _, _, m) = splitCubicLeft t cub in m + +-- | 終点 p3 から弧長 ~target だけ手前の媒介変数 t を二分法で求める (chord 近似)。 +-- |B(t) - p3| は t→1 で 0 へ単調減少。 末尾セグ全長が target 未満なら 0 を返す。 +trimParamForLen :: Double -> (Point, Point, Point, Point) -> Double +trimParamForLen target cub@(_, _, _, p3) = + let dist t = let Point mx my = cubicAt t cub; Point px py = p3 + in sqrt ((px - mx) ** 2 + (py - my) ** 2) + go lo hi 0 = (lo + hi) / 2 + go lo hi k = let mid = (lo + hi) / 2 + in if dist mid > target then go mid hi (k - 1 :: Int) + else go lo mid (k - 1) + in if dist 0 <= target then 0 else go 0 1 32 + +-- | R3 (Step6 P7a): graphviz Proutespline の制御点列 ([始点, c1, c2, 終点, c1, c2, ...]) +-- を cubic Bézier path + 矢印で描画。 矢印方向は最終 segment の (c2→終点) 接線。 +cubicEdgeFromControls :: [Point] -> ThemePalette -> [Primitive] +cubicEdgeFromControls ctrl pal + | length ctrl < 4 = case ctrl of + [a, b] -> arrowEdgeFromPorts a b pal + _ -> [] + | otherwise = + let p0 = head ctrl + segs = chunk3 (tail ctrl) + curveSegs = [ CurveTo c1 c2 e | [c1, c2, e] <- segs ] + -- ★ Phase 44.8: 末尾 cubic を de Casteljau で弧長 ~headLen 分手前へ分割し + -- 線を曲線上の base 点で止める (折れ無し)。 tip は鏃が担う。 + (trimmed, basePt, apex, u) = trimLastCubic dagHeadLen p0 curveSegs + edgePath = PPath (MoveTo p0 : trimmed) + (FillStyle "#000000" 0) + (Just (StrokeStyle (tpAxis pal) 1.5)) + in [edgePath, arrowHeadPrim basePt apex u pal] + where + chunk3 (a : b : c : rest) = [a, b, c] : chunk3 rest + chunk3 _ = [] + +-- | Corner-cutting smoothing: 内部点 P[i] (i ∉ {0, n-1}) を +-- (P[i-1] + 2 P[i] + P[i+1]) / 4 で置換し 'k' 回繰り返す。 端点は不変。 +-- 'splineEdgeFromPorts' で dummy 経由制御点列の「棚」 を緩和するために使う。 +smoothInterior :: Int -> [Point] -> [Point] +smoothInterior k ps + | k <= 0 || length ps < 3 = ps + | otherwise = smoothInterior (k - 1) (onePass ps) + where + avg3 (Point ax ay) (Point bx by) (Point cx cy) = + Point ((ax + 2 * bx + cx) / 4) ((ay + 2 * by + cy) / 4) + onePass xs = + let middle = zipWith3 avg3 xs (drop 1 xs) (drop 2 xs) + in head xs : middle ++ [last xs] + +-- | Catmull-Rom control 列 → cubic Bezier segments。 端点は ghost (= 自分自身) +-- で扱う (= natural spline、 端で直線に近づく)。 +-- +-- ★ Phase 39 (2026-06-24): 制御点オフセットを **セグメント長でクランプ** する。 +-- knot 間隔が極端に不均一だと (= 例: 迂回 waypoint 不足で長 edge が 3 点になる場合)、 +-- tangent (b-prev)/6 が遠い prev に引っ張られ制御点が segment 外へ大きく overshoot し、 +-- 末端に「フック」が出ていた。 均等間隔での標準オフセットは segLen/3 ゆえ上限 0.5·segLen +-- なら通常曲線は不変、 過大時のみ抑制される (graphviz が box 内拘束で防ぐのと同趣旨)。 +catmullRomToBezier :: [Point] -> [PathSegment] +catmullRomToBezier ps = go (0 :: Int) ps + where + n = length ps + at i = ps !! i + -- ベクトル (dx,dy) を最大長 maxL にクランプ。 + clampLen maxL dx dy = + let l = sqrt (dx * dx + dy * dy) + in if l > maxL && l > 1e-12 then (dx * maxL / l, dy * maxL / l) else (dx, dy) + go _ [_] = [] + go _ [] = [] + go i (a : b : rest) = + let prev = if i == 0 then a else at (i - 1) + next = case rest of + (c : _) -> c + [] -> b + Point ax ay = a + Point bx by = b + Point px py = prev + Point qx qy = next + segLen = sqrt ((bx - ax) ^ (2 :: Int) + (by - ay) ^ (2 :: Int)) + maxOff = 0.5 * segLen + (o1x, o1y) = clampLen maxOff ((bx - px) / 6) ((by - py) / 6) + (o2x, o2y) = clampLen maxOff ((qx - ax) / 6) ((qy - ay) / 6) + c1 = Point (ax + o1x) (ay + o1y) + c2 = Point (bx - o2x) (by - o2y) + in CurveTo c1 c2 b : go (i + 1) (b : rest) + where + _unused = n -- silence unused if any + +-- | Phase 11 A6: geom_text / geom_label。 各 (x,y) 点に lyLabel 列の文字を描く。 +-- withBox=True (= geom_label) は文字の背後に角丸風の矩形を敷く。 色は static color +-- 指定 (= 固定色 color) があればそれ、 無ければ tpText。 font サイズは lySize (default 11)。 +renderText :: Resolver -> Layout -> ThemePalette -> Layer -> Bool -> [Primitive] +renderText r layout pal ly withBox = + let xs = V.toList (vecOr (lyEncX ly) r) + ys = V.toList (vecOr (lyEncY ly) r) + labs = case getLast (lyLabel ly) of + Just cr -> case resolveCol r cr of + Just (TxtData v) -> V.toList v + Just (NumData v) -> V.toList (V.map numToText v) + Nothing -> [] + Nothing -> [] + n = minimum [length xs, length ys, length labs] + -- 固定色 (color) 明示時のみ採用 (= geom_text(color=))、 それ以外は theme text 色。 + txtCol = case getLast (lyColor ly) of + Just (ColorStatic c) -> c + _ -> tpText pal + fontSz = doubleOr (lySize ly) 11 + coord = lpCoord layout + ts = TextStyle txtCol fontSz "sans-serif" AnchorMiddle 0 "normal" False + mkOne i = + let Point px py = projectPoint coord layout (xs !! i) (ys !! i) + lab = labs !! i + -- geom_label の背景矩形 (文字幅を 0.6×fontSize×文字数 で概算 + padding)。 + boxW = fontSz * 0.6 * fromIntegral (T.length lab) + 8 + boxH = fontSz + 6 + box = [ PRect (Rect (px - boxW / 2) (py - boxH / 2) boxW boxH) + (FillStyle (tpBackground pal) 0.9) + (Just (StrokeStyle (tpAxis pal) 0.5)) ] + -- 文字 baseline を矩形中央に合わせる (= py + fontSize*0.35)。 + textP = [ PText (Point px (py + fontSz * 0.35)) lab ts ] + in (if withBox then box else []) <> textP + in if n <= 0 then [] else concatMap mkOne [0 .. n - 1] + +-- | Phase 26 §E-6: HBM ModelGraph DAG 描画。 +-- node 位置 (dnX, dnY) は domain 座標として scale 適用、 node = PCircle + +-- PText、 edge = PLine。 layout 計算は外部 (= hanalyze / frontend) で。 +-- | embedded DAG (= MDAG レイヤを他 geom と同一軸に重ねた退化ケース)。 +-- ★ Phase 44.2: 旧実装は node 座標を [0,1] に潰す `nrm` shim + 軸 scale で +-- 直線のみ (矢印/plate 箱/迂回 routing 無し) を描く間に合わせだった。 本格 +-- 'renderDAGStandalone' (矢印・plate・routing・fit 完備) が landing 済のため、 +-- shim を撤去して standalone を panel 矩形 ('lpPlotArea') 上で呼ぶ委譲に統一する。 +-- これで mixed ケースでも DAG 専用経路 (renderDAGOnly) と同一品質で描画される。 +renderDAG :: Layout -> ThemePalette -> Layer -> [Primitive] +renderDAG layout = renderDAGStandalone (lpPlotArea layout) + +-- | Phase 26 §C-2 #13: parallel coordinates。 lyHover で渡された N 列を +-- 等間隔の縦軸として並べ、 row 毎に折線を引く。 placeholder 実装: data の +-- 各列を [0, 1] に正規化、 polyline で描画。 +renderParallel :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderParallel r layout pal ly = + let cols = lyHover ly + nCols = length cols + a = lpPlotArea layout + vecs = [V.toList (vecOr (Last (Just c)) r) | c <- cols] + n = case vecs of + [] -> 0 + _ -> minimum (map length vecs) + in if nCols < 2 || n == 0 then [] else + let -- 各 column の min/max + extents = [ (minimum xs, maximum xs) | xs <- vecs, not (null xs) ] + norm vx (lo, hi) = if hi <= lo then 0.5 else (vx - lo) / (hi - lo) + -- 軸 x 座標 + axisX i = rX a + rW a * fromIntegral i / fromIntegral (nCols - 1) + -- 軸名 (inline 列は名前を持たないので placeholder のときは空 = ラベル無し) + labelTextOf i = let nm = colRefName (cols !! i) + in if nm == "<inline-num>" || nm == "<inline-txt>" then "" else nm + anyLabel = any (\i -> labelTextOf i /= "") [0 .. nCols - 1] + -- ラベルがあるときだけ上端に帯を確保 (= タイトルと被らないよう領域内に置く)。 + -- ラベルが無ければ topPad=0 で詰める。 + topPad = if anyLabel then 16 else 0 + yTop = rY a + topPad + -- 値 → 画面 y (反転: 0 が下、 1 が上)。 データは yTop..下端 に収める。 + valY ny = yTop + (rH a - topPad) * (1 - ny) + -- 軸を縦線で描画 (データ域 yTop..下端) + axisLines = [ PLine (Point (axisX i) yTop) (Point (axisX i) (rY a + rH a)) + (solid (tpAxis pal) 1.0) + | i <- [0 .. nCols - 1] ] + -- 各 row の折線 + rowSegs row = + let pts = [ Point (axisX i) (valY (norm (vecs !! i !! row) (extents !! i))) + | i <- [0 .. nCols - 1] ] + pairs = zip pts (drop 1 pts) + c = tpDefault pal + in [ PLine pa pb (solid c 0.6) | (pa, pb) <- pairs ] + -- col label (領域内上端・空ラベルは描かない) + labels_ = + [ PText (Point (axisX i) (yTop - 4)) + (labelTextOf i) + (mkFontTS Nothing pal TickF AnchorMiddle 0) + | i <- [0 .. nCols - 1], labelTextOf i /= "" ] + in axisLines <> concatMap rowSegs [0 .. n - 1] <> labels_ + +-- | Pie chart (Phase 6+ C-2): lyEncX = categorical labels、 lyEncY = values。 +-- plotArea 中央に円描画、 各 slice は categorical palette で着色。 軸 / tick 非表示前提。 +renderPie :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderPie r layout thePal ly = + let area = lpPlotArea layout + values = V.toList (vecOr (lyEncY ly) r) + labels = catLabelsOf r ly + total = sum values + cx = rX area + rW area / 2 + cy = rY area + rH area / 2 + radius = min (rW area) (rH area) * 0.4 + pal = lpCategoricalPalette layout + a = doubleOr (lyAlpha ly) 0.9 + tsLabel = mkFontTS Nothing thePal TickF AnchorMiddle 0 + -- 各 slice を path (= moveTo center + arc approximation by 60 line segs + close) + mkSlice i (v, lbl) startA = + let endA = startA + 2 * pi * v / max total 1 + segments = 60 :: Int + sample k = let t = startA + (endA - startA) * fromIntegral k / fromIntegral segments + in Point (cx + radius * cos t) (cy + radius * sin t) + color = pal !! (i `mod` length pal) + slicePath = PPath + ( MoveTo (Point cx cy) + : LineTo (sample 0) + : [ LineTo (sample k) | k <- [1 .. segments] ] + ++ [ClosePath] + ) + (FillStyle color a) (Just (StrokeStyle "#ffffff" 1.0)) + -- Phase 8 B1: 扇の重心方向 (= 半径 0.7) に「項目名 (n%)」 ラベル (PS と同型) + midA = (startA + endA) / 2 + lx = cx + radius * 0.7 * cos midA + ly_ = cy + radius * 0.7 * sin midA + pct = if total > 0 then v / total * 100 else 0 + lblTxt = if T.null lbl then "" else lbl <> " (" <> numToText pct <> "%)" + labelPrim = [ PText (Point lx ly_) lblTxt tsLabel | not (T.null lblTxt) ] + in slicePath : labelPrim + n = length values + paddedLabels = labels ++ replicate (n - length labels) "" + starts = scanl (\acc v -> acc + 2 * pi * v / max total 1) (-pi / 2) values + in concat [ mkSlice i (v, lbl) s + | (i, (v, lbl, s)) <- zip [0..] (zip3 values paddedLabels starts) ] + +-- | Waterfall chart (Phase 6+ C-2): lyEncX = categorical labels、 lyEncY = delta values。 +-- 各 bar は前 bar の累積値から start、 + delta だけ移動。 +-- 正 = positive 色、 負 = negative 色。 +renderWaterfall :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderWaterfall r layout pal ly = + let xCats = lpXCategoryLabels layout + isCat = not (null xCats) + deltas = V.toList (vecOr (lyEncY ly) r) + n = length deltas + -- 累積位置 (= 前 bar 終了 = 次 bar 開始) + cumulative = scanl (+) 0 deltas + -- bar 配置: x position は 0..n-1 + a = doubleOr (lyAlpha ly) 0.85 + posC = "#16a34a" -- 緑 (positive) + negC = "#dc2626" -- 赤 (negative) + sx = scaleApply (lpXScale layout) + sy = scaleApply (lpYScale layout) + area = lpPlotArea layout + -- Phase 8 A2 Step4c: bar 幅 = 1 スロット (unit = sx 1 - sx 0) の 0.6。 旧 rW/n (Total + -- スロットを数えず個数ベース) を unit ベースに。 PS renderWaterfallLayer と同値に統一 + -- (従来 HS=rW/n*0.6 / PS=rW/(n+1)*0.7 で不一致だった)。 ±0.6 expansion にも追従。 + coord = flipOnly (lpCoord layout) -- A7-c: waterfall は polar 非対象 + bw = catUnitPx coord layout * 0.6 -- Phase 10 A4-fix: flip では縦スロット幅 + mkBar i d = + let xp = if isCat then fromIntegral i else fromIntegral i + yStart = cumulative !! i + yEnd = yStart + d + c = if d >= 0 then posC else negC + -- Phase 10 A4: data x=xp、 yStart..yEnd を data 値で、 厚み bw px (flip 追従)。 + in PRect (projectBarRect coord layout xp yStart yEnd bw) + (FillStyle c a) (Just (StrokeStyle c 1.0)) + -- Phase 7 A6: 末尾に合計 (Total) バー (= base 0 から累積到達値)。 デフォルト出す + -- (フラグ切替の Spec API は後追い)。 中立灰で増減バーと区別。 x = n (Layout で + -- category を "Total" 1 つ拡張済み)。 + totalC = "#6b7280" + total = sum deltas + totalBar = + let xp = fromIntegral n + in PRect (projectBarRect coord layout xp 0 total bw) + (FillStyle totalC a) (Just (StrokeStyle totalC 1.0)) + in [ mkBar i d | (i, d) <- zip [0..] deltas ] ++ [totalBar] diff --git a/src/Graphics/Hgg/Render/Statistical.hs b/src/Graphics/Hgg/Render/Statistical.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Render/Statistical.hs @@ -0,0 +1,589 @@ +-- | +-- Module : Graphics.Hgg.Render.Statistical +-- Description : 統計 mark (qq/ecdf/rangebar/heatmap/contour/regression/density/statline) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +module Graphics.Hgg.Render.Statistical where + +import Graphics.Hgg.Layout (numToText, + Layout (..), Rect (..), Scale (..), + ViewportSize (..), computeLayout, + ggAxTextMar, ggAxTitleMar, ggHalfLine, + ggTickLen, niceTicks, scaleApply, + Track (..), solveTracks, + needsLegend, effectiveLegendPos, + coordOf, isPolar, polarCenter, polarPoint, + domFrac, projectXY, projectRectData, + projectBarRect, catUnitPx, resolutionOf, + AxisPlacement (..), + coordXAxisPlacement, coordYAxisPlacement, + coordXGridIsVertical) +import Graphics.Hgg.Layout.RangeOf (qqPoints, ecdfPoints) -- Phase 11 A6-2/A6-4 +import Graphics.Hgg.Math.Griddata (gridOf, marchingSegments, innerLevels) -- Phase 24 A4/A5 +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Time.Format as Data.Time.Format +import Graphics.Hgg.Spec (Annotation (..), AxisFormat (..), + ColData (..), ColRef, + ColorEnc (..), ConnectSpec (..), + DAGEdge (..), DAGLayoutAlgorithm (..), + DAGNode (..), DAGNodeKind (..), + DAGPlate (..), DAGSpec (..), Layer (..), + LegendPosition (..), LegendSpec (..), + Inset (..), MarginalSpec (..), MarkKind (..), + MarkShape (..), ShapeMapEntry (..), + LineType (..), lineTypeDash, lineTypeForIndex, + ReferenceLine (..), Resolver, + Position (..), Coord (..), + FacetScales (..), freeScaleX, freeScaleY, + FacetSpace (..), freeSpaceX, freeSpaceY, + ThemeOverride (..), + VisualSpec (..), YAxisSide (..), axisFormatOf, + axisRotateOf, resolveAxisAngle, axisShowTicksOf, + axShowGrid, + FontSpec (..), orderedCats, histBinning, + HexCell (..), hexbinLayerCells, + colRefName, resolveCol, resolveNum) +import Data.Maybe (mapMaybe, isJust) +import Data.List (sortOn, foldl') +import qualified Data.Map.Strict as Map +import Data.List (dropWhile, elemIndex, groupBy, nub, + sort, takeWhile) +import qualified Graphics.Hgg.Spec +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Numeric (showEFloat, showFFloat) + +import Graphics.Hgg.Primitive +import Graphics.Hgg.Render.Common + + +-- | Phase 11 A6-2: Q-Q plot (= ggplot geom_qq)。 sample (encY) をソートして +-- order statistic を y、 理論正規分位点 Φ⁻¹((i-0.5)/n) を x に取り点を描く。 +-- 理論分位点は 'qqPoints' (RangeOf) を単一情報源として共有 (= x range と一致)。 +-- 参照線 (qq line) は ggplot でも別 geom (geom_qq_line) なので本 geom は点のみ。 +renderQQ :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderQQ r layout pal ly = + let sample = V.toList (vecOr (lyEncY ly) r) + pts = qqPoints sample -- [(theoretical x, ordered y)] + c = staticColorOr ly (tpDefault pal) + a = doubleOr (lyAlpha ly) 0.85 + ptSz = doubleOr (lySize ly) (mmPt 1.5) + coord = lpCoord layout + in [ PCircle (projectPoint coord layout xt y) (ptSz / 2) + (FillStyle c a) (Just (StrokeStyle c 1.0)) Nothing + | (xt, y) <- pts ] + +-- | Phase 11 A6-4: ECDF (= ggplot stat_ecdf)。 sample (encX) をソートして右連続の +-- 階段 F(x)=#(≤x)/n を描く。 角点列 'ecdfPoints' を単一情報源とし連続線で結ぶ。 +renderEcdf :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderEcdf r layout pal ly = + let sample = V.toList (vecOr (lyEncX ly) r) + verts = ecdfPoints sample + c = staticColorOr ly (tpDefault pal) + w = doubleOr (lyStroke ly) (mmPt 0.5) + dash = maybe [] lineTypeDash (getLast (lyLinetype ly)) + ls = LineStyle c w dash + coord = lpCoord layout + pp = projectPoint coord layout + mkSeg ((x1,y1),(x2,y2)) = PLine (pp x1 y1) (pp x2 y2) ls + in case verts of + [] -> [] + _ -> map mkSeg (zip verts (tail verts)) + +-- | Phase 11 A6-4b: 区間 geom (linerange / pointrange / crossbar)。 各 (x,y) に縦区間 +-- y±errorY を描く。 withPoint=中心点を足す (pointrange)、 asBox=幅付き箱+中央線 (crossbar)。 +-- 箱の半幅は px 固定 (= error bar cap と同じ px 空間、 連続 x でも安定)。 +renderRangeBar :: Resolver -> Layout -> ThemePalette -> Layer -> Bool -> Bool -> [Primitive] +renderRangeBar r layout pal ly withPoint asBox = + let xs = V.toList (vecOr (lyEncX ly) r) + ys = V.toList (vecOr (lyEncY ly) r) + es = V.toList (vecOr (lyErrorY ly) r) + n = minimum [length xs, length ys, length es] + c = staticColorOr ly (tpDefault pal) + w = doubleOr (lyStroke ly) (mmPt 0.5) + ptSz = doubleOr (lySize ly) (mmPt 1.5) + ls = solid c w + coord = lpCoord layout + pp = projectPoint coord layout + -- ★ Phase 41: crossbar 箱の半幅を ggplot 同様データ単位化 (width = markWidth × resolution)。 + -- boxplot bw と同型 (catUnitPx × 幅係数)・resolution で連続 x にも追従。 旧 px 固定 10 を置換。 + capWFactor = doubleOr (lyMarkWidth ly) 0.9 -- ggplot geom_crossbar 既定 width = 0.9 + finite v = not (isNaN v) && not (isInfinite v) + resX = resolutionOf (filter finite xs) + halfW = 0.5 * capWFactor * resX * catUnitPx coord layout + mkOne i = + let x = xs !! i; y = ys !! i; e = es !! i + Point pcx pcyLo = pp x (y - e) + Point _ pcyHi = pp x (y + e) + Point pmx pmy = pp x y + in if asBox + then -- crossbar: 箱 (px 幅) + 中央水平線 + [ PRect (Rect (pmx - halfW) (min pcyLo pcyHi) (2 * halfW) (abs (pcyHi - pcyLo))) + (FillStyle c 0.15) (Just (StrokeStyle c w)) + , PLine (Point (pmx - halfW) pmy) (Point (pmx + halfW) pmy) ls ] + else -- linerange: 縦線。 pointrange は中心点を追加 + PLine (Point pcx pcyLo) (Point pcx pcyHi) ls + : (if withPoint + then [ PCircle (Point pmx pmy) (ptSz / 2) + (FillStyle c 1.0) (Just (StrokeStyle c 1.0)) Nothing ] + else []) + in if n <= 0 then [] else concatMap mkOne [0 .. n - 1] + +-- | Phase 11 A6-3: heatmap (= ggplot geom_tile)。 x/y はカテゴリ列、 value (= lyColor の +-- ColorByContinuous) を各 (x,y) セルの連続色 (Viridis) に写して矩形で塗る。 セルは data 空間で +-- カテゴリ中心 ±0.5 の 1 単位四方 (= projectRectData で flip も自動追従)。 cell 間は背景色の +-- 細い枠で区切る (= grid 状)。 同 (x,y) が重複する行は後勝ち (= 描画順で上書き)。 +renderHeatmap :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderHeatmap r layout pal ly = + let toLabels mcr = case getLast mcr of + Just cr -> case resolveCol r cr of + Just (TxtData v) -> V.toList v + Just (NumData v) -> V.toList (V.map numToText v) + Nothing -> [] + Nothing -> [] + xs = toLabels (lyEncX ly) + ys = toLabels (lyEncY ly) + n = min (length xs) (length ys) + cs = colorVector r layout pal ly n -- ColorByContinuous → Viridis 連続色 + xLabels = lpXCategoryLabels layout + yLabels = lpYCategoryLabels layout + coord = lpCoord layout + a = doubleOr (lyAlpha ly) 1.0 + mkCell i = do + xi <- elemIndex (xs !! i) xLabels + yi <- elemIndex (ys !! i) yLabels + let c = cs V.! i + xd = fromIntegral xi; yd = fromIntegral yi + rc = projectRectData coord layout (xd - 0.5) (xd + 0.5) (yd - 0.5) (yd + 0.5) + Just (PRect rc (FillStyle c a) (Just (StrokeStyle (tpBackground pal) 1.0))) + in if n <= 0 then [] else mapMaybe mkCell [0 .. n - 1] + +-- | Phase 28 (Ch10 EDA): geom_count (= ggplot @geom_count()@ / @stat_sum@)。 +-- x/y はともにカテゴリ列。 各 (x,y) セルの観測件数を集計し、 cell 中心に +-- **面積 ∝ 件数** (= 半径 ∝ √件数) の点を打つ。 最大件数のセルが半径 maxR (px)、 +-- 件数 0 のセルは描かない。 maxR は lySize で上書き可 (既定 18 → 半径 9)。 +-- heatmap と同じカテゴリ軸 (lpX/YCategoryLabels) を用いるので両軸自動でカテゴリ化。 +renderCount :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderCount r layout pal ly = + let toLabels mcr = case getLast mcr of + Just cr -> case resolveCol r cr of + Just (TxtData v) -> V.toList v + Just (NumData v) -> V.toList (V.map numToText v) + Nothing -> [] + Nothing -> [] + xs = toLabels (lyEncX ly) + ys = toLabels (lyEncY ly) + n = min (length xs) (length ys) + xLabels = lpXCategoryLabels layout + yLabels = lpYCategoryLabels layout + coord = lpCoord layout + c = staticColorOr ly (tpDefault pal) + a = doubleOr (lyAlpha ly) 0.85 + maxR = doubleOr (lySize ly) (mmPt 4.5) / 2 -- 最大件数セルの半径 (既定 4.5mm 径) + -- (xi, yi) セル → 件数 (カテゴリに無い水準は除外) + counts = Map.toList $ Map.fromListWith (+) + [ ((xi, yi), 1 :: Int) + | i <- [0 .. n - 1] + , Just xi <- [elemIndex (xs !! i) xLabels] + , Just yi <- [elemIndex (ys !! i) yLabels] ] + maxC = maximum (1 : map snd counts) + mkPt ((xi, yi), cnt) = + let xd = fromIntegral xi; yd = fromIntegral yi + rad = maxR * sqrt (fromIntegral cnt / fromIntegral maxC) -- 面積 ∝ 件数 + in PCircle (projectPoint coord layout xd yd) rad + (FillStyle c a) (Just (StrokeStyle c 1.0)) Nothing + in if n <= 0 then [] else map mkPt counts + +-- | contour (= 等高線図、 marching squares)。 連続 x/y/z を正則格子に再標本化 +-- (inverse-distance weighting で散布点 → ノード) し、 z 範囲を等分した nLev 段の +-- **等値線**を marching squares で描く。 各等値線は z 値で連続色 (Viridis)。 +-- 旧実装は binned heatmap だったが、 「contour = 等高線」 の名に合わせ isolines に +-- (binned heatmap が要るなら 'bin2d')。 HS=PS 同式 (PS renderContour も同型)。 +-- +-- TODO (Phase 14 繰越、 2026-06-04): 等値線が**ガタつく**。 原因 = ① IDW は各データ点で +-- 尖る (cusp) ため格子データでも滑らかにならない、 ② 32×32 再標本化が粗い、 ③ marching +-- squares の線形補間で階段状になりやすい。 改善案 = (a) IDW を**双線形補間** (元が格子なら +-- 格子直引き) に置換、 (b) 再標本化後に軽い Gaussian smoothing、 (c) 解像度↑。 +-- HS/PS 両方に同じ修正が要る (parity 維持)。 +renderContour :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderContour r layout _pal ly = + case contourInput r ly of + Nothing -> [] + Just (xNodes, yNodes, gridV, zmin, zmax) -> + let levels = contourLevelsFor ly zmin zmax + coord = lpCoord layout + pp = projectPoint coord layout + gridL = map V.toList (V.toList gridV) -- 共有核 (Griddata) は [[Double]] + levelColor lv = continuousColor (lpContinuousPalette layout) + (if zmax == zmin then 0.5 else (lv - zmin)/(zmax - zmin)) + drawLevel lv = + [ PLine (pp ax ay) (pp bx by) (solid (levelColor lv) 1.5) + | ((ax,ay),(bx,by)) <- marchingSegments xNodes yNodes gridL lv ] + in if zmax <= zmin then [] else concatMap drawLevel levels + +-- | Phase 24 A4: contour / filled contour の共通入力 — (x,y,z) triple を +-- 'gridOf' で格子化する。 ★規則 grid 入力 (計画格子・linspace 由来) は +-- **補間せず直入力** (旧実装は常に全点 IDW で 32x32 再標本化しており、 +-- 規則 grid でも等値線が歪む + 隅に偽輪郭が出るバグだった)。 +-- 散布入力のみ k 近傍 IDW で 32x32 へ。 格子の向きは grid!!j!!i (行 = y)。 +contourInput :: Resolver -> Layer + -> Maybe ([Double], [Double], V.Vector (V.Vector Double), Double, Double) +contourInput r ly = + let xs = V.toList (vecOr (lyEncX ly) r) + ys = V.toList (vecOr (lyEncY ly) r) + vs = case getLast (lyColor ly) of + Just (ColorByContinuous cr) -> maybe [] V.toList (resolveNum r cr) + _ -> [] + n = minimum [length xs, length ys, length vs] + in if n < 4 then Nothing + else + let triples = [ (xs !! i, ys !! i, vs !! i) | i <- [0 .. n - 1] ] + (xNodes, yNodes, grid) = gridOf 32 triples + gridV = V.fromList (map V.fromList grid) + allZ = concat grid + in Just (xNodes, yNodes, gridV, minimum allZ, maximum allZ) + +-- | Phase 24 A4: 等高線レベル。 明示 breaks ('contourBreaks') > 本数指定 +-- ('contourLevels'、 既定 8)。 既定は (zmin, zmax) の**内側等間隔** +-- (lv_k = zmin + (zmax-zmin)·k/(n+1)) — 端値ちょうどの退化等値線を避ける +-- (旧実装の 15%-95% クランプは廃止 = 端近くのレベルも出る)。 +contourLevelsFor :: Layer -> Double -> Double -> [Double] +contourLevelsFor ly zmin zmax = + case getLast (lyContourBreaks ly) of + Just bs -> bs + Nothing -> + innerLevels (max 1 (fromMaybe 8 (getLast (lyContourLevels ly)))) zmin zmax + +-- | Phase 24 A4: filled contour (等値帯の塗り)。 各セルを「最下帯の色で全塗り → +-- level 昇順に z >= lv の部分多角形を上塗り」 の累積方式で塗る (セル内は +-- marching squares と同じ線形補間の境界 = 'contour' の線と整合)。 +-- saddle セル (対角ケース) は頂点巡回順の単一多角形で近似 (v1 既知の限界)。 +renderContourFilled :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderContourFilled r layout _pal ly = + case contourInput r ly of + Nothing -> [] + Just (xNodes, yNodes, gridV, zmin, zmax) + | zmax <= zmin -> [] + | otherwise -> + let levels = contourLevelsFor ly zmin zmax + coord = lpCoord layout + pp = projectPoint coord layout + nx = length xNodes + ny = length yNodes + xAt i = xNodes !! i + yAt j = yNodes !! j + zAt i j = (gridV V.! j) V.! i + norm v = (v - zmin) / (zmax - zmin) + -- 帯色: level 列で区切った各帯の中央値の連続色 + fences = zmin : levels ++ [zmax] + bandCol k = continuousColor (lpContinuousPalette layout) + (norm ((fences !! k + fences !! (k+1)) / 2)) + -- セルの z >= lv 部分多角形: 角を巡回し、 含まれる角 + 辺の交点を拾う + polyAbove lv i j = + let cs = [ ((xAt i, yAt j), zAt i j) + , ((xAt (i+1), yAt j), zAt (i+1) j) + , ((xAt (i+1), yAt (j+1)), zAt (i+1) (j+1)) + , ((xAt i, yAt (j+1)), zAt i (j+1)) ] + seg ((p1, z1), (p2, z2)) + | z1 >= lv && z2 >= lv = [p2] + | z1 >= lv = [cross p1 z1 p2 z2] + | z2 >= lv = [cross p1 z1 p2 z2, p2] + | otherwise = [] + cross (ax, ay) za (bx, by) zb = + let t = if zb == za then 0.5 else (lv - za) / (zb - za) + in (ax + t*(bx-ax), ay + t*(by-ay)) + in concatMap seg (zip cs (drop 1 cs ++ [head cs])) + -- 塗りと同色の細 stroke = 隣接セル間の anti-alias 白筋 (seam) 埋め + fillPoly col pts = case map (uncurry pp) pts of + (p0 : rest@(_ : _ : _)) -> + [ PPath (MoveTo p0 : map LineTo rest ++ [ClosePath]) + (FillStyle col 1.0) + (Just (StrokeStyle col 0.6)) ] + _ -> [] + cellPrims i j = + let base = fillPoly (bandCol 0) + [ (xAt i, yAt j), (xAt (i+1), yAt j) + , (xAt (i+1), yAt (j+1)), (xAt i, yAt (j+1)) ] + ups = concat + [ fillPoly (bandCol k) (polyAbove lv i j) + | (k, lv) <- zip [1 ..] levels ] + in base ++ ups + in concat [ cellPrims i j | i <- [0 .. nx - 2], j <- [0 .. ny - 2] ] + +-- | binned heatmap (= ggplot geom_bin2d)。 連続 x/y/z を nBins×nBins の grid に +-- binning し、 各セルの z 平均を連続色 (Viridis) で塗る。 'renderContour' (等高線) の +-- 塗り版。 セルは生 data 範囲 [xLo,xHi]×[yLo,yHi] を等分し projectRectData で投影 +-- (flip 自動追従)。 空セルは描かない。 PS と同一式。 +renderBin2d :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderBin2d r layout _pal ly = + let xs = V.toList (vecOr (lyEncX ly) r) + ys = V.toList (vecOr (lyEncY ly) r) + -- z (ColorByContinuous) があればセル平均 (= stat_summary_2d)、 無ければ + -- セル**件数** (= ggplot geom_bin2d 既定の fill=count)。 + hasZ = case getLast (lyColor ly) of Just (ColorByContinuous _) -> True; _ -> False + vs = case getLast (lyColor ly) of + Just (ColorByContinuous cr) -> maybe [] V.toList (resolveNum r cr) + _ -> replicate (min (length xs) (length ys)) 0 + n = minimum [length xs, length ys, length vs] + in if n < 3 then [] + else + let triples = [ (xs !! i, ys !! i, vs !! i) | i <- [0 .. n - 1] ] + xLo = minimum [x | (x,_,_) <- triples]; xHi = maximum [x | (x,_,_) <- triples] + yLo = minimum [y | (_,y,_) <- triples]; yHi = maximum [y | (_,y,_) <- triples] + xSpan = xHi - xLo; ySpan = yHi - yLo + nBins = 12 :: Int + binOf lo sp p = max 0 (min (nBins - 1) + (floor ((p - lo) / sp * fromIntegral nBins))) + assigned = [ (binOf xLo xSpan x, binOf yLo ySpan y, v) | (x,y,v) <- triples ] + cellMean i j = let ms = [ v | (bx,by,v) <- assigned, bx == i, by == j ] + in if null ms then Nothing + else Just (if hasZ then sum ms / fromIntegral (length ms) + else fromIntegral (length ms)) -- count + cells = [ (i, j, cellMean i j) | i <- [0 .. nBins - 1], j <- [0 .. nBins - 1] ] + means = [ m | (_,_,Just m) <- cells ] + vMin = minimum means; vMax = maximum means + coord = lpCoord layout + drawCell (i, j, mm) = case mm of + Nothing -> [] + Just m -> + let xd0 = xLo + fromIntegral i * xSpan / fromIntegral nBins + xd1 = xLo + fromIntegral (i + 1) * xSpan / fromIntegral nBins + yd0 = yLo + fromIntegral j * ySpan / fromIntegral nBins + yd1 = yLo + fromIntegral (j + 1) * ySpan / fromIntegral nBins + t = if vMax == vMin then 0.5 else (m - vMin) / (vMax - vMin) + col = continuousColor (lpContinuousPalette layout) (max 0 (min 1 t)) + rc = projectRectData coord layout xd0 xd1 yd0 yd1 + in [ PRect rc (FillStyle col 1.0) (Just (StrokeStyle "#ffffff" 0.3)) ] + in if null means then [] else concatMap drawCell cells + +-- | geom_tile / geom_raster 相当 (Phase 60)。 __1 行 = 1 セル__。 連続 x/y をセル中心とし、 +-- fill (colorBy = 'ColorByCol' 離散 / 'ColorByContinuous' 連続) の色で矩形をベタ塗りする。 +-- bin2d と違い**再ビニングしない** (事前計算済みグリッドをそのまま塗る)。 セル幅/高さは +-- sorted unique x/y の隣接差分の最小 = 格子間隔から自動 (ggplot @resolution()@ 相当・隙間なし)。 +-- 決定境界の res×res グリッド塗り (縞解消) が主用途。 色/凡例は 'colorVector' + color-enc 駆動 +-- guide が自動処理 (categorical なら離散パレット + 離散凡例)。 枠線なし = seamless。 +renderTile :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderTile r layout pal ly = + let xs = V.toList (vecOr (lyEncX ly) r) + ys = V.toList (vecOr (lyEncY ly) r) + n = min (length xs) (length ys) + cs = colorVector r layout pal ly n -- ColorByCol=離散 / ColorByContinuous=連続 両対応 + coord = lpCoord layout + a = doubleOr (lyAlpha ly) 1.0 + dx = gridStep xs + dy = gridStep ys + mkCell i = + let x = xs !! i; y = ys !! i + c = cs V.! i + rc = projectRectData coord layout (x - dx/2) (x + dx/2) (y - dy/2) (y + dy/2) + in PRect rc (FillStyle c a) Nothing -- 隙間なし = 枠線なし (seamless) + in if n <= 0 then [] else map mkCell [0 .. n - 1] + +-- | sorted unique 値の隣接差分の最小を格子間隔とする (ggplot @resolution()@)。 +-- 単一値 / 差分無しは 1.0 fallback。 +gridStep :: [Double] -> Double +gridStep vs = + let us = map head (groupBy (==) (sort vs)) -- sorted unique + diffs = [ b - x | (x, b) <- zip us (drop 1 us), b > x ] + in if null diffs then 1.0 else minimum diffs + +-- | Phase 40: hexbin (= ggplot @geom_hex@ / matplotlib @hexbin@)。 連続 x/y を六角格子に +-- binning し、 各セルの**件数**を連続色 (Viridis) の pointy-top 六角形で塗る。 セル分割数は +-- 'lyBinCount' (既定 30)。 binning は純関数 'hexbinCells' (d3-hexbin)、 描画はその 6 頂点を +-- 'projectPoint' で screen へ投影して 'PPath' で塗る。 colorbar は count guide (別途) が出す。 +renderHexbin :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderHexbin r layout _pal ly = + case hexbinLayerCells r ly of + [] -> [] + cells -> + let counts = map hexCount cells + vMin = fromIntegral (minimum counts) :: Double + vMax = fromIntegral (maximum counts) :: Double + coord = lpCoord layout + pp = projectPoint coord layout + drawCell c = + let t = if vMax == vMin then 1.0 + else (fromIntegral (hexCount c) - vMin) / (vMax - vMin) + col = continuousColor (lpContinuousPalette layout) (max 0 (min 1 t)) + in case map (uncurry pp) (hexVerts c) of + (p0 : rest@(_ : _ : _)) -> + [ PPath (MoveTo p0 : map LineTo rest ++ [ClosePath]) + (FillStyle col 1.0) (Just (StrokeStyle col 0.5)) ] + _ -> [] + in concatMap drawCell cells + +renderStatLine :: Resolver -> Layout -> ThemePalette -> Layer + -> ([Double] -> Double) -> [Primitive] +renderStatLine r layout pal ly statF = + let vs = V.toList (vecOr (lyEncY ly) r) + in if null vs then [] else + let v = statF vs + sy = scaleApply (lpYScale layout) + a = lpPlotArea layout + c = staticColorOr ly (tpAxis pal) + w = doubleOr (lyStroke ly) (mmPt 0.5) + in [ PLine (Point (rX a) (sy v)) (Point (rX a + rW a) (sy v)) + (solid c w) ] + +-- | Density plot (= Gaussian KDE 簡易版)。 lyEncX = 値ベクター。 +-- bandwidth は Silverman の経験則、 100 grid 点で評価して PPath で曲線描画。 +-- +-- color/fill aesthetic (= 'ColorByCol') があるときは群ごとに分割し、 各群を +-- 独立に正規化した KDE 曲線を群色で重ねて描く (= ggplot @geom_density(aes(color=g))@)。 +-- 各群の peak が異なるので y domain も群対応 (RangeOf.densityYRange と整合)。 +renderDensity :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderDensity r layout pal ly = + let xsFull = V.toList (vecOrFull (lyEncX ly) r) -- 長さ保持 (群キーと整列するため) + xs = filter (not . isNaN) xsFull -- 単群 KDE 用 (NaN = Maybe の Nothing を除去) + w = doubleOr (lyStroke ly) (mmPt 0.5) + isNorm = getLast (lyDensityNorm ly) == Just True + -- Phase 28: density 曲線下の塗り (= ggplot geom_density(aes(fill=)))。 alpha と併用。 + doFill = getLast (lyDensityFill ly) == Just True + fillA = doubleOr (lyAlpha ly) 0.5 + coord = lpCoord layout + nGrid = 100 :: Int + -- x grid は data 範囲だけでなく x axis 全体 (= padded range) を評価 + -- (= padded 領域でも density が tail 値で描画される。 matplotlib seaborn 流) + xDomLo = lsDomainLo (lpXScale layout) + xDomHi = lsDomainHi (lpXScale layout) + step = (xDomHi - xDomLo) / fromIntegral (nGrid - 1) + gridX = [ xDomLo + fromIntegral i * step | i <- [0 .. nGrid - 1] ] + -- 1 群 (= 1 系列) の Silverman KDE を gridX で評価。 + kdeYs gxs = + let n = length gxs + mu = sum gxs / fromIntegral n + sd = sqrt (sum [(x - mu)^(2 :: Int) | x <- gxs] / fromIntegral (n - 1)) + bw = max (1.06 * sd * fromIntegral n ** (-0.2 :: Double)) 1e-9 + kde x = sum [ exp (negate ((x - xi) ** 2) / (2 * bw ** 2)) + | xi <- gxs ] / (fromIntegral n * bw * sqrt (2 * pi)) + in map kde gridX + -- projectPoint 経由の曲線 PPath (通常 density)。 + curveOf col gxs + | length gxs < 2 = [] + | otherwise = + let pts = zipWith (\x y -> projectPoint coord layout x y) gridX (kdeYs gxs) + segs = case pts of { [] -> []; (p:rest) -> MoveTo p : map LineTo rest } + -- Phase 28: doFill なら曲線下を col×fillA で塗る (= 曲線 → 右端 base → + -- 左端 base へ閉じた polygon)。 既定は ggplot 同様 fill=NA = 線のみ。 + fillPrim + | not doFill = [] + | otherwise = + let baseR = projectPoint coord layout (last gridX) 0 + baseL = projectPoint coord layout (head gridX) 0 + fsegs = segs ++ [LineTo baseR, LineTo baseL] + in [ PPath fsegs (FillStyle col fillA) Nothing ] + in fillPrim ++ [ PPath segs (FillStyle "" 0) (Just (StrokeStyle col w)) ] + -- 群別 density 判定: lyColor = ColorByCol で群キーが xs と整列。 + -- isNorm (= pairs 対角) は値軸ゆえ群分割の対象外 (従来通り 1 本)。 + grouped = case getLast (lyColor ly) of + Just (ColorByCol gcr) | not isNorm -> + case groupKeysOf r gcr of + -- ★ 群キーは値列と同じ全長で整列。 NaN 値の行を両方から落として対応を保つ + -- (vecOr で先に縮めると length 不一致で群分割が無効化していた)。 + Just ks | length ks == length xsFull -> + Just (unzip [ (k, x) | (k, x) <- zip ks xsFull, not (isNaN x) ]) + _ -> Nothing + _ -> Nothing + in case grouped of + -- === 群別: colorVector と同じ規則で群色を割当て、 群ごとに曲線を重ねる === + Just (ks, gxsVals) -> + let distinct = let cats = lyColorCats ly in if null cats then orderedCats ks else cats + palArr = lpCategoricalPalette layout + manual = lpColorManual layout + colorOf t = case lookup t manual of + Just cc -> cc + Nothing -> case elemIndex t distinct of + Just i -> palArr !! (i `mod` length palArr) + Nothing -> tpDefault pal + grps = orderedGroups ks gxsVals -- [(key,[x])] 初出順 + -- distinct (= 凡例) 順で描画し色を一致させる。 + ordered = [ (g, vs) | g <- distinct, Just vs <- [lookup g grps] ] + in concat [ curveOf (colorOf g) gxs | (g, gxs) <- ordered ] + -- === 非 group / pairs 対角: 従来どおり全データ 1 本 === + Nothing -> + let c = staticColorOr ly (tpDefault pal) + in if length xs < 2 then [] else + let ys = kdeYs xs + sx = scaleApply (lpXScale layout) + -- Phase 8 B16: densityNorm (pairs 対角) は y 軸 = 値範囲なので panel + -- 高さに独立正規化して描く (= seaborn pairplot 対角の挙動)。 + area = lpPlotArea layout + yPeak = maximum (1e-12 : ys) + syNorm v = rY area + rH area - (v / yPeak) * rH area * 0.95 + pts = if isNorm + then zipWith (\x y -> Point (sx x) (syNorm y)) gridX ys + else zipWith (\x y -> projectPoint coord layout x y) gridX ys + segs = case pts of { [] -> []; (p:rest) -> MoveTo p : map LineTo rest } + -- Phase 28: doFill なら曲線下を塗る (isNorm 時は基線が panel 下端)。 + fillPrim + | not doFill = [] + | otherwise = + let (baseR, baseL) + | isNorm = ( Point (sx (last gridX)) (rY area + rH area) + , Point (sx (head gridX)) (rY area + rH area) ) + | otherwise = ( projectPoint coord layout (last gridX) 0 + , projectPoint coord layout (head gridX) 0 ) + in [ PPath (segs ++ [LineTo baseR, LineTo baseL]) (FillStyle c fillA) Nothing ] + in fillPrim ++ [ PPath segs (FillStyle "" 0) (Just (StrokeStyle c w)) ] + +-- | 頻度多角形 (Ch10 EDA, Phase 28): @geom_freqpoly@。 histogram と同じ bin 化 +-- ('histBinning') で各 bin の count を求め、 bin 中心 @origin+(i+0.5)*binW@ と count を +-- 折れ線で結ぶ (KDE の 'renderDensity' とは別物 = ビン頻度の生の折れ線)。 空 bin は +-- count 0 として線が底に落ちる (ggplot geom_freqpoly と同じ)。 'lyHistDensity' True で +-- after_stat(density) = count/(群N*binW) に正規化 (面積 1)。 color 群分割 +-- (lyColor = ColorByCol) は 'renderDensity' と同方式で群ごとに別色の折れ線を重ねる。 +renderFreqPoly :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderFreqPoly r layout pal ly = + let xs = V.toList (vecOr (lyEncX ly) r) + w = doubleOr (lyStroke ly) (mmPt 0.5) + isDensity = getLast (lyHistDensity ly) == Just True + coord = lpCoord layout + in if null xs then [] else + let (origin, binW, nB) = histBinning ly (minimum xs, maximum xs) + binIx x = min (nB - 1) (max 0 (floor ((x - origin) / binW))) + center i = origin + (fromIntegral i + 0.5) * binW + -- 1 群 (= 1 系列) の bin count → bin 中心折れ線。 + polyOf col gxs + | null gxs = [] + | otherwise = + let cs = foldl (\acc x -> let i = binIx x + in take i acc <> [acc !! i + 1] <> drop (i+1) acc) + (replicate nB (0 :: Int)) gxs + gN = fromIntegral (length gxs) :: Double + toY c = if isDensity && gN > 0 && binW > 0 + then fromIntegral c / (gN * binW) + else fromIntegral c + pts = [ projectPoint coord layout (center i) (toY c) + | (i, c) <- zip [0 ..] cs ] + segs = case pts of { [] -> []; (p:rest) -> MoveTo p : map LineTo rest } + in [ PPath segs (FillStyle "" 0) (Just (StrokeStyle col w)) ] + -- 群分割判定 (= renderDensity と同規則)。 + grouped = case getLast (lyColor ly) of + Just (ColorByCol gcr) -> + case groupKeysOf r gcr of + Just ks | length ks == length xs -> Just ks + _ -> Nothing + _ -> Nothing + in case grouped of + Just ks -> + let distinct = let cats = lyColorCats ly in if null cats then orderedCats ks else cats + palArr = lpCategoricalPalette layout + manual = lpColorManual layout + colorOf t = case lookup t manual of + Just cc -> cc + Nothing -> case elemIndex t distinct of + Just i -> palArr !! (i `mod` length palArr) + Nothing -> tpDefault pal + grps = orderedGroups ks xs + ordered = [ (g, vs) | g <- distinct, Just vs <- [lookup g grps] ] + in concat [ polyOf (colorOf g) gxs | (g, gxs) <- ordered ] + Nothing -> + let c = staticColorOr ly (tpDefault pal) + in polyOf c xs diff --git a/src/Graphics/Hgg/Spec.hs b/src/Graphics/Hgg/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec.hs @@ -0,0 +1,390 @@ +-- | +-- Module : Graphics.Hgg.Spec +-- Description : Layer 3 ─ VisualSpec / Layer / ColRef + Monoid (Phase 26 §A-2) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- 設計方針 (詳細: design/api-style-discussion-2.md + 続き): +-- +-- * 2 階層 Monoid: 'Layer' (= 1 layer 内属性) と 'VisualSpec' (= 図全体) +-- * 全 helper が `<>` で paren 無し合成可能 (= plotnine 風) +-- * 'ColRef' で「文字列 col 参照」 と「Vector inline」 両対応、 +-- ('OverloadedStrings' で `"weight" :: ColRef` が自動 'ColByName') +-- * core は DataFrame 型に非依存。 col 名 → Vector 解決は 'Resolver' +-- callback で render 時に行う (= core 内ではデータ source を持たない) +-- * Generic + ToJSON/FromJSON で Spec 全体が **JSON serializable** +-- (= frontend ↔ backend 間で共有し、 差分 Patch を送るユースケースを想定) +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec + ( -- * ColRef + Resolver + ColRef(..) + , ColData(..) + , Resolver + , emptyResolver + , resolveCol + , bakeSpec + , resolveNum + , resolveTxt + , colRefName + -- * Inline column conversion + , Numeric(..) + , Categorical(..) + , inline + , inlineCat + -- * Layer + , Layer(..) + , MarkKind(..) + , ColorEnc(..) + -- ** 固定色 'Color' 型 (re-export from "Graphics.Hgg.Color") + , Color(..) + , rgb + , fromHex + , fromHexMaybe + , fromHexA + , fromHexAMaybe + , ConnectSpec(..) + , defaultConnectSpec + -- * 2D 点 'Point2' (= 3D 'Graphics.Hgg.ThreeD.Types.Point3' と対称) + , Point2(..) + -- * Phase 51: custom mark (拡張可能な描画語彙) + , RenderCtx(..) + , CustomMark(..) + , customMark + , customMarkWith + , encX + , encY + -- * Layer constructors (= Layer 返却) + , scatter + , line + , scatterPoints -- ★ Phase 30 A7 inline [Point2] (= 3D scatter3DPoints と対称) + , linePoints -- ★ Phase 30 A7 inline [Point2] (= 3D line3DPoints と対称) + , bar + , quiver + , arrowScale + , arrowColorByMagnitude + , text + , label + , qq + , ecdf + , lineRange + , pointRange + , crossbar + , statFunction + , histogram + , freqpoly -- ★ Ch10 EDA (Phase 28) geom_freqpoly (= 頻度多角形) + , countXY -- ★ Ch10 EDA (Phase 28) geom_count (= 2 カテゴリ件数) + , histogramWide -- ★ P1 (Phase 6 A10) wide-form 重ね + , autocorr -- ★ P19 (Phase 6 A4) MCMC autocorrelation + , autocorrMaxLag -- ★ Phase 6 A4 max lag override + , ess -- ★ P20 (Phase 6 A5) Effective Sample Size + , chain -- ★ Phase 6 A5 chain group 設定 + , forest -- ★ Phase 6 A2 Forest plot (= horizontal CI bar) + , forestNull -- ★ Phase 6 A2 null effect 位置 (= 縦 0 線、 default 0) + , funnel -- ★ Phase 6 A3 Funnel plot (= effect vs SE) + , boxplot + , groupBy -- ★ Phase 36: 群配置チャネル (色なし・ggplot aes(group=)) + , density + , densityNorm + , pie + , waterfall + , heatmap + , contour + , contourFilled + , contourLevels + , contourBreaks + , bin2d + , bin2dCount -- ★ Ch10 EDA (Phase 28) geom_bin2d (count 版) + , tile -- ★ Phase 60: 連続軸タイル塗り (geom_tile/raster・決定境界) + , hexbin -- ★ Phase 40: 六角ビニング (geom_hex / matplotlib hexbin) + , hexbinBins -- ★ Phase 40: hexbin の x 方向セル分割数 (既定 30) + , HexCell(..) -- ★ Phase 40: 六角セル (中心+件数+頂点) + , hexbinCells -- ★ Phase 40: 六角ビニング純関数 (d3-hexbin) + , hexbinLayerCells -- ★ Phase 40: Layer 解決版 (render/colorbar 共有) + , subplots + , subplotCols + , selectPanels + , selectedSubplots + , scaleXDiscreteLimits + , scaleYDiscreteLimits + , applyDiscreteLimits + , hconcat + , vconcat + , (<->) + , (<:>) + , repeatFields + , pairs + , step + , stem + , statLm + , statLmLevel + , statSmooth + , statSmoothCI + , statPoly + , statResid + , band + , stream + , violin + , strip + , swarm + , raincloud + , (<+>) + , distCols + , compositeLanes + , ridge + , ridgeAutoFlip + , jitterX + , jitterY + , sqrtAxis + , timeAxis + , AxisBreak(..) + , axisBreak + , axisBreaksAt + , axisTickLabels + , axisBreaksLabeled + , hideTicks + , Annotation(..) + , annotate + , annotText + , annotTextP + , annotArrow + , annotArrowP + , annotRect + , annotRectP + , annotLine + , annotLineP + , Inset(..) + , inset + , insetAt + , insetElement + , palette + , paletteGGplot + , continuousPalette + , scaleColorManual + , scaleColorGradient2 + , scaleSize + , YAxisSide(..) + , yAxisRight + , toRightY + , toLeftY + , statMean + , statMedian + , parallelCoords + , dag + , dagFromLists + , dagFromListsWithPlates + , dagNode + , dagNodeDist + , dagEdge + , trace + , traceLines + -- * Layer-local attribute (= Layer 返却) + , color + , colorRGBA + , colorRGBAMaybe + , colorBy + , distGroupRef + , distDodgeRef + , colorContinuousBy + , alpha + , size + , stroke + , edgeOn + , edge + , edgeWidth + , hoverCols + , errorX + , errorY + , connect + , connectOrder + , connectGroup + , connectColor + , connectWidth + -- * Axis (= Phase 26 §C-2 #1 / #2) + , AxisSpec(..) + , AxisKind(..) + , AxisFormat(..) + , axisKindOf + , axisFormatOf + , axTickValsOf + , axTickLabelsOf + , axisRotateOf + , resolveAxisAngle + , axisShowTicksOf + , axisRotate + , linearAxis + , logAxis + , axisFormat + , axisMin + , axisMax + , axisRange + , binCount + , binWidth + , histBinning + , histogramDensity + , histBorder + , densityFill + , hollow + -- * 分布 mark の位置決め (= Phase 36 D1) + , Side(..) + , nudge + , markWidth + , side + -- * Bar position adjustment (= Phase 9 B) + , Position(..) + , position + , Coord(..) + , coordFlip + , coordPolar + , coordPolarY + , reverseX + , reverseY + , coordCartesianX + , coordCartesianY + , coordCartesian + -- * Reference line (= Phase 26 §C-2 #3) + , ReferenceLine(..) + -- * Marginal histogram (= Phase 26 §C-2 #10) + , MarginalSpec(..) + , MarginalKind(..) + , defaultMarginalSpec + , LegendSpec(..) + , LegendPosition(..) + , defaultLegendSpec + , legend + , legendOff + , legendPos + , guideColorNone + , legendReverse + , legendNcol + , legendNrow + -- * DAG (= Phase 26 §E-6, HBM ModelGraph) + , DAGSpec(..) + , DAGNode(..) + , DAGEdge(..) + , RoutedEdge(..) + , EdgeShapeKind(..) + , DAGPlate(..) + , DAGNodeKind(..) + , DAGLayoutAlgorithm(..) + -- * Top-level + , VisualSpec(..) + , ThemeName(..) + , themeSeriesPalette + , okabeIto, tolBright, brewerSet2, brewerDark2 + , ThemeOverride(..) + , themeGrid, panelFill, panelBorder, themeAxisLine, gridColor, plotBg, axisColor, textColor + , themeTitleFont, themeAxisLabelFont, themeTickFont, themeLegendFont, themeAxisTextAngle + , themeAxisTextAngleX, themeAxisTextAngleY, axisTextAngleXOf, axisTextAngleYOf + , stripFill, themeStrip + , titleHjust, titleColor, tickColor, legendKeyBg -- ★ Phase 43 A4 + -- * Top-level setters (= VisualSpec 返却) + , purePlot + , layer + , title + , theme + , facet + , facetWrap + , facetCols + , facetGrid + , FacetScales(..) + , freeScaleX + , freeScaleY + , facetScales + , FacetSpace(..) + , freeSpaceX + , freeSpaceY + , facetSpace + , xLabel + , yLabel + , legendTitle + , subtitle + , caption + , tag + , Labs(..) + , emptyLabs + , labs + , width + , height + , widthMm + , heightMm + , widthUnit + , heightUnit + , dpi + , aspectRatio + , xAxis + , yAxis + , refLine + , refIdentity + , refHorizontal + , refVertical + , marginal + , marginalX + , marginalY + -- * C-6 Shape encoding + , MarkShape(..) + , ShapeMapEntry(..) + , shape + , shapeBy + , shapeMapEntry + , sizeBy + , alphaBy -- ★ Phase 30 A8 連続 alpha encoding (= ggplot scale_alpha) + , colorCats + , orderedCats + -- * Phase 11 A4-b linetype encoding + , LineType(..) + , linetype + , linetypeBy + , lineTypeDash + , lineTypeForIndex + -- * Font customization (= hgg-frontend-settings-spec v0.1 §1.3) + , FontSpec(..) + , emptyFontSpec + , fontSize + , fontFamily + , fontWeight + , fontItalic + , fontColor + , titleFont + , axisLabelFont + , tickFont + , legendFont + ) where + +import Graphics.Hgg.Color (Color (..), rgb, fromHex, fromHexMaybe, + fromHexA, fromHexAMaybe, toCss) +import Data.Aeson (FromJSON, ToJSON, toJSON, parseJSON, toEncoding, + Value (Object)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KM +import qualified Data.Char as Char +import qualified Data.List +import Data.Maybe (catMaybes) +import Data.Monoid (First (..), Last (..)) +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector (Vector) +import qualified Data.Vector as V +import GHC.Generics (Generic, Generically (..)) + +import Graphics.Hgg.Unit (Length, Pos (..), lengthToPt, mm, (*~)) +import Graphics.Hgg.Primitive (Primitive, Rect (..)) -- Phase 51: custom mark closure 型 +-- Phase 55: Spec の module 分割 (本 module は facade として全 API を re-export) +import Graphics.Hgg.Spec.Axis +import Graphics.Hgg.Spec.Bake +import Graphics.Hgg.Spec.Column +import Graphics.Hgg.Spec.Concat +import Graphics.Hgg.Spec.Constructors +import Graphics.Hgg.Spec.Decoration +import Graphics.Hgg.Spec.CustomMark +import Graphics.Hgg.Spec.Layer +import Graphics.Hgg.Spec.Mark +import Graphics.Hgg.Spec.Setters +import Graphics.Hgg.Spec.Theme +import Graphics.Hgg.Spec.Visual + diff --git a/src/Graphics/Hgg/Spec/Axis.hs b/src/Graphics/Hgg/Spec/Axis.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Axis.hs @@ -0,0 +1,214 @@ +-- | +-- Module : Graphics.Hgg.Spec.Axis +-- Description : AxisSpec ─ 軸 1 本の設定 (scale 種別 / format / break / 回転) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 軸 1 本の宣言型設定 +-- 'AxisSpec' (log/sqrt/time scale・範囲・tick・回転・break) とその setter / +-- accessor を持つ。 Spec 内の他 module に依存しない leaf。 公開 API は従来どおり +-- 'Graphics.Hgg.Spec' (facade) が re-export する。 挙動・出力は完全に不変。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Axis + ( AxisKind(..) + , AxisFormat(..) + , AxisBreak(..) + , AxisSpec(..) + , linearAxis, logAxis, sqrtAxis, timeAxis + , axisMin, axisMax, axisRange + , axisFormat, axisRotate, axisTickLabels, hideTicks + , axisBreak, axisBreaksAt, axisBreaksLabeled + , axisKindOf, axisFormatOf, axisRotateOf, axisShowTicksOf + , axTickValsOf, axTickLabelsOf + , resolveAxisAngle, themeAngleOr0 + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Monoid (Last (..)) +import Data.Text (Text) +import GHC.Generics (Generic) + +-- =========================================================================== +-- AxisSpec ─ 軸 1 本の設定 (Phase 26 §C-2 #1 LogScale + #2 軸 format) +-- =========================================================================== + +-- | 軸 scale 種別。 線形 / 対数 / sqrt / time / ordinal / band を将来追加。 +-- 現状は AxisLinear / AxisLog / AxisSqrt (P15) / AxisTime (P7)。 +data AxisKind = AxisLinear | AxisLog | AxisSqrt | AxisTime + deriving (Show, Eq, Generic) + +instance ToJSON AxisKind +instance FromJSON AxisKind + +-- | 軸ラベルの数値表記。 +data AxisFormat + = AxisIntegerFmt + | AxisDecimalFmt !Int -- 小数桁数 + | AxisExponentFmt !Int -- 指数表記 N 桁 + | AxisTimeFmt !Text -- ★ P7 timestamp ms → date 文字列 (= "yyyy-MM-dd" 等) + deriving (Show, Eq, Generic) + +instance ToJSON AxisFormat +instance FromJSON AxisFormat + +-- | 軸 1 本の設定。 全 field を Maybe で Monoid 化、 後勝ち合成。 +data AxisBreak = AxisBreak { abFrom :: !Double, abTo :: !Double } + deriving (Show, Eq, Generic) + +instance ToJSON AxisBreak +instance FromJSON AxisBreak + +data AxisSpec = AxisSpec + { axKind :: !(Last AxisKind) + , axFormat :: !(Last AxisFormat) + , axMin :: !(Last Double) + , axMax :: !(Last Double) + , axRotate :: !(Last Double) -- ★ P10 軸 label 回転 (度) + , axBreaks :: ![AxisBreak] -- ★ P16 軸不連続範囲 + , axShowTicks :: !(Last Bool) -- ★ tick 表示 (= default true、 pairs/facet 内側 false) + , axShowGrid :: !(Last Bool) -- ★ C-5 grid line 表示 (= default false) + -- ★ Phase 11 A4-d: 明示 tick 位置 (= ggplot scale_*_continuous(breaks=))。 非空なら + -- 自動 extendedBreaks を上書き。 numeric 軸のみ有効 (categorical は無視)。 + , axTickVals :: ![Double] + -- ★ Phase 11 A4-d: 明示 tick ラベル (= ggplot labels=)。 axTickVals と 1:1 対応 + -- (短ければ "" 埋め)。 空なら値を format して使う。 + , axTickLabels :: ![Text] + } deriving (Show, Eq, Generic) + +instance ToJSON AxisSpec +instance FromJSON AxisSpec + +-- ★ Phase 43 A3: レコードフィールド形式 (位置依存撲滅・挙動不変)。axTickVals/axTickLabels +-- のみ「右が非空なら右」特殊合成 (list `<>` = 連結と別) を名前付きで温存。 +instance Semigroup AxisSpec where + a <> b = AxisSpec + { axKind = axKind a <> axKind b + , axFormat = axFormat a <> axFormat b + , axMin = axMin a <> axMin b + , axMax = axMax a <> axMax b + , axRotate = axRotate a <> axRotate b + , axBreaks = axBreaks a <> axBreaks b + , axShowTicks = axShowTicks a <> axShowTicks b + , axShowGrid = axShowGrid a <> axShowGrid b + -- ★ A4-d: 明示 break/label は「後勝ち」 (= 後から与えた breaks=/labels= が前の指定を + -- 完全に置換)。 空配列なら前の指定を温存。 + , axTickVals = if null (axTickVals b) then axTickVals a else axTickVals b + , axTickLabels = if null (axTickLabels b) then axTickLabels a else axTickLabels b + } + +instance Monoid AxisSpec where + mempty = AxisSpec mempty mempty mempty mempty mempty [] mempty mempty [] [] + +-- | Last AxisSpec から AxisKind を取り出す (= default は AxisLinear)。 +axisKindOf :: Last AxisSpec -> AxisKind +axisKindOf (Last Nothing) = AxisLinear +axisKindOf (Last (Just as)) = case getLast (axKind as) of + Just k -> k + Nothing -> AxisLinear + +-- | Last AxisSpec から AxisFormat を取り出す (= default は AxisDecimalFmt 1 +-- 相当の auto)。 +axisFormatOf :: Last AxisSpec -> Maybe AxisFormat +axisFormatOf (Last Nothing) = Nothing +axisFormatOf (Last (Just as)) = getLast (axFormat as) + +-- | 'xAxis (linearAxis)' / 'xAxis (logAxis)' のような書き方の起点。 +linearAxis, logAxis, sqrtAxis :: AxisSpec +linearAxis = mempty { axKind = Last (Just AxisLinear) } +logAxis = mempty { axKind = Last (Just AxisLog) } +sqrtAxis = mempty { axKind = Last (Just AxisSqrt) } + +-- | P7: time axis (= 値 Unix timestamp ms、 pattern で date 文字列に format)。 +timeAxis :: Text -> AxisSpec +timeAxis pat = mempty + { axKind = Last (Just AxisTime) + , axFormat = Last (Just (AxisTimeFmt pat)) } + +-- | P16: 軸不連続範囲 1 つを追加。 +axisBreak :: Double -> Double -> AxisSpec +axisBreak from to = mempty { axBreaks = [AxisBreak { abFrom = from, abTo = to }] } + +-- | A4-d: 明示 tick 位置 (= ggplot scale_*_continuous(breaks=))。 自動 tick を +-- これで上書き (numeric 軸のみ。 categorical 軸では無視)。 範囲外の値は描画時に +-- censor される。 例: @xAxis (axisBreaksAt [0,25,50,75,100])@。 +axisBreaksAt :: [Double] -> AxisSpec +axisBreaksAt vs = mempty { axTickVals = vs } + +-- | A4-d: 明示 tick ラベル (= ggplot labels=)。 'axisBreaksAt' と組で使い、 i 番目の +-- break に i 番目のラベルを割り当てる (長さは breaks に揃える)。 単体指定でも +-- 自動 break の順に割り当たるが、 通常は 'axisBreaksLabeled' を推奨。 +axisTickLabels :: [Text] -> AxisSpec +axisTickLabels ls = mempty { axTickLabels = ls } + +-- | A4-d: break 位置とラベルを対で指定する便利関数 (= ggplot breaks=/labels= を一度に)。 +-- 例: @xAxis (axisBreaksLabeled [(0,\"low\"),(50,\"mid\"),(100,\"high\")])@。 +axisBreaksLabeled :: [(Double, Text)] -> AxisSpec +axisBreaksLabeled prs = mempty { axTickVals = map fst prs, axTickLabels = map snd prs } + +-- | Last AxisSpec から明示 tick 位置を取り出す (未指定 = [])。 +axTickValsOf :: Last AxisSpec -> [Double] +axTickValsOf (Last Nothing) = [] +axTickValsOf (Last (Just as)) = axTickVals as + +-- | Last AxisSpec から明示 tick ラベルを取り出す (未指定 = [])。 +axTickLabelsOf :: Last AxisSpec -> [Text] +axTickLabelsOf (Last Nothing) = [] +axTickLabelsOf (Last (Just as)) = axTickLabels as + +-- | tick を隠す (= pairs / facet の内側 panel 用)。 +hideTicks :: AxisSpec +hideTicks = mempty { axShowTicks = Last (Just False) } + +-- | 'xAxis (axisFormat (AxisDecimalFmt 2))' で軸 format を指定。 +axisFormat :: AxisFormat -> AxisSpec +axisFormat f = mempty { axFormat = Last (Just f) } + +-- | 軸 label 回転 (度・**CCW = 反時計回りが正**、 R / matplotlib / ggplot と同じ規約・Phase 50 A1)。 +-- 30 / 45 / 90 等。 例: @xAxis (axisRotate 90)@ で x 目盛ラベルを CCW 90° +-- (縦書き・下→上読み・y 軸タイトルと同じ向き)。 内部の SVG/canvas rotate は CW 正なので +-- 'resolveAxisAngle' で符号反転して描画に渡す (公開 API は R 準拠の CCW に統一)。 +axisRotate :: Double -> AxisSpec +axisRotate deg = mempty { axRotate = Last (Just deg) } + +-- | frontend-settings v0.1 §1.5: 軸 min 値。 +axisMin :: Double -> AxisSpec +axisMin v = mempty { axMin = Last (Just v) } + +-- | frontend-settings v0.1 §1.5: 軸 max 値。 +axisMax :: Double -> AxisSpec +axisMax v = mempty { axMax = Last (Just v) } + +-- | frontend-settings v0.1 §1.5: 軸 min + max 同時指定。 +axisRange :: Double -> Double -> AxisSpec +axisRange lo hi = mempty { axMin = Last (Just lo), axMax = Last (Just hi) } + +-- | Last AxisSpec から軸 rotation を取り出す (= default 0)。 +axisRotateOf :: Last AxisSpec -> Double +axisRotateOf (Last Nothing) = 0 +axisRotateOf (Last (Just as)) = case getLast (axRotate as) of + Just d -> d + Nothing -> 0 + +-- | Phase 9 A-3 / Phase 50 A1: 軸目盛りラベルの回転角を解決 (**CCW 正・canonical**)。 +-- 'axisRotate' / theme axis.text angle も内部 'tsRotate' も **CCW 正** (R/matplotlib/ggplot 準拠) +-- で一貫。 CW の device (SVG/canvas/rasterific) への変換は **各 backend の emit で 1 回だけ** 行う +-- (PDF は y-up=CCW ゆえ恒等)。 per-axis 明示指定を最優先、 無ければ theme override、 無ければ 0。 +resolveAxisAngle :: Last AxisSpec -> Last Double -> Double +resolveAxisAngle (Last (Just as)) themeAngle + | Just d <- getLast (axRotate as) = d + | otherwise = themeAngleOr0 themeAngle +resolveAxisAngle (Last Nothing) themeAngle = themeAngleOr0 themeAngle + +themeAngleOr0 :: Last Double -> Double +themeAngleOr0 a = case getLast a of + Just d -> d + Nothing -> 0 + +-- | Last AxisSpec から axShowTicks を取り出す (= default True、 Nothing も True 扱い)。 +axisShowTicksOf :: Last AxisSpec -> Bool +axisShowTicksOf (Last Nothing) = True +axisShowTicksOf (Last (Just as)) = case getLast (axShowTicks as) of + Just b -> b + Nothing -> True + diff --git a/src/Graphics/Hgg/Spec/Bake.hs b/src/Graphics/Hgg/Spec/Bake.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Bake.hs @@ -0,0 +1,70 @@ +-- | +-- Module : Graphics.Hgg.Spec.Bake +-- Description : Resolver の焼き込み (ColByName → inline 解決、 Phase 8 B16) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 spec 内の全 +-- 'ColByName' を 'Resolver' で inline ('ColNum' / 'ColTxt') 化する 'bakeSpec' +-- を持つ。 'VisualSpec' / 'Layer' 全体を走査する sink (被参照ゼロ・Phase 55 A1 +-- 実測) ゆえ分割 module 群の最後段。 公開 API は従来どおり 'Graphics.Hgg.Spec' +-- (facade) が re-export する。 挙動・出力は完全に不変。 +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Bake + ( bakeSpec + ) where + +import Graphics.Hgg.Spec.Column +import Graphics.Hgg.Spec.Layer (Layer (..)) +import Graphics.Hgg.Spec.Mark (ColorEnc (..)) +import Graphics.Hgg.Spec.Visual (VisualSpec (..)) + +-- =========================================================================== +-- Resolver の焼き込み (Phase 8 B16): ColByName を inline (ColNum/ColTxt) に解決 +-- =========================================================================== +-- PS canvas backend は Resolver を持たず spec JSON だけ受け取るため、 ColByName +-- (列名参照) のままだと PS で解決できず描画されない (= pairs/facet/legend が空)。 +-- JSON 出力前に bakeSpec で全 ColRef を inline 化すると PS でも描ける。 + +-- | ColByName を Resolver で解決し ColNum/ColTxt に置換 (解決不能なら元のまま)。 +bakeColRef :: Resolver -> ColRef -> ColRef +bakeColRef r cr@(ColByName n) = case r n of + Just (NumData v) -> ColNum v + Just (TxtData v) -> ColTxt v + Nothing -> cr +bakeColRef _ cr = cr + +bakeColorEnc :: Resolver -> ColorEnc -> ColorEnc +bakeColorEnc r (ColorByCol cr) = ColorByCol (bakeColRef r cr) +-- Phase 9 A-5 fix: ColorByContinuous も inline 化しないと PS (emptyResolver) で色も +-- legend も出ない (= legend-continuous で発覚)。 +bakeColorEnc r (ColorByContinuous cr) = ColorByContinuous (bakeColRef r cr) +bakeColorEnc _ ce = ce + +bakeLayer :: Resolver -> Layer -> Layer +bakeLayer r l = l + { lyEncX = bakeColRef r <$> lyEncX l + , lyEncY = bakeColRef r <$> lyEncY l + , lyEncY2 = bakeColRef r <$> lyEncY2 l + , lyErrorX = bakeColRef r <$> lyErrorX l + , lyErrorY = bakeColRef r <$> lyErrorY l + , lyChain = bakeColRef r <$> lyChain l + , lyShapeBy = bakeColRef r <$> lyShapeBy l + , lySizeBy = bakeColRef r <$> lySizeBy l + , lyAlphaBy = bakeColRef r <$> lyAlphaBy l + , lyLinetypeBy = bakeColRef r <$> lyLinetypeBy l + , lyLabel = bakeColRef r <$> lyLabel l + , lyColor = bakeColorEnc r <$> lyColor l + , lyOverlay = map (bakeLayer r) (lyOverlay l) -- ★ Phase 36 D2: sub-mark の inline 列も bake + } + +-- | spec 内の全 ColByName を Resolver で inline 化 (layers + facet + subplots 再帰)。 +-- JSON 出力前に呼ぶと PS でも Resolver 不要で描ける。 +bakeSpec :: Resolver -> VisualSpec -> VisualSpec +bakeSpec r spec = spec + { vsLayers = map (bakeLayer r) (vsLayers spec) + , vsFacet = bakeColRef r <$> vsFacet spec + , vsFacetRow = bakeColRef r <$> vsFacetRow spec + , vsFacetCol = bakeColRef r <$> vsFacetCol spec + , vsSubplots = map (bakeSpec r) (vsSubplots spec) + } diff --git a/src/Graphics/Hgg/Spec/Column.hs b/src/Graphics/Hgg/Spec/Column.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Column.hs @@ -0,0 +1,151 @@ +-- | +-- Module : Graphics.Hgg.Spec.Column +-- Description : データ列参照 (ColRef/Resolver) + inline 変換 + Point2 (Spec の leaf) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' (3420 行) の module 分割で切り出した leaf。 +-- 列参照の 3 variant ('ColByName' / 'ColNum' / 'ColTxt') と render 時解決 +-- ('Resolver')、 inline 列変換 ('Numeric' / 'Categorical')、 2D 点 ('Point2') を +-- 持つ。 Spec 内の他 module に依存しない最下層。 公開 API は従来どおり +-- 'Graphics.Hgg.Spec' (facade) が re-export する。 挙動・出力は完全に不変。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Column + ( -- * ColRef + Resolver + ColRef(..) + , ColData(..) + , Resolver + , emptyResolver + , resolveCol + , resolveNum + , resolveTxt + , colRefName + -- * Inline column conversion + , Numeric(..) + , Categorical(..) + , inline + , inlineCat + -- * Point2 + , Point2(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector (Vector) +import qualified Data.Vector as V +import GHC.Generics (Generic) + +-- =========================================================================== +-- ColRef + Resolver +-- =========================================================================== + +-- | データ列の参照方法。 3 つの variant: +-- +-- * 'ColByName' ─ 文字列 col 名。 'Resolver' で実 Vector に解決される。 +-- * 'ColNum' ─ 数値 Vector を inline (= 即値、 resolver 不要) +-- * 'ColTxt' ─ 文字列 Vector を inline (= categorical encoding 用) +-- +-- 'OverloadedStrings' で `"weight" :: ColRef` が `ColByName "weight"` に。 +data ColRef + = ColByName !Text + | ColNum !(Vector Double) + | ColTxt !(Vector Text) + deriving (Generic, Show, Eq) + +instance ToJSON ColRef +instance FromJSON ColRef + +instance IsString ColRef where + fromString = ColByName . T.pack + +-- | Resolver が返すデータ形 (= 数値 or 文字列)。 +data ColData + = NumData !(Vector Double) + | TxtData !(Vector Text) + deriving (Show, Eq) + +-- | render 時に col 名を Vector に解決する callback。 +-- 数値列 / 文字列列 どちらも返せるよう 'ColData' で union。 +type Resolver = Text -> Maybe ColData + +emptyResolver :: Resolver +emptyResolver _ = Nothing + +-- | 'ColRef' を 'ColData' に解決。 inline は variant に応じて直接返す。 +resolveCol :: Resolver -> ColRef -> Maybe ColData +resolveCol r (ColByName n) = r n +resolveCol _ (ColNum v) = Just (NumData v) +resolveCol _ (ColTxt v) = Just (TxtData v) + +-- | 数値解決 (= 数値列 or 数値 inline のみ成功、 文字列は 'Nothing')。 +resolveNum :: Resolver -> ColRef -> Maybe (Vector Double) +resolveNum r cr = case resolveCol r cr of + Just (NumData v) -> Just v + _ -> Nothing + +-- | 文字列解決 (= 文字列 inline or 文字列列のみ成功)。 +resolveTxt :: Resolver -> ColRef -> Maybe (Vector Text) +resolveTxt r cr = case resolveCol r cr of + Just (TxtData v) -> Just v + _ -> Nothing + +-- | ColRef の表示名 (= hover tooltip / legend 等)。 +colRefName :: ColRef -> Text +colRefName (ColByName n) = n +colRefName (ColNum _) = "<inline-num>" +colRefName (ColTxt _) = "<inline-txt>" + +-- =========================================================================== +-- Inline column conversion +-- =========================================================================== + +-- | 数値系 (Vector n / [n], n は Real instance を持つ任意型) を 'ColRef' に。 +class Numeric a where + toNumVec :: a -> Vector Double + +instance Real n => Numeric (Vector n) where + toNumVec = V.map realToFrac + +instance Real n => Numeric [n] where + toNumVec = V.fromList . map realToFrac + +-- | 文字列系 (= categorical encoding 用)。 +class Categorical a where + toTxtVec :: a -> Vector Text + +instance Categorical (Vector Text) where toTxtVec = id +instance Categorical [Text] where toTxtVec = V.fromList +instance Categorical [String] where toTxtVec = V.fromList . map T.pack + +-- | 数値 (Vector / List) を inline 'ColRef' に。 'Int' / 'Double' / 'Float' / +-- 'Integer' / 'Word' 等 'Real' instance を持つ任意型に対応。 +-- +-- > scatter (inline xs) (inline ys) +-- > scatter (inline [1, 2, 3]) (inline [4.0, 5.0, 6.0]) +inline :: Numeric a => a -> ColRef +inline = ColNum . toNumVec + +-- | 文字列系を inline 'ColRef' に (= categorical encoding 用)。 +-- +-- > colorBy (inlineCat ["red", "blue", "green"]) +inlineCat :: Categorical a => a -> ColRef +inlineCat = ColTxt . toTxtVec + +-- =========================================================================== +-- Point2 (= 2D 点・3D 'Point3' と対称) +-- =========================================================================== + +-- | 2D 点 (= world space)。 'Graphics.Hgg.ThreeD.Types.Point3' と対称の直積型。 +-- inline の点単位 API ('scatterPoints' / 'linePoints') で使う。 +-- +-- JSON: positional fields → array @[x, y]@ (= aeson Generic デフォルト挙動・ +-- 'Point3' と同形式)。 ※ 'Graphics.Hgg.Render' の @Point@ は screen 空間で別物。 +data Point2 = Point2 !Double !Double + deriving (Show, Eq, Generic) +instance ToJSON Point2 +instance FromJSON Point2 + diff --git a/src/Graphics/Hgg/Spec/Concat.hs b/src/Graphics/Hgg/Spec/Concat.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Concat.hs @@ -0,0 +1,132 @@ +-- | +-- Module : Graphics.Hgg.Spec.Concat +-- Description : 図の合成 (hconcat / vconcat / <-> / <:> + pairs、 patchwork 風) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 複数 'VisualSpec' を +-- 1 枚に並べる合成 (Vega-Lite hconcat/vconcat 相当・patchwork 風演算子) と +-- 'pairs' (散布図行列) を持つ。 subplots + subplotCols の純粋な薄ラッパで、 +-- レンダリングは既存 subplots 経路を使う。 公開 API は従来どおり +-- 'Graphics.Hgg.Spec' (facade) が re-export する。 挙動・出力は完全に不変。 +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Concat + ( hconcat + , vconcat + , (<->) + , (<:>) + , asHGroup + , asVGroup + , pairs + ) where + +import Data.Monoid (Last (..)) + +import Graphics.Hgg.Spec.Axis (hideTicks) +import Graphics.Hgg.Spec.Column (ColRef, colRefName) +import Graphics.Hgg.Spec.Constructors (densityNorm, scatter) +import Graphics.Hgg.Spec.Layer (alpha, size) +import Graphics.Hgg.Spec.Setters +import Graphics.Hgg.Spec.Visual + +-- =========================================================================== +-- concat 合成 (Vega-Lite hconcat/vconcat 相当・patchwork 風演算子) +-- =========================================================================== +-- subplots + subplotCols の純粋な薄ラッパ。 レンダリングは既存 subplots 経路を +-- そのまま使う (render/parity への影響ゼロ)。 +-- +-- 演算子 '<->' (横) / '<:>' (縦) は同方向チェーンを **平坦化** する: +-- (a <-> b <-> c) は subplots [a,b,c] (3 等分列) になり、 二項ネスト +-- (= 2 列で左セルが a,b に分割) にはならない。 平坦化は「左辺が cols==列数の +-- 水平グループなら末尾追加、 そうでなければ新規 2 要素」 で行う。 leaf プロットは +-- vsSubplots=[] ゆえ必ず新規開始 = 通常チャートを誤って取り込まない。 +-- 例: @(a <-> b <-> c) <:> d@ = 1 行目 3 列 + 2 行目を全幅 (1 行目セルの 3 倍幅)。 +-- これは @vconcat [hconcat [a,b,c], d]@ と同値。 +-- +-- ★演算子の選定: '<->'(横)・'<:>'(縦) は Prelude/標準ライブラリと衝突しない +-- (旧案 '<|>' は Control.Applicative の Alternative と衝突したため回避した)。 + +-- | 横並び (= Vega-Lite hconcat): n 要素を 1 行 n 列に。 +hconcat :: [VisualSpec] -> VisualSpec +hconcat ss = subplots ss <> subplotCols (length ss) + +-- | 縦並び (= Vega-Lite vconcat): n 要素を n 行 1 列に。 +vconcat :: [VisualSpec] -> VisualSpec +vconcat ss = subplots ss <> subplotCols 1 + +-- ★ fixity: '<->' (横) と '<:>' (縦) を同 precedence infixl 6 に揃える (Phase 59)。 +-- '<>' (Semigroup、 infixr 6) と同 precedence・異 associativity なので、 +-- @a <:> b <> opt@ / @a <-> b <> opt@ は無括弧だと**コンパイルエラー** +-- (Haskell 2010 §10.6 = 同 precedence の infixl/infixr 混在は構文エラー) になり、 +-- @(a <:> b) <> opt@ と括弧を強制できる = 全体オプションが右パネルだけに付く +-- サイレント誤りを防ぐ。 旧 '<:>'=infixl 5 は '<>' より緩く @a <:> (b <> opt)@ と +-- 黙って結合してしまう footgun だった (横 '<->' は元から infixl 6 でエラー = 安全側。 +-- 縦だけ非対称に危険だったのを解消)。 +infixl 6 <-> +infixl 6 <:> + +-- | 横結合演算子 (= hconcat の二項・同方向チェーンを平坦化)。 +(<->) :: VisualSpec -> VisualSpec -> VisualSpec +a <-> b = case asHGroup a of + Just xs -> hconcat (xs ++ [b]) + Nothing -> hconcat [a, b] + +-- | 縦結合演算子 (= vconcat の二項・同方向チェーンを平坦化)。 +(<:>) :: VisualSpec -> VisualSpec -> VisualSpec +a <:> b = case asVGroup a of + Just xs -> vconcat (xs ++ [b]) + Nothing -> vconcat [a, b] + +-- | spec が「純粋な水平グループ (subplots=xs (>1 要素)・cols==要素数)」 なら xs。 +asHGroup :: VisualSpec -> Maybe [VisualSpec] +asHGroup s = case getLast (vsSubplotCols s) of + Just c | let xs = vsSubplots s, length xs > 1, c == length xs -> Just (vsSubplots s) + _ -> Nothing + +-- | spec が「純粋な垂直グループ (subplots=xs (>1 要素)・cols==1)」 なら xs。 +asVGroup :: VisualSpec -> Maybe [VisualSpec] +asVGroup s = case getLast (vsSubplotCols s) of + Just 1 | length (vsSubplots s) > 1 -> Just (vsSubplots s) + _ -> Nothing + +-- | P18: pairs plot (= N 列の posterior 等を N×N grid で対角は density、 +-- | 非対角は scatter)。 +pairs :: [ColRef] -> VisualSpec +pairs cols = + let n = length cols + -- Phase 7 A6: 内側パネルの軸目盛りを抑制 (= seaborn/ggpairs 流)。 + -- x tick は最下段 (i == n-1) のみ、 y tick は左端列 (j == 0) のみ表示。 + -- 対角 (i == j) は density で y = count スケールのため、 左端の (0,0) も y は抑制。 + -- ※ axShowTicks (Bool) は HS が真の JSON boolean で出力する。 PS Codec の + -- decodeBoolean を boolean 両対応にして HS→PS decode を通るようにした。 + mkPanel i j = + let showXAxis = i == n - 1 + -- 左端列 (j==0) は対角も含め y 軸目盛りを表示 (= その行の変数値スケール)。 + showYAxis = j == 0 + axisCfg = (if showXAxis then mempty else xAxis hideTicks) + <> (if showYAxis then mempty else yAxis hideTicks) + -- seaborn/ggpairs 流: 軸ラベル (変数名) は最下段 x・左端 y のみ。 + -- inline 列は名前を持たない (placeholder) ので、 その場合はラベルを付けない + -- (= xLabel/yLabel を呼ばず mempty。 空ラベルの margin 予約も避けて詰める)。 + axName c = let nm = colRefName c + in if nm == "<inline-num>" || nm == "<inline-txt>" then "" else nm + xLab c = if i == n - 1 && axName c /= "" then xLabel (axName c) else mempty + yLab c = if j == 0 && axName c /= "" then yLabel (axName c) else mempty + base + -- 対角 (i==j): densityNorm (= y 軸 = 値範囲、 KDE は panel 高さに正規化、 + -- seaborn pairplot 対角)。 左端列なら y タイトルも。 + | i == j = case cols !? i of + Just c -> purePlot <> layer (densityNorm c) <> xLab c <> yLab c + Nothing -> purePlot + | otherwise = case (cols !? j, cols !? i) of + (Just xc, Just yc) -> purePlot + <> layer (scatter xc yc <> alpha 0.3 <> size 2.5) + <> xLab xc <> yLab yc + _ -> purePlot + in base <> axisCfg + panels = [ mkPanel i j | i <- [0..n-1], j <- [0..n-1] ] + in subplots panels <> subplotCols n <> title "Pairs plot" + where + (!?) :: [a] -> Int -> Maybe a + xs !? i = if i < 0 || i >= length xs then Nothing else Just (xs !! i) + diff --git a/src/Graphics/Hgg/Spec/Constructors.hs b/src/Graphics/Hgg/Spec/Constructors.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Constructors.hs @@ -0,0 +1,824 @@ +-- | +-- Module : Graphics.Hgg.Spec.Constructors +-- Description : Layer constructors (= 各 mark の最小起点、 mark カタログ) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 mark ごとの Layer +-- 構築子 ('scatter' / 'line' / 'bar' / ... / 'customMark') と mark 固有 setter +-- ('binCount' / 'jitterX' / 'shape' / 'statLm' 系等)、 hexbin の binning +-- ('HexCell') を持つ。 中身は等質な mark カタログ (辞書的) ゆえ 1 module に +-- まとめる (Phase 55 A1 で user 合意)。 公開 API は従来どおり +-- 'Graphics.Hgg.Spec' (facade) が re-export する。 挙動・出力は完全に不変。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Constructors + ( -- * 基本 mark + scatter, line, bar, histogram, histogramDensity + , heatmap, boxplot, density, densityFill, freqpoly + , scatterPoints, linePoints, unzipPoint2 + -- * custom mark (Phase 51) + , customMark, customMarkWith, encX, encY + -- * 統計 / 分布 mark + , trace, traceLines, forest, forestNull, funnel, autocorr, autocorrMaxLag, ess + , violin, strip, swarm, raincloud, ridge + , qq, ecdf, lineRange, pointRange, crossbar + , statMean, statMedian, statLm, statLmLevel, statSmooth, statSmoothCI + , statPoly, statResid, statFunction + -- * 特化 mark + , band, step, stem, stream, pie, waterfall, parallelCoords + , countXY, quiver, contour, contourFilled, bin2d, bin2dCount, tile + , hexbin, hexbinBins, HexCell(..), hexbinCells, hexbinLayerCells + , dag, dagNode, dagNodeDist, dagEdge, dagFromLists, dagFromListsWithPlates + -- * mark 固有 setter / 補助 + , (<+>) + , alphaBy, arrowColorByMagnitude, arrowScale + , binCount, binWidth, histBinning, histBorder, hollow + , chain, colorCats, orderedCats, compositeLanes, densityNorm + , contourBreaks, contourLevels + , groupBy, jitterX, jitterY, label + , linetype, linetypeBy, markWidth, nudge, position + , shape, shapeBy, shapeMapEntry, side, sizeBy, text + ) where + +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.List +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as V + +import Graphics.Hgg.Color (fromHex) +import Graphics.Hgg.Primitive (Primitive) +import Graphics.Hgg.Spec.Column +import Graphics.Hgg.Spec.CustomMark +import Graphics.Hgg.Spec.Layer +import Graphics.Hgg.Spec.Mark + +-- =========================================================================== +-- Layer constructors (= 各 mark の最小起点) +-- =========================================================================== + +scatter, line, bar :: ColRef -> ColRef -> Layer +scatter x y = mempty + { lyKind = First (Just MScatter), lyEncX = Last (Just x), lyEncY = Last (Just y) } +line x y = mempty + { lyKind = First (Just MLine), lyEncX = Last (Just x), lyEncY = Last (Just y) } +bar x y = mempty + { lyKind = First (Just MBar), lyEncX = Last (Just x), lyEncY = Last (Just y) } + +-- | Phase 51: custom mark を定義する公開 API。 core (@MarkKind@ の閉列挙) を触らず +-- 新しいプロット型を足す拡張点。 @cid@ = 安定 mark 識別子 (PS registry dispatch の鍵)、 +-- @draw@ = 'RenderCtx' を受け取り 'Primitive' 列を返す描画 closure。 データは closure に +-- 閉じ込めても、 'rcResolver' 経由で layer 束縛列を引いてもよい。 +-- +-- HS は closure を直接呼んで描く (SVG/PDF/Rasterific)。 PS canvas で parity が欲しい時は +-- 同じ @cid@ で PS registry に draw 関数を手登録する (無ければ HS 専用)。 +-- +-- > customMark "myElbow" $ \ctx -> [ PLine (uncurry Point (rcProjectXY ctx 0 0)) ... ] +customMark :: Text -> (RenderCtx -> [Primitive]) -> Layer +customMark cid draw = mempty + { lyKind = First (Just MCustom) + , lyCustom = Last (Just (CustomMark cid Aeson.Null draw)) } + +-- | option 付き 'customMark'。 @opts@ は PS registry の draw 関数へ渡る serializable JSON。 +customMarkWith :: Text -> Value -> (RenderCtx -> [Primitive]) -> Layer +customMarkWith cid opts draw = mempty + { lyKind = First (Just MCustom) + , lyCustom = Last (Just (CustomMark cid opts draw)) } + +-- | x / y encoding 列を単独で束ねる 'Layer' setter。 mark 種別に依らず合成でき、 custom mark を +-- 「一級 mark」化する (= 軸 range が 'lyEncX'/'lyEncY' から自動計算され、 @df |>>@ とも連携)。 +-- 既存 mark の encoding 上書きにも使える。 custom mark の名前付き combinator は普通こう書く: +-- +-- > dendrogram :: ColRef -> ColRef -> Layer +-- > dendrogram x y = customMark "dendrogram" (drawFromCols x y) <> encX x <> encY y +-- > -- 使う側: layer (dendrogram "leaf" "height") ← scatter x y と同じ使い勝手 +encX :: ColRef -> Layer +encX x = mempty { lyEncX = Last (Just x) } + +encY :: ColRef -> Layer +encY y = mempty { lyEncY = Last (Just y) } + +-- | Phase 30 A7: 2D scatter ('Point2' 直入れ・3D 'Graphics.Hgg.ThreeD.Spec.scatter3DPoints' +-- と対称)。 内部は @scatter (inline xs) (inline ys)@ に等価 (= x/y を inline 列に分解) +-- なので Render/JSON/PS 無改修。 +-- +-- > scatterPoints [Point2 1 2, Point2 3 4] +scatterPoints :: [Point2] -> Layer +scatterPoints pts = scatter (inline xs) (inline ys) + where (xs, ys) = unzipPoint2 pts + +-- | Phase 30 A7: 2D line ('Point2' 直入れ・3D 'Graphics.Hgg.ThreeD.Spec.line3DPoints' +-- と対称)。 内部は @line (inline xs) (inline ys)@ に等価。 +linePoints :: [Point2] -> Layer +linePoints pts = line (inline xs) (inline ys) + where (xs, ys) = unzipPoint2 pts + +-- | '[Point2]' を x / y の 'Double' リストに分解 ('scatterPoints' / 'linePoints' 用)。 +unzipPoint2 :: [Point2] -> ([Double], [Double]) +unzipPoint2 = unzip . map (\(Point2 x y) -> (x, y)) + +-- | Phase 26 A2: vector field (quiver)。 各 (x,y) に成分 (u,v) の矢印を描く +-- (= matplotlib @quiver@)。 矢印長は autoscale (= 最長矢印がデータ対角の ~8%) +-- に 'arrowScale' 倍を掛けた長さ。 列バインドは @df |>> quiver \"x\" \"y\" \"u\" \"v\"@。 +-- 矢印を magnitude (= √(u²+v²)) で連続色マップするには 'arrowColorByMagnitude'。 +quiver :: ColRef -> ColRef -> ColRef -> ColRef -> Layer +quiver x y u v = mempty + { lyKind = First (Just MQuiver) + , lyEncX = Last (Just x), lyEncY = Last (Just y) + , lyEncU = Last (Just u), lyEncV = Last (Just v) } + +-- | Phase 26 A2: quiver 矢印長の倍率 (autoscale × この値・既定 1)。 値を上げると矢印が長く。 +arrowScale :: Double -> Layer +arrowScale s = mempty { lyArrowScale = Last (Just s) } + +-- | Phase 26 A2: quiver の矢印を magnitude (= √(u²+v²)) で連続色マップする (+ 既定 OFF)。 +-- 色は連続パレット (viridis 系)。 OFF 時は単色 ('color' / theme)。 +arrowColorByMagnitude :: Layer +arrowColorByMagnitude = mempty { lyArrowMagnitude = Last (Just True) } + +-- | Phase 11 A6: データ駆動テキストラベル (= ggplot @geom_text@)。 各 (x,y) 点に lab 列の +-- 文字を描く。 'annotate' (固定 1 点) と違い列駆動で点数ぶん出る。 +text :: ColRef -> ColRef -> ColRef -> Layer +text x y lab = mempty + { lyKind = First (Just MText), lyEncX = Last (Just x), lyEncY = Last (Just y) + , lyLabel = Last (Just lab) } + +-- | Phase 11 A6: 背景付きテキストラベル (= ggplot @geom_label@)。 'text' と同じだが +-- 各文字の背後に角丸矩形を敷く (= 重なる点の上でも読みやすい)。 +label :: ColRef -> ColRef -> ColRef -> Layer +label x y lab = mempty + { lyKind = First (Just MLabel), lyEncX = Last (Just x), lyEncY = Last (Just y) + , lyLabel = Last (Just lab) } + +-- | Phase 11 A6-2: Q-Q plot (= ggplot @stat_qq@ / @geom_qq@)。 sample 列のみを取り、 +-- ソートした order statistic y_(i) を y、 理論正規分位点 Φ⁻¹((i-0.5)/n) を x に置いて +-- 点を描く (= 正規性の視覚診断)。 理論分位点は render / range 側で算出するため、 +-- ここでは sample を encY に保持するだけ (encX 列は持たない)。 +qq :: ColRef -> Layer +qq sample = mempty + { lyKind = First (Just MQQ), lyEncY = Last (Just sample) } + +-- | Phase 11 A6-4: ECDF plot (= ggplot @stat_ecdf@)。 sample 列 (encX) をソートして +-- 右連続の経験累積分布 F(x)=#(≤x)/n を階段状に描く (y∈[0,1])。 +ecdf :: ColRef -> Layer +ecdf sample = mempty + { lyKind = First (Just MEcdf), lyEncX = Last (Just sample) } + +-- | Phase 11 A6-4b: linerange (= ggplot @geom_linerange@)。 各 (x,y) に縦線 y±err を描く。 +lineRange :: ColRef -> ColRef -> ColRef -> Layer +lineRange x y err = mempty + { lyKind = First (Just MLineRange), lyEncX = Last (Just x) + , lyEncY = Last (Just y), lyErrorY = Last (Just err) } + +-- | Phase 11 A6-4b: pointrange (= ggplot @geom_pointrange@)。 linerange + 中心点。 +pointRange :: ColRef -> ColRef -> ColRef -> Layer +pointRange x y err = mempty + { lyKind = First (Just MPointRange), lyEncX = Last (Just x) + , lyEncY = Last (Just y), lyErrorY = Last (Just err) } + +-- | Phase 11 A6-4b: crossbar (= ggplot @geom_crossbar@)。 幅付き箱 (y±err) + 中央水平線。 +crossbar :: ColRef -> ColRef -> ColRef -> Layer +crossbar x y err = mempty + { lyKind = First (Just MCrossbar), lyEncX = Last (Just x) + , lyEncY = Last (Just y), lyErrorY = Last (Just err) } + +-- | Phase 11 A6-4c: stat_function (= ggplot @stat_function@ / @geom_function@)。 +-- 関数 f を [xLo, xHi] で n 点サンプルし、 inline 列の line layer を生成する。 +-- 関数自体は JSON 化できないため **構成時にサンプル点へ焼き込む** (= spec には点列が入り、 +-- canvas backend は通常の line として描く)。 n<2 は 2 に切り上げ。 +statFunction :: (Double -> Double) -> Double -> Double -> Int -> Layer +statFunction f xLo xHi n = + let m = max 2 n + xs = [ xLo + (xHi - xLo) * fromIntegral i / fromIntegral (m - 1) | i <- [0 .. m - 1] ] + ys = map f xs + in line (ColNum (V.fromList xs)) (ColNum (V.fromList ys)) + +histogram :: ColRef -> Layer +histogram x = mempty + { lyKind = First (Just MHistogram), lyEncX = Last (Just x) } + +-- | 頻度多角形 (Ch10 EDA, Phase 28): @geom_freqpoly(aes(x = …))@ 相当。 histogram と +-- 同じ bin 化で各 bin の count を求め、 bin 中心を折れ線で結ぶ。 bin 幅は +-- 'binWidth' / 'binCount'、 after_stat(density) は 'histogramDensity' True で +-- 流用 (= histogram と同じフラグ)。 color aesthetic ('colorBy') で群分割すると +-- 群ごとに別色の折れ線を重ねる (cut 別 price 分布の比較等)。 +freqpoly :: ColRef -> Layer +freqpoly x = mempty + { lyKind = First (Just MFreqPoly), lyEncX = Last (Just x) } + +-- | Ch10 EDA (Phase 28): 2 カテゴリ変数の件数 (= ggplot @geom_count()@ / @stat_sum@)。 +-- @countXY x y@ は (x,y) のカテゴリ組合せごとに観測件数を集計し、 各セル中心に +-- 面積 ∝ 件数 (= 半径 ∝ √件数) の点を描く。 'size' で最大半径 px を上書き可。 +countXY :: ColRef -> ColRef -> Layer +countXY x y = mempty + { lyKind = First (Just MCount), lyEncX = Last (Just x), lyEncY = Last (Just y) } + +-- | MCMC autocorrelation plot (P19、 Phase 6 A4): 1 列の時系列から lag-k 自己相関 r(τ) +-- を計算し bar chart で表示。 max lag は 'autocorrMaxLag'、 default は 40。 +-- ±1.96/√N の significance band も同時描画。 +-- +-- r(τ) = Σ(x_t - μ)(x_{t+τ} - μ) / Σ(x_t - μ)² +-- +-- matplotlib との対応: `plt.acorr(x, maxlags=40)` 相当 (= 但し片側のみ)。 +autocorr :: ColRef -> Layer +autocorr c = mempty + { lyKind = First (Just MAutocorr) + , lyEncX = Last (Just c) + } + +-- | autocorr の max lag (= 'autocorr' と '<>' で組合せ)。 default 40。 +autocorrMaxLag :: Int -> Layer +autocorrMaxLag n = mempty { lyMaxLag = Last (Just n) } + +-- | Effective Sample Size plot (P20、 Phase 6 A5): chain ごとに ESS bar を描画。 +-- chain group は 'chain' で指定 (= 'ess vals <> chain chainCol')。 +-- chain 未指定なら全体を 1 chain として 1 bar。 +-- +-- ESS = N / (1 + 2 Σ |r(τ)|) (= τ=1 から r(τ) > 0 まで) +-- +-- matplotlib / arviz 対応: `az.plot_ess(idata)` の chain ごと bar (= 簡略版)。 +-- | ESS 棒グラフ (Phase 8 B13): encX = パラメータ/chain 名 (categorical)、 +-- encY = 計算済み ESS 値。 ESS の計算は統計ライブラリ (analyze 側) の責務で、 +-- plot は値を棒にするだけ (= ggplot/bayesplot mcmc_neff 流の「計算と描画の分離」)。 +ess :: ColRef -> ColRef -> Layer +ess nameCol essCol = mempty + { lyKind = First (Just MEss) + , lyEncX = Last (Just nameCol) + , lyEncY = Last (Just essCol) + } + +-- | chain group 列を設定 (= 'autocorr' / 'ess' で chain 分け、 MTrace でも将来使用)。 +chain :: ColRef -> Layer +chain c = mempty { lyChain = Last (Just c) } + +-- | Forest plot (Phase 6 A2): 各 row が「label + 点推定 + CI」 の horizontal CI bar 群。 +-- +-- 引数: label 列 (= categorical/text)、 point estimate 列、 ± 半幅 列 (= 対称 CI)。 +-- +-- * y 軸: label +-- * x 軸: estimate +-- * 中央 vertical 線: 'forestNull' (= default 0、 メタ解析慣例で OR は 1) +-- +-- asymmetric CI (= lo / hi 個別) は将来。 現状は対称 CI のみ。 +forest :: ColRef -> ColRef -> ColRef -> Layer +forest labelCol estCol errCol = mempty + { lyKind = First (Just MForest) + , lyEncX = Last (Just estCol) + , lyEncY = Last (Just labelCol) + , lyErrorX = Last (Just errCol) + } + +-- | Forest plot の null effect 位置 (= 縦 0 線、 メタ解析の reference)。 default 0。 +-- リスク比 / オッズ比 を log scale で扱う場合は 0 (= log 1)、 線形なら 0 (= 差)。 +forestNull :: Double -> Layer +forestNull v = mempty { lyMaxLag = Last (Just (round v)) } + -- 流用: lyMaxLag を null position の Int で再利用 (= round)。 + -- TODO: Double-precision null position field を別途 (= 当面 Int で十分) + +-- | Funnel plot (Phase 6 A3): 効果量 vs 標準誤差の散布図 + 95% 信頼区間 envelope。 +-- +-- 引数: 効果量 (effect) 列、 標準誤差 (SE) 列。 出版 bias 確認に使う。 +-- +-- * x 軸: effect (= estimate) +-- * y 軸: SE (= 上方が精度高、 下方が精度低) +-- * 中央 vertical 線: pooled mean (= データから算出) +-- * diagonal 線: pooled ± 1.96 * SE の envelope +funnel :: ColRef -> ColRef -> Layer +funnel effectCol seCol = mempty + { lyKind = First (Just MFunnel) + , lyEncX = Last (Just effectCol) + , lyEncY = Last (Just seCol) + } + +-- | Box plot。 ★ Phase 36: 値 1 列を受ける。 群分けは @<> groupBy "g"@ (色一律) / +-- @<> colorBy "g"@ (群色+凡例) で付ける (ggplot 同型)。 群指定なしなら単一 box。 +boxplot :: ColRef -> Layer +boxplot vals = mempty + { lyKind = First (Just MBox), lyEncY = Last (Just vals) } + +-- | ★ Phase 36: 群で分けて配置するチャネル (= ggplot @aes(group=)@)。 色は付けない +-- (一律。 色は 'color' / 'colorBy' で別途)。 distribution mark (boxplot/violin 等) では +-- 群ごとに集約を作りカテゴリ x に並べる。 内部表現は encX (= 既存の群配置機構を流用)。 +-- ⚠ @Data.List.groupBy@ と同名なので、 両方 import する場合は qualified 推奨。 +groupBy :: ColRef -> Layer +groupBy g = mempty { lyEncX = Last (Just g) } + +-- | Density plot: x 列の値ベクター で Gaussian KDE 曲線。 +density :: ColRef -> Layer +density x = mempty + { lyKind = First (Just MDensity), lyEncX = Last (Just x) } + +-- | Phase 8 B16: pairs 対角用 density。 y 軸目盛りは値範囲 (= 行の変数値、 散布図行と +-- 共有)、 KDE 曲線は panel 高さに独立正規化して描く (= seaborn pairplot 対角の挙動)。 +densityNorm :: ColRef -> Layer +densityNorm x = mempty + { lyKind = First (Just MDensity), lyEncX = Last (Just x) + , lyDensityNorm = Last (Just True) } + +-- | Phase 26 S4-d: Pie chart (= encX cat, encY 値合計の扇)。 +pie :: ColRef -> ColRef -> Layer +pie x y = mempty + { lyKind = First (Just MPie), lyEncX = Last (Just x), lyEncY = Last (Just y) } + +-- | Phase 26 S5-c: Waterfall chart (= encX cat, encY delta、 累積 bar)。 +waterfall :: ColRef -> ColRef -> Layer +waterfall x y = mempty + { lyKind = First (Just MWaterfall), lyEncX = Last (Just x), lyEncY = Last (Just y) } + +-- | Phase 26 S4 / Phase 11 A6-3 (= Heatmap): x = カテゴリ, y = カテゴリ, value = 数値。 +-- | 各 (x,y) セルを value の連続色 (Viridis) で塗る。 value は ColorByContinuous で表現。 +-- | PS heatmap と対応。 +heatmap :: ColRef -> ColRef -> ColRef -> Layer +heatmap x y v = mempty + { lyKind = First (Just MHeatmap) + , lyEncX = Last (Just x), lyEncY = Last (Just y) + , lyColor = Last (Just (ColorByContinuous v)) + } + +-- | Phase 26 S5-e-1: Contour / binned heatmap (= 連続 x/y/z、 grid 化して +-- | セル平均を Viridis 色マッピング)。 ResponseSurface の基盤。 +-- | color は ColorByContinuous で z 列を表現。 +contour :: ColRef -> ColRef -> ColRef -> Layer +contour x y z = mempty + { lyKind = First (Just MContour) + , lyEncX = Last (Just x), lyEncY = Last (Just y) + , lyColor = Last (Just (ColorByContinuous z)) + } + +-- | Phase 24 A4: filled contour (= matplotlib @contourf@ / ggplot +-- @geom_contour_filled@)。 等値帯を Viridis 連続色で塗る。 入力が規則 grid +-- (x 固有値 × y 固有値が全組存在) なら補間せず直入力、 散布なら k 近傍 IDW で +-- 格子化 ('Graphics.Hgg.Math.Griddata')。 線の 'contour' と重畳すると +-- matplotlib の contourf+contour 同等。 +contourFilled :: ColRef -> ColRef -> ColRef -> Layer +contourFilled x y z = mempty + { lyKind = First (Just MContourFilled) + , lyEncX = Last (Just x), lyEncY = Last (Just y) + , lyColor = Last (Just (ColorByContinuous z)) + } + +-- | Phase 24 A4: 等高線の本数 (既定 8)。 @contour x y z <> contourLevels 12@。 +contourLevels :: Int -> Layer +contourLevels n = mempty { lyContourLevels = Last (Just n) } + +-- | Phase 24 A4: 等高線レベルの明示指定 (本数指定より優先)。 +contourBreaks :: [Double] -> Layer +contourBreaks bs = mempty { lyContourBreaks = Last (Just bs) } + +-- | binned heatmap (= ggplot geom_bin2d / stat_summary_2d)。 連続 x/y/z を +-- nBins×nBins の grid に binning し、 各セルの z 平均を連続色 (Viridis) で塗る。 +-- 'contour' (等高線) の塗り版。 ResponseSurface の塗り基盤。 +bin2d :: ColRef -> ColRef -> ColRef -> Layer +bin2d x y z = mempty + { lyKind = First (Just MBin2d) + , lyEncX = Last (Just x), lyEncY = Last (Just y) + , lyColor = Last (Just (ColorByContinuous z)) + } + +-- | Ch10 EDA (Phase 28): 2D bin の**件数**を連続色で塗る (= ggplot @geom_bin2d()@ 既定)。 +-- @bin2dCount x y@ は連続 x/y を 12×12 grid に binning し、 各セルの**観測件数**を +-- Viridis で塗る (z 列なし = 'bin2d' の count 版)。 'bin2d' (z 平均) は stat_summary_2d 相当。 +bin2dCount :: ColRef -> ColRef -> Layer +bin2dCount x y = mempty + { lyKind = First (Just MBin2d) + , lyEncX = Last (Just x), lyEncY = Last (Just y) + } + +-- | geom_tile / geom_raster 相当 (Phase 60)。 連続 x/y を**セル中心**、 fill を**離散カテゴリ** +-- として矩形をベタ塗りする (幅/高さは格子間隔から自動・隙間なし)。 bin2d と違い再ビニングせず +-- 1 行=1 セルをそのまま塗る (= 決定境界の res×res グリッド塗り)。 fill の離散色と離散凡例は +-- colorBy 経路で自動 (重ねる散布点と同じカテゴリ空間ならパレット一致)。 連続 fill の塗りは +-- 'bin2d' (再ビニング) を使う。 +tile :: ColRef -> ColRef -> ColRef -> Layer +tile x y fill = mempty + { lyKind = First (Just MTile) + , lyEncX = Last (Just x), lyEncY = Last (Just y) + , lyColor = Last (Just (ColorByCol fill)) + } + +-- | Phase 40: hexbin (= matplotlib @hexbin@ / ggplot @geom_hex@)。 連続 x/y を**六角格子**で +-- binning し、 各セルの**観測件数**を Viridis 連続色で塗る (= 散布過密の密度可視化)。 +-- セル分割数は 'hexbinBins' で上書き (既定 30)。 矩形ビンの 'bin2dCount' の六角版。 +-- アルゴは d3-hexbin (Carr 1987) を binwidth 正規化空間で適用 (pointy-top)。 +hexbin :: ColRef -> ColRef -> Layer +hexbin x y = mempty + { lyKind = First (Just MHexbin) + , lyEncX = Last (Just x), lyEncY = Last (Just y) + } + +-- | Phase 40: hexbin の x 方向セル分割数を指定 (= ggplot @bins@ / matplotlib @gridsize@)。 +-- 既定 30。 'hexbin' に @<>@ で重ねる: @layer (hexbin "x" "y" <> hexbinBins 40)@。 +-- 内部は 'lyBinCount' を流用 (histogram と共有フィールド)。 +hexbinBins :: Int -> Layer +hexbinBins n = mempty { lyBinCount = Last (Just n) } + +-- | P12: step plot (= 階段状 line)。 +step :: ColRef -> ColRef -> Layer +step x y = mempty + { lyKind = First (Just MStep), lyEncX = Last (Just x), lyEncY = Last (Just y) } + +-- | Phase 16: stat-in 線形回帰 (= ggplot @geom_smooth(method="lm")@)。 純タグ Layer。 +-- 回帰 fit は描画前に analyze-bridge の @resolveStats@ が hanalyze で行い、 信頼帯 (band) + +-- 回帰線 (line) に展開する。 装飾は通常 geom と同じ: @statLm "x" "y" <> color N.red <> stroke 2@。 +-- ★単体では描画されない (renderer は MStatLM を skip)。 必ず bridge の saveSVGBoundStats 等で解決する。 +statLm :: ColRef -> ColRef -> Layer +statLm x y = mempty + { lyKind = First (Just MStatLM), lyEncX = Last (Just x), lyEncY = Last (Just y) } + +-- | Phase 16 B1: 信頼水準を指定できる線形回帰 stat。 'statLm' は 0.95 固定だが、 +-- こちらは @lvl@ (例 0.99) を 'lyStatLevel' に持たせる。 resolveStats が band 幅に反映する。 +statLmLevel :: ColRef -> ColRef -> Double -> Layer +statLmLevel x y lvl = (statLm x y) + { lyStatLevel = Last (Just lvl) } + +-- | Phase 16: stat-in B-spline 平滑 (= ggplot @geom_smooth()@)。 knot 数 n。 曲線のみ (帯なし)。 +-- resolveStats が hanalyze で fit し line に展開。 装飾は line に引き継がれる。 +statSmooth :: ColRef -> ColRef -> Int -> Layer +statSmooth x y n = mempty + { lyKind = First (Just MStatSmooth), lyEncX = Last (Just x), lyEncY = Last (Just y) + , lyBinCount = Last (Just n) } + +-- | Phase 16 B1: 信頼帯つき B-spline 平滑。 'statSmooth' は曲線のみだが、 こちらは +-- 'lyStatLevel' を Just にして「帯あり」を signal する。 resolveStats が bs 設計行列の +-- confidenceBand で band+line に展開する。 既定水準は 0.95 (@statSmoothCI x y n@)。 +statSmoothCI :: ColRef -> ColRef -> Int -> Layer +statSmoothCI x y n = (statSmooth x y n) + { lyStatLevel = Last (Just 0.95) } + +-- | Phase 16 B3: 多項式回帰 stat (= ggplot @geom_smooth(method="lm", formula=y~poly(x,deg))@)。 +-- 次数 deg は 'lyBinCount' を流用。 resolveStats が @y ~ poly(x,deg)@ で fit し band+line に展開。 +-- 信頼帯の水準は 'lyStatLevel' (既定 0.95)。 ★単体では描画されない (renderer は MStatPoly を skip)。 +statPoly :: ColRef -> ColRef -> Int -> Layer +statPoly x y deg = mempty + { lyKind = First (Just MStatPoly), lyEncX = Last (Just x), lyEncY = Last (Just y) + , lyBinCount = Last (Just deg) } + +-- | Phase 16 B3: 残差 vs fitted 診断散布 (= base R @plot(lm)@ #1)。 @y ~ x@ で fit し +-- 各点を (fitted, residual) に写した scatter に展開する (回帰診断)。 装飾は scatter に引き継ぐ。 +-- ★単体では描画されない (renderer は MStatResid を skip)。 bridge resolveStats が必要。 +statResid :: ColRef -> ColRef -> Layer +statResid x y = mempty + { lyKind = First (Just MStatResid), lyEncX = Last (Just x), lyEncY = Last (Just y) } + +-- | P11: stem / lollipop plot。 +stem :: ColRef -> ColRef -> Layer +stem x y = mempty + { lyKind = First (Just MStem), lyEncX = Last (Just x), lyEncY = Last (Just y) } + +-- | TODO-11 (2026-05-27): area band (= 信頼区間 / 予測帯)。 +-- | x = 共通 x 軸 +-- | yLow = 下境界 y +-- | yHigh = 上境界 y +-- | Render は PPath fill 1 枚 (= forward x-yLow + backward x-yHigh + close)。 +-- | alpha は layer modifier の `alpha` で指定 (= default 0.2)。 +band :: ColRef -> ColRef -> ColRef -> Layer +band x yLow yHigh = mempty + { lyKind = First (Just MBand) + , lyEncX = Last (Just x) + , lyEncY = Last (Just yLow) + , lyEncY2 = Last (Just yHigh) + } + +-- | Phase 52.D2: streamgraph (= 中心化積層 area)。 +-- | x = 共通 x 軸 (連続、 例: 時間) +-- | y = 各系列の値 +-- | 系列分割は color aesthetic で行う (= 'bar' の群分けと同型)。 +-- | +-- | > stream "t" "value" <> colorBy "series" +-- | +-- | 各 x 点で系列を積層し baseline を -(Σy)/2 から開始する (silhouette 中心化)。 +-- | wiggle 最小化 (ThemeRiver) は行わない。 +stream :: ColRef -> ColRef -> Layer +stream x y = mempty + { lyKind = First (Just MStream), lyEncX = Last (Just x), lyEncY = Last (Just y) } + +-- | P2: violin plot。 ★ Phase 36 B1c: boxplot と同じく **値 1 列**を受ける。 群分けは +-- @<> groupBy "g"@ (色一律) / @<> colorBy "g"@ (群色+凡例) で付ける (ggplot 同型)。 +-- 群指定なしなら単一 violin。 +violin :: ColRef -> Layer +violin v = mempty { lyKind = First (Just MViolin), lyEncY = Last (Just v) } + +-- | P3: strip plot。 ★ Phase 36 B1c: 値 1 列 + groupBy/colorBy で群分け。 +strip :: ColRef -> Layer +strip v = mempty { lyKind = First (Just MStrip), lyEncY = Last (Just v) } + +-- | P3: swarm plot。 ★ Phase 36 B1c: 値 1 列 + groupBy/colorBy で群分け。 +swarm :: ColRef -> Layer +swarm v = mempty { lyKind = First (Just MSwarm), lyEncY = Last (Just v) } + +-- | P22: raincloud (= violin + box + strip 合成)。 ★ Phase 36 B1c: 値 1 列 + groupBy/colorBy。 +-- | Phase 36 D2: mark 直結合成。 @a \<+\> b@ は a を base、 b を重畳 sub-mark とする +-- **単一 Layer** を返す (= 戻り型 Layer 維持ゆえ @raincloud v \<+\> ... \<\> groupBy g@ の +-- ような群修飾が従来どおり効く)。 b 側の overlay も平坦化して取り込む。 render は base + +-- 各 overlay を「親の群 (encX)・色 (colorBy)・値 (encY) を継承・自前の kind/nudge/markWidth/side +-- で」 描く。 1D 分布 mark (box/violin/strip/swarm) の重畳を想定 (= raincloud / 自作 composite)。 +infixl 7 <+> +(<+>) :: Layer -> Layer -> Layer +a <+> b = a { lyOverlay = lyOverlay a ++ [b { lyOverlay = [] }] ++ lyOverlay b } + +-- | P22: raincloud (= 半 violin + box + jitter strip の合成)。 ★ Phase 36 D2: 専用 mark を廃し +-- '<+>' による 3 sub-mark 合成の preset に降格 (= 位置決めは D1 つまみ nudge/markWidth/side に委譲)。 +-- 戻り型は Layer なので @raincloud v \<\> groupBy g@ / @\<\> colorBy g@ は従来どおり群分けする。 +raincloud :: ColRef -> Layer +raincloud v = + (violin v <> side SideRight <> nudge 0.15 <> markWidth 0.40) + <+> (boxplot v <> nudge 0.00 <> markWidth 0.10) + <+> (strip v <> nudge (-0.25) <> markWidth 0.18) + +-- | Phase 36 D3: 合成 Layer (base + overlay sub-mark) の値列レーン (= encY の distinct・base 先頭・ +-- 'colRefName' で重複除去)。 描画/Layout は各マークの slot を「自 encY が此のレーン列の何番目か」 +-- で決める。 同一列なら 1 レーン (= raincloud の重畳)、 複数列なら横並び (= distCols)。 +compositeLanes :: Layer -> [ColRef] +compositeLanes ly = foldl add [] [ c | l <- ly : lyOverlay ly, Just c <- [getLast (lyEncY l)] ] + where add acc c = if any ((== colRefName c) . colRefName) acc then acc else acc ++ [c] + +-- | P21: ridge / joyplot。 ★ Phase 36 B1c: 他 distribution mark と統一して **値 1 列**を +-- | 受ける。 群分けは @<> groupBy "g"@ / @<> colorBy "g"@ (= box/violin と同じ)。 +-- | 群指定なしは単一 density 風。 ridge は値→x・群→y の向きが要るため、 ridge レイヤを +-- | 含む spec は 'ridgeAutoFlip' で coord_flip を自動適用する (値が x、 群が y に回る)。 +-- | 内部表現は violin と同じ encY=値。 +ridge :: ColRef -> Layer +ridge v = mempty { lyKind = First (Just MRidge), lyEncY = Last (Just v) } + +-- | P14: scatter jitter (= plotArea 比率 0..1)。 +jitterX, jitterY :: Double -> Layer +jitterX a = mempty { lyJitterX = Last (Just a) } +jitterY a = mempty { lyJitterY = Last (Just a) } + +-- | frontend-settings v0.1 §2.4: histogram の bin 数 (= default 10)。 +binCount :: Int -> Layer +binCount n = mempty { lyBinCount = Last (Just n) } + +-- | Phase 28: histogram の bin 幅 (= ggplot @geom_histogram(binwidth = w)@)。 +-- 'binWidth' を指定すると 'binCount' より優先され、 'histBinning' が ggplot 流 +-- (boundary = w/2 で bin 原点を定める) の bin 化を行う。 +binWidth :: Double -> Layer +binWidth w = mempty { lyBinWidth = Last (Just w) } + +-- | histogram の bin 化パラメタ (origin, binW, nBin) を決める単一情報源。 +-- render (Render.Basic) と y/x range (Layout.RangeOf) の双方がこれを使い、 +-- bin 境界・棒高・軸範囲を一致させる。 +-- +-- * 'lyBinWidth' 指定時: ggplot @bin_breaks_width@ と同式。 boundary = w/2 とし、 +-- origin = boundary + floor((lo - boundary)/w) * w、 nBin = ceil((hi - origin)/w)。 +-- これで R4DS の @binwidth=@ と同じ bin 境界・棒高になる。 +-- * 未指定時: 従来どおり 'lyBinCount' (既定 30) で [lo,hi] を等分。 +-- +-- bin i は @[origin + i*binW, origin + (i+1)*binW)@、 値 v の所属は +-- @clamp 0 (nBin-1) (floor ((v - origin)/binW))@。 +histBinning :: Layer -> (Double, Double) -> (Double, Double, Int) +histBinning ly (lo, hi) = + case getLast (lyBinWidth ly) of + Just w | w > 0 -> + let boundary = w / 2 + shift = fromIntegral (floor ((lo - boundary) / w) :: Int) + origin = boundary + shift * w + nBin = max 1 (ceiling ((hi - origin) / w)) + in (origin, w, nBin) + _ -> + let nBin = case getLast (lyBinCount ly) of + Just n | n > 0 -> n + _ -> 30 + binW = if hi > lo then (hi - lo) / fromIntegral nBin else 1 + in (lo, binW, nBin) + +-- | Phase 40: hexbin の六角セル (中心 + 件数 + 6 頂点、 すべてデータ座標)。 +data HexCell = HexCell + { hexCx :: !Double -- ^ セル中心 x (データ座標) + , hexCy :: !Double -- ^ セル中心 y + , hexCount :: !Int -- ^ セルに入った点数 + , hexVerts :: ![(Double, Double)] -- ^ 6 頂点 (pointy-top、 データ座標) + } deriving (Show, Eq) + +-- | Phase 40: 六角ビニング (d3-hexbin = Carr 1987)。 @bins@ = x 方向セル分割数。 +-- (xmin,xmax)/(ymin,ymax) = データ範囲、 @pts@ = (x,y) 点列。 binwidth で正規化した +-- (u,v) 空間で点を六角セルに割当て件数を数え、 中心・6 頂点をデータ座標で返す +-- (= scale パイプラインでそのまま screen へ。 pointy-top)。 +-- ★HS/PS で同式・JS Math.round (= @floor (z+0.5)@) を使い byte 一致させる。 +hexbinCells :: Int -> (Double, Double) -> (Double, Double) + -> [(Double, Double)] -> [HexCell] +hexbinCells bins (xmin, xmax) (ymin, ymax) pts + | bins <= 0 || bwx <= 0 || bwy <= 0 || null pts = [] + | otherwise = + [ mkCell (head grp) (length grp) + | grp <- Data.List.group (Data.List.sort (map assign pts)) ] + where + bwx = (xmax - xmin) / fromIntegral bins + bwy = (ymax - ymin) / fromIntegral bins + dyv = sqrt 3 / 2 -- = 1.5·r (r = 1/√3、 dx=√3·r=1 に正規化) + ruv = 1 / sqrt 3 + jsRound z = floor (z + 0.5) :: Int -- JS Math.round (half-up)・HS=PS 一致用 + -- 点 → セルキー (pi, pj) (d3-hexbin verbatim) + assign :: (Double, Double) -> (Int, Int) + assign (x, y) = + let u = (x - xmin) / bwx + v = (y - ymin) / bwy + py = v / dyv + pj = jsRound py + px = u - (if odd pj then 0.5 else 0) -- dx=1、 奇数行 0.5 シフト + pii = jsRound px + py1 = py - fromIntegral pj + in if abs py1 * 3 > 1 + then let px1 = px - fromIntegral pii + pi2 = fromIntegral pii + (if px < fromIntegral pii then -1 else 1) / 2 :: Double + pj2 = pj + (if py < fromIntegral pj then -1 else 1) + px2 = px - pi2 + py2 = py - fromIntegral pj2 + in if px1 * px1 + py1 * py1 > px2 * px2 + py2 * py2 + then (jsRound (pi2 + (if odd pj then 1 else -1) / 2), pj2) + else (pii, pj) + else (pii, pj) + -- セルキー → HexCell (中心・頂点をデータ座標へ) + mkCell :: (Int, Int) -> Int -> HexCell + mkCell (pii, pj) n = + let cu = fromIntegral pii + (if odd pj then 0.5 else 0) -- × dx(=1) + cv = fromIntegral pj * dyv + cx = xmin + cu * bwx + cy = ymin + cv * bwy + vert k = let ang = fromIntegral k * pi / 3 + vu = sin ang * ruv + vv = negate (cos ang) * ruv + in (xmin + (cu + vu) * bwx, ymin + (cv + vv) * bwy) + in HexCell cx cy n (map vert [0 .. 5 :: Int]) + +-- | Phase 40: hexbin layer を解決して六角セルを返す (renderHexbin と count colorbar が共有)。 +-- x/y を 'resolveNum' で取り NaN を除いて zip、 bins (既定 30) で 'hexbinCells'。 +-- render と凡例で**同じ count 域**を得るために 1 本に集約する。 +hexbinLayerCells :: Resolver -> Layer -> [HexCell] +hexbinLayerCells r ly = + case (getLast (lyEncX ly), getLast (lyEncY ly)) of + (Just xr, Just yr) -> + case (resolveNum r xr, resolveNum r yr) of + (Just xv, Just yv) -> + let pts = [ (x, y) | (x, y) <- zip (V.toList xv) (V.toList yv) + , not (isNaN x), not (isNaN y) ] + bins = case getLast (lyBinCount ly) of Just b | b > 0 -> b; _ -> 30 + in if null pts then [] + else let xs = map fst pts; ys = map snd pts + in hexbinCells bins (minimum xs, maximum xs) (minimum ys, maximum ys) pts + _ -> [] + _ -> [] + +-- | TODO-3a (2026-05-29): histogram の y 軸を密度 (= count / (total * binW)) +-- に正規化。 PS Spec.histogramDensity と同等。 SVG export でも動くように HS +-- 側にも実装 (= 旧来 HS は count のみで density mode が機能しなかった)。 +histogramDensity :: Bool -> Layer +histogramDensity b = mempty { lyHistDensity = Last (Just b) } + +-- | Phase 8 B7: histogram / bar の bin 境界線 (= 各バーの白枠) を表示するか。 +-- デフォルトは False (= ggplot 流フラットバー、 枠なし)。 True で bin 区切りが見える。 +histBorder :: Bool -> Layer +histBorder b = mempty { lyHistBorder = Last (Just b) } + +-- | Phase 28: density 曲線の下を塗りつぶす (= ggplot @geom_density(aes(fill = …))@)。 +-- 群別 ('color') と 'alpha' を併用すると、 各群を群色 × alpha で塗る (R4DS Ch1 §1.5)。 +-- 既定 (未指定/False) は ggplot 同様 fill=NA = 線のみ。 +densityFill :: Bool -> Layer +densityFill b = mempty { lyDensityFill = Last (Just b) } + +-- | Phase 34: マーカーを中抜き (= ggplot @shape="circle open"@ / @geom_point(fill = NA)@)。 +-- 塗りを透明にし、 点色で輪郭 (stroke) のみ描く。 'size' で輪郭円の直径、 +-- 'stroke' で線幅 (既定 1pt)。 重畳して「点を輪で囲む」 強調に使う (R4DS Ch9 §9.6)。 +hollow :: Layer +hollow = mempty { lyHollow = Last (Just True) } + +-- | Phase 36 D1: 分布 mark (box/violin/strip/swarm) の slot 内横 offset。 値は **slot 幅比** +-- (= ggplot @position_nudge@)。 正で右、 負で左。 raincloud の「box を中央・strip を左・雲を右」 +-- のような重畳配置を組むのに使う (= 旧 raincloud のハードコード offset を置換)。 +nudge :: Double -> Layer +nudge x = mempty { lyNudge = Last (Just x) } + +-- | Phase 36 D1: 分布 mark の幅 (= **slot 幅比・占有率**)。 各 mark の既定占有率 +-- (box 0.5 / violin 0.7 / strip 0.4 / swarm 0.8) を上書きする。 raincloud では box を細く +-- (= 0.1 等) するのに使う。 +markWidth :: Double -> Layer +markWidth w = mempty { lyMarkWidth = Last (Just w) } + +-- | Phase 36 D1: violin の片側化 (= 半 violin)。 @violin "v" <> side SideRight@ で右半分のみ。 +-- raincloud の「雲」 (= 片側 violin) に使う。 box/strip 等には影響しない。 +side :: Side -> Layer +side s = mempty { lySide = Last (Just s) } + +-- | Phase 9 B: bar の position adjustment (= ggplot `position`)。 +-- 群分け (= color/group aesthetic) があるとき 'PosDodge' / 'PosStack' / 'PosFill' で +-- 並べ方を選ぶ。 既定 ('PosIdentity') は従来通り単色棒 (color を見ない)。 +-- +-- > bar "cat" "y" <> colorBy "grp" <> position PosDodge +position :: Position -> Layer +position p = mempty { lyPosition = Last (Just p) } + +-- | Phase 30 A3: 固定 shape (= layer 全体に適用・ggplot @shape=@)。 bare=固定。 +-- 'shapeBy' (列で map) より優先される ('pointShapeAt' 参照)。 +shape :: MarkShape -> Layer +shape s = mempty { lyShape = Last (Just s) } + +-- | C-6: shape categorical encoding 列。 +shapeBy :: ColRef -> Layer +shapeBy c = mempty { lyShapeBy = Last (Just c) } + +-- | C-6: cat 名 → MarkShape 1 件追加 (= 複数 entry は <> で合成)。 +shapeMapEntry :: Text -> MarkShape -> Layer +shapeMapEntry v s = mempty { lyShapeMap = [ ShapeMapEntry { smeValue = v, smeShape = s } ] } + +-- | C-6: size continuous encoding 列。 +sizeBy :: ColRef -> Layer +sizeBy c = mempty { lySizeBy = Last (Just c) } + +-- | Phase 30 A8: alpha (= 不透明度) を連続値の列で encode する (= ggplot @scale_alpha@・ +-- @aes(alpha = col)@)。 列値 min..max を alpha @[0.1, 1.0]@ に線形 map (ggplot 既定 range)。 +-- 固定 alpha は bare 'alpha' (案2 = bare 固定 / `*By` = map)。 +-- +-- > scatter "x" "y" <> alphaBy "weight" +alphaBy :: ColRef -> Layer +alphaBy c = mempty { lyAlphaBy = Last (Just c) } + +-- | Phase 11 A4-b: 固定 linetype (= ggplot linetype="dashed")。 line 系 mark に適用。 +-- 例: @line "x" "y" <> linetype LtDashed@ +linetype :: LineType -> Layer +linetype lt = mempty { lyLinetype = Last (Just lt) } + +-- | Phase 11 A4-b: categorical linetype encoding 列 (= ggplot linetype=factor(g))。 +-- line を群ごとに分割し各群へ巡回 LineType ('lineTypeForIndex') を割当。 +-- 例: @line "x" "y" <> linetypeBy (ColByName "grp")@ +linetypeBy :: ColRef -> Layer +linetypeBy c = mempty { lyLinetypeBy = Last (Just c) } + +-- | C-step trellis 色一貫性: 全データ cat 出現順を Layer に注入。 +colorCats :: [Text] -> Layer +colorCats cs = mempty { lyColorCats = cs } + +-- | Phase 28: categorical 水準の既定順 (= ggplot2 の factor 既定 = アルファベット順)。 +-- 色 / x 軸 / shape の distinct を取るときに使い、 R4DS と凡例・色・並びを一致させる。 +-- 明示順が要るとき (fct_infreq 等) は 'colorCats' / 'xCatOrder' で上書きする。 +orderedCats :: [Text] -> [Text] +orderedCats = Data.List.sort . Data.List.nub + +-- | Phase 26 §C-2 #8: 列の平均値を水平線として描画 (= PlotConfig.showMean)。 +statMean :: ColRef -> Layer +statMean c = mempty + { lyKind = First (Just MStatMean), lyEncY = Last (Just c) } + +-- | Phase 26 §C-2 #8: 列の中央値を水平線として描画 (= PlotConfig.showMedian)。 +statMedian :: ColRef -> Layer +statMedian c = mempty + { lyKind = First (Just MStatMedian), lyEncY = Last (Just c) } + +-- | Phase 26 §C-2 #13: parallel coordinates plot。 各 col が縦軸となり、 +-- 各 row を全軸 cross する折線で表現。 hover で row 強調 (= 後追い)。 +parallelCoords :: [ColRef] -> Layer +parallelCoords cols = mempty + { lyKind = First (Just MParallel), lyHover = cols } + +-- | Phase 26 §E-6: HBM ModelGraph DAG を描画する layer。 +-- 内部 builder で使う直接 constructor。 ユーザは 'Graphics.Hgg.DAG.dagPlot' +-- (= Graph a + ~> 経由) を使う方が良い。 +dagFromLists :: [DAGNode] -> [DAGEdge] -> DAGLayoutAlgorithm -> Layer +dagFromLists nodes edges algo = mempty + { lyKind = First (Just MDAG) + , lyDAG = Last (Just (DAGSpec nodes edges algo [])) } + +-- | dsPlates も指定する版。 +dagFromListsWithPlates + :: [DAGNode] -> [DAGEdge] -> DAGLayoutAlgorithm -> [DAGPlate] -> Layer +dagFromListsWithPlates nodes edges algo plates = mempty + { lyKind = First (Just MDAG) + , lyDAG = Last (Just (DAGSpec nodes edges algo plates)) } + +-- | DAGNode constructor (= kind + 分布名なし)。 +dagNode :: Text -> Text -> DAGNodeKind -> Double -> Double -> DAGNode +dagNode i l k x y = DAGNode i l k Nothing x y + +-- | 分布名付き DAGNode constructor (= PyMC 風 "name ~ dist" 表示用)。 +dagNodeDist :: Text -> Text -> DAGNodeKind -> Text -> Double -> Double -> DAGNode +dagNodeDist i l k dist x y = DAGNode i l k (Just dist) x y + +-- | DAGEdge constructor。 +dagEdge :: Text -> Text -> DAGEdge +dagEdge f t = DAGEdge f t Nothing Nothing + +-- | 互換用 shortcut: 既存 demo / test 用 (= NodeLatent + LayoutManual)。 +-- 新規 API は Graphics.Hgg.DAG.dagPlot を使う。 +dag :: [DAGNode] -> [DAGEdge] -> Layer +dag nodes edges = dagFromLists nodes edges LayoutManual + +-- | Phase 26 §E-1: MCMC trace plot (single chain)。 iteration vs parameter +-- 値の line。 mark kind は MTrace (= alias for MLine、 frontend で区別可能)。 +trace :: ColRef -> ColRef -> Layer +trace iterCol valCol = mempty + { lyKind = First (Just MTrace) + , lyEncX = Last (Just iterCol) + , lyEncY = Last (Just valCol) + } + +-- | Phase 26 §E-1: multi-chain trace。 chain 列で色分け、 connect group も +-- chain 列 (= chain 内で連結、 chain 跨ぎ無し)。 PlotConfig.StreamingTracePlot 等価。 +traceLines :: ColRef -> ColRef -> ColRef -> Layer +traceLines iterCol valCol chainCol = + trace iterCol valCol + <> colorBy chainCol + <> connectGroup chainCol + <> stroke 1.0 + diff --git a/src/Graphics/Hgg/Spec/CustomMark.hs b/src/Graphics/Hgg/Spec/CustomMark.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/CustomMark.hs @@ -0,0 +1,75 @@ +-- | +-- Module : Graphics.Hgg.Spec.CustomMark +-- Description : custom mark の payload 型 (RenderCtx / CustomMark、 Phase 51) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出した leaf。 Phase 51 の +-- custom mark 拡張点のうち **型** ('RenderCtx' / 'CustomMark') のみを持つ +-- (smart constructor 'customMark' 等は 'Graphics.Hgg.Spec.Constructors' 側)。 +-- 依存は 'Graphics.Hgg.Spec.Column' ('Resolver') と 'Graphics.Hgg.Primitive'。 +-- 公開 API は従来どおり 'Graphics.Hgg.Spec' (facade) が re-export する。 +-- 挙動・出力 (JSON 形含む) は完全に不変。 +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.CustomMark + ( RenderCtx(..) + , CustomMark(..) + ) where + +import Data.Aeson (FromJSON, ToJSON, toJSON, parseJSON, + Value) +import qualified Data.Aeson as Aeson +import Data.Text (Text) + +import Graphics.Hgg.Primitive (Primitive, Rect (..)) +import Graphics.Hgg.Spec.Column (Resolver) + +-- =========================================================================== +-- Phase 51: custom mark (拡張可能な描画語彙) +-- =========================================================================== + +-- | custom mark の draw closure に渡す描画文脈。 backend 非依存。 scale 適用済の +-- projection・plot 領域 (px)・データ resolver・theme 既定色を提供する。 これと +-- ("Graphics.Hgg.Render" が re-export する) 'Primitive' 構築子が custom mark の +-- authoring API。 +data RenderCtx = RenderCtx + { rcProjectXY :: !(Double -> Double -> (Double, Double)) -- ^ データ座標 (x,y) → device px + , rcPlotArea :: !Rect -- ^ plot 描画領域 (px) + , rcResolver :: !Resolver -- ^ 列名 → データ (layer 束縛列を引く) + , rcColor :: !Text -- ^ theme 既定の線/点色 + , rcFill :: !Text -- ^ theme 既定の塗り色 + , rcTextColor :: !Text -- ^ theme 既定の文字色 + , rcAxisColor :: !Text -- ^ theme 既定の軸色 + } + +-- | custom mark の payload。 'lyCustom' に載る。 +-- +-- * 'cmDraw' は HS の描画 closure。 データは closure に閉じ込め可。 __serialize 不能__ +-- ゆえ JSON では落ち、 decode 時は no-op (@const []@) に戻る。 PS は 'cmId' で自前 +-- registry を引いて描く (parity 手登録)。 +-- * 'cmOptions' は PS へ渡す必要のある serializable option (任意)。 +-- +-- 'Eq' / 'Show' は closure を無視し 'cmId' + 'cmOptions' で比較 (function は比較不能ゆえ)。 +data CustomMark = CustomMark + { cmId :: !Text -- ^ 安定 mark 識別子 (PS dispatch の鍵・serialize される) + , cmOptions :: !Value -- ^ PS へ渡す option (JSON・任意) + , cmDraw :: !(RenderCtx -> [Primitive]) -- ^ HS 描画 closure (JSON 非対象) + } + +instance Show CustomMark where + show cm = "CustomMark " <> show (cmId cm) + +instance Eq CustomMark where + a == b = cmId a == cmId b && cmOptions a == cmOptions b + +-- closure は落とし 'cmId' + 'cmOptions' のみ serialize。 +instance ToJSON CustomMark where + toJSON cm = Aeson.object [ "cmId" Aeson..= cmId cm, "cmOptions" Aeson..= cmOptions cm ] + +-- decode では closure を復元できないので no-op に戻す (HS は live 値を使い、 PS は registry)。 +instance FromJSON CustomMark where + parseJSON = Aeson.withObject "CustomMark" $ \o -> + CustomMark <$> o Aeson..: "cmId" + <*> o Aeson..:? "cmOptions" Aeson..!= Aeson.Null + <*> pure (const []) + diff --git a/src/Graphics/Hgg/Spec/Decoration.hs b/src/Graphics/Hgg/Spec/Decoration.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Decoration.hs @@ -0,0 +1,201 @@ +-- | +-- Module : Graphics.Hgg.Spec.Decoration +-- Description : 図の装飾 spec (ReferenceLine / Annotation / Marginal / Legend / Font) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 図に載せる装飾の +-- 宣言型 spec 群 ('ReferenceLine' / 'Annotation' / 'MarginalSpec' / +-- 'LegendSpec' / 'FontSpec') を持つ。 ※'Inset' は 'VisualSpec' と相互参照の +-- ため 'Graphics.Hgg.Spec.Visual' 側 (Phase 55 A1 実測)。 公開 API は従来どおり +-- 'Graphics.Hgg.Spec' (facade) が re-export する。 挙動・出力は完全に不変。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Decoration + ( -- * ReferenceLine / Annotation + ReferenceLine(..) + , Annotation(..) + -- * Marginal / Legend + , MarginalKind(..) + , MarginalSpec(..) + , defaultMarginalSpec + , LegendPosition(..) + , LegendSpec(..) + , defaultLegendSpec + -- * FontSpec + , FontSpec(..) + , emptyFontSpec + , fontSize, fontFamily, fontWeight, fontItalic, fontColor + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Monoid (Last (..)) +import Data.Text (Text) +import GHC.Generics (Generic, Generically (..)) + +import Graphics.Hgg.Unit (Pos (..)) + +-- =========================================================================== +-- ReferenceLine (= Phase 26 §C-2 #3: 既存 PlotConfig.referenceLine 等価) +-- =========================================================================== + +-- | plot area 内に重ねる参照線。 +-- * 'RefIdentity' ─ y = x の対角線 (= Actual vs Predicted) +-- * 'RefHorizontalAt c' ─ y = c +-- * 'RefVerticalAt c' ─ x = c +-- * 'RefLinear slope intercept' ─ y = slope * x + intercept +data ReferenceLine + = RefIdentity + | RefHorizontalAt !Double + | RefVerticalAt !Double + | RefLinear { rlSlope, rlIntercept :: !Double } + deriving (Show, Eq, Generic) + +instance ToJSON ReferenceLine +instance FromJSON ReferenceLine + +-- =========================================================================== +-- Annotation (= P6、 2026-05-25 任意 overlay) +-- =========================================================================== + +-- ★ Phase 33 B6: 注釈の座標は 'Pos' (native/npc/絶対長を軸ごとに混在指定可)。 +-- 旧 'AnnotCoord' (Data/Frac) は Pos に統一して撤去 (Frac は HS 描画で未実装だった)。 +-- AnnRect は w/h でなく 2 隅 (x1,y1)-(x2,y2) の Pos で表す (座標一貫)。 +data Annotation + = AnnText + { anX :: !Pos, anY :: !Pos + , anText :: !Text + , anColor :: !Text, anSize :: !Double } + | AnnArrow + { anX1 :: !Pos, anY1 :: !Pos + , anX2 :: !Pos, anY2 :: !Pos + , anColor :: !Text, anWidth :: !Double } + | AnnRect + { anX1 :: !Pos, anY1 :: !Pos + , anX2 :: !Pos, anY2 :: !Pos + , anFill :: !Text, anStroke :: !Text + , anStrokeWidth :: !Double, anFillOpacity :: !Double } + | AnnLine + { anX1 :: !Pos, anY1 :: !Pos + , anX2 :: !Pos, anY2 :: !Pos + , anColor :: !Text, anWidth :: !Double } + deriving (Show, Eq, Generic) + +instance ToJSON Annotation +instance FromJSON Annotation + +-- =========================================================================== +-- MarginalSpec (= Phase 26 §C-2 #10 周辺 histogram) +-- =========================================================================== + +-- | P9: marginal の種別 (hist / density / 重ね)。 +data MarginalKind = MarginalHist | MarginalDensity | MarginalBoth + deriving (Show, Eq, Generic) + +instance ToJSON MarginalKind +instance FromJSON MarginalKind + +-- | scatter の周辺に X/Y histogram を sub-plot として配置するか。 +data MarginalSpec = MarginalSpec + { msShowX :: !Bool + , msShowY :: !Bool + , msBins :: !Int -- bin 数 (= default 20) + , msKind :: !MarginalKind -- ★ P9 hist / density / 重ね + } deriving (Show, Eq, Generic) + +instance ToJSON MarginalSpec +instance FromJSON MarginalSpec + +-- ★ Phase 43 A3: レコードフィールド形式 (位置依存撲滅・挙動不変)。全 field が非 Monoid +-- (Bool/Int/enum) なので合成は名前付きで明示: show は OR・bins は max・kind は後勝ち。 +instance Semigroup MarginalSpec where + a <> b = MarginalSpec + { msShowX = msShowX a || msShowX b + , msShowY = msShowY a || msShowY b + , msBins = max (msBins a) (msBins b) + , msKind = msKind b -- 後勝ち + } + +instance Monoid MarginalSpec where + mempty = defaultMarginalSpec + +defaultMarginalSpec :: MarginalSpec +defaultMarginalSpec = MarginalSpec False False 20 MarginalHist + +-- =========================================================================== +-- LegendSpec (= P8、 2026-05-25 凡例設定) +-- =========================================================================== + +data LegendPosition + = LegendRight | LegendBottom | LegendNone + | LegendInsideTopRight | LegendInsideTopLeft + | LegendInsideBottomRight | LegendInsideBottomLeft + -- ★ Phase 32 (re-apply): 外・右に置きつつ panel 高の縦中央に揃える (ggplot 既定の + -- legend.position="right" は縦中央寄せ)。 LegendRight=上揃えは不変・これは opt-in。 + | LegendRightCenter + deriving (Show, Eq, Generic) + +instance ToJSON LegendPosition +instance FromJSON LegendPosition + +data LegendSpec = LegendSpec + { lgPosition :: !LegendPosition + , lgTitle :: !(Last Text) + } deriving (Show, Eq, Generic) + +instance ToJSON LegendSpec +instance FromJSON LegendSpec + +-- ★ Phase 43 A3: レコードフィールド形式 (位置依存撲滅・挙動不変)。lgPosition は非 Monoid +-- enum なので後勝ち、 lgTitle は素直な `Last` 合成。 +instance Semigroup LegendSpec where + a <> b = LegendSpec + { lgPosition = lgPosition b -- 後勝ち (enum) + , lgTitle = lgTitle a <> lgTitle b + } + +instance Monoid LegendSpec where + mempty = defaultLegendSpec + +defaultLegendSpec :: LegendSpec +defaultLegendSpec = LegendSpec LegendRightCenter mempty -- Phase 43: ggplot 既定 (右・縦中央) + +-- =========================================================================== +-- FontSpec (= hgg-frontend-settings-spec v0.1 §1.3) +-- =========================================================================== + +data FontSpec = FontSpec + { fsFamily :: !(Last Text) + , fsSize :: !(Last Double) + , fsWeight :: !(Last Text) + , fsItalic :: !(Last Bool) -- ★ TODO-10 (2026-05-29): PS parity + , fsColor :: !(Last Text) + } deriving stock (Show, Eq, Generic) + -- ★ Phase 43 A3: 全 field が `Last` の素直な per-field 合成なので generic 導出 + -- (= 手書き instance ゼロ・field 追加に強い)。挙動は旧手書きと完全同型。 + deriving (Semigroup, Monoid) via Generically FontSpec + +instance ToJSON FontSpec +instance FromJSON FontSpec + +-- | 空 'FontSpec' (= 'mempty' alias、 generic 導出の mempty と同値)。 +emptyFontSpec :: FontSpec +emptyFontSpec = mempty + +fontSize :: Double -> FontSpec +fontSize n = emptyFontSpec { fsSize = Last (Just n) } + +fontFamily :: Text -> FontSpec +fontFamily f = emptyFontSpec { fsFamily = Last (Just f) } + +fontWeight :: Text -> FontSpec +fontWeight w = emptyFontSpec { fsWeight = Last (Just w) } + +fontItalic :: Bool -> FontSpec +fontItalic b = emptyFontSpec { fsItalic = Last (Just b) } + +fontColor :: Text -> FontSpec +fontColor c = emptyFontSpec { fsColor = Last (Just c) } + diff --git a/src/Graphics/Hgg/Spec/Layer.hs b/src/Graphics/Hgg/Spec/Layer.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Layer.hs @@ -0,0 +1,333 @@ +-- | +-- Module : Graphics.Hgg.Spec.Layer +-- Description : Layer (内側 Monoid) 本体 + layer-local attribute setter +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 1 layer の全 field を +-- 持つ 'Layer' record と field-wise Monoid ('lyKind' のみ First・後は Last/concat、 +-- @design/monoid-semantics.md@ §1)、 および「直前の 'Layer' に @<>@ する」 +-- layer-local setter ('colorBy' / 'alpha' / 'size' / 'connect' 系等) を持つ。 +-- mark ごとの構築子は 'Graphics.Hgg.Spec.Constructors' 側。 公開 API は従来どおり +-- 'Graphics.Hgg.Spec' (facade) が re-export する。 挙動・出力 (JSON 形含む) は +-- 完全に不変。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Layer + ( -- * Layer (内側 Monoid) + Layer(..) + -- * layer-local attribute setter + , colorBy + , distGroupRef + , distDodgeRef + , color + , colorRGBA + , colorRGBAMaybe + , colorContinuousBy + , alpha + , size + , stroke + , edgeOn + , edge + , edgeWidth + , hoverCols + , errorX + , errorY + , connect + , connectOrder + , connectGroup + , connectColor + , connectWidth + ) where + +import Data.Aeson (FromJSON, ToJSON, toJSON, parseJSON, + Value (Object)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Graphics.Hgg.Color (Color, fromHexA, fromHexAMaybe, toCss) +import Graphics.Hgg.Unit (Length, lengthToPt) +import Graphics.Hgg.Spec.Column (ColRef) +import Graphics.Hgg.Spec.CustomMark (CustomMark) +import Graphics.Hgg.Spec.Mark + +-- =========================================================================== +-- Layer (= 内側 Monoid) +-- =========================================================================== + +-- | 1 layer の全 field。 各 field を 'First' (= kind は最初勝ち) または +-- 'Last' (= 属性は後勝ち) で包んで Monoid を field-wise に。 +data Layer = Layer + { lyKind :: !(First MarkKind) + , lyEncX :: !(Last ColRef) + , lyEncY :: !(Last ColRef) + , lyColor :: !(Last ColorEnc) + , lyAlpha :: !(Last Double) + , lySize :: !(Last Double) + , lyStroke :: !(Last Double) + , lyHover :: ![ColRef] -- ★ Phase 26 §C-2 #4 multi-col tooltip + , lyConnect :: !(Last ConnectSpec) -- ★ Phase 26 §C-2 #5 connect points + , lyErrorX :: !(Last ColRef) -- ★ Phase 26 §C-2 #6 ± 半幅 X + , lyErrorY :: !(Last ColRef) -- ★ Phase 26 §C-2 #6 ± 半幅 Y + , lyEncY2 :: !(Last ColRef) -- ★ TODO-11: MBand 用 upper y + , lyDAG :: !(Last DAGSpec) -- ★ Phase 26 §E-6 HBM ModelGraph + , lyJitterX :: !(Last Double) -- ★ P14 jitter X (plotArea 比率) + , lyJitterY :: !(Last Double) -- ★ P14 jitter Y + , lyYAxisSide :: !(Last YAxisSide) -- ★ P5 どちら Y 軸か + , lyBinCount :: !(Last Int) -- ★ frontend-settings v0.1 §2.4 hist bin 数 + , lyBinWidth :: !(Last Double) -- ★ Phase 28: histogram の bin 幅 (= ggplot binwidth)。 binCount より優先 + , lyShape :: !(Last MarkShape) -- ★ Phase 30 A3: 固定 shape (bare=固定・lyShapeBy より優先) + , lyShapeBy :: !(Last ColRef) -- ★ C-6 categorical shape encoding 列 + , lyShapeMap :: ![ShapeMapEntry] -- ★ C-6 cat → shape 上書き + , lySizeBy :: !(Last ColRef) -- ★ C-6 continuous size encoding 列 + , lyAlphaBy :: !(Last ColRef) -- ★ Phase 30 A8 continuous alpha encoding 列 + , lyColorCats :: ![Text] -- ★ trellis 色一貫性 (= 全 data cat 順) + , lyHistDensity :: !(Last Bool) -- ★ TODO-3a (2026-05-29): histogram を density 正規化 + , lyHistBorder :: !(Last Bool) -- ★ Phase 8 B7: histogram/bar の bin 境界線 (= default False) + , lyDensityFill :: !(Last Bool) -- ★ Phase 28: density 曲線下を塗る (= ggplot geom_density(aes(fill=)))。 alpha と併用 + , lyHollow :: !(Last Bool) -- ★ Phase 34: 中抜きマーカー (= ggplot shape="circle open"/fill=NA)。 塗り透明 + 点色 stroke + , lyNudge :: !(Last Double) -- ★ Phase 36 D1: 分布 mark の slot 内横 offset (slot 幅比、 ggplot position_nudge 相当) + , lyMarkWidth :: !(Last Double) -- ★ Phase 36 D1: 分布 mark の幅 (slot 幅比・占有率)。 各 mark の既定占有率を上書き + , lySide :: !(Last Side) -- ★ Phase 36 D1: violin の片側化 (= 半 violin)。 既定 Both + , lyMaxLag :: !(Last Int) -- ★ Phase 6 A4 autocorr max lag (= default 40) + , lyChain :: !(Last ColRef) -- ★ Phase 6 A5 chain group 列 (ESS / trace で chain 分け) + , lyDensityNorm :: !(Last Bool) -- ★ Phase 8 B16: pairs 対角用。 y 軸 = 値範囲、 KDE は panel 高さに独立正規化 + , lyPosition :: !(Last Position) -- ★ Phase 9 B: bar position adjustment (dodge/stack/fill、 既定 identity) + , lyLinetype :: !(Last LineType) -- ★ Phase 11 A4-b: 固定 linetype (= ggplot linetype=) + , lyLinetypeBy :: !(Last ColRef) -- ★ Phase 11 A4-b: categorical linetype scale 列 + , lyLabel :: !(Last ColRef) -- ★ Phase 11 A6: geom_text/label のラベル列 (各点の文字) + , lyStatLevel :: !(Last Double) -- ★ Phase 16 B1: stat 回帰の信頼水準 (= 既定 0.95)。 MStat* 解決時のみ意味を持つ + , lyContourLevels :: !(Last Int) -- ★ Phase 24 A4: 等高線の本数 (既定 8)。 MContour/MContourFilled 用 + , lyContourBreaks :: !(Last [Double]) -- ★ Phase 24 A4: 等高線レベルの明示指定 (本数指定より優先) + , lyEncU :: !(Last ColRef) -- ★ Phase 26 A2: vector field (quiver) の u 成分列 + , lyEncV :: !(Last ColRef) -- ★ Phase 26 A2: vector field (quiver) の v 成分列 + , lyArrowScale :: !(Last Double) -- ★ Phase 26 A2: quiver 矢印長の倍率 (autoscale × この値・既定 1) + , lyArrowMagnitude :: !(Last Bool) -- ★ Phase 26 A2: quiver を magnitude (|u,v|) で連続色マップ (既定 False) + , lyEdge :: !(Last Bool) -- ★ Phase 28: 散布点の縁を描くか (既定 False = 縁なし、 ggplot 塗り点 shape 19 相当) + , lyEdgeColor :: !(Last Text) -- ★ Phase 28: 縁の色 (未指定なら点と同色) + , lyEdgeWidth :: !(Last Double) -- ★ Phase 28: 縁の幅 px (既定 1.0) + , lyOverlay :: ![Layer] -- ★ Phase 36 D2: 同一 layer 内に重畳する追加 sub-mark + -- (= '<+>' で蓄積)。 各 sub は自前の kind/nudge/markWidth/side + -- を持ち、 親の群 (encX)・色 (colorBy)・値 (encY) を継承して描かれる。 + -- raincloud = (半 violin <+> box <+> strip) の preset。 + , lyCustom :: !(Last CustomMark) -- ★ Phase 51: custom mark payload (MCustom 用・id/options/draw closure) + } deriving (Generic, Show, Eq) + +instance ToJSON Layer +-- ★ Phase 36 D2: lyOverlay は後付けフィールドゆえ、 旧 JSON (= gallery specs/**.json 等) に +-- キーが無くても [] として decode できるよう、 generic parse の前に欠損キーを補う。 +instance FromJSON Layer where + parseJSON v = case v of + -- ★ Phase 36 D2 / Phase 51: 後付けフィールド (lyOverlay/lyCustom) が旧 JSON に無くても + -- decode できるよう、 generic parse の前に欠損キーを既定値で補う。 + Object o -> + let o1 = if KM.member "lyOverlay" o then o + else KM.insert "lyOverlay" (toJSON ([] :: [Layer])) o + o2 = if KM.member "lyCustom" o1 then o1 + else KM.insert "lyCustom" Aeson.Null o1 + in Aeson.genericParseJSON Aeson.defaultOptions (Object o2) + _ -> Aeson.genericParseJSON Aeson.defaultOptions v + +-- | 1 layer 内の属性合成。 'lyKind' のみ 'First' (= 最初の mark が勝ち、 後続の +-- mark は消える点に注意 ─ 重畳は 'layer' で包んで合成する。 @design/monoid-semantics.md@ +-- §1 参照)。 lyHover/lyShapeMap は concat、 lyColorCats は last-nonempty、 残りは 'Last'。 +-- Phase 26 A2: field 数が多く positional 列挙は取り違えやすいので record 構文で +-- per-field '(<>)' する (= Layer3D が Phase 25 A3 で行った変更と同方針)。 挙動は +-- 旧 positional 版と同一: 'lyKind' は First (= 最初の mark 勝ち)、 'lyHover'/ +-- 'lyShapeMap' は list concat ('(<>)')、 'lyColorCats' は last-nonempty、 残りは Last。 +instance Semigroup Layer where + a <> b = Layer + { lyKind = lyKind a <> lyKind b + , lyEncX = lyEncX a <> lyEncX b + , lyEncY = lyEncY a <> lyEncY b + , lyColor = lyColor a <> lyColor b + , lyAlpha = lyAlpha a <> lyAlpha b + , lySize = lySize a <> lySize b + , lyStroke = lyStroke a <> lyStroke b + , lyHover = lyHover a <> lyHover b + , lyConnect = lyConnect a <> lyConnect b + , lyErrorX = lyErrorX a <> lyErrorX b + , lyErrorY = lyErrorY a <> lyErrorY b + , lyEncY2 = lyEncY2 a <> lyEncY2 b + , lyDAG = lyDAG a <> lyDAG b + , lyJitterX = lyJitterX a <> lyJitterX b + , lyJitterY = lyJitterY a <> lyJitterY b + , lyYAxisSide = lyYAxisSide a <> lyYAxisSide b + , lyBinCount = lyBinCount a <> lyBinCount b + , lyBinWidth = lyBinWidth a <> lyBinWidth b + , lyShape = lyShape a <> lyShape b + , lyShapeBy = lyShapeBy a <> lyShapeBy b + , lyShapeMap = lyShapeMap a <> lyShapeMap b + , lySizeBy = lySizeBy a <> lySizeBy b + , lyAlphaBy = lyAlphaBy a <> lyAlphaBy b + , lyColorCats = if null (lyColorCats b) then lyColorCats a else lyColorCats b + , lyHistDensity = lyHistDensity a <> lyHistDensity b + , lyHistBorder = lyHistBorder a <> lyHistBorder b + , lyDensityFill = lyDensityFill a <> lyDensityFill b + , lyHollow = lyHollow a <> lyHollow b + , lyNudge = lyNudge a <> lyNudge b + , lyMarkWidth = lyMarkWidth a <> lyMarkWidth b + , lySide = lySide a <> lySide b + , lyMaxLag = lyMaxLag a <> lyMaxLag b + , lyChain = lyChain a <> lyChain b + , lyDensityNorm = lyDensityNorm a <> lyDensityNorm b + , lyPosition = lyPosition a <> lyPosition b + , lyLinetype = lyLinetype a <> lyLinetype b + , lyLinetypeBy = lyLinetypeBy a <> lyLinetypeBy b + , lyLabel = lyLabel a <> lyLabel b + , lyStatLevel = lyStatLevel a <> lyStatLevel b + , lyContourLevels = lyContourLevels a <> lyContourLevels b + , lyContourBreaks = lyContourBreaks a <> lyContourBreaks b + , lyEncU = lyEncU a <> lyEncU b + , lyEncV = lyEncV a <> lyEncV b + , lyArrowScale = lyArrowScale a <> lyArrowScale b + , lyArrowMagnitude = lyArrowMagnitude a <> lyArrowMagnitude b + , lyEdge = lyEdge a <> lyEdge b + , lyEdgeColor = lyEdgeColor a <> lyEdgeColor b + , lyEdgeWidth = lyEdgeWidth a <> lyEdgeWidth b + , lyOverlay = lyOverlay a <> lyOverlay b -- ★ Phase 36 D2: sub-mark を concat + , lyCustom = lyCustom a <> lyCustom b -- ★ Phase 51: custom mark payload (Last) + } + +instance Monoid Layer where + mempty = Layer + { lyKind = mempty, lyEncX = mempty, lyEncY = mempty, lyColor = mempty + , lyAlpha = mempty, lySize = mempty, lyStroke = mempty, lyHover = [] + , lyConnect = mempty, lyErrorX = mempty, lyErrorY = mempty, lyEncY2 = mempty + , lyDAG = mempty, lyJitterX = mempty, lyJitterY = mempty, lyYAxisSide = mempty + , lyBinCount = mempty, lyBinWidth = mempty, lyShape = mempty, lyShapeBy = mempty, lyShapeMap = [], lySizeBy = mempty + , lyAlphaBy = mempty + , lyColorCats = [], lyHistDensity = mempty, lyHistBorder = mempty + , lyDensityFill = mempty, lyHollow = mempty + , lyNudge = mempty, lyMarkWidth = mempty, lySide = mempty + , lyMaxLag = mempty, lyChain = mempty, lyDensityNorm = mempty + , lyPosition = mempty, lyLinetype = mempty, lyLinetypeBy = mempty + , lyLabel = mempty, lyStatLevel = mempty, lyContourLevels = mempty + , lyContourBreaks = mempty, lyEncU = mempty, lyEncV = mempty + , lyArrowScale = mempty, lyArrowMagnitude = mempty + , lyEdge = mempty, lyEdgeColor = mempty, lyEdgeWidth = mempty + , lyOverlay = [] + , lyCustom = mempty + } + +-- =========================================================================== +-- Layer-local attribute (= 直前の Layer に <>) +-- =========================================================================== + +-- | 列で色分け encoding (= categorical / continuous は ColRef 種別による)。 +-- Phase 30 案2: map 系は @*By@ 接尾辞 ('color' は固定色に明け渡し)。 +colorBy :: ColRef -> Layer +colorBy c = mempty { lyColor = Last (Just (ColorByCol c)) } + +-- | Phase 36 B1b: distribution mark の「群分け列」。 明示の 'lyEncX' があればそれを +-- 群列とし、 無ければ 'colorBy' (= 'ColorByCol') の列を群列とみなす。 これにより +-- @boxplot "v" <> colorBy "g"@ が scatter と同様に群分割される (従来は encX 専用で +-- colorBy 単体だと単一群になっていた)。 distribution renderer と +-- 'collectCategoricalLabels' (distribution 限定) が共有する。 +distGroupRef :: Layer -> Maybe ColRef +distGroupRef ly = case getLast (lyEncX ly) of + Just cr -> Just cr + Nothing -> case getLast (lyColor ly) of + Just (ColorByCol cr) -> Just cr + _ -> Nothing + +-- | Phase 36 B2: distribution mark の dodge 検出。 @groupBy@ (= 'lyEncX' = 位置列) と +-- @colorBy@ (= 'lyColor' の 'ColorByCol' = 色列) が **両方** 指定され、 かつ別列の +-- とき @Just (位置列, 色列)@。 このとき各位置カテゴリ内で色サブグループを横並び +-- (= ggplot @position_dodge@) する。 同一列 (groupBy と colorBy が同じ) のときは +-- dodge せず単一群彩色のまま (= 'distGroupRef' 経路) なので 'Nothing'。 +distDodgeRef :: Layer -> Maybe (ColRef, ColRef) +distDodgeRef ly = case (getLast (lyEncX ly), getLast (lyColor ly)) of + (Just posC, Just (ColorByCol colC)) + -- ★ 同一列 (groupBy と colorBy が同じ列) は dodge せず単一群彩色のまま。 判定は + -- ColRef の構造比較 (inline 列は 'colRefName' が両方 "<inline-*>" に潰れるため + -- 名前比較では別列を取り違える)。 + | posC /= colC -> Just (posC, colC) + _ -> Nothing + +-- | 静的色 (layer 全体に適用)。 Phase 30 案2: 固定色 aesthetic は bare 名 'color'。 +-- 'Color' 型 (RGB / 'fromHex' / R 657 名前付き定数) を受け、 ワイヤは 'toCss' で Text 化。 +color :: Color -> Layer +color c = mempty { lyColor = Last (Just (ColorStatic (toCss c))) } + +-- | 便利関数: 8 桁 RGBA hex (@"#rrggbbaa"@ / 4 桁 @"#rgba"@) を 1 つで受け、 +-- @color (fromHex …) <> alpha …@ に展開する ('fromHexA' 経由)。 design ツール / +-- Web 由来の RGBA hex をそのまま貼れる。 ★@Color@ は RGB のみゆえ alpha は別 channel +-- に分離される (後続の @<> alphaBy "col"@ 等は 'Last' で後勝ち)。 不正入力は 'error' +-- (total 版は 'colorRGBAMaybe')。 6/3 桁 (alpha 無し) は不透明として扱う。 +colorRGBA :: Text -> Layer +colorRGBA t = let (c, a) = fromHexA t in color c <> alpha a + +-- | 'colorRGBA' の total 版。 不正な hex は 'Nothing'。 +colorRGBAMaybe :: Text -> Maybe Layer +colorRGBAMaybe t = (\(c, a) -> color c <> alpha a) <$> fromHexAMaybe t + +-- | Phase 26 §C-2 #9: 連続値 column を Viridis 風 gradient で色分け。 +-- Phase 30 案2: map 系ゆえ @*By@ 接尾辞。 +colorContinuousBy :: ColRef -> Layer +colorContinuousBy c = mempty { lyColor = Last (Just (ColorByContinuous c)) } + +-- | 透過度 (0..1)。 これは無次元なので 'Double' のまま。 +alpha :: Double -> Layer +alpha a = mempty { lyAlpha = Last (Just a) } + +-- | マーカー径 ('size') / 線幅 ('stroke') を 'Length' で指定 (Phase 34 A4)。 +-- bare 数値リテラルは @Num Length@ 経由で **pt** (@size 6@ = 6pt 直径)。 別単位は +-- @size (2 *~ mm)@。 内部は pt の 'Double' に解決して保持する (px は描画 dpi が +-- 確定する前なので、 例外的に 96dpi で pt 化する = マーカーに px 指定は非推奨)。 +size, stroke :: Length -> Layer +size s = mempty { lySize = Last (Just (lengthToPt 96 s)) } +stroke s = mempty { lyStroke = Last (Just (lengthToPt 96 s)) } + +-- | Phase 28: 散布点に縁 (edge) を付ける。 既定は縁なし (= ggplot の塗り点 shape 19)。 +-- 'edgeOn' は点と同色の 1px 縁、 'edge col' は色を指定、 'edgeWidth w' は幅を指定 +-- (いずれも縁を有効化)。 縁の透過は色に alpha 付き hex (例 @edge "#00000044"@) で表せる。 +edgeOn :: Layer +edgeOn = mempty { lyEdge = Last (Just True) } + +edge :: Text -> Layer +edge c = mempty { lyEdge = Last (Just True), lyEdgeColor = Last (Just c) } + +edgeWidth :: Double -> Layer +edgeWidth w = mempty { lyEdge = Last (Just True), lyEdgeWidth = Last (Just w) } + +-- | hover tooltip に表示する追加列 (= multi-col)。 +-- +-- > scatter "x" "y" <> hoverCols ["group", "label"] +hoverCols :: [ColRef] -> Layer +hoverCols cs = mempty { lyHover = cs } + +-- | Phase 26 §C-2 #6: 各点の X 方向 ± 半幅 (error bar)。 +errorX :: ColRef -> Layer +errorX c = mempty { lyErrorX = Last (Just c) } + +-- | Phase 26 §C-2 #6: 各点の Y 方向 ± 半幅 (error bar)。 +errorY :: ColRef -> Layer +errorY c = mempty { lyErrorY = Last (Just c) } + +-- | Phase 26 §C-2 #5: scatter 点を線で結ぶ ON。 +-- +-- > scatter "x" "y" <> connect +-- > scatter "x" "y" <> connect <> connectOrder "time" <> connectGroup "id" +connect :: Layer +connect = mempty { lyConnect = Last (Just defaultConnectSpec) } + +connectOrder :: ColRef -> Layer +connectOrder c = mempty + { lyConnect = Last (Just (defaultConnectSpec { csOrder = Last (Just c) })) } + +connectGroup :: ColRef -> Layer +connectGroup c = mempty + { lyConnect = Last (Just (defaultConnectSpec { csGroup = Last (Just c) })) } + +connectColor :: Text -> Layer +connectColor c = mempty + { lyConnect = Last (Just (defaultConnectSpec { csColor = Last (Just c) })) } + +connectWidth :: Double -> Layer +connectWidth w = mempty + { lyConnect = Last (Just (defaultConnectSpec { csWidth = Last (Just w) })) } + diff --git a/src/Graphics/Hgg/Spec/Mark.hs b/src/Graphics/Hgg/Spec/Mark.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Mark.hs @@ -0,0 +1,497 @@ +-- | +-- Module : Graphics.Hgg.Spec.Mark +-- Description : mark 種別 (MarkKind) + DAG 型群 + layer 補助 enum (Spec の leaf) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出した leaf。 幾何種別 +-- 'MarkKind'、 DAG 描画の型群 ('DAGSpec' 一式)、 layer 属性の enum +-- ('ColorEnc' / 'Position' / 'Side' / 'Coord' / facet 系 / 'MarkShape' / +-- 'LineType' 等) を持つ。 依存は 'Graphics.Hgg.Spec.Column' ('ColRef') のみ。 +-- 公開 API は従来どおり 'Graphics.Hgg.Spec' (facade) が re-export する。 +-- 挙動・出力 (JSON tag 含む) は完全に不変。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Mark + ( -- * MarkKind + MarkKind(..) + -- * DAG + , DAGNodeKind(..) + , DAGLayoutAlgorithm(..) + , DAGNode(..) + , EdgeShapeKind(..) + , RoutedEdge(..) + , DAGEdge(..) + , DAGPlate(..) + , DAGSpec(..) + -- * layer 補助 enum / spec + , ConnectSpec(..) + , defaultConnectSpec + , ColorEnc(..) + , YAxisSide(..) + , Position(..) + , Side(..) + , Coord(..) + , FacetScales(..) + , freeScaleX + , freeScaleY + , FacetSpace(..) + , freeSpaceX + , freeSpaceY + -- * shape / linetype + , MarkShape(..) + , ShapeMapEntry(..) + , LineType(..) + , lineTypeDash + , lineTypeForIndex + ) where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as Aeson +import qualified Data.Char as Char +import Data.Monoid (Last (..)) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Graphics.Hgg.Spec.Column (ColRef) + +-- =========================================================================== +-- Layer (= 内側 Monoid) +-- =========================================================================== + +-- | 1 layer の幾何種別。 Phase 26 §A-2 で 12 種列挙、 実 render は §A-5 で +-- 段階追加 (= Scatter / Line / Bar / Histogram を先行)。 +data MarkKind + = MScatter | MLine | MBar | MHistogram | MBox | MHeatmap + -- 統計特化 (Phase 26 §E) + | MTrace | MDensity | MForest | MFunnel + -- Phase 28 (Ch10 EDA): 頻度多角形 (= ggplot geom_freqpoly)。 histogram と同じ + -- bin 化 (histBinning) で各 bin の count を求め、 bin 中心を折れ線で結ぶ。 + -- KDE の MDensity とは別物 (= ビン頻度の折れ線、 滑らかでない)。 lyHistDensity + -- True で after_stat(density) = count/(群N*binW) 正規化 (面積 1)。 color + -- aesthetic で群分割すると群ごとに別色の折れ線を重ねる (MDensity 同方式)。 + | MFreqPoly + -- 半導体特化 (Phase 26 §F) + | MWaferMap | MControl + -- 統計線 (Phase 26 §C-2 #8) + | MStatMean | MStatMedian + -- Parallel coordinates (Phase 26 §C-2 #13) + | MParallel + -- DAG (Phase 26 §E-6 HBM ModelGraph) + | MDAG + -- Pie chart (Phase 26 S4-d) + | MPie + -- Waterfall (Phase 26 S5-c) + | MWaterfall + -- Contour (連続 x/y/z → marching squares の等高線 iso-line) + | MContour + -- Filled contour (等値帯の塗り = matplotlib contourf / ggplot geom_contour_filled。 Phase 24 A4) + | MContourFilled + -- Bin2d (連続 x/y/z → grid binning + セル平均を連続色で塗る = ggplot geom_bin2d) + | MBin2d + -- Tile (連続 x/y のセルを fill 値でベタ塗り = ggplot geom_tile/geom_raster。 1 行=1 セル・ + -- 再ビニングせず格子間隔から幅自動。 決定境界の連続軸塗りが主用途。 Phase 60) + | MTile + -- MCMC 診断 (P19, P20) + | MAutocorr | MEss + -- P11 / P12: stem / step + | MStep | MStem + -- P2 / P3 / P22: distribution 系 + | MViolin | MStrip | MSwarm | MRaincloud + -- P21: ridge / joyplot + | MRidge + -- TODO-11 (2026-05-27): area band (= 信頼区間 / 予測帯、 PPath fill 1 枚) + | MBand + -- 3D placeholder (Phase 26 §C-2 #15、 実装は別 Phase で hgg-3d) + | MScatter3D + -- Phase 11 A6: データ駆動テキストラベル (geom_text / geom_label)。 各 (x,y) 点に + -- lyLabel 列の文字を描く。 MLabel は背景の角丸矩形付き (= ggplot geom_label)。 + | MText | MLabel + -- Phase 11 A6-2: Q-Q plot (= ggplot stat_qq / geom_qq)。 encY = サンプル列。 + -- ソートした order statistic を y、 理論正規分位点 Φ⁻¹((i-0.5)/n) を x に取り + -- scatter 系で描画する (= 正規性の視覚診断)。 + | MQQ + -- Phase 11 A6-4: ECDF (= ggplot stat_ecdf)。 encX = サンプル列。 ソートして + -- 右連続の階段 F(x)=#(≤x)/n を描く (y∈[0,1])。 + | MEcdf + -- Phase 11 A6-4b: 区間 geom (= ggplot geom_linerange / geom_pointrange / geom_crossbar)。 + -- encX=x, encY=y(中心), errorY=半幅 (y±err)。 linerange=縦線のみ、 pointrange=縦線+中心点、 + -- crossbar=幅付き箱 (y±err) + 中央水平線。 + | MLineRange | MPointRange | MCrossbar + -- Phase 16: stat-in (= ggplot stat_smooth(method="lm"/"…"))。 純タグ (回帰 fit は + -- analyze-bridge の resolveStats が hanalyze で行い band+line layer に展開する)。 + -- encX=x, encY=y。 lyColor/lyStroke/lyAlpha 等の装飾はそのまま band/line に引き継がれる。 + -- MStatSmooth の knot 数は lyBinCount を流用。 renderer は MStat* を no-op (skip)。 + | MStatLM | MStatSmooth + -- Phase 16 B3: 多項式回帰 (= ggplot stat_smooth(method="lm", formula=y~poly(x,deg)))。 + -- deg は lyBinCount を流用。 resolveStats が y~poly(x,deg) で fit し band+line に展開。 + -- MStatResid = 残差 vs fitted の診断散布図 (= base R plot(lm) #1)。 fit して + -- (fitted, residual) を scatter に展開する。 いずれも renderer は MStat* を skip。 + | MStatPoly | MStatResid + -- Phase 52.D2: Streamgraph (= 中心化積層 area、 ThemeRiver 風)。 encX=x, encY=y、 + -- color aes で系列分割。 各 x 点で系列 y を積層し baseline を -(Σy)/2 から開始する + -- (silhouette 中心化)。 各系列を renderBand 同型の塗り polygon で描く。 + | MStream + -- Phase 26 A2: vector field (quiver)。 encX=x, encY=y, lyEncU=u, lyEncV=v。 + -- 各 (x,y) に成分 (u,v) の矢印を描く (autoscale × lyArrowScale)。 magnitude + -- 連続色は lyArrowMagnitude。 = matplotlib quiver / geom_segment(arrow=)。 + | MQuiver + -- Phase 28 (Ch10 EDA): 2 カテゴリ変数の件数 (= ggplot geom_count / stat_sum)。 + -- encX/encY はともにカテゴリ列。 各 (x,y) セルの観測件数を集計し、 cell 中心に + -- 面積 ∝ 件数 (= 半径 ∝ √件数) の点を打つ。 lySize で最大半径 px を上書き可。 + | MCount + -- Phase 40: hexbin (六角ビニング = matplotlib hexbin / ggplot geom_hex)。 encX/encY は + -- 連続列。 binwidth 正規化空間で d3-hexbin (Carr 1987) アルゴで点を六角セルに割当て count し、 + -- pointy-top 六角形を count→連続色 (Viridis) で塗る。 セル分割数は lyBinCount を流用 (既定 30)。 + | MHexbin + -- Phase 51: custom mark (拡張可能な描画語彙)。 core を触らず 'customMark' で新プロット型を + -- 足す拡張点。 payload (id/options/draw closure) は 'lyCustom' に持つ。 renderer は + -- 'lyCustom' の 'cmDraw' を呼んで primitive を emit する (= registry 不要・closure が源)。 + | MCustom + deriving (Show, Eq, Generic) + +instance ToJSON MarkKind +instance FromJSON MarkKind + +-- | Phase 26 §E-6: HBM ModelGraph DAG。 +-- node 種別 (= 汎用、 HBM 慣例の latent/observed/deterministic/data を含む)。 +-- 描画形状 (PyMC 慣例): NodeLatent = 白楕円、 NodeObserved = 灰楕円、 +-- NodeDeterministic = 白四角 (Phase 52.A15)、 NodeData = 灰角丸四角、 NodeOther = 四角。 +data DAGNodeKind = NodeLatent | NodeObserved | NodeDeterministic | NodeData | NodeOther + deriving (Show, Eq, Ord, Generic) + +instance ToJSON DAGNodeKind +instance FromJSON DAGNodeKind + +-- | DAG layout algorithm。 +-- * 'LayoutManual' ─ dnX / dnY をそのまま使う +-- * 'LayoutHierarchical' ─ topological sort + 同層 x 均等配置 +-- * 'LayoutForce' ─ 将来 (= force-directed、 §C-2 後続) +data DAGLayoutAlgorithm = LayoutManual | LayoutHierarchical + deriving (Show, Eq, Generic) + +instance ToJSON DAGLayoutAlgorithm +instance FromJSON DAGLayoutAlgorithm + +data DAGNode = DAGNode + { dnId :: !Text + , dnLabel :: !Text + , dnKind :: !DAGNodeKind + , dnDist :: !(Maybe Text) -- ★ 分布名 (= "Normal" / "HalfCauchy" 等、 PyMC 風 sub-label) + , dnX :: !Double -- LayoutManual のみ参照、 他は layout で上書き + , dnY :: !Double + } deriving (Show, Eq, Ord, Generic) + +instance ToJSON DAGNode +instance FromJSON DAGNode + +-- | DAG edge。 Phase 1 A5 で 'dePath' (= dummy 経由の control 点列) を追加、 +-- layout 計算後に埋まる。 JSON FromJSON はフィールド欠落時 'Nothing' default +-- (= aeson Generic 既定動作)、 旧 JSON との backward compat 維持。 +-- | Phase 42 sub B: edge routing の形状種別 (= Render.EdgeRoute の constructor を +-- spec に焼き込むための非依存 tag)。 StraightArrow/SplinePath/BezierPath/CubicPath に対応。 +data EdgeShapeKind = EShStraight | EShSpline | EShBezier | EShCubic + deriving (Show, Eq, Generic) + +instance ToJSON EdgeShapeKind +instance FromJSON EdgeShapeKind + +-- | Phase 42 sub B: HS が焼き込んだ routing 結果 (= pt 空間 = post-'toScreen'・pre-fit)。 +-- HS 'routeEdge' が owner。 PS は描画 + 'fitPrimsToArea' のみ (option1 / DRY)。 +-- 'rePts' の意味は 'reKind' 依存: Straight=[port0,port1]、 Spline/Bezier=制御点列、 +-- Cubic=先頭が始点で以後 3 点ずつ (ctrl1,ctrl2,end) の cubic segment 列。 +data RoutedEdge = RoutedEdge + { reKind :: !EdgeShapeKind + , rePts :: ![(Double, Double)] + } deriving (Show, Eq, Generic) + +instance ToJSON RoutedEdge +instance FromJSON RoutedEdge + +data DAGEdge = DAGEdge + { deFrom :: !Text + , deTo :: !Text + , dePath :: !(Maybe [(Double, Double)]) + -- ^ Phase 1 A5: 中継 dummy 経由の制御点列 (= 始点と終点を含む 0..1 domain)。 + -- 'Nothing' なら短 edge (= 直線描画)、 'Just [..]' なら spline 描画。 + , deRoute :: !(Maybe RoutedEdge) + -- ^ Phase 42 sub B: HS が layout 時に焼き込む pt 空間 routing (= PS と byte parity 用)。 + -- 'Nothing' なら未 bake (= HS は live routeEdge、 PS は straight fallback)。 + -- aeson Generic は欠落時 Nothing default で旧 JSON と backward compat。 + } deriving (Show, Eq, Generic) + +instance ToJSON DAGEdge +instance FromJSON DAGEdge + +-- | Plate (= PyMC スタイルの "repeated" group 囲み)。 +-- 含まれる node id 列を指定、 layout 時に bounding box を自動計算。 +data DAGPlate = DAGPlate + { dpLabel :: !Text -- e.g. "course (10)" / "record (2396)" + , dpNodeIds :: ![Text] + } deriving (Show, Eq, Generic) + +instance ToJSON DAGPlate +instance FromJSON DAGPlate + +data DAGSpec = DAGSpec + { dsNodes :: ![DAGNode] + , dsEdges :: ![DAGEdge] + , dsLayout :: !DAGLayoutAlgorithm + , dsPlates :: ![DAGPlate] -- ★ Plate 群 (= PyMC スタイル grouping) + } deriving (Show, Eq, Generic) + +instance ToJSON DAGSpec +instance FromJSON DAGSpec + +-- | Phase 26 §C-2 #5: scatter 点を線で結ぶ設定。 +-- PlotConfig.connectPoints / connectOrderColumn / connectGroupColumn / +-- connectColor / connectWidth / connectBeforePoints 等価。 +data ConnectSpec = ConnectSpec + { csOrder :: !(Last ColRef) -- Nothing = データ順 + , csGroup :: !(Last ColRef) -- Nothing = 全点 1 本 + , csColor :: !(Last Text) -- Nothing = layer 色 + , csWidth :: !(Last Double) -- Nothing = 1.5 + , csBefore :: !Bool -- True = 点より下に線、 False = 点より上 + } deriving (Show, Eq, Generic) + +instance ToJSON ConnectSpec +instance FromJSON ConnectSpec + +-- ★ Phase 43 A3: レコードフィールド形式 (位置依存撲滅・挙動不変)。csBefore のみ +-- Bool 左勝ち (非 Monoid) なので名前付きで温存。残りは素直な per-field `<>`。 +instance Semigroup ConnectSpec where + a <> b = ConnectSpec + { csOrder = csOrder a <> csOrder b + , csGroup = csGroup a <> csGroup b + , csColor = csColor a <> csColor b + , csWidth = csWidth a <> csWidth b + , csBefore = csBefore a -- 左 (= 最初に setup されたもの) を優先 + } + +instance Monoid ConnectSpec where + mempty = defaultConnectSpec + +defaultConnectSpec :: ConnectSpec +defaultConnectSpec = ConnectSpec mempty mempty mempty mempty False + +-- | 色 encoding: 列指定 (categorical) か 静的色 か 連続値 gradient。 +data ColorEnc + = ColorByCol !ColRef -- categorical: Okabe-Ito palette + | ColorStatic !Text -- "red" / "#ff0000" + | ColorByContinuous !ColRef -- ★ Phase 26 §C-2 #9 連続値 → Viridis 風 gradient + deriving (Generic, Show, Eq) + +instance ToJSON ColorEnc +instance FromJSON ColorEnc + +-- | P5: layer がどちらの Y 軸に属するか。 +data YAxisSide = YAxisLeft | YAxisRight + deriving (Show, Eq, Generic) + +instance ToJSON YAxisSide +instance FromJSON YAxisSide + +-- | Phase 9 B: bar の position adjustment (= ggplot position_*)。 +-- 1 カテゴリに複数系列 (= color/group aesthetic = 'lyColor' の 'ColorByCol') の棒を +-- どう配置するか。 'PosIdentity' (既定) = 従来挙動 (= color を見ず単色棒)。 +-- * 'PosDodge' = 系列を横に並べる (slot を系列数で等分) +-- * 'PosStack' = 系列を縦に積む (cumsum、 y domain は群和の max) +-- * 'PosFill' = stack を各カテゴリ合計 1 に正規化 (y domain = [0,1]) +-- JSON tag: "identity" / "dodge" / "stack" / "fill" (PS Codec と一致)。 +data Position = PosIdentity | PosDodge | PosStack | PosFill + deriving (Show, Eq, Generic) + +positionJsonOptions :: Aeson.Options +positionJsonOptions = Aeson.defaultOptions + { Aeson.constructorTagModifier = \s -> case s of + 'P':'o':'s':rest -> map Char.toLower rest + other -> other + } + +instance ToJSON Position where + toJSON = Aeson.genericToJSON positionJsonOptions + toEncoding = Aeson.genericToEncoding positionJsonOptions + +instance FromJSON Position where + parseJSON = Aeson.genericParseJSON positionJsonOptions + +-- | Phase 36 D1: violin の片側化。 'SideBoth' (既定) = 左右対称、 'SideRight' / 'SideLeft' = +-- 半 violin (片側のみ。 raincloud の「雲」 や非対称比較で使う)。 +-- JSON tag: "both" / "left" / "right" (PS Codec と一致)。 +data Side = SideBoth | SideLeft | SideRight + deriving (Show, Eq, Generic) + +sideJsonOptions :: Aeson.Options +sideJsonOptions = Aeson.defaultOptions + { Aeson.constructorTagModifier = \s -> case s of + 'S':'i':'d':'e':rest -> map Char.toLower rest + other -> other } + +instance ToJSON Side where + toJSON = Aeson.genericToJSON sideJsonOptions + toEncoding = Aeson.genericToEncoding sideJsonOptions + +instance FromJSON Side where + parseJSON = Aeson.genericParseJSON sideJsonOptions + +-- | Phase 9 C / 11 A7-c: 座標系 (= ggplot coord_*)。 'CoordCartesian' (既定) = 通常の +-- 直交座標。 'CoordFlip' = x/y 軸を入れ替える (= coord_flip、 横棒グラフ等)。 +-- 'CoordPolarX' / 'CoordPolarY' = 極座標 (= coord_polar(theta="x"|"y"))。 theta 軸を +-- 角度 (0..2π、 上始点・時計回り)、 他軸を半径に写す。 PolarY + stacked bar = 円グラフ。 +-- JSON tag: "cartesian" / "flip" / "polarx" / "polary" (PS Codec と一致)。 +data Coord = CoordCartesian | CoordFlip | CoordPolarX | CoordPolarY + deriving (Show, Eq, Generic) + +coordJsonOptions :: Aeson.Options +coordJsonOptions = Aeson.defaultOptions + { Aeson.constructorTagModifier = \s -> case s of + 'C':'o':'o':'r':'d':rest -> map Char.toLower rest + other -> other + } + +instance ToJSON Coord where + toJSON = Aeson.genericToJSON coordJsonOptions + toEncoding = Aeson.genericToEncoding coordJsonOptions + +instance FromJSON Coord where + parseJSON = Aeson.genericParseJSON coordJsonOptions + +-- | Phase 11 A7-b: facet の scale 共有方式 (= ggplot facet_wrap(scales=))。 +-- 'FacetFixed' (既定) = 全 panel 共通 domain (値比較可)。 'FacetFreeX' = x 軸のみ +-- panel ごとに独立 domain、 'FacetFreeY' = y のみ、 'FacetFree' = 両軸独立。 free な +-- 軸は各 panel が自分のデータ範囲で scale を持ち、 全 panel に軸を表示する。 +-- JSON tag: "fixed" / "freex" / "freey" / "free" (PS Codec と一致)。 +data FacetScales = FacetFixed | FacetFreeX | FacetFreeY | FacetFree + deriving (Show, Eq, Generic) + +facetScalesJsonOptions :: Aeson.Options +facetScalesJsonOptions = Aeson.defaultOptions + { Aeson.constructorTagModifier = \s -> case s of + 'F':'a':'c':'e':'t':rest -> map Char.toLower rest + other -> other + } + +instance ToJSON FacetScales where + toJSON = Aeson.genericToJSON facetScalesJsonOptions + toEncoding = Aeson.genericToEncoding facetScalesJsonOptions + +instance FromJSON FacetScales where + parseJSON = Aeson.genericParseJSON facetScalesJsonOptions + +-- | x 軸が free か (= 'FacetFreeX' または 'FacetFree')。 +freeScaleX :: FacetScales -> Bool +freeScaleX fs = fs == FacetFreeX || fs == FacetFree + +-- | y 軸が free か (= 'FacetFreeY' または 'FacetFree')。 +freeScaleY :: FacetScales -> Bool +freeScaleY fs = fs == FacetFreeY || fs == FacetFree + +-- | Phase 11 A7-b: facet_grid の panel サイズ配分 (= ggplot facet_grid(space=))。 +-- 'SpaceFixed' (既定) = 全 panel 同サイズ。 'SpaceFreeX' = 列幅を各列の x データ範囲に +-- 比例、 'SpaceFreeY' = 行高を各行の y データ範囲に比例、 'SpaceFree' = 両方。 通常 +-- scales="free" と併用する (= 各 panel の単位長を揃える)。 JSON tag: "fixed" / "freex" +-- / "freey" / "free"。 +data FacetSpace = SpaceFixed | SpaceFreeX | SpaceFreeY | SpaceFree + deriving (Show, Eq, Generic) + +facetSpaceJsonOptions :: Aeson.Options +facetSpaceJsonOptions = Aeson.defaultOptions + { Aeson.constructorTagModifier = \s -> case s of + 'S':'p':'a':'c':'e':rest -> map Char.toLower rest + other -> other + } + +instance ToJSON FacetSpace where + toJSON = Aeson.genericToJSON facetSpaceJsonOptions + toEncoding = Aeson.genericToEncoding facetSpaceJsonOptions + +instance FromJSON FacetSpace where + parseJSON = Aeson.genericParseJSON facetSpaceJsonOptions + +-- | 列幅が free か (= 'SpaceFreeX' または 'SpaceFree')。 +freeSpaceX :: FacetSpace -> Bool +freeSpaceX fs = fs == SpaceFreeX || fs == SpaceFree + +-- | 行高が free か (= 'SpaceFreeY' または 'SpaceFree')。 +freeSpaceY :: FacetSpace -> Bool +freeSpaceY fs = fs == SpaceFreeY || fs == SpaceFree + +-- | C-6: shape encoding 用 8 種。 PS Spec.purs MarkShape と一致 (= JSON round-trip)。 +-- JSON: "circle" / "square" / ... ("MSh" prefix を constructorTagModifier で剥がす)。 +data MarkShape + = MShCircle | MShSquare | MShTriangle | MShDiamond | MShCross + | MShSpade | MShHeart | MShClub + deriving (Show, Eq, Generic) + +markShapeJsonOptions :: Aeson.Options +markShapeJsonOptions = Aeson.defaultOptions + { Aeson.constructorTagModifier = \s -> case s of + 'M':'S':'h':rest -> map Char.toLower rest + other -> other + } + +instance ToJSON MarkShape where + toJSON = Aeson.genericToJSON markShapeJsonOptions + toEncoding = Aeson.genericToEncoding markShapeJsonOptions + +instance FromJSON MarkShape where + parseJSON = Aeson.genericParseJSON markShapeJsonOptions + +-- | cat 名 → MarkShape の対応 1 件。 PS は `{ value, shape }` record で表現。 +data ShapeMapEntry = ShapeMapEntry + { smeValue :: !Text + , smeShape :: !MarkShape + } deriving (Show, Eq, Generic) + +-- フィールドは sme- prefix (= 固定 shape combinator 'shape' とのセレクタ名衝突回避)。 +-- JSON キーは従来通り value/shape を維持 (PS canvas round-trip 不変)。 +shapeMapEntryJsonOptions :: Aeson.Options +shapeMapEntryJsonOptions = Aeson.defaultOptions + { Aeson.fieldLabelModifier = \s -> case s of + "smeValue" -> "value" + "smeShape" -> "shape" + other -> other } + +instance ToJSON ShapeMapEntry where + toJSON = Aeson.genericToJSON shapeMapEntryJsonOptions + toEncoding = Aeson.genericToEncoding shapeMapEntryJsonOptions +instance FromJSON ShapeMapEntry where + parseJSON = Aeson.genericParseJSON shapeMapEntryJsonOptions + +-- | Phase 11 A4-b: linetype aesthetic 用 6 種 (= ggplot2 標準 linetype)。 +-- JSON: "solid"/"dashed"/"dotted"/"dotdash"/"longdash"/"twodash" +-- ("Lt" prefix を constructorTagModifier で剥がし lowercase)。 PS Spec.purs LineType と一致。 +data LineType + = LtSolid | LtDashed | LtDotted | LtDotDash | LtLongDash | LtTwoDash + deriving (Show, Eq, Enum, Bounded, Generic) + +lineTypeJsonOptions :: Aeson.Options +lineTypeJsonOptions = Aeson.defaultOptions + { Aeson.constructorTagModifier = \s -> case s of + 'L':'t':rest -> map Char.toLower rest + other -> other + } + +instance ToJSON LineType where + toJSON = Aeson.genericToJSON lineTypeJsonOptions + toEncoding = Aeson.genericToEncoding lineTypeJsonOptions + +instance FromJSON LineType where + parseJSON = Aeson.genericParseJSON lineTypeJsonOptions + +-- | LineType → SVG/Canvas dash array (px)。 Solid のみ [] (= 実線・dasharray 無し)。 +-- 値は ggplot2 既定の見た目に近い汎用パターン。 lsWidth に依存しない固定 px。 +-- ※ Solid が [] を返すことが既存 SVG ゼロ diff の要 (dasharray attr を出さない)。 +lineTypeDash :: LineType -> [Double] +lineTypeDash lt = case lt of + LtSolid -> [] + LtDashed -> [4, 4] + LtDotted -> [1, 3] + LtDotDash -> [1, 3, 4, 3] + LtLongDash -> [8, 4] + LtTwoDash -> [2, 2, 6, 2] + +-- | categorical linetype scale: cat index → LineType (Solid から巡回)。 +-- ggplot scale_linetype_discrete 同様、 index 0 = solid。 PS と同一順。 +lineTypeForIndex :: Int -> LineType +lineTypeForIndex i = cycle [minBound .. maxBound] !! i diff --git a/src/Graphics/Hgg/Spec/Setters.hs b/src/Graphics/Hgg/Spec/Setters.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Setters.hs @@ -0,0 +1,659 @@ +-- | +-- Module : Graphics.Hgg.Spec.Setters +-- Description : VisualSpec への top-level setter (title / theme / axis / legend / annot 等) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 'VisualSpec' を +-- `<>` で組み立てる top-level setter 群 ('layer' / 'title' / 'theme' / +-- 'facet' 系 / 'legend' 系 / 'annot' 系 / inset / 図サイズ / font setter 等) と +-- 'Labs'、 VisualSpec 依存の mark 構築子 3 種 ('histogramWide' / 'distCols' / +-- 'ridgeAutoFlip') を持つ。 図の合成演算子は 'Graphics.Hgg.Spec.Concat' 側。 +-- 公開 API は従来どおり 'Graphics.Hgg.Spec' (facade) が re-export する。 +-- 挙動・出力は完全に不変。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Setters + ( -- * layer 装着 + 基本 setter + layer, purePlot, title, subtitle, caption, tag, xLabel, yLabel + , Labs(..), labs, emptyLabs + , theme, facet, facetWrap, facetGrid, facetCols, facetScales, facetSpace + , subplots, subplotCols, repeatFields, selectPanels, selectedSubplots + , scaleXDiscreteLimits, scaleYDiscreteLimits, applyDiscreteLimits, reindexLayer + -- * theme override setter + , plotBg, panelFill, panelBorder, gridColor, themeGrid, themeAxisLine + , axisColor, textColor, tickColor, titleColor, titleHjust + , stripFill, themeStrip, legendKeyBg + , themeTitleFont, themeAxisLabelFont, themeTickFont, themeLegendFont + , themeAxisTextAngle, themeAxisTextAngleX, themeAxisTextAngleY + , axisTextAngleXOf, axisTextAngleYOf + -- * VisualSpec 依存の mark 構築子 (Phase 55: Constructors に置けない 3 種) + , histogramWide, distCols, ridgeAutoFlip + -- * 軸 / 凡例 / 装飾 / 座標系 / サイズ + , xAxis, yAxis, yAxisRight, toLeftY, toRightY + , legend, legendPos, legendOff, legendTitle, legendReverse, legendNcol, legendNrow + , guideColorNone + , refLine, refVertical, refHorizontal, refIdentity + , annotate, annotText, annotTextP, annotLine, annotLineP + , annotRect, annotRectP, annotArrow, annotArrowP + , inset, insetAt, insetElement + , marginal, marginalX, marginalY + , palette, paletteGGplot, continuousPalette + , scaleColorManual, scaleColorGradient2, scaleSize + , coordFlip, coordPolar, coordPolarY, coordCartesian, coordCartesianX, coordCartesianY + , reverseX, reverseY, aspectRatio + , width, height, widthUnit, heightUnit, widthMm, heightMm, dpi + -- * font setter + , titleFont, axisLabelFont, tickFont, legendFont + ) where + +import Data.Maybe (catMaybes) +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as V + +import Graphics.Hgg.Unit (Length, Pos (..), mm, (*~)) +import Graphics.Hgg.Spec.Axis (AxisSpec) +import Graphics.Hgg.Spec.Column +import Graphics.Hgg.Spec.Bake (bakeSpec) +import Graphics.Hgg.Spec.Constructors (binCount, histogram, (<+>)) +import Graphics.Hgg.Spec.Decoration +import Graphics.Hgg.Spec.Layer +import Graphics.Hgg.Spec.Mark +import Graphics.Hgg.Spec.Theme (ThemeName, ThemeOverride (..)) +import Graphics.Hgg.Spec.Visual + + +-- =========================================================================== +-- Top-level setters +-- =========================================================================== + +-- | spec の純粋値起点 (= 'mempty' alias)。 mempty 直接でも良いが、 「これは +-- plot spec の最初の値ですよ」 という意図を名前で示す。 副作用関数 +-- ('plot' / 'saveSVG' 等) との対比で `pure-` prefix。 +purePlot :: VisualSpec +purePlot = mempty + +-- | 'Layer' を 'VisualSpec' に lift (= layer リストの単一要素 spec)。 +layer :: Layer -> VisualSpec +layer l = mempty { vsLayers = [l] } + +title, xLabel, yLabel :: Text -> VisualSpec +title t = mempty { vsTitle = Last (Just t) } +xLabel t = mempty { vsXLabel = Last (Just t) } +yLabel t = mempty { vsYLabel = Last (Just t) } + +-- | Phase 11 A4-c: 凡例タイトル (= ggplot scale_color_*(name=) / labs(color=))。 +-- color/fill/shape/linetype の凡例ヘッダに表示。 軸タイトルは 'xLabel'/'yLabel' を使う +-- (= positional scale の name = 軸ラベル)。 +legendTitle :: Text -> VisualSpec +legendTitle t = mempty { vsLegendTitle = Last (Just t) } + +-- | Phase 11 A5-a: labs サブシステムの個別 setter (= ggplot labs(subtitle=,caption=,tag=))。 +-- 'subtitle' = title 直下の小見出し、 'caption' = 図右下の注記、 'tag' = 左上隅のタグ。 +subtitle, caption, tag :: Text -> VisualSpec +subtitle t = mempty { vsSubtitle = Last (Just t) } +caption t = mempty { vsCaption = Last (Just t) } +tag t = mempty { vsTag = Last (Just t) } + +-- | Phase 11 A5-a: ggplot @labs()@ 相当のまとめ setter。 各フィールドは 'Maybe' で +-- 「指定しない」 を表す。 @labs emptyLabs { labsTitle = Just "T", labsX = Just "x" }@ の +-- ように 'emptyLabs' を起点に必要な label だけ埋める。 @labsColor@ は凡例タイトル +-- ('legendTitle')。 指定した label を 'mconcat' で合成するので既存 setter と等価。 +data Labs = Labs + { labsTitle :: Maybe Text + , labsSubtitle :: Maybe Text + , labsCaption :: Maybe Text + , labsTag :: Maybe Text + , labsX :: Maybe Text + , labsY :: Maybe Text + , labsColor :: Maybe Text -- = 凡例タイトル ('legendTitle') + } deriving (Show, Eq) + +-- | 全フィールド未指定の 'Labs' 起点 (= record update のベース)。 +emptyLabs :: Labs +emptyLabs = Labs Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +labs :: Labs -> VisualSpec +labs lb = mconcat $ catMaybes + [ title <$> labsTitle lb + , subtitle <$> labsSubtitle lb + , caption <$> labsCaption lb + , tag <$> labsTag lb + , xLabel <$> labsX lb + , yLabel <$> labsY lb + , legendTitle <$> labsColor lb + ] + +theme :: ThemeName -> VisualSpec +theme t = mempty { vsTheme = Last (Just t) } + +-- | Phase 9 A-2: element 単位 theme override の setter 群 (ggplot theme(element_*) 相当)。 +-- `theme ThemeGrey <> themeGrid False <> panelFill "#fafafa"` のように `<>` で重ねる。 +themeGrid :: Bool -> VisualSpec -- panel.grid on/off +themeGrid b = mempty { vsThemeOverride = mempty { toShowGrid = Last (Just b) } } + +panelFill :: Text -> VisualSpec -- panel.background fill (= 塗り on + 色指定) +panelFill c = mempty { vsThemeOverride = mempty { toPanelBg = Last (Just c), toShowPanel = Last (Just True) } } + +panelBorder :: Bool -> VisualSpec -- panel.border on/off +panelBorder b = mempty { vsThemeOverride = mempty { toShowBorder = Last (Just b) } } + +themeAxisLine :: Bool -> VisualSpec -- axis.line (下/左 2 辺) on/off +themeAxisLine b = mempty { vsThemeOverride = mempty { toShowAxisLine = Last (Just b) } } + +gridColor :: Text -> VisualSpec -- panel.grid colour +gridColor c = mempty { vsThemeOverride = mempty { toGridColor = Last (Just c) } } + +plotBg :: Text -> VisualSpec -- plot.background fill +plotBg c = mempty { vsThemeOverride = mempty { toPlotBg = Last (Just c) } } + +axisColor :: Text -> VisualSpec -- axis 線/目盛り色 +axisColor c = mempty { vsThemeOverride = mempty { toAxisColor = Last (Just c) } } + +textColor :: Text -> VisualSpec -- 文字色 +textColor c = mempty { vsThemeOverride = mempty { toTextColor = Last (Just c) } } + +-- | Phase 9 A-3: theme 経由の font setter 群 (ggplot theme(plot.title=element_text(...)) 等)。 +-- vsTitleFont 等の専用 setter より優先される (= 後付け theme 上書き)。 `<>` で重ねる。 +themeTitleFont :: FontSpec -> VisualSpec -- plot.title +themeTitleFont f = mempty { vsThemeOverride = mempty { toTitleFont = Last (Just f) } } + +themeAxisLabelFont :: FontSpec -> VisualSpec -- axis.title +themeAxisLabelFont f = mempty { vsThemeOverride = mempty { toAxisLabelFont = Last (Just f) } } + +themeTickFont :: FontSpec -> VisualSpec -- axis.text +themeTickFont f = mempty { vsThemeOverride = mempty { toTickFont = Last (Just f) } } + +themeLegendFont :: FontSpec -> VisualSpec -- legend.title / legend.text +themeLegendFont f = mempty { vsThemeOverride = mempty { toLegendFont = Last (Just f) } } + +-- | axis.text の回転角 (度) を theme から指定。 per-axis 'axisRotate' 未指定時の fallback。 +themeAxisTextAngle :: Double -> VisualSpec +themeAxisTextAngle a = mempty { vsThemeOverride = mempty { toAxisTextAngle = Last (Just a) } } + +-- | axis.text の **x 軸のみ** の回転角 (度・CCW) を theme から指定 (Phase 50 A3)。 +-- 共通 'themeAxisTextAngle' より優先。 per-axis 'xAxis (axisRotate …)' が更に優先。 +themeAxisTextAngleX :: Double -> VisualSpec +themeAxisTextAngleX a = mempty { vsThemeOverride = mempty { toAxisTextAngleX = Last (Just a) } } + +-- | axis.text の **y 軸のみ** の回転角 (度・CCW) を theme から指定 (Phase 50 A3)。 +themeAxisTextAngleY :: Double -> VisualSpec +themeAxisTextAngleY a = mempty { vsThemeOverride = mempty { toAxisTextAngleY = Last (Just a) } } + +-- | theme の x 軸 axis.text 回転角を解決 (軸別 'toAxisTextAngleX' > 共通 'toAxisTextAngle')。 +-- 'resolveAxisAngle' の theme fallback 引数に渡す (Phase 50 A3)。 +axisTextAngleXOf :: ThemeOverride -> Last Double +axisTextAngleXOf o = toAxisTextAngle o <> toAxisTextAngleX o + +-- | theme の y 軸 axis.text 回転角を解決 (軸別 'toAxisTextAngleY' > 共通 'toAxisTextAngle')。 +axisTextAngleYOf :: ThemeOverride -> Last Double +axisTextAngleYOf o = toAxisTextAngle o <> toAxisTextAngleY o + +-- | Phase 9 A-4: facet strip.background の塗り色を指定 (= 塗り on + 色)。 +stripFill :: Text -> VisualSpec +stripFill c = mempty { vsThemeOverride = mempty { toStripBg = Last (Just c), toShowStrip = Last (Just True) } } + +-- | facet strip 矩形の on/off。 +themeStrip :: Bool -> VisualSpec +themeStrip b = mempty { vsThemeOverride = mempty { toShowStrip = Last (Just b) } } + +-- | Phase 43 A4: プリセット専用だった 4 項目の theme 上書き setter (= 全プロパティ `<>` 上書き)。 +-- `theme ThemeGrey <> titleHjust 0.5 <> legendKeyBg "#fff"` のように重ねる。 +titleHjust :: Double -> VisualSpec -- plot.title の水平揃え (0=左、 0.5=中央) +titleHjust h = mempty { vsThemeOverride = mempty { toTitleHjust = Last (Just h) } } + +titleColor :: Text -> VisualSpec -- plot.title / axis.title の文字色 +titleColor c = mempty { vsThemeOverride = mempty { toTitleColor = Last (Just c) } } + +tickColor :: Text -> VisualSpec -- 軸目盛線 (tick mark) の色 +tickColor c = mempty { vsThemeOverride = mempty { toTickLineColor = Last (Just c) } } + +legendKeyBg :: Text -> VisualSpec -- legend.key 背景塗り色 ("" なら塗らない) +legendKeyBg c = mempty { vsThemeOverride = mempty { toLegendKeyBg = Last (Just c) } } + +facet :: ColRef -> VisualSpec +facet c = mempty { vsFacet = Last (Just c) } + +-- | Phase 8 C G7: facet_wrap(~c, ncol=n)。 c で分割し n 列で複数行に折り返す。 +-- ncol 未使用 (= 'facet' のみ) なら従来の 1 行 N 列。 +facetWrap :: ColRef -> Int -> VisualSpec +facetWrap c n = mempty { vsFacet = Last (Just c), vsFacetNcol = Last (Just n) } + +-- | facet の列数のみ指定 (= 既存 'facet' と併用)。 +facetCols :: Int -> VisualSpec +facetCols n = mempty { vsFacetNcol = Last (Just n) } + +-- | Phase 11 A7-b: facet_wrap の scale 共有方式 (= ggplot facet_wrap(scales=))。 +-- 'FacetFixed' (既定) = 共通 domain、 'FacetFree'/'FacetFreeX'/'FacetFreeY' = 該当軸を +-- panel ごとに独立 domain に。 free な軸は全 panel に軸を表示する。 'facet' と併用。 +facetScales :: FacetScales -> VisualSpec +facetScales fs = mempty { vsFacetScales = Last (Just fs) } + +-- | Phase 11 A7-b: facet_grid の panel サイズ配分 (= ggplot facet_grid(space=))。 +-- 'SpaceFree' 等で free 軸の track 幅/高を data 範囲に比例配分する。 通常 +-- 'facetScales' と併用。 facet_grid のみ有効。 +facetSpace :: FacetSpace -> VisualSpec +facetSpace fs = mempty { vsFacetSpace = Last (Just fs) } + +-- | Phase 8 C G7 part-b: facet_grid(row ~ col)。 row 変数の levels で行、 +-- col 変数の levels で列を作り 2 次元の cross 配置にする。 strip は上 (col 名)・ +-- 右 (row 名)、 軸は最下行 x・左端列 y のみ (ggplot facet_grid 既定)。 +facetGrid :: ColRef -> ColRef -> VisualSpec +facetGrid rowC colC = mempty { vsFacetRow = Last (Just rowC) + , vsFacetCol = Last (Just colC) } + +-- | Phase 26 S5-e-1: panel grid (= facet とは独立、 各 spec を独立 panel として並べる)。 +-- | facet は 1 列でデータを分割するのに対し、 subplots は完全に別 spec を並べる。 +-- | DoE の MainEffects (= 複数 factor を横並び) で使う。 +subplots :: [VisualSpec] -> VisualSpec +subplots ss = mempty { vsSubplots = ss } + +-- | P18: subplots の 2D grid 折り返し列数。 +subplotCols :: Int -> VisualSpec +subplotCols n = mempty { vsSubplotCols = Last (Just n) } + +-- | Phase 18 A1: subplot panel を **名前 (= 子 spec の 'vsTitle') で選択 + 並べ替え**。 +-- 'repeatFields' (名前リスト → panel 群) の逆方向。 列挙順がそのまま表示順になる +-- (ggplot @scale_*_discrete(limits=)@ と同じ「選択 + 順序」 の意味論)。 +-- 一致しない名前は無視、 title 無し panel は選択時には常に落ちる。 +-- +-- > subplots panels <> selectPanels ["b", "a"] <> subplotCols 2 +selectPanels :: [Text] -> VisualSpec +selectPanels ws = mempty { vsPanelSel = Last (Just ws) } + +-- | 'vsPanelSel' を適用した後の実効 subplot 列。 描画 ('renderSubplots') の正本で、 +-- HS 外 (canvas / PS codec) へ spec を送る側も serialise 前にこれで解決すれば +-- PS 非改修で選択が効く。 選択未指定 ('Nothing') は全 panel をそのまま返す。 +selectedSubplots :: VisualSpec -> [VisualSpec] +selectedSubplots s = case getLast (vsPanelSel s) of + Nothing -> vsSubplots s + Just ws -> [ p | nm <- ws, p <- vsSubplots s, getLast (vsTitle p) == Just nm ] + +-- | Phase 18 A2: 離散 x 軸の limits (= ggplot @scale_x_discrete(limits=)@)。 +-- x encoding が ColTxt の layer のカテゴリ行を **選択 + 列挙順に並べ替え**る。 +-- aes 基準なので coord_flip と直交 (flip 後も x データ軸を指す)。 +scaleXDiscreteLimits :: [Text] -> VisualSpec +scaleXDiscreteLimits ws = mempty { vsXDiscreteLimits = Last (Just ws) } + +-- | Phase 18 A2: 離散 y 軸の limits (= ggplot @scale_y_discrete(limits=)@)。 +-- 'forest' は cat ラベルが y encoding なのでこちらを使う。 +scaleYDiscreteLimits :: [Text] -> VisualSpec +scaleYDiscreteLimits ws = mempty { vsYDiscreteLimits = Last (Just ws) } + +-- | Phase 18 A2 の解決 (正本): 'vsXDiscreteLimits' / 'vsYDiscreteLimits' を layer の +-- 行 filter + 並べ替えとして適用する。 layout / render の入口で呼ぶ (冪等)。 +-- +-- * 当該軸の encoding が 'ColTxt' の layer のみ対象 (数値軸 layer は不変)。 +-- * 行 filter は **全 row-aligned encoding** (encX/encY/encY2/errorX/errorY/shapeBy/ +-- sizeBy/chain/linetypeBy/label/hover/color 列) を同 index で間引く (整合維持)。 +-- * 'ColByName' (resolver 参照) を含む spec は先に 'bakeSpec' で inline 化してから +-- filter する (limits 未指定なら bake もしない = 従来経路完全不変)。 +-- * limits は当該 spec 自身の layer にのみ効く (subplot 子へは伝播しない — +-- 子は自分の limits を持てる)。 +applyDiscreteLimits :: Resolver -> VisualSpec -> VisualSpec +applyDiscreteLimits r spec = + case (getLast (vsXDiscreteLimits spec), getLast (vsYDiscreteLimits spec)) of + (Nothing, Nothing) -> spec + (mxs, mys) -> + let b = bakeSpec r spec + limited = map (limitAxis lyEncY mys . limitAxis lyEncX mxs) (vsLayers b) + in b { vsLayers = limited } + where + limitAxis enc (Just ws) ly + | Just (ColTxt cats) <- getLast (enc ly) = + let n = V.length cats + idx = V.fromList + [ i | w <- ws + , (i, c) <- zip [0 ..] (V.toList cats), c == w ] + in reindexLayer n idx ly + limitAxis _ _ ly = ly + +-- | layer の全 row-aligned encoding を同じ index 列で間引く ('applyDiscreteLimits' 用)。 +-- 長さ @n@ (= cat 列長) と一致する inline 列のみ対象 (不一致・'ColByName' は据え置き)。 +reindexLayer :: Int -> Vector Int -> Layer -> Layer +reindexLayer n idx ly = ly + { lyEncX = reC <$> lyEncX ly + , lyEncY = reC <$> lyEncY ly + , lyEncY2 = reC <$> lyEncY2 ly + , lyErrorX = reC <$> lyErrorX ly + , lyErrorY = reC <$> lyErrorY ly + , lyShapeBy = reC <$> lyShapeBy ly + , lySizeBy = reC <$> lySizeBy ly + , lyAlphaBy = reC <$> lyAlphaBy ly + , lyChain = reC <$> lyChain ly + , lyLinetypeBy = reC <$> lyLinetypeBy ly + , lyLabel = reC <$> lyLabel ly + , lyHover = map reC (lyHover ly) + , lyColor = reColor <$> lyColor ly + } + where + reC c = case c of + ColNum v | V.length v == n -> ColNum (V.backpermute v idx) + ColTxt v | V.length v == n -> ColTxt (V.backpermute v idx) + _ -> c + reColor ce = case ce of + ColorByCol c -> ColorByCol (reC c) + ColorByContinuous c -> ColorByContinuous (reC c) + ColorStatic t -> ColorStatic t + +-- | Vega-Lite @repeat@ 相当: フィールド名のリストを反復し、 各フィールドから +-- | 1 つの view (VisualSpec) を生成して 'subplots' に並べる (= フィールド自動反復)。 +-- | @repeatFields ["a","b","c"] (\\f -> layer (hist f))@ は 3 パネルを作る。 +-- | 列数は @<> subplotCols n@ で指定する。 Vega の @repeat@ が encoding 内の +-- | @{repeat: ...}@ でフィールドを差し込むのに対し、 こちらは生成関数に +-- | フィールド名を渡す明示形 (spec を値として組む方針ゆえ)。 +repeatFields :: [Text] -> (Text -> VisualSpec) -> VisualSpec +repeatFields fields mk = subplots (map mk fields) + +-- Phase 55: 以下 3 関数は mark 構築子だが 'VisualSpec' と 'layer' に依存するため +-- 'Spec.Constructors' には置けず、 top-level setter 群と同居する。 + +-- | Wide-form histogram (P1、 Phase 6 A10): 複数列を **同一 plot に半透明で重ねる**。 +-- +-- `histogramWide [c1, c2, c3]` は 'VisualSpec' を返し、 内部で各列を独立 layer 化: +-- +-- * layer i = `histogram cᵢ <> color (fromHex (palette i)) <> alpha 0.4 <> binCount 20` +-- +-- palette は ColorBrewer Set1 (= categorical 9-class、 wong / 独自 切替は今後)。 +-- bin 数は全列で **共通** (= seaborn の `multiple="layer"` 同等)、 デフォ 20。 +-- +-- matplotlib との対応: `plt.hist([c1, c2, c3], alpha=0.5, label=names)` 相当。 +histogramWide :: [ColRef] -> VisualSpec +histogramWide cols = + let pal = ["#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00" + , "#FFFF33", "#A65628", "#F781BF", "#999999"] + mkLayer i c = layer + ( histogram c + -- 内部 palette は Text 経路ゆえ ColorStatic 直構築で温存 (Color 型を通さない) + <> mempty { lyColor = Last (Just (ColorStatic (cycleColor pal i))) } + <> alpha 0.4 + <> binCount 20 + ) + in mconcat [ mkLayer i c | (i, c) <- zip [0 ..] cols ] + where + cycleColor cs i = cs !! (i `mod` length cs) + +-- | Phase 36 D3: 別列・別 mark を 1 パネルに併置 (= mixed-mark)。 @<+>@ の list 版 +-- (@distCols xs = layer (foldl1 (<+>) xs)@)。 各マークの値列 (encY) が別なので別 slot +-- (列名) に横並び・y は全列の値域和・単一パネル (subplot とは別)。 lane は 1D 分布 mark 専用 +-- (box/violin/strip/swarm/raincloud)。 raincloud は全マーク同一列ゆえ 1 slot に重畳する +-- ('compositeLanes' が列数を決める)。 +-- +-- > distCols [ boxplot "a", violin "c", boxplot "d" ] +distCols :: [Layer] -> VisualSpec +distCols [] = mempty +distCols (l : ls) = layer (foldl (<+>) l ls) + +-- | ★ Phase 36 B1c: ridge レイヤを含み coord 未指定の spec に coord_flip を自動付与する。 +-- ridge は「値→x(連続)・群→y(カテゴリ)」だが combinator は box/violin と統一 (値=encY・ +-- 群=encX via groupBy)。 coord_flip で encY(値)→x・encX(群)→y に回す (box-flip と同機構)。 +-- computeLayout / renderToPrimitives の入口で適用する。 +ridgeAutoFlip :: VisualSpec -> VisualSpec +ridgeAutoFlip spec + | any (\l -> getFirst (lyKind l) == Just MRidge) (vsLayers spec) + , Nothing <- getLast (vsCoord spec) + = spec { vsCoord = Last (Just CoordFlip) } + | otherwise = spec + + +-- | P6: annotation 1 個を追加。 +annotate :: Annotation -> VisualSpec +annotate a = mempty { vsAnnotations = [a] } + +-- | P6: data 座標で text label を打つ shortcut (= 'annotTextP' の PNative ラッパ)。 +annotText :: Double -> Double -> Text -> VisualSpec +annotText x y t = annotTextP (PNative x) (PNative y) t + +-- | ★ Phase 33 B6: 'Pos' で text を打つ (native/npc/絶対長を軸ごと混在可)。 +-- 例: @annotTextP (PNpc 0.95) (PNative 3.0) "R²"@ (右端 npc・data y)。 +annotTextP :: Pos -> Pos -> Text -> VisualSpec +annotTextP x y t = annotate $ AnnText + { anX = x, anY = y, anText = t, anColor = "", anSize = 12 } + +-- | P6: data 座標で arrow を引く shortcut。 +annotArrow :: Double -> Double -> Double -> Double -> VisualSpec +annotArrow x1 y1 x2 y2 = + annotArrowP (PNative x1) (PNative y1) (PNative x2) (PNative y2) + +-- | ★ Phase 33 B6: 'Pos' で arrow を引く。 +annotArrowP :: Pos -> Pos -> Pos -> Pos -> VisualSpec +annotArrowP x1 y1 x2 y2 = annotate $ AnnArrow + { anX1 = x1, anY1 = y1, anX2 = x2, anY2 = y2 + , anColor = "#444", anWidth = 1.5 } + +-- | P6: data 座標で rect を描く shortcut (x,y,w,h → 2 隅 Pos へ変換)。 +annotRect :: Double -> Double -> Double -> Double -> Text -> VisualSpec +annotRect x y w h col = + annotRectP (PNative x) (PNative y) (PNative (x + w)) (PNative (y + h)) col + +-- | ★ Phase 33 B6: 'Pos' 2 隅で rect を描く。 +-- 例: @annotRectP (PNpc 0.0) (PNative 1.0) (PNpc 1.0) (PNative 2.0) "grey"@ +-- (帯: x 全幅 npc・y は data 1..2)。 +annotRectP :: Pos -> Pos -> Pos -> Pos -> Text -> VisualSpec +annotRectP x1 y1 x2 y2 col = annotate $ AnnRect + { anX1 = x1, anY1 = y1, anX2 = x2, anY2 = y2 + , anFill = col, anStroke = "", anStrokeWidth = 0, anFillOpacity = 0.2 } + +-- | P6: data 座標で line を引く shortcut。 +annotLine :: Double -> Double -> Double -> Double -> VisualSpec +annotLine x1 y1 x2 y2 = + annotLineP (PNative x1) (PNative y1) (PNative x2) (PNative y2) + +-- | ★ Phase 33 B6: 'Pos' で line を引く。 +annotLineP :: Pos -> Pos -> Pos -> Pos -> VisualSpec +annotLineP x1 y1 x2 y2 = annotate $ AnnLine + { anX1 = x1, anY1 = y1, anX2 = x2, anY2 = y2 + , anColor = "#444", anWidth = 1 } + +-- | P13: inset 1 個追加 (= デフォルト位置 右上 30%×30%)。 +inset :: VisualSpec -> VisualSpec +inset s = insetAt 0.65 0.05 0.3 0.3 s + +-- | P13: 位置 + サイズ (plotArea 比率 0..1) 指定で inset を追加。 +-- inX/inY は **左上原点・y 下向き** (= 描画系と同じ)。 +insetAt :: Double -> Double -> Double -> Double -> VisualSpec -> VisualSpec +insetAt x y w h s = mempty + { vsInsets = [ Inset { inSpec = s, inX = x, inY = y, inW = w, inH = h } ] } + +-- | Phase 8 C G8: patchwork 'inset_element' 準拠の inset 追加。 +-- left/bottom/right/top は plotArea 比率 0..1 で **左下原点・y 上向き** (patchwork 慣例)。 +-- 内部で従来 'insetAt' (左上原点・y 下向き) へ変換するだけの薄いラッパ (非破壊)。 +-- patchwork 感覚で `inset_element(p, left, bottom, right, top)` と同じ向きに置ける。 +insetElement :: Double -> Double -> Double -> Double -> VisualSpec -> VisualSpec +insetElement left bottom right top s = + insetAt left (1 - top) (right - left) (top - bottom) s + +-- | P17: categorical palette を指定。 default = hggMain (F-3)。 +palette :: [Text] -> VisualSpec +palette colors = mempty { vsPalette = Last (Just colors) } + +-- | Phase 7 A6: ggplot2 hue パレット (= @scales::hue_pal()@) を選ぶ。 群数 n は描画時に +-- 決まるため sentinel を渡し、 Layout で n 展開する (= 'Graphics.Hgg.Palette.ggplotHue')。 +paletteGGplot :: VisualSpec +paletteGGplot = mempty { vsPalette = Last (Just ["__ggplot_hue__"]) } + +-- | P17: continuous (sequential) palette を指定。 default = viridis5。 +continuousPalette :: [Text] -> VisualSpec +continuousPalette colors = mempty { vsContinuousPal = Last (Just colors) } + +-- | A4-e: ggplot @scale_color_manual(values=)@。 カテゴリ名→色(hex) の辞書を指定。 +-- 'color' (ColorByCol) のカテゴリ名がここにあればその色を最優先で使う。 未登録名は +-- 従来の positional palette ('palette'/theme) にフォールバック。 +scaleColorManual :: [(Text, Text)] -> VisualSpec +scaleColorManual dict = mempty { vsColorManual = Last (Just dict) } + +-- | A4-e: ggplot @scale_color_gradient2(low,mid,high,midpoint=)@。 発散 (diverging) +-- continuous palette。 'colorContinuousBy' (ColorByContinuous) のとき、 midpoint を中心 +-- (0.5) に固定し lo..mid を [0,0.5]・mid..hi を [0.5,1] へ個別正規化して 3-stop 補間。 +scaleColorGradient2 :: Text -> Text -> Text -> Double -> VisualSpec +scaleColorGradient2 low mid high midpoint = + mempty { vsColorGradient2 = Last (Just (low, mid, high, midpoint)) } + +-- | A4-e: ggplot @scale_size(range=c(min,max))@。 'sizeBy' (continuous size aesthetic) の +-- 半径 px 範囲を指定 (default (3,10))。 sizeBy 未使用なら無影響。 +scaleSize :: Double -> Double -> VisualSpec +scaleSize lo hi = mempty { vsSizeRange = Last (Just (lo, hi)) } + +-- | P8: 凡例を有効化 (= 既定: 右側)。 +legend :: VisualSpec +legend = mempty { vsLegend = Last (Just defaultLegendSpec) } + +-- | P8: 凡例を抑制。 +legendOff :: VisualSpec +legendOff = mempty + { vsLegend = Last (Just (LegendSpec LegendNone mempty)) } + +-- | P8: 凡例位置を指定。 +legendPos :: LegendPosition -> VisualSpec +legendPos pos = mempty { vsLegend = Last (Just (LegendSpec pos mempty)) } + +-- | Phase 11 A5-c: 色凡例を非表示 (= ggplot @guides(color="none")@)。 この系では凡例は +-- 色 (color/fill) のみなので 'legendOff' と同義。 ggplot 慣習名の別名として提供。 +guideColorNone :: VisualSpec +guideColorNone = legendOff + +-- | Phase 11 A5-c: 凡例キーの表示順を逆に (= ggplot @guide_legend(reverse=TRUE)@)。 +-- 各キーの色は固定のまま順序のみ反転。 位置設定 ('legend'/'legendPos') と独立合成可。 +legendReverse :: VisualSpec +legendReverse = mempty { vsLegendReverse = Last (Just True) } + +-- | Phase 11 A5-c: 縦凡例 (Right/Inside) の列数 (= ggplot @guide_legend(ncol=)@)。 +legendNcol :: Int -> VisualSpec +legendNcol n = mempty { vsLegendNcol = Last (Just n) } + +-- | Phase 11 A5-c: 横凡例 (Bottom) の行数 (= ggplot @guide_legend(nrow=)@)。 +legendNrow :: Int -> VisualSpec +legendNrow n = mempty { vsLegendNrow = Last (Just n) } + +-- | 図サイズ ('Length'・Phase 34 A4)。 bare 数値リテラルは @Num Length@ 経由で +-- **pt** (@width 600@ = 600pt)。 mm で書きたいときは 'widthMm' / 'heightMm'、 +-- その他の単位は @width (7 *~ inch)@ / 'widthUnit' を使う。 +width, height :: Length -> VisualSpec +width = widthUnit +height = heightUnit + +-- | 図サイズ (mm 直接)。@widthMm 180@ = 180mm。 A4 で 'width' の bare が pt に +-- 変わったので、 従来の mm 指定はこちらへ移行する。 +widthMm, heightMm :: Double -> VisualSpec +widthMm w = widthUnit (w *~ mm) +heightMm h = heightUnit (h *~ mm) + +-- | 図サイズ (単位明示)。@widthUnit (7 *~ inch)@ / @widthUnit (800 *~ px)@。 +widthUnit, heightUnit :: Length -> VisualSpec +widthUnit l = mempty { vsWidth = Last (Just l) } +heightUnit l = mempty { vsHeight = Last (Just l) } + +-- | 描画 dpi (px backend は px=pt×dpi/72)。@plot <> dpi 300@。既定 96。PDF は無視。 +dpi :: Double -> VisualSpec +dpi d = mempty { vsDpi = Last (Just d) } + +-- | Phase 8 A2 Step2: coord_fixed(ratio) 相当。 panel の 高/幅 比 (aspect) を固定。 +-- 指定時は可用域内で aspect を保つ最大 panel を取り中央寄せ (ggplot Coord$aspect)。 +aspectRatio :: Double -> VisualSpec +aspectRatio a = mempty { vsAspect = Last (Just a) } + +-- | Phase 9 C: coord_flip。 x/y 軸を入れ替える (= 横棒グラフ等)。 ggplot coord_flip() 相当。 +-- +-- > bar "cat" "y" `layer'` purePlot <> coordFlip +coordFlip :: VisualSpec +coordFlip = mempty { vsCoord = Last (Just CoordFlip) } + +-- | Phase 11 A7-c: 極座標 (= ggplot @coord_polar(theta="x")@)。 データ x を角度 +-- (0..2π、 上始点・時計回り)、 データ y を半径に写す。 line/point は radar / spiral に。 +coordPolar :: VisualSpec +coordPolar = mempty { vsCoord = Last (Just CoordPolarX) } + +-- | Phase 11 A7-c: 極座標 (= ggplot @coord_polar(theta="y")@)。 データ y を角度、 +-- データ x を半径に写す。 単一カテゴリの stacked bar と併せると円グラフになる。 +coordPolarY :: VisualSpec +coordPolarY = mempty { vsCoord = Last (Just CoordPolarY) } + +-- | Phase 11 A4-a: X 軸反転 (= ggplot @scale_x_reverse()@)。 大値が左、 小値が右へ。 +-- coord_flip と独立合成可。 +-- +-- > scatter "x" "y" `layer'` purePlot <> reverseX +reverseX :: VisualSpec +reverseX = mempty { vsReverseX = Last (Just True) } + +-- | Phase 11 A4-a: Y 軸反転 (= ggplot @scale_y_reverse()@)。 大値が下、 小値が上へ。 +reverseY :: VisualSpec +reverseY = mempty { vsReverseY = Last (Just True) } + +-- | Phase 11 A7-a: X 軸 zoom (= ggplot @coord_cartesian(xlim=c(lo,hi))@)。 +-- 'axisRange' (= scale limits、 範囲外データを切る) と異なり **データを落とさず** +-- 表示範囲だけを [lo,hi] に上書きする。 stat (regression/density 等) は全データから +-- 計算され、 範囲外の glyph は panel に clip される。 numeric 軸のみ有効。 +coordCartesianX :: Double -> Double -> VisualSpec +coordCartesianX lo hi = mempty { vsCoordXLim = Last (Just (lo, hi)) } + +-- | Phase 11 A7-a: Y 軸 zoom (= ggplot @coord_cartesian(ylim=c(lo,hi))@)。 +coordCartesianY :: Double -> Double -> VisualSpec +coordCartesianY lo hi = mempty { vsCoordYLim = Last (Just (lo, hi)) } + +-- | Phase 11 A7-a: X/Y 同時 zoom (= ggplot @coord_cartesian(xlim=,ylim=)@)。 +-- 'coordCartesianX' と 'coordCartesianY' の合成。 +coordCartesian :: Double -> Double -> Double -> Double -> VisualSpec +coordCartesian xlo xhi ylo yhi = coordCartesianX xlo xhi <> coordCartesianY ylo yhi + +-- | 軸 (X / Y) 設定の合成 helper。 +-- +-- > example = ... <> xAxis logAxis <> yAxis (linearAxis <> ...) +xAxis, yAxis :: AxisSpec -> VisualSpec +xAxis a = mempty { vsXAxis = Last (Just a) } +yAxis a = mempty { vsYAxis = Last (Just a) } + +-- | P5: 右側 Y 軸の AxisSpec (= dual Y を有効化)。 +yAxisRight :: AxisSpec -> VisualSpec +yAxisRight a = mempty { vsYAxisRight = Last (Just a) } + +-- | P5: layer を右側 Y 軸に紐付ける。 +toRightY :: Layer +toRightY = mempty { lyYAxisSide = Last (Just YAxisRight) } + +-- | P5: layer を左側 Y 軸に紐付ける (= default なので通常不要)。 +toLeftY :: Layer +toLeftY = mempty { lyYAxisSide = Last (Just YAxisLeft) } + +-- | 参照線を 1 本追加 (= 重ねがけで複数本)。 +-- +-- > example = ... <> refLine RefIdentity <> refLine (RefHorizontalAt 0) +refLine :: ReferenceLine -> VisualSpec +refLine rl = mempty { vsRefLines = [rl] } + +-- | shortcut。 +refIdentity :: VisualSpec +refIdentity = refLine RefIdentity +refHorizontal :: Double -> VisualSpec +refHorizontal y = refLine (RefHorizontalAt y) +refVertical :: Double -> VisualSpec +refVertical x = refLine (RefVerticalAt x) + +-- | Phase 26 §C-2 #10: scatter の周辺に X/Y 両方の histogram。 +marginal :: VisualSpec +marginal = mempty { vsMarginal = Last (Just (defaultMarginalSpec { msShowX = True, msShowY = True })) } + +-- | 周辺 histogram X 軸のみ。 +marginalX :: VisualSpec +marginalX = mempty { vsMarginal = Last (Just (defaultMarginalSpec { msShowX = True })) } + +-- | 周辺 histogram Y 軸のみ。 +marginalY :: VisualSpec +marginalY = mempty { vsMarginal = Last (Just (defaultMarginalSpec { msShowY = True })) } + +-- =========================================================================== +-- Font customization setter (= hgg-frontend-settings-spec v0.1 §1.3) +-- =========================================================================== + +titleFont :: FontSpec -> VisualSpec +titleFont f = mempty { vsTitleFont = Last (Just f) } + +axisLabelFont :: FontSpec -> VisualSpec +axisLabelFont f = mempty { vsAxisLabelFont = Last (Just f) } + +tickFont :: FontSpec -> VisualSpec +tickFont f = mempty { vsTickFont = Last (Just f) } + +legendFont :: FontSpec -> VisualSpec +legendFont f = mempty { vsLegendFont = Last (Just f) } diff --git a/src/Graphics/Hgg/Spec/Theme.hs b/src/Graphics/Hgg/Spec/Theme.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Theme.hs @@ -0,0 +1,141 @@ +-- | +-- Module : Graphics.Hgg.Spec.Theme +-- Description : theme preset (ThemeName) + series palette + element 単位 override +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 描画 theme の名前 +-- ('ThemeName')、 preset ごとの series palette、 named palette (Okabe-Ito 等)、 +-- element 単位の上書き ('ThemeOverride'、 ggplot theme(element_*) 相当) を持つ。 +-- 公開 API は従来どおり 'Graphics.Hgg.Spec' (facade) が re-export する。 +-- 挙動・出力は完全に不変。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Theme + ( -- * theme preset + palette + ThemeName(..) + , themeSeriesPalette + , okabeIto, tolBright, brewerSet2, brewerDark2 + -- * element 単位 override + , ThemeOverride(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Monoid (Last (..)) +import Data.Text (Text) +import GHC.Generics (Generic, Generically (..)) + +import Graphics.Hgg.Spec.Decoration (FontSpec) + +-- | 描画 theme (= 名前で参照、 関数を持たない = JSON serializable)。 +-- ggplot 標準 preset (ThemeGrey) + ブランドテーマを追加。 +-- * ThemeGrey = ggplot 既定 theme_grey (灰背景 #EBEBEB・白 grid・枠なし・軸線なし) +-- * ThemeNoir = ブランド (暗・上品・寒色アクセント、 コンペ用に残置) +-- * ThemeLumen = ブランド (白基調・深い差し色・清潔、 コンペ用に残置) +-- * ThemeParchment = 羊皮紙基調・明の正式テーマ。 配色は cream/gold/ink + +-- Universal Categorical series 由来。 +-- * ThemeParchmentDark = 同テーマの暗版 (焦茶インク背景・series は shade 300 で沈み防止)。 +data ThemeName = ThemeDefault | ThemeMinimal | ThemeDark | ThemeLight + | ThemeGrey | ThemeBW | ThemeClassic | ThemeVoid | ThemeLinedraw + | ThemeNoir | ThemeLumen + | ThemeParchment | ThemeParchmentDark + deriving (Show, Eq, Generic) + +instance ToJSON ThemeName +instance FromJSON ThemeName + +-- | preset ごとの既定 series palette (= palette 未指定時に使う色順)。 +-- ggplot 系 preset は従来通り hggMain (既定配色)、 ブランド 3 種は専用 series。 +-- Layout.computeLayout の catPal 既定がこれを参照する (= palette 指定で上書き可)。 +themeSeriesPalette :: ThemeName -> [Text] +themeSeriesPalette t = case t of + ThemeNoir -> ["#7AA2F7", "#BB9AF7", "#7DCFFF", "#9ECE6A", "#E0AF68", "#F7768E"] + ThemeLumen -> ["#4C5BD4", "#D6336C", "#2F9E44", "#E8590C", "#7048E8", "#1098AD"] + -- Parchment 明: 案3 (#1 = White Rabbit Inner Ear Pink #F0A5A0、 + -- #3 = Dormouse 系 Warm Yellow #E8D58A、 他は既定配色)。 + ThemeParchment -> canvasPal + -- 暗版 (Charcoal 背景): 案3 の暗色 (purple/teal/rose/wine) を明度調整し沈み防止。色相・順序は維持。 + ThemeParchmentDark -> [ "#F0A5A0", "#A98BD0", "#E8D58A", "#5FA0A8" + , "#E0617E", "#B8C7D9", "#D9685F" ] + -- default 系 (grey/default/minimal/light/dark) は ggplot2 既定 scales::hue_pal() にならう。 + -- ★Phase 28 (2026-06-14): 固定 7 色版でなく **群数 n 依存の hue sentinel** を返す。 + -- ggplot は離散色スケールごとに hue_pal()(n) を再計算するため、 群数 3 なら + -- 赤/緑/青、 4 なら別配色…と変わる。 固定 7 色だと群数 3 でも index 0,1,2 = + -- 赤/金/緑 になり R4DS と食い違っていた。 sentinel は Layout.catPal / + -- Bridge.resolveGrouped が 'ggplotHue' n で展開する。 + _ -> ["__ggplot_hue__"] + where + canvasPal = [ "#F0A5A0", "#7A5C92", "#E8D58A", "#3E6A6F" + , "#C7445D", "#B8C7D9", "#7E1F23" ] + +-- | 学術向け named series palette。 theme とは独立に `palette <名>` で使う (colorblind-safe 中心)。 +-- Okabe-Ito (Okabe & Ito 2008、 色覚バリアフリー定番、 R palette.colors("Okabe-Ito") と同一)。 +okabeIto :: [Text] +okabeIto = [ "#000000", "#E69F00", "#56B4E9", "#009E73" + , "#F0E442", "#0072B2", "#D55E00", "#CC79A7" ] + +-- | Paul Tol bright (7 色、 色覚バリアフリー)。 +tolBright :: [Text] +tolBright = [ "#4477AA", "#EE6677", "#228833", "#CCBB44" + , "#66CCEE", "#AA3377", "#BBBBBB" ] + +-- | ColorBrewer Set2 (8 色、 柔らかい定性)。 +brewerSet2 :: [Text] +brewerSet2 = [ "#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3" + , "#A6D854", "#FFD92F", "#E5C494", "#B3B3B3" ] + +-- | ColorBrewer Dark2 (8 色、 濃いめ定性、 白背景向き)。 +brewerDark2 :: [Text] +brewerDark2 = [ "#1B9E77", "#D95F02", "#7570B3", "#E7298A" + , "#66A61E", "#E6AB02", "#A6761D", "#666666" ] + +-- =========================================================================== +-- Phase 9 A-2: element 単位 theme override (ggplot theme(element_*) 相当) +-- =========================================================================== +-- | preset (ThemeName) に要素単位で上書きを合成する override。 各 field は Last で +-- 「指定があれば優先」。 'resolveTheme' (Render) が preset palette に合成する。 +-- 全 field Monoid なので setter を `<>` で重ねられる (ggplot の theme() 加算と同様)。 +data ThemeOverride = ThemeOverride + { toPlotBg :: !(Last Text) -- plot.background fill + , toPanelBg :: !(Last Text) -- panel.background fill + , toShowPanel :: !(Last Bool) -- panel 矩形を塗るか + , toGridColor :: !(Last Text) -- panel.grid colour + , toShowGrid :: !(Last Bool) -- panel.grid on/off + , toShowBorder :: !(Last Bool) -- panel.border on/off + , toShowAxisLine :: !(Last Bool) -- axis.line on/off + , toAxisColor :: !(Last Text) -- axis 線/目盛り色 + , toTextColor :: !(Last Text) -- 文字色 + -- ★ Phase 9 A-3: 文字 theme 統合 (ggplot theme(text/plot.title/axis.title/...) 相当)。 + -- 各 slot の FontSpec を theme から差し替え可能に。 優先順位は + -- override (これ) > font setter (vsTitleFont 等) > preset 既定 ('mkFontTS')。 + , toTitleFont :: !(Last FontSpec) -- plot.title + , toAxisLabelFont :: !(Last FontSpec) -- axis.title + , toTickFont :: !(Last FontSpec) -- axis.text + , toLegendFont :: !(Last FontSpec) -- legend.title / legend.text + -- ★ axis.text の回転角 (度・CCW)。 per-axis 'axisRotate' 未指定時の fallback。 + -- 'toAxisTextAngle' = x/y 共通既定、 'toAxisTextAngleX'/'toAxisTextAngleY' = 軸別上書き + -- (Phase 50 A3・軸別 > 共通 の優先。 'axisTextAngleXOf'/'axisTextAngleYOf' で解決)。 + , toAxisTextAngle :: !(Last Double) + , toAxisTextAngleX :: !(Last Double) + , toAxisTextAngleY :: !(Last Double) + -- ★ Phase 9 A-4: strip.background (facet strip の灰矩形)。 + , toStripBg :: !(Last Text) -- strip.background fill + , toShowStrip :: !(Last Bool) -- strip 矩形を塗るか + -- ★ Phase 43 A4: プリセット専用だった 4 項目に上書き口を追加 (= 全プロパティ `<>` 上書き + -- 可能に)。対応 'ThemePalette' field = tpTitleHjust / tpTitleColor / tpTickLineColor / + -- tpLegendKeyBg。generic 導出なので field 追加のみで instance は自動追従。 + , toTitleHjust :: !(Last Double) -- plot.title の水平揃え (0=左、 0.5=中央) + , toTitleColor :: !(Last Text) -- plot.title / axis.title の文字色 + , toTickLineColor :: !(Last Text) -- 軸目盛線 (tick mark) の色 + , toLegendKeyBg :: !(Last Text) -- legend.key 背景塗り色 ("" なら塗らない) + } deriving stock (Generic, Show, Eq) + -- ★ Phase 43 A3: 全 field が `Last` の素直な per-field 合成なので generic 導出。 + -- 位置依存の手書き instance (旧 `a1..p1` を数で揃える形) を撲滅し、 以後の field + -- 追加 (A4) を「field を足すだけ」で安全にする。挙動は旧手書きと完全同型。 + deriving (Semigroup, Monoid) via Generically ThemeOverride + +instance ToJSON ThemeOverride +instance FromJSON ThemeOverride + diff --git a/src/Graphics/Hgg/Spec/Visual.hs b/src/Graphics/Hgg/Spec/Visual.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Spec/Visual.hs @@ -0,0 +1,266 @@ +-- | +-- Module : Graphics.Hgg.Spec.Visual +-- Description : VisualSpec (= 外側 Monoid、 図全体の宣言型 spec) + Inset +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 図全体の宣言型 spec +-- 'VisualSpec' と field-wise Monoid 合成 (@design/monoid-semantics.md@)、 および +-- 'Inset' を持つ。 'Inset.inSpec :: VisualSpec' ⇄ 'VisualSpec.vsInsets :: [Inset]' +-- の相互参照ゆえ 2 型は本 module に同居する (Phase 55 A1 実測・唯一の循環ペア)。 +-- 公開 API は従来どおり 'Graphics.Hgg.Spec' (facade) が re-export する。 +-- 挙動・出力 (JSON 形含む) は完全に不変。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Visual + ( VisualSpec(..) + , Inset(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.List +import Data.Monoid (Last (..)) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Graphics.Hgg.Unit (Length) +import Graphics.Hgg.Spec.Axis (AxisSpec) +import Graphics.Hgg.Spec.Column (ColRef) +import Graphics.Hgg.Spec.Decoration (Annotation, FontSpec, LegendSpec, + MarginalSpec, ReferenceLine) +import Graphics.Hgg.Spec.Layer (Layer) +import Graphics.Hgg.Spec.Mark (Coord, FacetScales, FacetSpace) +import Graphics.Hgg.Spec.Theme (ThemeName, ThemeOverride) + +-- =========================================================================== +-- Inset (= P13、 親 plot に小型 sub-plot を埋込み) +-- =========================================================================== + +data Inset = Inset + { inSpec :: !VisualSpec + , inX :: !Double, inY :: !Double + , inW :: !Double, inH :: !Double + } deriving (Show, Eq, Generic) + +instance ToJSON Inset +instance FromJSON Inset + +-- =========================================================================== +-- VisualSpec (= 外側 Monoid) +-- =========================================================================== + +-- | 図全体の宣言型 spec。 全 field を Monoid 化して field-wise `<>` 合成。 +data VisualSpec = VisualSpec + { vsLayers :: ![Layer] + , vsTitle :: !(Last Text) + , vsTheme :: !(Last ThemeName) + , vsFacet :: !(Last ColRef) + , vsXLabel :: !(Last Text) + , vsYLabel :: !(Last Text) + , vsXAxis :: !(Last AxisSpec) -- ★ Phase 26 §C-2 #1 + , vsYAxis :: !(Last AxisSpec) -- ★ Phase 26 §C-2 #1 + , vsYAxisRight :: !(Last AxisSpec) -- ★ P5 dual Y 軸 (右側) + , vsRefLines :: ![ReferenceLine] -- ★ Phase 26 §C-2 #3 + , vsMarginal :: !(Last MarginalSpec) -- ★ Phase 26 §C-2 #10 + , vsSubplots :: ![VisualSpec] -- ★ Phase 26 S5-e-1 panel grid (= facet と独立、 任意の sub-spec 並列) + , vsSubplotCols :: !(Last Int) -- ★ P18 2D grid 折り返し列数 + , vsLegend :: !(Last LegendSpec) -- ★ P8 2026-05-25 凡例設定 (= Nothing なら auto) + , vsAnnotations :: ![Annotation] -- ★ P6 任意 overlay (text/arrow/rect/line) + , vsInsets :: ![Inset] -- ★ P13 inset axes + , vsPalette :: !(Last [Text]) -- ★ P17 categorical palette (= Nothing なら hggMain F-3) + , vsContinuousPal :: !(Last [Text]) -- ★ P17 continuous palette (= Nothing なら viridis5) + , vsTitleFont :: !(Last FontSpec) -- ★ frontend-settings v0.1 §1.3 + , vsAxisLabelFont :: !(Last FontSpec) -- ★ 〃 + , vsTickFont :: !(Last FontSpec) -- ★ 〃 + , vsLegendFont :: !(Last FontSpec) -- ★ 〃 + , vsWidth :: !(Last Length) -- ★ Phase 33: 図幅 (Length・既定 mm)。px=pt×dpi/72。 + , vsHeight :: !(Last Length) -- ★ Phase 33: 図高 (Length・既定 mm)。 + -- ★ Phase 33: 描画 dpi。px backend は px=pt×dpi/72、PDF backend は無視 (pt 直結)。 + -- 未指定 = 96 (web 標準)。 + , vsDpi :: !(Last Double) + -- ★ Phase 8 A2 Step2: coord_fixed(ratio) 相当。 panel の 高/幅 比 (aspect)。 + -- Nothing = 可用域を埋める (ggplot 既定 Coord$aspect = NULL)。 Just a (a>0) = + -- 可用域内で aspect を保つ最大 panel を取り中央寄せ。 root: ggplot R/coord-.R。 + , vsAspect :: !(Last Double) + -- ★ Phase 8 C G7: facet_wrap の列数 (ncol)。 Nothing = 従来の 1 行 N 列 (非破壊)、 + -- Just n = n 列で複数行に折り返し (nrow = ceil(panel 数 / n))。 root: ggplot facet_wrap。 + , vsFacetNcol :: !(Last Int) + -- ★ Phase 8 C G7 part-b: facet_grid(row ~ col)。 2 変数 cross 配置。 + -- vsFacetRow = 行を作る変数 (levels が各行、 右側 strip)、 vsFacetCol = 列を作る変数 + -- (levels が各列、 上側 strip)。 両 Nothing = grid 無し (= 従来 facet_wrap 経路)。 + -- 片方のみ指定も可 (1 行 or 1 列の grid)。 root: ggplot facet_grid。 + , vsFacetRow :: !(Last ColRef) + , vsFacetCol :: !(Last ColRef) + -- ★ Phase 9 A-2: element 単位 theme override (preset に合成、 resolveTheme で解決)。 + , vsThemeOverride :: !ThemeOverride + -- ★ Phase 9 C: 座標系 (coord_flip 等)。 Nothing = CoordCartesian (= ggplot 既定)。 + , vsCoord :: !(Last Coord) + -- ★ Phase 11 A4-a: 軸反転 (= ggplot scale_x_reverse / scale_y_reverse)。 + -- Just True で該当軸の scale range (rLo/rHi) を入替え、 大値が小座標側に。 + -- tick/grid/glyph は scaleApply 経由なので自動追従 (renderer 無変更)。 + -- coord_flip とは独立合成 (= データ軸基準で反転、 flip 後も x/y データ軸を指す)。 + , vsReverseX :: !(Last Bool) + , vsReverseY :: !(Last Bool) + -- ★ Phase 11 A4-c: 明示凡例タイトル (= ggplot scale_color_*(name=) / labs(color=))。 + -- Nothing なら従来通りタイトル非表示 (= legend 項目が自己説明的)。 明示値なので + -- bakeSpec (色列 inline 化) 後も保持され HS/PS が同一描画 (Phase 9 A-5 の食い違い回避)。 + , vsLegendTitle :: !(Last Text) + -- ★ Phase 11 A4-e: 色/サイズ scale 拡充。 + -- vsColorManual = ggplot scale_color_manual(values=)。 カテゴリ名→hex の辞書。 + -- ColorByCol で当該名があれば palette index より優先。 未登録名は従来の palette。 + , vsColorManual :: !(Last [(Text, Text)]) + -- vsColorGradient2 = ggplot scale_color_gradient2(low,mid,high,midpoint=)。 発散 palette。 + -- ColorByContinuous で midpoint を 0.5 に固定 (lo..mid→[0,.5]・mid..hi→[.5,1] 個別正規化)。 + , vsColorGradient2 :: !(Last (Text, Text, Text, Double)) + -- vsSizeRange = ggplot scale_size(range=c(min,max))。 sizeBy の px 範囲 (default (3,10))。 + , vsSizeRange :: !(Last (Double, Double)) + -- ★ Phase 11 A5-a: labs サブシステム (= ggplot labs(subtitle=,caption=,tag=))。 + -- vsSubtitle = title 直下の小見出し。 vsCaption = 図右下の注記。 vsTag = 左上隅のタグ。 + -- いずれも Nothing で従来同一 (= 描画も margin 予約も無し)。 + , vsSubtitle :: !(Last Text) + , vsCaption :: !(Last Text) + , vsTag :: !(Last Text) + -- ★ Phase 11 A5-c: guides サブシステム (= ggplot guide_legend(reverse=, ncol=, nrow=))。 + -- 位置 ('vsLegend') とは独立 (= vsLegendTitle と同じく VisualSpec レベルに置き + -- LegendSpec Semigroup の position 上書き footgun を回避)。 いずれも Nothing で従来同一。 + -- vsLegendReverse = 凡例キーの表示順を逆に (色は各キーに固定のまま)。 + -- vsLegendNcol = 縦凡例 (Right/Inside) の列数、 vsLegendNrow = 横凡例 (Bottom) の行数。 + , vsLegendReverse :: !(Last Bool) + , vsLegendNcol :: !(Last Int) + , vsLegendNrow :: !(Last Int) + -- ★ Phase 11 A7-a: coord_cartesian(xlim,ylim) = データを落とさない zoom。 + -- axisRange (= scale limits、 範囲外データを切る) と別概念で、 scale domain を + -- 指定範囲に上書きするだけ。 stat (regression/density 等) は全データから計算され、 + -- 範囲外の glyph は panel に clip される (= ggplot coord_cartesian, expand=FALSE)。 + -- numeric 軸のみ有効 (categorical / funnel 軸は無視)。 Nothing で従来同一。 + , vsCoordXLim :: !(Last (Double, Double)) + , vsCoordYLim :: !(Last (Double, Double)) + -- ★ Phase 11 A7-b: facet free scales (= ggplot facet_wrap(scales=))。 Nothing = + -- FacetFixed (全 panel 共通 domain)。 free な軸は各 panel が自分のデータで domain を + -- 再計算し、 全 panel に軸を表示する (= 値比較より panel 内分布を優先)。 facet_wrap + -- (renderFaceted) のみ対応 (facet_grid は別途)。 + , vsFacetScales :: !(Last FacetScales) + -- ★ Phase 11 A7-b: facet_grid の panel サイズ配分 (= ggplot facet_grid(space=))。 + -- Nothing = SpaceFixed (全 panel 同サイズ)。 free な軸は track 重みを data 範囲比例に。 + , vsFacetSpace :: !(Last FacetSpace) + -- ★ Phase 18 A1: subplot panel の名前選択 (= 'repeatFields' の逆方向)。 + -- Just ws = vsSubplots の子を vsTitle ∈ ws で filter し **ws の列挙順に並べ替え** + -- (ggplot discrete limits と同じ「選択 + 順序」 の意味論)。 名前不一致は無視。 + -- Nothing = 従来通り全 panel。 facet panel (データ分割) は対象外 (subplots 専用)。 + , vsPanelSel :: !(Last [Text]) + -- ★ Phase 18 A2: 離散軸カテゴリの limits (= ggplot @scale_x_discrete(limits=)@ / + -- @scale_y_discrete(limits=)@、 連続版 'axisRange' の離散対応)。 Just ws = 当該軸の + -- encoding が ColTxt の layer について **カテゴリ行を選択 + ws の列挙順に並べ替え** + -- (行 filter は全 row-aligned encoding を同 index で間引く)。 aes 基準 (coord_flip と + -- 直交 = flip 後も x/y データ軸を指す、 'vsReverseX' と同思想)。 Nothing = 従来通り。 + -- ★Last-上書き footgun 回避のため AxisSpec でなく VisualSpec 直 field + -- ('vsLegendTitle' / Phase 11 A4-c と同じ判断)。 + , vsXDiscreteLimits :: !(Last [Text]) + , vsYDiscreteLimits :: !(Last [Text]) + } deriving (Generic, Show, Eq) + +instance ToJSON VisualSpec +instance FromJSON VisualSpec + +-- | 図全体の合成。 list 系 (layers/refLines/subplots/annotations/insets) は +-- concat、 残りは 'Last' で後勝ち、 themeOverride は element 単位 Monoid。 +-- 合成規則の全体表は @design/monoid-semantics.md@ を参照。 +-- ★ Phase 43 A3: レコードフィールド形式 (位置依存撲滅・挙動不変)。49 field の位置揃え +-- (旧 `l1 t1 th1 …`) を撲滅し、 以後の field 追加を「行を 1 本足すだけ」 + `-Wmissing-fields` +-- 保護下にする。唯一の特殊合成 'mergeColorManual' (= Phase 52.A10/19 の dedup 合成) のみ +-- 名前付きで温存。list 系は `<>`=concat、 残りは `Last` 後勝ち、 themeOverride は element Monoid。 +instance Semigroup VisualSpec where + a <> b = VisualSpec + { vsLayers = vsLayers a <> vsLayers b + , vsTitle = vsTitle a <> vsTitle b + , vsTheme = vsTheme a <> vsTheme b + , vsFacet = vsFacet a <> vsFacet b + , vsXLabel = vsXLabel a <> vsXLabel b + , vsYLabel = vsYLabel a <> vsYLabel b + , vsXAxis = vsXAxis a <> vsXAxis b + , vsYAxis = vsYAxis a <> vsYAxis b + , vsYAxisRight = vsYAxisRight a <> vsYAxisRight b + , vsRefLines = vsRefLines a <> vsRefLines b + , vsMarginal = vsMarginal a <> vsMarginal b + , vsSubplots = vsSubplots a <> vsSubplots b + , vsSubplotCols = vsSubplotCols a <> vsSubplotCols b + , vsLegend = vsLegend a <> vsLegend b + , vsAnnotations = vsAnnotations a <> vsAnnotations b + , vsInsets = vsInsets a <> vsInsets b + , vsPalette = vsPalette a <> vsPalette b + , vsContinuousPal = vsContinuousPal a <> vsContinuousPal b + , vsTitleFont = vsTitleFont a <> vsTitleFont b + , vsAxisLabelFont = vsAxisLabelFont a <> vsAxisLabelFont b + , vsTickFont = vsTickFont a <> vsTickFont b + , vsLegendFont = vsLegendFont a <> vsLegendFont b + , vsWidth = vsWidth a <> vsWidth b + , vsHeight = vsHeight a <> vsHeight b + , vsDpi = vsDpi a <> vsDpi b + , vsAspect = vsAspect a <> vsAspect b + , vsFacetNcol = vsFacetNcol a <> vsFacetNcol b + , vsFacetRow = vsFacetRow a <> vsFacetRow b + , vsFacetCol = vsFacetCol a <> vsFacetCol b + , vsThemeOverride = vsThemeOverride a <> vsThemeOverride b + , vsCoord = vsCoord a <> vsCoord b + , vsReverseX = vsReverseX a <> vsReverseX b + , vsReverseY = vsReverseY a <> vsReverseY b + , vsLegendTitle = vsLegendTitle a <> vsLegendTitle b + -- ★特殊: 全群の色辞書を concat+dedup (Last 後勝ちだと先頭群が消える・Phase 52.A10/19) + , vsColorManual = mergeColorManual (vsColorManual a) (vsColorManual b) + , vsColorGradient2 = vsColorGradient2 a <> vsColorGradient2 b + , vsSizeRange = vsSizeRange a <> vsSizeRange b + , vsSubtitle = vsSubtitle a <> vsSubtitle b + , vsCaption = vsCaption a <> vsCaption b + , vsTag = vsTag a <> vsTag b + , vsLegendReverse = vsLegendReverse a <> vsLegendReverse b + , vsLegendNcol = vsLegendNcol a <> vsLegendNcol b + , vsLegendNrow = vsLegendNrow a <> vsLegendNrow b + , vsCoordXLim = vsCoordXLim a <> vsCoordXLim b + , vsCoordYLim = vsCoordYLim a <> vsCoordYLim b + , vsFacetScales = vsFacetScales a <> vsFacetScales b + , vsFacetSpace = vsFacetSpace a <> vsFacetSpace b + , vsPanelSel = vsPanelSel a <> vsPanelSel b + , vsXDiscreteLimits = vsXDiscreteLimits a <> vsXDiscreteLimits b + , vsYDiscreteLimits = vsYDiscreteLimits a <> vsYDiscreteLimits b + } + +instance Monoid VisualSpec where + -- 全 field が Monoid (list=[]・Last=Last Nothing・ThemeOverride=element mempty) なので + -- 一律 mempty。レコード形式により field 追加時の位置ズレ事故が起きない。 + mempty = VisualSpec + { vsLayers = mempty, vsTitle = mempty, vsTheme = mempty, vsFacet = mempty + , vsXLabel = mempty, vsYLabel = mempty, vsXAxis = mempty, vsYAxis = mempty + , vsYAxisRight = mempty, vsRefLines = mempty, vsMarginal = mempty + , vsSubplots = mempty, vsSubplotCols = mempty, vsLegend = mempty + , vsAnnotations = mempty, vsInsets = mempty, vsPalette = mempty + , vsContinuousPal = mempty, vsTitleFont = mempty, vsAxisLabelFont = mempty + , vsTickFont = mempty, vsLegendFont = mempty, vsWidth = mempty, vsHeight = mempty + , vsDpi = mempty, vsAspect = mempty, vsFacetNcol = mempty, vsFacetRow = mempty + , vsFacetCol = mempty, vsThemeOverride = mempty, vsCoord = mempty + , vsReverseX = mempty, vsReverseY = mempty, vsLegendTitle = mempty + , vsColorManual = mempty, vsColorGradient2 = mempty, vsSizeRange = mempty + , vsSubtitle = mempty, vsCaption = mempty, vsTag = mempty + , vsLegendReverse = mempty, vsLegendNcol = mempty, vsLegendNrow = mempty + , vsCoordXLim = mempty, vsCoordYLim = mempty, vsFacetScales = mempty + , vsFacetSpace = mempty, vsPanelSel = mempty, vsXDiscreteLimits = mempty + , vsYDiscreteLimits = mempty + } + +-- | Phase 52.A10: scale_color_manual 辞書の合成。 旧実装は Last の最後勝ちで、 異モデル +-- 重畳 (各レイヤが 1 群の ColorByCol + 単一辞書) のとき先頭群の色辞書が捨てられ全線同色化 +-- していた。 ここでは両辞書を concat し同じカテゴリ名は後勝ちで dedup する (= 全群の色が +-- 残り各 ColorByCol レイヤが自色を引ける)。 片方 Nothing は他方をそのまま採用。 +mergeColorManual :: Last [(Text, Text)] -> Last [(Text, Text)] -> Last [(Text, Text)] +mergeColorManual (Last Nothing) b = b +mergeColorManual a (Last Nothing) = a +mergeColorManual (Last (Just d1)) (Last (Just d2)) = + Last (Just (dedupColorManual (d1 <> d2))) + where + -- 同 key (カテゴリ名) は後勝ち = 後方の値を優先。 出現順は最初の出現位置で保存。 + dedupColorManual kvs = + let lastVal k = last [ v | (k', v) <- kvs, k' == k ] + -- ★Phase 19: 旧 foldr 形は interleaved 重複で最終出現順になっていた + -- (辞書は lookup のみで順序非依存だが、 コメント通り初出順に統一) + keysInOrder = nubKeep (map fst kvs) + in [ (k, lastVal k) | k <- keysInOrder ] + nubKeep = Data.List.nub diff --git a/src/Graphics/Hgg/Unit.hs b/src/Graphics/Hgg/Unit.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Unit.hs @@ -0,0 +1,174 @@ +-- | +-- Module : Graphics.Hgg.Unit +-- Description : 長さの単位系 (pt オーサリング + dpi 描画境界、Phase 33) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- hgg は SVG / Canvas / PNG / PDF の複数 backend を持つ。PDF は point +-- (1/72 inch) ネイティブなので、オーサリングは物理単位 (mm/cm/inch/pt) を主とし、 +-- px 出力境界で一度だけ @px = pt × dpi/72@ を掛ける。本 module は最下層の純 value +-- 層で、Spec / Layout から参照される (Spec には依存しない = 循環回避)。 +-- +-- 単位は値と一体 ('Length')。混在は許さず、各値が自分の単位を持つ。px は dpi 依存 +-- なので 'toPt' では変換できず ('Nothing')、dpi を受け取る 'lengthToPt' で解決する。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Graphics.Hgg.Unit + ( LUnit(..) + , Length(..) + , mm, cm, inch, pt', px + , (*~) + , mmToPt + , toPt + , lengthToPt + -- * 座標 (Phase 33 B3): 相対単位込みの位置型 + resolver 別名 + , Pos(..) + , resolveLen + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, + pairs, withObject, (.:), (.=)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +-- === 型 === + +-- | 長さの単位。Mm/Cm/In/Pt は dpi 非依存の物理単位、Px は device 依存。 +data LUnit = Mm | Cm | In | Pt | Px + deriving (Eq, Show, Generic) + +-- | 値と単位を一体に保持する長さ。 +data Length = Length !Double !LUnit + deriving (Eq, Show, Generic) + +-- | 軸に沿った「座標」(サイズ 'Length' ではない)。注釈・参照線・inset の自由配置 +-- に使う。相対単位 (npc/native) の意味は panel rect / scale が決めるので、解決は +-- 'UCtx' を受け取る Layout 側 resolver (@resolvePosX/Y@) が担う (本 module には +-- 型と Codec だけ置き、Rect/Scale への依存を避ける = 循環回避)。 +data Pos + = PAbs !Length -- ^ 物理長オフセット (pt/mm/in/px)。panel 原点基準。 + | PNpc !Double -- ^ panel 正規化座標 0..1 (0=左/下端, 1=右/上端)。 + | PNative !Double -- ^ data 座標 (scale 経由で pt 化)。 + deriving (Eq, Show, Generic) + +-- === 構築 (単位量 + スカラ倍) === + +-- | 各単位の「1 単位」を表す単位量。@7 *~ inch@ のように使う。 +mm, cm, inch, pt', px :: Length +mm = Length 1 Mm +cm = Length 1 Cm +inch = Length 1 In +pt' = Length 1 Pt +px = Length 1 Px + +-- | スカラ倍 (単位保存)。@k *~ (n 単位) = (k*n) 単位@。 +infixl 7 *~ +(*~) :: Double -> Length -> Length +k *~ Length n u = Length (k * n) u + +-- | 数値リテラルを 'Length' として解釈するための 'Num' / 'Fractional' instance +-- (Phase 34 A2)。狙いは @width 624@ のような **bare 数値リテラル = pt** を成立させ、 +-- かつ @width (7 *~ inch)@ の単位付きも同じ引数型で受けること。 +-- +-- ★ なぜ型クラス ('ToLength' 案) でなくこちら: @ToLength a => a -> _@ だと +-- @width 624@ が @(Num a, ToLength a) => a@ で曖昧化し、ToLength が標準クラスでない +-- ため Haskell2010 の defaulting が効かず**コンパイル不可** (Phase 34 A2 で実測検証)。 +-- @Num Length@ なら @624 :: Length = fromInteger 624 = Length 624 Pt@ と確定し曖昧化しない +-- (CSS length ライブラリ = clay/diagrams と同じ慣用)。 +-- +-- 算術 (@+@/@-@/@*@) は **同一単位の被演算子**を想定し、左辺の単位を保存して数値だけ +-- 合成する (主用途はリテラル overloading なので cross-unit 演算は非対象)。 +instance Num Length where + fromInteger n = Length (fromInteger n) Pt + Length a u + Length b _ = Length (a + b) u + Length a u - Length b _ = Length (a - b) u + Length a u * Length b _ = Length (a * b) u + abs (Length a u) = Length (abs a) u + signum (Length a u) = Length (signum a) u + negate (Length a u) = Length (negate a) u + +instance Fractional Length where + fromRational r = Length (fromRational r) Pt + Length a u / Length b _ = Length (a / b) u + +-- === pt への正規化 === + +-- | mm → pt 変換定数 (72pt / 25.4mm ≈ 2.8346)。ggplot の @.pt=72.27/25.4@ / +-- @.stroke=96/25.4@ の基準混在は採らず、全部 72pt/inch に統一する。 +mmToPt :: Double +mmToPt = 72 / 25.4 + +-- | dpi 非依存単位を pt 化。'Px' は dpi が要るので 'Nothing' (型で表現)。 +toPt :: Length -> Maybe Double +toPt (Length n u) = case u of + Pt -> Just n + In -> Just (n * 72) + Cm -> Just (n * 10 * mmToPt) + Mm -> Just (n * mmToPt) + Px -> Nothing + +-- | dpi を受け取り全単位を pt 化。'Px' のみ @n * 72/dpi@。 +-- computeLayout 入口で figure size を解決する本命関数。 +lengthToPt :: Double -> Length -> Double +lengthToPt dpi (Length n u) = case u of + Pt -> n + In -> n * 72 + Cm -> n * 10 * mmToPt + Mm -> n * mmToPt + Px -> n * 72 / dpi + +-- | 'Length' を pt 化する resolver 別名 ('lengthToPt' と同一)。Pos resolver +-- (@resolvePosX/Y@) と対で「単位を pt へ解く」API を一様に呼ぶための名前。 +resolveLen :: Double -> Length -> Double +resolveLen = lengthToPt + +-- === JSON Codec === +-- @{ "v": Double, "u": String }@。key 順 v→u を toEncoding で固定し、PS argonaut と +-- byte 一致させる。tag は小文字 "mm"|"cm"|"in"|"pt"|"px"。 + +lunitTag :: LUnit -> Text +lunitTag u = case u of + Mm -> "mm"; Cm -> "cm"; In -> "in"; Pt -> "pt"; Px -> "px" + +instance ToJSON Length where + toJSON (Length v u) = object ["v" .= v, "u" .= lunitTag u] + toEncoding (Length v u) = pairs ("v" .= v <> "u" .= lunitTag u) + +instance FromJSON Length where + -- 後方互換 (Phase 33 移行): 旧来の px Int/Number 形式を px Length として読む。 + parseJSON (Number n) = pure (Length (realToFrac n) Px) + parseJSON other = flip (withObject "Length") other $ \o -> do + v <- o .: "v" + uStr <- o .: "u" + u <- case (uStr :: Text) of + "mm" -> pure Mm + "cm" -> pure Cm + "in" -> pure In + "pt" -> pure Pt + "px" -> pure Px + _ -> fail ("Graphics.Hgg.Unit: unknown LUnit tag " <> T.unpack uStr) + pure (Length v u) + +-- | 'Pos' の Codec。tag 付き @{ "t": "abs"|"npc"|"native", ... }@。 +-- "abs" は @"l"@ に 'Length'、"npc"/"native" は @"p"@ に Double。key 順は +-- toEncoding (t→payload) で固定し PS argonaut と byte 一致させる。 +instance ToJSON Pos where + toJSON p = case p of + PAbs l -> object ["t" .= ("abs" :: Text), "l" .= l] + PNpc x -> object ["t" .= ("npc" :: Text), "p" .= x] + PNative x -> object ["t" .= ("native" :: Text), "p" .= x] + toEncoding p = case p of + PAbs l -> pairs ("t" .= ("abs" :: Text) <> "l" .= l) + PNpc x -> pairs ("t" .= ("npc" :: Text) <> "p" .= x) + PNative x -> pairs ("t" .= ("native" :: Text) <> "p" .= x) + +instance FromJSON Pos where + parseJSON = withObject "Pos" $ \o -> do + t <- o .: "t" + case (t :: Text) of + "abs" -> PAbs <$> o .: "l" + "npc" -> PNpc <$> o .: "p" + "native" -> PNative <$> o .: "p" + _ -> fail ("Graphics.Hgg.Unit: unknown Pos tag " <> T.unpack t) diff --git a/src/Graphics/Hgg/Validate.hs b/src/Graphics/Hgg/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Validate.hs @@ -0,0 +1,466 @@ +-- | +-- Module : Graphics.Hgg.Validate +-- Description : Layer 3.5 ─ compile / validate / 診断 (Phase 11 A1 core hardening) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- 設計方針: +-- +-- * 「'VisualSpec' は直接描画しない」 を型で固定する。 backend に渡す前に +-- 'compilePlot' を通し、 必須 aesthetic 欠落 / 列解決失敗 / 型不一致 を検出。 +-- * 診断は **actionable** であること (= 「Missing y」 ではなく +-- 「scatter は x と y が必要。 y 列が未指定。 `y "yield"` を足してください」)。 +-- * 列名解決失敗には **編集距離 suggestion** を添える ('validatePlotWith' に +-- 既知列名を渡したとき)。 +-- * 'BackendCapability' で backend 非対応機能を compile 時に検出する。 +-- +-- 本 module は render を一切呼ばない (= 出力中立)。 既存 backend は当面そのまま +-- 動き、 段階的に 'compilePlot' 経由へ寄せる。 +-- +-- 既知の制約: 「1 layer に mark 2 個 (`scatter x y <> line x y`) を合成して 2 個目が +-- 黙って消える」 footgun は、 'Layer' の `lyKind :: First MarkKind` が合成時点で +-- 不可逆に潰れるため **post-hoc には検出できない**。 検出には Layer に診断用 +-- フィールドを足す必要があり、 Phase 11 A2 (Monoid 明文化) で扱う。 +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Validate + ( -- * Aesthetic / 型 + Aesthetic(..) + , aesName + , ExpectedType(..) + , ActualType(..) + -- * 診断 + , Severity(..) + , DiagnosticContext(..) + , PlotErrorKind(..) + , PlotWarningKind(..) + , PlotDiagnostic(..) + , diagnosticSeverity + , renderDiagnostic + -- * 必須 aesthetic + , requiredAes + , layerCols + -- * validate / compile + , validatePlot + , validatePlotWith + , suggest + , CompiledPlot + , compiledSpec + , compilePlot + , compilePlotWith + -- * Backend capability matrix (= §5.5) + , BackendName(..) + , FeatureName(..) + , BackendCapability(..) + , svgCapability + , pngCapability + , pdfCapability + , canvasCapability + , webglCapability + , checkCapability + ) where + +import Data.List (foldl', sortOn) +import Data.Maybe (isJust, mapMaybe) +import Data.Monoid (First (..), Last (..)) +import Data.Text (Text) +import qualified Data.Text as T + +import Graphics.Hgg.Spec + +-- =========================================================================== +-- Aesthetic / 型 +-- =========================================================================== + +-- | mark が要求しうる aesthetic 種別 (= 診断メッセージ用)。 +data Aesthetic + = AesX | AesY | AesY2 | AesColor | AesErrorX | AesErrorY + | AesSize | AesShape | AesDAG | AesCols + | AesU | AesV -- Phase 26 A2: vector field (quiver) の成分 + deriving (Show, Eq) + +-- | 診断文に出す aesthetic 名 (= setter 名に寄せる)。 +aesName :: Aesthetic -> Text +aesName a = case a of + AesX -> "x" + AesY -> "y" + AesY2 -> "y2 (upper)" + AesColor -> "color" + AesErrorX -> "errorX" + AesErrorY -> "errorY" + AesSize -> "size" + AesShape -> "shape" + AesDAG -> "dag" + AesCols -> "columns" + AesU -> "u" + AesV -> "v" + +data ExpectedType = ExpNumeric | ExpCategorical | ExpAny + deriving (Show, Eq) + +data ActualType = ActNumeric | ActCategorical | ActUnresolved + deriving (Show, Eq) + +-- =========================================================================== +-- 診断 +-- =========================================================================== + +data Severity = SevError | SevWarning | SevInfo + deriving (Show, Eq, Ord) + +-- | どの layer / mark で起きたか (= メッセージの文脈)。 +data DiagnosticContext = DiagnosticContext + { dcLayer :: Maybe Int -- ^ 0 始まりの layer index (Nothing = 図全体) + , dcMark :: Maybe MarkKind + } deriving (Show, Eq) + +topCtx :: DiagnosticContext +topCtx = DiagnosticContext Nothing Nothing + +data PlotErrorKind + = MissingAesthetic MarkKind Aesthetic + | ColumnNotFound Text [Text] -- ^ 見つからない列名 + 候補 (編集距離) + | ColumnTypeMismatch Text Aesthetic ExpectedType ActualType + | EmptyPlot -- ^ layer が 1 つも無い + | DistColsNonDistribution MarkKind -- ^ ★ Phase 36 D3: distCols のレーンが分布 mark でない + deriving (Show, Eq) + +data PlotWarningKind + = BackendUnsupported BackendName FeatureName + | TooFewColumns Aesthetic Int Int -- ^ 必要数 / 実数 (parallel 等) + deriving (Show, Eq) + +data PlotDiagnostic + = PlotError PlotErrorKind DiagnosticContext + | PlotWarning PlotWarningKind DiagnosticContext + | PlotInfo Text + deriving (Show, Eq) + +diagnosticSeverity :: PlotDiagnostic -> Severity +diagnosticSeverity PlotError{} = SevError +diagnosticSeverity PlotWarning{} = SevWarning +diagnosticSeverity PlotInfo{} = SevInfo + +-- | 人間が読める actionable メッセージ (= §5.4 Diagnostics Policy)。 +renderDiagnostic :: PlotDiagnostic -> Text +renderDiagnostic d = case d of + PlotError k ctx -> sev "error" <> ctxStr ctx <> errMsg k + PlotWarning k ctx -> sev "warning" <> ctxStr ctx <> warnMsg k + PlotInfo t -> sev "info" <> t + where + sev s = "[" <> s <> "] " + ctxStr (DiagnosticContext ml mm) = + let lp = maybe "" (\i -> "layer " <> tshow i <> " ") ml + mp = maybe "" (\m -> "(" <> markName m <> ") ") mm + in lp <> mp + errMsg k = case k of + MissingAesthetic m a -> + markName m <> " は " <> reqList m <> " が必要です。 " + <> aesName a <> " が未指定です。 setter `" <> aesName a + <> " ...` を足してください。" + ColumnNotFound n [] -> + "列 \"" <> n <> "\" が Resolver で解決できません。 列名と Resolver の供給列を確認してください。" + ColumnNotFound n cs -> + "列 \"" <> n <> "\" が見つかりません。 もしかして: " + <> T.intercalate " / " (map (\c -> "\"" <> c <> "\"") cs) <> " ?" + ColumnTypeMismatch n a exp_ act -> + "列 \"" <> n <> "\" を " <> aesName a <> " に使えません。 " + <> expName exp_ <> " が必要ですが " <> actName act <> " でした。" + EmptyPlot -> + "layer が 1 つもありません。 `layer (scatter x y)` 等を合成してください。" + DistColsNonDistribution m -> + "distCols のレーンは 1D 分布 mark (box/violin/strip/swarm/raincloud) 専用です。 " + <> markName m <> " は描画されません。 レーンを分布 mark にしてください。" + warnMsg k = case k of + BackendUnsupported b f -> + backendName b <> " backend は " <> featureName f + <> " 非対応です (fallback または無視されます)。" + TooFewColumns a need got -> + aesName a <> " は最低 " <> tshow need <> " 列必要ですが " <> tshow got <> " 列でした。" + expName ExpNumeric = "数値列" + expName ExpCategorical = "カテゴリ列" + expName ExpAny = "任意の列" + actName ActNumeric = "数値列" + actName ActCategorical = "カテゴリ (文字列) 列" + actName ActUnresolved = "未解決" + reqList m = T.intercalate "+" (map aesName (requiredAes m)) + +tshow :: Show a => a -> Text +tshow = T.pack . show + +markName :: MarkKind -> Text +markName = T.pack . drop 1 . show -- "MScatter" -> "Scatter" + +-- =========================================================================== +-- 必須 aesthetic (= constructor 定義から導出した事実、 Spec.hs L673-993) +-- =========================================================================== + +-- | mark が描画に最低限要求する aesthetic。 これが欠けると 'validatePlot' が +-- 'MissingAesthetic' を返す。 categorical/numeric の別は型チェックで別途見る。 +requiredAes :: MarkKind -> [Aesthetic] +requiredAes m = case m of + MScatter -> [AesX, AesY] + MLine -> [AesX, AesY] + MBar -> [AesX, AesY] + MStep -> [AesX, AesY] + MStem -> [AesX, AesY] + MPie -> [AesX, AesY] + MWaterfall -> [AesX, AesY] + MTrace -> [AesX, AesY] + MViolin -> [AesX, AesY] + MStrip -> [AesX, AesY] + MSwarm -> [AesX, AesY] + MRaincloud -> [AesX, AesY] + MRidge -> [AesX, AesY] + MEss -> [AesX, AesY] + MHistogram -> [AesX] + MDensity -> [AesX] + MFreqPoly -> [AesX] + MAutocorr -> [AesX] + MBox -> [AesY] + MStatMean -> [AesY] + MStatMedian -> [AesY] + MBand -> [AesX, AesY, AesY2] + MContour -> [AesX, AesY, AesColor] + MContourFilled -> [AesX, AesY, AesColor] + MBin2d -> [AesX, AesY] -- z (AesColor) は任意 (無ければ count = geom_bin2d 既定) + MTile -> [AesX, AesY] -- Phase 60: fill (AesColor) は任意 (colorBy で離散/連続) + MHexbin -> [AesX, AesY] -- Phase 40: count は自動集計 (z 不要) + MHeatmap -> [AesX, AesY, AesColor] + MCount -> [AesX, AesY] + MForest -> [AesX, AesY, AesErrorX] + MFunnel -> [AesX, AesY] + MParallel -> [AesCols] + MDAG -> [AesDAG] + MScatter3D -> [AesX, AesY] + -- Phase 11 A6: geom_text / geom_label (label 列は Aes ではないので x/y のみ) + MText -> [AesX, AesY] + MLabel -> [AesX, AesY] + -- Phase 11 A6-2: geom_qq は sample 列のみ (encY)、 x は理論分位点を内部算出 + MQQ -> [AesY] + -- Phase 11 A6-4: stat_ecdf は sample 列のみ (encX)、 y は #(≤x)/n を内部算出 + MEcdf -> [AesX] + -- Phase 11 A6-4b: 区間 geom は x/y/errorY (= y±err) + MLineRange -> [AesX, AesY, AesErrorY] + MPointRange -> [AesX, AesY, AesErrorY] + MCrossbar -> [AesX, AesY, AesErrorY] + -- 半導体特化 (spec のみ、 render 未): 暫定の最小要求 + MWaferMap -> [AesX, AesY] + MControl -> [AesY] + -- Phase 16: stat-in (= ggplot stat_smooth)。 x/y 必須。 描画前に bridge resolveStats が + -- band/line に展開する (未解決のまま描くと renderer は skip)。 + MStatLM -> [AesX, AesY] + MStatSmooth -> [AesX, AesY] + -- Phase 16 B3: 多項式回帰 / 残差診断。 ともに x/y 必須。 resolveStats が band+line / scatter に展開。 + MStatPoly -> [AesX, AesY] + MStatResid -> [AesX, AesY] + -- Phase 52.D2: streamgraph は x/y/color (= 系列分割) 必須 + MStream -> [AesX, AesY, AesColor] + -- Phase 26 A2: vector field (quiver) は x/y/u/v 必須 + MQuiver -> [AesX, AesY, AesU, AesV] + -- Phase 51: custom mark は必須 aesthetic なし (データは closure/resolver/options 経由)。 + MCustom -> [] + +-- =========================================================================== +-- validate +-- =========================================================================== + +-- | 既知列名なしの検証 (= 列解決の成否のみ、 suggestion 無し)。 +validatePlot :: Resolver -> VisualSpec -> [PlotDiagnostic] +validatePlot = validatePlotWith [] + +-- | 既知列名 (= Resolver が供給できる列の一覧) を渡すと 'ColumnNotFound' に +-- 編集距離 suggestion が付く。 +validatePlotWith :: [Text] -> Resolver -> VisualSpec -> [PlotDiagnostic] +validatePlotWith known r spec = + emptyCheck ++ layerDiags ++ subDiags + where + ls = vsLayers spec + emptyCheck + | null ls && null (vsSubplots spec) = [PlotError EmptyPlot topCtx] + | otherwise = [] + layerDiags = concat (zipWith (validateLayer known r) [0 ..] ls) + -- subplots は独立 spec なので再帰 (layer index は各 sub で 0 始まり) + subDiags = concatMap (validatePlotWith known r) (vsSubplots spec) + +-- | 1 layer の検証: 必須 aesthetic 欠落 + 列解決 + 型チェック。 +validateLayer :: [Text] -> Resolver -> Int -> Layer -> [PlotDiagnostic] +validateLayer known r i ly = + case getFirst (lyKind ly) of + Nothing -> [] -- mark 未指定の attribute-only layer (合成途中) はスキップ + Just mark -> + let ctx = DiagnosticContext (Just i) (Just mark) + present = layerCols ly + missing = + [ PlotError (MissingAesthetic mark a) ctx + | a <- requiredAes mark + , a `notElem` map fst present + , a `notElem` [AesDAG, AesCols] -- DAG/cols は別チェック + ] + dagMiss = + [ PlotError (MissingAesthetic mark AesDAG) ctx + | AesDAG `elem` requiredAes mark + , Nothing <- [getLast (lyDAG ly)] ] + colsMiss = + [ PlotWarning (TooFewColumns AesCols 2 (length (lyHover ly))) ctx + | AesCols `elem` requiredAes mark + , length (lyHover ly) < 2 ] + resolveDiags = concatMap (uncurry (checkCol known r ctx)) present + -- ★ Phase 36 D3 ②: distCols(= 合成が複数の値列)のサブマークは 1D 分布 mark 専用。 + distColsDiags + | length (compositeLanes ly) > 1 = + [ PlotError (DistColsNonDistribution k) (DiagnosticContext (Just i) (Just k)) + | sub <- ly : lyOverlay ly + , Just k <- [getFirst (lyKind sub)] + , k `notElem` [MBox, MViolin, MStrip, MSwarm, MRaincloud] ] + | otherwise = [] + in missing ++ dagMiss ++ colsMiss ++ resolveDiags ++ distColsDiags + +-- | layer に実際に設定済みの (aesthetic, 列) 組を取り出す。 +layerCols :: Layer -> [(Aesthetic, ColRef)] +layerCols ly = mapMaybe pick + [ (AesX, getLast (lyEncX ly)) + , (AesY, getLast (lyEncY ly)) + , (AesY2, getLast (lyEncY2 ly)) + , (AesErrorX, getLast (lyErrorX ly)) + , (AesErrorY, getLast (lyErrorY ly)) + , (AesU, getLast (lyEncU ly)) -- Phase 26 A2: quiver u + , (AesV, getLast (lyEncV ly)) -- Phase 26 A2: quiver v + ] ++ colorCol + where + pick (a, Just c) = Just (a, c) + pick (_, Nothing) = Nothing + colorCol = case getLast (lyColor ly) of + Just (ColorByCol c) -> [(AesColor, c)] + Just (ColorByContinuous c) -> [(AesColor, c)] + _ -> [] + +-- | 列の解決可否 + 型チェック。 数値要求 aesthetic に文字列列が来たら型不一致。 +checkCol :: [Text] -> Resolver -> DiagnosticContext -> Aesthetic -> ColRef -> [PlotDiagnostic] +checkCol known r ctx aes cr = case cr of + ColByName n + | not (isJust (resolveCol r cr)) -> + [PlotError (ColumnNotFound n (suggest known n)) ctx] + | otherwise -> typeCheck n + _ -> typeCheck "" -- inline は常に解決可、 型のみ + where + typeCheck n = case (expectedFor aes, resolveCol r cr) of + (ExpNumeric, Just (TxtData _)) -> + [PlotError (ColumnTypeMismatch n aes ExpNumeric ActCategorical) ctx] + _ -> [] + +-- | aesthetic が数値を要求するか。 x/y は mark により categorical 可なので緩く ExpAny。 +-- color (continuous 経路で来たもの) と error bar は数値必須。 +expectedFor :: Aesthetic -> ExpectedType +expectedFor AesErrorX = ExpNumeric +expectedFor AesErrorY = ExpNumeric +expectedFor AesU = ExpNumeric -- Phase 26 A2: quiver 成分は数値 +expectedFor AesV = ExpNumeric +expectedFor _ = ExpAny + +-- =========================================================================== +-- 編集距離 suggestion (= Levenshtein、 距離 ≤ 3 を近い順に最大 3 件) +-- =========================================================================== + +suggest :: [Text] -> Text -> [Text] +suggest known target = + take 3 . map fst . sortOn snd $ + [ (k, d) | k <- known, let d = levenshtein target k, d <= maxDist ] + where + maxDist = max 2 (T.length target `div` 2) + +-- 標準 Levenshtein (Rosetta Code Haskell 版): 各行を scanl で構築。 +levenshtein :: Text -> Text -> Int +levenshtein a b = last (foldl' transform [0 .. length s1] s2) + where + s1 = T.unpack a + s2 = T.unpack b + transform prev@(p0 : _) c = + scanl calc (p0 + 1) (zip3 s1 prev (tail prev)) + where + calc left (c1, diag, up) = + minimum [up + 1, left + 1, diag + fromEnum (c1 /= c)] + transform [] _ = [] + +-- =========================================================================== +-- compile (= VisualSpec を「検証済」 でラップ) +-- =========================================================================== + +-- | 検証を通過した 'VisualSpec'。 backend はこれを受け取る形に寄せられる +-- (現状は 'compiledSpec' で素の VisualSpec を取り出して既存 backend に渡せる)。 +newtype CompiledPlot = CompiledPlot { compiledSpec :: VisualSpec } + deriving (Show) + +-- | error が無ければ 'CompiledPlot'、 あれば error 一覧を返す +-- (warning は通過させる)。 +compilePlot :: Resolver -> VisualSpec -> Either [PlotDiagnostic] CompiledPlot +compilePlot = compilePlotWith [] + +compilePlotWith :: [Text] -> Resolver -> VisualSpec + -> Either [PlotDiagnostic] CompiledPlot +compilePlotWith known r spec = + case filter ((== SevError) . diagnosticSeverity) (validatePlotWith known r spec) of + [] -> Right (CompiledPlot spec) + errs -> Left errs + +-- =========================================================================== +-- Backend capability matrix (= §5.5) +-- =========================================================================== + +data BackendName = BackendSVG | BackendPNG | BackendPDF | BackendCanvas | BackendWebGL + deriving (Show, Eq) + +backendName :: BackendName -> Text +backendName b = case b of + BackendSVG -> "SVG" + BackendPNG -> "PNG" + BackendPDF -> "PDF" + BackendCanvas -> "Canvas" + BackendWebGL -> "WebGL" + +data FeatureName + = FeatTransparency | FeatHover | FeatInteractive3D | FeatProjected3D + deriving (Show, Eq) + +featureName :: FeatureName -> Text +featureName f = case f of + FeatTransparency -> "透明度 (alpha)" + FeatHover -> "hover tooltip" + FeatInteractive3D -> "interactive 3D" + FeatProjected3D -> "3D (CPU projection)" + +-- | backend ごとの対応機能 (= §5.5)。 +data BackendCapability = BackendCapability + { capName :: BackendName + , capTransparency :: Bool + , capHover :: Bool + , capProjected3D :: Bool + , capInteractive3D :: Bool + } deriving (Show, Eq) + +svgCapability, pngCapability, pdfCapability, canvasCapability, webglCapability + :: BackendCapability +svgCapability = BackendCapability BackendSVG True False True False +pngCapability = BackendCapability BackendPNG True False True False +pdfCapability = BackendCapability BackendPDF True False True False +canvasCapability = BackendCapability BackendCanvas True True True False +webglCapability = BackendCapability BackendWebGL True True True True + +-- | spec が使う機能のうち backend 非対応なものを warning 化。 +checkCapability :: BackendCapability -> VisualSpec -> [PlotDiagnostic] +checkCapability cap spec = concatMap layerCap (vsLayers spec) + ++ concatMap (checkCapability cap) (vsSubplots spec) + where + b = capName cap + layerCap ly = + let ctx = DiagnosticContext Nothing (getFirst (lyKind ly)) + alphaUsed = case getLast (lyAlpha ly) of + Just a -> a < 1.0 + Nothing -> False + hoverUsed = not (null (lyHover ly)) + is3D = getFirst (lyKind ly) == Just MScatter3D + in [ PlotWarning (BackendUnsupported b FeatTransparency) ctx + | alphaUsed, not (capTransparency cap) ] + ++ [ PlotWarning (BackendUnsupported b FeatHover) ctx + | hoverUsed, not (capHover cap) ] + ++ [ PlotWarning (BackendUnsupported b FeatProjected3D) ctx + | is3D, not (capProjected3D cap) ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2674 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Graphics.Hgg.Easy +import Graphics.Hgg.Validate +import Graphics.Hgg.Layout +import Graphics.Hgg.Render +import Graphics.Hgg.Render.Common (pointShapeAt, alphaVector) +import Graphics.Hgg.Primitive (Point (..)) +import Graphics.Hgg.Render.Special (renderDAGStandalone, primsBBoxDAG, dagToScreen) +import Graphics.Hgg.Layout.RangeOf (invNormCdf, qqPoints, ecdfPoints) +import Graphics.Hgg.Layout.Grid (GridCell (..), GridPlacement (..), + flattenSubplots, gridDims, toPTree) +import Graphics.Hgg.Math.Special (logGamma, regIncompleteBeta, betaQuantile) +import qualified Graphics.Hgg.Math.Griddata as Griddata +import qualified Graphics.Hgg.DAG +import Graphics.Hgg.DAG ((~>)) +import qualified Graphics.Hgg.DAG.Internal.Sugiyama as Sugi +import qualified Graphics.Hgg.Render.EdgeRoute as ER +import qualified Data.Map.Strict as Map +import Data.List (sort) +import qualified Data.List +import qualified Data.Text +import Data.Monoid (First (..), Last (..)) +import qualified Data.Vector as V +import Test.Hspec +-- Phase 7 A7: gallery primitive count 回帰 test 用 +import qualified Data.ByteString.Lazy as BL +import Data.Aeson (eitherDecode, encode) +import Graphics.Hgg.Unit (Length (..), LUnit (..), (*~), + mm, inch, px, mmToPt, toPt, lengthToPt, + Pos (..), resolveLen) +import System.Directory (listDirectory, doesDirectoryExist, doesFileExist) +import System.FilePath ((</>), takeExtension) + +main :: IO () +main = hspec $ do + + describe "P2a acyclic (Sugiyama.breakCycles)" $ do + it "acyclic 入力は順序保持で不変 (= 現行図に非破壊)" $ do + let es = [("a","b"),("b","c"),("a","c")] + Sugi.breakCycles ["a","b","c"] es `shouldBe` es + it "back-edge を反転して DAG 化する (a→b→c→a の c→a を反転)" $ do + Sugi.breakCycles ["a","b","c"] [("a","b"),("b","c"),("c","a")] + `shouldBe` [("a","b"),("b","c"),("a","c")] + it "self-loop は rank 制約に寄与しないので除去する" $ do + Sugi.breakCycles ["a","b"] [("a","b"),("a","a"),("b","b")] + `shouldBe` [("a","b")] + it "閉路でも rank が単調になる (従来の 0 仮置きは誤りだった)" $ do + let lg = Sugi.assignRanks (Sugi.buildLayoutGraph ["a","b","c"] + (Sugi.breakCycles ["a","b","c"] [("a","b"),("b","c"),("c","a")])) + rk = Map.fromList [ (Sugi.lnId n, Sugi.lnRank n) | n <- Sugi.lgNodes lg ] + -- a<b<c が保たれる (a=0,b=1,c=2) + (Map.lookup "a" rk, Map.lookup "b" rk, Map.lookup "c" rk) + `shouldBe` (Just 0, Just 1, Just 2) + + describe "Graphics.Hgg.Layout.Grid (Phase 37 A2 統一グリッド平坦化)" $ do + -- 各 leaf を title で識別し、 占有セルを title で引く。 + let leaf nm = title (Data.Text.pack nm) + cellOf nm gp = + case [ c | (s, c) <- gpPanels gp, getLast (vsTitle s) == Just (Data.Text.pack nm) ] of + (c:_) -> c + [] -> error ("panel not found: " ++ nm) + it "leaf 単体は 1x1" $ + gridDims (toPTree (leaf "a")) `shouldBe` (1, 1) + it "a <-> b <-> c は 1 行 3 列・各 1x1" $ do + let gp = flattenSubplots (leaf "a" <-> leaf "b" <-> leaf "c") + (gpCols gp, gpRows gp) `shouldBe` (3, 1) + cellOf "a" gp `shouldBe` GridCell 0 1 0 1 + cellOf "b" gp `shouldBe` GridCell 0 1 1 1 + cellOf "c" gp `shouldBe` GridCell 0 1 2 1 + it "a <:> b <:> c は 3 行 1 列・各 1x1" $ do + let gp = flattenSubplots (leaf "a" <:> leaf "b" <:> leaf "c") + (gpCols gp, gpRows gp) `shouldBe` (1, 3) + cellOf "a" gp `shouldBe` GridCell 0 1 0 1 + cellOf "b" gp `shouldBe` GridCell 1 1 0 1 + cellOf "c" gp `shouldBe` GridCell 2 1 0 1 + it "(a<->b<->c) <:> d は d が下段全幅 (colSpan=3) で左端整列" $ do + let gp = flattenSubplots ((leaf "a" <-> leaf "b" <-> leaf "c") <:> leaf "d") + (gpCols gp, gpRows gp) `shouldBe` (3, 2) + cellOf "a" gp `shouldBe` GridCell 0 1 0 1 + cellOf "c" gp `shouldBe` GridCell 0 1 2 1 + cellOf "d" gp `shouldBe` GridCell 1 1 0 3 -- 上段左 a と下段 d の左端が col0 で一致 + it "(a<:>b) <-> c は c が右列全高 (rowSpan=2)" $ do + let gp = flattenSubplots ((leaf "a" <:> leaf "b") <-> leaf "c") + (gpCols gp, gpRows gp) `shouldBe` (2, 2) + cellOf "a" gp `shouldBe` GridCell 0 1 0 1 + cellOf "b" gp `shouldBe` GridCell 1 1 0 1 + cellOf "c" gp `shouldBe` GridCell 0 2 1 1 + it "Phase 59: a <:> b <-> c (無括弧) は (a<:>b)<->c と同結合 (both infixl 6 = 左結合)" $ do + -- fixity 回帰: 旧 <:>=infixl 5 では a <:> (b<->c) と別構造にパースされ fail する。 + let gp = flattenSubplots (leaf "a" <:> leaf "b" <-> leaf "c") + (gpCols gp, gpRows gp) `shouldBe` (2, 2) + cellOf "a" gp `shouldBe` GridCell 0 1 0 1 + cellOf "b" gp `shouldBe` GridCell 1 1 0 1 + cellOf "c" gp `shouldBe` GridCell 0 2 1 1 + it "(a<->b) <:> (c<->d) は 2x2 グリッド" $ do + let gp = flattenSubplots ((leaf "a" <-> leaf "b") <:> (leaf "c" <-> leaf "d")) + (gpCols gp, gpRows gp) `shouldBe` (2, 2) + cellOf "a" gp `shouldBe` GridCell 0 1 0 1 + cellOf "b" gp `shouldBe` GridCell 0 1 1 1 + cellOf "c" gp `shouldBe` GridCell 1 1 0 1 + cellOf "d" gp `shouldBe` GridCell 1 1 1 1 + it "深いネスト (a<->b<->c)<:>(d<->e) も span 整列" $ do + let gp = flattenSubplots ((leaf "a" <-> leaf "b" <-> leaf "c") <:> (leaf "d" <-> leaf "e")) + (gpCols gp, gpRows gp) `shouldBe` (3, 2) + cellOf "a" gp `shouldBe` GridCell 0 1 0 1 + cellOf "c" gp `shouldBe` GridCell 0 1 2 1 + -- 下段 d<->e は 2 要素を 3 列に詰める (hbox 幅 2 < グループ幅 3)。 + cellOf "d" gp `shouldBe` GridCell 1 1 0 1 + cellOf "e" gp `shouldBe` GridCell 1 1 1 1 + it "subplots 4 枚 + subplotCols 2 は 2x2 wrap grid" $ do + let gp = flattenSubplots (subplots [leaf "a", leaf "b", leaf "c", leaf "d"] + <> subplotCols 2) + (gpCols gp, gpRows gp) `shouldBe` (2, 2) + cellOf "a" gp `shouldBe` GridCell 0 1 0 1 + cellOf "d" gp `shouldBe` GridCell 1 1 1 1 + + describe "Phase 38 凡例 content-based 幅" $ do + it "isWideChar: ASCII は半角・CJK/かな/全角記号は全角" $ do + map isWideChar "Ab1_-" `shouldBe` [False, False, False, False, False] + map isWideChar "あ漢Ａ％" `shouldBe` [True, True, True, True] + it "textWidthEm: 字種別 advance (小文字0.58/全角1.0/細字0.30) を加算" $ do + textWidthEm "ab" `shouldBe` 1.16 -- 0.58 + 0.58 + textWidthEm "あい" `shouldBe` 2.0 -- 1.0 + 1.0 + textWidthEm "a漢" `shouldBe` 1.58 -- 0.58 + 1.0 + textWidthEm "il" `shouldBe` 0.6 -- 0.30 + 0.30 (細字 < 小文字) + textWidthEm "WM" `shouldBe` 1.84 -- 0.92 + 0.92 (幅広 > 小文字) + textWidthEm "" `shouldBe` 0.0 + it "legendGuideWidth: 最長ラベル(幅基準)で colW を駆動" $ do + -- colW = legendKeyW + ggHalfLine/2 + fItem*maxEm + ggHalfLine + let fItem = 8.8; fTitle = 11.0 + w = legendGuideWidth fItem fTitle "" ["aa", "bbbb"] -- 最長 = "bbbb" (em 4*0.58=2.32) + w `shouldBe` legendKeyW + ggHalfLine/2 + fItem * 2.32 + ggHalfLine + it "legendGuideWidth: 全角ラベルは半角同字数より広い" $ do + let f t = legendGuideWidth 8.8 11.0 "" [t] + f "東京" `shouldSatisfy` (> f "ab") -- 全角2 (2.0em) > 半角2 (1.2em) + it "legendGuideWidth: タイトルが最長アイテムより広ければタイトル幅" $ do + -- 短いラベル + 長いタイトル → titleW が勝つ + let w = legendGuideWidth 8.8 11.0 "verylongtitlexxxx" ["a"] + w `shouldBe` 11.0 * textWidthEm "verylongtitlexxxx" + it "legendGuideWidth: ラベル空集合でも key+pad 分の最小幅は確保" $ do + legendGuideWidth 8.8 11.0 "" [] `shouldBe` legendKeyW + ggHalfLine/2 + ggHalfLine + + describe "Graphics.Hgg.Unit (Phase 33 単位系)" $ do + it "(*~) はスカラ倍で単位保存" $ + (7 *~ inch) `shouldBe` Length 7 In + it "lengthToPt: inch は dpi 非依存 (7in = 504pt)" $ + lengthToPt 96 (7 *~ inch) `shouldBe` 504 + it "lengthToPt: mm は mmToPt 係数" $ + abs (lengthToPt 96 (1 *~ mm) - mmToPt) `shouldSatisfy` (< 1e-9) + it "lengthToPt: px は dpi 依存 (800px@96dpi = 600pt)" $ + lengthToPt 96 (800 *~ px) `shouldBe` 600 + it "px 遅延解決: pt→px 戻しで元の px に一致 (dpi 不問)" $ + let n = 800; dpiV = 137 + in abs (lengthToPt dpiV (n *~ px) * (dpiV/72) - n) `shouldSatisfy` (< 1e-9) + it "toPt: 物理単位は Just" $ + toPt (7 *~ inch) `shouldBe` Just 504 + it "toPt: px は Nothing (dpi 必須を型で表現)" $ + toPt (800 *~ px) `shouldBe` Nothing + it "JSON round-trip" $ + eitherDecode (encode (180 *~ mm)) `shouldBe` Right (Length 180 Mm) + it "JSON は {v,u} 順固定・tag 小文字" $ + encode (180 *~ mm) `shouldBe` "{\"v\":180.0,\"u\":\"mm\"}" + + describe "Graphics.Hgg.Unit Pos + resolver (Phase 33 B3)" $ do + -- panel rect: x=10,y=20,w=200,h=100。x scale: data 0..10→pt 10..210、 + -- y scale: data 0..5→pt 120(下)..20(上) の反転 (rY=上端 規約と整合)。 + let ctx = UCtx { uDpi = 96 + , uRect = Rect 10 20 200 100 + , uXScale = LinearScale 0 10 10 210 + , uYScale = LinearScale 0 5 120 20 } + it "resolvePosX PNpc: 0=左端, 1=右端, 0.5=中央" $ do + resolvePosX ctx (PNpc 0) `shouldBe` 10 + resolvePosX ctx (PNpc 1) `shouldBe` 210 + resolvePosX ctx (PNpc 0.5) `shouldBe` 110 + it "resolvePosY PNpc: 1=上端 rY, 0=下端 rY+rH" $ do + resolvePosY ctx (PNpc 1) `shouldBe` 20 + resolvePosY ctx (PNpc 0) `shouldBe` 120 + it "resolvePosX PNative: scaleApply 経由" $ + resolvePosX ctx (PNative 5) `shouldBe` 110 + it "resolvePosY PNative: 反転 scale が処理" $ + resolvePosY ctx (PNative 0) `shouldBe` 120 + it "resolvePosX PAbs: rX + 物理長 pt (1in=72pt)" $ + resolvePosX ctx (PAbs (1 *~ inch)) `shouldBe` 82 + it "resolveLen = lengthToPt" $ + resolveLen 96 (7 *~ inch) `shouldBe` 504 + it "Pos JSON round-trip (abs/npc/native)" $ do + eitherDecode (encode (PNative 3.5)) `shouldBe` Right (PNative 3.5) + eitherDecode (encode (PNpc 0.25)) `shouldBe` Right (PNpc 0.25) + eitherDecode (encode (PAbs (180 *~ mm))) `shouldBe` Right (PAbs (180 *~ mm)) + it "Pos JSON tag 形 (byte 安定・PS とミラー)" $ do + encode (PNpc 0.5) `shouldBe` "{\"t\":\"npc\",\"p\":0.5}" + encode (PNative 3.5) `shouldBe` "{\"t\":\"native\",\"p\":3.5}" + encode (PAbs (180.5 *~ mm)) `shouldBe` "{\"t\":\"abs\",\"l\":{\"v\":180.5,\"u\":\"mm\"}}" + + describe "scalePrimitives (Phase 33 B5・pt→device)" $ do + let rct = PRect (Rect 1 2 10 20) (FillStyle "#000" 1.0) (Just (StrokeStyle "#111" 3)) + cir = PCircle (Point 4 6) 5 (FillStyle "#000" 1.0) Nothing Nothing + txt = PText (Point 2 3) "x" (TextStyle "#000" 11 "sans-serif" AnchorStart 0 "normal" False) + it "k=1 は恒等" $ + scalePrimitives 1 [rct, cir, txt] `shouldBe` [rct, cir, txt] + it "k=2: rect 座標+サイズ+stroke 幅を倍化" $ + scalePrimitives 2 [rct] `shouldBe` + [PRect (Rect 2 4 20 40) (FillStyle "#000" 1.0) (Just (StrokeStyle "#111" 6))] + it "k=2: circle 中心+半径を倍化" $ + scalePrimitives 2 [cir] `shouldBe` + [PCircle (Point 8 12) 10 (FillStyle "#000" 1.0) Nothing Nothing] + it "k=2: text 位置+font size を倍化" $ + scalePrimitives 2 [txt] `shouldBe` + [PText (Point 4 6) "x" (TextStyle "#000" 22 "sans-serif" AnchorStart 0 "normal" False)] + + describe "Annotation Pos API (Phase 33 B6)" $ do + it "annotTextP は Pos をそのまま格納" $ + vsAnnotations (annotTextP (PNpc 0.95) (PNative 3) "R") + `shouldBe` [AnnText (PNpc 0.95) (PNative 3) "R" "" 12] + it "annotRect (旧 x,y,w,h) は 2 隅 PNative に変換" $ + vsAnnotations (annotRect 2 5 1 3 "grey") + `shouldBe` [AnnRect (PNative 2) (PNative 5) (PNative 3) (PNative 8) + "grey" "" 0 0.2] + it "Annotation JSON round-trip (native/npc/abs 混在)" $ do + let a1 = AnnText (PNpc 0.95) (PNative 3) "R" "#000" 12 + a2 = AnnArrow (PNative 1) (PNative 2) (PAbs (5 *~ mm)) (PNpc 0.5) "#444" 1.5 + eitherDecode (encode a1) `shouldBe` Right a1 + eitherDecode (encode a2) `shouldBe` Right a2 + it "PNpc 注釈が panel 相対で解決 (旧 HS の Frac 無視バグ修正)" $ + -- npc(0,1) = panel 左上 = (rX, rY)。旧実装は coord を無視し data 扱いだった。 + let spec = layer (scatter (inline [0.0, 1.0, 2.0]) (inline [0.0, 1.0, 2.0])) + <> annotTextP (PNpc 0) (PNpc 1) "tl" + lay = computeLayout emptyResolver spec + a = lpPlotArea lay + ps = renderToPrimitives emptyResolver lay spec + in [ p | PText p "tl" _ <- ps ] `shouldBe` [Point (rX a) (rY a)] + + describe "ColRef + OverloadedStrings" $ do + it "\"weight\" :: ColRef を ColByName に" $ + ("weight" :: ColRef) `shouldBe` ColByName "weight" + it "inline (Vector Double) → ColNum" $ + case inline (V.fromList [1.0, 2.0, 3.0]) of + ColNum v -> V.length v `shouldBe` 3 + _ -> expectationFailure "wrong tag" + it "inline [Int] → ColNum (auto-promotion)" $ + case inline [1, 2, 3 :: Int] of + ColNum v -> V.toList v `shouldBe` [1.0, 2.0, 3.0] + _ -> expectationFailure "wrong tag" + it "inlineCat [String] → ColTxt" $ + case inlineCat (["a", "b", "c"] :: [String]) of + ColTxt v -> V.length v `shouldBe` 3 + _ -> expectationFailure "wrong tag" + it "resolveNum inline は resolver 不要で解決" $ + resolveNum emptyResolver (inline [10.0, 20.0]) + `shouldBe` Just (V.fromList [10, 20]) + it "resolveNum ColByName は resolver を引く" $ + let r n = if n == "x" then Just (NumData (V.fromList [1, 2])) else Nothing + in resolveNum r "x" `shouldBe` Just (V.fromList [1, 2]) + it "resolveTxt 文字列列を解決" $ + let r n = if n == "g" then Just (TxtData (V.fromList ["a", "b"])) else Nothing + in resolveTxt r "g" `shouldBe` Just (V.fromList ["a", "b"]) + it "resolveTxt は 数値 inline では Nothing" $ + resolveTxt emptyResolver (inline [1.0]) `shouldBe` Nothing + + describe "Layer Monoid" $ do + it "scatter sets kind = MScatter" $ + getFirst (lyKind (scatter "x" "y")) `shouldBe` Just MScatter + it "alpha 2 回 → 後勝ち (Last)" $ + let l = scatter "x" "y" <> alpha 0.5 <> alpha 0.7 + in getLast (lyAlpha l) `shouldBe` Just 0.7 + it "kind は First (= 先勝ち)、 別 kind を <> しても上書きされない" $ + let l = scatter "x" "y" <> line "x" "z" + in getFirst (lyKind l) `shouldBe` Just MScatter + it "mempty <> l == l (Monoid law)" $ + let l = scatter "x" "y" <> alpha 0.5 + in (mempty <> l) `shouldBe` l + it "結合則 (a <> b) <> c == a <> (b <> c)" $ + let a = scatter "x" "y" + b = alpha 0.5 + c = size 6 + in ((a <> b) <> c) `shouldBe` (a <> (b <> c)) + + describe "Phase 30 A7: Point2 inline 形 (3D scatter3DPoints と対称)" $ do + it "scatterPoints == scatter (inline xs) (inline ys)" $ + scatterPoints [Point2 1 2, Point2 3 4] + `shouldBe` scatter (inline [1.0, 3.0]) (inline [2.0, 4.0]) + it "linePoints == line (inline xs) (inline ys)" $ + linePoints [Point2 1 2, Point2 3 4] + `shouldBe` line (inline [1.0, 3.0]) (inline [2.0, 4.0]) + it "scatterPoints の kind = MScatter" $ + getFirst (lyKind (scatterPoints [Point2 0 0])) `shouldBe` Just MScatter + it "Point2 JSON = positional array [x, y] (decode 往復)" $ + (eitherDecode "[1.5,2.5]" :: Either String Point2) `shouldBe` Right (Point2 1.5 2.5) + + describe "Phase 30 A8: alphaBy 連続 alpha encoding (= ggplot scale_alpha)" $ do + it "alphaBy で lyAlphaBy が設定される" $ + getLast (lyAlphaBy (alphaBy "w")) `shouldBe` Just (ColByName "w") + it "alphaVector: 列値 min..max → alpha [0.1, 1.0] に線形 map" $ + let ly = scatter "x" "y" <> alphaBy (inline [0.0, 5.0, 10.0]) + v = alphaVector emptyResolver ly 0.85 3 + in (V.toList v) `shouldBe` [0.1, 0.55, 1.0] + it "alphaVector: lyAlphaBy 無指定なら baseAlpha を全点に" $ + let ly = scatter "x" "y" + v = alphaVector emptyResolver ly 0.85 3 + in (V.toList v) `shouldBe` [0.85, 0.85, 0.85] + it "alphaVector: 定数列 (min==max) は baseAlpha にフォールバック" $ + let ly = scatter "x" "y" <> alphaBy (inline [4.0, 4.0]) + v = alphaVector emptyResolver ly 0.85 2 + in (V.toList v) `shouldBe` [0.85, 0.85] + + describe "colorRGBA: 8 桁 RGBA hex 便利関数 (= color (fromHex …) <> alpha …)" $ do + it "colorRGBA \"#00887766\" == color (fromHex \"#008877\") <> alpha (0x66/255)" $ + colorRGBA "#00887766" + `shouldBe` (color (fromHex "#008877") <> alpha (102/255)) + it "6 桁 (alpha 無し) は alpha=1.0 で不透明" $ + colorRGBA "#008877" `shouldBe` (color (fromHex "#008877") <> alpha 1.0) + it "4 桁省略形 #rgba を展開 (#0876 → #008877 + alpha 0x66/255)" $ + colorRGBA "#0876" `shouldBe` (color (fromHex "#008877") <> alpha (102/255)) + it "fromHexAMaybe: 不正 hex は Nothing" $ + fromHexAMaybe "#zz" `shouldBe` Nothing + it "colorRGBAMaybe: 正しい hex は Just" $ + colorRGBAMaybe "#00887766" `shouldBe` Just (color (fromHex "#008877") <> alpha (102/255)) + + describe "VisualSpec Monoid" $ do + it "purePlot == mempty" $ + purePlot `shouldBe` (mempty :: VisualSpec) + it "title 2 回 → 後勝ち" $ + getLast (vsTitle (title "a" <> title "b")) `shouldBe` Just "b" + it "layer を 2 つ <> すると vsLayers が 2 要素" $ + length (vsLayers (layer (scatter "x" "y") <> layer (line "x" "z"))) + `shouldBe` 2 + it "結合則 (top-level)" $ + let a = layer (scatter "x" "y") + b = title "t" + c = theme ThemeDark + in ((a <> b) <> c) `shouldBe` (a <> (b <> c)) + + describe "Layout" $ do + it "computeLayout default viewport 468x288pt (= 6.5x4in・Phase 33 B8)" $ + let l = computeLayout emptyResolver mempty + in (vsW (lpViewport l), vsH (lpViewport l)) `shouldBe` (468, 288) + it "spec 指定 size は pt 空間で viewport に反映 (px は dpi で pt 化)" $ + -- ★ Phase 33 B4: layout は純 pt。1024px@96dpi = 768pt / 768px = 576pt + -- (backend が k=dpi/72=4/3 を掛けて device px を復元するのは B5)。 + let l = computeLayout emptyResolver (widthUnit (1024 *~ px) <> heightUnit (768 *~ px)) + in (vsW (lpViewport l), vsH (lpViewport l)) `shouldBe` (768, 576) + it "niceTicks 5 0 10 == [0,2..10]" $ + niceTicks 5 0 10 `shouldBe` [0, 2, 4, 6, 8, 10] + -- Phase 8 C (§5 G3): extendedBreaks = R labeling::extended 移植。 + -- 既知の R 出力と照合 (Talbot-Lin-Hanrahan 2010 / ggplot2 既定 breaks)。 + it "G3 extendedBreaks 5 0 10 == [0,2.5,5,7.5,10]" $ + extendedBreaks 5 0 10 `shouldBe` [0, 2.5, 5, 7.5, 10] + it "G3 extendedBreaks 5 0 100 == [0,25,50,75,100]" $ + extendedBreaks 5 0 100 `shouldBe` [0, 25, 50, 75, 100] + it "G3 extendedBreaks 5 0 1 == [0,0.25,0.5,0.75,1]" $ + extendedBreaks 5 0 1 `shouldBe` [0, 0.25, 0.5, 0.75, 1] + it "G3 extendedBreaks 5 1 9 == [0,2.5,5,7.5,10] (censor 前のデータ範囲基準)" $ + extendedBreaks 5 1 9 `shouldBe` [0, 2.5, 5, 7.5, 10] + it "G3 extendedBreaks 退化域 (lo==hi) は単点" $ + extendedBreaks 5 2 2 `shouldBe` [2] + -- Phase 8 C (gtable §E-1): solveTracks = Fixed 先取り → 残りを Null 重み比で配分。 + it "A-gtable solveTracks: Fixed 先取り + 単一 Null に残り" $ + solveTracks 0 100 [Fixed 20, Null 1, Fixed 30] `shouldBe` [(0,20),(20,50),(70,30)] + it "A-gtable solveTracks: Null 重み比 (1:3 = 25:75)" $ + solveTracks 0 100 [Null 1, Null 3] `shouldBe` [(0,25),(25,75)] + it "A-gtable solveTracks: origin offset 反映" $ + solveTracks 10 100 [Fixed 20, Null 1] `shouldBe` [(10,20),(30,80)] + it "A-gtable solveTracks: Fixed 超過なら Null=0 (パネル潰れ)" $ + solveTracks 0 30 [Fixed 20, Fixed 20, Null 1] `shouldBe` [(0,20),(20,20),(40,0)] + -- Phase 8 C G8: insetElement (patchwork 左下原点) = insetAt (左上原点) への変換。 + -- (left,bottom,right,top)=(0.5,0.5,1,1) 右上 → insetAt(x=0.5,y=0,w=0.5,h=0.5)。 + it "G8 insetElement (0.5,0.5,1,1) == insetAt (0.5,0,0.5,0.5)" $ + insetElement 0.5 0.5 1.0 1.0 mempty `shouldBe` insetAt 0.5 0.0 0.5 0.5 mempty + it "scaleApply Linear 0..1 → 100..200 中点 150" $ + scaleApply (LinearScale 0 1 100 200) 0.5 `shouldBe` 150 + it "Phase 26 §C-2 #1: scaleApply Log 1..1000 → 0..300 中点 (=10) は ≈100" $ + abs (scaleApply (LogScale 1 1000 0 300) 10 - 100.0) `shouldSatisfy` (< 1e-9) + it "Phase 26 §C-2 #1: niceTicksLog 5 1 10000 = [1,10,100,1000,10000]" $ + niceTicksLog 5 1 10000 `shouldBe` [1, 10, 100, 1000, 10000] + it "Phase 26 §C-2 #1: xAxis logAxis を spec に与えると LogScale が出る" $ + let spec = layer (scatter (inline [1.0, 10.0, 100.0]) (inline [1.0, 4.0, 9.0])) + <> xAxis logAxis + in case lpXScale (computeLayout emptyResolver spec) of + LogScale{} -> True `shouldBe` True + LinearScale{} -> expectationFailure "expected LogScale" + + it "Phase 26 §E-1: traceLines (multi-chain) で chain ごとに線が分離 (= PLine 多数)" $ + let r n = case n of + "iter" -> Just (NumData (V.fromList [0, 1, 2, 0, 1, 2])) + "value" -> Just (NumData (V.fromList [0.1, 0.2, 0.5, 0.0, 0.4, 0.6])) + "chain" -> Just (TxtData (V.fromList ["1", "1", "1", "2", "2", "2"])) + _ -> Nothing + spec = layer (traceLines "iter" "value" "chain") + ps = renderToPrimitives r (computeLayout r spec) spec + lines_ = length [() | PLine{} <- ps] + in lines_ `shouldSatisfy` (>= 4) -- 2 chain × 2 segment 以上 + + it "Phase 26 §E-6: dag で 3 node 2 edge の primitive 全体数 > 5 (= node shape + arrow + label)" $ + let nodes = [ dagNode "a" "alpha" NodeLatent 0.0 0.0 + , dagNode "b" "beta" NodeLatent 1.0 0.0 + , dagNode "c" "y" NodeObserved 0.5 1.0 + ] + edges_ = [ dagEdge "a" "c" + , dagEdge "b" "c" + ] + spec = layer (dag nodes edges_) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + in length ps `shouldSatisfy` (> 5) + + it "Phase 26 §E-6: dagPlot (Graph builder + ~>) で arrow PPath 含む" $ + let g = ("alpha" :: Data.Text.Text) ~> "y" <> "beta" ~> "y" + spec = layer (Graphics.Hgg.DAG.dagPlot g) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + paths = length [() | PPath{} <- ps] + in paths `shouldSatisfy` (>= 2) -- arrow head + node 楕円 で複数 + + it "Phase 26 A2: quiver は零でない矢印 1 本につき 3 PLine (本線 + 矢じり 2)" $ + -- 軸/格子線も PLine なので、 同じ x/y で全零ベクトル版との差分 = 矢印分だけ。 + -- 非零 2 本 (2 本目は零ベクトルで非描画) → 差分 = 2 × 3 = 6。 + -- ★ Phase 36 A: 矢印は元レンジのまま plotArea でクリップ (range 非拡張・clip は + -- primitive 数不変) なので、 両版の軸/格子線は一致し差分 = 矢印分だけ。 + let xs = inline [0.0, 1.0, 2.0]; ys = inline [0.0, 0.0, 0.0] + mkLines us vs = + let spec = layer (quiver xs ys us vs) + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver spec) spec + in length [() | PLine{} <- ps] + withArrows = mkLines (inline [1.0, 0.0, 1.0]) (inline [0.0, 0.0, 1.0]) + noArrows = mkLines (inline [0.0, 0.0, 0.0]) (inline [0.0, 0.0, 0.0]) + in (withArrows - noArrows) `shouldBe` 6 + + it "Phase 26 A2: quiver requiredAes = x/y/u/v・layerCols で 4 列解決" $ do + let ly = quiver (inline [0.0]) (inline [0.0]) (inline [1.0]) (inline [1.0]) + requiredAes MQuiver `shouldBe` [AesX, AesY, AesU, AesV] + length (layerCols ly) `shouldBe` 4 + + it "Phase 26 §C-2 #13: parallelCoords 3 列 で N+1 軸線 (= 3 軸) が出る" $ + let spec = layer (parallelCoords [ inline [1.0, 2.0, 3.0] + , inline [4.0, 5.0, 6.0] + , inline [7.0, 8.0, 9.0] ]) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + -- 縦軸 3 本以上 (= 軸 + 各 row の polyline) + lines_ = length [() | PLine{} <- ps] + in lines_ `shouldSatisfy` (>= 3) + + it "Phase 26 §C-2 #10: marginal で X/Y histogram の PRect が追加される" $ + let baseSpec = layer (scatter (inline [0.0, 1.0, 2.0, 3.0, 4.0]) + (inline [0.0, 1.0, 4.0, 9.0, 16.0])) + extSpec = baseSpec <> marginal + n0 = length [() | PRect{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver baseSpec) baseSpec] + n1 = length [() | PRect{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver extSpec) extSpec] + in (n1 - n0) `shouldSatisfy` (>= 20) -- 20 bins × 2 軸 minimum + + it "Phase 26 §C-2 #12: facet 3 値 で panel が 3 つ出る (= 各 panel の header PText)" $ + let r n = case n of + "x" -> Just (NumData (V.fromList [1, 2, 3, 1, 2, 3, 1, 2, 3])) + "y" -> Just (NumData (V.fromList [1, 4, 9, 1, 4, 9, 1, 4, 9])) + "g" -> Just (TxtData (V.fromList ["A", "A", "A", "B", "B", "B", "C", "C", "C"])) + _ -> Nothing + spec = layer (scatter "x" "y") <> facet "g" + ps = renderToPrimitives r (computeLayout r spec) spec + texts = [t | PText _ t _ <- ps] + in do + ("A" `elem` texts) `shouldBe` True + ("B" `elem` texts) `shouldBe` True + ("C" `elem` texts) `shouldBe` True + + it "Phase 26 §C-2 #8: statMean が水平 PLine を 1 本生成 (= renderStatLine 直接 check)" $ + let r n = case n of + "y" -> Just (NumData (V.fromList [0, 1, 4, 9, 16])) + _ -> Nothing + spec = layer (statMean "y") + ps = renderToPrimitives r (computeLayout r spec) spec + -- 軸 tick の PLine も含まれるが、 lyKind = MStatMean の layer は 1 本だけ生成 + -- 確認用: PLine の中で plot area 幅の水平線 = stat line + a = lpPlotArea (computeLayout r spec) + isHorizFull (PLine (Point x1 _) (Point x2 _) _) = + abs (x1 - rX a) < 0.01 && abs (x2 - (rX a + rW a)) < 0.01 + isHorizFull _ = False + fullHoriz = filter isHorizFull ps + in length fullHoriz `shouldSatisfy` (>= 1) + it "Phase 26 §C-2 #15: MScatter3D を含めても render は通る (= placeholder)" $ + let spec = layer (mempty { lyKind = pure MScatter3D }) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + in length [() | PCircle{} <- ps] `shouldBe` 0 -- 3D は描画しない + + it "Phase 60: tile が連続軸で 4 セルを隙間なくベタ塗り + カテゴリ 2 色 (離散 colorBy)" $ + -- 2×2 の決定グリッド (x∈{0,1}, y∈{0,1}, class A/B) を tile で塗る。 + let r n = case n of + "x" -> Just (NumData (V.fromList [0, 1, 0, 1])) + "y" -> Just (NumData (V.fromList [0, 0, 1, 1])) + "c" -> Just (TxtData (V.fromList ["A", "A", "B", "B"])) + _ -> Nothing + spec = layer (tile "x" "y" "c") + ps = renderToPrimitives r (computeLayout r spec) spec + -- tile セル = 枠なし PRect・非白・大 (背景や凡例 chip を幅で除外) + cells = [ (x, y, w, col) + | PRect (Rect x y w _) (FillStyle col _) Nothing <- ps + , col /= "#ffffff", w > 100 ] + colors = Data.List.nub [ c | (_, _, _, c) <- cells ] + rows = Data.List.groupBy (\(_,y1,_,_) (_,y2,_,_) -> abs (y1 - y2) < 0.01) + (Data.List.sortOn (\(_,y,_,_) -> y) cells) + -- 同一 row の隣接 2 セル: 左の右端 == 右の左端 (隙間なし) + gapFree row = case Data.List.sortOn (\(x,_,_,_) -> x) row of + ((x1,_,w1,_) : (x2,_,_,_) : _) -> abs ((x1 + w1) - x2) < 0.01 + _ -> False + in do + length cells `shouldBe` 4 -- 2×2 = 4 セル + length colors `shouldBe` 2 -- カテゴリ A/B → 離散 2 色 + all gapFree rows `shouldBe` True -- 隙間なし (格子間隔で敷き詰め) + + it "Phase 26 §C-2 #6: errorY で各点 3 本 (vertical + 2 cap) 追加、 3 点 = 9 本" $ + let r n = case n of + "x" -> Just (NumData (V.fromList [0, 1, 2])) + "y" -> Just (NumData (V.fromList [0, 1, 4])) + "ey" -> Just (NumData (V.fromList [0.5, 0.3, 0.8])) + _ -> Nothing + baseSpec = layer (scatter "x" "y") + errSpec = layer (scatter "x" "y" <> errorY "ey") + n0 = length [() | PLine{} <- renderToPrimitives r + (computeLayout r baseSpec) baseSpec] + n1 = length [() | PLine{} <- renderToPrimitives r + (computeLayout r errSpec) errSpec] + in (n1 - n0) `shouldBe` 9 + + it "Phase 26 §C-2 #5: scatter + connect で PLine が n-1 本追加" $ + let baseSpec = layer (scatter (inline [0.0, 1.0, 2.0, 3.0]) + (inline [0.0, 1.0, 4.0, 9.0])) + withCSpec = layer (scatter (inline [0.0, 1.0, 2.0, 3.0]) + (inline [0.0, 1.0, 4.0, 9.0]) + <> connect) + n0 = length [() | PLine{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver baseSpec) baseSpec] + n1 = length [() | PLine{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver withCSpec) withCSpec] + in (n1 - n0) `shouldBe` 3 + + it "Phase 26 §C-2 #4: hoverCols で PCircle の title が col 値を含む" $ + let r n = case n of + "x" -> Just (NumData (V.fromList [0, 1, 2])) + "y" -> Just (NumData (V.fromList [0, 1, 4])) + "g" -> Just (NumData (V.fromList [10, 20, 30])) + _ -> Nothing + spec = layer (scatter "x" "y" <> hoverCols ["g"]) + ps = renderToPrimitives r (computeLayout r spec) spec + labels = [t | PCircle _ _ _ _ (Just t) <- ps] + in any (Data.Text.isInfixOf "g: 10") labels `shouldBe` True + + it "Phase 26 §C-2 #3: refIdentity を付けると y=x の PLine が 1 本 追加" $ + let baseSpec = layer (scatter (inline [0.0, 1.0, 2.0]) (inline [0.0, 1.0, 4.0])) + plain = renderToPrimitives emptyResolver + (computeLayout emptyResolver baseSpec) baseSpec + withRef = renderToPrimitives emptyResolver + (computeLayout emptyResolver (baseSpec <> refIdentity)) + (baseSpec <> refIdentity) + n1 = length [() | PLine{} <- plain] + n2 = length [() | PLine{} <- withRef] + in (n2 - n1) `shouldBe` 1 + it "Phase 26 §C-2 #3: refHorizontal 3 + refVertical 1 で計 +2 PLine" $ + let baseSpec = layer (scatter (inline [0.0, 1.0, 2.0]) (inline [0.0, 1.0, 4.0])) + extSpec = baseSpec <> refHorizontal 3 <> refVertical 1 + n1 = length [() | PLine{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver baseSpec) baseSpec] + n2 = length [() | PLine{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver extSpec) extSpec] + in (n2 - n1) `shouldBe` 2 + + it "Phase 26 §C-2 #2: AxisDecimalFmt 2 が tick 表示に反映 ('1.50' 等)" $ + let spec = layer (scatter (inline [0.0, 1.0, 2.0]) (inline [0.0, 1.0, 4.0])) + <> yAxis (axisFormat (AxisDecimalFmt 2)) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + texts = [t | PText _ t _ <- ps] + hasDot2 t = case Data.Text.breakOn "." t of + (_, suffix) | Data.Text.length suffix == 3 -> True + _ -> False + decimal2 = filter hasDot2 texts + in length decimal2 `shouldSatisfy` (>= 1) + + describe "Render" $ do + it "scatter 3 点で PCircle 3 個" $ + let spec = layer (scatter (inline [0, 1, 2 :: Double]) + (inline [0, 1, 4 :: Double])) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + in length [() | PCircle{} <- ps] `shouldBe` 3 + it "line 4 点で PLine 3 本 (= n-1 本)" $ + let spec = layer (line (inline [0, 1, 2, 3 :: Double]) + (inline [0, 1, 4, 9 :: Double])) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + -- axisFrame + tickMarks にも PLine が混ざるので line layer 由来だけ + -- 抽出するのは難しい。 ここでは全体の PLine 数だけ check (= 軸 tick + -- 6 個 + line 3 本 + xMark/yMark 各 12 本程度 = それなりの数) + nLines = length [() | PLine{} <- ps] + in nLines `shouldSatisfy` (>= 3) + it "ColByName で resolver から解決して描画" $ + let r n = case n of + "x" -> Just (NumData (V.fromList [0, 1, 2])) + "y" -> Just (NumData (V.fromList [0, 1, 4])) + _ -> Nothing + spec = layer (scatter "x" "y") + ps = renderToPrimitives r (computeLayout r spec) spec + in length [() | PCircle{} <- ps] `shouldBe` 3 + it "boxplot は PRect (箱) + PLine (median/髭) の組合せを出す" $ + let spec = layer (boxplot (inline [1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 100.0])) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + nRects = length [() | PRect{} <- ps] + in nRects `shouldSatisfy` (>= 2) -- axis frame + box の最低 2 個 + + it "density は PPath を 1 つ出す" $ + let spec = layer (density (inline [1.0, 2.0, 2.5, 3.0, 3.5, 4.0, 5.0])) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + in length [() | PPath{} <- ps] `shouldBe` 1 + + -- Phase 52.B1: subplots の入れ子が再帰描画される (renderSingle → renderToPrimitives、 + -- PS Render/Layer.purs:442 と同一方式)。 外側 subplots が内側 subplots を含むとき、 + -- 内側 panel の scatter 点まで描かれることを確認 (修正前は内側が無視され 3 点のみ)。 + it "B1 入れ子 subplots: 内側 scatter の点まで全部描画される" $ + let pts = layer (scatter (inline [0, 1, 2 :: Double]) + (inline [0, 1, 4 :: Double])) + inner = subplots [pts, pts] <> subplotCols 2 -- 内側: 2 panel × 3 点 = 6 + outer = subplots [inner, pts] <> subplotCols 1 -- 外側: 入れ子 + 単独 3 点 + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver outer) outer + in length [() | PCircle{} <- ps] `shouldBe` 9 -- 6 (入れ子) + 3 (単独) + + -- Phase 52.D (concat 合成): hconcat/vconcat ラッパ + 演算子 <-> (横) / <:> (縦)。 + -- subplots+subplotCols の薄ラッパで render/parity 影響なし。 演算子は同方向チェーンを + -- 平坦化する (a <-> b <-> c = 3 等分列、 二項ネストにしない)。 + it "concat: hconcat [a,b,c] = subplots 3 要素 + subplotCols 3" $ + let s = hconcat [purePlot, purePlot, purePlot] + in (length (vsSubplots s), getLast (vsSubplotCols s)) `shouldBe` (3, Just 3) + + it "concat: vconcat [a,b] = subplots 2 要素 + subplotCols 1" $ + let s = vconcat [purePlot, purePlot] + in (length (vsSubplots s), getLast (vsSubplotCols s)) `shouldBe` (2, Just 1) + + it "concat: a <-> b <-> c は 3 要素に平坦化 (二項ネストでなく 3 等分列)" $ + let s = purePlot <-> purePlot <-> purePlot + in (length (vsSubplots s), getLast (vsSubplotCols s)) `shouldBe` (3, Just 3) + + it "concat: <:> は横グループを単位として扱う (外側 cols 1・2 要素)" $ + let s = (purePlot <-> purePlot <-> purePlot) <:> purePlot + in (length (vsSubplots s), getLast (vsSubplotCols s)) `shouldBe` (2, Just 1) + + it "concat: (a <-> b <-> c) <:> d == vconcat [hconcat [a,b,c], d] (同一 spec 構造)" $ + let a = purePlot + shape s = ( getLast (vsSubplotCols s), length (vsSubplots s) + , [ (getLast (vsSubplotCols x), length (vsSubplots x)) | x <- vsSubplots s ] ) + opForm = (a <-> a <-> a) <:> a + listForm = vconcat [hconcat [a, a, a], a] + in shape opForm `shouldBe` shape listForm + + it "concat: (a <-> b <-> c) <:> d を実描画すると 1 行目 3 列 + 2 行目で全パネル描画" $ + let a = layer (scatter (inline [0, 1, 2 :: Double]) (inline [0, 1, 4 :: Double])) + spec = (a <-> a <-> a) <:> a + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver spec) spec + in length [() | PCircle{} <- ps] `shouldBe` 12 -- 4 パネル × 3 点 + + -- Phase 18 A1: selectPanels (= subplot panel の名前選択 + 列挙順並べ替え)。 + -- panel 名 = 子 spec の vsTitle。 ggplot discrete limits と同じ「選択 + 順序」。 + let selPts = layer (scatter (inline [0, 1, 2 :: Double]) (inline [0, 1, 4 :: Double])) + selPanel nm = selPts <> title nm + selGrid = subplots [selPanel "a", selPanel "b", selPanel "c"] + it "P18 selectPanels: 名前で選択し列挙順に並べ替える" $ + let s = selGrid <> selectPanels ["c", "a"] + in map (getLast . vsTitle) (selectedSubplots s) + `shouldBe` [Just "c", Just "a"] + + it "P18 selectPanels: 不一致名は無視 (存在する名前だけ残る)" $ + let s = selGrid <> selectPanels ["zzz", "b"] + in map (getLast . vsTitle) (selectedSubplots s) `shouldBe` [Just "b"] + + it "P18 selectPanels: 未指定なら全 panel をそのまま返す (従来不変)" $ + map (getLast . vsTitle) (selectedSubplots selGrid) + `shouldBe` [Just "a", Just "b", Just "c"] + + it "P18 selectPanels: title 無し panel は選択時に落ちる" $ + let s = subplots [selPts, selPanel "a"] <> selectPanels ["a"] + in length (selectedSubplots s) `shouldBe` 1 + + it "P18 selectPanels: 実描画で選択 panel の点だけ描かれる" $ + let s = selGrid <> selectPanels ["a", "c"] <> subplotCols 2 + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver s) s + in length [() | PCircle{} <- ps] `shouldBe` 6 -- 2 パネル × 3 点 + + -- Phase 18 A2: scale{X,Y}DiscreteLimits (= ggplot scale_*_discrete(limits=))。 + -- ColTxt encoding の layer のカテゴリ行を選択 + 列挙順に並べ替え (全 encoding 整合)。 + it "P18 discrete limits (Y): forest の行を選択 + 列挙順に並べ替え (encX/errorX も追従)" $ + let s = layer (forest (inlineCat ["a", "b", "c" :: Data.Text.Text]) + (inline [1, 2, 3 :: Double]) + (inline [0.1, 0.2, 0.3 :: Double])) + <> scaleYDiscreteLimits ["c", "a"] + l = head (vsLayers (applyDiscreteLimits emptyResolver s)) + cat = case getLast (lyEncY l) of Just (ColTxt v) -> V.toList v; _ -> [] + est = case getLast (lyEncX l) of Just (ColNum v) -> V.toList v; _ -> [] + err = case getLast (lyErrorX l) of Just (ColNum v) -> V.toList v; _ -> [] + in (cat, est, err) `shouldBe` (["c", "a"], [3, 1], [0.3, 0.1]) + + it "P18 discrete limits (X): bar の実描画で選択カテゴリの本数だけ PRect が出る" $ + let mk lim = let s = layer (bar (inlineCat ["p", "q", "r" :: Data.Text.Text]) + (inline [1, 2, 3 :: Double])) <> lim + in length [ () | PRect{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver s) s ] + in (mk (scaleXDiscreteLimits ["r", "p"]), mk mempty) + `shouldBe` (mk mempty - 1, mk mempty) -- bar 3→2 本 (他 PRect は不変) + + it "P18 discrete limits: coord_flip と直交 (flip 後も aes 基準で効く)" $ + let mk lim = let s = layer (bar (inlineCat ["p", "q", "r" :: Data.Text.Text]) + (inline [1, 2, 3 :: Double])) + <> coordFlip <> lim + in length [ () | PRect{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver s) s ] + in mk (scaleXDiscreteLimits ["p"]) `shouldBe` mk mempty - 2 -- 3→1 本 + + it "P18 discrete limits: ColByName 列も resolver 経由 (bake) で filter される" $ + let res n = case n of + "g" -> Just (TxtData (V.fromList ["p", "q", "r"])) + "v" -> Just (NumData (V.fromList [1, 2, 3])) + _ -> Nothing + s = layer (bar (ColByName "g") (ColByName "v")) + <> scaleXDiscreteLimits ["q"] + l = head (vsLayers (applyDiscreteLimits res s)) + cat = case getLast (lyEncX l) of Just (ColTxt v) -> V.toList v; _ -> [] + in cat `shouldBe` ["q"] + + -- Phase 52.D2: streamgraph (= 中心化積層 area)。 color aes で系列分割し、 各系列を + -- 塗り polygon (PPath) で描く。 baseline は -(Σy)/2 から (silhouette 中心化)。 + let streamR n = case n of + "t" -> Just (NumData (V.fromList [0,1,2, 0,1,2 :: Double])) + "v" -> Just (NumData (V.fromList [1,2,3, 2,2,1 :: Double])) + "g" -> Just (TxtData (V.fromList ["a","a","a","b","b","b"])) + _ -> Nothing + it "D2 stream: 2 系列で PPath を 2 枚 (= 系列数ぶん) 出す" $ + let spec = layer (stream "t" "v" <> colorBy "g") + ps = renderToPrimitives streamR (computeLayout streamR spec) spec + in length [() | PPath{} <- ps] `shouldBe` 2 + + it "D2 stream: 1 系列なら PPath 1 枚" $ + let r1 n = case n of + "t" -> Just (NumData (V.fromList [0,1,2 :: Double])) + "v" -> Just (NumData (V.fromList [1,2,3 :: Double])) + "g" -> Just (TxtData (V.fromList ["a","a","a"])) + _ -> Nothing + spec = layer (stream "t" "v" <> colorBy "g") + ps = renderToPrimitives r1 (computeLayout r1 spec) spec + in length [() | PPath{} <- ps] `shouldBe` 1 + + it "D2 stream: 中心化積層で y domain が負側に広がる (baseline=-Σy/2)" $ + let spec = layer (stream "t" "v" <> colorBy "g") + layout = computeLayout streamR spec + -- 各 x 総和 max M=4 (x=1,2 で 2+2 / 3+1) → range [-2,2] を含む (pad で更に外側) + in lsDomainLo (lpYScale layout) `shouldSatisfy` (< 0) + + -- Phase 52.D1: repeatFields = フィールド名を反復し 1 view/フィールドを生成して + -- subplots に並べる (Vega-Lite repeat 相当)。 3 フィールド × 3 点 scatter = 9 circle。 + it "D1 repeatFields: フィールド数ぶんの panel が subplots に展開される" $ + let mk _f = layer (scatter (inline [0, 1, 2 :: Double]) + (inline [0, 1, 4 :: Double])) + spec = repeatFields (["a", "b", "c"] :: [Data.Text.Text]) mk + <> subplotCols 3 + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + in length [() | PCircle{} <- ps] `shouldBe` 9 + + -- Phase 52.A11: DAG (MDAG・renderDAGOnly 経路) を subplot セル内に置くと、 修正前は + -- area を viewport (subplot では 0 に潰れる) から絶対原点 (40,50) で作っていたため、 + -- DAG が自セルを無視し図全体の左上に漏れていた。 修正後は viewport=0 を subplot 文脈と + -- 見て base 矩形を lpPlotArea (panelRect) に切替えるため各セルに収まる。 2 列に DAG を + -- 並べ、 ノードラベル (PText) が左半分・右半分の両方に出ることを確認 (修正前は全て左上)。 + it "A11 subplot 内 DAG: 各セルに収まる (左右両半分にノードが出る)" $ + let dagSpec = layer (Graphics.Hgg.DAG.dagPlot + (("a" :: Data.Text.Text) ~> "b")) + spec = subplots [dagSpec, dagSpec] <> subplotCols 2 -- 横 2 セル + lay = computeLayout emptyResolver spec + -- 図中点 (= viewport 幅の半分)。既定サイズ非依存に左右セルを判定する。 + midX = fromIntegral (vsW (lpViewport lay)) / 2 + ps = renderToPrimitives emptyResolver lay spec + textXs = [ x | PText (Point x _) _ _ <- ps ] + in (any (> midX) textXs, any (< midX) textXs) `shouldBe` (True, True) + + -- Phase 8 C G7: facet_wrap 複数行 (5 群 ncol=3 → 2 行)。 全点が各 panel に描かれ、 + -- panel frame が 5 枚 + background で PRect >= 6 (= 折り返しても panel が潰れない)。 + it "G7 facetWrap 5 群 ncol=3: 全 20 点描画 + panel frame 5 枚" $ + let r n = case n of + "x" -> Just (NumData (V.fromList (concat (replicate 5 [1,2,3,4])))) + "y" -> Just (NumData (V.fromList + [1,4,9,16,2,5,8,12,3,6,9,15,2,3,7,10,4,8,11,14])) + "g" -> Just (TxtData (V.fromList + (concatMap (replicate 4) ["A","B","C","D","E"]))) + _ -> Nothing + spec = layer (scatter "x" "y" <> size 6) <> facetWrap "g" 3 + ps = renderToPrimitives r (computeLayout r spec) spec + nCircles = length [() | PCircle{} <- ps] + nRects = length [() | PRect{} <- ps] + in (nCircles, nRects >= 6) `shouldBe` (20, True) + + it "ColorByCol で categorical 3 値 → 3 色の Okabe-Ito palette" $ + let r n = case n of + "x" -> Just (NumData (V.fromList [0, 1, 2, 3, 4, 5])) + "y" -> Just (NumData (V.fromList [0, 1, 4, 9, 16, 25])) + "g" -> Just (TxtData (V.fromList ["a", "b", "c", "a", "b", "c"])) + _ -> Nothing + spec = layer (scatter "x" "y" <> colorBy "g") + ps = renderToPrimitives r (computeLayout r spec) spec + colors = [c | PCircle _ _ (FillStyle c _) _ _ <- ps] + in length (Data.List.nub colors) `shouldBe` 3 + + describe "Phase 1 A2: Sugiyama rank assignment (= network simplex framework)" $ do + it "linear chain a→b→c は rank 0,1,2" $ + let lg = Sugi.assignRanks + (Sugi.buildLayoutGraph ["a", "b", "c"] + [("a", "b"), ("b", "c")]) + rankOf x = head [ Sugi.lnRank n | n <- Sugi.lgNodes lg, Sugi.lnId n == x ] + in (rankOf "a", rankOf "b", rankOf "c") `shouldBe` (0, 1, 2) + + it "diamond a→b, a→c, b→d, c→d は a=0, b=c=1, d=2" $ + let lg = Sugi.assignRanks + (Sugi.buildLayoutGraph ["a", "b", "c", "d"] + [("a","b"),("a","c"),("b","d"),("c","d")]) + rankOf x = head [ Sugi.lnRank n | n <- Sugi.lgNodes lg, Sugi.lnId n == x ] + in [rankOf "a", rankOf "b", rankOf "c", rankOf "d"] `shouldBe` [0, 1, 1, 2] + + it "孤立 node は rank 0" $ + let lg = Sugi.assignRanks (Sugi.buildLayoutGraph ["x"] []) + in map Sugi.lnRank (Sugi.lgNodes lg) `shouldBe` [0] + + it "結果は常に feasible (= rank(v) - rank(u) ≥ δ)" $ + let lg = Sugi.assignRanks + (Sugi.buildLayoutGraph ["a","b","c","d","e"] + [("a","b"),("a","c"),("b","d"),("c","d"),("d","e"),("a","e")]) + in Sugi.isFeasible lg `shouldBe` True + + describe "Step3.1: 汎用 network simplex (networkSimplex, P4a x 座標ソルバ)" $ do + let feasibleAll es r = all (\(t, h, d, _) -> + Map.findWithDefault 0 h r - Map.findWithDefault 0 t r >= d) es + obj es r = sum [ w * fromIntegral (Map.findWithDefault 0 h r - Map.findWithDefault 0 t r) + | (t, h, _, w) <- es ] :: Double + + it "一様 δ=ω=1 diamond は longest-path と一致 (a0 b1 c1 d2)" $ + let es = [("a","b",1,1),("a","c",1,1),("b","d",1,1),("c","d",1,1)] + r = Sugi.networkSimplex ["a","b","c","d"] es + in (Map.findWithDefault (-1) "a" r, Map.findWithDefault (-1) "b" r, + Map.findWithDefault (-1) "c" r, Map.findWithDefault (-1) "d" r) + `shouldBe` (0, 1, 1, 2) + + it "longest-path が非最適な異δ案件で最適目的値に到達 (a→c δ1, b→c δ5 → obj 6)" $ + let es = [("a","c",1,1),("b","c",5,1)] + r = Sugi.networkSimplex ["a","b","c"] es + in (feasibleAll es r, obj es r) `shouldBe` (True, 6) + + it "Ω 重み (1:8) で重い chain を直線化 (t0 m1 b2)" $ + let es = [("t","m",1,8),("m","b",1,8),("t","b",2,1)] + r = Sugi.networkSimplex ["t","m","b"] es + in (Map.findWithDefault (-1) "t" r, Map.findWithDefault (-1) "m" r, + Map.findWithDefault (-1) "b" r, feasibleAll es r) + `shouldBe` (0, 1, 2, True) + + it "孤立 node は 0" $ + Sugi.networkSimplex ["x","y"] [] `shouldBe` Map.fromList [("x",0),("y",0)] + + it "非連結成分は独立に解け各成分の最小が 0" $ + let es = [("a","b",1,1),("c","d",3,1)] + r = Sugi.networkSimplex ["a","b","c","d"] es + in (feasibleAll es r, + Map.findWithDefault (-1) "a" r, Map.findWithDefault (-1) "b" r, + Map.findWithDefault (-1) "c" r, Map.findWithDefault (-1) "d" r) + `shouldBe` (True, 0, 1, 0, 3) + + describe "Step3.2: aux-graph x 座標 (P4a, dummy 直線化 + chain body 外分離)" $ do + -- 長 edge (= 自 chain と並走する skip) の dummy 列が、 chain node の body の + -- 外へ出て、 かつ Ω=8 直線化で collinear (= 同 x) になることを assignCoords 経由で検証。 + -- これが P4a の核心 (= large funnel collapse の layout 層 主因の根治)。 + it "並走 skip の dummy は collinear (= 同 x、 |Δx| < 1e-9)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph + ["a0","a1","a2","a3","a4"] + [("a0","a1"),("a1","a2"),("a2","a3"),("a3","a4") -- chain + ,("a0","a4")] -- 並走 skip (dummy 3 個) + (g1, om) = Sugi.assignOrder g0 + coords = Sugi.assignCoords [] g1 om + dumXs = [ x | (k, x) <- Map.toList coords, Data.Text.isPrefixOf "__dummy_" k ] + in case dumXs of + [] -> expectationFailure "dummy が無い (skip が dummy 化されていない)" + _ -> maximum dumXs - minimum dumXs `shouldSatisfy` (< 1e-9) + + it "並走 skip の dummy 列は chain node 列から分離 (= 同 x でない)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph + ["a0","a1","a2","a3","a4"] + [("a0","a1"),("a1","a2"),("a2","a3"),("a3","a4"),("a0","a4")] + (g1, om) = Sugi.assignOrder g0 + coords = Sugi.assignCoords [] g1 om + dumX = head [ x | (k, x) <- Map.toList coords, Data.Text.isPrefixOf "__dummy_" k ] + chainX = Map.findWithDefault (-1) "a1" coords -- 中間 chain node + in abs (dumX - chainX) `shouldSatisfy` (> 1e-6) + + -- Phase 39 Step8 (P8) A1: cluster border 制約 (graphviz pos_clusters) を + -- P4a aux simplex へ注入。 plate メンバに左右 border node + contain/keepout + -- edge を張り、 非メンバが box の外へ・box が tight になることを raw 座標で検証。 + it "P8 A1 keepout: 非メンバ q が plate メンバ x 区間の外 (auxSimplexCoords)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph + ["r","p0","p1","q"] + [("r","p0"),("r","p1"),("r","q")] + (g1, om0) = Sugi.assignOrder g0 + om = Sugi.applyPlateConstraints [["p0","p1"]] om0 + c = Sugi.auxSimplexCoords [["p0","p1"]] g1 om + ps = [c Map.! "p0", c Map.! "p1"] + q = c Map.! "q" + in (q < minimum ps || q > maximum ps) `shouldBe` True + + it "P8 A1 keepout: plate 有りは非メンバ⇄member 間隔が plate 無し以上 (border margin)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph + ["r","p0","p1","q"] + [("r","p0"),("r","p1"),("r","q")] + (g1, om0) = Sugi.assignOrder g0 + -- 同一 order (plate 制約済) に対し border edge の有無だけ変える公正比較 + om = Sugi.applyPlateConstraints [["p0","p1"]] om0 + gap pl = let c = Sugi.auxSimplexCoords pl g1 om + ps = [c Map.! "p0", c Map.! "p1"] + in minimum [ abs (c Map.! "q" - p) | p <- ps ] + in gap [["p0","p1"]] `shouldSatisfy` (>= gap []) + + -- Phase 39 P8 A4-2 separate_subclust: 同 rank に並ぶ兄弟 plate (= 包含関係に無い) + -- の隣接 border 間に graphviz @make_aux_edge(rn_left, ln_right, CL_OFFSET, 0)@ を + -- 張り、 兄弟 plate box が重ならないよう CL_OFFSET ぶんの隙間を simplex 解に確保する。 + -- faithful 証拠 = 兄弟 plate 間の member gap が plate 内 member gap より広いこと + -- (= border contain margin + CL_OFFSET が plate 内 nodesep を上回る・raw 座標で検証)。 + it "P8 A4-2 separate_subclust: 兄弟 plate 間 gap > plate 内 gap (raw simplex)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph + ["r","p0","p1","q0","q1"] + [("r","p0"),("r","p1"),("r","q0"),("r","q1")] + (g1, om0) = Sugi.assignOrder g0 + plates = [["p0","p1"], ["q0","q1"]] + om = Sugi.applyPlateConstraints plates om0 + c = Sugi.auxSimplexCoords plates g1 om + -- 4 member の x を昇順に。 plate 内 2 member は連続するので + -- 並びは [plateL_m0, plateL_m1, plateR_m0, plateR_m1]。 + [a, b, cc, d] = sort [c Map.! k | k <- ["p0","p1","q0","q1"]] + gMid = cc - b -- 兄弟 plate 間 (separate_subclust + border margin) + gLeft = b - a -- 左 plate 内 (nodesep のみ) + gRight = d - cc -- 右 plate 内 (nodesep のみ) + in (gMid > gLeft, gMid > gRight) `shouldBe` (True, True) + + -- Phase 39 P8 A4-2 完全忠実 point pipeline: 'auxSimplexCoordsW' は per-node 実半幅 + -- (hwMap) を LR 制約 'auxSepOf' に反映する (= graphviz の point 一貫 layout)。 + -- 幅広 node は隣接 sep を押し広げるため、 同 rank 全体の span が広がることを検証する。 + it "P8 A4-2 point pipeline: 幅広 node は同 rank の span を広げる (size-aware)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph + ["r","a","b","c"] + [("r","a"),("r","b"),("r","c")] + (g1, om) = Sugi.assignOrder g0 + spanOf m = let xs = [m Map.! k | k <- ["a","b","c"]] + in maximum xs - minimum xs + narrow = Sugi.auxSimplexCoordsW Map.empty [] g1 om -- 一律 fallback 半幅 + wide = Sugi.auxSimplexCoordsW (Map.fromList [("b", 80)]) [] g1 om + in spanOf wide `shouldSatisfy` (> spanOf narrow) + + -- Phase 19 A4: rank 引き締め (source 引き下げ + エッジ無し plate メンバ) + it "tightenSourceRanks: 深い消費者を持つ source は直前 rank へ (a→b→c, s→c)" $ + let lg = Sugi.tightenSourceRanks [] + (Sugi.assignRanks + (Sugi.buildLayoutGraph ["a", "b", "c", "s"] + [("a","b"),("b","c"),("s","c")])) + rankOf x = head [ Sugi.lnRank n | n <- Sugi.lgNodes lg, Sugi.lnId n == x ] + in (rankOf "a", rankOf "b", rankOf "c", rankOf "s", Sugi.isFeasible lg) + `shouldBe` (0, 1, 2, 1, True) + + it "tightenSourceRanks: エッジ無し node は所属 plate の最小 rank へ" $ + let lg = Sugi.tightenSourceRanks [["b", "c", "g"]] + (Sugi.assignRanks + (Sugi.buildLayoutGraph ["a", "b", "c", "g"] + [("a","b"),("b","c")])) + rankOf x = head [ Sugi.lnRank n | n <- Sugi.lgNodes lg, Sugi.lnId n == x ] + in (rankOf "g", rankOf "b") `shouldBe` (1, 1) + + it "tightenSourceRanks: 浅い source / plate 無しは no-op (既存図ビット不変)" $ + let mk = Sugi.assignRanks + (Sugi.buildLayoutGraph ["a","b","c","d"] + [("a","b"),("a","c"),("b","d"),("c","d")]) + in Sugi.tightenSourceRanks [] mk `shouldBe` mk + + -- Phase 19 A5 → Phase 39 P8: plate 枠の重なり解消。 旧 cosmetic 'applyPlateBands' + -- (帯分離) は撤去済 (Step8)。 現在は P8 cluster 制約 (border node + contain/keepout) + -- が simplex 内で member x 区間を分離するため、 同じ構造的不変条件が faithful 経路で成立する。 + it "P8 cluster 制約: 2 plate のメンバ x 区間が分離し非メンバは帯外 (旧 applyPlateBands 置換)" $ + let mkN i = DAGNode i i NodeLatent Nothing 0 0 + nodes = map mkN ["h", "b0", "b1", "x", "mu", "y", "s"] + es = [ DAGEdge f t Nothing Nothing + | (f, t) <- [("h","b0"),("h","b1"),("b0","mu"),("b1","mu") + ,("x","mu"),("mu","y"),("s","y")] ] + plates = [ DAGPlate "G" ["b0", "b1"], DAGPlate "O" ["x", "mu", "y"] ] + (pos, _) = Graphics.Hgg.DAG.layoutHierarchicalFullWithPlates nodes es plates + xOf i = head [ dnX n | n <- pos, dnId n == i ] + gXs = [xOf "b0", xOf "b1"] + oXs = [xOf "x", xOf "mu", xOf "y"] + disjoint = maximum gXs < minimum oXs || maximum oXs < minimum gXs + -- s (rank 2 = O の rank 範囲内・非メンバ) は O メンバ区間の外 + sOut = xOf "s" < minimum oXs || xOf "s" > maximum oXs + in (disjoint, sOut) `shouldBe` (True, True) + + -- Phase 20 → Phase 39 P8: nested の兄弟 plate 分離。 旧 'applyPlateBands' 再帰版は + -- 撤去済 (Step8)。 現在は P8 cluster 制約 + separate_subclust が同 rank の兄弟 cluster + -- 間に CL_OFFSET を確保することで faithful に区間分離する。 + it "P8 cluster 制約: nested の兄弟 plate の x 区間が分離 (旧 applyPlateBands 置換)" $ + let mkN i = DAGNode i i NodeLatent Nothing 0 0 + -- school plate ⊃ {classA, classB} の入れ子。 各 class に 2 ノード + + -- school 直下に s0。 root h → 各ノード → 観測 y。 + ids = ["h", "a0", "a1", "b0", "b1", "s0", "y"] + nodes = map mkN ids + es = [ DAGEdge f t Nothing Nothing + | (f, t) <- [("h","a0"),("h","a1"),("h","b0"),("h","b1") + ,("h","s0") + ,("a0","y"),("a1","y"),("b0","y"),("b1","y") + ,("s0","y")] ] + plates = [ DAGPlate "school" ["a0", "a1", "b0", "b1", "s0"] + , DAGPlate "classA" ["a0", "a1"] + , DAGPlate "classB" ["b0", "b1"] ] + (pos, _) = Graphics.Hgg.DAG.layoutHierarchicalFullWithPlates nodes es plates + xOf i = head [ dnX n | n <- pos, dnId n == i ] + aXs = [xOf "a0", xOf "a1"] + bXs = [xOf "b0", xOf "b1"] + -- 兄弟 nested plate (classA / classB) の x 区間が交わらない + sibDisjoint = maximum aXs < minimum bXs || maximum bXs < minimum aXs + -- s0 (school メンバ・非 class メンバ) は両 class 区間の外 + s0Out = all (\xs -> xOf "s0" < minimum xs || xOf "s0" > maximum xs) + [aXs, bXs] + -- 全 nested メンバは school の帯 (= school メンバ全体の包) に居る前提で + -- 帯内に収まる (parent bbox を壊さない) + schoolXs = [xOf i | i <- ["a0","a1","b0","b1","s0"]] + inParent = all (\x -> x >= minimum schoolXs && x <= maximum schoolXs) + (aXs ++ bXs) + in (sibDisjoint, s0Out, inParent) `shouldBe` (True, True, True) + + -- ★ Phase 44.1: skip edge が plate 箱を貫通しない (edge 幾何回帰ゲート)。 + -- a → plate{b,c} → d + skip a→d で、a→d の routing が plate 箱の **内部**へ侵入しない + -- ことを pt 空間で検証する。graphviz は skip edge を cluster 箱の外へ回す (= 箱貫通 0)。 + -- ★ Phase 39 P8 A2 (e164df01) の stopgap (applyPlateBands) 撤去で a→d が箱の角を抉る + -- 回帰が入ったが、layout keepout / path 本数 test では捕まらなかった (= 本 test で恒久検出)。 + -- 制御点だけでなく cubic Bézier を実サンプルする (角抉りは制御点が箱外でも曲線が箱に入るため)。 + it "Phase 44.1 回帰ゲート: skip edge a→d が plate 箱を貫通しない (cubic 実サンプル)" $ + let mkN i = DAGNode i i NodeLatent Nothing 0 0 + nodes = map mkN ["a", "b", "c", "d"] + es = [ DAGEdge f t Nothing Nothing + | (f, t) <- [("a","b"),("b","d"),("a","c"),("c","d"),("a","d")] ] + plates = [ DAGPlate "plate" ["b", "c"] ] + (pos, routed) = Graphics.Hgg.DAG.layoutHierarchicalFullWithPlates nodes es plates + radius = 20 :: Double + toScreen = dagToScreen radius pos LayoutHierarchical + nodeMap = [ (dnId n, n) | n <- pos ] + look k = head [ n | n <- pos, dnId n == k ] + obs = ER.dagObstacles toScreen radius pos nodeMap plates routed + ad = head [ e | e@(DAGEdge f t _ _) <- routed, f == "a", t == "d" ] + adPath = (\(DAGEdge _ _ p _) -> p) ad + rt = ER.routeEdge toScreen obs (look "a") (look "d") adPath radius 0 1 + -- EdgeRoute → 細サンプル点列。 CubicPath は 3 点ずつの cubic Bézier を評価、 + -- それ以外は制御点間を線形補間 (折れ線近似)。 + bez (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) t = + let u = 1 - t + in Point (u*u*u*ax + 3*u*u*t*bx + 3*u*t*t*cx + t*t*t*dx) + (u*u*u*ay + 3*u*u*t*by + 3*u*t*t*cy + t*t*t*dy) + sampleCubic (p0:c1:c2:p3:rest) = + [ bez p0 c1 c2 p3 t | t <- [0, 0.05 .. 1.0] ] ++ sampleCubic (p3:rest) + sampleCubic _ = [] + lerp (Point x1 y1) (Point x2 y2) t = Point (x1+(x2-x1)*t) (y1+(y2-y1)*t) + samplePoly ps = concat [ [ lerp p q t | t <- [0, 0.1 .. 1.0] ] | (p, q) <- zip ps (drop 1 ps) ] + samples = case rt of + ER.CubicPath ps -> sampleCubic ps + ER.BezierPath ps -> samplePoly ps + ER.SplinePath ps -> samplePoly ps + ER.StraightArrow p q -> samplePoly [p, q] + box = ER.plateBoxPt toScreen radius nodeMap plates (head plates) + inside (Point x y) = case box of + Just (xlo, ylo, xhi, yhi) -> x > xlo && x < xhi && y > ylo && y < yhi + Nothing -> False + in any inside samples `shouldBe` False + + -- ★ Phase 53 A4: per-edge box 回廊 (= 他 edge の dummy lane 侵入禁止) の回帰ゲート。 + -- 並走する 2 本の skip edge (a→z / b→z、 dummy lane が隣接) で、 各 edge の spline が + -- **相手 lane の box (半幅 9pt)** の内側へ入らないことを rank band 近傍の実サンプルで + -- 検証する。 graphviz maximal_bbox の「隣接 virtual node で clip」 の忠実化 (= corr6 + -- braid の根治機構) を恒久検出する。 + it "Phase 53 A4 回帰ゲート: 並走 skip edge が相手の dummy lane に侵入しない" $ + let mkN i = DAGNode i i NodeLatent Nothing 0 0 + nodes = map mkN ["a", "b", "p", "q", "z"] + es = [ DAGEdge f t Nothing Nothing + | (f, t) <- [("a","p"),("b","p"),("p","q"),("q","z"),("a","z"),("b","z")] ] + (pos, routed) = Graphics.Hgg.DAG.layoutHierarchicalFull nodes es + radius = 20 :: Double + toScreen = dagToScreen radius pos LayoutHierarchical + nodeMap = [ (dnId n, n) | n <- pos ] + look k = head [ n | n <- pos, dnId n == k ] + obs = ER.dagObstacles toScreen radius pos nodeMap [] routed + pathOf f t = (\(DAGEdge _ _ p _) -> p) + (head [ e | e@(DAGEdge f' t' _ _) <- routed, f' == f, t' == t ]) + routeOf f t = ER.routeEdge toScreen obs (look f) (look t) (pathOf f t) radius 0 1 + -- 相手 lane の dummy 座標 (screen) + dummiesOf f t = case pathOf f t of + Just chain -> [ toScreen x y + | (x, y) <- take (length chain - 2) (drop 1 chain) ] + Nothing -> [] + bez (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) t = + let u = 1 - t + in Point (u*u*u*ax + 3*u*u*t*bx + 3*u*t*t*cx + t*t*t*dx) + (u*u*u*ay + 3*u*u*t*by + 3*u*t*t*cy + t*t*t*dy) + sampleCubic (p0:c1:c2:p3:rest) = + [ bez p0 c1 c2 p3 t | t <- [0, 0.05 .. 1.0] ] ++ sampleCubic (p3:rest) + sampleCubic _ = [] + samplesOf r = case r of + ER.CubicPath ps -> sampleCubic ps + ER.SplinePath ps -> ps + ER.BezierPath ps -> ps + ER.StraightArrow p' q' -> [p', q'] + -- spline (f,t) が相手 lane (f',t') の dummy へ x 距離 5pt 未満に近づく + -- rank band 近傍 (|y差| ≤ 4pt) のサンプルが無いこと + invades (f, t) (f', t') = or + [ abs (px - dx) < 5 + | Point dx dy <- dummiesOf f' t' + , Point px py <- samplesOf (routeOf f t) + , abs (py - dy) <= 4 ] + lanesSeparate = case (dummiesOf "a" "z", dummiesOf "b" "z") of + (da@(_:_), db@(_:_)) -> and [ abs (ax - bx) >= 18 - 1e-6 + | (Point ax _, Point bx _) <- zip da db ] + _ -> False + in ( lanesSeparate + , invades ("a", "z") ("b", "z") + , invades ("b", "z") ("a", "z") ) `shouldBe` (True, False, False) + + -- Phase 39 A3: fit の bbox ≤ canvas 回帰ゲート。 renderDAGStandalone は + -- fitPrimsToArea で全 primitive (plate 枠・ラベル・ノード・矢印・skip edge) を + -- area 内へ収めるはず。 plate + free node (σ) + plate 跨ぎ skip edge を含む DAG を + -- 縦横様々な canvas 寸法で描き、 bbox が area を一切超えないことを数値検証する。 + it "renderDAGStandalone: 全 primitive bbox が canvas area 内 (A3 はみ出しゼロ)" $ + let g = ("mu" :: Data.Text.Text) ~> "t1" <> "mu" ~> "t2" + <> "t1" ~> "y" <> "t2" ~> "y" <> "s" ~> "y" <> "mu" ~> "y" + plate = DAGPlate "grp (n=2)" ["t1", "t2"] + lyr = Graphics.Hgg.DAG.dagPlotWithPlates g [plate] + pal = themePalette ThemeLight + eps = 0.5 -- FP 誤差許容 + fits (w, h) = + let prims = renderDAGStandalone (Rect 0 0 w h) pal lyr + in case primsBBoxDAG prims of + Nothing -> False + Just (xlo, ylo, xhi, yhi) -> + xlo >= negate eps && ylo >= negate eps + && xhi <= w + eps && yhi <= h + eps + in map fits [(600, 400), (300, 500), (800, 220), (220, 800)] + `shouldBe` [True, True, True, True] + + -- Phase 23: plate 枠 = glyph bbox (中心 ± nodeExtent)。 旧実装 (中心 bbox + + -- 固定 pad radius*1.6) では label ≥ 9 文字のノードが水平端で枠を超えていた + -- (analyze Phase 63.2 の実測再現 = 長 label Data box が 22.3px 突き抜け)。 + it "renderPlate: 長 label ノードの glyph box が plate 枠に収まる (Phase 23)" $ + let nodes = [ DAGNode "x_duration_long" "x_duration_long" NodeData + (Just "Data") 0 0 + , DAGNode "y" "y" NodeObserved (Just "NegativeBinomial") 0 0 ] + es = [ DAGEdge "x_duration_long" "y" Nothing Nothing ] + plates = [ DAGPlate "obs (4)" ["x_duration_long", "y"] ] + (pos, routed) = + Graphics.Hgg.DAG.layoutHierarchicalFullWithPlates nodes es plates + spec = layer (dagFromListsWithPlates pos routed LayoutHierarchical plates) + <> widthUnit (760 *~ px) <> heightUnit (520 *~ px) + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver spec) spec + -- plate 枠 = fill-opacity 0 の PRect / node glyph 箱 = opacity > 0 の + -- PRect (背景の白 rect は除外) + frames = [ r | PRect r (FillStyle _ o) _ <- ps, o == 0 ] + boxes = [ r | PRect r (FillStyle c o) _ <- ps + , o > 0, c /= Data.Text.pack "#ffffff" ] + contains (Rect fx fy fw fh) (Rect bx by bw bh) = + fx <= bx && bx + bw <= fx + fw && fy <= by && by + bh <= fy + fh + in case frames of + [frame] -> (length boxes >= 1, all (contains frame) boxes) + `shouldBe` (True, True) + _ -> expectationFailure ("plate 枠 PRect が 1 個でない: " + <> show (length frames)) + + it "一様 δ=ω=1 では longest-path が edge length sum 最適 (= assignRanks と一致)" $ + let g0 = Sugi.buildLayoutGraph ["a","b","c","d"] + [("a","b"),("a","c"),("b","d"),("c","d")] + lpOnly = Sugi.longestPathRanking g0 + full = Sugi.assignRanks g0 + in Sugi.edgeLengthSum full `shouldBe` Sugi.edgeLengthSum lpOnly + + it "決定論性: 同 input は同 rank (= 2 回実行で完全一致)" $ + let g = Sugi.buildLayoutGraph ["x","y","z","w"] + [("x","y"),("y","z"),("x","w"),("w","z")] + r1 = Sugi.assignRanks g + r2 = Sugi.assignRanks g + in r1 `shouldBe` r2 + + it "後方互換: dagPlot の y 座標は新 rank 経由でも旧 longest-path と一致" $ + let g = ("alpha" :: Data.Text.Text) ~> "y" <> "beta" ~> "y" <> "alpha" ~> "sigma" <> "sigma" ~> "y" + spec = layer (Graphics.Hgg.DAG.dagPlot g) + -- 旧実装と同じ rank 構造: alpha=0, beta=0, sigma=1, y=2 + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + in length [() | PPath{} <- ps] `shouldSatisfy` (>= 4) -- 4 node 形状 + arrow + + describe "Step6 R2: funnel (Mononen, graphviz Pshortestpath 相当)" $ do + -- 規約: portal.left=小x / portal.right=大x、path は下方向 (y 増加)。 + it "wide channel (障害物なし) → 直線 (src,goal のみ・重複なし)" $ + let portals = [ (Point 5 0, Point 5 0) + , (Point 0 10, Point 10 10) + , (Point 0 20, Point 10 20) + , (Point 5 30, Point 5 30) ] + in ER.funnel portals `shouldBe` [Point 5 0, Point 5 30] + + it "右側障害物 → 左の角で taut に曲がる (cone 不変条件 OK)" $ + -- y=10 で free 区間 [2,10] (= x<2 が塞がれる)。 src/goal は x=0。 + -- 最短路は (0,0)→(2,10)→(0,20) で角 (2,10) を通る。 + let portals = [ (Point 0 0, Point 0 0) + , (Point 2 10, Point 10 10) + , (Point 0 20, Point 0 20) ] + in ER.funnel portals `shouldBe` [Point 0 0, Point 2 10, Point 0 20] + + it "taut 折れ線は左右往復しない (旧 zigzag 回帰防止)" $ + -- 3 連続 gate が右側を x≥2 に制限。 taut 路の x は単峰 (出て戻る) で、 + -- 局所 peak は高々 1 個 = 左右往復ジグザグでないこと。 + let portals = [ (Point 0 0, Point 0 0) + , (Point 2 10, Point 10 10) + , (Point 2 20, Point 10 20) + , (Point 2 30, Point 10 30) + , (Point 0 40, Point 0 40) ] + xs = [ x | Point x _ <- ER.funnel portals ] + peaks = length [ () | (a, b, c) <- zip3 xs (drop 1 xs) (drop 2 xs) + , b > a, b > c ] + in peaks `shouldSatisfy` (<= 1) + + it "buildChannel+funnel: 端点が片寄っても dummy lane に沿う (L字 shortcut しない)" $ + -- dummy lane = x13、 端点は x70/x52 (右寄り)。 旧 (free 区間全幅 portal) は funnel が + -- lane を無視し x≈52 へ shortcut → L字 → R3 bulge。 狭い窓 portal なら経路内部は + -- dummy lane (x13±portalHalfWidth=6) 近傍に留まる。 + let guide = [ Point 70 0, Point 13 30, Point 13 60, Point 13 90, Point 52 120 ] + taut = ER.funnel (ER.buildChannel [] guide) + interiorXs = [ x | Point x _ <- drop 1 (init taut) ] + in interiorXs `shouldSatisfy` all (<= 19 + 1e-9) + + describe "Step6 R3: cubic solver + Proutespline (graphviz route.c)" $ do + let approxRoots want got = case got of + Right rs -> let s = sort rs + in length s == length want + && and (zipWith (\a b -> abs (a - b) < 1e-6) s (sort want)) + Left () -> False + it "solve3: (x-1)(x-2)(x-3) → {1,2,3}" $ + -- x³ -6x² +11x -6 + ER.solve3 (-6, 11, -6, 1) `shouldSatisfy` approxRoots [1, 2, 3] + it "solve3: x³ - x → {-1,0,1}" $ + ER.solve3 (0, -1, 0, 1) `shouldSatisfy` approxRoots [-1, 0, 1] + it "solve3: 二重根 (x)(x-2)² → {0,2}" $ + -- x³ -4x² +4x + ER.solve3 (0, 4, -4, 1) `shouldSatisfy` approxRoots [0, 2] + it "solve3: 線形 2x+4 → {-2}" $ + ER.solve3 (4, 2, 0, 0) `shouldSatisfy` approxRoots [-2] + + it "proutespline: 障害物なし直線 taut → 始点/終点を保持した cubic" $ + let inps = [Point 0 0, Point 0 30, Point 0 60] + ctrl = ER.proutespline [] inps (Point 0 1) (Point 0 1) + in (head ctrl, last ctrl) `shouldBe` (Point 0 0, Point 0 60) + it "proutespline: 制御点列は 始点 + 3k 個 (cubic segment の倍数)" $ + let inps = [Point 0 0, Point 0 30, Point 0 60] + ctrl = ER.proutespline [] inps (Point 0 1) (Point 0 1) + in (length ctrl - 1) `mod` 3 `shouldBe` 0 + + describe "Phase 1 A3: order assignment (= dummy + median + transpose)" $ do + it "insertDummies: 長 edge (rank 差 3) で dummy 2 個 + 短 edge 3 本に展開" $ + let g0 = Sugi.buildLayoutGraph ["a", "b"] [("a", "b")] + -- 手動で b の rank を 3 に + g1 = g0 { Sugi.lgNodes = [ Sugi.LNode "a" 0 False + , Sugi.LNode "b" 3 False ] } + g2 = Sugi.insertDummies g1 + dummies = [ n | n <- Sugi.lgNodes g2, Sugi.lnDummy n ] + in (length dummies, length (Sugi.lgEdges g2)) `shouldBe` (2, 3) + + it "insertDummies: rank 差 1 の edge は触らない (= 元のまま)" $ + let g = Sugi.assignRanks (Sugi.buildLayoutGraph ["a","b"] [("a","b")]) + g2 = Sugi.insertDummies g + in (length (Sugi.lgNodes g2), length (Sugi.lgEdges g2)) `shouldBe` (2, 1) + + it "bilayerCrossings: 2 edge 交差ペアで 1" $ + let edges_ = [("a", "y"), ("b", "x")] + in Sugi.bilayerCrossings edges_ ["a", "b"] ["x", "y"] `shouldBe` 1 + + it "bilayerCrossings: 平行 edge は 0" $ + let edges_ = [("a", "x"), ("b", "y")] + in Sugi.bilayerCrossings edges_ ["a", "b"] ["x", "y"] `shouldBe` 0 + + it "K3,3 風 reverse pattern (= A→Z, B→Y, C→X) は median sweep で crossings 3 → 0" $ + let g0 = Sugi.assignRanks $ + Sugi.buildLayoutGraph ["A","B","C","X","Y","Z"] + [("A","Z"),("B","Y"),("C","X")] + ini = Sugi.initialOrder g0 + (g1, finalOrd) = Sugi.assignOrder g0 + cIni = Sugi.countCrossings g0 ini + cFin = Sugi.countCrossings g1 finalOrd + in (cIni, cFin) `shouldBe` (3, 0) + + it "決定論性: 同 input → 同 OrderMap (= 2 回 assignOrder 一致)" $ + let g0 = Sugi.assignRanks $ + Sugi.buildLayoutGraph ["a","b","c","d","e","f"] + [("a","d"),("a","e"),("b","f"),("c","d")] + (_, o1) = Sugi.assignOrder g0 + (_, o2) = Sugi.assignOrder g0 + in o1 `shouldBe` o2 + + it "countCrossings は最終 ≤ 初期 (= sweep が必ず改善 or 維持)" $ + let g0 = Sugi.assignRanks $ + Sugi.buildLayoutGraph ["a","b","c","p","q","r"] + [("a","q"),("a","r"),("b","p"),("c","p"),("c","r")] + ini = Sugi.initialOrder g0 + (g1, fin) = Sugi.assignOrder g0 + cIni = Sugi.countCrossings g0 ini + cFin = Sugi.countCrossings g1 fin + in cFin <= cIni `shouldBe` True + + it "dummy 込み全 LayoutGraph で feasible (= rank 差 = δ = 1 を保つ)" $ + let g0 = Sugi.assignRanks $ + Sugi.buildLayoutGraph ["a","b","c"] [("a","c"),("a","b"),("b","c")] + (g1, _) = Sugi.assignOrder g0 + in Sugi.isFeasible g1 `shouldBe` True + + describe "Phase 1 A4: Brandes-Köpfe coordinate assignment (= TD+BU median)" $ do + it "単一 chain a→b→c は全 node 同 x (= 垂直整列、 |Δx| < 1e-9)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph ["a","b","c"] + [("a","b"),("b","c")] + (g1, om) = Sugi.assignOrder g0 + coords = Sugi.assignCoords [] g1 om + [xa, xb, xc] = map (\k -> coords Map.! k) ["a","b","c"] + in maximum (map abs [xa - xb, xb - xc]) `shouldSatisfy` (< 1e-9) + + it "対称 diamond a→b,a→c,b→d,c→d で a と d は同 x、 b と c が対称" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph ["a","b","c","d"] + [("a","b"),("a","c"),("b","d"),("c","d")] + (g1, om) = Sugi.assignOrder g0 + coords = Sugi.assignCoords [] g1 om + [xa, xb, xc, xd] = map (\k -> coords Map.! k) ["a","b","c","d"] + in do + abs (xa - xd) `shouldSatisfy` (< 1e-9) + -- b と c は a/d の中心 (= (xa) と対称) → xb + xc ≈ 2 * xa + abs ((xb + xc) - 2 * xa) `shouldSatisfy` (< 1e-9) + + it "coord 範囲 [0, 1] (= 正規化)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph ["p","q","r","s"] + [("p","r"),("q","r"),("r","s")] + (g1, om) = Sugi.assignOrder g0 + coords = Map.elems (Sugi.assignCoords [] g1 om) + in do + minimum coords `shouldSatisfy` (>= 0) + maximum coords `shouldSatisfy` (<= 1) + + it "決定論性: 同 input → 同 coords (= 2 回 assignCoords 一致)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph ["a","b","c","d","e"] + [("a","b"),("a","c"),("b","d"),("c","d"),("d","e")] + (g1, om) = Sugi.assignOrder g0 + c1 = Sugi.assignCoords [] g1 om + c2 = Sugi.assignCoords [] g1 om + in c1 `shouldBe` c2 + + it "rank が 1 つ (= source 群のみ) は等間隔 [0..1]" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph ["a","b","c"] [] + (g1, om) = Sugi.assignOrder g0 + coords = Sugi.assignCoords [] g1 om + xs = sort [ coords Map.! k | k <- ["a","b","c"] ] + in (head xs, last xs) `shouldBe` (0, 1) + + it "computeOneDir 単独: top-down は source 側 anchor、 bottom-up は sink 側 anchor (= 2 候補で値が違う)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph ["a","b","c","d","e"] + [("a","c"),("b","c"),("c","d"),("c","e")] + (g1, om) = Sugi.assignOrder g0 + xTD = Sugi.computeOneDir True g1 om + xBU = Sugi.computeOneDir False g1 om + in xTD `shouldNotBe` xBU + + describe "Phase 1 A5: edge routing (= dummy 経由 + Catmull-Rom spline)" $ do + it "insertDummiesWithChains: 長 edge (rank 差 3) chain は 4 要素 [from, d1, d2, to]" $ + let g0 = Sugi.buildLayoutGraph ["a","b"] [("a","b")] + g1 = g0 { Sugi.lgNodes = [ Sugi.LNode "a" 0 False + , Sugi.LNode "b" 3 False ] } + (_, chainMap) = Sugi.insertDummiesWithChains g1 + chain = chainMap Map.! ("a", "b") + in length chain `shouldBe` 4 + + it "insertDummiesWithChains: 短 edge は chain 2 要素 [from, to]" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph ["a","b"] [("a","b")] + (_, chainMap) = Sugi.insertDummiesWithChains g0 + in chainMap Map.! ("a", "b") `shouldBe` ["a", "b"] + + it "assignOrderFull: chainMap が assignOrder 結果と整合 (= 全 edge に対応 chain あり)" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph ["a","b","c","d"] + [("a","b"),("a","d"),("c","d")] + (_, _, chainMap) = Sugi.assignOrderFull g0 + keys = Map.keys chainMap + in do + ("a","b") `elem` keys `shouldBe` True + ("a","d") `elem` keys `shouldBe` True + ("c","d") `elem` keys `shouldBe` True + + it "DAG.dagPlot 長 edge を含む graph で routedEdges の dePath が Just (= spline 描画)" $ + let g = ("a" :: Data.Text.Text) ~> "d" -- 直接 long edge (rank 0 → 3 予定) + <> "a" ~> "b" <> "b" ~> "c" <> "c" ~> "d" -- 経路 chain + spec = layer (Graphics.Hgg.DAG.dagPlot g) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + -- spline edge は PPath (= curve)、 矢印ヘッドも PPath。 多めに含まれるはず。 + paths = length [() | PPath{} <- ps] + in paths `shouldSatisfy` (>= 8) -- 4 node 楕円 + 4 短 edge 矢印 + 1 long edge spline + 1 long edge 矢印 = 10 程度 + + it "DAG.dagPlot 短 edge のみ graph では dePath が全て Nothing (= 直線描画)" $ + let g = ("a" :: Data.Text.Text) ~> "b" <> "b" ~> "c" + spec = layer (Graphics.Hgg.DAG.dagPlot g) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + -- 短 edge では PLine (= 直線) が edge ごとに 1 本 + plines = length [() | PLine{} <- ps] + in plines `shouldSatisfy` (>= 2) + + it "DAGEdge backward compat: dagEdge は dePath = Nothing default" $ + let e = dagEdge "x" "y" + in dePath e `shouldBe` Nothing + + describe "Phase 1 A6: plate-aware ordering" $ do + it "applyPlateConstraints: 2 plate ([a1,a2] と [b1,b2]) で同 rank 内 contiguous" $ + let -- 初期 order が [a1, b1, a2, b2] (= 交互) であっても plate 制約後は a1,a2 隣接 / b1,b2 隣接 + om0 = Map.fromList [(0, ["a1", "b1", "a2", "b2"])] + plates = [["a1", "a2"], ["b1", "b2"]] + om1 = Sugi.applyPlateConstraints plates om0 + row = om1 Map.! 0 + -- 同 plate の index 差が 1 (= 隣接) であること + ixOf v = head [ i | (i, x) <- zip [0 :: Int ..] row, x == v ] + in do + abs (ixOf "a1" - ixOf "a2") `shouldBe` 1 + abs (ixOf "b1" - ixOf "b2") `shouldBe` 1 + + it "applyPlateConstraints 空 plates: 入力 OrderMap と同一" $ + let om0 = Map.fromList [(0, ["a", "b", "c"])] + in Sugi.applyPlateConstraints [] om0 `shouldBe` om0 + + it "applyPlateConstraints: 非 plate node は元順序を保つ" $ + let om0 = Map.fromList [(0, ["x", "a1", "y", "a2", "z"])] + plates = [["a1", "a2"]] + om1 = Sugi.applyPlateConstraints plates om0 + row = om1 Map.! 0 + -- x, y, z の元順序が破壊されていない (= median 安定 sort) + posMap = Map.fromList (zip row [0 :: Int ..]) + in do + (posMap Map.! "x") < (posMap Map.! "y") `shouldBe` True + (posMap Map.! "y") < (posMap Map.! "z") `shouldBe` True + + it "dagPlotWithPlates: plate 渡しても layout 走る (= PRect plate box が出る)" $ + let g = ("a1" :: Data.Text.Text) ~> "y" + <> "a2" ~> "y" <> "b1" ~> "y" <> "b2" ~> "y" + plates = [ DAGPlate "plate-a" ["a1", "a2"] + , DAGPlate "plate-b" ["b1", "b2"] + ] + spec = layer (Graphics.Hgg.DAG.dagPlotWithPlates g plates) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + -- plate 2 個分の bounding box (= PRect) + plate label + rects = length [() | PRect{} <- ps] + in rects `shouldSatisfy` (>= 2) + + it "Phase 1 A7 (port snap): latent (ellipse) 水平方向 port は cx ± rx に snap" $ + let n = Graphics.Hgg.Easy.dagNode "v" "v" NodeLatent 0 0 + -- baseR = 20、 dist 無し → rx = ry = 20 + p = edgePortPoint n (Point 100 100) (Point 200 100) 20 + in case p of + Point px py -> do + abs (px - 120) `shouldSatisfy` (< 1e-9) + abs (py - 100) `shouldSatisfy` (< 1e-9) + + it "Phase 1 A7 (port snap): data (rect) 水平方向 port は cx + rx に snap" $ + let n = Graphics.Hgg.Easy.dagNode "v" "v" NodeData 0 0 + p = edgePortPoint n (Point 0 0) (Point 100 0) 20 + in case p of + Point px py -> do + abs (px - 20) `shouldSatisfy` (< 1e-9) + abs py `shouldSatisfy` (< 1e-9) + + it "Phase 1 A8 決定論性: 全 pipeline (= layoutHierarchicalFullWithPlates) を 2 回実行で完全一致" $ + let nodes = [ Graphics.Hgg.Easy.dagNode i i NodeLatent 0 0 + | i <- ["a","b","c","d","e","f"] ] + edges_ = [ dagEdge "a" "c", dagEdge "b" "c", dagEdge "c" "d" + , dagEdge "c" "e", dagEdge "d" "f", dagEdge "e" "f" + , dagEdge "a" "f" -- long edge → dummy 入る + ] + plates = [ DAGPlate "P" ["c", "d"] ] + run = Graphics.Hgg.DAG.layoutHierarchicalFullWithPlates nodes edges_ plates + r1 = run + r2 = run + in r1 `shouldBe` r2 + + it "graphviz parity bench: small case (N=10, 13 edges) で crossings = 0 (= 内部基準値)" $ + let nodeIds = ["a","b","c","d","e","f","g","h","i","j"] + es = [ ("a","c"),("b","c"),("c","d"),("c","e") + , ("d","f"),("e","f"),("d","g"),("e","h") + , ("f","i"),("g","j"),("h","j"),("i","j"),("a","j") ] + g0 = Sugi.assignRanks (Sugi.buildLayoutGraph nodeIds es) + (g1, om, _) = Sugi.assignOrderFull g0 + in Sugi.countCrossings g1 om `shouldBe` 0 + + it "Phase 1 並列 edge: 同 (from, to) を 3 本書くと PPath spline が 3 本 描画される" $ + let g = ("a" :: Data.Text.Text) ~> "b" <> "a" ~> "b" <> "a" ~> "b" + spec = layer (Graphics.Hgg.DAG.dagPlot g) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + -- 並列 3 本それぞれ spline edge (PPath) + 矢印 (PPath) = 6 PPath 増加 (+ node 2 個) + paths = length [() | PPath{} <- ps] + in paths `shouldSatisfy` (>= 8) -- 2 node 楕円 + 3 spline + 3 矢印 = 8 + + it "Phase 1 並列 edge: 1 本のみ (= parCount=1) なら従来の PLine 直線 (= spline 化しない)" $ + let g = ("a" :: Data.Text.Text) ~> "b" + spec = layer (Graphics.Hgg.DAG.dagPlot g) + ps = renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec + plines = length [() | PLine{} <- ps] + in plines `shouldSatisfy` (>= 1) + + it "Phase 1 A8 決定論性: assignRanks + assignOrder + applyPlateConstraints + assignCoords 全体" $ + let g0 = Sugi.assignRanks $ Sugi.buildLayoutGraph + ["x","y","z","w","u"] + [("x","y"),("y","z"),("x","w"),("w","z"),("z","u")] + (g1, o, _) = Sugi.assignOrderFull g0 + op = Sugi.applyPlateConstraints [["w","z"]] o + c1 = Sugi.assignCoords [] g1 op + c2 = Sugi.assignCoords [] g1 op + in c1 `shouldBe` c2 + + it "Phase 1 A7 (port snap): rect 対角 45° は短辺の方向で先に交点 (= min(rx/|ux|, ry/|uy|))" $ + let n = Graphics.Hgg.Easy.dagNode "v" "v" NodeData 0 0 + p = edgePortPoint n (Point 0 0) (Point 100 100) 20 + in case p of + -- ★A15: nodeExtent で可変サイズ。 NodeData "v" (1 行・dist 無し) は + -- rx = max 20 (1*6.6/2+8) = 20、 ry = max (20*0.7) (1*14/2+4) = 14。 + -- ux = uy = √2/2 ゆえ短辺 ry=14 が先 → t = 14/(√2/2)、 port = (14, 14)。 + Point px py -> do + abs (px - 14) `shouldSatisfy` (< 1e-9) + abs (py - 14) `shouldSatisfy` (< 1e-9) + + it "dagPlotWithPlates: plate メンバが contiguous (= 同 plate の x が近い)" $ + let g = ("a1" :: Data.Text.Text) ~> "z" + <> "a2" ~> "z" <> "b1" ~> "z" <> "b2" ~> "z" + plates = [ DAGPlate "A" ["a1", "a2"] + , DAGPlate "B" ["b1", "b2"] + ] + spec = layer (Graphics.Hgg.DAG.dagPlotWithPlates g plates) + dagSpec = case getLast (lyDAG (head (vsLayers spec))) of + Just ds -> ds + Nothing -> error "no dag" + ns = dsNodes dagSpec + xOf nid = case [dnX n | n <- ns, dnId n == nid] of + (x:_) -> x + _ -> 999 + a1 = xOf "a1"; a2 = xOf "a2"; b1 = xOf "b1"; b2 = xOf "b2" + insideA = abs (a1 - a2) + insideB = abs (b1 - b2) + between = min (abs (a1 - b1)) (abs (a2 - b2)) + in do + insideA `shouldSatisfy` (< between) + insideB `shouldSatisfy` (< between) + + -- ======================================================================= + -- Phase 53 A3: rank=same (assignRanksGrouped + P3e flat-edge ordering) + -- ======================================================================= + it "Phase 53 A3-2: assignRanksGrouped group 無し = 旧 pipeline (breakCycles→assignRanks→tighten) とビット一致" $ + let ids = ["s","a","b","t","c"] + es = [("s","a"),("a","b"),("b","a"),("b","t"),("c","c"),("s","c")] + plateIds = [["c","t"]] + old = Sugi.tightenSourceRanks plateIds $ Sugi.assignRanks $ + Sugi.buildLayoutGraph ids (Sugi.breakCycles ids es) + new = Sugi.assignRanksGrouped [] plateIds ids es + in new `shouldBe` old + + it "Phase 53 A3-2: rank group で member が同 rank + group 内 edge が flat 化 (原方向保持)" $ + let lg = Sugi.assignRanksGrouped [["b","c"]] [] + ["a","b","c","d"] + [("a","b"),("a","c"),("b","c"),("b","d"),("c","d")] + rk i = head [Sugi.lnRank n | n <- Sugi.lgNodes lg, Sugi.lnId n == i] + flats = [ (Sugi.leFrom e, Sugi.leTo e) + | e <- Sugi.lgEdges lg + , rk (Sugi.leFrom e) == rk (Sugi.leTo e) ] + in do + rk "b" `shouldBe` rk "c" + rk "a" `shouldSatisfy` (< rk "b") + rk "d" `shouldSatisfy` (> rk "b") + flats `shouldBe` [("b","c")] + + it "Phase 53 A3-3: flatReorder で flat edge が左→右 (from が to より左) に並ぶ" $ + let lg = Sugi.assignRanksGrouped [["b","c"]] [] + ["a","b","c","d"] + [("a","b"),("a","c"),("c","b"),("b","d"),("c","d")] -- flat: c→b + (_, om) = Sugi.assignOrder lg + rk i = head [Sugi.lnRank n | n <- Sugi.lgNodes lg, Sugi.lnId n == i] + orderAt = Map.findWithDefault [] (rk "b") om + ixOf v = length (takeWhile (/= v) orderAt) + in ixOf "c" `shouldSatisfy` (< ixOf "b") -- 初期 ID 辞書順 [b,c] からの反転を要求 + + it "Phase 53 A3-3: flat 閉路 (b⇄c) でも落ちず決定論的" $ + let lg = Sugi.assignRanksGrouped [["b","c"]] [] ["a","b","c"] + [("a","b"),("a","c"),("b","c"),("c","b")] + (_, om1) = Sugi.assignOrder lg + (_, om2) = Sugi.assignOrder lg + in om1 `shouldBe` om2 + + it "Phase 53 A3: dagPlotWithRankGroups end-to-end (同 dnY + 非隣接 flat edge の迂回 dePath)" $ + let g = ("r" :: Data.Text.Text) ~> "a" <> "r" ~> "m" <> "r" ~> "b" + <> "a" ~> "m" <> "m" ~> "b" <> "a" ~> "b" + spec = layer (Graphics.Hgg.DAG.dagPlotWithRankGroups g [["a","m","b"]]) + dagSpec = case getLast (lyDAG (head (vsLayers spec))) of + Just ds -> ds + Nothing -> error "no dag" + ns = dsNodes dagSpec + yOf nid = case [dnY n | n <- ns, dnId n == nid] of + (y:_) -> y + _ -> 999 + pathOf f t = case [ dePath e | e <- dsEdges dagSpec + , deFrom e == f, deTo e == t ] of + (p:_) -> p + _ -> Nothing + in do + yOf "a" `shouldBe` yOf "m" + yOf "m" `shouldBe` yOf "b" + -- 隣接 flat edge (a→m / m→b) = 水平直線 (dePath 無し) + pathOf "a" "m" `shouldBe` Nothing + pathOf "m" "b" `shouldBe` Nothing + -- 非隣接 flat edge (a→b、 間に m) = rank 上側 gap の waypoint 1 点 + case pathOf "a" "b" of + Just [(_, y0), (_, ym), (_, y1)] -> do + y0 `shouldBe` yOf "a" + y1 `shouldBe` yOf "b" + ym `shouldBe` yOf "a" - 0.5 + other -> expectationFailure ("unexpected dePath: " <> show other) + + -- ========================================================================= + -- Phase 11 A1: validate / compile / diagnostics + -- ========================================================================= + describe "Validate (Phase 11 A1)" $ do + let rXY n = case n of + "x" -> Just (NumData (V.fromList [1, 2, 3])) + "y" -> Just (NumData (V.fromList [4, 5, 6])) + "grp" -> Just (TxtData (V.fromList ["a", "b", "a"])) + _ -> Nothing + + it "完全な scatter は診断ゼロ" $ + validatePlot rXY (layer (scatter "x" "y")) `shouldBe` [] + + it "必須 aesthetic 欠落を検出 (histogram は x 必須、 空 layer)" $ + let emptyHist = mempty { lyKind = First (Just MHistogram) } :: Layer + diags = validatePlot emptyResolver (purePlot { vsLayers = [emptyHist] }) + in any isMissing diags `shouldBe` True + + it "解決できない列名で ColumnNotFound" $ + let diags = validatePlot rXY (layer (scatter "xxx" "y")) + in any isNotFound diags `shouldBe` True + + it "ColumnNotFound に編集距離 suggestion が付く (validatePlotWith)" $ + let known = ["x", "y", "grp"] + diags = validatePlotWith known rXY (layer (scatter "yy" "x")) + sugg = [cs | PlotError (ColumnNotFound _ cs) _ <- diags] + in case sugg of + (cs : _) -> cs `shouldSatisfy` (\xs -> "y" `elem` xs) + [] -> expectationFailure "ColumnNotFound が出ていない" + + it "errorX に文字列列で ColumnTypeMismatch" $ + let diags = validatePlot rXY (layer (forest "y" "grp" "grp")) + -- forest errCol = "grp" (文字列) → errorX 数値要求に不一致 + in any isTypeMismatch diags `shouldBe` True + + it "空プロットは EmptyPlot error" $ + validatePlot emptyResolver purePlot `shouldBe` [PlotError EmptyPlot (DiagnosticContext Nothing Nothing)] + + it "compilePlot: error があれば Left" $ + case compilePlot emptyResolver purePlot of + Left _ -> True `shouldBe` True + Right _ -> expectationFailure "EmptyPlot を素通しした" + + it "compilePlot: 正常 spec は Right" $ + case compilePlot rXY (layer (scatter "x" "y")) of + Right c -> length (vsLayers (compiledSpec c)) `shouldBe` 1 + Left ds -> expectationFailure ("予期せぬ error: " <> show ds) + + it "capability: hover + SVG backend は BackendUnsupported warning" $ + let spec = layer (scatter "x" "y" <> hoverCols ["grp"]) + warns = checkCapability svgCapability spec + in any isHoverWarn warns `shouldBe` True + + it "capability: hover + Canvas backend は warning 無し" $ + let spec = layer (scatter "x" "y" <> hoverCols ["grp"]) + in filter isHoverWarn (checkCapability canvasCapability spec) `shouldBe` [] + + -- ========================================================================= + -- Phase 11 A2: Monoid 合成規則の conformance (design/monoid-semantics.md と一致) + -- ========================================================================= + describe "Monoid 合成規則 (Phase 11 A2)" $ do + it "Layer: lyKind は first wins (scatter<>line は MScatter)" $ + let l = scatter "a" "b" <> line "c" "d" + in getFirst (lyKind l) `shouldBe` Just MScatter + + it "Layer: lyEncX/Y は last wins (scatter<>line で c/d が残る)" $ + let l = scatter "a" "b" <> line "c" "d" + in (getLast (lyEncX l), getLast (lyEncY l)) + `shouldBe` (Just (ColByName "c"), Just (ColByName "d")) + + it "Layer: lyHover は concat" $ + let l = hoverCols ["a"] <> hoverCols ["b", "c"] + in lyHover l `shouldBe` [ColByName "a", ColByName "b", ColByName "c"] + + it "Layer: lyAlpha は last wins" $ + getLast (lyAlpha (alpha 0.3 <> alpha 0.7)) `shouldBe` Just 0.7 + + it "Layer: lyColorCats は last-nonempty wins (concat ではない)" $ + lyColorCats (colorCats ["a", "b"] <> colorCats ["c"]) `shouldBe` ["c"] + + it "Layer: 空 colorCats を後に合成しても前者が残る" $ + lyColorCats (colorCats ["a", "b"] <> mempty) `shouldBe` ["a", "b"] + + it "VisualSpec: vsLayers は concat (layer<>layer で 2 層)" $ + length (vsLayers (layer (scatter "x" "y") <> layer (line "x" "z"))) `shouldBe` 2 + + it "VisualSpec: vsTitle は last wins" $ + getLast (vsTitle (title "a" <> title "b")) `shouldBe` Just "b" + + it "VisualSpec: vsRefLines は concat" $ + length (vsRefLines (refHorizontal 0 <> refHorizontal 1)) `shouldBe` 2 + + it "Monoid 則: 左単位元 (mempty <> s == s) for VisualSpec" $ + let s = layer (scatter "x" "y") <> title "t" + in (mempty <> s) `shouldBe` s + + -- ========================================================================= + -- Phase 11 A3: Easy 層 (値直接受け + overlay) + -- ========================================================================= + describe "Easy 層 (Phase 11 A3)" $ do + it "points xs ys ≡ scatter (inline xs) (inline ys)" $ + points [1, 2, 3] [4, 5, 6] `shouldBe` scatter (inline [1, 2, 3 :: Double]) (inline [4, 5, 6 :: Double]) + + it "lineXY ≡ line (inline ..) (inline ..)" $ + lineXY [1, 2] [3, 4] `shouldBe` line (inline [1, 2 :: Double]) (inline [3, 4 :: Double]) + + it "hist xs ≡ histogram (inline xs)" $ + hist [1, 2, 3] `shouldBe` histogram (inline [1, 2, 3 :: Double]) + + it "plotY は index を x に取る (= 0,1,2)" $ + case getLast (lyEncX (plotY [10, 20, 30])) of + Just (ColNum v) -> V.toList v `shouldBe` [0, 1, 2] + _ -> expectationFailure "encX が ColNum でない" + + it "overlay [a,b] は 2 layer の VisualSpec" $ + length (vsLayers (overlay [points [1] [2], lineXY [1] [2]])) `shouldBe` 2 + + it "plots は overlay の別名" $ + plots [points [1] [2]] `shouldBe` overlay [points [1] [2]] + + -- ========================================================================= + -- Phase 11 A4-a: scale reverse (軸反転 = range 入替) + -- ========================================================================= + describe "scale reverse (Phase 11 A4-a)" $ do + let mk extra = computeLayout emptyResolver (overlay [points [0, 5, 10] [0, 5, 10]] <> extra) + normal = mk mempty + + it "reverseX setter は vsReverseX のみ立てる" $ + (getLast (vsReverseX reverseX), getLast (vsReverseY reverseX)) + `shouldBe` (Just True, Nothing) + + it "通常 X は単調増加 (x=0 が x=10 より小 px)" $ + (scaleApply (lpXScale normal) 0 < scaleApply (lpXScale normal) 10) `shouldBe` True + + it "reverseX で X が単調減少 (x=0 が x=10 より大 px)" $ + let rev = mk reverseX + in (scaleApply (lpXScale rev) 0 > scaleApply (lpXScale rev) 10) `shouldBe` True + + it "reverseX は range 入替なので px の和が保存 (rev v + normal v = 一定)" $ + let rev = mk reverseX + s0 = scaleApply (lpXScale rev) 0 + scaleApply (lpXScale normal) 0 + s10 = scaleApply (lpXScale rev) 10 + scaleApply (lpXScale normal) 10 + in abs (s0 - s10) `shouldSatisfy` (< 1e-9) + + it "reverseY で Y が単調増加 (通常は減少 = 上が大)" $ + let revY' = mk reverseY + in (scaleApply (lpYScale revY') 0 < scaleApply (lpYScale revY') 10) `shouldBe` True + + it "reverse 無指定なら scale は従来通り (X 増加・Y 減少)" $ + ( scaleApply (lpXScale normal) 0 < scaleApply (lpXScale normal) 10 + , scaleApply (lpYScale normal) 0 > scaleApply (lpYScale normal) 10 ) + `shouldBe` (True, True) + + -- ========================================================================= + -- Phase 11 A7-a: coord_cartesian(xlim,ylim) = データ非破棄 zoom + -- ========================================================================= + describe "coord_cartesian zoom (Phase 11 A7-a)" $ do + -- 11 点 (x=0..10) の scatter。 zoom x∈[2,6] で窓外 8 点は描画 clip だが残る。 + let xs11 = [0,1,2,3,4,5,6,7,8,9,10] :: [Double] + spec extra = overlay [points xs11 xs11] <> extra + mk extra = computeLayout emptyResolver (spec extra) + zoom = mk (coordCartesian 2 6 0 40) + a = lpPlotArea zoom + + it "coordCartesianX setter は vsCoordXLim のみ立てる" $ + ( getLast (vsCoordXLim (coordCartesianX 2 6)) + , getLast (vsCoordYLim (coordCartesianX 2 6)) ) + `shouldBe` (Just (2, 6), Nothing) + + it "coordCartesian は X/Y 両 lim を合成する" $ + ( getLast (vsCoordXLim (coordCartesian 2 6 0 40)) + , getLast (vsCoordYLim (coordCartesian 2 6 0 40)) ) + `shouldBe` (Just (2, 6), Just (0, 40)) + + it "zoom 範囲の下端/上端が panel 左/右端に張り付く (domain 上書き)" $ + ( abs (scaleApply (lpXScale zoom) 2 - rX a) < 1e-6 + , abs (scaleApply (lpXScale zoom) 6 - (rX a + rW a)) < 1e-6 ) + `shouldBe` (True, True) + + it "窓外データ (x=0) は panel 左端より外に投影される (= clip 対象)" $ + (scaleApply (lpXScale zoom) 0 < rX a) `shouldBe` True + + it "データは落とさない (zoom でも 11 点すべて PCircle が出る)" $ + let ps = renderToPrimitives emptyResolver zoom (spec (coordCartesian 2 6 0 40)) + in length [() | PCircle{} <- ps] `shouldBe` 11 + + it "zoom 時は glyph を panel に clip (PClipPush/PClipPop が発行される)" $ + let ps = renderToPrimitives emptyResolver zoom (spec (coordCartesian 2 6 0 40)) + in ( length [() | PClipPush{} <- ps], length [() | PClipPop <- ps] ) + `shouldBe` (1, 1) + + it "zoom 無指定なら clip プリミティブは出ない (従来同一)" $ + let l = mk mempty + ps = renderToPrimitives emptyResolver l (spec mempty) + in length [() | PClipPush{} <- ps] `shouldBe` 0 + + -- ========================================================================= + -- Phase 11 A7-b: facet free scales (panel ごと独立 domain) + -- ========================================================================= + describe "facet free scales (Phase 11 A7-b)" $ do + -- 2 群 A/B で y のスケールが大きく違う (A: 1..2, B: 100..200)。 + let facetRes nm = case nm of + "x" -> Just (NumData (V.fromList [1, 2, 1, 2])) + "y" -> Just (NumData (V.fromList [1, 2, 100, 200])) + "g" -> Just (TxtData (V.fromList ["A", "A", "B", "B"])) + _ -> Nothing + baseSpec = layer (scatter "x" "y" <> colorBy "g") <> facet "g" + renderWith extra = + let s = baseSpec <> extra + in renderToPrimitives facetRes (computeLayout facetRes s) s + textCount ps = length [() | PText{} <- ps] + + it "facetScales setter は vsFacetScales を立てる" $ + getLast (vsFacetScales (facetScales FacetFree)) `shouldBe` Just FacetFree + + it "freeScaleX / freeScaleY の真理値表" $ + ( map freeScaleX [FacetFixed, FacetFreeX, FacetFreeY, FacetFree] + , map freeScaleY [FacetFixed, FacetFreeX, FacetFreeY, FacetFree] ) + `shouldBe` ( [False, True, False, True], [False, False, True, True] ) + + it "free scales は fixed より PText が多い (各 panel に独立 y 軸が出る)" $ + (textCount (renderWith (facetScales FacetFree)) > textCount (renderWith mempty)) + `shouldBe` True + + it "free-y は panel B の大きい値の tick ラベル (150) を含む" $ + let ps = renderWith (facetScales FacetFreeY) + texts = [t | PText _ t _ <- ps] + in elem "150" texts `shouldBe` True + + -- facet_grid free scales + space (列ごと x / 行ごと y 共有 domain) + let gridRes nm = case nm of + "x" -> Just (NumData (V.fromList [0, 1, 0, 10, 0, 1, 0, 10])) -- col L: 0..1, col R: 0..10 + "y" -> Just (NumData (V.fromList [1, 2, 1, 2, 100, 200, 100, 200])) -- row T: 1..2, row B: 100..200 + "c" -> Just (TxtData (V.fromList ["L", "L", "R", "R", "L", "L", "R", "R"])) + "r" -> Just (TxtData (V.fromList ["T", "T", "T", "T", "B", "B", "B", "B"])) + _ -> Nothing + gridSpec extra = layer (scatter "x" "y") <> facetGrid "r" "c" <> extra + renderGrid extra = + let s = gridSpec extra + in renderToPrimitives gridRes (computeLayout gridRes s) s + + it "facetSpace setter は vsFacetSpace を立てる" $ + getLast (vsFacetSpace (facetSpace SpaceFree)) `shouldBe` Just SpaceFree + + -- ★ Phase 34: tick ラベルは break ベクトル全体で小数桁統一 (formatTicksGG)。 + -- col R (0..10) の break は [0,2.5,5,7.5,10] ゆえ "10.0" (ggplot も "0.0|2.5|..|10.0")。 + it "facet_grid free-x は列ごとに x tick が異なる (col R の 10.0 が出る)" $ + let texts = [t | PText _ t _ <- renderGrid (facetScales FacetFreeX)] + in elem "10.0" texts `shouldBe` True + + it "facet_grid space free-x で列幅が x 範囲に比例 (R 列が L 列より広い)" $ + let psFree = renderGrid (facetScales FacetFreeX <> facetSpace SpaceFreeX) + -- 上 strip 背景帯 (col 名) の PRect は h = stripTopH(18)。 幅 = 列幅。 + -- col L (x 0..1) < col R (x 0..10) なので R が約 10 倍広い。 + stripWidths = [ w | PRect (Rect _ _ w h) _ _ <- psFree, abs (h - 18) < 0.01 ] + in case stripWidths of + (wL : wR : _) -> (wR > wL * 5) `shouldBe` True + _ -> expectationFailure "col strip 幅が 2 つ取れない" + + -- ========================================================================= + -- Phase 11 A7-c: coord_polar (極座標投影) + -- ========================================================================= + describe "coord_polar (Phase 11 A7-c)" $ do + let lay = computeLayout emptyResolver + (overlay [points [0, 1, 2, 3] [0, 1, 2, 3]] <> coordPolar) + (ccx, ccy, cmaxR) = polarCenter lay + + it "coordPolar setter は vsCoord = CoordPolarX を立てる" $ + getLast (vsCoord coordPolar) `shouldBe` Just CoordPolarX + + it "coordPolarY setter は vsCoord = CoordPolarY を立てる" $ + getLast (vsCoord coordPolarY) `shouldBe` Just CoordPolarY + + it "isPolar: polar のみ True" $ + map isPolar [CoordCartesian, CoordFlip, CoordPolarX, CoordPolarY] + `shouldBe` [False, False, True, True] + + it "polarPoint: r=0 は中心、 θ=0 r=1 は真上 (cx, cy-maxR)" $ + let (x0, y0) = polarPoint lay 0 0 + (xt, yt) = polarPoint lay 0 1 + in ( abs (x0 - ccx) < 1e-9 && abs (y0 - ccy) < 1e-9 + , abs (xt - ccx) < 1e-9 && abs (yt - (ccy - cmaxR)) < 1e-9 ) + `shouldBe` (True, True) + + it "polarPoint: θ=0.25 (= 90°) r=1 は右 (cx+maxR, cy)" $ + let (xr, yr) = polarPoint lay 0.25 1 + in ( abs (xr - (ccx + cmaxR)) < 1e-6, abs (yr - ccy) < 1e-6 ) + `shouldBe` (True, True) + + it "polar の grid は同心円 (PCircle) を含む (直交 grid line でなく円)" $ + let ps = renderToPrimitives emptyResolver lay + (overlay [points [0, 1, 2, 3] [0, 1, 2, 3]] <> coordPolar) + in (length [() | PCircle{} <- ps] > 0) `shouldBe` True + + it "polar + bar は扇形 (PPath) を bar の数だけ出す" $ + let s = layer (bars [1, 2, 3, 4] [4, 7, 5, 9]) <> coordPolar + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver s) s + in length [() | PPath{} <- ps] `shouldBe` 4 + + -- ========================================================================= + -- Phase 11 A4-b: linetype aesthetic (固定 + categorical 群分け) + -- ========================================================================= + describe "linetype (Phase 11 A4-b)" $ do + it "lineTypeDash: Solid=[] / Dashed=[4,4]" $ + (lineTypeDash LtSolid, lineTypeDash LtDashed) `shouldBe` ([], [4, 4]) + + it "lineTypeForIndex 巡回: 0=Solid, 1=Dashed, 6=Solid" $ + (lineTypeForIndex 0, lineTypeForIndex 1, lineTypeForIndex 6) + `shouldBe` (LtSolid, LtDashed, LtSolid) + + it "linetype setter は lyLinetype を立てる" $ + getLast (lyLinetype (linetype LtDashed)) `shouldBe` Just LtDashed + + it "line + linetype LtDashed で線分 (3点=2本) の lsDash が [4,4]" $ + let spec = layer (line (inline [0, 1, 2 :: Double]) (inline [0, 1, 2 :: Double]) + <> linetype LtDashed) + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver spec) spec + in length [ () | PLine _ _ (LineStyle _ _ d) <- ps, d == [4, 4] ] `shouldBe` 2 + + it "linetypeBy で群 B (3点=2本) のみ dashed、 群 A は実線" $ + let spec = layer (line (inline [0, 1, 2, 0, 1, 2 :: Double]) + (inline [0, 1, 2, 3, 4, 5 :: Double]) + <> linetypeBy (inlineCat (["A", "A", "A", "B", "B", "B"] :: [Data.Text.Text]))) + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver spec) spec + in length [ () | PLine _ _ (LineStyle _ _ d) <- ps, d == [4, 4] ] `shouldBe` 2 + + -- ========================================================================= + -- Phase 11 A4-c: legendTitle (= scale name / labs(color=)) + -- ========================================================================= + describe "legendTitle (Phase 11 A4-c)" $ do + it "legendTitle setter は vsLegendTitle を立てる" $ + getLast (vsLegendTitle (legendTitle "Series")) `shouldBe` Just (Data.Text.pack "Series") + + it "未指定なら vsLegendTitle = Nothing (= 従来通り凡例タイトル非表示)" $ + getLast (vsLegendTitle (mempty :: VisualSpec)) `shouldBe` Nothing + + it "legendTitle 指定で凡例に PText 'Series' が出る (color group + legend)" $ + let res k = case k of + "x" -> Just (NumData (V.fromList [0, 1, 2, 3 :: Double])) + "y" -> Just (NumData (V.fromList [0, 1, 2, 3 :: Double])) + "g" -> Just (TxtData (V.fromList ["A", "A", "B", "B"])) + _ -> Nothing + spec = layer (scatter (ColByName "x") (ColByName "y") <> colorBy (ColByName "g")) + <> legend <> legendTitle "Series" + ps = renderToPrimitives res (computeLayout res spec) spec + in any (\p -> case p of PText _ t _ -> t == Data.Text.pack "Series"; _ -> False) ps + `shouldBe` True + + -- ========================================================================= + -- Phase 11 A4-d: 明示 breaks / labels (= ggplot scale_*_continuous(breaks=,labels=)) + -- ========================================================================= + describe "explicit breaks/labels (Phase 11 A4-d)" $ do + let res k = case k of + "x" -> Just (NumData (V.fromList [0, 100 :: Double])) + "y" -> Just (NumData (V.fromList [0, 100 :: Double])) + _ -> Nothing + baseSpec extra = layer (scatter (ColByName "x") (ColByName "y")) <> extra + + it "axisBreaksAt setter は axTickVals を立てる" $ + axTickValsOf (Last (Just (axisBreaksAt [0, 25, 50]))) `shouldBe` [0, 25, 50] + + it "axisBreaksLabeled は axTickVals/axTickLabels を対で立てる" $ + let as = axisBreaksLabeled [(0, "lo"), (50, "mid"), (100, "hi")] + in ( axTickValsOf (Last (Just as)) + , axTickLabelsOf (Last (Just as)) ) + `shouldBe` ([0, 50, 100], map Data.Text.pack ["lo", "mid", "hi"]) + + it "axisBreaksAt で lpXTicks が明示値に上書きされる (範囲内のみ)" $ + let spec = baseSpec (xAxis (axisBreaksAt [0, 25, 50, 75, 100])) + l = computeLayout res spec + in lpXTicks l `shouldBe` [0, 25, 50, 75, 100] + + it "範囲外の break は censor される" $ + -- padded range は概ね [-5,105] なので 200 は落ちる + let spec = baseSpec (xAxis (axisBreaksAt [0, 50, 200])) + l = computeLayout res spec + in lpXTicks l `shouldBe` [0, 50] + + it "axisBreaksLabeled で lpXTickLabels が整列して入る" $ + let spec = baseSpec (xAxis (axisBreaksLabeled [(0, "lo"), (50, "mid"), (100, "hi")])) + l = computeLayout res spec + in (lpXTicks l, lpXTickLabels l) + `shouldBe` ([0, 50, 100], map Data.Text.pack ["lo", "mid", "hi"]) + + it "breaks のみ (labels 無し) なら lpXTickLabels は空 (= 値 format に委ねる)" $ + let spec = baseSpec (xAxis (axisBreaksAt [0, 50, 100])) + l = computeLayout res spec + in lpXTickLabels l `shouldBe` [] + + it "未指定なら従来通り (lpXTickLabels 空・auto tick)" $ + let l = computeLayout res (baseSpec mempty) + in lpXTickLabels l `shouldBe` [] + + it "明示ラベルが render の tick PText に出る" $ + let spec = baseSpec (xAxis (axisBreaksLabeled [(0, "start"), (100, "end")])) + ps = renderToPrimitives res (computeLayout res spec) spec + hasTxt s = any (\p -> case p of PText _ t _ -> t == Data.Text.pack s; _ -> False) ps + in (hasTxt "start", hasTxt "end") `shouldBe` (True, True) + + -- ========================================================================= + -- Phase 11 A4-e: 色/サイズ scale 拡充 (manual / gradient2 / size) + -- ========================================================================= + describe "color/size scales (Phase 11 A4-e)" $ do + let circFills ps = [ c | PCircle _ _ (FillStyle c _) _ _ <- ps ] + circRadii ps = [ rad | PCircle _ rad _ _ _ <- ps ] + tp s = Data.Text.pack s + + it "scaleColorManual setter は vsColorManual を立てる" $ + getLast (vsColorManual (scaleColorManual [(tp "A", tp "#ff0000")])) + `shouldBe` Just [(tp "A", tp "#ff0000")] + + it "scaleColorGradient2 setter は vsColorGradient2 を立てる" $ + getLast (vsColorGradient2 (scaleColorGradient2 (tp "#00f") (tp "#fff") (tp "#f00") 0.0)) + `shouldBe` Just (tp "#00f", tp "#fff", tp "#f00", 0.0) + + it "scaleSize setter は vsSizeRange を立てる" $ + getLast (vsSizeRange (scaleSize 2 12)) `shouldBe` Just (2, 12) + + it "scaleColorManual で該当カテゴリが指定色になる (未登録は palette)" $ + let res k = case k of + "x" -> Just (NumData (V.fromList [0, 1, 2, 3 :: Double])) + "y" -> Just (NumData (V.fromList [0, 1, 2, 3 :: Double])) + "g" -> Just (TxtData (V.fromList ["A", "A", "B", "B"])) + _ -> Nothing + spec = layer (scatter (ColByName "x") (ColByName "y") <> colorBy (ColByName "g")) + <> scaleColorManual [(tp "A", tp "#123456"), (tp "B", tp "#abcdef")] + fills = circFills (renderToPrimitives res (computeLayout res spec) spec) + -- 先頭 4 = データ点、 末尾 2 = 凡例 swatch。 両方とも manual 色 (= 凡例と panel が一致)。 + in fills `shouldBe` map tp ["#123456", "#123456", "#abcdef", "#abcdef", "#123456", "#abcdef"] + + it "scaleColorGradient2 で midpoint 値が mid 色になる" $ + let res k = case k of + "x" -> Just (NumData (V.fromList [0, 1, 2 :: Double])) + "y" -> Just (NumData (V.fromList [0, 1, 2 :: Double])) + "z" -> Just (NumData (V.fromList [-1, 0, 1 :: Double])) -- midpoint 0 が中央 + _ -> Nothing + spec = layer (scatter (ColByName "x") (ColByName "y") <> colorContinuousBy (ColByName "z")) + <> scaleColorGradient2 (tp "#0000ff") (tp "#ffffff") (tp "#ff0000") 0.0 + fills = circFills (renderToPrimitives res (computeLayout res spec) spec) + in (fills !! 1) `shouldBe` tp "#ffffff" -- z=0 (midpoint) → mid 色 (白) + + it "scaleSize で sizeBy の直径範囲が指定値になる (★Phase 34 A3: size=直径ゆえ半径=直径/2)" $ + let res k = case k of + "x" -> Just (NumData (V.fromList [0, 1, 2 :: Double])) + "y" -> Just (NumData (V.fromList [0, 1, 2 :: Double])) + "s" -> Just (NumData (V.fromList [10, 20, 30 :: Double])) + _ -> Nothing + spec = layer (scatter (ColByName "x") (ColByName "y") <> sizeBy (ColByName "s")) + <> scaleSize 4 16 + radii = circRadii (renderToPrimitives res (computeLayout res spec) spec) + in (minimum radii, maximum radii) `shouldBe` (2, 8) -- 直径範囲 (4,16) → 半径 (2,8) + + -- ========================================================================= + -- Phase 19: color 凡例整合 (glyph 色と凡例 swatch が同じ正本を参照する) + -- ========================================================================= + describe "Phase 19: color 凡例整合" $ do + let circFills ps = [ c | PCircle _ _ (FillStyle c _) _ _ <- ps ] + tp = Data.Text.pack + + -- A1 再現: `<>` 重畳の ColorByCol で glyph が layer 内 nub、 凡例が全 layer + -- union を引いてズレる。 layer2 ("C" のみ) の glyph は凡例 "C" swatch と + -- 同色でなければならない (旧バグ: palette 先頭 = 凡例 "A" の色になる)。 + it "重畳 ColorByCol レイヤの glyph 色 = 凡例 swatch 色 (A1)" $ + let res k = case k of + "x1" -> Just (NumData (V.fromList [0, 1 :: Double])) + "y1" -> Just (NumData (V.fromList [0, 1 :: Double])) + "g1" -> Just (TxtData (V.fromList ["A", "B"])) + "x2" -> Just (NumData (V.fromList [2 :: Double])) + "y2" -> Just (NumData (V.fromList [2 :: Double])) + "g2" -> Just (TxtData (V.fromList ["C"])) + _ -> Nothing + spec = layer (scatter (ColByName "x1") (ColByName "y1") <> colorBy (ColByName "g1")) + <> layer (scatter (ColByName "x2") (ColByName "y2") <> colorBy (ColByName "g2")) + fills = circFills (renderToPrimitives res (computeLayout res spec) spec) + -- 円 6 個 = data (A,B,C) + 凡例 swatch (A,B,C union 順) + in (length fills, fills !! 2 == fills !! 5, fills !! 2 /= fills !! 3) + `shouldBe` (6, True, True) + + it "単一 ColorByCol layer は従来配色のまま (glyph = 凡例・回帰)" $ + let res k = case k of + "x" -> Just (NumData (V.fromList [0, 1, 2 :: Double])) + "y" -> Just (NumData (V.fromList [0, 1, 2 :: Double])) + "g" -> Just (TxtData (V.fromList ["A", "B", "A"])) + _ -> Nothing + spec = layer (scatter (ColByName "x") (ColByName "y") <> colorBy (ColByName "g")) + fills = circFills (renderToPrimitives res (computeLayout res spec) spec) + -- data (A,B,A) + 凡例 (A,B): glyph と凡例が対応し、 A 2 点は同色 + in (length fills, fills !! 0 == fills !! 3, fills !! 1 == fills !! 4, + fills !! 0 == fills !! 2, fills !! 0 /= fills !! 1) + `shouldBe` (5, True, True, True, True) + + -- A2 再現: bar + ColorByCol が PosIdentity で無条件 renderBarSimple (単色) + -- に落ち、 本体単色なのに凡例は palette swatch を並べる。 + it "bar PosIdentity + ColorByCol で本体が色分けされ凡例と一致 (A2)" $ + let res k = case k of + "x" -> Just (TxtData (V.fromList ["a", "b"])) + "y" -> Just (NumData (V.fromList [1, 2 :: Double])) + "g" -> Just (TxtData (V.fromList ["A", "B"])) + _ -> Nothing + spec = layer (bar (ColByName "x") (ColByName "y") <> colorBy (ColByName "g")) + prims = renderToPrimitives res (computeLayout res spec) spec + -- 背景 PRect (#ffffff) と凡例キー背景 (grey95 #f2f2f2・Phase 34) を除外し + -- bar 本体 + 凡例 swatch のみ拾う + rectFills = [ c | PRect _ (FillStyle c _) _ <- prims + , c /= tp "#ffffff", c /= tp "#f2f2f2" ] + -- PRect = bar 本体 (A,B) + 凡例 swatch (A,B)。 本体 2 色が分かれ、 + -- 凡例 swatch と pairwise 一致する + in (length rectFills, rectFills !! 0 == rectFills !! 2, + rectFills !! 1 == rectFills !! 3, rectFills !! 0 /= rectFills !! 1) + `shouldBe` (4, True, True, True) + + -- Phase 30 A3: 固定 shape combinator (bare=固定・shapeBy より優先) + it "shape s は固定で全点に適用され shapeBy より優先 (A3)" $ + let ly = scatter (ColByName "x") (ColByName "y") + <> shape MShTriangle <> shapeBy (ColByName "g") + in pointShapeAt ly emptyResolver 0 `shouldBe` MShTriangle + it "shape 未指定かつ shapeBy なしは MShCircle (A3)" $ + let ly = scatter (ColByName "x") (ColByName "y") + in pointShapeAt ly emptyResolver 0 `shouldBe` MShCircle + + -- A2 はみ出し fix: 旧実装は categorical x を row index (0..n-1) に置いて + -- おり、 カテゴリ重複行が x domain を超えて plot 域外に描かれていた。 + -- cat index 配置で重複行は同 slot に重ね描き (ggplot identity 同型)。 + it "bar categorical x の重複行が plot 域内 (cat index 配置・A2)" $ + let res k = case k of + "x" -> Just (TxtData (V.fromList ["a", "b", "a"])) + "y" -> Just (NumData (V.fromList [1, 2, 3 :: Double])) + _ -> Nothing + spec = layer (bar (ColByName "x") (ColByName "y")) + lay = computeLayout res spec + area = lpPlotArea lay + rects = [ rc | PRect rc (FillStyle c _) _ + <- renderToPrimitives res lay spec + , c /= tp "#ffffff" ] + in (length rects, + all (\rc -> rX rc + rW rc <= rX area + rW area + 1e-9) rects, + rX (rects !! 0) == rX (rects !! 2)) -- 重複 cat "a" は同 slot + `shouldBe` (3, True, True) + + it "bar PosIdentity + ColorStatic は従来単色のまま (回帰)" $ + let res k = case k of + "x" -> Just (TxtData (V.fromList ["a", "b"])) + "y" -> Just (NumData (V.fromList [1, 2 :: Double])) + _ -> Nothing + spec = layer (bar (ColByName "x") (ColByName "y") + <> color (fromHex "#336699")) + prims = renderToPrimitives res (computeLayout res spec) spec + rectFills = [ c | PRect _ (FillStyle c _) _ <- prims, c /= tp "#ffffff" ] + in rectFills `shouldBe` [tp "#336699", tp "#336699"] + + -- ========================================================================= + -- Phase 11 A5-a: labs サブシステム (subtitle / caption / tag + labs まとめ setter) + -- ========================================================================= + describe "labs (Phase 11 A5-a)" $ do + let tp = Data.Text.pack + textsOf ps = [ t | PText _ t _ <- ps ] + + it "subtitle / caption / tag setter は各 field を立てる" $ + ( getLast (vsSubtitle (subtitle (tp "sub"))) + , getLast (vsCaption (caption (tp "cap"))) + , getLast (vsTag (tag (tp "T"))) ) + `shouldBe` (Just (tp "sub"), Just (tp "cap"), Just (tp "T")) + + it "labs まとめ setter は指定した label だけ合成する" $ + let s = labs emptyLabs { labsTitle = Just (tp "ti"), labsSubtitle = Just (tp "su") + , labsCaption = Just (tp "ca"), labsTag = Just (tp "tg") + , labsX = Just (tp "xx"), labsY = Just (tp "yy") + , labsColor = Just (tp "co") } + in ( getLast (vsTitle s), getLast (vsSubtitle s), getLast (vsCaption s) + , getLast (vsTag s), getLast (vsXLabel s), getLast (vsYLabel s) + , getLast (vsLegendTitle s) ) + `shouldBe` ( Just (tp "ti"), Just (tp "su"), Just (tp "ca") + , Just (tp "tg"), Just (tp "xx"), Just (tp "yy"), Just (tp "co") ) + + it "subtitle / caption / tag は描画され PText に出る" $ + let res k = case k of + "x" -> Just (NumData (V.fromList [0, 1, 2 :: Double])) + "y" -> Just (NumData (V.fromList [0, 1, 2 :: Double])) + _ -> Nothing + spec = layer (scatter (ColByName "x") (ColByName "y")) + <> title (tp "T") <> subtitle (tp "sub") <> caption (tp "cap") <> tag (tp "G") + ts = textsOf (renderToPrimitives res (computeLayout res spec) spec) + in all (`elem` ts) (map tp ["T", "sub", "cap", "G"]) `shouldBe` True + + -- ========================================================================= + -- Phase 11 A5-c: guides (reverse / ncol / nrow + guideColorNone) + -- ========================================================================= + describe "guides (Phase 11 A5-c)" $ do + let tp = Data.Text.pack + gres k = case k of + "x" -> Just (NumData (V.fromList [0, 1, 2, 3 :: Double])) + "y" -> Just (NumData (V.fromList [0, 1, 2, 3 :: Double])) + "g" -> Just (TxtData (V.fromList ["A", "A", "B", "B"])) + _ -> Nothing + legendTexts spec = + [ (t, py) | PText (Point _ py) t _ <- renderToPrimitives gres (computeLayout gres spec) spec + , t `elem` map tp ["A", "B"] ] + baseSpec = layer (scatter (ColByName "x") (ColByName "y") <> colorBy (ColByName "g")) + + it "legendReverse / legendNcol / legendNrow setter が各 field を立てる" $ + ( getLast (vsLegendReverse legendReverse) + , getLast (vsLegendNcol (legendNcol 2)) + , getLast (vsLegendNrow (legendNrow 3)) ) + `shouldBe` (Just True, Just 2, Just 3) + + it "guideColorNone は色凡例を消す (= 凡例テキスト無し)" $ + let spec = baseSpec <> legend <> guideColorNone + in legendTexts spec `shouldBe` [] + + it "legendReverse でキー順が逆になる (A が下、 B が上)" $ + let spec = baseSpec <> legend <> legendReverse + ys = [ py | (lbl, py) <- legendTexts spec, lbl == tp "A" || lbl == tp "B" ] + yA = head [ py | (lbl, py) <- legendTexts spec, lbl == tp "A" ] + yB = head [ py | (lbl, py) <- legendTexts spec, lbl == tp "B" ] + in (yB < yA, length ys) `shouldBe` (True, 2) + + it "legendReverse 無しは従来順 (A が上、 B が下)" $ + let spec = baseSpec <> legend + yA = head [ py | (lbl, py) <- legendTexts spec, lbl == tp "A" ] + yB = head [ py | (lbl, py) <- legendTexts spec, lbl == tp "B" ] + in (yA < yB) `shouldBe` True + + -- ========================================================================= + -- Phase 11 A6: geom_text / geom_label (データ駆動ラベル) + -- ========================================================================= + describe "text / label (Phase 11 A6)" $ do + let tp = Data.Text.pack + gres k = case k of + "x" -> Just (NumData (V.fromList [1, 2, 3 :: Double])) + "y" -> Just (NumData (V.fromList [1, 2, 3 :: Double])) + "l" -> Just (TxtData (V.fromList ["a", "b", "c"])) + _ -> Nothing + textsOf ps = [ t | PText _ t _ <- ps ] + rectsOf ps = [ r | r@PRect{} <- ps ] + + it "text は MText + lyLabel を立てる" $ + let ly = text (ColByName "x") (ColByName "y") (ColByName "l") + in (getFirst (lyKind ly), getLast (lyLabel ly)) + `shouldBe` (Just MText, Just (ColByName "l")) + + it "text で各点に label 列の文字が出る" $ + let spec = layer (text (ColByName "x") (ColByName "y") (ColByName "l")) + ts = textsOf (renderToPrimitives gres (computeLayout gres spec) spec) + in all (`elem` ts) (map tp ["a", "b", "c"]) `shouldBe` True + + it "label は文字 + 背景矩形 (各点) を出す" $ + let spec = layer (label (ColByName "x") (ColByName "y") (ColByName "l")) + prims = renderToPrimitives gres (computeLayout gres spec) spec + ts = textsOf prims + -- 背景矩形 (label box) = panel 背景/枠 を除いた幅の狭い矩形が 3 個 + boxes = [ () | PRect (Rect _ _ w _) _ _ <- prims, w < 100 ] + in (all (`elem` ts) (map tp ["a", "b", "c"]), length boxes) `shouldBe` (True, 3) + + -- ========================================================================= + -- Phase 11 A6-2: Q-Q plot (geom_qq) + -- ========================================================================= + describe "qq (Phase 11 A6-2)" $ do + let sres k = case k of + "s" -> Just (NumData (V.fromList [3.0, 1.0, 4.0, 1.5, 5.0, 9.0, 2.0])) + _ -> Nothing + circlesOf ps = [ (cx, cy) | PCircle (Point cx cy) _ _ _ _ <- ps ] + + it "qq は MQQ + encY を立てる (encX は持たない)" $ + let ly = qq (ColByName "s") + in (getFirst (lyKind ly), getLast (lyEncY ly), getLast (lyEncX ly)) + `shouldBe` (Just MQQ, Just (ColByName "s"), Nothing) + + it "invNormCdf は対称で中央が 0 (Φ⁻¹(0.5)=0, Φ⁻¹(0.975)≈1.96)" $ + let mid = abs (invNormCdf 0.5) < 1e-9 + sym = abs (invNormCdf 0.975 + invNormCdf 0.025) < 1e-6 + z975 = abs (invNormCdf 0.975 - 1.959964) < 1e-4 + in (mid, sym, z975) `shouldBe` (True, True, True) + + it "qqPoints は y を昇順 (order statistic) に並べ x も単調増加" $ + let pts = qqPoints [3.0, 1.0, 4.0, 1.5, 5.0] + ys = map snd pts + xs = map fst pts + asc zs = and (zipWith (<=) zs (drop 1 zs)) + in (ys, asc ys, asc xs) `shouldBe` ([1.0, 1.5, 3.0, 4.0, 5.0], True, True) + + it "qq で sample 点数ぶんの円が出る (= 7 個)" $ + let spec = layer (qq (ColByName "s")) + ps = renderToPrimitives sres (computeLayout sres spec) spec + in length (circlesOf ps) `shouldBe` 7 + + -- ========================================================================= + -- Phase 11 A6-3: heatmap (geom_tile) + -- ========================================================================= + describe "heatmap (Phase 11 A6-3)" $ do + -- 2×2 grid (long-form): (A,P)=1 (A,Q)=2 (B,P)=3 (B,Q)=4 + let hres k = case k of + "hx" -> Just (TxtData (V.fromList ["A", "A", "B", "B"])) + "hy" -> Just (TxtData (V.fromList ["P", "Q", "P", "Q"])) + "hv" -> Just (NumData (V.fromList [1.0, 2.0, 3.0, 4.0])) + _ -> Nothing + -- セル矩形 = 連続色塗りの矩形 (白の panel/canvas 背景・h=3.5 の凡例 strip を除外) + cellRects ps = [ () | PRect (Rect _ _ w h) (FillStyle f _) _ <- ps + , w > 50, h > 50, f /= "#ffffff" ] + + it "heatmap は MHeatmap + encX/encY + ColorByContinuous を立てる" $ + let ly = heatmap (ColByName "hx") (ColByName "hy") (ColByName "hv") + isContinuous = case getLast (lyColor ly) of + Just (ColorByContinuous (ColByName "hv")) -> True + _ -> False + in ( getFirst (lyKind ly) + , getLast (lyEncX ly), getLast (lyEncY ly), isContinuous ) + `shouldBe` ( Just MHeatmap, Just (ColByName "hx") + , Just (ColByName "hy"), True ) + + it "heatmap で grid セル数ぶんの矩形が出る (= 4 個)" $ + let spec = layer (heatmap (ColByName "hx") (ColByName "hy") (ColByName "hv")) + ps = renderToPrimitives hres (computeLayout hres spec) spec + in length (cellRects ps) `shouldBe` 4 + + -- ========================================================================= + -- contour (= 等高線図、 marching squares) + -- ========================================================================= + describe "contour (等高線、 marching squares)" $ do + -- 連続 x/y/z (5×5 grid = 25 点)、 z = x+y。 等値線を描く。 + let grid = [ (x, y) | x <- [0.0, 1.0, 2.0, 3.0, 4.0], y <- [0.0, 1.0, 2.0, 3.0, 4.0] ] + cres k = case k of + "cx" -> Just (NumData (V.fromList (map fst grid))) + "cy" -> Just (NumData (V.fromList (map snd grid))) + "cz" -> Just (NumData (V.fromList (map (\(x,y) -> x + y) grid))) + _ -> Nothing + -- 旧 binned heatmap のセル矩形 (白 0.3px 枠)。 等高線化で出なくなったことを確認。 + cellRectsC ps = [ () | PRect _ (FillStyle f _) (Just (StrokeStyle sc sw)) <- ps + , f /= "#ffffff", sc == "#ffffff", sw == 0.3 ] + + it "contour は MContour + encX/encY + ColorByContinuous を立てる" $ + let ly = contour (ColByName "cx") (ColByName "cy") (ColByName "cz") + isCont = case getLast (lyColor ly) of + Just (ColorByContinuous (ColByName "cz")) -> True + _ -> False + in (getFirst (lyKind ly), getLast (lyEncX ly), getLast (lyEncY ly), isCont) + `shouldBe` (Just MContour, Just (ColByName "cx"), Just (ColByName "cy"), True) + + it "contour は等値線 (PLine) を描き、 binned heatmap の塗り矩形は出さない" $ + let spec = layer (contour (ColByName "cx") (ColByName "cy") (ColByName "cz")) + ps = renderToPrimitives cres (computeLayout cres spec) spec + nLines = length [ () | PLine{} <- ps ] + -- 等高線は多数の線分、 旧 binned heatmap の塗り矩形は 0。 + in (cellRectsC ps == [], nLines > 30) `shouldBe` (True, True) + + -- ========================================================================= + -- Phase 11 A6-4: ECDF (stat_ecdf) + -- ========================================================================= + describe "ecdf (Phase 11 A6-4)" $ do + let eres k = case k of + "es" -> Just (NumData (V.fromList [3.0, 1.0, 4.0, 1.0, 5.0])) + _ -> Nothing + linesOf ps = [ () | PLine{} <- ps ] + + it "ecdf は MEcdf + encX を立てる (encY は持たない)" $ + let ly = ecdf (ColByName "es") + in (getFirst (lyKind ly), getLast (lyEncX ly), getLast (lyEncY ly)) + `shouldBe` (Just MEcdf, Just (ColByName "es"), Nothing) + + it "ecdfPoints は右連続の階段頂点を返す (n=4 → (x1,0) から始まり 2n 頂点)" $ + let pts = ecdfPoints [3.0, 1.0, 4.0, 2.0] + ys = map snd pts + in (length pts, head pts, last ys) `shouldBe` (8, (1.0, 0.0), 1.0) + + it "ecdf の階段は 2n-1 本の線分 (n=5 → 9 本、 grid は別ストローク)" $ + let spec = layer (ecdf (ColByName "es")) + ps = renderToPrimitives eres (computeLayout eres spec) spec + -- ecdf 線は default 色 (grid は pal.axis)。 default 色の線分のみ数える。 + ecLines = [ () | PLine _ _ (LineStyle col _ _) <- ps, col == "#1f77b4" ] + in length ecLines `shouldBe` 9 + + -- ========================================================================= + -- Phase 11 A6-4b: 区間 geom (linerange / pointrange / crossbar) + -- ========================================================================= + describe "linerange / pointrange / crossbar (Phase 11 A6-4b)" $ do + let rres k = case k of + "rx" -> Just (NumData (V.fromList [1.0, 2.0, 3.0])) + "ry" -> Just (NumData (V.fromList [3.0, 4.0, 5.0])) + "re" -> Just (NumData (V.fromList [0.5, 0.6, 0.4])) + _ -> Nothing + render s = renderToPrimitives rres (computeLayout rres s) s + circlesN ps = length [() | PCircle{} <- ps] + rangeLines ps = length [() | PLine _ _ (LineStyle col _ _) <- ps, col == "#1f77b4"] + -- Phase 41: crossbar 箱幅はデータ単位 (≈0.9×catUnitPx) になり px 固定 20px から + -- 広がった (x=[1,2,3] で ≈139px)。 上限を 60→300 に緩め panel 等の全幅矩形だけ除外。 + cellRectsR ps = length [() | PRect (Rect _ _ w _) (FillStyle f _) _ <- ps + , w < 300, w > 2, f == "#1f77b4"] + + it "lineRange は MLineRange + x/y/errorY を立てる" $ + let ly = lineRange (ColByName "rx") (ColByName "ry") (ColByName "re") + in (getFirst (lyKind ly), getLast (lyEncX ly), getLast (lyEncY ly), getLast (lyErrorY ly)) + `shouldBe` (Just MLineRange, Just (ColByName "rx"), Just (ColByName "ry"), Just (ColByName "re")) + + it "linerange は 3 本の縦線・点無し" $ + let ps = render (layer (lineRange (ColByName "rx") (ColByName "ry") (ColByName "re"))) + in (rangeLines ps, circlesN ps) `shouldBe` (3, 0) + + it "pointrange は 3 本の縦線 + 3 中心点" $ + let ps = render (layer (pointRange (ColByName "rx") (ColByName "ry") (ColByName "re"))) + in (rangeLines ps, circlesN ps) `shouldBe` (3, 3) + + it "crossbar は 3 箱 + 3 中央水平線" $ + let ps = render (layer (crossbar (ColByName "rx") (ColByName "ry") (ColByName "re"))) + in (cellRectsR ps, rangeLines ps) `shouldBe` (3, 3) + + -- Phase 41: resolutionOf (ggplot resolution(x) = 最小正間隔)。 cap データ単位化の基準。 + describe "resolutionOf (Phase 41)" $ do + it "等間隔グリッドは間隔を返す" $ + resolutionOf [0, 2, 4, 6] `shouldBe` 2.0 + it "categorical 整数位置は 1" $ + resolutionOf [0, 1, 2, 3] `shouldBe` 1.0 + it "単一値は 1 (間隔なし)" $ + resolutionOf [5, 5, 5] `shouldBe` 1.0 + it "不揃いは最小正間隔" $ + resolutionOf [0, 1, 3, 3.5] `shouldBe` 0.5 + it "空は 1" $ + resolutionOf [] `shouldBe` 1.0 + + -- ========================================================================= + -- Phase 11 A6-4c: stat_function (関数サンプリング → inline line) + -- ========================================================================= + describe "statFunction (Phase 11 A6-4c)" $ do + it "statFunction は f を n 点サンプルした inline line (MLine + ColNum) を作る" $ + let ly = statFunction (\x -> x * 2) 0.0 10.0 6 + in case (getFirst (lyKind ly), getLast (lyEncX ly), getLast (lyEncY ly)) of + (Just MLine, Just (ColNum xs), Just (ColNum ys)) -> + (V.toList xs, V.toList ys) + `shouldBe` ([0.0, 2.0, 4.0, 6.0, 8.0, 10.0], [0.0, 4.0, 8.0, 12.0, 16.0, 20.0]) + other -> expectationFailure ("unexpected: " <> show other) + + it "statFunction の n<2 は 2 に切り上げ (端点 2 点)" $ + let ly = statFunction (\x -> x) 1.0 5.0 1 + in case getLast (lyEncX ly) of + Just (ColNum xs) -> V.toList xs `shouldBe` [1.0, 5.0] + _ -> expectationFailure "encX should be inline ColNum" + + describe "Phase 16 stat-in (statLm / statSmooth)" $ do + it "statLm は MStatLM + encX/encY を持つ Layer" $ + case (getFirst (lyKind (statLm "x" "y")), getLast (lyEncX (statLm "x" "y")) + , getLast (lyEncY (statLm "x" "y"))) of + (Just MStatLM, Just _, Just _) -> True `shouldBe` True + other -> expectationFailure ("unexpected: " <> show other) + it "statSmooth は MStatSmooth + lyBinCount=n" $ + case (getFirst (lyKind (statSmooth "x" "y" 8)), getLast (lyBinCount (statSmooth "x" "y" 8))) of + (Just MStatSmooth, Just 8) -> True `shouldBe` True + other -> expectationFailure ("unexpected: " <> show other) + it "装飾が通常 geom と同じく Layer field に乗る (statLm <> stroke 2 <> colorStatic)" $ + let ly = statLm "x" "y" <> stroke 2 <> color (fromHex "#d62728") + in getLast (lyStroke ly) `shouldBe` Just 2 + it "renderer は未解決 MStat* を skip (band PPath = 0)" $ + let r n = case n of + "x" -> Just (NumData (V.fromList [1,2,3,4,5])) + "y" -> Just (NumData (V.fromList [2,4,6,8,10])) + _ -> Nothing + spec = layer (statLm "x" "y") + ps = renderToPrimitives r (computeLayout r spec) spec + in length [() | PPath{} <- ps] `shouldBe` 0 + + -- ========================================================================= + -- Phase 40 A3: hexbin binning core (hexbinCells = d3-hexbin) + -- ========================================================================= + describe "Phase 40 A3: hexbinCells (六角ビニング)" $ do + it "件数の総和 = 範囲内の点数 (件数保存)" $ + let pts = [ (x, y) | x <- [0.05, 0.15 .. 0.95], y <- [0.05, 0.15 .. 0.95] ] + cells = hexbinCells 6 (0, 1) (0, 1) pts + in sum (map hexCount cells) `shouldBe` length pts + it "同一座標の点は 1 セルに集約 (件数 = 点数)" $ + let cells = hexbinCells 8 (0, 1) (0, 1) (replicate 7 (0.5, 0.5)) + in (length cells, map hexCount cells) `shouldBe` (1, [7]) + it "各セルは 6 頂点 (pointy-top)" $ + let cells = hexbinCells 4 (0, 1) (0, 1) [(0.3, 0.3), (0.7, 0.8)] + in all ((== 6) . length . hexVerts) cells `shouldBe` True + it "退化入力 (bins<=0 / 空) は空" $ + (hexbinCells 0 (0,1) (0,1) [(0.5,0.5)], hexbinCells 5 (0,1) (0,1) []) + `shouldBe` ([], []) + + -- ========================================================================= + -- Phase 7 A7: gallery primitive count 回帰 test (golden) + -- 全 gallery spec を render し Primitive 本数を golden と突合。 1 chart を直すと + -- 別が静かに壊れる連鎖を機械検知する (目視に頼らない回帰検知の土台)。 + -- ========================================================================= + describe "gallery primitive count 回帰 (Phase 7 A7)" $ + it "全 gallery spec の primitive 本数が golden と一致" $ do + mGalleryDir <- findGalleryDir + case mGalleryDir of + -- fixture (design/gallery) 非同梱の環境 (公開ツリー等) では skip。 + Nothing -> pendingWith "design/gallery fixture が無い環境のため skip" + Just galleryDir -> do + actual <- galleryCountsString galleryDir + let goldenPath = galleryDir ++ "/primitive-counts.golden" + exists <- doesFileExist goldenPath + if not exists + then writeFile goldenPath actual + >> pendingWith "golden 初回生成 (次回実行から比較)" + else do golden <- readFile goldenPath + actual `shouldBe` golden + + + -- ========================================================================= + -- Phase 24 A4: contour バグ修正 (規則 grid 直入力) + griddata + level + filled + -- ========================================================================= + describe "Phase 24 A4: Griddata (規則 grid 検出 + k 近傍 IDW)" $ do + it "detectGrid: 規則 grid を補間なしで厳密復元 (行 = y)" $ + Griddata.detectGrid [ (x, y, x * 10 + y) | x <- [0, 1, 2], y <- [0, 1] ] + `shouldBe` Just ([0, 1, 2], [0, 1], [[0, 10, 20], [1, 11, 21]]) + it "detectGrid: 歯抜けの散布は Nothing (resampleKNN へ fallback)" $ + Griddata.detectGrid [(0, 0, 1), (1, 0, 2), (0, 1, 3)] `shouldBe` Nothing + it "resampleKNN: データ点と一致するノードはその z に収束 (局所重み)" $ + let (_, _, g) = Griddata.resampleKNN 4 3 3 [ (x, y, x + y) | x <- [0, 1, 2], y <- [0, 1, 2] ] + in abs ((g !! 0 !! 0) - 0) + abs ((g !! 2 !! 2) - 4) < 1e-6 `shouldBe` True + + describe "Phase 24 A4: contour level 指定 + filled contour" $ do + let gridPts = [ (x, y, x * x + y * y) | i <- [0 .. 10 :: Int], j <- [0 .. 10 :: Int] + , let x = -2 + 0.4 * fromIntegral i, let y = -2 + 0.4 * fromIntegral j ] + xs3 = [a | (a, _, _) <- gridPts]; ys3 = [b | (_, b, _) <- gridPts] + zs3 = [c | (_, _, c) <- gridPts] + mkSpec extra = layer (contour (inline xs3) (inline ys3) (inline zs3) <> extra) + primsOf spec = renderToPrimitives emptyResolver (computeLayout emptyResolver spec) spec + lineColors spec = Data.List.nub + [ c | PLine _ _ (LineStyle c _ _) <- primsOf spec, c /= tpA "#888888", c /= tpA "#bbbbbb" + , c /= tpA "#dddddd", c /= tpA "#444444", c /= tpA "#333333" ] + tpA = Data.Text.pack + it "既定 8 レベル (内側等間隔・クランプ廃止)" $ + length (lineColors (mkSpec mempty)) `shouldBe` 8 + it "contourLevels 4 で 4 レベル" $ + length (lineColors (mkSpec (contourLevels 4))) `shouldBe` 4 + it "contourBreaks [2] で 1 レベルのみ" $ + length (lineColors (mkSpec (contourBreaks [2]))) `shouldBe` 1 + it "contourFilled: 塗り PPath が出る (帯色 = level+1 種)" $ + let spec = layer (contourFilled (inline xs3) (inline ys3) (inline zs3) + <> contourLevels 4) + fills = Data.List.nub [ c | PPath _ (FillStyle c _) _ <- primsOf spec ] + in length fills `shouldBe` 5 + + describe "Math.Special: logGamma" $ do + it "logGamma 1 = 0 (Γ1=1)" $ abs (logGamma 1) < 1e-10 `shouldBe` True + it "logGamma 2 = 0 (Γ2=1)" $ abs (logGamma 2) < 1e-10 `shouldBe` True + it "logGamma 3 = ln 2" $ abs (logGamma 3 - log 2) < 1e-9 `shouldBe` True + it "logGamma 5 = ln 24" $ abs (logGamma 5 - log 24) < 1e-9 `shouldBe` True + it "logGamma 0.5 = ln √π" $ abs (logGamma 0.5 - log (sqrt pi)) < 1e-8 `shouldBe` True + + describe "Math.Special: regIncompleteBeta" $ do + it "I_x(1,1) = x (一様 CDF)" $ + all (\x -> abs (regIncompleteBeta 1 1 x - x) < 1e-9) [0.1,0.3,0.5,0.7,0.9] + `shouldBe` True + it "I_0.5(2,2) = 0.5 (対称)" $ abs (regIncompleteBeta 2 2 0.5 - 0.5) < 1e-9 `shouldBe` True + it "端点 I_0 = 0 / I_1 = 1" $ + (regIncompleteBeta 3 5 0 == 0 && regIncompleteBeta 3 5 1 == 1) `shouldBe` True + it "対称律 I_0.5(a,b) = 1 - I_0.5(b,a)" $ + abs (regIncompleteBeta 2 5 0.5 - (1 - regIncompleteBeta 5 2 0.5)) < 1e-10 `shouldBe` True + it "単調増加 (x↑ で I↑)" $ + let xs = [0.05,0.1..0.95] in + and (zipWith (<) (map (regIncompleteBeta 3 4) xs) (map (regIncompleteBeta 3 4) (tail xs))) + `shouldBe` True + + describe "Math.Special: betaQuantile" $ do + it "betaQuantile 0.5 1 1 = 0.5" $ abs (betaQuantile 0.5 1 1 - 0.5) < 1e-9 `shouldBe` True + it "betaQuantile 0.5 3 3 = 0.5 (対称)" $ abs (betaQuantile 0.5 3 3 - 0.5) < 1e-9 `shouldBe` True + it "逆関数往復 I(betaQuantile q) ≈ q" $ + all (\(q,a,b) -> abs (regIncompleteBeta a b (betaQuantile q a b) - q) < 1e-9) + [ (0.025,2,9), (0.5,5,5), (0.975,2,9), (0.1,1,1), (0.9,7,3) ] + `shouldBe` True + it "Benard 中央順位近似 (median ≈ (i-0.3)/(n+0.4))" $ + let n = 10 :: Int + ok i = abs (betaQuantile 0.5 (fromIntegral i) (fromIntegral (n-i+1)) + - (fromIntegral i - 0.3) / (fromIntegral n + 0.4)) < 0.01 + in all ok [1 .. n] `shouldBe` True + + where + isMissing (PlotError MissingAesthetic{} _) = True + isMissing _ = False + isNotFound (PlotError ColumnNotFound{} _) = True + isNotFound _ = False + isTypeMismatch (PlotError ColumnTypeMismatch{} _) = True + isTypeMismatch _ = False + isHoverWarn (PlotWarning (BackendUnsupported _ FeatHover) _) = True + isHoverWarn _ = False + +-- =========================================================================== +-- Phase 7 A7: gallery primitive count 回帰 test の helper (module level) +-- =========================================================================== + +-- | design/gallery/specs/**/*.json を全て render し、 case ごとの Primitive +-- constructor 別本数を 1 行にまとめた文字列を返す (golden 比較用)。 +-- ⚠ repo root を cwd として実行する前提 (cabal test を repo root から)。 +galleryCountsString :: FilePath -> IO String +galleryCountsString galleryDir = do + let specsDir = galleryDir ++ "/specs" + prefix = specsDir ++ "/" + files <- listJsonRec specsDir + rows <- mapM (countRow prefix) (sort files) + pure (unlines rows) + where + countRow prefix f = do + bs <- BL.readFile f + let rel = drop (length prefix) f + case eitherDecode bs of + Left err -> pure (rel ++ ": DECODE-ERROR " ++ err) + Right spec -> do + let lay = computeLayout emptyResolver spec + prims = renderToPrimitives emptyResolver lay spec + counts = Map.toAscList + (Map.fromListWith (+) [(ctorName p, 1 :: Int) | p <- prims]) + pure (rel ++ ": " ++ unwords [c ++ "=" ++ show n | (c, n) <- counts]) + +-- | cwd から design/gallery を探す (cabal test の cwd が repo root か package +-- dir か実行環境で異なるため、 数段上まで候補を辿る)。 +-- fixture 非同梱の環境 (公開ツリー等) では 'Nothing' (test 側で pendingWith skip)。 +findGalleryDir :: IO (Maybe FilePath) +findGalleryDir = go [ up n ++ "design/gallery" | n <- [0 .. 4 :: Int] ] + where + up n = concat (replicate n "../") + go [] = pure Nothing + go (d:ds) = do + e <- doesDirectoryExist d + if e then pure (Just d) else go ds + +-- | design/gallery/specs 配下を再帰列挙し .json のみ返す。 +listJsonRec :: FilePath -> IO [FilePath] +listJsonRec dir = do + entries <- listDirectory dir + fmap concat (mapM step entries) + where + step e = do + let full = dir </> e + isDir <- doesDirectoryExist full + if isDir then listJsonRec full + else pure [full | takeExtension full == ".json"] + +-- | Primitive の constructor 名 (count 集計キー)。 +ctorName :: Primitive -> String +ctorName p = case p of + PLine{} -> "PLine" + PRect{} -> "PRect" + PCircle{} -> "PCircle" + PPath{} -> "PPath" + PText{} -> "PText" + PClipPush{} -> "PClipPush" + PClipPop -> "PClipPop" + PTransformPush{} -> "PTransformPush" + PTransformPop -> "PTransformPop"