Merge pull request #332 from rformassspectrometry/extract_by_index

Add new extractByIndex method

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: Spectra
 Title: Spectra Infrastructure for Mass Spectrometry Data
-Version: 1.15.9
+Version: 1.15.10
 Description: The Spectra package defines an efficient infrastructure
    for storing and handling mass spectrometry spectra and functionality to
    subset, process, visualize and compare spectra data. It provides different

NAMESPACE

@@ -86,6 +86,7 @@ exportMethods(dropNaSpectraVariables)
 exportMethods(entropy)
 exportMethods(estimatePrecursorIntensity)
 exportMethods(export)
+exportMethods(extractByIndex)
 exportMethods(filterAcquisitionNum)
 exportMethods(filterDataOrigin)
 exportMethods(filterDataStorage)

NEWS.md

@@ -1,5 +1,10 @@
 # Spectra 1.15
 
+## Changes in 1.15.10
+
+- Add new `extractSpectra()` generic and implementation for `MsBackend`. Fixes
+  [issue #5](https://github.com/rformassspectrometry/MsBackendMetaboLights/issues/5).
+
 ## Changes in 1.15.9
 
 - Restructure and reorganize documentation for `Spectra`.

R/AllGenerics.R

@@ -19,6 +19,8 @@ setGeneric("entropy", function(object, ...)
   standardGeneric("entropy"))
 setGeneric("export", function(object, ...)
     standardGeneric("export"))
+setGeneric("extractByIndex", function(object, i)
+    standardGeneric("extractByIndex"))
 setGeneric("filterFourierTransformArtefacts", function(object, ...)
     standardGeneric("filterFourierTransformArtefacts"))
 setGeneric("neutralLoss", function(object, param, ...)

R/MsBackend.R

@@ -15,6 +15,7 @@
 #' @aliases dataStorageBasePath,MsBackendMzR-method
 #' @aliases dataStorageBasePath<-
 #' @aliases dataStorageBasePath<-,MsBackendMzR-method
+#' @aliases extractByIndex
 #' @aliases msLeveL<-,MsBackend-method
 #'
 #' @description
@@ -223,7 +224,9 @@
 #'   allowed. Parameter `i` should support `integer` indices and `logical`
 #'   and should throw an error if `i` is out of bounds. The
 #'   `MsCoreUtils::i2index` could be used to check the input `i`.
-#'   For `i = integer()` an empty backend should be returned.
+#'   For `i = integer()` an empty backend should be returned. Implementation
+#'   of this method is optional, as the default calls the `extractByIndex()`
+#'   method (which has to be implemented as the main subsetting method).
 #'
 #' - `$`, `$<-`: access or set/add a single spectrum variable (column) in the
 #'   backend. Using a `value` of `NULL` should allow deleting the specified
@@ -328,6 +331,17 @@
 #'   *mzML* or *mzXML* format. See the documentation for the `MsBackendMzR`
 #'   class below for more information.
 #'
+#' - `extractByIndex()`: function to subset a backend to selected elements
+#'   defined by the provided index. Similar to `[`, this method should allow
+#'   extracting (or to subset) the data in any order. In contrast to `[`,
+#'   however, `i` is expected to be an `integer` (while `[` should also
+#'   support `logical` and eventually `character`). While being apparently
+#'   redundant to `[`, this methods avoids package namespace errors/problems
+#'   that can result in implementations of `[` being not found by R (which
+#'   can happen sometimes in parallel processing using the [SnowParam()]). This
+#'   method is used internally by `Spectra` to extract/subset its backend.
+#'   Implementation of this method is mandatory.
+#'
 #' - `filterAcquisitionNum()`: filters the object keeping only spectra matching
 #'   the provided acquisition numbers (argument `n`). If `dataOrigin` or
 #'   `dataStorage` is also provided, `object` is subsetted to the spectra with
@@ -1101,6 +1115,22 @@ setMethod("dropNaSpectraVariables", "MsBackend", function(object) {
     selectSpectraVariables(object, c(svs[keep], "mz", "intensity"))
 })
 
+#' @rdname MsBackend
+#'
+#' @export
+setMethod("extractByIndex", c("MsBackend", "ANY"), function(object, i) {
+    if (existsMethod("[", class(object)[1L]))
+        object[i = i]
+    else stop("'extractByIndex' not implemented for ", class(object)[1L], ".")
+})
+
+#' @rdname MsBackend
+#'
+#' @export
+setMethod("extractByIndex", c("MsBackend", "missing"), function(object, i) {
+    object
+})
+
 #' @exportMethod filterAcquisitionNum
 #'
 #' @importMethodsFrom ProtGenerics filterAcquisitionNum
@@ -1831,7 +1861,7 @@ setMethod("tic", "MsBackend", function(object, initial = TRUE) {
 #'
 #' @export
 setMethod("[", "MsBackend", function(x, i, j, ..., drop = FALSE) {
-    stop("Not implemented for ", class(x), ".")
+    extractByIndex(x, i2index(i, length = length(x)))
 })
 
 #' @exportMethod $

R/MsBackendCached.R

@@ -294,6 +294,15 @@ setMethod("dataStorage", "MsBackendCached", function(object) {
     rep("<cache>", length(object))
 })
 
+#' @rdname MsBackendCached
+setMethod("extractByIndex", c("MsBackendCached", "ANY"),
+          function(object, i) {
+    slot(object, "localData", check = FALSE) <-
+        object@localData[i, , drop = FALSE]
+    object@nspectra <- nrow(object@localData)
+    object
+})
+
 #' @rdname MsBackendCached
 setMethod("length", "MsBackendCached", function(x) {
     x@nspectra
@@ -428,7 +437,7 @@ setMethod("show", "MsBackendCached", function(object) {
     cat(class(object), "with", n, "spectra\n")
     if (n) {
         idx <- unique(c(1L:min(6L, n), max(1L, n-5L):n))
-        spd <- spectraData(object[idx, ],
+        spd <- spectraData(extractByIndex(object, idx),
                            c("msLevel", "precursorMz", "polarity"))
         if (!length(rownames(spd)))
             rownames(spd) <- idx

R/MsBackendDataFrame.R

@@ -181,6 +181,14 @@ setReplaceMethod("dataStorage", "MsBackendDataFrame", function(object, value) {
     object
 })
 
+#' @rdname hidden_aliases
+setMethod("extractByIndex", c("MsBackendDataFrame", "ANY"),
+          function(object, i) {
+              slot(object, "spectraData", check = FALSE) <-
+                  extractROWS(object@spectraData, i)
+              object
+          })
+
 #' @rdname hidden_aliases
 setMethod("intensity", "MsBackendDataFrame", function(object) {
     if (any(colnames(object@spectraData) == "intensity"))
@@ -544,6 +552,8 @@ setReplaceMethod("$", "MsBackendDataFrame", function(x, name, value) {
 #' @importFrom MsCoreUtils i2index
 #'
 #' @rdname hidden_aliases
+#'
+#' @export
 setMethod("[", "MsBackendDataFrame", function(x, i, j, ..., drop = FALSE) {
     .subset_backend_data_frame(x, i)
 })
@@ -564,5 +574,5 @@ setMethod("filterAcquisitionNum", "MsBackendDataFrame",
                              "acquisition number(s) for sub-setting")
     sel_file <- .sel_file(object, dataStorage, dataOrigin)
     sel_acq <- acquisitionNum(object) %in% n & sel_file
-    object[sel_acq | !sel_file]
+    extractByIndex(object, which(sel_acq | !sel_file))
 })

R/MsBackendHdf5Peaks.R

@@ -291,6 +291,20 @@ setMethod("[", "MsBackendHdf5Peaks", function(x, i, j, ..., drop = FALSE) {
     x
 })
 
+#' @rdname hidden_aliases
+#'
+#' @aliases [,MsBackendHdf5Peaks-method
+setMethod("extractByIndex", c("MsBackendHdf5Peaks", "ANY"),
+          function(object, i) {
+              fls <- unique(object@spectraData$dataStorage)
+              slot(object, "spectraData", check = FALSE) <-
+                  extractROWS(object@spectraData, i)
+              slot(object, "modCount", check = FALSE) <-
+                  object@modCount[match(
+                             unique(object@spectraData$dataStorage), fls)]
+              object
+})
+
 #' @rdname hidden_aliases
 setMethod("backendMerge", "MsBackendHdf5Peaks", function(object, ...) {
     object <- unname(c(object, ...))

R/MsBackendMemory.R

@@ -192,6 +192,18 @@ setReplaceMethod("dataStorage", "MsBackendMemory", function(object, value) {
     object
 })
 
+#' @rdname hidden_aliases
+setMethod("extractByIndex", c("MsBackendMemory", "ANY"), function(object, i) {
+    slot(object, "spectraData", check = FALSE) <-
+        object@spectraData[i, , drop = FALSE]
+    if (length(object@peaksData))
+        slot(object, "peaksData", check = FALSE) <- object@peaksData[i]
+    if (length(object@peaksDataFrame))
+        slot(object, "peaksDataFrame", check = FALSE) <-
+            object@peaksDataFrame[i]
+    object
+})
+
 #' @rdname hidden_aliases
 setMethod("intensity", "MsBackendMemory", function(object) {
     if (length(object)) {

R/Spectra-functions.R

@@ -236,8 +236,9 @@ applyProcessing <- function(object, f = processingChunkFactor(object),
             }, queue = queue, pv = pv, svars = svars, BPPARAM = BPPARAM)
         bknds <- backendMerge(bknds)
         if (is.unsorted(f))
-            bknds <- bknds[order(unlist(split(seq_along(bknds), f),
-                                        use.names = FALSE))]
+            bknds <- extractByIndex(
+                bknds, order(unlist(split(seq_along(bknds), f),
+                                    use.names = FALSE)))
         object@backend <- bknds
     } else {
         if (length(svars))

R/Spectra.R

@@ -515,8 +515,9 @@ setMethod(
                 ## That below ensures the backend is returned in its original
                 ## order - unsplit does unfortunately not work.
                 if (is.unsorted(f))
-                    bknds <- bknds[order(unlist(split(seq_along(bknds), f),
-                                                use.names = FALSE))]
+                    bknds <- extractByIndex(
+                        bknds, order(unlist(split(seq_along(bknds), f),
+                                            use.names = FALSE)))
             } else {
                 bknds <- backendInitialize(
                     backend, data = spectraData(object@backend), ...)
@@ -2415,7 +2416,8 @@ setMethod("[", "Spectra", function(x, i, j, ..., drop = FALSE) {
         stop("Subsetting 'Spectra' by columns is not (yet) supported")
     if (missing(i))
         return(x)
-    slot(x, "backend", check = FALSE) <- x@backend[i = i]
+    slot(x, "backend", check = FALSE) <- extractByIndex(
+        x@backend, i2index(i, length(x)))
     x
 })
 
@@ -2439,7 +2441,8 @@ setMethod("filterAcquisitionNum", "Spectra", function(object, n = integer(),
 
 #' @rdname filterMsLevel
 setMethod("filterEmptySpectra", "Spectra", function(object) {
-    object@backend <- object@backend[as.logical(lengths(object))]
+    object@backend <- extractByIndex(object@backend,
+                                     which(as.logical(lengths(object))))
     object@processing <- .logging(object@processing,
                                   "Filter: removed empty spectra.")
     object

inst/test_backends/test_MsBackend/test_spectra_subsetting.R

@@ -49,6 +49,24 @@ test_that("[", {
     res <- be[integer()]
     expect_s4_class(res, class(be)[1L])
     expect_true(length(res) == 0L)
+
+    ## logical
+    l <- rep(FALSE, length(be))
+    l[sample(seq_along(l), floor(length(l) / 2))] <- TRUE
+    res <- be[l]
+    expect_true(validObject(res))
+    expect_true(length(res) == sum(l))
+    expect_equal(res, be[which(l)])
+})
+
+#' extractByIndex. Uses [ if not implemented
+test_that("extractByIndex", {
+    i <- sample(seq_along(be), floor(length(be) / 2))
+    res <- extractByIndex(be, i)
+    expect_true(validObject(res))
+    expect_equal(length(res), length(i))
+    expect_equal(msLevel(res), msLevel(be)[i])
+    expect_equal(rtime(res), rtime(be)[i])
 })
 
 #' dropNASpectraVariables: only for not read-only