Nothing
#' @include zzz.R
#' @include generics.R
#' @include assay.R
#' @include command.R
#' @include dimreduc.R
#' @include graph.R
#' @include spatial.R
#' @importFrom methods setClass
#'
NULL
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Class definitions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' The Seurat Class
#'
#' The Seurat object is a representation of single-cell expression data for R;
#' each Seurat object revolves around a set of cells and consists of one or more
#' \code{\link{Assay}} objects, or individual representations of
#' expression data (eg. RNA-seq, ATAC-seq, etc). These assays can be reduced
#' from their high-dimensional state to a lower-dimension state and stored as
#' \code{\link{DimReduc}} objects. Seurat objects also
#' store additional metadata, both at the cell and feature level (contained
#' within individual assays). The object was designed to be as self-contained as
#' possible, and easily extendable to new methods.
#'
#' @slot assays A list of assays for this project
#' @slot meta.data Contains meta-information about each cell, starting with
#' number of features detected (nFeature) and the original identity class
#' (orig.ident); more information is added using \code{\link{AddMetaData}}
#' @slot active.assay Name of the active, or default, assay; settable using
#' \code{\link{DefaultAssay}}
#' @slot active.ident The active cluster identity for this Seurat object;
#' settable using \code{\link{Idents}}
#' @slot graphs A list of \code{\link{Graph}} objects
#' @slot neighbors ...
#' @slot reductions A list of dimensional reduction objects for this object
#' @slot images A list of spatial image objects
#' @slot project.name Name of the project
#' @slot misc A list of miscellaneous information
#' @slot version Version of Seurat this object was built under
#' @slot commands A list of logged commands run on this \code{Seurat} object
#' @slot tools A list of miscellaneous data generated by other tools, should be
#' filled by developers only using \code{\link{Tool}<-}
#'
#' @name Seurat-class
#' @rdname Seurat-class
#' @exportClass Seurat
#'
#' @family seurat
#'
#' @aliases Seurat
#'
setClass(
Class = 'Seurat',
slots = c(
assays = 'list',
meta.data = 'data.frame',
active.assay = 'character',
active.ident = 'factor',
graphs = 'list',
neighbors = 'list',
reductions = 'list',
images = 'list',
project.name = 'character',
misc = 'list',
version = 'package_version',
commands = 'list',
tools = 'list'
)
)
#' The Seurat Class
#'
#' The Seurat object is the center of each single cell analysis. It stores all
#' information associated with the dataset, including data, annotations,
#' analyses, etc. All that is needed to construct a Seurat object is an
#' expression matrix (rows are genes, columns are cells), which should
#' be log-scale
#'
#' Each Seurat object has a number of slots which store information. Key slots
#' to access are listed below.
#'
#' @slot raw.data The raw project data
#' @slot data The normalized expression matrix (log-scale)
#' @slot scale.data scaled (default is z-scoring each gene) expression matrix;
#' used for dimensional reduction and heatmap visualization
#' @slot var.genes Vector of genes exhibiting high variance across single cells
#' @slot is.expr Expression threshold to determine if a gene is expressed
#' (0 by default)
#' @slot ident THe 'identity class' for each cell
#' @slot meta.data Contains meta-information about each cell, starting with
#' number of genes detected (nFeature) and the original identity class
#' (orig.ident); more information is added using \code{AddMetaData}
#' @slot project.name Name of the project (for record keeping)
#' @slot dr List of stored dimensional reductions; named by technique
#' @slot assay List of additional assays for multimodal analysis; named by
#' technique
#' @slot hvg.info The output of the mean/variability analysis for all genes
#' @slot imputed Matrix of imputed gene scores
#' @slot cell.names Names of all single cells
#' (column names of the expression matrix)
#' @slot cluster.tree List where the first element is a phylo object containing
#' the phylogenetic tree relating different identity classes
#' @slot snn Spare matrix object representation of the SNN graph
#' @slot calc.params Named list to store all calculation-related
#' parameter choices
#' @slot kmeans Stores output of gene-based clustering from \code{DoKMeans}
#' @slot spatial Stores internal data and calculations for spatial mapping of
#' single cells
#' @slot misc Miscellaneous spot to store any data alongside the object
#' (for example, gene lists)
#' @slot version Version of package used in object creation
#'
#' @name seurat-class
#' @rdname oldseurat-class
#' @aliases seurat-class oldseurat
#'
#' @concept unsorted
#' @concept v2
#'
#' @keywords internal
#'
setClass(
Class = "seurat",
slots = c(
raw.data = "ANY",
data = "ANY",
scale.data = "ANY",
var.genes = "vector",
is.expr = "numeric",
ident = "factor",
meta.data = "data.frame",
project.name = "character",
dr = "list",
assay = "list",
hvg.info = "data.frame",
imputed = "data.frame",
cell.names = "vector",
cluster.tree = "list",
snn = "dgCMatrix",
calc.params = "list",
kmeans = "ANY",
spatial = "ANY",
misc = "ANY",
version = "ANY"
)
)
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Functions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Get cell names grouped by identity class
#'
#' @param object A Seurat object
#' @param idents A vector of identity class levels to limit resulting list to;
#' defaults to all identity class levels
#' @param cells A vector of cells to grouping to
#' @param return.null If no cells are requested, return a \code{NULL};
#' by default, throws an error
#'
#' @return A named list where names are identity classes and values are vectors
#' of cells belonging to that class
#'
#' @export
#'
#' @concept data-access
#'
#' @examples
#' CellsByIdentities(object = pbmc_small)
#'
CellsByIdentities <- function(
object,
idents = NULL,
cells = NULL,
return.null = FALSE
) {
cells <- cells %||% colnames(x = object)
cells <- intersect(x = cells, y = colnames(x = object))
if (length(x = cells) == 0) {
if (isTRUE(x = return.null)) {
return(NULL)
}
stop("Cannot find cells provided")
}
idents <- idents %||% levels(x = object)
idents <- intersect(x = idents, y = levels(x = object))
if (length(x = idents) == 0) {
stop("None of the provided identity class levels were found", call. = FALSE)
}
cells.idents <- sapply(
X = idents,
FUN = function(i) {
return(cells[as.vector(x = Idents(object = object)[cells]) == i])
},
simplify = FALSE,
USE.NAMES = TRUE
)
if (any(is.na(x = Idents(object = object)[cells]))) {
cells.idents[["NA"]] <- names(x = which(x = is.na(x = Idents(object = object)[cells])))
}
return(cells.idents)
}
#' Get a vector of cell names associated with an image (or set of images)
#'
#' @param object Seurat object
#' @param images Vector of image names
#' @param unlist Return as a single vector of cell names as opposed to a list,
#' named by image name.
#'
#' @return A vector of cell names
#'
#' @concept data-access
#'
#' @examples
#' \dontrun{
#' CellsByImage(object = object, images = "slice1")
#' }
#'
CellsByImage <- function(object, images = NULL, unlist = FALSE) {
images <- images %||% Images(object = object)
cells <- sapply(
X = images,
FUN = function(x) {
Cells(x = object[[x]])
},
simplify = FALSE,
USE.NAMES = TRUE
)
if (unlist) {
cells <- unname(obj = unlist(x = cells))
}
return(cells)
}
#' Find Sub-objects of a Certain Class
#'
#' Get the names of objects within a \code{Seurat} object that are of a
#' certain class
#'
#' @param object A \code{\link{Seurat}} object
#' @param classes.keep A vector of names of classes to get
#'
#' @return A vector with the names of objects within the \code{Seurat} object
#' that are of class \code{classes.keep}
#'
#' @export
#'
#' @concept utils
#'
#' @templateVar fxn FilterObjects
#' @templateVar ver 5.0.0
#' @templateVar repl .FilterObjects
#' @template lifecycle-deprecated
#'
#' @examples
#' FilterObjects(pbmc_small)
#'
FilterObjects <- function(
object,
classes.keep = c('Assay', 'StdAssay', 'DimReduc')
) {
.Deprecate(when = '5.0.0', what = 'FilterObjects()', with = '.FilterObjects()')
object <- UpdateSlots(object = object)
slots <- na.omit(object = Filter(
f = function(x) {
sobj <- slot(object = object, name = x)
return(is.list(x = sobj) && !is.data.frame(x = sobj) && !is.package_version(x = sobj))
},
x = slotNames(x = object)
))
slots <- grep(pattern = 'tools', x = slots, value = TRUE, invert = TRUE)
slots <- grep(pattern = 'misc', x = slots, value = TRUE, invert = TRUE)
slots.objects <- unlist(
x = lapply(
X = slots,
FUN = function(x) {
return(names(x = slot(object = object, name = x)))
}
),
use.names = FALSE
)
object.classes <- sapply(
X = slots.objects,
FUN = function(i) {
return(inherits(x = object[[i]], what = classes.keep))
}
)
object.classes <- which(x = object.classes, useNames = TRUE)
return(names(x = object.classes))
}
#' @rdname ObjectAccess
#' @export
#'
#' @examples
#' Graphs(pbmc_small)
#'
Graphs <- function(object, slot = NULL) {
graphs <- .FilterObjects(object = object, classes.keep = "Graph")
if (is.null(x = slot)) {
return(graphs)
}
if (!slot %in% graphs) {
warning(
"Cannot find a Graph object of name ",
slot,
" in this Seurat object",
call. = FALSE,
immediate. = TRUE
)
}
return(slot(object = object, name = 'graphs')[[slot]])
}
#' Pull spatial image names
#'
#' List the names of \code{SpatialImage} objects present in a \code{Seurat}
#' object. If \code{assay} is provided, limits search to images associated with
#' that assay
#'
#' @param object A \code{Seurat} object
#' @param assay Name of assay to limit search to
#'
#' @return A list of image names
#'
#' @export
#'
#' @concept data-access
#'
#' @examples
#' \dontrun{
#' Images(object)
#' }
#'
Images <- function(object, assay = NULL) {
images <- names(x = slot(object = object, name = 'images'))
if (!is.null(x = assay)) {
assays <- c(assay, DefaultAssay(object = object[[assay]]))
images <- Filter(
f = function(x) {
return(DefaultAssay(object = object[[x]]) %in% assays)
},
x = images
)
}
return(images)
}
#' @inheritDotParams base::readRDS
#'
#' @rdname SaveSeuratRds
#' @export
#'
LoadSeuratRds <- function(file, ...) {
object <- readRDS(file = file, ...)
cache <- Tool(object = object, slot = 'SaveSeuratRds')
reqd.cols <- c('layer', 'path', 'class', 'pkg', 'fxn', 'assay')
emit <- ifelse(
test = isTRUE(x = getOption(x = 'Seurat.io.rds.strict', default = FALSE)),
yes = abort,
no = warn
)
if (!is.null(x = cache)) {
if (interactive()) {
check_installed(pkg = 'fs', reason = 'for finding file paths')
} else if (!requireNamespace('fs', quietly = TRUE)) {
abort(message = "Loading layers from disk requires `fs`")
}
# Check the format of the cache
if (!is.data.frame(x = cache)) {
emit(message = "Malformed layer cache: not a data frame")
return(object)
}
if (!all(reqd.cols %in% names(x = cache))) {
emit(message = "Malformed layer cache: missing required columns")
return(object)
}
# Check the assays specified
assays <- .FilterObjects(object = object, classes.keep = 'StdAssay')
cache <- cache[cache$assay %in% assays, , drop = FALSE]
if (!nrow(x = cache)) {
emit(message = "Incorrect layer cache: none of the assays listed present")
return(object)
}
# Check the files
exists <- vapply(
X = cache$path,
FUN = function(x) {
x <- unlist(x = strsplit(x = x, split = ','))
res <- vector(mode = 'logical', length = length(x = x))
for (i in seq_along(along.with = x)) {
res[i] <- fs::is_file(path = x[i]) || fs::dir_exists(path = x[i])
}
return(all(res))
},
FUN.VALUE = logical(length = 1L),
USE.NAMES = FALSE
)
exists[is.na(exists)] <- FALSE
cache <- cache[exists, , drop = FALSE]
if (!nrow(x = cache)) {
emit(message = "Cannot find any of the layer files specified")
return(object)
}
# Check the packages
missing.pkgs <- pkgs <- unique(x = cache$pkg)
for (pkg in pkgs) {
if (interactive()) {
check_installed(pkg = pkg)
}
if (requireNamespace(pkg, quietly = TRUE)) {
missing.pkgs <- setdiff(x = missing.pkgs, y = pkg)
} else {
emit(message = paste("Cannot find required package:", sQuote(x = pkg)))
}
}
pkgs <- setdiff(x = pkgs, y = missing.pkgs)
if (!length(x = pkgs)) {
emit(message = "None of the required layer packages found")
return(object)
}
p <- progressor(steps = nrow(x = cache))
# Load the layers
for (i in seq_len(length.out = nrow(x = cache))) {
lyr <- cache$layer[i]
pth <- cache$path[i]
fxn <- eval(expr = str2lang(s = cache$fxn[i]))
assay <- cache$assay[i]
p(
message = paste(
"Adding layer",
sQuote(x = lyr),
"to assay",
sQuote(x = assay)
),
class = 'sticky',
amount = 0
)
LayerData(object = object, assay = assay, layer = lyr) <- fxn(pth)
p()
}
}
return(object)
}
#' @rdname ObjectAccess
#' @export
#'
Neighbors <- function(object, slot = NULL) {
neighbors <- .FilterObjects(object = object, classes.keep = "Neighbor")
if (is.null(x = slot)) {
return(neighbors)
}
if (!slot %in% neighbors) {
warning(
"Cannot find a Neighbor object of name ",
slot,
" in this Seurat object",
call. = FALSE,
immediate. = TRUE
)
}
return(slot(object = object, name = 'neighbors')[[slot]])
}
#' @rdname ObjectAccess
#' @export
#'
#' @examples
#' Reductions(object = pbmc_small)
#'
Reductions <- function(object, slot = NULL) {
reductions <- .FilterObjects(object = object, classes.keep = 'DimReduc')
if (is.null(x = slot)) {
return(reductions)
}
if (!slot %in% reductions) {
warn(
message = paste(
'Cannot find a DimReduc of name',
slot,
'in this Seurat object')
)
return(NULL)
}
return(slot(object = object, name = 'reductions')[[slot]])
}
#' Rename assays in a \code{Seurat} object
#'
#' @param object A \code{Seurat} object
#' @param assay.name original name of assay
#' @param new.assay.name new name of assay
#' @param verbose Whether to print messages
#' @param ... Named arguments as \code{old.assay = new.assay}
#'
#' @return \code{object} with assays renamed
#'
#' @export
#'
#' @concept seurat
#'
#' @examples
#' RenameAssays(object = pbmc_small, RNA = 'rna')
#'
RenameAssays <- function(
object,
assay.name = NULL,
new.assay.name = NULL,
verbose = TRUE,
...) {
op <- options(Seurat.object.assay.calcn = FALSE)
on.exit(expr = options(op), add = TRUE)
if ((!is.null(x = assay.name) & is.null(x = new.assay.name))
| (is.null(x = assay.name) & !is.null(x = new.assay.name))) {
stop("Must provide both assay.name and new.assasy.name if using parameters. Otherwise, ",
"you can set arguments without parameters by doing ",
"{old.assay = new.assay} with your own assay names.", call. = FALSE)
}
if (!is.null(x = assay.name) & !is.null(x = new.assay.name)) {
assay.pairs <- new.assay.name
names(x = assay.pairs) <- assay.name
old.assays <- names(x = assay.pairs)
} else {
assay.pairs <- tryCatch(
expr = as.list(x = ...),
error = function(e) {
return(list(...))
}
)
old.assays <- names(x = assay.pairs)
names(x = assay.pairs) <- old.assays
}
# Handle missing assays
missing.assays <- setdiff(x = old.assays, y = Assays(object = object))
if (length(x = missing.assays) == length(x = old.assays)) {
stop("None of the assays provided are present in this object", call. = FALSE)
} else if (length(x = missing.assays)) {
warning(
"The following assays could not be found: ",
paste(missing.assays, collapse = ', '),
call. = FALSE,
immediate. = TRUE
)
}
old.assays <- setdiff(x = old.assays, missing.assays)
assay.pairs <- assay.pairs[old.assays]
# Check to see that all old assays are named
if (is.null(x = names(x = assay.pairs)) || any(sapply(X = old.assays, FUN = nchar) < 1)) {
stop("All arguments must be named with the old assay name", call. = FALSE)
}
# Ensure each old assay is going to one new assay
if (!all(sapply(X = assay.pairs, FUN = length) == 1) || length(x = old.assays) != length(x = unique(x = old.assays))) {
stop("Can only rename assays to one new name", call. = FALSE)
}
# Ensure each new assay is coming from one old assay
if (length(x = assay.pairs) != length(x = unique(x = assay.pairs))) {
stop(
"One or more assays are set to be lost due to duplicate new assay names",
call. = FALSE
)
}
# Rename assays
for (old in names(x = assay.pairs)) {
new <- assay.pairs[[old]]
# If we aren't actually renaming any
if (old == new) {
next
}
old.key <- Key(object = object[[old]])
suppressWarnings(expr = object[[new]] <- object[[old]])
if (old == DefaultAssay(object = object)) {
if (verbose) {
message("Renaming default assay from ", old, " to ", new)
}
DefaultAssay(object = object) <- new
}
Key(object = object[[new]]) <- old.key
# change assay used in any dimreduc object
for (i in Reductions(object = object)) {
if (DefaultAssay(object = object[[i]]) == old) {
DefaultAssay(object = object[[i]]) <- new
}
}
# Add new metadata if it exists
if (isTRUE(paste0("nCount_", old) %in% colnames(object[[]]))) {
slot(
object = object,
name = 'meta.data'
)[paste0("nCount_", new)] <- object[[]][,paste0("nCount_",old)]
}
if (isTRUE(paste0("nFeature_", old) %in% colnames(object[[]]))) {
slot(
object = object,
name = 'meta.data'
)[paste0("nFeature_", new)] <- object[[]][,paste0("nFeature_", old)]
}
object[[old]] <- NULL
}
return(object)
}
#' Save and Load \code{Seurat} Objects from Rds files
#'
#' @param object A \code{\link{Seurat}} object
#' @param file Path to save \code{object} to; defaults to
#' \code{file.path(getwd(), paste0(Project(object), ".Rds"))}
#' @param move Move on-disk layers into \code{dirname(file)}
#' @param destdir \Sexpr[stage=build,results=rd]{lifecycle::badge("deprecated")}
#' @param relative Save relative paths instead of absolute ones
#' @inheritDotParams base::saveRDS
#'
#' @return Invisibly returns \code{file}
#'
#' @export
#'
#' @template section-progressr
#'
#' @templateVar pkg fs
#' @template note-reqdpkg
#'
#' @concept utils
#'
#' @seealso \code{\link{saveRDS}()} \code{\link{readRDS}()}
#'
#' @order 1
#'
#' @examples
#' if (requireNamespace("fs", quietly = TRUE)) {
#' # Write out with DelayedArray
#' if (requireNamespace("HDF5Array", quietly = TRUE)) {
#' pbmc <- pbmc_small
#'
#' pbmc[["disk"]] <- CreateAssay5Object(list(
#' mem = LayerData(pbmc, "counts"),
#' disk = as(LayerData(pbmc, "counts"), "HDF5Array")
#' ))
#'
#' # Save `pbmc` to an Rds file
#' out <- tempfile(fileext = ".Rds")
#' SaveSeuratRds(pbmc, file = out)
#'
#' # Object cache
#' obj <- readRDS(out)
#' Tool(obj, "SaveSeuratRds")
#'
#' # Load the saved object with on-disk layers back into memory
#' pbmc2 <- LoadSeuratRds(out)
#' pbmc2
#' pbmc2[["disk"]]
#' }
#'
#' # Write out with BPCells
#' if (requireNamespace("BPCells", quietly = TRUE)) {
#' pbmc <- pbmc_small
#'
#' bpm <- BPCells::write_matrix_dir(LayerData(pbmc, "counts"), dir = tempfile())
#' bph <- BPCells::write_matrix_hdf5(
#' LayerData(pbmc, "counts"),
#' path = tempfile(fileext = ".h5"),
#' group = "counts"
#' )
#' pbmc[["disk"]] <- CreateAssay5Object(list(dir = bpm, h5 = bph))
#'
#' # Save `pbmc` to an Rds file
#' out <- tempfile(fileext = ".Rds")
#' SaveSeuratRds(pbmc, file = out)
#'
#' # Object cache
#' obj <- readRDS(out)
#' Tool(obj, "SaveSeuratRds")
#'
#' # Load the saved object with on-disk layers back into memory
#' pbmc2 <- LoadSeuratRds(out)
#' pbmc2
#' pbmc2[["disk"]]
#' }
#' }
#'
SaveSeuratRds <- function(
object,
file = NULL,
move = TRUE,
destdir = deprecated(),
relative = FALSE,
...
) {
file <- file %||% file.path(getwd(), paste0(Project(object = object), '.Rds'))
file <- normalizePath(path = file, winslash = '/', mustWork = FALSE)
if (is_present(arg = destdir)) {
.Deprecate(
when = '5.0.1',
what = 'SaveSeuratRds(destdir = )',
with = 'SaveSeuratRds(move = )',
details = paste(
"Specifying a directory to move on-disk layers stored in",
sQuote(x = normalizePath(path = tempdir(), winslash = '/', mustWork = FALSE)),
"is deprecated; now, specify `move = TRUE` either move all on-disk layers to",
sQuote(x = dirname(path = file)),
"or `move = FALSE` leave them as-is"
)
)
move <- is_bare_character(x = destdir, n = 1L) || is.null(x = destdir)
}
# Cache v5 assays
assays <- .FilterObjects(object = object, classes.keep = 'StdAssay')
p <- progressor(along = assays, auto_finish = TRUE)
on.exit(expr = p(type = 'finish'), add = TRUE)
p(
message = paste(
"Looking for on-disk matrices in",
length(x = assays),
"assays"
),
class = 'sticky',
amount = 0
)
cache <- vector(mode = 'list', length = length(x = assays))
names(x = cache) <- assays
destdir <- dirname(path = file)
if (isTRUE(x = move)) {
check_installed(pkg = 'fs', reason = 'for moving on-disk matrices')
}
for (assay in assays) {
p(
message = paste("Searching through assay", assay),
class = 'sticky',
amount = 0
)
df <- lapply(
X = Layers(object = object[[assay]]),
FUN = function(lyr) {
ldat <- LayerData(object = object[[assay]], layer = lyr)
path <- .FilePath(x = ldat)
path <- Filter(f = nzchar, x = path)
if (!length(x = path)) {
path <- NULL
}
if (is.null(x = path)) {
return(NULL)
}
return(data.frame(
layer = lyr,
path = path,
class = paste(class(x = ldat), collapse = ','),
pkg = .ClassPkg(object = ldat),
fxn = .DiskLoad(x = ldat) %||% identity
))
}
)
df <- do.call(what = 'rbind', args = df)
if (is.null(x = df) || !nrow(x = df)) {
p(message = "No on-disk layers found", class = 'sticky', amount = 0)
next
}
if (isTRUE(x = move)) {
for (i in seq_len(length.out = nrow(x = df))) {
pth <- df$path[i]
p(
message = paste(
"Moving layer",
sQuote(x = df$layer[i]),
"to",
sQuote(x = destdir)
),
class = 'sticky',
amount = 0
)
df[i, 'path'] <- as.character(x = .FileMove(
path = pth,
new_path = destdir
))
}
}
if (isTRUE(x = relative)) {
p(
message = paste(
"Adjusting paths to be relative to",
sQuote(x = dirname(path = file), q = FALSE)
),
class = 'sticky',
amount = 0
)
df$path <- as.character(x = fs::path_rel(
path = df$path,
start = dirname(path = file)
))
}
df$assay <- assay
cache[[assay]] <- df
if (nrow(x = df) == length(x = Layers(object = object[[assay]]))) {
p(
message = paste("Clearing layers from", assay),
class = 'sticky',
amount = 0
)
adata <- S4ToList(object = object[[assay]])
adata$layers <- list()
adata$default <- 0L
adata$cells <- LogMap(y = colnames(x = object[[assay]]))
adata$features <- LogMap(y = rownames(x = object[[assay]]))
object[[assay]] <- ListToS4(x = adata)
} else {
p(
message = paste("Clearing", nrow(x = df), "layers from", assay),
class = 'sticky',
amount = 0
)
for (layer in df$layer) {
LayerData(object = object[[assay]], layer = layer) <- NULL
}
}
p()
}
cache <- do.call(what = 'rbind', args = cache)
if (!is.null(x = cache) && nrow(x = cache)) {
p(message = "Saving on-disk cache to object", class = 'sticky', amount = 0)
row.names(x = cache) <- NULL
Tool(object = object) <- cache
}
saveRDS(object = object, file = file, ...)
return(invisible(x = file))
}
#' Update old Seurat object to accommodate new features
#'
#' Updates Seurat objects to new structure for storing data/calculations.
#' For Seurat v3 objects, will validate object structure ensuring all keys
#' and feature names are formed properly.
#'
#' @param object Seurat object
#'
#' @return Returns a Seurat object compatible with latest changes
#'
#' @importFrom methods .hasSlot new slot
#'
#' @export
#'
#' @concept seurat
#'
#' @examples
#' \dontrun{
#' updated_seurat_object = UpdateSeuratObject(object = old_seurat_object)
#' }
#'
UpdateSeuratObject <- function(object) {
op <- options(Seurat.object.validate = FALSE)
on.exit(expr = options(op), add = TRUE)
if (.hasSlot(object, "version")) {
if (slot(object = object, name = 'version') >= package_version(x = "2.0.0") && slot(object = object, name = 'version') < package_version(x = '3.0.0')) {
# Run update
message("Updating from v2.X to v3.X")
# seurat.version <- packageVersion(pkg = "SeuratObject")
seurat.version <- package_version(x = '3.0.0')
new.assay <- UpdateAssay(old.assay = object, assay = "RNA")
assay.list <- list(new.assay)
names(x = assay.list) <- "RNA"
for (i in names(x = object@assay)) {
assay.list[[i]] <- UpdateAssay(old.assay = object@assay[[i]], assay = i)
}
new.dr <- UpdateDimReduction(old.dr = object@dr, assay = "RNA")
object <- new(
Class = "Seurat",
version = seurat.version,
assays = assay.list,
active.assay = "RNA",
project.name = object@project.name,
misc = object@misc %||% list(),
active.ident = object@ident,
reductions = new.dr,
meta.data = object@meta.data,
tools = list()
)
# Run CalcN
for (assay in Assays(object = object)) {
n.calc <- CalcN(object = object[[assay]])
if (!is.null(x = n.calc)) {
names(x = n.calc) <- paste(names(x = n.calc), assay, sep = '_')
object[[names(x = n.calc)]] <- n.calc
}
to.remove <- c("nGene", "nUMI")
for (i in to.remove) {
if (i %in% colnames(x = object[[]])) {
object[[i]] <- NULL
}
}
}
}
if (package_version(x = slot(object = object, name = 'version')) >= package_version(x = "3.0.0")) {
# Run validation
message("Validating object structure")
# Update object slots
message("Updating object slots")
object <- UpdateSlots(object = object)
# Validate object keys
message("Ensuring keys are in the proper structure")
for (ko in .FilterObjects(object = object)) {
key <- Key(object = object[[ko]])
if (!length(x = key) || !nzchar(x = key)) {
key <- Key(object = ko, quiet = TRUE)
}
slot(
object = slot(object = object, name = FindObject(object, ko))[[ko]],
name = 'key'
) <- UpdateKey(key)
if (inherits(x = slot(object = object, name = FindObject(object, ko))[[ko]], what = 'DimReduc')) {
message("Updating matrix keys for DimReduc ", sQuote(ko))
for (m in c('cell.embeddings', 'feature.loadings', 'feature.loadings.projected')) {
mat <- slot(
object = slot(object = object, name = FindObject(object, ko))[[ko]],
name = m
)
if (IsMatrixEmpty(mat)) {
next
}
colnames(x = mat) <- paste0(key, seq_len(ncol(mat)))
slot(
object = slot(object = object, name = FindObject(object, ko))[[ko]],
name = m
) <- mat
}
}
}
# Rename assays
assays <- make.names(names = Assays(object = object))
names(x = assays) <- Assays(object = object)
object <- do.call(what = RenameAssays, args = c('object' = object, assays))
for (obj in .FilterObjects(object = object, classes.keep = c('Assay', 'DimReduc', 'Graph'))) {
suppressWarnings(
expr = object[[obj]] <- UpdateSlots(object = object[[obj]]),
classes = 'validationWarning'
)
}
for (cmd in Command(object = object)) {
slot(object = object, name = 'commands')[[cmd]] <- UpdateSlots(
object = Command(object = object, command = cmd)
)
}
# Validate object keys
message("Ensuring keys are in the proper structure")
for (ko in .FilterObjects(object = object)) {
suppressWarnings(
expr = Key(object = object[[ko]]) <- UpdateKey(key = Key(object = object[[ko]])),
classes = 'validationWarning'
)
}
# Check feature names
message("Ensuring feature names don't have underscores or pipes")
for (assay.name in .FilterObjects(object = object, classes.keep = 'Assay')) {
assay <- object[[assay.name]]
for (slot in c('counts', 'data', 'scale.data')) {
if (!IsMatrixEmpty(x = slot(object = assay, name = slot))) {
rownames(x = slot(object = assay, name = slot)) <- gsub(
pattern = '_',
replacement = '-',
x = rownames(x = slot(object = assay, name = slot))
)
rownames(x = slot(object = assay, name = slot)) <- gsub(
pattern = '|',
replacement = '-',
x = rownames(x = slot(object = assay, name = slot)),
fixed = TRUE
)
}
}
VariableFeatures(object = assay) <- gsub(
pattern = '_',
replacement = '-',
x = VariableFeatures(object = assay)
)
VariableFeatures(object = assay) <- gsub(
pattern = '|',
replacement = '-',
x = VariableFeatures(object = assay),
fixed = TRUE
)
rownames(x = slot(object = assay, name = "meta.features")) <- gsub(
pattern = '_',
replacement = '-',
x = rownames(x = assay[[]])
)
rownames(x = slot(object = assay, name = "meta.features")) <- gsub(
pattern = '|',
replacement = '-',
x = rownames(x = assay[[]]),
fixed = TRUE
)
# reorder features in scale.data and meta.features to match counts
sd.features <- rownames(x = slot(object = assay, name = "scale.data"))
data.features <- rownames(x = slot(object = assay, name = "data"))
md.features <- rownames(x = slot(object = assay, name = "meta.features"))
if (!all.equal(target = md.features, current = data.features, check.attributes = FALSE)) {
slot(object = assay, name = "meta.features") <- slot(object = assay, name = "meta.features")[data.features, ]
}
sd.order <- sd.features[order(match(x = sd.features, table = data.features))]
slot(object = assay, name = "scale.data") <- slot(object = assay, name = "scale.data")[sd.order, ]
suppressWarnings(
expr = object[[assay.name]] <- assay,
classes = 'validationWarning'
)
}
for (reduc.name in .FilterObjects(object = object, classes.keep = 'DimReduc')) {
reduc <- object[[reduc.name]]
for (slot in c('feature.loadings', 'feature.loadings.projected')) {
if (!IsMatrixEmpty(x = slot(object = reduc, name = slot))) {
rownames(x = slot(object = reduc, name = slot)) <- gsub(
pattern = '_',
replacement = '-',
x = rownames(x = slot(object = reduc, name = slot))
)
rownames(x = slot(object = reduc, name = slot)) <- gsub(
pattern = '_',
replacement = '-',
x = rownames(x = slot(object = reduc, name = slot)),
fixed = TRUE
)
}
}
suppressWarnings(
expr = object[[reduc.name]] <- reduc,
classes = 'validationWarning'
)
}
# Update Assays, DimReducs, and Graphs
for (x in names(x = object)) {
message("Updating slots in ", x)
xobj <- object[[x]]
xobj <- suppressWarnings(
expr = UpdateSlots(object = xobj),
classes = 'validationWarning'
)
if (inherits(x = xobj, what = "SCTAssay")){
sctmodels <- names(x = slot(object = xobj, name = "SCTModel.list"))
for (sctmodel in sctmodels){
median_umi <- tryCatch(
expr = slot(object = xobj@SCTModel.list[[sctmodel]], name = "median_umi"),
error = function(...) {
return(0)
}
)
xobj@SCTModel.list[[sctmodel]]@median_umi <- median_umi
}
}
if (inherits(x = xobj, what = 'DimReduc')) {
if (any(sapply(X = c('tsne', 'umap'), FUN = grepl, x = tolower(x = x)))) {
message("Setting ", x, " DimReduc to global")
slot(object = xobj, name = 'global') <- TRUE
}
} else if (inherits(x = xobj, what = 'Graph')) {
graph.assay <- unlist(x = strsplit(x = x, split = '_'))[1]
if (graph.assay %in% Assays(object = object)) {
message("Setting default assay of ", x, " to ", graph.assay)
suppressWarnings(
expr = DefaultAssay(object = xobj) <- graph.assay,
classes = 'validationWarning'
)
} else {
message(
"Cannot find ",
graph.assay,
" in the object, setting default assay of ",
x,
" to ",
DefaultAssay(object = object)
)
suppressWarnings(
expr = DefaultAssay(object = xobj) <- DefaultAssay(object = object),
classes = 'validationWarning'
)
}
}
suppressWarnings(
expr = object[[x]] <- xobj,
classes = 'validationWarning'
)
}
# Update SeuratCommands
for (cmd in Command(object = object)) {
cobj <- Command(object = object, command = cmd)
cobj <- UpdateSlots(object = cobj)
cmd.assay <- unlist(x = strsplit(x = cmd, split = '\\.'))
cmd.assay <- cmd.assay[length(x = cmd.assay)]
cmd.assay <- if (cmd.assay %in% Assays(object = object)) {
cmd.assay
} else if (cmd.assay %in% Reductions(object = object)) {
DefaultAssay(object = object[[cmd.assay]])
} else {
NULL
}
if (is.null(x = cmd.assay)) {
message("No assay information could be found for ", cmd)
} else {
message("Setting assay used for ", cmd, " to ", cmd.assay)
}
slot(object = cobj, name = 'assay.used') <- cmd.assay
suppressWarnings(
expr = object[[cmd]] <- cobj,
classes = 'validationWarning'
)
}
# Update object version
slot(object = object, name = 'version') <- packageVersion(pkg = 'SeuratObject')
}
object <- suppressWarnings(
expr = UpdateSlots(object = object),
classes = 'validationWarning'
)
if (package_version(x = slot(object = object, name = 'version')) <= package_version(x = '4.0.0')) {
# Transfer the object to the SeuratObject namespace
object <- suppressWarnings(
expr = UpdateClassPkg(
object = object,
from = 'Seurat',
to = 'SeuratObject'
),
classes = 'validationWarning'
)
}
slot(object = object, name = 'version') <- packageVersion(pkg = 'SeuratObject')
options(op)
validObject(object = object, complete = TRUE)
for (i in names(x = object)) {
message(
"Validating object structure for ",
paste(class(x = object[[i]])[1L], sQuote(x = i))
)
validObject(object = object[[i]])
}
message("Object representation is consistent with the most current Seurat version")
return(object)
}
stop(
"We are unable to convert Seurat objects less than version 2.X to version 3.X\n",
'Please use devtools::install_version to install Seurat v2.3.4 and update your object to a 2.X object',
call. = FALSE
)
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for Seurat-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' @rdname AddMetaData
#' @export
#' @method AddMetaData Seurat
#'
AddMetaData.Seurat <- .AddMetaData
#' @rdname ObjectAccess
#' @method Assays Seurat
#' @export
#'
Assays.Seurat <- function(object, slot = deprecated(), ...) {
if (is_present(arg = slot)) {
.Deprecate(
when = '5.0.0',
what = 'Assays(slot = )',
with = 'LayerData()'
)
return(methods::slot(object = object, name = 'assays')[[slot]])
}
return(names(x = methods::slot(object = object, name = 'assays')))
}
#' @method CastAssay Seurat
#' @export
#'
CastAssay.Seurat <- function(object, to, assay = NULL, layers = NA, ...) {
assay <- assay[1L] %||% DefaultAssay(object = object)
assay <- arg_match0(arg = assay, values = Assays(object = object))
to <- enquo(arg = to)
object[[assay]] <- CastAssay(
object = object[[assay]],
to = to,
layers = layers,
...
)
validObject(object = object)
return(object)
}
#' @method Cells Seurat
#' @export
#'
Cells.Seurat <- function(x, assay = NULL, ...) {
assay <- assay[1L] %||% DefaultAssay(object = x)
if (is.na(x = assay)) {
return(colnames(x = x))
}
assay <- tryCatch(
expr = match.arg(arg = assay, choices = Assays(object = x)),
error = function(e) {
return(NULL)
}
)
return(Cells(x = x[[assay]], ...))
}
#' @param command Name of the command to pull, pass \code{NULL} to get the
#' names of all commands run
#' @param value Name of the parameter to pull the value for
#'
#' @rdname Command
#' @export
#' @method Command Seurat
#'
Command.Seurat <- function(object, command = NULL, value = NULL, ...) {
CheckDots(...)
object <- UpdateSlots(object = object)
commands <- slot(object = object, name = "commands")
if (is.null(x = command)) {
return(names(x = commands))
}
if (is.null(x = commands[[command]])) {
stop(command, " has not been run or is not a valid command.")
}
command <- commands[[command]]
if (is.null(x = value)) {
return(command)
}
params <- slot(object = command, name = "params")
if (!value %in% names(x = params)) {
stop(value, " is not a valid parameter for ", slot(object = command, name = "name"))
}
return(params[[value]])
}
# @param row.names When \code{counts} is a \code{data.frame} or
# \code{data.frame}-derived object: an optional vector of feature names to be
# used
#
#' @rdname CreateSeuratObject
#' @method CreateSeuratObject default
#' @export
#'
CreateSeuratObject.default <- function(
counts,
assay = 'RNA',
names.field = 1L,
names.delim = '_',
meta.data = NULL,
project = 'SeuratProject',
min.cells = 0,
min.features = 0,
...
) {
assay.version <- getOption(x = 'Seurat.object.assay.version', default = 'v5')
if (.GetSeuratCompat() < '5.0.0') {
assay.version <- 'v3'
} else if (!inherits(counts, what = c('matrix', 'dgCMatrix')) && assay.version == 'v3') {
message(
"Counts matrix provided is not sparse; vreating v5 assay in Seurat object"
)
assay.version <- 'v5'
}
assay.data <- if (tolower(x = assay.version) == 'v3') {
assay.data <- CreateAssayObject(
counts = counts,
min.cells = min.cells,
min.features = min.features,
...
)
} else {
CreateAssay5Object(
counts = counts,
min.cells = min.cells,
min.features = min.features,
...
)
}
return(CreateSeuratObject(
counts = assay.data,
assay = assay,
names.field = names.field,
names.delim = names.delim,
meta.data = meta.data,
project = project
))
}
#' @rdname CreateSeuratObject
#' @method CreateSeuratObject Assay
#' @export
#'
CreateSeuratObject.Assay <- function(
counts,
assay = 'RNA',
names.field = 1L,
names.delim = '_',
meta.data = NULL,
project = 'SeuratProject',
...
) {
# Check the assay key
if (!isTRUE(x = nzchar(x = Key(object = counts)))) {
Key(object = counts) <- Key(object = tolower(x = assay), quiet = TRUE)
}
# Assemble the assay list
assay.list <- list(counts)
names(x = assay.list) <- assay
# Create identity classes
idents <- factor(x = unlist(x = lapply(
X = colnames(x = counts),
FUN = ExtractField,
field = names.field,
delim = names.delim
)))
if (any(is.na(x = idents))) {
warn(
"Input parameters result in NA values for initial cell identities. Setting all initial idents to the project name",
call. = FALSE,
immediate. = TRUE
)
idents <- factor(x = rep_len(x = project, length.out = ncol(x = counts)))
}
nidents <- length(x = levels(x = idents))
if (nidents > 100L || nidents == 0L || nidents == length(x = idents)) {
idents <- factor(x = rep_len(x = project, length.out = ncol(x = counts)))
}
names(x = idents) <- colnames(x = counts)
# Initialize meta data
meta.init <- EmptyDF(n = ncol(x = counts))
row.names(x = meta.init) <- colnames(x = counts)
# Create the object
op <- options(Seurat.object.validate = FALSE)
on.exit(expr = options(op), add = TRUE)
object <- suppressWarnings(expr = new(
Class = 'Seurat',
assays = assay.list,
meta.data = meta.init,
active.assay = assay,
active.ident = idents,
graphs = list(),
neighbors = list(),
reductions = list(),
images = list(),
project.name = project,
misc = list(),
version = packageVersion(pkg = 'SeuratObject'),
commands = list(),
tools = list()
))
options(op)
object[['orig.ident']] <- idents
# Calculate nCount and nFeature
calcN_option <- getOption(
x = 'Seurat.object.assay.calcn',
default = Seurat.options$Seurat.object.assay.calcn
)
calcN_option <- calcN_option %||% TRUE
if (isTRUE(x = calcN_option)) {
ncalc <- CalcN(object = counts)
if (!is.null(x = ncalc)) {
names(x = ncalc) <- paste(names(x = ncalc), assay, sep = '_')
object[[]] <- ncalc
}
}
# Add provided meta data
if (!is.null(x = meta.data)) {
tryCatch(
expr = object[[]] <- meta.data,
error = function(e) {
warning(e$message, call. = FALSE, immediate. = TRUE)
}
)
}
# Validate and return
validObject(object = object)
return(object)
}
#' @method CreateSeuratObject StdAssay
#' @export
#'
CreateSeuratObject.StdAssay <- CreateSeuratObject.Assay
#' @rdname CreateSeuratObject
#' @method CreateSeuratObject Assay5
#' @export
#'
CreateSeuratObject.Assay5 <- CreateSeuratObject.StdAssay
#' @rdname DefaultAssay
#' @export
#' @method DefaultAssay Seurat
#'
#' @examples
#' # Get current default assay
#' DefaultAssay(object = pbmc_small)
#'
DefaultAssay.Seurat <- function(object, ...) {
CheckDots(...)
default <- slot(object = object, name = 'active.assay')
if (!length(x = default)) {
default <- NULL
}
return(default)
}
#' @rdname DefaultAssay
#' @export
#' @method DefaultAssay<- Seurat
#'
#' @examples
#' # Create dummy new assay to demo switching default assays
#' new.assay <- pbmc_small[["RNA"]]
#' Key(object = new.assay) <- "RNA2_"
#' pbmc_small[["RNA2"]] <- new.assay
#' # switch default assay to RNA2
#' DefaultAssay(object = pbmc_small) <- "RNA2"
#' DefaultAssay(object = pbmc_small)
#'
"DefaultAssay<-.Seurat" <- function(object, ..., value) {
CheckDots(...)
value <- value[1L]
value <- match.arg(arg = value, choices = Assays(object = object))
slot(object = object, name = 'active.assay') <- value
return(object)
}
#' @param assay Name of assay to get or set default \code{\link{FOV}} for;
#' pass \code{NA} to get or set the global default \code{\link{FOV}}
#'
#' @rdname DefaultFOV
#' @method DefaultFOV Seurat
#' @export
#'
DefaultFOV.Seurat <- function(object, assay = NULL, ...) {
assay <- assay[1L] %||% DefaultAssay(object = object)
fovs <- .FilterObjects(object = object, classes.keep = 'FOV')
if (is.na(x = assay)) {
return(fovs[1L])
}
assay <- match.arg(arg = assay, choices = Assays(object = object))
assay.fovs <- Filter(
f = function(x) {
return(DefaultAssay(object = object[[x]]) == assay)
},
x = fovs
)
if (!length(x = assay.fovs)) {
warning(
"No FOV associated with assay '",
assay,
"', using global default FOV",
call. = FALSE,
immediate. = TRUE
)
assay.fovs <- fovs[1L]
}
return(assay.fovs[1L])
}
#' @rdname DefaultFOV
#' @method DefaultFOV<- Seurat
#' @export
#'
"DefaultFOV<-.Seurat" <- function(object, assay = NA, ..., value) {
assay <- assay[1L] %||% DefaultAssay(object = object)
fovs <- .FilterObjects(object = object, classes.keep = 'FOV')
value <- match.arg(arg = value, choices = fovs)
if (!is.na(x = assay)) {
assay <- match.arg(arg = assay, choices = Assays(object = object))
if (DefaultAssay(object = object[[value]]) != assay) {
warning(
"FOV '",
value,
"' currently associated with assay '",
DefaultAssay(object = object[[value]]),
"', changing to '",
assay,
"'",
call. = FALSE,
immediate. = TRUE
)
DefaultAssay(object = object[[value]]) <- assay
}
fovs <- Filter(
f = function(x) {
return(DefaultAssay(object = object[[x]]) == assay)
},
x = fovs
)
}
fidx <- which(x = fovs == value)
forder <- c(fidx, setdiff(x = seq_along(along.with = fovs), y = fidx))
fovs <- fovs[forder]
iidx <- seq_along(along.with = Images(object = object))
midx <- MatchCells(new = Images(object = object), orig = fovs, ordered = TRUE)
iidx[sort(x = midx)] <- midx
slot(object = object, name = 'images') <- slot(
object = object,
name = 'images'
)[iidx]
return(object)
}
#' @param reduction Name of reduction to pull cell embeddings for
#'
#' @rdname Embeddings
#' @export
#' @method Embeddings Seurat
#'
#' @examples
#' # Get the embeddings from a specific DimReduc in a Seurat object
#' Embeddings(object = pbmc_small, reduction = "pca")[1:5, 1:5]
#'
Embeddings.Seurat <- function(object, reduction = 'pca', ...) {
return(Embeddings(object = object[[reduction]], ...))
}
#' @method Features Seurat
#' @export
#'
Features.Seurat <- function(x, assay = NULL, ...) {
assay <- assay[1L] %||% DefaultAssay(object = x)
assay <- match.arg(arg = assay, choices = Assays(object = x))
return(Features(x = x[[assay]], ...))
}
#' @param vars List of all variables to fetch, use keyword \dQuote{ident} to
#' pull identity classes
#' @param cells Cells to collect data for (default is all cells)
#' @param layer Layer to pull feature data for
#' @param clean Remove cells that are missing data; choose from:
#' \itemize{
#' \item \dQuote{\code{all}}: consider all columns for cleaning
#' \item \dQuote{\code{ident}}: consider all columns except the identity
#' class for cleaning
#' \item \dQuote{\code{project}}: consider all columns except the identity
#' class for cleaning; fill missing identity values with the object's project
#' \item \dQuote{\code{none}}: do not clean
#' }
#' Passing \code{TRUE} is a shortcut for \dQuote{\code{ident}}; passing
#' \code{FALSE} is a shortcut for \dQuote{\code{none}}
#' @param slot Deprecated in favor of \code{layer}
#'
#' @return A data frame with cells as rows and cellular data as columns
#'
#' @rdname FetchData
#' @method FetchData Seurat
#' @export
#'
#' @concept data-access
#'
#' @examples
#' pc1 <- FetchData(object = pbmc_small, vars = 'PC_1')
#' head(x = pc1)
#' head(x = FetchData(object = pbmc_small, vars = c('groups', 'ident')))
#'
FetchData.Seurat <- function(
object,
vars,
cells = NULL,
layer = NULL,
clean = TRUE,
slot = deprecated(),
...
) {
if (is_present(arg = slot)) {
.Deprecate(
when = '5.0.0',
what = 'FetchData(slot = )',
with = 'FetchData(layer = )'
)
layer <- layer %||% slot
}
object <- UpdateSlots(object = object)
if (isTRUE(x = clean)) {
clean <- 'ident'
} else if (isFALSE(x = clean)) {
clean <- 'none'
}
clean <- arg_match0(arg = clean, values = c('all', 'ident', 'none', 'project'))
# Find cells to use
cells <- cells %||% colnames(x = object)
if (is.numeric(x = cells)) {
cells <- colnames(x = object)[cells]
}
if (is.null(x = vars)) {
return(data.frame(row.names = cells))
}
data.fetched <- EmptyDF(n = length(x = cells))
row.names(x = data.fetched) <- cells
# Pull vars from object metadata
meta.vars <- intersect(x = vars, y = names(x = object[[]]))
meta.vars <- setdiff(x = meta.vars, y = names(x = data.fetched))
if (length(x = meta.vars)) {
meta.default <- intersect(x = meta.vars, y = rownames(x = object))
if (length(x = meta.default)) {
warn(message = paste0(
"The following variables were found in both object meta data and the default assay: ",
paste0(meta.default, collapse = ', '),
"\nReturning meta data; if you want the feature, please use the assay's key (eg. ",
paste0(Key(object = object)[DefaultAssay(object = object)], meta.default[1L]),
")"
))
}
meta.pull <- object[[meta.vars]]
cells.meta <- row.names(x = meta.pull)
cells.order <- MatchCells(new = cells.meta, orig = cells, ordered = TRUE)
cells.meta <- cells.meta[cells.order]
data.fetched[cells.meta, meta.vars] <- meta.pull[cells.meta, , drop = FALSE]
}
# Find all vars that are keyed
keyed.vars <- sapply(
X = Keys(object = object),
FUN = function(key) {
if (!length(x = key) || !nzchar(x = key)) {
return(character(length = 0L))
}
return(grep(pattern = paste0('^', key), x = setdiff(vars, meta.vars), value = TRUE))
},
simplify = FALSE,
USE.NAMES = TRUE
)
keyed.vars <- Filter(f = length, x = keyed.vars)
# Check spatial keyed vars
ret.spatial2 <- vapply(
X = names(x = keyed.vars),
FUN = function(x) {
return(inherits(x = object[[x]], what = 'FOV'))
},
FUN.VALUE = logical(length = 1L),
USE.NAMES = FALSE
)
if (any(ret.spatial2)) {
abort(message = "Spatial coordinates are no longer fetchable with FetchData")
}
# Find all keyed.vars
data.keyed <- lapply(
X = names(x = keyed.vars),
FUN = function(x) {
data.return <- switch(
EXPR = x,
meta.data = {
md <- gsub(pattern = '^md', replacement = '', x = keyed.vars[[x]])
df <- object[[md]][cells, , drop = FALSE]
names(x = df) <- paste0('md_', names(x = df))
df
},
tryCatch(
expr = FetchData(
object = object[[x]],
vars = keyed.vars[[x]],
cells = cells,
layer = layer,
...
),
varsNotFoundError = function(...) {
warn(message = paste0(
'The following keyed vars could not be found in object ',
sQuote(x = x),
':',
paste(keyed.vars[[x]], collapse = ', '),
'\nAttempting to pull from other locations'
))
return(NULL)
}
)
)
return(data.return)
}
)
for (i in seq_along(along.with = data.keyed)) {
df <- data.keyed[[i]]
data.fetched[row.names(x = df), names(x = df)] <- df
}
# Pull vars from the default assay
default.vars <- intersect(x = vars, y = rownames(x = object))
default.vars <- setdiff(x = default.vars, y = names(x = data.fetched))
if (length(x = default.vars)) {
df <- FetchData(
object = object[[DefaultAssay(object = object)]],
vars = default.vars,
cells = cells,
layer = layer,
...
)
data.fetched[row.names(x = df), names(x = df)] <- df
}
# Pull identities
if ('ident' %in% vars && !'ident' %in% names(x = object[[]])) {
data.fetched[cells, 'ident'] <- Idents(object = object)[cells]
}
# Try to find ambiguous vars
vars.missing <- setdiff(x = vars, y = names(x = data.fetched))
if (length(x = vars.missing)) {
# Search for vars in alternate assays
# Create a list to hold vars and the alternate assays they're found in
vars.alt <- vector(mode = 'list', length = length(x = vars.missing))
names(x = vars.alt) <- vars.missing
# Search through features in alternate assays to see if
# they contain our missing vars
for (assay in Assays(object = object)) {
vars.assay <- Filter(
f = function(x) {
return(x %in% Features(x = object, assay = assay, layer = layer))
},
x = vars.missing
)
# Add the alternate assay to our holding list for our found vars
for (var in vars.assay) {
vars.alt[[var]] <- append(x = vars.alt[[var]], values = assay)
}
}
# Vars found in multiple alternative assays are truly ambiguous, will not pull
vars.many <- names(x = Filter(
f = function(x) {
return(length(x = x) > 1)
},
x = vars.alt
))
if (length(x = vars.many)) {
warn(message = paste(
"Found the following features in more than one assay, excluding the default.",
"We will not include these in the final data frame:",
paste(vars.many, collapse = ', ')
))
}
# Missing vars are either ambiguous or not found in exactly one assay
vars.missing <- names(x = Filter(
f = function(x) {
return(length(x = x) != 1)
},
x = vars.alt
))
# Pull vars found in only one alternative assay
# Key this var to highlight that it was found in an alternate assay
vars.alt <- Filter(
f = function(x) {
return(length(x = x) == 1)
},
x = vars.alt
)
for (var in names(x = vars.alt)) {
assay <- vars.alt[[var]]
warn(message = paste(
'Could not find',
var,
'in the default search locations, found in',
sQuote(x = assay),
'assay instead'
))
keyed.var <- paste0(Key(object = object[[assay]]), var)
vars[vars == var] <- keyed.var
df <- FetchData(
object = object[[assay]],
vars = keyed.var,
cells = cells,
layer = layer
)
data.fetched[row.names(x = df), names(x = df)] <- df
}
}
# Name the vars not found in a warning (or error if no vars found)
# `m2` is an additional message if we're missing more than 10 vars
m2 <- if (length(x = vars.missing) > 10) {
paste(' (10 out of', length(x = vars.missing), 'shown)')
} else {
''
}
if (length(x = vars.missing) == length(x = vars)) {
abort(
message = paste0(
"None of the requested variables were found",
m2,
': ',
paste(head(x = vars.missing, n = 10L), collapse = ', ')
),
class = 'varsNotFoundError'
)
} else if (length(x = vars.missing)) {
warn(message = paste0(
"The following requested variables were not found",
m2,
': ',
paste(head(x = vars.missing, n = 10L), collapse = ', ')
))
}
.FilterData <- function(df) {
return(which(x = apply(X = df, MARGIN = 1L, FUN = \(x) all(is.na(x = x)))))
}
# Clean the fetched data
data.fetched <- switch(
EXPR = clean,
all = {
# Clean all vars
no.data <- .FilterData(df = data.fetched)
if (length(x = no.data)) {
warn(message = paste(
"Removing",
length(x = no.data),
"cells missing data for vars requested"
))
data.fetched[-no.data, , drop = FALSE]
} else {
data.fetched
}
},
ident = {
# Clean all vars except ident
cols.clean <- names(x = data.fetched)
if (ncol(x = data.fetched) > 2L && !'ident' %in% names(x = object[[]])) {
cols.clean <- setdiff(x = cols.clean, y = 'ident')
}
no.data <- .FilterData(df = data.fetched[, cols.clean, drop = FALSE])
if (length(x = no.data)) {
warn(message = paste(
"Removing",
length(x = no.data),
"cells missing data for vars requested"
))
data.fetched[-no.data, , drop = FALSE]
} else {
data.fetched
}
},
project = {
# Clean all vars except ident
cols.clean <- names(x = data.fetched)
if (ncol(x = data.fetched) > 2L && !'ident' %in% names(x = object[[]])) {
cols.clean <- setdiff(x = cols.clean, y = 'ident')
}
no.data <- .FilterData(df = data.fetched[, cols.clean, drop = FALSE])
if (length(x = no.data)) {
warn(message = paste(
"Removing",
length(x = no.data),
"cells missing data for vars requested"
))
data.fetched <- data.fetched[-no.data, , drop = FALSE]
}
# When all idents are `NA`, set to Project(object)
if ('ident' %in% names(x = data.fetched) && !'ident' %in% names(x = object[[]])) {
if (all(is.na(x = data.fetched$ident))) {
warn(message = paste(
"None of the cells requested have an identity class, returning",
sQuote(x = Project(object = object)),
"instead"
))
data.fetched$ident <- Project(object = object)
}
}
data.fetched
},
# Don't clean vars
data.fetched
)
vars.return <- intersect(x = vars, y = names(x = data.fetched))
data.fetched <- data.fetched[, vars.return, drop = FALSE]
# data.order <- na.omit(object = pmatch(
# x = vars,
# table = names(x = data.fetched)
# ))
# if (length(x = data.order) > 1) {
# data.fetched <- data.fetched[, data.order]
# }
# colnames(x = data.fetched) <- vars[vars %in% fetched]
return(data.fetched)
}
#' @param assay Specific assay to get data from or set data for;
#' defaults to the \link[=DefaultAssay]{default assay}
#'
#' @rdname AssayData
#' @export
#' @method GetAssayData Seurat
#'
#' @order 3
#'
#' @examples
#' # Get assay data from the default assay in a Seurat object
#' GetAssayData(object = pbmc_small, layer = "data")[1:5,1:5]
#'
GetAssayData.Seurat <- function(
object,
assay = NULL,
layer = NULL,
slot = deprecated(),
...
) {
CheckDots(...)
if (is_present(arg = slot)) {
.Deprecate(
when = '5.0.0',
what = 'GetAssayData(slot = )',
with = 'GetAssayData(layer = )'
)
layer <- slot
}
object <- UpdateSlots(object = object)
assay <- assay %||% DefaultAssay(object = object)
assay <- arg_match(arg = assay, values = Assays(object = object))
return(GetAssayData(object = object[[assay]], layer = layer))
}
#' @param image Name of \code{SpatialImage} object to pull image data for; if
#' \code{NULL}, will attempt to select an image automatically
#'
#' @rdname GetImage
#' @method GetImage Seurat
#' @export
#'
GetImage.Seurat <- function(
object,
mode = c('grob', 'raster', 'plotly', 'raw'),
image = NULL,
...
) {
mode <- match.arg(arg = mode)
image <- image %||% DefaultImage(object = object)
if (is.null(x = image)) {
stop("No images present in this Seurat object", call. = FALSE)
}
return(GetImage(object = object[[image]], mode = mode, ...))
}
#' @param image Name of \code{SpatialImage} object to get coordinates for; if
#' \code{NULL}, will attempt to select an image automatically
#'
#' @rdname GetTissueCoordinates
#' @method GetTissueCoordinates Seurat
#' @export
#'
GetTissueCoordinates.Seurat <- function(object, image = NULL, ...) {
image <- image %||% DefaultImage(object = object)
if (is.null(x = image)) {
stop("No images present in this Seurat object", call. = FALSE)
}
return(GetTissueCoordinates(object = object[[image]], ...))
}
#' @param assay Name of assay to pull highly variable feature information for
#'
#' @importFrom tools file_path_sans_ext
#'
#' @rdname VariableFeatures
#' @export
#' @method HVFInfo Seurat
#'
#' @order 6
#'
#' @examples
#' # Get the HVF info from a specific Assay in a Seurat object
#' HVFInfo(object = pbmc_small, assay = "RNA")[1:5, ]
#'
HVFInfo.Seurat <- function(
object,
method = NULL,
status = FALSE,
assay = NULL,
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
}
object <- UpdateSlots(object = object)
assay <- assay %||% DefaultAssay(object = object)
if (is.null(x = method)) {
cmds <- apply(
X = expand.grid(
c('FindVariableFeatures', 'SCTransform'),
.FilterObjects(object = object, classes.keep = c('Assay', 'Assay5'))
),
MARGIN = 1,
FUN = paste,
collapse = '.'
)
find.command <- Command(object = object)[Command(object = object) %in% cmds]
if (length(x = find.command) < 1) {
abort(message = "Please run either 'FindVariableFeatures' or 'SCTransform'")
}
find.command <- find.command[length(x = find.command)]
test.command <- paste(file_path_sans_ext(x = find.command), assay, sep = '.')
find.command <- ifelse(
test = test.command %in% Command(object = object),
yes = test.command,
no = find.command
)
method <- switch(
EXPR = file_path_sans_ext(x = find.command),
'FindVariableFeatures' = Command(
object = object,
command = find.command,
value = 'selection.method'
),
'SCTransform' = 'sct',
stop("Unknown command for finding variable features: '", find.command, "'", call. = FALSE)
)
}
return(HVFInfo(
object = object[[assay]],
method = method,
status = status
))
}
#' @rdname Idents
#' @export
#' @method Idents Seurat
#'
Idents.Seurat <- function(object, ...) {
CheckDots(...)
# object <- UpdateSlots(object = object)
return(slot(object = object, name = 'active.ident'))
}
#' @param cells Set cell identities for specific cells
#' @param drop Drop unused levels
#' @param replace Replace identities for unset cells with \code{NA}
#'
#' @rdname Idents
#' @export
#' @method Idents<- Seurat
#'
"Idents<-.Seurat" <- function(
object,
cells = NULL,
drop = FALSE,
replace = FALSE,
...,
value
) {
CheckDots(...)
object <- UpdateSlots(object = object)
if (!(is.factor(x = value) || is.atomic(x = value))) {
abort(message = "'value' must be a factor or vector")
}
cells <- cells %||% names(x = value) %||% colnames(x = object)
if (is.numeric(x = cells)) {
cells <- colnames(x = object)[cells]
}
cells <- intersect(x = cells, y = colnames(x = object))
# cells <- match(x = cells, table = colnames(x = object))
if (!length(x = cells)) {
warn(message = 'Cannot find cells provided')
return(object)
}
idents.new <- if (length(x = value) == 1 && value %in% names(x = object[[]])) {
# unlist(x = object[[value]], use.names = FALSE)[cells]
object[[value, drop = TRUE]][cells]
} else {
if (is.list(x = value)) {
value <- unlist(x = value, use.names = FALSE)
}
rep_len(x = value, length.out = length(x = cells))
}
new.levels <- if (is.factor(x = idents.new)) {
levels(x = idents.new)
} else {
unique(x = idents.new)
}
levels <- union(x = new.levels, y = levels(x = object))
idents.new <- as.vector(x = idents.new)
idents <- if (isTRUE(x = replace)) {
rep_len(x = NA_character_, length.out = ncol(x = object))
} else {
as.vector(x = Idents(object = object))
}
names(x = idents) <- colnames(x = object)
idents[cells] <- idents.new
idents[is.na(x = idents)] <- 'NA'
levels <- intersect(x = levels, y = unique(x = idents))
names(x = idents) <- colnames(x = object)
missing.cells <- which(x = is.na(x = names(x = idents)))
if (length(x = missing.cells) > 0) {
idents <- idents[-missing.cells]
}
idents <- factor(x = idents, levels = levels)
slot(object = object, name = 'active.ident') <- idents
if (isTRUE(x = drop)) {
object <- droplevels(x = object)
}
return(object)
}
#' @param assay Name of assay to split layers
#'
#' @rdname SplitLayers
#' @method JoinLayers Seurat
#' @export
#'
JoinLayers.Seurat <- function(
object,
assay = NULL,
layers = NULL,
new = NULL,
...
) {
assay <- assay %||% DefaultAssay(object)
object[[assay]] <- JoinLayers(
object = object[[assay]],
layers = layers,
new = new,
...
)
return(object)
}
#' @rdname Key
#' @export
#' @method Key Seurat
#'
#' @examples
#' # Show all keys associated with a Seurat object
#' Key(object = pbmc_small)
#' Keys(object = pbmc_small)
#'
Key.Seurat <- function(object, ...) {
CheckDots(...)
object <- UpdateSlots(object = object)
return(c(
meta.data = .MetaKey,
vapply(
X = .FilterObjects(
object = object,
classes.keep = c('SpatialImage', 'KeyMixin')
),
FUN = \(x) Key(object = object[[x]]),
FUN.VALUE = character(length = 1L),
USE.NAMES = TRUE
)
))
}
#' @rdname Key
#' @export
#' @method Keys Seurat
#'
Keys.Seurat <- Key.Seurat
#' @param assay Name of assay to fetch layer data from or assign layer data to
#'
#' @rdname Layers
#' @method LayerData Seurat
#' @export
#'
LayerData.Seurat <- function(
object,
layer = NULL,
assay = NULL,
slot = deprecated(),
...
) {
if (is_present(arg = slot)) {
deprecate_stop(
when = "5.0.0",
what = "LayerData(slot = )",
with = "LayerData(layer = )"
)
}
assay <- assay %||% DefaultAssay(object = object)
assay <- arg_match(arg = assay, values = Assays(object = object))
return(LayerData(object = object[[assay]], layer = layer, ...))
}
#' @rdname Layers
#' @method LayerData<- Seurat
#' @export
#'
"LayerData<-.Seurat" <- function(object, layer, assay = NULL, ..., value) {
assay <- assay %||% DefaultAssay(object = object)
assay <- arg_match(arg = assay, values = Assays(object = object))
LayerData(object = object[[assay]], layer = layer, ...) <- value
return(object)
}
#' @rdname Layers
#' @method Layers Seurat
#' @export
#'
Layers.Seurat <- function(object, search = NA, assay = NULL, ...) {
assay <- assay %||% DefaultAssay(object = object)
assay <- arg_match(arg = assay, values = Assays(object = object))
return(Layers(object = object[[assay]], search = search, ...))
}
#' @param reduction Name of reduction to pull feature loadings for
#'
#' @rdname Loadings
#' @export
#' @method Loadings Seurat
#'
#' @examples
#' # Get the feature loadings for a specified DimReduc in a Seurat object
#' Loadings(object = pbmc_small, reduction = "pca")[1:5,1:5]
#'
Loadings.Seurat <- function(object, reduction = 'pca', projected = FALSE, ...) {
object <- UpdateSlots(object = object)
return(Loadings(object = object[[reduction]], projected = projected, ...))
}
#' @rdname Misc
#' @export
#' @method Misc Seurat
#'
#' @examples
#' # Get the misc info
#' Misc(object = pbmc_small, slot = "example")
#'
Misc.Seurat <- .Misc
#' @rdname Misc
#' @export
#' @method Misc<- Seurat
#'
#' @examples
#'# Add misc info
#' Misc(object = pbmc_small, slot = "example") <- "testing_misc"
#'
"Misc<-.Seurat" <- `.Misc<-`
#' @rdname Project
#' @export
#' @method Project Seurat
#'
Project.Seurat <- function(object, ...) {
CheckDots(...)
object <- UpdateSlots(object = object)
return(slot(object = object, name = 'project.name'))
}
#' @rdname Project
#' @export
#' @method Project<- Seurat
#'
"Project<-.Seurat" <- function(object, ..., value) {
CheckDots(...)
object <- UpdateSlots(object = object)
slot(object = object, name = 'project.name') <- as.character(x = value)
return(object)
}
#' @param reverse Reverse ordering
#' @param afxn Function to evaluate each identity class based on; default is
#' \code{\link[base]{mean}}
#' @param reorder.numeric Rename all identity classes to be increasing numbers
#' starting from 1 (default is FALSE)
#'
#' @rdname Idents
#' @export
#' @method ReorderIdent Seurat
#'
ReorderIdent.Seurat <- function(
object,
var,
reverse = FALSE,
afxn = mean,
reorder.numeric = FALSE,
...
) {
object <- UpdateSlots(object = object)
data.use <- FetchData(object = object, vars = var, ...)[, 1]
rfxn <- ifelse(
test = reverse,
yes = function(x) {
return(max(x) + 1 - x)
},
no = identity
)
new.levels <- names(x = rfxn(x = sort(x = tapply(
X = data.use,
INDEX = Idents(object = object),
FUN = afxn
))))
new.idents <- factor(
x = Idents(object = object),
levels = new.levels,
ordered = TRUE
)
if (reorder.numeric) {
new.idents <- rfxn(x = rank(x = tapply(
X = data.use,
INDEX = as.numeric(x = new.idents),
FUN = mean
)))[as.numeric(x = new.idents)]
new.idents <- factor(
x = new.idents,
levels = 1:length(x = new.idents),
ordered = TRUE
)
}
Idents(object = object) <- new.idents
return(object)
}
#' @param add.cell.id prefix to add cell names
#' @param for.merge Deprecated
#'
#' @details
#' If \code{add.cell.id} is set a prefix is added to existing cell names. If
#' \code{new.names} is set these will be used to replace existing names.
#'
#' @rdname RenameCells
#' @export
#' @method RenameCells Seurat
#'
#' @examples
#' # Rename cells in a Seurat object
#' head(x = colnames(x = pbmc_small))
#' pbmc_small <- RenameCells(object = pbmc_small, add.cell.id = "A")
#' head(x = colnames(x = pbmc_small))
#'
RenameCells.Seurat <- function(
object,
add.cell.id = missing_arg(),
new.names = missing_arg(),
for.merge = deprecated(),
...
) {
CheckDots(...)
object <- UpdateSlots(object = object)
working.cells <- Cells(x = object)
if (is_present(arg = for.merge)) {
.Deprecate(when = '5.0.0', what = 'RenameCells(for.merge = )')
}
if (is_missing(x = add.cell.id) && is_missing(x = new.names)) {
abort(message = "One of 'add.cell.id' and 'new.names' must be set")
}
if (!is_missing(x = add.cell.id) && !is_missing(x = new.names)) {
abort(message = "Only one of 'add.cell.id' and 'new.names' may be set")
}
if (!missing(x = add.cell.id)) {
new.cell.names <- paste(add.cell.id, working.cells, sep = "_")
} else {
if (length(x = new.names) == length(x = working.cells)) {
new.cell.names <- new.names
} else {
abort(message = paste0(
"the length of 'new.names' (",
length(x = new.names),
") must be the same as the number of cells (",
length(x = working.cells),
")"
))
}
}
old.names <- colnames(x = object)
new.cell.names.global <- old.names
new.cell.names.global[match(x = working.cells, table = old.names)] <- new.cell.names
new.cell.names <- new.cell.names.global
# rename the cell-level metadata first to rename colname()
old.meta.data <- object[[]]
row.names(x = old.meta.data) <- new.cell.names
slot(object = object, name = "meta.data") <- old.meta.data
# rename the active.idents
old.ids <- Idents(object = object)
names(x = old.ids) <- new.cell.names
Idents(object = object) <- old.ids
names(x = new.cell.names) <- old.names
# rename in the assay objects
assays <- .FilterObjects(object = object, classes.keep = 'Assay')
for (i in assays) {
slot(object = object, name = "assays")[[i]] <- RenameCells(
object = object[[i]],
new.names = new.cell.names[colnames(x = object[[i]])]
)
}
# rename in the assay5 objects
assays5 <- .FilterObjects(object = object, classes.keep = 'Assay5')
for (i in assays5) {
slot(object = object, name = "assays")[[i]] <- RenameCells(
object = object[[i]],
new.names = new.cell.names[colnames(x = object[[i]])]
)
}
# rename in the DimReduc objects
dimreducs <- .FilterObjects(object = object, classes.keep = 'DimReduc')
for (i in dimreducs) {
slot(object = object, name = "reductions")[[i]] <- RenameCells(
object = object[[i]],
new.names = new.cell.names[Cells(x = object[[i]])]
)
}
# rename the graphs
graphs <- .FilterObjects(object = object, classes.keep = "Graph")
for (g in graphs) {
graph.g <- object[[g]]
rownames(graph.g) <- colnames(graph.g) <- new.cell.names[colnames(x = graph.g)]
slot(object = object, name = "graphs")[[g]] <- graph.g
}
# Rename the images
for (i in Images(object = object)) {
slot(object = object, name = "images")[[i]] <- RenameCells(
object = object[[i]],
new.names = unname(
obj = new.cell.names[Cells(x = object[[i]], boundary = NA)]
)
)
}
# Rename the Neighbor
for (i in Neighbors(object = object)) {
slot(object = object, name = "neighbors")[[i]] <- RenameCells(
object = object[[i]],
old.names = Cells(x = object[[i]]),
new.names = new.cell.names[Cells(x = object[[i]])]
)
}
validObject(object)
return(object)
}
#' @rdname Idents
#' @export
#' @method RenameIdents Seurat
#'
RenameIdents.Seurat <- function(object, ...) {
ident.pairs <- tryCatch(
expr = as.list(x = ...),
error = function(e) {
return(list(...))
}
)
if (is.null(x = names(x = ident.pairs))) {
stop("All arguments must be named with the old identity class")
}
if (!all(sapply(X = ident.pairs, FUN = length) == 1)) {
stop("Can only rename identity classes to one value")
}
if (!any(names(x = ident.pairs) %in% levels(x = object))) {
stop("Cannot find any of the provided identities")
}
cells.idents <- CellsByIdentities(object = object)
for (i in rev(x = names(x = ident.pairs))) {
if (!i %in% names(x = cells.idents)) {
warning("Cannot find identity ", i, call. = FALSE, immediate. = TRUE)
next
}
Idents(object = object, cells = cells.idents[[i]]) <- ident.pairs[[i]]
}
return(object)
}
#' @rdname AssayData
#' @export
#' @method SetAssayData Seurat
#'
#' @order 4
#'
#' @examples
#' # Set an Assay layer through the Seurat object
#' count.data <- GetAssayData(object = pbmc_small[["RNA"]], layer = "counts")
#' count.data <- as.matrix(x = count.data + 1)
#' new.seurat.object <- SetAssayData(
#' object = pbmc_small,
#' layer = "counts",
#' new.data = count.data,
#' assay = "RNA"
#' )
#'
SetAssayData.Seurat <- function(
object,
layer = 'data',
new.data,
slot = deprecated(),
assay = NULL,
...
) {
CheckDots(...)
if (is_present(arg = slot)) {
.Deprecate(
when = '5.0.0',
what = 'SetAssayData(slot = )',
with = 'SetAssayData(layer = )'
)
layer <- slot
}
object <- UpdateSlots(object = object)
assay <- assay %||% DefaultAssay(object = object)
object[[assay]] <- SetAssayData(
object = object[[assay]],
layer = layer,
new.data = new.data,
...
)
return(object)
}
#' @rdname Idents
#' @export
#' @method SetIdent Seurat
#'
SetIdent.Seurat <- function(object, cells = NULL, value, ...) {
#message(
# 'With Seurat 3.X, setting identity classes can be done as follows:\n',
# 'Idents(object = ',
# deparse(expr = substitute(expr = object)),
# if (!is.null(x = cells)) {
# paste0(', cells = ', deparse(expr = substitute(expr = cells)))
# },
# ') <- ',
# deparse(expr = substitute(expr = value))
#)
CheckDots(...)
object <- UpdateSlots(object = object)
Idents(object = object, cells = cells) <- value
return(object)
}
#' @rdname VariableFeatures
#' @export
#' @method SpatiallyVariableFeatures Seurat
#'
#' @order 10
#'
SpatiallyVariableFeatures.Seurat <- function(
object,
method = "moransi",
assay = NULL,
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
}
assay <- assay %||% DefaultAssay(object = object)
return(SpatiallyVariableFeatures(
object = object[[assay]],
method = method,
decreasing = decreasing
))
}
#' @param save.name Store current identity information under this name
#'
#' @rdname Idents
#' @export
#' @method StashIdent Seurat
#'
StashIdent.Seurat <- function(object, save.name = 'orig.ident', ...) {
deprecate_soft(
when = '3.0.0',
what = 'StashIdent()',
details = paste0(
"Please use ",
deparse(expr = substitute(expr = object)),
'[[',
deparse(expr = substitute(expr = save.name)),
']] <- Idents(',
deparse(expr = substitute(expr = object)),
')'
)
)
CheckDots(...)
object <- UpdateSlots(object = object)
object[[save.name]] <- Idents(object = object)
return(object)
}
#' @param reduction Name of reduction to use
#'
#' @rdname Stdev
#' @export
#' @method Stdev Seurat
#'
#' @examples
#' # Get the standard deviations for each PC from the Seurat object
#' Stdev(object = pbmc_small, reduction = "pca")
#'
Stdev.Seurat <- function(object, reduction = 'pca', ...) {
CheckDots(...)
return(Stdev(object = object[[reduction]]))
}
#' @importFrom tools file_path_sans_ext
#'
#' @rdname VariableFeatures
#' @export
#' @method SVFInfo Seurat
#'
#' @order 9
#'
SVFInfo.Seurat <- function(
object,
method = c("markvariogram", "moransi"),
status = FALSE,
assay = NULL,
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
}
assay <- assay %||% DefaultAssay(object = object)
return(SVFInfo(object = object[[assay]], method = method, status = status))
}
#' @param slot Name of tool to pull
#'
#' @rdname Tool
#' @export
#' @method Tool Seurat
#'
Tool.Seurat <- function(object, slot = NULL, ...) {
CheckDots(...)
object <- UpdateSlots(object = object)
if (is.null(x = slot)) {
return(names(x = slot(object = object, name = 'tools')))
}
return(slot(object = object, name = 'tools')[[slot]])
}
#' @rdname Tool
#' @export
#' @method Tool<- Seurat
#'
"Tool<-.Seurat" <- function(object, ..., value) {
CheckDots(...)
object <- UpdateSlots(object = object)
calls <- as.character(x = sys.calls())
calls <- lapply(
X = strsplit(x = calls, split = '(', fixed = TRUE),
FUN = '[',
1
)
tool.call <- min(grep(pattern = 'Tool<-', x = calls))
if (tool.call <= 1) {
stop("'Tool<-' cannot be called at the top level", call. = FALSE)
}
tool.call <- calls[[tool.call - 1]]
class.call <- unlist(x = strsplit(
x = as.character(x = sys.call())[1],
split = '.',
fixed = TRUE
))
class.call <- class.call[length(x = class.call)]
tool.call <- sub(
pattern = paste0('\\.', class.call, '$'),
replacement = '',
x = tool.call,
perl = TRUE
)
slot(object = object, name = 'tools')[[tool.call]] <- value
return(object)
}
#' @rdname VariableFeatures
#' @export
#' @method VariableFeatures Seurat
#'
#' @order 7
#'
VariableFeatures.Seurat <- function(
object,
method = NULL,
assay = NULL,
nfeatures = NULL,
layer = NA,
simplify = TRUE,
selection.method = deprecated(),
...
) {
CheckDots(...)
if (is_present(arg = selection.method)) {
.Deprecate(
when = '5.0.0',
what = 'VariableFeatures(selection.method = )',
with = 'VariableFeatures(method = )'
)
method <- selection.method
}
assay <- assay %||% DefaultAssay(object = object)
return(VariableFeatures(
object = object[[assay]],
method = method,
nfeatures = nfeatures,
layer = layer,
simplify = simplify,
...
))
}
#' @rdname VariableFeatures
#' @export
#' @method VariableFeatures<- Seurat
#'
#' @order 8
#'
"VariableFeatures<-.Seurat" <- function(object, assay = NULL, ..., value) {
CheckDots(...)
object <- UpdateSlots(object = object)
assay <- assay %||% DefaultAssay(object = object)
VariableFeatures(object = object[[assay]]) <- value
return(object)
}
#' @param idents A vector of identity classes to keep
#' @param slot Slot to pull feature data for
#' @param downsample Maximum number of cells per identity class, default is
#' \code{Inf}; downsampling will happen after all other operations, including
#' inverting the cell selection
#' @param seed Random seed for downsampling. If NULL, does not set a seed
#' @inheritDotParams CellsByIdentities
#'
#' @importFrom stats na.omit
#' @importFrom rlang is_quosure enquo eval_tidy
#'
#' @rdname WhichCells
#' @export
#' @method WhichCells Seurat
#'
WhichCells.Seurat <- function(
object,
cells = NULL,
idents = NULL,
expression,
slot = 'data',
invert = FALSE,
downsample = Inf,
seed = 1,
...
) {
CheckDots(..., fxns = CellsByIdentities)
if (!is.null(x = seed)) {
set.seed(seed = seed)
}
object <- UpdateSlots(object = object)
cells <- cells %||% colnames(x = object)
if (is.numeric(x = cells)) {
cells <- colnames(x = object)[cells]
}
cell.order <- cells
if (!is.null(x = idents)) {
if (any(!idents %in% levels(x = Idents(object = object)))) {
stop(
"Cannot find the following identities in the object: ",
paste(
idents[!idents %in% levels(x = Idents(object = object))],
sep = ', '
)
)
}
cells.idents <- unlist(x = lapply(
X = idents,
FUN = function(i) {
cells.use <- which(x = as.vector(x = Idents(object = object)) == i)
cells.use <- names(x = Idents(object = object)[cells.use])
return(cells.use)
}
))
cells <- intersect(x = cells, y = cells.idents)
}
if (!missing(x = expression)) {
objects.use <- .FilterObjects(
object = object,
classes.keep = c('Assay', 'StdAssay', 'DimReduc', 'SpatialImage')
)
object.keys <- sapply(
X = objects.use,
FUN = function(i) {
return(Key(object = object[[i]]))
}
)
key.pattern <- paste0('^', object.keys, collapse = '|')
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 = '(',
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 %in% colnames(x = object[[]]) |
grepl(pattern = key.pattern, x = expr.char, perl = TRUE)
)
data.subset <- FetchData(
object = object,
vars = unique(x = expr.char[vars.use]),
cells = cells,
layer = slot
)
cells <- rownames(x = data.subset)[eval_tidy(expr = expr, data = data.subset)]
}
if (isTRUE(x = invert)) {
cell.order <- colnames(x = object)
cells <- colnames(x = object)[!colnames(x = object) %in% cells]
}
# only perform downsampling when "downsample" is smaller than the number of cells
if(downsample <= length(cells)){
cells <- CellsByIdentities(object = object, cells = cells, ...)
cells <- lapply(
X = cells,
FUN = function(x) {
if (length(x = x) > downsample) {
x <- sample(x = x, size = downsample, replace = FALSE)
}
return(x)
}
)
cells <- as.character(x = na.omit(object = unlist(x = cells, use.names = FALSE)))
}
cells <- cells[na.omit(object = match(x = cell.order, table = cells))]
return(cells)
}
#' @rdname Version
#' @method Version Seurat
#' @export
#'
Version.Seurat <- function(object, ...) {
CheckDots(...)
return(slot(object = object, name = 'version'))
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for R-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Dollar-sign Autocompletion
#'
#' Autocompletion for \code{$} access on a \code{\link{Seurat}} object
#'
#' @inheritParams utils::.DollarNames
#' @param x A \code{\link{Seurat}} object
#'
#' @return The meta data matches for \code{pattern}
#'
#' @importFrom utils .DollarNames
#'
#' @keywords internal
#'
#' @method .DollarNames Seurat
#' @export
#'
#' @concept seurat
#'
#' @inherit .DollarNames.Assay5 seealso
#'
".DollarNames.Seurat" <- function(x, pattern = '') {
meta.data <- as.list(x = colnames(x = x[[]]))
names(x = meta.data) <- unlist(x = meta.data)
return(.DollarNames(x = meta.data, pattern = pattern))
}
#' Cell-Level Meta Data
#'
#' Get and set cell-level meta data
#'
#' @inheritParams .DollarNames.Seurat
#' @param i Name of cell-level meta data
#' @param j Ignored
#' @template param-dots-ignored
#'
#' @return {$}: Metadata column \code{i} for object \code{x};
#' \strong{note}: unlike \code{[[}, \code{$} drops the shape of the metadata
#' to return a vector instead of a data frame
#'
#' @method $ Seurat
#' @export
#'
#' @family seurat
#'
#' @examples
#' # Get metadata using `$'
#' head(pbmc_small$groups)
#'
"$.Seurat" <- function(x, i) {
return(x[[i, drop = TRUE]])
}
#' @param value A vector to add as cell-level meta data
#'
#' @return \code{$<-}: \code{x} with metadata \code{value} saved as \code{i}
#'
#' @rdname cash-.Seurat
#'
#' @method $<- Seurat
#' @export
#'
#' @examples
#' # Add metadata using the `$' operator
#' set.seed(42)
#' pbmc_small$value <- sample(1:3, size = ncol(pbmc_small), replace = TRUE)
#' head(pbmc_small[["value"]])
#'
"$<-.Seurat" <- function(x, i, ..., value) {
x[[i]] <- value
return(x)
}
#' @return \code{[}: object \code{x} with features \code{i} and cells \code{j}
#'
#' @rdname subset.Seurat
#'
#' @method [ Seurat
#' @export
#'
#' @order 2
#'
#' @examples
#' # `[` examples
#' pbmc_small[VariableFeatures(object = pbmc_small), ]
#' pbmc_small[, 1:10]
#'
"[.Seurat" <- function(x, i, j, ...) {
x <- UpdateSlots(object = x)
if (missing(x = i) && missing(x = j)) {
return(x)
}
if (missing(x = i)) {
i <- NULL
} else if (missing(x = j)) {
j <- colnames(x = x)
}
if (is.logical(x = i)) {
if (length(i) != nrow(x = x)) {
stop("Incorrect number of logical values provided to subset features")
}
i <- rownames(x = x)[i]
}
if (is.logical(x = j)) {
if (length(j) != ncol(x = x)) {
stop("Incorrect number of logical values provided to subset cells")
}
j <- colnames(x = x)[j]
}
if (is.numeric(x = i)) {
i <- rownames(x = x)[i]
}
if (is.numeric(x = j)) {
j <- colnames(x = x)[j]
}
return(subset.Seurat(x = x, features = i, cells = j, ...))
}
#' Subobjects and Cell-Level Meta Data
#'
#' The \code{[[} operator pulls either subobjects
#' (eg. \link[=Assay]{v3} or \link[=Assay5]{v5} assays,
#' \link[=DimReduc]{dimensional reduction} information,
#' or \link[=Graph]{nearest-neighbor graphs}) or cell-level
#' meta data from a \code{\link{Seurat}} object
#'
#' @inheritParams $.Seurat
#' @param drop See \code{\link[base]{drop}}
#' @param na.rm Remove cells where meta data is all \code{NA}
#'
#' @return Varies based on the value of \code{i}:
#' \itemize{
#' \item If \code{i} is missing, a data frame with cell-level meta data
#' \item If \code{i} is a vector with cell-level meta data names, a data frame
#' (or vector of \code{drop = TRUE}) with cell-level meta data requested
#' \item If \code{i} is a one-length character with the
#' \link[=names.Seurat]{name of a subobject}, the
#' subobject specified by \code{i}
#' }
#'
#' @method [[ Seurat
#' @export
#'
#' @family seurat
#'
#' @seealso See \link[=$.Seurat]{here} for adding meta data with \code{[[<-},
#' \link[=[[<-,Seurat]{here} for adding subobjects with \code{[[<-}, and
#' \link[=[[<-,Seurat,NULL]{here} for removing subobjects and cell-level meta
#' data with \code{[[<-}
#'
#' @examples
#' # Get the cell-level metadata data frame
#' head(pbmc_small[[]])
#'
#' # Pull specific metadata information
#' head(pbmc_small[[c("letter.idents", "groups")]])
#' head(pbmc_small[["groups", drop = TRUE]])
#'
#' # Get a sub-object (eg. an `Assay` or `DimReduc`)
#' pbmc_small[["RNA"]]
#' pbmc_small[["pca"]]
#'
"[[.Seurat" <- function(x, i = missing_arg(), ..., drop = FALSE, na.rm = FALSE) {
md <- slot(object = x, name = 'meta.data')
if (is_missing(x = i)) {
return(md)
} else if (is.null(x = i)) {
return(NULL)
} else if (!length(x = i)) {
return(data.frame(row.names = row.names(x = md)))
}
# Correct invalid `i`
meta.cols <- names(x = md)
if (is_bare_integerish(x = i)) {
if (all(i > length(x = meta.cols))) {
abort(message = paste(
"Invalid integer indexing:",
"all integers greater than the number of meta columns"
))
}
i <- meta.cols[as.integer(x = i[i <= length(x = meta.cols)])]
}
if (!is.character(x = i)) {
abort(message = "'i' must be a character vector")
}
# Determine if we're pulling cell-level meta data
# or a sub-object
slot.use <- if (length(x = i) == 1L) {
.FindObject(object = x, name = i)
} else {
NULL
}
# Pull cell-level meta data
if (is.null(x = slot.use)) {
i <- tryCatch(
expr = arg_match(arg = i, values = meta.cols, multiple = TRUE),
error = function(e) {
#error message that indicates which colnames not found
abort(
message = paste(
paste(sQuote(x = setdiff(x = i, y = meta.cols)), collapse = ', '),
"not found in this Seurat object\n",
e$body
),
call = rlang::caller_env(n = 4L)
)
}
)
# Pull the cell-level meta data
data.return <- md[, i, drop = FALSE, ...]
# If requested, remove NAs
if (isTRUE(x = na.rm)) {
idx.na <- apply(X = is.na(x = data.return), MARGIN = 1L, FUN = all)
data.return <- data.return[!idx.na, , drop = FALSE]
} else {
idx.na <- rep_len(x = FALSE, length.out = ncol(x = x))
}
# If requested, coerce to a vector
if (isTRUE(x = drop)) {
data.return <- unlist(x = data.return, use.names = FALSE)
names(x = data.return) <- rep.int(
x = colnames(x = x)[!idx.na],
times = length(x = i)
)
}
return(data.return)
}
# Pull a sub-object
return(slot(object = x, name = slot.use)[[i]])
}
#' @inherit dim.Assay5 return title description details
#'
#' @inheritParams .DollarNames.Seurat
#'
#' @method dim Seurat
#' @export
#'
#' @family seurat
#'
#' @examples
#' # Get the number of features in an object
#' nrow(pbmc_small)
#'
#' # Get the number of cells in an object
#' ncol(pbmc_small)
#'
dim.Seurat <- function(x) {
return(c(
nrow(x = x[[DefaultAssay(object = x)]]) %||% 0L,
length(x = colnames(x = x)) %||% 0L
))
}
#' Feature and Cell Names
#'
#' Get and set feature and cell inames in \code{\link{Seurat}} objects
#'
#' @inheritParams .DollarNames.Seurat
#' @inheritParams dimnames.Assay5
#'
#' @return \code{dimnames}: A two-length list with the following values:
#' \itemize{
#' \item A character vector with all features in the
#' \link[=DefaultAssay]{default assay}
#' \item A character vector with all cells in \code{x}
#' }
#'
#' @method dimnames Seurat
#' @export
#'
#' @family seurat
#' @family dimnames
#'
#' @examples
#' # Get the feature names of an object
#' head(rownames(pbmc_small))
#'
#' # Get the cell names of an object
#' head(colnames(pbmc_small))
#'
dimnames.Seurat <- function(x) {
return(list(
rownames(x = x[[DefaultAssay(object = x)]]),
row.names(x = slot(object = x, name = 'meta.data'))
))
}
#' @return \code{dimnames<-}: \code{x} with the feature and/or cell
#' names updated to \code{value}
#'
#' @rdname dimnames.Seurat
#'
#' @method dimnames<- Seurat
#' @export
#'
#' @examples
#' colnames(pbmc_small)[1] <- "newcell"
#' head(colnames(pbmc_small))
#'
"dimnames<-.Seurat" <- 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)
onames <- dimnames(x = x)
# Rename cells at the Seurat level
names(x = slot(object = x, name = 'active.ident')) <-
row.names(x = slot(object = x, name = 'meta.data')) <-
value[[2L]]
# Rename features/cells at the Assay level
v3warn <- FALSE
for (assay in Assays(object = x)) {
anames <- dimnames(x = x[[assay]])
if (inherits(x = x[[assay]], what = 'StdAssay')) {
afeatures <- MatchCells(
new = onames[[1L]],
orig = anames[[1L]],
ordered = TRUE
)
if (length(x = afeatures)) {
idx <- MatchCells(new = anames[[1L]], orig = onames[[1L]])
anames[[1L]][idx] <- value[[1L]][afeatures]
}
} else if (isFALSE(x = v3warn) && any(onames[[1L]] != value[[1L]])) {
warning(
"Renaming features in v3/v4 assays is not supported",
call. = FALSE,
immediate. = TRUE
)
v3warn <- TRUE
}
acells <- MatchCells(new = onames[[2L]], orig = anames[[2L]])
anames[[2L]] <- value[[2L]][acells]
suppressWarnings(expr = dimnames(x = x[[assay]]) <- anames)
}
# Rename features/cells at the DimReduc level
for (reduc in Reductions(object = x)) {
rnames <- Cells(x = x[[reduc]])
rcells <- MatchCells(new = onames[[2L]], orig = rnames)
suppressWarnings(
expr = x[[reduc]] <- RenameCells(
object = x[[reduc]],
old.names = rnames,
new.names = value[[2L]][rcells]
)
)
if (!is.null(x = Features(x = x[[reduc]]))) {
rfnames <- Features(x = x[[reduc]])
rfeatures <- MatchCells(
new = onames[[1L]],
orig = rfnames,
ordered = TRUE
)
if (length(x = rfeatures)) {
suppressWarnings(
expr = x[[reduc]] <- .RenameFeatures(
object = x[[reduc]],
old.names = rfnames,
new.names = value[[1L]][rfeatures]
)
)
}
}
}
# TODO: Rename features/cells at the image level
for (img in Images(object = x)) {
inames <- Cells(x = x[[img]])
icells <- MatchCells(new = onames[[2L]], orig = inames)
suppressWarnings(
# TODO: replace with `x[[img]] <-`
expr = slot(object = x, name = 'images')[[img]] <- RenameCells(
object = x[[img]],
old.names = inames,
new.names = value[[2L]][icells]
)
)
# TODO: rename features
}
# Rename cells at the Graph level
for (graph in Graphs(object = x)) {
gnames <- dimnames(x = x[[graph]])
for (i in seq_along(along.with = gnames)) {
gcells <- MatchCells(new = onames[[2L]], orig = gnames[[i]])
gnames[[i]] <- value[[2L]][gcells]
}
suppressWarnings(expr = dimnames(x = x[[graph]]) <- gnames)
}
# Rename cells at the Neighbor level
for (nn in Neighbors(object = x)) {
nnames <- Cells(x = x[[nn]])
ncells <- MatchCells(new = onames[[2L]], orig = nnames)
suppressWarnings(
# TODO: replace with `x[[nn]] <-`
expr = slot(object = x, name = 'neighbors')[[nn]] <- RenameCells(
object = x[[nn]],
old.names = nnames,
new.names = value[[2L]][ncells]
)
)
}
# Validate and return
options(op)
validObject(object = x)
return(x)
}
#' @rdname Idents
#' @export
#' @method droplevels Seurat
#'
droplevels.Seurat <- function(x, ...) {
x <- UpdateSlots(object = x)
slot(object = x, name = 'active.ident') <- droplevels(x = Idents(object = x), ...)
return(x)
}
#' @param n Number of meta data rows to show
#'
#' @return \code{head}: The first \code{n} rows of cell-level metadata
#'
#' @rdname sub-sub-.Seurat
#'
#' @method head Seurat
#' @export
#'
#' @examples
#' # Get the first 10 rows of cell-level metadata
#' head(pbmc_small)
#'
head.Seurat <- .head
#' @rdname Idents
#' @export
#' @method levels Seurat
#'
#' @examples
#' # Get the levels of identity classes of a Seurat object
#' levels(x = pbmc_small)
#'
levels.Seurat <- function(x) {
x <- UpdateSlots(object = x)
return(levels(x = Idents(object = x)))
}
#' @rdname Idents
#' @export
#' @method levels<- Seurat
#'
#' @examples
#' # Reorder identity classes
#' levels(x = pbmc_small)
#' levels(x = pbmc_small) <- c('C', 'A', 'B')
#' levels(x = pbmc_small)
#'
"levels<-.Seurat" <- function(x, value) {
x <- UpdateSlots(object = x)
idents <- Idents(object = x)
if (!all(levels(x = idents) %in% value)) {
stop("NA's generated by missing levels", call. = FALSE)
}
idents <- factor(x = idents, levels = value)
Idents(object = x) <- idents
return(x)
}
#' Merge Seurat Objects
#'
#' @inheritParams CreateSeuratObject
#' @inheritParams merge.Assay5
#' @param x A \code{\link{Seurat}} object
#' @param y A single \code{Seurat} object or a list of \code{Seurat} 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 merge.dr Choose how to handle merging dimensional reductions:
#' \itemize{
#' \item \dQuote{\code{TRUE}}: merge dimensional reductions with the same name
#' across objects; dimensional reductions with different names are added as-is
#' \item \dQuote{\code{NA}}: keep dimensional reductions from separate objects
#' separate; will append the project name for duplicate reduction names
#' \item \dQuote{\code{FALSE}}: do not add dimensional reductions
#' }
#'
#' @return \code{merge}: Merged object
#'
#' @section Merge Details:
#' When merging Seurat objects, the merge procedure will merge the Assay level
#' counts and potentially the data slots (depending on the merge.data parameter).
#' It will also merge the cell-level meta data that was stored with each object
#' and preserve the cell identities that were active in the objects pre-merge.
#' The merge will optionally merge reductions depending on the values passed to
#' \code{merge.dr} if they have the same name across objects. Here the
#' embeddings slots will be merged and if there are differing numbers of
#' dimensions across objects, only the first N shared dimensions will be merged.
#' The feature loadings slots will be filled by the values present in the first
#' object.The merge will not preserve graphs, logged commands, or feature-level
#' metadata that were present in the original objects. If add.cell.ids isn't
#' specified and any cell names are duplicated, cell names will be appended
#' with _X, where X is the numeric index of the object in c(x, y).
#'
#' @method merge Seurat
#' @export
#'
#' @family seurat
#'
#' @aliases merge MergeSeurat AddSamples
#'
#' @examples
#' # `merge' examples
#' # merge two objects
#' merge(pbmc_small, y = pbmc_small)
#' # to merge more than two objects, pass one to x and a list of objects to y
#' merge(pbmc_small, y = c(pbmc_small, pbmc_small))
#'
merge.Seurat <- function(
x = NULL,
y = NULL,
add.cell.ids = NULL,
collapse = FALSE,
merge.data = TRUE,
merge.dr = FALSE,
project = getOption(x = 'Seurat.object.project', default = 'SeuratProject'),
...
) {
CheckDots(...)
objects <- c(x, y)
projects <- vapply(
X = objects,
FUN = Project,
FUN.VALUE = character(length = 1L)
)
if (anyDuplicated(x = projects)) {
projects <- as.character(x = seq_along(along.with = objects))
}
# Check cell names
if (is_na(x = add.cell.ids)) {
add.cell.ids <- as.character(x = seq_along(along.with = objects))
} else if (isTRUE(x = add.cell.ids)) {
add.cell.ids <- projects
}
if (!is.null(x = add.cell.ids)) {
if (length(x = add.cell.ids) != length(x = objects)) {
abort(
message = "Please provide a cell identifier for each object provided to merge"
)
}
# for (i in seq_along(along.with = add.cell.ids)) {
# colnames(x = objects[[i]]) <- paste(
# colnames(x = objects[[i]]),
# add.cell.ids[[i]],
# sep = '_'
# )
# }
for (i in 1:length(x = objects)) {
objects[[i]] <- RenameCells(object = objects[[i]], add.cell.id = add.cell.ids[i])
}
}
objects <- CheckDuplicateCellNames(object.list = objects)
# Merge assays
assays <- Reduce(f = union, x = lapply(X = objects, FUN = Assays))
assay.classes <- sapply(
X = assays,
FUN = function(a) {
cls <- vector(mode = 'character', length = length(x = objects))
for (i in seq_along(along.with = cls)) {
cls[i] <- if (a %in% Assays(object = objects[[i]])) {
class(x = objects[[i]][[a]])[1L]
} else {
NA_character_
}
}
return(unique(x = cls[!is.na(x = cls)]))
},
simplify = FALSE,
USE.NAMES = TRUE
)
# TODO: Handle merging v3 and v5 assays
# if (any(sapply(X = assay.classes, FUN = length) != 1L)) {
# stop("Cannot merge assays of different classes")
# }
assays.all <- vector(mode = 'list', length = length(x = assays))
names(x = assays.all) <- assays
for (assay in assays) {
assay.objs <- which(x = vapply(
X = lapply(X = objects, FUN = names),
FUN = '%in%',
FUN.VALUE = logical(length = 1L),
x = assay
))
if (length(x = assay.objs) == 1L) {
assays.all[[assay]] <- objects[[assay.objs]][[assay]]
next
}
idx.x <- assay.objs[[1L]]
idx.y <- setdiff(x = assay.objs, y = idx.x)
assays.all[[assay]] <- merge(
x = objects[[idx.x]][[assay]],
y = lapply(X = objects[idx.y], FUN = '[[', assay),
labels = projects,
add.cell.ids = NULL,
collapse = collapse,
merge.data = merge.data
)
}
names(objects) <- NULL
all.cells <- Reduce(f = union, x = lapply(X = objects, FUN = colnames))
idents.all <- unlist(x = lapply(X = objects, FUN = Idents))
idents.all <- idents.all[all.cells]
md.all <- EmptyDF(n = length(x = all.cells))
row.names(x = md.all) <- all.cells
obj.combined <- new(
Class = 'Seurat',
assays = assays.all,
reductions = list(),
images = list(),
meta.data = md.all,
active.assay = DefaultAssay(object = x),
active.ident = idents.all,
project.name = project
)
# Merge cell-level meta data, images
for (i in seq_along(along.with = objects)) {
df <- data.frame(
lapply(objects[[i]][[]], FUN = function(x) {
if (is.factor(x)) as.character(x) else x
}), stringsAsFactors=FALSE
)
rownames(df) <- rownames(objects[[i]][[]])
obj.combined[[]] <- df
for (img in Images(object = objects[[i]])) {
dest <- ifelse(
test = img %in% Images(object = obj.combined),
yes = paste(img, projects[i], sep = '.'),
no = img
)
obj.combined[[dest]] <- objects[[i]][[img]]
}
}
# Merge dimensional reductions
reducs.combined <- list()
if (is.character(x = merge.dr)) {
warn(message = "'merge.Seurat' no longer supports filtering dimensional reductions; merging all dimensional reductions")
merge.dr <- TRUE
}
if (isTRUE(x = merge.dr)) {
for (i in seq_along(along.with = objects)) {
for (reduc in Reductions(object = objects[[i]])) {
reducs.combined[[reduc]] <- if (reduc %in% names(x = reducs.combined)) {
inform(message = paste("Merging reduction", sQuote(x = reduc)))
merge(x = reducs.combined[[reduc]], y = objects[[i]][[reduc]])
} else {
objects[[i]][[reduc]]
}
}
}
} else if (is_na(x = merge.dr)) {
reducs.all <- unlist(
x = lapply(X = objects, FUN = Reductions),
use.names = FALSE
)
reducs.dup <- unique(x = reducs.all[duplicated(x = reducs.all)])
for (i in seq_along(along.with = objects)) {
for (reduc in Reductions(object = objects[[i]])) {
rname <- ifelse(
test = reduc %in% reducs.dup,
yes = paste(reduc, projects[i], sep = '.'),
no = reduc
)
reducs.combined[[rname]] <- objects[[i]][[reduc]]
if (rname != reduc) {
inform(message = paste(
"Changing",
reduc,
"in object",
projects[i],
"to",
rname
))
new.key <- Key(object = rname, quiet = TRUE)
inform(message = paste("Updating key to", new.key))
Key(object = reducs.combined[[rname]]) <- new.key
}
}
}
}
for (reduc in names(x = reducs.combined)) {
obj.combined[[reduc]] <- reducs.combined[[reduc]]
}
# Validate and return
validObject(object = obj.combined)
return(obj.combined)
# Merge DimReducs
combined.reductions <- list()
if (!is.null(x = merge.dr)) {
for (dr in merge.dr) {
drs.to.merge <- list()
for (i in 1:length(x = objects)) {
if (!dr %in% Reductions(object = objects[[i]])) {
warning("The DimReduc ", dr, " is not present in all objects being ",
"merged. Skipping and continuing.", call. = FALSE, immediate. = TRUE)
break
}
drs.to.merge[[i]] <- objects[[i]][[dr]]
}
if (length(x = drs.to.merge) == length(x = objects)) {
combined.reductions[[dr]] <- merge(
x = drs.to.merge[[1]],
y = drs.to.merge[2:length(x = drs.to.merge)]
)
}
}
}
}
#' Subobject Names
#'
#' Get the names of subobjects within a \code{\link{Seurat}} object
#'
#' @inheritParams .DollarNames.Seurat
#'
#' @return The names of all of the following subobjects within \code{x}:
#' \itemize{
#' \item \link[=Assay]{v3} and \link[=Assay5]{v5} assays
#' \item \link[=DimReduc]{dimensional reductions}
#' \item \link[=SpatialImage]{images} and \link[=FOV]{FOVs}
#' \item \link[=Graph]{nearest-neighbor graphs}
#' }
#'
#' @method names Seurat
#' @export
#'
#' @family seurat
#'
#' @examples
#' names(pbmc_small)
#'
names.Seurat <- function(x) {
return(.FilterObjects(
object = x,
classes.keep = c('Assay', 'StdAssay', 'DimReduc', 'Graph', 'SpatialImage')
))
}
#' @inherit split.Assay5 params return title description details sections
#'
#' @keywords internal
#' @method split Seurat
#' @export
#'
#' @family Seurat
#'
split.Seurat <- function(
x,
f,
drop = FALSE,
assay = NULL,
layers = NA,
...
){
assay <- assay %||% DefaultAssay(x)
x[[assay]] <- split(
x = x[[assay]],
f = f,
drop = drop,
layers = layers,
ret = 'assay',
...
)
return(x)
}
#' Subset \code{Seurat} Objects
#'
#' @inheritParams .DollarNames.Seurat
#' @inheritParams CellsByIdentities
#' @param subset Logical expression indicating features/variables to keep
#' @param cells,j A vector of cell names or indices to keep
#' @param features,i A vector of feature names or indices to keep
#' @param idents A vector of identity classes to keep
#' @param ... Arguments passed to \code{\link{WhichCells}}
#'
#' @return \code{subset}: A subsetted \code{Seurat} object
#'
#' @importFrom rlang enquo
#'
#' @export
#' @method subset Seurat
#'
#' @family seurat
#
#' @seealso \code{\link{WhichCells}}
#'
#' @aliases subset
#'
#' @order 1
#'
#' @examples
#' # `subset` examples
#' subset(pbmc_small, subset = MS4A1 > 4)
#' subset(pbmc_small, subset = `DLGAP1-AS1` > 2)
#' subset(pbmc_small, idents = '0', invert = TRUE)
#' subset(pbmc_small, subset = MS4A1 > 3, slot = 'counts')
#' subset(pbmc_small, features = VariableFeatures(object = pbmc_small))
#'
subset.Seurat <- function(
x,
subset,
cells = NULL,
features = NULL,
idents = NULL,
return.null = FALSE,
...
) {
# var.features <- VariableFeatures(object = x)
if (!missing(x = subset)) {
subset <- enquo(arg = subset)
}
cells <- WhichCells(
object = x,
cells = cells,
idents = idents,
expression = subset,
return.null = TRUE,
...
)
if (length(x = cells) == 0) {
if (isTRUE(x = return.null)) {
return(NULL)
}
abort(message = "No cells found")
}
if (all(cells %in% Cells(x = x)) &&
length(x = cells) == length(x = colnames(x = x)) &&
is.null(x = features)
) {
return(x)
}
op <- options(Seurat.object.validate = FALSE, Seurat.object.assay.calcn = FALSE)
on.exit(expr = options(op), add = TRUE)
# Remove metadata for cells not present
orig.cells <- colnames(x = x)
cells <- intersect(x = orig.cells, y = cells)
slot(object = x, name = 'meta.data') <- x[[]][cells, , drop = FALSE]
if (!all(orig.cells %in% cells)) {
# Remove neighbors
slot(object = x, name = 'neighbors') <- list()
# Filter Graphs
for (g in names(slot(object = x, name = 'graphs'))) {
cells.g <- intersect(colnames(x[[g]]), cells)
suppressWarnings(
expr = x[[g]] <- as.Graph(x = x[[g]][cells.g, cells.g, drop = FALSE])
)
}
}
Idents(object = x, drop = TRUE) <- Idents(object = x)[cells]
# Filter Assay objects
for (assay in Assays(object = x)) {
if (length(x = intersect(colnames(x = x[[assay]]), cells)) == 0) {
message(assay, " assay doesn't leave any cells, so it is removed")
if (DefaultAssay(x) == assay) {
stop('No cells left in the default assay, please change the default assay')
}
slot(object = x, name = 'assays')[[assay]] <- NULL
} else {
assay.features <- features %||% rownames(x = x[[assay]])
suppressWarnings(
expr = slot(object = x, name = 'assays')[[assay]] <- tryCatch(
# because subset is also an argument, we need to explictly use the base::subset function
expr = suppressWarnings(
expr = base::subset(
x = x[[assay]],
cells = cells,
features = assay.features
),
classes = 'validationWarning'
),
error = function(e) {
if (e$message == "Cannot find features provided") {
return(NULL)
} else {
stop(e)
}
}
)
)
}
}
slot(object = x, name = 'assays') <- Filter(
f = Negate(f = is.null),
x = slot(object = x, name = 'assays')
)
if (length(x = .FilterObjects(object = x, classes.keep = c('Assay', 'StdAssay'))) == 0 || is.null(x = x[[DefaultAssay(object = x)]])) {
abort(message = "Under current subsetting parameters, the default assay will be removed. Please adjust subsetting parameters or change default assay")
}
# Filter DimReduc objects
for (dimreduc in .FilterObjects(object = x, classes.keep = 'DimReduc')) {
suppressWarnings(
x[[dimreduc]] <- tryCatch(
expr = subset.DimReduc(x = x[[dimreduc]], cells = cells, features = features),
error = function(e) {
if (e$message %in% c("Cannot find cell provided", "Cannot find features provided")) {
return(NULL)
} else {
stop(e)
}
}
)
)
}
# Recalculate nCount and nFeature
if (!is.null(features)) {
for (assay in .FilterObjects(object = x, classes.keep = 'Assay')) {
n.calc <- CalcN(object = x[[assay]])
if (!is.null(x = n.calc)) {
names(x = n.calc) <- paste(names(x = n.calc), assay, sep = '_')
suppressWarnings(
expr = x[[names(x = n.calc)]] <- n.calc,
classes = 'validationWarning'
)
}
}
}
# # set variable features
# if (!is.null(var.features)) {
# suppressWarnings(
# expr = VariableFeatures(object = x) <- var.features,
# classes = 'validationWarning'
# )
# }
# subset images
for (image in Images(object = x)) {
cells.from.image <- cells[cells %in% Cells(x[[image]])]
if (length(cells.from.image) == 0) {
image.subset <- NULL
} else {
image.subset <- base::subset(x = x[[image]], cells = cells.from.image)
}
x[[image]] <- image.subset
}
return(x)
}
#' @return \code{tail}: The last \code{n} rows of cell-level metadata
#'
#' @rdname sub-sub-.Seurat
#'
#' @method tail Seurat
#' @export
#'
#' @examples
#' # Get the last 10 rows of cell-level metadata
#' tail(pbmc_small)
#'
tail.Seurat <- .tail
#' @method upgrade seurat
#' @export
#'
upgrade.seurat <- function(object, ...) {
# Run update
message("Updating from v2.X to v3.X")
seurat.version <- packageVersion(pkg = "SeuratObject")
new.assay <- UpdateAssay(old.assay = object, assay = "RNA")
assay.list <- list(RNA = new.assay)
for (i in names(x = object@assay)) {
assay.list[[i]] <- UpdateAssay(old.assay = object@assay[[i]], assay = i)
}
new.dr <- UpdateDimReduction(old.dr = object@dr, assay = "RNA")
object <- new(
Class = "Seurat",
version = seurat.version,
assays = assay.list,
active.assay = "RNA",
project.name = object@project.name,
misc = object@misc %||% list(),
active.ident = object@ident,
reductions = new.dr,
meta.data = object@meta.data,
tools = list()
)
# Run CalcN
for (assay in Assays(object = object)) {
n.calc <- CalcN(object = object[[assay]])
if (!is.null(x = n.calc)) {
names(x = n.calc) <- paste(names(x = n.calc), assay, sep = '_')
object[[names(x = n.calc)]] <- n.calc
}
for (i in c('nGene', 'nUMI')) {
if (i %in% colnames(x = object[[]])) {
object[[i]] <- NULL
}
}
}
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# S4 methods
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Original double-bracket assign
#'
#' This function has been replaced with value-specific double-bracket
#' assign methods and should generally not be called
#'
#' @param x A \code{\link{Seurat}} object
#' @param i The name to store a subobject or various cell-level meta data as
#' @param value New subobject or cell-level meta data
#'
#' @return \code{x} with \code{value} stored as \code{i}
#'
#' @name old-assign
#' @rdname old-assign
#'
#' @keywords internal
#'
#' @seealso See \link[=$.Seurat]{here} for adding metadata with \code{[[<-}, and
#' \link[=[[<-,Seurat,NULL]{here} for removing subobjects and cell-level meta
#' data with \code{[[<-}
#'
NULL
#' @rdname old-assign
#'
setMethod( # because R doesn't allow S3-style [[<- for S4 classes
f = '[[<-',
signature = c('x' = 'Seurat', i = 'character', value = 'ANY'),
definition = function(x, i, ..., value) {
x <- UpdateSlots(object = x)
# Require names, no index setting
if (!is.character(x = i)) {
stop("'i' must be a character", call. = FALSE)
}
# Allow removing of other object
if (is.null(x = value)) {
slot.use <- if (i %in% colnames(x = x[[]])) {
'meta.data'
} else {
FindObject(object = x, name = i)
}
if (is.null(x = slot.use)) {
stop("Cannot find object ", i, call. = FALSE)
}
if (i == DefaultAssay(object = x)) {
stop("Cannot delete the default assay", call. = FALSE)
}
}
# remove disallowed characters from object name
newi <- if (is.null(x = value)) {
i
} else {
make.names(names = i)
}
if (any(i != newi)) {
warning(
"Invalid name supplied, making object name syntactically valid. New object name is ",
newi,
"; see ?make.names for more details on syntax validity",
call. = FALSE,
immediate. = TRUE
)
i <- newi
}
# Figure out where to store data
slot.use <- if (inherits(x = value, what = 'Assay')) {
# Ensure we have the same number of cells
if (ncol(x = value) != ncol(x = x)) {
stop(
"Cannot add a different number of cells than already present",
call. = FALSE
)
}
# Ensure cell order stays the same
if (all(Cells(x = value) %in% Cells(x = x)) && !all(Cells(x = value) == Cells(x = x))) {
for (slot in c('counts', 'data', 'scale.data')) {
assay.data <- GetAssayData(object = value, layer = slot)
if (!IsMatrixEmpty(x = assay.data)) {
assay.data <- assay.data[, Cells(x = x), drop = FALSE]
}
# Use slot because SetAssayData is being weird
slot(object = value, name = slot) <- assay.data
}
}
'assays'
} else if (inherits(x = value, what = 'SpatialImage')) {
# Ensure that all cells for this image are present
if (!all(Cells(x = value) %in% Cells(x = x))) {
stop("All cells in the image must be present in assay.", call. = FALSE)
}
# Ensure Assay that SpatialImage is associated with is present in Seurat object
if (!DefaultAssay(object = value) %in% Assays(object = x)) {
warning(
"Adding image data that isn't associated with any assay present",
call. = FALSE,
immediate. = TRUE
)
}
'images'
} else if (inherits(x = value, what = 'Graph')) {
# Ensure Assay that Graph is associated with is present in the Seurat object
if (is.null(x = DefaultAssay(object = value))) {
warning(
"Adding a Graph without an assay associated with it",
call. = FALSE,
immediate. = TRUE
)
} else if (!any(DefaultAssay(object = value) %in% Assays(object = x))) {
stop("Cannot find assay '", DefaultAssay(object = value), "' in this Seurat object", call. = FALSE)
}
# Ensure Graph object is in order
if (all(Cells(x = value) %in% Cells(x = x)) && !all(Cells(x = value) == Cells(x = x))) {
value <- value[Cells(x = x), Cells(x = x)]
}
'graphs'
} else if (inherits(x = value, what = 'DimReduc')) {
# All DimReducs must be associated with an Assay
if (is.null(x = DefaultAssay(object = value))) {
stop("Cannot add a DimReduc without an assay associated with it", call. = FALSE)
}
# Ensure Assay that DimReduc is associated with is present in the Seurat object
if (!IsGlobal(object = value) && !any(DefaultAssay(object = value) %in% Assays(object = x))) {
stop("Cannot find assay '", DefaultAssay(object = value), "' in this Seurat object", call. = FALSE)
}
# Ensure DimReduc object is in order
if (all(Cells(x = value) %in% Cells(x = x)) && !all(Cells(x = value) == Cells(x = x))) {
slot(object = value, name = 'cell.embeddings') <- value[[Cells(x = x), ]]
}
'reductions'
} else if (inherits(x = value, what = "Neighbor")) {
# Ensure all cells are present in the Seurat object
if (length(x = Cells(x = value)) > length(x = Cells(x = x))) {
stop(
"Cannot have more cells in the Neighbor object than are present in the Seurat object.",
call. = FALSE
)
}
if (!all(Cells(x = value) %in% Cells(x = x))) {
stop(
"Cannot add cells in the Neighbor object that aren't present in the Seurat object.",
call. = FALSE
)
}
'neighbors'
} else if (inherits(x = value, what = 'SeuratCommand')) {
# Ensure Assay that SeuratCommand is associated with is present in the Seurat object
if (is.null(x = DefaultAssay(object = value))) {
warning(
"Adding a command log without an assay associated with it",
call. = FALSE,
immediate. = TRUE
)
} else if (!any(DefaultAssay(object = value) %in% Assays(object = x))) {
stop("Cannot find assay '", DefaultAssay(object = value), "' in this Seurat object", call. = FALSE)
}
'commands'
} else if (is.null(x = value)) {
slot.use
} else {
'meta.data'
}
if (slot.use == 'meta.data') {
# Add data to object metadata
meta.data <- x[[]]
cell.names <- rownames(x = meta.data)
# If we have metadata with names, ensure they match our order
if (is.data.frame(x = value) && !is.null(x = rownames(x = value))) {
meta.order <- match(x = rownames(x = meta.data), table = rownames(x = value))
value <- value[meta.order, , drop = FALSE]
}
if (length(x = i) > 1) {
# Add multiple pieces of metadata
value <- rep_len(x = value, length.out = length(x = i))
for (index in 1:length(x = i)) {
meta.data[i[index]] <- value[index]
}
} else {
# Add a single column to metadata
if (length(x = intersect(x = names(x = value), y = cell.names)) > 0) {
meta.data[, i] <- value[cell.names]
} else if (length(x = value) %in% c(nrow(x = meta.data), 1) || is.null(x = value)) {
meta.data[, i] <- value
} else {
stop("Cannot add more or fewer cell meta.data information without values being named with cell names", call. = FALSE)
}
}
# Check to ensure that we aren't adding duplicate names
if (any(colnames(x = meta.data) %in% FilterObjects(object = x))) {
bad.cols <- colnames(x = meta.data)[which(colnames(x = meta.data) %in% FilterObjects(object = x))]
stop(
paste0(
"Cannot add a metadata column with the same name as an Assay or DimReduc - ",
paste(bad.cols, collapse = ", ")),
call. = FALSE
)
}
# Store the revised metadata
slot(object = x, name = 'meta.data') <- meta.data
} else {
# Add other object to Seurat object
# Ensure cells match in value and order
if (!inherits(x = value, what = c('SeuratCommand', 'NULL', 'SpatialImage', 'Neighbor')) && !all(Cells(x = value) == colnames(x = x))) {
stop("All cells in the object being added must match the cells in this object", call. = FALSE)
}
# Ensure we're not duplicating object names
duplicate <- !is.null(x = FindObject(object = x, name = i)) &&
!inherits(x = value, what = c(class(x = x[[i]]), 'NULL')) &&
!inherits(x = x[[i]], what = class(x = value))
if (isTRUE(x = duplicate)) {
stop(
"This object already contains ",
i,
" as a",
ifelse(
test = tolower(x = substring(text = class(x = x[[i]]), first = 1, last = 1)) %in% c('a', 'e', 'i', 'o', 'u'),
yes = 'n ',
no = ' '
),
class(x = x[[i]]),
", so ",
i,
" cannot be used for a ",
class(x = value),
call. = FALSE
)
}
# Check keyed objects
if (inherits(x = value, what = c('Assay', 'DimReduc', 'SpatialImage'))) {
if (length(x = Key(object = value)) == 0 || nchar(x = Key(object = value)) == 0) {
Key(object = value) <- paste0(tolower(x = i), '_')
}
Key(object = value) <- UpdateKey(key = Key(object = value))
# Check for duplicate keys
object.keys <- Key(object = x)
vkey <- Key(object = value)
if (vkey %in% object.keys && !isTRUE(x = object.keys[i] == vkey)) {
new.key <- if (is.na(x = object.keys[i])) {
# Attempt to create a duplicate key based off the name of the object being added
new.keys <- paste0(
paste0(tolower(x = i), c('', RandomName(length = 2L))),
'_'
)
# Select new key to use
key.use <- min(which(x = !new.keys %in% object.keys))
new.key <- if (is.infinite(x = key.use)) {
RandomName(length = 17L)
} else {
new.keys[key.use]
}
warning(
"Cannot add objects with duplicate keys (offending key: ",
Key(object = value),
"), setting key to '",
new.key,
"'",
call. = FALSE
)
new.key
} else {
# Use existing key
warning(
"Cannot add objects with duplicate keys (offending key: ",
Key(object = value),
") setting key to original value '",
object.keys[i],
"'",
call. = FALSE
)
object.keys[i]
}
# Set new key
Key(object = value) <- new.key
}
}
# For Assays, run CalcN
if (inherits(x = value, what = 'Assay')) {
if ((!i %in% Assays(object = x)) |
(i %in% Assays(object = x) && !identical(
x = GetAssayData(object = x, assay = i, layer = "counts"),
y = GetAssayData(object = value, layer = "counts"))
)) {
n.calc <- CalcN(object = value)
if (!is.null(x = n.calc)) {
names(x = n.calc) <- paste(names(x = n.calc), i, sep = '_')
x[[names(x = n.calc)]] <- n.calc
}
}
}
# When removing an Assay, clear out associated DimReducs, Graphs, and SeuratCommands
if (is.null(x = value) && inherits(x = x[[i]], what = 'Assay')) {
objs.assay <- FilterObjects(
object = x,
classes.keep = c('DimReduc', 'SeuratCommand', 'Graph')
)
objs.assay <- Filter(
f = function(o) {
return(all(DefaultAssay(object = x[[o]]) == i) && !IsGlobal(object = x[[o]]))
},
x = objs.assay
)
for (o in objs.assay) {
x[[o]] <- NULL
}
}
# If adding a command, ensure it gets put at the end of the command list
if (inherits(x = value, what = 'SeuratCommand')) {
slot(object = x, name = slot.use)[[i]] <- NULL
slot(object = x, name = slot.use) <- Filter(
f = Negate(f = is.null),
x = slot(object = x, name = slot.use)
)
}
slot(object = x, name = slot.use)[[i]] <- value
slot(object = x, name = slot.use) <- Filter(
f = Negate(f = is.null),
x = slot(object = x, name = slot.use)
)
}
CheckGC()
return(x)
}
)
#' Add Subobjects
#'
#' Add subobjects containing expression, dimensional reduction, or other
#' containerized data to a \code{\link{Seurat}} object. Subobjects can be
#' accessed with \code{\link[=[[.Seurat]{[[}} and manipulated directly within
#' the \code{Seurat} object or used independently
#'
#' @inheritParams .DollarNames.Seurat
#' @inheritParams [[.Assay5
#' @param i Name to add subobject as
#' @param value A valid subobject (eg. a \link[=Assay]{v3} or \link[=Assay5]{v5}
#' assay, or a \link[=DimReduc]{dimensional reduction})
#'
#' @return \code{x} with \code{value} added as \code{i}
#'
#' @name [[<-,Seurat
#' @rdname sub-subset-Seurat
#'
#' @family seurat
#'
#' @seealso See \link[=[[.Seurat]{here} for pulling subobjects using \code{[[},
#' \link[=$.Seurat]{here} for adding metadata with \code{[[<-}, and
#' \link[=[[<-,Seurat,NULL]{here} for removing subobjects and cell-level meta
#' data with \code{[[<-}
#'
#' @aliases [[<-.Seurat \S4method{[[<-}{Seurat,character,missing,Assay}
#'
NULL
#' @rdname sub-subset-Seurat
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'character',
j = 'missing',
value = 'Assay'
),
definition = function(x, i, ..., value) {
if (.GetSeuratCompat() < '5.0.0') {
return(callNextMethod(x = x, i = i, value = value))
}
validObject(object = value)
i <- make.names(names = i)
# Checks for if the assay or name already exists
if (i %in% names(x = x)) {
if (!inherits(x = x[[i]], what = c('Assay', 'StdAssay'))) {
abort(
message = paste(
sQuote(i),
"already exists as an object of class",
class(x = x[[i]])[1L]
),
class = 'duplicateError'
)
}
if (!identical(x = class(x = value), y = class(x = x[[i]]))) {
warning(
"Assay ",
i,
" changing from ",
class(x = x[[i]]),
" to ",
class(x = value),
call. = FALSE,
immediate. = TRUE
)
}
if (!all(dim(x = value) == dim(x = x[[i]]))) {
warn(
message = paste0("Different cells and/or features from existing assay ", i),
class = 'dimWarning'
)
}
}
# Check for cells
if (!all(colnames(x = value) %in% colnames(x = x))) {
abort(message = "Cannot add new cells with [[<-")
}
cell.order <- MatchCells(
new = colnames(x = value),
orig = colnames(x = x),
ordered = TRUE
)
# TODO: enable reordering cells in assay
if (is.unsorted(x = cell.order)) {
if (inherits(x = value, what = 'Assay')) {
for (s in c('counts', 'data', 'scale.data')) {
if (!IsMatrixEmpty(x = slot(object = value, name = s))) {
slot(object = value, name = s) <- slot(object = value, name = s)[, cell.order]
}
}
} else {
abort(message = "Cannot add assays with unordered cells")
}
validObject(object = value)
}
# Check keys
Key(object = value) <- .CheckKey(
key = Key(object = value),
existing = Key(object = x),
name = i
)
# Run CalcN
do.calcn <- Misc(object = value, slot = 'calcN') %||% FALSE
suppressWarnings(Misc(object = value, slot = 'calcN') <- NULL)
if (isTRUE(x = do.calcn)) {
n.calc <- suppressWarnings(
expr = .CalcN(object = value, layer = 'counts', simplify = TRUE),
classes = 'missingLayerWarning'
)
if (!is.null(x = n.calc)) {
names(x = n.calc) <- paste(names(x = n.calc), i, sep = '_')
x[[]] <- n.calc
}
}
# Add the assay
slot(object = x, name = 'assays')[[i]] <- value
slot(object = x, name = 'assays') <- Filter(
f = Negate(f = is.null),
x = slot(object = x, name = 'assays')
)
# Validate and return
validObject(object = x)
return(x)
}
)
#' @rdname sub-subset-Seurat
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'character',
j = 'missing',
value = 'Assay5'
),
definition = function(x, i, ..., value) {
return(callNextMethod(x = x, i = i, ..., value = value))
}
)
#' @rdname cash-.Seurat
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'character',
j = 'missing',
value = 'data.frame'
),
definition = function(x, i, ..., value) {
# Because R is stupid sometimes
if (!length(x = i) && !ncol(x = value)) {
return(x)
}
# Check the names provided
if (length(x = i) == ncol(x = value)) {
# Add the names to the meta data
if (is.null(x = names(x = value))) {
names(x = value) <- i
}
if (ncol(x = value) == 1) {
v <- value[,1]
names(x = v) <- rownames(x = value)
x[[i]] <- v
return(x)
}
idx <- match(x = i, table = names(x = value))
# If there are any mismatches in `i` and `names(value)`
# rename `value` to match `i`
# if (all(is.na(x = idx))) {
# warn(message = paste(
# "None of the column names are found in meta data names;",
# "replacing to provided meta data names"
# ))
# }
if (any(is.na(x = idx))) {
meta.missing <- setdiff(
x = seq_len(length.out = ncol(x = value)),
y = idx[!is.na(x = idx)]
)
names(x = meta.missing) <- i[is.na(x = idx)]
# for (j in seq_along(along.with = meta.missing)) {
# warn(message = paste(
# "Column",
# sQuote(x = names(x = value)[meta.missing[j]]),
# "not found in meta data names, changing to",
# sQuote(x = names(x = meta.missing)[j])
# ))
# }
names(x = value)[meta.missing] <- names(x = meta.missing)
}
} else if (is.null(x = names(x = value))) {
# Cannot add meta data without names
abort(message = paste(
"Cannot assign",
length(x = i),
ifelse(test = length(x = i) == 1L, yes = 'name', no = 'names'),
"to",
ncol(x = value),
ifelse(test = ncol(x = value) == 1L, yes = 'bit', no = 'bits'),
"of meta data"
))
} else {
# Find matching `i` in `names(value)`
# Cannot rename as `length(i) != ncol(value)`
i.orig <- i
i <- intersect(x = i, y = names(x = value))
# If no matching, abort
if (!length(x = i)) {
abort(
message = "None of the meta data requested was found in the data frame"
)
}
# Alert user to `i` not found in `names(value)`
i.missing <- setdiff(x = i.orig, y = i)
if (length(x = i.missing)) {
warn(message = paste(
"The following bits of meta data in the data frame will not be added:",
paste(sQuote(x = i.missing), collapse = ', ')
))
}
}
# Handle meta data for different cells
names.intersect <- intersect(x = row.names(x = value), y = colnames(x = x))
if (length(x = names.intersect)) {
value <- value[names.intersect, , drop = FALSE]
if (!nrow(x = value)) {
abort(message = "None of the cells provided are in this Seurat object")
}
} else if (nrow(x = value) == ncol(x = x)) {
# When no cell names are provided in value, assume it's in cell order
row.names(x = value) <- colnames(x = x)
} else {
# Throw an error when no cell names provided and cannot assume cell order
abort(
message = "Cannot add more or less meta data without cell names"
)
}
# Add the cell-level meta data using the `value = vector` method
for (n in i) {
v <- value[[n]]
names(x = v) <- row.names(x = value)
x[[n]] <- v
}
return(x)
}
)
#' @rdname cash-.Seurat
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'missing',
j = 'missing',
value = 'data.frame'
),
definition = function(x, i, ..., value) {
# Allow removing all meta data
if (IsMatrixEmpty(x = value)) {
x[[names(x = x[[]])]] <- NULL
} else {
# If no `i` provided, use the column names from value
x[[names(x = value)]] <- value
}
return(x)
}
)
#' @rdname sub-subset-Seurat
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'character',
j = 'missing',
value = 'DimReduc'
),
definition = function(x, i, ..., value) {
validObject(object = value)
i <- make.names(names = i)
# Checks for if the DimReduc or name already exists
if (i %in% .Subobjects(object = x)) {
if (!inherits(x = x[[i]], what = 'DimReduc')) {
abort(
message = paste(
sQuote(i),
"already exists as an object of class",
class(x = x[[i]])[1L]
),
class = 'duplicateError'
)
}
if (!identical(x = class(x = value), y = class(x = x[[i]]))) {
warning(
"DimReduc ",
i,
" changing from ",
class(x = x[[i]]),
" to ",
class(x = value),
call. = FALSE,
immediate. = TRUE
)
}
if (length(x = value) != length(x = x[[i]])) {
warning(
"Number of dimensions changing from ",
length(x = x[[i]]),
" to ",
length(x = value),
call. = FALSE,
immediate. = TRUE
)
}
if (length(x = Cells(x = value)) != length(x = Cells(x = x[[i]]))) {
warning(
"Number of cells changing from ",
length(x = Cells(x = x[[i]])),
" to ",
length(x = Cells(x = value)),
call. = FALSE,
immediate. = TRUE
)
}
}
# Check default assay
if (is.null(x = DefaultAssay(object = value))) {
stop("Cannot add a DimReduc without an associated assay", call. = FALSE)
} else if (!any(DefaultAssay(object = value) %in% Assays(object = x))) {
warning(
"Adding a dimensional reduction (",
i,
") without the associated assay being present",
call. = FALSE,
immediate. = TRUE
)
}
# Check for cells
if (!all(Cells(x = value) %in% colnames(x = x))) {
stop("Cannot add new cells with [[<-", call. = FALSE)
}
cell.order <- MatchCells(
new = Cells(x = value),
orig = colnames(x = x),
ordered = TRUE
)
# TODO: enable reordering cells in DimReducs
if (is.unsorted(x = cell.order)) {
ordered.cells <- intersect(colnames(x = x), Cells(x = value))
slot(object = value, name = 'cell.embeddings') <- Embeddings(object = value)[ordered.cells,]
}
# Check keys
Key(object = value) <- .CheckKey(
key = Key(object = value),
existing = Key(object = x),
name = i
)
# Check loadings and embeddings column name
emb.names <- paste0(sapply(
X = strsplit(
x = colnames(Embeddings(object = value)),
split = '_'),
FUN = '[',
1)[1],
'_')
if (emb.names != Key(object = value)){
colnames(
slot(object = value, name = 'cell.embeddings')
) <- gsub(pattern = emb.names,
replacement = Key(object = value),
colnames(Embeddings(object = value))
)
}
if (!is.null(colnames(Loadings(object = value)))) {
loadings.names <- paste0(sapply(
X = strsplit(
x = colnames(Loadings(object = value)),
split = '_'),
FUN = '[',
1)[1],
'_')
if (loadings.names != Key(object = value)) {
colnames(
slot(object = value, name = 'feature.loadings')
) <- gsub(pattern = loadings.names,
replacement = Key(object = value),
colnames(Loadings(object = value))
)
}
}
slot(object = x, name = 'reductions')[[i]] <- value
slot(object = x, name = 'reductions') <- Filter(
f = Negate(f = is.null),
x = slot(object = x, name = 'reductions')
)
# check column names
# Validate and return
validObject(object = x)
return(x)
}
)
#' @rdname cash-.Seurat
#'
#' @importFrom methods selectMethod
#'
setMethod(
f = '[[<-',
signature = c(x = 'Seurat', i = 'character', j = 'missing', value = 'factor'),
definition = function(x, i, ..., value) {
# Add multiple objects
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]]
}
return(x)
}
objs <- .FilterObjects(
object = x,
classes.keep = c(
'Assay',
'StdAssay',
'DimReduc',
'Graph',
'Neighbor',
'SeuratCommand',
'SpatialImage'
)
)
if (i %in% objs) {
cls <- class(x = x[[i]])[1L]
abort(message = paste(
sQuote(x = i, q = FALSE),
"already exists as",
ifelse(
test = tolower(x = substr(x = cls, start = 1, stop = 1)) %in% .Vowels(),
yes = 'an',
no = 'a'
),
class(x = x[[i]])[1L]
))
}
# fast way to add column
if (length(x = value) == ncol(x = x) && all(names(x = value) == colnames(x = x))) {
slot(object = x, name = 'meta.data')[,i] <- value
return(x)
}
# Add a column of cell-level meta data
if (is.null(x = names(x = value))) {
# Handle cases where new meta data is unnamed
value <- rep_len(x = value, length.out = ncol(x = x))
names(x = value) <- colnames(x = x)
} else {
# Check cell names for new objects
names.intersect <- intersect(x = names(x = value), y = colnames(x = x))
if (!length(x = names.intersect)) {
stop(
"No cell overlap between new meta data and Seurat object",
call. = FALSE
)
}
value <- value[names.intersect]
}
df <- EmptyDF(n = ncol(x = x))
row.names(x = df) <- colnames(x = x)
df[[i]] <- factor(x = NA, levels = levels(x = value))
# df[[i]] <- if (i %in% names(x = x[[]])) {
# x[[i, na.rm = FALSE]]
# } else {
# factor(x = NA, levels = levels(x = value))
# }
df[names(x = value), i] <- value
slot(object = x, name = 'meta.data')[, i] <- df[[i]]
validObject(object = x)
return(x)
}
)
#' @rdname sub-subset-Seurat
#'
setMethod(
f = '[[<-',
signature = c(x = 'Seurat', i = 'character', j = 'missing', value = 'Graph'),
definition = function(x, i, ..., value) {
validObject(object = value)
i <- make.names(names = i)
# Checks for if the Graph or name already exists
if (i %in% names(x = x)) {
if (!inherits(x = x[[i]], what = 'Graph')) {
abort(
message = paste(
sQuote(i),
"already exists as an object of class",
class(x = x[[i]])[1L]
),
class = 'duplicateError'
)
}
if (!identical(x = class(x = value), y = class(x = x[[i]]))) {
warning(
"Graph ",
i,
" changing from ",
class(x = x[[i]]),
" to ",
class(x = value),
call. = FALSE,
immediate. = TRUE
)
}
if (!all(dim(x = value) == dim(x = x[[i]]))) {
warning(
"Different cells from existing graph ", i,
call. = FALSE,
immediate. = TRUE
)
}
}
# Check cells
gcells <- Cells(x = value, margin = NA_integer_)
if (!all(gcells %in% colnames(x = x))) {
stop("Cannot add cells with [[<-", call. = FALSE)
}
cell.order <- MatchCells(
new = gcells,
orig = colnames(x = x),
ordered = TRUE
)
# TODO: enable reordering cells in graph
if (is.unsorted(x = cell.order)) {
stop("Cannot add graphs with unordered cells", call. = FALSE)
validObject(object = value)
}
# Add the graph
slot(object = x, name = 'graphs')[[i]] <- value
slot(object = x, name = 'graphs') <- Filter(
f = Negate(f = is.null),
x = slot(object = x, name = 'graphs')
)
# Validate and return
validObject(object = x)
return(x)
}
)
#' @rdname cash-.Seurat
#'
setMethod(
f = '[[<-',
signature = c(x = 'Seurat', i = 'character', j = 'missing', value = 'list'),
definition = function(x, i, ..., value) {
# Because R is stupid sometimes
if (!length(x = i) && !length(x = value)) {
return(x)
}
# Check that the `i` we're adding are present in the list
if (!is.null(x = names(x = value))) {
i <- arg_match(arg = i, values = names(x = value), multiple = TRUE)
} else if (length(x = i) != length(x = value)) {
abort(message = paste(
"Cannot assing",
length(x = i),
"names to",
length(x = value),
"bits of meta data"
))
} else {
names(x = value) <- i
}
# Add the meta data
for (n in i) {
x[[n]] <- value[[n]]
}
return(x)
}
)
#' @rdname cash-.Seurat
#'
setMethod(
f = '[[<-',
signature = c(x = 'Seurat', i = 'missing', j = 'missing', value = 'list'),
definition = function(x, i, ..., value) {
stopifnot(IsNamedList(x = value))
for (y in names(x = value)) {
x[[y]] <- value[[y]]
}
return(x)
}
)
#' @rdname sub-subset-Seurat
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'character',
j = 'missing',
value = 'Neighbor'
),
definition = function(x, i, ..., value) {
validObject(object = value)
i <- make.names(names = i)
# Checks for if the Neighbor or name already exists
if (i %in% .Subobjects(object = x)) {
if (!inherits(x = x[[i]], what = 'Neighbor')) {
abort(
message = paste(
sQuote(i),
"already exists as an object of class",
class(x = x[[i]])[1L]
),
class = 'duplicateError'
)
}
if (!identical(x = class(x = value), y = class(x = x[[i]]))) {
warn(message = paste(
"Graph",
i,
"changing from",
class(x = x[[i]])[1L],
"to",
class(x = value)[1L]
))
}
if (length(x = Cells(x = value)) != length(x = Cells(x = x[[i]]))) {
warn(message = paste(
"Number of cells changing from",
length(x = Cells(x = x[[i]])),
"to",
length(x = Cells(x = value))
))
}
}
# Check for cells
if (!all(Cells(x = value) %in% colnames(x = x))) {
abort(message = "Cannot add new cells with [[<-")
}
cell.order <- MatchCells(
new = Cells(x = value),
orig = colnames(x = x),
ordered = TRUE
)
# TODO: enable reordering cells in Neighbors
if (is.unsorted(x = cell.order)) {
abort(message = "Cannot add Neighbors with unordered cells")
validObject(object = value)
}
slot(object = x, name = 'neighbors')[[i]] <- value
slot(object = x, name = 'neighbors') <- Filter(
f = Negate(f = is.null),
x = slot(object = x, name = 'neighbors')
)
# Validate and return
validObject(object = x)
return(x)
}
)
#' Remove Subobjects and Cell-Level Meta Data
#'
#' @inheritParams [[<-,Seurat
#' @param i Name(s) of subobject(s) or cell-level meta data to remove
#' @param value NULL
#'
#' @return \code{x} with \code{i} removed from the object
#'
#' @name [[<-,Seurat,NULL
#' @rdname sub-subset-Seurat-NULL
#'
#' @family seurat
#'
#' @seealso See \link[=[[.Seurat]{here} for pulling subobjects using \code{[[},
#' \link[=$.Seurat]{here} for adding metadata with \code{[[<-}, and
#' \link[=[[<-,Seurat]{here} for adding subobjects with \code{[[<-}
#'
#' @aliases remove-object remove-objects \S4method{[[<-}{Seurat,character,missing,NULL}
#'
NULL
#' @rdname sub-subset-Seurat-NULL
#'
setMethod(
f = '[[<-',
signature = c(x = 'Seurat', i = 'character', j = 'missing', value = 'NULL'),
definition = function(x, i, ..., value) {
# Allow removing multiple objects or bits of cell-level meta data at once
for (name in i) {
# Determine the slot to use
# If no subobject found, check cell-level meta data
slot.use <- .FindObject(object = x, name = name) %||% 'meta.data'
switch(
EXPR = slot.use,
'meta.data' = {
# If we can't find the cell-level meta data, throw a warning and move
# to the next name
if (!name %in% names(x = x[[]])) {
warn(message = paste(
"Cannot find cell-level meta data named ",
name
))
next
}
# Remove the column of meta data
slot(object = x, name = 'meta.data')[, name] <- value
},
'assays' = {
# Cannot remove the default assay
if (isTRUE(x = name == DefaultAssay(object = x))) {
stop("Cannot delete default assay", call. = FALSE)
}
# Remove the assay
slot(object = x, name = slot.use)[[i]] <- value
},
# Remove other subobjects
slot(object = x, name = slot.use)[[name]] <- value
)
}
# Validate and return
validObject(object = x)
return(x)
}
)
#' @rdname sub-subset-Seurat
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'character',
j = 'missing',
value = 'SeuratCommand'
),
definition = function(x, i, ..., value) {
validObject(object = value)
i <- make.names(names = i)
# Checks for if the SeuratCommand or name already exists
if (i %in% .Subobjects(object = x)) {
if (!inherits(x = x[[i]], what = 'SeuratCommand')) {
abort(
message = paste(
sQuote(i),
"already exists as an object of class",
class(x = x[[i]])[1L]
),
class = 'duplicateError'
)
}
if (!identical(x = class(x = value), y = class(x = x[[i]]))) {
warn(message = paste(
"Command",
i,
"changing from",
class(x = x[[i]])[1L],
"to",
class(x = value)[1L]
))
}
}
if (is.null(x = DefaultAssay(object = value))) {
warn(message = "Adding a command log without an assay associated with it")
}
# Ensure the command gets put at the end of the list
# slot(object = x, name = 'commands')[[i]] <- NULL
suppressWarnings(expr = x[[i]] <- NULL)
slot(object = x, name = 'commands')[[i]] <- value
slot(object = x, name = 'commands') <- Filter(
f = Negate(f = is.null),
x = slot(object = x, name = 'commands')
)
# Validate and return
validObject(object = x)
return(x)
}
)
#' @rdname sub-subset-Seurat
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'character',
j = 'missing',
value = 'SpatialImage'
),
definition = function(x, i, ..., value) {
validObject(object = value)
i <- make.names(names = i)
# Checks for if the image or name already exists
if (i %in% .Subobjects(object = x)) {
if (!inherits(x = x[[i]], what = 'SpatialImage')) {
abort(
message = paste(
sQuote(i),
"already exists as an object of class",
class(x = x[[i]])[1L]
),
class = 'duplicateError'
)
}
if (!identical(x = class(x = value), y = class(x = x[[i]]))) {
warn(message = paste(
"Image",
i,
"changing from",
class(x = x[[i]])[1L],
"to",
class(x = value)[1L]
))
}
}
# Check cells
if (!all(Cells(x = value) %in% colnames(x = x))) {
abort(message = "Cannot add new cells with [[<-")
}
cell.order <- MatchCells(
new = Cells(x = value),
orig = colnames(x = x),
ordered = TRUE
)
if (is.unsorted(x = cell.order)) {
warn(message = "Adding image with unordered cells")
}
# Check assay
if (!DefaultAssay(object = value) %in% Assays(object = x)) {
warn(message = "Adding image data that isn't associated with any assays")
}
# Check keys
Key(object = value) <- .CheckKey(
key = Key(object = value),
existing = Key(object = x),
name = i
)
slot(object = x, name = 'images')[[i]] <- value
slot(object = x, name = 'images') <- Filter(
f = Negate(f = is.null),
x = slot(object = x, name = 'images')
)
# Validate and return
validObject(object = x)
return(x)
}
)
#' @inherit [[<-,Seurat
#'
#' @keywords internal
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'character',
j = 'missing',
value = 'StdAssay'
),
definition = function(x, i, ..., value) {
# Reuse the `value = Assay` method
fn <- slot(
object = selectMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'character',
j = 'missing',
value = 'Assay'
)
),
name = '.Data'
)
cell.order <- MatchCells(
new = colnames(x = value),
orig = colnames(x = x),
ordered = TRUE
)
if (is.unsorted(cell.order)) {
value.order <- new(
Class = 'Assay5',
layers = list(),
default = 0L,
features = value@features,
cells = LogMap(colnames(value)[cell.order]),
meta.data = value@meta.data,
misc = value@misc
)
for (l in Layers(object = value)) {
LayerData(object = value.order, layer = l) <-
LayerData(object = value, layer = l)
}
value <- value.order
}
return(fn(x = x, i = i, value = value))
}
)
#' @rdname cash-.Seurat
#'
setMethod(
f = '[[<-',
signature = c(
x = 'Seurat',
i = 'character',
j = 'missing',
value = 'vector'
),
definition = function(x, i, ..., value) {
# Add multiple objects
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]]
}
return(x)
}
objs <- .FilterObjects(
object = x,
classes.keep = c(
'Assay',
'StdAssay',
'DimReduc',
'Graph',
'Neighbor',
'SeuratCommand',
'SpatialImage'
)
)
if (i %in% objs) {
cls <- class(x = x[[i]])[1L]
abort(message = paste(
sQuote(x = i, q = FALSE),
"already exists as",
ifelse(
test = tolower(x = substr(x = cls, start = 1, stop = 1)) %in% .Vowels(),
yes = 'an',
no = 'a'
),
class(x = x[[i]])[1L]
))
}
# fast way to add column
if (length(x = value) == ncol(x = x) && all(names(x = value) == colnames(x = x))) {
slot(object = x, name = 'meta.data')[,i] <- value
return(x)
}
# Add a column of cell-level meta data
if (is.null(x = names(x = value))) {
# Handle cases where new meta data is unnamed
value <- rep_len(x = value, length.out = ncol(x = x))
names(x = value) <- colnames(x = x)
} else {
# Check cell names for new objects
names.intersect <- intersect(x = names(x = value), y = colnames(x = x))
if (!length(x = names.intersect)) {
stop(
"No cell overlap between new meta data and Seurat object",
call. = FALSE
)
}
value <- value[names.intersect]
}
df <- EmptyDF(n = ncol(x = x))
row.names(x = df) <- colnames(x = x)
df[[i]] <- if (i %in% names(x = x[[]])) {
if (is.character(x = value)) {
as.character(x = x[[i, drop = TRUE, na.rm = FALSE]])
} else {
as.vector(x = x[[i, drop = TRUE, na.rm = FALSE]])
}
} else {
NA
}
df[names(x = value), i] <- value
slot(object = x, name = 'meta.data')[, i] <- df[[i]]
validObject(object = x)
return(x)
}
)
#' Row and Column Sums and Means
#'
#' Calculate \code{\link{rowSums}}, \code{\link{colSums}},
#' \code{\link{rowMeans}}, and \code{\link{colMeans}} on
#' \code{\link{Seurat}} objects
#'
#' @inheritParams .DollarNames.Seurat
#' @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 seurat
#'
#' @seealso \code{\link{Seurat}}
#'
#' @examples
#' head(colMeans(pbmc_small))
#'
setMethod(
f = 'colMeans',
signature = c('x' = 'Seurat'),
definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
return(colMeans(
x = LayerData(object = x, layer = slot),
na.rm = na.rm,
dims = dims,
...
))
}
)
#' @return \code{colSums}: the column (cell-wise) sums of \code{slot}
#'
#' @rdname colMeans-Seurat-method
#'
#' @importFrom Matrix colSums
#'
#' @export
#'
#' @examples
#' head(colSums(pbmc_small))
#'
setMethod(
f = 'colSums',
signature = c('x' = 'Seurat'),
definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
return(Matrix::colSums(
x = LayerData(object = x, layer = slot),
na.rm = na.rm,
dims = dims,
...
))
}
)
#' @importFrom methods initialize
#'
setMethod(
f = 'initialize',
signature = 'Seurat',
definition = function(
.Object,
assays = list(),
meta.data = NULL,
active.assay = character(length = 0L),
active.ident = NULL,
graphs = list(),
neighbors = list(),
reductions = list(),
images = list(),
project.name = getOption(
x = 'Seurat.object.project',
default = Seurat.options$Seurat.object.project
),
misc = list(),
version = packageVersion(pkg = 'SeuratObject'),
commands = list(),
tools = list(),
...
) {
# Initialize the object
.Object <- callNextMethod(.Object, ...)
# Set defaults for meta data and idents
cells <- Reduce(f = union, x = lapply(X = assays, FUN = Cells))
if (is.null(x = meta.data)) {
meta.data <- EmptyDF(n = length(x = cells))
row.names(x = meta.data) <- cells
}
if (is.null(x = active.ident)) {
active.ident <- factor(x = cells)
}
# Add slots
slot(object = .Object, name = 'assays') <- assays
slot(object = .Object, name = 'meta.data') <- meta.data
slot(object = .Object, name = 'active.assay') <- active.assay
slot(object = .Object, name = 'active.ident') <- active.ident
slot(object = .Object, name = 'graphs') <- graphs
slot(object = .Object, name = 'neighbors') <- neighbors
slot(object = .Object, name = 'reductions') <- reductions
slot(object = .Object, name = 'images') <- images
slot(object = .Object, name = 'project.name') <- project.name
slot(object = .Object, name = 'misc') <- misc
slot(object = .Object, name = 'version') <- version
slot(object = .Object, name = 'commands') <- commands
slot(object = .Object, name = 'tools') <- tools
# Validate the object
validObject(object = .Object)
# Return
return(.Object)
}
)
#' @return \code{rowMeans}: the row (feature-wise) means of \code{slot}
#'
#' @rdname colMeans-Seurat-method
#'
#' @importFrom Matrix colSums
#'
#' @export
#'
#' @examples
#' head(rowMeans(pbmc_small))
#'
setMethod(
f = 'rowMeans',
signature = c('x' = 'Seurat'),
definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
return(Matrix::rowMeans(
x = LayerData(object = x, layer = slot),
na.rm = na.rm,
dims = dims,
...
))
}
)
#' @return \code{rowSums}: the row (feature-wise) sums of \code{slot}
#'
#' @rdname colMeans-Seurat-method
#'
#' @importFrom Matrix rowSums
#'
#' @export
#'
#' @examples
#' head(rowSums(pbmc_small))
#'
setMethod(
f = 'rowSums',
signature = c('x' = 'Seurat'),
definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
return(Matrix::rowSums(
x = LayerData(object = x, layer = slot),
na.rm = na.rm,
dims = dims,
...
))
}
)
#' Seurat Object Overview
#'
#' Overview of a \code{\link{Seurat}} object
#'
#' @template return-show
#'
#' @keywords internal
#'
#' @concept seurat
#'
#' @examples
#' pbmc_small
#'
setMethod(
f = "show",
signature = "Seurat",
definition = function(object) {
#object <- UpdateSlots(object = object)
x <- tryCatch(
expr = slot(object = object, name = 'images'),
error = function(...) {stop("Please run UpdateSeuratObject on your object", call. = FALSE)})
assays <- .FilterObjects(object = object, classes.keep = c('Assay', 'StdAssay'))
nfeatures <- sum(vapply(
X = assays,
FUN = function(x) {
return(nrow(x = object[[x]]))
},
FUN.VALUE = numeric(length = 1L)
))
num.assays <- length(x = assays)
cat("An object of class", class(x = object), "\n")
cat(
nfeatures,
'features across',
ncol(x = object),
'samples within',
num.assays,
ifelse(test = num.assays == 1, yes = 'assay', no = 'assays'),
"\n"
)
cat(
"Active assay:",
DefaultAssay(object = object),
paste0(
'(',
nrow(x = object),
' features, ',
length(x = suppressWarnings(expr = VariableFeatures(object = object))),
' variable features)'
)
)
cat(
'\n',
length(x = Layers(object = object)),
ifelse(
test = length(x = Layers(object = object)) == 1L,
yes = 'layer',
no = 'layers'
),
'present:',
strwrap(x = paste(Layers(object = object), collapse = ', '))
)
other.assays <- assays[assays != DefaultAssay(object = object)]
if (length(x = other.assays) > 0) {
cat(
'\n',
length(x = other.assays),
'other',
ifelse(test = length(x = other.assays) == 1, yes = 'assay', no = 'assays'),
'present:',
strwrap(x = paste(other.assays, collapse = ', '))
)
}
reductions <- .FilterObjects(object = object, classes.keep = 'DimReduc')
if (length(x = reductions) > 0) {
cat(
'\n',
length(x = reductions),
'dimensional',
ifelse(test = length(x = reductions) == 1, yes = 'reduction', no = 'reductions'),
'calculated:',
strwrap(x = paste(reductions, collapse = ', '))
)
}
fovs <- .FilterObjects(object = object, classes.keep = 'FOV')
if (length(x = fovs)) {
cat(
'\n',
length(x = fovs),
'spatial',
ifelse(test = length(x = fovs) == 1L, yes = 'field', no = 'fields'),
'of view present:',
strwrap(x = paste(fovs, sep = ', '))
)
}
images <- .FilterObjects(object = object, classes.keep = 'SpatialImage')
images <- setdiff(x = images, y = fovs)
if (length(x = images)) {
cat(
'\n',
length(x = images),
ifelse(test = length(x = images) == 1L, yes = 'image', no = 'images'),
'present:',
strwrap(x = paste(images, collapse = ', '))
)
}
cat('\n')
}
)
#' Old Seurat Object Overview
#'
#' Overview of a \code{\link[=oldseurat]{seurat}} object overview
#'
#' @param object An old seurat object
#'
#' @template return-show
#'
#' @rdname show-oldseurat-method
#'
#' @keywords internal
#'
#' @concept oldseurat
#'
setMethod(
f = 'show',
signature = 'seurat',
definition = function(object) {
cat(
"An old seurat object\n",
nrow(x = object@data),
'genes across',
ncol(x = object@data),
'samples\n'
)
}
)
#' Seurat Object Validity
#'
#' @templateVar cls Seurat
#' @template desc-validity
#'
#' @name Seurat-validity
#'
#' @family seurat
#'
#' @seealso \code{\link[methods]{validObject}}
#'
setValidity(
Class = 'Seurat',
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
# TODO: Check meta data
md <- slot(object = object, name = 'meta.data')
# if (length(x = class(x = md)) != 1L || class(x = md) != 'data.frame') {
if (!.IsDataFrame(x = md)) {
valid <- c(valid, "'meta.data' must be a base-R data.frame")
}
if (ncol(x = md)) {
if (is.null(x = names(x = md)) || any(!nzchar(x = names(x = md)))) {
valid <- c(valid, "all columns in 'meta.data' must be named")
}
}
# TODO: Check cells
ocells <- colnames(x = object)
if (anyDuplicated(x = ocells)) {
valid <- c(valid, "cell names may not be duplicated")
}
# TODO: Check assays
if (!IsNamedList(x = slot(object = object, name = 'assays'))) {
valid <- c(valid, "'assays' must be a named list")
} else {
for (assay in Assays(object = object)) {
if (!inherits(x = object[[assay]], what = c('Assay', 'StdAssay'))) {
valid <- c(valid, "'assays' must be a list of 'Assay' objects")
break
}
acells <- colnames(x = object[[assay]])
if (!all(acells %in% ocells)) {
valid <- c(valid, "all cells in assays must be present in the Seurat object")
} else if (is.unsorted(x = MatchCells(new = acells, orig = ocells, ordered = TRUE))) {
valid <- c(
valid,
"all cells in assays must be in the same order as the Seurat object"
)
}
if (!isTRUE(x = nzchar(x = Key(object = object[[assay]])))) {
valid <- c(valid, "all assays must have a key")
}
}
}
# TODO: Check reductions
if (!IsNamedList(x = slot(object = object, name = 'reductions'), pass.zero = TRUE)) {
valid <- c(valid, "'reductions' must be a named list")
} else {
for (reduc in Reductions(object = object)) {
# Check cells
rcells <- Cells(x = object[[reduc]])
if (!all(rcells %in% ocells)) {
valid <- c(valid, "All cells in reductions must be present in the Seurat object")
} else if (is.unsorted(x = MatchCells(new = rcells, orig = ocells, ordered = TRUE))) {
valid <- c(valid, "all cells in reductions must be in the same order as the Seurat object")
}
# TODO: Check features
# TODO: Check default assay
}
}
# Check graphs
if (!IsNamedList(x = slot(object = object, name = 'graphs'), pass.zero = TRUE)) {
valid <- c(valid, "'graphs' must be a named list")
} else {
for (graph in Graphs(object = object)) {
gnames <- Cells(x = object[[graph]], margin = NA_integer_)
# if (!DefaultAssay(object = object[[graph]]) %in% Assays(object = object)) {
# valid <- c(
# valid,
# "the default assay for graphs must be present in the Seurat object"
# )
# }
if (!all(gnames %in% colnames(x = object))) {
valid <- c(valid, "all cells in graphs must be present in the Seurat object")
} else if (is.unsorted(x = MatchCells(new = gnames, orig = ocells, ordered = TRUE))) {
valid <- c(
valid,
paste0(
"all cells in graphs must be in the same order as the Seurat object (offending: ",
graph,
")"
)
)
}
}
}
# Check neighbors
if (!IsNamedList(x = slot(object = object, name = 'neighbors'), pass.zero = TRUE)) {
valid <- c(valid, "'neighbors' must be a named list")
} else {
for (nn in Neighbors(object = object)) {
ncells <- Cells(x = object[[nn]])
if (!all(ncells %in% ocells)) {
valid <- c(valid, "All cells in neighbor objects must be present in the Seurat object")
} else if (is.unsorted(x = MatchCells(new = ncells, orig = ocells, ordered = TRUE))) {
valid <- c(valid, "All cells in neighbor objects must be in the same order as the Seurat object")
}
}
}
# Check images
if (!IsNamedList(x = slot(object = object, name = 'images'), pass.zero = TRUE)) {
valid <- c(valid, "'images' must be a named list")
} else {
for (img in Images(object = object)) {
icells <- Cells(x = object[[img]])
if (!all(icells %in% ocells)) {
valid <- c(valid, "All cells in images must be present in the Seurat object")
}
# else if (is.unsorted(x = MatchCells(new = icells, orig = ocells, ordered = TRUE))) {
# valid <- c(valid, "All cells in images must be in the same order as the Seurat object")
# }
}
}
# TODO: Check project
proj <- Project(object = object)
if (length(x = proj) != 1L) {
valid <- c(valid, "'project' must be a 1-length character vector")
} else if (is.na(x = proj)) {
valid <- c(valid, "'project' cannot be NA")
} else if (!nzchar(x = proj)) {
valid <- c(valid, "'project' cannot be an empty character")
}
# TODO: Check idents
idents <- Idents(object = object)
if (length(x = idents) != ncol(x = object)) {
valid <- c(
valid,
"'active.idents' must be as long as the number of cells present"
)
} else if (!all(names(x = idents) == colnames(x = object))) {
valid <- c(valid, "'active.idents' must be named with cell names")
}
# TODO: Check version
if (length(x = slot(object = object, name = 'version')) > 1) {
valid <- c(valid, "Only one version is allowed")
}
return(valid %||% TRUE)
}
)
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Internal
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
.FilterCells <- function(object, validate = TRUE) {
objs <- .FilterObjects(
object = object,
classes.keep = c(
'Assay', # assays
'StdAssay', # assays
'Graph', # graphs
'Neighbor', # neighbors
'DimReduc', # reductions
'SpatialImage' # images
)
)
''
}
.SubobjectAssign <- function() {
classes <- slot(
object = methods::findMethods(f = '[[<-', classes = 'Seurat'),
name = 'signatures'
)
classes <- Filter(f = function(x) x[1] == 'Seurat', x = classes)
classes <- vapply(
X = classes,
FUN = function(x) {
return(x[length(x = x)])
},
FUN.VALUE = character(length = 1L)
)
classes <- unique(x = classes)
classes <- setdiff(
x = classes,
y = c('Seurat', 'ANY', 'NULL', 'vector', 'list', 'StdAssay')
)
classes <- Filter(
f = function(x) {
cdef <- methods::getClass(Class = x)
return(!'oldClass' %in% names(x = slot(object = cdef, name = 'contains')))
},
x = classes
)
}
#' Object Collections
#'
#' Find the names of collections in an object
#'
#' @param object An S4 object
#'
#' @return A vector with the names of slots that are a list
#'
#' @keywords internal
#'
#' @noRd
#'
#' @examples
#' \donttest{
#' SeuratObject:::Collections(pbmc_small)
#' }
#'
Collections <- function(object) {
if (!isS4(object)) {
return(NULL)
}
collections <- vapply(
X = slotNames(x = object),
FUN = function(x) {
return(inherits(x = slot(object = object, name = x), what = 'list'))
},
FUN.VALUE = logical(length = 1L)
)
collections <- Filter(f = isTRUE, x = collections)
return(names(x = collections))
}
#' Get the default image of an object
#'
#' Attempts to find all images associated with the default assay of the object.
#' If none present, finds all images present in the object. Returns the name of
#' the first image
#'
#' @param object A \code{\link{Seurat}} object
#'
#' @return The name of the default image
#'
#' @keywords internal
#'
#' @noRd
#'
DefaultImage <- function(object) {
object <- UpdateSlots(object = object)
images <- Images(object = object, assay = DefaultAssay(object = object))
if (length(x = images) < 1) {
images <- Images(object = object)
}
return(images[[1]])
}
#' Find the collection of an object within a Seurat object
#'
#' @param object A \code{\link{Seurat}} object
#' @param name Name of object to find
#'
#' @return The collection (slot) of the object
#'
#' @keywords internal
#'
#' @noRd
#'
#' @examples
#' \donttest{
#' SeuratObject:::FindObject(pbmc_small, name = "RNA")
#' }
#'
FindObject <- function(object, name) {
collections <- c(
'assays',
'graphs',
'neighbors',
'reductions',
'commands',
'images'
)
object.names <- lapply(
X = collections,
FUN = function(x) {
return(names(x = slot(object = object, name = x)))
}
)
names(x = object.names) <- collections
object.names <- Filter(f = Negate(f = is.null), x = object.names)
for (i in names(x = object.names)) {
if (name %in% names(x = slot(object = object, name = i))) {
return(i)
}
}
return(NULL)
}
#' Update Seurat v2 Internal Objects
#'
#' Helper functions to update old Seurat v2 objects to v3/v4 objects
#'
#' @param old.assay,old.dr,old.jackstraw Seurat v2 assay, dimensional
#' reduction, or jackstraw object
#' @param assay Name to store for assay in new object
#'
#' @return A v3/v4 \code{\link{Assay}}, \code{\link{DimReduc}}, or
#' \code{\link{JackStrawData}} object
#'
#' @name V2Update
#' @rdname V2Update
#'
#' @keywords internal
#'
#' @noRd
#'
UpdateAssay <- function(old.assay, assay) {
if (!is.null(x = old.assay@data)) {
cells <- colnames(x = old.assay@data)
} else {
cells <- colnames(x = old.assay@raw.data)
}
counts <- old.assay@raw.data
data <- old.assay@data
if (!inherits(x = counts, what = 'dgCMatrix')) {
counts <- as.sparse(x = as.matrix(x = counts))
}
if (!is.null(x = data)) {
if (!inherits(x = data, what = 'dgCMatrix')) {
data <- as.sparse(x = as.matrix(x = data))
}
} else {
data <- as.sparse(
x = Matrix(
data = 0,
nrow = nrow(x = counts),
ncol = ncol(x = counts),
dimnames = dimnames(x = counts)
),
)
}
if (!inherits(x = old.assay@scale.data, what = 'matrix')) {
scale.data <- new(Class = 'matrix')
} else {
scale.data <- old.assay@scale.data
}
new.assay <- new(
Class = 'Assay',
counts = counts[, cells],
data = data,
scale.data = scale.data,
meta.features = data.frame(row.names = rownames(x = counts)),
var.features = old.assay@var.genes,
key = paste0(assay, "_")
)
return(new.assay)
}
#' @param assay.used Name of assay used to compute dimension reduction
#'
#' @importFrom methods new
#'
#' @rdname V2Update
#'
#' @noRd
#'
UpdateDimReduction <- function(old.dr, assay) {
new.dr <- list()
for (i in names(x = old.dr)) {
cell.embeddings <- old.dr[[i]]@cell.embeddings %||% new(Class = 'matrix')
feature.loadings <- old.dr[[i]]@gene.loadings %||% new(Class = 'matrix')
stdev <- old.dr[[i]]@sdev %||% numeric()
misc <- old.dr[[i]]@misc %||% list()
new.jackstraw <- UpdateJackstraw(old.jackstraw = old.dr[[i]]@jackstraw)
old.key <- old.dr[[i]]@key
if (length(x = old.key) == 0) {
old.key <- gsub(pattern = "(.+?)(([0-9]+).*)", replacement = "\\1", x = colnames(cell.embeddings)[[1]])
if (length(x = old.key) == 0) {
old.key <- i
}
}
new.key <- suppressWarnings(expr = UpdateKey(key = old.key))
colnames(x = cell.embeddings) <- gsub(
pattern = old.key,
replacement = new.key,
x = colnames(x = cell.embeddings)
)
colnames(x = feature.loadings) <- gsub(
pattern = old.key,
replacement = new.key,
x = colnames(x = feature.loadings)
)
new.dr[[i]] <- new(
Class = 'DimReduc',
cell.embeddings = as(object = cell.embeddings, Class = 'matrix'),
feature.loadings = as(object = feature.loadings, Class = 'matrix'),
assay.used = assay,
global = FALSE,
stdev = as(object = stdev, Class = 'numeric'),
key = as(object = new.key, Class = 'character'),
jackstraw = new.jackstraw,
misc = as(object = misc, Class = 'list')
)
}
return(new.dr)
}
#' @importFrom methods .hasSlot new
#'
#' @rdname V2Update
#'
#' @keywords internal
#'
#' @noRd
#'
UpdateJackstraw <- function(old.jackstraw) {
if (is.null(x = old.jackstraw)) {
new.jackstraw <- new(
Class = 'JackStrawData',
empirical.p.values = new(Class = 'matrix'),
fake.reduction.scores = new(Class = 'matrix'),
empirical.p.values.full = new(Class = 'matrix'),
overall.p.values = new(Class = 'matrix')
)
} else {
if (.hasSlot(object = old.jackstraw, name = 'overall.p.values')) {
overall.p <- old.jackstraw@overall.p.values %||% new(Class = 'matrix')
} else {
overall.p <- new(Class = 'matrix')
}
new.jackstraw <- new(
Class = 'JackStrawData',
empirical.p.values = old.jackstraw@emperical.p.value %||% new(Class = 'matrix'),
fake.reduction.scores = old.jackstraw@fake.pc.scores %||% new(Class = 'matrix'),
empirical.p.values.full = old.jackstraw@emperical.p.value.full %||% new(Class = 'matrix'),
overall.p.values = overall.p
)
}
return(new.jackstraw)
}
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.