module ELynx.Data.MarkovProcess.MixtureModel
(
Weight,
Component (weight, substModel),
MixtureModel (name, alphabet, components),
getWeights,
getSubstitutionModels,
fromSubstitutionModels,
concatenate,
scale,
normalize,
appendNameComponents,
)
where
import qualified Data.List.NonEmpty as N
import Data.Semigroup
import ELynx.Data.Alphabet.Alphabet hiding (all)
import qualified ELynx.Data.MarkovProcess.SubstitutionModel as S
import Prelude
type Weight = Double
data Component = Component
{ weight :: Weight,
substModel :: S.SubstitutionModel
}
deriving (Show, Read)
data MixtureModel = MixtureModel
{
name :: S.Name,
alphabet :: Alphabet,
components :: N.NonEmpty Component
}
deriving (Show, Read)
getWeights :: MixtureModel -> N.NonEmpty Weight
getWeights = N.map weight . components
getSubstitutionModels :: MixtureModel -> N.NonEmpty S.SubstitutionModel
getSubstitutionModels = N.map substModel . components
fromSubstitutionModels ::
S.Name -> N.NonEmpty Weight -> N.NonEmpty S.SubstitutionModel -> MixtureModel
fromSubstitutionModels n ws sms =
if allEqual $ N.toList alphs
then MixtureModel n (N.head alphs) comps
else
error
"fromSubstitutionModels: alphabets of substitution models are not equal."
where
comps = N.zipWith Component ws sms
alphs = N.map S.alphabet sms
allEqual [] = True
allEqual xs = all (== head xs) $ tail xs
concatenate :: S.Name -> N.NonEmpty MixtureModel -> MixtureModel
concatenate n mms = fromSubstitutionModels n ws sms
where
comps = sconcat $ N.map components mms
ws = N.map weight comps
sms = N.map substModel comps
scaleComponent :: Double -> Component -> Component
scaleComponent s c = c {substModel = s'} where s' = S.scale s $ substModel c
scale :: Double -> MixtureModel -> MixtureModel
scale s m = m {components = cs'}
where
cs = components m
cs' = N.map (scaleComponent s) cs
normalize :: MixtureModel -> MixtureModel
normalize mm = scale (1 / c) mm
where
c = sum $ N.zipWith (*) weights scales
weights = getWeights mm
scales = N.map S.totalRate $ getSubstitutionModels mm
appendNameComponent :: S.Name -> Component -> Component
appendNameComponent n c = c {substModel = s'}
where
s' = S.appendName n $ substModel c
appendNameComponents :: S.Name -> MixtureModel -> MixtureModel
appendNameComponents n m = m {components = cs'}
where
cs = components m
cs' = N.map (appendNameComponent n) cs