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

-- |
-- Description :  Analyze trees
-- Copyright   :  (c) Dominik Schrempf 2021
-- 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
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