add htanno_title

DESCRIPTION

@@ -35,6 +35,7 @@ Collate:
     'htanno-group.R'
     'htanno-kmeans.R'
     'htanno-reorder.R'
+    'htanno-title.R'
     'import-standalone-assert.R'
     'import-standalone-cli.R'
     'import-standalone-obj-type.R'

NAMESPACE

@@ -75,6 +75,7 @@ export(htanno_gg)
 export(htanno_group)
 export(htanno_kmeans)
 export(htanno_reorder)
+export(htanno_title)
 export(is.ggheatmap)
 export(unit)
 exportMethods("&")

R/ggheat.R

@@ -81,6 +81,7 @@ ggheat.matrix <- function(data, mapping = NULL,
         theme(
             plot.background = element_blank(),
             panel.border = element_blank(),
+            strip.text = element_blank(),
             strip.background = element_blank()
         )
     if (ncol(data) > 10L) {

R/htanno-dendrogram.R

@@ -179,7 +179,7 @@ HtannoDendro <- ggplot2::ggproto("HtannoDendro", HtannoProto,
         if (!is.null(panels)) panels <- factor(panels, unique(panels[index]))
         list(panels, index)
     },
-    ggplot = function(self, panels, index, mapping, segment_params) {
+    ggplot = function(self, mapping, segment_params) {
         ans <- ggplot2::ggplot(mapping = mapping) +
             rlang::inject(ggplot2::geom_segment(
                 mapping = aes(

R/htanno-gg.R

@@ -44,7 +44,7 @@ gganno_left <- function(...) htanno_gg(position = "left", ...)
 gganno_right <- function(...) htanno_gg(position = "right", ...)
 
 HtannoGG <- ggplot2::ggproto("HtannoGG", HtannoProto,
-    ggplot = function(self, panels, index, mapping) {
+    ggplot = function(self, mapping) {
         ans <- ggplot2::ggplot(mapping = mapping) +
             ggplot2::theme_bw()
 

R/htanno-title.R

@@ -0,0 +1,81 @@
+#' Draw Heatmap rows/columns titles
+#' @param titles A character of titles, must be of length with the same number
+#' of heatmap rows/columns panels.
+#' @param ... Additional arguments passed to [geom_text][ggplot2::geom_text].
+#' @inheritParams ggplot2::ggplot
+#' @inheritParams htanno
+#' @inherit htanno return
+#' @examples
+#' small_mat <- matrix(rnorm(81), nrow = 9)
+#' ggheat(small_mat) +
+#'     htanno_group(
+#'         sample(letters[1:4], ncol(small_mat), replace = TRUE),
+#'         position = "top"
+#'     ) +
+#'     htanno_title()
+#' @export
+htanno_title <- function(titles = NULL, ..., mapping = aes(),
+                         size = unit(1, "cm"),
+                         set_context = TRUE, order = NULL, name = NULL,
+                         position = NULL) {
+    assert_mapping(mapping)
+    htanno(HtannoTitle,
+        params = list(
+            mapping = mapping, titles = titles,
+            text_params = rlang::list2(...)
+        ),
+        labels = NULL, labels_nudge = NULL,
+        position = position, size = size, data = NULL,
+        set_context = set_context,
+        order = order, name = name
+    )
+}
+
+HtannoTitle <- ggplot2::ggproto("HtannoTitle", HtannoProto,
+    ggplot = function(self, mapping, text_params) {
+        ans <- ggplot2::ggplot(mapping = mapping) +
+            rlang::inject(ggplot2::geom_text(!!!text_params)) +
+            ggplot2::theme_void()
+        add_default_mapping(ans, switch_position(
+            .subset2(self, "position"),
+            aes(x = 0L, y = .data$.y, label = .data$.label),
+            aes(y = 0L, x = .data$.x, label = .data$.label)
+        ))
+    },
+    draw = function(self, panels, index, titles) {
+        position <- .subset2(self, "position")
+        axis <- to_coord_axis(position)
+        coords <- data_frame0(.panel = panels[index], .index = index)
+        coords[[paste0(".", axis)]] <- seq_along(index)
+        formula <- rlang::new_formula(
+            rlang::sym(paste0(".", axis)),
+            quote(.panel)
+        )
+        plot <- .subset2(self, "plot")
+        data <- stats::aggregate(formula, data = coords, median)
+        if (is.null(titles)) {
+            titles <- as.character(data$.panel)
+        } else if (length(titles) != nlevels(panels)) {
+            cli::cli_abort(
+                sprintf(
+                    "{.arg titles} must be of length of %s %s %s (%d)",
+                    "the same number with heatmap",
+                    to_matrix_axis(position), "panels", nlevels(panels)
+                ),
+                call = .subset2(self, "call")
+            )
+        } else if (!is.atomic(titles)) {
+            cli::cli_abort(
+                "{.arg titles} must be an atomic vector",
+                call = .subset2(self, "call")
+            )
+        } else if (rlang::is_named(titles)) {
+            titles <- titles[as.character(data$.panel)]
+        } else {
+            titles <- as.character(titles)
+        }
+        data$.label <- titles
+        plot$data <- data
+        plot
+    }
+)

R/initialize-htanno.R

@@ -169,9 +169,7 @@ initialize_htanno_layout <- function(object, heatmap, object_name) {
     ggplot_params <- params[
         intersect(names(params), htanno_method_params(object$ggplot))
     ]
-    p <- rlang::inject(
-        object$ggplot(new_panels, new_index, !!!ggplot_params)
-    )
+    p <- rlang::inject(object$ggplot(!!!ggplot_params))
     # set the default theme for all annotation
     if (ggplot2::is.ggplot(p)) {
         p <- p + theme(