#' @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
#'
#'
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
#' \dontrun{
#' 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 = droplevels(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 (!identical(md.features, data.features)) {
          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]]
        if (inherits(x = xobj, what = 'FOV')) {
          fov_name <- x
          # Needs coord system update if 
          # object doesn't have coords_x_orientation slot or 
          # was saved prior to correction
          old_axis_orientation <- (!.hasSlot(xobj, "coords_x_orientation")) || (.hasSlot(xobj, "coords_x_orientation") && (slot(xobj, "coords_x_orientation") != 'horizontal'))
          is_visium <- inherits(xobj, "VisiumV1") || inherits(xobj, "VisiumV2")
          if (is_visium && old_axis_orientation) {
            tryCatch(
              expr = {
                boundaries <- slot(object = xobj, name = 'boundaries')
                # Find all centroid objects in boundaries
                centroids_indices <- which(sapply(X = boundaries, FUN = inherits, what = 'Centroids'))

                if (length(centroids_indices) > 0) {
                  centroids_names <- names(boundaries)[centroids_indices]
                  # Process each centroids object
                  for (i in seq_along(centroids_indices)) {
                    cent_name <- centroids_names[i]
                    cent <- boundaries[[cent_name]]

                    new_coords <- GetTissueCoordinates(object = cent)
                    old_x_coords <- new_coords$x
                    new_coords$x <- new_coords$y
                    new_coords$y <- old_x_coords
                    updated_cent <- CreateCentroids(new_coords, radius = Radius(cent))
                    boundaries[[cent_name]] <- updated_cent
                    message("Updated Centroids object ", sQuote(cent_name), " in FOV ", sQuote(fov_name))
                  }

                  # Update the FOV object if any boundaries were modified
                  message("Updated boundaries in FOV ", sQuote(fov_name))
                  slot(object = xobj, name = 'boundaries') <- boundaries
                  slot(object = xobj, name = 'coords_x_orientation') <- 'horizontal' # Update flag
                }
              },
              error = function(e) {
                message("Error updating objects in boundaries in FOV ", sQuote(fov_name))
              }
            )
          }
        }
        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 retrieve coordinates for the default image
#'
#' @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)

  all.cells <- colnames(object)
  default.cells <- Cells(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.names <- paste(add.cell.id, all.cells, sep = "_")
    cells.to.rename <- all.cells
  } else {
    # Determine which set of cells names `new.names` is intended to replace.
    # If `new.names` is a named vector, assume it should provide the mapping
    # we need.
    if (!is.null(names(new.names))) {
      cells.to.rename <- names(new.names)
    } else {
      # If `new.names` contains a value for every cell in the object, we'll
      # assume that `new.names` and `all.cells` are co-indexed.
      if (length(new.names) == length(all.cells)) {
        cells.to.rename <- all.cells
        # If `new.names` contains a value for every cell in the default assay,
        # we'll assume that `new.names` and `default.cells` are co-indexed.
      } else if (length(new.names) == length(default.cells)) {
        cells.to.rename <- default.cells
        # If the length of `new.names` doesn't match either option, we don't
        # know what cells to rename, so we'll throw an error.
      } else {
        stop(
          sprintf(
            paste(
              "`new.names` should be a named list or else be the same length",
              "as `colnames(object)` (%i) or `Cells(object)` (%i).",
              "`length(new.names)` was %i."
            ),
            length(all.cells),
            length(default.cells),
            length(new.names)
          )
        )
      }
    }
  }

  # Validate that `cells.to.rename` only contains valid cell names.
  missing.cells <- setdiff(cells.to.rename, all.cells)
  if (length(missing.cells) > 0) {
    stop("The following cells are not present in `object`: ...")
  }

  # Create a global mapping for all cell names in `object`.
  new.cell.names <- setNames(all.cells, all.cells)
  new.cell.names[cells.to.rename] <- new.names

  # 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)
  names(old.ids) <- new.cell.names
  Idents(object) <- old.ids
  # 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 <- all.vars(expr)
    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 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
  )
  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[assay.objs],
      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)
}
