diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -138,6 +138,10 @@ drawScaleSaturation' = fmap DrawScaleSaturation . unHelpful . drawScaleSaturation $ opts drawFont' = fmap DrawFont . unHelpful . drawFont $ opts + drawItemLineWeight' = fmap DrawItemLineWeight + . unHelpful + . drawItemLineWeight + $ opts output' = fromMaybe "dendrogram.svg" . unHelpful . output $ opts @@ -204,6 +208,7 @@ , _birchDrawDiscretize = drawDiscretize' , _birchDrawScaleSaturation = drawScaleSaturation' , _birchDrawFont = drawFont' + , _birchDrawItemLineWeight = drawItemLineWeight' , _birchTree = tree , _birchMat = Nothing , _birchSimMat = simMat diff --git a/birch-beer.cabal b/birch-beer.cabal --- a/birch-beer.cabal +++ b/birch-beer.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: birch-beer -version: 0.2.4.2 +version: 0.2.5.0 license: GPL-3 license-file: LICENSE copyright: 2019 Gregory W. Schwartz diff --git a/src/BirchBeer/Interactive.hs b/src/BirchBeer/Interactive.hs --- a/src/BirchBeer/Interactive.hs +++ b/src/BirchBeer/Interactive.hs @@ -91,6 +91,9 @@ drawScaleSaturation' <- fmap (Just . DrawScaleSaturation) $ TS.spinButtonAt 1 "Saturate colors in the HSV model" 1 + drawItemLineWeight' <- + fmap (Just . DrawItemLineWeight) + $ TS.spinButtonAt 0.1 "Line weight for item in collection" 1 return $ let drawLeaf' = case drawLeafTemp of @@ -122,6 +125,7 @@ , _birchDrawDiscretize = Nothing , _birchDrawScaleSaturation = drawScaleSaturation' , _birchDrawFont = Nothing + , _birchDrawItemLineWeight = drawItemLineWeight' , _birchTree = tree , _birchMat = mat , _birchSimMat = simMat diff --git a/src/BirchBeer/MainDiagram.hs b/src/BirchBeer/MainDiagram.hs --- a/src/BirchBeer/MainDiagram.hs +++ b/src/BirchBeer/MainDiagram.hs @@ -103,6 +103,8 @@ drawDiscretize' = _birchDrawDiscretize config drawScaleSaturation' = _birchDrawScaleSaturation config drawFont' = fromMaybe (DrawFont "Arial") $ _birchDrawFont config + drawItemLineWeight' = fromMaybe (DrawItemLineWeight 0.1) + $ _birchDrawItemLineWeight config order' = fromMaybe (Order 1) $ _birchOrder config mat = return $ _birchMat config simMat = _birchSimMat config @@ -134,6 +136,7 @@ drawMaxLeafNodeSize' drawNoScaleNodes' drawLegendSep' + drawItemLineWeight' -- Get the color of each label. let labelColorMapRaw = diff --git a/src/BirchBeer/Options.hs b/src/BirchBeer/Options.hs --- a/src/BirchBeer/Options.hs +++ b/src/BirchBeer/Options.hs @@ -46,6 +46,7 @@ , drawColors :: Maybe String "([Nothing] | COLORS) Custom colors for the labels or continuous features. Will repeat if more labels than provided colors. For continuous feature plots, uses first two colors [high, low], defaults to [red, gray]. For instance: --draw-colors \"[\\\"#e41a1c\\\", \\\"#377eb8\\\"]\"" , drawDiscretize :: Maybe String "([Nothing] | COLORS | INT) Discretize colors by finding the nearest color for each item and node. For instance, --draw-discretize \"[\\\"#e41a1c\\\", \\\"#377eb8\\\"]\" will change all node and item colors to one of those two colors, based on Euclidean distance. If using \"--draw-discretize INT\", will instead take the default map and segment (or interpolate) it into INT colors, rather than a more continuous color scheme. May have unintended results when used with --draw-scale-saturation." , drawScaleSaturation :: Maybe Double "([Nothing] | DOUBLE) Multiply the saturation value all nodes by this number in the HSV model. Useful for seeing more visibly the continuous colors by making the colors deeper against a gray scale." + , drawItemLineWeight :: Maybe Double "([0.1] | DOUBLE) The line weight for items in the leaves if shown. Supplied as if there are too many items, the collection may look like a black box. Set to 0 to disable outlines of items to avoid this." , drawFont :: Maybe String "([Arial] | FONT) Specify the font to use for the labels when plotting." , interactive :: Bool "Display interactive tree." } deriving (Generic) diff --git a/src/BirchBeer/Plot.hs b/src/BirchBeer/Plot.hs --- a/src/BirchBeer/Plot.hs +++ b/src/BirchBeer/Plot.hs @@ -165,12 +165,12 @@ -- | 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 = + => Maybe ItemColorMap -> DrawItemLineWeight -> V.Vector a -> Diagram B +dendrogramLeafItem Nothing w leaf = getItem w black # centerX # pad 1.3 # alignT +dendrogramLeafItem (Just (ItemColorMap cm)) w leaf = (vcat . fmap hcat . Split.chunksOf 10 $ items) # centerX # pad 1.3 # alignT where - items = fmap getItem colors + items = fmap (getItem w) colors colors = sort . fmap (flip (Map.findWithDefault black) cm . getId) . V.toList @@ -192,13 +192,17 @@ 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 = +drawGraphItem :: (TreeItem a) + => Maybe ItemColorMap + -> DrawItemLineWeight + -> Seq.Seq a + -> Diagram B +drawGraphItem Nothing w _ = getItem w black # centerX # pad 1.3 # center +drawGraphItem (Just (ItemColorMap cm)) w node = (vcat . fmap hcat . Split.chunksOf boxSize $ items) # center where boxSize = floor . sqrt . fromIntegral . Seq.length $ node - items = fmap getItem colors + items = fmap (getItem w) colors colors = sort . fmap (flip (Map.findWithDefault black) cm . getId) . F.toList @@ -236,8 +240,8 @@ 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. +getItem :: DrawItemLineWeight -> Kolor -> Diagram B +getItem (DrawItemLineWeight w) color = circle 1 # lc black # fc color # lwL w -- | Legend text size. legendFontSize :: Double @@ -495,10 +499,10 @@ 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 PieNone = scaleUToY scaleVal $ drawGraphItem cm (_drawItemLineWeight opts) items getItemsDia PieChart = mempty getItemsDia (CollectionGraph{}) = mempty - getItemsDia _ = scaleUToY (0.5 * scaleVal) $ drawGraphItem cm items + getItemsDia _ = scaleUToY (0.5 * scaleVal) $ drawGraphItem cm (_drawItemLineWeight opts) items collectionDia PieNone = mempty collectionDia x = scaleUToY scaleVal $ drawCollectionItem x cm lgdm n items @@ -543,8 +547,8 @@ -- | Plot the graph of a leaf. plotLeafGraph :: (Ord a, TreeItem a) - => Maybe ItemColorMap -> LeafGraph a -> IO (Diagram B) -plotLeafGraph cm (LeafGraph gr) = do + => Maybe ItemColorMap -> DrawItemLineWeight -> LeafGraph a -> IO (Diagram B) +plotLeafGraph cm ilw (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]) @@ -554,7 +558,7 @@ layout <- G.layoutGraph G.Neato gr let drawNode (_, x) pos = - ( getItem + ( getItem ilw . maybe black ( Map.findWithDefault black (getId x) . unItemColorMap ) @@ -606,7 +610,7 @@ lgdm <- sequence . fmap ( fmap LeafGraphDiaMap . sequence - . Map.map (plotLeafGraph cm) + . Map.map (plotLeafGraph cm (_drawItemLineWeight opts)) . unLeafGraphMap ) $ lgm diff --git a/src/BirchBeer/Types.hs b/src/BirchBeer/Types.hs --- a/src/BirchBeer/Types.hs +++ b/src/BirchBeer/Types.hs @@ -175,6 +175,9 @@ newtype DrawFont = DrawFont { unDrawFont :: String } deriving (Read,Show) +newtype DrawItemLineWeight = DrawItemLineWeight + { unDrawItemLineWeight :: Double + } deriving (Read,Show) newtype ClusterGraph a = ClusterGraph { unClusterGraph :: G.Gr (G.Node, Maybe (Seq.Seq a)) ClusterEdge } deriving (Read, Show) @@ -224,6 +227,7 @@ , _drawMaxLeafNodeSize :: DrawMaxLeafNodeSize , _drawNoScaleNodesFlag :: DrawNoScaleNodesFlag , _drawLegendSep :: DrawLegendSep + , _drawItemLineWeight :: DrawItemLineWeight } deriving (Read,Show) data Config a b = Config @@ -252,6 +256,7 @@ , _birchDrawDiscretize :: Maybe DrawDiscretize , _birchDrawScaleSaturation :: Maybe DrawScaleSaturation , _birchDrawFont :: Maybe DrawFont + , _birchDrawItemLineWeight :: Maybe DrawItemLineWeight , _birchTree :: Tree (TreeNode (V.Vector a)) , _birchMat :: Maybe b , _birchSimMat :: Maybe (SimMatrix b)