{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  TLynx.Compare.Compare
-- Description :  Compare two phylogenies
-- Copyright   :  2021 Dominik Schrempf
-- 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.ELynx
import ELynx.Tools.Environment
import ELynx.Tools.Logger
import ELynx.Tools.Options
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 :: [Char] -> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesOneFile [Char]
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
  [Char] -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment CompareArguments) ())
-> [Char] -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Parse file '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tf [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'."
  Forest Phylo Name
ts <- IO (Forest Phylo Name)
-> ReaderT (Environment CompareArguments) IO (Forest Phylo Name)
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO (Forest Phylo Name)
parseTrees NewickFormat
nwF [Char]
tf
  let n :: Int
n = Forest Phylo Name -> Int
forall a. [a] -> 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 -> [Char] -> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall a. HasCallStack => [Char] -> a
error [Char]
"Not enough trees in file."
    Ordering
GT -> [Char] -> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall a. HasCallStack => [Char] -> a
error [Char]
"Too many trees in file."
    Ordering
EQ ->
      (Tree Phylo Name, Tree Phylo Name)
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall a. a -> ReaderT (Environment CompareArguments) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Forest Phylo Name -> Tree Phylo Name
forall a. HasCallStack => [a] -> a
head Forest Phylo Name
ts, Forest Phylo Name -> Tree Phylo Name
forall a. HasCallStack => [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. HasCallStack => [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 :: [Char]
-> [Char]
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesTwoFiles [Char]
tf1 [Char]
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
  [Char] -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment CompareArguments) ())
-> [Char] -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Parse first tree file '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tf1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'."
  Tree Phylo Name
t1 <- IO (Tree Phylo Name)
-> ReaderT (Environment CompareArguments) IO (Tree Phylo Name)
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO (Tree Phylo Name)
parseTree NewickFormat
nwF [Char]
tf1
  [Char] -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment CompareArguments) ())
-> [Char] -> Logger (Environment CompareArguments) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Parse second tree file '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tf2 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'."
  Tree Phylo Name
t2 <- IO (Tree Phylo Name)
-> ReaderT (Environment CompareArguments) IO (Tree Phylo Name)
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO (Tree Phylo Name)
parseTree NewickFormat
nwF [Char]
tf2
  (Tree Phylo Name, Tree Phylo Name)
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall a. a -> ReaderT (Environment CompareArguments) IO a
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 <- [Char] -> [Char] -> ELynx CompareArguments Handle
forall a. Reproducible a => [Char] -> [Char] -> ELynx a Handle
outHandle [Char]
"results" [Char]
".out"
  -- Read input.
  let inFs :: [[Char]]
inFs = CompareArguments -> [[Char]]
argsInFiles CompareArguments
l
      nFs :: Int
nFs = [[Char]] -> Int
forall a. [a] -> Int
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 ([[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
inFs)
    Int
2 -> [Char]
-> [Char]
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
treesTwoFiles ([[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
inFs) ([[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head ([[Char]] -> [Char])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
forall a. HasCallStack => [a] -> [a]
tail ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]]
inFs)
    Int
_ ->
      [Char] -> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall a. HasCallStack => [Char] -> a
error
        [Char]
"Need two input files with one tree each or one input file with two trees."
  IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Tree 1:"
  IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Tree 2:"
  IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
  -- Intersect trees.
  (Tree Phylo Name
t1, Tree Phylo Name
t2) <-
    if CompareArguments -> Bool
argsIntersect CompareArguments
l
      then do
        case ([Char] -> Forest Phylo Name)
-> (Forest Phylo Name -> Forest Phylo Name)
-> Either [Char] (Forest Phylo Name)
-> Forest Phylo Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Forest Phylo Name
forall a. HasCallStack => [Char] -> a
error Forest Phylo Name -> Forest Phylo Name
forall a. a -> a
id (Either [Char] (Forest Phylo Name) -> Forest Phylo Name)
-> Either [Char] (Forest Phylo Name) -> Forest Phylo Name
forall a b. (a -> b) -> a -> b
$ Forest Phylo Name -> Either [Char] (Forest Phylo Name)
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
            IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Intersected trees are:"
            IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 a. a -> ReaderT (Environment CompareArguments) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree Phylo Name
x, Tree Phylo Name
y)
          Forest Phylo Name
_ -> [Char] -> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall a. HasCallStack => [Char] -> a
error [Char]
"compareCmd: Could not intersect trees."
      else (Tree Phylo Name, Tree Phylo Name)
-> ELynx CompareArguments (Tree Phylo Name, Tree Phylo Name)
forall a. a -> ReaderT (Environment CompareArguments) IO a
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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Distances."
  IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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"
        ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Either [Char] Int -> [Char]
forall a. Show a => a -> [Char]
show (Either [Char] Int -> [Char]) -> Either [Char] Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Tree Phylo Name -> Tree Phylo Name -> Either [Char] Int
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 (Tree Phylo Name -> Either [Char] (Tree Length Name)
forall e a.
HasMaybeLength e =>
Tree e a -> Either [Char] (Tree Length a)
toLengthTree Tree Phylo Name
t1, Tree Phylo Name -> Either [Char] (Tree Length Name)
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
      IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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"
            ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Either [Char] Double -> [Char]
forall a. Show a => a -> [Char]
show (Either [Char] Double -> [Char]) -> Either [Char] Double -> [Char]
forall a b. (a -> b) -> a -> b
$ Tree Length Name -> Tree Length Name -> Either [Char] Double
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
      [Char] -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Some branches do not have length values."
      [Char] -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Distances involving length cannot be calculated."
  case (Tree Phylo Name -> Either [Char] (Tree PhyloExplicit Name)
forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Either [Char] (Tree PhyloExplicit a)
toExplicitTree Tree Phylo Name
t1, Tree Phylo Name -> Either [Char] (Tree PhyloExplicit Name)
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 = 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'
      [Char] -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logDebugS [Char]
"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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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"
            ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Either [Char] Int -> [Char]
forall a. Show a => a -> [Char]
show (Either [Char] Int -> [Char]) -> Either [Char] Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name
-> Tree PhyloExplicit Name -> Either [Char] Int
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)
      IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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)"
            ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Either [Char] Int -> [Char]
forall a. Show a => a -> [Char]
show (Either [Char] Int -> [Char]) -> Either [Char] Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name
-> Tree PhyloExplicit Name -> Either [Char] Int
forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] 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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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)"
            ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Either [Char] Int -> [Char]
forall a. Show a => a -> [Char]
show (Either [Char] Int -> [Char]) -> Either [Char] Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name
-> Tree PhyloExplicit Name -> Either [Char] Int
forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] 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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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)"
            ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Either [Char] Int -> [Char]
