{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  TLynx.Distance.Options
-- Description :  Options of tree-dist
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Thu Aug 29 13:02:22 2019.
module TLynx.Distance.Options
  ( DistanceArguments (..),
    DistanceMeasure (..),
    distanceArguments,
    distanceFooter,
  )
where

import Data.Aeson
import qualified Data.Attoparsec.ByteString.Char8 as AC
import qualified Data.ByteString.Char8 as BS
import ELynx.Tools.Reproduction
import ELynx.Tree (Support (..), toSupportUnsafe)
import GHC.Generics
import Options.Applicative
import TLynx.Parsers
import Text.Printf

-- | Supported distance measures.
data DistanceMeasure
  = -- | Symmetric distance.
    Symmetric
  | -- | Incompatible split distance; collapse nodes
    -- with branch support below given value.
    IncompatibleSplit Support
  | -- | Branch score distance.
    BranchScore
  deriving (DistanceMeasure -> DistanceMeasure -> Bool
(DistanceMeasure -> DistanceMeasure -> Bool)
-> (DistanceMeasure -> DistanceMeasure -> Bool)
-> Eq DistanceMeasure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DistanceMeasure -> DistanceMeasure -> Bool
== :: DistanceMeasure -> DistanceMeasure -> Bool
$c/= :: DistanceMeasure -> DistanceMeasure -> Bool
/= :: DistanceMeasure -> DistanceMeasure -> Bool
Eq, (forall x. DistanceMeasure -> Rep DistanceMeasure x)
-> (forall x. Rep DistanceMeasure x -> DistanceMeasure)
-> Generic DistanceMeasure
forall x. Rep DistanceMeasure x -> DistanceMeasure
forall x. DistanceMeasure -> Rep DistanceMeasure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DistanceMeasure -> Rep DistanceMeasure x
from :: forall x. DistanceMeasure -> Rep DistanceMeasure x
$cto :: forall x. Rep DistanceMeasure x -> DistanceMeasure
to :: forall x. Rep DistanceMeasure x -> DistanceMeasure
Generic)

instance FromJSON DistanceMeasure

instance ToJSON DistanceMeasure

instance Show DistanceMeasure where
  show :: DistanceMeasure -> FilePath
show DistanceMeasure
Symmetric = FilePath
"Symmetric"
  show (IncompatibleSplit Support
c) = FilePath
"Incompatible Split (" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2f" (Support -> Double
fromSupport Support
c) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
")"
  show DistanceMeasure
BranchScore = FilePath
"Branch Score"

-- | Arguments needed to compute distance measures.
data DistanceArguments = DistanceArguments
  { DistanceArguments -> DistanceMeasure
argsDistance :: DistanceMeasure,
    DistanceArguments -> Bool
argsNormalize :: Bool,
    DistanceArguments -> Bool
argsIntersect :: Bool,
    DistanceArguments -> Bool
argsSummaryStatistics :: Bool,
    DistanceArguments -> Maybe FilePath
argsMasterTreeFile :: Maybe FilePath,
    DistanceArguments -> NewickFormat
argsNewickFormat :: NewickFormat,
    DistanceArguments -> [FilePath]
argsInFiles :: [FilePath]
  }
  deriving (DistanceArguments -> DistanceArguments -> Bool
(DistanceArguments -> DistanceArguments -> Bool)
-> (DistanceArguments -> DistanceArguments -> Bool)
-> Eq DistanceArguments
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DistanceArguments -> DistanceArguments -> Bool
== :: DistanceArguments -> DistanceArguments -> Bool
$c/= :: DistanceArguments -> DistanceArguments -> Bool
/= :: DistanceArguments -> DistanceArguments -> Bool
Eq, Int -> DistanceArguments -> ShowS
[DistanceArguments] -> ShowS
DistanceArguments -> FilePath
(Int -> DistanceArguments -> ShowS)
-> (DistanceArguments -> FilePath)
-> ([DistanceArguments] -> ShowS)
-> Show DistanceArguments
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DistanceArguments -> ShowS
showsPrec :: Int -> DistanceArguments -> ShowS
$cshow :: DistanceArguments -> FilePath
show :: DistanceArguments -> FilePath
$cshowList :: [DistanceArguments] -> ShowS
showList :: [DistanceArguments] -> ShowS
Show, (forall x. DistanceArguments -> Rep DistanceArguments x)
-> (forall x. Rep DistanceArguments x -> DistanceArguments)
-> Generic DistanceArguments
forall x. Rep DistanceArguments x -> DistanceArguments
forall x. DistanceArguments -> Rep DistanceArguments x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DistanceArguments -> Rep DistanceArguments x
from :: forall x. DistanceArguments -> Rep DistanceArguments x
$cto :: forall x. Rep DistanceArguments x -> DistanceArguments
to :: forall x. Rep DistanceArguments x -> DistanceArguments
Generic)

