birch-beer 0.1.3.0 → 0.1.3.1
raw patch · 8 files changed
+138/−38 lines, 8 files
Files
- app/Main.hs +19/−1
- birch-beer.cabal +1/−1
- src/BirchBeer/ColorMap.hs +28/−1
- src/BirchBeer/Interactive.hs +1/−0
- src/BirchBeer/MainDiagram.hs +23/−3
- src/BirchBeer/Plot.hs +41/−31
- src/BirchBeer/Types.hs +6/−0
- src/BirchBeer/Utility.hs +19/−1
app/Main.hs view
@@ -20,7 +20,7 @@ import Math.Clustering.Hierarchical.Spectral.Load (readSparseAdjMatrix) import Options.Generic import System.IO (openFile, hClose, IOMode (..))-import Text.Read (readMaybe)+import Text.Read (readMaybe, readEither) import TextShow (showt) import qualified Control.Lens as L import qualified Data.Aeson as A@@ -68,6 +68,7 @@ , drawLegendAllLabels :: Bool <?> "Whether to show all the labels in the label file instead of only showing labels within the current tree. The program generates colors from all labels in the label file first in order to keep consistent colors. By default, this value is false, meaning that only the labels present in the tree are shown (even though the colors are the same). The subset process occurs after --draw-colors, so when using that argument make sure to account for all labels." , drawPalette :: Maybe String <?> "([Set1] | Hsv | Ryb) Palette to use for legend colors. With high saturation in --draw-scale-saturation, consider using Hsv to better differentiate colors." , 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." , interactive :: Bool <?> "Display interactive tree." } deriving (Generic)@@ -83,6 +84,7 @@ short "maxDistance" = Just 'T' short "drawLeaf" = Just 'L' short "drawCollection" = Just 'D'+ short "drawDiscretize" = Nothing short "drawNodeNumber" = Just 'N' short "drawMark" = Just 'K' short "drawColors" = Just 'R'@@ -167,6 +169,21 @@ . unHelpful . drawColors $ opts+ drawDiscretize' = (=<<) (\x -> either error Just+ . either+ (\ err -> either+ (\y -> Left $ finalError err y)+ (Right . SegmentColorMap)+ (readEither x :: Either String Int)+ )+ (Right . CustomColorMap . fmap sRGB24read)+ $ (readEither x :: Either String [String])+ )+ . unHelpful+ . drawDiscretize+ $ opts+ where+ finalError err x = "Error in draw-discretize: " <> err <> " " <> x drawScaleSaturation' = fmap DrawScaleSaturation . unHelpful . drawScaleSaturation $ opts output' =@@ -229,6 +246,7 @@ , _birchDrawLegendAllLabels = drawLegendAllLabels' , _birchDrawPalette = drawPalette' , _birchDrawColors = drawColors'+ , _birchDrawDiscretize = drawDiscretize' , _birchDrawScaleSaturation = drawScaleSaturation' , _birchTree = tree , _birchMat = Nothing
birch-beer.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: birch-beer-version: 0.1.3.0+version: 0.1.3.1 license: GPL-3 license-file: LICENSE copyright: 2019 Gregory W. Schwartz
src/BirchBeer/ColorMap.hs view
@@ -27,6 +27,8 @@ , saturateNodeColorMap , saturateItemColorMap , saturateLabelColorMap+ , getDiscreteColorMap+ , discretizeColorMap ) where -- Remote@@ -380,4 +382,29 @@ -- | Saturate the label color map by multiplying the saturation in the HSV model -- by a specified amount. saturateLabelColorMap :: DrawScaleSaturation -> LabelColorMap -> LabelColorMap-saturateLabelColorMap x = LabelColorMap . fmap (saturateColor x) . unLabelColorMap+saturateLabelColorMap x =+ LabelColorMap . fmap (saturateColor x) . unLabelColorMap++-- | Get the color map list from user input, either the list itself or a way to+-- segment the current color scheme.+getDiscreteColorMap :: DrawLeaf+ -> Maybe CustomColors+ -> Maybe LabelColorMap+ -> DrawDiscretize+ -> Maybe DiscreteColorMap+getDiscreteColorMap DrawText _ _ _ = Nothing+getDiscreteColorMap _ _ _ (CustomColorMap cs) = Just $ DiscreteColorMap cs+getDiscreteColorMap (DrawItem DrawLabel) _ (Just (LabelColorMap cm)) (SegmentColorMap i) =+ Just . DiscreteColorMap . (\xs -> if Set.size xs <= i then Set.toAscList xs else interpColors i . Set.toAscList $ xs) . Set.fromList . Map.elems $ cm+getDiscreteColorMap (DrawItem (DrawThresholdContinuous _)) _ (Just (LabelColorMap cm)) (SegmentColorMap i) =+ Just . DiscreteColorMap . (\xs -> if Set.size xs <= i then Set.toAscList xs else interpColors i . Set.toAscList $ xs) . Set.fromList . Map.elems $ cm+getDiscreteColorMap _ customColors _ (SegmentColorMap i) =+ Just . DiscreteColorMap $ interpColors i [lowColor, highColor]+ where+ (highColor, lowColor) = getHighLowColors customColors++-- | Discretize color map by converting color to closest color in list.+discretizeColorMap :: (Eq a, Ord a) => DiscreteColorMap+ -> Map.Map a (Colour Double)+ -> Map.Map a (Colour Double)+discretizeColorMap (DiscreteColorMap cs) = fmap (closestColor cs)
src/BirchBeer/Interactive.hs view
@@ -116,6 +116,7 @@ , _birchDrawLegendAllLabels = DrawLegendAllLabels False , _birchDrawPalette = drawPalette' , _birchDrawColors = drawColors'+ , _birchDrawDiscretize = Nothing , _birchDrawScaleSaturation = drawScaleSaturation' , _birchTree = tree , _birchMat = mat
src/BirchBeer/MainDiagram.hs view
@@ -78,6 +78,7 @@ drawLegendSep' = _birchDrawLegendSep config drawPalette' = _birchDrawPalette config drawColors' = _birchDrawColors config+ drawDiscretize' = _birchDrawDiscretize config drawScaleSaturation' = _birchDrawScaleSaturation config order' = fromMaybe (Order 1) $ _birchOrder config mat = return $ _birchMat config@@ -126,6 +127,16 @@ lcm <- labelColorMapRaw lm <- labelMap' return $ labelToItemColorMap lcm lm+ -- | Get the discrete color list.+ discreteColors = drawDiscretize'+ >>= getDiscreteColorMap drawLeaf' drawColors' labelColorMap+ -- | This function will decide whether to update a map or not based on+ -- user input.+ discretizeColorMapHelper :: (Eq a, Ord a)+ => Map.Map a (D.Colour Double)+ -> Map.Map a (D.Colour Double)+ discretizeColorMapHelper cm =+ maybe cm (flip discretizeColorMap cm) discreteColors -- | Get the item color map. itemColorMapRaw <-@@ -144,11 +155,18 @@ _ -> return defaultGetItemColorMap -- | Get the node color map.- let itemColorMap = fmap- (maybe id saturateItemColorMap drawScaleSaturation')+ let itemColorMap = fmap ( ItemColorMap+ . discretizeColorMapHelper+ . unItemColorMap+ . (maybe id saturateItemColorMap drawScaleSaturation')+ ) itemColorMapRaw nodeColorMap =- fmap (maybe id saturateNodeColorMap drawScaleSaturation') $+ fmap ( NodeColorMap+ . discretizeColorMapHelper+ . unNodeColorMap+ . maybe id saturateNodeColorMap drawScaleSaturation'+ ) $ case drawLeaf' of (DrawItem DrawDiversity) -> fmap@@ -185,6 +203,7 @@ fmap ( fmap ( plotContinuousLegend drawColors'+ discreteColors (fromMaybe (DrawScaleSaturation 1) drawScaleSaturation') (fmap Feature x) )@@ -195,6 +214,7 @@ ( fmap ( plotSumContinuousLegend drawColors'+ discreteColors (fromMaybe (DrawScaleSaturation 1) drawScaleSaturation') ) )
src/BirchBeer/Plot.hs view
@@ -261,25 +261,32 @@ ) -- | Continous style of color bar.-cbOpts :: ColourBar B Double-cbOpts = 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- $ defColourBar+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 sat gs mat =+plotContinuousLegend customColors discreteColors sat gs mat = either text dia $ getCombinedFeatures gs $ mat where dia fs = vsep@@ -289,51 +296,54 @@ # fontSizeL legendFontSize , rotateBy (3 / 4) $ renderColourBar- cbOpts+ (cbOpts discreteColors) cm (fromMaybe 0 minVal, fromMaybe 0 maxVal) 100 ] where (minVal, maxVal) = Fold.fold ((,) <$> Fold.minimum <*> Fold.maximum) fs- cm = colourMap- . zip [1..]- . fmap (\x -> saturateColor sat $ blend x highColor lowColor)- $ [0,0.1..1]+ 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 sat mat = vsep+plotSumContinuousLegend customColors discreteColors sat mat = vsep (legendFontSize * 1.2) [ text "Total Sum" # font "Arial" # fontSizeL legendFontSize , rotateBy (3 / 4) $ renderColourBar- cbOpts+ (cbOpts discreteColors) cm (fromMaybe 0 minVal, fromMaybe 0 maxVal) 100 ] where- cm =- 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+ 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.
src/BirchBeer/Types.hs view
@@ -169,6 +169,9 @@ newtype CustomColors = CustomColors { unCustomColors :: [Kolor] } deriving (Read, Show)+newtype DiscreteColorMap = DiscreteColorMap+ { unDiscreteColorMap :: [Kolor]+ } deriving (Read, Show) newtype L = L Double newtype C = C Double newtype H = H Double@@ -190,6 +193,8 @@ data DrawNodeMark = MarkModularity | MarkNone deriving (Read, Show) data Palette = Set1 | Ryb | Hsv | Hcl deriving (Read, Show)+data DrawDiscretize = CustomColorMap [Kolor] | SegmentColorMap Int+ deriving (Read, Show) data DrawConfig = DrawConfig { _drawLeaf :: DrawLeaf@@ -221,6 +226,7 @@ , _birchDrawLegendSep :: DrawLegendSep , _birchDrawPalette :: Palette , _birchDrawColors :: Maybe CustomColors+ , _birchDrawDiscretize :: Maybe DrawDiscretize , _birchDrawScaleSaturation :: Maybe DrawScaleSaturation , _birchTree :: Tree (TreeNode (V.Vector a)) , _birchMat :: Maybe b
src/BirchBeer/Utility.hs view
@@ -5,6 +5,7 @@ -} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} module BirchBeer.Utility@@ -31,6 +32,7 @@ , median , subsetLabelColorMap , getHighLowColors+ , closestColor ) where -- Remote@@ -38,7 +40,7 @@ import Control.Monad.State (MonadState (..), State (..), evalState, execState, modify) import Data.Function (on) import Data.Int (Int32)-import Data.List (genericLength, maximumBy, foldl')+import Data.List (genericLength, maximumBy, minimumBy, foldl') import Data.Maybe (fromMaybe, catMaybes) import Data.Monoid ((<>)) import Data.Tree (Tree (..), flatten)@@ -320,3 +322,19 @@ highColor = fromMaybe D.red $ customColors >>= flip atMay 0 . unCustomColors lowColor = fromMaybe (D.blend 0.2 D.black D.white) $ customColors >>= flip atMay 1 . unCustomColors++-- | Find the closest color from a list.+closestColor :: [D.Colour Double] -> D.Colour Double -> D.Colour Double+closestColor cs c = minimumBy (compare `on` colorDist c) cs++-- | Get the distance between two colors.+colorDist :: D.Colour Double -> D.Colour Double -> Double+colorDist c1 = euclideanDist (colorToList c1) . colorToList++-- | Convert color values to a list.+colorToList :: D.Colour Double -> [Double]+colorToList (D.toSRGB -> D.RGB r g b) = [r, g, b]++-- | Euclidean distance between two lists.+euclideanDist :: [Double] -> [Double] -> Double+euclideanDist xs = sqrt . sum . zipWith (\x y -> (x - y) ** 2) xs