diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog for `hgg-custom` + +## 0.1.0.0 — 2026-07-18 + +First public release on Hackage. + +- Non-standard custom marks (dendrogram etc.). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +BSD 3-Clause License + +Copyright (c) 2026, Toshiaki Honda +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/hgg-custom.cabal b/hgg-custom.cabal new file mode 100644 --- /dev/null +++ b/hgg-custom.cabal @@ -0,0 +1,40 @@ +cabal-version: 3.0 +name: hgg-custom +version: 0.1.0.0 +extra-doc-files: CHANGELOG.md +synopsis: Non-standard / advanced custom marks for hgg (dendrogram, ...) +description: + An add-on package that isolates non-standard "custom marks" — new plot + types built on hgg-core's customMark extension point — from the core + library. It never touches core's MarkKind; it depends only on + hgg-core's Primitive / customMark API. Add it as a dependency only when + you need these specialized visualizations (e.g. for random forests or + hierarchical clustering). + . + Currently ships a dendrogram mark (tree diagrams for hierarchical + clustering), using pre-baked segments for easy cross-backend parity. +license: BSD-3-Clause +homepage: https://github.com/frenzieddoll/hgg +license-file: LICENSE +author: Toshiaki Honda +maintainer: frenzieddoll@gmail.com +copyright: 2026 Aelysce Project (Toshiaki Honda) +category: Graphics +build-type: Simple + +common warnings + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields + -Wredundant-constraints + +library + import: warnings + exposed-modules: Graphics.Hgg.Custom.Dendrogram + build-depends: base >= 4.16 && < 5 + , hgg-core ^>= 0.1 + , aeson >= 2.0 && < 3 + , text >= 1.2 && < 3 + , vector >= 0.12 && < 0.14 + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: OverloadedStrings diff --git a/src/Graphics/Hgg/Custom/Dendrogram.hs b/src/Graphics/Hgg/Custom/Dendrogram.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Hgg/Custom/Dendrogram.hs @@ -0,0 +1,105 @@ +-- | +-- Module : Graphics.Hgg.Custom.Dendrogram +-- Description : 階層クラスタリングの樹形図 (dendrogram) を custom mark で描く +-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda) +-- License : BSD-3-Clause +-- +-- Phase 48: dendrogram を Phase 51 の **custom mark** で本実装する。 core (@MarkKind@) は +-- 触らない (add-on package)。 +-- +-- 設計 = __焼き込み (baked segments)__: 樹形図の U 字リンクを「計算済みの線分列 ('DendroSeg')」 +-- として 'DendroPayload' に持ち、 それを @cmOptions@ (JSON) に焼き込む。 HS の draw closure は +-- payload を直接使い、 PS (canvas) の registry は同じ payload JSON を読む — どちらも「線分を +-- proj して 'PLine' で描くだけ」なので HS=PS parity が自明。 clustering/レイアウト算法は +-- __呼び出し側 (analyze の @dendrogramOf@ 等)__ が行い、 その結果の線分だけをここへ渡す。 +-- +-- 葉ラベル・軸は本 mark の外 (呼び出し側が数値 x 軸 + @axisBreaksLabeled@ で付ける)。 本 mark は +-- __U 字リンクの線分のみ__を描く。 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Hgg.Custom.Dendrogram + ( -- * 焼き込みペイロード + DendroSeg(..) + , DendroPayload(..) + -- * mark + , dendrogramMark + , drawDendro + -- * PS registry で使う mark id + , dendrogramMarkId + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson as Aeson +import qualified Data.Char as Char +import Data.Text (Text) +import qualified Data.Vector as V +import GHC.Generics (Generic) + +import Graphics.Hgg.Primitive (Point (..), Primitive (..), solid) +import Graphics.Hgg.Spec (ColRef (ColNum), Layer, RenderCtx (..), + customMarkWith, encX, encY) + +-- | dendrogram の 1 線分 (data 座標)。 x = 葉 slot / node 中点、 y = マージ高 (height)。 +-- JSON キーは prefix @seg@ を落とす: @x1/y1/x2/y2/color/width@。 +data DendroSeg = DendroSeg + { segX1 :: !Double + , segY1 :: !Double + , segX2 :: !Double + , segY2 :: !Double + , segColor :: !Text + , segWidth :: !Double + } deriving (Show, Eq, Generic) + +segOptions :: Aeson.Options +segOptions = Aeson.defaultOptions { Aeson.fieldLabelModifier = lowerFirst . drop 3 } + +instance ToJSON DendroSeg where + toJSON = Aeson.genericToJSON segOptions + toEncoding = Aeson.genericToEncoding segOptions +instance FromJSON DendroSeg where + parseJSON = Aeson.genericParseJSON segOptions + +-- | dendrogram 全体の焼き込みペイロード。 線分列 + 軸 range (葉方向 / height 方向)。 +-- JSON キーは prefix @dp@ を落とす: @segments/xRange/yRange@ (range は @[lo,hi]@ 配列)。 +data DendroPayload = DendroPayload + { dpSegments :: ![DendroSeg] + , dpXRange :: !(Double, Double) -- ^ 葉方向 range (例 -0.6 .. n-0.4) + , dpYRange :: !(Double, Double) -- ^ height 方向 range (例 0 .. maxH*1.05) + } deriving (Show, Eq, Generic) + +payloadOptions :: Aeson.Options +payloadOptions = Aeson.defaultOptions { Aeson.fieldLabelModifier = lowerFirst . drop 2 } + +instance ToJSON DendroPayload where + toJSON = Aeson.genericToJSON payloadOptions + toEncoding = Aeson.genericToEncoding payloadOptions +instance FromJSON DendroPayload where + parseJSON = Aeson.genericParseJSON payloadOptions + +lowerFirst :: String -> String +lowerFirst (c : cs) = Char.toLower c : cs +lowerFirst [] = [] + +-- | PS registry (canvas) と共有する安定 mark id。 +dendrogramMarkId :: Text +dendrogramMarkId = "dendrogram" + +-- | dendrogram を 'Layer' として返す (= 普通の mark 同様 @layer (...)@ に入れて使う)。 +-- 線分を @cmOptions@ に焼き込み、 'encX'/'encY' で軸 range を束ねる (不可視 anchor 不要)。 +dendrogramMark :: DendroPayload -> Layer +dendrogramMark p = + customMarkWith dendrogramMarkId (toJSON p) (drawDendro p) + <> encX (rangeCol (dpXRange p)) + <> encY (rangeCol (dpYRange p)) + where + rangeCol (lo, hi) = ColNum (V.fromList [lo, hi]) + +-- | payload の線分を 'RenderCtx' で proj して 'PLine' を emit する draw 関数 +-- (HS closure が源。 PS registry も同型の draw を手登録する = parity)。 +drawDendro :: DendroPayload -> RenderCtx -> [Primitive] +drawDendro p ctx = + [ PLine (proj (segX1 s) (segY1 s)) (proj (segX2 s) (segY2 s)) + (solid (segColor s) (segWidth s)) + | s <- dpSegments p ] + where + proj x y = uncurry Point (rcProjectXY ctx x y)