From 20fa50f80612fdd28dc71e28fdab281e68a83b1f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 11:43:12 +0200 Subject: [PATCH 01/44] replace single use internal functions --- R/bin.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/bin.R b/R/bin.R index 856568f08c..bd98cf6f05 100644 --- a/R/bin.R +++ b/R/bin.R @@ -25,8 +25,6 @@ bins <- function(breaks, closed = "right", ) } -is_bins <- function(x) inherits(x, "ggplot2_bins") - #' @export print.ggplot2_bins <- function(x, ...) { n <- length(x$breaks) @@ -133,7 +131,7 @@ bin_breaks_bins <- function(x_range, bins = 30, center = NULL, # Compute bins ------------------------------------------------------------ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) { - check_object(bins, is_bins, "a {.cls ggplot2_bins} object") + check_inherits(bins, "ggplot2_bins", "a {.cls ggplot2_bins} object") if (all(is.na(x))) { return(bin_out(length(x), NA, NA, xmin = NA, xmax = NA)) From 0bfbcc39997f1aaf4b4c9033a85906433c2144b1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 12:31:00 +0200 Subject: [PATCH 02/44] move helper to location where it is used --- R/stat-summary.R | 10 ++++++++++ R/utilities.R | 10 ---------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/R/stat-summary.R b/R/stat-summary.R index ddcb7b5ae3..48b9693b9f 100644 --- a/R/stat-summary.R +++ b/R/stat-summary.R @@ -218,6 +218,16 @@ summarise_by_x <- function(data, summary, ...) { merge(summary, unique, by = c("x", "group"), sort = FALSE) } +# Return unique columns +# This is used for figuring out which columns are constant within a group +# +# @keyword internal +uniquecols <- function(df) { + df <- df[1, sapply(df, is_unique), drop = FALSE] + rownames(df) <- seq_len(nrow(df)) + df +} + #' A selection of summary functions from Hmisc #' #' @description diff --git a/R/utilities.R b/R/utilities.R index a3357e6119..d78b1294ee 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -84,16 +84,6 @@ clist <- function(l) { paste(paste(names(l), l, sep = " = ", collapse = ", "), sep = "") } -# Return unique columns -# This is used for figuring out which columns are constant within a group -# -# @keyword internal -uniquecols <- function(df) { - df <- df[1, sapply(df, is_unique), drop = FALSE] - rownames(df) <- seq_len(nrow(df)) - df -} - #' Convenience function to remove missing values from a data.frame #' #' Remove all non-complete rows, with a warning if `na.rm = FALSE`. From 79866e8044475f72f682df5f203c6cdf3e914290 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 12:36:31 +0200 Subject: [PATCH 03/44] remove orphan functions --- R/geom-hex.R | 31 ------------------------------- R/guides-.R | 13 ------------- R/labeller.R | 8 -------- R/layer.R | 2 -- R/performance.R | 2 -- R/quick-plot.R | 5 ----- R/scale-view.R | 17 ----------------- R/utilities.R | 23 ----------------------- 8 files changed, 101 deletions(-) diff --git a/R/geom-hex.R b/R/geom-hex.R index 8573d6d8ba..74e853587a 100644 --- a/R/geom-hex.R +++ b/R/geom-hex.R @@ -117,34 +117,3 @@ GeomHex <- ggproto("GeomHex", Geom, rename_size = TRUE ) - - -# Draw hexagon grob -# Modified from code by Nicholas Lewin-Koh and Martin Maechler -# -# @param x positions of hex centres -# @param y positions -# @param size vector of hex sizes -# @param gp graphical parameters -# @keyword internal -# -# THIS IS NO LONGER USED BUT LEFT IF CODE SOMEWHERE ELSE RELIES ON IT -hexGrob <- function(x, y, size = rep(1, length(x)), gp = gpar()) { - if (length(y) != length(x)) { - cli::cli_abort("{.arg x} and {.arg y} must have the same length") - } - - dx <- resolution(x, FALSE) - dy <- resolution(y, FALSE) / sqrt(3) / 2 * 1.15 - - hexC <- hexbin::hexcoords(dx, dy, n = 1) - - n <- length(x) - - polygonGrob( - x = rep.int(hexC$x, n) * rep(size, each = 6) + rep(x, each = 6), - y = rep.int(hexC$y, n) * rep(size, each = 6) + rep(y, each = 6), - default.units = "native", - id.lengths = rep(6, n), gp = gp - ) -} diff --git a/R/guides-.R b/R/guides-.R index fc9d6e2b3c..34572699ca 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -870,19 +870,6 @@ include_layer_in_guide <- function(layer, matched) { isTRUE(layer$show.legend) } -# Simplify legend position to one of horizontal/vertical/inside -legend_position <- function(position) { - if (length(position) == 1) { - if (position %in% c("top", "bottom")) { - "horizontal" - } else { - "vertical" - } - } else { - "inside" - } -} - # resolve the guide from the scale and guides resolve_guide <- function(aesthetic, scale, guides, default = "none", null = "none") { guides[[aesthetic]] %||% scale$guide %|W|% default %||% null diff --git a/R/labeller.R b/R/labeller.R index 442f05d496..db5f5fda17 100644 --- a/R/labeller.R +++ b/R/labeller.R @@ -173,14 +173,6 @@ label_parsed <- function(labels, multi_line = TRUE) { } class(label_parsed) <- c("function", "labeller") -find_names <- function(expr) { - if (is.call(expr)) { - unlist(lapply(expr[-1], find_names)) - } else if (is.name(expr)) { - as.character(expr) - } -} - #' Label with mathematical expressions #' #' `label_bquote()` offers a flexible way of labelling diff --git a/R/layer.R b/R/layer.R index 8b4621bde2..8fa9e4740c 100644 --- a/R/layer.R +++ b/R/layer.R @@ -463,8 +463,6 @@ Layer <- ggproto("Layer", NULL, } ) -is.layer <- function(x) inherits(x, "Layer") - check_subclass <- function(x, subclass, argname = to_lower_ascii(subclass), env = parent.frame(), diff --git a/R/performance.R b/R/performance.R index b26b1a7072..f80c997882 100644 --- a/R/performance.R +++ b/R/performance.R @@ -10,8 +10,6 @@ mat_2_df <- function(x, col_names = colnames(x)) { data_frame0(!!!cols, .size = nrow(x)) } -df_col <- function(x, name) .subset2(x, name) - df_rows <- function(x, i) { cols <- lapply(x, `[`, i = i) data_frame0(!!!cols, .size = length(i)) diff --git a/R/quick-plot.R b/R/quick-plot.R index 0ef5852cfb..38cfd895fc 100644 --- a/R/quick-plot.R +++ b/R/quick-plot.R @@ -173,8 +173,3 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, #' @export #' @rdname qplot quickplot <- qplot - -is.constant <- function(x) { - is_I_call <- function(x) is.call(x) && identical(x[[1]], quote(I)) - vapply(x, is_I_call, logical(1)) -} diff --git a/R/scale-view.R b/R/scale-view.R index de78ebffb6..3cf18147ec 100644 --- a/R/scale-view.R +++ b/R/scale-view.R @@ -90,23 +90,6 @@ view_scale_secondary <- function(scale, limits = scale$get_limits(), } } -view_scale_empty <- function() { - ggproto(NULL, ViewScale, - is_empty = function() TRUE, - is_discrete = function() NA, - dimension = function() c(0, 1), - get_limits = function() c(0, 1), - get_breaks = function() NULL, - get_breaks_minor = function() NULL, - get_labels = function(breaks = NULL) breaks, - rescale = function(x) cli::cli_abort("Not implemented."), - map = function(x) cli::cli_abort("Not implemented."), - make_title = function(title) title, - break_positions = function() NULL, - break_positions_minor = function() NULL - ) -} - ViewScale <- ggproto("ViewScale", NULL, # map, rescale, and make_title need a reference # to the original scale diff --git a/R/utilities.R b/R/utilities.R index d78b1294ee..b1ae8342c3 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -190,12 +190,6 @@ waiver <- function() structure(list(), class = "waiver") is.waive <- function(x) inherits(x, "waiver") - -rescale01 <- function(x) { - rng <- range(x, na.rm = TRUE) - (x - rng[1]) / (rng[2] - rng[1]) -} - pal_binned <- function(palette) { function(x) { palette(length(x)) @@ -310,15 +304,6 @@ compact <- function(x) { is.formula <- function(x) inherits(x, "formula") -deparse2 <- function(x) { - y <- deparse(x, backtick = TRUE) - if (length(y) == 1) { - y - } else { - paste0(y[[1]], "...") - } -} - dispatch_args <- function(f, ...) { args <- list(...) formals <- formals(f) @@ -353,14 +338,6 @@ with_seed_null <- function(seed, code) { } } -seq_asc <- function(to, from) { - if (to > from) { - integer() - } else { - to:from - } -} - # Needed to trigger package loading #' @importFrom tibble tibble NULL From a5a1ce51c7275c4dd526a3cc7243375230482a0e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 15:41:32 +0200 Subject: [PATCH 04/44] replace and remove redundant `adjust_breaks()` function --- R/stat-bin2d.R | 15 ++------------- tests/testthat/test-stat-bin2d.R | 4 ++-- 2 files changed, 4 insertions(+), 15 deletions(-) diff --git a/R/stat-bin2d.R b/R/stat-bin2d.R index 69f57ebee3..bdb69db23a 100644 --- a/R/stat-bin2d.R +++ b/R/stat-bin2d.R @@ -104,7 +104,7 @@ dual_param <- function(x, default = list(x = NULL, y = NULL)) { } bin2d_breaks <- function(scale, breaks = NULL, origin = NULL, binwidth = NULL, - bins = 30, right = TRUE) { + bins = 30, closed = "right") { # Bins for categorical data should take the width of one level, # and should show up centered over their tick marks. All other parameters # are ignored. @@ -138,18 +138,7 @@ bin2d_breaks <- function(scale, breaks = NULL, origin = NULL, binwidth = NULL, if (length(breaks) > 1 && breaks[length(breaks) - 1] >= range[2]) { breaks <- breaks[-length(breaks)] } - - adjust_breaks(breaks, right) -} - -adjust_breaks <- function(x, right = TRUE) { - diddle <- 1e-07 * stats::median(diff(x)) - if (right) { - fuzz <- c(-diddle, rep.int(diddle, length(x) - 1)) - } else { - fuzz <- c(rep.int(-diddle, length(x) - 1), diddle) - } - sort(x) + fuzz + bins(breaks, closed)$fuzzy } bin_loc <- function(x, id) { diff --git a/tests/testthat/test-stat-bin2d.R b/tests/testthat/test-stat-bin2d.R index 31e9c819c6..54d95679c9 100644 --- a/tests/testthat/test-stat-bin2d.R +++ b/tests/testthat/test-stat-bin2d.R @@ -32,8 +32,8 @@ test_that("breaks override binwidth", { ) out <- get_layer_data(base) - expect_equal(out$xbin, cut(df$x, adjust_breaks(integer_breaks), include.lowest = TRUE, labels = FALSE)) - expect_equal(out$ybin, cut(df$y, adjust_breaks(half_breaks), include.lowest = TRUE, labels = FALSE)) + expect_equal(out$xbin, cut(df$x, bins(integer_breaks)$fuzzy, include.lowest = TRUE, labels = FALSE)) + expect_equal(out$ybin, cut(df$y, bins(half_breaks)$fuzzy, include.lowest = TRUE, labels = FALSE)) }) test_that("breaks are transformed by the scale", { From c4c61de5831f75345c2a822fb7798204abff0ddb Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 15:51:04 +0200 Subject: [PATCH 05/44] replace `df_rows()` with `vec_slice()` --- R/compat-plyr.R | 2 +- R/performance.R | 5 ----- 2 files changed, 1 insertion(+), 6 deletions(-) diff --git a/R/compat-plyr.R b/R/compat-plyr.R index 95c317a02c..fc62b9e6fb 100644 --- a/R/compat-plyr.R +++ b/R/compat-plyr.R @@ -293,7 +293,7 @@ dapply <- function(df, by, fun, ..., drop = TRUE) { ids <- id(grouping_cols, drop = drop) group_rows <- split_with_index(seq_len(nrow(df)), ids) result <- lapply(seq_along(group_rows), function(i) { - cur_data <- df_rows(df, group_rows[[i]]) + cur_data <- vec_slice(df, group_rows[[i]]) apply_fun(cur_data) }) vec_rbind0(!!!result) diff --git a/R/performance.R b/R/performance.R index f80c997882..7676ed31d6 100644 --- a/R/performance.R +++ b/R/performance.R @@ -10,11 +10,6 @@ mat_2_df <- function(x, col_names = colnames(x)) { data_frame0(!!!cols, .size = nrow(x)) } -df_rows <- function(x, i) { - cols <- lapply(x, `[`, i = i) - data_frame0(!!!cols, .size = length(i)) -} - # More performant modifyList without recursion modify_list <- function(old, new) { for (i in names(new)) old[[i]] <- new[[i]] From 2ce92fbf299a38452bd52b7d12f4b3d0dae307e2 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 15:52:39 +0200 Subject: [PATCH 06/44] inline `f_as_facets_list()` --- R/facet-.R | 26 ++++++++++---------------- 1 file changed, 10 insertions(+), 16 deletions(-) diff --git a/R/facet-.R b/R/facet-.R index 96c96dc6fd..5c5d882cd5 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -415,7 +415,14 @@ as_facets_list <- function(x) { # distinct facet dimensions and `+` defines multiple facet variables # inside each dimension. if (is_formula(x)) { - return(f_as_facets_list(x)) + if (length(x) == 2) { + rows <- f_as_facets(NULL) + cols <- f_as_facets(x) + } else { + rows <- f_as_facets(x[-3]) + cols <- f_as_facets(x[-2]) + } + return(list(rows, cols)) } # For backward-compatibility with facet_wrap() @@ -498,16 +505,6 @@ simplify <- function(x) { } } -f_as_facets_list <- function(f) { - lhs <- function(x) if (length(x) == 2) NULL else x[-3] - rhs <- function(x) if (length(x) == 2) x else x[-2] - - rows <- f_as_facets(lhs(f)) - cols <- f_as_facets(rhs(f)) - - list(rows, cols) -} - as_facets <- function(x) { if (is_facets(x)) { return(x) @@ -532,14 +529,11 @@ f_as_facets <- function(f) { # as.quoted() handles `+` specifications vars <- as.quoted(f) - # `.` in formulas is ignored - vars <- discard_dots(vars) + # `.` in formulas is discarded + vars <- vars[!vapply(vars, identical, logical(1), as.name("."))] as_quosures(vars, env, named = TRUE) } -discard_dots <- function(x) { - x[!vapply(x, identical, logical(1), as.name("."))] -} is_facets <- function(x) { if (!is.list(x)) { From 15241a67454874106139bbdf095623a78e0cc4ea Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:12:10 +0200 Subject: [PATCH 07/44] inline `find_origin()` --- R/utilities-break.R | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/R/utilities-break.R b/R/utilities-break.R index 1bcce62ec3..b503170374 100644 --- a/R/utilities-break.R +++ b/R/utilities-break.R @@ -76,8 +76,8 @@ cut_width <- function(x, width, center = NULL, boundary = NULL, closed = "right" } boundary <- as.numeric(boundary) - # Determine bins - min_x <- find_origin(x_range, width, boundary) + # Determine bins, find origin + min_x <- boundary + floor((x_range[1] - boundary) / width) * width # Small correction factor so that we don't get an extra bin when, for # example, origin = 0, max(x) = 20, width = 10. max_x <- max(x, na.rm = TRUE) + (1 - 1e-08) * width @@ -86,12 +86,6 @@ cut_width <- function(x, width, center = NULL, boundary = NULL, closed = "right" cut(x, breaks, include.lowest = TRUE, right = (closed == "right"), ...) } -# Find the left side of left-most bin -find_origin <- function(x_range, width, boundary) { - shift <- floor((x_range[1] - boundary) / width) - boundary + shift * width -} - breaks <- function(x, equal, nbins = NULL, binwidth = NULL) { equal <- arg_match0(equal, c("numbers", "width")) if ((!is.null(nbins) && !is.null(binwidth)) || (is.null(nbins) && is.null(binwidth))) { From 2e9b8c24beba8d80c0ee3ebab1589e24ac766ea7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:23:13 +0200 Subject: [PATCH 08/44] inline `firstUpper()` --- R/utilities.R | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index b1ae8342c3..bf9092e449 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -257,7 +257,9 @@ toupper <- function(x) { # Convert a snake_case string to camelCase camelize <- function(x, first = FALSE) { x <- gsub("_(.)", "\\U\\1", x, perl = TRUE) - if (first) x <- firstUpper(x) + if (first) { + x <- paste0(to_upper_ascii(substring(x, 1, 1)), substring(x, 2)) + } x } @@ -268,10 +270,6 @@ snakeize <- function(x) { to_lower_ascii(x) } -firstUpper <- function(s) { - paste0(to_upper_ascii(substring(s, 1, 1)), substring(s, 2)) -} - snake_class <- function(x) { snakeize(class(x)[1]) } From 0cca7a3cee4d777caaf8fd503d7461a809c3be5b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:25:34 +0200 Subject: [PATCH 09/44] replace `has_name()` --- R/limits.R | 2 +- R/utilities.R | 9 --------- 2 files changed, 1 insertion(+), 10 deletions(-) diff --git a/R/limits.R b/R/limits.R index 26528ee7ff..5aba62ef58 100644 --- a/R/limits.R +++ b/R/limits.R @@ -80,7 +80,7 @@ lims <- function(...) { args <- list2(...) - if (!all(has_name(args))) { + if (!is_named2(args)) { cli::cli_abort("All arguments must be named.") } env <- current_env() diff --git a/R/utilities.R b/R/utilities.R index bf9092e449..d6496d71ba 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -231,15 +231,6 @@ gg_dep <- function(version, msg) { invisible() } -has_name <- function(x) { - nms <- names(x) - if (is.null(nms)) { - return(rep(FALSE, length(x))) - } - - !is.na(nms) & nms != "" -} - # Use chartr() for safety since toupper() fails to convert i to I in Turkish locale lower_ascii <- "abcdefghijklmnopqrstuvwxyz" upper_ascii <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ" From 5f4a4b92de3d85d26071e6ee7acf40078920e23d Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:33:28 +0200 Subject: [PATCH 10/44] replace `interleave()` with `vec_interleave()` --- NAMESPACE | 2 -- R/geom-violin.R | 2 +- R/utilities-matrix.R | 13 ------------- tests/testthat/_snaps/utilities.md | 4 ---- tests/testthat/test-utilities.R | 4 ---- 5 files changed, 1 insertion(+), 24 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 6a57c5132d..b0b8320c44 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -84,8 +84,6 @@ S3method(guide_train,default) S3method(guide_transform,default) S3method(heightDetails,titleGrob) S3method(heightDetails,zeroGrob) -S3method(interleave,default) -S3method(interleave,unit) S3method(limits,Date) S3method(limits,POSIXct) S3method(limits,POSIXlt) diff --git a/R/geom-violin.R b/R/geom-violin.R index 0ac6cd29df..80897a0de5 100644 --- a/R/geom-violin.R +++ b/R/geom-violin.R @@ -217,7 +217,7 @@ create_quantile_segment_frame <- function(data, draw_quantiles) { # We have two rows per segment drawn. Each segment gets its own group. data_frame0( - x = interleave(violin.xminvs, violin.xmaxvs), + x = vec_interleave(violin.xminvs, violin.xmaxvs), y = rep(ys, each = 2), group = rep(ys, each = 2) ) diff --git a/R/utilities-matrix.R b/R/utilities-matrix.R index dd35e082ba..3a02725087 100644 --- a/R/utilities-matrix.R +++ b/R/utilities-matrix.R @@ -10,16 +10,3 @@ cunion <- function(a, b) { cbind(a, b[setdiff(names(b), names(a))]) } - -# Interleave (or zip) multiple units into one vector -interleave <- function(...) UseMethod("interleave") -#' @export -interleave.unit <- function(...) { - units <- lapply(list(...), as.list) - interleaved_list <- interleave.default(!!!units) - inject(unit.c(!!!interleaved_list)) -} -#' @export -interleave.default <- function(...) { - vec_interleave(...) -} diff --git a/tests/testthat/_snaps/utilities.md b/tests/testthat/_snaps/utilities.md index 0101c1edd1..6b2e0e8e8c 100644 --- a/tests/testthat/_snaps/utilities.md +++ b/tests/testthat/_snaps/utilities.md @@ -50,7 +50,3 @@ Only one of `boundary` and `center` may be specified. -# interleave() checks the vector lengths - - Can't recycle `..1` (size 4) to match `..2` (size 0). - diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index 4537b03210..4e490a7ec2 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -132,10 +132,6 @@ test_that("cut_*() checks its input and output", { expect_snapshot_error(cut_width(1:10, 1, center = 0, boundary = 0.5)) }) -test_that("interleave() checks the vector lengths", { - expect_snapshot_error(interleave(1:4, numeric())) -}) - test_that("vec_rbind0 can combined ordered factors", { withr::local_options(lifecycle_verbosity = "warning") From 79fa0b10c66f528463362f252b675b9f4217f651 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:40:34 +0200 Subject: [PATCH 11/44] remove `cunion()` --- R/coord-map.R | 2 +- R/geom-.R | 2 +- R/layer.R | 2 +- R/utilities-matrix.R | 12 ------------ 4 files changed, 3 insertions(+), 15 deletions(-) delete mode 100644 R/utilities-matrix.R diff --git a/R/coord-map.R b/R/coord-map.R index d300d33dce..3ba9260206 100644 --- a/R/coord-map.R +++ b/R/coord-map.R @@ -157,7 +157,7 @@ CoordMap <- ggproto("CoordMap", Coord, transform = function(self, data, panel_params) { trans <- mproject(self, data$x, data$y, panel_params$orientation) - out <- cunion(trans[c("x", "y")], data) + out <- data_frame0(!!!defaults(trans[c("x", "y")], data)) out$x <- rescale(out$x, 0:1, panel_params$x.proj) out$y <- rescale(out$y, 0:1, panel_params$y.proj) diff --git a/R/geom-.R b/R/geom-.R index c3da9be244..3a0a1b8e30 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -172,7 +172,7 @@ Geom <- ggproto("Geom", modified_aes <- data_frame0(!!!compact(modified_aes)) - data <- cunion(modified_aes, data) + data <- data_frame0(!!!defaults(modified_aes, data)) } # Override mappings with params diff --git a/R/layer.R b/R/layer.R index 8fa9e4740c..2b712b21fa 100644 --- a/R/layer.R +++ b/R/layer.R @@ -414,7 +414,7 @@ Layer <- ggproto("Layer", NULL, } stat_data <- cleanup_mismatched_data(stat_data, nrow(data), "after_stat") - cunion(stat_data, data) + data_frame0(!!!defaults(stat_data, data)) }, compute_geom_1 = function(self, data) { diff --git a/R/utilities-matrix.R b/R/utilities-matrix.R deleted file mode 100644 index 3a02725087..0000000000 --- a/R/utilities-matrix.R +++ /dev/null @@ -1,12 +0,0 @@ -# Col union -# Form the union of columns in a and b. If there are columns of the same name in both a and b, take the column from a. -# -# @param data frame a -# @param data frame b -# @keyword internal -cunion <- function(a, b) { - if (length(a) == 0) return(b) - if (length(b) == 0) return(a) - - cbind(a, b[setdiff(names(b), names(a))]) -} From abc62dd783876f6c308cd766756690754d3f1875 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:46:00 +0200 Subject: [PATCH 12/44] inline `is_dotted_var()` --- R/aes-evaluation.R | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/R/aes-evaluation.R b/R/aes-evaluation.R index 4c682e3f63..f9925caa80 100644 --- a/R/aes-evaluation.R +++ b/R/aes-evaluation.R @@ -207,10 +207,6 @@ stage_scaled <- function(start = NULL, after_stat = NULL, after_scale = NULL) { # Regex to determine if an identifier refers to a calculated aesthetic match_calculated_aes <- "^\\.\\.([a-zA-Z._]+)\\.\\.$" -is_dotted_var <- function(x) { - grepl(match_calculated_aes, x) -} - # Determine if aesthetic is calculated is_calculated_aes <- function(aesthetics, warn = FALSE) { vapply(aesthetics, is_calculated, warn = warn, logical(1), USE.NAMES = FALSE) @@ -229,7 +225,8 @@ is_calculated <- function(x, warn = FALSE) { if (is.null(x) || is.atomic(x)) { FALSE } else if (is.symbol(x)) { - res <- is_dotted_var(as.character(x)) + # Test if x is a dotted variable + res <- grepl(match_calculated_aes, as.character(x)) if (res && warn) { what <- I(paste0("The dot-dot notation (`", x, "`)")) var <- gsub(match_calculated_aes, "\\1", as.character(x)) From 4a3ffffb55b55965de525d06088b7a9eb20b5313 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:46:18 +0200 Subject: [PATCH 13/44] inline `is_facets()` --- R/facet-.R | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/R/facet-.R b/R/facet-.R index 5c5d882cd5..c9dc0f5d7a 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -506,7 +506,9 @@ simplify <- function(x) { } as_facets <- function(x) { - if (is_facets(x)) { + is_facets <- is.list(x) && length(x) > 0 && + all(vapply(x, is_quosure, logical(1))) + if (is_facets) { return(x) } @@ -535,17 +537,6 @@ f_as_facets <- function(f) { as_quosures(vars, env, named = TRUE) } -is_facets <- function(x) { - if (!is.list(x)) { - return(FALSE) - } - if (!length(x)) { - return(FALSE) - } - all(vapply(x, is_quosure, logical(1))) -} - - # When evaluating variables in a facet specification, we evaluate bare # variables and expressions slightly differently. Bare variables should # always succeed, even if the variable doesn't exist in the data frame: From 9976913a361d4e3a040e5c09131d60e8973c2a93 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:47:02 +0200 Subject: [PATCH 14/44] inline `is_labeller()` --- R/labeller.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/labeller.R b/R/labeller.R index db5f5fda17..06ca533e69 100644 --- a/R/labeller.R +++ b/R/labeller.R @@ -229,8 +229,6 @@ label_wrap_gen <- function(width = 25, multi_line = TRUE) { structure(fun, class = "labeller") } -is_labeller <- function(x) inherits(x, "labeller") - resolve_labeller <- function(rows, cols, labels) { if (is.null(cols) && is.null(rows)) { cli::cli_abort("Supply one of {.arg rows} or {.arg cols}.") @@ -292,7 +290,7 @@ as_labeller <- function(x, default = label_value, multi_line = TRUE) { # support it. default <- dispatch_args(default, multi_line = multi_line) - if (is_labeller(x)) { + if (inherits(x, "labeller")) { x <- dispatch_args(x, multi_line = multi_line) x(labels) } else if (is.function(x)) { From b4e0d808620d60bedd594ae3f1f9dad9e57e32d9 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:49:08 +0200 Subject: [PATCH 15/44] inline `is_missing_arg()` --- R/utilities.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index d6496d71ba..0e1ef1f292 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -301,7 +301,6 @@ dispatch_args <- function(f, ...) { f } -is_missing_arg <- function(x) identical(x, quote(expr = )) # Get all arguments in a function as a list. Will fail if an ellipsis argument # named .ignore # @param ... passed on in case enclosing function uses ellipsis in argument list @@ -310,7 +309,8 @@ find_args <- function(...) { args <- names(formals(sys.function(sys.parent(1)))) vals <- mget(args, envir = env) - vals <- vals[!vapply(vals, is_missing_arg, logical(1))] + # Remove missing arguments + vals <- vals[!vapply(vals, identical, logical(1), y = quote(expr = ))] modify_list(vals, dots_list(..., `...` = NULL, .ignore_empty = "all")) } From be4081a868504a1ba3518f8494c5c0b8ef0ac713 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:52:29 +0200 Subject: [PATCH 16/44] replace `is_npc()` (we partially backport `unitType()`) --- R/grob-dotstack.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/grob-dotstack.R b/R/grob-dotstack.R index 75ca9e81ed..d3463c18bd 100644 --- a/R/grob-dotstack.R +++ b/R/grob-dotstack.R @@ -14,15 +14,13 @@ dotstackGrob <- function( y <- unit(y, default.units) if (!is.unit(dotdia)) dotdia <- unit(dotdia, default.units) - if (!is_npc(dotdia)) + if (!unitType(dotdia) == "npc") cli::cli_warn("Unit type of dotdia should be {.val npc}") grob(x = x, y = y, stackaxis = stackaxis, dotdia = dotdia, stackposition = stackposition, stackdir = stackdir, stackratio = stackratio, name = name, gp = gp, vp = vp, cl = "dotstackGrob") } -# Only cross-version reliable way to check the unit of a unit object -is_npc <- function(x) isTRUE(grepl('^[^+^-^\\*]*[^s]npc$', as.character(x))) #' @export makeContext.dotstackGrob <- function(x) { From 70cc78b7d335d1d70e88ee8f44bf4e0eaa92ad6b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:53:41 +0200 Subject: [PATCH 17/44] inline `is_scalar_numeric()` --- R/save.R | 2 +- R/utilities.R | 2 -- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/R/save.R b/R/save.R index 2f28c49418..9d411b06c4 100644 --- a/R/save.R +++ b/R/save.R @@ -182,7 +182,7 @@ parse_dpi <- function(dpi, call = caller_env()) { print = 300, retina = 320, ) - } else if (is_scalar_numeric(dpi)) { + } else if (is_bare_numeric(dpi, n = 1L)) { dpi } else { stop_input_type(dpi, "a single number or string", call = call) diff --git a/R/utilities.R b/R/utilities.R index 0e1ef1f292..c057ae79e6 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -340,8 +340,6 @@ unique0 <- function(x, ...) if (is.null(x)) x else vec_unique(x, ...) # Code readability checking for uniqueness is_unique <- function(x) vec_unique_count(x) == 1L -is_scalar_numeric <- function(x) is_bare_numeric(x, n = 1L) - # Check inputs with tibble but allow column vectors (see #2609 and #2374) as_gg_data_frame <- function(x) { x <- lapply(x, validate_column_vec) From 997d9fe4eb4f2edd6bff32457b1db4ba37d632e1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:56:05 +0200 Subject: [PATCH 18/44] inline `is.margin()` --- R/margins.R | 3 --- R/theme.R | 2 +- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/R/margins.R b/R/margins.R index 0fee3ca0ab..128c299a2b 100644 --- a/R/margins.R +++ b/R/margins.R @@ -8,9 +8,6 @@ margin <- function(t = 0, r = 0, b = 0, l = 0, unit = "pt") { class(u) <- c("margin", class(u)) u } -is.margin <- function(x) { - inherits(x, "margin") -} #' Create a text grob with the proper location and margins #' diff --git a/R/theme.R b/R/theme.R index 7e8a794a11..3026940006 100644 --- a/R/theme.R +++ b/R/theme.R @@ -481,7 +481,7 @@ theme <- function(..., elements$panel.spacing.y <- elements$panel.margin.y elements$panel.margin.y <- NULL } - if (is.unit(elements$legend.margin) && !is.margin(elements$legend.margin)) { + if (is.unit(elements$legend.margin) && !inherits(elements$legend.margin, "margin")) { cli::cli_warn(c( "{.var legend.margin} must be specified using {.fn margin}", "i" = "For the old behavior use {.var legend.spacing}" From 1bdc20d2dc48eec0fd6d1f45b7405856273689ac Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 16:57:16 +0200 Subject: [PATCH 19/44] inline `is.sec_axis()` --- R/axis-secondary.R | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/R/axis-secondary.R b/R/axis-secondary.R index e535b1a95a..a163acfb02 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -124,10 +124,6 @@ dup_axis <- function(transform = identity, name = derive(), breaks = derive(), sec_axis(transform, trans = trans, name, breaks, labels, guide) } -is.sec_axis <- function(x) { - inherits(x, "AxisSecondary") -} - set_sec_axis <- function(sec.axis, scale) { if (!is.waive(sec.axis)) { if (scale$is_discrete()) { @@ -136,7 +132,7 @@ set_sec_axis <- function(sec.axis, scale) { } } if (is.formula(sec.axis)) sec.axis <- sec_axis(sec.axis) - if (!is.sec_axis(sec.axis)) { + if (!inherits(sec.axis, "AxisSecondary")) { cli::cli_abort("Secondary axes must be specified using {.fn sec_axis}.") } scale$secondary.axis <- sec.axis From b044fa2237a61ad8bea321fd065a79458d5afd6b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 17:00:47 +0200 Subject: [PATCH 20/44] inline `is.subclass()` --- R/theme.R | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/R/theme.R b/R/theme.R index 3026940006..98ac294d81 100644 --- a/R/theme.R +++ b/R/theme.R @@ -892,7 +892,9 @@ combine_elements <- function(e1, e2) { } # If e2 is 'richer' than e1, fill e2 with e1 parameters - if (is.subclass(e2, e1)) { + is_subclass <- !any(inherits(e2, class(e1), which = TRUE) == 0) + is_subclass <- is_subclass && length(setdiff(class(e2), class(e1)) > 0) + if (is_subclass) { new <- defaults(e1, e2) e2[names(new)] <- new return(e2) @@ -901,11 +903,6 @@ combine_elements <- function(e1, e2) { e1 } -is.subclass <- function(x, y) { - inheritance <- inherits(x, class(y), which = TRUE) - !any(inheritance == 0) && length(setdiff(class(x), class(y))) > 0 -} - #' Reports whether x is a theme object #' @param x An object to test #' @export From 490c9c3b6daadb78e98b9afdb1d7d9dab56286c7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 1 Aug 2024 17:09:35 +0200 Subject: [PATCH 21/44] inline `is_triple_bang()` --- R/aes.R | 4 +++- R/utilities.R | 18 ------------------ 2 files changed, 3 insertions(+), 19 deletions(-) diff --git a/R/aes.R b/R/aes.R index 4120657222..67f8532d3c 100644 --- a/R/aes.R +++ b/R/aes.R @@ -448,7 +448,9 @@ arg_enquos <- function(name, frame = caller_env()) { quo <- inject(enquo0(!!sym(name)), frame) expr <- quo_get_expr(quo) - if (!is_missing(expr) && is_triple_bang(expr)) { + is_triple_bang <- !is_missing(expr) && + is_bang(expr) && is_bang(expr[[2]]) && is_bang(expr[[c(2, 2)]]) + if (is_triple_bang) { # Evaluate `!!!` operand and create a list of quosures env <- quo_get_env(quo) xs <- eval_bare(expr[[2]][[2]][[2]], env) diff --git a/R/utilities.R b/R/utilities.R index c057ae79e6..a45ef753cc 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -644,24 +644,6 @@ is_bang <- function(x) { }) } -is_triple_bang <- function(x) { - if (!is_bang(x)) { - return(FALSE) - } - - x <- x[[2]] - if (!is_bang(x)) { - return(FALSE) - } - - x <- x[[2]] - if (!is_bang(x)) { - return(FALSE) - } - - TRUE -} - # Restart handler for using vec_rbind with mix of types # Ordered is coerced to factor # If a character vector is present the other is converted to character From 4ebdea3fac99955eb0fd0edb62d1d31fdd4eebbf Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 10:07:51 +0200 Subject: [PATCH 22/44] remove `justify_grobs()` --- R/margins.R | 76 -------------------------------- R/plot-build.R | 9 ++-- tests/testthat/_snaps/margins.md | 4 -- tests/testthat/test-margins.R | 3 -- 4 files changed, 4 insertions(+), 88 deletions(-) delete mode 100644 tests/testthat/_snaps/margins.md delete mode 100644 tests/testthat/test-margins.R diff --git a/R/margins.R b/R/margins.R index 128c299a2b..aa9457a85b 100644 --- a/R/margins.R +++ b/R/margins.R @@ -148,82 +148,6 @@ heightDetails.titleGrob <- function(x) { sum(x$heights) } -#' Justifies a grob within a larger drawing area -#' -#' `justify_grobs()` can be used to take one or more grobs and draw them justified inside a larger -#' drawing area, such as the cell in a gtable. It is needed to correctly place [`titleGrob`]s -#' with margins. -#' -#' @param grobs The single grob or list of grobs to justify. -#' @param x,y x and y location of the reference point relative to which justification -#' should be performed. If `NULL`, justification will be done relative to the -#' enclosing drawing area (i.e., `x = hjust` and `y = vjust`). -#' @param hjust,vjust Horizontal and vertical justification of the grob relative to `x` and `y`. -#' @param int_angle Internal angle of the grob to be justified. When justifying a text -#' grob with rotated text, this argument can be used to make `hjust` and `vjust` operate -#' relative to the direction of the text. -#' @param debug If `TRUE`, aids visual debugging by drawing a solid -#' rectangle behind the complete grob area. -#' -#' @noRd -justify_grobs <- function(grobs, x = NULL, y = NULL, hjust = 0.5, vjust = 0.5, - int_angle = 0, debug = FALSE) { - if (!inherits(grobs, "grob")) { - if (is.list(grobs)) { - return(lapply(grobs, justify_grobs, x, y, hjust, vjust, int_angle, debug)) - } - else { - stop_input_type(grobs, as_cli("an individual {.cls grob} or list of {.cls grob} objects")) - } - } - - if (inherits(grobs, "zeroGrob")) { - return(grobs) - } - - # adjust hjust and vjust according to internal angle - just <- rotate_just(int_angle, hjust, vjust) - - x <- x %||% unit(just$hjust, "npc") - y <- y %||% unit(just$vjust, "npc") - - - if (isTRUE(debug)) { - children <- gList( - rectGrob(gp = gg_par(fill = "lightcyan", col = NA)), - grobs - ) - } - else { - children = gList(grobs) - } - - - result_grob <- gTree( - children = children, - vp = viewport( - x = x, - y = y, - width = grobWidth(grobs), - height = grobHeight(grobs), - just = unlist(just) - ) - ) - - - if (isTRUE(debug)) { - #cat("x, y:", c(x, y), "\n") - #cat("E - hjust, vjust:", c(hjust, vjust), "\n") - grobTree( - result_grob, - pointsGrob(x, y, pch = 20, gp = gg_par(col = "mediumturquoise")) - ) - } else { - result_grob - } -} - - #' Rotate justification parameters counter-clockwise #' #' @param angle angle of rotation, in degrees diff --git a/R/plot-build.R b/R/plot-build.R index 2a68dd550f..cb91cb0019 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -402,11 +402,10 @@ table_add_tag <- function(table, label, theme) { x <- unit(position[1], "npc") y <- unit(position[2], "npc") } - # Do manual placement of tag - tag <- justify_grobs( - tag, x = x, y = y, - hjust = element$hjust, vjust = element$vjust, - int_angle = element$angle, debug = element$debug + # Re-render with manual positions + tag <- element_grob( + element, x = x, y = y, label = label, + margin_y = TRUE, margin_x = TRUE ) if (location == "plot") { table <- gtable_add_grob( diff --git a/tests/testthat/_snaps/margins.md b/tests/testthat/_snaps/margins.md deleted file mode 100644 index 3eefe771b7..0000000000 --- a/tests/testthat/_snaps/margins.md +++ /dev/null @@ -1,4 +0,0 @@ -# justify_grobs() checks input - - `grobs` must be an individual or list of objects, not the number 1. - diff --git a/tests/testthat/test-margins.R b/tests/testthat/test-margins.R deleted file mode 100644 index 522c457445..0000000000 --- a/tests/testthat/test-margins.R +++ /dev/null @@ -1,3 +0,0 @@ -test_that("justify_grobs() checks input", { - expect_snapshot_error(justify_grobs(1)) -}) From e0868174486efb44f08fca7bd0ff1d5e43dd1e1f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 10:14:22 +0200 Subject: [PATCH 23/44] inline `label_variable()` --- R/labeller.R | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/R/labeller.R b/R/labeller.R index 06ca533e69..da03569a00 100644 --- a/R/labeller.R +++ b/R/labeller.R @@ -111,21 +111,17 @@ label_value <- function(labels, multi_line = TRUE) { # currently needed for Roxygen class(label_value) <- c("function", "labeller") -# Helper for label_both -label_variable <- function(labels, multi_line = TRUE) { - if (multi_line) { - row <- as.list(names(labels)) - } else { - row <- list(paste(names(labels), collapse = ", ")) - } - lapply(row, rep, nrow(labels) %||% length(labels[[1]])) -} - #' @rdname labellers #' @export label_both <- function(labels, multi_line = TRUE, sep = ": ") { value <- label_value(labels, multi_line = multi_line) - variable <- label_variable(labels, multi_line = multi_line) + + if (isTRUE(multi_line)) { + row <- as.list(names(labels)) + } else { + row <- list(paste(names(labels), collapse = ", ")) + } + variable <- lapply(row, rep, nrow(labels) %||% length(labels[[1]])) if (multi_line) { out <- vector("list", length(value)) From 024a1b6cf46530c5304c7327dadd9ae704f84759 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 10:27:21 +0200 Subject: [PATCH 24/44] more responsibility for `parse_axes_labeling()`, so that it is less distracting --- R/coord-sf.R | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/R/coord-sf.R b/R/coord-sf.R index f861ae2d28..b7be2c752b 100644 --- a/R/coord-sf.R +++ b/R/coord-sf.R @@ -547,11 +547,7 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE, label_axes <- label_axes %|W|% "" } - if (is.character(label_axes)) { - label_axes <- parse_axes_labeling(label_axes) - } else if (!is.list(label_axes)) { - cli::cli_abort("Panel labeling format not recognized.") - } + label_axes <- parse_axes_labeling(label_axes) if (is.character(label_graticule)) { label_graticule <- unlist(strsplit(label_graticule, "")) @@ -585,8 +581,13 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE, } parse_axes_labeling <- function(x) { - labs = unlist(strsplit(x, "")) - list(top = labs[1], right = labs[2], bottom = labs[3], left = labs[4]) + if (is.character(x)) { + x <- unlist(strsplit(x, "")) + x <- list(top = x[1], right = x[2], bottom = x[3], left = x[4]) + } else if (!is.list(x)) { + cli::cli_abort("Panel labeling format not recognized.") + } + x } # This function does two things differently from standard breaks: From b2de86ec8d6c35f2ffc6c2ac73000ae1b441c5c8 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 10:42:53 +0200 Subject: [PATCH 25/44] remove `resolve_guide()` --- R/guides-.R | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 34572699ca..236286a2cb 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -350,13 +350,8 @@ Guides <- ggproto( # Find guide for aesthetic-scale combination # Hierarchy is in the order: # plot + guides(XXX) + scale_ZZZ(guide = XXX) > default(i.e., legend) - guide <- resolve_guide( - aesthetic = aesthetics[idx], - scale = scales[[idx]], - guides = guides, - default = default, - null = missing - ) + guide <- guides[[aesthetics[idx]]] %||% scales[[idx]]$guide %|W|% + default %||% missing if (isFALSE(guide)) { deprecate_warn0("3.3.4", I("The `guide` argument in `scale_*()` cannot be `FALSE`. This "), I('"none"')) @@ -870,11 +865,6 @@ include_layer_in_guide <- function(layer, matched) { isTRUE(layer$show.legend) } -# resolve the guide from the scale and guides -resolve_guide <- function(aesthetic, scale, guides, default = "none", null = "none") { - guides[[aesthetic]] %||% scale$guide %|W|% default %||% null -} - # validate guide object validate_guide <- function(guide) { # if guide is specified by character, then find the corresponding guide From f7c8cb6ce710bfe871c020835fec20483bef0a09 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 10:55:07 +0200 Subject: [PATCH 26/44] inline revalue --- R/aes.R | 7 +++++- R/compat-plyr.R | 32 +--------------------------- tests/testthat/_snaps/compat-plyr.md | 16 -------------- tests/testthat/test-compat-plyr.R | 6 ------ 4 files changed, 7 insertions(+), 54 deletions(-) delete mode 100644 tests/testthat/_snaps/compat-plyr.md delete mode 100644 tests/testthat/test-compat-plyr.R diff --git a/R/aes.R b/R/aes.R index 67f8532d3c..c5275d0cd8 100644 --- a/R/aes.R +++ b/R/aes.R @@ -177,7 +177,12 @@ standardise_aes_names <- function(x) { x <- sub("color", "colour", x, fixed = TRUE) # convert old-style aesthetics names to ggplot version - revalue(x, ggplot_global$base_to_ggplot) + convert <- ggplot_global$base_to_ggplot + convert <- convert[names(convert) %in% x] + if (length(convert) > 0) { + x[match(names(convert), x)] <- convert + } + x } # x is a list of aesthetic mappings, as generated by aes() diff --git a/R/compat-plyr.R b/R/compat-plyr.R index fc62b9e6fb..a540c641a4 100644 --- a/R/compat-plyr.R +++ b/R/compat-plyr.R @@ -166,37 +166,7 @@ join_keys <- function(x, y, by) { list(x = keys[seq_len(n_x)], y = keys[n_x + seq_len(n_y)], n = attr(keys, "n")) } -#' Replace specified values with new values, in a factor or character vector -#' -#' An easy to use substitution of elements in a string-like vector (character or -#' factor). If `x` is a character vector the matching elements will be replaced -#' directly and if `x` is a factor the matching levels will be replaced -#' -#' @param x A character or factor vector -#' @param replace A named character vector with the names corresponding to the -#' elements to replace and the values giving the replacement. -#' -#' @return A vector of the same class as `x` with the given values replaced -#' -#' @keywords internal -#' @noRd -#' -revalue <- function(x, replace) { - if (is.character(x)) { - replace <- replace[names(replace) %in% x] - if (length(replace) == 0) return(x) - x[match(names(replace), x)] <- replace - } else if (is.factor(x)) { - lev <- levels(x) - replace <- replace[names(replace) %in% lev] - if (length(replace) == 0) return(x) - lev[match(names(replace), lev)] <- replace - levels(x) <- lev - } else if (!is.null(x)) { - stop_input_type(x, "a factor or character vector") - } - x -} + # Iterate through a formula and return a quoted version simplify_formula <- function(x) { if (length(x) == 2 && x[[1]] == as.name("~")) { diff --git a/tests/testthat/_snaps/compat-plyr.md b/tests/testthat/_snaps/compat-plyr.md deleted file mode 100644 index d31d586cc8..0000000000 --- a/tests/testthat/_snaps/compat-plyr.md +++ /dev/null @@ -1,16 +0,0 @@ -# input checks work in compat functions - - Can only remove rownames from and objects. - ---- - - `x` must be a factor or character vector, not an integer vector. - ---- - - Must be a character vector, call, or formula. - ---- - - `x` must be a vector, not a character vector. - diff --git a/tests/testthat/test-compat-plyr.R b/tests/testthat/test-compat-plyr.R deleted file mode 100644 index b8fd891ebf..0000000000 --- a/tests/testthat/test-compat-plyr.R +++ /dev/null @@ -1,6 +0,0 @@ -test_that("input checks work in compat functions", { - expect_snapshot_error(unrowname(1:6)) - expect_snapshot_error(revalue(1:7, c("5" = 2))) - expect_snapshot_error(as.quoted(1:7)) - expect_snapshot_error(round_any(letters)) -}) From 323247194d641b47900c5601485c2f2d3131e1d0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 11:07:20 +0200 Subject: [PATCH 27/44] simplify `scale_flip_position()` --- R/guide-.R | 3 ++- R/scale-.R | 8 +------- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/R/guide-.R b/R/guide-.R index 0a334c4580..84d25b1362 100644 --- a/R/guide-.R +++ b/R/guide-.R @@ -519,7 +519,8 @@ opposite_position <- function(position) { top = "bottom", bottom = "top", left = "right", - right = "left" + right = "left", + position ) } diff --git a/R/scale-.R b/R/scale-.R index 1773f15142..8745aed9d4 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -1379,13 +1379,7 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, # In place modification of a scale to change the primary axis scale_flip_position <- function(scale) { - scale$position <- switch(scale$position, - top = "bottom", - bottom = "top", - left = "right", - right = "left", - scale$position - ) + scale$position <- opposite_position(scale$position) invisible() } From 37da40198ac7f7e3e457603a2462dcacf65263db Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 11:14:47 +0200 Subject: [PATCH 28/44] remove `as.quoted()` (note there is still `as_quoted()`) --- R/compat-plyr.R | 27 +-------------------------- R/facet-.R | 2 +- 2 files changed, 2 insertions(+), 27 deletions(-) diff --git a/R/compat-plyr.R b/R/compat-plyr.R index a540c641a4..b8d25d0ab2 100644 --- a/R/compat-plyr.R +++ b/R/compat-plyr.R @@ -188,32 +188,7 @@ simplify_formula <- function(x) { list(x) } } -#' Create a quoted version of x -#' -#' This function captures the special meaning of formulas in the context of -#' facets in ggplot2, where `+` have special meaning. It works as -#' `plyr::as.quoted` but only for the special cases of `character`, `call`, and -#' `formula` input as these are the only situations relevant for ggplot2. -#' -#' @param x A formula, string, or call to be quoted -#' @param env The environment to a attach to the quoted expression. -#' -#' @keywords internal -#' @noRd -#' -as.quoted <- function(x, env = parent.frame()) { - x <- if (is.character(x)) { - lapply(x, function(x) parse(text = x)[[1]]) - } else if (is.formula(x)) { - simplify_formula(x) - } else if (is.call(x)) { - as.list(x)[-1] - } else { - cli::cli_abort("Must be a character vector, call, or formula.") - } - attributes(x) <- list(env = env, class = 'quoted') - x -} + # round a number to a given precision round_any <- function(x, accuracy, f = round) { check_numeric(x) diff --git a/R/facet-.R b/R/facet-.R index c9dc0f5d7a..93f2583005 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -529,7 +529,7 @@ f_as_facets <- function(f) { env <- f_env(f) %||% globalenv() # as.quoted() handles `+` specifications - vars <- as.quoted(f) + vars <- simplify_formula(f) # `.` in formulas is discarded vars <- vars[!vapply(vars, identical, logical(1), as.name("."))] From 6ac62cfdd71e9c6b6b6f16d98f3e983072f5b0b0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 11:18:33 +0200 Subject: [PATCH 29/44] replace `simplify_formula()` with `simplify()` --- R/compat-plyr.R | 22 ---------------------- R/facet-.R | 2 +- 2 files changed, 1 insertion(+), 23 deletions(-) diff --git a/R/compat-plyr.R b/R/compat-plyr.R index b8d25d0ab2..3ebb4cfe8c 100644 --- a/R/compat-plyr.R +++ b/R/compat-plyr.R @@ -167,28 +167,6 @@ join_keys <- function(x, y, by) { n = attr(keys, "n")) } -# Iterate through a formula and return a quoted version -simplify_formula <- function(x) { - if (length(x) == 2 && x[[1]] == as.name("~")) { - return(simplify(x[[2]])) - } - if (length(x) < 3) - return(list(x)) - op <- x[[1]] - a <- x[[2]] - b <- x[[3]] - if (op == as.name("+") || op == as.name("*") || op == - as.name("~")) { - c(simplify(a), simplify(b)) - } - else if (op == as.name("-")) { - c(simplify(a), bquote(-.(x), list(x = simplify(b)))) - } - else { - list(x) - } -} - # round a number to a given precision round_any <- function(x, accuracy, f = round) { check_numeric(x) diff --git a/R/facet-.R b/R/facet-.R index 93f2583005..ef6dbaa0da 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -529,7 +529,7 @@ f_as_facets <- function(f) { env <- f_env(f) %||% globalenv() # as.quoted() handles `+` specifications - vars <- simplify_formula(f) + vars <- simplify(f) # `.` in formulas is discarded vars <- vars[!vapply(vars, identical, logical(1), as.name("."))] From db6feb89aa11e4821aca47ae0695acc95d157d14 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 11:33:41 +0200 Subject: [PATCH 30/44] inline `single_value()` --- NAMESPACE | 2 -- R/compat-plyr.R | 21 ++++++--------------- 2 files changed, 6 insertions(+), 17 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index b0b8320c44..1580d44f7e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -124,8 +124,6 @@ S3method(scale_type,logical) S3method(scale_type,numeric) S3method(scale_type,ordered) S3method(scale_type,sfc) -S3method(single_value,default) -S3method(single_value,factor) S3method(summary,ggplot) S3method(vec_cast,character.mapped_discrete) S3method(vec_cast,double.mapped_discrete) diff --git a/R/compat-plyr.R b/R/compat-plyr.R index 3ebb4cfe8c..bc5f675829 100644 --- a/R/compat-plyr.R +++ b/R/compat-plyr.R @@ -209,7 +209,12 @@ dapply <- function(df, by, fun, ..., drop = TRUE) { } # Shortcut when only one group - if (all(vapply(grouping_cols, single_value, logical(1)))) { + has_single_group <- all(vapply( + grouping_cols, + function(x) identical(as.character(levels(x) %||% attr(x, "n")), "1"), + logical(1) + )) + if (has_single_group) { return(apply_fun(df)) } @@ -221,17 +226,3 @@ dapply <- function(df, by, fun, ..., drop = TRUE) { }) vec_rbind0(!!!result) } - -single_value <- function(x, ...) { - UseMethod("single_value") -} -#' @export -single_value.default <- function(x, ...) { - # This is set by id() used in creating the grouping var - identical(attr(x, "n"), 1L) -} -#' @export -single_value.factor <- function(x, ...) { - # Panels are encoded as factor numbers and can never be missing (NA) - identical(levels(x), "1") -} From e75c6d63cba23155b130f5ead3f40ac64f83e54a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 12:42:38 +0200 Subject: [PATCH 31/44] inline `update_guides()` --- R/guides-.R | 13 ------------- R/plot-construction.R | 11 ++++++++++- 2 files changed, 10 insertions(+), 14 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index 236286a2cb..1e7e7e29f5 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -109,19 +109,6 @@ guides <- function(...) { NULL } -update_guides <- function(p, guides) { - p <- plot_clone(p) - if (inherits(p$guides, "Guides")) { - old <- p$guides - new <- ggproto(NULL, old) - new$add(guides) - p$guides <- new - } else { - p$guides <- guides - } - p -} - # Class ------------------------------------------------------------------- # Guides object encapsulates multiple guides and their state. diff --git a/R/plot-construction.R b/R/plot-construction.R index de1306098f..e1bf96a2aa 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -126,7 +126,16 @@ ggplot_add.labels <- function(object, plot, object_name) { } #' @export ggplot_add.Guides <- function(object, plot, object_name) { - update_guides(plot, object) + if (inherits(plot$guides, "Guides")) { + # We clone the guides object to prevent modify-in-place of guides + old <- plot$guides + new <- ggproto(NULL, old) + new$add(object) + plot$guides <- new + } else { + plot$guides <- object + } + plot } #' @export ggplot_add.uneval <- function(object, plot, object_name) { From 4739a126cab814724792ec56d3a2af3a1e452fd4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 13:01:28 +0200 Subject: [PATCH 32/44] inline `is_column_vec()` and better name for `validate_column_vec()` --- R/utilities.R | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index a45ef753cc..cac89a1d0f 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -342,19 +342,17 @@ is_unique <- function(x) vec_unique_count(x) == 1L # Check inputs with tibble but allow column vectors (see #2609 and #2374) as_gg_data_frame <- function(x) { - x <- lapply(x, validate_column_vec) + x <- lapply(x, drop_column_vec) data_frame0(!!!x) } -validate_column_vec <- function(x) { - if (is_column_vec(x)) { + +drop_column_vec <- function(x) { + dims <- dim(x) + if (length(dims) == 2L && dims[[2]] == 1L) { dim(x) <- NULL } x } -is_column_vec <- function(x) { - dims <- dim(x) - length(dims) == 2L && dims[[2]] == 1L -} # Parse takes a vector of n lines and returns m expressions. # See https://github.com/tidyverse/ggplot2/issues/2864 for discussion. From 47e36e2e45b35cc7248fdf6e6c21143156dab278 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 14:13:34 +0200 Subject: [PATCH 33/44] remove/replace `wrap_as_facets_list()` (by `compact_facets()` --- R/facet-.R | 3 +-- R/facet-grid-.R | 4 ++-- R/facet-wrap.R | 8 +------- tests/testthat/test-facet-.R | 22 +++++++++++----------- 4 files changed, 15 insertions(+), 22 deletions(-) diff --git a/R/facet-.R b/R/facet-.R index ef6dbaa0da..afd6bc69a6 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -455,10 +455,9 @@ validate_facets <- function(x) { x } - # Flatten a list of quosures objects to a quosures object, and compact it compact_facets <- function(x) { - + x <- as_facets_list(x) proxy <- vec_proxy(x) is_list <- vapply(proxy, vec_is_list, logical(1)) proxy[is_list] <- lapply(proxy[is_list], unclass) diff --git a/R/facet-grid-.R b/R/facet-grid-.R index 7bfb30dd6e..5b254797c2 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -219,8 +219,8 @@ grid_as_facets_list <- function(rows, cols) { check_object(cols, is_quosures, "a {.fn vars} specification", allow_null = TRUE) list( - rows = compact_facets(as_facets_list(rows)), - cols = compact_facets(as_facets_list(cols)) + rows = compact_facets(rows), + cols = compact_facets(cols) ) } diff --git a/R/facet-wrap.R b/R/facet-wrap.R index 68c02f0b21..b43c2cfaa8 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -147,7 +147,7 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", labeller <- check_labeller(labeller) # Flatten all facets dimensions into a single one - facets <- wrap_as_facets_list(facets) + facets <- compact_facets(facets) if (lifecycle::is_present(switch) && !is.null(switch)) { deprecate_warn0("2.2.0", "facet_wrap(switch)", "facet_wrap(strip.position)") @@ -182,12 +182,6 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", ) } -# Returns a quosures object -wrap_as_facets_list <- function(x) { - facets_list <- as_facets_list(x) - compact_facets(facets_list) -} - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL diff --git a/tests/testthat/test-facet-.R b/tests/testthat/test-facet-.R index 9e536798a8..5084737622 100644 --- a/tests/testthat/test-facet-.R +++ b/tests/testthat/test-facet-.R @@ -21,7 +21,7 @@ test_that("as_facets_list() coerces character vectors", { expect_identical(as_facets_list("foo"), list(foobar[1])) expect_identical(as_facets_list(c("foo", "bar")), list(foobar[1], foobar[2])) - expect_identical(wrap_as_facets_list(c("foo", "bar")), foobar) + expect_identical(compact_facets(c("foo", "bar")), foobar) }) test_that("as_facets_list() coerces lists", { @@ -47,12 +47,12 @@ test_that("facets reject aes()", { expect_error(facet_grid(aes(foo)), "Please use `vars()` to supply facet variables", fixed = TRUE) }) -test_that("wrap_as_facets_list() returns a quosures object with compacted", { - expect_identical(wrap_as_facets_list(vars(foo)), quos(foo = foo)) - expect_identical(wrap_as_facets_list(~foo + bar), quos(foo = foo, bar = bar)) +test_that("compact_facets() returns a quosures object with compacted", { + expect_identical(compact_facets(vars(foo)), quos(foo = foo)) + expect_identical(compact_facets(~foo + bar), quos(foo = foo, bar = bar)) f <- function(x) { - expect_identical(wrap_as_facets_list(vars(foo, {{ x }}, bar)), quos(foo = foo, bar = bar)) + expect_identical(compact_facets(vars(foo, {{ x }}, bar)), quos(foo = foo, bar = bar)) } f(NULL) @@ -71,12 +71,12 @@ test_that("grid_as_facets_list() returns a list of quosures objects with compact f() }) -test_that("wrap_as_facets_list() and grid_as_facets_list() accept empty specs", { - expect_identical(wrap_as_facets_list(NULL), quos()) - expect_identical(wrap_as_facets_list(list()), quos()) - expect_identical(wrap_as_facets_list(. ~ .), quos()) - expect_identical(wrap_as_facets_list(list(. ~ .)), quos()) - expect_identical(wrap_as_facets_list(list(NULL)), quos()) +test_that("compact_facets() and grid_as_facets_list() accept empty specs", { + expect_identical(compact_facets(NULL), quos()) + expect_identical(compact_facets(list()), quos()) + expect_identical(compact_facets(. ~ .), quos()) + expect_identical(compact_facets(list(. ~ .)), quos()) + expect_identical(compact_facets(list(NULL)), quos()) expect_identical(grid_as_facets_list(list(), NULL), list(rows = quos(), cols = quos())) expect_identical(grid_as_facets_list(. ~ ., NULL), list(rows = quos(), cols = quos())) From d74f6a59ae8f88ce2885e72ceff0a35079ef6d40 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 2 Aug 2024 14:19:18 +0200 Subject: [PATCH 34/44] finishing touches --- DESCRIPTION | 1 - R/stat-summary-bin.R | 3 ++- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3f34454b36..b6a181f107 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -276,7 +276,6 @@ Collate: 'utilities-break.R' 'utilities-grid.R' 'utilities-help.R' - 'utilities-matrix.R' 'utilities-patterns.R' 'utilities-resolution.R' 'utilities-tidy-eval.R' diff --git a/R/stat-summary-bin.R b/R/stat-summary-bin.R index ce57b6def9..e12e771480 100644 --- a/R/stat-summary-bin.R +++ b/R/stat-summary-bin.R @@ -78,7 +78,8 @@ StatSummaryBin <- ggproto("StatSummaryBin", Stat, data <- flip_data(data, flipped_aes) fun <- make_summary_fun(fun.data, fun, fun.max, fun.min, fun.args) x <- flipped_names(flipped_aes)$x - breaks <- bin2d_breaks(scales[[x]], breaks, origin, binwidth, bins, right = right) + breaks <- bin2d_breaks(scales[[x]], breaks, origin, binwidth, bins, + closed = if (right) "right" else "left") data$bin <- cut(data$x, breaks, include.lowest = TRUE, labels = FALSE) out <- dapply(data, "bin", fun) From 2f1f42f538147ee4affb11781a4c1b5544dc5933 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 27 Aug 2024 16:36:04 +0200 Subject: [PATCH 35/44] `parse_axes_labeling` uses parent call --- R/coord-sf.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/coord-sf.R b/R/coord-sf.R index a14554fe09..118d1e678e 100644 --- a/R/coord-sf.R +++ b/R/coord-sf.R @@ -580,12 +580,12 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE, ) } -parse_axes_labeling <- function(x) { +parse_axes_labeling <- function(x, call = caller_env()) { if (is.character(x)) { x <- unlist(strsplit(x, "")) x <- list(top = x[1], right = x[2], bottom = x[3], left = x[4]) } else if (!is.list(x)) { - cli::cli_abort("Panel labeling format not recognized.") + cli::cli_abort("Panel labeling format not recognized.", call = call) } x } From 276e6a29388189ebdb2872cded1029fca42569b5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 27 Aug 2024 16:42:10 +0200 Subject: [PATCH 36/44] elaborate on regex pattern --- R/aes-evaluation.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/aes-evaluation.R b/R/aes-evaluation.R index f5208aa8a2..8e47ebcd1e 100644 --- a/R/aes-evaluation.R +++ b/R/aes-evaluation.R @@ -219,6 +219,8 @@ stage_scaled <- function(start = NULL, after_stat = NULL, after_scale = NULL) { } # Regex to determine if an identifier refers to a calculated aesthetic +# The pattern includes ye olde '...var...' syntax, which was +# deprecated in 3.4.0 in favour of `after_stat()` match_calculated_aes <- "^\\.\\.([a-zA-Z._]+)\\.\\.$" # Determine if aesthetic is calculated From 2978d4d719629f671e73adee31a84bbbb0cd41ba Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 27 Aug 2024 17:02:04 +0200 Subject: [PATCH 37/44] Revert "inline `is_labeller()`" This reverts commit 9976913a361d4e3a040e5c09131d60e8973c2a93. --- R/labeller.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/labeller.R b/R/labeller.R index ce94157826..4ca220c2b4 100644 --- a/R/labeller.R +++ b/R/labeller.R @@ -228,6 +228,8 @@ label_wrap_gen <- function(width = 25, multi_line = TRUE) { structure(fun, class = "labeller") } +is_labeller <- function(x) inherits(x, "labeller") + resolve_labeller <- function(rows, cols, labels) { if (is.null(cols) && is.null(rows)) { cli::cli_abort("Supply one of {.arg rows} or {.arg cols}.") @@ -289,7 +291,7 @@ as_labeller <- function(x, default = label_value, multi_line = TRUE) { # support it. default <- dispatch_args(default, multi_line = multi_line) - if (inherits(x, "labeller")) { + if (is_labeller(x)) { x <- dispatch_args(x, multi_line = multi_line) x(labels) } else if (is.function(x)) { From 037c1ae71ecad05d71733c5ae9978bb04b9cf8f1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 27 Aug 2024 17:02:45 +0200 Subject: [PATCH 38/44] Revert "inline `is.sec_axis()`" This reverts commit 1bdc20d2dc48eec0fd6d1f45b7405856273689ac. --- R/axis-secondary.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/axis-secondary.R b/R/axis-secondary.R index 2f9767113a..2999bd79b5 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -124,6 +124,10 @@ dup_axis <- function(transform = identity, name = derive(), breaks = derive(), sec_axis(transform, trans = trans, name, breaks, labels, guide) } +is.sec_axis <- function(x) { + inherits(x, "AxisSecondary") +} + set_sec_axis <- function(sec.axis, scale) { if (!is.waive(sec.axis)) { if (scale$is_discrete()) { @@ -132,7 +136,7 @@ set_sec_axis <- function(sec.axis, scale) { } } if (is.formula(sec.axis)) sec.axis <- sec_axis(sec.axis) - if (!inherits(sec.axis, "AxisSecondary")) { + if (!is.sec_axis(sec.axis)) { cli::cli_abort("Secondary axes must be specified using {.fn sec_axis}.") } scale$secondary.axis <- sec.axis From 8076706f41996116eb3ad301d8ac53912d68ba48 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 27 Aug 2024 17:03:48 +0200 Subject: [PATCH 39/44] Revert "replace single use internal functions" This reverts commit 20fa50f80612fdd28dc71e28fdab281e68a83b1f. --- R/bin.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/bin.R b/R/bin.R index d889d11286..a7784d02e5 100644 --- a/R/bin.R +++ b/R/bin.R @@ -25,6 +25,8 @@ bins <- function(breaks, closed = "right", ) } +is_bins <- function(x) inherits(x, "ggplot2_bins") + #' @export print.ggplot2_bins <- function(x, ...) { n <- length(x$breaks) @@ -131,7 +133,7 @@ bin_breaks_bins <- function(x_range, bins = 30, center = NULL, # Compute bins ------------------------------------------------------------ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) { - check_inherits(bins, "ggplot2_bins", "a {.cls ggplot2_bins} object") + check_object(bins, is_bins, "a {.cls ggplot2_bins} object") if (all(is.na(x))) { return(bin_out(length(x), NA, NA, xmin = NA, xmax = NA)) From 049db27b49366e008553abca9ea6c645dc9b71a5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 27 Aug 2024 17:32:27 +0200 Subject: [PATCH 40/44] Collection of test functions for user-facing components --- NAMESPACE | 11 ++++++ R/coord-.R | 6 ---- R/facet-.R | 7 ---- R/ggproto.R | 5 --- R/plot.R | 6 ---- R/theme.R | 6 ---- R/utilities-checks.R | 83 ++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 94 insertions(+), 30 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 5147e41d34..7d15e2137a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -459,9 +459,20 @@ export(guide_transform) export(guides) export(has_flipped_aes) export(is.Coord) +export(is.coord) +export(is.element) export(is.facet) +export(is.geom) export(is.ggplot) export(is.ggproto) +export(is.guide) +export(is.guides) +export(is.layer) +export(is.mapping) +export(is.margin) +export(is.position) +export(is.scale) +export(is.stat) export(is.theme) export(label_both) export(label_bquote) diff --git a/R/coord-.R b/R/coord-.R index 57cf351f92..2292df6828 100644 --- a/R/coord-.R +++ b/R/coord-.R @@ -225,12 +225,6 @@ Coord <- ggproto("Coord", } ) -#' Is this object a coordinate system? -#' -#' @export is.Coord -#' @keywords internal -is.Coord <- function(x) inherits(x, "Coord") - # Renders an axis with the correct orientation or zeroGrob if no axis should be # generated render_axis <- function(panel_params, axis, scale, position, theme) { diff --git a/R/facet-.R b/R/facet-.R index ccfed668b5..b8826e53aa 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -353,13 +353,6 @@ get_strip_labels <- function(plot = get_last_plot()) { plot$plot$facet$format_strip_labels(layout, params) } -#' Is this object a faceting specification? -#' -#' @param x object to test -#' @keywords internal -#' @export -is.facet <- function(x) inherits(x, "Facet") - # A "special" value, currently not used but could be used to determine # if faceting is active NO_PANEL <- -1L diff --git a/R/ggproto.R b/R/ggproto.R index 0af8a5a5ab..e2c7b11733 100644 --- a/R/ggproto.R +++ b/R/ggproto.R @@ -106,11 +106,6 @@ ggproto_parent <- function(parent, self) { structure(list(parent = parent, self = self), class = "ggproto_parent") } -#' @param x An object to test. -#' @export -#' @rdname ggproto -is.ggproto <- function(x) inherits(x, "ggproto") - fetch_ggproto <- function(x, name) { res <- NULL diff --git a/R/plot.R b/R/plot.R index 6bdcabc23f..e6e53d74c9 100644 --- a/R/plot.R +++ b/R/plot.R @@ -154,12 +154,6 @@ plot_clone <- function(plot) { p } -#' Reports whether x is a ggplot object -#' @param x An object to test -#' @keywords internal -#' @export -is.ggplot <- function(x) inherits(x, "ggplot") - #' Explicitly draw plot #' #' Generally, you do not need to print or plot a ggplot2 plot explicitly: the diff --git a/R/theme.R b/R/theme.R index 09cb685543..9777a690df 100644 --- a/R/theme.R +++ b/R/theme.R @@ -905,12 +905,6 @@ combine_elements <- function(e1, e2) { e1 } -#' Reports whether x is a theme object -#' @param x An object to test -#' @export -#' @keywords internal -is.theme <- function(x) inherits(x, "theme") - #' @export `$.theme` <- function(x, ...) { .subset2(x, ...) diff --git a/R/utilities-checks.R b/R/utilities-checks.R index a1ed1b5091..2f5f2b7da9 100644 --- a/R/utilities-checks.R +++ b/R/utilities-checks.R @@ -1,3 +1,86 @@ +# Tests ------------------------------------------------------------------- + +#' Reports whether x is a type of object +#' @param x An object to test +#' @keywords internal +#' @export +#' @name is_tests +is.ggplot <- function(x) inherits(x, "ggplot") + +#' @export +#' @rdname is_tests +is.mapping <- function(x) inherits(x, "uneval") + +#' @export +#' @rdname is_tests +is.coord <- function(x) inherits(x, "Coord") + +#' @export +#' @rdname is_tests +#' @usage is.Coord(x) # Deprecated +is.Coord <- function(x) { + deprecate_soft0("3.5.2", "is.Coord()", "is.coord()") + is.coord(x) +} + +#' @export +#' @rdname is_tests +is.ggproto <- function(x) inherits(x, "ggproto") + +#' @export +#' @rdname is_tests +is.facet <- function(x) inherits(x, "Facet") + +#' @export +#' @rdname is_tests +#' @usage +#' # Layer related tests +#' is.layer(x) +is.layer <- function(x) inherits(x, "Layer") + +#' @export +#' @rdname is_tests +is.geom <- function(x) inherits(x, "Geom") + +#' @export +#' @rdname is_tests +is.stat <- function(x) inherits(x, "Stat") + +#' @export +#' @rdname is_tests +is.position <- function(x) inherits(x, "Position") + +#' @export +#' @usage +#' # Scale and guide related tests +#' is.scale(x) +#' @rdname is_tests +is.scale <- function(x) inherits(x, "Scale") + +#' @export +#' @rdname is_tests +is.guide <- function(x) inherits(x, "Guide") + +#' @export +#' @rdname is_tests +is.guides <- function(x) inherits(x, "Guides") + +#' @export +#' @usage +#' # Theme related tests +#' is.theme(x) +#' @rdname is_tests +is.theme <- function(x) inherits(x, "theme") + +#' @export +#' @rdname is_tests +is.element <- function(x) inherits(x, "element") + +#' @export +#' @rdname is_tests +is.margin <- function(x) inherits(x, "margin") + +# Checks ------------------------------------------------------------------ # Extra checks in addition to the ones in import-standalone-types-check.R From ae2561b286d727063e27890383f63105fedb4b11 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 27 Aug 2024 17:33:20 +0200 Subject: [PATCH 41/44] apply tests when applicable --- R/coord-cartesian-.R | 2 +- R/facet-.R | 2 +- R/fortify.R | 2 +- R/geom-defaults.R | 2 +- R/geom-label.R | 2 +- R/guide-.R | 2 +- R/guides-.R | 6 +++--- R/layer.R | 6 +++--- R/plot-build.R | 2 +- R/plot-construction.R | 2 +- R/plot.R | 2 +- R/scale-colour.R | 2 +- R/theme.R | 4 ++-- 13 files changed, 18 insertions(+), 18 deletions(-) diff --git a/R/coord-cartesian-.R b/R/coord-cartesian-.R index 74f46433db..bcae23877d 100644 --- a/R/coord-cartesian-.R +++ b/R/coord-cartesian-.R @@ -159,7 +159,7 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) { } panel_guides_grob <- function(guides, position, theme, labels = NULL) { - if (!inherits(guides, "Guides")) { + if (!is.guides(guides)) { return(zeroGrob()) } pair <- guides$get_position(position) diff --git a/R/facet-.R b/R/facet-.R index b8826e53aa..9d63ff7e66 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -437,7 +437,7 @@ as_facets_list <- function(x) { } validate_facets <- function(x) { - if (inherits(x, "uneval")) { + if (is.mapping(x)) { cli::cli_abort("Please use {.fn vars} to supply facet variables.") } # Native pipe have higher precedence than + so any type of gg object can be diff --git a/R/fortify.R b/R/fortify.R index 3a61e3ce49..23166ffa99 100644 --- a/R/fortify.R +++ b/R/fortify.R @@ -79,7 +79,7 @@ fortify.default <- function(model, data, ...) { "or an object coercible by {.fn fortify}, or a valid ", "{.cls data.frame}-like object coercible by {.fn as.data.frame}" ) - if (inherits(model, "uneval")) { + if (is.mapping(model)) { msg <- c( paste0(msg, ", not ", obj_type_friendly(model), "."), "i" = "Did you accidentally pass {.fn aes} to the {.arg data} argument?" diff --git a/R/geom-defaults.R b/R/geom-defaults.R index 65974f841a..b185990fbb 100644 --- a/R/geom-defaults.R +++ b/R/geom-defaults.R @@ -98,7 +98,7 @@ get_geom_defaults <- function(geom, theme = theme_get()) { if (is.character(geom)) { geom <- check_subclass(geom, "Geom") } - if (inherits(geom, "Geom")) { + if (is.geom(geom)) { out <- geom$use_defaults(data = NULL, theme = theme) return(out) } diff --git a/R/geom-label.R b/R/geom-label.R index 4168c98d94..6f21478da0 100644 --- a/R/geom-label.R +++ b/R/geom-label.R @@ -78,7 +78,7 @@ GeomLabel <- ggproto("GeomLabel", Geom, data <- coord$transform(data, panel_params) data$vjust <- compute_just(data$vjust, data$y, data$x, data$angle) data$hjust <- compute_just(data$hjust, data$x, data$y, data$angle) - if (!inherits(label.padding, "margin")) { + if (!is.margin("margin")) { label.padding <- rep(label.padding, length.out = 4) } diff --git a/R/guide-.R b/R/guide-.R index 176aee76e0..08dbc7b7c5 100644 --- a/R/guide-.R +++ b/R/guide-.R @@ -377,7 +377,7 @@ Guide <- ggproto( # Renders tickmarks build_ticks = function(key, elements, params, position = params$position, length = elements$ticks_length) { - if (!inherits(elements, "element")) { + if (!is.element(elements)) { elements <- elements$ticks } if (!inherits(elements, "element_line")) { diff --git a/R/guides-.R b/R/guides-.R index e5e9dae4eb..33ea9745fb 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -69,7 +69,7 @@ NULL guides <- function(...) { args <- list2(...) if (length(args) > 0) { - if (is.list(args[[1]]) && !inherits(args[[1]], "guide")) args <- args[[1]] + if (is.list(args[[1]]) && !is.guide(args[[1]])) args <- args[[1]] args <- rename_aes(args) } @@ -138,7 +138,7 @@ Guides <- ggproto( if (is.null(guides)) { return(invisible()) } - if (inherits(guides, "Guides")) { + if (is.guides(guides)) { guides <- guides$guides } self$guides <- defaults(guides, self$guides) @@ -862,7 +862,7 @@ validate_guide <- function(guide) { guide <- fun() } } - if (inherits(guide, "Guide")) { + if (is.guide(guide)) { return(guide) } if (inherits(guide, "guide") && is.list(guide)) { diff --git a/R/layer.R b/R/layer.R index b6334c2604..2f245676ce 100644 --- a/R/layer.R +++ b/R/layer.R @@ -58,8 +58,8 @@ #' `NA`, the default, includes if any aesthetics are mapped. #' `FALSE` never includes, and `TRUE` always includes. #' It can also be a named logical vector to finely select the aesthetics to -#' display. To include legend keys for all levels, even -#' when no data exists, use `TRUE`. If `NA`, all levels are shown in legend, +#' display. To include legend keys for all levels, even +#' when no data exists, use `TRUE`. If `NA`, all levels are shown in legend, #' but unobserved levels are omitted. #' @param inherit.aes If `FALSE`, overrides the default aesthetics, #' rather than combining with them. This is most useful for helper functions @@ -203,7 +203,7 @@ layer <- function(geom = NULL, stat = NULL, } validate_mapping <- function(mapping, call = caller_env()) { - if (!inherits(mapping, "uneval")) { + if (!is.mapping(mapping)) { msg <- "{.arg mapping} must be created by {.fn aes}." # Native pipe have higher precedence than + so any type of gg object can be # expected here, not just ggplot diff --git a/R/plot-build.R b/R/plot-build.R index 46e0517d3f..c7e641c8e6 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -288,7 +288,7 @@ ggplot_gtable.ggplot_built <- function(data) { plot_margin <- calc_element("plot.margin", theme) plot_table <- gtable_add_padding(plot_table, plot_margin) - if (inherits(theme$plot.background, "element")) { + if (is.element(theme$plot.background)) { plot_table <- gtable_add_grob(plot_table, element_render(theme, "plot.background"), t = 1, l = 1, b = -1, r = -1, name = "background", z = -Inf) diff --git a/R/plot-construction.R b/R/plot-construction.R index 6aedbd1aae..ac0619cbdb 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -149,7 +149,7 @@ ggplot_add.labels <- function(object, plot, object_name) { } #' @export ggplot_add.Guides <- function(object, plot, object_name) { - if (inherits(plot$guides, "Guides")) { + if (is.guides(plot$guides)) { # We clone the guides object to prevent modify-in-place of guides old <- plot$guides new <- ggproto(NULL, old) diff --git a/R/plot.R b/R/plot.R index e6e53d74c9..f78fe2c9aa 100644 --- a/R/plot.R +++ b/R/plot.R @@ -111,7 +111,7 @@ ggplot <- function(data = NULL, mapping = aes(), ..., #' @export ggplot.default <- function(data = NULL, mapping = aes(), ..., environment = parent.frame()) { - if (!missing(mapping) && !inherits(mapping, "uneval")) { + if (!missing(mapping) && !is.mapping(mapping)) { cli::cli_abort(c( "{.arg mapping} must be created with {.fn aes}.", "x" = "You've supplied {.obj_type_friendly {mapping}}." diff --git a/R/scale-colour.R b/R/scale-colour.R index 71255e2033..19cdda1396 100644 --- a/R/scale-colour.R +++ b/R/scale-colour.R @@ -197,7 +197,7 @@ scale_fill_binned <- function(..., # helper function to make sure that the provided scale is of the correct # type (i.e., is continuous and works with the provided aesthetic) check_scale_type <- function(scale, name, aesthetic, scale_is_discrete = FALSE, call = caller_env()) { - if (!is.ggproto(scale) || !inherits(scale, "Scale")) { + if (!is.ggproto(scale) || !is.scale(scale)) { cli::cli_abort(c( "The {.arg type} argument must return a continuous scale for the {.field {aesthetic}} aesthetic.", "x" = "The provided object is not a scale function." diff --git a/R/theme.R b/R/theme.R index 9777a690df..668ce9700e 100644 --- a/R/theme.R +++ b/R/theme.R @@ -483,7 +483,7 @@ theme <- function(..., elements$panel.spacing.y <- elements$panel.margin.y elements$panel.margin.y <- NULL } - if (is.unit(elements$legend.margin) && !inherits(elements$legend.margin, "margin")) { + if (is.unit(elements$legend.margin) && !is.margin(elements$legend.margin)) { cli::cli_warn(c( "{.var legend.margin} must be specified using {.fn margin}", "i" = "For the old behavior use {.var legend.spacing}" @@ -529,7 +529,7 @@ theme <- function(..., # If complete theme set all non-blank elements to inherit from blanks if (complete) { elements <- lapply(elements, function(el) { - if (inherits(el, "element") && !inherits(el, "element_blank")) { + if (is.element(el) && !inherits(el, "element_blank")) { el$inherit.blank <- TRUE } el From 3be8e6d84ecfebb88ddb3b5ba08431115763d338 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 27 Aug 2024 17:36:01 +0200 Subject: [PATCH 42/44] redocument --- man/ggproto.Rd | 5 ---- man/is.Coord.Rd | 12 --------- man/is.facet.Rd | 15 ------------ man/is.ggplot.Rd | 15 ------------ man/is.theme.Rd | 15 ------------ man/is_tests.Rd | 64 ++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 64 insertions(+), 62 deletions(-) delete mode 100644 man/is.Coord.Rd delete mode 100644 man/is.facet.Rd delete mode 100644 man/is.ggplot.Rd delete mode 100644 man/is.theme.Rd create mode 100644 man/is_tests.Rd diff --git a/man/ggproto.Rd b/man/ggproto.Rd index c00c2000f6..11e3af8093 100644 --- a/man/ggproto.Rd +++ b/man/ggproto.Rd @@ -3,14 +3,11 @@ \name{ggproto} \alias{ggproto} \alias{ggproto_parent} -\alias{is.ggproto} \title{Create a new ggproto object} \usage{ ggproto(`_class` = NULL, `_inherit` = NULL, ...) ggproto_parent(parent, self) - -is.ggproto(x) } \arguments{ \item{_class}{Class name to assign to the object. This is stored as the class @@ -24,8 +21,6 @@ inherit from any object.} functions that become methods of the class or regular objects.} \item{parent, self}{Access parent class \code{parent} of object \code{self}.} - -\item{x}{An object to test.} } \description{ Construct a new object with \code{ggproto()}, test with \code{is.ggproto()}, diff --git a/man/is.Coord.Rd b/man/is.Coord.Rd deleted file mode 100644 index 50b4520640..0000000000 --- a/man/is.Coord.Rd +++ /dev/null @@ -1,12 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/coord-.R -\name{is.Coord} -\alias{is.Coord} -\title{Is this object a coordinate system?} -\usage{ -is.Coord(x) -} -\description{ -Is this object a coordinate system? -} -\keyword{internal} diff --git a/man/is.facet.Rd b/man/is.facet.Rd deleted file mode 100644 index bd8fc7b5ba..0000000000 --- a/man/is.facet.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/facet-.R -\name{is.facet} -\alias{is.facet} -\title{Is this object a faceting specification?} -\usage{ -is.facet(x) -} -\arguments{ -\item{x}{object to test} -} -\description{ -Is this object a faceting specification? -} -\keyword{internal} diff --git a/man/is.ggplot.Rd b/man/is.ggplot.Rd deleted file mode 100644 index 837bc9a919..0000000000 --- a/man/is.ggplot.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R -\name{is.ggplot} -\alias{is.ggplot} -\title{Reports whether x is a ggplot object} -\usage{ -is.ggplot(x) -} -\arguments{ -\item{x}{An object to test} -} -\description{ -Reports whether x is a ggplot object -} -\keyword{internal} diff --git a/man/is.theme.Rd b/man/is.theme.Rd deleted file mode 100644 index c7930a2e96..0000000000 --- a/man/is.theme.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/theme.R -\name{is.theme} -\alias{is.theme} -\title{Reports whether x is a theme object} -\usage{ -is.theme(x) -} -\arguments{ -\item{x}{An object to test} -} -\description{ -Reports whether x is a theme object -} -\keyword{internal} diff --git a/man/is_tests.Rd b/man/is_tests.Rd new file mode 100644 index 0000000000..472896fe47 --- /dev/null +++ b/man/is_tests.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utilities-checks.R +\name{is_tests} +\alias{is_tests} +\alias{is.ggplot} +\alias{is.mapping} +\alias{is.coord} +\alias{is.Coord} +\alias{is.ggproto} +\alias{is.facet} +\alias{is.layer} +\alias{is.geom} +\alias{is.stat} +\alias{is.position} +\alias{is.scale} +\alias{is.guide} +\alias{is.guides} +\alias{is.theme} +\alias{is.element} +\alias{is.margin} +\title{Reports whether x is a type of object} +\usage{ +is.ggplot(x) + +is.mapping(x) + +is.coord(x) + +is.Coord(x) # Deprecated + +is.ggproto(x) + +is.facet(x) + +# Layer related tests +is.layer(x) + +is.geom(x) + +is.stat(x) + +is.position(x) + +# Scale and guide related tests +is.scale(x) + +is.guide(x) + +is.guides(x) + +# Theme related tests +is.theme(x) + +is.element(x) + +is.margin(x) +} +\arguments{ +\item{x}{An object to test} +} +\description{ +Reports whether x is a type of object +} +\keyword{internal} From 13b8d3633a835645fe534b8c256c53c435fbaa7a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 13 Sep 2024 09:38:42 +0200 Subject: [PATCH 43/44] abolish `uniquecols()`'s rownames --- R/stat-summary.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/stat-summary.R b/R/stat-summary.R index b1607e5ea2..a32eda8ca0 100644 --- a/R/stat-summary.R +++ b/R/stat-summary.R @@ -228,7 +228,7 @@ summarise_by_x <- function(data, summary, ...) { # @keyword internal uniquecols <- function(df) { df <- df[1, sapply(df, is_unique), drop = FALSE] - rownames(df) <- seq_len(nrow(df)) + attr(df, "row.names") <- .set_row_names(nrow(df)) df } From d7092aa3ccb3e99efd74c9ed87bf16caa44a0cdb Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 13 Sep 2024 10:05:20 +0200 Subject: [PATCH 44/44] move `is.*()` functions to class definitions --- R/aes.R | 4 +++ R/coord-.R | 13 +++++++ R/facet-.R | 4 +++ R/geom-.R | 3 ++ R/ggproto.R | 3 ++ R/guide-.R | 4 +++ R/guides-.R | 4 +++ R/layer.R | 4 +++ R/margins.R | 4 +++ R/plot.R | 7 ++++ R/position-.R | 4 +++ R/scale-.R | 4 +++ R/stat-.R | 4 +++ R/theme-elements.R | 4 +++ R/theme.R | 4 +++ R/utilities-checks.R | 83 -------------------------------------------- man/is_tests.Rd | 53 ++++++++++++++-------------- 17 files changed, 96 insertions(+), 110 deletions(-) diff --git a/R/aes.R b/R/aes.R index c5275d0cd8..d739289b0e 100644 --- a/R/aes.R +++ b/R/aes.R @@ -102,6 +102,10 @@ aes <- function(x, y, ...) { rename_aes(aes) } +#' @export +#' @rdname is_tests +is.mapping <- function(x) inherits(x, "uneval") + # Wrap symbolic objects in quosures but pull out constants out of # quosures for backward-compatibility new_aesthetic <- function(x, env = globalenv()) { diff --git a/R/coord-.R b/R/coord-.R index 2292df6828..a57abc7691 100644 --- a/R/coord-.R +++ b/R/coord-.R @@ -225,6 +225,19 @@ Coord <- ggproto("Coord", } ) + +#' @export +#' @rdname is_tests +is.coord <- function(x) inherits(x, "Coord") + +#' @export +#' @rdname is_tests +#' @usage is.Coord(x) # Deprecated +is.Coord <- function(x) { + deprecate_soft0("3.5.2", "is.Coord()", "is.coord()") + is.coord(x) +} + # Renders an axis with the correct orientation or zeroGrob if no axis should be # generated render_axis <- function(panel_params, axis, scale, position, theme) { diff --git a/R/facet-.R b/R/facet-.R index 9d63ff7e66..8faafc1428 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -266,6 +266,10 @@ Facet <- ggproto("Facet", NULL, } ) +#' @export +#' @rdname is_tests +is.facet <- function(x) inherits(x, "Facet") + # Helpers ----------------------------------------------------------------- #' Quote faceting variables diff --git a/R/geom-.R b/R/geom-.R index 9753511017..c5a1ab275d 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -236,6 +236,9 @@ Geom <- ggproto("Geom", ) +#' @export +#' @rdname is_tests +is.geom <- function(x) inherits(x, "Geom") eval_from_theme <- function(aesthetics, theme) { themed <- is_themed_aes(aesthetics) diff --git a/R/ggproto.R b/R/ggproto.R index e2c7b11733..6165a9707d 100644 --- a/R/ggproto.R +++ b/R/ggproto.R @@ -98,6 +98,9 @@ ggproto <- function(`_class` = NULL, `_inherit` = NULL, ...) { e } +#' @export +#' @rdname is_tests +is.ggproto <- function(x) inherits(x, "ggproto") #' @export #' @rdname ggproto diff --git a/R/guide-.R b/R/guide-.R index 08dbc7b7c5..dd63949cd2 100644 --- a/R/guide-.R +++ b/R/guide-.R @@ -66,6 +66,10 @@ new_guide <- function(..., available_aes = "any", super) { ) } +#' @export +#' @rdname is_tests +is.guide <- function(x) inherits(x, "Guide") + #' @section Guides: #' #' The `guide_*()` functions, such as `guide_legend()` return an object that diff --git a/R/guides-.R b/R/guides-.R index 33ea9745fb..d250c78025 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -109,6 +109,10 @@ guides <- function(...) { NULL } +#' @export +#' @rdname is_tests +is.guides <- function(x) inherits(x, "Guides") + # Class ------------------------------------------------------------------- # Guides object encapsulates multiple guides and their state. diff --git a/R/layer.R b/R/layer.R index 2f245676ce..3fd89cf3f7 100644 --- a/R/layer.R +++ b/R/layer.R @@ -202,6 +202,10 @@ layer <- function(geom = NULL, stat = NULL, ) } +#' @export +#' @rdname is_tests +is.layer <- function(x) inherits(x, "Layer") + validate_mapping <- function(mapping, call = caller_env()) { if (!is.mapping(mapping)) { msg <- "{.arg mapping} must be created by {.fn aes}." diff --git a/R/margins.R b/R/margins.R index aa9457a85b..7104a7d330 100644 --- a/R/margins.R +++ b/R/margins.R @@ -9,6 +9,10 @@ margin <- function(t = 0, r = 0, b = 0, l = 0, unit = "pt") { u } +#' @export +#' @rdname is_tests +is.margin <- function(x) inherits(x, "margin") + #' Create a text grob with the proper location and margins #' #' `titleGrob()` is called when creating titles and labels for axes, legends, diff --git a/R/plot.R b/R/plot.R index f78fe2c9aa..95c7f2f8a0 100644 --- a/R/plot.R +++ b/R/plot.R @@ -147,6 +147,13 @@ ggplot.function <- function(data = NULL, mapping = aes(), ..., )) } +#' Reports whether x is a type of object +#' @param x An object to test +#' @keywords internal +#' @export +#' @name is_tests +is.ggplot <- function(x) inherits(x, "ggplot") + plot_clone <- function(plot) { p <- plot p$scales <- plot$scales$clone() diff --git a/R/position-.R b/R/position-.R index 559c6c68d0..88d6f914a9 100644 --- a/R/position-.R +++ b/R/position-.R @@ -69,6 +69,10 @@ Position <- ggproto("Position", } ) +#' @export +#' @rdname is_tests +is.position <- function(x) inherits(x, "Position") + #' Convenience function to transform all position variables. #' #' @param trans_x,trans_y Transformation functions for x and y aesthetics. diff --git a/R/scale-.R b/R/scale-.R index 8d61dd345b..878cc602b9 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -357,6 +357,10 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name = ) } +#' @export +#' @rdname is_tests +is.scale <- function(x) inherits(x, "Scale") + #' @section Scales: #' #' All `scale_*` functions like [scale_x_continuous()] return a `Scale*` diff --git a/R/stat-.R b/R/stat-.R index 2d56937b06..11cdbc67d6 100644 --- a/R/stat-.R +++ b/R/stat-.R @@ -218,3 +218,7 @@ Stat <- ggproto("Stat", } ) + +#' @export +#' @rdname is_tests +is.stat <- function(x) inherits(x, "Stat") diff --git a/R/theme-elements.R b/R/theme-elements.R index 747bb0cf78..7e5de2f777 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -202,6 +202,10 @@ element_geom <- function( pointsize = 1.5, pointshape = 19 ) +#' @export +#' @rdname is_tests +is.element <- function(x) inherits(x, "element") + #' @export print.element <- function(x, ...) utils::str(x) diff --git a/R/theme.R b/R/theme.R index 668ce9700e..2eedd300c5 100644 --- a/R/theme.R +++ b/R/theme.R @@ -543,6 +543,10 @@ theme <- function(..., ) } +#' @export +#' @rdname is_tests +is.theme <- function(x) inherits(x, "theme") + # check whether theme is complete is_theme_complete <- function(x) isTRUE(attr(x, "complete", exact = TRUE)) diff --git a/R/utilities-checks.R b/R/utilities-checks.R index 2f5f2b7da9..a1ed1b5091 100644 --- a/R/utilities-checks.R +++ b/R/utilities-checks.R @@ -1,86 +1,3 @@ -# Tests ------------------------------------------------------------------- - -#' Reports whether x is a type of object -#' @param x An object to test -#' @keywords internal -#' @export -#' @name is_tests -is.ggplot <- function(x) inherits(x, "ggplot") - -#' @export -#' @rdname is_tests -is.mapping <- function(x) inherits(x, "uneval") - -#' @export -#' @rdname is_tests -is.coord <- function(x) inherits(x, "Coord") - -#' @export -#' @rdname is_tests -#' @usage is.Coord(x) # Deprecated -is.Coord <- function(x) { - deprecate_soft0("3.5.2", "is.Coord()", "is.coord()") - is.coord(x) -} - -#' @export -#' @rdname is_tests -is.ggproto <- function(x) inherits(x, "ggproto") - -#' @export -#' @rdname is_tests -is.facet <- function(x) inherits(x, "Facet") - -#' @export -#' @rdname is_tests -#' @usage -#' # Layer related tests -#' is.layer(x) -is.layer <- function(x) inherits(x, "Layer") - -#' @export -#' @rdname is_tests -is.geom <- function(x) inherits(x, "Geom") - -#' @export -#' @rdname is_tests -is.stat <- function(x) inherits(x, "Stat") - -#' @export -#' @rdname is_tests -is.position <- function(x) inherits(x, "Position") - -#' @export -#' @usage -#' # Scale and guide related tests -#' is.scale(x) -#' @rdname is_tests -is.scale <- function(x) inherits(x, "Scale") - -#' @export -#' @rdname is_tests -is.guide <- function(x) inherits(x, "Guide") - -#' @export -#' @rdname is_tests -is.guides <- function(x) inherits(x, "Guides") - -#' @export -#' @usage -#' # Theme related tests -#' is.theme(x) -#' @rdname is_tests -is.theme <- function(x) inherits(x, "theme") - -#' @export -#' @rdname is_tests -is.element <- function(x) inherits(x, "element") - -#' @export -#' @rdname is_tests -is.margin <- function(x) inherits(x, "margin") - -# Checks ------------------------------------------------------------------ # Extra checks in addition to the ones in import-standalone-types-check.R diff --git a/man/is_tests.Rd b/man/is_tests.Rd index 472896fe47..62ded3db09 100644 --- a/man/is_tests.Rd +++ b/man/is_tests.Rd @@ -1,59 +1,58 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utilities-checks.R -\name{is_tests} -\alias{is_tests} -\alias{is.ggplot} +% Please edit documentation in R/ggproto.R, R/aes.R, R/geom-.R, R/coord-.R, +% R/facet-.R, R/stat-.R, R/theme-elements.R, R/guide-.R, R/layer.R, +% R/guides-.R, R/margins.R, R/plot.R, R/position-.R, R/scale-.R, R/theme.R +\name{is.ggproto} +\alias{is.ggproto} \alias{is.mapping} +\alias{is.geom} \alias{is.coord} \alias{is.Coord} -\alias{is.ggproto} \alias{is.facet} -\alias{is.layer} -\alias{is.geom} \alias{is.stat} -\alias{is.position} -\alias{is.scale} +\alias{is.element} \alias{is.guide} +\alias{is.layer} \alias{is.guides} -\alias{is.theme} -\alias{is.element} \alias{is.margin} +\alias{is_tests} +\alias{is.ggplot} +\alias{is.position} +\alias{is.scale} +\alias{is.theme} \title{Reports whether x is a type of object} \usage{ -is.ggplot(x) +is.ggproto(x) is.mapping(x) +is.geom(x) + is.coord(x) is.Coord(x) # Deprecated -is.ggproto(x) - is.facet(x) -# Layer related tests -is.layer(x) - -is.geom(x) - is.stat(x) -is.position(x) - -# Scale and guide related tests -is.scale(x) +is.element(x) is.guide(x) +is.layer(x) + is.guides(x) -# Theme related tests -is.theme(x) +is.margin(x) -is.element(x) +is.ggplot(x) -is.margin(x) +is.position(x) + +is.scale(x) + +is.theme(x) } \arguments{ \item{x}{An object to test}