{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :  TLynx.Compare.Compare
-- Description :  Compare two phylogenies
-- Copyright   :  (c) Dominik Schrempf 2021
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Thu Sep 19 15:01:52 2019.
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
import ELynx.Tree
import Graphics.Gnuplot.Simple
import System.IO
import TLynx.Compare.Options
import TLynx.Parsers
import Text.Printf

treesOneFile ::
  FilePath ->
  ELynx
    CompareArguments
    (Tree Phylo Name, Tree Phylo Name)
treesOneFile :: FilePath
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesOneFile FilePath
tf = do
  NewickFormat
nwF <- CompareArguments -> NewickFormat
argsNewickFormat (CompareArguments -> NewickFormat)
-> (Environment CompareArguments -> CompareArguments)
-> Environment CompareArguments
-> NewickFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment CompareArguments -> CompareArguments
forall a. Environment a -> a
localArguments (Environment CompareArguments -> NewickFormat)
-> ReaderT
     (Environment CompareArguments) IO (Environment CompareArguments)
-> ReaderT (Environment CompareArguments) IO NewickFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Environment CompareArguments) IO (Environment CompareArguments)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logInfoS (FilePath -> Logger (Environment CompareArguments) ())
-> FilePath -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Parse file '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tf FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'."
  Forest Phylo Name
ts <- IO (Forest Phylo Name)
-> ReaderT (Environment CompareArguments) IO (Forest Phylo Name)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Forest Phylo Name)
 -> ReaderT (Environment CompareArguments) IO (Forest Phylo Name))
-> IO (Forest Phylo Name)
-> ReaderT (Environment CompareArguments) IO (Forest Phylo Name)
forall a b. (a -> b) -> a -> b
$ NewickFormat -> FilePath -> IO (Forest Phylo Name)
parseTrees NewickFormat
nwF FilePath
tf
  let n :: Int
n = Forest Phylo Name -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest Phylo Name
ts
  case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
n Int
2 of
    Ordering
LT -> FilePath
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall a. HasCallStack => FilePath -> a
error FilePath
"Not enough trees in file."
    Ordering
GT -> FilePath
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall a. HasCallStack => FilePath -> a
error FilePath
"Too many trees in file."
    Ordering
EQ ->
      (Tree Phylo Name, Tree Phylo Name)
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Forest Phylo Name -> Tree Phylo Name
forall a. [a] -> a
head Forest Phylo Name
ts, Forest Phylo Name -> Tree Phylo Name
forall a. [a] -> a
head (Forest Phylo Name -> Tree Phylo Name)
-> (Forest Phylo Name -> Forest Phylo Name)
-> Forest Phylo Name
-> Tree Phylo Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forest Phylo Name -> Forest Phylo Name
forall a. [a] -> [a]
tail (Forest Phylo Name -> Tree Phylo Name)
-> Forest Phylo Name -> Tree Phylo Name
forall a b. (a -> b) -> a -> b
$ Forest Phylo Name
ts)

treesTwoFiles ::
  FilePath ->
  FilePath ->
  ELynx
    CompareArguments
    (Tree Phylo Name, Tree Phylo Name)
treesTwoFiles :: FilePath
-> FilePath
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesTwoFiles FilePath
tf1 FilePath
tf2 = do
  NewickFormat
nwF <- CompareArguments -> NewickFormat
argsNewickFormat (CompareArguments -> NewickFormat)
-> (Environment CompareArguments -> CompareArguments)
-> Environment CompareArguments
-> NewickFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment CompareArguments -> CompareArguments
forall a. Environment a -> a
localArguments (Environment CompareArguments -> NewickFormat)
-> ReaderT
     (Environment CompareArguments) IO (Environment CompareArguments)
-> ReaderT (Environment CompareArguments) IO NewickFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Environment CompareArguments) IO (Environment CompareArguments)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logInfoS (FilePath -> Logger (Environment CompareArguments) ())
-> FilePath -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Parse first tree file '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tf1 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'."
  Tree Phylo Name
