diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -25,6 +25,7 @@ import Types import Utility import NewickConvert +import RJSONConvert import LineageConvert import TreeTransform import Print @@ -34,6 +35,8 @@ , inputFormat :: Format , inputExclusivity :: Exclusivity , inputNewickLabel :: Maybe String + , excludeInnerFlag :: Bool + , predefinedIDs :: Bool , output :: Maybe String } @@ -44,20 +47,26 @@ ( long "input" <> short 'i' <> metavar "FILE" - <> help "The input file containing the tree with labels" + <> help "The input file containing the tree with labels (or just use stdin)" ) ) <*> option auto ( long "format" <> short 'f' - <> metavar "[Haskell] | JSON | Lineage LABEL" - <> value Haskell - <> help "Whether the input tree is in Haskell, JSON, or Lineage format\ - \, where the Lineage format needs an additional field to\ + <> metavar "[JSON] | RJSON | Haskell | Lineage LABEL" + <> value JSON + <> help "Whether the input tree is in JSON, RJSON, Haskell, or Lineage format.\ + \ The format for JSON is\ + \ [{ \"nodeID\": \"ID\", \"nodeLabels\" [ \"Label\" ] }, [RECURSION]].\ + \ The format for RJSON is from\ + \ \"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 Lineage format needs an additional field to\ \ specify what to use as the label\ - \ (for instance, Lineage tissues). The format for JSON is\ - \ [{ \"nodeID\": \"ID\", \"nodeLabels\" [ \"Label\" ] },\ - \ [RECURSION]]" + \ (for instance, Lineage tissues).\ + \ See README for more information about formats." ) <*> option auto ( long "exclusivity" @@ -79,11 +88,24 @@ \ order to get the label." ) ) + <*> switch + ( long "exclude-inner" + <> short 'E' + <> help "Do not include inner node labels in clumpiness calculation." + ) + <*> switch + ( long "predefined-ids" + <> short 'p' + <> help "Whether the node IDs are predefined. Otherwise,\ + \ we set the unique ID of the node as Text integers\ + \ starting at 0. Recommended to ignore this flag unless you\ + \ know what you are doing. Ignore this flag for RJSON." + ) <*> optional ( strOption ( long "output" <> short 'o' <> metavar "FILE" - <> help "The output file containing the heatmap of clumpiness" + <> help "The output file containing the heatmap of clumpiness (or just use stdout)" ) ) @@ -96,7 +118,7 @@ return . read $ contents -- | Get the tree from a JSON format -jsonFormat :: Options -> IO (Tree NodeLabel) +jsonFormat :: Options -> IO (Tree NodeLabel) jsonFormat opts = do contents <- case input opts of Nothing -> C.getContents @@ -104,7 +126,7 @@ return ((either error id . eitherDecode $ contents) :: Tree NodeLabel) -- | Get the tree from a Newick format -newickFormat :: Options -> IO (Tree NodeLabel) +newickFormat :: Options -> IO (Tree NodeLabel) newickFormat opts = do contents <- case input opts of Nothing -> T.getContents @@ -121,24 +143,40 @@ . Newick.newicksFromText $ contents --- | Get the tree form a lineage fromat -lineageFormat :: Options -> T.Text -> IO (Tree NodeLabel) -lineageFormat opts x = do +-- | Get the tree from a lineage fromat +lineageFormat :: Options -> T.Text -> IO (Tree NodeLabel) +lineageFormat opts l = do contents <- case input opts of Nothing -> C.getContents (Just x) -> C.readFile x - return . getLineageTree x . decodeLineageTree $ contents + return . getLineageTree l . decodeLineageTree $ contents +-- | Get the tree from an R JSON format +rJsonFormat :: Options -> IO (Tree NodeLabel) +rJsonFormat opts = do + contents <- case input opts of + Nothing -> C.getContents + (Just x) -> C.readFile x + return . getRJsonTree . decodeRJsonTree $ contents + 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) - . innerToLeaves + . (\ 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 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.1.3 +version: 0.2.2.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 @@ -18,21 +18,23 @@ exposed-modules: Types , Utility , NewickConvert + , RJSONConvert , LineageConvert , TreeTransform , Print build-depends: base >= 4.7 && < 5 , clumpiness - , tree-fun - , containers - , unordered-containers - , vector + , BiobaseNewick + , aeson , bytestring + , containers + , listsafe + , mtl , text , text-show - , aeson - , BiobaseNewick - , listsafe + , tree-fun + , unordered-containers + , vector default-language: Haskell2010 executable find-clumpiness @@ -41,15 +43,15 @@ ghc-options: -threaded -rtsopts -O2 build-depends: base , find-clumpiness - , clumpiness - , tree-fun - , containers - , unordered-containers + , BiobaseNewick , aeson - , text , bytestring + , clumpiness + , containers , optparse-applicative - , BiobaseNewick + , text + , tree-fun + , unordered-containers default-language: Haskell2010 source-repository head diff --git a/src/LineageConvert.hs b/src/LineageConvert.hs --- a/src/LineageConvert.hs +++ b/src/LineageConvert.hs @@ -18,7 +18,6 @@ import qualified Data.Sequence as Seq import Data.Tree import qualified Data.HashMap.Strict as Hash -import Debug.Trace -- Cabal import qualified Data.Vector as V @@ -77,7 +76,7 @@ -- | Get the generic AST from the file decodeLineageTree :: C.ByteString -> Object decodeLineageTree contents = fromMaybe - (error "JSON is not an object") + (error "Input is not a JSON object") (decode contents :: Maybe Object) -- | Get the lineage tree from a generic AST diff --git a/src/RJSONConvert.hs b/src/RJSONConvert.hs new file mode 100644 --- /dev/null +++ b/src/RJSONConvert.hs @@ -0,0 +1,82 @@ +{- RJSONConvert +By Gregory W. Schwartz + +Collects functions pertaining to converting the JSON output of R to the workable +tree. To create the input for this program from R: + +@ +library(data.tree) +library(jsonlite) +hc = hclust(dist(USArrests), "ave") +tree = as.Node(as.dendrogram(hc)) +toJSON(as.list(tree, mode = "explicit", unname = TRUE)) +@ + +-} + +{-# LANGUAGE OverloadedStrings #-} + +module RJSONConvert + ( rJsonToTree + , decodeRJsonTree + , getRJsonTree + ) where + +-- Standard +import Data.Maybe +import qualified Data.Sequence as Seq +import Data.Tree +import Debug.Trace + +-- Cabal +import qualified Data.Vector as V +import qualified Data.ByteString.Lazy.Char8 as C +import qualified Data.Text as T +import TextShow (showt) +import Math.TreeFun.Types +import Math.TreeFun.Tree +import Data.Aeson +import Data.Aeson.Types + +-- Local +import Types + +-- | Convert a R JSON format into the workable tree format +rJsonToTree :: Object -> Tree NodeLabel +rJsonToTree object = + Node { rootLabel = getNodeLabel object + , subForest = fmap rJsonToTree . getChildren $ object + } + +-- | Get the NodeLabel of a node +getNodeLabel :: Object -> NodeLabel +getNodeLabel object = do + NodeLabel { nodeID = "" + , nodeLabels = getLabel object + } + +-- | Get the label of the node +getLabel :: Object -> Labels +getLabel object = Seq.fromList + . V.toList + . either error id + . flip parseEither object $ \obj -> do + labels <- obj .: "name" + return labels + +-- | Get the children of a node +getChildren :: Object -> [Object] +getChildren object = either (const []) id + . flip parseEither object $ \obj -> do + children <- obj .: "children" + return children + +-- | Get the generic AST from the file +decodeRJsonTree :: C.ByteString -> Object +decodeRJsonTree contents = fromMaybe + (error "Input is not a JSON object") + (decode contents :: Maybe Object) + +-- | Get the lineage tree from a generic AST +getRJsonTree :: Object -> Tree NodeLabel +getRJsonTree object = rJsonToTree object diff --git a/src/TreeTransform.hs b/src/TreeTransform.hs --- a/src/TreeTransform.hs +++ b/src/TreeTransform.hs @@ -12,20 +12,23 @@ , getPropertyMap , innerToLeaves , filterExclusiveTree + , addUniqueNodeIDs ) where -- Standard +import Control.Monad.State +import Data.Function (on) +import Data.Tree +import qualified Data.Foldable as F import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set -import Data.Tree -import qualified Data.Foldable as F -import Data.Function (on) -- Cabal import qualified Data.Text as T import Math.TreeFun.Types import Math.TreeFun.Tree +import TextShow (showt) -- Local import Types @@ -88,3 +91,20 @@ . Map.fromListWith (+) . flip zip [1,1..] . F.toList $ xs + +-- | Add unique node IDs to a tree, replacing any previous node IDs. +addUniqueNodeIDs :: Tree NodeLabel -> Tree NodeLabel +addUniqueNodeIDs tree = fst . runState (go tree) $ 0 + where + go :: Tree NodeLabel -> State Int (Tree NodeLabel) + go tree = do + newRootLabel <- updateRootLabel . rootLabel $ tree + newSubForest <- mapM go . subForest $ tree + return $ tree { rootLabel = newRootLabel + , subForest = newSubForest + } + updateRootLabel :: NodeLabel -> State Int NodeLabel + updateRootLabel n = do + nId <- get + modify (+ 1) + return $ n { nodeID = showt nId } diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -21,7 +21,7 @@ , nodeLabels :: !Labels } deriving (Generic, Eq, Ord, Read, Show) -data Format = Haskell | JSON | Newick | Lineage T.Text deriving (Read) +data Format = JSON | RJSON | Haskell | Newick | Lineage T.Text deriving (Read) data Exclusivity = Exclusive | AllExclusive | Majority deriving (Read)