{-# 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 System.IO
import TLynx.Compare.Options
import TLynx.Parsers
import Text.Printf

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

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

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

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

  -- Bipartitions.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CompareArguments -> Bool
argsBipartitions CompareArguments
l) forall a b. (a -> b) -> a -> b
$ Handle
-> Tree Phylo Name
-> Tree Phylo Name
-> Logger (Environment CompareArguments) ()
analyzeBipartitions Handle
outH Tree Phylo Name
t1 Tree Phylo Name
t2
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
outH

analyzeDistance ::
  Handle ->
  Tree Phylo Name ->
  Tree Phylo Name ->
  ELynx CompareArguments ()
analyzeDistance :: Handle
-> Tree Phylo Name
-> Tree Phylo Name
-> Logger (Environment CompareArguments) ()
analyzeDistance Handle
outH Tree Phylo Name
t1 Tree Phylo Name
t2 = do
  let formatD :: Text -> Text -> Text
formatD Text
str Text
val = Int -> Char -> Text -> Text
T.justifyLeft Int
25 Char
' ' Text
str forall a. Semigroup a => a -> a -> a
<> Text
"  " forall a. Semigroup a => a -> a -> a
<> Text
val
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Distances."
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
      Text -> Text -> Text
formatD
        Text
"Symmetric"
        ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
Ord a =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
symmetric Tree Phylo Name
t1 Tree Phylo Name
t2)
  case (forall e a.
HasMaybeLength e =>
Tree e a -> Either [Char] (Tree Length a)
toLengthTree Tree Phylo Name
t1, forall e a.
HasMaybeLength e =>
Tree e a -> Either [Char] (Tree Length a)
toLengthTree Tree Phylo Name
t2) of
    (Right Tree Length Name
t1', Right Tree Length Name
t2') -> do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Branch score"
            ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall e1 e2 a.
(HasLength e1, HasLength e2, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Double
branchScore Tree Length Name
t1' Tree Length Name
t2')
    (Either [Char] (Tree Length Name),
 Either [Char] (Tree Length Name))
_ -> do
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Some branches do not have length values."
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Distances involving length cannot be calculated."
  case (forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Either [Char] (Tree PhyloExplicit a)
toExplicitTree Tree Phylo Name
t1, forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Either [Char] (Tree PhyloExplicit a)
toExplicitTree Tree Phylo Name
t2) of
    (Right Tree PhyloExplicit Name
t1', Right Tree PhyloExplicit Name
t2') -> do
      let t1n :: Tree PhyloExplicit Name
t1n = forall e a. HasSupport e => Tree e a -> Tree e a
normalizeBranchSupport Tree PhyloExplicit Name
t1'
          t2n :: Tree PhyloExplicit Name
t2n = forall e a. HasSupport e => Tree e a -> Tree e a
normalizeBranchSupport Tree PhyloExplicit Name
t2'
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logDebugS [Char]
"Trees with normalized branch support values:"
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Tree Phylo a
toPhyloTree Tree PhyloExplicit Name
t1n
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e, HasName a) =>
Tree e a -> ByteString
toNewick forall a b. (a -> b) -> a -> b
$ forall e a.
(HasMaybeLength e, HasMaybeSupport e) =>
Tree e a -> Tree Phylo a
toPhyloTree Tree PhyloExplicit Name
t2n
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Incompatible split"
            ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
incompatibleSplits Tree PhyloExplicit Name
t1n Tree PhyloExplicit Name
t2n)
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Incompatible split (0.10)"
            ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
incompatibleSplits (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.1 Tree PhyloExplicit Name
t1n) (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.1 Tree PhyloExplicit Name
t2n))
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Incompatible split (0.50)"
            ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
incompatibleSplits (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.5 Tree PhyloExplicit Name
t1n) (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.5 Tree PhyloExplicit Name
t2n))
      -- 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))
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Incompatible split (0.80)"
            ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
incompatibleSplits (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.8 Tree PhyloExplicit Name
t1n) (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.8 Tree PhyloExplicit Name
t2n))
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
outH forall a b. (a -> b) -> a -> b
$
          Text -> Text -> Text
formatD
            Text
"Incompatible split (0.90)"
            ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a e1 e2.
