Nothing
#' @include zzz.R
#' @include assay.R
#' @include layers.R
#' @include logmap.R
#' @include keymixin.R
#' @importFrom methods callNextMethod setAs
#'
NULL
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Class definitions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Core Assay Infrastructure
#'
#' The \code{StdAssay} class is a virtual class that provides core
#' infrastructure for assay data in \pkg{Seurat}. Assays contain expression
#' data (layers) and associated feature-level meta data. Derived classes
#' (eg. \link[=Assay5]{the v5 Assay}) may optionally
#' define additional functionality
#'
#' @template slot-stdassay
#' @template slot-misc
#' @template slot-key
#'
#' @keywords internal
#'
#' @exportClass StdAssay
#'
#' @aliases StdAssay
#'
#' @family stdassay
#'
#' @seealso \code{\link{Assay5-class}} \code{\link{Assay5T-class}}
#'
setClass(
Class = 'StdAssay',
contains = c('VIRTUAL', 'KeyMixin'),
slots = c(
layers = 'list',
cells = 'LogMap',
features = 'LogMap',
default = 'integer',
assay.orig = 'character',
meta.data = 'data.frame',
misc = 'list'
)
)
#' The v5 \code{Assay} Object
#'
#' The v5 \code{Assay} is the typical \code{Assay} class used in \pkg{Seurat}
#' v5; ...
#'
#' @template slot-stdassay
#' @template slot-misc
#' @template slot-key
#'
#' @exportClass Assay5
#'
#' @aliases Assay5
#'
#' @family assay5
#'
setClass(
Class = 'Assay5',
contains = 'StdAssay'
)
#' The Transposed v5 \code{Assay} Object
#'
#' @template slot-stdassay
#' @template slot-misc
#' @template slot-key
#'
#' @template lifecycle-experimental
#'
#' @keywords internal
#'
#' @aliases Assay5T
#'
setClass(
Class = 'Assay5T',
contains = 'StdAssay'
)
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Functions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Create a v5 Assay object
#'
#' Create an \code{\link{Assay5}} object from a feature expression matrix;
#' the expected format of the matrix is features x cells
#'
#' @inheritParams .CreateStdAssay
#' @param data Optional prenormalized data matrix
#' @template param-dots-method
# @param transpose Create a transposed assay
# @param ... Extra parameters passed to \code{\link{.CreateStdAssay}}
#'
#' @return An \code{\link{Assay5}} object
#'
#' @export
#'
#' @concept assay
#'
CreateAssay5Object <- function(
counts = NULL,
data = NULL,
min.cells = 0,
min.features = 0,
csum = NULL,
fsum = NULL,
...
) {
transpose <- FALSE
colsums <- Matrix::colSums
rowsums <- Matrix::rowSums
type <- 'Assay5'
csum <- csum %||% colsums
fsum <- fsum %||% rowsums
counts <- CheckLayersName(matrix.list = counts, layers.type = 'counts')
data <- CheckLayersName(matrix.list = data, layers.type = 'data')
if (!is.null(x = counts) & !is.null(data)) {
counts.cells <- unlist(
x = lapply(
X = counts,
FUN = function(x) colnames(x = x)
)
)
data.cells <- unlist(
x = lapply(
X = data,
FUN = function(x) colnames(x)
)
)
if (!all(counts.cells == data.cells)) {
abort(message = 'counts and data input should have the same cells')
}
}
counts <- c(counts, data)
data <- NULL
CheckGC()
return(.CreateStdAssay(
counts = counts,
min.cells = min.cells,
min.features = min.features,
transpose = transpose,
type = type,
csum = csum,
fsum = fsum,
...
))
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for Seurat-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' @method .AssayClass Assay5T
#' @export
#'
.AssayClass.Assay5T <- function(object) {
return('Transposed Assay (v5)')
}
#' @method .CalcN StdAssay
#' @export
#'
.CalcN.StdAssay <- function(object, layer = 'counts', simplify = TRUE, ...) {
layer <- tryCatch(
expr = Layers(object = object, search = layer),
error = \(...) NULL
) # %||% DefaultLayer(object = object)
if (is.null(x = layer)) {
warn(
message = "Cannot find the layer(s) specified",
class = 'missingLayerWarning'
)
return(NULL)
}
calcn <- vector(mode = 'list', length = length(x = layer))
names(x = calcn) <- layer
for (lyr in layer) {
ldat <- LayerData(object = object, layer = lyr)
if (IsMatrixEmpty(x = ldat)) {
next
}
calcn[[lyr]] <- .CalcN(object = ldat)
}
calcn <- Filter(f = length, x = calcn)
# If every layer is empty, return `NULL`
if (!length(x = calcn)) {
return(NULL)
} else if (isFALSE(x = simplify)) {
# If we're not simplifying, return the list as-is
return(calcn)
} else if (length(x = calcn) == 1L) {
# If we're only calculating N for one layer, return those results
return(calcn[[1L]])
}
# Simplify the calcn list for all cells
all.cells <- Cells(x = object, layer = layer, simplify = TRUE)
ncells <- length(x = all.cells)
ncalc <- list(
nCount = vector(mode = 'numeric', length = ncells),
nFeature = vector(mode = 'numeric', length = ncells)
)
names(x = ncalc$nCount) <- names(x = ncalc$nFeature) <- all.cells
# For every layer, add the nCount and nFeature counts to existing cells
for (i in seq_along(along.with = calcn)) {
lcells <- names(x = calcn[[i]][['nCount']])
ncalc[['nCount']][lcells] <- calcn[[i]][['nCount']] + ncalc[['nCount']][lcells]
ncalc[['nFeature']][lcells] <- calcn[[i]][['nFeature']] + ncalc[['nFeature']][lcells]
}
return(ncalc)
}
#' @method .CalcN default
#' @export
#'
.CalcN.default <- function(object, ...) {
return(list(
nCount = Matrix::colSums(x = object),
nFeature = Matrix::colSums(x = object > 0)
))
}
#' @param layer Name of layer to store \code{counts} as
#'
#' @rdname dot-CreateStdAssay
#' @method .CreateStdAssay default
#' @export
#'
.CreateStdAssay.default <- function(
counts,
min.cells = 0,
min.features = 0,
cells = NULL,
features = NULL,
transpose = FALSE,
type = 'Assay5',
layer = 'counts',
...
) {
if (!is_bare_integerish(x = dim(x = counts), n = 2L, finite = TRUE)) {
abort(message = "'counts' must be a two-dimensional object")
}
dnames <- dimnames(x = counts)
cls <- class(x = counts)
if (isTRUE(x = transpose)) {
csum <- .GetMethod(fxn = 'rowSums', cls = cls)
cells <- cells %||% dnames[[1L]]
fsum <- .GetMethod(fxn = 'colSums', cls = cls)
features <- features %||% dnames[[2L]]
} else {
csum <- .GetMethod(fxn = 'colSums', cls = cls)
cells <- cells %||% dnames[[2L]]
fsum <- .GetMethod(fxn = 'rowSums', cls = cls)
features <- features %||% dnames[[1L]]
}
counts <- list(counts)
names(x = counts) <- layer
return(.CreateStdAssay(
counts = counts,
min.cells = min.cells,
layer = layer,
min.features = min.features,
cells = cells,
features = features,
transpose = transpose,
type = type,
fsum = fsum,
csum = csum,
...
))
}
#' @param csum Function for calculating cell sums
#' @param fsum Function for calculating feature sums
#'
#' @importFrom methods getClass
#' @importFrom utils getS3method methods
#'
#' @rdname dot-CreateStdAssay
#' @method .CreateStdAssay list
#' @export
#'
.CreateStdAssay.list <- function(
counts,
min.cells = 0,
min.features = 0,
cells = NULL,
features = NULL,
transpose = FALSE,
type = 'Assay5',
csum = Matrix::colSums,
fsum = Matrix::rowSums,
...
) {
# Figure out feature/cell MARGINs
cdef <- getClass(Class = type)
contains <- names(x = slot(object = cdef, name = 'contains'))
if (!'StdAssay' %in% contains) {
stop("Class '", type, "' does not inherit from StdAssay")
}
for (i in c(type, contains, 'default')) {
fmargin <- getS3method(f = '.MARGIN', class = i, optional = TRUE)
if (is.function(x = fmargin)) {
break
}
}
cdim <- fmargin(object = type, type = 'cells')
fdim <- fmargin(object = type, type = 'features')
counts <- lapply(X = counts, FUN = function(x) {
x <- CheckFeaturesNames(data = x)
return(x)
})
# Check cell/feature names for all layers
if (is.atomic(x = cells) || is.null(x = cells)) {
cells <- rep_len(x = list(cells), length.out = length(x = counts))
}
if (!is_bare_list(x = cells) || length(x = cells) != length(x = counts)) {
stop("Not enough cells for the counts matrices provided", call. = FALSE)
}
cells <- .CheckNames(x = cells, n = names(x = counts))
if (is.atomic(x = features) || is.null(x = features)) {
features <- rep_len(x = list(features), length.out = length(x = counts))
}
if (!is_bare_list(x = features) || length(x = features) != length(x = counts)) {
stop("Not enough features for the counts matrices provided", call. = FALSE)
}
features <- .CheckNames(x = features, n = names(x = counts))
for (layer in names(x = counts)) {
cells[[layer]] <- cells[[layer]] %||%
dimnames(x = counts[[layer]])[[cdim]] %||%
paste0('Cell_', seq_len(length.out = dim(x = counts[[layer]])[cdim]))
features[[layer]] <- features[[layer]] %||%
dimnames(x = counts[[layer]])[[fdim]] %||%
paste0('Feature', seq_len(length.out = dim(x = counts[[layer]])[fdim]))
}
# Filter based on min.features
if (min.features > 0) {
for (layer in names(x = counts)) {
if (inherits(x = counts[[layer]], what = "IterableMatrix")) {
check_installed(pkg = 'BPCells', reason = 'for working with BPCells')
col_stat <- BPCells::matrix_stats(matrix = counts[[layer]], col_stats = 'nonzero')$col_stats
cells.use <- which(x = col_stat >= min.features)
} else {
cells.use <- which(x = csum(counts[[layer]] > 0) >= min.features)
}
counts[[layer]] <- if (cdim == 1L) {
counts[[layer]][cells.use, ]
} else {
counts[[layer]][, cells.use]
}
cells[[layer]] <- cells[[layer]][cells.use]
}
}
# For now, coerce to dgCMatrix if not dgCMatrix, IterableMatrix, or DelayedArray
if (!inherits(x = counts[[layer]], what = c('dgCMatrix', 'IterableMatrix', 'DelayedArray'))) {
warning('Data is of class ', class(counts[[layer]])[1], ". Coercing to dgCMatrix.",
call. = FALSE, immediate. = TRUE)
if (inherits(x = counts[[layer]], what = "data.frame")) {
counts[[layer]] <- as.sparse(x = counts[[layer]], ...)
} else {
counts[[layer]] <- as.sparse(x = counts[[layer]])
}
}
# Filter based on min.cells
if (min.cells > 0) {
for (layer in names(x = counts)) {
if (inherits(x = counts[[layer]], what = "IterableMatrix")) {
check_installed(pkg = 'BPCells', reason = 'for working with BPCells')
row_stat <- BPCells::matrix_stats(matrix = counts[[layer]], row_stats = 'nonzero')$row_stats
features.use <- which(x = row_stat >= min.cells)
} else {
features.use <- which(x = fsum(counts[[layer]] > 0) >= min.cells)
}
counts[[layer]] <- if (fdim == 1L) {
counts[[layer]][features.use, ]
} else {
counts[[layer]][, features.use]
}
features[[layer]] <- features[[layer]][features.use]
}
}
features.all <- Reduce(f = union, x = features)
cells.all <- Reduce(f = union, x = cells)
calcN_option <- getOption(
x = 'Seurat.object.assay.calcn',
default = Seurat.options$Seurat.object.assay.calcn
)
# Create the object
object <- new(
Class = type,
layers = list(),
default = 0L,
features = LogMap(y = features.all),
cells = LogMap(y = cells.all),
meta.data = EmptyDF(n = length(x = features.all)),
misc = list(calcN = calcN_option %||% TRUE),
...
)
for (layer in names(x = counts)) {
LayerData(
object = object,
layer = layer,
features = features[[layer]],
cells = cells[[layer]],
transpose = transpose
) <- counts[[layer]]
}
DefaultLayer(object = object) <- Layers(object = object)[1L]
validObject(object = object)
return(object)
}
#' @rdname dot-CreateStdAssay
#' @method .CreateStdAssay Matrix
#' @export
#'
.CreateStdAssay.Matrix <- function(
counts,
min.cells = 0,
min.features = 0,
cells = NULL,
features = NULL,
transpose = FALSE,
type = 'Assay5',
layer = 'counts',
...
) {
counts <- list(counts)
names(x = counts) <- layer
if (isTRUE(x = transpose)) {
csum <- Matrix::rowSums
fsum <- Matrix::colSums
} else {
csum <- Matrix::colSums
fsum <- Matrix::rowSums
}
return(.CreateStdAssay(
counts = counts,
layer = layer,
min.cells = min.cells,
min.features = min.features,
cells = cells,
features = features,
transpose = transpose,
type = type,
csum = csum,
fsum = fsum,
...
))
}
#' @rdname dot-CreateStdAssay
#' @method .CreateStdAssay matrix
#' @export
#'
.CreateStdAssay.matrix <- .CreateStdAssay.Matrix
#' @method .MARGIN Assay5T
#' @export
#'
.MARGIN.Assay5T <- function(x, type = c('features', 'cells'), ...) {
type <- type[1]
type <- match.arg(arg = type)
return(unname(obj = c(features = 2L, cells = 1L)[type]))
}
#' @method .SelectFeatures StdAssay
#' @export
#'
.SelectFeatures.StdAssay <- function(object, ...) {
.NotYetImplemented()
}
#' @templateVar fxn AddMetaData
#' @template method-stdassay
#'
#' @method AddMetaData StdAssay
#' @export
#'
AddMetaData.StdAssay <- AddMetaData.Assay
#' @rdname AddMetaData
#' @method AddMetaData Assay5
#' @export
#'
AddMetaData.Assay5 <- AddMetaData.StdAssay
#' @templateVar fxn CastAssay
#' @template method-stdassay
#'
#' @importFrom methods as
#' @importFrom rlang quo_get_env quo_get_expr
#'
#' @method CastAssay StdAssay
#' @export
#'
CastAssay.StdAssay <- function(object, to, layers = NA, verbose = TRUE, ...) {
layers <- Layers(object = object, search = layers)
if (is_quosure(x = to)) {
to <- eval(
expr = quo_get_expr(quo = to),
envir = quo_get_env(quo = to)
)
}
stopifnot(is.character(x = to) || is.function(x = to))
for (lyr in layers) {
if (isTRUE(x = verbose)) {
msg <- paste("Attempting to cast layer", lyr)
if (is.character(x = to)) {
msg <- paste(msg, "to", to)
}
message(msg)
}
clyr <- Cells(x = object, layer = lyr)
flyr <- Features(x = object, layer = lyr)
w <- function(e) {
warn(message = paste0(
"Unable to cast layer ",
sQuote(x = lyr),
": ",
e$message
))
return(invisible(x = NULL))
}
if (is.function(x = to)) {
tryCatch(
expr = LayerData(
object = object,
layer = lyr,
cells = clyr,
features = flyr
) <- to(LayerData(object = object, layer = lyr, fast = TRUE), ...),
error = w
)
} else {
check <- is(
object = LayerData(object = object, layer = lyr, fast = TRUE),
class2 = to
)
if (isTRUE(x = check)) {
next
}
tryCatch(
expr = LayerData(
object = object,
layer = lyr,
cells = clyr,
features = flyr
) <- as(
object = LayerData(object = object, layer = lyr, fast = TRUE),
Class = to
),
error = w
)
}
}
return(object)
}
#' @template param-verbose
#' @param layers A vector of layers to cast; defaults to all layers
#'
#' @rdname CastAssay
#' @method CastAssay Assay5
#' @export
#'
CastAssay.Assay5 <- CastAssay.StdAssay
#' @templateVar fxn Cells
#' @template method-stdassay
#'
#' @method Cells StdAssay
#' @export
#'
Cells.StdAssay <- function(x, layer = NULL, simplify = TRUE, ...) {
if (any(is.na(x = layer)) || is.null(x = layer)) {
return(rownames(x = slot(object = x, name = 'cells')))
}
layer <- Layers(object = x, search = layer)
cells <- sapply(
X = layer,
FUN = function(lyr) {
return(slot(object = x, name = 'cells')[[lyr]])
},
simplify = FALSE,
USE.NAMES = TRUE
)
if (isFALSE(x = simplify)) {
return(cells)
}
return(Reduce(f = union, x = cells))
}
#' @param layer Layer to pull cells/features for; defaults to default layer;
#' if \code{NA}, returns all cells for the assay
#' @param simplify Simplify the cell/feature names into a single vector; if
#' \code{FALSE}, separates each cell/feature names by layer
#'
#' @rdname Cells
#' @method Cells Assay5
#' @export
#'
Cells.Assay5 <- Cells.StdAssay
#' @templateVar fxn DefaultAssay
#' @template method-stdassay
#'
#' @method DefaultAssay StdAssay
#' @export
#'
DefaultAssay.StdAssay <- function(object, ...) {
return(slot(object = object, name = 'assay.orig'))
}
#' @rdname DefaultAssay
#' @method DefaultAssay Assay5
#' @export
#'
DefaultAssay.Assay5 <- DefaultAssay.StdAssay
#' @rdname DefaultAssay-StdAssay
#' @method DefaultAssay<- StdAssay
#' @export
#'
"DefaultAssay<-.StdAssay" <- function(object, ..., value) {
slot(object = object, name = 'assay.orig') <- value
return(object)
}
#' @rdname DefaultAssay
#' @method DefaultAssay<- Assay5
#' @export
#'
"DefaultAssay<-.Assay5" <- `DefaultAssay<-.StdAssay`
#' @templateVar fxn DefaultLayer
#' @template method-stdassay
#'
#' @method DefaultLayer StdAssay
#' @export
#'
DefaultLayer.StdAssay <- function(object, ...) {
idx <- slot(object = object, name = 'default')
if (!length(x = idx) || idx == 0L) {
idx <- 1L
}
return(Layers(object = object)[seq_len(length.out = idx)])
}
#' @rdname DefaultLayer
#' @method DefaultLayer Assay5
#' @export
#'
DefaultLayer.Assay5 <- DefaultLayer.StdAssay
#' @rdname DefaultLayer-StdAssay
#' @method DefaultLayer<- StdAssay
#' @export
#'
"DefaultLayer<-.StdAssay" <- function(object, ..., value) {
layers <- Layers(object = object)
value <- Layers(object = object, search = value)
idx <- MatchCells(new = layers, orig = value, ordered = TRUE)
slot(object = object, name = 'layers') <- c(
slot(object = object, name = 'layers')[idx],
slot(object = object, name = 'layers')[-idx]
)
slot(object = object, name = 'default') <- length(x = value)
validObject(object = object)
return(object)
}
#' @rdname DefaultLayer
#' @method DefaultLayer<- Assay5
#' @export
#'
"DefaultLayer<-.Assay5" <- `DefaultLayer<-.StdAssay`
#' @rdname Cells-StdAssay
#' @method Features StdAssay
#' @export
#'
Features.StdAssay <- function(x, layer = NULL, simplify = TRUE, ...) {
if (any(is.na(x = layer)) || is.null(x = layer)) {
return(rownames(x = slot(object = x, name = 'features')))
}
layer <- Layers(object = x, search = layer)
features <- sapply(
X = layer,
FUN = function(lyr) {
return(slot(object = x, name = 'features')[[lyr]])
},
simplify = FALSE,
USE.NAMES = TRUE
)
if (isFALSE(x = simplify)) {
return(features)
}
return(Reduce(f = union, x = features))
}
#' @rdname Cells
#' @method Features Assay5
#' @export
#'
Features.Assay5 <- Features.StdAssay
#' @method FetchData StdAssay
#' @export
#'
FetchData.StdAssay <- function(
object,
vars,
cells = NULL,
layer = NULL,
clean = TRUE,
...
) {
# Identify layer(s) to use
layer.set <- rev(x = Layers(
object = object,
search = layer %||% 'data'
))
if (is.null(layer) && length(layer.set) == 1 && layer.set == 'scale.data'){
warning('Default search for "data" layer yielded no results; utilizing "scale.data" layer instead.')
}
if (is.null(layer.set) & is.null(layer) ) {
warning('data layer is not found and counts layer is used')
layer.set <- rev(x = Layers(
object = object,
search = 'counts'
))
}
if (is.null(layer.set)) {
stop('layer "', layer,'" is not found in the object')
} else {
layer <- layer.set
}
# Identify cells to use
cells <- cells %||% colnames(x = object)
if (is.numeric(x = cells)) {
cells <- colnames(x = object)[cells]
}
cells <- intersect(x = cells, y = colnames(x = object))
if (!length(x = cells)) {
abort(message = "None of the cells requested found in this assay")
}
# Check vars
orig <- vars
vars <- gsub(
pattern = paste0('^', Key(object = object)),
replacement = '',
x = vars
)
# Pull expression information
features <- sapply(
X = layer,
FUN = Features,
x = object,
simplify = FALSE,
USE.NAMES = TRUE
)
vars <- intersect(x = vars, y = Reduce(f = union, x = features))
data.fetched <- as.data.frame(x = matrix(
data = NA_real_,
nrow = length(x = cells),
ncol = length(x = vars),
dimnames = list(cells, vars)
))
for (lyr in layer) {
lcells <- intersect(x = cells, y = Cells(x = object, layer = lyr))
lvars <- intersect(x = vars, y = Features(x = object, layer = lyr))
if (!length(x = lcells) || !length(x = lvars)) {
next
}
data.fetched[lcells, lvars] <- as(t(x = LayerData(
object = object,
layer = lyr,
cells = lcells,
features = lvars
)[lvars, lcells, drop = FALSE]),
"matrix")
}
# Clean out missing cells from the expression matrix
if (isTRUE(x = clean)) {
no.data <- which(x = apply(
X = data.fetched,
MARGIN = 1L,
FUN = function(x) {
return(all(is.na(x = x)))
}
))
if (length(x = no.data)) {
warn(message = paste(
"Removing",
length(x = no.data),
"cells missing data for features requested"
))
data.fetched <- data.fetched[-no.data, , drop = FALSE]
}
}
# Add keys to keyed vars
keyed.features <- paste0(Key(object = object), colnames(x = data.fetched))
keyed.idx <- which(x = keyed.features %in% orig)
if (length(x = keyed.idx)) {
colnames(x = data.fetched)[keyed.idx] <- keyed.features[keyed.idx]
}
# Check final list of features
fetched <- setdiff(x = unlist(x = dimnames(x = data.fetched)), y = cells)
missing <- setdiff(x = orig, y = fetched)
if (length(x = missing) == length(x = orig)) {
abort(message = "None of the requested variables found", class = 'varsNotFoundError')
} else if (length(x = missing)) {
warn(message = paste(
"The following variables could not be found:",
paste(missing, collapse = ', ')
))
}
return(data.fetched)
# # Pull feature-level metadata
# meta.fetch <- c(
# grep(pattern = '^md_', x = vars, value = TRUE),
# vars[vars %in% colnames(x = object[[]])]
# )
# meta.fetch <- setdiff(x = meta.fetch, y = colnames(x = data.fetched))
# meta.keyed <- which(x = grepl(pattern = '^md', x = meta.fetch))
# meta.fetch <- gsub(pattern = '^md_', replacement = '', x = meta.fetch)
# meta.data <- lapply(
# X = meta.fetch,
# FUN = function(x, f) {
# df <- as.data.frame(x = matrix(
# data = NA,
# nrow = 1L,
# ncol = length(x = f),
# dimnames = list(x, f)
# ))
# df[x, ] <- object[[x]][f, , drop = TRUE]
# return(df)
# },
# f = colnames(x = data.fetched)
# )
# meta.data <- do.call(what = 'rbind', args = meta.data)
# if (length(x = meta.keyed)) {
# rownames(x = meta.data)[meta.keyed] <- paste0(
# 'md_',
# rownames(x = meta.data)[meta.keyed]
# )
# }
# keyed.meta <- paste0(Key(object = object), rownames(x = meta.data))
# keyed.meta.idx <- which(x = keyed.meta %in% orig)
# if (length(x = keyed.meta.idx)) {
# rownames(x = meta.data)[keyed.meta.idx] <- keyed.meta[keyed.meta.idx]
# }
# if (nrow(x = data.fetched) && (nrow(x = meta.data) %||% 0)) {
# warning(
# "Returning both expression and meta data; data types might be different than expected",
# call. = FALSE,
# immediate. = TRUE
# )
# }
# data.fetched <- rbind(data.fetched, meta.data)
# # Add keys to keyed vars
# keyed.features <- paste0(Key(object = object), colnames(x = data.fetched))
# keyed.idx <- which(x = keyed.features %in% orig)
# if (length(x = keyed.idx)) {
# colnames(x = data.fetched)[keyed.idx] <- keyed.features[keyed.idx]
# }
# # Check final list of features
# fetched <- setdiff(x = unlist(x = dimnames(x = data.fetched)), y = cells)
# missing <- setdiff(x = orig, y = fetched)
# if (length(x = missing) == length(x = orig)) {
# stop("None of the requested variables found", call. = FALSE)
# } else if (length(x = missing)) {
# warning(
# "The following variables could not be found: ",
# paste(missing, collapse = ', '),
# call. = FALSE,
# immediate. = TRUE
# )
# }
# return(data.fetched)
}
#' @method FetchData Assay5
#' @export
#'
FetchData.Assay5 <- FetchData.StdAssay
#' @templateVar fxn AssayData
#' @template method-stdassay
#'
#' @method GetAssayData StdAssay
#' @export
#'
GetAssayData.StdAssay <- function(
object,
layer = NULL,
slot = deprecated(),
...
) {
CheckDots(..., fxns = LayerData)
if (is_present(arg = slot)) {
.Deprecate(
when = '5.0.0',
what = 'GetAssayData(slot = )',
with = 'GetAssayData(layer = )'
)
layer <- slot
}
layer_name <- layer[1L] %||% DefaultLayer(object = object)[1L]
layer.set <- suppressWarnings(expr = Layers(
object = object,
search = layer %||% 'data'
))
if (is.null(layer.set) & is.null(layer)) {
warning('data layer is not found and counts layer is used')
layer <- rev(x = Layers(
object = object,
search = 'counts'
))
} else {
layer <- layer.set
}
if (length(x = layer) > 1) {
abort("GetAssayData doesn't work for multiple layers in v5 assay.",
" You can run 'object <- JoinLayers(object = object, layers = layer)'.")
}
if (is.null(x = layer)) {
msg <- paste("Layer", sQuote(x = layer_name), "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_name,
scale.data = new(Class = "matrix"), new(Class = "dgCMatrix")
),
NULL))
}
return(LayerData(object = object, layer = layer, ...))
}
#' @templateVar fxn VariableFeatures
#' @template method-stdassay
#'
#' @importFrom utils adist
#'
#' @method HVFInfo StdAssay
#' @export
#'
HVFInfo.StdAssay <- function(
object,
method = NULL,
status = FALSE,
layer = NULL,
strip = TRUE,
...
) {
# Find available HVF methods and layers
vf.methods.layers <- .VFMethodsLayers(object = object, type = 'hvf')
#vf.methods <- .VFMethods(object = object, type = 'hvf')
#vf.layers <- .VFLayers(object = object, type = 'hvf')
# Determine which method and layer to use
method <- method[length(methods)] %||% names(vf.methods.layers[length(vf.methods.layers)])
method <- switch(
EXPR = tolower(x = method),
mean.var.plot = 'mvp',
dispersion = 'disp',
method
)
method <- tryCatch(
expr = match.arg(arg = method, choices = names(vf.methods.layers)),
error = function(...) {
return(NULL)
}
)
# If no methods found, return NULL
if (is.null(x = method)) {
return(method)
}
vf.methods.layers <- unlist(vf.methods.layers, use.names = FALSE)
layer <- Layers(object = object, search = layer)
layer <- vf.methods.layers[which.min(x = adist(x = layer, y = vf.methods.layers))]
# Find the columns for the specified method and layer
cols <- grep(
pattern = paste0(paste('^vf', method, layer, sep = '_'), '_'),
x = colnames(x = object[[]]),
value = TRUE
)
if (!isTRUE(x = status)) {
cols <- setdiff(
x = cols,
y = paste('vf', method, layer, c('variable', 'rank'), sep = '_')
)
}
hvf.info <- object[[cols]]
colnames(x = hvf.info) <- gsub(
pattern = '^vf_',
replacement = '',
x = colnames(x = hvf.info)
)
if (isTRUE(x = strip)) {
colnames(x = hvf.info) <- gsub(
pattern = paste0(paste(method, layer, sep = '_'), '_'),
replacement = '',
x = colnames(x = hvf.info)
)
}
return(hvf.info)
}
#' @param layer Layer to pull variable features for
#' @param strip Remove method/layer identifiers from highly variable data frame
#'
#' @rdname VariableFeatures
#' @method HVFInfo Assay5
#' @export
#'
HVFInfo.Assay5 <- HVFInfo.StdAssay
#' @method JoinLayers StdAssay
#' @export
#'
JoinLayers.StdAssay <- function(
object,
layers = NULL,
new = NULL,
...
) {
layers <- layers %||% c('counts', 'data', 'scale.data')
new <- new %||% layers
if (length(x = layers) != length(x = new)) {
stop('Number of layers and new should be the same')
}
var.features <- VariableFeatures(object = object)
for (i in seq_along(layers)) {
num.layers <- suppressWarnings(
expr = length(x = Layers(object = object, search = layers[i]))
)
if (num.layers > 0L) {
object <- JoinSingleLayers(
object = object,
layers = layers[i],
new = new[i],
default = TRUE,
...
)
}
}
VariableFeatures(object = object) <- var.features
return(object)
}
#' @param layers Names of layers to split or join
#' @param new Name of new layers
#'
#' @rdname SplitLayers
#'
#' @method JoinLayers Assay5
#' @export
#'
JoinLayers.Assay5 <- JoinLayers.StdAssay
#' @rdname Key
#' @method Key Assay5
#' @export
#'
Key.Assay5 <- .Key
#' @rdname Key
#' @method Key<- Assay5
#' @export
#'
"Key<-.Assay5" <- `.Key<-`
#' @templateVar fxn Layers
#' @template method-stdassay
#'
#' @method LayerData StdAssay
#' @export
#'
LayerData.StdAssay <- function(
object,
layer = NULL,
cells = NULL,
features = NULL,
fast = FALSE,
slot = deprecated(),
...
) {
if (is_present(arg = slot)) {
deprecate_stop(
when = '5.0.0',
what = 'LayerData(slot = )',
with = 'LayerData(layer = )"'
)
}
layer_name <- layer[1L] %||% DefaultLayer(object = object)[1L]
# Identify layer(s) to use
layer.set <- suppressWarnings(expr = Layers(
object = object,
search = layer %||% 'data'
))
# If layer.set doesnt return anything and layer is not defined
if (is.null(layer.set) & is.null(layer) ) {
warning(
'data layer is not found and counts layer is used',
call. = F,
immediate. = T
)
layer <- Layers(
object = object,
search = 'counts'
)
} else {
layer <- layer.set
}
if (length(x = layer) > 1) {
warning("multiple layers are identified by ",
paste0(layer, collapse = ' '),
"\n only the first layer is used")
layer <- layer[1L]
}
# layer <- match.arg(arg = layer, choices = Layers(object = object))
if (is.null(x = layer) || any(is.na(x = layer))) {
msg <- paste("Layer", sQuote(x = layer_name), "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_name,
scale.data = new(Class = "matrix"), new(Class = "dgCMatrix")
),
NULL))
}
# Allow cell/feature subsets
dnames <- list(
Features(x = object, layer = layer),
Cells(x = object, layer = layer)
)
cells <- cells %||% dnames[[2L]]
if (is.numeric(x = cells)) {
cells <- dnames[[2L]][cells]
}
cells <- sort(x = MatchCells(
new = dnames[[2L]],
orig = cells,
ordered = TRUE
))
dnames[[2L]] <- dnames[[2L]][cells]
features <- features %||% dnames[[1L]]
if (is.numeric(x = features)) {
features <- dnames[[1L]][features]
}
features <- sort(x = MatchCells(
new = dnames[[1L]],
orig = features,
ordered = TRUE
))
dnames[[1L]] <- dnames[[1L]][features]
if(length(x = dnames[[1L]]) == 0) {
stop('features are not found')
}
# Pull the layer data
ldat <- if (.MARGIN(x = object) == 1L) {
methods::slot(object = object, name = 'layers')[[layer]][features, cells, drop = FALSE]
} else {
methods::slot(object = object, name = 'layers')[[layer]][cells, features, drop = FALSE]
}
# Add dimnames and transpose if requested
ldat <- if (isTRUE(x = fast)) {
ldat
} else if (is_na(x = fast)) {
.GetLayerData2(x = ldat, dnames = dnames, fmargin = 1L)
# .GetLayerData(
# x = ldat,
# dnames = dnames,
# fmargin = 1L,
# ...
# )
} else {
.GetLayerData2(
x = ldat,
dnames = dnames,
fmargin = .MARGIN(x = object, type = 'features')
)
# .GetLayerData(
# x = ldat,
# dnames = dnames,
# fmargin = .MARGIN(x = object, type = 'features'),
# ...
# )
}
return(ldat)
}
#' @param features,cells Vectors of features/cells to include
#' @param fast Determine how to return the layer data; choose from:
#' \describe{
#' \item{\code{FALSE}}{Apply any transpositions and attempt to add
#' feature/cell names (if supported) back to the layer data}
#' \item{\code{NA}}{Attempt to add feature/cell names back to the layer data,
#' skip any transpositions}
#' \item{\code{TRUE}}{Do not apply any transpositions or add feature/cell
#' names to the layer data}
#' }
#'
#' @rdname Layers
#' @method LayerData Assay5
#' @export
#'
LayerData.Assay5 <- LayerData.StdAssay
#'
#' @rdname Layers-StdAssay
#' @method LayerData<- StdAssay
#' @export
#'
"LayerData<-.StdAssay" <- function(
object,
layer,
features = NULL,
cells = NULL,
...,
value
) {
if (!is_scalar_character(x = layer) || !nzchar(x = layer)) {
abort(message = "'layer' must be a single non-empty string")
}
# Remove a layer
if (is.null(x = value)) {
if (length(x = Layers(object = object)) == 1L) {
stop("Cannot remove only layer")
} else if (layer %in% DefaultLayer(object = object)) {
msg <- 'Removing default layer'
if (length(x = DefaultLayer(object = object)) == 1L) {
DefaultLayer(object = object) <- Layers(object = object)[2]
msg <- paste0(
msg,
', setting default to ', DefaultLayer(object = object)
)
} else {
didx <- slot(object = object, name = 'default') - 1L
slot(object = object, name = 'default') <- didx
}
warning(msg, call. = FALSE, immediate. = TRUE)
}
slot(object = object, name = 'layers')[[layer]] <- NULL
if (slot(object = object, name = 'default') > length(x = Layers(object = object)) ||
!length(x = slot(object = object, name = 'default'))) {
slot(object = object, name = 'default') <- length(x = Layers(object = object))
}
maps <- c(
'cells',
'features'
)
for (i in maps) {
slot(object = object, name = i)[[layer]] <- NULL
}
validObject(object = object)
return(object)
}
# Add a layer
fdim <- .MARGIN(x = object, type = 'features')
cdim <- .MARGIN(x = object, type = 'cells')
# Assume input matrix is features x cells
dnames <- list(
features %||% dimnames(x = value)[[1L]],
cells %||% dimnames(x = value)[[2L]]
)
if (length(x = unique(x = dim(x = value))) > 1L) {
didx <- match(
x = vapply(
X = dnames,
FUN = length,
FUN.VALUE = numeric(length = 1L),
USE.NAMES = FALSE
),
table = dim(x = value)
)
dnames <- dnames[didx]
}
value <- .PrepLayerData2(
x = value,
target = dim(x = object),
dnames = dnames,
fmargin = fdim,
...
)
# value <- .PrepLayerData(
# x = value,
# target = dim(x = object),
# dnames = dnames,
# fmargin = fdim,
# ...
# )
# Check features and cells
features <- attr(x = value, which = 'features') %||% seq_len(length.out = dim(x = value)[fdim])
cells <- attr(x = value, which = 'cells') %||% seq_len(length.out = dim(x = value)[cdim])
fmatch <- MatchCells(
new = features,
orig = rownames(x = slot(object = object, name = 'features')),
ordered = TRUE
)
cmatch <- MatchCells(
new = cells,
orig = rownames(x = slot(object = object, name = 'cells')),
ordered = TRUE
)
if (is.null(x = fmatch)) {
stop(
"No feature overlap between existing object and new layer data",
call. = FALSE
)
} else if (is.null(x = cmatch)) {
stop(
"No cell overlap between existing object and new layer data",
call. = FALSE
)
}
features <- features[fmatch]
cells <- cells[cmatch]
# Check for existing layer data
if (layer %in% Layers(object = object)) {
fcheck <- if (is.numeric(x = features)) {
Features(x = object, layer = layer)[features]
} else {
features
}
ccheck <- if (is.numeric(x = cells)) {
Cells(x = object, layer = layer)[cells]
} else {
cells
}
if (!identical(x = fcheck, y = Features(x = object, layer = layer))) {
warning(
"Different features in new layer data than already exists for ",
layer,
call. = FALSE,
immediate. = TRUE
)
}
if (!identical(x = ccheck, y = Cells(x = object, layer = layer))) {
warning(
"Different cells in new layer data than already exists for ",
layer,
call. = FALSE,
immediate. = TRUE
)
}
}
# Reorder the layer data
value <- if (fdim == 1L) {
value[fmatch, cmatch]
} else {
value[cmatch, fmatch]
}
# Add the layer
slot(object = object, name = 'layers')[[layer]] <- value
# Update the maps
slot(object = object, name = 'features')[[layer]] <- features
slot(object = object, name = 'cells')[[layer]] <- cells
validObject(object = object)
return(object)
}
#' @rdname Layers
#' @method LayerData<- Assay5
#' @export
#'
"LayerData<-.Assay5" <- `LayerData<-.StdAssay`
#' @rdname Layers-StdAssay
#' @method Layers StdAssay
#' @export
#'
Layers.StdAssay <- function(object, search = NA, ...) {
if (is.null(x = search)) {
return(DefaultLayer(object = object))
}
layers <- names(x = slot(object = object, name = 'layers'))
if (!is_na(x = search)) {
layers <- unique(x = unlist(x = lapply(
X = search,
FUN = function(lyr) {
if (lyr %in% layers) {
return(lyr)
}
patterns <- c(paste0('^', lyr), paste0(lyr, '$'), lyr)
res <- vector(mode = 'character')
for (p in patterns) {
res <- grep(pattern = p, x = layers, value = TRUE, ...)
if (length(x = res)) {
break
}
}
return(res)
}
)))
if (!length(x = layers)) {
warning(message = "No layers found matching search pattern provided",
call. = FALSE,
immediate. = TRUE)
return(NULL)
}
}
return(layers)
}
#' @param search A pattern to search layer names for; pass one of:
#' \itemize{
#' \item \dQuote{\code{NA}} to pull all layers
#' \item \dQuote{\code{NULL}} to pull the default layer(s)
#' \item a \link[base:grep]{regular expression} that matches layer names
#' }
#'
#' @rdname Layers
#' @method Layers Assay5
#' @export
#'
Layers.Assay5 <- Layers.StdAssay
#' @templateVar fxn Misc
#' @template method-stdassay
#'
#' @method Misc StdAssay
#' @export
#'
Misc.StdAssay <- .Misc
#' @rdname Misc
#' @method Misc Assay5
#' @export
#'
Misc.Assay5 <- .Misc
#' @templateVar fxn Misc
#' @template method-stdassay
#'
#' @method Misc<- StdAssay
#' @export
#'
"Misc<-.StdAssay" <- `.Misc<-`
#' @rdname Misc
#' @method Misc<- Assay5
#' @export
#'
"Misc<-.Assay5" <- `.Misc<-`
#' @templateVar fxn RenameCells
#' @template method-stdassay
#'
#' @method RenameCells StdAssay
#' @export
#'
RenameCells.StdAssay <- function(object, new.names = NULL, ...) {
CheckDots(...)
colnames(object) <- new.names[colnames(object)]
return(object)
}
#' @rdname RenameCells
#' @method RenameCells Assay5
#' @export
#'
RenameCells.Assay5 <- RenameCells.StdAssay
#' @rdname AssayData-StdAssay
#' @method SetAssayData StdAssay
#' @export
#'
SetAssayData.StdAssay <- function(
object,
layer,
new.data,
slot = deprecated(),
...
) {
if (is_present(arg = slot)) {
.Deprecate(
when = '5.0.0',
what = 'SetAssayData(slot = )',
with = 'SetAssayData(layer = )'
)
layer <- slot
}
LayerData(object = object, layer = layer) <- new.data
return(object)
}
#' @rdname VariableFeatures-StdAssay
#' @method VariableFeatures StdAssay
#' @export
#'
VariableFeatures.StdAssay <- function(
object,
method = NULL,
layer = NA,
simplify = TRUE,
nfeatures = Inf,
selection.method = deprecated(),
...
) {
if (is_present(arg = selection.method)) {
.Deprecate(
when = '5.0.0',
what = 'VariableFeatures(selection.method = )',
with = 'VariableFeatures(method = )'
)
method <- selection.method
}
nfeatures <- nfeatures %||% Inf
if ("var.features" %in% colnames(object[[]])) {
if ("var.features.rank" %in% colnames(object[[]])) {
var.features <- row.names(x = object[[]])[which(!is.na(object[[]]$var.features.rank))]
var.features <- var.features[order(object[[]][["var.features.rank"]][which(!is.na(object[[]]$var.features))])]
}
else {
var.features <- as.vector(object["var.features", drop = TRUE])
var.features <- var.features[!is.na(var.features)]
}
if (isTRUE(x = simplify) & (is.null(x = layer) || any(is.na(x = layer))) &
(is.infinite(x = nfeatures) || length(x = var.features) ==
nfeatures)) {
return(var.features)
}
}
msg <- 'No variable features found'
layer.orig <- layer
methods <- .VFMethodsLayers(object = object, type = 'hvf', layers = layer)
layer <- Layers(object = object, search = layer)
method <- method %||% names(x = methods)[length(x = methods)]
method <- match.arg(arg = method, choices = names(x = methods))
if (is_na(x = layer.orig) || is.null(x = layer.orig)) {
layer <- unlist(methods[method], use.names = FALSE)
}
vf <- sapply(
X = layer,
FUN = function(lyr) {
hvf.info <- HVFInfo(
object = object,
method = method,
layer = lyr,
status = TRUE,
strip = TRUE
)
if (is.null(x = hvf.info)) {
return(NULL)
} else if (!'variable' %in% names(x = hvf.info)) {
return(NA)
}
vf <- row.names(x = hvf.info)[which(x = hvf.info$variable)]
if ('rank' %in% names(x = hvf.info)) {
vf <- vf[order(hvf.info$rank[which(x = hvf.info$variable)])]
} else {
warn(message = paste0(
"No variable feature rank found for ",
sQuote(x = lyr),
", returning features in assay order"
))
}
},
simplify = FALSE,
USE.NAMES = TRUE
)
if (is.null(x = unlist(x = vf))) {
return(NULL)
} else if (all(is.na(x = unlist(x = vf)))) {
abort(message = msg)
}
if (isTRUE(x = simplify)) {
vf <- .SelectFeatures(
object = vf,
all.features = intersect(
x = slot(object = object, name = 'features')[,layer]
),
nfeatures = nfeatures
)
}
return(vf)
# hvf.info <- HVFInfo(
# object = object,
# method = method,
# layer = layer,
# status = TRUE,
# strip = TRUE
# )
# if (is.null(x = hvf.info)) {
# warning(msg, call. = FALSE, immediate. = TRUE)
# return(NULL)
# }
# if (!'variable' %in% names(x = hvf.info)) {
# stop(msg, call. = FALSE)
# }
# vf <- rownames(x = hvf.info)[which(x = hvf.info$variable)]
# if ('rank' %in% names(x = hvf.info)) {
# vf <- vf[order(hvf.info$rank[which(x = hvf.info$variable)])]
# } else {
# warning(
# "No variable feature rank found, returning features in assay order",
# call. = FALSE,
# immediate. = TRUE
# )
# }
# return(vf)
}
#' @param simplify When pulling for multiple layers, combine into a single
#' vector and select a common set of variable features for all layers
#' @param nfeatures Maximum number of features to select when simplifying
#'
#' @rdname VariableFeatures
#' @method VariableFeatures Assay5
#' @export
#'
VariableFeatures.Assay5 <- VariableFeatures.StdAssay
#' @rdname VariableFeatures-StdAssay
#' @method VariableFeatures<- StdAssay
#' @export
#'
"VariableFeatures<-.StdAssay" <- function(
object,
method = 'custom',
layer = NULL,
...,
value
) {
if (!length(x = value)) {
return(object)
}
value <- intersect(x = value, y = rownames(x = object))
if (!length(x = value)) {
stop("None of the features specified are present in this assay", call. = FALSE)
}
object[['var.features']] <- value
# add rank
object[['var.features.rank']] <- NA
object[[]][row.names(object[[]]) %in% value,]$var.features.rank <- match(row.names(object[[]])[row.names(object[[]]) %in% value], value)
# layer <- Layers(object = object, search = layer)
# df <- data.frame(TRUE, seq_along(along.with = value), row.names = value)
# for (lyr in layer) {
# names(x = df) <- paste('vf', method, lyr, c('variable', 'rank'), sep = '_')
# object[] <- df
# }
return(object)
}
#' @rdname VariableFeatures
#' @method VariableFeatures<- Assay5
#' @export
#'
"VariableFeatures<-.Assay5" <- `VariableFeatures<-.StdAssay`
#' @method WhichCells StdAssay
#' @export
#'
WhichCells.StdAssay <- WhichCells.Assay
# WhichCells.StdAssay <- function(
# object,
# cells = NULL,
# expression = missing_arg(),
# invert = FALSE,
# ...
# ) {
# cells <- cells %||% colnames(x = object)
# if (!is_missing(x = expression) && !is.null(x = substitute(expr = expression))) {
# key.pattern <- paste0('^', Key(object = object))
# expr <- if (tryCatch(expr = is_quosure(x = expression), error = \(...) 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
# )
# }
# if (isTRUE(x = invert)) {
# cells <- setdiff(x = colnames(x = object), y = cells)
# }
# cells <- ''
# return(as.character(x = cells))
# }
#' @method WhichCells Assay5
#' @export
#'
WhichCells.Assay5 <- WhichCells.StdAssay
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for R-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' @inherit .DollarNames.Assay5 params return title description details sections
#'
#' @importFrom utils .DollarNames
#'
#' @keywords internal
#' @method .DollarNames StdAssay
#' @export
#'
#' @family stdassay
#'
.DollarNames.StdAssay <- function(x, pattern = '') {
layers <- as.list(x = Layers(object = x))
names(x = layers) <- unlist(x = layers)
return(.DollarNames(x = layers, pattern = pattern))
}
#' Dollar-sign Autocompletion
#'
#' Autocompletion for \code{$} access on an \code{\link{Assay5}} object
#'
#' @inheritParams [.Assay5
#' @inheritParams utils::.DollarNames
#'
#' @return The layer name matches for \code{pattern}
#'
#' @importFrom utils .DollarNames
#'
#' @keywords internal
#'
#' @method .DollarNames Assay5
#' @export
#'
#' @concept assay5
#'
#' @seealso \code{\link[utils:.DollarNames]{utils::.DollarNames}}
#'
.DollarNames.Assay5 <- .DollarNames.StdAssay
#' @inherit $.Assay5 params return title description details sections
#'
#' @keywords internal
#' @method $ StdAssay
#' @export
#'
#' @family stdassay
#'
"$.StdAssay" <- function(x, i) {
return(LayerData(object = x, layer = i))
}
#' Layer Data
#'
#' Get and set layer data
#'
#' @inheritParams [.Assay5
#'
#' @return {$}: Layer data for layer \code{i}
#'
#' @method $ Assay5
#' @export
#'
#' @family assay5
#'
"$.Assay5" <- `$.StdAssay`
#' @rdname cash-.StdAssay
#'
#' @method $<- StdAssay
#' @export
#'
"$<-.StdAssay" <- `$<-.Assay`
#' @return \code{$<-}: \code{x} with layer data \code{value} saved as \code{i}
#'
#' @rdname cash-.Assay5
#'
#' @method $<- Assay5
#' @export
#'
"$<-.Assay5" <- `$<-.StdAssay`
#' @inherit [.Assay5 params return title description details sections
#'
#' @keywords internal
#' @method [ StdAssay
#' @export
#'
#' @family stdassay
#'
"[.StdAssay" <- `[.Assay`
#' Layer Data
#'
#' Get and set layer data
#'
#' @inheritParams [[.Assay5
#' @param i Name of layer data to get or set
#' @param ... Arguments passed to \code{\link{LayerData}}
#'
#' @return \code{[}: The layer data for layer \code{i}
#'
#' @method [ Assay5
#' @export
#'
#' @family assay5
#'
#' @seealso \code{\link{LayerData}}
#'
#' @order 1
#'
"[.Assay5" <- `[.StdAssay`
#' @inherit [[.Assay5 params return title description details sections
#'
#' @keywords internal
#' @method [[ StdAssay
#' @export
#'
#' @family stdassay
#'
"[[.StdAssay" <- function(x, i, j, ..., drop = FALSE) {
if (missing(x = i)) {
i <- colnames(x = slot(object = x, name = 'meta.data'))
}
data.return <- slot(object = x, name = 'meta.data')[, i, drop = FALSE, ...]
if (nrow(x = data.return) == 0) {
return(data.return)
}
row.names(x = data.return) <- rownames(x = x)
if (isTRUE(x = 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)
}
#' Feature-Level Meta Data
#'
#' Get and set feature-level meta data
#'
#' @param x An \code{\link{Assay5}} object
#' @param i Name of feature-level meta data to fetch or add
#' @param j Ignored
#' @param drop See \code{\link{drop}}
#' @template param-dots-ignored
#'
#' @return \code{[[}: The feature-level meta data for \code{i}
#'
#' @method [[ Assay5
#' @export
#'
#' @family assay5
#'
#' @order 1
#'
"[[.Assay5" <- `[[.StdAssay`
#' @inherit dim.Assay5 params return title description details sections
#'
#' @keywords internal
#' @method dim StdAssay
#' @export
#'
#' @family stdassay
#'
dim.StdAssay <- function(x) {
return(vapply(
X = c('features', 'cells'),
FUN = function(s) {
return(nrow(x = slot(object = x, name = s)))
},
FUN.VALUE = numeric(length = 1L),
USE.NAMES = FALSE
))
}
#' Feature and Cell Numbers
#'
#' @inheritParams [[.Assay5
#'
#' @return A two-length numeric vector with the total number of
#' features and cells in \code{x}
#'
#' @method dim Assay5
#' @export
#'
#' @family assay5
#'
dim.Assay5 <- dim.StdAssay
#' @inherit dimnames.Assay5 params return title description details sections
#'
#' @keywords internal
#' @method dimnames StdAssay
#' @export
#'
#' @seealso \code{\link{Cells}} \code{\link{Features}}
#' @family stdassay
#'
dimnames.StdAssay <- function(x) {
return(list(Features(x = x, layer = NA), Cells(x = x, layer = NA)))
}
#' Assay-Level Feature and Cell Names
#'
#' Get and set feature and cell names in v5 Assays
#'
#' @inheritParams [[.Assay5
#'
#' @return \code{dimnames}: A two-length list with the following values:
#' \itemize{
#' \item A character vector with all features in \code{x}
#' \item A character vector with all cells in \code{x}
#' }
#'
#' @method dimnames Assay5
#' @export
#'
#' @family assay5
#' @family dimnames
#'
dimnames.Assay5 <- dimnames.StdAssay
#' @rdname dimnames.StdAssay
#'
#' @method dimnames<- StdAssay
#' @export
#'
"dimnames<-.StdAssay" <- function(x, value) {
msg <- "Invalid 'dimnames' given for an assay"
if (!is_bare_list(x = value, n = 2L)) {
stop(msg, call. = FALSE)
} else if (!all(sapply(X = value, FUN = length) == dim(x = x))) {
stop(msg, call. = FALSE)
}
value <- lapply(X = value, FUN = as.character)
rownames(x = slot(object = x, name = 'features')) <- value[[1L]]
rownames(x = slot(object = x, name = 'cells')) <- value[[2L]]
validObject(object = x)
return(x)
}
#' @param value A two-length list with updated feature and/or cells names
#'
#' @return \code{dimnames<-}: \code{x} with the feature and/or cell
#' names updated to \code{value}
#'
#' @rdname dimnames.Assay5
#'
#' @method dimnames<- Assay5
#' @export
#'
"dimnames<-.Assay5" <- `dimnames<-.StdAssay`
#' @rdname sub-sub-.StdAssay
#'
#' @method head StdAssay
#' @export
#'
head.StdAssay <- head.Assay
#' @param n Number of meta data rows to show
#'
#' @return \code{head}: The first \code{n} rows of feature-level meta data
#'
#' @rdname sub-sub-.Assay5
#'
#' @method head Assay5
#' @export
#'
head.Assay5 <- head.StdAssay
#' @inherit merge.Assay5 params return title description details sections
#'
#' @note All assays must be of the same type; merging different v5 assays (eg.
#' \code{\link{Assay5}} and \code{\link{Assay5T}}) is currently unsupported
#'
#' @keywords internal
#' @method merge StdAssay
#' @export
#'
merge.StdAssay <- function(
x,
y,
labels = NULL,
add.cell.ids = NULL,
collapse = FALSE,
...
) {
assays <- c(x, y)
for (i in seq_along(assays)) {
if (inherits(x = assays[[i]], what = 'Assay')) {
assays[[i]] <- as(object = assays[[i]], Class = "Assay5") # TODO: support Assay5T
}
}
labels <- labels %||% as.character(x = seq_along(along.with = assays))
# add.cell.ids <- add.cell.ids %||% labels
# TODO: Support collapsing layers
if (isTRUE(x = collapse)) {
abort(message = "Collapsing layers is not yet supported")
}
for (i in seq_along(along.with = assays)) {
if (is_na(x = labels[i])) {
labels[i] <- as.character(x = i)
}
if (is_na(x = add.cell.ids[i])) {
add.cell.ids[i] <- as.character(x = i)
}
if (!is.null(x = add.cell.ids[i])) {
colnames(x = assays[[i]]) <- paste(
colnames(x = assays[[i]]),
add.cell.ids[i], sep = '.'
)
}
}
features.all <- LogMap(y = Reduce(
f = union,
x = lapply(X = assays, FUN = rownames)
))
combined <- new(
Class = class(x = x),
layers = list(),
cells = LogMap(y = Reduce(
f = union,
x = lapply(X = assays, FUN = colnames)
)),
features = features.all,
meta.data = EmptyDF(n = nrow(x = features.all)),
misc = list(),
key = Key(object = x) %||% character(length = 0L)
)
# Add layers
# TODO: Support collapsing layers
if (isTRUE(x = collapse)) {
abort(message = "Collapsing layers is not yet supported")
} else {
# Get default layer as default of first assay
default <- DefaultLayer(assays[[1]])
for (i in seq_along(along.with = assays)) {
for (lyr in Layers(object = assays[[i]])) {
LayerData(
object = combined,
layer = paste(lyr, labels[i], sep = '.'),
features = Features(x = assays[[i]], layer = lyr),
cells = Cells(x = assays[[i]], layer = lyr)
) <- LayerData(object = assays[[i]], layer = lyr, fast = TRUE)
}
}
}
# Add feature-level metadata
for (i in seq_along(along.with = assays)) {
# Rename HVF columns
mf <- assays[[i]][[]]
if (!ncol(x = mf)) {
next
}
for (type in c('vf')) {
vf.idx <- grep(pattern = paste0('^', type, '_'), x = names(x = mf))
if (length(x = vf.idx)) {
names(x = mf)[vf.idx] <- vapply(
X = names(x = mf)[vf.idx],
FUN = function(vf) {
vf <- unlist(x = strsplit(x = vf, split = '_'))
vf <- paste(
paste(vf[1:2], collapse = '_'),
paste(
paste(vf[3:(length(x = vf) - 1L)], collapse = '_'),
labels[i],
sep = '.'
),
vf[length(x = vf)],
sep = '_'
)
},
FUN.VALUE = character(length = 1L)
)
}
}
combined[[]] <- mf
}
# TODO: Add misc
DefaultLayer(combined) <- Layers(object = combined, search = default)
validObject(object = combined)
return(combined)
}
#' Merge Assays
#'
#' Merge one or more v5 assays together
#'
#' \strong{Note}: collapsing layers is currently not supported
#'
#' @inheritParams [.Assay5
#' @template param-dots-ignored
#' @param y One or more \code{\link{Assay5}} objects
#' @param labels A character vector equal to the number of objects; defaults to
#' \code{as.character(seq_along(c(x, y)))}
#' @param add.cell.ids A character vector equal to the number of objects
#' provided to append to all cell names; if \code{TRUE}, uses \code{labels} as
#' \code{add.cell.ids}
#' @param collapse If \code{TRUE}, merge layers of the same name together; if
#' \code{FALSE}, appends \code{labels} to the layer name
#'
#' @return A new v5 assay with data merged from \code{c(x, y)}
#'
#' @method merge Assay5
#' @export
#'
#' @family assay5
#'
merge.Assay5 <- merge.StdAssay
#' @inherit split.Assay5 params return title description details sections
#'
#' @keywords internal
#' @method split StdAssay
#' @export
#'
#' @family stdassay
#'
split.StdAssay <- function(
x,
f,
drop = FALSE,
layers = c("counts", "data"),
ret = c('assay', 'multiassays', 'layers'),
...
) {
op <- options(Seurat.object.assay.brackets = 'v5')
on.exit(expr = options(op))
ret <- ret[1L]
ret <- match.arg(arg = ret)
layers.to.split <- Layers(object = x, search = layers)
if (!identical(Layers(object = x), layers.to.split)) {
message(
'Splitting ',
paste(sQuote(x = layers.to.split), collapse = ', '),
' layers. Not splitting ',
paste(
sQuote(x = setdiff(Layers(object = x), layers.to.split)),
collapse = ', '
),
'. If you would like to split other layers, set in `layers` argument.'
)
}
layers <- Layers(object = x, search = layers)
layers.split <- list()
for (i in seq_along(along.with = layers)) {
if (length(x = colnames(x = x[layers[i]])) != length(x = colnames(x = x))) {
layers.split[[i]] <- layers[i]
}
}
layers.split <- unlist(x = layers.split)
if (length(x = layers.split)) {
abort(message = paste(
strwrap(x = paste(
"The following layers are already split:",
paste(sQuote(x = layers.split), collapse = ', '),
"\nPlease join before splitting"
))
))
}
default <- ifelse(
test = DefaultLayer(object = x) %in% layers,
yes = DefaultLayer(object = x),
no = layers[1L]
)
cells <- Cells(x = x, layer = layers)
if (is_named(x = f)) {
f <- f[cells]
}
if (length(x = f) != length(x = cells)) {
abort(message = "Not enough splits for this assay")
}
if (any(is.na(x = f))) {
f <- factor(x = f, levels = c(unique(as.character(f)), 'na'))
f[is.na(x = f)] <- 'na'
} else {
f <- factor(x = f, levels = unique(x = as.character(x = f)))
}
splits <- split(x = cells, f = f, drop = drop)
names(x = splits) <- .MakeNames(x = names(x = splits))
return(switch(
EXPR = ret,
assay = {
for (lyr in layers) {
p <- progressor(steps = length(x = splits))
p(
message = paste(
'Splitting layer',
sQuote(x = lyr),
'into',
length(x = splits),
'splits'
),
class = 'sticky',
amount = 0
)
lcells <- Cells(x = x, layer = lyr)
for (i in seq_along(along.with = splits)) {
p(
message = paste(
'Creating split for',
sQuote(x = names(x = splits)[i])
),
class = 'sticky',
amount = 0
)
group <- paste(lyr, names(x = splits)[i], sep = '.')
xcells <- intersect(x = splits[[i]], y = lcells)
LayerData(object = x, layer = group, cells = xcells) <- LayerData(
object = x,
layer = lyr,
cells = xcells
)
p()
}
p(type = 'finish')
suppressWarnings(expr = LayerData(object = x, layer = lyr) <- NULL)
DefaultLayer(object = x) <- default
}
x
},
multiassays = {
value <- vector(mode = 'list', length = length(x = splits))
names(x = value) <- names(x = splits)
for (group in names(x = splits)) {
value[[group]] <- subset(
x = x,
cells = splits[[group]],
layers = layers
)
Key(object = value[[group]]) <- Key(object = group, quiet = TRUE)
}
value
},
layers = {
groups <- apply(
X = expand.grid(layers, names(x = splits)),
MARGIN = 1L,
FUN = paste,
collapse = '.'
)
value <- vector(mode = 'list', length = length(x = groups))
names(x = value) <- groups
for (lyr in layers) {
lcells <- Cells(x = x, layer = lyr)
for (i in seq_along(along.with = splits)) {
group <- paste(lyr, names(x = splits)[i], sep = '.')
xcells <- intersect(x = splits[[i]], y = lcells)
value[[group]] <- LayerData(object = x, layer = lyr, cells = xcells)
}
}
value
},
abort(message = paste("Unknown split return type", sQuote(x = ret)))
))
}
#' Split an Assay
#'
#' @inheritParams [.Assay5
#' @inheritParams base::split
#' @param layers Names of layers to include in the split; pass \code{NA} for
#' all layers; pass \code{NULL} for the \link[=DefaultLayer]{default layer}
#' @param ret Type of return value; choose from:
#' \itemize{
#' \item \dQuote{\code{assay}}: a single \code{\link{Assay5}} object
#' \item \dQuote{\code{multiassay}}: a list of \code{\link{Assay5}} objects
#' \item \dQuote{\code{layers}}: a list of layer matrices
#' }
#' @template param-dots-ignored
#'
#' @return Depends on the value of \code{ret}:
#' \itemize{
#' \item \dQuote{\code{assay}}: \code{x} with the layers requested in
#' \code{layers} split based on \code{f}; all other layers are left as-is
#' \item \dQuote{\code{multiassay}}: a list of \code{\link{Assay5}} objects;
#' the list contains one value per split and each assay contains only the
#' layers requested in \code{layers} with the \link[=Key]{key} set to the split
#' \item \dQuote{\code{layers}}: a list of matrices of length
#' \code{length(assays) * length(unique(f))}; the list is named as
#' \dQuote{\code{layer.split}}
#' }
#'
#' @method split Assay5
#' @export
#'
#' @family assay5
#'
#' @template section-progressr
#'
split.Assay5 <- split.StdAssay
#' @inherit subset.Assay5 params return title description details sections
#'
#' @keywords internal
#' @method subset StdAssay
#' @export
#'
#' @family stdassay
#'
subset.StdAssay <- function(
x,
cells = NULL,
features = NULL,
layers = NULL,
...
) {
if (is.null(x = cells) && is.null(x = features)) {
return(x)
}
# Check the cells vector
if (all(is.na(x = cells))) {
cells <- Cells(x = x, layer = NA)
} else if (any(is.na(x = cells))) {
warning(
"NAs passed in cells vector, removing NAs",
call. = FALSE,
immediate. = TRUE
)
cells <- cells[!is.na(x = cells)]
}
if (is.numeric(x = cells)) {
cells <- Cells(x = x, layer = NA)[cells]
}
cells <- intersect(x = Cells(x = x, layer = NA), y = cells)
if (!length(x = cells)) {
stop("None of the cells provided found in this assay", call. = FALSE)
}
# Check the features vector
if (all(is.na(x = features))) {
features <- Features(x = x, layer = NA)
} else if (any(is.na(x = features))) {
warning(
"NAs passed in features vector, removing NAs",
call. = FALSE,
immediate. = TRUE
)
features <- features[!is.na(x = features)]
}
if (is.numeric(x = features)) {
features <- Features(x = x, layer = NA)[features]
}
features <- intersect(x = features, y = Features(x = x, layer = NA))
if (!length(x = features)) {
stop("None of the features provided found in this assay", call. = FALSE)
}
# Check the layers
layers.all <- Layers(object = x)
layers <- layers %||% layers.all
layers <- match.arg(
arg = layers,
choices = layers.all,
several.ok = TRUE
)
# Remove unused layers
for (lyr in setdiff(x = layers.all, y = layers)) {
LayerData(object = x, layer = lyr) <- NULL
}
# Subset feature-level metadata
mfeatures <- MatchCells(
new = Features(x = x, layer = NA),
orig = features,
ordered = TRUE
)
# Perform the subsets
for (l in layers) {
lcells <- MatchCells(
new = Cells(x = x, layer = l),
orig = cells,
ordered = TRUE
)
lfeatures <- MatchCells(
new = Features(x = x, layer = l),
orig = features,
ordered = TRUE
)
if (is.null(x = lcells) || is.null(x = features)) {
LayerData(object = x, layer = l) <- NULL
} else {
LayerData(object = x, layer = l) <- LayerData(
object = x,
layer = l,
cells = lcells,
features = lfeatures
)
}
}
slot(object = x, name = 'cells') <- droplevels(x = slot(
object = x,
name = 'cells'
))
# Update the cell/feature maps
for (i in c('cells', 'features')) {
slot(object = x, name = i) <- droplevels(x = slot(object = x, name = i))
}
slot(object = x, name = 'meta.data') <- slot(
object = x,
name = 'meta.data'
)[mfeatures, , drop = FALSE]
validObject(object = x)
return(x)
}
#' Subset an Assay
#'
#' @inheritParams [[.Assay5
#' @param cells Cell names
#' @param features Feature names
#' @param layers Layer to keep; defaults to all layers
#'
#' @return \code{x} with just the cells and features specified by
#' \code{cells} and \code{features} for the layers specified by \code{layers}
#'
#' @method subset Assay5
#' @export
#'
#' @family assay5
#'
subset.Assay5 <- subset.StdAssay
#' @rdname sub-sub-.StdAssay
#'
#' @method tail StdAssay
#' @export
#'
tail.StdAssay <- tail.Assay
#' @return \code{tail}: the last \code{n} rows of feature-level meta data
#'
#' @rdname sub-sub-.Assay5
#'
#' @method tail Assay5
#' @export
#'
tail.Assay5 <- tail.StdAssay
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Internal
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
.VFLayers <- function(
object,
type = c('hvf', 'svf'),
layers = NA,
missing = FALSE
) {
type <- type[1L]
type <- match.arg(arg = type)
pattern <- switch(
EXPR = type,
'hvf' = '^vf_',
stop("Unknown type: '", type, "'", call. = FALSE)
)
vf.cols <- grep(
pattern = paste0(pattern, '[[:alnum:]]+_'),
x = colnames(x = object[[]]),
value = TRUE
)
vf.layers <- unique(x = unlist(x = lapply(
X = strsplit(x = vf.cols, split = '_'),
FUN = function(x) {
return(paste(x[3L:(length(x = x) - 1L)], collapse = '_'))
}
)))
if (!isTRUE(x = missing)) {
vf.layers <- intersect(
x = vf.layers,
y = Layers(object = object, search = layers)
)
}
if (!length(x = vf.layers)) {
vf.layers <- NULL
}
return(vf.layers)
}
#' @param object A \code{\link{StdAssay}} object
#' @param type Type of variable feature method to pull; choose from:
#' \itemize{
#' \item \dQuote{\code{hvf}}: highly variable features
#' \item \dQuote{\code{svf}}: spatially variable features
#' }
#' @param layers Vector of layers to restrict methods for, or a search pattern
#' for multiple layers
#'
#' @return A vector of variable feature methods found in \code{object}
#'
#' @noRd
#'
.VFMethods <- function(
object,
type = c('hvf', 'svf'),
layers = NA,
missing = FALSE
) {
type <- type[1L]
type <- match.arg(arg = type)
pattern <- switch(
EXPR = type,
'hvf' = '^vf_',
abort(message = paste("Unknown type:", sQuote(x = type)))
)
vf.cols <- grep(
pattern = paste0(pattern, '[[:alnum:]]+_'),
x = colnames(x = object[[]]),
value = TRUE
)
# layers <- Layers(object = object, search = layers)
layers <- .VFLayers(
object = object,
type = type,
layers = layers,
missing = missing
)
vf.cols <- Filter(
f = function(x) {
x <- unlist(x = strsplit(x = x, split = '_'))
x <- paste(x[3:(length(x = x) - 1L)], collapse = '_')
return(x %in% layers)
},
x = vf.cols
)
vf.methods <- unique(x = unlist(x = lapply(
X = strsplit(x = vf.cols, split = '_'),
FUN = '[[',
2L
)))
if (!length(x = vf.methods)) {
vf.methods <- NULL
}
return(vf.methods)
}
#' @param object A \code{\link{StdAssay}} object
#' @param type Type of variable feature method to pull; choose from:
#' \itemize{
#' \item \dQuote{\code{hvf}}: highly variable features
#' \item \dQuote{\code{svf}}: spatially variable features
#' }
#' @param layers Vector of layers to restrict methods for, or a search pattern
#' for multiple layers
#'
#' @return A vector of variable feature methods and corresponding layers found in \code{object}
#'
#' @importFrom stats setNames
#' @importFrom utils modifyList
#'
#' @noRd
#'
.VFMethodsLayers <- function(
object,
type = c('hvf', 'svf'),
layers = NA,
missing = FALSE
) {
type <- type[1L]
type <- match.arg(arg = type)
pattern <- switch(
EXPR = type,
'hvf' = '^vf_',
abort(message = paste("Unknown type:", sQuote(x = type)))
)
vf.cols <- grep(
pattern = paste0(pattern, '[[:alnum:]]+_'),
x = colnames(x = object[[]]),
value = TRUE
)
# layers <- Layers(object = object, search = layers)
layers <- .VFLayers(
object = object,
type = type,
layers = layers,
missing = missing
)
vf.cols <- Filter(
f = function(x) {
x <- unlist(x = strsplit(x = x, split = '_'))
x <- paste(x[3:(length(x = x) - 1L)], collapse = '_')
return(x %in% layers)
},
x = vf.cols
)
# Extract methods and layers
vf.methods.layers <- lapply(vf.cols, function(col) {
components <- strsplit(col, split = "_")[[1]]
method <- components[2]
layer <- paste(components[3:(length(components) - 1)], collapse = "_")
return(c(method = method, layer = layer))
})
# Combine into a list
vf.list <- lapply(unique(unlist(lapply(vf.methods.layers, `[[`, "method"))), function(method) {
layers <- unique(unlist(lapply(vf.methods.layers, function(x) {
if (x['method'] == method)
return(x['layer'])
})))
return(setNames(list(layers), method))
})
vf.list <- Reduce(modifyList, vf.list)
if (!length(x = vf.list)) {
vf.list <- NULL
}
return(vf.list)
}
CalcN5 <- function(object) {
if (IsMatrixEmpty(x = LayerData(object = object))) {
return(NULL)
}
return(list(
nCount = colSums(x = object),
nFeature = colSums(x = LayerData(object = object) > 0)
))
}
# Join single layers
#
JoinSingleLayers <- function(
object,
layers = NULL,
new = NULL,
default = TRUE,
nfeatures = Inf,
...
) {
if (is.null(x = layers)) {
stop('Layers cannot be NULL')
}
if (length(x = layers) > 1L) {
stop('The length of input layers should be 1')
}
layers <- Layers(object = object, search = layers)
new <- new %||% 'newlayer'
if (length(x = layers) == 1L) {
LayerData(object = object, layer = new) <- LayerData(object = object, layer = layers)
return(object)
}
if (length(x = layers) == 0L) {
return(object)
}
# Stitch the layers together
ldat <- StitchMatrix(
x = LayerData(object = object, layer = layers[1L]),
y = lapply(X = layers[2:length(x = layers)], FUN = LayerData, object = object),
rowmap = slot(object = object, name = 'features')[, layers],
colmap = slot(object = object, name = 'cells')[, layers]
)
LayerData(object = object, layer = new) <- ldat
# Set the new layer as default
if (isTRUE(x = default)) {
DefaultLayer(object = object) <- new
}
# Remove the old layers
for (lyr in layers) {
object[lyr] <- NULL
}
return(object)
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# S4 methods
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
setAs(
from = 'Assay',
to = 'Assay5',
def = function(from) {
# Initialize the new object
to <- new(
Class = 'Assay5',
cells = LogMap(y = colnames(x = from)),
features = LogMap(y = rownames(x = from)),
assay.orig = DefaultAssay(object = from) %||% character(length = 0L),
meta.data = EmptyDF(n = nrow(x = from)),
key = Key(object = from)
)
# browser()
# Add the expression matrices
for (i in c('counts', 'data', 'scale.data')) {
adata <- GetAssayData(object = from, layer = i)
if (IsMatrixEmpty(x = adata)) {
next
}
LayerData(object = to, layer = i) <- adata
}
# Set the default layer
DefaultLayer(object = to) <- ifelse(
test = 'counts' %in% Layers(object = to) && !'scale.data' %in% Layers(object = to),
yes = 'counts',
no = 'data'
)
# Add feature-level meta data
to[[]] <- from[[]]
# Set Variable features
VariableFeatures(object = to) <- VariableFeatures(object = from)
# Add miscellaneous data
mdata <- Misc(object = from)
for (i in names(x = mdata)) {
Misc(object = to, slot = i) <- mdata[[i]]
}
return(to)
}
)
setAs(
from = 'Assay5',
to = 'Assay',
def = function(from) {
data.list <- c()
original.layers <- Layers(object = from)
layers.saved <- c()
for (i in c('counts', 'data', 'scale.data')) {
layers.saved <- c(layers.saved, Layers(object = from, search = i))
if (length(Layers(object = from, search = i)) > 1) {
warning("Joining '", i, "' layers. If you have the same cells in multiple layers, ",
"the expression value for the cell in the '",
i, "' slot will be the value from the '",
Layers(object = from, search = i)[1], "' layer.",
call. = FALSE,
immediate. = TRUE)
from <- JoinLayers(object = from,
layers = i,
new = i)
}
if (i == "data") {
if (isTRUE(Layers(object = from, search = i) == "scale.data")) {
warning("No counts or data slot in object. Setting 'data' slot using",
" data from 'scale.data' slot. To recreate 'data' slot, you",
" must set and normalize data from a 'counts' slot.",
call. = FALSE)
}
}
adata <- LayerData(object = from, layer = i)
if(inherits(x = adata, what = "IterableMatrix")) {
warning("Converting IterableMatrix to sparse dgCMatrix",
call. = FALSE)
adata <- as(object = adata, Class = "dgCMatrix")
}
data.list[[i]] <- adata
}
if (IsMatrixEmpty(x = data.list[["data"]])){
data.list[["data"]] <- data.list[["counts"]]
}
if (any(!(original.layers %in% layers.saved))){
layers.remove <- original.layers[!(original.layers %in% layers.saved)]
warning("Layers ", paste0(layers.remove, collapse = ', '),
" will be removed from the object as v3 assays only support",
" 'counts', 'data', or 'scale.data' slots.",
call. = FALSE,
immediate. = TRUE)
}
to <- new(
Class = 'Assay',
counts = data.list[["counts"]],
data = data.list[["data"]],
scale.data = data.list[["scale.data"]],
assay.orig = DefaultAssay(object = from) %||% character(length = 0L),
meta.features = data.frame(row.names = rownames(x = data.list[["data"]])),
key = Key(object = from)
)
# Add feature-level meta data
suppressWarnings(to[[]] <- from[[]])
# set variable features
VariableFeatures(object = to) <- VariableFeatures(object = from)
mdata <- Misc(object = from)
for (i in names(x = mdata)) {
Misc(object = to, slot = i) <- mdata[[i]]
}
return(to)
}
)
#' @rdname sub-.StdAssay
#'
setMethod(
f = '[<-',
signature = c(x = 'StdAssay', i = 'character'),
definition = function(x, i, ..., value) {
LayerData(object = x, layer = i, ...) <- value
return(x)
}
)
#' @param value A matrix-like object to add as a new layer
#'
#' @return \code{[<-}: \code{x} with layer data \code{value} saved as \code{i}
#'
#' @rdname sub-.Assay5
#'
setMethod(
f = '[<-',
signature = c(x = 'Assay5', i = 'character'),
definition = function(x, i, ..., value) {
return(callNextMethod(x = x, i = i, ..., value = value))
}
)
#' @rdname sub-sub-.StdAssay
#'
setMethod(
f = '[[<-',
signature = c(
x = 'StdAssay',
i = 'character',
j = 'missing',
value = 'data.frame'
),
definition = function(x, i, ..., value) {
if (!length(x = i) && !ncol(x = value)) {
return(x)
}
i <- match.arg(arg = i, choices = colnames(x = value), several.ok = TRUE)
names.intersect <- intersect(
x = row.names(x = value),
y = Features(x = x, layer = NA)
)
if (length(x = names.intersect)) {
value <- value[names.intersect, , drop = FALSE]
} else if (nrow(x = value) == nrow(x = x)) {
row.names(x = value) <- Features(x = x, layer = NA)
} else {
abort(message = "Cannot add more or less meta data without feature names")
}
for (n in i) {
v <- value[[n]]
names(x = v) <- row.names(value)
x[[n]] <- v
}
return(x)
}
)
#' @rdname sub-sub-.StdAssay
#'
setMethod(
f = '[[<-',
signature = c(
x = 'StdAssay',
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)
}
)
#' @importFrom methods selectMethod
#'
#' @rdname sub-sub-.StdAssay
#'
setMethod(
f = '[[<-',
signature = c(x = 'StdAssay', i = 'character', j = 'missing', value = 'factor'),
definition = function(x, i, ..., value) {
f <- slot(
object = selectMethod(
f = '[[<-',
signature = c(
x = 'StdAssay',
i = 'character',
j = 'missing',
value = 'vector'
)
),
name = '.Data'
)
return(f(x = x, i = i, value = value))
}
)
#' @rdname sub-sub-.StdAssay
#'
setMethod(
f = '[[<-',
signature = c(x = 'StdAssay', i = 'character', j = 'missing', value = 'NULL'),
definition = function(x, i, ..., value) {
for (name in i) {
slot(object = x, name = 'meta.data')[[name]] <- NULL
}
return(x)
}
)
#' @rdname sub-sub-.StdAssay
#'
setMethod(
f = '[[<-',
signature = c(x = 'StdAssay', i = 'character', j = 'missing', value = 'vector'),
definition = function(x, i, ..., value) {
# Add multiple bits of metadata
if (length(x = i) > 1L) {
value <- rep_len(x = value, length.out = length(x = i))
for (idx in seq_along(along.with = i)) {
x[[i[idx]]] <- value[[idx]]
}
} else {
# Add a single column of metadata
if (is.null(x = names(x = value))) {
if (length(x = unique(x = value)) == 1) {
value <- rep_len(x = value, length.out = nrow(x = x))
names(x = value) <- Features(x = x, layer = NA)
} else {
names(x = value) <- value
}
}
names.intersect <- intersect(
x = names(x = value),
y = Features(x = x, layer = NA)
)
if (!length(x = names.intersect)) {
abort(message = "No feature overlap between new meta data and assay")
}
value <- value[names.intersect]
df <- EmptyDF(n = nrow(x = x))
rownames(x = df) <- Features(x = x, layer = NA)
# df[[i]] <- if (i %in% names(x = x[[]])) {
# x[[i]]
# } else {
# NA
# }
df[names(x = value), i] <- value
if (nrow(x = slot(object = x, name = 'meta.data')) == 0) {
slot(object = x, name = 'meta.data') <- EmptyDF(n = nrow(x = x))
}
slot(object = x, name = 'meta.data')[, i] <- df[[i]]
}
validObject(object = x)
return(x)
}
)
#' @rdname sub-sub-.StdAssay
#'
setMethod(
f = '[[<-',
signature = c(x = 'StdAssay', i = 'numeric', j = 'missing', value = 'ANY'),
definition = function(x, i, ..., value) {
if (ncol(x = x[[]])) {
i <- colnames(x = x[[]])[as.integer(x = i)]
i <- i[!is.na(x = i)]
if (length(x = i)) {
x[[i]] <- value
}
}
return(x)
}
)
#' @rdname sub-sub-.StdAssay
#'
setMethod(
f = '[[<-',
signature = c(x = 'StdAssay', i = 'missing', j = 'missing', value = 'NULL'),
definition = function(x, ..., value) {
slot(object = x, name = 'meta.data') <- EmptyDF(n = nrow(x = x))
return(x)
}
)
#' @param value Feature-level meta data to add
#'
#' @return \code{[[<-}: \code{x} with \code{value} added as \code{i}
#' in feature-level meta data
#'
#' @rdname sub-sub-.Assay5
#'
#' @order 2
#'
setMethod(
f = '[[<-',
signature = c(x = 'Assay5'),
definition = function(x, i, ..., value) {
return(callNextMethod(x = x, i = i, ..., value = value))
}
)
#' V5 Assay Summaries
#'
#' Summary maths for \code{\link{StdAssay}} Objects
#'
#' @inheritParams base::colSums
#' @param layer Name of layer to run function on
#' @template param-dots-ignored
#'
#' @return The results of the summary math function for the layer specified
#'
#' @name v5-assay-summaries
#' @rdname v5-assay-summaries
#'
#' @keywords internal
#'
NULL
#' @rdname v5-assay-summaries
#'
setMethod(
f = 'colMeans',
signature = c(x = 'StdAssay'),
definition = function(x, na.rm = FALSE, dims = 1, layer = NULL, ...) {
return(Matrix::colMeans(
x = LayerData(object = x, layer = layer),
na.rm = na.rm,
dims = dims
))
}
)
#' @rdname v5-assay-summaries
#'
setMethod(
f = 'colSums',
signature = c(x = 'StdAssay'),
definition = function(x, na.rm = FALSE, dims = 1, layer = NULL, ...) {
return(Matrix::colSums(
x = LayerData(object = x, layer = layer),
na.rm = na.rm,
dims = dims
))
}
)
#' @rdname v5-assay-summaries
#'
setMethod(
f = 'rowMeans',
signature = c(x = 'StdAssay'),
definition = function(x, na.rm = FALSE, dims = 1, layer = NULL, ...) {
return(Matrix::rowMeans(
x = LayerData(object = x, layer = layer),
na.rm = na.rm,
dims = dims
))
}
)
#' @rdname v5-assay-summaries
#'
setMethod(
f = 'rowSums',
signature = c(x = 'StdAssay'),
definition = function(x, na.rm = FALSE, dims = 1, layer = NULL, ...) {
return(Matrix::rowSums(
x = LayerData(object = x, layer = layer),
na.rm = na.rm,
dims = dims
))
}
)
#' V5 Assay Overview
#'
#' Overview of a \code{\link{StdAssay}} object
#'
#' @param object A v5 Assay
#'
#' @template return-show
#'
#' @keywords internal
#'
#' @family stdassay
#'
setMethod(
f = 'show',
signature = 'StdAssay',
definition = function(object) {
# Basic assay info
cat(
.AssayClass(object = object),
'data with',
nrow(x = object),
'features for',
ncol(x = object),
'cells\n'
)
# Feature information
if (length(x = VariableFeatures(object = object))) {
top.ten <- head(x = VariableFeatures(object = object), n = 10L)
top <- 'Top'
variable <- 'variable'
} else {
top.ten <- head(x = Features(x = object), n = 10L)
top <- 'First'
variable <- ''
}
features <- paste(
variable,
paste0(
ifelse(test = length(x = top.ten) == 1L, yes = 'feature', no = 'features'),
":\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'
)
cat(
"Layers:\n",
paste(strwrap(x = paste(Layers(object = object), collapse = ', ')), collapse = '\n'),
"\n"
)
return(invisible(x = NULL))
}
)
#' @rdname split.StdAssay
#'
setMethod( # Because R is stupid
f = 'split',
signature = c(x = 'StdAssay'),
definition = split.StdAssay
)
#' V5 Assay Validity
#'
#' @templateVar cls StdAssay
#' @template desc-validity
#'
#' @section Layer Validation:
#' blah
#'
#' @inheritSection Key-validity Key Validation
#'
#' @keywords internal
#'
#' @name StdAssay-validity
#'
#' @family stdassay
#'
#' @seealso \code{\link[methods]{validObject}}
#'
setValidity(
Class = 'StdAssay',
method = function(object) {
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 layers
dorder <- c(
features = .MARGIN(x = object, type = 'features'),
cells = .MARGIN(x = object, type = 'cells')
)
adims <- dim(x = object) # c(features, cells)
if (!IsNamedList(x = slot(object = object, name = 'layers'), pass.zero = TRUE)) {
valid <- c(valid, "'layers' must be a named list")
}
for (layer in Layers(object = object)) {
# Reorder dimensions of layer to c(features, cells)
ldims <- dim(x = slot(object = object, name = 'layers')[[layer]])[dorder]
if (length(x = ldims) != 2L) {
valid <- c(valid, "Layers must be two-dimensional objects")
break
}
# Check that we have the correct features and cells
for (i in seq.int(from = 1L, to = 2L)) {
if (ldims[i] > adims[i]) {
valid <- c(
valid,
paste0(
"Layers may not have more ",
names(x = dorder)[i],
" than present in the assay (offending layer",
layer,
")"
)
)
}
}
# Check that we've recorded the cells and features in the maps
for (i in c('cells', 'features')) {
didx <- c(features = 1L, cells = 2L)[i]
if (!layer %in% colnames(x = slot(object = object, name = i))) {
valid <- c(
valid,
paste0(
"All layers must have a record in the ",
i,
" map (offending layer: ",
layer,
")"
)
)
} else {
nmap <- length(x = slot(object = object, name = i)[[layer]])
if (nmap != ldims[didx]) {
valid <- c(
valid,
paste0(
"Layers must have the same ",
i,
" as present in the map (offending layer: ",
layer,
")"
)
)
}
}
}
}
didx <- slot(object = object, name = 'default')
if (length(x = didx)) {
if (didx < 0 || didx > length(x = Layers(object = object))) {
valid <- c(
valid,
"'default' must be between 0 and the number of layers present"
)
}
}
# TODO: Check variable features
# TODO: Check meta features
# TODO: Check key
# TODO: Check misc
return(valid %||% TRUE)
}
)
#' @inherit StdAssay-validity title details sections
#'
#' @templateVar cls Assay5
#' @template desc-validity
#'
#' @name Assay5-validity
#'
#' @family assay5
#'
#' @seealso \code{\link[methods]{validObject}}
#'
NULL
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.