Merge pull request #510 from lazappi/cellnames

Improve setting of cell names

NAMESPACE

@@ -142,6 +142,7 @@ export(Read10X_h5)
 export(RefinedMapping)
 export(RegressOut)
 export(RemoveFromTable)
+export(RenameCells)
 export(RenameIdent)
 export(ReorderIdent)
 export(RidgePlot)

R/dimensional_reduction.R

@@ -759,6 +759,8 @@ RunCCA <- function(
 #'
 #' @param object.list List of Seurat objects
 #' @param genes.use Genes to use in mCCA.
+#' @param add.cell.ids Vector of strings to pass to \code{\link{RenameCells}} to
+#' give unique cell names
 #' @param niter Number of iterations to perform. Set by default to 25.
 #' @param num.ccs Number of canonical vectors to calculate
 #' @param standardize standardize scale.data matrices to be centered (mean zero)
@@ -781,7 +783,8 @@ RunCCA <- function(
 #' # Print results
 #' PrintDim(pbmc_cca,reduction.type = 'cca')
 #'
-RunMultiCCA <- function(object.list, genes.use, niter = 25, num.ccs = 1, standardize = TRUE){
+RunMultiCCA <- function(object.list, genes.use, add.cell.ids = NULL,
+                        niter = 25, num.ccs = 1, standardize = TRUE){
   set.seed(42)
   if(length(object.list) < 3){
     stop("Must give at least 3 objects/matrices for MultiCCA")
@@ -808,6 +811,21 @@ RunMultiCCA <- function(object.list, genes.use, niter = 25, num.ccs = 1, standar
   else{
     stop("input data not Seurat objects")
   }
+
+  if (!missing(add.cell.ids)) {
+    if (length(add.cell.ids) != length(object.list)) {
+      stop("add.cell.ids must have the same length as object.list")
+    }
+    object.list <- lapply(seq_along(object.list), function(i) {
+      RenameCells(object = object.list[[i]], add.cell.id = add.cell.ids[i])
+    })
+  }
+  names.list <- lapply(object.list, slot, name = "cell.names")
+  names.intersect <- Reduce(intersect, names.list)
+  if(length(names.intersect) > 0) {
+    stop("duplicate cell names detected, please set 'add.cell.ids'")
+  }
+
   num.sets <- length(mat.list)
   if(standardize){
     for (i in 1:num.sets){

R/interaction.R

@@ -24,8 +24,8 @@ globalVariables(names = 'cell.name', package = 'Seurat', add = TRUE)
 #' field from the cell's column name
 #' @param names.delim For the initial identity class for each cell, choose this
 #' delimiter from the cell's column name
-#' @param add.cell.id1 String to be appended to the names of all cells in object1
-#' @param add.cell.id2 String to be appended to the names of all cells in object2
+#' @param add.cell.id1 String passed to \code{\link{RenameCells}} for object1
+#' @param add.cell.id2 String passed to \code{\link{RenameCells}} for object1
 #'
 #' @return Merged Seurat object
 #'
@@ -67,30 +67,10 @@ MergeSeurat <- function(
     stop("Second object provided has an empty raw.data slot. Adding/Merging performed on raw count data.")
   }
   if (!missing(x = add.cell.id1)) {
-    object1@cell.names <- paste(add.cell.id1,object1@cell.names, sep = "_")
-    colnames(x = object1@raw.data) <- paste(
-      add.cell.id1,
-      colnames(x = object1@raw.data),
-      sep = "_"
-    )
-    rownames(x = object1@meta.data) <- paste(
-      add.cell.id1,
-      rownames(x = object1@meta.data),
-      sep = "_"
-    )
+    object1 <- RenameCells(object1, add.cell.id = add.cell.id1)
   }
   if (!missing(x = add.cell.id2)) {
-  object2@cell.names <- paste(add.cell.id2,object2@cell.names, sep = "_")
-    colnames(x = object2@raw.data) <- paste(
-      add.cell.id2,
-      colnames(x = object2@raw.data),
-      sep = "_"
-    )
-    rownames(x = object2@meta.data) <- paste(
-      add.cell.id2,
-      rownames(x = object2@meta.data),
-      sep = "_"
-    )
+    object2 <- RenameCells(object2, add.cell.id = add.cell.id2)
   }
   if (any(object1@cell.names %in% object2@cell.names)) {
     stop("Duplicate cell names, please provide 'add.cell.id1' and/or 'add.cell.id2' for unique names")
@@ -313,21 +293,21 @@ AddSamples <- function(
 #' Creates a Seurat object containing only a subset of the cells in the
 #' original object. Forms a dataframe by fetching the variables in \code{vars.use}, then
 #' subsets it using \code{base::subset} with \code{predicate} as the filter.
-#' Returns the corresponding subset of the Seurat object. 
+#' Returns the corresponding subset of the Seurat object.
 #'
 #' @param object Seurat object
 #' @param vars.use Variables to fetch for use in base::subset. Character vector.
 #' @param predicate String to be parsed into an R expression and evaluated as an input to base::subset.
-#' 
+#'
 #' @export
 #'
 #' @examples
-#' pbmc1 <- SubsetByPredicate(object = pbmc_small, 
-#'                       vars.use = c("nUMI", "res.1"), 
+#' pbmc1 <- SubsetByPredicate(object = pbmc_small,
+#'                       vars.use = c("nUMI", "res.1"),
 #'                       predicate = "nUMI < 200 & res.1=='3'")
 #' pbmc1
 #'
-SubsetByPredicate = function( 
+SubsetByPredicate = function(
   object,
   vars.use,
   predicate
@@ -1144,3 +1124,82 @@ AddMetaData <- function(object, metadata, col.name = NULL) {
   object@meta.data[, cols.add] <- meta.add
   return(object)
 }
+
+
+#' Rename cells
+#'
+#' Change the cell names in all the different parts of a Seurat object. Can
+#' be useful before combining multiple objects.
+#'
+#' @param object Seurat object
+#' @param add.cell.id prefix to add cell names
+#' @param new.names vector of new cell names
+#'
+#' @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.
+#'
+#' @return Seurat object with new cell names
+#'
+#' @export
+#'
+#' @examples
+#' head(pbmc_small@cell.names)
+#' pbmc_small <- RenameCells(pbmc_small, add.cell.id = "Test")
+#' head(pbmc_small@cell.names)
+#'
+RenameCells <- function(object, add.cell.id = NULL, new.names = NULL) {
+
+  if (missing(add.cell.id) && missing(new.names)) {
+    stop("One of 'add.cell.id' and 'new.names' must be set")
+  }
+
+  if (!missing(add.cell.id) && !missing(new.names)) {
+    stop("Only one of 'add.cell.id' and 'new.names' must be set")
+  }
+
+  if (!missing(add.cell.id)) {
+    new.cell.names <- paste(add.cell.id, object@cell.names, sep = "_")
+  } else {
+    if (length(new.names) == length(object@cell.names)) {
+      new.cell.names <- new.names
+    } else {
+      stop("the length of 'new.names' (", length(new.names), ") must be the ",
+           "same as the length of 'object@cell.names' (",
+           length(object@cell.names), ")")
+    }
+  }
+
+  object@cell.names <- new.cell.names
+  colnames(object@raw.data) <- new.cell.names
+  colnames(object@data) <- new.cell.names
+
+  if (!is.null(object@scale.data)) {
+    colnames(object@scale.data) <- new.cell.names
+  }
+  rownames(object@meta.data) <- new.cell.names
+  names(object@ident) <- new.cell.names
+
+  if (length(object@dr) > 0) {
+    for (dr in names(object@dr)) {
+      rownames(object@dr[[dr]]@cell.embeddings) <- new.cell.names
+    }
+  }
+  if (nrow(object@snn) == length(new.cell.names)) {
+    colnames(object@snn) <- new.cell.names
+    rownames(object@snn) <- new.cell.names
+  }
+
+  if (!is.null(object@kmeans)) {
+    if (!is.null(object@kmeans@gene.kmeans.obj)) {
+      colnames(object@kmeans@gene.kmeans.obj$centers) <- new.cell.names
+    }
+    if (!is.null(object@kmeans@cell.kmeans.obj)) {
+      names(object@kmeans@cell.kmeans.obj$cluster) <- new.cell.names
+    }
+  }
+
+  rownames(object@spatial@mix.probs) <- new.cell.names
+
+  return(object)
+}

tests/testthat/test_alignment.R

@@ -31,3 +31,9 @@ test_that("CalcVarExpRatio performs as expectd", {
   expect_equal(pbmc_cca@meta.data$var.ratio.pca[40], 0.5198426, tolerance = 1e-6)
   expect_equal(pbmc_cca@meta.data$var.ratio.pca[80], 0.9824946, tolerance = 1e-6)
 })
+
+test_that("RunMultiCCA works with add.cell.ids", {
+  pbmc_multi_cca <- RunMultiCCA(list(pbmc_small, pbmc_small, pbmc_small),
+                                add.cell.ids = c("A", "B", "C"))
+  expect_s4_class(pbmc_multi_cca, "seurat")
+})

tests/testthat/test_interaction.R

@@ -101,3 +101,41 @@ test_that("do.clean and do.raw work", {
   expect_equal(length(x@dr), 2)
 })
 
+# Tests for RenameCells
+# --------------------------------------------------------------------------------
+context("RenameCells")
+
+test_that("argument checks work", {
+  expect_error(RenameCells(pbmc_small),
+               "One of 'add.cell.id' and 'new.names' must be set")
+  expect_error(RenameCells(pbmc_small, add.cell.id = "A", new.names = "A"),
+               "Only one of 'add.cell.id' and 'new.names' must be set")
+})
+
+test_that("add.cell.id works", {
+    test.names <- paste("Test", pbmc_small@cell.names, sep = "_")
+    x <- RenameCells(pbmc_small, add.cell.id = "Test")
+    expect_equal(x@cell.names, test.names)
+    expect_equal(colnames(x@raw.data), test.names)
+    expect_equal(colnames(x@data), test.names)
+    expect_equal(colnames(x@scale.data), test.names)
+    expect_equal(rownames(x@meta.data), test.names)
+    expect_equal(names(x@ident), test.names)
+    expect_equal(rownames(x@dr$pca@cell.embeddings), test.names)
+    expect_equal(rownames(x@dr$tsne@cell.embeddings), test.names)
+    expect_equal(rownames(x@spatial@mix.probs), test.names)
+})
+
+test_that("new.names works", {
+  test.names <- paste0("A", 1:80)
+  x <- RenameCells(pbmc_small, new.names = paste0("A", 1:80))
+  expect_equal(x@cell.names, test.names)
+  expect_equal(colnames(x@raw.data), test.names)
+  expect_equal(colnames(x@data), test.names)
+  expect_equal(colnames(x@scale.data), test.names)
+  expect_equal(rownames(x@meta.data), test.names)
+  expect_equal(names(x@ident), test.names)
+  expect_equal(rownames(x@dr$pca@cell.embeddings), test.names)
+  expect_equal(rownames(x@dr$tsne@cell.embeddings), test.names)
+  expect_equal(rownames(x@spatial@mix.probs), test.names)
+})