{-# LANGUAGE TemplateHaskell #-}
module ELynx.Data.MarkovProcess.MixtureModel
(
Weight
, Component (Component)
, MixtureModel (MixtureModel)
, name
, getAlphabet
, getWeights
, getSubstitutionModels
, fromSubstitutionModels
, concatenate
, scale
, normalize
, appendName
, isValid
, summarizeComponent
, summarize
) where
import Control.Lens
import qualified Data.ByteString.Builder as L
import qualified Data.ByteString.Lazy.Char8 as L
import ELynx.Data.Alphabet.Alphabet
import qualified ELynx.Data.MarkovProcess.SubstitutionModel as S
import ELynx.Tools.Equality (allEqual)
type Weight = Double
data Component = Component
{ _weight :: Weight
, _substModel :: S.SubstitutionModel
}
deriving (Show, Read)
makeLenses ''Component
data MixtureModel = MixtureModel
{ _name :: S.Name
, _components :: [Component]
}
deriving (Show, Read)
makeLenses ''MixtureModel
getAlphabet :: MixtureModel -> Alphabet
getAlphabet mm = if isValid mm
then head $ mm ^.. components . traverse . substModel . S.alphabet
else error "Mixture model is invalid."
getWeights :: MixtureModel -> [Weight]
getWeights m = m ^.. components . traverse . weight
getSubstitutionModels :: MixtureModel -> [S.SubstitutionModel]
getSubstitutionModels m = m ^.. components . traverse . substModel
fromSubstitutionModels :: S.Name -> [Weight] -> [S.SubstitutionModel] -> MixtureModel
fromSubstitutionModels n ws sms = MixtureModel n comps
where comps = zipWith Component ws sms
concatenate :: S.Name -> [MixtureModel] -> MixtureModel
concatenate n mms = MixtureModel n $ concatMap (view components) mms
scale :: Double -> MixtureModel -> MixtureModel
scale s = over (components . traverse . substModel) (S.scale s)
normalize :: MixtureModel -> MixtureModel
normalize mm = scale (1/c) mm
where c = sum $ zipWith (*) weights scales
weights = getWeights mm
scales = map S.totalRate $ getSubstitutionModels mm
appendName :: S.Name -> MixtureModel -> MixtureModel
appendName n = over (components . traverse . substModel) (S.appendName n)
isValid :: MixtureModel -> Bool
isValid mm = not (null $ mm ^. components)
&& allEqual alphabets
where alphabets = mm ^.. components . traverse . substModel . S.alphabet
summarizeComponent :: Component -> [L.ByteString]
summarizeComponent mmc =
L.pack "Weight: " <> (L.toLazyByteString . L.doubleDec $ mmc ^. weight)
: S.summarize (mmc ^. substModel)
summarize :: MixtureModel -> [L.ByteString]
summarize mm =
L.pack ("Mixture model: " ++ mm ^. name ++ ".")
: concat [ L.pack ("Component " ++ show i ++ ":") : summarizeComponent c
| (i, c) <- zip [1 :: Int ..] (mm ^. components) ]