{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  SLynx.Simulate.PhyloModel
-- Description :  Parse and interpret the model string
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Fri Feb  1 13:32:16 2019.
module SLynx.Simulate.PhyloModel
  ( getPhyloModel,
  )
where

import Control.Applicative
import Control.Monad (when)
import Data.Attoparsec.ByteString.Char8
import qualified Data.ByteString.Char8 as BS
import Data.Either (rights)
import Data.Maybe
import qualified Data.Vector as V
import ELynx.Import.MarkovProcess.EDMModelPhylobayes
  ( EDMComponent,
  )
import ELynx.MarkovProcess.AminoAcid
import ELynx.MarkovProcess.CXXModels
import qualified ELynx.MarkovProcess.MixtureModel as M
import ELynx.MarkovProcess.Nucleotide
import qualified ELynx.MarkovProcess.PhyloModel as P
import ELynx.MarkovProcess.RateMatrix
import qualified ELynx.MarkovProcess.SubstitutionModel as S
import ELynx.Tools.Equality
import ELynx.Tools.InputOutput
import Numeric.LinearAlgebra (norm_1, size, vector)
import SLynx.Simulate.Options (MixtureModelGlobalNormalization (..))

nNuc :: Int
-- nNuc = length (alphabet :: [Nucleotide])
nNuc :: Int
nNuc = Int
4

nAA :: Int
-- nAA = length (alphabet :: [AminoAcid])
nAA :: Int
nAA = Int
20

-- Model parameters between square brackets.
paramsStart :: Char
paramsStart :: Char
paramsStart = Char
'['

paramsEnd :: Char
paramsEnd :: Char
paramsEnd = Char
']'

-- Stationary distribution between curly brackets.
sdStart :: Char
sdStart :: Char
sdStart = Char
'{'

sdEnd :: Char
sdEnd :: Char
sdEnd = Char
'}'

-- Mixture model components between round brackets.
mmStart :: Char
mmStart :: Char
mmStart = Char
'('

mmEnd :: Char
mmEnd :: Char
mmEnd = Char
')'

separator :: Char
separator :: Char
separator = Char
','

name :: Parser String
name :: Parser [Char]
name =
  ByteString -> [Char]
BS.unpack
    (ByteString -> [Char])
-> Parser ByteString ByteString -> Parser [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString ByteString
takeWhile1 ([Char] -> Char -> Bool
notInClass [Char
paramsStart, Char
paramsEnd, Char
sdStart, Char
sdEnd, Char
mmStart, Char
mmEnd, Char
separator])

params :: Parser [Double]
params :: Parser Params
params = Char -> Parser Char
char Char
paramsStart Parser Char -> Parser Params -> Parser Params
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser R
double Parser R -> Parser Char -> Parser Params
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser Char
char Char
separator Parser Params -> Parser Char -> Parser Params
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
paramsEnd

stationaryDistribution :: Parser StationaryDistribution
stationaryDistribution :: Parser (Vector R)
stationaryDistribution = do
  Char
_ <- Char -> Parser Char
char Char
sdStart
  Vector R
f <- Params -> Vector R
vector (Params -> Vector R) -> Parser Params -> Parser (Vector R)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser R
double Parser R -> Parser Char -> Parser Params
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser Char
char Char
separator
  Char
_ <- Char -> Parser Char
char Char
sdEnd
  if R -> R -> Bool
nearlyEq (Vector R -> R
forall a. Normed a => a -> R
norm_1 Vector R
f) R
1.0
    then Vector R -> Parser (Vector R)
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Vector R
f
    else
      [Char] -> Parser (Vector R)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Parser (Vector R)) -> [Char] -> Parser (Vector R)
forall a b. (a -> b) -> a -> b
$
        [Char]
"Sum of stationary distribution is "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ R -> [Char]
forall a. Show a => a -> [Char]
show (Vector R -> R
forall a. Normed a => a -> R
norm_1 Vector R
f)
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" but should be 1.0."

assertLength :: StationaryDistribution -> Int -> a -> a
assertLength :: forall a. Vector R -> Int -> a -> a
assertLength Vector R
d Int
n a
r =
  if Vector R -> IndexOf Vector
forall (c :: * -> *) t. Container c t => c t -> IndexOf c
size Vector R
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n
    then
      [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$
        [Char]
"Length of stationary distribution is "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Vector R -> IndexOf Vector
forall (c :: * -> *) t. Container c t => c t -> IndexOf c
size Vector R
d)
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" but should be "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
    else a
r

-- This is the main function that connects the model string, the parameters and
-- the stationary distribution. It should check that the model is valid.
assembleSubstitutionModel ::
  S.Normalize ->
  String ->
  Maybe S.Params ->
  Maybe StationaryDistribution ->
  Either String S.SubstitutionModel
-- DNA models.
assembleSubstitutionModel :: Normalize
-> [Char]
-> Maybe Params
-> Maybe (Vector R)
-> Either [Char] SubstitutionModel
assembleSubstitutionModel Normalize
nz [Char]
"JC" Maybe Params
Nothing Maybe (Vector R)
Nothing = SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Normalize -> SubstitutionModel
jc Normalize
nz
assembleSubstitutionModel Normalize
nz [Char]
"F81" Maybe Params
Nothing (Just Vector R
d) =
  SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Vector R -> Int -> SubstitutionModel -> SubstitutionModel
forall a. Vector R -> Int -> a -> a
assertLength Vector R
d Int
nNuc (SubstitutionModel -> SubstitutionModel)
-> SubstitutionModel -> SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Normalize -> Vector R -> SubstitutionModel
f81 Normalize
nz Vector R
d
assembleSubstitutionModel Normalize
nz [Char]
"HKY" (Just [R
k]) (Just Vector R
d) =
  SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Vector R -> Int -> SubstitutionModel -> SubstitutionModel
forall a. Vector R -> Int -> a -> a
assertLength Vector R
d Int
nNuc (SubstitutionModel -> SubstitutionModel)
-> SubstitutionModel -> SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Normalize -> R -> Vector R -> SubstitutionModel
hky Normalize
nz R
k Vector R
d
assembleSubstitutionModel Normalize
nz [Char]
"GTR4" (Just Params
es) (Just Vector R
d) =
  SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Vector R -> Int -> SubstitutionModel -> SubstitutionModel
forall a. Vector R -> Int -> a -> a
assertLength Vector R
d Int
nNuc (SubstitutionModel -> SubstitutionModel)
-> SubstitutionModel -> SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Normalize -> Params -> Vector R -> SubstitutionModel
gtr4 Normalize
nz Params
es Vector R
d
-- Protein models.
assembleSubstitutionModel Normalize
nz [Char]
"Poisson" Maybe Params
Nothing Maybe (Vector R)
Nothing = SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Normalize -> SubstitutionModel
poisson Normalize
nz
assembleSubstitutionModel Normalize
nz [Char]
"Poisson-Custom" Maybe Params
Nothing (Just Vector R
d) =
  SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Vector R -> Int -> SubstitutionModel -> SubstitutionModel
forall a. Vector R -> Int -> a -> a
assertLength Vector R
d Int
nAA (SubstitutionModel -> SubstitutionModel)
-> SubstitutionModel -> SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> Normalize -> Vector R -> SubstitutionModel
poissonCustom Maybe [Char]
forall a. Maybe a
Nothing Normalize
nz Vector R
d
assembleSubstitutionModel Normalize
nz [Char]
"LG" Maybe Params
Nothing Maybe (Vector R)
Nothing = SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Normalize -> SubstitutionModel
lg Normalize
nz
assembleSubstitutionModel Normalize
nz [Char]
"LG-Custom" Maybe Params
Nothing (Just Vector R
d) =
  SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Vector R -> Int -> SubstitutionModel -> SubstitutionModel
forall a. Vector R -> Int -> a -> a
assertLength Vector R
d Int
nAA (SubstitutionModel -> SubstitutionModel)
-> SubstitutionModel -> SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> Normalize -> Vector R -> SubstitutionModel
lgCustom Maybe [Char]
forall a. Maybe a
Nothing Normalize
nz Vector R
d
assembleSubstitutionModel Normalize
nz [Char]
"WAG" Maybe Params
Nothing Maybe (Vector R)
Nothing = SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Normalize -> SubstitutionModel
wag Normalize
nz
assembleSubstitutionModel Normalize
nz [Char]
"WAG-Custom" Maybe Params
Nothing (Just Vector R
d) =
  SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Vector R -> Int -> SubstitutionModel -> SubstitutionModel
forall a. Vector R -> Int -> a -> a
assertLength Vector R
d Int
nAA (SubstitutionModel -> SubstitutionModel)
-> SubstitutionModel -> SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> Normalize -> Vector R -> SubstitutionModel
wagCustom Maybe [Char]
forall a. Maybe a
Nothing Normalize
nz Vector R
d
assembleSubstitutionModel Normalize
nz [Char]
"GTR20" (Just Params
es) (Just Vector R
d) =
  SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. b -> Either a b
Right (SubstitutionModel -> Either [Char] SubstitutionModel)
-> SubstitutionModel -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Vector R -> Int -> SubstitutionModel -> SubstitutionModel
forall a. Vector R -> Int -> a -> a
assertLength Vector R
d Int
nAA (SubstitutionModel -> SubstitutionModel)
-> SubstitutionModel -> SubstitutionModel
forall a b. (a -> b) -> a -> b
$ Normalize -> Params -> Vector R -> SubstitutionModel
gtr20 Normalize
nz Params
es Vector R
d
-- Ohterwisse, we cannot assemble the model.
assembleSubstitutionModel Normalize
nz [Char]
n Maybe Params
mps Maybe (Vector R)
mf =
  [Char] -> Either [Char] SubstitutionModel
forall a b. a -> Either a b
Left ([Char] -> Either [Char] SubstitutionModel)
-> [Char] -> Either [Char] SubstitutionModel
forall a b. (a -> b) -> a -> b
$
    [[Char]] -> [Char]
unlines
      [ [Char]
"Cannot assemble substitution model.",
        [Char]
"Normalize: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Normalize -> [Char]
forall a. Show a => a -> [Char]
show Normalize
nz,
        [Char]
"Name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
n,
        [Char]
"Parameters: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe Params -> [Char]
forall a. Show a => a -> [Char]
show Maybe Params
mps,
        [Char]
"Stationary distribution: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe (Vector R) -> [Char]
forall a. Show a => a -> [Char]
show Maybe (Vector R)
mf
      ]

parseSubstitutionModel :: S.Normalize -> Parser S.SubstitutionModel
parseSubstitutionModel :: Normalize -> Parser SubstitutionModel
parseSubstitutionModel Normalize
nz = do
  [Char]
n <- Parser [Char]
name
  Maybe Params
mps <- Parser Params -> Parser ByteString (Maybe Params)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Params
params
  Maybe (Vector R)
mf <- Parser (Vector R) -> Parser ByteString (Maybe (Vector R))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser (Vector R)
stationaryDistribution
  let esm :: Either [Char] SubstitutionModel
esm = Normalize
-> [Char]
-> Maybe Params
-> Maybe (Vector R)
-> Either [Char] SubstitutionModel
assembleSubstitutionModel Normalize
nz [Char]
n Maybe Params
mps Maybe (Vector R)
mf
  case Either [Char] SubstitutionModel
esm of
    Left [Char]
err -> [Char] -> Parser SubstitutionModel
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
    Right SubstitutionModel
sm -> SubstitutionModel -> Parser SubstitutionModel
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return SubstitutionModel
sm

edmModel :: MixtureModelGlobalNormalization -> [EDMComponent] -> Maybe [M.Weight] -> Parser M.MixtureModel
edmModel :: MixtureModelGlobalNormalization
-> [EDMComponent] -> Maybe Params -> Parser MixtureModel
edmModel MixtureModelGlobalNormalization
nz [EDMComponent]
cs Maybe Params
mws = do
  ByteString
_ <- ByteString -> Parser ByteString ByteString
string ByteString
"EDM"
  Char
_ <- Char -> Parser Char
char Char
mmStart
  [Char]
n <- Parser [Char]
name
  Maybe Params
mps <- Parser Params -> Parser ByteString (Maybe Params)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Params
params
  Char
_ <- Char -> Parser Char
char Char
mmEnd
  Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([EDMComponent] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EDMComponent]
cs) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Parser ByteString ()
forall a. HasCallStack => [Char] -> a
error [Char]
"edmModel: no EDM components given."
  let sms :: [Either [Char] SubstitutionModel]
