Fix cellMeta bug

R/liger-class.R

@@ -637,6 +637,24 @@ setMethod("length", signature(x = "liger"), function(x) {
 #' \code{ggplot(ligerObj, aes(...))} where cell metadata variables can be
 #' directly thrown into \code{aes()}.
 #'
+#' Special partial metadata insertion is implemented specifically for mapping
+#' categorical annotation from sub-population (subset object) back to original
+#' experiment (full-size object). For example, when sub-clustering and
+#' annotation is done for a specific cell-type of cells (stored in
+#' \code{subobj}) subset from an experiment (stored as \code{obj}), users can do
+#' \code{cellMeta(obj, "sub_ann", cellIdx = colnames(subobj)) <- subobj$sub_ann}
+#' to map the value back, leaving other cells non-annotated with NAs. Plotting
+#' with this variable will then also show NA cells with default grey color.
+#' Furthermore, sub-clustering labels for other cell types can also be mapped
+#' to the same variable. For example, \code{cellMeta(obj, "sub_ann",
+#' cellIdx = colnames(subobj2)) <- subobj2$sub_ann}. As long as the labeling
+#' variables are stored as factor class (categorical), the levels (category
+#' names) will be properly handled and merged. Other situations follow the R
+#' default behavior (e.g. categories might be converted to integer numbers if
+#' mapped to numerical variable in the original object). Note that this feature
+#' is only available with using the generic function \code{cellMeta} but not
+#' with the \code{`[[`} or \code{`$`} accessing methods due to syntax reasons.
+#'
 #' The generic \code{defaultCluster} works as both getter and setter. As a
 #' setter, users can do \code{defaultCluster(obj) <- "existingVariableName"} to
 #' set a categorical variable as default cluster used for visualization or
@@ -683,6 +701,15 @@ setGeneric(
         }
         res <- res[, columns, ...]
     }
+    if (length(columns) == 1) {
+        if (is.vector(res) || is.factor(res)) {
+            names(res) <- colnames(object)
+        } else if (!is.null(dim(res))) {
+            rownames(res) <- colnames(object)
+        } else {
+            warning("Failed to set cell IDs to returned value")
+        }
+    }
     if (!is.null(cellIdx)) {
         cellIdx <- .idxCheck(object, idx = cellIdx, orient = "cell")
         if (is.vector(res) || is.factor(res)) res <- res[cellIdx]
@@ -773,30 +800,63 @@ setReplaceMethod(
                 if (is.null(dim(value))) {
                     # vector/factor
                     x@cellMeta[[columns]] <- NA
-                    x@cellMeta[[columns]][cellIdx] <- value
+                    if (is.factor(value)) {
+                        charValue <- as.character(value)
+                        x@cellMeta[[columns]][cellIdx] <- charValue
+                        x@cellMeta[[columns]] <- factor(x@cellMeta[[columns]],
+                                                        levels = levels(value))
+                    } else {
+                        x@cellMeta[[columns]][cellIdx] <- value
+                    }
+                    if (!is.null(names(value))) {
+                        if (!identical(colnames(x)[cellIdx], names(value))) {
+                            warning("Names of inserted values do not ",
+                                    "match to cell IDs at specified index ",
+                                    "of the object. Forced to store using ",
+                                    "object colnames.")
+                        }
+                    }
                 } else {
                     # matrix like
                     x@cellMeta[[columns]] <- matrix(NA, ncol(x), ncol(value))
                     x@cellMeta[[columns]][cellIdx,] <- value
+                    if (!is.null(colnames(value))) {
+                        colnames(x@cellMeta[[columns]]) <- colnames(value)
+                    }
+                    if (!is.null(rownames(value))) {
+                        if (!identical(rownames(value), colnames(x)[cellIdx])) {
+                            warning("Rownames of inserted values do not match ",
+                                    "to cell IDs at specified index of the ",
+                                    "object. Forced to store using object ",
+                                    "colnames.")
+                        }
+                    }
                 }
             } else {
-                if (is.null(dim(value)) && is.null(x@cellMeta[[columns]])) {
-                    # both existing and new are vector/factor
-                    x@cellMeta[[columns]][cellIdx] <- value
+                if (is.null(dim(value)) && is.null(dim(x@cellMeta[[columns]]))) {
+                    # Both are 1D
+                    if (is.factor(value) && is.factor(x@cellMeta[[columns]])) {
+                        charVar <- as.character(x@cellMeta[[columns]])
+                        charVar[cellIdx] <- as.character(value)
+                        x@cellMeta[[columns]] <-
+                            factor(
+                                charVar,
+                                levels = unique(c(levels(x@cellMeta[[columns]]),
+                                                  levels(value)))
+                            )
+                    } else {
+                        x@cellMeta[[columns]][cellIdx] <- value
+                    }
                 } else if (!is.null(dim(value)) && !is.null(dim(x@cellMeta[[columns]]))) {
-                    # both existing and new are matrix like
+                    # Both are dimensional
+                    if (ncol(value) != ncol(x@cellMeta[[columns]])) {
+                        stop("Cannot insert value to a variable of different ",
+                             "dimensionality")
+                    }
                     x@cellMeta[[columns]][cellIdx,] <- value
                 } else {
-                    # Replace with NA first and then fill
-                    if (is.null(dim(value))) {
-                        # vector/factor
-                        x@cellMeta[[columns]] <- NA
-                        x@cellMeta[[columns]][cellIdx] <- value
-                    } else {
-                        # matrix like
-                        x@cellMeta[[columns]] <- matrix(NA, ncol(x), ncol(value))
-                        x@cellMeta[[columns]][cellIdx,] <- value
-                    }
+                    stop("Cannot insert value to a variable of different ",
+                         "dimensionality")
                 }
             }
         } else {