@@ -12,8 +12,7 @@ Depends:

     methods,

     BiocGenerics,

     GenomicRanges (>= 1.29.14),

-    SummarizedExperiment (>= 1.9.18),

-    parallel

+    SummarizedExperiment (>= 1.9.18)

 Imports:

     IRanges (>= 2.11.16),

     GenomeInfoDb,

@@ -30,17 +29,24 @@ Imports:

     permute,

     limma,

     DelayedArray (>= 0.5.34),

-    HDF5Array

+    Rcpp,

+    BiocParallel,

+    readr

 Suggests:

-    RUnit,

+    testthat,

     bsseqData,

     BiocStyle,

     rmarkdown,

     knitr,

+    beachmat,

+    Matrix,

+    HDF5Array,

+    doParallel,

+    testthat

 Collate:

     utils.R

     hasGRanges.R

-    BSseq_class.R

+    BSseq-class.R

     BSseqTstat_class.R

     BSseq_utils.R

     combine.R

@@ -57,8 +63,8 @@ Collate:

     BSseqStat_class.R

     getStats.R

     hdf5_utils.R

-    combine_utils.R

     DelayedArray_utils.R

+    collapseBSseq.R

 License: Artistic-2.0

 VignetteBuilder: knitr

 URL: https://github.com/kasperdanielhansen/bsseq

@@ -66,3 +72,6 @@ LazyData: yes

 LazyDataCompression: xz

 BugReports: https://github.com/kasperdanielhansen/bsseq/issues

 biocViews: DNAMethylation

+SystemRequirements: C++11

+LinkingTo: Rcpp, Rhdf5lib, beachmat

+NeedsCompilation: yes

@@ -17,7 +17,7 @@ importFrom(graphics, "abline", "axis", "layout", "legend", "lines",

 import(parallel)

 importFrom(locfit, "locfit", "lp")

 importFrom(DelayedMatrixStats, "rowSds", "rowVars", "colMeans2", "colSums2",

-           "rowSums2", "rowMeans2")

+           "rowSums2", "rowMeans2", "rowAlls")

 import(IRanges)

 import(GenomicRanges)

 import(SummarizedExperiment)

@@ -35,10 +35,9 @@ importFrom(data.table, "fread", "setnames")

 importFrom(R.utils, "isGzipped", "gunzip")

 import(limma)

 importFrom(permute, "shuffleSet", "how")

-importClassesFrom(DelayedArray, "DelayedArray", "DelayedMatrix")

-importFrom(DelayedArray, "DelayedArray", "plogis", "pmin2", "pmax2", "rowMaxs",

-           "rowMins")

-importClassesFrom(HDF5Array, "HDF5Array")

+import(DelayedArray)

+import(BiocParallel)

+importFrom(Rcpp, "sourceCpp")

 ##

 ## Exporting

@@ -86,3 +85,5 @@ S3method("plot", "BSseqTstat")

 exportMethods("assays", "assayNames")

+# C++ code registration

+useDynLib(bsseq, .registration = TRUE, .fixes = "cxx_")

@@ -1,3 +1,15 @@

+# Internal functions -----------------------------------------------------------

+

+.rowTickmarks <- function(hasGRanges, maxGap) {

+    gr <- granges(hasGRanges)

+    # NOTE: This relies on 'gr' being sorted, so really want to be sure of this!

+    stopifnot(!is.unsorted(gr))

+    clusters <- reduce(gr, min.gapwidth = maxGap, with.revmap = TRUE)

+    cumsum(lengths(mcols(clusters)[["revmap"]]))

+}

+

+# TODO: Remove other uses of this function, if possible.