t1 <- IO (Tree Phylo Name)
-> ReaderT (Environment CompareArguments) IO (Tree Phylo Name)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree Phylo Name)
 -> ReaderT (Environment CompareArguments) IO (Tree Phylo Name))
-> IO (Tree Phylo Name)
-> ReaderT (Environment CompareArguments) IO (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ NewickFormat -> FilePath -> IO (Tree Phylo Name)
parseTree NewickFormat
nwF FilePath
tf1
  FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logInfoS (FilePath -> Logger (Environment CompareArguments) ())
-> FilePath -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Parse second tree file '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tf2 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'."
  Tree Phylo Name
t2 <- IO (Tree Phylo Name)
-> ReaderT (Environment CompareArguments) IO (Tree Phylo Name)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree Phylo Name)
 -> ReaderT (Environment CompareArguments) IO (Tree Phylo Name))
-> IO (Tree Phylo Name)
-> ReaderT (Environment CompareArguments) IO (Tree Phylo Name)
forall a b. (a -> b) -> a -> b
$ NewickFormat -> FilePath -> IO (Tree Phylo Name)
parseTree NewickFormat
nwF FilePath
tf2
  (Tree Phylo Name, Tree Phylo Name)
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name
t1, Tree Phylo Name
t2)

-- | More detailed comparison of two trees.
compareCmd :: ELynx CompareArguments ()
compareCmd :: Logger (Environment CompareArguments) ()
compareCmd = do
  CompareArguments
l <- Environment CompareArguments -> CompareArguments
forall a. Environment a -> a
localArguments (Environment CompareArguments -> CompareArguments)
-> ReaderT
     (Environment CompareArguments) IO (Environment CompareArguments)
-> ReaderT (Environment CompareArguments) IO CompareArguments
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Environment CompareArguments) IO (Environment CompareArguments)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  -- Determine output handle (stdout or file).
  Handle
outH <- FilePath -> FilePath -> ELynx CompareArguments Handle
forall a. Reproducible a => FilePath -> FilePath -> ELynx a Handle
outHandle FilePath
"results" FilePath
".out"
  -- Read input.
  let inFs :: [FilePath]
inFs = CompareArguments -> [FilePath]
argsInFiles CompareArguments
l
      nFs :: Int
nFs = [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
inFs
  (Tree Phylo Name
tr1, Tree Phylo Name
tr2) <- case Int
nFs of
    Int
1 -> FilePath
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesOneFile ([FilePath] -> FilePath
forall a. [a] -> a
head [FilePath]
inFs)
    Int
2 -> FilePath
-> FilePath
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesTwoFiles ([FilePath] -> FilePath
forall a. [a] -> a
head [FilePath]
inFs) ([FilePath] -> FilePath
forall a. [a] -> a
head ([FilePath] -> FilePath)
-> ([FilePath] -> [FilePath]) -> [FilePath] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. [a] -> [a]
tail ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath]
inFs)
    Int
_ ->
      FilePath
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall a. HasCallStack => FilePath -> a
error
        FilePath
"Need two input files with one tree each or one input file with two trees."
  IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
"Tree 1:"
  IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
