plot_action() gains a new argument inherit

NEWS.md

@@ -2,6 +2,8 @@
 
 ## features:
 
+* `plot_action()` gains a new argument `inherit` to control the inheritance of `data` argument
+
 * new `ggoncoplot()` function to draw oncoprint
 
 * new `fortity_heatmap()` function to convert any objects for plot with [ggheatmap()]

R/action.R

@@ -7,14 +7,19 @@
 #' through the `action` argument in the `align_*()` functions, or it can be
 #' added directly to a plot.
 #'
-#' @param data A function to transform the plot data before rendering. Defaults
-#' to [`waiver()`][ggplot2::waiver()], which inherits from the parent layout. If
-#' no parent layout is specified, the default is `NULL`, meaning the data won't
-#' be modified. Use this hook to modify the data for all `geoms` after the
-#' layout is created but before rendering by `ggplot2`. The data returned must
-#' be a data frame.
+#' @param data A function to transform the plot data before rendering. Whether
+#' this function is applied after the parent layout's action data depends on
+#' the `inherit` argument. Defaults to [`waiver()`][ggplot2::waiver()], which
+#' directly inherits from the parent layout. If no parent layout is specified,
+#' the default is `NULL`, meaning the data won't be modified.
 #'
-#' @param theme Default plot theme: `r rd_theme()`
+#' Use this hook to modify the data for all `geoms` after the layout is created
+#' but before rendering by `ggplot2`. The returned data must be a data frame.
+#'
+#' @param theme Default plot theme, one of:
+#'   - `NULL`: will inherit from the parent layout directly.
+#'   - [`theme()`][ggplot2::theme]: will be added with the parent layout theme.
+#'     If you want to override the parent layout theme, set `complete=TRUE`.
 #'
 #' **Note:** Axis titles and labels that are parallel to the layout axis will
 #' always be removed by default. For vertical stack layouts, this refers to the
@@ -42,6 +47,11 @@
 #' parent layout, no axis titles will be aligned. If `NULL`, all axis titles
 #' will be aligned.
 #'
+#' @param inherit A single boolean value indicating whether to apply the parent
+#' action `data` first and then apply the specified action `data`. Defaults to
+#' `FALSE` for actions in the layout, `ggpanel()`, and `align_dendro()`, but
+#' `TRUE` for heatmap body and `ggalign()`.
+#'
 #' @return A `plot_action` object.
 #' @examples
 #' # used in the layout, define the default action for all plots in the layout
@@ -62,30 +72,33 @@
 #'
 #' @export
 plot_action <- function(data = NA, theme = NA, guides = NA,
-                        free_spaces = NA, free_labs = NA) {
+                        free_spaces = NA, free_labs = NA,
+                        inherit = NA) {
     if (!identical(data, NA)) data <- check_action_data(data)
     if (!identical(theme, NA)) assert_s3_class(theme, "theme", null_ok = TRUE)
     if (!identical(free_spaces, NA)) assert_layout_position(free_spaces)
     if (!identical(free_labs, NA)) assert_layout_position(free_labs)
     if (!identical(guides, NA)) assert_layout_position(guides)
+    if (!identical(inherit, NA)) assert_bool(inherit)
     structure(
         list(
             data = data,
             theme = theme,
             free_spaces = free_spaces,
             free_labs = free_labs,
-            guides = guides
+            guides = guides,
+            inherit = inherit
         ),
         class = "plot_action"
     )
 }
 
