From 4ca8ca3a3e5b02bb2393a73c7c12e11a8589a98a Mon Sep 17 00:00:00 2001 From: LiNk-NY Date: Fri, 18 Aug 2023 13:33:13 -0400 Subject: [PATCH] document drops generic, method, and replacement - remove from metadata - access with drops function - update unit tests --- NAMESPACE | 1 + R/MultiAssayExperiment-class.R | 29 +++++++++++++--------- R/MultiAssayExperiment-subset.R | 6 +++-- man/MultiAssayExperiment-class.Rd | 5 ---- man/MultiAssayExperiment-methods.Rd | 13 ++++++++++ tests/testthat/test-MultiAssayExperiment.R | 10 ++++---- 6 files changed, 40 insertions(+), 24 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a4e09f2..fbbac5b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -48,6 +48,7 @@ exportMethods("[[") exportMethods("[[<-") exportMethods("colData<-") exportMethods("colnames<-") +exportMethods("drops<-") exportMethods("experiments<-") exportMethods("names<-") exportMethods("sampleMap<-") diff --git a/R/MultiAssayExperiment-class.R b/R/MultiAssayExperiment-class.R index 4324d09..78474f0 100644 --- a/R/MultiAssayExperiment-class.R +++ b/R/MultiAssayExperiment-class.R @@ -512,6 +512,7 @@ setMethod("show", "MultiAssayExperiment", function(object) { #' \item experiments: Access the \link{ExperimentList} slot #' \item `[[`: Access the \link{ExperimentList} slot #' \item `$`: Access a column in \code{colData} +#' \item `drops`: Get a vector of dropped \link{ExperimentList} names #' } #' #' @section Setters: @@ -527,6 +528,8 @@ setMethod("show", "MultiAssayExperiment", function(object) { #' \item `[[<-`: Equivalent to the \code{experiments<-} setter method for #' convenience #' \item `$<-`: A vector to replace the indicated column in \code{colData} +#' \item `drops<-`: Trace \link{ExperimentList} names that have been +#' removed #' } #' #' @param object,x A \code{MultiAssayExperiment} object @@ -543,7 +546,7 @@ setMethod("show", "MultiAssayExperiment", function(object) { #' #' @example inst/scripts/MultiAssayExperiment-methods-Ex.R #' -#' @aliases experiments sampleMap experiments<- sampleMap<- +#' @aliases experiments sampleMap experiments<- sampleMap<- drops drops<- NULL ### - - - - - - - - - - - - - - - - - - - - - - - @@ -573,6 +576,15 @@ setMethod("colData", "MultiAssayExperiment", function(x, ...) { getElement(x, "colData") }) +#' @export +setGeneric("drops", function(x) standardGeneric("drops")) + +#' @exportMethod drops +#' @rdname MultiAssayExperiment-methods +setMethod("drops", "MultiAssayExperiment", function(x) { + getElement(x, "drops") +}) + ### - - - - - - - - - - - - - - - - - - - - - - - - ### Getters ### @@ -589,15 +601,6 @@ setMethod("names", "MultiAssayExperiment", function(x) names(experiments(x)) ) -#' @export -setGeneric("drops", function(x) standardGeneric("drops")) - -#' @exportMethod drops -#' @describeIn MultiAssayExperiment Get information about dropped experiments -setMethod("drops", "MultiAssayExperiment", function(x) { - getElement(x, "drops") -}) - ### - - - - - - - - - - - - - - - - - - - - - - - - ### Replacers ### @@ -640,6 +643,7 @@ setGeneric("experiments<-", function(object, value) standardGeneric("experiments<-")) #' @export +#' @rdname MultiAssayExperiment-methods setGeneric("drops<-", function(x, ..., value) standardGeneric("drops<-")) #' @exportMethod experiments<- @@ -647,7 +651,7 @@ setGeneric("drops<-", function(x, ..., value) standardGeneric("drops<-")) setReplaceMethod("experiments", c("MultiAssayExperiment", "ExperimentList"), function(object, value) { if (!any(names(object) %in% names(value)) && !isEmpty(object)) { - if (isEmpty(drops(x))) + if (isEmpty(drops(object))) warning("'experiments' dropped; see 'drops()'", call. = FALSE) drops(object) <- list(experiments = setdiff(names(object), names(value))) @@ -737,7 +741,8 @@ setReplaceMethod("colData", c("MultiAssayExperiment", "ANY"), } ) - +#' @exportMethod drops<- +#' @rdname MultiAssayExperiment-methods setReplaceMethod("drops", c("MultiAssayExperiment", "ANY"), function(x, ..., value) { anydrops <- getElement(x, "drops")[["experiments"]] diff --git a/R/MultiAssayExperiment-subset.R b/R/MultiAssayExperiment-subset.R index ad9353d..e394d9f 100644 --- a/R/MultiAssayExperiment-subset.R +++ b/R/MultiAssayExperiment-subset.R @@ -17,13 +17,15 @@ NULL isEmptyAssay <- .emptyAssays(experiments(object)) if (all(isEmptyAssay)) { drops(object) <- list(experiments = names(object)) + if (warn) + warning("'experiments' dropped; see 'drops()'", call. = FALSE) experiments(object) <- ExperimentList() } else if (any(isEmptyAssay)) { empties <- vapply(isEmptyAssay, isTRUE, logical(1L)) keeps <- names(isEmptyAssay)[!empties] drops(object) <- list(experiments = names(isEmptyAssay)[empties]) if (warn) - warning("'experiments' dropped; see 'metadata'", call. = FALSE) + warning("'experiments' dropped; see 'drops()'", call. = FALSE) FUN <- if (warn) force else suppressWarnings object <- FUN(subsetByAssay(object, keeps)) } @@ -47,7 +49,7 @@ NULL x <- subsetByRow(x, i, ...) } if (drop) { - x <- .dropEmpty(x) + x <- .dropEmpty(x, warn = TRUE) } return(x) } diff --git a/man/MultiAssayExperiment-class.Rd b/man/MultiAssayExperiment-class.Rd index 6fbff6d..f944217 100644 --- a/man/MultiAssayExperiment-class.Rd +++ b/man/MultiAssayExperiment-class.Rd @@ -7,7 +7,6 @@ \alias{show,MultiAssayExperiment-method} \alias{length,MultiAssayExperiment-method} \alias{names,MultiAssayExperiment-method} -\alias{drops,MultiAssayExperiment-method} \alias{updateObject,MultiAssayExperiment-method} \alias{coerce-MultiAssayExperiment} \alias{coerce,list,MultiAssayExperiment-method} @@ -28,8 +27,6 @@ \S4method{names}{MultiAssayExperiment}(x) -\S4method{drops}{MultiAssayExperiment}(x) - \S4method{updateObject}{MultiAssayExperiment}(object, ..., verbose = FALSE) \S4method{dimnames}{MultiAssayExperiment}(x) @@ -127,8 +124,6 @@ named arguments. See the examples below. \item \code{names(MultiAssayExperiment)}: Get the names of the ExperimentList -\item \code{drops(MultiAssayExperiment)}: Get information about dropped experiments - \item \code{updateObject(MultiAssayExperiment)}: Update old serialized MultiAssayExperiment objects to new API diff --git a/man/MultiAssayExperiment-methods.Rd b/man/MultiAssayExperiment-methods.Rd index 32e860d..791a096 100644 --- a/man/MultiAssayExperiment-methods.Rd +++ b/man/MultiAssayExperiment-methods.Rd @@ -7,15 +7,19 @@ \alias{sampleMap} \alias{experiments<-} \alias{sampleMap<-} +\alias{drops} +\alias{drops<-} \alias{sampleMap,MultiAssayExperiment-method} \alias{experiments,MultiAssayExperiment-method} \alias{colData,MultiAssayExperiment-method} +\alias{drops,MultiAssayExperiment-method} \alias{sampleMap<-,MultiAssayExperiment,DataFrame-method} \alias{sampleMap<-,MultiAssayExperiment,ANY-method} \alias{experiments<-,MultiAssayExperiment,ExperimentList-method} \alias{experiments<-,MultiAssayExperiment,List-method} \alias{colData<-,MultiAssayExperiment,DataFrame-method} \alias{colData<-,MultiAssayExperiment,ANY-method} +\alias{drops<-,MultiAssayExperiment-method} \alias{$<-,MultiAssayExperiment-method} \alias{names<-,MultiAssayExperiment-method} \alias{colnames<-,MultiAssayExperiment,List-method} @@ -29,10 +33,14 @@ \S4method{colData}{MultiAssayExperiment}(x, ...) +\S4method{drops}{MultiAssayExperiment}(x) + \S4method{sampleMap}{MultiAssayExperiment,DataFrame}(object) <- value \S4method{sampleMap}{MultiAssayExperiment,ANY}(object) <- value +drops(x, ...) <- value + \S4method{experiments}{MultiAssayExperiment,ExperimentList}(object) <- value \S4method{experiments}{MultiAssayExperiment,List}(object) <- value @@ -41,6 +49,8 @@ \S4method{colData}{MultiAssayExperiment,ANY}(x) <- value +\S4method{drops}{MultiAssayExperiment}(x, ...) <- value + \S4method{$}{MultiAssayExperiment}(x, name) <- value \S4method{names}{MultiAssayExperiment}(x) <- value @@ -82,6 +92,7 @@ exception of the \link{ExperimentList} accessor named \code{experiments}. \item experiments: Access the \link{ExperimentList} slot \item `[[`: Access the \link{ExperimentList} slot \item `$`: Access a column in \code{colData} + \item `drops`: Get a vector of dropped \link{ExperimentList} names } } @@ -99,6 +110,8 @@ Setter method values (i.e., '\code{function(x) <- value}'): \item `[[<-`: Equivalent to the \code{experiments<-} setter method for convenience \item `$<-`: A vector to replace the indicated column in \code{colData} + \item `drops<-`: Trace \link{ExperimentList} names that have been + removed } } diff --git a/tests/testthat/test-MultiAssayExperiment.R b/tests/testthat/test-MultiAssayExperiment.R index 63b2275..9052820 100644 --- a/tests/testthat/test-MultiAssayExperiment.R +++ b/tests/testthat/test-MultiAssayExperiment.R @@ -124,23 +124,23 @@ test_that("dropping experiments is noisy and traced", { mae <- MultiAssayExperiment(list(m=m, m2=m2, m3=m3)) ## check warning about experiments expect_warning( dp <- mae[, list(m = 1:3, m2 = 0, m3 = 1), , drop = TRUE] ) - ## check drops in metadata - expect_identical(metadata(dp)[["drops.experiments"]], "m2") + ## check drops in mae + expect_identical(drops(dp)[["experiments"]], "m2") ## check warning about experiments expect_warning( dp <- mae[character(0L), , drop = TRUE] ) ## check drops in metadata - expect_identical(metadata(dp)[["drops.experiments"]], names(mae)) + expect_identical(drops(dp)[["experiments"]], names(mae)) ## check warning about experiments expect_warning( dp <- mae[, , 0, drop = TRUE] ) ## check drops in metadata - expect_identical(metadata(dp)[["drops.experiments"]], names(mae)) + expect_identical(drops(dp)[["experiments"]], names(mae)) ## check warning about experiments expect_warning( dp <- mae[, , c(TRUE, FALSE), drop = TRUE] ) ## check drops in metadata - expect_identical(metadata(dp)[["drops.experiments"]], "m2") + expect_identical(drops(dp)[["experiments"]], "m2") }) test_that("MultiAssayExperiment replacements work", {