From 6fe905d1646708a119e5e0b8568130d4dc164d0f Mon Sep 17 00:00:00 2001 From: Meng Xu <86040828+mengxu98@users.noreply.github.com> Date: Thu, 10 Sep 2026 18:10:57 +0800 Subject: [PATCH] fix: support patchwork >= 1.3 in `build_patchwork()` --- R/utils.R | 89 +++++++++++++++++++++++++++++++++--- tests/test-build-patchwork.R | 51 +++++++++++++++++++++ 2 files changed, 134 insertions(+), 6 deletions(-) create mode 100644 tests/test-build-patchwork.R diff --git a/R/utils.R b/R/utils.R index 50faa03..e6c24a4 100644 --- a/R/utils.R +++ b/R/utils.R @@ -100,8 +100,44 @@ build_patchwork <- function( panel_row = 10, panel_col = 8 ) { + default_layout <- get_namespace_fun("patchwork", "default_layout") + table_defaults <- vapply( + c("TABLE_ROWS", "TABLE_COLS", "PANEL_ROW", "PANEL_COL"), + function(name) { + value <- tryCatch( + get(name, envir = asNamespace("patchwork")), + error = function(e) NA_real_ + ) + as.numeric(value) + }, + numeric(1) + ) + if (all(!is.na(table_defaults))) { + if (!identical( + as.numeric(c(table_rows, table_cols, panel_row, panel_col)), + unname(table_defaults) + )) { + log_message( + "{.arg table_rows}, {.arg table_cols}, {.arg panel_row} and {.arg panel_col} are set by patchwork and cannot be overridden", + message_type = "warning" + ) + } + table_rows <- table_defaults[[1]] + table_cols <- table_defaults[[2]] + panel_row <- table_defaults[[3]] + panel_col <- table_defaults[[4]] + } + if (length(tryCatch(x$plots, error = function(e) NULL)) == 0) { + get_patches_fun <- tryCatch( + get_namespace_fun("patchwork", "get_patches"), + error = function(e) NULL + ) + if (!is.null(get_patches_fun)) { + x <- get_patches_fun(x) + } + } x$layout <- utils::modifyList( - get_namespace_fun("patchwork", "default_layout"), + default_layout, x$layout[!vapply(x$layout, is.null, logical(1))] ) @@ -154,7 +190,7 @@ build_patchwork <- function( x$layout$design <- create_design_fun( dims[2], dims[1], - x$layout$byrow + isTRUE(x$layout$byrow) ) } else { dims <- c( @@ -190,7 +226,7 @@ build_patchwork <- function( seq_along(gt), function(i) { loc <- design[i, ] lay <- gt[[i]]$layout - lay$name <- paste0(lay$name, "-", i) + lay$z <- lay$z + ifelse(lay$name == "background", 0, max_z[i]) lay$t <- lay$t + ifelse( lay$t <= panel_row, (loc$t - 1) * table_rows, @@ -212,7 +248,8 @@ build_patchwork <- function( (loc$l - 1) * table_cols, (loc$r - 1) * table_cols ) - lay$z <- lay$z + max_z[i] + lay$z <- lay$z + ifelse(lay$name == "background", 0, max_z[i]) + lay$name <- paste0(lay$name, "-", i) lay } ) @@ -252,19 +289,59 @@ build_patchwork <- function( if (!attr(theme, "complete")) { theme <- ggplot2::theme_get() + theme } + position <- theme$legend.position %||% "right" + if (length(position) == 2) { + log_message( + "Manual legend position not possible for collected guides. Defaulting to 'right'", + message_type = "warning" + ) + position <- "right" + } assemble_guides_fun <- get_namespace_fun( "patchwork", "assemble_guides" ) - guide_grobs <- assemble_guides_fun(guide_grobs, theme) + guide_grobs <- assemble_guides_fun(guide_grobs, position, theme) attach_guides_fun <- get_namespace_fun( "patchwork", "attach_guides" ) - gt_new <- attach_guides_fun(gt_new, guide_grobs, theme) + gt_new <- attach_guides_fun(gt_new, guide_grobs, position, theme) } } else { gt_new$collected_guides <- guide_grobs } + axes <- x$layout$axes %||% default_layout$axes + if (axes %in% c("collect", "collect_x")) { + collect_axes_fun <- get_namespace_fun("patchwork", "collect_axes") + gt_new <- collect_axes_fun(gt_new, "x") + } + if (axes %in% c("collect", "collect_y")) { + collect_axes_fun <- get_namespace_fun("patchwork", "collect_axes") + gt_new <- collect_axes_fun(gt_new, "y") + } + titles <- x$layout$axis_titles %||% default_layout$axis_titles + if (titles %in% c("collect", "collect_x")) { + collect_titles_fun <- get_namespace_fun( + "patchwork", "collect_axis_titles" + ) + gt_new <- collect_titles_fun(gt_new, "x", merge = TRUE) + } + if (titles %in% c("collect", "collect_y")) { + collect_titles_fun <- get_namespace_fun( + "patchwork", "collect_axis_titles" + ) + gt_new <- collect_titles_fun(gt_new, "y", merge = TRUE) + } + gt_new <- gtable::gtable_add_grob( + gt_new, + ggplot2::zeroGrob(), t = panel_row, + l = panel_col, + b = panel_row + table_rows * (dims[1] - 1), + r = panel_col + table_cols * (dims[2] - 1), + z = -1, + name = "panel-area" + ) + class(gt_new) <- c("gtable_patchwork", class(gt_new)) gt_new } diff --git a/tests/test-build-patchwork.R b/tests/test-build-patchwork.R new file mode 100644 index 0000000..f4f57a3 --- /dev/null +++ b/tests/test-build-patchwork.R @@ -0,0 +1,51 @@ +library(ggplot2) +library(patchwork) +library(thisplot) + +grDevices::pdf(NULL) + +panel <- function(title) { + ggplot2::ggplot(mtcars, ggplot2::aes(wt, mpg)) + + ggplot2::geom_point(ggplot2::aes(colour = factor(cyl))) + + ggplot2::labs(title = title, x = "x", y = "y") +} + +pw <- patchwork::wrap_plots( + lapply(c("A", "B", "C", "D"), panel), + ncol = 2, + axes = "collect", + axis_titles = "collect", + guides = "collect" +) + + patchwork::plot_annotation(title = "Main title") + +built <- thisplot::build_patchwork(pw) + +warned <- FALSE +built_tall <- withCallingHandlers( + thisplot::build_patchwork(pw, table_rows = 36), + warning = function(w) { + warned <<- TRUE + invokeRestart("muffleWarning") + } +) + +grob <- thisplot::patchwork_grob(pw) +reference <- patchwork::patchworkGrob(pw) + +stopifnot( + inherits(built, "gtable"), + inherits(built, "gtable_patchwork"), + sum(built$layout$name == "panel-area") == 1, + all(built$layout$t >= 1), + all(built$layout$l >= 1), + all(built$layout$b <= nrow(built)), + all(built$layout$r <= ncol(built)), + warned, + identical(dim(built_tall), dim(built)), + inherits(grob, "gtable"), + !inherits(grob, "gtable_patchwork"), + identical(dim(grob), dim(reference)) +) + +grDevices::dev.off()