(Show a, Ord a) =>
Tree e1 a -> Tree e2 a -> Either [Char] Int
incompatibleSplits (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.9 Tree PhyloExplicit Name
t1n) (forall e a.
(Eq e, Eq a, HasSupport e) =>
Support -> Tree e a -> Tree e a
collapse Support
0.9 Tree PhyloExplicit Name
t2n))
    -- 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
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Some branches do not have support values."
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Distances involving branch support cannot be calculated."

analyzeBipartitions ::
  Handle ->
  Tree Phylo Name ->
  Tree Phylo Name ->
  ELynx CompareArguments ()
analyzeBipartitions :: Handle
-> Tree Phylo Name
-> Tree Phylo Name
-> Logger (Environment CompareArguments) ()
analyzeBipartitions Handle
outH Tree Phylo Name
t1 Tree Phylo Name
t2 =
  case (forall e a.
HasMaybeLength e =>
Tree e a -> Either [Char] (Tree Length a)
toLengthTree Tree Phylo Name
t1, forall e a.
HasMaybeLength e =>
Tree e a -> Either [Char] (Tree Length a)
toLengthTree Tree Phylo Name
t2) of
    (Right Tree Length Name
t1l, Right Tree Length Name
t2l) -> do
      let bp1 :: Set (Bipartition Name)
bp1 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a e.
Ord a =>
Tree e a -> Either [Char] (Set (Bipartition a))
bipartitions Tree Length Name
t1l
          bp2 :: Set (Bipartition Name)
bp2 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a e.
Ord a =>
Tree e a -> Either [Char] (Set (Bipartition a))
bipartitions Tree Length Name
t2l
          bp1Only :: Set (Bipartition Name)
bp1Only = Set (Bipartition Name)
bp1 forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set (Bipartition Name)
bp2
          bp2Only :: Set (Bipartition Name)
bp2Only = Set (Bipartition Name)
bp2 forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set (Bipartition Name)
bp1
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (forall a. Set a -> Bool
S.null Set (Bipartition Name)
bp1Only)
        ( do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
              Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Bipartitions in Tree 1 that are not in Tree 2."
            -- let bp1Strs = map (bphuman BL.unpack . bpmap getName) (S.toList bp1Only)
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set (Bipartition Name)
bp1Only (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> [Char] -> IO ()
hPutStrLn Handle
outH forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Bipartition a -> [Char]
bpHuman)
        )
      -- let bp1Strs = map (bphuman BL.unpack) (S.toList bp1Only)
      -- liftIO $ hPutStrLn outH $ intercalate "\n" bp1Strs)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (forall a. Set a -> Bool
S.null Set (Bipartition Name)
bp2Only)
        ( do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
              Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"Bipartitions in Tree 2 that are not in Tree 1."
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set (Bipartition Name)
bp2Only (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> [Char] -> IO ()
hPutStrLn Handle
outH forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Bipartition a -> [Char]
bpHuman)
        )
      -- Common bipartitions and their respective differences in branch lengths.
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
""
      let bpCommon :: Set (Bipartition Name)
bpCommon = Set (Bipartition Name)
bp1 forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set (Bipartition Name)
bp2
      if forall a. Set a -> Bool
S.null Set (Bipartition Name)
bpCommon
        then do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"There are no common bipartitions."
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
"No plots have been generated."
        else do
          let bpToBrLen1 :: Map (Bipartition Name) Double
bpToBrLen1 = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Length -> Double
fromLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. HasLength e => e -> Length
getLength) forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall e a.
(Semigroup e, Ord a) =>
Tree e a -> Either [Char] (Map (Bipartition a) e)
bipartitionToBranch Tree Length Name
t1l
              bpToBrLen2 :: Map (Bipartition Name) Double
bpToBrLen2 = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Length -> Double
fromLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. HasLength e => e -> Length
getLength) forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall e a.
(Semigroup e, Ord a) =>
Tree e a -> Either [Char] (Map (Bipartition a) e)
bipartitionToBranch Tree Length Name
t2l
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            Handle -> [Char] -> IO ()
hPutStrLn
              Handle
outH
              [Char]
"Common bipartitions and their respective differences in branch lengths."
          -- Header.
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
outH [Char]
header
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
            Set (Bipartition Name)