sms = (EDMComponent -> Either [Char] SubstitutionModel)
-> [EDMComponent] -> [Either [Char] SubstitutionModel]
forall a b. (a -> b) -> [a] -> [b]
map (\EDMComponent
c -> Normalize
-> [Char]
-> Maybe Params
-> Maybe (Vector R)
-> Either [Char] SubstitutionModel
assembleSubstitutionModel Normalize
subNz [Char]
n Maybe Params
mps (Vector R -> Maybe (Vector R)
forall a. a -> Maybe a
Just (Vector R -> Maybe (Vector R)) -> Vector R -> Maybe (Vector R)
forall a b. (a -> b) -> a -> b
$ EDMComponent -> Vector R
forall a b. (a, b) -> b
snd EDMComponent
c)) [EDMComponent]
cs
      edmName :: [Char]
edmName = [Char]
"EDM" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([EDMComponent] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EDMComponent]
cs)
      ws :: Params
ws = Params -> Maybe Params -> Params
forall a. a -> Maybe a -> a
fromMaybe ((EDMComponent -> R) -> [EDMComponent] -> Params
forall a b. (a -> b) -> [a] -> [b]
map EDMComponent -> R
forall a b. (a, b) -> a
fst [EDMComponent]
cs) Maybe Params
mws
      errs :: [[Char]]