instance Reproducible DistanceArguments where
  inFiles :: DistanceArguments -> [FilePath]
inFiles DistanceArguments
a = case DistanceArguments -> Maybe FilePath
argsMasterTreeFile DistanceArguments
a of
    Maybe FilePath
Nothing -> DistanceArguments -> [FilePath]
argsInFiles DistanceArguments
a
    Just FilePath
f -> FilePath
f FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: DistanceArguments -> [FilePath]
argsInFiles DistanceArguments
a
  outSuffixes :: DistanceArguments -> [FilePath]
outSuffixes DistanceArguments
_ = [FilePath
".out"]
  getSeed :: DistanceArguments -> Maybe SeedOpt
getSeed DistanceArguments
_ = Maybe SeedOpt
forall a. Maybe a
Nothing
  setSeed :: DistanceArguments -> SeedOpt -> DistanceArguments
setSeed = DistanceArguments -> SeedOpt -> DistanceArguments
forall a b. a -> b -> a
const
  parser :: Parser DistanceArguments
parser = Parser DistanceArguments
distanceArguments
  cmdName :: FilePath
cmdName = FilePath
"distance"
  cmdDsc :: [FilePath]
cmdDsc = [FilePath
"Compute distances between many phylogenetic trees."]
  cmdFtr :: [FilePath]
cmdFtr = [FilePath]
distanceFooter

instance FromJSON DistanceArguments

instance ToJSON DistanceArguments

-- | COmmand line parser.
distanceArguments :: Parser DistanceArguments
distanceArguments :: Parser DistanceArguments
distanceArguments =
  DistanceMeasure
-> Bool
-> Bool
-> Bool
-> Maybe FilePath
-> NewickFormat
-> [FilePath]
-> DistanceArguments
DistanceArguments
    (DistanceMeasure
 -> Bool
 -> Bool
 -> Bool
 -> Maybe FilePath
 -> NewickFormat
 -> [FilePath]
 -> DistanceArguments)
-> Parser DistanceMeasure
-> Parser
     (Bool
      -> Bool
      -> Bool
      -> Maybe FilePath
      -> NewickFormat
      -> [FilePath]
      -> DistanceArguments)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser DistanceMeasure
distanceOpt
    Parser
  (Bool
   -> Bool
   -> Bool
   -> Maybe FilePath
   -> NewickFormat
   -> [FilePath]
   -> DistanceArguments)
-> Parser Bool
-> Parser
     (Bool
      -> Bool
      -> Maybe FilePath
      -> NewickFormat
      -> [FilePath]
      -> DistanceArguments)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
normalizeSwitch
    Parser
  (Bool
   -> Bool
   -> Maybe FilePath
   -> NewickFormat
   -> [FilePath]
   -> DistanceArguments)
-> Parser Bool
-> Parser
     (Bool
      -> Maybe FilePath
      -> NewickFormat
      -> [FilePath]
      -> DistanceArguments)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
intersectSwitch
    Parser
  (Bool
   -> Maybe FilePath
   -> NewickFormat
   -> [FilePath]
   -> DistanceArguments)
-> Parser Bool
-> Parser
     (Maybe FilePath -> NewickFormat -> [FilePath] -> DistanceArguments)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
summaryStatisticsSwitch
    Parser
  (Maybe FilePath -> NewickFormat -> [FilePath] -> DistanceArguments)
-> Parser (Maybe FilePath)
-> Parser (NewickFormat -> [FilePath] -> DistanceArguments)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe FilePath)
masterTreeFile
    Parser (NewickFormat -> [FilePath] -> DistanceArguments)
