Enable customized categorical color setting on heatmap; export marker…

… heatmap

NAMESPACE

@@ -121,6 +121,7 @@ export(plotGeneHeatmap)
 export(plotGeneLoadingRank)
 export(plotGeneLoadings)
 export(plotGeneViolin)
+export(plotMarkerHeatmap)
 export(plotPeakDimRed)
 export(plotProportion)
 export(plotProportionBar)

R/DEG_marker.R

@@ -434,3 +434,88 @@ computePval <- function(ustat, ties, N, n1n2) {
     pvals <- matrix(2 * stats::pnorm(-abs(as.numeric(z))), ncol = ncol(z))
     return(pvals)
 }
+
+
+
+
+
+######################## Visualization #########################################
+
+#' Create heatmap for showing top marker expression in conditions
+#' @export
+#' @param object A \linkS4class{liger} object, with normalized data and metadata
+#' to annotate available.
+#' @param result The data.frame returned by \code{\link{runMarkerDEG}}.
+#' @param topN Number of top features to be plot for each group. Default
+#' \code{5}.
+#' @param lfcThresh Hard threshold on logFC value. Default \code{1}.
+#' @param padjThresh Hard threshold on adjusted P-value. Default \code{0.05}.
+#' @param pctInThresh,pctOutThresh Threshold on expression percentage. These
+#' mean that a feature will only pass the filter if it is expressed in more than
+#' \code{pctInThresh} percent of cells in the corresponding cluster. Similarly
+#' for \code{pctOutThresh}. Default \code{50} and \code{50}, respectively.
+#' @param dedupBy When ranking by padj and logFC and a feature is ranked as top
+#' for multiple clusters, assign this feature as the marker of a cluster when
+#' it has the largest \code{"logFC"} in the cluster or has the lowest
+#' \code{"padj"}. Default \code{"logFC"}.
+#' @param groupBy Cell metadata variable names for cell grouping. Downsample
+#' balancing will also be aware of this. Default \code{c("dataset",
+#' "leiden_cluster")}.
+#' @param groupSize Maximum number of cells in each group to be downsampled for
+#' plotting. Default \code{50}.
+#' @param column_title Title on the column. Default \code{NULL}.
+#' @param ... Parameter passed to wrapped functions in the inheritance order:
+#' \code{\link{plotGeneHeatmap}}, \code{\link{.plotHeatmap}},
+#' \code{ComplexHeatmap::\link[ComplexHeatmap]{Heatmap}}
+#' @examples
+#' markerTable <- runMarkerDEG(pbmcPlot)
+#' plotMarkerHeatmap(pbmcPlot, markerTable)
+plotMarkerHeatmap <- function(
+        object,
+        result,
+        topN = 5,
+        lfcThresh = 1,
+        padjThresh = 0.05,
+        pctInThresh = 50,
+        pctOutThresh = 50,
+        dedupBy = c("logFC", "padj"),
+        groupBy = c("dataset", "leiden_cluster"),
+        groupSize = 50,
+        column_title = NULL,
+        ...
+) {
+    dedupBy <- match.arg(dedupBy)
+    if (dedupBy == "logFC") {
+        result <- result[order(result[[dedupBy]], decreasing = TRUE), ]
+    } else if (dedupBy == "padj") {
+        result <- result[order(result[[dedupBy]], decreasing = FALSE), ]
+    }
+    result <- result[!duplicated(result$feature), ]
+    result <- result %>% dplyr::filter(.data$logFC > lfcThresh,
+                                       .data$padj < padjThresh,
+                                       .data$pct_in > pctInThresh,
+                                       .data$pct_out < pctOutThresh) %>%
+        dplyr::group_by(.data[["group"]]) %>%
+        dplyr::arrange(.data[["padj"]], -.data[["logFC"]], .by_group = TRUE) %>%
+        dplyr::filter(dplyr::row_number() %in% seq(topN)) %>%
+        as.data.frame()
+    cellIdx <- downsample(object, maxCells = groupSize, balance = groupBy,
+                          returnIndex = TRUE)
+    featureAnn <- result[, "group", drop = FALSE]
+
+    rownames(featureAnn) <- result$feature
+    colnames(featureAnn) <- "marker"
+    plotGeneHeatmap(object, features = result$feature,
+                    cellIdx = cellIdx,
+                    useCellMeta = groupBy,
+                    featureAnnotation = featureAnn,
+                    cellSplitBy = rev(groupBy),
+                    featureSplitBy = "marker",
+                    showFeatureLegend = FALSE,
+                    cluster_columns = FALSE,
+                    cluster_column_slices = FALSE,
+                    cluster_rows = FALSE,
+                    cluster_row_slices = FALSE,
+                    column_title = column_title,
+                    ...)
+}

