hgg-core-0.2.0.0: test/Spec.hs
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Graphics.Hgg.Easy
import Graphics.Hgg.Validate
import Graphics.Hgg.Layout
import Graphics.Hgg.Render
import Graphics.Hgg.Render.Common (pointShapeAt, alphaVector,
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"