outH (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> ByteString
forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick Tree Phylo Name
tr1
  IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
"Tree 2:"
  IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
outH (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> ByteString
forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick Tree Phylo Name
tr2
  IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
""
  -- Intersect trees.
  (Tree Phylo Name
t1, Tree Phylo Name
t2) <-
    if CompareArguments -> Bool
argsIntersect CompareArguments
l
      then do
        let [Tree Phylo Name
x, Tree Phylo Name
y] = (FilePath -> Forest Phylo Name)
-> (Forest Phylo Name -> Forest Phylo Name)
-> Either FilePath (Forest Phylo Name)
-> Forest Phylo Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Forest Phylo Name
forall a. HasCallStack => FilePath -> a
error Forest Phylo Name -> Forest Phylo Name
forall a. a -> a
id (Either FilePath (Forest Phylo Name) -> Forest Phylo Name)
-> Either FilePath (Forest Phylo Name) -> Forest Phylo Name
forall a b. (a -> b) -> a -> b
$ Forest Phylo Name -> Either FilePath (Forest Phylo Name)
forall e a.
(Semigroup e, Eq e, Ord a) =>
Forest e a -> Either FilePath (Forest e a)
intersect [Tree Phylo Name
tr1, Tree Phylo Name
tr2]
        IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
"Intersected trees are:"
        IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
outH (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> ByteString
forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick Tree Phylo Name
x
        IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
outH (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> ByteString
forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick Tree Phylo Name
y
        (Tree Phylo Name, Tree Phylo Name)
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name
x, Tree Phylo Name
y)
      else (Tree Phylo Name, Tree Phylo Name)
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name
tr1, Tree Phylo Name
tr2)

  -- Distances.
  Handle
-> Tree Phylo Name
-> Tree Phylo Name
-> Logger (Environment CompareArguments) ()
analyzeDistance Handle
outH Tree Phylo Name
t1 Tree Phylo Name
t2

  -- Bipartitions.
  Bool
-> Logger (Environment CompareArguments) ()
-> Logger (Environment CompareArguments) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CompareArguments -> Bool
argsBipartitions CompareArguments
l) (Logger (Environment CompareArguments) ()
 -> Logger (Environment CompareArguments) ())
-> Logger (Environment CompareArguments) ()
-> Logger (Environment CompareArguments) ()
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
  IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
val
  IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
"Distances."
  IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$
    Handle -> Text -> IO ()
T.hPutStrLn Handle
outH (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
      Text -> Text -> Text
formatD
        Text
"Symmetric"
        (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Either FilePath Int -> FilePath
forall a. Show a => a -> FilePath
show (Either FilePath Int -> FilePath)
-> Either FilePath Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> Tree Phylo Name -> Either FilePath Int
forall a e1 e2.
Ord a =>
Tree e1 a -> Tree e2 a -> Either FilePath Int
symmetric Tree Phylo Name
t1 Tree Phylo Name
t2)
  case (Tree Phylo Name -> Either FilePath (Tree Length Name)
forall e a.
HasMaybeLength e =>
Tree e a -> Either FilePath (Tree Length a)
toLengthTree Tree Phylo Name
t1, Tree Phylo Name -> Either FilePath (Tree Length Name)
forall e a.
HasMaybeLength e =>
Tree e a -> Either FilePath (Tree Length a)
toLengthTree Tree Phylo Name
t2) of
    (Right Tree Length Name
t1', Right Tree Length Name
t2') -> do
      IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Branch score"
            (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Either FilePath Double -> FilePath
forall a. Show a => a -> FilePath
show (Either FilePath Double -> FilePath)
-> Either FilePath Double -> FilePath
forall a b. (a -> b) -> a -> b
$ Tree Length Name -> Tree Length Name -> Either FilePath Double
forall e1 e2 a.
(HasLength e1, HasLength e2, Ord a) =>
Tree e1 a -> Tree e2 a -> Either FilePath Double
branchScore Tree Length Name
t1' Tree Length Name
t2')
    (Either FilePath (Tree Length Name),
 Either FilePath (Tree Length Name))
_ -> do
      FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logInfoS FilePath
"Some branches do not have length values."
      FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logInfoS FilePath
"Distances involving length cannot be calculated."
  case (Tree Phylo Name -> Either FilePath (Tree PhyloExplicit Name)
forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Either FilePath (Tree PhyloExplicit a)
toExplicitTree Tree Phylo Name
t1, Tree Phylo Name -> Either FilePath (Tree PhyloExplicit Name)
forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Either FilePath (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 = Tree PhyloExplicit Name -> Tree PhyloExplicit Name
forall e a. HasSupport e => Tree e a -> Tree e a
normalizeBranchSupport Tree PhyloExplicit Name
t1'
          t2n :: Tree PhyloExplicit Name
t2n = Tree PhyloExplicit Name -> Tree PhyloExplicit Name
forall e a. HasSupport e => Tree e a -> Tree e a
normalizeBranchSupport Tree PhyloExplicit Name
t2'
      FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logDebugS FilePath
"Trees with normalized branch support values:"
      ByteString -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB (ByteString -> Logger (Environment CompareArguments) ())
-> ByteString -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> ByteString
forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick (Tree Phylo Name -> ByteString) -> Tree Phylo Name -> ByteString
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name -> Tree Phylo Name
forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Tree Phylo a
toPhyloTree Tree PhyloExplicit Name
t1n
      ByteString -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB (ByteString -> Logger (Environment CompareArguments) ())
-> ByteString -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> ByteString
forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick (Tree Phylo Name -> ByteString) -> Tree Phylo Name -> ByteString
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name -> Tree Phylo Name
forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Tree Phylo a
toPhyloTree Tree PhyloExplicit Name
t2n
      IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Incompatible split"
            (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Either FilePath Int -> FilePath
forall a. Show a => a -> FilePath
show (Either FilePath Int -> FilePath)
-> Either FilePath Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name
-> Tree PhyloExplicit Name -> Either FilePath Int
forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either FilePath Int
incompatibleSplits Tree PhyloExplicit Name
t1n Tree PhyloExplicit Name
t2n)
      IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Incompatible split (0.10)"
            (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Either FilePath Int -> FilePath
forall a. Show a => a -> FilePath
show (Either FilePath Int -> FilePath)
-> Either FilePath Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name
-> Tree PhyloExplicit Name -> Either FilePath Int
forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either FilePath Int
incompatibleSplits (Support -> Tree PhyloExplicit Name -> Tree PhyloExplicit Name
forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.1 Tree PhyloExplicit Name
t1n) (Support -> Tree PhyloExplicit Name -> Tree PhyloExplicit Name
forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.1 Tree PhyloExplicit Name
t2n))
      IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Incompatible split (0.50)"
            (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Either FilePath Int -> FilePath
forall a. Show a => a -> FilePath
show (Either FilePath Int -> FilePath)
-> Either FilePath Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name
-> Tree PhyloExplicit Name -> Either FilePath Int
forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either FilePath Int
incompatibleSplits (Support -> Tree PhyloExplicit Name -> Tree PhyloExplicit Name
forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.5 Tree PhyloExplicit Name
t1n) (Support -> Tree PhyloExplicit Name -> Tree PhyloExplicit Name
forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.5 Tree PhyloExplicit Name
t2n))
      -- liftIO $ T.hPutStrLn outH $ formatD "Incompatible split (0.60)"
      --   (T.pack $ show $ incompatibleSplits (collapse 0.6 t1n) (collapse 0.6 t2n))
      -- liftIO $ T.hPutStrLn outH $ formatD "Incompatible split (0.70)"
      --   (T.pack $ show $ incompatibleSplits (collapse 0.7 t1n) (collapse 0.7 t2n))
      IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Incompatible split (0.80)"
            (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Either FilePath Int -> FilePath
forall a. Show a => a -> FilePath
show (Either FilePath Int -> FilePath)
-> Either FilePath Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name
-> Tree PhyloExplicit Name -> Either FilePath Int
forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either FilePath Int
incompatibleSplits (Support -> Tree PhyloExplicit Name -> Tree PhyloExplicit Name
forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.8 Tree PhyloExplicit Name
t1n) (Support -> Tree PhyloExplicit Name -> Tree PhyloExplicit Name
forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.8 Tree PhyloExplicit Name
t2n))
      IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Incompatible split (0.90)"
            (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Either FilePath Int -> FilePath
forall a. Show a => a -> FilePath
show (Either FilePath Int -> FilePath)
-> Either FilePath Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name
-> Tree PhyloExplicit Name -> Either FilePath Int
forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either FilePath Int
incompatibleSplits (Support -> Tree PhyloExplicit Name -> Tree PhyloExplicit Name
forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.9 Tree PhyloExplicit Name
t1n) (Support -> Tree PhyloExplicit Name -> Tree PhyloExplicit Name
forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.9 Tree PhyloExplicit Name
t2n))
    -- liftIO $ T.hPutStrLn outH $ formatD "Incompatible split (1.01)"
    --   (T.pack $ show $ incompatibleSplits (collapse 1.01 t1n) (collapse 1.01 t2n))
    -- liftIO $ BL.hPutStrLn outH $ toNewick (collapse 1.01 t1n)
    (Either FilePath (Tree PhyloExplicit Name),
 Either FilePath (Tree PhyloExplicit Name))
_ -> do
      FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logInfoS FilePath
"Some branches do not have support values."
      FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logInfoS FilePath
"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 (Tree Phylo Name -> Either FilePath (Tree Length Name)
forall e a.
HasMaybeLength e =>
Tree e a -> Either FilePath (Tree Length a)
toLengthTree Tree Phylo Name
t1, Tree Phylo Name -> Either FilePath (Tree Length Name)
forall e a.
HasMaybeLength e =>
Tree e a -> Either FilePath (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 = (FilePath -> Set (Bipartition Name))
-> (Set (Bipartition Name) -> Set (Bipartition Name))
-> Either FilePath (Set (Bipartition Name))
-> Set (Bipartition Name)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Set (Bipartition Name)
forall a. HasCallStack => FilePath -> a
error Set (Bipartition Name) -> Set (Bipartition Name)
forall a. a -> a
id (Either FilePath (Set (Bipartition Name))
 -> Set (Bipartition Name))
-> Either FilePath (Set (Bipartition Name))
-> Set (Bipartition Name)
forall a b. (a -> b) -> a -> b
$ Tree Length Name -> Either FilePath (Set (Bipartition Name))
forall a e.
Ord a =>
Tree e a -> Either FilePath (Set (Bipartition a))
bipartitions Tree Length Name
t1l
          bp2 :: Set (Bipartition Name)
bp2 = (FilePath -> Set (Bipartition Name))
-> (Set (Bipartition Name) -> Set (Bipartition Name))
-> Either FilePath (Set (Bipartition Name))
-> Set (Bipartition Name)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Set (Bipartition Name)
forall a. HasCallStack => FilePath -> a
error Set (Bipartition Name) -> Set (Bipartition Name)
forall a. a -> a
id (Either FilePath (Set (Bipartition Name))
 -> Set (Bipartition Name))
-> Either FilePath (Set (Bipartition Name))
-> Set (Bipartition Name)
forall a b. (a -> b) -> a -> b
$ Tree Length Name -> Either FilePath (Set (Bipartition Name))
forall a e.
Ord a =>
Tree e a -> Either FilePath (Set (Bipartition a))
bipartitions Tree Length Name
t2l
          bp1Only :: Set (Bipartition Name)
bp1Only = Set (Bipartition Name)
bp1 Set (Bipartition Name)
-> Set (Bipartition Name) -> Set (Bipartition Name)
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set (Bipartition Name)
bp2
          bp2Only :: Set (Bipartition Name)
bp2Only = Set (Bipartition Name)
bp2 Set (Bipartition Name)
-> Set (Bipartition Name) -> Set (Bipartition Name)
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set (Bipartition Name)
bp1
      Bool
-> Logger (Environment CompareArguments) ()
-> Logger (Environment CompareArguments) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (Set (Bipartition Name) -> Bool
forall a. Set a -> Bool
S.null Set (Bipartition Name)
bp1Only)
        ( do
            IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
""
            IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$
              Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
"Bipartitions in Tree 1 that are not in Tree 2."
            -- let bp1Strs = map (bphuman BL.unpack . bpmap getName) (S.toList bp1Only)
            Set (Bipartition Name)
-> (Bipartition Name -> Logger (Environment CompareArguments) ())
-> Logger (Environment CompareArguments) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set (Bipartition Name)
bp1Only (IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> (Bipartition Name -> IO ())
-> Bipartition Name
-> Logger (Environment CompareArguments) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> FilePath -> IO ()
hPutStrLn Handle
outH (FilePath -> IO ())
-> (Bipartition Name -> FilePath) -> Bipartition Name -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bipartition Name -> FilePath
forall a. Show a => Bipartition a -> FilePath
bpHuman)
        )
      -- let bp1Strs = map (bphuman BL.unpack) (S.toList bp1Only)
      -- liftIO $ hPutStrLn outH $ intercalate "\n" bp1Strs)
      Bool
-> Logger (Environment CompareArguments) ()
-> Logger (Environment CompareArguments) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (Set (Bipartition Name) -> Bool
forall a. Set a -> Bool
S.null Set (Bipartition Name)
bp2Only)
        ( do
            IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
""
            IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$
              Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
"Bipartitions in Tree 2 that are not in Tree 1."
            Set (Bipartition Name)
-> (Bipartition Name -> Logger (Environment CompareArguments) ())
-> Logger (Environment CompareArguments) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set (Bipartition Name)
bp2Only (IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> (Bipartition Name -> IO ())
-> Bipartition Name
-> Logger (Environment CompareArguments) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> FilePath -> IO ()
hPutStrLn Handle
outH (FilePath -> IO ())
-> (Bipartition Name -> FilePath) -> Bipartition Name -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bipartition Name -> FilePath
forall a. Show a => Bipartition a -> FilePath
bpHuman)
        )
      -- Common bipartitions and their respective differences in branch lengths.
      IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
""
      let bpCommon :: Set (Bipartition Name)
bpCommon = Set (Bipartition Name)
bp1 Set (Bipartition Name)
-> Set (Bipartition Name) -> Set (Bipartition Name)
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set (Bipartition Name)
bp2
      if Set (Bipartition Name) -> Bool
forall a. Set a -> Bool
S.null Set (Bipartition Name)
bpCommon
        then do
          IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
"There are no common bipartitions."
          IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
"No plots have been generated."
        else do
          let bpToBrLen1 :: Map (Bipartition Name) Double
bpToBrLen1 = (Length -> Double)
-> Map (Bipartition Name) Length -> Map (Bipartition Name) Double
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Length -> Double
fromLength (Length -> Double) -> (Length -> Length) -> Length -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Length -> Length
forall e. HasLength e => e -> Length
getLength) (Map (Bipartition Name) Length -> Map (Bipartition Name) Double)
-> Map (Bipartition Name) Length -> Map (Bipartition Name) Double
forall a b. (a -> b) -> a -> b
$ (FilePath -> Map (Bipartition Name) Length)
-> (Map (Bipartition Name) Length -> Map (Bipartition Name) Length)
-> Either FilePath (Map (Bipartition Name) Length)
-> Map (Bipartition Name) Length
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Map (Bipartition Name) Length
forall a. HasCallStack => FilePath -> a
error Map (Bipartition Name) Length -> Map (Bipartition Name) Length
forall a. a -> a
id (Either FilePath (Map (Bipartition Name) Length)
 -> Map (Bipartition Name) Length)
-> Either FilePath (Map (Bipartition Name) Length)
-> Map (Bipartition Name) Length
forall a b. (a -> b) -> a -> b
$ Tree Length Name -> Either FilePath (Map (Bipartition Name) Length)
forall e a.
(Semigroup e, Ord a) =>
Tree e a -> Either FilePath (Map (Bipartition a) e)
bipartitionToBranch Tree Length Name
t1l
              bpToBrLen2 :: Map (Bipartition Name) Double
bpToBrLen2 = (Length -> Double)
-> Map (Bipartition Name) Length -> Map (Bipartition Name) Double
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Length -> Double
fromLength (Length -> Double) -> (Length -> Length) -> Length -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Length -> Length
forall e. HasLength e => e -> Length
getLength) (Map (Bipartition Name) Length -> Map (Bipartition Name) Double)
-> Map (Bipartition Name) Length -> Map (Bipartition Name) Double
forall a b. (a -> b) -> a -> b
$ (FilePath -> Map (Bipartition Name) Length)
-> (Map (Bipartition Name) Length -> Map (Bipartition Name) Length)
-> Either FilePath (Map (Bipartition Name) Length)
-> Map (Bipartition Name) Length
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Map (Bipartition Name) Length
forall a. HasCallStack => FilePath -> a
error Map (Bipartition Name) Length -> Map (Bipartition Name) Length
forall a. a -> a
id (Either FilePath (Map (Bipartition Name) Length)
 -> Map (Bipartition Name) Length)
-> Either FilePath (Map (Bipartition Name) Length)
-> Map (Bipartition Name) Length
forall a b. (a -> b) -> a -> b
$ Tree Length Name -> Either FilePath (Map (Bipartition Name) Length)
forall e a.
(Semigroup e, Ord a) =>
Tree e a -> Either FilePath (Map (Bipartition a) e)
bipartitionToBranch Tree Length Name
t2l
          IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$
            Handle -> FilePath -> IO ()
hPutStrLn
              Handle
outH
              FilePath
"Common bipartitions and their respective differences in branch lengths."
          -- Header.
          IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
outH FilePath
header
          Set (Bipartition Name)
-> (Bipartition Name -> Logger (Environment CompareArguments) ())
-> Logger (Environment CompareArguments) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
            Set (Bipartition Name)
bpCommon
            ( IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                (IO () -> Logger (Environment CompareArguments) ())
-> (Bipartition Name -> IO ())
-> Bipartition Name
-> Logger (Environment CompareArguments) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> FilePath -> IO ()
hPutStrLn Handle
outH
                (FilePath -> IO ())
-> (Bipartition Name -> FilePath) -> Bipartition Name -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Bipartition Name) Double
-> Map (Bipartition Name) Double -> Bipartition Name -> FilePath
forall a b.
(Ord a, Show a, Fractional b, PrintfArg b) =>
Map (Bipartition a) b
-> Map (Bipartition a) b -> Bipartition a -> FilePath
getCommonBpStr Map (Bipartition Name) Double
bpToBrLen1 Map (Bipartition Name) Double
bpToBrLen2
            )
          -- XXX: This circumvents the extension checking, and hash creation for
          -- elynx files.
          Maybe FilePath
bn <- GlobalArguments -> Maybe FilePath
outFileBaseName (GlobalArguments -> Maybe FilePath)
-> (Environment CompareArguments -> GlobalArguments)
-> Environment CompareArguments
-> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment CompareArguments -> GlobalArguments
forall a. Environment a -> GlobalArguments
globalArguments (Environment CompareArguments -> Maybe FilePath)
-> ReaderT
     (Environment CompareArguments) IO (Environment CompareArguments)
-> ReaderT (Environment CompareArguments) IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Environment CompareArguments) IO (Environment CompareArguments)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
          case Maybe FilePath
bn of
            Maybe FilePath
Nothing ->
              FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logInfoS FilePath
"No output file name provided. Do not generate plots."
            Just FilePath
fn -> do
              let compareCommonBps :: [(Double, Double)]
compareCommonBps =
                    [ (Map (Bipartition Name) Double
bpToBrLen1 Map (Bipartition Name) Double -> Bipartition Name -> Double
forall k a. Ord k => Map k a -> k -> a
M.! Bipartition Name
b, Map (Bipartition Name) Double
bpToBrLen2 Map (Bipartition Name) Double -> Bipartition Name -> Double
forall k a. Ord k => Map k a -> k -> a
M.! Bipartition Name
b)
                      | Bipartition Name
b <- Set (Bipartition Name) -> [Bipartition Name]
forall a. Set a -> [a]
S.toList Set (Bipartition Name)
bpCommon
                    ]
              IO () -> Logger (Environment CompareArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment CompareArguments) ())
-> IO () -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ([Attribute] -> IO ()) -> IO ()
epspdfPlot FilePath
fn ([(Double, Double)] -> [Attribute] -> IO ()
plotBps [(Double, Double)]
compareCommonBps)
              FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logInfoS
                FilePath
"Comparison of branch lengths plot generated (EPS and PDF)"
    (Either FilePath (Tree Length Name),
 Either FilePath (Tree Length Name))
_ -> FilePath -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
FilePath -> Logger e ()
logWarnS FilePath
"Not all branches have a length! Can not analyze bipartitions."

header :: String
header :: FilePath
header = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"  " ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath]
cols [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"Bipartition"]
  where
    cols :: [FilePath]
