R/ExperimentList-class.R

In waldronlab/MultiAssayExperiment: Software for the integration of multi-omics experiments in Bioconductor

# ExperimentList class ----------------------------------------------------

# Structure ---------------------------------------------------------------

#' @name ExperimentList-class
#'
#' @docType class
#'
#' @title ExperimentList - A container for multi-experiment data
#'
#' @description The `ExperimentList` class is a container that builds on
#'   the `SimpleList` with additional checks for consistency in experiment
#'   names and length. It contains a `SimpleList` of experiments with
#'   sample identifiers. One element present per experiment performed.
#'
#'   Convert from `SimpleList` or `list` to the multi-experiment data
#'   container. When using the **mergeReplicates** method, additional
#'   arguments are passed to the given `simplify` function argument (e.g.,
#'   \code{na.rm = TRUE})
#'
#' @return An `ExperimentList` class object
#'
#' @examples
#'
#' ExperimentList()
#'
#' @exportClass ExperimentList
setClass("ExperimentList", contains = "SimpleList")

### - - - - - - - - - - - - - - - - - - - - - - - -
### Constructor
###

#' Represent multiple experiments as a List-derivative `ExperimentList`
#'
#' The `ExperimentList` class can contain several different types of data.
#' The only requirements for an `ExperimentList` class are that the
#' objects contained have the following set of methods: `dim`, \code{[},
#' `dimnames`
#'
#' @param ... A named `list` class object
#' @return A `ExperimentList` class object of experiment data
#'
#' @example inst/scripts/ExperimentList-Ex.R
#' @export
ExperimentList <- function(...) {
    listData <- list(...)
    if (length(listData) == 1L) {
        if (is(listData[[1L]], "MultiAssayExperiment"))
            stop("MultiAssayExperiment input detected. ",
                "Did you mean 'experiments()'?")
        if (is(listData[[1L]], "ExperimentList"))
            return(listData[[1L]])
        if (is.list(listData[[1L]]) || (is(listData[[1L]], "List") &&
            !is(listData[[1L]], "DataFrame"))) {
            listData <- listData[[1L]]
        } else if (is(listData[[1]], "DataFrame") ||
            is.data.frame(listData[[1]])) {
            warning(.DF_WARN, call. = FALSE)
        }
    } else if (!length(listData)) {
        return(new("ExperimentList",
            S4Vectors::SimpleList(structure(list(), .Names = character())))
        )
    }
    new("ExperimentList", as(listData, "SimpleList"))
}

# Validity ----------------------------------------------------------------

.checkDimnames <- function(x) {
    dims <- dimnames(x)
    !is.null(dims) && length(dimnames(x)) >= 2L
}

.getMethErr <- function(object) {
    supportedMethodFUN <- list(
        dimnames = .checkDimnames,
        `[` = function(x) hasMethod(`[`, class(x)),
        dim = function(x) length(dimnames(x)) >= 2L
    )
    methErr <- vapply(supportedMethodFUN, function(f) {
        "try-error" %in% class(try(f(object), silent = TRUE))
    }, logical(1L))
    if (any(methErr)) {
        unsupported <- names(which(methErr))
        msg <- paste0("class '", class(object),
            "' does not have compatible method(s): ",
            paste(unsupported, collapse = ", "))
        return(msg)
    }
    NULL
}

## ExperimentList elements
## 1.i For data classes stored in each ExperimentList element, ensure that
## method functions [ (bracket), dimnames, and dim are possible.
.testMethodsTable <- function(object) {
    errors <- NULL
    for (i in seq_along(object)) {
        coll_err <- .getMethErr(object[[i]])
        if (!is.null(coll_err)) {
            errors <- c(errors, paste0("Element [", i, "] of ", coll_err))
        }
    }
    errors
}

## 1.ii. For each ExperimentList element, ensure that dimensions of non-zero
## length in each ExperimentList element have non-null colnames.
.checkExperimentListNames <- function(object) {
    errors <- NULL
    if (is.null(names(object))) {
        msg <- "ExperimentList elements must be named"
        errors <- c(errors, msg)
    }
    if (anyDuplicated(names(object))) {
        msg <- "Non-unique names provided"
        errors <- c(errors, msg)
    }
    errors
}

## 1.iii. Ensure ExperimentList elements are appropriate for the API
## warn when DataFrame or data.frame present
.DF_WARN <- paste0("'ExperimentList' contains 'data.frame' or",
    " 'DataFrame',\n", "  potential for errors with mixed data types")

.checkClass <- function(object) {
    if (is.data.frame(object) || is(object, "DataFrame"))
        warning(.DF_WARN, call. = FALSE)

    if (is(object, "GRangesList") && !is(object, "RangedRaggedAssay"))
        paste0(" class is not supported, use 'RaggedExperiment' instead")
    else if (is.vector(object))
        paste0(" class is not supported, use a rectangular class")
    else
        NULL
}

.checkExperimentListClasses <- function(object) {
    errors <- NULL
    for (i in seq_along(object)) {
        class_err <- .checkClass(object[[i]])
        if (!is.null(class_err)) {
            errors <- c(errors, paste0("'", class(object[[i]]), "'", class_err))
        }
    }
    errors
}


.validExperimentList <- function(object) {
    if (length(object)) {
        c(
            .testMethodsTable(object),
            .checkExperimentListNames(object),
            .checkExperimentListClasses(object)
        )
    }
}

S4Vectors::setValidity2("ExperimentList", .validExperimentList)

.getDim <- function(x, pos) {
    vapply(x, `[`, integer(1L), pos)
}

#' @describeIn ExperimentList Show method for [`ExperimentList`] class
#'
#' @param object,x An [`ExperimentList`] object
setMethod("show", "ExperimentList", function(object) {
    o_class <- class(object)
    elem_cl <- vapply(object, function(o) { class(o)[[1L]] }, character(1L))
    o_len <- length(object)
    o_names <- names(object)
    o_dim <- lapply(object, dim)
    featdim <- .getDim(o_dim, 1L)
    sampdim <- .getDim(o_dim, 2L)
    cat(sprintf("%s", o_class),
        "class object of length",
        paste0(o_len, ":\n"),
        sprintf("[%i] %s: %s with %s rows and %s columns\n",
                seq(o_len), o_names, elem_cl, featdim, sampdim))
})


coerceToExperimentList <- function(from) {
    from <- as(from, "SimpleList")
    new("ExperimentList", from)
}

#' @rdname ExperimentList-class
#' @name coerce-ExperimentList
#'
#' @aliases coerce,list,ExperimentList-method coerce,List,ExperimentList-method
#'
#' @section
#' coercion:
#'  Convert a `list` or S4 `List` to an ExperimentList using the
#'  `as()` function.
#'
#'  In the following example, `x` is either a `list` or
#'  [`List`]:
#'
#'  \preformatted{    as(x, "ExperimentList")}
#'
#' @exportMethod coerce

setAs("list", "ExperimentList", function(from) {
    coerceToExperimentList(from)
})

setAs("List", "ExperimentList", function(from) {
    coerceToExperimentList(from)
})

#' @describeIn ExperimentList check for zero length across all
#' experiments
setMethod("isEmpty", "ExperimentList", function(x) {
    all(
        vapply(x, .isEmpty, logical(1L))
    )
})