diff --git a/Biobase/Primary/Nuc/DNA.hs b/Biobase/Primary/Nuc/DNA.hs --- a/Biobase/Primary/Nuc/DNA.hs +++ b/Biobase/Primary/Nuc/DNA.hs @@ -46,11 +46,11 @@ letterChar = dnaChar charLetter = charDNA -instance (LetterChar DNA) => ToJSON (Primary DNA) where - toJSON = toJSON . VU.toList . VU.map letterChar - -instance (MkPrimary (VU.Vector Char) DNA) => FromJSON (Primary DNA) where - parseJSON = fmap (primary :: String -> Primary DNA) . parseJSON +--instance (LetterChar DNA) => ToJSON (Primary DNA) where +-- toJSON = toJSON . VU.toList . VU.map letterChar +-- +--instance (MkPrimary (VU.Vector Char) DNA) => FromJSON (Primary DNA) where +-- parseJSON = fmap (primary :: String -> Primary DNA) . parseJSON acgt :: [Letter DNA] acgt = [A .. T] diff --git a/Biobase/Primary/Nuc/XNA.hs b/Biobase/Primary/Nuc/XNA.hs --- a/Biobase/Primary/Nuc/XNA.hs +++ b/Biobase/Primary/Nuc/XNA.hs @@ -49,11 +49,11 @@ letterChar = xnaChar charLetter = charXNA -instance (LetterChar XNA) => ToJSON (Primary XNA) where - toJSON = toJSON . VU.toList . VU.map letterChar - -instance (MkPrimary (VU.Vector Char) XNA) => FromJSON (Primary XNA) where - parseJSON = fmap (primary :: String -> Primary XNA) . parseJSON +--instance (LetterChar XNA) => ToJSON (Primary XNA) where +-- toJSON = toJSON . VU.toList . VU.map letterChar +-- +--instance (MkPrimary (VU.Vector Char) XNA) => FromJSON (Primary XNA) where +-- parseJSON = fmap (primary :: String -> Primary XNA) . parseJSON charXNA = toUpper >>> \case 'A' -> A diff --git a/Biobase/Secondary/Diagrams.hs b/Biobase/Secondary/Diagrams.hs --- a/Biobase/Secondary/Diagrams.hs +++ b/Biobase/Secondary/Diagrams.hs @@ -20,6 +20,7 @@ import GHC.Generics import qualified Data.Vector.Unboxed as VU import Text.Printf +import Control.DeepSeq import Biobase.Primary.Nuc import Biobase.Secondary.Basepair @@ -31,7 +32,7 @@ -- paired if @unD1S VU.! k >=0 0@ Unpaired status is @-1@. newtype D1Secondary = D1S {unD1S :: VU.Vector Int} - deriving (Read,Show,Eq,Generic) + deriving (Read,Show,Eq,Generic,NFData) instance Binary D1Secondary instance Serialize D1Secondary @@ -264,4 +265,28 @@ t' = either error id . dotBracket2pairlist ["()"] $ t ss = if sPairs then s' \\ t' else [] tt = if tPairs then t' \\ s' else [] + +-- | Calculate the distance between two 'D1Secondary' structures, that live +-- in the same underlying space. In particular, this probably only works +-- for structures on the same primary sequence. +-- +-- This function assumes somewhat dense structures, as it is @O(2n)@ with +-- @n@ the length of the underlying vectors. +-- +-- @(i,k)@ vs @(j,l)@ +-- +-- TODO error out on weird inputs! + +d1Distance :: D1Secondary -> D1Secondary -> Int +d1Distance (D1S x) (D1S y) +-- | VU.length x /= VU.length y = error "d1Distance called on vectors with differing lengths!" + | otherwise = (`div` 2) . VU.sum $ VU.zipWith chk (x VU.++ xx) (y VU.++ yy) + where xx = VU.replicate (VU.length y - VU.length x) (-2) + yy = VU.replicate (VU.length x - VU.length y) (-2) + chk i j | i==j = 0 + | i < 0 && j < 0 = 0 + | i >= 0 && j >= 0 = 2 + | otherwise = 1 + {-# Inline chk #-} +{-# NoInline d1Distance #-} diff --git a/BiobaseXNA.cabal b/BiobaseXNA.cabal --- a/BiobaseXNA.cabal +++ b/BiobaseXNA.cabal @@ -1,25 +1,25 @@ name: BiobaseXNA -version: 0.9.3.0 +version: 0.9.3.1 author: Christian Hoener zu Siederdissen maintainer: choener@bioinf.uni-leipzig.de homepage: https://github.com/choener/BiobaseXNA bug-reports: https://github.com/choener/BiobaseXNA/issues -copyright: Christian Hoener zu Siederdissen, 2011 - 2015 +copyright: Christian Hoener zu Siederdissen, 2011 - 2017 category: Bioinformatics synopsis: Efficient RNA/DNA representations license: GPL-3 license-file: LICENSE build-type: Simple stability: experimental -tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 7.10.3, GHC == 8.0.1 cabal-version: >= 1.10.0 description: This is a base library for bioinformatics with emphasis on RNA and DNA primary structure as well as amino acid sequences. . - Provided are efficient encodings for short sequences, as - required by RNA folding tools. Extended RNA secondary - structures can be represented as well. + Provided are efficient encodings for short (limited by the + amount of RAM) sequences, as required by RNA folding tools. + Extended RNA secondary structures can be represented as well. . Contains data from: . @@ -48,28 +48,29 @@ library build-depends: base >= 4.7 && < 5.0 - , aeson >= 0.8 && < 1.1 - , binary >= 0.7 && < 0.8 - , bytes >= 0.15 && < 0.16 - , bytestring >= 0.10 && < 0.11 - , cereal >= 0.4 && < 0.6 - , cereal-vector >= 0.2 && < 0.3 - , containers >= 0.5 && < 0.6 - , csv >= 0.1 && < 0.2 - , deepseq >= 1.3 && < 1.5 - , file-embed >= 0.0.8 && < 0.1 - , hashable >= 1.2 && < 1.3 - , lens >= 4.0 && < 5.0 - , primitive >= 0.5 && < 0.7 - , split >= 0.2 && < 0.3 - , text >= 1.0 && < 1.3 - , tuple >= 0.3 && < 0.4 - , vector >= 0.10 && < 0.12 - , vector-binary-instances >= 0.2 && < 0.3 - , vector-th-unbox >= 0.2 && < 0.3 + , aeson >= 0.8 + , binary >= 0.7 + , bytes >= 0.15 + , bytestring >= 0.10 + , cereal >= 0.4 + , cereal-vector >= 0.2 + , containers >= 0.5 + , csv >= 0.1 + , deepseq >= 1.3 + , file-embed >= 0.0.8 + , hashable >= 1.2 + , lens >= 4.0 + , primitive >= 0.5 + , QuickCheck >= 2.7 + , split >= 0.2 + , text >= 1.0 + , tuple >= 0.3 + , vector >= 0.10 + , vector-binary-instances >= 0.2 + , vector-th-unbox >= 0.2 -- , bimaps == 0.1.0.* - , PrimitiveArray == 0.7.1.* + , PrimitiveArray == 0.8.0.* exposed-modules: Biobase.Primary Biobase.Primary.AA @@ -118,7 +119,7 @@ executable SubOptDistance build-depends: base , BiobaseXNA - , cmdargs >= 0.10 && < 0.11 + , cmdargs >= 0.10 main-is: SubOptDistance.hs hs-source-dirs: @@ -131,6 +132,30 @@ , ScopedTypeVariables ghc-options: -O2 + + + +test-suite properties + type: + exitcode-stdio-1.0 + main-is: + properties.hs + ghc-options: + -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: + tests + default-language: + Haskell2010 + default-extensions: TemplateHaskell + , ScopedTypeVariables + build-depends: base + , QuickCheck >= 2.7 + , tasty >= 0.11 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 + , vector + -- + , BiobaseXNA diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +0.9.3.1 +------- + +- removed upper version bounds, bumped dependent versions +- added d1Distance for fast basepair distance calculations + 0.9.3.0 ------- diff --git a/tests/properties.hs b/tests/properties.hs new file mode 100644 --- /dev/null +++ b/tests/properties.hs @@ -0,0 +1,116 @@ + +module Main where + +import Control.Monad (join) +import Data.Bits +import Data.Function (on) +import Data.Int (Int16(..)) +import Data.List (groupBy,sort,permutations,nub,(\\)) +import Data.Maybe (isJust) +import Data.Word (Word) +import Debug.Trace +import qualified Data.Vector.Unboxed as VU +import Test.QuickCheck hiding ((.&.)) +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.TH + +import Biobase.Secondary.Diagrams +import Biobase.Secondary.Basepair (PairIdx) + + + +newtype ArbitrarySSTree = ASST (SSTree PairIdx ()) + deriving (Show) + +instance Arbitrary ArbitrarySSTree where + arbitrary = ASST <$> sized arbitrarySSTree + where + arbitrarySSTree m = do + Positive c <- arbitrary + cs <- go 0 (c*m) + let k = if null cs then 0 else 1 + maximum [ z | SSTree (_,z) _ _ <- cs ] + return $ SSExtern k () cs + go i j = do + Positive c <- arbitrary + Positive d <- arbitrary + if i+c+d >= j + then return [] + else do + cs <- go (i+c+1) (i+c+d) + let h = SSTree (i+c,i+c+d) () cs + ts <- go (i+c+d+1) j + return $ h:ts +{- + shrink (ASST (SSExtern k () cs)) + | null cs = [] + | otherwise = [ ASST +-} + +collectPairs (ASST (SSExtern k _ zs)) = (k, sort $ go zs) + where go [] = [] + go (SSTree (i,j) _ cs : ss) = (i,j) : go cs ++ go ss + +bld :: Int -> [PairIdx] -> D1Secondary +bld = curry mkD1S + +prop_d1Distance a@(ASST _) b@(ASST _) = d1Distance x y == k + where x = mkD1S (lx', x') + y = mkD1S (ly', y') + (lx', x') = collectPairs a + (ly', y') = collectPairs b + k = length $ (x' \\ y') ++ (y' \\ x') + +---- | Check if both the memoized version and the population enumeration +---- produce the same multisets, but maybe in different order. +---- +---- prop> \(n :: Int16) -> let b = popCount n in memoSorted b == enumSorted b +---- +-- +--prop_PopCountSet (NonZero (n' :: Int16)) = memo == enum +-- where b = popCount n +-- memo = memoSorted b +-- enum = enumSorted b +-- n = n' `mod` 12 +-- +--memoSorted, enumSorted :: Int -> [[Int]] +-- +--memoSorted b = map sort . groupBy ((==) `on` popCount) $ VU.toList $ popCntMemoInt b +--enumSorted b = map sort $ [0] : [ roll (popPermutation b) (Just $ 2^k-1) | k <- [1..b] ] +-- where roll f (Just k) = k : roll f (f k) +-- roll _ Nothing = [] +-- +--prop_lsb_Int (x :: Int) = lsbZ x == maybe (-1) id (maybeLsb x) +-- +--prop_lsb_Word (x :: Word) = lsbZ x == maybe (-1) id (maybeLsb x) +-- +--prop_OneBits_Int (x :: Int) = popCount x == length abl && and [ testBit x k | k <- abl ] +-- where abl = activeBitsL x +-- +---- Tests if we actually generate all permutations. +-- +--prop_allPermutations (a :: Int , b :: Int) = and $ zipWith cmp (sort qs) (sort $ nub ps) +-- where nbs = min a' b' -- number of 1 bits in set +-- sts = max a' b' -- set size +-- a' = a `mod` 8 -- finiteBitSize a +-- b' = b `mod` 8 -- finiteBitSize b +-- ps = permutations $ replicate (sts - nbs) False ++ replicate nbs True +-- qs = go (Just $ 2 ^ nbs - 1) +-- go :: Maybe Int -> [Int] +-- go Nothing = [] +-- go (Just k) = k : go (popPermutation sts k) +-- cmp k as = and [ if a then testBit k c else (not $ testBit k c) | (a,c) <- zip (reverse as) [0 .. ] ] +-- +---- TODO popComplement +-- +--prop_popShiftL_popShiftR (a::Word,b::Word) = s == l +-- where m = a .|. b +-- s = a .&. b +-- l = popShiftL m r +-- r = popShiftR m s + + + +main :: IO () +main = $(defaultMainGenerator) +