-> Parser NewickFormat -> Parser ([FilePath] -> DistanceArguments)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser NewickFormat
newickFormat
    Parser ([FilePath] -> DistanceArguments)
-> Parser [FilePath] -> Parser DistanceArguments
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser FilePath -> Parser [FilePath]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser FilePath
inFilesArg

masterTreeFile :: Parser (Maybe FilePath)
masterTreeFile :: Parser (Maybe FilePath)
masterTreeFile =
  Parser FilePath -> Parser (Maybe FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser FilePath -> Parser (Maybe FilePath))
-> Parser FilePath -> Parser (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$
    Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$
      FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"master-tree-file"
        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'm'
        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"MASTER-TREE-File"
        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Compare all trees to the tree in the master tree file."
        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasCompleter f => FilePath -> Mod f a
action FilePath
"file"

inFilesArg :: Parser FilePath
inFilesArg :: Parser FilePath
inFilesArg =
  Mod ArgumentFields FilePath -> Parser FilePath
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (Mod ArgumentFields FilePath -> Parser FilePath)
-> Mod ArgumentFields FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$
    FilePath -> Mod ArgumentFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"INPUT-FILES"
      Mod ArgumentFields FilePath
-> Mod ArgumentFields FilePath -> Mod ArgumentFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod ArgumentFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help
        FilePath
"Read tree(s) from INPUT-FILES; if more files are given, one tree is expected per file"
      Mod ArgumentFields FilePath
-> Mod ArgumentFields FilePath -> Mod ArgumentFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod ArgumentFields FilePath
forall (f :: * -> *) a. HasCompleter f => FilePath -> Mod f a
action FilePath
"file"

symmetric :: AC.Parser DistanceMeasure
symmetric :: Parser DistanceMeasure
symmetric = do
  ByteString
_ <- ByteString -> Parser ByteString
AC.string ByteString
"symmetric"
  ()
_ <- Parser ByteString ()
forall t. Chunk t => Parser t ()
AC.endOfInput
  DistanceMeasure -> Parser DistanceMeasure
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DistanceMeasure
Symmetric

incompatibleSplit :: AC.Parser DistanceMeasure
incompatibleSplit :: Parser DistanceMeasure
incompatibleSplit = do
  ByteString
_ <- ByteString -> Parser ByteString
AC.string ByteString
"incompatible-split"
  Char
_ <- Char -> Parser Char
AC.char Char
'['
  Double
f <- Parser Double
AC.double
  Char
_ <- Char -> Parser Char
AC.char Char
']'
  ()
_ <- Parser ByteString ()
forall t. Chunk t => Parser t ()
AC.endOfInput
  if (Double
0 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
f) Bool -> Bool -> Bool
&& (Double
f Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1)
    then DistanceMeasure -> Parser DistanceMeasure
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DistanceMeasure -> Parser DistanceMeasure)
-> DistanceMeasure -> Parser DistanceMeasure
forall a b. (a -> b) -> a -> b
$ Support -> DistanceMeasure
IncompatibleSplit (Support -> DistanceMeasure) -> Support -> DistanceMeasure
forall a b. (a -> b) -> a -> b
$ Double -> Support
toSupportUnsafe Double
f
    else FilePath -> Parser DistanceMeasure
forall a. HasCallStack => FilePath -> a
error FilePath
"Branch support has to be in [0, 1]."

branchScore :: AC.Parser DistanceMeasure
branchScore :: Parser DistanceMeasure
branchScore = do
  ByteString
_ <- ByteString -> Parser ByteString
AC.string ByteString
"branch-score"
  ()
_ <- Parser ByteString ()
forall t. Chunk t => Parser t ()
AC.endOfInput
  DistanceMeasure -> Parser DistanceMeasure
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DistanceMeasure
BranchScore

-- Try first the normalized one, since the normal branch score
-- parser also succeeds in this case.
distanceParser :: AC.Parser DistanceMeasure
distanceParser :: Parser DistanceMeasure
distanceParser = Parser DistanceMeasure
symmetric Parser DistanceMeasure
-> Parser DistanceMeasure -> Parser DistanceMeasure
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser DistanceMeasure
incompatibleSplit Parser DistanceMeasure
-> Parser DistanceMeasure -> Parser DistanceMeasure
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser DistanceMeasure
branchScore