-default_action <- function() {
+default_action <- function(inherit) {
     structure(
         list(
             data = waiver(), theme = NULL,
             free_spaces = waiver(), free_labs = waiver(),
-            guides = waiver()
+            guides = waiver(), inherit = inherit
         ),
         class = "plot_action"
     )
@@ -167,9 +180,24 @@ inherit_theme <- function(theme, parent) {
     parent + theme
 }
 
+inherit_action_data <- function(data, parent, inherit) {
+    if (is.waive(data)) return(parent) # styler: off
+    if (is.null(data)) return(NULL) # styler: off
+    if (is.function(parent) && inherit) {
+        user_data <- data # current action data function
+        data <- function(data) user_data(parent(data))
+    }
+    data
+}
+
 inherit_action <- function(action, parent) {
-    action["data"] <- list(.subset2(action, "data") %|w|%
-        .subset2(parent, "data"))
+    action["data"] <- list(
+        inherit_action_data(
+            .subset2(action, "data"),
+            .subset2(parent, "data"),
+            .subset2(action, "inherit")
+        )
+    )
     action["theme"] <- list(inherit_theme(
         .subset2(action, "theme"),
         .subset2(parent, "theme")

R/align-.R

@@ -69,7 +69,6 @@ align <- function(align_class, params,
     if (align_override_call(call)) {
         call <- current_call()
     }
-    action <- check_action(action, call = call)
 
     # check arguments ---------------------------------------------
     data <- allow_lambda(data)
@@ -86,12 +85,6 @@ align <- function(align_class, params,
         empty_ok = FALSE, na_ok = TRUE,
         null_ok = TRUE, call = call
     )
-    action <- deprecate_action(
-        action, snake_class(align_class), plot_data, theme,
-        free_spaces, free_labs,
-        free_guides = free_guides,
-        call = call
-    )
 
     # Warn about extra params or missing parameters ---------------
     all <- align_class$parameters()

R/align-dendrogram.R

@@ -96,6 +96,13 @@ align_dendro <- function(mapping = aes(), ...,
             "{.arg reorder_dendrogram} must be a single boolean value or a function"
         )
     }
+    action <- check_action(action, FALSE)
+    action <- deprecate_action(
+        action, "align_dendro",
+        plot_data, theme,
+        free_spaces, free_labs,
+        free_guides = free_guides
+    )
     assert_bool(merge_dendrogram)
     assert_bool(reorder_group)
     cutree <- allow_lambda(cutree)

R/align-gg.R

@@ -57,6 +57,13 @@ align_gg <- function(mapping = aes(), size = NULL, action = NULL,
                      plot_data = deprecated(), theme = deprecated(),
                      free_labs = deprecated()) {
     assert_mapping(mapping)
+    action <- check_action(action, TRUE)
+    action <- deprecate_action(
+        action, "align_gg",
+        plot_data, theme,
+        free_spaces, free_labs,
+        free_guides = free_guides
+    )
     align(AlignGG,
         params = list(mapping = mapping),
         size = size, data = data %||% waiver(), action = action,

R/align-panel.R

@@ -40,6 +40,13 @@ align_panel <- function(mapping = aes(), size = NULL, action = NULL,
                         plot_data = deprecated(), theme = deprecated(),
                         free_labs = deprecated()) {
     assert_mapping(mapping)
+    action <- check_action(action, FALSE)
+    action <- deprecate_action(
+        action, "align_panel",
+        plot_data, theme,
+        free_spaces, free_labs,
+        free_guides = free_guides
+    )
     align(AlignPanel,
         params = list(mapping = mapping),
         size = size, action = action, data = NULL, free_guides = free_guides,

R/layout-heatmap-.R

@@ -146,7 +146,7 @@ heatmap_layout.default <- function(data, ...) {
                             nobs_list, call = caller_call()) {
     width <- check_size(.width, call = call)
     height <- check_size(.height, call = call)
-    action <- check_action(action, call = call)
+    action <- check_action(action, FALSE, call = call)
     if (!is.null(theme)) assert_s3_class(theme, "theme", call = call)
     assert_bool(filling, call = call)
     assert_bool(set_context, call = call)
@@ -183,7 +183,7 @@ heatmap_layout.default <- function(data, ...) {
         "HeatmapLayout",
         data = data,
         theme = theme, action = action, # used by the layout
-        body_action = default_action(), # used by heatmap body
+        body_action = default_action(TRUE), # used by heatmap body
         # following parameters can be controlled by `active` object.
         width = width, height = height,
         # following parameters used when adding ggheamtap to ggstack

R/layout-heatmap-oncoplot.R

@@ -76,7 +76,7 @@ ggoncoplot.functon <- ggoncoplot.NULL
 #' @export
 ggoncoplot.formula <- ggoncoplot.functon
 
-#' @importFrom vctrs vec_slice
+#' @importFrom vctrs vec_slice list_sizes vec_rep_each
 #' @importFrom ggplot2 aes
 #' @export
 ggoncoplot.default <- function(data, mapping = aes(), ...,
@@ -147,20 +147,10 @@ ggoncoplot.default <- function(data, mapping = aes(), ...,
             hmanno("t") +
             align_order(order(column_scores, decreasing = TRUE))
     }
-    ans +
-        hmanno(NULL,
-            action = plot_action(data = function(data) {
-                separate_longer_alt(data)
-            })
-        ) +
-        # we always set the default plot action data for the heatmap body
-        plot_action(data = function(data) separate_longer_alt(data))
-}
-
-#' @importFrom vctrs list_sizes vec_rep_each
-separate_longer_alt <- function(data, delim = "[;:,|]") {
-    value_list <- strsplit(data$value, split = delim)
-    data <- vec_rep_each(data, list_sizes(value_list))
-    data$value <- unlist(value_list, recursive = FALSE, use.names = FALSE)
-    data
+    ans + hmanno(NULL, action = plot_action(data = function(data) {
+        value_list <- strsplit(data$value, split = "[;:,|]")
+        data <- vec_rep_each(data, list_sizes(value_list))
+        data$value <- unlist(value_list, recursive = FALSE, use.names = FALSE)
+        data
+    }))
 }

R/layout-stack-.R

@@ -94,7 +94,7 @@ stack_layout.NULL <- function(data, ...) {
                           nobs, call = caller_call()) {
     direction <- match.arg(direction, c("horizontal", "vertical"))
     sizes <- check_stack_sizes(sizes, call = call)
-    action <- check_action(action, call = call)
+    action <- check_action(action, FALSE, call = call)
     methods::new("StackLayout",
         data = data,
         direction = direction,

R/utils-assert.R

@@ -172,11 +172,13 @@ assert_action <- function(x, arg = caller_arg(x), call = caller_call()) {
     }
 }
 
-check_action <- function(x, arg = caller_arg(x), call = caller_call()) {
+check_action <- function(x, inherit,
+                         arg = caller_arg(x), call = caller_call()) {
+    ans <- default_action(inherit)
     if (is.null(x)) {
-        default_action()
+        ans
     } else {
         assert_action(x, arg = arg, call = call)
-        update_action(default_action(), x)
+        update_action(ans, x)
     }
 }

R/utils-rd.R

@@ -6,15 +6,6 @@ rd_values <- function(x, quote = TRUE, code = TRUE, sep = ", ", final = "and") {
 
 rd_layout <- function() "[heatmap_layout()] or [stack_layout()] object"
 
-rd_theme <- function() {
-    paste(
-        "One of:",
-        "- `NULL`: will inherit from the parent layout directly.",
-        "- [`theme()`][ggplot2::theme]: will be added with the parent layout theme.",
-        sep = "\n"
-    )
-}
-
 rd_stack_what <- function() {
     paste(
         "Options include::",

vignettes/layout-plot.Rmd

@@ -65,6 +65,7 @@ action argument `data` in the `align_gg()`/`ggalign()` function. This allows you
 to transform the default data for all subsequent geoms. 
 
 ```{r}
+set.seed(1234L)
 ggheatmap(small_mat) +
     scale_fill_viridis_c(guide = "none") +
     hmanno("t") +
@@ -73,6 +74,50 @@ ggheatmap(small_mat) +
     geom_bar(aes(y = value, fill = .row_names), stat = "identity")
 ```
 
+If the action data function has been set in both the single plot and the parent
+layout, Whether the action data function is applied after the parent layout's
+action data depends on the `inherit` argument in `plot_action()`. By default,
+only heatmap body and `ggalign()` will inherit the parent action data function.
+
+The following plot will result in an empty plot area since no data remains after
+filtering: 
+```{r}
+set.seed(1234L)
+ggheatmap(small_mat) +
+    scale_fill_viridis_c(guide = "none") +
+    hmanno("t",
+        action = plot_action(data = function(data) subset(data, .panel == 1L))
+    ) +
+    align_kmeans(3L) +
+    # this action data function will be applied after the layout action data
+    # function, so there is no panel in `2`
+    ggalign(action = plot_action(data = function(data) subset(data, .panel == 2L))) +
+    geom_bar(aes(y = value, fill = .row_names), stat = "identity")
+```
+
+To resolve this issue, you can set `inherit = FALSE`:
+```{r}
+set.seed(1234L)
+ggheatmap(small_mat) +
+    scale_fill_viridis_c(guide = "none") +
+    hmanno("t",
+        action = plot_action(data = function(data) subset(data, .panel == 1L))
+    ) +
+    align_kmeans(3L) +
+    # this action data function will be applied after the layout action data
+    # function
+    ggalign(
+        action = plot_action(
+            data = function(data) subset(data, .panel == 2L),
+            inherit = FALSE
+        )
+    ) +
+    geom_bar(aes(y = value, fill = .row_names), stat = "identity")
+```
+
+This functionality is particularly useful for `ggoncoplot()`, as it relies on
+action data to prepare the data internally.
+
 ### Cross panel sumamry
 When used in a heatmap layout, and the data is inherited from the heatmap data,
 a special column `.extra_panel` will be added, which is the panel information