Watch potential partial matches in Geom/Stat parameters (#6428)

* use snapshot test for partially matching arguments

* protect against `arrow`/`arrow.fill` partial match

* protect against $n partial matches

* protect against $method partial match

* protect against $fun partial matches

* fix other partial matching

---------

Co-authored-by: Yunuuuu <yunyunpp96@outlook.com>

Author: teunbrand

R/facet-.R

@@ -1436,7 +1436,7 @@ map_facet_data <- function(data, layout, params) {
     return(vec_cbind(data %|W|% NULL, PANEL = integer(0)))
   }
 
-  vars <- params$facet %||% c(params$rows, params$cols)
+  vars <- params$facets %||% c(params$rows, params$cols)
 
   if (length(vars) == 0) {
     data$PANEL <- layout$PANEL
@@ -1455,7 +1455,7 @@ map_facet_data <- function(data, layout, params) {
   # Compute faceting values
   facet_vals <- eval_facets(vars, data, params$.possible_columns)
 
-  include_margins <- !isFALSE(params$margin %||% FALSE) &&
+  include_margins <- !isFALSE(params$margins %||% FALSE) &&
     nrow(facet_vals) == nrow(data) && grid_layout
   if (include_margins) {
     # Margins are computed on evaluated faceting values (#1864).

R/geom-smooth.R

@@ -164,7 +164,7 @@ geom_smooth <- function(mapping = NULL, data = NULL,
     ...
   )
   if (identical(stat, "smooth")) {
-    params$method <- method
+    params[["method"]] <- method
     params$formula <- formula
   }
 

R/labels.R

@@ -351,7 +351,7 @@ get_alt_text.gtable <- function(p, ...) {
 #'
 generate_alt_text <- function(p) {
   # Combine titles
-  if (!is.null(p$label$title %||% p$labels$subtitle)) {
+  if (!is.null(p$labels$title %||% p$labels$subtitle)) {
     title <- sub("\\.?$", "", c(p$labels$title, p$labels$subtitle))
     if (length(title) == 2) {
       title <- paste0(title[1], ": ", title[2])

R/legend-draw.R

@@ -207,11 +207,11 @@ draw_key_path <- function(data, params, size) {
       lty = data$linetype %||% 1,
       lineend = params$lineend %||% "butt"
     ),
-    arrow = params$arrow
+    arrow = params[["arrow"]]
   )
-  if (!is.null(params$arrow)) {
-    angle <- deg2rad(params$arrow$angle)
-    length <- convertUnit(params$arrow$length, "cm", valueOnly = TRUE)
+  if (!is.null(params[["arrow"]])) {
+    angle <- deg2rad(params[["arrow"]]$angle)
+    length <- convertUnit(params[["arrow"]]$length, "cm", valueOnly = TRUE)
     attr(grob, "width")  <- cos(angle) * length * 1.25
     attr(grob, "height") <- sin(angle) * length * 2
   }
@@ -228,11 +228,11 @@ draw_key_vpath <- function(data, params, size) {
       lty = data$linetype %||% 1,
       lineend = params$lineend %||% "butt"
     ),
-    arrow = params$arrow
+    arrow = params[["arrow"]]
   )
-  if (!is.null(params$arrow)) {
-    angle <- deg2rad(params$arrow$angle)
-    length <- convertUnit(params$arrow$length, "cm", valueOnly = TRUE)
+  if (!is.null(params[["arrow"]])) {
+    angle <- deg2rad(params[["arrow"]]$angle)
+    length <- convertUnit(params[["arrow"]]$length, "cm", valueOnly = TRUE)
     attr(grob, "width")  <- sin(angle) * length * 2
     attr(grob, "height") <- cos(angle) * length * 1.25
   }

R/stat-density-2d.R

@@ -80,7 +80,7 @@ StatDensity2d <- ggproto(
     df$group <- data$group[1]
     df$ndensity <- df$density / max(df$density, na.rm = TRUE)
     df$count <- nx * df$density
-    df$n <- nx
+    df[["n"]] <- nx
     df$level <- 1
     df$piece <- 1
     df

R/stat-manual.R

@@ -6,8 +6,8 @@ StatManual <- ggproto(
   "StatManual", Stat,
 
   setup_params = function(data, params) {
-    params$fun <- allow_lambda(params$fun)
-    check_function(params$fun, arg = "fun")
+    params[["fun"]] <- allow_lambda(params[["fun"]])
+    check_function(params[["fun"]], arg = "fun")
     params
   },
 

R/stat-smooth.R

@@ -7,7 +7,7 @@ StatSmooth <- ggproto(
   setup_params = function(data, params) {
     params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
     msg <- character()
-    method <- params$method
+    method <- params[["method"]]
     if (is.null(method) || identical(method, "auto")) {
       # Use loess for small datasets, gam with a cubic regression basis for
       # larger. Based on size of the _largest_ group to avoid bad memory
@@ -56,14 +56,14 @@ StatSmooth <- ggproto(
     }
     # If gam and gam's method is not specified by the user then use REML
     if (identical(method, gam_method())) {
-      params$method.args$method <- params$method.args$method %||% "REML"
+      params$method.args[["method"]] <- params$method.args[["method"]] %||% "REML"
     }
 
     if (length(msg) > 0) {
       cli::cli_inform("{.fn geom_smooth} using {msg}")
     }
 
-    params$method <- method
+    params[["method"]] <- method
     params
   },
 

R/stat-summary-bin.R

@@ -68,8 +68,8 @@ StatSummaryBin <- ggproto("StatSummaryBin", Stat,
 
   setup_params = function(data, params) {
     params$flipped_aes <- has_flipped_aes(data, params)
-    params$fun <- make_summary_fun(
-      params$fun.data, params$fun,
+    params[["fun"]] <- make_summary_fun(
+      params$fun.data, params[["fun"]],
       params$fun.max, params$fun.min,
       params$fun.args %||% list()
     )

R/stat-summary.R

@@ -185,8 +185,8 @@ StatSummary <- ggproto("StatSummary", Stat,
 
   setup_params = function(data, params) {
     params$flipped_aes <- has_flipped_aes(data, params)
-    params$fun <- make_summary_fun(
-      params$fun.data, params$fun,
+    params[["fun"]] <- make_summary_fun(
+      params$fun.data, params[["fun"]],
       params$fun.max, params$fun.min,
       params$fun.args %||% list()
     )

R/stat-ydensity.R

@@ -102,23 +102,24 @@ StatYdensity <- ggproto(
       trim = trim, na.rm = na.rm, drop = drop, bounds = bounds,
       quantiles = quantiles
     )
-    if (!drop && any(data$n < 2)) {
+    if (!drop && any(data[["n"]] < 2)) {
       cli::cli_warn(
         "Cannot compute density for groups with fewer than two datapoints."
       )
     }
 
     # choose how violins are scaled relative to each other
-    data$violinwidth <- switch(scale,
-                               # area : keep the original densities but scale them to a max width of 1
-                               #        for plotting purposes only
-                               area = data$density / max(data$density, na.rm = TRUE),
-                               # count: use the original densities scaled to a maximum of 1 (as above)
-                               #        and then scale them according to the number of observations
-                               count = data$density / max(data$density, na.rm = TRUE) *
-                                 data$n / max(data$n),
-                               # width: constant width (density scaled to a maximum of 1)
-                               width = data$scaled
+    data$violinwidth <- switch(
+      scale,
+      # area : keep the original densities but scale them to a max width of 1
+      #        for plotting purposes only
+      area = data$density / max(data$density, na.rm = TRUE),
+      # count: use the original densities scaled to a maximum of 1 (as above)
+      #        and then scale them according to the number of observations
+      count = data$density / max(data$density, na.rm = TRUE) *
+        data[["n"]] / max(data[["n"]]),
+      # width: constant width (density scaled to a maximum of 1)
+      width = data$scaled
     )
     data$flipped_aes <- flipped_aes
     flip_data(data, flipped_aes)

R/theme-elements.R

@@ -389,10 +389,10 @@ element_grob.element_line <- function(element, x = 0:1, y = 0:1,
     linewidth <- size
   }
 
-  arrow <- if (is.logical(element$arrow) && !element$arrow) {
+  arrow <- if (is.logical(element[["arrow"]]) && !element[["arrow"]]) {
     NULL
   } else {
-    element$arrow
+    element[["arrow"]]
   }
   if (is.null(arrow)) {
     arrow.fill <- colour

tests/testthat/_snaps/function-args.md

@@ -0,0 +1,31 @@
+# GeomXxx$parameters() does not contain partial matches
+
+    Code
+      problems
+    Output
+       [1] "GeomBoxplot  : `notch` with `notchwidth`"
+       [2] "GeomContour  : `arrow` with `arrow.fill`"
+       [3] "GeomCurve    : `arrow` with `arrow.fill`"
+       [4] "GeomDensity2d: `arrow` with `arrow.fill`"
+       [5] "GeomFunction : `arrow` with `arrow.fill`"
+       [6] "GeomLine     : `arrow` with `arrow.fill`"
+       [7] "GeomPath     : `arrow` with `arrow.fill`"
+       [8] "GeomQuantile : `arrow` with `arrow.fill`"
+       [9] "GeomSegment  : `arrow` with `arrow.fill`"
+      [10] "GeomSf       : `arrow` with `arrow.fill`"
+      [11] "GeomSpoke    : `arrow` with `arrow.fill`"
+      [12] "GeomStep     : `arrow` with `arrow.fill`"
+
+# StatXxx$parameters() does not contain partial matches
+
+    Code
+      problems
+    Output
+      [1] "StatDensity        : `n` with `na.rm`"                             
+      [2] "StatDensity2d      : `na.rm` with `n`"                             
+      [3] "StatDensity2dFilled: `na.rm` with `n`"                             
+      [4] "StatQuantile       : `method` with `method.args`"                  
+      [5] "StatSmooth         : `method` with `method.args`, `n` with `na.rm`"
+      [6] "StatSummary2d      : `fun` with `fun.args`"                        
+      [7] "StatSummaryHex     : `fun` with `fun.args`"                        
+

tests/testthat/test-function-args.R

@@ -4,6 +4,23 @@ filter_args <- function(x) {
   x[all_names]
 }
 
+find_partial_match_pairs <- function(args) {
+  if (length(args) < 2) {
+    return(NULL)
+  }
+  combinations <- combn(args, 2L)
+  contains <- startsWith(combinations[1, ], combinations[2, ]) |
+    startsWith(combinations[2, ], combinations[1, ])
+
+  if (!any(contains)) {
+    return(NULL)
+  }
+
+  problem <- combinations[, contains, drop = FALSE]
+  paste0("`", problem[1, ], "` with `", problem[2, ], "`")
+}
+
+
 test_that("geom_xxx and GeomXxx$draw arg defaults match", {
   ggplot2_ns <- asNamespace("ggplot2")
   objs <- ls(ggplot2_ns)
@@ -73,3 +90,53 @@ test_that("stat_xxx and StatXxx$compute_panel arg defaults match", {
     )
   })
 })
+
+# If the following tests fail, you may have introduced a potential partial match
+# in argument names. The code should be double checked that is doesn't
+# accidentally use `list$arg` when `list$arg_name` also exists. If that doesn't
+# occur, the snapshot can be updated.
+
+test_that("GeomXxx$parameters() does not contain partial matches", {
+  ggplot2_ns <- asNamespace("ggplot2")
+  objs <- ls(ggplot2_ns)
+  geom_class_names <- grep("^Geom", objs, value = TRUE)
+  geom_class_names <- setdiff(geom_class_names, c("Geom"))
+
+  problems <- list()
+
+  for (geom_class_name in geom_class_names) {
+    geom_obj <- ggplot2_ns[[geom_class_name]]
+    params <- geom_obj$parameters()
+    issues <- find_partial_match_pairs(params)
+    if (length(issues) == 0) {
+      next
+    }
+    problems[[geom_class_name]] <- issues
+  }
+
+  problems <- vapply(problems, paste0, character(1), collapse = ", ")
+  problems <- paste0(format(names(problems)), ": ", problems)
+  expect_snapshot(problems)
+})
+
+test_that("StatXxx$parameters() does not contain partial matches", {
+  ggplot2_ns <- asNamespace("ggplot2")
+  objs <- ls(ggplot2_ns)
+  stat_class_names <- grep("^Stat", objs, value = TRUE)
+  stat_class_names <- setdiff(stat_class_names, c("Stat"))
+
+  problems <- list()
+
+  for (stat_class_name in stat_class_names) {
+    stat_obj <- ggplot2_ns[[stat_class_name]]
+    params <- stat_obj$parameters()
+    issues <- find_partial_match_pairs(params)
+    if (length(issues) == 0) {
+      next
+    }
+    problems[[stat_class_name]] <- issues
+  }
+  problems <- vapply(problems, paste0, character(1), collapse = ", ")
+  problems <- paste0(format(names(problems)), ": ", problems)
+  expect_snapshot(problems)
+})

tests/testthat/test-legend-draw.R

@@ -36,7 +36,7 @@ test_that("all keys can be drawn without 'params'", {
   expect_in(nse, names(keys))
 
   # Add title to every key
-  template <- gtable(width = unit(size, "mm"), heights = unit(c(1, size), c("lines", "mm")))
+  template <- gtable(widths = unit(size, "mm"), heights = unit(c(1, size), c("lines", "mm")))
   keys <- Map(
     function(key, name) {
       text <- textGrob(name, gp = gpar(fontsize = 8))