-- See 'eitherReader', but for an attoparsec parser.
eitherReadA :: AC.Parser a -> ReadM a
eitherReadA :: forall a. Parser a -> ReadM a
eitherReadA Parser a
p = (FilePath -> Either FilePath a) -> ReadM a
forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader ((FilePath -> Either FilePath a) -> ReadM a)
-> (FilePath -> Either FilePath a) -> ReadM a
forall a b. (a -> b) -> a -> b
$ \FilePath
input -> Parser a -> ByteString -> Either FilePath a
forall a. Parser a -> ByteString -> Either FilePath a
AC.parseOnly Parser a
p (FilePath -> ByteString
BS.pack FilePath
input)

distanceOpt :: Parser DistanceMeasure
distanceOpt :: Parser DistanceMeasure
distanceOpt =
  ReadM DistanceMeasure
-> Mod OptionFields DistanceMeasure -> Parser DistanceMeasure
forall a. ReadM a -> Mod OptionFields a -> Parser a
option (Parser DistanceMeasure -> ReadM DistanceMeasure
forall a. Parser a -> ReadM a
eitherReadA Parser DistanceMeasure
distanceParser) (Mod OptionFields DistanceMeasure -> Parser DistanceMeasure)
-> Mod OptionFields DistanceMeasure -> Parser DistanceMeasure
forall a b. (a -> b) -> a -> b
$
    FilePath -> Mod OptionFields DistanceMeasure
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"distance"
      Mod OptionFields DistanceMeasure
-> Mod OptionFields DistanceMeasure
-> Mod OptionFields DistanceMeasure
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields DistanceMeasure
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'd'
      Mod OptionFields DistanceMeasure
-> Mod OptionFields DistanceMeasure
-> Mod OptionFields DistanceMeasure
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields DistanceMeasure
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"MEASURE"
      Mod OptionFields DistanceMeasure
-> Mod OptionFields DistanceMeasure
-> Mod OptionFields DistanceMeasure
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields DistanceMeasure
forall (f :: * -> *) a. FilePath -> Mod f a
help
        FilePath
"Type of distance to calculate (available distance measures are listed below)"

summaryStatisticsSwitch :: Parser Bool
summaryStatisticsSwitch :: Parser Bool
summaryStatisticsSwitch =
  Mod FlagFields Bool -> Parser Bool
switch (Mod FlagFields Bool -> Parser Bool)
-> Mod FlagFields Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$
    FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"summary-statistics"
      Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
's'
      Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help
        FilePath
"Report summary statistics only"

normalizeSwitch :: Parser Bool
normalizeSwitch :: Parser Bool
normalizeSwitch =
  Mod FlagFields Bool -> Parser Bool
switch (Mod FlagFields Bool -> Parser Bool)
-> Mod FlagFields Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$
    FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"normalize"
      Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'n'
      Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help
        FilePath
"Normalize trees before distance calculation; only affect distances depending on branch lengths"

intersectSwitch :: Parser Bool
intersectSwitch :: Parser Bool
intersectSwitch =
  Mod FlagFields Bool -> Parser Bool
switch (Mod FlagFields Bool -> Parser Bool)
-> Mod FlagFields Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$
    FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"intersect"
      Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
't'
      Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help
        FilePath
"Compare intersections; i.e., before comparison, drop leaves that are not present in the other tree"

-- | Information about provided distance types.
distanceFooter :: [String]
distanceFooter :: [FilePath]
distanceFooter =
  [ FilePath
"Distance measures:",
    FilePath
"  symmetric                Symmetric distance (Robinson-Foulds distance).",
    FilePath
"  incompatible-split[VAL]  Incompatible split distance. Collapse branches with (normalized)",
    FilePath
"                           support less than 0.0<=VAL<=1.0 before distance calculation;",
    FilePath
"                           if, let's say, VAL>0.7, only well supported differences contribute",
    FilePath
"                           to the total distance.",
    FilePath
"  branch-score             Branch score distance."
  ]