forall a. Show a => a -> [Char]
show (Either [Char] Int -> [Char]) -> Either [Char] Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name
-> Tree PhyloExplicit Name -> Either [Char] Int
forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] 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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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)"
            ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Either [Char] Int -> [Char]
forall a. Show a => a -> [Char]
show (Either [Char] Int -> [Char]) -> Either [Char] Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Tree PhyloExplicit Name
-> Tree PhyloExplicit Name -> Either [Char] Int
forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] 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 [Char] (Tree PhyloExplicit Name),
 Either [Char] (Tree PhyloExplicit Name))
_ -> do
      [Char] -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Some branches do not have support values."
      [Char] -> Logger (Environment CompareArguments) ()
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 (Tree Phylo Name -> Either [Char] (Tree Length Name)
forall e a.
HasMaybeLength e =>
Tree e a -> Either [Char] (Tree Length a)
toLengthTree Tree Phylo Name
t1, Tree Phylo Name -> Either [Char] (Tree Length Name)
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 = ([Char] -> Set (Bipartition Name))
-> (Set (Bipartition Name) -> Set (Bipartition Name))
-> Either [Char] (Set (Bipartition Name))
-> Set (Bipartition Name)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Set (Bipartition Name)
forall a. HasCallStack => [Char] -> a
error Set (Bipartition Name) -> Set (Bipartition Name)
forall a. a -> a
id (Either [Char] (Set (Bipartition Name)) -> Set (Bipartition Name))
-> Either [Char] (Set (Bipartition Name)) -> Set (Bipartition Name)
forall a b. (a -> b) -> a -> b
$ Tree Length Name -> Either [Char] (Set (Bipartition Name))
forall a e.
Ord a =>
Tree e a -> Either [Char] (Set (Bipartition a))
bipartitions Tree Length Name
t1l
          bp2 :: Set (Bipartition Name)
bp2 = ([Char] -> Set (Bipartition Name))
-> (Set (Bipartition Name) -> Set (Bipartition Name))
-> Either [Char] (Set (Bipartition Name))
-> Set (Bipartition Name)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Set (Bipartition Name)
forall a. HasCallStack => [Char] -> a
error Set (Bipartition Name) -> Set (Bipartition Name)
forall a. a -> a
id (Either [Char] (Set (Bipartition Name)) -> Set (Bipartition Name))
-> Either [Char] (Set (Bipartition Name)) -> Set (Bipartition Name)
forall a b. (a -> b) -> a -> b
$ Tree Length Name -> Either [Char] (Set (Bipartition Name))
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 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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
            IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH ([Char] -> IO ())
-> (Bipartition Name -> [Char]) -> Bipartition Name -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bipartition Name -> [Char]
forall a. Show a => Bipartition a -> [Char]
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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
            IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH ([Char] -> IO ())
-> (Bipartition Name -> [Char]) -> Bipartition Name -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bipartition Name -> [Char]
forall a. Show a => Bipartition a -> [Char]
bpHuman)
        )
      -- Common bipartitions and their respective differences in branch lengths.
      IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
      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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"There are no common bipartitions."
          IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"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
