module BioInf.Keys where
import Data.Vector.Unboxed as VU hiding ((++),concatMap,length,concat,null)
import qualified Data.Vector.Unboxed as VU
import Data.List as L
import qualified Data.Map as M
import Biobase.Primary
import Biobase.Secondary
import Biobase.Secondary.Diagrams
import Data.PrimitiveArray
import Data.PrimitiveArray.Ix
import BioInf.Params as P
import BioInf.Params.Import as P
import BioInf.Params.Export as P
paramsKeys = concat
[ L.map (HairpinLength . fst) . assocs . hairpinLength $ zeroParams
, L.map (HairpinClose . fst) . assocs . hairpinClose $ zeroParams
, L.map (Stem . fst) . assocs . stem $ zeroParams
, L.map (StemTriplet . fst) . assocs . stemTriplet $ zeroParams
, L.map (InteriorLength . fst) . assocs . interiorLength $ zeroParams
, L.map (InteriorAsym . fst) . assocs . interiorAsym $ zeroParams
, L.map (InteriorClose . fst) . assocs . interiorClose $ zeroParams
, L.map (BulgeLength . fst) . assocs . bulgeLength $ zeroParams
, L.map (BulgeTriplet . fst) . assocs . bulgeTriplet $ zeroParams
, L.map (BulgeClose . fst) . assocs . bulgeClose $ zeroParams
, L.map (MbClose . fst) . assocs . mbClose $ zeroParams
, [ MultiBranched, MultiHelix, MultiUnpaired ]
, L.map (PairDistance . fst) . assocs . pairDistance $ zeroParams
, [ InterMolInit ]
]
data Keys
= HairpinLength Int
| HairpinClose (ExtPair,Nuc,Nuc)
| Stem (ExtPair,ExtPair)
| StemTriplet (ExtPair,ExtPair)
| InteriorLength Int
| InteriorAsym Int
| InteriorClose (ExtPair,Nuc,Nuc)
| BulgeLength Int
| BulgeTriplet (ExtPair,ExtPair)
| BulgeClose ExtPair
| MbClose (ExtPair,Nuc,Nuc)
| MultiBranched
| MultiHelix
| MultiUnpaired
| PairDistance Int
| InterMolInit
deriving (Read,Show,Eq,Ord)
featureVector :: String -> [ExtPairIdx] -> [Int]
featureVector inp xs = ys where
ys = L.map lookupFeatureIndex tr
tr = treeToFeatures inp $ ssTree (length inp) xs
lookupFeatureIndex :: Keys -> Int
lookupFeatureIndex k
| Just v <- k `M.lookup` kvs = v
| otherwise = error $ show ("key unknown: ", k)
where
kvs = M.fromList $ L.zip paramsKeys [0..]
vks = M.fromList $ L.zip [0 ::Int ..] paramsKeys
treeToFeatures :: (MkPrimary a, Show a) => a -> SSTree ExtPairIdx t -> [Keys]
treeToFeatures inp = f where
pri = mkPrimary inp
swap23 (a,b,c) = (a,c,b)
vuIndex xs k = if k<0 || k>= VU.length xs then error (show (inp,k)) else xs VU.! k
n = VU.length pri 1
f (SSExt n _ xs) = concatMap f xs
f (SSTree ((i,j),ijExt) _ xs)
| null xs
, let is = VU.length . VU.filter (==nIMI) . VU.take (ji) . VU.drop i $ pri
, is > 0
= L.replicate is InterMolInit
| null xs
, ji1<=P.maxLength
, ji>=3
= [ HairpinLength (ji1)
, HairpinClose (((nI,nJ),ijExt),nIp1,nJm1)
]
| [SSTree ((k,l),klExt) _ _] <- xs
, let nK = pri `vuIndex` k; nL = pri `vuIndex` l
, i+1==k && j1==l
= [ Stem (((nI,nJ),ijExt),((nL,nK),swap23 klExt))
] ++ concatMap f xs
| [SSTree ((k,l),klExt) _ _] <- xs
, let lenI = ki1; lenJ = jl1; len = lenI+lenJ
, lenI>=1 && lenJ>=1 && len<=P.maxLength
, let nL = pri `vuIndex` l; nK = pri `vuIndex` k; lkExt = swap23 klExt
, let nLm1 = pri `vuIndex` (l1); nKp1 = pri `vuIndex` (k+1)
, let nLp1 = pri `vuIndex` (l+1); nKm1 = pri `vuIndex` (k1)
= [ InteriorClose (((nI,nJ),ijExt),nIp1,nJm1)
, InteriorLength len
, InteriorAsym $ abs (lenIlenJ)
, InteriorClose (((nL,nK),lkExt),nLp1,nKm1)
] ++ concatMap f xs
| [SSTree ((k,l),klExt) _ _] <- xs
, let lenI = ki1; lenJ = jl1; len = max lenI lenJ
, lenI==0 && lenJ>0 || lenJ==0 && lenI>0
, len<=P.maxLength
, let nK = pri `vuIndex` k; nL = pri `vuIndex` l; lkExt = swap23 klExt
= [ BulgeLength len
, BulgeClose ((nI,nJ),ijExt)
] ++ concatMap f xs
| length xs > 1
= [ MbClose (((nI,nJ),ijExt),nIp1,nJm1)
, MultiBranched
, MultiHelix
] ++ concat
[ [ MbClose (((nL,nK),lkExt),nLp1,nKm1)
, MultiHelix ]
| SSTree ((k,l),klExt) _ _ <- xs
, k>0 && l<n
, let nK = pri `vuIndex` k; nL = pri `vuIndex` l
, let nKm1 = pri `vuIndex` (k1); nLp1 = pri `vuIndex` (l+1)
, let lkExt = swap23 klExt
] ++ concatMap f xs
| otherwise = concatMap f xs
where
nI = pri `vuIndex` i
nJ = pri `vuIndex` j
nIp1 = pri `vuIndex` (i+1)
nJm1 = pri `vuIndex` (j1)
jiExt = swap23 ijExt
ssTree :: Int -> [ExtPairIdx] -> SSTree ExtPairIdx ()
ssTree n xs = d2sTree . mkD2S . (n,) . L.filter okPairs $ xs where
okPairs ((i,j),_) = ji>2