diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -60,25 +60,33 @@ minDistance' = fmap MinDistance . unHelpful . minDistance $ opts minDistanceSearch' = fmap MinDistanceSearch . unHelpful . minDistanceSearch $ opts smartCutoff' = fmap SmartCutoff . unHelpful . smartCutoff $ opts + elbowCutoff' = + fmap ( ElbowCutoff + . fromMaybe (error "Cannot read --elbow-cutoff.") + . readMaybe + ) + . unHelpful + . elbowCutoff + $ opts customCut' = CustomCut . Set.fromList . unHelpful . customCut $ opts rootCut' = fmap RootCut . unHelpful . rootCut $ opts order' = fmap Order . unHelpful . order $ opts drawLeaf' = maybe (maybe DrawText (const (DrawItem DrawLabel)) labelsFile') - (fromMaybe (error "Cannot read draw-leaf.") . readMaybe) + (fromMaybe (error "Cannot read --draw-leaf.") . readMaybe) . unHelpful . drawLeaf $ opts drawCollection' = maybe PieChart - (fromMaybe (error "Cannot read draw-collection.") . readMaybe) + (fromMaybe (error "Cannot read --draw-collection.") . readMaybe) . unHelpful . drawCollection $ opts drawMark' = maybe MarkNone - (fromMaybe (error "Cannot read draw-mark.") . readMaybe) + (fromMaybe (error "Cannot read --draw-mark.") . readMaybe) . unHelpful . drawMark $ opts @@ -101,7 +109,7 @@ DrawLegendAllLabels . unHelpful . drawLegendAllLabels $ opts drawPalette' = maybe Set1 - (fromMaybe (error "Cannot read palette") . readMaybe) + (fromMaybe (error "Cannot read --palette") . readMaybe) . unHelpful . drawPalette $ opts @@ -178,6 +186,7 @@ , _birchMinDistance = minDistance' , _birchMinDistanceSearch = minDistanceSearch' , _birchSmartCutoff = smartCutoff' + , _birchElbowCutoff = elbowCutoff' , _birchCustomCut = customCut' , _birchRootCut = rootCut' , _birchOrder = order' 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.2.0 +version: 0.2.3.0 license: GPL-3 license-file: LICENSE copyright: 2019 Gregory W. Schwartz @@ -34,42 +34,43 @@ ghc-options: -O2 build-depends: base >=4.7 && <5, - SVGFonts >=1.6.0.3, - aeson >=1.3.1.1, + SVGFonts >=1.7.0.1, + aeson >=1.4.4.0, bytestring >=0.10.8.2, cassava >=0.5.1.0, - colour >=2.3.4, - containers >=0.5.11.0, - deepseq >=1.4.3.0, + colour >=2.3.5, + containers >=0.6.0.1, + deepseq >=1.4.4.0, diagrams >=1.4, - diagrams-cairo >=1.4.1, + diagrams-cairo >=1.4.1.1, diagrams-graphviz >=1.4.1, diagrams-gtk >=1.4, diagrams-lib >=1.4.2.3, diversity >=0.8.1.0, - fgl >=5.6.0.0, - foldl >=1.4.2, - graphviz >=2999.20.0.2, - gtk >=0.14.7, - hierarchical-clustering >=0.4.6, + elbow >=0.2.0.0, + fgl >=5.7.0.1, + foldl >=1.4.5, + graphviz >=2999.20.0.3, + gtk >=0.15.4, + hierarchical-clustering >=0.4.7, hierarchical-spectral-clustering >=0.5.0.1, - lens >=4.16.1, + lens >=4.17.1, matrix-market-attoparsec >=0.1.0.8, mtl >=2.2.2, optparse-generic >=1.3.0, - palette >=0.3.0.1, - plots >=0.1.1.0, + palette >=0.3.0.2, + plots >=0.1.1.2, safe >=0.3.17, scientific >=0.3.6.2, sparse-linear-algebra >=0.3.1, - spectral-clustering >=0.3.1.1, + spectral-clustering >=0.3.1.3, split >=0.2.3.3, - statistics >=0.14.0.2, + statistics >=0.15.0.0, temporary >=1.3, - text >=1.2.3.0, - text-show >=3.7.4, - typed-spreadsheet >=1.1.3, - vector >=0.12.0.1 + text >=1.2.3.1, + text-show >=3.8.2, + typed-spreadsheet >=1.1.4, + vector >=0.12.0.3 executable birch-beer main-is: Main.hs @@ -77,20 +78,21 @@ default-language: Haskell2010 ghc-options: -threaded -rtsopts -O2 build-depends: - base >=4.11.1.0, - aeson >=1.3.1.1, + base >=4.12.0.0, + aeson >=1.4.4.0, birch-beer -any, bytestring >=0.10.8.2, cassava >=0.5.1.0, - colour >=2.3.4, - containers >=0.5.11.0, + colour >=2.3.5, + containers >=0.6.0.1, diagrams >=1.4, - diagrams-cairo >=1.4.1, + diagrams-cairo >=1.4.1.1, diagrams-lib >=1.4.2.3, + elbow >=0.2.0.0, hierarchical-spectral-clustering >=0.5.0.1, - lens >=4.16.1, + lens >=4.17.1, optparse-generic >=1.3.0, sparse-linear-algebra >=0.3.1, - text >=1.2.3.0, - text-show >=3.7.4, - vector >=0.12.0.1 + text >=1.2.3.1, + text-show >=3.8.2, + vector >=0.12.0.3 diff --git a/src/BirchBeer/Interactive.hs b/src/BirchBeer/Interactive.hs --- a/src/BirchBeer/Interactive.hs +++ b/src/BirchBeer/Interactive.hs @@ -104,6 +104,7 @@ , _birchMinDistance = Nothing , _birchMinDistanceSearch = Nothing , _birchSmartCutoff = Nothing + , _birchElbowCutoff = Nothing , _birchCustomCut = CustomCut Set.empty , _birchRootCut = Nothing , _birchOrder = Nothing diff --git a/src/BirchBeer/MainDiagram.hs b/src/BirchBeer/MainDiagram.hs --- a/src/BirchBeer/MainDiagram.hs +++ b/src/BirchBeer/MainDiagram.hs @@ -43,36 +43,52 @@ let tree = _birchTree config labelMap' = _birchLabelMap config smartCutoff' = _birchSmartCutoff config + elbowCutoff' = _birchElbowCutoff config customCut' = _birchCustomCut config rootCut' = _birchRootCut config maxStep' = _birchMaxStep config minSize' = - case (fmap unSmartCutoff smartCutoff', _birchMinSize config) of - (Just x, Just _) -> + case (fmap unSmartCutoff smartCutoff', fmap unElbowCutoff elbowCutoff', _birchMinSize config) of + (_, Just x, Just _) -> Just . MinClusterSize . round . (2 **) + . elbowCut x (Just . logBase 2 . getSize) + $ tree + (Just x, Nothing, Just _) -> + Just + . MinClusterSize + . round + . (2 **) . smartCut x (Just . logBase 2 . getSize) $ tree otherwise -> _birchMinSize config maxProportion' = - case (fmap unSmartCutoff smartCutoff', _birchMaxProportion config) of - (Just x, Just _) -> Just - . MaxProportion - . (2 **) - $ smartCut x getProportion tree - otherwise -> _birchMaxProportion config + case (fmap unSmartCutoff smartCutoff', fmap unElbowCutoff elbowCutoff', _birchMaxProportion config) of + (_, Just x, Just _) -> Just + . MaxProportion + . (2 **) + $ elbowCut x getProportion tree + (Just x, Nothing, Just _) -> Just + . MaxProportion + . (2 **) + $ smartCut x getProportion tree + otherwise -> _birchMaxProportion config minDistance' = - case (fmap unSmartCutoff smartCutoff', _birchMinDistance config) of - (Just x, Just _) -> + case (fmap unSmartCutoff smartCutoff', fmap unElbowCutoff elbowCutoff', _birchMinDistance config) of + (_, Just x, Just _) -> + Just . MinDistance $ elbowCut x getDistance tree + (Just x, Nothing, Just _) -> Just . MinDistance $ smartCut x getDistance tree - otherwise -> _birchMinDistance config + otherwise -> _birchMinDistance config minDistanceSearch' = - case (fmap unSmartCutoff smartCutoff', _birchMinDistanceSearch config) of - (Just x, Just _) -> + case (fmap unSmartCutoff smartCutoff', fmap unElbowCutoff elbowCutoff', _birchMinDistanceSearch config) of + (_, Just x, Just _) -> + Just . MinDistanceSearch $ elbowCut x getDistance tree + (Just x, Nothing, Just _) -> Just . MinDistanceSearch $ smartCut x getDistance tree - otherwise -> _birchMinDistanceSearch config + otherwise -> _birchMinDistanceSearch config drawLeaf' = _birchDrawLeaf config drawCollection' = _birchDrawCollection config drawMark' = _birchDrawMark config diff --git a/src/BirchBeer/Options.hs b/src/BirchBeer/Options.hs --- a/src/BirchBeer/Options.hs +++ b/src/BirchBeer/Options.hs @@ -27,7 +27,8 @@ , maxProportion :: Maybe Double "([Nothing] | DOUBLE) Stopping criteria to stop at the node immediate after a node with DOUBLE proportion split. So a node N with L and R children will stop with this criteria at 0.5 if |L| / |R| < 0.5 or > 2 (absolute log2 transformed), that is, if one child has over twice as many items as the other child. Includes L and R in the final result." , minDistance :: Maybe Double "([Nothing] | DOUBLE) Stopping criteria to stop at the node immediate after a node with DOUBLE distance. So a node N with L and R children will stop with this criteria the distance at N to L and R is < DOUBLE. Includes L and R in the final result." , minDistanceSearch :: Maybe Double "([Nothing] | DOUBLE) Similar to --min-distance, but searches from the leaves to the root -- if a path from a subtree contains a distance of at least DOUBLE, keep that path, otherwise prune it. This argument assists in finding distant nodes." - , smartCutoff :: Maybe Double "([Nothing] | DOUBLE) Whether to set the cutoffs for --min-size, --max-proportion, --min-distance, and --min-distance-search based off of the distributions (median + (DOUBLE * MAD)) of all nodes. To use smart cutoffs, use this argument and then set one of the three arguments to an arbitrary number, whichever cutoff type you want to use. --min-size distribution is log2 transformed." + , smartCutoff :: Maybe Double "([Nothing] | DOUBLE) Whether to set the cutoffs for --min-size, --max-proportion, --min-distance, and --min-distance-search based off of the distributions (median + (DOUBLE * MAD)) of all nodes. To use smart cutoffs, use this argument and then set one of the three arguments to an arbitrary number, whichever cutoff type you want to use. --max-proportion and --min-size distributions are log2 transformed." + , elbowCutoff :: Maybe String "(Max | Min) Whether to set the cutoffs for --min-size, --max-proportion, --min-distance, and --min-distance-search based off of the elbow point of distributions of all nodes. For a distribution in positive x and y on a graph, the top left hump would be Max and the bottom right dip would be Min. To use elbow cutoffs, use this argument and then set one of the three arguments to an arbitrary number, whichever cutoff type you want to use. --max-proportion and --min-size distributions are log2 transformed. Conflicts with --smart-cutoff, so this argument takes precedent." , 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." @@ -66,6 +67,7 @@ short "drawNodeNumber" = Just 'N' short "drawPalette" = Just 'Y' short "drawScaleSaturation" = Just 'V' + short "elbowCut" = Nothing short "inputMatrix" = Just 'X' short "interactive" = Just 'I' short "maxProportion" = Just 'P' diff --git a/src/BirchBeer/Stopping.hs b/src/BirchBeer/Stopping.hs --- a/src/BirchBeer/Stopping.hs +++ b/src/BirchBeer/Stopping.hs @@ -26,6 +26,7 @@ , getProportionDend , smartCut , smartCutDend + , elbowCut , customCut , searchCut ) where @@ -38,6 +39,7 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Tree (Tree (..), flatten) +import Math.Elbow (MinMax (..), findElbowList) import Safe (headMay) import qualified Control.Lens as L import qualified Data.Clustering.Hierarchical as HC @@ -265,3 +267,14 @@ smartCut n f tree = median S.s xs + (n * mad S.s xs) where xs = V.fromList . catMaybes . getNodeInfo f $ tree + +-- | Get the elbow point of a tree. +elbowCut :: + MinMax -> (Tree (TreeNode a) -> Maybe Double) -> Tree (TreeNode a) -> Double +elbowCut minMax f tree = + fromMaybe (error "No elbow point found") + . fmap (snd . snd) + . findElbowList minMax + $ [[0..genericLength xs - 1], xs] + where + xs = 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 @@ -24,6 +24,7 @@ import Diagrams.Backend.Cairo import Diagrams.Prelude hiding (distance) import GHC.Generics (Generic) +import Math.Elbow (MinMax (..)) import TextShow (showt) import qualified Control.Lens as L import qualified Data.Aeson as A @@ -119,6 +120,9 @@ newtype SmartCutoff = SmartCutoff { unSmartCutoff :: Double } deriving (Read,Show) +newtype ElbowCutoff = ElbowCutoff + { unElbowCutoff :: MinMax + } deriving (Read,Show) newtype Order = Order { unOrder :: Double } deriving (Read,Show) @@ -225,6 +229,7 @@ data Config a b = Config { _birchLabelMap :: Maybe LabelMap , _birchSmartCutoff :: Maybe SmartCutoff + , _birchElbowCutoff :: Maybe ElbowCutoff , _birchCustomCut :: CustomCut , _birchRootCut :: Maybe RootCut , _birchMinSize :: Maybe MinClusterSize