$ ([Char] -> Map (Bipartition Name) Length)
-> (Map (Bipartition Name) Length -> Map (Bipartition Name) Length)
-> Either [Char] (Map (Bipartition Name) Length)
-> Map (Bipartition Name) Length
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Map (Bipartition Name) Length
forall a. HasCallStack => [Char] -> a
error Map (Bipartition Name) Length -> Map (Bipartition Name) Length
forall a. a -> a
id (Either [Char] (Map (Bipartition Name) Length)
 -> Map (Bipartition Name) Length)
-> Either [Char] (Map (Bipartition Name) Length)
-> Map (Bipartition Name) Length
forall a b. (a -> b) -> a -> b
$ Tree Length Name -> Either [Char] (Map (Bipartition Name) Length)
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 = (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
$ ([Char] -> Map (Bipartition Name) Length)
-> (Map (Bipartition Name) Length -> Map (Bipartition Name) Length)
-> Either [Char] (Map (Bipartition Name) Length)
-> Map (Bipartition Name) Length
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Map (Bipartition Name) Length
forall a. HasCallStack => [Char] -> a
error Map (Bipartition Name) Length -> Map (Bipartition Name) Length
forall a. a -> a
id (Either [Char] (Map (Bipartition Name) Length)
 -> Map (Bipartition Name) Length)
-> Either [Char] (Map (Bipartition Name) Length)
-> Map (Bipartition Name) Length
forall a b. (a -> b) -> a -> b
$ Tree Length Name -> Either [Char] (Map (Bipartition Name) Length)
forall e a.
(Semigroup e, Ord a) =>
Tree e a -> Either [Char] (Map (Bipartition a) e)
bipartitionToBranch Tree Length Name
t2l
          IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn
              Handle
outH
              [Char]
"Common bipartitions and their respective differences in branch lengths."
          -- Header.
          IO () -> Logger (Environment CompareArguments) ()
forall a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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 -> [Char] -> IO ()
hPutStrLn Handle
outH
                ([Char] -> IO ())
-> (Bipartition Name -> [Char]) -> Bipartition Name -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Bipartition Name) Double
-> Map (Bipartition Name) Double -> Bipartition Name -> [Char]
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
            )
          -- XXX: This circumvents the extension checking, and hash creation for
          -- elynx files.
          Maybe [Char]
bn <- GlobalArguments -> Maybe [Char]
outFileBaseName (GlobalArguments -> Maybe [Char])
-> (Environment CompareArguments -> GlobalArguments)
-> Environment CompareArguments
-> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment CompareArguments -> GlobalArguments
forall a. Environment a -> GlobalArguments
globalArguments (Environment CompareArguments -> Maybe [Char])
-> ReaderT
     (Environment CompareArguments) IO (Environment CompareArguments)
-> ReaderT (Environment CompareArguments) IO (Maybe [Char])
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 [Char]
bn of
            Maybe [Char]
Nothing ->
              [Char] -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"No output file name provided. Do not generate plots."
            Just [Char]
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 a. IO a -> ReaderT (Environment CompareArguments) IO a
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
$ [Char] -> ([Attribute] -> IO ()) -> IO ()
epspdfPlot [Char]
fn ([(Double, Double)] -> [Attribute] -> IO ()
plotBps [(Double, Double)]
compareCommonBps)
              [Char] -> Logger (Environment CompareArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS
                [Char]
"Comparison of branch lengths plot generated (EPS and PDF)"
    (Either [Char] (Tree Length Name),
 Either [Char] (Tree Length Name))
_ -> [Char] -> Logger (Environment CompareArguments) ()
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
header :: [Char]
header = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"  " ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]]
cols [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"Bipartition"]
  where
    cols :: [[Char]]
cols =
      (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
        (Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
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 =
  [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate
    [Char]
"  "
    [ [Char] -> b -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
l1,
      [Char] -> b -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
l2,
      [Char] -> b -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
d,
      [Char] -> b -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
rd,
      [Char]
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 :: [Char]
s = Bipartition a -> [Char]
forall a. Show a => Bipartition a -> [Char]
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]
++ [ [Char] -> Attribute
Title [Char]
"Comparison of branch lengths of common branches",
             [Char] -> Attribute
XLabel [Char]
"Branch lengths, tree 1",
             [Char] -> Attribute
YLabel [Char]
"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 a. Ord a => [a] -> a
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 a. Ord a => [a] -> a
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)