birch-beer-0.2.0.0: src/BirchBeer/Plot.hs
{- BirchBeer.Plot
Gregory W. Schwartz
Collects the functions pertaining to plotting the clusterings.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE GADTs #-}
module BirchBeer.Plot
( plotGraph
, plotLabelLegend
, plotContinuousLegend
, plotSumContinuousLegend
) where
-- Remote
import Control.Monad (forM, mapM, join)
import Control.Monad.State (State (..))
import Data.Bool (bool)
import Data.Colour (AffineSpace (..), withOpacity)
import Data.Colour.Names (black)
import Data.Colour.Palette.BrewerSet (brewerSet, ColorCat(..), Kolor)
import qualified Data.Colour.Palette.BrewerSet as Brewer
import Data.Colour.SRGB (RGB (..), toSRGB)
import Data.Either (isLeft, isRight)
import Data.Function (on)
import Data.List (nub, sort, sortBy, foldl1', transpose)
import Data.Maybe (fromMaybe, isNothing)
import Data.Tuple (swap)
import Diagrams.Backend.Cairo
-- import Diagrams.Dendrogram (dendrogramCustom, Width(..))
import Diagrams.Prelude
import Diagrams.TwoD.Arrow
import Graphics.SVGFonts
import Math.Clustering.Hierarchical.Spectral.Types (getClusterItemsDend)
import Plots
import Plots.Axis.ColourBar
import Plots.Legend
import qualified Control.Foldl as Fold
import qualified Control.Lens as L
import qualified Data.Clustering.Hierarchical as HC
import qualified Data.Foldable as F
import qualified Data.Graph.Inductive as G
import qualified Data.GraphViz as G
import qualified Data.GraphViz.Attributes.Complete as G
import qualified Data.List.Split as Split
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Sparse.Common as S
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Diagrams.TwoD.GraphViz as G hiding (mkGraph)
-- Local
import BirchBeer.Types
import BirchBeer.Utility
import BirchBeer.ColorMap
-- -- | Plot a dendrogram. Unused until upstream is updated.
-- plotDendrogram
-- :: (TreeItem a)
-- => Maybe (Diagram B)
-- -> DrawLeaf
-- -> Maybe ItemColorMap
-- -> HC.Dendrogram (V.Vector a)
-- -> Diagram B
-- plotDendrogram Nothing drawLeaf cm dend =
-- pad 1
-- . center
-- . dendrogramCustom
-- Variable
-- (whichLeaf drawLeaf $ cm)
-- (dendrogramPathLabel drawLeaf cm)
-- ((\tree items -> lw 0.3 . scaleToY (3 * height items) $ tree), curry snd)
-- $ dend
-- where
-- whichLeaf DrawText = dendrogramLeafLabel
-- whichLeaf (DrawItem _) = dendrogramLeafItem
-- plotDendrogram (Just legend) drawLeaf cm dend =
-- pad 1
-- . hsep 1
-- $ [ alignT
-- . center
-- . dendrogramCustom
-- Variable
-- (whichLeaf drawLeaf $ cm)
-- (dendrogramPathLabel drawLeaf cm)
-- ((\tree items -> lw 0.3 . scaleToY (2 * height items) $ tree), curry snd)
-- $ dend
-- , pad 2 . alignT . lw 0.3 center . scaleUToY (height tree / 6) $ legend
-- ]
-- where
-- tree = alignT
-- . center
-- . dendrogramCustom
-- Variable
-- (whichLeaf drawLeaf $ cm)
-- (dendrogramPathLabel drawLeaf cm)
-- ((\tree items -> lw 0.1 . scaleToY (3 * height items) $ tree), curry snd)
-- $ dend
-- whichLeaf DrawText = dendrogramLeafLabel
-- whichLeaf (DrawItem _) = dendrogramLeafItem
-- | Get the most frequent color of a dendrogram.
getMostFrequentColorDend
:: (TreeItem a)
=> ItemColorMap -> HC.Dendrogram (V.Vector a) -> Kolor
getMostFrequentColorDend (ItemColorMap cm) (HC.Leaf leaf) =
getMostFrequent
. fmap (flip (Map.findWithDefault black) cm . getId)
. V.toList
$ leaf
getMostFrequentColorDend (ItemColorMap cm) dend =
getMostFrequent
. concatMap ( fmap (flip (Map.findWithDefault black) cm . getId)
. V.toList
)
. getClusterItemsDend
$ dend
-- | Get the most frequent color of a list.
getMostFrequentColorList
:: (TreeItem a)
=> Maybe ItemColorMap -> [a] -> Kolor
getMostFrequentColorList Nothing = const black
getMostFrequentColorList (Just (ItemColorMap cm)) =
getMostFrequent . fmap (flip (Map.findWithDefault black) cm . getId)
-- | How to draw the path at each junction.
dendrogramPathLabel
:: (TreeItem a)
=> DrawLeaf
-> Maybe ItemColorMap
-> HC.Dendrogram (V.Vector a)
-> Diagram B
-> Diagram B
dendrogramPathLabel _ Nothing _ d = d
dendrogramPathLabel (DrawItem (DrawContinuous _)) _ _ d = d
dendrogramPathLabel (DrawItem DrawSumContinuous) _ _ d = d
dendrogramPathLabel _ (Just cm) dend d = lc color d
where
color = getMostFrequentColorDend cm dend
-- | Plot the leaf of a dendrogram as a text label.
dendrogramLeafLabel
:: (TreeItem a)
=> Maybe ItemColorMap -> V.Vector a -> Diagram B
dendrogramLeafLabel Nothing leaf =
case V.length leaf of
1 -> stroke (textSVG (T.unpack . unId . getId . V.head $ leaf) 1) # rotateBy (1/4) # fc black # centerX # pad 1.3 # alignT
s -> stroke (textSVG (show s) 1) # rotateBy (1/4) # fc black # centerX # pad 1.3 # alignT
dendrogramLeafLabel cm leaf =
case V.length leaf of
1 -> stroke (textSVG (T.unpack . unId . getId . V.head $ leaf) 1) # rotateBy (1/4) # fc black # lw none # centerX # pad 1.3 # alignT
s -> stroke (textSVG (show s) 1) # rotateBy (1/4) # fc color # lw none # centerX # pad 1.3 # alignT
where
color = getMostFrequentColorList cm . V.toList $ leaf
-- | Plot the leaf of a dendrogram as a collection of items.
dendrogramLeafItem
:: (TreeItem a)
=> Maybe ItemColorMap -> V.Vector a -> Diagram B
dendrogramLeafItem Nothing leaf = getItem black # centerX # pad 1.3 # alignT
dendrogramLeafItem (Just (ItemColorMap cm)) leaf =
(vcat . fmap hcat . Split.chunksOf 10 $ items) # centerX # pad 1.3 # alignT
where
items = fmap getItem colors
colors = sort
. fmap (flip (Map.findWithDefault black) cm . getId)
. V.toList
$ leaf
-- | Plot the node of a graph as a text label.
drawGraphLabel
:: (TreeItem a)
=> Maybe ItemColorMap -> Seq.Seq a -> Diagram B
drawGraphLabel Nothing items =
case Seq.length items of
1 -> stroke (textSVG (T.unpack . unId . getId . flip Seq.index 0 $ items) 1) # fc black # lw none # center
s -> stroke (textSVG (show s) 1) # fc black # lw none # center
drawGraphLabel cm items =
case Seq.length items of
1 -> stroke (textSVG (T.unpack . unId . getId . flip Seq.index 0 $ items) 1) # fc black # lw none # center
s -> stroke (textSVG (show s) 1) # fc color # lw none # center
where
color = getMostFrequentColorList cm . F.toList $ items
-- | Plot the node of a graph as a collection of items.
drawGraphItem :: (TreeItem a) => Maybe ItemColorMap -> Seq.Seq a -> Diagram B
drawGraphItem Nothing _ = getItem black # centerX # pad 1.3 # center
drawGraphItem (Just (ItemColorMap cm)) node =
(vcat . fmap hcat . Split.chunksOf boxSize $ items) # center
where
boxSize = floor . sqrt . fromIntegral . Seq.length $ node
items = fmap getItem colors
colors = sort
. fmap (flip (Map.findWithDefault black) cm . getId)
. F.toList
$ node
-- | Plot a collection of items.
drawCollectionItem
:: (TreeItem a)
=> DrawCollection
-> Maybe ItemColorMap
-> Maybe LeafGraphDiaMap
-> G.Node
-> Seq.Seq a
-> Diagram B
drawCollectionItem (CollectionGraph{}) _ Nothing _ _ = mempty
drawCollectionItem (CollectionGraph{}) _ (Just (LeafGraphDiaMap lgdm)) n _ =
fromMaybe mempty . Map.lookup n $ lgdm
drawCollectionItem _ Nothing _ _ _ = mempty
drawCollectionItem drawCollection (Just (ItemColorMap cm)) _ _ items =
renderAxis $ polarAxis &~ do
let colorWedge :: (Kolor, Double) -> State (Plot (Wedge Double) b) ()
colorWedge colorPair = do
plotColor .= fst colorPair
areaStyle . _lw .= none
colorPairs = sortBy (compare `on` snd)
. getFractions
. fmap (flip (Map.findWithDefault black) cm . getId)
. F.toList
$ items
piePlot colorPairs snd $ onWedges colorWedge
case drawCollection of
PieChart -> return ()
_ -> wedgeInnerRadius .= 0.9
hide (axes . traversed)
-- | Draw a single item.
getItem :: Kolor -> Diagram B
getItem color = circle 1 # lc black # fc color # lwL 0.1 -- Unfortunately cannot change to lwL or they disappear with certain scalings.
-- | Legend text size.
legendFontSize :: Double
legendFontSize = (/ 2.5) $ (def :: Legend B Double) ^. legendSpacing
plotLabelLegend :: LabelColorMap -> Diagram B
plotLabelLegend = flip (drawLegend emptyBox) legendOpts
. fmap plotLabel
. Map.toAscList
. unLabelColorMap
where
legendOpts :: Legend B Double
legendOpts =
over legendTextStyle (const (mempty # font "Arial" # fontSizeL legendFontSize))
. over legendStyle (lw none)
$ def
plotLabel :: (Label, Colour Double) -> (Diagram B, String)
plotLabel (!l, !c) =
( circle legendFontSize # lc black # fc c # lwL (0.1 * legendFontSize)
, T.unpack . unLabel $ l
)
-- | Continous style of color bar.
cbOpts :: Maybe DiscreteColorMap -> ColourBar B Double
cbOpts discreteColors =
over tickLabelStyle (font "Arial" # fontSizeL legendFontSize)
. over colourBarStyle (lwL (0.2 * legendFontSize))
. set majorTicksStyle (mempty # lwL (0.2 * legendFontSize))
. set (minorTicks . visible) False
. set (majorGridLines . visible) False
. set majorTicksAlignment insideTicks
. set visible True
. (\ x -> maybe x (\ (DiscreteColorMap y)
-> set colourBarDraw (pathColourBar (length y)) x
)
discreteColors
)
$ defColourBar
-- | Get the legend for a feature. Bar from
-- https://archives.haskell.org/projects.haskell.org/diagrams/blog/2013-12-03-Palette1.html
plotContinuousLegend :: (MatrixLike a)
=> Maybe CustomColors
-> Maybe DiscreteColorMap
-> DrawScaleSaturation
-> [Feature]
-> a
-> Diagram B
plotContinuousLegend customColors discreteColors sat gs mat =
either text dia $ getCombinedFeatures gs $ mat
where
dia fs = vsep
(legendFontSize * 1.2)
[ text (T.unpack . T.intercalate " " . fmap unFeature $ gs)
# font "Arial"
# fontSizeL legendFontSize
, rotateBy (3 / 4)
$ renderColourBar
(cbOpts discreteColors)
cm
(fromMaybe 0 minVal, fromMaybe 0 maxVal)
100
]
where
(minVal, maxVal) = Fold.fold ((,) <$> Fold.minimum <*> Fold.maximum) fs
cm = fromMaybe normalCm discreteCm
discreteCm =
fmap (colourMap . zip [1..] . unDiscreteColorMap) $ discreteColors
normalCm = colourMap
. zip [1..]
. fmap (\x -> saturateColor sat $ blend x highColor lowColor)
$ [0,0.1..1]
(highColor, lowColor) = getHighLowColors customColors
-- | Get the legend for the sum of all features. Bar from
-- https://archives.haskell.org/projects.haskell.org/diagrams/blog/2013-12-03-Palette1.html
plotSumContinuousLegend :: (MatrixLike a)
=> Maybe CustomColors
-> Maybe DiscreteColorMap
-> DrawScaleSaturation
-> a
-> Diagram B
plotSumContinuousLegend customColors discreteColors sat mat = vsep
(legendFontSize * 1.2)
[ text "Total Sum" # font "Arial" # fontSizeL legendFontSize
, rotateBy (3 / 4)
$ renderColourBar
(cbOpts discreteColors)
cm
(fromMaybe 0 minVal, fromMaybe 0 maxVal)
100
]
where
cm = fromMaybe normalCm discreteCm
discreteCm =
fmap (colourMap . zip [1..] . unDiscreteColorMap) $ discreteColors
normalCm =
colourMap
. zip [1 ..]
. fmap (\x -> saturateColor sat $ blend x highColor lowColor)
$ [0, 0.1 .. 1]
(minVal, maxVal) = Fold.fold ((,) <$> Fold.minimum <*> Fold.maximum)
. fmap sum
. S.toRowsL
. getMatrix
$ mat
(highColor, lowColor) = getHighLowColors customColors
-- | Get the maximum cluster size from a graph.
maxClusterSize :: G.Gr (G.Node, Maybe (Seq.Seq a)) e -> Int
maxClusterSize = maximum
. fmap (maybe 0 Seq.length . snd)
. F.toList
. flip getGraphLeaves 0
-- | Get the size of a leaf for graph plotting. Determines the size based on the
-- diameter of each node (36) and the maximum size of a cluster.
getScaledLeafSize :: Int -> Double -> Seq.Seq a -> Double
getScaledLeafSize maxLen maxSize =
isTo (fromIntegral . floor . sqrt . fromIntegral $ maxLen) (maxSize / 2)
. fromIntegral
. floor
. sqrt
. fromIntegral
. Seq.length
-- | Get the trail making the edge.
getEdgeTrail
:: P2 Double -> P2 Double -> Double -> Double -> Trail' Loop V2 Double
getEdgeTrail p1 p2 h1 h2 = fromVertices
[ perpendicular p1 p2 d1
, perpendicular p1 p2 (-d1)
, perpendicular p2 p1 d2
, perpendicular p2 p1 (-d2)
]
# closeLine
where
d1 = h1 / 2
d2 = h2 / 2
-- | Distance d away from p on perpendicular line from p to q, by byorgey.
perpendicular :: P2 Double -> P2 Double -> Double -> P2 Double
perpendicular p q d = p .+^ ((q .-. p) # perp # normalize # scale d)
-- | Get the linear gradient of an edge.
getEdgeGrad :: P2 Double
-> Kolor
-> P2 Double
-> Kolor
-> Double
-> Double
-> Texture Double
getEdgeGrad p1 c1 p2 c2 h1 h2 =
mkLinearGradient (mkStops [(c1, 0, 1), (c2, 1, 1)]) start end GradPad
where
start = perpendicular startPoint ((0 ^& 0) :: P2 Double) (- d1) -- Start gradient after node.
end = endPoint .+^ ((startPoint .-. endPoint) # normalize # scale d2) -- End gradient before node.
startPoint = p1 ^-^ origin
endPoint = p2 ^-^ origin
origin = perpendicular p1 p2 d1
d1 = h1 / 2
d2 = h2 / 2
-- | The function to draw a path connection two nodes in a graph.
drawGraphPath
:: (TreeItem a)
=> DrawConfig
-> Maybe NodeColorMap
-> ClusterGraph a
-> (G.Node, Maybe (Seq.Seq a))
-> P2 Double
-> (G.Node, Maybe (Seq.Seq a))
-> P2 Double
-> ClusterEdge
-> Path V2 Double
-> Diagram B
drawGraphPath opts ncm gr (n1, _) p1 (n2, _) p2 _ _ =
strokeLoop trail
# lw none
# fillTexture gradient
# flip place (perpendicular p1 p2 d1)
where
gradient = getEdgeGrad p1 c1 p2 c2 (height draw1) (height draw2)
d1 = height draw1 / 2
draw1 = drawNode n1 p1
draw2 = drawNode n2 p2
c1 = getNodeColor ncm n1
c2 = getNodeColor ncm n2
trail = getEdgeTrail p1 p2 (height draw1) (height draw2)
drawNode n p = drawGraphNode -- DrawText is irrelevant here.
(resetLeafSize opts)
Nothing
ncm
Nothing
Nothing
gr
(n, Nothing)
p
resetLeafSize x = x { _drawMaxLeafNodeSize = DrawMaxLeafNodeSize -- Reset the leaf node size to behave like an inner node.
. unDrawMaxNodeSize
. _drawMaxNodeSize
$ x
}
-- | Determine the smallest axis.
smallestAxis dia = min (width dia) (height dia)
-- | Determine the axis to scale on.
scaleAxis dia = if width dia > height dia
then scaleUToX
else scaleUToY
-- | Draw the final node of a graph.
drawGraphNode :: (TreeItem a)
=> DrawConfig
-> Maybe ItemColorMap
-> Maybe NodeColorMap
-> Maybe MarkColorMap
-> Maybe LeafGraphDiaMap
-> ClusterGraph a
-> (G.Node, Maybe (Seq.Seq a))
-> P2 Double
-> Diagram B
drawGraphNode opts@(DrawConfig { _drawLeaf = DrawText }) cm _ _ _ gr (n, Just items) pos =
((textDia dnn # fontSizeL (smallestAxis dia)) <> dia <> background)
# scaleUToX scaleVal
# moveTo pos
where
dia = itemDia # scaleAxis itemDia scaleVal
itemDia = drawGraphLabel cm items
background = circle 1 # fc white # lw none # scaleUToY scaleVal
maxLeafNodeSize = unDrawMaxLeafNodeSize . _drawMaxLeafNodeSize $ opts
textDia True = text (show n) # fc (bool black white . isNothing $ cm)
textDia False = mempty
dnn = unDrawNodeNumber . _drawNodeNumber $ opts
scaleVal = if unDrawNoScaleNodesFlag . _drawNoScaleNodesFlag $ opts
then maxLeafNodeSize
else getScaledLeafSize maxClusterSize' maxLeafNodeSize items
maxClusterSize' = maxClusterSize . unClusterGraph $ gr
drawGraphNode opts@(DrawConfig { _drawLeaf = (DrawItem drawType) }) cm ncm _ lgdm gr (n, Just items) pos =
((textDia dnn # fontSizeL (smallestAxis dia)) <> dia) # moveTo pos
where
dia = drawLeafDia drawType
drawLeafDia DrawDiversity =
( (circle 1 # fc (getNodeColor ncm n) # lw none # scaleUToY scaleVal)
<> background PieChart
)
drawLeafDia _ = ( collectionDia (_drawCollection opts)
<> itemsDia
<> background (_drawCollection opts)
)
background PieNone = roundedRect (width itemsDia) (height itemsDia) 1 # fc white # lw none # scaleUToY (scaleVal * 1.1)
background x@(CollectionGraph{}) = roundedRect (width (collectionDia x)) (height (collectionDia x)) 1 # fc white # lw none # scaleUToY (scaleVal * 1.1)
background _ = circle 1 # fc white # lw none # scaleUToY scaleVal
itemsDia = getItemsDia $ _drawCollection opts
getItemsDia PieNone = scaleUToY scaleVal $ drawGraphItem cm items
getItemsDia PieChart = mempty
getItemsDia (CollectionGraph{}) = mempty
getItemsDia _ = scaleUToY (0.5 * scaleVal) $ drawGraphItem cm items
collectionDia PieNone = mempty
collectionDia x =
scaleUToY scaleVal $ drawCollectionItem x cm lgdm n items
scaleVal = if unDrawNoScaleNodesFlag . _drawNoScaleNodesFlag $ opts
then maxLeafNodeSize
else getScaledLeafSize maxClusterSize' maxLeafNodeSize items
maxLeafNodeSize = unDrawMaxLeafNodeSize . _drawMaxLeafNodeSize $ opts
maxClusterSize' = maxClusterSize . unClusterGraph $ gr
textDia True = text (show n) # fc (bool black white . isNothing $ cm)
textDia False = mempty
dnn = unDrawNodeNumber . _drawNodeNumber $ opts
drawGraphNode opts cm ncm mcm _ gr (n, Nothing) pos =
(mark mcm <> mainNode) # moveTo pos
where
mainNode = ((textDia dnn # fontSizeL 1) <> mainDia)
# scaleUToY (getNodeSize (_drawNoScaleNodesFlag opts) items)
mainDia = circle 1 # fc color # rootDiffer n
mark :: Maybe MarkColorMap -> Diagram B
mark Nothing = mempty
mark (Just (MarkColorMap cm)) =
circle 1
# fcA transparent
# lcA (Map.findWithDefault transparent n cm)
# lw 0.4
# scaleUToY (unDrawMaxNodeSize . _drawMaxNodeSize $ opts)
dnn = unDrawNodeNumber . _drawNodeNumber $ opts
textDia True = text (show n) # fc (bool black white . isNothing $ cm)
textDia False = mempty
rootDiffer 0 = lw none
rootDiffer n = lw none
color = getNodeColor ncm n
items = getGraphLeafItems gr n
getNodeSize :: DrawNoScaleNodesFlag -> Seq.Seq a -> Double
getNodeSize (DrawNoScaleNodesFlag False) =
isTo totalItems (unDrawMaxNodeSize . _drawMaxNodeSize $ opts)
. fromIntegral
. Seq.length
getNodeSize (DrawNoScaleNodesFlag True) =
const (unDrawMaxNodeSize . _drawMaxNodeSize $ opts)
totalItems = fromIntegral . Seq.length . getGraphLeafItems gr $ 0
-- | Plot the graph of a leaf.
plotLeafGraph
:: (Ord a, TreeItem a)
=> Maybe ItemColorMap -> LeafGraph a -> IO (Diagram B)
plotLeafGraph cm (LeafGraph gr) = do
let params :: (TreeItem a) => G.GraphvizParams Int (G.Node, a) Double () (G.Node, a)
params = G.defaultDiaParams
{ G.fmtEdge = (\(_, _, w) -> [G.Weight . G.Int . round $ 100 * w])
-- , G.globalAttributes = [G.GraphAttrs { G.attrs = [G.Sep $ G.DVal 36] }]
}
layout <- G.layoutGraph G.Neato gr
let drawNode (_, x) pos =
( getItem
. maybe black ( Map.findWithDefault black (getId x)
. unItemColorMap
)
$ cm
)
# scaleUToY 36
# moveTo pos
drawEdge _ p1 _ p2 w p = arrowBetween' (opts p) p1 p2
# lc (blend w black white)
# lwL 5
opts p = with
& gaps .~ 0
& arrowHead .~ noHead
& arrowShaft .~ (unLoc . head $ pathTrails p)
treeDia =
G.drawGraph'
G.VerticesOnTop
drawNode
drawEdge
layout
return $ treeDia # center
-- | Plot a graph rather than a traditional tree. Uses only info in leaves
-- rather than a tree which stores all leaves.
plotGraph
:: (Ord a, TreeItem a)
=> Maybe (Diagram B)
-> DrawConfig
-> Maybe ItemColorMap
-> Maybe NodeColorMap
-> Maybe MarkColorMap
-> Maybe (LeafGraphMap T.Text)
-> ClusterGraph a
-> IO (Diagram B)
plotGraph legend opts cm ncm mcm lgm (ClusterGraph gr) = do
let numClusters :: Double
numClusters = fromIntegral . Seq.length $ getGraphLeaves gr 0
maxNodeSize = unDrawMaxNodeSize . _drawMaxNodeSize $ opts
params :: (TreeItem a) => G.GraphvizParams Int (G.Node, Maybe (Seq.Seq a)) ClusterEdge () (G.Node, Maybe (Seq.Seq a))
params = G.defaultDiaParams
{ G.fmtEdge = (\(_, _, !w) -> [G.Len . fromMaybe 0 . L.view edgeDistance $ w])
, G.globalAttributes = [G.GraphAttrs { G.attrs = [G.Sep . G.DVal $ maxNodeSize / 2] }]
}
layout <- G.layoutGraph' params G.TwoPi gr
-- Get the graphs at each leaf (if applicable).
lgdm <- sequence
. fmap ( fmap LeafGraphDiaMap
. sequence
. Map.map (plotLeafGraph cm)
. unLeafGraphMap
)
$ lgm
let treeDia =
G.drawGraph'
G.VerticesOnTop
(drawGraphNode opts cm ncm mcm lgdm (ClusterGraph gr))
(drawGraphPath opts ncm (ClusterGraph gr))
layout
dia = case legend of
Nothing -> pad 1 . center $ treeDia
(Just l) ->
pad 1
. hsep
(unDrawLegendSep . _drawLegendSep $ opts)
$ [ alignY 1.5 . lw 0.3 . center . scaleUToX (width treeDia / 8) $ l
, alignT . center $ treeDia
]
return dia