Add renameMetaPrograms function for renaming MPs in GeneNMF results

R/main.R

@@ -737,3 +737,83 @@ dropMetaPrograms <- function(mp.res,
   mp.res$programs.tree$call <- tree$call
   return(mp.res)
 }  
+
+#' Rename meta-programs
+#'
+#' Rename meta-programs in the GeneNMF results. This can be useful
+#' to assign more meaningful names to the meta-programs. Or to
+#' rename them after filtering or dropping some of the MPs.
+#'
+#' @param mp.res The meta-programs object generated by \code{\link{getMetaPrograms}}
+#' @param old.names A vector with the current names of the MPs
+#' @param new.names A vector with the new names of the MPs, align to the order of old.names
+#' @return The renamed meta-program object, with MPs ordered according to the order of new.names
+#'
+#' @examples
+#' library(Seurat)
+#' data(sampleObj)
+#' geneNMF_programs <- multiNMF(list(sampleObj), k = 5)
+#' geneNMF_metaprograms <- getMetaPrograms(geneNMF_programs, nMP = 5)
+#' geneNMF_metaprograms_filtered <- dropMetaPrograms(geneNMF_metaprograms, dropMP = c("MP2"))
+#' geneNMF_metaprograms_renamed <- renameMetaPrograms(geneNMF_metaprograms_filtered,
+#'  old.names = c("MP1", "MP3", "MP4", "MP5"),
+#'  new.names = c("MP1", "MP2", "MP3", "MP4")
+#' )
+#'
+#' @importFrom dendextend prune
+#' @importFrom stats as.hclust as.dendrogram
+#' @export
+renameMetaPrograms <- function(mp.res, old.names = NULL, new.names = NULL) {
+  if (is.null(old.names)) {
+    old.names <- names(mp.res$metaprograms.genes)
+  } else if (!identical(sort(old.names), sort(names(mp.res$metaprograms.genes)))) {
+    stop("old.names must match the names of metaprograms.genes in mp.res.")
+  }
+
+  if (is.null(new.names)) {
+    new.names <- paste0("MP", seq_along(old.names))
+  } else if (length(old.names) != length(new.names)) {
+    stop("old.names and new.names must have the same length.")
+  }
+
+  markers.genes <- mp.res$metaprograms.genes
+  markers.consensus <- mp.res$metaprograms.genes.weights
+  metaprograms.metrics <- mp.res$metaprograms.metrics
+  metaprograms.composition <- mp.res$metaprograms.composition
+  J <- mp.res$programs.similarity
+  tree <- mp.res$programs.tree
+  cl_members <- mp.res$programs.clusters
+
+  ord <- match(old.names, names(markers.genes))
+
+  markers.consensus <- markers.consensus[ord]
+  names(markers.consensus) <- new.names
+
+  # Reorder metrics and composition tables
+  metaprograms.metrics <- metaprograms.metrics[ord, , drop = F]
+  rownames(metaprograms.metrics) <- new.names
+  metaprograms.composition <- metaprograms.composition[ord, , drop = F]
+  rownames(metaprograms.composition) <- new.names
+
+  map.index <- seq_along(old.names)
+  names(map.index) <- as.numeric(gsub("MP", "", old.names))
+  cl_members.new <- map.index[as.character(cl_members)]
+
+  names(cl_members.new) <- names(cl_members)
+
+  # weights of individual genes in each MP
+  markers.consensus <- lapply(markers.consensus, function(m) {
+    m / sum(m)
+  })
+  markers.genes <- lapply(markers.consensus, names)
+
+  output.object <- list()
+  output.object[["metaprograms.genes"]] <- markers.genes
+  output.object[["metaprograms.genes.weights"]] <- markers.consensus
+  output.object[["metaprograms.metrics"]] <- metaprograms.metrics
+  output.object[["metaprograms.composition"]] <- metaprograms.composition
+  output.object[["programs.similarity"]] <- J
+  output.object[["programs.tree"]] <- tree
+  output.object[["programs.clusters"]] <- cl_members.new
+  return(output.object)
+}