### =========================================================================
### SummarizedExperiment objects
### -------------------------------------------------------------------------
###
setClassUnion("Assays_OR_NULL", c("Assays", "NULL"))
setClass("SummarizedExperiment",
contains=c("RectangularData", "Vector"),
representation(
colData="DataFrame", # columns and their annotations
assays="Assays_OR_NULL", # Data -- e.g., list of matrices
NAMES="character_OR_NULL",
elementMetadata="DataFrame"
),
prototype(
colData=new("DFrame"),
elementMetadata=new("DFrame")
)
)
### Combine the new "parallel slots" with those of the parent class. Make
### sure to put the new parallel slots **first**. See R/Vector-class.R file
### in the S4Vectors package for what slots should or should not be considered
### "parallel".
setMethod("parallel_slot_names", "SummarizedExperiment",
function(x) c("assays", "NAMES", callNextMethod())
)
setMethod("vertical_slot_names", "SummarizedExperiment",
function(x) parallel_slot_names(x)
)
### Like parallel_slot_names() methods, horizontal_slot_names() methods for
### SummarizedExperiment derivatives should be defined in an incremental
### fashion, that is, they should only explicitly list the new "horizontal
### slots" (i.e. the horizontal slots that they add to their parent class).
### See R/RectangularData-class.R file in the S4Vectors package for what
### slots should or should not be considered "horizontal".
setMethod("horizontal_slot_names", "SummarizedExperiment",
function(x) "colData"
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Validity
###
.valid.SummarizedExperiment.assays_nrow <- function(x)
{
if (length(x@assays) == 0L)
return(NULL)
assays_nrow <- nrow(x@assays)
rowData_nrow <- length(x)
if (assays_nrow != rowData_nrow) {
txt <- sprintf(
"\n nb of rows in 'assay' (%d) must equal nb of rows in 'rowData' (%d)",
assays_nrow, rowData_nrow)
return(txt)
}
NULL
}
.valid.SummarizedExperiment.assays_ncol <- function(x)
{
if (length(x@assays) == 0L)
return(NULL)
assays_ncol <- ncol(x@assays)
colData_nrow <- nrow(colData(x))
if (assays_ncol != colData_nrow) {
txt <- sprintf(
"\n nb of cols in 'assay' (%d) must equal nb of rows in 'colData' (%d)",
assays_ncol, colData_nrow)
return(txt)
}
NULL
}
.valid.SummarizedExperiment.assays_dim <- function(x)
{
c(.valid.SummarizedExperiment.assays_nrow(x),
.valid.SummarizedExperiment.assays_ncol(x))
}
.valid.SummarizedExperiment <- function(x)
{
.valid.SummarizedExperiment.assays_dim(x)
}
setValidity2("SummarizedExperiment", .valid.SummarizedExperiment)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Accessors
###
setMethod("length", "SummarizedExperiment",
function(x) nrow(x@elementMetadata)
)
setMethod("names", "SummarizedExperiment", function(x) x@NAMES)
setReplaceMethod("names", "SummarizedExperiment",
function(x, value)
{
NAMES <- S4Vectors:::normarg_names(value, class(x), length(x))
BiocGenerics:::replaceSlots(x, NAMES=NAMES, check=FALSE)
}
)
## rowData, colData seem too vague, but from eSet derived classes wanted to
## call the rows / cols something different from 'features' or 'samples', so
## might as well avoid the issue
setGeneric("rowData", signature="x",
function(x, use.names=TRUE, ...) standardGeneric("rowData")
)
### Fix old DataFrame instances on-the-fly (mcols() does it).
setMethod("rowData", "SummarizedExperiment",
function(x, use.names=TRUE, ...) mcols(x, use.names=use.names, ...)
)
setGeneric("rowData<-",
function(x, ..., value) standardGeneric("rowData<-"))
setReplaceMethod("rowData", "SummarizedExperiment",
function(x, ..., value) `mcols<-`(x, ..., value=value)
)
setGeneric("colData", function(x, ...) standardGeneric("colData"))
### Fix old DataFrame instances on-the-fly.
setMethod("colData", "SummarizedExperiment",
function(x, ...) updateObject(x@colData, check=FALSE)
)
setGeneric("colData<-",
function(x, ..., value) standardGeneric("colData<-"))
setReplaceMethod("colData", c("SummarizedExperiment", "DataFrame"),
function(x, ..., value)
{
if (nrow(value) != ncol(x))
stop("nrow of supplied 'colData' must equal ncol of object")
x <- updateObject(x, check=FALSE)
BiocGenerics:::replaceSlots(x, colData=value, check=FALSE)
})
setReplaceMethod("colData", c("SummarizedExperiment", "NULL"),
function(x, ..., value)
{
value <- new2("DFrame", nrows=ncol(x), rownames=colnames(x), check=FALSE)
x <- updateObject(x, check=FALSE)
BiocGenerics:::replaceSlots(x, colData=value, check=FALSE)
})
setGeneric("assays", signature="x",
function(x, withDimnames=TRUE, ...) standardGeneric("assays")
)
setMethod("assays", "SummarizedExperiment",
function(x, withDimnames=TRUE, ...)
{
if (!isTRUEorFALSE(withDimnames))
stop(wmsg("'withDimnames' must be TRUE or FALSE"))
assays <- as(x@assays, "SimpleList")
if (withDimnames) {
x_dimnames <- dimnames(x)
if (is.null(x_dimnames))
x_dimnames <- list(NULL, NULL)
assays <- endoapply(assays,
function(a) {
a_dimnames <- dimnames(a)
a_dimnames[1:2] <- x_dimnames
a_dimnames <- S4Arrays:::simplify_NULL_dimnames(a_dimnames)
S4Arrays:::set_dimnames(a, a_dimnames)
}
)
}
assays
})
setGeneric("assays<-", signature=c("x", "value"),
function(x, withDimnames=TRUE, ..., value) standardGeneric("assays<-"),
)
### 'expected_dimnames' must be a NULL or a list of length 2 where each
### list element is a character vector or a NULL.
### For assays with more than 2 dimensions, **only** the first 2
### dimnames components (i.e. rownames and colnames) are compared
### with 'expected_dimnames'.
### If 'strict' is FALSE, then a NULL on either side of the comparison
### is enough for the comparison to be considered succesful.
.assays_have_expected_dimnames <- function(assays, expected_dimnames,
strict=TRUE)
{
if (length(assays) == 0L)
return(TRUE)
## Returns the rownames and colnames in a list of length 2. Also list
## elements in the returned list that are equal to character(0) are
## replaced with NULLs. This is to accommodate the fact that, unlike
## an ordinary vector or data.frame, an ordinary matrix or array object
## will never hold a character(0) along a dimension of zero extend.
get_normalized_rownames_and_colnames <- function(dn) {
if (is.null(dn))
return(vector("list", length=2L))
rownames <- dn[[1L]]
colnames <- dn[[2L]]
## We use as.character() to drop the names on the rownames/colnames
## below. Also in the unlikely (but possible in theory) situation
## where an assay uses unconventional representation of the
## rownames/colnames (e.g. factor?), this will make sure that
## the rownames/colnames are returned in a character vector.
if (length(rownames) == 0L) {
rownames <- NULL
} else {
rownames <- as.character(rownames)
}
if (length(colnames) == 0L) {
colnames <- NULL
} else {
colnames <- as.character(colnames)
}
list(rownames, colnames)
}
expected_dimnames <- get_normalized_rownames_and_colnames(expected_dimnames)
expected_rownames <- expected_dimnames[[1L]]
expected_colnames <- expected_dimnames[[2L]]
if (!strict) {
expected_rownames_is_NULL <- is.null(expected_rownames)
expected_colnames_is_NULL <- is.null(expected_colnames)
if (expected_rownames_is_NULL && expected_colnames_is_NULL)
return(TRUE)
}
ok <- vapply(seq_along(assays),
function(i) {
a <- getListElement(assays, i)
a_dimnames <- get_normalized_rownames_and_colnames(dimnames(a))
a_rownames <- a_dimnames[[1L]]
a_colnames <- a_dimnames[[2L]]
ok1 <- identical(a_rownames, expected_rownames)
ok2 <- identical(a_colnames, expected_colnames)
if (!strict) {
ok1 <- ok1 || is.null(a_rownames) || expected_rownames_is_NULL
ok2 <- ok2 || is.null(a_colnames) || expected_colnames_is_NULL
}
ok1 && ok2
},
logical(1)
)
all(ok)
}
.SummarizedExperiment.assays.replace <-
function(x, withDimnames=TRUE, ..., value)
{
if (!isTRUEorFALSE(withDimnames))
stop(wmsg("'withDimnames' must be TRUE or FALSE"))
value <- normarg_assays(value, as.null.if.no.assay=TRUE)
## By default the dimnames on the supplied assays must be identical to
## the dimnames on 'x'. The user must use 'withDimnames=FALSE' if it's
## not the case. This is for symetry with the behavior of the getter.
## See https://github.com/Bioconductor/SummarizedExperiment/issues/35
if (withDimnames && !.assays_have_expected_dimnames(value, dimnames(x)))
stop(wmsg("please use 'assay(x, withDimnames=FALSE) <- value' ",
"or 'assays(x, withDimnames=FALSE) <- value' when ",
"the rownames or colnames of the supplied assay(s) ",
"are not identical to those of the receiving ",
class(x), " object 'x'"))
new_assays <- Assays(value, as.null.if.no.assay=TRUE)
x <- BiocGenerics:::replaceSlots(x, assays=new_assays, check=FALSE)
## validObject(x) should NOT be called below because it would then
## fully re-validate objects that derive from SummarizedExperiment
## (e.g. DESeqDataSet objects) after the user sets the assays slot with
## assays(x) <- value. For example the assays slot of a DESeqDataSet
## object must contain a matrix named 'counts' and calling validObject(x)
## would check that but .valid.SummarizedExperiment(x) doesn't.
## The FourC() constructor function defined in the FourCSeq package
## actually takes advantage of the incomplete validation below to
## purposedly return invalid FourC objects!
msg <- .valid.SummarizedExperiment(x)
if (!is.null(msg))
stop(msg)
x
}
setReplaceMethod("assays", c("SummarizedExperiment", "SimpleList"),
.SummarizedExperiment.assays.replace)
setReplaceMethod("assays", c("SummarizedExperiment", "list"),
.SummarizedExperiment.assays.replace)
setGeneric("assay", signature=c("x", "i"),
function(x, i, withDimnames=TRUE, ...) standardGeneric("assay")
)
## convenience for common use case
setMethod("assay", c("SummarizedExperiment", "missing"),
function(x, i, withDimnames=TRUE, ...)
{
assays <- assays(x, withDimnames=withDimnames, ...)
if (0L == length(assays))
stop("'assay(<", class(x), ">, i=\"missing\", ...) ",
"length(assays(<", class(x), ">)) is 0'")
assays[[1]]
})
setMethod("assay", c("SummarizedExperiment", "numeric"),
function(x, i, withDimnames=TRUE, ...)
{
tryCatch({
assays(x, withDimnames=withDimnames, ...)[[i]]
}, error=function(err) {
stop("'assay(<", class(x), ">, i=\"numeric\", ...)' ",
"invalid subscript 'i'\n", conditionMessage(err))
})
})
setMethod("assay", c("SummarizedExperiment", "character"),
function(x, i, withDimnames=TRUE, ...)
{
msg <- paste0("'assay(<", class(x), ">, i=\"character\", ...)' ",
"invalid subscript 'i'")
res <- tryCatch({
assays(x, withDimnames=withDimnames, ...)[[i]]
}, error=function(err) {
stop(msg, "\n", conditionMessage(err))
})
if (is.null(res))
stop(msg, "\n'", i, "' not in names(assays(<", class(x), ">))")
res
})
setGeneric("assay<-", signature=c("x", "i"),
function(x, i, withDimnames=TRUE, ..., value) standardGeneric("assay<-"))
setReplaceMethod("assay", c("SummarizedExperiment", "missing"),
function(x, i, withDimnames=TRUE, ..., value)
{
if (0L == length(assays(x, withDimnames=FALSE)))
stop("'assay(<", class(x), ">) <- value' ", "length(assays(<",
class(x), ">)) is 0")
assays(x, withDimnames=withDimnames, ...)[[1]] <- value
x
})
setReplaceMethod("assay", c("SummarizedExperiment", "numeric"),
function(x, i, withDimnames=TRUE, ..., value)
{
assays(x, withDimnames=withDimnames, ...)[[i]] <- value
x
})
setReplaceMethod("assay", c("SummarizedExperiment", "character"),
function(x, i, withDimnames=TRUE, ..., value)
{
assays(x, withDimnames=withDimnames, ...)[[i]] <- value
x
})
setGeneric("assayNames", function(x, ...) standardGeneric("assayNames"))
setMethod("assayNames", "SummarizedExperiment",
function(x, ...)
{
names(assays(x, withDimnames=FALSE))
})
setGeneric("assayNames<-",
function(x, ..., value) standardGeneric("assayNames<-"))
setReplaceMethod("assayNames", c("SummarizedExperiment", "character"),
function(x, ..., value)
{
names(assays(x, withDimnames=FALSE)) <- value
x
})
setMethod("nrow", "SummarizedExperiment", function(x) length(x))
setMethod("ncol", "SummarizedExperiment", function(x) nrow(colData(x)))
setMethod("rownames", "SummarizedExperiment", function(x) names(x))
setMethod("colnames", "SummarizedExperiment", function(x) rownames(colData(x)))
setReplaceMethod("dimnames", c("SummarizedExperiment", "list"),
function(x, value)
{
NAMES <- S4Vectors:::normarg_names(value[[1L]], class(x), length(x))
colData <- colData(x)
rownames(colData) <- value[[2L]]
BiocGenerics:::replaceSlots(x, NAMES=NAMES, colData=colData, check=FALSE)
})
setReplaceMethod("dimnames", c("SummarizedExperiment", "NULL"),
function(x, value)
{
dimnames(x) <- list(NULL, NULL)
x
})
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Low-level constructor (not exported)
###
new_SummarizedExperiment <- function(assays, names, rowData, colData,
metadata)
{
assays <- Assays(assays, as.null.if.no.assay=TRUE)
if (is.null(rowData)) {
if (!is.null(names)) {
nrow <- length(names)
} else if (!is.null(assays)) {
nrow <- nrow(assays)
} else {
nrow <- 0L
}
rowData <- S4Vectors:::make_zero_col_DataFrame(nrow)
} else {
rownames(rowData) <- NULL
}
new("SummarizedExperiment", NAMES=names,
elementMetadata=rowData,
colData=colData,
assays=assays,
metadata=as.list(metadata))
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### High-level SummarizedExperiment/RangedSummarizedExperiment constructor
###
### We use as.character() in .get_rownames_from_first_assay() and
### .get_colnames_from_first_assay() below to drop the names on the
### rownames/colnames. Also in the unlikely (but possible in theory)
### situation where an assay uses unconventional representation of the
### rownames/colnames (e.g. factor?), this will make sure that the
### rownames/colnames are returned in a character vector.
.get_rownames_from_first_assay <- function(assays)
{
if (length(assays) == 0L)
return(NULL)
rownames <- rownames(assays[[1L]])
if (!is.null(rownames))
rownames <- as.character(rownames)
rownames
}
.get_colnames_from_first_assay <- function(assays)
{
if (length(assays) == 0L)
return(NULL)
colnames <- colnames(assays[[1L]])
if (!is.null(colnames))
colnames <- as.character(colnames)
colnames
}
SummarizedExperiment <- function(assays=SimpleList(),
rowData=NULL, rowRanges=NULL,
colData=DataFrame(),
metadata=list(),
checkDimnames=TRUE)
{
if (!isTRUEorFALSE(checkDimnames))
stop(wmsg("'checkDimnames' must be TRUE or FALSE"))
assays <- normarg_assays(assays, as.null.if.no.assay=TRUE)
if (!missing(colData)) {
if (!is(colData, "DataFrame"))
colData <- as(colData, "DataFrame")
if (is.null(rownames(colData)))
rownames(colData) <- .get_colnames_from_first_assay(assays)
} else if (length(assays) != 0L) {
a1 <- assays[[1L]]
nms <- colnames(a1)
colData <- DataFrame(x=seq_len(ncol(a1)), row.names=nms)[, FALSE]
}
if (is.null(rowData)) {
if (is.null(rowRanges)) {
ans_rownames <- .get_rownames_from_first_assay(assays)
} else {
if (!is(rowRanges, "GenomicRanges_OR_GRangesList"))
stop("'rowRanges' must be a GRanges or GRangesList object")
if (is.null(names(rowRanges)))
names(rowRanges) <- .get_rownames_from_first_assay(assays)
ans_rownames <- names(rowRanges)
}
} else {
if (!is.null(rowRanges))
stop("only one of 'rowData' and 'rowRanges' can be specified")
if (is(rowData, "GenomicRanges_OR_GRangesList")) {
rowRanges <- rowData
if (is.null(names(rowRanges)))
names(rowRanges) <- .get_rownames_from_first_assay(assays)
ans_rownames <- names(rowRanges)
} else {
if (!is(rowData, "DataFrame"))
rowData <- as(rowData, "DataFrame")
ans_rownames <- rownames(rowData)
if (is.null(ans_rownames))
ans_rownames <- .get_rownames_from_first_assay(assays)
}
}
if (is.null(rowRanges)) {
ans <- new_SummarizedExperiment(assays, ans_rownames, rowData, colData,
metadata)
} else {
ans <- new_RangedSummarizedExperiment(assays, rowRanges, colData,
metadata)
}
if (!checkDimnames)
return(ans)
ans_dimnames <- dimnames(ans)
ok <- .assays_have_expected_dimnames(ans@assays, ans_dimnames, strict=FALSE)
if (!ok) {
if (is.null(ans_dimnames[[1L]])) {
what <- "colnames"
} else if (is.null(ans_dimnames[[2L]])) {
what <- "rownames"
} else {
what <- "rownames and colnames"
}
stop(wmsg("the ", what, " of the supplied assay(s) must be NULL ",
"or identical to those of the ", class(ans), " object ",
"(or derivative) to construct"))
}
ans
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Subsetting
###
.SummarizedExperiment.charbound <-
function(idx, txt, fmt)
{
orig <- idx
idx <- match(idx, txt)
if (any(bad <- is.na(idx))) {
msg <- paste(S4Vectors:::selectSome(orig[bad]), collapse=" ")
stop(sprintf(fmt, msg))
}
idx
}
### TODO: Refactor this to use extractROWS().
setMethod("[", c("SummarizedExperiment", "ANY", "ANY"),
function(x, i, j, ..., drop=TRUE)
{
if (1L != length(drop) || (!missing(drop) && drop))
warning("'drop' ignored '[,", class(x), ",ANY,ANY-method'")
if (missing(i) && missing(j))
return(x)
if (!missing(i)) {
if (is.character(i)) {
fmt <- paste0("<", class(x), ">[i,] index out of bounds: %s")
i <- .SummarizedExperiment.charbound(i, rownames(x), fmt)
}
ii <- as.vector(i)
ans_elementMetadata <- x@elementMetadata[i, , drop=FALSE]
if (is(x, "RangedSummarizedExperiment")) {
ans_rowRanges <- x@rowRanges[i]
} else {
ans_NAMES <- x@NAMES[ii]
}
}
if (!missing(j)) {
if (is.character(j)) {
fmt <- paste0("<", class(x), ">[,j] index out of bounds: %s")
j <- .SummarizedExperiment.charbound(j, colnames(x), fmt)
}
ans_colData <- x@colData[j, , drop=FALSE]
jj <- as.vector(j)
}
if (missing(i)) {
ans_assays <- x@assays[ , jj]
ans <- BiocGenerics:::replaceSlots(x, ...,
colData=ans_colData,
assays=ans_assays,
check=FALSE)
} else if (missing(j)) {
ans_assays <- x@assays[ii, ]
if (is(x, "RangedSummarizedExperiment")) {
ans <- BiocGenerics:::replaceSlots(x, ...,
elementMetadata=ans_elementMetadata,
rowRanges=ans_rowRanges,
assays=ans_assays,
check=FALSE)
} else {
ans <- BiocGenerics:::replaceSlots(x, ...,
elementMetadata=ans_elementMetadata,
NAMES=ans_NAMES,
assays=ans_assays,
check=FALSE)
}
} else {
ans_assays <- x@assays[ii, jj]
if (is(x, "RangedSummarizedExperiment")) {
ans <- BiocGenerics:::replaceSlots(x, ...,
elementMetadata=ans_elementMetadata,
rowRanges=ans_rowRanges,
colData=ans_colData,
assays=ans_assays,
check=FALSE)
} else {
ans <- BiocGenerics:::replaceSlots(x, ...,
elementMetadata=ans_elementMetadata,
NAMES=ans_NAMES,
colData=ans_colData,
assays=ans_assays,
check=FALSE)
}
}
ans
})
### TODO: Refactor this to use replaceROWS().
setReplaceMethod("[",
c("SummarizedExperiment", "ANY", "ANY", "SummarizedExperiment"),
function(x, i, j, ..., value)
{
if (missing(i) && missing(j))
return(value)
ans_metadata <- metadata(x)
if (!missing(i)) {
if (is.character(i)) {
fmt <- paste0("<", class(x), ">[i,] index out of bounds: %s")
i <- .SummarizedExperiment.charbound(i, rownames(x), fmt)
}
ii <- as.vector(i)
ans_elementMetadata <- local({
emd <- x@elementMetadata
emd[i,] <- value@elementMetadata
emd
})
if (is(x, "RangedSummarizedExperiment")) {
ans_rowRanges <- local({
r <- x@rowRanges
r[i] <- value@rowRanges
names(r)[ii] <- names(value@rowRanges)
r
})
} else {
ans_NAMES <- local({
nms <- x@NAMES
nms[ii] <- value@NAMES
nms
})
}
}
if (!missing(j)) {
if (is.character(j)) {
fmt <- paste0("<", class(x), ">[,j] index out of bounds: %s")
j <- .SummarizedExperiment.charbound(j, colnames(x), fmt)
}
jj <- as.vector(j)
ans_colData <- local({
c <- x@colData
c[j,] <- value@colData
rownames(c)[jj] <- rownames(value@colData)
c
})
}
if (missing(i)) {
ans_assays <- local({
a <- x@assays
a[ , jj] <- value@assays
a
})
ans <- BiocGenerics:::replaceSlots(x, ...,
metadata=ans_metadata,
colData=ans_colData,
assays=ans_assays,
check=FALSE)
msg <- .valid.SummarizedExperiment.assays_ncol(ans)
} else if (missing(j)) {
ans_assays <- local({
a <- x@assays
a[ii, ] <- value@assays
a
})
if (is(x, "RangedSummarizedExperiment")) {
ans <- BiocGenerics:::replaceSlots(x, ...,
metadata=ans_metadata,
elementMetadata=ans_elementMetadata,
rowRanges=ans_rowRanges,
assays=ans_assays,
check=FALSE)
} else {
ans <- BiocGenerics:::replaceSlots(x, ...,
metadata=ans_metadata,
elementMetadata=ans_elementMetadata,
NAMES=ans_NAMES,
assays=ans_assays,
check=FALSE)
}
msg <- .valid.SummarizedExperiment.assays_nrow(ans)
} else {
ans_assays <- local({
a <- x@assays
a[ii, jj] <- value@assays
a
})
if (is(x, "RangedSummarizedExperiment")) {
ans <- BiocGenerics:::replaceSlots(x, ...,
metadata=ans_metadata,
elementMetadata=ans_elementMetadata,
rowRanges=ans_rowRanges,
colData=ans_colData,
assays=ans_assays,
check=FALSE)
} else {
ans <- BiocGenerics:::replaceSlots(x, ...,
metadata=ans_metadata,
elementMetadata=ans_elementMetadata,
NAMES=ans_NAMES,
colData=ans_colData,
assays=ans_assays,
check=FALSE)
}
msg <- .valid.SummarizedExperiment.assays_dim(ans)
}
if (!is.null(msg))
stop(msg)
ans
})
setMethod("subset", "SummarizedExperiment",
function(x, subset, select, ...)
{
i <- S4Vectors:::evalqForSubset(subset, rowData(x, use.names=FALSE), ...)
j <- S4Vectors:::evalqForSubset(select, colData(x), ...)
x[i, j]
})
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Quick colData access
###
setMethod("[[", c("SummarizedExperiment", "ANY", "missing"),
function(x, i, j, ...)
{
colData(x)[[i, ...]]
})
setReplaceMethod("[[", c("SummarizedExperiment", "ANY", "missing"),
function(x, i, j, ..., value)
{
colData(x)[[i, ...]] <- value
x
})
.DollarNames.SummarizedExperiment <- function(x, pattern = "")
grep(pattern, names(colData(x)), value=TRUE)
setMethod("$", "SummarizedExperiment",
function(x, name)
{
colData(x)[[name]]
})
setReplaceMethod("$", "SummarizedExperiment",
function(x, name, value)
{
colData(x)[[name]] <- value
x
})
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Show
###
setMethod("show", "SummarizedExperiment",
function(object)
{
cat("class:", class(object), "\n")
cat("dim:", dim(object), "\n")
## metadata()
expt <- names(metadata(object))
if (is.null(expt))
expt <- character(length(metadata(object)))
coolcat("metadata(%d): %s\n", expt)
## assays()
nms <- assayNames(object)
if (is.null(nms))
nms <- character(length(assays(object, withDimnames=FALSE)))
coolcat("assays(%d): %s\n", nms)
## rownames()
rownames <- rownames(object)
if (!is.null(rownames)) coolcat("rownames(%d): %s\n", rownames)
else cat("rownames: NULL\n")
## rowData`()
coolcat("rowData names(%d): %s\n", names(rowData(object, use.names=FALSE)))
## colnames()
colnames <- colnames(object)
if (!is.null(colnames)) coolcat("colnames(%d): %s\n", colnames)
else cat("colnames: NULL\n")
## colData()
coolcat("colData names(%d): %s\n", names(colData(object)))
})
setMethod("showAsCell", "SummarizedExperiment",
function(object) rep.int("####", NROW(object))
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Combine
###
### Appropriate for objects with different ranges and same samples.
setMethod("rbind", "SummarizedExperiment",
function(..., deparse.level=1)
{
args <- unname(list(...))
.rbind.SummarizedExperiment(args)
})
.rbind.SummarizedExperiment <- function(args)
{
if (!.compare(lapply(args, colnames)))
stop("'...' objects must have the same colnames")
if (!.compare(lapply(args, ncol)))
stop("'...' objects must have the same number of samples")
if (is(args[[1L]], "RangedSummarizedExperiment")) {
rowRanges <- do.call(c, lapply(args, rowRanges))
} else {
## Code below taken from combine_GAlignments_objects() from the
## GenomicAlignments package.
## Combine "NAMES" slots.
NAMES_slots <- lapply(args, function(x) x@NAMES)
## TODO: Use elementIsNull() here when it becomes available.
has_no_names <- sapply(NAMES_slots, is.null, USE.NAMES=FALSE)
if (all(has_no_names)) {
NAMES <- NULL
} else {
noname_idx <- which(has_no_names)
if (length(noname_idx) != 0L)
NAMES_slots[noname_idx] <-
lapply(elementNROWS(args[noname_idx]), character)
NAMES <- unlist(NAMES_slots, use.names=FALSE)
}
}
colData <- .cbind.DataFrame(args, colData, "colData")
assays <- do.call(rbind, lapply(args, slot, "assays"))
elementMetadata <- do.call(rbind, lapply(args, slot, "elementMetadata"))
metadata <- do.call(c, lapply(args, metadata))
if (is(args[[1L]], "RangedSummarizedExperiment")) {
BiocGenerics:::replaceSlots(args[[1L]],
rowRanges=rowRanges, colData=colData, assays=assays,
elementMetadata=elementMetadata, metadata=metadata)
} else {
BiocGenerics:::replaceSlots(args[[1L]],
NAMES=NAMES, colData=colData, assays=assays,
elementMetadata=elementMetadata, metadata=metadata)
}
}
### Appropriate for objects with same ranges and different samples.
setMethod("cbind", "SummarizedExperiment",
function(..., deparse.level=1)
{
args <- unname(list(...))
.cbind.SummarizedExperiment(args)
})
.cbind.SummarizedExperiment <- function(args)
{
if (is(args[[1L]], "RangedSummarizedExperiment")) {
if (!.compare(lapply(args, rowRanges), TRUE))
stop("'...' object ranges (rows) are not compatible")
rowRanges <- rowRanges(args[[1L]])
mcols(rowRanges) <- .cbind.DataFrame(args, mcols, "mcols")
} else {
elementMetadata <- .cbind.DataFrame(args, mcols, "mcols")
}
colData <- do.call(rbind, lapply(args, colData))
assays <- do.call(cbind, lapply(args, slot, "assays"))
metadata <- do.call(c, lapply(args, metadata))
if (is(args[[1L]], "RangedSummarizedExperiment")) {
BiocGenerics:::replaceSlots(args[[1L]],
rowRanges=rowRanges,
colData=colData, assays=assays, metadata=metadata)
} else {
BiocGenerics:::replaceSlots(args[[1L]],
elementMetadata=elementMetadata,
colData=colData, assays=assays, metadata=metadata)
}
}
.compare <- function(x, GenomicRanges=FALSE)
{
x1 <- x[[1]]
if (GenomicRanges) {
if (is(x1, "GRangesList")) {
x <- lapply(x, unlist)
x1 <- x[[1]]
}
for (i in seq_along(x)[-1]) {
if (!identicalVals(x1, x[[i]]))
return(FALSE)
}
return(TRUE)
} else {
all(sapply(x[-1],
function(xelt) all(identical(xelt, x[[1]]))))
}
}
.cbind.DataFrame <- function(args, accessor, accessorName)
{
lst <- lapply(args, accessor, use.names=FALSE)
if (!.compare(lst)) {
nms <- lapply(lst, names)
nmsv <- unlist(nms, use.names=FALSE)
names(nmsv) <- rep(seq_along(nms), elementNROWS(nms))
dups <- duplicated(nmsv)
## no duplicates
if (!any(dups))
return(do.call(cbind, lst))
## confirm duplicates are the same
lapply(nmsv[duplicated(nmsv)], function(d) {
if (!.compare(lapply(lst, "[", d)))
stop("column(s) '", unname(d),
"' in ", sQuote(accessorName),
" are duplicated and the data do not match")})
## remove duplicates
do.call(cbind, lst)[,!dups]
} else {
lst[[1]]
}
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### identicalVals()
###
### Internal generic and methods (i.e. not exported).
### Provides a fast implementation of 'length(x) == length(y) && all(x == y)'
### for various kinds of vector-like objects.
### TODO: Move this to S4Vectors (for the generic and methods for factor and
### Rle objects) and IRanges (for the method for IntegerRanges objects).
###
setGeneric("identicalVals", function(x, y) standardGeneric("identicalVals"))
### Semantically equivalent to identical(as.character(x), as.character(y))
### but avoids turning the 2 factor objects into character vectors so is more
### efficient.
setMethod("identicalVals", c("factor", "factor"),
function(x, y)
{
m <- match(levels(y), levels(x), nomatch=0L)
identical(as.integer(x), m[y])
}
)
### Only support factor-Rle objects at the moment!
### Semantically equivalent to identical(as.character(x), as.character(y))
### but avoids turning the 2 factor-Rle objects into character vectors so is
### more efficient.
setMethod("identicalVals", c("Rle", "Rle"),
function(x, y) identical(runLength(x), runLength(y)) &&
identicalVals(runValue(x), runValue(y))
)
setMethod("identicalVals", c("IntegerRanges", "IntegerRanges"),
function(x, y) identical(start(x), start(y)) &&
identical(width(x), width(y))
)
### Like 'x == y' this method ignores circularity of the underlying sequences
### e.g. ranges [1, 10] and [101, 110] represent the same position on a
### circular sequence of length 100 so should be considered equal. However
### for 'x == y' and the method below, they are not.
### TODO: Take circularity of the underlying sequences into account.
setMethod("identicalVals", c("GenomicRanges", "GenomicRanges"),
function(x, y)
{
## Trying to merge 'seqinfo(x)' and 'seqinfo(y)' will raise an error
## if 'x' and 'y' are not based on the same reference genome. This is
## the standard way to check that 'x' and 'y' are based on the same
## reference genome.
merge(seqinfo(x), seqinfo(y)) # we ignore the returned value
identicalVals(seqnames(x), seqnames(y)) &&
identicalVals(ranges(x), ranges(y)) &&
identicalVals(strand(x), strand(y))
}
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### On-disk realization.
###
setMethod("realize", "SummarizedExperiment",
function(x, BACKEND=getAutoRealizationBackend())
{
for (i in seq_along(assays(x))) {
## The dimnames of the individual assays are kind of irrelevant so
## we drop them. The dimnames that really matter are 'dimnames(x)'
## and they are stored somewhere else in 'x'. So we don't loose
## them by not realizing the assay dimnames on disk. As a small
## extra bonus, this saves a little bit of time and disk space.
a <- assay(x, i, withDimnames=FALSE)
a <- S4Arrays:::set_dimnames(a, NULL)
assay(x, i, withDimnames=FALSE) <- realize(a, BACKEND=BACKEND)
}
x
}
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### saveRDS() method
###
setMethod("saveRDS", "SummarizedExperiment",
function(object, file="", ascii=FALSE, version=NULL,
compress=TRUE, refhook=NULL)
{
if (containsOutOfMemoryData(object))
stop(wmsg("This ", class(object), " object contains out-of-memory ",
"data so cannot be serialized reliably. Please use ",
"saveHDF5SummarizedExperiment() from the HDF5Array ",
"package instead. Alternatively you can call ",
"base::saveRDS() on it but only if you know what ",
"you are doing."),
"\n ",
wmsg("See '?containsOutOfMemoryData' in the BiocGenerics ",
"package for more information."))
invisible(callNextMethod())
}
)
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### updateObject() method
###
.updateObject_SummarizedExperiment <- function(object, ..., verbose=FALSE)
{
object@assays <- updateObject(object@assays, ..., verbose=verbose)
object@colData <- updateObject(object@colData, ..., verbose=verbose)
callNextMethod() # call method for Vector objects
}
setMethod("updateObject", "SummarizedExperiment",
.updateObject_SummarizedExperiment
)
