From c42cf585eefc4661509f3abe967a3539f472754d Mon Sep 17 00:00:00 2001 From: yun Date: Fri, 21 Jun 2024 21:30:10 +0800 Subject: [PATCH] fix `new_anno_subset` --- R/anno-.R | 3 ++- R/anno-subsettable-.R | 46 +++++++++++++++++------------------------- man/new_anno_subset.Rd | 19 ++++++++--------- 3 files changed, 28 insertions(+), 40 deletions(-) diff --git a/R/anno-.R b/R/anno-.R index 6df45ee..8512f98 100644 --- a/R/anno-.R +++ b/R/anno-.R @@ -54,8 +54,9 @@ new_anno <- function(n, draw_fn, ylim = NULL, # environment of `anno@fun` # here: we use new_anno instead, in this way, the function in the # package namespace can be used directly + draw_fn <- allow_lambda(draw_fn) assert_string(name, null_ok = TRUE) - name <- name %||% "" + name <- name %||% "new_anno" if (ht_opt$verbose) { msg <- "construct AnnotationFunction" if (name == "") msg <- paste(msg, "with {.fn {name}}") diff --git a/R/anno-subsettable-.R b/R/anno-subsettable-.R index 88e346f..53fe62e 100644 --- a/R/anno-subsettable-.R +++ b/R/anno-subsettable-.R @@ -1,11 +1,10 @@ #' Subsettable AnnotationFunction #' -#' @inheritParams ggheat +#' @inheritParams new_anno #' @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. +#' function should accept at least three `index`, `k`, `n` arguments in the +#' beginning. Names don't matter. #' @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 @@ -18,57 +17,53 @@ #' since the internal will set `@@subsettable` to `TRUE`. #' @examples #' anno <- new_anno_subset( -#' rnorm(10L), -#' draw_fn = function(matrix, index, k, n) { +#' 10L, function(index, k, n, matrix) { #' 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" -#' ) +#' grid.points(1:n, matrix[index], default.units = "native") #' if (k == 1) grid.yaxis() #' popViewport() #' }, +#' matrix = rnorm(10L), #' height = unit(2, "cm") #' ) #' draw(anno) +#' draw(anno[1:2]) #' @seealso #' - [new_anno] #' - [AnnotationFunction][ComplexHeatmap::AnnotationFunction] #' @inherit ComplexHeatmap::AnnotationFunction return #' @export new_anno_subset <- function( - matrix, draw_fn, ..., ylim = NULL, subset_rule = NULL, + n, 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" + name <- name %||% "new_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] + } else if (is.vector(var) && 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) { + rules_nms <- names(rules) imap(x, function(element, nm) { if (any(nm == rules_nms)) { - rule <- rules[[nm]] + rule <- .subset2(rules, nm) if (is.null(rule) || isFALSE(rule)) { # Don't do subset element @@ -82,15 +77,10 @@ new_anno_subset <- function( }) }) } - subset_rule <- c(internal_subset, subset_rule) - which <- cheat_which(which) anno <- new_anno( - n = nrow(matrix), + n = n, draw_fn = function(index, k, n) { - rlang::inject(draw_fn( - matrix = matrix, !!!dots, - index = index, k = k, n = n - )) + rlang::inject(draw_fn(index, k, n, !!!dots)) }, ylim = ylim, which = which, width = width, height = height, @@ -99,12 +89,12 @@ new_anno_subset <- function( 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` + anno@var_env <- environment(anno@fun) # should be the current environment + # Only save necessary variables for usage of `draw_fn` and `subset_rule` on.exit(rm( list = setdiff( ls(envir = anno@var_env, all.names = TRUE), - c("draw_fn", "matrix", "dots") + c("draw_fn", "dots", "rules") ), envir = anno@var_env, inherits = FALSE )) diff --git a/man/new_anno_subset.Rd b/man/new_anno_subset.Rd index 96bf01b..9e6f2be 100644 --- a/man/new_anno_subset.Rd +++ b/man/new_anno_subset.Rd @@ -5,7 +5,7 @@ \title{Subsettable AnnotationFunction} \usage{ new_anno_subset( - matrix, + n, draw_fn, ..., ylim = NULL, @@ -18,12 +18,11 @@ new_anno_subset( ) } \arguments{ -\item{matrix}{A matrix, if it is a simple vector, it will be converted to a -one-column matrix. Data.frame will also be coerced into matrix.} +\item{n}{Number of observations in the annotation. It is not mandatory, but it is better to provide this information so that the higher order \code{\link[ComplexHeatmap]{HeatmapAnnotation}} knows it and it can perform check on the consistency of annotations and heatmaps.} \item{draw_fn}{A function which defines how to draw the annotation. The -function should accept at least \code{matrix}, \code{index}, \code{k}, \code{n} arguments. -\code{...} is also passed on to this function.} +function should accept at least three \code{index}, \code{k}, \code{n} arguments in the +beginning. Names don't matter.} \item{...}{Additional arguments passed on to \code{draw_fn}.} @@ -58,21 +57,19 @@ since the internal will set \verb{@subsettable} to \code{TRUE}. } \examples{ anno <- new_anno_subset( - rnorm(10L), - draw_fn = function(matrix, index, k, n) { + 10L, function(index, k, n, matrix) { 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" - ) + grid.points(1:n, matrix[index], default.units = "native") if (k == 1) grid.yaxis() popViewport() }, + matrix = rnorm(10L), height = unit(2, "cm") ) draw(anno) +draw(anno[1:2]) } \seealso{ \itemize{