find-clumpiness 0.2.0.1 → 0.2.1.2
raw patch · 6 files changed
+169/−40 lines, 6 filesdep +BiobaseNewickdep +listsafedep ~optparse-applicative
Dependencies added: BiobaseNewick, listsafe
Dependency ranges changed: optparse-applicative
Files
- app/Main.hs +63/−33
- find-clumpiness.cabal +12/−6
- src/LineageConvert.hs +22/−0
- src/NewickConvert.hs +44/−0
- src/Types.hs +4/−1
- src/Utility.hs +24/−0
app/Main.hs view
@@ -8,21 +8,23 @@ -- Standard import Data.Maybe import Data.Tree-import qualified Data.HashMap.Strict as Hash+import Data.Semigroup ((<>)) -- Cabal-import Options.Applicative-import Math.TreeFun.Tree-import Math.TreeFun.Types-import qualified Math.Clumpiness.Algorithms as Clump 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 qualified Data.Aeson.Types as AT+import Math.TreeFun.Tree+import Math.TreeFun.Types+import qualified Math.Clumpiness.Algorithms as Clump+import qualified Biobase.Newick as Newick+import Options.Applicative -- Local import Types+import Utility+import NewickConvert import LineageConvert import TreeTransform import Print@@ -31,6 +33,7 @@ data Options = Options { input :: Maybe String , inputFormat :: Format , inputExclusivity :: Exclusivity+ , inputNewickLabel :: Maybe String , output :: Maybe String } @@ -67,6 +70,16 @@ \ alphabetical)." ) <*> optional ( strOption+ ( long "newick-label"+ <> short 'n'+ <> metavar "(SEPARATOR, FIELD)"+ <> help "In order to parse the Newick format, we need the labels to\+ \ look at clumpiness. Thus, we split the original label by\+ \ a separator and look at a specific field (1 indexed) in\+ \ order to get the label."+ )+ )+ <*> optional ( strOption ( long "output" <> short 'o' <> metavar "FILE"@@ -74,39 +87,56 @@ ) ) --- | Get the generic AST from the file-decodeLineageTree :: C.ByteString -> Object-decodeLineageTree contents = fromMaybe- (error "JSON is not an object")- (decode contents :: Maybe Object)+-- | Get the tree from a Haskell format+haskellFormat :: Options -> IO (Tree NodeLabel)+haskellFormat opts = do+ contents <- case input opts of+ Nothing -> getContents+ (Just x) -> readFile x+ return . read $ contents --- | Get the lineage tree from a generic AST-getLineageTree :: Label -> Object -> Tree NodeLabel-getLineageTree label object = either error (lineageToTree label)- . flip AT.parseEither object $ \obj -> do- germTree <- obj .: T.pack "tree"- tree <- germTree .: T.pack "children"- return . rootCheck tree $ germTree- where- -- Get the first branch point (sometimes there are additional nodes- -- right after the root for lineages that bypass the no root rule).- rootCheck [tree] _ = tree- rootCheck _ tree = tree+-- | Get the tree from a JSON format+jsonFormat :: Options -> IO (Tree NodeLabel) +jsonFormat opts = do+ contents <- case input opts of+ Nothing -> C.getContents+ (Just x) -> C.readFile x+ return ((either error id . eitherDecode $ contents) :: Tree NodeLabel) -findClumpiness :: Options -> IO ()-findClumpiness opts = do+-- | Get the tree from a Newick format+newickFormat :: Options -> IO (Tree NodeLabel) +newickFormat opts = do contents <- case input opts of+ Nothing -> T.getContents+ (Just x) -> T.readFile x+ let (sep, field) = case inputNewickLabel opts of+ Nothing -> (Separator T.empty, Field 1)+ (Just x) -> newickSplitters+ (read x :: (String, Int))++ return+ . newickToTree sep field+ . head+ . either error id+ . Newick.newicksFromText+ $ contents++-- | Get the tree form a lineage fromat+lineageFormat :: Options -> T.Text -> IO (Tree NodeLabel) +lineageFormat opts x = do+ contents <- case input opts of Nothing -> C.getContents (Just x) -> C.readFile x+ return . getLineageTree x . decodeLineageTree $ contents - let inputTree = case inputFormat opts of- Haskell -> read . C.unpack $ contents- JSON -> either error id- $ eitherDecode contents :: Tree NodeLabel- Lineage x -> getLineageTree x- . decodeLineageTree- $ contents- inputSuperTree = convertToSuperTree+findClumpiness :: Options -> IO ()+findClumpiness opts = do+ inputTree <- case inputFormat opts of+ Haskell -> haskellFormat opts+ JSON -> jsonFormat opts+ Newick -> newickFormat opts+ Lineage x -> lineageFormat opts x+ let inputSuperTree = convertToSuperTree . filterExclusiveTree (inputExclusivity opts) . innerToLeaves $ inputTree
find-clumpiness.cabal view
@@ -1,13 +1,13 @@ name: find-clumpiness-version: 0.2.0.1+version: 0.2.1.2 synopsis: Find the clumpiness of labels in a tree-description: Please see README.md+description: Use a clumpiness measure to find the aggregation relationship between labels inside of a tree. homepage: http://github.com/GregorySchwartz/find-clumpiness#readme-license: GPL-2+license: GPL-3 license-file: LICENSE author: Gregory W. Schwartz-maintainer: gregory.schwartz@drexel.edu-copyright: Copyright 2015 Gregory W. Schwartz+maintainer: gsch@mail.med.upenn.edu+copyright: Copyright 2017 Gregory W. Schwartz category: Math build-type: Simple -- extra-source-files:@@ -16,6 +16,8 @@ library hs-source-dirs: src exposed-modules: Types+ , Utility+ , NewickConvert , LineageConvert , TreeTransform , Print@@ -25,15 +27,18 @@ , containers , unordered-containers , vector+ , bytestring , text , text-show , aeson+ , BiobaseNewick+ , listsafe default-language: Haskell2010 executable find-clumpiness hs-source-dirs: app main-is: Main.hs- ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2+ ghc-options: -threaded -rtsopts -O2 build-depends: base , find-clumpiness , clumpiness@@ -44,6 +49,7 @@ , text , bytestring , optparse-applicative+ , BiobaseNewick default-language: Haskell2010 source-repository head
src/LineageConvert.hs view
@@ -9,6 +9,8 @@ module LineageConvert ( lineageToTree+ , decodeLineageTree+ , getLineageTree ) where -- Standard@@ -20,6 +22,7 @@ -- Cabal import qualified Data.Vector as V+import qualified Data.ByteString.Lazy.Char8 as C import qualified Data.Text as T import Math.TreeFun.Types import Math.TreeFun.Tree@@ -70,3 +73,22 @@ . flip parseEither object $ \obj -> do children <- obj .: "children" return children++-- | Get the generic AST from the file+decodeLineageTree :: C.ByteString -> Object+decodeLineageTree contents = fromMaybe+ (error "JSON is not an object")+ (decode contents :: Maybe Object)++-- | Get the lineage tree from a generic AST+getLineageTree :: Label -> Object -> Tree NodeLabel+getLineageTree label object = either error (lineageToTree label)+ . flip parseEither object $ \obj -> do+ germTree <- obj .: "tree"+ tree <- germTree .: "children"+ return . rootCheck tree $ germTree+ where+ -- Get the first branch point (sometimes there are additional nodes+ -- right after the root for lineages that bypass the no root rule).+ rootCheck [tree] _ = tree+ rootCheck _ tree = tree
+ src/NewickConvert.hs view
@@ -0,0 +1,44 @@+{- NewickConvert+By Gregory W. Schwartz++Collects functions pertaining to converting the Newick format to the+workable tree+-}++{-# LANGUAGE OverloadedStrings #-}++module NewickConvert+ ( newickToTree+ ) where++-- Standard+import Data.Maybe+import Data.Tree+import qualified Data.Sequence as Seq++-- Cabal+import qualified Data.List.Safe as Safe+import qualified Data.Text as T+import Biobase.Newick++-- Local+import Types++-- | Convert a newick format into the workable tree format.+newickToTree :: Separator -> Field -> NewickTree -> Tree NodeLabel+newickToTree sep field = go . getNewickTree+ where+ go (Node { rootLabel = x, subForest = ls }) =+ Node { rootLabel = NodeLabel { nodeID = label x+ , nodeLabels = getLabels sep field+ . label+ $ x+ }+ , subForest = map go ls+ }++-- | Get the label by splitting the original label by a separator and+-- choosing the 1 indexed field.+getLabels :: Separator -> Field -> T.Text -> Labels+getLabels (Separator sep) (Field field) =+ Seq.singleton . fromMaybe "" . (Safe.!! (field - 1)) . T.splitOn sep
src/Types.hs view
@@ -21,9 +21,12 @@ , nodeLabels :: !Labels } deriving (Generic, Eq, Ord, Read, Show) -data Format = Haskell | JSON | Lineage T.Text deriving (Read)+data Format = Haskell | JSON | Newick | Lineage T.Text deriving (Read) data Exclusivity = Exclusive | AllExclusive | Majority deriving (Read)++newtype Separator = Separator T.Text deriving (Show)+newtype Field = Field Int deriving (Show) -- Simple type Label = T.Text
+ src/Utility.hs view
@@ -0,0 +1,24 @@+{- Utility+By Gregory W. Schwartz++Collects functions pertaining to general helpers for the program.+-}++{-# LANGUAGE BangPatterns #-}++module Utility+ ( newickSplitters+ ) where++-- Standard++-- Cabal+import qualified Data.Text as T++-- Local+import Types++-- | Get the separator and field info for getting labels from Newick trees+newickSplitters :: (String, Int) -> (Separator, Field)+newickSplitters (!x, !y) = (Separator . T.pack $ x, Field y)+