diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,20 @@ # Changelog for `hgg-core` +## 0.2.0.0 — 2026-08-13 + +- **Breaking**: theme constructors `ThemeCanvas` / `ThemeCanvasDark` renamed + to `ThemeParchment` / `ThemeParchmentDark`. +- Generalized coordinate systems: ternary coordinates (`ternaryScatter` / + `ternaryLine` marks, `encZ` channel), polar start angle / direction / + rotation, polygon clipping; crossbar renders through the projection layer + (correct in polar coordinates). +- Theme extensions (cowplot parity): base-size scaling, font family, plot + margins, subplot relative widths and tags, three new presets; grid and + axis line widths are now theme-controlled. +- Fixes: facets now split inline (non-DataFrame) layer data; boxplot + outliers are included in the axis domain. +- Bilingual (English / Japanese) haddock across the public API. + ## 0.1.0.0 — 2026-07-18 First public release on Hackage. diff --git a/hgg-core.cabal b/hgg-core.cabal --- a/hgg-core.cabal +++ b/hgg-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hgg-core -version: 0.1.0.0 +version: 0.2.0.0 extra-doc-files: CHANGELOG.md synopsis: Core of hgg: VisualSpec / PlotData / Layout / Render primitives description: @@ -8,7 +8,7 @@ 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. diff --git a/src/Graphics/Hgg/Color.hs b/src/Graphics/Hgg/Color.hs --- a/src/Graphics/Hgg/Color.hs +++ b/src/Graphics/Hgg/Color.hs @@ -1,16 +1,26 @@ -- | -- Module : Graphics.Hgg.Color --- Description : 型安全な固定色 (RGB 全色を単一構成子で内包、Phase 30) +-- Description : Type-safe named colors, with the full RGB space in one constructor -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- RGB 全色 (256³ = 16,777,216) を単一構成子 @Color@ で連続的に内包し、 +-- [日本語]: RGB 全色 (256³ = 16,777,216) を単一構成子 @Color@ で連続的に内包し、 -- 固定色のタイポをコンパイルエラーに落とす。 名前付き 657 色は -- @Graphics.Hgg.Color.Named@ にトップレベル束縛として隔離する。 -- -- ★ワイヤ形式は従来通り Text: @ColorEnc@ の @ColorStatic !Text@ は据置で、 -- 固定色 combinator が入口で 'toCss' 変換して格納する。 → Render / PS -- canvas / JSON は無改修 (PS は Color 型を知らず解決済み Text のみ見る)。 +-- [English]: The full RGB space (256³ = 16,777,216 colors) is covered +-- continuously by the single constructor @Color@, turning typos in named +-- colors into compile errors. The 657 named colors are isolated as +-- top-level bindings in @Graphics.Hgg.Color.Named@. +-- +-- The wire format is Text as before: @ColorEnc@'s @ColorStatic !Text@ is +-- kept unchanged, and named-color combinators convert via 'toCss' at the +-- entry point and store the result. Render / the PureScript canvas / JSON +-- therefore need no changes (PureScript does not know the Color type and +-- only ever sees the already-resolved Text). {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} @@ -36,7 +46,9 @@ -- 型 -- =========================================================================== --- | 固定色。 単一構成子で RGB 全色を張る (各成分 0–255・Word8 で範囲保証)。 +-- | [日本語]: 固定色。 単一構成子で RGB 全色を張る (各成分 0–255・Word8 で範囲保証)。 +-- [English]: A named/fixed color. A single constructor spans the full RGB +-- space (each component ranges 0–255, guaranteed by Word8). data Color = Color !Word8 !Word8 !Word8 deriving (Show, Eq, Ord, Generic) @@ -44,12 +56,18 @@ -- 構築 / 変換 -- =========================================================================== --- | RGB 成分から構築 ('Color' と同義の読みやすい別名)。 +-- | [日本語]: RGB 成分から構築 ('Color' と同義の読みやすい別名)。 +-- [English]: Constructs a color from its RGB components (a readable alias +-- synonymous with 'Color'). rgb :: Word8 -> Word8 -> Word8 -> Color rgb = Color --- | @"#rrggbb"@ / @"#rgb"@ (先頭 @#@ は省略可) を解釈。 不正は 'Nothing'。 --- 3 桁省略形は各桁を 2 倍展開 (CSS 同様 @#f80@ → @#ff8800@)。 total 版。 +-- | [日本語]: @"#rrggbb"@ / @"#rgb"@ (先頭 @#@ は省略可) を解釈。 不正は +-- 'Nothing'。 3 桁省略形は各桁を 2 倍展開 (CSS 同様 @#f80@ → @#ff8800@)。 +-- total 版。 +-- [English]: Parses @"#rrggbb"@ / @"#rgb"@ (the leading @#@ is optional). +-- Invalid input yields 'Nothing'. The 3-digit shorthand expands each digit +-- twice, as in CSS (@#f80@ becomes @#ff8800@). A total function. fromHexMaybe :: Text -> Maybe Color fromHexMaybe raw = case map toLower (T.unpack (T.dropWhile (== '#') (T.strip raw))) of @@ -63,15 +81,26 @@ byte hi lo = fromIntegral (digitToInt hi * 16 + digitToInt lo) dup c = byte c c --- | 'fromHexMaybe' の partial 版。 不正入力で 'error' (リテラル用途で簡潔)。 +-- | [日本語]: 'fromHexMaybe' の partial 版。 不正入力で 'error' (リテラル用途で簡潔)。 +-- [English]: The partial version of 'fromHexMaybe'. Invalid input causes +-- an 'error' (kept concise for literal use). 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@ に展開)。 +-- | [日本語]: @"#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@ に展開)。 +-- [English]: Splits @"#rrggbbaa"@ / @"#rgba"@ (RGBA, leading @#@ optional) +-- into (color, opacity 0–1). Opacity is @aa/255@ (CSS 8-digit hex or the +-- 4-digit shorthand). The 6/3-digit forms without alpha pass through with +-- alpha = 1.0 (delegated to 'fromHexMaybe'). Invalid input yields +-- 'Nothing'. A total function. +-- Since 'Color' is RGB-only, alpha is returned separately (@colorRGBA@ +-- expands it to @color c <> alpha a@). fromHexAMaybe :: Text -> Maybe (Color, Double) fromHexAMaybe raw = case map toLower (T.unpack (T.dropWhile (== '#') (T.strip raw))) of @@ -87,12 +116,16 @@ dup c = byte c c alphaOf w = fromIntegral w / 255 --- | 'fromHexAMaybe' の partial 版。 不正入力で 'error' (リテラル用途で簡潔)。 +-- | [日本語]: 'fromHexAMaybe' の partial 版。 不正入力で 'error' (リテラル用途で簡潔)。 +-- [English]: The partial version of 'fromHexAMaybe'. Invalid input causes +-- an 'error' (kept concise for literal use). 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)。 +-- | [日本語]: CSS 文字列 @"#rrggbb"@ に整形 (各成分 2 桁・小文字 hex)。 +-- [English]: Formats as the CSS string @"#rrggbb"@ (each component as 2 +-- lowercase hex digits). toCss :: Color -> Text toCss (Color r g b) = T.pack ('#' : pad r ++ pad g ++ pad b) where diff --git a/src/Graphics/Hgg/Color/Named.hs b/src/Graphics/Hgg/Color/Named.hs --- a/src/Graphics/Hgg/Color/Named.hs +++ b/src/Graphics/Hgg/Color/Named.hs @@ -1,15 +1,24 @@ -- | -- Module : Graphics.Hgg.Color.Named --- Description : R colors() の 657 名前付き色 (機械生成、Phase 30) +-- Description : The 657 named colors from R's colors() (machine-generated) -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- ★このファイルは機械生成物 (scripts/gen-named-colors.py)。 手で編集しない。 +-- [日本語]: ★このファイルは機械生成物 (scripts/gen-named-colors.py)。 手で編集しない。 -- 一次ソース = R src/library/grDevices/src/colors.c の ColorDataBase[] -- (= R colors() の実体・657 色)。 値は捏造せず colors.c の hex から導出。 -- -- タイポは文字列ルックアップでなくトップレベル束縛ゆえコンパイルエラーで防げる。 -- grey/gray の両綴り・連番 (grey0..grey100 等) も R に倣って保持。 +-- [English]: This file is machine-generated (scripts/gen-named-colors.py). +-- Do not edit it by hand. The primary source is R's +-- src/library/grDevices/src/colors.c, specifically ColorDataBase[] (the +-- backing data for R's colors(), 657 colors). Values are derived from the +-- hex codes in colors.c, never invented. +-- +-- Because these are top-level bindings rather than a string lookup, typos +-- are caught as compile errors. Both the grey/gray spellings and the +-- numbered series (grey0..grey100, etc.) are kept, following R. {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Color.Named where diff --git a/src/Graphics/Hgg/DAG.hs b/src/Graphics/Hgg/DAG.hs --- a/src/Graphics/Hgg/DAG.hs +++ b/src/Graphics/Hgg/DAG.hs @@ -1,20 +1,39 @@ -- | -- Module : Graphics.Hgg.DAG --- Description : algebraic-graphs 流 DAG builder + layout (Phase 26 §E-6) +-- Description : algebraic-graphs-style DAG builder and layout -- 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) と同じ思想: +-- [日本語]: DAG (directed graph) を __polymorphic な Graph a + 代数演算__ で構築し、 +-- Graphics.Hgg.Spec.DAGSpec に変換して描画 layer を作る。 algebraic-graphs +-- (Mokhov) と同じ思想: -- --- * 'overlay' / '(<>)' ─ graph を並置 (= 和集合) --- * 'connect' / '(~>)' ─ 全 edge を貼る --- * 'vertex' ─ 単一 node --- * 'empty' ─ 何も無い +-- * 'overlay' / '(<>)' ─ graph を並置 (= 和集合) +-- * 'connect' / '(~>)' ─ 全 edge を貼る +-- * 'vertex' ─ 単一 node +-- * 'empty' ─ 何も無い -- --- 例: +-- node 属性 (= label / kind) は 'ToDAGNode' 型クラスで抽出。 'Text' は全 latent +-- default、 record や tuple で明示も可。 幽霊型 module (= 将来 +-- @Graphics.Hgg.DAG.Typed@) も instance 追加だけで対応。 -- +-- [English]: Builds a DAG (directed graph) using a __polymorphic Graph a__ +-- plus algebraic operations, and converts it to a +-- Graphics.Hgg.Spec.DAGSpec to produce a rendering layer. Follows the +-- same philosophy as algebraic-graphs (Mokhov): +-- +-- * 'overlay' / '(<>)' — juxtaposes graphs (union) +-- * 'connect' / '(~>)' — connects every pair with an edge +-- * 'vertex' — a single node +-- * 'empty' — the empty graph +-- +-- Node attributes (label / kind) are extracted through the 'ToDAGNode' +-- typeclass. 'Text' defaults to fully latent nodes; records or tuples can +-- spell them out explicitly. A phantom-typed module (a possible future +-- @Graphics.Hgg.DAG.Typed@) can be supported by adding just an instance. +-- +-- Example: +-- -- > hbmModel :: Graph Text -- > hbmModel -- > = "alpha" ~> "sigma" ~> "y" @@ -26,10 +45,6 @@ -- > 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 #-} @@ -79,13 +94,21 @@ -- Graph algebra (= algebraic-graphs / Mokhov) -- =========================================================================== --- | 代数的 DAG。 'a' は vertex の identity (任意型)。 +-- | [日本語]: 代数的 DAG。 @a@ は vertex の identity (任意型)。 -- --- * 'Empty' ─ 空 --- * 'Vertex' ─ 単一 node --- * 'Overlay' ─ 2 graph を並置 (= 和集合、 edges もそのまま) --- * 'Connect' ─ 2 graph の全ペアに edge を張る (= 第 1 の全 vertex から --- 第 2 の全 vertex へ) +-- * 'Empty' ─ 空 +-- * 'Vertex' ─ 単一 node +-- * 'Overlay' ─ 2 graph を並置 (= 和集合、 edges もそのまま) +-- * 'Connect' ─ 2 graph の全ペアに edge を張る (= 第 1 の全 vertex から +-- 第 2 の全 vertex へ) +-- +-- [English]: An algebraic DAG. @a@ is the vertex identity (any type). +-- +-- * 'Empty' — empty +-- * 'Vertex' — a single node +-- * 'Overlay' — juxtaposes two graphs (union; edges are kept as-is) +-- * 'Connect' — connects every pair between two graphs (an edge from +-- every vertex of the first to every vertex of the second) data Graph a = Empty | Vertex !a @@ -108,17 +131,23 @@ 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 される。 +-- | [日本語]: edge を貼る軽量 operator。 `<>` (infixr 6) より tight に binding (= 7) して +-- `a ~> b <> c ~> d` が `(a ~> b) <> (c ~> d)` と parse される。 +-- [English]: A lightweight operator for adding an edge. Binds tighter (= 7) +-- than `<>` (infixr 6), so `a ~> b <> c ~> d` parses as +-- `(a ~> b) <> (c ~> d)`. infix 7 ~> (~>) :: a -> a -> Graph a a ~> b = Connect (Vertex a) (Vertex b) --- | edge リストから graph を作る (= 補助 helper、 既存パターンの移行用)。 +-- | [日本語]: edge リストから graph を作る (= 補助 helper、 既存パターンの移行用)。 +-- [English]: Builds a graph from a list of edges (a helper for migrating +-- from an existing edge-list pattern). edges :: [(a, a)] -> Graph a edges es = foldl' Overlay Empty [ Connect (Vertex f) (Vertex t) | (f, t) <- es ] --- | vertex 群を overlay。 +-- | [日本語]: vertex 群を overlay。 +-- [English]: Overlays a list of vertices. vertices :: [a] -> Graph a vertices = foldl' Overlay Empty . map Vertex @@ -126,20 +155,28 @@ -- ToDAGNode (= attribute 抽出 type class) -- =========================================================================== --- | Graph の vertex 型 'a' から (id, label, kind) を取り出す。 --- ユーザ独自 newtype / 幽霊型でも instance 追加するだけで dagPlot に渡せる。 +-- | [日本語]: Graph の vertex 型 @a@ から (id, label, kind) を取り出す。 +-- ユーザ独自 newtype / 幽霊型でも instance 追加するだけで dagPlot に渡せる。 +-- [English]: Extracts (id, label, kind) from a Graph's vertex type @a@. A +-- user's own newtype or phantom type can be passed to dagPlot just by +-- adding an instance. class Ord a => ToDAGNode a where toDAGNode :: a -> (Text, Text, DAGNodeKind) --- | 最小 case: Text を id 兼 label、 kind = NodeLatent (default)。 +-- | [日本語]: 最小 case: Text を id 兼 label、 kind = NodeLatent (default)。 +-- [English]: The minimal case: 'Text' serves as both id and label, with +-- kind defaulting to NodeLatent. instance ToDAGNode Text where toDAGNode t = (t, t, NodeLatent) --- | (id, label, kind) tuple をそのまま。 +-- | [日本語]: (id, label, kind) tuple をそのまま。 +-- [English]: An (id, label, kind) tuple, used as-is. instance ToDAGNode (Text, Text, DAGNodeKind) where toDAGNode = id --- | DAGNode を直接 vertex として渡す場合 (= 位置情報含む、 LayoutManual 用)。 +-- | [日本語]: DAGNode を直接 vertex として渡す場合 (= 位置情報含む、 LayoutManual 用)。 +-- [English]: For passing a DAGNode directly as a vertex (carries position +-- information, used with LayoutManual). instance ToDAGNode DAGNode where toDAGNode n = (dnId n, dnLabel n, dnKind n) @@ -147,13 +184,16 @@ -- Graph → Layer 変換 (= dagPlot) -- =========================================================================== --- | algebraic graph を VisualSpec の Layer に。 layout は階層 (= 推奨 default)。 +-- | [日本語]: algebraic graph を VisualSpec の Layer に。 layout は階層 (= 推奨 default)。 +-- [English]: Converts an algebraic graph into a VisualSpec Layer. The +-- layout is hierarchical (the recommended default). -- -- > dagPlot ("a" ~> "b" ~> "c" <> "a" ~> "c") dagPlot :: ToDAGNode a => Graph a -> Layer dagPlot g = dagPlotWith LayoutHierarchical g --- | layout algorithm を明示指定。 +-- | [日本語]: layout algorithm を明示指定。 +-- [English]: Explicitly specifies the layout algorithm. dagPlotWith :: ToDAGNode a => DAGLayoutAlgorithm -> Graph a -> Layer dagPlotWith algo g = let vs = toVertices g @@ -169,9 +209,13 @@ 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 用)。 +-- | [日本語]: plate (= cluster) を伴う Graph DSL 用 helper。 +-- LayoutHierarchical で plate-aware ordering (= 同 plate メンバが rank 内で +-- contiguous) を適用する。 plates 順は外側 → 内側 (= nested plate 用)。 +-- [English]: A Graph DSL helper carrying plates (clusters). Applies +-- plate-aware ordering under LayoutHierarchical, keeping members of the +-- same plate contiguous within a rank. The plates order runs outermost to +-- innermost (for nested plates). dagPlotWithPlates :: ToDAGNode a => Graph a -> [DAGPlate] -> Layer dagPlotWithPlates g plates = let vs = toVertices g @@ -184,10 +228,16 @@ 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)。 +-- | [日本語]: rank group (= graphviz @rank=same@) を伴う Graph DSL 用 helper。 +-- 各 group の member id は同一 rank に置かれ、 group 内の edge は flat edge +-- (= 同 rank edge) として順序制約 (左→右) + 水平/迂回 spline で描画される。 +-- rank group は layout 制約であり出力 DAGSpec には載らない。 +-- [English]: A Graph DSL helper carrying rank groups (graphviz's +-- @rank=same@). Every member id of a group is placed on the same rank, and +-- an edge within a group is drawn as a flat edge (a same-rank edge) using +-- an ordering constraint (left to right) plus a horizontal / detour +-- spline. Rank groups are a layout-time constraint and are not carried +-- into the output DAGSpec. -- -- > dagPlotWithRankGroups ("a" ~> "b" <> "a" ~> "c") [["b", "c"]] dagPlotWithRankGroups :: ToDAGNode a => Graph a -> [[Text]] -> Layer @@ -202,7 +252,9 @@ layoutHierarchicalFullWithConstraints nodeList edgeList [] rankGroups in dagFromLists positioned routedEdges LayoutHierarchical --- | Graph 構造から vertex 列を抽出 (= 重複あり、 順序保持)。 +-- | [日本語]: Graph 構造から vertex 列を抽出 (= 重複あり、 順序保持)。 +-- [English]: Extracts the list of vertices from the Graph structure +-- (duplicates allowed, order preserved). toVertices :: Graph a -> [a] toVertices g = go g [] where @@ -211,7 +263,9 @@ go (Overlay x y) acc = go x (go y acc) go (Connect x y) acc = go x (go y acc) --- | Graph 構造から edge 列を抽出 (= Connect が出すクロス積)。 +-- | [日本語]: Graph 構造から edge 列を抽出 (= Connect が出すクロス積)。 +-- [English]: Extracts the list of edges from the Graph structure (the +-- cross product produced by Connect). toEdges :: Graph a -> [(a, a)] toEdges g = go g where @@ -227,25 +281,47 @@ -- Layout: 階層 (Sugiyama 簡易版) -- =========================================================================== --- | 階層 layout (= Sugiyama framework、 Phase 1 で network simplex rank assignment に置換)。 +-- | [日本語]: 階層 layout (= Sugiyama framework、 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 に比例 (= 上から下) +-- 1. Step 2 'Graphics.Hgg.DAG.Internal.Sugiyama.assignRanks' (= network simplex framework、 内部 'Graphics.Hgg.DAG.Internal.Sugiyama.longestPathRanking' で初期解、 一様 δ=ω=1 では即時最適) で各 node の rank を決定 +-- 2. (未実装) Step 3 Order assignment、 Step 4 Coordinate assignment は今は alphabetical 等間隔 (= 将来置換予定) +-- 3. y は rank に比例 (= 上から下) -- --- domain 座標で返す (= 0..1 正規化)。 Render 側で scale 適用。 +-- domain 座標で返す (= 0..1 正規化)。 Render 側で scale 適用。 +-- +-- [English]: Hierarchical layout (Sugiyama framework; rank assignment has +-- been replaced with network simplex). +-- +-- 1. Step 2 'Graphics.Hgg.DAG.Internal.Sugiyama.assignRanks' (the network simplex framework; internally +-- 'Graphics.Hgg.DAG.Internal.Sugiyama.longestPathRanking' provides the initial solution, which is +-- already optimal for the uniform case δ=ω=1) determines each node's +-- rank +-- 2. (not yet implemented) Step 3 Order assignment and Step 4 +-- Coordinate assignment currently use alphabetical, evenly-spaced +-- placement (planned to be replaced later) +-- 3. y is proportional to rank (top to bottom) +-- +-- Returns domain coordinates (normalized to 0..1); scale is applied on the +-- Render side. layoutHierarchical :: [DAGNode] -> [DAGEdge] -> [DAGNode] layoutHierarchical nodes es = fst (layoutHierarchicalFull nodes es) --- | 階層 layout の full 版 (= plate 無し)。 'layoutHierarchicalFullWithPlates' の薄 wrapper。 +-- | [日本語]: 階層 layout の full 版 (= plate 無し)。 'layoutHierarchicalFullWithPlates' の薄 wrapper。 +-- [English]: The full version of the hierarchical layout (no plates); a +-- thin wrapper over 'layoutHierarchicalFullWithPlates'. 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)。 +-- | [日本語]: rank group (= graphviz @rank=same@) も受ける full 版。 +-- rank group は __入力時 layout 制約__ で出力 spec には載せない (layout は builder +-- 時のみ実行され、 JSON 復元後の再 layout 経路が無いことを実測済)。 +-- [English]: The full version that also accepts rank groups (graphviz's +-- @rank=same@). A rank group is an __input-time layout constraint__ and is +-- not carried into the output spec (layout only runs at builder time, and +-- there is no re-layout path after JSON restoration — verified by +-- measurement). layoutHierarchicalFullWithConstraints :: [DAGNode] -> [DAGEdge] -> [DAGPlate] -> [[Text]] -> ([DAGNode], [DAGEdge]) layoutHierarchicalFullWithConstraints nodes es plates rankGroups = @@ -254,40 +330,63 @@ 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 用、 外側 → 内側)。 +-- | [日本語]: 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 独立) の入力契約の土台にする。 +-- 旧一枚岩 'let' を rank → order → coord → route の段階関数に分離。 +-- 各段の中身 (assignRanks 等の呼出) は不変、 段間は record の包み直しのみ +-- (= 出力ビット不変、 golden 回帰で担保)。 段階型 (= 'StageRaw' 〜 'StageRouted') +-- が「どの段で何が産出されるか」 (chainMap = order 段, coordMap = coord 段) を +-- 型に明示し、 将来 routing module を独立させる際の入力契約の土台にする。 +-- +-- [English]: plate-aware: computes a node's (x, y) placement and an edge's +-- 'dePath' together. When @plates@ is non-empty, a post-process step keeps +-- members of the same plate contiguous within a rank. The given plates +-- order is respected (outermost to innermost, for nesting). +-- +-- The old monolithic 'let' was split into stage functions: +-- rank → order → coord → route. The content of each stage (calls such as +-- assignRanks) is unchanged; only the record is re-wrapped between stages +-- (output is bit-identical, guarded by golden regression tests). The stage +-- types ('StageRaw' through 'StageRouted') make explicit in the type +-- system which stage produces what (chainMap at the order stage, coordMap +-- at the coord stage), laying the groundwork for the input contract of a +-- future independent routing module. layoutHierarchicalFullWithPlates :: [DAGNode] -> [DAGEdge] -> [DAGPlate] -> ([DAGNode], [DAGEdge]) layoutHierarchicalFullWithPlates nodes es plates = layoutHierarchicalFullWithConstraints nodes es plates [] -- =========================================================================== --- Phase 39 B1: layout pipeline の段階型と段階関数 +-- layout pipeline の段階型と段階関数 -- =========================================================================== --- | 段階0: 入力そのまま (rank 前)。 後段で nodes (= 最終配置) / es (= routedE・ --- recenter) / plates (= banding・extent) を参照するため全段で保持する。 +-- | [日本語]: 段階0: 入力そのまま (rank 前)。 後段で nodes (= 最終配置) / es (= routedE・ +-- recenter) / plates (= banding・extent) を参照するため全段で保持する。 +-- [English]: Stage 0: the input, unchanged (before ranking). Kept through +-- every stage because later stages reference nodes (final placement), es +-- (routedE / recenter), and plates (banding / extent). data StageRaw = StageRaw { srNodes :: [DAGNode] , srEdges :: [DAGEdge] , srPlates :: [DAGPlate] - , srRankGroups :: [[Text]] -- ^ Phase 53 A3: graphviz rank=same 相当の同 rank group + , srRankGroups :: [[Text]] + -- ^ [日本語]: graphviz rank=same 相当の同 rank group。 + -- [English]: A same-rank group, equivalent to graphviz's rank=same. } --- | 段階1: rank 割当済 (tightenSourceRanks 反映済) LayoutGraph。 +-- | [日本語]: 段階1: rank 割当済 (tightenSourceRanks 反映済) LayoutGraph。 +-- [English]: Stage 1: the LayoutGraph after rank assignment (with +-- tightenSourceRanks applied). data StageRanked = StageRanked { rkInput :: StageRaw , rkGraph :: LayoutGraph } --- | 段階2: order 確定 + 元 edge → chain map (= skip edge routing 用) が産出される段。 +-- | [日本語]: 段階2: order 確定 + 元 edge → chain map (= skip edge routing 用) が産出される段。 +-- [English]: Stage 2: the stage that finalizes order and produces the +-- original-edge-to-chain map (used for skip-edge routing). data StageOrdered = StageOrdered { odInput :: StageRaw , odGraph :: LayoutGraph @@ -295,7 +394,9 @@ , odChain :: Map.Map (Text, Text) [Text] } --- | 段階3: x 座標確定 (route 前)。 coordMap (= banding + recenter 反映済) が産出される段。 +-- | [日本語]: 段階3: x 座標確定 (route 前)。 coordMap (= banding + recenter 反映済) が産出される段。 +-- [English]: Stage 3: x coordinates finalized (before routing). The stage +-- that produces coordMap (with banding and recentering applied). data StagePositioned = StagePositioned { psInput :: StageRaw , psChain :: Map.Map (Text, Text) [Text] @@ -303,18 +404,29 @@ , psCoord :: Map.Map Text Double } --- | 段階4: 最終 (配置済 node + dePath 埋め edge)。 +-- | [日本語]: 段階4: 最終 (配置済 node + dePath 埋め edge)。 +-- [English]: Stage 4: the final stage (positioned nodes plus dePath-filled +-- edges). data StageRouted = StageRouted { rtNodes :: [DAGNode] , rtEdges :: [DAGEdge] } --- | rank 段: longest-path / network simplex で rank 割当 → source 引き締め。 +-- | [日本語]: 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) として下流へ流れる。 +-- 旧 breakCycles → assignRanks → tightenSourceRanks の直列は +-- 'assignRanksGrouped' に集約 (rank group 無しではビット一致、 test 担保)。 +-- rank group 有りでは group を代表 node に併合して rank 割当し、 group 内 edge が +-- flat edge (= 同 rank edge) として下流へ流れる。 +-- +-- [English]: The rank stage: assigns ranks via longest-path / network +-- simplex, then tightens sources. +-- +-- The old sequence breakCycles → assignRanks → tightenSourceRanks has been +-- consolidated into 'assignRanksGrouped' (bit-identical when there are no +-- rank groups, guarded by tests). When rank groups are present, each +-- group is merged into a representative node for rank assignment, and +-- edges within a group flow downstream as flat edges (same-rank edges). rankStage :: StageRaw -> StageRanked rankStage raw = let nodes = srNodes raw; es = srEdges raw; plates = srPlates raw @@ -323,27 +435,41 @@ ids [ (deFrom e, deTo e) | e <- es ] in StageRanked raw lg0' --- | order 段: dummy 挿入 + median heuristic + transpose、 元 edge → chain map 取得、 --- plate 制約 post-process。 +-- | [日本語]: order 段: dummy 挿入 + median heuristic + transpose、 元 edge → chain map 取得、 +-- plate 制約 post-process。 +-- [English]: The order stage: dummy insertion, median heuristic, and +-- transpose, plus obtaining the original-edge-to-chain map and applying +-- the plate-constraint post-process. orderStage :: StageRanked -> StageOrdered orderStage (StageRanked raw lg0') = - let -- A3: dummy 挿入 + median heuristic + transpose、 元 edge → chain map も取得 + let -- dummy 挿入 + median heuristic + transpose、 元 edge → chain map も取得 (lgFinal, orderMap0, chainMap) = assignOrderFull lg0' - -- A6: plate 制約 post-process (= 同 plate メンバを rank 内 contiguous に) + -- 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 座標を解く。 +-- | [日本語]: coord 段: 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]])。 +-- plate メンバ id を aux-graph simplex に渡し、 cluster border +-- 制約 (contain/keepout、 graphviz @pos_clusters@ 実装) を x 座標へ直接反映する。 +-- これで box 分離が simplex 由来になったため、 従来の cosmetic post-process +-- (@applyPlateBands@ = 帯分離 / @recenterNonPlateRows@ = 帯後の重心緩和) を __撤去__ +-- した ([[feedback-remove-stopgaps-when-real-algo-lands]])。 +-- +-- [English]: The coord stage: solves x coordinates via the aux-graph +-- network simplex. +-- +-- Plate member ids are passed to the aux-graph simplex, so cluster border +-- constraints (contain/keepout, per graphviz's @pos_clusters@) are +-- reflected directly in the x coordinates. Since box separation is now a +-- consequence of the simplex, the old cosmetic post-process steps +-- (@applyPlateBands@ for band separation, @recenterNonPlateRows@ for +-- post-band centroid relaxation) have been __removed__ +-- ([[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 座標**を + -- 完全忠実: real-width simplex の raw point 座標を -- 正規化せず直接使う (= graphviz の point 一貫 pipeline)。 wpt rescale を介さない。 hwMap = Map.fromList [ (dnId n, round (dagNodeBaseHalfWidth n) :: Int) | n <- srNodes raw ] @@ -351,25 +477,48 @@ rankOf = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lgFinal ] in StagePositioned raw chainMap rankOf coordMap --- | route 段: node 最終配置 (rank→y) + edge dePath (chain waypoint)。 +-- | [日本語]: route 段: node 最終配置 (rank→y) + edge dePath (chain waypoint)。 -- --- Phase 39 Step8 (P8) A3: plate 箱迂回の応急処置 'routeLongEdgeDummies' (RLED) を --- **撤去**した ([[feedback-remove-stopgaps-when-real-algo-lands]])。 撤去の根拠は --- 二段構えの本実装が landing したこと: +-- 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 へ整える。 → 幾何的に貫通しない。 +-- 1. layout 層 = 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 --- でしかなかったことが裏付けられた。 +-- 実測 (RLED 撤去 vs 存置): 実 HBM DAG (hbm-after) は __ビット不変__、 box を直線 +-- 貫通する合成ケース (plate-through/plate-cross) は RLED の「箱辺に張り付く」 bend +-- より funnel の方が箱から余裕を持って外迂回し改善。 RLED は箱辺密着の cosmetic +-- でしかなかったことが裏付けられた。 +-- +-- [English]: The route stage: final node placement (rank → y) plus edge +-- dePath (chain waypoints). +-- +-- The stopgap fix for plate-box detours, @routeLongEdgeDummies@ (RLED), +-- has been __removed__ ([[feedback-remove-stopgaps-when-real-algo-lands]]). +-- The removal is justified because the proper two-part implementation has +-- since landed: +-- +-- 1. layout layer — the cluster border constraint +-- (@keepout_othernodes@) pushes non-plate-member nodes (including +-- long-edge dummies) outside the box via the simplex, so the guide +-- itself already sits outside the box. +-- 2. render layer — the box-channel plus funnel of +-- 'Render.EdgeRoute.routeEdge' treat the plate box as an obstacle and +-- shape the guide into a taut spline outside the box, so it cannot +-- geometrically pass through it. +-- +-- Measurement (RLED removed vs. kept): the real HBM DAG (hbm-after) is +-- __bit-identical__; for synthetic cases where a straight line pierces a +-- box (plate-through/plate-cross), the funnel routes further clear of the +-- box than RLED's "hugs the box edge" bend, an improvement. This confirmed +-- that RLED was nothing more than a box-edge-hugging cosmetic fix. routeStage :: StagePositioned -> StageRouted routeStage (StagePositioned raw chainMap rankOf coordMap) = let nodes = srNodes raw; es = srEdges raw - -- ★ A4-3 (完全忠実 point pipeline): y は **rank index** をそのまま返す。 + -- 完全忠実 point pipeline: y は rank index をそのまま返す。 -- point 化 (× rankPitch = maxNodeH+ranksep) は radius が既知の render 側で行う -- (x は simplex の raw point ゆえ layout で確定・y だけ render で pitch を被せる)。 yOf r = fromIntegral r @@ -380,13 +529,13 @@ positionedN = [ n { dnX = x, dnY = y } | n <- nodes , let (x, y) = posOf (dnId n) ] - -- A5: 元 edge の chain から control 点列を埋める。 長 edge は rank 単位 dummy + -- 元 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 が + -- 間に node があれば rank の上側 gap (= r - 0.5、 graphviz make_flat_edge が -- rank 上の空間へ逃がすのと同層) に waypoint を 1 点置き、 render 側の -- box-channel / funnel / proutespline に迂回 spline を作らせる。 flatPath e = @@ -407,7 +556,7 @@ else Nothing _ -> Nothing routedE = [ e { dePath = maybe (chainToPath e) Just (flatPath e) } | e <- es ] - -- P2a: layout で back-edge が反転されている場合 chainMap の key は (to,from)。 + -- 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 @@ -418,12 +567,12 @@ in StageRouted positionedN routedE -- =========================================================================== --- Phase 1 A2 以前の 'computeDepths' (= longest path 直接実装) は削除済。 +-- かつての 'computeDepths' (= longest path 直接実装) は削除済。 -- 同等処理は 'Graphics.Hgg.DAG.Internal.Sugiyama.longestPathRanking' に移動、 --- 'assignRanks' (= network simplex framework) 経由で呼ばれる。 +-- 'Graphics.Hgg.DAG.Internal.Sugiyama.assignRanks' (= network simplex framework) 経由で呼ばれる。 -- =========================================================================== --- Phase 39 Step8 (P8) A3: long-edge dummy を plate 箱外へ bend する応急処置 --- 'routeLongEdgeDummies' (RLED) は撤去した。 plate 箱迂回は A1 cluster border 制約 +-- long-edge dummy を plate 箱外へ bend する応急処置 +-- @routeLongEdgeDummies@ (RLED) は撤去した。 plate 箱迂回は 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 --- a/src/Graphics/Hgg/DAG/Internal/Sugiyama.hs +++ b/src/Graphics/Hgg/DAG/Internal/Sugiyama.hs @@ -1,31 +1,56 @@ -- | -- Module : Graphics.Hgg.DAG.Internal.Sugiyama --- Description : Sugiyama framework 中間表現 + Step 2 Rank + Step 3 Order (Phase 1 A2-A3) +-- Description : Sugiyama-framework internals: rank, order, coordinate assignment -- 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 規律)。 +-- [日本語]: Graphics.Hgg.DAG 内部で使う Sugiyama framework の中間表現と各 step 実装。 +-- 外向け Graph a / DAGSpec には漏らさない (= spec §10.3 dummy node 規律)。 +-- [English]: The intermediate representation and per-step implementations of +-- the Sugiyama framework used internally by Graphics.Hgg.DAG. Never leaked +-- to the public Graph a / DAGSpec (per spec §10.3's dummy-node discipline). -- --- 現状 (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 探索 (= 該当無し → 即終了) という構造で書く。 +-- [English]: Current state: -- --- 計算量: +-- * The LNode / LEdge / LayoutGraph intermediate types +-- * Step 2 rank assignment: network simplex (Gansner-Koutsofios-North-Vo 1993 §2.3) +-- * Every edge defaults to minimum length δ = 1 and weight ω = 1 (DAG.Graph +-- edges currently carry no attributes; room to extend with weights later) +-- +-- [日本語]: 設計判断: 一様 δ=1 / ω=1 の場合、 longest-path ranking が既に Σ edge length +-- 最適解 (= 証明: edge 数固定で各 edge の最小 rank diff = 1)。 そのため network +-- simplex の __反復改善 phase は実質 no-op__ になる。 ただし将来 weight / 異δ +-- 拡張に備えて framework として実装し、 初期解 = longest-path、 反復 = 負 cut +-- value 探索 (= 該当無し → 即終了) という構造で書く。 +-- +-- [English]: Design rationale: with uniform δ=1 / ω=1, longest-path ranking +-- is already the Σ edge-length optimum (proof: with the edge count fixed, +-- the minimum rank diff per edge is 1). So the network simplex's +-- __iterative-improvement phase is effectively a no-op__. It is nonetheless +-- implemented as a full framework, in preparation for future weight and +-- non-uniform-δ extensions, structured as: initial solution = longest-path, +-- iteration = search for a negative cut value (none found here, so it +-- terminates immediately). +-- +-- [日本語]: 計算量: -- * 初期 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 -- +-- [English]: Complexity: +-- * Initial longest-path: O(V + E) +-- * Tight-tree construction: O(V + E) +-- * Cut-value computation: O(V × E) (scans the non-tree edges for each tree edge) +-- * Iteration: 0 for uniform ω; worst case O(V × E) per iteration × V iterations in general +-- {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.DAG.Internal.Sugiyama ( -- * 中間表現 @@ -33,7 +58,7 @@ , LEdge (..) , LayoutGraph (..) , buildLayoutGraph - -- * Step 2-0 (P2a): acyclic 化 + -- * Step 2-0: acyclic 化 , breakCycles -- * Step 2: Rank assignment , assignRanks @@ -41,7 +66,7 @@ , longestPathRanking , tightTreeEdges , tightenSourceRanks - -- * 汎用 network simplex (= P4a x 座標で使う共通ソルバ) + -- * 汎用 network simplex (= x 座標割当で使う共通ソルバ) , networkSimplex , networkSimplexBalanced -- * Step 3: Order assignment (= median heuristic + transpose) @@ -56,13 +81,13 @@ , assignOrderFull , countCrossings , bilayerCrossings - -- * Step 4: Coordinate assignment (= P4a aux graph network simplex) + -- * Step 4: Coordinate assignment (= aux graph network simplex) , assignCoords , assignCoordsW , auxSimplexCoords , auxSimplexCoordsW , computeOneDir - -- * Step 5 (Phase 1 A6): Plate (= cluster) 制約 + -- * Step 5: Plate (= cluster) 制約 , applyPlateConstraints -- * Inspection (= test 用) , edgeLengthSum @@ -78,36 +103,57 @@ import qualified Data.Text as T -- =========================================================================== --- 中間表現 +-- [日本語]: 中間表現 +-- [English]: Intermediate representation -- =========================================================================== --- | 内部 node。 元の DAGNode から id を保持し、 rank を埋める。 --- dummy node (= A3 で長 edge 中継用) は 'lnDummy' で区別。 +-- | [日本語]: 内部 node。 元の DAGNode から id を保持し、 rank を埋める。 +-- dummy node (= 長 edge 中継用) は 'lnDummy' で区別。 +-- [English]: An internal node. Retains the id from the original DAGNode and +-- gets its rank filled in. A dummy node (used to relay a long edge) is +-- distinguished by 'lnDummy'. data LNode = LNode - { lnId :: !Text -- ^ 元 node id (dummy なら "__dummy_") - , lnRank :: !Int -- ^ Step 2 で割当てる rank - , lnDummy :: !Bool -- ^ A3 で長 edge を分割するために追加した dummy か + { lnId :: !Text + -- ^ [日本語]: 元 node id (dummy なら "\_\_dummy_\") + -- [English]: The original node id (or "\_\_dummy_\" for a dummy) + , lnRank :: !Int + -- ^ [日本語]: Step 2 で割当てる rank + -- [English]: The rank assigned during Step 2 + , lnDummy :: !Bool + -- ^ [日本語]: 長 edge を分割するために追加した dummy か + -- [English]: Whether this is a dummy added to split a long edge } deriving (Eq, Show) --- | 内部 edge。 weight / minimum length δ を持つ。 --- Phase 1 A2 では全 edge weight=1, delta=1 だが将来拡張余地。 +-- | [日本語]: 内部 edge。 weight / minimum length δ を持つ。 +-- 全 edge weight=1, delta=1 が default だが将来拡張余地。 +-- [English]: An internal edge, carrying a weight and a minimum length δ. +-- All edges currently default to weight=1, delta=1, with room to extend +-- this later. data LEdge = LEdge { leFrom :: !Text , leTo :: !Text - , leDelta :: !Int -- ^ 最小 rank 差 (= δ)、 default 1 - , leWeight :: !Double -- ^ edge weight (= ω)、 default 1.0 + , leDelta :: !Int + -- ^ [日本語]: 最小 rank 差 (= δ)、 default 1 + -- [English]: The minimum rank difference (δ), default 1 + , leWeight :: !Double + -- ^ [日本語]: edge weight (= ω)、 default 1.0 + -- [English]: The edge weight (ω), default 1.0 } deriving (Eq, Show) --- | Sugiyama framework の中間 graph。 +-- | [日本語]: Sugiyama framework の中間 graph。 +-- [English]: The intermediate graph used by the Sugiyama framework. data LayoutGraph = LayoutGraph { lgNodes :: ![LNode] , lgEdges :: ![LEdge] } deriving (Eq, Show) --- | 元 (id, parents) ペア群から LayoutGraph を組み立てる。 --- すべての edge は δ=1 / ω=1 で初期化。 rank は未割当 (= 0)。 +-- | [日本語]: 元 (id, parents) ペア群から LayoutGraph を組み立てる。 +-- すべての edge は δ=1 / ω=1 で初期化。 rank は未割当 (= 0)。 +-- [English]: Builds a 'LayoutGraph' from the original (id, parents) pairs. +-- Every edge is initialized with δ=1 / ω=1; ranks are unassigned (0). buildLayoutGraph - :: [Text] -- ^ 全 node id (順序保持、 stable iteration 用) + :: [Text] -- ^ [日本語]: 全 node id (順序保持、 stable iteration 用) + -- [English]: All node ids (order-preserving, for stable iteration) -> [(Text, Text)] -- ^ edge list (from, to) -> LayoutGraph buildLayoutGraph ids es = @@ -117,23 +163,42 @@ } -- =========================================================================== --- Step 2-0 (P2a): acyclic 化 (= graphviz acyclic.c 相当) +-- [日本語]: Step 2-0: acyclic 化 (= graphviz acyclic.c 相当) +-- [English]: Step 2-0: making the graph acyclic (corresponds to graphviz's acyclic.c) -- =========================================================================== --- | DFS で back-edge を検出して反転し、 self-loop は rank 制約に寄与しないので --- 除去する。 rank/order 用の acyclic edge 列を返す。 +-- | [日本語]: DFS で back-edge を検出して反転し、 self-loop は rank 制約に寄与しないので +-- 除去する。 rank/order 用の acyclic edge 列を返す。 +-- [English]: Detects back-edges via DFS and reverses them; self-loops +-- contribute nothing to the rank constraints, so they are removed. Returns +-- an acyclic edge list for use by ranking/ordering. -- --- graphviz の 'acyclic.c' (decompose + break_cycles) と同じく「閉路を一時的に --- 反転して DAG 化 → layout → 描画時に向きを戻す」 戦略の前半。 描画方向は呼出側 --- (DAG.hs) が原 edge で保持し、 chain lookup は反転 key fallback で吸収する。 +-- [日本語]: graphviz の 'acyclic.c' (decompose + break_cycles) と同じく「閉路を一時的に +-- 反転して DAG 化 → layout → 描画時に向きを戻す」 戦略の前半。 描画方向は呼出側 +-- (DAG.hs) が原 edge で保持し、 chain lookup は反転 key fallback で吸収する。 +-- [English]: This is the first half of the same strategy as graphviz's +-- 'acyclic.c' (decompose + break_cycles): "temporarily reverse cycles to +-- make the graph a DAG, lay it out, then restore the original direction at +-- draw time". The draw direction is kept by the caller (DAG.hs) using the +-- original edges, and chain lookups fall back to the reversed key. -- --- **非破壊性**: 入力が既に DAG なら back-edge は存在せず、 self-loop も無ければ --- edge は順序保持で不変。 = 現行の acyclic テストケース (large/medium/small/ --- isolated) には影響しない。 閉路入力でのみ rank が正しくなる --- (従来は 'longestPathRanking' の「0 仮置き」 で誤った rank になっていた)。 +-- [日本語]: __非破壊性__: 入力が既に DAG なら back-edge は存在せず、 self-loop も無ければ +-- edge は順序保持で不変。 = 現行の acyclic テストケース (large/medium/small/ +-- isolated) には影響しない。 閉路入力でのみ rank が正しくなる +-- (従来は 'longestPathRanking' の「0 仮置き」 で誤った rank になっていた)。 +-- [English]: __Non-destructiveness__: if the input is already a DAG, no +-- back-edges exist, and absent self-loops the edges are unchanged +-- (order-preserving) — so the existing acyclic test cases (large/medium/ +-- small/isolated) are unaffected. Only cyclic input gets a corrected rank +-- (previously, the "placeholder 0" used by 'longestPathRanking' produced an +-- incorrect rank). -- --- DFS 着色: gray = 現在の stack 上、 black = 探索完了。 (u→v) で v が gray なら --- back-edge。 起点は @ids@ 順に全 node を走査するので非連結成分も網羅する。 +-- [日本語]: DFS 着色: gray = 現在の stack 上、 black = 探索完了。 (u→v) で v が gray なら +-- back-edge。 起点は @ids@ 順に全 node を走査するので非連結成分も網羅する。 +-- [English]: DFS coloring: gray means "currently on the stack", black means +-- "search complete". For (u→v), if v is gray it is a back-edge. Since +-- traversal starts from every node in @ids@ order, disconnected components +-- are covered too. breakCycles :: [Text] -> [(Text, Text)] -> [(Text, Text)] breakCycles ids es = let adj = Map.fromListWith (flip (++)) @@ -158,20 +223,32 @@ in [ e | Just e <- map orient es ] -- =========================================================================== --- Step 2: Rank assignment (= network simplex) +-- [日本語]: Step 2: Rank assignment (= network simplex) +-- [English]: Step 2: Rank assignment (network simplex) -- =========================================================================== --- | LayoutGraph の lnRank を埋める。 Phase 1 A2 採用 = network simplex。 +-- | [日本語]: LayoutGraph の lnRank を埋める。 採用アルゴリズムは network simplex。 +-- [English]: Fills in the lnRank of a LayoutGraph, using network simplex. -- --- 流れ (Gansner 1993 §2.3): +-- [日本語]: 流れ (Gansner 1993 §2.3): -- -- 1. 'longestPathRanking' で初期 feasible ranking --- 2. 'buildTightTree' で tight edge から spanning tree --- 3. 'cutValues' で各 tree edge の cut value +-- 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 になる。 +-- [English]: Flow (Gansner 1993 §2.3): +-- +-- 1. 'longestPathRanking' produces an initial feasible ranking +-- 2. @buildTightTree@ grows a spanning tree from tight edges +-- 3. @cutValues@ computes the cut value for each tree edge +-- 4. If any tree edge has a negative cut value, replace it ('pivotOnce'); otherwise it is optimal +-- 5. After iteration finishes, normalize ranks to be 0-based +-- +-- [日本語]: 一様 δ=1 / ω=1 では step 1 で最適解。 反復は no-op になる。 +-- [English]: With uniform δ=1 / ω=1, step 1 is already optimal, so the +-- iteration is a no-op. assignRanks :: LayoutGraph -> LayoutGraph assignRanks lg0 = let lg1 = longestPathRanking lg0 @@ -179,8 +256,11 @@ lg3 = normalizeRanks lg2 in lg3 --- | Step 2-1: longest-path ranking (= 各 node に「source からの最長 path 長」 を割当)。 --- 一様 δ=1 / ω=1 では Σ edge length 最適解。 +-- | [日本語]: Step 2-1: longest-path ranking (= 各 node に「source からの最長 path 長」 を割当)。 +-- 一様 δ=1 / ω=1 では Σ edge length 最適解。 +-- [English]: Step 2-1: longest-path ranking, assigning each node "the +-- longest path length from a source". With uniform δ=1 / ω=1 this is the +-- Σ edge-length optimum. longestPathRanking :: LayoutGraph -> LayoutGraph longestPathRanking lg = let parents = Map.fromListWith (<>) @@ -205,8 +285,11 @@ | n <- lgNodes lg ] in lg { lgNodes = newNodes } --- | Step 2-2〜5: simplex 反復。 上限 iteration 内で負 cut value が無くなるまで pivot。 --- 一様 δ=1 / ω=1 では即時終了 (= 負 cut value 無し)。 +-- | [日本語]: Step 2-2〜5: simplex 反復。 上限 iteration 内で負 cut value が無くなるまで pivot。 +-- 一様 δ=1 / ω=1 では即時終了 (= 負 cut value 無し)。 +-- [English]: Steps 2-2 through 2-5: the simplex iteration. Pivots until no +-- negative cut value remains, within an iteration budget. With uniform +-- δ=1 / ω=1 it terminates immediately (no negative cut value exists). iterateSimplex :: LayoutGraph -> Int -> LayoutGraph iterateSimplex lg 0 = lg iterateSimplex lg budget = @@ -214,30 +297,53 @@ Nothing -> lg -- 最適解到達 Just lg' -> iterateSimplex lg' (budget - 1) --- | 1 回の pivot: 負 cut value の tree edge を非 tree edge と置換。 --- 該当無しなら 'Nothing'。 +-- | [日本語]: 1 回の pivot: 負 cut value の tree edge を非 tree edge と置換。 +-- 該当無しなら 'Nothing'。 +-- [English]: A single pivot: replaces a negative-cut-value tree edge with a +-- non-tree edge. Returns 'Nothing' if there is none. -- --- **設計判断 (= Phase 1 A2 honest stub)**: +-- [日本語]: __設計判断 (honest stub)__: -- --- 一様 δ=1 / ω=1 の場合、 longest-path ranking が既に Σ edge length 最適解 --- (= 各 edge の length が ≥ δ=1 の制約下で全 edge 合計を最小化、 longest-path --- は各 node を最深位置に置くので「圧縮余地ゼロ」)。 したがって全 tree edge の --- cut value は ≥ 0 になることが保証され、 pivot は発生しない。 +-- 一様 δ=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' は初期解で即終了する。 +-- [English]: __Design rationale (honest stub)__: -- --- 拡張時の実装方針 (TODO Phase 1+): +-- With uniform δ=1 / ω=1, longest-path ranking is already the Σ +-- edge-length optimum (proof: it minimizes the total under the constraint +-- that each edge's length is ≥ δ=1, since longest-path places every node +-- at its deepest possible position, leaving "zero room to compress"). This +-- guarantees every tree edge's cut value is ≥ 0, so no pivot ever occurs. -- +-- [日本語]: 本関数は __将来 weight / 異 δ 拡張に備えた framework hook__。 現状は常に +-- 'Nothing' を返し、 'iterateSimplex' は初期解で即終了する。 +-- [English]: This function is a __framework hook in preparation for future weight / non-uniform-δ extensions__. +-- It currently always returns 'Nothing', so 'iterateSimplex' terminates at +-- the initial solution. +-- +-- [日本語]: 拡張時の実装方針 (TODO): +-- -- 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 で置換 +-- +-- [English]: Implementation plan for when this is extended (TODO): +-- +-- 1. Extract a spanning tree from tight edges via 'tightTreeEdges' +-- 2. For each tree edge, find the head/tail-side partition it induces by cutting it, via BFS +-- 3. Compute the cut value from the non-tree edge weight differences +-- 4. If the minimum cut value is < 0, replace it with the min-slack non-tree edge pivotOnce :: LayoutGraph -> Maybe LayoutGraph pivotOnce _ = Nothing --- | tight tree edge (= rank(v) - rank(u) = δ(u,v) を満たす edge) を列挙。 --- pivot 実装時の前段として用意。 現状未使用。 +-- | [日本語]: tight tree edge (= rank(v) - rank(u) = δ(u,v) を満たす edge) を列挙。 +-- pivot 実装時の前段として用意。 現状未使用。 +-- [English]: Enumerates tight tree edges (edges satisfying rank(v) - +-- rank(u) = δ(u,v)). Prepared as a building block for when pivoting is +-- implemented; currently unused. tightTreeEdges :: LayoutGraph -> [LEdge] tightTreeEdges lg = let rankOf = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] @@ -246,7 +352,8 @@ _ -> False in filter isTight (lgEdges lg) --- | rank を 0-base に正規化 (= 最小 rank を 0 に shift)。 +-- | [日本語]: rank を 0-base に正規化 (= 最小 rank を 0 に shift)。 +-- [English]: Normalizes ranks to be 0-based (shifts so the minimum rank is 0). normalizeRanks :: LayoutGraph -> LayoutGraph normalizeRanks lg = case lgNodes lg of @@ -256,20 +363,39 @@ newNodes = [ n { lnRank = lnRank n - rmin } | n <- ns ] in lg { lgNodes = newNodes } --- | Phase 19 A4: rank 引き締め ('assignRanks' の後処理)。 +-- | [日本語]: 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 データノードで顕在化)。 +-- ① __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 (= 既存図はビット不変)。 +-- 最後に 0-base へ再正規化する。 plate 無し・深い source 無しのグラフでは +-- no-op (= 既存図はビット不変)。 +-- +-- [English]: Tightens ranks (post-processing after 'assignRanks'). +-- +-- ① __Pull sources down__: a node with no in-edges and at least one +-- out-edge is moved to @min(rank(succ) − δ)@. Because longest-path +-- ranking pins sources to rank 0, a source with only deep consumers +-- (a data slot, sigma, etc.) has its edge span the whole figure, +-- stretching the plate bbox (the bounding box over its members) +-- vertically, and the Σ edge length is no longer optimal (graphviz +-- places sources at the rank right before their consumer). The +-- constraint rank difference ≥ δ over all out-edges is preserved by +-- how the min is taken. +-- ② __Pull in edgeless plate members__: a node with no edges at all that +-- is a plate member is moved to the minimum rank among the (edged) +-- members of the same plate (resolves "floating" members, seen with +-- analyze's DataIx data nodes). +-- +-- Finally re-normalizes to 0-based. This is a no-op for graphs with no +-- plates and no deep sources (existing figures are bit-identical). tightenSourceRanks :: [[Text]] -> LayoutGraph -> LayoutGraph tightenSourceRanks plateMembers lg = let nodes = lgNodes lg @@ -307,29 +433,55 @@ in normalizeRanks lg { lgNodes = newNodes } -- =========================================================================== --- Step 2-1 (P3e 前提・Phase 53 A3-2): rank=same 制約付き rank 割当 +-- [日本語]: Step 2-1 (rank=same 制約の前提): rank=same 制約付き rank 割当 +-- [English]: Step 2-1 (a prerequisite for rank=same constraints): rank assignment with rank=same constraints -- =========================================================================== --- | graphviz @rank=same@ 相当: 同 rank group を代表 node に併合して rank 割当 --- (= graphviz cluster collapse / @UF_union@) し、 member へ rank を展開する。 +-- | [日本語]: graphviz @rank=same@ 相当: 同 rank group を代表 node に併合して rank 割当 +-- (= graphviz cluster collapse / @UF_union@) し、 member へ rank を展開する。 +-- [English]: The equivalent of graphviz's @rank=same@: merges each +-- same-rank group into a representative node for rank assignment +-- (analogous to graphviz's cluster collapse / @UF_union@), then propagates +-- the resulting rank back out to the members. -- --- 戻り値の edge は rank 向きに正規化済: +-- [日本語]: 戻り値の edge は rank 向きに正規化済: -- -- * rank(from) < rank(to) はそのまま、 逆なら反転 (= 'breakCycles' の back-edge -- 反転と同値。 呼出側の chain lookup は既存の反転 key fallback で吸収) --- * rank(from) == rank(to) (= **flat edge**、 group 内 edge のみで発生) は +-- * 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 で担保)。 +-- [English]: The returned edges are already normalized to point in the +-- rank direction: +-- +-- * rank(from) < rank(to) is kept as-is; the reverse case is flipped (this +-- is equivalent to the back-edge reversal done by 'breakCycles' — the +-- caller's chain lookup absorbs it via the existing reversed-key fallback) +-- * rank(from) == rank(to) (a __flat edge__, which only arises from +-- within-group edges) keeps its original direction. It contributes +-- nothing to the ranking constraints (it becomes a self-loop after +-- merging and is excluded) +-- * self-loops are removed (as in 'breakCycles') +-- +-- [日本語]: @groups = []@ では rep = id で全経路が既存と一致し、 出力 LayoutGraph は +-- 従来の breakCycles → assignRanks → tightenSourceRanks とビット一致する +-- (orient は「back-edge 反転後の rank 差 ≥ 1」 の不変量により DFS 反転と同値。 +-- test で担保)。 +-- [English]: With @groups = []@, rep is the identity on every path, so the +-- output 'LayoutGraph' is bit-identical to the previous +-- breakCycles → assignRanks → tightenSourceRanks pipeline (orient is +-- equivalent to the DFS reversal by the invariant "rank difference ≥ 1 +-- after back-edge reversal"; guaranteed by tests). assignRanksGrouped - :: [[Text]] -- ^ 同 rank group 群 (member 共有 group は併合される) - -> [[Text]] -- ^ plate member 群 (= 'tightenSourceRanks' 用) - -> [Text] -- ^ 全 node id (順序保持) - -> [(Text, Text)] -- ^ 原 edge 列 (向き任意、 self-loop 可) + :: [[Text]] -- ^ [日本語]: 同 rank group 群 (member 共有 group は併合される) + -- [English]: The same-rank groups (groups sharing a member are merged) + -> [[Text]] -- ^ [日本語]: plate member 群 (= 'tightenSourceRanks' 用) + -- [English]: The plate member groups (for 'tightenSourceRanks') + -> [Text] -- ^ [日本語]: 全 node id (順序保持) + -- [English]: All node ids (order-preserving) + -> [(Text, Text)] -- ^ [日本語]: 原 edge 列 (向き任意、 self-loop 可) + -- [English]: The original edge list (any direction, self-loops allowed) -> LayoutGraph assignRanksGrouped groups plateIds ids es = let -- group の併合 (member 共有 = 同値類)。 rep = ids 中で最初に現れる member @@ -365,7 +517,8 @@ edges = [ LEdge f t 1 1.0 | Just (f, t) <- map orient es ] in LayoutGraph nodes edges --- | 順序保持の重複除去 (= 最初の出現のみ残す)。 +-- | [日本語]: 順序保持の重複除去 (= 最初の出現のみ残す)。 +-- [English]: Order-preserving deduplication (keeps only the first occurrence). dedupStable :: [Text] -> [Text] dedupStable = go Set.empty where @@ -375,11 +528,14 @@ | otherwise = x : go (Set.insert x seen) xs -- =========================================================================== --- Inspection (= test 用) +-- [日本語]: Inspection (= test 用) +-- [English]: Inspection helpers (for tests) -- =========================================================================== --- | Σ ω(u,v) × (rank(v) - rank(u)) を返す (= rank assignment の目的関数)。 --- longest-path / network simplex の検算用。 +-- | [日本語]: Σ ω(u,v) × (rank(v) - rank(u)) を返す (= rank assignment の目的関数)。 +-- longest-path / network simplex の検算用。 +-- [English]: Returns Σ ω(u,v) × (rank(v) - rank(u)) (the objective function +-- of rank assignment). Used to check longest-path / network simplex results. edgeLengthSum :: LayoutGraph -> Double edgeLengthSum lg = let rankOf = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] @@ -388,7 +544,8 @@ _ -> 0 in sum (map contrib (lgEdges lg)) --- | feasibility check: 全 edge で rank(v) - rank(u) ≥ δ(u,v)。 +-- | [日本語]: feasibility check: 全 edge で rank(v) - rank(u) ≥ δ(u,v)。 +-- [English]: Feasibility check: every edge satisfies rank(v) - rank(u) ≥ δ(u,v). isFeasible :: LayoutGraph -> Bool isFeasible lg = let rankOf = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] @@ -398,7 +555,7 @@ in all check (lgEdges lg) -- =========================================================================== --- 汎用 network simplex (Gansner-Koutsofios-North-Vo 1993 §2.3) +-- [日本語]: 汎用 network simplex (Gansner-Koutsofios-North-Vo 1993 §2.3) -- = graphviz の network simplex に相当する共通ソルバ。 node 集合と -- (tail, head, δ, ω) edge 群を受け、 各 node に整数座標 r を割当て -- Σ ω · (r_head − r_tail) @@ -407,7 +564,7 @@ -- graphviz では rank.c (rank 割当) と position.c (x 座標 = aux graph 上の -- 同 simplex) の両方がこれを使う。 本実装では ranking は一様 δ=ω=1 で -- longest-path が既に最適なため 'assignRanks' はそのまま据え置き、 本関数は --- 主に P4a x 座標割当 (= Ω 1:2:8 + nodesep の非一様 aux graph) で使う。 +-- 主に x 座標割当 (= Ω 1:2:8 + nodesep の非一様 aux graph) で使う。 -- -- 流れ: -- 1. initRankNS : longest-path で feasible 初期解 (入力は DAG 前提) @@ -419,16 +576,49 @@ -- 5. normalizeNS : 最小 r を 0 に -- -- 非連結 graph は弱連結成分ごとに独立フレームで解く。 +-- +-- [English]: General-purpose network simplex (Gansner-Koutsofios-North-Vo +-- 1993 §2.3) — the shared solver corresponding to graphviz's network +-- simplex. Given a node set and (tail, head, δ, ω) edges, it assigns an +-- integer coordinate r to each node, minimizing +-- Σ ω · (r_head − r_tail) +-- subject to r_head − r_tail ≥ δ. +-- +-- In graphviz, both rank.c (rank assignment) and position.c (x-coordinate +-- assignment — the same simplex, on the aux graph) use this. Here, ranking +-- uses uniform δ=ω=1 where longest-path is already optimal, so 'assignRanks' +-- is left as-is; this function is used mainly for x-coordinate assignment +-- (the non-uniform aux graph with the Ω 1:2:8 weighting plus nodesep). +-- +-- Flow: +-- 1. initRankNS : a feasible initial solution via longest-path (input assumed a DAG) +-- 2. feasibleTreeNS : grows a spanning tree from tight edges (adjusted via min-slack) +-- 3. tightRanksTree : the unique assignment that makes the tree all-tight (the +-- global shift freedom is fixed by root=0) +-- 4. optimize : swaps a negative-cut-value tree edge for the min-slack +-- non-tree edge crossing the cut in the opposite direction, +-- then re-assigns with the new tree +-- 5. normalizeNS : shifts the minimum r to 0 +-- +-- Disconnected graphs are solved independently per weakly-connected component. -- =========================================================================== --- | 汎用 network simplex。 戻り値は全 node の整数座標 (= rank / x)。 --- balance は行わない (= ranking 用・最適頂点を 1 つ返す)。 +-- | [日本語]: 汎用 network simplex。 戻り値は全 node の整数座標 (= rank / x)。 +-- balance は行わない (= ranking 用・最適頂点を 1 つ返す)。 +-- [English]: The general-purpose network simplex. Returns an integer +-- coordinate (rank / x) for every node. Performs no balancing — this is +-- for ranking, returning one optimal vertex. 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 を隣接の重心へ寄せ左右対称にする)。 +-- | [日本語]: LR balance 付き network simplex (= graphviz position.c の @rank(g, 2)@ 相当)。 +-- 最適到達後、 cut value 0 の tree edge を slack の中央へ寄せて対称化する +-- (= x 座標割当用。 free node を隣接の重心へ寄せ左右対称にする)。 +-- [English]: Network simplex with LR balancing (corresponds to graphviz +-- position.c's @rank(g, 2)@). After reaching the optimum, tree edges with +-- cut value 0 are moved to the middle of their slack to symmetrize the +-- layout (used for x-coordinate assignment, pulling free nodes toward +-- their neighbors' centroid for left-right symmetry). networkSimplexBalanced :: [Text] -> [(Text, Text, Int, Double)] -> Map Text Int networkSimplexBalanced = networkSimplexWith True @@ -437,7 +627,9 @@ networkSimplexWith balance nodes edges = Map.unions [ solveComponent balance cn ce | (cn, ce) <- weakComponents nodes edges ] --- | 弱連結成分に分解 (edge を無向視)。 edge を持たない孤立 node も 1 成分。 +-- | [日本語]: 弱連結成分に分解 (edge を無向視)。 edge を持たない孤立 node も 1 成分。 +-- [English]: Decomposes into weakly-connected components (treating edges as +-- undirected). An isolated node with no edges is also its own component. weakComponents :: [Text] -> [(Text, Text, Int, Double)] -> [([Text], [(Text, Text, Int, Double)])] @@ -460,7 +652,9 @@ (_, comps) = foldl' go (Set.empty, []) nodes in comps --- | 連結成分 1 個を解く。 @balance@ なら最後に LR balance を掛ける。 +-- | [日本語]: 連結成分 1 個を解く。 @balance@ なら最後に LR balance を掛ける。 +-- [English]: Solves a single connected component. Applies LR balancing at +-- the end if @balance@ is set. solveComponent :: Bool -> [Text] -> [(Text, Text, Int, Double)] -> Map Text Int solveComponent balance cnodes cedges @@ -475,7 +669,9 @@ rB = if balance then balanceLR cnodes cedges treeF rF else rF in normalizeNS rB --- | longest-path feasible 初期 rank (各 node = source からの δ 重み最長 path)。 +-- | [日本語]: longest-path feasible 初期 rank (各 node = source からの δ 重み最長 path)。 +-- [English]: A feasible initial rank via longest-path (each node gets the +-- δ-weighted longest path from a source). initRankNS :: [Text] -> [(Text, Text, Int, Double)] -> Map Text Int initRankNS cnodes cedges = let parents = Map.fromListWith (<>) @@ -493,14 +689,19 @@ 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)。 +-- | [日本語]: edge の slack = r_head − r_tail − δ (≥ 0 が feasible)。 +-- [English]: An edge's slack, r_head − r_tail − δ (feasible when ≥ 0). 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)。 +-- | [日本語]: tight edge で spanning tree を成長させ tree edge index 集合を返す。 +-- spanning に満たない間は min-slack の incident 非 tree edge を選び tree を +-- 平行移動して tight 化し、 再成長する (Gansner93 feasible_tree)。 +-- [English]: Grows a spanning tree from tight edges and returns the set of +-- tree edge indices. While the tree does not yet span, it picks the +-- min-slack incident non-tree edge, shifts the tree to make it tight, and +-- grows it again (Gansner93's feasible_tree). feasibleTreeNS :: [Text] -> [(Text, Text, Int, Double)] -> Map Text Int -> Set.Set Int feasibleTreeNS cnodes cedges r0 = @@ -540,7 +741,9 @@ in loop r' in loop r0 --- | spanning tree を全 edge tight にする一意 rank (root=start を 0 に固定)。 +-- | [日本語]: spanning tree を全 edge tight にする一意 rank (root=start を 0 に固定)。 +-- [English]: The unique rank that makes every edge of a spanning tree +-- tight (fixes root=start to 0). tightRanksTree :: [Text] -> [(Text, Text, Int, Double)] -> Set.Set Int -> Map Text Int tightRanksTree cnodes cedges tree = @@ -563,8 +766,10 @@ 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 で再利用する。 +-- | [日本語]: negative cut value の tree edge を解消するまで pivot。 +-- 戻り値 = (最終 spanning tree, rank)。 tree は balance で再利用する。 +-- [English]: Pivots until no tree edge has a negative cut value. Returns +-- (the final spanning tree, the rank); the tree is reused for balancing. optimizeNS :: Int -> [Text] -> [(Text, Text, Int, Double)] -> Set.Set Int -> Map Text Int -> (Set.Set Int, Map Text Int) @@ -614,10 +819,16 @@ 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 と同様)。 +-- | [日本語]: 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 と同様)。 +-- [English]: LR balancing (graphviz ns.c's @balance@, mode 2). Enumerates +-- tree edges with cut value 0, and for each, shifts its tail-side +-- component toward the center by half the slack δ (the room to move) of +-- the non-tree edge crossing it in the opposite direction. The cost is +-- unchanged (cut=0 means the derivative is 0), so this symmetrizes free +-- nodes while preserving optimality. A single pass, as in graphviz. balanceLR :: [Text] -> [(Text, Text, Int, Double)] -> Set.Set Int -> Map Text Int -> Map Text Int @@ -661,31 +872,47 @@ -- tail 側を持つ tree edge のみ対象 (LR/straightening 両方含む) in foldl' step rank0 (Set.toList tree) --- | 最小座標を 0 に正規化。 +-- | [日本語]: 最小座標を 0 に正規化。 +-- [English]: Normalizes the minimum coordinate to 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) +-- [日本語]: Step 3: Order assignment -- Gansner-Koutsofios-North-Vo 1993 §3、 dot default 24 iteration の -- median heuristic + transpose で同 rank 内の node 順を最適化。 -- 長 edge (rank 差 > 1) は dummy node 経由の short edge 列に展開する。 +-- [English]: Step 3: Order assignment. Optimizes node order within each rank +-- using the median heuristic + transpose over dot's default 24 iterations +-- (Gansner-Koutsofios-North-Vo 1993 §3). A long edge (rank difference > 1) +-- is expanded into a chain of short edges routed through dummy nodes. -- =========================================================================== --- | 各 rank の node 順 (= rank → 左から右の id 列)。 +-- | [日本語]: 各 rank の node 順 (= rank → 左から右の id 列)。 +-- [English]: The node order within each rank (rank to a left-to-right id list). type OrderMap = Map Int [Text] --- | 長 edge (= rank 差 > 1) を中間 rank の dummy node 経由の短 edge 列に展開。 --- dummy node は 'lnDummy = True' で区別、 id は @"__dummy_"@。 --- 元 edge は削除され、 同 weight の短 edge 列に置換される。 +-- | [日本語]: 長 edge (= rank 差 > 1) を中間 rank の dummy node 経由の短 edge 列に展開。 +-- dummy node は 'lnDummy = True' で区別、 id は @"\_\_dummy_\"@。 +-- 元 edge は削除され、 同 weight の短 edge 列に置換される。 +-- [English]: Expands a long edge (rank difference > 1) into a chain of +-- short edges routed through dummy nodes at the intermediate ranks. Dummy +-- nodes are distinguished by 'lnDummy = True', with ids of the form +-- @"\_\_dummy_\"@. The original edge is removed and replaced by a chain of +-- short edges carrying the same weight. 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 点列で描画するために使う。 +-- | [日本語]: 'insertDummies' + 元 edge → 経由 chain (= 始点と終点を含む id 列) を返す。 +-- 短 edge (rank 差 1) も map に含まれ、 chain = [from, to] (= 2 要素)。 +-- edge routing で、 元 edge を chain 経由の control 点列で描画するために使う。 +-- [English]: 'insertDummies' plus a map from the original edge to the chain +-- it is routed through (an id list including both endpoints). Short edges +-- (rank difference 1) are included too, as chain = [from, to] (2 +-- elements). Used by edge routing to draw the original edge through the +-- chain's control points. insertDummiesWithChains :: LayoutGraph -> (LayoutGraph, Map (Text, Text) [Text]) insertDummiesWithChains lg = @@ -714,15 +941,19 @@ in ( lg { lgNodes = lgNodes lg ++ extra, lgEdges = newEdges } , chainMap ) --- | rank ごとの初期順序 (= ID 辞書順、 決定論性のため)。 +-- | [日本語]: rank ごとの初期順序 (= ID 辞書順、 決定論性のため)。 +-- [English]: The initial order within each rank (lexicographic by id, for determinism). 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。 +-- | [日本語]: 2 隣接 rank 間の交差数 (naive O(E^2))。 +-- @edges@ は (u, v) ペア、 u は upper の id、 v は lower の id。 +-- [English]: The number of crossings between two adjacent ranks (naive +-- O(E^2)). @edges@ is a list of (u, v) pairs, where u is the upper rank's +-- id and v is the lower rank's id. bilayerCrossings :: [(Text, Text)] -> [Text] -> [Text] -> Int bilayerCrossings edges upper lower = let posU = Map.fromList (zip upper [0 :: Int ..]) @@ -739,7 +970,8 @@ in c + go rest in go pairs --- | 全 rank pair の交差数合計。 +-- | [日本語]: 全 rank pair の交差数合計。 +-- [English]: The total crossing count summed over all rank pairs. countCrossings :: LayoutGraph -> OrderMap -> Int countCrossings lg om = let rankMap = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] @@ -755,7 +987,9 @@ (Map.findWithDefault [] (r + 1) om) | r <- [0 .. maxR - 1] ] --- | median: 偶数個なら 2 中央値の平均、 奇数個なら中央。 +-- | [日本語]: median: 偶数個なら 2 中央値の平均、 奇数個なら中央。 +-- [English]: The median: the average of the two middle values for an even +-- count, or the middle value for an odd count. medianOf :: [Double] -> Maybe Double medianOf [] = Nothing medianOf xs = @@ -766,8 +1000,11 @@ then s !! mid else (s !! (mid - 1) + s !! mid) / 2 --- | 1 回 sweep (= median heuristic 1 pass)。 --- 'topDown' True = rank 増加方向、 False = 減少方向。 +-- | [日本語]: 1 回 sweep (= median heuristic 1 pass)。 +-- @topDown@ True = rank 増加方向、 False = 減少方向。 +-- [English]: A single sweep (one pass of the median heuristic). @topDown@ +-- True sweeps in the direction of increasing rank, False the decreasing +-- direction. medianSweep :: LayoutGraph -> Bool -> OrderMap -> OrderMap medianSweep lg topDown om0 = let ranks = sort (Map.keys om0) @@ -795,8 +1032,11 @@ in Map.insert r [ v | (_, v, _) <- sorted ] om' in foldl' (flip sweepOne) om0 sweepDir --- | transpose: 同 rank 内の隣接 pair を試し交換、 交差数が下がるなら採用。 --- 上下 rank の edge を両方見て判定。 +-- | [日本語]: transpose: 同 rank 内の隣接 pair を試し交換、 交差数が下がるなら採用。 +-- 上下 rank の edge を両方見て判定。 +-- [English]: Transpose: tries swapping adjacent pairs within a rank and +-- keeps the swap if it reduces the crossing count, judged by looking at +-- edges to both the rank above and below. transposeOrder :: LayoutGraph -> OrderMap -> OrderMap transposeOrder lg om0 = let rankMap = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] @@ -830,12 +1070,20 @@ 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 では全体が恒等、 既存図ビット不変)。 +-- | [日本語]: 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 では全体が恒等、 既存図ビット不変)。 +-- [English]: The ordering constraint for flat edges (same-rank edges). +-- Corresponds to graphviz @mincross.c@'s @flat_breakcycles@ + +-- @flat_reorder@: within each rank, reorders via a stable topological sort +-- that minimizes disturbance to the current order, so that flat edges +-- point left-to-right. Cycles among flat edges are broken deterministically +-- by 'breakCycles' (DFS over the current order). Ranks with no flat edges +-- are unchanged (identity when the graph has no flat edges at all, +-- preserving existing figures bit-for-bit). flatReorder :: LayoutGraph -> OrderMap -> OrderMap flatReorder lg om0 = let rankMap = Map.fromList [ (lnId n, lnRank n) | n <- lgNodes lg ] @@ -872,18 +1120,31 @@ 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 も含む。 +-- | [日本語]: Step 3 メイン: dummy 挿入 + 24 iteration median sweep + transpose。 +-- 戻り値 = (拡張済 LayoutGraph、 OrderMap)。 OrderMap は dummy も含む。 +-- [English]: The Step 3 main entry point: dummy insertion, then 24 +-- iterations of the median sweep plus transpose. Returns (the expanded +-- LayoutGraph, the OrderMap); the OrderMap includes dummies too. assignOrder :: LayoutGraph -> (LayoutGraph, OrderMap) assignOrder lg0 = let (a, b, _) = assignOrderFull lg0 in (a, b) --- | 'assignOrder' + 元 edge → chain map (= A5 edge routing 用)。 +-- | [日本語]: 'assignOrder' + 元 edge → chain map (= edge routing 用) を返す。 +-- [English]: 'assignOrder' plus a map from the original edge to its chain +-- (used for 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 に記載)。 +-- [日本語]: flat edge があれば初期順序と各 iteration 後に +-- 'flatReorder' を適用する (medianSweep / transpose は inter-rank edge しか +-- 見ないため、 flat 制約は都度回復させる)。 flat edge 交差は countCrossings の +-- 目的関数に__含めない__ (graphviz は flat も ncross に数えるが、 現用途の flat は +-- group 内の少数 edge で左→右向きの保証が主目的。 差分は correspondence doc に記載)。 +-- [English]: If flat edges are present, 'flatReorder' is applied both to +-- the initial order and after each iteration (since medianSweep / +-- transpose only look at inter-rank edges, the flat constraint has to be +-- restored every time). Flat-edge crossings are __not included__ in +-- countCrossings's objective function (graphviz does count flat edges in +-- ncross, but here flat edges are typically a small number of within-group +-- edges whose main purpose is guaranteeing left-to-right orientation; the +-- difference is documented in the correspondence doc). assignOrderFull :: LayoutGraph -> (LayoutGraph, OrderMap, Map (Text, Text) [Text]) @@ -905,33 +1166,60 @@ 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: Coordinate assignment +-- Brandes-Köpf 4-candidate から graphviz position.c 忠実の aux graph network +-- simplex ('auxSimplexCoordsW') に置換済。 旧 BK 実装 (brandesKopf / runBK / +-- markType1 / verticalAlign / horizCompact / bk 定数) は呼び出し元ゼロのまま +-- 残っていたため物理削除 (実装は git 履歴参照)。 +-- [English]: Step 4: Coordinate assignment. Replaced the Brandes-Köpf +-- 4-candidate approach with an aux-graph network simplex +-- ('auxSimplexCoordsW') that faithfully follows graphviz's position.c. The +-- old BK implementation (brandesKopf / runBK / markType1 / verticalAlign / +-- horizCompact / the bk constants) had zero remaining callers and was +-- physically deleted (see git history for the old implementation). -- =========================================================================== --- | Step 4 メイン: x 座標を割当て [0,1] 正規化。 --- 結果は OrderMap に含まれる全 node id (= dummy 含む) → x ∈ [0,1]。 +-- | [日本語]: Step 4 メイン: x 座標を割当て [0,1] 正規化。 +-- 結果は OrderMap に含まれる全 node id (= dummy 含む) → x ∈ [0,1]。 +-- [English]: The Step 4 main entry point: assigns x coordinates, normalized +-- to [0,1]. The result maps every node id in the OrderMap (dummies +-- included) to 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≥) を検証する。 +-- [日本語]: 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 層 主因を根治)。 +-- @plates@ (= cluster メンバ id 群) を aux graph simplex に渡し、 +-- cluster border 制約 ('clusterAuxEdges') を反映した x を解く。 plate 無し ([]) は +-- 従来と完全同一。 +-- [English]: Following graphviz's position.c, replaces Brandes-Köpf with an +-- __aux graph network simplex__ ('auxSimplexCoords'). It jointly optimizes, +-- as part of the simplex's objective/constraints, two things BK lacked — a +-- "dummy-chain straightening weight" (Ω 1:2:8) and "enforced nodesep +-- between adjacent pairs" — which separates a long edge's dummy chain into +-- an independent column outside the parallel node column (fixing the root +-- cause of the "large" example's funnel collapse at the layout level). +-- @plates@ (cluster member id groups) are passed into the aux-graph +-- simplex, which solves for x while honoring cluster-border constraints +-- ('clusterAuxEdges'). With no plates ([]), the result is unchanged. +-- +-- | [日本語]: 後方互換 wrapper (= 半幅情報なし = 全 real node 一律 'auxNodeHalfW')。 +-- test 群はこちらを使い構造的不変条件 (collinear / keepout / gap≥) を検証する。 +-- [English]: A backward-compatible wrapper (no per-node half-width info — +-- uses 'auxNodeHalfW' uniformly for every real node). Test suites use this +-- to check structural invariants (collinearity / 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 重なり根治)。 +-- | [日本語]: size-aware 版。 @hwMap@ = real node id → 横半幅 (px, 整数) +-- ('Graphics.Hgg.Layout.dagNodeBaseHalfWidth' を round したもの・DAG.coordStage が供給)。 simplex の +-- node 間隔/cluster border 制約を実 node 幅で解く (= 兄弟 plate の box 重なり根治)。 +-- [English]: The size-aware variant. @hwMap@ maps a real node id to its +-- horizontal half-width in px (an integer, the rounded +-- 'Graphics.Hgg.Layout.dagNodeBaseHalfWidth', supplied by DAG.coordStage). Solves the simplex's +-- node-spacing / cluster-border constraints using actual node widths +-- (fixing the root cause of sibling plate boxes overlapping). assignCoordsW :: Map Text Int -> [[Text]] -> LayoutGraph -> OrderMap -> Map Text Double assignCoordsW hwMap plates lg om = let raw = auxSimplexCoordsW hwMap plates lg om @@ -943,7 +1231,7 @@ in Map.map norm raw -- =========================================================================== --- Step 4 (Phase 39 Step3 = P4a): aux graph network simplex で x 座標 +-- [日本語]: Step 4 (aux graph network simplex で x 座標) -- graphviz position.c の @dot_position@ = -- create_aux_edges → rank(aux, 2 = LR balance) → remove_aux_edges -- を移植。 補助グラフは @@ -956,52 +1244,105 @@ -- (= 順序保持 + 最小間隔強制)。 dummy 絡みは間隔を詰める。 -- この aux graph 上で 'networkSimplexBalanced' を解くと、 並走する実 node 列と -- long-edge dummy 列が nodesep 以上離れた独立縦列になる。 +-- [English]: Step 4 (x-coordinate assignment via aux-graph network simplex). +-- Ports graphviz position.c's @dot_position@ = +-- create_aux_edges → rank(aux, 2 = LR balance) → remove_aux_edges. +-- The auxiliary graph consists of: +-- ① straightening: each layout edge (u,v) is turned into an aux node +-- a_e plus two minlen-0 edges a_e→u, a_e→v (weight Ω). a_e floats to +-- min(x_u,x_v), and cost = Ω·|x_u − x_v| (straightening). Ω depends +-- on the endpoint kinds: +-- real-real 1 : real-virtual 2 : virtual-virtual 8 +-- (dot's default ratio, keeping dummy chains straighter the longer they are). +-- ② LR constraint: an edge l→r for each same-rank adjacent pair (l,r), +-- with minlen = nodesep and weight 0 (preserves order and enforces +-- minimum spacing). Dummy-involved pairs get tighter spacing. +-- Solving 'networkSimplexBalanced' on this aux graph makes the parallel +-- real-node column and the long-edge dummy column separate into +-- independent columns at least nodesep apart. -- =========================================================================== --- | LR 制約の最小間隔 = graphviz make_LR_constraints の +-- | [日本語]: 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 層 主因を根治)。 +-- 各 node の __半幅__ + nodesep の和を隣接間隔とする。 これにより +-- real node の隣に来る dummy は real の半幅ぶん外へ押し出され、 real node の +-- body 内側に潜り込まない (= long-edge dummy 列が並走 chain の node body の外に +-- 出る = funnel collapse の layout 層 主因を根治)。 +-- [English]: The minimum LR-constraint spacing, ported from graphviz +-- make_LR_constraints's @width = ND_rw(left) + ND_lw(right) + nodesep@. The +-- spacing between neighbors is the sum of each node's __half-width__ plus +-- nodesep. This pushes a dummy sitting next to a real node outward by the +-- real node's half-width, so it never sinks inside the real node's body +-- (fixing the root cause of the funnel collapse at the layout level, where +-- a long edge's dummy column used to poke into the body of a parallel +-- node chain). -- --- 旧実装は dummy 絡みを一律に小間隔 (= 旧 BK bkDummySpacing 0.4) にしており、 --- dummy が real node body の内側に入っていた (= 並走 chain を貫通) のが large の --- 主因だった。 +-- [日本語]: 旧実装は dummy 絡みを一律に小間隔 (= 旧 BK bkDummySpacing 0.4) にしており、 +-- dummy が real node body の内側に入っていた (= 並走 chain を貫通) のが large の +-- 主因だった。 +-- [English]: The old implementation used a uniform small spacing for +-- anything involving a dummy (the old BK's bkDummySpacing 0.4), which let +-- dummies sit inside a real node's body (piercing a parallel chain) — the +-- main cause of the problem in the "large" example. -- --- 値は **偶数**にする: 全 minlen 偶数 → 全 rank 偶数和 → LR balance の --- @delta `div` 2@ が丸め無しで厳密中央化される。 +-- [日本語]: 値は __偶数__にする: 全 minlen 偶数 → 全 rank 偶数和 → LR balance の +-- @delta `div` 2@ が丸め無しで厳密中央化される。 +-- [English]: The value is kept __even__: all-even minlens give an +-- all-even rank sum, so LR balancing's @delta `div` 2@ centers exactly, +-- with no rounding. -- --- 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') に戻した。 size-aware +-- (per-node 幅) は非兄弟グラフの位置を動かし long-edge routing を折る回帰を生んだ +-- (実測 2026-06-24)。 兄弟 plate box の重なりは separate_subclust (normalized gap) +-- + render binding-pair (実幅は radius 既知の render で考慮) で解く。 +-- [English]: Half-widths were reverted to __uniform__ ('auxNodeHalfW'). +-- Making them size-aware (per-node width) moved unrelated (non-sibling) +-- graph positions and caused a regression that broke long-edge routing +-- (measured 2026-06-24). Overlap between sibling plate boxes is instead +-- resolved by separate_subclust (a normalized gap) plus the render-side +-- binding-pair step (which accounts for the actual width, known at render +-- time via the radius). 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 一貫) +auxNodeSep = 18 -- EXPERIMENT: graphviz nodesep 既定 18pt (point 一貫) --- | Phase 39 Step8 (P8): cluster (= plate) box の margin。 graphviz @CL_OFFSET@=8pt。 +-- | [日本語]: cluster (= plate) box の margin。 graphviz @CL_OFFSET@=8pt。 +-- [English]: The cluster (plate) box margin. graphviz's @CL_OFFSET@ = 8pt. auxPlateMargin :: Int auxPlateMargin = 8 --- | node a と b (= 同 rank で a が左・b が右隣) の最小間隔。 --- @hwOf@ = 各 node の半幅 (px・dummy/欠落は内部 fallback 済)。 +-- | [日本語]: node a と b (= 同 rank で a が左・b が右隣) の最小間隔。 +-- @hwOf@ = 各 node の半幅 (px・dummy/欠落は内部 fallback 済)。 +-- [English]: The minimum spacing between nodes a and b (same rank, a on +-- the left, b on the right). @hwOf@ gives each node's half-width in px +-- (dummies / missing entries already fall back internally). 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' 側。 +-- | [日本語]: aux graph を構築し simplex で x (整数) を解いて Double で返す。 +-- 戻り値 = 実 node (dummy 含む・aux 除く) の raw x。 正規化は 'assignCoords' 側。 +-- [English]: Builds the aux graph, solves for integer x via simplex, and +-- returns it as a Double. The result is the raw x of real nodes (dummies +-- included, aux nodes excluded); normalization happens in 'assignCoords'. -- --- Phase 39 Step8 (P8): 'plates' (= cluster メンバ id リスト群) があれば --- 'clusterAuxEdges' で graphviz position.c @pos_clusters@ 相当の cluster x 制約 --- (border node + contain/keepout edge) を aux graph に追加する。 plate 無しは --- 従来と完全同一 (= 図ビット不変)。 +-- [日本語]: @plates@ (= cluster メンバ id リスト群) があれば +-- 'clusterAuxEdges' で graphviz position.c @pos_clusters@ 相当の cluster x 制約 +-- (border node + contain/keepout edge) を aux graph に追加する。 plate 無しは +-- 従来と完全同一 (= 図ビット不変)。 +-- [English]: When @plates@ (cluster member id list groups) are given, +-- 'clusterAuxEdges' adds cluster x-constraints equivalent to graphviz +-- position.c's @pos_clusters@ (border nodes plus contain/keepout edges) to +-- the aux graph. With no plates, the result is unchanged (figures are +-- bit-identical). 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。 +-- | [日本語]: size-aware 版。 @hwMap@ = real node id → 横半幅 (px)。 +-- @hwOf@ は dummy を 'auxDummyHalfW'、 hwMap 欠落を 'auxNodeHalfW' へ fallback。 +-- [English]: The size-aware variant. @hwMap@ maps a real node id to its +-- horizontal half-width (px). @hwOf@ falls back to 'auxDummyHalfW' for +-- dummies and 'auxNodeHalfW' when missing from hwMap. auxSimplexCoordsW :: Map Text Int -> [[Text]] -> LayoutGraph -> OrderMap -> Map Text Double auxSimplexCoordsW hwMap plates lg om = @@ -1014,7 +1355,7 @@ | 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 + -- 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 ] @@ -1031,7 +1372,7 @@ 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) + -- ③ 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 ] @@ -1041,40 +1382,86 @@ 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 で別途)。 +-- | [日本語]: 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 は別途)。 +-- [English]: Generates, as edges for our aux-graph network simplex, the +-- cluster x-constraints that graphviz @lib/dotgen/position.c@'s +-- @pos_clusters@ (inside @create_aux_edges@) sets up. Faithful to the +-- primary source (CL_OFFSET=8pt maps to 'auxPlateMargin'; no border label, +-- so border.x=0; nesting is handled separately). -- --- 各 plate p に左右 border virtual node @ln_p@ / @rn_p@ を立て (graphviz --- @make_lrvn@ = SLACKNODE)、 以下を張る: +-- [日本語]: 各 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 に +-- * @keepout_othernodes@: 各 rank で member ブロックの外側最近接 __非メンバ__ u に -- @u → ln_p@ / @rn_p → u@ (minlen = margin + 半幅)。 = 非メンバを箱外へ排除。 --- * @separate_subclust@: 同一 rank に並ぶ **兄弟** plate (= 互いに包含関係に無い) +-- * @separate_subclust@: 同一 rank に並ぶ __兄弟__ plate (= 互いに包含関係に無い) -- の隣接 border 間に @rn_left → ln_right@ (minlen = CL_OFFSET)。 = 隣接箱の --- margin ぶんの隙間を x 解に確保 (= P8 A4-2・兄弟 plate box 重なりの根治)。 +-- margin ぶんの隙間を x 解に確保 (= 兄弟 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 実測)。 +-- [English]: For each plate p, sets up left/right border virtual nodes +-- @ln_p@ / @rn_p@ (graphviz @make_lrvn@ = SLACKNODE), and connects: -- --- これにより plate が box として x 分離し、 cosmetic な 'applyPlateBands' / --- 'recenterNonPlateRows' (帯分離) が不要になる (= Step8 で撤去済)。 +-- * @contain_nodes@: for each rank, @ln_p → leftmost member@ (minlen = +-- half-width + margin), and @rightmost member → rn_p@ (same). Fixes the +-- box's left and right edges. +-- * @contain_clustnodes@: @ln_p → rn_p@ (minlen 1, weight 128). Compresses +-- the box tight (a strong weight that packs the members together). +-- * @keepout_othernodes@: for each rank, the __non-member__ u nearest to +-- the outside of the member block gets @u → ln_p@ / @rn_p → u@ (minlen = +-- margin + half-width). Pushes non-members out of the box. +-- * @separate_subclust@: for __sibling__ plates (not in a containment +-- relation with each other) adjacent within the same rank, connects +-- @rn_left → ln_right@ between their borders (minlen = CL_OFFSET). +-- Reserves a margin-sized gap in the x solution between adjacent boxes +-- (fixing sibling plate box overlap). -- --- Phase 39 P8 A4-2: 半幅は固定 'auxNodeHalfW' でなく @hwOf@ (= 'auxSimplexCoordsW' --- が hwMap から作る per-node 実半幅) を使う。 dummy/欠落の fallback は hwOf 内で済。 +-- [日本語]: graphviz @pos_clusters@ にはもう一つ @contain_subclust@ +-- (nested 親子 plate に @ln_p → ln_c@ / @rn_c → rn_p@・minlen CL_OFFSET・weight 128 を +-- 直接の子へ張り、 親箱が子箱を margin ぶん外側で囲む) があるが、 __意図的に未実装__。 +-- 理由 (実測): 我々の plate box は 'Graphics.Hgg.Render.EdgeRoute.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 実測)。 +-- +-- [English]: graphviz's @pos_clusters@ has one more edge kind, +-- @contain_subclust@ (for a nested parent/child plate, connects @ln_p → +-- ln_c@ / @rn_c → rn_p@ directly to each child — minlen CL_OFFSET, weight +-- 128 — so the parent box encloses the child box by a margin), but it is +-- __deliberately not implemented__ here. Reason (measured): our plate box +-- is drawn by 'Graphics.Hgg.Render.EdgeRoute.plateBoxPt' as "the union of direct member glyph boxes and +-- (recursively) child plate boxes, plus a fixed margin", so nested +-- clearance is __already guaranteed by the box model itself__. A prototype +-- of contain_subclust, tested by regenerating the nested/deep/tri figures, +-- produced zero geometric change (only trailing floating-point noise; the +-- PNGs were byte-identical) — the border constraint never propagated to box +-- drawing. So while graphviz has it, it is __inert along our render path__ +-- and is not adopted (it would only add real cost from figure-regeneration +-- floating-point noise). Reconsider it if the box model is ever switched to +-- derive from border nodes. +-- ([[feedback-graphviz-only-faithful-algos]], measured 2026-06-26). +-- +-- [日本語]: これにより plate が box として x 分離し、 cosmetic な @applyPlateBands@ / +-- @recenterNonPlateRows@ (帯分離) が不要になる (= 撤去済)。 +-- [English]: As a result, plates separate along x as boxes, making the +-- cosmetic @applyPlateBands@ / @recenterNonPlateRows@ (band separation) +-- unnecessary (already removed). +-- +-- [日本語]: 半幅は固定 'auxNodeHalfW' でなく @hwOf@ (= 'auxSimplexCoordsW' +-- が hwMap から作る per-node 実半幅) を使う。 dummy/欠落の fallback は hwOf 内で済。 +-- [English]: Uses @hwOf@ (the per-node actual half-width built from hwMap +-- by 'auxSimplexCoordsW') rather than the fixed 'auxNodeHalfW'. The +-- dummy / missing-entry fallback is already handled inside hwOf. clusterAuxEdges :: (Text -> Int) -> OrderMap -> [[Text]] -> ([Text], [(Text, Text, Int, Double)]) @@ -1135,19 +1522,33 @@ in (concatMap fst perResults, concatMap snd perResults ++ sepEdges) -- =========================================================================== --- Step 5 (Phase 1 A6): Plate (= cluster) 制約 +-- [日本語]: Step 5: Plate (= cluster) 制約 -- median sweep 後の OrderMap を post-process し、 同 plate に属する node が -- 同 rank 内で連続するように再並べ替える。 各 plate の median 位置を維持して -- 並べ替えるため、 crossing 増加を最小化する。 -- --- nested plate: 渡された 'plates' 順を尊重し、 外側 → 内側 の順で適用する +-- nested plate: 渡された @plates@ 順を尊重し、 外側 → 内側 の順で適用する -- (= 最初に外側が contiguous 化、 次に内側がさらに細かく contiguous 化)。 -- 多重所属 (= 1 node が 2 plate に属する) は spec §10.4 で禁止、 -- plates 中で 後の plate が優先 (= 先のは無視) される簡略処理。 +-- [English]: Step 5: Plate (cluster) constraints. Post-processes the OrderMap +-- after the median sweep, reordering so that nodes belonging to the same +-- plate become contiguous within each rank. Reordering keeps each plate's +-- median position, minimizing the increase in crossings. +-- +-- Nested plates: applied in the order @plates@ were given, from outer to +-- inner (the outer plate is made contiguous first, then the inner one is +-- further refined into contiguity). Multiple membership (one node +-- belonging to 2 plates) is forbidden by spec §10.4; as a simplification, +-- whichever plate comes later in @plates@ takes priority (the earlier one +-- is ignored). -- =========================================================================== --- | 各 rank で plate メンバを contiguous にする。 plate id は plates 順の index --- (= 後の plate が優先、 = nested plate の内側を後ろに置く運用を想定)。 +-- | [日本語]: 各 rank で plate メンバを contiguous にする。 plate id は plates 順の index +-- (= 後の plate が優先、 = nested plate の内側を後ろに置く運用を想定)。 +-- [English]: Makes plate members contiguous within each rank. The plate id +-- is the index within @plates@ (later plates take priority — the intended +-- usage is placing a nested plate's inner plate later). applyPlateConstraints :: [[Text]] -> OrderMap -> OrderMap applyPlateConstraints [] om = om applyPlateConstraints plates om = @@ -1175,10 +1576,16 @@ 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 の遠回りを抑える)。 +-- | [日本語]: 1 方向 sweep。 @topDown@ True なら上 rank の median を anchor、 False なら下 rank。 +-- 同 rank 内では Step 3 の order を尊重しつつ最小間隔を保証する。 +-- 隣接ペアの少なくとも片方が dummy node なら spacing を @dummyMinSpacing@ に縮める +-- (= dummy は描画されないので chain node と近接させて長 edge spline の遠回りを抑える)。 +-- [English]: A single-direction sweep. When @topDown@ is True, anchors on +-- the median of the rank above; when False, the rank below. Within a rank +-- it respects the Step 3 order while guaranteeing minimum spacing. When at +-- least one node of an adjacent pair is a dummy node, spacing shrinks to +-- @dummyMinSpacing@ (since dummies are not drawn, keeping them close to +-- the chain node curbs long detours in the long-edge spline). computeOneDir :: Bool -> LayoutGraph -> OrderMap -> Map Text Double computeOneDir topDown lg om = let ranks = sort (Map.keys om) diff --git a/src/Graphics/Hgg/Easy.hs b/src/Graphics/Hgg/Easy.hs --- a/src/Graphics/Hgg/Easy.hs +++ b/src/Graphics/Hgg/Easy.hs @@ -1,12 +1,16 @@ -- | -- Module : Graphics.Hgg.Easy --- Description : Layer 1 ─ 入門用 Easy API (= 値直接受け + overlay 既定) + Spec 再 export +-- Description : Layer 1 (Easy API) — direct-value helpers, overlay by default, Spec re-export -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- 4 層 API 設計のうち **Easy 層**。 --- grammar API (`Graphics.Hgg.Spec`) を**そのまま再 export** した上で、 --- 「`inline` を書かずに `[Double]` を直接渡す」 専用ヘルパを足す (= 別名方式)。 +-- [日本語]: 4 層 API 設計のうち __Easy 層__。 +-- grammar API (`Graphics.Hgg.Spec`) を__そのまま再 export__ した上で、 +-- 「`inline` を書かずに `[Double]` を直接渡す」 専用ヘルパを足す (= 別名方式)。 +-- [English]: The __Easy layer__ of the 4-layer API design. Re-exports the +-- grammar API (`Graphics.Hgg.Spec`) __as-is__, and adds dedicated helpers +-- that let you pass a `[Double]` directly without writing `inline` (an +-- alias-based approach). -- -- @ -- import Graphics.Hgg.Easy @@ -20,8 +24,12 @@ -- , lineXY [1,2,3] [1,4,9] ] -- @ -- --- 設計: Easy helper は 'Layer' を返す (grammar と同じ合成性)。 重畳は 'overlay' で --- 包む (= 'scatter' '<>' 'line' の落とし穴を回避、 @design/monoid-semantics.md@ §1)。 +-- [日本語]: 設計: Easy helper は 'Layer' を返す (grammar と同じ合成性)。 重畳は +-- 'overlay' で包む (= 'scatter' '<>' 'line' の落とし穴を回避、 +-- @design/monoid-semantics.md@ §1)。 +-- [English]: Design: Easy helpers return a 'Layer' (the same composability +-- as grammar). Overlaying is done by wrapping with 'overlay' (avoiding the +-- 'scatter' '<>' 'line' pitfall; see @design/monoid-semantics.md@ §1). {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Easy ( -- * grammar API 全体 (再 export) @@ -39,31 +47,44 @@ import Graphics.Hgg.Spec --- | 散布図 (= 'scatter' の値直接受け版)。 @points xs ys@ は @scatter (inline xs) (inline ys)@。 +-- | [日本語]: 散布図 (= 'scatter' の値直接受け版)。 @points xs ys@ は +-- @scatter (inline xs) (inline ys)@。 +-- [English]: A scatter plot (the direct-value version of 'scatter'). +-- @points xs ys@ is @scatter (inline xs) (inline ys)@. points :: [Double] -> [Double] -> Layer points xs ys = scatter (inline xs) (inline ys) --- | 折れ線 (= 'line' の値直接受け版)。 +-- | [日本語]: 折れ線 (= 'line' の値直接受け版)。 +-- [English]: A line plot (the direct-value version of 'line'). lineXY :: [Double] -> [Double] -> Layer lineXY xs ys = line (inline xs) (inline ys) --- | 棒 (= 'bar' の値直接受け版)。 +-- | [日本語]: 棒 (= 'bar' の値直接受け版)。 +-- [English]: A bar chart (the direct-value version of 'bar'). bars :: [Double] -> [Double] -> Layer bars xs ys = bar (inline xs) (inline ys) --- | ヒストグラム (= 'histogram' の値直接受け版)。 +-- | [日本語]: ヒストグラム (= 'histogram' の値直接受け版)。 +-- [English]: A histogram (the direct-value version of 'histogram'). hist :: [Double] -> Layer hist xs = histogram (inline xs) --- | 片軸プロット: index (0,1,2,…) を x に取った散布図。 +-- | [日本語]: 片軸プロット: index (0,1,2,…) を x に取った散布図。 +-- [English]: A single-axis plot: a scatter plot using the index +-- (0, 1, 2, …) as x. plotY :: [Double] -> Layer plotY ys = points (map fromIntegral [0 .. length ys - 1]) ys --- | layer 群を重ね合わせた 'VisualSpec' (= @foldMap layer@)。 入門者はこれで --- 重畳を書く (`scatter <> line` の落とし穴を避ける)。 +-- | [日本語]: layer 群を重ね合わせた 'VisualSpec' (= @foldMap layer@)。 入門者は +-- これで重畳を書く (`scatter <> line` の落とし穴を避ける)。 +-- [English]: A 'VisualSpec' that overlays a group of layers (@foldMap +-- layer@). Beginners should use this to overlay plots, avoiding the +-- `scatter <> line` pitfall. overlay :: [Layer] -> VisualSpec overlay = foldMap layer --- | 'overlay' の別名 (= 複数 plot を「並べる」 ニュアンスの短名)。 +-- | [日本語]: 'overlay' の別名 (= 複数 plot を「並べる」 ニュアンスの短名)。 +-- [English]: An alias for 'overlay', with a shorter name conveying the +-- nuance of "arranging" multiple plots. plots :: [Layer] -> VisualSpec plots = overlay diff --git a/src/Graphics/Hgg/Layout.hs b/src/Graphics/Hgg/Layout.hs --- a/src/Graphics/Hgg/Layout.hs +++ b/src/Graphics/Hgg/Layout.hs @@ -1,1311 +1,2384 @@ -- | -- 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 単位に丸め。 --- 月 / 年単位の境界調整は将来。 +-- Description : Layer 2 — layout computation (viewport / scale / axis tick) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: 'VisualSpec' から viewport / scale / axis tick を計算する純粋関数群。 +-- col 名参照は 'Resolver' で Vector に解決した上で extent を求める。 +-- [English]: A set of pure functions that compute viewport / scale / axis +-- ticks from a 'VisualSpec'. Column-name references are resolved to +-- vectors via 'Resolver' before their extents are computed. +{-# 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 + , legendOrder + , 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 63 A4: tick 長・向きの実効値 (予約 computeLayout と描画 tickMarks で共有)。 + , effectiveTickLength + , effectiveTickDir + , tickOutwardLen + -- ★ Phase 63 A5: plot margin の実効値 (予約 computeLayout と描画 labels で共有)。 + , effectivePlotMargin + -- ★ Phase 63 A12: base font size の実効値 (予約 computeLayout と描画 mkFontTS で共有)。 + , effectiveBaseFontSize + , effectiveFontSize + -- ★ Phase 63 A13: half_line 派生 spacing の実効値 (既定 11 で従来定数と bit 同値)。 + , effectiveHalfLine + , effectiveAxTextMar + , effectiveAxTitleMar + , effectiveLegendBaseSize + , effectiveLegendKeyW + , effectiveLegendKeyPitch + , effectiveSubtitleSize + , effectiveCaptionSize + , effectiveTagSize + -- ★ Phase 63 A19: axis.text / axis.title 表示の実効値 (予約 computeLayout と + -- 描画 tickMarks/labels で共有。 ThemeVoid のみ既定 False)。 + , effectiveShowAxisText + , effectiveShowAxisTitle + -- ★ Phase 9 C: coord_flip 用の座標投影 helper (Render が共有)。 + , projectXY + , projectRectData + , projectBarRect + , catUnitPx + , resolutionOf + , AxisPlacement(..) + , coordXAxisPlacement + , coordYAxisPlacement + , coordXGridIsVertical + , coordOf + , isPolar + , isTernary + , normalizeTernary + , ternaryCenter + , ternaryVertices + , ternaryPoint + , polarCenter + , polarPoint + -- ★ Phase 64 A8: 外周円 (θ ラベル位置 = clip 境界) の比と clip path + , polarOuterFrac + , polarClipPath + , domFrac + -- ★ Phase 64 A2: 座標系依存の形状を投影層に集約する口 (§1 の受け皿)。 + , projectSegment + , BarShape(..) + , projectBar + , wedgeSegments + -- ★ Phase 64 A3: categorical-cross geom (box/violin/strip/swarm) 用の投影口。 + , CrossLoc(..) + , projectCrossPoint + , projectCrossSpan + , projectCrossBar + , valueAxisPx + ) 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 (..), ThemeOverride (..), TickDir (..), + Margin (..), Coord (..), PolarOpts (..), + TernaryOpts (..), defaultTernaryOpts, + VisualSpec (..), YAxisSide (..), + applyDiscreteLimits, axisKindOf, ridgeAutoFlip, + axTickValsOf, axTickLabelsOf, distGroupRef, + resolveAxisAngle, axisTextAngleXOf, + compositeLanes, colRefName, + lgPosition, lyColor, lyColorCats, lyShapeBy, + lyEncX, lyEncY, lyKind, lyBinCount, + lyYAxisSide, orderedCats, resolveCol, + resolveNum, themeSeriesPalette, + HexCell (..), hexbinLayerCells) +import Graphics.Hgg.Primitive (PathSegment (..), Point (..), + 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(..))@ を不変に保つ。 + +-- | [日本語]: 当初は Linear のみだったが、 PlotConfig.xLog / yLog 等価の +-- LogScale を追加 (= 自然対数 ln で線形化、 描画は底 10 で tick 表示)。 +-- [English]: Originally Linear-only; LogScale was added to match +-- PlotConfig.xLog / yLog (linearized via the natural log ln, rendered +-- with base-10 ticks). +data Scale + = LinearScale { lsDomainLo, lsDomainHi, lsRangeLo, lsRangeHi :: !Double } + | LogScale { lsDomainLo, lsDomainHi, lsRangeLo, lsRangeHi :: !Double } + -- | [日本語]: Sqrt scale: forward = sqrt v (= 数値が非負の domain 限定、 + -- 負値は range 下端 clip)。 inverse は描画側で不要 (= tick は値域、 表示は元値)。 + -- [English]: The Sqrt scale: forward = sqrt v (restricted to a + -- non-negative domain; negative values clip to the range's lower + -- bound). No inverse is needed on the render side (ticks are in value + -- space, and displayed values are the originals). + | SqrtScale { lsDomainLo, lsDomainHi, lsRangeLo, lsRangeHi :: !Double } + -- | [日本語]: Time scale: unix epoch (Double seconds) を Linear で扱う。 + -- tick は niceTimeTicks (= 1m / 1h / 1d / 1w / 1M / 1y candidates)。 + -- 表示 format は AxisFormat の AxisTimeFmt 経由 (= Render 側)。 + -- [English]: The Time scale: treats a unix epoch (Double seconds) + -- linearly. Ticks come from niceTimeTicks (1m / 1h / 1d / 1w / 1M / 1y + -- candidates). Display formatting goes through AxisFormat's AxisTimeFmt + -- (on the Render side). + | 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 64 A11: 三角座標 (ternary) 第 3 軸 (encZ 成分)。 CoordTernary のときだけ + -- 'Just' の [0,1] fraction scale + tick を持ち、 それ以外は 'Nothing' / [] で + -- 既存 2 軸の図に一切影響しない。 投影 (ternaryPoint) と grid は §3 A12 で consume。 + , lpZScale :: !(Maybe Scale) + , lpZTicks :: ![Double] + , lpZCategoryLabels :: ![T.Text] + , lpZTickLabels :: ![T.Text] + -- ★ 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 + -- ★ Phase 63 A15: 軸タイトルの配置 offset (panel 端 → axis.title margin 外縁まで = + -- tick 突出 + axis.text margin + tick ラベル帯 + axis.title margin)。 描画 + -- (Render.labels) は panel 端 + この offset を基準に baseline を置く (= ggplot の + -- 「軸 text 直下 + margin」 方式)。 bM/lM の予約 stack と同じ構成要素 (単一情報源)。 + -- 旧 boxBottom/boxLeft 最外端 pin は LegendBottom/caption 時にタイトルが凡例の + -- 外側 (最下端) へ出ていた (J2/J5)。 + , lpXTitleOff :: !Double + , lpYTitleOff :: !Double + -- ★ Phase 63 A17: bottom 凡例の配置 (予約 bM と描画 renderLegendBottom の単一情報源)。 + -- lpLegendYOff = panel 下端 → 凡例ブロック上端 (= bM の軸 stack と同一構成 + + -- legend gap 2×half_line = ggplot legend.box.spacing)。 lpLegendNCol = 実効列数 + -- (明示 legendNrow 優先、 未指定は panel 幅に収まる最大列数へ auto-wrap)。 + -- 旧 render は panel 下端 + 50 固定で軸タイトルと逆順 + 幅超過で右見切れ (J5)。 + , lpLegendYOff :: !Double + , lpLegendNCol :: !Int + } deriving (Show, Eq) + +-- | [日本語]: 'VisualSpec' の全 layer から 'Resolver' で encX/encY を解決、 +-- 全 layer横断で extent を計算。 viewport は spec の width/height、 余白は +-- 固定 margin。 +-- [English]: Resolves encX/encY across every layer of a 'VisualSpec' via +-- 'Resolver', computing the extent across all layers. The viewport comes +-- from the spec's width/height; margins are fixed. +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 過大予約 → 軸タイトルが遠かった)。 + -- ★ Phase 63 A12: 解決を mkFontTS と同一情報源へ (theme override の fsSize + + -- toBaseFontSize 派生既定)。 旧 fontSizeOf (setter のみ・13.2/11/8.8 固定) は + -- theme*Font 指定 (cowplot preset 等) を予約に反映できていなかった。 + base = effectiveBaseFontSize spec + ovT = vsThemeOverride spec + titleSize = effectiveFontSize (vsTitleFont spec) (toTitleFont ovT) (base * 1.2) -- plot.title + axisLabelSize = effectiveFontSize (vsAxisLabelFont spec) (toAxisLabelFont ovT) base -- axis.title + tickSize = effectiveFontSize (vsTickFont spec) (toTickFont ovT) (base * 0.8) -- axis.text + -- 左 margin 用の y 目盛りラベル: 離散 limits (yCatLabels) > 明示ラベル + -- (axisBreaksLabeled = explicitYLabs) > numeric tick の順で採用する。 + -- (明示ラベルを測らないと長い category ラベルが軸外へ溢れる)。 + yTickLabelStrs + | not (null yCatLabels) = yCatLabels + | not (null explicitYLabs) = explicitYLabs + | otherwise = formatTicksGG yTicks + -- ★ Phase 63 A19: axis.text / axis.title 非表示 (ThemeVoid 既定 / + -- themeAxisText・themeAxisTitle False) はラベル文字・軸タイトルぶんの予約を + -- 丸ごと落とす (ggplot element_blank = zero-size grob)。 tick 線の tickOut は + -- 独立に残る (長さは effectiveTickLength、 ThemeVoid は既定 0)。 + showAxText = effectiveShowAxisText spec + showAxTitle = effectiveShowAxisTitle spec + maxYTickW = if not showAxText || null yTickLabelStrs then 0 + else 0.6 * tickSize + * fromIntegral (maximum (map T.length yTickLabelStrs)) + hasTitle = case getLast (vsTitle spec) of Just _ -> True; _ -> False + hasXLabel = showAxTitle && case getLast (vsXLabel spec) of Just _ -> True; _ -> False + hasYLabel = showAxTitle && 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 + -- ★ Phase 63 A14: labs の font size も base 派生 (旧固定 11/9/13 は base 11 の + -- 丸め値。 描画 Render.labels と同じ effective* を参照 = 単一情報源)。 + labsSubExtra = if hasSubtitle then effectiveSubtitleSize spec + sc * hl else 0 + labsTagExtra = if hasTag && not (hasTitle || hasSubtitle) then effectiveTagSize spec + sc * hl else 0 + labsCapExtra = if hasCaption then effectiveCaptionSize spec + sc * hl 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 では + -- 新旧同値なので通常プロットは不変。 + -- ★ Phase 63 A5: 外周余白は theme 実効値 (themePlotMargin、 既定 = 各辺 half_line + -- で従来と同値)。 + -- ★ Phase 63 A13: 内側 spacing (title 下 margin・axis.text/axis.title margin・ + -- 凡例 gap) も half_line = base/2 派生の実効値へ (既定 11 で従来定数と bit 同値)。 + pm = effectivePlotMargin spec + hl = effectiveHalfLine spec + -- ★ Phase 63 A19: axis.text 非表示なら axis.text margin も 0 (定義 1 箇所で + -- bM/lM/xTitleOff/yTitleOff/legendYOff の全 stack に波及)。 + axTextMar = if showAxText then effectiveAxTextMar spec else 0 + axTitleMar = effectiveAxTitleMar spec + tM = sc * marTop pm + (if hasTitle then titleSize + sc * hl else 0) + + labsSubExtra + labsTagExtra + -- ★ x 目盛りラベルの回転 (axisRotate) 予約: 非回転は tickSize (従来) だが、 + -- 回転時はラベル**幅**が下方向に伸びる。 左 margin の maxYTickW と対称に、 + -- x 目盛りラベルの最大文字幅を回転角で投影して予約する (rotX=0 で従来同値)。 + -- ★ Phase 63 A16: 解決順を描画 (Render/Layer resolveAxisAngle) と単一情報源化。 + -- per-axis 明示 > theme (axisTextAngleXOf = 共通 <> X 別) > 0。 旧 axisRotateOf は + -- theme 経由の回転 (themeAxisTextAngleX 等) を無視し回転マージン未予約だった (J4)。 + xRot = resolveAxisAngle (vsXAxis spec) (axisTextAngleXOf ovT) + 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 + | not showAxText = 0 -- ★ A19: ラベル文字が無いので高さ予約もしない + | xRot == 0 = tickSize + | otherwise = let rad = xRot * pi / 180 + in tickSize * abs (cos rad) + maxXTickW * abs (sin rad) + -- ★ Phase 63 A4: tick の外向き突出量は theme 実効値 (themeTickLength/themeTickDir)。 + -- 未指定は ggTickLen/TickOut で従来と同値。 描画 (tickMarks) と単一情報源。 + tickOut = tickOutwardLen spec + bM | isContainer = sc * marBottom pm + legendH + labsCapExtra + | otherwise = sc * (marBottom pm + tickOut + axTextMar) + xTickReserve + + (if hasXLabel then sc * axTitleMar + axisLabelSize else 0) + + legendH + labsCapExtra + lM | isContainer = sc * marLeft pm + | otherwise = sc * (marLeft pm + tickOut + axTextMar) + maxYTickW + + (if hasYLabel then sc * axTitleMar + axisLabelSize else 0) + -- ★ Phase 63 A15: 軸タイトルの panel 端からの配置 offset。 bM/lM の予約 stack と + -- 同じ構成要素で算出 (単一情報源)。 container は軸 stack を持たないので + -- axTitleMar のみ。 + xTitleOff | isContainer = sc * axTitleMar + | otherwise = sc * (tickOut + axTextMar + axTitleMar) + xTickReserve + yTitleOff | isContainer = sc * axTitleMar + | otherwise = sc * (tickOut + axTextMar + axTitleMar) + maxYTickW + -- 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 spec) + -- ★ Phase 38: 右凡例幅を「最長ラベル」で算出 (固定 80/+70列 を撤去)。 renderGuideBlock の + -- 描画式に一致する 'legendGuideWidth' を全 guide に適用し、 縦スタックゆえ最大幅を予約。 + -- gap (panel→凡例 = 2*half_line) は renderLegendRight の x0 オフセットと一致。 + -- フォントは既定 (item=base×0.8 / title=base)。 override 無し時 render と一致 (旧固定80は + -- フォント完全無視だったので後退なし)。 + -- ★ Phase 63 A13: 凡例基準も base 派生 (effectiveLegendBaseSize = 2×half_line)。 + legItemF = effectiveLegendBaseSize spec * 0.8 + legTitleF = effectiveLegendBaseSize spec + 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 spec legItemF legTitleF (effectiveLegendTitle spec) (allColorCategories r (vsLayers spec)) + ColorGuide (ColorByContinuous cr) -> + legendGuideWidth spec legItemF legTitleF (effectiveLegendTitle spec) (contColorLabels cr) + ColorGuide (ColorStatic _) -> 0 + CountBarGuide lo hi -> + legendGuideWidth spec 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 spec 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 * hl + legendGuidesW else 0 + -- ★ Phase 63 A17: bottom 凡例の実寸予約 (旧 50 + (nrow-1)*16 固定を撤去 = J5)。 + -- gap = 2×half_line (ggplot legend.box.spacing)、 行 pitch = effectiveLegendKeyPitch。 + -- 列数 = 明示 legendNrow 優先、 未指定は panel 幅 (availW) に収まる最大列数 + -- (item/title 幅は renderLegendBottom の itemAdv/titleW と同式 = 予約と描画の + -- 単一情報源)。 availW は lM/rM のみ依存で legendH と循環しない。 + legendGapB = 2 * hl + legRowH = effectiveLegendKeyPitch spec + legLabels = map snd (legendOrder spec (allColorCategories r (vsLayers spec))) + nLeg = length legLabels + legItemAdv lbl = 14 + legItemF * textWidthEm lbl + hl + legTitleWB = let t = effectiveLegendTitle spec + in if t == "" then 0 else legTitleF * textWidthEm t + 12 + legFits nc = let colW c = maximum (0 : [ legItemAdv (legLabels !! k) + | k <- [0 .. nLeg - 1], k `mod` nc == c ]) + in legTitleWB + sum (map colW [0 .. nc - 1]) <= availW + legNCol + | nLeg == 0 = 1 + | otherwise = case getLast (vsLegendNrow spec) of + Just nr -> max 1 ((nLeg + max 1 nr - 1) `div` max 1 nr) + Nothing -> head ([ nc | nc <- [nLeg, nLeg - 1 .. 2], legFits nc ] ++ [1]) + legNRowB = max 1 ((max 1 nLeg + legNCol - 1) `div` legNCol) + legendH = if legendPos == LegendBottom + then legendGapB + fromIntegral legNRowB * legRowH else 0 + -- panel 下端 → 凡例ブロック上端 = bM の軸 stack (legendH/labsCapExtra を除く + -- 内側部分) + gap。 caption は凡例のさらに外側 (bM の積み順と同じ)。 + legendYOff | isContainer = legendGapB + | otherwise = sc * (tickOut + axTextMar) + xTickReserve + + (if hasXLabel then sc * axTitleMar + axisLabelSize else 0) + + legendGapB + rM = sc * marRight pm + 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)] ] + -- ★ Phase 70 A3: MEss を追加 — ESS bar は 0 起点なので下端 0 固定 + 上端のみ 5% + -- (pre-Phase 64 の自前マッピング = 0 が panel 底辺、 と同じ見た目規約)。 + hasYBaseline = any (`elem` [MBar, MHistogram, MDensity, MWaterfall, MEss]) 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 + -- ★ Phase 64 A11: ternary の第 3 軸。 CoordTernary 時のみ [0,1] fraction + -- scale + nice tick、 それ以外は Nothing/[] (既存図は不変)。 カテゴリ/tick + -- ラベル上書きは continuous 軸ゆえ空 (A12 の grid が数値 tick を描く)。 + , lpZScale = if isTernary (coordOf spec) + then Just (LinearScale 0 1 0 1) else Nothing + , lpZTicks = if isTernary (coordOf spec) then niceTicks 5 0 1 else [] + , lpZCategoryLabels = [] + , lpZTickLabels = [] + , 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 + , lpXTitleOff = xTitleOff + , lpYTitleOff = yTitleOff + , lpLegendYOff = legendYOff + , lpLegendNCol = legNCol + } + +-- | [日本語]: ggplot 準拠: margin 縮小係数を撤廃 (常に 1)。 ggplot は文字・余白を +-- 固定 pt で扱い viewport サイズで縮めない (パネルが残りを埋めるだけ)。 旧実装は +-- 小 viewport で sc<1 に縮小していたが、 grid は軸帯確保 (renderSubplots) で対応し、 +-- 単一小 viewport (inset) も固定 pt で ggplot と同挙動にする。 panel が潰れないよう +-- computeLayout 側で availW/availH に下限を設ける。 シグネチャは互換のため温存。 +-- [English]: Following ggplot: the margin-shrink factor has been removed +-- (always 1). ggplot treats text and whitespace as fixed pt and does not +-- shrink them with viewport size (the panel simply fills whatever +-- remains). The previous implementation shrank by sc<1 for small +-- viewports; grid now handles this via axis-band reservation +-- (renderSubplots), and a single small viewport (inset) also behaves like +-- ggplot with fixed pt. computeLayout sets a lower bound on availW/availH +-- to keep the panel from collapsing. The signature is kept for +-- compatibility. +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")、 残りスペースを重み比で +-- 分配 = パネル本体)。 +-- [English]: The size kind of a gtable track (row or column), matching +-- ggplot's grid::unit: Fixed v is a fixed pt size (the grob's actual size +-- for axis text/title/strip/plot.margin); Null w is an elastic track +-- (unit(w,"null"), distributing remaining space by weight — the panel +-- body). +data Track = Fixed !Double | Null !Double + deriving (Show, Eq) + +-- | [日本語]: 1 次元トラック割付。 利用可能長 avail から Fixed 合計を先取りし、 +-- 残りを Null トラックに重み比で配分する (= ggplot gtable の「固定先取り → +-- null 残り均等」)。 残りが負なら Null=0 (= パネルが潰れる、 ggplot と同挙動)。 +-- パネル間 spacing は呼び出し側が Fixed トラックとして明示挿入する。 戻り = +-- 各トラックの (start, length) (start は absolute)。 +-- [English]: 1D track allocation. Claims the sum of Fixed sizes from the +-- available length avail first, then distributes the remainder to Null +-- tracks by weight (matching ggplot gtable's "claim fixed first, then +-- split the null remainder"). If the remainder is negative, Null=0 (the +-- panel collapses, matching ggplot's behaviour). Inter-panel spacing must +-- be inserted explicitly by the caller as a Fixed track. Returns each +-- track's (start, length), where start is 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 + +-- | [日本語]: ggplot half_line マージン定数 (pt, sc 適用前)。 layout が純 pt +-- 空間になったことで、 これらは ggplot 由来の pt 値 (half_line= +-- base_size/2=5.5pt) そのものとして正しく pt 意味になる (値は不変・k は +-- backend)。 computeLayout の margin 計算と Render の描画オフセットで共有 +-- (単一情報源)。 +-- [English]: ggplot's half_line margin constants (pt, before sc is +-- applied). Now that layout is a pure pt space, these are correctly +-- interpreted as pt values straight from ggplot (half_line = +-- base_size/2 = 5.5pt; the values are unchanged, and k belongs to the +-- backend). Shared between computeLayout's margin computation and +-- Render's drawing offsets (a single source of truth). +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。 +-- [English]: The legend's base font size (pt). ggplot's @base_size@ is +-- 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。 +-- [English]: The side length of a legend key (pt), matching ggplot's +-- @legend.key.size = unit(1.2,"lines")@. Measured from an R gtable trace +-- as 17.34pt (at base 11pt). Since grid's "lines" is a line height +-- (1.2 × base × lineheight), the value is not 1.2×base(=13.2) but this +-- one: 1.2 × base × 1.3133. +legendKeyW :: Double +legendKeyW = 1.2 * legendBaseSize * 1.3133 + +-- | [日本語]: 凡例キーの行ピッチ = keyW (= ggplot gtable のキー間 spacing 行 = +-- 0pt = キーセル隣接)。 +-- [English]: The legend key's row pitch, equal to keyW (ggplot gtable's +-- inter-key spacing row is 0pt, so key cells are adjacent). +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 でなく実用的な +-- 近似・凡例幅にのみ使用)。 +-- [English]: Whether a character has East Asian Width Fullwidth (F) or +-- Wide (W), treated as 1.0em (CJK unified ideographs, kana, fullwidth +-- punctuation, Hangul, etc.). The ranges cover representative blocks +-- corresponding to Unicode EAW (UAX #11) W/F (a practical approximation +-- rather than an exact table; used only for legend width). +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 を計測して字種別にバケット化 (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 も同値)。 +-- [English]: Approximates a single character's advance in em units. +-- Measured from the actual advance of the default sans font (DejaVu) and +-- bucketed by character class (measured via rsvg trim; e.g. i/l≈0.25, +-- a/e≈0.56, M/W≈0.9). The previous flat 0.6 over-reserved space for +-- labels dominated by narrow glyphs (lowercase, hyphens, etc.), whose +-- true average is ~0.49em/char, producing excess right padding. Values +-- are rounded slightly above the measured average, on the safe side of +-- "never truncate". Fullwidth characters are 1.0em via 'isWideChar'. +-- This table must match exactly between Haskell and PureScript (the +-- PureScript canvas uses the same values). +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 × この値。 +-- [English]: Estimates a string's width in em units (the sum of per-glyph +-- 'charWidthEm'). The actual pt width is fontSize × this value. +textWidthEm :: Text -> Double +textWidthEm = T.foldl' (\acc ch -> acc + charWidthEm ch) 0 + +-- | [日本語]: DAG node ラベルのフォントサイズ (pt)。 layout (Sugiyama の +-- size-aware 横幅見積り) と render (@nodeExtent@) で共有する単一定義。 旧 +-- Render.EdgeRoute から移管。 +-- [English]: The font size of a DAG node label (pt). A single definition +-- shared by layout (Sugiyama's size-aware width estimation) and render +-- (@nodeExtent@). Migrated from the previous Render.EdgeRoute. +dagLabelFs :: Double +dagLabelFs = 11 + +-- | [日本語]: DAG node の __radius 非依存__な横半幅 (px)。 = @nodeExtent@ の +-- rx から @max baseR@ の floor を除いた本体 (ラベル名 / 分布 sublabel 幅に +-- 由来)。 +-- +-- layout の size-aware simplex (Sugiyama @auxSepOf@ / @clusterAuxEdges@) +-- と render の @nodeExtent@ が __同一式__を共有することで、 simplex が +-- 確保する node 間隔と描画箱の幅を整合させる (= 兄弟 plate の box 重なりを +-- 根治)。 radius は layout 時に未知 (= render-time の lySize) ゆえ floor +-- 部分は render 側 (@nodeExtent@) で適用する。 +-- [English]: The __radius-independent__ half-width (px) of a DAG node — +-- the body of @nodeExtent@\'s rx with the @max baseR@ floor removed +-- (derived from the label name / distribution sublabel width). +-- +-- Layout's size-aware simplex (Sugiyama's @auxSepOf@ / @clusterAuxEdges@) +-- and render's @nodeExtent@ share __the same formula__, keeping the node +-- spacing the simplex reserves consistent with the drawn box width (fixing +-- overlapping boxes between sibling plates at the root). Since the radius +-- is unknown at layout time (it is render-time's lySize), the floor part +-- is applied on the render side (@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)。 タイトルがそれより広ければ +-- タイトル幅。 引数: spec (★key 幅/gap を base 派生の実効値で引くため) / +-- item フォント pt / title フォント pt / タイトル文字列 / ラベル群。 ★「最長」 +-- は文字数でなく 'textWidthEm' 最大 (全角混在で逆転し得るため幅で選ぶ)。 +-- [English]: The required width (pt) of a single guide (a right-side, +-- single-column legend). Matches renderGuideBlock's drawing formula +-- exactly: column width = (key side) + (key-to-label gap = half_line/2) + +-- (longest label width) + (right padding = half_line). If the title is +-- wider, the title width wins instead. Arguments: spec (so key +-- width/gap are drawn from base-derived effective values), item font pt, +-- title font pt, title string, and labels. "Longest" is measured by +-- maximum 'textWidthEm', not character count (since fullwidth mixing can +-- reverse the ordering, width is used). +legendGuideWidth :: VisualSpec -> Double -> Double -> Text -> [Text] -> Double +legendGuideWidth spec fItem fTitle title labels = max titleW colW + where + hl = effectiveHalfLine spec + maxLabelEm = maximum (0 : map textWidthEm labels) + colW = effectiveLegendKeyW spec + hl / 2 + fItem * maxLabelEm + hl + 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) +-- [English]: Converts a number to a display string. Avoids +-- floating-point artifacts (0.1+0.2=0.300…04, etc.) by rounding to 12 +-- digits. Trailing zeros and the decimal point are stripped for integer +-- values. (Migrated from the previous 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) と揃える。 +-- [English]: An order-preserving nub (first-occurrence order), matching +-- the nub used by glyph color (@colorVector@) and PureScript's +-- (Array.nub) behaviour. +nubKeep :: [Text] -> [Text] +nubKeep = nub + +-- | [日本語]: 色 aesthetic を持つ最初のレイヤの ColorEnc (categorical / +-- continuous)。 +-- [English]: The ColorEnc (categorical or continuous) of the first layer +-- that has a color aesthetic. +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=))。 +-- 未指定なら ""。 +-- [English]: The explicit legend title (vsLegendTitle: a scale name or +-- labs(color=)). Empty string "" when unset. +effectiveLegendTitle :: VisualSpec -> Text +effectiveLegendTitle spec = maybe "" id (getLast (vsLegendTitle spec)) + +-- | [日本語]: 凡例キーの表示順。 (originalIndex, label) を返し、 色は +-- originalIndex で引く (= reverse しても各キーの色は固定)。 +-- vsLegendReverse=True で逆順。 ★Render/Layer から移設 (auto-wrap の列幅 +-- 計算が表示順に依存するため予約 computeLayout と描画で共有 = 単一情報源)。 +-- [English]: The display order of legend keys. Returns +-- (originalIndex, label); color is looked up by originalIndex, so each +-- key's color stays fixed even when reversed. Reversed when +-- vsLegendReverse=True. Migrated from Render/Layer, since auto-wrap's +-- column-width computation depends on display order and must be shared +-- between reservation (computeLayout) and rendering (a single source of +-- truth). +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 + +-- | [日本語]: 全 ColorByCol レイヤのカテゴリを順序保存で union (= 凡例 swatch / +-- glyph 色の正本)。 明示 @colorCats@ があればそれを先頭に、 無ければデータ +-- 水準を 'orderedCats' 順で。 +-- [English]: The order-preserving union of categories across all +-- ColorByCol layers (the source of truth for legend swatches / glyph +-- colors). If explicit @colorCats@ are given, they come first; otherwise, +-- data levels are used in 'orderedCats' order. +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) +-- が共有。 +-- [English]: A legend guide (color or shape). Shared between rendering +-- (renderGuideBlock) and reservation (legendW). +data LegendGuide + = ColorGuide !ColorEnc -- [日本語]: 色 guide (categorical / continuous)。 [English]: A color guide (categorical or continuous). + | ShapeGuide !ColRef -- [日本語]: 形 guide (色とは別列・または色無しのとき)。 [English]: A shape guide (a column distinct from color, or used when there is no color). + | CountBarGuide !Double !Double -- [日本語]: ★ Phase 40: 件数 colorbar (lo,hi)。 hexbin/bin2d-count 用 (列でなく集計値ゆえ ColorByContinuous と別。 ラベル = "count")。 + -- [English]: A count colorbar (lo,hi), for hexbin/bin2d-count (distinct from ColorByContinuous since it is an aggregate rather than a column; labeled "count"). + +-- | [日本語]: spec から guide を ggplot 順 (color → shape) で収集。 形が色と +-- 同列なら統合し形 guide なし。 +-- [English]: Collects guides from a spec in ggplot order (color, then +-- shape). If shape shares its column with color, they are merged and no +-- separate shape guide is produced. +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 + +-- | [日本語]: spec 中の hexbin layer の件数域 (min,max)。 colorbar guide + +-- needsLegend が使う。 render (renderHexbin) と同じ 'hexbinLayerCells' で +-- 計算するので域が一致する。 +-- [English]: The count domain (min, max) of the hexbin layer in a spec, +-- used by the colorbar guide and needsLegend. Computed with the same +-- 'hexbinLayerCells' as render (renderHexbin), so the domains agree. +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 + +-- | [日本語]: 凡例を実際に描画する位置 (= None なら凡例なし。 PS Layout と +-- 同一)。 color encoding が無ければ位置指定があっても None。 予約 +-- (computeLayout) / 描画 (Render) の両方がこれを使い、 「予約したのに +-- 描かれない / 描いたのに予約してない」 ズレを防ぐ。 +-- [English]: The position at which the legend is actually drawn (None +-- means no legend; identical to the PureScript Layout). Without a color +-- encoding, this is None even if a position was requested. Both +-- reservation (computeLayout) and rendering (Render) use this, preventing +-- the mismatch of "reserved but not drawn" or "drawn but not reserved". +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 + +-- | [日本語]: 色 enc を持たない hexbin layer (= 件数 colorbar 駆動) があるか +-- (構造のみ)。 +-- [English]: Whether there is a hexbin layer without a color encoding +-- (driven by a count colorbar); a structural check only. +hasHexbinCountGuide :: VisualSpec -> Bool +hasHexbinCountGuide spec = + not (hasColorEncoding (vsLayers spec)) + && any (\l -> getFirst (lyKind l) == Just MHexbin) (vsLayers spec) + +-- | [日本語]: layer 群に shape aesthetic (lyShapeBy) があるか。 +-- [English]: Whether any layer in the group has a shape aesthetic +-- (lyShapeBy). +hasShapeEncoding :: [Layer] -> Bool +hasShapeEncoding = any (\l -> case getLast (lyShapeBy l) of + Just _ -> True + Nothing -> False) + +-- | [日本語]: 有効 legend position を解決。 優先順 = 図レベル vsLegend +-- (@legendPos@ setter) > theme (toLegendPos) > 既定 LegendRightCenter +-- (= ggplot legend.position="right" と同じ縦中央)。 +-- [English]: Resolves the effective legend position. Priority: the +-- figure-level vsLegend (the @legendPos@ setter) > theme (toLegendPos) > +-- the default LegendRightCenter (matching ggplot's vertically centered +-- legend.position="right"). +effectiveLegendPos :: VisualSpec -> LegendPosition +effectiveLegendPos spec = case getLast (vsLegend spec) of + Just l -> lgPosition l + Nothing -> maybe LegendRightCenter id + (getLast (toLegendPos (vsThemeOverride spec))) + +-- | [日本語]: 実効 tick 長 (pt)。 theme (toTickLength) > 既定 half_line/2 +-- (ggplot axis.ticks.length。 ★固定 'ggTickLen' 2.75 から base 派生へ、 +-- 既定 11 で bit 同値。 ★ThemeVoid のみ既定 0 = ggplot theme_void の +-- axis.ticks.length = 0)。 +-- [English]: The effective tick length (pt). Priority: theme +-- (toTickLength) > the default half_line/2 (ggplot's +-- axis.ticks.length; changed from the fixed 'ggTickLen' 2.75 to a +-- base-derived value, bit-identical at the default of 11. ThemeVoid +-- alone defaults to 0, matching ggplot theme_void's +-- axis.ticks.length = 0). +effectiveTickLength :: VisualSpec -> Double +effectiveTickLength spec = + maybe def id (getLast (toTickLength (vsThemeOverride spec))) + where def = if isVoidTheme spec then 0 else effectiveHalfLine spec / 2 + +-- | [日本語]: theme preset が ThemeVoid か (void 系の既定分岐用)。 +-- [English]: Whether the theme preset is ThemeVoid (used to branch on +-- void-family defaults). +isVoidTheme :: VisualSpec -> Bool +isVoidTheme spec = getLast (vsTheme spec) == Just ThemeVoid + +-- | [日本語]: 実効 axis.text (目盛ラベル文字) 表示。 theme (toShowAxisText) > +-- preset 既定 (ThemeVoid のみ False = ggplot theme_void の axis.text +-- element_blank)。 表示 off は tick ラベル分の margin 予約 (axTextMar / +-- xTickReserve / maxYTickW) に波及するため、 computeLayout (予約) と +-- Render.tickMarks (描画) の単一情報源。 +-- [English]: Whether axis.text (tick label text) is effectively shown. +-- Priority: theme (toShowAxisText) > the preset default (False only for +-- ThemeVoid, matching ggplot theme_void's axis.text element_blank). +-- Turning display off cascades into the tick-label margin reservation +-- (axTextMar / xTickReserve / maxYTickW), so this is the single source of +-- truth shared by computeLayout (reservation) and Render.tickMarks +-- (drawing). +effectiveShowAxisText :: VisualSpec -> Bool +effectiveShowAxisText spec = + maybe (not (isVoidTheme spec)) id (getLast (toShowAxisText (vsThemeOverride spec))) + +-- | [日本語]: 実効 axis.title (軸タイトル) 表示。 既定は +-- 'effectiveShowAxisText' と同じ規則 (ThemeVoid のみ False)。 +-- computeLayout (予約) と Render.labels (描画) の単一情報源。 +-- [English]: Whether axis.title is effectively shown. The default +-- follows the same rule as 'effectiveShowAxisText' (False only for +-- ThemeVoid). A single source of truth shared by computeLayout +-- (reservation) and Render.labels (drawing). +effectiveShowAxisTitle :: VisualSpec -> Bool +effectiveShowAxisTitle spec = + maybe (not (isVoidTheme spec)) id (getLast (toShowAxisTitle (vsThemeOverride spec))) + +-- | [日本語]: 実効 tick 向き。 theme (toTickDir) > 既定 'TickOut' (ggplot 既定 +-- = 外向き)。 +-- [English]: The effective tick direction. Priority: theme (toTickDir) > +-- the default 'TickOut' (ggplot's default, pointing outward). +effectiveTickDir :: VisualSpec -> TickDir +effectiveTickDir spec = + maybe TickOut id (getLast (toTickDir (vsThemeOverride spec))) + +-- | [日本語]: tick の panel 外向き突出量 (pt)。 margin 予約 (computeLayout) と +-- 軸ラベル offset (Render.tickMarks) の単一情報源。 'TickIn' は panel 外に +-- 出ないので 0 (= ラベルが軸に寄る、 ggplot の負 axis.ticks.length と同挙動)。 +-- [English]: The amount a tick protrudes outward from the panel (pt). A +-- single source of truth shared by margin reservation (computeLayout) and +-- the axis-label offset (Render.tickMarks). 'TickIn' does not protrude +-- past the panel, so this is 0 (labels sit close to the axis, matching +-- ggplot's behaviour with a negative axis.ticks.length). +tickOutwardLen :: VisualSpec -> Double +tickOutwardLen spec = case effectiveTickDir spec of + TickIn -> 0 + _ -> effectiveTickLength spec + +-- | [日本語]: 実効 plot margin (pt)。 theme (toPlotMargin) > 既定 各辺 +-- half_line (★固定 'ggHalfLine' 5.5 から base 派生へ、 既定 11 で bit 同値)。 +-- 指定時は外周分を __置き換える__ (ggplot plot.margin と同じ)。 軸ラベル・ +-- title 帯・凡例などの内側予約は従来どおり自動算出のまま (computeLayout と +-- Render.labels が共有)。 +-- [English]: The effective plot margin (pt). Priority: theme +-- (toPlotMargin) > the default, half_line on each side (changed from +-- the fixed 'ggHalfLine' 5.5 to a base-derived value, bit-identical at +-- the default of 11). When specified, it __replaces__ the outer margin +-- entirely (matching ggplot's plot.margin). Inner reservations for axis +-- labels, the title band, the legend, etc. remain auto-computed as before +-- (shared by computeLayout and Render.labels). +effectivePlotMargin :: VisualSpec -> Margin +effectivePlotMargin spec = + let hl = effectiveHalfLine spec + in maybe (Margin hl hl hl hl) id + (getLast (toPlotMargin (vsThemeOverride spec))) + +-- | [日本語]: 実効 base font size (pt)。 theme (toBaseFontSize) > 既定 11 +-- (ggplot theme_grey base_size)。 各 slot の既定 font size はこれからの +-- 相対倍率で派生する。 computeLayout (予約) と Render.mkFontTS (描画) の +-- 単一情報源。 +-- [English]: The effective base font size (pt). Priority: theme +-- (toBaseFontSize) > the default 11 (ggplot theme_grey's base_size). Each +-- slot's default font size is derived from this by a relative multiplier. +-- A single source of truth shared by computeLayout (reservation) and +-- Render.mkFontTS (drawing). +effectiveBaseFontSize :: VisualSpec -> Double +effectiveBaseFontSize spec = + maybe 11 id (getLast (toBaseFontSize (vsThemeOverride spec))) + +-- | [日本語]: 実効 half_line (pt) = base/2 (ggplot @half_line@)。 spacing 系 +-- (外周 margin・title 下 margin・panel.spacing・凡例 gap) の共通派生元。 +-- 既定 base 11 で 5.5 = 従来 'ggHalfLine' と bit 同値 (golden 不変 gate、 +-- ULP 検証済)。 +-- [English]: The effective half_line (pt), = base/2 (ggplot's +-- @half_line@). The common derivation source for spacing values (outer +-- margin, title bottom margin, panel.spacing, legend gap). At the default +-- base of 11, this is 5.5, bit-identical to the previous 'ggHalfLine' +-- (verified to ULP precision via a golden-invariance gate). +effectiveHalfLine :: VisualSpec -> Double +effectiveHalfLine spec = effectiveBaseFontSize spec / 2 + +-- | [日本語]: 実効 axis.text margin (pt) = 0.8 × half_line/2 (ggplot 忠実)。 +-- 既定 11 で 2.2 = 従来 'ggAxTextMar' と bit 同値。 +-- [English]: The effective axis.text margin (pt), = 0.8 × half_line/2 +-- (faithful to ggplot). At the default of 11, this is 2.2, bit-identical +-- to the previous 'ggAxTextMar'. +effectiveAxTextMar :: VisualSpec -> Double +effectiveAxTextMar spec = 0.8 * (effectiveHalfLine spec / 2) + +-- | [日本語]: 実効 axis.title margin (pt) = half_line/2 (ggplot 忠実)。 既定 +-- 11 で 2.75 = 従来 'ggAxTitleMar' と bit 同値。 +-- [English]: The effective axis.title margin (pt), = half_line/2 +-- (faithful to ggplot). At the default of 11, this is 2.75, bit-identical +-- to the previous 'ggAxTitleMar'. +effectiveAxTitleMar :: VisualSpec -> Double +effectiveAxTitleMar spec = effectiveHalfLine spec / 2 + +-- | [日本語]: 実効凡例ベースフォント (pt) = 2 × half_line = base (ggplot +-- @base_size@ と一致)。 既定 11 で従来 'legendBaseSize' と bit 同値。 +-- [English]: The effective legend base font size (pt), = 2 × half_line = +-- base (matching ggplot's @base_size@). At the default of 11, +-- bit-identical to the previous 'legendBaseSize'. +effectiveLegendBaseSize :: VisualSpec -> Double +effectiveLegendBaseSize spec = 2 * effectiveHalfLine spec + +-- | [日本語]: 実効凡例キー 1 辺 (pt) = 1.2 lines (行高 1.3133 倍率は +-- 'legendKeyW' と同一)。 既定 11 で bit 同値。 pitch = keyW (キーセル隣接)。 +-- ★theme (toLegendKeySize、 ggplot legend.key.size 相当) が最優先。 +-- cowplot preset は 1.1 × font_size を焼き込む (gold 実測: base14 = 15.4pt +-- = 32px)。 +-- [English]: The effective legend key side length (pt), = 1.2 lines (the +-- 1.3133 line-height multiplier matches 'legendKeyW'). Bit-identical at +-- the default of 11. pitch = keyW (key cells adjacent). theme +-- (toLegendKeySize, corresponding to ggplot's legend.key.size) takes +-- priority. The cowplot preset bakes in 1.1 × font_size (measured against +-- gold: base14 = 15.4pt = 32px). +effectiveLegendKeyW :: VisualSpec -> Double +effectiveLegendKeyW spec = + maybe (1.2 * effectiveLegendBaseSize spec * 1.3133) id + (getLast (toLegendKeySize (vsThemeOverride spec))) + +effectiveLegendKeyPitch :: VisualSpec -> Double +effectiveLegendKeyPitch = effectiveLegendKeyW + +-- | [日本語]: 実効 subtitle / caption / tag font size (pt) = base 派生 +-- (ggplot theme_grey の倍率: plot.subtitle ×1 / plot.caption ×0.8 / +-- plot.tag ×1.2)。 旧固定 11/9/13 は base 11 の丸め値 (caption 8.8→9 / +-- tag 13.2→13) だったのを ggplot 忠実の派生式へ。 computeLayout (labs +-- 予約) と Render.labels (描画) の単一情報源。 +-- [English]: The effective subtitle / caption / tag font size (pt), +-- derived from base (ggplot theme_grey's multipliers: plot.subtitle ×1, +-- plot.caption ×0.8, plot.tag ×1.2). Replaces the old fixed 11/9/13 +-- (rounded values of base 11: caption 8.8→9, tag 13.2→13) with a formula +-- faithful to ggplot. A single source of truth shared by computeLayout +-- (labs reservation) and Render.labels (drawing). +effectiveSubtitleSize :: VisualSpec -> Double +effectiveSubtitleSize = effectiveBaseFontSize + +effectiveCaptionSize :: VisualSpec -> Double +effectiveCaptionSize spec = 0.8 * effectiveBaseFontSize spec + +effectiveTagSize :: VisualSpec -> Double +effectiveTagSize spec = 1.2 * effectiveBaseFontSize spec + +-- | [日本語]: slot の実効 font size (pt)。 解決順は Render.mkFontTS と同一 = +-- theme override (fsSize) > font setter (fsSize) > 既定 (base 派生)。 +-- setter と override は Maybe FontSpec の field-wise merge (override の +-- Just が優先)。 +-- [English]: The effective font size (pt) of a slot. Resolution order +-- matches Render.mkFontTS: theme override (fsSize) > the font setter +-- (fsSize) > the default (base-derived). The setter and override are +-- field-wise merged as Maybe FontSpec (a Just in override takes +-- priority). +effectiveFontSize :: Last FontSpec -> Last FontSpec -> Double -> Double +effectiveFontSize setterL overrideL def = + case getLast setterL <> getLast overrideL of + Just fs -> maybe def id (getLast (fsSize fs)) + Nothing -> def + +-- | [日本語]: layer 群に color/fill aesthetic (ColorByCol / ColorByContinuous) +-- があるか。 +-- [English]: Whether any layer in the group has a color/fill aesthetic +-- (ColorByCol or ColorByContinuous). +hasColorEncoding :: [Layer] -> Bool +hasColorEncoding = any (\l -> case getLast (lyColor l) of + Just (ColorByCol _) -> True + Just (ColorByContinuous _) -> True + _ -> False) + +-- | [日本語]: 軸 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)。 +-- [English]: Vector-formats axis tick labels following ggplot / base-R +-- @format()@. ggplot's default for continuous scales (@labels = waiver()@) +-- applies base R's @format()@ to the whole break vector. This reproduces +-- that behaviour: +-- +-- 1. Uses __the same decimal digit count for every break__ (keeping +-- trailing zeros). E.g. 0,.25,.5 becomes "0.00","0.25","0.50" +-- (the previous 'numToText' stripped zeros per value, +-- producing "0.5"). +-- 2. Chooses __fixed decimal vs. exponential__ by whichever has the +-- shorter maximum width (matching base R's @scipen = 0@: switches to +-- exponential only when fixed notation is wider). E.g. for density's +-- 0..5e-4, fixed "0.0005" (6 chars) is wider than exponential +-- "5e-04" (5 chars), so "0e+00".."5e-04" is used; for 0..1, fixed +-- "0.50" (4 chars) is no wider than exponential "5e-01" (5 chars), +-- so "0.00".."1.00" is used. +-- +-- Verified to match measured R @ggplot_build@ output (density y, 0..1 +-- ratio 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 桁上限。 +-- [English]: The decimal digits (0..10) needed to represent v without +-- error. Capped at 10 digits, assuming nice ticks. +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)。 +-- [English]: Normalizes v to a mantissa m∈[1,10) and an exponent e +-- (v = m * 10^e). 0 becomes (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")。 +-- [English]: A single exponential-notation string (a d-digit mantissa +-- plus "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 引数で指定。 +-- +-- 既定順を ggplot2 の factor 既定と同じ __アルファベット順__ ('orderedCats') +-- にした (= R4DS と凡例・色・軸並びを一致させる)。 明示順が要るときは +-- @scale_x_discrete(limits=)@ 相当の discrete-limits override (第 4 引数) を +-- 渡す (= fct_infreq / fct_reorder 相当)。 override 指定時はデータ内に +-- 在る水準だけをその順で返す (applyDiscreteLimits がデータ側を既に +-- filter/並べ替え済)。 +-- [English]: Categorical axis labels (the distinct ColTxt values, across +-- layers). Which encoding (encX / encY) is inspected is chosen by the +-- accessor argument. +-- +-- The default order matches ggplot2's default factor order, __alphabetical__ +-- ('orderedCats'), keeping legend/color/axis ordering consistent with +-- R4DS. When an explicit order is needed, pass a discrete-limits override +-- (the 4th argument) equivalent to @scale_x_discrete(limits=)@ (comparable +-- to fct_infreq / fct_reorder). When an override is given, only the +-- levels present in the data are returned, in that order +-- (applyDiscreteLimits has already filtered/reordered the data side). +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 -- 既定 = アルファベット順 + +-- | [日本語]: scale の range (rLo/rHi) を入替えて軸反転。 domain は不変なので +-- tick (= domain 値) は scaleApply 経由で自動的に逆向き座標へ写る。 全 +-- Scale variant が lsRangeLo/lsRangeHi を共有するため record update 1 つで +-- 賄える。 +-- [English]: Reverses an axis by swapping the scale's range (rLo/rHi). +-- Since the domain is unchanged, ticks (domain values) map automatically +-- to reversed coordinates via scaleApply. All Scale variants share +-- lsRangeLo/lsRangeHi, so a single record update suffices. +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 を +-- 与える。 +-- [English]: The context for resolving a 'Pos' to pt coordinates. Supplies +-- the panel rect and the x/y scales. +data UCtx = UCtx + { uDpi :: !Double -- ^ [日本語]: PAbs の Px を pt 化する dpi。 [English]: The dpi used to convert PAbs's Px to pt. + , uRect :: !Rect -- ^ [日本語]: panel rect (pt)。PNpc 解決に使う。 [English]: The panel rect (pt), used to resolve PNpc. + , uXScale :: !Scale -- ^ [日本語]: PNative (x) 解決。 [English]: Used to resolve PNative (x). + , uYScale :: !Scale -- ^ [日本語]: PNative (y) 解決。 [English]: Used to resolve PNative (y). + } deriving (Show, Eq) + +-- | [日本語]: x 座標の 'Pos' を pt へ。PNpc 0=左端 (rX), 1=右端 (rX+rW)。 +-- [English]: Resolves an x-coordinate 'Pos' to pt. For PNpc, 0 is the +-- left edge (rX) and 1 is the right edge (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 が処理。 +-- [English]: Resolves a y-coordinate 'Pos' to pt. Since device coordinates +-- point downward (rY is the top edge), PNpc 1 is the top edge (rY) and 0 +-- is the bottom edge (rY+rH). PNative is handled by the already-flipped +-- 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 の座標系。 明示 'vsCoord' 指定が最優先。 未指定でも +-- ★ Phase 69 A3: encZ を持つ layer があれば 'CoordTernary' と推論する +-- (encZ は ternary 専用 aesthetic ゆえ他座標系と衝突せず誤爆しない)。 それ以外は Cartesian。 +-- これにより最小形が @layer (ternaryScatter a b c)@ の 1 ピースで済む +-- (coordTernary を書き忘れて c=0 で潰れる事故も防ぐ)。 明示 coord は常に優先。 +-- [English]: A spec's coordinate system. An explicit 'vsCoord' wins. When +-- unspecified, ★ Phase 69 A3: infer 'CoordTernary' if any layer carries encZ +-- (encZ is a ternary-only aesthetic, so it never collides with other coords), +-- otherwise Cartesian. This lets the minimal form be a single +-- @layer (ternaryScatter a b c)@ (and prevents the collapse-to-c=0 accident of +-- forgetting coordTernary). An explicit coord always takes priority. +coordOf :: VisualSpec -> Coord +coordOf spec = case getLast (vsCoord spec) of + Just c -> c + Nothing + | any hasEncZ (vsLayers spec) -> CoordTernary defaultTernaryOpts + | otherwise -> CoordCartesian + where hasEncZ l = case getLast (lyEncZ l) of Just _ -> True; Nothing -> False + +-- | [日本語]: データ空間 (dx, dy) → px (横, 縦)。 Cartesian は (sx dx, sy dy)、 +-- Flip はデータ x を縦 px・データ y を横 px に (= 軸入替)。 +-- [English]: Maps data space (dx, dy) to px (horizontal, vertical). +-- Cartesian is (sx dx, sy dy); Flip maps data x to vertical px and data y +-- to horizontal px (swapping the axes). +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π、 上始点・ +-- 時計回り; start/direction は Phase 64 A16 で可変)、 他軸を半径 (中心=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) +-- ★ Phase 64 A12: 三角座標。 'projectXY' は 2 引数 (a,b) しか受けないので、 +-- 第 3 成分は @c = 1 - a - b@ と補完する (= a/b を既に fraction で渡す入力様式)。 +-- 3 列 (encX/encY/encZ) を直接投影する経路は §3-4 (A13) で geom 側が +-- 'ternaryPoint' を 3 引数で呼ぶ。 grid/tick は 'ternaryPoint' を直接使う。 +projectXY (CoordTernary _) l dx dy = ternaryPoint l (dx, dy, 1 - dx - dy) + +-- | [日本語]: scale の domain における正規化位置 [0,1] (= (v - dLo)/(dHi - +-- dLo))。 極座標で角度/半径の比率を出すのに使う。 domain が退化していれば +-- 0。 +-- [English]: The normalized position [0,1] within a scale's domain +-- ((v - dLo)/(dHi - dLo)). Used to compute angle/radius ratios in polar +-- coordinates. Returns 0 if the domain is degenerate. +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) + +-- | [日本語]: 極座標の中心とデータ最大半径。 +-- +-- ★ Phase 64 A8: 半径は **ggplot2 の npc 定数に合わせる** (それまでは +-- @min(w,h)/2@ = panel 内接円で、 外周が panel の縁にぴったり接するため +-- θ ラベル (外周のやや外) が必ず panel の外へ出てタイトルと重なっていた)。 +-- ggplot2 @coord-polar.R@ (2026-08-06 時点 main) の実装: +-- +-- * @r_rescale(x, range, donut = c(0, 0.4))@ (287-290 行) = +-- __データの最大半径は npc 0.4__ +-- * @render_fg@ (240-249 行) が θ ラベルを @0.45 * sin/cos + 0.5@ = +-- __npc 半径 0.45__ に中心揃えで置く +-- * panel 矩形の縁は中心から npc 0.5 +-- +-- つまり 0.4 (データ) \< 0.45 (θ ラベル・外周円) \< 0.5 (panel 縁) で、 +-- ggplot2 は__ラベルを panel の内側に収めることで余白予約を不要にしている__ +-- (@render_axis_h@ は空軸を返すだけ・@layout.R@ に θ 用の帯予約は無い)。 +-- 本実装もこれに倣うので 'computeLayout' は座標系を見る必要が無い。 +-- +-- [English]: The center and maximum data radius of polar coordinates. +-- Phase 64 A8 switched the radius to ggplot2's npc constants (it used to +-- be @min(w,h)/2@, the circle inscribed in the panel, which forced the +-- theta labels just outside it to leave the panel and collide with the +-- title). In ggplot2's @coord-polar.R@: data is rescaled into the donut +-- @c(0, 0.4)@, theta labels are centered at npc radius 0.45, and the +-- panel edge is at 0.5 — so labels stay inside the panel and no margin +-- reservation is needed. We follow the same ratios. +polarCenter :: Layout -> (Double, Double, Double) +polarCenter l = let a = lpPlotArea l + cx = rX a + rW a / 2 + cy = rY a + rH a / 2 + maxR = 0.4 * min (rW a) (rH a) + in (cx, cy, maxR) + +-- | [日本語]: θ ラベルを置く半径を、 データ最大半径 ('polarCenter' の maxR) との比で +-- 表したもの = @0.45 / 0.4 = 1.125@。 ggplot2 の npc 定数から導出 +-- (根拠は 'polarCenter' の注記)。 境界円 (= clip 境界) は maxR のままなので、 +-- ラベルは境界円の少し外・panel の内側という位置になる。 +-- [English]: The radius at which theta labels sit, as a ratio to the max +-- data radius: @0.45 / 0.4 = 1.125@, derived from ggplot2's npc constants +-- (see the note on 'polarCenter'). The boundary circle (and the clip +-- boundary) stays at maxR, so labels land just outside it but still +-- inside the panel. +polarOuterFrac :: Double +polarOuterFrac = 0.45 / 0.4 + +-- | [日本語]: 境界円 (= データ最大半径の円) を多角形近似した clip path +-- (Phase 64 A8 = B-2)。 @PClipPath@ に渡して「外周円の外に glyph が +-- 描かれない」 を実現する。 180 分割 (2°刻み) で、 半径 200px でも矢高誤差は +-- 0.03px 未満。 +-- [English]: A polygonal approximation of the boundary circle (at the max +-- data radius), for use with @PClipPath@ (Phase 64 A8 / B-2) so that no +-- glyph is drawn outside it. 180 segments (2 degrees each): the sagitta +-- error stays below 0.03px even at a 200px radius. +polarClipPath :: Layout -> [(Double, Double)] +polarClipPath l = + [ polarPoint l (fromIntegral i / n) 1.0 | i <- [0 .. round n - 1 :: Int] ] + where n = 180 :: Double + +-- | [日本語]: 極座標の開始角/回転方向を Layout の 'lpCoord' から取り出す +-- (= Phase 64 A16 = coord_polar(start=, direction=))。 polar でなければ既定 +-- (start=0, dir=+1)。 投影が 'polarPoint' 1 箇所に閉じているので、 grid / +-- スポーク / θ ラベルもこの opts を通る。 +-- [English]: Extracts the polar start angle / direction from the Layout's +-- 'lpCoord' (Phase 64 A16 = coord_polar(start=, direction=)). Returns the +-- default (start=0, dir=+1) for non-polar coords. Since projection is +-- confined to 'polarPoint', grid / spokes / theta labels all honor these. +polarOptsOf :: Coord -> (Double, Double) +polarOptsOf (CoordPolarX o) = (polarStart o, polarDirection o) +polarOptsOf (CoordPolarY o) = (polarStart o, polarDirection o) +polarOptsOf _ = (0, 1) + +-- | [日本語]: (角度 frac, 半径 frac) → px。 角度は 'lpCoord' の 'PolarOpts' で +-- @theta = start + dir * frac * 2π@ (既定 start=0=真上・dir=+1=時計回り)、 +-- 半径 frac=1 が外周。 +-- [English]: Maps (angle fraction, radius fraction) to px. The angle is +-- @theta = start + dir * frac * 2π@ from the 'PolarOpts' in 'lpCoord' +-- (default start=0 = top, dir=+1 = clockwise); radius fraction 1 is the +-- outer edge. +polarPoint :: Layout -> Double -> Double -> (Double, Double) +polarPoint l thetaFrac rFrac = + let (cx, cy, maxR) = polarCenter l + (start, dir) = polarOptsOf (lpCoord l) + theta = start + dir * thetaFrac * 2 * pi + r = rFrac * maxR + in (cx + r * sin theta, cy - r * cos theta) + +-- | [日本語]: 三角座標 (ternary) の中心と外接円半径 (= Phase 64 A12、 'polarCenter' +-- の対)。 正三角形は panel 矩形に内接し、 **極座標と同じ短辺基準の npc 0.4** で +-- 寸法を決める (中心から各頂点まで @R = 0.4*min(w,h)@)。 三角形の高さは @1.5R@・ +-- 幅は @√3 R@ で、 どちらも @min(w,h)@ 未満に収まり四方に軸ラベルの余白が残る。 +-- [English]: The center and circumradius of ternary coordinates (Phase 64 +-- A12; the counterpart of 'polarCenter'). The equilateral triangle is +-- inscribed in the panel rectangle and sized on the short side at npc 0.4 +-- (@R = 0.4*min(w,h)@ from the center to each vertex), matching polar. The +-- triangle's height @1.5R@ and width @√3 R@ both stay within @min(w,h)@, +-- leaving margin on all sides for axis labels. +ternaryCenter :: Layout -> (Double, Double, Double) +ternaryCenter l = + let a = lpPlotArea l + s = sqrt 3 / 2 + -- ★ Phase 69 A5: 三角図が plotArea に比べて小さく・上寄りだった (user 指摘) のを是正。 + -- 旧: @r = 0.4 * min(w,h)@ (保守的 + min で幅を活かせず) / 中心 = plotArea 中央 + -- (= 外接中心を置く → 上頂点は r 上・底辺は r/2 下で外接矩形が上へずれ、 下に余白過多)。 + -- 新: 三角形の実アスペクト (幅 √3·r / 高さ 1.5·r) と辺ラベル/頂点タイトル用の外周 + -- マージンから最大 r を算出し、 外接矩形 (縦幅 1.5r) の中心を plotArea 中心へ揃える。 + mLabel = 32 -- 頂点タイトル (outward 22 + 文字) / tick ラベル用の外周余白 + availW = max 1 (rW a - 2 * mLabel) + availH = max 1 (rH a - 2 * mLabel) + r = max 1 (min (availW / (2 * s)) (availH / 1.5)) -- 幅 √3r ≤ availW かつ 高さ 1.5r ≤ availH + cx = rX a + rW a / 2 + -- 外接矩形の縦中心 (cy - r/4) を plotArea 中心へ → cy を r/4 下げて上下均等に。 + cy = rY a + rH a / 2 + r / 4 + in (cx, cy, r) + +-- | [日本語]: 三角座標の 3 頂点の px。 成分 @(a,b,c)@ と頂点の対応 = **a=上 (12 時)・ +-- b=左下・c=右下** (中心から 90°/210°/330° = 反時計回り)。 'ternaryPoint' / +-- 'ternaryGrid' / clip path が共有する単一情報源。 +-- [English]: The pixel positions of the three ternary vertices. Component ↔ +-- vertex: **a = top (12 o'clock), b = bottom-left, c = bottom-right** (at +-- 90°/210°/330° from the center). Shared single source of truth for +-- 'ternaryPoint', the grid, and the clip path. +ternaryVertices :: Layout -> ((Double, Double), (Double, Double), (Double, Double)) +ternaryVertices l = + let (cx, cy, r) = ternaryCenter l + s = sqrt 3 / 2 + top = (cx, cy - r) -- 上 + bl = (cx - r * s, cy + r / 2) -- 左下 + br = (cx + r * s, cy + r / 2) -- 右下 + -- ★ Phase 69 A4: 向き opts を 'lpCoord' から読む (既定 = a=top/b=bl/c=br の従来配置)。 + -- clockwise は左下↔右下 を反転 (巡回方向を逆に)、 rotate は成分→頂点の割当を + -- 反時計回りに 120° ずつ巡回する。 + (clockwise, rot) = case lpCoord l of + CoordTernary o -> (ternaryClockwise o, ternaryRotate o) + _ -> (False, 0) + base = if clockwise then [top, br, bl] else [top, bl, br] -- 頂点の巡回列 (CCW / CW) + k = (rot `div` 120) `mod` 3 + -- 成分 (a,b,c) を base の巡回位置へ割り当てる (k 段ずらす)。 + rotated = drop k base ++ take k base + in case rotated of + (pa : pb : pc : _) -> (pa, pb, pc) + _ -> (top, bl, br) + +-- | [日本語]: 正規化済み成分 @(a,b,c)@ (合計 1 前提) → px。 重心座標 +-- @P = a*A + b*B + c*C@ ('ternaryVertices' の 3 頂点)。 正規化は呼出側で +-- 'normalizeTernary' を通す (= 退化行はそこで Nothing となり描画対象から落ちる)。 +-- [English]: Maps normalized components @(a,b,c)@ (assumed to sum to 1) to +-- pixels via barycentric coordinates @P = a*A + b*B + c*C@ over the three +-- 'ternaryVertices'. Callers normalize through 'normalizeTernary' first (so +-- degenerate rows become Nothing and are dropped from rendering). +ternaryPoint :: Layout -> (Double, Double, Double) -> (Double, Double) +ternaryPoint l (a, b, c) = + let ((ax, ay), (bx, by), (cx, cy)) = ternaryVertices l + in (a * ax + b * bx + c * cx, a * ay + b * by + c * cy) + +-- | [日本語]: データ空間の矩形 (x/y の min/max) → px Rect。 Flip では bbox が +-- 縦横転置される。 2 隅を projectXY して min/abs で正規化するだけ (= 向きに +-- 依らず正しい Rect)。 +-- [English]: Maps a data-space rectangle (x/y min/max) to a px Rect. Under +-- Flip, the bbox is transposed. Simply projects two corners via projectXY +-- and normalizes with min/abs (correct regardless of orientation). +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 の +-- まま = 軸スケールに依らない)。 +-- [English]: For bar/box: builds a px Rect from the centerline's data +-- coordinate (centerD, the x-group position), the base..value data +-- interval, and the thickness thicknessPx (the bar width in px). Under +-- Cartesian, horizontal position = centerD ± thickness/2 and +-- vertical = base..value. Under Flip, vertical position = +-- centerD ± thickness/2 and horizontal = base..value (thickness always +-- stays in px, independent of the axis scale). +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 +-- 極座標の 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 64 §3 (A12) までは ternary も Cartesian placeholder (未 render 経路)。 +projectBarRect (CoordTernary _) l centerD baseD valueD thicknessPx = + projectBarRect CoordCartesian l centerD baseD valueD thicknessPx + +-- | [日本語]: 扇形 (annular sector) の path。 (tf0..tf1) = 角度 frac 帯、 +-- (rf0..rf1) = 半径 frac 帯。 円弧は 0.1 rad 刻みの折線近似 (nSeg ≥ 2)。 +-- polar bar (rose/pie) と 'projectBar' が共有する。 +-- [English]: The path of an annular sector. (tf0..tf1) is the angular +-- fraction band and (rf0..rf1) the radial fraction band. Arcs are +-- approximated by a polyline at 0.1 rad per segment (nSeg >= 2). Shared by +-- polar bars (rose / pie) and 'projectBar'. +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] + [] -> [] + +-- | [日本語]: データ空間の線分 → px polyline。 直線座標系 (Cartesian/Flip) は +-- 両端の 2 点 (= 従来の直線結線と bit 一致)、 極座標は data 空間で線形補間した +-- 中間点を 'projectXY' で投影し θ 0.1 rad 刻み ('wedgeSegments' と同粒度) の +-- 折線に曲げる。 θ 不変 (= 純 radial) な線分は 2 点のまま。 geom はこの関数を +-- 通すことで「線分が座標系でどう曲がるか」 を知らずに済む。 +-- [English]: Projects a segment in data space to a pixel polyline. Linear +-- coordinate systems (Cartesian / Flip) give just the two endpoints (bit +-- identical to the previous straight-line joining); polar systems bend the +-- segment into a polyline by projecting intermediate points — linearly +-- interpolated in data space — through 'projectXY' at 0.1 rad per segment +-- (the same granularity as 'wedgeSegments'). A segment at constant theta +-- (purely radial) stays two points. Going through this function frees each +-- geom from knowing how a segment bends under the coordinate system. +projectSegment :: Coord -> Layout -> (Double, Double) -> (Double, Double) -> [Point] +projectSegment coord l (dx0, dy0) (dx1, dy1) + | not (isPolar coord) = + [ uncurry Point (projectXY coord l dx0 dy0) + , uncurry Point (projectXY coord l dx1 dy1) ] + | otherwise = + let (tf0, tf1) = case coord of + CoordPolarY _ -> (domFrac (lpYScale l) dy0, domFrac (lpYScale l) dy1) + _ -> (domFrac (lpXScale l) dx0, domFrac (lpXScale l) dx1) + dTheta = abs (tf1 - tf0) * 2 * pi + nSeg = max 1 (ceiling (dTheta / 0.1)) :: Int + lerp a b t = a + (b - a) * t + ts = [ fromIntegral i / fromIntegral nSeg | i <- [0 .. nSeg] ] + in [ uncurry Point (projectXY coord l (lerp dx0 dx1 t) (lerp dy0 dy1 t)) + | t <- ts ] + +-- | [日本語]: bar/box 系「data 空間の棒」 の座標系対応形状。 geom 側の +-- @case coord of@ を「形状の case」 に置き換えるための戻り値型。 +-- [English]: The coordinate-aware shape of a "bar in data space" for the +-- bar / box family. This return type replaces each geom's @case coord of@ +-- with a case on the shape instead. +data BarShape = BarRect !Rect | BarWedge ![PathSegment] + deriving (Show, Eq) + +-- | [日本語]: 棒 (中心 centerD ± halfWidthD、 base..value) の投影 dispatcher。 +-- 直線座標系は 'projectBarRect' の px Rect (= bit 一致、 厚みは従来通り px 指定)、 +-- 極座標は 'wedgeSegments' の扇形。 halfWidthD は data 単位の半幅 (bar 既定 0.45 +-- = resolution 0.9 の半分)、 thicknessPx は直線座標系専用の px 厚み (極座標では +-- 未使用)。 PolarX = 角度帯 centerD±halfWidthD × 半径 base..value (rose)、 +-- PolarY = 角度 base..value × 半径帯 centerD±halfWidthD (内径は 0 で clamp)。 +-- [English]: The projection dispatcher for a bar (centered at centerD with +-- half width halfWidthD, spanning base..value). Linear coordinate systems +-- give the pixel 'Rect' of 'projectBarRect' (bit identical; thickness is +-- still given in pixels), polar systems the annular sector of +-- 'wedgeSegments'. halfWidthD is the half width in data units (0.45 by +-- default for bars, half of the 0.9 resolution); thicknessPx is the pixel +-- thickness used only by linear systems. PolarX gives an angular band of +-- centerD±halfWidthD over radius base..value (a rose); PolarY gives angle +-- base..value over the radial band centerD±halfWidthD (inner radius clamped +-- at 0). +-- domain 退化 (span=0) 時の半幅 frac は 0.5 (= 旧 hwFrac の既定と同一)。 +projectBar :: Coord -> Layout -> Double -> Double -> Double -> Double -> Double + -> BarShape +projectBar coord l centerD baseD valueD halfWidthD thicknessPx = case coord of + CoordPolarX _ -> BarWedge (wedgeSegments l (cfx - hf) (cfx + hf) + (dfy baseD) (dfy valueD)) + CoordPolarY _ -> BarWedge (wedgeSegments l (dfy baseD) (dfy valueD) + (max 0 (cfx - hf)) (cfx + hf)) + _ -> BarRect (projectBarRect coord l centerD baseD valueD thicknessPx) + where + cfx = domFrac (lpXScale l) centerD + dfy = domFrac (lpYScale l) + spanX = lsDomainHi (lpXScale l) - lsDomainLo (lpXScale l) + hf = if spanX == 0 then 0.5 else halfWidthD / spanX + +-- | [日本語]: categorical-cross geom (box/violin/strip/swarm) の群中心指定。 +-- 'CrossAt' = cross 軸の data 座標 (categorical slot 位置 / dodge sub-slot 中心)、 +-- 'CrossMid' = 単一群 (カテゴリ軸なし) の「plotArea 中央」。 CrossMid を px で +-- なく変種として持つのは、 中央 px 自体が coord (Cartesian=横 / Flip=縦) に +-- 依存するため (= geom 側から case coord of を無くす)。 +-- [English]: Specifies the group center for categorical-cross geoms (box / +-- violin / strip / swarm). 'CrossAt' is a data coordinate on the cross axis +-- (a categorical slot position, or the center of a dodge sub-slot); +-- 'CrossMid' is "the middle of the plot area" for a single group with no +-- categorical axis. 'CrossMid' is a constructor rather than a pixel value +-- because that middle pixel itself depends on the coordinate system +-- (horizontal under Cartesian, vertical under Flip) — which is exactly what +-- lets each geom drop its @case coord of@. +data CrossLoc = CrossAt !Double | CrossMid + deriving (Show, Eq) + +-- | [日本語]: CrossLoc の cross 軸 data 座標 (polar 経路用)。 CrossMid は +-- x domain 中点 (= scale が plotArea を張る前提で plotArea 中央と affine 一致)。 +-- [English]: The cross-axis data coordinate of a 'CrossLoc', used by the +-- polar path. 'CrossMid' is the midpoint of the x domain, which coincides +-- affinely with the middle of the plot area given that the scale spans it. +crossLocD :: Layout -> CrossLoc -> Double +crossLocD _ (CrossAt d) = d +crossLocD l CrossMid = (lsDomainLo (lpXScale l) + lsDomainHi (lpXScale l)) / 2 + +-- | [日本語]: 極座標で「投影済み点を cross 軸方向へ offPx (px) ずらす」。 +-- PolarX (cross=角度) は接線方向 = 中心まわりの回転 (弧長 offPx)、 +-- PolarY (cross=半径) は radial。 jitter / beeswarm / violin 幅は視覚 px 量 +-- (点径・重なり回避) なので、 polar でも data 角度でなく px 弧長で当てるのが正 +-- (半径によらず点間隔が保たれる)。 半径 ≈ 0 は接線方向が定義できないため +-- 動かさない。 直線座標系は恒等 (linear 経路は projectCross* が px 加算で +-- 処理し、 ここへは来ない)。 +-- [English]: Nudges an already-projected point by offPx pixels along the +-- cross axis, in polar coordinates. Under PolarX (cross = angle) this is +-- tangential — a rotation about the center by arc length offPx; under +-- PolarY (cross = radius) it is radial. Jitter, beeswarm spread and violin +-- width are visual pixel quantities (point diameter, overlap avoidance), so +-- applying them as a pixel arc length rather than a data angle is the +-- correct choice even in polar: point spacing is then preserved regardless +-- of radius. At radius near 0 the tangential direction is undefined, so the +-- point is left alone. Linear coordinate systems are the identity here (the +-- linear path adds pixels inside projectCross* and never reaches this +-- function). +polarNudgePx :: Coord -> Layout -> Double -> Point -> Point +polarNudgePx coord l offPx p@(Point px py) = + let (cx, cy, _) = polarCenter l + dx = px - cx + dy = py - cy + r = sqrt (dx * dx + dy * dy) + in if r < 1e-9 then p else case coord of + CoordPolarX _ -> + -- 弧長 offPx = 角度 offPx/r の回転 (polarPoint と同じ時計回りが正)。 + let dTh = offPx / r + c = cos dTh + s = sin dTh + in Point (cx + dx * c - dy * s) (cy + dx * s + dy * c) + CoordPolarY _ -> + let k = (r + offPx) / r + in Point (cx + dx * k) (cy + dy * k) + _ -> p + +-- | [日本語]: 「categorical cross × 連続 value」 geom の点投影。 box の外れ値・ +-- strip の jitter 点・swarm の beeswarm 点・violin outline は全てここを通す。 +-- offPx = cross 軸方向の px offset (nudge / jitter / 幅)。 Cartesian/Flip は +-- 旧 geom 内 px 式と bit 一致: Cartesian = Point (sx cross + offPx) (sy v)、 +-- Flip = Point (syF v) (sxF cross + offPx)。 polar は projectXY 投影後に +-- 'polarNudgePx' で px nudge。 +-- [English]: Projects a point for a "categorical cross by continuous value" +-- geom. Box outliers, strip jitter points, swarm beeswarm points and violin +-- outlines all go through this. offPx is the pixel offset along the cross +-- axis (nudge / jitter / width). Cartesian and Flip are bit identical to +-- the pixel formulas previously inlined in each geom: Cartesian gives +-- @Point (sx cross + offPx) (sy v)@ and Flip gives +-- @Point (syF v) (sxF cross + offPx)@. Polar projects through 'projectXY' +-- first and then nudges in pixels via 'polarNudgePx'. +projectCrossPoint :: Coord -> Layout -> CrossLoc -> Double -> Double -> Point +projectCrossPoint CoordCartesian l loc offPx v = + let base = case loc of + CrossAt d -> scaleApply (lpXScale l) d + CrossMid -> let ar = lpPlotArea l in rX ar + rW ar / 2 + in Point (base + offPx) (scaleApply (lpYScale l) v) +projectCrossPoint CoordFlip l loc offPx v = + let base = case loc of + CrossAt d -> scaleApply (lpXScaleFlipped l) d + CrossMid -> let ar = lpPlotArea l in rY ar + rH ar / 2 + in Point (scaleApply (lpYScaleFlipped l) v) (base + offPx) +projectCrossPoint coord l loc offPx v = + polarNudgePx coord l offPx + (uncurry Point (projectXY coord l (crossLocD l loc) v)) + +-- | [日本語]: value 軸方向の px 座標 (単調)。 beeswarm binning 等「値どうしの +-- px 間隔」 が要る geom 用。 Cartesian/Flip は旧 sy / flip 式と bit 一致。 +-- polar は PolarX (value=半径) = 半径 px、 PolarY (value=角度) = 外周弧長 px。 +-- [English]: A monotone pixel coordinate along the value axis, for geoms +-- that need the pixel spacing between values (beeswarm binning and the +-- like). Cartesian and Flip are bit identical to the previous sy / flipped +-- formulas. In polar, PolarX (value = radius) gives the radius in pixels +-- and PolarY (value = angle) gives the arc length along the outer circle. +valueAxisPx :: Coord -> Layout -> Double -> Double +valueAxisPx CoordCartesian l v = scaleApply (lpYScale l) v +valueAxisPx CoordFlip l v = scaleApply (lpYScaleFlipped l) v +valueAxisPx (CoordPolarX _) l v = + let (_, _, maxR) = polarCenter l in domFrac (lpYScale l) v * maxR +valueAxisPx (CoordPolarY _) l v = + let (_, _, maxR) = polarCenter l in domFrac (lpYScale l) v * (2 * pi * maxR) +-- ★ Phase 64 §3 (A11) までは ternary の value 軸は Cartesian に fallback。 +valueAxisPx (CoordTernary _) l v = scaleApply (lpYScale l) v + +-- | [日本語]: value 一定で cross 方向へ ±半幅の短線 (box の median / whisker cap)。 +-- 直線座標系は px 半幅 halfPx の 2 点 (旧式 bit 一致: [base+offPx-halfPx, +-- base+offPx+halfPx])、 polar は data 半幅 halfD の弧 ('projectSegment') を +-- offPx だけ nudge した polyline (点列 ≥ 2)。 +-- [English]: A short span of ±half width along the cross axis at a fixed +-- value (a box's median line or whisker cap). Linear coordinate systems +-- give two points at pixel half width halfPx (bit identical to the previous +-- formula: @[base+offPx-halfPx, base+offPx+halfPx]@); polar gives a +-- polyline of at least two points — the arc of data half width halfD from +-- 'projectSegment', nudged by offPx. +projectCrossSpan :: Coord -> Layout -> CrossLoc -> Double -> Double -> Double + -> Double -> [Point] +projectCrossSpan coord l loc offPx halfPx halfD v + | not (isPolar coord) = + [ projectCrossPoint coord l loc (offPx - halfPx) v + , projectCrossPoint coord l loc (offPx + halfPx) v ] + | otherwise = + let d = crossLocD l loc + in map (polarNudgePx coord l offPx) + (projectSegment coord l (d - halfD, v) (d + halfD, v)) + +-- | [日本語]: box 本体等「cross 中心 ± 半幅 × value 区間」 の投影。 直線座標系は +-- px 半幅 halfPx の Rect (旧 geom 内 mkRect 式と bit 一致)、 polar は 'projectBar' +-- と同じ data 半幅 halfD の扇形 (wedge) を offPx だけ nudge。 +-- [English]: Projects "cross center ± half width by value interval" — the +-- body of a box and the like. Linear coordinate systems give a 'Rect' at +-- pixel half width halfPx (bit identical to the mkRect formula previously +-- inlined in each geom); polar gives the annular sector of data half width +-- halfD, as in 'projectBar', nudged by offPx. +projectCrossBar :: Coord -> Layout -> CrossLoc -> Double -> Double -> Double + -> Double -> Double -> BarShape +projectCrossBar CoordCartesian l loc offPx halfPx _halfD vLo vHi = + let base = case loc of + CrossAt d -> scaleApply (lpXScale l) d + CrossMid -> let ar = lpPlotArea l in rX ar + rW ar / 2 + cc = base + offPx + sy = scaleApply (lpYScale l) + in BarRect (Rect (cc - halfPx) (min (sy vLo) (sy vHi)) + (2 * halfPx) (abs (sy vHi - sy vLo))) +projectCrossBar CoordFlip l loc offPx halfPx _halfD vLo vHi = + let base = case loc of + CrossAt d -> scaleApply (lpXScaleFlipped l) d + CrossMid -> let ar = lpPlotArea l in rY ar + rH ar / 2 + cc = base + offPx + syF = scaleApply (lpYScaleFlipped l) + in BarRect (Rect (min (syF vLo) (syF vHi)) (cc - halfPx) + (abs (syF vHi - syF vLo)) (2 * halfPx)) +projectCrossBar coord l loc offPx _halfPx halfD vLo vHi = + let d = crossLocD l loc + nudgeP = polarNudgePx coord l offPx + nudgeSeg seg = case seg of + MoveTo p -> MoveTo (nudgeP p) + LineTo p -> LineTo (nudgeP p) + CurveTo a b c -> CurveTo (nudgeP a) (nudgeP b) (nudgeP c) + ClosePath -> ClosePath + in case projectBar coord l d vLo vHi halfD 0 of + BarWedge segs | offPx /= 0 -> BarWedge (map nudgeSeg segs) + shape -> shape + +-- | [日本語]: 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)。 +-- [English]: The cross-axis px width of a single categorical slot (used +-- for bar/box thickness). Under Cartesian, this is 1 unit of the x axis +-- (sx); under Flip, categories run vertically, so it is 1 vertical unit +-- of the flipped scale. Always using (sx 1 - sx 0) instead would let bars +-- overrun their vertical slot and overlap when flipped. Under Cartesian, +-- it is exactly (sx 1 - sx 0) (zero diff). +-- | [日本語]: ggplot @resolution(x)@ = ソート済み一意値の最小正間隔。 +-- errorbar/crossbar の cap 幅をデータ単位化する基準 (width = markWidth × +-- resolution)。 一意値が 1 個以下なら 1 (categorical = 整数位置 0,1,2… で +-- 間隔 1・単一点も 1)。 +-- [English]: ggplot's @resolution(x)@: the smallest positive gap between +-- sorted unique values. The basis for converting errorbar/crossbar cap +-- width to data units (width = markWidth × resolution). If there is at +-- most one unique value, returns 1 (categorical positions are integers +-- 0,1,2… with gap 1; a single point also gives 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 +catUnitPx (CoordTernary _) l = scaleApply (lpXScale l) 1 - scaleApply (lpXScale l) 0 + +-- | [日本語]: 軸が物理的にどの辺に来るか。 Cartesian: データ x=下・y=左。 +-- Flip: データ x=左・y=下。 極座標は直交的な辺軸を持たない (Render の polar +-- 分岐が独自に grid/軸を描く)。 +-- [English]: Which physical edge an axis is placed on. Cartesian: data +-- x=bottom, y=left. Flip: data x=left, y=bottom. Polar coordinates have no +-- orthogonal edge axis (Render's polar branch draws its own grid/axes). +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)。 +-- [English]: Whether the grid line for data x is vertical (Cartesian) or +-- horizontal (Flip). +coordXGridIsVertical :: Coord -> Bool +coordXGridIsVertical CoordFlip = False +coordXGridIsVertical _ = True + +-- | [日本語]: 極座標か (= CoordPolarX / CoordPolarY)。 +-- [English]: Whether this is polar (CoordPolarX or CoordPolarY). +isPolar :: Coord -> Bool +isPolar (CoordPolarX _) = True +isPolar (CoordPolarY _) = True +isPolar _ = False + +-- | [日本語]: 三角座標か (= 'CoordTernary')。 直交 tick の抑止 / grid ディスパッチ +-- (Phase 64 §3 A12) の判定に使う。 'isPolar' と同型。 +-- [English]: Whether this is ternary (CoordTernary). Used to suppress the +-- orthogonal ticks and to dispatch the grid (Phase 64 §3 A12); analogous to +-- 'isPolar'. +isTernary :: Coord -> Bool +isTernary (CoordTernary _) = True +isTernary _ = False + +-- | [日本語]: 三角座標の 3 成分 @(a,b,c)@ を合計 1 へ正規化 (= Phase 64 A11)。 +-- 組成データは合計が 1 (100%) でなくてもよく、 内部で @a\/(a+b+c)@ に正規化する。 +-- ★ 退化行の扱い (2026-08-07 user 判断 = 行ごと除外): **いずれかの成分が負** または +-- **合計 \<= 0** の行は組成データとして不正なので 'Nothing' を返し、 呼出側 +-- (§3 A12 の投影) が描画対象から落とす (= 欠損データと同じ扱い)。 +-- [English]: Normalizes a ternary triple @(a,b,c)@ to sum 1 (Phase 64 A11). +-- Compositional data need not already sum to 1; it is normalized internally +-- to @a\/(a+b+c)@. Degenerate-row policy (user decision 2026-08-07 = drop the +-- row): a row with **any negative component** or a **sum \<= 0** is invalid +-- compositional data, so 'Nothing' is returned and the caller (the §3 A12 +-- projection) drops it from rendering (treated like missing data). +normalizeTernary :: (Double, Double, Double) -> Maybe (Double, Double, Double) +normalizeTernary (a, b, c) + | a < 0 || b < 0 || c < 0 = Nothing + | s <= 0 = Nothing + | otherwise = Just (a / s, b / s, c / s) + where s = a + b + c + +-- | [日本語]: D3 風 nice tick (= 1/2/5 × 10^k の刻み)。 +-- [English]: D3-style nice ticks (steps of 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 + +-- | [日本語]: 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 に上限ガードを置く (実用域では枝刈りが先に +-- 効く)。 +-- [English]: A port of R's labeling::extended (Talbot, Lin & Hanrahan +-- 2010, "An Extension of Wilkinson's Algorithm…"), matching ggplot2's +-- default breaks (`scales::extended_breaks(n)`): candidate steps +-- Q=[1,5,2,2.5,4,3], weights w=[simplicity 0.25, coverage 0.2, +-- density 0.5, legibility 0.05], only.loose=False, legibility always 1 +-- (a placeholder in the R implementation too). Selects (lmin, lmax, +-- lstep) that maximises the weighted score of simplicity/coverage/ +-- density, and returns an evenly spaced break sequence. The input +-- (dmin,dmax) is __the data range before expansion__; m is the target +-- label count. Replaces the previous niceTicks (1/2/5×10^k) on linear +-- axes (matching ggplot's endpoints and tick count). +-- +-- The nested j→q→k→z→start loops reproduce the R implementation +-- directly. Each level stops via pruning on its upper bound +-- (simplicityMax / densityMax / coverageMax), with upper-bound guards on +-- j/k/z as a floating-point safety net (pruning kicks in first in +-- practical ranges). +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 +-- を出す。 +-- [English]: Ticks for the Log scale (a 10^k grid). Emits integer +-- exponents within the domain. +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: sqrt 後を niceTicks に通し、 二乗して戻す。 +-- domain が非負前提。 負値 lo は 0 にクランプ。 +-- [English]: Ticks for the Sqrt scale: passes sqrt-transformed values +-- through niceTicks, then squares them back. Assumes a non-negative +-- domain; a negative lo is clamped to 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: unix epoch (= seconds since 1970) を入力に、 +-- 「綺麗な」 間隔 (= 1m / 1h / 1d / 1w / 1M / 1y) で tick を生成。 簡略実装: +-- linear nice ticks を秒単位で取り、 1m / 1h / 1d / 1w 単位に丸め。 月 / 年 +-- 単位の境界調整は将来。 +-- [English]: Ticks for the Time scale: takes a unix epoch (seconds since +-- 1970) as input and generates ticks at "nice" intervals (1m / 1h / 1d / +-- 1w / 1M / 1y). A simplified implementation: takes linear nice ticks in +-- seconds and rounds to 1m / 1h / 1d / 1w units. Boundary adjustment for +-- month / year units is future work. niceTimeTicks :: Int -> Double -> Double -> [Double] niceTimeTicks n lo hi | hi <= lo = [lo] diff --git a/src/Graphics/Hgg/Layout/Grid.hs b/src/Graphics/Hgg/Layout/Grid.hs --- a/src/Graphics/Hgg/Layout/Grid.hs +++ b/src/Graphics/Hgg/Layout/Grid.hs @@ -1,25 +1,44 @@ -- | -- Module : Graphics.Hgg.Layout.Grid --- Description : subplots / <-> / <:> のネストを単一統一グリッドへ平坦化 (Phase 37 A2) +-- Description : Flattens nested subplots / <-> / <:> into a single unified grid -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 37 A2: subplots / @<->@ / @<:>@ のネストを **単一の統一グリッド**へ --- 平坦化する純関数。 patchwork 流 gtable 配置 (A3) の前段で、 任意の深さの +-- [日本語]: subplots / @<->@ / @<:>@ のネストを __単一の統一グリッド__へ +-- 平坦化する純関数。 patchwork 流 gtable 配置の前段で、 任意の深さの -- 入れ子を各 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 : @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 で一致する。 +-- [English]: A pure function that flattens nested subplots / @<->@ / @<:>@ +-- into __a single unified grid__. As a step before patchwork-style gtable +-- placement, it reduces arbitrarily deep nesting into a flat grid, giving +-- each leaf panel a @(rowStart, rowSpan, colStart, colSpan)@. Rendering +-- (Render/Layer) then only needs to reserve "left/right bands per column, +-- top/bottom bands per row" once for this single grid, which guarantees +-- panel-body alignment across nesting boundaries. +-- +-- Approach (see the design section of the plan): recursively computes +-- tree dimensions in integer grid units. +-- * leaf: @w=1, h=1@. +-- * hbox (side-by-side): @w=Σ child.w@, @h=max child.h@. Each child spans +-- its own width × the group height (row), keeping rows aligned. +-- * vbox (stacked): @h=Σ child.h@, @w=max child.w@. Each child spans the +-- group width (column) × its own height, keeping columns aligned. +-- Stretching a leaf to fill the span direction (vertical for hbox, +-- horizontal for vbox) means @d@ in @(a<->b<->c)<:>d@ spans the top row's +-- 3 columns at colSpan=3, so the top row's left edge lines up with the +-- bottom row's left edge at col0. {-# LANGUAGE BangPatterns #-} module Graphics.Hgg.Layout.Grid @@ -39,35 +58,49 @@ -- 型 -- =========================================================================== --- | 統一グリッド上の 1 パネルの占有矩形 (整数セル単位)。 +-- | [日本語]: 統一グリッド上の 1 パネルの占有矩形 (整数セル単位)。 +-- [English]: The rectangle a single panel occupies on the unified grid (in +-- integer cell units). data GridCell = GridCell - { gcRow :: !Int -- ^ 開始行 (0 始まり) - , gcRowSpan :: !Int -- ^ またぐ行数 (>= 1) - , gcCol :: !Int -- ^ 開始列 (0 始まり) - , gcColSpan :: !Int -- ^ またぐ列数 (>= 1) + { gcRow :: !Int -- ^ [日本語]: 開始行 (0 始まり)。 [English]: The starting row (0-based). + , gcRowSpan :: !Int -- ^ [日本語]: またぐ行数 (>= 1)。 [English]: The number of rows spanned (>= 1). + , gcCol :: !Int -- ^ [日本語]: 開始列 (0 始まり)。 [English]: The starting column (0-based). + , gcColSpan :: !Int -- ^ [日本語]: またぐ列数 (>= 1)。 [English]: The number of columns spanned (>= 1). } deriving (Eq, Show) --- | 平坦化結果。 グリッド総寸法 + leaf パネルとその占有セル。 +-- | [日本語]: 平坦化結果。 グリッド総寸法 + leaf パネルとその占有セル。 +-- [English]: The flattening result: overall grid dimensions plus each leaf +-- panel and its occupied cell. data GridPlacement = GridPlacement - { gpCols :: !Int -- ^ 統一グリッドの総列数 - , gpRows :: !Int -- ^ 統一グリッドの総行数 - , gpPanels :: ![(VisualSpec, GridCell)] -- ^ leaf パネル (描画対象) とセル + { gpCols :: !Int -- ^ [日本語]: 統一グリッドの総列数。 [English]: The total column count of the unified grid. + , gpRows :: !Int -- ^ [日本語]: 統一グリッドの総行数。 [English]: The total row count of the unified grid. + , gpPanels :: ![(VisualSpec, GridCell)] -- ^ [日本語]: leaf パネル (描画対象) とセル。 [English]: The leaf panels (render targets) with their cells. } --- | subplots ツリーの中間表現。 @<->@ は 'PH'、 @<:>@ は 'PV'、 単一プロットは 'PLeaf'。 --- 汎用 subplots (cols が 1 でも要素数でもない wrap grid) は @PV [PH ...]@ へ正規化する。 +-- | [日本語]: subplots ツリーの中間表現。 @<->@ は 'PH'、 @<:>@ は 'PV'、 単一 +-- プロットは 'PLeaf'。 汎用 subplots (cols が 1 でも要素数でもない wrap grid) +-- は @PV [PH ...]@ へ正規化する。 +-- [English]: An intermediate representation of the subplots tree. @<->@ is +-- 'PH', @<:>@ is 'PV', and a single plot is 'PLeaf'. A general subplots +-- layout (a wrap grid whose cols is neither 1 nor the element count) is +-- normalized to @PV [PH ...]@. data PTree = PLeaf VisualSpec - | PH [PTree] -- ^ 横並び (hconcat / @<->@) - | PV [PTree] -- ^ 縦並び (vconcat / @<:>@) + | PH [PTree] -- ^ [日本語]: 横並び (hconcat / @<->@)。 [English]: Side-by-side (hconcat / @<->@). + | PV [PTree] -- ^ [日本語]: 縦並び (vconcat / @<:>@)。 [English]: Stacked (vconcat / @<:>@). -- =========================================================================== -- VisualSpec → PTree -- =========================================================================== --- | subplots ネストを 'PTree' へ。 cols でグループ方向を判定: +-- | [日本語]: subplots ネストを 'PTree' へ。 cols でグループ方向を判定: -- @cols<=1@ → 縦・@cols>=n@ → 横・それ以外 → cols 列の wrap grid (=縦に並ぶ横行)。 --- 既定 cols は 'renderSubplots' と同じ @min n 3@ (parity 維持)。 +-- 既定 cols は @renderSubplots@ と同じ @min n 3@ (parity 維持)。 +-- [English]: Converts subplots nesting to a 'PTree'. cols determines the +-- grouping direction: @cols<=1@ means stacked; @cols>=n@ means +-- side-by-side; otherwise it is a wrap grid of cols columns (rows of +-- side-by-side panels, stacked). The default cols matches +-- @renderSubplots@, @min n 3@ (preserving parity). toPTree :: VisualSpec -> PTree toPTree s = case selectedSubplots s of @@ -80,7 +113,9 @@ else if cols >= n then PH kids else PV [ PH chunk | chunk <- chunksOf cols kids ] --- | リストを長さ n ずつに分割 (最後は端数)。 +-- | [日本語]: リストを長さ n ずつに分割 (最後は端数)。 +-- [English]: Splits a list into chunks of length n (the last chunk may be +-- shorter). chunksOf :: Int -> [a] -> [[a]] chunksOf n xs | n <= 0 = [xs] @@ -91,7 +126,8 @@ -- 寸法 (整数グリッド単位) と配置 -- =========================================================================== --- | サブツリーのグリッド寸法 @(cols, rows)@。 +-- | [日本語]: サブツリーのグリッド寸法 @(cols, rows)@。 +-- [English]: The grid dimensions of a subtree, @(cols, rows)@. gridDims :: PTree -> (Int, Int) gridDims (PLeaf _) = (1, 1) gridDims (PH ts) = ( sum (map (fst . gridDims) ts) @@ -99,26 +135,33 @@ gridDims (PV ts) = ( maximum (1 : map (fst . gridDims) ts) , sum (map (snd . gridDims) ts) ) --- | @placeT availRows availCols row0 col0 tree@: +-- | [日本語]: @placeT availRows availCols row0 col0 tree@: -- 左上 @(row0,col0)@ から @availRows × availCols@ の領域にツリーを配置し、 -- leaf パネルとその占有セルを返す。 leaf は与えられた領域いっぱいを span する。 +-- [English]: @placeT availRows availCols row0 col0 tree@: places the tree +-- in the @availRows × availCols@ region starting at the top-left +-- @(row0,col0)@, and returns the leaf panels with their occupied cells. +-- Each leaf spans the entire region given to it. 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。 列を順に消費。 + -- [日本語]: 各 child は自分の幅 × グループ高 (= ar 行) を span。 列を順に消費。 + -- [English]: Each child spans its own width × the group height (ar rows); columns are consumed in order. 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。 行を順に消費。 + -- [日本語]: 各 child はグループ幅 (= ac 列) × 自分の高さ を span。 行を順に消費。 + -- [English]: Each child spans the group width (ac columns) × its own height; rows are consumed in order. concat . snd $ mapAccumL (\rAcc t -> let h = snd (gridDims t) in (rAcc + h, placeT h ac rAcc c0 t)) r0 ts --- | VisualSpec の subplots ツリーを統一グリッドへ平坦化する。 +-- | [日本語]: VisualSpec の subplots ツリーを統一グリッドへ平坦化する。 +-- [English]: Flattens a VisualSpec's subplots tree into a unified grid. flattenSubplots :: VisualSpec -> GridPlacement flattenSubplots s = let t = toPTree s diff --git a/src/Graphics/Hgg/Layout/RangeOf.hs b/src/Graphics/Hgg/Layout/RangeOf.hs --- a/src/Graphics/Hgg/Layout/RangeOf.hs +++ b/src/Graphics/Hgg/Layout/RangeOf.hs @@ -1,25 +1,46 @@ -- | -- Module : Graphics.Hgg.Layout.RangeOf --- Description : Layer 2 ─ MarkKind 別 x/y axis range 寄与の計算 +-- Description : Layer 2 — computes each MarkKind's contribution to the x/y axis range -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- 各 chart 種類 (MarkKind) は y/x domain の決め方が異なる: +-- [日本語]: 各 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] +-- * scatter / line / errorbar / regression : encY = 値、 そのまま domain +-- * bar / waterfall : encY = 値、 domain は 0-base + max +-- * histogram / density : encY 無し、 domain は count / KDE peak +-- * box : encY = 値、 min-max (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 の寄与を集めるだけにする足場を提供する。 +-- これらを 1 箇所 ('Graphics.Hgg.Layout' の旧 paddedRange) で吸収しようとすると +-- chart 横断の副作用が出る。 本 module は MarkKind 別の range 寄与を分離し、 +-- @computeLayout@ は各 layer の寄与を集めるだけにする足場を提供する。 -- --- Phase 7 A2a: まず既存 'Graphics.Hgg.Layout' から range 計算を「挙動不変」 で --- 抽出 (= 出力 byte 一致)。 paddedRange 特例の除去は A2b で行う。 +-- 既存 'Graphics.Hgg.Layout' から range 計算を「挙動不変」 で抽出した +-- (= 出力 byte 一致)。 +-- [English]: Each chart type (MarkKind) determines its y/x domain +-- differently: +-- +-- * scatter / line / errorbar / regression: encY is the value, used as +-- the domain directly. +-- * bar / waterfall: encY is the value; the domain is 0-based plus max. +-- * histogram / density: no encY; the domain is the count or KDE peak. +-- * box: encY is the value; min-max, including outliers. +-- * violin / strip / swarm / raincloud / ridge: encY is the value; +-- min-max. +-- * autocorr: x = [0, maxLag], y = [-1, 1]. +-- * ess: x = [0, nChain], y = [0, N/nChain]. +-- +-- Trying to absorb all of this in a single place (the old paddedRange in +-- 'Graphics.Hgg.Layout') causes cross-chart side effects. This module +-- separates the range contribution per MarkKind, providing the scaffolding +-- for @computeLayout@ to simply collect each layer's contribution. +-- +-- The range computation was extracted from the existing +-- 'Graphics.Hgg.Layout' with behaviour unchanged (output is byte +-- identical). {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Layout.RangeOf ( collectXY @@ -36,7 +57,7 @@ import Graphics.Hgg.Spec (ColData (..), ColorEnc (..), Layer (..), MarkKind (..), Position (..), - Resolver, histBinning, lyBinCount, lyChain, lyColor, lyDensityNorm, + Resolver, histBinning, lyBinCount, lyColor, lyDensityNorm, lyEncX, lyEncY, lyEncY2, lyErrorX, lyHistDensity, lyKind, lyMaxLag, lyPosition, resolveCol, resolveNum, vsLayers, VisualSpec) @@ -50,12 +71,18 @@ -- 全 layer 横断の x/y range 収集 -- =========================================================================== --- | 全 layer の encX / encY を resolve して連結。 +-- | [日本語]: 全 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 する。 +-- MAutocorr / MEss は encX を「値ベクター」 として使うが、 x 軸の domain は +-- __lag__ (= 0..maxLag) なので、 encX を x として使うと壊れる。 該当 mark を +-- 持つ layer は x = [0, maxLag]、 y = [-1, 1] (autocorr) or y = ESS 範囲 +-- (= encX の長さ近辺) を contribute する。 +-- [English]: Resolves and concatenates encX / encY across all layers. +-- +-- MAutocorr / MEss use encX as a "value vector", but their x-axis domain +-- is __lag__ (0..maxLag), so using encX directly as x would break. Layers +-- with these marks instead contribute x = [0, maxLag] and y = [-1, 1] (for +-- autocorr) or y = the ESS range (roughly the length of encX). collectXY :: Resolver -> VisualSpec -> (Vector Double, Vector Double) collectXY r spec = let -- ★ Phase 36 D3: 合成 Layer (base + overlay) を range 計算用に展開し、 各 overlay の値列も @@ -124,14 +151,21 @@ -- MarkKind 別 y axis range 寄与 -- =========================================================================== --- | MHistogram layer か。 +-- | [日本語]: MHistogram layer か。 +-- [English]: Whether this is an 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 のはみ出しバグの原因)。 +-- | [日本語]: 全 histogram layer 共通の生 (pad なし) x domain (lo, hi)。 +-- render (renderHistogram) と y-range 計算 (sharedHistYRange) が __同じ__ +-- bin 境界を使うための単一情報源。 これがズレると bin 幅が変わり count が +-- 食い違って バーが y range を突き抜ける (かつてのはみ出しバグの原因)。 +-- [English]: The raw (unpadded), shared x domain (lo, hi) across all +-- histogram layers. The single source of truth that ensures render +-- (renderHistogram) and the y-range computation (sharedHistYRange) use +-- __the same__ bin boundaries. If they drift apart, bin widths differ and +-- counts mismatch, causing bars to overshoot the y range (the cause of a +-- past overshoot bug). histRawDomain :: Resolver -> [Layer] -> Maybe (Double, Double) histRawDomain r histLayers = let allXs = filter (not . isNaN) -- NA (NaN) を除く (nullable 列対応・有限には no-op) @@ -141,9 +175,15 @@ , 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]。 +-- | [日本語]: 全 histogram layer 共通 bin での maxCount を y range に。 +-- bin 境界は 'histRawDomain' (= 生 min/max) を単一情報源とし render と一致 +-- させる。 density mode は count/(N*binW) に正規化。 戻り値は +-- [0, 全層通じての maxY]。 +-- [English]: Puts the maxCount across a shared bin, for all histogram +-- layers, into the y range. Bin boundaries are kept consistent with +-- rendering by using 'histRawDomain' (raw min/max) as the single source of +-- truth. In density mode, values are normalised to count/(N*binW). Returns +-- [0, maxY across all layers]. sharedHistYRange :: Resolver -> [Layer] -> Vector Double sharedHistYRange r histLayers = case histRawDomain r histLayers of Nothing -> V.empty @@ -169,12 +209,21 @@ 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 を返す。 +-- | [日本語]: 全 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 を返す。 +-- [English]: The x-axis range of the shared bin across all histogram +-- layers (the bin's outer edges). Since the ggplot-style origin +-- (boundary = w/2) starts below the data's lower edge, and the last bin's +-- edge can exceed the data's upper edge, taking the x domain from the raw +-- data min/max would overflow the outer bars past the panel (pronounced +-- for large binwidths, and latent even for small ones). This computes +-- [origin, origin + nBin*binW] for each layer using the same +-- 'histBinning' (shared domain) as render (renderHistogram), and returns +-- the union. sharedHistXRange :: Resolver -> [Layer] -> Vector Double sharedHistXRange r histLayers = case histRawDomain r histLayers of Nothing -> V.empty @@ -187,9 +236,12 @@ _ -> 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 慣例) +-- | [日本語]: MHistogram / MDensity / MBar / MWaterfall の y 軸 range 候補。 +-- bar 系 chart の bar base は y=0、 だから y domain は [0, max(value)] に +-- する。 (= matplotlib / seaborn 慣例) +-- [English]: The y-axis range candidate for MHistogram / MDensity / MBar / +-- MWaterfall. Bar-family charts have a bar base of y=0, so the y domain is +-- [0, max(value)] (following matplotlib / seaborn convention). histogramYRange :: Resolver -> Layer -> Vector Double histogramYRange r l = case getFirst (lyKind l) of -- Bar / Waterfall: encY の max + 0 を contribute (= base = 0、 上方が data max) @@ -222,28 +274,20 @@ 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 も群ごとに髭を描くので両者整合。 + -- Box: encY = 値、 y domain = 全値 min-max (outlier 込み、 ggplot 流)。 + -- ★ Phase 65: 旧実装は群ごと Tukey whisker 範囲のみ (outlier 除外、 matplotlib 流) を + -- 返していたが、 Phase 34 で outlier ドット描画が追加されて以降は domain 外の実値に + -- 打点され panel 外に出ていた (probe: design/phase65-box-outlier-domain/、 + -- outlier PCircle y=-897 vs panel [24.2, 280.75])。 ggplot (と matplotlib の + -- flier 込み autoscale) に合わせ outlier も domain に含める。 whisker 端 (loV/hiV) + -- はフェンス内の実データ点なので min-max に包含され、 Phase 8 C の群ごと whisker + -- 和集合は不要になった。 NaN (= nullable 列の NA) は従来どおり除いてから min/max。 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) + Just v -> + let vals = V.filter (not . isNaN) v + in if V.null vals then V.empty + else V.fromList [V.minimum vals, V.maximum vals] _ -> V.empty Nothing -> V.empty -- Violin / Strip / Swarm / Raincloud / Ridge も同じく encY = 値 @@ -374,53 +418,46 @@ -- lag 軸 (autocorr / ess) の x/y range 寄与 -- =========================================================================== --- | autocorr / ess layer の x 軸 range 候補 (= [0, maxLag] or [0, nChain]) +-- | [日本語]: autocorr / ess layer の x 軸 range 候補 (= [0, maxLag])。 +-- [English]: The x-axis range candidate for autocorr / ess layers +-- ([0, maxLag]). lagXRange :: Resolver -> Layer -> Vector Double -lagXRange r l = case getFirst (lyKind l) of +lagXRange _ l = case getFirst (lyKind l) of Just MAutocorr -> + -- ★ Phase 64 A4-b: lag は連続値ではなく __離散スロット__。 各 lag が幅 1 の + -- スロットを持つよう ±0.5 を含む range を返す (categorical 軸と同じ規約)。 + -- [0, maxLag] のままだと lag 0 が panel 左端に来て棒が半分はみ出す + -- (A4-b の実測: 3.59 px 突出)。 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)] + in V.fromList [-0.5, fromIntegral maxLag + 0.5] + -- ★ Phase 70 A3: MEss の x range 供給を撤去。 現行設計 (ess nameCol essCol) の + -- x 軸は encX の categorical 経路 (xCatLabels → [-0.6, n-0.4]) が担う。 + -- 旧設計 (ess vals <> chain) 前提の [-0.5, nChain-0.5] は renderESS の + -- CrossAt 0..n-1 (n = 名前数) と乖離し bar が panel 外に出ていた (A2 実測)。 _ -> 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 候補 +-- | [日本語]: autocorr / ess layer の y 軸 range 候補。 +-- [English]: The y-axis range candidate for autocorr / ess layers. 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] + -- ★ Phase 70 A3: y range は encY の __実 ESS 値__ から [0, max(100, 最大値)]。 + -- 下限 100 は renderESS の閾値参照線 (100/400) の最小値が常に見えるための床で、 + -- renderer 側の tick 計算 yMax = maximum (100 : vals) (Render/MCMC.hs) と同一式。 + -- 旧実装は encX の「長さ」を MCMC サンプル数 N と誤用し ESS 実値を不参照だった + -- (demo で [0,6]・Text nameCol では n=1000 fallback、 A2 実測)。 + let vals = case getLast (lyEncY l) of + Just cr -> maybe [] V.toList (resolveNum r cr) + Nothing -> [] + in V.fromList [0, maximum (100 : vals)] _ -> 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)。 +-- | [日本語]: Forest layer の x range 寄与 (= estimate ± error + 中央 null +-- line x=0)。 これを range に含めないと CI 線が plotArea からはみ出す。 +-- [English]: The x-range contribution of a Forest layer (estimate ± error +-- plus the central null line x=0). Omitting it would let the CI lines +-- overflow the plot area. forestXRange :: Resolver -> Layer -> Vector Double forestXRange r l = case getFirst (lyKind l) of Just MForest -> @@ -434,8 +471,12 @@ 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 からはみ出す。 +-- | [日本語]: linerange / pointrange / crossbar の y 軸 range 寄与 = y ± errorY +-- (= forest の x ± err と同型)。 これが無いと区間 (y±err) が plotArea から +-- はみ出す。 +-- [English]: The y-range contribution of linerange / pointrange / +-- crossbar: y ± errorY (structurally identical to forest's x ± err). +-- Without it, the interval (y±err) would overflow the plot area. rangeBarYRange :: Resolver -> Layer -> Vector Double rangeBarYRange r l = case getFirst (lyKind l) of Just k | k `elem` [MLineRange, MPointRange, MCrossbar] -> @@ -448,10 +489,15 @@ 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 帯で露見)。 +-- | [日本語]: MBand (area band) の y 軸 range 寄与 = 上境界 encY2。 下境界 encY +-- は collectXY の ysFromEncY が既に拾う。 上境界 encY2 はどこも拾わないため、 +-- これが無いと帯の上側が plotArea からはみ出してクリップされる (GLM の +-- 非対称 μ-CI 帯で露見)。 +-- [English]: The y-range contribution of MBand (an area band): the upper +-- bound, encY2. The lower bound, encY, is already picked up by +-- collectXY's ysFromEncY. Since nothing else picks up encY2, omitting +-- this would clip the upper side of the band at the plot area (surfaced +-- by GLM's asymmetric μ-CI bands). bandYRange :: Resolver -> Layer -> Vector Double bandYRange r l = case getFirst (lyKind l) of Just MBand -> @@ -460,9 +506,15 @@ 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 ごとの総和だけが要る。 +-- | [日本語]: streamgraph の y 軸 range 寄与。 各 x 値ごとに全系列の y を合算した +-- 総和 total(x) の最大 M を取り、 中心化 (silhouette: baseline=-Σy/2) ゆえ +-- [-M/2, M/2] を返す。 系列は color で分かれるが range には x ごとの総和 +-- だけが要る。 +-- [English]: The y-range contribution of a streamgraph. Takes the maximum +-- M of the per-x total(x), the sum of y across all series at each x +-- value, and returns [-M/2, M/2] since the layout is centered (silhouette: +-- baseline = -Σy/2). Series are split by color, but the range only needs +-- the per-x total. streamYRange :: Resolver -> Layer -> Vector Double streamYRange r l = case getFirst (lyKind l) of Just MStream -> @@ -475,9 +527,15 @@ 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 と同型で算出)。 +-- | [日本語]: Q-Q plot の x 軸 range 寄与。 sample (encY) をソートして得る +-- order statistic に理論正規分位点 Φ⁻¹((i-0.5)/n) を割り当て、 その min/max +-- を x domain に contribute する (= 理論分位点は列に無いので forestXRange と +-- 同型で算出)。 +-- [English]: The x-range contribution of a Q-Q plot. Assigns theoretical +-- normal quantiles Φ⁻¹((i-0.5)/n) to the order statistics obtained by +-- sorting the sample (encY), and contributes their min/max to the x +-- domain (theoretical quantiles are not in any column, so they are +-- computed the same way as forestXRange). qqXRange :: Resolver -> Layer -> Vector Double qqXRange r l = case getFirst (lyKind l) of Just MQQ -> case getLast (lyEncY l) >>= resolveNum r of @@ -487,10 +545,17 @@ _ -> 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 近傍))。 +-- | [日本語]: サンプルから 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 近傍))。 +-- [English]: Builds the Q-Q plot point list (theoretical quantile, order +-- statistic) from a sample. A single source of truth ensuring render and +-- range use __the same formula__ (the same idea as histRawDomain). +-- y_(i) is the i-th sorted sample value; x_i = Φ⁻¹((i-0.5)/n) is the +-- plotting position, the default used by ggplot's stat_qq / R's qqnorm +-- (a near Blom's a=0.5). qqPoints :: [Double] -> [(Double, Double)] qqPoints sample = let ys = sort sample @@ -498,9 +563,15 @@ 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)。 空入力は []。 +-- | [日本語]: 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)。 +-- 空入力は []。 +-- [English]: The vertices of the ECDF (ggplot's stat_ecdf) step polyline. +-- A single source of truth ensuring render and the x/y range use the same +-- formula. Represents the right-continuous step function F(x)=#(≤x)/n as +-- a sequence of corner points: (x_1,0), (x_1,1/n), (x_2,1/n), (x_2,2/n), +-- …, (x_n, n/n). An empty input yields []. ecdfPoints :: [Double] -> [(Double, Double)] ecdfPoints sample = let xs = sort sample @@ -514,9 +585,14 @@ : [ (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 には到達しない)。 +-- | [日本語]: 標準正規分布の逆累積分布関数 Φ⁻¹ (= probit / qnorm)。 Acklam の +-- 有理多項式近似 (相対誤差 < 1.15e-9)。 p ∈ (0,1) を仮定 (端点は ±∞ を返す +-- が qqPoints では (0.5/n)〜((n-0.5)/n) なので 0/1 には到達しない)。 +-- [English]: The inverse CDF of the standard normal distribution, Φ⁻¹ +-- (probit / qnorm). Uses Acklam's rational polynomial approximation +-- (relative error < 1.15e-9). Assumes p ∈ (0,1) (the endpoints return ±∞, +-- but qqPoints only supplies (0.5/n) through ((n-0.5)/n), so 0/1 are never +-- reached). invNormCdf :: Double -> Double invNormCdf p | p <= 0 = -1 / 0 @@ -549,7 +625,10 @@ d1 = 7.784695709041462e-03; d2 = 3.224671290700398e-01 d3 = 2.445134137142996e+00; d4 = 3.754408661907416e+00 --- | autocorr / ess は encX を「値」 としてではなく lag/chain 軸として扱う layer。 +-- | [日本語]: autocorr / ess は encX を「値」 としてではなく lag/chain 軸と +-- して扱う layer。 +-- [English]: Whether this layer treats encX as a lag/chain axis rather +-- than a "value" (as autocorr / ess do). isLagAxis :: Layer -> Bool isLagAxis l = case getFirst (lyKind l) of Just MAutocorr -> True @@ -560,39 +639,13 @@ -- 共通 helper -- =========================================================================== --- | Vector の (min, max)。 空なら default (0, 1)。 +-- | [日本語]: Vector の (min, max)。 空なら default (0, 1)。 +-- [English]: A vector's (min, max), defaulting to (0, 1) when empty. 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) +-- ★ Phase 65: 旧 groupValsBy / tukeyWhisker (Phase 8 C の群ごと whisker domain 用) は +-- MBox domain の outlier 込み化で不要になり削除 (whisker 描画側の同一式は +-- Render/Distribution.hs renderBox にインラインで残っている)。 diff --git a/src/Graphics/Hgg/Math/Griddata.hs b/src/Graphics/Hgg/Math/Griddata.hs --- a/src/Graphics/Hgg/Math/Griddata.hs +++ b/src/Graphics/Hgg/Math/Griddata.hs @@ -1,23 +1,47 @@ -- | -- Module : Graphics.Hgg.Math.Griddata --- Description : 散布 (x,y,z) → 格子化 (Phase 24 A4・contour/surface 共用基盤) +-- Description : Scattered (x,y,z) to grid — shared foundation for contour and surface -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- contour / filled contour / 3D surface が共有する「散布データの格子化」 核。 +-- [日本語]: 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 保全)。 +-- * 'detectGrid' — 入力が__規則 grid__ (x の固有値 × y の固有値が全組存在) +-- なら補間せず__そのまま__格子に並べ替える (旧実装は規則 grid 入力でも +-- 全点 IDW 再標本化して歪んでいたバグの修正の本丸) +-- * 'resampleKNN' — 真の散布入力のみ __k 近傍 IDW__ (逆距離加重・power 2) +-- で格子に補間する (旧実装の全点 IDW は遠方点まで重み付けされ +-- 全体平均へ潰れる + 隅に偽値が出る) +-- * 'gridOf' — 上記 2 つの自動切替 (検出成功 = 直入力、 失敗 = k 近傍補間) +-- * 'marchingSegments' / 'innerLevels' — 等高線 (isoline) 抽出核。 marching +-- squares で 1 level 分の線分群を data 座標で返す。 2D @renderContour@ と +-- 3D 床面投影 contour が__同一核を共有__する (parity 保全)。 -- --- 格子の向き規約: @zGrid !! j !! i = z(xNodes !! i, yNodes !! j)@ (行 = y)。 +-- 格子の向き規約: @zGrid !! j !! i = z(xNodes !! i, yNodes !! j)@ (行 = y)。 +-- [English]: The "grid scattered data" core shared by contour, filled +-- contour, and 3D surface. +-- +-- * 'detectGrid' — If the input is a __regular grid__ (every combination +-- of the distinct x and y values is present), rearranges it into a +-- grid __directly__, without interpolation (this is the core of a bug +-- fix: the previous implementation resampled with full-point IDW even +-- for regular-grid input, distorting it). +-- * 'resampleKNN' — For genuinely scattered input only, interpolates +-- onto a grid using __k-nearest-neighbour IDW__ (inverse distance +-- weighting, power 2). (The previous full-point IDW weighted even +-- distant points, collapsing toward the overall mean and producing +-- spurious values at the corners.) +-- * 'gridOf' — Automatically switches between the two above (successful +-- detection uses the direct input; failure falls back to +-- k-nearest-neighbour interpolation). +-- * 'marchingSegments' / 'innerLevels' — The isoline-extraction core. +-- Returns the line segments for a single level, in data coordinates, +-- using marching squares. 2D @renderContour@ and the 3D floor-projected +-- contour __share this same core__ (preserving parity between them). +-- +-- Grid orientation convention: @zGrid !! j !! i = z(xNodes !! i, yNodes !! j)@ +-- (rows = y). {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Math.Griddata ( detectGrid @@ -31,10 +55,17 @@ import qualified Data.Map.Strict as Map import qualified Data.Vector as V --- | 規則 grid の検出: x / y の固有値数の積が点数と一致し、 かつ全セルが --- 埋まっていれば @Just (xNodes, yNodes, zGrid)@。 固有値は完全一致 (==) で --- 集計する (計画格子・linspace 由来の座標は bit 一致する前提。 ノイズ入り --- 座標は検出に落ちて 'resampleKNN' へ)。 重複座標 (反復測定) は後勝ち。 +-- | [日本語]: 規則 grid の検出: x / y の固有値数の積が点数と一致し、 かつ全セルが +-- 埋まっていれば @Just (xNodes, yNodes, zGrid)@。 固有値は完全一致 (==) で +-- 集計する (計画格子・linspace 由来の座標は bit 一致する前提。 ノイズ入り +-- 座標は検出に落ちて 'resampleKNN' へ)。 重複座標 (反復測定) は後勝ち。 +-- [English]: Detects a regular grid: if the product of the counts of +-- distinct x / y values equals the point count and every cell is filled, +-- returns @Just (xNodes, yNodes, zGrid)@. Distinct values are gathered by +-- exact equality (==), assuming coordinates from a planned grid or +-- linspace match bit-for-bit; noisy coordinates fail detection and fall +-- through to 'resampleKNN'. Duplicate coordinates (repeated measurements) +-- have the later one win. detectGrid :: [(Double, Double, Double)] -> Maybe ([Double], [Double], [[Double]]) detectGrid pts = let xs = uniqSorted [x | (x, _, _) <- pts] @@ -59,12 +90,16 @@ | otherwise = a : dedup (b : rest) dedup xs = xs --- | k 近傍 IDW (逆距離加重・power 2) で nx×ny 格子に補間する。 --- 旧実装 (全点 IDW) との違い = 各ノードで**最も近い k 点だけ**を重み付け --- するため、 遠方の点に引っ張られて全体平均へ潰れない。 -resampleKNN :: Int -- ^ 近傍数 k (目安 8) - -> Int -- ^ x 方向ノード数 - -> Int -- ^ y 方向ノード数 +-- | [日本語]: k 近傍 IDW (逆距離加重・power 2) で nx×ny 格子に補間する。 +-- 旧実装 (全点 IDW) との違い = 各ノードで__最も近い k 点だけを重み付け__する +-- ため、 遠方の点に引っ張られて全体平均へ潰れない。 +-- [English]: Interpolates onto an nx×ny grid using k-nearest-neighbour IDW +-- (inverse distance weighting, power 2). Unlike the previous implementation +-- (full-point IDW), each node here __weights only its k nearest points__, +-- so it is not pulled toward the overall mean by distant points. +resampleKNN :: Int -- ^ [日本語]: 近傍数 k (目安 8)。 [English]: The neighbour count k (typically 8). + -> Int -- ^ [日本語]: x 方向ノード数。 [English]: The number of nodes in the x direction. + -> Int -- ^ [日本語]: y 方向ノード数。 [English]: The number of nodes in the y direction. -> [(Double, Double, Double)] -> ([Double], [Double], [[Double]]) resampleKNN k nx ny pts = @@ -84,24 +119,35 @@ grid = [ [ idw px py | px <- xNodes ] | py <- yNodes ] in (xNodes, yNodes, grid) --- | 自動切替: 規則 grid なら直入力 (補間なし)、 散布なら k=8 近傍 IDW で --- n×n 格子化。 contour / filled contour / 床面投影が共有する入口。 -gridOf :: Int -- ^ 散布時の再標本ノード数 (各軸) +-- | [日本語]: 自動切替: 規則 grid なら直入力 (補間なし)、 散布なら k=8 近傍 IDW +-- で n×n 格子化。 contour / filled contour / 床面投影が共有する入口。 +-- [English]: Automatically switches: a regular grid is used directly (no +-- interpolation); scattered data is gridded to n×n via k=8 +-- nearest-neighbour IDW. The shared entry point for contour, filled +-- contour, and floor projections. +gridOf :: Int -- ^ [日本語]: 散布時の再標本ノード数 (各軸)。 [English]: The resampling node count per axis, used when the input is scattered. -> [(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)。 +-- | [日本語]: 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 が共有する核。 +-- [English]: Marching squares: the isoline segments (in data coordinates) +-- for a single @level@. Grid orientation is +-- @grid !! j !! i = z(xNodes !! i, yNodes !! j)@ (rows = y). The cell scan +-- order is @i (outer), j (inner)@, and the per-cell case dispatch matches +-- the previous inline implementation in 2D @renderContour@ exactly (SVG +-- output is bit-identical). The shared core for 2D contour and the 3D +-- floor-projected contour. marchingSegments - :: [Double] -- ^ xNodes (x 方向ノード) - -> [Double] -- ^ yNodes (y 方向ノード) - -> [[Double]] -- ^ grid (行 = y、 @grid!!j!!i@) + :: [Double] -- ^ [日本語]: xNodes (x 方向ノード)。 [English]: xNodes (nodes in the x direction). + -> [Double] -- ^ [日本語]: yNodes (y 方向ノード)。 [English]: yNodes (nodes in the y direction). + -> [[Double]] -- ^ [日本語]: grid (行 = y、 @grid!!j!!i@)。 [English]: The grid (rows = y, @grid!!j!!i@). -> Double -- ^ level -> [((Double, Double), (Double, Double))] marchingSegments xNodes yNodes grid lv = @@ -137,9 +183,13 @@ _ -> [] 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)。 +-- | [日本語]: 既定の等高線レベル: @(zmin, zmax)@ の__内側等間隔__ @lv_k = zmin + +-- (zmax-zmin)·k/(n+1)@ (k = 1..n)。 端値ちょうどの退化等値線を避ける。 +-- 2D @contourLevelsFor@ の既定枝と 3D 床面投影が共有。 +-- [English]: The default contour levels: __evenly spaced interior points__ +-- of @(zmin, zmax)@, @lv_k = zmin + (zmax-zmin)·k/(n+1)@ (k = 1..n). This +-- avoids degenerate isolines exactly at the endpoints. Shared by the +-- default branch of 2D @contourLevelsFor@ and the 3D floor projection. innerLevels :: Int -> Double -> Double -> [Double] innerLevels nLev zmin zmax = [ zmin + (zmax - zmin) * fromIntegral k / fromIntegral (nLev + 1) diff --git a/src/Graphics/Hgg/Math/Special.hs b/src/Graphics/Hgg/Math/Special.hs --- a/src/Graphics/Hgg/Math/Special.hs +++ b/src/Graphics/Hgg/Math/Special.hs @@ -1,19 +1,33 @@ -- | -- Module : Graphics.Hgg.Math.Special --- Description : 特殊関数 (log-gamma / 正則化不完全ベータ / ベータ分位点) +-- Description : Special functions — log-gamma, regularized incomplete beta, beta quantile -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- backend 非依存の数値特殊関数。 確率プロットの厳密 rank-based CI --- (順序統計量 U_(i) ~ Beta(i, n-i+1)) などで必要になる: +-- [日本語]: 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 (二分法による逆関数) +-- * '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 に分離する。 +-- アルゴリズムは Numerical Recipes の @gammln@ / @betai@ / @betacf@ に準ずる。 +-- core 内に他の特殊関数 (invNormCdf) は 'Graphics.Hgg.Layout.RangeOf' にあるが、 +-- ベータ系はサイズが大きいので本 module に分離する。 +-- [English]: Backend-agnostic numerical special functions, needed for +-- example by the exact rank-based confidence intervals of probability +-- plots (order statistics U_(i) ~ Beta(i, n-i+1)): +-- +-- * 'logGamma' : ln Γ(x) (Lanczos approximation, x > 0) +-- * 'regIncompleteBeta' : the regularized incomplete beta function +-- I_x(a,b) (continued fraction / Lentz's method) +-- * 'betaQuantile' : the x satisfying I_x(a,b) = q (inverse via +-- bisection) +-- +-- The algorithms follow Numerical Recipes' @gammln@ / @betai@ / @betacf@. +-- Another special function (invNormCdf) lives in 'Graphics.Hgg.Layout.RangeOf' +-- elsewhere in core, but the beta-related functions are split into this +-- module because of their size. module Graphics.Hgg.Math.Special ( logGamma , regIncompleteBeta @@ -24,8 +38,10 @@ -- log-gamma (Lanczos 近似、 g=5 / 6 係数) -- =========================================================================== --- | ln Γ(x) (x > 0 を仮定)。 相対誤差 < 2e-10。 --- Numerical Recipes @gammln@ と同一係数 (Lanczos, g=5)。 +-- | [日本語]: ln Γ(x) (x > 0 を仮定)。 相対誤差 < 2e-10。 +-- Numerical Recipes @gammln@ と同一係数 (Lanczos, g=5)。 +-- [English]: ln Γ(x), assuming x > 0. Relative error < 2e-10. Uses the +-- same coefficients as Numerical Recipes' @gammln@ (Lanczos, g=5). logGamma :: Double -> Double logGamma x = let tmp0 = x + 5.5 @@ -42,9 +58,14 @@ -- 正則化不完全ベータ 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) を使い収束を確保する。 +-- | [日本語]: 正則化不完全ベータ関数 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) を使い収束を確保する。 +-- [English]: The regularized incomplete beta function +-- I_x(a,b) = B(x;a,b) / B(a,b) ∈ [0,1], for a,b > 0 and x ∈ [0,1]. When +-- x < (a+1)/(a+b+2) the continued fraction is evaluated directly; +-- otherwise the symmetry I_x(a,b) = 1 - I_{1-x}(b,a) is used to ensure +-- convergence. regIncompleteBeta :: Double -> Double -> Double -> Double regIncompleteBeta a b x | x <= 0 = 0 @@ -56,7 +77,9 @@ then bt * betacf a b x / a else 1 - bt * betacf b a (1 - x) / b --- | I_x(a,b) の連分数展開 (Lentz の修正法)。 NR @betacf@ と同型。 +-- | [日本語]: I_x(a,b) の連分数展開 (Lentz の修正法)。 NR @betacf@ と同型。 +-- [English]: The continued-fraction expansion of I_x(a,b) (Lentz's +-- modified method). Structurally identical to Numerical Recipes' @betacf@. betacf :: Double -> Double -> Double -> Double betacf a b x = go 1 h0 c0 d0 where @@ -93,9 +116,14 @@ -- ベータ分位点 (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 精度では完全収束。 +-- | [日本語]: I_x(a,b) = q を満たす x ∈ [0,1] を二分法で求める (= Beta(a,b) の +-- q 分位点)。 'regIncompleteBeta' は x について単調増加なので二分法が確実に +-- 収束する。 80 反復で区間幅は 2^-80 (≈ 1e-24) になり double 精度では完全収束。 +-- [English]: Finds the x ∈ [0,1] satisfying I_x(a,b) = q by bisection (the +-- q-quantile of Beta(a,b)). Since 'regIncompleteBeta' is monotonically +-- increasing in x, bisection is guaranteed to converge. After 80 +-- iterations the interval width is 2^-80 (≈ 1e-24), which is full +-- convergence at double precision. betaQuantile :: Double -> Double -> Double -> Double betaQuantile q a b | q <= 0 = 0 diff --git a/src/Graphics/Hgg/Palette.hs b/src/Graphics/Hgg/Palette.hs --- a/src/Graphics/Hgg/Palette.hs +++ b/src/Graphics/Hgg/Palette.hs @@ -1,13 +1,20 @@ -- | -- Module : Graphics.Hgg.Palette --- Description : Categorical / Sequential / Diverging palette カタログ +-- Description : Categorical, sequential, and diverging palette catalog -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- P17 (2026-05-26 改訂): +-- [日本語]: 2026-05-26 改訂: -- * default `hggMain` = F-3 Balanced Mix (= 中程度彩度で重み均等) -- * sub `hggPastel` = F-2 Pastel Mix (= 淡色 secondary) -- * 全色は 7 キャラ設定画 Color Palette セクションの公式 hex +-- [English]: As of the 2026-05-26 revision: +-- * The default, `hggMain`, is F-3 Balanced Mix (medium saturation, +-- evenly weighted). +-- * The sub-palette, `hggPastel`, is F-2 Pastel Mix (light-colored +-- secondary). +-- * All colors are the official hex values from the Color Palette +-- section of the 7-character design sheet. {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Palette @@ -51,7 +58,7 @@ , hggHighlight , hggSuccess , hggInfo - -- * ColorBrewer 2.0 palette (Phase 6 A9、 P17) + -- * ColorBrewer 2.0 palette -- $colorbrewer -- ** Categorical (qualitative) , brewerSet1 @@ -83,7 +90,9 @@ viridis5 :: SequentialPalette viridis5 = ["#440154", "#3B528B", "#21918C", "#5EC962", "#FDE725"] --- | Spotfire 風 (= 標準 UI default colorPalette と一致)。 +-- | [日本語]: Spotfire 風 (= 標準 UI default colorPalette と一致)。 +-- [English]: Spotfire-style (matches the standard UI's default +-- colorPalette). spotfire :: CategoricalPalette spotfire = [ "#93c5fd", "#fca5a5", "#fde047", "#86efac", "#f9a8d4" @@ -110,10 +119,17 @@ [ "#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 色版。 +-- | [日本語]: 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 色版。 +-- [English]: ggplot2's default discrete palette (@scales::hue_pal()@). +-- Evenly spaced hues in HCL space (L=65, C=100, hue = +-- seq(15,375,length=n+1)[1:n]). Since the hues are redistributed depending +-- on the color count n, the output of R's @hue_pal()(n)@ is tabulated for +-- n=1..8 (avoiding an HCL to sRGB conversion at run time). For n>8 the +-- 8-color table is cycled; n<1 also uses the 8-color table. ggplotHue :: Int -> CategoricalPalette ggplotHue n | n <= 0 = ggplotHue8 @@ -208,86 +224,110 @@ -- =========================================================================== -- $colorbrewer --- ColorBrewer は地図・科学可視化向け 35 palette のセット。 +-- [日本語]: ColorBrewer は地図・科学可視化向け 35 palette のセット。 -- ここでは categorical 5 種 + diverging 7 種を import (= 9-class が中心)。 -- 公式: -- License: Apache 2.0 (= attribution required) +-- +-- [English]: ColorBrewer is a set of 35 palettes designed for maps and +-- scientific visualization. Here 5 categorical and 7 diverging palettes are +-- imported (mostly the 9-class variants). Official site: +-- . License: Apache 2.0 (attribution required). --- | Categorical Set1 (9-class)。 強い primary 色、 区別性高い。 +-- | [日本語]: Categorical Set1 (9-class)。 強い primary 色、 区別性高い。 +-- [English]: Categorical Set1 (9-class): strong primary colors with high +-- distinguishability. brewerSet1 :: CategoricalPalette brewerSet1 = [ "#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00" , "#FFFF33", "#A65628", "#F781BF", "#999999" ] --- | Categorical Set2 (8-class)。 やや pastel、 印刷に向く。 +-- | [日本語]: Categorical Set2 (8-class)。 やや pastel、 印刷に向く。 +-- [English]: Categorical Set2 (8-class): somewhat pastel, suited to print. brewerSet2 :: CategoricalPalette brewerSet2 = [ "#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3", "#A6D854" , "#FFD92F", "#E5C494", "#B3B3B3" ] --- | Categorical Set3 (12-class)。 多 categorical に向く、 薄め。 +-- | [日本語]: Categorical Set3 (12-class)。 多 categorical に向く、 薄め。 +-- [English]: Categorical Set3 (12-class): suited to many categories, +-- lighter tones. brewerSet3 :: CategoricalPalette brewerSet3 = [ "#8DD3C7", "#FFFFB3", "#BEBADA", "#FB8072", "#80B1D3" , "#FDB462", "#B3DE69", "#FCCDE5", "#D9D9D9", "#BC80BD" , "#CCEBC5", "#FFED6F" ] --- | Paired (12-class)。 light/dark のペア (= 2 グループ × 6 色)。 +-- | [日本語]: Paired (12-class)。 light/dark のペア (= 2 グループ × 6 色)。 +-- [English]: Paired (12-class): light/dark pairs (2 groups of 6 colors +-- each). brewerPaired :: CategoricalPalette brewerPaired = [ "#A6CEE3", "#1F78B4", "#B2DF8A", "#33A02C", "#FB9A99" , "#E31A1C", "#FDBF6F", "#FF7F00", "#CAB2D6", "#6A3D9A" , "#FFFF99", "#B15928" ] --- | Dark2 (8-class)。 dark 系、 強い contrast。 +-- | [日本語]: Dark2 (8-class)。 dark 系、 強い contrast。 +-- [English]: Dark2 (8-class): dark tones with strong contrast. brewerDark2 :: CategoricalPalette brewerDark2 = [ "#1B9E77", "#D95F02", "#7570B3", "#E7298A", "#66A61E" , "#E6AB02", "#A6761D", "#666666" ] --- | Diverging RdYlBu (9-class、 中心 #FFFFBF)。 赤 ↔ 黄 ↔ 青。 +-- | [日本語]: Diverging RdYlBu (9-class、 中心 #FFFFBF)。 赤 ↔ 黄 ↔ 青。 +-- [English]: Diverging RdYlBu (9-class, center #FFFFBF): red to yellow to +-- blue. brewerRdYlBu :: DivergingPalette brewerRdYlBu = [ "#D73027", "#F46D43", "#FDAE61", "#FEE090" , "#FFFFBF" , "#E0F3F8", "#ABD9E9", "#74ADD1", "#4575B4" ] --- | Diverging RdBu (9-class)。 赤 ↔ 青、 中央 #F7F7F7。 +-- | [日本語]: Diverging RdBu (9-class)。 赤 ↔ 青、 中央 #F7F7F7。 +-- [English]: Diverging RdBu (9-class): red to blue, center #F7F7F7. brewerRdBu :: DivergingPalette brewerRdBu = [ "#B2182B", "#D6604D", "#F4A582", "#FDDBC7" , "#F7F7F7" , "#D1E5F0", "#92C5DE", "#4393C3", "#2166AC" ] --- | Diverging Spectral (11-class)。 虹 (= 赤→橙→黄→緑→青→紫)、 中心 #FFFFBF。 +-- | [日本語]: Diverging Spectral (11-class)。 虹 (= 赤→橙→黄→緑→青→紫)、 中心 +-- #FFFFBF。 +-- [English]: Diverging Spectral (11-class): a rainbow (red to orange to +-- yellow to green to blue to purple), center #FFFFBF. brewerSpectral :: DivergingPalette brewerSpectral = [ "#9E0142", "#D53E4F", "#F46D43", "#FDAE61", "#FEE08B" , "#FFFFBF" , "#E6F598", "#ABDDA4", "#66C2A5", "#3288BD", "#5E4FA2" ] --- | Diverging PuOr (9-class)。 紫 ↔ 橙、 中央 #F7F7F7。 +-- | [日本語]: Diverging PuOr (9-class)。 紫 ↔ 橙、 中央 #F7F7F7。 +-- [English]: Diverging PuOr (9-class): purple to orange, center #F7F7F7. brewerPuOr :: DivergingPalette brewerPuOr = [ "#B35806", "#E08214", "#FDB863", "#FEE0B6" , "#F7F7F7" , "#D8DAEB", "#B2ABD2", "#8073AC", "#542788" ] --- | Diverging BrBG (9-class)。 茶 ↔ 緑、 中央 #F5F5F5。 +-- | [日本語]: Diverging BrBG (9-class)。 茶 ↔ 緑、 中央 #F5F5F5。 +-- [English]: Diverging BrBG (9-class): brown to green, center #F5F5F5. brewerBrBG :: DivergingPalette brewerBrBG = [ "#8C510A", "#BF812D", "#DFC27D", "#F6E8C3" , "#F5F5F5" , "#C7EAE5", "#80CDC1", "#35978F", "#01665E" ] --- | Diverging RdGy (9-class)。 赤 ↔ 灰、 中央 #FFFFFF。 +-- | [日本語]: Diverging RdGy (9-class)。 赤 ↔ 灰、 中央 #FFFFFF。 +-- [English]: Diverging RdGy (9-class): red to gray, center #FFFFFF. brewerRdGy :: DivergingPalette brewerRdGy = [ "#B2182B", "#D6604D", "#F4A582", "#FDDBC7" , "#FFFFFF" , "#E0E0E0", "#BABABA", "#878787", "#4D4D4D" ] --- | Diverging PiYG (9-class)。 ピンク ↔ 黄緑、 中央 #F7F7F7。 +-- | [日本語]: Diverging PiYG (9-class)。 ピンク ↔ 黄緑、 中央 #F7F7F7。 +-- [English]: Diverging PiYG (9-class): pink to yellow-green, center +-- #F7F7F7. brewerPiYG :: DivergingPalette brewerPiYG = [ "#C51B7D", "#DE77AE", "#F1B6DA", "#FDE0EF" diff --git a/src/Graphics/Hgg/Primitive.hs b/src/Graphics/Hgg/Primitive.hs --- a/src/Graphics/Hgg/Primitive.hs +++ b/src/Graphics/Hgg/Primitive.hs @@ -1,17 +1,27 @@ -- | -- Module : Graphics.Hgg.Primitive --- Description : backend 非依存の描画 primitive・幾何・スタイルの基盤型 (leaf) +-- Description : Backend-agnostic drawing primitives, geometry, and style leaf types -- 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 経路は不変。 +-- [日本語]: 描画 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 経路は不変。 +-- [English]: Consolidates the drawing primitives (Point/Rect/style/PathSegment/ +-- Transform/Primitive) into a __leaf module__ with no dependency on Spec/Layout/ +-- Render. These originally lived in 'Graphics.Hgg.Render.Common' (an upper layer +-- that imports Spec/Layout), which made it impossible to extend 'Spec.Layer' to +-- hold a draw closure (@RenderCtx -> [Primitive]@) for custom marks, due to a +-- __module cycle__. Since primitives conceptually depend only on geometry and +-- Text, they belong in the correct (lowest, leaf) layer. Behaviour and output +-- are completely unchanged (a pure type relocation). 'Graphics.Hgg.Render.Common' +-- and 'Graphics.Hgg.Render' re-export this module, so existing import paths are +-- unaffected. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Primitive @@ -43,7 +53,9 @@ data Point = Point !Double !Double deriving (Show, Eq) --- | plot 領域や clip 矩形。 (x,y) 左上 + 幅高 (pt 空間)。 +-- | [日本語]: plot 領域や clip 矩形。 (x,y) 左上 + 幅高 (pt 空間)。 +-- [English]: A plot area or clip rectangle: (x,y) top-left plus width and +-- height, in pt space. data Rect = Rect { rX :: !Double, rY :: !Double, rW :: !Double, rH :: !Double } deriving (Show, Eq, Generic) @@ -54,12 +66,18 @@ -- スタイル -- =========================================================================== --- | 線スタイル。 'lsDash' = SVG stroke-dasharray / Canvas setLineDash 用 px 配列。 --- 既定 (= 実線) は空配列 []。 'solid' ヘルパで作ると常に実線 (Phase 11 A4-b 以前と同一)。 +-- | [日本語]: 線スタイル。 'lsDash' = SVG stroke-dasharray / Canvas setLineDash 用 px 配列。 +-- 既定 (= 実線) は空配列 []。 'solid' ヘルパで作ると常に実線。 +-- [English]: A line style. 'lsDash' is the px array used by SVG +-- stroke-dasharray / Canvas setLineDash. The default (solid) is the empty +-- array []. Building it via the 'solid' helper always yields a solid line. data LineStyle = LineStyle { lsColor :: !Text, lsWidth :: !Double, lsDash :: ![Double] } deriving (Show, Eq) --- | Phase 11 A4-b: 実線 'LineStyle' の簡易構築 (= 旧 2 引数 LineStyle と同一)。 --- dash を持たない既存呼出は全てこれに置換 (出力完全不変)。 +-- | [日本語]: 実線 'LineStyle' の簡易構築 (= 旧 2 引数 LineStyle と同一)。 +-- dash を持たない既存呼出は全てこれに置換 (出力完全不変)。 +-- [English]: A convenience constructor for a solid 'LineStyle' (equivalent +-- to the old 2-argument LineStyle). All existing call sites without a dash +-- are replaced by this (output is completely unchanged). solid :: Text -> Double -> LineStyle solid c w = LineStyle c w [] @@ -93,27 +111,53 @@ -- Primitive -- =========================================================================== --- | backend 非依存の描画 primitive。 各 backend は drawPrimitives で --- これを順に解釈するだけ。 +-- | [日本語]: backend 非依存の描画 primitive。 各 backend は drawPrimitives で +-- これを順に解釈するだけ。 +-- [English]: A backend-agnostic drawing primitive. Each backend simply +-- interprets these in sequence via drawPrimitives. data Primitive = PLine !Point !Point !LineStyle | PRect !Rect !FillStyle (Maybe StrokeStyle) - -- | 'PCircle' は最終フィールドに optional hover label。 SVG backend は - -- 要素として埋め込み、 ブラウザ native の hover tooltip に。 - -- JS 不要。 + -- | [日本語]: 'PCircle' は最終フィールドに optional hover label。 SVG backend は + -- <title> 要素として埋め込み、 ブラウザ native の hover tooltip に。 + -- JS 不要。 + -- [English]: 'PCircle' carries an optional hover label as its final + -- field. The SVG backend embeds it as a @\<title\>@ element, giving a + -- browser-native hover tooltip with no JS required. | PCircle !Point !Double !FillStyle (Maybe StrokeStyle) (Maybe Text) | PPath ![PathSegment] !FillStyle (Maybe StrokeStyle) | PText !Point !Text !TextStyle | PClipPush !Rect + -- | [日本語]: 多角形 clip (Phase 64 §2)。 頂点列は 'PRect' と同じ左上原点 y-down + -- 空間で、 **最後の頂点から最初の頂点へ暗黙に閉じる** (明示 close 不要)。 + -- 矩形 clip は高速経路として 'PClipPush' を使い続ける (本 primitive は + -- polar の外周・ternary の三角形など矩形で表せない panel 用)。 + -- ★ 頂点が 3 点未満の退化列は **clip 無し (素通し)** として扱う — 全 backend で + -- 統一。 「全消し」 にすると図が黙って白紙になるので fail-open を採る。 + -- [English]: Polygon clip (Phase 64 §2). The vertex list lives in the + -- same top-left-origin, y-down space as 'PRect', and is **implicitly + -- closed** from the last vertex back to the first. Rectangular clips + -- keep using 'PClipPush' as the fast path; this primitive is for panels + -- that a rectangle cannot express (a polar boundary, a ternary + -- triangle, ...). A degenerate list of fewer than 3 vertices is treated + -- as __no clip at all__ (pass-through) in every backend: failing open + -- avoids silently blanking a figure. + | PClipPath ![Point] | 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' は比率ゆえ不変。 +-- | [日本語]: pt 空間の primitive を device 単位へ一括 scale (k = dpi/72)。 +-- ★ raster/vector backend で __唯一の dpi 適用点__。Layout/Render は +-- 純 pt を出力し、ここで一度だけ k を掛ける。PDF は k=1 (pt 直結・恒等) を渡す。 +-- 座標・サイズ・線幅・font size・dash 配列を全て k 倍する。'ScaleT' は比率ゆえ不変。 +-- [English]: Bulk-scales primitives from pt space to device units +-- (k = dpi/72). This is the __sole point where dpi is applied__ across +-- the raster/vector backends: Layout/Render emit pure pt values, and k is +-- applied exactly once here. PDF passes k=1 (a pt-direct identity). +-- Coordinates, sizes, line widths, font sizes, and dash arrays are all +-- scaled by k; 'ScaleT' is unaffected since it is a ratio. scalePrimitives :: Double -> [Primitive] -> [Primitive] scalePrimitives k | k == 1 = id @@ -138,6 +182,7 @@ 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) + PClipPath ps -> PClipPath (map sp ps) PClipPop -> PClipPop PTransformPush tr -> PTransformPush (str tr) PTransformPop -> PTransformPop diff --git a/src/Graphics/Hgg/Render.hs b/src/Graphics/Hgg/Render.hs --- a/src/Graphics/Hgg/Render.hs +++ b/src/Graphics/Hgg/Render.hs @@ -1,22 +1,36 @@ -- | -- Module : Graphics.Hgg.Render --- Description : Layer 1 ─ Renderer 抽象 (Phase 26 §A-5 Resolver 対応版) +-- Description : Layer 1 renderer abstraction: resolver-based, backend-independent primitives -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- 'VisualSpec' + 'Resolver' + 'Layout' → backend 非依存 'Primitive' 列。 --- 各 backend (SVG / PDF / Canvas / Rasterific) は 'drawPrimitives' のみ実装。 +-- [日本語]: 'Graphics.Hgg.Spec.VisualSpec' + 'Graphics.Hgg.Spec.Resolver' + 'Graphics.Hgg.Layout.Layout' → backend 非依存 'Primitive' 列。 +-- 各 backend (SVG / PDF / Canvas / Rasterific) は 'drawPrimitives' のみ実装。 +-- [English]: Converts a 'Graphics.Hgg.Spec.VisualSpec' + 'Graphics.Hgg.Spec.Resolver' + 'Graphics.Hgg.Layout.Layout' into a +-- backend-independent list of 'Primitive's. Each backend (SVG / PDF / +-- Canvas / Rasterific) implements only '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 +-- [日本語]: 旧 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 +-- [English]: Splits the old 3850-line monolith into modules by +-- responsibility. This module is a backwards-compatibility shim that only +-- re-exports the previous public names from 'Render.Common' / +-- 'Render.Special' / 'Render.Layer' (output-neutral, a pure move). +-- * "Graphics.Hgg.Render.Common" — types / theme / projection / axis / color / shape / stat helpers +-- * "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 @@ -33,15 +47,16 @@ -- * Theme palette , ThemePalette(..) , themePalette + , specThemePalette -- ★ Phase 63 A18: raster backend の init 色分岐用 -- * Primitive , Primitive(..) - -- * Phase 33 B5: pt→device scale (backend の唯一の dpi 適用点) + -- * pt→device scale (backend の唯一の dpi 適用点) , scalePrimitives -- * 変換 , renderToPrimitives -- * Backend interface , Renderer(..) - -- * Phase 1 A7: edge port + -- * edge port , edgePortPoint ) where diff --git a/src/Graphics/Hgg/Render/Basic.hs b/src/Graphics/Hgg/Render/Basic.hs --- a/src/Graphics/Hgg/Render/Basic.hs +++ b/src/Graphics/Hgg/Render/Basic.hs @@ -1,10 +1,11 @@ -- | -- Module : Graphics.Hgg.Render.Basic --- Description : 基本 mark (scatter/line/bar/histogram/band/step/stem) +-- Description : Basic marks: scatter, line, bar, histogram, band, step, stem -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +-- [日本語]: Render モノリス分割 (出力中立・純粋移動)。 +-- [English]: Split out from the Render monolith (an output-neutral, pure move). {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unused-imports #-} @@ -18,8 +19,10 @@ Track (..), solveTracks, needsLegend, effectiveLegendPos, coordOf, isPolar, polarCenter, polarPoint, + isTernary, domFrac, projectXY, projectRectData, projectBarRect, catUnitPx, resolutionOf, + BarShape (..), projectBar, projectSegment, AxisPlacement (..), coordXAxisPlacement, coordYAxisPlacement, coordXGridIsVertical) @@ -62,12 +65,18 @@ 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)。 +-- | [日本語]: 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)。 +-- [English]: TODO-11 (2026-05-27): an area band (a confidence interval / +-- prediction band). encX is the shared x, encY the lower bound, encY2 the +-- upper bound. Drawn as a single filled 'PPath' (forward along x-yLow, +-- backward along x-yHigh, then close). alpha is a layer modifier (default 0.2). renderBand :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] -renderBand r layout pal ly = +renderBand r layout pal ly + -- ★ Phase 64 A13: ternary では下/上境界を encZ 正規化して塗る (別経路)。 + | isTernary (lpCoord layout) = renderBandTernary r layout pal ly + | otherwise = let xs = V.toList (vecOr (lyEncX ly) r) yLo = V.toList (vecOr (lyEncY ly) r) yHi = case getLast (lyEncY2 ly) of @@ -96,10 +105,56 @@ 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) は行わない。 +-- | [日本語]: ★ Phase 64 A13: 三角座標 (ternary) の area band (ribbon)。 下境界 +-- (encX=a, encY=b, encZ=c) と上境界 (encX=a, encY2=b, encZ=c) をそれぞれ +-- 'ternaryRemap' で正規化 fraction 化し、 forward(下) + backward(上 reverse) の +-- 塗り polygon を作る。 退化/NaN 頂点は落とす。 三角形外への spill は dispatch 側 +-- (Render/Layer.hs) の三角形 clip が切る (= データ側で事前フィルタしない)。 +-- [English]: Phase 64 A13 ternary area band (ribbon). Normalizes the lower +-- boundary (encX=a, encY=b, encZ=c) and the upper boundary (encX=a, +-- encY2=b, encZ=c) each via 'ternaryRemap', then builds a filled polygon +-- forward along the lower boundary and backward along the (reversed) upper +-- boundary. Degenerate / NaN vertices are dropped. Any spill outside the +-- triangle is clipped by the triangle clip in the dispatch (Render/Layer.hs); +-- no data-side pre-filtering. +renderBandTernary :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] +renderBandTernary r layout pal ly = + let coord = lpCoord layout + pp = projectPoint coord layout + xsRaw = vecOrFull (lyEncX ly) r + loRaw = vecOrFull (lyEncY ly) r + hiRaw = case getLast (lyEncY2 ly) of + Just c -> vecOrFull (Last (Just c)) r + Nothing -> V.empty + c = staticColorOr ly (tpDefault pal) + a = doubleOr (lyAlpha ly) 0.2 + (xsLo, bLo) = ternaryRemap r layout ly xsRaw loRaw + (xsHi, bHi) = ternaryRemap r layout ly xsRaw hiRaw + -- 正規化済 (a,b) 対を px へ。 NaN (退化 / 欠損) 頂点は落とす。 + ptsOf axV bxV = + [ pp av bv + | i <- [0 .. min (V.length axV) (V.length bxV) - 1] + , let av = axV V.! i; bv = bxV V.! i + , not (isNaN av), not (isNaN bv) ] + forwardPts = ptsOf xsLo bLo + backwardPts = reverse (ptsOf xsHi bHi) + segs = case forwardPts of + [] -> [] + (h:tl) -> [MoveTo h] <> map LineTo tl <> map LineTo backwardPts <> [ClosePath] + in if length forwardPts < 2 || null backwardPts then [] + else [ PPath segs (FillStyle c a) Nothing ] + +-- | [日本語]: streamgraph (= 中心化積層 area、 ThemeRiver 風)。 color aes で系列分割し +-- (= 'renderBarGrouped' と同型の群キー取得)、 各 x 値で系列 y を積層、 baseline を +-- -(Σy)/2 から開始 (silhouette 中心化) して各系列を塗り polygon ('renderBand' と同型の +-- forward 下境界 + backward 上境界 + close) で描く。 wiggle 最小化 (ThemeRiver) は行わない。 +-- [English]: A streamgraph (a centered stacked area, ThemeRiver-style). Splits +-- series by the color aesthetic (using the same group-key extraction as +-- 'renderBarGrouped'), stacks each series' y value at every x, and starts the +-- baseline at -(Σy)/2 (silhouette centering) before filling each series as a +-- polygon (a forward lower boundary plus a backward upper boundary plus +-- close, the same shape as 'renderBand'). Wiggle minimization (as in +-- ThemeRiver) is not performed. renderStream :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderStream r layout pal ly = let xsAll = V.toList (vecOr (lyEncX ly) r) @@ -143,13 +198,15 @@ in if n < 2 || length xUniq < 2 || null groups then [] else concat [ mkSeries gi | gi <- [0 .. length groups - 1] ] --- | Scatter: 各 (x, y) を PCircle に。 +-- | [日本語]: Scatter: 各 (x, y) を PCircle に。 +-- [English]: Scatter: renders each (x, y) as a '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 + -- ★ Phase 64 A13: ternary は 'ternaryRemap' で (x,y) を encZ 正規化した fraction へ + -- 写す (退化行→NaN で下の NaN skip に乗る)。 非 ternary は素通し = byte 不変。 + let (xs, ys) = ternaryRemap r layout ly (vecOrFull (lyEncX ly) r) (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 @@ -176,22 +233,21 @@ resY = resolutionOf (filter finite (V.toList ys)) capHalfX = 0.5 * capWFactor * resX -- errorY の横 cap 半幅 (x データ単位) capHalfY = 0.5 * capWFactor * resY -- errorX の縦 cap 半幅 (y データ単位) + -- ★ Phase 64 A5: 誤差棒/cap は data 空間の線分として 'projectSegment' に通す。 + -- 直線座標系は両端 2 点 = 旧 projectXY 直結と bit 一致、 polar では x 方向に + -- 跨る線分 (errorY の cap・errorX の本体) が弦ではなく弧としてサンプルされる。 + errSeg (dx0, dy0) (dx1, dy1) = + let pts = projectSegment coord layout (dx0, dy0) (dx1, dy1) + in [ PLine p q (solid (tpAxis pal) 1.0) | (p, q) <- zip pts (drop 1 pts) ] 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) - ] + errSeg (x - dx, y) (x + dx, y) + <> errSeg (x - dx, y - capHalfY) (x - dx, y + capHalfY) + <> errSeg (x + dx, y - capHalfY) (x + dx, y + capHalfY) Nothing -> [] mkErrY i = let x = xs V.! i; y = ys V.! i @@ -199,16 +255,9 @@ 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) - ] + errSeg (x, y - dy) (x, y + dy) + <> errSeg (x - capHalfX, y - dy) (x + capHalfX, y - dy) + <> errSeg (x - capHalfX, y + dy) (x + capHalfX, y + dy) Nothing -> [] errorPrims = concatMap (\i -> mkErrX i <> mkErrY i) [0 .. n - 1] -- connect 線 (= Phase 26 §C-2 #5) @@ -255,11 +304,17 @@ -- 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 の矢印は --- 退化して描かれない。 +-- | [日本語]: 各 (x,y) に成分 (u,v) の矢印を描く (= matplotlib @quiver@)。 矢印長は +-- autoscale (= 最長矢印がデータ対角の 8%) に 'lyArrowScale' 倍を掛けた長さ。 +-- 'lyArrowMagnitude' で magnitude (√(u²+v²)) の連続色マップ (viridis)。 矢印は +-- 始点 (x,y) を根元に置く (pivot=tail・matplotlib 既定)。 magnitude 0 の矢印は +-- 退化して描かれない。 +-- [English]: Draws an arrow with components (u,v) at each (x,y) (matplotlib's +-- @quiver@). Arrow length is the autoscaled length (the longest arrow spans 8% +-- of the data diagonal) multiplied by 'lyArrowScale'. 'lyArrowMagnitude' maps +-- magnitude (√(u²+v²)) to a continuous color scale (viridis). Arrows are +-- anchored at the start point (x,y) (pivot=tail, matplotlib's default). Arrows +-- with magnitude 0 degenerate and are not drawn. renderQuiver :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderQuiver r layout pal ly = let xs = vecOr (lyEncX ly) r @@ -298,8 +353,11 @@ -- plotArea でクリップする (端の矢印は途切れる)。 = ドメイン拡張より自然。 in PClipPush (lpPlotArea layout) : concatMap arrow idxs ++ [PClipPop] --- | Phase 26 A2: 始点 from → 終点 to の矢印 (本線 + 2 本の矢じり)。 矢じり形状は --- 'AnnArrow' (Render/Layer.hs) と同じ (長さ 2.5mm・開き比 0.5)。 +-- | [日本語]: 始点 from → 終点 to の矢印 (本線 + 2 本の矢じり)。 矢じり形状は +-- 'AnnArrow' (Render/Layer.hs) と同じ (長さ 2.5mm・開き比 0.5)。 +-- [English]: An arrow from the start point to the end point (a shaft plus two +-- barbs). The barb shape matches 'AnnArrow' (Render/Layer.hs): length 2.5mm, +-- opening ratio 0.5. drawArrow2D :: Point -> Point -> LineStyle -> [Primitive] drawArrow2D (Point px1 py1) (Point px2 py2) ls = let dx = px2 - px1; dy = py2 - py1 @@ -317,8 +375,11 @@ 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 + -- ★ Phase 64 A13: ternary は 'ternaryRemap' で (x,y) を encZ 正規化 fraction へ写す + -- (退化行→NaN で seg が詰める)。 群/linetype 分割も変換後の xs/ys で従来どおり動く。 + let (xsV, ysV) = ternaryRemap r layout ly (vecOrFull (lyEncX ly) r) (vecOrFull (lyEncY ly) r) + xs = V.toList xsV + ys = V.toList ysV w = doubleOr (lyStroke ly) defaultLineWidth coord = lpCoord layout pp = projectPoint coord layout @@ -332,7 +393,7 @@ in case getLast (lyColor ly) of -- Phase 52.A10: ColorByCol は群ごとに色付き線 (= ggplot color=group)。 単一カテゴリ -- (statLabel 1 本) なら 1 本を該当カテゴリ色で描く。 旧実装は ColorByCol を staticColorOr - -- が拾えず default 単色に潰れ、 異モデル重畳の色分けが効かなかった。 色は 'colorVector' + -- が拾えず default 単色に潰れ、 異モデル重畳の色分けが効かなかった。 色は 'Graphics.Hgg.Render.Common.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)) @@ -356,10 +417,14 @@ | (i, (_, gpts)) <- zip [0 ..] (orderedGroups keys (zip xs ys)) ] Nothing -> seg c fixedDash (zip xs ys) --- | Phase 9 B: position adjustment 対応 dispatcher。 +-- | [日本語]: position adjustment 対応 dispatcher。 -- 既定 (position identity) または群分け (color aesthetic) 無しは従来の単色 bar -- ('renderBarSimple')。 dodge/stack/fill かつ categorical x かつ ColorByCol 群分けあり -- のとき 'renderBarGrouped' で系列を並べる。 +-- [English]: The position-adjustment dispatcher. With the default (position +-- identity) or no grouping (color aesthetic), falls back to the plain +-- single-color bar ('renderBarSimple'). With dodge/stack/fill, categorical x, +-- and a 'ColorByCol' grouping, arranges series with 'renderBarGrouped'. renderBar :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderBar r layout pal ly = let pos = maybe PosIdentity id (getLast (lyPosition ly)) @@ -375,9 +440,13 @@ (_, 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 が単色を返すので従来挙動不変)。 +-- | [日本語]: position identity / 群分けなしの bar。 色は 'Graphics.Hgg.Render.Common.colorVector' に +-- 委譲 (ColorByCol で per-bar 色分け = ggplot の identity + fill aesthetic 同型。 +-- ColorStatic / 色指定なしは colorVector が単色を返すので従来挙動不変)。 +-- [English]: The bar for position identity / no grouping. Color delegates to +-- 'Graphics.Hgg.Render.Common.colorVector' ('ColorByCol' gives per-bar coloring, matching ggplot's +-- identity + fill aesthetic; with 'ColorStatic' or no color specified, +-- 'Graphics.Hgg.Render.Common.colorVector' returns a single color, so the previous behavior is unchanged). renderBarSimple :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderBarSimple r layout pal ly = -- categorical x: 各 row の label を xCats (= x 軸のカテゴリ列) の index へ。 @@ -419,28 +488,25 @@ 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 11 A7-c: 極座標は扇形 (wedge)。 PolarX = rose (角度帯×半径=値)、 + -- PolarY = 中心からの扇形 (角度=値×半径帯)。 + -- ★ Phase 64 A2: coord 分岐は投影層 projectBar へ集約 (旧 mkWedge と式レベル同一。 + -- halfWidthD 0.45 = resolution 0.9 の半分)。 geom は BarShape で case する。 + in [ case projectBar coord layout x 0 y 0.45 bw of + BarRect rect -> PRect rect (FillStyle c a) border + BarWedge segs -> PPath segs (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)。 +-- | [日本語]: 群分け 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 と同一割当)。 +-- 色は群 index → categorical palette (= 'Graphics.Hgg.Render.Common.colorVector' の ColorByCol と同一割当)。 +-- [English]: Position adjustment for grouped bars (dodge / stack / fill). +-- Assumes long-form data (each row is (x-cat, group, value)); within each +-- x-category slot, arranges series (the color/group aesthetic) side by side +-- (dodge), stacked vertically (stack), or normalized to 100% (fill). Color +-- maps group index to the categorical palette (the same assignment +-- 'Graphics.Hgg.Render.Common.colorVector' uses for ColorByCol). renderBarGrouped :: Position -> [Text] -> Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderBarGrouped pos keys r layout pal ly = let xCats = lpXCategoryLabels layout @@ -543,8 +609,10 @@ , 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})。 +-- | [日本語]: Step plot: lyEncX = x、 lyEncY = y、 階段折れ線。 +-- 各 segment は (x_i, y_i) → (x_{i+1}, y_i) → (x_{i+1}, y_{i+1})。 +-- [English]: A step plot: lyEncX is x, lyEncY is y, drawn as a staircase +-- line. Each segment goes (x_i, y_i) to (x_{i+1}, y_i) to (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) @@ -564,7 +632,9 @@ ] ++ mkSegs ((x2, y2) : rest) in mkSegs pts --- | Stem / lollipop plot (Phase 6+ C-3): 縦棒 + 上端 circle marker。 +-- | [日本語]: Stem / lollipop plot: 縦棒 + 上端 circle marker。 +-- [English]: A stem / lollipop plot: a vertical bar with a circle marker at +-- the top. renderStem :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderStem r layout pal ly = let xs = V.toList (vecOr (lyEncX ly) r) diff --git a/src/Graphics/Hgg/Render/Common.hs b/src/Graphics/Hgg/Render/Common.hs --- a/src/Graphics/Hgg/Render/Common.hs +++ b/src/Graphics/Hgg/Render/Common.hs @@ -1,10 +1,11 @@ -- | -- Module : Graphics.Hgg.Render.Common --- Description : 共通基盤 (型・theme・projection・axis/grid/tick・color・shape・stat helper) +-- Description : Core types, theme, projection, axis/grid/tick, color, shape, and stat helpers -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +-- [日本語]: Render モノリス分割 (出力中立・純粋移動)。 +-- [English]: Split out from the Render monolith (output-neutral, pure relocation only). {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unused-imports #-} @@ -18,11 +19,25 @@ formatTicksGG, Track (..), solveTracks, needsLegend, effectiveLegendPos, + effectiveTickLength, effectiveTickDir, + tickOutwardLen, effectivePlotMargin, + effectiveBaseFontSize, effectiveHalfLine, + effectiveAxTextMar, + effectiveSubtitleSize, effectiveCaptionSize, + effectiveTagSize, + effectiveShowAxisText, effectiveShowAxisTitle, coordOf, isPolar, polarCenter, polarPoint, + polarOuterFrac, + isTernary, ternaryCenter, ternaryVertices, + ternaryPoint, normalizeTernary, domFrac, projectXY, projectRectData, projectBarRect, catUnitPx, AxisPlacement (..), coordXAxisPlacement, coordYAxisPlacement, coordXGridIsVertical, + -- Phase 64 A4: categorical-cross 投影口 + CrossLoc (..), BarShape (..), + projectCrossPoint, projectCrossSpan, + projectCrossBar, UCtx (..), resolvePosX, resolvePosY) import Graphics.Hgg.Unit (Pos (..), mmToPt) import Graphics.Hgg.Primitive -- Phase 51: Point/Rect/style/Primitive/scalePrimitives (leaf) @@ -43,9 +58,10 @@ Position (..), Coord (..), FacetScales (..), freeScaleX, freeScaleY, FacetSpace (..), freeSpaceX, freeSpaceY, - ThemeOverride (..), + ThemeOverride (..), TickDir (..), Margin (..), VisualSpec (..), YAxisSide (..), axisFormatOf, axisRotateOf, resolveAxisAngle, axisShowTicksOf, + axisTextAngleXOf, axisTextAngleYOf, axShowGrid, FontSpec (..), orderedCats, colRefName, distGroupRef, distDodgeRef, @@ -66,19 +82,27 @@ -- 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)。 +-- | [日本語]: TODO-10 (2026-05-29) PS port: どの font slot を引くか +-- (= spec の titleFont / axisLabelFont / tickFont / legendFont)。 +-- [English]: TODO-10 (2026-05-29) PS port: which font slot to pull (that is, +-- the spec's 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。 +-- | [日本語]: TODO-10 (2026-05-29) PS port: spec の font 設定 + theme default を merge して TextStyle を生成。 +-- spec を取れない場所 (= layer helper 内など) では Nothing を渡すと slot default に fallback。 +-- [English]: TODO-10 (2026-05-29) PS port: merges the spec's font settings with +-- the theme default to build a 'TextStyle'. Where the spec is unavailable +-- (for example, inside a layer helper), pass 'Nothing' to fall back to the +-- slot default. 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 + -- ★ Phase 63 A12: 固定 11 を theme (toBaseFontSize) の実効値へ。 spec を取れない + -- 場所 (mSpec = Nothing) は従来どおり 11。 予約 (Layout) と同一情報源。 + baseSize = maybe 11 effectiveBaseFontSize mSpec defSize = case fk of TitleF -> baseSize * 1.2 -- plot.title rel(1.2) = 13.2pt AxisLabelF -> baseSize -- axis.title = base = 11pt @@ -113,12 +137,17 @@ TitleF -> tpTitleColor pal AxisLabelF -> tpTitleColor pal _ -> tpText pal + -- ★ Phase 63 A20.5: 全 slot 共通の family fallback (themeFontFamily)。 + -- 優先順位: slot 別 FontSpec の fsFamily > toFontFamily > "sans-serif" + defFamily = case mSpec of + Nothing -> "sans-serif" + Just spec -> orElse (toFontFamily (vsThemeOverride spec)) "sans-serif" in case mFont of - Nothing -> TextStyle defColor defSize "sans-serif" anchor rot "normal" False + Nothing -> TextStyle defColor defSize defFamily 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" + , tsFamily = orElse (Graphics.Hgg.Spec.fsFamily fs) defFamily , tsAnchor = anchor , tsRotate = rot , tsWeight = orElse (Graphics.Hgg.Spec.fsWeight fs) "normal" @@ -127,38 +156,70 @@ -- 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')。 +-- | [日本語]: mm → pt 変換。 mark 既定 (point/line/半径/cap/矢じり) を物理 mm で +-- 書くためのヘルパ。 layout/Primitive は純 pt なので、 既定もここで pt に解決する。 +-- backend が dpi 係数 (k) を最後に一律適用する ('scalePrimitives')。 +-- [English]: Converts mm to pt. A helper for writing mark defaults +-- (point/line radius, cap, arrowhead) in physical mm. Since layout/Primitive +-- are in pure pt, defaults are resolved to pt here too; the backend applies +-- the dpi factor (k) uniformly at the end ('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)。 +-- | [日本語]: scatter / point マーカーの既定__直径__ (pt)。ggplot +-- @geom_point@ 既定を実測した 1.65mm (= 半径 2.34pt) に較正 +-- (`phase-34-measurements/A1-results.md`)。size 意味論は「外接円の直径」。 +-- [English]: The default __diameter__ (pt) of a scatter/point marker. +-- Calibrated to the measured 1.65mm (radius 2.34pt) default of ggplot's +-- @geom_point@ (see `phase-34-measurements/A1-results.md`). The "size" +-- semantics is "the diameter of the bounding circle". 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 実測で検証)。 +-- | [日本語]: 線 (geom_line/path/step/segment) の既定__線幅__ (pt)。ggplot +-- @linewidth 0.5@ の実描画幅 0.376mm に較正 (解析式 @nominal × .pt/96 × 25.4@ を +-- 太線 bbox 実測で検証)。 +-- [English]: The default __line width__ (pt) for lines (geom_line/path/step/ +-- segment). Calibrated to the measured 0.376mm rendered width of ggplot's +-- @linewidth 0.5@ (the formula @nominal × .pt/96 × 25.4@ was verified +-- against a thick-line bounding-box measurement). defaultLineWidth :: Double defaultLineWidth = mmPt 0.376 --- | geom_smooth 線の既定線幅 (pt)。ggplot は @linewidth = 2 × 既定@ なので line の --- 2倍 (0.753mm)。Phase 34 A1。 +-- | [日本語]: geom_smooth 線の既定線幅 (pt)。ggplot は @linewidth = 2 × 既定@ なので line の +-- 2倍 (0.753mm)。 +-- [English]: The default line width (pt) for geom_smooth lines. ggplot uses +-- @linewidth = 2 × default@, so this is twice the plain line width (0.753mm). 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)。 +-- | [日本語]: Theme 色 palette (= JSON serialize しないので Render module 内に閉じる)。 +-- 色に加え「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)。 +-- * tpShowBackground = plot 全面背景 (tpBackground) を塗るか。 +-- False = 塗らない = 透過。 tpBackground の色自体は geom_label 箱や bar 縁取り等の +-- 「背景色」 参照用に残る。 +-- [English]: The theme color palette (kept inside the Render module because +-- it is not JSON-serialized). Besides the colors themselves, it carries +-- on/off flags for panel background fill, grid, and border: +-- * tpPanelBg = the panel (plot area) background color, painted when +-- tpShowPanel is True. +-- * tpShowPanel = whether to paint the panel rectangle (True for +-- theme_grey / brand themes, False for the legacy presets). +-- * tpShowGrid = the theme-level grid master switch (False suppresses +-- all grid lines; ANDed with the per-axis axShowGrid). +-- * tpShowBorder = whether to draw the 4-sided axisFrame border (True for +-- the legacy presets, False for panel-filled themes). +-- * tpShowBackground = whether to paint the plot's full background +-- (tpBackground). False means no fill (transparent); the tpBackground +-- color itself is still kept for other uses, such as the geom_label box +-- or bar outline "background color". data ThemePalette = ThemePalette { tpBackground :: !Text + , tpShowBackground :: !Bool , tpAxis :: !Text , tpText :: !Text , tpGrid :: !Text @@ -169,6 +230,11 @@ , tpPanelBg :: !Text -- panel (plotArea) 背景色 , tpShowPanel :: !Bool -- panel 矩形を塗るか , tpShowGrid :: !Bool -- theme レベルの grid master + -- ★ Phase 63 A2: major/minor の個別 flag。 preset 定義では書かず 'themePalette' の + -- 出口で tpShowGrid と同値に初期化 (= 既定挙動不変)。 'resolveTheme' が + -- 個別 override > 一括 toShowGrid > preset の順で解決する。 + , tpShowGridMajor :: !Bool -- panel.grid.major + , tpShowGridMinor :: !Bool -- panel.grid.minor , tpShowBorder :: !Bool -- axisFrame の 4 辺枠を描くか , tpShowAxisLine :: !Bool -- 下辺(x軸)+左辺(y軸)の 2 本軸線を描くか (theme_classic) -- ★ Phase 32 (re-apply): ggplot theme_grey fidelity 用の追加 field。 @@ -186,21 +252,25 @@ { tpBackground = "#ffffff", tpAxis = "#444444", tpText = "#333333", tpGrid = "#dddddd" , tpDefault = "#1f77b4", tpDefaultFill = "#1f77b4", tpPanelBg = "#ffffff" , tpShowPanel = False, tpShowGrid = True, tpShowBorder = True, tpShowAxisLine = False + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True , 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 + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True , 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 + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True , 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 + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True , 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)。 @@ -208,6 +278,7 @@ { tpBackground = "#ffffff", tpAxis = "#4d4d4d", tpText = "#4d4d4d", tpGrid = "#ffffff" , tpDefault = "#000000", tpDefaultFill = "#595959", tpPanelBg = "#ebebeb" , tpShowPanel = True, tpShowGrid = True, tpShowBorder = False, tpShowAxisLine = False + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True -- ★ 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)。 @@ -215,11 +286,13 @@ { tpBackground = "#16161e", tpAxis = "#5a6080", tpText = "#c8ccda", tpGrid = "#2a2e45" , tpDefault = "#7aa2f7", tpDefaultFill = "#7aa2f7", tpPanelBg = "#1e2030" , tpShowPanel = True, tpShowGrid = True, tpShowBorder = False, tpShowAxisLine = False + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True , 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 + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True , tpTitleColor = "#2b2b33", tpTitleHjust = 0.0, tpTickLineColor = "#8a857e", tpLegendKeyBg = "" } -- Parchment 正式テーマ (明)。 panel=羊皮紙 cream-light #F8F5EE は据え置き、 -- 外周 plot bg は白 #FFFFFF にして軸内 panel を額装的に強調 (2026-06-02 ユーザ確定)。 @@ -227,49 +300,64 @@ { tpBackground = "#ffffff", tpAxis = "#8b6f3a", tpText = "#1a1620", tpGrid = "#e0d6c0" , tpDefault = "#f0a5a0", tpDefaultFill = "#f0a5a0", tpPanelBg = "#f8f5ee" , tpShowPanel = True, tpShowGrid = True, tpShowBorder = False, tpShowAxisLine = False + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True , 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 + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True , 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 + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True , 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 + , tpShowGridMajor = False, tpShowGridMinor = False, tpShowBackground = 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 + , tpShowGridMajor = False, tpShowGridMinor = False, tpShowBackground = True , 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 + , tpShowGridMajor = True, tpShowGridMinor = True, tpShowBackground = True , tpTitleColor = "#1a1a1a", tpTitleHjust = 0.0, tpTickLineColor = "#000000", tpLegendKeyBg = "" } --- | Phase 9 A-2: preset palette に ThemeOverride を合成 (element 単位上書き)。 --- 各 override field が Just なら preset 値を差し替える。 描画は合成後の値のみ参照。 +-- | [日本語]: preset palette に ThemeOverride を合成 (element 単位上書き)。 +-- 各 override field が Just なら preset 値を差し替える。 描画は合成後の値のみ参照。 +-- [English]: Merges a 'ThemeOverride' onto the preset palette (per-element +-- override). Each Just override field replaces the corresponding preset +-- value; rendering only ever consults the merged result. resolveTheme :: Graphics.Hgg.Spec.ThemeName -> ThemeOverride -> ThemePalette resolveTheme name ov = let base = themePalette name in base { tpBackground = ovT toPlotBg (tpBackground base) + -- ★ Phase 63 A18: plot.background 塗り on/off (False = 透過)。 + , tpShowBackground = ovB toShowBackground (tpShowBackground base) , tpPanelBg = ovT toPanelBg (tpPanelBg base) , tpShowPanel = ovB toShowPanel (tpShowPanel base) , tpGrid = ovT toGridColor (tpGrid base) , tpShowGrid = ovB toShowGrid (tpShowGrid base) + -- ★ Phase 63 A2: 個別 flag > 一括 toShowGrid > preset の順。 toShowGrid は + -- major/minor 両方を設定する糖衣なので、 一括値を既定に個別値で上書きする。 + , tpShowGridMajor = ovB toShowGridMajor (ovB toShowGrid (tpShowGridMajor base)) + , tpShowGridMinor = ovB toShowGridMinor (ovB toShowGrid (tpShowGridMinor base)) , tpShowBorder = ovB toShowBorder (tpShowBorder base) , tpShowAxisLine = ovB toShowAxisLine (tpShowAxisLine base) , tpAxis = ovT toAxisColor (tpAxis base) @@ -285,15 +373,22 @@ ovB f d = fromMaybe d (getLast (f ov)) ovD f d = fromMaybe d (getLast (f ov)) --- | spec の theme + override を解決して ThemePalette を得る (全 render 経路の入口)。 +-- | [日本語]: spec の theme + override を解決して ThemePalette を得る (全 render 経路の入口)。 +-- [English]: Resolves the spec's theme plus its override into a +-- 'ThemePalette' (the entry point used by every render path). 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) 優先。 +-- | [日本語]: facet strip.background の (塗り色, 表示) を解決。 ggplot は殆どの preset で +-- 灰矩形 (grey85 #d9d9d9)、 theme_minimal / theme_void は strip 矩形なし。 panel 塗り系 +-- (dark/noir/canvas-dark) は panel より少し明るい/暗い帯。 override (toStripBg/toShowStrip) 優先。 +-- [English]: Resolves the facet strip.background (fill color, visibility). +-- Most ggplot presets use a grey rectangle (grey85 #d9d9d9); theme_minimal / +-- theme_void draw no strip rectangle at all. Panel-filled themes +-- (dark/noir/canvas-dark) use a band slightly lighter/darker than the panel. +-- The override (toStripBg/toShowStrip) takes priority when present. themeStripStyle :: VisualSpec -> (Text, Bool) themeStripStyle spec = let name = fromMaybe Graphics.Hgg.Spec.ThemeDefault (getLast (vsTheme spec)) @@ -312,10 +407,16 @@ shw = fromMaybe dshow (getLast (toShowStrip ov)) in (bg, shw) --- | Scale の range (= pixel 出力域) を別 Rect に合わせて作り直す。 domain は不変。 --- plot area を縮める時 (subplot / marginal) は plotArea だけでなく scale の range も --- 必ず合わせないと、 mark の位置が古い枠基準のまま描かれて軸枠からはみ出す --- (= ggplot で panel が動けば座標変換も追従するのと同じ原則)。 +-- | [日本語]: Scale の range (= pixel 出力域) を別 Rect に合わせて作り直す。 domain は不変。 +-- plot area を縮める時 (subplot / marginal) は plotArea だけでなく scale の range も +-- 必ず合わせないと、 mark の位置が古い枠基準のまま描かれて軸枠からはみ出す +-- (= ggplot で panel が動けば座標変換も追従するのと同じ原則)。 +-- [English]: Rebuilds a scale's range (the pixel output extent) to match a +-- different Rect; the domain is unchanged. When shrinking the plot area +-- (subplots / marginal panels), the scale's range must be re-matched along +-- with plotArea — otherwise marks keep the old frame's positions and spill +-- outside the axis frame (the same principle as ggplot's coordinate +-- transform following the panel whenever it moves). 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) @@ -330,20 +431,60 @@ 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 挙動と互換)。 +-- =========================================================================== +-- ★ Phase 68: grid / 軸線 線幅の実効値解決 (単一情報源) +-- ThemeOverride の線幅 field (未指定=各 role の現状決め打ち) を解決する。 +-- 未指定時は既存 golden をゼロ diff で保つため現状リテラルへ fallback。 +-- 線幅は panel 面積に波及しないので Layout 予約は無く、 Render 側のみで閉じる。 +-- [English]: Phase 68 — effective line widths for grid / axis lines (single +-- source of truth). Resolves the ThemeOverride width fields, falling back to +-- each role's current literal when unspecified (zero golden diff). Widths do +-- not affect panel area, so this is closed on the Render side (no Layout +-- reservation). +-- =========================================================================== + +-- | Cartesian grid major の線幅。 既定 1.0。 +effectiveGridWidth :: ThemeOverride -> Double +effectiveGridWidth ov = fromMaybe 1.0 (getLast (toGridWidth ov)) + +-- | Cartesian grid minor の線幅。 未指定は major × 0.5 (ggplot @panel.grid.minor +-- = rel(0.5)@)、 'toGridMinorWidth' 明示時はそれを優先。 +effectiveGridMinorWidth :: ThemeOverride -> Double +effectiveGridMinorWidth ov = + fromMaybe (effectiveGridWidth ov * 0.5) (getLast (toGridMinorWidth ov)) + +-- | polar / ternary grid の線幅。 現状は座標系別の決め打ち 0.5。 'toGridWidth' を +-- 指定した場合は Cartesian major と統一する (ggplot panel.grid は座標系非依存)、 +-- 未指定は現状 0.5 を維持 (golden 保存)。 polar・ternary は同挙動なので共用。 +effectiveNonCartesianGridWidth :: ThemeOverride -> Double +effectiveNonCartesianGridWidth ov = fromMaybe 0.5 (getLast (toGridWidth ov)) + +-- | axis.line / panel.border / ternary edge / 右 Y 軸線 の線幅。 既定 1.0。 +-- (tick mark は ggplot @axis.ticks@ = 別 element なので本 Phase scope 外・1.0 維持。) +effectiveAxisLineWidth :: ThemeOverride -> Double +effectiveAxisLineWidth ov = fromMaybe 1.0 (getLast (toAxisLineWidth ov)) + +-- | [日本語]: 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 挙動と互換)。 +-- [English]: TODO-3b (2026-05-29): draws C-5 grid lines. Ported from PS +-- Render.purs:gridLines to Haskell. When axShowGrid is True on vsXAxis / +-- vsYAxis, faint grid lines are drawn at the x/y tick positions. Defaults to +-- false (compatible with the previous Haskell behavior). gridLines :: Layout -> VisualSpec -> ThemePalette -> [Primitive] gridLines layout spec pal = let area = lpPlotArea layout coord = coordOf spec + ov = vsThemeOverride spec -- ★ Phase 68: grid 線幅 override 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 68: 決め打ち 1.0/0.5 を theme (toGridWidth/toGridMinorWidth) 実効値へ。 + -- 未指定=現状値 (major 1.0 / minor = major×0.5 = 0.5) で golden ゼロ diff。 + majorStyle = solid (tpGrid pal) (effectiveGridWidth ov) + minorStyle = solid (tpGrid pal) (effectiveGridMinorWidth ov) -- 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 @@ -382,9 +523,13 @@ -- 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 [] + -- Phase 63 A2: major/minor を個別 flag で描き分け ('resolveTheme' が一括 + -- toShowGrid / preset との優先を解決済)。 軸ごと axShowGrid は従来通り AND。 + gx = pick showXGrid minorX majorX + gy = pick showYGrid minorY majorY + pick axOn minor major = + (if tpShowGridMinor pal && axOn then minor else []) + ++ (if tpShowGridMajor pal && axOn then major else []) in gx <> gy where axisOrDef la = case getLast la of @@ -411,63 +556,178 @@ (a : b : _) -> let step = b - a in [ t - step / 2 | t <- ts ] ++ [ last ts + step / 2 ] _ -> [] --- | Phase 11 A7-c: 極座標の grid + 軸 (= 直交 gridLines/axisFrame/tickMarks の代わり)。 +-- | [日本語]: 極座標の grid + 軸 (= 直交 gridLines/axisFrame/tickMarks の代わり)。 -- 半径方向 = 同心円 (rad tick ごと) + 中心からの r 軸ラベル (上スポーク沿い)。 -- 角度方向 = 放射スポーク (theta tick ごと) + 外周の角度ラベル。 -- theta 軸は PolarX なら x、 PolarY なら y。 +-- [English]: Polar-coordinate grid + axes (replacing the Cartesian +-- gridLines/axisFrame/tickMarks). The radial direction draws concentric +-- circles (one per radius tick) plus r-axis labels along the top spoke; the +-- angular direction draws radial spokes (one per theta tick) plus angle +-- labels around the perimeter. The theta axis is x for PolarX and y for +-- PolarY. 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) + -- ★ Phase 68: polar grid (同心円 + 外周円 + スポーク) の線幅を theme 実効値へ。 + -- 未指定 0.5 維持。 toGridWidth 指定時は Cartesian major と統一。 ('ovT' は下で定義) + polarGridW = effectiveNonCartesianGridWidth ovT + circleStyle = Just (StrokeStyle gridCol polarGridW) noFill = FillStyle gridCol 0.0 - spokeStyle = solid gridCol 0.5 + spokeStyle = solid gridCol polarGridW -- 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 ) + 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 + -- 外周円。 ★ Phase 64 A8: ggplot2 に完全準拠させた (user 判断 2026-08-06)。 + -- 旧実装は Phase 11 A7-c 由来の**軸色の濃い円** (ggplot2 に対応物が無い独自 + -- 要素) をデータ最大半径に描いていた。 ggplot2 は radial grid の最外周を + -- θ ラベルと同じ npc 0.45 に、 **grid 線として**置く + -- (coord-polar.R の @rfine <- c(r_rescale(...), 0.45)@)。 これに合わせたので + -- θ ラベルが線に重なっても読める (細い grid 色) し、 grid off の theme では + -- ggplot2 と同じく円自体が消える。 + boundary = [ PCircle (Point cx cy) (maxR * polarOuterFrac) noFill circleStyle Nothing ] + -- 放射スポーク (角度 grid)。 中心→外周円 (ggplot2 も中心→npc 0.45 = + -- coord-polar.R render_bg の @vec_interleave(0, 0.45 * sin(theta))@)。 + spokes = [ PLine (Point cx cy) + (uncurry Point (polarPointXY (domFrac thetaScale v) polarOuterFrac)) + 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 + -- θ 軸ラベル (外周円の上、 各 theta tick)。 categorical なら群名、 でなければ値。 + -- ★ Phase 64 A8: 旧実装は根拠の無い @1.12@ 倍で、 maxR が panel 内接円 + -- (= panel の縁) だったため必ず panel の外へ出てタイトルと重なっていた。 + -- maxR を ggplot2 の npc 0.4 に合わせた今は 'polarOuterFrac' (0.45/0.4) が + -- そのまま ggplot2 の θ ラベル半径 npc 0.45 に一致し、 panel 内に収まる。 + -- ★ Phase 64 A18: θ 軸ラベルの回転を theme の axis.text 角に従わせる + -- (ggplot axis.text.x = element_text(angle=))。 θ を担う軸は coord で変わる + -- (PolarX=x / PolarY=y) ので、 その軸の 'axisTextAngleXOf'/'axisTextAngleYOf' + -- を解決する (Cartesian tick と同じ resolveAxisAngle 経路 = CCW 正 canonical)。 + -- polar の θ ラベルは npc 0.45 の panel 内配置なので、 Cartesian と違い + -- 回転マージンの予約は不要 (Layout 側は無改造)。 接線方向への自動回転は + -- ggplot に無いので入れない (plan §4-3)。 + -- [English]: Make the theta-axis label rotation follow the theme's + -- axis.text angle (ggplot axis.text.x = element_text(angle=)). Which + -- spec axis drives theta depends on the coord (PolarX=x / PolarY=y), so + -- resolve that axis's angle via the same resolveAxisAngle path as + -- Cartesian ticks (CCW-positive canonical). Polar theta labels sit + -- inside the panel at npc 0.45, so unlike Cartesian no rotation-margin + -- reservation is needed (Layout untouched). No automatic tangential + -- rotation (ggplot has none; plan §4-3). + ovT = vsThemeOverride spec + thetaRot = case coord of + CoordPolarY _ -> resolveAxisAngle (vsYAxis spec) (axisTextAngleYOf ovT) + _ -> resolveAxisAngle (vsXAxis spec) (axisTextAngleXOf ovT) + tsT = mkFontTS (Just spec) pal TickF AnchorMiddle thetaRot 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 + thetaLabels = [ let (lx, ly) = polarPointXY (domFrac thetaScale v) polarOuterFrac in PText (Point lx (ly + 4)) (thetaLabelFor i v) tsT | (i, v) <- zip [0 ..] thetaTicks ] polarPointXY tf rf = polarPoint layout tf rf + -- ★ Phase 64 A8: 外周円は grid の一部になったので、 grid off の theme では + -- ggplot2 と同じく描かない (旧実装は軸要素扱いで常に描いていた)。 in if tpShowGrid pal then circles <> spokes <> boundary <> radLabels <> thetaLabels - else boundary <> radLabels <> thetaLabels + else 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] - [] -> [] +-- | [日本語]: 三角座標 (ternary) の grid + 軸 (= Phase 64 A12、 'polarGrid' の対)。 +-- 直交 gridLines/axisFrame/tickMarks の代わりに、 正三角形の外周 3 辺 + 3 方向の +-- 格子線 + 三辺の数値 tick ラベル + 3 頂点の軸タイトルを描く。 成分 ↔ 頂点は +-- 'ternaryVertices' に従う (a=上・b=左下・c=右下)。 grid off の theme では格子線を +-- 落とし、 外周 3 辺 + tick/タイトルは残す ('polarGrid' の外周円と同方針)。 +-- [English]: The ternary grid + axes (Phase 64 A12; the counterpart of +-- 'polarGrid'). Instead of the Cartesian gridLines/axisFrame/tickMarks, it +-- draws the equilateral triangle's three outer edges, three families of grid +-- lines, numeric tick labels along the three edges, and the three vertex +-- axis titles. Component ↔ vertex follows 'ternaryVertices' (a=top, +-- b=bottom-left, c=bottom-right). Under a grid-off theme the grid lines are +-- dropped while the outer edges, ticks, and titles remain (matching how +-- 'polarGrid' keeps its boundary). +ternaryGrid :: VisualSpec -> Layout -> ThemePalette -> [Primitive] +ternaryGrid spec layout pal = + let (ctrX, ctrY, _) = ternaryCenter layout + ov = vsThemeOverride spec -- ★ Phase 68: edge/grid 線幅 override + gridCol = tpGrid pal + axisCol = tpAxis pal + -- ★ Phase 68: 三角形の 3 辺 = axis.line role (toAxisLineWidth・既定 1.0)、 + -- 内部格子 = grid role (toGridWidth 指定で統一・未指定 0.5)。 + edgeStyle = solid axisCol (effectiveAxisLineWidth ov) + gridStyle = solid gridCol (effectiveNonCartesianGridWidth ov) + tp abc = uncurry Point (ternaryPoint layout abc) + -- 外周 3 辺 (a=上 A, b=左下 B, c=右下 C)。 + edges = [ PLine (tp (1, 0, 0)) (tp (0, 1, 0)) edgeStyle -- A→B (c=0) + , PLine (tp (0, 1, 0)) (tp (0, 0, 1)) edgeStyle -- B→C (a=0) + , PLine (tp (0, 0, 1)) (tp (1, 0, 0)) edgeStyle ] -- C→A (b=0) + -- 3 方向の格子線 (内部 tick fraction のみ)。 a=const は a=0 辺に平行、 以下同様。 + inner = [ t | t <- lpZTicks layout, t > 1e-9, t < 1 - 1e-9 ] + gridA = [ PLine (tp (t, 1 - t, 0)) (tp (t, 0, 1 - t)) gridStyle | t <- inner ] + gridB = [ PLine (tp (1 - t, t, 0)) (tp (0, t, 1 - t)) gridStyle | t <- inner ] + gridC = [ PLine (tp (1 - t, 0, t)) (tp (0, 1 - t, t)) gridStyle | t <- inner ] + -- 中心から外向きへ d px 押し出す (頂点タイトル用。 頂点は 1 点なので放射方向で正しい)。 + outward (px, py) d = + let dx = px - ctrX; dy = py - ctrY; m = sqrt (dx * dx + dy * dy) + in if m < 1e-9 then (px, py) else (px + dx / m * d, py + dy / m * d) + -- ★ Phase 69 A2: 辺の外向き法線 (辺 P→Q に垂直・重心から外向き)。 全 tick を + -- 同一方向へ一定 px 押すことで、 辺上のラベルが辺に平行に整列する。 + -- 旧実装 (重心放射 'outward') は辺中央の tick ほど押し出しが垂直になり、 + -- 底辺の 0.4/0.6 が 0.2/0.8 より下にずれていた (Phase 69 起票の user 指摘)。 + edgeNormal (x1, y1) (x2, y2) = + let ex = x2 - x1; ey = y2 - y1 + (nx, ny) = (-ey, ex) -- 辺に垂直 + mx = (x1 + x2) / 2; my = (y1 + y2) / 2 + s = if nx * (mx - ctrX) + ny * (my - ctrY) < 0 then -1 else 1 -- 外向きへ符号 + m = sqrt (nx * nx + ny * ny) + in if m < 1e-9 then (0, 0) else (s * nx / m, s * ny / m) + vA = ternaryPoint layout (1, 0, 0) + vB = ternaryPoint layout (0, 1, 0) + vC = ternaryPoint layout (0, 0, 1) + -- 三辺の数値 tick ラベル。 a 列の左辺 A-B / b 列の下辺 B-C / c 列の右辺 C-A。 + tsTick = mkFontTS (Just spec) pal TickF AnchorMiddle 0 + -- 端点 (0/1 = 三角形の頂点) は 2 軸の tick が重なる上に頂点タイトルと被るので + -- 除き、 内部 tick (0.2..0.8) のみラベルする。 + edgeLabels = inner + mkLabelOn (nx, ny) abc t = + let (px, py) = ternaryPoint layout abc + in PText (Point (px + nx * 12) (py + ny * 12 + 3)) (numToText t) tsTick + tickA = [ mkLabelOn (edgeNormal vA vB) (t, 1 - t, 0) t | t <- edgeLabels ] + tickB = [ mkLabelOn (edgeNormal vB vC) (0, t, 1 - t) t | t <- edgeLabels ] + tickC = [ mkLabelOn (edgeNormal vC vA) (1 - t, 0, t) t | t <- edgeLabels ] + -- 3 頂点の軸タイトル (vsXLabel/vsYLabel/vsZLabel、 無ければ encX/encY/encZ 列名)。 + tsTitle = mkFontTS (Just spec) pal AxisLabelF AnchorMiddle 0 + firstLay = case vsLayers spec of (l0 : _) -> Just l0; [] -> Nothing + -- ★ Phase 64 A13: 無名 inline 列の sentinel ("<inline-num>"/"<inline-txt>") は + -- 頂点タイトルに出さず Nothing に潰す (= 他の軸タイトル経路 Layout.hs/Special.hs/ + -- Layer.hs と同じ規律。 A12 で潰し漏れていた)。 ラベルは vsX/Y/ZLabel か名前付き列で。 + titleFor lbl enc = case getLast lbl of + Just t -> Just t + Nothing -> case fmap colRefName (firstLay >>= getLast . enc) of + Just nm | nm /= "<inline-num>" && nm /= "<inline-txt>" -> Just nm + _ -> Nothing + vertexTitle abc mtxt = case mtxt of + Nothing -> [] + Just txt -> let (lx, ly) = outward (ternaryPoint layout abc) 22 + in [ PText (Point lx (ly + 3)) txt tsTitle ] + titles = vertexTitle (1, 0, 0) (titleFor (vsXLabel spec) lyEncX) + <> vertexTitle (0, 1, 0) (titleFor (vsYLabel spec) lyEncY) + <> vertexTitle (0, 0, 1) (titleFor (vsZLabel spec) lyEncZ) + in if tpShowGrid pal + then gridA <> gridB <> gridC <> edges <> tickA <> tickB <> tickC <> titles + else edges <> tickA <> tickB <> tickC <> titles +-- ★ Phase 64 A2: wedgeSegments (Phase 11 A7-c の扇形 path) は投影層 (Layout.hs) へ +-- 移設 (projectBar が共有するため)。 + fromMaybe :: a -> Maybe a -> a fromMaybe d Nothing = d fromMaybe _ (Just v) = v @@ -476,40 +736,66 @@ -- 軸 / tick -- --------------------------------------------------------------------------- +-- | [日本語]: plot 全面背景。 tpShowBackground が False なら塗らない (= 透過。 +-- SVG/PDF は背景 rect 自体が消えて自然に透過、 raster は backend が init 色を切り替える)。 +-- [English]: The plot's full background. When tpShowBackground is False, +-- nothing is painted (transparent): for SVG/PDF the background rect simply +-- disappears, naturally leaving it transparent; for raster output the +-- backend switches its init color instead. 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 ] +background layout pal + | not (tpShowBackground pal) = [] + | otherwise = + 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 では何も描かない (= 従来の白背景挙動を温存)。 +-- | [日本語]: panel (plotArea) 背景の塗り経路。 theme_grey / ブランドは灰/暗の +-- panel 矩形を塗り、 その上に白/淡色 grid を重ねる (ggplot theme_grey 構造)。 +-- tpShowPanel が False の preset では何も描かない (= 従来の白背景挙動を温存)。 +-- [English]: The paint path for the panel (plot area) background. +-- theme_grey and brand themes paint a grey/dark panel rectangle and layer +-- white/pale grid lines on top of it (the ggplot theme_grey structure). +-- Presets with tpShowPanel False draw nothing, preserving the legacy white +-- background behavior. 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 +-- | [日本語]: axisFrame: panel の 4 辺枠。 tpShowBorder が False の theme (grey / ブランド) では +-- 枠を描かない (= ggplot theme_grey は border なし)。 +-- axisLine (下辺=x軸 + 左辺=y軸 の 2 本) は theme_classic 用に tpShowAxisLine で出す。 +-- border と axisLine は排他ではないが、 classic は border なし + axisLine ありの組合せ。 +-- [English]: axisFrame: the panel's 4-sided border. Themes with +-- tpShowBorder False (grey / brand) draw no border (ggplot theme_grey has +-- none). The axisLine (2 lines: bottom = x axis, left = y axis) is emitted +-- via tpShowAxisLine for theme_classic. border and axisLine are not +-- mutually exclusive, but classic uses the combination of no border plus an +-- axisLine. +-- ★ Phase 68: axisW = axis.line / panel.border の実効線幅 (呼び元が +-- 'effectiveAxisLineWidth' で解決。 theme override 非対応の呼び元 (MCMC) は現状値 1.0)。 +axisFrame :: Double -> Layout -> ThemePalette -> [Primitive] +axisFrame axisW layout pal = border ++ axisLine where a = lpPlotArea layout border | tpShowBorder pal = - [ PRect a (FillStyle (tpBackground pal) 0) (Just (StrokeStyle (tpAxis pal) 1.0)) ] + [ PRect a (FillStyle (tpBackground pal) 0) (Just (StrokeStyle (tpAxis pal) axisW)) ] | 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) ] + [ PLine (Point (rX a) (rY a + rH a)) (Point (rX a + rW a) (rY a + rH a)) (solid (tpAxis pal) axisW) + , PLine (Point (rX a) (rY a)) (Point (rX a) (rY a + rH a)) (solid (tpAxis pal) axisW) ] | 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 を省略。 +-- | [日本語]: 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 を省略。 +-- [English]: TODO-3 (2026-05-29): supports axRotate / axShowTicks (ported +-- from PS Render.tickMarksWithShow). TODO-10 (2026-05-29): threads mSpec +-- through to apply the tick font (spec.tickFont). rotX/rotY are in degrees +-- (0 = horizontal, 90 = vertical). Axes with showX/showY False omit both +-- the tick line and the label. tickMarks :: Maybe VisualSpec -> Layout -> ThemePalette -> Maybe AxisFormat -> Maybe AxisFormat -> Double -> Double -> Bool -> Bool -> [Primitive] @@ -529,11 +815,24 @@ -- 算出 (design §D-3)。 tickSize は実フォント値、 gap は sc 倍してマージン予約に整合。 sc = lpMarginScale layout tickSize = tsSize ts - tkLen = ggTickLen * sc - tkGap = (ggTickLen + ggAxTextMar) * sc + -- ★ Phase 63 A4: tick 長・向きは theme 実効値 (Layout の margin 予約と単一情報源)。 + -- outLen = panel 外向き分 / inLen = panel 内向き分。 ラベル offset (tkGap) は + -- 外向き分にのみ追従 (TickIn はラベルが軸に寄る)。 既定 (TickOut・ggTickLen) + -- では従来式 tkLen = ggTickLen*sc / tkGap = (ggTickLen+ggAxTextMar)*sc と同値。 + tkLen = maybe ggTickLen effectiveTickLength mSpec * sc + tickDir = maybe TickOut effectiveTickDir mSpec + outLen = case tickDir of TickIn -> 0; _ -> tkLen + inLen = case tickDir of TickOut -> 0; _ -> tkLen + -- ★ Phase 63 A13: axis.text margin も base 派生の実効値 (spec 不在時は従来定数)。 + tkGap = outLen + maybe ggAxTextMar effectiveAxTextMar mSpec * sc -- Phase 32 (re-apply): 目盛線 (tick mark) は tpTickLineColor (ggplot=grey20)。 -- 軸線/枠 (axisFrame) は tpAxis のままで別物。 tickStyle = solid (tpTickLineColor pal) 1.0 + -- ★ Phase 63 A19: axis.text (目盛ラベル文字) の表示。 Layout の margin 予約 + -- (effectiveShowAxisText) と単一情報源。 False は文字のみ落とし tick 線は + -- 長さ (effectiveTickLength) と独立に残す。 mSpec 無し経路は従来どおり表示。 + showText = maybe True effectiveShowAxisText mSpec + textPrims ps = if showText then ps else [] xCats = lpXCategoryLabels layout yCats = lpYCategoryLabels layout -- ★ Phase 11 A4-d: 明示ラベル override。 lpXTicks と 1:1 対応 (computeLayout で censor @@ -571,18 +870,19 @@ xMark v = let px = scaleApply sx v yb = rY a + rH a - in [ PLine (Point px yb) (Point px (yb + tkLen)) tickStyle + in [ PLine (Point px (yb - inLen)) (Point px (yb + outLen)) tickStyle ] -- Phase 8 C (small-viewport text fix): フォント由来オフセット (tickSize*k) は -- 等倍 (tkGap = sc*間隔 のみ scale)。 旧 *sc で小パネル時に数値が軸に被っていた。 - , if rotX == 0 + <> textPrims + [ 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 ] + in [ PLine (Point (xl + inLen) py) (Point (xl - outLen) py) tickStyle ] + <> textPrims [ 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 @@ -591,13 +891,13 @@ 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 ] + in [ PLine (Point (xl + inLen) py) (Point (xl - outLen) py) tickStyle ] + <> textPrims [ 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 ] + in [ PLine (Point px (yb - inLen)) (Point px (yb + outLen)) tickStyle ] + <> textPrims [ PText (Point px (yb + tkGap + tickSize * 0.8)) (yLabel v) ts ] (xMarkF, yMarkF) = case coord of CoordFlip -> (xMarkFlip, yMarkFlip) _ -> (xMark, yMark) @@ -606,10 +906,13 @@ 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 文字列を適用。 +-- | [日本語]: AxisFormat に応じて Double を表示文字列に。 Nothing = auto。 +-- 'AxisTimeFmt' は Double を unix epoch (= seconds since 1970 UTC) と +-- 解釈し、 Data.Time.formatTime で format 文字列を適用。 +-- [English]: Formats a Double as a display string according to the +-- 'AxisFormat'. 'Nothing' means auto. 'AxisTimeFmt' interprets the Double +-- as a Unix epoch (seconds since 1970 UTC) and applies the format string +-- via Data.Time.formatTime. formatTick :: Maybe AxisFormat -> Double -> Text formatTick fmt v = case fmt of Nothing -> numToText v @@ -641,8 +944,12 @@ boxTop = rY a - lpMarginTop layout boxBottom = rY a + rH a + lpMarginBottom layout boxLeft = rX a - lpMarginLeft layout + -- ★ Phase 63 A5: 外周余白は theme 実効値 (Layout の margin 予約と単一情報源)。 + -- 既定 (各辺 half_line) では従来式と同値。 + -- ★ Phase 63 A13: title→subtitle gap も half_line = base/2 派生へ。 + pm = effectivePlotMargin spec hasTitle = case getLast (vsTitle spec) of Just _ -> True; _ -> False - titleBaseY = boxTop + sc * (ggHalfLine + titleSize * 0.8) + titleBaseY = boxTop + sc * (marTop pm + titleSize * 0.8) -- Phase 32 (re-apply): plot.title の水平揃え。 hjust=0 (ggplot theme_grey) は -- panel 左端にアンカー開始、 それ以外 (既定 0.5) は従来通り中央。 (titleX, tsTitle') = if tpTitleHjust pal <= 0.0 @@ -651,28 +958,40 @@ titleP = case getLast (vsTitle spec) of Just t -> [ PText (Point titleX titleBaseY) t tsTitle' ] Nothing -> [] - -- x 軸タイトル = 最下要素。 baseline = 下 plot.margin の上 (= boxBottom - margin - descent)。 + -- ★ Phase 63 A15: 軸タイトルは「軸 text 直下 + axis.title margin」 基準 (= ggplot + -- 方式)。 offset は Layout の margin 予約と同じ stack (lpXTitleOff/lpYTitleOff = + -- 単一情報源)。 旧 boxBottom/boxLeft 最外端 pin は LegendBottom/caption 時に + -- タイトルが凡例の外側 (最下端) へ出ていた (J2/J5 root)。 + -- ★ Phase 63 A19: axis.title の表示 (ThemeVoid 既定 False = element_blank)。 + -- Layout の margin 予約 (hasXLabel/hasYLabel gating) と単一情報源。 + showAxTitle = effectiveShowAxisTitle spec + -- ★ Phase 64 A12: ternary は 3 頂点の軸タイトルを ternaryGrid が描くので、 + -- 直交 (bottom/left) の x/y タイトルは抑止して二重描画を防ぐ。 + isTern = isTernary (coordOf spec) + -- x 軸タイトル: baseline = panel 下端 + offset + ascent。 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。 + Just t | showAxTitle && not isTern -> [ PText (Point cx (rY a + rH a + lpXTitleOff layout + labelSize * 0.8)) t tsLabel ] + _ -> [] + -- y 軸タイトル (rot 90 CCW = ascent が -x 側): baseline = panel 左端 - offset - descent。 yLP = case getLast (vsYLabel spec) of - Just t -> [ PText (Point (boxLeft + sc * (ggHalfLine + labelSize * 0.7)) cy) t tsLabelV ] - Nothing -> [] + Just t | showAxTitle && not isTern -> [ PText (Point (rX a - lpYTitleOff layout - labelSize * 0.2) cy) t tsLabelV ] + _ -> [] -- ★ 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 + -- ★ Phase 63 A14: 固定 11/9/13 を base 派生 (×1 / ×0.8 / ×1.2 = ggplot + -- theme_grey 倍率) へ。 Layout の labs 予約と単一情報源。 + subSize = effectiveSubtitleSize spec + capSize = effectiveCaptionSize spec + tagSize = effectiveTagSize spec 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)) + subBaseY = (if hasTitle then titleBaseY + sc * effectiveHalfLine spec + subSize * 0.8 + else boxTop + sc * (marTop pm + subSize * 0.8)) -- plot.title と同じ hjust 規則: hjust=0 (theme_grey) は panel 左端アンカー開始。 (subX, tsSub') = if tpTitleHjust pal <= 0.0 then (rX a, tsSub { tsAnchor = AnchorStart }) @@ -681,44 +1000,104 @@ 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 ] + Just t -> [ PText (Point boxRight (boxBottom - sc * marBottom pm)) t tsCap ] Nothing -> [] tagP = case getLast (vsTag spec) of - Just t -> [ PText (Point boxLeft (boxTop + sc * ggHalfLine + tagSize * 0.8)) t tsTag ] + Just t -> [ PText (Point boxLeft (boxTop + sc * marTop pm + 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 +-- | [日本語]: lpYScaleRight が Just のとき plotArea 右端に Y 軸線 + tick を描画 +-- (= PS renderRightYAxis と同方式)。 Nothing なら何も描かない。 +-- [English]: When lpYScaleRight is Just, draws a Y axis line plus ticks at +-- the right edge of the plot area (same approach as PS renderRightYAxis). +-- Draws nothing when Nothing. +-- ★ Phase 68: axisW = 軸線 (右 Y 軸) の実効線幅 (呼び元が 'effectiveAxisLineWidth' +-- で解決)。 tick mark は scope 外 = 主軸 tick と同じ 1.0 固定 (axis.line と axis.ticks +-- を分離して統一挙動にする)。 +renderRightYAxis :: Double -> Layout -> ThemePalette -> Maybe AxisFormat -> [Primitive] +renderRightYAxis axisW 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 + axisStyle = solid (tpAxis pal) axisW -- 軸線 = toAxisLineWidth + tickStyle = solid (tpAxis pal) 1.0 -- tick mark = scope 外 (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 + in [ PLine (Point xR py) (Point (xR + 5) py) tickStyle , 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)。 +-- | [日本語]: データ空間 (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)。 +-- [English]: A thin wrapper that maps data space (dx, dy) to a pixel-space +-- 'Point' according to the coordinate system. projectXY returns a raw +-- tuple (Layout cannot depend on Render's Point), so mark renderers wrap it +-- into a Point via this helper. Given coord = lpCoord layout, the Cartesian +-- case is bit-identical to +-- `Point (scaleApply (lpXScale l) dx) (scaleApply (lpYScale l) dy)` (the +-- same as the previous `Point (sx x) (sy y)`, so it produces zero 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/ +-- | [日本語]: ★ Phase 64 A13: 三角座標 (ternary) の geom 前処理。 各行の (x,y) を +-- encZ 列と合わせて 'normalizeTernary' で成分和 1 の fraction (a',b') へ写す。 +-- __第 3 成分 c は @projectXY CoordTernary@ が @c = 1-a'-b'@ で補完する__ので、 +-- 正規化後の (a',b') をそのまま既存の 'projectXY' / 'projectPoint' に渡せば +-- 'ternaryPoint' と一致する (geom 側の投影呼出は無改造で 3 列を正しく使える)。 +-- 退化行 (負値 / 合計≤0、 および NaN) は @(NaN, NaN)@ にして既存の NA 除外 +-- (点 skip / 線の詰め) に乗せる (= 色/サイズ vector との行整列を保ったまま脱落)。 +-- encZ 未指定時は @c = 1-x-y@ で補完 (A12 の 2 引数挙動と互換)。 +-- __非 ternary 座標系では (xs, ys) を素通し (byte 不変)__。 +-- [English]: Phase 64 A13. Ternary geom preprocessing: normalizes each row's +-- (x, y) together with the encZ column into fractions summing to 1 via +-- 'normalizeTernary', returning (a', b'). Since @projectXY CoordTernary@ fills +-- the third component as @c = 1 - a' - b'@, passing the normalized (a', b') +-- straight to the existing 'projectXY' / 'projectPoint' reproduces +-- 'ternaryPoint' — so a geom's projection call sites need no change to use the +-- three columns correctly. Degenerate rows (negative component / non-positive +-- sum / NaN) become @(NaN, NaN)@ so the existing NA handling (point skip / +-- line contraction) drops them while preserving row alignment with the +-- color/size vectors. A missing encZ falls back to @c = 1 - x - y@ (compatible +-- with A12's two-argument behavior). For non-ternary coords, passes (xs, ys) +-- through unchanged (byte-identical). +ternaryRemap :: Resolver -> Layout -> Layer + -> V.Vector Double -> V.Vector Double + -> (V.Vector Double, V.Vector Double) +ternaryRemap r layout ly xs ys + | not (isTernary (lpCoord layout)) = (xs, ys) + | otherwise = + let zs = vecOrFull (lyEncZ ly) r + n = min (V.length xs) (V.length ys) + nan = 0 / 0 :: Double + remap i = + let x = xs V.! i + y = ys V.! i + z = if i < V.length zs then zs V.! i else 1 - x - y + in case normalizeTernary (x, y, z) of + Just (a, b, _) -> (a, b) + Nothing -> (nan, nan) + pairs = V.generate n remap + in (V.map fst pairs, V.map snd pairs) + +-- | [日本語]: 極座標を解さない standalone renderer (ess/autocorr/forest/funnel/ -- box/violin/strip/swarm/waterfall = 直交/flip 専用 2-way 分岐) 用に coord を -- {Cartesian, Flip} に正規化する (= polar はそれらの mark では Cartesian 扱い)。 -- polar は座標系として点/線/扇形 bar に意味があり、 これらの統計 mark には適用しない。 +-- [English]: Normalizes coord to {Cartesian, Flip} for standalone renderers +-- that don't understand polar coordinates (ess/autocorr/forest/funnel/ +-- box/violin/strip/swarm/waterfall, which only branch two ways between +-- Cartesian and Flip); polar is treated as Cartesian for these marks. The +-- polar coordinate system is meaningful for points/lines/sector bars, but +-- is not applicable to these statistical marks. flipOnly :: Coord -> Coord flipOnly CoordFlip = CoordFlip flipOnly _ = CoordCartesian @@ -735,21 +1114,29 @@ 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 用)。 +-- | [日本語]: categorical 列を群キー列 [Text] に解決 (linetypeBy 用)。 +-- [English]: Resolves a categorical column into a list of group keys +-- [Text] (used by 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)。 +-- | [日本語]: キー列と値列を zip し、 キー初出順を保ったまま群ごとにまとめる (= group split)。 +-- [English]: Zips a key column with a value column and groups values by +-- key, preserving the key's first-occurrence order (a 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 列があればソート後に連結。 +-- | [日本語]: scatter 上に「点を結ぶ線」 を生成。 group 列があれば +-- group 内のみで連結、 order 列があればソート後に連結。 +-- [English]: Generates "lines connecting the points" on top of a scatter. +-- When a group column is present, points are connected only within their +-- group; when an order column is present, points are connected after +-- sorting by it. renderConnect :: Resolver -> Layout -> ThemePalette -> Layer -> ConnectSpec -> V.Vector Double -> V.Vector Double -> Int -> [Primitive] renderConnect r layout pal ly cs xs ys n = @@ -789,11 +1176,19 @@ | (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 一貫のため受ける)。 +-- | [日本語]: plot area 内に参照線 1 本を描画。 +-- domain (= scale の dLo/dHi) を直接見て 2 端点を計算。 +-- [English]: Draws a single reference line inside the plot area. The two +-- endpoints are computed by reading the domain (the scale's dLo/dHi) +-- directly. +-- | [日本語]: ★ 参照線も 'resolvePosX'/'resolvePosY' (UCtx) 経由に統一。 +-- 値は PNative、panel 端は PNpc 0/1 で表す (出力は旧実装と bit 一致)。dpi は +-- PAbs Px 用 (参照線は使わないが UCtx 一貫のため受ける)。 +-- [English]: Reference lines are also unified to go through +-- 'resolvePosX'/'resolvePosY' (UCtx). Values use PNative and panel edges +-- use PNpc 0/1 (the output is bit-identical to the previous +-- implementation). dpi is for PAbs Px (reference lines don't use it, but it +-- is accepted for consistency with UCtx). renderRefLine :: Double -> Layout -> ThemePalette -> ReferenceLine -> [Primitive] renderRefLine dpi layout pal rl = let uc = UCtx dpi (lpPlotArea layout) (lpXScale layout) (lpYScale layout) @@ -826,29 +1221,47 @@ -- 共通 helper -- --------------------------------------------------------------------------- --- | 列を数値 Vector に解決。 **NA (NaN) を落とす** (nullable 列対応・ggplot na.rm +-- | [日本語]: 列を数値 Vector に解決。 __NA (NaN) を落とす__ (nullable 列対応・ggplot na.rm -- 相当)。 単一列 geom (histogram/freqpoly/density/box/ecdf 等) はこれで欠損を内部処理。 -- 非 NULL 列 (NaN を含まない) には no-op なので従来挙動と同一。 +-- [English]: Resolves a column to a numeric Vector, __dropping NA (NaN)__ +-- (supports nullable columns; equivalent to ggplot's na.rm). Single-column +-- geoms (histogram/freqpoly/density/box/ecdf, etc.) handle missing values +-- internally this way. It is a no-op on non-null columns (containing no +-- NaN), so behavior is unchanged from before. 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 がズレるため)。 +-- | [日本語]: 'vecOr' の NaN 保持版 (= 長さを保つ)。 +-- __多列 geom (scatter/line) が行整列を保って欠損対を落とす__ために使う +-- (per-column drop だと x/y がズレるため)。 +-- [English]: The NaN-preserving variant of 'vecOr' (keeps the length +-- unchanged). Used so that +-- __multi-column geoms (scatter/line) can drop missing pairs while keeping x/y row-aligned__ +-- (dropping per-column would throw x/y out of sync). 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 (= 色覚多様性配慮)。 +-- | [日本語]: Okabe-Ito 8 色 categorical palette (= 色覚多様性配慮)。 +-- [English]: The 8-color Okabe-Ito categorical palette (chosen for color- +-- vision-deficiency accessibility). 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 色 +-- | [日本語]: layer の color encoding を point 数 n の Vector に展開。 +-- * 'ColorStatic' → 全 point 同色 +-- * 'ColorByCol' → 列 (txt or num) を distinct 値ごとに palette index 割当 +-- * encoding 無し → theme の default 色 +-- [English]: Expands a layer's color encoding into a Vector of n colors, +-- one per point. +-- * 'ColorStatic' gives every point the same color. +-- * 'ColorByCol' assigns a palette index per distinct value of the +-- column (text or numeric). +-- * No encoding falls back to the theme's default color. colorVector :: Resolver -> Layout -> ThemePalette -> Layer -> Int -> V.Vector Text colorVector r layout pal ly n = case getLast (lyColor ly) of @@ -899,14 +1312,19 @@ in V.fromList filled Nothing -> V.replicate n (tpDefault pal) --- | Viridis 風 5-stop gradient (= 簡易版、 perceptually uniform に近い)。 --- t in [0, 1]。 +-- | [日本語]: Viridis 風 5-stop gradient (= 簡易版、 perceptually uniform に近い)。 +-- t in [0, 1]。 +-- [English]: A Viridis-like 5-stop gradient (a simplified version, close to +-- perceptually uniform). t is in [0, 1]. viridis :: Double -> Text viridis = continuousColor ["#440154", "#3B528B", "#21918C", "#5EC962", "#FDE725"] --- | P17: 任意 hex 配列の N-stop palette を t ∈ [0,1] で線形補間。 +-- | [日本語]: P17: 任意 hex 配列の N-stop palette を t ∈ [0,1] で線形補間。 -- layout.lpContinuousPalette を渡せば spec 指定の sequential が反映される。 +-- [English]: P17: linearly interpolates an arbitrary N-stop hex-color +-- palette at t ∈ [0,1]. Passing layout.lpContinuousPalette applies the +-- spec-specified sequential palette. continuousColor :: [Text] -> Double -> Text continuousColor palArr t = let n = length palArr @@ -968,23 +1386,31 @@ -- 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 で常に同値。 +-- | [日本語]: P14 PS port: deterministic pseudo-random ∈ [0,1) from Int seed。 +-- sin-hash トリック (= classic JS shadertoy)。 同 seed で常に同値。 +-- [English]: P14 PS port: a deterministic pseudo-random value in [0,1) from +-- an Int seed, using the classic sin-hash trick (as seen in JS shadertoy +-- code). The same seed always yields the same value. 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。 +-- | [日本語]: C-6 PS port: shape を Primitive (PCircle or PPath) に変換。 +-- MShCircle は PCircle (= hover label 付き)、 他は PPath。 +-- [English]: C-6 PS port: converts a shape into a Primitive (PCircle or +-- PPath). MShCircle becomes a PCircle (with a hover label); every other +-- shape becomes a 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 近似含む)。 +-- | [日本語]: C-6 PS port: shape 別 path 構築 (= PathSegment 列、 bezier 近似含む)。 +-- [English]: C-6 PS port: builds a per-shape path (a list of PathSegment, +-- including Bezier approximations). shapePath :: MarkShape -> Point -> Double -> [PathSegment] shapePath sh (Point cx cy) r = case sh of MShCircle -> [] @@ -1117,17 +1543,27 @@ , 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) で**同一の装飾規則**を使うための +-- | [日本語]: ggplot 同型のマーカー塗り (色 + alpha)。 hollow (中抜き) は透明・輪郭のみ。 +-- plot 点 (Render.Basic) と凡例キー (Render.Layer) で__同一の装飾規則__を使うための -- 単一ソース (= 「凡例マークは plot と揃える」 規律)。 +-- [English]: A ggplot-equivalent marker fill (color + alpha). Hollow +-- markers are transparent, outline only. This is the single source that +-- lets plotted points (Render.Basic) and legend keys (Render.Layer) share +-- __the same styling rule__ (the discipline that "legend marks match the +-- 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)。 +-- | [日本語]: ggplot 同型のマーカー縁 (stroke)。 既定は__縁なし__ (= 塗り点 shape 19)。 -- hollow → 点色で輪郭のみ (幅 'lyStroke'|1)。 'lyEdge' 指定時だけ縁を出す -- (色 'lyEdgeColor'|点色、 幅 'lyEdgeWidth'|1)。 plot/凡例で共通。 +-- [English]: A ggplot-equivalent marker edge (stroke). The default has +-- __no edge__ (a filled point, shape 19). hollow draws only an outline in the +-- point's color (width 'lyStroke' or 1). An edge is drawn only when +-- 'lyEdge' is set (color 'lyEdgeColor' or the point color, width +-- 'lyEdgeWidth' or 1). Shared by both the plot and the legend. markerStrokeFor :: Layer -> Text -> Maybe StrokeStyle markerStrokeFor ly c | getLast (lyHollow ly) == Just True = Just (StrokeStyle c (doubleOr (lyStroke ly) 1.0)) @@ -1135,10 +1571,17 @@ 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 の色割当と同思想)。 +-- | [日本語]: 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 の色割当と同思想)。 +-- [English]: C-6 PS port: gets the shape for the i-th data point in +-- scatter / strip and similar marks. Resolves the lyShapeBy column value +-- from the data and looks up shape by category. An explicit lyShapeMap +-- takes priority when present; otherwise 'shapePalette' is cycled by the +-- category's first-occurrence index (the automatic shape scale for ggplot +-- @aes(shape=factor(g))@, following the same idea as colorVector's color +-- assignment). pointShapeAt :: Layer -> Resolver -> Int -> MarkShape pointShapeAt ly r i = case getLast (lyShape ly) of Just s -> s -- ★ Phase 30 A3: 固定 shape 最優先 @@ -1157,22 +1600,37 @@ Just k -> shapePalette !! (k `mod` length shapePalette) Nothing -> MShCircle --- | 自動 shape scale の巡回パレット (ggplot 風: 丸→三角→四角→…)。 +-- | [日本語]: 自動 shape scale の巡回パレット (ggplot 風: 丸→三角→四角→…)。 +-- [English]: The cyclic palette for the automatic shape scale (ggplot +-- style: circle to triangle to square and onward). 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 を返す。 +-- | [日本語]: TODO-3e (2026-05-29): lySizeBy → 各点の半径 (px) Vector。 +-- lySizeBy 指定の列値 (= 要 numeric) を min..max → [szLo, szHi] px に線形 map。 +-- 指定無しなら lySize (or default 3.0) を全点に適用。 +-- [English]: TODO-3e (2026-05-29): lySizeBy maps to a per-point radius (px) +-- Vector. The column value given by lySizeBy (must be numeric) is linearly +-- mapped from its min..max range to [szLo, szHi] px. Without lySizeBy, +-- lySize (or the default 3.0) is applied to every point. +-- | [日本語]: 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)。 +-- ★ @size@ 意味論を「マーカー外接円の__直径__ (pt)」に統一。 +-- 'lySize' は直径として解釈し、shapeToPrim が要求する半径 (= 直径/2) を返す。 +-- 既定直径は 'defaultMarkerDiameter' (= ggplot 実測 1.65mm)。 +-- sizeBy (連続 size mapping) の範囲 'lpSizeRange' も__直径__範囲 (= scale_size、 +-- 既定 (6,20)pt → 半径 3..10pt)。 +-- [English]: Returns a Vector of per-point marker __radii__ (pt). +-- +-- The "size" semantics is unified as "the __diameter__ (pt) of the +-- marker's bounding circle". 'lySize' is interpreted as a diameter, and +-- this function returns the radius (diameter / 2) that shapeToPrim +-- requires. The default diameter is 'defaultMarkerDiameter' (ggplot's +-- measured 1.65mm). The range for sizeBy (continuous size mapping), +-- 'lpSizeRange', is likewise a __diameter__ range (scale_size, default +-- (6,20)pt, giving radius 3..10pt). sizeVector :: Resolver -> Layout -> Layer -> Int -> V.Vector Double sizeVector r layout ly n = let baseDiam = doubleOr (lySize ly) defaultMarkerDiameter -- 直径 (pt) @@ -1192,10 +1650,15 @@ 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 既定値) --- を全点に適用。 +-- | [日本語]: lyAlphaBy → 各点の alpha (不透明度) Vector。 +-- lyAlphaBy 指定の列値 (= 要 numeric) を min..max → alpha [0.1, 1.0] に線形 map +-- (= ggplot scale_alpha 既定 range)。 指定無しなら baseAlpha (固定 lyAlpha or 既定値) +-- を全点に適用。 +-- [English]: lyAlphaBy maps to a per-point alpha (opacity) Vector. The +-- column value given by lyAlphaBy (must be numeric) is linearly mapped +-- from its min..max range to alpha [0.1, 1.0] (ggplot's default +-- scale_alpha range). Without lyAlphaBy, baseAlpha (the fixed lyAlpha, or +-- the default) is applied to every point. alphaVector :: Resolver -> Layer -> Double -> Int -> V.Vector Double alphaVector r ly baseAlpha n = case getLast (lyAlphaBy ly) of @@ -1217,7 +1680,9 @@ -- Phase 6+ case C-2 ~ C-5: 基本 / 分布 chart の Render -- =========================================================================== --- | カテゴリ名 (= ColTxt) を Layer から取得。 categorical bar / pie 等で labels に。 +-- | [日本語]: カテゴリ名 (= ColTxt) を Layer から取得。 categorical bar / pie 等で labels に。 +-- [English]: Gets category names (a ColTxt column) from a Layer, used as +-- labels for categorical bar / pie and similar marks. catLabelsOf :: Resolver -> Layer -> [Text] catLabelsOf r ly = case getLast (lyEncX ly) of Just cr -> case resolveCol r cr of @@ -1229,9 +1694,13 @@ -- 分布 chart (group × value) -- =========================================================================== --- | group 列 (lyEncX ?? colorBy 列) と value 列 (lyEncY) を resolve。 group は --- categorical (= ColTxt) が普通、 ColNum でも対応 (= ColNum を distinct 値で group)。 --- 戻り値: [(group_label, [value])] +-- | [日本語]: group 列 (lyEncX ?? colorBy 列) と value 列 (lyEncY) を resolve。 group は +-- categorical (= ColTxt) が普通、 ColNum でも対応 (= ColNum を distinct 値で group)。 +-- 戻り値: [(group_label, [value])] +-- [English]: Resolves the group column (lyEncX or the colorBy column) and +-- the value column (lyEncY). The group column is usually categorical +-- (ColTxt), but ColNum is also supported (ColNum is grouped by its +-- distinct values). Returns [(group_label, [value])]. groupedValues :: Resolver -> Layer -> [(Text, [Double])] groupedValues r ly = case distGroupRef ly of Just crX -> case resolveCol r crX of @@ -1252,12 +1721,21 @@ Nothing -> [] Nothing -> [] --- | Phase 28: 'groupedValues' を x カテゴリ軸順 ('lpXCategoryLabels') に整列する。 +-- | [日本語]: 'groupedValues' を x カテゴリ軸順 ('lpXCategoryLabels') に整列する。 -- box / violin / strip / swarm / ridge は群を @zip [0..]@ で x 位置に並べるが、 -- x 軸ラベルは 'lpXCategoryLabels' (既定アルファベット順 / discrete-limits override) -- から来る。 両者の順を一致させないと「箱は Gentoo だがラベルは Chinstrap」 のような -- ズレが出る (= categorical 既定をアルファベット順にした際の回帰)。 軸ラベルが無い -- (数値 x 等) ときは 'groupedValues' の順をそのまま返す。 +-- [English]: Sorts 'groupedValues' into x-category axis order +-- ('lpXCategoryLabels'). box / violin / strip / swarm / ridge lay out +-- groups at x positions via @zip [0..]@, while the x-axis labels come from +-- 'lpXCategoryLabels' (default alphabetical order, or a discrete-limits +-- override). If the two orders don't match, a mismatch results — for +-- example, a box drawn for Gentoo but labeled Chinstrap (a regression from +-- defaulting categorical order to alphabetical). When there is no axis +-- label (for example, a numeric x), 'groupedValues' order is returned +-- as-is. groupedValuesOrdered :: Layout -> Resolver -> Layer -> [(Text, [Double])] groupedValuesOrdered layout r ly = let gv = groupedValues r ly @@ -1265,10 +1743,16 @@ 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) の群リスト。 +-- | [日本語]: distribution mark (violin/strip/swarm/raincloud) の群リスト。 -- 群列 ('distGroupRef' = encX ?? colorBy) があれば 'groupedValuesOrdered'、 無ければ -- encY 全体を単一群 ("") にする (= boxplot の単一群挙動と統一)。 これにより 1 引数 -- @violin "v"@ (群なし) でも空にならず 1 つ描ける。 +-- [English]: The group list for distribution marks (violin/strip/swarm/ +-- raincloud). When a group column ('distGroupRef' = encX or colorBy) is +-- present, uses 'groupedValuesOrdered'; otherwise treats the whole encY as +-- a single group ("") — unifying it with boxplot's single-group behavior. +-- This means even a single-argument @violin "v"@ (no group) draws one +-- group instead of nothing. distGroupsOrdered :: Layout -> Resolver -> Layer -> [(Text, [Double])] distGroupsOrdered layout r ly = case distGroupRef ly of Just _ -> groupedValuesOrdered layout r ly @@ -1282,12 +1766,22 @@ -- カテゴリ内に色サブグループを横並びにする (= ggplot @position_dodge@)。 -- --------------------------------------------------------------------------- --- | dodge cell 化: (位置列, 色列) について各 (位置 index, 色 index) の値リストを作る。 +-- | [日本語]: dodge cell 化: (位置列, 色列) について各 (位置 index, 色 index) の値リストを作る。 -- 戻り値: -- positions = 位置カテゴリ ('lpXCategoryLabels' = 既定アルファベット順) -- colorCats = 色カテゴリ ('lyColorCats' 優先、 無ければ色列の出現順 uniq) -- cells = @[(posIx, colIx, [value])]@ (空セルは除外) -- 値は encY、 NaN (= Maybe 列の Nothing) は行整列を保ったまま除外。 +-- [English]: Builds dodge cells: given a (position column, color column) +-- pair, builds a value list for each (position index, color index) pair. +-- Returns: +-- positions = the position categories ('lpXCategoryLabels', default +-- alphabetical order) +-- colorCats = the color categories ('lyColorCats' takes priority, +-- otherwise the color column's unique values in appearance order) +-- cells = @[(posIx, colIx, [value])]@ (empty cells excluded) +-- Values come from encY; NaN (a Nothing in a nullable column) is excluded +-- while preserving row alignment. dodgeCells :: Layout -> Resolver -> Layer -> ([Text], [Text], [(Int, Int, [Double])]) dodgeCells layout r ly = case distDodgeRef ly of Nothing -> ([], [], []) @@ -1314,8 +1808,12 @@ , let vs = cellAt pix cix, not (null vs) ] in (positions, colorCats, cells) --- | dodge sub-cell の data 空間中心 (= bar 'PosDodge' と同式)。 位置カテゴリ @pix@ の +-- | [日本語]: dodge sub-cell の data 空間中心 (= bar 'PosDodge' と同式)。 位置カテゴリ @pix@ の -- slot (幅 0.9) を色数 @nColor@ で等分し、 @cix@ 番目の中心を data 座標で返す。 +-- [English]: The data-space center of a dodge sub-cell (using the same +-- formula as bar's 'PosDodge'). The position category @pix@'s slot (width +-- 0.9) is divided evenly by the number of colors @nColor@, and the center +-- of the @cix@-th sub-cell is returned in data coordinates. dodgeCenterD :: Int -> Int -> Int -> Double dodgeCenterD pix cix nColor = fromIntegral pix - 0.45 @@ -1327,16 +1825,25 @@ -- stat_density / stat_boxplot 相当を 1 箇所に集約 (= 各 geom が再利用)。 -- --------------------------------------------------------------------------- --- | Gaussian KDE (Silverman bandwidth) を nGrid 点で評価し [(y, density)] を返す。 --- 戻り値は y 昇順。 violin/raincloud/density/ridge が共有。 grid は vals の min..max。 +-- | [日本語]: Gaussian KDE (Silverman bandwidth) を nGrid 点で評価し [(y, density)] を返す。 +-- 戻り値は y 昇順。 violin/raincloud/density/ridge が共有。 grid は vals の min..max。 +-- [English]: Evaluates a Gaussian KDE (Silverman bandwidth) at nGrid points +-- and returns [(y, density)]. The result is in ascending y order. Shared by +-- violin/raincloud/density/ridge. The grid spans 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 から。 +-- | [日本語]: grid 範囲を明示する版。 ridge は全群共通の値域 [gLo, gHi] で各群を +-- 評価し、 群データ端の外でも KDE 裾を滑らかに減衰させる (= 各群自前 min/max だと裾が +-- 打ち切られて横線にならない、 PS renderRidgeLayer と同方式)。 bw は群自身の vals から。 +-- [English]: A variant that takes an explicit grid range. ridge evaluates +-- every group over the shared value range [gLo, gHi], letting the KDE tail +-- decay smoothly even beyond each group's own data extent (using each +-- group's own min/max would truncate the tail instead of tapering it off, +-- the same approach as PS renderRidgeLayer). The bandwidth (bw) is still +-- computed from each group's own vals. kdeGridOver :: Double -> Double -> Int -> [Double] -> [(Double, Double)] kdeGridOver gLo gHi nGrid vals | length vals < 2 = [] @@ -1352,8 +1859,11 @@ 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)。 +-- | [日本語]: 5 数要約 (Tukey)。 q1/median/q3 + whisker 端 (1.5×IQR 内の最遠データ点)。 +-- box / raincloud が共有。 vals はソート不要 (内部で sort)。 +-- [English]: The Tukey five-number summary: q1/median/q3 plus the whisker +-- ends (the farthest data point within 1.5×IQR). Shared by box and +-- raincloud. vals need not be pre-sorted (sorted internally). data FiveNum = FiveNum { fnQ1 :: !Double, fnMed :: !Double, fnQ3 :: !Double , fnLoW :: !Double, fnHiW :: !Double } @@ -1379,8 +1889,48 @@ 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 白線を返す。 +-- | [日本語]: 細い箱ひげ (= raincloud 中央 / 単群 box 用)。 中心 x = cx、 半幅 hw px。 +-- 共通 'fiveNum' を使い whisker 足 + IQR 箱 + median 白線を返す。 +-- [English]: A thin box-and-whisker (used for the raincloud center / a +-- single-group box). Centered at x = cx, with half-width hw px. Uses the +-- shared 'fiveNum' to return the whisker legs, the IQR box, and the +-- white median line. +-- | [日本語]: 'boxAt' の座標系対応版。 cross 位置を 'CrossLoc' + px offset で受け、 +-- 座標変換を投影層 ('projectCrossPoint' / 'projectCrossSpan' / 'projectCrossBar') +-- に委ねる。 直線座標系は 'boxAt' と同じ primitive 列・同じ px を返す (byte 一致)。 +-- 極座標では箱が扇形、 髭が radial 線、 cap / median が弧になる。 halfD は極座標用の +-- data 単位半幅。 +-- [English]: The coordinate-aware counterpart of 'boxAt'. Takes the cross +-- position as a 'CrossLoc' plus a pixel offset and delegates coordinate +-- conversion to the projection layer ('projectCrossPoint' / +-- 'projectCrossSpan' / 'projectCrossBar'). Linear coordinate systems return +-- the same primitive sequence at the same pixels as 'boxAt' (byte +-- identical); in polar the box becomes a sector, the whiskers radial lines, +-- and the caps and median arcs. halfD is the half width in data units, used +-- by the polar path. +boxAtCross :: Coord -> Layout -> CrossLoc -> Double -> Double -> Double + -> Text -> [Double] -> [Primitive] +boxAtCross coord layout loc offPx hwPx halfD 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 + pt v = projectCrossPoint coord layout loc offPx v + spanLine w v = + let pts = projectCrossSpan coord layout loc offPx hwPx halfD v + in [ PLine p q (solid color w) | (p, q) <- zip pts (drop 1 pts) ] + body = case projectCrossBar coord layout loc offPx hwPx halfD q3 q1 of + BarRect rect -> PRect rect (FillStyle color 0.7) (Just (StrokeStyle color 1.0)) + BarWedge segs -> PPath segs (FillStyle color 0.7) (Just (StrokeStyle color 1.0)) + medianLine = + let pts = projectCrossSpan coord layout loc offPx hwPx halfD q2 + in [ PLine p q (solid "#ffffff" 1.5) | (p, q) <- zip pts (drop 1 pts) ] + in [ PLine (pt q3) (pt hiV) (solid color 1.0) + , PLine (pt q1) (pt loV) (solid color 1.0) ] + <> spanLine 1.0 hiV + <> spanLine 1.0 loV + <> [ body ] + <> medianLine + boxAt :: (Double -> Double) -> Double -> Double -> Text -> [Double] -> [Primitive] boxAt sy cx hw color vals = case fiveNum vals of Nothing -> [] @@ -1395,8 +1945,11 @@ , 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 を入れ替えた版が要る。 +-- | [日本語]: Ridge 用 group 化: encX = 値 (numeric)、 encY = 群 (categorical)。 +-- groupedValues は encX を群とするため、 ridge では x/y を入れ替えた版が要る。 +-- [English]: Grouping for Ridge plots: encX is the value (numeric), encY +-- is the group (categorical). Since groupedValues treats encX as the +-- group, ridge needs a variant with x and y swapped. ridgeGroups :: Resolver -> Layer -> [(Text, [Double])] ridgeGroups r ly = case getLast (lyEncY ly) of Just crG -> case resolveCol r crG of @@ -1413,7 +1966,9 @@ Nothing -> [] Nothing -> [] --- | Backend が実装する interface。 IO は canvas / file write のため。 +-- | [日本語]: Backend が実装する interface。 IO は canvas / file write のため。 +-- [English]: The interface implemented by each backend. IO is needed for +-- canvas drawing / file writing. class Renderer rndr where drawPrimitives :: rndr -> [Primitive] -> IO () diff --git a/src/Graphics/Hgg/Render/Distribution.hs b/src/Graphics/Hgg/Render/Distribution.hs --- a/src/Graphics/Hgg/Render/Distribution.hs +++ b/src/Graphics/Hgg/Render/Distribution.hs @@ -1,10 +1,11 @@ -- | -- Module : Graphics.Hgg.Render.Distribution --- Description : 分布 mark (box/violin/strip/swarm/raincloud/ridge) +-- Description : Distribution marks: box, violin, strip, swarm, raincloud, ridge -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +-- [日本語]: Render モノリス分割 (出力中立・純粋移動)。 +-- [English]: Split out from the Render monolith (an output-neutral, pure move). {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unused-imports #-} @@ -20,7 +21,11 @@ domFrac, projectXY, projectRectData, projectBarRect, catUnitPx, AxisPlacement (..), coordXAxisPlacement, coordYAxisPlacement, - coordXGridIsVertical) + coordXGridIsVertical, + -- Phase 64 A3: categorical-cross 投影口 + CrossLoc (..), BarShape (..), + projectCrossPoint, projectCrossSpan, + projectCrossBar, valueAxisPx) 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 @@ -61,25 +66,50 @@ import Graphics.Hgg.Render.Common --- | Phase 36 D3: 各群を 'lpXCategoryLabels' 内の **大域 index**(= 列名スロット)に置く。 --- cats が空(単一群・非 categorical)なら局所順 @[0..]@。 既存の grouped 図は groups が cats と --- 同順・全在ゆえ大域 = 局所で **byte 不変**。 distCols は各レーンが 1 群(自列名)= 大域 index。 +-- | [日本語]: 各群を 'lpXCategoryLabels' 内の __大域 index__ (= 列名スロット) に置く。 +-- cats が空 (単一群・非 categorical) なら局所順 @[0..]@。 既存の grouped 図は groups が cats と +-- 同順・全在ゆえ大域 = 局所で __byte 不変__。 distCols は各レーンが 1 群 (自列名) = 大域 index。 +-- [English]: Places each group at its __global index__ within +-- 'lpXCategoryLabels' (a column-name slot). If cats is empty (a single group, +-- non-categorical), falls back to local order @[0..]@. In existing grouped +-- figures, groups follow cats in the same order and are all present, so +-- global equals local and output is __byte-identical__. For distCols, each +-- lane is its own group (its own column name), which is its global 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 = +-- | [日本語]: Box plot (= 5-number summary)。 PS / HS で API 統一: lyEncY = 値、 lyEncX = 群 (optional)。 +-- 群指定なしなら単一 box を plot 中央に。 群指定ありなら各群について並列描画。 +-- 中央線 (median) + IQR 箱 + 髭 (min/max within 1.5*IQR)。 +-- [English]: A box plot (a 5-number summary). Unified API across PS/HS: +-- lyEncY is the value, lyEncX is the group (optional). With no group, draws +-- a single box centered in the plot; with a group, draws each group's box +-- side by side. Shows the median line, the IQR box, and whiskers +-- (min/max within 1.5*IQR). +-- | [日本語]: box glyph を CrossLoc (cross 位置) + 半幅指定で描く共通部。 +-- 座標変換は 'Graphics.Hgg.Layout.projectCrossBar' / +-- 'Graphics.Hgg.Layout.projectCrossSpan' / +-- 'Graphics.Hgg.Layout.projectCrossPoint' に集約し、 geom 側は coord を場合分け +-- しない。 直線座標系は旧 px 式と byte 一致 (halfPx = box 半幅 px)、 polar は +-- 箱 = wedge (halfD = data 半幅)・髭 = radial 線・median/cap = 弧。 +-- normal path (群 = カテゴリ位置) と dodge path (sub-slot 中心) が共有。 +-- [English]: The shared routine that draws a box glyph from a 'CrossLoc' +-- (its position on the cross axis) plus a half width. All coordinate +-- conversion is concentrated in 'Graphics.Hgg.Layout.projectCrossBar' / +-- 'Graphics.Hgg.Layout.projectCrossSpan' / +-- 'Graphics.Hgg.Layout.projectCrossPoint', so the geom itself never +-- branches on the coordinate system. Linear systems are byte identical to +-- the previous pixel formulas (halfPx is the box half width in pixels); in +-- polar the body becomes a wedge (halfD is the half width in data units), +-- the whiskers become radial lines, and the median and caps become arcs. +-- Shared by the normal path (group at a categorical position) and the dodge +-- path (centered in a sub-slot). +boxGlyphAt :: Coord -> Layout -> CrossLoc -> Double -> Double -> Double + -> Double -> [Double] -> Text -> Text -> [Primitive] +boxGlyphAt coord layout loc offPx halfPx halfD a sorted0 fill stroke = let sorted = sort sorted0 n = length sorted q p = @@ -97,26 +127,27 @@ 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)) + pt v = projectCrossPoint coord layout loc offPx v + -- cross 方向の短線 (median/cap)。 直線座標系は 2 点 = 単一 PLine (byte 不変)、 + -- polar の弧 (> 2 点) は連続 PLine 群で折線化。 + spanLine w hPx hD v = + let pts = projectCrossSpan coord layout loc offPx hPx hD v + in [ PLine p0 p1 (solid stroke w) | (p0, p1) <- zip pts (drop 1 pts) ] + body = case projectCrossBar coord layout loc offPx halfPx halfD q1 q3 of + BarRect rect -> PRect rect (FillStyle fill a) (Just (StrokeStyle stroke 1.0)) + BarWedge segs -> PPath segs (FillStyle fill a) (Just (StrokeStyle stroke 1.0)) 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 + [ PCircle (pt v) 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 + in [ body ] + <> spanLine 2.0 halfPx halfD q2 + <> [ PLine (pt q1) (pt loV) (solid stroke 1.0) + , PLine (pt q3) (pt hiV) (solid stroke 1.0) ] + <> spanLine 1.0 (halfPx / 2) (halfD / 2) loV + <> spanLine 1.0 (halfPx / 2) (halfD / 2) hiV + <> outlierPrims renderBox :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderBox r layout pal ly @@ -148,8 +179,6 @@ 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)) @@ -162,71 +191,29 @@ -- ★ 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 + -- ★ Phase 64 A3: 座標変換は boxGlyphAt (→ projectCross*) に集約。 flipOnly を + -- 撤去し polar もそのまま渡す (箱 = wedge / 髭 = radial で描かれる)。 + coord = lpCoord layout + -- polar 用の data 半幅: cat は 1 slot = 1 data 単位の mw/2、 単一群は x domain + -- 全幅の mw/2 (linear 座標系では halfPx 側が使われ、 この値は参照されない)。 + spanX = lsDomainHi (lpXScale layout) - lsDomainLo (lpXScale layout) + halfD = mw / 2 * (if hasCats then 1 else spanX) + locFor i = if hasCats then CrossAt (fromIntegral i) else CrossMid 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 + boxGlyphAt coord layout (locFor i) nudgePx (bwFor / 2) halfD + (if isHollow then 0.0 else a) sorted + (boxFillFor i) (strokeFor i) in concat (zipWith mkBox (laneIndices layout groups) groups) --- | Phase 36 B2: dodge box。 位置列 (@groupBy@) × 色列 (@colorBy@) で各位置カテゴリ内に +-- | [日本語]: dodge box。 位置列 (@groupBy@) × 色列 (@colorBy@) で各位置カテゴリ内に -- 色サブグループを横並び (= ggplot @position_dodge@)。 色 = colorBy 水準の categorical --- palette、 枠 = grey20 既定 (明示 'color' があれば枠色優先)。 box 実幅 = sub-slot の 85%。 +-- palette、 枠 = grey20 既定 (明示 'Graphics.Hgg.Spec.Layer.color' があれば枠色優先)。 box 実幅 = sub-slot の 85%。 +-- [English]: A dodge box. Given a position column (@groupBy@) and a color +-- column (@colorBy@), arranges color sub-groups side by side within each +-- position category (ggplot's @position_dodge@). Color follows the +-- categorical palette over colorBy levels; the stroke defaults to grey20 +-- (an explicit 'Graphics.Hgg.Spec.Layer.color' takes priority for the stroke). The actual box +-- width is 85% of the sub-slot. renderBoxDodge :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderBoxDodge r layout _pal ly = let (_positions, colorCats, cells) = dodgeCells layout r ly @@ -237,22 +224,22 @@ -- ★ 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) + -- ★ Phase 64 A3: 座標変換は boxGlyphAt (→ projectCross*) に集約 (flipOnly 撤去)。 + coord = lpCoord 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 + -- polar 用 data 半幅 = sub-slot (0.9/nColor data 単位) の 85% の半分 + halfD = 0.9 / fromIntegral nColor * 0.85 / 2 in concat - [ boxGlyphPx coord sy valPxF (crossScale (dodgeCenterD pix cix nColor)) (bw / 2) + [ boxGlyphAt coord layout (CrossAt (dodgeCenterD pix cix nColor)) 0 (bw / 2) halfD (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 を横並び。 +-- | [日本語]: dodge violin。 位置列 × 色列で各位置内に色サブグループの violin を横並び。 +-- [English]: A dodge violin. Given a position column and a color column, +-- arranges color sub-group violins side by side within each position. renderViolinDodge :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderViolinDodge r layout _ ly = let (_positions, colorCats, cells) = dodgeCells layout r ly @@ -260,34 +247,29 @@ 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) + -- ★ Phase 64 A3: 座標変換は projectCrossPoint に集約 (flipOnly / crossScale 撤去)。 + -- violin 幅は視覚 px 量のまま (polar では接線方向の px nudge = 半径不問の等幅)。 + coord = lpCoord 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) + let loc = CrossAt (dodgeCenterD pix cix nColor) + mkPt off y = projectCrossPoint coord layout loc off y 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 ] + rightPath = [ mkPt (wScale d) y | (y, d) <- ds ] + leftPath = [ mkPt (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 描画。 +-- | [日本語]: Violin: group ごとに 縦方向 KDE shape 描画。 +-- [English]: A violin: draws a vertically-oriented KDE shape for each group. renderViolin :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderViolin r layout pal ly | isJust (distDodgeRef ly) = renderViolinDodge r layout pal ly @@ -298,8 +280,6 @@ 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)) @@ -313,16 +293,11 @@ 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) + -- ★ Phase 64 A3: 座標変換は projectCrossPoint に集約 (flipOnly 撤去)。 violin 幅は + -- 視覚 px 量のまま (polar では接線方向 px nudge = 半径不問の等幅、 spine は radial)。 + coord = lpCoord layout + locFor i = if hasCats then CrossAt (fromIntegral i) else CrossMid + mkPt i off y = projectCrossPoint coord layout (locFor i) (nudgePx + off) y -- 各 group の violin shape (= 縦並び KDE、 共通 kdeGrid を左右対称展開) mkViolin i (_label, vals) = let color = pal !! (i `mod` length pal) @@ -348,10 +323,16 @@ (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 を横並び +-- | [日本語]: Strip plot: group ごとに 縦に scatter、 横 jitter で散らす +-- (= ggplot geom_jitter 流)。 jitter 幅は lyJitterX 指定 > 既定 (slot の 0.4)。 +-- [English]: A strip plot: scatters points vertically per group, spread +-- horizontally with jitter (in the style of ggplot's geom_jitter). Jitter +-- width follows an explicit lyJitterX, falling back to 0.4 of the slot. +-- | [日本語]: dodge strip。 位置列 × 色列で各位置内に色サブグループの jitter を横並び -- (= ggplot @position_jitterdodge@)。 jitter は sub-slot 幅基準。 +-- [English]: A dodge strip. Given a position column and a color column, +-- arranges color sub-group jitter side by side within each position +-- (ggplot's @position_jitterdodge@). Jitter is scaled to the sub-slot width. renderStripDodge :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderStripDodge r layout pal ly = let (_positions, colorCats, cells) = dodgeCells layout r ly @@ -360,23 +341,17 @@ 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) + -- ★ Phase 64 A3: 座標変換は projectCrossPoint に集約 (flipOnly / crossScale 撤去)。 + -- jitter は視覚 px 量のまま (polar では接線方向 px = 半径不問の等散らし)。 + coord = lpCoord 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) + let loc = CrossAt (dodgeCenterD pix cix nColor) color = colorFor cix - in [ PCircle (mkPt cx dx v) (sz/2) (FillStyle color a) Nothing Nothing + in [ PCircle (projectCrossPoint coord layout loc 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 @@ -390,8 +365,6 @@ 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 基準。 @@ -404,16 +377,11 @@ 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) + -- ★ Phase 64 A3: 座標変換は projectCrossPoint に集約 (flipOnly 撤去)。 + -- jitter は視覚 px 量のまま (polar では接線方向 px = 半径不問の等散らし)。 + coord = lpCoord layout + locFor i = if hasCats then CrossAt (fromIntegral i) else CrossMid + mkPt i off v = projectCrossPoint coord layout (locFor i) (nudgePx + off) v 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) @@ -422,10 +390,16 @@ , 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 適用後)。 +-- | [日本語]: Beeswarm の横 offset 計算: 値を pixel y にマップ後、 点直径ごとに +-- y ビンを切り、 各ビン内で点を中央から左右対称に並べる (= 1,-1,2,-2,... 列)。 +-- N に対し安定で、 横幅は maxOff で clamp (= はみ出さない)。 戻り値は各点の dx (px)。 +-- HS/PS 共通アルゴリズム。 入力 ys は pixel y 値 (sy 適用後)。 +-- [English]: Computes beeswarm horizontal offsets: after mapping values to +-- pixel y, cuts y bins one point-diameter wide and, within each bin, arranges +-- points symmetrically outward from the center (the sequence 1,-1,2,-2,...). +-- Stable with respect to N, and the width is clamped by maxOff (never +-- overflows). Returns each point's dx (px). A shared HS/PS algorithm. The +-- input ys are pixel y values (after applying sy). beeswarmOffsets :: Double -> Double -> [Double] -> [Double] beeswarmOffsets diameter maxOff ysPix = let binH = diameter @@ -442,9 +416,14 @@ in dx : go seen' rest in go [] ysPix --- | Swarm plot (Phase 8 B5): strip の衝突回避版 (beeswarm)。 値の近い点を --- 横方向に左右対称へ押し出して重なりを避ける。 N 大でも横幅 clamp で破綻しない。 --- | Phase 36 B2: dodge swarm。 位置列 × 色列で各位置内に色サブグループの beeswarm を横並び。 +-- | [日本語]: Swarm plot: strip の衝突回避版 (beeswarm)。 値の近い点を +-- 横方向に左右対称へ押し出して重なりを避ける。 N 大でも横幅 clamp で破綻しない。 +-- [English]: A swarm plot: the collision-avoiding variant of strip (a +-- beeswarm). Points with close values are pushed apart symmetrically to +-- avoid overlap. Stays well-behaved even for large N thanks to the width clamp. +-- | [日本語]: dodge swarm。 位置列 × 色列で各位置内に色サブグループの beeswarm を横並び。 +-- [English]: A dodge swarm. Given a position column and a color column, +-- arranges color sub-group beeswarms side by side within each position. renderSwarmDodge :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderSwarmDodge r layout pal ly = let (_positions, colorCats, cells) = dodgeCells layout r ly @@ -453,27 +432,21 @@ 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) + -- ★ Phase 64 A3: 座標変換は projectCrossPoint / valueAxisPx に集約 + -- (flipOnly / crossScale 撤去)。 beeswarm の押し出しは重なり回避のための + -- 視覚 px 量なので px のまま (polar では接線方向 px nudge)。 + coord = lpCoord 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) + let loc = CrossAt (dodgeCenterD pix cix nColor) color = colorFor cix sortedVals = sort vals - ysPix = map valuePx sortedVals + ysPix = map (valueAxisPx coord layout) sortedVals offs = beeswarmOffsets sz maxOff ysPix - in [ PCircle (mkPt cx off v) (sz/2) (FillStyle color a) Nothing Nothing + in [ PCircle (projectCrossPoint coord layout loc off v) (sz/2) + (FillStyle color a) Nothing Nothing | (v, off) <- zip sortedVals offs ] in concatMap mkPts cells @@ -485,8 +458,6 @@ 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)) @@ -497,32 +468,32 @@ 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) + -- ★ Phase 64 A3: 座標変換は projectCrossPoint / valueAxisPx に集約 (flipOnly と + -- 旧非網羅 case (CoordCartesian/CoordFlip のみ) を撤去)。 beeswarm の binning は + -- value 軸 px 上 (polar は半径 px / 外周弧長 px)、 押し出しは接線方向 px nudge。 + coord = lpCoord layout + locFor i = if hasCats then CrossAt (fromIntegral i) else CrossMid + mkPt i off v = projectCrossPoint coord layout (locFor i) (nudgePx + off) v mkPts i (_, vals) = let color = if c0 == tpDefault pal then cats !! (i `mod` length cats) else c0 sortedVals = sort vals - ysPix = map valuePx sortedVals + ysPix = map (valueAxisPx coord layout) 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) と重ならないよう左にオフセットして配置。 +-- | [日本語]: Raincloud plot: 群ごとに 右:half-violin + 中央:box + 左:jitter strip。 +-- 参照画像 (raincloud_ref.webp) 準拠。 ggplot 流に「3 つの geom を重ねる」 構成とし、 +-- KDE/四分位は共通 helper ('kdeGrid' / 'boxAt') を再利用 (= violin/box とロジック重複なし)。 +-- box は KDE の baseline (cx) と重ならないよう左にオフセットして配置。 +-- [English]: A raincloud plot: per group, a half-violin on the right, a box +-- in the middle, and a jitter strip on the left. Follows the reference image +-- (raincloud_ref.webp). Built by layering three geoms, ggplot-style; the KDE +-- and quartiles reuse the shared helpers ('kdeGrid' / 'boxAt') so there is no +-- logic duplicated with violin/box. The box is offset to the left so it does +-- not overlap the KDE baseline (cx). renderRaincloud :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderRaincloud r layout _ ly = let groups = distGroupsOrdered layout r ly @@ -533,43 +504,63 @@ 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 + -- ★ Phase 64 A4: 自前 sx/sy を投影層へ。 cross 位置は 'CrossLoc'、 3 部位の + -- 横ずらしは px offset として渡す。 直線座標系は旧式と bit 一致 + -- (catUnitPx CoordCartesian == sx 1 - sx 0)、 極座標では雲/雨/箱が + -- 接線方向に並ぶ。 halfWidthD は極座標用の data 単位半幅。 + coord = lpCoord layout + halfWidth = if hasCats then catUnitPx coord layout * 0.35 else rW area * 0.35 + spanXD = lsDomainHi (lpXScale layout) - lsDomainLo (lpXScale layout) + halfWidthD = 0.35 * (if hasCats then 1 else spanXD) + locFor i = if hasCats then CrossAt (fromIntegral i) else CrossMid 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 + let loc = locFor i + pt off v = projectCrossPoint coord layout loc off v color = case staticColorOr ly "" of "" -> pal !! (i `mod` length pal) given -> given - -- (1) 右半身 violin (= 「雲」、 共通 kdeGrid を baseline cx から右へ) + -- (1) 右半身 violin (= 「雲」、 共通 kdeGrid を baseline から右へ) 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 ] + rightPts = [ pt ((d / dMax) * halfWidth) v | (v, d) <- grid ] + basePts = reverse [ pt 0 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 + -- (2) box (= 共通 boxAtCross)。 KDE baseline と離すため左に halfWidth*0.32 寄せる + boxOff = negate (halfWidth * 0.32) + boxPrims = boxAtCross coord layout loc boxOff 3 (halfWidthD * 0.06) color vals -- (3) 左 jitter strip (= 「雨」、 box より更に左、 hashRand で deterministic) - stripCx = cx - halfWidth * 0.7 - stripPrims = [ PCircle (Point (stripCx + dx) (sy v)) (sz / 2) + stripOff = negate (halfWidth * 0.7) + stripPrims = [ PCircle (pt (stripOff + dx) 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' を共有。 +-- | [日本語]: Ridge plot / joyplot。 群ごとに density 曲線を描き、 値方向に山を並べて少し重ねる。 +-- 他 distribution mark と統一し encY=値・群=distGroupRef (encX ?? colorBy)。 +-- ridge は値→x・群→y の向きが要るため Layout が coord_flip を自動適用 ('Graphics.Hgg.Spec.Setters.ridgeAutoFlip')。 +-- よって値→x は 'lpYScaleFlipped'、 群→y baseline は 'lpXScaleFlipped' を使う (box-flip と同機構)。 +-- 軸/目盛/群ラベルは標準 path が描き、 ここは glyph (群ごと 1 PPath) のみ。 重なり headroom は +-- Layout が群 (= flip 後 y) カテゴリドメインを上方向へ expand して確保。 KDE は 'kdeGridOver' を共有。 +-- [English]: A ridge plot / joyplot. Draws a density curve per group and +-- lines up the peaks along the value axis with a slight overlap. Kept +-- consistent with the other distribution marks: encY is the value, and the +-- group is distGroupRef (encX, falling back to colorBy). Because ridge needs +-- the value going to x and the group going to y, Layout auto-applies +-- coord_flip ('Graphics.Hgg.Spec.Setters.ridgeAutoFlip'); accordingly value-to-x uses 'lpYScaleFlipped' +-- and the group-to-y baseline uses 'lpXScaleFlipped' (the same mechanism as +-- box-flip). The axes/ticks/group labels are drawn by the standard path; +-- this function draws only the glyphs (one 'PPath' per group). Overlap +-- headroom is secured by Layout expanding the group (post-flip y) category +-- domain upward. The KDE evaluation is shared via 'kdeGridOver'. renderRidge :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderRidge r layout _thePal ly = let vals = V.toList (vecOr (lyEncY ly) r) -- 値 (encY) @@ -592,6 +583,11 @@ a = doubleOr (lyAlpha ly) 0.8 area = lpPlotArea layout pal = lpCategoricalPalette layout + -- ★ Phase 64 A4: ここで flipped scale を直に使うのは意図的で、 投影層へは + -- 寄せない。 ridge は「値 → x・群 → y」 の向きが必須なので Layout 側が + -- 'Graphics.Hgg.Spec.Setters.ridgeAutoFlip' で coord_flip を自動適用しており、 + -- flipped scale を使うのがその機構の一部になっている。 投影層へ移すには + -- 自動 flip の設計自体を見直す必要があるため、 本 Phase では現状維持とした。 vx v = scaleApply (lpYScaleFlipped layout) v -- 値 → x (flip 済・連続) gyc i = scaleApply (lpXScaleFlipped layout) (fromIntegral i) -- 群 index → y baseline allVals = concatMap snd groups diff --git a/src/Graphics/Hgg/Render/EdgeRoute.hs b/src/Graphics/Hgg/Render/EdgeRoute.hs --- a/src/Graphics/Hgg/Render/EdgeRoute.hs +++ b/src/Graphics/Hgg/Render/EdgeRoute.hs @@ -1,17 +1,28 @@ -- | -- Module : Graphics.Hgg.Render.EdgeRoute --- Description : DAG edge の pt 空間 routing 幾何 (障害物回避・port・制御点列) +-- Description : Pt-space routing geometry for DAG edges (obstacle avoidance, ports, control points) -- 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 入力契約」。 +-- [日本語]: routing を描画 (Render.Special) から分離した純幾何 module。 +-- pt 空間で toScreen・radius・plate bbox (障害物) を受け、 edge の制御点列と +-- 描画 style ('EdgeRoute') を返す。 Primitive 生成や ThemePalette には依存しない +-- (= 描画は呼出側 'Graphics.Hgg.Render.Special.renderEdge' の責務)。 段階型と対になる「routing 入力契約」。 +-- [English]: A pure geometry module that separates edge routing from +-- rendering (Render.Special). Given toScreen, the radius, and plate bounding +-- boxes (obstacles) in pt space, it returns an edge's control point sequence +-- and its drawing style ('EdgeRoute'). It has no dependency on Primitive +-- generation or ThemePalette (drawing is the responsibility of the caller +-- 'Graphics.Hgg.Render.Special.renderEdge'). It is the "routing input contract" that pairs with the +-- staged types. -- --- node 形状幾何 ('nodeExtent' / 'edgePortPoint') も routing が依存するため本 module に --- 置き、 描画側 (renderNode 等) は本 module から import する (= 下位 = 幾何、 --- 上位 = 描画 の層分け)。 +-- [日本語]: node 形状幾何 ('nodeExtent' / 'edgePortPoint') も routing が依存するため本 module に +-- 置き、 描画側 (renderNode 等) は本 module から import する (= 下位 = 幾何、 +-- 上位 = 描画 の層分け)。 +-- [English]: Node shape geometry ('nodeExtent' / 'edgePortPoint') is also +-- kept in this module because routing depends on it, and the drawing side +-- (renderNode and friends) imports it from here (lower layer = geometry, +-- upper layer = drawing). {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Render.EdgeRoute ( -- * routing 結果 @@ -44,14 +55,26 @@ import Data.Maybe (mapMaybe) import Data.Text (Text) --- | edge routing の結果 = 制御点列 + 描画 style。 ThemePalette/Primitive 非依存。 +-- | [日本語]: 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 列。 +-- * '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 列。 +-- [English]: The result of edge routing: a control point sequence plus a +-- drawing style. Independent of ThemePalette/Primitive. +-- +-- * 'StraightArrow' — a lone short edge (a straight line plus an arrowhead) +-- * 'SplinePath' — parallel short edges, or long edges with no +-- detour (Catmull-Rom, smoothed by the caller) +-- * 'BezierPath' — a long edge detouring around a plate box (box-corner +-- waypoints are passed through without smoothing) +-- * 'CubicPath' — R3 (Step6 P7a): a box-constrained cubic Bezier fit +-- from graphviz's Proutespline. The first point is the +-- start point, followed by cubic segments in groups of +-- three (control point 1, control point 2, end point). data EdgeRoute = StraightArrow Point Point | SplinePath [Point] @@ -59,12 +82,19 @@ | CubicPath [Point] deriving (Show, Eq) --- | edge の制御点列と style を pt 空間で決定する純関数 (= 'renderEdge' から routing 部を抽出)。 --- 並列 edge は perpendicular に offset、 長 edge は graphviz routesplines: --- 障害物 ('Obstacles') から box-channel を作り (A-2)、 funnel 最短折れ線 (A-3) を通す。 +-- | [日本語]: edge の制御点列と style を pt 空間で決定する純関数 (= 'Graphics.Hgg.Render.Special.renderEdge' から routing 部を抽出)。 +-- 並列 edge は perpendicular に offset、 長 edge は graphviz routesplines: +-- 障害物 ('Obstacles') から box-channel を作り (A-2)、 funnel 最短折れ線 (A-3) を通す。 +-- [English]: A pure function that determines an edge's control point +-- sequence and style in pt space (the routing portion extracted from +-- 'Graphics.Hgg.Render.Special.renderEdge'). Parallel edges get a perpendicular offset; long edges +-- follow graphviz's routesplines approach: a box-channel is built from the +-- obstacles ('Obstacles') (A-2), and the shortest path is routed through it +-- with the funnel algorithm (A-3). routeEdge :: (Double -> Double -> Point) - -> Obstacles -- ^ A-1: node + plate 障害物 (pt 空間) + -> Obstacles -- ^ [日本語]: A-1: node + plate 障害物 (pt 空間) + -- [English]: A-1: node and plate obstacles (pt space) -> DAGNode -> DAGNode -> Maybe [(Double, Double)] -> Double -> Int -> Int -- ^ parIx, parCount @@ -164,40 +194,72 @@ -- A-1: 障害物モデル (pt 空間の軸並行矩形) -- =========================================================================== --- | pt 空間の軸並行矩形 (xlo ≤ xhi, ylo ≤ yhi)。 routing の障害物 / channel box 共用。 +-- | [日本語]: pt 空間の軸並行矩形 (xlo ≤ xhi, ylo ≤ yhi)。 routing の障害物 / channel box 共用。 +-- [English]: An axis-aligned rectangle in pt space (xlo <= xhi, ylo <= yhi), +-- shared by routing obstacles and channel boxes. data Box = Box !Double !Double !Double !Double -- ^ xlo ylo xhi yhi deriving (Show, Eq) --- | routing 用障害物集合。 node glyph box (= id 付き・端点除外用) と plate box を分けて保持。 +-- | [日本語]: 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 レーンに侵入不能)。 +-- '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 レーンに侵入不能)。 +-- [English]: The set of obstacles used for routing. Keeps node glyph boxes +-- (with ids, for excluding endpoints) and plate boxes separate. +-- +-- 'obLanes' is, per edge, the sequence of dummy lane boxes (keyed by +-- (from, to)). graphviz's @make_regular_edge@ per-edge boxes are "the +-- corridor clipped by the rank-order left/right neighboring objects +-- (__including virtual nodes__)" (@maximal_bbox@). Since the free-interval +-- clipping in 'buildChannel' already treats "the nearest crossing box" as +-- "the neighboring object", adding other edges' dummy lanes to the obstacle set +-- turns the channel into "this lane's own box corridor" (it cannot enter +-- another edge's dummy lane). data Obstacles = Obstacles - { obNodes :: [(Text, Box)] -- ^ node id → glyph box (clearance margin 込み) - , obPlates :: [Box] -- ^ plate 枠 box (clearance margin 込み) + { obNodes :: [(Text, Box)] + -- ^ [日本語]: node id → glyph box (clearance margin 込み) + -- [English]: node id to glyph box (clearance margin included) + , obPlates :: [Box] + -- ^ [日本語]: plate 枠 box (clearance margin 込み) + -- [English]: plate frame box (clearance margin included) , obLanes :: [((Text, Text), [Box])] - -- ^ A4: edge (from, to) → dummy lane box 列 (chain 内部 waypoint の virtual node box) + -- ^ [日本語]: edge (from, to) → dummy lane box 列 (chain 内部 waypoint の virtual node box) + -- [English]: edge (from, to) to its dummy lane box sequence (virtual + -- node boxes for the chain's interior waypoints) } 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') 側で行う。 +-- | [日本語]: clearance margin (= spline が箱に接しないための余白)。 graphviz: cluster 8pt。 +-- node 4→8pt を試したが channel が狭まり分割接合の junction kink (157°/54°) が +-- 再発したため 4pt に据え置き (routes CSV + analyze-kinks.py で確認)。 かすり対策は +-- box 辺 barrier (@boxBarriers@) 側で行う。 +-- [English]: The clearance margin (the space kept so that splines don't +-- touch a box). graphviz uses 8pt for clusters. Trying 4->8pt for nodes +-- narrowed the channel and reintroduced junction kinks (157/54 degrees) at +-- split joins, so it is kept at 4pt (confirmed with the routes CSV and +-- analyze-kinks.py). Near-miss avoidance is instead handled on the box-edge +-- barrier side (@boxBarriers@). obNodeMargin, obPlateMargin :: Double obNodeMargin = 4 obPlateMargin = 8 --- | 全 node glyph box (+margin) と plate box (+margin) を pt 空間で構築する (A-1)。 +-- | [日本語]: 全 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 上のオブジェクトではないため対象外。 +-- @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 上のオブジェクトではないため対象外。 +-- [English]: Builds every node glyph box (+margin) and plate box (+margin) +-- in pt space (A-1). +-- +-- Also builds dummy lane boxes ('obLanes') from @edges@. For each interior +-- chain waypoint (a long-edge dummy), it places a virtual node box of width +-- 'laneHalfW' and height equal to that rank's band (the max ry among real +-- nodes at the same y). A flat edge's (same-rank endpoints) gap waypoint is +-- excluded, since it is not an object on a rank line. dagObstacles :: (Double -> Double -> Point) -> Double -> [DAGNode] -> [(Text, DAGNode)] -> [DAGPlate] -> [DAGEdge] -> Obstacles @@ -241,19 +303,33 @@ , 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 すると同じ境界になる。 +-- | [日本語]: dummy lane box の半幅 (pt) = nodesep/2 (auxNodeSep 18 の半分)。 +-- graphviz @maximal_bbox@ は隣接 virtual node との中点 (= 自 box 右端 + nodesep/2) +-- まで回廊を開くため、 隣接 lane の回廊同士はちょうど tile して重ならない。 +-- 半幅 9pt の lane 障害物で clip すると同じ境界になる。 +-- [English]: Half-width (pt) of a dummy lane box: nodesep/2 (half of +-- auxNodeSep 18). graphviz's @maximal_bbox@ opens the corridor up to the +-- midpoint with the neighboring virtual node (its own box's right edge plus +-- nodesep/2), so adjacent lane corridors tile exactly without overlapping. +-- Clipping with a lane obstacle of half-width 9pt yields the same boundary. laneHalfW :: Double laneHalfW = 9 --- | この edge が避けるべき障害物 box 群。 端点 (from/to) の node box と、 端点中心を --- 内側に含む box (= 端点が属する plate 等) は除外する (= edge は正規にそこへ接続する)。 +-- | [日本語]: この 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 は除外する。 +-- 他 edge の dummy lane box ('obLanes') も避ける = per-edge box 回廊。 +-- 自 lane と、 同一端点対の並列 edge (chain 共有・perpendicular offset で分離済) の +-- lane は除外する。 +-- [English]: The set of obstacle boxes this edge must avoid. Excludes the +-- node boxes of its endpoints (from/to) and any box whose interior contains +-- an endpoint's center (e.g. the plate an endpoint belongs to), since the +-- edge legitimately connects there. +-- +-- It also avoids other edges' dummy lane boxes ('obLanes'), giving each +-- edge its own per-edge box corridor. It excludes its own lane and the +-- lanes of parallel edges sharing the same endpoint pair (which share the +-- chain and are already separated by a perpendicular offset). 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 ] @@ -264,7 +340,9 @@ allB = nodeB ++ obPlates obs ++ laneB in [ b | b <- allB, not (boxContains b srcC), not (boxContains b snkC) ] --- | 点が box の interior にあるか (境界は外側扱い)。 +-- | [日本語]: 点が box の interior にあるか (境界は外側扱い)。 +-- [English]: Whether a point is in a box's interior (the boundary counts as +-- outside). boxContains :: Box -> Point -> Bool boxContains (Box xlo ylo xhi yhi) (Point x y) = x > xlo && x < xhi && y > ylo && y < yhi @@ -273,23 +351,52 @@ -- 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 扱いを参照)。 +-- | [日本語]: 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)。 +-- ★ 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 になる。 +-- ★ 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 になる。 +-- [English]: Builds a portal sequence for the funnel algorithm from a guide +-- polyline (includes the endpoints, assumed y-monotone) and the obstacles. +-- At the y of each interior guide point, it finds the free interval +-- containing the guide's x (clipped by the nearest left/right obstacles) +-- and turns it into a (left point, right point) portal. The endpoints +-- (src/snk) are placed at both ends as degenerate portals. If a free +-- interval degenerates or inverts, it falls back to a degenerate portal +-- that simply passes the guide point through (that point then becomes a +-- forced pass-through point for the funnel; see how 'funnel' handles +-- degenerate portals). +-- +-- R1 (Step6 P7a, 2026-06-24): when one side has no obstacle, the wall is +-- clipped to __the graph bbox edge (a finite value)__ (previously ±Infinity). +-- graphviz's @maximal_bbox@ (dotsplines.c) always clips to the +-- cluster/graph boundary when there is no neighboring node, so the wall is +-- always finite. The old ±Inf turned the funnel's @tri@ cross product into +-- Infinity, collapsing its sign and causing a degenerate straight-line +-- collapse (correspondence doc §4-B). +-- +-- R2-fix (2026-06-24): a portal is now __a narrow window around the dummy's x__ +-- ([gx-w, gx+w] clipped by the free interval), not __the full free interval__. +-- graphviz's @maximal_bbox@ builds its box based on the +-- virtual node's own thin width (lw ~= 1pt), so the box hugs the dummy +-- tightly. The old implementation used the full free interval as the +-- portal, so when an endpoint was off-center the funnel would ignore the +-- dummy lane and shortcut toward the chain, producing an L-shape (a single +-- corner) that made R3's cubic fit run away (bulge). With a narrow window, +-- the funnel hugs the collinear dummy lane and produces a smooth bow, just +-- like graphviz. buildChannel :: [Box] -> [Point] -> [(Point, Point)] buildChannel boxes guide = case guide of [] -> [] @@ -341,8 +448,11 @@ else (Point gx gy, Point gx gy) -- 退化: lane x を強制通過 in (p0, p0) : map mkPortal eventYs ++ [(pn, pn)] --- | guide 折れ線 (y 単調を想定) の高さ @y@ における x を線形補間する。 --- box-stack portal の「側」 (どの障害物が左/右か) を決めるのに使う。 +-- | [日本語]: guide 折れ線 (y 単調を想定) の高さ @y@ における x を線形補間する。 +-- box-stack portal の「側」 (どの障害物が左/右か) を決めるのに使う。 +-- [English]: Linearly interpolates the x of a guide polyline (assumed +-- y-monotone) at height @y@. Used to decide the "side" of a box-stack +-- portal (which obstacle is left/right). guideXAt :: [Point] -> Double -> Double guideXAt pts y = go pts where @@ -355,7 +465,8 @@ go _ = 0 inSeg t a b = (t >= min a b - 1e-9) && (t <= max a b + 1e-9) --- | 昇順ソート (挿入ソート・小規模 event 列向け)。 +-- | [日本語]: 昇順ソート (挿入ソート・小規模 event 列向け)。 +-- [English]: Ascending sort (insertion sort, for small event lists). sortAsc :: [Double] -> [Double] sortAsc = foldr ins [] where @@ -363,7 +474,9 @@ ins x (z : zs) | x <= z = x : z : zs | otherwise = z : ins x zs --- | 近接した y を 1 つに畳む (portal の零高さセグメント除け)。 +-- | [日本語]: 近接した y を 1 つに畳む (portal の零高さセグメント除け)。 +-- [English]: Collapses nearby y values into one (removes zero-height portal +-- segments). dedupNear :: [Double] -> [Double] dedupNear [] = [] dedupNear (x : xs) = x : go x xs @@ -372,12 +485,18 @@ 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 の畳み込み閾値も兼ねる。 +-- | [日本語]: box 内側へ寄せて portal を sample する高さオフセット (pt)。 strict cross 判定に +-- 乗せ、box 上端・下端の角を確実に waypoint 化する。 近接 y の畳み込み閾値も兼ねる。 +-- [English]: The height offset (pt) used to sample a portal, pulled slightly +-- inside a box. This puts the sample on the strict-cross test, so a box's +-- top and bottom corners are reliably turned into waypoints. Also doubles +-- as the threshold for collapsing nearby y values. epsY :: Double epsY = 0.75 --- | R1 フォールバック壁の余白 (pt)。 graph bbox 端からさらに外へ取る隙間。 +-- | [日本語]: R1 フォールバック壁の余白 (pt)。 graph bbox 端からさらに外へ取る隙間。 +-- [English]: Margin (pt) for the R1 fallback wall: extra clearance taken +-- further outside the graph bbox edge. channelMargin :: Double channelMargin = 16 @@ -385,19 +504,40 @@ -- A-3: funnel (stringpulling) 最短折れ線 -- =========================================================================== --- | portal 列 ((左点, 右点) の列・先頭=src 末尾=snk の退化 portal) を通る最短折れ線を --- funnel アルゴリズムで求める。 戻り = src .. snk の折れ線 (端点含む)。 +-- | [日本語]: 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)。 +-- ★ 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' 分岐で素通り。 +-- 規約: portal.left = 小 x 側 / portal.right = 大 x 側、path は下方向 (y 増加)。 +-- 'triarea2' は canonical 定義 (bx*ay - ax*by)。right 壁が左へ寄ると triarea2 ≤ 0 で funnel が +-- 締まる (手計算検証済)。退化 portal (left==right) は 'vequal' 分岐で素通り。 +-- [English]: Finds the shortest polyline through a portal sequence (a list +-- of (left point, right point) pairs, with degenerate portals for src at +-- the head and snk at the tail) using the funnel algorithm. Returns the +-- src .. snk polyline (endpoints included). +-- +-- R2 (Step6 P7a, 2026-06-24): replaced with the textbook Lee funnel +-- (Mononen's "Simple Stupid Funnel Algorithm"), __mathematically identical__ +-- to graphviz's @Pshortestpath@ (shortest.c's triangulation +-- plus deque funnel plus @ccw@). In a box-stack polygon, a triangulation +-- diagonal is exactly a box-overlap portal, so portal-funnel is +-- triangulation-funnel (not a new algorithm, but Pshortestpath itself). The +-- old hand-rolled apex-jump funnel violated the cone invariant and produced +-- a zigzag that bounced between the left and right walls (correspondence +-- doc §4-C). +-- +-- Convention: portal.left is the smaller-x side, portal.right the +-- larger-x side, and the path runs downward (increasing y). 'triarea2' uses +-- the canonical definition (bx*ay - ax*by); when the right wall moves left, +-- triarea2 <= 0 tightens the funnel (verified by hand calculation). +-- Degenerate portals (left == right) pass straight through via the +-- 'vequal' branch. funnel :: [(Point, Point)] -> [Point] funnel [] = [] funnel ps @@ -432,9 +572,13 @@ 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 の零長 --- セグメント除けも兼ねる。 +-- | [日本語]: 連続する同一点 (vequal) を 1 つに畳む。 Mononen funnel は goal を末尾に必ず append +-- するため、 funnel が goal で collapse すると末尾が重複しうる。 R3 spline fit の零長 +-- セグメント除けも兼ねる。 +-- [English]: Collapses consecutive identical points (per 'vequal') into +-- one. Since the Mononen funnel always appends goal at the end, the tail +-- can end up duplicated when the funnel collapses onto goal. This also +-- removes zero-length segments before the R3 spline fit. dedupConsec :: [Point] -> [Point] dedupConsec [] = [] dedupConsec (x : xs) = x : go x xs @@ -444,7 +588,9 @@ | vequal prev y = go prev ys | otherwise = y : go y ys --- | 三角形 (a,b,c) の符号付き面積 ×2 (Mononen canonical: bx*ay - ax*by)。 +-- | [日本語]: 三角形 (a,b,c) の符号付き面積 ×2 (Mononen canonical: bx*ay - ax*by)。 +-- [English]: Twice the signed area of triangle (a,b,c) (Mononen's canonical +-- definition: 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' @@ -478,12 +624,22 @@ 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 境界上に乗るだけの接触は対象外。 +-- | [日本語]: 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 境界上に乗るだけの接触は対象外。 +-- [English]: A post-funnel correction of the taut path. In a row where the +-- guide pierces a box, the portal of 'buildChannel' can jump to the opposite +-- side via @pushOut@ (a side flip), so the channel polygon between +-- consecutive portals can straddle the box, causing a taut segment to cut +-- diagonally through the box's interior (observed: in dense15, the taut +-- segment x4->x15 (32.4,176)->(75.6,190.2) pierces the x13 box). For a +-- segment that substantially crosses a box's interior (crossing length > +-- 'boxCrossEps'), it inserts the box-corner waypoints on the crossing side +-- to route around the outside. A segment that merely touches the box +-- boundary at an endpoint is excluded. avoidBoxTaut :: [Box] -> [Point] -> [Point] avoidBoxTaut boxes = go (8 :: Int) where @@ -500,9 +656,15 @@ (cs : _) -> Just cs [] -> Nothing --- | 線分 (a,b) が box 内部を横切るとき、 迂回に挿入する box 角列 (a→b 順)。 --- Liang-Barsky で貫通区間を求め、 貫通長が 'boxCrossEps' 以下 (角の接触等) は無視。 --- 迂回側 (上辺経由 / 下辺経由 / 左右) は総距離が短い方を選ぶ。 +-- | [日本語]: 線分 (a,b) が box 内部を横切るとき、 迂回に挿入する box 角列 (a→b 順)。 +-- Liang-Barsky で貫通区間を求め、 貫通長が 'boxCrossEps' 以下 (角の接触等) は無視。 +-- 迂回側 (上辺経由 / 下辺経由 / 左右) は総距離が短い方を選ぶ。 +-- [English]: When segment (a,b) crosses a box's interior, returns the box +-- corner waypoints to insert as a detour (in a-to-b order). The crossing +-- interval is found with Liang-Barsky clipping; a crossing length at or +-- below 'boxCrossEps' (e.g. a corner touch) is ignored. Whichever detour +-- side (top / bottom / left / right) has the shorter total distance is +-- chosen. 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 @@ -545,17 +707,26 @@ else Just (if plen cw <= plen ccw then cw else ccw) _ -> Nothing --- | box 貫通とみなす最小貫通長 (pt)。 角の接触・境界沿いを除外する。 +-- | [日本語]: box 貫通とみなす最小貫通長 (pt)。 角の接触・境界沿いを除外する。 +-- [English]: The minimum crossing length (pt) counted as a box penetration. +-- Excludes corner touches and boundary-hugging contacts. boxCrossEps :: Double boxCrossEps = 2.0 --- | 迂回 corner waypoint を box から斜め外側へ逃がす量 (pt)。 spline の丸めが --- box 辺 barrier に触れない余地を作る。 +-- | [日本語]: 迂回 corner waypoint を box から斜め外側へ逃がす量 (pt)。 spline の丸めが +-- box 辺 barrier に触れない余地を作る。 +-- [English]: The amount (pt) by which a detour corner waypoint is pushed +-- diagonally outside the box. Gives the spline's rounding room so it +-- doesn't touch the box-edge barrier. cornerClear :: Double cornerClear = 2.0 --- | 近接 taut 点の畳み込み (端点は保持)。 corner 挿入 ('avoidBoxTaut') で旧 waypoint と --- 角が 1pt 未満で並ぶ backtrack を掃除し、 spline fit の零長セグメント荒れを防ぐ。 +-- | [日本語]: 近接 taut 点の畳み込み (端点は保持)。 corner 挿入 ('avoidBoxTaut') で旧 waypoint と +-- 角が 1pt 未満で並ぶ backtrack を掃除し、 spline fit の零長セグメント荒れを防ぐ。 +-- [English]: Collapses nearby taut points (endpoints are preserved). Cleans +-- up backtracks where a corner inserted by 'avoidBoxTaut' ends up within +-- 1pt of an old waypoint, preventing zero-length-segment noise in the +-- spline fit. dedupTaut :: Double -> [Point] -> [Point] dedupTaut eps pts = case pts of [] -> [] @@ -573,8 +744,12 @@ -- box 縁を沿走する正常区間まで「barrier 上のライド」 として fit 全棄却 → -- forceflag 直角に縮退したため撤回。 貫通対策は 'avoidBoxTaut' の corner 挿入のみ。) --- | portal 列から channel 境界の barrier 線分群を作る。 左鎖 (portal.left を上→下に連結) --- と右鎖 (portal.right を連結) の各隣接ペア。 spline はこの内側に留まる。 +-- | [日本語]: portal 列から channel 境界の barrier 線分群を作る。 左鎖 (portal.left を上→下に連結) +-- と右鎖 (portal.right を連結) の各隣接ペア。 spline はこの内側に留まる。 +-- [English]: Builds the channel-boundary barrier segments from a portal +-- sequence: each adjacent pair in the left chain (portal.left connected +-- top-to-bottom) and the right chain (portal.right connected). The spline +-- stays inside these. channelBarriers :: [(Point, Point)] -> [(Point, Point)] channelBarriers portals = let lefts = map fst portals @@ -582,26 +757,50 @@ 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 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 で自然方向へ戻した。) +-- 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 で自然方向へ戻した。) +-- [English]: The entry point for graphviz's Proutespline. Given the +-- barriers (channel boundary segments), the taut polyline (endpoints +-- included), and the endpoint tangent directions (ev0 = start, ev1 = end, +-- __unit vectors__), it returns a cubic Bezier control point sequence. +-- Returns [start, c1, c2, end, c1, c2, end, ...] (the leading start point +-- followed by cubic segments in groups of three). +-- +-- graphviz is designed so that endpoint slope is __supplied by the caller (dotsplines.c)__, +-- so this port also takes ev0/ev1 as arguments. graphviz's +-- @P->start.theta=-pi/2 / P->end.theta=pi/2 / constrained@ is a constraint +-- applied to __internal box-segment boundaries__, whereas the tangent at the +-- actual endpoints (src/snk ports) __follows the port direction (diagonal)__ +-- (primary observation: dot 14.1.5's gold output has a diagonal tangent at +-- the endpoints). The caller (routeEdge A3.3) passes +-- the taut path's end-segment direction, i.e. the natural port direction. +-- (A3.1 briefly passed a rank-direction perpendicular, a workaround from +-- the narrow-portal era for a symmetric-V taut path; once A3.2's y-sweep +-- cleaned the taut path down to four points, the clash between the +-- near-diagonal approach and the forced perpendicular produced an inward S, +-- so A3.3 reverted to the natural direction.) 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 列 (始点は含まない)。 +-- | [日本語]: route.c reallyroutespline。 1 本 fit を試み、 失敗なら最大偏差点で分割し再帰。 +-- 戻り = 3 点ずつの cubic segment 列 (始点は含まない)。 +-- [English]: route.c's reallyroutespline. Attempts a single fit, and on +-- failure splits at the point of maximum deviation and recurses. Returns +-- cubic segments in groups of three (the start point is not included). reallyroutespline :: [(Point, Point)] -> [Point] -> Point -> Point -> [Point] reallyroutespline barriers inps ev0 ev1 = let (pa, va, pb, vb) = mkspline inps ev0 ev1 @@ -616,8 +815,12 @@ in reallyroutespline barriers (take (spliti + 1) inps) ev0 splitv ++ reallyroutespline barriers (drop spliti inps) splitv ev1 --- | route.c mkspline。 input 折れ線 + 端点単位方向 ev0/ev1 から、 端点接線の scale を --- 最小二乗で解く。 戻り = (始点, 始点接線ベクトル, 終点, 終点接線ベクトル)。 +-- | [日本語]: route.c mkspline。 input 折れ線 + 端点単位方向 ev0/ev1 から、 端点接線の scale を +-- 最小二乗で解く。 戻り = (始点, 始点接線ベクトル, 終点, 終点接線ベクトル)。 +-- [English]: route.c's mkspline. From the input polyline and the endpoint +-- unit directions ev0/ev1, solves for the endpoint tangent scales by least +-- squares. Returns (start point, start tangent vector, end point, end +-- tangent vector). mkspline :: [Point] -> Point -> Point -> (Point, Point, Point, Point) mkspline inps ev0 ev1 = let p0 = head inps @@ -646,17 +849,34 @@ | 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)。 +-- | [日本語]: 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 と同じ収束先)。 +-- ★ (2026-07-08): channel 内でも control polygon が taut 比 +-- 'hairpinCap' 倍を超える候補は hairpin (接線暴走) として棄却する。 +-- 真因 (実測 = design/phase52-kink/): taut が 3 点 + 屈曲が終端寄りだと +-- 'mkspline' の最小二乗が厳密解に退化し接線 scale が爆発 (kink 辺 = taut 比 +-- 2.18 倍超、 健全辺 ≤ ~1.3 倍)。 graphviz は box 列が taut を密に拘束するため +-- 顕在化しないが、 我々の channel は片側が graph bbox 端 (R1) まで開くことが +-- あり、 暴走 S 字が「channel 内」 と誤判定されていた。 棄却後は a 半減で +-- 平坦化 → それでも合わなければ従来どおり分割 (= graphviz と同じ収束先)。 +-- [English]: route.c's splinefits. Builds control points while scaling +-- mkspline's tangents by a/3 (halving a from 4), and adopts the largest +-- (smoothest) one that fits inside the channel. inpn==2 is force-accepted +-- (forceflag). +-- +-- (2026-07-08): even inside the channel, a candidate whose control polygon +-- exceeds the taut ratio by more than 'hairpinCap' is rejected as a hairpin +-- (a tangent runaway). Root cause (from measurement, see +-- design/phase52-kink/): when the taut path has 3 points and the bend sits +-- near the end, the least squares of 'mkspline' degenerates to an exact solution +-- and the tangent scale explodes (kink edges show a taut ratio over 2.18x, +-- versus at most ~1.3x for healthy edges). graphviz doesn't show this +-- because its box sequence constrains the taut path tightly, but our +-- channel can open all the way to the graph bbox edge on one side (R1), and +-- the runaway S-shape was being misjudged as "inside the channel". After +-- rejection, halving a flattens it; if that still doesn't fit, it falls +-- back to splitting as before (converging to the same result as graphviz). splinefits :: [(Point, Point)] -> Point -> Point -> Point -> Point -> [Point] -> Maybe [Point] splinefits barriers pa va pb vb inps = goA 4 True where @@ -674,12 +894,17 @@ 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 倍。 +-- | [日本語]: hairpin 判定の control polygon 長 / taut 長 の上限比。 +-- 実測 (routes-before.csv): kink 5 辺 = 2.18〜2.6 倍 / 健全辺 ≤ ~1.3 倍。 +-- [English]: The upper-bound ratio of control-polygon length to taut length +-- used for the hairpin check. Measured (routes-before.csv): kink edges = a +-- 2.18x-2.6x ratio versus at most ~1.3x for healthy edges. hairpinCap :: Double hairpinCap = 1.5 --- | inps[0]..inps[n-1] の chord (始点-終点) から最も離れた内部点の index。 +-- | [日本語]: inps[0]..inps[n-1] の chord (始点-終点) から最も離れた内部点の index。 +-- [English]: The index of the interior point farthest from the chord +-- (start-end) of inps[0]..inps[n-1]. maxDevIndex :: [Point] -> Int maxDevIndex inps = let p0 = head inps @@ -688,7 +913,8 @@ ds = [ (distToSeg (inps !! i) p0 pn, i) | i <- [1 .. n - 2] ] in if null ds then 1 else snd (maximum ds) --- | 点 p から線分 (a,b) への距離。 +-- | [日本語]: 点 p から線分 (a,b) への距離。 +-- [English]: The distance from point p to segment (a,b). distToSeg :: Point -> Point -> Point -> Double distToSeg p a b = let ab = vsub b a @@ -700,8 +926,10 @@ polyLen :: [Point] -> Double polyLen ps = sum (zipWith vdist ps (drop 1 ps)) --- | route.c splineisinside。 cubic (sps=[P0,c1,c2,P3]) が barrier 線分のいずれかを --- 内部交差すれば外 (False)。 +-- | [日本語]: route.c splineisinside。 cubic (sps=[P0,c1,c2,P3]) が barrier 線分のいずれかを +-- 内部交差すれば外 (False)。 +-- [English]: route.c's splineisinside. Returns False (outside) if the cubic +-- (sps=[P0,c1,c2,P3]) crosses the interior of any barrier segment. splineisinside :: [(Point, Point)] -> [Point] -> Bool splineisinside barriers sps = not (any crosses barriers) where @@ -709,8 +937,12 @@ 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 上に乗る/解無限)。 +-- | [日本語]: route.c splineintersectsline。 cubic (sps) と線分 lps の交差 t (spline 側) を返す。 +-- Left () = 退化 (graphviz の rootn==4 = 直線が spline 上に乗る/解無限)。 +-- [English]: route.c's splineintersectsline. Returns the intersection t +-- (spline-side) of a cubic (sps) with segment lps. @Left ()@ is the +-- degenerate case (graphviz's rootn==4: the line lies on the spline / an +-- infinite solution). splineIntersectsLine :: [Point] -> (Point, Point) -> Either () [Double] splineIntersectsLine sps (lp0@(Point l0x l0y), lp1@(Point l1x l1y)) | vequal lp0 lp1 = Right [] -- 退化 barrier (点) は無視 @@ -740,7 +972,9 @@ 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³)。 +-- | [日本語]: Bézier control 値 (1D) → power-basis 係数 (c0 + c1 t + c2 t² + c3 t³)。 +-- [English]: Converts 1D Bezier control values to power-basis coefficients +-- (c0 + c1 t + c2 t^2 + c3 t^3). points2coeff :: Double -> Double -> Double -> Double -> (Double, Double, Double, Double) points2coeff p0 p1 p2 p3 = ( p0 @@ -748,12 +982,17 @@ , 3 * (p0 - 2 * p1 + p2) , p3 - 3 * p2 + 3 * p1 - p0 ) --- | power-basis cubic を t で評価。 +-- | [日本語]: power-basis cubic を t で評価。 +-- [English]: Evaluates a power-basis cubic at 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³)。 +-- | [日本語]: 実 cubic 求解 (solvers.c solve3 相当)。 戻り Right = 実根列、 Left () = 退化 (恒等0)。 +-- 係数は power basis (c0 + c1 x + c2 x² + c3 x³)。 +-- [English]: Solves a real cubic (equivalent to solvers.c's solve3). +-- Returns @Right@ with the list of real roots, or @Left ()@ if degenerate +-- (identically zero). Coefficients are in power basis (c0 + c1 x + c2 x^2 +-- + c3 x^3). solve3 :: (Double, Double, Double, Double) -> Either () [Double] solve3 (c0, c1, c2, c3) | abs c3 < tiny = solve2 (c0, c1, c2) @@ -795,7 +1034,9 @@ clampU :: Double -> Double clampU = max (-1) . min 1 --- | Bernstein 基底 (b01 = B0+B1, b23 = B2+B3)。 mkspline 用。 +-- | [日本語]: Bernstein 基底 (b01 = B0+B1, b23 = B2+B3)。 mkspline 用。 +-- [English]: Bernstein basis functions (b01 = B0+B1, b23 = B2+B3), used by +-- mkspline. b1, b2, b01, b23 :: Double -> Double b1 t = 3 * t * (1 - t) * (1 - t) b2 t = 3 * t * t * (1 - t) @@ -806,18 +1047,31 @@ -- Phase 52 A6: port 分散 (同一 node の近接重複 port を境界に沿って扇状に) -- =========================================================================== --- | route 端点の種別 (発 = 始点 / 着 = 終点)。 +-- | [日本語]: route 端点の種別 (発 = 始点 / 着 = 終点)。 +-- [English]: The kind of a route endpoint (source = start point / sink = +-- end point). 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 維持)。 +-- | [日本語]: 同一 node を共有する複数 edge の port が近接重複 ('portClusterEps' +-- 以内) するとき、 node 境界に沿って 'portSep' 間隔の扇状に分散する post-pass。 +-- graphviz P6 sameports 段 (correspondence doc Step 5、 未実装) の実用版。 +-- route 全体は動かさず __端点 + 隣接制御点を同 delta 平行移動__ するだけなので +-- 曲線形状は保たれる (delta は数 pt)。 bake ('Graphics.Hgg.Render.Special.dagBakeRoutes') と live +-- ('Graphics.Hgg.Render.Special.renderDAGStandalone') の両 pipeline が同順で呼ぶ (= HS/PS parity 維持)。 +-- [English]: A post-pass that, when multiple edges sharing the same node +-- have ports that closely overlap (within 'portClusterEps'), fans them out +-- along the node boundary at 'portSep' intervals. A practical stand-in for +-- graphviz's P6 sameports stage (correspondence doc Step 5, not +-- implemented). It doesn't move the whole route, only +-- __translates the endpoint and its adjacent control point by the same delta__, +-- so the curve's shape is preserved (delta is a few pt). Both the bake +-- ('Graphics.Hgg.Render.Special.dagBakeRoutes') and live ('Graphics.Hgg.Render.Special.renderDAGStandalone') pipelines call this in +-- the same order (maintaining HS/PS parity). spreadPorts :: (Double -> Double -> Point) -> Double - -> [(DAGNode, DAGNode)] -- ^ 各 route の (from, to)。 routes と同順 + -> [(DAGNode, DAGNode)] -- ^ [日本語]: 各 route の (from, to)。 routes と同順 + -- [English]: each route's (from, to), in the + -- same order as routes -> [EdgeRoute] -> [EdgeRoute] spreadPorts toScreen radius ends routes = let idx = zip [0 :: Int ..] (zip ends routes) @@ -904,7 +1158,9 @@ in Point (sum [ x | Point x _ <- ps ] / n) (sum [ y | Point _ y <- ps ] / n) ang (Point x y) = atan2 y x --- | route の端点 (+cubic は隣接制御点も) を delta 平行移動する。 +-- | [日本語]: route の端点 (+cubic は隣接制御点も) を delta 平行移動する。 +-- [English]: Translates a route's endpoint (and, for cubics, its adjacent +-- control point) by delta. adjustEnd :: PortEnd -> Point -> EdgeRoute -> EdgeRoute adjustEnd end d r = case (end, r) of (SrcEnd, StraightArrow a b) -> StraightArrow (vadd a d) b @@ -925,20 +1181,30 @@ [z] -> [f z] [] -> xs --- | port cluster 判定の近接閾値 (pt)。 これ未満の port 対は「重なって見える」。 +-- | [日本語]: port cluster 判定の近接閾値 (pt)。 これ未満の port 対は「重なって見える」。 +-- [English]: The proximity threshold (pt) for detecting a port cluster. A +-- pair of ports closer than this "looks overlapping". portClusterEps :: Double portClusterEps = 4.0 --- | 分散後の port 間隔 (境界弧距離、 pt)。 矢印幅 (~8pt) が重ならない程度。 +-- | [日本語]: 分散後の port 間隔 (境界弧距離、 pt)。 矢印幅 (~8pt) が重ならない程度。 +-- [English]: The port spacing (pt, boundary arc distance) after fanning +-- out, chosen so arrowheads (~8pt wide) don't overlap. portSep :: Double portSep = 7.0 --- | 扇順序の「進入回廊」 を測る端からの弧長 (pt)。 局所接線より遠くで測ることで --- 近接方向 edge 対の順序逆転 (= 分散後クロス) を防ぐ。 +-- | [日本語]: 扇順序の「進入回廊」 を測る端からの弧長 (pt)。 局所接線より遠くで測ることで +-- 近接方向 edge 対の順序逆転 (= 分散後クロス) を防ぐ。 +-- [English]: The arc length (pt) from the endpoint used to measure the +-- "approach corridor" for fan ordering. Measuring farther out than the +-- local tangent prevents order reversal (crossing after fanning) for edge +-- pairs with similar directions. portBackDist :: Double portBackDist = 20.0 --- | 整列済みリストを隣接述語で連結 cluster に分割する。 +-- | [日本語]: 整列済みリストを隣接述語で連結 cluster に分割する。 +-- [English]: Splits a sorted list into contiguous clusters using an +-- adjacency predicate. clusterBy :: (a -> a -> Bool) -> [a] -> [[a]] clusterBy _ [] = [] clusterBy eq (x : xs) = go [x] xs @@ -949,7 +1215,8 @@ | otherwise = reverse acc : go [y] ys go [] _ = [] --- | 挿入ソート (射影キー・小規模用)。 +-- | [日本語]: 挿入ソート (射影キー・小規模用)。 +-- [English]: Insertion sort on a projected key, for small lists. sortOnD :: Ord b => (a -> b) -> [a] -> [a] sortOnD f = foldr ins [] where @@ -957,7 +1224,9 @@ ins x (z : zs) | f x <= f z = x : z : zs | otherwise = z : ins x zs --- | Text の重複除去 (順序保持・小規模用)。 +-- | [日本語]: Text の重複除去 (順序保持・小規模用)。 +-- [English]: Deduplicates a list of Text values (order-preserving, for +-- small lists). dedupTexts :: [Text] -> [Text] dedupTexts = go [] where @@ -965,10 +1234,16 @@ 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 方向へ伸ばし、 --- 形状境界との交点を解析的に計算。 +-- | [日本語]: edge と node 形状の正確な交点を返す (= 矢印 port)。 +-- @nodeAt@ = node 中心 (screen 座標)、 @target@ = edge 反対側 (= 方向決定用)、 +-- @baseR@ = node の size scale。 楕円 / 矩形いずれも中心から target 方向へ伸ばし、 +-- 形状境界との交点を解析的に計算。 +-- [English]: Returns the exact intersection point of an edge with a node's +-- shape (the arrowhead port). @nodeAt@ is the node center (screen +-- coordinates), @target@ is the edge's opposite end (used to determine +-- direction), and @baseR@ is the node's size scale. For both ellipses and +-- rectangles, it extends a ray from the center toward @target@ and computes +-- its intersection with the shape boundary analytically. edgePortPoint :: DAGNode -> Point -> Point -> Double -> Point edgePortPoint n (Point cx cy) (Point tx ty) baseR = let (rx, ry) = nodeExtent n baseR -- ★A15-1: renderNode と同じ可変サイズを共有 @@ -993,13 +1268,22 @@ 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@ は最小サイズの下限。 +-- | [日本語]: DAG ノードの半径 (rx, ry) を label 文字幅に合わせて算出する。 +-- 'Graphics.Hgg.Render.Special.renderNode' と 'edgePortPoint' が共有し、 形状端と edge port を一致させる。 +-- deterministic は dist sublabel を出さない (= 1 行)。 @baseR@ は最小サイズの下限。 -- --- Phase 39 P8 A4-2: 横半幅 rx の本体 (radius 非依存部) は layout と共有する --- 'dagNodeBaseHalfWidth' に一本化した。 ここでは render-time に既知の baseR --- (= radius) を floor として被せるだけ。 +-- 横半幅 rx の本体 (radius 非依存部) は layout と共有する +-- 'Graphics.Hgg.Layout.dagNodeBaseHalfWidth' に一本化した。 ここでは render-time に既知の baseR +-- (= radius) を floor として被せるだけ。 +-- [English]: Computes a DAG node's radii (rx, ry) to fit the label text +-- width. Shared by 'Graphics.Hgg.Render.Special.renderNode' and 'edgePortPoint' so the shape's edge and +-- the edge port agree. A deterministic node shows no dist sublabel (a +-- single line). @baseR@ is the lower bound on the minimum size. +-- +-- The body of the horizontal half-width rx (the radius-independent part) +-- was consolidated into 'Graphics.Hgg.Layout.dagNodeBaseHalfWidth', which is shared with the +-- layout code. Here it simply applies the render-time-known baseR (the +-- radius) as a floor on top of that. nodeExtent :: DAGNode -> Double -> (Double, Double) nodeExtent n baseR = let showDist = nodeShowsDist n @@ -1009,22 +1293,41 @@ ry = max (baseR * 0.7) (fromIntegral nLines * lineH / 2 + 4) in (rx, ry) --- | dist sublabel (@~ Dist@) を描くか。 deterministic は派生量ゆえ分布を持たず name のみ (PyMC 慣例)。 +-- | [日本語]: dist sublabel (@~ Dist@) を描くか。 deterministic は派生量ゆえ分布を持たず name のみ (PyMC 慣例)。 +-- [English]: Whether to draw the dist sublabel (@~ Dist@). A deterministic +-- node is a derived quantity and has no distribution, so it shows only its +-- name (following PyMC convention). 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。 +-- | [日本語]: plate 枠の __実 bbox (pt 空間)__ = (xlo, boxTop, xhi, yhi)。 +-- label 帯を含む描画矩形そのもの。 'Graphics.Hgg.Render.Special.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' の包含関係から復元。 +-- 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@ の包含関係から復元。 +-- [English]: The plate frame's __actual bbox (pt space)__ = (xlo, boxTop, +-- xhi, yhi) — exactly the drawn rectangle, including the label band. Shared +-- by 'Graphics.Hgg.Render.Special.renderPlate' (drawing) and the pt-space edge router (obstacle +-- detection). Returns Nothing if the plate has no members at all. +-- +-- For a nested plate: faithfully reproduces graphviz's cluster bbox +-- computation (union the child cluster boxes with the direct members' +-- glyph boxes, then add one level's own margin) __recursively__. This makes +-- a nested plate's parent frame sit outside its children's margin (the +-- equivalent of graphviz's @CL_OFFSET@) — the old implementation +-- recomputed both parent and child from member extrema with a flat margin, +-- so the boundaries happened to coincide. A leaf plate (no children) is +-- identical to before, with @directIds = all members@ and +-- @childBoxes = []@ (pixel-identical output). A plate's direct children are +-- recovered from the containment relation among @allPlates@ by +-- 'plateChildrenOf'. plateBoxPt :: (Double -> Double -> Point) -> Double -> [(Text, DAGNode)] -> [DAGPlate] -> DAGPlate -> Maybe (Double, Double, Double, Double) @@ -1058,10 +1361,16 @@ -- 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、 という運用前提)。 +-- | [日本語]: plate @parent@ の __直接の子__ plate (= graphviz subcluster) 群。 +-- 子 = nodeIds が parent の真部分集合で、 間に別の plate を挟まない (= immediate) もの。 +-- graphviz は cluster をネスト木として保持するが、 我々は plate list の包含関係から +-- 復元する (= 内側 plate の member ⊊ 外側 plate の member、 という運用前提)。 +-- [English]: The __direct children__ of plate @parent@ (i.e. graphviz +-- subclusters). A child is one whose nodeIds are a strict subset of +-- parent's, with no other plate interposed (immediate). graphviz keeps +-- clusters as a nesting tree, but we recover it from the containment +-- relation among the plate list (assuming the convention that an inner +-- plate's members are a strict subset of an outer plate's members). plateChildrenOf :: [DAGPlate] -> DAGPlate -> [DAGPlate] plateChildrenOf allPlates parent = let strictSub q p = diff --git a/src/Graphics/Hgg/Render/Layer.hs b/src/Graphics/Hgg/Render/Layer.hs --- a/src/Graphics/Hgg/Render/Layer.hs +++ b/src/Graphics/Hgg/Render/Layer.hs @@ -4,7 +4,9 @@ -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +-- [日本語]: Render モノリス分割 (出力中立・純粋移動)。 +-- [English]: Split out of the render monolith (an output-neutral, purely +-- mechanical move). {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unused-imports #-} @@ -18,14 +20,18 @@ Track (..), solveTracks, needsLegend, effectiveLegendPos, coordOf, isPolar, polarCenter, polarPoint, + polarClipPath, + isTernary, ternaryVertices, domFrac, projectXY, projectRectData, projectBarRect, catUnitPx, AxisPlacement (..), coordXAxisPlacement, coordYAxisPlacement, coordXGridIsVertical, - legendBaseSize, legendKeyW, legendKeyPitch, + effectiveHalfLine, effectiveLegendBaseSize, + effectiveLegendKeyW, effectiveLegendKeyPitch, textWidthEm, legendGuideWidth, numToText, nubKeep, findColorEnc, - effectiveLegendTitle, allColorCategories, + effectiveLegendTitle, legendOrder, + allColorCategories, LegendGuide(..), collectGuides) import Graphics.Hgg.Layout.RangeOf (qqPoints, ecdfPoints) -- Phase 11 A6-2/A6-4 import Graphics.Hgg.Layout.Grid (GridCell (..), GridPlacement (..), @@ -47,7 +53,7 @@ Position (..), Coord (..), FacetScales (..), freeScaleX, freeScaleY, FacetSpace (..), freeSpaceX, freeSpaceY, - ThemeOverride (..), + ThemeOverride (..), TagStyle (..), VisualSpec (..), YAxisSide (..), axisFormatOf, applyDiscreteLimits, ridgeAutoFlip, selectedSubplots, axisRotateOf, resolveAxisAngle, axisShowTicksOf, @@ -55,7 +61,8 @@ axShowGrid, FontSpec (..), orderedCats, colRefName, resolveCol, resolveNum, - compositeLanes, inlineCat) + compositeLanes, inlineCat, reindexLayer) +import Data.Char (chr, ord) import Data.Maybe (mapMaybe, isJust, listToMaybe) import Data.List (sortOn, foldl') import qualified Data.Map.Strict as Map @@ -78,8 +85,11 @@ import Graphics.Hgg.Render.Special --- | spec → primitive 列。 layer ごとに mark kind に応じた変換 + 背景 + --- title / xLabel / yLabel + 軸 + tick + (Phase 26 §C-2 #12) facet panel grid。 +-- | [日本語]: spec → primitive 列。 layer ごとに mark kind に応じた変換 + 背景 + +-- title / xLabel / yLabel + 軸 + tick + facet panel grid。 +-- [English]: Converts a spec into a list of primitives. For each layer, +-- dispatches on mark kind, then adds the background, title / xLabel / +-- yLabel, axes, ticks, and facet panel grid lines. renderToPrimitives :: Resolver -> Layout -> VisualSpec -> [Primitive] renderToPrimitives r layout spec0 | isDAGOnly spec = renderDAGOnly layout spec -- ★ §E-6 DAG 専用 path @@ -100,7 +110,8 @@ hasFacetGrid = isJust (getLast (vsFacetRow spec)) || isJust (getLast (vsFacetCol spec)) --- | Pie 専用 spec か判定 (= 全 layer が MPie)。 +-- | [日本語]: Pie 専用 spec か判定 (= 全 layer が MPie)。 +-- [English]: Checks whether a spec is pie-only (all layers are 'MPie'). isPieOnly :: VisualSpec -> Bool isPieOnly spec = case vsLayers spec of [] -> False @@ -108,8 +119,11 @@ Just MPie -> True _ -> False) ls --- | Phase 8 B1: pie 専用描画 (= 軸 / tick / grid 無し、 PS renderPieOnly と同型)。 --- 背景 + title だけ描き、 扇形 + 項目名ラベルは renderPie に委譲。 +-- | [日本語]: pie 専用描画 (= 軸 / tick / grid 無し、 PS renderPieOnly と同型)。 +-- 背景 + title だけ描き、 扇形 + 項目名ラベルは renderPie に委譲。 +-- [English]: Draws pie charts standalone (no axes / ticks / grid, matching +-- PS renderPieOnly). Draws only the background and title; wedges and +-- category-name labels are delegated to 'renderPie'. renderPieStandalone :: Resolver -> Layout -> VisualSpec -> [Primitive] renderPieStandalone r layout spec = let pal = specThemePalette spec @@ -117,7 +131,8 @@ <> labels layout spec pal <> concatMap (renderPie r layout pal) (vsLayers spec) --- | Ess 専用 spec か判定 (= 全 layer が MEss)。 +-- | [日本語]: Ess 専用 spec か判定 (= 全 layer が MEss)。 +-- [English]: Checks whether a spec is ESS-only (all layers are 'MEss'). isEssOnly :: VisualSpec -> Bool isEssOnly spec = case vsLayers spec of [] -> False @@ -125,8 +140,12 @@ Just MEss -> True _ -> False) ls --- | Phase 8 B13: ess 専用描画。 x = 名前 (categorical) / y = ESS 値で軸が転置するため --- Layout の tickMarks (x=値前提) を使わず、 renderESS が自前で軸 + y 目盛り + 名前を描く。 +-- | [日本語]: ess 専用描画。 x = 名前 (categorical) / y = ESS 値で軸が転置するため +-- Layout の tickMarks (x=値前提) を使わず、 renderESS が自前で軸 + y 目盛り + 名前を描く。 +-- [English]: Draws ESS plots standalone. Since x = name (categorical) and +-- y = ESS value transposes the axes, this bypasses Layout's tickMarks +-- (which assume x = value); 'renderESS' draws its own axis plus y ticks +-- and names. renderEssStandalone :: Resolver -> Layout -> VisualSpec -> [Primitive] renderEssStandalone r layout spec = let pal = specThemePalette spec @@ -134,7 +153,9 @@ <> labels layout spec pal <> concatMap (renderESS r layout pal) (vsLayers spec) --- | Autocorr 専用 spec か判定 (= 全 layer が MAutocorr)。 +-- | [日本語]: Autocorr 専用 spec か判定 (= 全 layer が MAutocorr)。 +-- [English]: Checks whether a spec is autocorr-only (all layers are +-- 'MAutocorr'). isAutocorrOnly :: VisualSpec -> Bool isAutocorrOnly spec = case vsLayers spec of [] -> False @@ -142,8 +163,12 @@ Just MAutocorr -> True _ -> False) ls --- | Phase 8 B12: autocorr 専用描画。 x = lag / y = 相関で軸が転置するため Layout の --- tickMarks (x=値前提) を使わず、 renderAutocorr が自前で軸 + lag/相関 を描く。 +-- | [日本語]: autocorr 専用描画。 x = lag / y = 相関で軸が転置するため Layout の +-- tickMarks (x=値前提) を使わず、 renderAutocorr が自前で軸 + lag/相関 を描く。 +-- [English]: Draws autocorrelation plots standalone. Since x = lag and +-- y = correlation transposes the axes, this bypasses Layout's tickMarks +-- (which assume x = value); 'renderAutocorr' draws its own axis plus +-- lag/correlation ticks. renderAutocorrStandalone :: Resolver -> Layout -> VisualSpec -> [Primitive] renderAutocorrStandalone r layout spec = let pal = specThemePalette spec @@ -151,23 +176,48 @@ <> 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 回だけ確保するだけになり、 任意の深さで本体が整列する。 +-- | [日本語]: subplots layout (= 任意 spec を grid 並列)。 +-- ★ (統一グリッド): 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 分岐)。 +-- gtable 配置 (patchwork 流): 各 leaf を span を含む推定セル寸法で独立 computeLayout し、 +-- 必要マージンを得る。 列ごとに左右帯 = 最大マージン (始まり列 / 終わり列で集約)、 行ごとに +-- 上下帯 = 最大マージンを 1 回確保し、 残りをパネル本体として列/行で均等割り。 span パネルの +-- 本体はまたぐ列/行の本体 + 内側帯 + pad を内包する。 container 自身の phantom 軸マージンは +-- 既に除去済 (Layout の isContainer 分岐)。 -- --- ★既知の制約: 平坦化は leaf のみを残すため、 ネスト中間の subplots ノードに付けた --- title/theme は描かれない (operator チェーンの中間ノードは純粋な構造なので通常問題ない。 --- 全体 theme は top spec から themeCtx で全 leaf に伝播する)。 +-- ★既知の制約: 平坦化は leaf のみを残すため、 ネスト中間の subplots ノードに付けた +-- title/theme は描かれない (operator チェーンの中間ノードは純粋な構造なので通常問題ない。 +-- 全体 theme は top spec から themeCtx で全 leaf に伝播する)。 +-- [English]: Lays out subplots (tiles arbitrary specs into a grid). +-- (unified grid): flattens the nesting of vsSubplots / @<->@ / @<:>@ via +-- 'flattenSubplots' into a __single grid__, assigning each leaf panel +-- @(rowStart,rowSpan,colStart,colSpan)@. The previous implementation had +-- each subplots level build its own independent grid and recursed through +-- nesting in renderToPrimitives, so panel bodies did not align across +-- nesting boundaries. With flattening, rendering only needs to reserve +-- "left/right bands per column, top/bottom bands per row" once for this +-- single grid, so bodies align regardless of nesting depth. +-- +-- gtable placement (patchwork-style): each leaf is independently run +-- through computeLayout at its estimated cell size (including span) to +-- obtain its required margins. Per column, the left/right band is the +-- maximum margin (aggregated over the starting/ending column); per row, +-- the top/bottom band is likewise the maximum margin, reserved once; the +-- remainder is split evenly across columns/rows as the panel body. A +-- spanning panel's body encloses the bodies of the columns/rows it spans +-- plus the inner bands and padding. The container's own phantom axis +-- margin has already been removed (the isContainer branch in Layout). +-- +-- __Known limitation__: since flattening keeps only leaves, a +-- title/theme set on an intermediate subplots node in the nesting is not +-- drawn (intermediate nodes in the operator chain are purely structural, +-- so this is usually not an issue; the overall theme propagates from the +-- top spec to every leaf via themeCtx). renderSubplots :: Resolver -> Layout -> VisualSpec -> [Primitive] renderSubplots r parentLayout spec = let pal = specThemePalette spec @@ -183,16 +233,36 @@ gp = flattenSubplots spec gcols = gpCols gp grows = gpRows gp - panels = gpPanels gp -- [(leaf spec, GridCell)] + panels0 = gpPanels gp -- [(leaf spec, GridCell)] + -- ★ Phase 63 A7: panel 自動タグ (subplotTags = cowplot plot_grid labels="AUTO")。 + -- panel 列挙順に vsTag を注入する。 panel 自身の vsTag 明示指定が優先 + -- (Last の右勝ち = 個別 > 一括)。 注入位置を panels にすることで、 + -- computeLayout の margin 予約 (labsTagExtra) と labels の tag 描画が + -- 同じ tagged spec を見る (= 予約と描画の単一情報源)。 + panels = case getLast (vsSubplotTags spec) of + Nothing -> panels0 + Just sty -> [ (sub { vsTag = Last (Just (tagTextFor sty i)) <> vsTag sub }, c) + | (i, (sub, c)) <- zip [0 ..] panels0 ] 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) + -- ★ Phase 63 A13: half_line = base/2 派生へ (既定 11 で従来と bit 同値)。 + pad = effectiveHalfLine spec * lpMarginScale parentLayout + -- ★ Phase 63 A6: 列/行の相対サイズ (subplotWidths/Heights = cowplot rel_widths/ + -- rel_heights)。 グリッド数に対して不足分は 1 で埋める。 未指定 = 全て 1 で + -- 従来の等分と同値。 推定寸法 (margin 算出用) と本体分割の両方を同じ重みで割る。 + weightsFor mws n = take n (maybe [] id (getLast mws) ++ repeat 1) + colWs = weightsFor (vsSubplotWidths spec) gcols + rowWs = weightsFor (vsSubplotHeights spec) grows + colWSum = sum colWs + rowWSum = sum rowWs + -- 重み付きの単一セル寸法 (帯算出前の margin 推定用)。 + estColWOf j = (rW area - pad * fromIntegral (gcols - 1)) * (colWs !! j) / colWSum + estRowHOf i = (rH area - pad * fromIntegral (grows - 1)) * (rowWs !! i) / rowWSum + -- span を含む panel の推定寸法 (= またぐ列/行の本体 + 内側 pad)。 + estWOf c = sum [ estColWOf k | k <- [gcCol c .. gcCol c + gcColSpan c - 1] ] + + pad * fromIntegral (gcColSpan c - 1) + estHOf c = sum [ estRowHOf k | k <- [gcRow c .. gcRow c + gcRowSpan c - 1] ] + + 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)) })) @@ -210,16 +280,19 @@ 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 + -- ★ Phase 63 A6: 本体を重みで分割 (全重み 1 なら旧 等分 bodyW/bodyH と同値)。 + bodyTotalW = rW area - sumLR - pad * fromIntegral (gcols - 1) + bodyTotalH = rH area - sumTB - pad * fromIntegral (grows - 1) + colBodyW j = max 1 (bodyTotalW * (colWs !! j) / colWSum) + rowBodyH i = max 1 (bodyTotalH * (rowWs !! i) / rowWSum) + colBodyX j = rX area + sum [ colLeft k + colBodyW k + colRight k + pad | k <- [0 .. j - 1] ] + colLeft j + rowBodyY i = rY area + sum [ rowTop k + rowBodyH k + 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 + x0 = colBodyX c0; x1 = colBodyX c1 + colBodyW c1 + y0 = rowBodyY r0; y1 = rowBodyY r1 + rowBodyH r1 in Rect x0 y0 (x1 - x0) (y1 - y0) bg = background parentLayout pal -- Phase 11 A5-a: subtitle/caption/tag も labels で描く (= title 同様に root レベル)。 @@ -229,7 +302,7 @@ -- 飛び出す (subplots / hbm 図のタイトル不揃い)。 通常図の「タイトル = y 軸線に揃う」 -- と統一。 rY/rH は親のまま (= タイトルは上端・caption は下端のまま)。 gridLeft = colBodyX 0 - gridRight = colBodyX (gcols - 1) + bodyW + gridRight = colBodyX (gcols - 1) + colBodyW (gcols - 1) titleLayout = parentLayout { lpPlotArea = (lpPlotArea parentLayout) { rX = gridLeft, rW = gridRight - gridLeft } } title = case ( getLast (vsTitle spec), getLast (vsSubtitle spec) @@ -257,7 +330,27 @@ ] in bg <> title <> subPrims --- | DAG 専用 spec か判定 (= 全 layer が MDAG)。 +-- | [日本語]: 'TagStyle' と panel index (0 始まり) から自動タグ文字列を作る。 +-- 26 panel 超は spreadsheet 流 bijective 26 進 (\"Z\" の次は \"AA\") で総関数にする +-- (cowplot は LETTERS 超過で NA だが、 「エラーにしない」 方針に合わせる)。 +-- [English]: Builds the auto-tag string from a 'TagStyle' and a +-- zero-based panel index. Past 26 panels, this uses spreadsheet-style +-- bijective base-26 (after \"Z\" comes \"AA\") so the function stays +-- total (cowplot yields NA past LETTERS, but this follows the "never +-- error" policy instead). +tagTextFor :: TagStyle -> Int -> Text +tagTextFor TagNumeric i = T.pack (show (i + 1)) +tagTextFor TagUpper i = alphaTagFor 'A' i +tagTextFor TagLower i = alphaTagFor 'a' i + +alphaTagFor :: Char -> Int -> Text +alphaTagFor base = T.pack . reverse . go + where + go n = let (q, rest) = n `divMod` 26 + in chr (ord base + rest) : if q == 0 then [] else go (q - 1) + +-- | [日本語]: DAG 専用 spec か判定 (= 全 layer が MDAG)。 +-- [English]: Checks whether a spec is DAG-only (all layers are 'MDAG'). isDAGOnly :: VisualSpec -> Bool isDAGOnly spec = case vsLayers spec of [] -> False @@ -265,16 +358,32 @@ Just MDAG -> True _ -> False) ls --- | DAG 専用描画。 ★Phase 52: 他のプロット ('renderSingle') と**同じ枠組み**に統一した。 --- 'computeLayout' が確保した 'lpPlotArea' (= title 帯 + 軸目盛りマージンを引いた軸内領域) に --- DAG を描き、 title も 'labels' で標準位置 (他パネルと同じ高さ) に描く。 ただし**軸・グリッド・ --- 枠・目盛り・軸タイトルは一切描かない** (= DAG では常に非表示)。 'labels' は title のみ描く --- (DAG spec は xLabel/yLabel を持たないので軸タイトルは出ない)。 +-- | [日本語]: DAG 専用描画。 ★他のプロット ('renderSingle') と__同じ枠組み__に統一した。 +-- 'Graphics.Hgg.Layout.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 特例も本統一で不要に)。 +-- これにより DAG パネルの title 位置・plot area 枠が他パネルと揃う (subplot セルでも同じ: +-- 'labels' は viewport でなく lpPlotArea ± margin 基準で配置するため・'lpPlotArea' は親が +-- panelRect に retarget 済)。 旧実装は viewport±pad で独自に area/title を作っており、 DAG +-- だけ title がずれ、 入れ子セルから漏れていた (旧来の viewport 特例も本統一で不要に)。 +-- [English]: Draws DAGs standalone. Unified with the __same framework__ +-- as other plots ('renderSingle'). Draws the DAG inside the 'lpPlotArea' +-- reserved by 'Graphics.Hgg.Layout.computeLayout' (the in-axis region after subtracting the +-- title band and axis-tick margins), and draws the title at the standard +-- position via 'labels' (the same height as other panels). However, +-- __axes, grid, frame, ticks, and axis titles are never drawn__ (always +-- hidden for DAGs). 'labels' draws only the title (a DAG spec has no +-- xLabel/yLabel, so no axis title appears). +-- +-- This keeps a DAG panel's title position and plot-area frame aligned +-- with other panels (the same holds inside subplot cells: 'labels' +-- positions relative to lpPlotArea ± margin rather than the viewport, and +-- the parent has already retargeted 'lpPlotArea' to the panelRect). The +-- previous implementation built its own area/title from viewport±pad, +-- which made only the DAG title drift and leak out of nested cells (the +-- old viewport special-case is no longer needed under this unification). renderDAGOnly :: Layout -> VisualSpec -> [Primitive] renderDAGOnly layout spec = let pal = specThemePalette spec @@ -300,15 +409,27 @@ -- (= 範囲外データが panel 外にはみ出すのを防ぐ)。 未指定では従来同一 (ゼロ diff)。 hasCoordLim = getLast (vsCoordXLim spec) /= Nothing || getLast (vsCoordYLim spec) /= Nothing + -- ★ Phase 64 A8 (B-2): polar は常に外周円で clip する。 それまでは + -- coordXLim/YLim 指定時の矩形 clip しか無く、 半径が範囲外の点が + -- 外周円の外にはみ出して描かれていた。 coordClip prims + | polar = PClipPath [ Point x y | (x, y) <- polarClipPath mainLayout ] + : prims ++ [PClipPop] + -- ★ Phase 64 A12: ternary は正三角形で clip (辺をまたぐ line/area を辺で切る)。 + | ternary = let ((ax, ay), (bx, by), (cx, cy)) = ternaryVertices mainLayout + in PClipPath [Point ax ay, Point bx by, Point cx cy] + : prims ++ [PClipPop] | hasCoordLim = PClipPush (lpPlotArea mainLayout) : prims ++ [PClipPop] | otherwise = prims -- Phase 11 A7-c: 極座標は直交 grid/枠/tick の代わりに polarGrid (同心円 + スポーク)。 + -- Phase 64 A12: 三角座標は ternaryGrid (三角形外周 + 3 方向格子線 + 三辺 tick)。 polar = isPolar (coordOf spec) + ternary = isTernary (coordOf spec) gridAxisPrims | polar = polarGrid spec mainLayout pal + | ternary = ternaryGrid spec mainLayout pal | otherwise = gridLines mainLayout spec pal - <> axisFrame mainLayout pal + <> axisFrame (effectiveAxisLineWidth (vsThemeOverride spec)) 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。 @@ -322,7 +443,7 @@ <> 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)) + <> renderRightYAxis (effectiveAxisLineWidth (vsThemeOverride spec)) mainLayout pal (axisFormatOf (vsYAxisRight spec)) <> concatMap (renderRefLine annotDpi mainLayout pal) (vsRefLines spec) <> concatMap (renderAnnotation annotDpi mainLayout pal) (vsAnnotations spec) <> renderLegend r mainLayout pal spec @@ -330,8 +451,11 @@ -- 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 を描く。 +-- | [日本語]: scatter の周辺に X/Y histogram を sub-plot として配置。 +-- main plot area を縮めて余白に小さな histogram を描く。 +-- [English]: Places X/Y histograms as sub-plots around a scatter plot. +-- Shrinks the main plot area and draws the small histograms into the +-- freed margin. applyMarginal :: Resolver -> ThemePalette -> Layout -> VisualSpec -> (Layout, [Primitive]) applyMarginal r pal layout spec = case getLast (vsMarginal spec) of Nothing -> (layout, []) @@ -379,9 +503,13 @@ else [] in (mainLayout, xPrims <> yPrims) --- | 単一 ColRef を histogram として与えられた area に描画。 --- isVertical=False (= X marginal、 上に置く、 bar は縦)、 --- isVertical=True (= Y marginal、 右に置く、 bar は横)。 +-- | [日本語]: 単一 ColRef を histogram として与えられた area に描画。 +-- isVertical=False (= X marginal、 上に置く、 bar は縦)、 +-- isVertical=True (= Y marginal、 右に置く、 bar は横)。 +-- [English]: Draws a single 'ColRef' as a histogram into the given area. +-- isVertical=False draws the X marginal (placed above, vertical bars); +-- isVertical=True draws the Y marginal (placed to the right, horizontal +-- bars). 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 @@ -416,24 +544,29 @@ (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 --- 軸の縮尺対応は後続)。 +-- | [日本語]: facet 列の distinct 値ごとに plot area を grid 分割し、 +-- 各セルに「その facet 値だけの sub-resolver」 で sub-spec を描画。 +-- 簡易実装: 1 行 N 列 (= horizontal flow)、 各 panel は独立 axis (= shared +-- 軸の縮尺対応は後続)。 +-- [English]: Splits the plot area into a grid for each distinct value of +-- the facet column, drawing the sub-spec in each cell with a sub-resolver +-- restricted to that facet value's rows. Simple implementation: 1 row × N +-- columns (horizontal flow); each panel has an independent axis (shared +-- axis scaling support comes later). renderFaceted :: Resolver -> Layout -> VisualSpec -> ColRef -> [Primitive] renderFaceted r layout spec facetCol = let pal = specThemePalette spec + -- Phase 62 A2: facet 行 vec は facetVecOf に一元化 (subsetInlineSpec と共有)。 + facetVec = facetVecOf r facetCol + nFacet = length facetVec -- 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 -> [] + facetVals = orderedCats facetVec 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 + gutter = effectiveHalfLine spec * lpMarginScale layout -- ★ A13: base 派生 headerH = 18 -- panel 上の strip label (群名) 用 -- Phase 8 C G7: facet_wrap 複数行。 vsFacetNcol 未指定 = 1 行 N 列 (非破壊)、 -- 指定 = n 列で nRows = ceil(nPanels/n) 行に折り返す。 軸 drop は ggplot 流に @@ -485,9 +618,12 @@ -- 全 panel が重なって左/中央が空に見える)。 panelArea = Rect cellX panelTop cellW panelH subResolver = filterResolver r facetCol val + -- Phase 62 A2: inline encoding は Resolver を通らないため、 spec 側も + -- 同じ keepIdx で部分列化する (基準の一元化 = facetVecOf/facetKeepIdx)。 + specSub = subsetInlineSpec nFacet (facetKeepIdx facetVec val) specPanel -- free な軸の domain は panel 自身のデータで再計算 (fixed は parent layout)。 panelDomLayout - | freeX || freeY = computeLayout subResolver specPanel + | freeX || freeY = computeLayout subResolver specSub | otherwise = layout xSrc = if freeX then panelDomLayout else layout ySrc = if freeY then panelDomLayout else layout @@ -528,11 +664,11 @@ (mkFontTS (Just spec) pal TickF AnchorMiddle 0) ] in header <> panelBackground subLayout pal - <> axisFrame subLayout pal + <> axisFrame (effectiveAxisLineWidth (vsThemeOverride spec)) 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) + <> concatMap (renderLayer subResolver subLayout pal) (vsLayers specSub) in background layout pal <> labels layout spec pal <> concatMap panelFor (zip [0..] facetVals) @@ -540,29 +676,39 @@ -- computeLayout 側で行うので baseArea は既に凡例ぶん縮んでいる。 <> renderLegend r layout pal spec --- | Phase 8 C G7 part-b: facet_grid(row ~ col)。 2 変数 cross 配置。 +-- | [日本語]: 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 同様、 値比較可)。 +-- [English]: Implements facet_grid(row ~ col) — a two-variable cross +-- layout. Rows come from the distinct levels of the row variable, columns +-- from the distinct levels of the col variable; panel(r,c) is drawn only +-- from rows that satisfy both conditions (row==rowVal && col==colVal). +-- Strips appear on top (col name, once per column head) and on the right +-- (row name, once per row end, drawn vertically); axes appear only on the +-- bottom row (x) and leftmost column (y) — ggplot's default inner-axis +-- drop for facet_grid. If only one of row/col is given, the grid becomes +-- a single row (col only) or a single column (row only). All panels share +-- the same scale (as with 'renderFaceted', values remain comparable). 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 + -- Phase 62 A2: 行 vec は facetVecOf に一元化 (subsetInlineSpec と共有)。 + rowVec = maybe [] (facetVecOf r) mRowCol + colVec = maybe [] (facetVecOf r) mColCol + -- Phase 28: facet_grid もアルファベット順 + rowVals = if isJust mRowCol then orderedCats rowVec else [""] + colVals = if isJust mColCol then orderedCats colVec else [""] 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 + gutter = effectiveHalfLine spec * lpMarginScale layout -- ★ A13: base 派生 hasRowStrip = isJust mRowCol hasColStrip = isJust mColCol stripTopH = if hasColStrip then 18 else 0 @@ -576,12 +722,20 @@ facetSp = maybe SpaceFixed id (getLast (vsFacetSpace spec)) spX = freeSpaceX facetSp spY = freeSpaceY facetSp + -- Phase 62 A2: grid の facet 列長 (行/列とも同じ元データ行数。 片方のみ指定 + -- なら在る方)。 inline 部分列化の対象判定 n に使う。 + nFacetG = max (length rowVec) (length colVec) + -- 片軸のみの keepIdx (free-scale domain 用) と、 row×col 交差の keepIdx。 + keepIdxCol cv = if null colVec then [0 .. nFacetG - 1] + else facetKeepIdx colVec cv + keepIdxRow rv = if null rowVec then [0 .. nFacetG - 1] + else facetKeepIdx rowVec rv colDomLayout c = let cv = colVals !! c res = maybe r (\cc -> filterResolver r cc cv) mColCol - in computeLayout res specPanel + in computeLayout res (subsetInlineSpec nFacetG (keepIdxCol cv) specPanel) rowDomLayout rr = let rv = rowVals !! rr res = maybe r (\rc -> filterResolver r rc rv) mRowCol - in computeLayout res specPanel + in computeLayout res (subsetInlineSpec nFacetG (keepIdxRow rv) 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)) @@ -658,6 +812,11 @@ applyRow res = maybe res (\rc -> filterResolver res rc rowVal) mRowCol applyCol res = maybe res (\cc -> filterResolver res cc colVal) mColCol subResolver = applyCol (applyRow r) + -- Phase 62 A2: inline encoding 用の spec 側部分列化 (row∩col の交差)。 + keepIdxRC = [ i | i <- [0 .. nFacetG - 1] + , null rowVec || rowVec !! i == rowVal + , null colVec || colVec !! i == colVal ] + specSub = subsetInlineSpec nFacetG keepIdxRC specPanel isLeft = col == 0 -- y tick は左端列のみ isBottom = row == nRows - 1 -- x tick は最下行のみ -- Phase 10 A5 ②-fix: flip で軸転置に合わせ内側軸 drop の gating を入替 (renderFaceted と同様)。 @@ -665,39 +824,81 @@ CoordFlip -> (isLeft, isBottom) _ -> (isBottom, isLeft) in panelBackground subLayout pal - <> axisFrame subLayout pal + <> axisFrame (effectiveAxisLineWidth (vsThemeOverride spec)) 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) + <> concatMap (renderLayer subResolver subLayout pal) (vsLayers specSub) 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 で抽出。 +-- | [日本語]: facet 列を Text 行ベクタへ (keepIdx 算出の唯一の源)。 +-- 'filterResolver' (ColByName 経路) と 'subsetInlineSpec' (inline 経路) の +-- 分割基準がずれないよう、 両者ともここを通す。 +-- [English]: Converts the facet column to a Text row vector (the single +-- source used to compute keepIdx). Both 'filterResolver' (the ColByName +-- path) and 'subsetInlineSpec' (the inline path) go through here, so +-- their splitting criteria never diverge. +facetVecOf :: Resolver -> ColRef -> [Text] +facetVecOf r cr = case resolveCol r cr of + Just (TxtData v) -> V.toList v + Just (NumData v) -> map (T.pack . show) (V.toList v) + Nothing -> [] + +-- | [日本語]: facet 値 @val@ に一致する行 index。 +-- [English]: The row indices that match the facet value @val@. +facetKeepIdx :: [Text] -> Text -> [Int] +facetKeepIdx vec val = [i | (i, v) <- zip [0 ..] vec, v == val] + +-- | [日本語]: resolver wrap: facet 列が val に一致する行のみ通すフィルタ。 +-- 他列も同じ index で抽出。 +-- [English]: A resolver wrapper that filters to rows where the facet +-- column equals val; other columns are extracted using the same indices. 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] + let keepIdx = facetKeepIdx (facetVecOf base facetCol) 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 +-- | [日本語]: (§1) 'filterResolver' と対になる __spec 側の部分列化__。 +-- inline (ColNum/ColTxt) の encoding は Resolver を通らないため resolver wrap では +-- 絞れない (= facet が全 panel に同一データを描くバグの root)。 panel の keepIdx で +-- spec 直下 layer の inline 列を部分ベクタへ差し替える。 ColByName は従来通り +-- subResolver 側で絞られるので触らない ('reindexLayer' がその区別を持つ)。 +-- 長さが facet 列長 @n@ と一致する inline のみ対象 — 不一致は黙って切り詰めず +-- 据え置く (§3 = 検出して警告する側の対象)。 +-- [English]: (§1) The __spec-side counterpart__ to 'filterResolver'. +-- Inline (ColNum/ColTxt) encodings never go through a Resolver, so a +-- resolver wrap cannot restrict them (this was the root cause of the bug +-- where facets drew identical data in every panel). Using the panel's +-- keepIdx, this substitutes a partial vector for the inline columns of +-- layers directly under the spec. ColByName is left untouched, since it +-- is restricted on the subResolver side as before ('reindexLayer' knows +-- the distinction). Only inline columns whose length matches the facet +-- column length @n@ are affected — mismatches are left as-is rather than +-- silently truncated (§3 covers detecting and warning about those). +subsetInlineSpec :: Int -> [Int] -> VisualSpec -> VisualSpec +subsetInlineSpec n keepIdx sp = + sp { vsLayers = map (reindexLayer n (V.fromList keepIdx)) (vsLayers sp) } + -- --------------------------------------------------------------------------- -- Layer 別 render -- --------------------------------------------------------------------------- --- | Phase 8 B22: dual Y 軸対応の layer 描画。 layer が右軸 (lyYAxisSide = YAxisRight) --- かつ右軸 scale が存在する場合のみ、 lpYScale を右軸 scale に差し替えて描画する --- (= 右軸系列を独立 domain で位置決め)。 それ以外は通常の renderLayer。 +-- | [日本語]: dual Y 軸対応の layer 描画。 layer が右軸 (lyYAxisSide = YAxisRight) +-- かつ右軸 scale が存在する場合のみ、 lpYScale を右軸 scale に差し替えて描画する +-- (= 右軸系列を独立 domain で位置決め)。 それ以外は通常の renderLayer。 +-- [English]: Draws a layer with dual-Y-axis support. Only when the layer +-- targets the right axis (lyYAxisSide = YAxisRight) and a right-axis +-- scale exists does this swap lpYScale for the right-axis scale before +-- drawing (positioning the right-axis series on its own independent +-- domain). Otherwise it behaves like ordinary 'renderLayer'. renderLayerDual :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderLayerDual r layout pal ly = let effLayout = case (getLast (lyYAxisSide ly), lpYScaleRight layout) of @@ -705,10 +906,17 @@ _ -> layout in renderLayer r effLayout pal ly --- | ★ Phase 36 D2: 1 layer = 1 base mark + 任意個の重畳 sub-mark ('lyOverlay')。 +-- | [日本語]: ★ 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 一致。 +-- [English]: One layer = one base mark plus any number of overlaid +-- sub-marks ('lyOverlay'). After drawing the base, each sub-mark is drawn +-- "inheriting the parent's group (encX), color (colorBy), value (encY), +-- etc., but with its own kind/nudge/markWidth/side" (used for raincloud +-- plots / custom composites). If overlay is empty (an ordinary +-- single-mark layer), only the base is drawn and output stays byte-for- +-- byte identical to before. renderLayer :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderLayer r layout pal ly -- ★ Phase 36 D3: 合成が複数の値列にまたがる (= distCols) ときは、 各マークを「自分の値列名」 @@ -719,8 +927,12 @@ renderLayerBase r layout pal ly ++ concatMap (renderLayerBase r layout pal . inheritShared ly) (lyOverlay ly) --- | Phase 36 D3: distCols のレーン 1 マーク。 自分の値列名を inline カテゴリとして encX に与え、 +-- | [日本語]: distCols のレーン 1 マーク。 自分の値列名を inline カテゴリとして encX に与え、 -- 分布 renderer がそれを「列名スロット」 として大域 index に置く。 ① 非分布 mark は描画 skip。 +-- [English]: Draws one distCols lane mark. Passes its own value-column +-- name as an inline category on encX, which the distribution renderer +-- places at a global index acting as a "column-name slot". ① Non- +-- distribution marks are skipped. renderLaneMark :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderLaneMark r layout pal m | getFirst (lyKind m) `notElem` @@ -731,8 +943,13 @@ 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 側の指定を使う。 +-- | [日本語]: 親 layer の共有属性 (群・色・値・alpha 等) を sub-mark に継承させる。 kind と +-- 位置決めつまみ (nudge/markWidth/side) と overlay 自身は親から引き継がず、 sub 側の +-- 指定を使う。 +-- [English]: Has a sub-mark inherit the parent layer's shared attributes +-- (group, color, value, alpha, etc.). The kind, the positioning knobs +-- (nudge/markWidth/side), and overlay itself are not inherited from the +-- parent; the sub-mark's own values are used instead. inheritShared :: Layer -> Layer -> Layer inheritShared parent sub = let cleared = parent { lyKind = First Nothing @@ -795,10 +1012,16 @@ Just MCustom -> renderCustom r layout pal ly -- ★ Phase 51: custom mark (closure) _ -> [] -- 他 mark は §A-5 続きで段階追加 --- | ★ Phase 51: custom mark を描く。 'lyCustom' の draw closure に 'RenderCtx' を渡し、 +-- | [日本語]: ★ custom mark を描く。 'Graphics.Hgg.Spec.Layer.lyCustom' の draw closure に 'RenderCtx' を渡し、 -- 返った 'Primitive' 列をそのまま emit する (HS は registry 不要 = closure が源)。 --- 'lyCustom' が空なら no-op。 RenderCtx は scale 適用済 projection・plot 領域・resolver・ +-- 'Graphics.Hgg.Spec.Layer.lyCustom' が空なら no-op。 RenderCtx は scale 適用済 projection・plot 領域・resolver・ -- theme 既定色を提供する (authoring API)。 +-- [English]: Draws a custom mark. Passes a 'RenderCtx' to the draw +-- closure stored in 'Graphics.Hgg.Spec.Layer.lyCustom' and emits the returned 'Primitive' list +-- as-is (no registry is needed on the Haskell side — the closure is the +-- source). A no-op when 'Graphics.Hgg.Spec.Layer.lyCustom' is empty. RenderCtx provides the +-- scale-applied projection, plot area, resolver, and theme default +-- colors (the authoring API). renderCustom :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderCustom r layout pal ly = case getLast (lyCustom ly) of @@ -820,16 +1043,28 @@ -- 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)。 +-- | [日本語]: 凡例 (legend chip) を描画。 vsLegend が None なら空。 +-- 各 layer の lyColor が ColorByCol なら、 その列の distinct 値を chip として並べる。 +-- 位置は LegendPosition、 inside の場合は plotArea 内、 right/bottom は外側。 +-- [English]: Draws the legend (legend chips). Empty when vsLegend is +-- None. If a layer's lyColor is ColorByCol, that column's distinct +-- values are laid out as chips. Position is given by LegendPosition: +-- "inside" is placed within the plot area, while right/bottom are +-- placed outside it. +-- | [日本語]: legend を PS と同一ロジックで描画 (配置を ggplot に揃える)。 +-- gating は 'needsLegend' (= color encoding があれば 'Graphics.Hgg.Spec.Setters.legend' 明示なしでも auto)。 位置別に +-- Right / Bottom / Inside の sub-renderer に dispatch。 Right/Bottom は予約域 (Layout legendW/H) +-- に収まり、 Inside は panel 内に bg box 付きで描く。 色/文字は theme 連動 (mkFontTS / pal)。 +-- [English]: Draws the legend with the same logic as PS (positioning +-- matched to ggplot). Gating is via 'needsLegend' (auto-shown whenever a +-- color encoding exists, even without an explicit 'Graphics.Hgg.Spec.Setters.legend'). Dispatches +-- to a sub-renderer per position — Right / Bottom / Inside. Right/Bottom +-- fit within the reserved area (Layout's legendW/H), while Inside is +-- drawn inside the panel with a background box. Colors/text follow the +-- theme (mkFontTS / pal). renderLegend :: Resolver -> Layout -> ThemePalette -> VisualSpec -> [Primitive] renderLegend r layout pal spec = - let pos = needsLegend spec (effectiveLegendPos (vsLegend spec)) + let pos = needsLegend spec (effectiveLegendPos spec) -- ★ Phase 35: LegendRight は collectGuides 経路 (色/形の複数 guide・色無し形のみも可)。 -- Bottom/Inside は未 guide 化なので従来の単一 color enc 経路を維持。 in case pos of @@ -846,17 +1081,31 @@ LegendInsideBottomLeft -> renderLegendInside spec r layout pal enc 0 1 _ -> [] --- | 最初に見つけた color encoding を凡例化 (= PS findColorEnc)。 --- ★ Phase 38: findColorEnc / allColorCategories / effectiveLegendTitle / nubKeep / +-- | [日本語]: 最初に見つけた color encoding を凡例化 (= PS findColorEnc)。 +-- ★ findColorEnc / allColorCategories / effectiveLegendTitle / nubKeep / -- LegendGuide / collectGuides は Layout へ集約 (予約と描画の単一情報源)。 -- ここでは Layout から import して使う。 +-- [English]: Turns the first color encoding found into a legend (matches +-- PS findColorEnc). findColorEnc / allColorCategories / +-- effectiveLegendTitle / nubKeep / LegendGuide / collectGuides are all +-- consolidated into Layout (a single source shared by reservation and +-- drawing); here they are simply imported from Layout and used. --- | Phase 19 A1: 凡例の正本 ('allColorCategories' union) を glyph 側へ注入する。 --- 'lyColorCats' が空の ColorByCol レイヤにだけ union を詰める (ユーザ明示の --- 'colorCats' は非空なので上書きしない・冪等)。 'colorVector' (TODO-3d 機構) が --- この順序で palette index を引くため、 glyph と凡例 swatch が同じ正本を参照し --- `<>` 重畳・facet panel でズレない。 単一 layer では union = layer 内 nub --- (どちらも初出順) なので従来配色と一致する。 +-- | [日本語]: 凡例の正本 ('allColorCategories' union) を glyph 側へ注入する。 +-- 'lyColorCats' が空の ColorByCol レイヤにだけ union を詰める (ユーザ明示の +-- 'Graphics.Hgg.Spec.Constructors.colorCats' は非空なので上書きしない・冪等)。 'Graphics.Hgg.Render.Common.colorVector' (TODO-3d 機構) が +-- この順序で palette index を引くため、 glyph と凡例 swatch が同じ正本を参照し +-- `<>` 重畳・facet panel でズレない。 単一 layer では union = layer 内 nub +-- (どちらも初出順) なので従来配色と一致する。 +-- [English]: Injects the legend's source of truth (the union from +-- 'allColorCategories') into the glyph side. Only fills the union into +-- ColorByCol layers whose 'lyColorCats' is empty (a user-supplied +-- 'Graphics.Hgg.Spec.Constructors.colorCats' is non-empty, so it is never overwritten — idempotent). +-- Since 'Graphics.Hgg.Render.Common.colorVector' (the TODO-3d mechanism) looks up the palette index +-- by this ordering, glyphs and legend swatches reference the same source +-- of truth and never drift apart across @\<\>@ overlays or facet panels. +-- For a single layer, union == the layer's own nub (both in first-seen +-- order), so this matches the previous coloring. injectColorCats :: Resolver -> VisualSpec -> VisualSpec injectColorCats r spec = case allColorCategories r (vsLayers spec) of @@ -867,71 +1116,99 @@ 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 を入れたら復活させる。 +-- | [日本語]: 凡例タイトル (= 変数名) は常に非表示。 gallery 等で spec を JSON 化 +-- (bakeSpec) すると color 列が inline 化され列名が失われ、 PS は構造的にタイトルを出せない。 +-- HS だけ live 名 ("group") を出すと HS/PS が食い違う (= ユーザ報告)。 両方 "" に揃える +-- (legend 項目ラベル自体が自己説明的)。 将来 name 保持 bake を入れたら復活させる。 +-- [English]: The legend title (the variable name) is always hidden. When +-- a spec is serialized to JSON (bakeSpec) for the gallery and similar +-- uses, the color column becomes inline and its name is lost, so PS +-- cannot structurally show a title. If HS alone showed its live name +-- ("group"), HS and PS would disagree (a user-reported issue). Both are +-- aligned to "" instead (legend item labels are self-explanatory on +-- their own). This can be revived once a name-preserving bake exists. 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 63 A17: legendOrder は Layout へ移設 (auto-wrap の列幅計算と共有・import 済)。 --- | Phase 11 A5-c: 縦凡例の ncol (>=1)。 +-- | [日本語]: 縦凡例の ncol (>=1)。 +-- [English]: The ncol of a vertical legend (>=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))) +-- ★ Phase 63 A17: legendNrowOf/legendGridH は撤去 (bottom 凡例の列数は Layout の +-- lpLegendNCol = 予約と同一の単一情報源へ。 grid 位置は nc から直接 (mod/div))。 --- | 縦凡例グリッド: 表示 index k → (col, row)。 列優先 (column-major)、 nrows=ceil(n/ncol)。 +-- | [日本語]: 縦凡例グリッド: 表示 index k → (col, row)。 列優先 (column-major)、 nrows=ceil(n/ncol)。 -- ncol=1 なら (0, k) で従来の単一列と一致。 +-- [English]: The vertical-legend grid: display index k -> (col, row). +-- Column-major, with nrows=ceil(n/ncol). At ncol=1 this reduces to +-- (0, k), matching the previous single-column layout. 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)。 +-- | [日本語]: i 番目の categorical 色 (palette 長で wrap、 空なら default)。 +-- [English]: The categorical color at index i (wraps at palette length; +-- the default when the palette is empty). 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 の辞書に該当ラベルがあれば優先 (= 凡例と +-- | [日本語]: legend chip 色。 scale_color_manual の辞書に該当ラベルがあれば優先 (= 凡例と -- panel の色を一致させる)。 未登録は index ベースの 'legendColorAt'。 +-- [English]: The legend chip color. Prefers a matching label in the +-- scale_color_manual dictionary, if any (keeping the legend and panel +-- colors in sync). Falls back to the index-based 'legendColorAt' for +-- unregistered labels. 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 形状に従う)。 それ以外は矩形。 +-- | [日本語]: legend の color 凡例が point geom (= scatter) かどうか。 true なら +-- 色見本を panel と同じ円で描く (ggplot legend key は geom 形状に従う)。 それ以外は矩形。 +-- [English]: Whether the legend's color legend is a point geom +-- (scatter). When true, the color swatch is drawn as the same circle +-- used in the panel (ggplot legend keys follow the geom's shape); +-- otherwise a rectangle is used. 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) にして凡例だけ --- 大きくならないようにする。 +-- | [日本語]: legend の色見本 (left,top,key-size 指定)。 ★ ggplot @legend.key@ 同様 +-- 各キーに背景四角を敷き、 その上にマーカーを描く。 point geom は円 +-- (shapeBy が color と同列なら per-category の ●▲■)、 他は色付き矩形。 マーカー径は +-- __プロット中の点と同径__ (markerDiam = 解決済 lySize / 既定 1.65mm) にして凡例だけ +-- 大きくならないようにする。 +-- ★ キー背景は 'legendKeyPrim' と同じ theme 口 tpLegendKeyBg +-- ("" = 塗らない) に一本化。 旧 grey95 ハードコードは bottom/top 凡例だけ +-- 一本化から漏れていた取り残し。 +-- [English]: The legend's color swatch (given left, top, key size). +-- Like ggplot's @legend.key@, lays a background square behind each key +-- before drawing the marker on top. Point geoms are drawn as circles +-- (per-category ●▲■ when shapeBy maps to the same column as color); +-- others are drawn as colored rectangles. The marker diameter is set to +-- __the same diameter as points in the plot__ (markerDiam = the resolved +-- lySize, or the 1.65mm default) so the legend markers are not enlarged. +-- The key background is consolidated onto the same theme knob as +-- 'legendKeyPrim', tpLegendKeyBg ("" = unfilled). The old hardcoded +-- grey95 was a leftover that had been missed when the bottom/top legend +-- was consolidated onto this knob. 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 + let keyBg + | tpLegendKeyBg pal == "" = [] + | otherwise = [ PRect (Rect left top sz sz) + (FillStyle (tpLegendKeyBg pal) 1.0) Nothing ] + in (keyBg ++) $ if usePoint then let ctr = Point (left + sz / 2) (top + sz / 2) r = markerDiam / 2 -- plot 点と同じ装飾 (既定縁なし)。 旧 1pt 縁ハードコードを廃止。 @@ -941,46 +1218,63 @@ 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" + in [ marker ] + else [ PRect (Rect left top sz sz) (FillStyle col 1.0) (Just (StrokeStyle (tpAxis pal) 0.5)) ] -- ★ Phase 38: legendBaseSize / legendKeyW / legendKeyPitch は Layout へ集約 (単一情報源)。 -- ここでは Layout から import して使う (定義は Graphics.Hgg.Layout)。 --- | Phase 35: top-align 凡例ブロックの上余白 (pt)。 ggplot は右凡例を縦中央寄せするため +-- | [日本語]: top-align 凡例ブロックの上余白 (pt)。 ggplot は右凡例を縦中央寄せするため -- 直接の対応 metric は無い。 ユーザ好み (上揃え) ゆえ half_line の倍数で定義 (= 11pt ≈ 10)。 -legendTopInset :: Double -legendTopInset = 2 * ggHalfLine +-- ★ half_line = base/2 派生へ (既定 11 で従来 2×5.5 と bit 同値)。 +-- [English]: The top margin (pt) of a top-aligned legend block. ggplot +-- vertically centers the right legend, so there is no directly +-- corresponding metric; since this is a user preference (top-aligned), +-- it is defined as a multiple of half_line (11pt ≈ 10). half_line is +-- now derived as base/2 (bit-identical to the previous 2×5.5 at the +-- default of 11). +legendTopInset :: VisualSpec -> Double +legendTopInset spec = 2 * effectiveHalfLine spec --- | Phase 35: 凡例キーの描画スタイル (= ggplot draw_key 同型・geom 種で変わる)。 +-- | [日本語]: 凡例キーの描画スタイル (= ggplot draw_key 同型・geom 種で変わる)。 +-- [English]: The legend key's drawing style (mirrors ggplot's draw_key; +-- varies with the geom kind). 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 の塗り・ +-- | [日本語]: 凡例キー 1 個を (cx, cy) 中心に描く (キー灰背景は別途連続ブロックで描く)。 +-- [English]: Draws a single legend key centered at (cx, cy) (the key's +-- grey background is drawn separately as one contiguous block). +-- | [日本語]: ★ 凡例キーの装飾は 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 = +-- ★ キー 1 辺 kw は呼び手が実効値 ('effectiveLegendKeyW') で渡す +-- (pitch = keyW ゆえ引数 1 つ。 本関数は spec を持たないため)。 +-- [English]: The legend key's decoration is kept in sync with the +-- plot's points (@mLayer@ = the corresponding point layer). KeyPoint's +-- fill and stroke are consolidated onto 'markerFillFor'/'markerStrokeFor' +-- (no stroke by default). The previous implementation hardcoded a 1pt +-- stroke of the same color as the fill, which flattened fine shape +-- details such as suit-symbol notches (a mismatch with the plot). The +-- key's side length kw is passed by the caller as the effective value +-- ('effectiveLegendKeyW') — a single argument, since pitch = keyW and +-- this function itself does not hold the spec. +legendKeyPrim :: Double -> Maybe Layer -> LegendKeyStyle -> Double -> ThemePalette -> Double -> Double -> Text -> [Primitive] +legendKeyPrim kw 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) + keyRect = Rect (cx - (kw - lwInset) / 2) (cy - (kw - lwInset) / 2) + (kw - lwInset) (kw - lwInset) -- ★ Phase 32 (re-apply): legend.key 背景 (ggplot theme_grey = grey95 #F2F2F2)。 - -- symbol の背後にキーセル全体 (legendKeyW × legendKeyPitch) を塗る。 tpLegendKeyBg が + -- symbol の背後にキーセル全体 (keyW × keyW) を塗る。 tpLegendKeyBg が -- 空文字なら描かない (= 従来挙動)。 全 guide variant が legendKeyPrim 経由ゆえ 1 箇所で網羅。 keyBg | tpLegendKeyBg pal == "" = [] - | otherwise = [ PRect (Rect (cx - legendKeyW / 2) (cy - legendKeyPitch / 2) legendKeyW legendKeyPitch) + | otherwise = [ PRect (Rect (cx - kw / 2) (cy - kw / 2) kw kw) (FillStyle (tpLegendKeyBg pal) 1.0) Nothing ] in (keyBg ++) $ case style of KeyPoint mShape -> @@ -1001,8 +1295,11 @@ 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'。 +-- | [日本語]: 凡例マーカーの径 (pt)。 最初の scatter レイヤの解決済 'lySize' (= プロット点と +-- 同径)、 無ければ既定 'defaultMarkerDiameter'。 +-- [English]: The legend marker's diameter (pt): the resolved 'lySize' of +-- the first scatter layer (the same diameter as points in the plot), or +-- the 'defaultMarkerDiameter' if there is none. legendMarkerDiam :: VisualSpec -> Double legendMarkerDiam spec = case [ doubleOr (lySize l) defaultMarkerDiameter @@ -1010,10 +1307,16 @@ (d : _) -> d [] -> defaultMarkerDiameter --- | ★ Phase 34: 凡例エントリ k (= カテゴリ index) のマーカー形。 scatter レイヤが --- color と shape を **同じ列** にマップしているとき (ggplot の統合凡例) のみ、 自動 --- shape scale ('shapePalette') を k で巡回して返す。 色のみ・shape 別列 (= ggplot は --- 2 凡例) のときは Nothing (= 従来の円) にして単一 color 凡例を保つ。 +-- | [日本語]: ★ 凡例エントリ k (= カテゴリ index) のマーカー形。 scatter レイヤが +-- color と shape を __同じ列__ にマップしているとき (ggplot の統合凡例) のみ、 自動 +-- shape scale ('shapePalette') を k で巡回して返す。 色のみ・shape 別列 (= ggplot は +-- 2 凡例) のときは Nothing (= 従来の円) にして単一 color 凡例を保つ。 +-- [English]: The marker shape for legend entry k (a category index). +-- Only when a scatter layer maps color and shape to __the same column__ +-- (ggplot's combined legend) does this cycle through the automatic shape +-- scale ('shapePalette') by k. When color alone is mapped, or shape maps +-- to a different column (ggplot then shows 2 legends), returns Nothing +-- (the previous circle), keeping a single color legend. legendShapeFor :: VisualSpec -> Int -> Maybe MarkShape legendShapeFor spec k = case [ () | ly <- vsLayers spec @@ -1024,30 +1327,41 @@ (_ : _) -> Just (shapePalette !! (k `mod` length shapePalette)) [] -> Nothing --- | Phase 35: 凡例 guide (= ggplot guides)。 aesthetic ごとに 1 guide、 同一列に --- マップされた色+形は色 guide に統合 ('legendShapeFor' 経由) するので形 guide は作らない。 --- ★ Phase 38: LegendGuide / collectGuides は Layout へ集約 (import 済)。 +-- | [日本語]: 凡例 guide (= ggplot guides)。 aesthetic ごとに 1 guide、 同一列に +-- マップされた色+形は色 guide に統合 ('legendShapeFor' 経由) するので形 guide は作らない。 +-- [English]: A legend guide (mirrors ggplot's guides). One guide per +-- aesthetic; color and shape mapped to the same column are merged into +-- the color guide (via 'legendShapeFor'), so no separate shape guide is +-- created. --- | Phase 35: 1 guide を原点 (ox, oy) から描き、 (prims, ブロック高さ) を返す。 +-- | [日本語]: 1 guide を原点 (ox, oy) から描き、 (prims, ブロック高さ) を返す。 -- ブロック = [タイトル行 (凡例列名あり時)] + [エントリ行…]。 内部レイアウトは原点相対。 +-- [English]: Draws one guide starting from the origin (ox, oy), returning +-- (prims, block height). A block consists of [the title row, if a legend +-- column name exists] + [entry rows...]. The internal layout is relative +-- to the origin. 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 [] + -- pt メトリクス (ggplot 同型・マジック数を排す)。 半行 = half_line。 + -- ★ Phase 63 A13: 凡例メトリクスを base 派生の実効値へ (既定 11 で従来と bit 同値)。 + hl = effectiveHalfLine spec + lbs = effectiveLegendBaseSize spec + kw = effectiveLegendKeyW spec + kp = effectiveLegendKeyPitch spec + itemDy = lbs * 0.8 * 0.32 -- item 文字をキー中心に縦揃え + titleH = if title == "" then 0 else lbs + hl -- title 行高 (文字 + 下マージン) + header = if title == "" then [] else [ PText (Point ox (oy + lbs)) title tsTitle ] + firstCy = oy + titleH + kp / 2 -- 最初のキー中心 + labelX = ox + kw + hl / 2 -- key → label gap = half_line/2 + cyAt k = firstCy + fromIntegral k * kp + -- ★ Phase 63 A19.5: 旧 Phase 35 の「tpPanelBg 連続帯 (bgRect)」 を撤去。 ggplot に + -- キー列の連続帯という要素は無く、 凡例キー背景は legend.key = 'legendKeyPrim' の + -- keyBg (tpLegendKeyBg、 "" = 塗らない) が唯一の口。 旧帯は白背景 theme では + -- 不可視だったが、 A18 の背景透過で不透過白帯として顕在化した (root: + -- after-map 実測 RGBA(255,255,255,255))。 ThemeGrey も grey95 キーとの二重塗りを解消。 in case guide of ColorGuide (ColorByCol _cr) -> let vals = allColorCategories r (vsLayers spec) -- Phase 52.A10: 全レイヤ union @@ -1073,17 +1387,17 @@ 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 + in legendKeyPrim kw colorLayer (styleFor origI) (legendMarkerDiam spec) pal (ox + kw / 2) cy col <> [ PText (Point labelX (cy + itemDy)) label tsItem ] - in ( header <> bgRect n <> concat (zipWith chipFor [0 :: Int ..] items) - , titleH + fromIntegral n * legendKeyPitch ) + in ( header <> concat (zipWith chipFor [0 :: Int ..] items) + , titleH + fromIntegral n * kp ) 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 + barW = kw; barH = 11 * lbs; barX = ox; barY = oy + titleH nStop = 40 :: Int step = barH / fromIntegral nStop -- ★ A4-e: gradient2 指定時は発散 3-stop を bar に反映 (= 凡例も diverging palette)。 @@ -1095,7 +1409,7 @@ 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 + tickX = barX + barW + hl / 2 -- ggplot 同型: 連続凡例の目盛りは生 min/mid/max でなく Wilkinson extended -- breaks (= 軸と同じ nice 値) を範囲内に置く。 生値の長大桁を避けラベルが短くなる。 legBreaks = case filter (\b -> b >= vMin && b <= vMax) (extendedBreaks 5 vMin vMax) of @@ -1109,10 +1423,10 @@ -- ColorByContinuous と同型の gradient bar + extended breaks 目盛り、 タイトルは "count"。 CountBarGuide lo hi -> let barTitle = "count" - titleH' = legendBaseSize + ggHalfLine - header' = [ PText (Point ox (oy + legendBaseSize)) barTitle tsTitle ] + titleH' = lbs + hl + header' = [ PText (Point ox (oy + lbs)) barTitle tsTitle ] vMin = lo; vMax = hi - barW = legendKeyW; barH = 11 * legendBaseSize; barX = ox; barY = oy + titleH' + barW = kw; barH = 11 * lbs; barX = ox; barY = oy + titleH' nStop = 40 :: Int step = barH / fromIntegral nStop legendPal = lpContinuousPalette layout @@ -1121,7 +1435,7 @@ 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 + tickX = barX + barW + hl / 2 legBreaks = case filter (\b -> b >= vMin && b <= vMax) (extendedBreaks 5 vMin vMax) of [] -> [vMin, vMax] bs -> bs @@ -1142,34 +1456,48 @@ 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 + in legendKeyPrim kw (legendPointLayer spec) (KeyPoint (Just sh)) (legendMarkerDiam spec) pal (ox + kw / 2) cy inkCol <> [ PText (Point labelX (cy + itemDy)) label tsItem ] - in ( header <> bgRect n <> concat (zipWith chipFor [0..] vals) - , titleH + fromIntegral n * legendKeyPitch ) + in ( header <> concat (zipWith chipFor [0..] vals) + , titleH + fromIntegral n * kp ) --- | Phase 35: レイヤが色マップ (ColorByCol/ColorByContinuous) を持つか (= 凡例を駆動)。 +-- | [日本語]: レイヤが色マップ (ColorByCol/ColorByContinuous) を持つか (= 凡例を駆動)。 +-- [English]: Whether a layer carries a color mapping (ColorByCol/ +-- ColorByContinuous), which drives the legend. isColorMapLayer :: Layer -> Bool isColorMapLayer l = case getLast (lyColor l) of Just (ColorByCol _) -> True Just (ColorByContinuous _) -> True _ -> False --- | Phase 35: 凡例キーの装飾 (縁・hollow) を決める「代表 point レイヤ」。 色マップ層を +-- | [日本語]: 凡例キーの装飾 (縁・hollow) を決める「代表 point レイヤ」。 色マップ層を -- 優先し、 無ければ最初の scatter 層。 これを 'legendKeyPrim'/'legendSwatch' に渡し、 -- plot 点と同じ 'markerStrokeFor'/'markerFillFor' を凡例にも適用する。 +-- [English]: The "representative point layer" that decides the legend +-- key's decoration (stroke / hollow). Prefers a color-mapped layer, +-- falling back to the first scatter layer. Passed to 'legendKeyPrim'/ +-- 'legendSwatch' so that the same 'markerStrokeFor'/'markerFillFor' used +-- for plot points is also applied to the legend. 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 起点)。 +-- | [日本語]: LegendRight: panel 右の予約域に guide を縦スタック (= PS renderLegendRight)。 +-- centered=True (LegendRightCenter) なら guide スタック全体を panel 高の縦中央に揃える +-- (ggplot 既定の legend.position="right")。 False は従来の上揃え (legendTopInset 起点)。 +-- [English]: LegendRight: stacks guides vertically in the reserved area +-- to the right of the panel (matches PS renderLegendRight). When +-- centered=True (LegendRightCenter), the whole guide stack is vertically +-- centered on the panel height (ggplot's default legend.position= +-- "right"); False keeps the previous top alignment (anchored at +-- 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 + hl = effectiveHalfLine spec -- ★ A13: base 派生 (既定 11 で従来と同値) + x0 = rX area + rW area + 2 * hl -- panel→凡例 gap = ggplot legend.box.spacing = 1 line + guideGap = 2 * hl -- guide 間スペース = 1 line guides = collectGuides r spec -- shape 凡例の見出しは列名。 inline data に resolve され名前が失われた場合は -- sentinel ("<inline-txt>" / "<inline-num>") を出さず空に潰す (= color 凡例と同じ規律)。 @@ -1184,19 +1512,32 @@ 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 + y0 | centered = rY area + max (legendTopInset spec) ((rH area - totalH) / 2) + | otherwise = rY area + legendTopInset spec 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)。 +-- | [日本語]: LegendBottom: panel 下の予約域に横並び (= PS renderLegendBottom)。 +-- ★ 実位置 = panel 下端 + lpLegendYOff (Layout の bM 予約 stack と単一情報源 +-- = ticks→labels→title→legend の最外)。 旧 +50 固定は軸タイトルと逆順だった。 +-- 行 pitch も予約と同じ effectiveLegendKeyPitch。 +7 は swatch 上端 (cy-7) を +-- ブロック上端に一致させる内部 anchor (swatch/text の描画式は従来のまま)。 +-- [English]: LegendBottom: lays out entries horizontally in the reserved +-- area below the panel (matches PS renderLegendBottom). The actual +-- position is panel-bottom + lpLegendYOff (a single source shared with +-- Layout's bM reservation stack — the outermost of +-- ticks→labels→title→legend). The old hardcoded +50 was in the reverse +-- order from the axis title. The row pitch also matches the reservation +-- (effectiveLegendKeyPitch); the +7 is an internal anchor that aligns the +-- swatch's top edge (cy-7) with the block's top edge (the swatch/text +-- drawing formulas are unchanged). renderLegendBottom :: VisualSpec -> Resolver -> Layout -> ThemePalette -> ColorEnc -> [Primitive] renderLegendBottom spec r layout pal enc = let area = lpPlotArea layout - y0 = rY area + rH area + 50 + y0 = rY area + rH area + lpLegendYOff layout + 7 tsItem = mkFontTS (Just spec) pal LegendItemF AnchorStart 0 tsTitle = mkFontTS (Just spec) pal LegendTitleF AnchorStart 0 -- Phase 11 A4-c: タイトル指定時のみ先頭に表示し chip を右へずらす (未指定はゼロ diff)。 @@ -1210,20 +1551,21 @@ 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 63 A17: 列数は Layout の auto-wrap 結果 (明示 legendNrow も + -- Layout 側で解決済 = 予約 legendH と同一の単一情報源)。 + nc = max 1 (lpLegendNCol layout) + rowH = effectiveLegendKeyPitch spec -- ★ Phase 38: 各アイテムの横送りをラベル内容で算出 (旧 chipW=80 固定 → content-based)。 -- item 横幅 = swatch→label gap(14) + ラベル幅 + 列間 gap(ggHalfLine)。 - -- 列 (legendGridH の col) ごとに、 その列に入る全行アイテムの最大幅を採る。 - itemAdv lbl = 14 + tsSize tsItem * textWidthEm lbl + ggHalfLine + -- 列 (k mod nc) ごとに、 その列に入る全行アイテムの最大幅を採る + -- (Layout の legFits 列幅と同式)。 + itemAdv lbl = 14 + tsSize tsItem * textWidthEm lbl + effectiveHalfLine spec 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 + let (col, row) = (k `mod` nc, k `div` nc) -- 行優先 (旧 legendGridH と同式) 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) @@ -1231,8 +1573,11 @@ in titlePrim <> concat (zipWith chipFor [0..] items) _ -> [] --- | LegendInside: panel 内に bg box 付きで描く (= PS renderLegendInside)。 fracX/fracY は --- 0=左/上、 1=右/下。 +-- | [日本語]: LegendInside: panel 内に bg box 付きで描く (= PS renderLegendInside)。 fracX/fracY は +-- 0=左/上、 1=右/下。 +-- [English]: LegendInside: draws the legend inside the panel with a +-- background box (matches PS renderLegendInside). fracX/fracY: 0 = left/ +-- top, 1 = right/bottom. renderLegendInside :: VisualSpec -> Resolver -> Layout -> ThemePalette -> ColorEnc -> Double -> Double -> [Primitive] renderLegendInside spec r layout pal enc fracX fracY = @@ -1282,9 +1627,13 @@ -- Phase 6+ C-8: Annotation render -- =========================================================================== --- | annotation 1 個を Primitive に変換。 ★ Phase 33 B6: 座標は 'Pos' で、 --- 'resolvePosX'/'resolvePosY' (= UCtx 経由) で pt 化する。native/npc/絶対長を軸 --- ごとに混在できる。dpi は PAbs Px 解決にのみ使う (layout は pt)。 +-- | [日本語]: annotation 1 個を Primitive に変換。 ★ 座標は 'Graphics.Hgg.Unit.Pos' で、 +-- 'resolvePosX'/'resolvePosY' (= UCtx 経由) で pt 化する。native/npc/絶対長を軸 +-- ごとに混在できる。dpi は PAbs Px 解決にのみ使う (layout は pt)。 +-- [English]: Converts a single annotation into primitives. Coordinates +-- are given as 'Graphics.Hgg.Unit.Pos' and converted to pt via 'resolvePosX'/'resolvePosY' +-- (through UCtx). native/npc/absolute-length units can be mixed per +-- axis. dpi is used only to resolve PAbs Px (layout itself is in pt). renderAnnotation :: Double -> Layout -> ThemePalette -> Annotation -> [Primitive] renderAnnotation dpi layout pal ann = let uc = UCtx dpi (lpPlotArea layout) (lpXScale layout) (lpYScale layout) @@ -1321,9 +1670,13 @@ 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 の比率。 +-- | [日本語]: inset (図中図)。 子 spec を inset サイズの sub-viewport で描画し、 +-- offsetPrim で plotArea 内の (inX, inY) 位置へシフトする (= PS renderInset と同方式)。 +-- inX/inY/inW/inH は plotArea に対する 0..1 の比率。 +-- [English]: An inset (a figure within a figure). Draws the child spec +-- in a sub-viewport at the inset's size and shifts it via offsetPrim to +-- position (inX, inY) within the plot area (matches PS renderInset). +-- inX/inY/inW/inH are 0..1 fractions of the plot area. renderInset :: Resolver -> Layout -> ThemePalette -> Inset -> [Primitive] renderInset r layout pal ins = let a = lpPlotArea layout @@ -1340,7 +1693,8 @@ (Just (StrokeStyle (tpAxis pal) 0.8)) ] in frame <> inner --- | primitive を (dx, dy) 平行移動 (inset 配置用)。 +-- | [日本語]: primitive を (dx, dy) 平行移動 (inset 配置用)。 +-- [English]: Translates a primitive by (dx, dy), used to position insets. offsetPrim :: Double -> Double -> Primitive -> Primitive offsetPrim dx dy p = case p of PLine (Point x1 y1) (Point x2 y2) ls -> diff --git a/src/Graphics/Hgg/Render/MCMC.hs b/src/Graphics/Hgg/Render/MCMC.hs --- a/src/Graphics/Hgg/Render/MCMC.hs +++ b/src/Graphics/Hgg/Render/MCMC.hs @@ -1,10 +1,11 @@ -- | -- Module : Graphics.Hgg.Render.MCMC --- Description : MCMC 診断 mark (forest/funnel/autocorr/ess) +-- Description : MCMC diagnostic marks (forest, funnel, autocorrelation, ESS) -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +-- [日本語]: Render モノリス分割 (出力中立・純粋移動)。 +-- [English]: Split off from the Render monolith (output-neutral, pure move). {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unused-imports #-} @@ -21,7 +22,10 @@ domFrac, projectXY, projectRectData, projectBarRect, catUnitPx, AxisPlacement (..), coordXAxisPlacement, coordYAxisPlacement, - coordXGridIsVertical) + coordXGridIsVertical, + -- Phase 64 A4/A4-b: 参照線と棒を投影層へ通す + projectSegment, CrossLoc (..), BarShape (..), + projectCrossPoint, projectCrossBar) 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 @@ -65,12 +69,21 @@ -- 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 に頼らず自前マッピング。 +-- | [日本語]: autocorrelation plot: 1 列の時系列から lag-k 自己相関 r(τ) +-- を計算 + bar chart。 ±1.96/√N の significance band も併せて。 +-- [English]: Autocorrelation plot: computes the lag-k autocorrelation r(τ) +-- from a single time-series column and draws it as a bar chart, along with +-- the ±1.96/√N significance band. +-- | [日本語]: Autocorrelation plot: encX = 生サンプル列、 lyChain = chain (任意)。 +-- chain ごとに ACF ρ(k), k=0..maxLag を計算し、 lag を横軸に chain 別の細い棒で描く +-- (= bayesplot mcmc_acf_bar 流: ACF は plot 内で計算)。 x=lag/y=相関 で軸転置のため +-- Layout scale に頼らず自前マッピング。 +-- [English]: Autocorrelation plot: encX is the raw sample column, lyChain +-- is the chain (optional). Computes ACF ρ(k) for k=0..maxLag per chain and +-- draws thin per-chain bars along the lag axis (in the style of +-- bayesplot's mcmc_acf_bar, where the ACF is computed inside the plot). +-- Since x=lag / y=correlation transposes the axes, this uses its own +-- mapping rather than relying on the Layout scale. renderAutocorr :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderAutocorr r layout thePal ly = let xs = V.toList (vecOr (lyEncX ly) r) @@ -85,54 +98,52 @@ 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 + -- ★ Phase 64 A4-b: 自前 plotArea マッピングを撤去し投影層へ。 lag は + -- __離散スロット__ (`CrossAt k`)、 相関は value 軸 (lpYScale) として扱う。 + -- これで coordCartesianX/Y の zoom 指定が効くようになる (A4-b before 実測で + -- 従来は完全に無視されていた)。 chain は slot 内の px offset で横並び。 + coord = lpCoord layout + slotW = catUnitPx coord layout -- 1 lag ぶんの cross 軸 px + subW = slotW / fromIntegral nCh -- chain 1 本ぶんの sub-slot + barW = max 1.5 (subW * 0.7) + -- chain ci の slot 内 px offset (sub-slot 中心)。 A3 の dodge と同型。 + chainOff ci = negate (slotW / 2) + (fromIntegral ci + 0.5) * subW + -- 極座標用の data 単位半幅 (1 slot = 1 data 単位) + halfD = (0.7 / fromIntegral nCh) / 2 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 ] + mk k rk = case projectCrossBar coord layout (CrossAt (fromIntegral k)) + (chainOff ci) (barW / 2) halfD 0 rk of + BarRect rect -> PRect rect (FillStyle col 0.85) (Just (StrokeStyle col 0.5)) + BarWedge segs -> PPath segs (FillStyle col 0.85) (Just (StrokeStyle col 0.5)) + in [ mk k rk | (k, rk) <- zip [0 :: Int ..] rs ] bars = concat (zipWith drawChain [0..] groups) - -- significance band ±1.96/sqrt(N) (= 95% null) + 0 線。 value=t の参照線 (cross 軸全長)。 + -- 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 + xLoD = lsDomainLo (lpXScale layout) + xHiD = lsDomainHi (lpXScale layout) + valRefPrims t col w = + let pts = projectSegment coord layout (xLoD, t) (xHiD, t) + in [ PLine p q (solid col w) | (p, q) <- zip pts (drop 1 pts) ] + sigBand = valRefPrims 0 (tpAxis thePal) 1.0 + ++ concat [ valRefPrims sg "#888" 0.8 ++ valRefPrims (negate sg) "#888" 0.8 + | sg > 0 ] + -- value 軸目盛り (相関 -1..1)。 目盛の向きは coordYAxisPlacement で決める + -- (= 生の case coord of を持たない)。 + valAtLeft = coordYAxisPlacement coord == AxisLeft + valAnchor = if valAtLeft then AnchorEnd else AnchorMiddle tsY = mkFontTS Nothing thePal TickF valAnchor 0 + tickAnchorPt tv = projectCrossPoint coord layout (CrossAt xLoD) 0 tv 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 + , let Point ax ay = tickAnchorPt tv + , p <- if valAtLeft + then [ PLine (Point ax ay) (Point (ax - 5) ay) (solid (tpAxis thePal) 1.0) + , PText (Point (ax - 8) (ay + 4)) (numToText tv) tsY ] + else [ PLine (Point ax ay) (Point ax (ay + 5)) (solid (tpAxis thePal) 1.0) + , PText (Point ax (ay + 18)) (numToText tv) tsY ] ] + in axisFrame 1.0 layout thePal ++ yTicks ++ sigBand ++ bars -- ★ Phase 68: MCMC は theme 幅 override 非対応 = 現状 1.0 where chainGroups :: [String] -> [Double] -> [(String, [Double])] chainGroups labels values = @@ -155,10 +166,17 @@ -- 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 に頼らず自前マッピング。 +-- | [日本語]: ESS plot: encX = パラメータ/chain 名、 encY = 計算済み ESS 値。 +-- ESS 計算は統計ライブラリの責務、 plot は値を棒にするだけ (= ggplot/bayesplot 流の +-- 計算と描画の分離)。 ESS 閾値 (100/400) で色分け (赤=低い/橙=中/緑=高い)。 +-- x=名前/y=ESS で軸が転置するため Layout scale に頼らず自前マッピング。 +-- [English]: ESS plot: encX is the parameter/chain name, encY is the +-- pre-computed ESS value. ESS computation is the statistics library's +-- responsibility; the plot just turns the values into bars (following the +-- ggplot/bayesplot convention of separating computation from drawing). +-- Colored by the ESS threshold (100/400): red = low, orange = medium, +-- green = high. Since x=name / y=ESS transposes the axes, this uses its +-- own mapping rather than relying on the Layout scale. renderESS :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderESS r layout thePal ly = let names = catLabelsOf r ly @@ -170,57 +188,62 @@ 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 + -- ★ Phase 64 A4-b: autocorr と同型に投影層へ。 名前 (chain) は __離散スロット__ + -- (`CrossAt i`)、 ESS 値は value 軸 (lpYScale)。 これで coordCartesianX/Y の + -- zoom 指定が効く (従来の自前マッピングは無視していた)。 + coord = lpCoord layout + slotW = catUnitPx coord layout -- 1 名前ぶんの cross 軸 px + barW = slotW * 0.6 + halfD = 0.3 -- 極座標用の data 単位半幅 (0.6 の半分) + xLoD = lsDomainLo (lpXScale layout) + xHiD = lsDomainHi (lpXScale layout) + -- 軸の向きは placement helper で決める (= 生の case coord of を持たない) + valAtLeft = coordYAxisPlacement coord == AxisLeft + catAtBottom = coordXAxisPlacement coord == AxisBottom + catAnchor = if catAtBottom then AnchorMiddle else AnchorEnd + valAnchor = if valAtLeft then AnchorEnd else 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 下辺) + barPrim = case projectCrossBar coord layout (CrossAt (fromIntegral i)) + 0 (barW / 2) halfD 0 v of + BarRect rect -> PRect rect (FillStyle col 0.85) (Just (StrokeStyle col 0.5)) + BarWedge segs -> PPath segs (FillStyle col 0.85) (Just (StrokeStyle col 0.5)) + -- 名前ラベルは cross 軸の外側 (Cartesian = panel 下、 Flip = panel 左) + Point bx by = projectCrossPoint coord layout (CrossAt (fromIntegral i)) 0 0 + lblPt | catAtBottom = Point bx (rY area + rH area + 16) + | otherwise = Point (rX area - 6) (by + 4) + in [ barPrim, PText lblPt nm tsCat ] + -- ESS 閾値の参照線 (100 / 400)。 value=t を cross 軸全長に渡す。 + valRefPrims t = + let pts = projectSegment coord layout (xLoD, t) (xHiD, t) + in [ PLine p q (solid "#888888" 0.8) | (p, q) <- zip pts (drop 1 pts) ] + refLines = concat [ valRefPrims t | t <- [100, 400], t <= yMax ] + -- value 軸目盛り 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 + , let Point ax ay = projectCrossPoint coord layout (CrossAt xLoD) 0 tv + , p <- if valAtLeft + then [ PLine (Point ax ay) (Point (ax - 5) ay) (solid (tpAxis thePal) 1.0) + , PText (Point (ax - 8) (ay + 4)) (numToText tv) tsY ] + else [ PLine (Point ax ay) (Point ax (ay + 5)) (solid (tpAxis thePal) 1.0) + , PText (Point ax (ay + 18)) (numToText tv) tsY ] ] + in axisFrame 1.0 layout thePal ++ yTicks ++ refLines -- ★ Phase 68: MCMC は theme 幅 override 非対応 = 現状 1.0 ++ 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 線。 +-- | [日本語]: Forest plot: 各 row が「label + 点推定 + CI」 の horizontal CI bar 群。 +-- encY = label index (= 0..n-1)、 encX = estimate、 errorX = ± 半幅。 中央 vertical 線。 +-- [English]: Forest plot: each row is a horizontal CI bar showing +-- "label + point estimate + CI". encY is the label index (0..n-1), encX is +-- the estimate, and errorX is the ± half-width. Includes a central +-- vertical line. renderForest :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderForest r layout pal ly = let ests = V.toList (vecOr (lyEncX ly) r) @@ -237,16 +260,19 @@ 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 非対象 + -- ★ Phase 64 A4: glyph も参照線も投影層へ。 参照線は「data x=v を y domain 全長に + -- 渡す線分」 として 'projectSegment' に通す。 y scale の range は panel 端に + -- 一致するので直線座標系では旧 px 式と bit 一致し、 polar では radial 線/弧に + -- なる (flipOnly を撤去できた根拠)。 + coord = lpCoord layout 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) + yLo = lsDomainLo (lpYScale layout) + yHi = lsDomainHi (lpYScale layout) + refLinePrims v col = + let pts = projectSegment coord layout (v, yHi) (v, yLo) + in [ PLine p q (solid col 1.0) | (p, q) <- zip pts (drop 1 pts) ] -- 中央 null line - nullLine = let (p1, p2) = xRefLine nullX in [ PLine p1 p2 (solid "#888" 1.0) ] + nullLine = refLinePrims nullX "#888" -- 各 row: 水平 CI 線 + 点 marker rowsP = concat [ [ PLine (pp (e - err) yp) (pp (e + err) yp) (solid c 1.5) @@ -261,8 +287,11 @@ -- Phase 6 A3: Funnel plot -- =========================================================================== --- | Funnel plot (Phase 6 A3): 効果量 vs 標準誤差の散布図 + 95% envelope。 --- encX = effect、 encY = SE。 envelope は y range の最大 SE まで diagonal で描画。 +-- | [日本語]: Funnel plot: 効果量 vs 標準誤差の散布図 + 95% envelope。 +-- encX = effect、 encY = SE。 envelope は y range の最大 SE まで diagonal で描画。 +-- [English]: Funnel plot: a scatter of effect size vs. standard error plus +-- a 95% envelope. encX is the effect, encY is the SE. The envelope is +-- drawn diagonally out to the maximum SE in the y range. renderFunnel :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderFunnel r layout pal ly = let effects = V.toList (vecOr (lyEncX ly) r) @@ -275,17 +304,18 @@ 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 非対象 + -- ★ Phase 64 A4: 点・envelope 端点も mu 参照線も投影層へ (forest と同型)。 + -- 参照線は「data x=mu を y domain 全長に渡す線分」 を 'projectSegment' に通す。 + -- 直線座標系は旧 px 式と bit 一致、 polar では radial 線/弧になる。 + coord = lpCoord layout 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) + yLoF = lsDomainLo (lpYScale layout) + yHiF = lsDomainHi (lpYScale layout) 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) ] + muLine = let pts = projectSegment coord layout (mu, yHiF) (mu, yLoF) + in [ PLine p q (solid "#888" 1.0) | (p, q) <- zip pts (drop 1 pts) ] -- 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) diff --git a/src/Graphics/Hgg/Render/Special.hs b/src/Graphics/Hgg/Render/Special.hs --- a/src/Graphics/Hgg/Render/Special.hs +++ b/src/Graphics/Hgg/Render/Special.hs @@ -1,10 +1,11 @@ -- | -- Module : Graphics.Hgg.Render.Special --- Description : 特殊 mark (pie/waterfall/parallel/text/DAG) +-- Description : Special marks (pie, waterfall, parallel coordinates, text, DAG) -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +-- [日本語]: Render モノリス分割 (出力中立・純粋移動)。 +-- [English]: Split off from the Render monolith (output-neutral, pure move). {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unused-imports #-} @@ -18,8 +19,11 @@ Track (..), solveTracks, needsLegend, effectiveLegendPos, coordOf, isPolar, polarCenter, polarPoint, + isTernary, domFrac, projectXY, projectRectData, projectBarRect, catUnitPx, AxisPlacement (..), + -- Phase 64 A4: 棒を投影層の形状 dispatcher へ + BarShape (..), projectBar, coordXAxisPlacement, coordYAxisPlacement, coordXGridIsVertical, textWidthEm) import Graphics.Hgg.Layout.RangeOf (qqPoints, ecdfPoints) -- Phase 11 A6-2/A6-4 @@ -68,13 +72,24 @@ 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。 +-- | [日本語]: 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。 +-- [English]: Maps into pt space via @toScreen@ (computes a graphviz-style +-- natural aspect ratio from each node's actual size). A pure function +-- shared between rendering and routing bake; independent of area. +-- * LayoutHierarchical: dnX is the raw point x and dnY is the rank index. +-- x maps 1:1, and y = rank index times rankPitch (that is, +-- maxNodeH + ranksep) — a fully faithful point pipeline. +-- * LayoutManual: dnX/dnY are normalized to [0,1]^2. wpt is back-derived +-- from the minimum x gap within each rank so it does not collapse +-- horizontally, then expanded into pt space via wpt/hpt (graphviz-style). +-- The final 'fitPrimsToArea' uniformly fits either path into the area +-- while preserving the aspect ratio. dagToScreen :: Double -> [DAGNode] -> DAGLayoutAlgorithm -> (Double -> Double -> Point) dagToScreen radius nodes algo = toScreen where @@ -99,11 +114,18 @@ | 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)。 +-- | [日本語]: 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)。 +-- [English]: Bakes pt-space routing into the layer's DAG edges (filling in +-- 'deRoute'). Computed with the exact same steps as the edge routing +-- pipeline in 'renderDAGStandalone' (toScreen + obstacles + parallel index + +-- routeEdge), so the baked route is byte-identical to live routing. Size +-- comes from the layer's 'lySize' (default diameter 11 mm). An edge whose +-- endpoint node is missing is left as 'Nothing'. Once the resulting spec is +-- serialized to JSON, PS can draw the same routing (HS/PS parity). dagBakeRoutes :: Layer -> Layer dagBakeRoutes ly = case getLast (lyDAG ly) of Nothing -> ly @@ -142,13 +164,19 @@ 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 へ焼き込む境界)。 +-- | [日本語]: 'Graphics.Hgg.Spec.VisualSpec' 内の全 DAG layer に 'dagBakeRoutes' を適用。 +-- HS で図を生成し PS 用 JSON を吐く直前に呼ぶ (= routing を spec へ焼き込む境界)。 +-- [English]: Applies 'dagBakeRoutes' to every DAG layer in a 'Graphics.Hgg.Spec.VisualSpec'. +-- Call this right before HS generates the figure and emits JSON for PS +-- (the boundary where routing gets baked into the spec). bakeDAGRoutesInSpec :: VisualSpec -> VisualSpec bakeDAGRoutesInSpec vs = vs { vsLayers = map dagBakeRoutes (vsLayers vs) } --- | DAG 専用 (= axis 不要)。 0..1 domain 座標を area 内に直接 mapping。 --- 描画順序: plate (= 背景) → edge → node。 +-- | [日本語]: DAG 専用 (= axis 不要)。 0..1 domain 座標を area 内に直接 mapping。 +-- 描画順序: plate (= 背景) → edge → node。 +-- [English]: DAG-only rendering (no axis needed). Maps 0..1 domain +-- coordinates directly into the area. Draw order: plate (background), +-- then edge, then node. renderDAGStandalone :: Rect -> ThemePalette -> Layer -> [Primitive] renderDAGStandalone area pal ly = case getLast (lyDAG ly) of Nothing -> [] @@ -185,7 +213,7 @@ (Map.empty, []) es -- ★ Phase 42 sub C: edge に baked 'deRoute' があればそれを描画 (HS/PS で同一)、 - -- 無ければ従来どおり live 'routeEdge' で routing。 baked は同 pipeline 産なので + -- 無ければ従来どおり live 'Graphics.Hgg.Render.EdgeRoute.routeEdge' で routing。 baked は同 pipeline 産なので -- HS 出力は byte-identical。 -- ★ Phase 52 A6: 全 route 確定後に port 分散 ('spreadPorts')。 bake 済み route は -- bake 時に分散済 → cluster を成さず no-op (= 冪等) なので二重適用しない。 @@ -210,9 +238,14 @@ -- 縮小も拡大もし (一様スケール・中央寄せ)、 はみ出しゼロを最優先。 in fitPrimsToArea area (platePrims <> edgePrims <> nodePrims) --- | Phase 39 A1: DAG プリミティブ全体の bounding box (xlo, ylo, xhi, yhi)。 --- 'PText' は 'textWidthEm' × fontSize で幅、 fontSize で高さを見積もり anchor で --- 左右配分する (実フォント計測は不可ゆえ凡例/タイトルと同じ近似を流用)。 +-- | [日本語]: DAG プリミティブ全体の bounding box (xlo, ylo, xhi, yhi)。 +-- 'PText' は 'textWidthEm' × fontSize で幅、 fontSize で高さを見積もり anchor で +-- 左右配分する (実フォント計測は不可ゆえ凡例/タイトルと同じ近似を流用)。 +-- [English]: The bounding box (xlo, ylo, xhi, yhi) of the entire set of DAG +-- primitives. For 'PText', width is estimated as 'textWidthEm' times +-- fontSize and height as fontSize, then split left/right by anchor (actual +-- font measurement isn't available, so the same approximation used for the +-- legend/title is reused). primsBBoxDAG :: [Primitive] -> Maybe (Double, Double, Double, Double) primsBBoxDAG prims = case concatMap extents prims of @@ -248,10 +281,16 @@ in [(xl, y - asc, xr, y + dsc)] _ -> [] --- | Phase 39 A1: プリミティブ一式を指定 area 内に一括 scale+translate でフィット。 --- アスペクト比を保つ一様スケール (= min ratio・中央寄せ)。 figure が area より小さければ --- 拡大して余白を埋め (graphviz `ratio=expand` 相当)、 大きければ縮小する。 内側 pad を --- 取りストロークやラベル端が縁に触れないようにする。 フォント/線幅も s 倍。 +-- | [日本語]: プリミティブ一式を指定 area 内に一括 scale+translate でフィット。 +-- アスペクト比を保つ一様スケール (= min ratio・中央寄せ)。 figure が area より小さければ +-- 拡大して余白を埋め (graphviz `ratio=expand` 相当)、 大きければ縮小する。 内側 pad を +-- 取りストロークやラベル端が縁に触れないようにする。 フォント/線幅も s 倍。 +-- [English]: Fits an entire set of primitives into the given area with a +-- single scale+translate. Uses a uniform, aspect-preserving scale (min +-- ratio, centered). If the figure is smaller than the area it is enlarged +-- to fill the space (equivalent to graphviz's `ratio=expand`); if larger, +-- it is shrunk. Takes an inner pad so strokes and label edges don't touch +-- the border. Font size and line width are scaled by the same factor s. fitPrimsToArea :: Rect -> [Primitive] -> [Primitive] fitPrimsToArea area prims = case primsBBoxDAG prims of Nothing -> prims @@ -268,8 +307,11 @@ 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 専用版)。 +-- | [日本語]: x' = s·x + tx, y' = s·y + ty。 座標・半径・線幅・font size を一様に s 倍する +-- ('scalePrimitives' の dpi スケールに translate を加えた DAG fit 専用版)。 +-- [English]: x' = s*x + tx, y' = s*y + ty. Uniformly scales coordinates, +-- radius, line width, and font size by s (a DAG-fit-only variant of +-- 'scalePrimitives' with translation added to its dpi scaling). affinePrim :: Double -> Double -> Double -> Primitive -> Primitive affinePrim s tx ty = go where @@ -290,32 +332,43 @@ 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) + PClipPath ps -> PClipPath (map pt ps) PClipPop -> PClipPop PTransformPush tr -> PTransformPush tr PTransformPop -> PTransformPop --- | Phase 1 A5/A7/parallel: dePath で straight / spline 切替、 端点は A7 で node 形状との --- 正確な交点へ snap、 'parIx' / 'parCount' で並列 edge の perpendicular bend を付与。 +-- | [日本語]: dePath で straight / spline 切替、 端点は node 形状との +-- 正確な交点へ snap、 @parIx@ / @parCount@ で並列 edge の perpendicular bend を付与。 -- --- * 'parCount' = 1: 通常描画 (= bend 無し) --- * 'parCount' > 1: 各 edge を ((parIx - (N-1)/2) * spacing) perpendicular ずらして --- 重ならない曲線群にする (= graphviz dot の parallel edge 表現) +-- * @parCount@ = 1: 通常描画 (= bend 無し) +-- * @parCount@ > 1: 各 edge を ((parIx - (N-1)/2) * spacing) perpendicular ずらして +-- 重ならない曲線群にする (= graphviz dot の parallel edge 表現) +-- [English]: Switches between straight and spline via dePath; endpoints are +-- snapped to the exact intersection with the node shape. @parIx@ / +-- @parCount@ add a perpendicular bend for parallel edges. +-- +-- * @parCount@ = 1: normal drawing (no bend). +-- * @parCount@ > 1: each edge is offset perpendicular by +-- ((parIx - (N-1)/2) * spacing) so they form a set of non-overlapping +-- curves (the same representation graphviz dot uses for parallel edges). renderEdge :: (Double -> Double -> Point) - -> Obstacles -- ^ Phase 39 A-1: node + plate 障害物 (pt) + -> Obstacles -- ^ [日本語]: node + plate 障害物 (pt)。 [English]: Node and plate obstacles (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 を + -- 無ければ live 'Graphics.Hgg.Render.EdgeRoute.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 へ。 +-- | [日本語]: 'EdgeRoute' (制御点列 + 形状) を描画 primitive へ。 +-- [English]: Turns an 'EdgeRoute' (control points plus shape) into +-- rendering primitives. drawEdgeRoute :: ThemePalette -> EdgeRoute -> [Primitive] drawEdgeRoute pal route = case route of StraightArrow a b -> arrowEdgeFromPorts a b pal @@ -326,7 +379,8 @@ -- R3 (Step6 P7a): graphviz Proutespline の cubic Bézier 制御点列 (始点 + 3 点ずつ)。 CubicPath ctrl -> cubicEdgeFromControls ctrl pal --- | Phase 42 sub B/C: 焼き込んだ 'RoutedEdge' を 'EdgeRoute' へ復元 (pt 空間)。 +-- | [日本語]: 焼き込んだ 'RoutedEdge' を 'EdgeRoute' へ復元 (pt 空間)。 +-- [English]: Restores a baked 'RoutedEdge' back into an 'EdgeRoute' (pt space). routedToEdgeRoute :: RoutedEdge -> EdgeRoute routedToEdgeRoute (RoutedEdge k ps) = let pts = [ Point x y | (x, y) <- ps ] @@ -338,7 +392,9 @@ EShBezier -> BezierPath pts EShCubic -> CubicPath pts --- | Phase 42 sub B/C: 'EdgeRoute' を spec 焼き込み用 'RoutedEdge' (pt 空間) へ。 +-- | [日本語]: 'EdgeRoute' を spec 焼き込み用 'RoutedEdge' (pt 空間) へ。 +-- [English]: Converts an 'EdgeRoute' into a 'RoutedEdge' (pt space) for +-- baking into a spec. edgeRouteToRouted :: EdgeRoute -> RoutedEdge edgeRouteToRouted route = case route of StraightArrow a b -> RoutedEdge EShStraight (map p2 [a, b]) @@ -347,9 +403,14 @@ 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 非表示)。 +-- | [日本語]: 1 node を kind に応じた形状で描画 + label (+ 分布名 sub-label)。 +-- ★ サイズは label に合わせ可変 ('Graphics.Hgg.Render.EdgeRoute.nodeExtent')。 形状は PyMC 慣例 = latent/observed は楕円、 +-- deterministic/data/other は四角。 deterministic は name のみ (dist 非表示)。 +-- [English]: Draws a single node with a kind-appropriate shape plus its +-- label (and an optional distribution sub-label). Size varies to fit the +-- label ('Graphics.Hgg.Render.EdgeRoute.nodeExtent'). Shape follows PyMC convention: latent/observed use +-- an ellipse, deterministic/data/other use a rectangle. A deterministic +-- node shows only its name (no distribution). renderNode :: (Double -> Double -> Point) -> Double -> ThemePalette -> DAGNode -> [Primitive] renderNode toScreen radius pal n = @@ -390,7 +451,8 @@ [ PText (Point cx (cy + baseAdj)) (dnLabel n) ts ] in shape : textPrims --- | 楕円を Bezier 近似で path に。 +-- | [日本語]: 楕円を Bezier 近似で path に。 +-- [English]: Turns an ellipse into a path via Bezier approximation. ellipsePath :: Double -> Double -> Double -> Double -> [PathSegment] ellipsePath cx cy rx ry = let k = 0.5522847498 -- magic for circle approximation @@ -404,11 +466,18 @@ , ClosePath ] --- | plate を node 群の bounding box + label で描画。 +-- | [日本語]: plate を node 群の bounding box + label で描画。 -- --- Phase 23: bbox はノード中心でなく **glyph bbox (中心 ± 'nodeExtent')**。 --- 固定 pad (radius*1.6) だと label の長いノード (rx > pad) が plate の --- 水平端で枠を超える (analyze Phase 63.2 で実測確定)。 +-- bbox はノード中心でなく __glyph bbox (中心 ± 'Graphics.Hgg.Render.EdgeRoute.nodeExtent')__。 +-- 固定 pad (radius*1.6) だと label の長いノード (rx > pad) が plate の +-- 水平端で枠を超える (実測で確定)。 +-- [English]: Draws a plate as the bounding box of its node group plus a +-- label. +-- +-- The bbox is not the node centers but the +-- __glyph bbox (center plus/minus 'Graphics.Hgg.Render.EdgeRoute.nodeExtent')__. With a fixed pad +-- (radius*1.6), a node with a long label (rx > pad) would overflow the +-- plate's horizontal edge (confirmed by measurement). renderPlate :: (Double -> Double -> Point) -> Double -> ThemePalette -> [(Text, DAGNode)] -> [DAGPlate] -> DAGPlate -> [Primitive] renderPlate toScreen radius pal nodeMap allPlates plate = @@ -417,7 +486,7 @@ Just (xlo, boxTop, xhi, yhi) -> let rw = xhi - xlo -- label を枠の **下端・右寄せ** に置く (graphviz labelloc=b labeljust=r 同型)。 - -- label 帯は 'plateBoxPt' が box 下端に labelH ぶん確保済。 + -- label 帯は 'Graphics.Hgg.Render.EdgeRoute.plateBoxPt' が box 下端に labelH ぶん確保済。 rh = yhi - boxTop labelTS = mkFontTS Nothing pal LegendItemF AnchorEnd 0 in [ PRect (Rect xlo boxTop rw rh) @@ -427,7 +496,9 @@ (dpLabel plate) labelTS ] --- | Phase 1 A7: 端点が既に node 形状端に snap 済の前提で直線 + 矢印ヘッド描画。 +-- | [日本語]: 端点が既に node 形状端に snap 済の前提で直線 + 矢印ヘッド描画。 +-- [English]: Draws a straight line plus arrowhead, assuming the endpoints +-- are already snapped to the node shape's edge. arrowEdgeFromPorts :: Point -> Point -> ThemePalette -> [Primitive] arrowEdgeFromPorts (Point sx sy) (Point ex ey) pal = let dx = ex - sx; dy = ey - sy @@ -452,18 +523,38 @@ (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 は崩れない。 +-- | [日本語]: 始終点 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 を中央へ引き戻さないため、 迂回経路の描画に使う。 +-- ただし内部点が __1 個だけ__ (= 制御点 3 個、 dummy 1 個の短い skip) +-- の場合は smoothing を掛けない。 2-pass 平均は唯一の内部点を始終点の中点へ強く +-- 引き戻すため、 routeLongEdgeDummies が plate 箱の外へ出した bulge が潰れて edge が +-- 箱へ再侵入してしまう。 棚は内部点 2 個以上 (長い chain) でしか生じないので、 +-- 短い chain では bulge をそのまま活かす。 +-- [English]: Draws a Catmull-Rom spline plus arrowhead from a control-point +-- list whose start/end points are already snapped. Applies two passes of +-- corner-cutting smoothing to the interior control points (each interior +-- point is replaced by the (1,2,1)/4 average of itself and its two +-- neighbors) before handing them to Catmull-Rom. This softens the +-- "shelf / double-hump" artifact that comes from routing through dummy +-- points, yielding a look close to a true B-spline while staying a +-- straight-line path. Endpoints are preserved, so port snapping is not +-- disturbed. +-- +-- However, when there is only __one__ interior point (three control points +-- total — a short skip with a single dummy), smoothing is skipped. The +-- two-pass average would pull that lone interior point strongly toward the +-- midpoint of the start and end, collapsing the bulge that +-- routeLongEdgeDummies pushed outside the plate box and letting the edge +-- re-enter the box. The shelf artifact only occurs with two or more +-- interior points (a long chain), so short chains keep the bulge as-is. +-- | [日本語]: 制御点列を __そのまま__ Catmull-Rom で通す (= 平滑化なし)。 +-- 箱角 waypoint を中央へ引き戻さないため、 迂回経路の描画に使う。 +-- [English]: Passes the control-point list straight through Catmull-Rom, +-- unchanged (no smoothing). Used for drawing detour routes, since it must +-- not pull box-corner waypoints back toward the center. bezierThroughPorts :: [Point] -> ThemePalette -> [Primitive] bezierThroughPorts = drawCatmullRom @@ -472,7 +563,9 @@ let pts = if length ptsRaw >= 4 then smoothInterior 2 ptsRaw else ptsRaw in drawCatmullRom pts pal --- | Catmull-Rom spline + 矢印ヘッドを制御点列から描画 (平滑化は呼出側責務)。 +-- | [日本語]: Catmull-Rom spline + 矢印ヘッドを制御点列から描画 (平滑化は呼出側責務)。 +-- [English]: Draws a Catmull-Rom spline plus arrowhead from a control-point +-- list (smoothing is the caller's responsibility). drawCatmullRom :: [Point] -> ThemePalette -> [Primitive] drawCatmullRom pts pal = let n = length pts @@ -484,13 +577,19 @@ (Just (StrokeStyle (tpAxis pal) 1.5)) in [edgePath, arrowHeadPrim basePt apex u pal] --- | 矢じり寸法 (graphviz 較正: 長 10 × 底辺 7 = headWid*2)。 全 edge 描画で共有。 +-- | [日本語]: 矢じり寸法 (graphviz 較正: 長 10 × 底辺 7 = headWid*2)。 全 edge 描画で共有。 +-- [English]: Arrowhead dimensions (calibrated against graphviz: length 10, +-- base 7 = headWid*2). Shared across all edge rendering. dagHeadLen, dagHeadWid :: Double dagHeadLen = 10.0 dagHeadWid = 3.5 --- | 鏃 (塗り三角) primitive。 base = 底辺中心 (= 線の終端・曲線上)、 apex = 元終点 --- (= ノード port = tip)、 u = tip 方向単位ベクトル。 ★ Phase 44.8。 +-- | [日本語]: 鏃 (塗り三角) primitive。 base = 底辺中心 (= 線の終端・曲線上)、 apex = 元終点 +-- (= ノード port = tip)、 u = tip 方向単位ベクトル。 +-- [English]: The arrowhead (filled triangle) primitive. base is the center +-- of its base edge (the line's endpoint, on the curve), apex is the +-- original endpoint (the node port, i.e. the tip), and u is the unit +-- vector pointing toward the tip. arrowHeadPrim :: Point -> Point -> (Double, Double) -> ThemePalette -> Primitive arrowHeadPrim (Point bx by) apex (ux, uy) pal = let (perpx, perpy) = (-uy, ux) @@ -499,11 +598,20 @@ 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。 +-- | [日本語]: 描画パス末尾の cubic セグメントを __終点側へ弧長 ~headLen 分 de Casteljau 分割__し、 +-- 線を曲線上の base 点で滑らかに止める (= 鏃が tip を担う)。 終点だけ差し替えると +-- 制御点据え置きで曲線が変形し base で折れるため、 正しく分割して曲線形状を保つ +-- (graphviz の arrow clip と同型)。 戻り = (分割後セグ列, base 点(曲線上), +-- apex(=元終点), 単位 tip 方向)。 +-- [English]: Splits the last cubic segment of the drawn path via de +-- Casteljau, __trimming arc-length ~headLen back from the endpoint__, so +-- the line stops smoothly at a base point on the curve (the arrowhead +-- then covers the tip). Simply replacing the endpoint would deform the +-- curve while leaving the control points fixed, producing a kink at base; +-- splitting it properly preserves the curve shape (the same technique as +-- graphviz's arrow clip). Returns (the split segment list, the base point +-- on the curve, the apex — the original endpoint, and the unit tip +-- direction). trimLastCubic :: Double -> Point -> [PathSegment] -> ([PathSegment], Point, Point, (Double, Double)) @@ -528,7 +636,9 @@ segEndOf (MoveTo q) = q segEndOf ClosePath = p0 --- | cubic (p0,c1,c2,p3) を媒介変数 t で de Casteljau 分割し、 左半分の制御点を返す。 +-- | [日本語]: cubic (p0,c1,c2,p3) を媒介変数 t で de Casteljau 分割し、 左半分の制御点を返す。 +-- [English]: Splits the cubic (p0,c1,c2,p3) at parameter t via de +-- Casteljau, returning the control points of the left half. 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) @@ -537,12 +647,18 @@ m = lp d e in (p0, a, d, m) --- | cubic 上の点 B(t)。 +-- | [日本語]: cubic 上の点 B(t)。 +-- [English]: The point B(t) on the cubic. 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 を返す。 +-- | [日本語]: 終点 p3 から弧長 ~target だけ手前の媒介変数 t を二分法で求める +-- (chord 近似)。 距離 |B(t) - p3| は t→1 で 0 へ単調減少する。 末尾セグ全長が +-- target 未満なら 0 を返す。 +-- [English]: Binary-searches for the parameter t that is arc-length ~target +-- back from the endpoint p3 (chord approximation). The distance |B(t) - +-- p3| decreases monotonically to 0 as t approaches 1. Returns 0 if the +-- entire final segment is shorter than target. 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 @@ -553,8 +669,12 @@ 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→終点) 接線。 +-- | [日本語]: graphviz Proutespline の制御点列 ([始点, c1, c2, 終点, c1, c2, ...]) +-- を cubic Bézier path + 矢印で描画。 矢印方向は最終 segment の (c2→終点) 接線。 +-- [English]: Draws graphviz's Proutespline control-point list +-- ([start, c1, c2, end, c1, c2, ...]) as a cubic Bezier path plus +-- arrowhead. The arrow direction is the tangent of the final segment's +-- (c2 to end) leg. cubicEdgeFromControls :: [Point] -> ThemePalette -> [Primitive] cubicEdgeFromControls ctrl pal | length ctrl < 4 = case ctrl of @@ -575,9 +695,13 @@ 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 経由制御点列の「棚」 を緩和するために使う。 +-- | [日本語]: Corner-cutting smoothing: 内部点 P[i] (i ∉ {0, n-1}) を +-- (P[i-1] + 2 P[i] + P[i+1]) / 4 で置換し @k@ 回繰り返す。 端点は不変。 +-- 'splineEdgeFromPorts' で dummy 経由制御点列の「棚」 を緩和するために使う。 +-- [English]: Corner-cutting smoothing: replaces each interior point P[i] +-- (i not in {0, n-1}) with (P[i-1] + 2 P[i] + P[i+1]) / 4, repeated @k@ +-- times. Endpoints are left unchanged. Used by 'splineEdgeFromPorts' to +-- soften the "shelf" artifact of dummy-routed control-point lists. smoothInterior :: Int -> [Point] -> [Point] smoothInterior k ps | k <= 0 || length ps < 3 = ps @@ -589,14 +713,26 @@ 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、 端で直線に近づく)。 +-- | [日本語]: 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 内拘束で防ぐのと同趣旨)。 +-- ★ 制御点オフセットを __セグメント長でクランプ__ する。 +-- knot 間隔が極端に不均一だと (= 例: 迂回 waypoint 不足で長 edge が 3 点になる場合)、 +-- tangent (b-prev)/6 が遠い prev に引っ張られ制御点が segment 外へ大きく overshoot し、 +-- 末端に「フック」が出ていた。 均等間隔での標準オフセットは segLen/3 ゆえ上限 0.5·segLen +-- なら通常曲線は不変、 過大時のみ抑制される (graphviz が box 内拘束で防ぐのと同趣旨)。 +-- [English]: Converts a Catmull-Rom control-point list into cubic Bezier +-- segments. Endpoints are handled as their own ghost points (a natural +-- spline that approaches a straight line at the ends). +-- +-- __Clamps the control-point offset to the segment length__. When knot +-- spacing is extremely uneven (for example, a long edge reduced to three +-- points due to insufficient detour waypoints), the tangent (b-prev)/6 +-- gets pulled by a distant prev and the control point overshoots far +-- outside the segment, producing a "hook" at the end. Since the standard +-- offset for evenly spaced knots is segLen/3, clamping at 0.5*segLen +-- leaves ordinary curves unchanged and only suppresses the excessive case +-- (the same idea graphviz uses when it constrains points inside the box). catmullRomToBezier :: [Point] -> [PathSegment] catmullRomToBezier ps = go (0 :: Int) ps where @@ -627,13 +763,23 @@ 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)。 +-- | [日本語]: geom_text / geom_label。 各 (x,y) 点に lyLabel 列の文字を描く。 +-- withBox=True (= geom_label) は文字の背後に角丸風の矩形を敷く。 色は static color +-- 指定 (= 固定色 color) があればそれ、 無ければ tpText。 font サイズは lySize (default 11)。 +-- [English]: geom_text / geom_label. Draws the text from the lyLabel column +-- at each (x,y) point. withBox=True (geom_label) lays a rounded-rect-like +-- background behind the text. Color uses a static color (a fixed color) if +-- one is specified, otherwise falls back to tpText. Font size is 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) + -- ★ Phase 64 A13: ternary は (x,y) を encZ 正規化 fraction へ写す (vecOrFull で z と + -- 行整列、 退化行→NaN は下の mkOne 前 filter で落とす)。 非 ternary は従来の vecOr。 + let (xs, ys) = if isTernary (lpCoord layout) + then let (vx, vy) = ternaryRemap r layout ly + (vecOrFull (lyEncX ly) r) (vecOrFull (lyEncY ly) r) + in (V.toList vx, V.toList vy) + else (V.toList (vecOr (lyEncX ly) r), 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 @@ -660,23 +806,44 @@ -- 文字 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 64 A13: NaN (ternary 退化行) 点を落とす。 非 ternary は vecOr で NaN 無し=無影響。 + in if n <= 0 then [] + else concatMap mkOne [ i | i <- [0 .. n - 1] + , not (isNaN (xs !! i)), not (isNaN (ys !! i)) ] --- | 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) と同一品質で描画される。 +-- | [日本語]: HBM ModelGraph DAG 描画。 +-- node 位置 (dnX, dnY) は domain 座標として scale 適用、 node = PCircle + +-- PText、 edge = PLine。 layout 計算は外部 (= hanalyze / frontend) で。 +-- [English]: Draws an HBM ModelGraph DAG. Node positions (dnX, dnY) are +-- scaled as domain coordinates; a node becomes PCircle + PText, an edge +-- becomes PLine. Layout computation happens externally (in hanalyze +-- / the frontend). +-- | [日本語]: embedded DAG (= MDAG レイヤを他 geom と同一軸に重ねた退化ケース)。 +-- ★ 旧実装は node 座標を [0,1] に潰す @nrm@ shim + 軸 scale で +-- 直線のみ (矢印/plate 箱/迂回 routing 無し) を描く間に合わせだった。 本格 +-- 'renderDAGStandalone' (矢印・plate・routing・fit 完備) が landing 済のため、 +-- shim を撤去して standalone を panel 矩形 ('lpPlotArea') 上で呼ぶ委譲に統一する。 +-- これで mixed ケースでも DAG 専用経路 (renderDAGOnly) と同一品質で描画される。 +-- [English]: An embedded DAG (the degenerate case where an MDAG layer is +-- overlaid on the same axes as other geoms). +-- The old implementation was a stopgap that collapsed node coordinates +-- into [0,1] via an @nrm@ shim plus axis scaling, drawing only straight +-- lines (no arrowheads, plate boxes, or detour routing). Now that the +-- full-featured 'renderDAGStandalone' (arrowheads, plates, routing, and +-- fitting all included) has landed, the shim is removed and delegation is +-- unified to call standalone on the panel rectangle ('lpPlotArea'). As a +-- result, the mixed case now renders at the same quality as the dedicated +-- DAG path (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 で描画。 +-- | [日本語]: parallel coordinates。 lyHover で渡された N 列を +-- 等間隔の縦軸として並べ、 row 毎に折線を引く。 placeholder 実装: data の +-- 各列を [0, 1] に正規化、 polyline で描画。 +-- [English]: Parallel coordinates. Lays out the N columns passed via +-- lyHover as equally spaced vertical axes and draws a polyline per row. +-- Placeholder implementation: normalizes each column of data to [0, 1] +-- and draws it as a polyline. renderParallel :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderParallel r layout pal ly = let cols = lyHover ly @@ -721,8 +888,21 @@ | 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 非表示前提。 +-- | [日本語]: Pie chart: lyEncX = categorical labels、 lyEncY = values。 +-- plotArea 中央に円描画、 各 slice は categorical palette で着色。 軸 / tick 非表示前提。 +-- [English]: Pie chart: lyEncX gives the categorical labels, lyEncY gives +-- the values. Draws the circle centered in the plotArea, coloring each +-- slice from the categorical palette. Assumes axes and ticks are hidden. +-- +-- [日本語]: __投影層 (projectXY 等) を通さず自前で cos/sin を回すのは意図的__。 +-- pie はそもそも極座標専用の図で、 cross 軸 / value 軸という直交の役割分担を +-- 持たない (角度が値そのもの)。 座標系の切替対象ではないため投影層に載せる +-- 意味が薄い。 +-- [English]: __Deliberately computes cos/sin itself rather than going through +-- the projection layer__ (projectXY and friends). A pie is inherently a +-- polar-only chart with no cross-axis / value-axis split — the angle __is__ +-- the value — so it is not a target for coordinate switching and would gain +-- nothing from the projection layer. renderPie :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderPie r layout thePal ly = let area = lpPlotArea layout @@ -763,9 +943,13 @@ 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 色。 +-- | [日本語]: Waterfall chart: lyEncX = categorical labels、 lyEncY = delta values。 +-- 各 bar は前 bar の累積値から start、 + delta だけ移動。 +-- 正 = positive 色、 負 = negative 色。 +-- [English]: Waterfall chart: lyEncX gives the categorical labels, lyEncY +-- gives the delta values. Each bar starts from the previous bar's +-- cumulative value and moves by + delta. Positive deltas use the positive +-- color, negative deltas use the negative color. renderWaterfall :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderWaterfall r layout pal ly = let xCats = lpXCategoryLabels layout @@ -784,7 +968,10 @@ -- 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 非対象 + -- ★ Phase 64 A4: flipOnly を撤去し projectBar (形状 dispatcher) へ。 直線座標系は + -- projectBarRect と同式なので px は bit 一致、 極座標では扇形 (wedge) になる。 + -- halfWidthD 0.3 = 厚み 0.6 スロットの半分 (catUnitPx は 1 data 単位の px 幅)。 + coord = lpCoord layout bw = catUnitPx coord layout * 0.6 -- Phase 10 A4-fix: flip では縦スロット幅 mkBar i d = let xp = if isCat then fromIntegral i else fromIntegral i @@ -792,8 +979,9 @@ 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)) + in case projectBar coord layout xp yStart yEnd 0.3 bw of + BarRect rect -> PRect rect (FillStyle c a) (Just (StrokeStyle c 1.0)) + BarWedge segs -> PPath segs (FillStyle c a) (Just (StrokeStyle c 1.0)) -- Phase 7 A6: 末尾に合計 (Total) バー (= base 0 から累積到達値)。 デフォルト出す -- (フラグ切替の Spec API は後追い)。 中立灰で増減バーと区別。 x = n (Layout で -- category を "Total" 1 つ拡張済み)。 @@ -801,6 +989,7 @@ 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 case projectBar coord layout xp 0 total 0.3 bw of + BarRect rect -> PRect rect (FillStyle totalC a) (Just (StrokeStyle totalC 1.0)) + BarWedge segs -> PPath segs (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 --- a/src/Graphics/Hgg/Render/Statistical.hs +++ b/src/Graphics/Hgg/Render/Statistical.hs @@ -1,10 +1,11 @@ -- | -- Module : Graphics.Hgg.Render.Statistical --- Description : 統計 mark (qq/ecdf/rangebar/heatmap/contour/regression/density/statline) +-- Description : Statistical marks: qq, ecdf, rangebar, heatmap, contour, regression, density, statline -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 7 A4: Render モノリス分割 (出力中立・純粋移動)。 +-- [日本語]: Render モノリス分割 (出力中立・純粋移動)。 +-- [English]: Split out from the Render monolith (an output-neutral, pure move). {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unused-imports #-} @@ -19,7 +20,10 @@ needsLegend, effectiveLegendPos, coordOf, isPolar, polarCenter, polarPoint, domFrac, projectXY, projectRectData, - projectBarRect, catUnitPx, resolutionOf, + projectBarRect, projectSegment, + CrossLoc (..), BarShape (..), + projectCrossBar, projectCrossSpan, + catUnitPx, resolutionOf, AxisPlacement (..), coordXAxisPlacement, coordYAxisPlacement, coordXGridIsVertical) @@ -64,10 +68,16 @@ 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 は点のみ。 +-- | [日本語]: 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 は点のみ。 +-- [English]: A Q-Q plot (ggplot's geom_qq). Sorts the sample (encY) and +-- plots points with the order statistic as y and the theoretical normal +-- quantile Φ⁻¹((i-0.5)/n) as x. The theoretical quantiles are shared from +-- a single source, 'qqPoints' (RangeOf), so they match the x range. Even in +-- ggplot the reference line (qq line) is a separate geom (geom_qq_line), so +-- this geom draws only the points. renderQQ :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderQQ r layout pal ly = let sample = V.toList (vecOr (lyEncY ly) r) @@ -80,8 +90,11 @@ (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' を単一情報源とし連続線で結ぶ。 +-- | [日本語]: ECDF (= ggplot stat_ecdf)。 sample (encX) をソートして右連続の +-- 階段 F(x)=#(≤x)/n を描く。 角点列 'ecdfPoints' を単一情報源とし連続線で結ぶ。 +-- [English]: An ECDF (ggplot's stat_ecdf). Sorts the sample (encX) and draws +-- the right-continuous step function F(x)=#(≤x)/n. The corner points come +-- from a single source, 'ecdfPoints', connected with a continuous line. renderEcdf :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderEcdf r layout pal ly = let sample = V.toList (vecOr (lyEncX ly) r) @@ -97,9 +110,17 @@ [] -> [] _ -> 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 でも安定)。 +-- | [日本語]: 区間 geom (linerange / pointrange / crossbar)。 各 (x,y) に縦区間 +-- y±errorY を描く。 withPoint=中心点を足す (pointrange)、 asBox=幅付き箱+中央線 (crossbar)。 +-- 箱は投影層 ('projectCrossBar' / 'projectCrossSpan') 経由 (Phase 71 A2): +-- 直線座標系は px 半幅 (旧式 byte 一致)、 polar は data 半幅の wedge + 弧。 +-- [English]: A range geom (linerange / pointrange / crossbar). Draws a +-- vertical interval y±errorY at each (x,y). withPoint adds a center point +-- (pointrange); asBox draws a box with a width plus a center line +-- (crossbar). The box goes through the projection layer ('projectCrossBar' +-- / 'projectCrossSpan', Phase 71 A2): linear coordinate systems use the +-- pixel half-width (byte identical to the old formula), polar uses a wedge +-- and arcs at the data half-width. renderRangeBar :: Resolver -> Layout -> ThemePalette -> Layer -> Bool -> Bool -> [Primitive] renderRangeBar r layout pal ly withPoint asBox = let xs = V.toList (vecOr (lyEncX ly) r) @@ -118,28 +139,51 @@ finite v = not (isNaN v) && not (isInfinite v) resX = resolutionOf (filter finite xs) halfW = 0.5 * capWFactor * resX * catUnitPx coord layout + -- ★ Phase 71 A2: crossbar の箱幅は px (halfW) と data (halfD) の両建てで + -- 投影層へ渡す (boxAtCross と同じ契約: 直線座標系 = halfW px で旧式 byte + -- 一致、 polar = halfD data 単位の wedge)。 + halfD = 0.5 * capWFactor * resX 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 + 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 []) + then -- crossbar: 箱 + 中央線を投影層経由で組む + -- ★ Phase 71 A2: 旧実装は px 空間の PRect 直書きで、 polar は平面 + -- 矩形のまま (Phase 64 A5 除外)、 flip は pp x (y±e) の第 2 成分が + -- 両方 cross 位置になり箱の高さ 0 (実バグ、 md A1 実測) だった。 + -- 'projectCrossBar' / 'projectCrossSpan' 経由で cartesian は旧式 + -- byte 一致・flip は正しい向きの箱・polar は wedge + 弧になる。 + let loc = CrossAt x + body = case projectCrossBar coord layout loc 0 halfW halfD (y - e) (y + e) of + BarRect rect -> PRect rect (FillStyle c 0.15) (Just (StrokeStyle c w)) + BarWedge segs -> PPath segs (FillStyle c 0.15) (Just (StrokeStyle c w)) + center = projectCrossSpan coord layout loc 0 halfW halfD y + in body : [ PLine p q ls | (p, q) <- zip center (drop 1 center) ] + else -- linerange: 値軸方向の区間。 pointrange は中心点を追加 + -- ★ Phase 64 A5: 旧実装は低端の px x を両端に流用して画面垂直の線分を + -- 組んでいたため、 polar では半径方向にならず・flip では両端が同一点に + -- 潰れて (= 長さ 0) 誤差棒が消えていた。 'projectSegment' に委譲すると + -- 直線座標系は 2 点で旧 px 式と bit 一致、 polar は半径方向の線分、 + -- CoordPolarY は弧になる。 + let pts = projectSegment coord layout (x, y - e) (x, y + e) + in [ PLine p q ls | (p, q) <- zip pts (drop 1 pts) ] + ++ (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) が重複する行は後勝ち (= 描画順で上書き)。 +-- | [日本語]: heatmap (= ggplot geom_tile)。 x/y はカテゴリ列、 value (= lyColor の +-- ColorByContinuous) を各 (x,y) セルの連続色 (Viridis) に写して矩形で塗る。 セルは data 空間で +-- カテゴリ中心 ±0.5 の 1 単位四方 (= projectRectData で flip も自動追従)。 cell 間は背景色の +-- 細い枠で区切る (= grid 状)。 同 (x,y) が重複する行は後勝ち (= 描画順で上書き)。 +-- [English]: A heatmap (ggplot's geom_tile). x/y are categorical columns; +-- the value (lyColor's ColorByContinuous) is mapped to a continuous color +-- (Viridis) and painted as a rectangle for each (x,y) cell. Cells are a +-- one-unit square in data space, category center ±0.5 (using +-- projectRectData, so flip is handled automatically). Cells are separated +-- by a thin border in the background color (a grid look). When (x,y) is +-- duplicated across rows, the last one wins (overwritten in draw order). renderHeatmap :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderHeatmap r layout pal ly = let toLabels mcr = case getLast mcr of @@ -165,11 +209,19 @@ 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) を用いるので両軸自動でカテゴリ化。 +-- | [日本語]: geom_count (Ch10 EDA、 = ggplot @geom_count()@ / @stat_sum@)。 +-- x/y はともにカテゴリ列。 各 (x,y) セルの観測件数を集計し、 cell 中心に +-- __面積 ∝ 件数__ (= 半径 ∝ √件数) の点を打つ。 最大件数のセルが半径 maxR (px)、 +-- 件数 0 のセルは描かない。 maxR は lySize で上書き可 (既定 18 → 半径 9)。 +-- heatmap と同じカテゴリ軸 (lpX/YCategoryLabels) を用いるので両軸自動でカテゴリ化。 +-- [English]: geom_count (Ch10 EDA, ggplot's @geom_count()@ / @stat_sum@). +-- Both x and y are categorical columns. Tallies the observation count per +-- (x,y) cell and plots a point at each cell center, sized so +-- __area is proportional to count__ (radius proportional to √count). The +-- highest-count cell gets radius maxR (px); cells with count 0 are not +-- drawn. maxR can be overridden via lySize (default 18, giving radius 9). +-- Uses the same categorical axes as heatmap (lpX/YCategoryLabels), so both +-- axes become categorical automatically. renderCount :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderCount r layout pal ly = let toLabels mcr = case getLast mcr of @@ -201,17 +253,35 @@ (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 も同型)。 +-- | [日本語]: contour (= 等高線図、 marching squares)。 連続 x/y/z を正則格子に再標本化 +-- (inverse-distance weighting で散布点 → ノード) し、 z 範囲を等分した nLev 段の +-- __等値線__を marching squares で描く。 各等値線は z 値で連続色 (Viridis)。 +-- 旧実装は binned heatmap だったが、 「contour = 等高線」 の名に合わせ isolines に +-- (binned heatmap が要るなら 'Graphics.Hgg.Spec.Constructors.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 維持)。 +-- TODO (繰越、 2026-06-04): 等値線が__ガタつく__。 原因 = ① IDW は各データ点で +-- 尖る (cusp) ため格子データでも滑らかにならない、 ② 32×32 再標本化が粗い、 ③ marching +-- squares の線形補間で階段状になりやすい。 改善案 = (a) IDW を__双線形補間__ (元が格子なら +-- 格子直引き) に置換、 (b) 再標本化後に軽い Gaussian smoothing、 (c) 解像度↑。 +-- HS/PS 両方に同じ修正が要る (parity 維持)。 +-- [English]: A contour plot (isolines via marching squares). Resamples +-- continuous x/y/z onto a regular grid (scattered points to nodes, via +-- inverse-distance weighting) and draws __isolines__ at nLev levels evenly +-- spaced across the z range, using marching squares. Each isoline is +-- colored continuously (Viridis) by its z value. The previous +-- implementation was a binned heatmap, but this was changed to isolines to +-- match the name "contour" (use 'Graphics.Hgg.Spec.Constructors.bin2d' if a binned heatmap is needed). +-- HS and PS share the same formulas (PS's renderContour is structurally +-- identical). +-- +-- TODO (carried over, 2026-06-04): the isolines are __jagged__. Causes: (1) +-- IDW cusps at each data point, so even gridded data does not smooth out; +-- (2) the 32×32 resampling is coarse; (3) marching squares' linear +-- interpolation tends to look stair-stepped. Possible fixes: (a) replace +-- IDW with __bilinear interpolation__ (reading the grid directly when the +-- source is already gridded), (b) light Gaussian smoothing after +-- resampling, (c) higher resolution. The same fix is needed in both HS and +-- PS (to keep parity). renderContour :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderContour r layout _pal ly = case contourInput r ly of @@ -228,11 +298,19 @@ | ((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)。 +-- | [日本語]: contour / filled contour の共通入力 — (x,y,z) triple を +-- 'gridOf' で格子化する。 ★規則 grid 入力 (計画格子・linspace 由来) は +-- __補間せず直入力__ (旧実装は常に全点 IDW で 32x32 再標本化しており、 +-- 規則 grid でも等値線が歪む + 隅に偽輪郭が出るバグだった)。 +-- 散布入力のみ k 近傍 IDW で 32x32 へ。 格子の向きは grid!!j!!i (行 = y)。 +-- [English]: The shared input for contour / filled contour — grids +-- (x,y,z) triples via 'gridOf'. A regular grid input (a planned grid, +-- e.g. from linspace) is __used directly, without interpolation__ (the +-- old implementation always resampled all points to 32x32 via IDW, which +-- distorted the isolines and produced spurious contours at the corners +-- even for an already-regular grid). Only scattered input goes through +-- k-nearest-neighbor IDW to 32x32. Grid orientation is grid!!j!!i (rows +-- are y). contourInput :: Resolver -> Layer -> Maybe ([Double], [Double], V.Vector (V.Vector Double), Double, Double) contourInput r ly = @@ -250,10 +328,16 @@ 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% クランプは廃止 = 端近くのレベルも出る)。 +-- | [日本語]: 等高線レベル。 明示 breaks ('Graphics.Hgg.Spec.Constructors.contourBreaks') > 本数指定 +-- ('Graphics.Hgg.Spec.Constructors.contourLevels'、 既定 8)。 既定は (zmin, zmax) の__内側等間隔__ +-- (lv_k = zmin + (zmax-zmin)·k/(n+1)) — 端値ちょうどの退化等値線を避ける +-- (旧実装の 15%-95% クランプは廃止 = 端近くのレベルも出る)。 +-- [English]: Contour levels. Explicit breaks ('Graphics.Hgg.Spec.Constructors.contourBreaks') take +-- priority over a count ('Graphics.Hgg.Spec.Constructors.contourLevels', default 8). The default is +-- __evenly spaced strictly inside__ (zmin, zmax) +-- (lv_k = zmin + (zmax-zmin)·k/(n+1)) — this avoids a degenerate isoline +-- exactly at an endpoint (the old 15%-95% clamp has been removed, so +-- levels near the edges are also produced). contourLevelsFor :: Layer -> Double -> Double -> [Double] contourLevelsFor ly zmin zmax = case getLast (lyContourBreaks ly) of @@ -261,10 +345,18 @@ Nothing -> innerLevels (max 1 (fromMaybe 8 (getLast (lyContourLevels ly)))) zmin zmax --- | Phase 24 A4: filled contour (等値帯の塗り)。 各セルを「最下帯の色で全塗り → --- level 昇順に z >= lv の部分多角形を上塗り」 の累積方式で塗る (セル内は --- marching squares と同じ線形補間の境界 = 'contour' の線と整合)。 --- saddle セル (対角ケース) は頂点巡回順の単一多角形で近似 (v1 既知の限界)。 +-- | [日本語]: filled contour (等値帯の塗り)。 各セルを「最下帯の色で全塗り → +-- level 昇順に z >= lv の部分多角形を上塗り」 の累積方式で塗る (セル内は +-- marching squares と同じ線形補間の境界 = 'Graphics.Hgg.Spec.Constructors.contour' の線と整合)。 +-- saddle セル (対角ケース) は頂点巡回順の単一多角形で近似 (v1 既知の限界)。 +-- [English]: A filled contour (painting the isobands). Each cell is +-- painted by an accumulation method: fill the whole cell with the lowest +-- band's color, then overpaint the sub-polygon where z >= lv for each +-- level in ascending order (the boundary within a cell uses the same +-- linear interpolation as marching squares, so it stays consistent with +-- the lines drawn by 'Graphics.Hgg.Spec.Constructors.contour'). Saddle cells (the diagonal case) are +-- approximated as a single polygon following vertex traversal order (a +-- known limitation of v1). renderContourFilled :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderContourFilled r layout _pal ly = case contourInput r ly of @@ -317,10 +409,17 @@ 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 と同一式。 +-- | [日本語]: binned heatmap (= ggplot geom_bin2d)。 連続 x/y/z を nBins×nBins の grid に +-- binning し、 各セルの z 平均を連続色 (Viridis) で塗る。 'renderContour' (等高線) の +-- 塗り版。 セルは生 data 範囲 [xLo,xHi]×[yLo,yHi] を等分し projectRectData で投影 +-- (flip 自動追従)。 空セルは描かない。 PS と同一式。 +-- [English]: A binned heatmap (ggplot's geom_bin2d). Bins continuous x/y/z +-- onto an nBins×nBins grid and paints each cell's z average as a +-- continuous color (Viridis). The filled counterpart of 'renderContour' +-- (isolines). Cells evenly divide the raw data range +-- [xLo,xHi]×[yLo,yHi] and are projected via projectRectData (flip is +-- handled automatically). Empty cells are not drawn. Uses the same +-- formula as PS. renderBin2d :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderBin2d r layout _pal ly = let xs = V.toList (vecOr (lyEncX ly) r) @@ -363,12 +462,23 @@ 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。 +-- | [日本語]: geom_tile / geom_raster 相当。 __1 行 = 1 セル__。 連続 x/y をセル中心とし、 +-- fill (colorBy = 'ColorByCol' 離散 / 'ColorByContinuous' 連続) の色で矩形をベタ塗りする。 +-- bin2d と違い__再ビニングしない__ (事前計算済みグリッドをそのまま塗る)。 セル幅/高さは +-- sorted unique x/y の隣接差分の最小 = 格子間隔から自動 (ggplot @resolution()@ 相当・隙間なし)。 +-- 決定境界の res×res グリッド塗り (縞解消) が主用途。 色/凡例は 'Graphics.Hgg.Render.Common.colorVector' + color-enc 駆動 +-- guide が自動処理 (categorical なら離散パレット + 離散凡例)。 枠線なし = seamless。 +-- [English]: The equivalent of geom_tile / geom_raster. +-- __Each row is one cell__. Treats continuous x/y as cell centers and +-- flat-fills each rectangle with the fill color (colorBy: discrete via +-- 'ColorByCol' or continuous via 'ColorByContinuous'). Unlike bin2d, it +-- __does not rebin__ (it paints the precomputed grid as-is). Cell width/height are +-- derived automatically from the grid spacing — the minimum adjacent +-- difference among sorted unique x/y values (equivalent to ggplot's +-- @resolution()@, with no gaps). Its main use is painting a res×res +-- decision-boundary grid (to remove banding). Color/legend handling is +-- automatic via 'Graphics.Hgg.Render.Common.colorVector' plus the color-enc-driven guide (a discrete +-- palette and discrete legend for categorical data). No border, i.e. seamless. renderTile :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderTile r layout pal ly = let xs = V.toList (vecOr (lyEncX ly) r) @@ -386,18 +496,28 @@ 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。 +-- | [日本語]: sorted unique 値の隣接差分の最小を格子間隔とする (ggplot @resolution()@)。 +-- 単一値 / 差分無しは 1.0 fallback。 +-- [English]: Takes the minimum adjacent difference among sorted unique +-- values as the grid spacing (ggplot's @resolution()@). Falls back to +-- 1.0 for a single value or when there is no difference. 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 頂点を +-- | [日本語]: hexbin (= ggplot @geom_hex@ / matplotlib @hexbin@)。 連続 x/y を六角格子に +-- binning し、 各セルの__件数__を連続色 (Viridis) の pointy-top 六角形で塗る。 セル分割数は +-- 'lyBinCount' (既定 30)。 binning は純関数 'Graphics.Hgg.Spec.Constructors.hexbinCells' (d3-hexbin)、 描画はその 6 頂点を -- 'projectPoint' で screen へ投影して 'PPath' で塗る。 colorbar は count guide (別途) が出す。 +-- [English]: A hexbin (ggplot's @geom_hex@ / matplotlib's @hexbin@). Bins +-- continuous x/y onto a hexagonal grid and paints each cell's __count__ as +-- a pointy-top hexagon in a continuous color (Viridis). The number of +-- cells is controlled by 'lyBinCount' (default 30). Binning is the pure +-- function 'Graphics.Hgg.Spec.Constructors.hexbinCells' (d3-hexbin); drawing projects its 6 vertices to +-- screen space via 'projectPoint' and paints them as a 'PPath'. The +-- colorbar is emitted separately by the count guide. renderHexbin :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderHexbin r layout _pal ly = case hexbinLayerCells r ly of @@ -432,12 +552,21 @@ 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 で曲線描画。 +-- | [日本語]: 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 と整合)。 +-- color/fill aesthetic (= 'ColorByCol') があるときは群ごとに分割し、 各群を +-- 独立に正規化した KDE 曲線を群色で重ねて描く (= ggplot @geom_density(aes(color=g))@)。 +-- 各群の peak が異なるので y domain も群対応 (RangeOf.densityYRange と整合)。 +-- [English]: A density plot (a simplified Gaussian KDE). lyEncX is the +-- value vector. Bandwidth follows Silverman's rule of thumb, evaluated at +-- 100 grid points and drawn as a curve via 'PPath'. +-- +-- When a color/fill aesthetic ('ColorByCol') is present, splits by group +-- and overlays each group's independently normalized KDE curve in its +-- group color (ggplot's @geom_density(aes(color=g))@). Since each group's +-- peak differs, the y domain is also group-aware (consistent with +-- RangeOf.densityYRange). renderDensity :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderDensity r layout pal ly = let xsFull = V.toList (vecOrFull (lyEncX ly) r) -- 長さ保持 (群キーと整列するため) @@ -533,12 +662,21 @@ 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' と同方式で群ごとに別色の折れ線を重ねる。 +-- | [日本語]: 頻度多角形 (Ch10 EDA): @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' と同方式で群ごとに別色の折れ線を重ねる。 +-- [English]: A frequency polygon (Ch10 EDA): @geom_freqpoly@. Uses the same +-- binning as histogram ('histBinning') to get each bin's count, then +-- connects the bin center @origin+(i+0.5)*binW@ and count with a line +-- (distinct from the KDE-based 'renderDensity' — this is the raw polyline +-- of bin frequencies). Empty bins fall to count 0, so the line drops to +-- the baseline (same as ggplot's geom_freqpoly). With 'lyHistDensity' set +-- to True, normalizes to after_stat(density) = count/(groupN*binW) (area +-- 1). Color-based grouping (lyColor = ColorByCol) overlays a differently +-- colored line per group, the same way as 'renderDensity'. renderFreqPoly :: Resolver -> Layout -> ThemePalette -> Layer -> [Primitive] renderFreqPoly r layout pal ly = let xs = V.toList (vecOr (lyEncX ly) r) diff --git a/src/Graphics/Hgg/Spec.hs b/src/Graphics/Hgg/Spec.hs --- a/src/Graphics/Hgg/Spec.hs +++ b/src/Graphics/Hgg/Spec.hs @@ -1,19 +1,35 @@ -- | -- Module : Graphics.Hgg.Spec --- Description : Layer 3 ─ VisualSpec / Layer / ColRef + Monoid (Phase 26 §A-2) +-- Description : Layer 3 — VisualSpec / Layer / ColRef types, with Monoid instances -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- 設計方針 (詳細: design/api-style-discussion-2.md + 続き): +-- [日本語]: 設計方針 (詳細: design/api-style-discussion-2.md + 続き): -- -- * 2 階層 Monoid: 'Layer' (= 1 layer 内属性) と 'VisualSpec' (= 図全体) -- * 全 helper が `<>` で paren 無し合成可能 (= plotnine 風) -- * 'ColRef' で「文字列 col 参照」 と「Vector inline」 両対応、 --- ('OverloadedStrings' で `"weight" :: ColRef` が自動 'ColByName') +-- (@OverloadedStrings@ で `"weight" :: ColRef` が自動 'ColByName') -- * core は DataFrame 型に非依存。 col 名 → Vector 解決は 'Resolver' -- callback で render 時に行う (= core 内ではデータ source を持たない) --- * Generic + ToJSON/FromJSON で Spec 全体が **JSON serializable** +-- * Generic + ToJSON/FromJSON で Spec 全体が __JSON serializable__ -- (= frontend ↔ backend 間で共有し、 差分 Patch を送るユースケースを想定) +-- +-- [English]: Design policy (details: design/api-style-discussion-2.md and +-- its follow-ups): +-- +-- * Two-level Monoid: 'Layer' (attributes within a single layer) and +-- 'VisualSpec' (the whole figure) +-- * Every helper composes with `<>` without parentheses (plotnine style) +-- * 'ColRef' supports both "a string column reference" and "an inline +-- Vector" (@OverloadedStrings@ turns `"weight" :: ColRef` automatically +-- into 'ColByName') +-- * core is agnostic to any DataFrame type; resolving a column name to a +-- Vector happens at render time via the 'Resolver' callback (core +-- itself holds no data source) +-- * Generic + ToJSON/FromJSON make the whole Spec __JSON serializable__ +-- (shared between a frontend and a backend, with sending diff Patches +-- as the intended use case) {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} @@ -51,13 +67,15 @@ , defaultConnectSpec -- * 2D 点 'Point2' (= 3D 'Graphics.Hgg.ThreeD.Types.Point3' と対称) , Point2(..) - -- * Phase 51: custom mark (拡張可能な描画語彙) + -- * custom mark (拡張可能な描画語彙) , RenderCtx(..) , CustomMark(..) , customMark , customMarkWith , encX , encY + , encZ + , ternaryScatter, ternaryLine -- ★ Phase 69 A3: 三角座標 mark 束ね -- * Layer constructors (= Layer 返却) , scatter , line @@ -107,11 +125,16 @@ , hexbinLayerCells -- ★ Phase 40: Layer 解決版 (render/colorbar 共有) , subplots , subplotCols + , subplotWidths -- ★ Phase 63 A6: 列の相対幅 (rel_widths) + , subplotHeights -- ★ Phase 63 A6: 行の相対高 (rel_heights) + , subplotTags -- ★ Phase 63 A7: panel 自動タグ (labels="AUTO") + , TagStyle(..) -- ★ Phase 63 A7 , selectPanels , selectedSubplots , scaleXDiscreteLimits , scaleYDiscreteLimits , applyDiscreteLimits + , reindexLayer -- ★ Phase 62 A2: facet の inline 部分列化 (Render.Layer) で共用 , hconcat , vconcat , (<->) @@ -204,7 +227,7 @@ , connectGroup , connectColor , connectWidth - -- * Axis (= Phase 26 §C-2 #1 / #2) + -- * Axis , AxisSpec(..) , AxisKind(..) , AxisFormat(..) @@ -229,26 +252,34 @@ , histBorder , densityFill , hollow - -- * 分布 mark の位置決め (= Phase 36 D1) + -- * 分布 mark の位置決め , Side(..) , nudge , markWidth , side - -- * Bar position adjustment (= Phase 9 B) + -- * Bar position adjustment , Position(..) , position , Coord(..) + , PolarOpts(..) + , defaultPolarOpts + , TernaryOpts(..) -- ★ Phase 69 A4 + , defaultTernaryOpts , coordFlip , coordPolar , coordPolarY + , coordPolarWith + , coordPolarYWith + , coordTernary + , coordTernaryWith -- ★ Phase 69 A4 , reverseX , reverseY , coordCartesianX , coordCartesianY , coordCartesian - -- * Reference line (= Phase 26 §C-2 #3) + -- * Reference line , ReferenceLine(..) - -- * Marginal histogram (= Phase 26 §C-2 #10) + -- * Marginal histogram , MarginalSpec(..) , MarginalKind(..) , defaultMarginalSpec @@ -262,7 +293,7 @@ , legendReverse , legendNcol , legendNrow - -- * DAG (= Phase 26 §E-6, HBM ModelGraph) + -- * DAG (= HBM ModelGraph) , DAGSpec(..) , DAGNode(..) , DAGEdge(..) @@ -277,7 +308,20 @@ , themeSeriesPalette , okabeIto, tolBright, brewerSet2, brewerDark2 , ThemeOverride(..) - , themeGrid, panelFill, panelBorder, themeAxisLine, gridColor, plotBg, axisColor, textColor + , TickDir(..) -- ★ Phase 63 A4 + , Margin(..) -- ★ Phase 63 A5 + , themeGrid, themeGridMajor, themeGridMinor, themeLegendPos -- ★ Phase 63 A2/A3 + , themeTickLength, themeTickDir -- ★ Phase 63 A4 + , themeGridWidth, themeGridMinorWidth, themeAxisLineWidth -- ★ Phase 68 + , themePlotMargin -- ★ Phase 63 A5 + , themeBaseFontSize -- ★ Phase 63 A12 + , themeCowplot, themeMinimalGrid, themeMap -- ★ Phase 63 A8 + , themeCowplotSized, themeMinimalGridSized, themeMapSized -- ★ Phase 63 A14 + , themePlotBg -- ★ Phase 63 A18 + , themeAxisText, themeAxisTitle -- ★ Phase 63 A19 + , themeLegendKeySize -- ★ Phase 63 A19.5 + , themeFontFamily -- ★ Phase 63 A20.5 + , panelFill, panelBorder, themeAxisLine, gridColor, plotBg, axisColor, textColor , themeTitleFont, themeAxisLabelFont, themeTickFont, themeLegendFont, themeAxisTextAngle , themeAxisTextAngleX, themeAxisTextAngleY, axisTextAngleXOf, axisTextAngleYOf , stripFill, themeStrip @@ -285,6 +329,7 @@ -- * Top-level setters (= VisualSpec 返却) , purePlot , layer + , layers -- ★ Phase 66 , title , theme , facet @@ -301,6 +346,7 @@ , facetSpace , xLabel , yLabel + , zLabel , legendTitle , subtitle , caption @@ -335,7 +381,7 @@ , alphaBy -- ★ Phase 30 A8 連続 alpha encoding (= ggplot scale_alpha) , colorCats , orderedCats - -- * Phase 11 A4-b linetype encoding + -- * linetype encoding , LineType(..) , linetype , linetypeBy diff --git a/src/Graphics/Hgg/Spec/Axis.hs b/src/Graphics/Hgg/Spec/Axis.hs --- a/src/Graphics/Hgg/Spec/Axis.hs +++ b/src/Graphics/Hgg/Spec/Axis.hs @@ -1,13 +1,19 @@ -- | -- Module : Graphics.Hgg.Spec.Axis --- Description : AxisSpec ─ 軸 1 本の設定 (scale 種別 / format / break / 回転) +-- Description : AxisSpec — configuration for a single axis (scale, format, breaks, rotation) -- 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 する。 挙動・出力は完全に不変。 +-- [日本語]: 'Graphics.Hgg.Spec' の module 分割で切り出し。 軸 1 本の宣言型設定 +-- 'AxisSpec' (log/sqrt/time scale・範囲・tick・回転・break) とその setter / +-- accessor を持つ。 Spec 内の他 module に依存しない leaf。 公開 API は従来どおり +-- 'Graphics.Hgg.Spec' (facade) が re-export する。 挙動・出力は完全に不変。 +-- [English]: Split out during the module split of 'Graphics.Hgg.Spec'. Holds +-- the declarative per-axis configuration type 'AxisSpec' (log/sqrt/time +-- scale, range, ticks, rotation, breaks) along with its setters and +-- accessors. A leaf module with no dependency on other modules in Spec. +-- The public API is unchanged: 'Graphics.Hgg.Spec' (the facade) still +-- re-exports it. Behavior and output are completely unaffected. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Spec.Axis @@ -30,29 +36,36 @@ import GHC.Generics (Generic) -- =========================================================================== --- AxisSpec ─ 軸 1 本の設定 (Phase 26 §C-2 #1 LogScale + #2 軸 format) +-- AxisSpec ─ 軸 1 本の設定 (LogScale + 軸 format) -- =========================================================================== --- | 軸 scale 種別。 線形 / 対数 / sqrt / time / ordinal / band を将来追加。 --- 現状は AxisLinear / AxisLog / AxisSqrt (P15) / AxisTime (P7)。 +-- | [日本語]: 軸 scale 種別。 線形 / 対数 / sqrt / time / ordinal / band を将来追加。 +-- 現状は AxisLinear / AxisLog / AxisSqrt / AxisTime。 +-- [English]: The axis scale kind. Ordinal / band scales are planned for +-- the future. Currently supports AxisLinear / AxisLog / AxisSqrt / +-- AxisTime. data AxisKind = AxisLinear | AxisLog | AxisSqrt | AxisTime deriving (Show, Eq, Generic) instance ToJSON AxisKind instance FromJSON AxisKind --- | 軸ラベルの数値表記。 +-- | [日本語]: 軸ラベルの数値表記。 +-- [English]: The numeric display format for axis labels. data AxisFormat = AxisIntegerFmt | AxisDecimalFmt !Int -- 小数桁数 | AxisExponentFmt !Int -- 指数表記 N 桁 - | AxisTimeFmt !Text -- ★ P7 timestamp ms → date 文字列 (= "yyyy-MM-dd" 等) + | AxisTimeFmt !Text -- ★ timestamp ms → date 文字列 (= "yyyy-MM-dd" 等) deriving (Show, Eq, Generic) instance ToJSON AxisFormat instance FromJSON AxisFormat --- | 軸 1 本の設定。 全 field を Maybe で Monoid 化、 後勝ち合成。 +-- | [日本語]: 軸 1 本の設定。 全 field を Maybe で Monoid 化、 後勝ち合成。 +-- [English]: The configuration for a single axis. Every field is wrapped +-- in Maybe and turned into a Monoid, with later values winning on +-- combination. data AxisBreak = AxisBreak { abFrom :: !Double, abTo :: !Double } deriving (Show, Eq, Generic) @@ -64,14 +77,14 @@ , axFormat :: !(Last AxisFormat) , axMin :: !(Last Double) , axMax :: !(Last Double) - , axRotate :: !(Last Double) -- ★ P10 軸 label 回転 (度) - , axBreaks :: ![AxisBreak] -- ★ P16 軸不連続範囲 + , axRotate :: !(Last Double) -- ★ 軸 label 回転 (度) + , axBreaks :: ![AxisBreak] -- ★ 軸不連続範囲 , 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=))。 非空なら + -- ★ 明示 tick 位置 (= ggplot scale_*_continuous(breaks=))。 非空なら -- 自動 extendedBreaks を上書き。 numeric 軸のみ有効 (categorical は無視)。 , axTickVals :: ![Double] - -- ★ Phase 11 A4-d: 明示 tick ラベル (= ggplot labels=)。 axTickVals と 1:1 対応 + -- ★ 明示 tick ラベル (= ggplot labels=)。 axTickVals と 1:1 対応 -- (短ければ "" 埋め)。 空なら値を format して使う。 , axTickLabels :: ![Text] } deriving (Show, Eq, Generic) @@ -79,7 +92,7 @@ instance ToJSON AxisSpec instance FromJSON AxisSpec --- ★ Phase 43 A3: レコードフィールド形式 (位置依存撲滅・挙動不変)。axTickVals/axTickLabels +-- ★ レコードフィールド形式 (位置依存撲滅・挙動不変)。axTickVals/axTickLabels -- のみ「右が非空なら右」特殊合成 (list `<>` = 連結と別) を名前付きで温存。 instance Semigroup AxisSpec where a <> b = AxisSpec @@ -100,100 +113,151 @@ instance Monoid AxisSpec where mempty = AxisSpec mempty mempty mempty mempty mempty [] mempty mempty [] [] --- | Last AxisSpec から AxisKind を取り出す (= default は AxisLinear)。 +-- | [日本語]: Last AxisSpec から AxisKind を取り出す (= default は AxisLinear)。 +-- [English]: Extracts the AxisKind from a Last AxisSpec (defaults to +-- 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)。 +-- | [日本語]: Last AxisSpec から AxisFormat を取り出す (= default は AxisDecimalFmt 1 +-- 相当の auto)。 +-- [English]: Extracts the AxisFormat from a Last AxisSpec (defaults to an +-- auto format roughly equivalent to AxisDecimalFmt 1). axisFormatOf :: Last AxisSpec -> Maybe AxisFormat axisFormatOf (Last Nothing) = Nothing axisFormatOf (Last (Just as)) = getLast (axFormat as) --- | 'xAxis (linearAxis)' / 'xAxis (logAxis)' のような書き方の起点。 +-- | [日本語]: 'xAxis (linearAxis)' / 'xAxis (logAxis)' のような書き方の起点。 +-- [English]: The starting point for expressions like '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)。 +-- | [日本語]: time axis (= 値 Unix timestamp ms、 pattern で date 文字列に format)。 +-- [English]: A time axis (values are Unix timestamps in ms, formatted to +-- a date string via the given pattern). timeAxis :: Text -> AxisSpec timeAxis pat = mempty { axKind = Last (Just AxisTime) , axFormat = Last (Just (AxisTimeFmt pat)) } --- | P16: 軸不連続範囲 1 つを追加。 +-- | [日本語]: 軸不連続範囲 1 つを追加。 +-- [English]: Adds a single axis discontinuity (break) range. 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])@。 +-- | [日本語]: A4-d: 明示 tick 位置 (= ggplot scale_*_continuous(breaks=))。 自動 tick を +-- これで上書き (numeric 軸のみ。 categorical 軸では無視)。 範囲外の値は描画時に +-- censor される。 例: @xAxis (axisBreaksAt [0,25,50,75,100])@。 +-- [English]: A4-d: explicit tick positions (like ggplot's +-- scale_*_continuous(breaks=)). Overrides the automatic ticks (numeric +-- axes only; ignored on categorical axes). Values outside the range are +-- censored at render time. Example: +-- @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' を推奨。 +-- | [日本語]: A4-d: 明示 tick ラベル (= ggplot labels=)。 'axisBreaksAt' と組で使い、 i 番目の +-- break に i 番目のラベルを割り当てる (長さは breaks に揃える)。 単体指定でも +-- 自動 break の順に割り当たるが、 通常は 'axisBreaksLabeled' を推奨。 +-- [English]: A4-d: explicit tick labels (like ggplot's labels=). Used +-- together with 'axisBreaksAt' to assign the i-th label to the i-th break +-- (the length should match the breaks). Used alone, labels are assigned +-- in the order of the automatic breaks, but 'axisBreaksLabeled' is +-- usually recommended instead. axisTickLabels :: [Text] -> AxisSpec axisTickLabels ls = mempty { axTickLabels = ls } --- | A4-d: break 位置とラベルを対で指定する便利関数 (= ggplot breaks=/labels= を一度に)。 --- 例: @xAxis (axisBreaksLabeled [(0,\"low\"),(50,\"mid\"),(100,\"high\")])@。 +-- | [日本語]: A4-d: break 位置とラベルを対で指定する便利関数 (= ggplot breaks=/labels= を一度に)。 +-- 例: @xAxis (axisBreaksLabeled [(0,\"low\"),(50,\"mid\"),(100,\"high\")])@。 +-- [English]: A4-d: a convenience function that specifies break positions +-- and labels as pairs (setting ggplot's breaks=/labels= in one step). +-- Example: @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 位置を取り出す (未指定 = [])。 +-- | [日本語]: Last AxisSpec から明示 tick 位置を取り出す (未指定 = [])。 +-- [English]: Extracts the explicit tick positions from a Last AxisSpec +-- (unspecified = []). axTickValsOf :: Last AxisSpec -> [Double] axTickValsOf (Last Nothing) = [] axTickValsOf (Last (Just as)) = axTickVals as --- | Last AxisSpec から明示 tick ラベルを取り出す (未指定 = [])。 +-- | [日本語]: Last AxisSpec から明示 tick ラベルを取り出す (未指定 = [])。 +-- [English]: Extracts the explicit tick labels from a Last AxisSpec +-- (unspecified = []). axTickLabelsOf :: Last AxisSpec -> [Text] axTickLabelsOf (Last Nothing) = [] axTickLabelsOf (Last (Just as)) = axTickLabels as --- | tick を隠す (= pairs / facet の内側 panel 用)。 +-- | [日本語]: tick を隠す (= pairs / facet の内側 panel 用)。 +-- [English]: Hides the ticks (for inner panels in pairs / facet layouts). hideTicks :: AxisSpec hideTicks = mempty { axShowTicks = Last (Just False) } --- | 'xAxis (axisFormat (AxisDecimalFmt 2))' で軸 format を指定。 +-- | [日本語]: 'xAxis (axisFormat (AxisDecimalFmt 2))' で軸 format を指定。 +-- [English]: Specifies the axis format, for example via +-- 'xAxis (axisFormat (AxisDecimalFmt 2))'. axisFormat :: AxisFormat -> AxisSpec axisFormat f = mempty { axFormat = Last (Just f) } --- | 軸 label 回転 (度・**CCW = 反時計回りが正**、 R / matplotlib / ggplot と同じ規約・Phase 50 A1)。 +-- | [日本語]: 軸 label 回転 (度・__CCW = 反時計回りが正__、 R / matplotlib / ggplot と同じ規約)。 -- 30 / 45 / 90 等。 例: @xAxis (axisRotate 90)@ で x 目盛ラベルを CCW 90° -- (縦書き・下→上読み・y 軸タイトルと同じ向き)。 内部の SVG/canvas rotate は CW 正なので -- 'resolveAxisAngle' で符号反転して描画に渡す (公開 API は R 準拠の CCW に統一)。 +-- [English]: The axis label rotation, in degrees +-- (__CCW = counter-clockwise is positive__, the same convention as R / +-- matplotlib / ggplot). Typical values are 30 / 45 / 90. For example, +-- @xAxis (axisRotate 90)@ rotates the x tick labels 90° CCW (vertical +-- text, read bottom-to-top, the same orientation as the y-axis title). +-- Since the internal SVG/canvas rotation is CW-positive, +-- 'resolveAxisAngle' negates the sign before passing it to rendering +-- (the public API is uniformly CCW, matching R). axisRotate :: Double -> AxisSpec axisRotate deg = mempty { axRotate = Last (Just deg) } --- | frontend-settings v0.1 §1.5: 軸 min 値。 +-- | [日本語]: frontend-settings v0.1 §1.5: 軸 min 値。 +-- [English]: frontend-settings v0.1 §1.5: the axis minimum value. axisMin :: Double -> AxisSpec axisMin v = mempty { axMin = Last (Just v) } --- | frontend-settings v0.1 §1.5: 軸 max 値。 +-- | [日本語]: frontend-settings v0.1 §1.5: 軸 max 値。 +-- [English]: frontend-settings v0.1 §1.5: the axis maximum value. axisMax :: Double -> AxisSpec axisMax v = mempty { axMax = Last (Just v) } --- | frontend-settings v0.1 §1.5: 軸 min + max 同時指定。 +-- | [日本語]: frontend-settings v0.1 §1.5: 軸 min + max 同時指定。 +-- [English]: frontend-settings v0.1 §1.5: sets the axis min and max +-- together. axisRange :: Double -> Double -> AxisSpec axisRange lo hi = mempty { axMin = Last (Just lo), axMax = Last (Just hi) } --- | Last AxisSpec から軸 rotation を取り出す (= default 0)。 +-- | [日本語]: Last AxisSpec から軸 rotation を取り出す (= default 0)。 +-- [English]: Extracts the axis rotation from a Last AxisSpec (defaults to +-- 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。 +-- | [日本語]: 軸目盛りラベルの回転角を解決 (__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。 +-- [English]: Resolves the rotation angle for axis tick labels +-- (__CCW positive, canonical__). 'axisRotate', the theme's axis.text angle, +-- and the internal @tsRotate@ are all consistently __CCW positive__ +-- (matching R/matplotlib/ggplot). The conversion to the CW-positive +-- device coordinate system (SVG/canvas/rasterific) happens +-- __exactly once, in each backend's emit step__ (a no-op for PDF, since +-- y-up means CCW already). Explicit per-axis settings take highest +-- priority, falling back to the theme override, then to 0. resolveAxisAngle :: Last AxisSpec -> Last Double -> Double resolveAxisAngle (Last (Just as)) themeAngle | Just d <- getLast (axRotate as) = d @@ -205,7 +269,9 @@ Just d -> d Nothing -> 0 --- | Last AxisSpec から axShowTicks を取り出す (= default True、 Nothing も True 扱い)。 +-- | [日本語]: Last AxisSpec から axShowTicks を取り出す (= default True、 Nothing も True 扱い)。 +-- [English]: Extracts axShowTicks from a Last AxisSpec (defaults to True; +-- Nothing is also treated as True). axisShowTicksOf :: Last AxisSpec -> Bool axisShowTicksOf (Last Nothing) = True axisShowTicksOf (Last (Just as)) = case getLast (axShowTicks as) of diff --git a/src/Graphics/Hgg/Spec/Bake.hs b/src/Graphics/Hgg/Spec/Bake.hs --- a/src/Graphics/Hgg/Spec/Bake.hs +++ b/src/Graphics/Hgg/Spec/Bake.hs @@ -1,14 +1,22 @@ -- | -- Module : Graphics.Hgg.Spec.Bake --- Description : Resolver の焼き込み (ColByName → inline 解決、 Phase 8 B16) +-- Description : Baking the Resolver in (resolving ColByName references to inline data) -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 spec 内の全 +-- [日本語]: '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 する。 挙動・出力は完全に不変。 +-- を持つ。 'VisualSpec' / 'Layer' 全体を走査する sink (被参照ゼロ) ゆえ分割 +-- module 群の最後段。 公開 API は従来どおり 'Graphics.Hgg.Spec' (facade) が +-- re-export する。 挙動・出力は完全に不変。 +-- +-- [English]: A module split out of 'Graphics.Hgg.Spec'. Provides +-- 'bakeSpec', which inlines every 'ColByName' in the spec via the +-- 'Resolver' (into 'ColNum' / 'ColTxt'). Since it is a sink that walks the +-- whole 'VisualSpec' / 'Layer' tree (nothing else references it), it sits +-- last among the split modules. The public API is still re-exported by the +-- 'Graphics.Hgg.Spec' facade as before; behavior and output are completely +-- unchanged. {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Spec.Bake ( bakeSpec @@ -26,7 +34,10 @@ -- (列名参照) のままだと PS で解決できず描画されない (= pairs/facet/legend が空)。 -- JSON 出力前に bakeSpec で全 ColRef を inline 化すると PS でも描ける。 --- | ColByName を Resolver で解決し ColNum/ColTxt に置換 (解決不能なら元のまま)。 +-- | [日本語]: ColByName を Resolver で解決し ColNum/ColTxt に置換 (解決不能なら +-- 元のまま)。 +-- [English]: Resolves a ColByName via the Resolver and replaces it with +-- ColNum/ColTxt (left unchanged if it cannot be resolved). bakeColRef :: Resolver -> ColRef -> ColRef bakeColRef r cr@(ColByName n) = case r n of Just (NumData v) -> ColNum v @@ -45,6 +56,7 @@ bakeLayer r l = l { lyEncX = bakeColRef r <$> lyEncX l , lyEncY = bakeColRef r <$> lyEncY l + , lyEncZ = bakeColRef r <$> lyEncZ l -- ★ Phase 64 A11: ternary 第 3 成分列 , lyEncY2 = bakeColRef r <$> lyEncY2 l , lyErrorX = bakeColRef r <$> lyErrorX l , lyErrorY = bakeColRef r <$> lyErrorY l @@ -58,8 +70,11 @@ , lyOverlay = map (bakeLayer r) (lyOverlay l) -- ★ Phase 36 D2: sub-mark の inline 列も bake } --- | spec 内の全 ColByName を Resolver で inline 化 (layers + facet + subplots 再帰)。 --- JSON 出力前に呼ぶと PS でも Resolver 不要で描ける。 +-- | [日本語]: spec 内の全 ColByName を Resolver で inline 化 (layers + facet + +-- subplots 再帰)。 JSON 出力前に呼ぶと PS でも Resolver 不要で描ける。 +-- [English]: Inlines every ColByName in the spec via the Resolver +-- (recursing through layers + facet + subplots). Calling this before +-- JSON output lets PS draw without needing a Resolver. bakeSpec :: Resolver -> VisualSpec -> VisualSpec bakeSpec r spec = spec { vsLayers = map (bakeLayer r) (vsLayers spec) diff --git a/src/Graphics/Hgg/Spec/Column.hs b/src/Graphics/Hgg/Spec/Column.hs --- a/src/Graphics/Hgg/Spec/Column.hs +++ b/src/Graphics/Hgg/Spec/Column.hs @@ -1,14 +1,22 @@ -- | -- Module : Graphics.Hgg.Spec.Column --- Description : データ列参照 (ColRef/Resolver) + inline 変換 + Point2 (Spec の leaf) +-- Description : Column references (ColRef/Resolver), inline conversion, and Point2 — a Spec leaf -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 55: 'Graphics.Hgg.Spec' (3420 行) の module 分割で切り出した leaf。 +-- [日本語]: '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 する。 挙動・出力は完全に不変。 +-- +-- [English]: A leaf split out of 'Graphics.Hgg.Spec' (3420 lines) during +-- its module split. Carries the 3 column-reference variants ('ColByName' / +-- 'ColNum' / 'ColTxt'), their render-time resolution ('Resolver'), inline +-- column conversion ('Numeric' / 'Categorical'), and the 2D point +-- ('Point2'). The bottom layer, depending on no other module within Spec. +-- The public API is still re-exported by the 'Graphics.Hgg.Spec' facade as +-- before; behavior and output are completely unchanged. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -43,13 +51,23 @@ -- ColRef + Resolver -- =========================================================================== --- | データ列の参照方法。 3 つの variant: +-- | [日本語]: データ列の参照方法。 3 つの variant: -- --- * 'ColByName' ─ 文字列 col 名。 'Resolver' で実 Vector に解決される。 --- * 'ColNum' ─ 数値 Vector を inline (= 即値、 resolver 不要) --- * 'ColTxt' ─ 文字列 Vector を inline (= categorical encoding 用) +-- * 'ColByName' ─ 文字列 col 名。 'Resolver' で実 Vector に解決される。 +-- * 'ColNum' ─ 数値 Vector を inline (= 即値、 resolver 不要) +-- * 'ColTxt' ─ 文字列 Vector を inline (= categorical encoding 用) -- --- 'OverloadedStrings' で `"weight" :: ColRef` が `ColByName "weight"` に。 +-- @OverloadedStrings@ で `"weight" :: ColRef` が `ColByName "weight"` に。 +-- [English]: How a data column is referenced. Three variants: +-- +-- * 'ColByName' — a string column name, resolved to an actual Vector +-- by 'Resolver'. +-- * 'ColNum' — an inline numeric Vector (an immediate value, no +-- resolver needed) +-- * 'ColTxt' — an inline text Vector (for categorical encoding) +-- +-- With @OverloadedStrings@, `"weight" :: ColRef` becomes `ColByName +-- "weight"` automatically. data ColRef = ColByName !Text | ColNum !(Vector Double) @@ -62,38 +80,50 @@ instance IsString ColRef where fromString = ColByName . T.pack --- | Resolver が返すデータ形 (= 数値 or 文字列)。 +-- | [日本語]: Resolver が返すデータ形 (= 数値 or 文字列)。 +-- [English]: The data shape returned by a Resolver (numeric or text). data ColData = NumData !(Vector Double) | TxtData !(Vector Text) deriving (Show, Eq) --- | render 時に col 名を Vector に解決する callback。 --- 数値列 / 文字列列 どちらも返せるよう 'ColData' で union。 +-- | [日本語]: render 時に col 名を Vector に解決する callback。 +-- 数値列 / 文字列列 どちらも返せるよう 'ColData' で union。 +-- [English]: A callback that resolves a column name to a Vector at +-- render time. Unions over 'ColData' so it can return either a numeric +-- or a text column. type Resolver = Text -> Maybe ColData emptyResolver :: Resolver emptyResolver _ = Nothing --- | 'ColRef' を 'ColData' に解決。 inline は variant に応じて直接返す。 +-- | [日本語]: 'ColRef' を 'ColData' に解決。 inline は variant に応じて直接返す。 +-- [English]: Resolves a 'ColRef' to 'ColData'. Inline variants are +-- returned directly according to their 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')。 +-- | [日本語]: 数値解決 (= 数値列 or 数値 inline のみ成功、 文字列は 'Nothing')。 +-- [English]: Numeric resolution (succeeds only for a numeric column or +-- numeric inline data; text yields 'Nothing'). resolveNum :: Resolver -> ColRef -> Maybe (Vector Double) resolveNum r cr = case resolveCol r cr of Just (NumData v) -> Just v _ -> Nothing --- | 文字列解決 (= 文字列 inline or 文字列列のみ成功)。 +-- | [日本語]: 文字列解決 (= 文字列 inline or 文字列列のみ成功)。 +-- [English]: Text resolution (succeeds only for text inline data or a +-- text column). resolveTxt :: Resolver -> ColRef -> Maybe (Vector Text) resolveTxt r cr = case resolveCol r cr of Just (TxtData v) -> Just v _ -> Nothing --- | ColRef の表示名 (= hover tooltip / legend 等)。 +-- | [日本語]: ColRef の表示名 (= hover tooltip / legend 等)。 +-- [English]: The display name of a 'ColRef' (for hover tooltips, the +-- legend, etc.). colRefName :: ColRef -> Text colRefName (ColByName n) = n colRefName (ColNum _) = "<inline-num>" @@ -103,7 +133,10 @@ -- Inline column conversion -- =========================================================================== --- | 数値系 (Vector n / [n], n は Real instance を持つ任意型) を 'ColRef' に。 +-- | [日本語]: 数値系 (Vector n / [n]、 n は Real instance を持つ任意型) を +-- 'ColRef' に。 +-- [English]: Converts numeric data (Vector n / [n], where n is any type +-- with a Real instance) into a 'ColRef'. class Numeric a where toNumVec :: a -> Vector Double @@ -113,7 +146,8 @@ instance Real n => Numeric [n] where toNumVec = V.fromList . map realToFrac --- | 文字列系 (= categorical encoding 用)。 +-- | [日本語]: 文字列系 (= categorical encoding 用)。 +-- [English]: Text data (for categorical encoding). class Categorical a where toTxtVec :: a -> Vector Text @@ -121,15 +155,20 @@ 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 を持つ任意型に対応。 +-- | [日本語]: 数値 (Vector / List) を inline 'ColRef' に。 'Int' / 'Double' / +-- 'Float' / 'Integer' / 'Word' 等 'Real' instance を持つ任意型に対応。 +-- [English]: Converts numeric data (a Vector or list) into an inline +-- 'ColRef'. Works for any type with a 'Real' instance, such as 'Int', +-- 'Double', 'Float', 'Integer', or 'Word'. -- -- > 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 用)。 +-- | [日本語]: 文字列系を inline 'ColRef' に (= categorical encoding 用)。 +-- [English]: Converts text data into an inline 'ColRef' (for categorical +-- encoding). -- -- > colorBy (inlineCat ["red", "blue", "green"]) inlineCat :: Categorical a => a -> ColRef @@ -139,11 +178,19 @@ -- Point2 (= 2D 点・3D 'Point3' と対称) -- =========================================================================== --- | 2D 点 (= world space)。 'Graphics.Hgg.ThreeD.Types.Point3' と対称の直積型。 --- inline の点単位 API ('scatterPoints' / 'linePoints') で使う。 +-- | [日本語]: 2D 点 (= world space)。 @Graphics.Hgg.ThreeD.Types.Point3@ と対称の +-- 直積型。 inline の点単位 API (@scatterPoints@ / @linePoints@) で使う。 +-- [English]: A 2D point (in world space); a product type symmetric to +-- @Graphics.Hgg.ThreeD.Types.Point3@. Used by the inline point-wise API +-- (@scatterPoints@ / @linePoints@). -- --- JSON: positional fields → array @[x, y]@ (= aeson Generic デフォルト挙動・ --- 'Point3' と同形式)。 ※ 'Graphics.Hgg.Render' の @Point@ は screen 空間で別物。 +-- [日本語]: JSON: positional field は array @[x, y]@ になる (= aeson の +-- Generic 既定挙動・@Point3@ と同形式)。 ※ @Graphics.Hgg.Render@ の @Point@ +-- は screen 空間の別物。 +-- [English]: JSON: positional fields become the array @[x, y]@ (the +-- default aeson Generic behavior, in the same shape as @Point3@). Note: +-- the @Point@ type in @Graphics.Hgg.Render@ is a distinct, screen-space +-- type. data Point2 = Point2 !Double !Double deriving (Show, Eq, Generic) instance ToJSON Point2 diff --git a/src/Graphics/Hgg/Spec/Concat.hs b/src/Graphics/Hgg/Spec/Concat.hs --- a/src/Graphics/Hgg/Spec/Concat.hs +++ b/src/Graphics/Hgg/Spec/Concat.hs @@ -1,14 +1,23 @@ -- | -- Module : Graphics.Hgg.Spec.Concat --- Description : 図の合成 (hconcat / vconcat / <-> / <:> + pairs、 patchwork 風) +-- Description : Composing figures (hconcat / vconcat / <-> / <:> plus pairs), patchwork-style -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 複数 'VisualSpec' を +-- [日本語]: 'Graphics.Hgg.Spec' の module 分割で切り出し。 複数 'VisualSpec' を -- 1 枚に並べる合成 (Vega-Lite hconcat/vconcat 相当・patchwork 風演算子) と -- 'pairs' (散布図行列) を持つ。 subplots + subplotCols の純粋な薄ラッパで、 -- レンダリングは既存 subplots 経路を使う。 公開 API は従来どおり -- 'Graphics.Hgg.Spec' (facade) が re-export する。 挙動・出力は完全に不変。 +-- +-- [English]: A module split out of 'Graphics.Hgg.Spec'. Provides +-- composition that arranges multiple 'VisualSpec' values into one figure +-- (equivalent to Vega-Lite's hconcat/vconcat, with patchwork-style +-- operators), plus 'pairs' (a scatterplot matrix). A thin, pure wrapper +-- over subplots + subplotCols; rendering goes through the existing +-- subplots path. The public API is still re-exported by the +-- 'Graphics.Hgg.Spec' facade as before; behavior and output are completely +-- unchanged. {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Spec.Concat ( hconcat @@ -46,11 +55,15 @@ -- ★演算子の選定: '<->'(横)・'<:>'(縦) は Prelude/標準ライブラリと衝突しない -- (旧案 '<|>' は Control.Applicative の Alternative と衝突したため回避した)。 --- | 横並び (= Vega-Lite hconcat): n 要素を 1 行 n 列に。 +-- | [日本語]: 横並び (= Vega-Lite hconcat): n 要素を 1 行 n 列に。 +-- [English]: Places elements side by side (equivalent to Vega-Lite's +-- hconcat): arranges n elements into 1 row of n columns. hconcat :: [VisualSpec] -> VisualSpec hconcat ss = subplots ss <> subplotCols (length ss) --- | 縦並び (= Vega-Lite vconcat): n 要素を n 行 1 列に。 +-- | [日本語]: 縦並び (= Vega-Lite vconcat): n 要素を n 行 1 列に。 +-- [English]: Stacks elements vertically (equivalent to Vega-Lite's +-- vconcat): arranges n elements into n rows of 1 column. vconcat :: [VisualSpec] -> VisualSpec vconcat ss = subplots ss <> subplotCols 1 @@ -65,32 +78,44 @@ infixl 6 <-> infixl 6 <:> --- | 横結合演算子 (= hconcat の二項・同方向チェーンを平坦化)。 +-- | [日本語]: 横結合演算子 (= hconcat の二項・同方向チェーンを平坦化)。 +-- [English]: The horizontal-combine operator (the binary form of +-- hconcat; flattens chains in the same direction). (<->) :: VisualSpec -> VisualSpec -> VisualSpec a <-> b = case asHGroup a of Just xs -> hconcat (xs ++ [b]) Nothing -> hconcat [a, b] --- | 縦結合演算子 (= vconcat の二項・同方向チェーンを平坦化)。 +-- | [日本語]: 縦結合演算子 (= vconcat の二項・同方向チェーンを平坦化)。 +-- [English]: The vertical-combine operator (the binary form of vconcat; +-- flattens chains in the same direction). (<:>) :: VisualSpec -> VisualSpec -> VisualSpec a <:> b = case asVGroup a of Just xs -> vconcat (xs ++ [b]) Nothing -> vconcat [a, b] --- | spec が「純粋な水平グループ (subplots=xs (>1 要素)・cols==要素数)」 なら xs。 +-- | [日本語]: spec が「純粋な水平グループ (subplots=xs (>1 要素)・cols==要素数)」 +-- なら xs。 +-- [English]: If the spec is "a pure horizontal group" (subplots=xs with +-- more than 1 element, and cols equal to the element count), returns 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。 +-- | [日本語]: spec が「純粋な垂直グループ (subplots=xs (>1 要素)・cols==1)」 なら xs。 +-- [English]: If the spec is "a pure vertical group" (subplots=xs with +-- more than 1 element, and cols equal to 1), returns 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 plot (= N 列の posterior 等を N×N grid で対角は density、 +-- 非対角は scatter)。 +-- [English]: A pairs plot (arranges N columns, such as posterior +-- samples, into an N×N grid where the diagonal shows density and the +-- off-diagonal shows scatter). pairs :: [ColRef] -> VisualSpec pairs cols = let n = length cols diff --git a/src/Graphics/Hgg/Spec/Constructors.hs b/src/Graphics/Hgg/Spec/Constructors.hs --- a/src/Graphics/Hgg/Spec/Constructors.hs +++ b/src/Graphics/Hgg/Spec/Constructors.hs @@ -1,15 +1,23 @@ -- | -- Module : Graphics.Hgg.Spec.Constructors --- Description : Layer constructors (= 各 mark の最小起点、 mark カタログ) +-- Description : Layer constructors for plot marks (the mark catalogue) -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 mark ごとの Layer +-- [日本語]: '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 は従来どおり +-- まとめる (user 合意)。 公開 API は従来どおり -- 'Graphics.Hgg.Spec' (facade) が re-export する。 挙動・出力は完全に不変。 +-- [English]: Split out of 'Graphics.Hgg.Spec' as part of its module split. +-- Holds the per-mark Layer constructors ('scatter' / 'line' / 'bar' / ... / +-- 'customMark'), mark-specific setters ('binCount' / 'jitterX' / 'shape' / +-- the 'statLm' family, etc.), and hexbin binning ('HexCell'). Since the +-- contents form a homogeneous mark catalogue (dictionary-like), they are +-- kept in a single module (agreed with the user). The public API is +-- unchanged: 'Graphics.Hgg.Spec' (the facade) still re-exports everything. +-- Behavior and output are fully unchanged. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Spec.Constructors @@ -17,8 +25,9 @@ scatter, line, bar, histogram, histogramDensity , heatmap, boxplot, density, densityFill, freqpoly , scatterPoints, linePoints, unzipPoint2 - -- * custom mark (Phase 51) - , customMark, customMarkWith, encX, encY + -- * custom mark + , customMark, customMarkWith, encX, encY, encZ + , ternaryScatter, ternaryLine -- ★ Phase 69 A3: 三角座標 mark 束ね -- * 統計 / 分布 mark , trace, traceLines, forest, forestNull, funnel, autocorr, autocorrMaxLag, ess , violin, strip, swarm, raincloud, ridge @@ -68,127 +77,229 @@ 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 束縛列を引いてもよい。 +-- | [日本語]: 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 専用)。 +-- HS は closure を直接呼んで描く (SVG/PDF/Rasterific)。 PS canvas で parity が欲しい +-- 時は同じ @cid@ で PS registry に draw 関数を手登録する (無ければ HS 専用)。 +-- [English]: The public API for defining a custom mark. An extension +-- point for adding new plot types without touching the core (the closed +-- @MarkKind@ enum). @cid@ is the stable mark identifier (the key for PS +-- registry dispatch); @draw@ is a drawing closure that takes a +-- 'RenderCtx' and returns a list of 'Primitive'. Data can either be +-- captured in the closure or pulled from the layer's bound columns via +-- 'rcResolver'. -- +-- HS calls the closure directly to draw (SVG/PDF/Rasterific). When +-- parity with the PS canvas is needed, register a draw function by hand +-- in the PS registry under the same @cid@ (otherwise the mark is +-- HS-only). +-- -- > 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。 +-- | [日本語]: option 付き 'customMark'。 @opts@ は PS registry の draw 関数へ渡る +-- serializable JSON。 +-- [English]: 'customMark' with options. @opts@ is serializable JSON +-- passed through to the PS registry's draw function. 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 は普通こう書く: +-- | [日本語]: x / y encoding 列を単独で束ねる 'Layer' setter。 mark 種別に依らず +-- 合成でき、 custom mark を「一級 mark」化する (= 軸 range が 'lyEncX'/'lyEncY' +-- から自動計算され、 @df |>>@ とも連携)。 既存 mark の encoding 上書きにも使える。 +-- custom mark の名前付き combinator は普通こう書く: +-- [English]: A 'Layer' setter that binds the x / y encoding column on its +-- own. It composes with any mark kind and turns a custom mark into a +-- "first-class mark" (axis ranges are computed automatically from +-- 'lyEncX'/'lyEncY', and it works with @df |>>@ too). It can also +-- override the encoding of an existing mark. A named custom-mark +-- combinator is typically written like this: -- -- > dendrogram :: ColRef -> ColRef -> Layer -- > dendrogram x y = customMark "dendrogram" (drawFromCols x y) <> encX x <> encY y --- > -- 使う側: layer (dendrogram "leaf" "height") ← scatter x y と同じ使い勝手 +-- > -- usage: layer (dendrogram "leaf" "height") -- same feel as 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 無改修。 +-- | [日本語]: 三角座標 (ternary) の第 3 成分 aesthetic (= Phase 64 A11)。 encX/encY +-- と合わせ 3 成分 (a,b,c) を直接受ける。 'coordTernary' と併用したときのみ意味を +-- 持つ (直交/極座標では未使用)。 正規化 (合計→1) は library 側 ('normalizeTernary')。 +-- [English]: The third-component aesthetic of ternary coordinates (Phase 64 +-- A11). Together with encX/encY it takes the three components (a,b,c) +-- directly. It only has meaning when combined with 'coordTernary' (unused in +-- Cartesian / polar). Normalization (summing to 1) is done library-side +-- ('normalizeTernary'). +encZ :: ColRef -> Layer +encZ z = mempty { lyEncZ = Last (Just z) } + +-- | [日本語]: ★ Phase 69 A3: 三角座標の散布 mark 束ね。 @scatter a b <> encZ c@ の sugar +-- で、 3 成分 (a=上/b=左下/c=右下) を mark 1 個で受ける。 coord は 'coordOf' が encZ から +-- 'CoordTernary' と推論するので @coordTernary@ は不要 (向きを変える時だけ 'coordTernaryWith')。 +-- → 最小形 @layer (ternaryScatter a b c)@。 +-- [English]: ★ Phase 69 A3: the ternary scatter mark, sugar for +-- @scatter a b <> encZ c@, taking the three components (a=top / b=bottom-left / +-- c=bottom-right) as one mark. The coord is inferred as 'CoordTernary' from encZ +-- by 'coordOf', so @coordTernary@ is unnecessary (use 'coordTernaryWith' only to +-- change orientation). Minimal form: @layer (ternaryScatter a b c)@. +ternaryScatter :: ColRef -> ColRef -> ColRef -> Layer +ternaryScatter a b c = scatter a b <> encZ c + +-- | [日本語]: ★ Phase 69 A3: 三角座標の折れ線 mark 束ね (@line a b <> encZ c@ の sugar)。 +-- [English]: ★ Phase 69 A3: the ternary line mark (sugar for @line a b <> encZ c@). +ternaryLine :: ColRef -> ColRef -> ColRef -> Layer +ternaryLine a b c = line a b <> encZ c + +-- | [日本語]: 2D scatter ('Point2' 直入れ・3D +-- 'Graphics.Hgg.ThreeD.Spec.scatter3DPoints' と対称)。 内部は +-- @scatter (inline xs) (inline ys)@ に等価 (= x/y を inline 列に分解) なので +-- Render/JSON/PS 無改修。 +-- [English]: 2D scatter that takes 'Point2' values directly (the +-- counterpart of the 3D 'Graphics.Hgg.ThreeD.Spec.scatter3DPoints'). +-- Internally equivalent to @scatter (inline xs) (inline ys)@ (x/y are +-- split into inline columns), so Render/JSON/PS need no changes. -- -- > 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)@ に等価。 +-- | [日本語]: 2D line ('Point2' 直入れ・3D 'Graphics.Hgg.ThreeD.Spec.line3DPoints' と +-- 対称)。 内部は @line (inline xs) (inline ys)@ に等価。 +-- [English]: 2D line that takes 'Point2' values directly (the +-- counterpart of the 3D 'Graphics.Hgg.ThreeD.Spec.line3DPoints'). +-- Internally equivalent to @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' 用)。 +-- | [日本語]: '[Point2]' を x / y の 'Double' リストに分解 ('scatterPoints' / +-- 'linePoints' 用)。 +-- [English]: Splits a '[Point2]' into separate x / y 'Double' lists (used +-- by 'scatterPoints' / 'linePoints'). unzipPoint2 :: [Point2] -> ([Double], [Double]) unzipPoint2 = unzip . map (\(Point2 x y) -> (x, y)) --- | Phase 26 A2: vector field (quiver)。 各 (x,y) に成分 (u,v) の矢印を描く +-- | [日本語]: vector field (quiver)。 各 (x,y) に成分 (u,v) の矢印を描く -- (= matplotlib @quiver@)。 矢印長は autoscale (= 最長矢印がデータ対角の ~8%) --- に 'arrowScale' 倍を掛けた長さ。 列バインドは @df |>> quiver \"x\" \"y\" \"u\" \"v\"@。 --- 矢印を magnitude (= √(u²+v²)) で連続色マップするには 'arrowColorByMagnitude'。 +-- に 'arrowScale' 倍を掛けた長さ。 列バインドは +-- @df |>> quiver \"x\" \"y\" \"u\" \"v\"@。 矢印を magnitude (= √(u²+v²)) で +-- 連続色マップするには 'arrowColorByMagnitude'。 +-- [English]: A vector field (quiver). Draws an arrow with components +-- (u,v) at each (x,y), like matplotlib's @quiver@. Arrow length is the +-- autoscale length (the longest arrow is ~8% of the data diagonal) +-- multiplied by 'arrowScale'. Column binding looks like +-- @df |>> quiver \"x\" \"y\" \"u\" \"v\"@. Use 'arrowColorByMagnitude' to +-- map arrows to a continuous color by magnitude (= √(u²+v²)). 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)。 値を上げると矢印が長く。 +-- | [日本語]: quiver 矢印長の倍率 (autoscale × この値・既定 1)。 値を上げると矢印が +-- 長く。 +-- [English]: The scale factor for quiver arrow length (autoscale × this +-- value, default 1). Raising it makes arrows longer. arrowScale :: Double -> Layer arrowScale s = mempty { lyArrowScale = Last (Just s) } --- | Phase 26 A2: quiver の矢印を magnitude (= √(u²+v²)) で連続色マップする (+ 既定 OFF)。 --- 色は連続パレット (viridis 系)。 OFF 時は単色 ('color' / theme)。 +-- | [日本語]: quiver の矢印を magnitude (= √(u²+v²)) で連続色マップする (既定 +-- OFF)。 色は連続パレット (viridis 系)。 OFF 時は単色 ('color' / theme)。 +-- [English]: Maps quiver arrows to a continuous color by magnitude +-- (= √(u²+v²)); default OFF. The color uses a continuous (viridis-family) +-- palette. When OFF, arrows use a single color ('color' / theme). arrowColorByMagnitude :: Layer arrowColorByMagnitude = mempty { lyArrowMagnitude = Last (Just True) } --- | Phase 11 A6: データ駆動テキストラベル (= ggplot @geom_text@)。 各 (x,y) 点に lab 列の --- 文字を描く。 'annotate' (固定 1 点) と違い列駆動で点数ぶん出る。 +-- | [日本語]: データ駆動テキストラベル (= ggplot @geom_text@)。 各 (x,y) 点に lab +-- 列の文字を描く。 'Graphics.Hgg.Spec.Setters.annotate' (固定 1 点) と違い列駆動で点数ぶん出る。 +-- [English]: A data-driven text label (like ggplot's @geom_text@). Draws +-- the text of the lab column at each (x,y) point. Unlike 'Graphics.Hgg.Spec.Setters.annotate' +-- (a single fixed point), it is column-driven and produces one label per +-- row. 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' と同じだが +-- | [日本語]: 背景付きテキストラベル (= ggplot @geom_label@)。 'text' と同じだが -- 各文字の背後に角丸矩形を敷く (= 重なる点の上でも読みやすい)。 +-- [English]: A text label with a background (like ggplot's +-- @geom_label@). Same as 'text' but draws a rounded rectangle behind +-- each label (readable even over overlapping points). 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 列は持たない)。 +-- | [日本語]: Q-Q plot (= ggplot @stat_qq@ / @geom_qq@)。 sample 列のみを取り、 +-- ソートした order statistic y_(i) を y、 理論正規分位点 Φ⁻¹((i-0.5)/n) を x に +-- 置いて点を描く (= 正規性の視覚診断)。 理論分位点は render / range 側で算出する +-- ため、 ここでは sample を encY に保持するだけ (encX 列は持たない)。 +-- [English]: A Q-Q plot (like ggplot's @stat_qq@ / @geom_qq@). Takes only +-- a sample column and plots points with the sorted order statistic +-- y_(i) as y and the theoretical normal quantile Φ⁻¹((i-0.5)/n) as x +-- (a visual diagnostic for normality). Since the theoretical quantiles +-- are computed on the render / range side, this only stores sample in +-- encY (there is no encX column). 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) をソートして +-- | [日本語]: ECDF plot (= ggplot @stat_ecdf@)。 sample 列 (encX) をソートして -- 右連続の経験累積分布 F(x)=#(≤x)/n を階段状に描く (y∈[0,1])。 +-- [English]: An ECDF plot (like ggplot's @stat_ecdf@). Sorts the sample +-- column (encX) and draws the right-continuous empirical CDF +-- F(x)=#(≤x)/n as a step curve (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 (= ggplot @geom_linerange@)。 各 (x,y) に縦線 y±err を描く。 +-- [English]: A linerange (like ggplot's @geom_linerange@). Draws a +-- vertical segment y±err at each (x,y). 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 (= ggplot @geom_pointrange@)。 linerange + 中心点。 +-- [English]: A pointrange (like ggplot's @geom_pointrange@): a linerange +-- plus a center point. 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 (= ggplot @geom_crossbar@)。 幅付き箱 (y±err) + 中央水平線。 +-- [English]: A crossbar (like ggplot's @geom_crossbar@): a box of width +-- y±err with a horizontal center line. 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@)。 +-- | [日本語]: stat_function (= ggplot @stat_function@ / @geom_function@)。 -- 関数 f を [xLo, xHi] で n 点サンプルし、 inline 列の line layer を生成する。 --- 関数自体は JSON 化できないため **構成時にサンプル点へ焼き込む** (= spec には点列が入り、 --- canvas backend は通常の line として描く)。 n<2 は 2 に切り上げ。 +-- 関数自体は JSON 化できないため __構成時にサンプル点へ焼き込む__ (= spec には +-- 点列が入り、 canvas backend は通常の line として描く)。 n<2 は 2 に切り上げ。 +-- [English]: stat_function (like ggplot's @stat_function@ / +-- @geom_function@). Samples the function f at n points over +-- [xLo, xHi] and produces a line layer with inline columns. Since the +-- function itself cannot be serialized to JSON, __the sample points are baked in at construction time__ +-- (the spec holds the point series, and the canvas backend draws it as +-- an ordinary line). n<2 is rounded up to 2. statFunction :: (Double -> Double) -> Double -> Double -> Int -> Layer statFunction f xLo xHi n = let m = max 2 n @@ -200,49 +311,88 @@ 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 幅は +-- | [日本語]: 頻度多角形 (Ch10 EDA): @geom_freqpoly(aes(x = …))@ 相当。 histogram +-- と同じ bin 化で各 bin の count を求め、 bin 中心を折れ線で結ぶ。 bin 幅は -- 'binWidth' / 'binCount'、 after_stat(density) は 'histogramDensity' True で -- 流用 (= histogram と同じフラグ)。 color aesthetic ('colorBy') で群分割すると -- 群ごとに別色の折れ線を重ねる (cut 別 price 分布の比較等)。 +-- [English]: A frequency polygon (Ch10 EDA): the equivalent of +-- @geom_freqpoly(aes(x = …))@. Uses the same binning as histogram to +-- compute each bin's count, then connects the bin centers with a line. +-- Bin width follows 'binWidth' / 'binCount', and after_stat(density) is +-- reused via 'histogramDensity' True (the same flag as histogram). When +-- split by a color aesthetic ('colorBy'), overlays one differently +-- colored line per group (e.g. comparing price distributions by cut). 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 を上書き可。 +-- | [日本語]: Ch10 EDA: 2 カテゴリ変数の件数 (= ggplot @geom_count()@ / +-- @stat_sum@)。 @countXY x y@ は (x,y) のカテゴリ組合せごとに観測件数を集計し、 +-- 各セル中心に面積 ∝ 件数 (= 半径 ∝ √件数) の点を描く。 'size' で最大半径 px を +-- 上書き可。 +-- [English]: Ch10 EDA: counts for two categorical variables (like +-- ggplot's @geom_count()@ / @stat_sum@). @countXY x y@ tallies the +-- observed count for each (x,y) category combination and draws a point +-- at each cell center with area ∝ count (radius ∝ √count). 'size' +-- overrides the maximum radius in 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。 +-- | [日本語]: MCMC autocorrelation plot (P19): 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)` 相当 (= 但し片側のみ)。 +-- [English]: MCMC autocorrelation plot (P19): computes the lag-k +-- autocorrelation r(τ) from a single time-series column and displays it +-- as a bar chart. The max lag is set with 'autocorrMaxLag' (default 40), +-- and the ±1.96/√N significance band is drawn alongside. +-- +-- r(τ) = Σ(x_t - μ)(x_{t+τ} - μ) / Σ(x_t - μ)² +-- +-- Corresponds to matplotlib's `plt.acorr(x, maxlags=40)` (one-sided +-- only). autocorr :: ColRef -> Layer autocorr c = mempty { lyKind = First (Just MAutocorr) , lyEncX = Last (Just c) } --- | autocorr の max lag (= 'autocorr' と '<>' で組合せ)。 default 40。 +-- | [日本語]: autocorr の max lag (= 'autocorr' と '<>' で組合せ)。 default 40。 +-- [English]: The max lag for autocorr (combine with 'autocorr' via +-- '<>'). Default 40. autocorrMaxLag :: Int -> Layer autocorrMaxLag n = mempty { lyMaxLag = Last (Just n) } --- | Effective Sample Size plot (P20、 Phase 6 A5): chain ごとに ESS bar を描画。 +-- | [日本語]: Effective Sample Size plot (P20): 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 流の「計算と描画の分離」)。 +-- [English]: Effective Sample Size plot (P20): draws an ESS bar per +-- chain. The chain group is set with 'chain' (= 'ess vals <> chain +-- chainCol'); with no chain specified, the whole series is treated as a +-- single chain with a single bar. +-- +-- ESS = N / (1 + 2 Σ |r(τ)|) (from τ=1 up to where r(τ) > 0) +-- +-- Corresponds to arviz/matplotlib's `az.plot_ess(idata)`, per-chain bars +-- (a simplified version). +-- | [日本語]: ESS 棒グラフ: encX = パラメータ/chain 名 (categorical)、 +-- encY = 計算済み ESS 値。 ESS の計算は統計ライブラリ (analyze 側) の責務で、 +-- plot は値を棒にするだけ (= ggplot/bayesplot mcmc_neff 流の「計算と描画の +-- 分離」)。 +-- [English]: ESS bar chart: encX is the parameter/chain name +-- (categorical), encY is the precomputed ESS value. Computing ESS is the +-- responsibility of the statistics library (the analyze side); plot +-- merely turns the values into bars (the same separation of computation +-- and drawing as ggplot/bayesplot's mcmc_neff). ess :: ColRef -> ColRef -> Layer ess nameCol essCol = mempty { lyKind = First (Just MEss) @@ -250,19 +400,36 @@ , lyEncY = Last (Just essCol) } --- | chain group 列を設定 (= 'autocorr' / 'ess' で chain 分け、 MTrace でも将来使用)。 +-- | [日本語]: chain group 列を設定 (= 'autocorr' / 'ess' で chain 分け、 MTrace でも +-- 将来使用)。 +-- [English]: Sets the chain-group column (used by 'autocorr' / 'ess' to +-- split by chain; will also be used by MTrace in the future). chain :: ColRef -> Layer chain c = mempty { lyChain = Last (Just c) } --- | Forest plot (Phase 6 A2): 各 row が「label + 点推定 + CI」 の horizontal CI bar 群。 +-- | [日本語]: Forest plot: 各 row が「label + 点推定 + CI」 の horizontal CI bar +-- 群。 -- --- 引数: label 列 (= categorical/text)、 point estimate 列、 ± 半幅 列 (= 対称 CI)。 +-- 引数: label 列 (= categorical/text)、 点推定 列、 ± 半幅 列 (= 対称 CI)。 -- -- * y 軸: label -- * x 軸: estimate -- * 中央 vertical 線: 'forestNull' (= default 0、 メタ解析慣例で OR は 1) -- -- asymmetric CI (= lo / hi 個別) は将来。 現状は対称 CI のみ。 +-- [English]: A forest plot: a group of horizontal CI bars, one row per +-- "label + point estimate + CI". +-- +-- Arguments: the label column (categorical/text), the point-estimate +-- column, and the ± half-width column (a symmetric CI). +-- +-- * y axis: label +-- * x axis: estimate +-- * center vertical line: 'forestNull' (default 0; meta-analysis +-- convention uses 1 for an odds ratio) +-- +-- Asymmetric CI (separate lo / hi) is a future addition; only symmetric +-- CI is supported today. forest :: ColRef -> ColRef -> ColRef -> Layer forest labelCol estCol errCol = mempty { lyKind = First (Just MForest) @@ -271,14 +438,19 @@ , lyErrorX = Last (Just errCol) } --- | Forest plot の null effect 位置 (= 縦 0 線、 メタ解析の reference)。 default 0。 --- リスク比 / オッズ比 を log scale で扱う場合は 0 (= log 1)、 線形なら 0 (= 差)。 +-- | [日本語]: Forest plot の null effect 位置 (= 縦 0 線、 メタ解析の reference)。 +-- default 0。 リスク比 / オッズ比 を log scale で扱う場合は 0 (= log 1)、 線形なら +-- 0 (= 差)。 +-- [English]: The null-effect position for a forest plot (the vertical +-- reference line at 0, the meta-analysis reference). Default 0. When +-- handling risk ratios / odds ratios on a log scale, 0 (= log 1); on a +-- linear scale, 0 (= no difference). 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。 +-- | [日本語]: Funnel plot: 効果量 vs 標準誤差の散布図 + 95% 信頼区間 envelope。 -- -- 引数: 効果量 (effect) 列、 標準誤差 (SE) 列。 出版 bias 確認に使う。 -- @@ -286,6 +458,16 @@ -- * y 軸: SE (= 上方が精度高、 下方が精度低) -- * 中央 vertical 線: pooled mean (= データから算出) -- * diagonal 線: pooled ± 1.96 * SE の envelope +-- [English]: A funnel plot: a scatter of effect size vs. standard error +-- plus a 95% confidence envelope. +-- +-- Arguments: the effect-size (effect) column and the standard-error (SE) +-- column. Used to check for publication bias. +-- +-- * x axis: effect (the estimate) +-- * y axis: SE (higher = more precise, lower = less precise) +-- * center vertical line: the pooled mean (computed from the data) +-- * diagonal lines: the pooled ± 1.96 * SE envelope funnel :: ColRef -> ColRef -> Layer funnel effectCol seCol = mempty { lyKind = First (Just MFunnel) @@ -293,44 +475,71 @@ , lyEncY = Last (Just seCol) } --- | Box plot。 ★ Phase 36: 値 1 列を受ける。 群分けは @<> groupBy "g"@ (色一律) / +-- | [日本語]: Box plot。 ★ 値 1 列を受ける。 群分けは @<> groupBy "g"@ (色一律) / -- @<> colorBy "g"@ (群色+凡例) で付ける (ggplot 同型)。 群指定なしなら単一 box。 +-- [English]: A box plot. Takes a single value column. Grouping is added +-- with @<> groupBy "g"@ (uniform color) / @<> colorBy "g"@ (per-group +-- color + legend), matching ggplot. With no group specified, it draws a +-- single 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 推奨。 +-- | [日本語]: ★ 群で分けて配置するチャネル (= ggplot @aes(group=)@)。 色は付けない +-- (一律。 色は 'color' / 'colorBy' で別途)。 distribution mark (boxplot/violin +-- 等) では群ごとに集約を作りカテゴリ x に並べる。 内部表現は encX (= 既存の +-- 群配置機構を流用)。 ⚠ @Data.List.groupBy@ と同名なので、 両方 import する場合は +-- qualified 推奨。 +-- [English]: A channel for grouping and positioning marks (like +-- ggplot's @aes(group=)@). It does not add color (uniform; use 'color' / +-- 'colorBy' separately for that). Distribution marks (boxplot/violin, +-- etc.) build one aggregate per group and lay them out along categorical +-- x. Internally represented as encX (reusing the existing group-layout +-- mechanism). ⚠ Shares a name with @Data.List.groupBy@; use a qualified +-- import if importing both. groupBy :: ColRef -> Layer groupBy g = mempty { lyEncX = Last (Just g) } --- | Density plot: x 列の値ベクター で Gaussian KDE 曲線。 +-- | [日本語]: Density plot: x 列の値ベクターで Gaussian KDE 曲線。 +-- [English]: A density plot: a Gaussian KDE curve over the x column's +-- values. density :: ColRef -> Layer density x = mempty { lyKind = First (Just MDensity), lyEncX = Last (Just x) } --- | Phase 8 B16: pairs 対角用 density。 y 軸目盛りは値範囲 (= 行の変数値、 散布図行と --- 共有)、 KDE 曲線は panel 高さに独立正規化して描く (= seaborn pairplot 対角の挙動)。 +-- | [日本語]: pairs 対角用 density。 y 軸目盛りは値範囲 (= 行の変数値、 散布図行と +-- 共有)、 KDE 曲線は panel 高さに独立正規化して描く (= seaborn pairplot 対角の +-- 挙動)。 +-- [English]: A density mark for the diagonal of a pairs plot. The y-axis +-- ticks use the value range (the row's variable values, shared with the +-- scatter row), while the KDE curve is independently normalized to the +-- panel height (matching seaborn pairplot's diagonal behavior). 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 chart (= encX cat, encY 値合計の扇)。 +-- [English]: A pie chart (encX gives the category, encY the value whose +-- sum defines each slice). 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 chart (= encX cat, encY delta、 累積 bar)。 +-- [English]: A waterfall chart (encX gives the category, encY the +-- delta; bars accumulate). 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): x = カテゴリ, y = カテゴリ, value = 数値。 各 (x,y) セルを +-- value の連続色 (Viridis) で塗る。 value は ColorByContinuous で表現。 PS heatmap +-- と対応。 +-- [English]: A heatmap: x is a category, y is a category, value is +-- numeric. Each (x,y) cell is colored using value's continuous color +-- (Viridis); value is represented via ColorByContinuous. Corresponds to +-- the PS heatmap. heatmap :: ColRef -> ColRef -> ColRef -> Layer heatmap x y v = mempty { lyKind = First (Just MHeatmap) @@ -338,9 +547,12 @@ , lyColor = Last (Just (ColorByContinuous v)) } --- | Phase 26 S5-e-1: Contour / binned heatmap (= 連続 x/y/z、 grid 化して --- | セル平均を Viridis 色マッピング)。 ResponseSurface の基盤。 --- | color は ColorByContinuous で z 列を表現。 +-- | [日本語]: Contour / binned heatmap (= 連続 x/y/z、 grid 化してセル平均を +-- Viridis 色マッピング)。 ResponseSurface の基盤。 color は ColorByContinuous で +-- z 列を表現。 +-- [English]: Contour / binned heatmap (continuous x/y/z, gridded and +-- the per-cell average mapped to a Viridis color). The foundation for +-- ResponseSurface. color represents the z column via ColorByContinuous. contour :: ColRef -> ColRef -> ColRef -> Layer contour x y z = mempty { lyKind = First (Just MContour) @@ -348,11 +560,18 @@ , 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 同等。 +-- | [日本語]: filled contour (= matplotlib @contourf@ / ggplot +-- @geom_contour_filled@)。 等値帯を Viridis 連続色で塗る。 入力が規則 grid +-- (x 固有値 × y 固有値が全組存在) なら補間せず直入力、 散布なら k 近傍 IDW で +-- 格子化 ('Graphics.Hgg.Math.Griddata')。 線の 'contour' と重畳すると +-- matplotlib の contourf+contour 同等。 +-- [English]: A filled contour (like matplotlib's @contourf@ / ggplot's +-- @geom_contour_filled@). Fills iso-bands with a continuous Viridis +-- color. If the input is a regular grid (every combination of the x and +-- y distinct values is present), it is used as-is with no +-- interpolation; scattered input is gridded via k-nearest-neighbor IDW +-- ('Graphics.Hgg.Math.Griddata'). Overlaying it with the line-based +-- 'contour' matches matplotlib's contourf+contour. contourFilled :: ColRef -> ColRef -> ColRef -> Layer contourFilled x y z = mempty { lyKind = First (Just MContourFilled) @@ -360,17 +579,26 @@ , lyColor = Last (Just (ColorByContinuous z)) } --- | Phase 24 A4: 等高線の本数 (既定 8)。 @contour x y z <> contourLevels 12@。 +-- | [日本語]: 等高線の本数 (既定 8)。 @contour x y z <> contourLevels 12@。 +-- [English]: The number of contour levels (default 8). Example: +-- @contour x y z <> contourLevels 12@. contourLevels :: Int -> Layer contourLevels n = mempty { lyContourLevels = Last (Just n) } --- | Phase 24 A4: 等高線レベルの明示指定 (本数指定より優先)。 +-- | [日本語]: 等高線レベルの明示指定 (本数指定より優先)。 +-- [English]: Explicitly specifies contour levels (takes priority over +-- the level-count setting). 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 の塗り基盤。 +-- | [日本語]: binned heatmap (= ggplot geom_bin2d / stat_summary_2d)。 連続 +-- x/y/z を nBins×nBins の grid に binning し、 各セルの z 平均を連続色 +-- (Viridis) で塗る。 'contour' (等高線) の塗り版。 ResponseSurface の塗り基盤。 +-- [English]: A binned heatmap (like ggplot's geom_bin2d / +-- stat_summary_2d). Bins continuous x/y/z into an nBins×nBins grid and +-- colors each cell by its z average using a continuous (Viridis) color. +-- The filled counterpart of the contour-line 'contour'; the foundation +-- for the filled ResponseSurface. bin2d :: ColRef -> ColRef -> ColRef -> Layer bin2d x y z = mempty { lyKind = First (Just MBin2d) @@ -378,20 +606,36 @@ , 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 相当。 +-- | [日本語]: Ch10 EDA: 2D bin の__件数__を連続色で塗る (= ggplot @geom_bin2d()@ +-- 既定)。 @bin2dCount x y@ は連続 x/y を 12×12 grid に binning し、 各セルの +-- __観測件数__を Viridis で塗る (z 列なし = 'bin2d' の count 版)。 'bin2d' +-- (z 平均) は stat_summary_2d 相当。 +-- [English]: Ch10 EDA: colors the __count__ of a 2D bin with a +-- continuous color (ggplot's @geom_bin2d()@ default). @bin2dCount x y@ +-- bins continuous x/y into a 12×12 grid and colors each cell by its +-- __observed count__ using Viridis (no z column — the count version of +-- 'bin2d'). 'bin2d' (z average) corresponds to 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' (再ビニング) を使う。 +-- | [日本語]: geom_tile / geom_raster 相当。 連続 x/y を__セル中心__、 fill を +-- __離散カテゴリ__として矩形をベタ塗りする (幅/高さは格子間隔から自動・隙間 +-- なし)。 bin2d と違い再ビニングせず 1 行=1 セルをそのまま塗る (= 決定境界の +-- res×res グリッド塗り)。 fill の離散色と離散凡例は colorBy 経路で自動 (重ねる +-- 散布点と同じカテゴリ空間ならパレット一致)。 連続 fill の塗りは 'bin2d' +-- (再ビニング) を使う。 +-- [English]: The equivalent of geom_tile / geom_raster. Treats +-- continuous x/y as a __cell center__ and fill as a __discrete category__, +-- filling rectangles solidly (width/height are derived +-- automatically from the grid spacing, with no gaps). Unlike bin2d, it +-- does not re-bin — one row is drawn as one cell as-is (used for +-- painting a decision-boundary res×res grid). The discrete fill color +-- and legend are handled automatically via the colorBy path (palettes +-- match an overlaid scatter's category space). For continuous fill, use +-- 'bin2d' (which re-bins). tile :: ColRef -> ColRef -> ColRef -> Layer tile x y fill = mempty { lyKind = First (Just MTile) @@ -399,81 +643,142 @@ , 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 (= matplotlib @hexbin@ / ggplot @geom_hex@)。 連続 x/y を +-- __六角格子__で binning し、 各セルの__観測件数__を Viridis 連続色で塗る (= +-- 散布過密の密度可視化)。 セル分割数は 'hexbinBins' で上書き (既定 30)。 矩形 +-- ビンの 'bin2dCount' の六角版。 アルゴは d3-hexbin (Carr 1987) を binwidth +-- 正規化空間で適用 (pointy-top)。 +-- [English]: hexbin (like matplotlib's @hexbin@ / ggplot's @geom_hex@). +-- Bins continuous x/y into a __hexagonal grid__ and colors each cell by +-- its __observed count__ using a continuous Viridis color (a density +-- visualization for dense scatter). The number of cell divisions is +-- overridden via 'hexbinBins' (default 30); the hexagonal counterpart of +-- the rectangular-bin 'bin2dCount'. The algorithm applies d3-hexbin +-- (Carr 1987) in binwidth-normalized space (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 と共有フィールド)。 +-- | [日本語]: hexbin の x 方向セル分割数を指定 (= ggplot @bins@ / matplotlib +-- @gridsize@)。 既定 30。 'hexbin' に @<>@ で重ねる: +-- @layer (hexbin "x" "y" <> hexbinBins 40)@。 内部は 'lyBinCount' を流用 +-- (histogram と共有フィールド)。 +-- [English]: Sets the number of x-direction cell divisions for hexbin +-- (like ggplot's @bins@ / matplotlib's @gridsize@). Default 30. Layer it +-- onto 'hexbin' with @<>@: @layer (hexbin "x" "y" <> hexbinBins 40)@. +-- Internally reuses 'lyBinCount' (a field shared with histogram). hexbinBins :: Int -> Layer hexbinBins n = mempty { lyBinCount = Last (Just n) } --- | P12: step plot (= 階段状 line)。 +-- | [日本語]: P12: step plot (= 階段状 line)。 +-- [English]: P12: a step plot (a staircase-shaped 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 等で解決する。 +-- | [日本語]: 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 等で解決する。 +-- [English]: An in-place (stat-in) linear regression (like ggplot's +-- @geom_smooth(method="lm")@). A pure tag Layer. Before drawing, the +-- analyze-bridge's @resolveStats@ performs the fit via hanalyze and +-- expands it into a confidence band (band) plus a regression line +-- (line). Decoration works the same as an ordinary geom: +-- @statLm "x" "y" <> color N.red <> stroke 2@. It is never drawn on its +-- own (the renderer skips MStatLM) — it must be resolved via the +-- bridge's saveSVGBoundStats or similar. 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 幅に反映する。 +-- | [日本語]: 信頼水準を指定できる線形回帰 stat。 'statLm' は 0.95 固定だが、 +-- こちらは @lvl@ (例 0.99) を 'lyStatLevel' に持たせる。 resolveStats が band +-- 幅に反映する。 +-- [English]: A linear-regression stat that lets you specify the +-- confidence level. Whereas 'statLm' is fixed at 0.95, this one stores +-- @lvl@ (e.g. 0.99) in 'lyStatLevel'; resolveStats reflects it in the +-- band width. 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 に引き継がれる。 +-- | [日本語]: stat-in B-spline 平滑 (= ggplot @geom_smooth()@)。 knot 数 n。 +-- 曲線のみ (帯なし)。 resolveStats が hanalyze で fit し line に展開。 装飾は +-- line に引き継がれる。 +-- [English]: An in-place (stat-in) B-spline smoother (like ggplot's +-- @geom_smooth()@), with n knots. Curve only (no band). resolveStats fits +-- it via hanalyze and expands it into a line; decoration carries over to +-- the 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@)。 +-- | [日本語]: 信頼帯つき B-spline 平滑。 'statSmooth' は曲線のみだが、 こちらは +-- 'lyStatLevel' を Just にして「帯あり」を signal する。 resolveStats が bs +-- 設計行列の confidenceBand で band+line に展開する。 既定水準は 0.95 +-- (@statSmoothCI x y n@)。 +-- [English]: A B-spline smoother with a confidence band. Whereas +-- 'statSmooth' is curve-only, this one sets 'lyStatLevel' to Just to +-- signal "band included". resolveStats expands it into band+line via the +-- bs design matrix's confidenceBand. The default level is 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)。 +-- | [日本語]: 多項式回帰 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)。 +-- [English]: A polynomial-regression stat (like ggplot's +-- @geom_smooth(method="lm", formula=y~poly(x,deg))@). The degree deg +-- reuses 'lyBinCount'. resolveStats fits @y ~ poly(x,deg)@ and expands it +-- into band+line; the confidence band's level is 'lyStatLevel' (default +-- 0.95). It is never drawn on its own (the renderer skips MStatPoly). 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 が必要。 +-- | [日本語]: 残差 vs fitted 診断散布 (= base R @plot(lm)@ #1)。 @y ~ x@ で fit し +-- 各点を (fitted, residual) に写した scatter に展開する (回帰診断)。 装飾は +-- scatter に引き継ぐ。 ★単体では描画されない (renderer は MStatResid を +-- skip)。 bridge resolveStats が必要。 +-- [English]: A residual-vs-fitted diagnostic scatter (base R's +-- @plot(lm)@ #1). Fits @y ~ x@ and expands each point into a scatter +-- mapped to (fitted, residual) — a regression diagnostic. Decoration +-- carries over to the scatter. It is never drawn on its own (the +-- renderer skips MStatResid); it requires the bridge's 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。 +-- | [日本語]: P11: stem / lollipop plot。 +-- [English]: P11: a 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)。 +-- | [日本語]: 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)。 +-- [English]: TODO-11 (2026-05-27): an area band (a confidence interval / +-- prediction band). +-- x = the shared x axis +-- yLow = the lower bound y +-- yHigh = the upper bound y +-- Rendered as a single PPath fill (forward along x-yLow, backward along +-- x-yHigh, then close). alpha is set via the layer modifier `alpha` +-- (default 0.2). band :: ColRef -> ColRef -> ColRef -> Layer band x yLow yHigh = mempty { lyKind = First (Just MBand) @@ -482,85 +787,145 @@ , 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) は行わない。 +-- | [日本語]: streamgraph (= 中心化積層 area)。 +-- x = 共通 x 軸 (連続、 例: 時間) +-- y = 各系列の値 +-- 系列分割は color aesthetic で行う (= 'bar' の群分けと同じ機構)。 +-- +-- > stream "t" "value" <> colorBy "series" +-- +-- 各 x 点で系列を積層し baseline を -(Σy)/2 から開始する (silhouette 中心化)。 +-- wiggle 最小化 (ThemeRiver) は行わない。 +-- [English]: A streamgraph (a centered, stacked area). +-- x = the shared x axis (continuous, e.g. time) +-- y = each series' value +-- Series are split via the color aesthetic (the same mechanism used for +-- grouping in 'bar'). +-- +-- > stream "t" "value" <> colorBy "series" +-- +-- At each x point, series are stacked with the baseline starting at +-- -(Σy)/2 (silhouette centering). Wiggle minimization (ThemeRiver) is not +-- performed. 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。 +-- | [日本語]: P2: violin plot。 ★ boxplot と同じく __値 1 列__を受ける。 群分けは +-- @<> groupBy "g"@ (色一律) / @<> colorBy "g"@ (群色+凡例) で付ける (ggplot +-- 同型)。 群指定なしなら単一 violin。 +-- [English]: P2: a violin plot. Like boxplot, it takes a __single value column__. +-- Grouping is added with @<> groupBy "g"@ (uniform color) / +-- @<> colorBy "g"@ (per-group color + legend), matching ggplot. With no +-- group specified, it draws a single violin. violin :: ColRef -> Layer violin v = mempty { lyKind = First (Just MViolin), lyEncY = Last (Just v) } --- | P3: strip plot。 ★ Phase 36 B1c: 値 1 列 + groupBy/colorBy で群分け。 +-- | [日本語]: P3: strip plot。 ★ 値 1 列 + groupBy/colorBy で群分け。 +-- [English]: P3: a strip plot. A single value column, grouped via +-- 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 で群分け。 +-- | [日本語]: P3: swarm plot。 ★ 値 1 列 + groupBy/colorBy で群分け。 +-- [English]: P3: a swarm plot. A single value column, grouped via +-- 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)。 +-- | [日本語]: P22: raincloud (= violin + box + strip 合成)。 ★ 値 1 列 + +-- groupBy/colorBy。 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)。 +-- [English]: P22: raincloud (a composite of violin + box + strip). A +-- single value column, grouped via groupBy/colorBy. A direct mark +-- combinator: @a \<+\> b@ returns a __single Layer__ with a as the base +-- and b as the overlaid sub-mark (since the return type stays Layer, +-- group modifiers such as @raincloud v \<+\> ... \<\> groupBy g@ keep +-- working as before). b's own overlays are flattened in as well. +-- Rendering draws the base plus each overlay by "inheriting the +-- parent's group (encX), color (colorBy) and value (encY), with its own +-- kind/nudge/markWidth/side". Intended for overlaying 1D distribution +-- marks (box/violin/strip/swarm) — used by raincloud / custom +-- composites. 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@ は従来どおり群分けする。 +-- | [日本語]: P22: raincloud (= 半 violin + box + jitter strip の合成)。 ★ 専用 +-- mark を廃し '<+>' による 3 sub-mark 合成の preset に降格 (= 位置決めは D1 +-- つまみ nudge/markWidth/side に委譲)。 戻り型は Layer なので +-- @raincloud v \<\> groupBy g@ / @\<\> colorBy g@ は従来どおり群分けする。 +-- [English]: P22: raincloud (a composite of a half violin + box + +-- jitter strip). Retired as a dedicated mark and demoted to a preset +-- built from a 3-sub-mark composite via '<+>' (positioning is delegated +-- to the D1 knobs nudge/markWidth/side). Since the return type is Layer, +-- @raincloud v \<\> groupBy g@ / @\<\> colorBy g@ still group as before. 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)。 +-- | [日本語]: 合成 Layer (base + overlay sub-mark) の値列レーン (= encY の +-- distinct・base 先頭・'colRefName' で重複除去)。 描画/Layout は各マークの +-- slot を「自 encY が此のレーン列の何番目か」で決める。 同一列なら 1 レーン +-- (= raincloud の重畳)、 複数列なら横並び (= distCols)。 +-- [English]: The value-column lanes of a composite Layer (base + overlay +-- sub-marks) — the distinct encY values, base first, deduplicated via +-- 'colRefName'. Drawing/layout decides each mark's slot by "which +-- position its own encY occupies among these lane columns". The same +-- column collapses to a single lane (raincloud's overlay); different +-- columns lay out side by side (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=値。 +-- | [日本語]: P21: ridge / joyplot。 ★ 他 distribution mark と統一して +-- __値 1 列__を受ける。 群分けは @<> groupBy "g"@ / @<> colorBy "g"@ (= +-- box/violin と同じ)。 群指定なしは単一 density 風。 ridge は値→x・群→y の +-- 向きが要るため、 ridge レイヤを含む spec は 'Graphics.Hgg.Spec.Setters.ridgeAutoFlip' で coord_flip +-- を自動適用する (値が x、 群が y に回る)。 内部表現は violin と同じ encY=値。 +-- [English]: P21: ridge / joyplot. Unified with the other distribution +-- marks, it takes a __single value column__. Grouping is added via +-- @<> groupBy "g"@ / @<> colorBy "g"@ (the same as box/violin); with no +-- group specified it looks like a single density curve. Since ridge +-- needs value→x and group→y, a spec containing a ridge layer +-- automatically applies coord_flip via 'Graphics.Hgg.Spec.Setters.ridgeAutoFlip' (value becomes x, +-- group becomes y). Internally represented the same way as violin, +-- encY=value. ridge :: ColRef -> Layer ridge v = mempty { lyKind = First (Just MRidge), lyEncY = Last (Just v) } --- | P14: scatter jitter (= plotArea 比率 0..1)。 +-- | [日本語]: P14: scatter jitter (= plotArea 比率 0..1)。 +-- [English]: P14: scatter jitter (a plotArea ratio in 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)。 +-- | [日本語]: frontend-settings v0.1 §2.4: histogram の bin 数 (= default 10)。 +-- [English]: frontend-settings v0.1 §2.4: the number of histogram bins +-- (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 化を行う。 +-- | [日本語]: histogram の bin 幅 (= ggplot @geom_histogram(binwidth = w)@)。 +-- 'binWidth' を指定すると 'binCount' より優先され、 'histBinning' が ggplot +-- 流 (boundary = w/2 で bin 原点を定める) の bin 化を行う。 +-- [English]: The histogram bin width (like ggplot's +-- @geom_histogram(binwidth = w)@). Specifying 'binWidth' takes priority +-- over 'binCount', and 'histBinning' bins in the ggplot style +-- (determining the bin origin with boundary = w/2). binWidth :: Double -> Layer binWidth w = mempty { lyBinWidth = Last (Just w) } --- | histogram の bin 化パラメタ (origin, binW, nBin) を決める単一情報源。 --- render (Render.Basic) と y/x range (Layout.RangeOf) の双方がこれを使い、 --- bin 境界・棒高・軸範囲を一致させる。 +-- | [日本語]: 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)。 @@ -569,6 +934,21 @@ -- -- bin i は @[origin + i*binW, origin + (i+1)*binW)@、 値 v の所属は -- @clamp 0 (nBin-1) (floor ((v - origin)/binW))@。 +-- [English]: The single source of truth that determines the histogram +-- binning parameters (origin, binW, nBin). Both render (Render.Basic) +-- and the y/x range (Layout.RangeOf) use it, so bin boundaries, bar +-- heights and axis ranges stay consistent. +-- +-- * When 'lyBinWidth' is given: the same formula as ggplot's +-- @bin_breaks_width@. With boundary = w/2, origin = boundary + +-- floor((lo - boundary)/w) * w and nBin = ceil((hi - origin)/w). This +-- gives the same bin boundaries and bar heights as R4DS's +-- @binwidth=@. +-- * When unspecified: as before, divides [lo,hi] evenly using +-- 'lyBinCount' (default 30). +-- +-- Bin i is @[origin + i*binW, origin + (i+1)*binW)@; a value v belongs to +-- @clamp 0 (nBin-1) (floor ((v - origin)/binW))@. histBinning :: Layer -> (Double, Double) -> (Double, Double, Int) histBinning ly (lo, hi) = case getLast (lyBinWidth ly) of @@ -585,19 +965,29 @@ binW = if hi > lo then (hi - lo) / fromIntegral nBin else 1 in (lo, binW, nBin) --- | Phase 40: hexbin の六角セル (中心 + 件数 + 6 頂点、 すべてデータ座標)。 +-- | [日本語]: hexbin の六角セル (中心 + 件数 + 6 頂点、 すべてデータ座標)。 +-- [English]: A hexbin hex cell (center + count + six vertices, all in +-- data coordinates). data HexCell = HexCell - { hexCx :: !Double -- ^ セル中心 x (データ座標) - , hexCy :: !Double -- ^ セル中心 y - , hexCount :: !Int -- ^ セルに入った点数 - , hexVerts :: ![(Double, Double)] -- ^ 6 頂点 (pointy-top、 データ座標) + { hexCx :: !Double -- ^ [日本語]: セル中心 x (データ座標)。 [English]: Cell center x (data coordinates). + , hexCy :: !Double -- ^ [日本語]: セル中心 y。 [English]: Cell center y. + , hexCount :: !Int -- ^ [日本語]: セルに入った点数。 [English]: Number of points in the cell. + , hexVerts :: ![(Double, Double)] -- ^ [日本語]: 6 頂点 (pointy-top、 データ座標)。 [English]: The six vertices (pointy-top, data coordinates). } 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 一致させる。 +-- | [日本語]: 六角ビニング (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 一致させる。 +-- [English]: Hexagonal binning (d3-hexbin = Carr 1987). @bins@ is the +-- number of x-direction cell divisions; (xmin,xmax)/(ymin,ymax) is the +-- data range and @pts@ is the list of (x,y) points. Points are assigned +-- to hex cells in (u,v) space normalized by binwidth, counted, and +-- returned with center + six vertices in data coordinates (fed straight +-- into the scale pipeline to reach screen space; pointy-top). HS and PS +-- use the identical formula and JS Math.round (= @floor (z+0.5)@) to +-- match byte-for-byte. hexbinCells :: Int -> (Double, Double) -> (Double, Double) -> [(Double, Double)] -> [HexCell] hexbinCells bins (xmin, xmax) (ymin, ymax) pts @@ -644,9 +1034,15 @@ 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 本に集約する。 +-- | [日本語]: hexbin layer を解決して六角セルを返す (renderHexbin と count +-- colorbar が共有)。 x/y を 'resolveNum' で取り NaN を除いて zip、 bins (既定 +-- 30) で 'hexbinCells'。 render と凡例で__同じ count 域__を得るために 1 本に +-- 集約する。 +-- [English]: Resolves a hexbin layer and returns its hex cells (shared +-- by renderHexbin and the count colorbar). Takes x/y via 'resolveNum', +-- drops NaN, zips them, and calls 'hexbinCells' with bins (default 30). +-- Consolidated into a single function so render and the legend see the +-- __same count domain__. hexbinLayerCells :: Resolver -> Layer -> [HexCell] hexbinLayerCells r ly = case (getLast (lyEncX ly), getLast (lyEncY ly)) of @@ -662,150 +1058,241 @@ _ -> [] _ -> [] --- | TODO-3a (2026-05-29): histogram の y 軸を密度 (= count / (total * binW)) --- に正規化。 PS Spec.histogramDensity と同等。 SVG export でも動くように HS --- 側にも実装 (= 旧来 HS は count のみで density mode が機能しなかった)。 +-- | [日本語]: TODO-3a (2026-05-29): histogram の y 軸を密度 +-- (= count / (total * binW)) に正規化。 PS Spec.histogramDensity と同等。 +-- SVG export でも動くように HS 側にも実装 (= 旧来 HS は count のみで density +-- mode が機能しなかった)。 +-- [English]: TODO-3a (2026-05-29): normalizes the histogram's y axis to +-- density (count / (total * binW)). Equivalent to PS's +-- Spec.histogramDensity. Also implemented on the HS side so it works for +-- SVG export too (previously HS only supported count, so density mode +-- didn't work). histogramDensity :: Bool -> Layer histogramDensity b = mempty { lyHistDensity = Last (Just b) } --- | Phase 8 B7: histogram / bar の bin 境界線 (= 各バーの白枠) を表示するか。 --- デフォルトは False (= ggplot 流フラットバー、 枠なし)。 True で bin 区切りが見える。 +-- | [日本語]: histogram / bar の bin 境界線 (= 各バーの白枠) を表示するか。 +-- デフォルトは False (= ggplot 流フラットバー、 枠なし)。 True で bin 区切りが +-- 見える。 +-- [English]: Whether to show the bin border lines (a white outline per +-- bar) for histogram / bar. Default False (a flat ggplot-style bar with +-- no border); True makes the bin boundaries visible. 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 = 線のみ。 +-- | [日本語]: density 曲線の下を塗りつぶす (= ggplot +-- @geom_density(aes(fill = …))@)。 群別 ('color') と 'alpha' を併用すると、 +-- 各群を群色 × alpha で塗る (R4DS Ch1 §1.5)。 既定 (未指定/False) は ggplot +-- 同様 fill=NA = 線のみ。 +-- [English]: Fills below the density curve (like ggplot's +-- @geom_density(aes(fill = …))@). Combined with per-group color +-- ('color') and 'alpha', each group is filled with its group color × +-- alpha (R4DS Ch1 §1.5). The default (unspecified/False) is fill=NA as +-- in ggplot — line only. 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)。 +-- | [日本語]: マーカーを中抜き (= ggplot @shape="circle open"@ / +-- @geom_point(fill = NA)@)。 塗りを透明にし、 点色で輪郭 (stroke) のみ描く。 +-- 'size' で輪郭円の直径、 'stroke' で線幅 (既定 1pt)。 重畳して「点を輪で +-- 囲む」 強調に使う (R4DS Ch9 §9.6)。 +-- [English]: Makes markers hollow (like ggplot's +-- @shape="circle open"@ / @geom_point(fill = NA)@). Fill is made +-- transparent, drawing only the outline (stroke) in the point color. +-- 'size' controls the outline circle's diameter, 'stroke' its line +-- width (default 1pt). Used as an overlay to emphasize points by +-- "circling" them (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 を置換)。 +-- | [日本語]: 分布 mark (box/violin/strip/swarm) の slot 内横 offset。 値は +-- __slot 幅比__ (= ggplot @position_nudge@)。 正で右、 負で左。 raincloud の +-- 「box を中央・strip を左・雲を右」のような重畳配置を組むのに使う (= 旧 +-- raincloud のハードコード offset を置換)。 +-- [English]: The horizontal offset within a slot for distribution marks +-- (box/violin/strip/swarm). The value is a __ratio of the slot width__ +-- (like ggplot's @position_nudge@); positive moves right, negative +-- moves left. Used to build raincloud-style overlaid layouts such as +-- "box centered, strip to the left, cloud to the right" (replacing the +-- old hardcoded offsets in raincloud). 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 等) するのに使う。 +-- | [日本語]: 分布 mark の幅 (= __slot 幅比・占有率__)。 各 mark の既定占有率 +-- (box 0.5 / violin 0.7 / strip 0.4 / swarm 0.8) を上書きする。 raincloud +-- では box を細く (= 0.1 等) するのに使う。 +-- [English]: The width of a distribution mark (a __ratio of the slot width — its occupancy__). +-- Overrides each mark's default occupancy +-- (box 0.5 / violin 0.7 / strip 0.4 / swarm 0.8). Used in raincloud to +-- thin the box (e.g. to 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 等には影響しない。 +-- | [日本語]: violin の片側化 (= 半 violin)。 @violin "v" <> side SideRight@ で +-- 右半分のみ。 raincloud の「雲」 (= 片側 violin) に使う。 box/strip 等には +-- 影響しない。 +-- [English]: Makes a violin one-sided (a half violin). Example: +-- @violin "v" <> side SideRight@ shows only the right half. Used for +-- raincloud's "cloud" (a one-sided violin); has no effect on box/strip, +-- etc. side :: Side -> Layer side s = mempty { lySide = Last (Just s) } --- | Phase 9 B: bar の position adjustment (= ggplot `position`)。 --- 群分け (= color/group aesthetic) があるとき 'PosDodge' / 'PosStack' / 'PosFill' で +-- | [日本語]: bar の position adjustment (= ggplot `position`)。 群分け (= +-- color/group aesthetic) があるとき 'PosDodge' / 'PosStack' / 'PosFill' で -- 並べ方を選ぶ。 既定 ('PosIdentity') は従来通り単色棒 (color を見ない)。 +-- [English]: The position adjustment for bar (like ggplot's `position`). +-- When there is grouping (a color/group aesthetic), choose the layout +-- with 'PosDodge' / 'PosStack' / 'PosFill'. The default ('PosIdentity') +-- draws a single-color bar as before (ignoring 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 (= layer 全体に適用・ggplot @shape=@)。 bare=固定。 +-- 'shapeBy' (列で map) より優先される ('Graphics.Hgg.Render.Common.pointShapeAt' 参照)。 +-- [English]: A fixed shape (applies to the whole layer; like ggplot's +-- @shape=@). A bare value is fixed and takes priority over 'shapeBy' +-- (which maps from a column) — see 'Graphics.Hgg.Render.Common.pointShapeAt'. shape :: MarkShape -> Layer shape s = mempty { lyShape = Last (Just s) } --- | C-6: shape categorical encoding 列。 +-- | [日本語]: C-6: shape categorical encoding 列。 +-- [English]: C-6: the shape categorical-encoding column. shapeBy :: ColRef -> Layer shapeBy c = mempty { lyShapeBy = Last (Just c) } --- | C-6: cat 名 → MarkShape 1 件追加 (= 複数 entry は <> で合成)。 +-- | [日本語]: C-6: cat 名 → MarkShape 1 件追加 (= 複数 entry は <> で合成)。 +-- [English]: C-6: adds a single cat name → MarkShape entry (combine +-- multiple entries with <>). shapeMapEntry :: Text -> MarkShape -> Layer shapeMapEntry v s = mempty { lyShapeMap = [ ShapeMapEntry { smeValue = v, smeShape = s } ] } --- | C-6: size continuous encoding 列。 +-- | [日本語]: C-6: size continuous encoding 列。 +-- [English]: C-6: the size continuous-encoding column. 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)。 +-- | [日本語]: 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)。 +-- [English]: Encodes alpha (opacity) from a continuous-valued column +-- (like ggplot's @scale_alpha@ / @aes(alpha = col)@). Linearly maps the +-- column's min..max to alpha @[0.1, 1.0]@ (ggplot's default range). A +-- fixed alpha uses the bare 'alpha' (convention: bare = fixed, `*By` = +-- mapped). -- -- > 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 に適用。 +-- | [日本語]: 固定 linetype (= ggplot linetype="dashed")。 line 系 mark に適用。 -- 例: @line "x" "y" <> linetype LtDashed@ +-- [English]: A fixed linetype (like ggplot's linetype="dashed"), applied +-- to line-family marks. Example: @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))。 +-- | [日本語]: categorical linetype encoding 列 (= ggplot linetype=factor(g))。 -- line を群ごとに分割し各群へ巡回 LineType ('lineTypeForIndex') を割当。 -- 例: @line "x" "y" <> linetypeBy (ColByName "grp")@ +-- [English]: A categorical linetype-encoding column (like ggplot's +-- linetype=factor(g)). Splits the line by group and assigns each group +-- a cycled LineType ('lineTypeForIndex'). Example: +-- @line "x" "y" <> linetypeBy (ColByName "grp")@ linetypeBy :: ColRef -> Layer linetypeBy c = mempty { lyLinetypeBy = Last (Just c) } --- | C-step trellis 色一貫性: 全データ cat 出現順を Layer に注入。 +-- | [日本語]: C-step trellis 色一貫性: 全データ cat 出現順を Layer に注入。 +-- [English]: C-step trellis color consistency: injects the full +-- dataset's category order into the Layer. colorCats :: [Text] -> Layer colorCats cs = mempty { lyColorCats = cs } --- | Phase 28: categorical 水準の既定順 (= ggplot2 の factor 既定 = アルファベット順)。 --- 色 / x 軸 / shape の distinct を取るときに使い、 R4DS と凡例・色・並びを一致させる。 --- 明示順が要るとき (fct_infreq 等) は 'colorCats' / 'xCatOrder' で上書きする。 +-- | [日本語]: categorical 水準の既定順 (= ggplot2 の factor 既定 = アルファベット +-- 順)。 色 / x 軸 / shape の distinct を取るときに使い、 R4DS と凡例・色・並びを +-- 一致させる。 明示順が要るとき (fct_infreq 等) は 'colorCats' / @xCatOrder@ で +-- 上書きする。 +-- [English]: The default order of categorical levels (matching +-- ggplot2's factor default — alphabetical). Used when taking distinct +-- values for color / x axis / shape, to keep legend, color and ordering +-- consistent with R4DS. When an explicit order is needed (e.g. +-- fct_infreq), override it with 'colorCats' / @xCatOrder@. orderedCats :: [Text] -> [Text] orderedCats = Data.List.sort . Data.List.nub --- | Phase 26 §C-2 #8: 列の平均値を水平線として描画 (= PlotConfig.showMean)。 +-- | [日本語]: 列の平均値を水平線として描画 (= PlotConfig.showMean)。 +-- [English]: Draws the column's mean as a horizontal line +-- (PlotConfig.showMean). statMean :: ColRef -> Layer statMean c = mempty { lyKind = First (Just MStatMean), lyEncY = Last (Just c) } --- | Phase 26 §C-2 #8: 列の中央値を水平線として描画 (= PlotConfig.showMedian)。 +-- | [日本語]: 列の中央値を水平線として描画 (= PlotConfig.showMedian)。 +-- [English]: Draws the column's median as a horizontal line +-- (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 強調 (= 後追い)。 +-- | [日本語]: parallel coordinates plot。 各 col が縦軸となり、 各 row を全軸 +-- cross する折線で表現。 hover で row 強調 (= 後追い)。 +-- [English]: A parallel-coordinates plot. Each col becomes a vertical +-- axis, and each row is drawn as a polyline crossing all axes. Row +-- highlighting on hover is a follow-up feature. 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 + ~> 経由) を使う方が良い。 +-- | [日本語]: HBM ModelGraph DAG を描画する layer。 内部 builder で使う直接 +-- constructor。 ユーザは 'Graphics.Hgg.DAG.dagPlot' (= Graph a + ~> 経由) を +-- 使う方が良い。 +-- [English]: A layer that draws an HBM ModelGraph DAG. A direct +-- constructor used by the internal builder. Users are better off using +-- 'Graphics.Hgg.DAG.dagPlot' (via Graph a + ~>). dagFromLists :: [DAGNode] -> [DAGEdge] -> DAGLayoutAlgorithm -> Layer dagFromLists nodes edges algo = mempty { lyKind = First (Just MDAG) , lyDAG = Last (Just (DAGSpec nodes edges algo [])) } --- | dsPlates も指定する版。 +-- | [日本語]: dsPlates も指定する版。 +-- [English]: The variant that also specifies 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 constructor (= kind + 分布名なし)。 +-- [English]: A DAGNode constructor (kind, with no distribution name). 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" 表示用)。 +-- | [日本語]: 分布名付き DAGNode constructor (= PyMC 風 "name ~ dist" 表示用)。 +-- [English]: A DAGNode constructor with a distribution name (for a +-- PyMC-style "name ~ dist" display). 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 constructor。 +-- [English]: A DAGEdge constructor. dagEdge :: Text -> Text -> DAGEdge dagEdge f t = DAGEdge f t Nothing Nothing --- | 互換用 shortcut: 既存 demo / test 用 (= NodeLatent + LayoutManual)。 --- 新規 API は Graphics.Hgg.DAG.dagPlot を使う。 +-- | [日本語]: 互換用 shortcut: 既存 demo / test 用 (= NodeLatent + +-- LayoutManual)。 新規 API は Graphics.Hgg.DAG.dagPlot を使う。 +-- [English]: A compatibility shortcut for existing demos / tests +-- (NodeLatent + LayoutManual). New code should use +-- 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 で区別可能)。 +-- | [日本語]: MCMC trace plot (single chain)。 iteration vs parameter 値の +-- line。 mark kind は MTrace (= alias for MLine、 frontend で区別可能)。 +-- [English]: An MCMC trace plot (single chain): a line of iteration vs. +-- parameter value. Its mark kind is MTrace (an alias for MLine, +-- distinguishable by the frontend). trace :: ColRef -> ColRef -> Layer trace iterCol valCol = mempty { lyKind = First (Just MTrace) @@ -813,12 +1300,15 @@ , lyEncY = Last (Just valCol) } --- | Phase 26 §E-1: multi-chain trace。 chain 列で色分け、 connect group も --- chain 列 (= chain 内で連結、 chain 跨ぎ無し)。 PlotConfig.StreamingTracePlot 等価。 +-- | [日本語]: multi-chain trace。 chain 列で色分け、 connect group も chain 列 +-- (= chain 内で連結、 chain 跨ぎ無し)。 PlotConfig.StreamingTracePlot 等価。 +-- [English]: A multi-chain trace. Colored by the chain column; the +-- connect group is also the chain column (connected within a chain, no +-- crossing between chains). Equivalent to +-- 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 --- a/src/Graphics/Hgg/Spec/CustomMark.hs +++ b/src/Graphics/Hgg/Spec/CustomMark.hs @@ -1,15 +1,24 @@ -- | -- Module : Graphics.Hgg.Spec.CustomMark --- Description : custom mark の payload 型 (RenderCtx / CustomMark、 Phase 51) +-- Description : Payload types for custom marks (RenderCtx / CustomMark) -- 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 形含む) は完全に不変。 +-- [日本語]: 'Graphics.Hgg.Spec' の module 分割で切り出した leaf。 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 形含む) は完全に不変。 +-- +-- [English]: A leaf split out of 'Graphics.Hgg.Spec' during its module +-- split. Carries only the __types__ ('RenderCtx' / 'CustomMark') for the +-- custom-mark extension point (the smart constructor @customMark@ and +-- friends live in 'Graphics.Hgg.Spec.Constructors'). Depends only on +-- 'Graphics.Hgg.Spec.Column' ('Resolver') and 'Graphics.Hgg.Primitive'. The +-- public API is still re-exported by the 'Graphics.Hgg.Spec' facade as +-- before; behavior and output (including the JSON shape) are completely +-- unchanged. {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Spec.CustomMark ( RenderCtx(..) @@ -28,32 +37,60 @@ -- 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。 +-- | [日本語]: custom mark の draw closure に渡す描画文脈。 backend 非依存。 +-- scale 適用済の projection・plot 領域 (px)・データ resolver・theme 既定色を +-- 提供する。 これと ("Graphics.Hgg.Render" が re-export する) 'Primitive' +-- 構築子が custom mark の authoring API。 +-- [English]: The drawing context passed to a custom mark's draw closure. +-- Backend-agnostic. Supplies the scale-applied projection, the plot area +-- (px), the data resolver, and the theme's default colors. Together with +-- the 'Primitive' constructors (re-exported by "Graphics.Hgg.Render"), +-- this forms the 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 既定の軸色 + { rcProjectXY :: !(Double -> Double -> (Double, Double)) -- ^ [日本語]: データ座標 (x,y) → device px + -- [English]: Converts data coordinates (x,y) to device px. + , rcPlotArea :: !Rect -- ^ [日本語]: plot 描画領域 (px) + -- [English]: The plot drawing area (px). + , rcResolver :: !Resolver -- ^ [日本語]: 列名 → データ (layer 束縛列を引く) + -- [English]: Column name to data (looks up columns bound by the layer). + , rcColor :: !Text -- ^ [日本語]: theme 既定の線/点色 + -- [English]: The theme's default line/point color. + , rcFill :: !Text -- ^ [日本語]: theme 既定の塗り色 + -- [English]: The theme's default fill color. + , rcTextColor :: !Text -- ^ [日本語]: theme 既定の文字色 + -- [English]: The theme's default text color. + , rcAxisColor :: !Text -- ^ [日本語]: theme 既定の軸色 + -- [English]: The theme's default axis color. } --- | custom mark の payload。 'lyCustom' に載る。 +-- | [日本語]: custom mark の payload。 @lyCustom@ に載る。 -- --- * 'cmDraw' は HS の描画 closure。 データは closure に閉じ込め可。 __serialize 不能__ --- ゆえ JSON では落ち、 decode 時は no-op (@const []@) に戻る。 PS は 'cmId' で自前 --- registry を引いて描く (parity 手登録)。 --- * 'cmOptions' は PS へ渡す必要のある serializable option (任意)。 +-- * 'cmDraw' は HS の描画 closure。 データは closure に閉じ込め可。 +-- __serialize 不能__ ゆえ JSON では落ち、 decode 時は no-op (@const []@) +-- に戻る。 PS は 'cmId' で自前 registry を引いて描く (parity 手登録)。 +-- * 'cmOptions' は PS へ渡す必要のある serializable option (任意)。 -- --- 'Eq' / 'Show' は closure を無視し 'cmId' + 'cmOptions' で比較 (function は比較不能ゆえ)。 +-- 'Eq' / 'Show' は closure を無視し 'cmId' + 'cmOptions' で比較 (function は +-- 比較不能ゆえ)。 +-- [English]: The payload of a custom mark, carried in @lyCustom@. +-- +-- * 'cmDraw' is the Haskell draw closure. Data may be captured inside +-- the closure, so it is __not serializable__: it is dropped from +-- JSON, and decoding restores a no-op (@const []@). PS draws by +-- looking up its own registry via 'cmId' (manually registered for +-- parity). +-- * 'cmOptions' is the serializable option (optional) that needs to be +-- passed to PS. +-- +-- 'Eq' / 'Show' ignore the closure and compare by 'cmId' + 'cmOptions' +-- (since functions cannot be compared). data CustomMark = CustomMark - { cmId :: !Text -- ^ 安定 mark 識別子 (PS dispatch の鍵・serialize される) - , cmOptions :: !Value -- ^ PS へ渡す option (JSON・任意) - , cmDraw :: !(RenderCtx -> [Primitive]) -- ^ HS 描画 closure (JSON 非対象) + { cmId :: !Text -- ^ [日本語]: 安定 mark 識別子 (PS dispatch の鍵・serialize される) + -- [English]: The stable mark identifier (the key for PS dispatch; serialized). + , cmOptions :: !Value -- ^ [日本語]: PS へ渡す option (JSON・任意) + -- [English]: The option passed to PS (JSON, optional). + , cmDraw :: !(RenderCtx -> [Primitive]) -- ^ [日本語]: HS 描画 closure (JSON 非対象) + -- [English]: The Haskell draw closure (not part of the JSON). } instance Show CustomMark where diff --git a/src/Graphics/Hgg/Spec/Decoration.hs b/src/Graphics/Hgg/Spec/Decoration.hs --- a/src/Graphics/Hgg/Spec/Decoration.hs +++ b/src/Graphics/Hgg/Spec/Decoration.hs @@ -1,14 +1,21 @@ -- | -- Module : Graphics.Hgg.Spec.Decoration --- Description : 図の装飾 spec (ReferenceLine / Annotation / Marginal / Legend / Font) +-- Description : Decoration specs — reference lines, annotations, marginals, legends, fonts -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 図に載せる装飾の +-- [日本語]: @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 する。 挙動・出力は完全に不変。 +-- 'LegendSpec' / 'FontSpec') を持つ。 ※@Inset@ は @VisualSpec@ と相互参照の +-- ため @Graphics.Hgg.Spec.Visual@ 側。 公開 API は従来どおり +-- @Graphics.Hgg.Spec@ (facade) が re-export する。 挙動・出力は完全に不変。 +-- [English]: Split out from @Graphics.Hgg.Spec@ via module decomposition. +-- Holds the declarative spec types for decorations placed on a figure +-- ('ReferenceLine' / 'Annotation' / 'MarginalSpec' / 'LegendSpec' / +-- 'FontSpec'). Note: @Inset@ instead lives alongside @VisualSpec@ in +-- @Graphics.Hgg.Spec.Visual@, since the two cross-reference each other. +-- The public API is unchanged — @Graphics.Hgg.Spec@ (the facade) still +-- re-exports everything, and behavior/output are fully preserved. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} @@ -38,14 +45,19 @@ import Graphics.Hgg.Unit (Pos (..)) -- =========================================================================== --- ReferenceLine (= Phase 26 §C-2 #3: 既存 PlotConfig.referenceLine 等価) +-- ReferenceLine (= 既存 PlotConfig.referenceLine 等価) -- =========================================================================== --- | plot area 内に重ねる参照線。 +-- | [日本語]: plot area 内に重ねる参照線。 -- * 'RefIdentity' ─ y = x の対角線 (= Actual vs Predicted) --- * 'RefHorizontalAt c' ─ y = c --- * 'RefVerticalAt c' ─ x = c --- * 'RefLinear slope intercept' ─ y = slope * x + intercept +-- * @RefHorizontalAt c@ ─ y = c +-- * @RefVerticalAt c@ ─ x = c +-- * @RefLinear slope intercept@ ─ y = slope * x + intercept +-- [English]: A reference line overlaid on the plot area. +-- * 'RefIdentity' — the y = x diagonal (Actual vs Predicted) +-- * @RefHorizontalAt c@ — y = c +-- * @RefVerticalAt c@ — x = c +-- * @RefLinear slope intercept@ — y = slope * x + intercept data ReferenceLine = RefIdentity | RefHorizontalAt !Double @@ -57,10 +69,10 @@ instance FromJSON ReferenceLine -- =========================================================================== --- Annotation (= P6、 2026-05-25 任意 overlay) +-- Annotation (= 2026-05-25 任意 overlay) -- =========================================================================== --- ★ Phase 33 B6: 注釈の座標は 'Pos' (native/npc/絶対長を軸ごとに混在指定可)。 +-- ★ 注釈の座標は 'Pos' (native/npc/絶対長を軸ごとに混在指定可)。 -- 旧 'AnnotCoord' (Data/Frac) は Pos に統一して撤去 (Frac は HS 描画で未実装だった)。 -- AnnRect は w/h でなく 2 隅 (x1,y1)-(x2,y2) の Pos で表す (座標一貫)。 data Annotation @@ -87,28 +99,30 @@ instance FromJSON Annotation -- =========================================================================== --- MarginalSpec (= Phase 26 §C-2 #10 周辺 histogram) +-- MarginalSpec (= 周辺 histogram) -- =========================================================================== --- | P9: marginal の種別 (hist / density / 重ね)。 +-- | [日本語]: marginal の種別 (hist / density / 重ね)。 +-- [English]: The kind of marginal panel (histogram / density / overlaid). data MarginalKind = MarginalHist | MarginalDensity | MarginalBoth deriving (Show, Eq, Generic) instance ToJSON MarginalKind instance FromJSON MarginalKind --- | scatter の周辺に X/Y histogram を sub-plot として配置するか。 +-- | [日本語]: scatter の周辺に X/Y histogram を sub-plot として配置するか。 +-- [English]: Whether to place X/Y histograms as sub-plots around the scatter. data MarginalSpec = MarginalSpec { msShowX :: !Bool , msShowY :: !Bool , msBins :: !Int -- bin 数 (= default 20) - , msKind :: !MarginalKind -- ★ P9 hist / density / 重ね + , msKind :: !MarginalKind -- ★ hist / density / 重ね } deriving (Show, Eq, Generic) instance ToJSON MarginalSpec instance FromJSON MarginalSpec --- ★ Phase 43 A3: レコードフィールド形式 (位置依存撲滅・挙動不変)。全 field が非 Monoid +-- ★ レコードフィールド形式 (位置依存撲滅・挙動不変)。全 field が非 Monoid -- (Bool/Int/enum) なので合成は名前付きで明示: show は OR・bins は max・kind は後勝ち。 instance Semigroup MarginalSpec where a <> b = MarginalSpec @@ -125,14 +139,14 @@ defaultMarginalSpec = MarginalSpec False False 20 MarginalHist -- =========================================================================== --- LegendSpec (= P8、 2026-05-25 凡例設定) +-- LegendSpec (= 2026-05-25 凡例設定) -- =========================================================================== data LegendPosition = LegendRight | LegendBottom | LegendNone | LegendInsideTopRight | LegendInsideTopLeft | LegendInsideBottomRight | LegendInsideBottomLeft - -- ★ Phase 32 (re-apply): 外・右に置きつつ panel 高の縦中央に揃える (ggplot 既定の + -- ★ 外・右に置きつつ panel 高の縦中央に揃える (ggplot 既定の -- legend.position="right" は縦中央寄せ)。 LegendRight=上揃えは不変・これは opt-in。 | LegendRightCenter deriving (Show, Eq, Generic) @@ -148,7 +162,7 @@ instance ToJSON LegendSpec instance FromJSON LegendSpec --- ★ Phase 43 A3: レコードフィールド形式 (位置依存撲滅・挙動不変)。lgPosition は非 Monoid +-- ★ レコードフィールド形式 (位置依存撲滅・挙動不変)。lgPosition は非 Monoid -- enum なので後勝ち、 lgTitle は素直な `Last` 合成。 instance Semigroup LegendSpec where a <> b = LegendSpec @@ -160,7 +174,7 @@ mempty = defaultLegendSpec defaultLegendSpec :: LegendSpec -defaultLegendSpec = LegendSpec LegendRightCenter mempty -- Phase 43: ggplot 既定 (右・縦中央) +defaultLegendSpec = LegendSpec LegendRightCenter mempty -- ggplot 既定 (右・縦中央) -- =========================================================================== -- FontSpec (= hgg-frontend-settings-spec v0.1 §1.3) @@ -170,17 +184,19 @@ { fsFamily :: !(Last Text) , fsSize :: !(Last Double) , fsWeight :: !(Last Text) - , fsItalic :: !(Last Bool) -- ★ TODO-10 (2026-05-29): PS parity + , fsItalic :: !(Last Bool) -- ★ PS parity , fsColor :: !(Last Text) } deriving stock (Show, Eq, Generic) - -- ★ Phase 43 A3: 全 field が `Last` の素直な per-field 合成なので generic 導出 + -- ★ 全 field が `Last` の素直な per-field 合成なので generic 導出 -- (= 手書き instance ゼロ・field 追加に強い)。挙動は旧手書きと完全同型。 deriving (Semigroup, Monoid) via Generically FontSpec instance ToJSON FontSpec instance FromJSON FontSpec --- | 空 'FontSpec' (= 'mempty' alias、 generic 導出の mempty と同値)。 +-- | [日本語]: 空 'FontSpec' (= 'mempty' alias、 generic 導出の mempty と同値)。 +-- [English]: The empty 'FontSpec' (an alias for 'mempty', identical to the +-- value produced by the generic derivation). emptyFontSpec :: FontSpec emptyFontSpec = mempty diff --git a/src/Graphics/Hgg/Spec/Layer.hs b/src/Graphics/Hgg/Spec/Layer.hs --- a/src/Graphics/Hgg/Spec/Layer.hs +++ b/src/Graphics/Hgg/Spec/Layer.hs @@ -1,16 +1,26 @@ -- | -- Module : Graphics.Hgg.Spec.Layer --- Description : Layer (内側 Monoid) 本体 + layer-local attribute setter +-- Description : Layer (inner Monoid) record and layer-local attribute setters -- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) -- License : BSD-3-Clause -- --- Phase 55: 'Graphics.Hgg.Spec' の module 分割で切り出し。 1 layer の全 field を +-- [日本語]: '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 形含む) は -- 完全に不変。 +-- +-- [English]: Split out from 'Graphics.Hgg.Spec' during a module split. Holds +-- the 'Layer' record with every field for a single layer, together with a +-- field-wise Monoid instance (only 'lyKind' uses First; the rest use Last or +-- concatenation — see @design/monoid-semantics.md@ §1), plus the layer-local +-- setters (colorBy / alpha / size / connect, and friends) that each combine +-- with @<>@ onto the preceding 'Layer'. Mark-specific constructors live in +-- 'Graphics.Hgg.Spec.Constructors'. The public API is unchanged: +-- 'Graphics.Hgg.Spec' (the facade) still re-exports everything. Behavior and +-- output (including JSON shape) are completely unchanged. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Spec.Layer @@ -58,91 +68,110 @@ -- Layer (= 内側 Monoid) -- =========================================================================== --- | 1 layer の全 field。 各 field を 'First' (= kind は最初勝ち) または --- 'Last' (= 属性は後勝ち) で包んで Monoid を field-wise に。 +-- | [日本語]: 1 layer の全 field。 各 field を 'First' (= kind は最初勝ち) または +-- 'Last' (= 属性は後勝ち) で包んで Monoid を field-wise に。 +-- [English]: All fields for a single layer. Each field is wrapped in +-- 'First' (kind, where the first value wins) or 'Last' (attributes, where +-- the last value wins) to make the Monoid instance field-wise. data Layer = Layer { lyKind :: !(First MarkKind) , lyEncX :: !(Last ColRef) , lyEncY :: !(Last ColRef) + , lyEncZ :: !(Last ColRef) -- ★ Phase 64 A11: 三角座標 (ternary) の第 3 成分列。 CoordTernary 時のみ意味を持つ , 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 軸か + , lyHover :: ![ColRef] -- ★ multi-col tooltip + , lyConnect :: !(Last ConnectSpec) -- ★ connect points + , lyErrorX :: !(Last ColRef) -- ★ ± 半幅 X + , lyErrorY :: !(Last ColRef) -- ★ ± 半幅 Y + , lyEncY2 :: !(Last ColRef) -- ★ MBand 用 upper y + , lyDAG :: !(Last DAGSpec) -- ★ HBM ModelGraph + , lyJitterX :: !(Last Double) -- ★ jitter X (plotArea 比率) + , lyJitterY :: !(Last Double) -- ★ jitter Y + , lyYAxisSide :: !(Last YAxisSide) -- ★ どちら 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 より優先) + , lyBinWidth :: !(Last Double) -- ★ histogram の bin 幅 (= ggplot binwidth)。 binCount より優先 + , lyShape :: !(Last MarkShape) -- ★ 固定 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 列 + , lyAlphaBy :: !(Last ColRef) -- ★ 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 + , lyHistDensity :: !(Last Bool) -- ★ histogram を density 正規化 + , lyHistBorder :: !(Last Bool) -- ★ histogram/bar の bin 境界線 (= default False) + , lyDensityFill :: !(Last Bool) -- ★ density 曲線下を塗る (= ggplot geom_density(aes(fill=)))。 alpha と併用 + , lyHollow :: !(Last Bool) -- ★ 中抜きマーカー (= ggplot shape="circle open"/fill=NA)。 塗り透明 + 点色 stroke + , lyNudge :: !(Last Double) -- ★ 分布 mark の slot 内横 offset (slot 幅比、 ggplot position_nudge 相当) + , lyMarkWidth :: !(Last Double) -- ★ 分布 mark の幅 (slot 幅比・占有率)。 各 mark の既定占有率を上書き + , lySide :: !(Last Side) -- ★ violin の片側化 (= 半 violin)。 既定 Both + , lyMaxLag :: !(Last Int) -- ★ autocorr max lag (= default 40) + , lyChain :: !(Last ColRef) -- ★ chain group 列 (ESS / trace で chain 分け) + , lyDensityNorm :: !(Last Bool) -- ★ pairs 対角用。 y 軸 = 値範囲、 KDE は panel 高さに独立正規化 + , lyPosition :: !(Last Position) -- ★ bar position adjustment (dodge/stack/fill、 既定 identity) + , lyLinetype :: !(Last LineType) -- ★ A4-b: 固定 linetype (= ggplot linetype=) + , lyLinetypeBy :: !(Last ColRef) -- ★ A4-b: categorical linetype scale 列 + , lyLabel :: !(Last ColRef) -- ★ geom_text/label のラベル列 (各点の文字) + , lyStatLevel :: !(Last Double) -- ★ stat 回帰の信頼水準 (= 既定 0.95)。 MStat* 解決時のみ意味を持つ + , lyContourLevels :: !(Last Int) -- ★ 等高線の本数 (既定 8)。 MContour/MContourFilled 用 + , lyContourBreaks :: !(Last [Double]) -- ★ 等高線レベルの明示指定 (本数指定より優先) + , lyEncU :: !(Last ColRef) -- ★ vector field (quiver) の u 成分列 + , lyEncV :: !(Last ColRef) -- ★ vector field (quiver) の v 成分列 + , lyArrowScale :: !(Last Double) -- ★ quiver 矢印長の倍率 (autoscale × この値・既定 1) + , lyArrowMagnitude :: !(Last Bool) -- ★ quiver を magnitude (|u,v|) で連続色マップ (既定 False) + , lyEdge :: !(Last Bool) -- ★ 散布点の縁を描くか (既定 False = 縁なし、 ggplot 塗り点 shape 19 相当) + , lyEdgeColor :: !(Last Text) -- ★ 縁の色 (未指定なら点と同色) + , lyEdgeWidth :: !(Last Double) -- ★ 縁の幅 px (既定 1.0) + , lyOverlay :: ![Layer] -- ★ 同一 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) + , lyCustom :: !(Last CustomMark) -- ★ custom mark payload (MCustom 用・id/options/draw closure) } deriving (Generic, Show, Eq) instance ToJSON Layer --- ★ Phase 36 D2: lyOverlay は後付けフィールドゆえ、 旧 JSON (= gallery specs/**.json 等) に +-- ★ 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 に無くても + -- ★ 後付けフィールド (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) + -- ★ Phase 64 A11: lyEncZ も後付けゆえ旧 JSON (gallery specs 等) に無い。 + o3 = if KM.member "lyEncZ" o2 then o2 + else KM.insert "lyEncZ" Aeson.Null o2 + in Aeson.genericParseJSON Aeson.defaultOptions (Object o3) _ -> 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。 +-- | [日本語]: 1 layer 内の属性合成。 'lyKind' のみ 'First' (= 最初の mark が勝ち、 後続の +-- mark は消える点に注意 ─ 重畳は @layer@ で包んで合成する。 @design/monoid-semantics.md@ +-- §1 参照)。 lyHover/lyShapeMap は concat、 lyColorCats は last-nonempty、 残りは 'Last'。 +-- field 数が多く positional 列挙は取り違えやすいので record 構文で +-- per-field '(<>)' する (= Layer3D が同方針で行った変更)。 挙動は +-- 旧 positional 版と同一: 'lyKind' は First (= 最初の mark 勝ち)、 'lyHover'/ +-- 'lyShapeMap' は list concat ('(<>)')、 'lyColorCats' は last-nonempty、 残りは Last。 +-- [English]: Combines attributes within a single layer. Only 'lyKind' uses +-- 'First' (the first mark wins; note that later marks are dropped — +-- overlaying multiple marks should instead go through @layer@; see +-- @design/monoid-semantics.md@ §1). lyHover/lyShapeMap concatenate, +-- lyColorCats keeps the last non-empty value, and everything else uses +-- 'Last'. With this many fields, a positional field list is easy to get +-- wrong, so this uses record syntax with a per-field '(<>)' instead (the +-- same approach taken for Layer3D). The behavior matches the old +-- positional version exactly: 'lyKind' is First (the first mark wins), +-- 'lyHover'/'lyShapeMap' use list concatenation ('(<>)'), 'lyColorCats' +-- keeps the last non-empty value, and the rest use Last. instance Semigroup Layer where a <> b = Layer { lyKind = lyKind a <> lyKind b , lyEncX = lyEncX a <> lyEncX b , lyEncY = lyEncY a <> lyEncY b + , lyEncZ = lyEncZ a <> lyEncZ b , lyColor = lyColor a <> lyColor b , lyAlpha = lyAlpha a <> lyAlpha b , lySize = lySize a <> lySize b @@ -188,13 +217,13 @@ , 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) + , lyOverlay = lyOverlay a <> lyOverlay b -- ★ sub-mark を concat + , lyCustom = lyCustom a <> lyCustom b -- ★ custom mark payload (Last) } instance Monoid Layer where mempty = Layer - { lyKind = mempty, lyEncX = mempty, lyEncY = mempty, lyColor = mempty + { lyKind = mempty, lyEncX = mempty, lyEncY = mempty, lyEncZ = 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 @@ -217,16 +246,26 @@ -- Layer-local attribute (= 直前の Layer に <>) -- =========================================================================== --- | 列で色分け encoding (= categorical / continuous は ColRef 種別による)。 --- Phase 30 案2: map 系は @*By@ 接尾辞 ('color' は固定色に明け渡し)。 +-- | [日本語]: 列で色分け encoding (= categorical / continuous は ColRef 種別による)。 +-- map 系は @*By@ 接尾辞 ('color' は固定色に明け渡し)。 +-- [English]: Column-based color encoding (categorical or continuous, +-- depending on the ColRef kind). Mapping-style aesthetics use the @*By@ +-- suffix ('color' is reserved for a fixed color). colorBy :: ColRef -> Layer colorBy c = mempty { lyColor = Last (Just (ColorByCol c)) } --- | Phase 36 B1b: distribution mark の「群分け列」。 明示の 'lyEncX' があればそれを +-- | [日本語]: distribution mark の「群分け列」。 明示の 'lyEncX' があればそれを -- 群列とし、 無ければ 'colorBy' (= 'ColorByCol') の列を群列とみなす。 これにより -- @boxplot "v" <> colorBy "g"@ が scatter と同様に群分割される (従来は encX 専用で -- colorBy 単体だと単一群になっていた)。 distribution renderer と --- 'collectCategoricalLabels' (distribution 限定) が共有する。 +-- @collectCategoricalLabels@ (distribution 限定) が共有する。 +-- [English]: The "grouping column" for a distribution mark. If 'lyEncX' is +-- set explicitly, that is the grouping column; otherwise the column behind +-- 'colorBy' (a 'ColorByCol') is treated as the grouping column. This lets +-- @boxplot "v" <> colorBy "g"@ split into groups the same way scatter does +-- (previously only encX did this, and colorBy alone produced a single +-- group). Shared by the distribution renderer and +-- @collectCategoricalLabels@ (distribution-only). distGroupRef :: Layer -> Maybe ColRef distGroupRef ly = case getLast (lyEncX ly) of Just cr -> Just cr @@ -234,11 +273,19 @@ Just (ColorByCol cr) -> Just cr _ -> Nothing --- | Phase 36 B2: distribution mark の dodge 検出。 @groupBy@ (= 'lyEncX' = 位置列) と --- @colorBy@ (= 'lyColor' の 'ColorByCol' = 色列) が **両方** 指定され、 かつ別列の +-- | [日本語]: distribution mark の dodge 検出。 @groupBy@ (= 'lyEncX' = 位置列) と +-- @colorBy@ (= 'lyColor' の 'ColorByCol' = 色列) が __両方__ 指定され、 かつ別列の -- とき @Just (位置列, 色列)@。 このとき各位置カテゴリ内で色サブグループを横並び -- (= ggplot @position_dodge@) する。 同一列 (groupBy と colorBy が同じ) のときは -- dodge せず単一群彩色のまま (= 'distGroupRef' 経路) なので 'Nothing'。 +-- [English]: Detects dodging for a distribution mark. When @groupBy@ (that +-- is, 'lyEncX', the position column) and @colorBy@ (the 'ColorByCol' inside +-- 'lyColor', the color column) are __both__ set and refer to different +-- columns, returns @Just (position column, color column)@. In that case the +-- color subgroups within each position category are laid out side by side +-- (ggplot's @position_dodge@). When the two columns are the same (groupBy +-- and colorBy match), there is no dodging — coloring stays a single group +-- (the 'distGroupRef' path), so this returns 'Nothing'. distDodgeRef :: Layer -> Maybe (ColRef, ColRef) distDodgeRef ly = case (getLast (lyEncX ly), getLast (lyColor ly)) of (Just posC, Just (ColorByCol colC)) @@ -248,43 +295,72 @@ | posC /= colC -> Just (posC, colC) _ -> Nothing --- | 静的色 (layer 全体に適用)。 Phase 30 案2: 固定色 aesthetic は bare 名 'color'。 --- 'Color' 型 (RGB / 'fromHex' / R 657 名前付き定数) を受け、 ワイヤは 'toCss' で Text 化。 +-- | [日本語]: 静的色 (layer 全体に適用)。 固定色 aesthetic は bare 名 'color'。 +-- 'Color' 型 (RGB / @fromHex@ / R 657 名前付き定数) を受け、 ワイヤは 'toCss' で Text 化。 +-- [English]: A static color (applied to the whole layer). The fixed-color +-- aesthetic uses the bare name 'color'. Takes a 'Color' value (RGB / +-- @fromHex@ / one of the 657 R named colors) and converts it to Text on the +-- wire via 'toCss'. color :: Color -> Layer color c = mempty { lyColor = Last (Just (ColorStatic (toCss c))) } --- | 便利関数: 8 桁 RGBA hex (@"#rrggbbaa"@ / 4 桁 @"#rgba"@) を 1 つで受け、 +-- | [日本語]: 便利関数: 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 無し) は不透明として扱う。 +-- [English]: A convenience function: takes an 8-digit RGBA hex +-- (@"#rrggbbaa"@, or a 4-digit @"#rgba"@) as a single value and expands it +-- into @color (fromHex …) <> alpha …@ (via 'fromHexA'). Lets you paste RGBA +-- hex values straight from design tools or the web. Since @Color@ only +-- holds RGB, the alpha is split off into a separate channel (a later +-- @<> alphaBy "col"@ etc. still wins, per 'Last'). Invalid input calls +-- 'error' (see 'colorRGBAMaybe' for the total version). 6- and 3-digit +-- forms (no alpha) are treated as fully opaque. colorRGBA :: Text -> Layer colorRGBA t = let (c, a) = fromHexA t in color c <> alpha a --- | 'colorRGBA' の total 版。 不正な hex は 'Nothing'。 +-- | [日本語]: 'colorRGBA' の total 版。 不正な hex は 'Nothing'。 +-- [English]: The total version of 'colorRGBA'. Invalid hex input yields +-- '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@ 接尾辞。 +-- | [日本語]: 連続値 column を Viridis 風 gradient で色分け。 +-- map 系ゆえ @*By@ 接尾辞。 +-- [English]: Colors by a continuous column using a Viridis-like gradient. +-- Uses the @*By@ suffix since it is a mapping-style aesthetic. colorContinuousBy :: ColRef -> Layer colorContinuousBy c = mempty { lyColor = Last (Just (ColorByContinuous c)) } --- | 透過度 (0..1)。 これは無次元なので 'Double' のまま。 +-- | [日本語]: 透過度 (0..1)。 これは無次元なので 'Double' のまま。 +-- [English]: Opacity (0..1). This is dimensionless, so it stays a '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' で指定。 +-- bare 数値リテラルは @Num Length@ 経由で __pt__ (@size 6@ = 6pt 直径)。 別単位は +-- @size (2 *~ mm)@。 内部は pt の 'Double' に解決して保持する (px は描画 dpi が +-- 確定する前なので、 例外的に 96dpi で pt 化する = マーカーに px 指定は非推奨)。 +-- [English]: Sets marker diameter ('size') / stroke width ('stroke') via a +-- 'Length'. A bare numeric literal is __pt__ via @Num Length@ (@size 6@ = +-- a 6pt diameter). Other units use @size (2 *~ mm)@. Internally this +-- resolves and stores a 'Double' in pt (since the rendering dpi is not yet +-- known, px is converted at a fixed 96dpi as an exception — specifying +-- markers in px is discouraged). 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)。 +-- | [日本語]: 散布点に縁 (edge) を付ける。 既定は縁なし (= ggplot の塗り点 shape 19)。 -- 'edgeOn' は点と同色の 1px 縁、 'edge col' は色を指定、 'edgeWidth w' は幅を指定 -- (いずれも縁を有効化)。 縁の透過は色に alpha 付き hex (例 @edge "#00000044"@) で表せる。 +-- [English]: Adds an edge (outline) to scatter points. The default is no +-- edge (ggplot's filled-point shape 19). 'edgeOn' gives a 1px edge the same +-- color as the point, 'edge col' sets the edge color, and 'edgeWidth w' +-- sets the edge width (each of these also enables the edge). Edge +-- transparency can be expressed with an alpha-bearing color hex (for +-- example @edge "#00000044"@). edgeOn :: Layer edgeOn = mempty { lyEdge = Last (Just True) } @@ -294,21 +370,25 @@ edgeWidth :: Double -> Layer edgeWidth w = mempty { lyEdge = Last (Just True), lyEdgeWidth = Last (Just w) } --- | hover tooltip に表示する追加列 (= multi-col)。 +-- | [日本語]: hover tooltip に表示する追加列 (= multi-col)。 +-- [English]: Additional columns to show in the hover tooltip (multi-column). -- -- > scatter "x" "y" <> hoverCols ["group", "label"] hoverCols :: [ColRef] -> Layer hoverCols cs = mempty { lyHover = cs } --- | Phase 26 §C-2 #6: 各点の X 方向 ± 半幅 (error bar)。 +-- | [日本語]: 各点の X 方向 ± 半幅 (error bar)。 +-- [English]: The X-direction ± half-width for each point (an error bar). errorX :: ColRef -> Layer errorX c = mempty { lyErrorX = Last (Just c) } --- | Phase 26 §C-2 #6: 各点の Y 方向 ± 半幅 (error bar)。 +-- | [日本語]: 各点の Y 方向 ± 半幅 (error bar)。 +-- [English]: The Y-direction ± half-width for each point (an error bar). errorY :: ColRef -> Layer errorY c = mempty { lyErrorY = Last (Just c) } --- | Phase 26 §C-2 #5: scatter 点を線で結ぶ ON。 +-- | [日本語]: scatter 点を線で結ぶ ON。 +-- [English]: Turns on connecting scatter points with a line. -- -- > scatter "x" "y" <> connect -- > scatter "x" "y" <> connect <> connectOrder "time" <> connectGroup "id" diff --git a/src/Graphics/Hgg/Spec/Mark.hs b/src/Graphics/Hgg/Spec/Mark.hs --- a/src/Graphics/Hgg/Spec/Mark.hs +++ b/src/Graphics/Hgg/Spec/Mark.hs @@ -1,15 +1,23 @@ -- | -- Module : Graphics.Hgg.Spec.Mark --- Description : mark 種別 (MarkKind) + DAG 型群 + layer 補助 enum (Spec の leaf) +-- Description : Mark kind (MarkKind), DAG types, and layer helper enums (a 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 含む) は完全に不変。 +-- [日本語]: '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 含む) は完全に不変。 +-- [English]: A leaf split out from the 'Graphics.Hgg.Spec' module decomposition. +-- Holds the mark-kind type 'MarkKind', the DAG rendering type family (the +-- 'DAGSpec' bundle), and layer-attribute enums ('ColorEnc' / 'Position' / +-- 'Side' / 'Coord' / the facet family / 'MarkShape' / 'LineType', etc). The +-- only dependency is 'Graphics.Hgg.Spec.Column' ('ColRef'). The public API +-- continues to be re-exported by 'Graphics.Hgg.Spec' (the facade), as +-- before. Behavior and output (including JSON tags) are completely +-- unchanged. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Spec.Mark @@ -32,6 +40,10 @@ , Position(..) , Side(..) , Coord(..) + , PolarOpts(..) + , defaultPolarOpts + , TernaryOpts(..) -- ★ Phase 69 A4 + , defaultTernaryOpts , FacetScales(..) , freeScaleX , freeScaleY @@ -46,8 +58,10 @@ , lineTypeForIndex ) where -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), + object, (.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson (typeMismatch) import qualified Data.Char as Char import Data.Monoid (Last (..)) import Data.Text (Text) @@ -59,8 +73,11 @@ -- Layer (= 内側 Monoid) -- =========================================================================== --- | 1 layer の幾何種別。 Phase 26 §A-2 で 12 種列挙、 実 render は §A-5 で --- 段階追加 (= Scatter / Line / Bar / Histogram を先行)。 +-- | [日本語]: 1 layer の幾何種別。 12 種列挙、 実 render は段階追加 +-- (= Scatter / Line / Bar / Histogram を先行)。 +-- [English]: The geometric kind of a single layer. Twelve variants are +-- enumerated; actual render support is added incrementally (Scatter / +-- Line / Bar / Histogram first). data MarkKind = MScatter | MLine | MBar | MHistogram | MBox | MHeatmap -- 統計特化 (Phase 26 §E) @@ -92,15 +109,15 @@ -- Tile (連続 x/y のセルを fill 値でベタ塗り = ggplot geom_tile/geom_raster。 1 行=1 セル・ -- 再ビニングせず格子間隔から幅自動。 決定境界の連続軸塗りが主用途。 Phase 60) | MTile - -- MCMC 診断 (P19, P20) + -- MCMC 診断 | MAutocorr | MEss - -- P11 / P12: stem / step + -- stem / step | MStep | MStem - -- P2 / P3 / P22: distribution 系 + -- distribution 系 | MViolin | MStrip | MSwarm | MRaincloud - -- P21: ridge / joyplot + -- ridge / joyplot | MRidge - -- TODO-11 (2026-05-27): area band (= 信頼区間 / 予測帯、 PPath fill 1 枚) + -- area band (= 信頼区間 / 予測帯、 PPath fill 1 枚) | MBand -- 3D placeholder (Phase 26 §C-2 #15、 実装は別 Phase で hgg-3d) | MScatter3D @@ -153,20 +170,30 @@ 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 = 四角。 +-- | [日本語]: HBM ModelGraph DAG の node 種別 (= 汎用、 HBM 慣例の +-- latent/observed/deterministic/data を含む)。 +-- 描画形状 (PyMC 慣例): NodeLatent = 白楕円、 NodeObserved = 灰楕円、 +-- NodeDeterministic = 白四角、 NodeData = 灰角丸四角、 NodeOther = 四角。 +-- [English]: The node kind for an HBM ModelGraph DAG (a general-purpose +-- kind that also covers the HBM convention of latent/observed/ +-- deterministic/data). Drawn shapes (following PyMC convention): +-- NodeLatent = white ellipse, NodeObserved = gray ellipse, +-- NodeDeterministic = white square, NodeData = gray rounded square, +-- NodeOther = square. data DAGNodeKind = NodeLatent | NodeObserved | NodeDeterministic | NodeData | NodeOther deriving (Show, Eq, Ord, Generic) instance ToJSON DAGNodeKind instance FromJSON DAGNodeKind --- | DAG layout algorithm。 +-- | [日本語]: DAG layout algorithm。 -- * 'LayoutManual' ─ dnX / dnY をそのまま使う -- * 'LayoutHierarchical' ─ topological sort + 同層 x 均等配置 --- * 'LayoutForce' ─ 将来 (= force-directed、 §C-2 後続) +-- * @LayoutForce@ ─ 将来対応予定 (= force-directed) +-- [English]: DAG layout algorithm. +-- * 'LayoutManual' ─ uses dnX / dnY as-is +-- * 'LayoutHierarchical' ─ topological sort + evenly spaced x within a layer +-- * @LayoutForce@ ─ planned for the future (force-directed) data DAGLayoutAlgorithm = LayoutManual | LayoutHierarchical deriving (Show, Eq, Generic) @@ -185,21 +212,34 @@ 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 に対応。 +-- | [日本語]: DAG edge。 'dePath' (= dummy 経由の control 点列) は +-- layout 計算後に埋まる。 JSON FromJSON はフィールド欠落時 'Nothing' default +-- (= aeson Generic 既定動作)、 旧 JSON との backward compat 維持。 +-- [English]: A DAG edge. 'dePath' (the control-point list routed via a +-- dummy node) gets filled in after layout is computed. JSON FromJSON +-- defaults to 'Nothing' when the field is missing (the default aeson +-- Generic behavior), preserving backward compatibility with older JSON. +-- | [日本語]: edge routing の形状種別 (= Render.EdgeRoute の constructor を +-- spec に焼き込むための非依存 tag)。 StraightArrow/SplinePath/BezierPath/CubicPath に対応。 +-- [English]: The shape kind for edge routing (a spec-side tag, independent +-- of the renderer, that mirrors the Render.EdgeRoute constructors). +-- Corresponds to 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 列。 +-- | [日本語]: 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 列。 +-- [English]: The routing result baked in by HS (in point space, that is, +-- post-@toScreen@ and pre-fit). HS's @routeEdge@ owns this; PS only +-- draws it and applies @fitPrimsToArea@ (option 1 / DRY). The meaning of +-- 'rePts' depends on 'reKind': Straight = [port0, port1], Spline/Bezier = +-- the control-point list, Cubic = the start point followed by cubic +-- segments of 3 points each (ctrl1, ctrl2, end). data RoutedEdge = RoutedEdge { reKind :: !EdgeShapeKind , rePts :: ![(Double, Double)] @@ -212,19 +252,31 @@ { deFrom :: !Text , deTo :: !Text , dePath :: !(Maybe [(Double, Double)]) - -- ^ Phase 1 A5: 中継 dummy 経由の制御点列 (= 始点と終点を含む 0..1 domain)。 - -- 'Nothing' なら短 edge (= 直線描画)、 'Just [..]' なら spline 描画。 + -- ^ [日本語]: 中継 dummy 経由の制御点列 (= 始点と終点を含む 0..1 domain)。 + -- 'Nothing' なら短 edge (= 直線描画)、 'Just [..]' なら spline 描画。 + -- [English]: The control-point list routed via a relay dummy node (in + -- the 0..1 domain, including the start and end points). 'Nothing' + -- means a short edge (drawn straight), 'Just [..]' means it is drawn + -- as a 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。 + -- ^ [日本語]: HS が layout 時に焼き込む pt 空間 routing (= PS と byte parity 用)。 + -- 'Nothing' なら未 bake (= HS は live routeEdge、 PS は straight fallback)。 + -- aeson Generic は欠落時 Nothing default で旧 JSON と backward compat。 + -- [English]: The point-space routing that HS bakes in at layout time + -- (used to keep byte parity with PS). 'Nothing' means it has not been + -- baked yet (HS falls back to live routeEdge, PS falls back to a + -- straight line). aeson Generic defaults to 'Nothing' when the field + -- is missing, keeping backward compatibility with older JSON. } deriving (Show, Eq, Generic) instance ToJSON DAGEdge instance FromJSON DAGEdge --- | Plate (= PyMC スタイルの "repeated" group 囲み)。 --- 含まれる node id 列を指定、 layout 時に bounding box を自動計算。 +-- | [日本語]: Plate (= PyMC スタイルの "repeated" group 囲み)。 +-- 含まれる node id 列を指定、 layout 時に bounding box を自動計算。 +-- [English]: A plate (a PyMC-style "repeated" group enclosure). Specify +-- the contained node ids; the bounding box is computed automatically at +-- layout time. data DAGPlate = DAGPlate { dpLabel :: !Text -- e.g. "course (10)" / "record (2396)" , dpNodeIds :: ![Text] @@ -243,9 +295,12 @@ instance ToJSON DAGSpec instance FromJSON DAGSpec --- | Phase 26 §C-2 #5: scatter 点を線で結ぶ設定。 --- PlotConfig.connectPoints / connectOrderColumn / connectGroupColumn / --- connectColor / connectWidth / connectBeforePoints 等価。 +-- | [日本語]: scatter 点を線で結ぶ設定。 +-- PlotConfig.connectPoints / connectOrderColumn / connectGroupColumn / +-- connectColor / connectWidth / connectBeforePoints 等価。 +-- [English]: Settings for connecting scatter points with a line. +-- Equivalent to PlotConfig.connectPoints / connectOrderColumn / +-- connectGroupColumn / connectColor / connectWidth / connectBeforePoints. data ConnectSpec = ConnectSpec { csOrder :: !(Last ColRef) -- Nothing = データ順 , csGroup :: !(Last ColRef) -- Nothing = 全点 1 本 @@ -257,7 +312,7 @@ instance ToJSON ConnectSpec instance FromJSON ConnectSpec --- ★ Phase 43 A3: レコードフィールド形式 (位置依存撲滅・挙動不変)。csBefore のみ +-- ★ レコードフィールド形式 (位置依存撲滅・挙動不変)。csBefore のみ -- Bool 左勝ち (非 Monoid) なので名前付きで温存。残りは素直な per-field `<>`。 instance Semigroup ConnectSpec where a <> b = ConnectSpec @@ -274,7 +329,9 @@ defaultConnectSpec :: ConnectSpec defaultConnectSpec = ConnectSpec mempty mempty mempty mempty False --- | 色 encoding: 列指定 (categorical) か 静的色 か 連続値 gradient。 +-- | [日本語]: 色 encoding: 列指定 (categorical) か 静的色 か 連続値 gradient。 +-- [English]: Color encoding: a column reference (categorical), a static +-- color, or a continuous-value gradient. data ColorEnc = ColorByCol !ColRef -- categorical: Okabe-Ito palette | ColorStatic !Text -- "red" / "#ff0000" @@ -284,20 +341,33 @@ instance ToJSON ColorEnc instance FromJSON ColorEnc --- | P5: layer がどちらの Y 軸に属するか。 +-- | [日本語]: layer がどちらの Y 軸に属するか。 +-- [English]: Which Y axis a layer belongs to. 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') の棒を +-- | [日本語]: 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 と一致)。 +-- [English]: Bar position adjustment (equivalent to ggplot's position_*). +-- Controls how bars for multiple series in one category (that is, the +-- color/group aesthetic, a 'ColorByCol' in @lyColor@) are arranged. +-- 'PosIdentity' (default) keeps the legacy behavior (single-color bars, +-- ignoring color). +-- * 'PosDodge' places series side by side (splitting the slot evenly +-- across series) +-- * 'PosStack' stacks series vertically (cumulative sum; the y domain +-- is the max of the group sums) +-- * 'PosFill' normalizes each stack so every category sums to 1 +-- (y domain = [0,1]) +-- JSON tag: "identity" / "dodge" / "stack" / "fill" (matches the PS Codec). data Position = PosIdentity | PosDodge | PosStack | PosFill deriving (Show, Eq, Generic) @@ -315,9 +385,13 @@ instance FromJSON Position where parseJSON = Aeson.genericParseJSON positionJsonOptions --- | Phase 36 D1: violin の片側化。 'SideBoth' (既定) = 左右対称、 'SideRight' / 'SideLeft' = +-- | [日本語]: violin の片側化。 'SideBoth' (既定) = 左右対称、 'SideRight' / 'SideLeft' = -- 半 violin (片側のみ。 raincloud の「雲」 や非対称比較で使う)。 -- JSON tag: "both" / "left" / "right" (PS Codec と一致)。 +-- [English]: Half-sidedness for a violin. 'SideBoth' (default) is +-- left-right symmetric; 'SideRight' / 'SideLeft' produce a half violin +-- (one side only, used for the raincloud "cloud" and asymmetric +-- comparisons). JSON tag: "both" / "left" / "right" (matches the PS Codec). data Side = SideBoth | SideLeft | SideRight deriving (Show, Eq, Generic) @@ -334,33 +408,150 @@ instance FromJSON Side where parseJSON = Aeson.genericParseJSON sideJsonOptions --- | Phase 9 C / 11 A7-c: 座標系 (= ggplot coord_*)。 'CoordCartesian' (既定) = 通常の +-- | [日本語]: 極座標の角度パラメータ (= ggplot @coord_polar(start=, direction=)@)。 +-- 'polarStart' = θ 軸の開始角 (rad)。 0 = 真上 (12 時)。 'polarDirection' = +-- 回転方向の符号。 +1 = 時計回り (既定)、 -1 = 反時計回り。 投影は +-- @Layout.polarPoint@ 1 箇所に閉じており、 @theta = start + dir * frac * 2π@ +-- に一般化される (grid / スポーク / θ ラベルも同じ関数を通る)。 +-- 'defaultPolarOpts' = @start=0, direction=+1@ で、 Phase 64 A8 以前の +-- 「真上始点・時計回り固定」 と完全一致する (= 既存図は不変)。 +-- [English]: The angular parameters of polar coordinates (equivalent to +-- ggplot's @coord_polar(start=, direction=)@). 'polarStart' is the starting +-- angle of the theta axis in radians (0 = straight up, 12 o'clock). +-- 'polarDirection' is the sign of the rotation direction: +1 clockwise +-- (default), -1 counter-clockwise. Projection is confined to +-- @Layout.polarPoint@ and generalized to @theta = start + dir * frac * 2π@ +-- (grid, spokes, and theta labels all go through the same function). +-- 'defaultPolarOpts' (@start=0, direction=+1@) exactly matches the previous +-- fixed "top-start, clockwise" behavior, so existing figures are unchanged. +data PolarOpts = PolarOpts + { polarStart :: !Double -- ^ 開始角 (rad)。 0 = 真上 + , polarDirection :: !Double -- ^ 回転方向。 +1 = 時計回り (既定)、 -1 = 反時計回り + } deriving (Show, Eq, Generic) + +-- | [日本語]: 極座標の既定 (@start=0, direction=+1@ = 真上始点・時計回り)。 +-- [English]: The default polar options (@start=0, direction=+1@: top-start, +-- clockwise). +defaultPolarOpts :: PolarOpts +defaultPolarOpts = PolarOpts { polarStart = 0, polarDirection = 1 } + +-- | [日本語]: ★ Phase 69 A4: 三角座標の向きオプション (polar の 'PolarOpts' と同型)。 +-- 'ternaryClockwise' = 頂点の巡回方向 (True=時計回り = 左下↔右下 を反転)。 +-- 'ternaryRotate' = どの成分を上頂点に置くかの回転 (0/120/240 度・反時計回りに巡回)。 +-- 既定 (@clockwise=False, rotate=0@) = a=上・b=左下・c=右下 (Phase 64 の従来配置)。 +-- [English]: ★ Phase 69 A4: ternary orientation options (mirrors polar's +-- 'PolarOpts'). 'ternaryClockwise' flips the vertex precession (True swaps +-- bottom-left ↔ bottom-right); 'ternaryRotate' cycles which component sits at +-- the top vertex (0/120/240 degrees, counter-clockwise). The default +-- (@clockwise=False, rotate=0@) is a=top / b=bottom-left / c=bottom-right. +data TernaryOpts = TernaryOpts + { ternaryClockwise :: !Bool -- ^ True = 時計回り (左下↔右下 反転)。 既定 False + , ternaryRotate :: !Int -- ^ 上頂点の回転 0/120/240 度。 既定 0 + } deriving (Show, Eq, Generic) + +defaultTernaryOpts :: TernaryOpts +defaultTernaryOpts = TernaryOpts { ternaryClockwise = False, ternaryRotate = 0 } + +-- | [日本語]: 座標系 (= 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 +-- 角度 ('PolarOpts' で start/direction 可変)、 他軸を半径に写す。 PolarY + +-- stacked bar = 円グラフ。 'CoordTernary' = 三角座標 (組成データ、 3 成分を +-- 正三角形の 3 頂点へ; Phase 64 §3 で投影・grid を実装)。 +-- JSON tag: "cartesian" / "flip" / "polarx" / "polary" / "ternary" +-- (PS Codec と一致)。 ★ 後方互換: polar は既定 'PolarOpts' なら従来どおり +-- 文字列 tag ("polarx") を出力し、 start/direction を指定したときだけ +-- @{"tag":"polarx","start":..,"direction":..}@ の object 形になる。 読込は +-- 両形を受ける (旧 spec の "polarx" 文字列も既定 opts で読める)。 +-- [English]: The coordinate system (equivalent to ggplot's coord_*). +-- 'CoordCartesian' (default) is the usual orthogonal coordinate system. +-- 'CoordFlip' swaps the x/y axes (equivalent to coord_flip). 'CoordPolarX' / +-- 'CoordPolarY' are polar coordinates (coord_polar(theta="x"|"y")); the +-- theta axis maps to an angle (start/direction configurable via 'PolarOpts') +-- and the other axis to the radius. 'CoordTernary' is the ternary +-- (compositional) coordinate system, mapping three components to the corners +-- of an equilateral triangle (projection/grid implemented in Phase 64 §3). +-- JSON tag: "cartesian" / "flip" / "polarx" / "polary" / "ternary" (matches +-- the PS Codec). Backward compatible: a polar coord with default 'PolarOpts' +-- still encodes as the bare string tag ("polarx"); only a non-default +-- start/direction produces the object form +-- @{"tag":"polarx","start":..,"direction":..}@. Decoding accepts both forms +-- (an old spec's "polarx" string reads back with the default opts). +data Coord + = CoordCartesian + | CoordFlip + | CoordPolarX !PolarOpts + | CoordPolarY !PolarOpts + | CoordTernary !TernaryOpts -- ★ Phase 69 A4: 向き opts を保持 (既定は従来配置) 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 - } +-- | [日本語]: polar coord の 'PolarOpts' を JSON 化する共通部。 既定なら文字列 +-- tag のまま (後方互換)、 非既定なら object 形。 +-- [English]: Shared JSON encoding for a polar coord's 'PolarOpts'. Default +-- opts keep the bare string tag (backward compatible); non-default opts use +-- the object form. +polarCoordJson :: Text -> PolarOpts -> Value +polarCoordJson tag o + | o == defaultPolarOpts = String tag + | otherwise = object [ "tag" .= tag + , "start" .= polarStart o + , "direction" .= polarDirection o ] +-- | [日本語]: ★ Phase 69 A4: ternary の 'TernaryOpts' を JSON 化。 polar と同方針 +-- (既定なら文字列 tag "ternary"・非既定なら object 形)。 旧 spec の "ternary" 文字列は +-- 既定 opts で読める (後方互換)。 +-- [English]: ★ Phase 69 A4: JSON encoding for ternary's 'TernaryOpts', same +-- policy as polar (bare string tag "ternary" when default; object form +-- otherwise). Old specs' "ternary" string read back with the default opts. +ternaryCoordJson :: TernaryOpts -> Value +ternaryCoordJson o + | o == defaultTernaryOpts = String "ternary" + | otherwise = object [ "tag" .= ("ternary" :: Text) + , "clockwise" .= ternaryClockwise o + , "rotate" .= ternaryRotate o ] + instance ToJSON Coord where - toJSON = Aeson.genericToJSON coordJsonOptions - toEncoding = Aeson.genericToEncoding coordJsonOptions + toJSON CoordCartesian = String "cartesian" + toJSON CoordFlip = String "flip" + toJSON (CoordTernary o) = ternaryCoordJson o + toJSON (CoordPolarX o) = polarCoordJson "polarx" o + toJSON (CoordPolarY o) = polarCoordJson "polary" o instance FromJSON Coord where - parseJSON = Aeson.genericParseJSON coordJsonOptions + parseJSON (String s) = case s of + "cartesian" -> pure CoordCartesian + "flip" -> pure CoordFlip + "polarx" -> pure (CoordPolarX defaultPolarOpts) + "polary" -> pure (CoordPolarY defaultPolarOpts) + "ternary" -> pure (CoordTernary defaultTernaryOpts) + _ -> fail ("Coord: unknown tag " ++ show s) + parseJSON v@(Object o) = do + tag <- o .: "tag" + case (tag :: Text) of + "polarx" -> CoordPolarX <$> parsePolar + "polary" -> CoordPolarY <$> parsePolar + "ternary" -> CoordTernary <$> parseTernary + _ -> Aeson.typeMismatch "Coord" v + where + parsePolar = PolarOpts <$> o .:? "start" .!= polarStart defaultPolarOpts + <*> o .:? "direction" .!= polarDirection defaultPolarOpts + parseTernary = TernaryOpts <$> o .:? "clockwise" .!= ternaryClockwise defaultTernaryOpts + <*> o .:? "rotate" .!= ternaryRotate defaultTernaryOpts + parseJSON v = Aeson.typeMismatch "Coord" v --- | Phase 11 A7-b: facet の scale 共有方式 (= ggplot facet_wrap(scales=))。 +-- | [日本語]: 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 と一致)。 +-- [English]: How facets share their scale (equivalent to ggplot's +-- facet_wrap(scales=)). 'FacetFixed' (default) uses one common domain +-- across all panels (values are comparable). 'FacetFreeX' gives each +-- panel an independent domain on the x axis only, 'FacetFreeY' on the y +-- axis only, and 'FacetFree' makes both axes independent. A free axis +-- lets each panel hold a scale sized to its own data range, and every +-- panel shows its axis. JSON tag: "fixed" / "freex" / "freey" / "free" +-- (matches the PS Codec). data FacetScales = FacetFixed | FacetFreeX | FacetFreeY | FacetFree deriving (Show, Eq, Generic) @@ -378,19 +569,28 @@ instance FromJSON FacetScales where parseJSON = Aeson.genericParseJSON facetScalesJsonOptions --- | x 軸が free か (= 'FacetFreeX' または 'FacetFree')。 +-- | [日本語]: x 軸が free か (= 'FacetFreeX' または 'FacetFree')。 +-- [English]: Whether the x axis is free (that is, 'FacetFreeX' or 'FacetFree'). freeScaleX :: FacetScales -> Bool freeScaleX fs = fs == FacetFreeX || fs == FacetFree --- | y 軸が free か (= 'FacetFreeY' または 'FacetFree')。 +-- | [日本語]: y 軸が free か (= 'FacetFreeY' または 'FacetFree')。 +-- [English]: Whether the y axis is free (that is, 'FacetFreeY' or 'FacetFree'). freeScaleY :: FacetScales -> Bool freeScaleY fs = fs == FacetFreeY || fs == FacetFree --- | Phase 11 A7-b: facet_grid の panel サイズ配分 (= ggplot facet_grid(space=))。 +-- | [日本語]: facet_grid の panel サイズ配分 (= ggplot facet_grid(space=))。 -- 'SpaceFixed' (既定) = 全 panel 同サイズ。 'SpaceFreeX' = 列幅を各列の x データ範囲に -- 比例、 'SpaceFreeY' = 行高を各行の y データ範囲に比例、 'SpaceFree' = 両方。 通常 -- scales="free" と併用する (= 各 panel の単位長を揃える)。 JSON tag: "fixed" / "freex" -- / "freey" / "free"。 +-- [English]: How panel size is distributed in facet_grid (equivalent to +-- ggplot's facet_grid(space=)). 'SpaceFixed' (default) gives every panel +-- the same size. 'SpaceFreeX' makes column width proportional to each +-- column's x data range, 'SpaceFreeY' makes row height proportional to +-- each row's y data range, and 'SpaceFree' does both. This is usually +-- combined with scales="free" (to keep each panel's unit length +-- consistent). JSON tag: "fixed" / "freex" / "freey" / "free". data FacetSpace = SpaceFixed | SpaceFreeX | SpaceFreeY | SpaceFree deriving (Show, Eq, Generic) @@ -408,16 +608,21 @@ instance FromJSON FacetSpace where parseJSON = Aeson.genericParseJSON facetSpaceJsonOptions --- | 列幅が free か (= 'SpaceFreeX' または 'SpaceFree')。 +-- | [日本語]: 列幅が free か (= 'SpaceFreeX' または 'SpaceFree')。 +-- [English]: Whether column width is free (that is, 'SpaceFreeX' or 'SpaceFree'). freeSpaceX :: FacetSpace -> Bool freeSpaceX fs = fs == SpaceFreeX || fs == SpaceFree --- | 行高が free か (= 'SpaceFreeY' または 'SpaceFree')。 +-- | [日本語]: 行高が free か (= 'SpaceFreeY' または 'SpaceFree')。 +-- [English]: Whether row height is free (that is, 'SpaceFreeY' or '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 で剥がす)。 +-- | [日本語]: shape encoding 用 8 種。 PS Spec.purs MarkShape と一致 (= JSON round-trip)。 +-- JSON: "circle" / "square" / ... ("MSh" prefix を constructorTagModifier で剥がす)。 +-- [English]: Eight variants for shape encoding. Matches PS Spec.purs's +-- MarkShape (for JSON round-tripping). JSON: "circle" / "square" / ... +-- (the "MSh" prefix is stripped by constructorTagModifier). data MarkShape = MShCircle | MShSquare | MShTriangle | MShDiamond | MShCross | MShSpade | MShHeart | MShClub @@ -437,7 +642,9 @@ instance FromJSON MarkShape where parseJSON = Aeson.genericParseJSON markShapeJsonOptions --- | cat 名 → MarkShape の対応 1 件。 PS は `{ value, shape }` record で表現。 +-- | [日本語]: cat 名 → MarkShape の対応 1 件。 PS は `{ value, shape }` record で表現。 +-- [English]: One category-name to MarkShape mapping. PS represents this as +-- a `{ value, shape }` record. data ShapeMapEntry = ShapeMapEntry { smeValue :: !Text , smeShape :: !MarkShape @@ -458,9 +665,13 @@ 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 と一致。 +-- | [日本語]: linetype aesthetic 用 6 種 (= ggplot2 標準 linetype)。 +-- JSON: "solid"/"dashed"/"dotted"/"dotdash"/"longdash"/"twodash" +-- ("Lt" prefix を constructorTagModifier で剥がし lowercase)。 PS Spec.purs LineType と一致。 +-- [English]: Six variants for the linetype aesthetic (equivalent to +-- ggplot2's standard linetypes). JSON: "solid"/"dashed"/"dotted"/ +-- "dotdash"/"longdash"/"twodash" (the "Lt" prefix is stripped and +-- lowercased by constructorTagModifier). Matches PS Spec.purs's LineType. data LineType = LtSolid | LtDashed | LtDotted | LtDotDash | LtLongDash | LtTwoDash deriving (Show, Eq, Enum, Bounded, Generic) @@ -479,9 +690,14 @@ instance FromJSON LineType where parseJSON = Aeson.genericParseJSON lineTypeJsonOptions --- | LineType → SVG/Canvas dash array (px)。 Solid のみ [] (= 実線・dasharray 無し)。 --- 値は ggplot2 既定の見た目に近い汎用パターン。 lsWidth に依存しない固定 px。 --- ※ Solid が [] を返すことが既存 SVG ゼロ diff の要 (dasharray attr を出さない)。 +-- | [日本語]: LineType → SVG/Canvas dash array (px)。 Solid のみ [] (= 実線・dasharray 無し)。 +-- 値は ggplot2 既定の見た目に近い汎用パターン。 lsWidth に依存しない固定 px。 +-- ※ Solid が [] を返すことが既存 SVG ゼロ diff の要 (dasharray attr を出さない)。 +-- [English]: Maps a LineType to an SVG/Canvas dash array (in px). Only +-- Solid returns [] (a solid line with no dasharray). The values are a +-- generic pattern close to ggplot2's default look, expressed as fixed px +-- independent of lsWidth. Note: Solid returning [] is essential for +-- zero-diff SVG output (it must not emit a dasharray attribute). lineTypeDash :: LineType -> [Double] lineTypeDash lt = case lt of LtSolid -> [] @@ -491,7 +707,10 @@ LtLongDash -> [8, 4] LtTwoDash -> [2, 2, 6, 2] --- | categorical linetype scale: cat index → LineType (Solid から巡回)。 --- ggplot scale_linetype_discrete 同様、 index 0 = solid。 PS と同一順。 +-- | [日本語]: categorical linetype scale: cat index → LineType (Solid から巡回)。 +-- ggplot scale_linetype_discrete 同様、 index 0 = solid。 PS と同一順。 +-- [English]: A categorical linetype scale: category index to LineType +-- (cycling from Solid). As with ggplot's scale_linetype_discrete, index 0 +-- is solid. The order matches 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 --- a/src/Graphics/Hgg/Spec/Setters.hs +++ b/src/Graphics/Hgg/Spec/Setters.hs @@ -1,644 +1,1343 @@ -- | -- 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 軸のみ。 +-- Description : Top-level setters that build VisualSpec (title / theme / axis / legend / annot etc.) +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- [日本語]: '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 する。 +-- 挙動・出力は完全に不変。 +-- [English]: Split out of 'Graphics.Hgg.Spec' as part of its module split. +-- Holds the top-level setters that build 'VisualSpec' via `<>` ('layer' / +-- 'title' / 'theme' / the 'facet' family / the 'legend' family / the +-- @annot@ family / inset / figure size / font setters, etc.), 'Labs', and +-- the three VisualSpec-dependent mark constructors ('histogramWide' / +-- 'distCols' / 'ridgeAutoFlip'). Figure-composition operators live in +-- 'Graphics.Hgg.Spec.Concat'. The public API is unchanged: +-- 'Graphics.Hgg.Spec' (the facade) still re-exports everything. Behavior +-- and output are fully unchanged. +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Spec.Setters + ( -- * layer 装着 + 基本 setter + layer, layers, purePlot, title, subtitle, caption, tag, xLabel, yLabel, zLabel + , Labs(..), labs, emptyLabs + , theme, facet, facetWrap, facetGrid, facetCols, facetScales, facetSpace + , subplots, subplotCols, subplotWidths, subplotHeights, subplotTags + , repeatFields, selectPanels, selectedSubplots + , scaleXDiscreteLimits, scaleYDiscreteLimits, applyDiscreteLimits, reindexLayer + -- * theme override setter + , plotBg, themePlotBg, panelFill, panelBorder, gridColor, themeGrid, themeAxisLine + , themeGridMajor, themeGridMinor, themeLegendPos + , themeTickLength, themeTickDir, themePlotMargin, themeBaseFontSize + , themeGridWidth, themeGridMinorWidth, themeAxisLineWidth + , themeAxisText, themeAxisTitle, themeLegendKeySize + , axisColor, textColor, tickColor, titleColor, titleHjust + , stripFill, themeStrip, legendKeyBg + , themeTitleFont, themeAxisLabelFont, themeTickFont, themeLegendFont + , themeFontFamily + , themeAxisTextAngle, themeAxisTextAngleX, themeAxisTextAngleY + , axisTextAngleXOf, axisTextAngleYOf + -- * 合成 preset (cowplot 風) + , themeCowplot, themeMinimalGrid, themeMap + , themeCowplotSized, themeMinimalGridSized, themeMapSized + -- * VisualSpec 依存の mark 構築子 (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, coordPolarWith, coordPolarYWith, coordTernary + , coordTernaryWith -- ★ Phase 69 A4 + , 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 (Margin (..), ThemeName (..), + ThemeOverride (..), TickDir) +import Graphics.Hgg.Spec.Visual + + +-- =========================================================================== +-- Top-level setters +-- =========================================================================== + +-- | [日本語]: spec の純粋値起点 (= 'mempty' alias)。 mempty 直接でも良いが、 +-- 「これは plot spec の最初の値ですよ」 という意図を名前で示す。 副作用関数 +-- (@plot@ / @saveSVG@ 等) との対比で `pure-` prefix。 +-- [English]: The pure starting value for a spec (an alias for +-- 'mempty'). Using mempty directly would also work, but the name +-- signals the intent "this is the initial value of a plot spec" — the +-- `pure-` prefix contrasts with effectful functions (@plot@ / +-- @saveSVG@, etc.). +purePlot :: VisualSpec +purePlot = mempty + +-- | [日本語]: 'Layer' を 'VisualSpec' に lift (= layer リストの単一要素 +-- spec)。 +-- [English]: Lifts a 'Layer' into a 'VisualSpec' (a spec with a +-- single-element layer list). +layer :: Layer -> VisualSpec +layer l = mempty { vsLayers = [l] } + +-- | [日本語]: 'layer' のリスト版 (= @layer . mconcat@)。 hvega 風のリスト書きが +-- 好みの場合に: @layers [scatter "x" "y", colorBy "group"] = +-- layer (scatter "x" "y" <> colorBy "group")@。 等価な別名であり '<>' 版が正典 +-- (doc の例は '<>' で統一)。 外部フィードバック (公開版 hgg へのコメント) を +-- 受けて追加した。 +-- [English]: A list version of 'layer' (@layer . mconcat@). For those +-- who prefer hvega-style list syntax: +-- @layers [scatter "x" "y", colorBy "group"] = +-- layer (scatter "x" "y" <> colorBy "group")@. An equivalent alias — the +-- '<>' form is canonical (doc examples stick to '<>'). Added in response +-- to external feedback (comments on the public hgg release). +layers :: [Layer] -> VisualSpec +layers = layer . mconcat + +title, xLabel, yLabel, zLabel :: Text -> VisualSpec +title t = mempty { vsTitle = Last (Just t) } +xLabel t = mempty { vsXLabel = Last (Just t) } +yLabel t = mempty { vsYLabel = Last (Just t) } +-- ★ Phase 64 A11: 三角座標 (ternary) 第 3 軸 (encZ 成分) のタイトル。 +zLabel t = mempty { vsZLabel = Last (Just t) } + +-- | [日本語]: 凡例タイトル (= ggplot scale_color_*(name=) / labs(color=))。 +-- color/fill/shape/linetype の凡例ヘッダに表示。 軸タイトルは +-- 'xLabel'/'yLabel' を使う (= positional scale の name = 軸ラベル)。 +-- [English]: The legend title (like ggplot's scale_color_*(name=) / +-- labs(color=)). Shown as the header of the color/fill/shape/linetype +-- legend. Use 'xLabel'/'yLabel' for axis titles (a positional scale's +-- name is the axis label). +legendTitle :: Text -> VisualSpec +legendTitle t = mempty { vsLegendTitle = Last (Just t) } + +-- | [日本語]: labs サブシステムの個別 setter (= ggplot +-- labs(subtitle=,caption=,tag=))。 'subtitle' = title 直下の小見出し、 +-- 'caption' = 図右下の注記、 'tag' = 左上隅のタグ。 +-- [English]: Individual setters in the labs subsystem (like ggplot's +-- labs(subtitle=,caption=,tag=)). 'subtitle' is the sub-heading right +-- under the title, 'caption' is the note in the bottom-right corner, +-- and 'tag' is the tag in the top-left corner. +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) } + +-- | [日本語]: ggplot @labs()@ 相当のまとめ setter。 各フィールドは 'Maybe' で +-- 「指定しない」 を表す。 @labs emptyLabs { labsTitle = Just "T", labsX = Just "x" }@ +-- のように 'emptyLabs' を起点に必要な label だけ埋める。 @labsColor@ は凡例 +-- タイトル ('legendTitle')。 指定した label を 'mconcat' で合成するので既存 +-- setter と等価。 +-- [English]: A bundled setter equivalent to ggplot's @labs()@. Each +-- field is a 'Maybe' representing "not specified". Start from +-- 'emptyLabs' and fill only the labels you need, e.g. +-- @labs emptyLabs { labsTitle = Just "T", labsX = Just "x" }@. +-- @labsColor@ is the legend title ('legendTitle'). The specified labels +-- are combined with 'mconcat', so this is equivalent to the individual +-- setters. +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 のベース)。 +-- [English]: The starting 'Labs' value with every field unspecified +-- (the base for record updates). +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) } + +-- | [日本語]: element 単位 theme override の setter 群 (ggplot theme(element_*) +-- 相当)。 `theme ThemeGrey <> themeGrid False <> panelFill "#fafafa"` のように +-- `<>` で重ねる。 +-- [English]: A family of per-element theme-override setters (like +-- ggplot's theme(element_*)). Stack them with `<>`, e.g. +-- `theme ThemeGrey <> themeGrid False <> panelFill "#fafafa"`. +themeGrid :: Bool -> VisualSpec -- panel.grid on/off (= major/minor 両方の糖衣) +themeGrid b = mempty { vsThemeOverride = mempty { toShowGrid = Last (Just b) } } + +-- | [日本語]: grid major/minor の個別 on/off (cowplot @theme_minimal_grid()@ +-- 等)。 優先順は 個別 > 一括 'themeGrid' > preset。 +-- `theme ThemeMinimal <> themeGridMinor False` のように重ねる。 +-- [English]: Individual on/off for grid major/minor (like cowplot's +-- @theme_minimal_grid()@). Priority is individual > the bulk +-- 'themeGrid' > preset. Stack it like +-- `theme ThemeMinimal <> themeGridMinor False`. +themeGridMajor :: Bool -> VisualSpec -- panel.grid.major on/off +themeGridMajor b = mempty { vsThemeOverride = mempty { toShowGridMajor = Last (Just b) } } + +themeGridMinor :: Bool -> VisualSpec -- panel.grid.minor on/off +themeGridMinor b = mempty { vsThemeOverride = mempty { toShowGridMinor = Last (Just b) } } + +-- | [日本語]: legend.position を theme に焼き込む (自作 theme を `<>` で配る用)。 +-- 図レベルの 'legendPos' が指定されていればそちらが優先 (ggplot の theme() と +-- 個別指定の関係に同じ)。 +-- [English]: Bakes legend.position into the theme (for distributing a +-- custom theme via `<>`). If the figure-level 'legendPos' is set, it +-- takes priority (the same relationship as ggplot's theme() vs. an +-- individual setting). +themeLegendPos :: LegendPosition -> VisualSpec +themeLegendPos p = mempty { vsThemeOverride = mempty { toLegendPos = Last (Just p) } } + +-- | [日本語]: 軸目盛線の長さ (pt) を theme に焼き込む (ggplot +-- @axis.ticks.length@ 相当、 既定 2.75pt)。 tick 長は軸ラベル位置・マージン +-- 予約にも波及する (computeLayout が実効値を参照)。 +-- [English]: Bakes the axis tick length (pt) into the theme (like +-- ggplot's @axis.ticks.length@, default 2.75pt). The tick length also +-- affects axis-label position and margin reservation (computeLayout +-- reads the effective value). +themeTickLength :: Double -> VisualSpec +themeTickLength d = mempty { vsThemeOverride = mempty { toTickLength = Last (Just d) } } + +-- | [日本語]: ★ Phase 68: grid 線 (major・全 grid の base) の線幅 (pt) を theme に +-- 焼き込む (ggplot @theme(panel.grid = element_line(linewidth=))@ 相当)。 指定すると +-- Cartesian major に加え polar / ternary の grid も同じ幅に統一される (panel.grid は +-- 座標系非依存)。 未指定時は各座標系の現状値 (Cartesian major 1.0 / polar・ternary 0.5)。 +-- minor は 'themeGridMinorWidth' 未指定なら自動で major × 0.5 に追従する。 +-- [English]: ★ Phase 68: bakes the grid line width (pt) into the theme (like +-- ggplot's @theme(panel.grid = element_line(linewidth=))@). Setting it unifies +-- the Cartesian major with the polar / ternary grid at the same width +-- (panel.grid is coord-independent). When unspecified each coord keeps its +-- current literal (Cartesian major 1.0 / polar & ternary 0.5). The minor grid +-- follows major × 0.5 automatically unless 'themeGridMinorWidth' is set. +themeGridWidth :: Double -> VisualSpec +themeGridWidth d = mempty { vsThemeOverride = mempty { toGridWidth = Last (Just d) } } + +-- | [日本語]: ★ Phase 68: Cartesian minor grid の線幅 (pt) を独立に上書きする (ggplot +-- @panel.grid.minor = element_line(linewidth=)@)。 未指定時は 'themeGridWidth' +-- (major) × 0.5 (ggplot @rel(0.5)@ 準拠・既定 0.5)。 +-- [English]: ★ Phase 68: overrides the Cartesian minor grid width (pt) +-- independently (ggplot @panel.grid.minor = element_line(linewidth=)@). +-- When unspecified it is 'themeGridWidth' (major) × 0.5 (ggplot @rel(0.5)@, +-- default 0.5). +themeGridMinorWidth :: Double -> VisualSpec +themeGridMinorWidth d = mempty { vsThemeOverride = mempty { toGridMinorWidth = Last (Just d) } } + +-- | [日本語]: ★ Phase 68: 軸線の線幅 (pt) を theme に焼き込む (ggplot @axis.line@ / +-- @panel.border@ 相当)。 axis.line (下辺/左辺)・panel border・ternary の三辺・ +-- 右 Y 軸線を統一して太らせる。 未指定時は現状 1.0。 tick mark は対象外 +-- (ggplot @axis.ticks@ = 別 element)。 +-- [English]: ★ Phase 68: bakes the axis line width (pt) into the theme (like +-- ggplot's @axis.line@ / @panel.border@). Widens the axis.line (bottom/left), +-- panel border, ternary edges and the right Y axis uniformly. Defaults to the +-- current 1.0 when unspecified. Tick marks are excluded (ggplot @axis.ticks@ +-- is a separate element). +themeAxisLineWidth :: Double -> VisualSpec +themeAxisLineWidth d = mempty { vsThemeOverride = mempty { toAxisLineWidth = Last (Just d) } } + +-- | [日本語]: 軸目盛線の向き ('Graphics.Hgg.Spec.Theme.TickOut' 外 / +-- 'Graphics.Hgg.Spec.Theme.TickIn' 内 / 'Graphics.Hgg.Spec.Theme.TickBoth' +-- 両)。 TickIn は panel 外に出ないため、 軸ラベルは tick 長 0 と同じ位置に寄る +-- (ggplot の負 axis.ticks.length と同挙動)。 +-- [English]: The axis tick direction ('Graphics.Hgg.Spec.Theme.TickOut' +-- outward / 'Graphics.Hgg.Spec.Theme.TickIn' inward / +-- 'Graphics.Hgg.Spec.Theme.TickBoth' both). Since TickIn does not extend +-- outside the panel, axis labels move to the same position as a tick +-- length of 0 (the same behavior as ggplot's negative +-- axis.ticks.length). +themeTickDir :: TickDir -> VisualSpec +themeTickDir d = mempty { vsThemeOverride = mempty { toTickDir = Last (Just d) } } + +-- | [日本語]: 図の外周余白 (pt) を theme に焼き込む (ggplot @plot.margin@ +-- 相当)。 引数順は ggplot @margin(t, r, b, l)@ と同じ。 指定時は自動算出の +-- 外周分 (各辺 half_line = 5.5pt) を __置き換える__ (加算ではない)。 軸ラベル・ +-- title 帯・凡例などの内側予約は従来どおり自動算出のまま。 +-- [English]: Bakes the figure's outer margin (pt) into the theme (like +-- ggplot's @plot.margin@). Argument order matches ggplot's +-- @margin(t, r, b, l)@. When specified, it __replaces__ the +-- automatically computed outer margin (each side's half_line = 5.5pt) — +-- it does not add to it. Inner reservations such as axis labels, the +-- title band and the legend are still computed automatically as +-- before. +themePlotMargin :: Double -> Double -> Double -> Double -> VisualSpec +themePlotMargin t r b l = + mempty { vsThemeOverride = mempty { toPlotMargin = Last (Just (Margin t r b l)) } } + +-- | [日本語]: base font size (pt) を theme に焼き込む (ggplot @base_size@ +-- 相当、 既定 11)。 各 slot の既定 font size はこれからの相対倍率で派生する +-- (title ×1.2 / axis.title ×1 / axis.text ×0.8 / legend.title ×1 / +-- legend.text ×0.8)。 'themeTitleFont' 等の個別指定 (fsSize) があればそちらが +-- 優先。 +-- [English]: Bakes the base font size (pt) into the theme (like +-- ggplot's @base_size@, default 11). Each slot's default font size is +-- derived from this via a relative multiplier (title ×1.2 / +-- axis.title ×1 / axis.text ×0.8 / legend.title ×1 / legend.text ×0.8). +-- An individual override (fsSize) such as 'themeTitleFont' takes +-- priority when present. +themeBaseFontSize :: Double -> VisualSpec +themeBaseFontSize s = + mempty { vsThemeOverride = mempty { toBaseFontSize = Last (Just s) } } + +-- | [日本語]: 軸目盛ラベル文字 (ggplot @axis.text@) の表示。 False = +-- element_blank 相当で文字のみ消える (tick 線の有無は 'themeTickLength' と +-- 独立)。 ラベル文字ぶんの margin 予約も連動して落ちる。 既定は 'ThemeVoid' +-- のみ False。 +-- [English]: Whether to show axis tick-label text (ggplot's +-- @axis.text@). False is equivalent to element_blank — only the text +-- disappears (independent of whether tick marks are shown, controlled +-- by 'themeTickLength'). The margin reserved for label text is also +-- dropped accordingly. Default is False only for 'ThemeVoid'. +themeAxisText :: Bool -> VisualSpec -- axis.text on/off +themeAxisText b = mempty { vsThemeOverride = mempty { toShowAxisText = Last (Just b) } } + +-- | [日本語]: 軸タイトル (ggplot @axis.title@) の表示。 False = element_blank +-- 相当 ('xLabel' / 'yLabel' 指定があっても描かず margin も予約しない)。 +-- 既定は 'ThemeVoid' のみ False。 +-- [English]: Whether to show the axis title (ggplot's @axis.title@). +-- False is equivalent to element_blank (even if 'xLabel' / 'yLabel' is +-- set, it is neither drawn nor reserves margin). Default is False only +-- for 'ThemeVoid'. +themeAxisTitle :: Bool -> VisualSpec -- axis.title on/off +themeAxisTitle b = mempty { vsThemeOverride = mempty { toShowAxisTitle = Last (Just b) } } + +-- | [日本語]: 凡例キー 1 辺 (pt、 ggplot @legend.key.size@ 相当)。 キーの行 +-- pitch = キー辺なので凡例の行間もこれで決まる (既定 = 1.2 lines = 1.2 × base × +-- 1.3133、 base 11 で 17.34pt)。 凡例の margin 予約にも波及する。 +-- [English]: The legend key's side length (pt, like ggplot's +-- @legend.key.size@). Since the key's row pitch equals the key side, +-- this also determines the legend's line spacing (default = 1.2 lines +-- = 1.2 × base × 1.3133, i.e. 17.34pt at base 11). It also affects the +-- legend's margin reservation. +themeLegendKeySize :: Double -> VisualSpec -- legend.key.size (pt) +themeLegendKeySize d = mempty { vsThemeOverride = mempty { toLegendKeySize = Last (Just d) } } + +-- =========================================================================== +-- 合成 preset (cowplot 風) +-- =========================================================================== +-- 'ThemeName' の enum には足さず (JSON parity 維持)、 既存 setter を `<>` で +-- 束ねた 'VisualSpec' 値として提供する = 「自作 theme は setter 合成で表現する」 +-- 方針の自己適用。 後ろに setter を重ねれば個別上書きできる +-- (例 @themeCowplot <> themeTickLength 5@)。 数値は R cowplot 1.2.0 の既定 +-- (基準 font_size N: half_line=N/2 → margin N/2 pt / tick N/4 pt、 文字は +-- title ×16/14 bold / axis.title ×1 / axis.text ×12/14 の相対倍率、 黒基調)。 +-- ★ 'themeBaseFontSize' を焼き込む sized 版が本体。 tick 長・外周 +-- margin は base 派生の既定値に任せ、 明示 setter は置かない (= preset 後の +-- 'themeBaseFontSize' 上書きにも spacing が連動する)。 + +-- | [日本語]: cowplot @theme_cowplot(font_size = N)@ 相当 = grid なし・下/左の +-- 黒軸線・外向き tick N/4 pt・外周余白 N/2 pt・黒基調の文字・背景透過。 +-- [English]: The equivalent of cowplot's +-- @theme_cowplot(font_size = N)@: no grid, black axis lines on the +-- bottom/left, outward ticks of N/4 pt, an outer margin of N/2 pt, +-- black-toned text, and a transparent background. +themeCowplotSized :: Double -> VisualSpec +themeCowplotSized n = + theme ThemeClassic + <> themeBaseFontSize n + <> cowplotFontsSized n + <> axisColor "#000000" <> tickColor "#000000" + <> textColor "#000000" <> titleColor "#000000" + <> themePlotBg False -- ★ cowplot は rect fill NA = 背景透過 + <> themeLegendKeySize (1.1 * n) -- ★ cowplot は legend.key.size = 1.1×font_size + +-- | [日本語]: cowplot @theme_cowplot()@ 相当 (= 既定 font_size 14)。 +-- [English]: The equivalent of cowplot's @theme_cowplot()@ (default +-- font_size 14). +themeCowplot :: VisualSpec +themeCowplot = themeCowplotSized 14 + +-- | [日本語]: cowplot @theme_minimal_grid(font_size = N)@ 相当 = major grid +-- (grey85) のみ・軸線/枠/tick なし・黒基調の文字。 +-- [English]: The equivalent of cowplot's +-- @theme_minimal_grid(font_size = N)@: only the major grid (grey85), no +-- axis lines/border/ticks, black-toned text. +themeMinimalGridSized :: Double -> VisualSpec +themeMinimalGridSized n = + theme ThemeMinimal + <> themeBaseFontSize n + <> cowplotFontsSized n + <> textColor "#000000" <> titleColor "#000000" + <> themeGridMinor False + <> gridColor "#d9d9d9" + <> panelBorder False + <> themeTickLength 0 + <> themePlotBg False -- ★ cowplot は rect fill NA = 背景透過 + <> themeLegendKeySize (1.1 * n) -- ★ cowplot は legend.key.size = 1.1×font_size + +-- | [日本語]: cowplot @theme_minimal_grid()@ 相当 (= 既定 font_size 14)。 +-- [English]: The equivalent of cowplot's @theme_minimal_grid()@ +-- (default font_size 14). +themeMinimalGrid :: VisualSpec +themeMinimalGrid = themeMinimalGridSized 14 + +-- | [日本語]: cowplot @theme_map(font_size = N)@ 相当 = 軸線・grid・枠・tick +-- 線・軸ラベル文字・軸タイトルを全て消す (★ 'ThemeVoid' 既定で axis.text / +-- axis.title も blank)。 タイトル系と凡例は残る。 facet strip は theme_map が +-- grey80 で残すため 'stripFill' を明示 (ThemeVoid 既定は strip なし)。 +-- [English]: The equivalent of cowplot's @theme_map(font_size = N)@: +-- removes axis lines, grid, border, tick marks, axis-label text and +-- axis titles entirely ('ThemeVoid' also blanks axis.text / +-- axis.title by default). Title elements and the legend remain. Since +-- theme_map keeps the facet strip at grey80, 'stripFill' is set +-- explicitly (ThemeVoid's default has no strip). +themeMapSized :: Double -> VisualSpec +themeMapSized n = + theme ThemeVoid + <> themeBaseFontSize n + <> cowplotFontsSized n + <> textColor "#000000" <> titleColor "#000000" + <> themeTickLength 0 + <> themePlotBg False -- ★ cowplot は rect fill NA = 背景透過 + <> stripFill "#cccccc" -- ★ theme_map は strip.background grey80 を残す + <> themeLegendKeySize (1.1 * n) -- ★ cowplot は legend.key.size = 1.1×font_size + +-- | [日本語]: cowplot @theme_map()@ 相当 (= 既定 font_size 14)。 +-- [English]: The equivalent of cowplot's @theme_map()@ (default +-- font_size 14). +themeMap :: VisualSpec +themeMap = themeMapSized 14 + +-- | [日本語]: preset 3 種で共有する cowplot(N) の文字設定 (title は bold)。 +-- 倍率は cowplot 既定 rel_large = 16/14 (title) / rel_small = 12/14 +-- (axis.text・legend)。 ggplot 既定倍率 (1.2/0.8) と異なるため base 派生に +-- 任せず明示する。 +-- [English]: The cowplot(N) font settings shared by the three presets +-- (title is bold). The multipliers follow cowplot's defaults +-- rel_large = 16/14 (title) / rel_small = 12/14 (axis.text, legend). +-- Since these differ from ggplot's default multipliers (1.2/0.8), they +-- are set explicitly rather than left to derive from base. +cowplotFontsSized :: Double -> VisualSpec +cowplotFontsSized n = + themeTitleFont (fontSize (n * 16 / 14) <> fontWeight "bold") + <> themeAxisLabelFont (fontSize n) + <> themeTickFont (fontSize (n * 12 / 14)) + <> themeLegendFont (fontSize (n * 12 / 14)) + +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) } } + +-- | [日本語]: plot.background を塗るか (★)。 @themePlotBg False@ = 塗らない +-- (= 透過、 ggplot @plot.background = element_blank()@ / cowplot fill NA +-- 相当)。 +-- [English]: Whether to paint plot.background. @themePlotBg False@ +-- means no paint (transparent, equivalent to ggplot's +-- @plot.background = element_blank()@ / cowplot's fill NA). +themePlotBg :: Bool -> VisualSpec -- plot.background 塗り on/off +themePlotBg b = mempty { vsThemeOverride = mempty { toShowBackground = Last (Just b) } } + +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) } } + +-- | [日本語]: theme 経由の font setter 群 (ggplot +-- theme(plot.title=element_text(...)) 等)。 vsTitleFont 等の専用 setter より +-- 優先される (= 後付け theme 上書き)。 `<>` で重ねる。 +-- [English]: A family of font setters via theme (like ggplot's +-- theme(plot.title=element_text(...))). Takes priority over dedicated +-- setters such as vsTitleFont (a later theme override applied on top). +-- Stack them with `<>`. +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) } } + +-- | [日本語]: ★ 全 text slot 共通の font family (ggplot +-- theme(text = element_text(family=...)) 相当)。 slot 別 FontSpec の +-- 'Graphics.Hgg.Spec.fontFamily' 指定があればそちらが優先 ('Graphics.Hgg.Render.Common.mkFontTS' +-- 解決)。 slot 丸ごとの 'themeTitleFont' 等と違い preset の fontSize +-- 焼き込みを潰さない。 PNG backend は family 名を正規化してフォントファイルを +-- 解決する (不在なら既定フォント + stderr 警告)。 +-- [English]: The font family shared by all text slots (like ggplot's +-- theme(text = element_text(family=...))). A per-slot FontSpec setting +-- via 'Graphics.Hgg.Spec.fontFamily' takes priority when present +-- (resolved by 'Graphics.Hgg.Render.Common.mkFontTS'). Unlike whole-slot setters such as +-- 'themeTitleFont', it does not clobber a preset's baked-in fontSize. +-- The PNG backend normalizes the family name to resolve a font file (if +-- absent, it falls back to the default font plus a stderr warning). +themeFontFamily :: Text -> VisualSpec +themeFontFamily fam = mempty { vsThemeOverride = mempty { toFontFamily = Last (Just fam) } } + +-- | [日本語]: axis.text の回転角 (度) を theme から指定。 per-axis 'Graphics.Hgg.Spec.Axis.axisRotate' +-- 未指定時の fallback。 +-- [English]: Sets the axis.text rotation angle (degrees) from the +-- theme. A fallback used when the per-axis 'Graphics.Hgg.Spec.Axis.axisRotate' is not +-- specified. +themeAxisTextAngle :: Double -> VisualSpec +themeAxisTextAngle a = mempty { vsThemeOverride = mempty { toAxisTextAngle = Last (Just a) } } + +-- | [日本語]: axis.text の __x 軸のみ__ の回転角 (度・CCW) を theme から指定。 +-- 共通 'themeAxisTextAngle' より優先。 per-axis 'xAxis (axisRotate …)' が更に +-- 優先。 +-- [English]: Sets the rotation angle (degrees, CCW) for axis.text on +-- __the x axis only__, from the theme. Takes priority over the common +-- 'themeAxisTextAngle'; the per-axis 'xAxis (axisRotate …)' takes +-- priority over this. +themeAxisTextAngleX :: Double -> VisualSpec +themeAxisTextAngleX a = mempty { vsThemeOverride = mempty { toAxisTextAngleX = Last (Just a) } } + +-- | [日本語]: axis.text の __y 軸のみ__ の回転角 (度・CCW) を theme から指定。 +-- [English]: Sets the rotation angle (degrees, CCW) for axis.text on +-- __the y axis only__, from the theme. +themeAxisTextAngleY :: Double -> VisualSpec +themeAxisTextAngleY a = mempty { vsThemeOverride = mempty { toAxisTextAngleY = Last (Just a) } } + +-- | [日本語]: theme の x 軸 axis.text 回転角を解決 (軸別 'toAxisTextAngleX' > +-- 共通 'toAxisTextAngle')。 'Graphics.Hgg.Spec.Axis.resolveAxisAngle' の theme fallback 引数に渡す。 +-- [English]: Resolves the theme's x-axis axis.text rotation angle +-- (the per-axis 'toAxisTextAngleX' takes priority over the common +-- 'toAxisTextAngle'). Passed as the theme fallback argument to +-- 'Graphics.Hgg.Spec.Axis.resolveAxisAngle'. +axisTextAngleXOf :: ThemeOverride -> Last Double +axisTextAngleXOf o = toAxisTextAngle o <> toAxisTextAngleX o + +-- | [日本語]: theme の y 軸 axis.text 回転角を解決 (軸別 'toAxisTextAngleY' > +-- 共通 'toAxisTextAngle')。 +-- [English]: Resolves the theme's y-axis axis.text rotation angle +-- (the per-axis 'toAxisTextAngleY' takes priority over the common +-- 'toAxisTextAngle'). +axisTextAngleYOf :: ThemeOverride -> Last Double +axisTextAngleYOf o = toAxisTextAngle o <> toAxisTextAngleY o + +-- | [日本語]: facet strip.background の塗り色を指定 (= 塗り on + 色)。 +-- [English]: Sets the fill color for the facet strip.background +-- (turns fill on and sets the color). +stripFill :: Text -> VisualSpec +stripFill c = mempty { vsThemeOverride = mempty { toStripBg = Last (Just c), toShowStrip = Last (Just True) } } + +-- | [日本語]: facet strip 矩形の on/off。 +-- [English]: Toggles the facet strip rectangle on/off. +themeStrip :: Bool -> VisualSpec +themeStrip b = mempty { vsThemeOverride = mempty { toShowStrip = Last (Just b) } } + +-- | [日本語]: プリセット専用だった 4 項目の theme 上書き setter (= 全プロパティ +-- `<>` 上書き)。 `theme ThemeGrey <> titleHjust 0.5 <> legendKeyBg "#fff"` の +-- ように重ねる。 +-- [English]: Theme-override setters for four items that used to be +-- preset-only (all properties can be overridden with `<>`). Stack them +-- like `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) } + +-- | [日本語]: facet_wrap(~c, ncol=n)。 c で分割し n 列で複数行に折り返す。 +-- ncol 未使用 (= 'facet' のみ) なら従来の 1 行 N 列。 +-- [English]: facet_wrap(~c, ncol=n). Splits by c and wraps into +-- multiple rows of n columns. When ncol is unused ('facet' alone), it +-- falls back to the original single row of N columns. +facetWrap :: ColRef -> Int -> VisualSpec +facetWrap c n = mempty { vsFacet = Last (Just c), vsFacetNcol = Last (Just n) } + +-- | [日本語]: facet の列数のみ指定 (= 既存 'facet' と併用)。 +-- [English]: Specifies only the facet column count (used together with +-- the existing 'facet'). +facetCols :: Int -> VisualSpec +facetCols n = mempty { vsFacetNcol = Last (Just n) } + +-- | [日本語]: facet_wrap の scale 共有方式 (= ggplot facet_wrap(scales=))。 +-- 'FacetFixed' (既定) = 共通 domain、 'FacetFree'/'FacetFreeX'/'FacetFreeY' = +-- 該当軸を panel ごとに独立 domain に。 free な軸は全 panel に軸を表示する。 +-- 'facet' と併用。 +-- [English]: The scale-sharing mode for facet_wrap (like ggplot's +-- facet_wrap(scales=)). 'FacetFixed' (default) uses a shared domain; +-- 'FacetFree'/'FacetFreeX'/'FacetFreeY' give the corresponding axis an +-- independent domain per panel. A free axis is drawn on every panel. +-- Used together with 'facet'. +facetScales :: FacetScales -> VisualSpec +facetScales fs = mempty { vsFacetScales = Last (Just fs) } + +-- | [日本語]: facet_grid の panel サイズ配分 (= ggplot facet_grid(space=))。 +-- 'SpaceFree' 等で free 軸の track 幅/高を data 範囲に比例配分する。 通常 +-- 'facetScales' と併用。 facet_grid のみ有効。 +-- [English]: The panel-size allocation for facet_grid (like ggplot's +-- facet_grid(space=)). 'SpaceFree' etc. allocate a free axis's track +-- width/height proportionally to its data range. Usually used together +-- with 'facetScales'; only effective for facet_grid. +facetSpace :: FacetSpace -> VisualSpec +facetSpace fs = mempty { vsFacetSpace = Last (Just fs) } + +-- | [日本語]: facet_grid(row ~ col)。 row 変数の levels で行、 col 変数の +-- levels で列を作り 2 次元の cross 配置にする。 strip は上 (col 名)・右 +-- (row 名)、 軸は最下行 x・左端列 y のみ (ggplot facet_grid 既定)。 +-- [English]: facet_grid(row ~ col). Builds rows from the row variable's +-- levels and columns from the col variable's levels, giving a 2D +-- cross-tabulated layout. Strips appear at the top (col name) and right +-- (row name); axes appear only on the bottom row (x) and left column +-- (y) — ggplot's facet_grid default. +facetGrid :: ColRef -> ColRef -> VisualSpec +facetGrid rowC colC = mempty { vsFacetRow = Last (Just rowC) + , vsFacetCol = Last (Just colC) } + +-- | [日本語]: panel grid (= facet とは独立、 各 spec を独立 panel として並べる)。 +-- facet は 1 列でデータを分割するのに対し、 subplots は完全に別 spec を +-- 並べる。 DoE の MainEffects (= 複数 factor を横並び) で使う。 +-- [English]: A panel grid (independent of facet — lays out separate +-- specs as independent panels). Whereas facet splits data by a single +-- column, subplots lays out entirely distinct specs. Used for DoE's +-- MainEffects (multiple factors side by side). +subplots :: [VisualSpec] -> VisualSpec +subplots ss = mempty { vsSubplots = ss } + +-- | [日本語]: P18: subplots の 2D grid 折り返し列数。 +-- [English]: P18: the wrap column count for the subplots 2D grid. +subplotCols :: Int -> VisualSpec +subplotCols n = mempty { vsSubplotCols = Last (Just n) } + +-- | [日本語]: subplot 列の相対幅 (cowplot @plot_grid(rel_widths=)@ 相当)。 +-- 統一グリッドの列 index 順の重みで、 列数に対して不足分は 1 で埋める +-- (エラーにしない)。 @(a <-> b) <> subplotWidths [1.3, 1]@ のように使う。 +-- [English]: The relative widths of subplot columns (like cowplot's +-- @plot_grid(rel_widths=)@). Weights in the unified grid's column-index +-- order; any shortfall relative to the column count is padded with 1 +-- (not an error). Use it like +-- @(a <-> b) <> subplotWidths [1.3, 1]@. +subplotWidths :: [Double] -> VisualSpec +subplotWidths ws = mempty { vsSubplotWidths = Last (Just ws) } + +-- | [日本語]: subplot 行の相対高 (cowplot @plot_grid(rel_heights=)@ 相当)。 +-- [English]: The relative heights of subplot rows (like cowplot's +-- @plot_grid(rel_heights=)@). +subplotHeights :: [Double] -> VisualSpec +subplotHeights hs = mempty { vsSubplotHeights = Last (Just hs) } + +-- | [日本語]: subplot panel の自動タグ (cowplot @plot_grid(labels="AUTO")@ +-- 相当)。 統一グリッドの panel 列挙順に \"A\",\"B\",… ('TagUpper') \/ +-- \"a\",\"b\",… ('TagLower') \/ \"1\",\"2\",… ('TagNumeric') を各 panel の +-- 'tag' として注入する。 panel 自身の 'tag' 明示指定が優先 (個別 > 一括)。 +-- @(a <-> b) <> subplotTags TagUpper@ のように使う。 +-- [English]: Automatic subplot panel tags (like cowplot's +-- @plot_grid(labels="AUTO")@). Injects \"A\",\"B\",… ('TagUpper') / +-- \"a\",\"b\",… ('TagLower') / \"1\",\"2\",… ('TagNumeric') as each +-- panel's 'tag', in the unified grid's panel-enumeration order. A +-- panel's own explicit 'tag' takes priority (individual over bulk). Use +-- it like @(a <-> b) <> subplotTags TagUpper@. +subplotTags :: TagStyle -> VisualSpec +subplotTags s = mempty { vsSubplotTags = Last (Just s) } + +-- | [日本語]: subplot panel を __名前 (= 子 spec の 'vsTitle') で選択 + 並べ替え__。 +-- 'repeatFields' (名前リスト → panel 群) の逆方向。 列挙順がそのまま表示順に +-- なる (ggplot @scale_*_discrete(limits=)@ と同じ「選択 + 順序」 の意味論)。 +-- 一致しない名前は無視、 title 無し panel は選択時には常に落ちる。 +-- [English]: Selects and reorders subplot panels __by name (the child spec's 'vsTitle')__. +-- The reverse direction of 'repeatFields' (name +-- list → panel group). The enumeration order becomes the display order +-- directly (the same "select + order" semantics as ggplot's +-- @scale_*_discrete(limits=)@). Non-matching names are ignored, and +-- panels with no title are always dropped when selecting. +-- +-- > subplots panels <> selectPanels ["b", "a"] <> subplotCols 2 +selectPanels :: [Text] -> VisualSpec +selectPanels ws = mempty { vsPanelSel = Last (Just ws) } + +-- | [日本語]: 'vsPanelSel' を適用した後の実効 subplot 列。 描画 +-- ('Graphics.Hgg.Render.Layer.renderSubplots') の正本で、 HS 外 (canvas / PS codec) へ spec を送る側も +-- serialise 前にこれで解決すれば PS 非改修で選択が効く。 選択未指定 +-- ('Nothing') は全 panel をそのまま返す。 +-- [English]: The effective subplot list after applying 'vsPanelSel'. +-- The source of truth for rendering ('Graphics.Hgg.Render.Layer.renderSubplots'); resolving +-- through this before serializing on the side that sends the spec +-- outside HS (canvas / PS codec) makes selection work with no PS +-- changes. With no selection ('Nothing'), all panels are returned +-- as-is. +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 ] + +-- | [日本語]: 離散 x 軸の limits (= ggplot @scale_x_discrete(limits=)@)。 +-- x encoding が ColTxt の layer のカテゴリ行を __選択 + 列挙順に並べ替え__る。 +-- aes 基準なので coord_flip と直交 (flip 後も x データ軸を指す)。 +-- [English]: The limits for a discrete x axis (like ggplot's +-- @scale_x_discrete(limits=)@). For layers whose x encoding is +-- ColTxt, __selects and reorders__ the category rows by enumeration +-- order. Since it is aes-based, it is orthogonal to coord_flip (still +-- refers to the x data axis even after a flip). +scaleXDiscreteLimits :: [Text] -> VisualSpec +scaleXDiscreteLimits ws = mempty { vsXDiscreteLimits = Last (Just ws) } + +-- | [日本語]: 離散 y 軸の limits (= ggplot @scale_y_discrete(limits=)@)。 +-- 'Graphics.Hgg.Spec.Constructors.forest' は cat ラベルが y encoding なのでこちらを使う。 +-- [English]: The limits for a discrete y axis (like ggplot's +-- @scale_y_discrete(limits=)@). Since 'Graphics.Hgg.Spec.Constructors.forest' encodes its cat label +-- as y, use this one for it. +scaleYDiscreteLimits :: [Text] -> VisualSpec +scaleYDiscreteLimits ws = mempty { vsYDiscreteLimits = Last (Just ws) } + +-- | [日本語]: 離散軸 limits の解決 (正本): '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 を持てる)。 +-- [English]: The resolution (source of truth) for discrete-axis +-- limits: applies 'vsXDiscreteLimits' / 'vsYDiscreteLimits' as a +-- row-filter-plus-reorder on layers. Called at the layout / render +-- entry point (idempotent). +-- +-- * Only layers whose axis encoding is 'ColTxt' are affected (numeric +-- axis layers are unchanged). +-- * The row filter thins __all row-aligned encodings__ +-- (encX/encY/encY2/errorX/errorY/shapeBy/sizeBy/chain/linetypeBy/ +-- label/hover/color columns) using the same index (keeping them +-- consistent). +-- * A spec containing 'ColByName' (a resolver reference) is first +-- inlined via 'bakeSpec' before filtering (if limits are unspecified, +-- no baking happens either — the original path is fully unchanged). +-- * limits only affect the spec's own layers (they do not propagate to +-- subplot children — a child may have its own 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' は据え置き)。 +-- [English]: Thins every row-aligned encoding of a layer using the same +-- index column (used by 'applyDiscreteLimits'). Only inline columns +-- whose length matches @n@ (the cat column's length) are affected +-- (mismatched columns and 'ColByName' are left untouched). +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 + -- ★ Phase 62 A2/A6: quiver 成分 (row-aligned) + sub-mark (Phase 36 D2) 再帰。 + , lyEncU = reC <$> lyEncU ly + , lyEncV = reC <$> lyEncV ly + , lyOverlay = map (reindexLayer n idx) (lyOverlay 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 を値として組む方針ゆえ)。 +-- [English]: The equivalent of Vega-Lite's @repeat@: iterates a list of +-- field names, generating one view (VisualSpec) per field and laying +-- them out with 'subplots' (automatic field repetition). +-- @repeatFields ["a","b","c"] (\\f -> layer (hist f))@ produces 3 +-- panels. The column count is set via @<> subplotCols n@. Whereas +-- Vega's @repeat@ splices in fields via @{repeat: ...}@ inside the +-- encoding, this is an explicit form that passes the field name to a +-- generator function (following the approach of building specs as +-- values). +repeatFields :: [Text] -> (Text -> VisualSpec) -> VisualSpec +repeatFields fields mk = subplots (map mk fields) + +-- 以下 3 関数は mark 構築子だが 'VisualSpec' と 'layer' に依存するため +-- 'Spec.Constructors' には置けず、 top-level setter 群と同居する。 + +-- | [日本語]: Wide-form histogram (P1): 複数列を __同一 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)` +-- 相当。 +-- [English]: Wide-form histogram (P1): overlays multiple columns +-- __semi-transparently on the same plot__. +-- +-- `histogramWide [c1, c2, c3]` returns a 'VisualSpec', internally +-- turning each column into an independent layer: +-- +-- * layer i = `histogram cᵢ <> color (fromHex (palette i)) <> alpha 0.4 <> binCount 20` +-- +-- The palette is ColorBrewer Set1 (categorical 9-class; switching to +-- wong / a dedicated scheme is a future addition). The bin count is +-- __shared__ across all columns (equivalent to seaborn's +-- `multiple="layer"`), defaulting to 20. +-- +-- Corresponds to matplotlib's +-- `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) + +-- | [日本語]: 別列・別 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 に重畳する ('Graphics.Hgg.Spec.Constructors.compositeLanes' が列数を決める)。 +-- [English]: Places different columns / different marks side by side in +-- a single panel (mixed-mark). A list version of @<+>@ +-- (@distCols xs = layer (foldl1 (<+>) xs)@). Since each mark's value +-- column (encY) differs, they lay out in separate slots (columns); y +-- spans the union of all columns' ranges in a single panel (distinct +-- from subplot). Lanes are specific to 1D distribution marks +-- (box/violin/strip/swarm/raincloud). Since raincloud uses the same +-- column for every mark, they overlay into a single slot +-- ('Graphics.Hgg.Spec.Constructors.compositeLanes' determines the number of columns). +-- +-- > distCols [ boxplot "a", violin "c", boxplot "d" ] +distCols :: [Layer] -> VisualSpec +distCols [] = mempty +distCols (l : ls) = layer (foldl (<+>) l ls) + +-- | [日本語]: ★ 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 の入口で適用する。 +-- [English]: Automatically applies coord_flip to a spec that contains +-- a ridge layer and has no coord specified. Although ridge is +-- conceptually "value→x (continuous), group→y (categorical)", its +-- combinator is unified with box/violin (value=encY, group=encX via +-- groupBy). coord_flip rotates encY (value) to x and encX (group) to y +-- (the same mechanism as box-flip). Applied at the computeLayout / +-- renderToPrimitives entry point. +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 個を追加。 +-- [English]: P6: adds a single annotation. +annotate :: Annotation -> VisualSpec +annotate a = mempty { vsAnnotations = [a] } + +-- | [日本語]: P6: data 座標で text label を打つ shortcut (= 'annotTextP' の +-- PNative ラッパ)。 +-- [English]: P6: a shortcut for placing a text label in data +-- coordinates (a PNative wrapper around 'annotTextP'). +annotText :: Double -> Double -> Text -> VisualSpec +annotText x y t = annotTextP (PNative x) (PNative y) t + +-- | [日本語]: ★ 'Pos' で text を打つ (native/npc/絶対長を軸ごと混在可)。 +-- 例: @annotTextP (PNpc 0.95) (PNative 3.0) "R²"@ (右端 npc・data y)。 +-- [English]: Places text using 'Pos' (native/npc/absolute length can be +-- mixed per axis). Example: +-- @annotTextP (PNpc 0.95) (PNative 3.0) "R²"@ (npc for the right edge, +-- data for 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。 +-- [English]: P6: a shortcut for drawing an arrow in data coordinates. +annotArrow :: Double -> Double -> Double -> Double -> VisualSpec +annotArrow x1 y1 x2 y2 = + annotArrowP (PNative x1) (PNative y1) (PNative x2) (PNative y2) + +-- | [日本語]: ★ 'Pos' で arrow を引く。 +-- [English]: Draws an arrow using 'Pos'. +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 へ変換)。 +-- [English]: P6: a shortcut for drawing a rect in data coordinates +-- (converts x,y,w,h into two corner 'Pos' values). +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 + +-- | [日本語]: ★ 'Pos' 2 隅で rect を描く。 +-- 例: @annotRectP (PNpc 0.0) (PNative 1.0) (PNpc 1.0) (PNative 2.0) "grey"@ +-- (帯: x 全幅 npc・y は data 1..2)。 +-- [English]: Draws a rect from two 'Pos' corners. Example: +-- @annotRectP (PNpc 0.0) (PNative 1.0) (PNpc 1.0) (PNative 2.0) "grey"@ +-- (a band: x spans the full width in npc, y is 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。 +-- [English]: P6: a shortcut for drawing a line in data coordinates. +annotLine :: Double -> Double -> Double -> Double -> VisualSpec +annotLine x1 y1 x2 y2 = + annotLineP (PNative x1) (PNative y1) (PNative x2) (PNative y2) + +-- | [日本語]: ★ 'Pos' で line を引く。 +-- [English]: Draws a line using 'Pos'. +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%)。 +-- [English]: P13: adds a single inset (default position: top-right, +-- 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 下向き__ (= 描画系と同じ)。 +-- [English]: P13: adds an inset with a given position + size (a +-- plotArea ratio in 0..1). inX/inY use __the top-left origin with y pointing down__ +-- (matching the rendering coordinate system). +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 } ] } + +-- | [日本語]: patchwork @inset_element@ 準拠の inset 追加。 left/bottom/right/top +-- は plotArea 比率 0..1 で __左下原点・y 上向き__ (patchwork 慣例)。 内部で +-- 従来 'insetAt' (左上原点・y 下向き) へ変換するだけの薄いラッパ (非破壊)。 +-- patchwork 感覚で `inset_element(p, left, bottom, right, top)` と同じ向きに +-- 置ける。 +-- [English]: Adds an inset following patchwork's @inset_element@ +-- convention. left/bottom/right/top are a plotArea ratio in 0..1 using +-- __the bottom-left origin with y pointing up__ (the patchwork +-- convention). A thin, non-destructive wrapper that internally converts +-- to the original 'insetAt' (top-left origin, y down). Lets you place +-- insets in the same orientation as patchwork's +-- `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)。 +-- [English]: P17: specifies the categorical palette. Default = +-- hggMain (F-3). +palette :: [Text] -> VisualSpec +palette colors = mempty { vsPalette = Last (Just colors) } + +-- | [日本語]: ggplot2 hue パレット (= @scales::hue_pal()@) を選ぶ。 群数 n は +-- 描画時に決まるため sentinel を渡し、 Layout で n 展開する +-- (= 'Graphics.Hgg.Palette.ggplotHue')。 +-- [English]: Selects ggplot2's hue palette (like @scales::hue_pal()@). +-- Since the group count n is only known at draw time, a sentinel is +-- passed and expanded to n in Layout (via +-- 'Graphics.Hgg.Palette.ggplotHue'). +paletteGGplot :: VisualSpec +paletteGGplot = mempty { vsPalette = Last (Just ["__ggplot_hue__"]) } + +-- | [日本語]: P17: continuous (sequential) palette を指定。 default = +-- viridis5。 +-- [English]: P17: specifies the 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) に +-- フォールバック。 +-- [English]: A4-e: ggplot's @scale_color_manual(values=)@. Specifies a +-- category-name → color(hex) dictionary. If a 'color' (ColorByCol) +-- category name is present here, its color takes top priority. +-- Unregistered names fall back to the usual 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 補間。 +-- [English]: A4-e: ggplot's +-- @scale_color_gradient2(low,mid,high,midpoint=)@. A diverging +-- continuous palette. For 'colorContinuousBy' (ColorByContinuous), +-- fixes midpoint at the center (0.5) and independently normalizes +-- lo..mid to [0,0.5] and mid..hi to [0.5,1] for 3-stop interpolation. +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))@。 'Graphics.Hgg.Spec.Constructors.sizeBy' +-- (continuous size aesthetic) の半径 px 範囲を指定 (default (3,10))。 +-- sizeBy 未使用なら無影響。 +-- [English]: A4-e: ggplot's @scale_size(range=c(min,max))@. Specifies +-- the radius range in px for 'Graphics.Hgg.Spec.Constructors.sizeBy' (the continuous size aesthetic), +-- default (3,10). Has no effect if sizeBy is unused. +scaleSize :: Double -> Double -> VisualSpec +scaleSize lo hi = mempty { vsSizeRange = Last (Just (lo, hi)) } + +-- | [日本語]: P8: 凡例を有効化 (= 既定: 右側)。 +-- [English]: P8: enables the legend (default: right side). +legend :: VisualSpec +legend = mempty { vsLegend = Last (Just defaultLegendSpec) } + +-- | [日本語]: P8: 凡例を抑制。 +-- [English]: P8: suppresses the legend. +legendOff :: VisualSpec +legendOff = mempty + { vsLegend = Last (Just (LegendSpec LegendNone mempty)) } + +-- | [日本語]: P8: 凡例位置を指定。 +-- [English]: P8: specifies the legend position. +legendPos :: LegendPosition -> VisualSpec +legendPos pos = mempty { vsLegend = Last (Just (LegendSpec pos mempty)) } + +-- | [日本語]: 色凡例を非表示 (= ggplot @guides(color="none")@)。 この系では +-- 凡例は色 (color/fill) のみなので 'legendOff' と同義。 ggplot 慣習名の別名 +-- として提供。 +-- [English]: Hides the color legend (like ggplot's +-- @guides(color="none")@). Since this system's legend is color/fill +-- only, it is synonymous with 'legendOff'. Provided as an alias using +-- ggplot's conventional name. +guideColorNone :: VisualSpec +guideColorNone = legendOff + +-- | [日本語]: 凡例キーの表示順を逆に (= ggplot +-- @guide_legend(reverse=TRUE)@)。 各キーの色は固定のまま順序のみ反転。 +-- 位置設定 ('legend'/'legendPos') と独立合成可。 +-- [English]: Reverses the display order of legend keys (like ggplot's +-- @guide_legend(reverse=TRUE)@). Each key's color stays fixed; only the +-- order is reversed. Composes independently of the position setting +-- ('legend'/'legendPos'). +legendReverse :: VisualSpec +legendReverse = mempty { vsLegendReverse = Last (Just True) } + +-- | [日本語]: 縦凡例 (Right/Inside) の列数 (= ggplot +-- @guide_legend(ncol=)@)。 +-- [English]: The column count for a vertical legend (Right/Inside), +-- like ggplot's @guide_legend(ncol=)@. +legendNcol :: Int -> VisualSpec +legendNcol n = mempty { vsLegendNcol = Last (Just n) } + +-- | [日本語]: 横凡例 (Bottom) の行数 (= ggplot @guide_legend(nrow=)@)。 +-- [English]: The row count for a horizontal legend (Bottom), like +-- ggplot's @guide_legend(nrow=)@. +legendNrow :: Int -> VisualSpec +legendNrow n = mempty { vsLegendNrow = Last (Just n) } + +-- | [日本語]: 図サイズ ('Length')。 bare 数値リテラルは @Num Length@ 経由で +-- __pt__ (@width 600@ = 600pt)。 mm で書きたいときは 'widthMm' / 'heightMm'、 +-- その他の単位は @width (7 *~ inch)@ / 'widthUnit' を使う。 +-- [English]: The figure size ('Length'). A bare numeric literal is +-- __pt__ via @Num Length@ (@width 600@ = 600pt). To write in mm, use +-- 'widthMm' / 'heightMm'; for other units use @width (7 *~ inch)@ / +-- 'widthUnit'. +width, height :: Length -> VisualSpec +width = widthUnit +height = heightUnit + +-- | [日本語]: 図サイズ (mm 直接)。 @widthMm 180@ = 180mm。 A4 で 'width' の +-- bare が pt に変わったので、 従来の mm 指定はこちらへ移行する。 +-- [English]: The figure size, directly in mm. @widthMm 180@ = 180mm. +-- Since A4 changed the bare value of 'width' to pt, migrate previous mm +-- specifications to this instead. +widthMm, heightMm :: Double -> VisualSpec +widthMm w = widthUnit (w *~ mm) +heightMm h = heightUnit (h *~ mm) + +-- | [日本語]: 図サイズ (単位明示)。 @widthUnit (7 *~ inch)@ / +-- @widthUnit (800 *~ px)@。 +-- [English]: The figure size with an explicit unit. Examples: +-- @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 は無視。 +-- [English]: The rendering dpi (px backends use px = pt × dpi/72). +-- Example: @plot <> dpi 300@. Default 96; ignored by PDF. +dpi :: Double -> VisualSpec +dpi d = mempty { vsDpi = Last (Just d) } + +-- | [日本語]: coord_fixed(ratio) 相当。 panel の 高/幅 比 (aspect) を固定。 +-- 指定時は可用域内で aspect を保つ最大 panel を取り中央寄せ (ggplot +-- Coord$aspect)。 +-- [English]: The equivalent of coord_fixed(ratio). Fixes the panel's +-- height/width ratio (aspect). When specified, takes the largest panel +-- that preserves the aspect within the available area and centers it +-- (ggplot's Coord$aspect). +aspectRatio :: Double -> VisualSpec +aspectRatio a = mempty { vsAspect = Last (Just a) } + +-- | [日本語]: coord_flip。 x/y 軸を入れ替える (= 横棒グラフ等)。 ggplot +-- coord_flip() 相当。 +-- [English]: coord_flip. Swaps the x/y axes (used for horizontal bar +-- charts, etc.). Equivalent to ggplot's coord_flip(). +-- +-- > bar "cat" "y" `layer'` purePlot <> coordFlip +coordFlip :: VisualSpec +coordFlip = mempty { vsCoord = Last (Just CoordFlip) } + +-- | [日本語]: 極座標 (= ggplot @coord_polar(theta="x")@)。 データ x を角度 +-- (0..2π、 上始点・時計回り)、 データ y を半径に写す。 line/point は +-- radar / spiral に。 +-- [English]: Polar coordinates (like ggplot's +-- @coord_polar(theta="x")@). Maps data x to angle (0..2π, starting at +-- the top, clockwise) and data y to radius. Turns line/point marks into +-- a radar / spiral shape. +coordPolar :: VisualSpec +coordPolar = mempty { vsCoord = Last (Just (CoordPolarX defaultPolarOpts)) } + +-- | [日本語]: 極座標 (= ggplot @coord_polar(theta="y")@)。 データ y を角度、 +-- データ x を半径に写す。 単一カテゴリの stacked bar と併せると円グラフに +-- なる。 +-- [English]: Polar coordinates (like ggplot's +-- @coord_polar(theta="y")@). Maps data y to angle and data x to radius. +-- Combined with a single-category stacked bar, it becomes a pie chart. +coordPolarY :: VisualSpec +coordPolarY = mempty { vsCoord = Last (Just (CoordPolarY defaultPolarOpts)) } + +-- | [日本語]: 極座標 (theta="x") を開始角・回転方向つきで (= ggplot +-- @coord_polar(theta="x", start=, direction=)@)。 @start@ = θ=0 の向き +-- (rad、 0 = 真上)、 @direction@ = 回転方向の符号 (+1 = 時計回り \/ 既定、 +-- -1 = 反時計回り)。 'coordPolar' は @coordPolarWith 0 1@ と等価。 +-- [English]: Polar coordinates (theta="x") with a start angle and direction +-- (like ggplot's @coord_polar(theta="x", start=, direction=)@). @start@ is +-- the direction of theta=0 (radians, 0 = up), @direction@ the sign of the +-- rotation (+1 clockwise / default, -1 counter-clockwise). 'coordPolar' +-- equals @coordPolarWith 0 1@. +coordPolarWith :: Double -> Double -> VisualSpec +coordPolarWith start dir = + mempty { vsCoord = Last (Just (CoordPolarX (PolarOpts start dir))) } + +-- | [日本語]: 極座標 (theta="y") を開始角・回転方向つきで。 'coordPolarWith' の +-- theta="y" 版 (= ggplot @coord_polar(theta="y", start=, direction=)@)。 +-- [English]: Polar coordinates (theta="y") with a start angle and direction; +-- the theta="y" counterpart of 'coordPolarWith' (like ggplot's +-- @coord_polar(theta="y", start=, direction=)@). +coordPolarYWith :: Double -> Double -> VisualSpec +coordPolarYWith start dir = + mempty { vsCoord = Last (Just (CoordPolarY (PolarOpts start dir))) } + +-- | [日本語]: 三角座標 (= 組成データ用の ternary plot)。 3 成分 (a,b,c) を正 +-- 三角形の 3 頂点へ写す。 ★ Phase 64 §3 (A11-A13) で投影/grid を実装する。 +-- A10 時点では 'Coord' の枝と JSON codec のみが揃った状態 (render は未接続)。 +-- [English]: Ternary coordinates (a ternary plot for compositional data), +-- mapping three components (a,b,c) to the corners of an equilateral +-- triangle. Projection/grid are implemented in Phase 64 §3 (A11-A13); at A10 +-- only the 'Coord' constructor and JSON codec exist (rendering not wired up). +coordTernary :: VisualSpec +coordTernary = mempty { vsCoord = Last (Just (CoordTernary defaultTernaryOpts)) } + +-- | [日本語]: ★ Phase 69 A4: 三角座標を向きつきで指定する ('coordPolarWith' の対)。 +-- @coordTernaryWith clockwise rotate@ で、 clockwise=True なら左下↔右下 を反転 +-- (巡回方向を逆に)、 rotate=0/120/240 でどの成分を上頂点に置くかを回す。 +-- 'coordTernary' は @coordTernaryWith False 0@ と等価。 通常は encZ から coord が +-- 推論されるので、 本 setter は向きを変えたいときだけ足せばよい。 +-- [English]: ★ Phase 69 A4: ternary coordinates with an explicit orientation +-- (the counterpart of 'coordPolarWith'). @coordTernaryWith clockwise rotate@: +-- clockwise=True flips bottom-left ↔ bottom-right (reversing the precession), +-- rotate 0/120/240 cycles which component sits at the top vertex. 'coordTernary' +-- equals @coordTernaryWith False 0@. Since the coord is normally inferred from +-- encZ, add this setter only when you want to change the orientation. +coordTernaryWith :: Bool -> Int -> VisualSpec +coordTernaryWith clockwise rotate = + mempty { vsCoord = Last (Just (CoordTernary (TernaryOpts clockwise rotate))) } + +-- | [日本語]: X 軸反転 (= ggplot @scale_x_reverse()@)。 大値が左、 小値が右へ。 +-- coord_flip と独立合成可。 +-- [English]: Reverses the X axis (like ggplot's @scale_x_reverse()@): +-- large values move to the left, small values to the right. Composes +-- independently of coord_flip. +-- +-- > scatter "x" "y" `layer'` purePlot <> reverseX +reverseX :: VisualSpec +reverseX = mempty { vsReverseX = Last (Just True) } + +-- | [日本語]: Y 軸反転 (= ggplot @scale_y_reverse()@)。 大値が下、 小値が上へ。 +-- [English]: Reverses the Y axis (like ggplot's @scale_y_reverse()@): +-- large values move to the bottom, small values to the top. +reverseY :: VisualSpec +reverseY = mempty { vsReverseY = Last (Just True) } + +-- | [日本語]: X 軸 zoom (= ggplot @coord_cartesian(xlim=c(lo,hi))@)。 +-- 'Graphics.Hgg.Spec.Axis.axisRange' (= scale limits、 範囲外データを切る) と異なり __データを落とさず__ +-- 表示範囲だけを [lo,hi] に上書きする。 stat (regression/density +-- 等) は全データから計算され、 範囲外の glyph は panel に clip される。 +-- numeric 軸のみ有効。 +-- [English]: X-axis zoom (like ggplot's +-- @coord_cartesian(xlim=c(lo,hi))@). Unlike 'Graphics.Hgg.Spec.Axis.axisRange' (scale limits, +-- which drops out-of-range data), this __keeps all data__ and only +-- overrides the display range to [lo,hi]. Stats (regression/density, +-- etc.) are still computed from the full data, and out-of-range glyphs +-- are clipped to the panel. Only effective for numeric axes. +coordCartesianX :: Double -> Double -> VisualSpec +coordCartesianX lo hi = mempty { vsCoordXLim = Last (Just (lo, hi)) } + +-- | [日本語]: Y 軸 zoom (= ggplot @coord_cartesian(ylim=c(lo,hi))@)。 +-- [English]: Y-axis zoom (like ggplot's +-- @coord_cartesian(ylim=c(lo,hi))@). +coordCartesianY :: Double -> Double -> VisualSpec +coordCartesianY lo hi = mempty { vsCoordYLim = Last (Just (lo, hi)) } + +-- | [日本語]: X/Y 同時 zoom (= ggplot @coord_cartesian(xlim=,ylim=)@)。 +-- 'coordCartesianX' と 'coordCartesianY' の合成。 +-- [English]: Simultaneous X/Y zoom (like ggplot's +-- @coord_cartesian(xlim=,ylim=)@). A combination of 'coordCartesianX' +-- and 'coordCartesianY'. +coordCartesian :: Double -> Double -> Double -> Double -> VisualSpec +coordCartesian xlo xhi ylo yhi = coordCartesianX xlo xhi <> coordCartesianY ylo yhi + +-- | [日本語]: 軸 (X / Y) 設定の合成 helper。 +-- [English]: A helper for composing axis (X / Y) settings. +-- +-- > 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 を有効化)。 +-- [English]: P5: the AxisSpec for the right-side Y axis (enables dual +-- Y). +yAxisRight :: AxisSpec -> VisualSpec +yAxisRight a = mempty { vsYAxisRight = Last (Just a) } + +-- | [日本語]: P5: layer を右側 Y 軸に紐付ける。 +-- [English]: P5: binds a layer to the right-side Y axis. +toRightY :: Layer +toRightY = mempty { lyYAxisSide = Last (Just YAxisRight) } + +-- | [日本語]: P5: layer を左側 Y 軸に紐付ける (= default なので通常不要)。 +-- [English]: P5: binds a layer to the left-side Y axis (usually +-- unnecessary since it is the default). +toLeftY :: Layer +toLeftY = mempty { lyYAxisSide = Last (Just YAxisLeft) } + +-- | [日本語]: 参照線を 1 本追加 (= 重ねがけで複数本)。 +-- [English]: Adds a single reference line (stack multiple by layering). +-- +-- > example = ... <> refLine RefIdentity <> refLine (RefHorizontalAt 0) +refLine :: ReferenceLine -> VisualSpec +refLine rl = mempty { vsRefLines = [rl] } + +-- | [日本語]: shortcut。 +-- [English]: A shortcut. +refIdentity :: VisualSpec +refIdentity = refLine RefIdentity +refHorizontal :: Double -> VisualSpec +refHorizontal y = refLine (RefHorizontalAt y) +refVertical :: Double -> VisualSpec +refVertical x = refLine (RefVerticalAt x) + +-- | [日本語]: scatter の周辺に X/Y 両方の histogram。 +-- [English]: Adds both X and Y marginal histograms around a scatter. +marginal :: VisualSpec +marginal = mempty { vsMarginal = Last (Just (defaultMarginalSpec { msShowX = True, msShowY = True })) } + +-- | [日本語]: 周辺 histogram X 軸のみ。 +-- [English]: Only the X-axis marginal histogram. +marginalX :: VisualSpec +marginalX = mempty { vsMarginal = Last (Just (defaultMarginalSpec { msShowX = True })) } + +-- | [日本語]: 周辺 histogram Y 軸のみ。 +-- [English]: Only the Y-axis marginal histogram. marginalY :: VisualSpec marginalY = mempty { vsMarginal = Last (Just (defaultMarginalSpec { msShowY = True })) } diff --git a/src/Graphics/Hgg/Spec/Theme.hs b/src/Graphics/Hgg/Spec/Theme.hs --- a/src/Graphics/Hgg/Spec/Theme.hs +++ b/src/Graphics/Hgg/Spec/Theme.hs @@ -1,14 +1,21 @@ -- | -- Module : Graphics.Hgg.Spec.Theme --- Description : theme preset (ThemeName) + series palette + element 単位 override +-- Description : theme presets (ThemeName), series palettes, and per-element overrides -- 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 する。 --- 挙動・出力は完全に不変。 +-- [日本語]: '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 する。 +-- 挙動・出力は完全に不変。 +-- +-- [English]: Split out from 'Graphics.Hgg.Spec' during a module split. +-- Holds the theme name ('ThemeName'), the series palette for each preset, +-- named palettes (Okabe-Ito etc.), and per-element overrides +-- ('ThemeOverride', equivalent to ggplot's theme(element_*)). The public +-- API is still re-exported by 'Graphics.Hgg.Spec' (the facade) as before. +-- Behavior and output are entirely unchanged. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} @@ -20,6 +27,8 @@ , okabeIto, tolBright, brewerSet2, brewerDark2 -- * element 単位 override , ThemeOverride(..) + , TickDir(..) + , Margin(..) ) where import Data.Aeson (FromJSON, ToJSON) @@ -27,16 +36,34 @@ import Data.Text (Text) import GHC.Generics (Generic, Generically (..)) -import Graphics.Hgg.Spec.Decoration (FontSpec) +import Graphics.Hgg.Spec.Decoration (FontSpec, LegendPosition) --- | 描画 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 で沈み防止)。 +-- | [日本語]: 描画 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 で沈み防止)。 +-- +-- [English]: A rendering theme (referenced by name; carries no functions, +-- so it is JSON-serializable). Adds ggplot's standard preset (ThemeGrey) +-- plus the brand themes. +-- +-- * ThemeGrey = ggplot's default theme_grey (grey #EBEBEB +-- background, white grid, no border, no axis line) +-- * ThemeNoir = brand theme (dark, elegant, cool accents; +-- kept around from an earlier competition entry) +-- * ThemeLumen = brand theme (white-based, deep accent +-- colors, clean; kept around from an earlier competition entry) +-- * ThemeParchment = the official parchment-based light theme. +-- Colors come from cream/gold/ink + the Universal Categorical +-- series. +-- * ThemeParchmentDark = the dark variant of the same theme (dark +-- umber ink background; series colors use shade 300 to avoid +-- getting lost against it) data ThemeName = ThemeDefault | ThemeMinimal | ThemeDark | ThemeLight | ThemeGrey | ThemeBW | ThemeClassic | ThemeVoid | ThemeLinedraw | ThemeNoir | ThemeLumen @@ -46,96 +73,307 @@ instance ToJSON ThemeName instance FromJSON ThemeName --- | preset ごとの既定 series palette (= palette 未指定時に使う色順)。 --- ggplot 系 preset は従来通り hggMain (既定配色)、 ブランド 3 種は専用 series。 --- Layout.computeLayout の catPal 既定がこれを参照する (= palette 指定で上書き可)。 +-- | [日本語]: preset ごとの既定 series palette (= palette 未指定時に使う色順)。 +-- ggplot 系 preset は従来通り hggMain (既定配色)、 ブランド 3 種は専用 series。 +-- Layout.computeLayout の catPal 既定がこれを参照する (= palette 指定で上書き可)。 +-- [English]: The default series palette for each preset (the color order +-- used when no palette is specified). ggplot-family presets use +-- hggMain (the default color scheme) as before; the three brand themes +-- use their own dedicated series. Layout.computeLayout's default catPal +-- refers to this (overridable by specifying a 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、 他は既定配色)。 + -- [日本語]: Parchment 明: 案3 (#1 = White Rabbit Inner Ear Pink #F0A5A0、 + -- #3 = Dormouse 系 Warm Yellow #E8D58A、 他は既定配色)。 2026-06-02 確定。 + -- [English]: Parchment (light): option 3 (#1 = White Rabbit + -- Inner Ear Pink #F0A5A0, #3 = Dormouse-family Warm Yellow #E8D58A, the + -- rest is the default color scheme). Finalized 2026-06-02. ThemeParchment -> canvasPal - -- 暗版 (Charcoal 背景): 案3 の暗色 (purple/teal/rose/wine) を明度調整し沈み防止。色相・順序は維持。 + -- [日本語]: 暗版 (Charcoal 背景): 案3 の暗色 (purple/teal/rose/wine) を明度調整し沈み防止。色相・順序は維持。 + -- [English]: Dark variant (charcoal background): brightness-adjusted the + -- dark colors from option 3 (purple/teal/rose/wine) to avoid getting + -- lost against the background, while keeping hue and order unchanged. 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** を返す。 + -- [日本語]: 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 で展開する。 + -- Bridge.resolveGrouped が @ggplotHue@ n で展開する。 + -- [English]: The default-family presets (grey/default/minimal/light/dark) + -- follow ggplot2's default scales::hue_pal(). Rather than a fixed 7-color + -- set, this returns a __hue sentinel that depends on the group count n__. + -- ggplot recomputes hue_pal()(n) for every discrete color scale, so a + -- group count of 3 gives red/green/blue, 4 gives a different set, and so + -- on. With a fixed 7-color set, a group count of 3 would still take + -- indices 0,1,2 (red/gold/green), which disagreed with R4DS. Layout.catPal + -- / Bridge.resolveGrouped expand the sentinel via @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") と同一)。 +-- | [日本語]: 学術向け named series palette。 theme とは独立に `palette <名>` で使う (colorblind-safe 中心)。 +-- Okabe-Ito (Okabe & Ito 2008、 色覚バリアフリー定番、 R palette.colors("Okabe-Ito") と同一)。 +-- [English]: An academic-style named series palette, used independently of +-- the theme via `palette <name>` (mostly colorblind-safe). Okabe-Ito +-- (Okabe & Ito 2008, a colorblind-accessibility standard, identical to R's +-- palette.colors("Okabe-Ito")). okabeIto :: [Text] okabeIto = [ "#000000", "#E69F00", "#56B4E9", "#009E73" , "#F0E442", "#0072B2", "#D55E00", "#CC79A7" ] --- | Paul Tol bright (7 色、 色覚バリアフリー)。 +-- | [日本語]: Paul Tol bright (7 色、 色覚バリアフリー)。 +-- [English]: Paul Tol bright (7 colors, colorblind-accessible). tolBright :: [Text] tolBright = [ "#4477AA", "#EE6677", "#228833", "#CCBB44" , "#66CCEE", "#AA3377", "#BBBBBB" ] --- | ColorBrewer Set2 (8 色、 柔らかい定性)。 +-- | [日本語]: ColorBrewer Set2 (8 色、 柔らかい定性)。 +-- [English]: ColorBrewer Set2 (8 colors, soft qualitative palette). brewerSet2 :: [Text] brewerSet2 = [ "#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3" , "#A6D854", "#FFD92F", "#E5C494", "#B3B3B3" ] --- | ColorBrewer Dark2 (8 色、 濃いめ定性、 白背景向き)。 +-- | [日本語]: ColorBrewer Dark2 (8 色、 濃いめ定性、 白背景向き)。 +-- [English]: ColorBrewer Dark2 (8 colors, deeper qualitative palette, +-- suited to a white background). brewerDark2 :: [Text] brewerDark2 = [ "#1B9E77", "#D95F02", "#7570B3", "#E7298A" , "#66A61E", "#E6AB02", "#A6761D", "#666666" ] +-- | [日本語]: 軸目盛線 (tick mark) の向き。 'TickOut' = panel 外向き +-- (ggplot 既定)、 'TickIn' = panel 内向き (base R / 金融チャート系)、 +-- 'TickBoth' = 両向き。 JSON は nullary constructor 名 (canvas Codec と同形)。 +-- [English]: The direction of the axis tick marks. 'TickOut' points +-- outward from the panel (ggplot's default), 'TickIn' points inward +-- (base R / financial-chart style), and 'TickBoth' points both ways. The +-- JSON encoding uses the nullary constructor name (matching the canvas +-- codec's shape). +data TickDir = TickOut | TickIn | TickBoth + deriving (Show, Eq, Generic) + +instance ToJSON TickDir +instance FromJSON TickDir + +-- | [日本語]: 図の外周余白 (pt)。 フィールド順は ggplot @margin(t, r, b, l)@ +-- と同じ。 'ThemeOverride' の @toPlotMargin@ に指定すると自動算出の外周分 +-- (各辺 half_line = 5.5pt) を __置き換える__ (加算ではない)。 +-- [English]: The outer margin of the figure (pt). Field order matches +-- ggplot's @margin(t, r, b, l)@. When specified via the @toPlotMargin@ +-- field of 'ThemeOverride', it __replaces__ the automatically computed +-- outer margin +-- (each side's half_line = 5.5pt) rather than adding to it. +data Margin = Margin + { marTop :: !Double + , marRight :: !Double + , marBottom :: !Double + , marLeft :: !Double + } deriving (Show, Eq, Generic) + +instance ToJSON Margin +instance FromJSON Margin + -- =========================================================================== --- Phase 9 A-2: element 単位 theme override (ggplot theme(element_*) 相当) +-- element 単位 theme override (ggplot theme(element_*) 相当) -- =========================================================================== --- | preset (ThemeName) に要素単位で上書きを合成する override。 各 field は Last で --- 「指定があれば優先」。 'resolveTheme' (Render) が preset palette に合成する。 --- 全 field Monoid なので setter を `<>` で重ねられる (ggplot の theme() 加算と同様)。 +-- | [日本語]: preset (ThemeName) に要素単位で上書きを合成する override。 各 field は Last で +-- 「指定があれば優先」。 @resolveTheme@ (Render) が preset palette に合成する。 +-- 全 field Monoid なので setter を `<>` で重ねられる (ggplot の theme() 加算と同様)。 +-- [English]: An override that composes element-by-element adjustments onto +-- a preset (ThemeName). Each field is a Last, meaning "prefer it if +-- specified". @resolveTheme@ (Render) composes it onto the preset palette. +-- Since every field is a Monoid, setters can be stacked with `<>` (the same +-- way ggplot's theme() calls add up). data ThemeOverride = ThemeOverride { toPlotBg :: !(Last Text) -- plot.background fill + -- [日本語]: ★ Phase 63 A18: plot.background を塗るか (False = 塗らない = 透過。 + -- cowplot は rect fill NA = 透過なので合成 preset が False を焼き込む)。 + -- [English]: Whether to fill plot.background (False = don't fill, i.e. + -- transparent; since cowplot's rect fill NA means transparent, the + -- composed preset bakes in False). + , toShowBackground :: !(Last Bool) , toPanelBg :: !(Last Text) -- panel.background fill , toShowPanel :: !(Last Bool) -- panel 矩形を塗るか , toGridColor :: !(Last Text) -- panel.grid colour - , toShowGrid :: !(Last Bool) -- panel.grid on/off + , toShowGrid :: !(Last Bool) -- panel.grid on/off (= major/minor 両方の糖衣) + -- [日本語]: ★ Phase 63 A2: grid major/minor の個別 on/off (cowplot theme_minimal_grid 等)。 + -- 優先順は 個別 (これ) > 一括 toShowGrid > preset (@resolveTheme@ で解決)。 + -- [English]: Individual on/off for grid major/minor (cowplot's + -- theme_minimal_grid etc.). Priority is: individual (this) > the blanket + -- toShowGrid > the preset (resolved by @resolveTheme@). + , toShowGridMajor :: !(Last Bool) -- panel.grid.major on/off + , toShowGridMinor :: !(Last Bool) -- panel.grid.minor 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/...) 相当)。 + -- [日本語]: ★ Phase 9 A-3: 文字 theme 統合 (ggplot theme(text/plot.title/axis.title/...) 相当)。 -- 各 slot の FontSpec を theme から差し替え可能に。 優先順位は - -- override (これ) > font setter (vsTitleFont 等) > preset 既定 ('mkFontTS')。 + -- override (これ) > font setter (vsTitleFont 等) > preset 既定 (@mkFontTS@)。 + -- [English]: Unified text theming (equivalent to ggplot's + -- theme(text/plot.title/axis.title/...)). Lets the FontSpec of each slot + -- be swapped out from the theme. Priority is: override (this) > font + -- setters (vsTitleFont etc.) > the preset default (@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。 + -- [日本語]: axis.text の回転角 (度・CCW)。 per-axis @axisRotate@ 未指定時の fallback。 -- 'toAxisTextAngle' = x/y 共通既定、 'toAxisTextAngleX'/'toAxisTextAngleY' = 軸別上書き - -- (Phase 50 A3・軸別 > 共通 の優先。 'axisTextAngleXOf'/'axisTextAngleYOf' で解決)。 + -- (Phase 50 A3・軸別 > 共通 の優先。 @axisTextAngleXOf@/@axisTextAngleYOf@ で解決)。 + -- [English]: The rotation angle of axis.text (degrees, CCW). The + -- fallback used when the per-axis @axisRotate@ is not specified. + -- 'toAxisTextAngle' is the shared x/y default; 'toAxisTextAngleX' / + -- 'toAxisTextAngleY' are the per-axis overrides (per-axis takes priority + -- over shared; resolved by @axisTextAngleXOf@/@axisTextAngleYOf@). , toAxisTextAngle :: !(Last Double) , toAxisTextAngleX :: !(Last Double) , toAxisTextAngleY :: !(Last Double) - -- ★ Phase 9 A-4: strip.background (facet strip の灰矩形)。 + -- [日本語]: ★ Phase 9 A-4: strip.background (facet strip の灰矩形)。 + -- [English]: strip.background (the grey rectangle behind facet strips). , toStripBg :: !(Last Text) -- strip.background fill , toShowStrip :: !(Last Bool) -- strip 矩形を塗るか - -- ★ Phase 43 A4: プリセット専用だった 4 項目に上書き口を追加 (= 全プロパティ `<>` 上書き - -- 可能に)。対応 'ThemePalette' field = tpTitleHjust / tpTitleColor / tpTickLineColor / + -- [日本語]: ★ Phase 43 A4: プリセット専用だった 4 項目に上書き口を追加 (= 全プロパティ `<>` 上書き + -- 可能に)。対応 @ThemePalette@ field = tpTitleHjust / tpTitleColor / tpTickLineColor / -- tpLegendKeyBg。generic 導出なので field 追加のみで instance は自動追従。 + -- [English]: Added override hooks for four fields that used to be + -- preset-only (so every property can now be overridden with `<>`). + -- The corresponding @ThemePalette@ fields are tpTitleHjust / + -- tpTitleColor / tpTickLineColor / tpLegendKeyBg. Since the instance is + -- generically derived, adding a field is all that's needed and the + -- instance follows automatically. , 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 背景塗り色 ("" なら塗らない) + -- [日本語]: ★ Phase 63 A3: legend.position を theme に焼き込む口 (cowplot 自作 theme 用)。 + -- 優先順は 図レベル vsLegend (legendPos setter) > これ > 既定 LegendRightCenter + -- (@effectiveLegendPos@ で解決。 ggplot の theme() と個別指定の関係に同じ)。 + -- [English]: A hook for baking legend.position into the theme (for + -- cowplot-style custom themes). Priority is: the figure-level vsLegend + -- (the legendPos setter) > this > the default LegendRightCenter + -- (resolved by @effectiveLegendPos@; the same relationship as ggplot's + -- theme() versus per-call specification). + , toLegendPos :: !(Last LegendPosition) -- legend.position + -- [日本語]: ★ Phase 63 A4: 軸目盛線の長さ (pt)・向き (ggplot axis.ticks.length 相当)。 + -- tick 長は軸ラベル/マージン位置に波及するため、 palette でなく + -- Layout の @effectiveTickLength@/@effectiveTickDir@ が解決し + -- computeLayout (予約) と Render.tickMarks (描画) の単一情報源になる。 + -- 未指定時は ggTickLen (2.75pt) / TickOut (= 従来挙動と同一)。 + -- [English]: The length (pt) and direction of the axis tick marks + -- (equivalent to ggplot's axis.ticks.length). Since tick length + -- affects axis-label and margin placement, this is resolved not by the + -- palette but by Layout's @effectiveTickLength@/@effectiveTickDir@, + -- making them the single source of truth for computeLayout (reserving + -- space) and Render.tickMarks (drawing). When unspecified, defaults to + -- ggTickLen (2.75pt) / TickOut (identical to the previous behavior). + , toTickLength :: !(Last Double) -- axis.ticks.length (pt) + , toTickDir :: !(Last TickDir) -- 目盛線の向き (外/内/両) + -- [日本語]: ★ Phase 63 A5: 図の外周余白 (ggplot plot.margin 相当)。 指定時は自動算出の + -- 外周分 (各辺 ggHalfLine) を置き換える。 軸ラベル・title 帯・凡例などの + -- 内側予約は従来どおり自動。 Layout の @effectivePlotMargin@ が解決する。 + -- [English]: The outer margin of the figure (equivalent to ggplot's + -- plot.margin). When specified, it replaces the automatically + -- computed outer margin (each side's ggHalfLine). Inner reservations + -- such as axis labels, the title band, and the legend remain + -- automatic as before. Resolved by Layout's @effectivePlotMargin@. + , toPlotMargin :: !(Last Margin) -- plot.margin (t/r/b/l、 pt) + -- [日本語]: ★ Phase 63 A12: base font size (pt、 ggplot base_size 相当)。 各 slot の既定 + -- font size はこれからの相対倍率 (title ×1.2 / axis.title ×1 / axis.text ×0.8 / + -- legend.title ×1 / legend.text ×0.8) で派生する。 優先順 = 個別 theme*Font + -- (fsSize) > これによる base 派生 > 既定 11 (theme_grey base_size)。 + -- font size は layout 予約 (titleSize 等) に波及するため Layout の + -- @effectiveBaseFontSize@ が解決し、 computeLayout (予約) と + -- Render.mkFontTS (描画) の単一情報源になる。 + -- [English]: The base font size (pt, equivalent to ggplot's base_size). + -- Each slot's default font size is derived from this via a relative + -- multiplier (title x1.2 / axis.title x1 / axis.text x0.8 / + -- legend.title x1 / legend.text x0.8). Priority is: the per-slot + -- theme*Font (fsSize) > the base-derived value > the default 11 + -- (theme_grey's base_size). Since font size affects layout + -- reservations (titleSize etc.), Layout's @effectiveBaseFontSize@ + -- resolves it, making it the single source of truth for computeLayout + -- (reserving space) and Render.mkFontTS (drawing). + , toBaseFontSize :: !(Last Double) -- base font size (pt) + -- [日本語]: ★ Phase 63 A19: axis.text (目盛ラベル文字) / axis.title (軸タイトル) の表示。 + -- False = ggplot element_blank 相当 (tick 線の有無は toTickLength と独立)。 + -- 表示 off は margin 予約に波及するため Layout の @effectiveShowAxisText@ / + -- @effectiveShowAxisTitle@ が解決し、 computeLayout (予約) と Render + -- (tickMarks/labels の描画) の単一情報源になる。 既定は ThemeVoid のみ False + -- (ggplot theme_void = axis.text/axis.title とも element_blank)、 他 preset True。 + -- [English]: Visibility of axis.text (tick labels) / axis.title (axis + -- titles). False is equivalent to ggplot's element_blank (independent + -- of whether tick marks themselves are shown via toTickLength). Since + -- turning display off affects margin reservations, Layout's + -- @effectiveShowAxisText@ / @effectiveShowAxisTitle@ resolve it, making + -- them the single source of truth for computeLayout (reserving space) + -- and Render (drawing tickMarks/labels). Defaults to False only for + -- ThemeVoid (ggplot's theme_void makes both axis.text/axis.title + -- element_blank), True for every other preset. + , toShowAxisText :: !(Last Bool) -- axis.text on/off + , toShowAxisTitle :: !(Last Bool) -- axis.title on/off + -- [日本語]: ★ Phase 63 A19.5: 凡例キー 1 辺 (pt、 ggplot legend.key.size 相当)。 キーの + -- 行 pitch = キー辺なので凡例の行間もこれで決まる。 cowplot は全 preset で + -- 1.1 × font_size を明示上書きする (既定 = 1.2 lines = 1.2 × base × 1.3133)。 + -- 凡例幅/高さの margin 予約に波及するため Layout の @effectiveLegendKeyW@ が解決。 + -- [English]: The side length (pt) of a single legend key (equivalent + -- to ggplot's legend.key.size). Since a key's row pitch equals its + -- side length, this also determines the legend's line spacing. + -- cowplot explicitly overrides this to 1.1 x font_size for every + -- preset (the default is 1.2 lines = 1.2 x base x 1.3133). Since this + -- affects the legend's width/height margin reservation, Layout's + -- @effectiveLegendKeyW@ resolves it. + , toLegendKeySize :: !(Last Double) -- legend.key.size (pt) + -- [日本語]: ★ Phase 63 A20.5: 全 text slot 共通の font family fallback (ggplot + -- theme(text = element_text(family=...)) 相当)。 優先順位は slot 別 FontSpec の + -- fsFamily > これ > "sans-serif" (@mkFontTS@ が解決)。 slot 丸ごと置換 + -- (Last FontSpec) と違い preset の fontSize 焼き込みを潰さない。 + -- [English]: A font-family fallback shared by every text slot + -- (equivalent to ggplot's theme(text = element_text(family=...))). + -- Priority is: the per-slot FontSpec's fsFamily > this > "sans-serif" + -- (resolved by @mkFontTS@). Unlike replacing a whole slot (Last + -- FontSpec), this doesn't clobber the preset's baked-in fontSize. + , toFontFamily :: !(Last Text) -- text family (全 slot 共通 fallback) + -- [日本語]: ★ Phase 68: grid / 軸線の線幅 (ggplot @theme(panel.grid = + -- element_line(linewidth=))@ / @axis.line@ / @panel.border@ 相当)。 全て + -- @Last@ で、 未指定=各 role の現状決め打ちに fallback (既存 golden ゼロ diff)。 + -- 解決は 'Graphics.Hgg.Render.Common' の @effective*Width@ 群が単一情報源で行う + -- (Phase 63 の @effectiveX@ 方式)。 線幅は panel 面積に波及しないので Layout 予約は + -- 不要 (grid 色 'toGridColor' と同じく純 Render 事項)。 規約: + -- * 'toGridWidth' 未指定 = Cartesian major 1.0 / polar・ternary grid 0.5 (座標系別の + -- 現状値を維持) / 指定時 = 全 grid role を統一値に (ggplot panel.grid は座標系非依存)。 + -- * 'toGridMinorWidth' 未指定 = major × 0.5 (ggplot @panel.grid.minor = rel(0.5)@)。 + -- * 'toAxisLineWidth' = axis.line / panel.border / ternary edge / 右 Y 軸線 (未指定 1.0)。 + -- [English]: ★ Phase 68: line widths for grid / axis lines (ggplot + -- @theme(panel.grid = element_line(linewidth=))@ / @axis.line@ / + -- @panel.border@). All @Last@; unspecified falls back to each role's + -- current literal (zero golden diff). Resolved by the @effective*Width@ + -- helpers in 'Graphics.Hgg.Render.Common' as the single source of truth + -- (Phase 63's @effectiveX@ style). Widths don't affect panel area, so no + -- Layout reservation is needed (a pure Render concern, like grid colour). + -- Rules: 'toGridWidth' unspecified keeps the per-coord literals (Cartesian + -- major 1.0 / polar & ternary grid 0.5), while setting it unifies every + -- grid role (ggplot panel.grid is coord-independent). 'toGridMinorWidth' + -- defaults to major × 0.5 (ggplot @rel(0.5)@). 'toAxisLineWidth' covers + -- axis.line / panel.border / ternary edge / right Y axis (default 1.0). + , toGridWidth :: !(Last Double) -- panel.grid (major・全 grid の base) + , toGridMinorWidth :: !(Last Double) -- panel.grid.minor (Cartesian minor 独立上書き) + , toAxisLineWidth :: !(Last Double) -- axis.line / panel.border / ternary edge } deriving stock (Generic, Show, Eq) - -- ★ Phase 43 A3: 全 field が `Last` の素直な per-field 合成なので generic 導出。 + -- [日本語]: ★ Phase 43 A3: 全 field が `Last` の素直な per-field 合成なので generic 導出。 -- 位置依存の手書き instance (旧 `a1..p1` を数で揃える形) を撲滅し、 以後の field - -- 追加 (A4) を「field を足すだけ」で安全にする。挙動は旧手書きと完全同型。 + -- 追加を「field を足すだけ」で安全にする。挙動は旧手書きと完全同型。 + -- [English]: Since every field is a straightforward per-field + -- composition of `Last`, the instance is generically derived. This + -- eliminates the old position-dependent hand-written instance (which + -- lined up `a1..p1` by count) and makes future field additions safe — + -- just add the field. Behavior is exactly identical to the old + -- hand-written version. 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 --- a/src/Graphics/Hgg/Spec/Visual.hs +++ b/src/Graphics/Hgg/Spec/Visual.hs @@ -1,23 +1,36 @@ -- | -- Module : Graphics.Hgg.Spec.Visual --- Description : VisualSpec (= 外側 Monoid、 図全体の宣言型 spec) + Inset +-- Description : VisualSpec, the top-level plot spec aggregating all sub-specs, plus 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 形含む) は完全に不変。 +-- [日本語]: 'Graphics.Hgg.Spec' の module 分割で切り出し。 図全体の宣言型 spec +-- 'VisualSpec' と field-wise Monoid 合成 (@design/monoid-semantics.md@)、 および +-- 'Inset' を持つ。 @inSpec :: VisualSpec@ (= 'Inset' の field) ⇄ +-- @vsInsets :: [Inset]@ (= 'VisualSpec' の field) の相互参照ゆえ、 2 型は本 module に +-- 同居する (実測で確認済みの、 唯一の循環ペア)。 公開 API は従来どおり +-- 'Graphics.Hgg.Spec' (facade) が re-export する。 挙動・出力 (JSON 形含む) は +-- 完全に不変。 +-- [English]: Split out of 'Graphics.Hgg.Spec' when that module was divided up. +-- Holds 'VisualSpec', the declarative spec type for the whole figure, together +-- with its field-wise Monoid composition (@design/monoid-semantics.md@), and +-- 'Inset'. Because @inSpec :: VisualSpec@ (a field of 'Inset') and +-- @vsInsets :: [Inset]@ (a field of 'VisualSpec') reference each other, the two +-- types live together in this module (confirmed by measurement to be the only +-- cyclic pair). The public API is still re-exported by the facade module +-- 'Graphics.Hgg.Spec' as before. Behavior and output (including the JSON shape) +-- are completely unchanged. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Spec.Visual ( VisualSpec(..) , Inset(..) + , TagStyle(..) ) where -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON (..), ToJSON, Value (Object)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KM import qualified Data.List import Data.Monoid (Last (..)) import Data.Text (Text) @@ -33,7 +46,7 @@ import Graphics.Hgg.Spec.Theme (ThemeName, ThemeOverride) -- =========================================================================== --- Inset (= P13、 親 plot に小型 sub-plot を埋込み) +-- Inset (= 親 plot に小型 sub-plot を埋込み) -- =========================================================================== data Inset = Inset @@ -46,10 +59,34 @@ instance FromJSON Inset -- =========================================================================== +-- TagStyle (= subplot panel の自動タグ様式) +-- =========================================================================== + +-- | [日本語]: subplot panel の自動タグ様式 (cowplot @plot_grid(labels=)@ の +-- @"AUTO"@ / @"auto"@ / 連番 相当)。 統一グリッドの panel 列挙順に +-- \"A\",\"B\",… \/ \"a\",\"b\",… \/ \"1\",\"2\",… を各 panel の 'vsTag' として注入する +-- (panel 自身の 'vsTag' 明示指定が優先 = 個別 > 一括)。 +-- JSON は nullary constructor 名 (@TickDir@ と同パターン、 canvas Codec と parity)。 +-- [English]: The automatic tagging style for subplot panels (equivalent to +-- cowplot's @plot_grid(labels=)@ with @"AUTO"@ / @"auto"@ / sequential +-- numbering). In the panel enumeration order of the unified grid, injects +-- \"A\",\"B\",… \/ \"a\",\"b\",… \/ \"1\",\"2\",… as each panel's 'vsTag' (an +-- explicit 'vsTag' on the panel itself takes priority — per-panel over batch). +-- The JSON encoding uses the nullary constructor name (the same pattern as +-- @TickDir@, for parity with the canvas codec). +data TagStyle = TagUpper | TagLower | TagNumeric + deriving (Generic, Show, Eq) + +instance ToJSON TagStyle +instance FromJSON TagStyle + +-- =========================================================================== -- VisualSpec (= 外側 Monoid) -- =========================================================================== --- | 図全体の宣言型 spec。 全 field を Monoid 化して field-wise `<>` 合成。 +-- | [日本語]: 図全体の宣言型 spec。 全 field を Monoid 化して field-wise @<>@ 合成。 +-- [English]: The declarative spec type for the whole figure. Every field is a +-- Monoid, and specs are composed field-wise with @<>@. data VisualSpec = VisualSpec { vsLayers :: ![Layer] , vsTitle :: !(Last Text) @@ -57,18 +94,28 @@ , vsFacet :: !(Last ColRef) , vsXLabel :: !(Last Text) , vsYLabel :: !(Last Text) + , vsZLabel :: !(Last Text) -- ★ Phase 64 A11: 三角座標 (ternary) 第 3 軸ラベル , vsXAxis :: !(Last AxisSpec) -- ★ Phase 26 §C-2 #1 , vsYAxis :: !(Last AxisSpec) -- ★ Phase 26 §C-2 #1 - , vsYAxisRight :: !(Last AxisSpec) -- ★ P5 dual Y 軸 (右側) + , vsYAxisRight :: !(Last AxisSpec) -- ★ 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) + , vsSubplotCols :: !(Last Int) -- ★ 2D grid 折り返し列数 + -- ★ Phase 63 A6: subplot 列/行の相対サイズ (cowplot plot_grid の rel_widths / + -- rel_heights 相当)。 統一グリッドの列/行 index 順の重み。 グリッド数に対して + -- 不足分は 1 で埋める (エラーにしない)。 未指定 = 全列/行 1 (= 従来の等分)。 + , vsSubplotWidths :: !(Last [Double]) + , vsSubplotHeights :: !(Last [Double]) + -- ★ Phase 63 A7: subplot panel の自動タグ (cowplot plot_grid の labels="AUTO" 相当)。 + -- panel 列挙順に TagStyle の連番タグを各 panel の vsTag へ注入 (個別 vsTag 優先)。 + -- 未指定 = タグ無し (= 従来同一)。 + , vsSubplotTags :: !(Last TagStyle) + , vsLegend :: !(Last LegendSpec) -- ★ 2026-05-25 凡例設定 (= Nothing なら auto) + , vsAnnotations :: ![Annotation] -- ★ 任意 overlay (text/arrow/rect/line) + , vsInsets :: ![Inset] -- ★ inset axes + , vsPalette :: !(Last [Text]) -- ★ categorical palette (= Nothing なら hggMain F-3) + , vsContinuousPal :: !(Last [Text]) -- ★ continuous palette (= Nothing なら viridis5) , vsTitleFont :: !(Last FontSpec) -- ★ frontend-settings v0.1 §1.3 , vsAxisLabelFont :: !(Last FontSpec) -- ★ 〃 , vsTickFont :: !(Last FontSpec) -- ★ 〃 @@ -143,14 +190,14 @@ -- ★ 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 の列挙順に並べ替え** + -- ★ 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 の列挙順に並べ替え** + -- @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 @@ -160,15 +207,35 @@ } deriving (Generic, Show, Eq) instance ToJSON VisualSpec -instance FromJSON VisualSpec +-- ★ Phase 64 A11: vsZLabel は後付けフィールドゆえ、 旧 JSON (= gallery +-- specs/**.json 等・ternary 導入前に生成) にキーが無くても decode できるよう、 +-- generic parse の前に欠損キーを既定値 (null = Last Nothing) で補う +-- ('Layer' の lyOverlay/lyCustom/lyEncZ と同方針)。 +instance FromJSON VisualSpec where + parseJSON v = case v of + Object o -> + let o1 = if KM.member "vsZLabel" o then o + else KM.insert "vsZLabel" Aeson.Null o + in Aeson.genericParseJSON Aeson.defaultOptions (Object o1) + _ -> Aeson.genericParseJSON Aeson.defaultOptions v --- | 図全体の合成。 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。 +-- | [日本語]: 図全体の合成。 list 系 (layers/refLines/subplots/annotations/insets) は +-- concat、 残りは 'Last' で後勝ち、 themeOverride は element 単位 Monoid。 +-- 合成規則の全体表は @design/monoid-semantics.md@ を参照。 +-- レコードフィールド形式 (位置依存撲滅・挙動不変)。49 field の位置揃え +-- (旧 @l1 t1 th1 …@) を撲滅し、 以後の field 追加を「行を 1 本足すだけ」 + @-Wmissing-fields@ +-- 保護下にする。唯一の特殊合成 'mergeColorManual' (= dedup 合成) のみ +-- 名前付きで温存。list 系は @<>@=concat、 残りは @Last@ 後勝ち、 themeOverride は element Monoid。 +-- [English]: The composition of the whole figure. List-valued fields +-- (layers/refLines/subplots/annotations/insets) are concatenated, the rest use +-- 'Last'-style last-wins, and themeOverride is an element-wise Monoid. See +-- @design/monoid-semantics.md@ for the full composition-rule table. This uses +-- the record-field form (eliminating positional dependence, behavior +-- unchanged): it replaces the old positional @l1 t1 th1 …@ style, so that +-- adding a field is just "add one line", protected by @-Wmissing-fields@. The +-- only special composition kept under its own name is 'mergeColorManual' (the +-- dedup composition); list fields use @<>@ = concat, the rest use @Last@ +-- last-wins, and themeOverride uses the element Monoid. instance Semigroup VisualSpec where a <> b = VisualSpec { vsLayers = vsLayers a <> vsLayers b @@ -177,6 +244,7 @@ , vsFacet = vsFacet a <> vsFacet b , vsXLabel = vsXLabel a <> vsXLabel b , vsYLabel = vsYLabel a <> vsYLabel b + , vsZLabel = vsZLabel a <> vsZLabel b , vsXAxis = vsXAxis a <> vsXAxis b , vsYAxis = vsYAxis a <> vsYAxis b , vsYAxisRight = vsYAxisRight a <> vsYAxisRight b @@ -184,6 +252,9 @@ , vsMarginal = vsMarginal a <> vsMarginal b , vsSubplots = vsSubplots a <> vsSubplots b , vsSubplotCols = vsSubplotCols a <> vsSubplotCols b + , vsSubplotWidths = vsSubplotWidths a <> vsSubplotWidths b + , vsSubplotHeights = vsSubplotHeights a <> vsSubplotHeights b + , vsSubplotTags = vsSubplotTags a <> vsSubplotTags b , vsLegend = vsLegend a <> vsLegend b , vsAnnotations = vsAnnotations a <> vsAnnotations b , vsInsets = vsInsets a <> vsInsets b @@ -229,9 +300,10 @@ -- 一律 mempty。レコード形式により field 追加時の位置ズレ事故が起きない。 mempty = VisualSpec { vsLayers = mempty, vsTitle = mempty, vsTheme = mempty, vsFacet = mempty - , vsXLabel = mempty, vsYLabel = mempty, vsXAxis = mempty, vsYAxis = mempty + , vsXLabel = mempty, vsYLabel = mempty, vsZLabel = mempty, vsXAxis = mempty, vsYAxis = mempty , vsYAxisRight = mempty, vsRefLines = mempty, vsMarginal = mempty , vsSubplots = mempty, vsSubplotCols = mempty, vsLegend = mempty + , vsSubplotWidths = mempty, vsSubplotHeights = mempty, vsSubplotTags = mempty , vsAnnotations = mempty, vsInsets = mempty, vsPalette = mempty , vsContinuousPal = mempty, vsTitleFont = mempty, vsAxisLabelFont = mempty , vsTickFont = mempty, vsLegendFont = mempty, vsWidth = mempty, vsHeight = mempty @@ -246,10 +318,18 @@ , vsYDiscreteLimits = mempty } --- | Phase 52.A10: scale_color_manual 辞書の合成。 旧実装は Last の最後勝ちで、 異モデル --- 重畳 (各レイヤが 1 群の ColorByCol + 単一辞書) のとき先頭群の色辞書が捨てられ全線同色化 --- していた。 ここでは両辞書を concat し同じカテゴリ名は後勝ちで dedup する (= 全群の色が --- 残り各 ColorByCol レイヤが自色を引ける)。 片方 Nothing は他方をそのまま採用。 +-- | [日本語]: scale_color_manual 辞書の合成。 旧実装は Last の最後勝ちで、 異モデル +-- 重畳 (各レイヤが 1 群の ColorByCol + 単一辞書) のとき先頭群の色辞書が捨てられ全線同色化 +-- していた。 ここでは両辞書を concat し同じカテゴリ名は後勝ちで dedup する (= 全群の色が +-- 残り各 ColorByCol レイヤが自色を引ける)。 片方 Nothing は他方をそのまま採用。 +-- [English]: Composes @scale_color_manual@ dictionaries. The old implementation +-- used 'Last'-style last-wins semantics, so when heterogeneous groups were +-- overlaid (each layer being one ColorByCol group with a single dictionary), +-- the first group's color dictionary was discarded and every line ended up +-- the same color. Here the two dictionaries are concatenated, and duplicate +-- category names are deduplicated with last-wins (so every group's colors +-- survive and each ColorByCol layer can look up its own color). If either +-- side is Nothing, the other is used as-is. mergeColorManual :: Last [(Text, Text)] -> Last [(Text, Text)] -> Last [(Text, Text)] mergeColorManual (Last Nothing) b = b mergeColorManual a (Last Nothing) = a diff --git a/src/Graphics/Hgg/Unit.hs b/src/Graphics/Hgg/Unit.hs --- a/src/Graphics/Hgg/Unit.hs +++ b/src/Graphics/Hgg/Unit.hs @@ -1,16 +1,28 @@ -- | -- Module : Graphics.Hgg.Unit --- Description : 長さの単位系 (pt オーサリング + dpi 描画境界、Phase 33) +-- Description : The length unit system — pt authoring with a dpi rendering boundary -- 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 には依存しない = 循環回避)。 +-- [日本語]: 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' で解決する。 +-- 単位は値と一体 ('Length')。混在は許さず、各値が自分の単位を持つ。px は dpi +-- 依存なので 'toPt' では変換できず ('Nothing')、dpi を受け取る 'lengthToPt' で +-- 解決する。 +-- [English]: hgg has multiple backends — SVG / Canvas / PNG / PDF. +-- Since PDF is native in points (1/72 inch), authoring primarily uses +-- physical units (mm/cm/inch/pt), and @px = pt × dpi/72@ is applied exactly +-- once at the px output boundary. This module is the lowest, pure-value +-- layer; it is referenced from Spec / Layout but does not depend on Spec +-- itself, to avoid a cycle. +-- +-- A unit travels together with its value ('Length'); mixing is not +-- allowed, so each value carries its own unit. Since px is dpi-dependent, +-- 'toPt' cannot convert it ('Nothing'); resolving it requires 'lengthToPt', +-- which takes a dpi. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} @@ -22,7 +34,7 @@ , mmToPt , toPt , lengthToPt - -- * 座標 (Phase 33 B3): 相対単位込みの位置型 + resolver 別名 + -- * 座標: 相対単位込みの位置型 + resolver 別名 , Pos(..) , resolveLen ) where @@ -35,27 +47,43 @@ -- === 型 === --- | 長さの単位。Mm/Cm/In/Pt は dpi 非依存の物理単位、Px は device 依存。 +-- | [日本語]: 長さの単位。Mm/Cm/In/Pt は dpi 非依存の物理単位、Px は device 依存。 +-- [English]: A length unit. Mm/Cm/In/Pt are dpi-independent physical +-- units; Px is device-dependent. data LUnit = Mm | Cm | In | Pt | Px deriving (Eq, Show, Generic) --- | 値と単位を一体に保持する長さ。 +-- | [日本語]: 値と単位を一体に保持する長さ。 +-- [English]: A length that carries its value and unit together. 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 への依存を避ける = 循環回避)。 +-- | [日本語]: 軸に沿った「座標」(サイズ 'Length' ではない)。注釈・参照線・inset +-- の自由配置に使う。相対単位 (npc/native) の意味は panel rect / scale が +-- 決めるので、解決は @UCtx@ を受け取る Layout 側 resolver (@resolvePosX/Y@) +-- が担う (本 module には型と Codec だけ置き、Rect/Scale への依存を避ける = +-- 循環回避)。 +-- [English]: A "coordinate" along an axis (not a size, unlike 'Length'). +-- Used for freely positioning annotations, reference lines, and insets. +-- The meaning of the relative units (npc/native) is determined by the +-- panel rect / scale, so resolution is handled by the Layout-side +-- resolver (@resolvePosX/Y@), which takes a @UCtx@. This module holds only +-- the type and its Codec, avoiding a dependency on Rect/Scale (to prevent +-- a cycle). data Pos - = PAbs !Length -- ^ 物理長オフセット (pt/mm/in/px)。panel 原点基準。 - | PNpc !Double -- ^ panel 正規化座標 0..1 (0=左/下端, 1=右/上端)。 - | PNative !Double -- ^ data 座標 (scale 経由で pt 化)。 + = PAbs !Length -- ^ [日本語]: 物理長オフセット (pt/mm/in/px)。panel 原点基準。 + -- [English]: A physical-length offset (pt/mm/in/px), relative to the panel origin. + | PNpc !Double -- ^ [日本語]: panel 正規化座標 0..1 (0=左/下端, 1=右/上端)。 + -- [English]: A panel-normalised coordinate in 0..1 (0 = left/bottom edge, 1 = right/top edge). + | PNative !Double -- ^ [日本語]: data 座標 (scale 経由で pt 化)。 + -- [English]: A data coordinate (converted to pt via the scale). deriving (Eq, Show, Generic) -- === 構築 (単位量 + スカラ倍) === --- | 各単位の「1 単位」を表す単位量。@7 *~ inch@ のように使う。 +-- | [日本語]: 各単位の「1 単位」を表す単位量。@7 *~ inch@ のように使う。 +-- [English]: A unit quantity representing "one unit" of each unit; used as +-- in @7 *~ inch@. mm, cm, inch, pt', px :: Length mm = Length 1 Mm cm = Length 1 Cm @@ -63,23 +91,42 @@ pt' = Length 1 Pt px = Length 1 Px --- | スカラ倍 (単位保存)。@k *~ (n 単位) = (k*n) 単位@。 +-- | [日本語]: スカラ倍 (単位保存)。@k *~ (n 単位) = (k*n) 単位@。 +-- [English]: Scalar multiplication (unit-preserving). @k *~ (n units) = +-- (k*n) units@. 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)@ の単位付きも同じ引数型で受けること。 +-- | [日本語]: 数値リテラルを 'Length' として解釈するための 'Num' / 'Fractional' +-- instance。狙いは @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 と同じ慣用)。 +-- ★ なぜ型クラス (@ToLength@ 案) でなくこちら: @ToLength a => a -> _@ だと +-- @width 624@ が @(Num a, ToLength a) => a@ で曖昧化し、ToLength が標準クラスで +-- ないため Haskell2010 の defaulting が効かず__コンパイル不可__ (実測検証済)。 +-- @Num Length@ なら @624 :: Length = fromInteger 624 = Length 624 Pt@ と確定し +-- 曖昧化しない (CSS length ライブラリ = clay/diagrams と同じ慣用)。 -- --- 算術 (@+@/@-@/@*@) は **同一単位の被演算子**を想定し、左辺の単位を保存して数値だけ --- 合成する (主用途はリテラル overloading なので cross-unit 演算は非対象)。 +-- 算術 (@+@/@-@/@*@) は __同一単位の被演算子__を想定し、左辺の単位を保存して +-- 数値だけ合成する (主用途はリテラル overloading なので cross-unit 演算は +-- 非対象)。 +-- [English]: The 'Num' / 'Fractional' instances that let a numeric literal +-- be interpreted as a 'Length'. The goal is to make __a bare numeric literal mean pt__, +-- as in @width 624@, while also accepting a unit +-- annotation such as @width (7 *~ inch)@ at the same argument type. +-- +-- Why this rather than a type class (the @ToLength@ idea): with +-- @ToLength a => a -> _@, @width 624@ becomes ambiguous at +-- @(Num a, ToLength a) => a@, and since ToLength is not a standard class, +-- Haskell2010 defaulting does not kick in, so it __fails to compile__ +-- (verified by measurement). With @Num Length@, @624 :: Length@ resolves +-- unambiguously to @fromInteger 624 = Length 624 Pt@ (the same idiom used +-- by CSS-length libraries such as clay/diagrams). +-- +-- Arithmetic (@+@/@-@/@*@) assumes __operands of the same unit__: it keeps +-- the left operand's unit and only combines the numbers (the primary use +-- case is literal overloading, so cross-unit arithmetic is out of scope). instance Num Length where fromInteger n = Length (fromInteger n) Pt Length a u + Length b _ = Length (a + b) u @@ -95,12 +142,18 @@ -- === pt への正規化 === --- | mm → pt 変換定数 (72pt / 25.4mm ≈ 2.8346)。ggplot の @.pt=72.27/25.4@ / --- @.stroke=96/25.4@ の基準混在は採らず、全部 72pt/inch に統一する。 +-- | [日本語]: mm → pt 変換定数 (72pt / 25.4mm ≈ 2.8346)。ggplot の +-- @.pt=72.27/25.4@ / @.stroke=96/25.4@ の基準混在は採らず、全部 72pt/inch +-- に統一する。 +-- [English]: The mm to pt conversion constant (72pt / 25.4mm ≈ 2.8346). +-- Rather than mixing bases like ggplot's @.pt=72.27/25.4@ / +-- @.stroke=96/25.4@, everything here is unified to 72pt/inch. mmToPt :: Double mmToPt = 72 / 25.4 --- | dpi 非依存単位を pt 化。'Px' は dpi が要るので 'Nothing' (型で表現)。 +-- | [日本語]: dpi 非依存単位を pt 化。'Px' は dpi が要るので 'Nothing' (型で表現)。 +-- [English]: Converts dpi-independent units to pt. 'Px' requires a dpi, so +-- it yields 'Nothing' (expressed at the type level). toPt :: Length -> Maybe Double toPt (Length n u) = case u of Pt -> Just n @@ -109,8 +162,11 @@ Mm -> Just (n * mmToPt) Px -> Nothing --- | dpi を受け取り全単位を pt 化。'Px' のみ @n * 72/dpi@。 --- computeLayout 入口で figure size を解決する本命関数。 +-- | [日本語]: dpi を受け取り全単位を pt 化。'Px' のみ @n * 72/dpi@。 +-- computeLayout 入口で figure size を解決する本命関数。 +-- [English]: Converts every unit to pt, given a dpi; only 'Px' uses +-- @n * 72/dpi@. This is the primary function that resolves figure size at +-- the computeLayout entry point. lengthToPt :: Double -> Length -> Double lengthToPt dpi (Length n u) = case u of Pt -> n @@ -119,8 +175,12 @@ Mm -> n * mmToPt Px -> n * 72 / dpi --- | 'Length' を pt 化する resolver 別名 ('lengthToPt' と同一)。Pos resolver --- (@resolvePosX/Y@) と対で「単位を pt へ解く」API を一様に呼ぶための名前。 +-- | [日本語]: 'Length' を pt 化する resolver 別名 ('lengthToPt' と同一)。Pos +-- resolver (@resolvePosX/Y@) と対で「単位を pt へ解く」API を一様に呼ぶための +-- 名前。 +-- [English]: A resolver alias for converting 'Length' to pt (identical to +-- 'lengthToPt'). Paired with the Pos resolver (@resolvePosX/Y@) to give a +-- uniform name for "resolve a unit to pt" APIs. resolveLen :: Double -> Length -> Double resolveLen = lengthToPt @@ -151,9 +211,13 @@ _ -> 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 一致させる。 +-- | [日本語]: 'Pos' の Codec。tag 付き @{ "t": "abs"|"npc"|"native", ... }@。 +-- "abs" は @"l"@ に 'Length'、"npc"/"native" は @"p"@ に Double。key 順は +-- toEncoding (t→payload) で固定し PS argonaut と byte 一致させる。 +-- [English]: The Codec for 'Pos': tagged @{ "t": "abs"|"npc"|"native", ... }@. +-- "abs" carries a 'Length' at @"l"@; "npc"/"native" carry a Double at +-- @"p"@. Key order is fixed by toEncoding (t then payload) to byte-match +-- PureScript's argonaut. instance ToJSON Pos where toJSON p = case p of PAbs l -> object ["t" .= ("abs" :: Text), "l" .= l] diff --git a/src/Graphics/Hgg/Validate.hs b/src/Graphics/Hgg/Validate.hs --- a/src/Graphics/Hgg/Validate.hs +++ b/src/Graphics/Hgg/Validate.hs @@ -1,26 +1,49 @@ -- | -- Module : Graphics.Hgg.Validate --- Description : Layer 3.5 ─ compile / validate / 診断 (Phase 11 A1 core hardening) +-- Description : Layer 3.5 — compile / validate / diagnostics (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 時に検出する。 +-- * 「'VisualSpec' は直接描画しない」 を型で固定する。 backend に渡す前に +-- 'compilePlot' を通し、 必須 aesthetic 欠落 / 列解決失敗 / 型不一致 を検出。 +-- * 診断は __actionable__ であること (= 「Missing y」 ではなく +-- 「scatter は x と y が必要。 y 列が未指定。 `y "yield"` を足してください」)。 +-- * 列名解決失敗には __編集距離 suggestion__ を添える ('validatePlotWith' に +-- 既知列名を渡したとき)。 +-- * 'BackendCapability' で backend 非対応機能を compile 時に検出する。 -- --- 本 module は render を一切呼ばない (= 出力中立)。 既存 backend は当面そのまま --- 動き、 段階的に 'compilePlot' 経由へ寄せる。 +-- 本 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 明文化) で扱う。 +-- 既知の制約: 「1 layer に mark 2 個 (`scatter x y <> line x y`) を合成して 2 +-- 個目が黙って消える」 footgun は、 'Layer' の `lyKind :: First MarkKind` が +-- 合成時点で不可逆に潰れるため __post-hoc には検出できない__。 検出には Layer +-- に診断用フィールドを足す必要があり、 別途扱う (Monoid 明文化)。 +-- [English]: Design policy: +-- +-- * Fixes "'VisualSpec' does not render directly" at the type level. +-- Before handing off to a backend, it passes through 'compilePlot', +-- which detects missing required aesthetics, column-resolution +-- failures, and type mismatches. +-- * Diagnostics must be __actionable__ (not "Missing y" but "scatter +-- requires x and y. The y column is unset. Add \`y \"yield\"\`."). +-- * Column-resolution failures come with an __edit-distance suggestion__ +-- (when known column names are passed to 'validatePlotWith'). +-- * 'BackendCapability' detects backend-unsupported features at compile +-- time. +-- +-- This module never calls render (it is output-neutral). Existing +-- backends keep working unchanged for now, and are migrated to go through +-- 'compilePlot' incrementally. +-- +-- A known limitation: the footgun where composing two marks into one +-- layer (\`scatter x y <> line x y\`) silently drops the second one +-- __cannot be detected post-hoc__, because the \`lyKind :: First MarkKind\` +-- field of 'Layer' collapses irreversibly at composition time. Detecting +-- it would require adding a diagnostic field to Layer, which is handled +-- separately (as part of making the Monoid semantics explicit). {-# LANGUAGE OverloadedStrings #-} module Graphics.Hgg.Validate ( -- * Aesthetic / 型 @@ -42,12 +65,16 @@ -- * validate / compile , validatePlot , validatePlotWith + , facetInlineDiagnostics -- ★ Phase 62 A4 (§3) + , reportFacetInlineWarnings -- ★ Phase 62 A4: backend save 系共用の stderr 報告 + , ternaryMarkWarningsFor -- ★ Phase 64 A13 + , reportTernaryMarkWarnings -- ★ Phase 64 A13: coordTernary 非対応 mark の stderr 報告 , suggest , CompiledPlot , compiledSpec , compilePlot , compilePlotWith - -- * Backend capability matrix (= §5.5) + -- * Backend capability matrix , BackendName(..) , FeatureName(..) , BackendCapability(..) @@ -64,6 +91,8 @@ import Data.Monoid (First (..), Last (..)) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Vector as V +import System.IO (hPutStrLn, stderr) import Graphics.Hgg.Spec @@ -71,14 +100,18 @@ -- Aesthetic / 型 -- =========================================================================== --- | mark が要求しうる aesthetic 種別 (= 診断メッセージ用)。 +-- | [日本語]: mark が要求しうる aesthetic 種別 (= 診断メッセージ用)。 +-- [English]: The kinds of aesthetic a mark may require (for diagnostic +-- messages). 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 名に寄せる)。 +-- | [日本語]: 診断文に出す aesthetic 名 (= setter 名に寄せる)。 +-- [English]: The aesthetic name shown in diagnostic text (matches the +-- setter name). aesName :: Aesthetic -> Text aesName a = case a of AesX -> "x" @@ -107,9 +140,12 @@ data Severity = SevError | SevWarning | SevInfo deriving (Show, Eq, Ord) --- | どの layer / mark で起きたか (= メッセージの文脈)。 +-- | [日本語]: どの layer / mark で起きたか (= メッセージの文脈)。 +-- [English]: Which layer / mark the diagnostic occurred in (message +-- context). data DiagnosticContext = DiagnosticContext - { dcLayer :: Maybe Int -- ^ 0 始まりの layer index (Nothing = 図全体) + { dcLayer :: Maybe Int -- ^ [日本語]: 0 始まりの layer index (Nothing = 図全体)。 + -- [English]: The 0-based layer index (Nothing means the whole figure). , dcMark :: Maybe MarkKind } deriving (Show, Eq) @@ -118,15 +154,39 @@ data PlotErrorKind = MissingAesthetic MarkKind Aesthetic - | ColumnNotFound Text [Text] -- ^ 見つからない列名 + 候補 (編集距離) + | ColumnNotFound Text [Text] + -- ^ [日本語]: 見つからない列名 + 候補 (編集距離)。 + -- [English]: The column name that could not be found, plus candidates (by edit distance). | ColumnTypeMismatch Text Aesthetic ExpectedType ActualType - | EmptyPlot -- ^ layer が 1 つも無い - | DistColsNonDistribution MarkKind -- ^ ★ Phase 36 D3: distCols のレーンが分布 mark でない + | EmptyPlot + -- ^ [日本語]: layer が 1 つも無い。 + -- [English]: There is not a single layer. + | DistColsNonDistribution MarkKind + -- ^ [日本語]: ★ distCols のレーンが分布 mark でない。 + -- [English]: A distCols lane whose mark is not a distribution mark. deriving (Show, Eq) data PlotWarningKind = BackendUnsupported BackendName FeatureName - | TooFewColumns Aesthetic Int Int -- ^ 必要数 / 実数 (parallel 等) + | TooFewColumns Aesthetic Int Int + -- ^ [日本語]: 必要数 / 実数 (parallel 等)。 + -- [English]: The required count vs. the actual count (for e.g. parallel coordinates). + | FacetInlineLengthMismatch Aesthetic Int Int + -- ^ [日本語]: ★ facet 列と長さの異なる inline 列 (inline 長 / facet 長)。 + -- facet 分割がこの列に効かず全 panel に同一データが描かれる。 描画は継続する。 + -- [English]: An inline column whose length differs from the facet + -- column (inline length / facet length). Facet splitting has no + -- effect on this column, so the same data is drawn on every panel. + -- Rendering continues regardless. + | TernaryUnsupportedMark MarkKind + -- ^ [日本語]: ★ Phase 64 A13: 三角座標 (coordTernary) で意味を成さない mark。 + -- ternary は point/line/area/text 系の mark のみ意味を持つ。 それ以外の mark は + -- 投影自体は行われる (= 黙って Cartesian に落ちはしない) が結果は意味を持たない。 + -- 描画は継続する。 + -- [English]: A mark meaningless under ternary coordinates (coordTernary). + -- Ternary only makes sense for point/line/area/text marks; other marks + -- are still projected (they do not silently fall back to Cartesian) but + -- the result is not meaningful. Rendering continues regardless. deriving (Show, Eq) data PlotDiagnostic @@ -140,7 +200,9 @@ diagnosticSeverity PlotWarning{} = SevWarning diagnosticSeverity PlotInfo{} = SevInfo --- | 人間が読める actionable メッセージ (= §5.4 Diagnostics Policy)。 +-- | [日本語]: 人間が読める actionable メッセージ (= §5.4 Diagnostics Policy)。 +-- [English]: A human-readable, actionable message (§5.4 Diagnostics +-- Policy). renderDiagnostic :: PlotDiagnostic -> Text renderDiagnostic d = case d of PlotError k ctx -> sev "error" <> ctxStr ctx <> errMsg k @@ -176,6 +238,15 @@ <> " 非対応です (fallback または無視されます)。" TooFewColumns a need got -> aesName a <> " は最低 " <> tshow need <> " 列必要ですが " <> tshow got <> " 列でした。" + FacetInlineLengthMismatch a m n -> + "facet 列 (" <> tshow n <> " 行) と長さの異なる inline " <> aesName a + <> " 列 (" <> tshow m <> " 行) があります。 facet 分割がこの列に効かず、" + <> "全 panel に同一データが描かれます。 列長を facet 列と揃えるか、" + <> "名前参照 + Resolver (saveSVGWith / savePNGWith 等) を使ってください。" + TernaryUnsupportedMark m -> + "三角座標 (coordTernary) は point / line / area / text 系の mark のみ意味を持ちます。 " + <> markName m <> " は三角座標で意味を持ちません (投影は行われますが結果は不定です)。 " + <> "scatter / line / band / text へ変えるか、 coordTernary を外してください。" expName ExpNumeric = "数値列" expName ExpCategorical = "カテゴリ列" expName ExpAny = "任意の列" @@ -194,8 +265,12 @@ -- 必須 aesthetic (= constructor 定義から導出した事実、 Spec.hs L673-993) -- =========================================================================== --- | mark が描画に最低限要求する aesthetic。 これが欠けると 'validatePlot' が --- 'MissingAesthetic' を返す。 categorical/numeric の別は型チェックで別途見る。 +-- | [日本語]: mark が描画に最低限要求する aesthetic。 これが欠けると +-- 'validatePlot' が 'MissingAesthetic' を返す。 categorical/numeric の別は +-- 型チェックで別途見る。 +-- [English]: The minimum aesthetics a mark requires to render. Missing one +-- causes 'validatePlot' to return 'MissingAesthetic'. Whether a value is +-- categorical or numeric is checked separately, by type checking. requiredAes :: MarkKind -> [Aesthetic] requiredAes m = case m of MScatter -> [AesX, AesY] @@ -264,25 +339,76 @@ -- validate -- =========================================================================== --- | 既知列名なしの検証 (= 列解決の成否のみ、 suggestion 無し)。 +-- | [日本語]: 既知列名なしの検証 (= 列解決の成否のみ、 suggestion 無し)。 +-- [English]: Validates without known column names (only whether columns +-- resolve; no suggestions). validatePlot :: Resolver -> VisualSpec -> [PlotDiagnostic] validatePlot = validatePlotWith [] --- | 既知列名 (= Resolver が供給できる列の一覧) を渡すと 'ColumnNotFound' に --- 編集距離 suggestion が付く。 +-- | [日本語]: 既知列名 (= Resolver が供給できる列の一覧) を渡すと +-- 'ColumnNotFound' に編集距離 suggestion が付く。 +-- [English]: Passing known column names (the columns the Resolver can +-- supply) attaches an edit-distance suggestion to 'ColumnNotFound'. validatePlotWith :: [Text] -> Resolver -> VisualSpec -> [PlotDiagnostic] validatePlotWith known r spec = - emptyCheck ++ layerDiags ++ subDiags + emptyCheck ++ layerDiags ++ ternaryDiags ++ subDiags where ls = vsLayers spec emptyCheck | null ls && null (vsSubplots spec) = [PlotError EmptyPlot topCtx] | otherwise = [] layerDiags = concat (zipWith (validateLayer known r) [0 ..] ls) + -- ★ Phase 64 A13: coordTernary で point/line/area/text 以外の mark を警告 (= 黙って + -- Cartesian に落とさない・A13 の要件)。 subplot 再帰は subDiags 側が担う。 + ternaryDiags = ternaryMarkWarningsFor spec -- subplots は独立 spec なので再帰 (layer index は各 sub で 0 始まり) subDiags = concatMap (validatePlotWith known r) (vsSubplots spec) --- | 1 layer の検証: 必須 aesthetic 欠落 + 列解決 + 型チェック。 +-- | [日本語]: ★ Phase 64 A13: 単一 spec について、 coordTernary 下で 'ternaryValidMarks' +-- に無い mark (= point/line/area/text 以外) を 'TernaryUnsupportedMark' 警告にする。 +-- subplot 再帰はしない (呼出側が担う)。 mark 未指定 layer / 'MCustom' は対象外。 +-- [English]: Phase 64 A13. For a single spec, flags any mark not in +-- 'ternaryValidMarks' (i.e. not point/line/area/text) under coordTernary as a +-- 'TernaryUnsupportedMark' warning. Does not recurse into subplots (the caller +-- does). Mark-less layers and 'MCustom' are exempt. +ternaryMarkWarningsFor :: VisualSpec -> [PlotDiagnostic] +ternaryMarkWarningsFor spec + -- ★ Phase 69 A4: CoordTernary が opts を持つようになったのでパターンで判定 + -- (明示 coordTernary 指定時のみ・従来挙動を維持)。 + | Just (CoordTernary _) <- getLast (vsCoord spec) = + [ PlotWarning (TernaryUnsupportedMark m) (DiagnosticContext (Just i) (Just m)) + | (i, ly) <- zip [0 ..] (vsLayers spec) + , Just m <- [getFirst (lyKind ly)] + , m `notElem` ternaryValidMarks ] + | otherwise = [] + +-- | [日本語]: ★ Phase 64 A13: 'ternaryMarkWarningsFor' を stderr へ報告する backend 共用 +-- helper (SVG / PNG / PDF / TeX の save 系入口から 'reportFacetInlineWarnings' と並べて +-- 呼ぶ)。 診断ゼロなら無音。 描画は止めない (= 描画継続 + 警告)。 'validatePlot' 経由で +-- subplot も再帰的に拾い、 'TernaryUnsupportedMark' 警告のみに絞る。 +-- [English]: Phase 64 A13. A backend-shared helper that reports +-- 'ternaryMarkWarningsFor' to stderr (called alongside +-- 'reportFacetInlineWarnings' from the SVG / PNG / PDF / TeX save entry +-- points). Silent when there are none. Does not stop rendering. Goes through +-- 'validatePlot' to also pick up subplots recursively, filtering to only the +-- 'TernaryUnsupportedMark' warnings. +reportTernaryMarkWarnings :: Resolver -> VisualSpec -> IO () +reportTernaryMarkWarnings r spec = + mapM_ (hPutStrLn stderr . T.unpack . renderDiagnostic) + [ d | d@(PlotWarning (TernaryUnsupportedMark _) _) <- validatePlot r spec ] + +-- | [日本語]: ★ Phase 64 A13: 三角座標 (ternary) で意味を持つ mark。 point (scatter) / +-- line (line/trace) / area (band) / text (text/label)。 user 定義の 'MCustom' は +-- 判定不能ゆえ対象外 (警告しない)。 +-- [English]: Marks meaningful under ternary coordinates: point (scatter), +-- line (line/trace), area (band), text (text/label). User-defined 'MCustom' +-- is exempt (undecidable, so not warned). +ternaryValidMarks :: [MarkKind] +ternaryValidMarks = [MScatter, MLine, MTrace, MBand, MText, MLabel, MCustom] + +-- | [日本語]: 1 layer の検証: 必須 aesthetic 欠落 + 列解決 + 型チェック。 +-- [English]: Validates a single layer: missing required aesthetics, +-- column resolution, and type checking. validateLayer :: [Text] -> Resolver -> Int -> Layer -> [PlotDiagnostic] validateLayer known r i ly = case getFirst (lyKind ly) of @@ -315,7 +441,9 @@ | otherwise = [] in missing ++ dagMiss ++ colsMiss ++ resolveDiags ++ distColsDiags --- | layer に実際に設定済みの (aesthetic, 列) 組を取り出す。 +-- | [日本語]: layer に実際に設定済みの (aesthetic, 列) 組を取り出す。 +-- [English]: Extracts the (aesthetic, column) pairs actually set on a +-- layer. layerCols :: Layer -> [(Aesthetic, ColRef)] layerCols ly = mapMaybe pick [ (AesX, getLast (lyEncX ly)) @@ -334,7 +462,71 @@ Just (ColorByContinuous c) -> [(AesColor, c)] _ -> [] --- | 列の解決可否 + 型チェック。 数値要求 aesthetic に文字列列が来たら型不一致。 +-- | [日本語]: ★ facet 列と長さの異なる inline encoding の検出。 +-- inline 列は Resolver を通らないため、 facet の行分割 (@subsetInlineSpec@) は +-- __facet 列と同じ長さの inline のみ__に効く。 長さが違う inline が encoding +-- に残っていると、 その列は分割されず全 panel に同一データが描かれる — +-- それを明示検出する (検出しても描画は継続 = 非破壊、 user 決定)。 +-- 判定は 'applyDiscreteLimits' 適用後の姿で行う (= 経路 2 の bake / limits に +-- よる行 drop の後、 実際に render が見る spec と同条件。 limits の行 drop で +-- facet 列と layer が desync するケースもこれで捕まる)。 +-- [English]: Detects inline encodings whose length differs from the +-- facet column. Since inline columns bypass the Resolver, facet row +-- splitting (@subsetInlineSpec@) applies __only to inline columns whose length matches the facet column__. +-- If a mismatched-length inline +-- remains in the encoding, that column is not split and the same data is +-- drawn on every panel — this function explicitly detects that case +-- (detection does not stop rendering: it is non-destructive, per user +-- decision). The check is performed on the spec after +-- 'applyDiscreteLimits' has been applied (that is, after row drops from +-- path-2 baking / limits — the same condition the actual renderer sees. +-- This also catches cases where limits' row drops desync the facet column +-- from a layer). +facetInlineDiagnostics :: Resolver -> VisualSpec -> [PlotDiagnostic] +facetInlineDiagnostics r spec0 = go (applyDiscreteLimits r spec0) ++ subDiags + where + -- subplots は独立 spec (自分の facet を持てる) なので再帰 + subDiags = concatMap (facetInlineDiagnostics r) (vsSubplots spec0) + go spec = case facetLens spec of + [] -> [] + (n : _) -> concat (zipWith (layerMismatch n) [0 ..] (vsLayers spec)) + facetLens spec = mapMaybe colLen + (mapMaybe getLast [vsFacet spec, vsFacetRow spec, vsFacetCol spec]) + colLen cr = case resolveCol r cr of + Just (NumData v) -> Just (V.length v) + Just (TxtData v) -> Just (V.length v) + Nothing -> Nothing + layerMismatch n i ly = + let ctx = DiagnosticContext (Just i) (getFirst (lyKind ly)) + in [ PlotWarning (FacetInlineLengthMismatch a m n) ctx + | (a, cr) <- rowCols ly + , Just m <- [inlineLen cr] + , m /= n ] + inlineLen (ColNum v) = Just (V.length v) + inlineLen (ColTxt v) = Just (V.length v) + inlineLen _ = Nothing + -- layerCols (aes 付き encoding) + size/shape encoding。 chain/label/hover 等は + -- Aesthetic tag が無いため対象外 (要るなら Aesthetic 追加とセットで拡張)。 + rowCols ly = layerCols ly + ++ [ (AesSize, c) | Just c <- [getLast (lySizeBy ly)] ] + ++ [ (AesShape, c) | Just c <- [getLast (lyShapeBy ly)] ] + +-- | [日本語]: ★ 'facetInlineDiagnostics' を stderr へ報告する backend 共用 +-- helper (SVG / PNG / PDF / TeX の save 系入口から呼ぶ)。 診断ゼロなら無音。 +-- 描画は止めない (= 描画継続 + 警告)。 +-- [English]: A backend-shared helper that reports +-- 'facetInlineDiagnostics' to stderr (called from the SVG / PNG / PDF / +-- TeX save entry points). Silent when there are no diagnostics. Does not +-- stop rendering (rendering continues, with a warning). +reportFacetInlineWarnings :: Resolver -> VisualSpec -> IO () +reportFacetInlineWarnings r spec = + mapM_ (hPutStrLn stderr . T.unpack . renderDiagnostic) + (facetInlineDiagnostics r spec) + +-- | [日本語]: 列の解決可否 + 型チェック。 数値要求 aesthetic に文字列列が来たら +-- 型不一致。 +-- [English]: Checks column resolvability plus type. A textual column +-- supplied to a numeric-required aesthetic is a type mismatch. checkCol :: [Text] -> Resolver -> DiagnosticContext -> Aesthetic -> ColRef -> [PlotDiagnostic] checkCol known r ctx aes cr = case cr of ColByName n @@ -348,8 +540,13 @@ [PlotError (ColumnTypeMismatch n aes ExpNumeric ActCategorical) ctx] _ -> [] --- | aesthetic が数値を要求するか。 x/y は mark により categorical 可なので緩く ExpAny。 --- color (continuous 経路で来たもの) と error bar は数値必須。 +-- | [日本語]: aesthetic が数値を要求するか。 x/y は mark により categorical +-- 可なので緩く ExpAny。 color (continuous 経路で来たもの) と error bar は +-- 数値必須。 +-- [English]: Whether an aesthetic requires a numeric value. x/y are left +-- loose as ExpAny since they may be categorical depending on the mark. +-- color (when it arrives via the continuous path) and error bars require +-- numeric values. expectedFor :: Aesthetic -> ExpectedType expectedFor AesErrorX = ExpNumeric expectedFor AesErrorY = ExpNumeric @@ -385,13 +582,19 @@ -- compile (= VisualSpec を「検証済」 でラップ) -- =========================================================================== --- | 検証を通過した 'VisualSpec'。 backend はこれを受け取る形に寄せられる --- (現状は 'compiledSpec' で素の VisualSpec を取り出して既存 backend に渡せる)。 +-- | [日本語]: 検証を通過した 'VisualSpec'。 backend はこれを受け取る形に寄せ +-- られる (現状は 'compiledSpec' で素の VisualSpec を取り出して既存 backend +-- に渡せる)。 +-- [English]: A 'VisualSpec' that has passed validation. Backends can be +-- migrated to accept this type (currently, 'compiledSpec' extracts the +-- plain VisualSpec to pass to existing backends). newtype CompiledPlot = CompiledPlot { compiledSpec :: VisualSpec } deriving (Show) --- | error が無ければ 'CompiledPlot'、 あれば error 一覧を返す --- (warning は通過させる)。 +-- | [日本語]: error が無ければ 'CompiledPlot'、 あれば error 一覧を返す +-- (warning は通過させる)。 +-- [English]: Returns a 'CompiledPlot' if there are no errors, or the list +-- of errors otherwise (warnings are allowed through). compilePlot :: Resolver -> VisualSpec -> Either [PlotDiagnostic] CompiledPlot compilePlot = compilePlotWith [] @@ -428,7 +631,8 @@ FeatInteractive3D -> "interactive 3D" FeatProjected3D -> "3D (CPU projection)" --- | backend ごとの対応機能 (= §5.5)。 +-- | [日本語]: backend ごとの対応機能 (= §5.5)。 +-- [English]: The features each backend supports (§5.5). data BackendCapability = BackendCapability { capName :: BackendName , capTransparency :: Bool @@ -445,7 +649,9 @@ canvasCapability = BackendCapability BackendCanvas True True True False webglCapability = BackendCapability BackendWebGL True True True True --- | spec が使う機能のうち backend 非対応なものを warning 化。 +-- | [日本語]: spec が使う機能のうち backend 非対応なものを warning 化。 +-- [English]: Turns any feature used by the spec that the backend does not +-- support into a warning. checkCapability :: BackendCapability -> VisualSpec -> [PlotDiagnostic] checkCapability cap spec = concatMap layerCap (vsLayers spec) ++ concatMap (checkCapability cap) (vsSubplots spec) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,2670 +5,3938 @@ 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" +import Graphics.Hgg.Render.Common (pointShapeAt, alphaVector, + resolveTheme, specThemePalette, + ThemePalette (..), + effectiveGridWidth, effectiveGridMinorWidth, + effectiveNonCartesianGridWidth, effectiveAxisLineWidth) +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 (★A13: spec 引数追加) + let fItem = 8.8; fTitle = 11.0 + w = legendGuideWidth mempty 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 mempty 8.8 11.0 "" [t] + f "東京" `shouldSatisfy` (> f "ab") -- 全角2 (2.0em) > 半角2 (1.2em) + it "legendGuideWidth: タイトルが最長アイテムより広ければタイトル幅" $ do + -- 短いラベル + 長いタイトル → titleW が勝つ + let w = legendGuideWidth mempty 8.8 11.0 "verylongtitlexxxx" ["a"] + w `shouldBe` 11.0 * textWidthEm "verylongtitlexxxx" + it "legendGuideWidth: ラベル空集合でも key+pad 分の最小幅は確保" $ do + legendGuideWidth mempty 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)] + -- Phase 64 A7: 多角形 clip も dpi scale の対象 (頂点を全て k 倍) + it "k=2: PClipPath の全頂点を倍化" $ + scalePrimitives 2 [PClipPath [Point 1 2, Point 3 4, Point 5 6]] `shouldBe` + [PClipPath [Point 2 4, Point 6 8, Point 10 12]] + + 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)) + it "layers [a, b] == layer (a <> b) (Phase 66 リスト別名)" $ + layers [scatter "x" "y", colorBy "group"] + `shouldBe` layer (scatter "x" "y" <> colorBy "group") + it "layers [] == layer mempty (空 list = 空 Layer 1 枚、 purePlot ではない)" $ + layers [] `shouldBe` layer mempty + + 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) + -- ★ Phase 70 A3: ess の y domain は encY の実 ESS 値から [0, max(100, 最大値)] + -- + baseline (下端 0 固定・上端 5% pad)。 旧実装は encX の長さを MCMC の N と + -- 誤用し、 Text nameCol では n=1000 fallback で ESS 実値を不参照だった。 + it "ess の y domain = [0, ESS 最大値 × 1.05] (encY 実値基準・Phase 70 A3)" $ + let spec = layer (ess (inlineCat (["a", "b", "c"] :: [String])) + (inline [1500, 800, 2000])) + l = computeLayout emptyResolver spec + in (lsDomainLo (lpYScale l), lsDomainHi (lpYScale l)) `shouldBe` (0, 2100) + it "ess の x domain = categorical 経路 [-0.6, n-0.4] (Phase 70 A3)" $ + let spec = layer (ess (inlineCat (["a", "b", "c"] :: [String])) + (inline [1500, 800, 2000])) + l = computeLayout emptyResolver spec + in (lsDomainLo (lpXScale l), lsDomainHi (lpXScale l)) `shouldBe` (-0.6, 2.6) + it "ess の ESS 値が全て閾値 100 未満でも y domain 上端は 100 起点 (閾値線可視)" $ + let spec = layer (ess (inlineCat (["a"] :: [String])) (inline [40])) + l = computeLayout emptyResolver spec + in (lsDomainLo (lpYScale l), lsDomainHi (lpYScale l)) `shouldBe` (0, 105) + 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 + + -- Phase 62: facet が inline encoding (ColNum/ColTxt) を分割しない不具合の回帰。 + -- 「例外が出ない」 だけの smoke にせず **PCircle 数 + 座標** で分割を検証する + -- (旧テストは ColByName 経路のみで inline を素通りさせていた)。 + describe "Phase 62: facet × inline encoding の分割" $ do + let xs4 = [1, 2, 3, 4] :: [Double] + ys4 = [10, 20, 30, 40] :: [Double] + gs4 = ["g1", "g1", "g2", "g2"] :: [Data.Text.Text] + rP n = case n of + "x" -> Just (NumData (V.fromList xs4)) + "y" -> Just (NumData (V.fromList ys4)) + "g" -> Just (TxtData (V.fromList gs4)) + "h" -> Just (TxtData (V.fromList ["h1", "h1", "h1", "h1"])) + _ -> Nothing + circlesOf r spec = + [ (x, y) | PCircle (Point x y) _ _ _ _ <- + renderToPrimitives r (computeLayout r spec) spec ] + + it "inline encoding + inline facet 列 → 4 点 (報告者ケースの回帰)" $ + let spec = layer (scatter (inline xs4) (inline ys4)) + <> facet (inlineCat gs4) + in length (circlesOf emptyResolver spec) `shouldBe` 4 + + it "inline encoding + 名前参照 facet 列 → 4 点" $ + let spec = layer (scatter (inline xs4) (inline ys4)) <> facet "g" + in length (circlesOf rP spec) `shouldBe` 4 + + it "名前参照 + scaleXDiscreteLimits + facet → 4 点 (経路 2 = bakeSpec 強制 inline 化の回帰)" $ + let spec = layer (scatter "x" "y") <> facet "g" + <> scaleXDiscreteLimits ["dummy"] + in length (circlesOf rP spec) `shouldBe` 4 + + it "facetGrid + inline encoding → 4 点 (grid 経路の回帰)" $ + let spec = layer (scatter (inline xs4) (inline ys4)) <> facetGrid "g" "h" + in length (circlesOf rP spec) `shouldBe` 4 + + -- 座標レベル: どの点がどの panel に入ったかを検証 (総数だけでは分割先の + -- 入れ替わりを検出できない)。 panel はアルファベット順で g1=左, g2=右。 + -- fixed 共有 y scale では screen y は data y に単調減少なので、 g1 の 2 点 + -- (y=10,20) の screen y は g2 の 2 点 (y=30,40) より必ず大きい。 + it "座標レベル: 左 panel = g1 (y=10,20)、 右 panel = g2 (y=30,40)" $ + let spec = layer (scatter (inline xs4) (inline ys4)) + <> facet (inlineCat gs4) + cs = Data.List.sortOn fst (circlesOf emptyResolver spec) + (leftPts, rightPts) = splitAt 2 cs + allBelow = and [ yl > yr | (_, yl) <- leftPts, (_, yr) <- rightPts ] + in (length cs, allBelow) `shouldBe` (4, True) + + -- §3: facet 列と長さの合わない inline は黙って切り詰めず据え置き (= 未分割の + -- まま全 panel に描かれる) + 警告診断。 その挙動を固定する。 + it "長さ不一致 inline (5 行 vs facet 4 行) は据え置き = 全 panel に 5 点ずつ" $ + let spec = layer (scatter (inline [1, 2, 3, 4, 5 :: Double]) + (inline [1, 2, 3, 4, 5 :: Double])) + <> facet (inlineCat gs4) + in length (circlesOf emptyResolver spec) `shouldBe` 10 + + it "長さ不一致は facetInlineDiagnostics が警告 (x, y の 2 本)" $ + let spec = layer (scatter (inline [1, 2, 3, 4, 5 :: Double]) + (inline [1, 2, 3, 4, 5 :: Double])) + <> facet (inlineCat gs4) + in length (facetInlineDiagnostics emptyResolver spec) `shouldBe` 2 + + it "limits の行 drop で facet と desync した場合も警告 (既知の限界の検出)" $ + let rc n = case n of + "xc" -> Just (TxtData (V.fromList ["a", "b", "c", "d"])) + "y" -> Just (NumData (V.fromList ys4)) + "g" -> Just (TxtData (V.fromList gs4)) + _ -> Nothing + spec = layer (bar "xc" "y") <> facet "g" + <> scaleXDiscreteLimits ["a", "b", "c"] + in length (facetInlineDiagnostics rc spec) `shouldBe` 2 + + it "全長一致なら警告ゼロ" $ + let spec = layer (scatter (inline xs4) (inline ys4)) + <> facet (inlineCat gs4) + in facetInlineDiagnostics emptyResolver spec `shouldBe` [] + + 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 defaultPolarOpts) + + it "coordPolarY setter は vsCoord = CoordPolarY を立てる" $ + getLast (vsCoord coordPolarY) `shouldBe` Just (CoordPolarY defaultPolarOpts) + + it "isPolar: polar のみ True" $ + map isPolar [ CoordCartesian, CoordFlip, CoordPolarX defaultPolarOpts + , CoordPolarY defaultPolarOpts, CoordTernary defaultTernaryOpts ] + `shouldBe` [False, False, True, True, False] + + 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) + + -- ★ Phase 64 A10 (= §3 + §4-1 合流): Coord ADT の JSON codec 後方互換 + + -- CoordTernary + polar start/direction。 + it "Coord JSON: 既定 polar / cartesian / flip / ternary は文字列 tag (後方互換)" $ + map encode [ CoordCartesian, CoordFlip, CoordPolarX defaultPolarOpts + , CoordPolarY defaultPolarOpts, CoordTernary defaultTernaryOpts ] + `shouldBe` [ "\"cartesian\"", "\"flip\"", "\"polarx\"", "\"polary\"", "\"ternary\"" ] + + it "Coord JSON: 旧 spec の \"polarx\"/\"polary\" 文字列は既定 opts で読める" $ + ( eitherDecode "\"polarx\"", eitherDecode "\"polary\"", eitherDecode "\"ternary\"" ) + `shouldBe` ( Right (CoordPolarX defaultPolarOpts) + , Right (CoordPolarY defaultPolarOpts) + , Right (CoordTernary defaultTernaryOpts) ) + + it "Coord JSON: 非既定 start/direction は object 形で往復する (文字列でなくなる)" $ + let c = CoordPolarX (PolarOpts 1.5 (-1)) + in ( eitherDecode (encode c), encode c /= "\"polarx\"" ) + `shouldBe` ( Right c, True ) + + it "Coord JSON: object 形で start/direction 欠落は既定で補完" $ + ( eitherDecode "{\"tag\":\"polarx\"}" + , eitherDecode "{\"tag\":\"polary\",\"start\":0.5}" ) + `shouldBe` ( Right (CoordPolarX defaultPolarOpts) + , Right (CoordPolarY (PolarOpts 0.5 1)) ) + + it "coordPolarWith / coordPolarYWith / coordTernary setter" $ + ( getLast (vsCoord (coordPolarWith 1 (-1))) + , getLast (vsCoord (coordPolarYWith 0 1)) + , getLast (vsCoord coordTernary) ) + `shouldBe` ( Just (CoordPolarX (PolarOpts 1 (-1))) + , Just (CoordPolarY defaultPolarOpts) + , Just (CoordTernary defaultTernaryOpts) ) + + -- ★ Phase 69 A4: 三角座標の向き opts (TernaryOpts / coordTernaryWith)。 + it "Phase 69 A4: 既定 opts は \"ternary\" 文字列 (後方互換)・旧文字列を既定で読む" $ + ( encode (CoordTernary defaultTernaryOpts), eitherDecode "\"ternary\"" ) + `shouldBe` ( "\"ternary\"", Right (CoordTernary defaultTernaryOpts) ) + it "Phase 69 A4: 非既定 TernaryOpts は object 形で往復 (文字列でなくなる)" $ + let c = CoordTernary (TernaryOpts True 120) + in ( eitherDecode (encode c), encode c /= "\"ternary\"" ) `shouldBe` ( Right c, True ) + it "Phase 69 A4: object 形の clockwise/rotate 欠落は既定で補完" $ + ( eitherDecode "{\"tag\":\"ternary\"}" + , eitherDecode "{\"tag\":\"ternary\",\"clockwise\":true}" ) + `shouldBe` ( Right (CoordTernary defaultTernaryOpts) + , Right (CoordTernary (TernaryOpts True 0)) ) + it "Phase 69 A4: coordTernaryWith setter が opts を立てる" $ + getLast (vsCoord (coordTernaryWith True 120)) + `shouldBe` Just (CoordTernary (TernaryOpts True 120)) + it "Phase 69 A4: clockwise は左下↔右下 頂点を入れ替える (top 不変)" $ + let layD = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]] <> coordTernary) + layC = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]] <> coordTernaryWith True 0) + (aD, bD, cD) = ternaryVertices layD + (aC, bC, cC) = ternaryVertices layC + in (aD == aC, bD == cC, cD == bC) `shouldBe` (True, True, True) + it "Phase 69 A4: rotate 120 は成分→頂点を巡回 (a が旧 b=左下 の位置へ)" $ + let layD = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]] <> coordTernary) + layR = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]] <> coordTernaryWith False 120) + (_, bD, _) = ternaryVertices layD + (aR, _, _) = ternaryVertices layR + in aR `shouldBe` bD + + it "polarPoint: start=π/2 は θ=0 r=1 を右へ回す (既定の真上から 90° 回転)" $ + let layS = computeLayout emptyResolver + (overlay [points [0, 1, 2, 3] [0, 1, 2, 3]] <> coordPolarWith (pi / 2) 1) + (sx0, sy0) = polarPoint layS 0 1 + in ( abs (sx0 - (ccx + cmaxR)) < 1e-6, abs (sy0 - ccy) < 1e-6 ) + `shouldBe` (True, True) + + it "polarPoint: direction=-1 は θ=0.25 を右ではなく左へ (反時計回り)" $ + let layR = computeLayout emptyResolver + (overlay [points [0, 1, 2, 3] [0, 1, 2, 3]] <> coordPolarWith 0 (-1)) + (rx, ry) = polarPoint layR 0.25 1 + in ( abs (rx - (ccx - cmaxR)) < 1e-6, abs (ry - ccy) < 1e-6 ) + `shouldBe` (True, True) + + -- ★ Phase 64 A11 (= §3-2): ternary 第 3 位置 aesthetic (encZ) + 第 3 scale + 正規化。 + it "isTernary: CoordTernary のみ True" $ + map isTernary [ CoordCartesian, CoordFlip, CoordPolarX defaultPolarOpts + , CoordPolarY defaultPolarOpts, CoordTernary defaultTernaryOpts ] + `shouldBe` [False, False, False, False, True] + + -- ★ Phase 69 A3: mark 束ね (ternaryScatter/ternaryLine) + coord 推論。 + it "Phase 69 A3: ternaryScatter = scatter <> encZ (Layer 等価)" $ + ternaryScatter (ColByName "a") (ColByName "b") (ColByName "c") + `shouldBe` (scatter (ColByName "a") (ColByName "b") <> encZ (ColByName "c")) + it "Phase 69 A3: coordOf は encZ から CoordTernary を推論 (coord 未指定)" $ + coordOf (layer (ternaryScatter (ColByName "a") (ColByName "b") (ColByName "c"))) + `shouldBe` CoordTernary defaultTernaryOpts + it "Phase 69 A3: encZ 無しは CoordCartesian (推論しない)" $ + coordOf (layer (scatter (ColByName "a") (ColByName "b"))) `shouldBe` CoordCartesian + it "Phase 69 A3: 明示 coord は推論より優先 (encZ ありでも coordFlip)" $ + coordOf (layer (ternaryScatter (ColByName "a") (ColByName "b") (ColByName "c")) <> coordFlip) + `shouldBe` CoordFlip + it "Phase 69 A3: layer (ternaryScatter ...) は明示 coordTernary 形と同一 primitive" $ + let sa = layer (ternaryScatter (inline [0.2, 0.3, 0.5 :: Double]) + (inline [0.3, 0.4, 0.2]) (inline [0.5, 0.3, 0.3])) + sb = layer (scatter (inline [0.2, 0.3, 0.5 :: Double]) (inline [0.3, 0.4, 0.2]) + <> encZ (inline [0.5, 0.3, 0.3])) <> coordTernary + in renderToPrimitives emptyResolver (computeLayout emptyResolver sa) sa + `shouldBe` renderToPrimitives emptyResolver (computeLayout emptyResolver sb) sb + + it "normalizeTernary: 合計≠1 は a/(a+b+c) に正規化" $ + normalizeTernary (1, 1, 2) `shouldBe` Just (0.25, 0.25, 0.5) + + it "normalizeTernary: 合計=1 は恒等" $ + normalizeTernary (0.2, 0.3, 0.5) `shouldBe` Just (0.2, 0.3, 0.5) + + it "normalizeTernary: 退化行 (負値 / 合計≤0) は Nothing (行ごと除外)" $ + ( normalizeTernary (-1, 2, 3) -- 負値 + , normalizeTernary (0, 0, 0) -- 合計 0 + , normalizeTernary (2, -1, -1) ) -- 合計 0 かつ負値 + `shouldBe` (Nothing, Nothing, Nothing) + + it "encZ setter は lyEncZ を立てる / zLabel は vsZLabel を立てる" $ + ( getLast (lyEncZ (encZ (ColByName "c"))) + , getLast (vsZLabel (zLabel "third")) ) + `shouldBe` (Just (ColByName "c"), Just "third") + + it "第 3 scale: ternary のみ Just [0,1] + tick、 非 ternary は Nothing/[]" $ + let layT = computeLayout emptyResolver + (overlay [points [0, 1] [0, 1] <> encZ (ColByName "c")] <> coordTernary) + layC = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]]) + in ( lpZScale layT, null (lpZTicks layT), lpZScale layC, lpZTicks layC ) + `shouldBe` + ( Just (LinearScale 0 1 0 1), False, Nothing, [] ) + + it "既存 2 軸の図に無影響: 非 ternary の lpXScale/lpYScale は encZ 追加で不変" $ + let base = overlay [points [0, 1, 2] [0, 3, 6]] + withZ = overlay [points [0, 1, 2] [0, 3, 6] <> encZ (ColByName "c")] + lb = computeLayout emptyResolver base + lz = computeLayout emptyResolver withZ + in (lpXScale lb, lpYScale lb) `shouldBe` (lpXScale lz, lpYScale lz) + + it "ternary spec (coordTernary + encZ + zLabel) は JSON 往復する" $ + let s = layer (scatter (ColByName "a") (ColByName "b") <> encZ (ColByName "c")) + <> coordTernary <> zLabel "C" + in eitherDecode (encode s) `shouldBe` Right s + + -- ★ Phase 64 A12 (= §3-3): ternaryPoint 投影の幾何。 + it "ternaryPoint: 3 純成分は 3 頂点 (a=上・b=左下・c=右下)" $ + let layT = computeLayout emptyResolver + (overlay [points [0, 1] [0, 1]] <> coordTernary) + (tcx, tcy, tr) = ternaryCenter layT + s = sqrt 3 / 2 + near (x, y) (x', y') = abs (x - x') < 1e-6 && abs (y - y') < 1e-6 + in ( near (ternaryPoint layT (1, 0, 0)) (tcx, tcy - tr) -- 上 + , near (ternaryPoint layT (0, 1, 0)) (tcx - tr * s, tcy + tr / 2) -- 左下 + , near (ternaryPoint layT (0, 0, 1)) (tcx + tr * s, tcy + tr / 2) ) -- 右下 + `shouldBe` (True, True, True) + + it "ternaryPoint: 重心 (1/3,1/3,1/3) は三角形の中心" $ + let layT = computeLayout emptyResolver + (overlay [points [0, 1] [0, 1]] <> coordTernary) + (tcx, tcy, _) = ternaryCenter layT + (px, py) = ternaryPoint layT (1/3, 1/3, 1/3) + in ( abs (px - tcx) < 1e-6, abs (py - tcy) < 1e-6 ) `shouldBe` (True, True) + + it "ternaryVertices: 正三角形 (3 辺長が等しい)" $ + let layT = computeLayout emptyResolver + (overlay [points [0, 1] [0, 1]] <> coordTernary) + ((ax, ay), (bx, by), (cx, cy)) = ternaryVertices layT + dist (x0, y0) (x1, y1) = sqrt ((x1-x0)^(2::Int) + (y1-y0)^(2::Int)) + dAB = dist (ax, ay) (bx, by) + dBC = dist (bx, by) (cx, cy) + dCA = dist (cx, cy) (ax, ay) + in ( abs (dAB - dBC) < 1e-6, abs (dBC - dCA) < 1e-6 ) `shouldBe` (True, True) + + it "projectXY CoordTernary: (a,b) は c=1-a-b を補完して ternaryPoint と一致" $ + let layT = computeLayout emptyResolver + (overlay [points [0, 1] [0, 1]] <> coordTernary) + in projectXY (CoordTernary defaultTernaryOpts) layT 0.5 0.3 + `shouldBe` ternaryPoint layT (0.5, 0.3, 0.2) + + -- ★ Phase 64 A13 (= §3-4): geom が encZ を解決し 3 列で ternary 投影する経路。 + it "A13 ternary scatter: encZ を解決し正規化 (c≠1-a-b でも真の点)" $ + -- 行 (a,b,c)=(1,1,2): 合計 4 → 正規化 (0.25,0.25,0.5)。 旧 2 引数補完 (c=1-1-1=-1) + -- とは別の位置になる = encZ を実際に使っている証拠。 + let spec = overlay [ points [1] [1] <> encZ (inline [2 :: Double]) ] <> coordTernary + layT = computeLayout emptyResolver spec + ps = renderToPrimitives emptyResolver layT spec + centers = [ (x, y) | PCircle (Point x y) _ _ _ _ <- ps ] + near (x, y) (x', y') = abs (x - x') < 1e-6 && abs (y - y') < 1e-6 + in ( length centers + , all (\p -> near p (ternaryPoint layT (0.25, 0.25, 0.5))) centers ) + `shouldBe` (1, True) + + it "A13 ternary scatter: 退化行 (負 encZ) は落ちる (点数が減る)" $ + -- 中央行 z=-5 は normalizeTernary が Nothing → NaN → 描画対象から除外。 + let spec = overlay [ points [1, 1, 1] [1, 1, 1] + <> encZ (inline [1, -5, 1 :: Double]) ] <> coordTernary + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver spec) spec + in length [() | PCircle{} <- ps] `shouldBe` 2 + + it "A13 ternary line: 退化行は詰められ線分が n'-1 本 (NaN 除外)" $ + -- 3 行のうち中央が退化 → 有効 2 点 → PLine 1 本 (line layer 由来)。 grid/frame の + -- PLine と区別するため、 退化を含む場合 (1 本) と含まない場合 (2 本) の差で見る。 + let mk zs = let spec = overlay [ line (inline [0, 1, 2 :: Double]) (inline [0, 1, 2]) + <> encZ (inline zs) ] <> coordTernary + in length [() | PLine{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver spec) spec ] + in (mk [1, 1, 1 :: Double] - mk [1, -5, 1 :: Double]) `shouldBe` 1 + + it "A13 ternary warn: 非対応 mark (bar) は TernaryUnsupportedMark 警告" $ + let spec = layer (bar (inline [0, 1 :: Double]) (inline [1, 2 :: Double])) + <> coordTernary + ws = [ () | PlotWarning (TernaryUnsupportedMark _) _ + <- validatePlot emptyResolver spec ] + in length ws `shouldBe` 1 + + it "A13 ternary warn: point/line/area/text は警告なし" $ + let mkWarns mk = length + [ () | PlotWarning (TernaryUnsupportedMark _) _ + <- validatePlot emptyResolver (layer mk <> coordTernary) ] + in map mkWarns + [ scatter (inline [0, 1 :: Double]) (inline [1, 2 :: Double]) + , line (inline [0, 1 :: Double]) (inline [1, 2 :: Double]) + , band (inline [0, 1 :: Double]) (inline [0, 0 :: Double]) + (inline [1, 2 :: Double]) + , text (inline [0, 1 :: Double]) (inline [1, 2 :: Double]) + (inlineCat ["a", "b" :: Data.Text.Text]) ] + `shouldBe` [0, 0, 0, 0] + + it "Phase 69 A3: encZ 追加は coord 推論で ternary 化し PCircle 位置が変わる (旧 A13 no-op 契約を更新)" $ + -- Phase 64 A13 は「非 ternary で encZ は no-op (位置不変)」だったが、 Phase 69 A3 で + -- encZ を CoordTernary の推論トリガに契約変更 (encZ は ternary 専用 aesthetic ゆえ実害なし。 + -- coordOf に「明示 coord 未指定 + encZ あり → ternary」を追加)。 明示 coord を置けば従来優先。 + let base = layer (scatter (inline [0, 1, 2 :: Double]) (inline [0, 1, 4 :: Double])) + withZ = layer (scatter (inline [0, 1, 2 :: Double]) (inline [0, 1, 4 :: Double]) + <> encZ (inline [9, 9, 9 :: Double])) + centers s = [ (x, y) | PCircle (Point x y) _ _ _ _ + <- renderToPrimitives emptyResolver (computeLayout emptyResolver s) s ] + in (centers base /= centers withZ) `shouldBe` True + + -- ★ Phase 64 A2: 投影層への集約口 (projectSegment / projectBar) + it "projectSegment Cartesian: 両端 2 点で projectXY と一致" $ + let layC = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]]) + pts = projectSegment CoordCartesian layC (0, 0) (1, 1) + p0 = uncurry Point (projectXY CoordCartesian layC 0 0) + p1 = uncurry Point (projectXY CoordCartesian layC 1 1) + in pts `shouldBe` [p0, p1] + + it "projectSegment polar: θ 不変 (純 radial) は 2 点のまま" $ + length (projectSegment (CoordPolarX defaultPolarOpts) lay (1, 0) (1, 3)) `shouldBe` 2 + + it "projectSegment polar: r 一定の 1/4 周は弧にサンプルされ全点が同半径" $ + -- x domain 0..3 の x=0→x=1.5 は θfrac 0.5×(expansion 補正)。 サンプル数 ≥ 3 と + -- 「全点が中心から同距離」 (= 弧、 直線なら中点が凹む) を確認する。 + let ptsArc = projectSegment (CoordPolarX defaultPolarOpts) lay (0, 3) (1.5, 3) + ds = [ sqrt ((x - ccx) ^ (2 :: Int) + (y - ccy) ^ (2 :: Int)) + | Point x y <- ptsArc ] + in ( length ptsArc > 2 + , maximum ds - minimum ds < 1e-6 ) + `shouldBe` (True, True) + + it "projectBar Cartesian: BarRect = projectBarRect と bit 一致" $ + let layC = computeLayout emptyResolver + (layer (bars [1, 2, 3] [4, 7, 5])) + in projectBar CoordCartesian layC 1 0 4 0.45 20 + `shouldBe` BarRect (projectBarRect CoordCartesian layC 1 0 4 20) + + it "projectBar PolarX: BarWedge = wedgeSegments (旧 mkWedge の式) と一致" $ + let s = layer (bars [1, 2, 3, 4] [4, 7, 5, 9]) <> coordPolar + layP = computeLayout emptyResolver s + spanX = lsDomainHi (lpXScale layP) - lsDomainLo (lpXScale layP) + hw = 0.45 / spanX + dfx = domFrac (lpXScale layP) + dfy = domFrac (lpYScale layP) + in projectBar (CoordPolarX defaultPolarOpts) layP 1 0 4 0.45 999 + `shouldBe` BarWedge (wedgeSegments layP (dfx 1 - hw) (dfx 1 + hw) + (dfy 0) (dfy 4)) + + 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 64 A8: polar 外周円 clip (B-2) と θ ラベル位置 (B-3)。 + -- ggplot2 coord-polar.R の npc 定数に準拠: データ最大半径 = 0.4・ + -- θ ラベル / 外周円 = 0.45 (= polarOuterFrac)。 根拠は Layout.hs polarCenter。 + -- ===================================================================== + it "polarCenter: データ最大半径 = 0.4 * min(w,h) (ggplot2 npc donut 上限)" $ + let ar = lpPlotArea lay + in abs (cmaxR - 0.4 * min (rW ar) (rH ar)) < 1e-9 `shouldBe` True + + it "polarOuterFrac = 0.45 / 0.4 (θ ラベル npc 0.45 / データ npc 0.4)" $ + abs (polarOuterFrac - 0.45 / 0.4) < 1e-12 `shouldBe` True + + it "polarClipPath: 180 頂点で全点が外周円 (= maxR) 上に載る" $ + let pts = polarClipPath lay + ds = [ sqrt ((x - ccx) ^ (2 :: Int) + (y - ccy) ^ (2 :: Int)) + | (x, y) <- pts ] + in ( length pts, maximum ds - minimum ds < 1e-6 + , abs (maximum ds - cmaxR) < 1e-6 ) + `shouldBe` (180, True, True) + + it "polar は外周円で clip される: PClipPath が 1 本出て 180 頂点 (B-2)" $ + let s = layer (points [0, 1, 2, 3] [0, 1, 2, 3]) <> coordPolar + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver s) s + in [ length pts | PClipPath pts <- ps ] `shouldBe` [180] + + it "Cartesian は PClipPath を出さない (polar 専用・既存図ゼロ diff)" $ + let s = layer (points [0, 1, 2, 3] [0, 1, 2, 3]) + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver s) s + in [ () | PClipPath{} <- ps ] `shouldBe` [] + + it "θ ラベルは外周円上 (= polarOuterFrac の半径) に置かれる (B-3)" $ + -- polar-errorbar 相当 (pointRange x=1..6)。 θ ラベルの中心が npc 0.45 の + -- 円周上に載る (= 旧 1.12 決め打ち + panel 内接 maxR による panel はみ出しの解消)。 + let s = layer (pointRange (inline [1.0, 2, 3, 4, 5, 6]) + (inline [4.0, 5.5, 4.8, 6.2, 5.0, 5.8]) + (inline [0.6, 0.5, 0.8, 0.4, 0.7, 0.5])) + <> coordPolar + layE = computeLayout emptyResolver s + (ex, ey, emaxR) = polarCenter layE + ps = renderToPrimitives emptyResolver layE s + -- θ ラベルは AnchorMiddle (r 軸ラベルは AnchorEnd) で区別できる。 + -- 数字は θ (x=1..6) と r 軸 tick (4,5,6) で衝突するため anchor で絞る。 + -- +4 の y offset を戻して半径を測る。 + labelRs = [ sqrt ((x - ex) ^ (2 :: Int) + (y - 4 - ey) ^ (2 :: Int)) + | PText (Point x y) t ts <- ps + , t `elem` ["1","2","3","4","5","6"] + , tsAnchor ts == AnchorMiddle ] + in ( length labelRs + , all (\r -> abs (r - emaxR * polarOuterFrac) < 1e-6) labelRs ) + `shouldBe` (6, True) + + it "θ ラベルが plotArea (panel) の内側に収まる (タイトルと重ならない)" $ + let s = layer (pointRange (inline [1.0, 2, 3, 4, 5, 6]) + (inline [4.0, 5.5, 4.8, 6.2, 5.0, 5.8]) + (inline [0.6, 0.5, 0.8, 0.4, 0.7, 0.5])) + <> coordPolar + layE = computeLayout emptyResolver s + ar = lpPlotArea layE + ps = renderToPrimitives emptyResolver layE s + labelYs = [ y | PText (Point _ y) t ts <- ps + , t `elem` ["1","2","3","4","5","6"] + , tsAnchor ts == AnchorMiddle ] + in all (\y -> y >= rY ar - 1e-6 && y <= rY ar + rH ar + 1e-6) labelYs + `shouldBe` True + + -- ★ Phase 64 A18 (= §4-3): θ 軸ラベルの回転を theme の axis.text 角に従わせる。 + -- θ を担う軸は coord で変わる (PolarX=x / PolarY=y)。 既定 (角度未指定) は + -- rot 0 のまま = 既存 golden ゼロ diff。 θ ラベルは AnchorMiddle で識別。 + -- ===================================================================== + let polarThetaRots extra = + let s = layer (pointRange (inline [1.0, 2, 3, 4, 5, 6]) + (inline [4.0, 5.5, 4.8, 6.2, 5.0, 5.8]) + (inline [0.6, 0.5, 0.8, 0.4, 0.7, 0.5])) + <> extra + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver s) s + in [ tsRotate ts | PText _ t ts <- ps + , t `elem` ["1","2","3","4","5","6"] + , tsAnchor ts == AnchorMiddle ] + + it "既定 (角度未指定) の polar θ ラベルは rot 0 (= 既存 golden ゼロ diff)" $ + let rots = polarThetaRots coordPolar + in (length rots, all (== 0) rots) `shouldBe` (6, True) + + it "themeAxisTextAngleX 45 で PolarX の θ ラベルが 45° 回転する" $ + let rots = polarThetaRots (coordPolar <> themeAxisTextAngleX 45) + in (length rots, all (== 45) rots) `shouldBe` (6, True) + + it "PolarY では θ = y 軸なので themeAxisTextAngleY が θ ラベルに効く" $ + let rots = polarThetaRots (coordPolarY <> themeAxisTextAngleY 30) + in all (== 30) rots `shouldBe` True + + it "PolarX の θ ラベルは Y 側角 (themeAxisTextAngleY) では回らない (軸の取り違え防止)" $ + let rots = polarThetaRots (coordPolar <> themeAxisTextAngleY 60) + in all (== 0) rots `shouldBe` True + + -- ★ Phase 64 A3: categorical-cross geom 用の投影口 (CrossLoc 系)。 + -- 直線座標系は「旧 geom 内 px 式と bit 一致」 が契約 (golden 差分ゼロの根拠)。 + it "projectCrossPoint Cartesian: Point (sx d + off) (sy v) と bit 一致" $ + let layC = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]]) + sx = scaleApply (lpXScale layC) + sy = scaleApply (lpYScale layC) + in projectCrossPoint CoordCartesian layC (CrossAt 1) 7 0.5 + `shouldBe` Point (sx 1 + 7) (sy 0.5) + + it "projectCrossPoint Flip: Point (syF v) (sxF d + off) と bit 一致" $ + let layF = computeLayout emptyResolver + (overlay [points [0, 1] [0, 1]] <> coordFlip) + sxF = scaleApply (lpXScaleFlipped layF) + syF = scaleApply (lpYScaleFlipped layF) + in projectCrossPoint CoordFlip layF (CrossAt 1) 7 0.5 + `shouldBe` Point (syF 0.5) (sxF 1 + 7) + + it "projectCrossPoint CrossMid Cartesian: cross = plotArea 中央 + off" $ + let layC = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]]) + ar = lpPlotArea layC + sy = scaleApply (lpYScale layC) + in projectCrossPoint CoordCartesian layC CrossMid 3 0.5 + `shouldBe` Point (rX ar + rW ar / 2 + 3) (sy 0.5) + + it "projectCrossPoint PolarX off=0: projectXY と一致" $ + projectCrossPoint (CoordPolarX defaultPolarOpts) lay (CrossAt 1) 0 2 + `shouldBe` uncurry Point (projectXY (CoordPolarX defaultPolarOpts) lay 1 2) + + it "projectCrossPoint PolarX の px offset は接線方向 (半径不変・弧長 ≈ off)" $ + let Point x0 y0 = projectCrossPoint (CoordPolarX defaultPolarOpts) lay (CrossAt 1) 0 2 + Point x1 y1 = projectCrossPoint (CoordPolarX defaultPolarOpts) lay (CrossAt 1) 5 2 + rOf x y = sqrt ((x - ccx) ^ (2 :: Int) + (y - ccy) ^ (2 :: Int)) + chord = sqrt ((x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int)) + in ( abs (rOf x1 y1 - rOf x0 y0) < 1e-9 -- 半径が変わらない (= 回転) + , abs (chord - 5) < 0.1 ) -- 弧長 5px ≈ 弦長 + `shouldBe` (True, True) + + it "projectCrossPoint PolarY の px offset は radial (半径が off だけ増える)" $ + let layY = computeLayout emptyResolver + (overlay [points [0, 1, 2, 3] [0, 1, 2, 3]] <> coordPolarY) + (cyx, cyy, _) = polarCenter layY + rOf (Point x y) = sqrt ((x - cyx) ^ (2 :: Int) + (y - cyy) ^ (2 :: Int)) + p0 = projectCrossPoint (CoordPolarY defaultPolarOpts) layY (CrossAt 2) 0 1 + p1 = projectCrossPoint (CoordPolarY defaultPolarOpts) layY (CrossAt 2) 5 1 + in abs (rOf p1 - (rOf p0 + 5)) < 1e-9 `shouldBe` True + + it "projectCrossSpan Cartesian: [off-half, off+half] の 2 点で bit 一致" $ + let layC = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]]) + in projectCrossSpan CoordCartesian layC (CrossAt 1) 2 8 0.45 0.5 + `shouldBe` [ projectCrossPoint CoordCartesian layC (CrossAt 1) (2 - 8) 0.5 + , projectCrossPoint CoordCartesian layC (CrossAt 1) (2 + 8) 0.5 ] + + it "projectCrossSpan polar: data 半幅の弧 (3 点以上・全点同半径)" $ + let ptsA = projectCrossSpan (CoordPolarX defaultPolarOpts) lay (CrossAt 1.5) 0 999 1.0 3 + ds = [ sqrt ((x - ccx) ^ (2 :: Int) + (y - ccy) ^ (2 :: Int)) + | Point x y <- ptsA ] + in ( length ptsA > 2, maximum ds - minimum ds < 1e-6 ) + `shouldBe` (True, True) + + it "projectCrossBar Cartesian: 旧 mkRect 式 (cc±halfPx × min/abs) と bit 一致" $ + let layC = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]]) + sx = scaleApply (lpXScale layC) + sy = scaleApply (lpYScale layC) + cc = sx 1 + 2 + in projectCrossBar CoordCartesian layC (CrossAt 1) 2 8 0.45 0.2 0.7 + `shouldBe` BarRect (Rect (cc - 8) (min (sy 0.2) (sy 0.7)) + (2 * 8) (abs (sy 0.7 - sy 0.2))) + + it "projectCrossBar polar: off=0 は projectBar の wedge と一致" $ + projectCrossBar (CoordPolarX defaultPolarOpts) lay (CrossAt 1) 0 999 0.45 0 2 + `shouldBe` projectBar (CoordPolarX defaultPolarOpts) lay 1 0 2 0.45 0 + + -- A1 実測の決定的証拠 (box は coordPolar 有無で geom PRect 完全一致 = Cartesian + -- 落ち) の解消ゲート: polar box の箱は wedge (PPath) で出る。 + it "polar + boxplot は箱が wedge (PPath) になる (Phase 64 A3 polar 落ち解消)" $ + let sp = layer (boxplot (inline [1.0, 2, 3, 4, 5, 6, 7, 100])) <> coordPolar + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver sp) sp + in (length [() | PPath{} <- ps] >= 1) `shouldBe` True + + -- ★ Phase 64 A5: linerange / pointrange の区間。 旧実装は低端の px x を両端に + -- 流用して画面垂直の線分を組んでいたため、 flip では両端が同一点に潰れて + -- (= 長さ 0) 誤差棒が消え、 polar では半径方向にならなかった。 primitive の + -- 「本数」 は旧実装でも変わらないので gallery count 回帰では捕まらない。 + -- ここでは幾何 (長さ・向き) を直接押さえる。 + it "pointRange flip: 誤差棒が長さ 0 に潰れない (Phase 64 A5)" $ + let sp = layer (pointRange (inline [1.0, 2, 3]) (inline [4.0, 5, 6]) + (inline [0.5, 0.5, 0.5])) + <> coordFlip + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver sp) sp + degenerate = [ () | PLine (Point x1 y1) (Point x2 y2) _ <- ps + , abs (x1 - x2) < 1e-9 && abs (y1 - y2) < 1e-9 ] + in length degenerate `shouldBe` 0 + + it "pointRange polar: 誤差棒が中心を向く半径方向の線分になる (Phase 64 A5)" $ + let sp = layer (pointRange (inline [1.0, 2, 3, 4]) (inline [4.0, 5, 6, 5]) + (inline [0.5, 0.5, 0.5, 0.5])) + <> coordPolar + lay = computeLayout emptyResolver sp + ps = renderToPrimitives emptyResolver lay sp + (cx, cy, _) = polarCenter lay + -- 誤差棒 = grid の spoke (中心が端点) 以外の線分。 その延長線が中心を通る + -- = 中心・両端が同一直線上 (外積 ≒ 0)。 + atCenter x y = abs (x - cx) < 1e-6 && abs (y - cy) < 1e-6 + bars = [ (x1, y1, x2, y2) + | PLine (Point x1 y1) (Point x2 y2) _ <- ps + , not (atCenter x1 y1), not (atCenter x2 y2) ] + radial (x1, y1, x2, y2) = + abs ((x1 - cx) * (y2 - cy) - (y1 - cy) * (x2 - cx)) < 1e-6 + in (length bars, all radial bars) `shouldBe` (4, True) + + it "errorY の cap は polar で弧になる (弦のままでない、 Phase 64 A5)" $ + let sp k = layer (scatter (inline [1.0, 2, 3]) (inline [4.0, 5, 6]) + <> errorY (inline [0.5, 0.5, 0.5])) <> k + nLine k = let s = sp k + in length [ () | PLine{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver s) s ] + -- 直線座標系では cap は 2 点 (1 本) のまま。 polar では x 方向に跨るので + -- 0.1 rad 刻みでサンプルされ本数が増える。 + in (nLine coordPolar > nLine mempty) `shouldBe` True + + it "valueAxisPx: Cartesian = sy / Flip = syF と bit 一致" $ + let layC = computeLayout emptyResolver (overlay [points [0, 1] [0, 1]]) + layF = computeLayout emptyResolver + (overlay [points [0, 1] [0, 1]] <> coordFlip) + in ( valueAxisPx CoordCartesian layC 0.3 + == scaleApply (lpYScale layC) 0.3 + , valueAxisPx CoordFlip layF 0.3 + == scaleApply (lpYScaleFlipped layF) 0.3 ) + `shouldBe` (True, True) + + -- ★ Phase 71 A2: crossbar の投影層経由化。 旧実装は px 空間の PRect 直書きで、 + -- flip では pp x (y±e) の第 2 成分が両方 cross 位置になり箱の高さ 0 (実バグ、 + -- A1 dump 実測: PRect h=0.0 が 6 本)、 polar では平面矩形のままだった。 + -- primitive の本数は変わらないので count 回帰では捕まらない → 幾何を直接押さえる。 + it "crossbar flip: 箱が高さ 0 に潰れない (Phase 71 A2)" $ + let sp = layer (crossbar (inline [1.0, 2, 3]) (inline [4.0, 5, 6]) + (inline [0.5, 0.5, 0.5])) + <> coordFlip + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver sp) sp + -- crossbar の箱 = fill opacity 0.15 の PRect (panel/背景と区別) + boxes = [ (w0, h0) | PRect (Rect _ _ w0 h0) (FillStyle _ o) _ <- ps + , abs (o - 0.15) < 1e-9 ] + in (length boxes, all (\(w0, h0) -> w0 > 0 && h0 > 0) boxes) + `shouldBe` (3, True) + + it "crossbar polar: 箱が wedge (PPath) + 中央線が弧になる (Phase 71 A2)" $ + let sp = layer (crossbar (inline [1.0, 2, 3, 4]) (inline [4.0, 5, 6, 5]) + (inline [0.5, 0.5, 0.5, 0.5])) + <> coordPolar + ps = renderToPrimitives emptyResolver (computeLayout emptyResolver sp) sp + wedges = [ () | PPath _ (FillStyle _ o) _ <- ps, abs (o - 0.15) < 1e-9 ] + in length wedges `shouldBe` 4 + + it "crossbar cartesian: 旧 px 式 (cc±halfW × min/abs) と bit 一致 (Phase 71 A2)" $ + let sp = layer (crossbar (inline [1.0, 2, 3]) (inline [4.0, 5, 6]) + (inline [0.5, 0.5, 0.5])) + layC = computeLayout emptyResolver sp + ps = renderToPrimitives emptyResolver layC sp + sx = scaleApply (lpXScale layC) + sy = scaleApply (lpYScale layC) + -- markWidth 既定 0.9 × resolution 1 × catUnitPx (crossbar 幅の既定式) + halfW = 0.5 * 0.9 * catUnitPx CoordCartesian layC + expected x y e = Rect (sx x - halfW) (min (sy (y - e)) (sy (y + e))) + (2 * halfW) (abs (sy (y + e) - sy (y - e))) + boxes = [ r | PRect r (FillStyle _ o) _ <- ps, abs (o - 0.15) < 1e-9 ] + in boxes `shouldBe` [ expected 1 4 0.5, expected 2 5 0.5, expected 3 6 0.5 ] + + -- ========================================================================= + -- 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 "Phase 63 A2: grid major/minor の個別 on/off" $ do + -- 連続 x/y scatter + ThemeMinimal (grid on) を基準に、 PLine 本数の差分で + -- major/minor の描き分けを検証 (tick/軸枠も PLine のため絶対数でなく差分計数)。 + let spec63 extra = layer (scatter (inline [1.0, 2.0, 3.0, 4.0 :: Double]) + (inline [2.0, 4.0, 1.0, 3.0 :: Double])) + <> theme ThemeMinimal <> extra + nLines extra = let s = spec63 extra + in length [ () | PLine{} <- renderToPrimitives emptyResolver + (computeLayout emptyResolver s) s ] + nAll = nLines mempty + nMajorOff = nLines (themeGridMajor False) + nMinorOff = nLines (themeGridMinor False) + it "themeGridMajor False で major 分だけ減る" $ + (nAll - nMajorOff > 0) `shouldBe` True + it "themeGridMinor False で minor 分だけ減る" $ + (nAll - nMinorOff > 0) `shouldBe` True + it "個別 off ×2 = 一括 themeGrid False (糖衣と一致)" $ + nLines (themeGridMajor False <> themeGridMinor False) + `shouldBe` nLines (themeGrid False) + it "個別 > 一括: themeGrid False <> themeGridMinor True は minor のみ" $ + nLines (themeGrid False <> themeGridMinor True) `shouldBe` nMajorOff + it "指定順に依らず個別が勝つ (themeGridMinor True <> themeGrid False)" $ + nLines (themeGridMinor True <> themeGrid False) `shouldBe` nMajorOff + it "preset off (ThemeClassic) にも個別 on が勝つ" $ + (nLines (theme ThemeClassic <> themeGridMajor True) + > nLines (theme ThemeClassic)) `shouldBe` True + it "未指定は現行既定のまま (minor = 太さ 0.5 の線が存在)" $ + let s = spec63 mempty + ws = [ w | PLine _ _ (LineStyle _ w _) <- renderToPrimitives emptyResolver + (computeLayout emptyResolver s) s ] + in (0.5 `elem` ws) `shouldBe` True + + describe "Phase 63 A3: legend position の theme 化 (themeLegendPos)" $ do + it "theme 焼き込みが効く" $ + effectiveLegendPos (themeLegendPos LegendBottom) `shouldBe` LegendBottom + it "図レベル legendPos が theme より優先" $ + effectiveLegendPos (themeLegendPos LegendBottom <> legendPos LegendRight) + `shouldBe` LegendRight + it "未指定は既定 LegendRightCenter のまま" $ + effectiveLegendPos mempty `shouldBe` LegendRightCenter + it "render 経路でも themeLegendPos = 図レベル legendPos と同一出力" $ + let base = layer (scatter (inline [1.0, 2.0, 3.0, 4.0 :: Double]) + (inline [2.0, 4.0, 1.0, 3.0 :: Double]) + <> colorBy (inlineCat (["a", "a", "b", "b"] :: [Data.Text.Text]))) + mk extra = let s = base <> extra + in renderToPrimitives emptyResolver (computeLayout emptyResolver s) s + in mk (themeLegendPos LegendBottom) `shouldBe` mk (legendPos LegendBottom) + + describe "Phase 63 A4: tick の長さ・向き (themeTickLength/themeTickDir)" $ do + let base64 = layer (scatter (inline [1.0, 2.0, 3.0, 4.0 :: Double]) + (inline [2.0, 4.0, 1.0, 3.0 :: Double])) + layOf extra = computeLayout emptyResolver (base64 <> extra) + areaOf extra = lpPlotArea (layOf extra) + primsOf64 extra = renderToPrimitives emptyResolver (layOf extra) (base64 <> extra) + panelBottom extra = let a = areaOf extra in rY a + rH a + -- 下辺 tick = 垂直 PLine (x1 == x2)。 panel 下端からの外向き突出量の最大。 + overhang extra = + let yb = panelBottom extra + in maximum (0 : [ max y1 y2 - yb + | PLine (Point x1 y1) (Point x2 y2) _ <- primsOf64 extra + , x1 == x2 ]) + it "既定 = ggTickLen / TickOut" $ do + effectiveTickLength mempty `shouldBe` ggTickLen + effectiveTickDir mempty `shouldBe` TickOut + it "後勝ち合成 (Last)" $ + effectiveTickLength (themeTickLength 5 <> themeTickLength 10) `shouldBe` 10 + it "themeTickDir TickOut は既定と同一出力 (既存挙動不変)" $ + primsOf64 (themeTickDir TickOut) `shouldBe` primsOf64 mempty + it "themeTickLength が margin 予約に効く (左端が右へ・下端が上へ)" $ do + (rX (areaOf (themeTickLength 10)) > rX (areaOf mempty)) `shouldBe` True + (panelBottom (themeTickLength 10) < panelBottom mempty) `shouldBe` True + it "TickIn は外向き 0 = tickLength 0 と同じ margin" $ + areaOf (themeTickDir TickIn) `shouldBe` areaOf (themeTickLength 0) + it "render: themeTickLength で外向き tick が長くなる" $ + (overhang (themeTickLength 10) > overhang mempty) `shouldBe` True + it "render: TickIn は panel 下端より下に線が出ない" $ + let yb = panelBottom (themeTickDir TickIn) + ys = concat [ [y1, y2] + | PLine (Point _ y1) (Point _ y2) _ + <- primsOf64 (themeTickDir TickIn) ] + in all (<= yb + 1e-6) ys `shouldBe` True + it "render: TickBoth は panel 下端を跨ぐ tick が出る" $ + let yb = panelBottom (themeTickDir TickBoth) + in any (\(y1, y2) -> min y1 y2 < yb - 1e-6 && max y1 y2 > yb + 1e-6) + [ (y1, y2) | PLine (Point x1 y1) (Point x2 y2) _ + <- primsOf64 (themeTickDir TickBoth) + , x1 == x2 ] + `shouldBe` True + + describe "Phase 68: grid / 軸線 線幅の theme 化 (themeGridWidth/themeGridMinorWidth/themeAxisLineWidth)" $ do + -- === 解決関数の規約 (単一情報源) === + it "未指定 = 各 role の現状値 (golden 保存)" $ do + effectiveGridWidth mempty `shouldBe` 1.0 + effectiveGridMinorWidth mempty `shouldBe` 0.5 -- major 1.0 × 0.5 + effectiveNonCartesianGridWidth mempty `shouldBe` 0.5 -- polar / ternary grid + effectiveAxisLineWidth mempty `shouldBe` 1.0 + it "toGridWidth 指定で Cartesian major + polar/ternary grid が統一される (座標系非依存)" $ do + let ov = vsThemeOverride (themeGridWidth 2.5) + effectiveGridWidth ov `shouldBe` 2.5 + effectiveNonCartesianGridWidth ov `shouldBe` 2.5 + it "minor 未指定は major × 0.5 (ggplot rel(0.5)) に追従する" $ + effectiveGridMinorWidth (vsThemeOverride (themeGridWidth 3.0)) `shouldBe` 1.5 + it "themeGridMinorWidth は major と独立に上書きできる (major 不変)" $ do + let ov = vsThemeOverride (themeGridWidth 3.0 <> themeGridMinorWidth 0.9) + effectiveGridMinorWidth ov `shouldBe` 0.9 + effectiveGridWidth ov `shouldBe` 3.0 + it "themeAxisLineWidth は grid に波及しない (逆も同様)" $ do + let ov = vsThemeOverride (themeAxisLineWidth 4.0) + effectiveAxisLineWidth ov `shouldBe` 4.0 + effectiveGridWidth ov `shouldBe` 1.0 + effectiveNonCartesianGridWidth ov `shouldBe` 0.5 + it "後勝ち合成 (Last)" $ + effectiveGridWidth (vsThemeOverride (themeGridWidth 2 <> themeGridWidth 5)) `shouldBe` 5.0 + -- === JSON 後方互換 (新 field 無しの既存 spec が読める・Phase 64 A11 と同契約) === + it "JSON 後方互換: 新 field 無しの ThemeOverride は Last Nothing で decode" $ do + let dec = eitherDecode "{}" :: Either String ThemeOverride + fmap (getLast . toGridWidth) dec `shouldBe` Right Nothing + fmap (getLast . toGridMinorWidth) dec `shouldBe` Right Nothing + fmap (getLast . toAxisLineWidth) dec `shouldBe` Right Nothing + it "JSON roundtrip: themeGridWidth 2.0 が encode→decode で保存" $ + fmap (getLast . toGridWidth) + (eitherDecode (encode (vsThemeOverride (themeGridWidth 2.0))) :: Either String ThemeOverride) + `shouldBe` Right (Just 2.0) + -- === Render レベル (Cartesian grid の実線幅が変わる・既定は不変) === + let base68 = layer (scatter (inline [1.0, 2.0, 3.0, 4.0 :: Double]) + (inline [2.0, 4.0, 1.0, 3.0 :: Double])) + <> themeGrid True + widthsOf extra = + [ lsWidth ls + | PLine _ _ ls <- renderToPrimitives emptyResolver + (computeLayout emptyResolver (base68 <> extra)) (base68 <> extra) ] + it "render: 既定 grid 線幅に 2.0 は出ない (現状値のみ)" $ + elem 2.0 (widthsOf mempty) `shouldBe` False + it "render: themeGridWidth 2.0 で grid 線が 2.0 になる" $ + elem 2.0 (widthsOf (themeGridWidth 2.0)) `shouldBe` True + it "render: themeGridWidth 未指定は既定と byte 完全一致 (golden ゼロ diff)" $ + widthsOf (themeGridMinorWidth 0.5 <> themeGridWidth 1.0) `shouldBe` widthsOf mempty + + describe "Phase 63 A5: plot margin (themePlotMargin)" $ do + let base65 = layer (scatter (inline [1.0, 2.0, 3.0, 4.0 :: Double]) + (inline [2.0, 4.0, 1.0, 3.0 :: Double])) + layOf extra = computeLayout emptyResolver (base65 <> extra) + areaOf extra = lpPlotArea (layOf extra) + primsOf65 extra = renderToPrimitives emptyResolver (layOf extra) (base65 <> extra) + it "既定 = 各辺 ggHalfLine" $ + effectivePlotMargin mempty + `shouldBe` Margin ggHalfLine ggHalfLine ggHalfLine ggHalfLine + it "既定値の明示指定 (5.5 ×4) は既定と同一出力 (置き換え意味論・既存挙動不変)" $ + primsOf65 (themePlotMargin 5.5 5.5 5.5 5.5) `shouldBe` primsOf65 mempty + it "4 辺が個別に効く (t/r/b/l = 30/40/50/60)" $ do + let a0 = areaOf mempty + a1 = areaOf (themePlotMargin 30 40 50 60) + (rY a1 > rY a0) `shouldBe` True -- top + (rX a1 + rW a1 < rX a0 + rW a0) `shouldBe` True -- right + (rY a1 + rH a1 < rY a0 + rH a0) `shouldBe` True -- bottom + (rX a1 > rX a0) `shouldBe` True -- left + it "margin 0 で panel が外周いっぱいへ広がる" $ do + let a0 = areaOf mempty + a1 = areaOf (themePlotMargin 0 0 0 0) + (rW a1 > rW a0) `shouldBe` True + (rH a1 > rH a0) `shouldBe` True + it "render: title/軸タイトルが margin に追従 (予約と描画の整合)" $ + let textYs extra = [ y | PText (Point _ y) t _ + <- renderToPrimitives emptyResolver + (computeLayout emptyResolver (base65 <> title "T" <> extra)) + (base65 <> title "T" <> extra) + , t == "T" ] + in case (textYs mempty, textYs (themePlotMargin 30 5.5 5.5 5.5)) of + ([y0], [y1]) -> (y1 - y0) `shouldBe` (30 - 5.5) + _ -> expectationFailure "title PText が 1 個でない" + + describe "Phase 63 A6: subplot の相対サイズ (subplotWidths/Heights)" $ do + let p1 = layer (scatter (inline [1.0, 2.0 :: Double]) (inline [1.0, 2.0 :: Double])) + p2 = layer (scatter (inline [1.0, 2.0 :: Double]) (inline [2.0, 1.0 :: Double])) + prims66 spec = renderToPrimitives emptyResolver (computeLayout emptyResolver spec) spec + -- panel 枠 = stroke 付き PRect (background/panel 塗りは stroke 無し)。 + frames spec = [ r | PRect r _ (Just _) <- prims66 spec ] + it "未指定 = subplotWidths [1,1] と同一出力 (既定挙動不変)" $ + prims66 ((p1 <-> p2) <> subplotWidths [1, 1]) `shouldBe` prims66 (p1 <-> p2) + it "subplotWidths [3,1] で枠幅が 3:1" $ + case frames ((p1 <-> p2) <> subplotWidths [3, 1]) of + [ra, rb] -> (abs (rW ra / rW rb - 3) < 1e-6) `shouldBe` True + fs -> expectationFailure ("枠が 2 個でない: " <> show (length fs)) + it "不足分は 1 埋め ([3] = [3,1] と同一出力)" $ + prims66 ((p1 <-> p2) <> subplotWidths [3]) + `shouldBe` prims66 ((p1 <-> p2) <> subplotWidths [3, 1]) + it "subplotHeights [2,1] で枠高が 2:1 (縦並び)" $ + case frames ((p1 <:> p2) <> subplotHeights [2, 1]) of + [ra, rb] -> (abs (rH ra / rH rb - 2) < 1e-6) `shouldBe` True + fs -> expectationFailure ("枠が 2 個でない: " <> show (length fs)) + + describe "Phase 63 A7: subplot panel タグ (subplotTags)" $ do + let p1 = layer (scatter (inline [1.0, 2.0 :: Double]) (inline [1.0, 2.0 :: Double])) + p2 = layer (scatter (inline [1.0, 2.0 :: Double]) (inline [2.0, 1.0 :: Double])) + prims67 spec = renderToPrimitives emptyResolver (computeLayout emptyResolver spec) spec + texts spec = [ t | PText _ t _ <- prims67 spec ] + frames spec = [ r | PRect r _ (Just _) <- prims67 spec ] + it "未指定 = タグ無し (既定挙動不変)" $ + ("A" `elem` texts (p1 <-> p2)) `shouldBe` False + it "TagUpper で panel 列挙順に A/B" $ do + ("A" `elem` texts ((p1 <-> p2) <> subplotTags TagUpper)) `shouldBe` True + ("B" `elem` texts ((p1 <-> p2) <> subplotTags TagUpper)) `shouldBe` True + it "TagLower で a/b" $ do + ("a" `elem` texts ((p1 <-> p2) <> subplotTags TagLower)) `shouldBe` True + ("b" `elem` texts ((p1 <-> p2) <> subplotTags TagLower)) `shouldBe` True + it "TagNumeric の増分 = 1/2 (tick ラベルと区別して差分で見る)" $ + (texts ((p1 <-> p2) <> subplotTags TagNumeric) Data.List.\\ texts (p1 <-> p2)) + `shouldBe` ["1", "2"] + it "panel 個別の tag が優先 (個別 > 一括)" $ do + let tagged = ((p1 <> tag "X") <-> p2) <> subplotTags TagUpper + ("X" `elem` texts tagged) `shouldBe` True + ("B" `elem` texts tagged) `shouldBe` True + ("A" `elem` texts tagged) `shouldBe` False + it "tag の margin 予約が panel 枠に効く (枠上端が下がる)" $ + case (frames (p1 <-> p2), frames ((p1 <-> p2) <> subplotTags TagUpper)) of + ([ra, _], [rb, _]) -> (rY rb > rY ra) `shouldBe` True + _ -> expectationFailure "枠が 2 個でない" + it "JSON roundtrip (TagStyle = nullary 名)" $ + eitherDecode (encode ((p1 <-> p2) <> subplotTags TagLower)) + `shouldBe` Right ((p1 <-> p2) <> subplotTags TagLower) + + describe "Phase 63 A8: cowplot 風 preset (themeCowplot/themeMinimalGrid/themeMap)" $ do + let p1 = layer (scatter (inline [1.0, 2.0 :: Double]) (inline [1.0, 2.0 :: Double])) + palOf spec = resolveTheme + (maybe ThemeDefault id (getLast (vsTheme spec))) (vsThemeOverride spec) + it "themeCowplot = ThemeClassic 基調 + 黒軸線 + tick 3.5 + margin 7" $ do + getLast (vsTheme themeCowplot) `shouldBe` Just ThemeClassic + tpShowGridMajor (palOf themeCowplot) `shouldBe` False + tpShowAxisLine (palOf themeCowplot) `shouldBe` True + tpAxis (palOf themeCowplot) `shouldBe` "#000000" + tpTitleColor (palOf themeCowplot) `shouldBe` "#000000" + effectiveTickLength themeCowplot `shouldBe` 3.5 + effectivePlotMargin themeCowplot `shouldBe` Margin 7 7 7 7 + it "themeMinimalGrid = major grid (grey85) のみ・軸線/枠/tick なし" $ do + tpShowGridMajor (palOf themeMinimalGrid) `shouldBe` True + tpShowGridMinor (palOf themeMinimalGrid) `shouldBe` False + tpGrid (palOf themeMinimalGrid) `shouldBe` "#d9d9d9" + tpShowBorder (palOf themeMinimalGrid) `shouldBe` False + tpShowAxisLine (palOf themeMinimalGrid) `shouldBe` False + effectiveTickLength themeMinimalGrid `shouldBe` 0 + it "themeMap = ThemeVoid 基調 (軸/grid/枠なし) + margin 7" $ do + getLast (vsTheme themeMap) `shouldBe` Just ThemeVoid + tpShowGridMajor (palOf themeMap) `shouldBe` False + tpShowAxisLine (palOf themeMap) `shouldBe` False + tpShowBorder (palOf themeMap) `shouldBe` False + effectiveTickLength themeMap `shouldBe` 0 + effectivePlotMargin themeMap `shouldBe` Margin 7 7 7 7 + it "後置 setter が preset を上書き (preset は普通の VisualSpec 値)" $ do + effectiveTickLength (themeCowplot <> themeTickLength 5) `shouldBe` 5 + -- ★ A14: preset は tick 長を明示しない (base 派生に任せる) ため、 先置きの + -- 明示 setter は preset を通っても生き残る (A8 当時は preset 明示 3.5 が勝った)。 + effectiveTickLength (themeTickLength 5 <> themeCowplot) `shouldBe` 5 + -- base font size は preset が明示するので後置 preset が勝つ (Last)。 + effectiveBaseFontSize (themeBaseFontSize 12 <> themeCowplot) `shouldBe` 14 + it "JSON roundtrip (既存 field のみ = 新規 field 追加なし)" $ + eitherDecode (encode (p1 <> themeCowplot)) + `shouldBe` Right (p1 <> themeCowplot) + + describe "Phase 63 A12: base font size (themeBaseFontSize)" $ do + let base68 = layer (scatter (inline [1.0, 2.0, 3.0, 4.0 :: Double]) + (inline [2.0, 4.0, 1.0, 3.0 :: Double])) + <> title "T" <> xLabel "x" <> yLabel "y" + layOf extra = computeLayout emptyResolver (base68 <> extra) + areaOf extra = lpPlotArea (layOf extra) + primsOf68 extra = renderToPrimitives emptyResolver (layOf extra) (base68 <> extra) + -- 描画テキストの font size (本文 t で slot を特定) + sizeOf extra t = [ tsSize ts | PText _ t' ts <- primsOf68 extra, t' == t ] + it "既定 = 11" $ + effectiveBaseFontSize mempty `shouldBe` 11 + it "後勝ち合成 (Last)" $ + effectiveBaseFontSize (themeBaseFontSize 14 <> themeBaseFontSize 12) `shouldBe` 12 + it "既定値の明示指定 (11) は既定と同一出力 (golden 不変 gate の単体版)" $ + primsOf68 (themeBaseFontSize 11) `shouldBe` primsOf68 mempty + it "render: base 14 で相対倍率どおり派生 (title ×1.2 / axis.title ×1 / axis.text ×0.8)" $ do + sizeOf (themeBaseFontSize 14) "T" `shouldBe` [14 * 1.2] + sizeOf (themeBaseFontSize 14) "x" `shouldBe` [14.0] + sizeOf (themeBaseFontSize 14) "1" `shouldBe` [14 * 0.8, 14 * 0.8] -- x/y 両軸の tick "1" + it "個別 theme*Font (fsSize) > base 派生" $ + sizeOf (themeBaseFontSize 14 <> themeTickFont (fontSize 9)) "1" `shouldBe` [9, 9] + it "layout: base 拡大が margin 予約に効く (左端が右へ・下端が上へ)" $ do + (rX (areaOf (themeBaseFontSize 22)) > rX (areaOf mempty)) `shouldBe` True + let pb extra = let a = areaOf extra in rY a + rH a + (pb (themeBaseFontSize 22) < pb mempty) `shouldBe` True + it "layout: theme*Font の fsSize も予約に効く (旧 setter-only 解決の fix)" $ + (rY (areaOf (themeTitleFont (fontSize 30))) > rY (areaOf mempty)) `shouldBe` True + it "JSON roundtrip (toBaseFontSize field)" $ + eitherDecode (encode (base68 <> themeBaseFontSize 14)) + `shouldBe` Right (base68 <> themeBaseFontSize 14) + + describe "Phase 63 A13: spacing の half_line = base/2 派生" $ do + let base69 = layer (scatter (inline [1.0, 2.0, 3.0, 4.0 :: Double]) + (inline [2.0, 4.0, 1.0, 3.0 :: Double])) + areaOf extra = lpPlotArea (computeLayout emptyResolver (base69 <> extra)) + it "既定 11: 全派生値 = 従来定数と bit 同値 (golden 不変 gate の単体版)" $ do + effectiveHalfLine mempty `shouldBe` ggHalfLine + effectiveTickLength mempty `shouldBe` ggTickLen + effectiveAxTextMar mempty `shouldBe` ggAxTextMar + effectiveAxTitleMar mempty `shouldBe` ggAxTitleMar + effectiveLegendBaseSize mempty `shouldBe` legendBaseSize + effectiveLegendKeyW mempty `shouldBe` legendKeyW + effectiveLegendKeyPitch mempty `shouldBe` legendKeyPitch + it "base 22 で half_line 系が倍 (tick 5.5 / margin 11 / axText 4.4)" $ do + effectiveHalfLine (themeBaseFontSize 22) `shouldBe` 11 + effectiveTickLength (themeBaseFontSize 22) `shouldBe` 5.5 + effectivePlotMargin (themeBaseFontSize 22) `shouldBe` Margin 11 11 11 11 + effectiveAxTextMar (themeBaseFontSize 22) `shouldBe` 0.8 * 5.5 + it "個別 theme setter が base 派生既定より優先" $ do + effectiveTickLength (themeBaseFontSize 22 <> themeTickLength 3) `shouldBe` 3 + effectivePlotMargin (themeBaseFontSize 22 <> themePlotMargin 7 7 7 7) + `shouldBe` Margin 7 7 7 7 + it "layout: base 拡大で spacing 予約も拡がる (font 増分と独立に tick/margin 分)" $ do + -- font 由来分を themeTickFont 等で固定し、 spacing 増分だけを観測する + let fixFonts = themeTitleFont (fontSize 13.2) <> themeAxisLabelFont (fontSize 11) + <> themeTickFont (fontSize 8.8) + (rX (areaOf (fixFonts <> themeBaseFontSize 22)) > rX (areaOf fixFonts)) + `shouldBe` True + + describe "Phase 63 A14: themeCowplotSized (base_size 引数) + labs の base 派生" $ do + let p1 = layer (scatter (inline [1.0, 2.0 :: Double]) (inline [1.0, 2.0 :: Double])) + tp = Data.Text.pack + slotSizeOf sl spec = effectiveFontSize mempty (sl (vsThemeOverride spec)) 0 + base70 = p1 <> title (tp "T") <> subtitle (tp "sub") + <> caption (tp "cap") <> tag (tp "G") + primsOf70 extra = renderToPrimitives emptyResolver + (computeLayout emptyResolver (base70 <> extra)) (base70 <> extra) + sizeOf70 extra t = [ tsSize ts | PText _ t' ts <- primsOf70 extra, t' == tp t ] + it "themeCowplot = themeCowplotSized 14 (minimal-grid/map も同形)" $ do + themeCowplot `shouldBe` themeCowplotSized 14 + themeMinimalGrid `shouldBe` themeMinimalGridSized 14 + themeMap `shouldBe` themeMapSized 14 + it "themeCowplotSized N: base=N 焼き込みで tick N/4 / margin N/2 が自動連動 (A13)" $ do + effectiveBaseFontSize (themeCowplotSized 12) `shouldBe` 12 + effectiveTickLength (themeCowplotSized 12) `shouldBe` 3 + effectivePlotMargin (themeCowplotSized 12) `shouldBe` Margin 6 6 6 6 + effectiveTickLength (themeCowplotSized 14) `shouldBe` 3.5 + effectivePlotMargin (themeCowplotSized 14) `shouldBe` Margin 7 7 7 7 + -- minimal-grid/map は tick 0 を明示 (base 派生させない) + effectiveTickLength (themeMinimalGridSized 12) `shouldBe` 0 + effectiveTickLength (themeMapSized 12) `shouldBe` 0 + it "cowplot 倍率 font (title ×16/14 bold / axis.title ×1 / text ×12/14)" $ do + slotSizeOf toTitleFont (themeCowplotSized 12) `shouldBe` 12 * 16 / 14 + slotSizeOf toAxisLabelFont (themeCowplotSized 12) `shouldBe` 12 + slotSizeOf toTickFont (themeCowplotSized 12) `shouldBe` 12 * 12 / 14 + slotSizeOf toLegendFont (themeCowplotSized 12) `shouldBe` 12 * 12 / 14 + (getLast (toTitleFont (vsThemeOverride (themeCowplotSized 12))) + >>= getLast . fsWeight) `shouldBe` Just (tp "bold") + it "labs size = base 派生 (subtitle ×1 / caption ×0.8 / tag ×1.2 = ggplot 倍率)" $ do + effectiveSubtitleSize mempty `shouldBe` 11 + effectiveCaptionSize mempty `shouldBe` 0.8 * 11 + effectiveTagSize mempty `shouldBe` 1.2 * 11 + effectiveSubtitleSize (themeBaseFontSize 14) `shouldBe` 14 + effectiveCaptionSize (themeBaseFontSize 14) `shouldBe` 0.8 * 14 + effectiveTagSize (themeBaseFontSize 14) `shouldBe` 1.2 * 14 + it "render: subtitle/caption/tag の描画サイズも base 派生 (予約と単一情報源)" $ do + sizeOf70 (themeBaseFontSize 14) "sub" `shouldBe` [14.0] + sizeOf70 (themeBaseFontSize 14) "cap" `shouldBe` [0.8 * 14] + sizeOf70 (themeBaseFontSize 14) "G" `shouldBe` [1.2 * 14] + + describe "Phase 63 A15: 軸タイトル = 軸 text 直下 + axis.title margin (最外端 pin 廃止)" $ do + let p71 = layer (scatter (inline [1.0, 2.0, 3.0 :: Double]) + (inline [2.0, 4.0, 1.0 :: Double])) + <> xLabel "xt" <> yLabel "yt" + layOf71 extra = computeLayout emptyResolver (p71 <> extra) + primsOf71 extra = renderToPrimitives emptyResolver (layOf71 extra) (p71 <> extra) + textPtOf extra t = head [ p | PText p t' _ <- primsOf71 extra, t' == t ] + it "offset = tick 突出 + axis.text margin + tick ラベル帯 + axis.title margin (bM/lM 予約と同一 stack)" $ do + let lay = layOf71 mempty + -- x 側の tick ラベル帯 = tick font size (非回転 numeric)、 y 側 = 最長ラベル幅 (0.6em/char) + lpXTitleOff lay `shouldBe` + effectiveTickLength mempty + effectiveAxTextMar mempty + 0.8 * 11 + effectiveAxTitleMar mempty + lpYTitleOff lay `shouldBe` + effectiveTickLength mempty + effectiveAxTextMar mempty + 0.6 * (0.8 * 11) + effectiveAxTitleMar mempty + it "render: 軸タイトルは panel 端 + offset 基準 (boxBottom/boxLeft 最外端 pin 廃止)" $ do + let lay = layOf71 mempty + a = lpPlotArea lay + Point _ xy = textPtOf mempty "xt" + Point yx _ = textPtOf mempty "yt" + xy `shouldBe` rY a + rH a + lpXTitleOff lay + 0.8 * 11 + yx `shouldBe` rX a - lpYTitleOff lay - 0.2 * 11 + it "LegendBottom でも軸タイトルは軸 text 直下 = 凡例より内側 (J5 順序 fix)" $ do + let legended = layer (scatter (inline [1.0, 2.0, 3.0 :: Double]) + (inline [2.0, 4.0, 1.0 :: Double]) + <> colorBy (inlineCat ["a", "b", "c" :: Data.Text.Text])) + <> xLabel "xt" <> themeLegendPos LegendBottom + lay = computeLayout emptyResolver legended + a = lpPlotArea lay + xy = head [ y | PText (Point _ y) t _ <- renderToPrimitives emptyResolver lay legended + , t == "xt" ] + -- タイトル glyph 下端 (baseline + descent) が凡例ブロック上端 (★A17: lpLegendYOff) より内側 + (xy + 0.2 * 11 <= rY a + rH a + lpLegendYOff lay) `shouldBe` True + -- panel 相対位置は凡例の有無で不変 (旧 pin は legendH ぶん外へ出ていた = J5) + abs (xy - (rY a + rH a) - (lpXTitleOff lay + 0.8 * 11)) `shouldSatisfy` (< 1e-9) + it "caption があっても軸タイトルは軸 text 直下 (caption はさらに外側)" $ do + let withCap = p71 <> caption "cap" + layC = computeLayout emptyResolver withCap + aC = lpPlotArea layC + xyC = head [ y | PText (Point _ y) t _ <- renderToPrimitives emptyResolver layC withCap + , t == "xt" ] + abs (xyC - (rY aC + rH aC) - (lpXTitleOff layC + 0.8 * 11)) `shouldSatisfy` (< 1e-9) + + describe "Phase 63 A16: theme 回転角の layout 反映 (resolveAxisAngle 単一情報源)" $ do + let p72 = layer (bar (inlineCat ["alpha", "bravo", "charlie" :: Data.Text.Text]) + (inline [1, 2, 3 :: Double])) + <> xLabel "xt" + areaOf72 extra = lpPlotArea (computeLayout emptyResolver (p72 <> extra)) + pb72 extra = let a = areaOf72 extra in rY a + rH a -- panel 下端 + it "themeAxisTextAngleX で回転マージンが予約される (旧 axisRotateOf は theme 無視 = J4)" $ + (pb72 (themeAxisTextAngleX 45) < pb72 mempty) `shouldBe` True + it "共通 themeAxisTextAngle も x 側予約に効く" $ + (pb72 (themeAxisTextAngle 45) < pb72 mempty) `shouldBe` True + it "theme 回転と per-axis 回転で予約が同値 (描画 resolveAxisAngle と同じ解決順)" $ + areaOf72 (themeAxisTextAngleX 45) `shouldBe` areaOf72 (xAxis (axisRotate 45)) + it "per-axis 明示が theme より優先 (解決順の単一情報源)" $ + areaOf72 (xAxis (axisRotate 90) <> themeAxisTextAngleX 30) + `shouldBe` areaOf72 (xAxis (axisRotate 90)) + + describe "Phase 63 A17: bottom 凡例の実位置 + wrap (予約と描画の単一情報源)" $ do + let cats73 = ["aa", "bb", "cc"] :: [Data.Text.Text] + p73 = layer (scatter (inline [1.0, 2.0, 3.0 :: Double]) + (inline [2.0, 4.0, 1.0 :: Double]) + <> colorBy (inlineCat cats73)) + <> xLabel "xt" <> themeLegendPos LegendBottom + lay73 = computeLayout emptyResolver p73 + pb73 extra = let a = lpPlotArea (computeLayout emptyResolver (p73 <> extra)) + in rY a + rH a + it "lpLegendYOff = 軸 stack (bM 予約と同一) + 2×half_line (= legend.box.spacing)" $ + lpLegendYOff lay73 `shouldBe` + effectiveTickLength mempty + effectiveAxTextMar mempty + 0.8 * 11 + + effectiveAxTitleMar mempty + 11 + 2 * effectiveHalfLine mempty + it "render: 凡例は panel 下端 + lpLegendYOff 起点 = 軸タイトルの外側 (J5 順序 fix)" $ do + let a = lpPlotArea lay73 + prims = renderToPrimitives emptyResolver lay73 p73 + titleY = head [ y | PText (Point _ y) t _ <- prims, t == "xt" ] + legYs = [ y | PText (Point _ y) t _ <- prims, t `elem` cats73 ] + length legYs `shouldBe` 3 + -- chip text baseline = block 上端 (+7 anchor) + 2 (renderLegendBottom と同式) + all (\y -> abs (y - (rY a + rH a + lpLegendYOff lay73 + 9)) < 1e-9) legYs + `shouldBe` True + -- 凡例 text 上端がタイトル glyph 下端より外側 (ticks→labels→title→legend) + all (\y -> y - 0.8 * (0.8 * 11) >= titleY + 0.2 * 11) legYs `shouldBe` True + it "auto-wrap: panel 幅に収まらないラベル群は複数行 (行数 = ceil(n/lpLegendNCol))" $ do + let longCats = [ Data.Text.pack ("categorylabel-" <> show i) | i <- [1 .. 8 :: Int] ] + pW = layer (scatter (inline [1.0 .. 8.0 :: Double]) + (inline [1.0 .. 8.0 :: Double]) + <> colorBy (inlineCat longCats)) + <> themeLegendPos LegendBottom + layW = computeLayout emptyResolver pW + ys = Data.List.nub [ y | PText (Point _ y) t _ + <- renderToPrimitives emptyResolver layW pW + , t `elem` longCats ] + (lpLegendNCol layW < 8) `shouldBe` True + length ys `shouldBe` (8 + lpLegendNCol layW - 1) `div` lpLegendNCol layW + it "明示 legendNrow は auto-wrap より優先 (nc = ceil(n/nrow) の従来コース)" $ + lpLegendNCol (computeLayout emptyResolver (p73 <> legendNrow 3)) `shouldBe` 1 + it "legendH 予約が行数連動 (nrow=2 は nrow=1 より panel 下端が上がる)" $ + (pb73 (legendNrow 2) < pb73 (legendNrow 1)) `shouldBe` True + + describe "Phase 63 A18: plot 背景透過の口 (themePlotBg)" $ do + -- 全面背景 = viewport ぴったりの PRect (fill 不透過・枠なし)。 これの有無で + -- 「塗る/塗らない」 を検証 (panel 塗りは plotArea サイズなので誤検出しない)。 + let base18 = layer (scatter (inline [1.0, 2.0, 3.0 :: Double]) + (inline [2.0, 4.0, 1.0 :: Double])) + nBg extra = let s = base18 <> extra + l = computeLayout emptyResolver s + vp = lpViewport l + in length [ () | PRect (Rect 0 0 w h) (FillStyle _ 1.0) Nothing + <- renderToPrimitives emptyResolver l s + , w == fromIntegral (vsW vp) + , h == fromIntegral (vsH vp) ] + it "既定は全面背景 rect が 1 枚 (従来挙動不変)" $ + nBg mempty `shouldBe` 1 + it "themePlotBg False で全面背景 rect が消える (= 透過)" $ + nBg (themePlotBg False) `shouldBe` 0 + it "cowplot 3 preset は背景透過 (cowplot rect fill NA 相当)" $ + (nBg themeCowplot, nBg themeMinimalGrid, nBg themeMap) `shouldBe` (0, 0, 0) + it "preset 後の themePlotBg True で再点灯 (Last 合成)" $ + nBg (themeCowplot <> themePlotBg True) `shouldBe` 1 + it "specThemePalette: 未指定は tpShowBackground = True / override が勝つ" $ + ( tpShowBackground (specThemePalette mempty) + , tpShowBackground (specThemePalette (themePlotBg False)) ) + `shouldBe` (True, False) + + describe "Phase 63 A19: ThemeVoid 完全 void (axis.text / axis.title の blank 口)" $ do + let base19 = layer (scatter (inline [1.0, 2.0, 3.0 :: Double]) + (inline [2.0, 4.0, 1.0 :: Double])) + <> title "T" <> xLabel "xt" <> yLabel "yt" + layOf extra = computeLayout emptyResolver (base19 <> extra) + textsOf extra = [ t | PText _ t _ + <- renderToPrimitives emptyResolver (layOf extra) (base19 <> extra) ] + -- 軸 text の代表 = tick ラベル "1" (x/y 両軸)、 軸タイトル = "xt"/"yt" + hasTickLabel extra = "1" `elem` textsOf extra + hasAxisTitle extra = "xt" `elem` textsOf extra || "yt" `elem` textsOf extra + panelBottom extra = let a = lpPlotArea (layOf extra) in rY a + rH a + it "実効値: 既定 True / ThemeVoid のみ既定 False" $ do + ( effectiveShowAxisText mempty, effectiveShowAxisTitle mempty ) + `shouldBe` (True, True) + ( effectiveShowAxisText (theme ThemeVoid) + , effectiveShowAxisTitle (theme ThemeVoid) ) `shouldBe` (False, False) + it "ThemeVoid は tick 長も既定 0 (ggplot theme_void の axis.ticks.length = 0)" $ + effectiveTickLength (theme ThemeVoid) `shouldBe` 0 + it "ThemeVoid: tick ラベル文字・軸タイトルが消え、 タイトル系は残る" $ do + hasTickLabel (theme ThemeVoid) `shouldBe` False + hasAxisTitle (theme ThemeVoid) `shouldBe` False + ("T" `elem` textsOf (theme ThemeVoid)) `shouldBe` True + it "themeAxisText False: 文字のみ消え tick 線は残る (既定 theme)" $ do + hasTickLabel (themeAxisText False) `shouldBe` False + hasTickLabel mempty `shouldBe` True + -- tick 線 (PLine) の本数は不変 = 文字だけが落ちる + let nLines extra = length [ () | PLine _ _ _ + <- renderToPrimitives emptyResolver (layOf extra) + (base19 <> extra) ] + nLines (themeAxisText False) `shouldBe` nLines mempty + it "themeAxisTitle False: 軸タイトルのみ消える" $ do + hasAxisTitle (themeAxisTitle False) `shouldBe` False + hasTickLabel (themeAxisTitle False) `shouldBe` True + it "margin 予約が連動 (非表示で panel 下端が下がる = 予約解放)" $ do + (panelBottom (themeAxisText False) > panelBottom mempty) `shouldBe` True + (panelBottom (themeAxisTitle False) > panelBottom mempty) `shouldBe` True + it "ThemeVoid 後の themeAxisText True で再点灯 (Last 合成・override > preset)" $ + hasTickLabel (theme ThemeVoid <> themeAxisText True) `shouldBe` True + it "themeMap (合成 preset) も axis.text / axis.title が blank" $ do + hasTickLabel themeMap `shouldBe` False + hasAxisTitle themeMap `shouldBe` False + it "JSON roundtrip (toShowAxisText / toShowAxisTitle field)" $ + eitherDecode (encode (base19 <> themeAxisText False <> themeAxisTitle False)) + `shouldBe` Right (base19 <> themeAxisText False <> themeAxisTitle False) + + describe "Phase 63 A19.5: 凡例キー帯 (bgRect) 撤去 + legend.key.size の theme 口" $ do + let base195 = layer (scatter (inline [1.0, 2.0, 3.0 :: Double]) + (inline [2.0, 4.0, 1.0 :: Double]) + <> colorBy (inlineCat (["a", "b", "a"] :: [Data.Text.Text]))) + primsOf extra = renderToPrimitives emptyResolver + (computeLayout emptyResolver (base195 <> extra)) + (base195 <> extra) + it "凡例キー列の連続帯が出ない (ThemeVoid: 塗り PRect = 全面背景 1 枚のみ)" $ + -- 旧 bgRect は tpPanelBg 不透過帯を無条件に塗っていた (A18 の透過化で顕在化) + length [ () | PRect _ (FillStyle _ o) _ <- primsOf (theme ThemeVoid), o > 0 ] + `shouldBe` 1 + it "ThemeGrey は legend.key (grey95) がキー数ぶんのみ = 連続帯との二重塗り解消" $ + length [ () | PRect _ (FillStyle c o) _ <- primsOf (theme ThemeGrey) + , c == "#f2f2f2", o == 1.0 ] + `shouldBe` 2 + it "effectiveLegendKeyW: 既定は従来値 / cowplot preset = 1.1×font_size / 上書き優先" $ do + effectiveLegendKeyW mempty `shouldBe` legendKeyW + effectiveLegendKeyW themeCowplot `shouldBe` 1.1 * 14 + effectiveLegendKeyW (themeCowplotSized 12) `shouldBe` 1.1 * 12 + effectiveLegendKeyW themeMap `shouldBe` 1.1 * 14 + effectiveLegendKeyW (themeCowplot <> themeLegendKeySize 20) `shouldBe` 20 + it "凡例行 pitch = キー辺 (cowplot は 22.06pt → 15.4pt に詰まる = gold 32px@150dpi)" $ do + effectiveLegendKeyPitch themeCowplot `shouldBe` 1.1 * 14 + -- 描画実測: 凡例キー点 (panel 右端より外) の縦間隔が pitch と一致 + let pitchOf extra = + let l = computeLayout emptyResolver (base195 <> extra) + a = lpPlotArea l + ys = Data.List.sort + [ y | PCircle (Point x y) _ _ _ _ <- primsOf extra + , x > rX a + rW a ] + in case ys of + (y1 : y2 : _) -> y2 - y1 + _ -> 0 + -- 描画座標は offset 加算の丸めが乗るため ULP 許容で比較 + abs (pitchOf themeCowplot - 1.1 * 14) < 1e-9 `shouldBe` True + abs (pitchOf mempty - legendKeyPitch) < 1e-9 `shouldBe` True + it "JSON roundtrip (toLegendKeySize field)" $ + eitherDecode (encode (base195 <> themeLegendKeySize 15.4)) + `shouldBe` Right (base195 <> themeLegendKeySize 15.4) + + describe "Phase 63 A20: bottom/top 凡例の keyBg も tpLegendKeyBg へ一本化" $ do + -- legendSwatch (bottom/top 経路) の Phase 34 grey95 ハードコードが + -- A19.5 の一本化から漏れていた取り残し (実測: cowplot bottom 凡例に + -- #f2f2f2 1695px、 右凡例は 0px) + let base20 = layer (scatter (inline [1.0, 2.0, 3.0 :: Double]) + (inline [2.0, 4.0, 1.0 :: Double]) + <> colorBy (inlineCat (["a", "b", "a"] :: [Data.Text.Text]))) + greyKeys extra = + length [ () | PRect _ (FillStyle c o) _ + <- renderToPrimitives emptyResolver + (computeLayout emptyResolver (base20 <> extra)) + (base20 <> extra) + , c == "#f2f2f2", o == 1.0 ] + it "cowplot (tpLegendKeyBg = \"\") の bottom 凡例に grey95 キー箱が出ない" $ + greyKeys (themeCowplot <> themeLegendPos LegendBottom) `shouldBe` 0 + it "既定 theme (tpLegendKeyBg = \"\") の bottom 凡例も出ない = 右凡例と整合" $ + greyKeys (themeLegendPos LegendBottom) `shouldBe` 0 + it "ThemeGrey の bottom 凡例はキー数ぶんの grey95 (theme 口は生きる)" $ + greyKeys (theme ThemeGrey <> themeLegendPos LegendBottom) `shouldBe` 2 + + describe "Phase 63 A20.5: themeFontFamily (全 text slot 共通の family fallback)" $ do + let base205 = layer (scatter (inline [1.0, 2.0, 3.0 :: Double]) + (inline [2.0, 4.0, 1.0 :: Double]) + <> colorBy (inlineCat (["a", "b", "a"] :: [Data.Text.Text]))) + <> title "t" <> xLabel "x" <> yLabel "y" + famsOf extra = + nubKeepT [ tsFamily ts + | PText _ _ ts <- renderToPrimitives emptyResolver + (computeLayout emptyResolver (base205 <> extra)) + (base205 <> extra) ] + nubKeepT = foldr (\x acc -> if x `elem` acc then acc else x : acc) [] + it "themeFontFamily が全 text slot (title/axis/tick/legend) へ波及する" $ + famsOf (themeFontFamily "DejaVu Sans") `shouldBe` ["DejaVu Sans"] + it "slot 別 FontSpec の family が themeFontFamily より優先" $ do + let fams = famsOf (themeFontFamily "A" <> themeTickFont (fontFamily "B")) + ("A" `elem` fams, "B" `elem` fams) `shouldBe` (True, True) + it "preset の fontSize 焼き込みを潰さない (cowplotSized 12 の text size 不変)" $ + let sizesOf extra = + [ (tsSize ts, tsFamily ts) + | PText _ _ ts <- renderToPrimitives emptyResolver + (computeLayout emptyResolver (base205 <> extra)) + (base205 <> extra) ] + withFam = sizesOf (themeCowplotSized 12 <> themeFontFamily "X") + withoutFam = sizesOf (themeCowplotSized 12) + in map fst withFam `shouldBe` map fst withoutFam + it "JSON roundtrip (toFontFamily field)" $ + eitherDecode (encode (base205 <> themeFontFamily "DejaVu Sans")) + `shouldBe` Right (base205 <> themeFontFamily "DejaVu Sans") + + describe "Phase 65: boxplot outlier の domain 内包 (panel 外打点 fix)" $ do + let vals65 = [10, 11, 12, 13, 14, 15, 16, 40 :: Double] -- 40 = 1.5×IQR フェンス外 + sp65 = layer (boxplot (inline vals65) + <> groupBy (inlineCat (replicate 8 ("g" :: Data.Text.Text)))) + lay65 = computeLayout emptyResolver sp65 + a65 = lpPlotArea lay65 + circleYs = [ y | PCircle (Point _ y) _ _ _ _ + <- renderToPrimitives emptyResolver lay65 sp65 ] + it "outlier ドット (PCircle) が panel y 範囲内に収まる" $ do + length circleYs `shouldBe` 1 + all (\y -> y >= rY a65 && y <= rY a65 + rH a65) circleYs `shouldBe` True + + 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" + PClipPath{} -> "PClipPath" PClipPop -> "PClipPop" PTransformPush{} -> "PTransformPush" PTransformPop -> "PTransformPop"