diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -142,6 +142,7 @@ . unHelpful . drawItemLineWeight $ opts + drawBarBounds' = DrawBarBounds . unHelpful . drawBarBounds $ opts output' = fromMaybe "dendrogram.svg" . unHelpful . output $ opts @@ -209,6 +210,7 @@ , _birchDrawScaleSaturation = drawScaleSaturation' , _birchDrawFont = drawFont' , _birchDrawItemLineWeight = drawItemLineWeight' + , _birchDrawBarBounds = drawBarBounds' , _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,98 +1,96 @@ -cabal-version: >=1.10 -name: birch-beer -version: 0.3.1.1 -license: GPL-3 -license-file: LICENSE -copyright: 2019 Gregory W. Schwartz -maintainer: gsch@pennmedicine.upenn.edu -author: Gregory W. Schwartz -homepage: http://github.com/GregorySchwartz/birch-beer#readme -synopsis: Plot a colorful tree. -description: - Generate a tree for displaying a hierarchy of groups with colors, scaling, and more. -category: Bioinformatics -build-type: Simple - -source-repository head - type: git - location: https://github.com/GregorySchwartz/birch-beer +name: birch-beer +version: 0.4.1.0 +synopsis: Plot a colorful tree. +description: Generate a tree for displaying a hierarchy of groups with colors, scaling, and more. +homepage: http://github.com/GregorySchwartz/birch-beer#readme +license: GPL-3 +license-file: LICENSE +author: Gregory W. Schwartz +maintainer: gsch@pennmedicine.upenn.edu +copyright: 2019 Gregory W. Schwartz +category: Bioinformatics +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 library - exposed-modules: - BirchBeer.Types - BirchBeer.ColorMap - BirchBeer.Interactive - BirchBeer.LeafGraph - BirchBeer.Load - BirchBeer.MainDiagram - BirchBeer.Options - BirchBeer.Plot - BirchBeer.Stopping - BirchBeer.Utility - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -O2 - build-depends: - base >=4.7 && <5, - SVGFonts >=1.7.0.1, - aeson >=1.4.6.0, - bytestring >=0.10.8.2, - cassava >=0.5.2.0, - colour >=2.3.5, - containers >=0.6.0.1, - deepseq >=1.4.4.0, - diagrams >=1.4, - diagrams-cairo >=1.4.1.1, - diagrams-graphviz >=1.4.1, - diagrams-gtk >=1.4, - diagrams-lib >=1.4.3, - diversity >=0.8.1.0, - elbow >=0.2.0.0, - fgl >=5.7.0.2, - foldl >=1.4.6, - graphviz >=2999.20.0.4, - gtk >=0.15.4, - hierarchical-clustering >=0.4.7, - hierarchical-spectral-clustering >=0.5.0.1, - lens >=4.17.1, - matrix-market-attoparsec >=0.1.1.3, - mtl >=2.2.2, - optparse-generic >=1.3.1, - palette >=0.3.0.2, - plots >=0.1.1.2, - safe >=0.3.18, - scientific >=0.3.6.2, - sparse-linear-algebra >=0.3.1, - spectral-clustering >=0.3.1.3, - split >=0.2.3.3, - statistics >=0.15.2.0, - temporary >=1.3, - text >=1.2.3.1, - text-show >=3.8.2, - typed-spreadsheet >=1.1.4, - vector >=0.12.1.2 + hs-source-dirs: src + exposed-modules: BirchBeer.Types + , BirchBeer.ColorMap + , BirchBeer.Interactive + , BirchBeer.LeafGraph + , BirchBeer.Load + , BirchBeer.MainDiagram + , BirchBeer.Options + , BirchBeer.Plot + , BirchBeer.Stopping + , BirchBeer.Utility + build-depends: base >= 4.7 && < 5 + , SVGFonts + , aeson + , bytestring + , cassava + , colour + , containers + , deepseq + , diagrams + , diagrams-cairo + , diagrams-graphviz + , diagrams-gtk + , diagrams-lib + , diversity + , elbow + , fgl + , foldl + , graphviz + , gtk + , hierarchical-clustering + -- , hierarchical-clustering-diagrams + , hierarchical-spectral-clustering + , lens + , matrix-market-attoparsec + , mtl + , optparse-generic + , palette + , plots + , safe + , scientific + , sparse-linear-algebra + , spectral-clustering + , split + , statistics + , temporary + , text + , text-show + , typed-spreadsheet + , vector + ghc-options: -O2 + default-language: Haskell2010 executable birch-beer - main-is: Main.hs - hs-source-dirs: app - default-language: Haskell2010 - ghc-options: -threaded -rtsopts -O2 - build-depends: - base >=4.12.0.0, - aeson >=1.4.6.0, - birch-beer -any, - bytestring >=0.10.8.2, - cassava >=0.5.2.0, - colour >=2.3.5, - containers >=0.6.0.1, - diagrams >=1.4, - diagrams-cairo >=1.4.1.1, - diagrams-lib >=1.4.3, - elbow >=0.2.0.0, - hierarchical-spectral-clustering >=0.5.0.1, - lens >=4.17.1, - optparse-generic >=1.3.1, - sparse-linear-algebra >=0.3.1, - text >=1.2.3.1, - text-show >=3.8.2, - vector >=0.12.1.2 + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -O2 + build-depends: base + , aeson + , birch-beer + , bytestring + , cassava + , colour + , containers + , diagrams + , diagrams-cairo + , diagrams-lib + , elbow + , hierarchical-spectral-clustering + , lens + , optparse-generic + , sparse-linear-algebra + , text + , text-show + , vector + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/GregorySchwartz/birch-beer diff --git a/src/BirchBeer/ColorMap.hs b/src/BirchBeer/ColorMap.hs --- a/src/BirchBeer/ColorMap.hs +++ b/src/BirchBeer/ColorMap.hs @@ -255,7 +255,7 @@ -- for combinatorical labeling, but only reports those present in the data set. getLabelMapThresholdContinuous :: (MatrixLike a) - => [(Feature, Double)] -> a -> LabelMap + => [(Feature, Threshold)] -> a -> LabelMap getLabelMapThresholdContinuous gs mat | any (isNothing . getCol . fst) gs = LabelMap Map.empty | otherwise = LabelMap @@ -264,17 +264,20 @@ . getCutoffLabels $ gs' where - getCutoffLabels :: [(Feature, Double)] -> [Label] + getCutoffLabels :: [(Feature, Threshold)] -> [Label] getCutoffLabels = fmap (Label . List.foldl1' (\acc x -> acc <> " " <> x)) . List.transpose . fmap (uncurry getCutoffLabelFeature) getCutoffLabelFeature g v = - fmap (\x -> unFeature g <> " " <> if x > v then "high" else "low") + (\(!xs, !v') -> fmap (\x -> unFeature g <> " " <> if x > v' then "high" else "low") xs) + . (\xs -> (xs, fromThreshold v $ V.fromList xs)) . S.toDenseListSV . flip S.extractCol (colErr g $ getCol g) . getMatrix $ mat + fromThreshold (Exact x) _ = x + fromThreshold (MadMedian x) xs = smartValue x xs gs' = List.sortBy (compare `on` fst) gs colErr g = fromMaybe (error $ "Feature " <> T.unpack (unFeature g) <> " does not exist.") getCol g = V.elemIndex g diff --git a/src/BirchBeer/Interactive.hs b/src/BirchBeer/Interactive.hs --- a/src/BirchBeer/Interactive.hs +++ b/src/BirchBeer/Interactive.hs @@ -126,6 +126,7 @@ , _birchDrawScaleSaturation = drawScaleSaturation' , _birchDrawFont = Nothing , _birchDrawItemLineWeight = drawItemLineWeight' + , _birchDrawBarBounds = DrawBarBounds False , _birchTree = tree , _birchMat = mat , _birchSimMat = simMat @@ -136,9 +137,7 @@ graphicalUI' :: T.Text -> TS.Updatable (IO (D.Diagram D.Cairo)) - -> - -- ^ Program logic - IO () + -> IO () graphicalUI' = TS.ui setupGraphical processGraphicalEvent where setupGraphical :: Gtk.HBox -> IO Gtk.DrawingArea @@ -175,9 +174,7 @@ graphicalUIPng' :: T.Text -> TS.Updatable (IO (D.Diagram D.Cairo)) - -> - -- ^ Program logic - IO () + -> IO () graphicalUIPng' title updatable = withTempFile "." "temp_tree.png" $ \file h -> do TS.ui setupGraphical (processGraphicalEvent file h) title updatable where diff --git a/src/BirchBeer/MainDiagram.hs b/src/BirchBeer/MainDiagram.hs --- a/src/BirchBeer/MainDiagram.hs +++ b/src/BirchBeer/MainDiagram.hs @@ -105,6 +105,7 @@ drawFont' = fromMaybe (DrawFont "Arial") $ _birchDrawFont config drawItemLineWeight' = fromMaybe (DrawItemLineWeight 0.1) $ _birchDrawItemLineWeight config + drawBarBounds' = _birchDrawBarBounds config order' = fromMaybe (Order 1) $ _birchOrder config mat = return $ _birchMat config simMat = _birchSimMat config @@ -137,6 +138,7 @@ drawNoScaleNodes' drawLegendSep' drawItemLineWeight' + drawBarBounds' -- Get the color of each label. let labelColorMapRaw = @@ -246,6 +248,7 @@ fmap ( fmap ( plotContinuousLegend drawFont' + drawBarBounds' drawColors' discreteColors (fromMaybe (DrawScaleSaturation 1) drawScaleSaturation') @@ -258,6 +261,7 @@ ( fmap ( plotSumContinuousLegend drawFont' + drawBarBounds' drawColors' discreteColors (fromMaybe (DrawScaleSaturation 1) drawScaleSaturation') diff --git a/src/BirchBeer/Options.hs b/src/BirchBeer/Options.hs --- a/src/BirchBeer/Options.hs +++ b/src/BirchBeer/Options.hs @@ -33,7 +33,7 @@ , customCut :: [Int] "([Nothing] | NODE) List of nodes to prune (make these nodes leaves). Invoked by --custom-cut 34 --custom-cut 65 etc." , rootCut :: Maybe Int "([Nothing] | NODE) Assign a new root to the tree, removing all nodes outside of the subtree." , order :: Maybe Double "([1] | DOUBLE) The order of diversity for DrawItem DrawDiversity." - , drawLeaf :: Maybe String "([DrawText] | DrawItem DrawItemType) How to draw leaves in the dendrogram. DrawText is the number of items in that leaf. DrawItem is the collection of items represented by circles, consisting of: DrawItem DrawLabel, where each item is colored by its label, DrawItem (DrawContinuous [FEATURE]), where each item is colored by the expression of FEATURE (corresponding to a feature name in the input matrix, [FEATURE] is a list, so if more than one FEATURE is listed, uses the average of the feature values), DrawItem (DrawThresholdContinuous [(FEATURE, DOUBLE)]), where each item is colored by the binary high / low expression of FEATURE based on DOUBLE and multiple FEATUREs can be used to combinatorically label items (FEATURE1 high / FEATURE2 low, etc.), DrawItem DrawSumContinuous, where each item is colored by the sum of the post-normalized columns (use --normalization NoneNorm for UMI counts, default), and DrawItem DrawDiversity, where each node is colored by the diversity based on the labels of each item and the color is normalized separately for the leaves and the inner nodes. The default is DrawText, unless --labels-file is provided, in which DrawItem DrawLabel is the default. If the label or feature cannot be found, the default color will be black (check your spelling!)." + , drawLeaf :: Maybe String "([DrawText] | DrawItem DrawItemType) How to draw leaves in the dendrogram. DrawText is the number of items in that leaf. DrawItem is the collection of items represented by circles, consisting of: DrawItem DrawLabel, where each item is colored by its label, DrawItem (DrawContinuous [FEATURE]), where each item is colored by the expression of FEATURE (corresponding to a feature name in the input matrix, [FEATURE] is a list, so if more than one FEATURE is listed, uses the average of the feature values), DrawItem (DrawThresholdContinuous [(FEATURE, THRESHOLD)]), where each item is colored by the binary high / low expression of FEATURE based on THRESHOLD (either `Exact DOUBLE` or `MadMedian DOUBLE`, where Exact just uses the DOUBLE as a cutoff value while MadMedian uses the DOUBLE as the number of MADs away from the median value of the feature) and multiple FEATUREs can be used to combinatorically label items (FEATURE1 high / FEATURE2 low, etc.), DrawItem DrawSumContinuous, where each item is colored by the sum of the post-normalized columns (use --normalization NoneNorm for UMI counts, default), and DrawItem DrawDiversity, where each node is colored by the diversity based on the labels of each item and the color is normalized separately for the leaves and the inner nodes. The default is DrawText, unless --labels-file is provided, in which DrawItem DrawLabel is the default. If the label or feature cannot be found, the default color will be black (check your spelling!)." , drawCollection :: Maybe String "([PieChart] | PieRing | IndividualItems | Histogram | NoLeaf | CollectionGraph MAXWEIGHT THRESHOLD [NODE]) How to draw item leaves in the dendrogram. PieRing draws a pie chart ring around the items. PieChart only draws a pie chart instead of items. IndividualItems only draws items, no pie rings or charts. Histogram plots a histogram of the features requested. NoLeaf has no leaf, useful if there are so many items the tree takes very long to render. (CollectionGraph MAXWEIGHT THRESHOLD [NODE]) draws the nodes and edges within leaves that are descendents of NODE (empty list [] indicates draw all leaf networks) based on the input matrix, normalizes edges based on the MAXWEIGHT, and removes edges for display less than THRESHOLD (after normalization, so for CollectionGraph 2 0.5 [26], draw the leaf graphs for all leaves under node 26, then a edge of 0.7 would be removed because (0.7 / 2) < 0.5). For CollectionGraph with no colors, use --draw-leaf \"DrawItem DrawLabel\" and all nodes will be black. If you don't specify this option, DrawText from --draw-leaf overrides this argument and only the number of cells will be plotted." , drawMark :: Maybe String "([MarkNone] | MarkModularity | MarkSignificance ) How to draw annotations around each inner node in the tree. MarkNone draws nothing and MarkModularity draws a black circle representing the modularity at that node, darker black means higher modularity for that next split. MarkSignificance is for significance, i.e. p-value, darker means higher value." , drawNodeNumber :: Bool "Draw the node numbers on top of each node in the graph." @@ -48,6 +48,7 @@ , 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." + , drawBarBounds :: Bool "Whether to plot only the minimum and maximum ticks for the color bars." , interactive :: Bool "Display interactive tree." } deriving (Generic) @@ -70,6 +71,7 @@ short "drawNodeNumber" = Just 'N' short "drawPalette" = Just 'Y' short "drawScaleSaturation" = Just 'V' + short "drawBarBounds" = Nothing short "elbowCut" = Nothing short "inputMatrix" = Just 'X' short "interactive" = Just 'I' diff --git a/src/BirchBeer/Plot.hs b/src/BirchBeer/Plot.hs --- a/src/BirchBeer/Plot.hs +++ b/src/BirchBeer/Plot.hs @@ -42,6 +42,7 @@ import Plots.Axis.ColourBar import Plots.Axis.Line import Plots.Legend +import Safe (headMay, lastMay) import qualified Control.Foldl as Fold import qualified Control.Lens as L import qualified Data.Clustering.Hierarchical as HC @@ -270,10 +271,12 @@ ) -- | Continous style of color bar. -cbOpts :: DrawFont -> Maybe DiscreteColorMap -> ColourBar B Double -cbOpts (DrawFont font') discreteColors = +cbOpts + :: DrawFont -> DrawBarBounds -> Maybe DiscreteColorMap -> ColourBar B Double +cbOpts (DrawFont font') dbb discreteColors = over tickLabelStyle (font font' # fontSizeL legendFontSize) . over colourBarStyle (lwL (0.2 * legendFontSize)) + . setTickBounds dbb . set majorTicksStyle (mempty # lwL (0.2 * legendFontSize)) . set (minorTicks . visible) False . set (majorGridLines . visible) False @@ -285,18 +288,34 @@ discreteColors ) $ defColourBar + where + setTickBounds (DrawBarBounds True) = + set + majorTicksFunction + (\(!lb, !ub) + -> (\xs -> fromMaybe [] + . sequence + $ [ headMay . dropWhile (< lb) $ xs + , headMay . dropWhile (> ub) . reverse $ xs + ] + ) + . linearMajorTicks 5 + $ (lb, ub) + ) + setTickBounds (DrawBarBounds False) = id -- | 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) => DrawFont + -> DrawBarBounds -> Maybe CustomColors -> Maybe DiscreteColorMap -> DrawScaleSaturation -> [Feature] -> a -> Diagram B -plotContinuousLegend (DrawFont font') customColors discreteColors sat gs mat = +plotContinuousLegend (DrawFont font') dbb customColors discreteColors sat gs mat = either text dia $ getCombinedFeatures gs $ mat where dia fs = vsep @@ -306,7 +325,7 @@ # fontSizeL legendFontSize , rotateBy (3 / 4) $ renderColourBar - (cbOpts (DrawFont font') discreteColors) + (cbOpts (DrawFont font') dbb discreteColors) cm (fromMaybe 0 minVal, fromMaybe 0 maxVal) 100 @@ -326,17 +345,18 @@ -- https://archives.haskell.org/projects.haskell.org/diagrams/blog/2013-12-03-Palette1.html plotSumContinuousLegend :: (MatrixLike a) => DrawFont + -> DrawBarBounds -> Maybe CustomColors -> Maybe DiscreteColorMap -> DrawScaleSaturation -> a -> Diagram B -plotSumContinuousLegend (DrawFont font') customColors discreteColors sat mat = vsep +plotSumContinuousLegend (DrawFont font') dbb customColors discreteColors sat mat = vsep (legendFontSize * 1.2) [ text "Total Sum" # font font' # fontSizeL legendFontSize , rotateBy (3 / 4) $ renderColourBar - (cbOpts (DrawFont font') discreteColors) + (cbOpts (DrawFont font') dbb discreteColors) cm (fromMaybe 0 minVal, fromMaybe 0 maxVal) 100 diff --git a/src/BirchBeer/Stopping.hs b/src/BirchBeer/Stopping.hs --- a/src/BirchBeer/Stopping.hs +++ b/src/BirchBeer/Stopping.hs @@ -264,7 +264,7 @@ -- | Get the smart cut value of a tree. smartCut :: Double -> (Tree (TreeNode a) -> Maybe Double) -> Tree (TreeNode a) -> Double -smartCut n f tree = median S.s xs + (n * mad S.s xs) +smartCut n f tree = smartValue n xs where xs = V.fromList . catMaybes . getNodeInfo f $ tree diff --git a/src/BirchBeer/Types.hs b/src/BirchBeer/Types.hs --- a/src/BirchBeer/Types.hs +++ b/src/BirchBeer/Types.hs @@ -181,6 +181,9 @@ newtype DrawItemLineWeight = DrawItemLineWeight { unDrawItemLineWeight :: Double } deriving (Read,Show) +newtype DrawBarBounds = DrawBarBounds + { unDrawBarBounds :: Bool + } deriving (Read,Show) newtype ClusterGraph a = ClusterGraph { unClusterGraph :: G.Gr (G.Node, Maybe (Seq.Seq a)) ClusterEdge } deriving (Read, Show) @@ -207,10 +210,12 @@ data (MatrixLike a) => SimMatrix a = SimilarityMatrix a | B2Matrix a -- Advanced +data Threshold = Exact Double | MadMedian Double deriving (Read, Show) + data DrawItemType = DrawLabel | DrawContinuous [T.Text] - | DrawThresholdContinuous [(T.Text, Double)] + | DrawThresholdContinuous [(T.Text, Threshold)] | DrawSumContinuous | DrawDiversity deriving (Read,Show) @@ -231,6 +236,7 @@ , _drawNoScaleNodesFlag :: DrawNoScaleNodesFlag , _drawLegendSep :: DrawLegendSep , _drawItemLineWeight :: DrawItemLineWeight + , _drawBarBounds :: DrawBarBounds } deriving (Read,Show) data Config a b = Config @@ -260,6 +266,7 @@ , _birchDrawScaleSaturation :: Maybe DrawScaleSaturation , _birchDrawFont :: Maybe DrawFont , _birchDrawItemLineWeight :: Maybe DrawItemLineWeight + , _birchDrawBarBounds :: DrawBarBounds , _birchTree :: Tree (TreeNode (V.Vector a)) , _birchMat :: Maybe b , _birchSimMat :: Maybe (SimMatrix b) diff --git a/src/BirchBeer/Utility.hs b/src/BirchBeer/Utility.hs --- a/src/BirchBeer/Utility.hs +++ b/src/BirchBeer/Utility.hs @@ -37,6 +37,7 @@ , closestColor , getNodeAssignments , printNodeAssignments + , smartValue ) where -- Remote @@ -403,3 +404,8 @@ ) ) $ cr + +-- | Get a new value based on a collection of values and the desired number of +-- MADs from the median. +smartValue :: Double -> V.Vector Double -> Double +smartValue n xs = median S.s xs + (n * mad S.s xs)