diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -5,30 +5,30 @@ using the clumpiness metric -} --- Standard +-- Remote +import Data.Aeson import Data.Maybe -import Data.Tree import Data.Semigroup ((<>)) - --- Cabal -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.ByteString.Lazy.Char8 as C -import Data.Aeson +import Data.Tree import Math.TreeFun.Tree import Math.TreeFun.Types -import qualified Math.Clumpiness.Algorithms as Clump -import qualified Biobase.Newick as Newick import Options.Applicative +import qualified Biobase.Newick as Newick +import qualified Data.ByteString.Lazy.Char8 as C +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Math.Clumpiness.Algorithms as Clump -- Local -import Types -import Utility +import Clumpiness +import LineageConvert import NewickConvert +import Print import RJSONConvert -import LineageConvert import TreeTransform -import Print +import Types +import Utility -- Command line arguments data Options = Options { input :: Maybe String @@ -53,7 +53,7 @@ <*> option auto ( long "format" <> short 'f' - <> metavar "[JSON] | RJSON | Haskell | Lineage LABEL" + <> metavar "[JSON] | RJSON | Haskell HaskellFormat | Lineage LABEL" <> value JSON <> help "Whether the input tree is in JSON, RJSON, Haskell, or Lineage format.\ \ The format for JSON is\ @@ -62,7 +62,9 @@ \ \"toJSON(as.list(as.Node(dendrogram), mode = \"explicit\", unname = TRUE))\"\ \ using the data.tree and jsonlite libraries,\ \ where \"dendrogram\" is a dendrogram object in R.\ - \ The format for Haskell is \"Tree NodeLabel\" from this library.\ + \ The format for Haskell STRING is one of\ + \ \"Tree NodeLabel\" (BaseFormat) from this library or\ + \ \"Tree (Seq Text)\" (TreeFormat).\ \ The Lineage format needs an additional field to\ \ specify what to use as the label\ \ (for instance, Lineage tissues).\ @@ -110,12 +112,15 @@ ) -- | Get the tree from a Haskell format -haskellFormat :: Options -> IO (Tree NodeLabel) -haskellFormat opts = do +haskellFormat :: Options -> HaskellFormat -> IO (Tree NodeLabel) +haskellFormat opts format = do contents <- case input opts of Nothing -> getContents (Just x) -> readFile x - return . read $ contents + return . makeWork format $ contents + where + makeWork BaseFormat x = makeWorkable (read x :: Tree NodeLabel) + makeWork TreeFormat x = makeWorkable (read x :: Tree (Seq.Seq T.Text)) -- | Get the tree from a JSON format jsonFormat :: Options -> IO (Tree NodeLabel) @@ -162,30 +167,21 @@ findClumpiness :: Options -> IO () findClumpiness opts = do inputTree <- case inputFormat opts of - Haskell -> haskellFormat opts - JSON -> jsonFormat opts - RJSON -> rJsonFormat opts - Newick -> newickFormat opts - Lineage x -> lineageFormat opts x - let inputSuperTree = convertToSuperTree - . filterExclusiveTree (inputExclusivity opts) - . (\ x -> if excludeInnerFlag opts - then x - else innerToLeaves x - ) - . (\ x -> if predefinedIDs opts - then x - else addUniqueNodeIDs x - ) - $ inputTree - propertyMap = getPropertyMap inputSuperTree - clumpResult = Clump.generateClumpMap - (const True) - propertyMap - inputSuperTree + Haskell x -> haskellFormat opts x + JSON -> jsonFormat opts + RJSON -> rJsonFormat opts + Newick -> newickFormat opts + Lineage x -> lineageFormat opts x + let clumpResult = + getClumpiness + (inputExclusivity opts) + (predefinedIDs opts) + (excludeInnerFlag opts) + inputTree + case output opts of - Nothing -> T.putStrLn . printClumpList $ clumpResult + Nothing -> T.putStr . printClumpList $ clumpResult (Just x) -> T.writeFile x . printClumpList $ clumpResult main :: IO () diff --git a/find-clumpiness.cabal b/find-clumpiness.cabal --- a/find-clumpiness.cabal +++ b/find-clumpiness.cabal @@ -1,5 +1,5 @@ name: find-clumpiness -version: 0.2.2.0 +version: 0.2.3.0 synopsis: Find the clumpiness of labels in a tree description: Use a clumpiness measure to find the aggregation relationship between labels inside of a tree. homepage: http://github.com/GregorySchwartz/find-clumpiness#readme @@ -21,13 +21,15 @@ , RJSONConvert , LineageConvert , TreeTransform + , Clumpiness , Print build-depends: base >= 4.7 && < 5 - , clumpiness , BiobaseNewick , aeson , bytestring + , clumpiness , containers + , hierarchical-clustering , listsafe , mtl , text diff --git a/src/Clumpiness.hs b/src/Clumpiness.hs new file mode 100644 --- /dev/null +++ b/src/Clumpiness.hs @@ -0,0 +1,39 @@ +{- Clumpiness +By Gregory W. Schwartz + +Contains an easier to use version of the clumpiness function. +-} + +module Clumpiness + ( getClumpiness + ) where + +-- Cabal +import Data.Tree (Tree) +import Math.Clumpiness.Algorithms (generateClumpMap) +import Math.Clumpiness.Types (ClumpList) + +-- Local +import TreeTransform +import Types + +getClumpiness :: Exclusivity -- ^ How to look at vertices with multiple labels. + -> Bool -- ^ Whether the unique node IDs are predefined (recommended False unless you know what you are doing) + -> Bool -- ^ Whether to look at labels in inner vertices. + -> Tree NodeLabel + -> ClumpList Label +getClumpiness exclusivity predefinedIDs excludeInner tree = + generateClumpMap (const True) propertyMap superTree + where + superTree = convertToSuperTree + . filterExclusiveTree exclusivity + . (\ x -> if excludeInner + then x + else innerToLeaves x + ) + . (\ x -> if predefinedIDs + then x + else addUniqueNodeIDs x + ) + $ tree + propertyMap = getPropertyMap superTree diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -3,26 +3,29 @@ -- -- Collects all application specific types +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} module Types where --- Standard +-- Remote +import Data.Aeson +import Data.Tree import GHC.Generics import qualified Data.Sequence as Seq -import Data.Tree - --- Cabal import qualified Data.Text as T -import Data.Aeson +import qualified Data.Clustering.Hierarchical as H -- Algebraic data NodeLabel = NodeLabel { nodeID :: !T.Text , nodeLabels :: !Labels } deriving (Generic, Eq, Ord, Read, Show) -data Format = JSON | RJSON | Haskell | Newick | Lineage T.Text deriving (Read) +data Format = JSON | RJSON | Haskell HaskellFormat | Newick | Lineage T.Text deriving (Read) +data HaskellFormat = BaseFormat | TreeFormat | DendrogramFormat deriving (Read) + data Exclusivity = Exclusive | AllExclusive | Majority deriving (Read) newtype Separator = Separator T.Text deriving (Show) @@ -35,3 +38,26 @@ type Labels = Seq.Seq Label instance FromJSON NodeLabel + +-- | Class of trees that can be converted to workable trees. +class WorkableTree a where + makeWorkable :: a -> Tree NodeLabel + +instance WorkableTree (Tree NodeLabel) where + makeWorkable = id + +instance WorkableTree (Tree (Seq.Seq T.Text)) where + makeWorkable (Node { rootLabel = ls, subForest = xs}) = + Node { rootLabel = NodeLabel { nodeID = "", nodeLabels = ls} + , subForest = fmap makeWorkable xs + } + +instance WorkableTree (H.Dendrogram (Seq.Seq T.Text)) where + makeWorkable (H.Leaf x) = + Node { rootLabel = NodeLabel { nodeID = "", nodeLabels = x} + , subForest = [] + } + makeWorkable (H.Branch _ l r) = + Node { rootLabel = NodeLabel { nodeID = "", nodeLabels = Seq.empty } + , subForest = [makeWorkable l, makeWorkable r] + }