{-# LANGUAGE BangPatterns, OverloadedStrings, ViewPatterns #-}
module Utility ( addLengthHeader
, addMutationsHeader
, addFillerGermlines
, replaceChars
, fromEither
) where
import qualified Data.Map as M
import Data.Monoid
import qualified Data.Text as T
import Data.Fasta.Text
import TextShow
import Types
addLengthHeader :: FastaSequence -> FastaSequence
addLengthHeader fSeq = fSeq { fastaHeader = fastaHeader fSeq
<> "|"
<> (showt . T.length . fastaSeq $ fSeq)
}
addMutationsHeader :: Bool -> Field -> FastaSequence -> FastaSequence
addMutationsHeader aaFlag field fSeq =
fSeq { fastaHeader = fastaHeader fSeq
<> "|"
<> ( printMutations
. getMutations (fastaSeq germline)
. fastaSeq
$ fSeq
)
}
where
germline = if aaFlag then fromEither (translate 1 otherSeq) else otherSeq
otherSeq =
FastaSequence { fastaHeader = "", fastaSeq = getField field '|' fSeq }
printMutations :: [(Position, (Char, Char))] -> T.Text
printMutations = T.intercalate "/"
. map (\(!p, (!x, !y)) -> showt p <> T.pack ['-', x, '-', y])
getMutations :: T.Text -> T.Text -> [(Position, (Char, Char))]
getMutations xs = filter (\x -> isDiff x && noGaps x) . getDiff xs
where
isDiff (_, (!x, !y)) = x /= y
noGaps (_, !x) = not . any (flip inTuple x) $ ("-.~" :: String)
getDiff :: T.Text -> T.Text -> [(Position, (Char, Char))]
getDiff xs = zip [1..] . T.zip xs
inTuple :: (Eq a) => a -> (a, a) -> Bool
inTuple c (!x, !y) = c == x || c == y
addFillerGermlines :: [FastaSequence] -> CloneMap
addFillerGermlines = M.fromList . labelGermlines . map insertDummy
where
labelGermlines = map (\(x, (y, z)) -> ((x, y), z)) . zip [0..]
insertDummy x = (dummy, [x])
dummy = FastaSequence {fastaHeader = "filler", fastaSeq = "---"}
zipWithRetain :: (a -> a -> a) -> [a] -> [a] -> [a]
zipWithRetain _ [] [] = []
zipWithRetain _ xs [] = xs
zipWithRetain _ [] ys = ys
zipWithRetain f (x:xs) (y:ys) = f x y : zipWithRetain f xs ys
zipWithRetainText :: (Char -> Char -> Char) -> T.Text -> T.Text -> T.Text
zipWithRetainText _ (T.uncons -> Nothing) (T.uncons -> Nothing) = T.empty
zipWithRetainText _ xs (T.uncons -> Nothing) = xs
zipWithRetainText _ (T.uncons -> Nothing) ys = ys
zipWithRetainText f (T.uncons -> Just (x, xs)) (T.uncons -> Just (y, ys))
= f x y `T.cons` zipWithRetainText f xs ys
replaceChars :: Char -> T.Text -> T.Text -> T.Text
replaceChars c = zipWithRetainText changeChar
where
changeChar a b = if a == c && (not . T.isInfixOf (T.singleton b)) ".-"
then b
else a
fromEither :: Either T.Text b -> b
fromEither (Right x) = x
fromEither (Left x) = error . T.unpack $ x