bpCommon
            ( forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> [Char] -> IO ()
hPutStrLn Handle
outH
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b.
(Ord a, Show a, Fractional b, PrintfArg b) =>
Map (Bipartition a) b
-> Map (Bipartition a) b -> Bipartition a -> [Char]
getCommonBpStr Map (Bipartition Name) Double
bpToBrLen1 Map (Bipartition Name) Double
bpToBrLen2
            )
          -- XXX: This circumvents the extension checking, and hash creation for
          -- elynx files.
          Maybe [Char]
bn <- GlobalArguments -> Maybe [Char]
outFileBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Environment a -> GlobalArguments
globalArguments forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
          case Maybe [Char]
bn of
            Maybe [Char]
Nothing ->
              forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"No output file name provided. Do not generate plots."
            -- Just fn -> do
            --   let compareCommonBps =
            --         [ (bpToBrLen1 M.! b, bpToBrLen2 M.! b)
            --           | b <- S.toList bpCommon
            --         ]
            --   liftIO $ epspdfPlot fn (plotBps compareCommonBps)
            --   logInfoS
            --     "Comparison of branch lengths plot generated (EPS and PDF)"
            Just [Char]
_ -> do
              forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"No plot generated (no Gnuplot with GHC 9.2.1)"
    (Either [Char] (Tree Length Name),
 Either [Char] (Tree Length Name))
_ -> forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logWarnS [Char]
"Not all branches have a length! Can not analyze bipartitions."

header :: String
header :: [Char]
header = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"  " forall a b. (a -> b) -> a -> b
$ [[Char]]
cols forall a. [a] -> [a] -> [a]
++ [[Char]
"Bipartition"]
  where
    cols :: [[Char]]
cols =
      forall a b. (a -> b) -> [a] -> [b]
map
        (Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> Text -> Text
T.justifyRight Int
12 Char
' ')
        [Text
"Length 1", Text
"Length 2", Text
"Delta", Text
"Relative [%]"]

getCommonBpStr ::
  (Ord a, Show a, Fractional b, PrintfArg b) =>
  M.Map (Bipartition a) b ->
  M.Map (Bipartition a) b ->
  Bipartition a ->
  String
getCommonBpStr :: forall a b.
(Ord a, Show a, Fractional b, PrintfArg b) =>
Map (Bipartition a) b
-> Map (Bipartition a) b -> Bipartition a -> [Char]
getCommonBpStr Map (Bipartition a) b
m1 Map (Bipartition a) b
m2 Bipartition a
p =
  forall a. [a] -> [[a]] -> [a]
intercalate
    [Char]
"  "
    [ forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
l1,
      forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
l2,
      forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
d,
      forall r. PrintfType r => [Char] -> r
printf [Char]
"% 12.7f" b
rd,
      [Char]
s
    ]
  where
    l1 :: b
l1 = Map (Bipartition a) b
m1 forall k a. Ord k => Map k a -> k -> a
M.! Bipartition a
p
    l2 :: b
l2 = Map (Bipartition a) b
m2 forall k a. Ord k => Map k a -> k -> a
M.! Bipartition a
p
    d :: b
d = b
l1 forall a. Num a => a -> a -> a
- b
l2
    rd :: b
rd = b
2 forall a. Num a => a -> a -> a
* b
d forall a. Fractional a => a -> a -> a
/ (b
l1 forall a. Num a => a -> a -> a
+ b
l2)
    s :: [Char]
s = forall a. Show a => Bipartition a -> [Char]
bpHuman Bipartition a
p

-- -- NOTE: I removed the plotting functionality because Gnuplot does not
-- -- support GHC 9.2.1.
--
-- plotBps :: [(Double, Double)] -> [Attribute] -> IO ()
-- plotBps xs as = plotPathsStyle as' [(ps1, xs), (ps2, line)]
--   where
--     as' =
--       as
--         ++ [ Title "Comparison of branch lengths of common branches",
--              XLabel "Branch lengths, tree 1",
--              YLabel "Branch lengths, tree 2"
--            ]
--     ps1 = PlotStyle Points (DefaultStyle 1)
--     -- m = minimum $ map fst xs ++ map snd xs
--     mx = maximum $ map fst xs
--     my = maximum $ map snd xs
--     m = min mx my
--     line = [(0, 0), (m, m)]
--     ps2 = PlotStyle Lines (DefaultStyle 1)