errs = [[Char]
e | (Left [Char]
e) <- [Either [Char] SubstitutionModel]
sms]
  Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Either [Char] SubstitutionModel] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either [Char] SubstitutionModel]
sms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Params -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Params
ws) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> Parser ByteString ()
forall a. HasCallStack => [Char] -> a
error [Char]
"edmModel: number of substitution models and weights differs."
  if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
errs
    then [Char] -> Parser MixtureModel
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser MixtureModel) -> [Char] -> Parser MixtureModel
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
errs
    else
      MixtureModel -> Parser MixtureModel
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (MixtureModel -> Parser MixtureModel)
-> MixtureModel -> Parser MixtureModel
forall a b. (a -> b) -> a -> b
$
        [Char]
-> Normalize
-> Vector R
-> Vector SubstitutionModel
-> MixtureModel
M.fromSubstitutionModels [Char]
edmName Normalize
mmNz (Params -> Vector R
forall a. [a] -> Vector a
V.fromList Params
ws) ([SubstitutionModel] -> Vector SubstitutionModel
forall a. [a] -> Vector a
V.fromList ([SubstitutionModel] -> Vector SubstitutionModel)
-> [SubstitutionModel] -> Vector SubstitutionModel
forall a b. (a -> b) -> a -> b
$ [Either [Char] SubstitutionModel] -> [SubstitutionModel]
forall a b. [Either a b] -> [b]
rights [Either [Char] SubstitutionModel]
sms)
  where
    (Normalize
subNz, Normalize
mmNz) = case MixtureModelGlobalNormalization
nz of
      MixtureModelGlobalNormalization
