From aa7a967fec9533ed9543fd1a76a220fc3b9ac8a0 Mon Sep 17 00:00:00 2001 From: yun Date: Thu, 20 Jun 2024 18:56:11 +0800 Subject: [PATCH] remove the gganno2 --- DESCRIPTION | 2 +- NAMESPACE | 4 +- R/anno-.R | 59 ++++++++- R/anno-fn.R | 118 ----------------- R/anno-subsettable-.R | 154 +++++++++++++++++++++ R/gganno.R | 162 ++++++++++++++--------- R/prepare.R | 108 +++++++-------- R/utils-complexheatmap.R | 20 --- R/utils.R | 8 +- README.html | 62 +++------ README.md | 42 ++---- man/draw-ggAnnotationFunction-method.Rd | 13 +- man/figures/README-Heatmap_gganno-1.png | Bin 0 -> 28342 bytes man/figures/README-Heatmap_gganno2-1.png | Bin 28833 -> 0 bytes man/figures/README-ggheat_gganno2-1.png | Bin 25442 -> 0 bytes man/figures/README-unnamed-chunk-5-1.png | Bin 43252 -> 0 bytes man/gganno.Rd | 20 --- man/new_anno.Rd | 87 ++++++++++++ man/new_anno_subset.Rd | 82 ++++++++++++ vignettes/eheat.Rmd | 35 ++--- 20 files changed, 573 insertions(+), 403 deletions(-) delete mode 100644 R/anno-fn.R create mode 100644 R/anno-subsettable-.R create mode 100644 man/figures/README-Heatmap_gganno-1.png delete mode 100644 man/figures/README-Heatmap_gganno2-1.png delete mode 100644 man/figures/README-ggheat_gganno2-1.png delete mode 100644 man/figures/README-unnamed-chunk-5-1.png create mode 100644 man/new_anno.Rd create mode 100644 man/new_anno_subset.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 01c47d8..1eeffb8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -27,7 +27,7 @@ Suggests: rmarkdown Collate: 'anno-.R' - 'anno-fn.R' + 'anno-subsettable-.R' 'eheat-package.R' 'ggheat.R' 'gganno.R' diff --git a/NAMESPACE b/NAMESPACE index 17590f7..7930298 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,10 +2,11 @@ export(draw) export(gganno) -export(gganno2) export(ggheat) export(gpar) export(ht_opt) +export(new_anno) +export(new_anno_subset) export(unit) exportClasses(ggAnnotationFunction) exportClasses(ggHeatmap) @@ -15,6 +16,7 @@ importClassesFrom(ComplexHeatmap,AnnotationFunction) importClassesFrom(ComplexHeatmap,Heatmap) importFrom(ComplexHeatmap,draw) importFrom(ComplexHeatmap,ht_opt) +importFrom(ComplexHeatmap,make_layout) importFrom(ComplexHeatmap,prepare) importFrom(ggplot2,aes) importFrom(ggplot2,ggplot) diff --git a/R/anno-.R b/R/anno-.R index 5b8cba4..abf0ad4 100644 --- a/R/anno-.R +++ b/R/anno-.R @@ -1,13 +1,65 @@ +#' @inherit ComplexHeatmap::AnnotationFunction +#' @param draw_fn A function which defines how to draw the annotation. See +#' [ComplexHeatmap +#' Manual](https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#implement-new-annotation-functions) +#' for details. +#' +#' The function should have three arguments: `index`, `k` and `n` (the names of +#' the arguments can be arbitrary) where `k` and `n` are optional. `index` +#' corresponds to the indices of rows or columns of the heatmap. The value of +#' `index` is not necessarily to be the whole row indices or column indices in +#' the heatmap. It can also be a subset of the indices if the annotation is +#' split into slices according to the split of the heatmap. `index` is +#' reordered according to the reordering of heatmap rows or columns (e.g. by +#' clustering). So, `index` actually contains a list of row or column indices +#' for the current slice after row or column reordering. +#' +#' k corresponds to the current slice and n corresponds to the total number of +#' slices. +#' +#' @param ylim Ranges of data value on the data axis. +#' @param name Name of the annotation, only used for message. +#' @details +#' `new_anno` is similar with +#' [AnnotationFunction][ComplexHeatmap::AnnotationFunction], but `new_anno` +#' won't change the function environment of `draw_fn`. So it's safe to use +#' `new_anno` in pacakge development, particularly when dealing with internal +#' functions in the package namespace that are likely to exist. `@@subsettable` +#' will always be set to `FALSE`. +#' @examples +#' x <- 1:10 +#' anno1 <- new_anno( +#' n = 10, +#' draw_fn = function(index, k, n) { +#' n <- length(index) +#' pushViewport(viewport(xscale = c(0.5, n + 0.5), yscale = c(0, 10))) +#' grid.rect() +#' grid.points(1:n, x[index], default.units = "native") +#' if (k == 1) grid.yaxis() +#' popViewport() +#' }, +#' height = unit(2, "cm") +#' ) +#' m <- rbind(1:10, 11:20) +#' ggheat(m, top_annotation = HeatmapAnnotation(foo = anno1)) +#' ggheat(m, top_annotation = HeatmapAnnotation(foo = anno1), column_km = 2) +#' @seealso +#' - [new_anno_subset] +#' - [AnnotationFunction][ComplexHeatmap::AnnotationFunction] +#' @export new_anno <- function(n, draw_fn, ylim = NULL, - subset_rule = list(), subsettable = TRUE, width = NULL, height = NULL, show_name = TRUE, which = NULL, name = NULL) { # ComplexHeatmap::AnnotationFunction() will change the function # environment of `anno@fun` # here: we use new_anno instead, in this way, the function in the # package namespace can be used directly + assert_string(name, null_ok = TRUE) + name <- name %||% "" if (ht_opt$verbose) { - cli::cli_inform("construct AnnotationFunction with {.fn {name}}") + msg <- "construct AnnotationFunction" + if (name == "") msg <- paste(msg, "with {.fn {name}}") + cli::cli_inform(msg) } anno <- methods::new("AnnotationFunction") which <- cheat_which(which) @@ -21,8 +73,7 @@ new_anno <- function(n, draw_fn, ylim = NULL, anno@data_scale <- ylim %||% c(0L, 1L) anno@fun <- draw_fn anno@var_env <- new.env(parent = environment(draw_fn)) - anno@subsettable <- subsettable - anno@subset_rule <- subset_rule + anno@subsettable <- FALSE anno } diff --git a/R/anno-fn.R b/R/anno-fn.R deleted file mode 100644 index 4e67fec..0000000 --- a/R/anno-fn.R +++ /dev/null @@ -1,118 +0,0 @@ -anno_fn <- function( - matrix, draw_fn, ..., yscale = NULL, - subset_rule = NULL, subsettable = NULL, - width = NULL, height = NULL, show_name = TRUE, - which = NULL, name = NULL, heat_matrix = NULL) { - assert_s3_class(yscale, "Scale", null_ok = TRUE) - matrix <- anno_check_matrix(allow_lambda(matrix), which, heat_matrix) - ylim <- scale_get_limits(matrix, yscale) - draw_fn <- allow_lambda(draw_fn) - if (...length() != sum(nzchar(...names()))) { - cli::cli_abort("All elements in {.arg ...} must be named.") - } - name <- name %||% "anno_fn" - subsettable <- subsettable %||% TRUE - dots <- rlang::list2(...) - if (isTRUE(subsettable)) { - internal_subset <- list( - matrix = function(x, i) x[i, , drop = FALSE] - ) - if (...length() && is.null(subset_rule)) { - subset_rule <- lapply(dots, function(var) { - if (is.matrix(var)) { - function(x, i) { - x[i, , drop = FALSE] - } - } else if (inherits(var, "gpar")) { - subset_gp - } else if (is.vector(var)) { - if (length(var) > 1) { - function(x, i) { - x[i] - } - } - } - }) - } - if (!is.null(subset_rule)) { - rules <- subset_rule - rules_nms <- names(rules) - subset_rule <- list(dots = function(x, i) { - imap(x, function(element, nm) { - if (any(nm == rules_nms)) { - rule <- rules[[nm]] - if (is.null(rule) || isFALSE(rule)) { - element - } else { - rule(element, i) - } - } else { - element - } - }) - }) - subset_rule <- c(internal_subset, subset_rule) - } - } - # var_import <- list( - # matrix = matrix, dots = dots, - # which = which, ylim = ylim - # ) - new_anno( - n = nrow(matrix), - draw_fn = function(index, k, n) { - vp <- flip_viewport(which, - xscale = c(0.5, n + 0.5), - yscale = ylim - ) - matrix <- matrix[index, , drop = FALSE] - rlang::inject(draw_fn(matrix, !!!dots, which = which, vp = vp)) - }, - ylim = ylim, - subset_rule = subset_rule, subsettable = subsettable, - which = which, width = width, height = height, - show_name = show_name, name = name - ) -} - -anno_check_matrix <- function(matrix, which, heat_matrix, name) { - if (is.null(matrix) && is.null(heat_matrix)) { - cli::cli_abort("{.arg matrix} must be provided") - } else if (is.null(matrix)) { - matrix <- heat_matrix - } else { - if (is.function(matrix)) { - matrix <- matrix(heat_matrix) - } - matrix <- build_matrix(matrix) - if (!is.null(heat_matrix)) { - # check heat_matrix and anno_matrix are compatible - bad_matrix <- switch(which, - row = nrow(matrix) == nrow(heat_matrix), - column = nrow(matrix) == ncol(heat_matrix) - ) - if (bad_matrix) { - msg <- sprintf("(%s) annotation matrix", style_fn(name)) - msg <- paste(msg, "is not compatible with heatmap matrix", - sep = " " - ) - cli::cli_abort(msg) - } - } - } - matrix -} - -scale_get_limits <- function(matrix, scale = NULL) { - if (is.null(scale)) { - if (is_discrete(matrix)) { - scale <- ggplot2::scale_y_discrete() - } else { - scale <- ggplot2::scale_y_continuous() - } - } - new_scale <- scale$clone() - new_scale$reset() - new_scale$train(matrix) - new_scale$get_limits() -} diff --git a/R/anno-subsettable-.R b/R/anno-subsettable-.R new file mode 100644 index 0000000..88e346f --- /dev/null +++ b/R/anno-subsettable-.R @@ -0,0 +1,154 @@ +#' Subsettable AnnotationFunction +#' +#' @inheritParams ggheat +#' @param draw_fn A function which defines how to draw the annotation. The +#' function should accept at least `matrix`, `index`, `k`, `n` arguments. +#' `...` is also passed on to this function. +#' @param ... Additional arguments passed on to `draw_fn`. +#' @inheritParams new_anno +#' @inheritParams ComplexHeatmap::AnnotationFunction +#' @param subset_rule A list of function to subset variables in `...`. +#' @details +#' `new_anno_subset` is similar with +#' [AnnotationFunction][ComplexHeatmap::AnnotationFunction], but +#' `new_anno_subset` won't change the function environment of `draw_fn`. So it's +#' safe to use `new_anno_subset` in pacakge development, particularly when +#' dealing with internal functions in the package namespace that are likely to +#' exist. You must always ensure arguments passed on to `...` have subset rules +#' since the internal will set `@@subsettable` to `TRUE`. +#' @examples +#' anno <- new_anno_subset( +#' rnorm(10L), +#' draw_fn = function(matrix, index, k, n) { +#' n <- length(index) +#' pushViewport(viewport(xscale = c(0.5, n + 0.5), yscale = c(0, 10))) +#' grid.rect() +#' grid.points(1:n, +#' matrix[index, , drop = FALSE], +#' default.units = "native" +#' ) +#' if (k == 1) grid.yaxis() +#' popViewport() +#' }, +#' height = unit(2, "cm") +#' ) +#' draw(anno) +#' @seealso +#' - [new_anno] +#' - [AnnotationFunction][ComplexHeatmap::AnnotationFunction] +#' @inherit ComplexHeatmap::AnnotationFunction return +#' @export +new_anno_subset <- function( + matrix, draw_fn, ..., ylim = NULL, subset_rule = NULL, + width = NULL, height = NULL, show_name = TRUE, + which = NULL, name = NULL) { + matrix <- build_matrix(matrix) + draw_fn <- allow_lambda(draw_fn) + if (...length() != sum(nzchar(...names()))) { + cli::cli_abort("All elements in {.arg ...} must be named.") + } + name <- name %||% "anno_subset" + dots <- rlang::list2(...) + # https://github.com/jokergoo/ComplexHeatmap/blob/7d95ca5cf533b98bd0351eecfc6805ad30c754c0/R/AnnotationFunction-class.R#L270 + internal_subset <- list(matrix = function(x, i) x[i, , drop = FALSE]) + if (...length() && is.null(subset_rule)) { + subset_rule <- lapply(dots, function(var) { + if (is.matrix(var)) { + function(x, i) x[i, , drop = FALSE] + } else if (inherits(var, "gpar")) { + subset_gp + } else if (is.vector(var)) { + if (length(var) > 1) function(x, i) x[i] + } + }) + } + if (length(subset_rule)) { + rules <- subset_rule + rules_nms <- names(rules) + subset_rule <- list(dots = function(x, i) { + imap(x, function(element, nm) { + if (any(nm == rules_nms)) { + rule <- rules[[nm]] + if (is.null(rule) || isFALSE(rule)) { + # Don't do subset + element + } else { + # subset element + rule(element, i) + } + } else { + element + } + }) + }) + } + subset_rule <- c(internal_subset, subset_rule) + which <- cheat_which(which) + anno <- new_anno( + n = nrow(matrix), + draw_fn = function(index, k, n) { + rlang::inject(draw_fn( + matrix = matrix, !!!dots, + index = index, k = k, n = n + )) + }, + ylim = ylim, + which = which, width = width, height = height, + show_name = show_name, name = name + ) + anno@subsettable <- TRUE + anno@subset_rule <- subset_rule + # we change `var_env` into the environment of `draw_fn` + anno@var_env <- environment(anno@fun) + # Only save necessary variables for usage of `draw_fn` + on.exit(rm( + list = setdiff( + ls(envir = anno@var_env, all.names = TRUE), + c("draw_fn", "matrix", "dots") + ), + envir = anno@var_env, inherits = FALSE + )) + anno +} + +anno_check_matrix <- function(matrix, which, heat_matrix, name) { + if (is.null(matrix) && is.null(heat_matrix)) { + cli::cli_abort("{.arg matrix} must be provided") + } else if (is.null(matrix)) { + matrix <- heat_matrix + } else { + if (is.function(matrix)) { + matrix <- matrix(heat_matrix) + } + matrix <- build_matrix(matrix) + if (!is.null(heat_matrix)) { + # check heat_matrix and anno_matrix are compatible + bad_matrix <- switch(which, + row = nrow(matrix) == nrow(heat_matrix), + column = nrow(matrix) == ncol(heat_matrix) + ) + if (bad_matrix) { + msg <- sprintf("(%s) annotation matrix", style_fn(name)) + msg <- paste(msg, "is not compatible with heatmap matrix", + sep = " " + ) + cli::cli_abort(msg) + } + } + } + matrix +} + +scale_get_limits <- function(matrix, scale = NULL) { + if (is.null(scale)) { + if (is_discrete(matrix)) { + scale <- ggplot2::scale_y_discrete() + } else { + scale <- ggplot2::scale_y_continuous() + } + } + new_scale <- scale$clone() + new_scale$reset() + new_scale$train(matrix) + new_scale$get_limits() +} diff --git a/R/gganno.R b/R/gganno.R index 99ed9a0..b0ff668 100644 --- a/R/gganno.R +++ b/R/gganno.R @@ -10,7 +10,6 @@ #' @inheritParams ggheat #' @param ... Additional arguments passed to `ggfn`. #' @inheritParams ComplexHeatmap::AnnotationFunction -#' @return A `ggAnnotationFunction` object. #' @section ggfn: #' #' `ggfn` accept a ggplot2 object with a default data and mapping created by @@ -31,10 +30,7 @@ #' draw(gganno(rnorm(10L), function(p) { #' p + geom_point(aes(y = V1)) #' }, height = unit(10, "cm"), width = unit(0.7, "npc"))) -#' @return -#' - `gganno`: A `ggAnnotationFunction` object. -#' - `gganno2`: A [AnnotationFunction][ComplexHeatmap::AnnotationFunction] -#' object. +#' @return A `ggAnnotationFunction` object. #' @export #' @name gganno gganno <- function(matrix, ggfn, ..., which = NULL, @@ -46,8 +42,7 @@ gganno <- function(matrix, ggfn, ..., which = NULL, out <- new_anno( n = nrow(matrix), draw_fn = function(index, k, n) NULL, - ylim = NULL, subset_rule = list(), subsettable = FALSE, - which = which, width = width, height = height, + ylim = NULL, which = which, width = width, height = height, show_name = FALSE, name = "gganno" ) out <- methods::as(out, "ggAnnotationFunction") @@ -55,51 +50,10 @@ gganno <- function(matrix, ggfn, ..., which = NULL, out@ggfn <- ggfn out@ggparams <- ggparams out@debug <- debug + out@gginitialized <- FALSE out } -#' @examples -#' draw(gganno2(rnorm(10L), function(p) { -#' p + geom_point(aes(y = V1)) -#' }, height = unit(10, "cm"), width = unit(0.7, "npc"))) -#' @export -#' @rdname gganno -gganno2 <- function( - matrix, ggfn, ..., which = NULL, - width = NULL, height = NULL, debug = FALSE) { - anno <- gganno(matrix, - ggfn = ggfn, ..., which = which, - width = width, height = height, - debug = debug - ) - draw_fn2 <- NULL - draw_fn <- function(index, k, n) { - if (k == 1L) { - # only prepare ggplot data in the first run and run everytime when - # draw function execution - # https://github.com/jokergoo/ComplexHeatmap/blob/master/R/HeatmapList-draw_component.R - # trace back into `draw_heatmap_list()` - order_list <- cheat_get_order_list("ht_main") - if (isFALSE(order_list)) { - order_list <- switch(anno@which, - row = list(row_order_list = list(index)), - column = list(column_order_list = list(index)) - ) - } - draw_fn2 <<- draw_gganno(anno, order_list, NULL, "gganno2")$draw_fn - } - draw_fn2(index, k, n) - } - new_anno( # won't change the function environment of `draw_fn` - n = nrow(anno@matrix), draw_fn = draw_fn, ylim = NULL, - subset_rule = list(), subsettable = FALSE, - which = anno@which, width = width, height = height, - show_name = FALSE, name = "gganno2" - ) -} - -methods::setClassUnion("MatrixOrNull", c("matrix", "NULL")) - #' @importClassesFrom ComplexHeatmap AnnotationFunction #' @export #' @rdname gganno @@ -109,18 +63,61 @@ methods::setClass( slots = list( ggfn = "FunctionOrNull", ggparams = "list", - matrix = "MatrixOrNull", + gginitialized = "logical", + matrix = "matrix", debug = "ANY" ), contains = "AnnotationFunction" ) +#' @importFrom ComplexHeatmap make_layout +methods::setMethod( + "make_layout", "ggAnnotationFunction", + function(object, order_list, add_legend = TRUE, + heat_matrix = NULL, id = NULL) { + if (!object@gginitialized) { + if (is.null(heat_matrix) && + (is.null(object@matrix) || is.function(object@matrix))) { + cli::cli_abort(paste( + "You must provide a matrix in {.fn gganno}", + "in order to draw {.cls ggAnnotationFunction} directly" + )) + } + if (is.null(object@matrix)) { + object@matrix <- switch(object@which, + row = heat_matrix, + column = t(heat_matrix) + ) + } else if (is.function(object@matrix)) { + data <- switch(object@which, + row = heat_matrix, + column = t(heat_matrix) + ) + object@matrix <- object@matrix(data) + } + gganno_element <- draw_gganno( + object, order_list, + id = id %||% "ggAnnotationFunction" + ) + + # we merge the annotation_legend_list with ggplot2 legends ----- + # we'll trace back into `make_layout,HeatmapList` method + add_gg_legend_list("annotation_legend_list", gganno_element$legend) + object@fun <- gganno_element$draw_fn + object@gginitialized <- TRUE + } + object + } +) + #' Draw the ggAnnotationFunction Object #' -#' @param object The `ggAnnotationFunction-class` object. -#' @param index Index of observations. +#' @param object The [ggAnnotationFunction][gganno] object. +#' @param index A vector of indices. +#' @param k The current slice index for the annotation if it is split. +#' @param n Total number of slices. #' @param ... Additional arguments passed on to -#' [draw-AnnotationFunction][ComplexHeatmap::draw,HeatmapAnnotation-method]. +# [draw-AnnotationFunction][ComplexHeatmap::draw,HeatmapAnnotation-method]. #' @return draw the annotation. #' @examples #' draw(gganno(rnorm(10L), function(p) { @@ -130,22 +127,59 @@ methods::setClass( methods::setMethod( f = "draw", signature = "ggAnnotationFunction", - definition = function(object, index, ...) { + definition = function(object, index, k = 1L, n = 1L, ...) { if (ht_opt$verbose) { - cli::cli_inform("annotation generated by {.fn object@fun_name}") + cli::cli_inform("annotation generated by {.fn {object@fun_name}}") } if (missing(index)) index <- seq_len(object@n) - - order_list <- switch(object@which, - row = list(row_order_list = list(index)), - column = list(column_order_list = list(index)) + if (k == 1L && !object@gginitialized) { + # This is only used by ComplexHeatmap::Heatmap function + # since `ggheat` will initialize `gganno` when preparing the main + # heatmap layout. + order_list <- gganno_get_order_list("ht_main", object@which) + if (is.null(order_list)) { + if (n == 1L) { + order_list <- list(index) + } else { + cli::cli_abort( + "Cannot initialize {.cls ggAnnotationFunction}" + ) + } + } + object <- make_layout(object, order_list) + } + methods::callNextMethod( + object = object, index = index, + k = k, n = n, ... ) - gganno_element <- draw_gganno(object, order_list, id = "gganno") - object@fun <- gganno_element$draw_fn - methods::callNextMethod(object = object, index = index, ...) } ) +# https://github.com/jokergoo/ComplexHeatmap/blob/7d95ca5cf533b98bd0351eecfc6805ad30c754c0/R/HeatmapList-draw_component.R#L670 +# trace back into `draw_heatmap_list()` +# get slice informations from the draw function +gganno_get_order_list <- function(name, axis, call = quote(draw_heatmap_list)) { + pos <- -2L + nframes <- -sys.nframe() + 1L # total parents + while (pos >= nframes) { + env <- sys.frame(pos) + if (identical(utils::packageName(topenv(env)), "ComplexHeatmap") && + exists(name, envir = env, inherits = FALSE) && + identical(sys.call(pos - 1L)[[1L]], call)) { + obj <- .subset2(env, name) + if (methods::.hasSlot(obj, "row_order_list") && + methods::.hasSlot(obj, "column_order_list")) { + return(switch(axis, + row = obj@row_order_list, + column = obj@column_order_list + )) + } + } + pos <- pos - 1L + } + NULL +} + #' @importFrom ggplot2 ggplot #' @importFrom ggplot2 aes draw_gganno <- function(anno, order_list, heat_matrix, id) { @@ -155,10 +189,6 @@ draw_gganno <- function(anno, order_list, heat_matrix, id) { column = t(heat_matrix) ) labels <- rownames(matrix) - order_list <- switch(which, - row = order_list$row_order_list, - column = order_list$column_order_list - ) data <- as_tibble0(matrix, rownames = NULL) # nolint if (length(order_list) > 1L) { with_slice <- TRUE diff --git a/R/prepare.R b/R/prepare.R index c628455..b86577d 100644 --- a/R/prepare.R +++ b/R/prepare.R @@ -1,6 +1,6 @@ #' Prepare the Heatmap #' @inherit ComplexHeatmap::prepare -#' @examples +#' @examples #' prepare(ggheat(matrix(rnorm(81), nrow = 9))) #' @importFrom ComplexHeatmap prepare #' @export @@ -93,9 +93,7 @@ prepare_ggheat <- function(object) { if (!is.null(object@ggfn)) { p <- rlang::inject(object@ggfn(p, !!!object@ggparams)) if (!ggplot2::is.ggplot(p)) { - cli::cli_abort( - "{.arg ggfn} must return a {.cls ggplot2} object." - ) + cli::cli_abort("{.arg ggfn} must return a {.cls ggplot2} object.") } } @@ -153,16 +151,14 @@ prepare_ggheat <- function(object) { kr <- draw_body_env$kr kc <- draw_body_env$kc pattern <- sprintf("panel-%d-%d", kr, kc) - fit_panel( - gt_trim_zero_grob(gtable::gtable_filter(gt, pattern)), - vp = vp - ) + vp_gt <- gt_trim_zero_grob(gtable::gtable_filter(gt, pattern)) + fit_panel(vp_gt, vp = vp, elements = NULL) } else { - fit_panel(gt_trim_zero_grob(gt), vp = vp, elements = NULL) + vp_gt <- gt_trim_zero_grob(gt) + fit_panel(vp_gt, vp = vp, elements = NULL) } } - if (!is.null(object@ggfn) || - !identical(rect_gp$type, "none")) { + if (!is.null(object@ggfn) || !identical(rect_gp$type, "none")) { # if user provided `ggfn` or rect_gp$type is not none, # we should do something with `ggfn` object@matrix_param$layer_fun <- gglayer @@ -171,24 +167,11 @@ prepare_ggheat <- function(object) { # https://github.com/jokergoo/ComplexHeatmap/pull/1139 # object@heatmap_legend_list <- c( # guide_from_gtable(gt), - # prepare_legend_list(object@heatmap_legend_list) + # wrap_legend(object@heatmap_legend_list) # ) # we'll trace back into `make_layout,HeatmapList` method - pos <- 1L - while (pos <= sys.nframe()) { - env <- sys.frame(-pos) - if (exists("heatmap_legend_list", envir = env, inherits = FALSE) && - identical(sys.call(-(pos + 1L))[[1L]], quote(make_layout))) { - # we then modify the heatmap_legend_list - assign("heatmap_legend_list", c( - guide_from_gtable(gt), - prepare_legend_list(.subset2(env, "heatmap_legend_list")) - ), envir = env) - break - } - pos <- pos + 1L - } + add_gg_legend_list("heatmap_legend_list", guide_from_gtable(gt)) # we always prevent the ComplexHeatmap Heatmap body legend. object@heatmap_param$show_heatmap_legend <- FALSE @@ -197,11 +180,6 @@ prepare_ggheat <- function(object) { } prepare_gganno <- function(object) { - full_order_list <- list( - row_order_list = object@row_order_list, - column_order_list = object@column_order_list - ) - ggplot_legends <- NULL for (side in c("left", "right", "top", "bottom")) { anno_name <- sprintf("%s_annotation", side) annotation <- methods::slot(object, anno_name) @@ -212,46 +190,54 @@ prepare_gganno <- function(object) { anno <- anno_list[[i]]@fun # if the annotation exits and is `ggAnnotationFunction` if (!inherits(anno, "ggAnnotationFunction")) next + order_list <- switch(anno@which, + row = object@row_order_list, + column = object@column_order_list + ) # we initialize the ggplot2 object and extract the legends - gganno_element <- draw_gganno( - anno, full_order_list, object@matrix, + anno_list[[i]]@fun <- make_layout(anno, order_list, id = names(anno_list)[i] ) - anno@fun <- gganno_element$draw_fn - # if we don't transfer anno into AnnotationFunction. - # the internal will call draw method for `ggAnnotationFunction` - # which internally will call `draw_gganno` again - anno_list[[i]]@fun <- methods::as(anno, "AnnotationFunction") - ggplot_legends <- c(ggplot_legends, gganno_element$legend) } methods::slot(object, anno_name)@anno_list <- anno_list } - # we merge the annotation_legend_list with ggplot2 legends ----- - # object@annotation_legend_list <- c( - # annotation_legend_list, - # prepare_legend_list(object@annotation_legend_list) - # ) - # we'll trace back into `make_layout,HeatmapList` method - pos <- 1L - while (pos <= sys.nframe()) { - env <- sys.frame(-pos) - if (exists("annotation_legend_list", envir = env, inherits = FALSE) && - identical(sys.call(-(pos + 1L))[[1L]], quote(make_layout))) { - # we then modify the annotation_legend_list - assign("annotation_legend_list", c( - ggplot_legends, - prepare_legend_list(.subset2(env, "annotation_legend_list")) - ), envir = env) + object +} + +# here is the magic +add_gg_legend_list <- function(name, gg_legends, call = quote(make_layout)) { + if (length(gg_legends) == 0L) return(NULL) # styler: off + pos <- -2L + nframes <- -sys.nframe() + 1L # total parents + while (pos >= nframes) { + env <- sys.frame(pos) # we locate the legend environment + if (identical(utils::packageName(topenv(env)), "ComplexHeatmap") && + exists(name, envir = env, inherits = FALSE) && + # Since ComplexHeatmap function much are the S4 methods + # we identify the call name from the parent + identical(sys.call(pos - 1L)[[1L]], call)) { + old <- wrap_legend(.subset2(env, name)) + index <- grep("^\\.gg_legend\\d+$", rlang::names2(old), perl = TRUE) + old_gg_legends <- old[index] + names(gg_legends) <- paste0( + ".__gg_legend", seq_along(gg_legends) + length(old_gg_legends) + ) + # we then modify the legend list + assign( + # user provided legends always in the end + name, c(old_gg_legends, gg_legends, old[-index]), + envir = env + ) break } - pos <- pos + 1L + pos <- pos - 1L } - object } -prepare_legend_list <- function(x) { - if (length(x) > 0L && inherits(x, c("Legends", "grob"))) { - x <- list(x) +wrap_legend <- function(legend) { + if (length(legend) > 0L && inherits(legend, c("Legends", "grob"))) { + list(legend) + } else { + legend } - x } diff --git a/R/utils-complexheatmap.R b/R/utils-complexheatmap.R index cf4ccc9..6273e7c 100644 --- a/R/utils-complexheatmap.R +++ b/R/utils-complexheatmap.R @@ -18,26 +18,6 @@ cheat_env_get <- function(name) { cheat_env <- function() utils::getFromNamespace(".ENV", ns = "ComplexHeatmap") -# get slice informations from the draw function -cheat_get_order_list <- function(name, pos = 2L, return_env = FALSE) { - trace_data( - name = name, - has_fn = function(env, name) { - exists(name, envir = env, inherits = FALSE) && - methods::.hasSlot(.subset2(env, name), "row_order_list") && - methods::.hasSlot(.subset2(env, name), "column_order_list") - }, - return_fn = function(env, name) { - obj <- .subset2(env, name) - list( - row_order_list = obj@row_order_list, - column_order_list = obj@column_order_list - ) - }, - pos = pos, return_env = return_env - ) -} - cheat_full_slice_index <- function(order_list) { row_full <- unlist(order_list$row, recursive = FALSE, use.names = FALSE) row_full <- structure(seq_along(row_full), names = row_full) diff --git a/R/utils.R b/R/utils.R index 2e4a356..3650083 100644 --- a/R/utils.R +++ b/R/utils.R @@ -4,13 +4,13 @@ pkg_nm <- function() { utils::packageName(topenv(environment())) } -#' @examples +#' @examples #' gpar(col = "red") #' @importFrom grid gpar #' @export grid::gpar -#' @examples +#' @examples #' unit(1, "npc") #' @importFrom grid unit #' @export @@ -23,9 +23,7 @@ imap <- function(.x, .f, ...) { out } -compact <- function(.x) { - Filter(length, .x) -} +compact <- function(.x) Filter(length, .x) build_matrix <- function(matrix, arg = rlang::caller_arg(matrix)) { if (inherits(matrix, "data.frame")) { diff --git a/README.html b/README.html index aa7df22..ff54f06 100644 --- a/README.html +++ b/README.html @@ -606,7 +606,7 @@

eheat

-

R-CMD-check

+

R-CMD-check

This package serves as a bridge between the ggplot2 and @@ -868,19 +868,15 @@

ggheat

gganno

-

Both gganno and gganno2 perform identical -functions, but gganno is not compatible with direct -integration with ComplexHeatmap::Heatmap. In such cases, -only an empty annotation region can be added. On the other hand, -gganno2 can be seamlessly combined with both -ComplexHeatmap::Heatmap and ggheat, although -legends will not be extracted.

The same with ggheat, the essential parameter of -gganno is also ggfn, which accepts a ggplot2 -object equipped with a default data and mappings established by +gganno is also the ggfn, which accepts a +ggplot2 object equipped with a default data and mappings established by ggplot(data, aes(.data$.x (or .data$.y))). The original matrix will be converted into a data.frame with another 3 columns added:

+

gganno can be seamlessly combined with both +ggheat and ComplexHeatmap::Heatmap, although +legends will not be extracted in the later case.