diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Udo Stenzel + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Udo Stenzel nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,61 @@ +import Distribution.PackageDescription ( PackageDescription(..) ) +import Distribution.Simple +import Distribution.Simple.InstallDirs ( docdir, mandir, CopyDest (NoCopyDest) ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), absoluteInstallDirs ) +import Distribution.Simple.Program.Db ( ProgramDb, lookupProgram ) +import Distribution.Simple.Program.Run ( runProgramInvocation, programInvocation, progInvokeCwd ) +import Distribution.Simple.Program.Types ( ConfiguredProgram, simpleProgram ) +import Distribution.Simple.Setup ( copyDest, copyVerbosity, fromFlag, installVerbosity, haddockVerbosity ) +import Distribution.Simple.Utils ( installOrdinaryFile, installOrdinaryFiles, notice ) +import Distribution.Verbosity ( Verbosity, moreVerbose ) +import System.Exit ( exitSuccess ) +import System.FilePath ( splitDirectories, joinPath, takeExtension, replaceExtension, () ) +import System.Directory ( getCurrentDirectory, setCurrentDirectory, createDirectoryIfMissing, doesFileExist ) + +main :: IO () +main = do + defaultMainWithHooks $ simpleUserHooks + { postCopy = \ _ flags pkg lbi -> + installManpages pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags) + + , postInst = \ _ flags pkg lbi -> + installManpages pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest + + , postHaddock = \ _ flags pkg lbi -> + runPdflatex pkg lbi (fromFlag $ haddockVerbosity flags) + + , hookedPrograms = [ simpleProgram "pdflatex" ] + } + exitSuccess + +installManpages :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO () +installManpages pkg lbi verbosity copy = do + installOrdinaryFiles verbosity (mandir (absoluteInstallDirs pkg lbi copy)) + [ ("man", joinPath mp) | ("man":mp) <- map splitDirectories $ extraSrcFiles pkg ] + + installOrdinaryFiles' verbosity (docdir (absoluteInstallDirs pkg lbi copy)) + [ (buildDir lbi "latex", replaceExtension (last p) "pdf") + | ("doc":p@(_:_)) <- map splitDirectories $ extraSrcFiles pkg + , takeExtension (last p) == ".tex" ] + +installOrdinaryFiles' :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +installOrdinaryFiles' verb dest = mapM_ (uncurry go) + where + go base src = do e <- doesFileExist (base src) + if e then installOrdinaryFile verb (base src) (dest src) + else notice verb $ show (base src) ++ " was not built, can't install." + +withLatex :: LocalBuildInfo -> (ConfiguredProgram -> IO ()) -> IO () +withLatex lbi k = maybe (return ()) k $ lookupProgram (simpleProgram "pdflatex") $ withPrograms lbi + +runPdflatex :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +runPdflatex pkg lbi verb = + withLatex lbi $ \cmd -> do + cwd <- getCurrentDirectory + createDirectoryIfMissing True (buildDir lbi "latex") + sequence_ [ runProgramInvocation (moreVerbose verb) $ + (programInvocation cmd [ "-interaction=nonstopmode", cwd joinPath ("doc":f) ]) + { progInvokeCwd = Just (buildDir lbi "latex") } + | ("doc":f@(_:_)) <- map splitDirectories $ extraSrcFiles pkg + , takeExtension (last f) == ".tex" ] + diff --git a/biohazard.cabal b/biohazard.cabal new file mode 100644 --- /dev/null +++ b/biohazard.cabal @@ -0,0 +1,311 @@ +Name: biohazard +Version: 0.6.1 +Synopsis: bioinformatics support library +Description: This is a collection of modules I separated from + various bioinformatics tools. The hope is to make + them reusable and easier to maintain. Also includes + some of these tools and a bunch that work on mitochondrial + sequences. +Category: Bioinformatics + +Homepage: http://github.com/udo-stenzel/biohazard +License: BSD3 +License-File: LICENSE + +Author: Udo Stenzel +Maintainer: udo.stenzel@eva.mpg.de +Copyright: (C) 2010-2015 Udo Stenzel + +Extra-Source-Files: man/man7/biohazard.7 + man/man1/bam-meld.1 + man/man1/bam-rewrap.1 + man/man1/bam-rmdup.1 + man/man1/jivebunny.1 + man/man1/mt-anno.1 + doc/genotyping.tex + +Data-Files: index_db.json +Data-Dir: data + +Cabal-version: >=1.9.2 +Build-type: Custom + +source-repository head + type: git + location: git://github.com/udo-stenzel/biohazard.git + +source-repository this + type: git + location: git://github.com/udo-stenzel/biohazard.git + tag: 0.6.1 + + +Library + Exposed-modules: Bio.Base, + Bio.Align, + Bio.Bam, + Bio.Bam.Evan, + Bio.Bam.Fastq, + Bio.Bam.Filter, + Bio.Bam.Header, + Bio.Bam.Index, + Bio.Bam.Pileup, + Bio.Bam.Regions, + Bio.Bam.Reader + Bio.Bam.Rec, + Bio.Bam.Rmdup, + Bio.Bam.Trim, + Bio.Bam.Writer, + Bio.Genocall, + Bio.Genocall.Adna, + Bio.Genocall.AvroFile, + Bio.Glf, + Bio.Iteratee, + Bio.Iteratee.Bgzf, + Bio.Iteratee.Builder, + Bio.Iteratee.ZLib, + Bio.PriorityQueue, + Bio.TwoBit, + Bio.Util, + Data.Avro + + Other-modules: Paths_biohazard + + Build-depends: aeson >= 0.7 && < 0.9, + array >= 0.4 && < 0.6, + async == 2.0.*, + attoparsec >= 0.10 && < 0.13, + base >= 4.5 && < 4.9, + binary >= 0.7 && < 0.8, + bytestring >= 0.10.2 && < 0.11, + bytestring-mmap >= 0.2 && < 1.0, + containers >= 0.4.1 && < 0.6, + directory >= 1.2 && < 2.0, + exceptions >= 0.6 && < 0.9, + filepath >= 1.3 && < 2.0, + iteratee >= 0.8.9.6 && < 0.8.10, + ListLike >= 3.0 && < 5.0, + primitive >= 0.5 && < 0.7, + random >= 1.0 && < 1.2, + scientific == 0.3.*, + stm == 2.4.*, + template-haskell == 2.*, + text >= 1.0 && < 2.0, + transformers >= 0.3 && < 0.5, + unix == 2.*, + unordered-containers >= 0.2.3 && < 0.3, + Vec == 1.*, + vector >= 0.9 && < 0.11, + vector-algorithms >= 0.3 && < 1.0, + vector-th-unbox == 0.2.*, + zlib >= 0.5 && < 0.7 + + Ghc-options: -Wall -auto-all + Hs-source-dirs: src + Include-dirs: src/cbits + C-sources: src/cbits/myers_align.c + CC-options: -fPIC + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + +-- Test-Suite test-biohazard + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + -- Type: exitcode-stdio-1.0 + -- Main-is: test-biohazard.hs + +Executable afroengineer + Main-Is: afroengineer.hs + Hs-source-dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Other-Modules: Align, SimpleSeed + Build-Depends: base, + biohazard, + bytestring, + containers, + directory, + iteratee, + unordered-containers, + vector + +Executable bam-fixpair + Main-is: bam-fixpair.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + binary, + biohazard, + bytestring, + hashable >= 1.0 && < 1.3, + transformers + +Executable bam-meld + Main-is: bam-meld.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + biohazard, + bytestring, + containers + +Executable bam-resample + Main-is: bam-resample.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + biohazard, + bytestring, + random + +Executable bam-rewrap + Main-is: bam-rewrap.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + biohazard, + bytestring, + containers + +Executable bam-rmdup + Main-is: bam-rmdup.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + biohazard, + bytestring, + containers, + iteratee, + unordered-containers, + vector, + vector-algorithms + +Executable bam-trim + Main-is: bam-trim.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + biohazard, + bytestring + +Executable count-coverage + Main-is: count-coverage.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + biohazard, + iteratee + +Executable dmg-est + Main-is: dmg-est.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Other-Modules: AD + Build-depends: async, + base, + biohazard, + nonlinear-optimization == 0.3.*, + vector + +Executable fastq2bam + Main-is: fastq2bam.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + biohazard, + bytestring, + containers, + iteratee, + vector + +Executable glf-consensus + Main-is: glf-consensus.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + biohazard, + bytestring, + containers, + exceptions, + iteratee + +Executable gt-call + Main-is: gt-call.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + biohazard, + bytestring, + deepseq, + iteratee, + text, + vector + +Executable jivebunny + Main-is: jivebunny.hs + Hs-Source-Dirs: tools + C-sources: src/cbits/jive.c + CC-options: -std=c99 -ffast-math + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Other-modules: Index + Build-depends: aeson, + base, + biohazard, + bytestring, + containers, + directory, + hashable >= 1.0 && < 1.3, + random, + text, + transformers, + unordered-containers, + vector, + vector-algorithms, + vector-th-unbox + +Executable mt-anno + Main-Is: mt-anno.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Other-Modules: Anno, Seqs, Xlate + Build-Depends: base, + bytestring, + biohazard, + containers + +Executable mt-ccheck + Main-Is: mt-ccheck.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-Depends: base, + bytestring, + biohazard, + containers, + unordered-containers + +executable wiggle-coverage + Main-is: wiggle-coverage.hs + Hs-Source-Dirs: tools + -- Ghc-options: -Wall -auto-all -threaded -rtsopts -with-rtsopts=-N + Ghc-options: -Wall -auto-all -rtsopts + Build-depends: base, + biohazard + +-- :vim:tw=132: diff --git a/data/index_db.json b/data/index_db.json new file mode 100644 --- /dev/null +++ b/data/index_db.json @@ -0,0 +1,573 @@ +{ + "p5index": { + "is4": "AGATCTC", + + "PhiA": "AAAAAAAA", + "PhiC": "CCCCCCCC", + "PhiG": "GGGGGGGG", + "PhiT": "TTTTTTTT", + + "1": "TCGCAGG", + "2": "CTCTGCA", + "3": "CCTAGGT", + "4": "GGATCAA", + "5": "GCAAGAT", + "6": "ATGGAGA", + "7": "CTCGATG", + "8": "GCTCGAA", + "9": "ACCAACT", + "10": "CCGGTAC", + "11": "AACTCCG", + "12": "TTGAAGT", + "13": "ACTATCA", + "14": "TTGGATC", + "15": "CGACCTG", + "16": "TAATGCG", + "17": "AGGTACC", + "18": "TGCGTCC", + "19": "GAATCTC", + "20": "CATGCTC", + "21": "ACGCAAC", + "22": "GCATTGG", + "23": "GATCTCG", + "24": "CAATATG", + "25": "TGACGTC", + "26": "GATGCCA", + "27": "CAATTAC", + "28": "AGATAGG", + "29": "CCGATTG", + "30": "ATGCCGC", + "31": "CAGTACT", + "32": "AATAGTA", + "33": "CATCCGG", + "34": "TCATGGT", + "35": "AGAACCG", + "36": "TGGAATA", + "37": "CAGGAGG", + "38": "AATACCT", + "39": "CGAATGC", + "40": "TTCGCAA", + "41": "AATTCAA", + "42": "CGCGCAG", + "43": "AAGGTCT", + "44": "ACTGGAC", + "45": "AGCAGGT", + "46": "GTACCGG", + "47": "GGTCAAG", + "48": "AATGATG", + "49": "AGTCAGA", + "50": "AACTAGA", + "51": "CTATGGC", + "52": "CGACGGT", + "53": "AACCAAG", + "54": "CGGCGTA", + "55": "GCAGTCC", + "56": "CTCGCGC", + "57": "CTGCGAC", + "58": "ACGTATG", + "59": "ATACTGA", + "60": "TACTTAG", + "61": "AAGCTAA", + "62": "GACGGCG", + "63": "AGAAGAC", + "64": "GTCCGGC", + "65": "TCAGCTT", + "66": "AGAGCGC", + "67": "GCCTACG", + "68": "TAATCAT", + "69": "AACCTGC", + "70": "GACGATT", + "71": "TAGGCCG", + "72": "GGCATAG", + "73": "TTCAACC", + "74": "TTAACTC", + "75": "TAGTCTA", + "76": "TGCATGA", + "77": "AATAAGC", + "78": "AGCCTTG", + "79": "CCAACCT", + "80": "GCAGAAG", + "81": "AGAATTA", + "82": "CAGCATC", + "83": "TTCTAGG", + "84": "CCTCTAG", + "85": "CCGGATA", + "86": "GCCGCCT", + "87": "AACGACC", + "88": "CCAGCGG", + "89": "TAGTTCC", + "90": "TGGCAAT", + "91": "CGTATAT", + "92": "GCTAATC", + "93": "GACTTCT", + "94": "GTACTAT", + "95": "CGAGATC", + "96": "CGCAGCC", + + "502": "ATAGAGAG", + "503": "AGAGGATA", + "504": "TCTACTCT", + "505": "CTCCTTAC", + "506": "TATGCAGT", + "507": "TACTCCTT", + "508": "AGGCTTAG", + "510": "ATTAGACG", + "511": "CGGAGAGA", + "517": "TCTTACGC", + + "t1": "ATCACG", + "t2": "CGATGT", + "t3": "TTAGGC", + "t4": "TGACCA", + "t5": "ACAGTG", + "t6": "GCCAAT", + "t7": "CAGATC", + "t8": "ACTTGA", + "t9": "GATCAG", + "t10": "TAGCTT", + "t11": "GGCTAC", + "t12": "CTTGTA", + "t13": "AGTCAA", + "t14": "AGTTCC", + "t15": "ATGTCA", + "t16": "CCGTCC", + "t17": "GTAGAG", + "t18": "GTCCGC", + "t19": "GTGAAA", + "t20": "GTGGCC", + "t21": "GTTTCG", + "t22": "CGTACG", + "t23": "GAGTGG", + "t24": "GGTAGC", + "t25": "ACTGAT", + "t26": "ATGAGC", + "t27": "ATTCCT", + "t28": "CAAAAG", + "t29": "CAACTA", + "t30": "CACCGG", + "t31": "CACGAT", + "t32": "CACTCA", + "t33": "CAGGCG", + "t34": "CATGGC", + "t35": "CATTTT", + "t36": "CCAACA", + "t37": "CGGAAT", + "t38": "CTAGCT", + "t39": "CTATAC", + "t40": "CTCAGA", + "t41": "GACGAC", + "t42": "TAATCG", + "t43": "TACAGC", + "t44": "TATAAT", + "t45": "TCATTC", + "t46": "TCCCGA", + "t47": "TCGAAG", + "t48": "TCGGCA" + }, + + "p7index": { + "1": "ACAGTG", + "2": "GATCAG", + "3": "ATCACG", + "4": "CGATGT", + "5": "CTTGTA", + "6": "GGCTAC", + "7": "TGACCA", + "8": "AAAGCA", + "9": "AAATGC", + "10": "AAGCGA", + "11": "AAGGAC", + "12": "AATAGG", + "13": "ACCCAG", + "14": "ACTCTC", + "15": "AGAAGA", + "16": "AGCATC", + "17": "AGGCCG", + "18": "ATACGG", + "19": "ATCCTA", + "20": "ATCTAT", + "21": "ATGAGC", + "22": "CATTTT", + "23": "CCGCAA", + "24": "CTCAGA", + "25": "GAATAA", + "26": "GCCGCG", + "27": "GCTCCA", + "28": "GGCACA", + "29": "GGCCTG", + "30": "TCGGCA", + "31": "TCTACC", + "32": "TGCCAT", + "33": "TGCTGG", + "34": "AGGTTT", + "35": "AGTCAA", + "36": "AGTTCC", + "37": "ATGTCA", + "38": "CCGTCC", + "39": "GTAGAG", + "40": "GTGAAA", + "41": "GTGGCC", + "42": "GTTTCG", + "43": "CGTACG", + "44": "GAGTGG", + "45": "GGTAGC", + "46": "ACTTGA", + "47": "CAGATC", + "48": "GCCAAT", + "49": "TAGCTT", + "50": "TTAGGC", + "51": "AACCGCC", + "52": "AACGAAC", + "53": "AACGCCT", + "54": "AACGGTA", + "55": "AACTAGT", + "56": "AACTGAG", + "57": "AAGAATT", + "58": "AAGATAG", + "59": "AAGCTCT", + "60": "AAGTCTG", + "61": "AATAACC", + "62": "AATCCGT", + "63": "ACCGATT", + "64": "ACCGTAG", + "65": "ACCTCAT", + "66": "ACCTTGC", + "67": "ACGACCT", + "68": "ACGATTC", + "69": "ACGCGGC", + "70": "ACGGAGG", + "71": "ACGTAAC", + "72": "ACTACTG", + "73": "ACTCGTT", + "74": "ACTGCGC", + "75": "AGACCTC", + "76": "AGACTAG", + "77": "AGAGACC", + "78": "AGAGCGT", + "79": "AGATATG", + "80": "AGATTCT", + "81": "AGCAAGC", + "82": "AGCAGTT", + "83": "AGCGCTG", + "84": "AGTATAC", + "85": "ATAAGTC", + "86": "ATAATGG", + "87": "ATACTCC", + "88": "ATAGAAG", + "89": "ATCTCCG", + "90": "ATGCAGT", + "91": "ATGGTAT", + "92": "ATTATCT", + "93": "ATTCGAC", + "94": "ATTGCTA", + "95": "CAACCGG", + "96": "CAACTAA", + "97": "AATCTTC", + "98": "ACCAACG", + "99": "AGATGGC", + "100": "CCAGGTT", + "101": "CCGTTAG", + "102": "CGCCTCT", + "103": "CTTGCGG", + "104": "GGCGGAG", + "105": "TGGACGT", + "106": "AACCATG", + "107": "CAGGAAG", + "108": "CATACCT", + "109": "CCAATCC", + "110": "CCGGCGT", + "111": "CGCATAG", + "112": "CGTAATC", + "113": "CGTTGGT", + "114": "CTATACG", + "115": "GACCTAC", + "116": "GATATTG", + "117": "AAGACGC", + "118": "GCAGTAT", + "119": "GGTCCGC", + "120": "GTCGACT", + "121": "GTTAGAT", + "122": "TAACTCG", + "123": "TGCTTCC", + "124": "TGGCGCT", + "125": "AATGGCG", + "126": "ACCAGAC", + "127": "ACGCCAG", + "128": "ACTAAGT", + "129": "AGAACCG", + "130": "ATCGTTC", + "131": "CAACGTC", + "301": "TCGCAGG", + "302": "CTCTGCA", + "303": "CCTAGGT", + "304": "GGATCAA", + "305": "GCAAGAT", + "306": "ATGGAGA", + "307": "CTCGATG", + "308": "GCTCGAA", + "309": "ACCAACT", + "310": "CCGGTAC", + "311": "AACTCCG", + "312": "TTGAAGT", + "313": "ACTATCA", + "314": "TTGGATC", + "315": "CGACCTG", + "316": "TAATGCG", + "317": "AGGTACC", + "318": "TGCGTCC", + "319": "GAATCTC", + "320": "CATGCTC", + "321": "ACGCAAC", + "322": "GCATTGG", + "323": "GATCTCG", + "324": "CAATATG", + "325": "TGACGTC", + "326": "GATGCCA", + "327": "CAATTAC", + "328": "AGATAGG", + "329": "CCGATTG", + "330": "ATGCCGC", + "331": "CAGTACT", + "332": "AATAGTA", + "333": "CATCCGG", + "334": "TCATGGT", + "335": "AGAACCG", + "336": "TGGAATA", + "337": "CAGGAGG", + "338": "AATACCT", + "339": "CGAATGC", + "340": "TTCGCAA", + "341": "AATTCAA", + "342": "CGCGCAG", + "343": "AAGGTCT", + "344": "ACTGGAC", + "345": "AGCAGGT", + "346": "GTACCGG", + "347": "GGTCAAG", + "348": "AATGATG", + "349": "AGTCAGA", + "350": "AACTAGA", + "351": "CTATGGC", + "352": "CGACGGT", + "353": "AACCAAG", + "354": "CGGCGTA", + "355": "GCAGTCC", + "356": "CTCGCGC", + "357": "CTGCGAC", + "358": "ACGTATG", + "359": "ATACTGA", + "360": "TACTTAG", + "361": "AAGCTAA", + "362": "GACGGCG", + "363": "AGAAGAC", + "364": "GTCCGGC", + "365": "TCAGCTT", + "366": "AGAGCGC", + "367": "GCCTACG", + "368": "TAATCAT", + "369": "AACCTGC", + "370": "GACGATT", + "371": "TAGGCCG", + "372": "GGCATAG", + "373": "TTCAACC", + "374": "TTAACTC", + "375": "TAGTCTA", + "376": "TGCATGA", + "377": "AATAAGC", + "378": "AGCCTTG", + "379": "CCAACCT", + "380": "GCAGAAG", + "381": "AGAATTA", + "382": "CAGCATC", + "383": "TTCTAGG", + "384": "CCTCTAG", + "385": "CCGGATA", + "386": "GCCGCCT", + "387": "AACGACC", + "388": "CCAGCGG", + "389": "TAGTTCC", + "390": "TGGCAAT", + "391": "CGTATAT", + "392": "GCTAATC", + "393": "GACTTCT", + "394": "GTACTAT", + "395": "CGAGATC", + "396": "CGCAGCC", + "397": "GAGAGGC", + "398": "GCTTCAG", + "399": "ATATCCA", + "400": "GTTATAC", + "401": "CCTTAAT", + "402": "CGCCAAC", + "403": "TACTCGC", + "404": "AGCGCCA", + "405": "TAAGTAA", + "406": "TTGGTCA", + "407": "GTTGCAT", + "408": "ATCCTCT", + "409": "GGCGGTC", + "410": "ATATGAT", + "411": "GGTACGC", + "412": "AAGAACG", + "413": "CCGTTGA", + "414": "AGCAATC", + "415": "GCTCCGT", + "416": "CAACTCT", + "417": "AGACTCC", + "418": "CTATCTT", + "419": "AAGCAGT", + "420": "GTTACCG", + "421": "CCTAACG", + "422": "ATCATAA", + "423": "TGATAAC", + "424": "TCTCCTA", + "425": "CAGAGCA", + "426": "CGGCTGG", + "427": "CGCTATT", + "428": "GATCGTC", + "429": "ACGGCAG", + "430": "GACCGAT", + "431": "ACTTGCG", + "432": "GTAAGCC", + "433": "GCCATGC", + "434": "ATAACGT", + "435": "CGGACGT", + "436": "GCGAGTA", + "437": "ACGCGGA", + "438": "GTCTAAT", + "439": "GAAGCGT", + "440": "CGGTAAG", + "441": "GGTAACT", + "442": "AATATAG", + "443": "CCTCGCC", + "444": "TTAATAG", + "445": "CCGAAGC", + "446": "TCGTTAT", + "447": "GGCTCTG", + "448": "CCAAGTC", + "449": "CTTGGAA", + "450": "TGAAGCT", + "451": "GGTTGAC", + "452": "CCGCCAT", + "453": "ACCAGAG", + "454": "GCTGAGA", + "455": "CCTTCGC", + "456": "CTGGCCT", + "457": "CGCAAGG", + "458": "TGAGAGA", + "459": "AAGATTC", + "460": "ATCGGTT", + "461": "ACGAGCC", + "462": "TGGATAC", + "463": "ATTCCAG", + "464": "ACTCATT", + "465": "ACCTCGT", + "466": "AGCTTAT", + "467": "GCGATCT", + "468": "CTCCAGT", + "469": "GAACTTA", + "470": "CCAATAA", + "471": "AGGCGAG", + "472": "CTCAGAT", + "473": "AAGACGA", + "474": "ACCGCTC", + "475": "AACTGAC", + "476": "GCAACTG", + "477": "GAGTAAC", + "478": "GATTAGG", + "479": "AGTCGCT", + "480": "CATAGAC", + "481": "ACTACGG", + "482": "GGCTAGC", + "483": "CCATGAG", + "484": "GCTGGTT", + "485": "AGAGTAG", + "486": "TATCAAC", + "487": "ATACGCG", + "488": "GACGTAC", + "489": "CTACTTC", + "490": "TGGTCGG", + "491": "AGACCAT", + "492": "TCCGAAC", + + "701": "TAAGGCGA", + "702": "CGTACTAG", + "703": "AGGCAGAA", + "704": "TCCTGAGC", + "705": "GGACTCCT", + "706": "TAGGCATG", + "707": "CTCTCTAC", + "708": "CAGAGAGG", + "709": "GCTACGCT", + "710": "CGAGGCTG", + "711": "AAGAGGCA", + "712": "GTAGAGGA", + "716": "ACTCGCTA", + "718": "GGAGCTAC", + "719": "GCGTAGTA", + "720": "CGGAGCCT", + "721": "TACGCTGC", + "722": "ATGCGCAG", + "723": "TAGCGCTC", + "724": "ACTGAGCG", + "726": "CCTAAGAC", + "727": "CGATCAGT", + "728": "TGCAGCTA", + "729": "TCGACGTC", + + "PhiX": "TTGCCGC", + "PhiA": "AAAAAAAA", + "PhiC": "CCCCCCCC", + "PhiG": "GGGGGGGG", + "PhiT": "TTTTTTTT", + + "t1": "ATCACG", + "t2": "CGATGT", + "t3": "TTAGGC", + "t4": "TGACCA", + "t5": "ACAGTG", + "t6": "GCCAAT", + "t7": "CAGATC", + "t8": "ACTTGA", + "t9": "GATCAG", + "t10": "TAGCTT", + "t11": "GGCTAC", + "t12": "CTTGTA", + "t13": "AGTCAA", + "t14": "AGTTCC", + "t15": "ATGTCA", + "t16": "CCGTCC", + "t17": "GTAGAG", + "t18": "GTCCGC", + "t19": "GTGAAA", + "t20": "GTGGCC", + "t21": "GTTTCG", + "t22": "CGTACG", + "t23": "GAGTGG", + "t24": "GGTAGC", + "t25": "ACTGAT", + "t26": "ATGAGC", + "t27": "ATTCCT", + "t28": "CAAAAG", + "t29": "CAACTA", + "t30": "CACCGG", + "t31": "CACGAT", + "t32": "CACTCA", + "t33": "CAGGCG", + "t34": "CATGGC", + "t35": "CATTTT", + "t36": "CCAACA", + "t37": "CGGAAT", + "t38": "CTAGCT", + "t39": "CTATAC", + "t40": "CTCAGA", + "t41": "GACGAC", + "t42": "TAATCG", + "t43": "TACAGC", + "t44": "TATAAT", + "t45": "TCATTC", + "t46": "TCCCGA", + "t47": "TCGAAG", + "t48": "TCGGCA" + } +} diff --git a/doc/genotyping.tex b/doc/genotyping.tex new file mode 100644 --- /dev/null +++ b/doc/genotyping.tex @@ -0,0 +1,539 @@ +\documentclass{article} +\usepackage{a4} +\usepackage{amsmath} +\usepackage{todonotes} +\usepackage{xargs} + +\newcommandx{\beware}[2][1=]{\todo[nolist,noline,inline,linecolor=red,backgroundcolor=red!25,bordercolor=red,#1]{#2}} +\newcommandx{\idea}[2][1=]{\todo[nolist,noline,inline,linecolor=blue,backgroundcolor=blue!25,bordercolor=blue,#1]{#2}} +\newcommandx{\oops}[2][1=]{\todo[nolist,noline,inline,linecolor=yellow,backgroundcolor=yellow!25,bordercolor=yellow,#1]{#2}} + +\title{Deamination Aware Genotype Calling} +\author{Udo Stenzel} + +\begin{document} +\maketitle + +\section{``History'' Of Error Models} + +I tried to track down the logic behind the \texttt{samtools} and +\texttt{maq} error models, which supposedly go back to \texttt{CAP3}. +Near as I can tell, there is absolutely no reasoning behind any of it. +\texttt{CAP3} may have originated the idea of setting the probability of +$k$ errors to $p^{f(k)}$ where $f$ is a function that grows more slowly +than the identity function. The paper cited by \texttt{samtools} +doesn't actually mention any of that, though. + +\texttt{SOAPsnp}\cite{soapsnp} is the first(?) implementation of the idea. Bases are +dealt with in order of increasing(!) quality, the quality score of +observation $k$ is scaled by $\theta^k$, where $\theta$ is a constant +parameter. + +\texttt{Maq}\cite{maq} follows the same idea, but attempts some combinatorial +simplification. The derivation is rather complicated: It starts out +with a simplification (counting similar bases), then proceeds to apply +approximations (equal error rates), then ends up being incomprehensible +(weird effective error rate derived from quality scores). By that time, +it is no longer obvious whether that derivation makes any sense, and in +some cases, according to publications about +\texttt{samtools}\cite{samtools}, it +doesn't and fails catastrophically instead. + +\texttt{Samtools}\cite{samtools} improves upon the \texttt{maq} model, where the +claimed reason is that the \texttt{maq} model is ill-behaved at high +coverage and high error rate. Unfortunately, the fix in +\texttt{samtools} is only a different approximation in the last step of +an equally convoluted derivation. The chief difference seems to be that +\texttt{maq} computes a strange quantity based on a sort of average +error rate, while \texttt{samtools} deals with bases in order of +decreasing(!) quality. By that time, it's unclear that the +combinatorial contortions provide any benefit. + +The take home message is that we model error dependency by having a more +slowly growing exponent, that errors happening on different strands are +independent(?) from each other, and that the combinatorial +contortions in both the \texttt{maq} and the \texttt{samtools} model do +not seem to be useful. The order in which we touch the bases is up for +grabs, since there are two cases of prior art. We'll go with a simple +implementation like \texttt{SOAPsnp} (or more recently +\texttt{BSNP}\cite{bsnp}), which needs to be generalized for ancient +DNA. + +\section{Damage Model} + +Ancient DNA is conceptually modelled as double stranded with heavily +deaminated single stranded ends, whose lengths are distributed +geometrically. We apply the same simplification as in \cite{mapdamage}, +in that we don't try to estimate the overhang length for any molecule, +but compute an effective deamination probability for every position in a +read. + +For classically prepared ``double strand'' libraries, we get C to T +transitions near the 5' end and G to A transitions near the 3' end, and +the overhang lengths are equal. For single strand libraries, we get C +to T transitions near both ends, and the expected overhang lengths may +be different. The same models work for libraries treated with UDG. +While we cannot see the actual overhangs anymore, the overall damage +looks the same, but with much shorter overhangs. + +We can now construct a universal damage model that applies to every +library and estimate parameters for it. Let $\sigma_d$, $\delta_d$, +$\lambda_d$ be the single stranded deamination rate, the double +stranded deamination rate and the length parameter at the 5' end, +respectively, for a double stranded model. Let $\sigma_s$, $\delta_s$ +and $\lambda_s$ be the corresponding parameters for a single stranded +model, and $\kappa_s$ be the overhang length parameter at the 3' end in +a single stranded model. The probabilities that a position $i$ in a +read of length $l$ is in an overhang in a single stranded model, in a 5' +overhang, or in a 3' overhang in a double stranded model, are then: + +\begin{align*} +P_s(i|l) &= \lambda_s^{i+1} + \kappa_s^{l-i} - \lambda_s^{i+1} \kappa_s^{l-i} \\ +P_5(i|l) &= \lambda_d^{i+1} \\ +P_3(i|l) &= \lambda_d^{l-i} +\end{align*} + +From these, we compute the rates of C to T transversions and G to A transversions: + +\begin{align*} +P_{CT}(i|l) &= \sigma_s P_s(i|l) + \delta_s (1-P_s(i|l) + \sigma_d P_5(i|l) + \delta_d (1-P_5(i|l)) \\ +P_{GA}(i|l) &= \sigma_d P_3(i|l) + \delta_d (1-P_3(i|l)) +\end{align*} + +This yields the complete damage matrix used in the follwing sections: + +\begin{equation} +D_i = \left( \begin{array}{cccc} + 1 & 0 & P_{GA}(i) & 0 \\ + 0 & 1-P_{CT}(i) & 0 & 0 \\ + 0 & 0 & 1-P_{GA}(i) & 0 \\ + 0 & P_{CT}(i) & 0 & 1 + \end{array} \right) +\end{equation} + +To fit parameters to real data, we assume simple errors and no divergence. We separately fit a pure single stranded model, a pure +double stranded model, and a model without damage. At the maximum likelihood parameters, we compute the probabilities of either the +single stranded or double stranded model being correct. (For brevity, all parameters not mentioned here are assumed to be zero.) + +\begin{align*} +\hat{\sigma_s}, \hat{\delta_s}, \hat{\lambda_s}, \hat{\kappa_s} &:= \arg \max_{\sigma_s, \delta_s, \lambda_s, \kappa_s} + P(D | \sigma_s, \delta_s, \lambda_s, \kappa_s ) \\ +\hat{\sigma_d}, \hat{\delta_d}, \hat{\lambda_d} &:= \arg \max_{\sigma_d, \delta_d, \lambda_d} + P(D | \sigma_d, \delta_d, \lambda_d ) \\ +P_s(D) &:= \frac{ + P(D | \hat{\sigma_s}, \hat{\delta_s}, \hat{\lambda_s}, \hat{\kappa_s}) }{ + P(D | \hat{\sigma_s}, \hat{\delta_s}, \hat{\lambda_s}, \hat{\kappa_s}) + + P(D | \hat{\sigma_d}, \hat{\delta_d}, \hat{\lambda_d} ) + + P(D | \emptyset ) } \\ +P_d(D) &:= \frac{ + P(D | \hat{\sigma_d}, \hat{\delta_d}, \hat{\lambda_d} ) }{ + P(D | \hat{\sigma_s}, \hat{\delta_s}, \hat{\lambda_s}, \hat{\kappa_s}) + + P(D | \hat{\sigma_d}, \hat{\delta_d}, \hat{\lambda_d} ) + + P(D | \emptyset ) } +\end{align*} + +We might now simply select the most probable model, but this results in erratic behavior if the models cannot be distinguished +clearly. Instead, we use all of these models and roll their posterior probabilities into the damage probabilities. This yields the +final universal damage parameters + +\begin{align*} +&\sigma_s = P_s(D) \hat{\sigma_s}, \quad +\delta_s = P_s(D) \hat{\delta_s}, \quad +\lambda_s = \hat{\lambda_s}, \quad +\kappa_s = \hat{\kappa_s}, \\ +&\sigma_d = P_s(D) \hat{\sigma_d}, \quad +\delta_d = P_s(D) \hat{\delta_d}, \quad +\lambda_d = \hat{\lambda_d} +\end{align*} + +\section{Genotype Calling with Simple Errors} + +The following heavily borrows notation from the \texttt{BSNP}\cite{bsnp} paper. Consider a +genomic position $j$. Let $G_j$ be the true (unknown) genotype. For +convenience of notation, we write $G_j=\{1,0,0,0\}$ for \texttt{AA}, +$G_j=\{\frac{1}{2},\frac{1}{2},0,0\}$ for \texttt{AC}, and so on; we'll +often drop the $j$ subscript. Let $X=(X_1, X_2, \ldots, X_n) \in +\{A,C,G,T\}^n$ be the base calls, $q=(q_1, q_2, \ldots, q_n)$ their +effective\footnote{We roll base quality, base alignment quality, and map +quality into one, see Appendix \ref{app_qualities}} quality scores, $Q=(Q_1, Q_2, +\ldots, Q_n)$ the corresponding error probabilities, $H=(H_1, H_2, +\ldots, H_n) \in \{A,C,G,T\}^n$ the (unobserved) haploid bases +sequenced in each read. The model is that the $H$ are obtained by +sampling from the $G$, possibly modified by chemical damage, then the +$X$ are obtained from the $H$ by application of sequencing error. In +general: + +\begin{align*} +L(G) := P(X|G,Q) &= \prod_{i=1}^n P(X_i|G,Q_i,X_1,\ldots,X_{i-1}) \\ + &= \prod_{i=1}^n \sum_{H_i} P(X_i|Q_i,H_i,X_1,\ldots,X_{i-1}) P(H_i|G) \\ + &= \prod_{i=1}^n \sum_{H_i} P(X_i|Q_i,H_i,X_1,\ldots,X_{i-1}) (H_i \cdot D_i \cdot G_i) +\end{align*} + +where $D_i$ is the damage matrix, which depends on the read, +specifically the position within the read. How to model damage is out +of scope here, but would probably follow \cite{mapdamage}. +For maximum likelihood fitting of parameters, we set $L_j = \sum_G L_j(G) P(G)$, for Bayesian \emph{maximum a posteriori} calling, +we set $P(G_j|X_j,Q_j) = L_j(G_j) P(G_j) / L_j$. The prior can be a complicated model, in which case the ML fit serves to +derive statistical parameters, but the simplest possible prior models only heterozygosity: + +\begin{align*} +P(G=\{1,0,0,0\}) = P(G=\{0,1,0,0\}) = \cdots &= 1 - \frac{\pi}{4} \\ +P(G=\{\frac{1}{2},\frac{1}{2},0,0\}) = P(G=\{\frac{1}{2},0,\frac{1}{2},0\}) = \cdots &= \frac{\pi}{6} +\end{align*} + +The minimal error model has no dependency on other bases and directly applies the error rate from the quality score as $Q_i = +10^{-q_i/10}$, following \texttt{BSNP}\footnote{We assume a low quality base is random, as opposed to a random error. Both +are equivalent up to scaling of the error probability, see Appendix \ref{app_errprob}.}, we set: + +\begin{align*} +P(X_i|H_i,Q_i,X_1,\ldots,X_{i-1}) := P(X_i|H_i,Q_i) = (1-Q_i) X_i H_i + \frac{Q_i}{4} +\end{align*} + +A simple enhancement would be an error matrix modelling typical Illumina errors, another option would be three actual quality +scores from a suitable base caller. + +\section{Genotype Calling w/ Dependent Errors} + +Both the papers regarding \texttt{maq} and \texttt{BSNP} introduce dependency between errors by a ``dependency parameter'' $\theta$, +which could vary between 0 (totally independent) and 1 (totally dependent), and then raising quality scores to a power involving +$\theta$ and $k_i$, a counter of how many errors have happened so far: + +\begin{align*} +Q_i := 10^{-0.1 q'} \qquad \mbox{and} \qquad q'_i := \theta^{k_i} q_i +\end{align*} + +This is easy if we pretend that there is only one kind of error or that +we know which one happened (which is how \cite{samtools} gets away with +a very simple presentation). In the case of ancient DNA, we +do not necessarily know which error happened, since we cannot know what was the true base sequened. We have to generalize to +multiple kinds of errors, and count them fractionally. The above equation could be generalized by plugging in matrix exponentials, +but they are both expensive and unlikely to work in a predictable fashion. Instead we define a more general base likelihood: + +\begin{align*} +P(X_i|H_i,Q_i) = \left\{ \begin{array}{ccc} + w_{X_i,H_i} 10^{-0.1 q_i \theta^{k_{i,X_i,H_i}}} & \mbox{if} & X_i \neq H_i \\ + 1 - \sum_{Y \neq X_i} P(Y|H_i,Q_i) & \mbox{if} & X_i = H_i +\end{array} \right. +\end{align*} + +The $w_{X,H}$ allow for a substitution matrix or could all be set uniformly to +one quarter.\footnote{If we ever get four quality scores, this might produce +negative probabilities and may need to be modified. Such quality scores are +nowhere in sight, though.} For the $k_i$, we have to count errors +fractionally, so we set + +\begin{align*} +k_{1,X_i,H_i} &= 0 \\ +k_{i,X_i,H_i} &= k_{i-1,X_i,H_i} + P(H_i | X_i, Q_i, G) \\ +&= k_{i-1,X_i,H_i} + \frac{P(X_i | Q_i, H_i) P(H_i | G)}{P(X_i|Q_i, G_i)} \\ +&= k_{i-1,X_i,H_i} + \frac{P(X_i | Q_i, H_i) \left( H_i \cdot D_i \cdot G \right) } + {\sum_{H'} P(X_i| Q_i, H') \left( H' \cdot D_i \cdot G \right)} +\end{align*} + +\oops{In an earlier version, this said $P(X_i,H_i|Q_i,G)$, which is +nonsense, since $X_i$ already happened. So we must condition on it and +write $P(H_i|X_i,Q_i,G)$.} + +\section{Testing Method} + +\subsection{Handcrafted Data} + +To test for egregious bugs, we can write a couple of SMA or BAM files by +hand. This shouldn't really be called a test; it's ordinary, boring +debugging. + +\subsection{Simulated Data} + +For all of the simulations, the genome used does not matter at all. For +simplicity, the genome should be small (a megabase should be plenty) and +completely random. We start with a haploid reference genome, then we +apply divergence to get a diploid sample genome. Reads from the sample +genome are simulated along with their correct alignment, the reads are +then modified according to damage and error models. + +\beware{We are \textbf{not} going to use the \textbf{human genome} +or some other monstrosity here. It's needlessly complicated and +provides no benefit.} + +\beware{We specifically \textbf{do not} simulate reads, then +\textbf{align} them back. Doing so would introduce alignment problems +into the genotype calling, which makes testing harder while providing no +insight at all.} + +\paragraph{Simulated Modern Data} + +Starting from a genome with known divergence and heterozygosity, we +simulate plain reads with some sequencing error and suitable quality +scores, then genotype call. + +Called genotypes can be compared to the correct genome, but more +importantly, parameters (divergence, heterozygosity) should be fitted +and compared to their true values, particularly at low (roughly one or +twofold) coverage. + +\beware{There is no point in simulating fancy sequencing error. +Here, we assume the simple model is correct and show that maximum +likelihood estimation of parameters works in this setting.} + +\paragraph{Simulated Ancient Data} + +This is the same idea, this time including damage with known parameters. +As before, genotype calls can be compared and parameters fitted. The +main goal is to get the estimates for heterozygosity, especially +heterozygous transitions, and damage, which interact, right. + +Damage could be simulated either by chosing a position dependent damage +rate and damaging bases independently, or by chosing overhang lengths +according to a distribution, then damaging bases independently at +different constant rates for overhang vs. stem. The genotype caller +uses the former model, but the latter is more correct. We should test +both, both are expected to work reasonably well. + +\beware{We will not use an empirical distribution for the damage +rates. The empirical distribution is no closer to reality than one +based on a formula, so there is nothing to be learned from it. We could +use an empirical distribution of overhang lengths, if that could be +obtained.} + +\idea{Since damage should not correlate with genotypes, estimating +damage in a separate first pass might work and would be lot cheaper, +both conceptually and operationally, than co-estimating damage with +heterozygosity. This is a good time to try it.} + +\subsection{Real Sequencing Data} + +\paragraph{Clean, high-coverage, modern, haploid data} + +We need actual sequencing data from a haploid region at sensible +coverage. The goal is to test the two available error models in a +setting without confounding factors, especially heterozygosity. +This should be used to select the better error model and to fit the +$\theta$ parameter if the \texttt{Maq} model is selected. + +The haploid region of choice might be the mitochondrion, which is +haploid, but the data will be somewhat contaminated with nuMT sequences. +Alternatively, a uniquely mappable region of the X or Y chromosomes of a +male specimen would work, here the difficulty is to find that unique +region. + +\paragraph{Clean, high-coverage, modern data, two mixed haploids} + +Just like the previous test, but this time with two haploid samples +mixed in equal parts. Here, we simulate a diploid sample, but we know +from the individual calls which positions are heterozygous. Again, we +test which error model is better and assess the correctness of the +calls. + +\paragraph{Clean, high-coverage, diploid modern data} + +We test the two error models and select the better one. This must be an +internal goodness-of-fit test, since we cannot know the true genotypes. +In principle, this is the only test strictly necessary to decide on an +error model. + +\beware{In case the tests on haploid samples are inconclusive, +goodness-of-fit takes over. We don't mess with the particulars of the +above tests until we like the results.} + +\paragraph{Clean, low-coverage, modern data} + +Assuming we fixed the error model, assuming we can reliably estimate +difficult parameters like heterozygosity, he we investigate the bahviour +at low coverage. The sample can be a high coverage sample suitably +downsampled. In this case, we have an expectation for the estimated +parameters. + +\paragraph{Ancient data, one mitochondrion} + +To fit parameters to real data, using the best known model (at this +point, we should have selected an error model), without being confounded +by heterozygosity. Data should be clean, so we don't have to deal with +contamination. + +\idea{FFPE samples could serve in place of ancient DNA, it +might come with less trouble due to bacterial contamination.} + +\paragraph{Ancient data, two mixed mitochondria} + +To investigate interaction of heterozygosity, deamination, error model +in a setting where true heterozygous genotypes are known. Data should +be clean and ideally from the same run (we don't want to deal with +additional contamination and different error profiles). The assumtion +is that we can correctly call either sample on its own. + +In principle, if we haven't encountered difficulties so far, this should +simply work. We can learn to which extent the parameter estimates are +confounded with each other in a simple setting. + +\paragraph{Real Ancient Data} + +Including autosomes, sex chromosomes, mitochondria of +varying coverage. To estimate parameters separately, to see possible +interactions. To demostrate the process makes sense. + +\beware{I actually have no idea what to look for here. Any possible +result would have to be taken at face value.} + +\section{Further Directions} + +At this point, we should have a genotype caller that deals well with +deamination, heterozygosity, and recurrent errors. Thorough testing on +a real ancient diploid genome is not possible, because a validated data +set cannot be obtained. We also need a second calling step which +applies a prior and produces genotypes. After that, further ideas +include: + +\begin{itemize} +\item Likelihoods involving contamination. +\item Priors involving covariance matrices. +\end{itemize} + +\subsection{Dealing With Contamination} + +A natural direction to go in is to model contamination\todo{Actual +equations}. To a first +approximation, a contaminated sample has four haplotypes, two of which +are endogenous and occur at the same high frequency, and two are from +the contaminant and occur at lower frequency\footnote{It's conceivable +that we could get away with modelling a haploid contaminant. However, +then allele frequencies are modelled incorrectly at contaminated +heterozygous sites, and the gains of this simplification are modest +anyway: instead of 100 distinct genotypes we'd have 40. I think the +full model is worthwhile here.}. + +In a model with independent errors, our genotype likelihoods will now +depend on the contamination rate, which is a variable. However, the +dependency is linear\todo{Confirm}, so we can store each genotype +likelihood as two coefficients. This makes for 200 coefficients where +before we had 10 values. Bad, but no deal breaker. + +If we have dependent errors, things get complicated. We can recover +simple formulas by assuming low contamination and then ignoring it where +we count repeated errors. This amounts to assuming that contamination +is low enough so that we never make the same error twice when sequencing +the contaminant. Even if that's not strictly true, the effect should be +minor. + +Contamination is a property of a read, not really of a base. If we +tried to infer actual haplotypes, this could easily be taken into +account, but that seems too complicated to contemplate. Instead, when +considering a base in genotype calling, we could assign a probability of +coming from a contaminant to it, which is derived from length +distribution and deamination model. Strictly speaking, deamination +depends on genotype, so genotypes depend on other genotypes, which is +horrible. We recover a simple model by assuming everything a read +crosses matches the reference, except the base under consideration +\todo{Calculate and confirm}. + +Fitting of a simple model on a single sample could recover deamination +parameters, length distributions and contamination rate. We're really +only interested in the contamination rate, which is to be treated as +preliminary. A later stage could try and fit both the sample and the +contaminant into a phylogeny, thereby learning a more precise +contamination rate\todo{Try and confirm}. + +\subsection{Covariance-Matrix as Prior} + +When co-calling individuals from multiple populations, the correct prior +for the genotypes would be based on a covariance matrix. Estimating +that matrix allows Treemix, Patterson's~D and Pruefer's Divergence. + +Conceptually, it's easy: the covariance matrix serves as prior for the +allele frequencies in multiple populations, the allele frequency +(together with a small term for new mutations) serves as prior for the +genotypes\todo{Equation!}. Maximizing the covariance matrix is +straight-forward, but it would require integrating over the space of +possible combinations of allele frequencies, which sounds impractical, +and becomes more impractical the more samples are considered. + +Instead, we can estimate the joint probability (genotype(s), allele +frequency) and maximize that, which is much easier\footnote{Effectively, +we estimate the allele frequency at every position for every sample. +Which is impossible, but the aggregate makes sense for populations.}. +Only summation over the possible genotypes is necesssary, which is just +10 per individual, and individuals are independent; allele frequencies +and covariance matrix are co-estimated using something resembling the EM +algorithm. (One idea would be to not store the aforementioned 600GB of +likelihoods, but only 6GB or thereabout of allele frequency data. The +likelihoods can be generated from the smaller BAM files on the fly.) + + +\appendix + +\section{Random Base vs. Random Error} +\label{app_errprob} + +In \texttt{BSNP}, likelihood of a base is calculated in a way that would be appropriate if the quality score described the +probability of any of the three possible errors. This is problematic, since a low quality score should imply that a base is +completely random. However: + +\begin{align*} +L(X|H,Q) &= (1-Q)\delta_{H,X} + \frac{1}{3} Q (1-\delta_{H,X}) \\ +&= \delta_{H,X} - Q\delta_{H,X} + \frac{1}{3}Q - \frac{1}{3}Q\delta_{H,X} \\ +&= (1-\frac{4}{3}Q)\delta_{H,X} + \frac{1}{3}Q \\ +&= (1-P) \delta_{H,X} + \frac{1}{4}P \qquad \mbox{with} \qquad P=\frac{4}{3}Q +\end{align*} + +So if we replace $Q$ with $\frac{4}{3}Q$, we obtain the formula where the quality $P$ decribes the probability that an observation +is random. Therefore, the two approaches are equivalent up to scaling of the error probability. Both should be tested for any +given base caller, but no special coding is needed. + +\section{Effective Quality} +\label{app_qualities} + +We have two very different quality measures, base quality, which applies to bases, and map quality, which applies to reads. +\texttt{BSNP} tries to treat them separately, but since it treats different genomic location as independent, they become the same: + +\begin{align*} +P(X|H,Q,Z=0) &= \frac{1}{4} \\ +P(X|H,Q,Z=1) &= (1-Q)\delta_{X,H} + \frac{1}{4}Q \\ +P(X|H,Q,M) &= P(Z=0|M) P(X|H,Q,Z=0) + P(Z=1|M) P(X|H,Q,Z=1) \\ +&= \frac{M}{4} + (1-M)\left((1-Q)\delta_{X,H} + \frac{1}{4}Q \right) \\ +&= (1-M)(1-Q)\delta_{X,H} + (1-M)\frac{Q}{4} + \frac{M}{4} \\ +&= (1-M-Q+MQ) \delta_{X,H} + \frac{1}{4}(Q-MQ+M) \\ +&= (1-Q_e) \delta_{X,H} + \frac{Q_e}{4} \qquad \mbox{with} \qquad Q_e = Q+M-MQ +\end{align*} + +So we can handle map quality by defining an effective quality such that it describes at least of the two possible errors (sequencing +or mapping) happening, then computing everything with base qualities only. We can roll in base alignment quality (BAQ), which +doesn't even have a solid definition, too, and express it in quality scores: $q_{\operatorname{eff}} = \operatorname{softmin} \left[ +q_{\operatorname{base}}, q_{\operatorname{map}}, q_{\operatorname{baq}} \right]$. + +This treatment is not correct in that we try to model dependency between errors, which makes sense for base quality. Mapping +errors, however, are complex and probably even more dependent that sequencing errors. Considering that mapping quality is a crude +approximation anyway, this is not a major concern. In principle, PCR +error that happens before sequencing should also be modelled. However, +PCR error behaves similarly to mapping error, and mapping error is +always of at least the same magnitude. Therefore, we simply ignore PCR +error. + +\listoftodos + +\begin{thebibliography}{9} + +\bibitem{bsnp} + Ilan Gronau et. al., + \emph{Bayesian inference of ancient human demography from individual genome sequences}. + Nature Genetics 43, 1031---1034 (2011). + +\bibitem{samtools} + Heng Li, + \emph{Mathematical Notes on SAMtools Algorithms}. + https://www.broadinstitute.org/gatk/media/docs/Samtools.pdf (2010). + +\bibitem{soapsnp} + http://soap.genomics.org.cn/soapsnp.html + +\bibitem{maq} + Heng Li, Jue Ruan, and Richard Durbin, + \emph{Mapping short DNA sequencing reads and calling variants using mapping quality scores}. + Genome Research 18, 1851--1858 (2008). + +\bibitem{mapdamage} + Aurelien Ginolhac et. al., + \emph{mapDamage: testing for damage patterns in ancient DNA sequences}. + Bioinformatics 27 (15), 2153--2155 (2011). + +\end{thebibliography} + +\end{document} diff --git a/man/man1/bam-meld.1 b/man/man1/bam-meld.1 new file mode 100644 --- /dev/null +++ b/man/man1/bam-meld.1 @@ -0,0 +1,86 @@ +.\" Process this file with +.\" groff -man -Tascii bam-rmdup.1 +.\" +.TH BAM-MELD 1 "DECEMBER 2012" Applications "User Manuals" +.SH NAME +bam-meld \- meld BAM files together, keeping best alignments +.SH SYNOPSIS +.B bam-meld [ +.I option +.B | +.I file +.B ... ] +.SH DESCRIPTION +.B bam-meld +takes multiple BAM files as input and melds them into one by keeping the +best alignment for each read. Inputs must be in the same order with +mate pairs sorted together. One way to achieve that is to sort by query +name, another is to keep files in their original order. + + +.SH OPTIONS +.IP "-o, --output file" +Send output to +.I file +instead of standard output. + +.IP "-s, --sorted" +Tells +.I bam-meld +that the input files are sorted by query name. They will be merged, and +all the records found for a given read are melded into one. This works +even if a particular read is missing from some, but not all input files. + +.IP "-u, --unsorted" +Tells +.I bam-meld +the the input is unsorted. It is assumed to be grouped by query name +and all input files must have strictly the same order with no records +missing from any file. + +.IP "-w, --weight XX:Y" +Sets the weight for the badness of field +.I XX +to value +.I Y. +The values of all fields (with integer or floating type) are multiplied +by their weight and summed up to obtain the badness of an alignment. +The alignment with the lowest badness is chosen as the best, the +difference in badness between the two best alignments becomes a new +upper limit on the mapping quality. + +.IP "--bwa" +Sets a badness scheme suitable for programs that fill in the +.IR XM ", " XO ", and " XG +fields, e.g. +.I bwa aln. + +.IP "--anfo" +Sets a badness scheme suitable for programs that fill in the +.IR UQ " and " PQ +fields, e.g. +.I anfo. + +.IP "--blast" +Sets a badness scheme suitable for programs that fill in the +.I AS +field, e.g. +.I bwa bwasw +and presumably the +.I blast +family. + +.IP "--blat" +Sets a badness scheme suitable for programs that fill in the +.I NM +field, which would be appropriate for +.I blat +style programs. + + +.SH AUTHOR +Udo Stenzel + +.SH "SEE ALSO" +.BR biohazard (7) + diff --git a/man/man1/bam-rewrap.1 b/man/man1/bam-rewrap.1 new file mode 100644 --- /dev/null +++ b/man/man1/bam-rewrap.1 @@ -0,0 +1,56 @@ +.\" Process this file with +.\" groff -man -Tascii bam-rmdup.1 +.\" +.TH BAM-REWRAP 1 "SEPTEMBER 2013" Applications "User Manuals" +.SH NAME +bam-rewrap \- rewrap alignments in BAM file to real target length +.SH SYNOPSIS +.BI "bam-rewrap [" chrom : length " ...]" + +.SH DESCRIPTION +.B bam-rewrap +reads a BAM file from standard input and writes a BAM file to standard +output where every alignment to a subset of target sequences has been +wrapped to the targets actual length, obtained from the command line. + +The idea is that a circular reference sequence has been extended +artificially to facilitate alignment. Now the declared length in the +header is wrong, and some alignments overhang the end. +.B bam-rewrap +splits +those alignments into two, one for the beginning, one for the end of +the sequence, then soft-masks out the inappropriate parts. Alignments +falling completely behind the actual end of the target sequence are +wrapped to natural coordinates. + +.B bam-rewrap +tries to fix the map quality (MAPQ) for the affected reads as follows: if +a read has zero map quality, meaning multiple equally good hits, +.B bam-rewrap +checks the +.I XA +field. If it reports exactly one additional alignment, +and it matches the primary alignment when transformed to natural +coordinates, +.I XA +is removed and +.I MAPQ +set to 37, indicating a unique hit. This logic is not standardized and +is only known to work if alignments were produced by +.BR bwa . +It may or may not make sense for other aligners. + +.SH OPTIONS +.IP "chrom:length" +Indicates that the length of target sequence +.IR chrom " is " length . +This option can be repeated and each will cause alignments to the +specified target to be wrapped. A unique prefix of the sequence name is +sufficient. + +.SH AUTHOR +Udo Stenzel + +.SH "SEE ALSO" +.BR biohazard (7) + diff --git a/man/man1/bam-rmdup.1 b/man/man1/bam-rmdup.1 new file mode 100644 --- /dev/null +++ b/man/man1/bam-rmdup.1 @@ -0,0 +1,238 @@ +.\" Process this file with +.\" groff -man -Tascii bam-rmdup.1 +.\" +.TH BAM-RMDUP 1 "DECEMBER 2012" Applications "User Manuals" +.SH NAME +bam-rmdup \- remove PCR duplicates from BAM files +.SH SYNOPSIS +.B bam-rmdup [ +.I option +.B | +.I file +.B ... ] +.SH DESCRIPTION +.B bam-rmdup +searches for PCR duplicates in BAM files. From each set of duplicates, +a consensus is formed, which replaces the whole set. Input files must +be sorted by coordinate, all inputs will be merged into a single sorted +output file. Finally, a summary of the number of removed duplicates and +and estimate of library complexity is printed to standard output. + +.SH OPTIONS +.IP "-o, --output file" +Send BAM output to +.IR file . +The default is to produce no output and count duplicates only. If +.I file +is '-', BAM output is sent to stdout and the final tally is instead sent +to stderr. + +.IP "-O, --output-lib pat" +Split output by library (see notes below) and write each into a file +with the name created from +.IR pat . +If +.I pat +contains the characters +.IR '%s' , +they will be replaced by the name of the library. Note that there can +be reads assigned to no read group, these will have the empty string +substituted. The characters +.IR '%%' +will be replaced by a single percent sign. + +.IP "-R, --refseq REF" +Specify which parts of the input to read. Selective reading requires an +index file for the input. It allows separate processing of individual +reference sequences and hence parallelization. If +.IR REF " is " A , +the whole input is processed, which is the default. If +.I REF +is a number, only alignments to one reference sequence are processed. +If +.IR REF " is " X-Y ", where " X " and " Y +are numbers, alignments to reference sequences numbered +.IR X " through " Y +are processed. Reference sequences are numbered starting from +.IR 1 , +asking for references that do not exist results in no error, but an +empty output file. If +.IR REF " is " U , +only reads with invalid reference sequence (unaligned reads at the end +of the file) are processed. This only makes sense to simulate the +effect of +.IR --unaligned , +therefore +.IR "--refseq U" " implies " --unaligned . + +.IP "-z, --circular CHR:LEN" +Specify that the reference sequence starting with the string +.I CHR +is circular and has length +.IR LEN . + +The effect is that reads that align to one or more position that is +duplicated in the reference are normalized to a small start coordinate +and have their mapping quality (MAPQ) fixed where possible. After removal of +duplicates, reads that overhang the end of the reference sequence are +duplicated to the beginning and invalid parts of the alignment are +masked. The correct length is also entered in the BAM header. + +Assuming that reads were mapped to a reference that has a part from the +beginning pasted to its end, a subsequent genotype caller should now see +even coverage over the whole length of the reference. At the same time, +duplicate removal and complexity estimation should still work fine. +(Arguably, this is all way too complicated, but simple solutions seem +unattainable within the constraints of the BAM file format.) + +.IP "-p, --improper-pairs" +Retain improper pairs, that is, mate-pairs of which only one mate is +mapped. These are discarded by default. + +.IP "-u, --unaligned" +Retain unaligned reads and completely unaligned pairs. This amounts to +a simple copy operation at the end and may only be sensible in +conjunction with +.I --keep +if the output file is intended to replace the input file without loss of +any data. + +.IP "-1, --single-read" +Treat all reads as single. This might be a workaround for a very bad +second read, but is generally considered a bad idea. Reads will no +longer be marked as "paired" after running with this setting. + +.IP "-c, --cheap" +Run in cheap mode. Cheap mode does not compute a consensus sequence for +a cluster of duplicates, but selects one of the reads as representative. +Its advantage is that it runs faster. Cheap mode is the default if no +output file is specified, else a consensus is computed by default. + +.IP "-k, --keep, --mark-only" +Keep duplicates and mark them as such. Setting this option has the +effect that all reads that would have been discarded during duplicate +removal are instead retained and marked as duplicates. + +Note that +.I --keep +does not affect the operation of the filter settings! It may make sense +to combine +.I --keep +with +.IR --improper-pairs , +it may not make sense to combine it with +.IR --min-length . + +.IP "-Q, --max-qual qual" +Set the maximum quality score after consensus calling to +.I qual. +Consensus calling can result in unrealistically high quality scores due +to effects outside this program's scope (presumably errors in PCR). +Quality score are therefore limited to an upper value, even if we didn't +actually remove any duplicates. The default is 60, corresponding to a +very high fidelity polymerase. + +.IP "-l, --min-length len" +Discard reads shorter than +.IR len . +This option may conserve time if the plan is to discard short reads +later anyway. + +.IP "-q, --min-mapq qual" +Discard reads with a map quality (MAPQ) lower than +.IR qual . +If the +.IR --circular +option is in use, the filter is applied after reads have been wrapped +and their map quality has been corrected. This option may conserve time +if the plan is to discard short reads later anyway. + +.IP "-s, --no-strand" +Treat the strand information as uninformative. Normally, PCR duplicates +should always map to the same strand, however, in certain types of +library (e.g. Illumina fork adapter preparation) the two strands of the +same original molecule map to different strands. With the +.I --no-strand +option, these are considered duplicates, without it, they are distinct. + +.IP "-r, --ignore-rg" +Ignore read groups. Normally, no duplicates are expected across +different libraries, and this information is gleaned from the read group +headers. With +.IR --ignore-rg , +everything is treated as a single read group with duplicates potentially +everywhere. + +.SH THEORY OF OPERATION + +.SS Filtering Of Input + +In normal operation, unaligned single reads and completely unaligned +pairs, half-aligned pairs, and duplicate reads are discarded. The +rationale is that these will usually be dropped later anyway. If this +loss of information is undesirable, +.I --improper-pairs +retains half-aligned pairs and includes them in the duplicate removal +process, +.I --unaligned +includes unaligned single reads and completely unaligned read pairs in +the output, and +.I --keep +keeps duplicates and marks them as such. In summary, running with +.I -p -u -k +and without any of +.I -1 -l +should retain all information from the original file. + +.SS Definition of Duplicates + +To find duplicates, reads are grouped into sets of equal alignment +coordinate, equal library, and equal strand. Alignment coordinate means +the 5' coordinate and length for merged reads, the two leftmost +coordinates for read pairs, and just the leftmost coordinate for single +ended reads, the library is the one defined for the read group else the +sample specified for the read group, else the read group, else the empty +string, The assumption here is that different libraries cannot contain +libraries. This works best if the RG-LB field specifies the +"ur-library" before amplification. + +The choice of what constitutes a duplicate is made such that a read pair +can be dealt with using only the information available at one mate's +site ( +.IR POS , MPOS and FLAG +in BAM files). This way, +.B bam-rmdup +can stream a file with no additional sorting pass, and it can be +parallized over target sequences. + +For each set, a consensus is called by first determining the most common +CIGAR line and then calling the consensus of all reads that match the +CIGAR line. Note that this means reads with a different CIGAR line are +effectively discarded, but that also makes dealing with indels rather +easy. Quality scores are afterwards limited to a sensible maximum. + +.SS Mixed Data + +In principle, BAM files can contain a mix of paired end data, single +ended data, merges pairs, and half discarded pairs. The latter is +invalid, but surprisingly common in practice. We try to deal with the +mess as best as we can. The biggest difficulty arises from a mix of +single ended and paired reads, because it is is possible that a single +ended reads looks like a duplicate of two sets of pairs that are clearly +not duplicates of each other. + +.B bam-rmdup +solved this problem by treating single ended and paired data mostly +separately. If a set of single ended reads could be a duplicate of at +least one set of paired end, the singles are removed or marked, but they +are not included into any consensus. + +.SH BUGS +It's way too slow. + +.SH AUTHOR +Udo Stenzel + +.SH "SEE ALSO" +.BR biohazard (7) + diff --git a/man/man1/jivebunny.1 b/man/man1/jivebunny.1 new file mode 100644 --- /dev/null +++ b/man/man1/jivebunny.1 @@ -0,0 +1,177 @@ +.\" Process this file with +.\" groff -man -Tascii bam-rmdup.1 +.\" +.TH JIVEBUNNY 1 "JULY 2015" Applications "User Manuals" +.SH NAME +jivebunny \- demultiplex Illumina sequences +.SH SYNOPSIS +.B jivebunny [ +.I option +.B | +.I file +.B ... ] +.SH DESCRIPTION +.B jivebunny +demultiplexes double-index Illumina sequencing data from one or more BAM +files. In a first pass, the present mixture is analyzed, which serves +to estimate possibly uneven mixture ratios and to assess unexpected +contaminants. In a second pass, each read is assigned to the most +probable read group given the estimated mixture ratios. For both +passes, all input files are concatenated. Summary statistics and +quality scores are computed globally and per read as appropriate. + +.SH OPTIONS +.IP "-o, --output file" +Send BAM output to +.IR file . +The default is to produce no output and estimate mixture ratios only. If +.I file +is '-', BAM output is sent to +.I stdout +and the final tally is instead sent +to +.IR stderr . + +.IP "-I, --index-database file" +Read the database of possible indices from +.IR file . +Every combination of a P7 index and a P5 index from this file is +considered a possible component of the mix. The default is a file +containing all Illumina Truseq indices and indices from the +Meyer/Kircher paper. See below for the format of this file. + +.IP "-r, --read-groups file" +Read read group definitions from file, see below for the format of this +file. Read group definitions are not necessary to identify a mixture +component, but only known components can be named and assigned. + +.IP "--threshold frac" +Set the threshold for the estimation of mixture components to +.IR frac . +The iteration stops as soon as no estimate for any component changes by +more than +.IR frac . +The default of 1/200000 seems to work well in practice. + +.IP "--sample num" +Sample +.I num +reads for the mixture estimation. The default is 50000, which is +usually good enough. By sampling more, the ability to detect +contaminants at low concentration can be improved at the cost of longer +computation. + +.IP "--components num" +Print the top +.I num +components of the mixture after estimation. By default, 25% more than +the number of defined read groups, but at least 20 are printed. Setting +this to a higher number may be a good idea if you're trying to reverse +engineer a pipetting accident. + +.IP "-s, --single-index" +Pretend there is only one index. This switch doesn't change the +program's logic (it still pretends everything is doubly indexed), but it +helps to make the output more readable if only one index was really +sequenced. + +.IP "--pedantic" +Be pedantic about read groups. Normally, +.I jivebunny +will assign reads to undeclared read groups by placing the names of the +two most likely indices into the +.I RG +field. However, since it is not feasible to provide a header that +declares all these potential read groups, the BAM file will technically +be invalid. +.I samtools +will still happily filter on this field, though. If the +.I --pedantic +switch is set, these reads are not assigned to any read group. + + +.IP "--verbose" +Print progress reports during computation. The estimation process can +be observed and a counter runs while reading or writing BAM files. + +.IP "--quiet" +Don't print anything, not even the summary statistics. + +.IP "-h, -?, --help, --usage" +Prints a short usage message and exits the program. + +.IP "-V, --version" +Prints the version of biohazard used and exits the program. + +.SH FILES + +.SS Input Files + +All input files must be double index BAM files. Indices are stored in +tagged fields where +.IR XI " and " XJ +contain the first and second ASCII codes index sequence (only A,C,G,T +and N are allowed) and +.IR YI " and " YJ +contain the quality scores encoded as a string just like in FastaQ +(ASCII codepoint of value plus 33). Single indexed BAM files should +work in principle, but the output may be hard to interpret. + +.SS Output File + +The ouput is a single BAM file which is equivalent to the concatenated +inputs with the following modifications: The header contains an +additional +.I @PG +line and one +.I @RG +line for each read group. Each read gains the appropriate +.I @RG +field if a known read group can be assigned; otherwise the +.I @RG +field is deleted. The fields +.IR @Z0 " and " @Z2 +are deleted and the field +.I @Z1 +is added with a Phred scaled quality score for the assigned read group. +(In other words, +.I @Z1 +is the probability that some other assignment is actually correct, +expressed in deciban. If no read group could be assigned, this value +may not be of much value.) + +.SS Read Group File + +The read group file is TAB separated table containg an optional header +line starting with a hash mark ('#') and then one line per read group. +The first field is the name of the read group, the second field is the +name (not the sequence) of the first index, the third is the name of the +second index. Further fields must have the form +.I XY:val +and are copied into the +.I @RG +header of the output. This facility can be used to assign libraries or +samples to read groups for easier downstream processing. + +.SS Index Database + +The index database is a JSON file containing a single object with two +fields named ``p7index'' and ``p5index''. Each of these is an object +mapping index names to index sequences, the latter encoded as a string. + +It is permissible for multiple indices to have the same sequence. These +will be treated as aliases when parsing read group files, only the first +name is used when producing output. + + +.SH AUTHOR +Udo Stenzel + +.SH "SEE ALSO" +.BR biohazard (7), bam (5), fastq (5), json (5) + +Kircher +.I et.al +(2012). Double indexing overcomes inaccuracies in multiplex sequencing on the Illumina platform. +.IR "Nucleic Acids Research, 40" (1), +e3. doi:10.1093/nar/gkr771 diff --git a/man/man1/mt-anno.1 b/man/man1/mt-anno.1 new file mode 100644 --- /dev/null +++ b/man/man1/mt-anno.1 @@ -0,0 +1,55 @@ +.\" Process this file with +.\" groff -man -Tascii bam-rmdup.1 +.\" +.TH MT-ANNO 1 "JANUARY 2014" Applications "User Manuals" +.SH NAME +mt-anno \- annotate a +.IR human (!) +mitochondrion + +.SH SYNOPSIS +.B mt-anno +< +.I junk.fa +> +.I crap.txt + +.SH DESCRIPTION +.B mt-anno +reads a set of +.IR human (!) +mitochondrial sequences in fasta format from stdin and for each of them +writes a Genbank formatted annotation and the set of coded protein +sequences in fasta format to stdout. + +The annotation is built in and applied blindly. This is a +.IR "very stupid" ", " "very useless" " and " "very wasteful" +thing to do, but biologists have been asking for it repeatedly. +.B DO NOT USE +this tool if you like to think of yourself as a scientist! + +.SH OPTIONS + +.B mt-anno +comes without options and is not customizable. If you think any options +or any further documentation might be useful, you are confused. +Actually, if you want to use it at all, you are confused. + +.SH BUGS + +All +.B mt-anno +does is take the "official" annotation of rCRS and translate its +coordinates. If after translation the annotation doesn't make sense +anymore, there is no warning. If translated proteins lost their start +codon or gained a stop codon, there is no warning. If there is a +frame shift mutation, there is no warning. Arguable, the whole idea of +.B mt-anno +is one big bug, but it's considered unfixable. + +.SH AUTHOR +Udo Stenzel + +.SH "SEE ALSO" +.BR biohazard (7), fasta (5) + diff --git a/man/man7/biohazard.7 b/man/man7/biohazard.7 new file mode 100644 --- /dev/null +++ b/man/man7/biohazard.7 @@ -0,0 +1,28 @@ +.\" Process this file with +.\" groff -man -Tascii bam-rmdup.1 +.\" +.TH BIOHAZARD 1 "DECEMBER 2012" Miscellanea "User Manuals" +.SH NAME +biohazard \- library and tools working mostly with BAM files +.SH SYNOPSIS +.B bam-meld +.B bam-rmdup + +.SH DESCRIPTION +.B biohazard +is chiefly a Haskell library that reads and writes BAM files, along with +some algorithms and tools. See the Haskell Library documentation and +the individual programs' man pages for details. + +.SH AUTHOR +Udo Stenzel + +.SH "SEE ALSO" +.BR bam-fixpair (1) +.BR bam-meld (1) +.BR bam-rewrap (1) +.BR bam-rmdup (1) +.BR fastq2bam (1) +.BR jivebunny (1) +.BR http://samtools.sourceforge.net/SAM1.pdf + diff --git a/src/Bio/Align.hs b/src/Bio/Align.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Align.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Bio.Align ( + Mode(..), + myersAlign, + showAligned + ) where + +import Control.Applicative ( (<$>), (<*>) ) +import Foreign.C.String ( CString ) +import Foreign.C.Types ( CInt(..) ) +import Foreign.Marshal.Alloc ( allocaBytes ) +import System.IO.Unsafe ( unsafePerformIO ) + +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Unsafe as S +import qualified Data.ByteString.Lazy.Char8 as L + +foreign import ccall unsafe "myers_align.h myers_diff" myers_diff :: + CString -> CInt -> -- sequence A and length A + CInt -> -- mode (an enum) + CString -> CInt -> -- sequence B and length B + CInt -> -- max distance + CString -> -- backtracing space A + CString -> -- backtracing space B + IO CInt -- returns distance + +-- | Mode argument for 'myersAlign', determines where free gaps are +-- allowed. +data Mode = Globally -- ^ align globally, without gaps at either end + | HasPrefix -- ^ align so that the second sequence is a prefix of the first + | IsPrefix -- ^ align so that the first sequence is a prefix of the second + deriving Enum + +-- | Align two strings. @myersAlign maxd seqA mode seqB@ tries to align +-- @seqA@ to @seqB@, which will work as long as no more than @maxd@ gaps +-- or mismatches are incurred. The @mode@ argument determines if either +-- of the sequences is allowed to have an overhanging tail. +-- +-- The result is the triple of the actual distance (gaps + mismatches) +-- and the two padded sequences. These sequences are the original +-- sequences with dashes inserted for gaps. +-- +-- The algorithm is the O(nd) algorithm by Myers, implemented in C. A +-- gap and a mismatch score the same. The strings are supposed to code +-- for DNA, the code understands IUPAC ambiguity codes. Two characters +-- match iff there is at least one nucleotide both can code for. Note +-- that N is a wildcard, while X matches nothing. + +myersAlign :: Int -> S.ByteString -> Mode -> S.ByteString -> (Int, S.ByteString, S.ByteString) +myersAlign maxd seqA mode seqB = + unsafePerformIO $ + S.unsafeUseAsCStringLen seqA $ \(seq_a, len_a) -> + S.unsafeUseAsCStringLen seqB $ \(seq_b, len_b) -> + + -- size of output buffers derives from this: + -- char *out_a = bt_a + len_a + maxd +2 ; + -- char *out_b = bt_b + len_b + maxd +2 ; + allocaBytes (len_a + maxd + 2) $ \bt_a -> + allocaBytes (len_b + maxd + 2) $ \bt_b -> + + myers_diff seq_a (fromIntegral len_a) + (fromIntegral $ fromEnum mode) + seq_b (fromIntegral len_b) + (fromIntegral maxd) bt_a bt_b >>= \dist -> + if dist < 0 + then return (maxBound, S.empty, S.empty) + else (,,) (fromIntegral dist) <$> + S.packCString bt_a <*> + S.packCString bt_b + + +-- | Nicely print an alignment. An alignment is simply a list of +-- strings with inserted gaps to make them align. We split them into +-- manageable chunks, stack them vertically and add a line showing +-- asterisks in every column where all aligned strings agree. The +-- result is /almost/ the Clustal format. +showAligned :: Int -> [S.ByteString] -> [L.ByteString] +showAligned w ss | all S.null ss = [] + | otherwise = map (L.fromChunks . (:[])) lefts ++ + L.pack agreement : + L.empty : + showAligned w rights + where + (lefts, rights) = unzip $ map (S.splitAt w) ss + agreement = map star $ S.transpose lefts + star str = if S.null str || S.all (== S.head str) str then '*' else ' ' + diff --git a/src/Bio/Bam.hs b/src/Bio/Bam.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam.hs @@ -0,0 +1,14 @@ +module Bio.Bam ( module X ) where + +import Bio.Bam.Fastq as X +import Bio.Bam.Filter as X +import Bio.Bam.Header as X +import Bio.Bam.Index as X +import Bio.Bam.Reader as X +import Bio.Bam.Rec as X +import Bio.Bam.Trim as X +import Bio.Bam.Writer as X +import Bio.Iteratee as X + +-- ^ Umbrella module for most of what's under 'Bio.Bam'. + diff --git a/src/Bio/Bam/Evan.hs b/src/Bio/Bam/Evan.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Evan.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} +module Bio.Bam.Evan where + +-- ^ This module contains stuff relating to conventions local to MPI +-- EVAN. The code is needed regularly, but it can be harmful when +-- applied to BAM files that follow different conventions. Most +-- importantly, no program should call these functions by default. + +import Bio.Bam.Header +import Bio.Bam.Rec +import Data.Bits + +import qualified Data.ByteString.Char8 as S + +-- | Fixes abuse of flags valued 0x800 and 0x1000. We used them for +-- low quality and low complexity, but they have since been redefined. +-- If set, we clear them and store them into the ZD field. Also fixes +-- abuse of the combination of the paired, 1st mate and 2nd mate flags +-- used to indicate merging or trimming. These are canonicalized and +-- stored into the FF field. This function is unsafe on BAM files of +-- unclear origin! +fixupFlagAbuse :: BamRec -> BamRec +fixupFlagAbuse b = + (if b_flag b .&. flag_low_quality /= 0 then setQualFlag 'Q' else id) $ -- low qual, new convention + (if b_flag b .&. flag_low_complexity /= 0 then setQualFlag 'C' else id) $ -- low complexity, new convention + b { b_flag = cleaned_flags, b_exts = cleaned_exts } + where + -- removes old flag abuse + flags' = b_flag b .&. complement (flag_low_quality .|. flag_low_complexity) + cleaned_flags | flags' .&. flagPaired == 0 = flags' .&. complement (flagFirstMate .|. flagSecondMate) + | otherwise = flags' + + flag_low_quality = 0x800 + flag_low_complexity = 0x1000 + + -- merged & trimmed from old flag abuse + is_merged = flags' .&. (flagPaired .|. flagFirstMate .|. flagSecondMate) == flagFirstMate .|. flagSecondMate + is_trimmed = flags' .&. (flagPaired .|. flagFirstMate .|. flagSecondMate) == flagSecondMate + newflags = (if is_merged then eflagMerged else 0) .|. (if is_trimmed then eflagTrimmed else 0) + + -- Extended flags, renamed to avoid collision with BWA Goes like this: if FF is there, use + -- it. Else check if XF is there _and_is_numeric_. If so, use it and remove it, and set FF + -- instead. Else use 0 and leave it alone. Note that this solves the collision with BWA, + -- since BWA puts a character there, not an int. + cleaned_exts = case (lookup "FF" (b_exts b), lookup "XF" (b_exts b)) of + ( Just (Int i), _ ) -> updateE "FF" (Int (i .|. newflags)) (b_exts b) + ( _, Just (Int i) ) -> updateE "FF" (Int (i .|. newflags)) $ deleteE "XF" (b_exts b) + _ | newflags /= 0 -> updateE "FF" (Int newflags ) (b_exts b) + | otherwise -> b_exts b + + +-- | Fixes typical inconsistencies produced by Bwa: sometimes, 'mate unmapped' should be set, and we +-- can see it, because we match the mate's coordinates. Sometimes 'properly paired' should not be +-- set, because one mate in unmapped. This function is generally safe, but needs to be called only +-- on the output of affected (older?) versions of Bwa. +fixupBwaFlags :: BamRec -> BamRec +fixupBwaFlags b = b { b_flag = fixPP $ b_flag b .|. if mu then flagMateUnmapped else 0 } + where + -- Set "mate unmapped" if self coordinates and mate coordinates are equal, but self is + -- paired and mapped. (BWA forgets this flag for invalid mate alignments) + mu = and [ isPaired b, not (isUnmapped b) + , isReversed b == isMateReversed b + , b_rname b == b_mrnm b, b_pos b == b_mpos b ] + + -- If either mate is unmapped, remove "properly paired". + fixPP f | f .&. (flagUnmapped .|. flagMateUnmapped) == 0 = f + | otherwise = f .&. complement flagProperlyPaired + +-- | Removes syntactic warts from old read names or the read names used +-- in FastQ files. +removeWarts :: BamRec -> BamRec +removeWarts br = br { b_qname = name, b_flag = flags, b_exts = tags } + where + (name, flags, tags) = checkFR $ checkC $ checkSharp (b_qname br, b_flag br, b_exts br) + + checkFR (n,f,t) | "F_" `S.isPrefixOf` n = checkC (S.drop 2 n, f .|. flagFirstMate .|. flagPaired, t) + | "R_" `S.isPrefixOf` n = checkC (S.drop 2 n, f .|. flagSecondMate .|. flagPaired, t) + | "M_" `S.isPrefixOf` n = checkC (S.drop 2 n, f, insertE "FF" (Int eflagMerged) t) + | "T_" `S.isPrefixOf` n = checkC (S.drop 2 n, f, insertE "FF" (Int eflagTrimmed) t) + | "/1" `S.isSuffixOf` n = ( rdrop 2 n, f .|. flagFirstMate .|. flagPaired, t) + | "/2" `S.isSuffixOf` n = ( rdrop 2 n, f .|. flagSecondMate .|. flagPaired, t) + | otherwise = ( n, f, t) + + checkC (n,f,t) | "C_" `S.isPrefixOf` n = (S.drop 2 n, f, insertE "XP" (Int (-1)) t) + | otherwise = ( n, f, t) + + rdrop n s = S.take (S.length s - n) s + + checkSharp (n,f,t) = case S.split '#' n of [n',ts] -> (n', f, insertTags ts t) + _ -> ( n, f, t) + + insertTags ts t | S.null y = insertE "XI" (Text ts) t + | otherwise = insertE "XI" (Text x) $ insertE "XJ" (Text $ S.tail y) t + where (x,y) = S.break (== ',') ts + + diff --git a/src/Bio/Bam/Fastq.hs b/src/Bio/Bam/Fastq.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Fastq.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +module Bio.Bam.Fastq ( + parseFastq, parseFastq', parseFastqCassava + ) where + +import Bio.Bam.Header +import Bio.Bam.Rec +import Bio.Base +import Bio.Iteratee +import Control.Applicative hiding ( many ) +import Data.Attoparsec.ByteString.Char8 +import Data.Bits + +import qualified Data.Attoparsec.ByteString.Char8 as P +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S +import qualified Data.Iteratee.ListLike as I +import qualified Data.Vector.Generic as V + +-- ^ Parser for @FastA/FastQ@, 'Iteratee' style, based on +-- "Data.Attoparsec", and written such that it is compatible with module +-- 'Bio.Bam'. This gives import of @FastA/FastQ@ while respecting some +-- local conventions. + +-- | Reader for DNA (not protein) sequences in FastA and FastQ. We read +-- everything vaguely looking like FastA or FastQ, then shoehorn it into +-- a BAM record. We strive to extract information following more or +-- less established conventions from the header, but we won't support +-- everything under the sun. The recognized syntactical warts are +-- converted into appropriate flags and removed. Only the canonical +-- variant of FastQ is supported (qualities stored as raw bytes with +-- base 33). +-- +-- Supported additional conventions: +-- +-- * A name suffix of @/1@ or @/2@ is turned into the first mate or second +-- mate flag and the read is flagged as paired. +-- +-- * Same for name prefixes of @F_@ or @R_@, respectively. +-- +-- * A name prefix of @M_@ flags the sequence as unpaired and merged +-- +-- * A name prefix of @T_@ flags the sequence as unpaired and trimmed +-- +-- * A name prefix of @C_@, either before or after any of the other +-- prefixes, is turned into the extra flag @XP:i:-1@ (result of +-- duplicate removal with unknown duplicate count). +-- +-- * A collection of tags separated from the name by an octothorpe is +-- removed and put into the fields @XI@ and @XJ@ as text. +-- +-- * In 'parseFastqCassava' only, if the first word of the description +-- has at least four colon separated subfields, the first if used to +-- flag first/second mate, the second is the \"QC failed\" flag, and +-- the fourth is the index sequence. +-- +-- Everything before the first sequence header is ignored. Headers can +-- start with @\>@ or @\@@, we treat both equally. The first word of +-- the header becomes the read name, the remainder of the header is +-- ignored. The sequence can be split across multiple lines; +-- whitespace, dashes and dots are ignored, IUPAC ambiguity codes are +-- accepted as bases, anything else causes an error. The sequence ends +-- at a line that is either a header or starts with @\+@, in the latter +-- case, that line is ignored and must be followed by quality scores. +-- There must be exactly as many Q-scores as there are bases, followed +-- immediately by a header or end-of-file. Whitespace is ignored. + +{-# WARNING parseFastq "parseFastq no longer removes syntactic warts!" #-} +parseFastq :: Monad m => Enumeratee S.ByteString [ BamRec ] m a +parseFastq = parseFastq' (const id) + +parseFastqCassava :: Monad m => Enumeratee S.ByteString [ BamRec ] m a +parseFastqCassava = parseFastq' (pdesc . S.split ':' . S.takeWhile (' ' /=)) + where + pdesc (num:flg:_:idx:_) br = br { b_flag = sum [ if num == "1" then flagFirstMate .|. flagPaired else 0 + , if num == "2" then flagSecondMate .|. flagPaired else 0 + , if flg == "Y" then flagFailsQC else 0 + , b_flag br .&. complement (flagFailsQC .|. flagSecondMate .|. flagPaired) ] + , b_exts = if S.all (`S.elem` "ACGTN") idx then insertE "XI" (Text idx) (b_exts br) else b_exts br } + pdesc _ br = br + +-- | Same as 'parseFastq', but a custom function can be applied to the +-- description string (the part of the header after the sequence name), +-- which can modify the parsed record. Note that the quality field can +-- end up empty. + +{-# WARNING parseFastq' "parseFastq' no longer removes syntactic warts!" #-} +parseFastq' :: Monad m => ( S.ByteString -> BamRec -> BamRec ) + -> Enumeratee S.ByteString [ BamRec ] m a +parseFastq' descr it = do skipJunk ; convStream (parserToIteratee $ (:[]) <$> pRec) it + where + isCBase = inClass "ACGTUBDHVSWMKRYNacgtubdhvswmkryn" + canSkip c = isSpace c || c == '.' || c == '-' + isHdr c = c == '@' || c == '>' + + pRec = (satisfy isHdr "start marker") *> (makeRecord <$> pName <*> (descr <$> P.takeWhile ('\n' /=)) <*> (pSeq >>= pQual)) + pName = takeTill isSpace <* skipWhile (\c -> c /= '\n' && isSpace c) "read name" + pSeq = (:) <$> satisfy isCBase <*> pSeq + <|> satisfy canSkip *> pSeq + <|> pure [] "sequence" + + pQual sq = (,) sq <$> (char '+' *> skipWhile ('\n' /=) *> pQual' (length sq) <* skipSpace <|> return S.empty) "qualities" + pQual' n = B.filter (not . isSpace_w8) <$> scan n step + step 0 _ = Nothing + step i c | isSpace c = Just i + | otherwise = Just (i-1) + +skipJunk :: Monad m => Iteratee S.ByteString m () +skipJunk = I.peek >>= check + where + check (Just c) | bad c = I.dropWhile (c2w '\n' /=) >> I.drop 1 >> skipJunk + check _ = return () + bad c = c /= c2w '>' && c /= c2w '@' + +makeRecord :: Seqid -> (BamRec->BamRec) -> (String, S.ByteString) -> BamRec +makeRecord name extra (sq,qual) = extra $ nullBamRec + { b_qname = name, b_seq = V.fromList $ read sq, b_qual = V.fromList $ map (Q . subtract 33) $ B.unpack qual } + +---------------------------------------------------------------------------- + +some_file :: FilePath +some_file = "/mnt/ngs_data/101203_SOLEXA-GA04_00007_PEDi_MM_QF_SR/Ibis/Final_Sequences/s_5_L3280_sequence_merged.txt" + +fastq_test :: FilePath -> IO () +fastq_test = fileDriver $ joinI $ parseFastq print_names + +print_names :: Iteratee [BamRec] IO () +print_names = I.mapM_ $ S.putStrLn . b_qname + diff --git a/src/Bio/Bam/Filter.hs b/src/Bio/Bam/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Filter.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleContexts #-} +module Bio.Bam.Filter ( + filterPairs, QualFilter, + complexSimple, complexEntropy, + qualityAverage, qualityMinimum, + qualityFromOldIllumina, qualityFromNewIllumina + ) where + +import Bio.Bam.Header +import Bio.Bam.Rec +import Bio.Base +import Bio.Iteratee +import Data.Bits + +import qualified Data.Vector.Generic as V + +-- ^ Quality filters adapted from old pipeline. + +-- | A filter/transformation applied to pairs of reads. We supply a +-- predicate to be applied to single reads and one to be applied to +-- pairs, tha latter can get incomplete pairs, too, if mates have been +-- separated or filtered asymmetrically. + +filterPairs :: Monad m => (BamRec -> [BamRec]) + -> (Maybe BamRec -> Maybe BamRec -> [BamRec]) + -> Enumeratee [BamRec] [BamRec] m a +filterPairs ps pp = eneeCheckIfDone step + where + step k = tryHead >>= step' k + step' k Nothing = return $ liftI k + step' k (Just b) + | isPaired b = tryHead >>= step'' k b + | otherwise = case ps b of [] -> step k ; b' -> eneeCheckIfDone step . k $ Chunk b' + + step'' k b Nothing = case pp (Just b) Nothing of + [] -> return $ liftI k + b' -> return $ k $ Chunk b' + + step'' k b (Just c) + | b_rname b /= b_rname c || not (isPaired c) = + let b' = if isSecondMate b then pp Nothing (Just b) else pp (Just b) Nothing + in case b' of [] -> step' k (Just c) + _ -> eneeCheckIfDone (\k' -> step' k' (Just c)) . k $ Chunk b' + + | isFirstMate c && isSecondMate b = step''' k c b + | otherwise = step''' k b c + + step''' k b c = case pp (Just b) (Just c) of [] -> step k + b' -> eneeCheckIfDone step . k $ Chunk b' + + +-- | A quality filter is simply a transformation on @BamRec@s. By +-- convention, quality filters should set @flagFailsQC@, a further step +-- can then remove the failed reads. Filtering of individual reads +-- tends to result in mate pairs with inconsistent flags, which in turn +-- will result in lone mates and all sort of troubles with programs that +-- expect non-broken BAM files. It is therefore recommended to use +-- @pairFilter@ with suitable predicates to do the post processing. + +type QualFilter = BamRec -> BamRec + +{-# INLINE count #-} +count :: (V.Vector v a, Eq a) => a -> v a -> Int +count x = V.foldl' (\acc y -> if x == y then acc+1 else acc) 0 + +-- | Simple complexity filter aka "Nancy Filter". A read is considered +-- not-sufficiently-complex if the most common base accounts for greater +-- than the @cutoff@ fraction of all non-N bases. +{-# INLINE complexSimple #-} +complexSimple :: Double -> QualFilter +complexSimple r b = if p then b else b' + where + b' = setQualFlag 'C' $ b { b_flag = b_flag b .|. flagFailsQC } + p = let counts = [ count x $ b_seq b | x <- properBases ] + lim = floor $ r * fromIntegral (sum counts) + in all (<= lim) counts + +-- | Filter on order zero empirical entropy. Entropy per base must be +-- greater than cutoff. +{-# INLINE complexEntropy #-} +complexEntropy :: Double -> QualFilter +complexEntropy r b = if p then b else b' + where + b' = setQualFlag 'C' $ b { b_flag = b_flag b .|. flagFailsQC } + p = ent >= r * total + + counts = [ count x $ b_seq b | x <- properBases ] + total = fromIntegral $ V.length $ b_seq b + ent = sum [ fromIntegral c * log (total / fromIntegral c) | c <- counts, c /= 0 ] / log 2 + +-- | Filter on average quality. Reads without quality string pass. +{-# INLINE qualityAverage #-} +qualityAverage :: Int -> QualFilter +qualityAverage q b = if p then b else b' + where + b' = setQualFlag 'Q' $ b { b_flag = b_flag b .|. flagFailsQC } + p = let total = V.foldl' (\a x -> a + fromIntegral (unQ x)) 0 $ b_qual b + in total >= q * V.length (b_qual b) + +-- | Filter on minimum quality. In @qualityMinimum n q@, a read passes +-- if it has no more than @n@ bases with quality less than @q@. Reads +-- without quality string pass. +{-# INLINE qualityMinimum #-} +qualityMinimum :: Int -> Qual -> QualFilter +qualityMinimum n (Q q) b = if p then b else b' + where + b' = setQualFlag 'Q' $ b { b_flag = b_flag b .|. flagFailsQC } + p = V.length (V.filter (< Q q) (b_qual b)) <= n + + +-- | Convert quality scores from old Illumina scale (different formula +-- and offset 64 in FastQ). +qualityFromOldIllumina :: BamRec -> BamRec +qualityFromOldIllumina b = b { b_qual = V.map conv $ b_qual b } + where + conv (Q s) = let s' :: Double + s' = exp $ log 10 * (fromIntegral s - 31) / (-10) + p = s' / (1+s') + q = - 10 * log p / log 10 + in Q (round q) + +-- | Convert quality scores from new Illumina scale (standard formula +-- but offset 64 in FastQ). +qualityFromNewIllumina :: BamRec -> BamRec +qualityFromNewIllumina b = b { b_qual = V.map (Q . subtract 31 . unQ) $ b_qual b } + + diff --git a/src/Bio/Bam/Header.hs b/src/Bio/Bam/Header.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Header.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE OverloadedStrings, BangPatterns #-} +module Bio.Bam.Header ( + BamMeta(..), + parseBamMeta, + parseBamMetaLine, + showBamMeta, + addPG, + + BamKey(..), + BamHeader(..), + BamSQ(..), + BamSorting(..), + BamOtherShit, + + Refseq(..), + invalidRefseq, + isValidRefseq, + invalidPos, + isValidPos, + unknownMapq, + isKnownMapq, + + Refs, + noRefs, + getRef, + + compareNames, + + flagPaired, + flagProperlyPaired, + flagUnmapped, + flagMateUnmapped, + flagReversed, + flagMateReversed, + flagFirstMate, + flagSecondMate, + flagAuxillary, + flagFailsQC, + flagDuplicate, + eflagTrimmed, + eflagMerged, + + distinctBin, + + MdOp(..), + readMd, + showMd + ) where + +import Bio.Base +import Control.Applicative +import Data.Bits ( shiftL, shiftR, (.&.), (.|.) ) +import Data.Char ( isDigit, ord, chr ) +import Data.ByteString.Builder +import Data.Ix +import Data.List ( (\\), foldl' ) +import Data.Monoid +import Data.Sequence ( (><), (|>) ) +import Data.String +import Data.Version ( Version, showVersion ) +import Data.Word ( Word16, Word32 ) +import System.Environment ( getArgs, getProgName ) + +import qualified Data.Attoparsec.ByteString.Char8 as P +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S +import qualified Data.Foldable as F +import qualified Data.Sequence as Z + +data BamMeta = BamMeta { + meta_hdr :: !BamHeader, + meta_refs :: !Refs, + meta_other_shit :: [(BamKey, BamOtherShit)], + meta_comment :: [S.ByteString] + } deriving Show + +-- | Exactly two characters, for the \"named\" fields in bam. +newtype BamKey = BamKey Word16 + deriving ( Eq, Ord ) + +instance IsString BamKey where + {-# INLINE fromString #-} + fromString [a,b] + | ord a < 256 && ord b < 256 + = BamKey . fromIntegral $ ord a .|. shiftL (ord b) 8 + + fromString s + = error $ "Not a legal BAM key: " ++ show s + +instance Show BamKey where + show (BamKey a) = [ chr (fromIntegral a .&. 0xff), chr (shiftR (fromIntegral a) 8 .&. 0xff) ] + +addPG :: Maybe Version -> IO (BamMeta -> BamMeta) +addPG vn = do + args <- getArgs + pn <- getProgName + return $ go args pn + where + go args pn bm = bm { meta_other_shit = ("PG",pg_line) : meta_other_shit bm } + where + pg_line = concat [ [ ("ID", pg_id) ] + , [ ("PN", S.pack pn) ] + , [ ("CL", S.pack $ unwords args) ] + , maybe [] (\v -> [("VN",S.pack (showVersion v))]) vn + , map (\p -> ("PP",p)) (take 1 pg_pp) + , map (\p -> ("pp",p)) (drop 1 pg_pp) ] + + pg_id : _ = filter (not . flip elem pg_ids) . map S.pack $ + pn : [ pn ++ '-' : show i | i <- [(1::Int)..] ] + + pg_ids = [ pgid | ("PG",fs) <- meta_other_shit bm, ("ID",pgid) <- fs ] + pg_pps = [ pgid | ("PG",fs) <- meta_other_shit bm, ("PP",pgid) <- fs ] + + pg_pp = pg_ids \\ pg_pps + + +instance Monoid BamMeta where + mempty = BamMeta mempty noRefs [] [] + a `mappend` b = BamMeta { meta_hdr = meta_hdr a `mappend` meta_hdr b + , meta_refs = meta_refs a >< meta_refs b + , meta_other_shit = meta_other_shit a ++ meta_other_shit b + , meta_comment = meta_comment a ++ meta_comment b } + +data BamHeader = BamHeader { + hdr_version :: (Int, Int), + hdr_sorting :: !BamSorting, + hdr_other_shit :: BamOtherShit + } deriving Show + +instance Monoid BamHeader where + mempty = BamHeader (1,0) Unknown [] + a `mappend` b = BamHeader { hdr_version = hdr_version a `min` hdr_version b + , hdr_sorting = let u = hdr_sorting a ; v = hdr_sorting b in if u == v then u else Unknown + , hdr_other_shit = hdr_other_shit a ++ hdr_other_shit b } + +data BamSQ = BamSQ { + sq_name :: Seqid, + sq_length :: Int, + sq_other_shit :: BamOtherShit + } deriving Show + +bad_seq :: BamSQ +bad_seq = BamSQ (error "no SN field") (error "no LN field") [] + +-- | Possible sorting orders from bam header. Thanks to samtools, which +-- doesn't declare sorted files properly, we have to have the stupid +-- 'Unknown' state, too. +data BamSorting = Unknown | Unsorted | Grouped | Queryname | Coordinate | GroupSorted + deriving (Show, Eq) + +type BamOtherShit = [(BamKey, S.ByteString)] + +parseBamMeta :: P.Parser BamMeta +parseBamMeta = fixup . foldl' (flip ($)) mempty <$> P.sepBy parseBamMetaLine (P.skipWhile (=='\t') >> P.char '\n') + where + fixup meta = meta { meta_other_shit = reverse (meta_other_shit meta) + , meta_comment = reverse (meta_comment meta) } + +parseBamMetaLine :: P.Parser (BamMeta -> BamMeta) +parseBamMetaLine = P.char '@' >> P.choice [hdLine, sqLine, coLine, otherLine] + where + hdLine = P.string "HD\t" >> + (\fns meta -> let fixup hdr = hdr { hdr_other_shit = reverse (hdr_other_shit hdr) } + in meta { meta_hdr = fixup $! foldl' (flip ($)) (meta_hdr meta) fns }) + <$> P.sepBy1 (P.choice [hdvn, hdso, hdother]) tabs + + sqLine = P.string "SQ\t" >> + (\fns meta -> let fixup sq = sq { sq_other_shit = reverse (sq_other_shit sq) } + !s = fixup $ foldl' (flip ($)) bad_seq fns + in meta { meta_refs = meta_refs meta |> s }) + <$> P.sepBy1 (P.choice [sqnm, sqln, sqother]) tabs + + hdvn = P.string "VN:" >> + (\a b hdr -> hdr { hdr_version = (a,b) }) + <$> P.decimal <*> ((P.char '.' <|> P.char ':') >> P.decimal) + + hdso = P.string "SO:" >> + (\s hdr -> hdr { hdr_sorting = s }) + <$> P.choice [ Grouped <$ P.string "grouped" + , Queryname <$ P.string "queryname" + , Coordinate <$ P.string "coordinate" + , GroupSorted <$ P.string "groupsort" + , Unsorted <$ P.string "unsorted" + , Unknown <$ P.skipWhile (\c -> c/='\t' && c/='\n') ] + + sqnm = P.string "SN:" >> (\s sq -> sq { sq_name = s }) <$> pall + sqln = P.string "LN:" >> (\i sq -> sq { sq_length = i }) <$> P.decimal + + hdother = (\t hdr -> t `seq` hdr { hdr_other_shit = t : hdr_other_shit hdr }) <$> tagother + sqother = (\t sq -> t `seq` sq { sq_other_shit = t : sq_other_shit sq }) <$> tagother + + coLine = P.string "CO\t" >> + (\s meta -> s `seq` meta { meta_comment = s : meta_comment meta }) + <$> P.takeWhile (/= 'n') + + otherLine = (\k ts meta -> meta { meta_other_shit = (k,ts) : meta_other_shit meta }) + <$> bamkey <*> (tabs >> P.sepBy1 tagother tabs) + + tagother :: P.Parser (BamKey,S.ByteString) + tagother = (,) <$> bamkey <*> (P.char ':' >> pall) + + tabs = P.char '\t' >> P.skipWhile (== '\t') + + pall :: P.Parser S.ByteString + pall = P.takeWhile (\c -> c/='\t' && c/='\n') + + bamkey :: P.Parser BamKey + bamkey = (\a b -> fromString [a,b]) <$> P.anyChar <*> P.anyChar + +showBamMeta :: BamMeta -> Builder +showBamMeta (BamMeta h ss os cs) = + show_bam_meta_hdr h <> + F.foldMap show_bam_meta_seq ss <> + F.foldMap show_bam_meta_other os <> + F.foldMap show_bam_meta_comment cs + where + show_bam_meta_hdr (BamHeader (major,minor) so os') = + byteString "@HD\tVN:" <> + intDec major <> char7 '.' <> intDec minor <> + byteString (case so of Unknown -> B.empty + Unsorted -> "\tSO:unsorted" + Grouped -> "\tSO:grouped" + Queryname -> "\tSO:queryname" + Coordinate -> "\tSO:coordinate" + GroupSorted -> "\tSO:groupsort") <> + show_bam_others os' + + show_bam_meta_seq (BamSQ _ _ []) = mempty + show_bam_meta_seq (BamSQ nm ln ts) = + byteString "@SQ\tSN:" <> byteString nm <> + byteString "\tLN:" <> intDec ln <> show_bam_others ts + + show_bam_meta_comment cm = byteString "@CO\t" <> byteString cm <> char7 '\n' + + show_bam_meta_other (BamKey k,ts) = + char7 '@' <> word16LE k <> show_bam_others ts + + show_bam_others ts = + F.foldMap show_bam_other ts <> char7 '\n' + + show_bam_other (BamKey k,v) = + char7 '\t' <> word16LE k <> char7 ':' <> byteString v + + +-- | Reference sequence in Bam +-- Bam enumerates the reference sequences and then sorts by index. We +-- need to track that index if we want to reproduce the sorting order. +newtype Refseq = Refseq { unRefseq :: Word32 } deriving (Eq, Ord, Ix) + +instance Show Refseq where + showsPrec p (Refseq r) = showsPrec p r + +instance Enum Refseq where + succ = Refseq . succ . unRefseq + pred = Refseq . pred . unRefseq + toEnum = Refseq . fromIntegral + fromEnum = fromIntegral . unRefseq + enumFrom = map Refseq . enumFrom . unRefseq + enumFromThen (Refseq a) (Refseq b) = map Refseq $ enumFromThen a b + enumFromTo (Refseq a) (Refseq b) = map Refseq $ enumFromTo a b + enumFromThenTo (Refseq a) (Refseq b) (Refseq c) = map Refseq $ enumFromThenTo a b c + + +-- | Tests whether a reference sequence is valid. +-- Returns true unless the the argument equals @invalidRefseq@. +isValidRefseq :: Refseq -> Bool +isValidRefseq = (/=) invalidRefseq + +-- | The invalid Refseq. +-- Bam uses this value to encode a missing reference sequence. +invalidRefseq :: Refseq +invalidRefseq = Refseq 0xffffffff + +-- | The invalid position. +-- Bam uses this value to encode a missing position. +{-# INLINE invalidPos #-} +invalidPos :: Int +invalidPos = -1 + +-- | Tests whether a position is valid. +-- Returns true unless the the argument equals @invalidPos@. +{-# INLINE isValidPos #-} +isValidPos :: Int -> Bool +isValidPos = (/=) invalidPos + +{-# INLINE unknownMapq #-} +unknownMapq :: Int +unknownMapq = 255 + +isKnownMapq :: Int -> Bool +isKnownMapq = (/=) unknownMapq + +-- | A list of reference sequences. +type Refs = Z.Seq BamSQ + +-- | The empty list of references. Needed for BAM files that don't really store alignments. +noRefs :: Refs +noRefs = Z.empty + +getRef :: Refs -> Refseq -> BamSQ +getRef refs (Refseq i) + | 0 <= i && fromIntegral i <= Z.length refs = Z.index refs (fromIntegral i) + | otherwise = BamSQ "*" 0 [] + + +flagPaired, flagProperlyPaired, flagUnmapped, flagMateUnmapped, flagReversed, flagMateReversed, flagFirstMate, flagSecondMate, + flagAuxillary, flagFailsQC, flagDuplicate :: Int + +flagPaired = 0x1 +flagProperlyPaired = 0x2 +flagUnmapped = 0x4 +flagMateUnmapped = 0x8 +flagReversed = 0x10 +flagMateReversed = 0x20 +flagFirstMate = 0x40 +flagSecondMate = 0x80 +flagAuxillary = 0x100 +flagFailsQC = 0x200 +flagDuplicate = 0x400 + +eflagTrimmed, eflagMerged :: Int +eflagTrimmed = 0x1 +eflagMerged = 0x2 + + +-- | Compares two sequence names the way samtools does. +-- samtools sorts by "strnum_cmp": +-- . if both strings start with a digit, parse the initial +-- sequence of digits and compare numerically, if equal, +-- continue behind the numbers +-- . else compare the first characters (possibly NUL), if equal +-- continue behind them +-- . else both strings ended and the shorter one counts as +-- smaller (and that part is stupid) + +compareNames :: Seqid -> Seqid -> Ordering +compareNames n m = case (B.uncons n, B.uncons m) of + ( Nothing, Nothing ) -> EQ + ( Just _, Nothing ) -> GT + ( Nothing, Just _ ) -> LT + ( Just (c,n'), Just (d,m') ) + | is_digit c && is_digit d -> + let Just (u,n'') = S.readInt n + Just (v,m'') = S.readInt m + in case u `compare` v of + LT -> LT + GT -> GT + EQ -> n'' `compareNames` m'' + | otherwise -> case c `compare` d of + LT -> LT + GT -> GT + EQ -> n' `compareNames` m' + where + is_digit c = 48 <= c && c < 58 + + +data MdOp = MdNum Int | MdRep Nucleotides | MdDel [Nucleotides] deriving Show + +readMd :: S.ByteString -> Maybe [MdOp] +readMd s | S.null s = return [] + | isDigit (S.head s) = do (n,t) <- S.readInt s + (MdNum n :) <$> readMd t + | S.head s == '^' = let (a,b) = S.break isDigit (S.tail s) + in (MdDel (map toNucleotides $ S.unpack a) :) <$> readMd b + | otherwise = (MdRep (toNucleotides $ S.head s) :) <$> readMd (S.tail s) + +-- | Normalizes a series of 'MdOp's and encodes them in the way BAM and +-- SAM expect it. +showMd :: [MdOp] -> S.ByteString +showMd = S.pack . flip s1 [] + where + s1 (MdNum i : MdNum j : ms) = s1 (MdNum (i+j) : ms) + s1 (MdNum 0 : ms) = s1 ms + s1 (MdNum i : ms) = shows i . s1 ms + + s1 (MdRep r : ms) = shows r . s1 ms + + s1 (MdDel d1 : MdDel d2 : ms) = s1 (MdDel (d1++d2) : ms) + s1 (MdDel [] : ms) = s1 ms + s1 (MdDel ns : MdRep r : ms) = (:) '^' . shows ns . (:) '0' . shows r . s1 ms + s1 (MdDel ns : ms) = (:) '^' . shows ns . s1 ms + s1 [ ] = id + + +-- | Computes the "distinct bin" according to the BAM binning scheme. If +-- an alignment starts at @pos@ and its CIGAR implies a length of @len@ +-- on the reference, then it goes into bin @distinctBin pos len@. +distinctBin :: Int -> Int -> Int +distinctBin beg len = mkbin 14 $ mkbin 17 $ mkbin 20 $ mkbin 23 $ mkbin 26 0 + where end = beg + len - 1 + mkbin n x = if beg `shiftR` n /= end `shiftR` n then x + else ((1 `shiftL` (29-n))-1) `div` 7 + (beg `shiftR` n) diff --git a/src/Bio/Bam/Index.hs b/src/Bio/Bam/Index.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Index.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards, PatternGuards, FlexibleContexts #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +module Bio.Bam.Index ( + BamIndex(..), + readBamIndex, + readBaiIndex, + readTabix, + + Region(..), + Subsequence(..), + eneeBamRefseq, + eneeBamSubseq, + eneeBamRegions, + eneeBamUnaligned, + subsampleBam +) where + +import Bio.Bam.Header +import Bio.Bam.Reader +import Bio.Bam.Rec +import Bio.Bam.Regions ( Region(..), Subsequence(..) ) +import Bio.Iteratee +import Bio.Iteratee.Bgzf +import Control.Monad +import Data.Bits ( shiftL, shiftR, testBit ) +import Data.ByteString ( ByteString ) +import Data.Char ( chr ) +import Data.Int ( Int64 ) +import Data.IntMap ( IntMap ) +import System.Directory ( doesFileExist ) +import System.FilePath ( dropExtension, takeExtension, (<.>) ) +import System.Random ( randomRIO ) + +import qualified Bio.Bam.Regions as R +import qualified Control.Exception as E +import qualified Data.IntMap as M +import qualified Data.ByteString as B +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as W +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as N +import qualified Data.Vector.Algorithms.Intro as N + +-- | Full index, unifying BAI and CSI style. In both cases, we have the +-- binning scheme, parameters are fixed in BAI, but variable in CSI. +-- Checkpoints are created from the linear index in BAI or from the +-- `loffset' field in CSI. + +data BamIndex a = BamIndex { + -- | Minshift parameter from CSI + minshift :: !Int, + + -- | Depth parameter from CSI + depth :: !Int, + + -- | Best guess at where the unaligned records start + unaln_off :: !Int64, + + -- | Room for stuff (needed for tabix) + extensions :: a, + + -- | Records for the binning index, where each bin has a list of + -- segments belonging to it. + refseq_bins :: !(V.Vector Bins), + + -- | Known checkpoints of the form (pos,off) where off is the + -- virtual offset of the first record crossing pos. + refseq_ckpoints :: !(V.Vector Ckpoints) } + + deriving Show + +-- | Mapping from bin number to vector of clusters. +type Bins = IntMap Segments +type Segments = U.Vector (Int64,Int64) + + +-- | Checkpoints. Each checkpoint is a position with the virtual offset +-- where the first alignment crossing the position is found. In BAI, we +-- get this from the 'ioffset' vector, in CSI we get it from the +-- 'loffset' field: "Given a region [beg,end), we only need to visit +-- chunks whose end file offset is larger than 'ioffset' of the 16kB +-- window containing 'beg'." (Sounds like a marginal gain, though.) + +type Ckpoints = IntMap Int64 + + +-- | Decode only those reads that fall into one of several regions. +-- Strategy: We will scan the file mostly linearly, but only those +-- regions that are actually needed. We filter the decoded stuff so +-- that it actually overlaps our regions. +-- +-- From the binning index, we get a list of segments per requested +-- region. Using the checkpoints, we prune them: if we have a +-- checkpoint to the left of the beginning of the interesting region, we +-- can move the start of each segment forward to the checkpoint. If +-- that makes the segment empty, it can be droppped. +-- +-- The resulting segment lists are merged, then traversed. We seek to +-- the beginning of the earliest segment and start decoding. Once the +-- virtual file position leaves the segment or the alignment position +-- moves past the end of the requested region, we move to the next. +-- Moving is a seek if it spans a sufficiently large gap or points +-- backwards, else we just keep going. + +-- | A 'Segment' has a start and an end offset, and an "end coordinate" +-- from the originating region. +data Segment = Segment !Int64 !Int64 !Int deriving Show + +segmentLists :: BamIndex a -> Refseq -> R.Subsequence -> [[Segment]] +segmentLists bi@BamIndex{..} (Refseq ref) (R.Subsequence imap) + | Just bins <- refseq_bins V.!? fromIntegral ref, + Just cpts <- refseq_ckpoints V.!? fromIntegral ref + = [ rgnToSegments bi beg end bins cpts | (beg,end) <- M.toList imap ] +segmentLists _ _ _ = [] + +-- from region to list of bins, then to list of segments +rgnToSegments :: BamIndex a -> Int -> Int -> Bins -> Ckpoints -> [Segment] +rgnToSegments bi@BamIndex{..} beg end bins cpts = + [ Segment boff' eoff end + | bin <- binList bi beg end + , (boff,eoff) <- maybe [] U.toList $ M.lookup bin bins + , let boff' = max boff cpt + , boff' < eoff ] + where + !cpt = maybe 0 snd $ lookupLE beg cpts + +-- list of bins for given range of coordinates, from Heng's horrible code +binList :: BamIndex a -> Int -> Int -> [Int] +binList BamIndex{..} beg end = binlist' 0 (minshift + 3*depth) 0 + where + binlist' l s t = if l > depth then [] else [b..e] ++ loop + where + b = t + beg `shiftR` s + e = t + (end-1) `shiftR` s + loop = binlist' (l+1) (s-3) (t + 1 `shiftL` (3*l)) + + +-- | Merges two lists of segments. Lists must be sorted, the merge sort +-- merges overlapping segments into one. +infix 4 ~~ +(~~) :: [Segment] -> [Segment] -> [Segment] +Segment a b e : xs ~~ Segment u v f : ys + | b < u = Segment a b e : (xs ~~ Segment u v f : ys) -- no overlap + | a < u && b < v = Segment a v (max e f) : (xs ~~ ys) -- some overlap + | b < v = Segment u v (max e f) : (xs ~~ ys) -- contained + | v < a = Segment u v f : (xs ~~ Segment a b e : ys) -- no overlap + | u < a = Segment u b (max e f) : (xs ~~ ys) -- some overlap + | otherwise = Segment a b (max e f) : (xs ~~ ys) -- contained +[] ~~ ys = ys +xs ~~ [] = xs + + +-- | Reads any index we can find for a file. If the file name has a +-- .bai or .csi extension, we read it. Else we look for the index by +-- adding such an extension and by replacing the extension with these +-- two, and finally in the file itself. The first file that exists and +-- can actually be parsed, is used. +readBamIndex :: FilePath -> IO (BamIndex ()) +readBamIndex fp | takeExtension fp == ".bai" = fileDriver readBaiIndex fp + | takeExtension fp == ".csi" = fileDriver readBaiIndex fp + | otherwise = try (fp <.> "bai") $ + try (dropExtension fp <.> "bai") $ + try (fp <.> "csi") $ + try (dropExtension fp <.> "csi") $ + fileDriver readBaiIndex fp + where + try f k = do e <- doesFileExist f + if e then do r <- enumFile defaultBufSize f readBaiIndex >>= tryRun + case r of Right ix -> return ix + Left (IterStringException _) -> k + else k + +-- | Read an index in BAI or CSI format, recognized automatically. +-- Note that TBI is supposed to be compressed using bgzip; it must be +-- decompressed before being passed to 'readBaiIndex'. + +readBaiIndex :: MonadIO m => Iteratee ByteString m (BamIndex ()) +readBaiIndex = iGetString 4 >>= switch + where + switch "BAI\1" = do nref <- fromIntegral `liftM` endianRead4 LSB + getIndexArrays nref 14 5 (const return) getIntervals + + switch "CSI\1" = do minshift <- fromIntegral `liftM` endianRead4 LSB + depth <- fromIntegral `liftM` endianRead4 LSB + endianRead4 LSB >>= dropStream . fromIntegral -- aux data + nref <- fromIntegral `liftM` endianRead4 LSB + getIndexArrays nref minshift depth (addOneCheckpoint minshift depth) return + + switch magic = throwErr . iterStrExc $ "index signature " ++ show magic ++ " not recognized" + + + -- Insert one checkpoint. If we already have an entry (can happen + -- if it comes from a different bin), we conservatively take the min + addOneCheckpoint minshift depth bin cp = do + loffset <- fromIntegral `liftM` endianRead8 LSB + let key = llim (fromIntegral bin) (3*depth) minshift + return $! M.insertWith min key loffset cp + + -- compute left limit of bin + llim bin dp sf | dp == 0 = 0 + | bin >= ix = (bin - ix) `shiftL` sf + | otherwise = llim bin (dp-3) (sf+3) + where ix = (1 `shiftL` dp - 1) `div` 7 + +type TabIndex = BamIndex TabMeta + +data TabMeta = TabMeta { format :: TabFormat + , col_seq :: Int -- Column for the sequence name + , col_beg :: Int -- Column for the start of a region + , col_end :: Int -- Column for the end of a region + , comment_char :: Char + , skip_lines :: Int + , names :: V.Vector ByteString } + deriving Show + +data TabFormat = Generic | SamFormat | VcfFormat | ZeroBased deriving Show + +-- | Reads a Tabix index. Note that tabix indices are compressed, this +-- is taken care of. +readTabix :: MonadIO m => Iteratee ByteString m TabIndex +readTabix = joinI $ decompressBgzf $ iGetString 4 >>= switch + where + switch "TBI\1" = do nref <- fromIntegral `liftM` endianRead4 LSB + format <- liftM toFormat (endianRead4 LSB) + col_seq <- liftM fromIntegral (endianRead4 LSB) + col_beg <- liftM fromIntegral (endianRead4 LSB) + col_end <- liftM fromIntegral (endianRead4 LSB) + comment_char <- liftM (chr . fromIntegral) (endianRead4 LSB) + skip_lines <- liftM fromIntegral (endianRead4 LSB) + names <- liftM (V.fromList . B.split 0) . iGetString . fromIntegral =<< endianRead4 LSB + + ix <- getIndexArrays nref 14 5 (const return) getIntervals + fin <- isFinished + if fin then return $! ix { extensions = TabMeta{..} } + else do unaln <- fromIntegral `liftM` endianRead8 LSB + return $! ix { unaln_off = unaln, extensions = TabMeta{..} } + + switch magic = throwErr . iterStrExc $ "index signature " ++ show magic ++ " not recognized" + + toFormat 1 = SamFormat + toFormat 2 = VcfFormat + toFormat x = if testBit x 16 then ZeroBased else Generic + +-- Read the intervals. Each one becomes a checkpoint. +getIntervals :: Monad m => (IntMap Int64, Int64) -> Iteratee ByteString m (IntMap Int64, Int64) +getIntervals (cp,mx0) = do + nintv <- fromIntegral `liftM` endianRead4 LSB + reduceM 0 nintv (cp,mx0) $ \(!im,!mx) int -> do + oo <- fromIntegral `liftM` endianRead8 LSB + return (if oo == 0 then im else M.insert (int * 0x4000) oo im, max mx oo) + + +getIndexArrays :: MonadIO m => Int -> Int -> Int + -> (Word32 -> Ckpoints -> Iteratee ByteString m Ckpoints) + -> ((Ckpoints, Int64) -> Iteratee ByteString m (Ckpoints, Int64)) + -> Iteratee ByteString m (BamIndex ()) +getIndexArrays nref minshift depth addOneCheckpoint addManyCheckpoints + | nref < 1 = return $ BamIndex minshift depth 0 () V.empty V.empty + | otherwise = do + rbins <- liftIO $ W.new nref + rckpts <- liftIO $ W.new nref + mxR <- reduceM 0 nref 0 $ \mx0 r -> do + nbins <- endianRead4 LSB + (!bins,!cpts,!mx1) <- reduceM 0 nbins (M.empty,M.empty,mx0) $ \(!im,!cp,!mx) _ -> do + bin <- endianRead4 LSB -- the "distinct bin" + cp' <- addOneCheckpoint bin cp + segsarr <- getSegmentArray + let !mx' = if U.null segsarr then mx else max mx (snd (U.last segsarr)) + return (M.insert (fromIntegral bin) segsarr im, cp', mx') + (!cpts',!mx2) <- addManyCheckpoints (cpts,mx1) + liftIO $ W.write rbins r bins >> W.write rckpts r cpts' + return mx2 + liftM2 (BamIndex minshift depth mxR ()) (liftIO $ V.unsafeFreeze rbins) (liftIO $ V.unsafeFreeze rckpts) + +-- | Reads the list of segments from an index file and makes sure +-- it is sorted. +getSegmentArray :: MonadIO m => Iteratee ByteString m Segments +getSegmentArray = do + nsegs <- fromIntegral `liftM` endianRead4 LSB + segsarr <- liftIO $ N.new nsegs + loopM 0 nsegs $ \i -> do beg <- fromIntegral `liftM` endianRead8 LSB + end <- fromIntegral `liftM` endianRead8 LSB + liftIO $ N.write segsarr i (beg,end) + liftIO $ N.sort segsarr >> U.unsafeFreeze segsarr + +{-# INLINE reduceM #-} +reduceM :: (Monad m, Enum ix, Eq ix) => ix -> ix -> a -> (a -> ix -> m a) -> m a +reduceM beg end acc cons = if beg /= end then cons acc beg >>= \n -> reduceM (succ beg) end n cons else return acc + +{-# INLINE loopM #-} +loopM :: (Monad m, Enum ix, Eq ix) => ix -> ix -> (ix -> m ()) -> m () +loopM beg end k = if beg /= end then k beg >> loopM (succ beg) end k else return () + + +-- | Seeks to a given sequence in a Bam file and enumerates only those +-- records aligning to that reference. We use the first checkpoint +-- available for the sequence. This requires an appropriate index, and +-- the file must have been opened in such a way as to allow seeking. +-- Enumerates over the @BamRaw@ records of the correct sequence only, +-- doesn't enumerate at all if the sequence isn't found. + +eneeBamRefseq :: Monad m => BamIndex b -> Refseq -> Enumeratee [BamRaw] [BamRaw] m a +eneeBamRefseq BamIndex{..} (Refseq r) iter + | Just ckpts <- refseq_ckpoints V.!? fromIntegral r + , Just (voff, _) <- M.minView ckpts + , voff /= 0 = do seek $ fromIntegral voff + breakE ((Refseq r /=) . b_rname . unpackBam) iter + | otherwise = return iter + +-- | Seeks to the part of a Bam file that contains unaligned reads and +-- enumerates those. Sort of the dual to 'eneeBamRefseq'. We use the +-- best guess at where the unaligned stuff starts. If no such guess is +-- available, we decode everything. + +eneeBamUnaligned :: Monad m => BamIndex b -> Enumeratee [BamRaw] [BamRaw] m a +eneeBamUnaligned BamIndex{..} iter = do when (unaln_off /= 0) $ seek $ fromIntegral unaln_off + filterStream (not . isValidRefseq . b_rname . unpackBam) iter + +-- | Enumerates one 'Segment'. Seeks to the start offset, unless +-- reading over the skipped part looks cheaper. Enumerates until we +-- either cross the end offset or the max position. +eneeBamSegment :: Monad m => Segment -> Enumeratee [BamRaw] [BamRaw] m r +eneeBamSegment (Segment beg end mpos) out = do + -- seek if it's a backwards seek or more than 512k forwards + peekStream >>= \x -> case x of + Just br | beg <= o && beg + 0x8000 > o -> return () + where o = fromIntegral $ virt_offset br + _ -> seek $ fromIntegral beg + + let in_segment br = virt_offset br <= fromIntegral end && b_pos (unpackBam br) <= mpos + takeWhileE in_segment out + +eneeBamSubseq :: Monad m => BamIndex b -> Refseq -> R.Subsequence -> Enumeratee [BamRaw] [BamRaw] m a +eneeBamSubseq bi ref subs = foldr ((>=>) . eneeBamSegment) return segs ><> filterStream olap + where + segs = foldr (~~) [] $ segmentLists bi ref subs + olap br = b_rname == ref && R.overlaps b_pos (b_pos + alignedLength b_cigar) subs + where BamRec{..} = unpackBam br + +eneeBamRegions :: Monad m => BamIndex b -> [R.Region] -> Enumeratee [BamRaw] [BamRaw] m a +eneeBamRegions bi = foldr ((>=>) . uncurry (eneeBamSubseq bi)) return . R.toList . R.fromList + + +lookupLE :: M.Key -> M.IntMap a -> Maybe (M.Key, a) +lookupLE k m = case ma of + Just a -> Just (k,a) + Nothing | M.null m1 -> Nothing + | otherwise -> Just $ M.findMax m1 + where (m1,ma,_) = M.splitLookup k m + + +-- | Subsample randomly from a BAM file. If an index exists, this +-- produces an infinite stream taken from random locations in the file. + +subsampleBam :: (MonadIO m, MonadMask m) => FilePath -> Enumerator' BamMeta [BamRaw] m b +subsampleBam fp o = liftIO (E.try (readBamIndex fp)) >>= subsam + where + -- no index, so just stream + subsam (Left e) = enumFile defaultBufSize fp >=> run $ + joinI $ decompressBgzfBlocks $ + joinI $ decodeBam $ \hdr -> + takeWhileE (isValidRefseq . b_rname . unpackBam) (o hdr) + `const` (e::E.SomeException) + + -- with index: chose random bins and read from them + subsam (Right bix) = withFileFd fp $ \fd -> do + hdr <- enumFdRandom defaultBufSize fd >=> run $ + joinI $ decompressBgzfBlocks' 1 $ + joinI $ decodeBam return + loop fd (o hdr) + where + !ckpts = U.fromList . V.foldr ((++) . M.elems) [] $ refseq_ckpoints bix + + loop fd o1 = enumCheckIfDone o1 >>= loop' fd + + loop' _ (True, o2) = return o2 + loop' fd (False, o2) = do i <- liftIO $ randomRIO (0, U.length ckpts -1) + enum fd i o2 >>= loop fd + + enum fd i = enumFdRandom defaultBufSize fd $= + decompressBgzfBlocks' 1 $= + (\it -> do seek . fromIntegral $ ckpts U.! i + convStream getBamRaw it) $= + takeStream 512 diff --git a/src/Bio/Bam/Pileup.hs b/src/Bio/Bam/Pileup.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Pileup.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE BangPatterns, Rank2Types, RecordWildCards, OverloadedStrings #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +module Bio.Bam.Pileup where + +-- import Text.Printf + +import Bio.Base +import Bio.Bam.Header +import Bio.Bam.Rec +import Bio.Genocall.Adna +import Bio.Iteratee + +import Control.Arrow ( (&&&) ) +import Control.Applicative +import Control.Monad hiding ( mapM_ ) +import Control.Monad.Fix ( fix ) +import Data.Foldable hiding ( sum, product ) +import Data.Monoid +import Data.Ord +import Data.Vec.Packed ( Mat44D, packMat ) + +import qualified Data.ByteString as B +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Unboxed as U + +import Prelude hiding ( foldr, foldr1, concat, mapM_, all ) + +-- ^ Genotype Calling: like Samtools(?), but for aDNA +-- +-- The goal for this module is to call haploid and diploid single +-- nucleotide variants the best way we can, including support for aDNA. +-- Indel calling is out of scope, we only do it "on the side". +-- +-- The cleanest way to call genotypes under all circumstances is +-- probably the /Dindel/ approach: define candidate haplotypes, align +-- each read to each haplotype, then call the likely haplotypes with a +-- quality derived from the quality scores. This approach neatly +-- integrates indel calling with ancient DNA and makes a separate indel +-- realigner redundant. However, it's rather expensive in that it +-- requires inclusion of an aligner, and we'd need an aligner that is +-- compatible with the chosen error model, which might be hard. +-- +-- Here we'll take a short cut: We do not really call indels. Instead, +-- these variants are collected and are assigned an affine score. This +-- works best if indels are 'left-aligned' first. In theory, one indel +-- variant could be another indel variant with a sequencing error---we +-- ignore that possibility for the most part. Once indels are taken +-- care off, SNVs are treated separately as independent columns of the +-- pileup. +-- +-- Regarding the error model, there's a choice between /samtools/ or the +-- naive model everybody else (GATK, Rasmus Nielsen, etc.) uses. Naive +-- is easy to marry to aDNA, samtools is (probably) better. Either way, +-- we introduce a number of parameters (@eta@ and @kappa@ for +-- /samtools/, @lambda@, @delta@, @delta_ss@ for /Johnson/). Running a +-- maximum likehood fit for those may be valuable. It would be cool, if +-- we could do that without rerunning the complete genotype caller, but +-- it's not a priority. +-- +-- So, outline of the genotype caller: We read BAM (minimally +-- filtering; general filtering is somebody else's problem, but we might +-- want to split by read group). We will scan each read's CIGAR line in +-- concert with the sequence and effective quality. Effective quality +-- is the lowest available quality score of QUAL, MAPQ, and BQ. For +-- aDNA calling, the base is transformed into four likelihoods based on +-- the aDNA substitution matrix. +-- +-- So, either way, we need something like "pileup", where indel variants +-- are collected as they are (any length), while matches are piled up. +-- +-- Regarding output, we certainly don't want to write VCF or BCF. (No +-- VCF because it's ugly, no BCF, because the tool support is +-- non-existent.) It will definitely be something binary. For the GL +-- values, small floating point formats may make sense: half-precision +-- floating point's representable range would be 6.1E-5 to 6.5E+5, 0.4.4 +-- minifloat from Bio.Util goes from 0 to 63488. + + +-- *TODO* +-- +-- * A whole lot of testing. +-- * Actual genotype calling. +-- * ML fitting and evaluation of parameters for different possible +-- error and damage models. +-- * Maybe specialize to ploidy one and two. + +-- | The primitive pieces for genotype calling: A position, a base +-- represented as four likelihoods, an inserted sequence, and the +-- length of a deleted sequence. The logic is that we look at a base +-- followed by some indel, and all those indels are combined into a +-- single insertion and a single deletion. +data PrimChunks = Seek !Int !PrimBase -- ^ skip to position (at start or after N operation) + | Indel !Int [DamagedBase] !PrimBase -- ^ observed deletion and insertion between two bases + | EndOfRead -- ^ nothing anymore + deriving Show + +data PrimBase = Base { _pb_wait :: !Int -- ^ number of bases to wait due to a deletion + , _pb_likes :: !DamagedBase -- ^ four likelihoods + , _pb_mapq :: !Qual -- ^ map quality + , _pb_rev :: !Bool -- ^ reverse strand? + , _pb_chunks :: PrimChunks } -- ^ more chunks + deriving Show + + +-- | Represents our knowledge about a certain base, which consists of +-- the base itself (A,C,G,T, encoded as 0..3; no Ns), the quality score +-- (anything that isn't A,C,G,T becomes A with quality 0), and a +-- substitution matrix representing post-mortem but pre-sequencing +-- substitutions. +-- +-- Unfortunately, none of this can be rolled into something more simple, +-- because damage and sequencing error behave so differently. + +data DamagedBase = DB { db_call :: !Nucleotide + , db_qual :: !Qual + , db_dmg :: !Mat44D } + +instance Show DamagedBase where + showsPrec _ (DB n q _) = shows n . (:) '@' . shows q + + +-- | Decomposes a BAM record into chunks suitable for piling up. We +-- pick apart the CIGAR field, and combine it with sequence and quality +-- as appropriate. We ignore the @MD@ field, even if it is present. +-- Clipped bases are removed/skipped as appropriate. We also ignore the +-- reference allele, in fact, we don't even know it, which nicely avoids +-- any possible reference bias by construction. But we do apply a +-- substitution matrix to each base, which must be supplied along with +-- the read. + +decompose :: BamRaw -> [Mat44D] -> PrimChunks +decompose br matrices + | isUnmapped b || b_rname == invalidRefseq = EndOfRead + | otherwise = firstBase b_pos 0 0 matrices + where + b@BamRec{..} = unpackBam br + + !max_cig = V.length b_cigar + !max_seq = V.length b_seq + -- !mapq = br_mapq br + !baq = extAsString "BQ" b + + -- This will compute the effective quality. As far as I can see + -- from the BAM spec V1.4, the qualities that matter are QUAL, MAPQ, + -- and BAQ. If QUAL is invalid, we replace it (arbitrarily) with + -- 23 (assuming a rather conservative error rate of ~0.5%), BAQ is + -- added to QUAL, and MAPQ is an upper limit for effective quality. + get_seq :: Int -> Mat44D -> DamagedBase + get_seq i = case b_seq V.! i of -- nucleotide + n | n == nucsA -> DB nucA qe + | n == nucsC -> DB nucC qe + | n == nucsG -> DB nucG qe + | n == nucsT -> DB nucT qe + | otherwise -> DB nucA (Q 0) + where + !q = case b_qual V.! i of Q 0xff -> Q 30 ; x -> x -- quality; invalid (0xff) becomes 30 + !q' | i >= B.length baq = q -- no BAQ available + | otherwise = Q (unQ q + (B.index baq i - 64)) -- else correct for BAQ + !qe = min q' b_mapq -- use MAPQ as upper limit + + -- Look for first base following the read's start or a gap (CIGAR + -- code N). Indels are skipped, since these are either bugs in the + -- aligner or the aligner getting rid of essentially unalignable + -- bases. + firstBase :: Int -> Int -> Int -> [Mat44D] -> PrimChunks + firstBase !_ !_ !_ [ ] = EndOfRead + firstBase !pos !is !ic mms@(m:ms) + | is >= max_seq || ic >= max_cig = EndOfRead + | otherwise = case b_cigar V.! ic of + Ins :* cl -> firstBase pos (cl+is) (ic+1) mms + SMa :* cl -> firstBase pos (cl+is) (ic+1) mms + Del :* cl -> firstBase (pos+cl) is (ic+1) mms + Nop :* cl -> firstBase (pos+cl) is (ic+1) mms + HMa :* _ -> firstBase pos is (ic+1) mms + Pad :* _ -> firstBase pos is (ic+1) mms + Mat :* 0 -> firstBase pos is (ic+1) mms + Mat :* _ -> Seek pos $ nextBase 0 pos is ic 0 m ms + + -- Generate likelihoods for the next base. When this gets called, + -- we are looking at an M CIGAR operation and all the subindices are + -- valid. + nextBase :: Int -> Int -> Int -> Int -> Int -> Mat44D -> [Mat44D] -> PrimBase + nextBase !wt !pos !is !ic !io m ms = Base wt (get_seq is m) b_mapq (isReversed b) + $ nextIndel [] 0 (pos+1) (is+1) ic (io+1) ms + + -- Look for the next indel after a base. We collect all indels (I + -- and D codes) into one combined operation. If we hit N or the + -- read's end, we drop all of it (indels next to a gap indicate + -- trouble). Other stuff is skipped: we could check for stuff that + -- isn't valid in the middle of a read (H and S), but then what + -- would we do about it anyway? Just ignoring it is much easier and + -- arguably at least as correct. + nextIndel :: [[DamagedBase]] -> Int -> Int -> Int -> Int -> Int -> [Mat44D] -> PrimChunks + nextIndel _ _ !_ !_ !_ !_ [ ] = EndOfRead + nextIndel ins del !pos !is !ic !io mms@(m:ms) + | is >= max_seq || ic >= max_cig = EndOfRead + | otherwise = case b_cigar V.! ic of + Ins :* cl -> nextIndel (isq cl) del pos (cl+is) (ic+1) 0 (drop cl mms) + SMa :* cl -> nextIndel ins del pos (cl+is) (ic+1) 0 (drop cl mms) + Del :* cl -> nextIndel ins (cl+del) (pos+cl) is (ic+1) 0 mms + Pad :* _ -> nextIndel ins del pos is (ic+1) 0 mms + HMa :* _ -> nextIndel ins del pos is (ic+1) 0 mms + Mat :* cl | io == cl -> nextIndel ins del pos is (ic+1) 0 mms + | otherwise -> Indel del out $ nextBase del pos is ic io m ms -- ends up generating a 'Base' + Nop :* cl -> firstBase (pos+cl) is (ic+1) mms -- ends up generating a 'Seek' + where + out = concat $ reverse ins + isq cl = zipWith ($) [ get_seq i | i <- [is..is+cl-1] ] (take cl mms) : ins + + +-- | Statistics about a genotype call. Probably only useful for +-- fitlering (so not very useful), but we keep them because it's easy to +-- track them. + +data CallStats = CallStats { read_depth :: !Int -- number of contributing reads + , reads_mapq0 :: !Int -- number of (non-)contributing reads with MAPQ==0 + , sum_mapq :: !Int -- sum of map qualities of contributing reads + , sum_mapq_squared :: !Int } -- sum of squared map qualities of contributing reads + deriving Show + +instance Monoid CallStats where + mempty = CallStats { read_depth = 0 + , reads_mapq0 = 0 + , sum_mapq = 0 + , sum_mapq_squared = 0 } + mappend x y = CallStats { read_depth = read_depth x + read_depth y + , reads_mapq0 = reads_mapq0 x + reads_mapq0 y + , sum_mapq = sum_mapq x + sum_mapq y + , sum_mapq_squared = sum_mapq_squared x + sum_mapq_squared y } + +-- | Genotype likelihood values. A variant call consists of a position, +-- some measure of qualities, genotype likelihood values, and a +-- representation of variants. A note about the GL values: @VCF@ would +-- normalize them so that the smallest one becomes zero. We do not do +-- that here, since we might want to compare raw values for a model +-- test. We also store them in a 'Double' to make arithmetics easier. +-- Normalization is appropriate when converting to @VCF@. +-- +-- If GL is given, we follow the same order used in VCF: +-- \"the ordering of genotypes for the likelihoods is given by: +-- F(j/k) = (k*(k+1)/2)+j. In other words, for biallelic sites the +-- ordering is: AA,AB,BB; for triallelic sites the ordering is: +-- AA,AB,BB,AC,BC,CC, etc.\" + +type GL = U.Vector Prob + +newtype V_Nuc = V_Nuc (U.Vector Nucleotide) deriving (Eq, Ord, Show) +data IndelVariant = IndelVariant { deleted_bases :: !Int + , inserted_bases :: !V_Nuc } + deriving (Eq, Ord, Show) + +-- Both types of piles carry along the map quality. We'll only need it +-- in the case of Indels. +type BasePile = [( Qual, DamagedBase )] -- a list of encountered bases +type IndelPile = [( Qual, (Int, [DamagedBase]) )] -- a list of indel variants + +-- | Running pileup results in a series of piles. A 'Pile' has the +-- basic statistics of a 'VarCall', but no GL values and a pristine list +-- of variants instead of a proper call. We emit one pile with two +-- 'BasePile's (one for each strand) and one 'IndelPile' (the one +-- immediately following) at a time. + +data Pile' a b = Pile { p_refseq :: !Refseq + , p_pos :: !Int + , p_snp_stat :: !CallStats + , p_snp_pile :: a + , p_indel_stat :: !CallStats + , p_indel_pile :: b } + deriving Show + +type Pile = Pile' (BasePile, BasePile) IndelPile +type Calls = Pile' GL (GL, [IndelVariant]) + +-- | The pileup enumeratee takes 'BamRaw's, decomposes them, interleaves +-- the pieces appropriately, and generates 'Pile's. The output will +-- contain at most one 'BasePile' and one 'IndelPile' for each position, +-- piles are sorted by position. +-- +-- This top level driver receives 'BamRaw's. Unaligned reads and +-- duplicates are skipped (but not those merely failing quality checks). +-- Processing stops when the first read with invalid 'br_rname' is +-- encountered or a t end of file. + +pileup :: Monad m => DamageModel Double -> Enumeratee [BamRaw] [Pile] m a +pileup dm = takeWhileE (isValidRefseq . b_rname . unpackBam) ><> filterStream useable ><> + eneeCheckIfDonePass (icont . runPileM pileup' finish (Refseq 0) 0 [] Empty dm) + where + useable = not . (\b -> isUnmapped b || isDuplicate b) . unpackBam + + finish () _r _p [] Empty _dm out inp = idone (liftI out) inp + finish () _ _ _ _ _ _ _ = error "logic error: leftovers after pileup" + + +-- | The pileup logic keeps a current coordinate (just two integers) and +-- two running queues: one of /active/ 'PrimBase's that contribute to +-- current genotype calling and on of /waiting/ 'PrimBase's that will +-- contribute at a later point. +-- +-- Oppan continuation passing style! Not only is the CPS version of the +-- state monad (we have five distinct pieces of state) somewhat faster, +-- we also need CPS to interact with the mechanisms of 'Iteratee'. It +-- makes implementing 'yield', 'peek', and 'bump' straight forward. + +newtype PileM m a = PileM { runPileM :: forall r . (a -> PileF m r) -> PileF m r } + +-- | The things we drag along in 'PileM'. Notes: +-- * The /active/ queue is a simple stack. We add at the front when we +-- encounter reads, which reverses them. When traversing it, we traverse +-- reads backwards, but since we accumulate the 'BasePile', it gets reversed +-- back. The new /active/ queue, however, is no longer reversed (as it should +-- be). So after the traversal, we reverse it again. (Yes, it is harder to +-- understand than using a proper deque type, but it is cheaper. +-- There may not be much point in the reversing, though.) + +type PileF m r = Refseq -> Int -> -- current position + [PrimBase] -> -- active queue + Heap -> -- waiting queue + DamageModel Double -> + (Stream [Pile] -> Iteratee [Pile] m r) -> -- output function + Stream [BamRaw] -> -- pending input + Iteratee [BamRaw] m (Iteratee [Pile] m r) + +instance Functor (PileM m) where + fmap f (PileM m) = PileM $ \k -> m (k . f) + +instance Applicative (PileM m) where + pure a = PileM $ \k -> k a + u <*> v = PileM $ \k -> runPileM u (\a -> runPileM v (k . a)) + +instance Monad (PileM m) where + return a = PileM $ \k -> k a + m >>= k = PileM $ \k' -> runPileM m (\a -> runPileM (k a) k') + +instance MonadIO m => MonadIO (PileM m) where + liftIO m = PileM $ \k r p a w d o i -> liftIO m >>= \x -> k x r p a w d o i + +get_refseq :: PileM m Refseq +get_refseq = PileM $ \k r -> k r r + +get_pos :: PileM m Int +get_pos = PileM $ \k r p -> k p r p + +upd_pos :: (Int -> Int) -> PileM m () +upd_pos f = PileM $ \k r p -> k () r $! f p + +set_pos :: (Refseq, Int) -> PileM m () +set_pos (!r,!p) = PileM $ \k _ _ -> k () r p + +get_active :: PileM m [PrimBase] +get_active = PileM $ \k r p a -> k a r p a + +upd_active :: ([PrimBase] -> [PrimBase]) -> PileM m () +upd_active f = PileM $ \k r p a -> k () r p $! f a + +get_waiting :: PileM m Heap +get_waiting = PileM $ \k r p a w -> k w r p a w + +upd_waiting :: (Heap -> Heap) -> PileM m () +upd_waiting f = PileM $ \k r p a w -> k () r p a $! f w + +get_damage_model :: PileM m (DamageModel Double) +get_damage_model = PileM $ \k r p a w d -> k d r p a w d + +yield :: Monad m => Pile -> PileM m () +yield x = PileM $ \k r p a w d out inp -> + eneeCheckIfDone (\out' -> k () r p a w d out' inp) . out $ Chunk [x] + +-- | Inspect next input element, if any. Returns @Just b@ if @b@ is the +-- next input element, @Nothing@ if no such element exists. Waits for +-- more input if nothing is available immediately. +peek :: PileM m (Maybe BamRaw) +peek = PileM $ \k r p a w d out inp -> case inp of + EOF _ -> k Nothing r p a w d out inp + Chunk [ ] -> liftI $ runPileM peek k r p a w d out + Chunk (b:_) -> k (Just b) r p a w d out inp + +-- | Discard next input element, if any. Does nothing if input has +-- already ended. Waits for input to discard if nothing is available +-- immediately. +bump :: PileM m () +bump = PileM $ \k r p a w d out inp -> case inp of + EOF _ -> k () r p a w d out inp + Chunk [ ] -> liftI $ runPileM bump k r p a w d out + Chunk (_:x) -> k () r p a w d out (Chunk x) + + +consume_active :: a -> (a -> PrimBase -> PileM m a) -> PileM m a +consume_active nil cons = do ac <- get_active + upd_active (const []) + foldM cons nil ac + +-- | The actual pileup algorithm. +pileup' :: Monad m => PileM m () +pileup' = do + refseq <- get_refseq + active <- get_active + next_waiting <- fmap ((,) refseq) . getMinKey <$> get_waiting + next_input <- fmap ((b_rname &&& b_pos) . unpackBam) <$> peek + + -- If /active/ contains something, continue here. Else find the coordinate + -- to continue from, which is the minimum of the next /waiting/ coordinate + -- and the next coordinate in input; if found, continue there, else we're + -- all done. + case (active, next_waiting, next_input) of + ( (_:_), _, _ ) -> pileup'' + ( [ ], Just nw, Nothing ) -> set_pos nw >> pileup'' + ( [ ], Nothing, Just ni ) -> set_pos ni >> pileup'' + ( [ ], Just nw, Just ni ) -> set_pos (min nw ni) >> pileup'' + ( [ ], Nothing, Nothing ) -> return () + +pileup'' :: Monad m => PileM m () +pileup'' = do + -- Input is still 'BamRaw', since these can be relied on to be + -- sorted. First see if there is any input at the current location, + -- if so, decompose it and add it to the appropriate queue. + rs <- get_refseq + po <- get_pos + dm <- get_damage_model + + -- liftIO $ printf "pileup' @%d:%d, %d active, %d waiting\n" + -- (unRefseq rs) po (-1::Int) (-1::Int) + + -- feed in input as long as it starts at the current position + fix $ \loop -> peek >>= mapM_ (\br -> + let b = unpackBam br + in when (b_rname b == rs && b_pos b == po) $ do + bump + case decompose br $ map packMat $ toList $ dm (isReversed b) (V.length (b_seq b)) of + Seek p pb -> upd_waiting (insert p pb) + Indel _ _ pb -> upd_active (pb:) + EndOfRead -> return () + loop) + + + -- Check /waiting/ queue. If there is anything waiting for the + -- current position, move it to /active/ queue. + fix $ \loop -> (viewMin <$> get_waiting) >>= mapM_ (\(mk,pb,w') -> + when (mk == po) $ do upd_active (pb:) + upd_waiting (const w') + loop) + + -- Scan /active/ queue and make a 'BasePile'. Also see what's next in the + -- 'PrimChunks': 'Indel's contribute to an 'IndelPile', 'Seek's and + -- deletions are pushed back to the /waiting/ queue, 'EndOfRead's are + -- removed, and everything else is added to the fresh /active/ queue. + ((fin_bs, fin_bp), (fin_is, fin_ip)) <- consume_active (mempty, mempty) $ + \(!bpile, !ipile) (Base wt qs mq str pchunks) -> + let put (Q q) x (!st,!vs) = ( st { read_depth = read_depth st + 1 + , reads_mapq0 = reads_mapq0 st + (if q == 0 then 1 else 0) + , sum_mapq = sum_mapq st + fromIntegral q + , sum_mapq_squared = sum_mapq_squared st + fromIntegral q * fromIntegral q } + , (Q q, x) : vs ) + b' = Base (wt-1) qs mq str pchunks + put' = put mq (if str then Left qs else Right qs) + in case pchunks of + _ | wt > 0 -> do upd_active (b' :) ; return ( bpile, ipile ) + Seek p' pb' -> do upd_waiting (insert p' pb') ; return ( put' bpile, ipile ) + Indel del ins pb' -> do upd_active (pb' :) ; return ( put' bpile, put mq (del,ins) ipile ) + EndOfRead -> do return ( put' bpile, ipile ) + + -- We just reversed /active/ inplicitly, which is no desaster, but may come + -- as a surprise downstream. So reverse it back. + upd_active reverse + + -- Output, but don't bother emitting empty piles. Note that a plain + -- basecall still yields an entry in the 'IndelPile'. This is necessary, + -- because actual indel calling will want to know how many reads /did not/ + -- show the variant. However, if no reads show any variant, and here is the + -- first place where we notice that, the pile is useless. + let uninteresting (_,(d,i)) = d == 0 && null i + + unless (null fin_bp && all uninteresting fin_ip) + $ yield $ Pile rs po fin_bs (partitionPairEithers fin_bp) fin_is fin_ip + + -- Bump coordinate and loop. (Note that the bump to the next + -- reference /sequence/ is done implicitly, because we will run out of + -- reads and restart in 'pileup''.) + upd_pos succ + pileup' + +partitionPairEithers :: [(a, Either b c)] -> ([(a,b)], [(a,c)]) +partitionPairEithers = foldr either' ([],[]) + where + either' (a, Left b) = left a b + either' (a, Right c) = right a c + + left a b ~(l, r) = ((a,b):l, r) + right a c ~(l, r) = (l, (a,c):r) + +-- | We need a simple priority queue. Here's a skew heap (specialized +-- to strict 'Int' priorities and 'PrimBase' values). +data Heap = Empty | Node {-# UNPACK #-} !Int {-# UNPACK #-} !PrimBase Heap Heap + +union :: Heap -> Heap -> Heap +Empty `union` t2 = t2 +t1 `union` Empty = t1 +t1@(Node k1 x1 l1 r1) `union` t2@(Node k2 x2 l2 r2) + | k1 <= k2 = Node k1 x1 (t2 `union` r1) l1 + | otherwise = Node k2 x2 (t1 `union` r2) l2 + +insert :: Int -> PrimBase -> Heap -> Heap +insert k v heap = Node k v Empty Empty `union` heap + +getMinKey :: Heap -> Maybe Int +getMinKey Empty = Nothing +getMinKey (Node x _ _ _) = Just x + +viewMin :: Heap -> Maybe (Int, PrimBase, Heap) +viewMin Empty = Nothing +viewMin (Node k v l r) = Just (k, v, l `union` r) + diff --git a/src/Bio/Bam/Reader.hs b/src/Bio/Bam/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Reader.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings, FlexibleContexts #-} +module Bio.Bam.Reader ( + Block(..), + decompressBgzfBlocks, + decompressBgzf, + compressBgzf, + + decodeBam, + getBamRaw, + decodeAnyBam, + decodeAnyBamFile, + + BamrawEnumeratee, + BamEnumeratee, + isBamOrSam, + + isBam, + isPlainBam, + isGzipBam, + isBgzfBam, + + decodeSam, + decodeSam', + + decodeAnyBamOrSam, + decodeAnyBamOrSamFile, + + concatInputs, + concatDefaultInputs, + mergeInputs, + mergeDefaultInputs, + combineCoordinates, + combineNames, + ) where + +import Bio.Base +import Bio.Bam.Header +import Bio.Bam.Rec +import Bio.Iteratee +import Bio.Iteratee.Bgzf +import Bio.Iteratee.ZLib hiding ( CompressionLevel ) + +import Control.Applicative +import Control.Arrow ( (&&&) ) +import Control.Monad +import Data.Attoparsec.ByteString ( anyWord8 ) +import Data.Char ( digitToInt ) +import Data.Monoid +import Data.Sequence ( (|>) ) +import Data.String ( fromString ) +import System.Environment ( getArgs ) + +import qualified Data.Attoparsec.ByteString.Char8 as P +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S +import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as M +import qualified Data.Sequence as Z +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as U + +-- ^ Parsers for BAM and SAM. We employ an @Iteratee@ interface, and we +-- strive to support everything possible in BAM. The implementation of +-- nucleotides is somewhat lacking: the "=" symbol is not understood. +-- +-- TONOTDO: +-- - Reader for gzipped/bzipped/bgzf'ed SAM. Storing SAM is a bad idea, +-- so why would anyone ever want to compress, much less index it? + +type ByteString = B.ByteString +type BamrawEnumeratee m b = Enumeratee' BamMeta S.ByteString [BamRaw] m b +type BamEnumeratee m b = Enumeratee' BamMeta ByteString [BamRec] m b + +isBamOrSam :: MonadIO m => Iteratee ByteString m (BamEnumeratee m a) +isBamOrSam = maybe decodeSam wrap `liftM` isBam + where + wrap enee it' = enee (\hdr -> mapStream unpackBam (it' hdr)) >>= lift . run + + +-- | Checks if a file contains BAM in any of the common forms, +-- then decompresses it appropriately. If the stream doesn't contain +-- BAM at all, it is instead decoded as SAM. Since SAM is next to +-- impossible to recognize reliably, we don't even try. Any old junk is +-- decoded as SAM and will fail later. +decodeAnyBamOrSam :: MonadIO m => BamEnumeratee m a +decodeAnyBamOrSam it = isBamOrSam >>= \k -> k it + +decodeAnyBamOrSamFile :: (MonadIO m, MonadMask m) + => FilePath -> (BamMeta -> Iteratee [BamRec] m a) -> m (Iteratee [BamRec] m a) +decodeAnyBamOrSamFile fn k = enumFileRandom defaultBufSize fn (decodeAnyBamOrSam k) >>= run + +-- | Iteratee-style parser for SAM files, designed to be compatible with +-- the BAM parsers. Parses plain uncompressed SAM, nothing else. Since +-- it is supposed to work the same way as the BAM parser, it requires +-- the presense of the SQ header lines. These are stripped from the +-- header text and turned into the symbol table. +decodeSam :: Monad m => (BamMeta -> Iteratee [BamRec] m a) -> Iteratee ByteString m (Iteratee [BamRec] m a) +decodeSam inner = joinI $ enumLinesBS $ do + let pHeaderLine acc str = case P.parseOnly parseBamMetaLine str of Right f -> return $ f : acc + Left e -> fail $ e ++ ", " ++ show str + meta <- liftM (foldr ($) mempty . reverse) (joinI $ breakE (not . S.isPrefixOf "@") $ foldStreamM pHeaderLine []) + decodeSamLoop (meta_refs meta) (inner meta) + +decodeSamLoop :: Monad m => Refs -> Enumeratee [ByteString] [BamRec] m a +decodeSamLoop refs inner = convStream (liftI parse_record) inner + where !refs' = M.fromList $ zip [ nm | BamSQ { sq_name = nm } <- F.toList refs ] [toEnum 0..] + ref x = M.lookupDefault invalidRefseq x refs' + + parse_record (EOF x) = icont parse_record x + parse_record (Chunk []) = liftI parse_record + parse_record (Chunk (l:ls)) | "@" `S.isPrefixOf` l = parse_record (Chunk ls) + parse_record (Chunk (l:ls)) = case P.parseOnly (parseSamRec ref) l of + Right r -> idone [r] (Chunk ls) + Left err -> icont parse_record (Just $ iterStrExc $ err ++ ", " ++ show l) + +-- | Parser for SAM that doesn't look for a header. Has the advantage +-- that it doesn't stall on a pipe that never delivers data. Has the +-- disadvantage that it never reads the header and therefore needs a +-- list of allowed RNAMEs. +decodeSam' :: Monad m => Refs -> Enumeratee ByteString [BamRec] m a +decodeSam' refs inner = joinI $ enumLinesBS $ decodeSamLoop refs inner + +parseSamRec :: (ByteString -> Refseq) -> P.Parser BamRec +parseSamRec ref = mkBamRec + <$> word <*> num <*> (ref <$> word) <*> (subtract 1 <$> num) + <*> (Q <$> num') <*> (VS.fromList <$> cigar) <*> rnext <*> (subtract 1 <$> num) + <*> snum <*> sequ <*> quals <*> exts <*> pure 0 + where + sep = P.endOfInput <|> () <$ P.char '\t' + word = P.takeTill ((==) '\t') <* sep + num = P.decimal <* sep + num' = P.decimal <* sep + snum = P.signed P.decimal <* sep + + rnext = id <$ P.char '=' <* sep <|> const . ref <$> word + sequ = {-# SCC "parseSamRec/sequ" #-} + (V.empty <$ P.char '*' <|> + V.fromList . map toNucleotides . S.unpack <$> P.takeWhile is_nuc) <* sep + + quals = {-# SCC "parseSamRec/quals" #-} defaultQs <$ P.char '*' <* sep <|> bsToVec <$> word + where + defaultQs sq = VS.replicate (V.length sq) (Q 0xff) + bsToVec qs _ = VS.fromList . map (Q . subtract 33) $ B.unpack qs + + cigar = [] <$ P.char '*' <* sep <|> + P.manyTill (flip (:*) <$> P.decimal <*> cigop) sep + + cigop = P.choice $ zipWith (\c r -> r <$ P.char c) "MIDNSHP" [Mat,Ins,Del,Nop,SMa,HMa,Pad] + exts = ext `P.sepBy` sep + ext = (\a b v -> (fromString [a,b],v)) <$> P.anyChar <*> P.anyChar <*> (P.char ':' *> value) + + value = P.char 'A' *> P.char ':' *> (Char <$> anyWord8) <|> + P.char 'i' *> P.char ':' *> (Int <$> P.signed P.decimal) <|> + P.char 'Z' *> P.char ':' *> (Text <$> P.takeTill ((==) '\t')) <|> + P.char 'H' *> P.char ':' *> (Bin <$> hexarray) <|> + P.char 'f' *> P.char ':' *> (Float . realToFrac <$> P.double) <|> + P.char 'B' *> P.char ':' *> ( + P.satisfy (P.inClass "cCsSiI") *> (intArr <$> many (P.char ',' *> P.signed P.decimal)) <|> + P.char 'f' *> (floatArr <$> many (P.char ',' *> P.double))) + + intArr is = IntArr $ U.fromList is + floatArr fs = FloatArr $ U.fromList $ map realToFrac fs + hexarray = B.pack . repack . S.unpack <$> P.takeWhile (P.inClass "0-9A-Fa-f") + repack (a:b:cs) = fromIntegral (digitToInt a * 16 + digitToInt b) : repack cs ; repack _ = [] + is_nuc = P.inClass "acgtswkmrybdhvnACGTSWKMRYBDHVN" + + mkBamRec nm fl rn po mq cg rn' mp is sq qs' = + BamRec nm fl rn po mq cg (rn' rn) mp is sq (qs' sq) + +-- | Tests if a data stream is a Bam file. +-- Recognizes plain Bam, gzipped Bam and bgzf'd Bam. If a file is +-- recognized as Bam, a decoder (suitable Enumeratee) for it is +-- returned. This uses 'iLookAhead' internally, so it shouldn't consume +-- anything from the stream. +isBam, isEmptyBam, isPlainBam, isBgzfBam, isGzipBam :: MonadIO m + => Iteratee S.ByteString m (Maybe (BamrawEnumeratee m a)) +isBam = firstOf [ isEmptyBam, isPlainBam, isBgzfBam, isGzipBam ] + where + firstOf [] = return Nothing + firstOf (k:ks) = iLookAhead k >>= maybe (firstOf ks) (return . Just) + +isEmptyBam = (\e -> if e then Just (\k -> return $ k mempty) else Nothing) `liftM` isFinished + +isPlainBam = (\n -> if n == 4 then Just (joinI . decompressPlain . decodeBam) else Nothing) `liftM` heads "BAM\SOH" + +-- Interesting... iLookAhead interacts badly with the parallel +-- decompression of BGZF. (The chosen interface doesn't allow the EOF +-- signal to be passed on.) One workaround would be to run sequential +-- BGZF decompression to check if the content is BAM, but since BGZF is +-- actually GZip in disguise, the easier workaround if to use the +-- ordinary GZip decompressor. +-- (A clean workaround would be an @Alternative@ instance for +-- @Iteratee@.) +isBgzfBam = do b <- isBgzf + k <- if b then joinI $ enumInflate GZip defaultDecompressParams isPlainBam else return Nothing + return $ (\_ -> (joinI . decompressBgzfBlocks . decodeBam)) `fmap` k + +isGzipBam = do b <- isGzip + k <- if b then joinI $ enumInflate GZip defaultDecompressParams isPlainBam else return Nothing + return $ ((joinI . enumInflate GZip defaultDecompressParams) .) `fmap` k + +-- | Checks if a file contains BAM in any of the common forms, then +-- decompresses it appropriately. We support plain BAM, Bgzf'd BAM, +-- and Gzip'ed BAM. +-- +-- The recommendation for these functions is to use @decodeAnyBam@ (or +-- @decodeAnyBamFile@) for any code that can handle @BamRaw@ input, but +-- @decodeAnyBamOrSam@ (or @decodeAnyBamOrSamFile@) for code that needs +-- @BamRec@. That way, SAM is supported automatically, and seeking will +-- be supported if possible. +decodeAnyBam :: MonadIO m => BamrawEnumeratee m a +decodeAnyBam it = do mk <- isBam ; case mk of Just k -> k it + Nothing -> fail "this isn't BAM." + +decodeAnyBamFile :: (MonadIO m, MonadMask m) => FilePath -> (BamMeta -> Iteratee [BamRaw] m a) -> m (Iteratee [BamRaw] m a) +decodeAnyBamFile fn k = enumFileRandom defaultBufSize fn (decodeAnyBam k) >>= run + +concatDefaultInputs :: (MonadIO m, MonadMask m) => Enumerator' BamMeta [BamRaw] m a +concatDefaultInputs it0 = liftIO getArgs >>= \fs -> concatInputs fs it0 + +concatInputs :: (MonadIO m, MonadMask m) => [FilePath] -> Enumerator' BamMeta [BamRaw] m a +concatInputs [ ] = \k -> enumHandle defaultBufSize stdin (decodeAnyBam k) >>= run +concatInputs (fp0:fps0) = \k -> enum1 fp0 k >>= go fps0 + where + enum1 "-" k1 = enumHandle defaultBufSize stdin (decodeAnyBam k1) >>= run + enum1 fp k1 = enumFile defaultBufSize fp (decodeAnyBam k1) >>= run + + go [ ] = return + go (fp1:fps) = enum1 fp1 . const >=> go fps + +mergeDefaultInputs :: (MonadIO m, MonadMask m) + => (BamMeta -> Enumeratee [BamRaw] [BamRaw] (Iteratee [BamRaw] m) a) + -> Enumerator' BamMeta [BamRaw] m a +mergeDefaultInputs (?) it0 = liftIO getArgs >>= \fs -> mergeInputs (?) fs it0 + +mergeInputs :: (MonadIO m, MonadMask m) + => (BamMeta -> Enumeratee [BamRaw] [BamRaw] (Iteratee [BamRaw] m) a) + -> [FilePath] -> Enumerator' BamMeta [BamRaw] m a +mergeInputs _ [ ] = \k -> enumHandle defaultBufSize stdin (decodeAnyBam k) >>= run +mergeInputs (?) (fp0:fps0) = go fp0 fps0 + where + enum1 "-" k1 = enumHandle defaultBufSize stdin (decodeAnyBam k1) >>= run + enum1 fp k1 = enumFile defaultBufSize fp (decodeAnyBam k1) >>= run + + go fp [ ] = enum1 fp + go fp (fp1:fps) = mergeEnums' (go fp1 fps) (enum1 fp) (?) + +{-# INLINE combineCoordinates #-} +combineCoordinates :: Monad m => BamMeta -> Enumeratee [BamRaw] [BamRaw] (Iteratee [BamRaw] m) a +combineCoordinates _ = mergeSortStreams (?) + where u ? v = if (b_rname &&& b_pos) (unpackBam u) < (b_rname &&& b_pos) (unpackBam v) then Less else NotLess + +{-# INLINE combineNames #-} +combineNames :: Monad m => BamMeta -> Enumeratee [BamRaw] [BamRaw] (Iteratee [BamRaw] m) a +combineNames _ = mergeSortStreams (?) + where u ? v = case b_qname (unpackBam u) `compareNames` b_qname (unpackBam v) of LT -> Less ; _ -> NotLess + +-- | Decode a BAM stream into raw entries. Note that the entries can be +-- unpacked using @decodeBamEntry@. Also note that this is an +-- Enumeratee in spirit, only the @BamMeta@ and @Refs@ need to get +-- passed separately. +{-# INLINE decodeBam #-} +decodeBam :: Monad m => (BamMeta -> Iteratee [BamRaw] m a) -> Iteratee Block m (Iteratee [BamRaw] m a) +decodeBam inner = do meta <- liftBlock get_bam_header + refs <- liftBlock get_ref_array + convStream getBamRaw $ inner $! merge meta refs + where + get_bam_header = do magic <- heads "BAM\SOH" + when (magic /= 4) $ do s <- iGetString 10 + fail $ "BAM signature not found: " ++ show magic ++ " " ++ show s + hdr_len <- endianRead4 LSB + joinI $ takeStream (fromIntegral hdr_len) $ parserToIteratee parseBamMeta + + get_ref_array = do nref <- endianRead4 LSB + foldM (\acc _ -> do + nm <- endianRead4 LSB >>= iGetString . fromIntegral + ln <- endianRead4 LSB + return $! acc |> BamSQ (S.init nm) (fromIntegral ln) [] + ) Z.empty $ [1..nref] + + -- Need to merge information from header into actual reference list. + -- The latter is the authoritative source for the *order* of the + -- sequences, so leftovers from the header are discarded. Merging + -- is by name. So we merge information from the header into the + -- list, then replace the header information. + merge meta refs = + let tbl = M.fromList [ (sq_name sq, sq) | sq <- F.toList (meta_refs meta) ] + in meta { meta_refs = fmap (\s -> maybe s (merge' s) (M.lookup (sq_name s) tbl)) refs } + + merge' l r | sq_length l == sq_length r = l { sq_other_shit = sq_other_shit l ++ sq_other_shit r } + | otherwise = l -- contradiction in header, but we'll just ignore it + + +{-# INLINE getBamRaw #-} +getBamRaw :: Monad m => Iteratee Block m [BamRaw] +getBamRaw = do off <- getOffset + raw <- liftBlock $ do + bsize <- endianRead4 LSB + when (bsize < 32) $ fail "short BAM record" + iGetString (fromIntegral bsize) + return [bamRaw off raw] diff --git a/src/Bio/Bam/Rec.hs b/src/Bio/Bam/Rec.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Rec.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE OverloadedStrings, PatternGuards, BangPatterns #-} +{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE RecordWildCards, TypeFamilies, MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Parsers and Printers for BAM and SAM. We employ an @Iteratee@ +-- interface, and we strive to support everything possible in BAM. So +-- far, the implementation of the nucleotides is somewhat lacking: we +-- do not have support for ambiguity codes, and the "=" symbol is not +-- understood. + +-- TODO: +-- - Automatic creation of some kind of index. If possible, this should +-- be the standard index for sorted BAM and/or the newer CSI format. +-- Optionally, a block index for slicing of large files, even unsorted +-- ones. Maybe an index by name and an index for group-sorted files. +-- Sensible indices should be generated whenever a file is written. +-- - Same for statistics. Something like "flagstats" could always be +-- written. Actually, having @writeBamHandle@ return enhanced +-- flagstats as a result might be even better. +-- + +module Bio.Bam.Rec ( + BamRaw, + bamRaw, + virt_offset, + raw_data, + + BamRec(..), + unpackBam, + nullBamRec, + getMd, + + Cigar(..), + CigOp(..), + alignedLength, + + Nucleotides(..), Vector_Nucs_half, + Extensions, Ext(..), + extAsInt, extAsString, setQualFlag, + deleteE, insertE, updateE, adjustE, + + isPaired, + isProperlyPaired, + isUnmapped, + isMateUnmapped, + isReversed, + isMateReversed, + isFirstMate, + isSecondMate, + isAuxillary, + isFailsQC, + isDuplicate, + isTrimmed, + isMerged, + type_mask, + + progressPos, + Word32 +) where + +import Bio.Base +import Bio.Bam.Header +import Bio.Iteratee +import Bio.Util ( showNum ) + +import Control.Monad +import Control.Monad.Primitive ( unsafePrimToPrim, unsafeInlineIO ) +import Control.Applicative +import Data.Bits ( Bits, testBit, shiftL, shiftR, (.&.), (.|.) ) +import Data.ByteString ( ByteString ) +import Data.Int ( Int32, Int16, Int8 ) +import Data.Ix +import Data.String ( fromString ) +import Data.Word ( Word32, Word16 ) +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Storable ( peek, poke, peekByteOff, pokeByteOff, Storable(..) ) +import System.IO.Unsafe ( unsafeDupablePerformIO ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as VM +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as U + + +-- | Cigar line in BAM coding +-- Bam encodes an operation and a length into a single integer, we keep +-- those integers in an array. +data Cigar = !CigOp :* !Int deriving (Eq, Ord) +infix 9 :* + +data CigOp = Mat | Ins | Del | Nop | SMa | HMa | Pad + deriving ( Eq, Ord, Enum, Show, Bounded, Ix ) + +instance Show Cigar where + showsPrec _ (op :* num) = shows num . (:) (S.index "MIDNSHP" (fromEnum op)) + +instance Storable Cigar where + sizeOf _ = 4 + alignment _ = 1 + + peek p = do w0 <- peekByteOff p 0 :: IO Word8 + w1 <- peekByteOff p 1 :: IO Word8 + w2 <- peekByteOff p 2 :: IO Word8 + w3 <- peekByteOff p 3 :: IO Word8 + let w = fromIntegral w0 `shiftL` 0 .|. fromIntegral w1 `shiftL` 8 .|. + fromIntegral w2 `shiftL` 16 .|. fromIntegral w3 `shiftL` 24 + return $ toEnum (w .&. 0xf) :* shiftR w 4 + + poke p (op :* num) = do pokeByteOff p 0 (fromIntegral $ shiftR w 0 :: Word8) + pokeByteOff p 1 (fromIntegral $ shiftR w 8 :: Word8) + pokeByteOff p 2 (fromIntegral $ shiftR w 16 :: Word8) + pokeByteOff p 3 (fromIntegral $ shiftR w 24 :: Word8) + where + w = fromEnum op .|. shiftL num 4 + +-- | extracts the aligned length from a cigar line +-- This gives the length of an alignment as measured on the reference, +-- which is different from the length on the query or the length of the +-- alignment. +{-# INLINE alignedLength #-} +alignedLength :: V.Vector v Cigar => v Cigar -> Int +alignedLength = V.foldl' (\a -> (a +) . l) 0 + where l (op :* n) = if op == Mat || op == Del || op == Nop then n else 0 + + +-- | internal representation of a BAM record +data BamRec = BamRec { + b_qname :: Seqid, + b_flag :: Int, + b_rname :: Refseq, + b_pos :: Int, + b_mapq :: Qual, + b_cigar :: VS.Vector Cigar, + b_mrnm :: Refseq, + b_mpos :: Int, + b_isize :: Int, + b_seq :: Vector_Nucs_half Nucleotides, + b_qual :: VS.Vector Qual, + b_exts :: Extensions, + b_virtual_offset :: FileOffset -- ^ virtual offset for indexing purposes + } deriving Show + +nullBamRec :: BamRec +nullBamRec = BamRec { + b_qname = S.empty, + b_flag = flagUnmapped, + b_rname = invalidRefseq, + b_pos = invalidPos, + b_mapq = Q 0, + b_cigar = VS.empty, + b_mrnm = invalidRefseq, + b_mpos = invalidPos, + b_isize = 0, + b_seq = V.empty, + b_qual = VS.empty, + b_exts = [], + b_virtual_offset = 0 + } + +getMd :: BamRec -> Maybe [MdOp] +getMd r = case lookup "MD" $ b_exts r of + Just (Text mdfield) -> readMd mdfield + Just (Char mdfield) -> readMd $ B.singleton mdfield + _ -> Nothing + +-- | A vector that packs two 'Nucleotides' into one byte, just like Bam does. +data Vector_Nucs_half a = Vector_Nucs_half !Int !Int !(ForeignPtr Word8) + +-- | A mutable vector that packs two 'Nucleotides' into one byte, just like Bam does. +data MVector_Nucs_half s a = MVector_Nucs_half !Int !Int !(ForeignPtr Word8) + +type instance V.Mutable Vector_Nucs_half = MVector_Nucs_half + +instance V.Vector Vector_Nucs_half Nucleotides where + basicUnsafeFreeze (MVector_Nucs_half o l fp) = return $ Vector_Nucs_half o l fp + basicUnsafeThaw (Vector_Nucs_half o l fp) = return $ MVector_Nucs_half o l fp + + basicLength (Vector_Nucs_half _ l _) = l + basicUnsafeSlice s l (Vector_Nucs_half o _ fp) = Vector_Nucs_half (o + s) l fp + + basicUnsafeIndexM (Vector_Nucs_half o _ fp) i + | even (o+i) = return . Ns $ (b `shiftR` 4) .&. 0xF + | otherwise = return . Ns $ b .&. 0xF + where !b = unsafeInlineIO $ withForeignPtr fp $ \p -> peekByteOff p ((o+i) `shiftR` 1) + +instance VM.MVector MVector_Nucs_half Nucleotides where + basicLength (MVector_Nucs_half _ l _) = l + basicUnsafeSlice s l (MVector_Nucs_half o _ fp) = MVector_Nucs_half (o + s) l fp + + basicOverlaps (MVector_Nucs_half _ _ fp1) (MVector_Nucs_half _ _ fp2) = fp1 == fp2 + basicUnsafeNew l = unsafePrimToPrim $ MVector_Nucs_half 0 l <$> mallocForeignPtrBytes ((l+1) `shiftR` 1) + + basicUnsafeRead (MVector_Nucs_half o _ fp) i + | even (o+i) = liftM (Ns . (.&.) 0xF . (`shiftR` 4)) b + | otherwise = liftM (Ns . (.&.) 0xF ) b + where b = unsafePrimToPrim $ withForeignPtr fp $ \p -> peekByteOff p ((o+i) `shiftR` 1) + + basicUnsafeWrite (MVector_Nucs_half o _ fp) i (Ns x) = + unsafePrimToPrim $ withForeignPtr fp $ \p -> do + y <- peekByteOff p ((o+i) `shiftR` 1) + let y' | even (o+i) = x `shiftL` 4 .|. y .&. 0x0F + | otherwise = x .|. y .&. 0xF0 + pokeByteOff p ((o+i) `shiftR` 1) y' + +instance Show (Vector_Nucs_half Nucleotides) where + show = show . V.toList + +-- | Bam record in its native encoding along with virtual address. +data BamRaw = BamRaw { virt_offset :: {-# UNPACK #-} !FileOffset + , raw_data :: {-# UNPACK #-} !S.ByteString } + +-- | Smart constructor. Makes sure we got a at least a full record. +{-# INLINE bamRaw #-} +bamRaw :: FileOffset -> S.ByteString -> BamRaw +bamRaw o s = if good then BamRaw o s else error $ "broken BAM record " ++ show (S.length s, m) ++ show m + where + good | S.length s < 32 = False + | otherwise = S.length s >= sum m + m = [ 32, l_rnm, l_seq, (l_seq+1) `div` 2, l_cig * 4 ] + l_rnm = fromIntegral (B.unsafeIndex s 8) - 1 + l_cig = fromIntegral (B.unsafeIndex s 12) .|. fromIntegral (B.unsafeIndex s 13) `shiftL` 8 + l_seq = fromIntegral (B.unsafeIndex s 16) .|. fromIntegral (B.unsafeIndex s 17) `shiftL` 8 .|. + fromIntegral (B.unsafeIndex s 18) `shiftL` 16 .|. fromIntegral (B.unsafeIndex s 19) `shiftL` 24 + +{-# INLINE[1] unpackBam #-} +unpackBam :: BamRaw -> BamRec +unpackBam br = BamRec { + b_rname = Refseq $ getInt32 0, + b_pos = getInt32 4, + b_mapq = Q $ getInt8 9, + b_flag = getInt16 14, + b_mrnm = Refseq $ getInt32 20, + b_mpos = getInt32 24, + b_isize = fromIntegral (getInt32 28 :: Int32), + + b_qname = B.unsafeTake l_read_name $ B.unsafeDrop 32 $ raw_data br, + b_cigar = VS.unsafeCast $ VS.unsafeFromForeignPtr fp (off0+off_c) (4*l_cigar), + b_seq = Vector_Nucs_half (2 * (off_s+off0)) l_seq fp, + b_qual = VS.unsafeCast $ VS.unsafeFromForeignPtr fp (off0+off_q) l_seq, + + b_exts = unpackExtensions $ S.drop off_e $ raw_data br, + b_virtual_offset = virt_offset br } + where + (fp, off0, _) = B.toForeignPtr $ raw_data br + off_c = 33 + l_read_name + off_s = off_c + 4 * l_cigar + off_q = off_s + (l_seq + 1) `div` 2 + off_e = off_q + l_seq + + l_read_name = getInt8 8 - 1 + l_seq = getInt32 16 + l_cigar = getInt16 12 + + getInt8 :: (Num a, Bits a) => Int -> a + getInt8 o = fromIntegral (B.unsafeIndex (raw_data br) o) + + getInt16 :: (Num a, Bits a) => Int -> a + getInt16 o = fromIntegral (B.unsafeIndex (raw_data br) o) .|. + fromIntegral (B.unsafeIndex (raw_data br) $ o+1) `shiftL` 8 + + getInt32 :: (Num a, Bits a) => Int -> a + getInt32 o = fromIntegral (B.unsafeIndex (raw_data br) $ o+0) .|. + fromIntegral (B.unsafeIndex (raw_data br) $ o+1) `shiftL` 8 .|. + fromIntegral (B.unsafeIndex (raw_data br) $ o+2) `shiftL` 16 .|. + fromIntegral (B.unsafeIndex (raw_data br) $ o+3) `shiftL` 24 + +-- | A collection of extension fields. The key is actually only two @Char@s, but that proved impractical. +-- (Hmm... we could introduce a Key type that is a 16 bit int, then give +-- it an @instance IsString@... practical?) +type Extensions = [( BamKey, Ext )] + +-- | Deletes all occurences of some extension field. +deleteE :: BamKey -> Extensions -> Extensions +deleteE k = filter ((/=) k . fst) + +-- | Blindly inserts an extension field. This can create duplicates +-- (and there is no telling how other tools react to that). +insertE :: BamKey -> Ext -> Extensions -> Extensions +insertE k v = (:) (k,v) + +-- | Deletes all occurences of an extension field, then inserts it with +-- a new value. This is safer than 'insertE', but also more expensive. +updateE :: BamKey -> Ext -> Extensions -> Extensions +updateE k v = insertE k v . deleteE k + +-- | Adjusts a named extension by applying a function. +adjustE :: (Ext -> Ext) -> BamKey -> Extensions -> Extensions +adjustE _ _ [ ] = [] +adjustE f k ((k',v):es) | k == k' = (k', f v) : es + | otherwise = (k', v) : adjustE f k es + +data Ext = Int Int | Float Float | Text ByteString | Bin ByteString | Char Word8 + | IntArr (U.Vector Int) | FloatArr (U.Vector Float) + deriving (Show, Eq, Ord) + +{-# INLINE unpackExtensions #-} +unpackExtensions :: ByteString -> Extensions +unpackExtensions = go + where + go s | S.length s < 4 = [] + | otherwise = let key = fromString [ S.index s 0, S.index s 1 ] + in case S.index s 2 of + 'Z' -> case S.break (== '\0') (S.drop 3 s) of (l,r) -> (key, Text l) : go (S.drop 1 r) + 'H' -> case S.break (== '\0') (S.drop 3 s) of (l,r) -> (key, Bin l) : go (S.drop 1 r) + 'A' -> (key, Char (B.index s 3)) : go (S.drop 4 s) + 'B' -> let tp = S.index s 3 + n = getInt 'I' (S.drop 4 s) + in case tp of + 'f' -> (key, FloatArr (U.fromListN (n+1) [ getFloat (S.drop i s) | i <- [8, 12 ..] ])) + : go (S.drop (12+4*n) s) + _ -> (key, IntArr (U.fromListN (n+1) [ getInt tp (S.drop i s) | i <- [8, 8 + size tp ..] ])) + : go (S.drop (8 + size tp * (n+1)) s) + 'f' -> (key, Float (getFloat (S.drop 3 s))) : go (S.drop 7 s) + tp -> (key, Int (getInt tp (S.drop 3 s))) : go (S.drop (3 + size tp) s) + + size 'C' = 1 + size 'c' = 1 + size 'S' = 2 + size 's' = 2 + size 'I' = 4 + size 'i' = 4 + size 'f' = 4 + size _ = 0 + + getInt 'C' s | S.length s >= 1 = fromIntegral (fromIntegral (B.index s 0) :: Word8) + getInt 'c' s | S.length s >= 1 = fromIntegral (fromIntegral (B.index s 0) :: Int8) + getInt 'S' s | S.length s >= 2 = fromIntegral (i :: Word16) + where i = fromIntegral (B.index s 0) .|. fromIntegral (B.index s 1) `shiftL` 8 + getInt 's' s | S.length s >= 2 = fromIntegral (i :: Int16) + where i = fromIntegral (B.index s 0) .|. fromIntegral (B.index s 1) `shiftL` 8 + getInt 'I' s | S.length s >= 4 = fromIntegral (i :: Word32) + where i = fromIntegral (B.index s 0) .|. fromIntegral (B.index s 1) `shiftL` 8 .|. + fromIntegral (B.index s 2) `shiftL` 16 .|. fromIntegral (B.index s 3) `shiftL` 24 + getInt 'i' s | S.length s >= 4 = fromIntegral (i :: Int32) + where i = fromIntegral (B.index s 0) .|. fromIntegral (B.index s 1) `shiftL` 8 .|. + fromIntegral (B.index s 2) `shiftL` 16 .|. fromIntegral (B.index s 3) `shiftL` 24 + getInt _ _ = 0 + + getFloat s = unsafeDupablePerformIO $ alloca $ \buf -> + pokeByteOff buf 0 (getInt 'I' s :: Word32) >> peek buf + + +isPaired, isProperlyPaired, isUnmapped, isMateUnmapped, isReversed, + isMateReversed, isFirstMate, isSecondMate, isAuxillary, isFailsQC, + isDuplicate, isTrimmed, isMerged :: BamRec -> Bool + +isPaired = flip testBit 0 . b_flag +isProperlyPaired = flip testBit 1 . b_flag +isUnmapped = flip testBit 2 . b_flag +isMateUnmapped = flip testBit 3 . b_flag +isReversed = flip testBit 4 . b_flag +isMateReversed = flip testBit 5 . b_flag +isFirstMate = flip testBit 6 . b_flag +isSecondMate = flip testBit 7 . b_flag +isAuxillary = flip testBit 8 . b_flag +isFailsQC = flip testBit 9 . b_flag +isDuplicate = flip testBit 10 . b_flag +isTrimmed = flip testBit 16 . b_flag +isMerged = flip testBit 17 . b_flag + +type_mask :: Int +type_mask = flagFirstMate .|. flagSecondMate .|. flagPaired + +extAsInt :: Int -> BamKey -> BamRec -> Int +extAsInt d nm br = case lookup nm (b_exts br) of Just (Int i) -> i ; _ -> d + +extAsString :: BamKey -> BamRec -> ByteString +extAsString nm br = case lookup nm (b_exts br) of + Just (Char c) -> B.singleton c + Just (Text s) -> s + _ -> B.empty + +setQualFlag :: Char -> BamRec -> BamRec +setQualFlag c br = br { b_exts = updateE "ZQ" (Text s') $ b_exts br } + where + s = extAsString "ZQ" br + s' = if c `S.elem` s then s else c `S.cons` s + +-- | A simple progress indicator that prints sequence id and position. +progressPos :: MonadIO m => String -> (String -> IO ()) -> Refs -> Enumeratee [BamRaw] [BamRaw] m a +progressPos msg put refs = eneeCheckIfDonePass (icont . go 0) + where + go !_ k (EOF mx) = idone (liftI k) (EOF mx) + go !n k (Chunk [ ]) = liftI $ go n k + go !n k (Chunk as@(a:_)) = do let !n' = n + length as + when (n `div` 65536 /= n' `div` 65536) $ liftIO $ do + let BamRec{..} = unpackBam a + nm = unpackSeqid (sq_name (getRef refs b_rname)) ++ ":" + put $ "\27[K" ++ msg ++ nm ++ showNum b_pos ++ "\r" + eneeCheckIfDonePass (icont . go n') . k $ Chunk as + diff --git a/src/Bio/Bam/Regions.hs b/src/Bio/Bam/Regions.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Regions.hs @@ -0,0 +1,49 @@ +module Bio.Bam.Regions where + +import Bio.Bam.Header ( Refseq(..) ) +import Data.List ( foldl' ) +import qualified Data.IntMap as IM + +data Region = Region { refseq :: !Refseq, start :: !Int, end :: !Int } + deriving (Eq, Ord, Show) + +-- | A subset of a genome. The idea is to map the reference sequence +-- (represented by its number) to a 'Subseqeunce'. +newtype Regions = Regions (IM.IntMap Subsequence) deriving Show + +-- | A mostly contiguous subset of a sequence, stored as a set of +-- non-overlapping intervals in an 'IntMap' from start position to end +-- position (half-open intervals, naturally). +newtype Subsequence = Subsequence (IM.IntMap Int) deriving Show + +toList :: Regions -> [(Refseq, Subsequence)] +toList (Regions m) = [ (Refseq $ fromIntegral k, v) | (k,v) <- IM.toList m ] + +fromList :: [Region] -> Regions +fromList = foldl' (flip add) (Regions IM.empty) + +add :: Region -> Regions -> Regions +add (Region (Refseq r) b e) (Regions m) = + let single = Just . Subsequence $ IM.singleton b e + in Regions $ IM.alter (maybe single (Just . addInt b e)) (fromIntegral r) m + + +addInt :: Int -> Int -> Subsequence -> Subsequence +addInt b e (Subsequence m0) = Subsequence $ merge_into b e m0 + where + merge_into x y m = case lookupLT y m of + Just (u,v) | x < u && y <= v -> merge_into x v $ IM.delete u m -- extend to the left + | x < u -> merge_into x y $ IM.delete u m -- subsume + | y <= v -> m -- subsumed + | x <= v -> merge_into u y $ IM.delete u m -- extend to the right + _ -> IM.insert x y m -- no overlap + +overlaps :: Int -> Int -> Subsequence -> Bool +overlaps b e (Subsequence m) = case lookupLT e m of + Just (_,v) -> b < v + Nothing -> False + +lookupLT :: IM.Key -> IM.IntMap a -> Maybe (IM.Key, a) +lookupLT k m | IM.null m1 = Nothing + | otherwise = Just $ IM.findMax m1 + where (m1,_) = IM.split k m diff --git a/src/Bio/Bam/Rmdup.hs b/src/Bio/Bam/Rmdup.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Rmdup.hs @@ -0,0 +1,692 @@ +{-# LANGUAGE ExistentialQuantification, RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings, BangPatterns, FlexibleContexts #-} +module Bio.Bam.Rmdup( + rmdup, Collapse, cons_collapse, cheap_collapse, + cons_collapse_keep, cheap_collapse_keep, + check_sort, normalizeTo, wrapTo + ) where + +import Bio.Bam.Header +import Bio.Bam.Rec +import Bio.Base +import Bio.Iteratee +import Control.Applicative +import Data.Bits +import Data.List +import Data.Ord ( comparing ) +import Data.String ( fromString ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as T +import qualified Data.Iteratee as I +import qualified Data.Map as M +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as U + +data Collapse = Collapse { + collapse :: [BamRec] -> (Decision,[BamRec]), -- cluster to consensus and stuff or representative and stuff + originals :: [BamRec] -> [BamRec] } -- treatment of the redundant original reads + +data Decision = Consensus { fromDecision :: BamRec } + | Representative { fromDecision :: BamRec } + +cons_collapse :: Qual -> Collapse +cons_collapse maxq = Collapse (do_collapse maxq) (const []) + +cons_collapse_keep :: Qual -> Collapse +cons_collapse_keep maxq = Collapse (do_collapse maxq) (map (\b -> b { b_flag = b_flag b .|. flagDuplicate })) + +cheap_collapse :: Collapse +cheap_collapse = Collapse do_cheap_collapse (const []) + +cheap_collapse_keep :: Collapse +cheap_collapse_keep = Collapse do_cheap_collapse (map (\b -> b { b_flag = b_flag b .|. flagDuplicate })) + + +-- | Removes duplicates from an aligned, sorted BAM stream. +-- +-- The incoming stream must be sorted by coordinate, and we check for +-- violations of that assumption. We cannot assume that length was +-- taken into account when sorting (samtools doesn't do so), so +-- duplicates may be separated by reads that start at the same position +-- but have different length or different strand. +-- +-- We are looking at three different kinds of reads: paired reads, true +-- single ended reads, merged or trimmed reads. They are somewhat +-- different, but here's the situation if we wanted to treat them +-- separately. These conditions define a set of duplicates: +-- +-- Merged or trimmed: We compare the leftmost coordinates and the +-- aligned length. If the library prep is strand-preserving, we also +-- compare the strand. +-- +-- Paired: We compare both left-most coordinates (b_pos and b_mpos). If +-- the library prep is strand-preserving, only first-mates can be +-- duplicates of first-mates. Else a first-mate can be the duplicate of +-- a second-mate. There may be pairs with one unmapped mate. This is +-- not a problem as they get assigned synthetic coordinates and will be +-- handled smoothly. +-- +-- True singles: We compare only the leftmost coordinate. It does not +-- matter if the library prep is strand-preserving, the strand always +-- matters. +-- +-- Across these classes, we can see more duplicates: +-- +-- Merged/trimmed and paired: these can be duplicates if the merging +-- failed for the pair. We would need to compare the outer coordinates +-- of the merged reads to the two 5' coordinates of the pair. However, +-- since we don't have access to the mate, we cannot actually do +-- anything right here. This case should be solved externally by +-- merging those pairs that overlap in coordinate space. +-- +-- Single and paired: in the single case, we only have one coordinate +-- to compare. This will inevitably lead to trouble, as we could find +-- that the single might be the duplicate of two pairs, but those two +-- pairs are definitely not duplicates of each other. We solve it by +-- removing the single read(s). +-- +-- Single and merged/trimmed: same trouble as in the single+paired +-- case. We remove the single to solve it. +-- +-- +-- In principle, we might want to allow some wiggle room in the +-- coordinates. So far, this has not been implemented. It adds the +-- complication that groups of separated reads can turn into a set of +-- duplicates because of the appearance of a new reads. Needs some +-- thinking about... or maybe it's not too important. +-- +-- Once a set of duplicates is collected, we perform a majority vote on +-- the correct CIGAR line. Of all those reads that agree on this CIGAR +-- line, a consensus is called, quality scores are adjusted and clamped +-- to a maximum, the MD field is updated and the XP field is assigned +-- the number of reads in the original cluster. The new MAPQ becomes +-- the RMSQ of the map qualities of all reads. +-- +-- Treatment of Read Groups: We generalize by providing a "label" +-- function; only reads that have the same label are considered +-- duplicates of each other. The typical label function would extract +-- read groups, libraries or samples. + +rmdup :: (Monad m, Ord l) => (BamRec -> l) -> Bool -> Collapse -> Enumeratee [BamRec] [BamRec] m r +rmdup label strand_preserved collapse_cfg = + -- Easiest way to go about this: We simply collect everything that + -- starts at some specific coordinate and group it appropriately. + -- Treat the groups separately, output, go on. + check_sort "input must be sorted for rmdup to work" ><> + mapGroups rmdup_group ><> + check_sort "internal error, output isn't sorted anymore" + where + rmdup_group = nice_sort . do_rmdup label strand_preserved collapse_cfg + same_pos u v = b_cpos u == b_cpos v + b_cpos u = (b_rname u, b_pos u) + + nice_sort x = sortBy (comparing (V.length . b_seq)) x + + mapGroups f o = I.tryHead >>= maybe (return o) (\a -> eneeCheckIfDone (mg1 f a []) o) + mg1 f a acc k = I.tryHead >>= \mb -> case mb of + Nothing -> return . k . Chunk . f $ a:acc + Just b | same_pos a b -> mg1 f a (b:acc) k + | otherwise -> eneeCheckIfDone (mg1 f b []) . k . Chunk . f $ a:acc + +check_sort :: Monad m => String -> Enumeratee [BamRec] [BamRec] m a +check_sort msg out = I.tryHead >>= maybe (return out) (\a -> eneeCheckIfDone (step a) out) + where + step a k = I.tryHead >>= maybe (return . k $ Chunk [a]) (step' a k) + step' a k b | (b_rname a, b_pos a) > (b_rname b, b_pos b) = fail $ "rmdup: " ++ msg + | otherwise = eneeCheckIfDone (step b) . k $ Chunk [a] + + +{- | Workhorse for duplicate removal. + + - Unmapped fragments should not be considered to be duplicates of + mapped fragments. The /unmapped/ flag can serve for that: while + there are two classes of /unmapped/ reads (those that are not mapped + and those that are mapped to an invalid position), the two sets will + always have different coordinates. (Unfortunately, correct duplicate + removal now relies on correct /unmapped/ and /mate unmapped/ flags, + and we don't get them from unmodified BWA. So correct operation + requires patched BWA or a run of @bam-fixpair@.) + + (1) Other definitions (e.g. lack of CIGAR) don't work, because that + information won't be available for the mate. + + (2) This would amount to making the /unmapped/ flag part of the + coordinate, but samtools is not going to take it into account + when sorting. + + (3) Instead, both flags become part of the /mate pos/ grouping + criterion. + + - First Mates should (probably) not be considered duplicates of Second + Mates. This is unconditionally true for libraries with A\/B-style + adapters (definitely 454, probably Mathias' ds protocol) and the ss + protocol, it is not true for fork adapter protocols (vanilla Illumina + protocol). So it has to be an option, which would ideally be derived + from header information. + + - This code ignores read groups, but it will do a majority vote on the + @RG@ field and call consensi for the index sequences. If you believe + that duplicates across read groups are impossible, you must call it + with an appropriately filtered stream. + + - Half-Aligned Pairs (meaning one known coordinate, while the validity + of the alignments is immaterial) are rather complicated: + + (1) Given that only one coordinate is known (5' of the aligned mate), + we want to treat them like true singles. But the unaligned mate + should be kept if possible, though it should not contribute to a + consensus sequence. We assume nothing about the unaligned mate, + not even that it /shouldn't/ be aligned, never mind the fact that + it /couldn't/ be. (The difference is in the finite abilities of + real world aligners, naturally.) + + (2) Therefore, aligned reads with unaligned mates go to the same + potential duplicate set as true singletons. If at least one pair + exists that might be a duplicate of those, all singletons and + half-aligned mates are discarded. Else a consensus is computed + and replaces the aligned mates. + + (3) The unaligned mates end up in the same place in a BAM stream as + the aligned mates (therefore we see them and can treat them + locally). We cannot call a consensus, since these molecules may + well have different length, so we select one. It doesn't really + matter which one is selected, and since we're treating both mates + at the same time, it doesn't even need to be reproducible without + local information. This is made to be the mate of the consensus. + + (4) See 'merge_singles' for how it's actually done. +-} + +do_rmdup :: Ord l => (BamRec -> l) -> Bool -> Collapse -> [BamRec] -> [BamRec] +do_rmdup label strand_preserved Collapse{..} = + concatMap do_rmdup1 . M.elems . accumMap label id + where + do_rmdup1 rds = results ++ originals (leftovers ++ r1 ++ r2 ++ r3) + where + (results, leftovers) = merge_singles singles' unaligned' $ + [ (str, fromDecision b) | ((_,str ),b) <- M.toList merged' ] ++ + [ (str, fromDecision b) | ((_,str,_),b) <- M.toList pairs' ] + + (raw_pairs, raw_singles) = partition isPaired rds + (merged, true_singles) = partition (liftA2 (||) isMerged isTrimmed) raw_singles + + (pairs, raw_half_pairs) = partition b_totally_aligned raw_pairs + (half_unaligned, half_aligned) = partition isUnmapped raw_half_pairs + + mkMap f x = let m1 = M.map collapse $ accumMap f id x + in (M.map fst m1, concatMap snd $ M.elems m1) + + (pairs',r1) = mkMap (\b -> (b_mate_pos b, b_strand b, b_mate b)) pairs + (merged',r2) = mkMap (\b -> (alignedLength (b_cigar b), b_strand b)) merged + (singles',r3) = mkMap b_strand (true_singles++half_aligned) + unaligned' = accumMap b_strand id half_unaligned + + b_strand b = strand_preserved && isReversed b + b_mate b = strand_preserved && isFirstMate b + + +-- | Merging information about true singles, merged singles, +-- half-aligned pairs, actually aligned pairs. +-- +-- We collected aligned reads with unaligned mates together with aligned +-- true singles (@singles@). We collected the unaligned mates, which +-- necessarily have the exact same alignment coordinates, separately +-- (@unaligned@). If we don't find a matching true pair (that case is +-- already handled smoothly), we keep the highest quality unaligned +-- mate, pair it with the consensus of the aligned mates and aligned +-- singletons, and give it the lexically smallest name of the +-- half-aligned pairs. + +-- NOTE: I need to decide when to run 'make_singleton'. Basically, +-- when we call a consensus for half-aligned pairs and keep +-- everything(?). Then we don't have a mate for the consensus... though +-- we could decide to duplicate one mate read to get it. + +merge_singles :: M.Map Bool Decision -- strand --> true singles & half aligned + -> M.Map Bool [BamRec] -- strand --> half unaligned + -> [ (Bool, BamRec) ] -- strand --> paireds & mergeds + -> ([BamRec],[BamRec]) -- results, leftovers + +merge_singles singles unaligneds = go + where + -- Say we generated a consensus or passed something through. If + -- there is a singleton consensus with the same strand, we should + -- add in its XP field and discard it. If there is a singleton + -- representative, we add in its XP field and put it into the + -- leftovers. If there is unaligned stuff here that has the same + -- strand, it goes to the leftovers. + go ( (str, v) : paireds) = + let (r,l) = merge_singles (M.delete str singles) (M.delete str unaligneds) paireds + unal = M.findWithDefault [] str unaligneds ++ l + + in case M.lookup str singles of + Nothing -> ( v : r, unal ) + Just (Consensus w) -> ( add_xp_of w v : r, unal ) -- XXX do we need this w?! + Just (Representative w) -> ( add_xp_of w v : r, w : unal ) + + -- No more pairs, delegate the problem + go [] = merge_halves unaligneds (M.toList singles) + + add_xp_of w v = v { b_exts = updateE "XP" (Int $ extAsInt 1 "XP" w `oplus` extAsInt 1 "XP" v) (b_exts v) } + +-- | Merging of half-aligned reads. The first argument is a map of +-- unaligned reads (their mates are aligned to the current position), +-- the second is a list of reads that are aligned (their mates are not +-- aligned). +-- +-- So, suppose we're looking at a 'Representative' that was passed +-- through. We need to emit it along with its mate, which may be hidden +-- inside a list. (Alternatively, we could force it to single, but that +-- fails if we're passing everything along somehow.) +-- +-- Suppose we're looking at a 'Consensus'. We could pair it with some +-- mate (which we'd need to duplicate), or we could turn it into a +-- singleton. Duplication is ugly, so in this case, we force it to +-- singleton. + +merge_halves :: M.Map Bool [BamRec] -- strand --> half unaligned + -> [(Bool, Decision)] -- strand --> true singles & half aligned + -> ([BamRec],[BamRec]) -- results, leftovers + +-- Emitting a consensus: make it a single. Nothing goes to leftovers; +-- we may still need it for something else to be emitted. (While that +-- would be strange, making sure the BAM file stays completely valid is +-- probably better.) +merge_halves unaligneds ((_, Consensus v) : singles) = + case merge_halves unaligneds singles of + (l,r) -> ( v { b_flag = b_flag v .&. complement pflags } : r, l ) + where + pflags = flagPaired .|. flagProperlyPaired .|. flagMateUnmapped .|. flagMateReversed .|. flagFirstMate .|. flagSecondMate + + +-- Emitting a representative: find the mate in the list of unaligned +-- reads (take up to one match to be robust), and emit that, too, as a +-- result. Everything else goes to leftovers. If the representative +-- happens to be unpaired, no mate is found and that case therefore is +-- handled smoothly. +merge_halves unaligneds ((str, Representative v) : singles) = (v : take 1 same ++ r, drop 1 same ++ diff ++ l) + where + (r,l) = merge_halves (M.delete str unaligneds) singles + (same,diff) = partition (is_mate_of v) $ M.findWithDefault [] str unaligneds + is_mate_of a b = b_qname a == b_qname b && isPaired a && isPaired b && isFirstMate a == isSecondMate b + +-- No more singles, all unaligneds are leftovers. +merge_halves unaligneds [] = ( [], concat $ M.elems unaligneds ) + + + + +type MPos = (Refseq, Int, Bool, Bool) + +b_mate_pos :: BamRec -> MPos +b_mate_pos b = (b_mrnm b, b_mpos b, isUnmapped b, isMateUnmapped b) + +b_totally_aligned :: BamRec -> Bool +b_totally_aligned b = not (isUnmapped b || isMateUnmapped b) + + +accumMap :: Ord k => (a -> k) -> (a -> v) -> [a] -> M.Map k [v] +accumMap f g = go M.empty + where + go m [ ] = m + go m (a:as) = let ws = M.findWithDefault [] (f a) m ; g' = g a + in g' `seq` go (M.insert (f a) (g':ws) m) as + + +{- We need to deal sensibly with each field, but different fields have + different needs. We can take the value from the first read to + preserve determinism or because all reads should be equal anyway, + aggregate over all reads computing either RMSQ or the most common + value, delete a field because it wouldn't make sense anymore or + because doing something sensible would be hard and we're going to + ignore it anyway, or we calculate some special value; see below. + Unknown fields will be taken from the first read, which seems to be a + safe default. + + QNAME and most fields taken from first + FLAG qc fail majority vote + dup deleted + MAPQ rmsq + CIGAR, SEQ, QUAL, MD, NM, XP generated + XA concatenate all + + BQ, CM, FZ, Q2, R2, XM, XO, XG, YQ, EN + deleted because they would become wrong + + CQ, CS, E2, FS, OQ, OP, OC, U2, H0, H1, H2, HI, NH, IH, ZQ + delete because they will be ignored anyway + + AM, AS, MQ, PQ, SM, UQ + compute rmsq + + X0, X1, XT, XS, XF, XE, BC, LB, RG, XI, YI, XJ, YJ + majority vote -} + +do_collapse :: Qual -> [BamRec] -> (Decision, [BamRec]) +do_collapse maxq [br] | V.all (<= maxq) (b_qual br) = ( Representative br, [ ] ) -- no modifcation, pass through + | otherwise = ( Consensus lq_br, [br] ) -- qualities reduced, must keep original + where + lq_br = br { b_qual = V.map (min maxq) $ b_qual br + , b_virtual_offset = 0 + , b_qname = b_qname br `B.snoc` c2w 'c' } + +do_collapse maxq brs = ( Consensus b0 { b_exts = modify_extensions $ b_exts b0 + , b_flag = failflag .&. complement flagDuplicate + , b_mapq = Q $ rmsq $ map (unQ . b_mapq) $ good brs + , b_cigar = cigar' + , b_seq = V.fromList $ map fst cons_seq_qual + , b_qual = V.fromList $ map snd cons_seq_qual + , b_qname = b_qname b0 `B.snoc` 99 + , b_virtual_offset = 0 }, brs ) -- many modifications, must keep everything + where + !b0 = minimumBy (comparing b_qname) brs + !most_fail = 2 * length (filter isFailsQC brs) > length brs + !failflag | most_fail = b_flag b0 .|. flagFailsQC + | otherwise = b_flag b0 .&. complement flagFailsQC + + rmsq xs = case foldl' (\(!n,!d) x -> (n + fromIntegral x * fromIntegral x, d + 1)) (0,0) xs of + (!n,!d) -> round $ sqrt $ (n::Double) / fromIntegral (d::Int) + + maj xs = head . maximumBy (comparing length) . group . sort $ xs + nub' = concatMap head . group . sort + + -- majority vote on the cigar lines, then filter + !cigar' = maj $ map b_cigar brs + good = filter ((==) cigar' . b_cigar) + + cons_seq_qual = [ consensus maxq [ (V.unsafeIndex (b_seq b) i, q) + | b <- good brs, let q = if V.null (b_qual b) then Q 23 else b_qual b V.! i ] + | i <- [0 .. len - 1] ] + where !len = V.length . b_seq . head $ good brs + + md' = case [ (b_seq b,md,b) | b <- good brs, Just md <- [ getMd b ] ] of + [ ] -> [] + (seq1, md1,b) : _ -> case mk_new_md' [] (V.toList cigar') md1 (V.toList seq1) (map fst cons_seq_qual) of + Right x -> x + Left (MdFail cigs ms osq nsq) -> error $ unlines + [ "Broken MD field when trying to construct new MD!" + , "QNAME: " ++ show (b_qname b) + , "POS: " ++ shows (unRefseq (b_rname b)) ":" ++ show (b_pos b) + , "CIGAR: " ++ show cigs + , "MD: " ++ show ms + , "refseq: " ++ show osq + , "readseq: " ++ show nsq ] + + + nm' = sum $ [ n | Ins :* n <- VS.toList cigar' ] ++ [ n | Del :* n <- VS.toList cigar' ] ++ [ 1 | MdRep _ <- md' ] + xa' = nub' [ T.split ';' xas | Just (Text xas) <- map (lookup "XA" . b_exts) brs ] + + modify_extensions es = foldr ($!) es $ + [ let vs = [ v | Just v <- map (lookup k . b_exts) brs ] + in if null vs then id else updateE k $! maj vs | k <- do_maj ] ++ + [ let vs = [ v | Just (Int v) <- map (lookup k . b_exts) brs ] + in if null vs then id else updateE k $! Int (rmsq vs) | k <- do_rmsq ] ++ + [ deleteE k | k <- useless ] ++ + [ updateE "NM" $! Int nm' + , updateE "XP" $! Int (foldl' (\a b -> a `oplus` extAsInt 1 "XP" b) 0 brs) + , if null xa' then id else updateE "XA" $! (Text $ T.intercalate (T.singleton ';') xa') + , if null md' then id else updateE "MD" $! (Text $ showMd md') ] + + useless = map fromString $ words "BQ CM FZ Q2 R2 XM XO XG YQ EN CQ CS E2 FS OQ OP OC U2 H0 H1 H2 HI NH IH ZQ" + do_rmsq = map fromString $ words "AM AS MQ PQ SM UQ" + do_maj = map fromString $ words "X0 X1 XT XS XF XE BC LB RG XI XJ YI YJ" + +minViewBy :: (a -> a -> Ordering) -> [a] -> (a,[a]) +minViewBy _ [ ] = error "minViewBy on empty list" +minViewBy cmp (x:xs) = go x [] xs + where + go m acc [ ] = (m,acc) + go m acc (a:as) = case m `cmp` a of GT -> go a (m:acc) as + _ -> go m (a:acc) as + +data MdFail = MdFail [Cigar] [MdOp] [Nucleotides] [Nucleotides] + +mk_new_md' :: [MdOp] -> [Cigar] -> [MdOp] -> [Nucleotides] -> [Nucleotides] -> Either MdFail [MdOp] +mk_new_md' acc [] [] [] [] = Right $ normalize [] acc + where + normalize a (MdNum 0:os) = normalize a os + normalize (MdNum n:a) (MdNum m:os) = normalize (MdNum (n+m):a) os + normalize a (MdDel []:os) = normalize a os + normalize (MdDel u:a) (MdDel v:os) = normalize (MdDel (v++u):a) os + normalize a ( o:os) = normalize (o:a) os + normalize a [ ] = a + +mk_new_md' acc ( _ :* 0 : cigs) mds osq nsq = mk_new_md' acc cigs mds osq nsq +mk_new_md' acc cigs (MdNum 0 : mds) osq nsq = mk_new_md' acc cigs mds osq nsq +mk_new_md' acc cigs (MdDel [] : mds) osq nsq = mk_new_md' acc cigs mds osq nsq + +mk_new_md' acc (Mat :* u : cigs) (MdRep b : mds) (_:osq) (n:nsq) + | b == n = mk_new_md' (MdNum 1 : acc) (Mat :* (u-1):cigs) mds osq nsq + | otherwise = mk_new_md' (MdRep b : acc) (Mat :* (u-1):cigs) mds osq nsq + +mk_new_md' acc (Mat :* u : cigs) (MdNum v : mds) (o:osq) (n:nsq) + | o == n = mk_new_md' (MdNum 1 : acc) (Mat :* (u-1):cigs) (MdNum (v-1) : mds) osq nsq + | otherwise = mk_new_md' (MdRep o : acc) (Mat :* (u-1):cigs) (MdNum (v-1) : mds) osq nsq + +mk_new_md' acc (Del :* n : cigs) (MdDel bs : mds) osq nsq | n == length bs = mk_new_md' (MdDel bs : acc) cigs mds osq nsq +mk_new_md' acc (Del :* n : cigs) (MdDel (b:bs) : mds) osq nsq = mk_new_md' (MdDel [b] : acc) (Del :* (n-1) : cigs) (MdDel bs:mds) osq nsq +mk_new_md' acc (Del :* n : cigs) (MdRep b : mds) osq nsq = mk_new_md' (MdDel [b] : acc) (Del :* (n-1) : cigs) mds osq nsq +mk_new_md' acc (Del :* n : cigs) (MdNum m : mds) osq nsq = mk_new_md' (MdDel [nucsN] : acc) (Del :* (n-1) : cigs) (MdNum (m-1):mds) osq nsq + +mk_new_md' acc (Ins :* n : cigs) md osq nsq = mk_new_md' acc cigs md (drop n osq) (drop n nsq) +mk_new_md' acc (SMa :* n : cigs) md osq nsq = mk_new_md' acc cigs md (drop n osq) (drop n nsq) +mk_new_md' acc (HMa :* _ : cigs) md osq nsq = mk_new_md' acc cigs md osq nsq +mk_new_md' acc (Pad :* _ : cigs) md osq nsq = mk_new_md' acc cigs md osq nsq +mk_new_md' acc (Nop :* _ : cigs) md osq nsq = mk_new_md' acc cigs md osq nsq + +mk_new_md' _acc cigs ms osq nsq = Left $ MdFail cigs ms osq nsq + +consensus :: Qual -> [ (Nucleotides, Qual) ] -> (Nucleotides, Qual) +consensus (Q maxq) nqs = if qr > 3 then (n0, Q qr) else (nucsN, Q 0) + where + accs :: U.Vector Int + accs = U.accum (+) (U.replicate 16 0) [ (fromIntegral n, fromIntegral q) | (Ns n,Q q) <- nqs ] + + (n0,q0) : (_,q1) : _ = sortBy (flip $ comparing snd) $ zip [Ns 0 ..] $ U.toList accs + qr = fromIntegral $ (q0-q1) `min` fromIntegral maxq + + +-- Cheap version: simply takes the lexically first record, adds XP field +do_cheap_collapse :: [BamRec] -> ( Decision, [BamRec] ) +do_cheap_collapse [b] = ( Representative b, [] ) +do_cheap_collapse bs = ( Representative $ replaceXP new_xp b0, bx ) + where + (b0, bx) = minViewBy (comparing b_qname) bs + new_xp = foldl' (\a b -> a `oplus` extAsInt 1 "XP" b) 0 bs + +replaceXP :: Int -> BamRec -> BamRec +replaceXP new_xp b0 = b0 { b_exts = updateE "XP" (Int new_xp) $ b_exts b0 } + +oplus :: Int -> Int -> Int +_ `oplus` (-1) = -1 +(-1) `oplus` _ = -1 +a `oplus` b = a + b + +-- | Normalize a read's alignment to fall into the canonical region +-- of [0..l]. Takes the name of the reference sequence and its length. +normalizeTo :: Seqid -> Int -> BamRec -> BamRec +normalizeTo nm l b = b { b_pos = b_pos b `mod` l + , b_mpos = b_mpos b `mod` l + , b_mapq = if dups_are_fine then Q 37 else b_mapq b + , b_exts = if dups_are_fine then deleteE "XA" (b_exts b) else b_exts b } + where + dups_are_fine = all_match_XA (extAsString "XA" b) + all_match_XA s = case T.split ';' s of [xa1, xa2] | T.null xa2 -> one_match_XA xa1 + [xa1] -> one_match_XA xa1 + _ -> False + one_match_XA s = case T.split ',' s of (sq:pos:_) | sq == nm -> pos_match_XA pos ; _ -> False + pos_match_XA s = case T.readInt s of Just (p,z) | T.null z -> int_match_XA p ; _ -> False + int_match_XA p | p >= 0 = (p-1) `mod` l == b_pos b `mod` l && not (isReversed b) + | otherwise = (-p-1) `mod` l == b_pos b `mod` l && isReversed b + + +-- | Wraps a read to be fully contained in the canonical interval +-- [0..l]. If the read overhangs, it is duplicated and both copies are +-- suitably masked. +wrapTo :: Int -> BamRec -> [BamRec] +wrapTo l b = if overhangs then do_wrap else [b] + where + overhangs = not (isUnmapped b) && b_pos b < l && l < b_pos b + alignedLength (b_cigar b) + + do_wrap = case split_ecig (l - b_pos b) $ toECig (b_cigar b) (maybe [] id $ getMd b) of + (left,right) -> [ b { b_cigar = toCigar left } `setMD` left + , b { b_cigar = toCigar right, b_pos = 0 } `setMD` right ] + +-- | Split an 'ECig' into two at some position. The position is counted +-- in terms of the reference (therefore, deletions count, insertions +-- don't). The parts that would be skipped if we were splitting lists +-- are replaced by soft masks. +split_ecig :: Int -> ECig -> (ECig, ECig) +split_ecig _ WithMD = (WithMD, WithMD) +split_ecig _ WithoutMD = (WithoutMD, WithoutMD) +split_ecig 0 ecs = (mask_all ecs, ecs) + +split_ecig i (Ins' n ecs) = case split_ecig i ecs of (u,v) -> (Ins' n u, SMa' n v) +split_ecig i (SMa' n ecs) = case split_ecig i ecs of (u,v) -> (SMa' n u, SMa' n v) +split_ecig i (HMa' n ecs) = case split_ecig i ecs of (u,v) -> (HMa' n u, HMa' n v) +split_ecig i (Pad' n ecs) = case split_ecig i ecs of (u,v) -> (Pad' n u, v) + +split_ecig i (Mat' n ecs) + | i >= n = case split_ecig (i-n) ecs of (u,v) -> (Mat' n u, SMa' n v) + | otherwise = (Mat' i $ SMa' (n-i) $ mask_all ecs, SMa' i $ Mat' (n-i) ecs) + +split_ecig i (Rep' x ecs) = case split_ecig (i-1) ecs of (u,v) -> (Rep' x u, SMa' 1 v) +split_ecig i (Del' x ecs) = case split_ecig (i-1) ecs of (u,v) -> (Del' x u, v) + +split_ecig i (Nop' n ecs) + | i >= n = case split_ecig (i-n) ecs of (u,v) -> (Nop' n u, v) + | otherwise = (Nop' i $ mask_all ecs, Nop' (n-i) ecs) + +mask_all :: ECig -> ECig +mask_all WithMD = WithMD +mask_all WithoutMD = WithoutMD +mask_all (Nop' _ ec) = mask_all ec +mask_all (HMa' _ ec) = mask_all ec +mask_all (Pad' _ ec) = mask_all ec +mask_all (Del' _ ec) = mask_all ec +mask_all (Rep' _ ec) = SMa' 1 $ mask_all ec +mask_all (Mat' n ec) = SMa' n $ mask_all ec +mask_all (Ins' n ec) = SMa' n $ mask_all ec +mask_all (SMa' n ec) = SMa' n $ mask_all ec + +-- | Argh, this business with the CIGAR operations is a mess, it gets +-- worse when combined with MD. Okay, we will support CIGAR (no "=" and +-- "X" operations) and MD. If we have MD on input, we generate it on +-- output, too. And in between, we break everything into /very small/ +-- operations. (Yes, the two terminating constructors are a weird +-- hack.) + +data ECig = WithMD -- terminate, do generate MD field + | WithoutMD -- terminate, don't bother with MD + | Mat' Int ECig + | Rep' Nucleotides ECig + | Ins' Int ECig + | Del' Nucleotides ECig + | Nop' Int ECig + | SMa' Int ECig + | HMa' Int ECig + | Pad' Int ECig + + +toECig :: VS.Vector Cigar -> [MdOp] -> ECig +toECig cig md = go (VS.toList cig) md + where + go cs (MdNum 0:mds) = go cs mds + go cs (MdDel []:mds) = go cs mds + go (_:*0 :cs) mds = go cs mds + go [ ] [ ] = WithMD -- all was fine to the very end + go [ ] _ = WithoutMD -- here it wasn't fine + + go (Mat :* n : cs) (MdRep x:mds) = Rep' x $ go (Mat :* (n-1) : cs) mds + go (Mat :* n : cs) (MdNum m:mds) + | n < m = Mat' n $ go cs (MdNum (m-n):mds) + | n > m = Mat' m $ go (Mat :* (n-m) : cs) mds + | otherwise = Mat' n $ go cs mds + go (Mat :* n : cs) _ = Mat' n $ go' cs + + go (Ins :* n : cs) mds = Ins' n $ go cs mds + go (Del :* n : cs) (MdDel (x:xs):mds) = Del' x $ go (Del :* (n-1) : cs) (MdDel xs:mds) + go (Del :* n : cs) _ = Del' nucsN $ go' (Del :* (n-1) : cs) + + go (Nop :* n : cs) mds = Nop' n $ go cs mds + go (SMa :* n : cs) mds = SMa' n $ go cs mds + go (HMa :* n : cs) mds = HMa' n $ go cs mds + go (Pad :* n : cs) mds = Pad' n $ go cs mds + + -- We jump here once the MD fiels ran out early or was messed up. + -- We no longer bother with it (this also happens if the MD isn't + -- present to begin with). + go' (_ :* 0 : cs) = go' cs + go' [ ] = WithoutMD -- we didn't have MD or it was broken + + go' (Mat :* n : cs) = Mat' n $ go' cs + go' (Ins :* n : cs) = Ins' n $ go' cs + go' (Del :* n : cs) = Del' nucsN $ go' (Del :* (n-1) : cs) + + go' (Nop :* n : cs) = Nop' n $ go' cs + go' (SMa :* n : cs) = SMa' n $ go' cs + go' (HMa :* n : cs) = HMa' n $ go' cs + go' (Pad :* n : cs) = Pad' n $ go' cs + + +-- We normalize matches, deletions and soft masks, because these are the +-- operations we generate. Everything else is either already normalized +-- or nobody really cares anyway. +toCigar :: ECig -> VS.Vector Cigar +toCigar = V.fromList . go + where + go WithMD = [] + go WithoutMD = [] + + go (Ins' n ecs) = Ins :* n : go ecs + go (Nop' n ecs) = Nop :* n : go ecs + go (HMa' n ecs) = HMa :* n : go ecs + go (Pad' n ecs) = Pad :* n : go ecs + go (SMa' n ecs) = go_sma n ecs + go (Mat' n ecs) = go_mat n ecs + go (Rep' _ ecs) = go_mat 1 ecs + go (Del' _ ecs) = go_del 1 ecs + + go_sma !n (SMa' m ecs) = go_sma (n+m) ecs + go_sma !n ecs = SMa :* n : go ecs + + go_mat !n (Mat' m ecs) = go_mat (n+m) ecs + go_mat !n (Rep' _ ecs) = go_mat (n+1) ecs + go_mat !n ecs = Mat :* n : go ecs + + go_del !n (Del' _ ecs) = go_del (n+1) ecs + go_del !n ecs = Del :* n : go ecs + + + +-- | Create an MD field from an extended CIGAR and place it in a record. +-- We build it piecemeal (in 'go'), call out to 'addNum', 'addRep', +-- 'addDel' to make sure the operations are not generated in a +-- degenerate manner, and finally check if we're even supposed to create +-- an MD field. +setMD :: BamRec -> ECig -> BamRec +setMD b ec = case go ec of + Just md -> b { b_exts = updateE "MD" (Text $ showMd md) (b_exts b) } + Nothing -> b { b_exts = deleteE "MD" (b_exts b) } + where + go WithMD = Just [] + go WithoutMD = Nothing + + go (Ins' _ ecs) = go ecs + go (Nop' _ ecs) = go ecs + go (SMa' _ ecs) = go ecs + go (HMa' _ ecs) = go ecs + go (Pad' _ ecs) = go ecs + go (Mat' n ecs) = (if n == 0 then id else fmap (addNum n)) $ go ecs + go (Rep' x ecs) = (if isGap x then id else fmap (addRep x)) $ go ecs + go (Del' x ecs) = (if isGap x then id else fmap (addDel x)) $ go ecs + + addNum n (MdNum m : mds) = MdNum (n+m) : mds + addNum n mds = MdNum n : mds + + addRep x mds = MdRep x : mds + + addDel x (MdDel y : mds) = MdDel (x:y) : mds + addDel x mds = MdDel [x] : mds diff --git a/src/Bio/Bam/Trim.hs b/src/Bio/Bam/Trim.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Trim.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +-- | Trimming of reads as found in BAM files. Implements trimming low +-- quality sequence from the 3' end. + +module Bio.Bam.Trim ( trim_3', trim_3, trim_low_quality ) where + +import Bio.Bam.Rec +import Bio.Base + +import Data.Bits ( testBit ) +import Data.List ( inits ) +import qualified Data.Vector.Generic as V + +-- | Trims from the 3' end of a sequence. +-- @trim_3\' p b@ trims the 3' end of the sequence in @b@ at the +-- earliest position such that @p@ evaluates to true on every suffix +-- that was trimmed off. Note that the 3' end may be the beginning of +-- the sequence if it happens to be stored in reverse-complemented form. +-- Also note that trimming from the 3' end may not make sense for reads +-- that were constructed by merging paired end data (but we cannot take +-- care of that here). Further note that trimming may break dependent +-- information, notably the "mate" information of the mate and many +-- optional fields. +-- +-- TODO: The MD field is currently removed. It should be repaired +-- instead. Many other fields should be trimmed if present. + +trim_3' :: ([Nucleotides] -> [Qual] -> Bool) -> BamRec -> BamRec +trim_3' p b | b_flag b `testBit` 4 = trim_rev + | otherwise = trim_fwd + where + trim_fwd = let l = subtract 1 . fromIntegral . length . takeWhile (uncurry p) $ + zip (inits . reverse . V.toList $ b_seq b) + (inits . reverse . V.toList $ b_qual b) + in trim_3 l b + + trim_rev = let l = subtract 1 . fromIntegral . length . takeWhile (uncurry p) $ + zip (inits . V.toList $ b_seq b) + (inits . V.toList $ b_qual b) + in trim_3 l b + +trim_3 :: Int -> BamRec -> BamRec +trim_3 l b | b_flag b `testBit` 4 = trim_rev + | otherwise = trim_fwd + where + trim_fwd = let (_, cigar') = trim_back_cigar (b_cigar b) l + in b { b_seq = V.take (V.length (b_seq b) - l) (b_seq b) + , b_qual = V.take (V.length (b_qual b) - l) (b_qual b) + , b_cigar = cigar' + , b_exts = deleteE "MD" (b_exts b) } + + trim_rev = let (off, cigar') = trim_fwd_cigar (b_cigar b) l + in b { b_seq = V.drop l (b_seq b) + , b_qual = V.drop l (b_qual b) + , b_cigar = cigar' + , b_exts = deleteE "MD" (b_exts b) + , b_pos = b_pos b + off + } + +trim_back_cigar, trim_fwd_cigar :: V.Vector v Cigar => v Cigar -> Int -> ( Int, v Cigar ) +trim_back_cigar c l = (o, V.fromList $ reverse c') where (o,c') = sanitize_cigar . trim_cigar l $ reverse $ V.toList c +trim_fwd_cigar c l = (o, V.fromList c') where (o,c') = sanitize_cigar $ trim_cigar l $ V.toList c + +sanitize_cigar :: (Int, [Cigar]) -> (Int, [Cigar]) +sanitize_cigar (o, [ ]) = (o, []) +sanitize_cigar (o, (op:*l):xs) | op == Pad = sanitize_cigar (o,xs) -- del P + | op == Del || op == Nop = sanitize_cigar (o + l, xs) -- adjust D,N + | op == Ins = (o, (SMa :* l):xs) -- I --> S + | otherwise = (o, (op :* l):xs) -- rest is fine + +trim_cigar :: Int -> [Cigar] -> (Int, [Cigar]) +trim_cigar 0 cs = (0, cs) +trim_cigar _ [] = (0, []) +trim_cigar l ((op:*ll):cs) | bad_op op = let (o,cs') = trim_cigar l cs in (o + reflen op ll, cs') + | otherwise = case l `compare` ll of + LT -> (reflen op l, (op :* (ll-l)):cs) + EQ -> (reflen op ll, cs) + GT -> let (o,cs') = trim_cigar (l - ll) cs in (o + reflen op ll, cs') + + where + reflen op' = if ref_op op' then id else const 0 + bad_op o = o /= Mat && o /= Ins && o /= SMa + ref_op o = o == Mat || o == Del + + +-- | Trim predicate to get rid of low quality sequence. +-- @trim_low_quality q ns qs@ evaluates to true if all qualities in @qs@ +-- are smaller (i.e. worse) than @q@. +trim_low_quality :: Qual -> a -> [Qual] -> Bool +trim_low_quality q = const $ all (< q) + + + diff --git a/src/Bio/Bam/Writer.hs b/src/Bio/Bam/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Bam/Writer.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings, FlexibleContexts #-} +module Bio.Bam.Writer ( + IsBamRec(..), + encodeBamWith, + + writeBamFile, + writeBamHandle, + pipeBamOutput, + pipeSamOutput + ) where + +import Bio.Base +import Bio.Bam.Header +import Bio.Bam.Rec +import Bio.Iteratee +import Bio.Iteratee.Builder + +import Control.Applicative +import Data.ByteString.Builder ( toLazyByteString ) +import Data.Bits +import Data.Char ( ord, chr ) +import Data.Foldable ( foldMap ) +import Data.Monoid +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Storable ( pokeByteOff, peek ) +import System.IO +import System.IO.Unsafe ( unsafeDupablePerformIO ) + +import qualified Control.Monad.Catch as C +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as U +import qualified Data.Sequence as Z + +-- ^ Printers for BAM. We employ an @Iteratee@ interface, and we strive +-- to keep BAM records in their encoded form. This is most compact and +-- often faster, since it saves the time for repeated decoding and +-- encoding, if that's not strictly needed. + + +-- | write in SAM format to stdout +-- This is useful for piping to other tools (say, AWK scripts) or for +-- debugging. No convenience function to send SAM to a file exists, +-- because that's a stupid idea. +pipeSamOutput :: MonadIO m => BamMeta -> Iteratee [BamRec] m () +pipeSamOutput meta = do liftIO . L.putStr . toLazyByteString $ showBamMeta meta + mapStreamM_ $ \b -> liftIO . putStr $ encodeSamEntry (meta_refs meta) b "\n" + +encodeSamEntry :: Refs -> BamRec -> String -> String +encodeSamEntry refs b = conjoin '\t' [ + unpck (b_qname b), + shows (b_flag b .&. 0xffff), + unpck (sq_name $ getRef refs $ b_rname b), + shows (b_pos b + 1), + shows (b_mapq b), + shows (b_cigar b), + unpck (sq_name $ getRef refs $ b_mrnm b), + shows (b_mpos b + 1), + shows (b_isize b + 1), + shows (V.toList $ b_seq b), + (++) (V.toList . V.map (chr . (+33) . fromIntegral . unQ) $ b_qual b) ] . + foldr (\(k,v) f -> (:) '\t' . shows k . (:) ':' . extToSam v . f) id (b_exts b) + where + unpck = (++) . S.unpack + conjoin c = foldr1 (\a f -> a . (:) c . f) + + extToSam (Int i) = (:) 'i' . (:) ':' . shows i + extToSam (Float f) = (:) 'f' . (:) ':' . shows f + extToSam (Text t) = (:) 'Z' . (:) ':' . unpck t + extToSam (Bin x) = (:) 'H' . (:) ':' . tohex x + extToSam (Char c) = (:) 'A' . (:) ':' . (:) (w2c c) + extToSam (IntArr arr) = (:) 'B' . (:) ':' . (:) 'i' . sarr arr + extToSam (FloatArr arr) = (:) 'B' . (:) ':' . (:) 'f' . sarr arr + + tohex = B.foldr (\c f -> w2d (c `shiftR` 4) . w2d (c .&. 0xf) . f) id + w2d = (:) . S.index "0123456789ABCDEF" . fromIntegral + sarr v = conjoin ',' . map shows $ U.toList v + +class IsBamRec a where + pushBam :: a -> Push + +instance IsBamRec BamRaw where + {-# INLINE pushBam #-} + pushBam = pushBamRaw + +instance IsBamRec BamRec where + {-# INLINE pushBam #-} + pushBam = pushBamRec + +instance (IsBamRec a, IsBamRec b) => IsBamRec (Either a b) where + {-# INLINE pushBam #-} + pushBam = either pushBam pushBam + +-- | Encodes BAM records straight into a dynamic buffer, the BGZF's it. +-- Should be fairly direct and perform well. +{-# INLINE encodeBamWith #-} +encodeBamWith :: (MonadIO m, IsBamRec r) => Int -> BamMeta -> Enumeratee [r] B.ByteString m a +encodeBamWith lv meta = joinI . eneeBam . encodeBgzfWith lv + where + eneeBam = eneeCheckIfDone (\k -> mapChunks (foldMap pushBam) . k $ Chunk pushHeader) + + pushHeader = pushByteString "BAM\1" + <> setMark -- the length byte + <> pushBuilder (showBamMeta meta) + <> endRecord -- fills the length in + <> pushWord32 (fromIntegral . Z.length $ meta_refs meta) + <> foldMap pushRef (meta_refs meta) + + pushRef bs = ensureBuffer (fromIntegral $ B.length (sq_name bs) + 9) + <> unsafePushWord32 (fromIntegral $ B.length (sq_name bs) + 1) + <> unsafePushByteString (sq_name bs) + <> unsafePushByte 0 + <> unsafePushWord32 (fromIntegral $ sq_length bs) + +{-# INLINE pushBamRaw #-} +pushBamRaw :: BamRaw -> Push +pushBamRaw br = ensureBuffer (B.length (raw_data br) + 4) + <> unsafePushWord32 (fromIntegral $ B.length (raw_data br)) + <> unsafePushByteString (raw_data br) + +-- | writes BAM encoded stuff to a file +-- XXX This should(!) write indexes on the side---a simple block index +-- for MapReduce style slicing, a standard BAM index or a name index +-- would be possible. When writing to a file, this makes even more +-- sense than when writing to a @Handle@. +writeBamFile :: IsBamRec r => FilePath -> BamMeta -> Iteratee [r] IO () +writeBamFile fp meta = + C.bracket (liftIO $ openBinaryFile fp WriteMode) + (liftIO . hClose) + (flip writeBamHandle meta) + +-- | write BAM encoded stuff to stdout +-- This send uncompressed BAM to stdout. Useful for piping to other +-- tools. +pipeBamOutput :: IsBamRec r => BamMeta -> Iteratee [r] IO () +pipeBamOutput meta = encodeBamWith 0 meta =$ mapChunksM_ (liftIO . S.hPut stdout) + +-- | writes BAM encoded stuff to a @Handle@ +-- We generate BAM with dynamic blocks, then stream them out to the file. +-- +-- XXX This could write indexes on the side---a simple block index +-- for MapReduce style slicing, a standard BAM index or a name index +-- would be possible. +writeBamHandle :: (MonadIO m, IsBamRec r) => Handle -> BamMeta -> Iteratee [r] m () +writeBamHandle hdl meta = encodeBamWith 6 meta =$ mapChunksM_ (liftIO . S.hPut hdl) + +{-# RULES + "pushBam/unpackBam" forall b . pushBamRec (unpackBam b) = pushBamRaw b + #-} + +{-# INLINE[1] pushBamRec #-} +pushBamRec :: BamRec -> Push +pushBamRec BamRec{..} = mconcat + [ ensureBuffer minlength + , unsafeSetMark + , unsafePushWord32 $ unRefseq b_rname + , unsafePushWord32 $ fromIntegral b_pos + , unsafePushByte $ fromIntegral $ B.length b_qname + 1 + , unsafePushByte $ unQ b_mapq + , unsafePushWord16 $ fromIntegral bin + , unsafePushWord16 $ fromIntegral $ VS.length b_cigar + , unsafePushWord16 $ fromIntegral b_flag + , unsafePushWord32 $ fromIntegral $ V.length b_seq + , unsafePushWord32 $ unRefseq b_mrnm + , unsafePushWord32 $ fromIntegral b_mpos + , unsafePushWord32 $ fromIntegral b_isize + , unsafePushByteString b_qname + , unsafePushByte 0 + , VS.foldr ((<>) . unsafePushByte) mempty (VS.unsafeCast b_cigar :: VS.Vector Word8) + , pushSeq b_seq + , VS.foldr ((<>) . unsafePushByte . unQ) mempty b_qual + , foldMap pushExt b_exts + , endRecord ] + where + bin = distinctBin b_pos (alignedLength b_cigar) + minlength = 37 + B.length b_qname + 4 * V.length b_cigar + V.length b_qual + (V.length b_seq + 1) `shiftR` 1 + + pushSeq :: V.Vector vec Nucleotides => vec Nucleotides -> Push + pushSeq v = case v V.!? 0 of + Nothing -> mempty + Just a -> case v V.!? 1 of + Nothing -> unsafePushByte (unNs a `shiftL` 4) + Just b -> unsafePushByte (unNs a `shiftL` 4 .|. unNs b) + <> pushSeq (V.drop 2 v) + + pushExt :: (BamKey, Ext) -> Push + pushExt (BamKey k, e) = case e of + Text t -> common (4 + B.length t) 'Z' $ + unsafePushByteString t <> unsafePushByte 0 + + Bin t -> common (4 + B.length t) 'H' $ + unsafePushByteString t <> unsafePushByte 0 + + Char c -> common 4 'A' $ unsafePushByte c + + Float f -> common 7 'f' $ unsafePushWord32 (fromIntegral $ fromFloat f) + + Int i -> case put_some_int (U.singleton i) of + (c,op) -> common 7 c (op i) + + IntArr ia -> case put_some_int ia of + (c,op) -> common (4 * U.length ia) 'B' $ unsafePushByte (fromIntegral $ ord c) + <> unsafePushWord32 (fromIntegral $ U.length ia-1) + <> U.foldr ((<>) . op) mempty ia + + FloatArr fa -> common (4 * U.length fa) 'B' $ unsafePushByte (fromIntegral $ ord 'f') + <> unsafePushWord32 (fromIntegral $ U.length fa-1) + <> U.foldr ((<>) . unsafePushWord32 . fromFloat) mempty fa + where + common l z b = ensureBuffer l <> unsafePushWord16 k + <> unsafePushByte (fromIntegral $ ord z) <> b + + put_some_int :: U.Vector Int -> (Char, Int -> Push) + put_some_int is + | U.all (between 0 0xff) is = ('C', unsafePushByte . fromIntegral) + | U.all (between (-0x80) 0x7f) is = ('c', unsafePushByte . fromIntegral) + | U.all (between 0 0xffff) is = ('S', unsafePushWord16 . fromIntegral) + | U.all (between (-0x8000) 0x7fff) is = ('s', unsafePushWord16 . fromIntegral) + | U.all (> 0) is = ('I', unsafePushWord32 . fromIntegral) + | otherwise = ('i', unsafePushWord32 . fromIntegral) + + between :: Int -> Int -> Int -> Bool + between l r x = l <= x && x <= r + + fromFloat :: Float -> Word32 + fromFloat float = unsafeDupablePerformIO $ alloca $ \buf -> + pokeByteOff buf 0 float >> peek buf + diff --git a/src/Bio/Base.hs b/src/Bio/Base.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Base.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses, BangPatterns, TemplateHaskell #-} +-- | Common data types used everywhere. This module is a collection of +-- very basic "bioinformatics" data types that are simple, but don't +-- make sense to define over and over. + +module Bio.Base( + Nucleotide(..), Nucleotides(..), + Qual(..), toQual, fromQual, fromQualRaised, probToQual, + Prob(..), toProb, fromProb, qualToProb, pow, + + Word8, + nucA, nucC, nucG, nucT, + nucsA, nucsC, nucsG, nucsT, nucsN, gap, + toNucleotide, toNucleotides, nucToNucs, + showNucleotide, showNucleotides, + isGap, + isBase, + isProperBase, + properBases, + compl, compls, + everything, + + Seqid, + unpackSeqid, + packSeqid, + + Position(..), + shiftPosition, + p_is_reverse, + + Range(..), + shiftRange, + reverseRange, + extendRange, + insideRange, + wrapRange, + + w2c, + c2w, + + findAuxFile +) where + +import Bio.Util ( log1p ) +import Data.Array.Unboxed +import Data.Bits +import Data.ByteString.Internal ( c2w, w2c ) +import Data.Char ( isAlpha, isSpace, ord, toUpper ) +import Data.Word ( Word8 ) +import Data.Vector.Generic ( Vector(..) ) +import Data.Vector.Generic.Mutable ( MVector(..) ) +import Data.Vector.Unboxed.Deriving +import Foreign.Storable ( Storable(..) ) +import Numeric ( showFFloat ) +import System.Directory ( doesFileExist ) +import System.FilePath ( (), isAbsolute, splitSearchPath ) +import System.Environment ( getEnvironment ) + +import qualified Data.ByteString.Char8 as S + + +-- | A nucleotide base. We only represent A,C,G,T. + +newtype Nucleotide = N { unN :: Word8 } deriving ( Eq, Ord, Enum, Ix, Storable ) + +derivingUnbox "Nucleotide" [t| Nucleotide -> Word8 |] [| unN |] [| N |] + +instance Bounded Nucleotide where + minBound = N 0 + maxBound = N 3 + +everything :: (Bounded a, Ix a) => [a] +everything = range (minBound, maxBound) + +-- | A nucleotide base in an alignment. +-- Experience says we're dealing with Ns and gaps all the type, so +-- purity be damned, they are included as if they were real bases. +-- +-- To allow @Nucleotides@s to be unpacked and incorparated into +-- containers, we choose to represent them the same way as the BAM file +-- format: as a 4 bit wide field. Gaps are encoded as 0 where they +-- make sense, N is 15. + +newtype Nucleotides = Ns { unNs :: Word8 } deriving ( Eq, Ord, Enum, Ix, Storable ) + +derivingUnbox "Nucleotides" [t| Nucleotides -> Word8 |] [| unNs |] [| Ns |] + +instance Bounded Nucleotides where + minBound = Ns 0 + maxBound = Ns 15 + +nucToNucs :: Nucleotide -> Nucleotides +nucToNucs (N x) = Ns $ 1 `shiftL` fromIntegral (x .&. 3) + +-- | Qualities are stored in deciban, also known as the Phred scale. To +-- represent a value @p@, we store @-10 * log_10 p@. Operations work +-- directly on the \"Phred\" value, as the name suggests. The same goes +-- for the 'Ord' instance: greater quality means higher \"Phred\" +-- score, meand lower error probability. +newtype Qual = Q { unQ :: Word8 } deriving ( Eq, Ord, Storable, Bounded ) + +derivingUnbox "Qual" [t| Qual -> Word8 |] [| unQ |] [| Q |] + +instance Show Qual where + showsPrec p (Q q) = (:) 'q' . showsPrec p q + +toQual :: (Floating a, RealFrac a) => a -> Qual +toQual a = Q $ round (-10 * log a / log 10) + +fromQual :: Qual -> Double +fromQual (Q q) = 10 ** (- fromIntegral q / 10) + +fromQualRaised :: Double -> Qual -> Double +fromQualRaised k (Q q) = 10 ** (- k * fromIntegral q / 10) + +-- | A positive 'Double' value stored in log domain. We store the +-- natural logarithm (makes computation easier), but allow conversions +-- to the familiar \"Phred\" scale used for 'Qual' values. +newtype Prob = Pr { unPr :: Double } deriving ( Eq, Ord, Storable ) + +derivingUnbox "Prob" [t| Prob -> Double |] [| unPr |] [| Pr |] + +instance Show Prob where + showsPrec _ (Pr p) = (:) 'q' . showFFloat (Just 1) q + where q = - 10 * p / log 10 + +instance Num Prob where + fromInteger a = Pr (log (fromInteger a)) + Pr x + Pr y = Pr $ if x >= y then x + log1p ( exp (y-x)) else y + log1p (exp (x-y)) + Pr x - Pr y = Pr $ if x >= y then x + log1p (- exp (y-x)) else error "no negative error probabilities" + Pr a * Pr b = Pr $ a + b + negate _ = Pr $ error "no negative error probabilities" + abs x = x + signum _ = Pr 0 + +instance Fractional Prob where + fromRational a = Pr (log (fromRational a)) + Pr a / Pr b = Pr (a - b) + recip (Pr a) = Pr (negate a) + +infixr 8 `pow` +pow :: Prob -> Double -> Prob +pow (Pr a) e = Pr (a*e) + + +toProb :: Double -> Prob +toProb p = Pr (log p) + +fromProb :: Prob -> Double +fromProb (Pr q) = exp q + +qualToProb :: Qual -> Prob +qualToProb (Q q) = Pr (- log 10 * fromIntegral q / 10) + +probToQual :: Prob -> Qual +probToQual (Pr p) = Q (round (- 10 * p / log 10)) + +nucA, nucC, nucG, nucT :: Nucleotide +nucA = N 0 +nucC = N 1 +nucG = N 2 +nucT = N 3 + +gap, nucsA, nucsC, nucsG, nucsT, nucsN :: Nucleotides +gap = Ns 0 +nucsA = Ns 1 +nucsC = Ns 2 +nucsG = Ns 4 +nucsT = Ns 8 +nucsN = Ns 15 + + +-- | Sequence identifiers are ASCII strings +-- Since we tend to store them for a while, we use strict byte strings. +-- If you get a lazy bytestring from somewhere, use 'shelve' to convert +-- it for storage. Use @unpackSeqid@ and @packSeqid@ to avoid the +-- import of @Data.ByteString@. +type Seqid = S.ByteString + +-- | Unpacks a @Seqid@ into a @String@ +unpackSeqid :: Seqid -> String +unpackSeqid = S.unpack + +-- | Packs a @String@ into a @Seqid@. Only works for ASCII subset. +packSeqid :: String -> Seqid +packSeqid = S.pack + +-- | Coordinates in a genome. +-- The position is zero-based, no questions about it. Think of the +-- position as pointing to the crack between two bases: looking forward +-- you see the next base to the right, looking in the reverse direction +-- you see the complement of the first base to the left. +-- +-- To encode the strand, we (virtually) reverse-complement any sequence +-- and prepend it to the normal one. That way, reversed coordinates +-- have a negative sign and automatically make sense. Position 0 could +-- either be the beginning of the sequence or the end on the reverse +-- strand... that ambiguity shouldn't really matter. + +data Position = Pos { + p_seq :: {-# UNPACK #-} !Seqid, -- ^ sequence (e.g. some chromosome) + p_start :: {-# UNPACK #-} !Int -- ^ offset, zero-based + } deriving (Show, Eq, Ord) + +p_is_reverse :: Position -> Bool +p_is_reverse = (< 0) . p_start + +-- | Ranges in genomes +-- We combine a position with a length. In 'Range pos len', 'pos' is +-- always the start of a stretch of length 'len'. Positions therefore +-- move in the opposite direction on the reverse strand. To get the +-- same stretch on the reverse strand, shift r_pos by r_length, then +-- reverse direction (or call reverseRange). +data Range = Range { + r_pos :: {-# UNPACK #-} !Position, + r_length :: {-# UNPACK #-} !Int + } deriving (Show, Eq, Ord) + + +-- | Converts a character into a 'Nucleotides'. +-- The usual codes for A,C,G,T and U are understood, '-' and '.' become +-- gaps and everything else is an N. +toNucleotide :: Char -> Nucleotide +toNucleotide c = if inRange (bounds arr) (ord c) then N (arr ! ord c) else N 0 + where + arr :: UArray Int Word8 + arr = listArray (0,127) (repeat 0) // + ( [ (ord x, n) | (x, N n) <- pairs ] ++ + [ (ord (toUpper x), n) | (x, N n) <- pairs ] ) + + pairs = [ ('a', nucA), ('c', nucC), ('g', nucG), ('t', nucT) ] + + +-- | Converts a character into a 'Nucleotides'. +-- The usual codes for A,C,G,T and U are understood, '-' and '.' become +-- gaps and everything else is an N. +toNucleotides :: Char -> Nucleotides +toNucleotides c = if inRange (bounds arr) (ord c) then Ns (arr ! ord c) else nucsN + where + arr :: UArray Int Word8 + arr = listArray (0,127) (repeat (unNs nucsN)) // + ( [ (ord x, n) | (x, Ns n) <- pairs ] ++ + [ (ord (toUpper x), n) | (x, Ns n) <- pairs ] ) + + Ns a `plus` Ns b = Ns (a .|. b) + + pairs = [ ('a', nucsA), ('c', nucsC), ('g', nucsG), ('t', nucsT), + ('u', nucsT), ('-', gap), ('.', gap), + ('b', nucsC `plus` nucsG `plus` nucsT), + ('d', nucsA `plus` nucsG `plus` nucsT), + ('h', nucsA `plus` nucsC `plus` nucsT), + ('v', nucsA `plus` nucsC `plus` nucsG), + ('k', nucsG `plus` nucsT), + ('m', nucsA `plus` nucsC), + ('s', nucsC `plus` nucsG), + ('w', nucsA `plus` nucsT), + ('r', nucsA `plus` nucsG), + ('y', nucsC `plus` nucsT) ] + +-- | Tests if a 'Nucleotides' is a base. +-- Returns 'True' for everything but gaps. +isBase :: Nucleotides -> Bool +isBase (Ns n) = n /= 0 + +-- | Tests if a 'Nucleotides' is a proper base. +-- Returns 'True' for A,C,G,T only. +isProperBase :: Nucleotides -> Bool +isProperBase x = x == nucsA || x == nucsC || x == nucsG || x == nucsT + +properBases :: [ Nucleotides ] +properBases = [ nucsA, nucsC, nucsG, nucsT ] + +-- | Tests if a 'Nucleotides' is a gap. +-- Returns true only for the gap. +isGap :: Nucleotides -> Bool +isGap x = x == gap + + +{-# INLINE showNucleotide #-} +showNucleotide :: Nucleotide -> Char +showNucleotide (N x) = S.index str $ fromIntegral $ x .&. 3 + where str = S.pack "ACGT" + +{-# INLINE showNucleotides #-} +showNucleotides :: Nucleotides -> Char +showNucleotides (Ns x) = S.index str $ fromIntegral $ x .&. 15 + where str = S.pack "-ACMGRSVTWYHKDBN" + +instance Show Nucleotide where + show x = [ showNucleotide x ] + showList l = (map showNucleotide l ++) + +instance Read Nucleotide where + readsPrec _ ('a':cs) = [(nucA, cs)] + readsPrec _ ('A':cs) = [(nucA, cs)] + readsPrec _ ('c':cs) = [(nucC, cs)] + readsPrec _ ('C':cs) = [(nucC, cs)] + readsPrec _ ('g':cs) = [(nucG, cs)] + readsPrec _ ('G':cs) = [(nucG, cs)] + readsPrec _ ('t':cs) = [(nucT, cs)] + readsPrec _ ('T':cs) = [(nucT, cs)] + readsPrec _ ('u':cs) = [(nucT, cs)] + readsPrec _ ('U':cs) = [(nucT, cs)] + readsPrec _ _ = [ ] + + readList ('-':cs) = readList cs + readList (c:cs) | isSpace c = readList cs + | otherwise = case readsPrec 0 (c:cs) of + [] -> [ ([],c:cs) ] + xs -> [ (n:ns,r2) | (n,r1) <- xs, (ns,r2) <- readList r1 ] + readList [] = [([],[])] + +instance Show Nucleotides where + show x = [ showNucleotides x ] + showList l = (map showNucleotides l ++) + +instance Read Nucleotides where + readsPrec _ (c:cs) = [(toNucleotides c, cs)] + readsPrec _ [ ] = [] + readList s = let (hd,tl) = span (\c -> isAlpha c || isSpace c || '-' == c) s + in [(map toNucleotides $ filter (not . isSpace) hd, tl)] + +-- | Complements a Nucleotides. +{-# INLINE compl #-} +compl :: Nucleotide -> Nucleotide +compl (N n) = N $ n `xor` 3 + +-- | Complements a Nucleotides. +{-# INLINE compls #-} +compls :: Nucleotides -> Nucleotides +compls (Ns x) = Ns $ arr ! (x .&. 15) + where + arr :: UArray Word8 Word8 + !arr = listArray (0,15) [ 0, 8, 4, 12, 2, 10, 6, 14, 1, 9, 5, 13, 3, 11, 7, 15 ] + + +-- | Moves a @Position@. The position is moved forward according to the +-- strand, negative indexes move backward accordingly. +shiftPosition :: Int -> Position -> Position +shiftPosition a p = p { p_start = p_start p + a } + +-- | Moves a @Range@. This is just @shiftPosition@ lifted. +shiftRange :: Int -> Range -> Range +shiftRange a r = r { r_pos = shiftPosition a (r_pos r) } + +-- | Reverses a 'Range' to give the same @Range@ on the opposite strand. +reverseRange :: Range -> Range +reverseRange (Range (Pos sq pos) len) = Range (Pos sq (-pos-len)) len + +-- | Extends a range. The length of the range is simply increased. +extendRange :: Int -> Range -> Range +extendRange a r = r { r_length = r_length r + a } + +-- | Expands a subrange. +-- @(range1 `insideRange` range2)@ interprets @range1@ as a subrange of +-- @range2@ and computes its absolute coordinates. The sequence name of +-- @range1@ is ignored. +insideRange :: Range -> Range -> Range +insideRange r1@(Range (Pos _ start1) length1) r2@(Range (Pos sq start2) length2) + | start2 < 0 = reverseRange (insideRange r1 (reverseRange r2)) + | start1 <= length2 = Range (Pos sq (start2 + start1)) (min length1 (length2 - start1)) + | otherwise = Range (Pos sq (start2 + length2)) 0 + + +-- | Wraps a range to a region. This simply normalizes the start +-- position to be in the interval '[0,n)', which only makes sense if the +-- @Range@ is to be mapped onto a circular genome. This works on both +-- strands and the strand information is retained. +wrapRange :: Int -> Range -> Range +wrapRange n (Range (Pos sq s) l) = Range (Pos sq (s `mod` n)) l + +-- | Finds a file by searching the environment variable BIOHAZARD like a +-- PATH. +findAuxFile :: FilePath -> IO FilePath +findAuxFile fn | isAbsolute fn = return fn + | otherwise = loop . maybe ["."] splitSearchPath . lookup "BIOHAZARD" =<< getEnvironment + where + loop [ ] = return fn + loop (p:ps) = do e <- doesFileExist $ p fn + if e then return $ p fn else loop ps + diff --git a/src/Bio/Genocall.hs b/src/Bio/Genocall.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Genocall.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE BangPatterns #-} +module Bio.Genocall where + +import Debug.Trace + +import Bio.Bam.Pileup +import Bio.Base +import Bio.Genocall.Adna +import Control.Applicative +import Data.Foldable hiding ( sum, product ) +import Data.List ( inits, tails, sortBy ) +import Data.Ord +import Data.Vec.Base ( (:.)(..) ) +import Data.Vec.LinAlg +import Data.Vec.Packed + +import qualified Data.Set as Set +import qualified Data.Vector.Unboxed as V +import qualified Data.Vec as Vec + +-- | Simple indel calling. We don't bother with it too much, so here's +-- the gist: We collect variants (simply different variants, details +-- don't matter), so @n@ variants give rise to (n+1)*n/2 GL values. +-- (That's two out of @(n+1)@, the reference allele, represented here as +-- no deletion and no insertion, is there, too.) To assign these, we +-- need a likelihood for an observed variant given an assumed genotype. +-- +-- For variants of equal length, the likelihood is the sum of qualities +-- of mismatching bases, but no higher than the mapping quality. That +-- is roughly the likelihood of getting the observed sequence even +-- though the real sequence is a different variant. For variants of +-- different length, the likelihood is the map quality. This +-- corresponds to the assumption that indel errors in sequencing are +-- much less likely than mapping errors. Since this hardly our +-- priority, the approximations are declared good enough. + +simple_indel_call :: Int -> IndelPile -> (GL, [IndelVariant]) +simple_indel_call ploidy vars = (simple_call ploidy mkpls vars, vars') + where + vars' = Set.toList $ Set.fromList + [ IndelVariant d (V_Nuc $ V.fromList $ map db_call i) | (_q,(d,i)) <- vars ] + + match = zipWith $ \(DB b q m) n -> let p = m ! n :-> b + p' = fromQual q + in toProb $ p + p' - p * p' + + mkpls (q,(d,i)) = let !q' = qualToProb q + in [ if d /= dr || length i /= V.length ir + then q' else q' + product (match i $ V.toList ir) + | IndelVariant dr (V_Nuc ir) <- vars' ] + +-- | Naive SNP call; essentially the GATK model. We create a function +-- that computes a likelihood for a given base, then hand over to simple +-- call. Since everything is so straight forward, this works even in +-- the face of damage. + +simple_snp_call :: Int -> BasePile -> GL +simple_snp_call ploidy vars = simple_call ploidy mkpls vars + where + mkpls (q, DB b qq m) = [ toProb $ x + pe*(s-x) | n <- [0..3], let x = m ! N n :-> b ] + where + !p1 = fromQual q + !p2 = fromQual qq + !pe = p1 + p2 - p1*p2 + !s = sum [ m ! N n :-> b | n <- [0..3] ] / 4 + +-- | Compute @GL@ values for the simple case. The simple case is where +-- we sample 'ploidy' alleles with equal probability and assume that +-- errors occur independently from each other. +-- +-- The argument 'pls' is a function that computes the likelihood for +-- getting the current read, for every variant assuming that variant was +-- sampled. +-- +-- NOTE, this may warrant specialization to diploidy and four alleles +-- (common SNPs) and diploidy and two alleles (common indels). + +simple_call :: Int -> (a -> [Prob]) -> [a] -> GL +simple_call ploidy pls = foldl1' (V.zipWith (*)) . map step + where + foldl1' _ [ ] = V.singleton 1 + foldl1' f (a:as) = foldl' f a as + + !mag = toProb (fromIntegral ploidy) `pow` (-1) + + -- XXX This could probably be simplified given the mk_pls function + -- below. + step = V.fromList . map (* mag) . reverse . mk_pls ploidy . reverse . pls + + -- Meh. Pointless, but happens to be the unit. + mk_pls 0 _ = return 0 + + -- Okay, we sample ONE allele. Likelihood of the data is simply the + -- GL value that was passed to us. + mk_pls 1 ls = ls + + -- We extend the genotype and sample another allele. + mk_pls n ls = do ls'@(hd:_) <- tails ls + (+) hd <$> mk_pls (n-1) ls' + + +-- | Make a list of genotypes, each represented as a vector of allele +-- probabilities, from ploidy and four possible alleles. +-- +-- This makes the most sense for SNPs. The implied order of alleles is +-- A,C,G,T, and the resulting genotype vectors can straight forwardly be +-- mutiplied with a substitution matrix to give a sensible result. +-- (Something similar for indels could be imagined, but doesn't seem all +-- that useful. We specialize for SNPs to get simpler types and +-- efficient code.) +-- +-- "For biallelic sites the ordering is: AA,AB,BB; for triallelic +-- sites the ordering is: AA,AB,BB,AC,BC,CC, etc." + +mk_snp_gts :: Int -> [Vec4D] +mk_snp_gts ploidy = go ploidy alleles + where + !mag = recip $ fromIntegral ploidy + alleles = [ Vec4D 1 0 0 0, Vec4D 0 1 0 0, Vec4D 0 0 1 0, Vec4D 0 0 0 1 ] + + -- 'go p' as returns all p-ploid genotypes that can be made from the + -- alleles 'as', in the order in which they appear in VCF. + -- So, that's + -- - all (p-1)-ploid genotypes that can be made from 1 allele, plus allele 0 (AA) + -- - all (p-1)-ploid genotypes that can be made from 2 alleles, plus allele 1 (AC,CC) + -- ... + -- + -- - there's one 0-ploid genotype: the zero vector + -- - the genotypes that can be made from 0 alleles is an empty list + + go !p as | p == 0 = [ Vec4D 0 0 0 0 ] + | otherwise = [ gt + mag * last as' | as'@(_:_) <- inits as, gt <- go (p-1) as' ] + +-- | SNP call according to maq/samtools/bsnp model. The matrix k counts +-- how many errors we made, approximately. + +maq_snp_call :: Int -> Double -> BasePile -> GL +maq_snp_call ploidy theta bases = V.fromList $ map l $ mk_snp_gts ploidy + where + -- Bases with effective qualities in order of decreasing(!) quality. + -- A vector based algorithm may fit here. + bases' = sortBy (flip $ comparing db_qual) + [ db { db_qual = mq `min` db_qual db } | (mq,db) <- bases ] + + everynuc :: Vec.Vec4 Nucleotide + everynuc = nucA :. nucC :. nucG :. nucT :. () + + -- L(G) + l gt = l' gt (toProb 1) (0 :: Mat44D) bases' + + l' _ !acc _ [ ] = acc + l' !gt !acc !k (!x:xs) = + let + -- P(X|Q,H), a vector of four (x is fixed, h is not) + -- this is the simple form where we set all w to 1/4 + p_x__q_h_ = Vec.map (\h -> 0.25 * fromQualRaised (theta ** (k ! h :-> db_call x)) (db_qual x)) everynuc + p_x__q_h = Vec.zipWith (\p h -> if db_call x == h then 1 + p - Vec.sum p_x__q_h_ else p) p_x__q_h_ everynuc + + -- P(H|X), again a vector of four + p_x__q = dot p_x__q_h dg + p_h__x = Vec.zipWith (\p p_h -> p / p_x__q * p_h) p_x__q_h dg + dg = (db_dmg x `multmv` gt) + + kk = Vec.getElem (fromIntegral . unN $ db_call x) k + pack p_h__x + k' = Vec.setElem (fromIntegral . unN $ db_call x) kk k + + acc' = acc * toProb p_x__q + meh = Vec.map (\h -> k ! h :-> db_call x) everynuc -- XXX + in {- trace (unlines ["gt " ++ show gt + ,"p(x|q,h) " ++ show p_x__q_h + ,"dg " ++ show dg ++ ", call = " ++ show (db_call x) + ,"p(h|x) " ++ show p_h__x + ,"k " ++ show k + ,"k' " ++ show k' + ,"meh " ++ show meh]) $ -} l' gt acc' k' xs + +{- +smoke_test :: IO () +smoke_test = + -- decodeAnyBamFile "/mnt/datengrab/test.bam" >=> run $ \_hdr -> + -- enumPure1Chunk crap_data >=> run $ + -- joinI $ filterStream ((/=) (Q 0) . br_mapq) $ + -- joinI $ pileup (dsDamage $ DSD 0.9 0.02 0.3) $ -- noDamage $ + joinI $ pileup (ssDamage $ SSD 0.9 0.02 0.3 0.5) $ -- noDamage $ + -- joinI $ takeStream 5 $ mapStreamM_ print + -- joinI $ filterStream ((> 0) . either vc_mapq0 vc_mapq0) $ + joinI $ takeStream 5000 $ mapStreamM_ call_and_print + where + call_and_print (Right ic) = put . showCall show_indels . fmap (simple_indel_call 2) $ ic + call_and_print (Left bc) = put . showCall show_bases . fmap (simple_snp_call 2) $ bc + + put f = putStr $ f "\n" + + show_bases :: () -> ShowS + show_bases () = (++) "A,C,G,T" + + show_indels :: IndelVars -> ShowS + show_indels = (++) . intercalate "," . map show_indel + + show_indel :: (Int, [Nucleotide]) -> String + show_indel (d, ins) = shows ins $ '-' : show d +-} + +{- showCall :: (a -> ShowS) -> VarCall (GL,a) -> ShowS +showCall f vc = shows (vc_refseq vc) . (:) ':' . + shows (vc_pos vc) . (:) '\t' . + f (snd $ vc_vars vc) . (++) "\tDP=" . + shows (vc_depth vc) . (++) ":MQ0=" . + shows (vc_mapq0 vc) . (++) ":MAPQ=" . + shows mapq . (:) '\t' . + show_pl (fst $ vc_vars vc) + where + show_pl :: Vector Prob -> ShowS + show_pl = (++) . intercalate "," . map show . V.toList + + mapq = vc_sum_mapq vc `div` vc_depth vc -} + + +-- | Error model with dependency parameter. Since both strands are +-- supposed to still be independent, we feed in only one pile, and +-- later combine both calls. XXX What's that doing HERE?! + diff --git a/src/Bio/Genocall/Adna.hs b/src/Bio/Genocall/Adna.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Genocall/Adna.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE BangPatterns, RecordWildCards #-} +module Bio.Genocall.Adna where + +import Bio.Base +import Data.Vec +import qualified Data.Vector as V + +-- ^ Things specific to ancient DNA, e.g. damage models. +-- +-- For aDNA, we need a substitution probability. We have three options: +-- use an empirically determined PSSM, use an arithmetically defined +-- PSSM based on the /Johnson/ model, use a context sensitive PSSM based +-- on the /Johnson/ model and an alignment. Using /Dindel/, actual +-- substitutions relative to a called haplotype would be taken into +-- account. Since we're not going to do that, taking alignments into +-- account is difficult, somewhat approximate, and therefore not worth +-- the hassle. +-- +-- We represent substitution matrices by the type 'Mat44D'. Internally, +-- this is a vector of packed vectors. Conveniently, each of the packed +-- vectors represents all transition /into/ the given nucleotide. + + +-- | A 'DamageModel' is a function that gives substitution matrices for +-- each position in a read. The 'DamageModel' can depend on the length +-- of the read and whether its alignment is reversed. In practice, we +-- should probably memoize precomputed damage models somehow. + +type DamageModel a = Bool -> Int -> V.Vector (Mat44 a) + +data To = Nucleotide :-> Nucleotide + +infix 9 :-> +infix 8 ! + +-- | Convenience function to access a substitution matrix that has a +-- mnemonic reading. +{-# INLINE (!) #-} +(!) :: Mat44D -> To -> Double +(!) m (N x :-> N y) = getElem (fromIntegral x) $ getElem (fromIntegral y) m + +-- | 'DamageModel' for undamaged DNA. The likelihoods follow directly +-- from the quality score. This needs elaboration to see what to do +-- with amibiguity codes (even though those haven't actually been +-- observed in the wild). + +{-# SPECIALIZE noDamage :: DamageModel Double #-} +noDamage :: Num a => DamageModel a +noDamage _ l = V.replicate l identity + + +-- | Parameters for the universal damage model. +-- +-- We assume the correct model is either no damage, or single strand +-- damage, or double strand damage. Each of them comes with a +-- probability. It turns out that blending them into one is simply +-- accomplished by multiplying these probabilities onto the deamination +-- probabilities. +-- +-- For single stranded library prep, only one kind of damage occurs (C +-- to T), it occurs at low frequency ('ssd_delta') everywhere, at high +-- frequency ('ssd_sigma') in single stranded parts, and the overhang +-- length is distributed exponentially with parameter 'ssd_lambda' at +-- the 5' end and 'ssd_kappa' at the 3' end. (Without UDG treatment, +-- those will be equal. With UDG, those are much smaller and in fact +-- don't literally represent overhangs.) +-- +-- For double stranded library prep, we get C->T damage at the 5' end +-- and G->A at the 3' end with rate 'dsd_sigma' and both in the interior +-- with rate 'dsd_delta'. Everything is symmetric, and therefore the +-- orientation of the aligned read doesn't matter either. Both +-- overhangs follow a distribution with parameter 'dsd_lambda'. + +data DamageParameters float = DP { ssd_sigma :: !float -- deamination rate in ss DNA, SS model + , ssd_delta :: !float -- deamination rate in ds DNA, SS model + , ssd_lambda :: !float -- param for geom. distribution, 5' end, SS model + , ssd_kappa :: !float -- param for geom. distribution, 3' end, SS model + , dsd_sigma :: !float -- deamination rate in ss DNA, DS model + , dsd_delta :: !float -- deamination rate in ds DNA, DS model + , dsd_lambda :: !float } -- param for geom. distribution, DS model + deriving (Read, Show) + +-- | Generic substitution matrix, has C->T and G->A deamination as +-- parameters. Setting 'p' or 'q' to 0 as appropriate makes this apply +-- to the single stranded or undamaged case. + +genSubstMat :: Fractional a => a -> a -> Mat44 a +genSubstMat p q = vec4 ( vec4 1 0 q 0 ) + ( vec4 0 (1-p) 0 0 ) + ( vec4 0 0 (1-q) 0 ) + ( vec4 0 p 0 1 ) + +-- Forward strand first, C->T only; reverse strand next, G->A instead + +{- +{-# SPECIALIZE ssDamage :: SsDamageParameters Double -> DamageModel Double #-} +ssDamage :: Fractional a => SsDamageParameters a -> DamageModel a +ssDamage SSD{..} r l = V.generate l $ if r then ssd_rev else ssd_fwd + where + ssd_fwd i = genSubstMat p 0 + where + !lam5 = ssd_lambda ^ (1+i) + !lam3 = ssd_kappa ^ (l-i) + !lam = lam3 + lam5 - lam3 * lam5 + !p = ssd_sigma * lam + ssd_delta * (1-lam) + + ssd_rev i = genSubstMat 0 p + where + !lam5 = ssd_lambda ^ (l-i) + !lam3 = ssd_kappa ^ (1+i) + !lam = lam3 + lam5 - lam3 * lam5 + !p = ssd_sigma * lam + ssd_delta * (1-lam) + + + +{-# SPECIALIZE dsDamage :: DsDamageParameters Double -> DamageModel Double #-} +dsDamage :: Fractional a => DsDamageParameters a -> DamageModel a +dsDamage DSD{..} _ l = V.generate l mat + where + mat i = genSubstMat p q + where + p = dsd_sigma * lam5 + dsd_delta * (1-lam5) + q = dsd_sigma * lam3 + dsd_delta * (1-lam3) + lam5 = dsd_lambda ^ (1+i) + lam3 = dsd_lambda ^ (l-i) +-} + +{-# INLINE vec4 #-} +vec4 :: a -> a -> a -> a -> Vec4 a +vec4 a b c d = a :. b :. c :. d :. () + +memoDamageModel :: DamageModel a -> DamageModel a +memoDamageModel f = \r l -> if l > 512 || l < 0 then f r l + else if r then V.unsafeIndex rev l + else V.unsafeIndex fwd l + where + rev = V.generate 512 $ f True + fwd = V.generate 512 $ f False + +{-# SPECIALIZE univDamage :: DamageParameters Double -> DamageModel Double #-} +univDamage :: Fractional a => DamageParameters a -> DamageModel a +univDamage DP{..} r l = V.generate l mat + where + mat i = genSubstMat (p1+p2) (q1+q2) + where + (p1, q1) = if r then let lam5 = ssd_lambda ^ (l-i) + lam3 = ssd_kappa ^ (1+i) + lam = lam3 + lam5 - lam3 * lam5 + p = ssd_sigma * lam + ssd_delta * (1-lam) + in (0,p) + else let lam5 = ssd_lambda ^ (1+i) + lam3 = ssd_kappa ^ (l-i) + lam = lam3 + lam5 - lam3 * lam5 + p = ssd_sigma * lam + ssd_delta * (1-lam) + in (p,0) + + p2 = dsd_sigma * lam5_ds + dsd_delta * (1-lam5_ds) + q2 = dsd_sigma * lam3_ds + dsd_delta * (1-lam3_ds) + lam5_ds = dsd_lambda ^ (1+i) + lam3_ds = dsd_lambda ^ (l-i) + diff --git a/src/Bio/Genocall/AvroFile.hs b/src/Bio/Genocall/AvroFile.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Genocall/AvroFile.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +module Bio.Genocall.AvroFile where + +import Bio.Base +import Bio.Bam.Pileup +import Data.Aeson +import Data.Avro hiding ((.=)) +import Data.Binary.Builder +import Data.Binary.Get +import Data.Monoid + +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Vector.Unboxed as U + +-- ^ File format for genotype calls. + +-- | To output a container file, we need to convert calls into a stream of +-- sensible objects. To cut down on redundancy, the object will have a +-- header that names the reference sequence and the start, followed by +-- calls. The calls themselves have contiguous coordinates, we start a +-- new block if we have to skip; we also start a new block when we feel +-- the current one is getting too large. + +data GenoCallBlock = GenoCallBlock + { reference_name :: T.Text + , start_position :: Int + , called_sites :: [ GenoCallSite ] } + +data GenoCallSite = GenoCallSite + { snp_stats :: CallStats + , snp_likelihoods :: [ Int ] -- B.ByteString + , indel_stats :: CallStats + , indel_variants :: [ IndelVariant ] + , indel_likelihoods :: [ Int ] -- B.ByteString + } + +$( deriveAvros [ ''GenoCallBlock, ''GenoCallSite, ''CallStats, ''IndelVariant ] ) + +instance Avro V_Nuc where + toSchema _ = return $ object [ "type" .= String "bytes", "doc" .= String "A,C,G,T" ] + toBin (V_Nuc v) = encodeIntBase128 (U.length v) <> U.foldr ((<>) . singleton . unN) mempty v + fromBin = decodeIntBase128 >>= fmap (V_Nuc . U.fromList . map N . B.unpack) . getByteString + toAvron (V_Nuc v) = String . T.pack . map w2c . U.toList $ U.map unN v + diff --git a/src/Bio/Glf.hs b/src/Bio/Glf.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Glf.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE FlexibleContexts #-} +module Bio.Glf ( + GlfSeq(..), + GlfRec(..), + enee_glf_file, + enum_glf_file, + enum_glf_handle + ) where + +import Bio.Iteratee +import Bio.Iteratee.Bgzf +import Control.Monad +import Data.Bits +import System.IO + +import qualified Data.ByteString.Char8 as S +import qualified Data.Iteratee.ListLike as I + + +data GlfRec = SNP { glf_refbase :: {-# UNPACK #-} !Char + , glf_offset :: {-# UNPACK #-} !Int + , glf_depth :: {-# UNPACK #-} !Int + , glf_min_lk :: {-# UNPACK #-} !Int + , glf_mapq :: {-# UNPACK #-} !Int + , glf_lk :: [Int] } + | Indel { glf_refbase :: {-# UNPACK #-} !Char + , glf_offset :: {-# UNPACK #-} !Int + , glf_depth :: {-# UNPACK #-} !Int + , glf_min_lk :: {-# UNPACK #-} !Int + , glf_mapq :: {-# UNPACK #-} !Int + , glf_lk_hom1 :: {-# UNPACK #-} !Int + , glf_lk_hom2 :: {-# UNPACK #-} !Int + , glf_lk_het :: {-# UNPACK #-} !Int + , glf_is_ins1 :: !Bool + , glf_is_ins2 :: !Bool + , glf_seq1 :: {-# UNPACK #-} !S.ByteString + , glf_seq2 :: {-# UNPACK #-} !S.ByteString } + deriving Show + +data GlfSeq = GlfSeq { glf_seqname :: {-# UNPACK #-} !S.ByteString + , glf_seqlen :: {-# UNPACK #-} !Int } + deriving Show + + +enee_glf_recs :: Monad m => Enumeratee S.ByteString [GlfRec] m b +enee_glf_recs = eneeCheckIfDone step + where + step oit' = I.isFinished >>= step' oit' + + step' oit' True = return $ liftI oit' + step' oit' False = do + type_ref <- I.head + let refbase = "XACMGRSVTWYHKDBN" !! fromIntegral (type_ref .&. 0xf) + case type_ref `shiftR` 4 of + 0 -> return $ oit' $ EOF Nothing + 1 -> do r <- get_snp $ get_common (SNP refbase) + eneeCheckIfDone step . oit' $ Chunk [r] + 2 -> do r <- get_indel $ get_common (Indel refbase) + eneeCheckIfDone step . oit' $ Chunk [r] + x -> fail $ "unknown GLF record #" ++ show x + + get_common f = return f + `ap` (fromIntegral `liftM` endianRead4 LSB) + `ap` (fromIntegral `liftM` endianRead3 LSB) + `ap` (fromIntegral `liftM` I.head) + `ap` (fromIntegral `liftM` I.head) + + get_snp f = f `ap` get_lk_arr + get_lk_arr = replicateM 10 (fromIntegral `liftM` I.head) + + get_indel f = do + f' <- f `ap` (fromIntegral `liftM` I.head) + `ap` (fromIntegral `liftM` I.head) + `ap` (fromIntegral `liftM` I.head) + l1 <- getInt16le + l2 <- getInt16le + liftM2 (f' (l1 >= 0) (l2 >= 0)) (iGetString (abs l1)) (iGetString (abs l2)) + + getInt16le = do i <- endianRead2 LSB + return $ if i > 0x7fff then fromIntegral i - 0x10000 + else fromIntegral i + +enee_glf_seq :: Monad m => (GlfSeq -> Enumeratee [GlfRec] a m b) -> Enumeratee S.ByteString a m b +enee_glf_seq per_seq oit = do l <- endianRead4 LSB + s <- liftM2 GlfSeq (S.init `liftM` iGetString (fromIntegral l)) + (fromIntegral `liftM` endianRead4 LSB) + enee_glf_recs ><> per_seq s $ oit + +-- | Iterates over a GLF file. In @get_glf_file per_seq per_file@, the +-- enumerator @per_file genome_name@, where @genome_name@ is the name +-- stored in the GLF header, is run once, then the enumeratee @per_seq +-- glfseq@ is iterated over the records in each sequence. +enee_glf_file :: Monad m => (GlfSeq -> Enumeratee [GlfRec] a m b) + -> (S.ByteString -> Enumerator a m b) + -> Enumeratee S.ByteString a m b +enee_glf_file per_seq per_file oit = do + matched <- I.heads (S.pack "GLF\003") + when (matched /= 4) (fail "GLF signature not found") + nm <- endianRead4 LSB >>= iGetString . fromIntegral + lift (per_file nm oit) >>= loop + where + -- loop :: Monad m => Iteratee a m b -> Iteratee S.ByteString m (Iteratee a m b) + loop it = I.isFinished >>= loop' it + loop' it True = return it + loop' it False = loop =<< enee_glf_seq per_seq it + + +-- | Enumerate the contents of a GLF file, apply suitable Enumeratees to +-- both sequences and records, resulting in an Enumerator of /whatever/, +-- typically output Strings or records... +-- +-- This type is positively weird and I'm not entirely sure this is the +-- right way to go about it. +enum_glf_file :: (MonadIO m, MonadMask m) + => FilePath + -> (GlfSeq -> Enumeratee [GlfRec] a m b) + -> (S.ByteString -> Enumerator a m b) + -> Enumerator a m b +enum_glf_file fp per_seq per_file output = + enumFile defaultBufSize fp >=> run $ + joinI $ decompressBgzf $ + enee_glf_file per_seq per_file output + +enum_glf_handle :: (MonadIO m, MonadMask m) + => Handle + -> (GlfSeq -> Enumeratee [GlfRec] a m b) + -> (S.ByteString -> Enumerator a m b) + -> Enumerator a m b +enum_glf_handle hdl per_seq per_file output = + enumHandle defaultBufSize hdl >=> run $ + joinI $ decompressBgzf $ + enee_glf_file per_seq per_file output + diff --git a/src/Bio/Iteratee.hs b/src/Bio/Iteratee.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Iteratee.hs @@ -0,0 +1,503 @@ +{-# LANGUAGE PatternGuards, BangPatterns, DeriveDataTypeable #-} + +-- | Basically a reexport of "Data.Iteratee" less the names that clash +-- with "Prelude" plus a handful of utilities. + +module Bio.Iteratee ( + groupStreamBy, + groupStreamOn, + iGetString, + iLookAhead, + headStream, + peekStream, + takeStream, + dropStream, + mapStreamM, + mapStreamM_, + filterStream, + filterStreamM, + foldStream, + foldStreamM, + zipStreams, + protectTerm, + concatMapStream, + concatMapStreamM, + mapMaybeStream, + parMapChunksIO, + progressNum, + + I.mapStream, + I.takeWhileE, + I.tryHead, + I.isFinished, + I.heads, + I.breakE, + + ($==), + mBind, mBind_, ioBind, ioBind_, + ListLike, + MonadIO, MonadMask, + lift, liftIO, + (>=>), (<=<), + stdin, stdout, stderr, + + enumAuxFile, + enumInputs, + enumDefaultInputs, + defaultBufSize, + + Ordering'(..), + mergeSortStreams, + + Enumerator', + Enumeratee', + mergeEnums', + + QQ(..), + emptyQ, + lengthQ, + pushQ, + popQ, + cancelAll, + + ParseError(..), + parserToIteratee, + stream2vector, + stream2vectorN, + + Fd, + withFileFd, + module X ) where + +import Bio.Base ( findAuxFile ) +import Bio.Util ( showNum ) +import Control.Concurrent.Async ( Async, async, wait, cancel ) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Iteratee.Binary as X +import Data.Iteratee.Char as X +import Data.Iteratee.IO as X hiding ( defaultBufSize ) +import Data.Iteratee.Iteratee as X hiding ( identity ) +import Data.ListLike ( ListLike ) +import Data.Monoid +import Data.Typeable +import System.IO ( stdin, stdout, stderr, hIsTerminalDevice ) +import System.Environment ( getArgs ) +import System.Mem ( performGC ) +import System.Posix ( Fd, openFd, closeFd, OpenMode(..), defaultFileFlags ) + +import qualified Data.Attoparsec.ByteString as A +import qualified Data.ByteString as S +import qualified Data.Iteratee as I +import qualified Data.ListLike as LL +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VM + +-- | Grouping on 'Iteratee's. @groupStreamOn proj inner outer@ executes +-- @inner (proj e)@, where @e@ is the first input element, to obtain an +-- 'Iteratee' @i@, then passes elements @e@ to @i@ as long as @proj e@ +-- produces the same result. If @proj e@ changes or the input ends, the +-- pair of @proj e@ and the result of @run i@ is passed to @outer@. At +-- end of input, the resulting @outer@ is returned. +groupStreamOn :: (Monad m, LL.ListLike l e, Eq t1, NullPoint l, Nullable l) + => (e -> t1) + -> (t1 -> m (Iteratee l m t2)) + -> Enumeratee l [(t1, t2)] m a +groupStreamOn proj inner = eneeCheckIfDonePass (icont . step) + where + step outer (EOF mx) = idone (liftI outer) $ EOF mx + step outer c@(Chunk as) + | LL.null as = liftI $ step outer + | otherwise = let x = proj (LL.head as) + in lift (inner x) >>= \i -> step' x i outer c + + -- We want to feed a 'Chunk' to the inner 'Iteratee', which might be + -- finished. In that case, we would want to abort, but we cannot, + -- since the outer iteration is still going on. So instead we + -- discard data we would have fed to the inner 'Iteratee'. (Use of + -- 'enumPure1Chunk' is not appropriate, it would accumulate the + -- data, just to have it discarded by the 'run' that eventually + -- happens. + + step' c it outer (Chunk as) + | LL.null as = liftI $ step' c it outer + | (l,r) <- LL.span ((==) c . proj) as, not (LL.null l) = + let od a _str = idoneM a $ EOF Nothing + oc k Nothing = return $ k (Chunk l) + oc k m = icontM k m + in lift (runIter it od oc) >>= \it' -> step' c it' outer (Chunk r) + + step' c it outer str = + lift (run it) >>= \b -> eneeCheckIfDone (`step` str) . outer $ Chunk [(c,b)] + + +-- | Grouping on 'Iteratee's. @groupStreamBy cmp inner outer@ executes +-- @inner@ to obtain an 'Iteratee' @i@, then passes elements @e@ to @i@ +-- as long as @cmp e0 e@, where @e0@ is some preceeding element, is +-- true. Else, the result of @run i@ is passed to @outer@ and +-- 'groupStreamBy' restarts. At end of input, the resulting @outer@ is +-- returned. +groupStreamBy :: (Monad m, LL.ListLike l t, NullPoint l, Nullable l) + => (t -> t -> Bool) + -> m (Iteratee l m t2) + -> Enumeratee l [t2] m a +groupStreamBy cmp inner = eneeCheckIfDonePass (icont . step) + where + step outer (EOF mx) = idone (liftI outer) $ EOF mx + step outer c@(Chunk as) + | LL.null as = liftI $ step outer + | otherwise = lift inner >>= \i -> step' (LL.head as) i outer c + + step' c it outer (Chunk as) + | LL.null as = liftI $ step' c it outer + | (l,r) <- LL.span (cmp c) as, not (LL.null l) = + let od a _str = idoneM a $ EOF Nothing + oc k Nothing = return $ k (Chunk l) + oc k m = icontM k m + in lift (runIter it od oc) >>= \it' -> step' (LL.head l) it' outer (Chunk r) + + step' _ it outer str = + lift (run it) >>= \b -> eneeCheckIfDone (`step` str) . outer $ Chunk [b] + + +-- | Take a prefix of a stream, the equivalent of 'Data.List.take'. +{-# INLINE takeStream #-} +takeStream :: (Monad m, Nullable s, ListLike s el) => Int -> Enumeratee s s m a +takeStream = I.take + +-- | Take first element of a stream or fail. +{-# INLINE headStream #-} +headStream :: ListLike s el => Iteratee s m el +headStream = I.head + +{-# INLINE peekStream #-} +peekStream :: ListLike s el => Iteratee s m (Maybe el) +peekStream = I.peek + +{-# INLINE dropStream #-} +dropStream :: (Nullable s, ListLike s el) => Int -> Iteratee s m () +dropStream = I.drop + +-- | Run an Iteratee, collect the input. When it finishes, return the +-- result along with *all* input. Effectively allows lookahead. Be +-- careful, this will eat memory if the @Iteratee@ doesn't return +-- speedily. +iLookAhead :: Monoid s => Iteratee s m a -> Iteratee s m a +iLookAhead = go mempty + where + go acc it = Iteratee $ \od oc -> runIter it (\x _ -> od x (Chunk acc)) (oc . step acc) + + step acc k c@(Chunk str) = go (acc `mappend` str) (k c) + step acc k c@(EOF _) = Iteratee $ \od1 -> runIter (k c) (\x _ -> od1 x (Chunk acc)) + + +-- | Collects a string of a given length. Don't use this for long +-- strings, use 'takeStream' instead. +iGetString :: Monad m => Int -> Iteratee S.ByteString m S.ByteString +iGetString 0 = idone S.empty (Chunk S.empty) +iGetString n = liftI $ step [] 0 + where + step acc l c@(EOF _) = icont (step acc l) (Just $ setEOF c) + step acc l (Chunk c) | l + S.length c >= n = let r = S.concat . reverse $ S.take (n-l) c : acc + in idone r (Chunk $ S.drop (n-l) c) + | otherwise = liftI $ step (c:acc) (l + S.length c) + +{-# INLINE mBind #-} +-- | Lifts a monadic action and combines it with a continuation. +-- @mBind m f@ is the same as @lift m >>= f@, but does not require a +-- 'Nullable' constraint on the stream type. +infixl 1 `mBind` +mBind :: Monad m => m a -> (a -> Iteratee s m b) -> Iteratee s m b +mBind m f = Iteratee $ \onDone onCont -> m >>= \a -> runIter (f a) onDone onCont + +{-# INLINE mBind_ #-} +-- | Lifts a monadic action, ignored the result and combines it with a +-- continuation. @mBind_ m f@ is the same as @lift m >>= f@, but does +-- not require a 'Nullable' constraint on the stream type. +infixl 1 `mBind_` +mBind_ :: Monad m => m a -> Iteratee s m b -> Iteratee s m b +mBind_ m b = Iteratee $ \onDone onCont -> m >> runIter b onDone onCont + +{-# INLINE ioBind #-} +-- | Lifts an IO action and combines it with a continuation. +-- @ioBind m f@ is the same as @liftIO m >>= f@, but does not require a +-- 'Nullable' constraint on the stream type. +infixl 1 `ioBind` +ioBind :: MonadIO m => IO a -> (a -> Iteratee s m b) -> Iteratee s m b +ioBind m f = Iteratee $ \onDone onCont -> liftIO m >>= \a -> runIter (f a) onDone onCont + +{-# INLINE ioBind_ #-} +-- | Lifts an IO action, ignores its result, and combines it with a +-- continuation. @ioBind_ m f@ is the same as @liftIO m >> f@, but does +-- not require a 'Nullable' constraint on the stream type. +infixl 1 `ioBind_` +ioBind_ :: MonadIO m => IO a -> Iteratee s m b -> Iteratee s m b +ioBind_ m b = Iteratee $ \onDone onCont -> liftIO m >> runIter b onDone onCont + +infixl 1 $== +{-# INLINE ($==) #-} +-- | Compose an 'Enumerator\'' with an 'Enumeratee', giving a new +-- 'Enumerator\''. +($==) :: Monad m => Enumerator' hdr input m (Iteratee output m result) + -> Enumeratee input output m result + -> Enumerator' hdr output m result +($==) enum enee iter = run =<< enum (enee . iter) + +-- | Merge two 'Enumerator\''s into one. The header provided by the +-- inner 'Enumerator\'' is passed to the output iterator, the header +-- provided by the outer 'Enumerator\'' is passed to the merging iteratee +-- +-- XXX Something about those headers is unsatisfactory... there should +-- be an unobtrusive way to combine headers. + +{-# INLINE mergeEnums' #-} +mergeEnums' :: (Nullable s2, Nullable s1, Monad m) + => Enumerator' hi s1 m a -- ^ inner enumerator + -> Enumerator' ho s2 (Iteratee s1 m) a -- ^ outer enumerator + -> (ho -> Enumeratee s2 s1 (Iteratee s1 m) a) -- ^ merging enumeratee + -> Enumerator' hi s1 m a +mergeEnums' e1 e2 etee i = e1 $ \hi -> e2 (\ho -> joinI . etee ho $ ilift lift (i hi)) >>= run + +-- | Apply a function to the elements of a stream, concatenate the +-- results into a stream. No giant intermediate list is produced. +{-# INLINE concatMapStream #-} +concatMapStream :: (Monad m, ListLike s a, NullPoint s, ListLike t b) => (a -> t) -> Enumeratee s t m r +concatMapStream f = eneeCheckIfDone (liftI . go) + where + go k (EOF mx) = idone (liftI k) (EOF mx) + go k (Chunk xs) | LL.null xs = liftI (go k) + | otherwise = eneeCheckIfDone (flip go (Chunk (LL.tail xs))) . k . Chunk . f $ LL.head xs + +-- | Apply a monadic function to the elements of a stream, concatenate +-- the results into a stream. No giant intermediate list is produced. +{-# INLINE concatMapStreamM #-} +concatMapStreamM :: (Monad m, ListLike s a, NullPoint s, ListLike t b) => (a -> m t) -> Enumeratee s t m r +concatMapStreamM f = eneeCheckIfDone (liftI . go) + where + go k (EOF mx) = idone (liftI k) (EOF mx) + go k (Chunk xs) | LL.null xs = liftI (go k) + | otherwise = f (LL.head xs) `mBind` + eneeCheckIfDone (flip go (Chunk (LL.tail xs))) . k . Chunk + +{-# INLINE mapMaybeStream #-} +mapMaybeStream :: (Monad m, ListLike s a, NullPoint s, ListLike t b) => (a -> Maybe b) -> Enumeratee s t m r +mapMaybeStream f = mapChunks mm + where + mm l = if LL.null l then LL.empty else + case f (LL.head l) of Nothing -> mm (LL.tail l) + Just b -> LL.cons b $ mm (LL.tail l) + +-- | Apply a filter predicate to an 'Iteratee'. +{-# INLINE filterStream #-} +filterStream :: (Monad m, ListLike s a, NullPoint s) => (a -> Bool) -> Enumeratee s s m r +filterStream = mapChunks . LL.filter + +-- | Apply a monadic filter predicate to an 'Iteratee'. +{-# INLINE filterStreamM #-} +filterStreamM :: (Monad m, ListLike s a, Nullable s, NullPoint s) => (a -> m Bool) -> Enumeratee s s m r +filterStreamM k = mapChunksM (go id) + where + go acc s | LL.null s = return $! acc LL.empty + | otherwise = do p <- k (LL.head s) + let acc' = if p then LL.cons (LL.head s) . acc else acc + go acc' (LL.tail s) + +-- | Map a monadic function over an 'Iteratee'. +{-# INLINE mapStreamM #-} +mapStreamM :: (Monad m, ListLike (s el) el, ListLike (s el') el', NullPoint (s el), Nullable (s el), LooseMap s el el') + => (el -> m el') -> Enumeratee (s el) (s el') m a +mapStreamM = mapChunksM . LL.mapM + +-- | Map a monadic function over an 'Iteratee', discarding the results. +{-# INLINE mapStreamM_ #-} +mapStreamM_ :: (Monad m, Nullable s, ListLike s el) => (el -> m b) -> Iteratee s m () +mapStreamM_ = mapChunksM_ . LL.mapM_ + +-- | Fold a monadic function over an 'Iteratee'. +{-# INLINE foldStreamM #-} +foldStreamM :: (Monad m, Nullable s, ListLike s a) => (b -> a -> m b) -> b -> Iteratee s m b +foldStreamM k = foldChunksM go + where + go b s | LL.null s = return b + | otherwise = k b (LL.head s) >>= \b' -> go b' (LL.tail s) + +-- | Fold a function over an 'Iteratee'. +foldStream :: (Monad m, Nullable s, ListLike s a) => (b -> a -> b) -> b -> Iteratee s m b +foldStream f = foldChunksM (\b s -> return $! LL.foldl' f b s) + + +zipStreams :: (Monad m, Nullable s, ListLike s e) + => Iteratee s m a -> Iteratee s m b -> Iteratee s m (a, b) +zipStreams = I.zip + +type Enumerator' h eo m b = (h -> Iteratee eo m b) -> m (Iteratee eo m b) +type Enumeratee' h ei eo m b = (h -> Iteratee eo m b) -> Iteratee ei m (Iteratee eo m b) + +enumAuxFile :: (MonadIO m, MonadMask m) => FilePath -> Iteratee S.ByteString m a -> m a +enumAuxFile fp it = liftIO (findAuxFile fp) >>= fileDriver it + +enumDefaultInputs :: (MonadIO m, MonadMask m) => Enumerator S.ByteString m a +enumDefaultInputs it0 = liftIO getArgs >>= flip enumInputs it0 + +enumInputs :: (MonadIO m, MonadMask m) => [FilePath] -> Enumerator S.ByteString m a +enumInputs [] = enumHandle defaultBufSize stdin +enumInputs xs = go xs + where go ("-":fs) = enumHandle defaultBufSize stdin >=> go fs + go ( f :fs) = enumFile defaultBufSize f >=> go fs + go [ ] = return + +-- | Default buffer size in elements. This is 1024 in "Data.Iteratee", +-- which is obviously too small. Since we want to merge many files, a +-- read should take more time than a seek. This sets the sensible +-- buffer size to more than about one MB. +defaultBufSize :: Int +defaultBufSize = 2*1024*1024 + + +data Ordering' a = Less | Equal a | NotLess + +mergeSortStreams :: (Monad m, ListLike s a, Nullable s) => (a -> a -> Ordering' a) -> Enumeratee s s (Iteratee s m) b +mergeSortStreams comp = eneeCheckIfDone step + where + step out = peekStream >>= \mx -> lift peekStream >>= \my -> case (mx, my) of + (Just x, Just y) -> case x `comp` y of + Less -> do I.drop 1 ; eneeCheckIfDone step . out . Chunk $ LL.singleton x + NotLess -> do lift (I.drop 1) ; eneeCheckIfDone step . out . Chunk $ LL.singleton y + Equal z -> do I.drop 1 ; lift (I.drop 1) ; eneeCheckIfDone step . out . Chunk $ LL.singleton z + + (Just x, Nothing) -> do I.drop 1 ; eneeCheckIfDone step . out . Chunk $ LL.singleton x + (Nothing, Just y) -> do lift (I.drop 1) ; eneeCheckIfDone step . out . Chunk $ LL.singleton y + (Nothing, Nothing) -> idone (liftI out) $ EOF Nothing + + +-- | Parallel map of an IO action over the elements of a stream +-- +-- This 'Enumeratee' applies an 'IO' action to every chunk of the input +-- stream. These 'IO' actions are run asynchronously in a limited +-- parallel way. Don't forget to `evaluate` + +parMapChunksIO :: (MonadIO m, Nullable s) => Int -> (s -> IO t) -> Enumeratee s t m a +parMapChunksIO np f = eneeCheckIfDonePass (go emptyQ) + where + -- check if the queue is full + go !qq k (Just e) = cancelAll qq >> icont (go' emptyQ k) (Just e) + go !qq k Nothing = case popQ qq of + Just (a,qq') | lengthQ qq == np -> liftIO (wait a) >>= eneeCheckIfDonePass (go qq') . k . Chunk + _ -> liftI $ go' qq k + + -- we have room for input + go' !qq k (EOF mx) = do a <- liftIO (async (f empty)) + goE mx (pushQ a qq) k Nothing + go' !qq k (Chunk c) = do a <- liftIO (async (f c)) + go (pushQ a qq) k Nothing + + -- input ended, empty the queue + goE _ !qq k (Just e) = cancelAll qq >> icont (go' emptyQ k) (Just e) + goE mx !qq k Nothing = case popQ qq of + Nothing -> idone (liftI k) (EOF mx) + Just (a,qq') -> liftIO (wait a) >>= eneeCheckIfDonePass (goE mx qq') . k . Chunk + +-- | Protects the terminal from binary junk. If @i@ is an 'Iteratee' +-- that might write binary to 'stdout', then @protectTerm i@ is the same +-- 'Iteratee', but it will abort if 'stdout' is a terminal device. +protectTerm :: (Nullable s, MonadIO m) => Iteratee s m a -> Iteratee s m a +protectTerm itr = do + t <- liftIO $ hIsTerminalDevice stdout + if t then err else itr + where + err = error "cowardly refusing to write binary data to terminal" + +-- | A simple progress indicator that prints the number of records. +progressNum :: (MonadIO m, Nullable s, NullPoint s, ListLike s a) + => String -> (String -> IO ()) -> Enumeratee s s m b +progressNum msg put = eneeCheckIfDonePass (icont . go 0) + where + go !_ k (EOF mx) = idone (liftI k) (EOF mx) + go !n k (Chunk as) = do let !n' = n + LL.length as + when (n `div` 65536 /= n' `div` 65536) . liftIO . + put $ "\27[K" ++ msg ++ showNum n ++ "\r" + eneeCheckIfDonePass (icont . go n') . k $ Chunk as + + +-- A very simple queue data type. +-- Invariants: q = QQ l f b --> l == length f + length b +-- --> l == 0 || not (null f) + +data QQ a = QQ !Int [a] [a] + +emptyQ :: QQ a +emptyQ = QQ 0 [] [] + +lengthQ :: QQ a -> Int +lengthQ (QQ l _ _) = l + +pushQ :: a -> QQ a -> QQ a +pushQ a (QQ l [] b) = QQ (l+1) (reverse (a:b)) [] +pushQ a (QQ l f b) = QQ (l+1) f (a:b) + +popQ :: QQ a -> Maybe (a, QQ a) +popQ (QQ l (a:[]) b) = Just (a, QQ (l-1) (reverse b) []) +popQ (QQ l (a:fs) b) = Just (a, QQ (l-1) fs b) +popQ (QQ _ [ ] _) = Nothing + +cancelAll :: MonadIO m => QQ (Async a) -> m () +cancelAll (QQ _ ff bb) = liftIO $ mapM_ cancel (ff ++ bb) + +data ParseError = ParseError {errorContexts :: [String], errorMessage :: String} + deriving (Show, Typeable) + +instance Exception ParseError + +-- | A function to convert attoparsec 'Parser's into 'Iteratee's. +parserToIteratee :: (Monad m) => A.Parser a -> Iteratee S.ByteString m a +parserToIteratee p = icont (f (A.parse p)) Nothing + where + f k (EOF Nothing) = + case A.feed (k S.empty) S.empty of + A.Fail _ err dsc -> throwErr (toException $ ParseError err dsc) + A.Partial _ -> throwErr (toException EofException) + A.Done rest v | S.null rest -> idone v (EOF Nothing) + | otherwise -> idone v (Chunk rest) + f _ (EOF (Just e)) = throwErr e + f k (Chunk s) + | S.null s = icont (f k) Nothing + | otherwise = + case k s of + A.Fail _ err dsc -> throwErr (toException $ ParseError err dsc) + A.Partial k' -> icont (f k') Nothing + A.Done rest v -> idone v (Chunk rest) + + +-- | Equivalent to @joinI $ takeStream n $ stream2vector@, but more +-- efficient. +stream2vectorN :: (MonadIO m, ListLike s a, Nullable s, VG.Vector v a) => Int -> Iteratee s m (v a) +stream2vectorN n = do + mv <- liftIO $ VM.new n + l <- go mv 0 + liftIO $ VG.unsafeFreeze $ VM.take l mv + where + go mv i + | i == n = return n + | otherwise = + I.tryHead >>= \x -> case x of + Nothing -> return i + Just a -> liftIO (VM.write mv i a) >> go mv (i+1) + +-- | Reads the whole stream into a 'VG.Vector'. +stream2vector :: (MonadIO m, ListLike s a, Nullable s, VG.Vector v a) => Iteratee s m (v a) +stream2vector = liftIO (VM.new 1024) >>= go 0 + where + go !i !mv = I.tryHead >>= \x -> case x of + Nothing -> liftIO $ VG.unsafeFreeze $ VM.take i mv + Just a -> do mv' <- if VM.length mv == i then liftIO (VM.grow mv (VM.length mv)) else return mv + when (i `rem` 0x10000 == 0) $ liftIO performGC + liftIO $ VM.write mv' i a + go (i+1) mv' + +withFileFd :: (MonadIO m, MonadMask m) => FilePath -> (Fd -> m a) -> m a +withFileFd filepath iter = bracket + (liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags) + (liftIO . closeFd) iter + diff --git a/src/Bio/Iteratee/Bgzf.hsc b/src/Bio/Iteratee/Bgzf.hsc new file mode 100644 --- /dev/null +++ b/src/Bio/Iteratee/Bgzf.hsc @@ -0,0 +1,498 @@ +{-# LANGUAGE ForeignFunctionInterface, BangPatterns, EmptyDataDecls #-} +{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} + +-- | Handling of BGZF files. Right now, we have an Enumeratee each for +-- input and output. The input iteratee can optionally supply virtual +-- file offsets, so that seeking is possible. + +module Bio.Iteratee.Bgzf ( + Block(..), decompressBgzfBlocks', decompressBgzfBlocks, + decompressBgzf, decompressPlain, + maxBlockSize, bgzfEofMarker, liftBlock, getOffset, + BgzfChunk(..), isBgzf, isGzip, parMapChunksIO, + compressBgzf, compressBgzfLv, compressBgzf', CompressParams(..), + compressChunk + ) where + +import Bio.Iteratee +import Control.Concurrent ( getNumCapabilities ) +import Control.Concurrent.Async ( async, wait ) +import Control.Monad ( liftM, forM_, when ) +import Data.Bits ( shiftL, shiftR, testBit, (.&.) ) +import Data.Monoid ( Monoid(..) ) +import Data.Word ( Word32, Word16, Word8 ) +import Foreign.Marshal.Alloc ( mallocBytes, free, allocaBytes ) +import Foreign.Storable ( peekByteOff, pokeByteOff ) +import Foreign.C.String ( withCAString ) +import Foreign.C.Types ( CInt(..), CChar(..), CUInt(..), CULong(..) ) +import Foreign.Ptr ( nullPtr, castPtr, Ptr, plusPtr, minusPtr ) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Unsafe as S +import qualified Data.Iteratee.ListLike as I + +#include + +-- | One BGZF block: virtual offset and contents. Could also be a block +-- of an uncompressed file, if we want to support indexing of +-- uncompressed BAM or some silliness like that. +data Block = Block { block_offset :: {-# UNPACK #-} !FileOffset + , block_contents :: {-# UNPACK #-} !S.ByteString } + +instance NullPoint Block where empty = Block 0 S.empty +instance Nullable Block where nullC (Block _ s) = S.null s + +instance Monoid Block where + mempty = empty + mappend (Block x s) (Block _ t) = Block x (s `S.append` t) + mconcat [] = empty + mconcat bs@(Block x _:_) = Block x $ S.concat [s|Block _ s <- bs] + +-- | "Decompresses" a plain file. What's actually happening is that the +-- offset in the input stream is tracked and added to the @ByteString@s +-- giving @Block@s. This results in the same interface as decompressing +-- actual Bgzf. +decompressPlain :: MonadIO m => Enumeratee S.ByteString Block m a +decompressPlain = eneeCheckIfDone (liftI . step 0) + where + step !o it (Chunk s) = eneeCheckIfDone (liftI . step (o + fromIntegral (S.length s))) . it $ Chunk (Block o s) + step _ it (EOF mx) = idone (liftI it) (EOF mx) + +-- | Decompress a BGZF stream into a stream of 'S.ByteString's. +decompressBgzf :: MonadIO m => Enumeratee S.ByteString S.ByteString m a +decompressBgzf = decompressBgzfBlocks ><> mapChunks block_contents + +decompressBgzfBlocks :: MonadIO m => Enumeratee S.ByteString Block m a +decompressBgzfBlocks out = do + np <- liftIO $ getNumCapabilities + decompressBgzfBlocks' np out + +-- | Decompress a BGZF stream into a stream of 'Block's, 'np' fold parallel. +decompressBgzfBlocks' :: MonadIO m => Int -> Enumeratee S.ByteString Block m a +decompressBgzfBlocks' np = eneeCheckIfDonePass (go 0 emptyQ) + where + -- check if the queue is full + go !off !qq k (Just e) = handleSeek off qq k e + go !off !qq k Nothing = case popQ qq of + Just (a, qq') | lengthQ qq == np -> liftIO (wait a) >>= eneeCheckIfDonePass (go off qq') . k . Chunk + _ -> liftI $ go' off qq k + + -- we have room for input, so try and get a compressed block + go' !_ !qq k (EOF mx) = goE mx qq k Nothing + go' !off !qq k (Chunk c) + | S.null c = liftI $ go' off qq k + | otherwise = joinIM $ enumPure1Chunk c $ do + (off', op) <- get_bgzf_block off + a <- liftIO (async op) + go off' (pushQ a qq) k Nothing + + -- input ended, empty the queue + goE _ !qq k (Just e) = handleSeek 0 qq k e + goE mx !qq k Nothing = case popQ qq of + Nothing -> idone (liftI k) (EOF mx) + Just (a,qq') -> liftIO (wait a) >>= eneeCheckIfDonePass (goE mx qq') . k . Chunk + + handleSeek !off !qq k e = case fromException e of + Nothing -> throwRecoverableErr e $ go' off qq k + Just (SeekException o) -> do + cancelAll qq + seek $ o `shiftR` 16 + eneeCheckIfDonePass (go (o `shiftR` 16) emptyQ) $ do + block'drop . fromIntegral $ o .&. 0xffff + k (EOF Nothing) + -- I think, 'seek' swallows one 'Stream' value on + -- purpose, so we have to give it a dummy one. + + block'drop sz = liftI $ \s -> case s of + EOF _ -> throwErr $ setEOF s + Chunk (Block p c) + | S.length c < sz -> block'drop (sz - S.length c) + | otherwise -> let b' = Block (p + fromIntegral sz) (S.drop sz c) + in idone () (Chunk b') + +get_bgzf_block :: MonadIO m => FileOffset -> Iteratee S.ByteString m (FileOffset, IO Block) +get_bgzf_block off = do !(csize,xlen) <- get_bgzf_header + !comp <- get_block . fromIntegral $ csize - xlen - 19 + !crc <- endianRead4 LSB + !isize <- endianRead4 LSB + + let !off' = off + fromIntegral csize + 1 + op = decompress1 (off `shiftL` 16) comp crc (fromIntegral isize) + return (off',op) + where + -- Get a block of a prescribed size. Comes back as a list of chunks. + get_block sz = liftI $ \s -> case s of + EOF _ -> throwErr $ setEOF s + Chunk c | S.length c < sz -> (:) c `liftM` get_block (sz - S.length c) + | otherwise -> idone [S.take sz c] (Chunk (S.drop sz c)) + + +-- | Decodes a BGZF block header and returns the block size if +-- successful. +get_bgzf_header :: Monad m => Iteratee S.ByteString m (Word16, Word16) +get_bgzf_header = do n <- I.heads "\31\139" + _cm <- I.head + flg <- I.head + if flg `testBit` 2 then do + I.drop 6 + xlen <- endianRead2 LSB + it <- I.take (fromIntegral xlen) get_bsize >>= lift . tryRun + case it of Left e -> throwErr e + Right s | n == 2 -> return (s,xlen) + _ -> throwErr $ iterStrExc "No BGZF" + else throwErr $ iterStrExc "No BGZF" + where + get_bsize = do i1 <- I.head + i2 <- I.head + len <- endianRead2 LSB + if i1 == 66 && i2 == 67 && len == 2 + then endianRead2 LSB + else I.drop (fromIntegral len) >> get_bsize + +-- | Tests whether a stream is in BGZF format. Does not consume any +-- input. +isBgzf :: Monad m => Iteratee S.ByteString m Bool +isBgzf = liftM isRight $ checkErr $ iLookAhead $ get_bgzf_header + where + isRight = either (const False) (const True) + +-- | Tests whether a stream is in GZip format. Also returns @True@ on a +-- Bgzf stream, which is technically a special case of GZip. +isGzip :: Monad m => Iteratee S.ByteString m Bool +isGzip = liftM (either (const False) id) $ checkErr $ iLookAhead $ test + where + test = do n <- I.heads "\31\139" + I.drop 24 + b <- I.isFinished + return $ not b && n == 2 + +-- ------------------------------------------------------------------------- Output + +-- | Maximum block size for Bgzf: 64k with some room for headers and +-- uncompressible stuff +maxBlockSize :: Int +maxBlockSize = 65450 + + +-- | The EOF marker for BGZF files. +-- This is just an empty string compressed as BGZF. Appended to BAM +-- files to indicate their end. +bgzfEofMarker :: S.ByteString +bgzfEofMarker = "\x1f\x8b\x8\x4\0\0\0\0\0\xff\x6\0\x42\x43\x2\0\x1b\0\x3\0\0\0\0\0\0\0\0\0" + +-- | Decompress a collection of strings into a single BGZF block. +-- +-- Ideally, we receive one decode chunk from a BGZF file, decompress it, +-- and return it, in the process attaching the virtual address. But we +-- might actually get more than one chunk, depending on the internals of +-- the @Iteratee@s used. If so, we concatenate them; the first gets to +-- assign the address. +-- +-- Now allocate space for uncompressed data, decompress the chunks we +-- got, compute crc for each and check it, finally convert to ByteString +-- and emit. +-- +-- We could probably get away with @unsafePerformIO@'ing everything in +-- here, but then again, we only do this when we're writing output +-- anyway. Hence, run in IO. + + +decompress1 :: FileOffset -> [S.ByteString] -> Word32 -> Int -> IO Block +decompress1 off ss crc usize = + allocaBytes (#{const sizeof(z_stream)}) $ \stream -> do + buf <- mallocBytes usize + + #{poke z_stream, msg} stream nullPtr + #{poke z_stream, zalloc} stream nullPtr + #{poke z_stream, zfree} stream nullPtr + #{poke z_stream, opaque} stream nullPtr + #{poke z_stream, next_in} stream nullPtr + #{poke z_stream, next_out} stream buf + #{poke z_stream, avail_in} stream (0 :: CUInt) + #{poke z_stream, avail_out} stream (fromIntegral usize :: CUInt) + + z_check "inflateInit2" =<< c_inflateInit2 stream (-15) + + -- loop over the fragments, forward order + forM_ ss $ \s -> case fromIntegral $ S.length s of + l | l > 0 -> S.unsafeUseAsCString s $ \p -> do + #{poke z_stream, next_in} stream p + #{poke z_stream, avail_in} stream (l :: CUInt) + z_check "inflate" =<< c_inflate stream #{const Z_NO_FLUSH} + _ -> return () + + z_check "inflate" =<< c_inflate stream #{const Z_FINISH} + z_check "inflateEnd" =<< c_inflateEnd stream + + pe <- #{peek z_stream, next_out} stream + when (pe `minusPtr` buf /= usize) $ error "size mismatch after deflate()" + + crc0 <- c_crc32 0 nullPtr 0 + crc' <- c_crc32 crc0 buf (fromIntegral usize) + when (fromIntegral crc /= crc') $ error "CRC error after deflate()" + + Block off `liftM` S.unsafePackCStringFinalizer (castPtr buf) usize (free buf) + + +-- | Compress a collection of strings into a single BGZF block. +-- +-- Okay, performance was lacking... let's do it again, in a more direct +-- style. We build our block manually. First check if the compressed +-- data is going to fit---if not, that's a bug. Then alloc a buffer, +-- fill with a dummy header, alloc a ZStream, compress the pieces we +-- were handed one at a time. Calculate CRC32, finalize header, +-- construct a byte string, return it. +-- +-- We could probably get away with @unsafePerformIO@'ing everything in +-- here, but then again, we only do this when we're writing output +-- anyway. Hence, run in IO. + +compress1 :: Int -> [S.ByteString] -> IO S.ByteString +compress1 _lv [] = return bgzfEofMarker +compress1 lv ss0 = + allocaBytes (#{const sizeof(z_stream)}) $ \stream -> do + + let input_length = sum (map S.length ss0) + when (input_length > maxBlockSize) $ error "Trying to create too big a BGZF block; this is a bug." + buf <- mallocBytes 65536 + + -- steal header from the EOF marker (length is wrong for now) + S.unsafeUseAsCString bgzfEofMarker $ \eof -> + forM_ [0,4..16] $ \o -> do x <- peekByteOff eof o + pokeByteOff buf o (x::Word32) + + #{poke z_stream, msg} stream nullPtr + #{poke z_stream, zalloc} stream nullPtr + #{poke z_stream, zfree} stream nullPtr + #{poke z_stream, opaque} stream nullPtr + #{poke z_stream, next_in} stream nullPtr + #{poke z_stream, next_out} stream (buf `plusPtr` 18) + #{poke z_stream, avail_in} stream (0 :: CUInt) + #{poke z_stream, avail_out} stream (65536-18-8 :: CUInt) + + z_check "deflateInit2" =<< c_deflateInit2 stream (fromIntegral lv) #{const Z_DEFLATED} + (-15) 8 #{const Z_DEFAULT_STRATEGY} + + -- loop over the fragments. In reverse order! + let loop (s:ss) = do + crc <- loop ss + S.unsafeUseAsCString s $ \p -> + case fromIntegral $ S.length s of + l | l > 0 -> do + #{poke z_stream, next_in} stream p + #{poke z_stream, avail_in} stream (l :: CUInt) + z_check "deflate" =<< c_deflate stream #{const Z_NO_FLUSH} + c_crc32 crc p l + _ -> return crc + loop [] = c_crc32 0 nullPtr 0 + crc <- loop ss0 + + z_check "deflate" =<< c_deflate stream #{const Z_FINISH} + z_check "deflateEnd" =<< c_deflateEnd stream + + compressed_length <- (+) (18+8) `fmap` #{peek z_stream, total_out} stream + when (compressed_length > 65536) $ error "produced too big a block" + + -- set length in header + pokeByteOff buf 16 (fromIntegral $ (compressed_length-1) .&. 0xff :: Word8) + pokeByteOff buf 17 (fromIntegral $ (compressed_length-1) `shiftR` 8 :: Word8) + + pokeByteOff buf (compressed_length-8) (fromIntegral crc :: Word32) + pokeByteOff buf (compressed_length-4) (fromIntegral input_length :: Word32) + + S.unsafePackCStringFinalizer buf compressed_length (free buf) + + +data ZStream + +{-# INLINE z_check #-} +z_check :: String -> CInt -> IO () +z_check msg c = when (c /= #{const Z_OK} && c /= #{const Z_STREAM_END}) $ + error $ msg ++ " failed: " ++ show c + + +c_deflateInit2 :: Ptr ZStream -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt +c_deflateInit2 z a b c d e = withCAString #{const_str ZLIB_VERSION} $ \versionStr -> + c_deflateInit2_ z a b c d e versionStr (#{const sizeof(z_stream)} :: CInt) + +foreign import ccall unsafe "zlib.h deflateInit2_" c_deflateInit2_ :: + Ptr ZStream -> CInt -> CInt -> CInt -> CInt -> CInt + -> Ptr CChar -> CInt -> IO CInt + +c_inflateInit2 :: Ptr ZStream -> CInt -> IO CInt +c_inflateInit2 z a = withCAString #{const_str ZLIB_VERSION} $ \versionStr -> + c_inflateInit2_ z a versionStr (#{const sizeof(z_stream)} :: CInt) + +foreign import ccall unsafe "zlib.h inflateInit2_" c_inflateInit2_ :: + Ptr ZStream -> CInt -> Ptr CChar -> CInt -> IO CInt + +foreign import ccall unsafe "zlib.h deflate" c_deflate :: + Ptr ZStream -> CInt -> IO CInt + +foreign import ccall unsafe "zlib.h inflate" c_inflate :: + Ptr ZStream -> CInt -> IO CInt + +foreign import ccall unsafe "zlib.h deflateEnd" c_deflateEnd :: + Ptr ZStream -> IO CInt + +foreign import ccall unsafe "zlib.h inflateEnd" c_inflateEnd :: + Ptr ZStream -> IO CInt + +foreign import ccall unsafe "zlib.h crc32" c_crc32 :: + CULong -> Ptr CChar -> CUInt -> IO CULong + +-- ------------------------------------------------------------------------------------------------- utils + +-- | Get the current virtual offset. The virtual address in a BGZF +-- stream contains the offset of the current block in the upper 48 bits +-- and the current offset into that block in the lower 16 bits. This +-- scheme is compatible with the way BAM files are indexed. +getOffset :: Monad m => Iteratee Block m FileOffset +getOffset = liftI step + where + step s@(EOF _) = icont step (Just (setEOF s)) + step s@(Chunk (Block o _)) = idone o s + +-- | Runs an @Iteratee@ for @ByteString@s when decompressing BGZF. Adds +-- internal bookkeeping. +liftBlock :: Monad m => Iteratee S.ByteString m a -> Iteratee Block m a +liftBlock = liftI . step + where + step it (EOF ex) = joinI $ lift $ enumChunk (EOF ex) it + + step it (Chunk (Block !l !s)) = Iteratee $ \od oc -> + enumPure1Chunk s it >>= \it' -> runIter it' (onDone od) (oc . step . liftI) + where + !sl = S.length s + onDone od hdr (Chunk !rest) = od hdr . Chunk $! Block (l + fromIntegral (sl - S.length rest)) rest + onDone od hdr (EOF ex) = od hdr (EOF ex) + + +-- | Compresses a stream of @ByteString@s into a stream of BGZF blocks, +-- in parallel + +-- We accumulate an uncompressed block as long as adding a new chunk to +-- it doesn't exceed the max. block size. If we receive an empty chunk +-- (used as a flush signal), or if we would exceed the block size, we +-- write out a block. Then we continue writing until we're below block +-- size. On EOF, we flush and write the end marker. + +compressBgzf' :: MonadIO m => CompressParams -> Enumeratee BgzfChunk S.ByteString m a +compressBgzf' (CompressParams lv np) = bgzfBlocks ><> parMapChunksIO np (compress1 lv) + +data BgzfChunk = SpecialChunk !S.ByteString BgzfChunk + | RecordChunk !S.ByteString BgzfChunk + | LeftoverChunk !S.ByteString BgzfChunk + | NoChunk + +instance NullPoint BgzfChunk where empty = NoChunk +instance Nullable BgzfChunk where + nullC NoChunk = True + nullC (SpecialChunk s c) = S.null s && nullC c + nullC (RecordChunk s c) = S.null s && nullC c + nullC (LeftoverChunk s c) = S.null s && nullC c + +-- | Breaks a stream into chunks suitable to be compressed individually. +-- Each chunk on output is represented as a list of 'S.ByteString's, +-- each list must be reversed and concatenated to be compressed. +-- ('compress1' does that.) + +bgzfBlocks :: Monad m => Enumeratee BgzfChunk [S.ByteString] m a +bgzfBlocks = eneeCheckIfDone (liftI . to_blocks 0 []) + where + -- terminate by sending the last block and then an empty block, + -- which becomes the EOF marker + to_blocks _alen acc k (EOF mx) = + lift (enumPure1Chunk [S.empty] (k $ Chunk acc)) >>= flip idone (EOF mx) + + -- \'Empty list\', in a sense. + to_blocks alen acc k (Chunk NoChunk) = liftI $ to_blocks alen acc k + + to_blocks alen acc k (Chunk (SpecialChunk c cs)) -- special chunk, encode then flush + -- If it fits, flush. + | alen + S.length c < maxBlockSize = eneeCheckIfDone (\k' -> to_blocks 0 [] k' (Chunk cs)) . k $ Chunk (c:acc) + -- If nothing is pending, flush the biggest thing that does fit. + | null acc = let (l,r) = S.splitAt maxBlockSize c + in eneeCheckIfDone (\k' -> to_blocks 0 [] k' (Chunk (SpecialChunk r cs))) . k $ Chunk [l] + -- Otherwise, flush what's pending and think again. + | otherwise = eneeCheckIfDone (\k' -> to_blocks 0 [] k' (Chunk (SpecialChunk c cs))) . k $ Chunk acc + + to_blocks alen acc k (Chunk (RecordChunk c cs)) + -- if it fits, we accumulate, (needs to consider the length prefix!) + | alen + S.length c + 4 < maxBlockSize = to_blocks (alen + S.length c + 4) (c:encLength c:acc) k (Chunk cs) + -- else if nothing's pending, we break the chunk, (needs to consider the length prefix!) + | null acc = let (l,r) = S.splitAt (maxBlockSize-4) c + in eneeCheckIfDone (\k' -> to_blocks 0 [] k' (Chunk (LeftoverChunk r cs))) . k $ + Chunk [l, encLength l] + -- else we flush the accumulator and think again. + | otherwise = eneeCheckIfDone (\k' -> to_blocks 0 [] k' (Chunk (RecordChunk c cs))) . k $ Chunk acc + where + encLength s = let !l = S.length s in S.pack [ fromIntegral (l `shiftR` 0 .&. 0xff) + , fromIntegral (l `shiftR` 8 .&. 0xff) + , fromIntegral (l `shiftR` 16 .&. 0xff) + , fromIntegral (l `shiftR` 24 .&. 0xff) ] + + to_blocks alen acc k (Chunk (LeftoverChunk c cs)) + -- if it fits, we accumulate, + | alen + S.length c < maxBlockSize = to_blocks (alen + S.length c) (c:acc) k (Chunk cs) + -- else if nothing's pending, we break the chunk, + | null acc = let (l,r) = S.splitAt maxBlockSize c + in eneeCheckIfDone (\k' -> to_blocks 0 [] k' (Chunk (LeftoverChunk r cs))) . k $ Chunk [l] + -- else we flush the accumulator and think again. + | otherwise = eneeCheckIfDone (\k' -> to_blocks 0 [] k' (Chunk (LeftoverChunk c cs))) . k $ Chunk acc + +-- | Like 'compressBgzf'', with sensible defaults. +compressBgzf :: MonadIO m => Enumeratee BgzfChunk S.ByteString m a +compressBgzf = compressBgzfLv 6 + +compressBgzfLv :: MonadIO m => Int -> Enumeratee BgzfChunk S.ByteString m a +compressBgzfLv lv out = do + np <- liftIO $ getNumCapabilities + compressBgzf' (CompressParams lv (np+2)) out + +data CompressParams = CompressParams { + compression_level :: Int, + queue_depth :: Int } + deriving Show + +compressChunk :: Int -> Ptr CChar -> CUInt -> IO S.ByteString +compressChunk lv ptr len = + allocaBytes (#{const sizeof(z_stream)}) $ \stream -> do + buf <- mallocBytes 65536 + + -- steal header from the EOF marker (length is wrong for now) + S.unsafeUseAsCString bgzfEofMarker $ \eof -> + forM_ [0,4..16] $ \o -> do x <- peekByteOff eof o + pokeByteOff buf o (x::Word32) + + -- set up ZStream + #{poke z_stream, msg} stream nullPtr + #{poke z_stream, zalloc} stream nullPtr + #{poke z_stream, zfree} stream nullPtr + #{poke z_stream, opaque} stream nullPtr + #{poke z_stream, next_in} stream ptr + #{poke z_stream, next_out} stream (buf `plusPtr` 18) + #{poke z_stream, avail_in} stream len + #{poke z_stream, avail_out} stream (65536-18-8 :: CUInt) + + z_check "deflateInit2" =<< c_deflateInit2 stream (fromIntegral lv) #{const Z_DEFLATED} + (-15) 8 #{const Z_DEFAULT_STRATEGY} + -- z_check "deflate" =<< c_deflate stream #{const Z_NO_FLUSH} + z_check "deflate" =<< c_deflate stream #{const Z_FINISH} + z_check "deflateEnd" =<< c_deflateEnd stream + + crc0 <- c_crc32 0 nullPtr 0 + crc <- c_crc32 crc0 ptr len + + compressed_length <- (+) (18+8) `fmap` #{peek z_stream, total_out} stream + when (compressed_length > 65536) $ error "produced too big a block" + + -- set length in header + pokeByteOff buf 16 (fromIntegral $ (compressed_length-1) .&. 0xff :: Word8) + pokeByteOff buf 17 (fromIntegral $ (compressed_length-1) `shiftR` 8 :: Word8) + + pokeByteOff buf (compressed_length-8) (fromIntegral crc :: Word32) + pokeByteOff buf (compressed_length-4) (fromIntegral len :: Word32) + + S.unsafePackCStringFinalizer buf compressed_length (free buf) + diff --git a/src/Bio/Iteratee/Builder.hs b/src/Bio/Iteratee/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Iteratee/Builder.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE UnboxedTuples, RecordWildCards, FlexibleContexts, BangPatterns, OverloadedStrings #-} +-- | Buffer builder to assemble Bgzf blocks. (This will probably be +-- renamed.) The plan is to serialize stuff (BAM and BCF) into a +-- buffer, then Bgzf chunks from the buffer and reuse it. This /should/ +-- avoid redundant copying and relieve some pressure from the garbage +-- collector. And I hope to plug a mysterious memory leak that doesn't +-- show up in the profiler. +-- +-- Exported functions with @unsafe@ in the name resulting in a type of +-- 'Push' omit the bounds checking. To use them safely, an appropriate +-- 'ensureBuffer' has to precede them. + +module Bio.Iteratee.Builder where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Bits +import Data.Monoid +import Data.Primitive.Addr +import Data.Primitive.ByteArray +import GHC.Exts +import GHC.Word ( Word8, Word16, Word32 ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Builder as B ( Builder, toLazyByteString ) +import qualified Data.ByteString.Lazy as B ( foldrChunks ) + +import Bio.Iteratee +import Bio.Iteratee.Bgzf + +import Foreign.Marshal.Utils +import Foreign.Ptr + +-- | The 'MutableByteArray' is garbage collected, so we don't get leaks. +-- Once it has grown to a practical size (and the initial 128k should be +-- very practical), we don't get fragmentation either. We also avoid +-- copies for the most part, since no intermediate 'ByteString's, either +-- lazy or strict have to be allocated. +data BB = BB { buffer :: {-# UNPACK #-} !(MutableByteArray RealWorld) + , len :: {-# UNPACK #-} !Int + , mark :: {-# UNPACK #-} !Int } + +-- This still seems to have considerable overhead. Don't know if this +-- can be improved by effectively inlining IO and turning the BB into an +-- unboxed tuple. XXX +newtype Push = Push (BB -> IO BB) + +instance Monoid Push where + {-# INLINE mempty #-} + mempty = Push return + {-# INLINE mappend #-} + Push a `mappend` Push b = Push (a >=> b) + +instance NullPoint Push where + empty = Push return + + +-- | Creates a buffer with initial capacity of ~128k. +newBuffer :: IO BB +newBuffer = newPinnedByteArray 128000 >>= \arr -> return $ BB arr 0 0 + +-- | Ensures a given free space in the buffer by doubling its capacity +-- if necessary. +{-# INLINE ensureBuffer #-} +ensureBuffer :: Int -> Push +ensureBuffer n = Push $ \b -> do + let sz = sizeofMutableByteArray (buffer b) + if len b + n < sz + then return b + else expandBuffer b + +expandBuffer :: BB -> IO BB +expandBuffer b = do let sz = sizeofMutableByteArray (buffer b) + arr1 <- newPinnedByteArray (sz+sz) + copyMutableByteArray arr1 0 (buffer b) 0 (len b) + return $ b { buffer = arr1 } + +{-# INLINE unsafePushByte #-} +unsafePushByte :: Word8 -> Push +unsafePushByte w = Push $ \b -> do + writeByteArray (buffer b) (len b) w + return $ b { len = len b + 1 } + +{-# INLINE pushByte #-} +pushByte :: Word8 -> Push +pushByte b = ensureBuffer 1 <> unsafePushByte b + +{-# INLINE unsafePushWord32 #-} +unsafePushWord32 :: Word32 -> Push +unsafePushWord32 w = unsafePushByte (fromIntegral $ w `shiftR` 0) + <> unsafePushByte (fromIntegral $ w `shiftR` 8) + <> unsafePushByte (fromIntegral $ w `shiftR` 16) + <> unsafePushByte (fromIntegral $ w `shiftR` 24) + +{-# INLINE unsafePushWord16 #-} +unsafePushWord16 :: Word16 -> Push +unsafePushWord16 w = unsafePushByte (fromIntegral $ w `shiftR` 0) + <> unsafePushByte (fromIntegral $ w `shiftR` 8) + +{-# INLINE pushWord32 #-} +pushWord32 :: Word32 -> Push +pushWord32 w = ensureBuffer 4 <> unsafePushWord32 w + +{-# INLINE pushWord16 #-} +pushWord16 :: Word16 -> Push +pushWord16 w = ensureBuffer 2 <> unsafePushWord16 w + +{-# INLINE unsafePushByteString #-} +unsafePushByteString :: B.ByteString -> Push +unsafePushByteString bs = Push $ \b -> + B.unsafeUseAsCStringLen bs $ \(p,ln) -> do + case mutableByteArrayContents (buffer b) of + Addr adr -> copyBytes (Ptr adr `plusPtr` len b) p ln + return $ b { len = len b + ln } + +{-# INLINE pushByteString #-} +pushByteString :: B.ByteString -> Push +pushByteString bs = ensureBuffer (B.length bs) <> unsafePushByteString bs + +{-# INLINE pushBuilder #-} +pushBuilder :: B.Builder -> Push +pushBuilder = B.foldrChunks ((<>) . pushByteString) mempty . B.toLazyByteString + +-- | Sets a mark. This can later be filled in with a record length +-- (used to create BAM records). +{-# INLINE unsafeSetMark #-} +unsafeSetMark :: Push +unsafeSetMark = Push $ \b -> return $ b { len = len b + 4, mark = len b } + +{-# INLINE setMark #-} +setMark :: Push +setMark = ensureBuffer 4 <> unsafeSetMark + +-- | Ends a record by filling the length into the field that was +-- previously marked. Terrible things will happen if this wasn't +-- preceded by a corresponding 'setMark'. +{-# INLINE endRecord #-} +endRecord :: Push +endRecord = Push $ \b -> do + let !l = len b - mark b - 4 + writeByteArray (buffer b) (mark b + 0) (fromIntegral $ shiftR l 0 :: Word8) + writeByteArray (buffer b) (mark b + 1) (fromIntegral $ shiftR l 8 :: Word8) + writeByteArray (buffer b) (mark b + 2) (fromIntegral $ shiftR l 16 :: Word8) + writeByteArray (buffer b) (mark b + 3) (fromIntegral $ shiftR l 24 :: Word8) + return b + + +{-# INLINE encodeBgzfWith #-} +encodeBgzfWith :: MonadIO m => Int -> Enumeratee Push B.ByteString m b +encodeBgzfWith lv o = newBuffer `ioBind` \bb -> eneeCheckIfDone (liftI . step bb) o + where + step bb k (EOF mx) = finalFlush bb k mx + step bb k (Chunk (Push p)) = p bb `ioBind` \bb' -> tryFlush bb' 0 k + + tryFlush bb off k + | len bb - off < maxBlockSize + = copyMutableByteArray (buffer bb) 0 (buffer bb) off (len bb - off) + `ioBind_` liftI (step (bb { len = len bb - off + , mark = mark bb - off `max` 0 }) k) + + | otherwise + = (case mutableByteArrayContents (buffer bb) of + Addr adr -> compressChunk lv (Ptr adr `plusPtr` off) (fromIntegral maxBlockSize)) + `ioBind` eneeCheckIfDone (tryFlush bb (off+maxBlockSize)) . k . Chunk + + finalFlush bb k mx + | len bb < maxBlockSize + = (case mutableByteArrayContents (buffer bb) of + Addr adr -> compressChunk lv (Ptr adr) (fromIntegral $ len bb)) + `ioBind` eneeCheckIfDone (finalFlush2 mx) . k . Chunk + + | otherwise + = error "WTF?! This wasn't supposed to happen." + + finalFlush2 mx k = idone (k $ Chunk bgzfEofMarker) (EOF mx) + + + diff --git a/src/Bio/Iteratee/ZLib.hsc b/src/Bio/Iteratee/ZLib.hsc new file mode 100644 --- /dev/null +++ b/src/Bio/Iteratee/ZLib.hsc @@ -0,0 +1,754 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +{-# OPTIONS -Wall -fno-warn-unused-do-bind #-} + +{- Stolen from iteratee-compress module, which doesn't work due to + dependency problems. Modified for proper early-out behaviour. -} +module Bio.Iteratee.ZLib + ( + -- * Enumeratees + enumInflate, + enumInflateAny, + enumDeflate, + -- * Exceptions + ZLibParamsException(..), + ZLibException(..), + -- * Parameters + CompressParams(..), + defaultCompressParams, + DecompressParams(..), + defaultDecompressParams, + Format(..), + CompressionLevel(..), + Method(..), + WindowBits(..), + MemoryLevel(..), + CompressionStrategy(..), + enumSyncFlush, + enumFullFlush, + enumBlockFlush, + ) +where +#include + +import Bio.Iteratee +import Control.Applicative +import Control.Exception +import Control.Monad ( liftM, liftM2 ) +import Data.ByteString as BS +import Data.ByteString.Internal +import Data.Foldable +import Data.Typeable +import Foreign +import Foreign.C +#ifdef DEBUG +import qualified Foreign.Concurrent as C +import System.IO (stderr) +import qualified System.IO as IO +#endif + +-- | Denotes error is user-supplied parameter +data ZLibParamsException + = IncorrectCompressionLevel !Int + -- ^ Incorrect compression level was chosen + | IncorrectWindowBits !Int + -- ^ Incorrect number of window bits was chosen + | IncorrectMemoryLevel !Int + -- ^ Incorrect memory level was chosen + deriving (Eq,Typeable) + +-- | Denotes error in compression and decompression +data ZLibException + = NeedDictionary + -- ^ Decompression requires user-supplied dictionary (not supported) + | BufferError + -- ^ Buffer error - denotes a library error +-- | File Error + | StreamError + -- ^ State of steam inconsistent + | DataError + -- ^ Input data corrupted + | MemoryError + -- ^ Not enough memory + | VersionError + -- ^ Version error + | Unexpected !CInt + -- ^ Unexpected or unknown error - please report as bug + | IncorrectState + -- ^ Incorrect state - denotes error in library + deriving (Eq,Typeable) + +-- | Denotes the flush that can be sent to stream +data ZlibFlush + = SyncFlush + -- ^ All pending output is flushed and all input that is available is sent + -- to inner Iteratee. + | FullFlush + -- ^ Flush all pending output and reset the compression state. It allows to + -- restart from this point if compression was damaged but it can seriously + -- affect the compression rate. + -- + -- It may be only used during compression. + | Block + -- ^ If the iteratee is compressing it requests to stop when next block is + -- emmited. On the beginning it skips only header if and only if it exists. + deriving (Eq,Typeable) + +instance Show ZlibFlush where + show SyncFlush = "zlib: flush requested" + show FullFlush = "zlib: full flush requested" + show Block = "zlib: block flush requested" + +instance Exception ZlibFlush + +fromFlush :: ZlibFlush -> CInt +fromFlush SyncFlush = #{const Z_SYNC_FLUSH} +fromFlush FullFlush = #{const Z_FULL_FLUSH} +fromFlush Block = #{const Z_BLOCK} + +instance Show ZLibParamsException where + show (IncorrectCompressionLevel lvl) + = "zlib: incorrect compression level " ++ show lvl + show (IncorrectWindowBits lvl) + = "zlib: incorrect window bits " ++ show lvl + show (IncorrectMemoryLevel lvl) + = "zlib: incorrect memory level " ++ show lvl + +instance Show ZLibException where + show NeedDictionary = "zlib: needs dictionary" + show BufferError = "zlib: no progress is possible (internal error)" +-- show FileError = "zlib: file I/O error" + show StreamError = "zlib: stream error" + show DataError = "zlib: data error" + show MemoryError = "zlib: memory error" + show VersionError = "zlib: version error" + show (Unexpected lvl) = "zlib: unknown error " ++ show lvl + show IncorrectState = "zlib: incorrect state" + +instance Exception ZLibParamsException +instance Exception ZLibException + +newtype ZStream = ZStream (ForeignPtr ZStream) +withZStream :: ZStream -> (Ptr ZStream -> IO a) -> IO a +withZStream (ZStream fptr) = withForeignPtr fptr + + +-- Following code is copied from Duncan Coutts zlib haskell library version +-- 0.5.2.0 ((c) 2006-2008 Duncan Coutts, published on BSD licence) and adapted + +-- | Set of parameters for compression. For sane defaults use +-- 'defaultCompressParams' +data CompressParams = CompressParams { + compressLevel :: !CompressionLevel, + compressMethod :: !Method, + compressWindowBits :: !WindowBits, + compressMemoryLevel :: !MemoryLevel, + compressStrategy :: !CompressionStrategy, + -- | The size of output buffer. That is the size of 'Chunk's that will be + -- emitted to inner iterator (except the last 'Chunk'). + compressBufferSize :: !Int, + compressDictionary :: !(Maybe ByteString) + } + +defaultCompressParams :: CompressParams +defaultCompressParams + = CompressParams DefaultCompression Deflated DefaultWindowBits + DefaultMemoryLevel DefaultStrategy (8*1024) Nothing + +-- | Set of parameters for decompression. For sane defaults see +-- 'defaultDecompressParams'. +data DecompressParams = DecompressParams { + -- | Window size - it have to be at least the size of + -- 'compressWindowBits' the stream was compressed with. + -- + -- Default in 'defaultDecompressParams' is the maximum window size - + -- please do not touch it unless you know what you are doing. + decompressWindowBits :: !WindowBits, + -- | The size of output buffer. That is the size of 'Chunk's that will be + -- emitted to inner iterator (except the last 'Chunk'). + decompressBufferSize :: !Int, + decompressDictionary :: !(Maybe ByteString) + } + +defaultDecompressParams :: DecompressParams +defaultDecompressParams = DecompressParams DefaultWindowBits (8*1024) Nothing + +-- | Specify the format for compression and decompression +data Format + = GZip + -- ^ The gzip format is widely used and uses a header with checksum and + -- some optional metadata about the compress file. + -- + -- It is intended primarily for compressing individual files but is also + -- used for network protocols such as HTTP. + -- + -- The format is described in RFC 1952 + -- . + | Zlib + -- ^ The zlib format uses a minimal header with a checksum but no other + -- metadata. It is designed for use in network protocols. + -- + -- The format is described in RFC 1950 + -- + | Raw + -- ^ The \'raw\' format is just the DEFLATE compressed data stream without + -- and additionl headers. + -- + -- Thr format is described in RFC 1951 + -- + | GZipOrZlib + -- ^ "Format" for decompressing a 'Zlib' or 'GZip' stream. + deriving (Eq) + +-- | The compression level specify the tradeoff between speed and compression. +data CompressionLevel + = DefaultCompression + -- ^ Default compression level set at 6. + | NoCompression + -- ^ No compression, just a block copy. + | BestSpeed + -- ^ The fastest compression method (however less compression) + | BestCompression + -- ^ The best compression method (however slowest) + | CompressionLevel Int + -- ^ Compression level set by number from 1 to 9 + +-- | Specify the compression method. +data Method + = Deflated + -- ^ \'Deflate\' is so far the only method supported. + +-- | This specify the size of compression level. Larger values result in better +-- compression at the expense of highier memory usage. +-- +-- The compression window size is 2 to the power of the value of the window +-- bits. +-- +-- The total memory used depends on windows bits and 'MemoryLevel'. +data WindowBits + = WindowBits Int + -- ^ The size of window bits. It have to be between @8@ (which corresponds + -- to 256b i.e. 32B) and @15@ (which corresponds to 32 kib i.e. 4kiB). + | DefaultWindowBits + -- ^ The default window size which is 4kiB + +-- | The 'MemoryLevel' specifies how much memory should be allocated for the +-- internal state. It is a tradeoff between memory usage, speed and +-- compression. +-- Using more memory allows faster and better compression. +-- +-- The memory used for interal state, excluding 'WindowBits', is 512 bits times +-- 2 to power of memory level. +-- +-- The total amount of memory use depends on the 'WindowBits' and +-- 'MemoryLevel'. +data MemoryLevel + = DefaultMemoryLevel + -- ^ Default memory level set to 8. + | MinMemoryLevel + -- ^ Use the small amount of memory (equivalent to memory level 1) - i.e. + -- 1024b or 256 B. + -- It slow and reduces the compresion ratio. + | MaxMemoryLevel + -- ^ Maximum memory level for optimal compression speed (equivalent to + -- memory level 9). + -- The internal state is 256kib or 32kiB. + | MemoryLevel Int + -- ^ A specific level. It have to be between 1 and 9. + +-- | Tunes the compress algorithm but does not affact the correctness. +data CompressionStrategy + = DefaultStrategy + -- ^ Default strategy + | Filtered + -- ^ Use the filtered compression strategy for data produced by a filter + -- (or predictor). Filtered data consists mostly of small values with a + -- somewhat random distribution. In this case, the compression algorithm + -- is tuned to compress them better. The effect of this strategy is to + -- force more Huffman coding and less string matching; it is somewhat + -- intermediate between 'DefaultStrategy' and 'HuffmanOnly'. + | HuffmanOnly + -- ^ Use the Huffman-only compression strategy to force Huffman encoding + -- only (no string match). + +fromMethod :: Method -> CInt +fromMethod Deflated = #{const Z_DEFLATED} + +fromCompressionLevel :: CompressionLevel -> Either ZLibParamsException CInt +fromCompressionLevel DefaultCompression = Right $! -1 +fromCompressionLevel NoCompression = Right $! 0 +fromCompressionLevel BestSpeed = Right $! 1 +fromCompressionLevel BestCompression = Right $! 9 +fromCompressionLevel (CompressionLevel n) + | n >= 0 && n <= 9 = Right $! fromIntegral $! n + | otherwise = Left $! IncorrectCompressionLevel n + +fromWindowBits :: Format -> WindowBits -> Either ZLibParamsException CInt +fromWindowBits format bits + = formatModifier format <$> checkWindowBits bits + where checkWindowBits DefaultWindowBits = Right $! 15 + checkWindowBits (WindowBits n) + | n >= 8 && n <= 15 = Right $! fromIntegral $! n + | otherwise = Left $! IncorrectWindowBits $! n + formatModifier Zlib = id + formatModifier GZip = (+16) + formatModifier GZipOrZlib = (+32) + formatModifier Raw = negate + +fromMemoryLevel :: MemoryLevel -> Either ZLibParamsException CInt +fromMemoryLevel DefaultMemoryLevel = Right $! 8 +fromMemoryLevel MinMemoryLevel = Right $! 1 +fromMemoryLevel MaxMemoryLevel = Right $! 9 +fromMemoryLevel (MemoryLevel n) + | n >= 1 && n <= 9 = Right $! fromIntegral n + | otherwise = Left $! IncorrectMemoryLevel $! fromIntegral n + +fromCompressionStrategy :: CompressionStrategy -> CInt +fromCompressionStrategy DefaultStrategy = #{const Z_DEFAULT_STRATEGY} +fromCompressionStrategy Filtered = #{const Z_FILTERED} +fromCompressionStrategy HuffmanOnly = #{const Z_HUFFMAN_ONLY} + +fromErrno :: CInt -> Either ZLibException Bool +fromErrno (#{const Z_OK}) = Right $! True +fromErrno (#{const Z_STREAM_END}) = Right $! False +fromErrno (#{const Z_NEED_DICT}) = Left $! NeedDictionary +fromErrno (#{const Z_BUF_ERROR}) = Left $! BufferError +--fromErrno (#{const Z_ERRNO}) = Left $! FileError +fromErrno (#{const Z_STREAM_ERROR}) = Left $! StreamError +fromErrno (#{const Z_DATA_ERROR}) = Left $! DataError +fromErrno (#{const Z_MEM_ERROR}) = Left $! MemoryError +fromErrno (#{const Z_VERSION_ERROR}) = Left $! VersionError +fromErrno n = Left $! Unexpected n + +-- Helper function +convParam :: Format + -> CompressParams + -> Either ZLibParamsException (CInt, CInt, CInt, CInt, CInt) +convParam f (CompressParams c m w l s _ _) + = let c' = fromCompressionLevel c + m' = fromMethod m + b' = fromWindowBits f w + l' = fromMemoryLevel l + s' = fromCompressionStrategy s + eit = either Left + r = Right + in eit (\c_ -> eit (\b_ -> eit (\l_ -> r (c_, m', b_, l_, s')) l') b') c' + +-- In following code we go through 7 states. Some of the operations are +-- 'deterministic' like 'insertOut' and some of them depends on input ('fill') +-- or library call. +-- +-- (Finished) +-- ^ +-- | +-- | +-- | finish +-- | +-- insertOut fill[1] | +--- (Initial) -------------> (EmptyIn) -----------> (Finishing) +-- ^ ^ | ^ | +-- | run[2] | | | \------------------\ +-- | | | | | +-- | | | \------------------\ | +-- | run[1] | | flush[0] | | +-- \------------------\ | | fill[0] | | fill[3] +-- | | | | | +-- | | | | | +-- swapOut | | v flush[1] | v +-- (FullOut) -------------> (Invalid) <----------- (Flushing) +-- +-- Initial: Initial state, both buffers are empty +-- EmptyIn: Empty in buffer, out waits untill filled +-- FullOut: Out was filled and sent. In was not entirely read +-- Invalid[1]: Both buffers non-empty +-- Finishing: There is no more in data and in buffer is empty. Waits till +-- all outs was sent. +-- Finished: Operation finished +-- Flushing: Flush requested +-- +-- Please note that the decompressing can finish also on flush and finish. +-- +-- [1] Named for 'historical' reasons + +newtype Initial = Initial ZStream +data EmptyIn = EmptyIn !ZStream !ByteString +data FullOut = FullOut !ZStream !ByteString +data Invalid = Invalid !ZStream !ByteString !ByteString +data Finishing = Finishing !ZStream !ByteString +data Flushing = Flushing !ZStream !ZlibFlush !ByteString + +withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a +withByteString (PS ptr off len) f + = withForeignPtr ptr (\ptr' -> f (ptr' `plusPtr` off) len) + +#ifdef DEBUG +mkByteString :: MonadIO m => Int -> m ByteString +mkByteString s = liftIO $ do + base <- mallocForeignPtrArray s + withForeignPtr base $ \ptr -> C.addForeignPtrFinalizer base $ do + IO.hPutStrLn stderr $ "Freed buffer " ++ show ptr + IO.hPutStrLn stderr $ "Allocated buffer " ++ show base + return $! PS base 0 s + +dumpZStream :: ZStream -> IO () +dumpZStream zstr = withZStream zstr $ \zptr -> do + IO.hPutStr stderr $ "<>" +#else +mkByteString :: MonadIO m => Int -> m ByteString +mkByteString s = liftIO $ create s (\_ -> return ()) +#endif + +putOutBuffer :: Int -> ZStream -> IO ByteString +putOutBuffer size zstr = do + _out <- mkByteString size + withByteString _out $ \ptr len -> withZStream zstr $ \zptr -> do + #{poke z_stream, next_out} zptr ptr + #{poke z_stream, avail_out} zptr len + return _out + +putInBuffer :: ZStream -> ByteString -> IO () +putInBuffer zstr _in + = withByteString _in $ \ptr len -> withZStream zstr $ \zptr -> do + #{poke z_stream, next_in} zptr ptr + #{poke z_stream, avail_in} zptr len + +pullOutBuffer :: ZStream -> ByteString -> IO ByteString +pullOutBuffer zstr _out = withByteString _out $ \ptr _ -> do + next_out <- withZStream zstr $ \zptr -> #{peek z_stream, next_out} zptr + return $! BS.take (next_out `minusPtr` ptr) _out + +pullInBuffer :: ZStream -> ByteString -> IO ByteString +pullInBuffer zstr _in = withByteString _in $ \ptr _ -> do + next_in <- withZStream zstr $ \zptr -> #{peek z_stream, next_in} zptr + return $! BS.drop (next_in `minusPtr` ptr) _in + +type EnumerateeS eli elo m a = (Stream eli -> Iteratee eli m a) -> Iteratee elo m (Iteratee eli m a) + +eneeErr :: (Monad m, Exception err, Nullable elo) + => (Stream eli -> Iteratee eli m a) -> err -> Iteratee elo m () +eneeErr iter = liftM (const ()) . lift . run . iter . EOF . Just . toException + +insertOut :: MonadIO m + => Int + -> (ZStream -> CInt -> IO CInt) + -> Initial + -> Enumeratee ByteString ByteString m a +insertOut size runf (Initial zstr) iter = do + _out <- liftIO $ putOutBuffer size zstr +#ifdef DEBUG + liftIO $ IO.hPutStrLn stderr $ "Inserted out buffer of size " ++ show size +#endif + eneeCheckIfDone (fill size runf (EmptyIn zstr _out)) iter + +fill :: MonadIO m + => Int + -> (ZStream -> CInt -> IO CInt) + -> EmptyIn + -> EnumerateeS ByteString ByteString m a +fill size run' (EmptyIn zstr _out) iter + = let fill' (Chunk _in) + | not (BS.null _in) = do + liftIO $ putInBuffer zstr _in +#ifdef DEBUG + liftIO $ IO.hPutStrLn stderr $ + "Inserted in buffer of size " ++ show (BS.length _in) +#endif + doRun size run' (Invalid zstr _in _out) iter + | otherwise = fillI + fill' (EOF Nothing) = do + out <- liftIO $ pullOutBuffer zstr _out + eneeCheckIfDone (finish size run' (Finishing zstr BS.empty)) $ iter (Chunk out) + fill' (EOF (Just err)) + = case fromException err of + Just err' -> flush size run' (Flushing zstr err' _out) iter + Nothing -> throwRecoverableErr err fill' +#ifdef DEBUG + fillI = do + liftIO $ IO.hPutStrLn stderr $ "About to insert in buffer" + liftI fill' +#else + fillI = liftI fill' +#endif + in fillI + +swapOut :: MonadIO m + => Int + -> (ZStream -> CInt -> IO CInt) + -> FullOut + -> Enumeratee ByteString ByteString m a +swapOut size run' (FullOut zstr _in) iter = do + _out <- liftIO $ putOutBuffer size zstr +#ifdef DEBUG + liftIO $ IO.hPutStrLn stderr $ "Swapped out buffer of size " ++ show size +#endif + eneeCheckIfDone (doRun size run' (Invalid zstr _in _out)) iter + +doRun :: MonadIO m + => Int + -> (ZStream -> CInt -> IO CInt) + -> Invalid + -> EnumerateeS ByteString ByteString m a +doRun size run' (Invalid zstr _in _out) iter = do +#ifdef DEBUG + liftIO $ IO.hPutStrLn stderr $ "About to run" + liftIO $ dumpZStream zstr +#endif + status <- liftIO $ run' zstr #{const Z_NO_FLUSH} +#ifdef DEBUG + liftIO $ IO.hPutStrLn stderr $ "Runned" +#endif + case fromErrno status of + Left err -> do + eneeErr iter err + throwErr (toException err) + Right False -> do -- End of stream + remaining <- liftIO $ pullInBuffer zstr _in + out <- liftIO $ pullOutBuffer zstr _out + idone (iter (Chunk out)) (Chunk remaining) + Right True -> do -- Continue + (avail_in, avail_out) <- liftIO $ withZStream zstr $ \zptr -> do + avail_in <- liftIO $ #{peek z_stream, avail_in} zptr + avail_out <- liftIO $ #{peek z_stream, avail_out} zptr + return (avail_in, avail_out) :: IO (CInt, CInt) + case avail_out of + 0 -> do + out <- liftIO $ pullOutBuffer zstr _out + case avail_in of + 0 -> insertOut size run' (Initial zstr) $ iter (Chunk out) + _ -> swapOut size run' (FullOut zstr _in) $ iter (Chunk out) + _ -> case avail_in of + 0 -> fill size run' (EmptyIn zstr _out) iter + _ -> do + eneeErr iter IncorrectState + throwErr (toException IncorrectState) + +flush :: MonadIO m + => Int + -> (ZStream -> CInt -> IO CInt) + -> Flushing + -> EnumerateeS ByteString ByteString m a +flush size run' (Flushing zstr _flush _out) iter = do + status <- liftIO $ run' zstr (fromFlush _flush) + case fromErrno status of + Left err -> do + eneeErr iter err + throwErr (toException err) + Right False -> do -- Finished + out <- liftIO $ pullOutBuffer zstr _out + idone (iter (Chunk out)) (Chunk BS.empty) + Right True -> do + -- TODO: avail_in is unused, can it be completely removed? + -- or should it be used? + (_avail_in, avail_out) <- liftIO $ withZStream zstr $ \zptr -> do + avail_in <- liftIO $ #{peek z_stream, avail_in} zptr + avail_out <- liftIO $ #{peek z_stream, avail_out} zptr + return (avail_in, avail_out) :: IO (CInt, CInt) + case avail_out of + 0 -> do + out <- liftIO $ pullOutBuffer zstr _out + out' <- liftIO $ putOutBuffer size zstr + eneeCheckIfDone (flush size run' (Flushing zstr _flush out')) $ iter (Chunk out) + _ -> insertOut size run' (Initial zstr) (liftI iter) + +finish :: MonadIO m + => Int + -> (ZStream -> CInt -> IO CInt) + -> Finishing + -> EnumerateeS ByteString ByteString m a +finish size run' fin@(Finishing zstr _in) iter = do +#ifdef DEBUG + liftIO $ IO.hPutStrLn stderr $ + "Finishing with out buffer of size " ++ show size +#endif + _out <- liftIO $ putOutBuffer size zstr + status <- liftIO $ run' zstr #{const Z_FINISH} + case fromErrno status of + Left err -> do + eneeErr iter err + throwErr (toException err) + Right False -> do -- Finished + remaining <- liftIO $ pullInBuffer zstr _in + out <- liftIO $ pullOutBuffer zstr _out + idone (iter (Chunk out)) (Chunk remaining) + Right True -> do + -- TODO: avail_in is unused, is this an error or can it be removed? + (_avail_in, avail_out) <- liftIO $ withZStream zstr $ \zptr -> do + avail_in <- liftIO $ #{peek z_stream, avail_in} zptr + avail_out <- liftIO $ #{peek z_stream, avail_out} zptr + return (avail_in, avail_out) :: IO (CInt, CInt) + case avail_out of + 0 -> do + out <- liftIO $ pullOutBuffer zstr _out + eneeCheckIfDone (finish size run' fin) $ iter (Chunk out) + _ -> do + eneeErr iter IncorrectState + throwErr $! toException IncorrectState + +foreign import ccall unsafe deflateInit2_ :: Ptr ZStream -> CInt -> CInt + -> CInt -> CInt -> CInt + -> CString -> CInt -> IO CInt +foreign import ccall unsafe inflateInit2_ :: Ptr ZStream -> CInt + -> CString -> CInt -> IO CInt +foreign import ccall unsafe inflate :: Ptr ZStream -> CInt -> IO CInt +foreign import ccall unsafe deflate :: Ptr ZStream -> CInt -> IO CInt +foreign import ccall unsafe "&deflateEnd" + deflateEnd :: FunPtr (Ptr ZStream -> IO ()) +foreign import ccall unsafe "&inflateEnd" + inflateEnd :: FunPtr (Ptr ZStream -> IO ()) +foreign import ccall unsafe deflateSetDictionary :: Ptr ZStream -> Ptr Word8 + -> CUInt -> IO CInt +foreign import ccall unsafe inflateSetDictionary :: Ptr ZStream -> Ptr Word8 + -> CUInt -> IO CInt + +deflateInit2 :: Ptr ZStream -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt +deflateInit2 s l m wB mL s' + = withCString #{const_str ZLIB_VERSION} $ \v -> + deflateInit2_ s l m wB mL s' v #{size z_stream} + +inflateInit2 :: Ptr ZStream -> CInt -> IO CInt +inflateInit2 s wB + = withCString #{const_str ZLIB_VERSION} $ \v -> + inflateInit2_ s wB v #{size z_stream} + +#ifdef DEBUG +deflate' :: ZStream -> CInt -> IO CInt +deflate' z f = withZStream z $ \p -> do + IO.hPutStrLn stderr "About to run deflate" + deflate p f + +inflate' :: ZStream -> CInt -> IO CInt +inflate' z f = withZStream z $ \p -> do + IO.hPutStrLn stderr "About to run inflate" + inflate p f +#else +deflate' :: ZStream -> CInt -> IO CInt +deflate' z f = withZStream z $ \p -> deflate p f + +inflate' :: ZStream -> CInt -> IO CInt +inflate' z f = withZStream z $ \p -> inflate p f +#endif + +mkCompress :: Format -> CompressParams + -> IO (Either ZLibParamsException Initial) +mkCompress frm cp + = case convParam frm cp of + Left err -> return $! Left err + Right (c, m, b, l, s) -> do + zstr <- mallocForeignPtrBytes #{size z_stream} + withForeignPtr zstr $ \zptr -> do + memset (castPtr zptr) 0 #{size z_stream} + deflateInit2 zptr c m b l s `finally` + addForeignPtrFinalizer deflateEnd zstr + for_ (compressDictionary cp) $ \(PS fp off len) -> + withForeignPtr fp $ \ptr -> + deflateSetDictionary zptr (ptr `plusPtr` off) + (fromIntegral len) + return $! Right $! Initial $ ZStream zstr + +mkDecompress :: Format -> DecompressParams + -> IO (Either ZLibParamsException (Initial, Maybe ByteString)) +mkDecompress frm (DecompressParams w _ md) + = case fromWindowBits frm w of + Left err -> return $! Left err + Right wB' -> do + zstr <- mallocForeignPtrBytes #{size z_stream} + v <- withForeignPtr zstr $ \zptr -> do + memset (castPtr zptr) 0 #{size z_stream} + inflateInit2 zptr wB' `finally` + addForeignPtrFinalizer inflateEnd zstr + case (md, frm) of + (Just (PS fp off len), Raw) -> do + withForeignPtr fp $ \ptr -> + inflateSetDictionary zptr (ptr `plusPtr` off) + (fromIntegral len) + return $! Nothing + (Nothing, _) -> return $! Nothing + (Just bs, _) -> return $! (Just bs) + return $! Right $! (Initial $ ZStream zstr, v) + +-- User-related code + +-- | Compress the input and send to inner iteratee. +enumDeflate :: MonadIO m + => Format -- ^ Format of input + -> CompressParams -- ^ Parameters of compression + -> Enumeratee ByteString ByteString m a +enumDeflate f cp@(CompressParams _ _ _ _ _ size _) iter = do + cmp <- liftIO $ mkCompress f cp + case cmp of + Left err -> do + _ <- lift $ enumErr err iter + throwErr (toException err) + Right init' -> insertOut size deflate' init' iter + +-- | Decompress the input and send to inner iteratee. If there is data +-- after the end of zlib stream, it is left unprocessed. +enumInflate :: MonadIO m + => Format + -> DecompressParams + -> Enumeratee ByteString ByteString m a +enumInflate f dp@(DecompressParams _ size _md) iter = do + dcmp <- liftIO $ mkDecompress f dp + case dcmp of + Left err -> do + _ <- lift $ enumErr err iter + throwErr (toException err) + Right (init', Nothing) -> insertOut size inflate' init' iter + Right (init', (Just (PS fp off len))) -> + let inflate'' zstr param = do + ret <- inflate' zstr param + case fromErrno ret of + Left NeedDictionary -> do + withForeignPtr fp $ \ptr -> + withZStream zstr $ \zptr -> + inflateSetDictionary zptr (ptr `plusPtr` off) + (fromIntegral len) + inflate' zstr param + _ -> return ret + in insertOut size inflate'' init' iter + +-- | Inflate if Gzip format is recognized, otherwise pass through. +enumInflateAny :: MonadIO m => Enumeratee ByteString ByteString m a +enumInflateAny it = do magic <- iLookAhead $ liftM2 (,) tryHead tryHead + case magic of + (Just 0x1f, Just 0x8b) -> + enumInflate GZip defaultDecompressParams it + _ -> mapChunks id it + +enumSyncFlush :: Monad m => Enumerator ByteString m a +-- ^ Enumerate synchronise flush. It cause the all pending output to be flushed +-- and all available input is sent to inner Iteratee. +enumSyncFlush = enumErr SyncFlush + +enumFullFlush :: Monad m => Enumerator ByteString m a +-- ^ Enumerate full flush. It flushes all pending output and reset the +-- compression. It allows to restart from this point if compressed data was +-- corrupted but it can affect the compression rate. +-- +-- It may be only used during compression. +enumFullFlush = enumErr FullFlush + +enumBlockFlush :: Monad m => Enumerator ByteString m a +-- ^ Enumerate block flush. If the enumerator is compressing it allows to +-- finish current block. If the enumerator is decompressing it forces to stop +-- on next block boundary. +enumBlockFlush = enumErr Block + diff --git a/src/Bio/PriorityQueue.hs b/src/Bio/PriorityQueue.hs new file mode 100644 --- /dev/null +++ b/src/Bio/PriorityQueue.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE BangPatterns #-} +module Bio.PriorityQueue ( + Sizeable(..), + PQ_Conf(..), + + PQ, + withPQ, + makePQ, + deletePQ, + enqueuePQ, + dequeuePQ, + getMinPQ, + peekMinPQ, + sizePQ +) where + +import Data.Binary +import Data.IORef +import qualified Control.Exception as CE + +-- | A Priority Queue that can fall back to external storage. +-- +-- Note that such a Priority Queue automatically gives rise to an +-- external sorting algorithm: enqueue everything, dequeue until empty. +-- +-- Whatever is to be stored in this queue needs to be in Binary, because +-- it may need to be moved to external storage on demand. We also need +-- a way to estimate the memory consumption of an enqueued object. When +-- constructing the queue, the maximum amount of RAM to consume is set. +-- Note that open input streams use memory for buffering, too. +-- +-- Enqueued objects are kept in an in memory heap until the memory +-- consumption becomes too high. At that point, the whole heap is +-- sorted and dumped to external storage. If necessary, the file to do +-- so is created and kept open. The newly created stream is added to a +-- heap so that dequeueing objects amounts to performing a merge sort on +-- multiple external streams. To conserve on file descriptors, we +-- concatenate multiple streams into a single file, then use pread(2) on +-- that as appropriate. If too many streams are open (how do we set +-- that limit?), we do exactly that: merge-sort all streams and the +-- in-memory heap into a single new stream. One file is created for +-- each generation of streams, so that mergind handles streams of +-- roughly equal length. +-- +-- XXX Truth be told, this queue isn't backed externally, and ignores +-- all limits. It *is* a Priority Queue, though! +-- +-- XXX May want to add callbacks for significant events (new file, +-- massive merge, deletion of file?) +-- +-- XXX Need to track memory consumption of input buffers. +-- +-- XXX Need a way to decide when too many streams are open. That point +-- is reached when seeking takes about as much time as reading +-- (which depends on buffer size and system characteristics), so +-- that an additional merge pass becomes economical. +-- +-- XXX These will be useful: +-- unix-bytestring:System.Posix.IO.ByteString.fdPread +-- temporary:System.IO.Temp.openBinaryTempFile +-- lz4:Codec.Compression.LZ4 + +data PQ_Conf = PQ_Conf { + max_mb :: Int, -- ^ memory limit + temp_path :: FilePath -- ^ path to temporary files (a directory will be created) + -- functions to report progress go here + } + +newtype PQ a = PQ (IORef (SkewHeap a, Int)) + +class Sizeable a where usedBytes :: a -> Int + +-- | Creates a priority queue. Note that the priority queue creates +-- files, which will only be cleaned up if deletePQ is called. +makePQ :: (Binary a, Ord a, Sizeable a) => PQ_Conf -> IO (PQ a) +makePQ _ = PQ `fmap` newIORef (Empty,0) + +-- | Deletes the priority queue and all associated temporary files. +deletePQ :: PQ a -> IO () +deletePQ (PQ _) = return () + +withPQ :: (Binary a, Ord a, Sizeable a) => PQ_Conf -> (PQ a -> IO b) -> IO b +withPQ conf = CE.bracket (makePQ conf) deletePQ + +-- | Enqueues an element. +-- This operation may result in the creation of a file or in an enormous +-- merge of already created files. +enqueuePQ :: (Binary a, Ord a, Sizeable a) => a -> PQ a -> IO () +enqueuePQ a (PQ pq) = do (p,s) <- readIORef pq + let !p' = insert a p + !s' = 1 + s + writeIORef pq (p',s') + +-- | Removes the minimum element from the queue. +-- If the queue is already empty, nothing happens. As a result, it is +-- possible that one or more file become empty and are deleted. +dequeuePQ :: (Binary a, Ord a, Sizeable a ) => PQ a -> IO () +dequeuePQ (PQ pq) = do (p,s) <- readIORef pq + let !p' = dropMin p + !s' = max 0 (s - 1) + writeIORef pq (p',s') + + +-- | Returns the minimum element from the queue. +-- If the queue is empty, Nothing is returned. Else the minimum element +-- currently in the queue. +peekMinPQ :: (Binary a, Ord a, Sizeable a) => PQ a -> IO (Maybe a) +peekMinPQ (PQ pq) = (getMin . fst) `fmap` readIORef pq + +getMinPQ :: (Binary a, Ord a, Sizeable a) => PQ a -> IO (Maybe a) +getMinPQ (PQ pq) = do r <- (getMin . fst) `fmap` readIORef pq + case r of Nothing -> return () ; Just _ -> dequeuePQ (PQ pq) + return r + +sizePQ :: (Binary a, Ord a, Sizeable a) => PQ a -> IO Int +sizePQ (PQ pq) = snd `fmap` readIORef pq + + +-- We need an in-memory heap anyway. Here's a skew heap. +data SkewHeap a = Empty | Node a (SkewHeap a) (SkewHeap a) + +singleton :: Ord a => a -> SkewHeap a +singleton x = Node x Empty Empty + +union :: Ord a => SkewHeap a -> SkewHeap a -> SkewHeap a +Empty `union` t2 = t2 +t1 `union` Empty = t1 +t1@(Node x1 l1 r1) `union` t2@(Node x2 l2 r2) + | x1 <= x2 = Node x1 (t2 `union` r1) l1 + | otherwise = Node x2 (t1 `union` r2) l2 + +insert :: Ord a => a -> SkewHeap a -> SkewHeap a +insert x heap = singleton x `union` heap + +getMin :: Ord a => SkewHeap a -> Maybe a +getMin Empty = Nothing +getMin (Node x _ _) = Just x + +dropMin :: Ord a => SkewHeap a -> SkewHeap a +dropMin Empty = error "dropMin on empty queue... are you sure?!" +dropMin (Node _ l r) = l `union` r + diff --git a/src/Bio/TwoBit.hs b/src/Bio/TwoBit.hs new file mode 100644 --- /dev/null +++ b/src/Bio/TwoBit.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE BangPatterns #-} +module Bio.TwoBit ( + module Bio.Base, + + TwoBitFile, + openTwoBit, + + getSubseq, + getSubseqWith, + getSubseqAscii, + getSubseqMasked, + getSeqnames, + hasSequence, + getSeqLength, + clampPosition, + getRandomSeq, + + Mask(..) + ) where + +import Bio.Base +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.Binary.Get +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Char (toLower) +import qualified Data.IntMap as I +import qualified Data.Map as M +import Data.Maybe +import Numeric +import System.IO.Posix.MMap +import System.Random + +-- ^ Would you believe it? The 2bit format stores blocks of Ns in a table at +-- the beginning of a sequence, then packs four bases into a byte. So it +-- is neither possible nor necessary to store Ns in the main sequence, and +-- you would think they aren't stored there, right? And they aren't. +-- Instead Ts are stored which the reader has to replace with Ns. +-- +-- The sensible way to treat these is probably to just say there are two +-- kinds of implied annotation (repeats and large gaps for a typical +-- genome), which can be interpreted in whatever way fits. And that's why +-- we have 'Mask' and 'getSubseqWith'. +-- +-- TODO: use binary search for the Int->Int mappings? + +data TwoBitFile = TBF { + tbf_raw :: B.ByteString, + tbf_seqs :: !(M.Map Seqid TwoBitSequence) +} + +data TwoBitSequence = Indexed { tbs_n_blocks :: !(I.IntMap Int) + , tbs_m_blocks :: !(I.IntMap Int) + , tbs_dna_offset :: {-# UNPACK #-} !Int + , tbs_dna_size :: {-# UNPACK #-} !Int } + +-- | Brings a 2bit file into memory. The file is mmap'ed, so it will +-- not work on streams that are not actual files. It's also unsafe if +-- the file is modified in any way. +openTwoBit :: FilePath -> IO TwoBitFile +openTwoBit fp = do raw <- unsafeMMapFile fp + return $ flip runGet (L.fromChunks [raw]) $ do + sig <- getWord32be + getWord32 <- case sig of + 0x1A412743 -> return $ fromIntegral `fmap` getWord32be + 0x4327411A -> return $ fromIntegral `fmap` getWord32le + _ -> fail $ "invalid .2bit signature " ++ showHex sig [] + + version <- getWord32 + unless (version == 0) $ fail $ "wrong .2bit version " ++ show version + + nseqs <- getWord32 + _reserved <- getWord32 + + TBF raw <$> foldM (\ix _ -> do !key <- getWord8 >>= getByteString . fromIntegral + !off <- getWord32 + return $! M.insert key (mkBlockIndex raw getWord32 off) ix + ) M.empty [1..nseqs] + + +mkBlockIndex :: B.ByteString -> Get Int -> Int -> TwoBitSequence +mkBlockIndex raw getWord32 ofs = runGet getBlock $ L.fromChunks [B.drop ofs raw] + where + getBlock = do ds <- getWord32 + nb <- readBlockList + mb <- readBlockList + len <- getWord32 >> bytesRead + return $! Indexed (I.fromList nb) (I.fromList mb) (ofs + fromIntegral len) ds + + readBlockList = getWord32 >>= \n -> liftM2 zip (repM n getWord32) (repM n getWord32) + +-- | Repeat monadic action 'n' times. Returns result in reverse(!) order. +repM :: Monad m => Int -> m a -> m [a] +repM n0 m = go [] n0 + where + go acc 0 = return acc + go acc n = m >>= \x -> x `seq` go (x:acc) (n-1) + +takeOverlap :: Int -> I.IntMap Int -> [(Int,Int)] +takeOverlap k m = dropWhile far_left $ + maybe id (\(kv,_) -> (:) kv) (I.maxViewWithKey left) $ + maybe id (\v -> (:) (k,v)) middle $ + I.toAscList right + where + (left, middle, right) = I.splitLookup k m + far_left (s,l) = s+l <= k + +data Mask = None | Soft | Hard | Both deriving (Eq, Ord, Enum, Show) + +getFwdSubseqWith :: B.ByteString -> Int -- raw data, dna offset + -> I.IntMap Int -> I.IntMap Int -- N blocks, M blocks + -> (Word8 -> Mask -> a) -- mask function + -> Int -> Int -> [a] -- start, len, result +getFwdSubseqWith raw ofs n_blocks m_blocks nt start len = + do_mask (takeOverlap start n_blocks `mergeblocks` takeOverlap start m_blocks) start . + take len . drop (start .&. 3) . + B.foldr toDNA [] . + B.take (len `shiftR` 2 + 2) . -- needed?! + B.drop (fromIntegral $ ofs + (start `shiftR` 2)) $ raw + where + toDNA b = (++) [ 3 .&. (b `shiftR` x) | x <- [6,4,2,0] ] + + do_mask _ _ [] = [] + do_mask [ ] _ ws = map (`nt` None) ws + do_mask ((s,l,m):is) p ws + | p < s = map (`nt` None) (take (s-p) ws) ++ do_mask ((s,l,m):is) s (drop (s-p) ws) + | otherwise = map (`nt` m) (take (s+l-p) ws) ++ do_mask is (s+l) (drop (s+l-p) ws) + +-- | Merge blocks of Ns and blocks of Ms into single list of blocks with +-- masking annotation. Gaps remain. Used internally only. +mergeblocks :: [(Int,Int)] -> [(Int,Int)] -> [(Int,Int,Mask)] +mergeblocks ((_,0):nbs) mbs = mergeblocks nbs mbs +mergeblocks nbs ((_,0):mbs) = mergeblocks nbs mbs + +mergeblocks ((ns,nl):nbs) ((ms,ml):mbs) + | ns < ms = let l = min (ms-ns) nl in (ns,l, Hard) : mergeblocks ((ns+l,nl-l):nbs) ((ms,ml):mbs) + | ms < ns = let l = min (ns-ms) ml in (ms,l, Soft) : mergeblocks ((ns,nl):nbs) ((ms+l,ml-l):mbs) + | otherwise = let l = min nl ml in (ns,l, Both) : mergeblocks ((ns+l,nl-l):nbs) ((ms+l,ml-l):mbs) + +mergeblocks ((ns,nl):nbs) [] = (ns,nl, Hard) : mergeblocks nbs [] +mergeblocks [] ((ms,ml):mbs) = (ms,ml, Soft) : mergeblocks [] mbs + +mergeblocks [ ] [ ] = [] + + +-- | Extract a subsequence and apply masking. TwoBit file can represent +-- two kinds of masking (hard and soft), where hard masking is usually +-- realized by replacing everything by Ns and soft masking is done by +-- lowercasing. Here, we take a user supplied function to apply +-- masking. +getSubseqWith :: (Nucleotide -> Mask -> a) -> TwoBitFile -> Range -> [a] +getSubseqWith maskf tbf (Range { r_pos = Pos { p_seq = chr, p_start = start }, r_length = len }) = do + let sq1 = maybe (error $ unpackSeqid chr ++ " doesn't exist") id $ M.lookup chr (tbf_seqs tbf) + let go = getFwdSubseqWith (tbf_raw tbf) (tbs_dna_offset sq1) (tbs_n_blocks sq1) (tbs_m_blocks sq1) + if start < 0 + then reverse $ go (maskf . cmp_nt) (-start-len) len + else go (maskf . fwd_nt) start len + where + fwd_nt = (!!) [nucT, nucC, nucA, nucG] . fromIntegral + cmp_nt = (!!) [nucA, nucG, nucT, nucC] . fromIntegral + + +-- | Extract a subsequence without masking. +getSubseq :: TwoBitFile -> Range -> [Nucleotide] +getSubseq = getSubseqWith const + +-- | Extract a subsequence with typical masking: soft masking is +-- ignored, hard masked regions are replaced with Ns. +getSubseqMasked :: TwoBitFile -> Range -> [Nucleotides] +getSubseqMasked = getSubseqWith mymask + where + mymask n None = nucToNucs n + mymask n Soft = nucToNucs n + mymask _ Hard = nucsN + mymask _ Both = nucsN + +-- | Extract a subsequence with masking for biologists: soft masking is +-- done by lowercasing, hard masking by printing an N. +getSubseqAscii :: TwoBitFile -> Range -> String +getSubseqAscii = getSubseqWith mymask + where + mymask n None = showNucleotide n + mymask n Soft = toLower (showNucleotide n) + mymask _ Hard = 'N' + mymask _ Both = 'N' + + +getSeqnames :: TwoBitFile -> [Seqid] +getSeqnames = M.keys . tbf_seqs + +hasSequence :: TwoBitFile -> Seqid -> Bool +hasSequence tbf sq = isJust . M.lookup sq . tbf_seqs $ tbf + +getSeqLength :: TwoBitFile -> Seqid -> Int +getSeqLength tbf chr = + maybe (error $ shows chr " doesn't exist") tbs_dna_size $ + M.lookup chr (tbf_seqs tbf) + +-- | limits a range to a position within the actual sequence +clampPosition :: TwoBitFile -> Range -> Range +clampPosition tbf (Range (Pos n start) len) = Range (Pos n start') (end' - start') + where + size = getSeqLength tbf n + start' = if start < 0 then max start (-size) else start + end' = min (start + len) $ if start < 0 then 0 else size + + +-- | Sample a piece of random sequence uniformly from the genome. +-- Only pieces that are not hard masked are sampled, soft masking is +-- allowed, but not reported. +-- On a 32bit platform, this will fail for genomes larger than 1G bases. +-- However, if you're running this code on a 32bit platform, you have +-- bigger problems to worry about. +getRandomSeq :: RandomGen g => TwoBitFile -- ^ 2bit file + -> Int -- ^ desired length + -> g -- ^ RNG + -> ((Range, [Nucleotide]), g) -- ^ position, sequence, new RNG +getRandomSeq tbf len = draw + where + names = getSeqnames tbf + lengths = map (getSeqLength tbf) names + total = sum lengths + frags = I.fromList $ zip (scanl (+) 0 lengths) names + + draw g0 | good = ((r', sq), gn) + | otherwise = draw gn + where + (p0, gn) = randomR (0, 2*total-1) g0 + p = p0 `shiftR` 1 + Just ((o,s),_) = I.maxViewWithKey $ fst $ I.split (p+1) frags + r' = (if odd p0 then id else reverseRange) $ clampPosition tbf $ Range (Pos s (p-o)) len + sq = catMaybes $ getSubseqWith mask2maybe tbf r' + good = r_length r' == len && length sq == len + + mask2maybe n None = Just n + mask2maybe n Soft = Just n + mask2maybe _ Hard = Nothing + mask2maybe _ Both = Nothing + diff --git a/src/Bio/Util.hs b/src/Bio/Util.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Util.hs @@ -0,0 +1,226 @@ +module Bio.Util ( + wilson, invnormcdf, choose, + estimateComplexity, showNum, showOOM, + float2mini, mini2float, log1p, expm1, + phredplus, phredminus, phredsum, (<#>), phredconverse + ) where + +import Data.Bits +import Data.Char ( intToDigit ) +import Data.List ( foldl' ) +import Data.Word ( Word8 ) + +-- ^ Random useful stuff I didn't know where to put. + +-- | calculates the Wilson Score interval. +-- If @(l,m,h) = wilson c x n@, then @m@ is the binary proportion and +-- @(l,h)@ it's @c@-confidence interval for @x@ positive examples out of +-- @n@ observations. @c@ is typically something like 0.05. + +wilson :: Double -> Int -> Int -> (Double, Double, Double) +wilson c x n = ( (m - h) / d, p, (m + h) / d ) + where + nn = fromIntegral n + p = fromIntegral x / nn + + z = invnormcdf (1-c*0.5) + h = z * sqrt (( p * (1-p) + 0.25*z*z / nn ) / nn) + m = p + 0.5 * z * z / nn + d = 1 + z * z / nn + +showNum :: Show a => a -> String +showNum = triplets [] . reverse . show + where + triplets acc [] = acc + triplets acc (a:[]) = a:acc + triplets acc (a:b:[]) = b:a:acc + triplets acc (a:b:c:[]) = c:b:a:acc + triplets acc (a:b:c:s) = triplets (',':c:b:a:acc) s + +showOOM :: Double -> String +showOOM x | x < 0 = '-' : showOOM (negate x) + | otherwise = findSuffix (x*10) ".kMGTPEZY" + where + findSuffix _ [] = "many" + findSuffix y (s:ss) | y < 100 = intToDigit (round y `div` 10) : case (round y `mod` 10, s) of + (0,'.') -> [] ; (0,_) -> [s] ; (d,_) -> [s, intToDigit d] + | y < 1000 = intToDigit (round y `div` 100) : intToDigit ((round y `mod` 100) `div` 10) : + if s == '.' then [] else [s] + | y < 10000 = intToDigit (round y `div` 1000) : intToDigit ((round y `mod` 1000) `div` 100) : + '0' : if s == '.' then [] else [s] + | otherwise = findSuffix (y*0.001) ss + +-- Stolen from Lennart Augustsson's erf package, who in turn took it rom +-- http://home.online.no/~pjacklam/notes/invnorm/ Accurate to about 1e-9. +invnormcdf :: (Ord a, Floating a) => a -> a +invnormcdf p = + let a1 = -3.969683028665376e+01 + a2 = 2.209460984245205e+02 + a3 = -2.759285104469687e+02 + a4 = 1.383577518672690e+02 + a5 = -3.066479806614716e+01 + a6 = 2.506628277459239e+00 + + b1 = -5.447609879822406e+01 + b2 = 1.615858368580409e+02 + b3 = -1.556989798598866e+02 + b4 = 6.680131188771972e+01 + b5 = -1.328068155288572e+01 + + c1 = -7.784894002430293e-03 + c2 = -3.223964580411365e-01 + c3 = -2.400758277161838e+00 + c4 = -2.549732539343734e+00 + c5 = 4.374664141464968e+00 + c6 = 2.938163982698783e+00 + + d1 = 7.784695709041462e-03 + d2 = 3.224671290700398e-01 + d3 = 2.445134137142996e+00 + d4 = 3.754408661907416e+00 + + pLow = 0.02425 + + nan = 0/0 + + in if p < 0 then + nan + else if p == 0 then + -1/0 + else if p < pLow then + let q = sqrt(-2 * log p) + in (((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) / + ((((d1*q+d2)*q+d3)*q+d4)*q+1) + else if p < 1 - pLow then + let q = p - 0.5 + r = q*q + in (((((a1*r+a2)*r+a3)*r+a4)*r+a5)*r+a6)*q / + (((((b1*r+b2)*r+b3)*r+b4)*r+b5)*r+1) + else if p <= 1 then + - invnormcdf (1 - p) + else + nan + + +-- | Try to estimate complexity of a whole from a sample. Suppose we +-- sampled @total@ things and among those @singles@ occured only once. +-- How many different things are there? +-- +-- Let the total number be @m@. The copy number follows a Poisson +-- distribution with paramter @\lambda@. Let @z := e^{\lambda}@, then +-- we have: +-- +-- P( 0 ) = e^{-\lambda} = 1/z +-- P( 1 ) = \lambda e^{-\lambda} = ln z / z +-- P(>=1) = 1 - e^{-\lambda} = 1 - 1/z +-- +-- singles = m ln z / z +-- total = m (1 - 1/z) +-- +-- D := total/singles = (1 - 1/z) * z / ln z +-- f := z - 1 - D ln z = 0 +-- +-- To get @z@, we solve using Newton iteration and then substitute to +-- get @m@: +-- +-- df/dz = 1 - D/z +-- z' := z - z (z - 1 - D ln z) / (z - D) +-- m = singles * z /log z +-- +-- It converges as long as the initial @z@ is large enough, and @10D@ +-- (in the line for @zz@ below) appears to work well. + +estimateComplexity :: (Integral a, Floating b, Ord b) => a -> a -> Maybe b +estimateComplexity total singles | total <= singles = Nothing + | singles <= 0 = Nothing + | otherwise = Just m + where + d = fromIntegral total / fromIntegral singles + step z = z * (z - 1 - d * log z) / (z - d) + iter z = case step z of zd | abs zd < 1e-12 -> z + | otherwise -> iter $! z-zd + zz = iter $! 10*d + m = fromIntegral singles * zz / log zz + + +-- | Computes @-10 * log_10 (10 ** (-x\/10) + 10 ** (-y\/10))@ without +-- losing precision. Used to add numbers on "the Phred scale", +-- otherwise known as (deci-)bans. +{-# INLINE phredplus #-} +phredplus :: Double -> Double -> Double +phredplus x y = if x < y then pp x y else pp y x where + pp u v = u - 10 / log 10 * log1p (exp ((u-v) * log 10 / 10)) + +-- | Computes @-10 * log_10 (10 ** (-x\/10) - 10 ** (-y\/10))@ without +-- losing precision. Used to subtract numbers on "the Phred scale", +-- otherwise known as (deci-)bans. +{-# INLINE phredminus #-} +phredminus :: Double -> Double -> Double +phredminus x y = if x < y then pm x y else pm y x where + pm u v = u - 10 / log 10 * log1p (- exp ((u-v) * log 10 / 10)) + +-- | Computes @-10 * log_10 (sum [10 ** (-x\/10) | x <- xs])@ without losing +-- precision. +{-# INLINE phredsum #-} +phredsum :: [Double] -> Double +phredsum = foldl' (<#>) (1/0) + +infixl 3 <#>, `phredminus`, `phredplus` +{-# INLINE (<#>) #-} +(<#>) :: Double -> Double -> Double +(<#>) = phredplus + +-- | Computes @1-p@ without leaving the "Phred scale" +phredconverse :: Double -> Double +phredconverse v = - 10 / log 10 * log1p (- exp ((-v) * log 10 / 10)) + +-- | Computes @log (1+x)@ to a relative precision of @10^-8@ even for +-- very small @x@. Stolen from http://www.johndcook.com/cpp_log_one_plus_x.html +{-# INLINE log1p #-} +log1p :: (Floating a, Ord a) => a -> a +log1p x | x < -1 = error "log1p: argument must be greater than -1" + -- x is large enough that the obvious evaluation is OK: + | x > 0.0001 || x < -0.0001 = log $ 1 + x + -- Use Taylor approx. log(1 + x) = x - x^2/2 with error roughly x^3/3 + -- Since |x| < 10^-4, |x|^3 < 10^-12, relative error less than 10^-8: + | otherwise = (1 - 0.5*x) * x + + +-- | Computes @exp x - 1@ to a relative precision of @10^-10@ even for +-- very small @x@. Stolen from http://www.johndcook.com/cpp_expm1.html +expm1 :: (Floating a, Ord a) => a -> a +expm1 x | x > -0.00001 && x < 0.00001 = (1 + 0.5 * x) * x -- Taylor approx + | otherwise = exp x - 1 -- direct eval + + +-- | Binomial coefficient: @n `choose` k == n! / ((n-k)! k!)@ +{-# INLINE choose #-} +choose :: Integral a => a -> a -> a +n `choose` k = product [n-k+1 .. n] `div` product [2..k] + + +-- | Conversion to 0.4.4 format minifloat: This minifloat fits into a +-- byte. It has no sign, four bits of precision, and the range is from +-- 0 to 63488, initially in steps of 1/8. Nice to store quality scores +-- with reasonable precision and range. +float2mini :: RealFloat a => a -> Word8 +float2mini f | f' < 0 = error "no negative minifloats" -- negative zero is fine! + | f < 2 = f' + | e >= 17 = 0xff + | s < 16 = error $ "oops: " ++ show (e,s) + | s < 32 = (e-1) `shiftL` 4 .|. (s .&. 0xf) + | s == 32 = e `shiftL` 4 + | otherwise = error $ "oops: " ++ show (e,s) + where + f' = round (8*f) + e = fromIntegral $ exponent f + s = round $ 32 * significand f + +-- | Conversion from 0.4.4 format minifloat, see 'float2mini'. +mini2float :: Fractional a => Word8 -> a +mini2float w | e == 0 = fromIntegral w / 8.0 + | otherwise = 2^e * fromIntegral m / 16.0 + where + m = (w .&. 0xF) .|. 0x10 + e = w `shiftR` 4 + diff --git a/src/Data/Avro.hs b/src/Data/Avro.hs new file mode 100644 --- /dev/null +++ b/src/Data/Avro.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, TemplateHaskell #-} +{-# LANGUAGE RecordWildCards, BangPatterns, FlexibleContexts #-} +module Data.Avro where + +import Bio.Iteratee +import Control.Applicative +import Control.Monad +import Control.Monad.ST ( runST, ST ) +import Data.Aeson hiding ((.=)) +import Data.Array.MArray +import Data.Array.ST ( STUArray ) +import Data.Array.Unsafe ( castSTUArray ) +import Data.Binary.Get +import Data.Bits +import Data.Binary.Builder +import Data.Foldable ( foldMap ) +import Data.Int ( Int64 ) +import Data.Maybe +import Data.Monoid +import Data.Scientific +import Data.Text.Encoding +import Data.Word ( Word32, Word64 ) +import Foreign.Storable ( Storable, sizeOf ) +import Language.Haskell.TH +import System.Random + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as H +import qualified Data.ListLike as LL +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U + +-- ^ Support for Avro. +-- Current status is that we can generate schemas for certain Haskell +-- values, serialize to binary and JSON representations, and write +-- Container files using the null codec. The C implementation likes +-- some, but not all of these containers; it's unclear if that's the +-- fault of the C implementation, though. +-- +-- Meanwhile, serialization works for nested sums-of-products, as long as the +-- product uses record syntax and the top level is a plain record. +-- The obvious primitives are supported. + +(.=) :: ToJSON a => String -> a -> (T.Text, Value) +k .= v = (T.pack k, toJSON v) + +string :: String -> Value +string = String . T.pack + +-- | This is the class of types we can embed into the Avro +-- infrastructure. Right now, we can derive a schema, encode to +-- the Avro binary format, and encode to the Avro JSON encoding. +class Avro a where + -- | Produces the schema for this type. Schemas are represented as + -- JSON values. The monad is used to keep a table of already + -- defined types, so the schema can refer to them by name. (The + -- concrete argument serves to specify the type, it is not actually + -- used.) + toSchema :: a -> MkSchema Value + + -- | Serializes a value to the binary representation. The schema is + -- implied, serialization to related schemas is not supported. + toBin :: a -> Builder + + -- | Deserializzes a value from binary representation. Right now, + -- no attempt at schema matching is done, the schema must match the + -- expected one exactly. + fromBin :: Get a + + -- | Serializes a value to the JSON representation. Note that even + -- the JSON format needs a schema for successful deserialization, + -- and here we support only the one implied schema. + toAvron :: a -> Value + + +newtype MkSchema a = MkSchema + { mkSchema :: (a -> H.HashMap T.Text Value -> Value) -> H.HashMap T.Text Value -> Value } + +instance Functor MkSchema where fmap f m = MkSchema (\k -> mkSchema m (k . f)) +instance Applicative MkSchema where pure a = MkSchema (\k -> k a) + u <*> v = MkSchema (\k -> mkSchema u (\a -> mkSchema v (k . a))) +instance Monad MkSchema where return a = MkSchema (\k -> k a) + a >>= m = MkSchema (\k -> mkSchema a (\a' -> mkSchema (m a') k)) + +memoObject :: String -> [(T.Text,Value)] -> MkSchema Value +memoObject nm ps = MkSchema $ \k h -> + let nm' = T.pack nm + obj = object $ ("name" .= nm) : ps + in case H.lookup nm' h of + Nothing -> k obj $! H.insert nm' obj h + Just obj' | obj == obj' -> k (String nm') h + | otherwise -> error $ "same type name, different schema: " ++ nm + +runMkSchema :: MkSchema Value -> Value +runMkSchema x = mkSchema x postproc H.empty + where + -- Objects are fine as is. + postproc (Object o) _ = Object o + -- Top level can't be a string, can it? Need to wrap into the long form. + postproc (String tp) _ = object [ "type" .= String tp ] + -- Top level Array should be fine, too. + postproc (Array a) _ = Array a + -- reject anything else + postproc v _ = error $ "Not allowed as toplevel schema: " ++ show v + +-- instances for primitive types + +-- | The Avro \"null\" type is represented as the empty tuple. +instance Avro () where + toSchema _ = return $ String "null" + toBin () = mempty + fromBin = return () + toAvron () = Null + +instance Avro Bool where + toSchema _ = return $ String "boolean" + toBin = singleton . fromIntegral . fromEnum + fromBin = toEnum . fromIntegral <$> getWord8 + toAvron = Bool + +instance Avro Int where + toSchema _ = return $ String "long" + toBin = encodeIntBase128 + fromBin = decodeIntBase128 + toAvron = Number . fromIntegral + +instance Avro Int64 where + toSchema _ = return $ String "long" + toBin = encodeIntBase128 + fromBin = decodeIntBase128 + toAvron = Number . fromIntegral + +instance Avro Float where + toSchema _ = return $ String "float" + toBin = putWord32le . floatToWord + fromBin = wordToFloat <$> getWord32le + toAvron = Number . fromFloatDigits + +instance Avro Double where + toSchema _ = return $ String "double" + toBin = putWord64le . doubleToWord + fromBin = wordToDouble <$> getWord64le + toAvron = Number . fromFloatDigits + +instance Avro B.ByteString where + toSchema _ = return $ String "bytes" + toBin s = encodeIntBase128 (B.length s) <> fromByteString s + fromBin = decodeIntBase128 >>= getByteString + toAvron = String . decodeLatin1 + +instance Avro T.Text where + toSchema _ = return $ String "string" + toBin = toBin . encodeUtf8 + fromBin = decodeUtf8 <$> fromBin + toAvron = String + + +-- Integer<->Float conversions, stolen from cereal. + +{-# INLINE wordToFloat #-} +wordToFloat :: Word32 -> Float +wordToFloat x = runST (cast x) + +{-# INLINE wordToDouble #-} +wordToDouble :: Word64 -> Double +wordToDouble x = runST (cast x) + +{-# INLINE floatToWord #-} +floatToWord :: Float -> Word32 +floatToWord x = runST (cast x) + +{-# INLINE doubleToWord #-} +doubleToWord :: Double -> Word64 +doubleToWord x = runST (cast x) + +{-# INLINE cast #-} +cast :: ( MArray (STUArray s) b (ST s), MArray (STUArray s) a (ST s) ) => a -> ST s b +cast x = (newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0) + +-- | Implements Zig-Zag-Coding like in Protocol Buffers and Avro. +zig :: (Storable a, Bits a) => a -> a +zig x = (x `shiftL` 1) `xor` (x `shiftR` (8 * sizeOf x -1)) + +-- | Reverses Zig-Zag-Coding like in Protocol Buffers and Avro. +zag :: (Storable a, Bits a, Num a) => a -> a +zag x = negate (x .&. 1) `xor` ((x .&. complement 1) `rotateR` 1) + +-- | Encodes a word of any size using a variable length "base 128" +-- encoding. +encodeWordBase128 :: (Integral a, Bits a) => a -> Builder +encodeWordBase128 x | x' == 0 = singleton (fromIntegral (x .&. 0x7f)) + | otherwise = singleton (fromIntegral (x .&. 0x7f .|. 0x80)) + <> encodeWordBase128 x' + where x' = x `shiftR` 7 + +decodeWordBase128 :: (Integral a, Bits a) => Get a +decodeWordBase128 = go 0 0 + where + go acc sc = do x <- getWord8 + let !acc' = acc .|. fromIntegral x `shiftL` sc + if x .&. 0x80 == 0 + then return acc' + else go acc' (sc+7) + +-- | Encodes an int of any size by combining the zig-zag coding with the +-- base 128 encoding. +encodeIntBase128 :: (Integral a, Bits a, Storable a) => a -> Builder +encodeIntBase128 = encodeWordBase128 . zig + +-- | Decodes an int of any size by combining the zig-zag decoding with +-- the base 128 decoding. +decodeIntBase128 :: (Integral a, Bits a, Storable a) => Get a +decodeIntBase128 = zag <$> decodeWordBase128 + +zigInt :: Int -> Builder +zigInt = encodeIntBase128 + +zagInt :: Get Int +zagInt = decodeWordBase128 + +-- Complex Types + +-- | A list becomes an Avro array +-- The chunked encoding for lists may come in handy. How to select the +-- chunk size is not obvious, though. +instance Avro a => Avro [a] where + toSchema as = do sa <- toSchema (head as) + return $ object [ "type" .= String "array", "items" .= sa ] + toBin [] = singleton 0 + toBin as = toBin (length as) <> foldMap toBin as <> singleton 0 + toAvron = Array . V.fromList . map toAvron + + -- This is not suitable for incremental processing. + fromBin = get_blocks [] + where + get_blocks acc = zagInt >>= \l -> if l == 0 then return $ reverse acc + else get_block acc l >>= get_blocks + get_block acc l = if l == 0 then return acc + else fromBin >>= \a -> get_block (a:acc) (l-1) + + +-- | A generic vector becomes an Avro array +instance Avro a => Avro (V.Vector a) where + toSchema as = do sa <- toSchema (V.head as) + return $ object [ "type" .= String "array", "items" .= sa ] + toBin as | V.null as = singleton 0 + | otherwise = toBin (V.length as) <> foldMap toBin as <> singleton 0 + toAvron = Array . V.map toAvron + + -- This is not suitable for incremental processing. + fromBin = get_blocks [] + where + get_blocks acc = zagInt >>= \l -> if l == 0 then return $ V.concat $ reverse acc + else get_block [] l >>= + get_blocks . (: acc) . V.fromListN l . reverse + get_block acc l = if l == 0 then return acc + else fromBin >>= \a -> get_block (a:acc) (l-1) + +-- | An unboxed vector becomes an Avro array +instance (Avro a, U.Unbox a) => Avro (U.Vector a) where + toSchema as = do sa <- toSchema (U.head as) + return $ object [ "type" .= String "array", "items" .= sa ] + toBin as | U.null as = singleton 0 + | otherwise = toBin (U.length as) <> U.foldr ((<>) . toBin) mempty as <> singleton 0 + toAvron = Array . V.map toAvron . U.convert + + -- This is not suitable for incremental processing. + fromBin = get_blocks [] + where + get_blocks acc = zagInt >>= \l -> if l == 0 then return $ U.concat $ reverse acc + else get_block [] l >>= + get_blocks . (: acc) . U.fromListN l . reverse + get_block acc l = if l == 0 then return acc + else fromBin >>= \a -> get_block (a:acc) (l-1) + + +-- | A map from Text becomes an Avro map. +instance Avro a => Avro (H.HashMap T.Text a) where + toSchema m = do sa <- toSchema (m H.! T.empty) + return $ object [ "type" .= String "map", "values" .= sa ] + toBin as | H.null as = singleton 0 + | otherwise = toBin (H.size as) <> H.foldrWithKey (\k v b -> toBin k <> toBin v <> b) (singleton 0) as + toAvron = Object . H.map toAvron + + -- This is not suitable for incremental processing. + fromBin = get_blocks H.empty + where + get_blocks !acc = zagInt >>= \l -> if l == 0 then return acc + else get_block acc l >>= get_blocks + get_block !acc l = if l == 0 then return acc + else fromBin >>= \k -> fromBin >>= \v -> get_block (H.insert k v acc) (l-1) + + + +-- * Some(!) complex types. +-- +-- Enums: Enumerated symbols. This is generated automatically for sums +-- of empty alternatives. Constructor names become enum symbols. + +-- Records: This is generated automatically for product types using +-- Haskell record syntax. +-- +-- Unions: For Haskell sum-of-product types using record syntax for +-- every arm, an Avro instance resolving to a union of record can be +-- generated automatically. The constructor names become record type +-- names, their fields become record fields. + +-- XXX Sometimes we build sum types containing sum types, Maybe being the +-- most obvious example. A (Maybe a) where a itself yields a union, +-- should probably yield a union with one more alternative (the null). + + +deriveAvros :: [Name] -> Q [Dec] +deriveAvros = liftM concat . mapM deriveAvro + +deriveAvro :: Name -> Q [Dec] +deriveAvro nm = reify nm >>= case_info + where + err m = fail $ "cannot derive Avro for " ++ show nm ++ ", " ++ m + + case_info (TyConI dec) = case_dec dec + case_info _ = err "it is not a type constructor" + + simple_cons (NormalC _ []) = True + simple_cons _ = False + + record_cons (RecC _ _) = True + record_cons _ = False + + case_dec (NewtypeD _cxt _name _tyvarbndrs _con _) = err $ "don't know what to do for NewtypeD" + case_dec (DataD _cxt _name _tyvarbndrs cons _) + | all simple_cons cons = mk_enum_inst [ nm1 | NormalC nm1 [] <- cons ] + | all record_cons cons = mk_record_inst [ (nm1, vsts) | RecC nm1 vsts <- cons ] + | otherwise = err $ "don't know how to make an instance with these constructors" + case_dec _ = fail $ "is not a data or newtype declaration" + + tolit = litE . StringL . nameBase + tolitlist (x:xs) = [| T.pack $(tolit x) : $(tolitlist xs) |] + tolitlist [ ] = [| [] |] + + -- enum instance from list of names + mk_enum_inst :: [Name] -> Q [Dec] + mk_enum_inst nms = + [d| instance Avro $(conT nm) where + toSchema _ = return $ object [ "type" .= string "enum" + , "name" .= string $(tolit nm) + , "symbols" .= $(tolitlist nms) ] + toBin x = $( + return $ CaseE (VarE 'x) + [ Match (ConP nm1 []) + (NormalB (AppE (VarE 'zigInt) + (LitE (IntegerL i)))) [] + | (i,nm1) <- zip [0..] nms ] ) + + fromBin = zagInt >>= \x -> $( + return $ CaseE (VarE 'x) + [ Match (LitP (IntegerL i)) + (NormalB (AppE (VarE 'return) + (ConE nm1))) [] + | (i,nm1) <- zip [0..] nms ] ) + + toAvron x = $( + return $ CaseE (VarE 'x) + [ Match (ConP nm1 []) + (NormalB (AppE (VarE 'string) + (LitE (StringL (nameBase nm1))))) [] + | nm1 <- nms ] ) + |] + + -- record instance from record-like constructors + -- XXX maybe allow empty "normal" constructors, too + mk_record_inst :: [ (Name, [(Name, Strict, Type)]) ] -> Q [Dec] + mk_record_inst [(nm1,fs1)] = + [d| instance Avro $(conT nm) where + toSchema _ = $(mk_product_schema nm1 fs1) + toBin = $(to_bin_product fs1) + fromBin = $(from_bin_product [| return $(conE nm1) |] fs1) + toAvron = $(to_avron_product fs1) + |] + + mk_record_inst arms = + [d| instance Avro $(conT nm) where + toSchema _ = Array . V.fromList <$> sequence + $( foldr (\(nm1,fs) k -> [| $(mk_product_schema nm1 fs) : $k |]) + [| [] |] arms ) + toBin = + $( do x <- newName "x" + LamE [VarP x] . CaseE (VarE x) + <$> sequence [ ($ []) . Match (RecP nm1 []) . NormalB + <$> [| zigInt $(litE (IntegerL i)) <> $(to_bin_product fs) $(varE x) |] + | (i,(nm1,fs)) <- zip [0..] arms ] ) + + fromBin = zagInt >>= + $( do x <- newName "x" + LamE [VarP x] . CaseE (VarE x) + <$> sequence [ ($ []) . Match (LitP (IntegerL i)) . NormalB + <$> from_bin_product [| return $(conE nm1) |] fs + | (i,(nm1,fs)) <- zip [0..] arms ] ) + + toAvron = + $( do x <- newName "x" + LamE [VarP x] . CaseE (VarE x) + <$> sequence [ ($ []) . Match (RecP nm1 []) . NormalB + <$> [| object [ $(tolit nm1) .= $(to_avron_product fs) $(varE x) ] |] + | (nm1,fs) <- arms ] ) + |] + + -- create schema for a product from a name and a list of fields + mk_product_schema nm1 tps = + [| $( fieldlist tps ) >>= \flds -> + memoObject $( tolit nm1 ) + [ "type" .= string "record" + , "fields" .= Array (V.fromList flds) ] |] + + fieldlist = foldr go [| return [] |] + where + go (nm1,_,tp) k = + [| do sch <- toSchema $(sigE (varE 'undefined) (return tp)) + obs <- $k + return $ object [ "name" .= string $(tolit nm1) + , "type" .= sch ] + : obs |] + + -- binary encoding of records: field by field. + to_bin_product nms = + [| \x -> $( foldr (\(nm1,_,_) k -> [| mappend (toBin ($(varE nm1) x)) $k |] ) + [| mempty |] nms ) |] + + from_bin_product = + foldl (\expr (_,_,_) -> [| $expr <*> fromBin |]) + + -- json encoding of records: fields in an object + to_avron_product nms = + [| \x -> object $( + foldr (\(nm1,_,_) k -> [| ($(tolit nm1) .= toAvron ($(varE nm1) x)) : $k |] ) + [| [] |] nms ) |] + + +data ContainerOpts = ContainerOpts { objects_per_block :: Int + , filetype_label :: B.ByteString } + +-- Writing a container file. This is an 'Enumeratee', we read a list of +-- suitable types, we write a header containing the generated schema, +-- and a series of blocks with serialized data. +writeAvroContainer :: (MonadIO m, Nullable s, ListLike s a, Avro a) + => ContainerOpts -> Enumeratee s B.ByteString m r +writeAvroContainer ContainerOpts{..} out = do + ma <- peekStream + sync_marker <- liftIO $ B.pack <$> replicateM 16 randomIO + + let schema = encode . runMkSchema . toSchema . fromJust $ ma + + meta :: H.HashMap T.Text B.ByteString + meta = H.fromList [( "avro.schema", B.concat $ BL.toChunks schema ) + ,( "avro.codec", "null" ) + ,( "biohazard.filetype", filetype_label )] + + hdr = fromByteString "Obj\1" <> toBin meta <> fromByteString sync_marker + + let enc_blocks = iterLoop $ \out' -> do (num,code) <- joinI $ takeStream objects_per_block $ + foldStream (\(!n,c) o -> (n+1, c <> toBin o)) (0::Int,mempty) + + let code1 = toLazyByteString code + block = toBin num <> toBin (BL.length code1) <> + fromLazyByteString code1 <> fromByteString sync_marker + lift (enumList (BL.toChunks $ toLazyByteString block) out') + + lift (enumList (BL.toChunks $ toLazyByteString hdr) out) >>= enc_blocks + +-- XXX Possible codecs: null, zlib, snappy, lzma; all missing +-- XXX Should check schema on reading. + +readAvroContainer :: (Monad m, ListLike s a, Avro a) => Enumeratee B.ByteString s m r +readAvroContainer out = do + 4 <- heads "Obj\1" -- enough magic? + meta <- iterGet (fromBin :: Get (H.HashMap T.Text B.ByteString)) + sync_marker <- iGetString 16 + + flip iterLoop out $ \o -> do num <- iterGet zagInt + sz <- iterGet fromBin + o' <- joinI $ takeStream sz $ -- codec goes here + convStream (LL.singleton `liftM` iterGet fromBin) o + 16 <- heads sync_marker + return o' + +-- | Repeatedly apply an 'Iteratee' to a value until end of stream. +-- Returns the final value. +iterLoop :: (Nullable s, Monad m) => (a -> Iteratee s m a) -> a -> Iteratee s m a +iterLoop it a = do e <- isFinished + if e then return a + else it a >>= iterLoop it + + +iterGet :: Monad m => Get a -> Iteratee B.ByteString m a +iterGet = go . runGetIncremental + where + go (Fail _ _ err) = throwErr (iterStrExc err) + go (Done rest _ a) = idone a (Chunk rest) + go (Partial dec) = liftI $ \ck -> case ck of + Chunk s -> go (dec $ Just s) + EOF mx -> case dec Nothing of + Fail _ _ err -> throwErr (iterStrExc err) + Partial _ -> throwErr (iterStrExc "") + Done rest _ a | B.null rest -> idone a (EOF mx) + | otherwise -> idone a (Chunk rest) + diff --git a/src/cbits/jive.c b/src/cbits/jive.c new file mode 100644 --- /dev/null +++ b/src/cbits/jive.c @@ -0,0 +1,93 @@ +/** Computes likelihoods for each pair of indices, given matching + * probabilities for each and a matrix of prior probabilities. Return + * the index pair that yields the maximum likelihood and the total + * likelihood. (The length of p5_ must be a multiple of 32 to make + * vectorization easier.) + * + * @param v_ matrix of dimension (n7,n5_*32) containing the prior + * @param p7_ vector of length n7 containing matching probabilities for + * the first index + * @param n7 length of vector p7_ + * @param p5_ vector of length (n5_*32) containing matching + * probabilities for the second index + * @param n5 length of vector p5_ divided by 32 + * @param pi7 pointer to location that receives index of the first index + * that yields the maximum likelihood (ignored if null) + * @param pi5 pointer to location that receives index of the second index + * that yields the maximum likelihood (ignored if null) + * @return the total likelihood + */ +double c_unmix_total( const double *restrict v_ + , const double *restrict p7_, unsigned n7 + , const double *restrict p5_, unsigned n5_ + , unsigned *pi7, unsigned *pi5 ) +{ + unsigned n5 = n5_ * 32 ; + const double *restrict v = v_ ; // __builtin_assume_aligned( v_, 16 ) ; + const double *restrict p5 = p5_ ; // __builtin_assume_aligned( p5_, 16 ) ; + const double *restrict p7 = p7_ ; // __builtin_assume_aligned( p7_, 16 ) ; + + double acc = 0 ; + double max = 0 ; + unsigned mi7 = 0 ; + unsigned mi5 = 0 ; + for( unsigned i = 0, k = 0 ; i != n7 ; ++i, k += n5 ) { + double p7i = p7[i] ; + for( unsigned j = 0 ; j != n5 ; ++j ) { + double p = v[k+j] * p7i * p5[j] ; + acc += p ; + if( p > max ) { + max = p ; + mi7 = i ; + mi5 = j ; + } + } + } + if( pi7 ) *pi7 = mi7 ; + if( pi5 ) *pi5 = mi5 ; + return acc ; +} + +/** Computes posterior probabilities for each pair of indices, given + * matching probabilities for each and a matrix of prior probabilities, + * the total likelihood and the index pair that yields the maximum + * likelihood. The posterior is added to an accumulator, and a quality + * score is returned. (The length of p5_ must be a multiple of 32 to + * make vectorization easier.) + * + * @param w_ matrix of dimension (n7,n5_*32) to which the posterior is added (ignored if null) + * @param v_ matrix of dimension (n7,n5_*32) containing the prior + * @param p7_ vector of length n7 containing matching probabilities for the first index + * @param n7 length of vector p7_ + * @param p5_ vector of length (n5_*32) containing matching probabilities for the second index + * @param n5 length of vector p5_ divided by 32 + * @param total the total likelihood + * @param mi7 index of the first index that yields the maximum likelihood + * @param mi5 index of the second index that yields the maximum likelihood + * @return the posterior probability for any other than the most likely assignment + */ +double c_unmix_qual( double *restrict w_ + , const double *restrict v_ + , const double *restrict p7_, unsigned n7 + , const double *restrict p5_, unsigned n5_ + , double total, unsigned mi7, unsigned mi5 ) +{ + unsigned n5 = n5_ * 32 ; + double *restrict w = w_ ; // __builtin_assume_aligned( w_, 16 ) ; + const double *restrict v = v_ ; // __builtin_assume_aligned( v_, 16 ) ; + const double *restrict p5 = p5_ ; // __builtin_assume_aligned( p5_, 16 ) ; + const double *restrict p7 = p7_ ; // __builtin_assume_aligned( p7_, 16 ) ; + double acc = 0 ; + + total = 1.0 / total ; + for( unsigned i = 0, k = 0 ; i != n7 ; ++i ) { + double p7i = p7[i] ; + for( unsigned j = 0 ; j != n5 ; ++j, ++k ) { + double p = total * v[k] * p7i * p5[j] ; + if( w ) w[k] += p ; + if( mi7 != i || mi5 != j ) acc += p ; + } + } + return acc ; +} + diff --git a/src/cbits/myers_align.c b/src/cbits/myers_align.c new file mode 100644 --- /dev/null +++ b/src/cbits/myers_align.c @@ -0,0 +1,104 @@ +#include "myers_align.h" + +#include +#include +#include + +inline int match( char a, char b ) { return (char_to_bitmap(a) & char_to_bitmap(b)) != 0 ; } + +// [*blech*, this looks and feels like FORTRAN.] +unsigned myers_diff( + const char *seq_a, int len_a, enum myers_align_mode mode, + const char* seq_b, int len_b, int maxd, + char *bt_a, char *bt_b ) +{ + // int len_a = strlen( seq_a ), len_b = strlen( seq_b ) ; + if( maxd > len_a + len_b ) maxd = len_a + len_b ; + + // in vee[d][k], d runs from 0 to maxd; k runs from -d to +d + int **vee = calloc( maxd, sizeof(int*) ) ; + + int d, dd, k, x, y, r = UINT_MAX ; + int *v_d_1 = 0, *v_d = 0 ; // "array slice" vee[.][d-1] + for( d = 0 ; d != maxd ; ++d, v_d_1 = v_d ) // D-paths in order of increasing D + { + v_d = d + (vee[d] = malloc( (2 * d + 1) * sizeof( int ) )) ; // "array slice" vee[.][d] + + for( k = max(-d,-len_a) ; k <= min(d,len_b) ; ++k ) // diagonals + { + if( d == 0 ) x = 0 ; + else if(d==1&&k==0) x = v_d_1[ k ]+1 ; + else if( k == -d ) x = v_d_1[ k+1 ] ; + else if( k == d ) x = v_d_1[ k-1 ]+1 ; // argh, need to check for d first, b/c -d+2 could be equal to d + else if( k == -d+1 ) x = max( v_d_1[ k ]+1, v_d_1[ k+1 ] ) ; + else if( k == d-1 ) x = max( v_d_1[ k-1 ]+1, v_d_1[ k ]+1 ) ; + else x = max3( v_d_1[ k-1 ]+1, v_d_1[ k ]+1, v_d_1[ k+1 ] ) ; + + y = x-k ; + while( x < len_b && y < len_a && match( seq_b[x], seq_a[y] ) ) ++x, ++y ; + v_d[ k ] = x ; + + if( + bt_a && bt_b && + (mode == myers_align_is_prefix || y == len_a) && + (mode == myers_align_has_prefix || x == len_b) ) + { + char *out_a = bt_a + len_a + d +2 ; + char *out_b = bt_b + len_b + d +2 ; + *--out_a = 0 ; + *--out_b = 0 ; + for( dd = d ; dd != 0 ; ) + { + if( k != -dd && k != dd && x == vee[ dd-1 ][ k + dd-1 ]+1 ) + { + --dd ; + --x ; + --y ; + *--out_b = seq_b[x] ; + *--out_a = seq_a[y] ; + } + else if( k > -dd+1 && x == vee[ dd-1 ][ k-1 + dd-1 ]+1 ) + { + --x ; + --k ; + --dd ; + *--out_b = seq_b[x] ; + *--out_a = '-' ; + } + else if( k < dd-1 && x == vee[ dd-1 ][ k+1 + dd-1 ] ) + { + ++k ; + --y ; + --dd ; + *--out_b = '-' ; + *--out_a = seq_a[y] ; + } + else // this better had been a match... + { + --x ; + --y ; + *--out_b = seq_b[x] ; + *--out_a = seq_a[y] ; + } + } + while( x > 0 ) + { + --x ; + *--out_b = seq_b[x] ; + *--out_a = seq_a[x] ; + } + memmove( bt_a, out_a, bt_a + len_a + d + 2 - out_a ) ; + memmove( bt_b, out_b, bt_b + len_b + d + 2 - out_b ) ; + r = d ; + goto cleanup ; + } + } + } + +cleanup: + for( dd = maxd ; dd != 0 ; --dd ) + free( vee[dd-1] ) ; + free( vee ) ; + return r ; +} + diff --git a/tools/AD.hs b/tools/AD.hs new file mode 100644 --- /dev/null +++ b/tools/AD.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE BangPatterns #-} +module AD where + +import qualified Data.Vector.Unboxed as U + +-- Simple forward-mode AD to get a scalar valued function and a +-- gradient. + +data AD = C !Double | D !Double !(U.Vector Double) + deriving Show + +instance Num AD where + {-# INLINE (+) #-} + C x + C y = C (x+y) + C x + D y v = D (x+y) v + D x u + C y = D (x+y) u + D x u + D y v = D (x+y) (U.zipWith (+) u v) + + {-# INLINE (-) #-} + C x - C y = C (x-y) + C x - D y v = D (x-y) (U.map negate v) + D x u - C y = D (x-y) u + D x u - D y v = D (x-y) (U.zipWith (-) u v) + + {-# INLINE (*) #-} + C x * C y = C (x*y) + C x * D y v = D (x*y) (U.map (x*) v) + D x u * C y = D (x*y) (U.map (y*) u) + D x u * D y v = D (x*y) (U.zipWith (+) (U.map (x*) v) (U.map (y*) u)) + + {-# INLINE negate #-} + negate (C x) = C (negate x) + negate (D x u) = D (negate x) (U.map negate u) + + {-# INLINE fromInteger #-} + fromInteger = C . fromInteger + + {-# INLINE abs #-} + abs (C x) = C (abs x) + abs (D x u) | x < 0 = D (negate x) (U.map negate u) + | otherwise = D x u + + {-# INLINE signum #-} + signum (C x) = C (signum x) + signum (D x _) = C (signum x) + + +instance Fractional AD where + {-# INLINE (/) #-} + C x / C y = C (x/y) + D x u / C y = D (x*z) (U.map (z*) u) where z = recip y + C x / D y v = D (x/y) (U.map (w*) v) where w = negate $ x * z * z ; z = recip y + D x u / D y v = D (x/y) (U.zipWith (-) (U.map (z*) u) (U.map (w*) v)) + where z = recip y ; w = x * z * z + + {-# INLINE recip #-} + recip (C x) = C (recip x) + recip (D x u) = D (recip x) (U.map (y*) u) where y = negate $ recip $ x*x + + {-# INLINE fromRational #-} + fromRational = C . fromRational + + +instance Floating AD where + {-# INLINE pi #-} + pi = C pi + + {-# INLINE exp #-} + exp (C x) = C (exp x) + exp (D x u) = D (exp x) (U.map (* exp x) u) + + {-# INLINE sqrt #-} + sqrt (C x) = C (sqrt x) + sqrt (D x u) = D (sqrt x) (U.map (*w) u) where w = recip $ 2 * sqrt x + + {-# INLINE log #-} + log (C x) = C (log x) + log (D x u) = D (log x) (U.map (*w) u) where w = recip x + + {- (**) = undefined -- :: a -> a -> a + logBase = undefined -- :: a -> a -> a + sin = undefined -- :: a -> a + tan = undefined -- :: a -> a + cos = undefined -- :: a -> a + asin = undefined -- :: a -> a + atan = undefined -- :: a -> a + acos = undefined -- :: a -> a + sinh = undefined -- :: a -> a + tanh = undefined -- :: a -> a + cosh = undefined -- :: a -> a + asinh = undefined -- :: a -> a + atanh = undefined -- :: a -> a + acosh = undefined -- :: a -> a -} + + +paramVector :: [Double] -> [AD] +paramVector xs = [ D x (U.generate l (\j -> if i == j then 1 else 0)) | (i,x) <- zip [0..] xs ] + where l = length xs + diff --git a/tools/Align.hs b/tools/Align.hs new file mode 100644 --- /dev/null +++ b/tools/Align.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards #-} +{-# OPTIONS_GHC -Wall #-} + +module Align where + +import Bio.Base +import Bio.Bam +import Control.Applicative +import Control.Monad +import Control.Monad.ST (runST) +import Data.Bits +import Data.List (group) +import Data.Sequence ( (<|), (><), ViewL((:<)) ) + +import qualified Data.Foldable as F +import qualified Data.Sequence as Z +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Storable as S +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as UM + +data Base = A | C | G | T | None + deriving (Eq, Ord, Enum, Show) + +-- | For a reference sequence, we store five(!) probabilities for each +-- base in phred format. The fifth is the probability of a gap. + +newtype RefSeq = RS (U.Vector Word8) deriving Show + +refseq_len :: RefSeq -> Int +refseq_len (RS v) = U.length v `div` 5 + +prob_of :: Base -> Int -> RefSeq -> Word8 +prob_of b i (RS v) = indexV "prob_of" v ( 5*i + fromEnum b ) + +-- | Turns a sequence into probabilities. @Right n@ is an ordinary +-- 'Nucleotide', @Left n@ is one we think might be absent (e.g. because +-- it was soft masked in the input). +prep_reference :: [Either Nucleotides Nucleotides] -> RefSeq +prep_reference = RS . U.concat . map (either (to probG) (to probB)) + where + to ps n = U.slice (5 * fromIntegral (unNs n)) 5 ps + + -- XXX we should probably add some noise here, so the placement of + -- gaps isn't completely random, but merely unpredictable + probB = U.fromListN 80 $ concatMap (\l -> l ++ [255]) raw_probs + probG = U.fromListN 80 $ concatMap (\l -> map (+3) l ++ [3]) raw_probs + + raw_probs = [[ 25, 25, 25, 25 ] -- 0 + ,[ 0, 25, 25, 25 ] -- A + ,[ 25, 0, 25, 25 ] -- C + ,[ 3, 3, 25, 25 ] -- M + ,[ 25, 25, 0, 25 ] -- G + ,[ 3, 25, 3, 25 ] -- R + ,[ 25, 3, 3, 25 ] -- S + ,[ 5, 5, 5, 25 ] -- V + ,[ 25, 25, 25, 0 ] -- T + ,[ 3, 25, 25, 3 ] -- W + ,[ 25, 3, 25, 3 ] -- Y + ,[ 5, 5, 25, 5 ] -- H + ,[ 25, 25, 3, 3 ] -- K + ,[ 5, 25, 5, 5 ] -- D + ,[ 25, 5, 5, 5 ] -- B + ,[ 6, 6, 6, 6 ]] -- N + +-- | Encoding of the query: one word per position, the two lowest bits +-- encode the base, the rest is the quality score (shifted left by 2). +newtype QuerySeq = QS { unQS :: U.Vector Word8 } deriving Show + +-- | Prepare query for subsequent alignment to the forward strand. +prep_query_fwd :: BamRec -> QuerySeq +prep_query_fwd BamRec{..} = QS $ U.fromListN len $ zipWith pair (V.toList b_seq) (V.toList b_qual) + where + pair b (Q q) = q `shiftL` 2 .|. indexV "prep_query_fwd" code (fromIntegral $ unNs b) + code = U.fromListN 16 [0,0,1,0,2,0,0,0,3,0,0,0,0,0,0,0] + len = V.length b_seq + +prep_query_rev :: BamRec -> QuerySeq +prep_query_rev = revcompl_query . prep_query_fwd + where + revcompl_query (QS v) = QS $ U.map (xor 3) $ U.reverse v + +qseqToBamSeq :: QuerySeq -> Vector_Nucs_half Nucleotides +qseqToBamSeq = V.fromList . U.toList . U.map (\x -> Ns $ 1 `shiftL` fromIntegral (x .&. 3)) . unQS + +qseqToBamQual :: QuerySeq -> S.Vector Qual +qseqToBamQual = S.convert . U.map (Q . (`shiftR` 2)) . unQS + +-- | Memoization matrix for dynamic programming. We understand it as a +-- matrix B columns wide and L rows deep, where B is the bandwidth and L +-- the query length. Successive rows are understood to be skewed to the +-- right. (This means all operations need the bandwidth as an +-- argument.) + +newtype MemoMat = MemoMat (U.Vector Float) deriving Show +newtype Bandwidth = BW Int deriving Show +newtype RefPosn = RP Int deriving Show + +data AlignResult = AlignResult + { viterbi_forward :: MemoMat -- DP matrix from running Viterbi + , viterbi_score :: Float -- alignment score (log scale, vs. radom alignment) + , viterbi_position :: Int -- position (start of the most probable alignment) + , viterbi_backtrace :: S.Vector Cigar } -- backtrace (most probable alignment) + deriving Show + +data Traced = Tr { tr_op :: CigOp, tr_score :: Float } + +instance Eq Traced where Tr _ a == Tr _ b = a == b +instance Ord Traced where Tr _ a `compare` Tr _ b = a `compare` b + +-- | All sorts of alignment shit collected in one place, mostly so I can +-- reuse the scoring functions. +align :: Float -> RefSeq -> QuerySeq -> RefPosn -> Bandwidth -> AlignResult +align gp (RS rs) (QS qs) (RP p0) (BW bw_) = runST (do + let bw = abs bw_ + v <- UM.unsafeNew $ bw * U.length qs + bw + + let readV row col | row < 0 || col < 0 || col >= bw || row > U.length qs = error $ "Read from memo: " ++ show (row,col) + | ix < 0 || ix >= UM.length v = error $ "Read from memo: " ++ show ix + | otherwise = UM.read v ix + where ix = bw*row + col + + let score qpos _ | qpos < 0 || qpos >= U.length qs = error $ "Read from QS: " ++ show qpos + score qpos rpos = let base = (indexV "align/score/base" qs qpos) .&. 3 :: Word8 + qual = (indexV "align/score/qual" qs qpos) `shiftR` 2 :: Word8 + prob = let ix = 5*rpos + fromIntegral base in + if ix < 0 then error ("Huh? " ++ show ix) else + if ix < U.length rs then indexV "align/score/prob/A" rs ix else + if ix - U.length rs < U.length rs then indexV "align/score/prob/B" rs (ix - U.length rs) :: Word8 else + error ("Huh? " ++ show (ix,qpos,rpos,p0,base)) + + -- Improbability of a mismatch, it's the + -- probability of the reference not being + -- correct or the query not being correct, + -- whichever is higher. + mismatch = fromIntegral (min qual prob) + + -- Improbability of a random match. It's + -- 6 if we have a good base, corresponding + -- to randomness. If we have a bad base, + -- it's lower, because we aren't doing + -- better than random. + randmatch = fromIntegral (min qual 6) + + -- Score is our mismatch probability vs. + -- random sequences. Note that this ends + -- up being 0 for low quality bases, -6 + -- for high quality matches, and 30+ for + -- high quality mismatches. + in mismatch - randmatch + + let gscore rpos = let prob = let ix = 5*rpos + 4 in + if ix < 0 then error ("Huh? " ++ show ix) else + if ix < U.length rs then indexV "align/gscore/prob/A" rs ix else + if ix - U.length rs < U.length rs then indexV "align/gscore/prob/B" rs (ix - U.length rs) :: Word8 else + error ("Huh? " ++ show (ix,rpos,p0)) + in min gp $ fromIntegral prob + + let match row col = Tr Mat . (+ score (row-1) (p0+row+col-1)) <$> readV (row-1) (col+0) + let gapH row col = Tr Del . (+ gscore (p0+row+col-1)) <$> readV (row+0) (col-1) + let gapV row col = Tr Ins . (+ gp) <$> readV (row-1) (col+1) + + let cell row col = do x <- if row == 0 then return (Tr Nop 0) else match row col + y <- if col == 0 then return x else min x <$> gapH row col + z <- if row == 0 || col == bw-1 then return y else min y <$> gapV row col + return z + + -- Fill the DP matrix. XXX: there's got to be way to express this + -- using 'Vector's bulk operations. Would that be more readable? + -- Faster? + forM_ [0 .. U.length qs] $ \row -> + forM_ [0 .. bw-1] $ \col -> + UM.write v (bw*row + col) . tr_score =<< cell row col + + let pack_cigar = S.fromList . map (\x -> head x :* length x) . group + let traceback acc row col = do op <- tr_op <$> cell row col + case op of Mat -> traceback (Mat:acc) (row-1) (col+0) + Ins -> traceback (Ins:acc) (row-1) (col+1) + Del -> traceback (Del:acc) (row+0) (col-1) + Nop | row == 0 -> return (p0+col, pack_cigar acc) + + viterbi_forward <- MemoMat <$> U.unsafeFreeze v + (viterbi_score, mincol) <- minimum . flip zip [0..] <$> mapM (readV (U.length qs)) [0..bw-1] + (viterbi_position, viterbi_backtrace) <- traceback [] (U.length qs) mincol + return $ AlignResult{..}) + +-- For each position, a vector of pseudocounts in the same order as in +-- 'RefSeq', followed by the same for based inserted after the current +-- one. +newtype NewRefSeq = NRS (Z.Seq NewColumn) + +-- Inserts come (conceptually) before the base whose coordinate they +-- bear. So every column has inserts first, then the single aligned +-- base. +data NewColumn = NC { nc_inserts :: !(U.Vector Float) + , nc_base :: !(U.Vector Float) } + +new_ref_seq :: RefSeq -> NewRefSeq +new_ref_seq rs = NRS $ Z.replicate (refseq_len rs) (NC (U.replicate 0 0) (U.replicate 5 0)) + +mkNC :: U.Vector Float -> U.Vector Float -> NewColumn +mkNC !i !b | U.length b /= 5 = error "mkNC" + | otherwise = NC i b + +-- Add an alignment to the new reference. We compute the quality of the +-- alignment (probability that it belongs vs. probability that it's +-- random), that's how many votes we're going to cast. (A perfect +-- alignment gives a whole vote, a random one gives none. Call this +-- with an alignment that's worse than random at your own peril.) +-- If we're voting for a base, we vote for the called one according to +-- its quality and for all others with the error probability. +-- A deletion is a vote against all bases, an insert is a vote for how +-- ever many bases. The first five values sum up to the total votes so +-- far, and they all count as votes against any further extension to an +-- insert. We start with five pseudo-votes to get the numerics under +-- control (or to have a uniform Dirichlet-prior, if you prefer). +-- +-- Note that this logic was arrived at by "thinking hard". A clean way +-- to do it is to maximize the alignment score expected in the next +-- round, assuming the alignments do not change. It might work out to +-- the same thing... who knows? + +add_to_refseq :: NewRefSeq -> QuerySeq -> AlignResult -> NewRefSeq +add_to_refseq (NRS nrs0) (QS qs0) AlignResult{..} = + NRS $ rotateZ (Z.length nrs0 - viterbi_position) + $ mat here back qs0 $ S.toList viterbi_backtrace + where + here :< back = Z.viewl $ rotateZ viterbi_position nrs0 + rotateZ n = uncurry (flip (><)) . Z.splitAt n + + !odds = 10 ** (-viterbi_score / 10) -- often huge, + !votes = 1 - recip (1+odds) -- often exactly 1 + + -- Grrr, this isn't going to work. We'll split it: + -- One function deals with inserts. As long as we get inserted + -- bases, we vote for them. Then we vote against the remainder and + -- pass the buck. + -- The other deals with a base. We vote for it if we matched it, + -- against it if we deleted it. Then we recurse. + ins !nc@(NC is b) !nrs !nins !qs cigs = case cigs of + [ ] -> nc <| nrs + ( _ :* 0 :cs) -> ins nc nrs nins qs cs + + (Ins :* n :cs) -> let is' = vote_for_at votes (U.sum b) nins (U.head qs) is + in ins (mkNC is' b) nrs (nins+1) (U.tail qs) (Ins :* (n-1) : cs) + + _ -> let is' = vote_against_from votes nins is + in mat (mkNC is' b) nrs qs cigs + + mat !nc@(NC is b) !nrs !qs cigs = case cigs of + [ ] -> nc <| nrs + ( _ :* 0 :cs) -> mat nc nrs qs cs + + (Del :* n :cs) -> let nc2 :< rest = Z.viewl nrs + b' = vote_against votes b + in mkNC is b' let nc2 :< rest = Z.viewl nrs + b' = vote_for votes (U.head qs) b + in mkNC is b' ins nc nrs (0::Int) qs cigs + + ( Int -> U.Vector Float -> U.Vector Float +-- vote_against_from votes ix ps | trace ("vote_against_from " ++ show (ix, U.length ps)) False = undefined +vote_against_from votes ix ps = U.accum (+) ps [(i,votes) | i <- [ix+4, ix+9 .. U.length ps-1]] + +vote_against :: Float -> U.Vector Float -> U.Vector Float +-- vote_against votes ps | trace ("vote_against " ++ show (U.length ps)) False = undefined +vote_against votes ps = U.accum (+) ps [(4,votes)] + +vote_for :: Float -> Word8 -> U.Vector Float -> U.Vector Float +vote_for votes = vote_for_at votes 0 0 + +vote_for_at :: Float -> Float -> Int -> Word8 -> U.Vector Float -> U.Vector Float +vote_for_at votes v0 idx bq ps = + U.accum (+) ps' $ (base+5*idx,pt) : [(5*idx+i,pe)|i<-[0,1,2,3]] + where + base = fromIntegral $ bq .&. 3 + qual = bq `shiftR` 2 + perr = 10 ** (fromIntegral qual * (-0.1)) + pe = votes * perr / 3 + pt = votes * (1 - perr) - pe + + ps' | U.length ps >= 5*idx+5 = ps + | otherwise = U.concat (ps : replicate (idx+1 - U.length ps `div` 5) (U.fromList [0,0,0,0,v0])) + + +-- Back to compact representation. Every group of five votes gets +-- converted to five probabilities, and those to quality scores. Then +-- we concatenate. +finalize_ref_seq :: NewRefSeq -> (RefSeq, XTab) +finalize_ref_seq (NRS z) = + ( RS $ U.concat $ F.foldr unpack [] z + , Z.fromList $ scanl (+) 0 $ F.foldr tolen [] z) + where + unpack (NC ins bas) k = map5 call ins ++ call bas : k + map5 f v = [ f (U.slice i 5 v) | i <- [0, 5 .. U.length v - 5] ] + call v = U.map (\x -> round $ (-10) / log 10 * log ((x+1) / total)) v where total = U.sum v + 5 + + tolen (NC ins _bas) k = U.length ins `div` 5 + 1 : k + +-- Table for coordinate translation +type XTab = Z.Seq Int + + +{-# INLINE indexV #-} +indexV :: String -> U.Vector Word8 -> Int -> Word8 +-- indexV m v i | i < 0 = error $ m ++ ": index too large" + -- | i >= U.length v = error $ m ++ ": negative index" + -- | otherwise = v U.! i +indexV _ = (U.!) diff --git a/tools/Anno.hs b/tools/Anno.hs new file mode 100644 --- /dev/null +++ b/tools/Anno.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wall #-} +module Anno where + +import Data.List + +-- What does this header mean? +-- >Feature ref|NC_012920.1| + +to_tab :: String -> [Anno] -> [String] +to_tab nm ann = (">Feature " ++ nm) : (map (intercalate "\t") $ concatMap to_tab1 ann) + where + to_tab1 :: Anno -> [[String]] + to_tab1 Gene{..} = + [ show start, show end, label what name ] : + ( if has_gene what then [[ "", "", "", "gene", name ]] else [] ) ++ + [ [ "", "", "", "gene_syn", sy ] | sy <- syns ] ++ + [ [ show start, show end, w ] | w <- describe what ] ++ + [ [ "", "", "", "product", p ] | p <- [prod], not (null p) ] ++ + [ [ "", "", "", "note", n ] | n <- notes ] ++ + more what + + describe CDS = ["CDS"] + describe CDS' = ["CDS"] + describe TRNA = ["tRNA"] + describe RRNA = ["rRNA"] + describe _ = [] + + has_gene (STS _) = False + has_gene Other = False + has_gene _ = True + + label (STS _) _ = "STS" + label Other n = n + label _ _ = "gene" + + more CDS' = [ [ "", "", "", "note", "TAA stop codon is completed by the addition of 3' A residues to the mRNA" ] ] + more (STS sn) = [ [ "", "", "", "standard_name", sn ] ] + more _ = [] + +data Anno + = Gene { start :: Int + , end :: Int + , name :: String + , syns :: [String] + , what :: What + , prod :: String + , notes :: [String] } + deriving Show + +data What = CDS | CDS' | TRNA | RRNA | Other | STS String deriving Show + +rCRS_anno :: [Anno] +rCRS_anno = + [ Gene 576 1 "D-loop" [] Other "" [] + , Gene 16569 16024 "" [] Other "" [] + , Gene 577 647 "TRNF" [] TRNA "tRNA-Phe" [] + , Gene 648 1601 "RNR1" ["MTRNR1"] RRNA "s-rRNA" ["12S rRNA; 12S ribosomal RNA"] + , Gene 1602 1670 "TRNV" [] TRNA "tRNA-Val" [] + , Gene 1671 3229 "RNR2" [] RRNA "l-rRNA" ["16S ribosomal RNA; 16S rRNA"] + , Gene 3230 3304 "TRNL1" ["MTTL1"] TRNA "tRNA-Leu" [] + , Gene 3307 4262 "ND1" [] CDS' "NADH dehydrogenase subunit 1" [] + + , Gene 4263 4331 "TRNI" [] TRNA "tRNA-Ile" [] + , Gene 4400 4329 "TRNQ" [] TRNA "tRNA-Gln" [] + , Gene 4402 4469 "TRNM" [] TRNA "tRNA-Met" [] + , Gene 4470 5511 "ND2" [] CDS' "NADH dehydrogenase subunit 2" [] + , Gene 5512 5579 "TRNW" [] TRNA "tRNA-Trp" [] + , Gene 5655 5587 "TRNA" [] TRNA "tRNA-Ala" [] + , Gene 5729 5657 "TRNN" [] TRNA "tRNA-Asn" [] + , Gene 5826 5761 "TRNC" [] TRNA "tRNA-Cys" [] + , Gene 5891 5826 "TRNY" [] TRNA "tRNA-Tyr" [] + , Gene 5904 7445 "COX1" ["COI"] CDS "cytochrome c oxidase subunit I" ["cytochrome c oxidase I"] + , Gene 7514 7446 "TRNS1" [] TRNA "tRNA-Ser" [] + , Gene 7518 7585 "TRND" [] TRNA "tRNA-Asp" [] + , Gene 7586 8269 "COX2" [] CDS "cytochrome c oxidase subunit II" ["cytochrome c oxidase II"] + , Gene 8295 8364 "TRNK" [] TRNA "tRNA-Lys" [] + , Gene 8366 8572 "ATP8" [] CDS "ATP synthase F0 subunit 8" ["ATP synthase 8; ATPase subunit 8"] + , Gene 8527 9207 "ATP6" [] CDS "ATP synthase F0 subunit 6" ["ATP synthase 6; ATPase subunit 6"] + , Gene 9207 9990 "COX3" [] CDS' "cytochrome c oxidase subunit III" [] + , Gene 9342 9416 "" [] (STS "PMC55343P8") "" [] + , Gene 9991 10058 "TRNG" [] TRNA "tRNA-Gly" [] + , Gene 10059 10404 "ND3" [] CDS' "NADH dehydrogenase subunit 3" [] + , Gene 10405 10469 "TRNR" [] TRNA "tRNA-Arg" [] + , Gene 10470 10766 "ND4L" [] CDS "NADH dehydrogenase subunit 4L" [] + , Gene 10760 12137 "ND4" [] CDS' "NADH dehydrogenase subunit 4" [] + , Gene 12138 12206 "TRNH" [] TRNA "tRNA-His" [] + , Gene 12207 12265 "TRNS2" [] TRNA "tRNA-Ser" [] + , Gene 12266 12336 "TRNL2" [] TRNA "tRNA-Leu" [] + , Gene 12337 14148 "ND5" [] CDS "NADH dehydrogenase subunit 5" [] + , Gene 14673 14149 "ND6" [] CDS "NADH dehydrogenase subunit 6" [] + , Gene 14742 14674 "TRNE" [] TRNA "tRNA-Glu" [] + , Gene 14747 15887 "CYTB" [] CDS' "cytochrome b" [] + , Gene 15888 15953 "TRNT" [] TRNA "tRNA-Thr" [] + , Gene 16023 15956 "TRNP" [] TRNA "tRNA-Pro" [] ] + +aas :: [(String, String)] +aas = [ + (,) "ND1" + "MPMANLLLLIVPILIAMAFLMLTERKILGYMQLRKGPNVVGPYG\ + \LLQPFADAMKLFTKEPLKPATSTITLYITAPTLALTIALLLWTPLPMPNPLVNLNLGL\ + \LFILATSSLAVYSILWSGWASNSNYALIGALRAVAQTISYEVTLAIILLSTLLMSGSF\ + \NLSTLITTQEHLWLLLPSWPLAMMWFISTLAETNRTPFDLAEGESELVSGFNIEYAAG\ + \PFALFFMAEYTNIIMMNTLTTTIFLGTTYDALSPELYTTYFVTKTLLLTSLFLWIRTA\ + \YPRFRYDQLMHLLWKNFLPLTLALLMWYVSMPITISSIPPQT", + (,) "ND2" + "MNPLAQPVIYSTIFAGTLITALSSHWFFTWVGLEMNMLAFIPVL\ + \TKKMNPRSTEAAIKYFLTQATASMILLMAILFNNMLSGQWTMTNTTNQYSSLMIMMAM\ + \AMKLGMAPFHFWVPEVTQGTPLTSGLLLLTWQKLAPISIMYQISPSLNVSLLLTLSIL\ + \SIMAGSWGGLNQTQLRKILAYSSITHMGWMMAVLPYNPNMTILNLTIYIILTTTAFLL\ + \LNLNSSTTTLLLSRTWNKLTWLTPLIPSTLLSLGGLPPLTGFLPKWAIIEEFTKNNSL\ + \IIPTIMATITLLNLYFYLRLIYSTSITLLPMSNNVKMKWQFEHTKPTPFLPTLIALTT\ + \LLLPISPFMLMIL", + (,) "COX1" + "MFADRWLFSTNHKDIGTLYLLFGAWAGVLGTALSLLIRAELGQP\ + \GNLLGNDHIYNVIVTAHAFVMIFFMVMPIMIGGFGNWLVPLMIGAPDMAFPRMNNMSF\ + \WLLPPSLLLLLASAMVEAGAGTGWTVYPPLAGNYSHPGASVDLTIFSLHLAGVSSILG\ + \AINFITTIINMKPPAMTQYQTPLFVWSVLITAVLLLLSLPVLAAGITMLLTDRNLNTT\ + \FFDPAGGGDPILYQHLFWFFGHPEVYILILPGFGMISHIVTYYSGKKEPFGYMGMVWA\ + \MMSIGFLGFIVWAHHMFTVGMDVDTRAYFTSATMIIAIPTGVKVFSWLATLHGSNMKW\ + \SAAVLWALGFIFLFTVGGLTGIVLANSSLDIVLHDTYYVVAHFHYVLSMGAVFAIMGG\ + \FIHWFPLFSGYTLDQTYAKIHFTIMFIGVNLTFFPQHFLGLSGMPRRYSDYPDAYTTW\ + \NILSSVGSFISLTAVMLMIFMIWEAFASKRKVLMVEEPSMNLEWLYGCPPPYHTFEEP\ + \VYMKS", + (,) "COX2" + "MAHAAQVGLQDATSPIMEELITFHDHALMIIFLICFLVLYALFL\ + \TLTTKLTNTNISDAQEMETVWTILPAIILVLIALPSLRILYMTDEVNDPSLTIKSIGH\ + \QWYWTYEYTDYGGLIFNSYMLPPLFLEPGDLRLLDVDNRVVLPIEAPIRMMITSQDVL\ + \HSWAVPTLGLKTDAIPGRLNQTTFTATRPGVYYGQCSEICGANHSFMPIVLELIPLKI\ + \FEMGPVFTL", + (,) "ATP8" + "MPQLNTTVWPTMITPMLLTLFLITQLKMLNTNYHLPPSPKPMKM\ + \KNYNKPWEPKWTKICSLHSLPPQS", + (,) "ATP6" + "MNENLFASFIAPTILGLPAAVLIILFPPLLIPTSKYLINNRLIT\ + \TQQWLIKLTSKQMMTMHNTKGRTWSLMLVSLIIFIATTNLLGLLPHSFTPTTQLSMNL\ + \AMAIPLWAGTVIMGFRSKIKNALAHFLPQGTPTPLIPMLVIIETISLLIQPMALAVRL\ + \TANITAGHLLMHLIGSATLAMSTINLPSTLIIFTILILLTILEIAVALIQAYVFTLLV\ + \SLYLHDNT", + (,) "COX3" + "MTHQSHAYHMVKPSPWPLTGALSALLMTSGLAMWFHFHSMTLLM\ + \LGLLTNTLTMYQWWRDVTRESTYQGHHTPPVQKGLRYGMILFITSEVFFFAGFFWAFY\ + \HSSLAPTPQLGGHWPPTGITPLNPLEVPLLNTSVLLASGVSITWAHHSLMENNRNQMI\ + \QALLITILLGLYFTLLQASEYFESPFTISDGIYGSTFFVATGFHGLHVIIGSTFLTIC\ + \FIRQLMFHFTSKHHFGFEAAAWYWHFVDVVWLFLYVSIYWWGS", + (,) "ND3" + "MNFALILMINTLLALLLMIITFWLPQLNGYMEKSTPYECGFDPM\ + \SPARVPFSMKFFLVAITFLLFDLEIALLLPLPWALQTTNLPLMVMSSLLLIIILALSL\ + \AYEWLQKGLDWTE", + (,) "ND4L" + "MPLIYMNIMLAFTISLLGMLVYRSHLMSSLLCLEGMMLSLFIMA\ + \TLMTLNTHSLLANIVPIAMLVFAACEAAVGLALLVSISNTYGLDYVHNLNLLQC", + (,) "ND4" + "MLKLIVPTIMLLPLTWLSKKHMIWINTTTHSLIISIIPLLFFNQ\ + \INNNLFSCSPTFSSDPLTTPLLMLTTWLLPLTIMASQRHLSSEPLSRKKLYLSMLISL\ + \QISLIMTFTATELIMFYIFFETTLIPTLAIITRWGNQPERLNAGTYFLFYTLVGSLPL\ + \LIALIYTHNTLGSLNILLLTLTAQELSNSWANNLMWLAYTMAFMVKMPLYGLHLWLPK\ + \AHVEAPIAGSMVLAAVLLKLGGYGMMRLTLILNPLTKHMAYPFLVLSLWGMIMTSSIC\ + \LRQTDLKSLIAYSSISHMALVVTAILIQTPWSFTGAVILMIAHGLTSSLLFCLANSNY\ + \ERTHSRIMILSQGLQTLLPLMAFWWLLASLANLALPPTINLLGELSVLVTTFSWSNIT\ + \LLLTGLNMLVTALYSLYMFTTTQWGSLTHHINNMKPSFTRENTLMFMHLSPILLLSLN\ + \PDIITGFSS", + (,) "ND5" + "MTMHTTMTTLTLTSLIPPILTTLVNPNKKNSYPHYVKSIVASTF\ + \IISLFPTTMFMCLDQEVIISNWHWATTQTTQLSLSFKLDYFSMMFIPVALFVTWSIME\ + \FSLWYMNSDPNINQFFKYLLIFLITMLILVTANNLFQLFIGWEGVGIMSFLLISWWYA\ + \RADANTAAIQAILYNRIGDIGFILALAWFILHSNSWDPQQMALLNANPSLTPLLGLLL\ + \AAAGKSAQLGLHPWLPSAMEGPTPVSALLHSSTMVVAGIFLLIRFHPLAENSPLIQTL\ + \TLCLGAITTLFAAVCALTQNDIKKIVAFSTSSQLGLMMVTIGINQPHLAFLHICTHAF\ + \FKAMLFMCSGSIIHNLNNEQDIRKMGGLLKTMPLTSTSLTIGSLALAGMPFLTGFYSK\ + \DHIIETANMSYTNAWALSITLIATSLTSAYSTRMILLTLTGQPRFPTLTNINENNPTL\ + \LNPIKRLAAGSLFAGFLITNNISPASPFQTTIPLYLKLTALAVTFLGLLTALDLNYLT\ + \NKLKMKSPLCTFYFSNMLGFYPSITHRTIPYLGLLTSQNLPLLLLDLTWLEKLLPKTI\ + \SQHQISTSIITSTQKGMIKLYFLSFFFPLILTLLLIT", + (,) "ND6" + "MMYALFLLSVGLVMGFVGFSSKPSPIYGGLVLIVSGVVGCVIIL\ + \NFGGGYMGLMVFLIYLGGMMVVFGYTTAMAIEEYPEAWGSGVEVLVSVLVGLAMEVGL\ + \VLWVKEYDGVVVVVNFNSVGSWMIYEGEGSGLIREDPIGAGALYDYGRWLVVVTGWTL\ + \FVGVYIVIEIARGN", + (,) "CYTB" + "MTPMRKTNPLMKLINHSFIDLPTPSNISAWWNFGSLLGACLILQ\ + \ITTGLFLAMHYSPDASTAFSSIAHITRDVNYGWIIRYLHANGASMFFICLFLHIGRGL\ + \YYGSFLYSETWNIGIILLLATMATAFMGYVLPWGQMSFWGATVITNLLSAIPYIGTDL\ + \VQWIWGGYSVDSPTLTRFFTFHFILPFIIAALATLHLLFLHETGSNNPLGITSHSDKI\ + \TFHPYYTIKDALGLLLFLLSLMTLTLFSPDLLGDPDNYTLANPLNTPPHIKPEWYFLF\ + \AYTILRSVPNKLGGVLALLLSILILAMIPILHMSKQQSMMFRPLSQSLYWLLAADLLI\ + \LTWIGGQPVSYPFTIIGQVASVLYFTTILILMPTISLIENKMLKWA" ] diff --git a/tools/Index.hs b/tools/Index.hs new file mode 100644 --- /dev/null +++ b/tools/Index.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies #-} +module Index where + +-- ^ This tiny module defines the 'Index' type and derives the 'Unbox' +-- instance. That dramatically lowers the chance that template haskell +-- runs into problems :( + +import Data.Bits +import Data.Char ( chr ) +import Data.Hashable +import Data.Vector.Unboxed.Deriving +import Data.Word ( Word64 ) +import Foreign.Storable ( Storable ) +import Data.Vector.Generic ( Vector(..) ) +import Data.Vector.Generic.Mutable ( MVector(..) ) + +-- | An index sequence must have at most eight bases. We represent a +-- base and its quality score in a single byte: the top three bits are +-- the base ("ACGTN" = [0,1,3,2,7]), the lower five bits are the quality, +-- clamped to 31. + +newtype Index = Index Word64 deriving (Storable, Eq) + +instance Hashable Index where + hashWithSalt salt (Index x) = hashWithSalt salt x + hash (Index x) = hash x + +instance Show Index where + show (Index x) = [ "ACTGNNNN" !! fromIntegral b | i <- [56,48..0], let b = (x `shiftR` (i+5)) .&. 0x7 ] + ++ 'q' : [ chr (fromIntegral q+33) | i <- [56,48..0], let q = (x `shiftR` i) .&. 0x1F ] + +derivingUnbox "Index" [t| Index -> Word64 |] [| \ (Index i) -> i |] [| Index |] + + diff --git a/tools/Seqs.hs b/tools/Seqs.hs new file mode 100644 --- /dev/null +++ b/tools/Seqs.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +module Seqs where + +import Data.ByteString.Char8 (ByteString) + +raw_rCRS :: ByteString +raw_rCRS = + "GATCACAGGTCTATCACCCTATTAACCACTCACGGGAGCTCTCCATGCATTTGGTATTTTCGTCTGGGGGGTATGCACGCGATAGCATTGCGAGACGCTG\ + \GAGCCGGAGCACCCTATGTCGCAGTATCTGTCTTTGATTCCTGCCTCATCCTATTATTTATCGCACCTACGTTCAATATTACAGGCGAACATACTTACTA\ + \AAGTGTGTTAATTAATTAATGCTTGTAGGACATAATAATAACAATTGAATGTCTGCACAGCCACTTTCCACACAGACATCATAACAAAAAATTTCCACCA\ + \AACCCCCCCTCCCCCGCTTCTGGCCACAGCACTTAAACACATCTCTGCCAAACCCCAAAAACAAAGAACCCTAACACCAGCCTAACCAGATTTCAAATTT\ + \TATCTTTTGGCGGTATGCACTTTTAACAGTCACCCCCCAACTAACACATTATTTTCCCCTCCCACTCCCATACTACTAATCTCATCAATACAACCCCCGC\ + \CCATCCTACCCAGCACACACACACCGCTGCTAACCCCATACCCCGAACCAACCAAACCCCAAAGACACCCCCCACAGTTTATGTAGCTTACCTCCTCAAA\ + \GCAATACACTGAAAATGTTTAGACGGGCTCACATCACCCCATAAACAAATAGGTTTGGTCCTAGCCTTTCTATTAGCTCTTAGTAAGATTACACATGCAA\ + \GCATCCCCGTTCCAGTGAGTTCACCCTCTAAATCACCACGATCAAAAGGAACAAGCATCAAGCACGCAGCAATGCAGCTCAAAACGCTTAGCCTAGCCAC\ + \ACCCCCACGGGAAACAGCAGTGATTAACCTTTAGCAATAAACGAAAGTTTAACTAAGCTATACTAACCCCAGGGTTGGTCAATTTCGTGCCAGCCACCGC\ + \GGTCACACGATTAACCCAAGTCAATAGAAGCCGGCGTAAAGAGTGTTTTAGATCACCCCCTCCCCAATAAAGCTAAAACTCACCTGAGTTGTAAAAAACT\ + \CCAGTTGACACAAAATAGACTACGAAAGTGGCTTTAACATATCTGAACACACAATAGCTAAGACCCAAACTGGGATTAGATACCCCACTATGCTTAGCCC\ + \TAAACCTCAACAGTTAAATCAACAAAACTGCTCGCCAGAACACTACGAGCCACAGCTTAAAACTCAAAGGACCTGGCGGTGCTTCATATCCCTCTAGAGG\ + \AGCCTGTTCTGTAATCGATAAACCCCGATCAACCTCACCACCTCTTGCTCAGCCTATATACCGCCATCTTCAGCAAACCCTGATGAAGGCTACAAAGTAA\ + \GCGCAAGTACCCACGTAAAGACGTTAGGTCAAGGTGTAGCCCATGAGGTGGCAAGAAATGGGCTACATTTTCTACCCCAGAAAACTACGATAGCCCTTAT\ + \GAAACTTAAGGGTCGAAGGTGGATTTAGCAGTAAACTAAGAGTAGAGTGCTTAGTTGAACAGGGCCCTGAAGCGCGTACACACCGCCCGTCACCCTCCTC\ + \AAGTATACTTCAAAGGACATTTAACTAAAACCCCTACGCATTTATATAGAGGAGACAAGTCGTAACATGGTAAGTGTACTGGAAAGTGCACTTGGACGAA\ + \CCAGAGTGTAGCTTAACACAAAGCACCCAACTTACACTTAGGAGATTTCAACTTAACTTGACCGCTCTGAGCTAAACCTAGCCCCAAACCCACTCCACCT\ + \TACTACCAGACAACCTTAGCCAAACCATTTACCCAAATAAAGTATAGGCGATAGAAATTGAAACCTGGCGCAATAGATATAGTACCGCAAGGGAAAGATG\ + \AAAAATTATAACCAAGCATAATATAGCAAGGACTAACCCCTATACCTTCTGCATAATGAATTAACTAGAAATAACTTTGCAAGGAGAGCCAAAGCTAAGA\ + \CCCCCGAAACCAGACGAGCTACCTAAGAACAGCTAAAAGAGCACACCCGTCTATGTAGCAAAATAGTGGGAAGATTTATAGGTAGAGGCGACAAACCTAC\ + \CGAGCCTGGTGATAGCTGGTTGTCCAAGATAGAATCTTAGTTCAACTTTAAATTTGCCCACAGAACCCTCTAAATCCCCTTGTAAATTTAACTGTTAGTC\ + \CAAAGAGGAACAGCTCTTTGGACACTAGGAAAAAACCTTGTAGAGAGAGTAAAAAATTTAACACCCATAGTAGGCCTAAAAGCAGCCACCAATTAAGAAA\ + \GCGTTCAAGCTCAACACCCACTACCTAAAAAATCCCAAACATATAACTGAACTCCTCACACCCAATTGGACCAATCTATCACCCTATAGAAGAACTAATG\ + \TTAGTATAAGTAACATGAAAACATTCTCCTCCGCATAAGCCTGCGTCAGATTAAAACACTGAACTGACAATTAACAGCCCAATATCTACAATCAACCAAC\ + \AAGTCATTATTACCCTCACTGTCAACCCAACACAGGCATGCTCATAAGGAAAGGTTAAAAAAAGTAAAAGGAACTCGGCAAATCTTACCCCGCCTGTTTA\ + \CCAAAAACATCACCTCTAGCATCACCAGTATTAGAGGCACCGCCTGCCCAGTGACACATGTTTAACGGCCGCGGTACCCTAACCGTGCAAAGGTAGCATA\ + \ATCACTTGTTCCTTAAATAGGGACCTGTATGAATGGCTCCACGAGGGTTCAGCTGTCTCTTACTTTTAACCAGTGAAATTGACCTGCCCGTGAAGAGGCG\ + \GGCATAACACAGCAAGACGAGAAGACCCTATGGAGCTTTAATTTATTAATGCAAACAGTACCTAACAAACCCACAGGTCCTAAACTACCAAACCTGCATT\ + \AAAAATTTCGGTTGGGGCGACCTCGGAGCAGAACCCAACCTCCGAGCAGTACATGCTAAGACTTCACCAGTCAAAGCGAACTACTATACTCAATTGATCC\ + \AATAACTTGACCAACGGAACAAGTTACCCTAGGGATAACAGCGCAATCCTATTCTAGAGTCCATATCAACAATAGGGTTTACGACCTCGATGTTGGATCA\ + \GGACATCCCGATGGTGCAGCCGCTATTAAAGGTTCGTTTGTTCAACGATTAAAGTCCTACGTGATCTGAGTTCAGACCGGAGTAATCCAGGTCGGTTTCT\ + \ATCTACNTTCAAATTCCTCCCTGTACGAAAGGACAAGAGAAATAAGGCCTACTTCACAAAGCGCCTTCCCCCGTAAATGATATCATCTCAACTTAGTATT\ + \ATACCCACACCCACCCAAGAACAGGGTTTGTTAAGATGGCAGAGCCCGGTAATCGCATAAAACTTAAAACTTTACAGTCAGAGGTTCAATTCCTCTTCTT\ + \AACAACATACCCATGGCCAACCTCCTACTCCTCATTGTACCCATTCTAATCGCAATGGCATTCCTAATGCTTACCGAACGAAAAATTCTAGGCTATATAC\ + \AACTACGCAAAGGCCCCAACGTTGTAGGCCCCTACGGGCTACTACAACCCTTCGCTGACGCCATAAAACTCTTCACCAAAGAGCCCCTAAAACCCGCCAC\ + \ATCTACCATCACCCTCTACATCACCGCCCCGACCTTAGCTCTCACCATCGCTCTTCTACTATGAACCCCCCTCCCCATACCCAACCCCCTGGTCAACCTC\ + \AACCTAGGCCTCCTATTTATTCTAGCCACCTCTAGCCTAGCCGTTTACTCAATCCTCTGATCAGGGTGAGCATCAAACTCAAACTACGCCCTGATCGGCG\ + \CACTGCGAGCAGTAGCCCAAACAATCTCATATGAAGTCACCCTAGCCATCATTCTACTATCAACATTACTAATAAGTGGCTCCTTTAACCTCTCCACCCT\ + \TATCACAACACAAGAACACCTCTGATTACTCCTGCCATCATGACCCTTGGCCATAATATGATTTATCTCCACACTAGCAGAGACCAACCGAACCCCCTTC\ + \GACCTTGCCGAAGGGGAGTCCGAACTAGTCTCAGGCTTCAACATCGAATACGCCGCAGGCCCCTTCGCCCTATTCTTCATAGCCGAATACACAAACATTA\ + \TTATAATAAACACCCTCACCACTACAATCTTCCTAGGAACAACATATGACGCACTCTCCCCTGAACTCTACACAACATATTTTGTCACCAAGACCCTACT\ + \TCTAACCTCCCTGTTCTTATGAATTCGAACAGCATACCCCCGATTCCGCTACGACCAACTCATACACCTCCTATGAAAAAACTTCCTACCACTCACCCTA\ + \GCATTACTTATATGATATGTCTCCATACCCATTACAATCTCCAGCATTCCCCCTCAAACCTAAGAAATATGTCTGATAAAAGAGTTACTTTGATAGAGTA\ + \AATAATAGGAGCTTAAACCCCCTTATTTCTAGGACTATGAGAATCGAACCCATCCCTGAGAATCCAAAATTCTCCGTGCCACCTATCACACCCCATCCTA\ + \AAGTAAGGTCAGCTAAATAAGCTATCGGGCCCATACCCCGAAAATGTTGGTTATACCCTTCCCGTACTAATTAATCCCCTGGCCCAACCCGTCATCTACT\ + \CTACCATCTTTGCAGGCACACTCATCACAGCGCTAAGCTCGCACTGATTTTTTACCTGAGTAGGCCTAGAAATAAACATGCTAGCTTTTATTCCAGTTCT\ + \AACCAAAAAAATAAACCCTCGTTCCACAGAAGCTGCCATCAAGTATTTCCTCACGCAAGCAACCGCATCCATAATCCTTCTAATAGCTATCCTCTTCAAC\ + \AATATACTCTCCGGACAATGAACCATAACCAATACTACCAATCAATACTCATCATTAATAATCATAATAGCTATAGCAATAAAACTAGGAATAGCCCCCT\ + \TTCACTTCTGAGTCCCAGAGGTTACCCAAGGCACCCCTCTGACATCCGGCCTGCTTCTTCTCACATGACAAAAACTAGCCCCCATCTCAATCATATACCA\ + \AATCTCTCCCTCACTAAACGTAAGCCTTCTCCTCACTCTCTCAATCTTATCCATCATAGCAGGCAGTTGAGGTGGATTAAACCAAACCCAGCTACGCAAA\ + \ATCTTAGCATACTCCTCAATTACCCACATAGGATGAATAATAGCAGTTCTACCGTACAACCCTAACATAACCATTCTTAATTTAACTATTTATATTATCC\ + \TAACTACTACCGCATTCCTACTACTCAACTTAAACTCCAGCACCACGACCCTACTACTATCTCGCACCTGAAACAAGCTAACATGACTAACACCCTTAAT\ + \TCCATCCACCCTCCTCTCCCTAGGAGGCCTGCCCCCGCTAACCGGCTTTTTGCCCAAATGGGCCATTATCGAAGAATTCACAAAAAACAATAGCCTCATC\ + \ATCCCCACCATCATAGCCACCATCACCCTCCTTAACCTCTACTTCTACCTACGCCTAATCTACTCCACCTCAATCACACTACTCCCCATATCTAACAACG\ + \TAAAAATAAAATGACAGTTTGAACATACAAAACCCACCCCATTCCTCCCCACACTCATCGCCCTTACCACGCTACTCCTACCTATCTCCCCTTTTATACT\ + \AATAATCTTATAGAAATTTAGGTTAAATACAGACCAAGAGCCTTCAAAGCCCTCAGTAAGTTGCAATACTTAATTTCTGTAACAGCTAAGGACTGCAAAA\ + \CCCCACTCTGCATCAACTGAACGCAAATCAGCCACTTTAATTAAGCTAAGCCCTTACTAGACCAATGGGACTTAAACCCACAAACACTTAGTTAACAGCT\ + \AAGCACCCTAATCAACTGGCTTCAATCTACTTCTCCCGCCGCCGGGAAAAAAGGCGGGAGAAGCCCCGGCAGGTTTGAAGCTGCTTCTTCGAATTTGCAA\ + \TTCAATATGAAAATCACCTCGGAGCTGGTAAAAAGAGGCCTAACCCCTGTCTTTAGATTTACAGTCCAATGCTTCACTCAGCCATTTTACCTCACCCCCA\ + \CTGATGTTCGCCGACCGTTGACTATTCTCTACAAACCACAAAGACATTGGAACACTATACCTATTATTCGGCGCATGAGCTGGAGTCCTAGGCACAGCTC\ + \TAAGCCTCCTTATTCGAGCCGAGCTGGGCCAGCCAGGCAACCTTCTAGGTAACGACCACATCTACAACGTTATCGTCACAGCCCATGCATTTGTAATAAT\ + \CTTCTTCATAGTAATACCCATCATAATCGGAGGCTTTGGCAACTGACTAGTTCCCCTAATAATCGGTGCCCCCGATATGGCGTTTCCCCGCATAAACAAC\ + \ATAAGCTTCTGACTCTTACCTCCCTCTCTCCTACTCCTGCTCGCATCTGCTATAGTGGAGGCCGGAGCAGGAACAGGTTGAACAGTCTACCCTCCCTTAG\ + \CAGGGAACTACTCCCACCCTGGAGCCTCCGTAGACCTAACCATCTTCTCCTTACACCTAGCAGGTGTCTCCTCTATCTTAGGGGCCATCAATTTCATCAC\ + \AACAATTATCAATATAAAACCCCCTGCCATAACCCAATACCAAACGCCCCTCTTCGTCTGATCCGTCCTAATCACAGCAGTCCTACTTCTCCTATCTCTC\ + \CCAGTCCTAGCTGCTGGCATCACTATACTACTAACAGACCGCAACCTCAACACCACCTTCTTCGACCCCGCCGGAGGAGGAGACCCCATTCTATACCAAC\ + \ACCTATTCTGATTTTTCGGTCACCCTGAAGTTTATATTCTTATCCTACCAGGCTTCGGAATAATCTCCCATATTGTAACTTACTACTCCGGAAAAAAAGA\ + \ACCATTTGGATACATAGGTATGGTCTGAGCTATGATATCAATTGGCTTCCTAGGGTTTATCGTGTGAGCACACCATATATTTACAGTAGGAATAGACGTA\ + \GACACACGAGCATATTTCACCTCCGCTACCATAATCATCGCTATCCCCACCGGCGTCAAAGTATTTAGCTGACTCGCCACACTCCACGGAAGCAATATGA\ + \AATGATCTGCTGCAGTGCTCTGAGCCCTAGGATTCATCTTTCTTTTCACCGTAGGTGGCCTGACTGGCATTGTATTAGCAAACTCATCACTAGACATCGT\ + \ACTACACGACACGTACTACGTTGTAGCCCACTTCCACTATGTCCTATCAATAGGAGCTGTATTTGCCATCATAGGAGGCTTCATTCACTGATTTCCCCTA\ + \TTCTCAGGCTACACCCTAGACCAAACCTACGCCAAAATCCATTTCACTATCATATTCATCGGCGTAAATCTAACTTTCTTCCCACAACACTTTCTCGGCC\ + \TATCCGGAATGCCCCGACGTTACTCGGACTACCCCGATGCATACACCACATGAAACATCCTATCATCTGTAGGCTCATTCATTTCTCTAACAGCAGTAAT\ + \ATTAATAATTTTCATGATTTGAGAAGCCTTCGCTTCGAAGCGAAAAGTCCTAATAGTAGAAGAACCCTCCATAAACCTGGAGTGACTATATGGATGCCCC\ + \CCACCCTACCACACATTCGAAGAACCCGTATACATAAAATCTAGACAAAAAAGGAAGGAATCGAACCCCCCAAAGCTGGTTTCAAGCCAACCCCATGGCC\ + \TCCATGACTTTTTCAAAAAGGTATTAGAAAAACCATTTCATAACTTTGTCAAAGTTAAATTATAGGCTAAATCCTATATATCTTAATGGCACATGCAGCG\ + \CAAGTAGGTCTACAAGACGCTACTTCCCCTATCATAGAAGAGCTTATCACCTTTCATGATCACGCCCTCATAATCATTTTCCTTATCTGCTTCCTAGTCC\ + \TGTATGCCCTTTTCCTAACACTCACAACAAAACTAACTAATACTAACATCTCAGACGCTCAGGAAATAGAAACCGTCTGAACTATCCTGCCCGCCATCAT\ + \CCTAGTCCTCATCGCCCTCCCATCCCTACGCATCCTTTACATAACAGACGAGGTCAACGATCCCTCCCTTACCATCAAATCAATTGGCCACCAATGGTAC\ + \TGAACCTACGAGTACACCGACTACGGCGGACTAATCTTCAACTCCTACATACTTCCCCCATTATTCCTAGAACCAGGCGACCTGCGACTCCTTGACGTTG\ + \ACAATCGAGTAGTACTCCCGATTGAAGCCCCCATTCGTATAATAATTACATCACAAGACGTCTTGCACTCATGAGCTGTCCCCACATTAGGCTTAAAAAC\ + \AGATGCAATTCCCGGACGTCTAAACCAAACCACTTTCACCGCTACACGACCGGGGGTATACTACGGTCAATGCTCTGAAATCTGTGGAGCAAACCACAGT\ + \TTCATGCCCATCGTCCTAGAATTAATTCCCCTAAAAATCTTTGAAATAGGGCCCGTATTTACCCTATAGCACCCCCTCTACCCCCTCTAGAGCCCACTGT\ + \AAAGCTAACTTAGCATTAACCTTTTAAGTTAAAGATTAAGAGAACCAACACCTCTTTACAGTGAAATGCCCCAACTAAATACTACCGTATGGCCCACCAT\ + \AATTACCCCCATACTCCTTACACTATTCCTCATCACCCAACTAAAAATATTAAACACAAACTACCACCTACCTCCCTCACCAAAGCCCATAAAAATAAAA\ + \AATTATAACAAACCCTGAGAACCAAAATGAACGAAAATCTGTTCGCTTCATTCATTGCCCCCACAATCCTAGGCCTACCCGCCGCAGTACTGATCATTCT\ + \ATTTCCCCCTCTATTGATCCCCACCTCCAAATATCTCATCAACAACCGACTAATCACCACCCAACAATGACTAATCAAACTAACCTCAAAACAAATGATA\ + \ACCATACACAACACTAAAGGACGAACCTGATCTCTTATACTAGTATCCTTAATCATTTTTATTGCCACAACTAACCTCCTCGGACTCCTGCCTCACTCAT\ + \TTACACCAACCACCCAACTATCTATAAACCTAGCCATGGCCATCCCCTTATGAGCGGGCACAGTGATTATAGGCTTTCGCTCTAAGATTAAAAATGCCCT\ + \AGCCCACTTCTTACCACAAGGCACACCTACACCCCTTATCCCCATACTAGTTATTATCGAAACCATCAGCCTACTCATTCAACCAATAGCCCTGGCCGTA\ + \CGCCTAACCGCTAACATTACTGCAGGCCACCTACTCATGCACCTAATTGGAAGCGCCACCCTAGCAATATCAACCATTAACCTTCCCTCTACACTTATCA\ + \TCTTCACAATTCTAATTCTACTGACTATCCTAGAAATCGCTGTCGCCTTAATCCAAGCCTACGTTTTCACACTTCTAGTAAGCCTCTACCTGCACGACAA\ + \CACATAATGACCCACCAATCACATGCCTATCATATAGTAAAACCCAGCCCATGACCCCTAACAGGGGCCCTCTCAGCCCTCCTAATGACCTCCGGCCTAG\ + \CCATGTGATTTCACTTCCACTCCATAACGCTCCTCATACTAGGCCTACTAACCAACACACTAACCATATACCAATGATGGCGCGATGTAACACGAGAAAG\ + \CACATACCAAGGCCACCACACACCACCTGTCCAAAAAGGCCTTCGATACGGGATAATCCTATTTATTACCTCAGAAGTTTTTTTCTTCGCAGGATTTTTC\ + \TGAGCCTTTTACCACTCCAGCCTAGCCCCTACCCCCCAATTAGGAGGGCACTGGCCCCCAACAGGCATCACCCCGCTAAATCCCCTAGAAGTCCCACTCC\ + \TAAACACATCCGTATTACTCGCATCAGGAGTATCAATCACCTGAGCTCACCATAGTCTAATAGAAAACAACCGAAACCAAATAATTCAAGCACTGCTTAT\ + \TACAATTTTACTGGGTCTCTATTTTACCCTCCTACAAGCCTCAGAGTACTTCGAGTCTCCCTTCACCATTTCCGACGGCATCTACGGCTCAACATTTTTT\ + \GTAGCCACAGGCTTCCACGGACTTCACGTCATTATTGGCTCAACTTTCCTCACTATCTGCTTCATCCGCCAACTAATATTTCACTTTACATCCAAACATC\ + \ACTTTGGCTTCGAAGCCGCCGCCTGATACTGGCATTTTGTAGATGTGGTTTGACTATTTCTGTATGTCTCCATCTATTGATGAGGGTCTTACTCTTTTAG\ + \TATAAATAGTACCGTTAACTTCCAATTAACTAGTTTTGACAACATTCAAAAAAGAGTAATAAACTTCGCCTTAATTTTAATAATCAACACCCTCCTAGCC\ + \TTACTACTAATAATTATTACATTTTGACTACCACAACTCAACGGCTACATAGAAAAATCCACCCCTTACGAGTGCGGCTTCGACCCTATATCCCCCGCCC\ + \GCGTCCCTTTCTCCATAAAATTCTTCTTAGTAGCTATTACCTTCTTATTATTTGATCTAGAAATTGCCCTCCTTTTACCCCTACCATGAGCCCTACAAAC\ + \AACTAACCTGCCACTAATAGTTATGTCATCCCTCTTATTAATCATCATCCTAGCCCTAAGTCTGGCCTATGAGTGACTACAAAAAGGATTAGACTGAACC\ + \GAATTGGTATATAGTTTAAACAAAACGAATGATTTCGACTCATTAAATTATGATAATCATATTTACCAAATGCCCCTCATTTACATAAATATTATACTAG\ + \CATTTACCATCTCACTTCTAGGAATACTAGTATATCGCTCACACCTCATATCCTCCCTACTATGCCTAGAAGGAATAATACTATCGCTGTTCATTATAGC\ + \TACTCTCATAACCCTCAACACCCACTCCCTCTTAGCCAATATTGTGCCTATTGCCATACTAGTCTTTGCCGCCTGCGAAGCAGCGGTGGGCCTAGCCCTA\ + \CTAGTCTCAATCTCCAACACATATGGCCTAGACTACGTACATAACCTAAACCTACTCCAATGCTAAAACTAATCGTCCCAACAATTATATTACTACCACT\ + \GACATGACTTTCCAAAAAACACATAATTTGAATCAACACAACCACCCACAGCCTAATTATTAGCATCATCCCTCTACTATTTTTTAACCAAATCAACAAC\ + \AACCTATTTAGCTGTTCCCCAACCTTTTCCTCCGACCCCCTAACAACCCCCCTCCTAATACTAACTACCTGACTCCTACCCCTCACAATCATGGCAAGCC\ + \AACGCCACTTATCCAGTGAACCACTATCACGAAAAAAACTCTACCTCTCTATACTAATCTCCCTACAAATCTCCTTAATTATAACATTCACAGCCACAGA\ + \ACTAATCATATTTTATATCTTCTTCGAAACCACACTTATCCCCACCTTGGCTATCATCACCCGATGAGGCAACCAGCCAGAACGCCTGAACGCAGGCACA\ + \TACTTCCTATTCTACACCCTAGTAGGCTCCCTTCCCCTACTCATCGCACTAATTTACACTCACAACACCCTAGGCTCACTAAACATTCTACTACTCACTC\ + \TCACTGCCCAAGAACTATCAAACTCCTGAGCCAACAACTTAATATGACTAGCTTACACAATAGCTTTTATAGTAAAGATACCTCTTTACGGACTCCACTT\ + \ATGACTCCCTAAAGCCCATGTCGAAGCCCCCATCGCTGGGTCAATAGTACTTGCCGCAGTACTCTTAAAACTAGGCGGCTATGGTATAATACGCCTCACA\ + \CTCATTCTCAACCCCCTGACAAAACACATAGCCTACCCCTTCCTTGTACTATCCCTATGAGGCATAATTATAACAAGCTCCATCTGCCTACGACAAACAG\ + \ACCTAAAATCGCTCATTGCATACTCTTCAATCAGCCACATAGCCCTCGTAGTAACAGCCATTCTCATCCAAACCCCCTGAAGCTTCACCGGCGCAGTCAT\ + \TCTCATAATCGCCCACGGGCTTACATCCTCATTACTATTCTGCCTAGCAAACTCAAACTACGAACGCACTCACAGTCGCATCATAATCCTCTCTCAAGGA\ + \CTTCAAACTCTACTCCCACTAATAGCTTTTTGATGACTTCTAGCAAGCCTCGCTAACCTCGCCTTACCCCCCACTATTAACCTACTGGGAGAACTCTCTG\ + \TGCTAGTAACCACGTTCTCCTGATCAAATATCACTCTCCTACTTACAGGACTCAACATACTAGTCACAGCCCTATACTCCCTCTACATATTTACCACAAC\ + \ACAATGGGGCTCACTCACCCACCACATTAACAACATAAAACCCTCATTCACACGAGAAAACACCCTCATGTTCATACACCTATCCCCCATTCTCCTCCTA\ + \TCCCTCAACCCCGACATCATTACCGGGTTTTCCTCTTGTAAATATAGTTTAACCAAAACATCAGATTGTGAATCTGACAACAGAGGCTTACGACCCCTTA\ + \TTTACCGAGAAAGCTCACAAGAACTGCTAACTCATGCCCCCATGTCTAACAACATGGCTTTCTCAACTTTTAAAGGATAACAGCTATCCATTGGTCTTAG\ + \GCCCCAAAAATTTTGGTGCAACTCCAAATAAAAGTAATAACCATGCACACTACTATAACCACCCTAACCCTGACTTCCCTAATTCCCCCCATCCTTACCA\ + \CCCTCGTTAACCCTAACAAAAAAAACTCATACCCCCATTATGTAAAATCCATTGTCGCATCCACCTTTATTATCAGTCTCTTCCCCACAACAATATTCAT\ + \GTGCCTAGACCAAGAAGTTATTATCTCGAACTGACACTGAGCCACAACCCAAACAACCCAGCTCTCCCTAAGCTTCAAACTAGACTACTTCTCCATAATA\ + \TTCATCCCTGTAGCATTGTTCGTTACATGGTCCATCATAGAATTCTCACTGTGATATATAAACTCAGACCCAAACATTAATCAGTTCTTCAAATATCTAC\ + \TCATCTTCCTAATTACCATACTAATCTTAGTTACCGCTAACAACCTATTCCAACTGTTCATCGGCTGAGAGGGCGTAGGAATTATATCCTTCTTGCTCAT\ + \CAGTTGATGATACGCCCGAGCAGATGCCAACACAGCAGCCATTCAAGCAATCCTATACAACCGTATCGGCGATATCGGTTTCATCCTCGCCTTAGCATGA\ + \TTTATCCTACACTCCAACTCATGAGACCCACAACAAATAGCCCTTCTAAACGCTAATCCAAGCCTCACCCCACTACTAGGCCTCCTCCTAGCAGCAGCAG\ + \GCAAATCAGCCCAATTAGGTCTCCACCCCTGACTCCCCTCAGCCATAGAAGGCCCCACCCCAGTCTCAGCCCTACTCCACTCAAGCACTATAGTTGTAGC\ + \AGGAATCTTCTTACTCATCCGCTTCCACCCCCTAGCAGAAAATAGCCCACTAATCCAAACTCTAACACTATGCTTAGGCGCTATCACCACTCTGTTCGCA\ + \GCAGTCTGCGCCCTTACACAAAATGACATCAAAAAAATCGTAGCCTTCTCCACTTCAAGTCAACTAGGACTCATAATAGTTACAATCGGCATCAACCAAC\ + \CACACCTAGCATTCCTGCACATCTGTACCCACGCCTTCTTCAAAGCCATACTATTTATGTGCTCCGGGTCCATCATCCACAACCTTAACAATGAACAAGA\ + \TATTCGAAAAATAGGAGGACTACTCAAAACCATACCTCTCACTTCAACCTCCCTCACCATTGGCAGCCTAGCATTAGCAGGAATACCTTTCCTCACAGGT\ + \TTCTACTCCAAAGACCACATCATCGAAACCGCAAACATATCATACACAAACGCCTGAGCCCTATCTATTACTCTCATCGCTACCTCCCTGACAAGCGCCT\ + \ATAGCACTCGAATAATTCTTCTCACCCTAACAGGTCAACCTCGCTTCCCCACCCTTACTAACATTAACGAAAATAACCCCACCCTACTAAACCCCATTAA\ + \ACGCCTGGCAGCCGGAAGCCTATTCGCAGGATTTCTCATTACTAACAACATTTCCCCCGCATCCCCCTTCCAAACAACAATCCCCCTCTACCTAAAACTC\ + \ACAGCCCTCGCTGTCACTTTCCTAGGACTTCTAACAGCCCTAGACCTCAACTACCTAACCAACAAACTTAAAATAAAATCCCCACTATGCACATTTTATT\ + \TCTCCAACATACTCGGATTCTACCCTAGCATCACACACCGCACAATCCCCTATCTAGGCCTTCTTACGAGCCAAAACCTGCCCCTACTCCTCCTAGACCT\ + \AACCTGACTAGAAAAGCTATTACCTAAAACAATTTCACAGCACCAAATCTCCACCTCCATCATCACCTCAACCCAAAAAGGCATAATTAAACTTTACTTC\ + \CTCTCTTTCTTCTTCCCACTCATCCTAACCCTACTCCTAATCACATAACCTATTCCCCCGAGCAATCTCAATTACAATATATACACCAACAAACAATGTT\ + \CAACCAGTAACTACTACTAATCAACGCCCATAATCATACAAAGCCCCCGCACCAATAGGATCCTCCCGAATCAACCCTGACCCCTCTCCTTCATAAATTA\ + \TTCAGCTTCCTACACTATTAAAGTTTACCACAACCACCACCCCATCATACTCTTTCACCCACAGCACCAATCCTACCTCCATCGCTAACCCCACTAAAAC\ + \ACTCACCAAGACCTCAACCCCTGACCCCCATGCCTCAGGATACTCCTCAATAGCCATCGCTGTAGTATATCCAAAGACAACCATCATTCCCCCTAAATAA\ + \ATTAAAAAAACTATTAAACCCATATAACCTCCCCCAAAATTCAGAATAATAACACACCCGACCACACCGCTAACAATCAATACTAAACCCCCATAAATAG\ + \GAGAAGGCTTAGAAGAAAACCCCACAAACCCCATTACTAAACCCACACTCAACAGAAACAAAGCATACATCATTATTCTCGCACGGACTACAACCACGAC\ + \CAATGATATGAAAAACCATCGTTGTATTTCAACTACAAGAACACCAATGACCCCAATACGCAAAACTAACCCCCTAATAAAATTAATTAACCACTCATTC\ + \ATCGACCTCCCCACCCCATCCAACATCTCCGCATGATGAAACTTCGGCTCACTCCTTGGCGCCTGCCTGATCCTCCAAATCACCACAGGACTATTCCTAG\ + \CCATGCACTACTCACCAGACGCCTCAACCGCCTTTTCATCAATCGCCCACATCACTCGAGACGTAAATTATGGCTGAATCATCCGCTACCTTCACGCCAA\ + \TGGCGCCTCAATATTCTTTATCTGCCTCTTCCTACACATCGGGCGAGGCCTATATTACGGATCATTTCTCTACTCAGAAACCTGAAACATCGGCATTATC\ + \CTCCTGCTTGCAACTATAGCAACAGCCTTCATAGGCTATGTCCTCCCGTGAGGCCAAATATCATTCTGAGGGGCCACAGTAATTACAAACTTACTATCCG\ + \CCATCCCATACATTGGGACAGACCTAGTTCAATGAATCTGAGGAGGCTACTCAGTAGACAGTCCCACCCTCACACGATTCTTTACCTTTCACTTCATCTT\ + \GCCCTTCATTATTGCAGCCCTAGCAACACTCCACCTCCTATTCTTGCACGAAACGGGATCAAACAACCCCCTAGGAATCACCTCCCATTCCGATAAAATC\ + \ACCTTCCACCCTTACTACACAATCAAAGACGCCCTCGGCTTACTTCTCTTCCTTCTCTCCTTAATGACATTAACACTATTCTCACCAGACCTCCTAGGCG\ + \ACCCAGACAATTATACCCTAGCCAACCCCTTAAACACCCCTCCCCACATCAAGCCCGAATGATATTTCCTATTCGCCTACACAATTCTCCGATCCGTCCC\ + \TAACAAACTAGGAGGCGTCCTTGCCCTATTACTATCCATCCTCATCCTAGCAATAATCCCCATCCTCCATATATCCAAACAACAAAGCATAATATTTCGC\ + \CCACTAAGCCAATCACTTTATTGACTCCTAGCCGCAGACCTCCTCATTCTAACCTGAATCGGAGGACAACCAGTAAGCTACCCTTTTACCATCATTGGAC\ + \AAGTAGCATCCGTACTATACTTCACAACAATCCTAATCCTAATACCAACTATCTCCCTAATTGAAAACAAAATACTCAAATGGGCCTGTCCTTGTAGTAT\ + \AAACTAATACACCAGTCTTGTAAACCGGAGATGAAAACCTTTTTCCAAGGACAAATCAGAGAAAAAGTCTTTAACTCCACCATTAGCACCCAAAGCTAAG\ + \ATTCTAATTTAAACTATTCTCTGTTCTTTCATGGGGAAGCAGATTTGGGTACCACCCAAGTATTGACTCACCCATCAACAACCGCTATGTATTTCGTACA\ + \TTACTGCCAGCCACCATGAATATTGTACGGTACCATAAATACTTGACCACCTGTAGTACATAAAAACCCAATCCACATCAAAACCCCCTCCCCATGCTTA\ + \CAAGCAAGTACAGCAATCAACCCTCAACTATCACACATCAACTGCAACTCCAAAGCCACCCCTCACCCACTAGGATACCAACAAACCTACCCACCCTTAA\ + \CAGTACATAGTACATAAAGCCATTTACCGTACATAGCACATTACAGTCAAATCCCTTCTCGTCCCCATGGATGACCCCCCTCAGATAGGGGTCCCTTGAC\ + \CACCATCCTCCGTGAAATCAATATCCCGCACAAGAGTGCTACTCTCCTCGCTCCGGGCCCATAACACTTGGGGGTAGCTAAAGTGAACTGTATCCGACAT\ + \CTGGTTCCTACTTCAGGGTCATAAAGCCTAAATAGCCCACACGTTCCCCTTAAATAAGACATCACGATG" + diff --git a/tools/SimpleSeed.hs b/tools/SimpleSeed.hs new file mode 100644 --- /dev/null +++ b/tools/SimpleSeed.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards #-} +{-# OPTIONS_GHC -Wall #-} +module SimpleSeed where + +import Bio.Base +import Bio.Bam.Rec + +import Data.Bits +import Data.List +import Data.Maybe + +import qualified Data.IntMap as IM +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Unboxed as U + +-- | Discontiguous template "12 of 16", stolen from MegaBLAST: +-- 1,110,110,110,110,111, with two bits per base gives 0xFCF3CF3F + +template :: Int +template = 0xFCF3CF3F + +create_seed_words :: [Nucleotides] -> [(Int, Int)] +create_seed_words = drop 32 . go 0x0 (-16) 0x0 0 + where + go !accf !i !accr !ir s = + (accf .&. template, i) : (accr .&. template, ir) : case s of + [ ] -> [] + (Ns n:ns) -> go (accf `shiftR` 2 .|. (codef U.! fromIntegral n) `shiftL` 30) (i+1) + (accr `shiftL` 2 .|. (coder U.! fromIntegral n)) (ir-1) ns + + -- These codes are chosen so that ambiguity codes result in zeroes. + -- The seed word 0, which would otherwise be the low-complexity and + -- useless poly-A, is later ignored. + codef, coder :: U.Vector Int + codef = U.fromList [0,0,1,0,2,0,0,0,3,0,0,0,0,0,0,0] + coder = U.fromList [0,3,2,0,1,0,0,0,0,0,0,0,0,0,0,0] + +-- Turns a list of seed words into a map. Only the first entry is used, +-- duplicates are discarded silenty. + +data I2 = I2 !Int !Int + +newtype SeedMap = SM { unSM :: IM.IntMap Int } + deriving Show + +create_seed_map :: [Nucleotides] -> SeedMap +create_seed_map = SM . cleanup . foldl' (\m (k,v) -> IM.insertWith' add k v m) IM.empty . + map (\(x,y) -> (x,(I2 1 y))) . create_seed_words . pad + where pad ns = ns ++ take 15 ns + add (I2 x i) (I2 y _) = I2 (x+y) i + cleanup = IM.mapMaybe $ \(I2 n j) -> if n < 8 then Just j else Nothing + +create_seed_maps :: [[Nucleotides]] -> SeedMap +create_seed_maps = SM . IM.unionsWith const . map (unSM . create_seed_map) + +-- | Actual seeding. We take every hit and guesstimate an alignment +-- region from it (by adding the overhanging sequence parts and rounding +-- a bit up). Regions are overlapped into larger ones, counting votes. +-- The region with the most votes is used as seed region. (This will +-- occasionally result in a very long initial alignment. We can afford +-- that.) +-- +-- If we have PE data where only one read is seeded, we can either +-- discard the pair or align the second mate very expensively. While +-- possible, that sounds rather expensive and should probably depend on +-- the quality of the first mates' alignment. Generally, we may want to +-- check the quality of the initial alignment anyway. +-- +-- For proper overlapping, we need to normalize each region to strictly +-- positive or strictly negative coordinates. After sorting and +-- overlapping, we only need to check if the last region overlaps the +-- first---there can be only one such overlap per strand. We should +-- probably discard overly long regions. + +do_seed :: Int -> SeedMap -> BamRec -> Maybe (Int,Int) +do_seed ln (SM sm) BamRec{..} = -- do S.hPut stdout $ S.concat [ b_qname, key, ": ", S.pack (shows b_seq "\n") ] + -- mapM_ (\x -> hPutStrLn stdout $ " " ++ show x) rgns + case rgns of + [ ] -> Nothing -- putStrLn "discard" + {- (a,b,_) : _ | a > 20000 || a < (-20000) -> error $ concat [ + "Weird region: ", + shows (a,b,ln) "; ", + "Primitive regions: ", + shows (rgns_fwd ++ rgns_rev) "; ", + "Resulting regions: ", + show rgns ] -} + (a,b,_) : _ -> Just (a,b) -- putStrLn $ "seed to " ++ shows a ".." ++ shows b " (" + -- ++ shows (b-a) "/" ++ shows (V.length b_seq) ")" + + where + seeds = filter ((/= 0) . fst) $ filter ((/= template) . fst) $ + filter ((>= 0) . snd) $ create_seed_words $ V.toList b_seq + + more x = (x * 9) `div` 8 + 16 + + rgns = sortBy (\(_,_,c) (_,_,z) -> compare z c) $ filter reasonably_short $ + (wrap_with id $ overlap $ sort $ map norm_right rgns_fwd) ++ + (wrap_with norm_left $ overlap $ sort $ map norm_left rgns_rev) + + (rgns_fwd, rgns_rev) = let put (f,r) (i,j) | j >= 0 = (rgn:f, r) + | otherwise = (f, rgn:r) + where rgn = (j - more i, j + more (V.length b_seq - i), 1::Int) + in foldl put ([],[]) [ (i,j) | (k,i) <- seeds, j <- maybeToList $ IM.lookup k sm ] + + norm_right (a,b,n) = if a < 0 then (a+ln, b+ln, n) else (a,b,n) + norm_left (a,b,n) = if b >= 0 then (a-ln, b-ln, n) else (a,b,n) + + wrap_with _ [ ] = [] + wrap_with _ [ r ] = [r] + wrap_with f rs@((x,y,n):rs') + | i <= y+ln && x+ln <= j = f (min (x+ln) i, max (y+ln) j, n+m) : init rs' + | otherwise = rs + where + (i,j,m) = last rs + + overlap ( (x,y,n) : (i,j,m) : rs ) | i <= y = overlap ( (x,max y j,n+m) : rs ) + overlap ( (x,y,n) : rs ) = (x,y,n) : overlap rs + overlap [] = [] + + -- First cut: reasonable is less than the whole MT. Tuning can + -- come later. + reasonably_short (x,y,_) = y-x < ln + diff --git a/tools/Xlate.hs b/tools/Xlate.hs new file mode 100644 --- /dev/null +++ b/tools/Xlate.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wall #-} +module Xlate where + +import qualified Data.ByteString.Char8 as S +import qualified Data.IntMap as I +import qualified Data.List as L +import qualified Data.Map as M + +-- aligned sequences in, coodinate on first in, coordinate on second out +xpose :: S.ByteString -> S.ByteString -> Int -> Int +xpose ref smp = \p -> I.findWithDefault (-1) p mm + where + (!mm,_,_) = L.foldl' advance (I.empty, 0, 0) $ S.zip ref smp + advance (!m,!p1,!p2) (r,s) = let !p1' = if r == '-' then p1 else 1+p1 + !p2' = if s == '-' then p2 else 1+p2 + in if r == '-' then (m,p1',p2') + else (I.insert p1' p2' m, p1', p2') + +-- diffz :: CDS -> [(String, Int, Char, Char)] +-- diffz cds@(CDS _ nm _) = [ (nm, i, r, b) | (i,r,b) <- zip3 [1..] aa_ref aa_bnt, r /= b ] + -- where (aa_ref, aa_bnt) = get_protein cds + +get_protein :: S.ByteString -> (Int,Int) -> String +get_protein ns (s,e) = translate $ cutout + where + cutout | s <= e = (take (e-s+1) $ drop (s-1) $ filter (/= '-') $ S.unpack ns) ++ "AA" + | otherwise = (map compl $ reverse $ + take (s-e+1) $ drop (e-1) $ filter (/= '-') $ S.unpack ns) ++ "AA" + + compl 'A' = 'T' + compl 'C' = 'G' + compl 'G' = 'C' + compl 'T' = 'A' + compl x = x + + +translate :: String -> String +translate (a:b:c:s) = m : translate s + where m = M.findWithDefault 'X' (a,b,c) mito_code +translate _ = [] + +standard_code :: M.Map (Char,Char,Char) Char +standard_code = M.fromList $ zip3 base1 base2 base3 `zip` aas + where + aas = "FFLLSSSSYY**CC*WLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG" + base1 = "TTTTTTTTTTTTTTTTCCCCCCCCCCCCCCCCAAAAAAAAAAAAAAAAGGGGGGGGGGGGGGGG" + base2 = "TTTTCCCCAAAAGGGGTTTTCCCCAAAAGGGGTTTTCCCCAAAAGGGGTTTTCCCCAAAAGGGG" + base3 = "TCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAG" + +mito_code :: M.Map (Char,Char,Char) Char +mito_code = M.insert ('A','G','A') '*' $ + M.insert ('A','G','G') '*' $ + M.insert ('A','T','A') 'M' $ + M.insert ('T','G','A') 'W' $ standard_code + diff --git a/tools/afroengineer.hs b/tools/afroengineer.hs new file mode 100644 --- /dev/null +++ b/tools/afroengineer.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards, RankNTypes #-} +{-# OPTIONS_GHC -Wall #-} + +-- Cobble up a mitochondrion, or something similar. This is not an +-- assembly, but something that could serve in stead of one :) +-- +-- The goal is to reconstruct a mitochondrion (or similar small, haploid +-- locus) from a set of sequencing reads and a reference sequence. The +-- idea is to first select reads using some sort of filtering strategy, +-- simply for speed reasons. They are then aligned to the reference +-- using banded Smith-Waterman algorithm, and a more likely reference is +-- called. This is repeated till it converges. A bad implementation of +-- the idea was called MIA. + +import Align +import SimpleSeed + +import Bio.Base +import Bio.Bam +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.Char +import Data.List ( isSuffixOf ) +import Data.Monoid +import Numeric +import Prelude hiding ( round ) +import System.Console.GetOpt +import System.Directory ( doesFileExist ) +import System.Environment +import System.Exit +import System.IO + +import qualified Bio.Iteratee.ZLib as ZLib +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Foldable as F +import qualified Data.Iteratee as I +import qualified Data.Sequence as Z +import qualified Data.Vector.Generic as V + +import Debug.Trace + +-- Read a FastA file, drop the names, yield the sequences. +readFasta :: L.ByteString -> [( S.ByteString, [Either Nucleotides Nucleotides] )] +readFasta = go . dropWhile (not . isHeader) . L.lines + where + isHeader s = not (L.null s) && L.head s == '>' + + go [ ] = [] + go (hd:ls) = case break isHeader ls of + (body, rest) -> let ns = map toNuc . concat $ map L.unpack body + nm = S.concat . L.toChunks . L.tail . head $ L.words hd + in (nm,ns) : if null rest then [] else go rest + + toNuc x | isUpper x = Right $ toNucleotides x + | otherwise = Left $ toNucleotides (toUpper x) + + +-- | A query record. We construct these after the seeding phase and +-- keep the bare minimum: name, sequence/quality, seed region, flags +-- (currently only the strand). Just enough to write a valig BAM file. + +data QueryRec = QR { qr_name :: {-# UNPACK #-} !Seqid -- from BAM + , qr_seq :: {-# UNPACK #-} !QuerySeq -- sequence and quality + , qr_pos :: {-# UNPACK #-} !RefPosn -- start position of band + , qr_band :: {-# UNPACK #-} !Bandwidth } -- bandwidth (negative to indicate reversed sequence_ + deriving Show + +data Conf = Conf { + conf_references :: [FilePath] -> [FilePath], + conf_aln_outputs :: Maybe (Int -> FilePath), + conf_cal_outputs :: Maybe (Int -> FilePath) } + +iniconf :: Conf +iniconf = Conf id Nothing Nothing + +options :: [ OptDescr (Conf -> IO Conf) ] +options = [ + Option "r" ["reference"] (ReqArg add_ref "FILE") "Read references from FILE", + Option "a" ["align-out"] (ReqArg set_aln_out "PAT") "Write intermediate alignments to PAT", + Option "c" ["called-out"] (ReqArg set_cal_out "PAT") "Write called references to PAT" ] + where + add_ref f c = return $ c { conf_references = conf_references c . (:) f } + set_aln_out p c = return $ c { conf_aln_outputs = Just (splice_pat p) } + set_cal_out p c = return $ c { conf_cal_outputs = Just (splice_pat p) } + + splice_pat [] _ = [] + splice_pat ('%':'%':s) x = '%' : splice_pat s x + splice_pat ('%':'d':s) x = shows x $ splice_pat s x + splice_pat (c:s) x = c : splice_pat s x + +main :: IO () +main = do + (opts, files, errors) <- getOpt Permute options <$> getArgs + unless (null errors) $ mapM_ (hPutStrLn stderr) errors >> exitFailure + Conf{..} <- foldl (>>=) (return iniconf) opts + + inputs@((refname,reference):_) <- concatMap readFasta <$> mapM L.readFile (conf_references []) + + let !sm = create_seed_maps (map (map (either id id) . snd) inputs) + !rs = prep_reference reference + + let bamhdr = mempty { meta_hdr = BamHeader (1,4) Unsorted [] + , meta_refs = Z.singleton $ BamSQ refname (length reference) [] } + + + -- uhh.. termination condition? + let round n k = do let bamout = case conf_aln_outputs of + Nothing -> skipToEof + Just nf -> write_iter_bam (nf n) bamhdr + (newref, queries) <- k bamout + case conf_cal_outputs of Nothing -> return () + Just nf -> write_ref_fasta (nf n) n newref + putStrLn $ "Round " ++ shows n ": Kept " ++ shows (length queries) " queries." + round (n+1) (\out -> enumPure1Chunk queries >=> run $ roundN newref out) + + round 1 (\out -> foldr ((>=>) . readFreakingInput) run files $ round1 sm rs out) + + -- print queries + -- return () + + +-- General plan: In the first round, we read, seed, align, call the new +-- working sequence, and write a BAM file. Then write the new working +-- sequence out. In subsequent rounds, the seeding is skipped and the +-- sequences come from memory. +-- +-- XXX the bandwidth is too low, definitely in round 1, probably in +-- subsequent rounds. + +round1 :: MonadIO m + => SeedMap -> RefSeq + -> Iteratee [(QueryRec, AlignResult)] m () -- BAM output + -> Iteratee [BamRec] m -- queries in + (RefSeq, [QueryRec]) -- new reference & queries out +round1 sm rs out = convStream (headStream >>= seed) =$ roundN rs out + where + seed br@BamRec{..} + | low_qual = return [] + | otherwise = case do_seed (refseq_len rs) sm br of + Nothing -> return [] + Just (a,b) | a >= 0 -> return [ QR b_qname (prep_query_fwd br) (RP a ) (BW bw ) ] + | otherwise -> return [ QR b_qname (prep_query_rev br) (RP (-b)) (BW (-bw)) ] + where bw = b - a - V.length b_seq + where + low_qual = 2 * l1 < l2 + l2 = V.length b_seq + l1 = V.length $ V.filter (> Q 10) b_qual + +roundN :: Monad m + => RefSeq + -> Iteratee [(QueryRec, AlignResult)] m () -- BAM output + -> Iteratee [QueryRec] m -- queries in + (RefSeq, [QueryRec]) -- new reference & queries out +roundN rs out = do + ((), (rs', xtab), qry') <- mapStream aln =$ filterStream good =$ + I.zip3 out mkref collect + return (rs', reverse $ map (xlate xtab) qry') + + where + gap_cost = 50 -- Hmm, better suggestions? + pad = 8 + + aln qr@QR{..} = let res = align gap_cost rs qr_seq qr_pos qr_band + in ( new_coords qr res, res ) + good (_, res) = viterbi_score res < 0 + + mkref = finalize_ref_seq `liftM` foldStream step (new_ref_seq rs) + step nrs (qr, res) = add_to_refseq nrs (qr_seq qr) res + + collect :: Monad m => Iteratee [(QueryRec, AlignResult)] m [(Int,Int,QueryRec)] + collect = foldStream (\l (!qr,!ar) -> + -- get alignment ends from ar, add some buffer + -- XXX does this yield invalid coordinates? + let !left = viterbi_position ar - 8 + !right = viterbi_position ar + 8 + alignedLength (viterbi_backtrace ar) + in (left,right,qr) : l) [] + + xlate :: XTab -> (Int, Int, QueryRec) -> QueryRec + xlate tab (l,r,qr) + | r <= l = error "confused reft and light" + | left < 0 || right < 0 = error "too far left" + | right' < left = error "flipped over" + | otherwise = qr { qr_pos = RP left, qr_band = BW $ right' - left } + where + lk x | x < 0 = Z.index tab (x + Z.length tab - 1) + | x < Z.length tab = Z.index tab x + | otherwise = Z.index tab (x - Z.length tab + 1) + + left = lk l ; right = lk r ; _ Z.:> newlen = Z.viewr tab + right' = if left < right then right else right + newlen + + new_coords qr rr = qr { qr_pos = RP $ viterbi_position rr - pad + , qr_band = BW $ (if reversed (qr_band qr) then negate else id) $ + 2*pad + max_bandwidth (viterbi_backtrace rr) } + + reversed (BW x) = x < 0 + + max_bandwidth = (+1) . (*2) . V.maximum . V.map abs . V.scanl plus 0 + + plus a (Mat :* _) = a + plus a (Ins :* n) = a+n + plus a (Del :* n) = a-n + + + +-- Outline for further rounds: We keep the same queries, we use the new +-- reference called in the previous round. Output is channelled to +-- different files. However, we need to translate coordinates to keep +-- the alignment windows in the correct places. This should actually +-- come from the calling of the new reference. Note that coordinate +-- translation may actually change the bandwidth. Also we have to +-- compute a sensible bandwidth from the alignment. + +write_iter_bam :: FilePath -> BamMeta -> Iteratee [(QueryRec, AlignResult)] IO () +write_iter_bam fp hdr = mapStream conv =$ writeBamFile fp hdr + where + conv (QR{..}, AlignResult{..}) = BamRec + { b_qname = qname + , b_flag = if reversed qr_band then flagReversed else 0 + , b_rname = Refseq 0 + , b_pos = viterbi_position + , b_mapq = Q 255 + , b_cigar = viterbi_backtrace + , b_mrnm = invalidRefseq + , b_mpos = 0 + , b_isize = 0 + , b_seq = qseqToBamSeq qr_seq + , b_qual = qseqToBamQual qr_seq + , b_virtual_offset = 0 + , b_exts = [] } + where + qname = qr_name `S.append` S.pack (" " ++ showFFloat (Just 1) viterbi_score []) + reversed (BW x) = x < 0 + +-- | Calls sequence and writes to file. We call a base only if the gap +-- has a probability lower than 50%. We call a weak base if the gap has +-- a probality of more than 25%. If the most likely base is at least +-- twice as likely as the second most likely one, we call it. Else we +-- call an N or n. +write_ref_fasta :: FilePath -> Int -> RefSeq -> IO () +write_ref_fasta fp num rs = writeFile fp $ unlines $ + (">genotype_call-" ++ show num) : chunk 70 (ref_to_ascii rs) + where + chunk n s = case splitAt n s of _ | null s -> [] ; (l,r) -> l : chunk n r + +ref_to_ascii :: RefSeq -> String +ref_to_ascii (RS v) = [ base | i <- [0, 5 .. V.length v - 5] + , let pgap = indexV "ref_to_ascii/pgap" v (i+4) + , pgap > 3 + , let letters = if pgap <= 6 then "acgtn" else "ACGTN" + , let (index, p1, p2) = minmin i 4 + , let good = p2 - p1 >= 3 -- probably nonsense + , let base = S.index letters $ if good then index else trace (show (V.slice i 5 v)) 4 ] + where + minmin i0 l = V.ifoldl' step (l, 255, 255) $ V.slice i0 l v + step (!i, !m, !n) j x | x <= m = (j, x, m) + | x <= n = (i, m, x) + | otherwise = (i, m, n) + + + +readFreakingInput :: (MonadIO m, MonadMask m) => FilePath -> Enumerator [BamRec] m b +readFreakingInput fp k | ".bam" `isSuffixOf` fp = do liftIO (hPutStrLn stderr $ "Reading BAM from " ++ fp) + decodeAnyBamFile fp . const $= mapStream unpackBam $ k + | otherwise = maybe_read_two fp unzipFastq k + +check_r2 :: FilePath -> IO (Maybe FilePath) +check_r2 = go [] . reverse + where + go acc ('1':'r':fp) = do let fp' = reverse fp ++ 'r' : '2' : acc + e <- doesFileExist fp' + return $ if e then Just fp' else Nothing + go acc (c:fp) = go (c:acc) fp + go _ [ ] = return Nothing + +maybe_read_two :: (MonadIO m, MonadMask m) + => FilePath + -> (forall m1 b . (MonadIO m1, MonadMask m1) => Enumeratee S.ByteString [BamRec] m1 b) + -> Enumerator [BamRec] m a +maybe_read_two fp e1 = (\k -> liftIO (check_r2 fp) >>= maybe (rd1 k) (rd2 k)) + where + rd1 k = do liftIO (hPutStrLn stderr $ "Reading FastQ from " ++ fp) + enumFile defaultBufSize fp $= e1 $ k + rd2 k fp' = do liftIO (hPutStrLn stderr $ "Reading FastQ from " ++ fp ++ " and " ++ fp') + mergeEnums (enumFile defaultBufSize fp $= e1) + (enumFile defaultBufSize fp' $= e1) + (convStream unite_pairs) k + +-- No, we don't need to 'removeWarts'. This input is, of course, a special case. :-( +unzipFastq :: (MonadIO m, MonadMask m) => Enumeratee S.ByteString [BamRec] m b +unzipFastq = ZLib.enumInflateAny ><> parseFastq + +unite_pairs :: Monad m => Iteratee [BamRec] (Iteratee [BamRec] m) [BamRec] +unite_pairs = do a <- lift headStream + b <- headStream + return [ a { b_flag = b_flag a .|. flagFirstMate } + , b { b_flag = b_flag b .|. flagSecondMate } ] + diff --git a/tools/bam-fixpair.hs b/tools/bam-fixpair.hs new file mode 100644 --- /dev/null +++ b/tools/bam-fixpair.hs @@ -0,0 +1,594 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings, FlexibleContexts, RecordWildCards #-} + +{- +This is a validator/fixup for paired end BAM files, that is more +efficient than 'samtools sort -n' followed by 'samtools fixmate'. + +We want both: to quickly join separate mates together again from the +information about the mate's mapping coordinate, but at the same time +deal with broken files where that doesn't actually work. Whenever we +join mates, we also check if the flags are consistent and fix them if +they aren't. + +In the end, the code will work... + + - splendidly, if mates are already adjacent, in which case everything + is streamed. + - well, if the input is sorted properly, in which case most reads + stream, but improper pairs need to queue until the mate is reached. + - reasonably, if there are occasional lone mates, which will be queued + to the very end and sorted by hashed-qname before they are recognized + and repaired. + - awkwardly, if sorting is violated, flags are wrong or lone mates are + the rule, because then it degenerates to a full sort by qname. + +TODO: + . upgrade to pqueue in external memory + . a companion program that sorts would be cool, but it should be an + opportunistic sort that is fast on almost sorted files. +-} + +import Bio.Base +import Bio.Bam.Header +import Bio.Bam.Reader hiding ( mergeInputs, combineCoordinates ) +import Bio.Bam.Rec +import Bio.Bam.Writer +import Bio.Iteratee +import Bio.PriorityQueue +import Bio.Util ( showNum ) +import Control.Arrow ( (&&&) ) +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Class +import Data.Binary +import Data.Bits +import Data.Hashable +import Data.List +import Data.Version ( showVersion ) +import Paths_biohazard ( version ) +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) +import System.Exit ( exitFailure, exitSuccess ) +import System.IO ( hPutStrLn ) +import Text.Printf + +import qualified Data.ByteString as S + +data Verbosity = Silent | Errors | Warnings | Notices deriving (Eq, Ord) +data KillMode = KillNone | KillUu | KillAll deriving (Eq, Ord) + +data Config = CF { report_mrnm :: !Bool + , report_mpos :: !Bool + , report_isize :: !Bool + , report_flags :: !Bool + , report_fflag :: !Bool + , report_ixs :: !Bool + , verbosity :: Verbosity + , killmode :: KillMode + , output :: BamMeta -> Iteratee [BamRec] IO () } + +config0 :: IO Config +config0 = return $ CF True True False True False True Errors KillNone (protectTerm . pipeBamOutput) + +options :: [OptDescr (Config -> IO Config)] +options = [ + Option "o" ["output"] (ReqArg set_output "FILE") "Write output to FILE", + Option "n" ["dry-run","validate"] (NoArg set_validate) "No output, validate only", + Option "k" ["kill-lone"] (NoArg (\c -> return $ c { killmode = KillAll })) "Delete all lone mates", + Option "u" ["kill-unmap"] (NoArg (\c -> return $ c { killmode = KillUu })) "Delete unmapped lone mates", + Option [ ] ["kill-none"] (NoArg (\c -> return $ c { killmode = KillNone })) "Never delete lone mates (default)", + + Option "v" ["verbose"] (NoArg (\c -> return $ c { verbosity = Notices })) "Print informational messages", + Option "w" ["warnings"] (NoArg (\c -> return $ c { verbosity = Warnings })) "Print warnings and errors", + Option [ ] ["errors"] (NoArg (\c -> return $ c { verbosity = Errors })) "Print only errors (default)", + Option "q" ["quiet"] (NoArg (\c -> return $ c { verbosity = Silent })) "Print only fatal errors", + + Option "" ["report-mrnm"] (NoArg (\c -> return $ c { report_mrnm = True })) "Report wrong mate reference name (default yes)", + Option "" ["report-mpos"] (NoArg (\c -> return $ c { report_mpos = True })) "Report wrong mate position (default yes)", + Option "" ["report-isize"] (NoArg (\c -> return $ c { report_isize = True })) "Report wrong insert size (default no)", + Option "" ["report-flags"] (NoArg (\c -> return $ c { report_flags = True })) "Report wrong flags (default yes)", + Option "" ["report-fflag"] (NoArg (\c -> return $ c { report_fflag = True })) "Report commonly inconsistent flags (default no)", + + Option "" ["no-report-mrnm"] (NoArg (\c -> return $ c { report_mrnm = False })) "Do not report wrong mate reference name", + Option "" ["no-report-mpos"] (NoArg (\c -> return $ c { report_mpos = False })) "Do not report wrong mate position", + Option "" ["no-report-isize"] (NoArg (\c -> return $ c { report_isize = False })) "Do not report wrong insert size", + Option "" ["no-report-flags"] (NoArg (\c -> return $ c { report_flags = False })) "Do not report wrong flags", + Option "" ["no-report-fflag"] (NoArg (\c -> return $ c { report_fflag = False })) "Do not report commonly inconsistent flags", + Option "" ["no-report-fflag"] (NoArg (\c -> return $ c { report_ixs = False })) "Do not report mismatched index fields", + + Option "h?" ["help","usage"] (NoArg usage) "Print this helpful message and exit", + Option "V" ["version"] (NoArg vrsn) "Print version number and exit" ] + where + usage _ = do pn <- getProgName + let blah = "Usage: " ++ pn ++ " [OPTION...] [FILE...]\n\ + \Merge BAM files, rearrange them to move mate pairs together, \ + \output a file with consistent mate pair information." + hPutStrLn stderr $ usageInfo blah options + exitSuccess + + vrsn _ = do pn <- getProgName + hPutStrLn stderr $ pn ++ ", version " ++ showVersion version + exitSuccess + + set_output "-" c = return $ c { output = pipeBamOutput } + set_output f c = return $ c { output = writeBamFile f } + set_validate c = return $ c { output = \_ -> skipToEof } + + +-- XXX placeholder... +pqconf :: PQ_Conf +pqconf = PQ_Conf 1000 "/var/tmp/" + +main :: IO () +main = do (opts, files, errors) <- getOpt Permute options `fmap` getArgs + unless (null errors) $ mapM_ (hPutStrLn stderr) errors >> exitFailure + config <- foldl (>>=) config0 opts + add_pg <- addPG $ Just version + withQueues $ \queues -> + mergeInputs files >=> run $ \hdr -> + re_pair queues config (meta_refs hdr) =$ + (output config) (add_pg hdr) + + +-- | Fix a pair of reads. Right now fixes their order and checks that +-- one is 1st mate, the other 2nd mate. More fixes to come. + +fixmate :: MonadIO m => BamRaw -> BamRaw -> Mating r m [BamRec] +fixmate r s | isFirstMate (unpackBam r) && isSecondMate (unpackBam s) = sequence [go r s, go s r] + | isSecondMate (unpackBam r) && isFirstMate (unpackBam s) = sequence [go s r, go r s] + | otherwise = liftIO $ do hPutStrLn stderr $ "Names match, but 1st mate / 2nd mate flags do not: " + ++ unpackSeqid (b_qname (unpackBam r)) + hPutStrLn stderr $ "There is no clear way to fix this file. Giving up." + exitFailure + where + -- position of 5' end + pos5 a = if isReversed a then b_pos a + alignedLength (b_cigar a) else b_pos a + + -- transfer info from b to a + go p q | null problems = return a + | otherwise = do infos <- filter (not . null) `fmap` sequence [ m | (_,_,m) <- problems ] + unless (null infos) $ liftIO $ hPutStrLn stderr $ message infos + return $ foldr (\(_,m,_) -> m) a problems + where + a = unpackBam p + b = unpackBam q + + problems = filter (\(x,_,_) -> not x) checks + checks = [ (b_mrnm a == b_rname b, \x -> x { b_mrnm = b_rname b }, count_mrnm) + , (b_mpos a == b_pos b, \x -> x { b_mpos = b_pos b }, count_mpos) + , (b_isize a == computedIsize, \x -> x { b_isize = computedIsize }, count_isize) + , (b_flag a === computedFlag, \x -> x { b_flag = computedFlag }, count_flags) + , (b_flag a =!= computedFlag, \x -> x { b_flag = computedFlag }, count_fflag) + , (b_indices a == common_indices, setIndices common_indices, count_ixs) ] + + message infos = "fixing " ++ shows (b_qname a `S.append` if isFirstMate a then "/1" else "/2") + ": \t" ++ intercalate ", " infos + !computedFlag' = (if b_rname a == invalidRefseq then (.|. flagUnmapped) else id) . + (if b_rname b == invalidRefseq then (.|. flagMateUnmapped) else id) . + (if isReversed b then (.|. flagMateReversed) else (.&. complement flagMateReversed)) . + (if isUnmapped b then (.|. flagMateUnmapped) else (.&. complement flagMateUnmapped)) . + (if isFailsQC b then (.|. flagFailsQC) else id) $ + b_flag a + + !properly_paired = computedFlag' .&. (flagUnmapped .|. flagMateUnmapped) == 0 && b_rname a == b_rname b + !computedFlag = if properly_paired then computedFlag' else computedFlag' .&. complement flagProperlyPaired + !computedIsize = if properly_paired then pos5 b - pos5 a else 0 + + reduce f | f .&. flagMateUnmapped == 0 = f .&. complement flagFailsQC + | otherwise = f .&. complement (flagFailsQC .|. flagMateReversed) + + f1 === f2 = reduce f1 == reduce f2 + f1 =!= f2 = f1 /= f2 && f1 === f2 + + onlyIf f m = (\z -> if z then m else "") `fmap` tells f + + count_mrnm = do modify $ \c -> c { num_mrnm = 1 + num_mrnm c } + let ra = unRefseq (b_mrnm a); rb = unRefseq (b_rname b) + onlyIf report_mrnm $ printf "MRNM %d is wrong (%d)" ra rb + + count_mpos = do modify $ \c -> c { num_mpos = 1 + num_mpos c } + onlyIf report_mpos $ printf "MPOS %d is wrong (%d)" (b_mpos a) (b_pos b) + + count_isize = do modify $ \c -> c { num_isize = 1 + num_isize c } + onlyIf report_isize $ printf "ISIZE %d is wrong (%d)" (b_isize a) computedIsize + + count_flags = do modify $ \c -> c { num_flags = 1 + num_flags c } + onlyIf report_flags $ printf "FLAG %03X is wrong (+%03X,-%03X)" (b_flag a) fp fm + + count_fflag = do modify $ \c -> c { num_fflag = 1 + num_fflag c } + onlyIf report_fflag $ printf "FLAG %03X is technically wrong (+%03X,-%03X)" (b_flag a) fp fm + + count_ixs = do modify $ \c -> c { num_ixs = 1 + num_ixs c } + onlyIf report_ixs $ printf "Index fields %s are wrong (%s)" (show $ b_indices a) (show common_indices) + + fp = computedFlag .&. complement (b_flag a) + fm = complement computedFlag .&. b_flag a + + index_fields = [ "XI", "XJ", "YI", "YJ", "RG", "BC" ] + b_indices x = [ extAsString key x | key <- index_fields ] + common_indices = zipWith max (b_indices a) (b_indices b) + + setIndices is x = x { b_exts = add_new . remove_old $ b_exts x } + where + add_new y = foldr (:) y $ zip index_fields $ map Text is + remove_old y = foldr deleteE y index_fields + +-- | Turns a lone mate into a single. Basically removes the pairing +-- related flags and clear the information concerning the mate. +divorce :: BamRec -> BamRec +divorce b = b { b_flag = b_flag b .&. complement pair_flags + , b_mrnm = invalidRefseq + , b_mpos = invalidPos + , b_isize = 0 } + where + pair_flags = flagPaired .|. flagProperlyPaired .|. + flagFirstMate .|. flagSecondMate .|. + flagMateUnmapped .|. flagMateReversed + +-- I think this can work with priority queues alone: +-- +-- - One contains incomplete pairs ordered by mate position. When we +-- reach a given position and find the 2nd mate, the minimum in this +-- queue must be the 1st mate (or another 1st mate matching another +-- read we'll find here). +-- +-- - One contains incomplete pairs ordered by (hash of) qname. This one +-- is only used if we missed a mate for some reason. After we read +-- the whole input, all remaining pairs can be pulled off this queue +-- in order of increasing (hash of) qname. +-- +-- - At any given position, we will have a number of 1st mates that have +-- been waiting in the queue and a number of 2nd mates that are coming +-- in from the input. We dump both sets into a queue by qname, then +-- pull them out in pairs. Stuff that comes off as anything else than +-- a pair gets queued up again. + +data MatingStats = MS { total_in :: !Int + , total_out :: !Int + , singletons :: !Int + , lone_mates :: !Int + , num_mrnm :: !Int + , num_mpos :: !Int + , num_isize :: !Int + , num_flags :: !Int + , num_fflag :: !Int + , num_ixs :: !Int } + +report_stats :: MatingStats -> String +report_stats ms = unlines [ + "number of records read: " ++ showNum (total_in ms), + "number of records written: " ++ showNum (total_out ms), + "number of true singletons: " ++ showNum (singletons ms), + "number of lone mates: " ++ showNum (lone_mates ms), + "number of repaired MRNM values: " ++ showNum (num_mrnm ms), + "number of repaired MPOS values: " ++ showNum (num_mpos ms), + "number of repaired ISIZE values: " ++ showNum (num_isize ms), + "number of repaired FLAGS values: " ++ showNum (num_flags ms), + "number of common FLAGS problems: " ++ showNum (num_fflag ms), + "number of index field problems: " ++ showNum (num_ixs ms) ] + +data Queues = QS { right_here :: !(PQ ByQName) + , in_order :: !(PQ ByMatePos) + , messed_up :: !(PQ ByQName) } + +withQueues :: (Queues -> IO r) -> IO r +withQueues k = withPQ pqconf $ \h -> + withPQ pqconf $ \o -> + withPQ pqconf $ \m -> + k $ QS h o m + +ms0 :: MatingStats +ms0 = MS 0 0 0 0 0 0 0 0 0 0 + +getSize :: (MonadIO m, Ord a, Binary a, Sizeable a) => (Queues -> PQ a) -> Mating r m Int +getSize sel = getq sel >>= liftIO . sizePQ + +enqueue :: (MonadIO m, Ord a, Binary a, Sizeable a) => a -> (Queues -> PQ a) -> Mating r m () +enqueue a sel = getq sel >>= liftIO . enqueuePQ a + +peekMin :: (MonadIO m, Ord a, Binary a, Sizeable a) => (Queues -> PQ a) -> Mating r m (Maybe a) +peekMin sel = getq sel >>= liftIO . peekMinPQ + +fetchMin :: (MonadIO m, Ord a, Binary a, Sizeable a) => (Queues -> PQ a) -> Mating r m (Maybe a) +fetchMin sel = getq sel >>= liftIO . getMinPQ + +discardMin :: (MonadIO m, Ord a, Binary a, Sizeable a) => (Queues -> PQ a) -> Mating r m () +discardMin sel = getq sel >>= liftIO . getMinPQ >>= \_ -> return () + + +note, warn, err :: MonadIO m => String -> Mating r m () +note msg = do v <- tells verbosity ; unless (v < Notices) $ liftIO $ hPutStrLn stderr $ "[fixpair] info: " ++ msg +warn msg = do v <- tells verbosity ; unless (v < Warnings) $ liftIO $ hPutStrLn stderr $ "[fixpair] warning: " ++ msg +err msg = do v <- tells verbosity ; unless (v < Errors) $ liftIO $ hPutStrLn stderr $ "[fixpair] error: " ++ msg + +report' :: MonadIO m => Mating r m () +report' = do o <- gets total_out + when (o `mod` 0x40000 == 0) $ do + ms <- getSize messed_up + note $ printf "out: %d, mess: %d" o ms + +report :: MonadIO m => BamRaw -> Mating r m () +report br = do i <- gets total_in + o <- gets total_out + when (i `mod` 0x20000 == 0) $ do + hs <- getSize right_here + os <- getSize in_order + ms <- getSize messed_up + rr <- getRefseqs + let BamRec{..} = unpackBam br + rn = unpackSeqid . sq_name $ getRef rr b_rname + at = if b_rname == invalidRefseq || b_pos == invalidPos + then "" else printf "@%s/%d, " rn b_pos + note $ printf "%sin: %d, out: %d, here: %d, wait: %d, mess: %d" (at::String) i o hs os ms + +no_mate_here :: MonadIO m => String -> BamRaw -> Mating r m () +no_mate_here l br = do note $ let b = unpackBam br + in "[" ++ l ++ "] record " + ++ shows (b_qname b) (if isFirstMate b then "/1" else "/2") + ++ " did not have a mate at the right location." + let !br' = br_copy br + enqueue (byQName br') messed_up + +no_mate_ever :: MonadIO m => BamRaw -> Mating r m () +no_mate_ever b = do let b' = unpackBam b + err $ "record " ++ shows (b_qname b') " (" ++ + shows (extAsInt 1 "XI" b') ") did not have a mate at all." + modify $ \c -> c { lone_mates = 1 + lone_mates c } + kill <- tells killmode + case kill of + KillAll -> return () + KillUu -> unless (isUnmapped b') $ yield [divorce b'] + KillNone -> yield [divorce b'] + +-- Basically the CPS version of the State Monad. CPS is necessary to be +-- able to call 'eneeCheckIfDone' in the middle, and that fixes the +-- underlying monad to an 'Iteratee' and the ultimate return type to an +-- 'Iteratee', too. Pretty to work with, not pretty to look at. +type Sink r m = Stream [BamRec] -> Iteratee [BamRec] m r +newtype Mating r m a = Mating { runMating :: + (a -> MatingStats -> Sink r m -> Queues -> Config -> Refs -> Iteratee [BamPair] m (Iteratee [BamRec] m r)) + -> MatingStats -> Sink r m -> Queues -> Config -> Refs -> Iteratee [BamPair] m (Iteratee [BamRec] m r) } + +instance Functor (Mating r m) where + fmap f m = Mating $ \k -> runMating m (k . f) + +instance Applicative (Mating r m) where + pure a = Mating $ \k -> k a + u <*> v = Mating $ \k -> runMating u (\a -> runMating v (k . a)) + +instance Monad (Mating r m) where + return a = Mating $ \k -> k a + m >>= k = Mating $ \k2 -> runMating m (\a -> runMating (k a) k2) + +instance MonadIO m => MonadIO (Mating r m) where + liftIO f = Mating $ \k s o q c r -> liftIO f >>= \a -> k a s o q c r + +instance MonadTrans (Mating r) where + lift m = Mating $ \k s o q c r -> lift m >>= \a -> k a s o q c r + +lift'it :: Monad m => Iteratee [BamPair] m a -> Mating r m a +lift'it m = Mating $ \k s o q c r -> m >>= \a -> k a s o q c r + +tells :: (Config -> a) -> Mating r m a +tells f = Mating $ \k s o q c -> k (f c) s o q c + +gets :: (MatingStats -> a) -> Mating r m a +gets f = Mating $ \k s -> k (f s) s + +getq :: (Queues -> a) -> Mating r m a +getq f = Mating $ \k s o q -> k (f q) s o q + +modify :: (MatingStats -> MatingStats) -> Mating r m () +modify f = Mating $ \k s -> (k () $! f s) + +getRefseqs :: Mating r m Refs +getRefseqs = Mating $ \k s o q c r -> k r s o q c r + +fetchNext :: MonadIO m => Mating r m (Maybe BamPair) +fetchNext = do r <- lift'it tryHead + case r of Nothing -> return () + Just (Singleton x) -> do modify $ \s -> s { total_in = 1 + total_in s } ; report x + Just (Pair _ x) -> do modify $ \s -> s { total_in = 2 + total_in s } ; report x + Just (LoneMate x) -> do modify $ \s -> s { total_in = 1 + total_in s } ; report x + return r + +yield :: MonadIO m => [BamRec] -> Mating r m () +yield rs = Mating $ \k s o q c r -> let !s' = s { total_out = length rs + total_out s } + in eneeCheckIfDone (\o' -> k () s' o' q c r) . o $ Chunk rs + +-- To ensure proper cleanup, we require the priority queues to be created +-- outside. Since one is continually reused, it is important that a PQ +-- that is emptied no longer holds on to files on disk. +re_pair :: MonadIO m => Queues -> Config -> Refs -> Enumeratee [BamPair] [BamRec] m a +re_pair qs cf rs = eneeCheckIfDone $ \out -> runMating go finish ms0 out qs cf rs + where + go = fetchNext >>= go' + + -- At EOF, flush everything. + go' Nothing = peekMin right_here >>= \mm -> case mm of + Just (ByQName _ _ qq) -> do complete_here (br_self_pos qq) + flush_here Nothing -- flush_here loops back here + Nothing -> flush_in_order -- this ends the whole operation + + -- Single read? Pass through and go on. + -- Paired read? Does it belong 'here'? + go' (Just (Singleton x)) = modify (\c -> c { singletons = 1 + singletons c }) >> yield [unpackBam x] >> go + go' (Just (Pair x y)) = fixmate x y >>= yield >> go + go' (Just (LoneMate r)) = peekMin right_here >>= \mm -> case mm of + + -- there's nothing else here, so here becomes redefined + Nothing -> enqueueThis r >> go + + Just (ByQName _ _ qq) -> case compare (br_self_pos r) (br_self_pos qq) of + -- nope, r is out of order and goes to 'messed_up' + LT -> do warn $ "record " ++ show (br_qname r) ++ " is out of order." + let !r' = br_copy r + enqueue (byQName r') messed_up + go + + -- nope, r comes later. we need to finish our business here + GT -> do complete_here (br_self_pos qq) + flush_here (Just (LoneMate r)) + + -- it belongs here or there is nothing else here + EQ -> enqueueThis r >> go + + + -- lonely guy, belongs either here or needs to wait for the mate + enqueueThis r | br_self_pos r >= br_mate_pos r = enqueue (byQName r) right_here + | otherwise = r' `seq` enqueue (ByMatePos r') in_order + where r' = br_copy r + + -- Flush the in_order queue to messed_up, since those didn't find + -- their mate the ordinary way. Afterwards, flush the messed_up + -- queue. + flush_in_order = fetchMin in_order >>= \zz -> case zz of + Just (ByMatePos b) -> no_mate_here "flush_in_order" b >> flush_in_order + Nothing -> flush_messed_up + + -- Flush the messed up queue. Everything should come off in pairs, + -- unless something is broken. + flush_messed_up = fetchMin messed_up >>= flush_mess1 + + flush_mess1 Nothing = return () + flush_mess1 (Just (ByQName _ ai a)) = fetchMin messed_up >>= flush_mess2 ai a + + flush_mess2 _ a Nothing = no_mate_ever a + + flush_mess2 ai a b'@(Just (ByQName _ bi b)) + | ai /= bi || br_qname a /= br_qname b = no_mate_ever a >> report' >> flush_mess1 b' + | otherwise = fixmate a b >>= yield >> report' >> flush_messed_up + + + -- Flush the right_here queue. Everything should come off in pairs, + -- if not, it goes to messed_up. When done, loop back to 'go' + flush_here r = fetchMin right_here >>= flush_here1 r + + flush_here1 r Nothing = go' r + flush_here1 r (Just a) = fetchMin right_here >>= flush_here2 r a + + flush_here2 r (ByQName _ _ a) Nothing = do no_mate_here "flush_here2/Nothing" a + flush_here r + + flush_here2 r (ByQName _ ai a) b'@(Just (ByQName _ bi b)) + | ai /= bi || br_qname a /= br_qname b = no_mate_here "flush_here2/Just" a >> flush_here1 r b' + | otherwise = fixmate a b >>= yield >> flush_here r + + + -- add stuff coming from 'in_order' to 'right_here' + complete_here pivot = do + zz <- peekMin in_order + case zz of + Nothing -> return () + Just (ByMatePos b) + | pivot > br_mate_pos b -> do discardMin in_order + no_mate_here "complete_here" b + complete_here pivot + + | pivot == br_mate_pos b -> do discardMin in_order + enqueue (byQName b) right_here + complete_here pivot + + | otherwise -> return () + + finish () st o _qs _cf _rs = do liftIO $ hPutStrLn stderr $ report_stats st + return (liftI o) + +data ByQName = ByQName { _bq_hash :: !Int + , _bq_alnid :: !Int + , _bq_rec :: !BamRaw } + +byQName :: BamRaw -> ByQName +byQName b = ByQName (hash $ br_qname b) (extAsInt 0 "XI" $ unpackBam b) b + +instance Eq ByQName where + ByQName ah ai a == ByQName bh bi b = + (ah, ai, br_qname a) == (bh, bi, br_qname b) + +instance Ord ByQName where + ByQName ah ai a `compare` ByQName bh bi b = + (ah, ai, b_qname (unpackBam a)) `compare` (bh, bi, b_qname (unpackBam b)) + +newtype ByMatePos = ByMatePos BamRaw + +instance Eq ByMatePos where + ByMatePos a == ByMatePos b = + br_mate_pos a == br_mate_pos b + +instance Ord ByMatePos where + ByMatePos a `compare` ByMatePos b = + br_mate_pos a `compare` br_mate_pos b + +instance Binary ByQName where put = undefined ; get = undefined -- XXX +instance Binary ByMatePos where put = undefined ; get = undefined -- XXX + +instance Sizeable ByQName where usedBytes = undefined -- XXX +instance Sizeable ByMatePos where usedBytes = undefined -- XXX + +br_mate_pos :: BamRaw -> (Refseq, Int) +br_mate_pos = (b_mrnm &&& b_mpos) . unpackBam + +br_self_pos :: BamRaw -> (Refseq, Int) +br_self_pos = (b_rname &&& b_pos) . unpackBam + +br_qname :: BamRaw -> Seqid +br_qname = b_qname . unpackBam + +br_copy :: BamRaw -> BamRaw +br_copy br = bamRaw (virt_offset br) $! S.copy (raw_data br) + + + +-- | To catch pairs whose mates are adjacent (either because the file +-- has never been sorted or because it has been group-sorted), we apply +-- preprocessing. The idea is that if we can catch these pairs early, +-- the priority queues never fill up and we save a ton of processing. +-- Now to make the re-pair algorithm work well, we need to merge-sort +-- inputs. But after that, the pairs have been separated. So we apply +-- the preprocessing to each input file, then merge then, then run +-- re-pair. + +data BamPair = Singleton BamRaw | Pair BamRaw BamRaw | LoneMate BamRaw + + +mergeInputs :: (MonadIO m, MonadMask m) => [FilePath] -> Enumerator' BamMeta [BamPair] m a +mergeInputs = go0 + where + go0 [ ] = enumG $ enumHandle defaultBufSize stdin + go0 (fp0:fps0) = go fp0 fps0 + + go fp [ ] = enum1 fp + go fp (fp1:fps) = mergeEnums' (go fp1 fps) (enum1 fp) combineCoordinates + + enum1 "-" = enumG $ enumHandle defaultBufSize stdin + enum1 fp = enumG $ enumFile defaultBufSize fp + + enumG ee k = ee >=> run $ joinI $ decodeAnyBam $ \h -> quick_pair (k h) + + +quick_pair :: Monad m => Enumeratee [BamRaw] [BamPair] m a +quick_pair = eneeCheckIfDone go0 + where + go0 k = tryHead >>= maybe (return $ liftI k) (\x -> go1 x k) + + go1 x k | not (isPaired (unpackBam x)) = eneeCheckIfDone go0 . k $ Chunk [Singleton x] + | otherwise = tryHead >>= maybe (return . k $ Chunk [LoneMate x]) (\y -> go2 x y k) + + go2 x y k | b_qname (unpackBam x) == b_qname (unpackBam y) = eneeCheckIfDone go0 . k $ Chunk [Pair x y] + | otherwise = eneeCheckIfDone (go1 y) . k $ Chunk [LoneMate x] + + +combineCoordinates :: Monad m => BamMeta -> Enumeratee [BamPair] [BamPair] (Iteratee [BamPair] m) a +combineCoordinates _ = mergeSortStreams (?) + where u ? v = if (bp_rname u, bp_pos u) < (bp_rname v, bp_pos v) then Less else NotLess + +bp_rname :: BamPair -> Refseq +bp_rname (Singleton u) = b_rname $ unpackBam u +bp_rname (Pair u _) = b_rname $ unpackBam u +bp_rname (LoneMate u) = b_rname $ unpackBam u + +bp_pos :: BamPair -> Int +bp_pos (Singleton u) = b_pos $ unpackBam u +bp_pos (Pair u _) = b_pos $ unpackBam u +bp_pos (LoneMate u) = b_pos $ unpackBam u + diff --git a/tools/bam-meld.hs b/tools/bam-meld.hs new file mode 100644 --- /dev/null +++ b/tools/bam-meld.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +-- Reads multiple BAM files, melds them by keeping the best hit for +-- every entry. All input files must be parallel (same reads, same +-- order, no omissions). The best hit and the new mapq are calculated +-- by combining appropriate optional fields. Presets exist for common +-- types of aligners, other schemes can be configured flexibly. +-- +-- Paired end support is easy: since all input files are either +-- unsorted (and strictly parallel) or sorted by read name, pairs are +-- also sorted together. So all we have to do is (maybe) exchange first +-- and seocnd mate. + +import Bio.Base +import Bio.Bam.Header +import Bio.Bam.Reader +import Bio.Bam.Rec +import Bio.Bam.Writer +import Bio.Iteratee +import Control.Monad ( unless, foldM ) +import Data.List ( sortBy ) +import Data.Monoid +import Data.String ( fromString ) +import Data.Version ( showVersion ) +import Paths_biohazard ( version ) +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) +import System.Exit ( exitSuccess, exitFailure ) +import System.IO ( hPutStrLn ) + +import qualified Data.ByteString.Char8 as S +import qualified Data.Sequence as Z + +data Conf = Conf { + c_score :: Maybe (BamPair -> Int), + c_output :: BamMeta -> Iteratee [BamRec] IO (), + c_merge :: Enumeratee [BamPair] [[BamPair]] (Iteratee [[BamPair]] IO) () } + +defaultConf :: Conf +defaultConf = Conf Nothing (protectTerm . pipeBamOutput) iter_transpose + +defaultScore :: BamPair -> Int +defaultScore r = 30 * getExt "XM" r + 45 * getExt "XO" r + 15 * getExt "XG" r + +getExt :: BamKey -> BamPair -> Int +getExt k (Single a) = extAsInt 0 k a +getExt k (Pair a b) = extAsInt 0 k a + extAsInt 0 k b + + +-- | Enumerates a list of BAM files. Meta records are merged sensibly, +-- records are merged using the supplied "merging Enumeratee". Results +-- in something close to an Enumerator (not quite, because the merged +-- headers need to be passed along). +enum_bam_files :: (MonadIO m, MonadMask m) + => Enumeratee [BamPair] [[BamPair]] (Iteratee [[BamPair]] m) a + -> [ FilePath ] + -> Enumerator' BamMeta [[BamPair]] m a +enum_bam_files _etee [ ] = return . ($ mempty) +enum_bam_files etee (f1:fs1) = go (decodeAnyBamOrSamFile f1 $== find_pairs $== mapStream (:[])) fs1 + where + go e1 [ ] k = e1 k + go e1 (f:fs) k = go e1 fs $ + \h1 -> (decodeAnyBamOrSamFile f $== adjust h1 $== find_pairs) + (\h2 -> joinI . etee $ ilift lift (k $ h1 `mappend` h2)) >>= run + + -- How to merge? We keep the stream from e1 as is, the refids in + -- e2 are shifted down by the number of refseqs in h1. Headers + -- are merged by concatenating the reference lists and appending + -- the headers using mappend. The Monoid instance does + -- everything. + + adjust h = let o = Z.length . meta_refs $ h + f br = br { b_rname = b_rname br `plus` o + , b_mrnm = b_mrnm br `plus` o } + in mapStream f + + r `plus` _ | r == invalidRefseq = r + Refseq r `plus` o = Refseq (r + fromIntegral o) + +data BamPair = Single BamRec | Pair BamRec BamRec + +find_pairs :: Monad m => Enumeratee [BamRec] [BamPair] m a +find_pairs = mapStream Single + +unpair :: Monad m => Enumeratee [BamPair] [BamRec] m a +unpair = mapChunks (concatMap unpair1) + where + unpair1 (Single a) = [a] + unpair1 (Pair a b) = [a,b] + +p_qname :: BamPair -> Seqid +p_qname (Single a) = b_qname a +p_qname (Pair a _) = b_qname a + +p_mapq :: BamPair -> Qual +p_mapq (Single a) = b_mapq a +p_mapq (Pair a _) = b_mapq a + +p_is_unmapped :: BamPair -> Bool +p_is_unmapped (Single a) = isUnmapped a +p_is_unmapped (Pair a b) = isUnmapped a && isUnmapped b + +set_mapq :: BamPair -> Qual -> BamPair +set_mapq (Single a) q = Single (a { b_mapq = q }) +set_mapq (Pair a b) q = Pair (a { b_mapq = q }) (b { b_mapq = q }) + +meld :: BamMeta -> (BamPair -> Int) -> [BamPair] -> BamPair +meld hdr score rs | all p_is_unmapped rs = head rs + | all_equal (map p_qname rs) = set_mapq best' mapq + | otherwise = error $ "BAMs are not in the same order or sequences are missing: " + ++ show (map p_qname rs) + where + all_equal [] = error "no input (not supposed to happen)" + all_equal (x:xs) = all ((==) x) xs + + ( best : rs' ) = sortBy (\a b -> score a `compare` score b) $ filter (not . p_is_unmapped) rs + mapq = case rs' of [ ] -> p_mapq best + (r2:_) -> Q . fromIntegral $ fromIntegral (unQ (p_mapq best)) + `min` (score r2 - score best) + + + split_xa br = let s = extAsString "XA" br in if S.null s then id else (++) (S.split ';' s) + + get_xas (Single a) (one,two) = (split_xa a one, two) + get_xas (Pair a b) (one,two) = (split_xa a one, split_xa b two) + + (xas1, xas2) = foldr enc_xas (foldr get_xas ([],[]) (best:rs')) rs' + + add_xas xas b = b { b_exts = updateE "XA" (Text (S.intercalate (S.singleton ';') xas)) (b_exts b) } + + best' = case best of Single a -> Single (add_xas xas1 a) + Pair a b -> Pair (add_xas xas1 a) (add_xas xas2 b) + + enc_xas (Single a) (one,two) = (encode a one,two) + enc_xas (Pair a b) (one,two) = (encode a one,encode b two) + + encode b xas | isUnmapped b = xas + | otherwise = S.intercalate (S.singleton ',') [ rnm, pos, cig, nm ] : xas + where + nm = S.pack $ show $ extAsInt 0 "NM" b + pos = S.pack $ (if isReversed b then '-' else '+') : show (b_pos b) + rnm = sq_name $ getRef (meta_refs hdr) (b_rname b) + cig = S.pack $ show $ b_cigar b + + +options :: [OptDescr (Conf -> IO Conf)] +options = + [ Option "o" ["output"] (ReqArg set_output "FILE") "Send output to FILE" + , Option "u" ["unsorted"] (NoArg set_unsorted) "Input is unsorted" + , Option "s" ["sorted"] (NoArg set_sorted) "Input is sorted by name" + , Option "w" ["weight"] (ReqArg set_weight "XX:Y") "Set the badness of field XX to Y" + , Option [ ] ["bwa"] (NoArg set_bwa) "Preset for alignments from 'bwa' (uses XM, XO, XG)" + , Option [ ] ["anfo"] (NoArg set_anfo) "Preset for alignments from 'anfo' (uses UQ, PQ)" + , Option [ ] ["blast"] (NoArg set_blast) "Preset for alignments from 'blast' (uses AS)" + , Option [ ] ["blat"] (NoArg set_blat) "Preset for alignments from 'blat' (uses NM)" + , Option "h?" ["help","usage"] (NoArg usage) "Display this information and exit" + , Option "V" ["version"] (NoArg vrsn) "Display version number and exit" ] + +vrsn :: Conf -> IO Conf +vrsn _ = do pn <- getProgName + hPutStrLn stderr $ pn ++ ", version " ++ showVersion version + exitSuccess + +usage :: Conf -> IO Conf +usage _ = putStrLn (usageInfo blurb options) >> exitSuccess + where + blurb = "Merges multiple bam files containing the same sequences, keeping only\n\ + \the best hit for each. Attempts to be configurable to bam files from\n\ + \various sources and attempts to calculate a sensible map quality.\n" + +set_output :: String -> Conf -> IO Conf +set_output "-" c = return $ c { c_output = pipeBamOutput } +set_output fn c = return $ c { c_output = writeBamFile fn } + +set_unsorted :: Conf -> IO Conf +set_unsorted c = return $ c { c_merge = iter_transpose } + +set_sorted :: Conf -> IO Conf +set_sorted c = return $ c { c_merge = merge_by_name } + +set_weight :: String -> Conf -> IO Conf +set_weight (a:b:':':rest) c = do + w <- readIO rest + let f = \r -> getExt (fromString [a,b]) r * w + maybe 0 ($ r) (c_score c) + return $ c { c_score = Just f } +set_weight s _ = error $ "illegal weight specification " ++ show s + +set_bwa, set_anfo, set_blat, set_blast :: Conf -> IO Conf +set_bwa c = return $ c { c_score = Just defaultScore } +set_anfo c = return $ c { c_score = Just $ \r -> getExt "UQ" r } +set_blat c = return $ c { c_score = Just $ \r -> getExt "NM" r * 30 } +set_blast c = return $ c { c_score = Just $ \r -> getExt "AS" r * (-3) } + +main :: IO () +main = do + ( opts, files, errors ) <- getOpt Permute options `fmap` getArgs + conf <- foldM (flip id) defaultConf opts + + let errors' | null files = "no input files" : errors + | otherwise = errors + + unless (null errors') $ do + mapM_ (hPutStrLn stderr) errors' + exitFailure + + add_pg <- addPG (Just version) + enum_bam_files (c_merge conf) files >=> run $ \hdr -> + joinI $ mapStream (meld hdr $ maybe defaultScore id $ c_score conf) $ + joinI $ unpair $ c_output conf (add_pg hdr) + + +iter_transpose :: Monad m => Enumeratee [BamPair] [[BamPair]] (Iteratee [[BamPair]] m) a +iter_transpose = eneeCheckIfDone step + where + step k = do mx <- tryHead ; my <- lift tryHead ; step' k mx my + + step' k Nothing Nothing = idone (liftI k) $ EOF Nothing + step' k (Just x) (Just ys) | p_qname x == p_qname (head ys) = iter_transpose . k $ Chunk [x:ys] + step' _ _ _ = error "files do not contain the same query records" + +merge_by_name :: Monad m => Enumeratee [BamPair] [[BamPair]] (Iteratee [[BamPair]] m) a +merge_by_name = ensure_sorting ><> merge' + where + merge' = eneeCheckIfDone (\k -> tryHead >>= \mx -> lift tryHead >>= \my -> merge''' k mx my) + merge'x my = eneeCheckIfDone (\k -> tryHead >>= \mx -> merge''' k mx my) + merge'y mx = eneeCheckIfDone (\k -> lift tryHead >>= \my -> merge''' k mx my) + + merge''' k Nothing Nothing = idone (liftI k) $ EOF Nothing + merge''' k Nothing (Just ys) = merge'y Nothing . k $ Chunk [ys] + merge''' k (Just x) Nothing = merge'x Nothing . k $ Chunk [[x]] + merge''' k (Just x) (Just ys) = case p_qname x `compareNames` p_qname (head ys) of + LT -> merge'x (Just ys) . k $ Chunk [[ x ]] + EQ -> merge' . k $ Chunk [ x:ys ] + GT -> merge'y (Just x) . k $ Chunk [ ys ] + +ensure_sorting :: Monad m => Enumeratee [BamPair] [BamPair] m a +ensure_sorting = eneeCheckIfDonePass (icont . step) + where + step k (EOF mx) = idone (liftI k) $ EOF mx + step k (Chunk [ ]) = liftI $ step k + step k (Chunk (x:xs)) = step' x k $ Chunk xs + + step' x1 k (EOF mx) = idone (k $ Chunk [ x1 ]) $ EOF mx + step' x1 k (Chunk []) = liftI $ step' x1 k + step' x1 k (Chunk (x2:xs)) = case p_qname x1 `compareNames` p_qname x2 of + GT -> error "input is not sorted by qname" + _ -> eneeCheckIfDone (\k' -> step' x2 k' (Chunk xs)) . k $ Chunk [ x1 ] + diff --git a/tools/bam-resample.hs b/tools/bam-resample.hs new file mode 100644 --- /dev/null +++ b/tools/bam-resample.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BangPatterns #-} +-- Resample m out of n `virtual' BAM records. +-- +-- Strategy for fair down sampling: we first count the number of +-- records, then scan again to sample. Input must be grouped by QNAME +-- (sorted by QNAME is fine). +-- +-- Usage: resample [NUM] [FILE...] + +import Bio.Bam.Header +import Bio.Bam.Reader +import Bio.Bam.Rec +import Bio.Bam.Writer +import Bio.Iteratee +import Data.Version ( showVersion ) +import Paths_biohazard ( version ) +import System.Environment +import System.Exit ( exitFailure ) +import System.Random +import System.IO ( hPutStr ) + +main :: IO () +main = do + args <- getArgs + case args of + [] -> complain + [_num] -> complain + num_ : files -> case reads num_ of + [(num,"")] -> main' num files + _ -> complain + +complain :: IO () +complain = do pn <- getProgName + hPutStr stderr $ pn ++ ", version " ++ showVersion version + ++ "\nUsage: " ++ pn ++ " [file...]\n" + exitFailure + +main' :: Int -> [String] -> IO () +main' num files = do + hPutStr stderr "counting... " + total <- enumInputs files >=> run $ + joinI $ decodeAnyBam $ \_hdr -> + joinI $ groupOn (b_qname . unpackBam) $ + foldStream (\a _ -> 1+a) 0 + hPutStr stderr $ shows total " records.\n" + + add_pg <- addPG (Just version) + enumInputs files >=> run $ + joinI $ decodeAnyBam $ + joinI . groupOn (b_qname . unpackBam) . + joinI . resample num total . + protectTerm . pipeBamOutput . add_pg + + +resample :: MonadIO m => Int -> Int -> Enumeratee [[BamRaw]] [BamRaw] m a +resample m0 n0 | m0 > n0 = error "upsampling requested" +resample m0 n0 = eneeCheckIfDone (go m0 n0) + where + go !m !n k = tryHead >>= maybe (return (liftI k)) (go' m n k) + go' !m !n k a = do r <- liftIO $ randomRIO (0,n-1) + if r < m + then eneeCheckIfDone (go (m-1) (n-1)) . k $ Chunk a + else go m (n-1) k + +groupOn :: (Monad m, Eq b) => (a -> b) -> Enumeratee [a] [[a]] m c +groupOn f = eneeCheckIfDone (\k -> tryHead >>= maybe (return $ liftI k) (\a -> go k [a] (f a))) + where + go k acc fa = tryHead >>= maybe (return . k $ Chunk [reverse acc]) (go' k acc fa) + go' k acc fa b | fa == f b = go k (b:acc) fa + | otherwise = eneeCheckIfDone (\k' -> go k' [b] (f b)) . k $ Chunk [reverse acc] diff --git a/tools/bam-rewrap.hs b/tools/bam-rewrap.hs new file mode 100644 --- /dev/null +++ b/tools/bam-rewrap.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE BangPatterns #-} +-- Re-wrap alignments to obey the given length of the reference +-- sequence. +-- +-- The idea is that a circular reference sequence has been extended +-- artificially to facilitate alignment. Now the declared length in the +-- header is wrong, and the alignments overhang the end. Here we split +-- those alignments into two, one for the beginning, one for the end of +-- the sequence, then soft-mask out the inappropriate parts. +-- +-- What's the best course of action, operationally? As usual, we need +-- to decide whether to rely on sorted input and whether to produce +-- sorted output, and how much to copy senselessly. +-- +-- In a sane world, this program runs precisely once, after alignment, +-- and output is piped somewhere. So that's what we do: input is +-- unsorted, so is output, output is piped (and hence uncompressed). +-- We also fix the header while we're at it. +-- +-- We try to fix the map quality for the affected reads as follows: if +-- a read has map quality 0 (meaning multiple equally good hits), we +-- check the XA field. If it reports exactly one additional alignment, +-- and it matches the primary alignment when transformed to canonical +-- coordinates, we remove XA and set MAPQ to 37. + +import Bio.Bam +import Bio.Bam.Rmdup +import Control.Monad ( when ) +import Data.Foldable ( toList ) +import Data.Version ( showVersion ) +import Paths_biohazard ( version ) +import System.Environment ( getArgs, getProgName ) +import System.Exit ( exitFailure ) +import System.IO ( hPutStr ) + +import qualified Data.ByteString.Char8 as S +import qualified Data.Map as M +import qualified Data.Sequence as Z + +usage :: IO a +usage = do pn <- getProgName + hPutStr stderr $ pn ++ ", version " ++ showVersion version ++ + "\nUsage: " ++ pn ++ " [chrom:length...]\n\ + \Pipes a BAM file from stdin to stdout and for every 'chrom'\n\ + \mentioned on the command line, wraps alignments to a new \n\ + \target length of 'length'.\n" + exitFailure + +main :: IO () +main = getArgs >>= \args -> + when (null args) usage >>= \_ -> + enumHandle defaultBufSize stdin >=> run $ + joinI $ decodeAnyBam $ \hdr -> do + add_pg <- liftIO (addPG $ Just version) + let (ltab, seqs') = parseArgs (meta_refs hdr) args + joinI $ mapChunks (concatMap (rewrap (M.fromList ltab) . unpackBam)) + $ protectTerm $ pipeBamOutput (add_pg hdr { meta_refs = seqs' }) + +parseArgs :: Refs -> [String] -> ([(Refseq,(Int,S.ByteString))], Refs) +parseArgs refs | Z.null refs = error $ "no target sequences found (empty input?)" + | otherwise = foldl parseArg ([],refs) + where + parseArg (sqs, h) arg = case break (==':') arg of + (nm,':':r) -> case reads r of + [(l,[])] | l > 0 -> case filter (S.isPrefixOf (S.pack nm) . sq_name . snd) $ zip [0..] $ toList h of + [(k,a)] | sq_length a >= l -> ( (Refseq $ fromIntegral k,(l, sq_name a)):sqs, Z.update k (a { sq_length = l }) h ) + | otherwise -> error $ "cannot wrap " ++ show nm ++ " to " ++ show l + ++ ", which is more than the original " ++ show (sq_length a) + [] -> error $ "no match for target sequence " ++ show nm + _ -> error $ "target sequence " ++ show nm ++ " is ambiguous" + _ -> error $ "couldn't parse length " ++ show r ++ " for " ++ show nm + _ -> error $ "couldn't parse argument " ++ show arg + + + +-- | This runs both stages of the rewrapping: First normalize alignments +-- (POS must be in the canonical interval) and fix XA, MPOS, MAPQ where +-- appropriate, then duplicate the read and softmask the noncanonical +-- parts. Rmdup fits in between the two, hence the split +rewrap :: M.Map Refseq (Int,S.ByteString) -> BamRec -> [BamRec] +rewrap m b = maybe [b] (\(l,nm) -> wrapTo l $ normalizeTo nm l b) + $ M.lookup (b_rname b) m + diff --git a/tools/bam-rmdup.hs b/tools/bam-rmdup.hs new file mode 100644 --- /dev/null +++ b/tools/bam-rmdup.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE RecordWildCards, BangPatterns, FlexibleContexts, OverloadedStrings #-} +import Bio.Bam +import Bio.Bam.Rmdup +import Bio.Base +import Bio.Util ( showNum, showOOM, estimateComplexity ) +import Control.Monad +import Control.Monad.ST ( runST ) +import Data.Bits +import Data.Foldable ( toList ) +import Data.List ( intercalate ) +import Data.Maybe +import Data.Monoid ( mempty ) +import Data.Ord ( comparing ) +import Data.Vector.Algorithms.Intro ( sortBy ) +import Data.Version ( showVersion ) +import Numeric ( showFFloat ) +import Paths_biohazard ( version ) +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) +import System.Exit +import System.IO + +import qualified Data.ByteString.Char8 as S +import qualified Data.HashMap.Strict as M +import qualified Data.IntMap as IM +import qualified Data.Iteratee as I +import qualified Data.Sequence as Z +import qualified Data.Vector as VV +import qualified Data.Vector.Generic as V + +data Conf = Conf { + output :: Maybe ((BamRec -> Seqid) -> BamMeta -> Iteratee [BamRec] IO ()), + strand_preserved :: Bool, + collapse :: Bool -> Collapse, + clean_multimap :: BamRec -> IO (Maybe BamRec), + keep_all :: Bool, + keep_unaligned :: Bool, + keep_improper :: Bool, + transform :: BamRec -> Maybe BamRec, + min_len :: Int, + min_qual :: Qual, + get_label :: M.HashMap Seqid Seqid -> BamRec -> Seqid, + putResult :: String -> IO (), + debug :: String -> IO (), + which :: Which, + circulars :: Refs -> IO (IM.IntMap (Seqid,Int), Refs) } + +-- | Which reference sequences to scan +data Which = All | Some Refseq Refseq | Unaln deriving Show + +defaults :: Conf +defaults = Conf { output = Nothing + , strand_preserved = True + , collapse = cons_collapse' (Q 60) + , clean_multimap = check_flags + , keep_all = False + , keep_unaligned = False + , keep_improper = False + , transform = Just + , min_len = 0 + , min_qual = Q 0 + , get_label = get_library + , putResult = putStr + , debug = \_ -> return () + , which = All + , circulars = \rs -> return (IM.empty, rs) } + +options :: [OptDescr (Conf -> IO Conf)] +options = [ + Option "o" ["output"] (ReqArg set_output "FILE") "Write to FILE (default: no output, count only)", + Option "O" ["output-lib"] (ReqArg set_lib_out "PAT") "Write each lib to file named following PAT", + Option [ ] ["debug"] (NoArg set_debug_out) "Write textual debugging output", + Option "z" ["circular"] (ReqArg add_circular "CHR:LEN") "Refseq CHR is circular with length LEN", + Option "R" ["refseq"] (ReqArg set_range "RANGE") "Read only range of reference sequences", + Option "p" ["improper-pairs"] (NoArg set_improper) "Include improper pairs", + Option "u" ["unaligned"] (NoArg set_unaligned) "Include unaligned reads and pairs", + Option "1" ["single-read"] (NoArg set_single) "Pretend there is no second mate", + Option "m" ["multimappers"] (NoArg set_multi) "Process multi-mappers (by dropping secondary alignments)", + Option "c" ["cheap"] (NoArg set_cheap) "Cheap computation: skip the consensus calling", + Option "k" ["keep","mark-only"](NoArg set_keep) "Mark duplicates, but include them in output", + Option "Q" ["max-qual"] (ReqArg set_qual "QUAL") "Set maximum quality after consensus call to QUAL", + Option "l" ["min-length"] (ReqArg set_len "LEN") "Discard reads shorter than LEN", + Option "q" ["min-mapq"] (ReqArg set_mapq "QUAL") "Discard reads with map quality lower than QUAL", + Option "s" ["no-strand"] (NoArg set_no_strand) "Strand of alignments is uninformative", + Option "r" ["ignore-rg"] (NoArg set_no_rg) "Ignore read groups when looking for duplicates", + Option "v" ["verbose"] (NoArg set_verbose) "Print more diagnostics", + Option "h?" ["help","usage"] (NoArg (const usage)) "Display this message", + Option "V" ["version"] (NoArg (const vrsn)) "Display version number and exit" ] + + where + set_output "-" c = return $ c { output = Just $ \_ -> pipeBamOutput, putResult = hPutStr stderr } + set_output f c = return $ c { output = Just $ \_ -> writeBamFile f } + set_lib_out f c = return $ c { output = Just $ writeLibBamFiles f } + set_debug_out c = return $ c { output = Just $ \_ -> pipeSamOutput, putResult = hPutStr stderr } + set_qual n c = readIO n >>= \q -> return $ c { collapse = cons_collapse' (Q q) } + set_no_strand c = return $ c { strand_preserved = False } + set_verbose c = return $ c { debug = hPutStr stderr } + set_improper c = return $ c { keep_improper = True } + set_single c = return $ c { transform = make_single } + set_cheap c = return $ c { collapse = cheap_collapse' } + set_keep c = return $ c { keep_all = True } + set_unaligned c = return $ c { keep_unaligned = True } + set_len n c = readIO n >>= \l -> return $ c { min_len = l } + set_mapq n c = readIO n >>= \q -> return $ c { min_qual = Q q } + set_no_rg c = return $ c { get_label = get_no_library } + set_multi c = return $ c { clean_multimap = clean_multi_flags } + + set_range a c + | a == "A" || a == "a" = return $ c { which = All } + | a == "U" || a == "u" = return $ c { which = Unaln } + | otherwise = case reads a of + [ (x,"") ] -> return $ c { which = Some (Refseq $ x-1) (Refseq $ x-1) } + [ (x,'-':b) ] -> readIO b >>= \y -> + return $ c { which = Some (Refseq $ x-1) (Refseq $ y-1) } + _ -> fail $ "parse error in " ++ show a + + add_circular a c = case break ((==) ':') a of + (nm,':':r) -> case reads r of + [(l,[])] | l > 0 -> return $ c { circulars = add_circular' (S.pack nm) l (circulars c) } + _ -> fail $ "couldn't parse length " ++ show r ++ " for " ++ show nm + _ -> fail $ "couldn't parse \"circular\" argument " ++ show a + + add_circular' nm l io refs = do + (m1, refs') <- io refs + case filter (S.isPrefixOf nm . sq_name . snd) $ zip [0..] $ toList refs' of + [(k,a)] | sq_length a >= l -> let m2 = IM.insert k (sq_name a,l) m1 + refs'' = Z.update k (a { sq_length = l }) refs' + in return (m2, refs'') + | otherwise -> fail $ "cannot wrap " ++ show nm ++ " to " ++ show l + ++ ", which is more than the original " ++ show (sq_length a) + [] -> fail $ "no match for target sequence " ++ show nm + _ -> fail $ "target sequence " ++ show nm ++ " is ambiguous" + +vrsn :: IO a +vrsn = do pn <- getProgName + hPutStrLn stderr $ pn ++ ", version " ++ showVersion version + exitSuccess + +usage :: IO a +usage = do p <- getProgName + hPutStrLn stderr $ "Usage: " ++ usageInfo (p ++ info) options + exitSuccess + where + info = " [option...] [bam-file...]\n\ + \Removes PCR duplicates from BAM files and calls a consensus for each duplicate set. \n\ + \Input files must be sorted by coordinate and are merged on the fly. Options are:" + +cons_collapse' :: Qual -> Bool -> Collapse +cons_collapse' m False = cons_collapse m +cons_collapse' m True = cons_collapse_keep m + +cheap_collapse' :: Bool -> Collapse +cheap_collapse' False = cheap_collapse +cheap_collapse' True = cheap_collapse_keep + +-- | Get library from BAM record. +-- This gets the read group from a bam record, then the library for read +-- group. This will work correctly if and only if the RG-LB field is +-- the name of the "Ur-Library", the common one before the first +-- amplification. +-- +-- If no RG-LB field is present, RG-SM is used instead. This will work +-- if and only if no libraries were aliquotted and then pooled again. +-- +-- Else the RG-ID field is used. This will work if and only if read +-- groups correspond directly to libraries. +-- +-- If no RG is present, the empty string is returned. This serves as +-- fall-back. + +get_library, get_no_library :: M.HashMap Seqid Seqid -> BamRec -> Seqid +get_library tbl br = M.lookupDefault rg rg tbl where rg = extAsString "RG" br +get_no_library _ _ = S.empty + +mk_rg_tbl :: BamMeta -> M.HashMap Seqid Seqid +mk_rg_tbl hdr = M.fromList + [ (rg_id, rg_lb) + | ("RG",fields) <- meta_other_shit hdr + , rg_id <- take 1 [ i | ("ID",i) <- fields ] + , rg_lb <- take 1 $ [ l | ("LB",l) <- fields ] + ++ [ s | ("SM",s) <- fields ] + ++ [ rg_id ] ] + +data Counts = Counts { tin :: !Int + , tout :: !Int + , good_singles :: !Int + , good_total :: !Int } + +main :: IO () +main = do + args <- getArgs + when (null args) usage + let (opts, files, errors) = getOpt Permute options args + unless (null errors) $ mapM_ (hPutStrLn stderr) errors >> exitFailure + Conf{..} <- foldr (>=>) return opts defaults + + add_pg <- addPG $ Just version + (counts, ()) <- mergeInputRanges which files >=> run $ \hdr -> do + (circtable, refs') <- liftIO $ circulars (meta_refs hdr) + let tbl = mk_rg_tbl hdr + unless (M.null tbl) $ liftIO $ do + debug "mapping of read groups to libraries:\n" + mapM_ debug [ unpackSeqid k ++ " --> " ++ unpackSeqid v ++ "\n" | (k,v) <- M.toList tbl ] + + let filters = progressPos "Rmdup at " debug refs' ><> + mapChunks (mapMaybe (transform . unpackBam)) ><> + mapChunksM (mapMM clean_multimap) ><> + filterStream (\br -> (keep_unaligned || is_aligned br) && + (keep_improper || is_proper br) && + eff_len br >= min_len) + + let (co, ou) = case output of Nothing -> (cheap_collapse', skipToEof) + Just o -> (collapse, joinI $ wrapSortWith circtable $ + o (get_label tbl) (add_pg hdr { meta_refs = refs' })) + + ou' <- takeWhileE is_halfway_aligned ><> filters ><> + normalizeSortWith circtable ><> + filterStream (\b -> b_mapq b >= min_qual) ><> + rmdup (get_label tbl) strand_preserved (co keep_all) $ + count_all (get_label tbl) `I.zip` ou + + let do_copy = do liftIO $ debug "\27[Krmdup done; copying junk\n" ; joinI (filters ou') + do_bail = do liftIO $ debug "\27[Krmdup done\n" ; lift (run ou') + + case which of + Unaln -> do_copy + _ | keep_unaligned -> do_copy + _ -> do_bail + + putResult . unlines $ + "\27[K#RG\tin\tout\tin@MQ20\tsingle@MQ20\tunseen\ttotal\t%unique\t%exhausted" + : map (uncurry do_report) (M.toList counts) + + +do_report :: Seqid -> Counts -> String +do_report lbl Counts{..} = intercalate "\t" fs + where + fs = label : showNum tin : showNum tout : showNum good_total : showNum good_singles : + report_estimate (estimateComplexity good_total good_singles) + + label = if S.null lbl then "--" else unpackSeqid lbl + + report_estimate Nothing = [ "N/A" ] + report_estimate (Just good_grand_total) = + [ showOOM (grand_total - fromIntegral tout) + , showOOM grand_total + , showFFloat (Just 1) rate [] + , showFFloat (Just 1) exhaustion [] ] + where + grand_total = good_grand_total * fromIntegral tout / fromIntegral good_total + exhaustion = 100 * fromIntegral good_total / good_grand_total + rate = 100 * fromIntegral tout / fromIntegral tin :: Double + + +-- | Counting reads: we count total read in (ti), total reads out (to), +-- good (confidently mapped) singletons out (gs), total good +-- (confidently mapped) reads out (gt). Paired reads count 1, unpaired +-- reads count 2, and at the end we divide by 2. This ensures that we +-- don't double count mate pairs, while still working mostly sensibly in +-- the presence of broken BAM files. + +count_all :: Functor m => (BamRec -> Seqid) -> Iteratee [BamRec] m (M.HashMap Seqid Counts) +count_all lbl = M.map fixup `fmap` I.foldl' plus M.empty + where + plus m b = M.insert (lbl b) cs m + where + !cs = plus1 (M.lookupDefault (Counts 0 0 0 0) (lbl b) m) b + + plus1 (Counts ti to gs gt) b = Counts ti' to' gs' gt' + where + !w = if isPaired b then 1 else 2 + !ti' = ti + w * extAsInt 1 "XP" b + !to' = to + w + !gs' = if b_mapq b >= Q 20 && extAsInt 1 "XP" b == 1 then gs + w else gs + !gt' = if b_mapq b >= Q 20 then gt + w else gt + + fixup (Counts ti to gs gt) = Counts (div ti 2) (div to 2) (div gs 2) (div gt 2) + +eff_len :: BamRec -> Int +eff_len b | isProperlyPaired b = abs $ b_isize b + | otherwise = V.length $ b_seq b + +is_halfway_aligned :: BamRaw -> Bool +is_halfway_aligned = isValidRefseq . b_rname . unpackBam + +is_aligned :: BamRec -> Bool +is_aligned b = not (isUnmapped b && isMateUnmapped b) && isValidRefseq (b_rname b) + +is_proper :: BamRec -> Bool +is_proper b = not (isPaired b) || (isMateUnmapped b == isUnmapped b && isProperlyPaired b) + +make_single :: BamRec -> Maybe BamRec +make_single b | isPaired b && isSecondMate b = Nothing + | isUnmapped b = Nothing + | not (isPaired b) = Just b + | otherwise = Just $ b { b_flag = b_flag b .&. complement pair_flags + , b_mrnm = invalidRefseq + , b_mpos = invalidPos + , b_isize = 0 } + where + pair_flags = flagPaired .|. flagProperlyPaired .|. + flagFirstMate .|. flagSecondMate .|. + flagMateUnmapped + + +mergeInputRanges :: (MonadIO m, MonadMask m) + => Which -> [FilePath] -> Enumerator' BamMeta [BamRaw] m a +mergeInputRanges All fps = mergeInputs combineCoordinates fps +mergeInputRanges _ [ ] = \k -> return $ k mempty +mergeInputRanges rng (fp0:fps0) = go fp0 fps0 + where + enum1 fp k1 = case rng of All -> decodeAnyBamFile fp k1 + Some x y -> decodeBamFileRange x y fp k1 + Unaln -> decodeWithIndex eneeBamUnaligned fp k1 + + go fp [ ] = enum1 fp + go fp (fp1:fps) = mergeEnums' (go fp1 fps) (enum1 fp) combineCoordinates + + decodeBamFileRange x y = decodeWithIndex $ + \idx -> foldr ((>=>) . eneeBamRefseq idx) return [x..y] + + +decodeWithIndex :: (MonadIO m, MonadMask m) + => (BamIndex () -> Enumeratee [BamRaw] [BamRaw] m a) + -> FilePath -> (BamMeta -> Iteratee [BamRaw] m a) + -> m (Iteratee [BamRaw] m a) +decodeWithIndex enum fp k0 = do + idx <- liftIO $ readBamIndex fp + decodeAnyBamFile fp >=> run $ enum idx . k0 + + +writeLibBamFiles :: (MonadIO m, MonadMask m) + => FilePath -> (BamRec -> Seqid) -> BamMeta -> Iteratee [BamRec] m () +writeLibBamFiles fp lbl hdr = tryHead >>= loop M.empty + where + loop m Nothing = liftIO . mapM_ run $ M.elems m + loop m (Just br) = do + let !l = lbl br + let !it = M.lookupDefault (writeBamFile (fp `subst` l) hdr) l m + it' <- liftIO $ enumPure1Chunk [br] it + let !m' = M.insert l it' m + tryHead >>= loop m' + + subst [ ] _ = [] + subst ('%':'s':rest) l = unpackSeqid l ++ subst rest l + subst ('%':'%':rest) l = '%' : subst rest l + subst ( c : rest) l = c : subst rest l + + +mapMM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMM f = go [] + where + go acc [ ] = return $ reverse acc + go acc (a:as) = do b <- f a ; go (maybe acc (:acc) b) as + + +check_flags :: Monad m => BamRec -> m (Maybe BamRec) +check_flags b | extAsInt 1 "HI" b /= 1 = fail "cannot deal with HI /= 1" + | extAsInt 1 "IH" b /= 1 = fail "cannot deal with IH /= 1" + | extAsInt 1 "NH" b /= 1 = fail "cannot deal with NH /= 1" + | otherwise = return $ Just b + +clean_multi_flags :: Monad m => BamRec -> m (Maybe BamRec) +clean_multi_flags b = return $ if extAsInt 1 "HI" b /= 1 then Nothing else Just b' + where + b' = b { b_exts = deleteE "HI" $ deleteE "IH" $ deleteE "NH" $ b_exts b } + + +-- Given a map from reference sequences to arguments, extract those +-- groups as list, apply a function to the argument and the list, pass +-- the result on. Absent groups are passed on as they are. Note that +-- ordering within groups is messed up (it doesn't matter here). +mapAtGroups :: Monad m => IM.IntMap a -> (a -> [BamRec] -> [BamRec]) -> Enumeratee [BamRec] [BamRec] m b +mapAtGroups m f = eneeCheckIfDonePass no_group + where + no_group k (Just e) = idone (liftI k) $ EOF (Just e) + no_group k Nothing = tryHead >>= maybe (idone (liftI k) $ EOF Nothing) (\a -> no_group_1 a k Nothing) + + no_group_1 _ k (Just e) = idone (liftI k) $ EOF (Just e) + no_group_1 a k Nothing = case IM.lookup (b_rname_int a) m of + Nothing -> eneeCheckIfDonePass no_group . k $ Chunk [a] + Just arg -> cont_group (b_rname a) arg [a] k Nothing + + cont_group _rn _arg _acc k (Just e) = idone (liftI k) $ EOF (Just e) + cont_group rn arg acc k Nothing = tryHead >>= maybe flush_eof check1 + where + flush_eof = idone (k $ Chunk $ f arg acc) (EOF Nothing) + flush_go a = eneeCheckIfDonePass (no_group_1 a) . k . Chunk $ f arg acc + check1 a | b_rname a == rn = cont_group rn arg (a:acc) k Nothing + | otherwise = flush_go a + + b_rname_int = fromIntegral . unRefseq . b_rname + +normalizeSortWith :: Monad m => IM.IntMap (Seqid, Int) -> Enumeratee [BamRec] [BamRec] m a +normalizeSortWith m = mapAtGroups m $ \(nm,l) -> sortPos . map (normalizeTo nm l) + +wrapSortWith :: Monad m => IM.IntMap (Seqid, Int) -> Enumeratee [BamRec] [BamRec] m a +wrapSortWith m = mapAtGroups m $ \(_,l) -> sortPos . concatMap (wrapTo l) + +sortPos :: [BamRec] -> [BamRec] +sortPos l = VV.toList $ runST (VV.unsafeThaw (VV.fromList l) >>= \vm -> sortBy (comparing b_pos) vm >> VV.unsafeFreeze vm) diff --git a/tools/bam-trim.hs b/tools/bam-trim.hs new file mode 100644 --- /dev/null +++ b/tools/bam-trim.hs @@ -0,0 +1,54 @@ +import Bio.Bam +import Bio.Base +import Control.Monad ( unless, foldM ) +import Data.Version ( showVersion ) +import Paths_biohazard ( version ) +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) +import System.Exit ( exitFailure, exitSuccess ) +import System.IO ( hPutStrLn ) + +data Conf = Conf { c_trim_pred :: [Nucleotides] -> [Qual] -> Bool + , c_pass_pred :: BamRec -> Bool } + +options :: [OptDescr (Conf -> IO Conf)] +options = [ Option "q" ["minq"] (ReqArg set_minq "Q") "Trim where quality is below Q" + , Option "m" ["mapped"] (NoArg set_monly) "Trim only mapped sequences" + , Option "h?" ["help"] (NoArg usage) "Display this text and exit" + , Option "V" ["version"] (NoArg vrsn) "Display version number and exit" ] + +set_minq :: String -> Conf -> IO Conf +set_minq s c = readIO s >>= \q -> return $ c { c_trim_pred = trim_low_quality (Q q) } + +set_monly :: Conf -> IO Conf +set_monly c = return $ c { c_pass_pred = \r -> isMerged r || isUnmapped r } + +vrsn :: Conf -> IO Conf +vrsn _ = do pn <- getProgName + hPutStrLn stderr $ pn ++ ", version " ++ showVersion version + exitSuccess + +usage :: Conf -> IO Conf +usage _ = do hPutStrLn stderr $ usageInfo info options ; exitSuccess + where info = "Simple trimming of sequences in Bam files. Reads a Bam file from stdin,\n\ + \trims sequences of low quality, writes Bam to stdout. Does not trim\n\ + \merged reads." + + +main :: IO () +main = do + (opts, files, errors) <- getOpt Permute options `fmap` getArgs + + unless (null errors) $ mapM_ (hPutStrLn stderr) errors + c <- foldM (flip id) (Conf (trim_low_quality (Q 20)) isMerged) opts + unless (null errors && null files) exitFailure + + let do_trim r | c_pass_pred c r' = Left r + | otherwise = Right $ trim_3' (c_trim_pred c) r' + where r' = unpackBam r + + add_pg <- addPG (Just version) + concatDefaultInputs >=> run $ + joinI . mapStream do_trim . + protectTerm . pipeBamOutput . add_pg + diff --git a/tools/count-coverage.hs b/tools/count-coverage.hs new file mode 100644 --- /dev/null +++ b/tools/count-coverage.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns, NoMonomorphismRestriction, FlexibleContexts #-} +import Bio.Bam.Header +import Bio.Bam.Reader +import Bio.Bam.Rec +import Bio.Base +import Bio.Iteratee +import Data.Version ( showVersion ) +import Paths_biohazard ( version ) +import System.Environment +import System.Exit +import System.IO ( hPutStr ) + +main :: IO () +main = do + mq <- getArgs >>= \args -> case (args, reads (head args)) of + ([ ], _) -> return (Q 0) + ([_], [(x,[])]) -> return (Q x) + _ -> do pn <- getProgName + hPutStr stderr $ pn ++ ", version " ++ showVersion version + ++ "\nUsage: " ++ pn ++ "[]\n" + exitFailure + + let putLine nm cv = putStr $ nm ++ '\t' : shows cv "\n" + + printOne :: Refs -> (Refseq, Int) -> IO () + printOne refs (r,c) = putLine (unpackSeqid (sq_name (getRef refs r))) c + + do_count :: Monad m => Iteratee [(a,Int)] m Int + do_count = foldStream (\a -> (+) a . snd) 0 + + (total,()) <- enumHandle defaultBufSize stdin >=> run $ + joinI $ decodeAnyBam $ \hdr -> + joinI $ mapMaybeStream ( \br -> case unpackBam br of + b | not (isUnmapped b) && b_mapq b >= mq + -> Just $! P (b_rname b) (b_pos b) (alignedLength (b_cigar b)) + _ -> Nothing ) $ + joinI $ groupStreamOn ref count_cov $ + zipStreams do_count (mapStreamM_ $ printOne $ meta_refs hdr) + + putLine "total" total + +data P = P { ref :: !Refseq, pos :: !Int, alen :: !Int } + +count_cov :: Monad m => a -> m (Iteratee [P] m Int) +count_cov _ = return $ liftI $ step 0 + where + step !a (EOF ex) = idone a (EOF ex) + step !a (Chunk [ ]) = liftI $ step a + step !a (Chunk (r:rs)) = extend a (pos r) (pos r + alen r) (Chunk rs) + + extend !a !u !v (EOF ex) = idone (a+v-u) (EOF ex) + extend !a !u !v (Chunk [ ]) = liftI $ extend a u v + extend !a !u !v (Chunk (r:rs)) + | pos r <= v = extend a u (max v (pos r + alen r)) (Chunk rs) + | otherwise = step (a+v-u) (Chunk (r:rs)) + + + + + + diff --git a/tools/dmg-est.hs b/tools/dmg-est.hs new file mode 100644 --- /dev/null +++ b/tools/dmg-est.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns, BangPatterns, TypeFamilies #-} +-- Estimates aDNA damage. Crude first version. +-- +-- - Read or subsample a BAM file, make compact representation of the reads. +-- - Compute likelihood of each read under simple model of +-- damage, error/divergence, contamination. +-- +-- For the fitting, we simplify radically: ignore sequencing error, +-- assume damage and simple, symmetric substitutions which subsume error +-- and divergence. +-- +-- Trying to compute symbolically is too much, the high power terms get +-- out of hand quickly, and we get mixed powers of \lambda and \kappa. +-- The fastest version so far uses the cheap implementation of automatic +-- differentiation in AD.hs together with the Hager-Zhang method from +-- package nonlinear-optimization. BFGS from hmatrix-gsl takes longer +-- to converge. Didn't try an actual Newton iteration (yet?), AD from +-- package ad appears slower. +-- +-- If I include parameters, whose true value is zero, the transformation +-- to the log-odds-ratio doesn't work, because then the maximum doesn't +-- exist anymore. For many parameters, zero makes sense, but one +-- doesn't. A different transformation ('sigmoid2'/'isigmoid2' +-- below) allows for an actual zero (but not an actual one), while +-- avoiding ugly boundary conditions. That appears to work well. +-- +-- The current hack assumes all molecules have an overhang at both ends, +-- then each base gets deaminated with a position dependent probability +-- following a geometric distribution. If we try to model a fraction of +-- undeaminated molecules (a contaminant) in addition, this fails. To +-- rescue the idea, I guess we must really decide if the molecule has an +-- overhang at all (probability 1/2) at each end, then deaminate it. +-- +-- TODO +-- - needs better packaging, better output +-- - needs support for multiple input files(?) +-- - needs read group awareness(?) +-- - needs to deal with long (unmerged) reads (by ignoring them?) + +import Bio.Bam.Header +import Bio.Bam.Index +import Bio.Bam.Rec +import Bio.Base +import Bio.Genocall.Adna +import Bio.Iteratee +import Control.Concurrent.Async +import Data.Bits +import Data.Foldable +import Data.Ix +import Data.Maybe +import Numeric.Optimization.Algorithms.HagerZhang05 +import System.Environment + +import qualified Data.Vector as V +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U + +import AD +import Prelude hiding ( sequence_, mapM, mapM_, concatMap, sum, minimum, foldr1 ) + +-- | Roughly @Maybe (Nucleotide, Nucleotide)@, encoded compactly +newtype NP = NP { unNP :: Word8 } deriving (Eq, Ord, Ix) +data Seq = Merged { unSeq :: U.Vector Word8 } + | First { unSeq :: U.Vector Word8 } + | Second { unSeq :: U.Vector Word8 } + +instance Show NP where + show (NP w) + | w == 16 = "NN" + | w > 16 = "XX" + | otherwise = [ "ACGT" !! fromIntegral (w `shiftR` 2) + , "ACGT" !! fromIntegral (w .&. 3) ] + + +sigmoid2, isigmoid2 :: (Num a, Fractional a, Floating a) => a -> a +sigmoid2 x = y*y where y = (exp x - 1) / (exp x + 1) +isigmoid2 y = log $ (1 + sqrt y) / (1 - sqrt y) + +{-# INLINE lk_fun1 #-} +lk_fun1 :: (Num a, Show a, Fractional a, Floating a, Memorable a) => Int -> [a] -> V.Vector Seq -> a +lk_fun1 lmax parms = case length parms of + 1 -> V.foldl' (\a b -> a - log (lk tab00 tab00 tab00 b)) 0 . guardV -- undamaged case + where + !tab00 = fromListN (rangeSize my_bounds) [ l_epq p_subst 0 0 x + | (_,_,x) <- range my_bounds ] + + 4 -> V.foldl' (\a b -> a - log (lk tabDS tabDS1 tabDS1 b)) 0 . guardV -- double strand case + where + !tabDS = fromListN (rangeSize my_bounds) [ l_epq p_subst p_d p_e x + | (l,i,x) <- range my_bounds + , let p_d = mu $ lambda ^^ (1+i) + , let p_e = mu $ lambda ^^ (l-i) ] + + !tabDS1 = fromListN (rangeSize my_bounds) [ l_epq p_subst p_d 0 x + | (_,i,x) <- range my_bounds + , let p_d = mu $ lambda ^^ (1+i) ] + + 5 -> V.foldl' (\a b -> a - log (lk tabSS tabSS1 tabSS2 b)) 0 . guardV -- single strand case + where + !tabSS = fromListN (rangeSize my_bounds) [ l_epq p_subst p_d 0 x + | (l,i,x) <- range my_bounds + , let lam5 = lambda ^^ (1+i) ; lam3 = kappa ^^ (l-i) + , let p_d = mu $ lam3 + lam5 - lam3 * lam5 ] + + !tabSS1 = fromListN (rangeSize my_bounds) [ l_epq p_subst p_d 0 x + | (_,i,x) <- range my_bounds + , let p_d = mu $ lambda ^^ (1+i) ] + + !tabSS2 = fromListN (rangeSize my_bounds) [ l_epq p_subst 0 p_d x + | (_,i,x) <- range my_bounds + , let p_d = mu $ lambda ^^ (1+i) ] + + _ -> error "Not supposed to happen: unexpected number of model parameters." + where + ~(l_subst : ~(l_sigma : ~(l_delta : ~(l_lam : ~(l_kap : _))))) = parms + + p_subst = 0.33333 * sigmoid2 l_subst + sigma = sigmoid2 l_sigma + delta = sigmoid2 l_delta + lambda = sigmoid2 l_lam + kappa = sigmoid2 l_kap + + guardV = V.filter (\u -> U.length (unSeq u) >= lmin && U.length (unSeq u) <= lmax) + + -- Likelihood given precomputed damage table. We compute the giant + -- table ahead of time, which maps length, index and base pair to a + -- likelihood. + lk tab_m _ _ (Merged b) = U.ifoldl' (\a i np -> a * tab_m `bang` index' my_bounds (U.length b, i, NP np)) 1 b + lk _ tab_f _ (First b) = U.ifoldl' (\a i np -> a * tab_f `bang` index' my_bounds (U.length b, i, NP np)) 1 b + lk _ _ tab_s (Second b) = U.ifoldl' (\a i np -> a * tab_s `bang` index' my_bounds (U.length b, i, NP np)) 1 b + + index' bnds x | inRange bnds x = index bnds x + | otherwise = error $ "Huh? " ++ show x ++ " \\nin " ++ show bnds + + my_bounds = ((lmin,0,NP 0),(lmax,lmax,NP 16)) + mu p = sigma * p + delta * (1-p) + + +-- Likelihood for a certain pair of bases given error rate, C-T-rate +-- and G-A rate. +l_epq :: (Num a, Fractional a, Floating a) => a -> a -> a -> NP -> a +l_epq e p q (NP x) = case x of { + 0 -> s ; 1 -> e ; 2 -> e ; 3 -> e ; + 4 -> e ; 5 -> s-p+4*e*p ; 6 -> e ; 7 -> e+p-4*e*p ; + 8 -> e+q-4*e*q ; 9 -> e ; 10 -> s-q+4*e*q ; 11 -> e ; + 12 -> e ; 13 -> e ; 14 -> e ; 15 -> s ; + _ -> 1 } where s = 1 - 3 * e + + +lkfun :: Int -> V.Vector Seq -> U.Vector Double -> Double +lkfun lmax brs parms = lk_fun1 lmax (U.toList parms) brs + +combofn :: Int -> V.Vector Seq -> U.Vector Double -> (Double, U.Vector Double) +combofn lmax brs parms = (x,g) + where D x g = lk_fun1 lmax (paramVector $ U.toList parms) brs + +params :: Parameters +params = defaultParameters { printFinal = False, verbose = Quiet, maxItersFac = 20 } + +lmin :: Int +lmin = 25 + +main :: IO () +main = do + [fp] <- getArgs + brs <- subsampleBam fp >=> run $ \_ -> + joinI $ filterStream (\b -> not (isUnmapped (unpackBam b)) && G.length (b_seq (unpackBam b)) >= lmin) $ + joinI $ takeStream 100000 $ + joinI $ mapStream pack_record $ + joinI $ filterStream (\u -> U.length (U.filter (<16) (unSeq u)) * 10 >= 9 * U.length (unSeq u)) $ + stream2vectorN 30000 + + let lmax = V.maximum $ V.map (U.length . unSeq) brs + v0 = crude_estimate brs + opt v = optimize params 0.0001 v + (VFunction $ lkfun lmax brs) + (VGradient $ snd . combofn lmax brs) + (Just . VCombined $ combofn lmax brs) + + results <- mapConcurrently opt [ v0, U.take 4 v0, U.take 1 v0 ] + + let mlk = minimum [ finalValue st | (_,_,st) <- results ] + tot = sum [ exp $ mlk - finalValue st | (_,_,st) <- results ] + p l = exp (mlk - l) / tot + + [ (p_ss, [ _, ssd_sigma_, ssd_delta_, ssd_lambda, ssd_kappa ]), + (p_ds, [ _, dsd_sigma_, dsd_delta_, dsd_lambda ]), + (_ , [ _ ]) ] = [ (p (finalValue st), map sigmoid2 $ G.toList xs) | (xs,_,st) <- results ] + + ssd_sigma = p_ss * ssd_sigma_ + ssd_delta = p_ss * ssd_delta_ + dsd_sigma = p_ds * dsd_sigma_ + dsd_delta = p_ds * dsd_delta_ + + print DP{..} + +-- We'll require the MD field to be present. Then we cook each read +-- into a list of paired bases. Deleted bases are dropped, inserted +-- bases replaced with an escape code. +-- +-- XXX This is annoying... almost, but not quite the same as the code +-- in the "Pileup" module. This also relies on MD and doesn't offer the +-- alternative of accessing a reference genome. (The latter may not be +-- worth the trouble.) It also resembles the 'ECig' logic from +-- "Bio.Bam.Rmdup". + +pack_record :: BamRaw -> Seq +pack_record br = if isReversed b then k (revcom u1) else k u1 + where + b@BamRec{..} = unpackBam br + + k | isMerged b = Merged + | isTrimmed b = Merged + | isSecondMate b = Second + | otherwise = First + + revcom = U.reverse . U.map (\x -> if x > 15 then x else xor x 15) + u1 = U.fromList . map unNP $ go (G.toList b_cigar) (G.toList b_seq) (fromMaybe [] $ getMd b) + + go :: [Cigar] -> [Nucleotides] -> [MdOp] -> [NP] + + go (_:*0 :cs) ns mds = go cs ns mds + go cs ns (MdNum 0:mds) = go cs ns mds + go cs ns (MdDel []:mds) = go cs ns mds + go _ [] _ = [] + go [] _ _ = [] + + go (Mat:*nm :cs) (n:ns) (MdNum mm:mds) = mk_pair n n : go (Mat:*(nm-1):cs) ns (MdNum (mm-1):mds) + go (Mat:*nm :cs) (n:ns) (MdRep n':mds) = mk_pair n n' : go (Mat:*(nm-1):cs) ns mds + go (Mat:*nm :cs) ns (MdDel _ :mds) = go (Mat:* nm :cs) ns mds + + go (Ins:*nm :cs) ns mds = replicate nm esc ++ go cs (drop nm ns) mds + go (SMa:*nm :cs) ns mds = replicate nm esc ++ go cs (drop nm ns) mds + go (Del:*nm :cs) ns (MdDel (_:ds):mds) = go (Del:*(nm-1):cs) ns (MdDel ds:mds) + go (Del:*nm :cs) ns ( _:mds) = go (Del:* nm :cs) ns mds + + go (_:cs) nd mds = go cs nd mds + + +esc :: NP +esc = NP 16 + +mk_pair :: Nucleotides -> Nucleotides -> NP +mk_pair (Ns a) = case a of 1 -> mk_pair' 0 + 2 -> mk_pair' 1 + 4 -> mk_pair' 2 + 8 -> mk_pair' 3 + _ -> const esc + where + mk_pair' u (Ns b) = case b of 1 -> NP $ u .|. 0 + 2 -> NP $ u .|. 4 + 4 -> NP $ u .|. 8 + 8 -> NP $ u .|. 12 + _ -> esc + + +infix 7 /%/ +(/%/) :: Integral a => a -> a -> Double +0 /%/ 0 = 0 +a /%/ b = fromIntegral a / fromIntegral b + +-- Crude estimate. Need two overhang lengths, two deamination rates, +-- undamaged fraction, SS/DS, substitution rate. +-- +-- DS or SS: look whether CT or GA is greater at 3' terminal position √ +-- Left overhang length: ratio of damage at second position to first √ +-- Right overang length: ratio of CT at last to snd-to-last posn √ +-- + ratio of GA at last to snd-to-last posn √ +-- SS rate: condition on damage on one end, compute rate at other √ +-- DS rate: condition on damage, compute rate in interior √ +-- substitution rate: count all substitutions not due to damage √ +-- undamaged fraction: see below √ +-- +-- Contaminant fraction: let f5 (f3, f1) be the fraction of reads +-- showing damage at the 5' end (3' end, both ends). Let a (b) be +-- the probability of an endogenous reads to show damage at the 5' +-- end (3' end). Let e be the fraction of endogenous reads. Then +-- we have: +-- +-- f5 = e * a +-- f3 = e * b +-- f1 = e * a * b +-- +-- f5 * f3 / f1 = e +-- +-- Straight forward and easy to understand, but in practice, this method +-- produces ridiculous overestimates, ridiculous underestimates, +-- negative contamination rates, and general grief. It's actually +-- better to start from a constant number. + + +crude_estimate :: V.Vector Seq -> U.Vector Double +crude_estimate seqs0 = U.fromList [ l_subst, l_sigma, l_delta, l_lam, l_kap ] + where + seqs = V.filter ((>= 10) . U.length) $ V.map unSeq seqs0 + + total_equals = V.sum (V.map (U.length . U.filter isNotSubst) seqs) + total_substs = V.sum (V.map (U.length . U.filter isOrdinarySubst) seqs) * 6 `div` 5 + l_subst = isigmoid2 $ max 0.001 $ total_substs /%/ (total_equals + total_substs) + + c_to_t, g_to_a, c_to_c :: Word8 + c_to_t = 7 + g_to_a = 8 + c_to_c = 5 + + isNotSubst x = x < 16 && x `shiftR` 2 == x .&. 3 + isOrdinarySubst x = x < 16 && x `shiftR` 2 /= x .&. 3 && + x /= c_to_t && x /= g_to_a + + ct_at_alpha = V.length $ V.filter (\v -> v U.! 0 == c_to_t && dmg_omega v) seqs + cc_at_alpha = V.length $ V.filter (\v -> v U.! 0 == c_to_c && dmg_omega v) seqs + ct_at_beta = V.length $ V.filter (\v -> v U.! 1 == c_to_t && dmg_omega v) seqs + cc_at_beta = V.length $ V.filter (\v -> v U.! 1 == c_to_c && dmg_omega v) seqs + + dmg_omega v = v U.! (l-1) == c_to_t || v U.! (l-1) == g_to_a + || v U.! (l-2) == c_to_t || v U.! (l-2) == g_to_a + || v U.! (l-3) == c_to_t || v U.! (l-3) == g_to_a + where l = U.length v + + l_lam = isigmoid2 lambda + lambda = min 0.9 $ max 0.1 $ + (ct_at_beta * (cc_at_alpha + ct_at_alpha)) /%/ + ((cc_at_beta + ct_at_beta) * ct_at_alpha) + + ct_at_omega = V.length $ V.filter (\v -> v U.! (U.length v -1) == c_to_t && dmg_alpha v) seqs + cc_at_omega = V.length $ V.filter (\v -> v U.! (U.length v -1) == c_to_c && dmg_alpha v) seqs + ct_at_psi = V.length $ V.filter (\v -> v U.! (U.length v -2) == c_to_t && dmg_alpha v) seqs + cc_at_psi = V.length $ V.filter (\v -> v U.! (U.length v -2) == c_to_c && dmg_alpha v) seqs + + dmg_alpha v = v U.! 0 == c_to_t || v U.! 1 == c_to_t || v U.! 2 == c_to_t + + l_kap = isigmoid2 $ min 0.9 $ max 0.1 $ + (ct_at_psi * (cc_at_omega+ct_at_omega)) /%/ + ((cc_at_psi+ct_at_psi) * ct_at_omega) + + total_inner_CCs = V.sum $ V.map (U.length . U.filter (== c_to_c) . takeInner) seqs + total_inner_CTs = V.sum $ V.map (U.length . U.filter (== c_to_t) . takeInner) seqs + takeInner v = U.slice 5 (U.length v - 10) v + + delta = (total_inner_CTs /%/ (total_inner_CTs+total_inner_CCs)) + raw_rate = ct_at_alpha /%/ (ct_at_alpha + cc_at_alpha) + + -- clamping is necessary if f_endo ends up wrong + l_delta = isigmoid2 $ min 0.99 delta + l_sigma = isigmoid2 . min 0.99 $ raw_rate / lambda + + +class Memorable a where + type Memo a :: * + + fromListN :: Int -> [a] -> Memo a + bang :: Memo a -> Int -> a + +instance Memorable Double where + type Memo Double = U.Vector Double + + fromListN = U.fromListN + bang = (U.!) + +instance Memorable AD where + type Memo AD = (Int, U.Vector Double) + + fromListN n xs@(D _ v:_) = (1+d, U.fromListN (n * (1+d)) $ concatMap unpack xs) + where + !d = U.length v + unpack (C a) = a : replicate d 0 + unpack (D a da) = a : U.toList da + + bang (d, v) i = D (v U.! (d*i+0)) (U.slice (d*i+1) (d-1) v) diff --git a/tools/fastq2bam.hs b/tools/fastq2bam.hs new file mode 100644 --- /dev/null +++ b/tools/fastq2bam.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} +import Bio.Base +import Bio.Bam +import Bio.Bam.Evan ( removeWarts ) +import Bio.Iteratee.ZLib +import Control.Monad +import Data.Bits +import Data.Monoid ( mempty ) +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S +import qualified Data.Vector.Generic as V + +-- TODO: +-- - optional(!) GZip + +data Opts = Opts { output :: BamMeta -> Iteratee [BamRec] IO () + , inputs :: [Input] + , verbose :: Bool } + +defaultOpts :: Opts +defaultOpts = Opts { output = protectTerm . pipeBamOutput + , inputs = [] + , verbose = False } + +data Input = Input { _read1 :: FilePath + , read2 :: Maybe FilePath + , index1 :: Maybe FilePath + , index2 :: Maybe FilePath } + deriving Show + +getopts :: [String] -> ([Opts -> IO Opts], [String], [String]) +getopts = getOpt (ReturnInOrder add_read1) options + where + options = + [ Option "o" ["output"] (ReqArg set_output "FILE") "Write output to FILE" + , Option "1" ["read-one"] (ReqArg add_read1 "FILE") "Parse FILE for anything" + , Option "2" ["read-two"] (ReqArg add_read2 "FILE") "Parse FILE for second mates" + , Option "I" ["index-one"] (ReqArg add_idx1 "FILE") "Parse FILE for first index" + , Option "J" ["index-two"] (ReqArg add_idx2 "FILE") "Parse FILE for second index" + , Option "v" ["verbose"] (NoArg set_verbose) "Print progress information" + , Option "h?" ["help","usage"] (NoArg usage) "Print this helpful message" ] + + set_output "-" c = return $ c { output = pipeBamOutput } + set_output fn c = return $ c { output = writeBamFile fn } + set_verbose c = return $ c { verbose = True } + + add_read1 fn c = return $ c { inputs = Input fn Nothing Nothing Nothing : inputs c } + add_read2 fn c = return $ c { inputs = at_head (\i -> i { read2 = Just fn }) (inputs c) } + add_idx1 fn c = return $ c { inputs = at_head (\i -> i { index1 = Just fn }) (inputs c) } + add_idx2 fn c = return $ c { inputs = at_head (\i -> i { index2 = Just fn }) (inputs c) } + + at_head f [ ] = [ f $ Input "-" Nothing Nothing Nothing ] + at_head f (i:is) = f i : is + + usage _ = do pn <- getProgName + let t = "Usage: " ++ pn ++ " [OPTION...]\n" ++ + "Reads multiple FastA or FastQ files and converts them to BAM. See manpage for details." + hPutStrLn stderr $ usageInfo t options + exitSuccess + + +main :: IO () +main = do (opts, [], errors) <- getopts `fmap` getArgs + unless (null errors) $ mapM_ (hPutStrLn stderr) errors >> exitFailure + conf <- foldl (>>=) (return defaultOpts) opts + pgm <- addPG Nothing + + let eff_inputs = if null (inputs conf) then [ Input "-" Nothing Nothing Nothing ] else inputs conf + hPrint stderr $ eff_inputs + + foldr ((>=>) . enum_input) run (reverse eff_inputs) $ + joinI $ progress (verbose conf) $ + joinI $ mapChunks concatDuals $ + ilift liftIO $ output conf (pgm mempty) + + +type UpToTwo a = (a, Maybe a) + +one :: a -> UpToTwo a +one a = (a, Nothing) + +two :: a -> a -> UpToTwo a +two a b = (a, Just b) + +mapU2 :: (a -> b) -> UpToTwo a -> UpToTwo b +mapU2 f (a,b) = (f a, fmap f b) + +concatDuals :: [UpToTwo a] -> [a] +concatDuals ((a,Just b):ds) = a : b : concatDuals ds +concatDuals ((a,Nothing):ds) = a : concatDuals ds +concatDuals [ ] = [] + +-- Enumerates a file. Sequence and quality end up in b_seq and b_qual. +fromFastq :: (MonadIO m, MonadMask m) => FilePath -> Enumerator [BamRec] m a +fromFastq fp = enumAny fp $= enumInflateAny $= parseFastqCassava $= mapStream removeWarts + where + enumAny "-" = enumHandle defaultBufSize stdin + enumAny f = enumFile defaultBufSize f + +enum_input :: (MonadIO m, MonadMask m) => Input -> Enumerator [UpToTwo BamRec] m a +enum_input inp@(Input r1 mr2 mi1 mi2) o = do + liftIO $ hPrint stderr inp + (withIndex mi1 "XI" "YI" $ withIndex mi2 "XJ" "YJ" $ + case mr2 of Nothing -> fromFastq r1 $= mapStream one ; Just r2 -> enumDual r1 r2) o + +-- Given an enumerator and maybe a filename, read index sequences from +-- the file and merge them with the numerator. +withIndex :: (MonadIO m, MonadMask m) + => Maybe FilePath -> BamKey -> BamKey + -> Enumerator [UpToTwo BamRec] m a -> Enumerator [UpToTwo BamRec] m a +withIndex Nothing _ _ enum = enum +withIndex (Just fp) tagi tagq enum = mergeEnums enum (fromFastq fp) (convStream combine) + where + combine = do seqrecs <- lift headStream + idxrec <- headStream + when (b_qname (fst seqrecs) /= b_qname idxrec) . error $ + "read names do not match: " ++ shows (b_qname (fst seqrecs)) " & " ++ show (b_qname idxrec) + + let idxseq = S.pack $ map showNucleotides $ V.toList $ b_seq idxrec + idxqual = B.pack $ map ((+33) . unQ) $ V.toList $ b_qual idxrec + return [ flip mapU2 seqrecs $ + \r -> r { b_exts = (if B.null idxqual then id else insertE tagq (Text idxqual)) + $ insertE tagi (Text idxseq) $ b_exts r } ] + +-- Enumerate dual files. We read two FastQ files and match them up. We +-- must make sure the names match, and we will flag everything as +-- 1st/2nd mate, no matter if the syntactic warts were present in the +-- files themselves. +enumDual :: (MonadIO m, MonadMask m) + => FilePath -> FilePath -> Enumerator [UpToTwo BamRec] m a +enumDual f1 f2 = mergeEnums (fromFastq f1 $= mapStream one) (fromFastq f2) (convStream combine) + where + combine = do (firstMate, Nothing) <- lift headStream + secondMate <- headStream + + when (b_qname firstMate /= b_qname secondMate) . error $ + "read names do not match: " ++ shows (b_qname firstMate) " & " ++ show (b_qname secondMate) + + let qc = (b_flag firstMate .|. b_flag secondMate) .&. flagFailsQC + addx k = maybe id (updateE k) $ maybe (lookup k (b_exts secondMate)) Just $ lookup k (b_exts firstMate) + add_indexes = addx "XI" . addx "XJ" . addx "YI" . addx "YJ" + + return [ two (firstMate { b_flag = qc .|. flagFirstMate .|. flagPaired .|. b_flag firstMate .&. complement flagSecondMate + , b_exts = add_indexes $ b_exts firstMate }) + (secondMate { b_flag = qc .|. flagSecondMate .|. flagPaired .|. b_flag secondMate .&. complement flagFirstMate + , b_exts = add_indexes $ b_exts secondMate }) ] + + +progress :: MonadIO m => Bool -> Enumeratee [UpToTwo BamRec] [UpToTwo BamRec] m b +progress False = mapChunks id +progress True = eneeCheckIfDonePass (icont . go 0 0) + where + go !_ !_ k (EOF mx) = idone (liftI k) (EOF mx) + go !l !n k (Chunk [ ]) = liftI $ go l n k + go !l !n k (Chunk as@(a:_)) = do + let !n' = n + length as + !nm = b_qname (fst a) + !l' = l `max` S.length nm + when (n `div` 2048 /= n' `div` 2048) $ liftIO $ do + hPutStr stderr $ "\27[K" ++ + replicate (l' - S.length nm) ' ' + ++ S.unpack nm ++ ", " + ++ shows n' " records processed\n" + hFlush stderr + eneeCheckIfDonePass (icont . go l' n') . k $ Chunk as + + diff --git a/tools/glf-consensus.hs b/tools/glf-consensus.hs new file mode 100644 --- /dev/null +++ b/tools/glf-consensus.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE BangPatterns #-} +import Control.Applicative ( (<$>) ) +import Control.Monad +import Control.Monad.Catch +import Data.Char ( isSpace, toLower, chr ) +import Data.List ( intercalate, sort ) +import Data.Version ( showVersion ) +import Paths_biohazard ( version ) +import System.Console.GetOpt +import System.IO +import System.Environment ( getArgs, getProgName ) +import System.Exit + +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Map as M + +import qualified Data.Iteratee.ListLike as I + +import Bio.Base +import Bio.Glf +import Bio.Iteratee + +data Config = Config { + conf_min_qual :: Int, + conf_call :: [Int] -> [(Int, Char)], + conf_output :: Iteratee String IO (), + conf_input :: GlfInput, + conf_conv :: Formatter, + conf_mkname :: S.ByteString -> String } + +type GlfInput = (GlfSeq -> Enumeratee [GlfRec] String IO ()) + -> (S.ByteString -> Enumerator String IO ()) + -> Enumerator String IO () + +options :: [ OptDescr (Config -> IO Config) ] +options = [ + Option "1" ["haploid"] + (NoArg (\c -> return $ c { conf_call = haploid_call })) + "Force haploid consensus", + Option "2" ["diploid"] + (NoArg (\c -> return $ c { conf_call = diploid_call })) + "Allow diploid consensus", + Option "m" ["min-qual"] + (ReqArg (\a c -> readIO a >>= \m -> return $ c { conf_min_qual = m }) "Q") + "Require minimum quality of Q", + Option "o" ["output"] + (ReqArg (\fp c -> return $ c { conf_output = iterToFile fp }) "FILE") + "Write output to FILE instead of stdout", + Option "q" ["fastq"] + (NoArg (\c -> return $ c { conf_conv = print_fastq })) + "Write FastQ instead of FastA", + Option "I" ["identifier"] + (ReqArg (\n c -> return $ c { conf_mkname = subst_name n }) "ID") + "Use ID as identifier for consensus", + Option "if" ["input"] + (ReqArg (\fp c -> return $ c { conf_input = enum_glf_file fp }) "FILE") + "Read input from FILE instead of stdin", + Option "h?" ["help", "usage"] + (NoArg (usage exitSuccess)) + "Print this help", + Option "V" ["version"] + (NoArg vrsn) + "Print version number and exit" ] + +vrsn :: Config -> IO a +vrsn _ = do pn <- getProgName + hPutStrLn stderr $ pn ++ ", version " ++ showVersion version + exitSuccess + +usage :: IO a -> Config -> IO a +usage e _ = getProgName >>= \p -> putStrLn (usageInfo (blurb p) options) >> e + where blurb prg = + "Usage: " ++ prg ++ " [Option...] [FastA-File...]\n" ++ + "Reads GLF from stdin and prints the contained consensus sequence in\n" ++ + "FastA/FastQ format. Gaps are filled with a reference sequence if known\n" ++ + "from the FastA files on the command line, otherwise with Ns." + +iterToFile :: FilePath -> Iteratee String IO () +iterToFile fp = bracket (lift $ openFile fp WriteMode) + (lift . hClose) + (mapChunksM_ . hPutStr) + +defaultConfig :: Config +defaultConfig = Config 0 diploid_call (mapChunksM_ putStr) (enum_glf_handle stdin) print_fasta S.unpack + +main :: IO () +main = do (opts, files, errors) <- getOpt Permute options <$> getArgs + unless (null errors) $ mapM_ (hPutStrLn stderr) errors >> exitFailure + Config min_qual call output input conv mkname <- foldl (>>=) (return defaultConfig) opts + refs <- M.fromList . concatMap readFasta <$> mapM L.readFile files + + hPutStrLn stderr $ + "known reference sequences: [" ++ intercalate ", " + [ show (L.unpack k) ++ " (" ++ show (L.length v) ++ ")" | (k,v) <- M.toList refs ] + ++ "]" + + let per_file :: Seqid -> Enumerator String IO () + per_file _genome_name = return + + per_seq :: GlfSeq -> Enumeratee [GlfRec] String IO () + per_seq glfseq = extract1consensus (mkRef refs glfseq) call min_qual + ><> conv (mkname $ glf_seqname glfseq) + + input per_seq per_file output >>= run + +-- get the "most likely" consensus, defined as: +-- - as many reference bases or else Ns as were skipped from the previous record, then +-- - if there's an insert, the most likely insert sequence (may be empty) +-- - if there's a deletion, skip the most likely number of bases (may be zero) +-- - else the most likely base + +mkRef :: M.Map L.ByteString L.ByteString -> GlfSeq -> Int -> Int -> QSeq +mkRef refs glfseq = case M.lookup (L.fromChunks [glf_seqname glfseq]) refs of + Nothing -> \o l -> replicate (min l (glf_seqlen glfseq - o)) ('N',2) + Just s -> \o l -> let l' = fromIntegral $ min l (glf_seqlen glfseq - o) + in [ (toLower b,30) | b <- L.unpack $ L.take l' $ L.drop (fromIntegral o) s ] + +type QSeq = [(Char,Int)] -- sequence w/ quality + +extract1consensus :: Monad m + => (Int -> Int -> QSeq) + -> ([Int] -> [(Int,Char)]) -- call function + -> Int -- minimum quality + -> Enumeratee [GlfRec] QSeq m r -- eats records, emits calls +extract1consensus ref call min_qual oit = liftI $ scan oit 0 0 + where + -- rec_pos: position of last record + -- ref_pos: first position in reference we haven't handled + scan k !_ !ref_pos (EOF x) = lift $ enumPure1Chunk (ref ref_pos maxBound) >=> enumChunk (EOF x) $ k + scan k !rec_pos_ !ref_pos (Chunk [ ]) = liftI $ scan k rec_pos_ ref_pos + scan k !rec_pos_ !ref_pos (Chunk (r:rs)) = + case r of SNP {} -> let (_,!base) : (!qual,_) : _ = sort $ call (glf_lk r) + in ( if qual >= min_qual + then lift $ enumPure1Chunk (ref ref_pos (rec_pos - ref_pos)) k + >>= enumPure1Chunk [(base,qual)] + else lift $ enumPure1Chunk (ref ref_pos (1 + rec_pos - ref_pos)) k ) + >>= \k' -> scan k' rec_pos (1+rec_pos) (Chunk rs) + + Indel {} | ins && iqual >= min_qual -> lift (enumPure1Chunk (ref ref_pos (rec_pos + 1 - ref_pos)) k >>= + enumPure1Chunk [ (b,iqual) | b <- S.unpack sq ]) >>= \k'' -> + scan k'' rec_pos ref_pos (Chunk rs) + | not ins && iqual >= min_qual -> lift (enumPure1Chunk (ref ref_pos (rec_pos - ref_pos)) k) >>= \k' -> + scan k' rec_pos (ref_pos + S.length sq) (Chunk (drop (S.length sq) rs)) + | otherwise -> lift (enumPure1Chunk (ref ref_pos (rec_pos - ref_pos)) k) >>= \k' -> + scan k' rec_pos ref_pos (Chunk rs) + where + !rec_pos = rec_pos_ + glf_offset r + (ins,sq) = if glf_lk_hom1 r > glf_lk_hom2 r + then (glf_is_ins2 r, glf_seq2 r) else (glf_is_ins1 r, glf_seq1 r) + iqual = abs $ glf_lk_hom1 r - glf_lk_hom2 r + + +diploid_call, haploid_call :: [Int] -> [(Int, Char)] +diploid_call lks = zip lks "AMRWCSYGKT" +haploid_call lks = zip (map (lks !!) [0,4,7,9]) "ACGT" + + +type Formatter = String -> Enumeratee QSeq String IO () + +print_fasta :: Formatter +print_fasta name = eneeCheckIfDone (\k -> mapStream fst ><> toLines 60 $ k $ Chunk ('>' : name ++ "\n")) + +print_fastq :: Formatter +print_fastq name = eneeCheckIfDone p'header + where + p'header k = p'seq . k $ Chunk ('@' : name ++ "\n") + p'seq it = I.zip ((mapStream fst ><> toLines 60) it) (liftI $ coll []) + >>= \(it', qs) -> eneeCheckIfDone (p'sep qs) it' + p'sep qs k = lift $ (enumList (map S.unpack qs) >=> run) (toLines 60 . k $ Chunk "+\n") + + mkqual = chr . max 33 . min 126 . (+) 33 . fromIntegral + coll !acc (EOF x) = lift (putStrLn $ show $ length acc) >> idone (reverse acc) (EOF x) + coll !acc (Chunk []) = liftI $ coll acc + coll !acc (Chunk c) = liftI . coll $! norm (S.pack (map (mkqual . snd) c)) acc + + -- ensure that we don't build many small ByteStrings + norm !x [] = [x] + norm !x (y:ys) | S.length x > S.length y = norm (y `S.append` x) ys + | otherwise = x:y:ys + + +toLines :: Monad m => Int -> Enumeratee String String m r +toLines n = eneeCheckIfDone (\k -> I.isFinished >>= go k) + where + go k True = return $ liftI k + go k False = do s <- I.take n I.stream2list >>= lift . run + eneeCheckIfDone (\k1 -> toLines n . k1 $ Chunk "\n") . k $ Chunk s + + +readFasta :: L.ByteString -> [(L.ByteString, L.ByteString)] +readFasta = rd . dropWhile (not . isHeader) . L.lines + where + isHeader l = not (L.null l) && L.head l == '>' + rd [] = [] + rd (l:ls) = let name = L.takeWhile (not . isSpace) $ L.drop 1 l + (sqs,rest) = break isHeader ls + in (name, L.filter (`elem` "ACGTBDHVSWMKYRNU") $ L.concat sqs) : rd rest + +subst_name :: String -> S.ByteString -> String +subst_name [] _ = [] +subst_name ('%':'s':t) s = S.unpack s ++ subst_name t s +subst_name ('%':'%':t) s = '%' : subst_name t s +subst_name (t:ts) s = t : subst_name ts s + diff --git a/tools/gt-call.hs b/tools/gt-call.hs new file mode 100644 --- /dev/null +++ b/tools/gt-call.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE RecordWildCards, BangPatterns, OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell, FlexibleContexts #-} +-- Command line driver for simple genotype calling. + +import Bio.Base +import Bio.Bam.Header +import Bio.Bam.Reader +import Bio.Bam.Rec +import Bio.Bam.Pileup +import Bio.Genocall +import Bio.Genocall.Adna +import Bio.Genocall.AvroFile +import Bio.Iteratee +import Bio.Util ( float2mini ) +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Data.Avro +import Data.Function +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO + +-- import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S +import qualified Data.Iteratee as I +-- import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector.Unboxed as V + +-- import Debug.Trace + +-- Ultimately, we might produce a VCF file looking somewhat like this: +-- +-- ##FORMAT= +-- ##FORMAT= +-- ##FORMAT= +-- ##FORMAT= +-- (we should count bases on both strands for this) +-- +-- ##FORMAT= +-- ##INFO= +-- ##INFO= +-- (basic statistics. we keep these) +-- +-- ##FORMAT= +-- ##FORMAT= +-- ##INFO= +-- (this is bullshit) +-- +-- ##FORMAT= +-- ##FORMAT= +-- ##FORMAT= +-- (these are straight forward to compute?) +-- +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- (this is external, will not be generated) +-- +-- ##INFO= +-- ##INFO= +-- (this is computable, isn't it?!) +-- +-- ##INFO= +-- (this is from VarScan 2, a program that uses fixed cutoffs. It +-- is not clear that this has any use at all.) +-- +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- ##INFO= +-- (WTF?) + +-- parameters used for the Unified Genotyper: +-- downsample_to_coverage=250 +-- heterozygosity=0.001 +-- pcr_error_rate=1.0E-4 +-- indel_heterozygosity=1.25E-4 + + +-- auxilliary files (from Martin's option parser): +-- +-- ancestor_path EMF /mnt/expressions/martin/sequence_db/epo/epo_6_primate_v64/split/ +-- G1000 VCF /mnt/expressions/martin/sequence_db/snps/20110521_G1000_release/phase1_intergrated_calls.20101123.snps_indels_svs.sites.vcf.gz +-- bscores TSV1i /mnt/454/Altaiensis/users/martin/HighCoverage/additional_information/bscores/liftover/human.tsv.gz +-- mammalscores TSV2f /mnt/454/Altaiensis/users/martin/HighCoverage/additional_information/mammal_conservation/liftover/human.tsv.gz +-- primatescores TSV2f /mnt/454/Altaiensis/users/martin/HighCoverage/additional_information/primate_conservation/liftover/human.tsv.gz +-- gerpscores TSV2f /mnt/454/Altaiensis/users/fernando/sequencedb/GERP/liftover/human.tsv.gz +-- mapability TSV2i /mnt/454/Altaiensis/users/martin/HighCoverage/additional_information/mapability/liftover/human.tsv.gz +-- uregions TSV1 /mnt/454/Altaiensis/users/martin/HighCoverage/additional_information/EL_control_regions/liftover/human.tsv.gz +-- syserrors TSV1 /mnt/454/Altaiensis/users/martin/HighCoverage/additional_information/sys_errors/liftover/human.tsv.gz +-- syserrorsHCB TSV1 /mnt/454/Altaiensis/users/fernando/sequencedb/SysErrHCB/human.tsv.gz + +-- TSV1: chr start end score +-- TSV2: chr pos score + +-- About damage parameters: We effectively have three different models +-- (SS, DS, no damage) and it may not be possible to choose one a +-- priori. To manage this cleanly, we should have one universal model, +-- but the three we have are not generalizations of each other. +-- +-- So we treat the choice of model as another parameter. We feed +-- parameters for all three in, together with probabilities for each. +-- Said probabilities are derived from the likelihoods obtained when +-- fitting the parameters individually. Genotype calling then involves +-- calling once under each model and summing them (effectively +-- marginalizing on the choice of model). + +data Conf = Conf { + conf_output :: Maybe Output, + conf_sample :: S.ByteString, + conf_ploidy :: S.ByteString -> Int, + conf_damage :: Maybe (DamageParameters Double), + conf_loverhang :: Maybe Double, + conf_roverhang :: Maybe Double, + conf_ds_deam :: Double, + conf_ss_deam :: Double, + conf_theta :: Maybe Double, + conf_report :: String -> IO (), + conf_prior_het :: Prob, + conf_prior_indel :: Prob } + +defaultConf :: Conf +defaultConf = Conf Nothing "John_Doe" (const 2) Nothing Nothing Nothing + 0.02 0.45 Nothing (\_ -> return ()) + (qualToProb $ Q 30) (qualToProb $ Q 45) + +options :: [OptDescr (Conf -> IO Conf)] +options = [ + Option "o" ["output", "avro-output"] (ReqArg set_avro_out "FILE") "Write AVRO output to FILE", + Option [ ] ["fasta-output"] (ReqArg set_fa_output "FILE") "Write FA output to FILE", + Option "N" ["name","sample-name"] (ReqArg set_sample "NAME") "Set sample name to NAME", + Option "1" ["haploid-chromosomes"] (ReqArg set_haploid "PRF") "Targets starting with PRF are haploid", + Option "2" ["diploid-chromosomes"] (ReqArg set_diploid "PRF") "Targets starting with PRF are diploid", + Option "D" ["damage"] (ReqArg set_damage "PARMS") "Set universal damage parameters", + Option "l" ["overhang-param","left-overhang-param"] + (ReqArg set_loverhang "PROB") "Parameter for 5' overhang length is PROB", + Option "r" ["right-overhang-param"] (ReqArg set_roverhang "PROB") "Parameter for 3' overhang length is PROB, assume single-strand prep", + Option "d" ["deamination-rate","ds-deamination-rate","double-strand-deamination-rate"] + (ReqArg set_ds_deam "FRAC") "Deamination rate in double stranded section is FRAC", + Option "s" ["ss-deamination-rate","single-strand-deamination-rate"] + (ReqArg set_ss_deam "FRAC") "Deamination rate in single stranded section is FRAC", + Option "t" ["theta","dependency-coefficient"] + (ReqArg set_theta "FRAC") "Set dependency coefficient to FRAC (\"N\" to turn off)", + Option "H" ["prior-heterozygous", "heterozygosity"] + (ReqArg set_phet "PROB") "Set prior for a heterozygous variant to PROB", + -- Removed this, because it needs access to a reference. + -- But maybe we can derive this from a suitable BAM file? + -- Or move it to another tool? + -- Option "S" ["prior-snp","snp-rate","divergence"] + -- (ReqArg set_pdiv "PROB") "Set prior for an indel variant to PROB", + Option "I" ["prior-indel","indel-rate"] (ReqArg set_pindel "PROB") "Set prior for an indel variant to PROB", + Option "v" ["verbose"] (NoArg be_verbose) "Print more diagnostics", + Option "h?" ["help","usage"] (NoArg disp_usage) "Display this message" ] + where + disp_usage _ = do pn <- getProgName + let blah = "Usage: " ++ pn ++ " [OPTION...] [BAM-FILE...]" + putStrLn $ usageInfo blah options + exitFailure + + be_verbose c = return $ c { conf_report = hPutStrLn stderr } + + set_fa_output fn = add_output $ output_fasta fn + set_avro_out fn = add_output $ output_avro fn + + add_output ofn cf = + return $ cf { conf_output = Just $ \k -> + ofn $ \oit1 -> maybe (k oit1) ($ \oit2 -> k (\c r -> () <$ I.zip (oit1 c r) (oit2 c r))) (conf_output cf) } + + set_sample nm c = return $ c { conf_sample = S.pack nm } + + set_haploid arg c = return $ c { conf_ploidy = \chr -> if S.pack arg `S.isPrefixOf` chr then 1 else conf_ploidy c chr } + set_diploid arg c = return $ c { conf_ploidy = \chr -> if S.pack arg `S.isPrefixOf` chr then 2 else conf_ploidy c chr } + + set_theta "N" c = return $ c { conf_theta = Nothing } + set_theta a c = (\t -> c { conf_theta = Just t }) <$> readIO a + set_loverhang a c = (\l -> c { conf_loverhang = Just l }) <$> readIO a + set_roverhang a c = (\l -> c { conf_roverhang = Just l }) <$> readIO a + set_ss_deam a c = (\r -> c { conf_ss_deam = r }) <$> readIO a + set_ds_deam a c = (\r -> c { conf_ds_deam = r }) <$> readIO a + set_phet a c = (\r -> c { conf_prior_het = toProb r }) <$> readIO a + set_pindel a c = (\r -> c { conf_prior_indel = toProb r }) <$> readIO a + set_damage a c = (\u -> c { conf_damage = Just u }) <$> readIO a + +main :: IO () +main = do + (opts, files, errs) <- getOpt Permute options <$> getArgs + unless (null errs) $ mapM_ (hPutStrLn stderr) errs >> exitFailure + conf@Conf{..} <- foldl (>>=) (return defaultConf) opts + + let no_damage = conf_report "using no damage model" >> return noDamage + ss_damage p = conf_report ("using single strand damage model with " ++ show p) >> return (univDamage p) + ds_damage p = conf_report ("using double strand damage model with " ++ show p) >> return (univDamage p) + u_damage p = conf_report ("using universal damage parameters " ++ show p) >> return (univDamage p) + + dmg_model <- case (conf_damage, conf_loverhang, conf_roverhang) of + (Just u, _, _) -> u_damage u + (_, Nothing, Nothing) -> no_damage + (_, Just pl, Nothing) -> ds_damage $ DP 0 0 0 0 conf_ss_deam conf_ds_deam pl + (_, Nothing, Just pr) -> ss_damage $ DP conf_ss_deam conf_ds_deam pr pr 0 0 0 + (_, Just pl, Just pr) -> ss_damage $ DP conf_ss_deam conf_ds_deam pl pr 0 0 0 + + maybe (output_fasta "-") id conf_output $ \oiter -> + mergeInputs combineCoordinates files >=> run $ \hdr -> + filterStream ((\b -> not (isUnmapped b) && isValidRefseq (b_rname b)) . unpackBam) =$ + progressPos "GT call at " conf_report (meta_refs hdr) =$ + by_groups ((==) `on` b_rname . unpackBam) (\br out -> do + let sname = sq_name $ getRef (meta_refs hdr) $ b_rname $ unpackBam br + pl = conf_ploidy sname + liftIO $ conf_report $ S.unpack sname ++ ["",": haploid call",": diploid call"] !! pl + pileup dmg_model =$ mapStream (calls conf_theta pl) out) =$ + oiter conf (meta_refs hdr) + + +type OIter = Conf -> Refs -> Iteratee [Calls] IO () +type Output = (OIter -> IO ()) -> IO () + +output_fasta :: FilePath -> (OIter -> IO r) -> IO r +output_fasta fn k = if fn == "-" then k (fa_out stdout) + else withFile fn WriteMode $ k . fa_out + where + fa_out :: Handle -> Conf -> Refs -> Iteratee [Calls] IO () + fa_out hdl Conf{..} refs = + by_groups ((==) `on` p_refseq) (\cs out -> do + let sname = sq_name $ getRef refs $ p_refseq cs + out' <- lift $ enumPure1Chunk [S.concat [">", conf_sample, "--", sname]] out + convStream (do callz <- headStream + let s1 = format_snp_call conf_prior_het callz + S.append s1 <$> format_indel_call conf_prior_indel callz) + =$ collect_lines out') =$ + mapStreamM_ (S.hPut hdl . (flip S.snoc '\n')) + + +-- | We do calls of any ploidy, but the FastA output code will fail if +-- the ploidy isn't 1 or 2. For indel calls, the FastA output will also +-- cheat and pretend it was a haploid call. +-- +-- XXX For the time being, forward and reverse piles get concatenated. +-- For the naive call, this doesn't matter. For the MAQ call, it feels +-- more correct to treat them separately and multiply (add?) the results. + +calls :: Maybe Double -> Int -> Pile -> Calls +calls Nothing pl pile = pile { p_snp_pile = s, p_indel_pile = i } + where + !s = simple_snp_call pl $ uncurry (++) $ p_snp_pile pile + !i = force $ simple_indel_call pl $ p_indel_pile pile + +calls (Just theta) pl pile = pile { p_snp_pile = s, p_indel_pile = i } + where + !s = maq_snp_call pl theta $ uncurry (++) $ p_snp_pile pile -- XXX + !i = force $ simple_indel_call pl $ p_indel_pile pile + +instance NFData IndelVariant where + rnf (IndelVariant d (V_Nuc i)) = rnf d `seq` rnf i `seq` () + + +-- | Formatting a SNP call. If this was a haplopid call (four GL +-- values), we pick the most likely base and pass it on. If it was +-- diploid, we pick the most likely dinucleotide and pass it on. + +format_snp_call :: Prob -> Calls -> S.ByteString +format_snp_call p cs + | V.length gl == 4 = S.take 1 $ S.drop (maxQualIndex gl) hapbases + | V.length gl == 10 = S.take 1 $ S.drop (maxQualIndex $ V.zipWith (*) ps gl) dipbases + | otherwise = error "Thou shalt not try to format_snp_call unless thou madeth a haploid or diploid call!" + where + gl = p_snp_pile cs + ps = V.fromListN 10 [p,1,p,1,1,p,1,1,1,p] + dipbases = "NAMCRSGWYKT" + hapbases = "NACGT" + +-- | Formatting an Indel call. We pick the most likely variant and +-- pass its sequence on. Then we drop incoming calls that should be +-- deleted according to the chosen variant. Note that this will blow up +-- unless the call was done assuming a haploid genome (which is +-- guaranteeed /in this program/)! + +format_indel_call :: Monad m => Prob -> Calls -> Iteratee [Calls] m S.ByteString +format_indel_call p cs + | V.length gl0 == nv = go gl0 + | V.length gl0 == nv * (nv+1) `div` 2 = go homs + | otherwise = error "Thou shalt not try to format_indel_call unless thou madeth a haploid or diploid call!" + where + (gl0,vars) = p_indel_pile cs + !nv = length vars + !homs = V.fromListN nv [ gl0 V.! (i*(i+1) `div` 2 -1) | i <- [1..nv] ] + + go gl = I.dropWhile skip >> return (S.pack $ show $ V.toList ins) + where + eff_gl = V.fromList $ zipWith adjust (V.toList gl) vars + adjust q (IndelVariant ds (V_Nuc is)) = if ds == 0 && V.null is then q else p * q + + IndelVariant del (V_Nuc ins) = ( IndelVariant 0 (V_Nuc V.empty) : vars ) !! maxQualIndex eff_gl + skip ocs = p_refseq ocs == p_refseq cs && p_pos ocs < p_pos cs + del + +maxQualIndex :: V.Vector Prob -> Int +maxQualIndex vec = case V.ifoldl' step (0, 0, 0) vec of + (!i, !m, !m2) -> if m / m2 > 2 then i else 0 + where + step (!i,!m,!m2) j v = if v >= m then (j+1,v,m) else (i,m,m2) + +collect_lines :: Monad m => Enumeratee S.ByteString [S.ByteString] m r +collect_lines = eneeCheckIfDone (liftI . go S.empty) + where + go acc k (EOF mx) = idone (k $ Chunk [acc]) $ EOF mx + go acc k (Chunk s) = case S.splitAt 60 (acc `S.append` s) of + (left, right) | S.null right -> liftI $ go left k + | otherwise -> eneeCheckIfDone (liftI . go right) . k $ Chunk [left] + +by_groups :: ( Monad m, ListLike s a, Nullable s ) + => (a -> a -> Bool) -> (a -> Enumeratee s b m r) -> Enumeratee s b m r +by_groups pr k out = do + mhd <- peekStream + case mhd of + Nothing -> return out + Just hd -> takeWhileE (pr hd) =$ k hd out >>= by_groups pr k + + +output_avro :: FilePath -> (OIter -> IO r) -> IO r +output_avro fn k = if fn == "-" then k (av_out stdout) + else withFile fn WriteMode $ k . av_out + where + av_out :: Handle -> Conf -> Refs -> Iteratee [Calls] IO () + av_out hdl _cfg refs = compileBlocks refs =$ + writeAvroContainer ContainerOpts{..} =$ + mapChunksM_ (S.hPut hdl) + + objects_per_block = 16 + filetype_label = "Genotype Likelihoods V0.1" + + +-- Serialize the results from genotype calling in a sensible way. We +-- write an Avro file, but we add another blocking layer on top so we +-- don't need to endlessly repeat coordinates. + +compileBlocks :: Monad m => Refs -> Enumeratee [Calls] [GenoCallBlock] m a +compileBlocks refs = convStream $ do + c1 <- headStream + tailBlock (p_refseq c1) (p_pos c1) (p_pos c1) (16*1024 :: Int) [pack c1] + where + tailBlock !rs !p0 !po !n acc = do + mc <- peekStream + case mc of + Just c1 | rs == p_refseq c1 && po+1 == p_pos c1 && n > 0 -> do + _ <- headStream + tailBlock rs p0 (po+1) (n-1) $ pack c1 : acc + + _ -> return [ GenoCallBlock + { reference_name = T.decodeLatin1 $ sq_name $ getRef refs rs + , start_position = p0 + , called_sites = reverse acc } ] + + pack c1 = GenoCallSite{..} + where + snp_stats = p_snp_stat c1 + indel_stats = p_indel_stat c1 + snp_likelihoods = compact_likelihoods $ p_snp_pile c1 + indel_likelihoods = compact_likelihoods $ fst $ p_indel_pile c1 + indel_variants = snd $ p_indel_pile c1 + +-- | Storing likelihoods: we take the natural logarithm (GL values are +-- already in a log scale) and convert to minifloat 0.4.4 +-- representation. Range and precision should be plenty. +compact_likelihoods :: V.Vector Prob -> [Int] -- B.ByteString +compact_likelihoods = map fromIntegral {- B.pack -} . V.toList . V.map (float2mini . negate . unPr) + diff --git a/tools/jivebunny.hs b/tools/jivebunny.hs new file mode 100644 --- /dev/null +++ b/tools/jivebunny.hs @@ -0,0 +1,531 @@ +{-# LANGUAGE OverloadedStrings, BangPatterns, ForeignFunctionInterface #-} +{-# LANGUAGE RecordWildCards, MultiParamTypeClasses, TypeFamilies #-} + +-- Two-stage demultiplexing. +-- +-- We assume we know the list of i7 and i5 index oligos. We seek to +-- decompose a set of reads into a mix of pairs of these by the Maximum +-- Likelihood method. Once that's done, an empirical Bayesian Maximum +-- Posterior call is done. All kinds of errors can be rolled into one +-- quality score. +-- +-- - Input layer to gather index sequences. (Done.) +-- - Input layer to gather read group defs. (Done.) +-- - First pass to gather data. Any index read shall be represented +-- in a single Word64. (Done. Reading BAM is slow. BCL would be +-- much more suitable here.) +-- - Multiple passes of the EM algorithm. (Done.) +-- - Start with a naive mix, to avoid arguments. (Done.) +-- - Final calling pass from BAM to BAM. (Done. BCL to BAM would be +-- even nicer.) +-- - Auxillary statistics: composition of the mix (Done.), false +-- assignment rates per read group (Done.), maximum achievable false +-- assignment rates (Done.) + +import Bio.Bam +import Bio.Util ( showNum ) +import Control.Applicative +import Control.Arrow ( (&&&) ) +import Control.Monad ( when, unless, forM_, foldM ) +import Data.Aeson +import Data.Bits +import Data.List ( foldl', sortBy ) +import Data.Monoid +import Data.String ( fromString ) +import Data.Version ( showVersion ) +import Data.Word ( Word64 ) +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import Paths_biohazard ( version, getDataFileName ) +import System.Console.GetOpt +import System.Environment ( getProgName, getArgs ) +import System.Exit +import System.IO +import System.Random ( randomRIO ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BS +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as L hiding ( singleton ) +import qualified Data.Text.Lazy.IO as L +import qualified Data.Text.Lazy.Builder as L +import qualified Data.Text.Lazy.Builder.Int as L +import qualified Data.Text.Lazy.Builder.RealFloat as L +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Intro as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM + +import Index + +fromS :: B.ByteString -> Index +fromS sq = fromSQ sq (B.replicate (B.length sq) 64) + +fromSQ :: B.ByteString -> B.ByteString -> Index +fromSQ sq qs = Index . foldl' (\a b -> a `shiftL` 8 .|. fromIntegral b) 0 $ + take 8 $ (++ repeat 0) $ + B.zipWith (\b q -> shiftL (b .&. 0xE) 4 .|. (min 31 $ max 33 q - 33)) sq qs + +fromTags :: BamKey -> BamKey -> BamRaw -> Index +fromTags itag qtag br = fromSQ sq (if B.null qs then "@@@@@@@@" else qs) + where + sq = extAsString itag $ unpackBam br + qs = extAsString qtag $ unpackBam br + +gather :: MonadIO m => Int -> (String -> IO ()) -> (String -> IO ()) -> BamMeta -> Iteratee [BamRaw] m (U.Vector (Index, Index)) +gather num say mumble hdr = case hdr_sorting $ meta_hdr hdr of + Unsorted -> greedy + Grouped -> greedy + Queryname -> greedy + Unknown -> safe + Coordinate -> fair + GroupSorted -> fair + where + greedy = do liftIO . say $ "File is unsorted, sampling up to " + ++ showNum num ++ " records from the beginning.\n" + go stream2vectorN + + fair = do liftIO . say $ "File is sorted, need to sample up to " + ++ showNum num ++ " from whole file.\n" + go subsam2vector + + safe = do liftIO . say $ "File might be sorted, need to sample up to " + ++ showNum num ++ " from whole file.\n" + go subsam2vector + + go k = filterStream ((\b -> not (isPaired b) || isFirstMate b) . unpackBam) =$ + progressNum "reading " mumble =$ + mapStream (fromTags "XI" "YI" &&& fromTags "XJ" "YJ") =$ k num + + +subsam2vector :: (MonadIO m, ListLike s a, Nullable s, VG.Vector v a) => Int -> Iteratee s m (v a) +subsam2vector sz = liftIO (VGM.new sz) >>= go 0 + where + go !i !mv = tryHead >>= \x -> case x of + Nothing -> liftIO $ if i < sz then VG.unsafeFreeze $ VGM.take i mv + else VG.unsafeFreeze mv + Just a -> do liftIO $ if i < sz + then VGM.write mv i a + else do p <- randomRIO (0,i) + when (p < sz) $ VGM.write mv p a + go (i+1) mv + +data IndexTab = IndexTab { unique_indices :: U.Vector Index + , canonical_names :: V.Vector T.Text + , alias_names :: HM.HashMap T.Text Int } + +single_placeholder :: IndexTab +single_placeholder = IndexTab (U.singleton (fromS "")) (V.singleton "is4") $ + HM.fromList [ (k,0) | [_,_,k] <- map T.words $ T.lines default_rgs ] + +data Both = Both { p7is :: IndexTab, p5is :: IndexTab } + +instance FromJSON Both where + parseJSON = withObject "toplevel object expected" $ \v -> + both <$> ((v .: "p7index") >>= parse_assocs) + <*> (((v .: "p5index") >>= parse_assocs) <|> pure []) + where + parse_assocs = withObject "association list expected" $ \o -> + sequence [ (,) k <$> withText "sequence expected" (return . T.encodeUtf8) v | (k,v) <- HM.toList o ] + + both as7 as5 = Both (canonical as7) (canonical as5) + where + canonical pairs = + let hm = HM.toList $ HM.fromListWith (++) [ (fromS v,[k]) | (k,v) <- pairs ] + in IndexTab (U.fromList $ map fst hm) + (V.fromList $ map (head . snd) hm) + (HM.fromList $ [ (k,i) | (i, ks) <- zip [0..] (map snd hm), k <- ks ]) + +data RG = RG { rgid :: B.ByteString + , rgi7 :: Int + , rgi5 :: Int + , tags :: BamOtherShit } + +-- | Parses read group defintions from a file. The file can have +-- optional header lines, the remainder must be a tab-separated table, +-- first column is the read group name, second is the P7 index name, +-- third is the P5 index name (*must* be present), all others are tagged +-- fields just like BAM expects them in the header. +-- +-- For integration with a LIMS, something structured like JSON would +-- probably work better, however, absent such a LIMS, tables are easier +-- to come by. + +readRGdefns :: HM.HashMap T.Text Int -> HM.HashMap T.Text Int -> T.Text -> [ RG ] +readRGdefns p7is p5is = map repack . filter (not . null) . map (T.split (=='\t')) + . dropWhile ("#" `T.isPrefixOf`) . T.lines + where + repack (rg:_) | T.any (\c -> c == '/' || c == ',') rg = error $ "RG name must not contain ',' or '/': " ++ show rg + repack (rg:p7:p5:tags) = case HM.lookup p7 p7is of + Nothing -> error $ "unknown P7 index " ++ show p7 + Just i7 -> case HM.lookup p5 p5is of + Nothing -> error $ "unknown P5 index " ++ show p5 + Just i5 -> RG (T.encodeUtf8 rg) i7 i5 (map repack1 tags) + repack ws = error $ "short RG line " ++ show (T.intercalate "\t" ws) + repack1 w | T.length w > 3 && T.index w 2 == ':' + = (fromString [T.index w 0, T.index w 1], T.encodeUtf8 $ T.drop 3 w) + | otherwise = error $ "illegal tag " ++ show w + +default_rgs :: T.Text +default_rgs = "PhiXA\tPhiA\tPhiA\nPhiXC\tPhiC\tPhiC\nPhiXG\tPhiG\tPhiG\nPhiXT\tPhiT\tPhiT\nPhiX\tPhiX\tis4\n" + +-- | Compute mismatch score: sum of the qualities in 'a' at positions +-- where the bases don't match. Works by comparing through an xor, +-- building a mask from it, then adding quality scores sideways. +-- +-- Since we keep quality scores in the lower 5 bits of each byte, adding +-- all eight is guaranteed to fit into the highest 8 bits. +match :: Index -> Index -> Word64 +match (Index a) (Index b) = score + where x = a `xor` b + y = (shiftR x 5 .|. shiftR x 6 .|. shiftR x 7) .&. 0x0101010101010101 + mask = (0x2020202020202020 - y) .&. 0x1F1F1F1F1F1F1F1F + score = shiftR ((a .&. mask) * 0x0101010101010101) 56 + +-- | A mixture description is one probability for each combination of p7 +-- and p5 index. They should sum to one. +type Mix = VS.Vector Double +type MMix = VSM.IOVector Double + +padding :: Int +padding = 31 + +stride' :: Int -> Int +stride' n5 = (n5 + padding) .&. complement padding + +-- | Computing the naively assumed mix when nothing is known: uniform +-- distribution. +naiveMix :: (Int,Int) -> Int -> Mix +naiveMix (n7,n5) total = VS.replicate vecsize (fromIntegral total / fromIntegral bins) + where + !vecsize = n7 * stride' n5 + !bins = n7 * n5 + +-- | Matches an index against both p7 and p5 lists, computes posterior +-- likelihoods from the provided prior and accumulates them onto the +-- posterior. +unmix1 :: U.Vector Index -> U.Vector Index -> Mix -> MMix -> (Index, Index) -> IO () +unmix1 p7 p5 prior acc (x,y) = + let !m7 = VS.fromListN (U.length p7) . map (phredPow . match x) $ U.toList p7 + !l5 = stride' (U.length p5) + !m5 = VS.fromListN l5 $ map (phredPow . match y) (U.toList p5) ++ repeat 0 + + -- *sigh*, Vector doesn't fuse well. Gotta hand it over to gcc. :-( + in VSM.unsafeWith acc $ \pw -> + VS.unsafeWith prior $ \pv -> + VS.unsafeWith m7 $ \q7 -> + VS.unsafeWith m5 $ \q5 -> + c_unmix_total pv q7 (fromIntegral $ VS.length m7) + q5 (fromIntegral $ l5 `div` succ padding) + nullPtr nullPtr >>= \total -> + c_unmix_qual pw pv q7 (fromIntegral $ VS.length m7) + q5 (fromIntegral $ l5 `div` succ padding) + total 0 0 >>= \_qual -> + return () -- the quality is meaningless here + +foreign import ccall unsafe "c_unmix_total" + c_unmix_total :: Ptr Double -- prior mix + -> Ptr Double -> CUInt -- P7 scores, length + -> Ptr Double -> CUInt -- P5 scores, length/32 + -> Ptr CUInt -> Ptr CUInt -- out: ML P7 index, P5 index + -> IO Double -- total likelihood + +foreign import ccall unsafe "c_unmix_qual" + c_unmix_qual :: Ptr Double -- posterior mix, mutable accumulator + -> Ptr Double -- prior mix + -> Ptr Double -> CUInt -- P7 scores, length + -> Ptr Double -> CUInt -- P5 scores, length/32 + -> Double -- total likelihood + -> CUInt -> CUInt -- maximizing P7 index, P5 index + -> IO Double -- posterior probability for any other assignment + +-- | Matches an index against both p7 and p5 lists, computes MAP +-- assignment and quality score. +class1 :: HM.HashMap (Int,Int) (B.ByteString, VSM.IOVector Double) + -> U.Vector Index -> U.Vector Index + -> Mix -> (Index, Index) -> IO (Double, Int, Int) +class1 rgs p7 p5 prior (x,y) = + let !m7 = VS.fromListN (U.length p7) . map (phredPow . match x) $ U.toList p7 + !l5 = stride' (U.length p5) + !m5 = VS.fromListN l5 $ map (phredPow . match y) (U.toList p5) ++ repeat 0 + + -- *sigh*, Vector doesn't fuse well. Gotta hand it over to gcc. :-( + in alloca $ \pi7 -> + alloca $ \pi5 -> + VS.unsafeWith prior $ \pv -> + VS.unsafeWith m7 $ \q7 -> + VS.unsafeWith m5 $ \q5 -> + ( {-# SCC "c_unmix_total" #-} + c_unmix_total pv q7 (fromIntegral $ VS.length m7) + q5 (fromIntegral $ l5 `div` succ padding) + pi7 pi5 ) >>= \total -> + peek pi7 >>= \i7 -> + peek pi5 >>= \i5 -> + withDirt (fromIntegral i7, fromIntegral i5) $ \pw -> + ( {-# SCC "c_unmix_qual" #-} + c_unmix_qual pw pv q7 (fromIntegral $ VS.length m7) + q5 (fromIntegral $ l5 `div` succ padding) + total i7 i5 ) >>= \qual -> + return ( qual, fromIntegral i7, fromIntegral i5 ) + where + withDirt ix k = case HM.lookup ix rgs of + Just (_,dirt) -> VSM.unsafeWith dirt k + Nothing -> k nullPtr + + +phredPow :: Word64 -> Double +phredPow x = exp $ -0.1 * log 10 * fromIntegral x + +-- | One iteration of the EM algorithm. Input is a vector of pairs of +-- indices, the p7 and p5 index collections, and a prior mixture; output +-- is the posterior mixture. +iterEM :: U.Vector (Index, Index) -> U.Vector Index -> U.Vector Index -> Mix -> IO Mix +iterEM pairs p7 p5 prior = do + acc <- VSM.replicate (VS.length prior) 0 + U.mapM_ (unmix1 p7 p5 prior acc) pairs + VS.unsafeFreeze acc + +data Loudness = Quiet | Normal | Loud + +unlessQuiet :: Monad m => Loudness -> m () -> m () +unlessQuiet Quiet _ = return () +unlessQuiet _ k = k + +data Conf = Conf { + cf_index_list :: FilePath, + cf_output :: Maybe (BamMeta -> Iteratee [BamRec] IO ()), + cf_stats_hdl :: Handle, + cf_num_stats :: Int -> Int, + cf_threshold :: Double, + cf_loudness :: Loudness, + cf_single :: Bool, + cf_samplesize :: Int, + cf_readgroups :: [FilePath] } + +defaultConf :: IO Conf +defaultConf = do ixdb <- getDataFileName "index_db.json" + return $ Conf { + cf_index_list = ixdb, + cf_output = Nothing, + cf_stats_hdl = stdout, + cf_num_stats = \l -> max 20 $ l * 5 `div` 4, + cf_threshold = 0.000005, + cf_loudness = Normal, + cf_single = False, + cf_samplesize = 50000, + cf_readgroups = [] } + +options :: [OptDescr (Conf -> IO Conf)] +options = [ + Option "o" ["output"] (ReqArg set_output "FILE") "Send output to FILE", + Option "I" ["index-database"] (ReqArg set_index_db "FILE") "Read index database from FILE", + Option "r" ["read-groups"] (ReqArg set_rgs "FILE") "Read read group definitions from FILE", + Option "s" ["single-index"] (NoArg set_single) "Only consider first index", + Option [ ] ["threshold"] (ReqArg set_thresh "FRAC") "Iterate till uncertainty is below FRAC", + Option [ ] ["sample"] (ReqArg set_sample "NUM") "Sample NUM reads for mixture estimation", + Option [ ] ["components"] (ReqArg set_compo "NUM") "Print NUM components of the mixture", + Option "v" ["verbose"] (NoArg set_loud) "Print more diagnostic messages", + Option "q" ["quiet"] (NoArg set_quiet) "Print fewer diagnostic messages", + Option "h?" ["help", "usage"] (NoArg (const usage)) "Print this message and exit", + Option "V" ["version"] (NoArg (const vrsn)) "Display version number and exit" ] + where + set_output "-" c = return $ c { cf_output = Just $ pipeBamOutput, cf_stats_hdl = stderr } + set_output fp c = return $ c { cf_output = Just $ writeBamFile fp } + set_index_db fp c = return $ c { cf_index_list = fp } + set_rgs fp c = return $ c { cf_readgroups = fp : cf_readgroups c } + set_loud c = return $ c { cf_loudness = Loud } + set_quiet c = return $ c { cf_loudness = Quiet } + set_single c = return $ c { cf_single = True } + set_thresh a c = readIO a >>= \x -> return $ c { cf_threshold = x } + set_sample a c = readIO a >>= \x -> return $ c { cf_samplesize = x } + set_compo a c = readIO a >>= \x -> return $ c { cf_num_stats = const x } + + usage = do pn <- getProgName + putStrLn $ usageInfo ("Usage: " ++ pn ++ " [options] [bam-files]\n" ++ + "Decomposes a mix of libraries and assigns read groups.") options + exitSuccess + + vrsn = do pn <- getProgName + hPutStrLn stderr $ pn ++ ", version " ++ showVersion version + exitSuccess + + +adj_left :: Int -> Char -> L.Builder -> L.Builder +adj_left n c b = mconcat (replicate (n - fromIntegral (L.length t)) (L.singleton c)) <> L.fromLazyText t + where t = L.toLazyText b + +adj_left_text :: Int -> Char -> T.Text -> L.Builder +adj_left_text n c t = mconcat (replicate (n - T.length t) (L.singleton c)) <> L.fromText t + +main :: IO () +main = do + (opts, files, errs) <- getOpt Permute options <$> getArgs + unless (null errs) $ mapM_ (hPutStrLn stderr) errs >> exitFailure + Conf{..} <- foldl (>>=) defaultConf opts + when (null files) $ hPutStrLn stderr "no input files." >> exitFailure + add_pg <- addPG $ Just version + + let notice = case cf_loudness of Quiet -> \_ -> return () ; _ -> hPutStr stderr + info = case cf_loudness of Loud -> hPutStr stderr ; _ -> \_ -> return () + + Both{..} <- B.readFile cf_index_list >>= \raw -> case decodeStrict' raw of + Nothing -> hPutStrLn stderr "Couldn't parse index database." >> exitFailure + Just x | cf_single -> return $ x { p5is = single_placeholder } + | otherwise -> return x + + rgdefs <- concatMap (readRGdefns (alias_names p7is) (alias_names p5is)) . (:) default_rgs <$> mapM T.readFile cf_readgroups + notice $ "Got " ++ showNum (U.length (unique_indices p7is)) ++ " unique P7 indices and " + ++ showNum (U.length (unique_indices p5is)) ++ " unique P5 indices.\n" + notice $ "Declared " ++ showNum (length rgdefs) ++ " read groups.\n" + + let n7 = U.length $ unique_indices p7is + n5 = U.length $ unique_indices p5is + stride = stride' n5 + vsize = n7 * stride + + !rgs <- do let dup_error x y = error $ "Read groups " ++ show (fst x) ++ " and " + ++ show (fst y) ++ " have the same indices." + HM.fromListWith dup_error <$> sequence + [ VSM.replicate vsize (0::Double) >>= \dirt -> return ((i7,i5),(rg,dirt)) + | RG !rg !i7 !i5 _ <- rgdefs ] + + let inspect = inspect' rgs (canonical_names p7is) (canonical_names p5is) + + ixvec <- concatInputs files >=> run $ gather cf_samplesize notice info + notice $ "Got " ++ showNum (U.length ixvec) ++ " index pairs.\n" + + notice "decomposing mix " + let loop !n v = do v' <- iterEM ixvec (unique_indices p7is) (unique_indices p5is) v + case cf_loudness of Loud -> hPutStrLn stderr [] >> inspect stderr 20 v' + Normal -> hPutStr stderr "." + Quiet -> return () + let d = VS.foldl' (\a -> max a . abs) 0 $ VS.zipWith (-) v v' + if n > 0 && d > cf_threshold * fromIntegral (U.length ixvec) + then loop (n-1) v' + else do notice (if n == 0 then "\nmaximum number of iterations reached.\n" + else "\nmixture ratios converged.\n") + return v' + + mix <- loop (50::Int) $ naiveMix (U.length $ unique_indices p7is, U.length $ unique_indices p5is) (U.length ixvec) + + unlessQuiet cf_loudness $ do + T.hPutStrLn cf_stats_hdl "\nfinal mixture estimate:" + inspect cf_stats_hdl (cf_num_stats $ HM.size rgs) mix + + let maxlen = maximum $ map (B.length . rgid) rgdefs + ns7 = canonical_names p7is + ns5 = canonical_names p5is + num = 7 + sortOn f = sortBy (\a b -> compare (f a) (f b)) + + case cf_output of + Nothing -> do unlessQuiet cf_loudness $ do + T.hPutStrLn cf_stats_hdl "\nmaximum achievable quality, top pollutants:" + forM_ (sortOn (fst.snd) $ HM.toList rgs) $ \((i7,i5), (rgid,_)) -> do + (p,_,_) <- class1 HM.empty (unique_indices p7is) (unique_indices p5is) mix + (unique_indices p7is U.! i7, unique_indices p5is U.! i5) + + let qmax = negate . round $ 10 / log 10 * log p :: Int + L.hPutStrLn cf_stats_hdl . L.toLazyText $ + adj_left_text maxlen ' ' (T.decodeUtf8 rgid) <> + L.fromText ": " <> + adj_left 4 ' ' (L.singleton 'Q' <> L.decimal (max 0 qmax)) + + Just out -> do concatInputs files >=> run $ \hdr -> + let hdr' = hdr { meta_other_shit = + [ os | os@(k,_) <- meta_other_shit hdr, k /= "RG" ] ++ + HM.elems (HM.fromList [ (rgid, ("RG", ("ID",rgid):tags)) | RG{..} <- rgdefs ] ) } + in mapStreamM (\br -> do + let b = unpackBam br + eff_rgs | not (isPaired b) = rgs + | isFirstMate b = rgs + | otherwise = HM.empty + (p,i7,i5) <- class1 eff_rgs (unique_indices p7is) (unique_indices p5is) mix + (fromTags "XI" "YI" br, fromTags "XJ" "YJ" br) + let q = negate . round $ 10 / log 10 * log p + ex = deleteE "ZR" . deleteE "Z0" . deleteE "Z2" . updateE "Z1" (Int q) $ + updateE "ZX" (Text $ T.encodeUtf8 $ T.concat [ ns7 V.! i7, ",", ns5 V.! i5 ]) $ + case HM.lookup (i7,i5) rgs of + Nothing -> deleteE "RG" $ b_exts b + Just (rgn,_) -> updateE "RG" (Text rgn) $ b_exts b + return $ case lookup "ZQ" ex of + Just (Text t) | BS.null t' -> b { b_exts = deleteE "ZQ" ex + , b_flag = b_flag b .&. complement flagFailsQC } + | otherwise -> b { b_exts = updateE "ZQ" (Text t') ex } + where + t' = BS.filter (\c -> c /= 'C' && c /= 'I' && c /= 'W') t + _ -> b { b_exts = ex + , b_flag = b_flag b .&. complement flagFailsQC }) =$ + progressNum "writing " info =$ + out (add_pg hdr') + + unlessQuiet cf_loudness $ do + grand_total <- foldM (\ !acc (_,dirt) -> VS.freeze dirt >>= return . (+) acc . VS.sum) 0 (HM.elems rgs) + T.hPutStrLn cf_stats_hdl "\nmaximum achievable and average quality, top pollutants:" + forM_ (sortOn (fst.snd) $ HM.toList rgs) $ \((i7,i5), (rgid,dirt_)) -> do + dirt <- VS.freeze dirt_ + (p,_,_) <- class1 HM.empty (unique_indices p7is) (unique_indices p5is) mix + (unique_indices p7is U.! i7, unique_indices p5is U.! i5) + + let total = VS.sum dirt + others = VS.sum $ VS.ifilter (\i _ -> i /= i7 * stride + i5) dirt + qmax = negate . round $ 10 / log 10 * log p :: Int + qavg = negate . round $ 10 / log 10 * log (others/total) :: Int + + v <- U.unsafeThaw . U.fromListN (VS.length dirt) . zip [0..] . VS.toList $ dirt + V.sortBy (\(_,a) (_,b) -> compare b a) v -- meh. + v' <- U.unsafeFreeze v + + let fmt_one (i,n) = + let (i7', i5') = i `quotRem` stride + chunk = L.formatRealFloat L.Fixed (Just 2) (100*n/total) <> L.singleton '%' <> + L.singleton ' ' <> L.fromText (ns7 V.! i7') <> + L.singleton '/' <> L.fromText (ns5 V.! i5') <> + case HM.lookup (i7',i5') rgs of + Nothing -> mempty + Just (rg,_) -> L.singleton ' ' <> L.singleton '(' <> + L.fromText (T.decodeUtf8 rg) <> L.singleton ')' + in if (i7 == i7' && i5 == i5') || i5' >= n5 then id else (:) chunk + + when (total >= 1) . L.hPutStrLn cf_stats_hdl . L.toLazyText $ + adj_left_text maxlen ' ' (T.decodeUtf8 rgid) <> + L.singleton ':' <> L.singleton ' ' <> + adj_left 4 ' ' (L.singleton 'Q' <> L.decimal (max 0 qmax)) <> L.fromText ", " <> + adj_left 4 ' ' (L.singleton 'Q' <> L.decimal (max 0 qavg)) <> L.fromText ", " <> + L.fromString (showNum (round total :: Int)) <> L.fromText " (" <> + L.formatRealFloat L.Fixed (Just 2) (100*total/grand_total) <> L.fromText "%); " <> + foldr1 (\a b -> a <> L.fromText ", " <> b) + (take num $ U.foldr fmt_one [] v') + +inspect' :: HM.HashMap (Int,Int) (B.ByteString, t) -> V.Vector T.Text -> V.Vector T.Text -> Handle -> Int -> Mix -> IO () +inspect' rgs n7 n5 hdl num mix = do + v <- U.unsafeThaw $ U.fromListN (VS.length mix) $ zip [0..] $ VS.toList mix + V.partialSortBy (\(_,a) (_,b) -> compare b a) v num -- meh. + v' <- U.unsafeFreeze v + + let total = U.sum . U.map snd $ v' + others = U.sum . U.map snd . U.drop num $ v' + + U.forM_ (U.take num v') $ \(i,n) -> do + let (i7, i5) = i `quotRem` stride' (V.length n5) + L.hPutStrLn hdl . L.toLazyText $ + adj_left_text 7 ' ' (n7 V.! i7) <> L.singleton ',' <> L.singleton ' ' <> + adj_left_text 7 ' ' (n5 V.! i5) <> L.singleton ':' <> L.singleton ' ' <> + adj_left 8 ' ' (L.formatRealFloat L.Fixed (Just 3) (100 * n / total)) <> L.singleton '%' <> L.singleton ' ' <> + case HM.lookup (i7,i5) rgs of + Nothing -> mempty + Just (rg,_) -> L.singleton '(' <> L.fromText (T.decodeUtf8 rg) <> L.singleton ')' + + L.hPutStrLn hdl . L.toLazyText $ + L.fromLazyText " all others: " <> + adj_left 8 ' ' (L.formatRealFloat L.Fixed (Just 3) (100 * others / total)) <> + L.singleton '%' + diff --git a/tools/mt-anno.hs b/tools/mt-anno.hs new file mode 100644 --- /dev/null +++ b/tools/mt-anno.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wall #-} +import Anno +import Seqs +import Xlate + +import Bio.Align +import Control.Applicative +import Data.Char +import Text.Printf + +import qualified Data.ByteString.Char8 as S + +main :: IO () +main = do + smps <- fromFasta . S.lines . S.filter (/= '\r') <$> S.getContents + + let (tabs, fas) = unzip $ map (uncurry do_anno) smps + + putStrLn $ unlines $ concatMap (++ [[]]) tabs + putStrLn $ unlines $ concatMap (++ [[]]) fas + + +do_anno :: S.ByteString -> S.ByteString -> ([String], [String]) +do_anno smp_name raw_sample = (tab, fa) + where + (_, rCRS, sample) = myersAlign 3000 {- maxd -} raw_rCRS Globally raw_sample + xpose1 = xpose rCRS sample + xpose_anno g = g { start = xpose1 (start g), end = xpose1 (end g) } + + tab = to_tab (S.unpack smp_name) $ map xpose_anno $ rCRS_anno + fa = concatMap (to_fasta smp_name sample xpose1) rCRS_anno + + +to_fasta :: S.ByteString -> S.ByteString -> (Int -> Int) -> Anno -> [String] +to_fasta smp_name smp f Gene{..} = case what of CDS -> go ; CDS' -> go ; _ -> [] + where + go = let s' = f start + e' = f end + prot = case init $ get_protein smp (s',e') of + 'I' : rest -> 'M' : rest ; x -> x + hdr = printf ">%s [gene=%s] [protein=%s] [location=%s]" + (S.unpack smp_name) name prod loc + loc | s' <= e' = shows s' ".." ++ show e' + | otherwise = "complement(" ++ shows e' ".." ++ shows s' ")" + in hdr : chunk prot + + chunk s = case splitAt 70 s of (u,v) | null v -> [u] + | otherwise -> u : chunk v + + +fromFasta :: [S.ByteString] -> [(S.ByteString, S.ByteString)] +fromFasta ls = case dropWhile (not . isHeader) ls of + [ ] -> [] + (h:rest) -> case break isHeader rest of + (body,rest') -> (S.drop 1 h, S.map toUpper $ S.concat body) : fromFasta rest' + where + isHeader s = not (S.null s) && S.head s == '>' + diff --git a/tools/mt-ccheck.hs b/tools/mt-ccheck.hs new file mode 100644 --- /dev/null +++ b/tools/mt-ccheck.hs @@ -0,0 +1,594 @@ +{-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards #-} +-- Simple Mitochondrial Contamination Check on BAM files. +-- +-- This is based on Ye Olde Contamination Check for the Neanderthal +-- genome; the method is the same (and will continue to not work on +-- modern humans), but simplified and sanitized. Differences from +-- before: +-- +-- * We use the alignment from the BAM file as is. Earlier we would +-- have created *two* new alignments. That is silly, however. Two +-- new alignments should not be followed by bean counting, but by an +-- attempt to genotype both the sample and the contaminant. +-- +-- * Before, the sample and contaminant sequences were fixed. Now we +-- instead input a list of the diagnostic positions. Instead of an +-- explicit list, the two sequences can still be used, or only the +-- contaminant can be supplied while the sample is genotype-called. + + +-- TODO +-- +-- (1) Given a list of diagnostic positions, implement the contamination +-- check. Structure of the code can be stolen from ccheck in the +-- mia package. +-- +-- - What do we do about wrapped alignments? Mia has f/b/a labels, +-- BAM doesn't. We can see if it overhangs, though. +-- +-- (2) Given a high-coverage sample, genotype call it and derive the +-- diagnostic positions. +-- +-- - This method needs some definition of the contaminant consensus +-- thingy. +-- +-- (3) Given a `correct' sample sequence, align it to the reference and +-- derive diagnostic positions from that. +-- +-- - Needs the same description of the contaminant thingy. +-- +-- (4) Consider Read Groups. +-- +-- - One result per read group (or maybe per library, alternatively +-- per file) should be produced. +-- - The "aDNA" setting should be determined from either the @RG +-- header or from an external source. + + +import Bio.Base +import Bio.Bam hiding ( Unknown ) +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.Monoid +import Data.List +import Numeric +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO + +import qualified Data.HashMap.Strict as HM +import qualified Data.IntMap as IM + +data Conf = Conf { + conf_adna :: Adna, + conf_verbosity :: Int, + conf_header :: HeaderFn, + conf_output :: OutputFn, + conf_shoot_foot :: Bool, + conf_dp_list :: DpList + } + +options :: [OptDescr (Conf -> IO Conf)] +options = public_options ++ hidden_options + where + public_options = [ + Option "a" ["ancient","dsprot"] (NoArg (set_adna ancientDNAds)) "Treat DNA as ancient, double strand protocol", + Option "s" ["ssprot"] (NoArg (set_adna ancientDNAss)) "Treat DNA as ancient, single strand protocol", + Option "" ["fresh"] (NoArg (set_adna freshDNA)) "Treat DNA as fresh (not ancient)", + Option "T" ["table"] (NoArg set_output_table) "Print output in table form", + + Option "v" ["verbose"] (NoArg (mod_verbosity succ)) "Produce more debug output", + Option "q" ["quiet"] (NoArg (mod_verbosity pred)) "Produce less debug output", + Option "h?" ["help","usage"] (NoArg usage) "Print this message and exit" + ] + + hidden_options = [ + Option "" ["shoot","foot"] (NoArg set_shoot_foot) [] + ] + + usage _ = do pn <- getProgName + hPutStrLn stderr $ usageInfo ("Usage: " ++ pn ++ " [OPTION...] [Bam-File...]") public_options + exitSuccess + + set_shoot_foot c = return $ c { conf_shoot_foot = True } + set_adna a c = return $ c { conf_adna = a } + set_output_table c = return $ c { conf_output = show_result_table, conf_header = header_table } + mod_verbosity f c = return $ c { conf_verbosity = f (conf_verbosity c) } + + +conf0 :: IO Conf +conf0 = return $ Conf { conf_adna = freshDNA + , conf_verbosity = 1 + , conf_header = "" + , conf_output = show_result_plain + , conf_shoot_foot = False + , conf_dp_list = error "no diagnostic positions defined" + } + +{- Old options... may or may not be of much use. + +struct option longopts[] = { + { "reference", required_argument, 0, 'r' }, + { "transversions", no_argument, 0, 't' }, + { "span", required_argument, 0, 's' }, + { "maxd", required_argument, 0, 'd' }, +} ; + +void usage( const char* pname ) +{ + "Reads a maln file and tries to quantify contained contamination.\n" + "Options:\n" + " -r, --reference FILE FASTA file with the likely contaminant (default: builtin mt311)\n" + " -t, --transversions Treat only transversions as diagnostic\n" + " -s, --span M-N Look only at range from M to N\n" + " -n, --numpos N Require N diagnostic sites in a single read (default: 1)\n" +} +-} + +-- | A list of diagnostic positions. We drop the failed idea of +-- "weakly diagnostic positions". We also work in the coordinate system +-- of the reference. Therefore, a diagnostic position is defined by +-- position, allele in the clean sample and allele in the contaminant. + +data Dp = Dp { _dp_clean_allele :: !Nucleotide + , _dp_dirty_allele :: !Nucleotide } + deriving Show + +type DpList = IM.IntMap Dp + +show_dp_list :: DpList -> ShowS +show_dp_list = flip IM.foldrWithKey id $ \pos (Dp cln drt) k -> + (:) '<' . shows pos . (:) ':' . shows drt . + (:) ',' . shows cln . (++) ">, " . k + + +-- | Reads are classified into one of these. +data Klass = Unknown | Clean | Dirty | Conflict | Nonsense + deriving (Ord, Eq, Enum, Bounded, Show) + +instance Monoid Klass where + mempty = Unknown + Clean `mappend` Dirty = Conflict + Dirty `mappend` Clean = Conflict + x `mappend` y = if x < y then y else x + +newtype Summary = Summary (IM.IntMap Int) + +sum_count :: Klass -> Summary -> Summary +sum_count kl (Summary m) = Summary $ IM.insertWith' (+) (fromEnum kl) 1 m + +sum_get :: Klass -> Summary -> Int +sum_get kl (Summary m) = IM.findWithDefault 0 (fromEnum kl) m + + +-- | Determines what an allele could come from. Does not take +-- port-mortem modifications into account. +classify :: Dp -> Nucleotide -> Klass +classify (Dp cln drt) nuc + | maybe_clean && maybe_dirty = Unknown + | maybe_clean = Clean + | maybe_dirty = Dirty + | otherwise = Nonsense + where + maybe_clean = unN cln .&. unN nuc /= 0 + maybe_dirty = unN drt .&. unN nuc /= 0 + + +-- | We deal with aDNA by transforming a base into all the bases it +-- could have been. So the configuration is simply the transformation +-- function. +type Adna = Nucleotide -> Nucleotide + +-- | Fresh DNA: no transformation. +freshDNA :: Adna +freshDNA = id + +-- | Ancient DNA, single strand protocol. Deamination can turn C into T +-- only. +ancientDNAss :: Adna +ancientDNAss = N . app . unN + where app x = if x .&. unN nucT /= 0 then x .|. unN nucC else x + +-- | Ancient DNA, double strand protocol. Deamination can turn C into T +-- and G into A. +ancientDNAds :: Adna +ancientDNAds = N . app1 . app2 . unN + where app1 x = if x .&. unN nucT /= 0 then x .|. unN nucC else x + app2 x = if x .&. unN nucA /= 0 then x .|. unN nucG else x + + +-- | Classifying a read. In an ideal world, we'd be looking at a single +-- read mapped in one piece. Instead, we may be looking at half a mate +-- pair or even a single read mapped inconveniently across the origin. +-- +-- We will be reading a BAM stream. All reads with the same name (there +-- maybe 1..4, assuming no major breakage) need to be processed +-- together. We'll isolate that here: our input stream consists of +-- reads that all have the same qname. Results in exactly one 'Klass'. +-- We will ignore mate pairs that are improperly mapped or filtered. +-- +-- May need more options. Note that application of the aDNA function +-- depends on the strandedness of the alignment. FIXME +-- +-- This is the only place where counting of votes was used before, and +-- only for debugging purposes. Everything that was either dirty or +-- clean (but not both) counted as a vote. + +classify_read_set :: Monad m => DpList -> Adna -> Iteratee [BamRaw] m Klass +classify_read_set = undefined + +-- | Classifying a stream. We create a map from read name to iteratee. +-- New names are inserted, known names fed to stored iteratees. +-- ``Done'' iteratees are disposed of immediately. + +classify_stream :: Monad m => DpList -> Adna -> Iteratee [BamRaw] m Summary +classify_stream dps adna = foldStreamM classify_read (Summary IM.empty, HM.empty) >>= lift . finish + where + classify0 = classify_read_set dps adna + + classify_read (summary, iters) rd = do + let nm = b_qname $ unpackBam rd + let it = HM.lookupDefault classify0 nm iters + (isdone, it') <- enumPure1Chunk [rd] it >>= enumCheckIfDone + if isdone then do cl <- run it' + return (sum_count cl summary, HM.delete nm iters) + else return (summary, HM.insert nm it' iters) + + finish (summary, iters) = foldM (\s it -> flip sum_count s `liftM` run it) summary $ HM.elems iters + + +{- Missing from the output right now: + + * filename (library would be better) + * alignment distance (only useful if DPs are derived from alignment) + * number of difference (likewise) + * number of DPs + * number of DPs which are transversions +-} + +result_labels :: [ String ] +result_labels = [ "unclassified", "clean", "polluting", "conflicting", "nonsensical", "LB", "ML", "UB" ] + +type HeaderFn = String +type OutputFn = Summary -> Maybe [Double] -> String + +show_result_plain :: OutputFn +show_result_plain summary ests = unlines $ zipWith fmt result_labels [minBound..maxBound] ++ [[]] + where + labellen = (+) 2 . maximum . map length $ zipWith const result_labels [minBound..maxBound::Klass] + pad n s = replicate (n - length s) ' ' ++ s + + fmt lbl kl = pad labellen lbl ++ " fragments: " ++ show (sum_get kl summary) ++ + if kl == Dirty then maybe [] fmt_ests ests else [] + + fmt_ests [lb,ml,ub] = " (" ++ showFFloat (Just 1) lb " .. " + ++ showFFloat (Just 1) ml " .. " + ++ showFFloat (Just 1) ub "%)" + +header_table :: HeaderFn +header_table = intercalate "\t" result_labels + +show_result_table :: OutputFn +show_result_table summary ests = intercalate "\t" $ + [ show $ sum_get kl summary | kl <- [minBound..maxBound] ] ++ + maybe (replicate 3 "N/A") (map (\x -> showFFloat (Just 1) x [])) ests + + +show_result_with :: (Summary -> Maybe [Double] -> a) -> Summary -> a +show_result_with f summary = f summary (if nn /= 0 then Just [lb,ml,ub] else Nothing) + where + z = 1.96 -- this is Z_{0.975}, giving a 95% confidence interval + k = fromIntegral (sum_get Dirty summary) + n = k + fromIntegral (sum_get Clean summary) + nn = sum_get Dirty summary + sum_get Clean summary + + p_ = k / n + c = p_ + 0.5 * z * z / n + w = z * sqrt( p_ * (1-p_) / n + 0.25 * z * z / (n*n) ) + d = 1 + z * z / n + + lb = max 0 $ 100 * (c-w) / d -- lower bound of CI + ml = 100 * p_ -- ML estimate + ub = min 100 $ 100 * (c+w) / d -- upper bound of CI + + +-- The following is old 'ccheck'... for reference and guidance. + + +{- +/* + * Contamination Checker. Outline: + * + * - read the human reference (concsensus of contaminants); this will + * contain ambiguity codes + * - read maln file, including assembly and assembled reads + * - align contaminant-consensus and assembly globally + * This uses Myers' O(nd) aligner, for it grasps ambiguity codes and + * runs fast enough, in little memory, for long, but similar + * sequences. + * - find "strongly diagnostic positions", positions where ass and con + * are incompatible, and "weakly diagnostic positions", positions + * where ass and con are not always equal + * - for every "end" fragment: store it and later join with its other + * half to give an effectively "full" fragment + * - for every "full" fragment: if it crosses at least one (strongly or + * weakly) diagnostic position, cut out that range from ref and align + * to it globally using the mia aligner + * - pass 1: for every weakly diagnostic position where the bases agree, + * store whether a contaminant was discovered, and if so, turn them + * into "actually diagnostic positions". + * - pass 2: for every (strongly or actually) diagnostic position where + * the bases agree, classify it, then classify the fragment + * (conflicting, uninformative, contaminant, endogenous) + * - produce a summary + * + * Notable features: + * - operates sensibly on aDNA + * - has sensible commandline and doesn't make too much noise in operation + * - optionally considers only certain diagnostic positions + * (tranversions only and/or some region only) + * - new consensus sequence has other letters besides N + */ + +// Everything that differs is weakly diagnostic, unless it's a gap. +// Note that this mean that Ns are usually weakly diagnostic. +bool is_diagnostic( char aln1, char aln2 ) +{ + return aln1 != '-' && aln2 != '-' && toupper(aln1) != toupper(aln2) ; +} + +// Interesting question... given ambiguity codes, what's a transversion? +// One way to put it: anything that is incompatible with all four +// transitions. Needs a different implementation. +bool is_transversion( char a, char b ) +{ + char u = a & ~32 ; + char v = b & ~32 ; + switch( u ) + { + case 'A': return v != 'G' ; + case 'C': return v != 'T' ; + case 'G': return v != 'A' ; + case 'T': + case 'U': return v != 'C' ; + default: return false ; + } +} + + +dp_list mk_dp_list( const char* aln1, const char* aln2, int span_from, int span_to ) +{ + dp_list l ; + int index = 0 ; + while( index != span_from && *aln1 && *aln2 ) + { + if( *aln2 != '-' ) ++index ; + ++aln1 ; + ++aln2 ; + } + while( index != span_to && *aln1 && *aln2 ) + { + if( is_diagnostic( *aln1, *aln2 ) ) { + l[index].consensus = *aln1 ; + l[index].assembly = *aln2 ; + } + if( *aln2 != '-' ) ++index ; + ++aln1 ; + ++aln2 ; + } + return l ; +} +-} + +-- We won't keep this. Mt311 should be stored as half a Dp list. +-- extern char mt311_sequence[] ; +-- extern const int mt311_sequence_size ; + +main :: IO () +main = do + (opts, files, errors) <- getOpt Permute options <$> getArgs + unless (null errors) $ mapM_ (hPutStrLn stderr) errors >> exitFailure + Conf{..} <- foldl (>>=) conf0 opts + +{- + bool transversions = false ; + int min_diag_posns = 1 ; + int maxd = 0 ; + int span_from = 0, span_to = INT_MAX ; + + int opt ; + do { + opt = getopt_long( argc, argv, "r:avhts:d:n:MfTF", longopts, 0 ) ; + switch( opt ) + { + case 'r': read_fasta_ref( &hum_ref, optarg ) ; break ; + case 't': transversions = true ; break ; + case 's': sscanf( optarg, "%u-%u", &span_from, &span_to ) ; if( span_from ) span_from-- ; break ; + case 'n': min_diag_posns = atoi( optarg ) ; break ; + case 'd': maxd = atoi( optarg ) ; break ; + } + } while( opt != -1 ) ; +-} + + when (IM.size conf_dp_list < 40 && not conf_shoot_foot) $ do + hPutStrLn stderr $ + "\n *** Low number (" ++ shows (IM.size conf_dp_list) ") of diagnostic positions found.\n\ + \ *** I will stop now for your own safety.\n\ + \ *** If you are sure you want to shoot yourself\n\ + \ *** in the foot, read the man page to learn\n\ + \ *** how to lift this restriction.\n\n" + exitFailure + + -- TODO We will usually want to seek to the mitochondrion, which + -- doesn't work with the simple 'mergeInputs' invocation. + r <- mergeInputs combineCoordinates files >=> run $ \hdr -> + classify_stream conf_dp_list conf_adna + + putStrLn $ unlines $ conf_header : show_result_with conf_output r : [] + + {- + if( mktable ) { + fputs( infile.c_str(), stdout ) ; + putchar( '\t' ) ; + } + else { + puts( infile.c_str() ) ; + putchar( '\n' ) ; + } + -} + + -- if( !maxd ) maxd = max( strlen(hum_ref.seq), strlen(maln->ref->seq) ) / 10 ; +-- char *aln_con = (char*)malloc( strlen(hum_ref.seq) + maxd + 2 ) ; + -- char *aln_ass = (char*)malloc( strlen(maln->ref->seq) + maxd + 2 ) ; + -- unsigned d = myers_diff( hum_ref.seq, myers_align_globally, maln->ref->seq, maxd, aln_con, aln_ass ) ; + + {- + if( d == UINT_MAX ) { + fprintf( stderr, "\n *** Could not align references with up to %d mismatches.\n" + " *** This is usually a sign of trouble, but\n" + " *** IF AND ONLY IF YOU KNOW WHAT YOU ARE DOING, you can\n" + " *** try the -d N option with N > %d.\n\n", maxd, maxd ) ; + return 1 ; + } + if( mktable ) printf( "%d\t", d ) ; + else printf( " %d alignment distance between reference and assembly.\n", d ) ; + + if( verbose >= 6 ) print_aln( aln_con, aln_ass ) ; + + dp_list l = mk_dp_list( aln_con, aln_ass, span_from, span_to ) ; + if( mktable ) printf( "%u\t", (unsigned)l.size() ) ; + else printf( " %u total differences between reference and assembly.\n", (unsigned)l.size() ) ; + + int num_strong = 0 ; + for( dp_list::const_iterator i = l.begin() ; i != l.end() ; ++i ) + if( i->second.strength > weak ) ++num_strong ; + if( mktable ) printf( "%d\t", (int)l.size() ) ; + else { + printf( " %d diagnostic positions", (int)l.size() ) ; + if( span_from != 0 || span_to != INT_MAX ) + printf( " in range [%d,%d)", span_from, span_to ) ; + printf( ", %d of which are strongly diagnostic.\n", num_strong ) ; + } + + if( verbose >= 3 ) { + print_dp_list( stderr, l.begin(), l.end(), '\n', 0 ) ; + print_dp_list( stderr, l.begin(), l.end(), '\n', 1 ) ; + } + +-} + + {- + if( verbose >= 2 ) fputs( "Pass one: finding actually diagnostic positions.\n", stderr ) ; + for( const AlnSeqP *s = maln->AlnSeqArray ; s != maln->AlnSeqArray + maln->num_aln_seqs ; ++s ) + { + fixup_name( *s ) ; + + std::string the_ass( maln->ref->seq + (*s)->start, (*s)->end - (*s)->start + 1 ) ; + // are we overlapping anything at all? + std::pair< dp_list::const_iterator, dp_list::const_iterator > p = + overlapped_diagnostic_positions( l, *s ) ; + + if( verbose >= 3 ) + { + fprintf( stderr, "%s/%c:\n %d potentially diagnostic positions", + (*s)->id, (*s)->segment, (int)std::distance( p.first, p.second ) ) ; + if( verbose >= 4 ) + { + putc( ':', stderr ) ; putc( ' ', stderr ) ; + print_dp_list( stderr, p.first, p.second, 0 ) ; + } + fprintf( stderr, "; range: %d..%d\n", (*s)->start, (*s)->end ) ; + } +-} + + + {- + int t = 0 ; + for( dp_list::const_iterator i = l.begin() ; i != l.end() ; ++i ) + if( is_transversion( i->second.consensus, i->second.assembly ) ) ++t ; + if( mktable ) printf( "%d\t%d\t", t, num_strong ) ; + else { + printf( " %d effectively diagnostic positions", (int)l.size() ) ; + if( span_from != 0 || span_to != INT_MAX ) + printf( " in range [%d,%d)", span_from, span_to ) ; + printf( ", %d of which are transversions.\n\n", t ) ; + } + if( verbose >= 3 ) print_dp_list( stderr, l.begin(), l.end(), '\n' ) ; + + std::deque< cached_pwaln >::const_iterator cpwaln = cached_pwalns.begin() ; + for( const AlnSeqP *s = maln->AlnSeqArray ; s != maln->AlnSeqArray + maln->num_aln_seqs ; ++s, ++cpwaln ) + { + whatsit klass = unknown ; + int votes = 0, votes2 = 0 ; + + std::string the_ass( maln->ref->seq + (*s)->start, (*s)->end - (*s)->start + 1 ) ; + // enough overlap? (we only have _actually_ diagnostic positions now) + std::pair< dp_list::const_iterator, dp_list::const_iterator > p = + overlapped_diagnostic_positions( l, *s ) ; + if( std::distance( p.first, p.second ) < min_diag_posns ) + { + if( verbose >= 3 ) { + fputs( (*s)->id, stderr ) ; + putc( '/', stderr ) ; + putc( (*s)->segment, stderr ) ; + fputs( ": no diagnostic positions\n", stderr ) ; + } + } + else + { + if( verbose >= 3 ) + { + fprintf( stderr, "%s/%c: %d diagnostic positions", (*s)->id, (*s)->segment, (int)std::distance( p.first, p.second ) ) ; + if( verbose >= 4 ) + { + putc( ':', stderr ) ; putc( ' ', stderr ) ; + print_dp_list( stderr, p.first, p.second, 0 ) ; + } + fprintf( stderr, "; range: %d..%d\n", (*s)->start, (*s)->end ) ; + } + + // Hmm, all this iterator business is somewhat lacking... + char *paln1 = aln_con, *paln2 = aln_ass ; + int ass_pos = 0 ; + while( ass_pos != (*s)->start && *paln1 && *paln2 ) + { + if( *paln2 != '-' ) ass_pos++ ; + ++paln1 ; + ++paln2 ; + } + + char *in_ass = maln->ref->seq + (*s)->start ; + char *in_frag_v_ass = (*s)->seq ; + std::string::const_iterator in_frag_v_ref = cpwaln->frag_seq.begin() ; + + std::string lifted = lift_over( aln_con, aln_ass, (*s)->start, (*s)->end + 1 ) ; + std::string in_ref = lifted.substr( 0, cpwaln->start ) ; + in_ref.append( cpwaln->ref_seq ) ; + + while( ass_pos != (*s)->end +1 && *paln1 && *paln2 && !in_ref.empty() && *in_ass && *in_frag_v_ass && *in_frag_v_ref ) + { + if( *paln1 != '-' ) { + do { + in_ref=in_ref.substr(1) ; + in_frag_v_ref++ ; + } while( in_ref[0] == '-' ) ; + } + if( *paln2 != '-' ) { + ass_pos++ ; + do { + in_ass++ ; + in_frag_v_ass++ ; + } while( *in_ass == '-' ) ; + } + ++paln1 ; + ++paln2 ; + } + if( verbose >= 4 ) putc( '\n', stderr ) ; + } + } + } +} + -} + diff --git a/tools/wiggle-coverage.hs b/tools/wiggle-coverage.hs new file mode 100644 --- /dev/null +++ b/tools/wiggle-coverage.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE BangPatterns #-} +import Bio.Bam.Header +import Bio.Bam.Reader +import Bio.Bam.Rec +import Bio.Base +import Bio.Iteratee + +main :: IO () +main = mergeDefaultInputs combineCoordinates >=> run $ \hdr -> + joinI $ filterStream (not . isUnmapped . unpackBam) $ + joinI $ groupStreamOn (b_rname . unpackBam) (cov_to_wiggle hdr) $ + skipToEof + +cov_to_wiggle :: MonadIO m => BamMeta -> Refseq -> m (Iteratee [BamRaw] m ()) +cov_to_wiggle hdr rname = return $ liftI step + where + step (EOF mx) = idone () (EOF mx) + step (Chunk [ ]) = liftI step + step (Chunk (x:xs)) = do + let sid = unpackSeqid . sq_name $ meta_refs hdr `getRef` rname + liftIO $ putStr $ "chrom=" ++ sid ++ " start=" ++ shows (b_pos $ unpackBam x) " step=1\n" + step' (0::Int) [] (b_pos $ unpackBam x) (Chunk (x:xs)) + + step' !cov (e:ends) p str | e == p = step' (cov-1) ends p str + + step' !cov ends p (Chunk [ ]) = liftI (step' cov ends p) + step' !cov ends p (Chunk (x:xs)) | b_pos y == p = let !e' = b_pos y + alignedLength (b_cigar y) + in step' (cov+1) (ins e' ends) p (Chunk xs) + where y = unpackBam x + + step' _ [ ] _ str = step str + step' !cov ends p str = do liftIO $ putStrLn $ show cov + step' cov ends (p+1) str + + ins a [] = [a] + ins a (b:bs) | a <= b = a : b : bs + | otherwise = b : ins a bs +