GlobalNormalization -> (Normalize
S.DoNotNormalize, Normalize
S.DoNormalize)
      MixtureModelGlobalNormalization
LocalNormalization -> (Normalize
S.DoNormalize, Normalize
S.DoNotNormalize)

cxxModel :: MixtureModelGlobalNormalization -> Maybe [M.Weight] -> Parser M.MixtureModel
cxxModel :: MixtureModelGlobalNormalization
-> Maybe Params -> Parser MixtureModel
cxxModel MixtureModelGlobalNormalization
LocalNormalization Maybe Params
_ = [Char] -> Parser MixtureModel
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Local normalization impossible with CXX models."
cxxModel MixtureModelGlobalNormalization
_ Maybe Params
mws = do
  Char
_ <- Char -> Parser Char
char Char
'C'
  Int
n <- Parser Int
forall a. Integral a => Parser a
decimal :: Parser Int
  MixtureModel -> Parser MixtureModel
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (MixtureModel -> Parser MixtureModel)
-> MixtureModel -> Parser MixtureModel
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Params -> MixtureModel
cxx Int
n Maybe Params
mws

standardMixtureModel :: MixtureModelGlobalNormalization -> [M.Weight] -> Parser M.MixtureModel
standardMixtureModel :: MixtureModelGlobalNormalization -> Params -> Parser MixtureModel
standardMixtureModel MixtureModelGlobalNormalization
nz Params
ws = do
  ByteString
