{-# LANGUAGE OverloadedStrings #-}
module TLynx.Compare.Compare
( compareCmd,
)
where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader (ask)
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.List (intercalate)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.IO as T
import ELynx.Tools.ELynx
import ELynx.Tools.Environment
import ELynx.Tools.Logger
import ELynx.Tools.Options
import ELynx.Tree
import System.IO
import TLynx.Compare.Options
import TLynx.Parsers
import Text.Printf
treesOneFile ::
FilePath ->
ELynx
CompareArguments
(Tree Phylo Name, Tree Phylo Name)
treesOneFile :: [Char] -> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesOneFile [Char]
tf = do
NewickFormat
nwF <- CompareArguments -> NewickFormat
argsNewickFormat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Environment a -> a
localArguments forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ [Char]
"Parse file '" forall a. [a] -> [a] -> [a]
++ [Char]
tf forall a. [a] -> [a] -> [a]
++ [Char]
"'."
Forest Phylo Name
ts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ NewickFormat -> [Char] -> IO (Forest Phylo Name)
parseTrees NewickFormat
nwF [Char]
tf
let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest Phylo Name
ts
case forall a. Ord a => a -> a -> Ordering
compare Int
n Int
2 of
Ordering
LT -> forall a. HasCallStack => [Char] -> a
error [Char]
"Not enough trees in file."
Ordering
GT -> forall a. HasCallStack => [Char] -> a
error [Char]
"Too many trees in file."
Ordering
EQ ->
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> a
head Forest Phylo Name
ts, forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ Forest Phylo Name
ts)
treesTwoFiles ::
FilePath ->
FilePath ->
ELynx
CompareArguments
(Tree Phylo Name, Tree Phylo Name)
treesTwoFiles :: [Char]
-> [Char]
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesTwoFiles [Char]
tf1 [Char]
tf2 = do
NewickFormat
nwF <- CompareArguments -> NewickFormat
argsNewickFormat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Environment a -> a
localArguments forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ [Char]
"Parse first tree file '" forall a. [a] -> [a] -> [a]
++ [Char]
tf1 forall a. [a] -> [a] -> [a]
++ [Char]
"'."
Tree Phylo Name
t1 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ NewickFormat -> [Char] -> IO (Tree Phylo Name)
parseTree NewickFormat
nwF [Char]
tf1
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ [Char]
"Parse second tree file '" forall a. [a] -> [a] -> [a]
++ [Char]
tf2 forall a. [a] -> [a] -> [a]
++ [Char]
"'."
Tree Phylo Name
t2 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ NewickFormat -> [Char] -> IO (Tree Phylo Name)
parseTree NewickFormat
nwF [Char]
tf2
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name
t1, Tree Phylo Name
t2)
compareCmd :: ELynx CompareArguments ()
compareCmd :: Logger (Environment CompareArguments) ()
compareCmd = do
CompareArguments
l <- forall a. Environment a -> a
localArguments forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Handle
outH <- forall a. Reproducible a => [Char] -> [Char] -> ELynx a Handle
outHandle [Char]
"results" [Char]
".out"
let inFs :: [[Char]]
inFs = CompareArguments -> [[Char]]
argsInFiles CompareArguments
l
nFs :: Int
nFs = forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
inFs
(Tree Phylo Name
tr1, Tree Phylo Name
tr2) <- case Int
nFs of
Int
1 -> [Char] -> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesOneFile (forall a. [a] -> a
head [[Char]]
inFs)
Int
2 -> [Char]
-> [Char]
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesTwoFiles (forall a. [a] -> a
head [[Char]]
inFs) (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ [[Char]]
inFs)
Int
_ ->
forall a. HasCallStack => [Char] -> a
error
[Char]
"Need two input files with one tree each or one input file with two trees."
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Tree 1:"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick Tree Phylo Name
tr1
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Tree 2:"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick Tree Phylo Name
tr2
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
(Tree Phylo Name
t1, Tree Phylo Name
t2) <-
if CompareArguments -> Bool
argsIntersect CompareArguments
l
then do
case forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall e a.
(Semigroup e, Eq e, Ord a) =>
Forest e a -> Either [Char] (Forest e a)
intersect [Tree Phylo Name
tr1, Tree Phylo Name
tr2] of
[Tree Phylo Name
x, Tree Phylo Name
y] -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Intersected trees are:"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick Tree Phylo Name
x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick Tree Phylo Name
y
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name
x, Tree Phylo Name
y)
Forest Phylo Name
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"compareCmd: Could not intersect trees."
else forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name
tr1, Tree Phylo Name
tr2)
Handle
-> Tree Phylo Name
-> Tree Phylo Name
-> Logger (Environment CompareArguments) ()
analyzeDistance Handle
outH Tree Phylo Name
t1 Tree Phylo Name
t2
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CompareArguments -> Bool
argsBipartitions CompareArguments
l) forall a b. (a -> b) -> a -> b
$ Handle
-> Tree Phylo Name
-> Tree Phylo Name
-> Logger (Environment CompareArguments) ()
analyzeBipartitions Handle
outH Tree Phylo Name
t1 Tree Phylo Name
t2
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
outH
analyzeDistance ::
Handle ->
Tree Phylo Name ->
Tree Phylo Name ->
ELynx CompareArguments ()
analyzeDistance :: Handle
-> Tree Phylo Name
-> Tree Phylo Name
-> Logger (Environment CompareArguments) ()
analyzeDistance Handle
outH Tree Phylo Name
t1 Tree Phylo Name
t2 = do
let formatD :: Text -> Text -> Text
formatD Text
str Text
val = Int -> Char -> Text -> Text
T.justifyLeft Int
25 Char
' ' Text
str forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
val
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Distances."
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text
formatD
Text
"Symmetric"
([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
Ord a =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
symmetric Tree Phylo Name
t1 Tree Phylo Name
t2)
case (forall e a.
HasMaybeLength e =>
Tree e a -> Either [Char] (Tree Length a)
toLengthTree Tree Phylo Name
t1, forall e a.
HasMaybeLength e =>
Tree e a -> Either [Char] (Tree Length a)
toLengthTree Tree Phylo Name
t2) of
(Right Tree Length Name
t1', Right Tree Length Name
t2') -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text
formatD
Text
"Branch score"
([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall e1 e2 a.
(HasLength e1, HasLength e2, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Double
branchScore Tree Length Name
t1' Tree Length Name
t2')
(Either [Char] (Tree Length Name),
Either [Char] (Tree Length Name))
_ -> do
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Some branches do not have length values."
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Distances involving length cannot be calculated."
case (forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Either [Char] (Tree PhyloExplicit a)
toExplicitTree Tree Phylo Name
t1, forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Either [Char] (Tree PhyloExplicit a)
toExplicitTree Tree Phylo Name
t2) of
(Right Tree PhyloExplicit Name
t1', Right Tree PhyloExplicit Name
t2') -> do
let t1n :: Tree PhyloExplicit Name
t1n = forall e a. HasSupport e => Tree e a -> Tree e a
normalizeBranchSupport Tree PhyloExplicit Name
t1'
t2n :: Tree PhyloExplicit Name
t2n = forall e a. HasSupport e => Tree e a -> Tree e a
normalizeBranchSupport Tree PhyloExplicit Name
t2'
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logDebugS [Char]
"Trees with normalized branch support values:"
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Tree Phylo a
toPhyloTree Tree PhyloExplicit Name
t1n
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Tree Phylo a
toPhyloTree Tree PhyloExplicit Name
t2n
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text
formatD
Text
"Incompatible split"
([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
incompatibleSplits Tree PhyloExplicit Name
t1n Tree PhyloExplicit Name
t2n)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text
formatD
Text
"Incompatible split (0.10)"
([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
incompatibleSplits (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.1 Tree PhyloExplicit Name
t1n) (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.1 Tree PhyloExplicit Name
t2n))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text
formatD
Text
"Incompatible split (0.50)"
([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
incompatibleSplits (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.5 Tree PhyloExplicit Name
t1n) (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.5 Tree PhyloExplicit Name
t2n))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text
formatD
Text
"Incompatible split (0.80)"
([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
incompatibleSplits (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.8 Tree PhyloExplicit Name
t1n) (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.8 Tree PhyloExplicit Name
t2n))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text
formatD
Text
"Incompatible split (0.90)"
([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
incompatibleSplits (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.9 Tree PhyloExplicit Name
t1n) (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.9 Tree PhyloExplicit Name
t2n))
(Either [Char] (Tree PhyloExplicit Name),
Either [Char] (Tree PhyloExplicit Name))
_ -> do
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Some branches do not have support values."
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Distances involving branch support cannot be calculated."
analyzeBipartitions ::
Handle ->
Tree Phylo Name ->
Tree Phylo Name ->
ELynx CompareArguments ()
analyzeBipartitions :: Handle
-> Tree Phylo Name
-> Tree Phylo Name
-> Logger (Environment CompareArguments) ()
analyzeBipartitions Handle
outH Tree Phylo Name
t1 Tree Phylo Name
t2 =
case (forall e a.
HasMaybeLength e =>
Tree e a -> Either [Char] (Tree Length a)
toLengthTree Tree Phylo Name
t1, forall e a.
HasMaybeLength e =>
Tree e a -> Either [Char] (Tree Length a)
toLengthTree Tree Phylo Name
t2) of
(Right Tree Length Name
t1l, Right Tree Length Name
t2l) -> do
let bp1 :: Set (Bipartition Name)
bp1 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a e.
Ord a =>
Tree e a -> Either [Char] (Set (Bipartition a))
bipartitions Tree Length Name
t1l
bp2 :: Set (Bipartition Name)
bp2 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a e.
Ord a =>
Tree e a -> Either [Char] (Set (Bipartition a))
bipartitions Tree Length Name
t2l
bp1Only :: Set (Bipartition Name)
bp1Only = Set (Bipartition Name)
bp1 forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set (Bipartition Name)
bp2
bp2Only :: Set (Bipartition Name)
bp2Only = Set (Bipartition Name)
bp2 forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set (Bipartition Name)
bp1
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
(forall a. Set a -> Bool
S.null Set (Bipartition Name)
bp1Only)
( do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Bipartitions in Tree 1 that are not in Tree 2."
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set (Bipartition Name)
bp1Only (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> [Char] -> IO ()
hPutStrLn Handle
outH forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Bipartition a -> [Char]
bpHuman)
)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
(forall a. Set a -> Bool
S.null Set (Bipartition Name)
bp2Only)
( do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Bipartitions in Tree 2 that are not in Tree 1."
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set (Bipartition Name)
bp2Only (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> [Char] -> IO ()
hPutStrLn Handle
outH forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Bipartition a -> [Char]
bpHuman)
)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
let bpCommon :: Set (Bipartition Name)
bpCommon = Set (Bipartition Name)
bp1 forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set (Bipartition Name)
bp2
if forall a. Set a -> Bool
S.null Set (Bipartition Name)
bpCommon
then do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"There are no common bipartitions."
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"No plots have been generated."
else do
let bpToBrLen1 :: Map (Bipartition Name) Double
bpToBrLen1 = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Length -> Double
fromLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. HasLength e => e -> Length
getLength) forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall e a.
(Semigroup e, Ord a) =>
Tree e a -> Either [Char] (Map (Bipartition a) e)
bipartitionToBranch Tree Length Name
t1l
bpToBrLen2 :: Map (Bipartition Name) Double
bpToBrLen2 = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Length -> Double
fromLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. HasLength e => e -> Length
getLength) forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall e a.
(Semigroup e, Ord a) =>
Tree e a -> Either [Char] (Map (Bipartition a) e)
bipartitionToBranch Tree Length Name
t2l
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
Handle -> [Char] -> IO ()
hPutStrLn
Handle
outH
[Char]
"Common bipartitions and their respective differences in branch lengths."
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
header
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
Set (Bipartition Name)
bpCommon
( forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> [Char] -> IO ()
hPutStrLn Handle
outH
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b.
(Ord a, Show a, Fractional b, PrintfArg b) =>
Map (Bipartition a) b
-> Map (Bipartition a) b -> Bipartition a -> [Char]
getCommonBpStr Map (Bipartition Name) Double
bpToBrLen1 Map (Bipartition Name) Double
bpToBrLen2
)
Maybe [Char]
bn <- GlobalArguments -> Maybe [Char]
outFileBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Environment a -> GlobalArguments
globalArguments forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
case Maybe [Char]
bn of
Maybe [Char]
Nothing ->
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"No output file name provided. Do not generate plots."
Just [Char]
_ -> do
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"No plot generated (no Gnuplot with GHC 9.2.1)"
(Either [Char] (Tree Length Name),
Either [Char] (Tree Length Name))
_ -> forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logWarnS [Char]
"Not all branches have a length! Can not analyze bipartitions."
header :: String
= forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" " forall a b. (a -> b) -> a -> b
$ [[Char]]
cols forall a. [a] -> [a] -> [a]
++ [[Char]
"Bipartition"]
where
cols :: [[Char]]
cols =
forall a b. (a -> b) -> [a] -> [b]
map
(Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> Text -> Text
T.justifyRight Int
12 Char
' ')
[Text
"Length 1", Text
"Length 2", Text
"Delta", Text
"Relative [%]"]
getCommonBpStr ::
(Ord a, Show a, Fractional b, PrintfArg b) =>
M.Map (Bipartition a) b ->
M.Map (Bipartition a) b ->
Bipartition a ->
String
getCommonBpStr :: forall a b.
(Ord a, Show a, Fractional b, PrintfArg b) =>
Map (Bipartition a) b
-> Map (Bipartition a) b -> Bipartition a -> [Char]
getCommonBpStr Map (Bipartition a) b
m1 Map (Bipartition a) b
m2 Bipartition a
p =
forall a. [a] -> [[a]] -> [a]
intercalate
[Char]
" "
[ forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
l1,
forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
l2,
forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
d,
forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
rd,
[Char]
s
]
where
l1 :: b
l1 = Map (Bipartition a) b
m1 forall k a. Ord k => Map k a -> k -> a
M.! Bipartition a
p
l2 :: b
l2 = Map (Bipartition a) b
m2 forall k a. Ord k => Map k a -> k -> a
M.! Bipartition a
p
d :: b
d = b
l1 forall a. Num a => a -> a -> a
- b
l2
rd :: b
rd = b
2 forall a. Num a => a -> a -> a
* b
d forall a. Fractional a => a -> a -> a
/ (b
l1 forall a. Num a => a -> a -> a
+ b
l2)
s :: [Char]
s = forall a. Show a => Bipartition a -> [Char]
bpHuman Bipartition a
p