diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -128,6 +128,7 @@ finalError err x = "Error in draw-discretize: " <> err <> " " <> x drawScaleSaturation' = fmap DrawScaleSaturation . unHelpful . drawScaleSaturation $ opts + drawFont' = fmap DrawFont . unHelpful . drawFont $ opts output' = fromMaybe "dendrogram.svg" . unHelpful . output $ opts @@ -191,6 +192,7 @@ , _birchDrawColors = drawColors' , _birchDrawDiscretize = drawDiscretize' , _birchDrawScaleSaturation = drawScaleSaturation' + , _birchDrawFont = drawFont' , _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.0.0 +version: 0.2.1.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 @@ -119,6 +119,7 @@ , _birchDrawColors = drawColors' , _birchDrawDiscretize = Nothing , _birchDrawScaleSaturation = drawScaleSaturation' + , _birchDrawFont = Nothing , _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 @@ -85,6 +85,7 @@ drawColors' = _birchDrawColors config drawDiscretize' = _birchDrawDiscretize config drawScaleSaturation' = _birchDrawScaleSaturation config + drawFont' = fromMaybe (DrawFont "Arial") $ _birchDrawFont config order' = fromMaybe (Order 1) $ _birchOrder config mat = return $ _birchMat config simMat = _birchSimMat config @@ -208,6 +209,7 @@ (DrawItem (DrawContinuous x)) -> fmap ( fmap ( plotContinuousLegend + drawFont' drawColors' discreteColors (fromMaybe (DrawScaleSaturation 1) drawScaleSaturation') @@ -219,6 +221,7 @@ fmap ( fmap ( plotSumContinuousLegend + drawFont' drawColors' discreteColors (fromMaybe (DrawScaleSaturation 1) drawScaleSaturation') @@ -230,7 +233,7 @@ lm <- labelMap' lcm <- labelColorMap return - . plotLabelLegend + . plotLabelLegend drawFont' . bool (subsetLabelColorMap gr lm) id diff --git a/src/BirchBeer/Options.hs b/src/BirchBeer/Options.hs --- a/src/BirchBeer/Options.hs +++ b/src/BirchBeer/Options.hs @@ -43,6 +43,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." + , drawFont :: Maybe String "([Arial] | FONT) Specify the font to use for the labels when plotting." , interactive :: Bool "Display interactive tree." } deriving (Generic) @@ -50,27 +51,28 @@ modifiers = lispCaseModifiers { shortNameModifier = short } where short "customCut" = Nothing - short "inputMatrix" = Just 'X' - short "minSize" = Just 'M' - short "maxStep" = Just 'S' - short "maxProportion" = Just 'P' - short "minDistance" = Just 'T' - short "minDistanceSearch" = Nothing - short "drawLeaf" = Just 'L' short "drawCollection" = Just 'D' + short "drawColors" = Just 'R' short "drawDiscretize" = Nothing - short "drawNodeNumber" = Just 'N' + short "drawFont" = Nothing + short "drawLeaf" = Just 'L' + short "drawLegendAllLabels" = Just 'J' + short "drawLegendSep" = Just 'Q' short "drawMark" = Just 'K' - short "drawColors" = Just 'R' - short "drawNoScaleNodes" = Just 'W' - short "drawMaxNodeSize" = Just 'A' short "drawMaxLeafNodeSize" = Nothing - short "drawLegendSep" = Just 'Q' - short "drawLegendAllLabels" = Just 'J' + short "drawMaxNodeSize" = Just 'A' + short "drawNoScaleNodes" = Just 'W' + short "drawNodeNumber" = Just 'N' short "drawPalette" = Just 'Y' short "drawScaleSaturation" = Just 'V' - short "order" = Just 'O' + short "inputMatrix" = Just 'X' short "interactive" = Just 'I' + short "maxProportion" = Just 'P' + short "maxStep" = Just 'S' + short "minDistance" = Just 'T' + short "minDistanceSearch" = Nothing + short "minSize" = Just 'M' + short "order" = Just 'O' short x = firstLetter x instance ParseRecord Options where diff --git a/src/BirchBeer/Plot.hs b/src/BirchBeer/Plot.hs --- a/src/BirchBeer/Plot.hs +++ b/src/BirchBeer/Plot.hs @@ -243,15 +243,15 @@ legendFontSize :: Double legendFontSize = (/ 2.5) $ (def :: Legend B Double) ^. legendSpacing -plotLabelLegend :: LabelColorMap -> Diagram B -plotLabelLegend = flip (drawLegend emptyBox) legendOpts - . fmap plotLabel - . Map.toAscList - . unLabelColorMap +plotLabelLegend :: DrawFont -> LabelColorMap -> Diagram B +plotLabelLegend (DrawFont font') = flip (drawLegend emptyBox) legendOpts + . fmap plotLabel + . Map.toAscList + . unLabelColorMap where legendOpts :: Legend B Double legendOpts = - over legendTextStyle (const (mempty # font "Arial" # fontSizeL legendFontSize)) + over legendTextStyle (const (mempty # font font' # fontSizeL legendFontSize)) . over legendStyle (lw none) $ def plotLabel :: (Label, Colour Double) -> (Diagram B, String) @@ -261,9 +261,9 @@ ) -- | Continous style of color bar. -cbOpts :: Maybe DiscreteColorMap -> ColourBar B Double -cbOpts discreteColors = - over tickLabelStyle (font "Arial" # fontSizeL legendFontSize) +cbOpts :: DrawFont -> Maybe DiscreteColorMap -> ColourBar B Double +cbOpts (DrawFont font') discreteColors = + over tickLabelStyle (font font' # fontSizeL legendFontSize) . over colourBarStyle (lwL (0.2 * legendFontSize)) . set majorTicksStyle (mempty # lwL (0.2 * legendFontSize)) . set (minorTicks . visible) False @@ -280,23 +280,24 @@ -- | 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 + => DrawFont + -> Maybe CustomColors -> Maybe DiscreteColorMap -> DrawScaleSaturation -> [Feature] -> a -> Diagram B -plotContinuousLegend customColors discreteColors sat gs mat = +plotContinuousLegend (DrawFont font') 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" + # font font' # fontSizeL legendFontSize , rotateBy (3 / 4) $ renderColourBar - (cbOpts discreteColors) + (cbOpts (DrawFont font') discreteColors) cm (fromMaybe 0 minVal, fromMaybe 0 maxVal) 100 @@ -315,17 +316,18 @@ -- | 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 + => DrawFont + -> Maybe CustomColors -> Maybe DiscreteColorMap -> DrawScaleSaturation -> a -> Diagram B -plotSumContinuousLegend customColors discreteColors sat mat = vsep +plotSumContinuousLegend (DrawFont font') customColors discreteColors sat mat = vsep (legendFontSize * 1.2) - [ text "Total Sum" # font "Arial" # fontSizeL legendFontSize + [ text "Total Sum" # font font' # fontSizeL legendFontSize , rotateBy (3 / 4) $ renderColourBar - (cbOpts discreteColors) + (cbOpts (DrawFont font') discreteColors) cm (fromMaybe 0 minVal, fromMaybe 0 maxVal) 100 diff --git a/src/BirchBeer/Types.hs b/src/BirchBeer/Types.hs --- a/src/BirchBeer/Types.hs +++ b/src/BirchBeer/Types.hs @@ -165,6 +165,9 @@ newtype DrawScaleSaturation = DrawScaleSaturation { unDrawScaleSaturation :: Double } deriving (Read,Show) +newtype DrawFont = DrawFont + { unDrawFont :: String + } deriving (Read,Show) newtype ClusterGraph a = ClusterGraph { unClusterGraph :: G.Gr (G.Node, Maybe (Seq.Seq a)) ClusterEdge } deriving (Read, Show) @@ -239,6 +242,7 @@ , _birchDrawColors :: Maybe CustomColors , _birchDrawDiscretize :: Maybe DrawDiscretize , _birchDrawScaleSaturation :: Maybe DrawScaleSaturation + , _birchDrawFont :: Maybe DrawFont , _birchTree :: Tree (TreeNode (V.Vector a)) , _birchMat :: Maybe b , _birchSimMat :: Maybe (SimMatrix b)