_ <- ByteString -> Parser ByteString ByteString
string ByteString
"MIXTURE"
  Char
_ <- Char -> Parser Char
char Char
mmStart
  [SubstitutionModel]
sms <- Normalize -> Parser SubstitutionModel
parseSubstitutionModel Normalize
subNz Parser SubstitutionModel
-> Parser Char -> Parser ByteString [SubstitutionModel]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser Char
char Char
separator
  Char
_ <- Char -> Parser Char
char Char
mmEnd
  -- XXX: The use of `Data.List.NonEmpty.fromList` leads to uninformative error messages.
  MixtureModel -> Parser MixtureModel
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (MixtureModel -> Parser MixtureModel)
-> MixtureModel -> Parser MixtureModel
forall a b. (a -> b) -> a -> b
$ [Char]
-> Normalize
-> Vector R
-> Vector SubstitutionModel
-> MixtureModel
M.fromSubstitutionModels [Char]
"MIXTURE" Normalize
mmNz (Params -> Vector R
forall a. [a] -> Vector a
V.fromList Params
ws) ([SubstitutionModel] -> Vector SubstitutionModel
forall a. [a] -> Vector a
V.fromList [SubstitutionModel]
sms)
  where
    (Normalize
subNz, Normalize
mmNz) = case MixtureModelGlobalNormalization
nz of
      MixtureModelGlobalNormalization
GlobalNormalization -> (Normalize
S.DoNotNormalize, Normalize
S.DoNormalize)
      MixtureModelGlobalNormalization
LocalNormalization -> (Normalize
S.DoNormalize, Normalize
S.DoNotNormalize)

mixtureModel :: MixtureModelGlobalNormalization -> Maybe [EDMComponent] -> Maybe [M.Weight] -> Parser M.MixtureModel
mixtureModel :: MixtureModelGlobalNormalization
-> Maybe [EDMComponent] -> Maybe Params -> Parser MixtureModel
mixtureModel MixtureModelGlobalNormalization
nz Maybe [EDMComponent]
Nothing Maybe Params
Nothing = Parser MixtureModel -> Parser MixtureModel
forall i a. Parser i a -> Parser i a
try (MixtureModelGlobalNormalization
-> Maybe Params -> Parser MixtureModel
cxxModel MixtureModelGlobalNormalization
nz Maybe Params
forall a. Maybe a
Nothing) Parser MixtureModel -> Parser MixtureModel -> Parser MixtureModel
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> Parser MixtureModel
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"No weights provided."
mixtureModel MixtureModelGlobalNormalization
nz Maybe [EDMComponent]
Nothing mws :: Maybe Params
mws@(Just Params
ws) = Parser MixtureModel -> Parser MixtureModel
forall i a. Parser i a -> Parser i a
try (MixtureModelGlobalNormalization
-> Maybe Params -> Parser MixtureModel
cxxModel MixtureModelGlobalNormalization
nz Maybe Params
mws) Parser MixtureModel -> Parser MixtureModel -> Parser MixtureModel
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MixtureModelGlobalNormalization -> Params -> Parser MixtureModel
standardMixtureModel MixtureModelGlobalNormalization
nz Params
ws
mixtureModel MixtureModelGlobalNormalization
nz (Just [EDMComponent]
cs) Maybe Params
mws = MixtureModelGlobalNormalization
-> [EDMComponent] -> Maybe Params -> Parser MixtureModel
edmModel MixtureModelGlobalNormalization
nz [EDMComponent]
cs Maybe Params
mws

-- | Parse the phylogenetic model string. The argument list is somewhat long,
-- but models can have many parameters and we have to check for redundant
-- parameters.
--
-- @
-- getPhyloModel maybeSubstitutionModelString maybeMixtureModelString maybeEDMComponents
-- @
getPhyloModel ::
  Maybe String ->
  Maybe String ->
  MixtureModelGlobalNormalization ->
  Maybe [M.Weight] ->
  Maybe [EDMComponent] ->
  Either String P.PhyloModel