+# TODO: Rename to .makeClusters() since it's an internal function

 makeClusters <- function(hasGRanges, maxGap = 10^8) {

     chrOrder <- as.character(runValue(seqnames(hasGRanges)))

     if(anyDuplicated(chrOrder))

@@ -18,136 +30,320 @@ makeClusters <- function(hasGRanges, maxGap = 10^8) {

     clusterIdx

 }

+.BSmooth <- function(b, M, Cov, pos, coef_sink, se.coef_sink,

+                     coef_sink_lock, se.coef_sink_lock, grid, pos_grid,

+                     ns, h, keep.se) {

+    # Load packages on worker (required for SnowParam) -------------------------

+

+    suppressPackageStartupMessages({

+        library(BiocParallel)

+    })

+    suppressPackageStartupMessages({

+        library(locfit)

+    })

+    suppressPackageStartupMessages({

+        library(DelayedArray)

+    })

+

+    # Construct inputs for smoothing -------------------------------------------

+

+    # NOTE: 'bb' indexes over elements of pos_grid by cycling `ncol(M)` times

+    #       over 1, ..., nrow(pos_grid).

+    bb <- (b - 1L) %% nrow(pos_grid) + 1L

+    # NOTE: unname() is necessary because M and Cov may carry colnames

+    sdata <- data.frame(

+        pos = DelayedArray:::extract_block(pos, pos_grid[[bb]]),

+        M = unname(DelayedArray:::extract_block(M, grid[[b]])),

+        Cov = unname(DelayedArray:::extract_block(Cov, grid[[b]])))

+    # Ensure 0 < M < Cov to avoid boundary issues (only relevant at loci with

+    # non-zero coverage, so doesn't matter what M is for these loci).

+    sdata[["M"]] <- pmin(pmax(sdata[["M"]], 0.01), pmax(sdata[["Cov"]] - 0.01))

+    n_loci <- nrow(sdata)

+    n_loci_with_non_zero_coverage <- sum(sdata[["Cov"]] > 0)

-BSmooth <- function(BSseq, ns = 70, h = 1000, maxGap = 10^8, parallelBy = c("sample", "chromosome"),

-                    mc.preschedule = FALSE, mc.cores = 1, keep.se = FALSE, verbose = TRUE) {

-    smooth <- function(idxes, sampleIdx) {

-        ## Assuming that idxes is a set of indexes into the BSseq object

-        ## sampleIdx is a single character

-        this_sample_chr <- c(sampleNames(BSseq)[sampleIdx],

-                             as.character(seqnames(BSseq)[idxes[1]]))

-        if(verbose >= 2)

-            cat(sprintf("[BSmooth]   smoothing start: sample:%s, chr:%s, nLoci:%s\n",

-                        this_sample_chr[1], this_sample_chr[2], length(idxes)))

-        Cov <- unname(as.array(

-            getCoverage(BSseq, type = "Cov")[idxes, sampleIdx]))

-        M <- unname(as.array(

-            getCoverage(BSseq, type = "M")[idxes, sampleIdx]))

-        pos <- start(BSseq)[idxes]

-        stopifnot(all(diff(pos) > 0))

-        wh <- which(Cov != 0)

-        nn <- ns / length(wh)

-        if(length(wh) <= ns) {

-            if(keep.se)

-                se.coef <- rep(NA_real_, length(Cov))

-            else

-                se.coef <- NULL

-            return(list(coef = rep(NA_real_, length(Cov)),

-                        se.coef = se.coef,

-                        trans = NULL, h = h, nn = nn))

+    # Fit local binomial regression model --------------------------------------

+

+    # NOTE: Require (ns + 1) loci with non-zero coverage to run smooth.

+    if (n_loci_with_non_zero_coverage <= ns) {

+        coef <- rep(NA_real_, n_loci)

+        if (keep.se) {

+            se.coef <- rep(NA_real_, n_loci)

+        } else {

+            se.coef <- NULL

         }

-        sdata <- data.frame(pos = pos[wh],

-                            M = pmin(pmax(M[wh], 0.01),

-                                     Cov[wh] - 0.01),

-                            Cov = Cov[wh])

-        fit <- locfit(M ~ lp(pos, nn = nn, h = h), data = sdata,

-                      weights = Cov, family = "binomial", maxk = 10000)

-        pp <- preplot(fit, where = "data", band = "local",

-                      newdata = data.frame(pos = pos))

-        if(keep.se) {

+    } else {

+        # Set 'nearest neighbour' smoothing parameter.

+        nn <- ns / n_loci_with_non_zero_coverage

+        # Fit model only using loci with non-zero coverage.

+        fit <- locfit(

+            M ~ lp(pos, nn = nn, h = h),

+            data = sdata,

+            weights = Cov,

+            family = "binomial",

+            subset = Cov > 0,

+            maxk = 10000)

+        # Evaluate smooth at all loci (regardless of coverage).

+        pp <- preplot(

+            object = fit,

+            newdata = sdata["pos"],

+            band = "local")

+        coef <- pp$fit

+        if (keep.se) {

             se.coef <- pp$se.fit

         } else {

             se.coef <- NULL

         }

-        if(verbose >= 2)

-            cat(sprintf("[BSmooth]   smoothing end: sample:%s, chr:%s, nLoci:%s, nCoveredLoci:%s\n",

-                        this_sample_chr[1], this_sample_chr[2], length(idxes), nrow(sdata)))

-        return(list(coef = pp$fit, se.coef = se.coef,

-                    trans = pp$trans, h = h, nn = nn))

     }

-    stopifnot(class(BSseq) == "BSseq")

-    parallelBy <- match.arg(parallelBy)

-    if(verbose) cat("[BSmooth] preprocessing ... ")

-    ptime1 <- proc.time()

-    clusterIdx <- makeClusters(BSseq, maxGap = maxGap)

-    ptime2 <- proc.time()

-    stime <- (ptime2 - ptime1)[3]

-    if(verbose) cat(sprintf("done in %.1f sec\n", stime))

-

-    sampleNames <- sampleNames(BSseq)

-    names(sampleNames) <- sampleNames

-

-    ptime.outer1 <- proc.time()

-    switch(parallelBy, "sample" = {

-        if(verbose) cat(sprintf("[BSmooth] smoothing by 'sample' (mc.cores = %d, mc.preschedule = %s)\n",

-                                mc.cores, mc.preschedule))

-        out <- mclapply(seq(along = sampleNames), function(sIdx) {

-            ptime1 <- proc.time()

-            tmp <- lapply(clusterIdx, function(jj) {

-                try(smooth(idxes = jj, sampleIdx = sIdx))

-            })

-            coef <- do.call(c, lapply(tmp, function(xx) xx$coef))

-            se.coef <- do.call(c, lapply(tmp, function(xx) xx$se.coef))

-            ptime2 <- proc.time()

-            stime <- (ptime2 - ptime1)[3]

-            if(verbose) {

-                cat(sprintf("[BSmooth] sample %s (out of %d), done in %.1f sec\n",

-                            sampleNames[sIdx], length(sampleNames), stime))

+

+    # Return the results of the smooth or write them to the RealizationSink ----

+

+    if (is.null(coef_sink)) {

+        return(list(coef = coef, se.coef = se.coef))

+    }

+    # Write to coef_sink and se.coef_sink while respecting the IPC lock(s).

+    ipclock(coef_sink_lock)

+    write_block_to_sink(as.matrix(coef), coef_sink, grid[[b]])

+    ipcunlock(coef_sink_lock)

+    if (keep.se) {

+        ipclock(se.coef_sink_lock)

+        write_block_to_sink(as.matrix(se.coef), se.coef_sink, grid[[b]])

+        ipcunlock(se.coef_sink_lock)

+    }

+}

+

+# Exported functions -----------------------------------------------------------

+

+# TODO: Make 'mc.cores', 'mc.preschedule', and 'verbose' defunct one release

+#       cycle with them deprecated.

+# TODO: Consider having BSmooth() create a 'smoothed' assay in addition to or

+#       instead of the 'coef' and 'se.coef' assays.

+# TODO: To benefit from error recovery requires that bpStopOnError(BPPARAM) is

+#       TRUE but the default is FALSE. How to help the user? Probably don't

+#       want to override the user-specified value.

+BSmooth <- function(BSseq, ns = 70, h = 1000, maxGap = 10^8,

+                    parallelBy = c("sample", "chromosome"),

+                    mc.preschedule = FALSE, mc.cores = 1, keep.se = FALSE,

+                    verbose = TRUE, BPREDO = list(), BPPARAM = bpparam()) {

+    # Argument checks-----------------------------------------------------------

+

+    # Check if this is a re-do.

+    # NOTE: Under the assumptions of a re-do (i.e. BSmooth() is being re-run

+    #       with the same arguments), we skip straight ahead to re-running

+    #       failed smoothing tasks with no further argument checks.

+    if (length(BPREDO)) {

+        if (!is.list(BPREDO) ||

+            identical(names(BPREDO), c("smooth", "coef_sink", "se.coef_sink",

+                                       "realization_backend"))) {

+            stop("'BPREDO' should be a list with elements 'smooth', ",

+                 "'coef_sink', 'se.coef_sink', and 'realization_backend'.")

+        }

+        is_redo <- TRUE

+        coef_sink <- BPREDO[["coef_sink"]]

+        se.coef_sink <- BPREDO[["se.coef_sink"]]

+        realization_backend <- BPREDO[["realization_sink"]]

+        BPREDO <- BPREDO[["smooth"]]

+    } else {

+        is_redo <- FALSE

+        # Check validity of 'BSseq' argument

+        if (!is(BSseq, "BSseq")) {

+            stop("'BSseq' must be a BSseq object.")

+        }

+        if (!isTRUE(all(width(BSseq) == 1L))) {

+            stop("All loci in 'BSseq' must have width == 1.")

+        }

+        if (is.unsorted(BSseq)) {

+            stop("'BSseq' must be sorted before smoothing. Use 'sort(BSseq)'.")

+        }

+        # Check for deprecated arguments and issue warning(s) if found.

+        if (!missing(parallelBy)) {

+            warning(

+                "'parallelBy' is deprecated.\n",

+                "See help(\"BSmooth\") for details.",

+                call. = FALSE,

+                immediate. = TRUE)

+        }

+        if (!missing(mc.preschedule)) {

+            warning(

+                "'mc.preschedule' is deprecated.\n",

+                "See help(\"BSmooth\") for details.",

+                call. = FALSE,

+                immediate. = TRUE)

+        }

+        if (!missing(mc.cores)) {

+            warning(

+                "'mc.cores' is deprecated.\n",

+                "See help(\"BSmooth\").",

+                call. = FALSE,

+                immediate. = TRUE)

+            BPPARAM <- MulticoreParam(workers = mc.cores)

+        }

+        if (!missing(verbose)) {

+            warning(

+                "'verbose' is deprecated.\n",

+                "See help(\"BSmooth\") for details.",

+                call. = FALSE,

+                immediate. = TRUE)

+            if (verbose) bpprogressbar(BPPARAM) <- TRUE

+        }

+        # Check compatability of realization backend with backend(s) of BSseq

+        # object.

+        realization_backend <- getRealizationBackend()

+        BSseq_backends <- .getBSseqBackends(BSseq)

+        if (.areBackendsInMemory(realization_backend) &&

+            !.areBackendsInMemory(BSseq_backends)) {

+            stop("Using an in-memory backend for a disk-backed BSseq object ",

+                 "is not supported.\n",

+                 "See help(\"BSmooth\") for details.",

+                 call. = FALSE)

+        }

+        # Check compatability of 'BPPARAM' with the realization backend.

+        if (!.areBackendsInMemory(realization_backend)) {

+            if (!.isSingleMachineBackend(BPPARAM)) {

+                stop("The parallelisation strategy must use a single machine ",

+                     "when using an on-disk realization backend.\n",

+                     "See help(\"BSmooth\") for details.",

+                     call. = FALSE)

+            }

+        } else {

+            if (!is.null(realization_backend)) {

+                # NOTE: Currently do not support any in-memory realization

+                #       backends. If the realization backend is NULL then an

+                #       ordinary matrix is returned rather than a matrix-backed

+                #       DelayedMatrix.

+                stop("The '", realization_backend, "' realization backend is ",

+                     "not supported.\n",

+                     "See help(\"BSmooth\") for details.",

+                     call. = FALSE)

+            }

+        }

+    }

+

+    # Smoothing ----------------------------------------------------------------

+

+    # Extract pieces of BSseq object required for smoothing

+    M <- getCoverage(BSseq, type = "M", withDimnames = FALSE)

+    Cov <- getCoverage(BSseq, type = "Cov", withDimnames = FALSE)

+    pos <- matrix(start(BSseq), ncol = 1)

+    # Set up ArrayGrid so that each block contains data for a single sample and

+    # single cluster of loci.

+    row_tickmarks <- .rowTickmarks(BSseq, maxGap)

+    col_tickmarks <- seq_len(ncol(M))

+    grid <- ArbitraryArrayGrid(list(row_tickmarks, col_tickmarks))

+    # Set up "parallel" ArrayGrid over pos

+    pos_grid <- ArbitraryArrayGrid(list(row_tickmarks, 1L))

+    # Construct RealizationSink objects (as required)

+    if (!is_redo) {

+        if (is.null(realization_backend)) {

+            coef_sink <- NULL

+            coef_sink_lock <- NULL

+            se.coef_sink <- NULL

+            se.coef_sink_lock <- NULL

+        } else {

+            coef_sink <- DelayedArray:::RealizationSink(dim(M), type = "double")

+            on.exit(close(coef_sink), add = TRUE)

+            coef_sink_lock <- ipcid()

+            on.exit(ipcremove(coef_sink_lock), add = TRUE)

+            if (keep.se) {

+                se.coef_sink <- DelayedArray:::RealizationSink(dim(M),

+                                                               type = "double")

+                on.exit(close(se.coef_sink), add = TRUE)

+                se.coef_sink_lock <- ipcid()

+                on.exit(ipcremove(se.coef_sink_lock), add = TRUE)

+            } else {

+                se.coef_sink <- NULL

+                se.coef_sink_lock <- NULL

             }

-            return(list(coef = coef, se.coef = se.coef))

-        }, mc.preschedule = mc.preschedule, mc.cores = mc.cores)

-        if(any(sapply(out, is, class2 = "try-error")))

-            stop("BSmooth encountered smoothing errors")

-        coef <- do.call(cbind, lapply(out, function(xx) xx$coef))

-        se.coef <- do.call(cbind, lapply(out, function(xx) xx$se.coef))

-    }, "chromosome" = {

-        if(verbose) cat(sprintf("[BSmooth] smoothing by 'chromosome' (mc.cores = %d, mc.preschedule = %s)\n",

-                                mc.cores, mc.preschedule))

-        out <- mclapply(1:length(clusterIdx), function(ii) {

-            ptime1 <- proc.time()

-            tmp <- lapply(seq(along = sampleNames), function(sIdx) {

-                smooth(idxes = clusterIdx[[ii]], sampleIdx = sIdx)

-            })

-            coef <- do.call(cbind, lapply(tmp, function(xx) xx$coef))

-            se.coef <- do.call(cbind, lapply(tmp, function(xx) xx$se.coef))

-            ptime2 <- proc.time()

-            stime <- (ptime2 - ptime1)[3]

-            if(verbose)

-                cat(sprintf("[BSmooth] chr idx %d (out of %d), done in %.1f sec\n",

-                            ii, length(clusterIdx), stime))

-            return(list(coef = coef, se.coef = se.coef))

-        }, mc.preschedule = mc.preschedule, mc.cores = mc.cores)

-        if(any(sapply(out, is, class2 = "try-error")))

-            stop("BSmooth encountered smoothing errors")

-        coef <- do.call(rbind, lapply(out, function(xx) xx$coef))

-        se.coef <- do.call(rbind, lapply(out, function(xx) xx$se.coef))

-    })

-    coef <- .DelayedMatrix(coef)

-    if (!is.null(se.coef)) {

-        se.coef <- .DelayedMatrix(se.coef)

+        }

+    }

+

+    # Set number of tasks to ensure the progress bar gives frequent updates.

+    # NOTE: The progress bar increments once per task

+    #       (https://github.com/Bioconductor/BiocParallel/issues/54).

+    #       Although it is somewhat of a bad idea to overrides a user-specified

+    #       bptasks(BPPARAM), the value of bptasks(BPPARAM) doesn't affect

+    #       performance in this instance, and so we opt for a useful progress

+    #       bar. Only SnowParam (and MulticoreParam by inheritance) have a

+    #       bptasks<-() method.

+    if (is(BPPARAM, "SnowParam") && bpprogressbar(BPPARAM)) {

+        bptasks(BPPARAM) <- length(grid)

+    }

+    smooth <- bptry(bplapply(

+        X = seq_along(grid),

+        FUN = .BSmooth,

+        M = M,

+        Cov = Cov,

+        pos = pos,

+        coef_sink = coef_sink,

+        se.coef_sink = se.coef_sink,

+        coef_sink_lock = coef_sink_lock,

+        se.coef_sink_lock = se.coef_sink_lock,

+        grid = grid,

+        pos_grid = pos_grid,

+        ns = ns,

+        h = h,

+        keep.se = keep.se,

+        BPREDO = BPREDO,

+        BPPARAM = BPPARAM))

+    if (!all(bpok(smooth))) {

+        # TODO: Feels like stop() rather than warning() should be used, but

+        #       stop() doesn't allow for the return of partial results;

+        #       see https://support.bioconductor.org/p/109374/

+        warning("BSmooth() encountered errors: ",

+                sum(!bpok(smooth)), " of ", length(smooth),

+                " smoothing tasks failed.\n",

+                "BSmooth() has returned partial results, including errors, ",

+                "for debugging purposes.\n",

+                "It may be possible to re-run just these failed smoothing ",

+                "tasks.\nSee help(\"BSmooth\")",

+                call. = FALSE)

+        # NOTE: Return intermediate results as well as all derived variables.

+        return(list(smooth = smooth,

+                    coef_sink = coef_sink,

+                    se.coef_sink = se.coef_sink,

+                    realization_backend = realization_backend))

     }

-    ptime.outer2 <- proc.time()

-    stime.outer <- (ptime.outer2 - ptime.outer1)[3]

-    if(verbose)

-        cat(sprintf("[BSmooth] smoothing done in %.1f sec\n", stime.outer))

-

-    rownames(coef) <- NULL

-    colnames(coef) <- sampleNames(BSseq)

-    if(!is.null(se.coef)) {

-        rownames(se.coef) <- NULL

-        colnames(se.coef) <- sampleNames(BSseq)

+    # Construct coef and se.coef from results of smooth().

+    if (is.null(realization_backend)) {

+        # Returning matrix objects.

+        coef <- do.call(c, lapply(smooth, "[[", "coef"))

+        attr(coef, "dim") <- dim(M)

+        if (keep.se) {

+            se.coef <- do.call(c, lapply(smooth, "[[", "se.coef"))

+            attr(se.coef, "dim") <- dim(M)

+        } else {

+            se.coef <- NULL

+        }

+    } else {

+        # Returning DelayedMatrix objects.

+        coef <- as(coef_sink, "DelayedArray")

+        if (keep.se) {

+            se.coef <- as(se.coef_sink, "DelayedArray")

+        } else {

+            se.coef <- NULL

+        }

     }

-    if(!is.null(coef))

-        assay(BSseq, "coef") <- coef

-    if(!is.null(se.coef))

-        assay(BSseq, "se.coef") <- se.coef

-    BSseq@trans <- plogis

+    # Construct BSseq object ---------------------------------------------------

-    parameters <- list(smoothText = sprintf("BSmooth (ns = %d, h = %d, maxGap = %d)", ns, h, maxGap),

-                       ns = ns, h = h, maxGap = maxGap)

-    BSseq@parameters <- parameters

-    BSseq

+    assays <- c(assays(BSseq, withDimnames = FALSE), SimpleList(coef = coef))

+    if (keep.se) assays <- c(assays, SimpleList(se.coef = se.coef))

+    BiocGenerics:::replaceSlots(

+        object = BSseq,

+        assays = Assays(assays),

+        trans = plogis,

+        parameters = list(

+            smoothText = sprintf(

+                "BSmooth (ns = %d, h = %d, maxGap = %d)", ns, h, maxGap),

+            ns = ns,

+            h = h,

+            maxGap = maxGap),

+        check = FALSE)

 }

+# TODOs ------------------------------------------------------------------------

+# TODO: Use the logging facilities of BiocParallel. This is a longterm goal.

+#       For example, we could set custom messages within .BSmooth() using the

+#       futile.logger syntax; see the BiocParalell vignette 'Errors, Logs and

+#       Debugging in BiocParallel'.

+# TODO: Remove NOTEs that are really documentation issues to the docs

new file mode 100644

@@ -0,0 +1,318 @@

+# Exported classes -------------------------------------------------------------

+

+# NOTE: This create a 'classGeneratorFunction' (internal constructor), .BSseq()

+.BSseq <- setClass(

+    "BSseq",

+    slots = representation(

+        trans = "function",

+        parameters = "list"),

+    contains = "RangedSummarizedExperiment"

+)

+

+# Validity methods -------------------------------------------------------------

+

+.checkAssayNames <- function(object, names) {

+    if (all(names %in% assayNames(object))) {

+        return(NULL)

+    } else {

+        paste0(

+            "object of class ",

+            class(object),

+            " needs to have assay slots with names ",

+            paste0(names, collapse = ", "))

+

+    }

+}

+

+.checkMandCov <- function(M, Cov) {

+    msg <- NULL

+    validMsg(msg, .Call(cxx_check_M_and_Cov, M, Cov))

+}

+

+setValidity2("BSseq", function(object) {

+    msg <- NULL

+

+    if (identical(object, .BSseq())) {

+        # No validity checks for object returned by internal constructor

+        return(msg)

+    }

+    msg <- validMsg(msg, .checkAssayNames(object, c("Cov", "M")))

+

+    # TODO: Are colnames strictly necessary?

+    if (is.null(colnames(object))) {

+        msg <- validMsg(msg, "colnames (aka sampleNames) need to be set")

+    }

+

+    assay_rownames <- lapply(assays(object), rownames)

+    if (!all(S4Vectors:::sapply_isNULL(assay_rownames))) {

+        msg <- validMsg(msg, "unnecessary rownames on one-or-more assays")

+    }

+

+    msg <- validMsg(msg,

+                    .checkMandCov(assay(object, "M", withDimnames = FALSE),

+                                  assay(object, "Cov", withDimnames = FALSE)))

+

+    if (is.null(msg)) TRUE else msg

+})

+

+# Internal functions -----------------------------------------------------------

+

+.oldTrans <- function(x) {

+    y <- x

+    ix <- which(x < 0)

+    ix2 <- which(x > 0)

+    y[ix] <- exp(x[ix])/(1 + exp(x[ix]))

+    y[ix2] <- 1/(1 + exp(-x[ix2]))

+    y

+}

+

+# Exported functions -----------------------------------------------------------

+

+# TODO: BSseq() is arguably a bad constructor. It doesn't return a valid BSseq

+#       object when called without any arguments. It also does some pretty

+#       complicated parsing of the inputs. Still, I think we're stuck with it

+#       because it's been around for a long time.

+BSseq <- function(M = NULL, Cov = NULL, coef = NULL, se.coef = NULL,

+                  trans = NULL, parameters = NULL, pData = NULL,

+                  gr = NULL, pos = NULL, chr = NULL, sampleNames = NULL,

+                  rmZeroCov = FALSE) {

+

+    # Process 'gr', or 'pos' and 'chr'

+    if (is.null(gr)) {

+        if (is.null(pos) || is.null(chr)) {

+            stop("Need 'pos' and 'chr' if 'gr' not supplied.")

+        }

+        gr <- GRanges(seqnames = chr, ranges = IRanges(start = pos, width = 1L))

+    }

+    if (!is(gr, "GRanges")) stop("'gr' needs to be a GRanges.")

+    if (any(width(gr) != 1L)) stop("'gr' needs to have widths of 1.")

+

+    # Process 'M' and 'Cov'

+    if (is.null(M) || is.null(Cov)) stop("Need 'M' and 'Cov'.")

+    if (length(gr) != nrow(M) ||

+        length(gr) != nrow(Cov) ||

+        ncol(Cov) != ncol(M)) {

+        stop("'gr', 'M' and 'Cov' need to have compatible dimensions.")

+    }

+    if (!is.null(rownames(M))) rownames(M) <- NULL

+    if (!is.null(rownames(Cov))) rownames(Cov) <- NULL

+    if (!is.null(names(gr))) names(gr) <- NULL

+

+    # Process 'sampleNames' and 'pData'

+    if (is.null(pData)) {

+        if (is.null(sampleNames)) {

+            if (!is.null(colnames(M))) {

+                sampleNames <- colnames(M)

+            } else if (!is.null(colnames(Cov))) {

+                sampleNames <- colnames(Cov)

+            } else {

+                sampleNames <- paste0("V", seq_len(ncol(M)))

+            }

+        }

+        pData <- DataFrame(row.names = sampleNames)

+    } else {

+        pData <- as(pData, "DataFrame")

+    }

+    if (is.null(sampleNames) && !is.null(pData) && !is.null(rownames(pData))) {

+        sampleNames <- rownames(pData)

+    }

+    if (length(unique(sampleNames)) != ncol(M)) {

+        stop("sampleNames need to be unique and of the right length.")

+    }

+

+    # TODO: Is this really necessary? It complicates things because HDF5Matrix

+    #       will be degraded to a DelayedMatrix

+    # Add column names to assays

+    if (is.null(colnames(M)) || any(sampleNames != colnames(M))) {

+        colnames(M) <- sampleNames

+    }

+    if (is.null(colnames(Cov)) || any(sampleNames != colnames(Cov))) {

+        colnames(Cov) <- sampleNames

+    }

+    if (!is.null(coef)) {

+        if (nrow(coef) != nrow(M) || ncol(coef) != ncol(M)) {

+            stop("'coef' does not have the right dimensions")

+        }

+        if (is.null(colnames(coef)) || any(sampleNames != colnames(coef))) {

+            colnames(coef) <- sampleNames

+        }

+        if (!is.null(rownames(coef))) {

+            rownames(coef) <- NULL

+        }

+    }

+    if (!is.null(se.coef)) {

+        if (nrow(se.coef) != nrow(M) || ncol(se.coef) != ncol(M)) {

+            stop("'se.coef' does not have the right dimensions")

+        }

+        if (is.null(colnames(se.coef)) ||

+            any(sampleNames != colnames(se.coef))) {

+            colnames(se.coef) <- sampleNames

+        }

+        if (!is.null(rownames(se.coef))) {

+            rownames(se.coef) <- NULL

+        }

+    }

+

+    # Optionally, remove positions with Cov == 0

+    if (rmZeroCov) {

+        loci_with_zero_cov <- rowAlls(Cov, value = 0)

+        if (any(loci_with_zero_cov)) {

+            gr <- gr[!loci_with_zero_cov]

+            M <- M[!loci_with_zero_cov, , drop = FALSE]

+            Cov <- Cov[!loci_with_zero_cov, , drop = FALSE]

+        }

+    }

+

+    # Collapse duplicate loci

+    if (any(duplicated(gr))) {

+        warning("Detected duplicate loci. Collapsing counts in 'M' and 'Cov' ",

+                "at these positions.")

+        if (!is.null(coef) || !is.null(se.coef)) {

+            stop("Cannot collapse when 'coef' or 'se.coef' are present.")

+        }

+        # NOTE: reduce() sorts the output

+        unique_gr <- unique(gr)

+        ol <- findOverlaps(unique_gr, gr)

+        gr <- unique(gr)

+        idx <- as.list(ol)

+        M <- .collapseMatrixLike(M, idx, MARGIN = 2L)

+        Cov <- .collapseMatrixLike(Cov, idx, MARGIN = 2L)

+    }

+

+    # Sort loci

+    if (is.unsorted(gr)) {

+        o <- order(gr)

+        gr <- gr[o]

+        M <- M[o, , drop = FALSE]

+        Cov <- Cov[o, , drop = FALSE]

+        coef <- coef[o, , drop = FALSE]

+        se.coef <- se.coef[o, , drop = FALSE]

+    }

+

+    # Construct BSseq object

+    assays <- SimpleList(M = M, Cov = Cov, coef = coef, se.coef = se.coef)

+    assays <- assays[!S4Vectors:::sapply_isNULL(assays)]

+    se <- SummarizedExperiment(assays = assays, rowRanges = gr, colData = pData)

+    if (is.null(parameters)) {

+        parameters <- list()

+    }

+    if (is.null(trans)) {

+        trans <- function(x) NULL

+    }

+    .BSseq(se, trans = trans, parameters = parameters)

+}

+

+hasBeenSmoothed <- function(BSseq) "coef" %in% assayNames(BSseq)

+

+# TODO: Document withDimnames

+getBSseq <- function(BSseq,

+                     type = c("Cov", "M", "gr", "coef", "se.coef", "trans",

+                              "parameters"),

+                     withDimnames = TRUE) {

+    type <- match.arg(type)

+    if (type %in% c("M", "Cov")) {

+        return(assay(BSseq, type, withDimnames = withDimnames))

+    }

+    if (type %in% c("coef", "se.coef") && type %in% assayNames(BSseq)) {

+        return(assay(BSseq, type, withDimnames = withDimnames))

+    }

+    if (type %in% c("coef", "se.coef")) return(NULL)

+    if (type == "trans") return(BSseq@trans)

+    if (type == "parameters") return(BSseq@parameters)

+    if (type == "gr") return(BSseq@rowRanges)

+

+}

+

+strandCollapse <- function(BSseq, shift = TRUE) {

+    if (all(runValue(strand(BSseq)) == "*")) {

+        warning("All loci are unstranded; nothing to collapse")

+        return(BSseq)

+    }

+    if (!(all(runValue(strand(BSseq)) %in% c("+", "-")))) {

+        stop("'BSseq' object has a mix of stranded and unstranded loci.")

+    }

+    BS.forward <- BSseq[strand(BSseq) == "+"]

+    strand(BS.forward) <- "*"

+    BS.reverse <- BSseq[strand(BSseq) == "-"]

+    strand(BS.reverse) <- "*"

+    if (shift) rowRanges(BS.reverse) <- shift(rowRanges(BS.reverse), -1L)

+    sampleNames(BS.reverse) <- paste0(sampleNames(BS.reverse), "_REVERSE")

+    BS.comb <- combine(BS.forward, BS.reverse)

+    newBSseq <- collapseBSseq(BS.comb, columns = rep(sampleNames(BSseq), 2))

+    newBSseq

+}

+

+# Exported methods -------------------------------------------------------------

+

+setMethod("show", signature(object = "BSseq"), function(object) {

+    cat("An object of type 'BSseq' with\n")

+    cat(" ", nrow(object), "methylation loci\n")

+    cat(" ", ncol(object), "samples\n")

+    if (hasBeenSmoothed(object)) {

+        cat("has been smoothed with\n")

+        cat(" ", object@parameters$smoothText, "\n")

+    } else {

+        cat("has not been smoothed\n")

+    }

+    if (.isHDF5ArrayBacked(object)) {

+        cat("Some assays are HDF5Array-backed\n")

+    } else {

+        cat("All assays are in-memory\n")

+    }

+})

+

+setMethod("pData", "BSseq", function(object) {

+    object@colData

+})

+

+setReplaceMethod(

+    "pData",

+    signature = signature(object = "BSseq", value = "data.frame"),

+    function(object, value) {

+        colData(object) <- as(value, "DataFrame")

+        object

+    }

+)

+

+setReplaceMethod(

+    "pData",

+    signature = signature(object = "BSseq", value = "DataFrame"),

+    function(object, value) {

+        colData(object) <- value

+        object

+    }

+)

+

+setMethod("sampleNames", "BSseq", function(object) colnames(object))

+

+setReplaceMethod(

+    "sampleNames",

+    signature = signature(object = "BSseq", value = "ANY"),

+    function(object, value) {

+        colnames(object) <- value

+        object

+    }

+)

+

+setMethod("updateObject", "BSseq",

+          function(object, ...) {

+              # NOTE: identical() is too strong

+              if (isTRUE(all.equal(getBSseq(object, "trans"), .oldTrans))) {

+                  object@trans <- plogis

+              }

+              if (is(object, "SummarizedExperiment")) {

+                  # NOTE: Call method for SummarizedExperiment objects

+                  object <- callNextMethod()

+                  return(object)

+              } else {

+                  BSseq(gr = object@gr,

+                        M = object@M,

+                        Cov = object@Cov,

+                        coef = object@coef,

+                        se.coef = object@se.coef,

+                        trans = object@trans,

+                        parameters = object@parameters,

+                        pData = object@phenoData@data)

+              }

+          }

+)

deleted file mode 100644

@@ -1,355 +0,0 @@

-setClass("BSseq", contains = "RangedSummarizedExperiment",

-         representation(trans = "function",

-                        parameters = "list"))