diff --git a/Biobase/Newick.hs b/Biobase/Newick.hs new file mode 100644 --- /dev/null +++ b/Biobase/Newick.hs @@ -0,0 +1,12 @@ + +module Biobase.Newick + ( module Biobase.Newick.Types + , module Biobase.Newick.Export + , module Biobase.Newick.Import + ) + where + +import Biobase.Newick.Export +import Biobase.Newick.Import +import Biobase.Newick.Types + diff --git a/Biobase/Newick/Export.hs b/Biobase/Newick/Export.hs new file mode 100644 --- /dev/null +++ b/Biobase/Newick/Export.hs @@ -0,0 +1,29 @@ + +module Biobase.Newick.Export where + +import Data.List (intersperse) +import Data.Monoid +import Data.Text.Lazy.Builder (Builder) +import Data.Text (Text) +import Data.Tree +import qualified Data.Text.Lazy as T (toStrict) +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy.Builder.RealFloat as B + +import Biobase.Newick.Types + + + +-- | Render a list of Newick trees to a newick string. + +newicksToText :: [NewickTree] -> Text +newicksToText = T.toStrict . B.toLazyText . toTextBuilder + +-- | Via builder + +toTextBuilder :: [NewickTree] -> Builder +toTextBuilder = mconcat . map ((<> ";\n") . go . getNewickTree) + where go (Node lbl []) = label lbl + go (Node lbl cs) = "(" <> mconcat (intersperse "," $ map go cs) <> ")" <> label lbl + label (Info lbl len) = B.fromText lbl <> (if len == 0 then mempty else ":" <> B.realFloat len) + diff --git a/Biobase/Newick/Import.hs b/Biobase/Newick/Import.hs new file mode 100644 --- /dev/null +++ b/Biobase/Newick/Import.hs @@ -0,0 +1,79 @@ + +-- | +-- +-- NOTE We need to make sure to be compatible to everything here: +-- @http://evolution.genetics.washington.edu/phylip/newicktree.html@ In +-- particular, we do not do any conversion from @_@ to @(space)@ right now. + +module Biobase.Newick.Import where + +import Control.Applicative +import Data.Attoparsec.Text (Parser,()) +import Data.Char (isAlpha) +import Data.Text (Text) +import Data.Tree +import qualified Data.Attoparsec.Text as A +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Biobase.Newick.Types + + + +type PNT = Parser (Tree Info) + +newicksFromFile :: FilePath -> IO (Either String [NewickTree]) +newicksFromFile f = newicksFromText <$> T.readFile f + +newicksFromText :: Text -> Either String [NewickTree] +newicksFromText = A.parseOnly manyNewick + +manyNewick = some (newick <* A.skipSpace) <* A.endOfInput + +newick :: Parser NewickTree +newick = NewickTree <$> tree <* ";" "newick" + +tree :: PNT +tree = A.skipSpace *> (branched <|> leaf) "tree" + +branched :: PNT +branched = flip Node <$ "(" <*> tree `A.sepBy1` "," <* ")" <*> info "branched" + +leaf :: PNT +leaf = (flip Node []) <$> info "leaf" + +info :: Parser Info +info = Info <$> name <*> plength "info" + +-- | +-- +-- NOTE http://evolution.genetics.washington.edu/phylip/newicktree.html +-- +-- A name can be any string of printable characters except blanks, colons, +-- semicolons, parentheses, and square brackets. +-- +-- I am excluding commas as well. + +name :: Parser Text +name = A.takeWhile accept "name" + where accept a = not $ A.isHorizontalSpace a || A.inClass ",:;()[]" a -- isAlpha a || A.inClass "_." a || A.isHorizontalSpace a + +plength :: Parser Double +plength = ":" *> A.double <|> pure 0 "plength" + + +{- +test = mapM_ (\x -> (either error (putStr . drawTree . fmap show . head . map getNewickTree) $ A.parseOnly manyNewick x) >> putStrLn "\n\n\n") + [ "B:0.2;" + , "A;" + , ";" + , "(,);" + , "((raccoon:19.19959,bear:6.80041):0.84600,((sea_lion:11.99700, seal:12.00300):7.52973,((monkey:100.85930,cat:47.14069):20.59201, weasel:18.87953):2.09460):3.87382,dog:25.46154);" + , "(Bovine:0.69395,(Gibbon:0.36079,(Orang:0.33636,(Gorilla:0.17147,(Chimp:0.19268, Human:0.11927):0.08386):0.06124):0.15057):0.54939,Mouse:1.21460):0.10;" + , "(Bovine:0.69395,(Hylobates:0.36079,(Pongo:0.33636,(G._Gorilla:0.17147, (P._paniscus:0.19268,H._sapiens:0.11927):0.08386):0.06124):0.15057):0.54939, Rodent:1.21460);" + , "A;" + , "((A,B),(C,D));" + , "(Alpha,Beta,Gamma,Delta,,Epsilon,,,);" + ] +-} + diff --git a/Biobase/Newick/StaticForest.hs b/Biobase/Newick/StaticForest.hs new file mode 100644 --- /dev/null +++ b/Biobase/Newick/StaticForest.hs @@ -0,0 +1,32 @@ + +module Biobase.Newick.StaticForest where + +import Data.Tree (drawForest,flatten) +import qualified Data.Tree as T +import qualified Data.Vector as V + +import Data.Forest.Static + +import Biobase.Newick.Types + +import Data.Graph.Inductive.Basic -- only for @test@ +import Biobase.Newick.Import + + + +test = do + let ts = map (addIndices 0 . getNewickTree) $ either error id $ newicksFromText t + let ss = either error id $ newicksFromText t + mapM_ (putStrLn . T.drawTree . fmap show) ts + putStrLn "" + mapM_ (mapM_ (putStrLn . show) . postorder) ts + putStrLn "" + mapM_ (mapM_ (putStrLn . show) . preorder) ts + putStrLn "" + mapM_ (mapM_ print . T.levels) ts + putStrLn "" + print (forestPre $ map getNewickTree ss :: Forest Pre V.Vector Info) + putStrLn "" + print (forestPost $ map getNewickTree ss :: Forest Post V.Vector Info) + where t = "((raccoon:19.19959,bear:6.80041):0.84600,((sea_lion:11.99700, seal:12.00300):7.52973,((monkey:100.85930,cat:47.14069):20.59201, weasel:18.87953):2.09460):3.87382,dog:25.46154)Root;" + diff --git a/Biobase/Newick/Types.hs b/Biobase/Newick/Types.hs new file mode 100644 --- /dev/null +++ b/Biobase/Newick/Types.hs @@ -0,0 +1,62 @@ + +module Biobase.Newick.Types where + +import Control.Applicative +import Control.Monad +import Data.Aeson (FromJSON,ToJSON) +import Data.Binary (Binary) +import Data.Monoid +import Data.Serialize (Serialize) +import Data.Serialize.Text +import Data.Text.Binary +import Data.Text (Text) +import Data.Tree +import GHC.Generics +import Test.QuickCheck + + + +-- | Node and leaf information in Newick trees. + +data Info = Info + { label :: Text + , distance :: Double + } deriving (Eq,Show,Generic) + +instance Binary Info +instance Serialize Info +instance FromJSON Info +instance ToJSON Info + +instance Arbitrary Info where + arbitrary = Info <$> pure "" <*> (maybe 0 getPositive <$> arbitrary) + shrink (Info lbl d) + | d == 0 = [] + | otherwise = [Info lbl 0] + + + +-- | Newick tree newtype wrapper. + +newtype NewickTree = NewickTree { getNewickTree :: Tree Info } + deriving (Eq,Show,Generic) + +instance Binary NewickTree +instance Serialize NewickTree +instance FromJSON NewickTree +instance ToJSON NewickTree + +instance Arbitrary NewickTree where + arbitrary = NewickTree <$> (arbNewickTree =<< (getSmall <$> arbitrary)) + shrink (NewickTree (Node lbl [])) = [NewickTree (Node l []) | l <- shrink lbl] + shrink (NewickTree (Node lbl cs)) = [NewickTree (Node l ds) | l <- shrink lbl + , ds <- map (map getNewickTree) . shrink $ map NewickTree cs] + +arbNewickTree :: Int -> Gen (Tree Info) +arbNewickTree k | k<=0 = Node <$> arbitrary <*> pure [] +arbNewickTree k = do + n <- choose (0,5) + ds <- replicateM n $ choose (0,k-1) + cs <- mapM arbNewickTree ds + Node <$> arbitrary <*> pure cs + diff --git a/BiobaseNewick.cabal b/BiobaseNewick.cabal new file mode 100644 --- /dev/null +++ b/BiobaseNewick.cabal @@ -0,0 +1,118 @@ +Name: BiobaseNewick +Version: 0.0.0.1 +License: BSD3 +License-file: LICENSE +Author: Christian Hoener zu Siederdissen +Maintainer: choener@bioinf.uni-leipzig.de +Copyright: Christian Hoener zu Siederdissen, 2015-2016 +Homepage: https://github.com/choener/BiobaseNewick +bug-reports: https://github.com/choener/BiobaseNewick/issues +Stability: Experimental +Category: Bioinformatics +Build-type: Simple +Cabal-version: >= 1.10 +tested-with: GHC == 7.10.3 +Synopsis: Newick file format parser. +Description: + This is a simple parser for Newick trees. The parser returns a + rose tree. Each node is labelled with the node name (or an + empty string for anonymous nodes) and a distance (0 if not + given). + . + Includes conversion to an efficient static forest. + +extra-source-files: + changelog.md + README.md + + + +library + exposed-modules: + Biobase.Newick + Biobase.Newick.Export + Biobase.Newick.Import + Biobase.Newick.StaticForest + Biobase.Newick.Types + + build-depends: base >= 4.7 && < 4.9 + , aeson >= 0.8 && < 0.11 + , attoparsec >= 0.12 && < 0.14 + , binary >= 0.7 && < 0.8 + , cereal >= 0.4 && < 0.6 + , cereal-text >= 0.1.0 && < 0.1.1 + , containers >= 0.5 && < 0.6 + , fgl >= 5.5 && < 6.0 + , ForestStructures >= 0.0.0 && < 0.0.1 + , QuickCheck >= 2.7 && < 2.9 + , text >= 1.2 && < 1.3 + , text-binary >= 0.1.0 && < 0.2.2 + , vector >= 0.10 && < 0.12 + ghc-options: + -O2 + -funbox-strict-fields + default-language: + Haskell2010 + default-extensions: DeriveGeneric + , DataKinds + , OverloadedStrings + + + +-- A small helper that turns a Newick tree in a diagram. + +--executable Newick-diagrams +-- build-depends: base +-- , BiobaseNewick +-- , cmdargs >= 0.10 && < 0.11 +-- , diagrams >= 1.3 && < 1.4 +-- , diagrams-postscript >= 1.3 && < 1.4 +-- , diagrams-rasterific >= 1.3 && < 1.4 +-- hs-source-dirs: +-- src +-- main-is: +-- diagram.hs +-- default-language: +-- Haskell2010 +-- default-extensions: BangPatterns +-- , FlexibleContexts +-- , FlexibleInstances +-- , MultiParamTypeClasses +-- , RecordWildCards +-- , TemplateHaskell +-- , TypeFamilies +-- , TypeOperators +-- ghc-options: +-- -O2 + + + +test-suite properties + type: + exitcode-stdio-1.0 + main-is: + properties.hs + ghc-options: + -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: + tests + default-language: + Haskell2010 + default-extensions: ScopedTypeVariables + , TemplateHaskell + build-depends: base + , aeson + , binary + , BiobaseNewick + , cereal + , QuickCheck + , test-framework >= 0.8 && < 0.9 + , test-framework-quickcheck2 >= 0.3 && < 0.4 + , test-framework-th >= 0.2 && < 0.3 + + + +source-repository head + type: git + location: git://github.com/choener/BiobaseNewick + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Christian Hoener zu Siederdissen 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Christian Hoener zu Siederdissen nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,24 @@ +[![Build Status](https://travis-ci.org/choener/BiobaseNewick.svg?branch=master)](https://travis-ci.org/choener/BiobaseNewick) + +# BiobaseNewick + +This is a simple parser for Newick trees. The parser returns a rose tree. Each +node is labelled with the node name (or an empty string for anonymous nodes) +and a distance (0 if not given). + +Newick trees can be ex- and imported into the Newick tree format. We also have +serialization to the usual serializers. + +This package was written mostly to complement a course a Univ. Leipzig. There +is a more comprehensive package written by R. Newton + which you might want instead. + + + +#### Contact + +Christian Hoener zu Siederdissen +Leipzig University, Leipzig, Germany +choener@bioinf.uni-leipzig.de +http://www.bioinf.uni-leipzig.de/~choener/ + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,7 @@ +0.0.0.1 +------- + +- initial creation +- travis-ci integration +- simple test framework +- depends on ForestStructures for conversion into efficient static forest diff --git a/tests/properties.hs b/tests/properties.hs new file mode 100644 --- /dev/null +++ b/tests/properties.hs @@ -0,0 +1,36 @@ + +module Main where + +import Debug.Trace +import qualified Data.Aeson as A +import qualified Data.Binary as B +import qualified Data.Serialize as S +import Test.Framework.Providers.QuickCheck2 +import Test.Framework.TH + +import Biobase.Newick +import qualified Biobase.Newick as N + + + +-- * Serialization to and from the canonical Newick format. + +prop_Newick (t :: NewickTree) = Right [t] == ss + where ss = newicksFromText tt + tt = newicksToText [t] + +-- * Serialization with default Haskell machinery + +-- | Correct @Binary@ serialization + +prop_Binary (t :: NewickTree) = t == B.decode (B.encode t) + +-- | Correct @Cerial@ serialization + +prop_Serialize (t :: NewickTree) = Right t == S.decode (S.encode t) + +prop_Aeson (t :: NewickTree) = Right t == A.eitherDecode (A.encode t) + +main :: IO () +main = $(defaultMainGenerator) +