#' @include zzz.R
#' @include generics.R
#' @include default.R
#' @include graph.R
#' @include keymixin.R
#'
NULL
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Class definitions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
setClassUnion(name = 'AnyMatrix', members = c("matrix", "dgCMatrix"))
#' The Assay Class
#'
#' The Assay object is the basic unit of Seurat; each Assay stores raw,
#' normalized, and scaled data as well as cluster information, variable
#' features, and any other assay-specific metadata. Assays should contain single
#' cell expression data such as RNA-seq, protein, or imputed expression data.
#'
#' @slot counts Unnormalized data such as raw counts or TPMs
#' @slot data Normalized expression data
#' @slot scale.data Scaled expression data
# @slot key Key for the Assay
#' @slot assay.orig Original assay that this assay is based off of. Used to
#' track assay provenance
#' @slot var.features Vector of features exhibiting high variance across
#' single cells
#' @slot meta.features Feature-level metadata
# @slot misc Utility slot for storing additional data associated with the assay
#' @template slot-misc
#' @template slot-key
#'
#' @name Assay-class
#' @rdname Assay-class
#' @exportClass Assay
#'
#' @family assay
#'
#' @aliases Assay
#'
setClass(
Class = 'Assay',
contains = 'KeyMixin',
slots = c(
counts = 'AnyMatrix',
data = 'AnyMatrix',
scale.data = 'matrix',
# key = 'character',
assay.orig = 'OptionalCharacter',
var.features = 'vector',
meta.features = 'data.frame',
misc = 'OptionalList'
)
)
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Functions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Create an Assay object
#'
#' Create an Assay object from a feature (e.g. gene) expression matrix. The
#' expected format of the input matrix is features x cells.
#'
#' Non-unique cell or feature names are not allowed. Please make unique before
#' calling this function.
#'
#' @param counts Unnormalized data such as raw counts or TPMs
#' @param data Prenormalized data; if provided, do not pass \code{counts}
#' @param min.cells Include features detected in at least this many cells. Will
#' subset the counts matrix as well. To reintroduce excluded features, create a
#' new object with a lower cutoff
#' @param min.features Include cells where at least this many features are
#' detected
#' @param key Optional key to initialize assay with
#' @param check.matrix Check counts matrix for NA, NaN, Inf, and
#' non-integer values
#' @param ... Arguments passed to \code{\link{as.sparse}}
#'
#' @return A \code{\link{Assay}} object
#'
#' @importFrom methods as
#' @importFrom Matrix colSums rowSums
#'
#' @export
#'
#' @family assay
#'
#' @examples
#' \dontrun{
#' pbmc_raw <- read.table(
#' file = system.file('extdata', 'pbmc_raw.txt', package = 'Seurat'),
#' as.is = TRUE
#' )
#' pbmc_rna <- CreateAssayObject(counts = pbmc_raw)
#' pbmc_rna
#' }
#'
CreateAssayObject <- function(
counts,
data,
min.cells = 0,
min.features = 0,
key = NULL,
check.matrix = FALSE,
...
) {
if (missing(x = counts) && missing(x = data)) {
abort(message = "Must provide either 'counts' or 'data'")
} else if (!missing(x = counts) && !missing(x = data)) {
abort(message = "Either 'counts' or 'data' must be missing; both cannot be provided")
} else if (!missing(x = counts)) {
# check that dimnames of input counts are unique
if (anyDuplicated(x = rownames(x = counts))) {
warn(
message = "Non-unique features (rownames) present in the input matrix, making unique"
)
rownames(x = counts) <- make.unique(names = rownames(x = counts))
}
if (anyDuplicated(x = colnames(x = counts))) {
warn(
message = "Non-unique cell names (colnames) present in the input matrix, making unique"
)
colnames(x = counts) <- make.unique(names = colnames(x = counts))
}
if (is.null(x = colnames(x = counts))) {
abort(message = "No cell names (colnames) names present in the input matrix")
}
if (any(rownames(x = counts) == '')) {
abort(message = "Feature names of counts matrix cannot be empty")
}
if (nrow(x = counts) > 0 && is.null(x = rownames(x = counts))) {
abort(message = "No feature names (rownames) names present in the input matrix")
}
if (!inherits(x = counts, what = 'dgCMatrix')) {
if (inherits(x = counts, what = "data.frame")) {
counts <- as.sparse(x = counts, ...)
} else {
counts <- as.sparse(x = counts)
}
}
if (isTRUE(x = check.matrix)) {
CheckMatrix(object = counts)
}
# Filter based on min.features
if (min.features > 0) {
nfeatures <- Matrix::colSums(x = counts > 0)
counts <- counts[, which(x = nfeatures >= min.features)]
}
# filter genes on the number of cells expressing
if (min.cells > 0) {
num.cells <- Matrix::rowSums(x = counts > 0)
counts <- counts[which(x = num.cells >= min.cells), ]
}
data <- counts
} else if (!missing(x = data)) {
# check that dimnames of input data are unique
if (anyDuplicated(x = rownames(x = data))) {
warn(
message = "Non-unique features (rownames) present in the input matrix, making unique"
)
rownames(x = data) <- make.unique(names = rownames(x = data))
}
if (anyDuplicated(x = colnames(x = data))) {
warn(
message = "Non-unique cell names (colnames) present in the input matrix, making unique"
)
colnames(x = data) <- make.unique(names = colnames(x = data))
}
if (is.null(x = colnames(x = data))) {
abort(message = "No cell names (colnames) names present in the input matrix")
}
if (any(rownames(x = data) == '')) {
abort(message = "Feature names of data matrix cannot be empty", call. = FALSE)
}
if (nrow(x = data) > 0 && is.null(x = rownames(x = data))) {
abort(message = "No feature names (rownames) names present in the input matrix")
}
if (min.cells != 0 | min.features != 0) {
warn(
message = "No filtering performed if passing to data rather than counts"
)
}
counts <- new(Class = 'matrix')
}
# Ensure row- and column-names are vectors, not arrays
if (!is.vector(x = rownames(x = counts))) {
rownames(x = counts) <- as.vector(x = rownames(x = counts))
}
if (!is.vector(x = colnames(x = counts))) {
colnames(x = counts) <- as.vector(x = colnames(x = counts))
}
if (!is.vector(x = rownames(x = data))) {
rownames(x = data) <- as.vector(x = rownames(x = data))
}
if (!is.vector(x = colnames(x = data))) {
colnames(x = data) <- as.vector(x = colnames(x = data))
}
counts <- CheckFeaturesNames(data = counts)
data <- CheckFeaturesNames(data = data)
# Initialize meta.features
init.meta.features <- data.frame(row.names = rownames(x = data))
misc <- if (.GetSeuratCompat() < '5.0.0') {
list()
} else {
calcN_option <- getOption(
x = 'Seurat.object.assay.calcn',
default = Seurat.options$Seurat.object.assay.calcn
)
list(calcN = calcN_option %||% TRUE)
}
assay <- new(
Class = 'Assay',
counts = counts,
data = data,
scale.data = new(Class = 'matrix'),
key = Key(object = key)[1L] %||% '',
meta.features = init.meta.features,
misc = misc
)
return(assay)
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for Seurat-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' @importFrom Matrix colSums
#'
#' @method .CalcN Assay
#' @export
#'
.CalcN.Assay <- function(object, layer = 'counts', ...) {
layer <- tryCatch(
expr = Layers(object = object, search = layer),
error = function(...) NULL
)
if (is.null(x = layer)) {
return(NULL)
}
ldat <- LayerData(object = object, layer = layer)
if (IsMatrixEmpty(x = ldat) || !inherits(x = ldat, what = 'Matrix')) {
return(NULL)
}
cells_stat <- .CalcN.default(object = ldat)
return(cells_stat)
}
#' @rdname AddMetaData
#'
# @templateVar fname AddMetaData
# @templateVar version 4
# @template name-oldv
#'
#' @export
#' @method AddMetaData Assay
#'
AddMetaData.Assay <- function(object, metadata, col.name = NULL) {
if (is.null(x = col.name) && (is.atomic(x = metadata) && !is.matrix(x = metadata))) {
abort(message = "'col.name' must be provided for atomic meta data")
}
if (inherits(x = metadata, what = c('matrix', 'Matrix'))) {
metadata <- as.data.frame(x = metadata)
}
col.name <- col.name %||% names(x = metadata) %||% colnames(x = metadata)
if (is.null(x = col.name)) {
abort(message = "No metadata name provided and could not infer it from metadata object")
}
object[[col.name]] <- metadata
return(object)
}
#' @rdname DefaultAssay
#' @export
#' @method DefaultAssay Assay
#'
DefaultAssay.Assay <- function(object, ...) {
object <- UpdateSlots(object = object)
return(slot(object = object, name = 'assay.orig'))
}
#' @rdname DefaultAssay
#' @export
#' @method DefaultAssay<- Assay
#'
"DefaultAssay<-.Assay" <- function(object, ..., value) {
object <- UpdateSlots(object = object)
slot(object = object, name = 'assay.orig') <- value
return(object)
}
#' @rdname DefaultLayer
#' @method DefaultLayer Assay
#' @export
#'
DefaultLayer.Assay <- function(object, ...) {
return('data')
}
#' @method Features Assay
#' @export
#'
Features.Assay <- function(
x,
layer = c('data', 'scale.data', 'counts'),
slot = deprecated(),
...
) {
if (is_present(arg = slot)) {
.Deprecate(
when = '5.0.0',
what = 'Features(slot = )',
with = 'Features(layer = )'
)
layer <- slot
}
layer <- layer[1L] %||% 'data'
layer <- match.arg(arg = layer)
features <- rownames(x = GetAssayData(object = x, layer = layer))
if (!length(x = features)) {
features <- NULL
}
return(features)
}
#' @method FetchData Assay
#' @export
#'
FetchData.Assay <- function(
object,
vars,
cells = NULL,
layer = NULL,
slot = deprecated(),
...
) {
if (is_present(arg = slot)) {
.Deprecate(
when = '5.0.0',
what = 'FetchData(slot = )',
with = 'FetchData(layer = )'
)
layer <- layer %||% slot
}
# Identify slot to use
layer <- layer %||% 'data'
layer <- match.arg(arg = layer, choices = c('counts', 'data', 'scale.data'))
# Identify cells to use
cells <- cells %||% colnames(x = object)
if (is.numeric(x = cells)) {
cells <- colnames(x = object)[cells]
}
cells.orig <- cells
cells <- intersect(x = cells, y = colnames(x = object))
if (length(x = cells) != length(x = cells.orig)) {
warn(message = paste(
"Removing",
length(x = cells.orig) - length(x = cells),
"cells not present in the assay"
))
}
# Check vars
orig <- vars
vars <- gsub(
pattern = paste0('^', Key(object = object)),
replacement = '',
x = vars
)
# Pull expression information
mat <- GetAssayData(object = object, layer = layer)
if (IsMatrixEmpty(x = mat)) {
abort(message = paste("Layer", sQuote(x = layer), "is empty in this assay"))
}
vars <- intersect(x = vars, y = rownames(x = mat))
tf <- .GetMethod(fxn = 't', cls = class(x = mat))
data.fetched <- as.data.frame(x = as.matrix(
x = tf(x = mat[vars, cells, drop = FALSE])
))
# Add keys to keyed vars
keyed.features <- paste0(Key(object = object), names(x = data.fetched))
keyed.idx <- which(x = keyed.features %in% orig)
if (length(x = keyed.idx)) {
names(x = data.fetched)[keyed.idx] <- keyed.features[keyed.idx]
}
# Check the final list of features
missing <- setdiff(x = orig, y = names(x = data.fetched))
if (length(x = missing) == length(x = orig)) {
abort(message = "None of the requested features found")
} else if (length(x = missing)) {
warn(message = paste(
"The following features could not be found",
paste(missing, collapse = ', ')
))
}
return(data.fetched)
}
#' @rdname AssayData
#' @export
#' @method GetAssayData Assay
#'
#' @examples
#' # Get the data directly from an Assay object
#' GetAssayData(pbmc_small[["RNA"]], layer = "data")[1:5,1:5]
#'
GetAssayData.Assay <- function(
object,
layer = c('data', 'scale.data', 'counts'),
slot = deprecated(),
...
) {
CheckDots(...)
if (is_present(arg = slot)) {
.Deprecate(
when = '5.0.0',
what = 'GetAssayData(slot = )',
with = 'GetAssayData(layer = )'
)
layer <- slot
}
layer <- layer[1L] %||% 'data'
layer <- match.arg(arg = layer)
return(methods::slot(object = object, name = layer))
}
#' @rdname VariableFeatures
#' @export
#' @method HVFInfo Assay
#'
#' @examples
#' # Get the HVF info directly from an Assay object
#' HVFInfo(pbmc_small[["RNA"]], method = 'vst')[1:5, ]
#'
HVFInfo.Assay <- function(
object,
method,
status = FALSE,
selection.method = deprecated(),
...
) {
CheckDots(...)
if (is_present(arg = selection.method)) {
.Deprecate(
when = '5.0.0',
what = 'HVFInfo(selection.method = )',
with = 'HVFInfo(method = )'
)
method <- selection.method
}
disp.methods <- c('mean.var.plot', 'dispersion', 'disp')
if (tolower(x = method) %in% disp.methods) {
method <- 'mvp'
}
method <- switch(
EXPR = tolower(x = method),
sctransform = 'sct',
method
)
vars <- switch(
EXPR = method,
vst = c('mean', 'variance', 'variance.standardized'),
mvp = c('mean', 'dispersion', 'dispersion.scaled'),
sct = c('gmean', 'variance', 'residual_variance'),
abort(message = paste("Unknown method:", sQuote(x = method)))
)
tryCatch(
expr = hvf.info <- object[[paste(method, vars, sep = '.')]],
error = function(e) {
stop(
"Unable to find highly variable feature information for method '",
method,
"'",
call. = FALSE
)
}
)
colnames(x = hvf.info) <- vars
if (status) {
hvf.info$variable <- object[[paste0(method, '.variable')]]
}
return(hvf.info)
}
#' @rdname Key
#' @export
#' @method Key Assay
#'
#' @examples
#' # Get an Assay key
#' Key(pbmc_small[["RNA"]])
#'
Key.Assay <- function(object, ...) {
CheckDots(...)
return(slot(object = object, name = 'key'))
}
#' @rdname Key
#' @export
#' @method Key<- Assay
#'
#' @examples
#' # Set the key for an Assay
#' Key(pbmc_small[["RNA"]]) <- "newkey_"
#' Key(pbmc_small[["RNA"]])
#'
"Key<-.Assay" <- function(object, ..., value) {
CheckDots(...)
slot(object = object, name = 'key') <- value
return(object)
}
#' @rdname Layers
#' @method LayerData Assay
#' @export
#'
LayerData.Assay <- function(
object,
layer = NULL,
cells = NULL,
features = NULL,
slot = deprecated(),
...
) {
if (is_present(arg = slot)) {
deprecate_stop(
when = "5.0.0",
what = "LayerData(slot = )",
with = "LayerData(layer = )"
)
}
# Figure out which matrix we're pulling
layer <- layer[1L] %||% "data"
# layer <- match.arg(
# arg = layer,
# choices = Layers(object = object, search = FALSE)
# )
# Handle empty layers
if (IsMatrixEmpty(x = methods::slot(object = object, name = layer))) {
msg <- paste("Layer", sQuote(x = layer), "is empty")
opt <- getOption(
x = 'Seurat.object.assay.v3.missing_layer',
default = Seurat.options$Seurat.object.assay.v3.missing_layer
)
opt <- tryCatch(
expr = arg_match0(arg = opt, values = c('matrix', 'null', 'error')),
error = function(...) {
return(Seurat.options$Seurat.object.assay.v3.missing_layer)
}
)
if (opt == 'error') {
abort(message = msg)
}
warn(message = msg)
return(switch(
EXPR = opt,
matrix = switch(
EXPR = layer,
scale.data = new(Class = 'matrix'),
new(Class = 'dgCMatrix')
),
NULL
))
}
# Allow cell/feature subsets
cells <- cells %||% colnames(x = object)
features <- features %||% Features(x = object, layer = layer)
if (is_bare_integerish(x = cells, finite = TRUE)) {
cells <- colnames(x = object)[cells]
}
cells <- arg_match(
arg = cells,
values = colnames(x = object),
multiple = TRUE
)
if (is_bare_integerish(x = features, finite = TRUE)) {
features <- Features(x = object, layer = layer)[features]
}
features <- arg_match(
arg = features,
values = Features(x = object, layer = layer),
multiple = TRUE
)
if (length(x = features) == 0) {
stop('features are not found')
}
# Pull the matrix for the cells/features requested
return(methods::slot(object = object, name = layer)[features, cells])
}
#' @rdname Layers
#' @method LayerData<- Assay
#' @export
#'
"LayerData<-.Assay" <- function(object, layer, ..., value) {
# Check the layer name
layer <- layer[1L]
layer <- match.arg(
arg = layer,
choices = Layers(object = object, search = FALSE)
)
# Allow short-hand switch
if (rlang::is_scalar_character(x = value)) {
value <- arg_match0(arg = value, values = Layers(object = object))
value <- LayerData(object = object, layer = value)
}
# Prepare an empty matrix if value is NULL
value <- value %||% switch(
EXPR = layer,
scale.data = new(Class = 'matrix'),
counts = new(Class = 'dgCMatrix'),
data = {
if (IsMatrixEmpty(x = suppressWarnings(expr = LayerData(object = object, layer = 'counts')))) {
abort(message = "Cannot remove the data layer")
}
warn(message = "Resetting the data matrix to the raw counts")
LayerData(object = object, layer = 'counts')
}
)
# Check the class of the matrix
if (!inherits(x = value, what = c('matrix', 'dgCMatrix'))) {
abort(message = paste(
"'value' must be a 'matrix' or 'dgCMatrix' in v3 Assays, not a",
sQuote(x = class(x = value)[1L])
))
}
if (!IsMatrixEmpty(x = value)) {
vnames <- dimnames(x = value)
# Check presence of cell- and feature-names
if (is.null(x = vnames)) {
if (!all(dim(x = value) == dim(x = object))) {
abort(message = "New data must have feature and cell names")
}
dimnames(x = value) <- dimnames(x = object)
} else if (any(.IsNull(x = vnames)) || !all(unlist(x = lapply(X = vnames, FUN = nzchar)))) {
abort(message = "New data must have feature and cell names")
}
# Remove underscores from feature names
if (any(grepl(pattern = '_', x = rownames(x = value)))) {
warn(
message = "Feature names cannot have underscores ('_'), replacing with dashes ('-')"
)
rownames(x = value) <- gsub(
pattern = '_',
replacement = '-',
x = rownames(x = value)
)
}
# Check the the cells
if (ncol(x = value) != ncol(x = object)) {
abort(message = "The new data must have the same number of cells as the current data")
} else if (!all(colnames(x = value) %in% colnames(x = object))) {
abort(message = "The new data must have the same cells as the current data")
}
value <- value[, colnames(x = object), drop = FALSE]
# Check the features
if (!any(rownames(x = value) %in% rownames(x = object))) {
abort(message = "None of the features provided are present in the existing data")
} else if (!all(rownames(x = value) %in% rownames(x = object))) {
warn(message = "Extra features present in the the new data compared to the existing data")
}
features <- intersect(x = rownames(x = object), y = rownames(x = value))
value <- value[features, , drop = FALSE]
if (layer %in% c('counts', 'data') && nrow(x = value) != nrow(x = object)) {
abort(message = "The new data must have the same number of features as the current data")
}
}
slot(object = object, name = layer) <- value
validObject(object = object)
return(object)
}
#' @rdname Layers
#' @method Layers Assay
#' @export
#'
Layers.Assay <- function(object, search = NA, ...) {
layers <- c('counts', 'data', 'scale.data')
if (isFALSE(x = search)) {
return(layers)
}
layers <- Filter(
f = function(x) {
return(!IsMatrixEmpty(x = slot(object = object, name = x)))
},
x = layers
)
if (!length(x = layers)) {
abort(message = "All matrices are empty in this Assay")
}
if (is.null(x = search)) {
return(DefaultLayer(object = object))
}
if (!is_na(x = search)) {
layers <- intersect(x = search, y = layers)
if (length(x = layers) == 0) {
warning(
"Layer ",
search,
" isn't present in the assay ",
deparse(expr = substitute(expr = object)),
"; returning NULL",
call. = FALSE,
immediate. = TRUE
)
return(NULL)
}
}
return(layers)
}
#' @param slot Name of specific bit of meta data to pull
#'
#' @rdname Misc
#' @export
#' @method Misc Assay
#'
Misc.Assay <- .Misc
#' @rdname Misc
#' @export
#' @method Misc<- Assay
#'
"Misc<-.Assay" <- `.Misc<-`
#' @param new.names vector of new cell names
#'
#' @rdname RenameCells
#' @export
#' @method RenameCells Assay
#'
#' @examples
#' # Rename cells in an Assay
#' head(x = colnames(x = pbmc_small[["RNA"]]))
#' renamed.assay <- RenameCells(
#' pbmc_small[["RNA"]],
#' new.names = paste0("A_", colnames(x = pbmc_small[["RNA"]]))
#' )
#' head(x = colnames(x = renamed.assay))
#'
RenameCells.Assay <- function(object, new.names = NULL, ...) {
CheckDots(...)
names(new.names) <- NULL
for (data.slot in c("counts", "data", "scale.data")) {
old.data <- GetAssayData(object = object, layer = data.slot)
if (ncol(x = old.data) <= 1) {
next
}
colnames(x = slot(object = object, name = data.slot)) <- new.names
}
return(object)
}
#' @importFrom stats na.omit
#'
#' @rdname AssayData
#' @export
#' @method SetAssayData Assay
#'
#' @examples
#' # Set an Assay layer directly
#' count.data <- GetAssayData(pbmc_small[["RNA"]], layer = "counts")
#' count.data <- as.matrix(x = count.data + 1)
#' new.assay <- SetAssayData(pbmc_small[["RNA"]], layer = "counts", new.data = count.data)
#'
SetAssayData.Assay <- function(
object,
layer = c('data', 'scale.data', 'counts'),
new.data,
slot = deprecated(),
...
) {
if (is_present(arg = slot)) {
.Deprecate(
when = '5.0.0',
what = 'SetAssayData(slot = )',
with = 'SetAssayData(layer = )'
)
layer <- slot
}
CheckDots(...)
layer <- layer[1]
layer <- match.arg(arg = layer)
if (!IsMatrixEmpty(x = new.data)) {
if (any(grepl(pattern = '_', x = rownames(x = new.data)))) {
warning(
"Feature names cannot have underscores ('_'), replacing with dashes ('-')",
call. = FALSE,
immediate. = TRUE
)
rownames(x = new.data) <- gsub(
pattern = '_',
replacement = '-',
x = rownames(x = new.data)
)
}
if (ncol(x = new.data) != ncol(x = object)) {
stop(
"The new data doesn't have the same number of cells as the current data",
call. = FALSE
)
}
num.counts <- nrow(x = object)
counts.names <- rownames(x = object)
if (layer == 'scale.data' && nrow(x = new.data) > num.counts) {
warning(
"Adding more features than present in current data",
call. = FALSE,
immediate. = TRUE
)
} else if (layer %in% c('counts', 'data') && nrow(x = new.data) != num.counts) {
warning(
"The new data doesn't have the same number of features as the current data",
call. = FALSE,
immediate. = TRUE
)
}
if (!all(rownames(x = new.data) %in% counts.names)) {
warning(
"Adding features not currently present in the object",
call. = FALSE,
immediate. = TRUE
)
}
new.features <- na.omit(object = match(
x = counts.names,
table = rownames(x = new.data)
))
new.cells <- colnames(x = new.data)
if (!all(new.cells %in% colnames(x = object))) {
stop(
"All cell names must match current cell names",
call. = FALSE
)
}
new.data <- new.data[new.features, colnames(x = object), drop = FALSE]
if (layer %in% c('counts', 'data') && !all(dim(x = new.data) == dim(x = object))) {
stop(
"Attempting to add a different number of cells and/or features",
call. = FALSE
)
}
}
if (!is.vector(x = rownames(x = new.data))) {
rownames(x = new.data) <- as.vector(x = rownames(x = new.data))
}
if (!is.vector(x = colnames(x = new.data))) {
colnames(x = new.data) <- as.vector(x = colnames(x = new.data))
}
slot(object = object, name = layer) <- new.data
return(object)
}
#' @param decreasing Return features in decreasing order (most spatially
#' variable first).
#'
#' @rdname VariableFeatures
#' @export
#' @method SpatiallyVariableFeatures Assay
#'
SpatiallyVariableFeatures.Assay <- function(
object,
method = "moransi",
decreasing = TRUE,
selection.method = deprecated(),
...
) {
CheckDots(...)
if (is_present(arg = selection.method)) {
.Deprecate(
when = '5.0.0',
what = 'SpatiallyVariableFeatures(selection.method = )',
with = 'SpatiallyVariableFeatures(method = )'
)
method <- selection.method
}
vf <- SVFInfo(object = object, method = method, status = TRUE)
vf <- vf[rownames(x = vf)[which(x = vf[, "variable"][, 1])], ]
if (!is.null(x = decreasing)) {
vf <- vf[order(x = vf[, "rank"], decreasing = !decreasing), ]
}
return(rownames(x = vf)[which(x = vf[, "variable"][, 1])])
}
#' @rdname VariableFeatures
#' @export
#' @method SVFInfo Assay
#'
SVFInfo.Assay <- function(
object,
method = c("markvariogram", "moransi"),
status = FALSE,
selection.method = deprecated(),
...
) {
CheckDots(...)
if (is_present(arg = selection.method)) {
.Deprecate(
when = '5.0.0',
what = 'SVFInfo(selection.method = )',
with = 'SVFInfo(method = )'
)
method <- selection.method
}
method <- method[1]
method <- match.arg(arg = method)
vars <- switch(
EXPR = method,
markvariogram = grep(
pattern = "r.metric",
x = colnames(x = object[]),
value = TRUE
),
moransi = grep(
pattern = 'moransi',
x = colnames(x = object[]),
value = TRUE
),
abort(message = paste("Unknown method:", sQuote(x = method)))
)
tryCatch(
expr = svf.info <- object[[vars]],
error = function(e) {
stop(
"Unable to find highly variable feature information for method '",
method,
"'",
call. = FALSE
)
}
)
colnames(x = svf.info) <- vars
if (status) {
svf.info$variable <- object[[paste0(method, '.spatially.variable')]]
svf.info$rank <- object[[paste0(method, '.spatially.variable.rank')]]
}
return(svf.info)
}
#' @rdname VariableFeatures
#' @export
#' @method VariableFeatures Assay
#'
VariableFeatures.Assay <- function(
object,
method = NULL,
selection.method = deprecated(),
...
) {
suppressWarnings(CheckDots(...))
if (is_present(arg = selection.method)) {
.Deprecate(
when = '5.0.0',
what = 'VariableFeatures(selection.method = )',
with = 'VariableFeatures(method = )'
)
method <- selection.method
}
if (!is.null(x = method)) {
vf <- HVFInfo(
object = object,
method = method,
status = TRUE
)
return(rownames(x = vf)[which(x = vf[, "variable"][, 1])])
}
return(slot(object = object, name = 'var.features'))
}
#' @rdname VariableFeatures
#' @export
#' @method VariableFeatures<- Assay
#'
"VariableFeatures<-.Assay" <- function(object, ..., value) {
CheckDots(...)
if (!length(x = value)) {
slot(object = object, name = 'var.features') <- character(length = 0)
return(object)
}
if (any(grepl(pattern = '_', x = value))) {
warning(
"Feature names cannot have underscores '_', replacing with dashes '-'",
call. = FALSE,
immediate = TRUE
)
value <- gsub(pattern = '_', replacement = '-', x = value)
}
value <- split(x = value, f = value %in% rownames(x = object))
if (length(x = value[['FALSE']]) > 0) {
if (length(x = value[['TRUE']]) == 0) {
abort(message = "None of the features provided are in this Assay object")
} else {
warning(
"Not all features provided are in this Assay object, removing the following feature(s): ",
paste(value[['FALSE']], collapse = ', '),
call. = FALSE,
immediate. = TRUE
)
}
}
slot(object = object, name = 'var.features') <- value[['TRUE']]
return(object)
}
#' @param cells Subset of cell names
#' @param expression A predicate expression for feature/variable expression,
#' can evaluate anything that can be pulled by \code{FetchData}; please note,
#' you may need to wrap feature names in backticks (\code{``}) if dashes
#' between numbers are present in the feature name
#' @param invert Invert the selection of cells
#'
#' @importFrom stats na.omit
#'
#' @rdname WhichCells
#' @export
#' @method WhichCells Assay
#'
WhichCells.Assay <- function(
object,
cells = NULL,
expression,
invert = FALSE,
...
) {
CheckDots(...)
cells <- cells %||% colnames(x = object)
if (!missing(x = expression) && !is.null(x = substitute(expr = expression))) {
key.pattern <- paste0('^', Key(object = object))
expr <- if (tryCatch(expr = is_quosure(x = expression), error = function(...) FALSE)) {
expression
} else if (is.call(x = enquo(arg = expression))) {
enquo(arg = expression)
} else {
parse(text = expression)
}
expr.char <- suppressWarnings(expr = as.character(x = expr))
expr.char <- unlist(x = lapply(X = expr.char, FUN = strsplit, split = ' '))
expr.char <- gsub(
pattern = key.pattern,
replacement = '',
x = expr.char,
perl = TRUE
)
expr.char <- gsub(
pattern = '(',
replacement = '',
x = expr.char,
fixed = TRUE
)
expr.char <- gsub(
pattern = '`',
replacement = '',
x = expr.char
)
vars.use <- which(x = expr.char %in% rownames(x = object))
expr.char <- expr.char[vars.use]
data.subset <- FetchData(object = object, vars = expr.char)
cells <- rownames(x = data.subset)[eval_tidy(expr = expr, data = data.subset)]
}
if (invert) {
cells <- colnames(x = object)[!colnames(x = object) %in% cells]
}
cells <- na.omit(object = unlist(x = cells, use.names = FALSE))
return(as.character(x = cells))
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for R-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' @inherit .DollarNames.Assay5 return title details sections seealso
#'
#' @description Autocompletion for \code{$} access on an
#' \code{\link{Assay}} object
#'
#' @inheritParams utils::.DollarNames
#' @param x An \code{\link{Assay}} object
#'
#' @importFrom utils .DollarNames
#'
#' @keywords internal
#'
#' @method .DollarNames Assay
#' @export
#'
#' @concept assay
#'
.DollarNames.Assay <- function(x, pattern = '') {
slots.avial <- Layers(x)
slots.avial <- as.list(slots.avial)
names(slots.avial) <- unlist(slots.avial)
return(.DollarNames(x = slots.avial, pattern = pattern))
}
#' @inherit $.Assay5 return title description details sections params
#'
#' @param x An \code{\link{Assay}} object
#'
#' @method $ Assay
#' @export
#'
#' @family assay
#'
#' @examples
#' rna <- pbmc_small[["RNA"]]
#'
#' # Fetch a layer with `$`
#' rna$data[1:10, 1:4]
#'
"$.Assay" <- function(x, i) {
return(LayerData(object = x, layer = i))
}
#' @rdname cash-.Assay
#'
#' @method $<- Assay
#' @export
#'
#' @examples
#' # Add a layer with `$`
#' rna$data <- rna$counts
#' rna$data[1:10, 1:4]
#'
"$<-.Assay" <- function(x, i, value) {
LayerData(object = x, layer = i) <- value
return(x)
}
#' @inherit [.Assay5 return title description details sections
#'
#' @inheritParams [.Assay5
#' @param x An \code{\link{Assay}} object
#' @param j Ignored
#'
#' @method [ Assay
#' @export
#'
#' @order 1
#'
#' @seealso \code{\link{LayerData}}
#'
#' @family assay
#'
#' @examples
#' rna <- pbmc_small[["RNA"]]
#'
#' # Get a vector of layer names in this assay
#' rna[]
#'
#' # Fetch layer data
#' rna["data"][1:10, 1:4]
#'
"[.Assay" <- function(x, i = missing_arg(), j = missing_arg(), ...) {
if (getOption(x = 'Seurat.object.assay.brackets', default = 'v5') == 'v3') {
if (is_missing(x = i)) {
i <- seq_len(length.out = nrow(x = x))
}
if (is_missing(x = j)) {
j <- seq_len(length.out = ncol(x = x))
}
return(LayerData(
object = x,
layer = DefaultLayer(object = x)[1L],
cells = j,
features = i
))
}
if (is_missing(x = i)) {
return(Layers(object = x))
}
return(LayerData(object = x, layer = i, ...))
}
#' @inherit [[.Assay5 return title description details sections
#'
#' @inheritParams [[.Assay5
#' @param x An \code{\link{Assay}} object
#'
#' @method [[ Assay
#' @export
#'
#' @family assay
#'
#' @order 1
#'
#' @examples
#' rna <- pbmc_small[["RNA"]]
#'
#' # Pull the entire feature-level meta data data frame
#' head(rna[[]])
#'
#' # Pull a specific column of feature-level meta data
#' head(rna[["vst.mean"]])
#' head(rna[["vst.mean", drop = TRUE]])
#'
"[[.Assay" <- function(x, i, ..., drop = FALSE) {
if (missing(x = i)) {
i <- colnames(x = slot(object = x, name = 'meta.features'))
}
data.return <- slot(object = x, name = 'meta.features')[, i, drop = FALSE, ...]
if (drop) {
data.return <- unlist(x = data.return, use.names = FALSE)
names(x = data.return) <- rep.int(x = rownames(x = x), times = length(x = i))
}
return(data.return)
}
#' @inherit dim.Assay5 return title description details sections
#'
#' @inheritParams [.Assay
#'
#' @method dim Assay
#' @export
#'
#' @family assay
#'
#' @examples
#' rna <- pbmc_small[["RNA"]]
#' dim(rna)
#'
dim.Assay <- function(x) {
return(dim(x = GetAssayData(object = x)))
}
#' @inherit dimnames.Assay5 title description details sections
#'
#' @inheritParams [.Assay
#'
#' @return \code{dimnames}: A two-length list with the following values:
#' \itemize{
#' \item A character vector will all features in \code{x}
#' \item A character vector will all cells in \code{x}
#' }
#'
#' @method dimnames Assay
#' @export
#'
#' @family assay
#' @family dimnames
#'
#' @examples
#' rna <- pbmc_small[["RNA"]]
#'
#' # Feature and cell names can be acquired with `rownames` and `colnames`
#' head(rownames(rna))
#' head(colnames(rna))
#'
dimnames.Assay <- function(x) {
return(dimnames(x = GetAssayData(object = x)))
}
#' @param value A two-length list where the first entry is the existing feature
#' names for \code{x} and the second entry is the \emph{updated} cell names
#' for \code{x}
#'
#' @return \code{dimnames<-}: \code{x} with the cell names updated to those
#' in \code{value[[2L]]}
#'
#' @rdname dimnames.Assay
#'
#' @method dimnames<- Assay
#' @export
#'
#' @examples
#' # Cell names can be updated with `colnames<-`
#' colnames(rna)[1] <- "newcell"
#' head(colnames(rna))
#'
"dimnames<-.Assay" <- function(x, value) {
op <- options(Seurat.object.validate = FALSE)
on.exit(expr = options(op), add = TRUE)
# Check the provided dimnames
msg <- "Invalid 'dimnames' given for a Seurat object"
if (!is_bare_list(x = value, n = 2L)) {
abort(message = msg)
} else if (!all(sapply(X = value, FUN = length) == dim(x = x))) {
abort(message = msg)
}
value <- lapply(X = value, FUN = as.character)
# Warn about changing features
if (!all(value[[1L]] == rownames(x = slot(object = x, name = 'data')))) {
warn(message = "Changing feature names in v3 Assays is not supported")
}
# Set cell names
for (lyr in c('counts', 'data', 'scale.data')) {
if (!IsMatrixEmpty(x = slot(object = x, name = lyr))) {
suppressWarnings(expr = colnames(x = slot(object = x, name = lyr)) <- value[[2L]])
}
}
# Validate and return the Seurat object
options(op)
validObject(object = x)
return(x)
}
#' @rdname sub-sub-.Assay
#'
#' @method head Assay
#' @export
#'
#' @examples
#' # `head` and `tail` can be used to quickly view feature-level meta data
#' head(rna)
#'
head.Assay <- function(x, n = 10L, ...) {
return(head(x[[]], n = 10L, ...))
}
#' Merge Assays
#'
#' Merge one or more v3 assays together
#'
#' @inheritParams [[.Assay
#' @param y One or more \code{\link{Assay}} objects
#' @param add.cell.ids A character vector of \code{length(x = c(x, y))};
#' appends the corresponding values to the start of each objects' cell names
#' @param merge.data Merge the data slots instead of just merging the counts
#' (which requires renormalization); this is recommended if the same
#' normalization approach was applied to all objects
#' @param labels,collapse Currently unused
#'
#' @return A new assay with data merged from \code{c(x, y)}
#'
#' @method merge Assay
#' @export
#'
#' @family assay
#'
merge.Assay <- function(
x = NULL,
y = NULL,
add.cell.ids = NULL,
merge.data = TRUE,
labels = NULL,
collapse = TRUE,
...
) {
CheckDots(...)
assays <- c(x, y)
if (any(sapply(
X = assays,
FUN = function(assay.i) inherits(x = assay.i, what = "Assay5")
))) {
return(merge(x = as(x, "Assay5"), y, ...))
}
if (!is.null(x = add.cell.ids)) {
for (i in seq_along(along.with = assays)) {
assays[[i]] <- RenameCells(
object = assays[[i]],
new.names = add.cell.ids[i]
)
}
}
# Merge the counts (if present)
counts.mats <- lapply(X = assays, FUN = ValidateDataForMerge, slot = "counts")
keys <- unlist(sapply(X = assays, FUN = Key))
merged.counts <- RowMergeSparseMatrices(
mat1 = counts.mats[[1]],
mat2 = counts.mats[2:length(x = counts.mats)]
)
combined.assay <- CreateAssayObject(
counts = merged.counts,
min.cells = -1,
min.features = -1
)
Key(object = combined.assay) <- keys[1]
if (merge.data) {
data.mats <- lapply(X = assays, FUN = ValidateDataForMerge, slot = "data")
merged.data <- RowMergeSparseMatrices(
mat1 = data.mats[[1]],
mat2 = data.mats[2:length(x = data.mats)]
)
# only keep cells that made it through counts filtering params
if (!all.equal(target = colnames(x = combined.assay), current = colnames(x = merged.data))) {
merged.data <- merged.data[, colnames(x = combined.assay)]
}
combined.assay <- SetAssayData(
object = combined.assay,
layer = "data",
new.data = merged.data
)
}
return(combined.assay)
}
#' @inherit split.Assay5 title description details
#'
#' @inheritParams split.Assay5
#' @param x An \code{\link{Assay}} object
#'
#' @return Returns a v5 assay with splitted layers
#'
#' @method split Assay
#' @export
#'
#' @family assay
#'
split.Assay <- function(
x,
f,
drop = FALSE,
layers = NA,
...
) {
warn(message = paste(
strwrap(x = paste(
"Input is a v3 assay and `split()` only works for v5 assays;",
"converting to a v5 assay"
))
))
x <- as(object = x, Class = 'Assay5')
split.x <- split(
x = x,
f = f,
drop = drop,
layers = layers,
...
)
return(split.x)
}
#' @inherit subset.Assay5 title description details sections
#'
#' @inheritParams subset.Assay5
#' @param x An \code{\link{Assay}} object
#'
#' @return \code{x} with just the cells and features specified by
#' \code{cells} and \code{features}
#'
#' @importFrom stats na.omit
#'
#' @method subset Assay
#' @export
#'
#' @family assay
#'
#' @examples
#' rna <- pbmc_small[["RNA"]]
#' rna2 <- subset(rna, features = VariableFeatures(rna))
#' rna2
#'
subset.Assay <- function(x, cells = NULL, features = NULL, ...) {
CheckDots(...)
cells <- cells %||% colnames(x = x)
if (all(is.na(x = cells))) {
cells <- colnames(x = x)
} else if (any(is.na(x = cells))) {
warn(message = "NAs passed in cells vector, removing NAs")
cells <- na.omit(object = cells)
}
cells <- intersect(x = colnames(x), y = cells)
features <- features %||% rownames(x = x)
if (all(is.na(x = features))) {
features <- rownames(x = x)
} else if (any(is.na(x = features))) {
warn(message = "NAs passed in the features vector, removing NAs")
features <- na.omit(object = features)
}
if (all(sapply(X = list(features, cells), FUN = length) == dim(x = x))) {
return(x)
}
if (is.numeric(x = features)) {
features <- rownames(x = x)[features]
}
features <- gsub(
pattern = paste0('^', Key(object = x)),
replacement = '',
x = features
)
features <- intersect(x = features, y = rownames(x = x))
if (length(x = features) == 0) {
abort(message = "Cannot find features provided")
}
if (ncol(x = GetAssayData(object = x, layer = 'counts')) == ncol(x = x)) {
slot(object = x, name = "counts") <- GetAssayData(object = x, layer = "counts")[features, cells, drop = FALSE]
}
slot(object = x, name = "data") <- GetAssayData(object = x, layer = "data")[features, cells, drop = FALSE]
cells.scaled <- colnames(x = GetAssayData(object = x, layer = "scale.data"))
cells.scaled <- cells.scaled[cells.scaled %in% cells]
cells.scaled <- cells.scaled[na.omit(object = match(x = colnames(x = x), table = cells.scaled))]
features.scaled <- rownames(x = GetAssayData(object = x, layer = 'scale.data'))
features.scaled <- intersect(x = features, y = features.scaled)
slot(object = x, name = "scale.data") <- if (length(x = cells.scaled) > 0 && length(x = features.scaled) > 0) {
GetAssayData(object = x, layer = "scale.data")[features.scaled, cells.scaled, drop = FALSE]
} else {
new(Class = 'matrix')
}
VariableFeatures(object = x) <- VariableFeatures(object = x)[VariableFeatures(object = x) %in% features]
slot(object = x, name = 'meta.features') <- x[[]][features, , drop = FALSE]
validObject(object = x)
return(x)
}
#' @rdname sub-sub-.Assay
#'
#' @method tail Assay
#' @export
#'
#' @examples
#' tail(rna)
#'
tail.Assay <- function(x, n = 10L, ...) {
return(tail(x[[]], n = n, ...))
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# S4 methods
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' @rdname sub-.Assay
#'
#' @examples
#' # Set layer data
#' rna["data"] <- rna["counts"]
#' rna["data"][1:10, 1:4]
#'
setMethod(
f = '[<-',
signature = c(x = 'Assay', i = 'character'),
definition = function(x, i, ..., value) {
LayerData(object = x, layer = i, ...) <- value
return(x)
}
)
#' @rdname sub-sub-.Assay
#'
#' @order 2
#'
setMethod(
f = '[[<-',
signature = c(x = 'Assay'),
definition = function(x, i, ..., value) {
meta.data <- x[[]]
feature.names <- rownames(x = meta.data)
if (is.data.frame(x = value)) {
value <- lapply(
X = 1:ncol(x = value),
FUN = function(index) {
v <- value[[index]]
names(x = v) <- rownames(x = value)
return(v)
}
)
}
err.msg <- "Cannot add more or fewer meta.features information without values being named with feature names"
if (length(x = i) > 1) {
# Add multiple bits of feature-level metadata
value <- rep_len(x = value, length.out = length(x = i))
for (index in 1:length(x = i)) {
names.intersect <- intersect(x = names(x = value[[index]]), feature.names)
if (length(x = names.intersect) > 0) {
meta.data[names.intersect, i[index]] <- value[[index]][names.intersect]
} else if (length(x = value) %in% c(nrow(x = meta.data), 1) %||% is.null(x = value)) {
meta.data[i[index]] <- value[index]
} else {
stop(err.msg, call. = FALSE)
}
}
} else {
# Add a single column to feature-level metadata
value <- unlist(x = value)
if (length(x = intersect(x = names(x = value), y = feature.names)) > 0) {
meta.data[, i] <- value[feature.names]
} else if (length(x = value) %in% c(nrow(x = meta.data), 1) || is.null(x = value)) {
meta.data[, i] <- value
} else {
stop(err.msg, call. = FALSE)
}
}
slot(object = x, name = 'meta.features') <- meta.data
return(x)
}
)
#' @rdname sub-sub-.Assay
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Assay',
i = 'missing',
j = 'missing',
value = 'data.frame'
),
definition = function(x, ..., value) {
# Allow removing all meta data
if (IsMatrixEmpty(x = value)) {
x[[names(x = x[[]])]] <- NULL
return(x)
}
if (is.null(names(x = value))) {
warn(message = 'colnames of input cannot be NULL')
} else {
# If no `i` provided, use the column names from value
x[[names(x = value)]] <- value
}
return(x)
}
)
#' Row and Column Sums and Means
#'
#' Calculate \code{\link{rowSums}}, \code{\link{colSums}},
#' \code{\link{rowMeans}}, and \code{\link{colMeans}} on \code{Assay} objects
#'
#' @inheritParams [[.Assay
#' @inheritParams Matrix::colMeans
#' @param slot Name of assay expression matrix to calculate column/row
#' means/sums on
#'
#' @return \code{colMeans}: The column (cell-wise) means of \code{slot}
#'
#' @importFrom Matrix colMeans
#'
#' @keywords internal
#'
#' @export
#'
#' @concept assay
#'
#' @seealso \code{\link{Assay}}
#'
#' @examples
#' rna <- pbmc_small[["RNA"]]
#'
#' colMeans(rna)
#'
setMethod(
f = 'colMeans',
signature = c(x = 'Assay'),
definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
return(Matrix::colMeans(
x = GetAssayData(object = x, layer = slot),
na.rm = na.rm,
dims = dims,
...
))
}
)
#' @return \code{colSums}: The column (cell-wise) sums of \code{slot}
#'
#' @rdname colMeans-Assay-method
#'
#' @importFrom Matrix colSums
#'
#' @export
#'
#' @examples
#' colSums(rna)
#'
setMethod(
f = 'colSums',
signature = c(x = 'Assay'),
definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
return(Matrix::colSums(
x = GetAssayData(object = x, layer = slot),
na.rm = na.rm,
dims = dims,
...
))
}
)
#' @return \code{rowMeans}: The row (feature-wise) means of \code{slot}
#'
#' @rdname colMeans-Assay-method
#'
#' @importFrom Matrix rowMeans
#'
#' @export
#'
#' @examples
#' rowMeans(rna)
#'
setMethod(
f = 'rowMeans',
signature = c(x = 'Assay'),
definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
return(Matrix::rowMeans(
x = GetAssayData(object = x, layer = slot),
na.rm = na.rm,
dims = dims,
...
))
}
)
#' @return \code{rowSums}: The row (feature-wise) sums of \code{slot}
#'
#' @rdname colMeans-Assay-method
#'
#' @importFrom Matrix rowSums
#'
#' @export
#'
#' @examples
#' rowSums(rna)
#'
setMethod(
f = 'rowSums',
signature = c(x = 'Assay'),
definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
return(Matrix::rowSums(
x = GetAssayData(object = x, layer = slot),
na.rm = na.rm,
dims = dims,
...
))
}
)
#' V3 Assay Overview
#'
#' Overview of an \code{\link{Assay}} object
#'
#' @template return-show
#'
#' @keywords internal
#'
#' @concept assay
#'
#' @seealso \code{\link{Assay}}
#'
#' @examples
#' rna <- pbmc_small[["RNA"]]
#' rna
#'
setMethod(
f = 'show',
signature = 'Assay',
definition = function(object) {
cat(
class(x = object)[1],
'data with',
nrow(x = object),
'features for',
ncol(x = object), 'cells\n'
)
if (length(x = VariableFeatures(object = object)) > 0) {
top.ten <- head(x = VariableFeatures(object = object), n = 10L)
top <- 'Top'
variable <- 'variable'
} else {
top.ten <- head(x = rownames(x = object), n = 10L)
top <- 'First'
variable <- ''
}
features <- paste0(
variable,
' feature',
if (length(x = top.ten) != 1) {
's'
},
":\n"
)
features <- gsub(pattern = '^\\s+', replacement = '', x = features)
cat(
top,
length(x = top.ten),
features,
paste(strwrap(x = paste(top.ten, collapse = ', ')), collapse = '\n'),
'\n'
)
return(invisible(x = NULL))
}
)
#' V3 Assay Validity
#'
#' @templateVar cls Assay
#' @template desc-validity
#'
#' @section \code{data} Validation:
#' blah
#'
#' @section \code{counts} Validation:
#' blah
#'
#' @section \code{scale.data} Validation:
#' blah
#'
#' @section Feature-Level Meta Data Validation:
#' blah
#'
#' @section Variable Feature Validation:
#' blah
#'
#' @inheritSection Key-validity Key Validation
#'
#' @name Assay-validity
#'
#' @family assay
#' @seealso \code{\link[methods]{validObject}}
#'
#' @examples
#' rna <- pbmc_small[["RNA"]]
#' validObject(rna)
#'
setValidity(
Class = 'Assay',
method = function(object) {
if (.GetSeuratCompat() < '5.0.0') {
return(TRUE)
}
if (isFALSE(x = getOption(x = "Seurat.object.validate", default = TRUE))) {
warn(
message = paste("Not validating", class(x = object)[1L], "objects"),
class = 'validationWarning'
)
return(TRUE)
}
valid <- NULL
# Check matrices
features <- rownames(x = slot(object = object, name = 'data'))
if (anyDuplicated(x = features)) {
valid <- c(valid, "duplicate feature names are not allowed")
}
cells <- colnames(x = slot(object = object, name = 'data'))
if (anyDuplicated(x = cells)) {
valid <- c(valid, "duplicate cell names are not allowed")
}
for (lyr in c('counts', 'scale.data')) {
ldat <- slot(object = object, name = lyr)
if (IsMatrixEmpty(x = ldat)) {
next
}
if (!all(colnames(x = ldat) == cells)) {
valid <- c(
valid,
paste0("'", lyr, "' must have the same cells as 'data'")
)
}
if (lyr == 'counts' && !all(rownames(x = ldat) == features)) {
valid <- c(
valid,
paste0("'", lyr, "' must have the same features as 'data'")
)
} else if (lyr == 'scale.data') {
scaled <- rownames(x = ldat)
if (!all(scaled %in% features)) {
valid <- c(
valid,
"all features in 'scale.data' must be present in 'data'"
)
} else if (is.unsorted(x = MatchCells(new = scaled, orig = features, ordered = TRUE))) {
valid <- c(
valid,
"features in 'scale.data' must be in the same order as in 'data'"
)
}
}
}
# Check meta.features
mf <- slot(object = object, name = 'meta.features')
if (nrow(x = mf) != length(x = features)) {
valid <- c(
valid,
"'meta.features' must have the same number of rows as 'data'"
)
} else if (!all(row.names(x = mf) == features)) {
valid <- c(valid, "meta.features' must have the same features as 'data'")
}
# Check variable features
vf <- slot(object = object, name = 'var.features')
if (length(x = vf) && !all(vf %in% features)) {
valid <- c(valid, "all 'var.features' must be present in")
}
# TODO: Check assay.orig
return(valid %||% TRUE)
}
)
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Internal
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Calculate nCount and nFeature
#'
#' @param object An \code{\link{Assay}} object
#'
#' @return A named list with nCount and nFeature
#'
#' @keywords internal
#'
#' @noRd
#'
#' @examples
#' \donttest{
#' calcn <- SeuratObject:::CalcN(pbmc_small[["RNA"]])
#' head(as.data.frame(calcn))
#' }
#'
CalcN <- .CalcN
#' Subset cells in vst data
#'
#' @param sct.info A vst.out list
#' @param cells vector of cells to retain
#' @param features vector of features to retain
#'
#' @keywords internal
#'
#' @noRd
#'
SubsetVST <- function(sct.info, cells, features) {
cells.keep <- intersect(x = cells, y = rownames(x = sct.info$cell_attr))
sct.info$cell_attr <- sct.info$cell_attr[cells.keep, ]
# find which subset of features are in the SCT assay
feat.keep <- intersect(x = features, y = rownames(x = sct.info$gene_attr))
sct.info$gene_attr <- sct.info$gene_attr[feat.keep, ]
return(sct.info)
}
#' Validate Assay Data for Merge
#'
#' Pulls the proper data matrix for merging assay data. If the slot is empty,
#' will return an empty matrix with the proper dimensions from one of the
#' remaining data slots.
#'
#' @param assay Assay to pull data from
#' @param slot Slot to pull from
#'
#' @return Returns the data matrix if present (i.e.) not 0x0. Otherwise,
#' returns an appropriately sized empty sparse matrix
#'
#' @importFrom methods as
#' @importFrom Matrix Matrix
#'
#' @keywords internal
#'
#' @noRd
#'
ValidateDataForMerge <- function(assay, slot) {
mat <- GetAssayData(object = assay, layer = slot)
if (any(dim(x = mat) == c(0, 0))) {
slots.to.check <- setdiff(x = c("counts", "data", "scale.data"), y = slot)
for (ss in slots.to.check) {
data.dims <- dim(x = GetAssayData(object = assay, layer = ss))
data.slot <- ss
if (!any(data.dims == c(0, 0))) {
break
}
}
if (any(data.dims == c(0, 0))) {
stop("The counts, data, and scale.data slots are all empty for the provided assay.")
}
mat <- Matrix(
data = 0,
nrow = data.dims[1],
ncol = data.dims[2],
dimnames = dimnames(x = GetAssayData(object = assay, layer = data.slot))
)
mat <- as.sparse(x = mat)
}
return(mat)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.