R/heatmap.R

@@ -159,6 +159,11 @@ plotFactorHeatmap <- function(
 #' @param showCellLegend,showFeatureLegend Logical, whether to show cell or
 #' feature legends. Default \code{TRUE}. Can be a scalar for overall control
 #' or a vector matching with each given annotation variable.
+#' @param cellAnnColList,featureAnnColList List object, with each element a
+#' named vector of R-interpretable color code. The names of the list elements
+#' are used for matching the annotation variable names. The names of the colors
+#' in the vectors are used for matching the levels of a variable (factor object,
+#' categorical). Default \code{NULL} generates ggplot-flavor categorical colors.
 #' @param scale Logical, whether to take z-score to scale and center gene
 #' expression. Applied after \code{dataScaleFunc}. Default \code{FALSE}.
 #' @param trim Numeric vector of two values. Limit the z-score value into this
@@ -192,6 +197,8 @@ plotFactorHeatmap <- function(
         showCellLegend = TRUE,
         showFeatureLabel = TRUE,
         showFeatureLegend = TRUE,
+        cellAnnColList = NULL,
+        featureAnnColList = NULL,
         scale = FALSE,
         trim = c(-2, 2),
         baseSize = 8,
@@ -257,11 +264,13 @@ plotFactorHeatmap <- function(
     cellHA <- .constructHA(cellDF, legendTitleSize = legendTitle,
                            legendTextSize = legendText,
                            which = ifelse(transpose, "row", "column"),
-                           showLegend = showCellLegend)
+                           showLegend = showCellLegend,
+                           colList = cellAnnColList)
     featureHA <- .constructHA(featureDF, legendTitleSize = legendTitle,
                               legendTextSize = legendText,
                               which = ifelse(transpose, "column", "row"),
-                              showLegend = showFeatureLegend)
+                              showLegend = showFeatureLegend,
+                              colList = featureAnnColList)
 
     if (!isTRUE(transpose)) {
         hm <- ComplexHeatmap::Heatmap(
@@ -343,23 +352,23 @@ plotFactorHeatmap <- function(
     if (inherits(annDF, c("data.frame", "DFrame"))) {
         notFound <- !(charIdx %in% rownames(annDF))
         if (any(notFound))
-            warning(sum(notFound), " cells selected could not be found in ",
-                    "given cell annotation.")
+            warning(sum(notFound), " selected could not be found in ",
+                    "given annotation.")
         # Convert to data.frame first so missing value can be filled with NA
         if (!is.data.frame(annDF))
             annDF <- as.data.frame(annDF)
         annDF <- annDF[charIdx, , drop = FALSE]
         if (is.null(AnnDF)) AnnDF <- annDF
         else AnnDF <- cbind(AnnDF, annDF)
     } else if (!is.null(annDF)) {
-        warning("`cellAnnotation` of class ", class(annDF),
+        warning("Annotation of class ", class(annDF),
                 " is not supported yet.")
     }
 
     if (!is.null(splitBy)) {
         notFound <- !splitBy %in% colnames(AnnDF)
         if (any(notFound))
-            warning("Variables in `cellSplitBy` not detected in specified ",
+            warning("Variables in `cell/featureSplitBy` not detected in specified ",
                     "annotation: ",
                     paste(splitBy[notFound], collapse = ", "))
         splitBy <- splitBy[!notFound]
@@ -372,17 +381,28 @@ plotFactorHeatmap <- function(
 
 # HA - HeatmapAnnotation()
 .constructHA <- function(df, legendTitleSize, legendTextSize,
-                         which = c("row", "column"), showLegend = TRUE) {
+                         which = c("row", "column"), showLegend = TRUE,
+                         colList = NULL) {
     which <- match.arg(which)
     if (!is.null(df) && ncol(df) > 0) {
         annCol <- list()
         for (var in colnames(df)) {
             if (is.factor(df[[var]])) {
-                # Still generate all colors for all classes in var
-                # So it matches up with other visualization
-                annCol[[var]] <- scales::hue_pal()(length(levels(df[[var]])))
-                names(annCol[[var]]) <- levels(df[[var]])
-                df[[var]] <- droplevels(df[[var]])
+                if (var %in% names(colList)) {
+                    df[[var]] <- droplevels(df[[var]])
+                    if (any(!levels(df[[var]]) %in% names(colList[[var]]))) {
+                        stop("Given customized annotation color must have ",
+                             "names matching to all available levels in the ",
+                             "annotation.")
+                    }
+                    annCol[[var]] <- colList[[var]][levels(df[[var]])]
+                } else {
+                    # Automatic generate with ggplot2 strategy,
+                    # with level awareness
+                    annCol[[var]] <- scales::hue_pal()(length(levels(df[[var]])))
+                    names(annCol[[var]]) <- levels(df[[var]])
+                    df[[var]] <- droplevels(df[[var]])
+                }
             }
         }
         ha <- ComplexHeatmap::HeatmapAnnotation(

R/wilcoxon.R

@@ -392,64 +392,3 @@ calcDatasetSpecificity <- function(
                    pctSpec = 100 * (1 - (pct1 / pct2)))
     return(result)
 }
-
-############################# For fast Wilcoxon test ###########################
-# helper function for wilcoxon tests on general variables like matrix and
-# dgCMatrix
-
-
-################################################################################
-# Visualization ####
-################################################################################
-
-plotMarkerHeatmap <- function(
-        object,
-        result,
-        topN = 5,
-        lfcThresh = 1,
-        padjThresh = 0.01,
-        pctInThresh = 50,
-        pctOutThresh = 50,
-        dedupBy = c("padj", "logFC"),
-        groupBy = c("dataset", "leiden_cluster"),
-        groupSize = 50,
-        column_title = NULL,
-        ...
-) {
-    dedupBy <- match.arg(dedupBy)
-    if (dedupBy == "logFC") {
-        result <- result[order(result[[dedupBy]], decreasing = TRUE), ]
-    } else if (dedupBy == "padj") {
-        result <- result[order(result[[dedupBy]], decreasing = FALSE), ]
-    }
-    result <- result[-duplicated(result$feature), ]
-    # TODO
-    result <- result %>% dplyr::filter(.data$logFC > lfcThresh,
-                                       .data$padj < padjThresh,
-                                       .data$pct_in > pctInThresh,
-                                       .data$pct_out < pctOutThresh) %>%
-        dplyr::group_by(.data[["group"]]) %>%
-        # dplyr::top_n(-topN, .data[["padj"]]) %>%
-        dplyr::top_n(topN, .data[["logFC"]]) %>%
-        dplyr::arrange(.data[["group"]]) %>%
-        as.data.frame()
-
-    object <- downsample(object, maxCells = groupSize,
-                         balance = groupBy,
-                         useSlot = "normData")
-    featureAnn <- result[, "group", drop = FALSE]
-    rownames(featureAnn) <- result$feature
-    plotGeneHeatmap(object, features = result$feature,
-                    useCellMeta = groupBy,
-                    featureAnnotation = featureAnn,
-                    cellSplitBy = rev(groupBy),
-                    featureSplitBy = "group",
-                    showFeatureLegend = FALSE,
-                    cluster_columns = FALSE,
-                    cluster_column_slices = FALSE,
-                    cluster_rows = FALSE,
-                    cluster_row_slices = FALSE,
-                    column_title = column_title,
-                    ...)
-}
-