feat: add resize argument to free_vp to control viewport resizing

Author: Yunuuuu

R/alignpatch-free-vp.R

@@ -1,30 +1,38 @@
 #' @inheritParams grid::viewport
 #' @inheritDotParams grid::viewport -x -y -width -height
+#' @param resize A logical value. If `TRUE`, the viewport will be resized to
+#'   accommodate the underlying gtable. This only applies when both the viewport
+#'   width/height and the underlying gtable widths/heights are specified using
+#'   absolute units. If `TRUE` and the viewport width/height is `NA`, the
+#'   width/height will be set to match the gtable's widths/heights. Otherwise,
+#'   the width/height will be set to `unit(1, "npc")`. See
+#'   [`absolute.size()`][grid::absolute.size] for absolute unit.
 #' @return
 #' - `free_vp`: A modified version of `plot` with a `ggalign_free_vp` class.
 #' @export
 #' @rdname free
-free_vp <- function(plot, x = 0.5, y = 0.5, width = NA, height = NA, ...) {
+free_vp <- function(plot, x = 0.5, y = 0.5, width = NA, height = NA, ...,
+                    resize = TRUE) {
     UseMethod("free_vp")
 }
 
 #' @importFrom grid viewport
 #' @export
 free_vp.default <- function(plot, x = 0.5, y = 0.5,
-                            width = NA, height = NA, ...) {
-    attr(plot, "ggalign_free_vp") <- viewport(
-        x = x, y = y, width = width, height = height, ...,
-    )
+                            width = NA, height = NA, ...,
+                            resize = TRUE) {
+    vp <- viewport(x = x, y = y, width = width, height = height, ..., )
+    attr(plot, "ggalign_free_vp") <- list(vp = vp, resize = resize)
     add_class(plot, "ggalign_free_vp")
 }
 
 #' @importFrom grid viewport
 #' @export
 free_vp.ggalign_free_vp <- function(plot, x = 0.5, y = 0.5,
-                                    width = NA, height = NA, ...) {
-    attr(plot, "ggalign_free_vp") <- viewport(
-        x = x, y = y, width = width, height = height, ...,
-    )
+                                    width = NA, height = NA, ...,
+                                    resize = TRUE) {
+    vp <- viewport(x = x, y = y, width = width, height = height, ..., )
+    attr(plot, "ggalign_free_vp") <- list(vp = vp, resize = resize)
     plot
 }
 
@@ -40,23 +48,37 @@ patch.ggalign_free_vp <- function(x) {
         vp = attr(x, "ggalign_free_vp", exact = TRUE),
         place = function(self, gtable, gt, t, l, b, r, i, bg_z, plot_z) {
             if (is.grob(gt)) {
-                vp <- self$vp
-
-                if (all(is_absolute_unit(widths <- .subset2(gt, "widths")))) {
-                    vp$width <- sum(widths)
-                } else if (!is.na(as.numeric(vp$width))) {
-                    # we guess the width from the gtable
-                    vp$width <- max(vp$width, sum(widths))
-                } else {
-                    vp$width <- unit(1, "npc")
-                }
-                if (all(is_absolute_unit(heights <- .subset2(gt, "heights")))) {
-                    vp$height <- sum(heights)
-                } else if (!is.na(as.numeric(vp$height))) {
-                    # we guess the height from the gtable
-                    vp$height <- max(vp$height, sum(heights))
+                vp <- self$vp$vp
+                widths <- .subset2(gt, "widths")
+                heights <- .subset2(gt, "heights")
+                if (isTRUE(self$vp$resize)) {
+                    if (is.na(as.numeric(vp$width))) {
+                        # we guess the width from the gtable
+                        if (all(is_absolute_unit(widths))) {
+                            vp$width <- sum(widths)
+                        } else {
+                            vp$width <- unit(1, "npc")
+                        }
+                    } else if (is_absolute_unit(vp$width)) {
+                        vp$width <- max(vp$width, sum(widths))
+                    }
+                    if (is.na(as.numeric(vp$height))) {
+                        # we guess the height from the gtable
+                        if (all(is_absolute_unit(heights))) {
+                            vp$height <- sum(heights)
+                        } else {
+                            vp$height <- unit(1, "npc")
+                        }
+                    } else if (is_absolute_unit(vp$height)) {
+                        vp$height <- max(vp$height, sum(heights))
+                    }
                 } else {
-                    vp$height <- unit(1, "npc")
+                    if (is.na(as.numeric(vp$width))) {
+                        vp$width <- unit(1, "npc")
+                    }
+                    if (is.na(as.numeric(vp$height))) {
+                        vp$height <- unit(1, "npc")
+                    }
                 }
                 gt <- editGrob(gt, vp = vp)
             }

R/layout-chain-stack-composer.R

@@ -120,13 +120,13 @@ stack_composer_add <- function(box, stack, composer, ...) {
                 composer$align <- .subset2(composer, "align") + 1L
             }
             if (is_absolute_unit(size <- .subset2(sizes, "top"))) {
-                attr(top, "ggalign_free_vp")$height <- size
+                attr(top, "ggalign_free_vp")$vp$height <- size
             }
             composer <- stack_composer_add_plot(composer, top, t = 1L, l = l)
         }
         if (!is.null(bottom <- .subset2(plots, "bottom"))) {
             if (is_absolute_unit(size <- .subset2(sizes, "bottom"))) {
-                attr(bottom, "ggalign_free_vp")$height <- size
+                attr(bottom, "ggalign_free_vp")$vp$height <- size
             }
             composer <- stack_composer_add_plot(composer, bottom,
                 t = .subset2(composer, "align") + 1L, l = l
@@ -160,13 +160,13 @@ stack_composer_add <- function(box, stack, composer, ...) {
                 composer$align <- .subset2(composer, "align") + 1L
             }
             if (is_absolute_unit(size <- .subset2(sizes, "left"))) {
-                attr(left, "ggalign_free_vp")$width <- size
+                attr(left, "ggalign_free_vp")$vp$width <- size
             }
             composer <- stack_composer_add_plot(composer, left, t = t, l = 1L)
         }
         if (!is.null(right <- .subset2(plots, "right"))) {
             if (is_absolute_unit(size <- .subset2(sizes, "right"))) {
-                attr(right, "ggalign_free_vp")$width <- size
+                attr(right, "ggalign_free_vp")$vp$width <- size
             }
             composer <- stack_composer_add_plot(composer, right,
                 t = t, l = .subset2(composer, "align") + 1L

man/free.Rd

@@ -5,7 +5,7 @@ test_that("free_vp() assigns class and viewport attribute", {
 
     expect_s3_class(p_vp, "ggalign_free_vp")
     expect_s3_class(p_vp, "ggplot")
-    vp <- attr(p_vp, "ggalign_free_vp")
+    vp <- attr(p_vp, "ggalign_free_vp")$vp
     expect_true(inherits(vp, "viewport"))
     expect_equal(as.numeric(vp$x), 0.3)
     expect_equal(as.numeric(vp$y), 0.7)
@@ -20,16 +20,16 @@ test_that("free_space() works with alignpatch objects", {
     p_vp <- free_vp(p, x = 0.1, y = 0.9)
 
     expect_s3_class(p_vp, "ggalign_free_vp")
-    expect_equal(as.numeric(attr(p_vp, "ggalign_free_vp")$x), 0.1)
-    expect_equal(as.numeric(attr(p_vp, "ggalign_free_vp")$y), 0.9)
+    expect_equal(as.numeric(attr(p_vp, "ggalign_free_vp")$vp$x), 0.1)
+    expect_equal(as.numeric(attr(p_vp, "ggalign_free_vp")$vp$y), 0.9)
 })
 
 test_that("free_vp() uses defaults when width/height missing", {
     p <- ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt)) +
         ggplot2::geom_point()
     p_vp <- free_vp(p)
 
-    vp <- attr(p_vp, "ggalign_free_vp")
+    vp <- attr(p_vp, "ggalign_free_vp")$vp
     expect_true(inherits(vp, "viewport"))
     expect_equal(as.numeric(vp$x), 0.5)
     expect_equal(as.numeric(vp$y), 0.5)