Use innate plot size in ggsave()

NEWS.md

@@ -289,6 +289,9 @@
 * `geom_abline()` clips to the panel range in the vertical direction too
   (@teunbrand, #6086).
 * Added `panel.widths` and `panel.heights` to `theme()` (#5338, @teunbrand).
+* New options `ggsave(..., width = derive(), height = derive())` to tailor
+  output size to absolute dimensions set with 
+  `theme(panel.widths, panel.heights)` (#).
 * Standardised the calculation of `width`, which are now implemented as
   aesthetics (@teunbrand, #2800).
 * Stricter check on `register_theme_elements(element_tree)` (@teunbrand, #6162)

R/backports.R

@@ -17,26 +17,6 @@ if (getRversion() < "3.3") {
 
 on_load(backport_unit_methods())
 
-unitType <- function(x) {
-  unit <- attr(x, "unit")
-  if (!is.null(unit)) {
-    return(unit)
-  }
-  if (is.list(x) && is.unit(x[[1]])) {
-    unit <- vapply(x, unitType, character(1))
-    return(unit)
-  } else if ("fname" %in% names(x)) {
-    return(x$fname)
-  }
-  rep("", length(x)) # we're only interested in simple units for now
-}
-
-on_load({
-  if ("unitType" %in% getNamespaceExports("grid")) {
-    unitType <- grid::unitType
-  }
-})
-
 # isFALSE() and isTRUE() are available on R (>=3.5)
 if (getRversion() < "3.5") {
   isFALSE <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) && !x

R/facet-null.R

@@ -60,8 +60,16 @@ FacetNull <- ggproto("FacetNull", Facet,
       zeroGrob(),  axis_h$bottom, zeroGrob()
     ), ncol = 3, byrow = TRUE)
     z_matrix <- matrix(c(5, 6, 4, 7, 1, 8, 3, 9, 2), ncol = 3, byrow = TRUE)
-    grob_widths <- unit.c(grobWidth(axis_v$left), unit(1, "null"), grobWidth(axis_v$right))
-    grob_heights <- unit.c(grobHeight(axis_h$top), unit(abs(aspect_ratio), "null"), grobHeight(axis_h$bottom))
+    grob_widths <- unit.c(
+      unit(width_cm(axis_v$left), "cm"),
+      unit(1, "null"),
+      unit(width_cm(axis_v$right), "cm")
+    )
+    grob_heights <- unit.c(
+      unit(height_cm(axis_h$top), "cm"),
+      unit(abs(aspect_ratio), "null"),
+      unit(height_cm(axis_h$bottom), "cm")
+    )
     grob_names <- c("spacer", "axis-l", "spacer", "axis-t", "panel", "axis-b", "spacer", "axis-r", "spacer")
 
     layout <- gtable_matrix("layout", all,

R/guides-.R

@@ -927,7 +927,7 @@ validate_guide <- function(guide) {
 
 redistribute_null_units <- function(units, spacing, margin, type = "width") {
 
-  has_null <- vapply(units, function(x) any(unitType(x) == "null"), logical(1))
+  has_null <- vapply(units, has_null_unit, logical(1))
 
   # Early exit when we needn't bother with null units
   if (!any(has_null)) {

R/save.R

@@ -34,6 +34,9 @@
 #' @param scale Multiplicative scaling factor.
 #' @param width,height Plot size in units expressed by the `units` argument.
 #'   If not supplied, uses the size of the current graphics device.
+#'   Alternatively, these can be set to `derived()` in order to use innate
+#'   plot dimensions for output. This is useful when the
+#'   `theme(panel.widths, panel.heights)` options are set to absolute units.
 #' @param units One of the following units in which the `width` and `height`
 #'   arguments are expressed: `"in"`, `"cm"`, `"mm"` or `"px"`.
 #' @param dpi Plot resolution. Also accepts a string input: "retina" (320),
@@ -99,8 +102,12 @@
 
   dpi <- parse_dpi(dpi)
   dev <- validate_device(device, filename, dpi = dpi)
-  dim <- plot_dim(c(width, height), scale = scale, units = units,
-    limitsize = limitsize, dpi = dpi)
+  dim <- plot_dim(
+    width = width, height = height,
+    scale = scale, units = units,
+    limitsize = limitsize, dpi = dpi,
+    plot = plot
+  )
 
   if (is_null(bg)) {
     bg <- calc_element("plot.background", plot_theme(plot))$fill %||% "transparent"
@@ -189,12 +196,48 @@
   }
 }
 
-plot_dim <- function(dim = c(NA, NA), scale = 1, units = "in",
-                     limitsize = TRUE, dpi = 300, call = caller_env()) {
+plot_dim <- function(width = NA, height = NA, scale = 1, units = "in",
+                     limitsize = TRUE, dpi = 300, plot = NULL, call = caller_env()) {
   units <- arg_match0(units, c("in", "cm", "mm", "px"))
-  to_inches <- function(x) x / c(`in` = 1, cm = 2.54, mm = 2.54 * 10, px = dpi)[units]
+  to_inches   <- function(x) x / c(`in` = 1, cm = 2.54, mm = 2.54 * 10, px = dpi)[units]
   from_inches <- function(x) x * c(`in` = 1, cm = 2.54, mm = 2.54 * 10, px = dpi)[units]
 
+  if (is.derived(width) || is.derived(height)) {
+    # To size from plot if width or height are derived
+    # TODO: use gtable::as.gtable when implemented
+    if (is.ggplot(plot)) {
+      plot <- ggplotGrob(plot)
+    }
+    if (!inherits(plot, "gtable")) {
+      cli::cli_abort(
+        "Cannot derive size of plot when {.arg plot} is \\
+        {.obj_type_friendly {plot}}.",
+        call = call
+      )
+    }
+    width  <- if (is.derived(width))  gtable_width(plot)  else width
+    height <- if (is.derived(height)) gtable_height(plot) else height
+  }
+
+  if (is.unit(width)) {
+    if (has_null_unit(width)) {
+      # When plot has no absolute dimensions, fall back to device size
+      width <- NA
+    } else {
+      width <- from_inches(convertWidth(width, "in", valueOnly = TRUE))
+    }
+  }
+
+  if (is.unit(height)) {
+    if (has_null_unit(height)) {
+      # When plot has no absolute dimensions, fall back to device size
+      height <- NA
+    } else {
+      height <- from_inches(convertHeight(height, "in", valueOnly = TRUE))
+    }
+  }
+
+  dim <- c(width, height)
   dim <- to_inches(dim) * scale
 
   if (anyNA(dim)) {

R/utilities-grid.R

@@ -67,3 +67,7 @@ height_cm <- function(x) {
     cli::cli_abort("Don't know how to get height of {.cls {class(x)}} object")
   }
 }
+
+has_null_unit <- function(x) {
+  any(unlist(unitType(x, recurse = TRUE), use.names = FALSE) == "null")
+}

tests/testthat/_snaps/ggsave.md

@@ -36,7 +36,7 @@
 # warned about large plot unless limitsize = FALSE
 
     Code
-      plot_dim(c(50, 50))
+      plot_dim(50, 50)
     Condition
       Error:
       ! Dimensions exceed 50 inches (`height` and `width` are specified in inches not pixels).
@@ -45,12 +45,20 @@
 ---
 
     Code
-      plot_dim(c(15000, 15000), units = "px")
+      plot_dim(15000, 15000, units = "px")
     Condition
       Error:
       ! Dimensions exceed 50 inches (`height` and `width` are specified in pixels).
       i If you're sure you want a plot that big, use `limitsize = FALSE`.
 
+# derives dimensions from plot
+
+    Code
+      plot_dim(width = derive(), height = derive(), plot = theme())
+    Condition
+      Error:
+      ! Cannot derive size of plot when `plot` is a <theme> object.
+
 # unknown device triggers error
 
     `device` must be a string, function or `NULL`, not the number 1.

tests/testthat/test-ggsave.R

@@ -112,14 +112,29 @@ test_that("uses 7x7 if no graphics device open", {
 })
 
 test_that("warned about large plot unless limitsize = FALSE", {
-  expect_snapshot(plot_dim(c(50, 50)), error = TRUE)
-  expect_equal(plot_dim(c(50, 50), limitsize = FALSE), c(50, 50))
-  expect_snapshot(plot_dim(c(15000, 15000), units = "px"), error = TRUE)
+  expect_snapshot(plot_dim(50, 50), error = TRUE)
+  expect_equal(plot_dim(50, 50, limitsize = FALSE), c(50, 50))
+  expect_snapshot(plot_dim(15000, 15000, units = "px"), error = TRUE)
 })
 
 test_that("scale multiplies height & width", {
-  expect_equal(plot_dim(c(10, 10), scale = 1), c(10, 10))
-  expect_equal(plot_dim(c(5, 5), scale = 2), c(10, 10))
+  expect_equal(plot_dim(10, 10, scale = 1), c(10, 10))
+  expect_equal(plot_dim(5, 5, scale = 2), c(10, 10))
+})
+
+test_that("derives dimensions from plot", {
+
+  plot <- gtable(widths = unit(1, "null"), heights = unit(1, "in"))
+  dim  <- suppressMessages(plot_dim(width = derive(), height = derive(), plot = plot))
+  expect_equal(unname(dim), c(7, 1))
+
+  plot <- gtable(widths = unit(12.7, "cm"), heights = unit(1, "null"))
+  dim  <- suppressMessages(plot_dim(width = derive(), height = derive(), plot = plot))
+  expect_equal(unname(dim), c(5, 7))
+
+  # Cannot derive from non-plot objects
+  expect_snapshot(plot_dim(width = derive(), height = derive(), plot = theme()), error = TRUE)
+
 })
 
 # plot_dev ---------------------------------------------------------------------