packages feed

biohazard 0.6.6.1 → 0.6.9

raw patch · 66 files changed

+3465/−4422 lines, 66 filesdep +aeson-prettydep +base-preludedep +hybrid-vectorsdep −Vecdep −deepseqdep −hmatrixdep ~aesondep ~asyncdep ~attoparsecsetup-changednew-component:exe:redeye-flownew-component:exe:test-pileup

Dependencies added: aeson-pretty, base-prelude, hybrid-vectors, process, shake, vector-binary-instances

Dependencies removed: Vec, deepseq, hmatrix, strict

Dependency ranges changed: aeson, async, attoparsec, base, binary, bytestring, filepath, iteratee, nonlinear-optimization, primitive, random, stm, text, transformers, unix, unordered-containers, vector, vector-algorithms

Files

Setup.hs view
@@ -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)
biohazard.cabal view
@@ -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,
data/index_db.json view
@@ -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",
− doc/genotyping.tex 
@@ -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}
+ man/man1/bam-fixpair.1 view
@@ -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 <udo_stenzel@eva.mpg.de>++.SH "SEE ALSO"+.BR biohazard (7)+
+ man/man1/fastq2bam.1 view
@@ -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 <udo_stenzel@eva.mpg.de>++.SH "SEE ALSO"+.BR biohazard (7)+
src/Bio/Adna.hs view
@@ -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
src/Bio/Align.hs view
@@ -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 :
src/Bio/Bam/Evan.hs view
@@ -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
src/Bio/Bam/Fastq.hs view
@@ -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
src/Bio/Bam/Filter.hs view
@@ -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
src/Bio/Bam/Header.hs view
@@ -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)
src/Bio/Bam/Index.hs view
@@ -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                      $=
src/Bio/Bam/Pileup.hs view
@@ -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)
src/Bio/Bam/Reader.hs view
@@ -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
src/Bio/Bam/Rec.hs view
@@ -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))
src/Bio/Bam/Regions.hs view
@@ -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)
src/Bio/Bam/Rmdup.hs view
@@ -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
src/Bio/Bam/Trim.hs view
@@ -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']+
src/Bio/Bam/Writer.hs view
@@ -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))+
src/Bio/Base.hs view
@@ -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)
src/Bio/Genocall.hs view
@@ -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)
− src/Bio/Genocall/AvroFile.hs 
@@ -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-
+ src/Bio/Genocall/Estimators.hs view
@@ -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) ]
− src/Bio/Genocall/Metadata.hs 
@@ -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
src/Bio/Iteratee.hs view
@@ -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
src/Bio/Iteratee/Bgzf.hsc view
@@ -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
src/Bio/Iteratee/Builder.hs view
@@ -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
src/Bio/Iteratee/ZLib.hsc view
@@ -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
+ src/Bio/Prelude.hs view
@@ -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+
src/Bio/PriorityQueue.hs view
@@ -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
src/Bio/TwoBit.hs view
@@ -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"
src/Bio/Util/AD.hs view
@@ -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
src/Bio/Util/AD2.hs view
@@ -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 ]
+ src/Bio/Util/Jacobi.hs view
@@ -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<q@.  Algorithm inspired by "Numerical+-- Recipes in C: The Art of Scientific Computing" (ISBN 0-521-43108-6)+jacobi_rot :: Int -> 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+
src/Bio/Util/Numeric.hs view
@@ -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)
− src/Bio/Util/Regex.hsc 
@@ -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 <sys/types.h>-#include <regex.h>--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 "&regfree" regfree :: FunPtr (Ptr Regex -> IO ())
+ src/Bio/Util/Zlib.hs view
@@ -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+
− src/Data/Avro.hs 
@@ -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--
− src/Data/MiniFloat.hs 
@@ -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--
src/cbits/myers_align.c view
@@ -4,8 +4,6 @@ #include <stdlib.h> #include <string.h> -inline int match( char a, char b ) { return (char_to_bitmap(a) & char_to_bitmap(b)) != 0 ; }- // [*blech*, this looks and feels like FORTRAN.] unsigned myers_diff(         const char *seq_a, int len_a, enum myers_align_mode mode,
src/cbits/myers_align.h view
@@ -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
+ tests/test-pileup.hs view
@@ -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
tools/Align.hs view
@@ -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
tools/Anno.hs view
@@ -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|
tools/Index.hs view
@@ -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(..) )
tools/Seqs.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-} module Seqs where  import Data.ByteString.Char8 (ByteString)
tools/SimpleSeed.hs view
@@ -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
tools/Xlate.hs view
@@ -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
tools/afroengineer.hs view
@@ -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]
tools/bam-fixpair.hs view
@@ -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 ()
tools/bam-meld.hs view
@@ -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)]
tools/bam-resample.hs view
@@ -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
tools/bam-rewrap.hs view
@@ -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
tools/bam-rmdup.hs view
@@ -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)+
tools/bam-trim.hs view
@@ -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 }
tools/fastq2bam.hs view
@@ -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 ++ ", "
− tools/gt-scan.hs 
@@ -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))-
tools/jivebunny.hs view
@@ -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
tools/mt-anno.hs view
@@ -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
tools/mt-ccheck.hs view
@@ -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.
tools/redeye-dar.hs view
@@ -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
− tools/redeye-div.hs 
@@ -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-
+ tools/redeye-flow.hs view
@@ -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)++
− tools/redeye-pileup.hs 
@@ -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-
tools/redeye-single.hs view
@@ -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 (<p) $ U.map fromProb $+                 U.init $ U.postscanl (+) 0 $ U.map (/ U.sum ps) ps+  where+    ps = single_pop_posterior priors 0 lks++++-- A function from likelihoods to called index.  It's allowed to require+-- a random number generator.+type CallFunc gen = U.Vector Prob -> 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--