biohazard (empty) → 0.6.1
raw patch · 63 files changed
+15008/−0 lines, 63 filesdep +ListLikedep +Vecdep +aesonbuild-type:Customsetup-changed
Dependencies added: ListLike, Vec, aeson, array, async, attoparsec, base, binary, biohazard, bytestring, bytestring-mmap, containers, deepseq, directory, exceptions, filepath, hashable, iteratee, nonlinear-optimization, primitive, random, scientific, stm, template-haskell, text, transformers, unix, unordered-containers, vector, vector-algorithms, vector-th-unbox, zlib
Files
- LICENSE +30/−0
- Setup.hs +61/−0
- biohazard.cabal +311/−0
- data/index_db.json +573/−0
- doc/genotyping.tex +539/−0
- man/man1/bam-meld.1 +86/−0
- man/man1/bam-rewrap.1 +56/−0
- man/man1/bam-rmdup.1 +238/−0
- man/man1/jivebunny.1 +177/−0
- man/man1/mt-anno.1 +55/−0
- man/man7/biohazard.7 +28/−0
- src/Bio/Align.hs +87/−0
- src/Bio/Bam.hs +14/−0
- src/Bio/Bam/Evan.hs +96/−0
- src/Bio/Bam/Fastq.hs +129/−0
- src/Bio/Bam/Filter.hs +127/−0
- src/Bio/Bam/Header.hs +392/−0
- src/Bio/Bam/Index.hs +384/−0
- src/Bio/Bam/Pileup.hs +511/−0
- src/Bio/Bam/Reader.hs +302/−0
- src/Bio/Bam/Rec.hs +397/−0
- src/Bio/Bam/Regions.hs +49/−0
- src/Bio/Bam/Rmdup.hs +692/−0
- src/Bio/Bam/Trim.hs +93/−0
- src/Bio/Bam/Writer.hs +231/−0
- src/Bio/Base.hs +382/−0
- src/Bio/Genocall.hs +222/−0
- src/Bio/Genocall/Adna.hs +161/−0
- src/Bio/Genocall/AvroFile.hs +45/−0
- src/Bio/Glf.hs +133/−0
- src/Bio/Iteratee.hs +503/−0
- src/Bio/Iteratee/Bgzf.hsc +498/−0
- src/Bio/Iteratee/Builder.hs +179/−0
- src/Bio/Iteratee/ZLib.hsc +754/−0
- src/Bio/PriorityQueue.hs +142/−0
- src/Bio/TwoBit.hs +241/−0
- src/Bio/Util.hs +226/−0
- src/Data/Avro.hs +508/−0
- src/cbits/jive.c +93/−0
- src/cbits/myers_align.c +104/−0
- tools/AD.hs +99/−0
- tools/Align.hs +315/−0
- tools/Anno.hs +187/−0
- tools/Index.hs +34/−0
- tools/Seqs.hs +175/−0
- tools/SimpleSeed.hs +123/−0
- tools/Xlate.hs +56/−0
- tools/afroengineer.hs +300/−0
- tools/bam-fixpair.hs +594/−0
- tools/bam-meld.hs +247/−0
- tools/bam-resample.hs +70/−0
- tools/bam-rewrap.hs +83/−0
- tools/bam-rmdup.hs +401/−0
- tools/bam-trim.hs +54/−0
- tools/count-coverage.hs +61/−0
- tools/dmg-est.hs +369/−0
- tools/fastq2bam.hs +172/−0
- tools/glf-consensus.hs +205/−0
- tools/gt-call.hs +392/−0
- tools/jivebunny.hs +531/−0
- tools/mt-anno.hs +59/−0
- tools/mt-ccheck.hs +594/−0
- tools/wiggle-coverage.hs +38/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -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" ]+
+ biohazard.cabal view
@@ -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:
+ data/index_db.json view
@@ -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"+ }+}
+ doc/genotyping.tex view
@@ -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}
+ man/man1/bam-meld.1 view
@@ -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 <udo_stenzel@eva.mpg.de>++.SH "SEE ALSO"+.BR biohazard (7)+
+ man/man1/bam-rewrap.1 view
@@ -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 <udo_stenzel@eva.mpg.de>++.SH "SEE ALSO"+.BR biohazard (7)+
+ man/man1/bam-rmdup.1 view
@@ -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 <udo_stenzel@eva.mpg.de>++.SH "SEE ALSO"+.BR biohazard (7)+
+ man/man1/jivebunny.1 view
@@ -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 <udo_stenzel@eva.mpg.de>++.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
+ man/man1/mt-anno.1 view
@@ -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 <udo_stenzel@eva.mpg.de>++.SH "SEE ALSO"+.BR biohazard (7), fasta (5)+
+ man/man7/biohazard.7 view
@@ -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 <udo_stenzel@eva.mpg.de>++.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+
+ src/Bio/Align.hs view
@@ -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 ' '+
+ src/Bio/Bam.hs view
@@ -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'.+
+ src/Bio/Bam/Evan.hs view
@@ -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++
+ src/Bio/Bam/Fastq.hs view
@@ -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+
+ src/Bio/Bam/Filter.hs view
@@ -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 }++
+ src/Bio/Bam/Header.hs view
@@ -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)
+ src/Bio/Bam/Index.hs view
@@ -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
+ src/Bio/Bam/Pileup.hs view
@@ -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)+
+ src/Bio/Bam/Reader.hs view
@@ -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]
+ src/Bio/Bam/Rec.hs view
@@ -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+
+ src/Bio/Bam/Regions.hs view
@@ -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
+ src/Bio/Bam/Rmdup.hs view
@@ -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
+ src/Bio/Bam/Trim.hs view
@@ -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)+++
+ src/Bio/Bam/Writer.hs view
@@ -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+
+ src/Bio/Base.hs view
@@ -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+
+ src/Bio/Genocall.hs view
@@ -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?!+
+ src/Bio/Genocall/Adna.hs view
@@ -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)+
+ src/Bio/Genocall/AvroFile.hs view
@@ -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+
+ src/Bio/Glf.hs view
@@ -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+
+ src/Bio/Iteratee.hs view
@@ -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+
+ src/Bio/Iteratee/Bgzf.hsc view
@@ -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 <zlib.h>++-- | 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)+
+ src/Bio/Iteratee/Builder.hs view
@@ -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)+++
+ src/Bio/Iteratee/ZLib.hsc view
@@ -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 <zlib.h>++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+ -- <http://www.ietf.org/rfc/rfc1952.txt>.+ | 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+ -- <http://www.ietf.org/rfc/rfc1950.txt>+ | Raw+ -- ^ The \'raw\' format is just the DEFLATE compressed data stream without+ -- and additionl headers.+ --+ -- Thr format is described in RFC 1951+ -- <http://www.ietf.org/rfc/rfc1951.txt>+ | 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 $ "<<ZStream@"+ IO.hPutStr stderr $ (show zptr)+ IO.hPutStr stderr . (" next_in=" ++) . show =<<+ (#{peek z_stream, next_in} zptr :: IO (Ptr ()))+ IO.hPutStr stderr . (" avail_in=" ++) . show =<<+ (#{peek z_stream, avail_in} zptr :: IO CUInt)+ IO.hPutStr stderr . (" total_in=" ++) . show =<<+ (#{peek z_stream, total_in} zptr :: IO CULong)+ IO.hPutStr stderr . (" next_out=" ++) . show =<<+ (#{peek z_stream, next_out} zptr :: IO (Ptr ()))+ IO.hPutStr stderr . (" avail_out=" ++) . show =<<+ (#{peek z_stream, avail_out} zptr :: IO CUInt)+ IO.hPutStr stderr . (" total_out=" ++) . show =<<+ (#{peek z_stream, total_out} zptr :: IO CULong)+-- IO.hPutStr stderr . (" msg=" ++) =<< peekCString =<<+-- (#{peek z_stream, msg} zptr)+ IO.hPutStrLn 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+
+ src/Bio/PriorityQueue.hs view
@@ -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+
+ src/Bio/TwoBit.hs view
@@ -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+
+ src/Bio/Util.hs view
@@ -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+
+ src/Data/Avro.hs view
@@ -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 "<partial>")+ Done rest _ a | B.null rest -> idone a (EOF mx)+ | otherwise -> idone a (Chunk rest)+
+ src/cbits/jive.c view
@@ -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 ;+}+
+ src/cbits/myers_align.c view
@@ -0,0 +1,104 @@+#include "myers_align.h"++#include <limits.h>+#include <stdlib.h>+#include <string.h>++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 ;+}+
+ tools/AD.hs view
@@ -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+
+ tools/Align.hs view
@@ -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' <!| mat nc2 rest qs (Del :* (n-1) : cs)++ (Mat :* n :cs) -> let nc2 :< rest = Z.viewl nrs+ b' = vote_for votes (U.head qs) b+ in mkNC is b' <!| mat nc2 rest (U.tail qs) (Mat :* (n-1) : cs)++ _ -> ins nc nrs (0::Int) qs cigs++ (<!|) !a !as = a <| as+++vote_against_from :: Float -> 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.!)
+ tools/Anno.hs view
@@ -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" ]
+ tools/Index.hs view
@@ -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 |]++
+ tools/Seqs.hs view
@@ -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"+
+ tools/SimpleSeed.hs view
@@ -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+
+ tools/Xlate.hs view
@@ -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+
+ tools/afroengineer.hs view
@@ -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 } ]+
+ tools/bam-fixpair.hs view
@@ -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+
+ tools/bam-meld.hs view
@@ -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 ]+
+ tools/bam-resample.hs view
@@ -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 ++ " <num> [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]
+ tools/bam-rewrap.hs view
@@ -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+
+ tools/bam-rmdup.hs view
@@ -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)
+ tools/bam-trim.hs view
@@ -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+
+ tools/count-coverage.hs view
@@ -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 ++ "[<min-mapq>]\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))++++++
+ tools/dmg-est.hs view
@@ -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)
+ tools/fastq2bam.hs view
@@ -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++
+ tools/glf-consensus.hs view
@@ -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+
+ tools/gt-call.hs view
@@ -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=<ID=A,Number=2,Type=Integer,Description="Number of A bases on forward and reverse strand">+-- ##FORMAT=<ID=C,Number=2,Type=Integer,Description="Number of C bases on forward and reverse strand">+-- ##FORMAT=<ID=G,Number=2,Type=Integer,Description="Number of G bases on forward and reverse strand">+-- ##FORMAT=<ID=T,Number=2,Type=Integer,Description="Number of T bases on forward and reverse strand">+-- (we should count bases on both strands for this)+--+-- ##FORMAT=<ID=DP,Number=1,Type=Integer,Description="Read Depth (only filtered reads used for calling)">+-- ##INFO=<ID=MQ,Number=1,Type=Float,Description="RMS Mapping Quality">+-- ##INFO=<ID=MQ0,Number=1,Type=Integer,Description="Total Mapping Quality Zero Reads">+-- (basic statistics. we keep these)+--+-- ##FORMAT=<ID=IR,Number=1,Type=Integer,Description="Number of reads with InDel starting at this position">+-- ##FORMAT=<ID=AD,Number=.,Type=Integer,Description="Allelic depths for the ref and alt alleles in the order listed">+-- ##INFO=<ID=Dels,Number=1,Type=Float,Description="Fraction of Reads Containing Spanning Deletions">+-- (this is bullshit)+--+-- ##FORMAT=<ID=GQ,Number=1,Type=Float,Description="Genotype Quality">+-- ##FORMAT=<ID=GT,Number=1,Type=String,Description="Genotype">+-- ##FORMAT=<ID=PL,Number=G,Type=Integer,Description="Normalized, Phred-scaled likelihoods for genotypes as defined in the VCF specification">+-- (these are straight forward to compute?)+--+-- ##INFO=<ID=AF1000g,Number=1,Type=Float,Description="Global alternative allele frequency (AF)...">+-- ##INFO=<ID=AMR_AF,Number=1,Type=Float,Description="Alternative allele frequency (AF) for samples from AMR based on 1000G">+-- ##INFO=<ID=ASN_AF,Number=1,Type=Float,Description="Alternative allele frequency (AF) for samples from ASN based on 1000G">+-- ##INFO=<ID=AFR_AF,Number=1,Type=Float,Description="Alternative allele frequency (AF) for samples from AFR based on 1000G">+-- ##INFO=<ID=EUR_AF,Number=1,Type=Float,Description="Alternative allele frequency (AF) for samples from EUR based on 1000G">+-- ##INFO=<ID=1000gALT,Number=1,Type=String,Description="Alternative allele referred to by 1000G">+-- ##INFO=<ID=TS,Number=1,Type=String,Description="Sequences in Ensembl v64 EPO Compara 6 primate block">+-- ##INFO=<ID=TSseq,Number=1,Type=String,Description="Primary species bases (in order of TS field) in the EPO Compara 6 primate block">+-- ##INFO=<ID=CAnc,Number=1,Type=String,Description="Ref-Chimp/Human ancestor base at this position">+-- ##INFO=<ID=GAnc,Number=1,Type=String,Description="Ref-Gorilla ancestor base at this position">+-- ##INFO=<ID=OAnc,Number=1,Type=String,Description="Ref-Orang ancestor base at this position">+-- ##INFO=<ID=mSC,Number=1,Type=Float,Description="PhastCons Mammalian conservation score (excluding human)">+-- ##INFO=<ID=pSC,Number=1,Type=Float,Description="PhastCons Primate conservation score (excluding human)">+-- ##INFO=<ID=GRP,Number=1,Type=Float,Description="GERP conservation score">+-- ##INFO=<ID=bSC,Number=1,Type=Float,Description="B score">+-- ##INFO=<ID=Map20,Number=1,Type=Float,Description="Mapability score of Duke University (determined from 20bp reads)">+-- ##INFO=<ID=RM,Number=0,Type=Flag,Description="Position is repeat masked in the reference sequence of the EPO 6 primate block">+-- ##INFO=<ID=SysErr,Number=0,Type=Flag,Description="Position was identified as systematic error in the 1000 genome trios">+-- ##INFO=<ID=SysErrHCB,Number=0,Type=Flag,Description="Position was identified as systematic error based on shared SNPs...">+-- ##INFO=<ID=UR,Number=0,Type=Flag,Description="Position is in a copy number control region identified by the Eichler lab">+-- (this is external, will not be generated)+--+-- ##INFO=<ID=CpG,Number=0,Type=Flag,Description="Position is in a CpG context based on the Ref/Ancestor">+-- ##INFO=<ID=InbreedingCoeff,Number=1,Type=Float,Description="Inbreeding coefficient as estimated from the genotype likelihoods...">+-- (this is computable, isn't it?!)+--+-- ##INFO=<ID=FS,Number=1,Type=Float,Description="Phred-scaled p-value using Fisher's exact test to detect strand bias">+-- (this is from VarScan 2, a program that uses fixed cutoffs. It+-- is not clear that this has any use at all.)+--+-- ##INFO=<ID=AC,Number=A,Type=Integer,Description="Allele count in genotypes, for each ALT allele, in the same order as listed">+-- ##INFO=<ID=AF,Number=A,Type=Float,Description="Allele Frequency, for each ALT allele, in the same order as listed">+-- ##INFO=<ID=AN,Number=1,Type=Integer,Description="Total number of alleles in called genotypes">+-- ##INFO=<ID=BaseQRankSum,Number=1,Type=Float,Description="Z-score from Wilcoxon rank sum test of Alt Vs. Ref base qualities">+-- ##INFO=<ID=DP,Number=1,Type=Integer,Description="Filtered Depth">+-- ##INFO=<ID=DS,Number=0,Type=Flag,Description="Were any of the samples downsampled?">+-- ##INFO=<ID=HRun,Number=1,Type=Integer,Description="Largest Contiguous Homopolymer Run of Variant Allele In Either Direction">+-- ##INFO=<ID=HaplotypeScore,Number=1,Type=Float,Description="Consistency of the site with at most two segregating haplotypes">+-- ##INFO=<ID=MQRankSum,Number=1,Type=Float,Description="Z-score From Wilcoxon rank sum test of Alt vs. Ref read mapping qualities">+-- ##INFO=<ID=QD,Number=1,Type=Float,Description="Variant Confidence/Quality by Depth">+-- ##INFO=<ID=ReadPosRankSum,Number=1,Type=Float,Description="Z-score from Wilcoxon rank sum test of Alt vs. Ref read position bias">+-- (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)+
+ tools/jivebunny.hs view
@@ -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 '%'+
+ tools/mt-anno.hs view
@@ -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 == '>'+
+ tools/mt-ccheck.hs view
@@ -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 ) ;+ }+ }+ }+}+ -}+
+ tools/wiggle-coverage.hs view
@@ -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+