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

-- |
-- Description :  Analyze trees
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Fri May 24 13:47:56 2019.
module TLynx.Examine.Examine
  ( examine,
  )
where

import Control.Monad (unless)
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader (ask)
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Containers.ListUtils (nubOrd)
import Data.List ((\\))
import ELynx.Tools.ByteString
import ELynx.Tools.ELynx
import ELynx.Tools.Environment
import ELynx.Tools.Logger
import ELynx.Tree
import System.IO
  ( Handle,
    hPutStrLn,
  )
import TLynx.Examine.Options
import TLynx.Parsers
import Text.Printf

pretty :: Length -> String
pretty :: Length -> String
pretty = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.5f" (Double -> String) -> (Length -> Double) -> Length -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Length -> Double
fromLength

prettyRow :: String -> String -> BL.ByteString
prettyRow :: String -> String -> ByteString
prettyRow String
name String
val = Int -> ByteString -> ByteString
alignLeft Int
33 ByteString
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
alignRight Int
8 ByteString
v
  where
    n :: ByteString
n = String -> ByteString
BL.pack String
name
    v :: ByteString
v = String -> ByteString
BL.pack String
val

-- | Examine branches of a tree.
summarizeLengths :: HasLength e => Tree e a -> BL.ByteString
summarizeLengths :: Tree e a -> ByteString
summarizeLengths Tree e a
t =
  ByteString -> [ByteString] -> ByteString
BL.intercalate
    ByteString
"\n"
    [ String -> String -> ByteString
prettyRow String
"Origin height: " (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Length -> String
pretty Length
h,
      String -> String -> ByteString
prettyRow String
"Mean distance origin leaves: " (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Length -> String
pretty Length
h',
      String -> String -> ByteString
prettyRow String
"Total branch length: " (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Length -> String
pretty Length
b
    ]
  where
    n :: Int
n = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ Tree e a -> [a]
forall e a. Tree e a -> [a]
leaves Tree e a
t
    h :: Length
h = Tree e a -> Length
forall e a. HasLength e => Tree e a -> Length
height Tree e a
t
    h' :: Length
h' = [Length] -> Length
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Tree e a -> [Length]
forall e a. HasLength e => Tree e a -> [Length]
distancesOriginLeaves Tree e a
t) Length -> Length -> Length
forall a. Fractional a => a -> a -> a
/ Int -> Length
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
    b :: Length
b = Tree e a -> Length
forall e a. HasLength e => Tree e a -> Length
totalBranchLength Tree e a
t

readTrees :: FilePath -> ELynx ExamineArguments (Forest Phylo Name)
readTrees :: String -> ELynx ExamineArguments (Forest Phylo Name)
readTrees String
fp = do
  String -> Logger (Environment ExamineArguments) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String -> Logger (Environment ExamineArguments) ())
-> String -> Logger (Environment ExamineArguments) ()
forall a b. (a -> b) -> a -> b
$ String
"Read tree(s) from file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
  NewickFormat
nf <- ExamineArguments -> NewickFormat
argsNewickFormat (ExamineArguments -> NewickFormat)
-> (Environment ExamineArguments -> ExamineArguments)
-> Environment ExamineArguments
-> NewickFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment ExamineArguments -> ExamineArguments
forall a. Environment a -> a
localArguments (Environment ExamineArguments -> NewickFormat)
-> ReaderT
     (Environment ExamineArguments) IO (Environment ExamineArguments)
-> ReaderT (Environment ExamineArguments) IO NewickFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Environment ExamineArguments) IO (Environment ExamineArguments)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO (Forest Phylo Name)
-> ELynx ExamineArguments (Forest Phylo Name)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Forest Phylo Name)
 -> ELynx ExamineArguments (Forest Phylo Name))
-> IO (Forest Phylo Name)
-> ELynx ExamineArguments (Forest Phylo Name)
forall a b. (a -> b) -> a -> b
$ NewickFormat -> String -> IO (Forest Phylo Name)
parseTrees NewickFormat
nf String
fp

examineTree :: HasName a => Handle -> Tree Phylo a -> IO ()
examineTree :: Handle -> Tree Phylo a -> IO ()
examineTree Handle
h Tree Phylo a
t = do
  Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Number of leaves: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
lvs)
  let l :: Either String (Tree Length a)
l = Tree Phylo a -> Either String (Tree Length a)
forall e a.
HasMaybeLength e =>
Tree e a -> Either String (Tree Length a)
toLengthTree Tree Phylo a
t
  case Either String (Tree Length a)
l of
    Left String
_ -> Handle -> String -> IO ()
hPutStrLn Handle
h String
"Branch lengths not available."
    Right Tree Length a
t' -> Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Tree Length a -> ByteString
forall e a. HasLength e => Tree e a -> ByteString
summarizeLengths Tree Length a
t'
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
dups) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Handle -> String -> IO ()
hPutStrLn Handle
h String
""
    Handle -> String -> IO ()
hPutStrLn Handle
h (String
"Duplicate leaves: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ByteString] -> String
forall a. Show a => a -> String
show [ByteString]
dups)
  Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Leave names: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
" " [ByteString]
lvs
  where
    lvs :: [ByteString]
lvs = (a -> ByteString) -> [a] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ByteString
fromName (Name -> ByteString) -> (a -> Name) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. HasName a => a -> Name
getName) ([a] -> [ByteString]) -> [a] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Tree Phylo a -> [a]
forall e a. Tree e a -> [a]
leaves Tree Phylo a
t
    dups :: [ByteString]
dups = [ByteString]
lvs [ByteString] -> [ByteString] -> [ByteString]
forall a. Eq a => [a] -> [a] -> [a]
\\ [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
nubOrd [ByteString]
lvs

-- | Examine phylogenetic trees.
examine :: ELynx ExamineArguments ()
examine :: Logger (Environment ExamineArguments) ()
examine = do
  ExamineArguments
l <- Environment ExamineArguments -> ExamineArguments
forall a. Environment a -> a
localArguments (Environment ExamineArguments -> ExamineArguments)
-> ReaderT
     (Environment ExamineArguments) IO (Environment ExamineArguments)
-> ReaderT (Environment ExamineArguments) IO ExamineArguments
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Environment ExamineArguments) IO (Environment ExamineArguments)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let inFn :: String
inFn = ExamineArguments -> String
argsInFile ExamineArguments
l
  Forest Phylo Name
trs <- String -> ELynx ExamineArguments (Forest Phylo Name)
readTrees String
inFn
  Handle
outH <- String -> String -> ELynx ExamineArguments Handle
forall a. Reproducible a => String -> String -> ELynx a Handle
outHandle String
"results" String
".out"
  IO () -> Logger (Environment ExamineArguments) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment ExamineArguments) ())
-> IO () -> Logger (Environment ExamineArguments) ()
forall a b. (a -> b) -> a -> b
$ (Tree Phylo Name -> IO ()) -> Forest Phylo Name -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Tree Phylo Name -> IO ()
forall a. HasName a => Handle -> Tree Phylo a -> IO ()
examineTree Handle
outH) Forest Phylo Name
trs