cols =
      (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map
        (Text -> FilePath
T.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
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 :: Map (Bipartition a) b
-> Map (Bipartition a) b -> Bipartition a -> FilePath
getCommonBpStr Map (Bipartition a) b
m1 Map (Bipartition a) b
m2 Bipartition a
p =
  FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate
    FilePath
"  "
    [ FilePath -> b -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"% 12.7f" b
l1,
      FilePath -> b -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"% 12.7f" b
l2,
      FilePath -> b -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"% 12.7f" b
d,
      FilePath -> b -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"% 12.7f" b
rd,
      FilePath
s
    ]
  where
    l1 :: b
l1 = Map (Bipartition a) b
m1 Map (Bipartition a) b -> Bipartition a -> b
forall k a. Ord k => Map k a -> k -> a
M.! Bipartition a
p
    l2 :: b
l2 = Map (Bipartition a) b
m2 Map (Bipartition a) b -> Bipartition a -> b
forall k a. Ord k => Map k a -> k -> a
M.! Bipartition a
p
    d :: b
d = b
l1 b -> b -> b
forall a. Num a => a -> a -> a
- b
l2
    rd :: b
rd = b
2 b -> b -> b
forall a. Num a => a -> a -> a
* b
d b -> b -> b
forall a. Fractional a => a -> a -> a
/ (b
l1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
l2)
    s :: FilePath
s = Bipartition a -> FilePath
forall a. Show a => Bipartition a -> FilePath
bpHuman Bipartition a
p

plotBps :: [(Double, Double)] -> [Attribute] -> IO ()
plotBps :: [(Double, Double)] -> [Attribute] -> IO ()
plotBps [(Double, Double)]
xs [Attribute]
as = [Attribute] -> [(PlotStyle, [(Double, Double)])] -> IO ()
forall a. C a => [Attribute] -> [(PlotStyle, [(a, a)])] -> IO ()
plotPathsStyle [Attribute]
as' [(PlotStyle
ps1, [(Double, Double)]
xs), (PlotStyle
ps2, [(Double, Double)]
line)]
  where
    as' :: [Attribute]
as' =
      [Attribute]
as
        [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Attribute
Title FilePath
"Comparison of branch lengths of common branches",
             FilePath -> Attribute
XLabel FilePath
"Branch lengths, tree 1",
             FilePath -> Attribute
YLabel FilePath
"Branch lengths, tree 2"
           ]
    ps1 :: PlotStyle
ps1 = PlotType -> LineSpec -> PlotStyle
PlotStyle PlotType
Points (Int -> LineSpec
DefaultStyle Int
1)
    -- m = minimum $ map fst xs ++ map snd xs
    mx :: Double
mx = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ ((Double, Double) -> Double) -> [(Double, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Double) -> Double
forall a b. (a, b) -> a
fst [(Double, Double)]
xs
    my :: Double
my = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ ((Double, Double) -> Double) -> [(Double, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Double) -> Double
forall a b. (a, b) -> b
snd [(Double, Double)]
xs
    m :: Double
m = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
mx Double
my
    line :: [(Double, Double)]
line = [(Double
0, Double
0), (Double
m, Double
m)]
    ps2 :: PlotStyle
ps2 = PlotType -> LineSpec -> PlotStyle
PlotStyle PlotType
Lines (Int -> LineSpec
DefaultStyle Int
1)