diff --git a/R/facet-.R b/R/facet-.R index 51a6ad5b2d..63f99f1b51 100644 --- a/R/facet-.R +++ b/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). diff --git a/R/geom-smooth.R b/R/geom-smooth.R index 1f3ee3bc11..f1893a15dc 100644 --- a/R/geom-smooth.R +++ b/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 } diff --git a/R/labels.R b/R/labels.R index 17374aafbd..713d85470a 100644 --- a/R/labels.R +++ b/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]) diff --git a/R/legend-draw.R b/R/legend-draw.R index 04276dd471..25aedae0f7 100644 --- a/R/legend-draw.R +++ b/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 } diff --git a/R/stat-density-2d.R b/R/stat-density-2d.R index 2db6d37f05..cc9a6e20bb 100644 --- a/R/stat-density-2d.R +++ b/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 diff --git a/R/stat-manual.R b/R/stat-manual.R index c3eb9503df..5269c8d6c9 100644 --- a/R/stat-manual.R +++ b/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 }, diff --git a/R/stat-smooth.R b/R/stat-smooth.R index 3b2d262493..4b3499217e 100644 --- a/R/stat-smooth.R +++ b/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 }, diff --git a/R/stat-summary-bin.R b/R/stat-summary-bin.R index e55fcedfb3..a8449950c9 100644 --- a/R/stat-summary-bin.R +++ b/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() ) diff --git a/R/stat-summary.R b/R/stat-summary.R index 02c1b885dc..f8b028abcd 100644 --- a/R/stat-summary.R +++ b/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() ) diff --git a/R/stat-ydensity.R b/R/stat-ydensity.R index 22cc4a591a..e568196743 100644 --- a/R/stat-ydensity.R +++ b/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) diff --git a/R/theme-elements.R b/R/theme-elements.R index 3d367c6da7..887168f045 100644 --- a/R/theme-elements.R +++ b/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 diff --git a/tests/testthat/_snaps/function-args.md b/tests/testthat/_snaps/function-args.md new file mode 100644 index 0000000000..32101d9cb9 --- /dev/null +++ b/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`" + diff --git a/tests/testthat/test-function-args.R b/tests/testthat/test-function-args.R index cb4586c5d7..c5e4e56907 100644 --- a/tests/testthat/test-function-args.R +++ b/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) +}) diff --git a/tests/testthat/test-legend-draw.R b/tests/testthat/test-legend-draw.R index 5f4cc01032..b0c0505b2a 100644 --- a/tests/testthat/test-legend-draw.R +++ b/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))