getPhyloModel :: Maybe [Char]
-> Maybe [Char]
-> MixtureModelGlobalNormalization
-> Maybe Params
-> Maybe [EDMComponent]
-> Either [Char] PhyloModel
getPhyloModel Maybe [Char]
Nothing Maybe [Char]
Nothing MixtureModelGlobalNormalization
_ Maybe Params
_ Maybe [EDMComponent]
_ = [Char] -> Either [Char] PhyloModel
forall a b. a -> Either a b
Left [Char]
"No model was given. See help."
getPhyloModel (Just [Char]
_) (Just [Char]
_) MixtureModelGlobalNormalization
_ Maybe Params
_ Maybe [EDMComponent]
_ =
  [Char] -> Either [Char] PhyloModel
forall a b. a -> Either a b
Left [Char]
"Both, substitution and mixture model string given; use only one."
getPhyloModel (Just [Char]
s) Maybe [Char]
Nothing MixtureModelGlobalNormalization
nz Maybe Params
Nothing Maybe [EDMComponent]
Nothing
  | MixtureModelGlobalNormalization
nz MixtureModelGlobalNormalization
-> MixtureModelGlobalNormalization -> Bool
forall a. Eq a => a -> a -> Bool
== MixtureModelGlobalNormalization
GlobalNormalization = [Char] -> Either [Char] PhyloModel
forall a b. a -> Either a b
Left [Char]
"Global normalization not possible for substitution models."
  | Bool
otherwise = PhyloModel -> Either [Char] PhyloModel
forall a b. b -> Either a b
Right (PhyloModel -> Either [Char] PhyloModel)
-> PhyloModel -> Either [Char] PhyloModel
forall a b. (a -> b) -> a -> b
$ SubstitutionModel -> PhyloModel
P.SubstitutionModel (SubstitutionModel -> PhyloModel)
-> SubstitutionModel -> PhyloModel
forall a b. (a -> b) -> a -> b
$ Parser SubstitutionModel -> [Char] -> SubstitutionModel
forall a. Parser a -> [Char] -> a
parseStringWith (Normalize -> Parser SubstitutionModel
parseSubstitutionModel Normalize
S.DoNormalize) [Char]
s
getPhyloModel (Just [Char]
_) Maybe [Char]
Nothing MixtureModelGlobalNormalization
_ (Just Params
_) Maybe [EDMComponent]
_ =
  [Char] -> Either [Char] PhyloModel
forall a b. a -> Either a b
Left [Char]
"Weights given; but cannot be used with substitution model."
getPhyloModel (Just [Char]
_) Maybe [Char]
Nothing MixtureModelGlobalNormalization
_ Maybe Params
_ (Just [EDMComponent]
_) =
  let msg1 :: [Char]
msg1 = [Char]
"Empirical distribution mixture model components given;"
      msg2 :: [Char]
msg2 = [Char]
" but cannot be used with substitution model."
   in [Char] -> Either [Char] PhyloModel
forall a b. a -> Either a b
Left ([Char] -> Either [Char] PhyloModel)
-> [Char] -> Either [Char] PhyloModel
forall a b. (a -> b) -> a -> b
$ [Char]
msg1 [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msg2
getPhyloModel Maybe [Char]
Nothing (Just [Char]
m) MixtureModelGlobalNormalization
nz Maybe Params
mws Maybe [EDMComponent]
mcs =
  PhyloModel -> Either [Char] PhyloModel
forall a b. b -> Either a b
Right (PhyloModel -> Either [Char] PhyloModel)
-> PhyloModel -> Either [Char] PhyloModel
forall a b. (a -> b) -> a -> b
$ MixtureModel -> PhyloModel
P.MixtureModel (MixtureModel -> PhyloModel) -> MixtureModel -> PhyloModel
forall a b. (a -> b) -> a -> b
$ Parser MixtureModel -> [Char] -> MixtureModel
forall a. Parser a -> [Char] -> a
parseStringWith (MixtureModelGlobalNormalization
-> Maybe [EDMComponent] -> Maybe Params -> Parser MixtureModel
mixtureModel MixtureModelGlobalNormalization
nz Maybe [EDMComponent]
mcs Maybe Params
mws) [Char]
m