R/seurat.R
In mojaveazure/seurat-object: Data Structures for Single Cell Data
Defines functions
UpdateJackstraw
UpdateDimReduction
UpdateAssay
FindObject
DefaultImage
Collections
.SubobjectAssign
.FilterCells
upgrade.seurat
subset.Seurat
split.Seurat
names.Seurat
merge.Seurat
levels.Seurat
droplevels.Seurat
dimnames.Seurat
dim.Seurat
Version.Seurat
WhichCells.Seurat
VariableFeatures.Seurat
Tool.Seurat
SVFInfo.Seurat
Stdev.Seurat
StashIdent.Seurat
SpatiallyVariableFeatures.Seurat
SetIdent.Seurat
SetAssayData.Seurat
RenameIdents.Seurat
RenameCells.Seurat
ReorderIdent.Seurat
Project.Seurat
Loadings.Seurat
Layers.Seurat
LayerData.Seurat
Key.Seurat
JoinLayers.Seurat
Idents.Seurat
HVFInfo.Seurat
GetTissueCoordinates.Seurat
GetImage.Seurat
GetAssayData.Seurat
FetchData.Seurat
Features.Seurat
Embeddings.Seurat
DefaultFOV.Seurat
DefaultAssay.Seurat
CreateSeuratObject.Assay
CreateSeuratObject.default
Command.Seurat
Cells.Seurat
CastAssay.Seurat
Assays.Seurat
UpdateSeuratObject
SaveSeuratRds
RenameAssays
Reductions
Neighbors
LoadSeuratRds
Images
Graphs
FilterObjects
CellsByImage
CellsByIdentities
Documented in
Assays.Seurat
CellsByIdentities
CellsByImage
Command.Seurat
CreateSeuratObject.Assay
CreateSeuratObject.default
DefaultAssay.Seurat
DefaultFOV.Seurat
dimnames.Seurat
dim.Seurat
droplevels.Seurat
Embeddings.Seurat
FetchData.Seurat
GetImage.Seurat
GetTissueCoordinates.Seurat
Graphs
Idents.Seurat
Images
JoinLayers.Seurat
Key.Seurat
levels.Seurat
Loadings.Seurat
merge.Seurat
names.Seurat
Neighbors
Project.Seurat
Reductions
RenameAssays
RenameCells.Seurat
RenameIdents.Seurat
ReorderIdent.Seurat
SetIdent.Seurat
split.Seurat
StashIdent.Seurat
Stdev.Seurat
subset.Seurat
Tool.Seurat
UpdateSeuratObject
Version.Seurat
WhichCells.Seurat
#' @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)
}
mojaveazure/seurat-object documentation built on Aug. 3, 2024, 4:59 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions UpdateJackstraw UpdateDimReduction UpdateAssay FindObject DefaultImage Collections .SubobjectAssign .FilterCells upgrade.seurat subset.Seurat split.Seurat names.Seurat merge.Seurat levels.Seurat droplevels.Seurat dimnames.Seurat dim.Seurat Version.Seurat WhichCells.Seurat VariableFeatures.Seurat Tool.Seurat SVFInfo.Seurat Stdev.Seurat StashIdent.Seurat SpatiallyVariableFeatures.Seurat SetIdent.Seurat SetAssayData.Seurat RenameIdents.Seurat RenameCells.Seurat ReorderIdent.Seurat Project.Seurat Loadings.Seurat Layers.Seurat LayerData.Seurat Key.Seurat JoinLayers.Seurat Idents.Seurat HVFInfo.Seurat GetTissueCoordinates.Seurat GetImage.Seurat GetAssayData.Seurat FetchData.Seurat Features.Seurat Embeddings.Seurat DefaultFOV.Seurat DefaultAssay.Seurat CreateSeuratObject.Assay CreateSeuratObject.default Command.Seurat Cells.Seurat CastAssay.Seurat Assays.Seurat UpdateSeuratObject SaveSeuratRds RenameAssays Reductions Neighbors LoadSeuratRds Images Graphs FilterObjects CellsByImage CellsByIdentities
Documented in Assays.Seurat CellsByIdentities CellsByImage Command.Seurat CreateSeuratObject.Assay CreateSeuratObject.default DefaultAssay.Seurat DefaultFOV.Seurat dimnames.Seurat dim.Seurat droplevels.Seurat Embeddings.Seurat FetchData.Seurat GetImage.Seurat GetTissueCoordinates.Seurat Graphs Idents.Seurat Images JoinLayers.Seurat Key.Seurat levels.Seurat Loadings.Seurat merge.Seurat names.Seurat Neighbors Project.Seurat Reductions RenameAssays RenameCells.Seurat RenameIdents.Seurat ReorderIdent.Seurat SetIdent.Seurat split.Seurat StashIdent.Seurat Stdev.Seurat subset.Seurat Tool.Seurat UpdateSeuratObject Version.Seurat WhichCells.Seurat
#' @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)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.