diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,16 +1,13 @@ import Control.Exception ( try, IOException ) import Distribution.PackageDescription ( PackageDescription(..) ) import Distribution.Simple -import Distribution.Simple.InstallDirs ( docdir, mandir, CopyDest (NoCopyDest) ) +import Distribution.Simple.InstallDirs ( 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.Setup ( copyDest, copyVerbosity, fromFlag, installVerbosity ) import Distribution.Simple.Utils -import Distribution.Verbosity ( Verbosity, moreVerbose ) +import Distribution.Verbosity ( Verbosity ) import System.Exit ( exitSuccess ) -import System.FilePath ( splitDirectories, joinPath, takeExtension, replaceExtension, () ) +import System.FilePath ( splitDirectories, joinPath, () ) main :: IO () main = do @@ -20,11 +17,6 @@ , 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 @@ -33,29 +25,9 @@ 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_ go where go :: (FilePath, FilePath) -> IO (Either IOException ()) go (base,src) = try $ installOrdinaryFile verb (base src) (dest src) -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 - createDirectoryIfMissingVerbose verb True (buildDir lbi "latex") - sequence_ [ runProgramInvocation (moreVerbose verb) $ - (programInvocation cmd [ "-interaction=nonstopmode", ddir joinPath ("doc":f) ]) - { progInvokeCwd = Just bdir } - | ("doc":f@(_:_)) <- map splitDirectories $ extraSrcFiles pkg - , takeExtension (last f) == ".tex" ] - where - bdir = buildDir lbi "latex" - ddir = joinPath (map (const "..") $ splitDirectories bdir) diff --git a/biohazard.cabal b/biohazard.cabal --- a/biohazard.cabal +++ b/biohazard.cabal @@ -1,10 +1,10 @@ Name: biohazard -Version: 0.6.6.1 +Version: 0.6.9 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 + some of these tools and a bunch that work on mitochondrial sequences. Category: Bioinformatics @@ -14,22 +14,23 @@ Author: Udo Stenzel Maintainer: udo.stenzel@eva.mpg.de -Copyright: (C) 2010-2016 Udo Stenzel +Copyright: (C) 2010-2017 Udo Stenzel Extra-Source-Files: man/man7/biohazard.7 + man/man1/bam-fixpair.1 man/man1/bam-meld.1 man/man1/bam-rewrap.1 man/man1/bam-rmdup.1 + man/man1/fastq2bam.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 +Cabal-version: >= 1.10 Build-type: Custom -Tested-With: GHC == 7.6.2, GHC == 7.8.4, GHC == 7.10.1 +Tested-With: GHC == 7.8.4, GHC == 7.10.1, GHC == 8.0.1 source-repository head type: git @@ -38,8 +39,12 @@ source-repository this type: git location: https://bitbucket.org/ustenzel/biohazard.git - tag: 0.6.6.1 + tag: 0.6.9 +Flag debug + Description: enable additional sanity checks + Default: False + Manual: True Library Exposed-modules: Bio.Base, @@ -52,42 +57,43 @@ Bio.Bam.Header, Bio.Bam.Index, Bio.Bam.Pileup, - Bio.Bam.Regions, Bio.Bam.Reader Bio.Bam.Rec, + Bio.Bam.Regions, Bio.Bam.Rmdup, Bio.Bam.Trim, Bio.Bam.Writer, Bio.Genocall, - Bio.Genocall.AvroFile, - Bio.Genocall.Metadata, + Bio.Genocall.Estimators, Bio.Iteratee, Bio.Iteratee.Bgzf, Bio.Iteratee.Builder, Bio.Iteratee.ZLib, + Bio.Prelude, Bio.PriorityQueue, Bio.TwoBit, Bio.Util.AD, Bio.Util.AD2, + Bio.Util.Jacobi, Bio.Util.Numeric, - Bio.Util.Regex, - Data.MiniFloat, - Data.Avro - - Other-modules: Paths_biohazard + Bio.Util.Zlib, + Paths_biohazard - Build-depends: aeson >= 0.7 && < 0.9, - async == 2.0.*, - attoparsec >= 0.10 && < 0.13, - base >= 4.5 && < 4.10, + Build-depends: aeson >= 0.7 && < 1.1, + aeson-pretty == 0.8.*, + async >= 2.0 && < 2.2, + attoparsec >= 0.10 && < 0.14, + base >= 4.6 && < 4.10, + base-prelude == 1.0.*, binary >= 0.7 && < 0.9, bytestring >= 0.10.2 && < 0.11, bytestring-mmap >= 0.2 && < 1.0, containers >= 0.4.1 && < 0.6, - deepseq >= 1.3 && < 1.5, directory >= 1.2 && < 2.0, exceptions >= 0.6 && < 0.9, filepath >= 1.3 && < 2.0, + hashable >= 1.0 && < 1.3, + hybrid-vectors == 0.2.*, iteratee >= 0.8.9.6 && < 0.8.10, ListLike >= 3.0 && < 5.0, nonlinear-optimization == 0.3.*, @@ -97,16 +103,40 @@ stm == 2.4.*, template-haskell == 2.*, text >= 1.0 && < 2.0, - transformers >= 0.3 && < 0.6, + transformers >= 0.4.1 && < 0.6, unix >= 2.5 && < 2.8, unordered-containers >= 0.2.3 && < 0.3, - Vec == 1.*, - vector >= 0.9 && < 0.11, + vector == 0.11.*, vector-algorithms >= 0.3 && < 1.0, + vector-binary-instances == 0.2.*, vector-th-unbox == 0.2.*, zlib >= 0.5 && < 0.7 - Ghc-options: -Wall + Ghc-options: -Wall -fprof-auto + + Default-Language: Haskell2010 + + Default-Extensions: BangPatterns, + DeriveDataTypeable, + FlexibleContexts, + FlexibleInstances, + MultiParamTypeClasses, + NoImplicitPrelude, + OverloadedStrings, + RecordWildCards, + TypeSynonymInstances + + Other-Extensions: CPP, + DeriveGeneric, + ExistentialQuantification, + GeneralizedNewtypeDeriving, + PatternGuards, + Rank2Types, + ScopedTypeVariables, + TemplateHaskell, + TypeFamilies, + TypeOperators + Hs-source-dirs: src Install-Includes: src/cbits/myers_align.h C-sources: src/cbits/myers_align.c @@ -123,120 +153,126 @@ -- Type: exitcode-stdio-1.0 -- Main-is: test-biohazard.hs -Executable redeye-dar - Main-is: redeye-dar.hs - Hs-Source-Dirs: tools - Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N +Executable test-pileup + Main-is: test-pileup.hs + Hs-Source-Dirs: tests + Ghc-options: -Wall -fprof-auto + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, BangPatterns Build-depends: async, base, biohazard, + bytestring, filepath, unordered-containers, + random, text, vector -Executable redeye-div - Main-is: redeye-div.hs - Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N +Executable redeye-dar + Main-is: redeye-dar.hs Hs-Source-Dirs: tools - Build-depends: async, - base, - biohazard, - filepath, - hmatrix == 0.16.*, - unordered-containers, - text, - vector - -Executable redeye-pileup - Main-is: redeye-pileup.hs Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - Hs-Source-Dirs: tools - Build-depends: aeson, + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, + BangPatterns, RecordWildCards + Build-depends: aeson-pretty, + async, base, + binary, biohazard, bytestring, containers, - directory, filepath, - iteratee, - text, unordered-containers, - Vec, + text, vector Executable redeye-single Main-is: redeye-single.hs - Ghc-options: -Wall -rtsopts + Ghc-options: -Wall -rtsopts -fprof-auto + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, + BangPatterns, RecordWildCards, FlexibleContexts Hs-Source-Dirs: tools Build-depends: aeson, base, + binary, biohazard, bytestring, containers, directory, - iteratee, filepath, + random, text, unix, unordered-containers, vector -Executable gt-scan - Main-is: gt-scan.hs - Ghc-options: -Wall +Executable redeye-flow + Main-is: redeye-flow.hs + Ghc-options: -Wall -rtsopts + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, + BangPatterns, DeriveGeneric Hs-Source-Dirs: tools Build-depends: aeson, + aeson-pretty, base, + binary, biohazard, bytestring, containers, - iteratee, - nonlinear-optimization, - primitive, - strict == 0.3.*, - unordered-containers, + directory, + shake == 0.15.*, text, + unordered-containers, vector --- ------ - Executable afroengineer Main-is: afroengineer.hs - Ghc-options: -Wall - Hs-source-dirs: tools - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, + BangPatterns, RecordWildCards, Rank2Types + Hs-source-dirs: tools Other-Modules: Align, SimpleSeed Build-Depends: base, biohazard, bytestring, containers, directory, - iteratee, unordered-containers, vector Executable bam-fixpair Main-is: bam-fixpair.hs - Ghc-options: -Wall - Hs-Source-Dirs: tools - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts - Build-depends: base, + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, + BangPatterns, RecordWildCards, FlexibleContexts + Hs-Source-Dirs: tools + Build-depends: async, + base, binary, biohazard, bytestring, - hashable >= 1.0 && < 1.3, + process, + stm, transformers, + unix, vector Executable bam-meld Main-is: bam-meld.hs - Ghc-options: -Wall - Hs-Source-Dirs: tools - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, + BangPatterns, FlexibleContexts + Hs-Source-Dirs: tools Build-depends: base, biohazard, bytestring, @@ -244,10 +280,11 @@ Executable bam-resample Main-is: bam-resample.hs - Ghc-options: -Wall - Hs-Source-Dirs: tools - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, BangPatterns + Hs-Source-Dirs: tools Build-depends: base, biohazard, bytestring, @@ -255,10 +292,11 @@ Executable bam-rewrap Main-is: bam-rewrap.hs - Ghc-options: -Wall - Hs-Source-Dirs: tools - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, BangPatterns + Hs-Source-Dirs: tools Build-depends: base, biohazard, bytestring, @@ -266,40 +304,42 @@ Executable bam-rmdup Main-is: bam-rmdup.hs - Ghc-options: -Wall - Hs-Source-Dirs: tools - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, + BangPatterns, RecordWildCards, FlexibleContexts + Hs-Source-Dirs: tools Build-depends: base, biohazard, bytestring, containers, - iteratee, + -- primitive, unordered-containers, - vector, - vector-algorithms + vector Executable bam-trim Main-is: bam-trim.hs - Ghc-options: -Wall - Hs-Source-Dirs: tools - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, BangPatterns + Hs-Source-Dirs: tools Build-depends: base, biohazard, bytestring Executable fastq2bam Main-is: fastq2bam.hs - Ghc-options: -Wall - Hs-Source-Dirs: tools - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, BangPatterns + Hs-Source-Dirs: tools Build-depends: base, biohazard, bytestring, containers, - iteratee, vector Executable jivebunny @@ -307,8 +347,11 @@ Hs-Source-Dirs: tools C-sources: src/cbits/jive.c CC-options: -std=c99 -ffast-math - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, + BangPatterns, TypeFamilies, RecordWildCards Other-modules: Index Build-depends: aeson, base, @@ -316,7 +359,6 @@ bytestring, containers, directory, - hashable >= 1.0 && < 1.3, random, text, transformers, @@ -327,10 +369,12 @@ Executable mt-anno Main-is: mt-anno.hs - Ghc-options: -Wall - Hs-Source-Dirs: tools - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, + BangPatterns, RecordWildCards + Hs-Source-Dirs: tools Other-Modules: Anno, Seqs, Xlate Build-Depends: base, bytestring, @@ -339,10 +383,12 @@ Executable mt-ccheck Main-is: mt-ccheck.hs - Ghc-options: -Wall - Hs-Source-Dirs: tools - -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N Ghc-options: -Wall -rtsopts + -- Ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + Default-Language: Haskell2010 + Default-Extensions: NoImplicitPrelude, OverloadedStrings, + BangPatterns, RecordWildCards + Hs-Source-Dirs: tools Build-Depends: base, bytestring, biohazard, diff --git a/data/index_db.json b/data/index_db.json --- a/data/index_db.json +++ b/data/index_db.json @@ -104,6 +104,7 @@ "95": "CGAGATC", "96": "CGCAGCC", + "501": "GCGATCTA", "502": "ATAGAGAG", "503": "AGAGGATA", "504": "TCTACTCT", @@ -113,8 +114,24 @@ "508": "AGGCTTAG", "510": "ATTAGACG", "511": "CGGAGAGA", + "513": "CTAGTCGA", + "515": "AGCTAGAA", + "516": "ACTCTAGG", "517": "TCTTACGC", + "518": "CTTAATAG", + "520": "ATAGCCTT", + "521": "TAAGGCTC", + "522": "TCGCATAA", + "592": "GATTTCCA", + "593": "ATCATGTT", + "594": "TTTCATCA", + "595": "AGTCCGAC", + "596": "GCTAGAAA", + "597": "CTTGGTTA", + "598": "CGATACAC", + "599": "TTGATGGA", + "t1": "ATCACG", "t2": "CGATGT", "t3": "TTAGGC", @@ -297,6 +314,44 @@ "129": "AGAACCG", "130": "ATCGTTC", "131": "CAACGTC", + + "193": "GAGGTTG", + "194": "TATGAGT", + "195": "CTTCGTT", + "196": "CCGTCCG", + "197": "AACGTTA", + "198": "GCATATT", + "199": "ACCTTCC", + "200": "TTCCGAG", + "201": "AACCGCA", + "202": "AGTCCTC", + "203": "ACGACTT", + "204": "ATCCATA", + "205": "CGGTCTC", + "206": "CTCATCG", + "207": "TCGCGTT", + "208": "CTTGACC", + "209": "ATAGCTG", + "210": "CGTTCCT", + "211": "CGCCTCA", + "212": "CAATCGA", + "213": "ACGCTCG", + "214": "CAGGCAA", + "215": "AGAGACT", + "216": "AATTGGT", + "217": "CAAGAAT", + "218": "AAGAGAT", + "219": "CTGACTA", + "220": "AAGCCTG", + "221": "CAACGAA", + "222": "CCATACC", + "223": "AAGTTGG", + "224": "ACCGAGG", + "225": "AACGCAT", + "226": "ATAGAAC", + "227": "CAAGGCC", + "228": "CGATTCG", + "301": "TCGCAGG", "302": "CTCTGCA", "303": "CCTAGGT", @@ -516,6 +571,11 @@ "727": "CGATCAGT", "728": "TGCAGCTA", "729": "TCGACGTC", + + "796": "TGGATCTG", + "797": "CCGTTTGT", + "798": "TGCTGGGT", + "799": "AGGTTGGG", "PhiX": "TTGCCGC", "PhiA": "AAAAAAAA", diff --git a/doc/genotyping.tex b/doc/genotyping.tex deleted file mode 100644 --- a/doc/genotyping.tex +++ /dev/null @@ -1,730 +0,0 @@ -\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}} -\newcommandx{\result}[2][1=]{\todo[nolist,noline,inline,linecolor=green,backgroundcolor=green!25,bordercolor=green,#1]{#2}} - -\newcommand{\argmax}{\operatornamewithlimits{arg\,max}} - -\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} &:= \argmax_{\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} &:= \argmax_{\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{Parameter Fitting for Single Sample} - -We seek to fit the Allele Frequency Spectrum to a single sample, or in -other words, to estimate heterozygosity and divergence. Let $X,Y$ be -the genotype at some site and $R$ be the reference allele. Now set: - -\begin{equation*} -P(x,y|r) = \left\{ \begin{array}{cl} - dh/3 & \mbox{if} \quad x \neq y \wedge (x=r \vee y=r) \\ - d(h-1)/3 & \mbox{if} \quad x=y \wedge x \neq r \\ - 1 - d & \mbox{if} \quad x=y \wedge x=r \\ - 0 & \mbox{otherwise} - \end{array} \right. -\end{equation*} - -Here we assume that all heterozygous mutations happen at the same -uniform rate, and all homozygous mutations at a different uniform rate. -We declare heterozygous genotypes with two alternative alleles to be -impossibru, getting us out of the need to fit a third parameter, which -would have little impact anyway. We get a divergence of $d$ and a -heterozygosity of $dh$. Labelling the genotype likelihoods as $G_{XY}$ -and assuming the reference allele is $A$ for convenience, we can compute -the likelihood per site: - -\begin{align*} -L &= G_{AA} \left( 1-d \right) + \frac{d(1-h)}{3} \left( G_{CC} + G_{GG} + G_{TT} \right) - + \frac{dh}{3} \left( G_{AC} + G_{AG} + G_{AT} \right) \\ - &= G_{AA} \left( 1-d + d(1-h) \frac{G_{CC} + G_{GG} + G_{TT}}{3 G_{AA}} - + dh \frac{G_{AC} + G_{AG} + G_{AT}}{3 G_{AA}} \right) -\end{align*} - -We now define three quantities of interest, which we sort by magnitude. -The smallest one is accumulated directly, the differences to the other -two are discretized and tabulated. Just six small tables are needed. - -\begin{equation*} -R_i := \ln 3 G_{AA}, \quad -D_i := \ln G_{CC} + G_{GG} + G_{TT}, \quad -H_i := \ln G_{AC} + G_{AG} + G_{AT} -\end{equation*} - -We further set $\delta = \ln \frac{d}{1-d}$ and $\eta = \ln -\frac{h}{1-h}$, because the log-odds-ratios pose fewer numerical -problems and provide cleaner confidence intervals. Thus we recover the -log-likelihood as follows: - -\begin{align*} -L_l &= - \sum_{i} R_i - \sum_{i} \ln \left( \frac{1}{1+e^\delta} + - \frac{e^\delta}{1+e^\delta} \frac{1}{1+e^\eta} e^{D_i} + - \frac{e^\delta}{1+e^\delta} \frac{e^\eta}{1+e^\eta} e^{H_i} \right) -\end{align*} - -\idea{Need to do something similar for indels.} - -\result{Hand-crafting partial derivatives of this equation didn't seem to -yield anything that simplifies, so I applied Automatic -Differentiation and handed it over to Hager-Zhang.} - -\section{Testing Method} - -\subsection{Handcrafted Data} - -To test for egregious bugs, we can write a couple of SAM or BAM files by -hand. This shouldn't really be called a test; it's ordinary, boring -debugging. - -\result{Nothing to see here. Code runs.} - -\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.} - -\beware{It is not actually possible to test the precision of a genotype -caller by counting miscalls. In any such tests, a genotype callers that -doesn't try to call heterozygotes ``wins''. Since that's undesirable, -``simply counting errors'' is a terrible testing method.} - -\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 call genotypes. - -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.} - -\result{We accidentally skipped this part.} - -\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.} - -\result{Since damage should not correlate with genotypes, estimating -damage in a separate first pass works and is a lot cheaper, -both conceptually and operationally, than co-estimating damage with -heterozygosity.} - -\result{Homa simulated two diploid genomes with divergence and aligned, -damaged reads from these. I estimated damage from the reads, and the -estimate is nearly spot on. On a dataset with 20\% divergence, the -estimated divergence and heterozygosity are unaffected by damage, -probably because damage is a minor effect compared to divergence here. -On a 0.1\% divergent dataset, naive genotype calling overestimates -heterozygosity by a factor of 15, but gets homozygous divergence right -(estimated $D=1.56\%, H/D=0.93$, but should be $D=0.3\%, H/D=0.67$. -Running with the estimated damage parameters gives a practically perfect -result.} - - -\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 by the maximum likelihood method, if the \texttt{Maq} model is -selected. It's a good idea to check whether $\theta$ varies between -sample sor sequencing runs. - -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. - -\idea{A couple of variations on the error model need to be investigated: -handle in bases in ascending, descending, random or input order of -quality; treat errors on different strands as dependent or independent; -various values of $\theta$. For $\theta = 1$, all of these should match -the naïve error model.} - -\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. - -\beware{Counting miscalls suffers from the usual problem that it's -entirely unclear how to count errors. The plan is therefore to estimate -heterozygosity.} - -\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, here we investigate the -behaviour at low coverage. The sample can be a high coverage sample -suitably downsampled. In this case, we have a reasonable 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 assumption -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\footnote{We -restrict to site-by-site analysis and a couple more simplifying -assumptions.}. Estimating that matrix allows Treemix, Patterson's~D, -Pr\:ufer's Divergence, and PCA; possibly more. We also get a clean -method for imputation for free. -% And the replacement for TreeMix is "Blandskog" (== mixed forest) - -Conceptually, it's easy: the covariance matrix serves as prior for the -allele frequencies in multiple populations, the allele frequency serves -as prior for the genotype. The goal is to maximize the likelihood with -respect to the covariance matrix. The likelihood function looks more or -less like this: - -\begin{equation*} -L = \frac{1}{\sqrt{2^k \pi^k |\Sigma|}} \int_{0^k}^{1^k} f^T G f - \exp \left( -\frac{1}{2}(f-\mu)^T \Sigma^{-1} (f-\mu) \right) df -\end{equation*} - -This appears to require integration over the space of possible -combinations of allele frequencies, which sounds impractical. If this -has to be done numerically (Monte-Carlo integration seems at least -feasible), it will be slow and horrible. It's not obvious how to do it -symbolically (it would only make sense if the genotypes can be -separated, otherwise marginalization over all \emph{combinations} of -genotypes remains), but even then, a few problems remain: - -\begin{itemize} -\item The formula lacks a normalization factor arising from the -integration bounds. -\item PopGen models based on allele frequencies fail catastrophically if -the frequencies approach 1 or 0. It seems disingenious to integrate out -to these boundaries. -\item How to deal with $\mu$ is not obvious. -\end{itemize} - -Instead, we sidestep these problems by taking inspiration from -SeqEm\cite{seqem}. We treat the allele frequencies $\bar{f}$ as -hidden parameters, marginalize over the genotypes(!), and maximize the -joint probability $P(\mathcal{D}, \bar{f} | \Sigma, \mu)$ with -respect to the variance-covariance matrix $\Sigma$ and the mean -distances $\mu$ using an EM algorithm\footnote{Effectively, we estimate -the allele frequency at every position for every sample. Literally, -this is of course impossible, but in aggregate makes sense for -populations.}. - -The expectation step, which is finding estimates for the allele -frequencies, is much easier, as it requires only summation over the -possible genotypes of \emph{one} individual at a time and optimizes -\emph{one} allele frequency at a time, holding the others -constant\todo{Is this correct? At any rate, even if not, multivariate -maximization should do it.}. Maximization is finding a covariance -matrix from allele frequencies, and this is again easy. The obvious -moment based estimator should work. - -Maximization (actually done by the moment based estimator for sample -mean and sample covariances): - -\begin{equation*} -\hat{\mu}, \hat{\Sigma} := \argmax_{\mu,\Sigma} - P(\bar{f}_1,\ldots,\bar{f}_k| \mu,\Sigma) -\end{equation*} - -Expectation (for each site): -\begin{align*} -\hat{f_1} \lell \hat{f_k} &= \argmax_{f_1,\ldots,f_k} - P(\mathcal{D} | f_1,\ldots,f_k) P(f_1,\ldots,f_k | \mu, \Sigma) \\ - &= \argmax_{f_1,\ldots,f_k} - \prod_{i=1}^k \sum_{G_i} P(\mathcal{D} | G_i) P( G_i | f_i ) - e^{ -\frac{1}{2} ((f_1,\ldots,f_k) - \mu)^T \Sigma^{-1} ((f_1,\ldots,f_k) - \mu) } -\end{align*} - -Here, $P(\mathcal{D}|G_i)$ is a genotype likelihood, acting as a -constant, and $P( G_i | f_i)$ follows by assuming -Hardy-Weinberg-Equilibrium\footnote{Even if HWE is violated in practice, -it will be absorbed by the estimation of more drift along the affected -lineage.}: - -\begin{equation*} -P(G=RR) = (1-f)^2 \quad P(G=RA) = 2f(1-f) \quad P(AA) = f^2 -\end{equation*} - -This \emph{looks} as if it can be optimized analytically. The summation -over the genotypes requires no nested sums, so it \emph{looks} tractable. - -\idea{The practical implementation should probably not store the -aforementioned 600GB of likelihoods, but only 6GB or thereabout of -allele frequency data per sample. The likelihoods can be generated from -the smaller BAM files on the fly. That probably means 'pileup' needs to -get a lot faster. On second thought, maybe the frequencies don't need -to be stored at all.} - -\idea{Dealing with contamination becomes obvious in this framework. For -a contaminated sample, every position has two allele frequencies (or two -sets of three allele frequencies). We need to assign a contaminant -probability to each read, which should derive from the alignment score -given the currently estimated allele frequencies.} - -\subsection{Principal Component Analysis} - -\beware{I personally think PCA is not an analysis, it barely(!) serves -as visualisation method. Nonetheless, it is frequently requested.} - -``Modern'' PCA starts with a matrix where rows correspond to $m$ -individuals and columns to $n$ markers, such as allele frequencies. -Means are subtracted from each column, then each column is divided by -its empirical standard deviation $\sqrt{f_j (1 - f_j)}$. For -multiallelic sites, one frequency is used per variant. - -Since $m < n$, matrix $X = \frac{1}{n} M M^T$ is small and -\textsc{Lapack} can trivially perform PCA on it. It just so happens -that $X$ is the same covariance matrix we estimated above. (Before -David and Nick got involved, everybody PCA'd $\frac{1}{m} M^T M$ -instead, which is much bigger. I don't know why.) - - - -\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). - -\bibitem{seqem} - E. R. Martin et. al., - \emph{SeqEM: an adaptive genotype-calling approach for next-generation - sequencing studies}. - Bioinformatics 26 (22), 2803-2810 (2010). -\end{thebibliography} - -\end{document} diff --git a/man/man1/bam-fixpair.1 b/man/man1/bam-fixpair.1 new file mode 100644 --- /dev/null +++ b/man/man1/bam-fixpair.1 @@ -0,0 +1,152 @@ +.\" Process this file with +.\" groff -man -Tascii bam-rmdup.1 +.\" +.TH BAM-FIXPAIR 1 "OCTOBER 2016" Applications "User Manuals" +.SH NAME +bam-fixpair \- bring read pairs together an repair them +.SH SYNOPSIS + +.B bam-fixpair [ +.I option +.B | +.I file +.B ... ] + +.B bam-fixpair [ +.I option +.B | +.I file +.B ... ] --exec [program] CLOWNS MIDDLE JOKERS + +.SH DESCRIPTION +.B bam-fixpair +reads one or more BAM files, brings the paired end reads together, fixes +any flags as needed, and writes the result out in BAM format again or +pipes(!) it into another program that expects two(!) FastQ files as input. + +.B bam-fixpair +should work with any input, but it performs best on sorted BAM input +that hasn't been filtered in a way to make it internally inconsistent. +Performance on inconsistent BAM files suffers, but the output will +always be an internally consistent file. Output is never sorted, but +the two mates of a pair appear next to each other. + +.SH OPTIONS + +.IP "-o, --output file" +Send BAM output to +.IR file . +The default is to pipe uncompressed BAM to stdout. + +.IP "-X, --exec" +Pipe two streams in FastQ format to a program. This option ends the +command line for +.B bam-fixpair +and is followed by the command line of a program to execute. The +command line shall contain the literal words +.IR CLOWNS ", " MIDDLE " and " JOKERS +up to once each. If present, these will be replaced with file names +that refer to pipes such that reading from +.I CLOWNS +yields the first mates, +.I JOKERS +yields the second mates of each read pair in the same order and +.I MIDDLE +yields the unpaired reads. To avoid leaking memory, the executed +program should read from all these file descriptors in an interleaved +fashion. When done, +.B bam-fixpair +exists with the exit code of the external program. + +.IP "-n, --dry-run, --validate" +Turns off output. Any errors or inconsistencies found by +.B bam-fixpair +will still be reported, so it serves to validate a BAM file. + +.IP "-k, --kill-widows" +Delete reads that lost their mate. Widows typically result from well +intended filters that deal improperly with paired end data. + +.IP "-u, --kill-unmapped" +Delete unmapped reads that lost their mate. The retained widows are +flagged as unpaired to make the output valid. + +.IP "--kill-none" +Do not delete reads that lost their mate. They are flagged as unpaired +to make the output valid. This is the default. + +.IP "-v, --verbose" +Print all informational messages. This is potentially very noisy. + +.IP "-w, --warnings" +Print warnings and errors. Warnings are emitted for minor +inconveniences like mismatches flags, errors are emitted for outright +mistakes like missing reads. This would be a good setting when +combined with +.IR "--validate" . + +.IP "--errors" +Print only errors. Errors are emitted for outright mistakes like +missing reads. This is the default setting. + +.IP "-q, --quiet" +Print only fatal errors that prevent program continuation. Use this if +you don't care about how badly mutilated the file is, and just want to +feed it into some program somehow. + +.IP "--report-mrnm, --no-report-mrnm" +Report / don't report mismatched mate reference names. Defaults to yes. + +.IP "--report-mpos, --no-report-mpos" +Report / don't report mismatches mate position. Defaults to yes. + +.IP "--report-isize, --no-report-isize" +Report / don't report wrong insert size. Slighly miscalculate insert +sizes are surprisingly common, so this defaults to no. + +.IP "--report-flags, --no-report-flags" +Report / don't report mismatched flags. Defaults to yes. + +.IP "--report-fflag, --no-report-fflag" +Report / don't report mismatched flags that are commonly inconsistent. +This applies to flags that are so often mishandled by common software +that they are more or less expected to be inconsistent, therefore it +defaults to no. + +.IP "--report-ixs, --no-report-ixs" +Report / don't report mismatched index information. Defaults to yes. + +.IP "--only-mapped" +Drop completely unmapped input. Single reads are retained in the output +if and only if they are mapped, paired reads are retained if and only if +.I at least one +of the two mates in a pair is mapped. This results in consistent +output, while the attempt to achieve the same by calling +.B samtools view -F4 +results in an inconsistent output. + +.IP "--fix-sven QUAL" +Trim the longest suffix off each read that has an average quality below +.IR QUAL . +If that causes a read to vanish, it is removed and leaves a widow, which +is then either flagged correctly or killed, depending on the setting +mentioned above. This option is a bad idea, don't use it. + +.IP "-h, -?, --help, --usage" +Prints a short usage information and exit. + +.IP "-V, --version" +Prints the version number and exits. + +.SH BUGS +For large and badly messed up inputs, +.B bam-fixpair +will run out of memory. A possible fix would be to buffer in external +memory, and that is planned, but hasn't been done. + +.SH AUTHOR +Udo Stenzel + +.SH "SEE ALSO" +.BR biohazard (7) + diff --git a/man/man1/fastq2bam.1 b/man/man1/fastq2bam.1 new file mode 100644 --- /dev/null +++ b/man/man1/fastq2bam.1 @@ -0,0 +1,181 @@ +.\" Process this file with +.\" groff -man -Tascii bam-rmdup.1 +.\" +.TH FASTQ2BAM 1 "OCTOBER 2014" Applications "User Manuals" +.SH NAME +fastq2bam \- convert fastq files to bam +.SH SYNOPSIS +.B fastq2bam [ +.I option +.B ... ] +.SH DESCRIPTION +.B fastq2bam +takes FastQ or FastA files as input and converts them to BAM, honoring +various common conventions. Paired end and singly or doubly indexed +reads are supported in most encodings encountered in the wild. + +Most syntactic conventions employed in FastQ are recognized, see below. +Multiple files can be given as input, they are combined sensibly and +finally concatenated. Bare file arguments behave the same as if they +were given with the +.I --read-one +option. + + +.SH OPTIONS +.IP "-o, --output file" +Send output to +.I file +instead of standard output. Absent +.IR -o , +uncompressed BAM is piped to stdout. + +.IP "-1, --read-one file" +Read +.I file +and turn each contained sequence into a BAM record. +.I file +may contain an arbitrary mix of paired and unpaired reads, first and +second mates, and so on. + +.IP "-2, --read-two file" +Read +.I file +and interpret the contents as second mates of read pairs. Each read is +paired up with one from the source previously given with +.I --read-one +(or stdin if no +.I --read-one +was encountered), and the pair is appropriately flagged a 1st mate and +2nd mate. + +.IP "-I, --index-one file" +Read +.I file +and interpret the contents as the first index sequence, which is +combined with reads from the source previously given with +.I --read-one +(or stdin if no +.I --read-one +was encountered). + +.IP "-J, --index-two file" +Read +.I file +and interpret the contents as the second index sequence, which is +combined with reads from the source previously given with +.I --read-one +(or stdin if no +.I --read-one +was encountered). + +.IP "-v, --verbose" +Causes +.I fastq2bam +to print a progress report to stderr. + +.SH INPUT FILES + +Input files can be FastQ or FastA, even a mix of the two, +optionally compressed using +.IR gzip "(1)." +If the input is FastA, the output will not have quality scores +associated with the sequences, but nothing else changes. Many +annotations in the header are recognized: + +.IP \(bu 4 +A name suffix of "/1" or "/2" is turned into the first mate or second +mate flag, respectively (Illumina convention). + +.IP \(bu 4 +The name prefixes "F_" and "R_" are turned into the first mate or +second mate flag, respectively (legacy MPI EVAN convention). + +.IP \(bu 4 +The name prefix "M_" flags the sequence as unpaired and merged (legacy +MPI EVAN convention). + +.IP \(bu 4 +The name prefix "T_" flags the sequence as unpaired and trimmed +(legacy MPI EVAN convention). + +.IP \(bu 4 +The name prefix of "C_", either before or after any of the other +prefixes, is turned into the extra flag +.IR XP:i:-1 , +meaning the result of duplicate removal with unknown duplicate count +(legacy MPI EVAN convention, I'm really sorry for this one). + +.IP \(bu 4 +A nucleotide sequence separated from the name by an octothorpe ("#") is +removed and treated as the first index. Two such sequences, separated +by a comma, are treated as first and second index (legacy convention, +possibly MPI EVAN only). + +.IP \(bu 4 +If the first word of the description has at least four colon separated +subfields, the first is used to flag first/second mate if it has the +value +.IR 1 or 2 , +respectively, the second is interpreted as the "QC failed" flag if it +has the value +.IR Y , +, and the fourth is used as the first index sequence. + +If multiple files are read and combined, later files override the +appropriate values parsed from earlier files. This makes it possible +to, e.g. have one file containing the first mates with their index +sequences, another with the second mates with their index sequences, and +a third file that supplies the second index sequence only. + + +.SH OUTPUT FILES + +Output is BAM. Most information is encoded in the standard fields and +flags. In addition, the first index sequence is placed into the +.I XI +field with string type, its quality score into the +.I YI +field with string type, encoded just like in FastQ files. +Likewise, the second index goes into +.IR XJ and YJ . +If a read is recognized as being a replacement for a cluster of +duplicates, this is encoded by setting +.I XP +to +.I -1 +with integer type. If a read is to be flagged as trimmed, the +.I FF +field is set to +.I 1 +, or to +.I 2 +if the read resulted from merging of a read pair (MPI EVAN convention). + +.SH NOTES + +Whenever multiple files are to be combined, they must run parallel, that +is, each file must contain sequences with the same read names in the +same order. + +If only a +.I --read-one +argument is combined with one or two index files, the normal parsing +logic applies, so a mix of paired and unpaired reads, even with indices +is allowed. The index sequences are overridden with those from the +separate input files. + +If one +.I --read-one +argument is combined with one +.I --read-two +argument, the pairing flags are forced. While the normal parsing logic +still applies, a mix of paired and unpaired reads will not work as +desired and will probably lead to errors. + +.SH AUTHOR +Udo Stenzel + +.SH "SEE ALSO" +.BR biohazard (7) + diff --git a/src/Bio/Adna.hs b/src/Bio/Adna.hs --- a/src/Bio/Adna.hs +++ b/src/Bio/Adna.hs @@ -1,37 +1,42 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric, CPP #-} module Bio.Adna ( DmgStats(..), + CompositionStats, + SubstitutionStats, + addFragType, damagePatternsIter, damagePatternsIterMD, damagePatternsIter2Bit, DamageParameters(..), + NewDamageParameters(..), + GenDamageParameters(..), DamageModel, - bang, + bang, nudge, Alignment(..), FragType(..), - To(..), + Subst(..), NPair, noDamage, univDamage, - memoDamageModel, - Mat44, - Mat44D - ) where + empDamage, + Mat44D(..), + MMat44D(..), + scalarMat, + complMat, + freezeMats, + bwa_cal_maxdiff + ) where + import Bio.Bam -import Bio.Base +import Bio.Prelude import Bio.TwoBit -import Control.Applicative -import Control.Arrow ( (***) ) -import Control.Monad -import Data.Bits ( xor ) -import Data.Monoid -import Data.Vec ( Mat44, Mat44D, identity, getElem, Vec4, (:.)((:.)) ) +import Data.Aeson hiding ( pairs ) -import qualified Data.Vector.Generic as G import qualified Data.Vector as V +import qualified Data.Vector.Generic as G import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as UM @@ -51,14 +56,26 @@ -- this is a vector of packed vectors. Conveniently, each of the packed -- vectors represents all transition /into/ the given nucleotide. +newtype Mat44D = Mat44D (U.Vector Double) deriving (Show, Generic) +newtype MMat44D = MMat44D (UM.IOVector Double) +instance ToJSON Mat44D where + toJSON (Mat44D v) = Array $ V.fromListN 4 + [ toJSON $ U.slice i 4 v + | i <- [0, 4, 8, 12] ] + +instance FromJSON Mat44D where + parseJSON = withArray "matrix" $ + fmap Mat44D . fmap U.concat . mapM parseJSON . V.toList + -- | 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. +-- each position in a read. The 'DamageModel' can depend on whether the +-- alignment is reversed, the length of the read and the position. (In +-- practice, we should probably memoize precomputed damage models +-- somehow.) -type DamageModel a = Bool -> Int -> V.Vector (Mat44 a) -data To = Nucleotide :-> Nucleotide +type DamageModel = Bool -> Int -> Int -> Mat44D +data Subst = Nucleotide :-> Nucleotide deriving (Eq, Ord, Ix, Show) infix 9 :-> infix 8 `bang` @@ -66,17 +83,57 @@ -- | Convenience function to access a substitution matrix that has a -- mnemonic reading. {-# INLINE bang #-} -bang :: Mat44D -> To -> Double -bang m (N x :-> N y) = getElem (fromIntegral x) $ getElem (fromIntegral y) m +bang :: Mat44D -> Subst -> Double +bang (Mat44D v) (N x :-> N y) + | U.length v == 16 = v U.! (fromIntegral x + 4 * fromIntegral y) + | otherwise = error $ "Huh? " ++ show (U.length v) +{-# INLINE nudge #-} +nudge :: MMat44D -> Subst -> Double -> IO () +nudge (MMat44D v) (N x :-> N y) a = UM.read v i >>= UM.write v i . (+) a + where i = fromIntegral x + 4 * fromIntegral y + +scalarMat :: Double -> Mat44D +scalarMat s = Mat44D $ U.fromListN 16 [ s, 0, 0, 0 + , 0, s, 0, 0 + , 0, 0, s, 0 + , 0, 0, 0, s ] + +complMat :: Mat44D -> Mat44D +complMat v = Mat44D $ U.fromListN 16 [ v `bang` compl x :-> compl y + | y <- range (nucA, nucT) + , x <- range (nucA, nucT) ] + +-- | Adds the two matrices of a mutable substitution model (one for each +-- strand) appropriately, normalizes the result (to make probabilities +-- from pseudo-counts), and freezes that into one immutable matrix. We +-- add a single count everywhere to avoid getting NaNs from bizarre +-- data. +freezeMats :: MMat44D -> MMat44D -> IO Mat44D +freezeMats (MMat44D vv) (MMat44D ww) = do + v <- Mat44D <$> U.freeze vv + w <- complMat . Mat44D <$> U.freeze ww + + let sums = U.generate 4 $ \x0 -> + let x = N $ fromIntegral x0 + in sum [ v `bang` x :-> z + w `bang` x :-> z + | z <- range (nucA, nucT) ] + 4 + + return . Mat44D $ U.fromListN 16 + [ (v `bang` x :-> y + w `bang` x :-> y + 1) / s + | y <- range (nucA, nucT) + , x <- range (nucA, nucT) + , let s = sums U.! fromIntegral (unN x) ] + + -- | '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 +noDamage :: DamageModel +noDamage _ _ _ = one + where !one = scalarMat 1 -- | Parameters for the universal damage model. @@ -88,7 +145,6 @@ -- 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, @@ -108,36 +164,41 @@ , 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) + deriving (Read, Show, Generic) +data NewDamageParameters vec float = NDP { dp_gc_frac :: !float + , dp_mu :: !float + , dp_nu :: !float + , dp_alpha5 :: !(vec float) + , dp_beta5 :: !(vec float) + , dp_alpha :: !float + , dp_beta :: !float + , dp_alpha3 :: !(vec float) + , dp_beta3 :: !(vec float) } + deriving (Read, Show, Generic) + +data GenDamageParameters vec float + = UnknownDamage + | OldDamage (DamageParameters float) + | NewDamage (NewDamageParameters vec float) + deriving (Show, Generic, Read) + + + -- | 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. {-# INLINE genSubstMat #-} -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 ) - where - 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 +genSubstMat :: Double -> Double -> Mat44D +genSubstMat p q = Mat44D $ U.fromListN 16 [ 1, 0, q, 0 + , 0, 1-p, 0, 0 + , 0, 0, 1-q, 0 + , 0, p, 0, 1 ] -{-# 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 +univDamage :: DamageParameters Double -> DamageModel +univDamage DP{..} r l 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 @@ -154,43 +215,73 @@ lam5_ds = dsd_lambda ^ (1+i) lam3_ds = dsd_lambda ^ (l-i) +empDamage :: NewDamageParameters U.Vector Double -> DamageModel +empDamage NDP{..} = + \r l i -> if i+i < l then + if r then fromMaybe middleRev (rev5 V.!? i) + else fromMaybe middle (fwd5 V.!? i) + else + if r then fromMaybe middleRev (rev3 V.!? (l-i-1)) + else fromMaybe middle (fwd3 V.!? (l-i-1)) + where + !middle = genSubstMat' dp_alpha dp_beta + !middleRev = genSubstMat' dp_beta dp_alpha + !fwd5 = V.zipWith genSubstMat' (G.convert dp_alpha5) (G.convert dp_beta5) + !fwd3 = V.zipWith genSubstMat' (G.convert dp_alpha3) (G.convert dp_beta3) + !rev5 = V.zipWith genSubstMat' (G.convert dp_beta5) (G.convert dp_alpha5) + !rev3 = V.zipWith genSubstMat' (G.convert dp_beta3) (G.convert dp_alpha3) + + genSubstMat' a b = genSubstMat (recip $ 1 + exp (-a)) (recip $ 1 + exp (-b)) + + -- | Collected \"traditional\" statistics: -- -- * Base composition near 5' end and near 3' end. Each consists of --- five vectors of counts of A,C,G,T, and everything else. 'basecompo5' --- begins with 'context' bases to the left of the 5' end, 'basecompo3' --- ends with 'context' bases to the right of the 3' end. +-- five vectors of counts of A,C,G,T, and everything else. +-- 'basecompo5' begins with 'context' bases to the left of the 5' end, +-- 'basecompo3' ends with 'context' bases to the right of the 3' end. -- -- * Substitutions. Counted from the reconstructed alignment, once --- around the 5' end and once around the 3' end. For a total of 2*4*4 --- different substitutions. +-- around the 5' end and once around the 3' end. For a total of 2*4*4 +-- different substitutions. Positions where the query has a gap are +-- skipped. -- --- * Substitutions at CpG motivs. Also counted from the reconstructed --- alignment, and a CpG site is simply the sequence CG in the reference. --- Gaps may interfere with that, but that might actually be desirable. +-- * Substitutions at CpG motifs. Also counted from the reconstructed +-- alignment, and a CpG site is simply the sequence CG in the +-- reference. Gaps may confuse that definition, so that CpHpG still +-- counts as CpG, because the H is gapped. That might actually +-- be desirable. -- --- * Conditional substitutions. Need an exact definition, and then a --- couple additional tables. +-- * Conditional substitutions. The 5' and 3' ends count as damaged if +-- the very last position has a C-to-T substitution. With that in +-- mind, 'substs5d5', 'substs5d3', 'substs5dd' are like 'substs5', but +-- counting only reads where the 5' end is damaged, where the 3' end +-- is damaged, and where both ends are damaged, respectively. -- -- XXX This got kind of ugly. We'll see where this goes... data DmgStats a = DmgStats { - basecompo5 :: [( Maybe Nucleotide, U.Vector Int )], - basecompo3 :: [( Maybe Nucleotide, U.Vector Int )], - substs5 :: [( To, U.Vector Int )], - substs3 :: [( To, U.Vector Int )], - substs5d5 :: [( To, U.Vector Int )], - substs3d5 :: [( To, U.Vector Int )], - substs5d3 :: [( To, U.Vector Int )], - substs3d3 :: [( To, U.Vector Int )], - substs5dd :: [( To, U.Vector Int )], - substs3dd :: [( To, U.Vector Int )], - substs5cpg :: [( To, U.Vector Int )], - substs3cpg :: [( To, U.Vector Int )], + basecompo5 :: CompositionStats, + basecompo3 :: CompositionStats, + substs5 :: SubstitutionStats, + substs3 :: SubstitutionStats, + substs5d5 :: SubstitutionStats, + substs3d5 :: SubstitutionStats, + substs5d3 :: SubstitutionStats, + substs3d3 :: SubstitutionStats, + substs5dd :: SubstitutionStats, + substs3dd :: SubstitutionStats, + substs5cpg :: SubstitutionStats, + substs3cpg :: SubstitutionStats, stats_more :: a } + deriving Show +type CompositionStats = [( Maybe Nucleotide, U.Vector Int )] +type SubstitutionStats = [( Subst, U.Vector Int )] + + data FragType = Complete | Leading | Trailing deriving (Show, Eq) type NPair = ( Nucleotides, Nucleotides ) @@ -201,6 +292,17 @@ { a_sequence :: !(U.Vector NPair) -- the alignment proper , a_fragment_type :: !FragType } -- was the adapter trimmed? +addFragType :: BamMeta -> Enumeratee [BamRaw] [(BamRaw,FragType)] m b +addFragType meta = mapStream $ \br -> (br, case unpackBam br of + b | isFirstMate b && isPaired b -> Leading + | isSecondMate b && isPaired b -> Trailing + | not sane -> Complete -- leeHom fscked it up + | isFirstMate b || isSecondMate b -> Complete -- old style flagging + | isTrimmed b || isMerged b -> Complete -- new style flagging + | otherwise -> Leading) + where + sane = null [ () | ("PG",line) <- meta_other_shit meta + , ("PN","mergeTrimReadsBAM") <- line ] -- | Enumeratee (almost) that computes some statistics from plain BAM -- (no MD field needed) and a 2bit file. The 'Alignment' is also @@ -215,28 +317,26 @@ -- to reconstruct the alignment. -- -- Arguments are the table of reference names, the 2bit file with the --- reference, the amount of context outside the alignment desired, the --- amount of context inside desired, and whether to compensate for --- leeHom breakage. +-- reference, the amount of context outside the alignment desired, and +-- the amount of context inside desired. -- -- For 'Complete' fragments, we cut the read in the middle, so the 5' -- and 3' plots stay clean from each other's influence. 'Leading' and -- 'Trailing' fragments count completely towards the appropriate end. damagePatternsIter2Bit :: MonadIO m - => Refs -> TwoBitFile -> Int -> Int -> Bool + => Refs -> TwoBitFile -> Int -> Int -> Iteratee [Alignment] m b - -> Iteratee [BamRaw] m (DmgStats b) -damagePatternsIter2Bit refs tbf ctx rng = - damagePatternsIter ctx rng $ \br -> + -> Iteratee [(BamRaw,FragType)] m (DmgStats b) +damagePatternsIter2Bit refs tbf ctx rng it = + mapMaybeStream (\(br,ft) -> do let b@BamRec{..} = unpackBam br - ref_nm = sq_name $ getRef refs b_rname + guard (not $ isUnmapped b) + let ref_nm = sq_name $ getRef refs b_rname ref = getFragment tbf ref_nm (b_pos - ctx) (alignedLength b_cigar + 2*ctx) pairs = aln_from_ref (U.drop ctx ref) b_seq b_cigar - in if isUnmapped b - then Nothing - else Just (b, ref, pairs) - + return (b, ft, ref, pairs)) =$ + damagePatternsIter ctx rng it -- | Enumeratee (almost) that computes some statistics from plain BAM -- with a valid MD field. The 'Alignment' is also reconstructed and @@ -247,26 +347,24 @@ -- * Filter the alignment to get the reference sequence, accumulate it. -- * Accumulate everything over the alignment. -- --- Arguments are just the amount of context inside desired. --- Arguments are the amount of context inside desired, and whether to --- compensate for leeHom breakage. +-- The argument is the amount of context inside desired. -- -- For 'Complete' fragments, we cut the read in the middle, so the 5' -- and 3' plots stay clean from each other's influence. 'Leading' and -- 'Trailing' fragments count completely towards the appropriate end. damagePatternsIterMD :: MonadIO m - => Int -> Bool - -> Iteratee [Alignment] m b - -> Iteratee [BamRaw] m (DmgStats b) -damagePatternsIterMD rng = - damagePatternsIter 0 rng $ \br -> do + => Int -> Iteratee [Alignment] m b + -> Iteratee [(BamRaw,FragType)] m (DmgStats b) +damagePatternsIterMD rng it = + mapMaybeStream (\(br,ft) -> do let b@BamRec{..} = unpackBam br guard (not $ isUnmapped b) md <- getMd b let pairs = aln_from_md b_seq b_cigar md ref = U.map fromN $ U.filter ((/=) gap . fst) pairs - return (b, ref, pairs) + return (b, ft, ref, pairs)) =$ + damagePatternsIter 0 rng it where fromN (ns,_) | ns == nucsA = 2 | ns == nucsC = 1 @@ -280,38 +378,36 @@ -- strand of the reference; we reverse-complement it if necessary. damagePatternsIter :: MonadIO m => Int -> Int - -> (BamRaw -> Maybe (BamRec, U.Vector Word8, U.Vector NPair)) - -> Bool -> Iteratee [Alignment] m b - -> Iteratee [BamRaw] m (DmgStats b) -damagePatternsIter ctx rng get_ref_and_aln leeHom it = do + -> Iteratee [Alignment] m b + -> Iteratee [(BamRec, FragType, U.Vector Word8, U.Vector NPair)] m (DmgStats b) +damagePatternsIter ctx rng it = mapStream revcom_both =$ do let maxwidth = ctx + rng acc_bc <- liftIO $ UM.replicate (2 * 5 * maxwidth) (0::Int) acc_st <- liftIO $ UM.replicate (2 * 4 * 4 * 4 * rng) (0::Int) acc_cg <- liftIO $ UM.replicate (2 * 2 * 4 * rng) (0::Int) - let do_bc br = case fmap revcom_both $ get_ref_and_aln br of - Nothing -> return [] - Just (b@BamRec{..}, ref, a_sequence) -> liftIO $ do - + it' <- flip mapStreamM it $ \(BamRec{..}, a_fragment_type, ref, a_sequence) -> liftIO $ do +#ifdef DEBUG + when (U.any (<0) ref || U.any (>4) ref) . error $ + "Unexpected value in reference fragment: " ++ show ref +#endif let good_pairs = U.indexed a_sequence good_pairs_rev = U.indexed $ U.reverse a_sequence - a_fragment_type | isFirstMate b && isPaired b = Leading - | isSecondMate b && isPaired b = Trailing - | leeHom = Complete - | isFirstMate b || isSecondMate b = Complete -- old style flagging - | isTrimmed b || isMerged b = Complete -- new style flagging - | otherwise = Leading -- basecompositon near 5' end, near 3' end - let width = ctx + min rng (alignedLength b_cigar `div` 2) - mapM_ (\i -> bump (fromIntegral (ref U.! i ) * maxwidth + i) acc_bc) [0 .. width-1] - mapM_ (\i -> bump (fromIntegral (ref U.! (i + U.length ref) +6) * maxwidth + i) acc_bc) [-width .. -1] + let (width5, width3) = case a_fragment_type of + Leading -> (full_width, 0) + Trailing -> (0, full_width) + Complete -> (half_width, half_width) + where full_width = min (U.length ref) $ ctx + min rng (alignedLength b_cigar) + half_width = min (U.length ref) $ ctx + min rng (alignedLength b_cigar `div` 2) + mapM_ (\i -> bump (fromIntegral (ref U.! i ) * maxwidth + i) acc_bc) [0 .. width5-1] + mapM_ (\i -> bump (fromIntegral (ref U.! (i + U.length ref) +6) * maxwidth + i) acc_bc) [-width3 .. -1] -- For substitutions, decide what damage class we're in: -- 0 - no damage, 1 - damaged 5' end, 2 - damaged 3' end, 3 - both - let dmgbase = 2*4*4*rng * - ( (if U.null a_sequence || U.head a_sequence /= (nucsC,nucsT) then 1 else 0) - + (if U.null a_sequence || U.last a_sequence /= (nucsC,nucsT) then 2 else 0) ) + let dmgbase = 2*4*4*rng * ( (if U.null a_sequence || U.head a_sequence /= (nucsC,nucsT) then 1 else 0) + + (if U.null a_sequence || U.last a_sequence /= (nucsC,nucsT) then 2 else 0) ) -- substitutions near 5' end let len_at_5 = case a_fragment_type of Leading -> min rng (G.length b_seq) @@ -344,30 +440,9 @@ (U.drop 1 good_pairs_rev) (U.take len_at_3 good_pairs_rev) - return [ ALN{..} ] - where - {-# INLINE withPair #-} - withPair (Ns u, Ns v) k = case pairTab `U.unsafeIndex` fromIntegral (16*u+v) of - j -> if j >= 0 then k j else return () - - !pairTab = U.replicate 256 (-1) U.// - [ (fromIntegral $ 16*u+v, x*4+y) | (Ns u,x) <- zip [nucsA, nucsC, nucsG, nucsT] [0,1,2,3] - , (Ns v,y) <- zip [nucsA, nucsC, nucsG, nucsT] [0,1,2,3] ] - - {-# INLINE bump #-} - bump i v = UM.unsafeRead v i >>= UM.unsafeWrite v i . succ - - {-# INLINE withNs #-} - withNs ns k | ns == nucsA = k 0 - | ns == nucsC = k 1 - | ns == nucsG = k 2 - | ns == nucsT = k 3 - | otherwise = return () - - - it' <- concatMapStreamM do_bc it + return ALN{..} - let nsubsts = 2*4*4*rng + let nsubsts = 4*4*rng mk_substs off = sequence [ (,) (n1 :-> n2) <$> U.unsafeFreeze (UM.slice ((4*i+j)*rng + off*nsubsts) rng acc_st) | (i,n1) <- zip [0..] [nucA..nucT] , (j,n2) <- zip [0..] [nucA..nucT] ] @@ -395,25 +470,85 @@ , (j,n1) <- zip [0..] [nucA..nucT] ] accs' <- accs `liftM` lift (run it') - let vsum = foldl1 (zipWith s1) . map ($ accs') - s1 (x :-> y, u) (z :-> w, v) | x == z && y == w = (x :-> y, U.zipWith (+) u v) - | otherwise = error $ "Mismatch in zip. This is a bug." + return $ accs' { substs5 = mconcat [ substs5 accs', substs5d5 accs', substs5d3 accs', substs5dd accs' ] + , substs3 = mconcat [ substs3 accs', substs3d5 accs', substs3d3 accs', substs3dd accs' ] + , substs5d5 = mconcat [ substs5d5 accs', substs5dd accs'] + , substs3d5 = mconcat [ substs3d5 accs', substs3dd accs'] + , substs5d3 = mconcat [ substs5d3 accs', substs5dd accs'] + , substs3d3 = mconcat [ substs3d3 accs', substs3dd accs'] } + where + {-# INLINE withPair #-} + withPair (Ns u, Ns v) k = case pairTab `U.unsafeIndex` fromIntegral (16*u+v) of + j -> if j >= 0 then k j else return () - return $ accs' { substs5 = vsum [ substs5, substs5d5, substs5d3, substs5dd ] - , substs3 = vsum [ substs3, substs3d5, substs3d3, substs3dd ] - , substs5d5 = vsum [ substs5d5, substs5dd ] - , substs3d5 = vsum [ substs3d5, substs3dd ] - , substs5d3 = vsum [ substs5d3, substs5dd ] - , substs3d3 = vsum [ substs3d3, substs3dd ] } + !pairTab = U.replicate 256 (-1) U.// + [ (fromIntegral $ 16*u+v, x*4+y) | (Ns u,x) <- zip [nucsA, nucsC, nucsG, nucsT] [0,1,2,3] + , (Ns v,y) <- zip [nucsA, nucsC, nucsG, nucsT] [0,1,2,3] ] + {-# INLINE bump #-} +#ifdef DEBUG + bump i v = UM.read v i >>= UM.write v i . succ +#else + bump i v = UM.unsafeRead v i >>= UM.unsafeWrite v i . succ +#endif + {-# INLINE withNs #-} + withNs ns k | ns == nucsA = k 0 + | ns == nucsC = k 1 + | ns == nucsG = k 2 + | ns == nucsT = k 3 + | otherwise = return () -revcom_both :: ( BamRec, U.Vector Word8, U.Vector (Nucleotides, Nucleotides) ) - -> ( BamRec, U.Vector Word8, U.Vector (Nucleotides, Nucleotides) ) -revcom_both (b, ref, pairs) - | isReversed b = ( b, revcom_ref ref, revcom_pairs pairs ) - | otherwise = ( b, ref, pairs ) + +instance Monoid a => Monoid (DmgStats a) where + mempty = DmgStats { basecompo5 = empty_compo + , basecompo3 = empty_compo + , substs5 = empty_subst + , substs3 = empty_subst + , substs5d5 = empty_subst + , substs3d5 = empty_subst + , substs5d3 = empty_subst + , substs3d3 = empty_subst + , substs5dd = empty_subst + , substs3dd = empty_subst + , substs5cpg = empty_subst + , substs3cpg = empty_subst + , stats_more = mempty } + where + empty_compo = [ (nuc, U.empty) | nuc <- [Just nucA, Just nucC, Just nucG, Just nucT, Nothing] ] + empty_subst = [ (n1 :-> n2, U.empty) | n1 <- [nucA..nucT], n2 <- [nucA..nucT] ] + + a `mappend` b = DmgStats { basecompo5 = zipWith s1 (basecompo5 a) (basecompo5 b) + , basecompo3 = zipWith s1 (basecompo3 a) (basecompo3 b) + , substs5 = zipWith s2 (substs5 a) (substs5 b) + , substs3 = zipWith s2 (substs3 a) (substs3 b) + , substs5d5 = zipWith s2 (substs5d5 a) (substs5d5 b) + , substs3d5 = zipWith s2 (substs3d5 a) (substs3d5 b) + , substs5d3 = zipWith s2 (substs5d3 a) (substs5d3 b) + , substs3d3 = zipWith s2 (substs3d3 a) (substs3d3 b) + , substs5dd = zipWith s2 (substs5dd a) (substs5dd b) + , substs3dd = zipWith s2 (substs3dd a) (substs3dd b) + , substs5cpg = zipWith s2 (substs5cpg a) (substs5cpg b) + , substs3cpg = zipWith s2 (substs3cpg a) (substs3cpg b) + , stats_more = mappend (stats_more a) (stats_more b) } + where + s1 (x, u) (z, v) | x /= z = error "Mismatch in zip. This is a bug." + | U.null u = (x, v) + | U.null v = (x, u) + | otherwise = (x, U.zipWith (+) u v) + + s2 (x :-> y, u) (z :-> w, v) | x /= z || y /= w = error "Mismatch in zip. This is a bug." + | U.null u = (x :-> y, v) + | U.null v = (x :-> y, u) + | otherwise = (x :-> y, U.zipWith (+) u v) + + +revcom_both :: ( BamRec, FragType, U.Vector Word8, U.Vector (Nucleotides, Nucleotides) ) + -> ( BamRec, FragType, U.Vector Word8, U.Vector (Nucleotides, Nucleotides) ) +revcom_both (b, ft, ref, pairs) + | isReversed b = ( b, ft, revcom_ref ref, revcom_pairs pairs ) + | otherwise = ( b, ft, ref, pairs ) where - revcom_ref = U.reverse . U.map (xor 2) + revcom_ref = U.reverse . U.map (\c -> if c > 3 then c else xor c 2) revcom_pairs = U.reverse . U.map (compls *** compls) @@ -473,4 +608,52 @@ step' qry Nop _ cig md = step qry cig md step' qry Pad _ cig md = step qry cig md +-- | Number of mismatches allowed by BWA. +-- @bwa_cal_maxdiff thresh len@ returns the number of mismatches +-- @bwa aln -n $tresh@ would allow in a read of length @len@. For +-- reference, here is the code from BWA that computes it (we assume @err +-- = 0.02@, just like BWA): +-- +-- @ +-- int bwa_cal_maxdiff(int l, double err, double thres) +-- { +-- double elambda = exp(-l * err); +-- double sum, y = 1.0; +-- int k, x = 1; +-- for (k = 1, sum = elambda; k < 1000; ++k) { +-- y *= l * err; +-- x *= k; +-- sum += elambda * y / x; +-- if (1.0 - sum < thres) return k; +-- } +-- return 2; +-- } +-- @ +-- double sum, y = 1.0; +-- int k, x = 1; +-- for (k = 1, sum = elambda; k < 1000; ++k) { +-- y *= l * err; +-- x *= k; +-- sum += elambda * y / x; +-- if (1.0 - sum < thres) return k; +-- } +-- return 2; +-- } +-- @ +-- + +bwa_cal_maxdiff :: Double -> Int -> Int +bwa_cal_maxdiff thresh len = k_fin-1 + where + (k_fin, _, _, _) : _ = dropWhile bad $ iterate step (1,elambda,1,1) + + err = 0.02 + elambda = exp . negate $ fromIntegral len * err + + step (k, s, x, y) = (k+1, s', x', y') + where y' = y * fromIntegral len * err + x' = x * fromIntegral k + s' = s + elambda * y' / x' + + bad (_, s, _, _) = 1-s >= thresh diff --git a/src/Bio/Align.hs b/src/Bio/Align.hs --- a/src/Bio/Align.hs +++ b/src/Bio/Align.hs @@ -1,15 +1,13 @@ -{-# LANGUAGE ForeignFunctionInterface #-} module Bio.Align ( Mode(..), myersAlign, showAligned ) where -import Control.Applicative ( (<$>), (<*>) ) +import Bio.Prelude hiding ( lefts, rights ) 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 @@ -46,7 +44,7 @@ -- 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 :: Int -> Bytes -> Mode -> Bytes -> (Int, Bytes, Bytes) myersAlign maxd seqA mode seqB = unsafePerformIO $ S.unsafeUseAsCStringLen seqA $ \(seq_a, len_a) -> @@ -74,7 +72,7 @@ -- 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 :: Int -> [Bytes] -> [L.ByteString] showAligned w ss | all S.null ss = [] | otherwise = map (L.fromChunks . (:[])) lefts ++ L.pack agreement : diff --git a/src/Bio/Bam/Evan.hs b/src/Bio/Bam/Evan.hs --- a/src/Bio/Bam/Evan.hs +++ b/src/Bio/Bam/Evan.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -- | 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 @@ -9,6 +8,7 @@ import Bio.Bam.Header import Bio.Bam.Rec import Data.Bits +import Prelude import qualified Data.ByteString.Char8 as S diff --git a/src/Bio/Bam/Fastq.hs b/src/Bio/Bam/Fastq.hs --- a/src/Bio/Bam/Fastq.hs +++ b/src/Bio/Bam/Fastq.hs @@ -1,15 +1,10 @@ -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} -module Bio.Bam.Fastq ( - parseFastq, parseFastq', parseFastqCassava - ) where +module Bio.Bam.Fastq ( parseFastq, parseFastq', parseFastqCassava ) where import Bio.Bam.Header import Bio.Bam.Rec -import Bio.Base +import Bio.Prelude hiding ( isSpace ) 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 @@ -66,11 +61,10 @@ -- 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 :: Monad m => Enumeratee Bytes [ BamRec ] m a parseFastq = parseFastq' (const id) -parseFastqCassava :: Monad m => Enumeratee S.ByteString [ BamRec ] m a +parseFastqCassava :: Monad m => Enumeratee Bytes [ 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 @@ -86,8 +80,7 @@ -- 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' :: Monad m => ( Bytes -> BamRec -> BamRec ) -> Enumeratee Bytes [ BamRec ] m a parseFastq' descr it = do skipJunk ; convStream (parserToIteratee $ (:[]) <$> pRec) it where isCBase = inClass "ACGTUBDHVSWMKRYNacgtubdhvswmkryn" @@ -106,25 +99,14 @@ step i c | isSpace c = Just i | otherwise = Just (i-1) -skipJunk :: Monad m => Iteratee S.ByteString m () +skipJunk :: Monad m => Iteratee Bytes 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 :: Seqid -> (BamRec->BamRec) -> (String, Bytes) -> BamRec makeRecord name extra (sq,qual) = extra $ nullBamRec { b_qname = name, b_seq = V.fromList $ read sq, b_qual = V.fromList $ map (Q . subtract 33) $ B.unpack qual } - ----------------------------------------------------------------------------- - -some_file :: FilePath -some_file = "/mnt/ngs_data/101203_SOLEXA-GA04_00007_PEDi_MM_QF_SR/Ibis/Final_Sequences/s_5_L3280_sequence_merged.txt" - -fastq_test :: FilePath -> IO () -fastq_test = fileDriver $ joinI $ parseFastq print_names - -print_names :: Iteratee [BamRec] IO () -print_names = I.mapM_ $ S.putStrLn . b_qname diff --git a/src/Bio/Bam/Filter.hs b/src/Bio/Bam/Filter.hs --- a/src/Bio/Bam/Filter.hs +++ b/src/Bio/Bam/Filter.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE FlexibleContexts #-} module Bio.Bam.Filter ( filterPairs, QualFilter, complexSimple, complexEntropy, qualityAverage, qualityMinimum, qualityFromOldIllumina, qualityFromNewIllumina - ) where + ) where import Bio.Bam.Header import Bio.Bam.Rec import Bio.Base import Bio.Iteratee import Data.Bits +import Prelude import qualified Data.Vector.Generic as V diff --git a/src/Bio/Bam/Header.hs b/src/Bio/Bam/Header.hs --- a/src/Bio/Bam/Header.hs +++ b/src/Bio/Bam/Header.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings, BangPatterns #-} module Bio.Bam.Header ( BamMeta(..), parseBamMeta, @@ -39,6 +38,7 @@ flagDuplicate, eflagTrimmed, eflagMerged, + eflagVestigial, distinctBin, @@ -47,30 +47,20 @@ showMd ) where -import Bio.Base -import Control.Applicative -import Data.Bits ( shiftL, shiftR, (.&.), (.|.) ) -import Data.Char ( isDigit, ord, chr ) +import Bio.Prelude hiding ( uncons ) +import Data.ByteString ( uncons ) import Data.ByteString.Builder -import Data.Ix -import Data.List ( (\\), foldl' ) 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] + meta_comment :: [Bytes] } deriving Show -- | Exactly two characters, for the \"named\" fields in bam. @@ -117,14 +107,14 @@ 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 } + , meta_other_shit = nub $ meta_other_shit a ++ meta_other_shit b + , meta_comment = nub $ meta_comment a ++ meta_comment b } data BamHeader = BamHeader { hdr_version :: (Int, Int), hdr_sorting :: !BamSorting, hdr_other_shit :: BamOtherShit - } deriving Show + } deriving (Show, Eq) instance Monoid BamHeader where mempty = BamHeader (1,0) Unknown [] @@ -136,7 +126,7 @@ sq_name :: Seqid, sq_length :: Int, sq_other_shit :: BamOtherShit - } deriving Show + } deriving (Show, Eq) bad_seq :: BamSQ bad_seq = BamSQ (error "no SN field") (error "no LN field") [] @@ -147,7 +137,7 @@ data BamSorting = Unknown | Unsorted | Grouped | Queryname | Coordinate | GroupSorted deriving (Show, Eq) -type BamOtherShit = [(BamKey, S.ByteString)] +type BamOtherShit = [(BamKey, Bytes)] parseBamMeta :: P.Parser BamMeta parseBamMeta = fixup . foldl' (flip ($)) mempty <$> P.sepBy parseBamMetaLine (P.skipWhile (=='\t') >> P.char '\n') @@ -195,12 +185,12 @@ 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 :: P.Parser (BamKey,Bytes) tagother = (,) <$> bamkey <*> (P.char ':' >> pall) tabs = P.char '\t' >> P.skipWhile (== '\t') - pall :: P.Parser S.ByteString + pall :: P.Parser Bytes pall = P.takeWhile (\c -> c/='\t' && c/='\n') bamkey :: P.Parser BamKey @@ -209,14 +199,14 @@ 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 + foldMap show_bam_meta_seq ss <> + foldMap show_bam_meta_other os <> + 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 + byteString (case so of Unknown -> mempty Unsorted -> "\tSO:unsorted" Grouped -> "\tSO:grouped" Queryname -> "\tSO:queryname" @@ -235,7 +225,7 @@ char7 '@' <> word16LE k <> show_bam_others ts show_bam_others ts = - F.foldMap show_bam_other ts <> char7 '\n' + foldMap show_bam_other ts <> char7 '\n' show_bam_other (BamKey k,v) = char7 '\t' <> word16LE k <> char7 ':' <> byteString v @@ -317,9 +307,10 @@ flagFailsQC = 0x200 flagDuplicate = 0x400 -eflagTrimmed, eflagMerged :: Int +eflagTrimmed, eflagMerged, eflagVestigial :: Int eflagTrimmed = 0x1 eflagMerged = 0x2 +eflagVestigial = 0x4 -- | Compares two sequence names the way samtools does. @@ -333,7 +324,7 @@ -- smaller (and that part is stupid) compareNames :: Seqid -> Seqid -> Ordering -compareNames n m = case (B.uncons n, B.uncons m) of +compareNames n m = case (uncons n, uncons m) of ( Nothing, Nothing ) -> EQ ( Just _, Nothing ) -> GT ( Nothing, Just _ ) -> LT @@ -355,7 +346,7 @@ data MdOp = MdNum Int | MdRep Nucleotides | MdDel [Nucleotides] deriving Show -readMd :: S.ByteString -> Maybe [MdOp] +readMd :: Bytes -> Maybe [MdOp] readMd s | S.null s = return [] | isDigit (S.head s) = do (n,t) <- S.readInt s (MdNum n :) <$> readMd t @@ -365,7 +356,7 @@ -- | Normalizes a series of 'MdOp's and encodes them in the way BAM and -- SAM expect it. -showMd :: [MdOp] -> S.ByteString +showMd :: [MdOp] -> Bytes showMd = S.pack . flip s1 [] where s1 (MdNum i : MdNum j : ms) = s1 (MdNum (i+j) : ms) diff --git a/src/Bio/Bam/Index.hs b/src/Bio/Bam/Index.hs --- a/src/Bio/Bam/Index.hs +++ b/src/Bio/Bam/Index.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards, PatternGuards, FlexibleContexts #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} module Bio.Bam.Index ( BamIndex(..), readBamIndex, @@ -21,12 +19,7 @@ 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 Bio.Prelude import System.Directory ( doesFileExist ) import System.FilePath ( dropExtension, takeExtension, (<.>) ) import System.Random ( randomRIO ) @@ -48,24 +41,24 @@ data BamIndex a = BamIndex { -- | Minshift parameter from CSI - minshift :: !Int, + minshift :: {-# UNPACK #-} !Int, -- | Depth parameter from CSI - depth :: !Int, + depth :: {-# UNPACK #-} !Int, -- | Best guess at where the unaligned records start - unaln_off :: !Int64, + unaln_off :: {-# UNPACK #-} !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), + refseq_bins :: {-# UNPACK #-} !(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) } + refseq_ckpoints :: {-# UNPACK #-} !(V.Vector Ckpoints) } deriving Show @@ -104,7 +97,7 @@ -- | 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 +data Segment = Segment {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int deriving Show segmentLists :: BamIndex a -> Refseq -> R.Subsequence -> [[Segment]] segmentLists bi@BamIndex{..} (Refseq ref) (R.Subsequence imap) @@ -128,11 +121,11 @@ 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 + binlist' l s t = if l > depth then [] else [b..e] ++ go where b = t + beg `shiftR` s e = t + (end-1) `shiftR` s - loop = binlist' (l+1) (s-3) (t + 1 `shiftL` (3*l)) + go = binlist' (l+1) (s-3) (t + 1 `shiftL` (3*l)) -- | Merges two lists of segments. Lists must be sorted, the merge sort @@ -158,23 +151,23 @@ 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") $ + | otherwise = tryIx (fp <.> "bai") $ + tryIx (dropExtension fp <.> "bai") $ + tryIx (fp <.> "csi") $ + tryIx (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 + tryIx 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 :: MonadIO m => Iteratee Bytes m (BamIndex ()) readBaiIndex = iGetString 4 >>= switch where switch "BAI\1" = do nref <- fromIntegral `liftM` endianRead4 LSB @@ -210,14 +203,14 @@ , col_end :: Int -- Column for the end of a region , comment_char :: Char , skip_lines :: Int - , names :: V.Vector ByteString } + , names :: V.Vector Bytes } 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 :: MonadIO m => Iteratee Bytes m TabIndex readTabix = joinI $ decompressBgzf $ iGetString 4 >>= switch where switch "TBI\1" = do nref <- fromIntegral `liftM` endianRead4 LSB @@ -242,7 +235,7 @@ 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 :: Monad m => (IntMap Int64, Int64) -> Iteratee Bytes m (IntMap Int64, Int64) getIntervals (cp,mx0) = do nintv <- fromIntegral `liftM` endianRead4 LSB reduceM 0 nintv (cp,mx0) $ \(!im,!mx) int -> do @@ -251,9 +244,9 @@ getIndexArrays :: MonadIO m => Int -> Int -> Int - -> (Word32 -> Ckpoints -> Iteratee ByteString m Ckpoints) - -> ((Ckpoints, Int64) -> Iteratee ByteString m (Ckpoints, Int64)) - -> Iteratee ByteString m (BamIndex ()) + -> (Word32 -> Ckpoints -> Iteratee Bytes m Ckpoints) + -> ((Ckpoints, Int64) -> Iteratee Bytes m (Ckpoints, Int64)) + -> Iteratee Bytes m (BamIndex ()) getIndexArrays nref minshift depth addOneCheckpoint addManyCheckpoints | nref < 1 = return $ BamIndex minshift depth 0 () V.empty V.empty | otherwise = do @@ -274,7 +267,7 @@ -- | Reads the list of segments from an index file and makes sure -- it is sorted. -getSegmentArray :: MonadIO m => Iteratee ByteString m Segments +getSegmentArray :: MonadIO m => Iteratee Bytes m Segments getSegmentArray = do nsegs <- fromIntegral `liftM` endianRead4 LSB segsarr <- liftIO $ N.new nsegs @@ -351,6 +344,12 @@ -- | Subsample randomly from a BAM file. If an index exists, this -- produces an infinite stream taken from random locations in the file. +-- +-- XXX It would be cool if we could subsample from multiple BAM files. +-- It's a bit annoying to code: we'd probably read the indices up front, +-- estimate how many reads we'd find in each file, then open them +-- recursively to form a monad stack where the merging function has to +-- select randomly where to read from. Hm. subsampleBam :: (MonadIO m, MonadMask m) => FilePath -> Enumerator' BamMeta [BamRaw] m b subsampleBam fp o = liftIO (E.try (readBamIndex fp)) >>= subsam @@ -367,15 +366,15 @@ hdr <- enumFdRandom defaultBufSize fd >=> run $ joinI $ decompressBgzfBlocks' 1 $ joinI $ decodeBam return - loop fd (o hdr) + go fd (o hdr) where !ckpts = U.fromList . V.foldr ((++) . M.elems) [] $ refseq_ckpoints bix - loop fd o1 = enumCheckIfDone o1 >>= loop' fd + go fd o1 = enumCheckIfDone o1 >>= go' 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 + go' _ (True, o2) = return o2 + go' fd (False, o2) = do i <- liftIO $ randomRIO (0, U.length ckpts -1) + enum fd i o2 >>= go fd enum fd i = enumFdRandom defaultBufSize fd $= decompressBgzfBlocks' 1 $= diff --git a/src/Bio/Bam/Pileup.hs b/src/Bio/Bam/Pileup.hs --- a/src/Bio/Bam/Pileup.hs +++ b/src/Bio/Bam/Pileup.hs @@ -1,25 +1,15 @@ -{-# LANGUAGE BangPatterns, Rank2Types, RecordWildCards, OverloadedStrings #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE Rank2Types, DeriveGeneric #-} module Bio.Bam.Pileup where -import Bio.Base import Bio.Bam.Header import Bio.Bam.Rec import Bio.Iteratee - -import Control.Applicative -import Control.Monad hiding ( mapM_ ) -import Control.Monad.Fix ( fix ) -import Data.Foldable hiding ( sum, product ) -import Data.Ord -import Data.Vec.Packed ( Mat44D ) +import Bio.Prelude 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 @@ -71,31 +61,23 @@ -- minifloat from Bio.Util goes from 0 to 63488. --- *TODO* --- --- * A whole lot of testing. --- * 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 [Nucleotides] [DamagedBase] PrimBase -- ^ observed deletion and insertion between two bases - | EndOfRead -- ^ nothing anymore +data PrimChunks = Seek Int PrimBase -- ^ skip to position (at start or after N operation) + | Indel [Nucleotides] [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 +data PrimBase = Base { _pb_wait :: {-# UNPACK #-} !Int -- ^ number of bases to wait due to a deletion + , _pb_base :: {-# UNPACK #-} !DamagedBase + , _pb_mapq :: {-# UNPACK #-} !Qual -- ^ map quality + , _pb_chunks :: PrimChunks } -- ^ more chunks deriving Show -type PosPrimChunks = (Refseq, Int, PrimChunks) +type PosPrimChunks = (Refseq, Int, Bool, PrimChunks) -- | 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 @@ -105,14 +87,21 @@ -- -- Unfortunately, none of this can be rolled into something more simple, -- because damage and sequencing error behave so differently. +-- +-- Damage information is polymorphic. We might run with a simple +-- version (a matrix) for calling, but we need more (a matrix and a +-- mutable matrix, I think) for estimation. -data DamagedBase = DB { db_call :: {-# UNPACK #-} !Nucleotide -- ^ called base - , db_qual :: {-# UNPACK #-} !Qual -- ^ quality of called base - , db_ref :: {-# UNPACK #-} !Nucleotides -- ^ reference base from MD field - , db_dmg :: {-# UNPACK #-} !Mat44D } -- ^ damage matrix +data DamagedBase = DB { db_call :: {-# UNPACK #-} !Nucleotide -- ^ called base + , db_qual :: {-# UNPACK #-} !Qual -- ^ quality of called base + , db_dmg_tk :: {-# UNPACK #-} !DmgToken -- ^ damage information + , db_dmg_pos :: {-# UNPACK #-} !Int -- ^ damage information + , db_ref :: {-# UNPACK #-} !Nucleotides } -- ^ reference base from MD field +newtype DmgToken = DmgToken { fromDmgToken :: Int } + instance Show DamagedBase where - showsPrec _ (DB n q r _) + showsPrec _ (DB n q _ _ r) | nucToNucs n == r = shows n . (:) '@' . shows q | otherwise = shows n . (:) '/' . shows r . (:) '@' . shows q @@ -122,14 +111,14 @@ -- and quality as appropriate. Clipped bases are removed/skipped as -- appropriate. We also do apply a substitution matrix to each base, -- which must be supplied along with the read. - -decompose :: [Mat44D] -> BamRaw -> Maybe PosPrimChunks -decompose matrices br = +{-# INLINE decompose #-} +decompose :: DmgToken -> BamRaw -> [PosPrimChunks] +decompose dtok br = if isUnmapped b || isDuplicate b || not (isValidRefseq b_rname) - then Nothing else Just (b_rname, b_pos, pchunks) + then [] else [(b_rname, b_pos, isReversed b, pchunks)] where b@BamRec{..} = unpackBam br - pchunks = firstBase b_pos 0 0 (maybe [] id $ getMd b) matrices + pchunks = firstBase b_pos 0 0 (maybe [] id $ getMd b) !max_cig = V.length b_cigar !max_seq = V.length b_seq @@ -140,49 +129,50 @@ -- 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 -> Nucleotides -> 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) + get_seq :: Int -> Nucleotides -> DamagedBase + get_seq i = case b_seq `V.unsafeIndex` i of -- nucleotide + n | n == nucsA -> DB nucA qe dtok dmg + | n == nucsC -> DB nucC qe dtok dmg + | n == nucsG -> DB nucG qe dtok dmg + | n == nucsT -> DB nucT qe dtok dmg + | otherwise -> DB nucA (Q 0) dtok dmg 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 + !q = case b_qual `V.unsafeIndex` 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 + !dmg = if i+i > max_seq then i-max_seq else i - get_seq' :: Int -> Mat44D -> DamagedBase - get_seq' i = case b_seq V.! i of -- nucleotide - n | n == nucsA -> DB nucA qe nucsA - | n == nucsC -> DB nucC qe nucsC - | n == nucsG -> DB nucG qe nucsG - | n == nucsT -> DB nucT qe nucsT - | otherwise -> DB nucA (Q 0) n + get_seq' :: Int -> DamagedBase + get_seq' i = case b_seq `V.unsafeIndex` i of -- nucleotide + n | n == nucsA -> DB nucA qe dtok dmg nucsA + | n == nucsC -> DB nucC qe dtok dmg nucsC + | n == nucsG -> DB nucG qe dtok dmg nucsG + | n == nucsT -> DB nucT qe dtok dmg nucsT + | otherwise -> DB nucA (Q 0) dtok dmg n 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 + !q = case b_qual `V.unsafeIndex` 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 + !dmg = if i+i > max_seq then i-max_seq else i -- 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 -> [MdOp] -> [Mat44D] -> PrimChunks - firstBase !_ !_ !_ _ [ ] = EndOfRead - firstBase !pos !is !ic mds mms@(m:ms) + firstBase :: Int -> Int -> Int -> [MdOp] -> PrimChunks + firstBase !pos !is !ic mds | is >= max_seq || ic >= max_cig = EndOfRead - | otherwise = case b_cigar V.! ic of - Ins :* cl -> firstBase pos (cl+is) (ic+1) mds mms - SMa :* cl -> firstBase pos (cl+is) (ic+1) mds mms - Del :* cl -> firstBase (pos+cl) is (ic+1) (drop_del cl mds) mms - Nop :* cl -> firstBase (pos+cl) is (ic+1) mds mms - HMa :* _ -> firstBase pos is (ic+1) mds mms - Pad :* _ -> firstBase pos is (ic+1) mds mms - Mat :* 0 -> firstBase pos is (ic+1) mds mms - Mat :* _ -> Seek pos $ nextBase 0 pos is ic 0 mds m ms + | otherwise = case b_cigar `V.unsafeIndex` ic of + Ins :* cl -> firstBase pos (cl+is) (ic+1) mds + SMa :* cl -> firstBase pos (cl+is) (ic+1) mds + Del :* cl -> firstBase (pos+cl) is (ic+1) (drop_del cl mds) + Nop :* cl -> firstBase (pos+cl) is (ic+1) mds + HMa :* _ -> firstBase pos is (ic+1) mds + Pad :* _ -> firstBase pos is (ic+1) mds + Mat :* 0 -> firstBase pos is (ic+1) mds + Mat :* _ -> Seek pos $ nextBase 0 pos is ic 0 mds where -- We have to treat (MdNum 0), because samtools actually -- generates(!) it all over the place and if not handled as a @@ -200,18 +190,17 @@ -- I don't think we can ever get (MdDel []), but then again, who -- knows what crazy shit samtools decides to generate. There is -- little harm in special-casing it. - nextBase :: Int -> Int -> Int -> Int -> Int -> [MdOp] -> Mat44D -> [Mat44D] -> PrimBase - nextBase !wt !pos !is !ic !io mds m ms = case mds of - MdNum 0 : mds' -> nextBase wt pos is ic io mds' m ms - MdDel [] : mds' -> nextBase wt pos is ic io mds' m ms - MdNum 1 : mds' -> nextBase' (get_seq' is m) mds' - MdNum n : mds' -> nextBase' (get_seq' is m) (MdNum (n-1) : mds') - MdRep ref : mds' -> nextBase' (get_seq is ref m) mds' - MdDel _ : _ -> nextBase' (get_seq is nucsN m) mds - [ ] -> nextBase' (get_seq is nucsN m) [ ] + nextBase :: Int -> Int -> Int -> Int -> Int -> [MdOp] -> PrimBase + nextBase !wt !pos !is !ic !io mds = case mds of + MdNum 0 : mds' -> nextBase wt pos is ic io mds' + MdDel [] : mds' -> nextBase wt pos is ic io mds' + MdNum 1 : mds' -> nextBase' (get_seq' is ) mds' + MdNum n : mds' -> nextBase' (get_seq' is ) (MdNum (n-1) : mds') + MdRep ref : mds' -> nextBase' (get_seq is ref ) mds' + MdDel _ : _ -> nextBase' (get_seq is nucsN) mds + [ ] -> nextBase' (get_seq is nucsN) [ ] where - nextBase' ref mds' = Base wt ref b_mapq (isReversed b) - $ nextIndel [] [] (pos+1) (is+1) ic (io+1) mds' ms + nextBase' ref mds' = Base wt ref b_mapq $ nextIndel [] [] (pos+1) (is+1) ic (io+1) mds' -- 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 @@ -220,25 +209,24 @@ -- 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]] -> [Nucleotides] -> Int -> Int -> Int -> Int -> [MdOp] -> [Mat44D] -> PrimChunks - nextIndel _ _ !_ !_ !_ !_ _ [ ] = EndOfRead - nextIndel ins del !pos !is !ic !io mds mms@(m:ms) + nextIndel :: [[DamagedBase]] -> [Nucleotides] -> Int -> Int -> Int -> Int -> [MdOp] -> PrimChunks + nextIndel ins del !pos !is !ic !io mds | 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 mds (drop cl mms) - SMa :* cl -> nextIndel ins del pos (cl+is) (ic+1) 0 mds (drop cl mms) - Del :* cl -> nextIndel ins (del++dsq) (pos+cl) is (ic+1) 0 mds' mms + | otherwise = case b_cigar `V.unsafeIndex` ic of + Ins :* cl -> nextIndel (isq cl) del pos (cl+is) (ic+1) 0 mds + SMa :* cl -> nextIndel ins del pos (cl+is) (ic+1) 0 mds + Del :* cl -> nextIndel ins (del++dsq) (pos+cl) is (ic+1) 0 mds' where (dsq,mds') = split_del cl mds - Pad :* _ -> nextIndel ins del pos is (ic+1) 0 mds mms - HMa :* _ -> nextIndel ins del pos is (ic+1) 0 mds mms - Nop :* cl -> firstBase (pos+cl) is (ic+1) mds mms -- ends up generating a 'Seek' - Mat :* cl | io == cl -> nextIndel ins del pos is (ic+1) 0 mds mms - | otherwise -> indel del out $ nextBase (length del) pos is ic io mds m ms -- ends up generating a 'Base' + Pad :* _ -> nextIndel ins del pos is (ic+1) 0 mds + HMa :* _ -> nextIndel ins del pos is (ic+1) 0 mds + Nop :* cl -> firstBase (pos+cl) is (ic+1) mds -- ends up generating a 'Seek' + Mat :* cl | io == cl -> nextIndel ins del pos is (ic+1) 0 mds + | otherwise -> indel del out $ nextBase (length del) pos is ic io mds -- ends up generating a 'Base' where indel d o k = rlist o `seq` Indel d o k out = concat $ reverse ins - isq cl = zipWith ($) [ get_seq i gap | i <- [is..is+cl-1] ] (take cl mms) : ins - rlist [] = () + isq cl = [ get_seq i gap | i <- [is..is+cl-1] ] : ins + rlist [ ] = () rlist (a:as) = a `seq` rlist as -- We have to treat (MdNum 0), because samtools actually @@ -259,7 +247,7 @@ , reads_mapq0 :: {-# UNPACK #-} !Int -- number of (non-)contributing reads with MAPQ==0 , sum_mapq :: {-# UNPACK #-} !Int -- sum of map qualities of contributing reads , sum_mapq_squared :: {-# UNPACK #-} !Int } -- sum of squared map qualities of contributing reads - deriving (Show, Eq) + deriving (Show, Eq, Generic) instance Monoid CallStats where mempty = CallStats { read_depth = 0 @@ -290,9 +278,8 @@ newtype V_Nuc = V_Nuc (U.Vector Nucleotide) deriving (Eq, Ord, Show) newtype V_Nucs = V_Nucs (U.Vector Nucleotides) deriving (Eq, Ord, Show) -data IndelVariant = IndelVariant { deleted_bases :: {-# UNPACK #-} !V_Nucs - , inserted_bases :: {-# UNPACK #-} !V_Nuc } - deriving (Eq, Ord, Show) +data IndelVariant = IndelVariant { deleted_bases :: !V_Nucs, inserted_bases :: !V_Nuc } + deriving (Eq, Ord, Show, Generic) -- | Map quality and a list of encountered bases, with damage @@ -318,8 +305,31 @@ , p_indel_pile :: b } deriving Show -type Pile = Pile' (BasePile, BasePile) IndelPile +-- | Raw pile. Bases and indels are piled separately on forward and +-- backward strands. +type Pile = Pile' (BasePile, BasePile) (IndelPile, IndelPile) +-- | Simple single population model. 'prob_div' is the fraction of +-- homozygous divergent sites, 'prob_het' is the fraction of +-- heterozygous variant sites among sites that are not homozygous +-- divergent. +data SinglePop = SinglePop { prob_div :: !Double, prob_het :: !Double } + +-- | Computes posterior genotype probabilities from likelihoods under +-- the 'SinglePop' model. +{-# INLINE single_pop_posterior #-} +single_pop_posterior :: ( U.Unbox a, Ord a, Floating a ) + => SinglePop -> Int -> U.Vector (Prob' a) -> U.Vector (Prob' a) +single_pop_posterior SinglePop{..} refix lks = U.map (/ U.sum v) v + where + priors = U.replicate (U.length lks) + ((1/3) * prob_het * (1-prob_div)) -- hets + U.// [ (refix, (1-prob_het) * (1-prob_div)) ] -- ref + U.// [ (i, (1/3) * prob_div ) | i <- hixes, i /= refix ] -- homs + + v = U.zipWith (\l p -> l * toProb (realToFrac p)) lks priors + hixes = takeWhile (< U.length lks) $ scanl (+) 0 [2..] + -- | 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, @@ -330,10 +340,11 @@ -- Processing stops when the first read with invalid 'br_rname' is -- encountered or a t end of file. -pileup :: Monad m => Enumeratee [PosPrimChunks] [Pile] m a -pileup = eneeCheckIfDonePass (icont . runPileM pileup' finish (Refseq 0) 0 [] Empty) +{-# INLINE pileup #-} +pileup :: Enumeratee [PosPrimChunks] [Pile] IO b +pileup = eneeCheckIfDonePass (icont . runPileM pileup' finish (Refseq 0) 0 ([],[]) (Empty,Empty)) where - finish () _r _p [] Empty out inp = idone (liftI out) inp + finish () _r _p ([],[]) (Empty,Empty) out inp = idone (liftI out) inp finish () _ _ _ _ _ _ = error "logic error: leftovers after pileup" @@ -358,11 +369,11 @@ -- 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 - (Stream [Pile] -> Iteratee [Pile] m r) -> -- output function - Stream [PosPrimChunks] -> -- pending input +type PileF m r = Refseq -> Int -> -- current position + ( [PrimBase], [PrimBase] ) -> -- active queues + ( Heap, Heap ) -> -- waiting queues + (Stream [Pile] -> Iteratee [Pile] m r) -> -- output function + Stream [PosPrimChunks] -> -- pending input Iteratee [PosPrimChunks] m (Iteratee [Pile] m r) instance Functor (PileM m) where @@ -393,109 +404,57 @@ upd_pos :: (Int -> Int) -> PileM m () upd_pos f = PileM $ \k r p -> k () r $! f p -{-# INLINE set_pos #-} -set_pos :: (Refseq, Int) -> PileM m () -set_pos (!r,!p) = PileM $ \k _ _ -> k () r p - -{-# INLINE get_active #-} -get_active :: PileM m [PrimBase] -get_active = PileM $ \k r p a -> k a r p a - -{-# INLINE upd_active #-} -upd_active :: ([PrimBase] -> [PrimBase]) -> PileM m () -upd_active f = PileM $ \k r p a -> k () r p $! f a - -{-# INLINE add_active #-} -add_active :: PrimBase -> PileM m () -add_active !pb = PileM $ \k r p a -> k () r p (pb:a) - -{-# INLINE clr_active #-} -clr_active :: PileM m [PrimBase] -clr_active = PileM $ \k r p a -> k a r p [] - -{-# INLINE ins_waiting #-} -ins_waiting :: Int -> PrimBase -> PileM m () -ins_waiting !q !v = PileM $ \ k r p a w -> k () r p a $! Node q v Empty Empty `union` w - -{-# INLINE get_waiting #-} -get_waiting :: PileM m Heap -get_waiting = PileM $ \k r p a w -> k w r p a w - -{-# INLINE set_waiting #-} -set_waiting :: Heap -> PileM m () -set_waiting !w = PileM $ \k r p a _ -> k () r p a w - -- | Sends one piece of output downstream. You are not expected to --- understand how this works, but at last it doesn't leak memory. -{-# INLINE yield #-} -yield :: Monad m => Pile -> PileM m () -yield x = PileM $ \ !kont !r !p !a !w !out !inp -> Iteratee $ \od oc -> - let loop = kont () r p a w +-- understand how this works, but inlining 'eneeCheckIfDone' plugged an +-- annoying memory leak. +{-# INLINE yieldPile #-} +yieldPile :: CallStats -> BasePile -> BasePile -> CallStats -> IndelPile -> IndelPile -> PileM m () +yieldPile x1 x2a x2b x3 x4a x4b = PileM $ \ !kont !r !p !a !w !out !inp -> Iteratee $ \od oc -> + let recurse = kont () r p a w onDone y s = od (idone y s) inp - onCont k Nothing = runIter (loop k inp) od oc - onCont k (Just e) = runIter (throwRecoverableErr e (loop k . (<>) inp)) od oc - in runIter (out (Chunk [x])) onDone onCont - --- | 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. -{-# INLINE peek #-} -peek :: PileM m (Maybe PosPrimChunks) -peek = PileM $ \k r p a w out inp -> case inp of - EOF _ -> k Nothing r p a w out inp - Chunk [ ] -> liftI $ runPileM peek k r p a w out - Chunk (b:_) -> k (Just b) r p a w 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. -{-# INLINE bump #-} -bump :: PileM m () -bump = PileM $ \k r p a w out inp -> case inp of - EOF _ -> k () r p a w out inp - Chunk [ ] -> liftI $ runPileM bump k r p a w out - Chunk (_:x) -> k () r p a w out (Chunk x) - - -{-# INLINE consume_active #-} -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 + onCont k Nothing = runIter (recurse k inp) od oc + onCont k (Just e) = runIter (throwRecoverableErr e (recurse k . (<>) inp)) od oc + pile = Pile r p x1 (x2a,x2b) x3 (x4a,x4b) + in runIter (out (Chunk [pile])) onDone onCont -- | The actual pileup algorithm. 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. -pileup' :: Monad m => PileM m () +pileup' :: PileM m () pileup' = PileM $ \ !k !refseq !pos !active !waiting !out !inp -> let recurse = runPileM pileup' k refseq pos active waiting out cont2 rs po = runPileM pileup'' k rs po active waiting out inp leave = k () refseq pos active waiting out inp - in case (active, getMinKey waiting, inp) of - ( _:_, _, _ ) -> cont2 refseq pos - ( [ ], Just nw, EOF _ ) -> cont2 refseq nw - ( [ ], Nothing, EOF _ ) -> leave - ( _, _, Chunk [ ] ) -> liftI recurse - ( [ ], Nothing, Chunk ((r,p,_):_) ) -> cont2 r p - ( [ ], Just nw, Chunk ((r,p,_):_) ) - | (refseq,nw) <= (r,p) -> cont2 refseq nw - | otherwise -> cont2 r p + in case (active, getMinKeysH waiting, inp) of + ( (_:_,_), _, _ ) -> cont2 refseq pos + ( (_,_:_), _, _ ) -> cont2 refseq pos + ( _, Just nw, EOF _ ) -> cont2 refseq nw + ( _, Nothing, EOF _ ) -> leave + ( _, _, Chunk [ ] ) -> liftI recurse + ( _, Nothing, Chunk ((r,p,_,_):_) ) -> cont2 r p + ( _, Just nw, Chunk ((r,p,_,_):_) ) + | (refseq,nw) <= (r,p) -> cont2 refseq nw + | otherwise -> cont2 r p + where + getMinKeysH :: (Heap, Heap) -> Maybe Int + getMinKeysH (a,b) = case (getMinKeyH a, getMinKeyH b) of + ( Nothing, Nothing ) -> Nothing + ( Just x, Nothing ) -> Just x + ( Nothing, Just y ) -> Just y + ( Just x, Just y ) -> Just (min x y) -pileup'' :: Monad m => PileM m () +pileup'' :: 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 - p'feed_input p'check_waiting - ((fin_bs, fin_bp), (fin_is, fin_ip)) <- p'scan_active + ((fin_bsL, fin_bpL), (fin_bsR, fin_bpR), (fin_isL, fin_ipL), (fin_isR, fin_ipR)) <- p'scan_active -- Output, but don't bother emitting empty piles. Note that a plain -- basecall still yields an entry in the 'IndelPile'. This is necessary, @@ -503,8 +462,9 @@ -- 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)) = null d && null i - unless (null fin_bp && all uninteresting fin_ip) . yield $ - Pile rs po fin_bs (partitionPairEithers fin_bp) fin_is fin_ip + unless (null fin_bpL && null fin_bpR && all uninteresting fin_ipL && all uninteresting fin_ipR) $ + yieldPile (fin_bsL <> fin_bsR) fin_bpL fin_bpR + (fin_isL <> fin_isR) fin_ipL fin_ipR -- Bump coordinate and loop. (Note that the bump to the next -- reference /sequence/ is done implicitly, because we will run out of @@ -514,77 +474,84 @@ -- | Feeds input as long as it starts at the current position p'feed_input :: PileM m () -p'feed_input = do - rs <- get_refseq - po <- get_pos +p'feed_input = PileM $ \kont rs po ac@(af,ar) wt@(wf,wr) out inp -> case inp of + Chunk [ ] -> liftI $ runPileM p'feed_input kont rs po ac wt out + Chunk ((rs', po', str, prim):bs) + | rs == rs' && po == po' -> + case prim of + Seek !p !pb -> let wf' = Node p pb Empty Empty `unionH` wf + wr' = Node p pb Empty Empty `unionH` wr + in runPileM p'feed_input kont rs po ac (if str then (wf,wr') else (wf',wr)) out (Chunk bs) - fix $ \loop -> peek >>= mapM_ (\(rs', po', prim) -> - when (rs == rs' && po == po') $ do - bump - case prim of Seek !p !pb -> ins_waiting p pb - Indel _ _ !pb -> add_active pb - EndOfRead -> return () - loop) + Indel _ _ !pb -> runPileM p'feed_input kont rs po (if str then (af,pb:ar) else (pb:af,ar)) wt out (Chunk bs) + EndOfRead -> runPileM p'feed_input kont rs po ac wt out (Chunk bs) + + _ -> kont () rs po ac wt out inp + -- | Checks /waiting/ queue. If there is anything waiting for the -- current position, moves it to /active/ queue. p'check_waiting :: PileM m () -p'check_waiting = do - po <- get_pos - fix $ \loop -> (viewMin <$> get_waiting) >>= mapM_ (\(!mk,!pb,w') -> - when (mk == po) $ do add_active pb - set_waiting w' - loop) +p'check_waiting = PileM $ \kont rs po (af0,ar0) (wf0,wr0) -> + let go1 af wf = case viewMinH wf of + Just (!mk, !pb, !wf') | mk == po -> go1 (pb:af) wf' + _ -> go2 af wf ar0 wr0 --- | Scans /active/ queue and makes a 'BasePile'. Also sees 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. -p'scan_active :: PileM m (( CallStats, [( Qual, Either DamagedBase DamagedBase )] ), - ( CallStats, [( Qual, ([Nucleotides], [DamagedBase]) )] )) -p'scan_active = - 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 add_active b' ; return ( bpile, ipile ) - Seek p' pb' -> do ins_waiting p' pb' ; return ( put' bpile, ipile ) - Indel del ins pb' -> do add_active pb' ; return ( put' bpile, put mq (del,ins) ipile ) - EndOfRead -> do return ( put' bpile, ipile ) + go2 af wf ar wr = case viewMinH wr of + Just (!mk, !pb, !wr') | mk == po -> go2 af wf (pb:ar) wr' + _ -> kont () rs po (af,ar) (wf,wr) + in go1 af0 wf0 -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) +-- | Separately scans the two /active/ queues and makes one 'BasePile' +-- from each. Also sees what's next in the 'PrimChunks': 'Indel's +-- contribute to two separate 'IndelPile's, 'Seek's are pushed back to +-- the /waiting/ queue, 'EndOfRead's are removed, and everything else is +-- added to two fresh /active/ queues. +p'scan_active :: PileM m (( CallStats, BasePile ), ( CallStats, BasePile ), + ( CallStats, IndelPile ), ( CallStats, IndelPile )) +p'scan_active = do + (bpf,ipf) <- PileM $ \kont rs pos (af,ar) (wf,wr) -> go (\r af' wf' -> kont r rs pos (af',ar) (wf',wr)) [] wf mempty mempty af + (bpr,ipr) <- PileM $ \kont rs pos (af,ar) (wf,wr) -> go (\r ar' wr' -> kont r rs pos (af,ar') (wf,wr')) [] wr mempty mempty ar + return (bpf,bpr,ipf,ipr) + where + go k !ac !wt !bpile !ipile [ ] = k (bpile, ipile) (reverse ac) wt + go k !ac !wt !bpile !ipile (Base nwt qs mq pchunks : bs) = + case pchunks of + _ | nwt > 0 -> b' `seq` go k (b':ac) wt bpile ipile bs + Seek p' pb' -> go k ac (ins p' pb' wt) (z bpile) ipile bs + Indel nd ni pb' -> go k (pb':ac) wt (z bpile) (y ipile) bs where y = put mq (nd,ni) + EndOfRead -> go k ac wt (z bpile) ipile bs + where + b' = Base (nwt-1) qs mq pchunks + z = put mq qs + ins q v w = Node q v Empty Empty `unionH` w + + 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 ) + + -- | 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 +data Heap = Empty | Node {-# UNPACK #-} !Int 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 +unionH :: Heap -> Heap -> Heap +Empty `unionH` t2 = t2 +t1 `unionH` Empty = t1 +t1@(Node k1 x1 l1 r1) `unionH` t2@(Node k2 x2 l2 r2) + | k1 <= k2 = Node k1 x1 (t2 `unionH` r1) l1 + | otherwise = Node k2 x2 (t1 `unionH` r2) l2 -getMinKey :: Heap -> Maybe Int -getMinKey Empty = Nothing -getMinKey (Node x _ _ _) = Just x +getMinKeyH :: Heap -> Maybe Int +getMinKeyH Empty = Nothing +getMinKeyH (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) +viewMinH :: Heap -> Maybe (Int, PrimBase, Heap) +viewMinH Empty = Nothing +viewMinH (Node k v l r) = Just (k, v, l `unionH` r) diff --git a/src/Bio/Bam/Reader.hs b/src/Bio/Bam/Reader.hs --- a/src/Bio/Bam/Reader.hs +++ b/src/Bio/Bam/Reader.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings, FlexibleContexts #-} module Bio.Bam.Reader ( Block(..), decompressBgzfBlocks, @@ -33,21 +32,15 @@ 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 Bio.Prelude -import Control.Applicative -import Control.Arrow ( (&&&) ) -import Control.Monad import Data.Attoparsec.ByteString ( anyWord8 ) -import Data.Char ( digitToInt ) 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 @@ -67,11 +60,10 @@ -- - 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 +type BamrawEnumeratee m b = Enumeratee' BamMeta Bytes [BamRaw] m b +type BamEnumeratee m b = Enumeratee' BamMeta Bytes [BamRec] m b -isBamOrSam :: MonadIO m => Iteratee ByteString m (BamEnumeratee m a) +isBamOrSam :: MonadIO m => Iteratee Bytes m (BamEnumeratee m a) isBamOrSam = maybe decodeSam wrap `liftM` isBam where wrap enee it' = enee (\hdr -> mapStream unpackBam (it' hdr)) >>= lift . run @@ -94,14 +86,14 @@ -- 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 :: Monad m => (BamMeta -> Iteratee [BamRec] m a) -> Iteratee Bytes 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 :: Monad m => Refs -> Enumeratee [Bytes] [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' @@ -117,10 +109,10 @@ -- 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' :: Monad m => Refs -> Enumeratee Bytes [BamRec] m a decodeSam' refs inner = joinI $ enumLinesBS $ decodeSamLoop refs inner -parseSamRec :: (ByteString -> Refseq) -> P.Parser BamRec +parseSamRec :: (Bytes -> Refseq) -> P.Parser BamRec parseSamRec ref = mkBamRec <$> word <*> num <*> (ref <$> word) <*> (subtract 1 <$> num) <*> (Q <$> num') <*> (VS.fromList <$> cigar) <*> rnext <*> (subtract 1 <$> num) @@ -173,7 +165,7 @@ -- 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)) + => Iteratee Bytes m (Maybe (BamrawEnumeratee m a)) isBam = firstOf [ isEmptyBam, isPlainBam, isBgzfBam, isGzipBam ] where firstOf [] = return Nothing diff --git a/src/Bio/Bam/Rec.hs b/src/Bio/Bam/Rec.hs --- a/src/Bio/Bam/Rec.hs +++ b/src/Bio/Bam/Rec.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE RecordWildCards, BangPatterns, TypeFamilies, FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} -- | Parsers and Printers for BAM and SAM. We employ an @Iteratee@ -- interface, and we strive to support everything possible in BAM. So @@ -13,10 +12,6 @@ -- 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, @@ -51,29 +46,23 @@ isDuplicate, isTrimmed, isMerged, + isVestigial, type_mask, progressBam, Word32 ) where -import Bio.Base import Bio.Bam.Header import Bio.Iteratee +import Bio.Prelude -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.C.Types ( CInt(..), CSize(..) ) import Foreign.ForeignPtr import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Ptr ( Ptr, plusPtr ) 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 @@ -175,29 +164,53 @@ type instance V.Mutable Vector_Nucs_half = MVector_Nucs_half instance V.Vector Vector_Nucs_half Nucleotides where + {-# INLINE basicUnsafeFreeze #-} basicUnsafeFreeze (MVector_Nucs_half o l fp) = return $ Vector_Nucs_half o l fp + {-# INLINE basicUnsafeThaw #-} basicUnsafeThaw (Vector_Nucs_half o l fp) = return $ MVector_Nucs_half o l fp + {-# INLINE basicLength #-} basicLength (Vector_Nucs_half _ l _) = l + {-# INLINE basicUnsafeSlice #-} basicUnsafeSlice s l (Vector_Nucs_half o _ fp) = Vector_Nucs_half (o + s) l fp + {-# INLINE basicUnsafeIndexM #-} 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 + {-# INLINE basicLength #-} basicLength (MVector_Nucs_half _ l _) = l + {-# INLINE basicUnsafeSlice #-} basicUnsafeSlice s l (MVector_Nucs_half o _ fp) = MVector_Nucs_half (o + s) l fp + {-# INLINE basicOverlaps #-} basicOverlaps (MVector_Nucs_half _ _ fp1) (MVector_Nucs_half _ _ fp2) = fp1 == fp2 + {-# INLINE basicUnsafeNew #-} basicUnsafeNew l = unsafePrimToPrim $ MVector_Nucs_half 0 l <$> mallocForeignPtrBytes ((l+1) `shiftR` 1) + {-# INLINE basicInitialize #-} + basicInitialize v@(MVector_Nucs_half o l fp) + + | even o = do unsafePrimToPrim $ withForeignPtr fp $ \p -> + memset (plusPtr p (o `shiftR` 1)) 0 (fromIntegral $ l `shiftR` 1) + when (odd l) $ VM.basicUnsafeWrite v (l-1) (Ns 0) + + | otherwise = do when (odd o) $ VM.basicUnsafeWrite v 0 (Ns 0) + unsafePrimToPrim $ withForeignPtr fp $ \p -> + memset (plusPtr p ((o+1) `shiftR` 1)) 0 (fromIntegral $ (l-1) `shiftR` 1) + when (even l) $ VM.basicUnsafeWrite v (l-1) (Ns 0) + + + {-# INLINE basicUnsafeRead #-} 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) + {-# INLINE basicUnsafeWrite #-} basicUnsafeWrite (MVector_Nucs_half o _ fp) i (Ns x) = unsafePrimToPrim $ withForeignPtr fp $ \p -> do y <- peekByteOff p ((o+i) `shiftR` 1) @@ -205,16 +218,19 @@ | otherwise = x .|. y .&. 0xF0 pokeByteOff p ((o+i) `shiftR` 1) y' +foreign import ccall unsafe "string.h memset" memset + :: Ptr Word8 -> CInt -> CSize -> IO () + 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 } + , raw_data :: {-# UNPACK #-} !Bytes } -- | Smart constructor. Makes sure we got a at least a full record. {-# INLINE bamRaw #-} -bamRaw :: FileOffset -> S.ByteString -> BamRaw +bamRaw :: FileOffset -> Bytes -> 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 @@ -254,7 +270,7 @@ l_seq = getInt32 16 l_cigar = getInt16 12 - getInt8 :: (Num a, Bits a) => Int -> a + getInt8 :: Num a => Int -> a getInt8 o = fromIntegral (B.unsafeIndex (raw_data br) o) getInt16 :: (Num a, Bits a) => Int -> a @@ -292,12 +308,12 @@ 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 +data Ext = Int Int | Float Float | Text Bytes | Bin Bytes | Char Word8 | IntArr (U.Vector Int) | FloatArr (U.Vector Float) deriving (Show, Eq, Ord) {-# INLINE unpackExtensions #-} -unpackExtensions :: ByteString -> Extensions +unpackExtensions :: Bytes -> Extensions unpackExtensions = go where go s | S.length s < 4 = [] @@ -345,7 +361,7 @@ isPaired, isProperlyPaired, isUnmapped, isMateUnmapped, isReversed, isMateReversed, isFirstMate, isSecondMate, isAuxillary, isFailsQC, - isDuplicate, isTrimmed, isMerged :: BamRec -> Bool + isDuplicate, isTrimmed, isMerged, isVestigial :: BamRec -> Bool isPaired = flip testBit 0 . b_flag isProperlyPaired = flip testBit 1 . b_flag @@ -361,6 +377,7 @@ isTrimmed = flip testBit 0 . extAsInt 0 "FF" isMerged = flip testBit 1 . extAsInt 0 "FF" +isVestigial = flip testBit 2 . extAsInt 0 "FF" type_mask :: Int type_mask = flagFirstMate .|. flagSecondMate .|. flagPaired @@ -368,7 +385,7 @@ 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 :: BamKey -> BamRec -> Bytes extAsString nm br = case lookup nm (b_exts br) of Just (Char c) -> B.singleton c Just (Text s) -> s @@ -381,6 +398,6 @@ s' = if c `S.elem` s then s else c `S.cons` s -- | A simple progress indicator that prints sequence id and position. -progressBam :: MonadIO m => String -> (String -> IO ()) -> Refs -> Enumeratee [BamRaw] [BamRaw] m a +progressBam :: MonadIO m => String -> Refs -> Int -> (String -> IO ()) -> Enumeratee [BamRaw] [BamRaw] m a progressBam = progressPos (\br -> case unpackBam br of b -> (b_rname b, b_pos b)) diff --git a/src/Bio/Bam/Regions.hs b/src/Bio/Bam/Regions.hs --- a/src/Bio/Bam/Regions.hs +++ b/src/Bio/Bam/Regions.hs @@ -3,6 +3,7 @@ import Bio.Bam.Header ( Refseq(..) ) import Data.List ( foldl' ) import qualified Data.IntMap as IM +import Prelude data Region = Region { refseq :: !Refseq, start :: !Int, end :: !Int } deriving (Eq, Ord, Show) diff --git a/src/Bio/Bam/Rmdup.hs b/src/Bio/Bam/Rmdup.hs --- a/src/Bio/Bam/Rmdup.hs +++ b/src/Bio/Bam/Rmdup.hs @@ -1,20 +1,14 @@ -{-# 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 + check_sort, normalizeTo, wrapTo, + ECig(..), toECig, setMD, toCigar ) 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 Bio.Prelude hiding ( left, right ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as T @@ -506,12 +500,15 @@ -- | 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 } +-- Returns @Left x@ if the coordinate decreased so the result is out of +-- order now, @Right x@ if the coordinate is unchanged. +normalizeTo :: Seqid -> Int -> BamRec -> Either BamRec BamRec +normalizeTo nm l b = lr $ 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 + lr = if b_pos b >= l then Left else Right 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 @@ -524,15 +521,17 @@ -- | 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] +-- suitably masked. A piece with changed coordinate that is now out of +-- order is returned as @Left x@, if the order is fine, it is returned +-- as @Right x@. +wrapTo :: Int -> BamRec -> [Either BamRec BamRec] +wrapTo l b = if overhangs then do_wrap else [Right 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 ] + (left,right) -> [ Right $ b { b_cigar = toCigar left } `setMD` left + , 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 diff --git a/src/Bio/Bam/Trim.hs b/src/Bio/Bam/Trim.hs --- a/src/Bio/Bam/Trim.hs +++ b/src/Bio/Bam/Trim.hs @@ -1,15 +1,22 @@ -{-# 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 +module Bio.Bam.Trim where +import Bio.Bam.Header import Bio.Bam.Rec -import Bio.Base +import Bio.Bam.Rmdup ( ECig(..), setMD, toECig ) +import Bio.Iteratee +import Bio.Prelude -import Data.Bits ( testBit ) -import Data.List ( inits ) -import qualified Data.Vector.Generic as V +import qualified Data.ByteString as B +import qualified Data.Vector.Fusion.Bundle.Size as S +import qualified Data.Vector.Fusion.Bundle.Monadic as S +import qualified Data.Vector.Fusion.Stream.Monadic as SS +import qualified Data.Vector.Fusion.Util as SS +import qualified Data.Vector.Hybrid.Internal as Hybrid +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Unboxed as U -- | Trims from the 3' end of a sequence. -- @trim_3\' p b@ trims the 3' end of the sequence in @b@ at the @@ -21,9 +28,6 @@ -- 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 @@ -44,19 +48,72 @@ | 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) + c = modMd (takeECig (V.length (b_seq b) - l)) b + in c { b_seq = V.take (V.length (b_seq c) - l) (b_seq c) + , b_qual = V.take (V.length (b_qual c) - l) (b_qual c) , b_cigar = cigar' - , b_exts = deleteE "MD" (b_exts b) } + , b_exts = map (\(k,e) -> case e of + Text t | k `elem` trim_set + -> (k, Text (B.take (B.length t - l) t)) + _ -> (k,e) + ) (b_exts c) } 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) + c = modMd (dropECig l) b + in c { b_seq = V.drop l (b_seq c) + , b_qual = V.drop l (b_qual c) + , b_pos = b_pos c + off , b_cigar = cigar' - , b_exts = deleteE "MD" (b_exts b) - , b_pos = b_pos b + off - } + , b_exts = map (\(k,e) -> case e of + Text t | k `elem` trim_set + -> (k, Text (B.drop l t)) + _ -> (k,e) + ) (b_exts c) } + trim_set = ["BQ","CQ","CS","E2","OQ","U2"] + + modMd :: (ECig -> ECig) -> BamRec -> BamRec + modMd f br = maybe br (setMD br . f . toECig (b_cigar br)) (getMd br) + + endOf :: ECig -> ECig + endOf WithMD = WithMD + endOf WithoutMD = WithoutMD + endOf (Mat' _ es) = endOf es + endOf (Ins' _ es) = endOf es + endOf (SMa' _ es) = endOf es + endOf (Rep' _ es) = endOf es + endOf (Del' _ es) = endOf es + endOf (Nop' _ es) = endOf es + endOf (HMa' _ es) = endOf es + endOf (Pad' _ es) = endOf es + + takeECig :: Int -> ECig -> ECig + takeECig 0 es = endOf es + takeECig _ WithMD = WithMD + takeECig _ WithoutMD = WithoutMD + takeECig n (Mat' m es) = Mat' n $ if n > m then takeECig (n-m) es else WithMD + takeECig n (Ins' m es) = Ins' n $ if n > m then takeECig (n-m) es else WithMD + takeECig n (SMa' m es) = SMa' n $ if n > m then takeECig (n-m) es else WithMD + takeECig n (Rep' ns es) = Rep' ns $ takeECig (n-1) es + takeECig n (Del' ns es) = Del' ns $ takeECig n es + takeECig n (Nop' m es) = Nop' m $ takeECig n es + takeECig n (HMa' m es) = HMa' m $ takeECig n es + takeECig n (Pad' m es) = Pad' m $ takeECig n es + + dropECig :: Int -> ECig -> ECig + dropECig 0 es = es + dropECig _ WithMD = WithMD + dropECig _ WithoutMD = WithoutMD + dropECig n (Mat' m es) = if n > m then dropECig (n-m) es else Mat' n WithMD + dropECig n (Ins' m es) = if n > m then dropECig (n-m) es else Ins' n WithMD + dropECig n (SMa' m es) = if n > m then dropECig (n-m) es else SMa' n WithMD + dropECig n (Rep' _ es) = dropECig (n-1) es + dropECig n (Del' _ es) = dropECig n es + dropECig n (Nop' _ es) = dropECig n es + dropECig n (HMa' _ es) = dropECig n es + dropECig n (Pad' _ es) = dropECig n es + + 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 @@ -91,16 +148,190 @@ -- | Overlap-merging of read pairs. We shall compute the likelihood --- for every possible overlap, the select the most likely one (unless it +-- for every possible overlap, then select the most likely one (unless it -- looks completely random), compute a quality from the second best --- merge, then merge and clamp the quality accordingly. Output should --- be the pair *and* the merged representation, suitably flagged. --- We might try looking for chimaera after completing the merge, if only --- we knew which ones to expect. +-- merge, then merge and clamp the quality accordingly. +-- (We could try looking for chimaera after completing the merge, if +-- only we knew which ones to expect?) -- --- Likelihoods are straight forward; for adapters we have to assume a --- realistic error rate (Q30 sounds good). To make it robust, we reduce --- the adapters to their invariant prefix (about 20nt long), and try to --- trim all adapters known to us (should be only two or three). +-- Two reads go in, with two adapter lists. We return 'Nothing' if all +-- merges looked mostly random. Else we return the two original reads, +-- flagged as 'eflagVestigial' *and* the merged version, flagged as +-- 'eflagMerged' and optionally 'eflagTrimmed'. All reads contain the +-- computed qualities (in YM and YN), which we also return. -- --- Single-end reads are treated as pairs with an empty second read. +-- The merging automatically limits quality scores some of the time. We +-- additionally impose a hard limit of 63 to avoid difficulties +-- representing the result, and even that is ridiculous. Sane people +-- would further limit the returned quality! (In practice, map quality +-- later imposes a limit anyway, so no worries...) + +merge_overlap :: BamRec -> [ U.Vector Nucleotides ] + -> BamRec -> [ U.Vector Nucleotides ] + -> Maybe ( BamRec, BamRec, BamRec, Int, Int ) +merge_overlap r1 ads1 r2 ads2 = + case possible_merges of + [ ] -> Nothing + (score, len) : [ ] -> result len score plain_score + (score1, len) : (score2, _) : _ -> result len score1 score2 + where + rq1 = Hybrid.V (b_seq r1) (b_qual r1) + rq2 = Hybrid.V (b_seq r2) (b_qual r2) + + -- the "merge" score if there is no overlap + plain_score = 6 * fromIntegral (V.length rq1 + V.length rq2) + + possible_merges = sortBy (\a b -> fst a `compare` fst b) + [ ( merge_score ads1 ads2 rq1 rq2 l, l ) + | l <- [0 .. V.length rq1 + V.length rq2 - 1] ] + + flag_vestigial br = br { b_exts = updateE "FF" (Int $ extAsInt 0 "FF" br .|. eflagVestigial) $ b_exts br } + store_quals s1 s2 br = br { b_exts = updateE "YM" (Int $ s2 - s1) $ + updateE "YN" (Int $ plain_score - s1) $ b_exts br } + + result l s1 s2 = Just ( store_quals s1 s2 $ flag_vestigial r1 + , store_quals s1 s2 $ flag_vestigial r2 + , store_quals s1 s2 $ merged_read l (fromIntegral . min 63 $ s2-s1) + , s2 - s1, plain_score - s1 ) + + merged_read l qmax + | V.length merged_seq /= l = error $ "Logic error in merged_read: " ++ show (V.length merged_seq, l) + | otherwise = nullBamRec { + b_qname = b_qname r1, + b_flag = flagUnmapped .|. complement pair_flags .&. b_flag r1, + b_seq = V.unstream $ flip S.fromStream (S.Exact $ V.length merged_seq) $ SS.map fst $ S.elements $ V.stream merged_seq, + b_qual = V.unstream $ flip S.fromStream (S.Exact $ V.length merged_seq) $ SS.map snd $ S.elements $ V.stream merged_seq, + b_exts = let ff = if l < V.length (b_seq r1) then eflagTrimmed else 0 + in updateE "FF" (Int $ extAsInt 0 "FF" r1 .|. eflagMerged .|. ff) $ b_exts r1 } + where + merged_seq = V.concat + [ V.take (l - V.length rq2) rq1 + , merge_seqs qmax (V.take l $ V.drop (l - V.length rq2) rq1) + (V.reverse $ V.take l $ V.drop (l - V.length rq1) rq2) + , V.reverse $ V.take (l - V.length rq1) rq2 ] + + pair_flags = flagPaired.|.flagProperlyPaired.|.flagMateUnmapped.|.flagMateReversed.|.flagFirstMate.|.flagSecondMate + + merge_seqs qmax = V.zipWith $ \(!n1,!(Q q1)) (!n2,!(Q q2)) -> + if n1 == n2 then (n1, Q $ min qmax (q1 + q2)) + else if q1 > q2 then (n1, Q $ q1 - q2 ) + else (n2, Q $ q2 - q1 ) + + +-- | Trimming for a single read: we need one adapter only (the one coming +-- /after/ the read), here provided as a list of options, and then we +-- merge with an empty second read. Results in up to two reads (the +-- original, possibly flagged, and the trimmed one, definitely flagged, +-- and two qualities). +trim_adapter :: BamRec -> [ U.Vector Nucleotides ] -> Maybe ( BamRec, BamRec, Int, Int ) +trim_adapter r1 ads1 = + case possible_trims of + [ ] -> Nothing + (score, len) : [ ] -> result len score plain_score + (score1, len) : (score2, _) : _ -> result len score1 score2 + where + rq1 = Hybrid.V (b_seq r1) (b_qual r1) + + -- the "merge" score if there is no trimming + plain_score = 6 * fromIntegral (V.length rq1) + + possible_trims = sortBy (\a b -> fst a `compare` fst b) + [ ( merge_score ads1 [V.empty] rq1 V.empty l, l ) + | l <- [0 .. V.length rq1 - 1] ] + + flag_vestigial br = br { b_exts = updateE "FF" (Int $ extAsInt 0 "FF" br .|. eflagVestigial) $ b_exts br } + store_quals s1 s2 br = br { b_exts = updateE "YM" (Int $ s2 - s1) $ + updateE "YN" (Int $ plain_score - s1) $ b_exts br } + + result l s1 s2 = Just ( store_quals s1 s2 $ flag_vestigial r1 + , store_quals s1 s2 $ trimmed_read l + , s2 - s1, plain_score - s1 ) + + trimmed_read l = nullBamRec { + b_qname = b_qname r1, + b_flag = flagUnmapped .|. b_flag r1, + b_seq = V.take l $ b_seq r1, + b_qual = V.take l $ b_qual r1, + b_exts = updateE "FF" (Int $ extAsInt 0 "FF" r1 .|. eflagTrimmed) $ b_exts r1 } + + +-- | For merging, we don't need the complete adapters (length around 70!), +-- only a sufficient prefix. Taking only the more-or-less constant +-- part (length around 30), there aren't all that many different +-- adapters in the world. To deal with pretty much every library, we +-- only need the following forward adapters, which will be the default +-- (defined here in the direction they would be sequenced in): Genomic +-- R2, Multiplex R2, Fraft P7. + +default_fwd_adapters :: [ U.Vector Nucleotides ] +default_fwd_adapters = map (U.fromList. map toNucleotides) + [ {- Genomic R2 -} "AGATCGGAAGAGCGGTTCAGCAGGAATGCCGAGACCG" + , {- Multiplex R2 -} "AGATCGGAAGAGCACACGTCTGAACTCCAGTCAC" + , {- Graft P7 -} "AGATCGGAAGAGCTCGTATGCCGTCTTCTGCTTG" ] + +-- | Like 'default_rev_adapters', these are the few adapters needed for +-- the reverse read (defined in the direction they would be sequenced in +-- as part of the second read): Genomic R1, CL 72. + +default_rev_adapters :: [ U.Vector Nucleotides ] +default_rev_adapters = map (U.fromList. map toNucleotides) + [ {- Genomic_R1 -} "AGATCGGAAGAGCGTCGTGTAGGGAAAGAGTGT" + , {- CL72 -} "GGAAGAGCGTCGTGTAGGGAAAGAGTGT" ] + +-- We need to compute the likelihood of a read pair given an assumed +-- insert length. The likelihood of the first read is the likelihood of +-- a match with the adapter where it overlaps the 3' adapter, elsewhere +-- it's 1/4 per position. The likelihood of the second read is the +-- likelihood of a match with the adapter where it overlaps the adapter, +-- the likehood of a read-read match where it overlaps read one, 1/4 per +-- position elsewhere. (Yes, this ignores base composition. It doesn't +-- matter enough.) + +merge_score + :: ( V.Vector v Nucleotides, V.Vector u (Nucleotides, Qual) ) + => [ v Nucleotides ] -- 3' adapters as they appear in the first read + -> [ v Nucleotides ] -- 5' adapters as they appear in the second read + -> u (Nucleotides, Qual) -- first read + -> u (Nucleotides, Qual) -- second read + -> Int -- assumed insert length + -> Int -- score (roughly sum of qualities at mismatches) +merge_score fwd_adapters rev_adapters read1 read2 l + = 6 * fromIntegral (l `min` V.length read1) -- read1, part before adapter + + 6 * fromIntegral (max 0 (l - V.length read1)) -- read2, part before overlap + + + minimum [ match_adapter (V.drop l read1) fwd_ad -- read1, match with forward adapter + + 6 * fromIntegral (max 0 (V.length read1 - V.length fwd_ad - l)) -- read1, part after (known) adapter + | fwd_ad <- fwd_adapters ] + + + minimum [ match_adapter (V.drop l read2) rev_ad -- read2, match with reverse adapter + + 6 * fromIntegral (max 0 (V.length read2 - V.length rev_ad - l)) -- read2, part after (known) adapter + | rev_ad <- rev_adapters ] + + + match_reads (V.take l $ V.drop (l - V.length read2) read1) + (V.take l $ V.drop (l - V.length read1) read2) -- read2, overlap with read1 + where + -- match_adapter :: u (Nucleotides, Qual) -> v Nucleotides -> Double + match_adapter rd ad = SS.unId $ SS.foldl' (+) 0 $ + SS.zipWith (\(!n, Q !q) m -> if n == m then 0 else min 25 (fromIntegral q)) + (S.elements $ V.stream rd) (S.elements $ V.stream ad) + + -- match_reads :: u (Nucleotides, Qual) -> u (Nucleotides, Qual) -> Double + match_reads rd1 rd2 = SS.unId $ SS.foldl' (+) 0 $ + SS.zipWith (\(!n1, Q !q1) (!n2, Q !q2) -> if n1 == compls n2 then 0 else fromIntegral $ min q1 q2) + (S.elements $ V.stream rd1) (S.elements $ V.streamR rd2) + +mergeTrimBam :: Monad m => [U.Vector Nucleotides] -> [U.Vector Nucleotides] -> Enumeratee [BamRec] [BamRec] m a +mergeTrimBam fwd_ads rev_ads = convStream go + where + go = do r1 <- headStream + if isPaired r1 + then tryHead >>= go2 r1 + else case trim_adapter r1 fwd_ads of + Nothing -> return [r1] + Just (r1',r1t,_q1,_q2) -> return [r1t,r1'] + + go2 r1 Nothing = error $ "Lone mate found: " ++ show (b_qname r1) + go2 r1 (Just r2) = case merge_overlap r1 fwd_ads r2 rev_ads of + Nothing -> return [r1,r2] + Just (r1',r2',rm,_q1,_q2) -> return [rm,r1',r2'] + diff --git a/src/Bio/Bam/Writer.hs b/src/Bio/Bam/Writer.hs --- a/src/Bio/Bam/Writer.hs +++ b/src/Bio/Bam/Writer.hs @@ -1,33 +1,29 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings, FlexibleContexts #-} module Bio.Bam.Writer ( IsBamRec(..), encodeBamWith, + packBam, writeBamFile, writeBamHandle, pipeBamOutput, pipeSamOutput ) where -import Bio.Base import Bio.Bam.Header import Bio.Bam.Rec import Bio.Iteratee import Bio.Iteratee.Builder +import Bio.Prelude -import Data.ByteString.Builder ( toLazyByteString ) -import Data.Bits -import Data.Char ( ord, chr ) -import Data.Foldable ( foldMap ) +import Data.ByteString.Internal ( ByteString(..) ) +import Data.ByteString.Builder ( hPutBuilder ) import Foreign.Marshal.Alloc ( alloca ) import Foreign.Storable ( pokeByteOff, peek ) -import System.IO -import System.IO.Unsafe ( unsafeDupablePerformIO ) +import System.IO ( openBinaryFile, IOMode(..) ) 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 @@ -44,7 +40,7 @@ -- 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 +pipeSamOutput meta = do liftIO . hPutBuilder stdout $ showBamMeta meta mapStreamM_ $ \b -> liftIO . putStr $ encodeSamEntry (meta_refs meta) b "\n" encodeSamEntry :: Refs -> BamRec -> String -> String @@ -65,13 +61,13 @@ 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 + 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 a) = (:) 'B' . (:) ':' . (:) 'i' . sarr a + extToSam (FloatArr a) = (:) 'B' . (:) ':' . (:) 'f' . sarr a tohex = B.foldr (\c f -> w2d (c `shiftR` 4) . w2d (c .&. 0xf) . f) id w2d = (:) . S.index "0123456789ABCDEF" . fromIntegral @@ -226,4 +222,9 @@ fromFloat :: Float -> Word32 fromFloat float = unsafeDupablePerformIO $ alloca $ \buf -> pokeByteOff buf 0 float >> peek buf + +packBam :: BamRec -> IO BamRaw +packBam br = do bb' <- case pushBamRec br of Push p -> newBuffer 1000 >>= p + return $ bamRaw 0 (PS (buffer bb') 4 (len bb' - 4)) + diff --git a/src/Bio/Base.hs b/src/Bio/Base.hs --- a/src/Bio/Base.hs +++ b/src/Bio/Base.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, FlexibleInstances, CPP #-} -{-# LANGUAGE MultiParamTypeClasses, BangPatterns, TemplateHaskell, RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, CPP #-} +{-# LANGUAGE ExistentialQuantification, 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. @@ -21,8 +21,6 @@ compl, compls, Seqid, - unpackSeqid, - packSeqid, Position(..), shiftPosition, @@ -38,23 +36,18 @@ w2c, c2w, - findAuxFile, - module Data.Monoid + findAuxFile ) where -import Bio.Util.Numeric ( log1p ) -import Data.Bits +import BasePrelude +#if MIN_VERSION_base(4,9,0) + hiding ( log1pexp, log1mexp ) +#endif +import Bio.Util.Numeric ( log1pexp, log1mexp ) import Data.ByteString.Internal ( c2w, w2c ) -import Data.Char ( isAlpha, isSpace, ord, toUpper ) -import Data.Ix ( Ix ) -import Data.Monoid -import Data.Word ( Word8 ) import Data.Vector.Unboxed.Deriving ( derivingUnbox ) -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 import qualified Data.Vector.Unboxed as U @@ -132,12 +125,19 @@ where q = - 10 * p / log 10 instance (Floating a, Ord a) => Num (Prob' a) where + {-# INLINE fromInteger #-} 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" + {-# INLINE (+) #-} + Pr x + Pr y = Pr $ if x >= y then x + log1pexp (y-x) else y + log1pexp (x-y) + {-# INLINE (-) #-} + Pr x - Pr y = Pr $ if x >= y then x + log1mexp (y-x) else error "no negative error probabilities" + {-# INLINE (*) #-} Pr a * Pr b = Pr $ a + b + {-# INLINE negate #-} negate _ = Pr $ error "no negative error probabilities" + {-# INLINE abs #-} abs x = x + {-# INLINE signum #-} signum _ = Pr 0 instance (Floating a, Fractional a, Ord a) => Fractional (Prob' a) where @@ -179,18 +179,8 @@ -- | Sequence identifiers are ASCII strings -- Since we tend to store them for a while, we use strict byte strings. --- Use @unpackSeqid@ and @packSeqid@ to avoid the qualified 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 @@ -227,9 +217,9 @@ -- 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 ord c < 128 then N (arr `U.unsafeIndex` ord c) else N 0 +toNucleotide c = if ord c < 128 then N (ar `U.unsafeIndex` ord c) else N 0 where - arr = U.replicate 128 0 U.// + ar = U.replicate 128 0 U.// ( [ (ord x, n) | (x, N n) <- pairs ] ++ [ (ord (toUpper x), n) | (x, N n) <- pairs ] ) @@ -240,9 +230,9 @@ -- 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 ord c < 128 then Ns (arr `U.unsafeIndex` ord c) else nucsN +toNucleotides c = if ord c < 128 then Ns (ar `U.unsafeIndex` ord c) else nucsN where - arr = U.replicate 128 (unNs nucsN) U.// + ar = U.replicate 128 (unNs nucsN) U.// ( [ (ord x, n) | (x, Ns n) <- pairs ] ++ [ (ord (toUpper x), n) | (x, Ns n) <- pairs ] ) @@ -332,9 +322,9 @@ -- | Complements a Nucleotides. {-# INLINE compls #-} compls :: Nucleotides -> Nucleotides -compls (Ns x) = Ns $ arr `U.unsafeIndex` fromIntegral (x .&. 15) +compls (Ns x) = Ns $ ar `U.unsafeIndex` fromIntegral (x .&. 15) where - !arr = U.fromListN 16 [ 0, 8, 4, 12, 2, 10, 6, 14, 1, 9, 5, 13, 3, 11, 7, 15 ] + !ar = U.fromListN 16 [ 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 @@ -376,9 +366,9 @@ -- PATH. findAuxFile :: FilePath -> IO FilePath findAuxFile fn | isAbsolute fn = return fn - | otherwise = loop . maybe ["."] splitSearchPath . lookup "BIOHAZARD" =<< getEnvironment + | otherwise = go . 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 + go [ ] = return fn + go (p:ps) = doesFileExist (p fn) >>= + bool (return $ p fn) (go ps) diff --git a/src/Bio/Genocall.hs b/src/Bio/Genocall.hs --- a/src/Bio/Genocall.hs +++ b/src/Bio/Genocall.hs @@ -1,20 +1,15 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} module Bio.Genocall where import Bio.Adna import Bio.Bam.Pileup -import Bio.Base -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 Bio.Prelude +import Data.Aeson +import qualified Data.HashMap.Strict as H import qualified Data.Set as Set -import qualified Data.Vector.Unboxed as V -import qualified Data.Vec as Vec +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U -- | Simple indel calling. We don't bother with it too much, so here's -- the gist: We collect variants (simply different variants, details @@ -32,82 +27,141 @@ -- much less likely than mapping errors. Since this is hardly our -- priority, the approximations are hereby declared good enough. -simple_indel_call :: Int -> IndelPile -> (GL, [IndelVariant]) -simple_indel_call _ [ ] = ( V.empty, [] ) -simple_indel_call _ [_] = ( V.empty, [] ) -simple_indel_call ploidy vars = ( simple_call ploidy mkpls vars, vars' ) +{-# INLINE simple_indel_call #-} +simple_indel_call :: (DmgToken -> Int -> Bool -> Mat44D) -> (IndelPile,IndelPile) -> (GL, [IndelVariant]) +simple_indel_call get_dmg (varsF,varsR) + | length (varsF++varsR) <= 1 = ( U.empty, [] ) + | otherwise = ( simple_call $ map (mkpls False) varsF ++ map (mkpls True) varsR, vars' ) where - vars' = IndelVariant (V_Nucs V.empty) (V_Nuc V.empty) : + vars' = IndelVariant (V_Nucs U.empty) (V_Nuc U.empty) : (Set.toList . Set.fromList) - [ IndelVariant (V_Nucs $ V.fromList d) - (V_Nuc $ V.fromList $ map db_call i) - | (_q,(d,i)) <- vars + [ IndelVariant (V_Nucs $ U.fromList d) + (V_Nuc $ U.fromList $ map db_call i) + | (_q,(d,i)) <- varsF ++ varsR , not (null d) || not (null i) ] - match = zipWith $ \(DB b q _ m) n -> let p = m `bang` n :-> b - p' = fromQual q - in toProb $ p + p' - p * p' + match str = zipWith $ \(DB b q dt di _) n -> let p = get_dmg dt di str `bang` n :-> b + p' = fromQual q + in toProb $ p + p' - p * p' - mkpls :: (Qual, ([Nucleotides], [DamagedBase])) -> [Prob] - mkpls (q,(d,i)) = [ qualToProb q + - if length d /= V.length dr || length i /= V.length ir - then 0 else product (match i $ V.toList ir) - | IndelVariant (V_Nucs dr) (V_Nuc ir) <- vars' ] + mkpls :: Bool -> (Qual, ([Nucleotides], [DamagedBase])) -> U.Vector Prob + mkpls str (q,(d,i)) = U.fromList [ qualToProb q + + if length d /= U.length dr || length i /= U.length ir + then 0 else product (match str i $ U.toList ir) + | IndelVariant (V_Nucs 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. +-- | A completely universal, completely empirical substituion model. +-- We make no attempt to distinguish damage from error. The model is +-- cloned so we don't need to constantly flip matrices depending on +-- strand. +data SubstModel_ m = SubstModel + { left_substs_fwd :: {-# UNPACK #-} !(V.Vector m) + , middle_substs_fwd :: !m + , right_substs_fwd :: {-# UNPACK #-} !(V.Vector m) + , left_substs_rev :: {-# UNPACK #-} !(V.Vector m) + , middle_substs_rev :: !m + , right_substs_rev :: {-# UNPACK #-} !(V.Vector m) } + deriving (Show, Generic) -simple_snp_call :: (Qual -> Double) -> Int -> BasePile -> Snp_GLs -simple_snp_call from_qual ploidy vars = snp_gls (simple_call ploidy mkpls vars) ref - where - ref = case vars of (_, DB _ _ r _) : _ -> r ; _ -> nucsN - mkpls (q, DB b qq _ m) = [ toProb $ x + pe*(s-x) | n <- [0..3], let x = m `bang` N n :-> b ] - where - !p1 = from_qual q - !p2 = from_qual qq - !pe = p1 + p2 - p1*p2 - !s = sum [ m `bang` N n :-> b | n <- [0..3] ] / 4 +instance ToJSON m => ToJSON (SubstModel_ m) +instance FromJSON m => FromJSON (SubstModel_ m) --- | 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. --- --- XXX This eats up ~40% of total runtime; it *screams out* for --- specialization to diploidy and four alleles (common SNPs) and maybe --- diploidy and two alleles (common indels). +type SubstModel = SubstModel_ Mat44D -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 +-- | Mutable version of SubstModel, we'll probably have to accumulate in +-- this thing. +type MSubstModel = SubstModel_ MMat44D - !mag = recip $ toProb (fromIntegral ploidy) +lookupSubstModel :: SubstModel_ a -> Int -> Bool -> a +lookupSubstModel m i False + | i >= 0 && i < V.length (left_substs_fwd m) = V.unsafeIndex (left_substs_fwd m) i + | i < 0 && (-i) <= V.length (right_substs_fwd m) = V.unsafeIndex (right_substs_fwd m) (-i-1) + | otherwise = middle_substs_fwd m +lookupSubstModel m i True + | i >= 0 && i < V.length (left_substs_rev m) = V.unsafeIndex (left_substs_rev m) i + | i < 0 && (-i) <= V.length (right_substs_rev m) = V.unsafeIndex (right_substs_rev m) (-i-1) + | otherwise = middle_substs_rev m - -- XXX This could probably be simplified given the mk_pls function - -- below. - step = V.fromList . map (* mag) . reverse . mk_pls ploidy . reverse . pls +-- Freezes a mutable substitution model into an immutable one. Both +-- strands are combined, the result is normalized, and duplicated to +-- have a model for each strand again. +freezeSubstModel :: MSubstModel -> IO SubstModel +freezeSubstModel mm = do + new_left <- V.zipWithM freezeMats (left_substs_fwd mm) (right_substs_rev mm) + new_middle <- freezeMats (middle_substs_fwd mm) (middle_substs_rev mm) + new_right <- V.zipWithM freezeMats (right_substs_fwd mm) (left_substs_rev mm) - -- Meh. Pointless, but happens to be the unit. - mk_pls 0 _ = return 0 + return $ SubstModel new_left new_middle new_right + ( V.map complMat new_left ) + ( complMat new_middle ) + ( V.map complMat new_right ) - -- Okay, we sample ONE allele. Likelihood of the data is simply the - -- GL value that was passed to us. - mk_pls 1 ls = ls +newtype SubstModels = SubstModels (HashMap Bytes SubstModel) + deriving (Show, Generic) - -- We extend the genotype and sample another allele. - mk_pls n ls = do ls'@(hd:_) <- tails ls - (+) hd <$> mk_pls (n-1) ls' +instance ToJSON SubstModels where + toJSON (SubstModels m) = Object $ H.fromList + [ ( decodeBytes k, toJSON v ) | (k,v) <- H.toList m ] +instance FromJSON SubstModels where + parseJSON = withObject "map of substitution models" $ \o -> + SubstModels . H.fromList <$> sequence + [ (,) (encodeBytes k) <$> parseJSON v | (k,v) <- H.toList o ] + + + +-- | Naive SNP call; essentially the GATK model. We compute the +-- likelihood for each base from an empirical error/damage model, then +-- hand over to 'simple_call'. Base quality is ignored, but map quality +-- is incorporated. + +{-# INLINE simple_snp_call #-} +simple_snp_call :: (DmgToken -> Int -> Bool -> Mat44D) -> (BasePile,BasePile) -> Snp_GLs +simple_snp_call get_dmg (varsF,varsR) = mk_snp_gls (simple_call $ map (mkpls False) varsF ++ map (mkpls True) varsR) ref + where + ref = case varsF ++ varsR of (_, DB _ _ _ _ r) : _ -> r ; _ -> nucsN + mkpls str (qq, DB b _ dt di _) = U.generate 4 $ \n -> + let x = get_dmg dt di str `bang` N (fromIntegral n) :-> b + in toProb $ x + fromQual qq * (1-x) + +-- | Compute @GL@ values for the simple case. The simple case is where +-- we sample two alleles with equal probability and assume that errors +-- occur independently from each other. This is specialized for a few +-- common cases: two variants, because that's a typical indel; four +-- variants, because that's every SNP. + +{-# INLINE simple_call #-} +simple_call :: [U.Vector Prob] -> GL +simple_call [ ] = U.empty +simple_call (gl:gls) = case U.length gl of + 2 -> foldl' (U.zipWith (*)) (step2 gl) $ map step2 gls + where + step2 v = U.fromListN 3 [ x0, (x0+x1) / 2, x1 ] + where x0 = U.unsafeIndex v 0 + x1 = U.unsafeIndex v 1 + + 4 -> foldl' (U.zipWith (*)) (step4 gl) $ map step4 gls + where + step4 v = U.fromListN 10 [ x0 + , (x0+x1)/2, x1 + , (x0+x2)/2, (x1+x2)/2, x2 + , (x0+x3)/2, (x1+x3)/2, (x2+x3)/2, x3 ] + where x0 = U.unsafeIndex v 0 + x1 = U.unsafeIndex v 1 + x2 = U.unsafeIndex v 2 + x3 = U.unsafeIndex v 3 + + _ -> foldl' (U.zipWith (*)) (step gl) $ map step gls + where + step !ls = U.concatMap (\i -> let hd = U.unsafeIndex ls i + ls' = U.unsafeTake (i+1) ls + in U.map (\x -> 0.5 * (hd + x)) ls' + ) (U.enumFromN 0 $ U.length ls) + + -- | Make a list of genotypes, each represented as a vector of allele --- probabilities, from ploidy and four possible alleles. +-- probabilities, from 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 @@ -119,114 +173,49 @@ -- "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 ] +mk_snp_gts :: [Vec4D] +mk_snp_gts = [ Vec4D (0.5*(a+w)) (0.5*(b+x)) (0.5*(c+y)) (0.5*(d+z)) + | as@(_:_) <- inits [ Vec4D 1 0 0 0, Vec4D 0 1 0 0, Vec4D 0 0 1 0, Vec4D 0 0 0 1 ] + , let Vec4D a b c d = last as + , Vec4D w x y z <- as ] - -- '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' ] +getRow :: Int -> Mat44D -> Vec4D +getRow i (Mat44D v) = Vec4D (v U.! (4*i)) (v U.! (4*i+1)) (v U.! (4*i+2)) (v U.! (4*i+3)) --- | SNP call according to maq/samtools/bsnp model. The matrix k counts --- how many errors we made, approximately. +setRow :: Int -> Vec4D -> Mat44D -> Mat44D +setRow i (Vec4D a b c d) (Mat44D v) = Mat44D $ v U.// [ (4*i,a), (4*i+1,b), (4*i+2,c), (4*i+3,d) ] -maq_snp_call :: Int -> Double -> BasePile -> Snp_GLs -maq_snp_call ploidy theta bases = snp_gls (V.fromList $ map l $ mk_snp_gts ploidy) ref - 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 ] - ref = case bases of (_, DB _ _ r _) : _ -> r ; _ -> nucsN - - 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 `bang` h :-> db_call x)) (db_qual x)) everynuc - - -- eh, this is cumbersome... what was I thinking?! - 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 `bang` 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 +type Calls = Pile' Snp_GLs (GL, [IndelVariant]) - put f = putStr $ f "\n" +-- | This pairs up GL values and the reference allele. When +-- constructing it, we make sure the GL values are in the correct order +-- if the reference allele is listed first. +data Snp_GLs = Snp_GLs { snp_gls :: !GL, snp_refbase :: !Nucleotides } + deriving Show - show_bases :: () -> ShowS - show_bases () = (++) "A,C,G,T" +mk_snp_gls :: GL -> Nucleotides -> Snp_GLs +mk_snp_gls gl ref | U.length gl /= 10 = error "only diploid genomes are supported!" + | otherwise = Snp_GLs gl ref - show_indels :: IndelVars -> ShowS - show_indels = (++) . intercalate "," . map show_indel +data Vec4D = Vec4D {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double - show_indel :: (Int, [Nucleotide]) -> String - show_indel (d, ins) = shows ins $ '-' : show d --} +vecNucs :: (Nucleotide -> Double) -> Vec4D +vecNucs f = Vec4D (f nucA) (f nucC) (f nucG) (f nucT) --- 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?! +vecSum :: Vec4D -> Double +vecSum (Vec4D a b c d) = a + b + c + d -type Calls = Pile' Snp_GLs (GL, [IndelVariant]) +dot :: Vec4D -> Vec4D -> Double +dot (Vec4D a b c d) (Vec4D w x y z) = a*w + b*x + c*y + d*z --- | This pairs up GL values and the reference allele. When --- constructing it, we make sure the GL values are in the correct order --- if the reference allele is listed first. -data Snp_GLs = Snp_GLs !GL !Nucleotides - deriving Show +multmv :: Mat44D -> Vec4D -> Vec4D +multmv m v = Vec4D (dot (getRow 0 m) v) (dot (getRow 1 m) v) + (dot (getRow 2 m) v) (dot (getRow 3 m) v) -snp_gls :: GL -> Nucleotides -> Snp_GLs -snp_gls pls ref | ref == nucsT = Snp_GLs (pls `V.backpermute` V.fromList [9,6,0,7,1,2,8,3,4,5]) ref - | ref == nucsG = Snp_GLs (pls `V.backpermute` V.fromList [5,3,0,4,1,2,8,6,7,9]) ref - | ref == nucsC = Snp_GLs (pls `V.backpermute` V.fromList [2,1,0,4,3,5,7,6,8,9]) ref - | otherwise = Snp_GLs pls ref +vecZip :: (Double -> Double -> Double) -> Vec4D -> Vec4D -> Vec4D +vecZip f (Vec4D a b c d) (Vec4D w x y z) = Vec4D (f a w) (f b x) (f c y) (f d z) +vecZipNucs :: (Double -> Nucleotide -> Double) -> Vec4D -> Vec4D +vecZipNucs f (Vec4D a b c d) = Vec4D (f a nucA) (f b nucC) (f c nucG) (f d nucT) diff --git a/src/Bio/Genocall/AvroFile.hs b/src/Bio/Genocall/AvroFile.hs deleted file mode 100644 --- a/src/Bio/Genocall/AvroFile.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings, PatternGuards #-} -module Bio.Genocall.AvroFile where - -import Bio.Base -import Bio.Bam.Header -import Bio.Bam.Pileup -import Control.Applicative -import Data.Aeson -import Data.Avro -import Data.Binary.Builder -import Data.Binary.Get -import Data.List ( intersperse ) -import Data.MiniFloat -import Data.Scientific ( toBoundedInteger ) -import Data.Text.Encoding ( encodeUtf8 ) - -import qualified Data.ByteString as B -import qualified Data.HashMap.Strict as H -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U -import qualified Data.Sequence as Z - --- ^ 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 :: {-# UNPACK #-} !Refseq - , start_position :: {-# UNPACK #-} !Int - , called_sites :: [ GenoCallSite ] } - deriving (Show, Eq) - -data GenoCallSite = GenoCallSite - { snp_stats :: {-# UNPACK #-} !CallStats - -- snp likelihoods appear in the same order as in VCF, the reference - -- allele goes first if it is A, C, G or T. Else A goes first---not - -- my problem how to express that in VCF. - , snp_likelihoods :: {-# UNPACK #-} !(U.Vector Mini) -- B.ByteString? - , ref_allele :: {-# UNPACK #-} !Nucleotides - , indel_stats :: {-# UNPACK #-} !CallStats - , indel_variants :: [ IndelVariant ] - , indel_likelihoods :: {-# UNPACK #-} !(U.Vector Mini) } -- B.ByteString? - deriving (Show, Eq) - --- | 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 :: U.Vector Prob -> U.Vector Mini -- B.ByteString -compact_likelihoods = U.map $ float2mini . negate . unPr --- compact_likelihoods = map fromIntegral {- B.pack -} . U.toList . U.map (float2mini . negate . unPr) - - -deriveAvros [ ''GenoCallBlock, ''GenoCallSite, ''CallStats, ''IndelVariant ] - -instance Avro V_Nuc where - toSchema _ = return $ object [ "type" .= String "bytes", "doc" .= String doc ] - where doc = T.pack $ intersperse ',' $ show $ [minBound .. maxBound :: Nucleotide] - toBin (V_Nuc v) = encodeIntBase128 (U.length v) <> U.foldr ((<>) . singleton . unN) mempty v - fromBin = decodeIntBase128 >>= \l -> V_Nuc . U.fromListN l . map N . B.unpack <$> getByteString l - toAvron (V_Nuc v) = String . T.pack . map w2c . U.toList $ U.map unN v - -instance Avro V_Nucs where - toSchema _ = return $ object [ "type" .= String "bytes", "doc" .= String doc ] - where doc = T.pack $ intersperse ',' $ show $ [minBound .. maxBound :: Nucleotides] - toBin (V_Nucs v) = encodeIntBase128 (U.length v) <> U.foldr ((<>) . singleton . unNs) mempty v - fromBin = decodeIntBase128 >>= \l -> V_Nucs . U.fromListN l . map Ns . B.unpack <$> getByteString l - toAvron (V_Nucs v) = String . T.pack . map w2c . U.toList $ U.map unNs v - -instance Avro Nucleotides where - toSchema _ = return $ String "int" - toBin = encodeIntBase128 . unNs - fromBin = Ns <$> decodeIntBase128 - toAvron = Number . fromIntegral . unNs - -instance Avro Mini where - toSchema _ = return $ String "int" - toBin = encodeIntBase128 . unMini - fromBin = Mini <$> decodeIntBase128 - toAvron = Number . fromIntegral . unMini - --- | We encode the Refseq as an Avro enum, which serves as a kind of --- symbol table. To make this work, the environment of the 'MkSchema' --- monad has to be prepopulated with a suitable schema. -instance Avro Refseq where - toSchema _ = getNamedSchema "Refseq" - toBin = encodeIntBase128 . unRefseq - fromBin = Refseq <$> decodeIntBase128 - - -- This is cheating, we should use the enum names, but they are not - -- available. Doesn't matter, this is mostly for debugging anyway. - toAvron = Number . fromIntegral . unRefseq - - --- | Reconstructs the list of reference sequences from Avro metadata. --- If a type named @Refseq@ is defined in the schema and is an enum, it --- defines the symbol table, otherwise an empty list is returned. If --- @biohazard.refseq_length@ exists, and is an array, it's elements are --- interpreted as the lengths in order, otherwise the lengths are set to --- zero. -getRefseqs :: AvroMeta -> Refs -getRefseqs meta - | Object o <- findSchema "Refseq" meta - , Just (String "enum") <- H.lookup "type" o - , Just (Array syms) <- H.lookup "symbols" o - = Z.fromList [ BamSQ (encodeUtf8 nm) ln [] | (String nm, ln) <- V.toList syms `zip` lengths ] - | otherwise = Z.empty - where - lengths = case decodeStrict =<< H.lookup "biohazard.refseq_length" meta of - Just (Array lns) -> [ case l of Number n -> maybe 0 id $ toBoundedInteger n ; _ -> 0 | l <- V.toList lns ] - _ -> repeat 0 - diff --git a/src/Bio/Genocall/Estimators.hs b/src/Bio/Genocall/Estimators.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Genocall/Estimators.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -O0 #-} +module Bio.Genocall.Estimators ( + tabulateSingle, + estimateSingle, + DivEst(..), + ExtModel(..), + DivTable(..), + good_regions + ) where + +import Bio.Bam +import Bio.Bam.Pileup ( p_snp_pile ) +import Bio.Genocall ( Snp_GLs(..), Calls, SubstModels ) +import Bio.Prelude +import Bio.Util.AD +import Bio.Util.AD2 +import Bio.Util.Numeric ( log1pexp ) +import Data.Aeson +import Data.Binary +import Data.Vector.Binary () + +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as M + + +data DivTable = DivTable !Double !(U.Vector Int) deriving (Show, Generic) + +instance Binary DivTable + +instance Monoid DivTable where + mempty = DivTable 0 U.empty + + DivTable a u `mappend` DivTable b v = DivTable (a+b) w + where w | U.null u = v + | U.null v = u + | otherwise = U.zipWith (+) u v + +-- | Divergence estimate. Lists contain three or four floats, these are +-- divergence, heterozygosity at W sites, heterozygosity at S sites, and +-- optionally gappiness in this order. +data DivEst = DivEst { + point_est :: [Double], + conf_region :: [( [Double], [Double] )] + } deriving (Show, Generic) + +instance ToJSON DivEst +instance FromJSON DivEst + +data ExtModel = ExtModel { population :: DivEst + , pop_separate :: Maybe DivEst + , damage :: SubstModels } + deriving (Show, Generic) + +instance ToJSON ExtModel +instance FromJSON ExtModel + +-- XXX the optimizations fit only two or three parameters. +-- Newton-Iteration should be more efficient than the generic CG method. +-- +-- For Newton-Iteration, the update is \(x := x + dt\) where +-- \(dt = -\Nabla^2 f(x)^{-1} \Nabla f(x)\) or \(\Nabla^2 f(x) dt = -\Nabla f(x)\) + +estimateSingle :: DivTable -> IO (DivEst, DivEst) +estimateSingle (DivTable _llk_rr tab) = do + (fit1, _res1, _stats1) <- minimize quietParameters 0.0000001 (llk tab) (U.fromList [0,0]) + (fit2, _res2, _stats2) <- minimize quietParameters 0.0000001 (llk tab) (U.fromList [0,0,0]) + + let xform v = map (\x -> recip $ 1 + exp (-x)) $ V.toList v + !de1 = DivEst (xform fit1) (map (xform *** xform) $ confidenceIntervals (llk2 tab) (V.convert fit1)) + !de2 = DivEst (xform fit2) (map (xform *** xform) $ confidenceIntervals (llk2 tab) (V.convert fit2)) + + return (de1,de2) + +llk :: U.Vector Int -> [AD] -> AD +llk tab [delta,eta] = llk' tab 0 delta eta + llk' tab 6 delta eta +llk tab [delta,eta,eta2] = llk' tab 0 delta eta + llk' tab 6 delta eta2 +llk _ _ = error "Wtf? (3)" + +llk2 :: U.Vector Int -> [AD2] -> AD2 +llk2 tab [delta,eta] = llk' tab 0 delta eta + llk' tab 6 delta eta +llk2 tab [delta,eta,eta2] = llk' tab 0 delta eta + llk' tab 6 delta eta2 +llk2 _ _ = error "Wtf? (4)" + +{-# INLINE llk' #-} +llk' :: (Ord a, Floating a) => U.Vector Int -> Int -> a -> a -> a +llk' tab base delta eta = block (base+0) g_RR g_RA g_AA + + block (base+1) g_RR g_AA g_RA + + block (base+2) g_RA g_RR g_AA + + block (base+3) g_RA g_AA g_RR + + block (base+4) g_AA g_RR g_RA + + block (base+5) g_AA g_RA g_RR + where + !maxD2 = U.length tab `div` 12 + !maxD = round (sqrt (fromIntegral maxD2) :: Double) + + !g_AA = Pr delta / Pr (log1pexp delta) + !g_RA = 1 / Pr (log1pexp delta) * Pr eta / Pr (log1pexp eta) + !g_RR = 1 / Pr (log1pexp delta) * 1 / Pr (log1pexp eta) + + block ix g1 g2 g3 = U.ifoldl' step 0 $ U.slice (ix * maxD2) maxD2 tab + where + step !acc !i !num = acc - fromIntegral num * unPr p + where + (!d1,!d2) = i `quotRem` maxD + p = g1 + Pr (- fromIntegral d1) * g2 + Pr (- fromIntegral (d1+d2)) * g3 + + +-- | Parameter estimation for a single sample. The parameters are +-- divergence and heterozygosity. We tabulate the data here and do the +-- estimation afterwards. Returns the product of the +-- parameter-independent parts of the likehoods and the histogram +-- indexed by D and H (see @genotyping.pdf@ for details). +tabulateSingle :: MonadIO m => Iteratee [Calls] m DivTable +tabulateSingle = do + tab <- liftIO $ M.replicate (12 * maxD * maxD) (0 :: Int) + DivTable `liftM` foldStreamM (\acc -> accum tab acc . p_snp_pile) (0 :: Double) + `ap` liftIO (U.unsafeFreeze tab) + where + maxD = 64 + + -- We need GL values for the invariant, the three homozygous variant + -- and the three single-event heterozygous variant cases. The + -- ordering is like in BCF, with the reference first. + -- Ref ~ A ==> PL ~ AA, AC, CC, AG, CG, GG, AT, CT, GT, TT + {-# INLINE accum #-} + accum !tab !acc !snp + | ref `elem` [nucsC,nucsG] = accum' 0 tab acc gls ref + | ref `elem` [nucsA,nucsT] = accum' 6 tab acc gls ref + | otherwise = return acc -- unknown reference + where + ref = snp_refbase snp + gls = snp_gls snp + + -- The simple 2D table didn't work, it lacked resolution in some + -- cases. We make six separate tables instead so we can store two + -- differences with good resolution in every case. + {-# INLINE accum' #-} + accum' !refix !tab !acc !gls !ref + | g_RR >= g_RA && g_RA >= g_AA = store 0 g_RR g_RA g_AA + | g_RR >= g_AA && g_AA >= g_RA = store 1 g_RR g_AA g_RA + | g_RA >= g_RR && g_RR >= g_AA = store 2 g_RA g_RR g_AA + | g_RA >= g_AA && g_AA >= g_RR = store 3 g_RA g_AA g_RR + | g_RR >= g_RA = store 4 g_AA g_RR g_RA + | otherwise = store 5 g_AA g_RA g_RR + + where + g_RR | ref == nucsT = unPr $ U.unsafeIndex gls 9 + | ref == nucsG = unPr $ U.unsafeIndex gls 5 + | ref == nucsC = unPr $ U.unsafeIndex gls 2 + | otherwise = unPr $ U.unsafeIndex gls 0 + + g_RA = unPr $ (U.unsafeIndex gls 1 + U.unsafeIndex gls 3 + U.unsafeIndex gls 6) / 3 + + g_AA | ref == nucsT = unPr $ (U.unsafeIndex gls 0 + U.unsafeIndex gls 2 + U.unsafeIndex gls 5) / 3 + | ref == nucsG = unPr $ (U.unsafeIndex gls 0 + U.unsafeIndex gls 2 + U.unsafeIndex gls 9) / 3 + | ref == nucsC = unPr $ (U.unsafeIndex gls 0 + U.unsafeIndex gls 5 + U.unsafeIndex gls 9) / 3 + | otherwise = unPr $ (U.unsafeIndex gls 2 + U.unsafeIndex gls 5 + U.unsafeIndex gls 9) / 3 + + store !t !a !b !c = do let d1 = min (maxD-1) . round $ a - b + d2 = min (maxD-1) . round $ b - c + ix = (t + refix) * maxD * maxD + d1 * maxD + d2 + liftIO $ M.read tab ix >>= M.write tab ix . succ + return $! acc + a + +-- | These are the longest contiguous mappable regions (chromosome, +-- start position, length) on the autosomes taken from Heng Li's +-- "filt35_50" until their cumulative length is greater than 10MB. +-- We'll use them for parameter fitting without worrying about +-- mappability. + +good_regions :: [( Bytes, Int, Int )] +good_regions = [ ("9",137210024,50801), ("18",72958402,47124), ("3",126700279,40864), ("4",20244708,36976), + ("7",50443055,36829), ("2",172933866,35408), ("6",50781199,35328), ("4",111534379,34160), ("9",23816847,33889), + ("12",5601165,33717), ("5",134654381,32840), ("1",87790801,32108), ("12",54342242,31191), ("2",72016632,31107), + ("3",47025806,30522), ("8",140633542,30431), ("3",49678222,30361), ("22",23433574,30325), ("18",31218235,29907), + ("5",94195249,29776), ("14",22842926,29664), ("3",10955664,29450), ("11",2701423,29287), ("6",47822738,29094), + ("2",179421187,29001), ("1",2975248,28500), ("11",15625359,28497), ("16",65235334,28387), ("11",17606351,28374), + ("11",6627401,28349), ("14",101962136,28122), ("11",131331738,28031), ("3",35676569,27919), ("20",23007246,27904), + ("16",86516836,27686), ("8",143601826,27591), ("4",105402662,27565), ("22",19954339,27544), ("8",142668520,27397), + ("7",27127108,27336), ("3",135073061,27276), ("1",49175564,27118), ("6",93965080,27113), ("7",50707378,27090), + ("5",66378246,27041), ("18",76730933,26975), ("13",44578644,26722), ("12",65886788,26632), ("9",124513463,26507), + ("11",31654911,26355), ("10",130630869,26343), ("3",96522468,26316), ("5",71281187,26300), ("18",72601061,26219), + ("8",89116777,26217), ("8",77595904,26119), ("7",36636342,26036), ("2",72353320,25820), ("3",112988383,25762), + ("7",155239629,25756), ("1",2789639,25749), ("1",48213405,25681), ("4",136124313,25649), ("1",196271156,25641), + ("10",11191315,25583), ("2",206608755,25468), ("12",54410147,25352), ("2",12854107,25292), ("11",11581616,25288), + ("12",13700919,25192), ("8",142864620,25147), ("2",179465162,25139), ("9",14514334,25107), ("3",35717320,25063), + ("22",19729058,24923), ("9",109680443,24899), ("6",94115565,24860), ("8",93505503,24846), ("4",158790023,24704), + ("10",131751339,24684), ("1",181704049,24484), ("10",80682212,24465), ("3",169164284,24463), ("11",17511342,24437), + ("14",33968191,24411), ("1",53992234,24288), ("4",183056381,24222), ("2",71820551,24155), ("9",137265761,24075), + ("15",36124467,24063), ("14",46406527,24053), ("1",83210498,24021), ("6",108476739,23964), ("5",131587752,23956), + ("3",48615599,23886), ("6",55728531,23880), ("7",127697189,23869), ("12",50346181,23863), ("3",144228991,23831), + ("4",8265418,23682), ("2",45148758,23679), ("5",134540523,23644), ("5",134371610,23626), ("1",42036301,23604), + ("8",116656966,23590), ("9",96702236,23589), ("1",37307947,23570), ("1",210850735,23541), ("9",135459556,23527), + ("2",51135518,23503), ("11",45670249,23503), ("3",122993389,23483), ("14",56745421,23461), ("12",5898019,23455), + ("2",163037779,23446), ("11",69447933,23373), ("2",212035036,23357), ("6",96460435,23294), ("18",44764982,23243), + ("10",101278523,23242), ("5",160036671,23241), ("1",49124538,23176), ("7",18260998,23158), ("2",99167682,23147), + ("14",29232562,23127), ("15",97239853,23121), ("10",50494407,23089), ("15",70369320,23071), ("3",168827492,23039), + ("8",77761638,23015), ("15",38157092,22957), ("10",11365418,22949), ("3",105255227,22893), ("1",34814158,22881), + ("1",37392280,22867), ("11",71705177,22832), ("12",2418673,22823), ("1",72511401,22645), ("7",1265072,22602), + ("13",112699565,22576), ("20",57188413,22568), ("21",16420477,22503), ("3",129287740,22468), ("9",125868895,22467), + ("1",160050031,22456), ("12",48128061,22430), ("18",5282725,22418), ("13",67789099,22414), ("6",40287102,22408), + ("18",5880352,22384), ("8",143528138,22367), ("12",85676068,22365), ("8",84320057,22352), ("9",37321783,22293), + ("1",209775949,22272), ("3",18389755,22252), ("4",147944592,22243), ("8",133906982,22224), ("11",133329130,22217), + ("3",173313782,22215), ("5",11889097,22179), ("11",79649083,22174), ("5",132731240,22137), ("7",157466401,22137), + ("2",179634275,22116), ("11",43589949,22100), ("4",52766804,22099), ("12",3355258,22074), ("5",131397743,22070), + ("10",80291692,21987), ("9",14296528,21964), ("10",98269731,21962), ("3",16914253,21948), ("1",197561249,21908), + ("6",120906102,21884), ("2",193650467,21851), ("2",128384358,21847), ("3",48662757,21839), ("6",43733826,21830), + ("4",10215804,21821), ("22",46353587,21773), ("1",239171473,21764), ("12",54373478,21741), ("15",88509335,21732), + ("18",35145944,21709), ("15",95071676,21703), ("1",3220853,21688), ("1",82261961,21677), ("13",26246199,21672), + ("2",121320633,21663), ("5",95664126,21658), ("18",53770513,21624), ("5",108573486,21615), ("10",1762508,21612), + ("8",131982804,21550), ("12",59791869,21536), ("2",164194661,21524), ("11",64389512,21519), ("10",48420962,21516), + ("12",55408280,21514), ("14",33881612,21508), ("8",93616886,21507), ("3",134838560,21418), ("1",32215568,21396), + ("1",88245563,21394), ("5",163625223,21390), ("1",154971490,21367), ("1",2393882,21354), ("2",119583947,21343), + ("10",125760979,21336), ("12",1928169,21298), ("11",15787032,21257), ("1",160020996,21256), ("14",34162064,21249), + ("5",152857671,21234), ("10",132906774,21228), ("12",91441003,21228), ("1",168471368,21187), ("11",6660346,21183), + ("15",93125306,21146), ("2",159569436,21136), ("7",114286123,21134), ("3",55497586,21131), ("20",61147962,21120), + ("18",31314083,21087), ("5",87948855,21077), ("12",107266456,21071), ("1",112382584,21045), ("1",44871084,21041), + ("8",59833303,21037), ("20",12185890,21016), ("1",175835258,20982), ("11",132197740,20962), ("6",128317896,20960), + ("1",216882694,20949), ("11",61329536,20948), ("4",24007933,20895), ("7",42485962,20843), ("10",44446025,20828), + ("11",2153220,20823), ("3",52112801,20818), ("1",75232624,20802), ("1",81018216,20782), ("21",17158618,20749), + ("11",15830777,20738), ("20",11895285,20734), ("10",52998525,20713), ("5",93635203,20708), ("17",80003858,20685), + ("9",129968922,20683), ("6",70561018,20671), ("4",97130238,20662), ("8",135136261,20658), ("2",23903685,20632), + ("22",24548899,20628), ("9",7497211,20620), ("13",110428506,20601), ("15",48384378,20563), ("12",70712242,20555), + ("7",149504838,20520), ("1",42189196,20518), ("2",109987828,20491), ("3",18073619,20438), ("1",239875096,20430), + ("11",124937110,20416), ("5",11382753,20401), ("20",39447354,20400), ("14",105252979,20394), ("9",24026887,20386), + ("5",132623090,20381), ("8",65608184,20365), ("6",33743378,20351), ("2",151329557,20344), ("20",37892360,20340), + ("1",3367177,20331), ("5",122512407,20331), ("10",102974441,20331), ("13",112755319,20326), ("3",12992872,20315), + ("13",42170961,20306), ("10",80874296,20300), ("20",60444066,20292), ("2",73146343,20284), ("3",50190348,20284), + ("22",50340074,20277), ("1",77030540,20253), ("13",102679591,20222), ("10",81040310,20197), ("9",9211551,20188), + ("18",22738887,20181), ("3",44052705,20176), ("2",54880032,20166), ("5",37822780,20150), ("18",53007829,20135), + ("9",129187481,20128), ("6",144270559,20091), ("1",205403570,20090), ("4",44421876,20045), ("10",44861946,20023), + ("4",67049100,19998), ("7",32096011,19967), ("7",34131372,19967), ("1",110017253,19938), ("1",77080436,19922), + ("5",88010450,19920), ("7",15716479,19911), ("15",33826577,19904), ("9",126521960,19877), ("14",58022067,19853), + ("7",27160875,19845), ("4",90823485,19825), ("18",45240281,19818), ("1",3005635,19809), ("2",157007834,19789), + ("12",114832107,19789), ("6",45288303,19788), ("6",99074944,19783), ("11",2670228,19779), ("5",73567689,19774), + ("6",51224143,19774), ("5",102223202,19766), ("15",89899715,19750), ("4",104970277,19740), ("15",70349377,19722), + ("6",101837270,19718), ("4",96325943,19709), ("2",168098209,19708), ("21",39746588,19693), ("3",59949020,19686), + ("2",119358552,19681), ("2",67497291,19679), ("12",105117749,19661), ("3",180017017,19638), ("4",1793613,19638), + ("7",92453277,19635), ("20",16315532,19598), ("5",169493896,19574), ("3",18469949,19564), ("4",2061136,19548), + ("1",175528763,19535), ("15",87190931,19514), ("14",101991199,19498), ("9",9497024,19493), ("11",15896925,19493), + ("22",43629376,19444), ("11",64363871,19436), ("3",50399986,19433), ("1",244210029,19431), ("11",2591551,19424), + ("11",1239413,19417), ("9",116776003,19416), ("1",198338602,19414), ("7",8501937,19411), ("1",120452998,19403), + ("14",24722981,19395), ("15",39870070,19395), ("2",134164180,19386), ("11",109293469,19365), ("3",113929897,19362), + ("4",107835785,19338), ("17",32778941,19337), ("5",122424884,19327), ("13",105234793,19317), ("21",18170750,19309), + ("5",134719430,19301), ("14",56588948,19294), ("6",39449811,19289), ("7",116762432,19282), ("8",79510243,19281), + ("11",75301993,19266), ("3",89452118,19229), ("6",40123796,19208), ("1",181452626,19207), ("14",33860687,19197), + ("11",124731491,19188), ("8",62768789,19187), ("9",124458437,19180), ("9",4097024,19172), ("2",205522223,19160), + ("1",166027772,19156), ("10",130504847,19155), ("17",7306011,19144), ("10",23479527,19123), ("4",2245744,19117), + ("3",46901850,19109), ("3",139771287,19105), ("9",34548966,19104), ("8",110811609,19093), ("2",220339781,19077), + ("16",1811705,19062), ("7",155530076,19061), ("3",110181036,19060), ("2",127805324,19050), ("7",55182828,19047), + ("7",27223390,19039), ("1",51432006,19038), ("4",88753129,19035), ("15",63122126,19030), ("5",87837753,19018), + ("2",36665285,19015), ("18",35186913,18942), ("5",129172415,18940), ("15",68111506,18935), ("7",25440487,18925), + ("8",93889992,18924), ("17",56398946,18921), ("13",107170684,18912), ("13",102563238,18908), ("10",43743824,18896), + ("15",50211905,18888), ("10",72530467,18883), ("11",113271284,18878), ("12",81086307,18874), ("1",175352300,18867), + ("4",10071903,18866), ("14",89644782,18857), ("3",50419448,18855), ("11",93212299,18848), ("7",44268521,18838), + ("12",123458577,18812), ("5",61089957,18811), ("2",19554179,18803), ("7",132105968,18781), ("15",97129465,18776), + ("20",21492872,18766), ("2",149670253,18746), ("10",49649785,18737), ("10",125062922,18725), ("22",51154624,18693), + ("20",57815879,18683), ("2",76497569,18675), ("8",96701949,18673), ("1",87612820,18670), ("5",158974585,18664), + ("13",58980956,18664), ("2",156229090,18654), ("5",159334986,18638), ("14",101316928,18631), ("3",42692075,18627), + ("7",55163429,18609), ("17",63881123,18590), ("9",73721557,18579), ("1",177235920,18568), ("3",10800230,18565), + ("2",66495731,18555), ("2",6162803,18553), ("6",102243030,18543), ("5",160945102,18539), ("7",94527596,18539), + ("11",128360895,18538), ("5",113693991,18537), ("3",127979662,18534) ] diff --git a/src/Bio/Genocall/Metadata.hs b/src/Bio/Genocall/Metadata.hs deleted file mode 100644 --- a/src/Bio/Genocall/Metadata.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleContexts, BangPatterns #-} --- | Metadata necessary for a sensible genotyping workflow. -module Bio.Genocall.Metadata where - -import Bio.Adna ( DamageParameters(..) ) -import Control.Applicative hiding ( empty ) -import Control.Concurrent ( threadDelay ) -import Control.Exception ( bracket, onException, handleJust ) -import Control.Monad ( forM_ ) -import Data.Aeson -import Data.Binary -import Data.Binary.Get ( runGetOrFail ) -import Data.Binary.Put ( runPut ) -import Data.ByteString.Lazy ( toChunks, readFile ) -import Data.ByteString.Unsafe ( unsafeUseAsCStringLen ) -import Data.Monoid -import Data.Text ( Text, pack ) -import Foreign.Ptr ( castPtr ) -import GHC.IO.Exception ( IOErrorType(..) ) -import Prelude hiding ( writeFile, readFile ) -import System.IO.Error ( isAlreadyExistsErrorType, ioeGetErrorType ) -import System.Posix.Files ( rename, removeLink ) -import System.Posix.IO - -import qualified Data.HashMap.Strict as M -import qualified Data.Vector.Unboxed as U - -data DivTable = DivTable !Double !(U.Vector Int) - deriving Show - -data Sample = Sample { - sample_libraries :: [Library], - sample_avro_files :: M.HashMap Text Text, -- ^ maps a region to the av file - sample_bcf_files :: M.HashMap Text Text, -- ^ maps a region to the bcf file - sample_div_tables :: M.HashMap Text DivTable, -- ^ maps a region to the table needed for div. estimation - sample_divergences :: M.HashMap Text DivEst - } deriving Show - -data Library = Library { - library_name :: Text, - library_files :: [Text], - library_damage :: Maybe (DamageParameters Double) - } deriving Show - --- | Divergence estimate. Lists contain three or four floats, these are --- divergence, heterozygosity at W sites, heterozygosity at S sites, and --- optionally gappiness in this order. -data DivEst = DivEst { - point_est :: [Double], - conf_region :: [( [Double], [Double] )] - } deriving Show - - -type Metadata = M.HashMap Text Sample - -instance ToJSON DivEst where - toJSON DivEst{..} = object $ [ "estimate" .= point_est - , "confidence-region" .= conf_region ] - -instance Binary DivEst where - put DivEst{..} = put point_est >> put conf_region - get = DivEst <$> get <*> get - -instance FromJSON DivEst where - parseJSON (Object o) = DivEst <$> o .: "estimate" <*> o .:? "confidence-region" .!= [] - parseJSON (Array a) = flip DivEst [] <$> parseJSON (Array a) - parseJSON _ = fail $ "divergence estimate should be an array or an object" - -instance ToJSON float => ToJSON (DamageParameters float) where - toJSON DP{..} = object [ "ss-sigma" .= ssd_sigma - , "ss-delta" .= ssd_delta - , "ss-lambda" .= ssd_lambda - , "ss-kappa" .= ssd_kappa - , "ds-sigma" .= dsd_sigma - , "ds-delta" .= dsd_delta - , "ds-lambda" .= dsd_lambda ] - -instance Binary float => Binary (DamageParameters float) where - put DP{..} = put ssd_sigma >> put ssd_delta >> put ssd_lambda >> put ssd_kappa >> - put dsd_sigma >> put dsd_delta >> put dsd_lambda - get = DP <$> get <*> get <*> get <*> get <*> get <*> get <*> get - -instance FromJSON float => FromJSON (DamageParameters float) where - parseJSON = withObject "damage parameters" $ \o -> - DP <$> o .: "ss-sigma" - <*> o .: "ss-delta" - <*> o .: "ss-lambda" - <*> o .: "ss-kappa" - <*> o .: "ds-sigma" - <*> o .: "ds-delta" - <*> o .: "ds-lambda" - -instance ToJSON Library where - toJSON (Library name files dp) = object ( maybe id ((:) . ("damage" .=)) dp - $ [ "name" .= name, "files" .= files ] ) - -instance Binary Library where - put Library{..} = put library_name >> put library_files >> put library_damage - get = Library <$> get <*> get <*> get - -instance FromJSON Library where - parseJSON (String name) = return $ Library name [name <> ".bam"] Nothing - parseJSON (Object o) = Library <$> o .: "name" - <*> (maybe id (:) <$> o .:? "file" - <*> o .:? "files" .!= []) - <*> o .:? "damage" - parseJSON _ = fail "String or Object expected for library" - -instance ToJSON Sample where - toJSON (Sample ls avfs bcfs dts ds) = object $ hashToJson "divergences" ds $ - listToJson "libraries" ls $ - hashToJson "avro-files" avfs $ - hashToJson "bcf-files" bcfs $ - hashToJson "div-tables" dts [] - where - hashToJson k vs = if M.null vs then id else (:) (k .= vs) - listToJson k vs = if null vs then id else (:) (k .= vs) - -instance Binary Sample where - put Sample{..} = put sample_libraries >> putObject sample_avro_files >> - putObject sample_bcf_files >> putObject sample_div_tables >> - putObject sample_divergences - get = Sample <$> get <*> getObject <*> getObject <*> getObject <*> getObject - -instance FromJSON Sample where - parseJSON (String s) = pure $ Sample [Library s [s <> ".bam"] Nothing] M.empty M.empty M.empty M.empty - parseJSON (Array ls) = (\ll -> Sample ll M.empty M.empty M.empty M.empty) <$> parseJSON (Array ls) - parseJSON (Object o) = Sample <$> o .: "libraries" - <*> (M.singleton "" <$> o .: "avro-file" <|> o .:? "avro-files" .!= M.empty) - <*> (M.singleton "" <$> o .: "bcf-file" <|> o .:? "bcf-files" .!= M.empty) - <*> o .:? "div-tables" .!= M.empty - <*> (M.singleton "" <$> o .: "divergence" <|> o.:? "divergences" .!= M.empty) - parseJSON _ = fail $ "String, Array or Object expected for Sample" - -instance FromJSON DivTable where - parseJSON x = parseJSON x >>= \[a,b] -> DivTable <$> parseJSON a <*> parseJSON b - -instance Binary DivTable where - put (DivTable a b) = put a >> putVector b - get = DivTable <$> get <*> getVector - -instance ToJSON DivTable where - toJSON (DivTable a b) = toJSON [toJSON a, toJSON b] - -putObject :: Binary value => M.HashMap Text value -> Put -putObject m = put (M.size m) >> M.foldrWithKey (\k v a -> put k >> put v >> a) (return ()) m - -getObject :: Binary value => Get (M.HashMap Text value) -getObject = get >>= \l -> get_map M.empty (l::Int) - where - get_map !acc 0 = return acc - get_map !acc n = get >>= \k -> get >>= \v -> get_map (M.insert k v acc) (n-1) - --- Hm. I'm putting the vector in reverse order, because the --- accumulation when reading reverses it. -putVector :: (U.Unbox a, Binary a) => U.Vector a -> Put -putVector v = put (U.length v) >> U.mapM_ put (U.reverse v) - -getVector :: (U.Unbox a, Binary a) => Get (U.Vector a) -getVector = get >>= \l -> U.fromListN l <$> get_list [] l - where - get_list acc 0 = return acc - get_list acc n = get >>= \ !x -> get_list (x:acc) (n-1) - - --- | Read the configuration file. Retries, because NFS tends to result --- in 'ResourceVanished' if the file is replaced while we try to read it. -readJsonMetadata :: FilePath -> IO Metadata -readJsonMetadata fn = either error return . eitherDecode =<< go (15::Int) - where - go !n = handleJust -- retry every sec for 15 seconds - (\e -> case ioeGetErrorType e of ResourceVanished | n > 0 -> Just () ; _ -> Nothing) - (\_ -> threadDelay 1000000 >> go (n-1)) - (readFile fn) - --- | Read the configuration file. Retries, because NFS tends to result --- in 'ResourceVanished' if the file is replaced while we try to read it. -readMetadata :: FilePath -> IO Metadata -readMetadata fn = either (error . show) (\(_,_,r) -> return r) . runGetOrFail getObject =<< go (15::Int) - where - go !n = handleJust -- retry every sec for 15 seconds - (\e -> case ioeGetErrorType e of ResourceVanished | n > 0 -> Just () ; _ -> Nothing) - (\_ -> threadDelay 1000000 >> go (n-1)) - (readFile fn) - --- | Update the configuration file. Open a new file (fn++"~new") in --- exclusive mode. Then read the old file, write the update to the new --- file, rename it atomically, then close it. Use of O_EXCL should --- ensure that nobody interferes. This is atomic even on NFS, provided --- NFS and kernel are new enough. For older NFS, I cannot be bothered. --- --- (The first idea was to base this on the supposed fact that link(2) is --- atomic and fails if the new filename exists. This approach does seem --- to contain a race condition, though.) -updateMetadata :: (Metadata -> Metadata) -> FilePath -> IO () -updateMetadata f fp = go (360::Int) -- retry every 5 secs for 30 minutes - where - fpn = fp <> "~new" - - go !n = handleJust - (\e -> if isAlreadyExistsErrorType (ioeGetErrorType e) && n > 0 then Just () else Nothing) - (\_ -> threadDelay 5000000 >> go (n-1)) $ do - bracket - (openFd fpn WriteOnly (Just 0o666) defaultFileFlags{ exclusive = True }) - (closeFd) $ \fd -> - (do mdata <- readMetadata fp - forM_ (toChunks . runPut . putObject $ f mdata) $ \ch -> - unsafeUseAsCStringLen ch $ \(p,l) -> - fdWriteBuf fd (castPtr p) (fromIntegral l) - rename fpn fp) - `onException` removeLink fpn - -writeMetadata :: FilePath -> Metadata -> IO () -writeMetadata fp mdata = bracket - (openFd fp WriteOnly (Just 0o666) defaultFileFlags{ exclusive = True }) - (closeFd) $ \fd -> - forM_ (toChunks . runPut . putObject $ mdata) $ \ch -> - unsafeUseAsCStringLen ch $ \(p,l) -> - fdWriteBuf fd (castPtr p) (fromIntegral l) - -split_sam_rgns :: Metadata -> [String] -> [( String, [Maybe String] )] -split_sam_rgns _meta [ ] = [] -split_sam_rgns meta (s:ss) = (s, if null rgns then [Nothing] else map Just rgns) : split_sam_rgns meta rest - where (rgns, rest) = break (\x -> pack x `M.member` meta) ss diff --git a/src/Bio/Iteratee.hs b/src/Bio/Iteratee.hs --- a/src/Bio/Iteratee.hs +++ b/src/Bio/Iteratee.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternGuards, BangPatterns, DeriveDataTypeable #-} - -- | Basically a reexport of "Data.Iteratee" less the names that clash -- with "Prelude" plus a handful of utilities. @@ -14,6 +12,10 @@ peekStream, takeStream, dropStream, + mapChunks, + mapChunksM, + mapStream, + rigidMapStream, mapStreamM, mapStreamM_, filterStream, @@ -21,15 +23,16 @@ foldStream, foldStreamM, zipStreams, + zipStreams3, protectTerm, concatMapStream, concatMapStreamM, mapMaybeStream, parMapChunksIO, + progressGen, progressNum, progressPos, - I.mapStream, I.takeWhileE, I.tryHead, I.isFinished, @@ -76,32 +79,27 @@ module Data.Iteratee.Iteratee ) where -import Bio.Base ( findAuxFile ) import Bio.Bam.Header import Bio.Util.Numeric ( showNum ) +import Bio.Prelude import Control.Concurrent.Async ( Async, async, wait, cancel ) -import Control.Monad -import Control.Monad.Catch +import Control.Monad.Catch ( MonadMask(..) ) import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.Binary.Get -import Data.Bits ( shiftR ) import Data.Iteratee.Binary import Data.Iteratee.Char import Data.Iteratee.IO hiding ( defaultBufSize ) -import Data.Iteratee.Iteratee hiding ( identity ) +import Data.Iteratee.Iteratee hiding ( identity, empty, mapChunks, mapChunksM, (>>>) ) 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 System.IO ( hIsTerminalDevice ) +import qualified Control.Monad.Catch as CMC import qualified Data.Attoparsec.ByteString as A import qualified Data.ByteString.Char8 as S import qualified Data.Iteratee as I import qualified Data.ListLike as LL +import qualified Data.NullPoint as N import qualified Data.Vector.Generic as VG import qualified Data.Vector.Generic.Mutable as VM @@ -111,7 +109,7 @@ -- 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) +groupStreamOn :: (Monad m, LL.ListLike l e, Eq t1, Nullable l) => (e -> t1) -> (t1 -> m (Iteratee l m t2)) -> Enumeratee l [(t1, t2)] m a @@ -149,7 +147,7 @@ -- 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) +groupStreamBy :: (Monad m, LL.ListLike l t, Nullable l) => (t -> t -> Bool) -> m (Iteratee l m t2) -> Enumeratee l [t2] m a @@ -205,7 +203,7 @@ -- | 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 :: Int -> Iteratee S.ByteString m S.ByteString iGetString 0 = idone S.empty (Chunk S.empty) iGetString n = liftI $ step [] 0 where @@ -223,7 +221,7 @@ -- | Convert a 'Get' into an 'Iteratee'. The 'Get' is applied once, the -- decoded data is returned, unneded input remains in the stream. -iterGet :: Monad m => Get a -> Iteratee S.ByteString m a +iterGet :: Get a -> Iteratee S.ByteString m a iterGet = go . runGetIncremental where go (Fail _ _ err) = throwErr (iterStrExc err) @@ -295,7 +293,7 @@ -- | 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 :: (Monad m, ListLike s a, NullPoint s) => (a -> t) -> Enumeratee s t m r concatMapStream f = eneeCheckIfDone (liftI . go) where go k (EOF mx) = idone (liftI k) (EOF mx) @@ -305,7 +303,7 @@ -- | 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 :: (Monad m, ListLike s a, NullPoint s) => (a -> m t) -> Enumeratee s t m r concatMapStreamM f = eneeCheckIfDone (liftI . go) where go k (EOF mx) = idone (liftI k) (EOF mx) @@ -314,7 +312,7 @@ 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 :: (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 @@ -323,12 +321,12 @@ -- | 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 :: (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 :: (Monad m, ListLike s a, Nullable 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 @@ -336,9 +334,40 @@ let acc' = if p then LL.cons (LL.head s) . acc else acc go acc' (LL.tail s) +{-# INLINE mapChunks #-} +mapChunks :: NullPoint s => (s -> s') -> Enumeratee s s' m a +mapChunks f = eneeCheckIfDonePass (icont . step) + where + step k (Chunk xs) = eneeCheckIfDonePass (icont . step) . k . Chunk $ f xs + step k str = idone (liftI k) str + +{-# INLINE mapChunksM #-} +mapChunksM :: (Monad m, NullPoint s) => (s -> m s') -> Enumeratee s s' m a +mapChunksM f = eneeCheckIfDonePass (icont . step) + where + step k (Chunk xs) = f xs `mBind` eneeCheckIfDonePass (icont . step) . k . Chunk + step k str = idone (liftI k) str + +-- | Map a function over an 'Iteratee'. +-- This one is reimplemented and differs from the the one in +-- "Data.Iteratee.ListLike" in so far that it doesn't pass on an 'EOF' +-- received in the input, which is the expected behavior. +{-# INLINE mapStream #-} +mapStream :: (ListLike (s el) el, ListLike (s el') el', NullPoint (s el)) + => (el -> el') -> Enumeratee (s el) (s el') m a +mapStream = mapChunks . LL.map + +-- | Map a function over an 'Iteratee' rigidly. +-- This one is reimplemented and differs from the the one in +-- "Data.Iteratee.ListLike" in so far that it doesn't pass on an 'EOF' +-- received in the input, which is the expected behavior. +{-# INLINE rigidMapStream #-} +rigidMapStream :: (ListLike s el, NullPoint s) => (el -> el) -> Enumeratee s s m a +rigidMapStream = mapChunks . LL.rigidMap + -- | 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') +mapStreamM :: (Monad m, ListLike (s el) el, ListLike (s el') el', NullPoint (s el)) => (el -> m el') -> Enumeratee (s el) (s el') m a mapStreamM = mapChunksM . LL.mapM @@ -364,6 +393,11 @@ => Iteratee s m a -> Iteratee s m b -> Iteratee s m (a, b) zipStreams = I.zip +-- | Apply three 'Iteratee's to the same stream. +zipStreams3 :: (Nullable s, ListLike s el, Monad m) + => Iteratee s m a -> Iteratee s m b -> Iteratee s m c -> Iteratee s m (a, b, c) +zipStreams3 = I.zip3 + 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) @@ -420,7 +454,7 @@ _ -> liftI $ go' qq k -- we have room for input - go' !qq k (EOF mx) = do a <- liftIO (async (f empty)) + go' !qq k (EOF mx) = do a <- liftIO (async (f N.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 @@ -441,30 +475,34 @@ 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) +-- | A general progress indicator that prints some message after a set +-- number of records have passed through. +progressGen :: (MonadIO m, NullPoint s, ListLike s a) + => (Int -> a -> String) -> Int -> (String -> IO ()) -> Enumeratee s s m b +progressGen msg sz 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 + go !n k (Chunk as) + | LL.null as = liftI $ go n k + | otherwise = let !n' = n + LL.length as + in when (n' `div` sz /= n `div` sz) (liftIO . put $ + "\27[K" ++ msg n' (LL.head as) ++ "\r") + `ioBind_` eneeCheckIfDonePass (icont . go n') (k $ Chunk as) --- | A simple progress indicator that prints a position. +-- | A simple progress indicator that prints the number of records. +progressNum :: (MonadIO m, NullPoint s, ListLike s a) + => String -> Int -> (String -> IO ()) -> Enumeratee s s m b +progressNum msg = progressGen (\n _ -> msg ++ " " ++ showNum n) + +-- | A simple progress indicator that prints a position every set number +-- of passed records. progressPos :: (MonadIO m, ListLike s a, NullPoint s) - => (a -> (Refseq, Int)) -> String -> (String -> IO ()) -> Refs -> Enumeratee s s m b -progressPos f msg put refs = eneeCheckIfDonePass (icont . go invalidRefseq 0) - where - go !_ !_ k (EOF mx) = idone (liftI k) (EOF mx) - go !rs0 !po0 k c@(Chunk as) - | LL.null as = liftI $ go rs0 po0 k - | otherwise = when (rs1 /= rs0 || po1 `shiftR` 19 /= po0 `shiftR` 19) - (let nm = S.unpack (sq_name (getRef refs rs1)) ++ ":" - in put $ "\27[K" ++ msg ++ nm ++ showNum po1 ++ "\r") - `ioBind_` eneeCheckIfDonePass (icont . go rs1 po1) (k c) - where (!rs1, !po1) = f (LL.head as) + => (a -> (Refseq, Int)) -> String -> Refs + -> Int -> (String -> IO ()) -> Enumeratee s s m b +progressPos f msg refs = + progressGen $ \_ a -> let (!rs1, !po1) = f a + !nm = unpack . sq_name $ getRef refs rs1 + in msg ++ " " ++ nm ++ ":" ++ showNum po1 -- A very simple queue data type. -- Invariants: q = QQ l f b --> l == length f + length b @@ -496,7 +534,7 @@ 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 :: A.Parser a -> Iteratee S.ByteString m a parserToIteratee p = icont (f (A.parse p)) Nothing where f k (EOF Nothing) = @@ -542,7 +580,7 @@ go (i+1) mv' withFileFd :: (MonadIO m, MonadMask m) => FilePath -> (Fd -> m a) -> m a -withFileFd filepath iter = bracket +withFileFd filepath iter = CMC.bracket (liftIO $ openFd filepath ReadOnly Nothing defaultFileFlags) (liftIO . closeFd) iter diff --git a/src/Bio/Iteratee/Bgzf.hsc b/src/Bio/Iteratee/Bgzf.hsc --- a/src/Bio/Iteratee/Bgzf.hsc +++ b/src/Bio/Iteratee/Bgzf.hsc @@ -1,6 +1,3 @@ -{-# 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. @@ -15,12 +12,8 @@ ) where import Bio.Iteratee -import Control.Concurrent ( getNumCapabilities ) +import Bio.Prelude 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 ) @@ -37,38 +30,38 @@ -- 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 } + , block_contents :: {-# UNPACK #-} !Bytes } -instance NullPoint Block where empty = Block 0 S.empty +instance NullPoint Block where empty = mempty instance Nullable Block where nullC (Block _ s) = S.null s instance Monoid Block where - mempty = empty + mempty = Block 0 S.empty mappend (Block x s) (Block _ t) = Block x (s `S.append` t) - mconcat [] = empty + mconcat [] = Block 0 S.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 +-- offset in the input stream is tracked and added to the @Bytes@s -- giving @Block@s. This results in the same interface as decompressing -- actual Bgzf. -decompressPlain :: MonadIO m => Enumeratee S.ByteString Block m a +decompressPlain :: MonadIO m => Enumeratee Bytes 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 +-- | Decompress a BGZF stream into a stream of 'Bytes's. +decompressBgzf :: MonadIO m => Enumeratee Bytes Bytes m a decompressBgzf = decompressBgzfBlocks ><> mapChunks block_contents -decompressBgzfBlocks :: MonadIO m => Enumeratee S.ByteString Block m a +decompressBgzfBlocks :: MonadIO m => Enumeratee Bytes 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' :: MonadIO m => Int -> Enumeratee Bytes Block m a decompressBgzfBlocks' np = eneeCheckIfDonePass (go 0 emptyQ) where -- check if the queue is full @@ -110,7 +103,7 @@ | 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 :: MonadIO m => FileOffset -> Iteratee Bytes m (FileOffset, IO Block) get_bgzf_block off = do !(csize,xlen) <- get_bgzf_header !comp <- get_block . fromIntegral $ csize - xlen - 19 !crc <- endianRead4 LSB @@ -129,7 +122,7 @@ -- | 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 :: Monad m => Iteratee Bytes m (Word16, Word16) get_bgzf_header = do n <- I.heads "\31\139" _cm <- I.head flg <- I.head @@ -151,14 +144,12 @@ -- | Tests whether a stream is in BGZF format. Does not consume any -- input. -isBgzf :: Monad m => Iteratee S.ByteString m Bool +isBgzf :: Monad m => Iteratee Bytes 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 :: Monad m => Iteratee Bytes m Bool isGzip = liftM (either (const False) id) $ checkErr $ iLookAhead $ test where test = do n <- I.heads "\31\139" @@ -177,7 +168,7 @@ -- | 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 :: Bytes 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. @@ -189,7 +180,7 @@ -- 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 +-- got, compute crc for each and check it, finally convert to 'Bytes' -- and emit. -- -- We could probably get away with @unsafePerformIO@'ing everything in @@ -197,7 +188,7 @@ -- anyway. Hence, run in IO. -decompress1 :: FileOffset -> [S.ByteString] -> Word32 -> Int -> IO Block +decompress1 :: FileOffset -> [Bytes] -> Word32 -> Int -> IO Block decompress1 off ss crc usize = allocaBytes (#{const sizeof(z_stream)}) $ \stream -> do buf <- mallocBytes usize @@ -247,7 +238,7 @@ -- 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 :: Int -> [Bytes] -> IO Bytes compress1 _lv [] = return bgzfEofMarker compress1 lv ss0 = allocaBytes (#{const sizeof(z_stream)}) $ \stream -> do @@ -274,8 +265,8 @@ (-15) 8 #{const Z_DEFAULT_STRATEGY} -- loop over the fragments. In reverse order! - let loop (s:ss) = do - crc <- loop ss + let go (s:ss) = do + crc <- go ss S.unsafeUseAsCString s $ \p -> case fromIntegral $ S.length s of l | l > 0 -> do @@ -284,8 +275,8 @@ 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 + go [] = c_crc32 0 nullPtr 0 + crc <- go ss0 z_check "deflate" =<< c_deflate stream #{const Z_FINISH} z_check "deflateEnd" =<< c_deflateEnd stream @@ -347,15 +338,15 @@ -- 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 :: 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 +-- | Runs an @Iteratee@ for @Bytes@s when decompressing BGZF. Adds -- internal bookkeeping. -liftBlock :: Monad m => Iteratee S.ByteString m a -> Iteratee Block m a +liftBlock :: Monad m => Iteratee Bytes m a -> Iteratee Block m a liftBlock = liftI . step where step it (EOF ex) = joinI $ lift $ enumChunk (EOF ex) it @@ -368,7 +359,7 @@ onDone od hdr (EOF ex) = od hdr (EOF ex) --- | Compresses a stream of @ByteString@s into a stream of BGZF blocks, +-- | Compresses a stream of @Bytes@s into a stream of BGZF blocks, -- in parallel -- We accumulate an uncompressed block as long as adding a new chunk to @@ -377,12 +368,12 @@ -- 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' :: MonadIO m => CompressParams -> Enumeratee BgzfChunk Bytes 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 +data BgzfChunk = SpecialChunk !Bytes BgzfChunk + | RecordChunk !Bytes BgzfChunk + | LeftoverChunk !Bytes BgzfChunk | NoChunk instance NullPoint BgzfChunk where empty = NoChunk @@ -393,11 +384,11 @@ 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 chunk on output is represented as a list of 'Bytes', -- each list must be reversed and concatenated to be compressed. -- ('compress1' does that.) -bgzfBlocks :: Monad m => Enumeratee BgzfChunk [S.ByteString] m a +bgzfBlocks :: Monad m => Enumeratee BgzfChunk [Bytes] m a bgzfBlocks = eneeCheckIfDone (liftI . to_blocks 0 []) where -- terminate by sending the last block and then an empty block, @@ -442,10 +433,10 @@ | 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 :: MonadIO m => Enumeratee BgzfChunk Bytes m a compressBgzf = compressBgzfLv 6 -compressBgzfLv :: MonadIO m => Int -> Enumeratee BgzfChunk S.ByteString m a +compressBgzfLv :: MonadIO m => Int -> Enumeratee BgzfChunk Bytes m a compressBgzfLv lv out = do np <- liftIO $ getNumCapabilities compressBgzf' (CompressParams lv (np+2)) out @@ -455,7 +446,7 @@ queue_depth :: Int } deriving Show -compressChunk :: Int -> Ptr CChar -> CUInt -> IO S.ByteString +compressChunk :: Int -> Ptr CChar -> CUInt -> IO Bytes compressChunk lv ptr len = allocaBytes (#{const sizeof(z_stream)}) $ \stream -> do buf <- mallocBytes 65536 diff --git a/src/Bio/Iteratee/Builder.hs b/src/Bio/Iteratee/Builder.hs --- a/src/Bio/Iteratee/Builder.hs +++ b/src/Bio/Iteratee/Builder.hs @@ -1,4 +1,3 @@ -{-# 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/ @@ -9,22 +8,24 @@ -- 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. +-- +-- XXX This may not be the most clever way to do it. According to the +-- reasoning behind the binary-serialise-cbor package, it would be more +-- clever to have a representation of the things we can 'Push' that's +-- similar to a list, and then a function (an Iteratee?) that consumes +-- the list of tokens and fills a buffer. module Bio.Iteratee.Builder where -import Bio.Iteratee +import Bio.Iteratee hiding ( NullPoint ) import Bio.Iteratee.Bgzf -import Data.Bits -import Data.Monoid -import Data.Primitive.Addr -import Data.Primitive.ByteArray -import Data.Word ( Word8, Word16, Word32 ) +import Bio.Prelude +import Data.NullPoint ( NullPoint(..) ) +import Foreign.ForeignPtr import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr -import Foreign.Storable ( peek, poke ) -import GHC.Exts -import System.IO.Unsafe ( unsafePerformIO ) +import Foreign.Storable import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B @@ -36,7 +37,8 @@ -- 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) +data BB = BB { buffer :: {-# UNPACK #-} !(ForeignPtr Word8) + , size :: {-# UNPACK #-} !Int , len :: {-# UNPACK #-} !Int , mark :: {-# UNPACK #-} !Int , mark2 :: {-# UNPACK #-} !Int } @@ -56,30 +58,35 @@ empty = Push return --- | Creates a buffer with initial capacity of ~128k. -newBuffer :: IO BB -newBuffer = newPinnedByteArray 128000 >>= \arr -> return $ BB arr 0 0 0 +-- | Creates a buffer with a given initial capacity. +newBuffer :: Int -> IO BB +newBuffer sz = mallocForeignPtrBytes sz >>= \ar -> return $ BB ar sz 0 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 +ensureBuffer n = Push $ \b -> + if len b + n < size b + 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 } +expandBuffer b = do arr1 <- mallocForeignPtrBytes (size b + size b) + withForeignPtr arr1 $ \d -> + withForeignPtr (buffer b) $ \s -> + copyBytes d s (len b) + return $ BB { buffer = arr1 + , size = size b + size b + , len = len b + , mark = mark b + , mark2 = mark2 b } {-# INLINE unsafePushByte #-} unsafePushByte :: Word8 -> Push unsafePushByte w = Push $ \b -> do - writeByteArray (buffer b) (len b) w + withForeignPtr (buffer b) $ \p -> + pokeByteOff p (len b) w return $ b { len = len b + 1 } {-# INLINE pushByte #-} @@ -109,10 +116,10 @@ {-# 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 } + B.unsafeUseAsCStringLen bs $ \(p,ln) -> + withForeignPtr (buffer b) $ \adr -> + b { len = len b + ln } <$ + copyBytes (adr `plusPtr` len b) p ln {-# INLINE pushByteString #-} pushByteString :: B.ByteString -> Push @@ -120,10 +127,9 @@ {-# INLINE unsafePushFloat #-} unsafePushFloat :: Float -> Push -unsafePushFloat f = unsafePushWord32 i - where - i :: Word32 - i = unsafePerformIO $ alloca $ \b -> poke (castPtr b) f >> peek b +unsafePushFloat f = + unsafePushWord32 $ unsafeDupablePerformIO $ + alloca $ \b -> poke (castPtr b) f >> peek b {-# INLINE pushFloat #-} pushFloat :: Float -> Push @@ -148,12 +154,12 @@ -- preceded by a corresponding 'setMark'. {-# INLINE endRecord #-} endRecord :: Push -endRecord = Push $ \b -> do +endRecord = Push $ \b -> withForeignPtr (buffer b) $ \p -> 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) + pokeByteOff p (mark b + 0) (fromIntegral $ shiftR l 0 :: Word8) + pokeByteOff p (mark b + 1) (fromIntegral $ shiftR l 8 :: Word8) + pokeByteOff p (mark b + 2) (fromIntegral $ shiftR l 16 :: Word8) + pokeByteOff p (mark b + 3) (fromIntegral $ shiftR l 24 :: Word8) return b -- | Ends the first part of a record. The length is filled in *before* @@ -163,12 +169,12 @@ -- of 'setMark'. {-# INLINE endRecordPart1 #-} endRecordPart1 :: Push -endRecordPart1 = Push $ \b -> do +endRecordPart1 = Push $ \b -> withForeignPtr (buffer b) $ \p -> do let !l = len b - mark b - 4 - writeByteArray (buffer b) (mark b - 4) (fromIntegral $ shiftR l 0 :: Word8) - writeByteArray (buffer b) (mark b - 3) (fromIntegral $ shiftR l 8 :: Word8) - writeByteArray (buffer b) (mark b - 2) (fromIntegral $ shiftR l 16 :: Word8) - writeByteArray (buffer b) (mark b - 1) (fromIntegral $ shiftR l 24 :: Word8) + pokeByteOff p (mark b - 4) (fromIntegral $ shiftR l 0 :: Word8) + pokeByteOff p (mark b - 3) (fromIntegral $ shiftR l 8 :: Word8) + pokeByteOff p (mark b - 2) (fromIntegral $ shiftR l 16 :: Word8) + pokeByteOff p (mark b - 1) (fromIntegral $ shiftR l 24 :: Word8) return $ b { mark2 = len b } -- | Ends the second part of a record. The length is filled in at the @@ -178,37 +184,37 @@ -- 'setMark' and one of 'endRecordPart1'. {-# INLINE endRecordPart2 #-} endRecordPart2 :: Push -endRecordPart2 = Push $ \b -> do +endRecordPart2 = Push $ \b -> withForeignPtr (buffer b) $ \p -> do let !l = len b - mark2 b - 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) + pokeByteOff p (mark b + 0) (fromIntegral $ shiftR l 0 :: Word8) + pokeByteOff p (mark b + 1) (fromIntegral $ shiftR l 8 :: Word8) + pokeByteOff p (mark b + 2) (fromIntegral $ shiftR l 16 :: Word8) + pokeByteOff p (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 +encodeBgzfWith lv o = newBuffer 128000 `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) + = withForeignPtr (buffer bb) + (\p -> moveBytes p (p `plusPtr` 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)) + = withForeignPtr (buffer bb) + (\adr -> compressChunk lv (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)) + = withForeignPtr (buffer bb) + (\adr -> compressChunk lv (castPtr adr) (fromIntegral $ len bb)) `ioBind` eneeCheckIfDone (finalFlush2 mx) . k . Chunk | otherwise diff --git a/src/Bio/Iteratee/ZLib.hsc b/src/Bio/Iteratee/ZLib.hsc --- a/src/Bio/Iteratee/ZLib.hsc +++ b/src/Bio/Iteratee/ZLib.hsc @@ -1,11 +1,5 @@ -{-# 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. -} +-- Stolen from iteratee-compress module, which doesn't work due to +-- dependency problems. Modified for proper early-out behaviour. module Bio.Iteratee.ZLib ( -- * Enumeratees @@ -43,6 +37,7 @@ import Data.Typeable import Foreign import Foreign.C +import Prelude #ifdef DEBUG import qualified Foreign.Concurrent as C import System.IO (stderr) @@ -555,13 +550,8 @@ 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 + avail_out <- liftIO $ withZStream zstr #{peek z_stream, avail_out} + case avail_out :: CInt of 0 -> do out <- liftIO $ pullOutBuffer zstr _out out' <- liftIO $ putOutBuffer size zstr @@ -589,12 +579,8 @@ 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 + avail_out <- liftIO $ withZStream zstr #{peek z_stream, avail_out} + case avail_out :: CInt of 0 -> do out <- liftIO $ pullOutBuffer zstr _out eneeCheckIfDone (finish size run' fin) $ iter (Chunk out) @@ -654,9 +640,9 @@ 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 + _ <- 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) @@ -671,15 +657,15 @@ 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 + _ <- 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 + _ <- 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) @@ -717,10 +703,10 @@ ret <- inflate' zstr param case fromErrno ret of Left NeedDictionary -> do - withForeignPtr fp $ \ptr -> - withZStream zstr $ \zptr -> - inflateSetDictionary zptr (ptr `plusPtr` off) - (fromIntegral len) + _ <- withForeignPtr fp $ \ptr -> + withZStream zstr $ \zptr -> + inflateSetDictionary zptr (ptr `plusPtr` off) + (fromIntegral len) inflate' zstr param _ -> return ret in insertOut size inflate'' init' iter diff --git a/src/Bio/Prelude.hs b/src/Bio/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Prelude.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE CPP, TypeOperators #-} +module Bio.Prelude ( + module Bio.Base, + module BasePrelude, + module System.Posix.Files, + module System.Posix.IO, + module System.Posix.Types, + Bytes, LazyBytes, + HashMap, + HashSet, + IntMap, + IntSet, + Text, LazyText, + Pair(..), +#ifndef __HADDOCK__ +#ifdef __GLASGOW_HASKELL__ + (:!:), +#endif +#endif + +#if !MIN_VERSION_base(4,7,0) + isLeft, + isRight, +#endif + +#if !MIN_VERSION_base(4,8,0) + first, + second, +#endif + + decodeBytes, + encodeBytes, + + Hashable(..), + Unpack(..), + hPutStr, + hPutStrLn, + fdPut, + fdPutLazy, + withFd, + stderr, + stdout, + stdin + ) where + +import BasePrelude +#if MIN_VERSION_base(4,9,0) + hiding ( EOF, log1p, log1pexp, log1mexp, expm1 ) +#elif MIN_VERSION_base(4,7,0) + hiding ( EOF ) +#else + hiding ( EOF, block ) +#endif + +#if !MIN_VERSION_base(4,8,0) +-- Not as nice as Data.Bifunctor, but still useful. +import Control.Arrow ( first, second ) +#endif + +import Bio.Base +import Data.ByteString ( ByteString ) +import Data.Text ( Text ) +import Data.Hashable ( Hashable(..) ) +import Data.HashMap.Strict ( HashMap ) +import Data.HashSet ( HashSet ) +import Data.IntMap ( IntMap ) +import Data.IntSet ( IntSet ) +import Data.Text.Encoding ( encodeUtf8, decodeUtf8With ) +import Foreign.C.Error ( throwErrnoIf_ ) +import Foreign.Ptr ( castPtr ) +import System.IO ( hPutStr, hPutStrLn, stderr, stdout, stdin ) +import System.Posix.Files +import System.Posix.IO +import System.Posix.Types + +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as S +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +type Bytes = ByteString +type LazyBytes = BL.ByteString +type LazyText = TL.Text + +infixl 2 :!: + +-- | A strict pair. +data Pair a b = !a :!: !b deriving(Eq, Ord, Show, Read, Bounded, Ix) + +#ifndef __HADDOCK__ +#ifdef __GLASGOW_HASKELL__ +-- This gives a nicer syntax for the type but only works in GHC for now. +type (:!:) = Pair +#endif +#endif + +-- | Class of things that can be unpacked into 'String's. Kind of the +-- opposite of 'IsString'. +class Unpack s where unpack :: s -> String + +instance Unpack ByteString where unpack = S.unpack +instance Unpack Text where unpack = T.unpack +instance Unpack String where unpack = id + +#if !MIN_VERSION_base(4,7,0) +isLeft, isRight :: Either a b -> Bool +isLeft = either (const False) (const True) +isRight = either (const True) (const False) +#endif + +fdPut :: Fd -> Bytes -> IO () +fdPut fd s = B.unsafeUseAsCStringLen s $ \(p,l) -> + throwErrnoIf_ (/= fromIntegral l) "fdPut" $ + fdWriteBuf fd (castPtr p) (fromIntegral l) + +fdPutLazy :: Fd -> LazyBytes -> IO () +fdPutLazy fd = mapM_ (fdPut fd) . BL.toChunks + +withFd :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags + -> (Fd -> IO a) -> IO a +withFd fp om fm ff k = bracket (openFd fp om fm ff) closeFd k + +-- | Converts 'Bytes' into 'Text'. This uses UTF8, but if there is an +-- error, it pretends it was Latin1. Evil as this is, it tends to Just +-- Work on files where nobody ever wasted a thought on encodings. +decodeBytes :: Bytes -> Text +decodeBytes = decodeUtf8With (const $ fmap w2c) + +-- | Converts 'Text' into 'Bytes'. This uses UTF8. +encodeBytes :: Text -> Bytes +encodeBytes = encodeUtf8 + diff --git a/src/Bio/PriorityQueue.hs b/src/Bio/PriorityQueue.hs --- a/src/Bio/PriorityQueue.hs +++ b/src/Bio/PriorityQueue.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} module Bio.PriorityQueue ( Sizeable(..), PQ_Conf(..), @@ -17,9 +16,10 @@ import Data.Binary import Data.IORef import qualified Control.Exception as CE +import Prelude --- | A Priority Queue that can fall back to external storage. --- +-- | 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. -- @@ -27,7 +27,7 @@ -- 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. +-- 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 @@ -101,7 +101,7 @@ writeIORef pq (p',s') --- | Returns the minimum element from the queue. +-- | 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) @@ -118,24 +118,24 @@ -- 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 :: 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 :: SkewHeap a -> Maybe a getMin Empty = Nothing getMin (Node x _ _) = Just x - + dropMin :: Ord a => SkewHeap a -> SkewHeap a dropMin Empty = error "dropMin on empty queue... are you sure?!" dropMin (Node _ l r) = l `union` r diff --git a/src/Bio/TwoBit.hs b/src/Bio/TwoBit.hs --- a/src/Bio/TwoBit.hs +++ b/src/Bio/TwoBit.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE BangPatterns, NamedFieldPuns, RecordWildCards #-} module Bio.TwoBit ( - module Bio.Base, - TwoBitFile(..), TwoBitSequence(..), openTwoBit, @@ -25,21 +22,15 @@ Mask(..) ) where -import Bio.Base -import Control.Applicative -import Control.Monad -import Data.Bits +import Bio.Prelude hiding ( left, right, chr ) import Data.Binary.Get import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import Data.Char (toLower) -- can't use Data.IntMap.Strict to remain compatible with -- containers-0.4.1 and therefore ghc 7.4 :-( import qualified Data.IntMap as I import qualified Data.HashMap.Lazy as M -import Data.Maybe import qualified Data.Vector.Unboxed as U -import Numeric import System.IO.Posix.MMap import System.Random @@ -162,7 +153,7 @@ -- 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 sq1 = maybe (error $ unpack chr ++ " doesn't exist") id $ M.lookup chr (tbf_seqs tbf) let go = getFwdSubseqWith tbf sq1 if start < 0 then reverse $ take len $ go (maskf . cmp_nt) (-start-len) @@ -174,7 +165,7 @@ -- | Works only in forward direction. getLazySubseq :: TwoBitFile -> Position -> [Nucleotide] getLazySubseq tbf (Pos { p_seq = chr, p_start = start }) = do - let sq1 = maybe (error $ unpackSeqid chr ++ " doesn't exist") id $ M.lookup chr (tbf_seqs tbf) + let sq1 = maybe (error $ unpack chr ++ " doesn't exist") id $ M.lookup chr (tbf_seqs tbf) let go = getFwdSubseqWith tbf sq1 if start < 0 then error "sorry, can't go backwards" diff --git a/src/Bio/Util/AD.hs b/src/Bio/Util/AD.hs --- a/src/Bio/Util/AD.hs +++ b/src/Bio/Util/AD.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE BangPatterns #-} module Bio.Util.AD ( AD(..), paramVector, minimize , module Numeric.Optimization.Algorithms.HagerZhang05 , debugParameters, quietParameters + , IsDouble(..) ) where import Numeric.Optimization.Algorithms.HagerZhang05 import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Storable as V +import Prelude -- | Simple forward-mode AD to get a scalar valued function with gradient. data AD = C !Double | D !Double !(U.Vector Double) deriving Show @@ -131,3 +132,6 @@ debugParameters :: Parameters debugParameters = defaultParameters { verbose = Verbose } +class IsDouble a where fromDouble :: Double -> a +instance IsDouble Double where fromDouble = id +instance IsDouble AD where fromDouble = C diff --git a/src/Bio/Util/AD2.hs b/src/Bio/Util/AD2.hs --- a/src/Bio/Util/AD2.hs +++ b/src/Bio/Util/AD2.hs @@ -1,12 +1,17 @@ -{-# LANGUAGE BangPatterns #-} -module Bio.Util.AD2 ( AD2(..), paramVector2 ) where +module Bio.Util.AD2 ( AD2(..), paramVector2, IsDouble(..), confidenceIntervals ) where -import qualified Data.Vector.Unboxed as U +import Bio.Util.AD ( IsDouble(..) ) +import Bio.Util.Jacobi +import Prelude +import qualified Data.Vector.Unboxed as U + -- | Simple forward-mode AD to get a scalar valued function -- with gradient and Hessian. data AD2 = C2 !Double | D2 !Double !(U.Vector Double) !(U.Vector Double) +instance IsDouble AD2 where fromDouble = C2 + instance Show AD2 where show (C2 x) = show x show (D2 x y z) = show x ++ " " ++ show (U.toList y) ++ " " @@ -97,7 +102,7 @@ tan = liftF tan (\x -> recip (sqr (cos x))) (\x -> 2 * tan x / sqr (cos x)) tanh = liftF tanh (\x -> recip (sqr (cosh x))) (\x -> -2 * tanh x / sqr (cosh x)) - + asin = liftF asin (\x -> recip (sqrt (1 - sqr x))) (\x -> x / sqrt (cube (1 - sqr x))) acos = liftF acos (\x -> - recip (sqrt (1 - sqr x))) (\x -> -x / sqrt (cube (1 - sqr x))) asinh = liftF asinh (\x -> recip (sqrt (sqr x + 1))) (\x -> -x / sqrt (cube (sqr x + 1))) @@ -129,4 +134,17 @@ paramVector2 xs = [ D2 x (U.generate l (\j -> if i == j then 1 else 0)) nil | (i,x) <- zip [0..] xs ] where l = length xs ; nil = U.replicate (l*l) 0 + +-- | Confidence region: PCA on Hessian matrix, then for each +-- eigenvalue λ add/subtract 1.96 / sqrt λ times the corresponding +-- eigenvalue to the estimate. Should describe a nice spheroid. +confidenceIntervals :: ([AD2] -> AD2) -> U.Vector Double -> [(U.Vector Double, U.Vector Double)] +confidenceIntervals fun fit = intervs + where + D2 _val _grd hss = fun (paramVector2 $ U.toList fit) + (evals, evecs) = eigenS hss + intervs = [ ( U.zipWith (\a b -> a + lam * b) fit evec + , U.zipWith (\a b -> a - lam * b) fit evec ) + | (eval, evec) <- zip (U.toList evals) evecs + , let lam = 1.96 / sqrt eval ] diff --git a/src/Bio/Util/Jacobi.hs b/src/Bio/Util/Jacobi.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Util/Jacobi.hs @@ -0,0 +1,89 @@ +-- | Jacobi algorithm for Eigen decomposition of symmetric matrices. + +module Bio.Util.Jacobi ( eigenS ) where + +import Bio.Prelude + +import qualified Data.Vector.Unboxed as U ( Vector, thaw, unsafeFreeze, fromListN, slice ) +import qualified Data.Vector.Unboxed.Mutable as U ( read, write, MVector, length, replicate ) + +type Matrix = U.Vector Double +type Vector = U.Vector Double + +type MMatrix s = U.MVector s Double + + +-- | Decomposes a symmetric matrix into a vector of eigenvalues and a +-- vector of eigenvectors. + +eigenS :: Matrix -> ( Vector, [Vector] ) +eigenS mat = runST (do + m <- U.thaw mat + let n = round (sqrt (fromIntegral (U.length m) :: Double)) + + v <- U.replicate (n*n) 0 + forM_ [0..n-1] $ \i -> U.write v (n*i+i) 1 + + let j_iter !rd = do + sm <- sum . map abs <$> sequence + [ U.read m (p*n+q) | p <- [1..n-2], q <- [p+1..n-1] ] + case () of + _ | sm == 0 -> return () -- normal exit: convergence to machine precision + | rd == 50 -> return () -- 50 iters, weird, but IDGAF. + | otherwise -> do + let thresh = if rd < 3 then 0.2 * sm / fromIntegral (n*n) else 0 + forM_ [1..n-1] $ \k -> + forM_ [0..k-1] $ \l -> + jacobi_rot n thresh (l,k) m v + j_iter (rd+1) + j_iter (0::Int) + + d <- U.fromListN n <$> forM [0..n-1] (\i -> U.read m (n*i+i)) + v' <- U.unsafeFreeze v + return (d, [ U.slice i n v' | i <- [0,n..n*n-1] ])) + + +-- | Performs one Jacobi rotation at @(p,q)@. We operate on the upper +-- triangle, so at all times @p Double -> (Int,Int) -> MMatrix s -> MMatrix s -> ST s () +jacobi_rot n thresh (p,q) m v = do + a_pp <- U.read m (p*n+p) + a_pq <- U.read m (p*n+q) + a_qq <- U.read m (q*n+q) + let g = 100 * abs a_pq + + case () of + _ | abs a_pq <= thresh -> return () + | abs a_pp + g == abs a_pp && + abs a_qq + g == abs a_qq -> U.write v (p*n+q) 0 + | otherwise -> do + let theta = 0.5 * (a_qq-a_pp) / a_pq + t = if theta*theta + 1 == theta*theta + then recip $ 2 * theta -- approx for overflow case + else signum theta / ( abs theta + sqrt ( theta*theta +1 ) ) + c = recip $ sqrt $ t*t + 1 + s = c*t + tau = s / (1+c) + + forM_ [0..n-1] $ \r -> do + when (r/=p && r/=q) $ do + a_rp <- U.read m $ min (r*n+p) (p*n+r) + a_rq <- U.read m $ min (r*n+q) (q*n+r) + + let a_rp' = a_rp - s * (a_rq + tau * a_rp) + a_rq' = a_rq + s * (a_rp - tau * a_rq) + + U.write m (min (r*n+p) (p*n+r)) a_rp' + U.write m (min (r*n+q) (q*n+r)) a_rq' + + v_rp <- U.read v (p*n+r) + v_rq <- U.read v (q*n+r) + + U.write v (p*n+r) $ v_rp - s * (v_rq + tau * v_rp) + U.write v (q*n+r) $ v_rq + s * (v_rp - tau * v_rq) + + U.write m (p*n+q) 0 + U.write m (p*n+p) $ a_pp - t * a_pq + U.write m (q*n+q) $ a_qq + t * a_pq + diff --git a/src/Bio/Util/Numeric.hs b/src/Bio/Util/Numeric.hs --- a/src/Bio/Util/Numeric.hs +++ b/src/Bio/Util/Numeric.hs @@ -2,12 +2,14 @@ wilson, invnormcdf, choose, estimateComplexity, showNum, showOOM, log1p, expm1, (<#>), + log1mexp, log1pexp, lsum, llerp, sigmoid2, isigmoid2 ) where import Data.List ( foldl1' ) import Data.Char ( intToDigit ) +import Prelude -- ^ Random useful stuff I didn't know where to put. @@ -147,7 +149,7 @@ infixl 5 <#> {-# INLINE (<#>) #-} (<#>) :: (Floating a, Ord a) => a -> a -> a -x <#> y = if x >= y then x + log1p (exp (y-x)) else y + log1p (exp (x-y)) +x <#> y = if x >= y then x + log1pexp (y-x) else y + log1pexp (x-y) -- | 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 @@ -163,15 +165,31 @@ -- | 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 +{-# INLINE expm1 #-} 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 +-- | Computes @log (1 - exp x)@, following Martin Mächler. +{-# INLINE log1mexp #-} +log1mexp :: (Floating a, Ord a) => a -> a +log1mexp x | x > - log 2 = log (- expm1 x) + | otherwise = log1p (- exp x) + +-- | Computes @log (1 + exp x)@, following Martin Mächler. +{-# INLINE log1pexp #-} +log1pexp :: (Floating a, Ord a) => a -> a +log1pexp x | x <= -37 = exp x + | x <= 18 = log1p $ exp x + | x <= 33.3 = x + exp (-x) + | otherwise = x + + -- | Computes \( \log ( \sum_i e^{x_i} ) \) sensibly. The list must be -- sorted in descending(!) order. {-# INLINE lsum #-} lsum :: (Floating a, Ord a) => [a] -> a -lsum xs = foldl1' (\x y -> if x >= y then x + log1p (exp (y-x)) else err) xs +lsum xs = foldl1' (\x y -> if x >= y then x + log1pexp (y-x) else err) xs where err = error $ "lsum: argument list must be in descending order" -- | Computes \( \log \left( c e^x + (1-c) e^y \right) \). @@ -179,8 +197,8 @@ llerp :: (Floating a, Ord a) => a -> a -> a -> a llerp c x y | c <= 0.0 = y | c >= 1.0 = x - | x >= y = log c + x + log1p ( (1-c)/c * exp (y-x) ) - | otherwise = log1p (-c) + y + log1p ( c/(1-c) * exp (x-y) ) + | x >= y = log c + x + log1p ( (1-c)/c * exp (y-x) ) -- Hmm. + | otherwise = log1p (-c) + y + log1p ( c/(1-c) * exp (x-y) ) -- Hmm. -- | Binomial coefficient: @n `choose` k == n! / ((n-k)! k!)@ {-# INLINE choose #-} @@ -191,11 +209,11 @@ -- | Kind-of sigmoid function that maps the reals to the interval -- @[0,1)@. Good to compute a probability without introducing boundary -- conditions. -sigmoid2 :: (Num a, Fractional a, Floating a) => a -> a +sigmoid2 :: (Fractional a, Floating a) => a -> a sigmoid2 x = y*y where y = (exp x - 1) / (exp x + 1) -- | Inverse of 'sigmoid2'. -isigmoid2 :: (Num a, Fractional a, Floating a) => a -> a +isigmoid2 :: (Fractional a, Floating a) => a -> a isigmoid2 y = log $ (1 + sqrt y) / (1 - sqrt y) diff --git a/src/Bio/Util/Regex.hsc b/src/Bio/Util/Regex.hsc deleted file mode 100644 --- a/src/Bio/Util/Regex.hsc +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} --- | The absolute minimum necessary for regex matching using POSIX regexec. -module Bio.Util.Regex ( Regex, regComp, regMatch )where - -#include -#include - -import Control.Applicative -import Control.Monad -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.Marshal.Alloc -import Foreign.C.String -import Foreign.C.Types -import System.IO.Unsafe - -newtype Regex = Regex (ForeignPtr Regex) - -regComp :: String -> Regex -regComp re = unsafePerformIO $ do - fp <- mallocForeignPtrBytes #{size regex_t} - withForeignPtr fp $ \p -> do - withCString re $ \pre -> do - ec <- regcomp p pre (#{const REG_EXTENDED} + #{const REG_NOSUB}) - when (ec /= 0) $ do - sz <- regerror ec p nullPtr 0 - allocaBytes (fromIntegral sz) $ \err -> do - _ <- regerror ec p err sz - peekCString err >>= error . (++) "regexec: " - addForeignPtrFinalizer regfree fp - return $ Regex fp - -regMatch :: Regex -> String -> Bool -regMatch (Regex fp) str = - unsafePerformIO $ - withForeignPtr fp $ \p -> - withCString str $ \s -> - (==) 0 <$> regexec p s 0 nullPtr 0 - - -foreign import ccall unsafe regcomp :: Ptr Regex -> CString -> CInt -> IO CInt -foreign import ccall unsafe regexec :: Ptr Regex -> CString -> CSize -> Ptr () -> CInt -> IO CInt -foreign import ccall unsafe regerror :: CInt -> Ptr Regex -> CString -> CSize -> IO CSize -foreign import ccall unsafe "®free" regfree :: FunPtr (Ptr Regex -> IO ()) diff --git a/src/Bio/Util/Zlib.hs b/src/Bio/Util/Zlib.hs new file mode 100644 --- /dev/null +++ b/src/Bio/Util/Zlib.hs @@ -0,0 +1,23 @@ +module Bio.Util.Zlib ( decompressGzip ) where + +import Prelude + +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L ( ByteString(..) ) +import qualified Codec.Compression.Zlib.Internal as Z + + +-- | Decompresses Gzip or Bgzf and passes everything else on. In +-- reality, it simply decompresses Gzip, and when done, looks for +-- another Gzip stream. Trailing garbage is returned as is, therefore, +-- uncompressed files are passed through. Since there is a small chance +-- to attempt compression of an uncompressed stream, the original data +-- is returned in case of an error. +decompressGzip :: L.ByteString -> L.ByteString +decompressGzip s = case L.uncons s of + Just (31, s') -> case L.uncons s' of + Just (139,_) -> Z.foldDecompressStreamWithInput L.Chunk decompressGzip (const s) + (Z.decompressST Z.gzipOrZlibFormat Z.defaultDecompressParams) s + _ -> s + _ -> s + diff --git a/src/Data/Avro.hs b/src/Data/Avro.hs deleted file mode 100644 --- a/src/Data/Avro.hs +++ /dev/null @@ -1,541 +0,0 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, TemplateHaskell #-} -{-# LANGUAGE RecordWildCards, BangPatterns, FlexibleContexts #-} -{-# LANGUAGE PatternGuards #-} -module Data.Avro where - -import Bio.Iteratee -import Control.Applicative -import Control.Monad -import Data.Aeson -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 ( Word8, Word32, Word64 ) -import Foreign.Marshal.Alloc ( alloca ) -import Foreign.Storable ( Storable, sizeOf, peek, pokeByteOff ) -import Language.Haskell.TH -import System.Random -import System.IO.Unsafe ( unsafeDupablePerformIO ) - -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. - --- | 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 - - --- | Making schemas requires a memo table of type definitions. -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 - -getNamedSchema :: String -> MkSchema Value -getNamedSchema nm = MkSchema $ \k h -> - let nm' = T.pack nm - in case H.lookup nm' h of - Nothing -> error $ "Schema for " ++ nm ++ " not provided." - -- Use the provided schema now, use only the name next time. - Just obj -> k obj $! H.insert nm' (String nm') h - - -runMkSchema :: MkSchema Value -> H.HashMap T.Text Value -> Value -runMkSchema x = mkSchema x postproc - 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 Word8 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 = cast x - -{-# INLINE wordToDouble #-} -wordToDouble :: Word64 -> Double -wordToDouble x = cast x - -{-# INLINE floatToWord #-} -floatToWord :: Float -> Word32 -floatToWord x = cast x - -{-# INLINE doubleToWord #-} -doubleToWord :: Double -> Word64 -doubleToWord x = cast x - -{-# INLINE cast #-} -cast :: ( Storable a, Storable b ) => a -> b -cast x | sizeOf x == sizeOf y = y - | otherwise = error "cannot cast: size mismatch" - where - y = unsafeDupablePerformIO $ alloca $ \buf -> - pokeByteOff buf 0 x >> peek buf - --- | 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 .&. 0x7f) `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 = decodeIntBase128 - --- 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 (ConE '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 - , initial_schemas :: H.HashMap T.Text Value - , meta_info :: H.HashMap T.Text 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) initial_schemas - - meta = H.insert "avro.schema" (B.concat $ BL.toChunks schema) $ - H.insert "avro.codec" "null" $ - H.insert "biohazard.filetype" filetype_label $ meta_info - - 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 = zigInt 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 - --- | Avro Meta Data is currently unprocessed. Contains the codec, the --- schema, a version number. -type AvroMeta = H.HashMap T.Text B.ByteString - --- | Decodes an AVRO container file into a list. Meta data is passed --- on. Note that if this blows up, it's usually due to it being applied --- at the wrong type. Be sure to correctly count the brackets... --- --- XXX Possible codecs: null, zlib, snappy, lzma; all missing --- XXX Should check schema on reading. - -readAvroContainer :: (Monad m, Avro a) => Enumeratee' AvroMeta B.ByteString [a] m r -readAvroContainer out = do - 4 <- heads "Obj\1" -- enough magic? - meta <- iterGet fromBin - sync_marker <- iGetString 16 - - flip iterLoop (out meta) $ \o -> do - _num <- iterGet zagInt - sz <- iterGet zagInt - -- liftIO $ hPutStrLn stderr $ "got block: " ++ showNum num - -- ++ " things in " ++ showNum sz ++ " bytes." - o' <- joinI $ takeStream sz -- codec goes here - $ convStream (LL.singleton `liftM` iterGet fromBin) o - 16 <- heads sync_marker - -- liftIO $ hPutStrLn stderr "got good sync" - return o' - --- | Finds a names schema from the meta data of an Avro container. -findSchema :: T.Text -> AvroMeta -> Value -findSchema nm meta = maybe Null go $ decodeStrict =<< H.lookup "avro.schema" meta - where - go :: Value -> Value - go (Object obj) - | Just (String k) <- H.lookup "name" obj, k == nm -- found it - = Object obj - | Just (String "record") <- H.lookup "type" obj -- record, descend into "fields" - = maybe Null go_struct $ H.lookup "fields" obj - | Just (String "array") <- H.lookup "type" obj -- array, descend into "items" - = maybe Null go_union $ H.lookup "items" obj - | Just (String "map") <- H.lookup "type" obj -- map, descend into "values" - = maybe Null go $ H.lookup "values" obj - - go _ = Null - - go_struct (Array arr) = V.foldr (try_next . go') Null arr -- struct fields, recurse into "type" subfield - go_struct _ = Null - - go' (Object o) | Just o' <- H.lookup "type" o = go o' - go' _ = Null - - go_union (Array arr) = V.foldr (try_next . go) Null arr -- union arms, recurse - go_union _ = Null - - try_next Null b = b - try_next a _ = a - - diff --git a/src/Data/MiniFloat.hs b/src/Data/MiniFloat.hs deleted file mode 100644 --- a/src/Data/MiniFloat.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleInstances, CPP #-} -{-# LANGUAGE MultiParamTypeClasses, TemplateHaskell #-} -module Data.MiniFloat ( Mini(..), float2mini, mini2float ) where - -import Data.Bits -import Data.Ix -import Data.Word ( Word8 ) -import Data.Vector.Unboxed.Deriving ( derivingUnbox ) - -#if __GLASGOW_HASKELL__ == 704 -import Data.Vector.Generic ( Vector(..) ) -import Data.Vector.Generic.Mutable ( MVector(..) ) -#endif - -data Mini = Mini { unMini :: Word8 } deriving ( Eq, Ord, Show, Ix, Bounded ) - -derivingUnbox "Mini" [t| Mini -> Word8 |] [| unMini |] [| Mini |] - --- | 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 -> Mini -float2mini f | f' < 0 = error "no negative minifloats" -- negative zero is fine! - | f < 2 = Mini f' - | e >= 17 = Mini 0xff - | s < 16 = error $ "oops: " ++ show (e,s) - | s < 32 = Mini $ (e-1) `shiftL` 4 .|. (s .&. 0xf) - | s == 32 = Mini $ 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 => Mini -> a -mini2float (Mini w) | e == 0 = fromIntegral w / 8.0 - | otherwise = 2^e * fromIntegral m / 16.0 - where - m = (w .&. 0xF) .|. 0x10 - e = w `shiftR` 4 - - diff --git a/src/cbits/myers_align.c b/src/cbits/myers_align.c --- a/src/cbits/myers_align.c +++ b/src/cbits/myers_align.c @@ -4,8 +4,6 @@ #include #include -inline int match( char a, char b ) { return (char_to_bitmap(a) & char_to_bitmap(b)) != 0 ; } - // [*blech*, this looks and feels like FORTRAN.] unsigned myers_diff( const char *seq_a, int len_a, enum myers_align_mode mode, diff --git a/src/cbits/myers_align.h b/src/cbits/myers_align.h --- a/src/cbits/myers_align.h +++ b/src/cbits/myers_align.h @@ -39,7 +39,7 @@ //! \brief converts an IUPAC-IUB ambiguity code to a bitmap Each base is //! represented by a bit, makes checking for matches easier. -inline int char_to_bitmap( char x ) +static inline int char_to_bitmap( char x ) { switch( x & ~32 ) { @@ -66,10 +66,11 @@ } } -inline int compatible( char x, char y ) { return (char_to_bitmap(x) & char_to_bitmap(y)) != 0 ; } +static inline int compatible( char x, char y ) { return (char_to_bitmap(x) & char_to_bitmap(y)) != 0 ; } +static inline int match( char a, char b ) { return (char_to_bitmap(a) & char_to_bitmap(b)) != 0 ; } -inline int min( int a, int b ) { return a < b ? a : b ; } -inline int max( int a, int b ) { return a < b ? b : a ; } -inline int max3( int a, int b, int c ) { return a < b ? max( b, c ) : max( a, c ) ; } +static inline int min( int a, int b ) { return a < b ? a : b ; } +static inline int max( int a, int b ) { return a < b ? b : a ; } +static inline int max3( int a, int b, int c ) { return a < b ? max( b, c ) : max( a, c ) ; } #endif diff --git a/tests/test-pileup.hs b/tests/test-pileup.hs new file mode 100644 --- /dev/null +++ b/tests/test-pileup.hs @@ -0,0 +1,12 @@ +import Bio.Bam +import Bio.Bam.Pileup +import Bio.Prelude + +main :: IO () +main = do + bams <- getArgs + mergeInputs combineCoordinates bams >=> run $ \_ -> + takeWhileE (isValidRefseq . b_rname . unpackBam) =$ + concatMapStream (decompose $ DmgToken 0) =$ + pileup =$ + skipToEof diff --git a/tools/Align.hs b/tools/Align.hs --- a/tools/Align.hs +++ b/tools/Align.hs @@ -1,15 +1,7 @@ -{-# 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 Bio.Prelude import Data.Sequence ( (<|), (><), ViewL((:<)) ) import qualified Data.Foldable as F @@ -294,10 +286,10 @@ -- we concatenate. finalize_ref_seq :: NewRefSeq -> (RefSeq, XTab) finalize_ref_seq (NRS z) = - ( RS $ U.concat $ F.foldr unpack [] z + ( RS $ U.concat $ F.foldr unpck [] z , Z.fromList $ scanl (+) 0 $ F.foldr tolen [] z) where - unpack (NC ins bas) k = map5 call ins ++ call bas : k + unpck (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 diff --git a/tools/Anno.hs b/tools/Anno.hs --- a/tools/Anno.hs +++ b/tools/Anno.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wall #-} module Anno where import Data.List +import Prelude -- What does this header mean? -- >Feature ref|NC_012920.1| diff --git a/tools/Index.hs b/tools/Index.hs --- a/tools/Index.hs +++ b/tools/Index.hs @@ -1,17 +1,13 @@ -{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-} +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, CPP #-} 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 Bio.Prelude import Data.Vector.Unboxed.Deriving -import Data.Word ( Word64 ) -import Foreign.Storable ( Storable ) #if __GLASGOW_HASKELL__ == 704 import Data.Vector.Generic ( Vector(..) ) diff --git a/tools/Seqs.hs b/tools/Seqs.hs --- a/tools/Seqs.hs +++ b/tools/Seqs.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wall #-} module Seqs where import Data.ByteString.Char8 (ByteString) diff --git a/tools/SimpleSeed.hs b/tools/SimpleSeed.hs --- a/tools/SimpleSeed.hs +++ b/tools/SimpleSeed.hs @@ -1,13 +1,7 @@ -{-# 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 Bio.Prelude import qualified Data.IntMap as IM import qualified Data.Vector.Generic as V @@ -73,20 +67,8 @@ -- 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) ")" - +do_seed ln (SM sm) BamRec{..} = case rgns of [ ] -> Nothing + (a,b,_) : _ -> Just (a,b) where seeds = filter ((/= 0) . fst) $ filter ((/= template) . fst) $ filter ((>= 0) . snd) $ create_seed_words $ V.toList b_seq diff --git a/tools/Xlate.hs b/tools/Xlate.hs --- a/tools/Xlate.hs +++ b/tools/Xlate.hs @@ -1,11 +1,10 @@ -{-# 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 +import Prelude -- aligned sequences in, coodinate on first in, coordinate on second out xpose :: S.ByteString -> S.ByteString -> Int -> Int diff --git a/tools/afroengineer.hs b/tools/afroengineer.hs --- a/tools/afroengineer.hs +++ b/tools/afroengineer.hs @@ -1,6 +1,3 @@ -{-# 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 :) -- @@ -15,30 +12,17 @@ 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 Numeric -import Prelude hiding ( round ) +import Bio.Prelude hiding ( round, left, right ) import System.Console.GetOpt -import System.Directory ( doesFileExist ) -import System.Environment -import System.Exit -import System.IO +import System.Directory ( doesFileExist ) 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.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 @@ -59,10 +43,10 @@ -- 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_ +data QueryRec = QR { qr_name :: !Seqid -- from BAM + , qr_seq :: !QuerySeq -- sequence and quality + , qr_pos :: !RefPosn -- start position of band + , qr_band :: !Bandwidth } -- bandwidth (negative to indicate reversed sequence_ deriving Show data Conf = Conf { @@ -153,7 +137,7 @@ (RefSeq, [QueryRec]) -- new reference & queries out roundN rs out = do ((), (rs', xtab), qry') <- mapStream aln =$ filterStream good =$ - I.zip3 out mkref collect + zipStreams3 out mkref collect return (rs', reverse $ map (xlate xtab) qry') where @@ -248,9 +232,9 @@ , 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 (ix, 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 ] + , let base = S.index letters $ if good then ix 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) @@ -287,7 +271,7 @@ (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 :: MonadIO m => Enumeratee S.ByteString [BamRec] m b unzipFastq = ZLib.enumInflateAny ><> parseFastq unite_pairs :: Monad m => Iteratee [BamRec] (Iteratee [BamRec] m) [BamRec] diff --git a/tools/bam-fixpair.hs b/tools/bam-fixpair.hs --- a/tools/bam-fixpair.hs +++ b/tools/bam-fixpair.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings, FlexibleContexts, RecordWildCards #-} - +{-# LANGUAGE CPP #-} {- This is a validator/fixup for paired end BAM files, that is more efficient than 'samtools sort -n' followed by 'samtools fixmate'. @@ -16,10 +15,10 @@ 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 + - reasonably, if there are occasional widows, 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 + - awkwardly, if sorting is violated, flags are wrong or widows are the rule, because then it degenerates to a full sort by qname. TODO: @@ -28,32 +27,24 @@ 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.Trim -import Bio.Bam.Writer -import Bio.Iteratee +import Bio.Bam hiding ( mergeInputs, combineCoordinates ) +import Bio.Prelude hiding ( yield ) import Bio.PriorityQueue import Bio.Util.Numeric ( showNum ) -import Control.Arrow ( (&&&) ) -import Control.Applicative -import Control.Monad +import Control.Concurrent.Async +import Control.Concurrent.STM.TQueue +import Control.Concurrent.STM.TVar 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 System.Process +#if MIN_VERSION_process(1,2,1) + hiding ( createPipe ) +#endif import qualified Data.ByteString as S +import qualified Data.ByteString.Builder as B import qualified Data.Vector.Generic as V data Verbosity = Silent | Errors | Warnings | Notices deriving (Eq, Ord) @@ -67,19 +58,22 @@ , report_ixs :: !Bool , verbosity :: Verbosity , killmode :: KillMode - , output :: BamMeta -> Iteratee [BamRec] IO () + , infilter :: BamPair -> Bool + , output :: BamMeta -> Iteratee [BamRec] IO ExitCode , fixsven :: Maybe Int } config0 :: IO Config -config0 = return $ CF True True False True False True Errors KillNone (protectTerm . pipeBamOutput) Nothing +config0 = return $ CF True True False True False True Errors KillNone + (const True) (fmap (const ExitSuccess) . protectTerm . pipeBamOutput) Nothing options :: [OptDescr (Config -> IO Config)] options = [ - Option "o" ["output"] (ReqArg set_output "FILE") "Write output to FILE", + Option "o" ["output"] (ReqArg set_output "FILE") "Write output to FILE", + Option "X" ["exec"] (NoArg return) "Send FastQ output to a program", 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 "k" ["kill-widows"] (NoArg (\c -> return $ c { killmode = KillAll })) "Delete all widows", + Option "u" ["kill-unmapped"](NoArg (\c -> return $ c { killmode = KillUu })) "Delete unmapped widows", + Option [ ] ["kill-none"] (NoArg (\c -> return $ c { killmode = KillNone })) "Never delete widows (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", @@ -91,14 +85,16 @@ 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 "" ["report-ixs"] (NoArg (\c -> return $ c { report_ixs = False })) "Report mismatched index fields (default yes)", 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 "" ["no-report-ixs"] (NoArg (\c -> return $ c { report_ixs = False })) "Do not report mismatched index fields", + Option "" ["only-mapped"] (NoArg (\c -> return $ c { infilter = mapped_only })) "Ignore totally unmapped input", Option "" ["fix-sven"] (ReqArg set_fixsven "QUAL") "Trim 3' ends of avg qual lower than QUAL", Option "h?" ["help","usage"] (NoArg usage) "Print this helpful message and exit", @@ -115,23 +111,84 @@ 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 } + set_output "-" c = return $ c { output = fmap (const ExitSuccess) . pipeBamOutput } + set_output f c = return $ c { output = fmap (const ExitSuccess) . writeBamFile f } + set_validate c = return $ c { output = \_ -> ExitSuccess <$ skipToEof } set_fixsven a c = readIO a >>= \q -> return $ c { fixsven = Just q } +mapped_only :: BamPair -> Bool +mapped_only p = case p of + Singleton a -> okay a + LoneMate a -> okay a + Pair a b -> okay a || okay b + where + okay = (\r -> not (isUnmapped r) || (isPaired r && not (isMateUnmapped r))) . unpackBam +pipe_to :: FilePath -> [String] -> ([Config -> IO Config], t1, t2) -> ([Config -> IO Config], t1, t2) +pipe_to cmd args (opts, errs, fs) = (mkout : opts, errs, fs) + where + mk1out key test (as, flush, qs, vs, ps, rfds) + | all (/= key) as = return (as, flush, qs, vs, ps, rfds) + | otherwise = do + (pout, pin) <- createPipe + setFdOption pin CloseOnExec True + queue <- newTQueueIO + vnum <- newTVarIO (0::Int) + pid <- async $ flush_fastq queue vnum pin + link pid + + return ( map (\a -> if a == key then "/dev/fd/" ++ show pout else a) as + , \br -> when (test br) (modifyTVar' vnum succ >> writeTQueue queue (Just br)) >> flush br + , queue : qs + , vnum : vs + , pid : ps + , pout : rfds ) + + mkout cfg = do + (args', flush_bam, queues, vars, pids, rfds) <- mk1out "CLOWNS" isFirstMate =<< + mk1out "JOKERS" isSecondMate =<< + mk1out "MIDDLE" (not . isPaired) + (args, const (return ()), [], [], [], []) + pid_cmd <- spawnProcess cmd args' + mapM_ closeFd rfds + + return $ cfg { output = \_ -> do + mapStreamM_ (\br -> atomically $ do ns <- mapM readTVar vars + when (minimum ns > 64) retry + flush_bam br) + liftIO $ do atomically $ mapM_ (flip writeTQueue Nothing) queues + mapM_ wait pids + waitForProcess pid_cmd } + + flush_fastq qq nn fd = do + mbr <- atomically $ readTQueue qq <* modifyTVar' nn pred + case mbr of + Just br -> do fdPutLazy fd . B.toLazyByteString $ + B.char8 '@' <> B.byteString (b_qname br) <> + (if isFirstMate br then B.char8 '/' <> B.char8 '1' else mempty) <> + (if isSecondMate br then B.char8 '/' <> B.char8 '2' else mempty) <> + B.char8 '\n' <> V.foldr ((<>) . B.char8 . showNucleotides) mempty (b_seq br) <> + B.char8 '\n' <> B.char8 '+' <> B.char8 '\n' <> + V.foldr ((<>) . B.word8 . (+) 33 . unQ) (B.char8 '\n') (b_qual br) + flush_fastq qq nn fd + Nothing -> return () + + -- XXX placeholder... pqconf :: PQ_Conf pqconf = PQ_Conf 1000 "/var/tmp/" -main :: IO () -main = do (opts, files, errors) <- getOpt Permute options `fmap` getArgs +main :: IO ExitCode +main = do (args,cmd) <- break (`elem` ["-X","--exec"]) `fmap` getArgs + let (opts, files, errors) = (case cmd of _:cmd':args' -> pipe_to cmd' args' ; _ -> id) + $ getOpt Permute options args + unless (null errors) $ mapM_ (hPutStrLn stderr) errors >> exitFailure config <- foldl (>>=) config0 opts add_pg <- addPG $ Just version withQueues $ \queues -> mergeInputs files >=> run $ \hdr -> + filterStream (infilter config) =$ re_pair queues config (meta_refs hdr) =$ mapChunks (maybe id do_trim (fixsven config)) =$ (output config) (add_pg hdr) @@ -144,7 +201,7 @@ 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)) + ++ unpack (b_qname (unpackBam r)) hPutStrLn stderr $ "There is no clear way to fix this file. Giving up." exitFailure where @@ -220,7 +277,7 @@ 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 +-- | Turns a widow 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 @@ -253,7 +310,7 @@ data MatingStats = MS { total_in :: !Int , total_out :: !Int , singletons :: !Int - , lone_mates :: !Int + , widows :: !Int , num_mrnm :: !Int , num_mpos :: !Int , num_isize :: !Int @@ -266,7 +323,7 @@ "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 widows: " ++ showNum (widows 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), @@ -323,7 +380,7 @@ ms <- getSize messed_up rr <- getRefseqs let BamRec{..} = unpackBam br - rn = unpackSeqid . sq_name $ getRef rr b_rname + rn = unpack . 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 @@ -340,7 +397,7 @@ 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 } + modify $ \c -> c { widows = 1 + widows c } kill <- tells killmode case kill of KillAll -> return () diff --git a/tools/bam-meld.hs b/tools/bam-meld.hs --- a/tools/bam-meld.hs +++ b/tools/bam-meld.hs @@ -1,4 +1,3 @@ -{-# 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 @@ -10,21 +9,10 @@ -- 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.String ( fromString ) -import Data.Version ( showVersion ) +import Bio.Bam +import Bio.Prelude 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 @@ -77,10 +65,10 @@ data BamPair = Single BamRec | Pair BamRec BamRec -find_pairs :: Monad m => Enumeratee [BamRec] [BamPair] m a +find_pairs :: Enumeratee [BamRec] [BamPair] m a find_pairs = mapStream Single -unpair :: Monad m => Enumeratee [BamPair] [BamRec] m a +unpair :: Enumeratee [BamPair] [BamRec] m a unpair = mapChunks (concatMap unpair1) where unpair1 (Single a) = [a] @@ -135,10 +123,10 @@ 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) + nm = fromString $ show $ extAsInt 0 "NM" b + cig = fromString $ show $ b_cigar b + pos = fromString $ (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)] diff --git a/tools/bam-resample.hs b/tools/bam-resample.hs --- a/tools/bam-resample.hs +++ b/tools/bam-resample.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -- Resample m out of n `virtual' BAM records. -- -- Strategy for fair down sampling: we first count the number of @@ -7,17 +6,10 @@ -- -- 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 Bio.Bam +import Bio.Prelude import Paths_biohazard ( version ) -import System.Environment -import System.Exit ( exitFailure ) import System.Random -import System.IO ( hPutStr ) main :: IO () main = do diff --git a/tools/bam-rewrap.hs b/tools/bam-rewrap.hs --- a/tools/bam-rewrap.hs +++ b/tools/bam-rewrap.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -- Re-wrap alignments to obey the given length of the reference -- sequence. -- @@ -25,13 +24,8 @@ import Bio.Bam import Bio.Bam.Rmdup -import Control.Monad ( when ) -import Data.Foldable ( toList ) -import Data.Version ( showVersion ) +import Bio.Prelude 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 @@ -56,13 +50,13 @@ 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 -> [String] -> ([(Refseq,(Int,Bytes))], 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 + [(l,[])] | l > 0 -> case filter (S.isPrefixOf (fromString 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) @@ -76,8 +70,10 @@ -- | 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) +-- parts. Rmdup fits in between the two, hence the split. We ignore +-- sorting in here. +rewrap :: M.Map Refseq (Int,Bytes) -> BamRec -> [BamRec] +rewrap m b = maybe [b] (\(l,nm) -> map (either id id) . wrapTo l . + either id id . normalizeTo nm l $ b) $ M.lookup (b_rname b) m diff --git a/tools/bam-rmdup.hs b/tools/bam-rmdup.hs --- a/tools/bam-rmdup.hs +++ b/tools/bam-rmdup.hs @@ -1,31 +1,16 @@ -{-# LANGUAGE RecordWildCards, BangPatterns, FlexibleContexts, OverloadedStrings #-} import Bio.Bam import Bio.Bam.Rmdup -import Bio.Base -import Bio.Util.Numeric ( 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.Ord ( comparing ) -import Data.Vector.Algorithms.Intro ( sortBy ) -import Data.Version ( showVersion ) -import Numeric ( showFFloat ) -import Paths_biohazard ( version ) +import Bio.Iteratee.Builder +import Bio.Prelude +import Bio.Util.Numeric ( showNum, showOOM, estimateComplexity ) +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 +import qualified Data.ByteString.Char8 as S +import qualified Data.HashMap.Strict as M +import qualified Data.IntMap as I +import qualified Data.Sequence as Z +import qualified Data.Vector.Generic as V data Conf = Conf { output :: Maybe ((BamRec -> Seqid) -> BamMeta -> Iteratee [BamRec] IO ()), @@ -38,11 +23,11 @@ transform :: BamRec -> Maybe BamRec, min_len :: Int, min_qual :: Qual, - get_label :: M.HashMap Seqid Seqid -> BamRec -> Seqid, + get_label :: HashMap Seqid Seqid -> BamRec -> Seqid, putResult :: String -> IO (), debug :: String -> IO (), which :: Which, - circulars :: Refs -> IO (IM.IntMap (Seqid,Int), Refs) } + circulars :: Refs -> IO (IntMap (Seqid,Int), Refs) } -- | Which reference sequences to scan data Which = Allrefs | Some Refseq Refseq | Unaln deriving Show @@ -62,7 +47,7 @@ , putResult = putStr , debug = \_ -> return () , which = Allrefs - , circulars = \rs -> return (IM.empty, rs) } + , circulars = \rs -> return (I.empty, rs) } options :: [OptDescr (Conf -> IO Conf)] options = [ @@ -115,14 +100,14 @@ 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) } + [(l,[])] | l > 0 -> return $ c { circulars = add_circular' (fromString 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 + [(k,a)] | sq_length a >= l -> let m2 = I.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 @@ -199,33 +184,41 @@ 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 ] + mapM_ debug [ unpack k ++ " --> " ++ unpack v ++ "\n" | (k,v) <- M.toList tbl ] - let filters = progressBam "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 cleanup = cleanup2 . transform . unpackBam - 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' })) + cleanup2 Nothing = return [] + cleanup2 (Just b) = cleanup3 <$> clean_multimap b - 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 + cleanup3 (Just b) + | keep_unaligned || is_aligned b + , keep_improper || is_proper b + , eff_len b >= min_len = [b] + cleanup3 _ = [ ] - 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') + (ct,ou) <- progressBam "Rmdup at" refs' 0x8000 debug =$ + takeWhileE is_halfway_aligned =$ + concatMapStreamM cleanup =$ + normalizeSortWith circtable =$ + filterStream (\b -> b_mapq b >= min_qual) =$ + case output of + Nothing -> rmdup (get_label tbl) strand_preserved (cheap_collapse' keep_all) =$ + count_all (get_label tbl) `zipStreams` (skipToEof <$ skipToEof) - case which of - Unaln -> do_copy - _ | keep_unaligned -> do_copy - _ -> do_bail + Just o -> rmdup (get_label tbl) strand_preserved (collapse keep_all) =$ + zipStreams (count_all (get_label tbl)) + (wrapSortWith circtable $ + o (get_label tbl) (add_pg hdr { meta_refs = refs' })) + let do_copy = progressBam "Copying junk at" refs' 0x8000 debug ><> + concatMapStreamM cleanup + + r <- case which of Unaln -> lift (run $ do_copy =$ ou) + _ | keep_unaligned -> lift (run $ do_copy =$ ou) + _ -> lift (run ou) + return (ct,r) + putResult . unlines $ "\27[K#RG\tin\tout\tin@MQ20\tsingle@MQ20\tunseen\ttotal\t%unique\t%exhausted" : map (uncurry do_report) (M.toList counts) @@ -237,7 +230,7 @@ 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 + label = if S.null lbl then "--" else unpack lbl report_estimate Nothing = [ "N/A" ] report_estimate (Just good_grand_total) = @@ -258,8 +251,8 @@ -- 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 +count_all :: Monad m => (BamRec -> Seqid) -> Iteratee [BamRec] m (M.HashMap Seqid Counts) +count_all lbl = M.map fixup `liftM` foldStream plus M.empty where plus m b = M.insert (lbl b) cs m where @@ -328,31 +321,24 @@ decodeAnyBamFile fp >=> run $ enum idx . k0 -writeLibBamFiles :: (MonadIO m, MonadMask m) +writeLibBamFiles :: MonadIO m => FilePath -> (BamRec -> Seqid) -> BamMeta -> Iteratee [BamRec] m () -writeLibBamFiles fp lbl hdr = tryHead >>= loop M.empty +writeLibBamFiles fp lbl hdr = tryHead >>= go M.empty where - loop m Nothing = liftIO . mapM_ run $ M.elems m - loop m (Just br) = do + go m Nothing = liftIO . mapM_ run $ M.elems m + go 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' + tryHead >>= go m' subst [ ] _ = [] - subst ('%':'s':rest) l = unpackSeqid l ++ subst rest l + subst ('%':'s':rest) l = unpack 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" @@ -365,36 +351,69 @@ b' = b { b_exts = deleteE "HI" $ deleteE "IH" $ deleteE "NH" $ b_exts b } +normalizeSortWith :: MonadIO m => IntMap (Seqid, Int) -> Enumeratee [BamRec] [BamRec] m a +normalizeSortWith m = mapSortAtGroups m $ \(nm,l) r -> [ normalizeTo nm l r ] + +wrapSortWith :: MonadIO m => IntMap (Seqid, Int) -> Enumeratee [BamRec] [BamRec] m a +wrapSortWith m = mapSortAtGroups m $ \(_,l) -> wrapTo l + -- 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 +-- +-- We accumulate the 'Left' and 'Right' 'BamRec's directly into two BBs. +-- This should result in two sorted BAM streams. When done, we stream +-- the buffers back (somehow...) and merge them. +mapSortAtGroups :: MonadIO m => IntMap a -> (a -> BamRec -> [Either BamRec BamRec]) -> Enumeratee [BamRec] [BamRec] m b +mapSortAtGroups 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 + no_group_1 a k Nothing = + case I.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 + Just arg -> do bbs <- pushTo (f arg a) (collect, collect) + cont_group (b_rname a) arg bbs 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 + cont_group _rn _arg _bbs k (Just e) = idone (liftI k) $ EOF (Just e) + cont_group rn arg bbs 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 + flush_eof = streamOut bbs (liftI k) + flush_go a = streamOut bbs (liftI k) >>= eneeCheckIfDonePass (no_group_1 a) + check1 a | b_rname a == rn = do bbs' <- pushTo (f arg a) bbs + cont_group rn arg bbs' 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) +collect :: MonadIO m => Iteratee [BamRec] m [Bytes] +collect = mapChunks (foldMap pushBam) ><> encodeBgzfWith 1 =$ liftI (chunksToList []) + where + chunksToList acc (Chunk x) = y `seq` liftI (chunksToList (y:acc)) where y = S.copy x + chunksToList acc (EOF mx) = idone (reverse acc) (EOF mx) -sortPos :: [BamRec] -> [BamRec] -sortPos l = VV.toList $ runST (VV.unsafeThaw (VV.fromList l) >>= \vm -> sortBy (comparing b_pos) vm >> VV.unsafeFreeze vm) + +pushTo :: Monad m => [Either BamRec BamRec] -> (Iteratee [BamRec] m a, Iteratee [BamRec] m a) + -> m (Iteratee [BamRec] m a, Iteratee [BamRec] m a) +pushTo es (bb1,bb2) = liftM2 (,) (enumPure1Chunk ls bb1) (enumPure1Chunk rs bb2) + where (ls,rs) = partitionEithers es + + +streamOut :: (MonadIO m, Nullable x) + => (Iteratee s (Iteratee x m) [Bytes], Iteratee s1 (Iteratee x m) [Bytes]) + -> Enumeratee x [BamRec] m a +streamOut (bb1,bb2) it = do + bs1 <- run bb1 + bs2 <- run bb2 + lift $ mergeEnums (streamBB bs1) (streamBB bs2) (mergeSortStreams (?)) it + where + (?) :: BamRec -> BamRec -> Ordering' BamRec + u ? v = if (b_rname &&& b_pos) u < (b_rname &&& b_pos) v then Less else NotLess + + streamBB :: MonadIO m => [Bytes] -> Enumerator [BamRec] m b1 + streamBB bb = enumList bb $= decompressBgzfBlocks $= convStream (map unpackBam `liftM` getBamRaw) + diff --git a/tools/bam-trim.hs b/tools/bam-trim.hs --- a/tools/bam-trim.hs +++ b/tools/bam-trim.hs @@ -1,12 +1,7 @@ import Bio.Bam -import Bio.Base -import Control.Monad ( unless, foldM ) -import Data.Version ( showVersion ) +import Bio.Prelude 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 } diff --git a/tools/fastq2bam.hs b/tools/fastq2bam.hs --- a/tools/fastq2bam.hs +++ b/tools/fastq2bam.hs @@ -1,59 +1,62 @@ -{-# 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 Bio.Prelude import System.Console.GetOpt -import System.Environment -import System.Exit import System.IO -import qualified Data.ByteString as B +import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as S -import qualified Data.Vector.Generic as V - --- TODO: --- - optional(!) GZip +import qualified Data.Vector.Generic as V -data Opts = Opts { output :: BamMeta -> Iteratee [BamRec] IO () - , inputs :: [Input] - , verbose :: Bool } +data Opts = Opts { output :: BamMeta -> Iteratee [BamRec] IO () + , inputs :: [Input] + , verbose :: Bool + , merge :: Bool } defaultOpts :: Opts -defaultOpts = Opts { output = protectTerm . pipeBamOutput - , inputs = [] - , verbose = False } +defaultOpts = Opts { output = protectTerm . pipeBamOutput + , inputs = [] + , verbose = False + , merge = False } -data Input = Input { _read1 :: FilePath - , read2 :: Maybe FilePath - , index1 :: Maybe FilePath - , index2 :: Maybe FilePath } +data Input = Input { _read1 :: FilePath -- ^ file with first read (or other stuff) + , read2 :: Maybe FilePath -- ^ optional file with second read + , index1 :: Maybe FilePath -- ^ optional file with first index + , index2 :: Maybe FilePath -- ^ optional file with second index + , lindex1 :: Int } -- ^ length of first index contained in first read deriving Show +plainInput :: FilePath -> Input +plainInput fn = Input fn Nothing Nothing Nothing 0 + 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" ] + [ 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 "l" ["length-index-one"] (ReqArg set_lidx1 "NUM") "Read 1 ends on NUM index bases" + , Option "m" ["merge-overlap"] (NoArg set_merge) "Attempt to merge or trim reads" + , 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_output "-" c = return $ c { output = pipeBamOutput } + set_output fn c = return $ c { output = writeBamFile fn } set_verbose c = return $ c { verbose = True } + set_merge c = return $ c { merge = True } - add_read1 fn c = return $ c { inputs = Input fn Nothing Nothing Nothing : inputs c } + add_read1 fn c = return $ c { inputs = plainInput fn : 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 ] + set_lidx1 a c = readIO a >>= \n -> return $ c { inputs = at_head (\i -> i { lindex1 = n}) (inputs c) } + + at_head f [ ] = [ f $ plainInput "-" ] at_head f (i:is) = f i : is usage _ = do pn <- getProgName @@ -69,13 +72,13 @@ 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 + let eff_inputs = if null (inputs conf) then [ plainInput "-" ] else inputs conf + when (verbose conf) $ mapM_ (hPrint stderr) eff_inputs foldr ((>=>) . enum_input) run (reverse eff_inputs) $ joinI $ progress (verbose conf) $ - joinI $ mapChunks concatDuals $ - ilift liftIO $ output conf (pgm mempty) + joinI $ mapChunks (if merge conf then mergeDuals else concatDuals) $ + output conf (pgm mempty) type UpToTwo a = (a, Maybe a) @@ -94,19 +97,44 @@ concatDuals ((a,Nothing):ds) = a : concatDuals ds concatDuals [ ] = [] +mergeDuals :: [UpToTwo BamRec] -> [BamRec] +mergeDuals ((r1,Just r2):ds) + = case merge_overlap r1 default_fwd_adapters r2 default_rev_adapters of + Nothing -> r1 : r2 : mergeDuals ds + Just (r1',r2',rm,_q1,_q2) -> rm : r1' : r2' : mergeDuals ds + +mergeDuals ((r1,Nothing):ds) + = case trim_adapter r1 default_fwd_adapters of + Nothing -> r1 : mergeDuals ds + Just (r1',r1t,_q1,_q2) -> r1t : r1' : mergeDuals ds + +mergeDuals [] = [] + -- 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 + 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 +enum_input (Input r1 mr2 mi1 mi2 il1) = enum $= mapStream (addIdx il1) + where + enum = withIndex mi1 "XI" "YI" $ withIndex mi2 "XJ" "YJ" $ + maybe (fromFastq r1 $= mapStream one) (enumDual r1) mr2 +addIdx :: Int -> UpToTwo BamRec -> UpToTwo BamRec +addIdx 0 brs = brs +addIdx l (br1, mbr2) = ( doext br1', fmap doext mbr2 ) + where + l' = V.length (b_seq br1) - l + + br1' = br1 { b_seq = V.take l' (b_seq br1), b_qual = V.take l' (b_qual br1) } + doext br = br { b_exts = updateE "XI" (Text xi) $ updateE "YI" (Text yi) $ b_exts br } + + xi = S.pack . map showNucleotides . V.toList . V.drop l' $ b_seq br1 + yi = B.pack . map ((+) 33 . unQ) . V.toList . V.drop l' $ b_qual br1 + -- Given an enumerator and maybe a filename, read index sequences from -- the file and merge them with the numerator. withIndex :: (MonadIO m, MonadMask m) @@ -160,7 +188,7 @@ 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 + when (n .&. complement 0x1fff /= n' .&. complement 0x1fff) $ liftIO $ do hPutStr stderr $ "\27[K" ++ replicate (l' - S.length nm) ' ' ++ S.unpack nm ++ ", " diff --git a/tools/gt-scan.hs b/tools/gt-scan.hs deleted file mode 100644 --- a/tools/gt-scan.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards, FlexibleContexts, TypeFamilies #-} --- Scan file with GT likelihoods, fit something... --- --- First iteration: Mitochondrion only. We don't need to fit --- anything. So far, the likelihoods behave strangely in that smaller --- \theta is always better, as long as it doesn't become zero. --- --- Second iteration: Mitochondrion only, but with a divergence --- parameter. Needs to be scanned in parallel with a TwoBit file. - -import Bio.Base -import Bio.Bam.Header -import Bio.Genocall.AvroFile -import Bio.Iteratee -import Bio.TwoBit -import Bio.Util.AD -import Bio.Util.Numeric -import Data.Avro -import Data.List ( intercalate ) -import Data.MiniFloat ( mini2float ) -import Data.Strict.Tuple ( Pair((:!:)) ) -import Numeric ( showFFloat ) - -import qualified Data.Vector.Storable as S -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Mutable as UM - -main :: IO () -main = do hg19 <- openTwoBit "/mnt/datengrab/hg19.2bit" - mtbl <- UM.replicate (max_lk-min_lk+1) 0 - - let all_lk tbl (p1 :!: p2) ref site = (lk0 p1 site :!:) `fmap` lk1 tbl p2 ref site - - p0 :!: pe <- enumDefaultInputs >=> run $ - joinI $ readAvroContainer $ \meta -> do - foldStreamM (lk_block (getRefseqs meta) (all_lk mtbl) hg19) (1 :!: 1) - - tbl <- U.unsafeFreeze mtbl - - -- optimize llk1 vs. d argument. - let plainfn :: U.Vector Double -> Double - plainfn args = llk1 tbl (unPr pe) $ args U.! 0 - - combofn :: U.Vector Double -> (Double, U.Vector Double) - combofn args = case llk1 tbl (C (unPr pe)) $ D (args U.! 0) (U.singleton 1) of - (D x dx) -> ( x, dx ) - - params = defaultParameters { printFinal = False, verbose = {- Verbose -} Quiet, maxItersFac = 20 } - - (x,q,s) <- optimize params 0.0001 (U.singleton 0.01) - (VFunction plainfn) - (VGradient $ snd . combofn) - (Just $ VCombined combofn) - - -- print $ llk1 tbl (C (unPr pe)) (D 0.001 (U.singleton 1)) - putStrLn $ intercalate "\t" - [ showNum (round $ unPr p0 :: Int), showFFloat (Just 5) (sigmoid2 $ x S.! 0) [] - , show q, showNum (round $ finalValue s :: Int), show s ] - -- print (map sigmoid2 $ S.toList x, q, s) - - --- | Scans block together with reference sequence. Folds a monadic --- action over the called sites. -lk_block :: Monad m => Refs -> (b -> Nucleotide -> GenoCallSite -> m b) -> TwoBitFile -> b -> GenoCallBlock -> m b -lk_block refs f tbf b GenoCallBlock{..} = foldM3f b start_position refseq called_sites - where - refseq = getLazySubseq tbf $ Pos (sq_name $ getRef refs reference_name) start_position - - foldM2 acc (x:xs) (y:ys) = do !acc' <- f acc x y ; foldM2 acc' xs ys - foldM2 acc [ ] _ = return acc - foldM2 acc _ [ ] = return acc - - - -- XXX terrible hack to deal with PhiX! Remove this as soon as - -- sensible! - foldM3f acc n (x:xs) (y:ys) - | n `elem` bad = foldM3f acc (succ n) xs ys - | otherwise = do !acc' <- f acc x y ; foldM3f acc' (succ n) xs ys - foldM3f acc _ [ ] _ = return acc - foldM3f acc _ _ [ ] = return acc - - bad = [1400,1643] - -- bad = [586,832,1649,2810,4517] - -{- p_block tbf GenoCallBlock{..} = do - printf "Block %s:%d-%d\n" (show reference_name) start_position - (start_position + length called_sites) - zipWithM_ (curry print) refseq (map snp_likelihoods called_sites) - where - refseq = getLazySubseq tbf (Pos (encodeUtf8 reference_name) start_position) -} - - - --- | Likelihood with flat prior (no parameters). -lk0 :: Prob -> GenoCallSite -> Prob -lk0 !pp GenoCallSite{..} | U.length snp_likelihoods == 4 = - pp * 0.25 * U.sum (U.map (Pr . negate . mini2float) snp_likelihoods) - | otherwise = pp - --- | Likelihood precomputation. Total likelihood computes as product --- over sites @i@ with reference alleles @X_i@: --- @ --- L(d) = \prod_i ( (1-d) * GL(X_i) + 1/3 * d * \sum_{Y/=X_i} GL(Y) ) --- = \prod_i GL(X_i) * \prod_i ( 1 - d + 1/3 * d * \sum_{Y/=X_i} GL(Y)/GL(X) ) --- @ --- --- We compute the first term on the first pass and tabulate a quantized --- form of the second term: @round (log \sum_{Y/=X_i} GL(Y)/GL(X))@. --- (Maybe add a scaling factor, though the plain natural log seems --- pretty good.) - -type LkTableM = UM.IOVector Int -type LkTable = U.Vector Int - -min_lk, max_lk :: Int -min_lk = -256 -max_lk = 255 - --- | Likelihood with one parameter, the divergence. Computes one --- part directly, bins the variable part into a mutable table. -lk1 :: LkTableM -> Prob -> Nucleotide -> GenoCallSite -> IO Prob -lk1 tbl !pp ref GenoCallSite{..} | U.length snp_likelihoods == 4 = do - let lx = Pr . negate . mini2float $ snp_likelihoods U.! fromEnum ref - odds = U.ifoldl' (\a i v -> if i == fromEnum ref then a else a + Pr (- mini2float v)) 0 snp_likelihoods / lx - qq = round (unPr odds) `min` max_lk `max` min_lk - min_lk - UM.write tbl qq . succ =<< UM.read tbl qq - return $! pp * lx - | otherwise = return pp - --- | Actual negative log-likelihood. Gets a table and a divergence --- value. Returns likelihoods and first two derivatives with respect to --- the divergence value. -llk1 :: (Ord a, Floating a) => LkTable -> a -> a -> a -llk1 tbl p d = U.ifoldl' step (-p) tbl - where - !d1 = log1p (- sigmoid2 d) - !d3 = log (sigmoid2 d) - log 3 - - step acc qq num = acc - fromIntegral num * (d1 <#> d3 + fromIntegral (min_lk + qq)) - diff --git a/tools/jivebunny.hs b/tools/jivebunny.hs --- a/tools/jivebunny.hs +++ b/tools/jivebunny.hs @@ -1,6 +1,3 @@ -{-# 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 @@ -23,46 +20,35 @@ -- assignment rates (Done.) import Bio.Bam -import Bio.Util.Numeric ( showNum ) -import Control.Applicative -import Control.Arrow ( (&&&) ) -import Control.Monad ( when, unless, forM_, foldM ) +import Bio.Prelude +import Bio.Util.Numeric ( showNum ) 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 Paths_biohazard ( version, getDataFileName ) import System.Console.GetOpt -import System.Environment ( getProgName, getArgs ) -import System.Exit -import System.IO -import System.Random ( randomRIO ) +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 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 @@ -102,7 +88,7 @@ go subsam2vector go k = filterStream ((\b -> not (isPaired b) || isFirstMate b) . unpackBam) =$ - progressNum "reading " mumble =$ + progressNum "reading " 0x100000 mumble =$ mapStream (fromTags "XI" "YI" &&& fromTags "XJ" "YJ") =$ k num @@ -138,8 +124,8 @@ both as7 as5 = Both (canonical as7) (canonical as5) where - canonical pairs = - let hm = HM.toList $ HM.fromListWith (++) [ (fromS v,[k]) | (k,v) <- pairs ] + canonical pps = + let hm = HM.toList $ HM.fromListWith (++) [ (fromS v,[k]) | (k,v) <- pps ] 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 ]) @@ -187,8 +173,8 @@ 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 + bitmask = (0x2020202020202020 - y) .&. 0x1F1F1F1F1F1F1F1F + score = shiftR ((a .&. bitmask) * 0x0101010101010101) 56 -- | A mixture description is one probability for each combination of p7 -- and p5 index. They should sum to one. @@ -288,9 +274,9 @@ -- 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 +iterEM pps p7 p5 prior = do acc <- VSM.replicate (VS.length prior) 0 - U.mapM_ (unmix1 p7 p5 prior acc) pairs + U.mapM_ (unmix1 p7 p5 prior acc) pps VS.unsafeFreeze acc data Loudness = Quiet | Normal | Loud @@ -299,6 +285,8 @@ unlessQuiet Quiet _ = return () unlessQuiet _ k = k +-- should I have a config for merging here? adapter lists? +-- does it ever make sense to skip the merging? data Conf = Conf { cf_index_list :: FilePath, cf_output :: Maybe (BamMeta -> Iteratee [BamRec] IO ()), @@ -309,7 +297,8 @@ cf_single :: Bool, cf_samplesize :: Int, cf_readgroups :: [FilePath], - cf_implied :: [T.Text] } + cf_implied :: [T.Text], + cf_merge :: Maybe ([U.Vector Nucleotides], [U.Vector Nucleotides]) } defaultConf :: IO Conf defaultConf = do ixdb <- getDataFileName "index_db.json" @@ -323,22 +312,25 @@ cf_single = False, cf_samplesize = 50000, cf_readgroups = [], - cf_implied = [default_rgs] } + cf_implied = [default_rgs], + cf_merge = Nothing } 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 [ ] ["nocontrol"] (NoArg set_no_control) "Suppress implied read groups for controls", - 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" ] + 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 [ ] ["nocontrol"] (NoArg set_no_control) "Suppress implied read groups for controls", + Option "F" ["forward-adapter"] (ReqArg set_forward "SEQ") "SEQ is a possible forward adapter", + Option "R" ["reverse-adapter"] (ReqArg set_reverse "SEQ") "SEQ is a possible reverse adapter", + 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 } @@ -352,6 +344,9 @@ 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 } + set_forward a c = readIO a >>= \x -> return $ c { cf_merge = Just $ first (x:) $ fromMaybe ([],[]) $ cf_merge c } + set_reverse a c = readIO a >>= \x -> return $ c { cf_merge = Just $ second (x:) $ fromMaybe ([],[]) $ cf_merge c } + usage = do pn <- getProgName putStrLn $ usageInfo ("Usage: " ++ pn ++ " [options] [bam-files]\n" ++ "Decomposes a mix of libraries and assigns read groups.") options @@ -407,18 +402,18 @@ 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' + let go !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 go (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) + mix <- go (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:" @@ -428,7 +423,6 @@ 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 @@ -468,7 +462,9 @@ 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 =$ + progressNum "writing " 0x100000 info =$ + maybe (mergeTrimBam default_fwd_adapters default_rev_adapters) + (uncurry mergeTrimBam) cf_merge =$ out (add_pg hdr') unlessQuiet cf_loudness $ do diff --git a/tools/mt-anno.hs b/tools/mt-anno.hs --- a/tools/mt-anno.hs +++ b/tools/mt-anno.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wall #-} import Anno import Seqs import Xlate @@ -7,6 +5,7 @@ import Bio.Align import Control.Applicative import Data.Char +import Prelude import Text.Printf import qualified Data.ByteString.Char8 as S diff --git a/tools/mt-ccheck.hs b/tools/mt-ccheck.hs --- a/tools/mt-ccheck.hs +++ b/tools/mt-ccheck.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings, BangPatterns, RecordWildCards #-} -- Simple Mitochondrial Contamination Check on BAM files. -- -- This is based on Ye Olde Contamination Check for the Neanderthal @@ -45,17 +44,9 @@ -- 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.List -import Numeric +import Bio.Prelude 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 @@ -187,8 +178,8 @@ -- | 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 +ancientDNAss = N . app0 . unN + where app0 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. diff --git a/tools/redeye-dar.hs b/tools/redeye-dar.hs --- a/tools/redeye-dar.hs +++ b/tools/redeye-dar.hs @@ -1,192 +1,59 @@ -{-# 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. +{-# LANGUAGE FlexibleContexts #-} +-- Co-estimates aDNA damage with parameters for a simple genotype prior. -- --- 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. +-- We want to estimate on only a subset of the genome. For the time +-- being, this is by definition a subset of the large blocks of the +-- mappability track for the human genome (so this doesn't work for +-- other genomes). To make this less crude, we need a differently +-- prepared input, but right now, input is one BAM file with read group +-- annotations. -- --- TODO --- - needs better output --- - needs support for multiple input files --- - needs to deal with long (unmerged) reads (by ignoring them?) +-- We run the EM algorithm, repeatedly estimating one damage/error model +-- per read group and the global genotype parameters. Convergence is +-- achieved when the changes in the damage models are sufficiently +-- small. The damage/error model is one substitution matrix for each +-- position within a read near the ends, and one for what remains in the +-- middle. -import Bio.Adna hiding ( bang ) -import Bio.Bam.Header -import Bio.Bam.Index -import Bio.Bam.Rec -import Bio.Base -import Bio.Genocall.Metadata -import Bio.Iteratee +import Bio.Adna +import Bio.Bam +import Bio.Bam.Pileup +import Bio.Genocall +import Bio.Genocall.Estimators +import Bio.Prelude import Bio.Util.AD -import Bio.Util.AD2 -import Bio.Util.Numeric -import Control.Applicative -import Control.Concurrent.Async -import Control.Monad ( unless ) -import Data.Bits -import Data.Foldable -import Data.Ix -import Data.Maybe -import Data.String ( fromString ) -import Data.Text ( unpack ) +import Data.Aeson.Encode.Pretty import System.Console.GetOpt -import System.Environment -import System.Exit -import System.FilePath -import System.IO ( hPutStrLn ) -import qualified Data.HashMap.Strict as M -import qualified Data.Vector as V -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed as U - -import Prelude hiding ( sequence_, mapM, mapM_, concatMap, sum, minimum, foldr1, foldl ) - --- | Roughly @Maybe (Nucleotide, Nucleotide)@, encoded compactly -newtype NP = NP { unNP :: Word8 } deriving (Eq, Ord, Ix) -data Seq = Merged { unSeq :: U.Vector Word8 } - | Mate1st { unSeq :: U.Vector Word8 } - | Mate2nd { 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) ] - - -{-# INLINE lk_fun1 #-} -lk_fun1 :: (Num a, Show a, Fractional a, Floating a, Memorable a) - => Int -> Int -> [a] -> V.Vector Seq -> a -lk_fun1 lmin 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 _ (Mate1st b) = U.ifoldl' (\a i np -> a * tab_f `bang` index' my_bounds (U.length b, i, NP np)) 1 b - lk _ _ tab_s (Mate2nd 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 -> Int -> V.Vector Seq -> U.Vector Double -> Double -lkfun lmin lmax brs parms = lk_fun1 lmin lmax (U.toList parms) brs - -lkfun' :: Int -> Int -> V.Vector Seq -> [Double] -> AD -lkfun' lmin lmax brs parms = lk_fun1 lmin lmax (paramVector parms) brs - -lkfun'' :: Int -> Int -> V.Vector Seq -> [Double] -> AD2 -lkfun'' lmin lmax brs parms = lk_fun1 lmin lmax (paramVector2 parms) brs - -combofn :: Int -> Int -> V.Vector Seq -> U.Vector Double -> (Double, U.Vector Double) -combofn lmin lmax brs parms = (x,g) - where D x g = lk_fun1 lmin lmax (paramVector $ U.toList parms) brs - +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as Z +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as M data Conf = Conf { - conf_lmin :: Int, - conf_metadata :: FilePath, - conf_report :: String -> IO (), - conf_params :: Parameters } + conf_output :: LazyBytes -> IO (), + conf_report :: LazyBytes -> IO (), + conf_params :: Parameters, + conf_length :: Int, + conf_eps :: Double } defaultConf :: Conf -defaultConf = Conf 25 (error "no config file specified") (\_ -> return ()) quietParameters +defaultConf = Conf (L.hPutStrLn stdout) (\_ -> return ()) quietParameters 16 1.0E-6 options :: [OptDescr (Conf -> IO Conf)] options = [ - Option "m" ["min-length"] (ReqArg set_lmin "LEN") "Set minimum length to LEN (25)", - Option "c" ["config"] (ReqArg set_conf "FILE") "Configuiration is stored in FILE", + Option "o" ["output"] (ReqArg set_output "FILE") "Write output to FILE (stdout)", + Option "l" ["model-length"] (ReqArg set_len "NUM") "Set size of subst. model to NUM (16)", + Option "e" ["precision"] (ReqArg set_prec "NUM") "Set precision for fit to NUM (1E-6)", Option "v" ["verbose"] (NoArg set_verbose) "Print progress reports", Option "h?" ["help","usage"] (NoArg disp_usage) "Print this message and exit" ] where - set_lmin a c = readIO a >>= \l -> return $ c { conf_lmin = l } - set_conf f c = return $ c { conf_metadata = f } - set_verbose c = return $ c { conf_report = hPutStrLn stderr, conf_params = debugParameters } + set_verbose c = return $ c { conf_report = L.hPutStrLn stderr, conf_params = debugParameters } + set_output f c = return $ c { conf_output = L.writeFile f } + set_len a c = readIO a >>= \x -> return $ c { conf_length = x } + set_prec a c = readIO a >>= \x -> return $ c { conf_eps = x } disp_usage _ = do pn <- getProgName let blah = "Usage: " ++ pn ++ " [OPTION...] [LIBRARY-NAME...]" @@ -195,259 +62,189 @@ main :: IO () main = do - (opts, lnames, errors) <- getOpt Permute options <$> getArgs + (opts, files, errors) <- getOpt Permute options <$> getArgs unless (null errors) $ mapM_ (hPutStrLn stderr) errors >> exitFailure - conf <- foldl (>>=) (return defaultConf) opts - mapM_ (main' conf) lnames - -main' :: Conf -> String -> IO () -main' Conf{..} lname = do - [Library _ fs _] <- return . filter ((fromString lname ==) . library_name) . concatMap sample_libraries . M.elems - =<< readMetadata conf_metadata - - -- XXX meh. subsampling from multiple files is not yet supported :( - brs <- subsampleBam (takeDirectory conf_metadata unpack (head fs)) >=> run $ \_ -> - joinI $ filterStream (\b -> not (isUnmapped (unpackBam b)) && G.length (b_seq (unpackBam b)) >= conf_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 conf_params 0.0001 v - (VFunction $ lkfun conf_lmin lmax brs) - (VGradient $ snd . combofn conf_lmin lmax brs) - (Just . VCombined $ combofn conf_lmin 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_ - - putStrLn $ "p_{ss} = " ++ show p_ss ++ ", p_{ds} = " ++ show p_ds - putStrLn $ show DP{..} - updateMetadata (store_dp lname DP{..}) conf_metadata + Conf{..} <- foldl (>>=) (return defaultConf) opts - -- Trying to get confidence intervals. Right now, just get the - -- gradient and Hessian at the ML point. Gradient should be nearly - -- zero, Hessian should be symmetric and positive definite. - -- (Remember, we minimized.) - mapM_ print [ (r,s) | (_,r,s) <- results ] - putStrLn "" - mapM_ print [ lkfun' conf_lmin lmax brs (G.toList xs) | (xs,_,_) <- results ] - putStrLn "" - mapM_ print [ lkfun'' conf_lmin lmax brs (G.toList xs) | (xs,_,_) <- results ] + -- For each iteration: read the input, decompose, pileup. The + -- "prior" damage model is the usual 'SubstModel', the "posterior" + -- damage model needs to be a mutable 'MSubstModel'. We feed + -- likelihoods into the div/het estimation (just as in + -- 'redeye-pileup'), but also into a caller that will estimate + -- damage. + let iter sp0 mod0 = do (((de1,de2),mod1),syms) <- emIter conf_length sp0 mod0 files + conf_report $ encodePretty de2 + if diffSubstMod mod0 mod1 > conf_eps + then iter (case point_est de1 of [a,b] -> SinglePop a b) mod1 + else return . ExtModel de1 (Just de2) . SubstModels + $ H.map ((mod1 V.!) . fromDmgToken) syms --- 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". + final_model <- iter (SinglePop 0.001 0.002) V.empty + conf_output $ encodePretty (final_model :: ExtModel) -pack_record :: BamRaw -> Seq -pack_record br = if isReversed b then k (revcom u1) else k u1 +diffSubstMod :: V.Vector SubstModel -> V.Vector SubstModel -> Double +diffSubstMod v1 v2 = + V.foldl' max 0 (V.zipWith diff1 v1 v2) `max` + V.foldl' max 0 (V.map abs1 (V.drop (V.length v2) v1)) `max` + V.foldl' max 0 (V.map abs1 (V.drop (V.length v1) v2)) where - b@BamRec{..} = unpackBam br + diff1 :: SubstModel -> SubstModel -> Double + diff1 sm1 sm2 = maximum $ + [ V.maximum $ V.zipWith diff2 (left_substs_fwd sm1) (left_substs_fwd sm2) + , diff2 (middle_substs_fwd sm1) (middle_substs_fwd sm2) + , V.maximum $ V.zipWith diff2 (right_substs_fwd sm1) (right_substs_fwd sm2) ] - k | isMerged b = Merged - | isTrimmed b = Merged - | isSecondMate b = Mate2nd - | otherwise = Mate1st + diff2 :: Mat44D -> Mat44D -> Double + diff2 (Mat44D u) (Mat44D v) = U.maximum $ U.map abs $ U.zipWith (-) u v - 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) + abs1 :: SubstModel -> Double + abs1 sm1 = V.maximum (V.map abs2 (left_substs_fwd sm1)) `max` + abs2 (middle_substs_fwd sm1) `max` + V.maximum (V.map abs2 (right_substs_fwd sm1)) - go :: [Cigar] -> [Nucleotides] -> [MdOp] -> [NP] + abs2 :: Mat44D -> Double + abs2 (Mat44D v) = U.maximum v - 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 +-- One iteration of EM algorithm. We go in with a substitution model +-- and het/div, we come out with new estimates for same. We get het/div from +-- tabulation followed by numerical optimization. For damage, we have to +-- compute posterior probabilities using the old model, then update the +-- damage matrices with pseudo counts. (This amounts to a maximum +-- likelihood estimate for a weighted multinomial distribution.) +emIter :: Int -> SinglePop -> V.Vector SubstModel -> [FilePath] -> IO (((DivEst,DivEst), V.Vector SubstModel), HashMap Bytes DmgToken) +emIter msize divest mod0 infiles = + liftIO (newIORef V.empty) >>= \mmod -> + liftIO (newIORef H.empty) >>= \symtab -> + concatInputs infiles >=> run $ \hdr -> + concatMapStreamM (decompose_dmg_from symtab) =$ + pileup =$ + filterPilesWith (the_regions hdr) =$ + mapStream ( id &&& calls mod0 ) =$ + let div_estimation :: MonadIO m => Iteratee [(a, Calls)] m (DivEst,DivEst) + div_estimation = mapStream snd =$ + tabulateSingle >>= + liftIO . estimateSingle -esc :: NP -esc = NP 16 + dmg_estimation :: MonadIO m => Iteratee [(Pile, Calls)] m (V.Vector SubstModel) + dmg_estimation = mapStreamM_ (\(p,c) -> + liftIO . updateSubstModel msize mod0 mmod p $ + single_pop_posterior divest + (refix $ snp_refbase $ p_snp_pile c) + (snp_gls $ p_snp_pile c)) >> + liftIO (readIORef mmod) >>= + liftIO . V.mapM freezeSubstModel -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 + in (,) <$> zipStreams div_estimation dmg_estimation + <*> liftIO (readIORef symtab) 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 + the_regions hdr = sort [ Region (Refseq $ fromIntegral ri) p (p+l) + | (ch, p, l) <- good_regions + , let Just ri = Z.findIndexL ((==) ch . sq_name) (meta_refs hdr) ] --- 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. + refix ref = U.fromListN 16 [0,0,2,0,5,0,0,0,9,0,0,0,0,0,0,0] U.! fromIntegral (unNs ref) -crude_estimate :: V.Vector Seq -> U.Vector Double -crude_estimate seqs0 = U.fromList [ l_subst, l_sigma, l_delta, l_lam, l_kap ] +filterPilesWith :: Monad m => [Region] -> Enumeratee [Pile] [Pile] m b +filterPilesWith = unfoldConvStream go where - seqs = V.filter ((>= 10) . U.length) $ V.map unSeq seqs0 + go [ ] = skipToEof >> return ([],[]) + go (r:rs) = do mp <- peekStream + case mp of + Just p | (p_refseq p, p_pos p) < (refseq r, start r) -> headStream >> go (r:rs) + | (p_refseq p, p_pos p) >= (refseq r, end r) -> go rs + | otherwise -> (\x -> (r:rs, [x])) `liftM` headStream + Nothing -> return ([],[]) - 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) +-- Probabilistically count substitutions. We infer from posterior +-- genotype probabilities what the base must have been, then count +-- substitutions from that to the actual base. - 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 +updateSubstModel :: Int -> V.Vector SubstModel -> IORef (V.Vector MSubstModel) -> Pile -> U.Vector Prob -> IO () +updateSubstModel msize mods0 vmods1 pile postp = case p_snp_pile pile of + (basesF, basesR) -> do mapM_ (count_base False) basesF + mapM_ (count_base True) basesR + where + -- Posterior probalities of the haploid base before damage + -- @P(H) = \sum_{G} P(H|G) P(G|D)@ + pH_A = fromProb $ postp U.! 0 + 0.5 * ( postp U.! 1 + postp U.! 3 + postp U.! 6 ) + pH_C = fromProb $ postp U.! 2 + 0.5 * ( postp U.! 1 + postp U.! 4 + postp U.! 7 ) + pH_G = fromProb $ postp U.! 5 + 0.5 * ( postp U.! 3 + postp U.! 4 + postp U.! 8 ) + pH_T = fromProb $ postp U.! 9 + 0.5 * ( postp U.! 6 + postp U.! 7 + postp U.! 8 ) - dmg_alpha v = v U.! 0 == c_to_t || v U.! 1 == c_to_t || v U.! 2 == c_to_t + -- P(H:->X) = P(H|X) + -- = P(X|H) P(H) / P(X) + -- = P(X|H) P(H) / \sum_H' P(X|H') P(H') + -- + -- We get P(X|H) from the old substitution model. - 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) + count_base str (q,b) = do + let old_mat = case mods0 V.!? fromDmgToken (db_dmg_tk b) of + Nothing -> initmat + Just sm -> lookupSubstModel sm (db_dmg_pos b) str - 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 + new_mat <- do mods1 <- readIORef vmods1 + sm <- case mods1 V.!? fromDmgToken (db_dmg_tk b) of + Nothing -> do m <- new_mmodel + writeIORef vmods1 (V.snoc mods1 m) + return m + Just m -> return m + return $ lookupSubstModel sm (db_dmg_pos b) str - delta = (total_inner_CTs /%/ (total_inner_CTs+total_inner_CCs)) - raw_rate = ct_at_alpha /%/ (ct_at_alpha + cc_at_alpha) + -- Use map quality to de-emphasize badly mapped reads. If + -- everything is badly mapped, the estimation still works; if + -- some data is well mapped, that naturally dominates the + -- estimate. + let pHX = (1 - fromQual q) / (pHX_A + pHX_C + pHX_G + pHX_T) + pHX_A = (old_mat `bang` nucA :-> db_call b) * pH_A + pHX_C = (old_mat `bang` nucC :-> db_call b) * pH_C + pHX_G = (old_mat `bang` nucG :-> db_call b) * pH_G + pHX_T = (old_mat `bang` nucT :-> db_call b) * pH_T - -- 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 + nudge new_mat (nucA :-> db_call b) (pHX_A * pHX) + nudge new_mat (nucC :-> db_call b) (pHX_C * pHX) + nudge new_mat (nucG :-> db_call b) (pHX_G * pHX) + nudge new_mat (nucT :-> db_call b) (pHX_T * pHX) -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 _ [ ] = error "unexpected: tried to memorize an empty list" - fromListN _ (C _ :_) = error "unexpected: tried to memorize a value without derivatives" - fromListN n xs@(D _ v:_) = (1+d, U.fromListN (n * (1+d)) $ concatMap unp xs) - where - !d = U.length v - unp (C a) = a : replicate d 0 - unp (D a da) = a : U.toList da + new_mmodel = SubstModel <$> V.replicateM msize nullmat + <*> nullmat + <*> V.replicateM msize nullmat + <*> V.replicateM msize nullmat + <*> nullmat + <*> V.replicateM msize nullmat - bang (d, v) i = D (v U.! (d*i+0)) (U.slice (d*i+1) (d-1) v) + nullmat = MMat44D <$> M.replicate 16 (0::Double) -instance Memorable AD2 where - type Memo AD2 = (Int, U.Vector Double) +calls :: V.Vector SubstModel -> Pile -> Calls +calls dmg pile = pile { p_snp_pile = s, p_indel_pile = i } + where + !s = simple_snp_call get_dmg $ p_snp_pile pile + !i = simple_indel_call get_dmg $ p_indel_pile pile - fromListN _ [ ] = error "unexpected: tried to memorize an empty list" - fromListN _ (C2 _ : _) = error "unexpected: tried to memorize a value without derivatives" - fromListN n xs@(D2 _ v _ : _) = (d, U.fromListN (n * (1+d+d*d)) $ concatMap unp xs) - where - !d = U.length v - unp (C2 a) = a : replicate (d+d*d) 0 - unp (D2 a da dda) = a : U.toList da ++ U.toList dda + get_dmg :: DmgToken -> Int -> Bool -> Mat44D + get_dmg (DmgToken dt) di ds = case dmg V.!? dt of + Nothing -> initmat -- not found, happens in first round + Just sm -> lookupSubstModel sm di ds - bang (d, v) i = D2 (v U.! (stride*i)) - (U.slice (stride*i+1) d v) - (U.slice (stride*i+1+d) (d*d) v) - where - stride = 1 + d + d*d +initmat :: Mat44D +initmat = Mat44D $ U.fromListN 16 [ 0.91, 0.03, 0.03, 0.03 + , 0.03, 0.91, 0.03, 0.03 + , 0.03, 0.03, 0.91, 0.03 + , 0.03, 0.03, 0.03, 0.91 ] +{-# INLINE decompose_dmg_from #-} +decompose_dmg_from :: IORef (HashMap Bytes DmgToken) -> BamRaw -> IO [PosPrimChunks] +decompose_dmg_from ref raw = do + hm <- readIORef ref + let rg = extAsString "RG" (unpackBam raw) + token <- case H.lookup rg hm of + Just tk -> return tk + Nothing -> do let tk = DmgToken $ H.size hm + writeIORef ref $! H.insert rg tk hm + return tk + return $ decompose token raw -store_dp :: String -> DamageParameters Double -> Metadata -> Metadata -store_dp lname dp = M.map go1 - where - go1 (Sample ls af bf ts dv) = Sample (map go2 ls) af bf ts dv - go2 (Library nm fs dmg) - | nm == fromString lname = Library nm fs (Just dp) - | otherwise = Library nm fs dmg diff --git a/tools/redeye-div.hs b/tools/redeye-div.hs deleted file mode 100644 --- a/tools/redeye-div.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, OverloadedStrings #-} --- Here we read the tables from sample_div_tables, add them up as --- necessary, estimate divergence and heterozygosity from them, and --- store the result back. The estimate can be done for regions, which --- are defined by regular expressions. - -import Bio.Base -import Bio.Genocall.Metadata -import Bio.Util.AD -import Bio.Util.AD2 -import Bio.Util.Numeric ( log1p ) -import Bio.Util.Regex ( regComp, regMatch ) -import Control.Concurrent.Async ( async, wait ) -import Control.Monad ( when, unless, forM, (>=>) ) -import Data.Foldable ( foldMap ) -import Data.List ( foldl1' ) -import Data.String ( fromString ) -import Data.Text ( Text, unpack ) -import Numeric ( showFFloat ) -import Numeric.LinearAlgebra.HMatrix ( eigSH', (><), toRows, scale ) -import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitSuccess, exitFailure ) -import System.IO ( hPutStrLn, stderr ) - -import qualified Data.HashMap.Strict as H -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Unboxed as U - -data Conf = Conf { conf_metadata :: FilePath - , conf_regions :: [Text] - , conf_purge :: Bool - , conf_verbose :: Bool } - -defaultConf :: Conf -defaultConf = Conf (error "no metadata file specified") [] False False - -options :: [OptDescr (Conf -> IO Conf)] -options = [ - Option "c" ["config"] (ReqArg set_conf "FILE") "Set name of json config file to FILE", - Option "r" ["region"] (ReqArg add_region "REGEX") "What matches REGEX becomes a region", - Option "p" ["purge"] (NoArg do_purge) "Purge tables after use", - Option "H" ["human"] (NoArg set_human) "Use regions for a human genome", - Option "v" ["verbose"] (NoArg be_verbose) "Print more diagnostics", - Option "h?" ["help","usage"] (NoArg disp_usage) "Display this message" ] - where - be_verbose c = return $ c { conf_verbose = True } - do_purge c = return $ c { conf_purge = True } - set_conf fn c = return $ c { conf_metadata = fn } - add_region re c = return $ c { conf_regions = fromString re : conf_regions c } - set_human c = return $ c { conf_regions = [ "^(chr)?[0-9]+$", "^(chr)?X$", "^(chr)?Y$" ] } - - disp_usage _ = do pn <- getProgName - let blah = "Usage: " ++ pn ++ " [OPTION...] [SAMPLE...]" - putStrLn $ usageInfo blah options - exitSuccess - - -main :: IO () -main = do - (opts, samples, errs) <- getOpt Permute options `fmap` getArgs - Conf{..} <- foldl (>>=) (return defaultConf) opts - unless (null errs) $ mapM_ (hPutStrLn stderr) errs >> exitFailure - - meta0 <- readMetadata conf_metadata - - let eff_samples = if null samples then H.keys meta0 else map fromString samples - eff_regions = if null conf_regions then [""] else conf_regions - - updates <- forM eff_samples >=> mapM wait $ \sample -> case H.lookup sample meta0 of - - Nothing -> do hPutStrLn stderr $ "unknown sample " ++ show sample - async $ return id - - Just smp -> async $ do - ests <- forM eff_regions >=> mapM wait $ \rgn -> async - $ fmap ((,) rgn) - $ estimateSingle conf_verbose - $ foldl1' (\(DivTable a u) (DivTable b v) -> DivTable (a+b) (U.zipWith (+) u v)) - $ H.elems - $ H.filterWithKey (match rgn) - $ sample_div_tables smp - - let app_purge = if conf_purge then appEndo (foldMap purge eff_regions) else id - upd_smp smp' = smp' { sample_divergences = ins_many ests $ sample_divergences smp' - , sample_div_tables = app_purge $ sample_div_tables smp' } - - when conf_verbose $ putStrLn $ "Estimate done for " ++ show sample ++ "." - return $ H.adjust upd_smp sample - updateMetadata (foldr (.) id updates) conf_metadata - - where - match :: Text -> Text -> a -> Bool - match rgn = const . regMatch (regComp $ unpack rgn) . unpack - - purge :: Text -> Endo (H.HashMap Text a) - purge rgn = Endo $ H.filterWithKey ((.) not . match rgn) - - ins_many :: [(Text,v)] -> H.HashMap Text v -> H.HashMap Text v - ins_many = flip $ foldr (uncurry H.insert) - - --- XXX we should estimate an indel rate, to be appended as the fourth --- result (but that needs different tables) -estimateSingle :: Bool -> DivTable -> IO DivEst -estimateSingle verbose (DivTable llk_rr tab) = do - (fit, res, stats) <- minimize quietParameters 0.0001 (llk tab) (U.fromList [0,0,0]) - let xform = map (\x -> exp x / (1 + exp x)) . VS.toList - - let showRes [dv,h1,h2] = - "D = " ++ showFFloat (Just 3) dv ", " ++ - "H1 = " ++ showFFloat (Just 3) h1 ", " ++ - "H2 = " ++ showFFloat (Just 3) h2 "" - showRes _ = error "Wtf? (1)" - - -- Confidence interval: PCA on Hessian matrix, then for each - -- eigenvalue λ add/subtract 1.96 / sqrt λ times the corresponding - -- eigenvalue to the estimate. Should describe a nice spheroid. - let D2 _val grd hss = llk2 tab (paramVector2 $ VS.toList fit) - d = U.length grd - (evals, evecs) = eigSH' $ (d >< d) (U.toList hss) - intervs = [ (xform (fit + scale lam evec), xform (fit + scale (-lam) evec)) - | (eval, evec) <- zip (VS.toList evals) (toRows evecs), let lam = 1.96 / sqrt eval ] - - when verbose $ putStrLn $ unlines $ - (:) (show res ++ ", " ++ show stats { finalValue = finalValue stats - llk_rr }) $ - (:) (showRes $ xform fit) $ - map (\(u,v) -> "[ " ++ showRes u ++ " .. " ++ showRes v ++ " ]") intervs - - return $! DivEst (xform fit) intervs - -llk :: U.Vector Int -> [AD] -> AD -llk tab [delta,eta,eta2] = llk' tab 0 delta eta + llk' tab 6 delta eta2 -llk _ _ = error "Wtf? (3)" - -llk2 :: U.Vector Int -> [AD2] -> AD2 -llk2 tab [delta,eta,eta2] = llk' tab 0 delta eta + llk' tab 6 delta eta2 -llk2 _ _ = error "Wtf? (4)" - -{-# INLINE llk' #-} -llk' :: (Ord a, Floating a) => U.Vector Int -> Int -> a -> a -> a -llk' tab base delta eta = block (base+0) g_RR g_RA g_AA - + block (base+1) g_RR g_AA g_RA - + block (base+2) g_RA g_RR g_AA - + block (base+3) g_RA g_AA g_RR - + block (base+4) g_AA g_RR g_RA - + block (base+5) g_AA g_RA g_RR - where - !maxD2 = U.length tab `div` 12 - !maxD = round (sqrt (fromIntegral maxD2) :: Double) - - !g_RR = 1 / Pr (log1p (exp delta)) - !g_AA = Pr delta / Pr (log1p (exp delta)) * 1 / Pr (log1p (exp eta)) - !g_RA = Pr delta / Pr (log1p (exp delta)) * Pr eta / Pr (log1p (exp eta)) - - block ix g1 g2 g3 = U.ifoldl' step 0 $ U.slice (ix * maxD2) maxD2 tab - where - step !acc !i !num = acc - fromIntegral num * unPr p - where - (!d1,!d2) = i `quotRem` maxD - p = g1 + Pr (- fromIntegral d1) * g2 + Pr (- fromIntegral (d1+d2)) * g3 - diff --git a/tools/redeye-flow.hs b/tools/redeye-flow.hs new file mode 100644 --- /dev/null +++ b/tools/redeye-flow.hs @@ -0,0 +1,192 @@ +-- Genotype call a bunch of samples. Dependency-driven, in parallel. +-- +-- - Small amounts of output land in files. Annoying, but easy. +-- - We optionally run -dar and -single on the SGE. Other parts run locally. + +import Bio.Bam +import Bio.Genocall.Estimators ( estimateSingle, good_regions ) +import Bio.Prelude +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.Aeson.Types +import Data.Binary ( decodeOrFail ) +import Development.Shake +import Development.Shake.FilePath +import System.Directory +import System.Console.GetOpt +import System.IO + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as Z +import qualified Data.Vector.Generic as V + +data Sample = Sample { + sample_name :: Text, + sample_libraries :: [ Text ] + } deriving Show + +parseSamples :: Value -> Parser [Sample] +parseSamples = withObject "samples" $ \o -> + sequence [ Sample k <$> parseStrings v | (k,v) <- H.toList o ] + where + parseStrings v = withText "file name" (return . (:[])) v + <|> withArray "file names" + (mapM (withText "file name" return) . V.toList) v + + +data Flags = GridEngine | Samples FilePath deriving Eq + +flagOptions :: [ OptDescr (Either String Flags) ] +flagOptions = [ Option "G" ["grid-engine"] (NoArg $ Right GridEngine) "Run on grid engine (uses qrsh)." + , Option "S" ["samples"] (ReqArg (Right . Samples) "FILE") "Read samples from FILE" ] + + +main :: IO () +main = shakeArgsWith shakeOptions flagOptions $ \flags targets -> return $ Just $ do + samples <- liftIO $ concat <$> sequence + [ do str <- B.readFile fp + case eitherDecodeStrict' str of + Left err -> error err + Right val -> case parseEither parseSamples val of + Left err -> error err + Right smps -> return smps + | Samples fp <- flags ] + + if null targets then do + -- final artefacts: one BCF per chromosome, + let chromosomes = map show [1..22::Int] ++ [ "X", "Y" ] + want [ "build/" ++ unpack (sample_name smp) ++ "." ++ chrom ++ ".bcf" + | chrom <- chromosomes, smp <- samples ] + + -- and div/het estimates + want [ "build/" ++ unpack (sample_name smp) ++ "." ++ part ++ ".divest" + | part <- ["auto","X","Y"], smp <- samples ] + else + want targets + + callz samples flags + divests + dmgests flags + rgn_files samples + + +divests :: Rules () +divests = do + "build/*.auto.divest" %> \out -> do + let stem = dropExtension $ dropExtension out + raw <- lReadFiles' [ stem ++ "." ++ show c ++ ".divtab" | c <- [1..22::Int] ] + putLoud $ "estimate for " ++ out + either fail_decode (\tabs -> liftIO $ do + (de1,de2) <- estimateSingle $ mconcat [ t | (_,_,t) <- tabs ] + L.writeFile out $ encodePretty [ de1, de2 ]) + $ mapM decodeOrFail raw + + "build/*.X.divest" %> \out -> do + raw <- lReadFile' (out -<.> "divtab") + putLoud $ "estimate for " ++ out + either fail_decode (\(_,_,tab) -> liftIO $ do + (de1,de2) <- estimateSingle tab + L.writeFile out $ encodePretty [ de1, de2 ]) + $ decodeOrFail raw + + "build/*.Y.divest" %> \out -> do + raw <- lReadFile' (out -<.> "divtab") + putLoud $ "estimate for " ++ out + either fail_decode (\(_,_,tab) -> liftIO $ do + (de1,de2) <- estimateSingle tab + L.writeFile out $ encodePretty [ de1, de2 ]) + $ decodeOrFail raw + where + fail_decode (rest,off,msg) = error $ + msg ++ " at " ++ shows off " near " ++ show (L.take 16 rest) + + lReadFile' x = need [x] >> liftIO (L.readFile x) + lReadFiles' xs = need xs >> liftIO (mapM L.readFile xs) + + +-- one pileup per chrmosome * sample; input is the +-- bam files and one dmgest per sample +callz :: [Sample] -> [Flags] -> Rules () +callz samples flags = [ "build/*.*.bcf", "build/*.*.divtab" ] &%> \[bcf,tab] -> do + let (sm,'.':c) = splitExtension $ dropExtension $ takeFileName bcf + dmg = "build" sm <.> "dmgest" + bams = [ unpack libf | s <- samples, sm == unpack (sample_name s) + , libf <- sample_libraries s ] + need $ dmg : bams + + if GridEngine `elem` flags + then + unsafeExtraThread $ + command [] "qrsh" $ + "-now" : "no" : "-cwd" : "-N" : (sm ++ "-" ++ c) : + "-l" : "h_vmem=3.4G,s_vmem=3.4G,virtual_free=3.4G,s_stack=2M" : + "redeye-single" : "-o" : bcf : "-c" : c : "-T" : tab : "-D" : dmg + : "-N" : sm : "-v" : bams + else + command [] "redeye-single" $ + "-o" : bcf : "-c" : c : "-T" : tab : "-D" : dmg + : "-N" : sm : "-v" : bams + + +dmgests :: [Flags] -> Rules () +dmgests flags = "build/*.dmgest" %> \out -> do + let sm = dropExtension $ takeFileName out + rgn_file = "build" sm <.> "good_regions.bam" + need [ rgn_file ] + + if GridEngine `elem` flags + then + unsafeExtraThread $ + command [] "qrsh" $ + "-now" : "no" : "-cwd" : "-N" : (sm ++ "-dar") : + "-l" : "h_vmem=3.4G,s_vmem=3.4G,virtual_free=3.4G,s_stack=2M" : + "redeye-dar" : "-o" : out : rgn_file : [] + else + command [] "redeye-dar" $ "-o" : out : rgn_file : [] + +rgn_files :: [Sample] -> Rules () +rgn_files samples = do + mem <- newResource "heavy IO" 1 + "build/*.good_regions.bam" %> \out -> do + let sm = dropExtension $ dropExtension $ takeFileName out + lfs = [ unpack f | s <- samples, unpack (sample_name s) == sm + , f <- sample_libraries s ] + need lfs + withResource mem 1 $ do + putLoud $ "subsetting " ++ show lfs + liftIO $ subsetbams out lfs (takeLen 5000000 good_regions) 35 + where + takeLen !n (x@(_,_,l):xs) | n > 0 = x : takeLen (n-l) xs + takeLen _ _ = [] + + +-- | Reads regions from many bam files, writes one. +-- XXX It might make sense to serialize not BAM, but the result of +-- piling up. +subsetbams :: FilePath -> [FilePath] -> [( Bytes, Int, Int )] -> Int -> IO () +subsetbams ofp (ifp:ifps) rgns0 minlen = do + withFile (ofp ++ "~") WriteMode $ \hdl -> + go ifp ifps >=> run $ \hdr -> + filterStream ((>= minlen) . V.length . b_seq . unpackBam) =$ + writeBamHandle hdl hdr + renameFile (ofp ++ "~") ofp + where + enum1 :: (MonadIO m, MonadMask m) => FilePath -> Enumerator' BamMeta [BamRaw] m a + enum1 fp k = do idx <- liftIO $ readBamIndex fp + enumFileRandom defaultBufSize fp >=> run >=> run $ + decodeAnyBam $ \hdr -> + let rgns = sort [ Region (Refseq $ fromIntegral ri) p (p+l) + | (ch, p, l) <- rgns0 + , let Just ri = Z.findIndexL ((==) ch . sq_name) (meta_refs hdr) ] + in eneeBamRegions idx rgns (k hdr) + + go :: (MonadIO m, MonadMask m) => FilePath -> [FilePath] -> Enumerator' BamMeta [BamRaw] m b + go fp [ ] = enum1 fp + go fp (fp1:fps) = mergeEnums' (go fp1 fps) (enum1 fp) combineCoordinates + +subsetbams ofp [] rgns0 minlen = + error $ "Wait, what? " ++ show (ofp, rgns0, minlen) + + diff --git a/tools/redeye-pileup.hs b/tools/redeye-pileup.hs deleted file mode 100644 --- a/tools/redeye-pileup.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# LANGUAGE RecordWildCards, BangPatterns, OverloadedStrings, FlexibleContexts #-} --- Command line driver for simple genotype calling. We have three --- separate steps: Pileup from a BAM file (or multiple merged files) to --- produce likelihoods (and some auxillary statistics). These are --- written into an Avro container. Next we need to estimate parameters, --- in the simplest case divergence and heterozygosity. We can save some --- time by fusing this with the first step. The final step is calling --- bases by scnaning the Avro container and applying some model, and --- again, in the simplest case that's just divergence and --- heterozygosity. We keep that separate, because different models will --- require different programs. So here we produce likelihoods and --- a simple model fit. - --- The likelihoods depend on damage parameters and an error model, --- otherwise they are 'eternal'. (For the time being, it's probably --- wise to go with the naïve error model.) Technically, they also --- depend on ploidy, but since only diploid organisms are interesting --- right now, we fix that to two. We pay some overhead on the sex --- chromosomes, but the simplification is worth it. - --- 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. --- However, all can be generalized into one model with slightly more --- parameters. See tools/dmg-est.hs for how we fit the model. - --- Calling is always diploid, for maximum flexibility. We don't really --- support higher ploidies, so the worst damage is that we output an --- overhead of 150% useless likelihood values for the sex chromosomes --- and maybe estimate heterozygosity where there is none. - -import Bio.Adna -import Bio.Base -import Bio.Bam.Header -import Bio.Bam.Index -import Bio.Bam.Pileup -import Bio.Bam.Reader -import Bio.Bam.Rec -import Bio.Genocall -import Bio.Genocall.AvroFile -import Bio.Genocall.Metadata -import Bio.Iteratee -import Control.Applicative -import Control.Monad -import Data.Aeson -import Data.Avro -import Data.String ( fromString ) -import Data.Vec.Packed ( packMat ) -import System.Console.GetOpt -import System.Directory ( renameFile ) -import System.Environment -import System.Exit -import System.FilePath -import System.IO - -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy as BL -import qualified Data.Foldable as F -import qualified Data.HashMap.Strict as H -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector.Storable as VS -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Mutable as M -import qualified Data.Sequence as Z - -data Conf = Conf { - -- Generator for output file name. Receives sample name and - -- (optional) region as arguments. - conf_output :: String -> Maybe String -> FilePath, - conf_metadata :: FilePath, - conf_theta :: Maybe Double, - conf_report :: String -> IO () } - -defaultConf :: Conf -defaultConf = Conf default_out (error "no metadata file specified") Nothing (\_ -> return ()) - where - default_out smp Nothing = smp <> ".av" - default_out smp (Just rgn) = smp <> "-" <> rgn <> ".av" - -options :: [OptDescr (Conf -> IO Conf)] -options = [ - Option "c" ["config"] (ReqArg set_conf "FILE") "Set name of json config file to FILE", - Option "o" ["output"] (ReqArg set_output "FILE") "Set out file schema to FILE", - Option "t" dep_param (ReqArg set_theta "FRAC") "Set dependency coefficient to FRAC (\"N\" to turn off)", - Option "v" ["verbose"] (NoArg be_verbose) "Print more diagnostics", - Option "h?" ["help","usage"] (NoArg disp_usage) "Display this message" ] - where - dep_param = ["theta","dependency-coefficient"] - - disp_usage _ = do pn <- getProgName - let blah = "Usage: " ++ pn ++ " [OPTION...] [SAMPLE [REGION...] ...]" - putStrLn $ usageInfo blah options - exitSuccess - - be_verbose c = return $ c { conf_report = hPutStrLn stderr } - set_conf fn c = return $ c { conf_metadata = fn } - - set_theta "N" c = return $ c { conf_theta = Nothing } - set_theta a c = (\t -> c { conf_theta = Just t }) <$> readIO a - - set_output fn c = return $ c { conf_output = mkoutput fn } - -mkoutput :: FilePath -> String -> Maybe String -> FilePath -mkoutput str smp rgn = go str - where - go ('%':'s':s) = smp ++ go s - go ('%':'r':s) = maybe id (++) rgn $ go s - go ('%':'%':s) = '%' : go s - go ('%': c :s) = c : go s - go ( c :s) = c : go s - go [ ] = [ ] - -main :: IO () -main = do - (opts, samprgns, errs) <- getOpt Permute options <$> getArgs - Conf{..} <- foldl (>>=) (return defaultConf) opts - unless (null errs) $ mapM_ (hPutStrLn stderr) errs >> exitFailure - - -- samprgns contains samples and regions. We define anything found in the metadata as sample, - -- anything else as region to apply to the previous sample. Name a sample "chr1" and you get - -- what you deserve. - - samples <- flip split_sam_rgns samprgns <$> readMetadata conf_metadata - when (null samples) $ hPutStrLn stderr "need (at least) one sample name" >> exitFailure - - forM_ samples $ \(sample, rgns) -> do - meta <- readMetadata conf_metadata - - case H.lookup (fromString sample) meta of - Nothing -> hPutStrLn stderr $ "unknown sample " ++ show sample - - Just smp -> forM_ rgns $ \rgn -> do - let outstem = conf_output sample rgn - outfile = takeDirectory conf_metadata outstem - tmpfile = outfile ++ ".#" - (tab,()) <- withFile tmpfile WriteMode $ \ohdl -> - mergeLibraries conf_report conf_metadata (sample_libraries smp) rgn >=> run $ \hdr -> - progressPos (\(rs, p, _) -> (rs, p)) "GT call at " conf_report (meta_refs hdr) =$ - pileup =$ - mapStream (calls conf_theta) =$ - zipStreams tabulateSingle (output_avro ohdl $ meta_refs hdr) - - let upd_sample s = s { sample_div_tables = H.insert (maybe T.empty T.pack rgn) tab (sample_div_tables s) - , sample_avro_files = H.insert (maybe T.empty T.pack rgn) (fromString outstem) (sample_avro_files s) } - - updateMetadata (H.adjust upd_sample (fromString sample)) conf_metadata - renameFile tmpfile outfile - -mergeLibraries :: (MonadIO m, MonadMask m) - => (String -> IO ()) -> FilePath - -> [Library] -> Maybe String -> Enumerator' BamMeta [PosPrimChunks] m b -mergeLibraries report cfg [ l ] mrgn = enumLibrary report cfg l mrgn -mergeLibraries report cfg (l:ls) mrgn = mergeEnums' (mergeLibraries report cfg ls mrgn) (enumLibrary report cfg l mrgn) mm - where - mm _ = mergeSortStreams $ \(rs1, p1, _) (rs2, p2, _) -> if (rs1, p1) < (rs2, p2) then Less else NotLess - -enumLibrary :: (MonadIO m, MonadMask m) - => (String -> IO ()) -> FilePath - -> Library -> Maybe String -> Enumerator' BamMeta [PosPrimChunks] m b -enumLibrary report cfg (Library nm fs mdp) mrgn output = do - let (msg, dmg) = case mdp of Nothing -> ("no damage model", noDamage) - Just dp -> ("universal damage parameters" ++ show dp, univDamage dp) - - liftIO . report $ "using " ++ msg ++ " for " ++ T.unpack nm - mergeInputRgns mrgn combineCoordinates (map (() (takeDirectory cfg) . T.unpack) fs) - $== takeWhileE (isValidRefseq . b_rname . unpackBam) - $== mapMaybeStream (\br -> - let b = unpackBam br - m = dmg (isReversed b) (VS.length (b_qual b)) - in decompose (map packMat $ V.toList m) br) - $ output - -mergeInputRgns :: (MonadIO m, MonadMask m) - => Maybe String - -> (BamMeta -> Enumeratee [BamRaw] [BamRaw] (Iteratee [BamRaw] m) a) - -> [FilePath] -> Enumerator' BamMeta [BamRaw] m a -mergeInputRgns _ _ [ ] = \k -> return (k mempty) -mergeInputRgns Nothing (?) fps = mergeInputs (?) fps -mergeInputRgns (Just rs) (?) (fp0:fps0) = go fp0 fps0 - where - enum1 fp k1 = do idx <- liftIO $ readBamIndex fp - enumFileRandom defaultBufSize fp >=> run >=> run $ - decodeAnyBam $ \hdr -> - let Just ri = Z.findIndexL ((==) rs . unpackSeqid . sq_name) (meta_refs hdr) - in eneeBamRefseq idx (Refseq $ fromIntegral ri) $ k1 hdr - - go fp [ ] = enum1 fp - go fp (fp1:fps) = mergeEnums' (go fp1 fps) (enum1 fp) (?) - - --- | Ploidy is hardcoded as two here. Can be changed if the need --- arises. --- --- 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 -> Pile -> Calls -calls Nothing pile = pile { p_snp_pile = s, p_indel_pile = i } - where - !s = simple_snp_call fq 2 $ uncurry (++) $ p_snp_pile pile - !i = simple_indel_call 2 $ p_indel_pile pile - -- XXX this should be a cmdline option - -- fq = min 1 . (*) 1.333 . fromQual - fq = fromQual - -calls (Just theta) pile = pile { p_snp_pile = s, p_indel_pile = i } - where - !i = simple_indel_call 2 $ p_indel_pile pile - - -- This lumps the two strands together - -- !s = maq_snp_call 2 theta $ uncurry (++) $ p_snp_pile pile -- XXX - - -- This treats them separately - !s | r == r' = Snp_GLs (U.zipWith (*) x y) r -- same ref base (normal case): multiply - | r == nucsN = Snp_GLs y r' -- forward ref is N, use backward call - | otherwise = Snp_GLs x r -- else use forward call (even if this is incorrect, - where -- there is nothing else we can do here) - Snp_GLs x r = maq_snp_call 2 theta $ fst $ p_snp_pile pile - Snp_GLs y r' = maq_snp_call 2 theta $ snd $ p_snp_pile pile - - --- | 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 => Enumeratee [Calls] [GenoCallBlock] m a -compileBlocks = convStream $ do - c1 <- headStream - tailBlock (p_refseq c1) (p_pos c1) (p_pos c1) . (:[]) $! pack c1 - where - tailBlock !rs !p0 !po acc = do - mc <- peekStream - case mc of - Just c1 | rs == p_refseq c1 && po+1 == p_pos c1 && po - p0 < 65536 -> do - _ <- headStream - tailBlock rs p0 (po+1) . (:acc) $! pack c1 - - _ -> return [ GenoCallBlock - { reference_name = rs - , start_position = p0 - , called_sites = reverse acc } ] - - pack c1 = rlist indel_variants `seq` GenoCallSite{..} - where - Snp_GLs snp_pls !ref_allele = p_snp_pile c1 - - !snp_stats = p_snp_stat c1 - !indel_stats = p_indel_stat c1 - !snp_likelihoods = compact_likelihoods snp_pls - !indel_likelihoods = compact_likelihoods $ fst $ p_indel_pile c1 - !indel_variants = snd $ p_indel_pile c1 - - rlist [] = () - rlist (x:xs) = x `seq` rlist xs - - -output_avro :: Handle -> Refs -> Iteratee [Calls] IO () -output_avro hdl refs = compileBlocks =$ - writeAvroContainer ContainerOpts{..} =$ - mapChunksM_ (S.hPut hdl) - where - objects_per_block = 16 - filetype_label = "Genotype Likelihoods V0.1" - initial_schemas = H.singleton "Refseq" $ - object [ "type" .= String "enum" - , "name" .= String "Refseq" - , "symbols" .= Array - (V.fromList . map (String . T.decodeUtf8 . sq_name) $ F.toList refs) ] - meta_info = H.singleton "biohazard.refseq_length" $ - S.concat $ BL.toChunks $ encode $ Array $ V.fromList - [ Number (fromIntegral (sq_length s)) | s <- F.toList refs ] - - -maxD :: Int -maxD = 64 - --- | Parameter estimation for a single sample. The parameters are --- divergence and heterozygosity. We tabulate the data here and do the --- estimation afterwards. Returns the product of the --- parameter-independent parts of the likehoods and the histogram --- indexed by D and H (see @genotyping.pdf@ for details). -tabulateSingle :: (Functor m, MonadIO m) => Iteratee [Calls] m DivTable -tabulateSingle = do - tab <- liftIO $ M.replicate (12 * maxD * maxD) (0 :: Int) - DivTable <$> foldStreamM (\acc -> accum tab acc . p_snp_pile) (0 :: Double) - <*> liftIO (U.unsafeFreeze tab) - where - -- We need GL values for the invariant, the three homozygous variant - -- and the three single-event heterozygous variant cases. The - -- ordering is like in BCF, with the reference first. - -- Ref ~ A ==> PL ~ AA, AC, CC, AG, CG, GG, AT, CT, GT, TT - {-# INLINE accum #-} - accum !tab !acc (Snp_GLs !gls !ref) - | U.length gls /= 10 = error "Ten GL values expected for SNP!" -- should not happen - | ref `elem` [nucsC,nucsG] = accum' 0 tab acc gls - | ref `elem` [nucsA,nucsT] = accum' 6 tab acc gls - | otherwise = return acc -- unknown reference - - -- The simple 2D table didn't work, it lacked resolution in some - -- cases. We make six separate tables instead so we can store two - -- differences with good resolution in every case. - {-# INLINE accum' #-} - accum' refix !tab !acc !gls - | g_RR >= g_RA && g_RA >= g_AA = store 0 g_RR g_RA g_AA - | g_RR >= g_AA && g_AA >= g_RA = store 1 g_RR g_AA g_RA - | g_RA >= g_RR && g_RR >= g_AA = store 2 g_RA g_RR g_AA - | g_RA >= g_AA && g_AA >= g_RR = store 3 g_RA g_AA g_RR - | g_RR >= g_RA = store 4 g_AA g_RR g_RA - | otherwise = store 5 g_AA g_RA g_RR - - where - g_RR = unPr $ U.unsafeIndex gls 0 - g_RA = unPr $ (U.unsafeIndex gls 1 + U.unsafeIndex gls 3 + U.unsafeIndex gls 6) / 3 - g_AA = unPr $ (U.unsafeIndex gls 2 + U.unsafeIndex gls 5 + U.unsafeIndex gls 9) / 3 - - store t a b c = do let d1 = min (maxD-1) . round $ a - b - d2 = min (maxD-1) . round $ b - c - ix = (t + refix) * maxD * maxD + d1 * maxD + d2 - liftIO $ M.read tab ix >>= M.write tab ix . succ - return $! acc + a - diff --git a/tools/redeye-single.hs b/tools/redeye-single.hs --- a/tools/redeye-single.hs +++ b/tools/redeye-single.hs @@ -1,173 +1,218 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, OverloadedStrings, FlexibleContexts #-} --- Genotype calling for a single individual. The only parameters needed --- are the (prior) probabilities for a heterozygous or homozygous variant. +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} +-- Command line driver for simple genotype calling. We have two +-- separate steps: We estimate parameters on a subset of the input, +-- then we pile up. Output from pileup is a BCF file containing +-- likelihoods, posterior probabilities, and genotype calls. +-- Alternatively we could write a Heffalump, which has only genotype +-- calls. We also write a table on the side, which can be used to +-- estimate divergence and heterozygosity per chromosome or genome wide. -- +-- The likelihoods depend on damage parameters and an error model, +-- otherwise they are 'eternal'. (For the time being, it's probably +-- wise to go with the naïve error model.) Technically, they also +-- depend on ploidy, but since only diploid organisms are interesting +-- right now, we fix that to two. We pay some overhead on the sex +-- chromosomes, but the simplification is worth it. +-- +-- About damage parameters: Everything converged on an empirical model +-- where damage and sequencing error are both modelled as one position +-- specific substitution matrix. The damage model is specific to a read +-- group, so read group annotations must be present. +-- +-- Calling is always diploid, for maximum flexibility. We don't really +-- support higher ploidies, so the worst damage is that we output an +-- overhead of 150% useless likelihood values for the sex chromosomes +-- and maybe estimate heterozygosity where there is none. +-- -- (This can be extended easily into a caller for a homogenous -- population where individuals are assumed to be randomly related (i.e. -- not family). In this case, the prior is the allele frequency -- spectrum, the call would be the set(!) of genotypes that has maximum -- posterior probability. Computation is possible in quadratic time and -- linear space using a DP scheme; see Heng Li's paper for details.) --- --- What's the output format? Fasta or Fastq could be useful in limited --- circumstances, else BCF (not VCF) would be canonical. Or maybe BCF --- restricted to variant sites. Or BCF restricted to sites not known to --- be reference. People will come up with filters for sure... -import Bio.Base +import Bio.Adna import Bio.Bam import Bio.Bam.Pileup -import Bio.Genocall.AvroFile -import Bio.Genocall.Metadata +import Bio.Genocall +import Bio.Genocall.Estimators import Bio.Iteratee.Builder -import Bio.Util.Regex ( Regex, regComp, regMatch ) -import Control.Applicative -import Control.Exception ( bracket ) -import Control.Monad -import Data.Avro -import Data.Bits -import Data.Foldable ( toList, foldMap ) -import Data.MiniFloat -import Data.String -import Data.Text ( Text, unpack ) -import Foreign.Ptr ( castPtr ) +import Bio.Prelude +import Data.Aeson +import GHC.Float ( double2Float ) import System.Console.GetOpt -import System.Directory ( renameFile ) -import System.Environment -import System.Exit import System.FilePath -import System.Posix.IO +import System.Random +import qualified Data.Binary as Bin import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Unsafe as S +import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as Z +import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U -import qualified System.IO as IO +type Reporter = String -> IO () + data Conf = Conf { - conf_metadata :: FilePath, - -- | Generator for output file name. Receives sample name and - -- (optional) region as arguments. - conf_output :: String -> Text -> FilePath, - conf_regions :: Regex, - conf_ploidy :: String -> Int, - conf_report :: String -> IO () } + conf_output :: FilePath, + conf_dmg :: ExtModel, + conf_chrom :: String, + conf_report :: Reporter, + conf_table :: Maybe FilePath, + conf_random :: Maybe StdGen, + sample_name :: Conf -> String } + +-- | We map read groups to damage models. The set of damage models is +-- supplied in a JSON file. defaultConf :: Conf -defaultConf = Conf (error "no metadata file specified") default_out (regComp "") (const 2) (\_ -> return ()) - where - default_out smp "" = smp <> ".bcf" - default_out smp rgn = smp <> "-" <> unpack rgn <> ".bcf" +defaultConf = Conf { conf_output = error "no output file" + , conf_dmg = ExtModel (DivEst [0.001,0.0005] []) Nothing (SubstModels mempty) + , conf_chrom = "" + , conf_report = \_ -> return () + , conf_table = Nothing + , conf_random = Nothing + , sample_name = takeWhile (/='.') . takeFileName . conf_output } + options :: [OptDescr (Conf -> IO Conf)] options = [ - Option "c" ["config"] (ReqArg set_conf "FILE") "Set name of json config file to FILE", - Option "o" ["output"] (ReqArg set_output "FILE") "Set output file pattern to FILE", - Option "r" ["regions"] (ReqArg set_regions "REGEX") "Process only regions matching REGEX", - Option "1" ["haploid-chromosomes"] (ReqArg set_hap "REGEX") "Targets matching REGEX are haploid", - Option "2" ["diploid-chromosomes"] (ReqArg set_dip "REGEX") "Targets matching REGEX are diploid", - Option "v" ["verbose"] (NoArg be_verbose) "Print more diagnostics", - Option "h?" ["help","usage"] (NoArg disp_usage) "Display this message" ] + Option "o" ["output"] (ReqArg set_output "FILE") "Set output filename to FILE", + Option "c" ["chromosome","region"] (ReqArg set_chrom "NAME") "Restrict to chromosome NAME", + Option "D" ["damage"] (ReqArg set_dmg "FILE") "Read damage model from FILE", + Option "T" ["table"] (ReqArg want_table "FILE") "Print table for divergence estimation to FILE", + Option "s" ["sample-genotypes"] (OptArg set_rnd "SEED") "Sample genotypes from posterior", + Option "N" ["name"] (ReqArg set_name "NAME") "Set sample name to NAME", + 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...] [SAMPLE [REGION...] ...]" - putStrLn $ usageInfo blah options - exitFailure + disp_usage _ = do pn <- getProgName + let blah = "Usage: " ++ pn ++ " [[OPTION...] [BAM-FILE...] ...]" + putStrLn $ usageInfo blah options + exitSuccess - be_verbose c = return $ c { conf_report = IO.hPutStrLn stderr } - set_conf fn c = return $ c { conf_metadata = fn } + be_verbose c = return $ c { conf_report = hPutStrLn stderr } + want_table fp c = return $ c { conf_table = Just fp } - set_hap a c = return $ c { conf_ploidy = \chr -> if regMatch (regComp a) chr then 1 else conf_ploidy c chr } - set_dip a c = return $ c { conf_ploidy = \chr -> if regMatch (regComp a) chr then 2 else conf_ploidy c chr } - set_regions a c = return $ c { conf_regions = regComp $ "^" ++ a ++ "$" } + set_dmg a c = BL.readFile a >>= \s -> case eitherDecode' s of + Left err -> error err + Right ds -> return $ c { conf_dmg = ds } - set_output fn c = return $ c { conf_output = mkoutput fn } + set_chrom a c = return $ c { conf_chrom = a } + set_output fn c = return $ c { conf_output = fn } + set_name nm c = return $ c { sample_name = const nm } -mkoutput :: FilePath -> String -> Text -> FilePath -mkoutput str smp rgn = go str - where - go ('%':'s':s) = smp ++ go s - go ('%':'r':s) = unpack rgn ++ go s - go ('%':'%':s) = '%' : go s - go ('%': c :s) = c : go s - go ( c :s) = c : go s - go [ ] = [ ] + set_rnd Nothing c = newStdGen >>= \g -> return $ c { conf_random = Just g } + set_rnd (Just a) c = readIO a >>= \s -> return $ c { conf_random = Just (mkStdGen s) } + main :: IO () main = do - (opts, samples, errs) <- getOpt Permute options <$> getArgs - unless (null errs) $ mapM_ (IO.hPutStrLn stderr) errs >> exitFailure + (opts, files, errs) <- getOpt Permute options <$> getArgs + conf@Conf{..} <- foldl (>>=) (return defaultConf) opts + unless (null errs) $ mapM_ (hPutStrLn stderr) errs >> exitFailure - conf <- foldl (>>=) (return defaultConf) opts - when (null samples) $ IO.hPutStrLn stderr "need (at least) one sample name" >> exitFailure + let symtab = H.fromList $ zip [ k | (k,_) <- case damage conf_dmg of SubstModels ms -> H.toList ms ] (map DmgToken [0..]) + smodel = V.fromList [ v | (_,v) <- case damage conf_dmg of SubstModels ms -> H.toList ms ] - forM_ samples $ \sample -> do - meta <- readMetadata (conf_metadata conf) + let prior_div:prior_het:_ = point_est $ population conf_dmg + callz = ( call $ SinglePop prior_div prior_het + , call $ SinglePop (0.1 * prior_div) (0.1 * prior_het) ) - case H.lookup (fromString sample) meta of - Nothing -> IO.hPutStrLn stderr $ "unknown sample " ++ show sample - Just smp -> main' conf sample smp (conf_regions conf) + (tab,()) <- withOutputFd conf_output $ \ofd -> + mergeInputRgns combineCoordinates conf_chrom files >=> run $ \hdr -> + takeWhileE (isValidRefseq . b_rname . unpackBam) =$ + concatMapStream (decompose_dmg_from symtab) =$ + progressPos (\(a,b,_,_)->(a,b)) "GT call at" (meta_refs hdr) 0x4000 conf_report =$ + pileup =$ + mapStream (simple_calls smodel) =$ + zipStreams tabulateSingle + (toBcf (meta_refs hdr) [fromString $ sample_name conf] callz conf_random =$ + mapChunksM_ (liftIO . fdPut ofd)) --- | Call for a given sample and a set of regions defined by a regex. --- Input are the av files whose keys match the region regex, output is --- generated schematically from the keys so that we get one bcf output --- for every av input. Divergence parameters for each av file are the --- first set whose key interpreted as a regex matches the key for the av --- file. -main' :: Conf -> String -> Sample -> Regex -> IO () -main' Conf{..} sample_name smp rgnex = - forM_ (filter (regMatch rgnex . unpack . fst) . H.toList $ sample_avro_files smp) $ \(rgn, avfile) -> - case fmap point_est $ H.foldrWithKey (ifMatch rgn) Nothing (sample_divergences smp) of - Just (prior_div : prior_het : _prior_het2 : more) -> do - liftIO $ conf_report $ "Calling " ++ sample_name ++ "/" ++ unpack rgn ++ "." - let prior_indel = case more of [] -> prior_div * 0.1 ; p : _ -> p - infile = takeDirectory conf_metadata unpack avfile - outfile = takeDirectory conf_metadata conf_output sample_name rgn - tmpfile = outfile ++ ".#" + forM_ conf_table $ flip BL.writeFile $ Bin.encode tab - bracket (openFd tmpfile WriteOnly (Just 0o666) defaultFileFlags) closeFd $ \ofd -> - enumFile defaultBufSize infile >=> run $ - joinI $ readAvroContainer $ \av_meta -> - joinI $ progressPos getpos "calling at " conf_report (getRefseqs av_meta) $ - bcf_to_fd ofd (getRefseqs av_meta) [fromString sample_name] - (call (prior_div/3) prior_het, call prior_indel prior_het) + (de1,de2) <- estimateSingle tab + putStrLn $ unlines $ + showRes (point_est de1) : + [ "[ " ++ showRes u ++ " .. " ++ showRes v ++ " ]" | (u,v) <- conf_region de1 ] ++ + [] : showRes (point_est de2) : + [ "[ " ++ showRes u ++ " .. " ++ showRes v ++ " ]" | (u,v) <- conf_region de2 ] + where + showRes [dv,h] = "D = " ++ showFFloat (Just 6) dv ", " ++ + "H = " ++ showFFloat (Just 6) h "" + showRes [dv,hs,hw] = "D = " ++ showFFloat (Just 6) dv ", " ++ + "Hs = " ++ showFFloat (Just 6) hs ", " ++ + "Hw = " ++ showFFloat (Just 6) hw "" + showRes _ = error "Wtf? (showRes)" - let upd_bcf_files f s = s { sample_bcf_files = f $ sample_bcf_files s } - ins_bcf_file = upd_bcf_files $ H.insert rgn (fromString outfile) - updateMetadata (H.adjust ins_bcf_file (fromString sample_name)) conf_metadata - renameFile tmpfile outfile - _ -> fail $ sample_name ++ "/" ++ unpack rgn ++ " is missing divergence information" +withOutputFd :: FilePath -> (Fd -> IO a) -> IO a +withOutputFd "-" k = k stdOutput +withOutputFd f k = do + r <- withFd (f++".#") WriteOnly (Just 0o666) defaultFileFlags k + rename (f++".#") f + return r + +simple_calls :: V.Vector SubstModel -> Pile -> Calls +simple_calls dmods pile = pile { p_snp_pile = s, p_indel_pile = i } where - call :: Double -> Double -> U.Vector (Prob' Float) -> Int - call prior prior_h lks = U.maxIndex . U.zipWith (*) lks $ - U.replicate (U.length lks) (toProb . realToFrac $ prior_h * prior) - U.// [ (0, toProb . realToFrac $ 1-prior) ] - U.// [ (i, toProb . realToFrac $ (1-prior_h) * prior) - | i <- takeWhile (< U.length lks) (scanl (+) 2 [3..]) ] + !s = simple_snp_call get_dmg $ p_snp_pile pile + !i = simple_indel_call get_dmg $ p_indel_pile pile - getpos :: GenoCallBlock -> (Refseq, Int) - getpos b = (reference_name b, start_position b) + get_dmg :: DmgToken -> Int -> Bool -> Mat44D + get_dmg (DmgToken dt) = case dmods V.!? dt of + Nothing -> error "shouldn't happen" + Just sm -> lookupSubstModel sm - ifMatch :: Text -> Text -> a -> Maybe a -> Maybe a - ifMatch r k v a = if regMatch (regComp (unpack k)) (unpack r) then Just v else a +{-# INLINE decompose_dmg_from #-} +decompose_dmg_from :: HashMap Bytes DmgToken -> BamRaw -> [PosPrimChunks] +decompose_dmg_from hm raw = + let rg = extAsString "RG" (unpackBam raw) + in case H.lookup rg hm of + Just tk -> decompose tk raw + Nothing -> error $ "no substitution model for " ++ unpack rg --- | Generates BCF and writes it to a 'Handle'. For the necessary VCF --- header, we get the /names/ of the reference sequences from the Avro --- schema and the /lengths/ from the biohazard.refseq_length entry in --- the meta data. -bcf_to_fd :: MonadIO m => Fd -> Refs -> [S.ByteString] -> CallFuncs -> Iteratee [GenoCallBlock] m () -bcf_to_fd hdl refs name callz = - toBcf refs name callz ><> encodeBgzfWith 9 =$ - mapChunksM_ (\s -> liftIO $ S.unsafeUseAsCStringLen s $ \(p,l) -> - fdWriteBuf hdl (castPtr p) (fromIntegral l)) +mergeInputRgns :: (MonadIO m, MonadMask m) + => (BamMeta -> Enumeratee [BamRaw] [BamRaw] (Iteratee [BamRaw] m) a) + -> String -> [FilePath] -> Enumerator' BamMeta [BamRaw] m a +mergeInputRgns _ _ [ ] = \k -> return (k mempty) +mergeInputRgns (?) "" fps = mergeInputs (?) fps +mergeInputRgns (?) rs (fp0:fps0) = go fp0 fps0 + where + enum1 fp k1 = do idx <- liftIO $ readBamIndex fp + enumFileRandom defaultBufSize fp >=> run >=> run $ + decodeAnyBam $ \hdr -> + let Just ri = Z.findIndexL ((==) rs . unpack . sq_name) (meta_refs hdr) + in eneeBamRefseq idx (Refseq $ fromIntegral ri) $ k1 hdr + go fp [ ] = enum1 fp + go fp (fp1:fps) = mergeEnums' (go fp1 fps) (enum1 fp) (?) -type CallFunc = U.Vector (Prob' Float) -> Int -type CallFuncs = (CallFunc, CallFunc) +-- | Ploidy is hardcoded as two here. Can be changed if the need +-- arises. +call :: SinglePop -> U.Vector Prob -> Maybe StdGen -> (Int,Maybe StdGen) +call priors lks gen = case gen of + Nothing -> ( U.maxIndex ps, Nothing ) + Just g -> ( ix, Just g' ) + where + (p,g') = randomR (0, 1) g + ix = U.length $ U.takeWhile ( gen -> (Int, gen) +type CallFuncs gen = (CallFunc gen, CallFunc gen) + vcf_header :: Refs -> [S.ByteString] -> Push vcf_header refs smps = foldr (\a b -> pushByteString a <> pushByte 10 <> b) mempty $ [ "##fileformat=VCFv4.2" @@ -181,63 +226,69 @@ [ S.intercalate "\t" $ "#CHROM\tPOS\tID\tREF\tALT\tQUAL\tFILTER\tINFO\tFORMAT" : smps ] --- XXX Ploidy is being ignored. -toBcf :: Monad m => Refs -> [S.ByteString] -> CallFuncs -> Enumeratee [GenoCallBlock] Push m r -toBcf refs smps (snp_call, indel_call) = eneeCheckIfDone go +toBcf :: MonadIO m => Refs -> [S.ByteString] -> CallFuncs gen -> gen -> Enumeratee [Calls] Bytes m r +toBcf refs smps (snp_call, indel_call) gen0 = eneeCheckIfDone go ><> encodeBgzfWith 6 where - go k = mapChunks (foldMap encode) . k $ Chunk hdr - - hdr = pushByteString "BCF\2\2" <> setMark <> - vcf_header refs smps <> pushByte 0 <> endRecord + go k = eneeCheckIfDone (go2 gen0) . k $ Chunk hdr + go2 g k = tryHead >>= \zz -> case zz of + Nothing -> return $ liftI k + Just cs -> let (p,g1) = encode1 cs g + in eneeCheckIfDone (go2 g1) . k $ Chunk p - encode :: GenoCallBlock -> Push - encode GenoCallBlock{..} = mconcat $ zipWith (encode1 reference_name) [start_position..] called_sites + hdr = pushByteString "BCF\2\2" <> setMark <> + vcf_header refs smps <> pushByte 0 <> endRecord - encode1 :: Refseq -> Int -> GenoCallSite -> Push - encode1 ref pos site = - encodeSNP site ref pos snp_call <> - case indel_variants site of - [ ] -> mempty - [_] -> mempty - v:_ | U.null d && U.null i -> encodeIndel site ref pos indel_call - | otherwise -> error "First indel variant should always be the reference." - where - IndelVariant (V_Nucs d) (V_Nuc i) = v + encode1 cs g0 = (p1 <> p2, g2) + where + (p1,g1) = encodeSNP cs snp_call g0 + (p2,g2) = case snd $ p_indel_pile cs of + [ ] -> (mempty,g1) + [_] -> (mempty,g1) + v:_ | U.null d && U.null i -> encodeIndel cs indel_call g1 + | otherwise -> error "First indel variant should always be the reference." + where + IndelVariant (V_Nucs d) (V_Nuc i) = v -encodeSNP :: GenoCallSite -> Refseq -> Int -> CallFunc -> Push -encodeSNP site = encodeVar (map S.singleton alleles) (snp_likelihoods site) (snp_stats site) +encodeSNP :: Calls -> CallFunc gen -> gen -> (Push, gen) +encodeSNP cs = encodeVar (map S.singleton alleles) (gls `U.backpermute` U.fromList perm) + (p_snp_stat cs) (p_refseq cs) (p_pos cs) where - -- Permuting the reference allele to the front sucks. Since - -- there are only four possibilities, I'm not going to bother - -- with an algorithm and just open-code it. - alleles | ref_allele site == nucsT = "TACG" - | ref_allele site == nucsG = "GACT" - | ref_allele site == nucsC = "CAGT" - | otherwise = "ACGT" + Snp_GLs gls ref_allele = p_snp_pile cs -encodeIndel :: GenoCallSite -> Refseq -> Int -> CallFunc -> Push -encodeIndel site = encodeVar alleles (indel_likelihoods site) (indel_stats site) + -- Permuting the reference allele to the front in alleles and PLs + -- sucks. Since there are only four possibilities, I'm not going to + -- bother with an algorithm and just open-code it. + (alleles, perm) | ref_allele == nucsT = ("TACG", [9,6,0,7,1,2,8,3,4,5]) + | ref_allele == nucsG = ("GACT", [5,3,0,4,1,2,8,6,7,9]) + | ref_allele == nucsC = ("CAGT", [2,1,0,4,3,5,7,6,8,9]) + | otherwise = ("ACGT", [0,1,2,3,4,5,6,7,8,9]) + +encodeIndel :: Calls -> CallFunc gen -> gen -> (Push, gen) +encodeIndel cs = encodeVar alleles (fst $ p_indel_pile cs) + (p_indel_stat cs) (p_refseq cs) (p_pos cs) where - -- We're looking at the indel /after/ the current position. - -- That's sweet, because we can just prepend the current - -- reference base and make bcftools and friends happy. Longest - -- reported deletion becomes the reference allele. Others may - -- need padding. - rallele = snd $ maximum [ (U.length r, r) | IndelVariant (V_Nucs r) _ <- indel_variants site ] - alleles = [ S.pack $ showNucleotides (ref_allele site) : show (U.toList a) ++ show (U.toList $ U.drop (U.length r) rallele) - | IndelVariant (V_Nucs r) (V_Nuc a) <- indel_variants site ] + Snp_GLs _ ref_allele = p_snp_pile cs -encodeVar :: [S.ByteString] -> U.Vector Mini -> CallStats -> Refseq -> Int -> CallFunc -> Push -encodeVar alleles likelihoods CallStats{..} ref pos do_call = - setMark <> setMark <> -- remember space for two marks - b_share <> endRecordPart1 <> -- store 1st length and 2nd mark - b_indiv <> endRecordPart2 -- store 2nd length + -- We're looking at the indel /after/ the current position. That's + -- sweet, because we can just prepend the current reference base and + -- make bcftools and friends happy. Longest reported deletion + -- becomes the reference allele. Others may need padding. + rallele = snd $ maximum [ (U.length r, r) | IndelVariant (V_Nucs r) _ <- snd $ p_indel_pile cs ] + alleles = [ S.pack $ showNucleotides ref_allele : show (U.toList a) ++ show (U.toList $ U.drop (U.length r) rallele) + | IndelVariant (V_Nucs r) (V_Nuc a) <- snd $ p_indel_pile cs ] + +encodeVar :: [S.ByteString] -> U.Vector Prob -> CallStats -> Refseq -> Int -> CallFunc gen -> gen -> (Push, gen) +encodeVar alleles lks CallStats{..} ref pos do_call gen = + ( setMark <> setMark <> -- remember space for two marks + b_share <> endRecordPart1 <> -- store 1st length and 2nd mark + b_indiv <> endRecordPart2 -- store 2nd length + , gen' ) where b_share = pushWord32 (unRefseq ref) <> pushWord32 (fromIntegral pos) <> pushWord32 0 <> -- rlen?! WTF?! - pushFloat gq <> -- QUAL + pushFloat (double2Float gq) <> -- QUAL pushWord16 2 <> -- ninfo pushWord16 (fromIntegral $ length alleles) <> -- n_allele pushWord32 0x04000001 <> -- n_fmt, n_sample @@ -273,15 +324,11 @@ | otherwise = pushByte 0xF7 <> pushByte 0x03 <> pushWord32 (fromIntegral $ S.length s) <> pushByteString s pl_vals = U.foldr ((<>) . pushWord16 . round . max 0 . min 0x7fff . (*) (-10/log 10) . unPr . (/ lks U.! maxidx)) mempty lks - - lks = U.map (Pr . negate . mini2float) likelihoods :: U.Vector (Prob' Float) maxidx = U.maxIndex lks gq = -10 * unPr (U.sum (U.ifilter (\i _ -> i /= maxidx) lks) / U.sum lks) / log 10 gq' = round . max 0 . min 127 $ gq - callidx = do_call lks + (callidx, gen') = do_call lks gen h = length $ takeWhile (<= callidx) $ scanl (+) 1 [2..] g = callidx - h * (h+1) `div` 2 - -