From 0154671cf9dee96c1b553aac1a1bf94de4651375 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 10 Mar 2025 10:12:31 +0100 Subject: [PATCH 01/30] import S7 --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 753e7dd49a..0a33c39ea4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,6 +39,7 @@ Imports: isoband, lifecycle (> 1.0.1), rlang (>= 1.1.0), + S7, scales (>= 1.3.0), stats, vctrs (>= 0.6.0), From b4163e0361fd208316dae808b0067101fd5eba64 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 10 Mar 2025 10:47:13 +0100 Subject: [PATCH 02/30] convert theme to S7 --- NAMESPACE | 3 +-- R/plot-construction.R | 6 +---- R/theme.R | 50 +++++++++++++++++++++---------------- tests/testthat/test-theme.R | 2 +- 4 files changed, 31 insertions(+), 30 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index b58765ecc1..5470079408 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,8 +1,8 @@ # Generated by roxygen2: do not edit by hand +S3method("$","ggplot2::theme") S3method("$",ggproto) S3method("$",ggproto_parent) -S3method("$",theme) S3method("$<-",uneval) S3method("+",gg) S3method("[",mapped_discrete) @@ -66,7 +66,6 @@ S3method(ggplot_add,data.frame) S3method(ggplot_add,default) S3method(ggplot_add,labels) S3method(ggplot_add,list) -S3method(ggplot_add,theme) S3method(ggplot_add,uneval) S3method(ggplot_build,ggplot) S3method(ggplot_build,ggplot_built) diff --git a/R/plot-construction.R b/R/plot-construction.R index cd18fc8310..33b2763d78 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -133,11 +133,7 @@ ggplot_add.function <- function(object, plot, object_name) { "i" = "Did you forget to add parentheses, as in {.fn {object_name}}?" )) } -#' @export -ggplot_add.theme <- function(object, plot, object_name) { - plot$theme <- add_theme(plot$theme, object) - plot -} + #' @export ggplot_add.Scale <- function(object, plot, object_name) { plot$scales$add(object) diff --git a/R/theme.R b/R/theme.R index dfe986fc62..77241af6c6 100644 --- a/R/theme.R +++ b/R/theme.R @@ -549,25 +549,39 @@ theme <- function(..., el }) } - structure( + S7::new_object( elements, - class = c("theme", "gg"), complete = complete, validate = validate ) } +theme <- S7::new_class( + "theme", S7::new_S3_class("gg"), + properties = list( + complete = S7::class_logical, + validate = S7::class_logical + ), + constructor = theme +) + +S7::method(ggplot_add, theme) <- function(object, plot, object_name, ...) { + plot$theme <- add_theme(plot$theme, object) + plot +} + #' @export #' @rdname is_tests -is.theme <- function(x) inherits(x, "theme") +is.theme <- function(x) S7::S7_inherits(x, theme) # check whether theme is complete -is_theme_complete <- function(x) isTRUE(attr(x, "complete", exact = TRUE)) +is_theme_complete <- function(x) { + is.theme(x) && isTRUE(x@complete) +} # check whether theme should be validated is_theme_validate <- function(x) { - validate <- attr(x, "validate", exact = TRUE) - isTRUE(validate %||% TRUE) + !is.theme(x) || isTRUE(x@validate) } check_theme <- function(theme, tree = get_element_tree(), call = caller_env()) { @@ -604,16 +618,9 @@ complete_theme <- function(theme = NULL, default = theme_get()) { } check_object(default, is.theme, "a {.cls theme} object") theme <- plot_theme(list(theme = theme), default = default) - - # Using `theme(!!!theme)` drops `NULL` entries, so strip most attributes and - # construct a new theme - attributes(theme) <- list(names = attr(theme, "names")) - structure( - theme, - class = c("theme", "gg"), - complete = TRUE, # This theme is complete and has no missing elements - validate = FALSE # Settings have already been validated - ) + theme@complete <- TRUE + theme@validate <- FALSE + theme } # Combine plot defaults with current theme to get complete theme for a plot @@ -677,13 +684,12 @@ add_theme <- function(t1, t2, t2name, call = caller_env()) { } ) - # make sure the "complete" attribute is set; this can be missing - # when t1 is an empty list - attr(t1, "complete") <- is_theme_complete(t1) + if (!is.theme(t1) && is.list(t1)) { + t1 <- theme(!!!t1) + } # Only validate if both themes should be validated - attr(t1, "validate") <- - is_theme_validate(t1) && is_theme_validate(t2) + t1@validate <- is_theme_validate(t1) && is_theme_validate(t2) t1 } @@ -949,7 +955,7 @@ combine_elements <- function(e1, e2) { } #' @export -`$.theme` <- function(x, ...) { +`$.ggplot2::theme` <- function(x, ...) { .subset2(x, ...) } diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 8d74b4038f..70dd36f4f2 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -634,7 +634,7 @@ test_that("complete_theme completes a theme", { # `NULL` should match default gray <- theme_gray() new <- complete_theme(NULL, default = gray) - expect_equal(new, gray, ignore_attr = "validate") + expect_equal(S7::S7_data(new), S7::S7_data(gray)) # Elements are propagated new <- complete_theme(theme(axis.line = element_line("red")), gray) From 7fce100aee1b6ee46b8e9accf4fd6da0b0cb0f16 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 10 Mar 2025 20:07:51 +0100 Subject: [PATCH 03/30] Reimplement S3 into S7 --- NAMESPACE | 11 +++--- R/aes.R | 58 +++++++++++++++----------------- R/layer.R | 6 ++-- R/plot-construction.R | 7 ++-- R/quick-plot.R | 2 +- R/summarise-plot.R | 2 +- man/aes.Rd | 4 +-- tests/testthat/_snaps/aes.md | 2 +- tests/testthat/_snaps/fortify.md | 4 +-- tests/testthat/test-add.R | 4 +-- tests/testthat/test-aes.R | 6 ++-- tests/testthat/test-fortify.R | 2 +- tests/testthat/test-geom-.R | 4 +-- 13 files changed, 51 insertions(+), 61 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 5470079408..ee904b7c9e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,14 +3,14 @@ S3method("$","ggplot2::theme") S3method("$",ggproto) S3method("$",ggproto_parent) -S3method("$<-",uneval) +S3method("$<-","ggplot2::mapping") S3method("+",gg) +S3method("[","ggplot2::mapping") S3method("[",mapped_discrete) -S3method("[",uneval) +S3method("[<-","ggplot2::mapping") S3method("[<-",mapped_discrete) -S3method("[<-",uneval) S3method("[[",ggproto) -S3method("[[<-",uneval) +S3method("[[<-","ggplot2::mapping") S3method(.DollarNames,ggproto) S3method(as.data.frame,mapped_discrete) S3method(as.list,ggproto) @@ -66,7 +66,6 @@ S3method(ggplot_add,data.frame) S3method(ggplot_add,default) S3method(ggplot_add,labels) S3method(ggplot_add,list) -S3method(ggplot_add,uneval) S3method(ggplot_build,ggplot) S3method(ggplot_build,ggplot_built) S3method(ggplot_gtable,ggplot_built) @@ -105,6 +104,7 @@ S3method(predictdf,default) S3method(predictdf,glm) S3method(predictdf,locfit) S3method(predictdf,loess) +S3method(print,"ggplot2::mapping") S3method(print,element) S3method(print,ggplot) S3method(print,ggplot2_bins) @@ -112,7 +112,6 @@ S3method(print,ggproto) S3method(print,ggproto_method) S3method(print,rel) S3method(print,theme) -S3method(print,uneval) S3method(scale_type,Date) S3method(scale_type,POSIXt) S3method(scale_type,character) diff --git a/R/aes.R b/R/aes.R index 045d388d8a..d02282eb5a 100644 --- a/R/aes.R +++ b/R/aes.R @@ -46,8 +46,8 @@ NULL #' 'AsIs' variables. #' #' @family aesthetics documentation -#' @return A list with class `uneval`. Components of the list are either -#' quosures or constants. +#' @return An S7 object representing a list with class `mapping`. Components of +#' the list are either quosures or constants. #' @export #' @examples #' aes(x = mpg, y = wt) @@ -105,13 +105,21 @@ aes <- function(x, y, ...) { inject(aes(!!!args)) }) - aes <- new_aes(args, env = parent.frame()) - rename_aes(aes) + mapping(rename_aes(args), env = parent.frame()) } +mapping <- S7::new_class( + "mapping", parent = S7::new_S3_class("gg"), + constructor = function(x, env = globalenv()) { + check_object(x, is.list, "a {.cls list}") + x <- lapply(x, new_aesthetic, env = env) + S7::new_object(x) + } +) + #' @export #' @rdname is_tests -is.mapping <- function(x) inherits(x, "uneval") +is.mapping <- function(x) S7::S7_inherits(x, mapping) # Wrap symbolic objects in quosures but pull out constants out of # quosures for backward-compatibility @@ -130,14 +138,9 @@ new_aesthetic <- function(x, env = globalenv()) { x } -new_aes <- function(x, env = globalenv()) { - check_object(x, is.list, "a {.cls list}") - x <- lapply(x, new_aesthetic, env = env) - structure(x, class = "uneval") -} #' @export -print.uneval <- function(x, ...) { +`print.ggplot2::mapping` <- function(x, ...) { cat("Aesthetic mapping: \n") if (length(x) == 0) { @@ -153,25 +156,22 @@ print.uneval <- function(x, ...) { } #' @export -"[.uneval" <- function(x, i, ...) { - new_aes(NextMethod()) +"[.ggplot2::mapping" <- function(x, i, ...) { + mapping(NextMethod()) } # If necessary coerce replacements to quosures for compatibility #' @export -"[[<-.uneval" <- function(x, i, value) { - new_aes(NextMethod()) +"[[<-.ggplot2::mapping" <- function(x, i, value) { + mapping(NextMethod()) } #' @export -"$<-.uneval" <- function(x, i, value) { - # Can't use NextMethod() because of a bug in R 3.1 - x <- unclass(x) - x[[i]] <- value - new_aes(x) +"$<-.ggplot2::mapping" <- function(x, i, value) { + mapping(NextMethod()) } #' @export -"[<-.uneval" <- function(x, i, value) { - new_aes(NextMethod()) +"[<-.ggplot2::mapping" <- function(x, i, value) { + mapping(NextMethod()) } #' Standardise aesthetic names @@ -212,8 +212,7 @@ substitute_aes <- function(x, fun = standardise_aes_symbols, ...) { x <- lapply(x, function(aesthetic) { as_quosure(fun(quo_get_expr(aesthetic), ...), env = environment(aesthetic)) }) - class(x) <- "uneval" - x + mapping(x) } # x is a quoted expression from inside aes() standardise_aes_symbols <- function(x) { @@ -311,7 +310,7 @@ aes_ <- function(x, y, ...) { } } mapping <- lapply(mapping, as_quosure_aes) - structure(rename_aes(mapping), class = "uneval") + mapping(rename_aes(mapping)) } #' @rdname aes_ @@ -337,7 +336,7 @@ aes_string <- function(x, y, ...) { new_aesthetic(x, env = caller_env) }) - structure(rename_aes(mapping), class = "uneval") + mapping(rename_aes(mapping)) } #' @export @@ -358,10 +357,7 @@ aes_all <- function(vars) { # Quosure the symbols in the empty environment because they can only # refer to the data mask - structure( - lapply(vars, function(x) new_quosure(as.name(x), emptyenv())), - class = "uneval" - ) + mapping(lapply(vars, function(x) new_quosure(as.name(x), emptyenv()))) } #' Automatic aesthetic mapping @@ -396,7 +392,7 @@ aes_auto <- function(data = NULL, ...) { aes <- c(aes, args[names(args) != "data"]) } - structure(rename_aes(aes), class = "uneval") + mapping(rename_aes(aes)) } mapped_aesthetics <- function(x) { diff --git a/R/layer.R b/R/layer.R index 6be74b5d72..28ee7bb817 100644 --- a/R/layer.R +++ b/R/layer.R @@ -213,7 +213,7 @@ validate_mapping <- function(mapping, call = caller_env()) { } # For backward compatibility with pre-tidy-eval layers - new_aes(mapping) + mapping(mapping) } Layer <- ggproto("Layer", NULL, @@ -265,7 +265,7 @@ Layer <- ggproto("Layer", NULL, setup_layer = function(self, data, plot) { # For annotation geoms, it is useful to be able to ignore the default aes if (isTRUE(self$inherit.aes)) { - self$computed_mapping <- defaults(self$mapping, plot$mapping) + self$computed_mapping <- mapping(defaults(self$mapping, plot$mapping)) # Inherit size as linewidth from global mapping if (self$geom$rename_size && @@ -275,8 +275,6 @@ Layer <- ggproto("Layer", NULL, self$computed_mapping$size <- plot$mapping$size deprecate_soft0("3.4.0", I("Using `size` aesthetic for lines"), I("`linewidth`")) } - # defaults() strips class, but it needs to be preserved for now - class(self$computed_mapping) <- "uneval" } else { self$computed_mapping <- self$mapping } diff --git a/R/plot-construction.R b/R/plot-construction.R index 33b2763d78..449b916999 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -156,11 +156,8 @@ ggplot_add.Guides <- function(object, plot, object_name) { } plot } -#' @export -ggplot_add.uneval <- function(object, plot, object_name) { - plot$mapping <- defaults(object, plot$mapping) - # defaults() doesn't copy class, so copy it. - class(plot$mapping) <- class(object) +S7::method(ggplot_add, mapping) <- function(object, plot, object_name) { + plot$mapping <- mapping(defaults(object, plot$mapping)) plot } #' @export diff --git a/R/quick-plot.R b/R/quick-plot.R index 38cfd895fc..cf0b68d788 100644 --- a/R/quick-plot.R +++ b/R/quick-plot.R @@ -78,7 +78,7 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, is_constant <- (!names(exprs) %in% ggplot_global$all_aesthetics) | vapply(exprs, quo_is_call, logical(1), name = "I") - mapping <- new_aes(exprs[!is_missing & !is_constant], env = parent.frame()) + mapping <- mapping(exprs[!is_missing & !is_constant], env = parent.frame()) consts <- exprs[is_constant] diff --git a/R/summarise-plot.R b/R/summarise-plot.R index 9ab046cb8c..6498e5f30d 100644 --- a/R/summarise-plot.R +++ b/R/summarise-plot.R @@ -124,7 +124,7 @@ summarise_coord <- function(p) { summarise_layers <- function(p) { check_inherits(p, "ggplot_built") - # Default mappings. Make sure it's a regular list instead of an uneval + # Default mappings. Make sure it's a regular list instead of a mapping # object. default_mapping <- unclass(p$plot$mapping) diff --git a/man/aes.Rd b/man/aes.Rd index ed77c5d39e..adce5c7ad4 100644 --- a/man/aes.Rd +++ b/man/aes.Rd @@ -17,8 +17,8 @@ The names for x and y aesthetics are typically omitted because they are so common; all other aesthetics must be named.} } \value{ -A list with class \code{uneval}. Components of the list are either -quosures or constants. +An S7 object representing a list with class \code{mapping}. Components of +the list are either quosures or constants. } \description{ Aesthetic mappings describe how variables in the data are mapped to visual diff --git a/tests/testthat/_snaps/aes.md b/tests/testthat/_snaps/aes.md index 4a891eacbe..46d72876e7 100644 --- a/tests/testthat/_snaps/aes.md +++ b/tests/testthat/_snaps/aes.md @@ -54,7 +54,7 @@ Don't know how to get alternative usage for `foo`. -# new_aes() checks its inputs +# mapping() checks its inputs `x` must be a , not an integer vector. diff --git a/tests/testthat/_snaps/fortify.md b/tests/testthat/_snaps/fortify.md index 605829d9d8..5baf41b576 100644 --- a/tests/testthat/_snaps/fortify.md +++ b/tests/testthat/_snaps/fortify.md @@ -1,6 +1,6 @@ -# fortify.default proves a helpful error with class uneval +# fortify.default proves a helpful error with mapping class - `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`, not a object. + `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`, not a object. i Did you accidentally pass `aes()` to the `data` argument? # fortify.default can handle healthy data-frame-like objects diff --git a/tests/testthat/test-add.R b/tests/testthat/test-add.R index a860a55845..285510d8de 100644 --- a/tests/testthat/test-add.R +++ b/tests/testthat/test-add.R @@ -1,4 +1,4 @@ -test_that("mapping class is preserved when adding uneval objects", { +test_that("mapping class is preserved when adding mapping objects", { p <- ggplot(mtcars) + aes(wt, mpg) - expect_identical(class(p$mapping), "uneval") + expect_s7_class(p$mapping, mapping) }) diff --git a/tests/testthat/test-aes.R b/tests/testthat/test-aes.R index a42b4a3ae1..86c93de5d7 100644 --- a/tests/testthat/test-aes.R +++ b/tests/testthat/test-aes.R @@ -67,7 +67,7 @@ test_that("aes evaluated in environment where plot created", { test_that("constants are not wrapped in quosures", { aes <- aes(1L, "foo", 1.5) - expect_identical(unclass(aes), list(x = 1L, y = "foo", 1.5)) + expect_identical(S7::S7_data(aes), list(x = 1L, y = "foo", 1.5)) }) test_that("assignment methods wrap symbolic objects in quosures", { @@ -195,8 +195,8 @@ test_that("alternative_aes_extract_usage() can inspect the call", { expect_snapshot_error(alternative_aes_extract_usage(x)) }) -test_that("new_aes() checks its inputs", { - expect_snapshot_error(new_aes(1:5)) +test_that("mapping() checks its inputs", { + expect_snapshot_error(mapping(1:5)) }) # Visual tests ------------------------------------------------------------ diff --git a/tests/testthat/test-fortify.R b/tests/testthat/test-fortify.R index e98edad549..2650884942 100644 --- a/tests/testthat/test-fortify.R +++ b/tests/testthat/test-fortify.R @@ -56,7 +56,7 @@ test_that("spatial polygons have correct ordering", { ) }) -test_that("fortify.default proves a helpful error with class uneval", { +test_that("fortify.default proves a helpful error with mapping class", { expect_snapshot_error(ggplot(aes(x = x))) }) diff --git a/tests/testthat/test-geom-.R b/tests/testthat/test-geom-.R index 6766178f22..3c22324c91 100644 --- a/tests/testthat/test-geom-.R +++ b/tests/testthat/test-geom-.R @@ -53,7 +53,7 @@ test_that("updating geom aesthetic defaults preserves class and order", { updated_defaults <- GeomPoint$default_aes - expect_s3_class(updated_defaults, "uneval") + expect_s7_class(updated_defaults, mapping) intended_defaults <- original_defaults intended_defaults[["colour"]] <- "red" @@ -75,7 +75,7 @@ test_that("updating stat aesthetic defaults preserves class and order", { updated_defaults <- StatBin$default_aes - expect_s3_class(updated_defaults, "uneval") + expect_s7_class(updated_defaults, mapping) intended_defaults <- original_defaults intended_defaults[["y"]] <- expr(after_stat(density)) From 32ccdb29663953052cebf978f20f73295fb56697 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 11 Mar 2025 13:18:00 +0100 Subject: [PATCH 04/30] convert labels to S7 --- NAMESPACE | 1 - R/labels.R | 32 +++++++++++++++++--------------- R/plot-construction.R | 3 +-- tests/testthat/test-labels.R | 8 ++++---- 4 files changed, 22 insertions(+), 22 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index ee904b7c9e..2ea66959d0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -64,7 +64,6 @@ S3method(ggplot_add,Scale) S3method(ggplot_add,by) S3method(ggplot_add,data.frame) S3method(ggplot_add,default) -S3method(ggplot_add,labels) S3method(ggplot_add,list) S3method(ggplot_build,ggplot) S3method(ggplot_build,ggplot_built) diff --git a/R/labels.R b/R/labels.R index a736e2bf54..a53f6ea1bc 100644 --- a/R/labels.R +++ b/R/labels.R @@ -175,22 +175,24 @@ setup_plot_labels <- function(plot, layers, data) { #' p + #' labs(title = "title") + #' labs(title = NULL) -labs <- function(..., title = waiver(), subtitle = waiver(), caption = waiver(), - tag = waiver(), dictionary = waiver(), alt = waiver(), - alt_insight = waiver()) { - # .ignore_empty = "all" is needed to allow trailing commas, which is NOT a trailing comma for dots_list() as it's in ... - args <- dots_list(..., title = title, subtitle = subtitle, caption = caption, - tag = tag, alt = allow_lambda(alt), alt_insight = alt_insight, - dictionary = dictionary, .ignore_empty = "all") +labs <- S7::new_class( + "labels", parent = S7::new_S3_class("gg"), + constructor = function(..., title = waiver(), subtitle = waiver(), + caption = waiver(), tag = waiver(), dictionary = waiver(), + alt = waiver(), alt_insight = waiver()) { + # .ignore_empty = "all" is needed to allow trailing commas, which is NOT a trailing comma for dots_list() as it's in ... + args <- dots_list(..., title = title, subtitle = subtitle, caption = caption, + tag = tag, alt = allow_lambda(alt), alt_insight = alt_insight, + dictionary = dictionary, .ignore_empty = "all") - is_waive <- vapply(args, is.waiver, logical(1)) - args <- args[!is_waive] - # remove duplicated arguments - args <- args[!duplicated(names(args))] - args <- rename_aes(args) - - structure(args, class = c("labels", "gg")) -} + is_waive <- vapply(args, is.waiver, logical(1)) + args <- args[!is_waive] + # remove duplicated arguments + args <- args[!duplicated(names(args))] + args <- rename_aes(args) + S7::new_object(args) + } +) #' @rdname labs #' @export diff --git a/R/plot-construction.R b/R/plot-construction.R index 449b916999..b4b3ec0eef 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -139,8 +139,7 @@ ggplot_add.Scale <- function(object, plot, object_name) { plot$scales$add(object) plot } -#' @export -ggplot_add.labels <- function(object, plot, object_name) { +S7::method(ggplot_add, labs) <- function(object, plot, object_name) { update_labels(plot, object) } #' @export diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 172eca6364..90162b530f 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -25,16 +25,16 @@ test_that("setting guide labels works", { expect_identical(labs(color = "my label")$colour, "my label") # No extra elements exists - expect_equal(labs(title = "my title"), list(title = "my title"), ignore_attr = TRUE) # formal argument - expect_equal(labs(colour = "my label"), list(colour = "my label"), ignore_attr = TRUE) # dot - expect_equal(labs(foo = "bar"), list(foo = "bar"), ignore_attr = TRUE) # non-existent param + expect_length(labs(title = "my title"), 1) # formal argument + expect_length(labs(colour = "my label"), 1) # dot + expect_length(labs(foo = "bar"), 1) # non-existent param # labs() has list-splicing semantics params <- list(title = "my title", tag = "A)") expect_identical(labs(!!!params)$tag, "A)") # NULL is preserved - expect_equal(labs(title = NULL), list(title = NULL), ignore_attr = TRUE) + expect_length(labs(title = NULL), 1) # ggtitle works in the same way as labs() expect_identical(ggtitle("my title")$title, "my title") From 032ca6af9ed03069a34692b29dac43373c0e01de Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 12 Mar 2025 16:21:52 +0100 Subject: [PATCH 05/30] make S7 class_ggplot --- DESCRIPTION | 5 +++-- R/all-classes.R | 10 ++++++++++ R/plot.R | 30 +++++++++++++++++++++++++----- 3 files changed, 38 insertions(+), 7 deletions(-) create mode 100644 R/all-classes.R diff --git a/DESCRIPTION b/DESCRIPTION index 0a33c39ea4..de58fdc300 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -94,6 +94,7 @@ Collate: 'compat-plyr.R' 'utilities.R' 'aes.R' + 'all-classes.R' 'utilities-checks.R' 'legend-draw.R' 'geom-.R' @@ -202,10 +203,11 @@ Collate: 'limits.R' 'margins.R' 'performance.R' + 'theme.R' + 'plot.R' 'plot-build.R' 'plot-construction.R' 'plot-last.R' - 'plot.R' 'position-.R' 'position-collide.R' 'position-dodge.R' @@ -272,7 +274,6 @@ Collate: 'stat-ydensity.R' 'summarise-plot.R' 'summary.R' - 'theme.R' 'theme-defaults.R' 'theme-current.R' 'theme-sub.R' diff --git a/R/all-classes.R b/R/all-classes.R new file mode 100644 index 0000000000..8c0f67865c --- /dev/null +++ b/R/all-classes.R @@ -0,0 +1,10 @@ + +class_gg <- S7::new_class("gg", abstract = TRUE) +class_scale <- S7::new_S3_class("Scale") +class_guides <- S7::new_S3_class("Guides") +class_coord <- S7::new_S3_class("Coord") +class_facet <- S7::new_S3_class("Facet") +class_layer <- S7::new_S3_class("Layer") +class_scales_list <- S7::new_S3_class("ScalesList") +class_layout <- S7::new_S3_class("Layout") +class_ggproto <- S7::new_S3_class("ggproto") diff --git a/R/plot.R b/R/plot.R index f6a6aaeb49..037e694c41 100644 --- a/R/plot.R +++ b/R/plot.R @@ -1,3 +1,23 @@ +#' @include all-classes.R +#' @include theme.R + +class_ggplot <- S7::new_class( + name = "ggplot", parent = class_gg, + properties = list( + data = S7::class_any, + layers = S7::class_list, + scales = class_scales_list, + guides = class_guides, + mapping = mapping, + theme = theme, + coordinates = class_coord, + facet = class_facet, + layout = class_layout, + labels = labs, + plot_env = S7::class_environment + ) +) + #' Create a new ggplot #' #' `ggplot()` initializes a ggplot object. It can be used to @@ -120,19 +140,19 @@ ggplot.default <- function(data = NULL, mapping = aes(), ..., data <- fortify(data, ...) - p <- structure(list( + p <- class_ggplot( data = data, layers = list(), scales = scales_list(), guides = guides_list(), mapping = mapping, - theme = list(), + theme = theme(), coordinates = coord_cartesian(default = TRUE), facet = facet_null(), plot_env = environment, layout = ggproto(NULL, Layout), - labels = list() - ), class = c("gg", "ggplot")) + labels = labs() + ) set_last_plot(p) p @@ -153,7 +173,7 @@ ggplot.function <- function(data = NULL, mapping = aes(), ..., #' @keywords internal #' @export #' @name is_tests -is.ggplot <- function(x) inherits(x, "ggplot") +is.ggplot <- function(x) S7::S7_inherits(x, class_ggplot) plot_clone <- function(plot) { p <- plot From c37317b75a29d5493b674a94481465bec5cf5069 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 12 Mar 2025 16:50:57 +0100 Subject: [PATCH 06/30] Use `@` as accessor --- R/facet-.R | 2 +- R/guides-.R | 2 +- R/labels.R | 36 +++++++++---------- R/layer.R | 14 ++++---- R/plot-build.R | 52 +++++++++++++-------------- R/plot-construction.R | 26 +++++++------- R/plot.R | 3 +- R/summarise-plot.R | 4 +-- R/summary.R | 20 +++++------ R/theme.R | 7 +++- R/zzz.R | 1 + man/ggplot_add.Rd | 2 +- tests/testthat/helper-plot-data.R | 6 ++-- tests/testthat/test-add.R | 2 +- tests/testthat/test-aes.R | 4 +-- tests/testthat/test-coord-.R | 2 +- tests/testthat/test-facet-strips.R | 4 +-- tests/testthat/test-geom-polygon.R | 2 +- tests/testthat/test-geom-sf.R | 28 +++++++-------- tests/testthat/test-guide-.R | 16 ++++----- tests/testthat/test-guide-colorbar.R | 4 +-- tests/testthat/test-guide-legend.R | 2 +- tests/testthat/test-guides.R | 10 +++--- tests/testthat/test-labels.R | 20 +++++------ tests/testthat/test-layer.R | 14 ++++---- tests/testthat/test-scales.R | 4 +-- tests/testthat/test-theme.R | 54 ++++++++++++++-------------- 27 files changed, 173 insertions(+), 168 deletions(-) diff --git a/R/facet-.R b/R/facet-.R index 0c120beba3..5ebb3a94f9 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -401,7 +401,7 @@ get_strip_labels <- function(plot = get_last_plot()) { plot <- ggplot_build(plot) layout <- plot$layout$layout params <- plot$layout$facet_params - plot$plot$facet$format_strip_labels(layout, params) + plot$plot@facet$format_strip_labels(layout, params) } # A "special" value, currently not used but could be used to determine diff --git a/R/guides-.R b/R/guides-.R index 83ced80cd7..3432807373 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -832,7 +832,7 @@ get_guide_data <- function(plot = get_last_plot(), aesthetic, panel = 1L) { if (!aesthetic %in% c("x", "y", "x.sec", "y.sec", "theta", "r")) { # Non position guides: check if aesthetic in colnames of key - keys <- lapply(plot$plot$guides$params, `[[`, "key") + keys <- lapply(plot$plot@guides$params, `[[`, "key") keep <- vapply(keys, function(x) any(colnames(x) %in% aesthetic), logical(1)) keys <- switch(sum(keep) + 1, NULL, keys[[which(keep)]], keys[keep]) return(keys) diff --git a/R/labels.R b/R/labels.R index a53f6ea1bc..146b9826f2 100644 --- a/R/labels.R +++ b/R/labels.R @@ -12,7 +12,7 @@ #' update_labels(p, list(colour = "Fail silently")) update_labels <- function(p, labels) { p <- plot_clone(p) - p$labels <- defaults(labels, p$labels) + p@labels <- labs(!!!defaults(labels, p@labels)) p } @@ -69,7 +69,7 @@ setup_plot_labels <- function(plot, layers, data) { # Warn for spurious labels that don't have a mapping. # Note: sometimes, 'x' and 'y' might not have a mapping, like in # `geom_function()`. We can display these labels anyway, so we include them. - plot_labels <- plot$labels + plot_labels <- plot@labels known_labels <- c(names(labels), fn_fmls_names(labs), "x", "y") extra_labels <- setdiff(names(plot_labels), known_labels) @@ -102,7 +102,7 @@ setup_plot_labels <- function(plot, layers, data) { }) } - defaults(plot_labels, labels) + labs(!!!defaults(plot_labels, labels)) } #' Modify axis, legend, and plot labels @@ -220,7 +220,7 @@ ggtitle <- function(label, subtitle = waiver()) { get_labs <- function(plot = get_last_plot()) { plot <- ggplot_build(plot) - labs <- plot$plot$labels + labs <- plot$plot@labels xy_labs <- rename( c(x = plot$layout$resolve_label(plot$layout$panel_scales_x[[1]], labs), @@ -231,7 +231,7 @@ get_labs <- function(plot = get_last_plot()) { labs <- defaults(xy_labs, labs) - guides <- plot$plot$guides + guides <- plot$plot@guides if (length(guides$aesthetics) == 0) { return(labs) } @@ -281,19 +281,19 @@ get_alt_text <- function(p, ...) { } #' @export get_alt_text.ggplot <- function(p, ...) { - alt <- p$labels[["alt"]] %||% "" + alt <- p@labels[["alt"]] %||% "" if (!is.function(alt)) { return(alt) } - p$labels[["alt"]] <- NULL + p@labels[["alt"]] <- NULL build <- ggplot_build(p) - build$plot$labels[["alt"]] <- alt + build$plot@labels[["alt"]] <- alt get_alt_text(build) } #' @export get_alt_text.ggplot_built <- function(p, ...) { - alt <- p$plot$labels[["alt"]] %||% "" - p$plot$labels[["alt"]] <- NULL + alt <- p$plot@labels[["alt"]] %||% "" + p$plot@labels[["alt"]] <- NULL if (is.function(alt)) alt(p$plot) else alt } #' @export @@ -347,8 +347,8 @@ get_alt_text.gtable <- function(p, ...) { #' generate_alt_text <- function(p) { # Combine titles - if (!is.null(p$label$title %||% p$labels$subtitle)) { - title <- sub("\\.?$", "", c(p$labels$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]) } @@ -364,7 +364,7 @@ generate_alt_text <- function(p) { axes <- safe_string(axes) # Get layer types - layers <- vapply(p$layers, function(l) snake_class(l$geom), character(1)) + layers <- vapply(p@layers, function(l) snake_class(l$geom), character(1)) layers <- sub("_", " ", sub("^geom_", "", unique0(layers))) if (length(layers) == 1) { layers <- paste0(" using a ", layers, " layer") @@ -375,8 +375,8 @@ generate_alt_text <- function(p) { # Combine alt <- paste0(title, "A plot", axes, layers, ".") - if (!is.null(p$labels$alt_insight)) { - alt <- paste0(alt, " ", p$labels$alt_insight) + if (!is.null(p@labels$alt_insight)) { + alt <- paste0(alt, " ", p@labels$alt_insight) } as.character(alt) } @@ -384,12 +384,12 @@ safe_string <- function(string) { if (length(string) == 0) "" else string } scale_description <- function(p, name) { - scale <- p$scales$get_scales(name) + scale <- p@scales$get_scales(name) if (is.null(scale)) { - lab <- p$labels[[name]] + lab <- p@labels[[name]] type <- "the" } else { - lab <- scale$make_title(scale$name %|W|% p$labels[[name]]) + lab <- scale$make_title(scale$name %|W|% p@labels[[name]]) type <- "a continuous" if (scale$is_discrete()) type <- "a discrete" if (inherits(scale, "ScaleBinned")) type <- "a binned" diff --git a/R/layer.R b/R/layer.R index 28ee7bb817..83d1a6d3ed 100644 --- a/R/layer.R +++ b/R/layer.R @@ -265,14 +265,14 @@ Layer <- ggproto("Layer", NULL, setup_layer = function(self, data, plot) { # For annotation geoms, it is useful to be able to ignore the default aes if (isTRUE(self$inherit.aes)) { - self$computed_mapping <- mapping(defaults(self$mapping, plot$mapping)) + self$computed_mapping <- mapping(defaults(self$mapping, plot@mapping)) # Inherit size as linewidth from global mapping if (self$geom$rename_size && - "size" %in% names(plot$mapping) && + "size" %in% names(plot@mapping) && !"linewidth" %in% names(self$computed_mapping) && "linewidth" %in% self$geom$aesthetics()) { - self$computed_mapping$size <- plot$mapping$size + self$computed_mapping$size <- plot@mapping$size deprecate_soft0("3.4.0", I("Using `size` aesthetic for lines"), I("`linewidth`")) } } else { @@ -300,7 +300,7 @@ Layer <- ggproto("Layer", NULL, # Evaluate aesthetics evaled <- eval_aesthetics(aesthetics, data) - plot$scales$add_defaults(evaled, plot$plot_env) + plot@scales$add_defaults(evaled, plot@plot_env) # Check for discouraged usage in mapping warn_for_aes_extract_usage(aesthetics, data[setdiff(names(data), "PANEL")]) @@ -370,7 +370,7 @@ Layer <- ggproto("Layer", NULL, if (length(new) == 0) return(data) # data needs to be non-scaled - data_orig <- plot$scales$backtransform_df(data) + data_orig <- plot@scales$backtransform_df(data) # Add map stat output to aesthetics stat_data <- eval_aesthetics( @@ -387,11 +387,11 @@ Layer <- ggproto("Layer", NULL, stat_data <- data_frame0(!!!stat_data) # Add any new scales, if needed - plot$scales$add_defaults(stat_data, plot$plot_env) + plot@scales$add_defaults(stat_data, plot@plot_env) # Transform the values, if the scale say it's ok # (see stat_spoke for one exception) if (self$stat$retransform) { - stat_data <- plot$scales$transform_df(stat_data) + stat_data <- plot@scales$transform_df(stat_data) } stat_data <- cleanup_mismatched_data(stat_data, nrow(data), "after_stat") diff --git a/R/plot-build.R b/R/plot-build.R index f855dddd78..93d2aab2f2 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -39,28 +39,28 @@ ggplot_build.ggplot_built <- function(plot) { #' @export ggplot_build.ggplot <- function(plot) { plot <- plot_clone(plot) - if (length(plot$layers) == 0) { + if (length(plot@layers) == 0) { plot <- plot + geom_blank() } - layers <- plot$layers + layers <- plot@layers data <- rep(list(NULL), length(layers)) - scales <- plot$scales + scales <- plot@scales # Allow all layers to make any final adjustments based # on raw input data and plot info - data <- by_layer(function(l, d) l$layer_data(plot$data), layers, data, "computing layer data") + data <- by_layer(function(l, d) l$layer_data(plot@data), layers, data, "computing layer data") data <- by_layer(function(l, d) l$setup_layer(d, plot), layers, data, "setting up layer") # Initialise panels, add extra data for margins & missing faceting # variables, and add on a PANEL variable to data - layout <- create_layout(plot$facet, plot$coordinates, plot$layout) - data <- layout$setup(data, plot$data, plot$plot_env) + layout <- create_layout(plot@facet, plot@coordinates, plot@layout) + data <- layout$setup(data, plot@data, plot@plot_env) # Compute aesthetics to produce data with generalised variable names data <- by_layer(function(l, d) l$compute_aesthetics(d, plot), layers, data, "computing aesthetics") - plot$labels <- setup_plot_labels(plot, layers, data) + plot@labels <- setup_plot_labels(plot, layers, data) data <- .ignore_data(data) # Transform all scales @@ -80,7 +80,7 @@ ggplot_build.ggplot <- function(plot) { data <- by_layer(function(l, d) l$map_statistic(d, plot), layers, data, "mapping stat to aesthetics") # Make sure missing (but required) aesthetics are added - plot$scales$add_missing(c("x", "y"), plot$plot_env) + plot@scales$add_missing(c("x", "y"), plot@plot_env) # Reparameterise geoms from (e.g.) y and width to ymin and ymax data <- by_layer(function(l, d) l$compute_geom_1(d), layers, data, "setting up geom") @@ -98,27 +98,27 @@ ggplot_build.ggplot <- function(plot) { data <- layout$map_position(data) # Hand off position guides to layout - layout$setup_panel_guides(plot$guides, plot$layers) + layout$setup_panel_guides(plot@guides, plot@layers) # Complete the plot's theme - plot$theme <- plot_theme(plot) + plot@theme <- plot_theme(plot) # Train and map non-position scales and guides npscales <- scales$non_position_scales() if (npscales$n() > 0) { - npscales$set_palettes(plot$theme) + npscales$set_palettes(plot@theme) lapply(data, npscales$train_df) - plot$guides <- plot$guides$build(npscales, plot$layers, plot$labels, data, plot$theme) + plot@guides <- plot@guides$build(npscales, plot@layers, plot@labels, data, plot@theme) data <- lapply(data, npscales$map_df) } else { # Only keep custom guides if there are no non-position scales - plot$guides <- plot$guides$get_custom() + plot@guides <- plot@guides$get_custom() } data <- .expose_data(data) # Fill in defaults etc. data <- by_layer( - function(l, d) l$compute_geom_2(d, theme = plot$theme), + function(l, d) l$compute_geom_2(d, theme = plot@theme), layers, data, "setting up geom aesthetics" ) @@ -129,7 +129,7 @@ ggplot_build.ggplot <- function(plot) { data <- layout$finish_data(data) # Consolidate alt-text - plot$labels$alt <- get_alt_text(plot) + plot@labels$alt <- get_alt_text(plot) structure( list(data = data, layout = layout, plot = plot), @@ -169,7 +169,7 @@ layer_scales <- get_panel_scales get_layer_grob <- function(plot = get_last_plot(), i = 1L) { b <- ggplot_build(plot) - b$plot$layers[[i]]$draw_geom(b$data[[i]], b$layout) + b$plot@layers[[i]]$draw_geom(b$data[[i]], b$layout) } #' @export @@ -196,7 +196,7 @@ layer_grob <- get_layer_grob #' @export ggplot_gtable <- function(data) { # Attaching the plot env to be fetched by deprecations etc. - attach_plot_env(data$plot$plot_env) + attach_plot_env(data$plot@plot_env) UseMethod('ggplot_gtable') } @@ -206,33 +206,33 @@ ggplot_gtable.ggplot_built <- function(data) { plot <- data$plot layout <- data$layout data <- data$data - theme <- plot$theme + theme <- plot@theme - geom_grobs <- by_layer(function(l, d) l$draw_geom(d, layout), plot$layers, data, "converting geom to grob") + geom_grobs <- by_layer(function(l, d) l$draw_geom(d, layout), plot@layers, data, "converting geom to grob") - plot_table <- layout$render(geom_grobs, data, theme, plot$labels) + plot_table <- layout$render(geom_grobs, data, theme, plot@labels) # Legends - legend_box <- plot$guides$assemble(theme) + legend_box <- plot@guides$assemble(theme) plot_table <- table_add_legends(plot_table, legend_box, theme) # Title title <- element_render( - theme, "plot.title", plot$labels$title, + theme, "plot.title", plot@labels$title, margin_y = TRUE, margin_x = TRUE ) title_height <- grobHeight(title) # Subtitle subtitle <- element_render( - theme, "plot.subtitle", plot$labels$subtitle, + theme, "plot.subtitle", plot@labels$subtitle, margin_y = TRUE, margin_x = TRUE ) subtitle_height <- grobHeight(subtitle) # whole plot annotation caption <- element_render( - theme, "plot.caption", plot$labels$caption, + theme, "plot.caption", plot@labels$caption, margin_y = TRUE, margin_x = TRUE ) caption_height <- grobHeight(caption) @@ -283,7 +283,7 @@ ggplot_gtable.ggplot_built <- function(data) { plot_table <- gtable_add_grob(plot_table, caption, name = "caption", t = -1, b = -1, l = caption_l, r = caption_r, clip = "off") - plot_table <- table_add_tag(plot_table, plot$labels$tag, theme) + plot_table <- table_add_tag(plot_table, plot@labels$tag, theme) # Margins plot_margin <- calc_element("plot.margin", theme) %||% margin() @@ -298,7 +298,7 @@ ggplot_gtable.ggplot_built <- function(data) { } # add alt-text as attribute - attr(plot_table, "alt-label") <- plot$labels$alt + attr(plot_table, "alt-label") <- plot@labels$alt plot_table } diff --git a/R/plot-construction.R b/R/plot-construction.R index b4b3ec0eef..f645aae6a4 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -123,7 +123,7 @@ ggplot_add.NULL <- function(object, plot, object_name) { } #' @export ggplot_add.data.frame <- function(object, plot, object_name) { - plot$data <- object + plot@data <- object plot } #' @export @@ -136,7 +136,7 @@ ggplot_add.function <- function(object, plot, object_name) { #' @export ggplot_add.Scale <- function(object, plot, object_name) { - plot$scales$add(object) + plot@scales$add(object) plot } S7::method(ggplot_add, labs) <- function(object, plot, object_name) { @@ -144,33 +144,33 @@ S7::method(ggplot_add, labs) <- function(object, plot, object_name) { } #' @export ggplot_add.Guides <- function(object, plot, object_name) { - if (is.guides(plot$guides)) { + if (is.guides(plot@guides)) { # We clone the guides object to prevent modify-in-place of guides - old <- plot$guides + old <- plot@guides new <- ggproto(NULL, old) new$add(object) - plot$guides <- new + plot@guides <- new } else { - plot$guides <- object + plot@guides <- object } plot } S7::method(ggplot_add, mapping) <- function(object, plot, object_name) { - plot$mapping <- mapping(defaults(object, plot$mapping)) + plot@mapping <- mapping(defaults(object, plot@mapping)) plot } #' @export ggplot_add.Coord <- function(object, plot, object_name) { - if (!isTRUE(plot$coordinates$default)) { + if (!isTRUE(plot@coordinates$default)) { cli::cli_inform("Coordinate system already present. Adding new coordinate system, which will replace the existing one.") } - plot$coordinates <- object + plot@coordinates <- object plot } #' @export ggplot_add.Facet <- function(object, plot, object_name) { - plot$facet <- object + plot@facet <- object plot } #' @export @@ -187,9 +187,9 @@ ggplot_add.by <- function(object, plot, object_name) { #' @export ggplot_add.Layer <- function(object, plot, object_name) { - layers_names <- new_layer_names(object, names2(plot$layers)) - plot$layers <- append(plot$layers, object) - names(plot$layers) <- layers_names + layers_names <- new_layer_names(object, names2(plot@layers)) + plot@layers <- append(plot@layers, object) + names(plot@layers) <- layers_names plot } diff --git a/R/plot.R b/R/plot.R index 037e694c41..46c27f5e28 100644 --- a/R/plot.R +++ b/R/plot.R @@ -177,8 +177,7 @@ is.ggplot <- function(x) S7::S7_inherits(x, class_ggplot) plot_clone <- function(plot) { p <- plot - p$scales <- plot$scales$clone() - + p@scales <- plot@scales$clone() p } diff --git a/R/summarise-plot.R b/R/summarise-plot.R index 6498e5f30d..aa192e777a 100644 --- a/R/summarise-plot.R +++ b/R/summarise-plot.R @@ -126,9 +126,9 @@ summarise_layers <- function(p) { # Default mappings. Make sure it's a regular list instead of a mapping # object. - default_mapping <- unclass(p$plot$mapping) + default_mapping <- unclass(p$plot@mapping) - layer_mappings <- lapply(p$plot$layers, function(layer) { + layer_mappings <- lapply(p$plot@layers, function(layer) { defaults(layer$mapping, default_mapping) }) diff --git a/R/summary.R b/R/summary.R index 4a227a3599..ce9a4ddd7b 100644 --- a/R/summary.R +++ b/R/summary.R @@ -15,27 +15,27 @@ summary.ggplot <- function(object, ...) { "\n", sep = "" ) - if (!is.null(object$data)) { + if (!is.null(object@data)) { output <- paste( - "data: ", paste(names(object$data), collapse = ", "), - " [", nrow(object$data), "x", ncol(object$data), "] ", + "data: ", paste(names(object@data), collapse = ", "), + " [", nrow(object@data), "x", ncol(object@data), "] ", "\n", sep = "") cat(wrap(output)) } - if (length(object$mapping) > 0) { - cat("mapping: ", clist(object$mapping), "\n", sep = "") + if (length(object@mapping) > 0) { + cat("mapping: ", clist(object@mapping), "\n", sep = "") } - if (object$scales$n() > 0) { - cat("scales: ", paste(object$scales$input(), collapse = ", "), "\n") + if (object@scales$n() > 0) { + cat("scales: ", paste(object@scales$input(), collapse = ", "), "\n") } - vars <- object$facet$vars() + vars <- object@facet$vars() vars <- if (length(vars) > 0) paste0("~", vars) else "" cat("faceting: ", paste0(vars, collapse = ", "), "\n") - if (length(object$layers) > 0) + if (length(object@layers) > 0) cat("-----------------------------------\n") - invisible(lapply(object$layers, function(x) { + invisible(lapply(object@layers, function(x) { print(x) cat("\n") })) diff --git a/R/theme.R b/R/theme.R index 77241af6c6..1e914fffe9 100644 --- a/R/theme.R +++ b/R/theme.R @@ -625,7 +625,12 @@ complete_theme <- function(theme = NULL, default = theme_get()) { # Combine plot defaults with current theme to get complete theme for a plot plot_theme <- function(x, default = get_theme()) { - theme <- x$theme + if (S7::S7_inherits(x)) { + theme <- x@theme + } else { + theme <- x$theme + } + # apply theme defaults appropriately if needed if (is_theme_complete(theme)) { diff --git a/R/zzz.R b/R/zzz.R index 398cb7d7b6..249d96a1be 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -30,6 +30,7 @@ on_load( vars <- dplyr::vars } ) +on_load(S7::methods_register()) .onLoad <- function(...) { run_on_load() } diff --git a/man/ggplot_add.Rd b/man/ggplot_add.Rd index c71d6f863e..91f386c306 100644 --- a/man/ggplot_add.Rd +++ b/man/ggplot_add.Rd @@ -4,7 +4,7 @@ \alias{ggplot_add} \title{Add custom objects to ggplot} \usage{ -ggplot_add(object, plot, object_name) +ggplot_add(object, plot, ...) } \arguments{ \item{object}{An object to add to the plot} diff --git a/tests/testthat/helper-plot-data.R b/tests/testthat/helper-plot-data.R index 13e36d861a..74911db54c 100644 --- a/tests/testthat/helper-plot-data.R +++ b/tests/testthat/helper-plot-data.R @@ -5,8 +5,8 @@ cdata <- function(plot) { lapply(pieces$data, function(d) { dapply(d, "PANEL", function(panel_data) { scales <- pieces$layout$get_scales(panel_data$PANEL[1]) - panel_params <- plot$coordinates$setup_panel_params(scales$x, scales$y, params = pieces$layout$coord_params) - plot$coordinates$transform(panel_data, panel_params) + panel_params <- plot@coordinates$setup_panel_params(scales$x, scales$y, params = pieces$layout$coord_params) + plot@coordinates$transform(panel_data, panel_params) }) }) } @@ -18,7 +18,7 @@ pranges <- function(plot) { y_ranges <- lapply(layout$panel_scales_y, function(scale) scale$get_limits()) - npscales <- plot$scales$non_position_scales() + npscales <- plot@scales$non_position_scales() npranges <- lapply(npscales$scales$scales, function(scale) scale$get_limits()) diff --git a/tests/testthat/test-add.R b/tests/testthat/test-add.R index 285510d8de..1f08648e49 100644 --- a/tests/testthat/test-add.R +++ b/tests/testthat/test-add.R @@ -1,4 +1,4 @@ test_that("mapping class is preserved when adding mapping objects", { p <- ggplot(mtcars) + aes(wt, mpg) - expect_s7_class(p$mapping, mapping) + expect_s7_class(p@mapping, mapping) }) diff --git a/tests/testthat/test-aes.R b/tests/testthat/test-aes.R index 86c93de5d7..2e230c87e4 100644 --- a/tests/testthat/test-aes.R +++ b/tests/testthat/test-aes.R @@ -96,13 +96,13 @@ test_that("assignment methods pull unwrap constants from quosures", { test_that("quosures are squashed when creating default label for a mapping", { p <- ggplot(mtcars) + aes(!!quo(identity(!!quo(cyl)))) - labels <- ggplot_build(p)$plot$labels + labels <- ggplot_build(p)$plot@labels expect_identical(labels$x, "identity(cyl)") }) test_that("labelling doesn't cause error if aesthetic is NULL", { p <- ggplot(mtcars) + aes(x = NULL) - labels <- ggplot_build(p)$plot$labels + labels <- ggplot_build(p)$plot@labels expect_identical(labels$x, "x") }) diff --git a/tests/testthat/test-coord-.R b/tests/testthat/test-coord-.R index b0cef2de26..e171f6680d 100644 --- a/tests/testthat/test-coord-.R +++ b/tests/testthat/test-coord-.R @@ -34,7 +34,7 @@ test_that("guide names are not removed by `train_panel_guides()`", { layout <- data$layout data <- data$data - layout$setup_panel_guides(guides_list(NULL), plot$layers) + layout$setup_panel_guides(guides_list(NULL), plot@layers) # Line showing change in outcome expect_named(layout$panel_params[[1]]$guides$aesthetics, c("x", "y", "x.sec", "y.sec")) diff --git a/tests/testthat/test-facet-strips.R b/tests/testthat/test-facet-strips.R index d13f8d500c..a44d4c0a43 100644 --- a/tests/testthat/test-facet-strips.R +++ b/tests/testthat/test-facet-strips.R @@ -5,9 +5,9 @@ strip_layout <- function(p) { data <- data$data theme <- plot_theme(plot) - geom_grobs <- Map(function(l, d) l$draw_geom(d, layout), plot$layers, data) + geom_grobs <- Map(function(l, d) l$draw_geom(d, layout), plot@layers, data) - facet <- layout$render(geom_grobs, data, theme, plot$labels) + facet <- layout$render(geom_grobs, data, theme, plot@labels) layout <- facet$layout strip_layout <- layout[grepl("^strip", layout$name), 1:4] as.list(strip_layout) diff --git a/tests/testthat/test-geom-polygon.R b/tests/testthat/test-geom-polygon.R index 3cf3636655..1e74c43b9d 100644 --- a/tests/testthat/test-geom-polygon.R +++ b/tests/testthat/test-geom-polygon.R @@ -40,7 +40,7 @@ test_that("geom_polygon is closed before munching", { coord_polar() built <- ggplot_build(p) - coord <- built$plot$coordinates + coord <- built$plot@coordinates data <- built$data[[1]] param <- built$layout$panel_params[[1]] diff --git a/tests/testthat/test-geom-sf.R b/tests/testthat/test-geom-sf.R index 29f5da8323..f1df3ad59d 100644 --- a/tests/testthat/test-geom-sf.R +++ b/tests/testthat/test-geom-sf.R @@ -30,24 +30,24 @@ test_that("geom_sf() determines the legend type automatically", { } # test the automatic choice - expect_true(fun_geom_sf(mp, TRUE)$plot$layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mp, TRUE)$plot$layers[[1]]$computed_geom_params$legend, "point") + expect_true(fun_geom_sf(mp, TRUE)$plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mp, TRUE)$plot@layers[[1]]$computed_geom_params$legend, "point") - expect_true(fun_geom_sf(mls, TRUE)$plot$layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mls, TRUE)$plot$layers[[1]]$computed_geom_params$legend, "line") + expect_true(fun_geom_sf(mls, TRUE)$plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mls, TRUE)$plot@layers[[1]]$computed_geom_params$legend, "line") - expect_true(fun_geom_sf(mpol, TRUE)$plot$layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mpol, TRUE)$plot$layers[[1]]$computed_geom_params$legend, "other") + expect_true(fun_geom_sf(mpol, TRUE)$plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mpol, TRUE)$plot@layers[[1]]$computed_geom_params$legend, "other") # test that automatic choice can be overridden manually - expect_true(fun_geom_sf(mp, "point")$plot$layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mp, "point")$plot$layers[[1]]$computed_geom_params$legend, "point") + expect_true(fun_geom_sf(mp, "point")$plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mp, "point")$plot@layers[[1]]$computed_geom_params$legend, "point") - expect_true(fun_geom_sf(mls, "point")$plot$layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mls, "point")$plot$layers[[1]]$computed_geom_params$legend, "point") + expect_true(fun_geom_sf(mls, "point")$plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mls, "point")$plot@layers[[1]]$computed_geom_params$legend, "point") - expect_true(fun_geom_sf(mpol, "point")$plot$layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mpol, "point")$plot$layers[[1]]$computed_geom_params$legend, "point") + expect_true(fun_geom_sf(mpol, "point")$plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mpol, "point")$plot@layers[[1]]$computed_geom_params$legend, "point") }) test_that("geom_sf() determines the legend type from mapped geometry column", { @@ -68,12 +68,12 @@ test_that("geom_sf() determines the legend type from mapped geometry column", { p <- ggplot_build( ggplot(d_sf) + geom_sf(aes(geometry = g_point, colour = "a")) ) - expect_identical(p$plot$layers[[1]]$computed_geom_params$legend, "point") + expect_identical(p$plot@layers[[1]]$computed_geom_params$legend, "point") p <- ggplot_build( ggplot(d_sf) + geom_sf(aes(geometry = g_line, colour = "a")) ) - expect_identical(p$plot$layers[[1]]$computed_geom_params$legend, "line") + expect_identical(p$plot@layers[[1]]$computed_geom_params$legend, "line") }) test_that("geom_sf() removes rows containing missing aes", { diff --git a/tests/testthat/test-guide-.R b/tests/testthat/test-guide-.R index 4f66920c3e..e5f9c34bc6 100644 --- a/tests/testthat/test-guide-.R +++ b/tests/testthat/test-guide-.R @@ -14,29 +14,29 @@ test_that("plotting does not induce state changes in guides", { geom_point() + guides - snapshot <- serialize(as.list(p$guides), NULL) + snapshot <- serialize(as.list(p@guides), NULL) grob <- ggplotGrob(p) - expect_identical(as.list(p$guides), unserialize(snapshot)) + expect_identical(as.list(p@guides), unserialize(snapshot)) }) test_that("adding guides doesn't change plot state", { p1 <- ggplot(mtcars, aes(disp, mpg)) - expect_length(p1$guides$guides, 0) + expect_length(p1@guides$guides, 0) p2 <- p1 + guides(y = guide_axis(angle = 45)) - expect_length(p1$guides$guides, 0) - expect_length(p2$guides$guides, 1) + expect_length(p1@guides$guides, 0) + expect_length(p2@guides$guides, 1) p3 <- p2 + guides(y = guide_axis(angle = 90)) - expect_length(p3$guides$guides, 1) - expect_equal(p3$guides$guides[[1]]$params$angle, 90) - expect_equal(p2$guides$guides[[1]]$params$angle, 45) + expect_length(p3@guides$guides, 1) + expect_equal(p3@guides$guides[[1]]$params$angle, 90) + expect_equal(p2@guides$guides[[1]]$params$angle, 45) }) test_that("dots are checked when making guides", { diff --git a/tests/testthat/test-guide-colorbar.R b/tests/testthat/test-guide-colorbar.R index 7cfd96a2f1..b13d4d1b48 100644 --- a/tests/testthat/test-guide-colorbar.R +++ b/tests/testthat/test-guide-colorbar.R @@ -12,10 +12,10 @@ test_that("Colorbar respects show.legend in layer", { df <- data_frame(x = 1:3, y = 1) p <- ggplot(df, aes(x = x, y = y, color = x)) + geom_point(size = 20, shape = 21, show.legend = FALSE) - expect_length(ggplot_build(p)$plot$guides$guides, 0L) + expect_length(ggplot_build(p)$plot@guides$guides, 0L) p <- ggplot(df, aes(x = x, y = y, color = x)) + geom_point(size = 20, shape = 21, show.legend = TRUE) - expect_length(ggplot_build(p)$plot$guides$guides, 1L) + expect_length(ggplot_build(p)$plot@guides$guides, 1L) }) test_that("colorsteps and bins checks the breaks format", { diff --git a/tests/testthat/test-guide-legend.R b/tests/testthat/test-guide-legend.R index cd2311ee93..d877853649 100644 --- a/tests/testthat/test-guide-legend.R +++ b/tests/testthat/test-guide-legend.R @@ -128,7 +128,7 @@ test_that("legends can be forced to display unrelated geoms", { ) b <- ggplot_build(p) - legend <- b$plot$guides$params[[1]] + legend <- b$plot@guides$params[[1]] expect_equal( legend$decor[[1]]$data$fill, diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 1a3a31143a..a0763f82b8 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -7,11 +7,11 @@ test_that("guide_none() can be used in non-position scales", { built <- ggplot_build(p) plot <- built$plot - guides <- guides_list(plot$guides) + guides <- guides_list(plot@guides) guides <- guides$build( - plot$scales, - plot$layers, - plot$labels + plot@scales, + plot@layers, + plot@labels ) expect_length(guides$guides, 0) @@ -156,7 +156,7 @@ test_that("empty guides are dropped", { expect_equal(nrow(gd), 0) # Draw guides - guides <- p$plot$guides$assemble(theme_gray()) + guides <- p$plot@guides$assemble(theme_gray()) # All guide-boxes should be empty expect_true(is.zero(guides)) diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 90162b530f..77b1b845b6 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -134,7 +134,7 @@ test_that("position axis label hierarchy works as intended", { geom_point(size = 5) p <- ggplot_build(p) - resolve_label <- function(x) p$layout$resolve_label(x, p$plot$labels) + resolve_label <- function(x) p$layout$resolve_label(x, p$plot@labels) # In absence of explicit title, get title from mapping expect_identical( @@ -159,7 +159,7 @@ test_that("position axis label hierarchy works as intended", { # Guide titles overrule scale names p$layout$setup_panel_guides( guides_list(list(x = guide_axis("quuX"), y = guide_axis("corgE"))), - p$plot$layers + p$plot@layers ) expect_identical( resolve_label(scale_x_continuous("Baz")), @@ -186,7 +186,7 @@ test_that("position axis label hierarchy works as intended", { p$layout$setup_panel_guides( guides_list(list(x = guide_axis("quuX"), y = guide_axis("corgE"), x.sec = guide_axis("waldo"), y.sec = guide_axis("fred"))), - p$plot$layers + p$plot@layers ) expect_identical( resolve_label(xsec), @@ -236,7 +236,7 @@ test_that("moving guide positions lets titles follow", { list(x = guide_axis("baz", position = "bottom"), y = guide_axis("qux", position = "left")) ), - p$plot$layers + p$plot@layers ) labs <- get_labs(p) expect <- list(x = "baz", x.sec = NULL, y = "qux", y.sec = NULL) @@ -248,7 +248,7 @@ test_that("moving guide positions lets titles follow", { list(x = guide_axis("baz", position = "top"), y = guide_axis("qux", position = "right")) ), - p$plot$layers + p$plot@layers ) labs <- get_labs(p) expect_identical(labs[names(expect)], expect) @@ -262,7 +262,7 @@ test_that("moving guide positions lets titles follow", { x.sec = guide_axis("quux"), y.sec = guide_axis("corge")) ), - p$plot$layers + p$plot@layers ) labs <- get_labs(p) expect[c("x.sec", "y.sec")] <- list("quux", "corge") @@ -281,16 +281,16 @@ test_that("label dictionaries work", { )) p <- ggplot_build(p) - x <- p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels) + x <- p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot@labels) expect_equal(x$primary, "Displacement") - y <- p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels) + y <- p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot@labels) expect_equal(y$primary, "Miles per gallon") - shape <- p$plot$guides$get_params("shape")$title + shape <- p$plot@guides$get_params("shape")$title expect_equal(shape, "Number of cylinders") - size <- p$plot$guides$get_params("size")$title + size <- p$plot@guides$get_params("size")$title expect_equal(size, "Rear axle ratio") }) diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index 59970c7db5..fa8f54b66d 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -91,10 +91,10 @@ test_that("layers are stateless except for the computed params", { df <- data.frame(x = 1:10, y = 1:10) p <- ggplot(df) + geom_col(aes(x = x, y = y), width = 0.8, fill = "red") - col_layer <- as.list(p$layers[[1]]) + col_layer <- as.list(p@layers[[1]]) stateless_names <- setdiff(names(col_layer), c("computed_geom_params", "computed_stat_params", "computed_mapping")) invisible(ggplotGrob(p)) - expect_identical(as.list(p$layers[[1]])[stateless_names], col_layer[stateless_names]) + expect_identical(as.list(p@layers[[1]])[stateless_names], col_layer[stateless_names]) }) test_that("inherit.aes works", { @@ -105,7 +105,7 @@ test_that("inherit.aes works", { geom_col(aes(x = x, y = y), inherit.aes = FALSE) invisible(ggplotGrob(p1)) invisible(ggplotGrob(p2)) - expect_identical(p1$layers[[1]]$computed_mapping, p2$layers[[1]]$computed_mapping) + expect_identical(p1@layers[[1]]$computed_mapping, p2@layers[[1]]$computed_mapping) }) test_that("retransform works on computed aesthetics in `map_statistic`", { @@ -114,8 +114,8 @@ test_that("retransform works on computed aesthetics in `map_statistic`", { expect_equal(get_layer_data(p)$y, c(3, 5)) # To double check: should be original values when `retransform = FALSE` - parent <- p$layers[[1]]$stat - p$layers[[1]]$stat <- ggproto(NULL, parent, retransform = FALSE) + parent <- p@layers[[1]]$stat + p@layers[[1]]$stat <- ggproto(NULL, parent, retransform = FALSE) expect_equal(get_layer_data(p)$y, c(9, 25)) }) @@ -145,10 +145,10 @@ test_that("layer warns for constant aesthetics", { test_that("layer names can be resolved", { p <- ggplot() + geom_point() + geom_point() - expect_equal(names(p$layers), c("geom_point", "geom_point...2")) + expect_equal(names(p@layers), c("geom_point", "geom_point...2")) p <- ggplot() + geom_point(name = "foo") + geom_point(name = "bar") - expect_equal(names(p$layers), c("foo", "bar")) + expect_equal(names(p@layers), c("foo", "bar")) l <- geom_point(name = "foobar") expect_snapshot(p + l + l, error = TRUE) diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 0a750e4821..7670bdf1c7 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -2,10 +2,10 @@ test_that("building a plot does not affect its scales", { dat <- data_frame(x = rnorm(20), y = rnorm(20)) p <- ggplot(dat, aes(x, y)) + geom_point() - expect_length(p$scales$scales, 0) + expect_length(p@scales$scales, 0) ggplot_build(p) - expect_length(p$scales$scales, 0) + expect_length(p@scales$scales, 0) }) test_that("ranges update only for variables listed in aesthetics", { diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 70dd36f4f2..5af8e74b5c 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -56,34 +56,34 @@ test_that("adding theme object to ggplot object with + operator works", { ## test with complete theme p <- ggplot(data.frame(x = 1:3), aes(x, x)) + geom_point() + theme_grey() p <- p + theme(axis.title = element_text(size = 20)) - expect_true(p$theme$axis.title$size == 20) + expect_true(p@theme$axis.title$size == 20) # Should update specified properties, but not reset other properties p <- p + theme(text = element_text(colour = 'red')) - expect_true(p$theme$text$colour == 'red') + expect_true(p@theme$text$colour == 'red') tt <- theme_grey()$text tt$colour <- 'red' expect_true(tt$inherit.blank) tt$inherit.blank <- FALSE - expect_identical(p$theme$text, tt) + expect_identical(p@theme$text, tt) ## test without complete theme p <- ggplot(data.frame(x = 1:3), aes(x, x)) + geom_point() p <- p + theme(axis.title = element_text(size = 20)) - expect_true(p$theme$axis.title$size == 20) + expect_true(p@theme$axis.title$size == 20) # Should update specified properties, but not reset other properties p <- p + theme(text = element_text(colour = 'red')) - expect_true(p$theme$text$colour == 'red') - expect_null(p$theme$text$family) - expect_null(p$theme$text$face) - expect_null(p$theme$text$size) - expect_null(p$theme$text$hjust) - expect_null(p$theme$text$vjust) - expect_null(p$theme$text$angle) - expect_null(p$theme$text$lineheight) - expect_null(p$theme$text$margin) - expect_null(p$theme$text$debug) + expect_true(p@theme$text$colour == 'red') + expect_null(p@theme$text$family) + expect_null(p@theme$text$face) + expect_null(p@theme$text$size) + expect_null(p@theme$text$hjust) + expect_null(p@theme$text$vjust) + expect_null(p@theme$text$angle) + expect_null(p@theme$text$lineheight) + expect_null(p@theme$text$margin) + expect_null(p@theme$text$debug) ## stepwise addition of partial themes is identical to one-step addition p <- ggplot(data.frame(x = 1:3), aes(x, x)) + geom_point() @@ -95,7 +95,7 @@ test_that("adding theme object to ggplot object with + operator works", { theme(axis.line.x = element_line(color = "blue"), axis.ticks.x = element_line(color = "red")) - expect_identical(p1$theme, p2$theme) + expect_identical(p1@theme, p2@theme) }) test_that("replacing theme elements with %+replace% operator works", { @@ -221,33 +221,33 @@ test_that("complete and non-complete themes interact correctly with ggplot objec # Check that adding two theme successive theme objects to a ggplot object # works like adding the two theme object to each other p <- ggplot_build(base + theme_bw() + theme(text = element_text(colour = 'red'))) - expect_true(attr(p$plot$theme, "complete")) + expect_true(attr(p$plot@theme, "complete")) # Compare the theme objects, after sorting the items, because item order can differ - pt <- p$plot$theme + pt <- p$plot@theme tt <- theme_bw() + theme(text = element_text(colour = 'red')) pt <- pt[order(names(pt))] tt <- tt[order(names(tt))] expect_identical(pt, tt) p <- ggplot_build(base + theme(text = element_text(colour = 'red')) + theme_bw()) - expect_true(attr(p$plot$theme, "complete")) + expect_true(attr(p$plot@theme, "complete")) # Compare the theme objects, after sorting the items, because item order can differ - pt <- p$plot$theme + pt <- p$plot@theme tt <- theme(text = element_text(colour = 'red')) + theme_bw() pt <- pt[order(names(pt))] tt <- tt[order(names(tt))] expect_identical(pt, tt) p <- ggplot_build(base + theme(text = element_text(colour = 'red', face = 'italic'))) - expect_equal(p$plot$theme$text$colour, "red") - expect_equal(p$plot$theme$text$face, "italic") + expect_equal(p$plot@theme$text$colour, "red") + expect_equal(p$plot@theme$text$face, "italic") p <- ggplot_build(base + theme(text = element_text(colour = 'red')) + theme(text = element_text(face = 'italic'))) - expect_equal(p$plot$theme$text$colour, "red") - expect_equal(p$plot$theme$text$face, "italic") + expect_equal(p$plot@theme$text$colour, "red") + expect_equal(p$plot@theme$text$face, "italic") }) test_that("theme(validate=FALSE) means do not check_element", { @@ -255,16 +255,16 @@ test_that("theme(validate=FALSE) means do not check_element", { bw <- p + theme_bw() red.text <- theme(text = element_text(colour = "red")) bw.before <- bw + theme(animint.width = 500, validate = FALSE) - expect_equal(bw.before$theme$animint.width, 500) + expect_equal(bw.before@theme$animint.width, 500) bw.after <- p + theme(animint.width = 500, validate = FALSE) + theme_bw() - expect_null(bw.after$theme$animint.width) + expect_null(bw.after@theme$animint.width) red.after <- p + theme(animint.width = 500, validate = FALSE) + red.text - expect_equal(red.after$theme$animint.width, 500) + expect_equal(red.after@theme$animint.width, 500) red.before <- p + red.text + theme(animint.width = 500, validate = FALSE) - expect_equal(red.before$theme$animint.width, 500) + expect_equal(red.before@theme$animint.width, 500) }) test_that("theme validation happens at build stage", { From 90d644f2270c6f4fb1ae03f7e4632000a5959426 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 13 Mar 2025 10:58:06 +0100 Subject: [PATCH 07/30] double dispatch for `ggplot_add()` --- NAMESPACE | 11 -- R/plot-construction.R | 155 +++++++++--------- R/theme.R | 5 - tests/testthat/_snaps/prohibited-functions.md | 3 - 4 files changed, 81 insertions(+), 93 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 2ea66959d0..db38b2a498 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -54,17 +54,6 @@ S3method(get_alt_text,ggplot_built) S3method(get_alt_text,gtable) S3method(ggplot,"function") S3method(ggplot,default) -S3method(ggplot_add,"NULL") -S3method(ggplot_add,"function") -S3method(ggplot_add,Coord) -S3method(ggplot_add,Facet) -S3method(ggplot_add,Guides) -S3method(ggplot_add,Layer) -S3method(ggplot_add,Scale) -S3method(ggplot_add,by) -S3method(ggplot_add,data.frame) -S3method(ggplot_add,default) -S3method(ggplot_add,list) S3method(ggplot_build,ggplot) S3method(ggplot_build,ggplot_built) S3method(ggplot_gtable,ggplot_built) diff --git a/R/plot-construction.R b/R/plot-construction.R index f645aae6a4..301f3d4361 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -1,3 +1,6 @@ +#' @include plot.R +NULL + #' Add components to a plot #' #' `+` is the key to constructing sophisticated ggplot2 graphics. It @@ -52,7 +55,6 @@ e2name <- deparse(substitute(e2)) if (is.theme(e1)) add_theme(e1, e2, e2name) - else if (is.ggplot(e1)) add_ggplot(e1, e2, e2name) else if (is.ggproto(e1)) { cli::cli_abort(c( "Cannot add {.cls ggproto} objects together.", @@ -61,10 +63,15 @@ } } +S7::method(`+`, list(class_ggplot, S7::class_any)) <- function(e1, e2) { + e2name <- deparse(substitute(e2, env = caller_env(2))) + add_ggplot(e1, e2, e2name) +} + #' @rdname gg-add #' @export -"%+%" <- `+.gg` +"%+%" <- function(e1, e2) e1 + e2 add_ggplot <- function(p, object, objectname) { if (is.null(object)) return(p) @@ -110,88 +117,88 @@ add_ggplot <- function(p, object, objectname) { #' #' # clean-up #' rm(ggplot_add.element_text) -ggplot_add <- function(object, plot, object_name) { - UseMethod("ggplot_add") -} -#' @export -ggplot_add.default <- function(object, plot, object_name) { - cli::cli_abort("Can't add {.var {object_name}} to a {.cls ggplot} object.") -} -#' @export -ggplot_add.NULL <- function(object, plot, object_name) { - plot -} -#' @export -ggplot_add.data.frame <- function(object, plot, object_name) { - plot@data <- object - plot -} -#' @export -ggplot_add.function <- function(object, plot, object_name) { - cli::cli_abort(c( - "Can't add {.var {object_name}} to a {.cls ggplot} object", - "i" = "Did you forget to add parentheses, as in {.fn {object_name}}?" - )) -} +ggplot_add <- S7::new_generic("ggplot_add", c("object", "plot")) -#' @export -ggplot_add.Scale <- function(object, plot, object_name) { - plot@scales$add(object) - plot -} -S7::method(ggplot_add, labs) <- function(object, plot, object_name) { - update_labels(plot, object) -} -#' @export -ggplot_add.Guides <- function(object, plot, object_name) { - if (is.guides(plot@guides)) { - # We clone the guides object to prevent modify-in-place of guides +S7::method(ggplot_add, list(S7::class_any, class_ggplot)) <- + function(object, plot, object_name, ...) { + cli::cli_abort("Can't add {.var {object_name}} to a {.cls ggplot} object.") + } + +S7::method(ggplot_add, list(S7::class_function, class_ggplot)) <- + function(object, plot, object_name, ...) { + cli::cli_abort(c( + "Can't add {.var {object_name}} to a {.cls ggplot} object", + "i" = "Did you forget to add parentheses, as in {.fn {object_name}}?" + )) + } + +S7::method(ggplot_add, list(NULL, class_ggplot)) <- + function(object, plot, ...) { plot } + +S7::method(ggplot_add, list(S7::class_data.frame, class_ggplot)) <- + function(object, plot, ...) { S7::set_props(plot, data = object) } + +S7::method(ggplot_add, list(class_scale, class_ggplot)) <- + function(object, plot, ...) { + plot@scales$add(object) + plot + } + +S7::method(ggplot_add, list(labs, class_ggplot)) <- + function(object, plot, ...) { update_labels(plot, object) } + +S7::method(ggplot_add, list(class_guides, class_ggplot)) <- + function(object, plot, ...) { old <- plot@guides new <- ggproto(NULL, old) new$add(object) plot@guides <- new - } else { - plot@guides <- object + plot } - plot -} -S7::method(ggplot_add, mapping) <- function(object, plot, object_name) { - plot@mapping <- mapping(defaults(object, plot@mapping)) - plot -} -#' @export -ggplot_add.Coord <- function(object, plot, object_name) { - if (!isTRUE(plot@coordinates$default)) { - cli::cli_inform("Coordinate system already present. Adding new coordinate system, which will replace the existing one.") + +S7::method(ggplot_add, list(mapping, class_ggplot)) <- + function(object, plot, ...) { + S7::set_props(plot, mapping = mapping(defaults(object, plot@mapping))) } - plot@coordinates <- object - plot -} -#' @export -ggplot_add.Facet <- function(object, plot, object_name) { - plot@facet <- object - plot -} -#' @export -ggplot_add.list <- function(object, plot, object_name) { - for (o in object) { - plot <- ggplot_add(o, plot, object_name) +S7::method(ggplot_add, list(theme, class_ggplot)) <- + function(object, plot, ...) { + S7::set_props(plot, theme = add_theme(plot@theme, object)) } - plot -} -#' @export -ggplot_add.by <- function(object, plot, object_name) { - ggplot_add.list(object, plot, object_name) -} -#' @export -ggplot_add.Layer <- function(object, plot, object_name) { - layers_names <- new_layer_names(object, names2(plot@layers)) - plot@layers <- append(plot@layers, object) - names(plot@layers) <- layers_names - plot -} +S7::method(ggplot_add, list(class_coord, class_ggplot)) <- + function(object, plot, ...) { + if (!isTRUE(plot@coordinates$default)) { + cli::cli_inform(c( + "Coordinate system already present.", + i = "Adding new coordinate system, which will replace the existing one." + )) + } + S7::set_props(plot, coordinates = object) + } + +S7::method(ggplot_add, list(class_facet, class_ggplot)) <- + function(object, plot, ...) { S7::set_props(plot, facet = object) } + +S7::method(ggplot_add, list(class_layer, class_ggplot)) <- + function(object, plot, ...) { + layers_names <- new_layer_names(object, names2(plot@layers)) + object <- setNames(append(plot@layers, object), layers_names) + S7::set_props(plot, layers = object) + } + +S7::method(ggplot_add, list(S7::class_list, class_ggplot)) <- + function(object, plot, object_name, ...) { + for (o in object) { + plot <- ggplot_add(o, plot, object_name) + } + plot + } + +S7::method(ggplot_add, list(S7::new_S3_class("by"), class_ggplot)) <- + function(object, plot, object_name, ...) { + ggplot_add(unclass(object), plot, object_name) + } new_layer_names <- function(layer, existing) { diff --git a/R/theme.R b/R/theme.R index 1e914fffe9..7cfa70d89d 100644 --- a/R/theme.R +++ b/R/theme.R @@ -565,11 +565,6 @@ theme <- S7::new_class( constructor = theme ) -S7::method(ggplot_add, theme) <- function(object, plot, object_name, ...) { - plot$theme <- add_theme(plot$theme, object) - plot -} - #' @export #' @rdname is_tests is.theme <- function(x) S7::S7_inherits(x, theme) diff --git a/tests/testthat/_snaps/prohibited-functions.md b/tests/testthat/_snaps/prohibited-functions.md index 34e58d5d14..aa82e6dd65 100644 --- a/tests/testthat/_snaps/prohibited-functions.md +++ b/tests/testthat/_snaps/prohibited-functions.md @@ -52,9 +52,6 @@ $geom_violin [1] "draw_quantiles" - $ggplot_add - [1] "object_name" - $ggproto [1] "_class" "_inherit" From 0310be86d95c61088c8edac238de7e5a2b47d328 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 13 Mar 2025 11:07:30 +0100 Subject: [PATCH 08/30] Write methods for external generics as S7 --- NAMESPACE | 5 ----- R/plot.R | 14 +++++++------- R/save.R | 5 +---- R/summary.R | 6 +++--- R/theme.R | 3 +-- man/print.ggplot.Rd | 6 ++---- man/summary.ggplot.Rd | 2 +- 7 files changed, 15 insertions(+), 26 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index db38b2a498..56b8ca7969 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -58,7 +58,6 @@ S3method(ggplot_build,ggplot) S3method(ggplot_build,ggplot_built) S3method(ggplot_gtable,ggplot_built) S3method(grid.draw,absoluteGrob) -S3method(grid.draw,ggplot) S3method(grobHeight,absoluteGrob) S3method(grobHeight,zeroGrob) S3method(grobWidth,absoluteGrob) @@ -87,19 +86,16 @@ S3method(pattern_alpha,GridPattern) S3method(pattern_alpha,GridTilingPattern) S3method(pattern_alpha,default) S3method(pattern_alpha,list) -S3method(plot,ggplot) S3method(predictdf,default) S3method(predictdf,glm) S3method(predictdf,locfit) S3method(predictdf,loess) S3method(print,"ggplot2::mapping") S3method(print,element) -S3method(print,ggplot) S3method(print,ggplot2_bins) S3method(print,ggproto) S3method(print,ggproto_method) S3method(print,rel) -S3method(print,theme) S3method(scale_type,Date) S3method(scale_type,POSIXt) S3method(scale_type,character) @@ -113,7 +109,6 @@ S3method(scale_type,logical) S3method(scale_type,numeric) S3method(scale_type,ordered) S3method(scale_type,sfc) -S3method(summary,ggplot) S3method(vec_cast,character.mapped_discrete) S3method(vec_cast,double.mapped_discrete) S3method(vec_cast,factor.mapped_discrete) diff --git a/R/plot.R b/R/plot.R index 46c27f5e28..fcd7b00f7a 100644 --- a/R/plot.R +++ b/R/plot.R @@ -194,8 +194,10 @@ plot_clone <- function(plot) { #' @param ... other arguments not used by this method #' @keywords hplot #' @return Invisibly returns the original plot. -#' @export -#' @method print ggplot +#' @name print.ggplot +#' @usage +#' print(x, newpage = is.null(vp), vp = NULL, ...) +#' plot(x, newpage = is.null(vp), vp = NULL, ...) #' @examples #' colours <- list(~class, ~drv, ~fl) #' @@ -210,7 +212,9 @@ plot_clone <- function(plot) { #' print(ggplot(mpg, aes_(~ displ, ~ hwy, colour = colour)) + #' geom_point()) #' } -print.ggplot <- function(x, newpage = is.null(vp), vp = NULL, ...) { +S7::method(print, class_ggplot) <- + S7::method(plot, class_ggplot) <- + function(x, newpage = is.null(vp), vp = NULL, ...) { set_last_plot(x) if (newpage) grid.newpage() @@ -239,7 +243,3 @@ print.ggplot <- function(x, newpage = is.null(vp), vp = NULL, ...) { invisible(x) } -#' @rdname print.ggplot -#' @method plot ggplot -#' @export -plot.ggplot <- print.ggplot diff --git a/R/save.R b/R/save.R index 5e1ef5983a..8917d75ad9 100644 --- a/R/save.R +++ b/R/save.R @@ -313,10 +313,7 @@ validate_device <- function(device, filename = NULL, dpi = 300, call = caller_en dev } -#' @export -grid.draw.ggplot <- function(x, recording = TRUE) { - print(x) -} +S7::method(grid.draw, class_ggplot) <- function(x, recording = TRUE) print(x) absorb_grdevice_args <- function(f) { function(..., type, antialias) { diff --git a/R/summary.R b/R/summary.R index ce9a4ddd7b..6feb565600 100644 --- a/R/summary.R +++ b/R/summary.R @@ -3,13 +3,13 @@ #' @param object ggplot2 object to summarise #' @param ... other arguments ignored (for compatibility with generic) #' @keywords internal -#' @method summary ggplot -#' @export +#' @name summary.ggplot +#' @usage summary(object, ...) #' @examples #' p <- ggplot(mtcars, aes(mpg, wt)) + #' geom_point() #' summary(p) -summary.ggplot <- function(object, ...) { +S7::method(summary, class_ggplot) <- function(object, ...) { wrap <- function(x) paste( paste(strwrap(x, exdent = 2), collapse = "\n"), "\n", sep = "" diff --git a/R/theme.R b/R/theme.R index 7cfa70d89d..a857ef8e92 100644 --- a/R/theme.R +++ b/R/theme.R @@ -959,5 +959,4 @@ combine_elements <- function(e1, e2) { .subset2(x, ...) } -#' @export -print.theme <- function(x, ...) utils::str(x) +S7::method(print, theme) <- function(x, ...) utils::str(x) diff --git a/man/print.ggplot.Rd b/man/print.ggplot.Rd index 07b2a68942..4981fe41c1 100644 --- a/man/print.ggplot.Rd +++ b/man/print.ggplot.Rd @@ -2,12 +2,10 @@ % Please edit documentation in R/plot.R \name{print.ggplot} \alias{print.ggplot} -\alias{plot.ggplot} \title{Explicitly draw plot} \usage{ -\method{print}{ggplot}(x, newpage = is.null(vp), vp = NULL, ...) - -\method{plot}{ggplot}(x, newpage = is.null(vp), vp = NULL, ...) +print(x, newpage = is.null(vp), vp = NULL, ...) +plot(x, newpage = is.null(vp), vp = NULL, ...) } \arguments{ \item{x}{plot to display} diff --git a/man/summary.ggplot.Rd b/man/summary.ggplot.Rd index cf426610bc..62b8a900db 100644 --- a/man/summary.ggplot.Rd +++ b/man/summary.ggplot.Rd @@ -4,7 +4,7 @@ \alias{summary.ggplot} \title{Displays a useful description of a ggplot object} \usage{ -\method{summary}{ggplot}(object, ...) +summary(object, ...) } \arguments{ \item{object}{ggplot2 object to summarise} From 26075971ffa25c7ecf42917b6641b7984a072e47 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 13 Mar 2025 12:22:08 +0100 Subject: [PATCH 09/30] backward compatibility for ggplot class --- NAMESPACE | 6 ++++++ R/bench.R | 2 +- R/facet-.R | 2 +- R/facet-grid-.R | 2 +- R/layer-sf.R | 2 +- R/layer.R | 2 +- R/plot.R | 36 ++++++++++++++++++++++++++++++++++++ tests/testthat/test-qplot.R | 15 ++++++++++----- 8 files changed, 57 insertions(+), 10 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 56b8ca7969..0d7e663d74 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,15 +1,21 @@ # Generated by roxygen2: do not edit by hand +S3method("$","ggplot2::ggplot") S3method("$","ggplot2::theme") S3method("$",ggproto) S3method("$",ggproto_parent) +S3method("$<-","ggplot2::ggplot") S3method("$<-","ggplot2::mapping") S3method("+",gg) +S3method("[","ggplot2::ggplot") S3method("[","ggplot2::mapping") S3method("[",mapped_discrete) +S3method("[<-","ggplot2::ggplot") S3method("[<-","ggplot2::mapping") S3method("[<-",mapped_discrete) +S3method("[[","ggplot2::ggplot") S3method("[[",ggproto) +S3method("[[<-","ggplot2::ggplot") S3method("[[<-","ggplot2::mapping") S3method(.DollarNames,ggproto) S3method(as.data.frame,mapped_discrete) diff --git a/R/bench.R b/R/bench.R index 4d679b8e31..81835836ac 100644 --- a/R/bench.R +++ b/R/bench.R @@ -15,7 +15,7 @@ benchplot <- function(x) { x <- enquo(x) construct <- system.time(x <- eval_tidy(x)) - check_inherits(x, "ggplot") + check_inherits(x, "ggplot2::ggplot") build <- system.time(data <- ggplot_build(x)) render <- system.time(grob <- ggplot_gtable(data)) diff --git a/R/facet-.R b/R/facet-.R index 5ebb3a94f9..41b6d4afd6 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -493,7 +493,7 @@ check_vars <- function(x) { } # Native pipe have higher precedence than + so any type of gg object can be # expected here, not just ggplot - if (inherits(x, "gg")) { + if (S7::S7_inherits(x, class_gg)) { cli::cli_abort(c( "Please use {.fn vars} to supply facet variables.", "i" = "Did you use {.code %>%} or {.code |>} instead of {.code +}?" diff --git a/R/facet-grid-.R b/R/facet-grid-.R index ff5cdf0d81..886e77abdd 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -196,7 +196,7 @@ grid_as_facets_list <- function(rows, cols) { msg <- "{.arg rows} must be {.code NULL} or a {.fn vars} list if {.arg cols} is a {.fn vars} list." # Native pipe have higher precedence than + so any type of gg object can be # expected here, not just ggplot - if (inherits(rows, "gg")) { + if (S7::S7_inherits(rows, class_gg)) { msg <- c( msg, "i" = "Did you use {.code %>%} or {.code |>} instead of {.code +}?" diff --git a/R/layer-sf.R b/R/layer-sf.R index 3a282e734f..7a952971ec 100644 --- a/R/layer-sf.R +++ b/R/layer-sf.R @@ -45,7 +45,7 @@ LayerSf <- ggproto("LayerSf", Layer, # automatically determine the name of the geometry column # and add the mapping if it doesn't exist if ((isTRUE(self$inherit.aes) && is.null(self$computed_mapping$geometry) && - is.null(plot$computed_mapping$geometry)) || + is.null(self$computed_mapping$geometry)) || (!isTRUE(self$inherit.aes) && is.null(self$computed_mapping$geometry))) { if (is_sf(data)) { geometry_col <- attr(data, "sf_column") diff --git a/R/layer.R b/R/layer.R index 83d1a6d3ed..49e53f35d9 100644 --- a/R/layer.R +++ b/R/layer.R @@ -205,7 +205,7 @@ validate_mapping <- function(mapping, call = caller_env()) { 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 - if (inherits(mapping, "gg")) { + if (S7::S7_inherits(mapping, class_gg)) { msg <- c(msg, "i" = "Did you use {.code %>%} or {.code |>} instead of {.code +}?") } diff --git a/R/plot.R b/R/plot.R index fcd7b00f7a..e532661e3c 100644 --- a/R/plot.R +++ b/R/plot.R @@ -153,6 +153,7 @@ ggplot.default <- function(data = NULL, mapping = aes(), ..., layout = ggproto(NULL, Layout), labels = labs() ) + class(p) <- union("ggplot", class(p)) set_last_plot(p) p @@ -243,3 +244,38 @@ S7::method(print, class_ggplot) <- invisible(x) } + +#' @export +`$.ggplot2::ggplot` <- function(x, i) { + `[[`(S7::props(x), i) +} + +#' @export +`$<-.ggplot2::ggplot` <- function(x, i, value) { + S7::props(x) <- `$<-`(S7::props(x), i, value) + x +} + +#' @export +`[.ggplot2::ggplot` <- function(x, i) { + `[`(S7::props(x), i) +} + +#' @export +`[<-.ggplot2::ggplot` <- function(x, i, value) { + S7::props(x) <- `[<-`(S7::props(x), i, value) + x +} + +#' @export +`[[.ggplot2::ggplot` <- function(x, i) { + `[[`(S7::props(x), i) +} + +#' @export +`[[<-.ggplot2::ggplot` <- function(x, i, value) { + S7::props(x) <- `[[<-`(S7::props(x), i, value) + x +} + + diff --git a/tests/testthat/test-qplot.R b/tests/testthat/test-qplot.R index 74ab153c39..59527d1989 100644 --- a/tests/testthat/test-qplot.R +++ b/tests/testthat/test-qplot.R @@ -3,20 +3,25 @@ test_that("qplot works with variables in data frame and parent env", { y <- 1:10 b <- 1:10 + lifecycle::expect_deprecated( - expect_s3_class(qplot(x, y, data = df), "ggplot") + p <- qplot(x, y, data = df) ) + expect_s7_class(p, class_ggplot) lifecycle::expect_deprecated( - expect_s3_class(qplot(x, y, data = df, colour = a), "ggplot") + p <- qplot(x, y, data = df, colour = a) ) + expect_s7_class(p, class_ggplot) lifecycle::expect_deprecated( - expect_s3_class(qplot(x, y, data = df, colour = b), "ggplot") + p <- qplot(x, y, data = df, colour = b) ) + expect_s7_class(p, class_ggplot) bin <- 1 lifecycle::expect_deprecated( - expect_s3_class(qplot(x, data = df, binwidth = bin), "ggplot") + p <- qplot(x, data = df, binwidth = bin) ) + expect_s7_class(p, class_ggplot) }) test_that("qplot works in non-standard environments", { @@ -27,7 +32,7 @@ test_that("qplot works in non-standard environments", { qplot(x, breaks = 0:`-1-`) }) ) - expect_s3_class(p, "ggplot") + expect_s7_class(p, class_ggplot) }) test_that("qplot() evaluates constants in the right place", { From 30b11183b95d04102fc46d2ace5cb21853d63f14 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 14 Mar 2025 10:15:58 +0100 Subject: [PATCH 10/30] Implement as S7 --- R/all-classes.R | 2 ++ R/facet-.R | 6 ++--- R/guides-.R | 6 ++--- R/labels.R | 16 ++++++------ R/plot-build.R | 32 ++++++++++++++--------- R/summarise-plot.R | 18 ++++++------- tests/testthat/_snaps/summarise-plot.md | 6 ++--- tests/testthat/helper-plot-data.R | 8 +++--- tests/testthat/test-aes.R | 4 +-- tests/testthat/test-build.R | 2 +- tests/testthat/test-coord-.R | 12 ++++----- tests/testthat/test-coord-cartesian.R | 6 ++--- tests/testthat/test-coord-polar.R | 6 ++--- tests/testthat/test-coord-transform.R | 24 ++++++++--------- tests/testthat/test-coord_sf.R | 14 +++++----- tests/testthat/test-facet-labels.R | 2 +- tests/testthat/test-facet-map.R | 2 +- tests/testthat/test-facet-strips.R | 6 ++--- tests/testthat/test-geom-boxplot.R | 8 +++--- tests/testthat/test-geom-dotplot.R | 4 +-- tests/testthat/test-geom-polygon.R | 6 ++--- tests/testthat/test-geom-sf.R | 28 ++++++++++---------- tests/testthat/test-guide-colorbar.R | 4 +-- tests/testthat/test-guide-legend.R | 2 +- tests/testthat/test-guides.R | 4 +-- tests/testthat/test-labels.R | 34 ++++++++++++------------- tests/testthat/test-scale-discrete.R | 2 +- tests/testthat/test-scale-manual.R | 2 +- tests/testthat/test-scales.R | 12 ++++----- tests/testthat/test-stat-bin.R | 14 +++++----- tests/testthat/test-stats.R | 12 ++++----- tests/testthat/test-theme.R | 16 ++++++------ 32 files changed, 165 insertions(+), 155 deletions(-) diff --git a/R/all-classes.R b/R/all-classes.R index 8c0f67865c..88fc6db554 100644 --- a/R/all-classes.R +++ b/R/all-classes.R @@ -5,6 +5,8 @@ class_guides <- S7::new_S3_class("Guides") class_coord <- S7::new_S3_class("Coord") class_facet <- S7::new_S3_class("Facet") class_layer <- S7::new_S3_class("Layer") +class_layout <- S7::new_S3_class("Layout") class_scales_list <- S7::new_S3_class("ScalesList") class_layout <- S7::new_S3_class("Layout") class_ggproto <- S7::new_S3_class("ggproto") +class_gtable <- S7::new_S3_class("gtable") diff --git a/R/facet-.R b/R/facet-.R index 41b6d4afd6..4e77642b26 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -399,9 +399,9 @@ vars <- function(...) { #' get_strip_labels(p + facet_grid(year ~ cyl)) get_strip_labels <- function(plot = get_last_plot()) { plot <- ggplot_build(plot) - layout <- plot$layout$layout - params <- plot$layout$facet_params - plot$plot@facet$format_strip_labels(layout, params) + layout <- plot@layout$layout + params <- plot@layout$facet_params + plot@plot@facet$format_strip_labels(layout, params) } # A "special" value, currently not used but could be used to determine diff --git a/R/guides-.R b/R/guides-.R index 3432807373..75ead3ccc2 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -832,7 +832,7 @@ get_guide_data <- function(plot = get_last_plot(), aesthetic, panel = 1L) { if (!aesthetic %in% c("x", "y", "x.sec", "y.sec", "theta", "r")) { # Non position guides: check if aesthetic in colnames of key - keys <- lapply(plot$plot@guides$params, `[[`, "key") + keys <- lapply(plot@plot@guides$params, `[[`, "key") keep <- vapply(keys, function(x) any(colnames(x) %in% aesthetic), logical(1)) keys <- switch(sum(keep) + 1, NULL, keys[[which(keep)]], keys[keep]) return(keys) @@ -840,12 +840,12 @@ get_guide_data <- function(plot = get_last_plot(), aesthetic, panel = 1L) { # Position guides: find the right layout entry check_number_whole(panel) - layout <- plot$layout$layout + layout <- plot@layout$layout select <- layout[layout$PANEL == panel, , drop = FALSE] if (nrow(select) == 0) { return(NULL) } - params <- plot$layout$panel_params[select$PANEL][[1]] + params <- plot@layout$panel_params[select$PANEL][[1]] # If panel params don't have guides, we probably have old coord system # that doesn't use the guide system. diff --git a/R/labels.R b/R/labels.R index 146b9826f2..6ec8ae5535 100644 --- a/R/labels.R +++ b/R/labels.R @@ -220,18 +220,18 @@ ggtitle <- function(label, subtitle = waiver()) { get_labs <- function(plot = get_last_plot()) { plot <- ggplot_build(plot) - labs <- plot$plot@labels + labs <- plot@plot@labels xy_labs <- rename( - c(x = plot$layout$resolve_label(plot$layout$panel_scales_x[[1]], labs), - y = plot$layout$resolve_label(plot$layout$panel_scales_y[[1]], labs)), + c(x = plot@layout$resolve_label(plot@layout$panel_scales_x[[1]], labs), + y = plot@layout$resolve_label(plot@layout$panel_scales_y[[1]], labs)), c(x.primary = "x", x.secondary = "x.sec", y.primary = "y", y.secondary = "y.sec") ) labs <- defaults(xy_labs, labs) - guides <- plot$plot@guides + guides <- plot@plot@guides if (length(guides$aesthetics) == 0) { return(labs) } @@ -287,14 +287,14 @@ get_alt_text.ggplot <- function(p, ...) { } p@labels[["alt"]] <- NULL build <- ggplot_build(p) - build$plot@labels[["alt"]] <- alt + build@plot@labels[["alt"]] <- alt get_alt_text(build) } #' @export get_alt_text.ggplot_built <- function(p, ...) { - alt <- p$plot@labels[["alt"]] %||% "" - p$plot@labels[["alt"]] <- NULL - if (is.function(alt)) alt(p$plot) else alt + alt <- p@plot@labels[["alt"]] %||% "" + p@plot@labels[["alt"]] <- NULL + if (is.function(alt)) alt(p@plot) else alt } #' @export get_alt_text.gtable <- function(p, ...) { diff --git a/R/plot-build.R b/R/plot-build.R index 93d2aab2f2..acaa82b09b 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -1,3 +1,14 @@ +#' @include plot.R + +class_ggplot_built <- S7::new_class( + "ggplot_built", + properties = list( + data = S7::class_list, + layout = class_layout, + plot = class_ggplot + ) +) + #' Build ggplot for rendering. #' #' `ggplot_build()` takes the plot object, and performs all steps necessary @@ -131,16 +142,13 @@ ggplot_build.ggplot <- function(plot) { # Consolidate alt-text plot@labels$alt <- get_alt_text(plot) - structure( - list(data = data, layout = layout, plot = plot), - class = "ggplot_built" - ) + class_ggplot_built(data = data, layout = layout, plot = plot) } #' @export #' @rdname ggplot_build get_layer_data <- function(plot = get_last_plot(), i = 1L) { - ggplot_build(plot)$data[[i]] + ggplot_build(plot)@data[[i]] } #' @export #' @rdname ggplot_build @@ -151,12 +159,12 @@ layer_data <- get_layer_data get_panel_scales <- function(plot = get_last_plot(), i = 1L, j = 1L) { b <- ggplot_build(plot) - layout <- b$layout$layout + layout <- b@layout$layout selected <- layout[layout$ROW == i & layout$COL == j, , drop = FALSE] list( - x = b$layout$panel_scales_x[[selected$SCALE_X]], - y = b$layout$panel_scales_y[[selected$SCALE_Y]] + x = b@layout$panel_scales_x[[selected$SCALE_X]], + y = b@layout$panel_scales_y[[selected$SCALE_Y]] ) } @@ -169,7 +177,7 @@ layer_scales <- get_panel_scales get_layer_grob <- function(plot = get_last_plot(), i = 1L) { b <- ggplot_build(plot) - b$plot@layers[[i]]$draw_geom(b$data[[i]], b$layout) + b@plot@layers[[i]]$draw_geom(b@data[[i]], b@layout) } #' @export @@ -203,9 +211,9 @@ ggplot_gtable <- function(data) { #' @export ggplot_gtable.ggplot_built <- function(data) { - plot <- data$plot - layout <- data$layout - data <- data$data + plot <- data@plot + layout <- data@layout + data <- data@data theme <- plot@theme geom_grobs <- by_layer(function(l, d) l$draw_geom(d, layout), plot@layers, data, "converting geom to grob") diff --git a/R/summarise-plot.R b/R/summarise-plot.R index aa192e777a..39d3df5c17 100644 --- a/R/summarise-plot.R +++ b/R/summarise-plot.R @@ -62,8 +62,8 @@ NULL #' @rdname summarise_plot #' @export summarise_layout <- function(p) { - check_inherits(p, "ggplot_built") - l <- p$layout + check_inherits(p, "ggplot2::ggplot_built") + l <- p@layout layout <- l$layout layout <- data_frame0( @@ -99,7 +99,7 @@ summarise_layout <- function(p) { #' @rdname summarise_plot #' @export summarise_coord <- function(p) { - check_inherits(p, "ggplot_built") + check_inherits(p, "ggplot2::ggplot_built") # Given a transform object, find the log base; if the transform object is # NULL, or if it's not a log transform, return NA. @@ -112,9 +112,9 @@ summarise_coord <- function(p) { } list( - xlog = trans_get_log_base(p$layout$coord$trans$x), - ylog = trans_get_log_base(p$layout$coord$trans$y), - flip = inherits(p$layout$coord, "CoordFlip") + xlog = trans_get_log_base(p@layout$coord$trans$x), + ylog = trans_get_log_base(p@layout$coord$trans$y), + flip = inherits(p@layout$coord, "CoordFlip") ) } @@ -122,13 +122,13 @@ summarise_coord <- function(p) { #' @rdname summarise_plot #' @export summarise_layers <- function(p) { - check_inherits(p, "ggplot_built") + check_inherits(p, "ggplot2::ggplot_built") # Default mappings. Make sure it's a regular list instead of a mapping # object. - default_mapping <- unclass(p$plot@mapping) + default_mapping <- unclass(p@plot@mapping) - layer_mappings <- lapply(p$plot@layers, function(layer) { + layer_mappings <- lapply(p@plot@layers, function(layer) { defaults(layer$mapping, default_mapping) }) diff --git a/tests/testthat/_snaps/summarise-plot.md b/tests/testthat/_snaps/summarise-plot.md index 32582d9366..84128c3b47 100644 --- a/tests/testthat/_snaps/summarise-plot.md +++ b/tests/testthat/_snaps/summarise-plot.md @@ -1,12 +1,12 @@ # summarise_*() throws appropriate errors - `p` must be a object, not the number 10. + `p` must be a object, not the number 10. --- - `p` must be a object, not the string "A". + `p` must be a object, not the string "A". --- - `p` must be a object, not `TRUE`. + `p` must be a object, not `TRUE`. diff --git a/tests/testthat/helper-plot-data.R b/tests/testthat/helper-plot-data.R index 74911db54c..cf97be4122 100644 --- a/tests/testthat/helper-plot-data.R +++ b/tests/testthat/helper-plot-data.R @@ -2,17 +2,17 @@ cdata <- function(plot) { pieces <- ggplot_build(plot) - lapply(pieces$data, function(d) { + lapply(pieces@data, function(d) { dapply(d, "PANEL", function(panel_data) { - scales <- pieces$layout$get_scales(panel_data$PANEL[1]) - panel_params <- plot@coordinates$setup_panel_params(scales$x, scales$y, params = pieces$layout$coord_params) + scales <- pieces@layout$get_scales(panel_data$PANEL[1]) + panel_params <- plot@coordinates$setup_panel_params(scales$x, scales$y, params = pieces@layout$coord_params) plot@coordinates$transform(panel_data, panel_params) }) }) } pranges <- function(plot) { - layout <- ggplot_build(plot)$layout + layout <- ggplot_build(plot)@layout x_ranges <- lapply(layout$panel_scales_x, function(scale) scale$get_limits()) y_ranges <- lapply(layout$panel_scales_y, function(scale) scale$get_limits()) diff --git a/tests/testthat/test-aes.R b/tests/testthat/test-aes.R index 2e230c87e4..c4f479d02c 100644 --- a/tests/testthat/test-aes.R +++ b/tests/testthat/test-aes.R @@ -96,13 +96,13 @@ test_that("assignment methods pull unwrap constants from quosures", { test_that("quosures are squashed when creating default label for a mapping", { p <- ggplot(mtcars) + aes(!!quo(identity(!!quo(cyl)))) - labels <- ggplot_build(p)$plot@labels + labels <- ggplot_build(p)@plot@labels expect_identical(labels$x, "identity(cyl)") }) test_that("labelling doesn't cause error if aesthetic is NULL", { p <- ggplot(mtcars) + aes(x = NULL) - labels <- ggplot_build(p)$plot@labels + labels <- ggplot_build(p)@plot@labels expect_identical(labels$x, "x") }) diff --git a/tests/testthat/test-build.R b/tests/testthat/test-build.R index cdcbe0c6ac..cfb4cf6e4a 100644 --- a/tests/testthat/test-build.R +++ b/tests/testthat/test-build.R @@ -2,7 +2,7 @@ df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) test_that("there is one data frame for each layer", { - nlayers <- function(x) length(ggplot_build(x)$data) + nlayers <- function(x) length(ggplot_build(x)@data) l1 <- ggplot(df, aes(x, y)) + geom_point() l2 <- ggplot(df, aes(x, y)) + geom_point() + geom_line() diff --git a/tests/testthat/test-coord-.R b/tests/testthat/test-coord-.R index e171f6680d..ea80cb5ce1 100644 --- a/tests/testthat/test-coord-.R +++ b/tests/testthat/test-coord-.R @@ -8,7 +8,7 @@ test_that("Coord errors on missing methods", { test_that("clipping is on by default", { p <- ggplot() - coord <- ggplot_build(p)$layout$coord + coord <- ggplot_build(p)@layout$coord expect_equal(coord$clip, "on") }) @@ -30,9 +30,9 @@ test_that("guide names are not removed by `train_panel_guides()`", { data <- ggplot_build(gg) # Excerpt from ggplot_gtable.ggplot_built - plot <- data$plot - layout <- data$layout - data <- data$data + plot <- data@plot + layout <- data@layout + data <- data@data layout$setup_panel_guides(guides_list(NULL), plot@layers) @@ -97,12 +97,12 @@ test_that("coord expand takes a vector", { base <- ggplot() + lims(x = c(0, 10), y = c(0, 10)) p <- ggplot_build(base + coord_cartesian(expand = c(TRUE, FALSE, FALSE, TRUE))) - pp <- p$layout$panel_params[[1]] + pp <- p@layout$panel_params[[1]] expect_equal(pp$x.range, c(-0.5, 10)) expect_equal(pp$y.range, c(0, 10.5)) p <- ggplot_build(base + coord_cartesian(expand = c(top = FALSE, left = FALSE))) - pp <- p$layout$panel_params[[1]] + pp <- p@layout$panel_params[[1]] expect_equal(pp$x.range, c(0, 10.5)) expect_equal(pp$y.range, c(-0.5, 10)) diff --git a/tests/testthat/test-coord-cartesian.R b/tests/testthat/test-coord-cartesian.R index 5bb16c4cd1..f404094d4a 100644 --- a/tests/testthat/test-coord-cartesian.R +++ b/tests/testthat/test-coord-cartesian.R @@ -1,16 +1,16 @@ test_that("clipping can be turned off and on", { # clip on by default p <- ggplot() + coord_cartesian() - coord <- ggplot_build(p)$layout$coord + coord <- ggplot_build(p)@layout$coord expect_equal(coord$clip, "on") # clip can be turned on and off p <- ggplot() + coord_cartesian(clip = "off") - coord <- ggplot_build(p)$layout$coord + coord <- ggplot_build(p)@layout$coord expect_equal(coord$clip, "off") p <- ggplot() + coord_cartesian(clip = "on") - coord <- ggplot_build(p)$layout$coord + coord <- ggplot_build(p)@layout$coord expect_equal(coord$clip, "on") }) diff --git a/tests/testthat/test-coord-polar.R b/tests/testthat/test-coord-polar.R index 466162b0f5..28518eddb9 100644 --- a/tests/testthat/test-coord-polar.R +++ b/tests/testthat/test-coord-polar.R @@ -55,11 +55,11 @@ test_that("polar distance calculation ignores NA's", { test_that("clipping can be turned off and on", { # clip can be turned on and off p <- ggplot() + coord_polar() - coord <- ggplot_build(p)$layout$coord + coord <- ggplot_build(p)@layout$coord expect_equal(coord$clip, "on") p <- ggplot() + coord_polar(clip = "off") - coord <- ggplot_build(p)$layout$coord + coord <- ggplot_build(p)@layout$coord expect_equal(coord$clip, "off") }) @@ -205,7 +205,7 @@ test_that("coord_radial can deal with empty breaks (#6271)", { scale_x_continuous(breaks = numeric()) + scale_y_continuous(breaks = numeric()) ) - guides <- p$layout$panel_params[[1]]$guides$guides + guides <- p@layout$panel_params[[1]]$guides$guides is_none <- vapply(guides, inherits, logical(1), what = "GuideNone") expect_true(all(is_none)) }) diff --git a/tests/testthat/test-coord-transform.R b/tests/testthat/test-coord-transform.R index 7621f5ed9c..9a01b709b7 100644 --- a/tests/testthat/test-coord-transform.R +++ b/tests/testthat/test-coord-transform.R @@ -28,8 +28,8 @@ test_that("coord_trans() expands axes identically to coord_cartesian()", { built_cartesian <- ggplot_build(p + coord_cartesian()) built_trans <- ggplot_build(p + coord_trans()) - cartesian_params <- built_cartesian$layout$panel_params[[1]] - trans_params <- built_trans$layout$panel_params[[1]] + cartesian_params <- built_cartesian@layout$panel_params[[1]] + trans_params <- built_trans@layout$panel_params[[1]] expect_identical(cartesian_params$x.range, trans_params$x.range) expect_identical(cartesian_params$y.range, trans_params$y.range) @@ -40,8 +40,8 @@ test_that("coord_trans(expand = FALSE) expands axes identically to coord_cartesi built_cartesian <- ggplot_build(p + coord_cartesian(expand = FALSE)) built_trans <- ggplot_build(p + coord_trans(expand = FALSE)) - cartesian_params <- built_cartesian$layout$panel_params[[1]] - trans_params <- built_trans$layout$panel_params[[1]] + cartesian_params <- built_cartesian@layout$panel_params[[1]] + trans_params <- built_trans@layout$panel_params[[1]] expect_identical(cartesian_params$x.range, trans_params$x.range) expect_identical(cartesian_params$y.range, trans_params$y.range) @@ -52,8 +52,8 @@ test_that("coord_trans(y = 'log10') expands the x axis identically to scale_y_lo built_cartesian <- ggplot_build(p + scale_y_log10()) built_trans <- ggplot_build(p + coord_trans(y = "log10")) - cartesian_params <- built_cartesian$layout$panel_params[[1]] - trans_params <- built_trans$layout$panel_params[[1]] + cartesian_params <- built_cartesian@layout$panel_params[[1]] + trans_params <- built_trans@layout$panel_params[[1]] expect_identical(cartesian_params$y.range, trans_params$y.range) }) @@ -65,8 +65,8 @@ test_that("coord_trans() expands axes outside the domain of the axis trans", { built_cartesian <- ggplot_build(p + scale_y_sqrt()) built_trans <- ggplot_build(p + coord_trans(y = "sqrt")) - cartesian_params <- built_cartesian$layout$panel_params[[1]] - trans_params <- built_trans$layout$panel_params[[1]] + cartesian_params <- built_cartesian@layout$panel_params[[1]] + trans_params <- built_trans@layout$panel_params[[1]] expect_identical(cartesian_params$y.range, trans_params$y.range) }) @@ -78,8 +78,8 @@ test_that("coord_trans() works with the reverse transformation", { built_cartesian <- ggplot_build(p + scale_y_reverse()) built_trans <- ggplot_build(p + coord_trans(y = "reverse")) - cartesian_params <- built_cartesian$layout$panel_params[[1]] - trans_params <- built_trans$layout$panel_params[[1]] + cartesian_params <- built_cartesian@layout$panel_params[[1]] + trans_params <- built_trans@layout$panel_params[[1]] expect_identical(cartesian_params$y.range, trans_params$y.range) }) @@ -91,8 +91,8 @@ test_that("coord_trans() can reverse discrete axes", { built_cartesian <- ggplot_build(p) built_trans <- ggplot_build(p + coord_trans(x = "reverse")) - cartesian_params <- built_cartesian$layout$panel_params[[1]] - trans_params <- built_trans$layout$panel_params[[1]] + cartesian_params <- built_cartesian@layout$panel_params[[1]] + trans_params <- built_trans@layout$panel_params[[1]] expect_identical(cartesian_params$x.range, -rev(trans_params$x.range)) }) diff --git a/tests/testthat/test-coord_sf.R b/tests/testthat/test-coord_sf.R index a684bea20b..3e96f926dd 100644 --- a/tests/testthat/test-coord_sf.R +++ b/tests/testthat/test-coord_sf.R @@ -56,7 +56,7 @@ test_that("axis labels are correct for manual breaks", { scale_x_continuous(breaks = c(1000, 2000, 3000)) + scale_y_continuous(breaks = c(1000, 1500, 2000)) ) - graticule <- b$layout$panel_params[[1]]$graticule + graticule <- b@layout$panel_params[[1]]$graticule expect_identical( graticule[graticule$type == "E", ]$degree_label, c("1000", "2000", "3000") @@ -85,7 +85,7 @@ test_that("axis labels can be set manually", { labels = c("D", "E", "F") ) ) - graticule <- b$layout$panel_params[[1]]$graticule + graticule <- b@layout$panel_params[[1]]$graticule expect_identical( graticule[graticule$type == "E", ]$degree_label, c("A", "B", "C") @@ -128,7 +128,7 @@ test_that("factors are treated like character labels and are not parsed", { labels = factor(c("1 * degree * N", "1.5 * degree * N", "2 * degree * N")) ) ) - graticule <- b$layout$panel_params[[1]]$graticule + graticule <- b@layout$panel_params[[1]]$graticule expect_identical( graticule[graticule$type == "E", ]$degree_label, c("A", "B", "C") @@ -156,7 +156,7 @@ test_that("expressions can be mixed with character labels", { labels = parse(text = c("10^3", "1.5 %*% 10^3", "2 %*% 10^3")) ) ) - graticule <- b$layout$panel_params[[1]]$graticule + graticule <- b@layout$panel_params[[1]]$graticule expect_identical( graticule[graticule$type == "E", ]$degree_label, as.list(c("A", "B", "C")) @@ -180,7 +180,7 @@ test_that("expressions can be mixed with character labels", { labels = parse(text = c("10^3", "1.5 %*% 10^3", "2 %*% 10^3")) ) ) - graticule <- b$layout$panel_params[[1]]$graticule + graticule <- b@layout$panel_params[[1]]$graticule expect_identical( graticule[graticule$type == "N", ]$degree_label, as.list(c("A", "B", "C")) @@ -207,7 +207,7 @@ test_that("degree labels are automatically parsed", { scale_y_continuous(breaks = c(10, 15, 20)) ) - graticule <- b$layout$panel_params[[1]]$graticule + graticule <- b@layout$panel_params[[1]]$graticule expect_setequal( graticule[graticule$type == "N", ]$degree, c(10, 15, 20) @@ -343,7 +343,7 @@ test_that("coord_sf() can use function breaks and n.breaks", { scale_y_continuous(n.breaks = 4) b <- ggplot_build(p) - grat <- b$layout$panel_params[[1]]$graticule + grat <- b@layout$panel_params[[1]]$graticule expect_equal( vec_slice(grat$degree, grat$type == "E"), diff --git a/tests/testthat/test-facet-labels.R b/tests/testthat/test-facet-labels.R index b0b014cd2e..e8c9dab21b 100644 --- a/tests/testthat/test-facet-labels.R +++ b/tests/testthat/test-facet-labels.R @@ -1,6 +1,6 @@ get_labels_matrix <- function(plot, ...) { data <- ggplot_build(plot) - layout <- data$layout + layout <- data@layout labels <- get_labels_info(layout$facet, layout, ...) labeller <- match.fun(layout$facet$params$labeller) diff --git a/tests/testthat/test-facet-map.R b/tests/testthat/test-facet-map.R index de2bf20af2..4ae93119b2 100644 --- a/tests/testthat/test-facet-map.R +++ b/tests/testthat/test-facet-map.R @@ -123,7 +123,7 @@ test_that("grid: missing values are located correctly", { # Facet order ---------------------------------------------------------------- -get_layout <- function(p) ggplot_build(p)$layout$layout +get_layout <- function(p) ggplot_build(p)@layout$layout # Data with factor f with levels CBA d <- data_frame(x = 1:9, y = 1:9, diff --git a/tests/testthat/test-facet-strips.R b/tests/testthat/test-facet-strips.R index a44d4c0a43..2f1080877f 100644 --- a/tests/testthat/test-facet-strips.R +++ b/tests/testthat/test-facet-strips.R @@ -1,8 +1,8 @@ strip_layout <- function(p) { data <- ggplot_build(p) - plot <- data$plot - layout <- data$layout - data <- data$data + plot <- data@plot + layout <- data@layout + data <- data@data theme <- plot_theme(plot) geom_grobs <- Map(function(l, d) l$draw_geom(d, layout), plot@layers, data) diff --git a/tests/testthat/test-geom-boxplot.R b/tests/testthat/test-geom-boxplot.R index 81d37cc5a9..9d977501ff 100644 --- a/tests/testthat/test-geom-boxplot.R +++ b/tests/testthat/test-geom-boxplot.R @@ -3,8 +3,8 @@ test_that("geom_boxplot range includes all outliers", { dat <- data_frame(x = 1, y = c(-(1:20) ^ 3, (1:20) ^ 3) ) p <- ggplot_build(ggplot(dat, aes(x,y)) + geom_boxplot()) - miny <- p$layout$panel_params[[1]]$y.range[1] - maxy <- p$layout$panel_params[[1]]$y.range[2] + miny <- p@layout$panel_params[[1]]$y.range[1] + maxy <- p@layout$panel_params[[1]]$y.range[2] expect_true(miny <= min(dat$y)) expect_true(maxy >= max(dat$y)) @@ -12,8 +12,8 @@ test_that("geom_boxplot range includes all outliers", { # Unless specifically directed not to p <- ggplot_build(ggplot(dat, aes(x, y)) + geom_boxplot(outliers = FALSE)) - miny <- p$layout$panel_params[[1]]$y.range[1] - maxy <- p$layout$panel_params[[1]]$y.range[2] + miny <- p@layout$panel_params[[1]]$y.range[1] + maxy <- p@layout$panel_params[[1]]$y.range[2] expect_lte(maxy, max(dat$y)) expect_gte(miny, min(dat$y)) diff --git a/tests/testthat/test-geom-dotplot.R b/tests/testthat/test-geom-dotplot.R index f7159bdd80..fa43204e67 100644 --- a/tests/testthat/test-geom-dotplot.R +++ b/tests/testthat/test-geom-dotplot.R @@ -68,8 +68,8 @@ test_that("when binning on y-axis, limits depend on the panel", { b1 <- ggplot_build(p + facet_wrap(~am)) b2 <- ggplot_build(p + facet_wrap(~am, scales = "free_y")) - equal_limits1 <- (b1$layout$panel_params[[1]]$y.range == b1$layout$panel_params[[2]]$y.range) - equal_limits2 <- (b2$layout$panel_params[[1]]$y.range == b2$layout$panel_params[[2]]$y.range) + equal_limits1 <- (b1@layout$panel_params[[1]]$y.range == b1@layout$panel_params[[2]]$y.range) + equal_limits2 <- (b2@layout$panel_params[[1]]$y.range == b2@layout$panel_params[[2]]$y.range) expect_true(all(equal_limits1)) expect_false(all(equal_limits2)) diff --git a/tests/testthat/test-geom-polygon.R b/tests/testthat/test-geom-polygon.R index 1e74c43b9d..eec237f588 100644 --- a/tests/testthat/test-geom-polygon.R +++ b/tests/testthat/test-geom-polygon.R @@ -40,9 +40,9 @@ test_that("geom_polygon is closed before munching", { coord_polar() built <- ggplot_build(p) - coord <- built$plot@coordinates - data <- built$data[[1]] - param <- built$layout$panel_params[[1]] + coord <- built@plot@coordinates + data <- built@data[[1]] + param <- built@layout$panel_params[[1]] closed <- coord_munch(coord, data, param, is_closed = TRUE) open <- coord_munch(coord, data, param, is_closed = FALSE) diff --git a/tests/testthat/test-geom-sf.R b/tests/testthat/test-geom-sf.R index f1df3ad59d..60a6ab49a1 100644 --- a/tests/testthat/test-geom-sf.R +++ b/tests/testthat/test-geom-sf.R @@ -30,24 +30,24 @@ test_that("geom_sf() determines the legend type automatically", { } # test the automatic choice - expect_true(fun_geom_sf(mp, TRUE)$plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mp, TRUE)$plot@layers[[1]]$computed_geom_params$legend, "point") + expect_true(fun_geom_sf(mp, TRUE)@plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mp, TRUE)@plot@layers[[1]]$computed_geom_params$legend, "point") - expect_true(fun_geom_sf(mls, TRUE)$plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mls, TRUE)$plot@layers[[1]]$computed_geom_params$legend, "line") + expect_true(fun_geom_sf(mls, TRUE)@plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mls, TRUE)@plot@layers[[1]]$computed_geom_params$legend, "line") - expect_true(fun_geom_sf(mpol, TRUE)$plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mpol, TRUE)$plot@layers[[1]]$computed_geom_params$legend, "other") + expect_true(fun_geom_sf(mpol, TRUE)@plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mpol, TRUE)@plot@layers[[1]]$computed_geom_params$legend, "other") # test that automatic choice can be overridden manually - expect_true(fun_geom_sf(mp, "point")$plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mp, "point")$plot@layers[[1]]$computed_geom_params$legend, "point") + expect_true(fun_geom_sf(mp, "point")@plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mp, "point")@plot@layers[[1]]$computed_geom_params$legend, "point") - expect_true(fun_geom_sf(mls, "point")$plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mls, "point")$plot@layers[[1]]$computed_geom_params$legend, "point") + expect_true(fun_geom_sf(mls, "point")@plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mls, "point")@plot@layers[[1]]$computed_geom_params$legend, "point") - expect_true(fun_geom_sf(mpol, "point")$plot@layers[[1]]$show.legend) - expect_identical(fun_geom_sf(mpol, "point")$plot@layers[[1]]$computed_geom_params$legend, "point") + expect_true(fun_geom_sf(mpol, "point")@plot@layers[[1]]$show.legend) + expect_identical(fun_geom_sf(mpol, "point")@plot@layers[[1]]$computed_geom_params$legend, "point") }) test_that("geom_sf() determines the legend type from mapped geometry column", { @@ -68,12 +68,12 @@ test_that("geom_sf() determines the legend type from mapped geometry column", { p <- ggplot_build( ggplot(d_sf) + geom_sf(aes(geometry = g_point, colour = "a")) ) - expect_identical(p$plot@layers[[1]]$computed_geom_params$legend, "point") + expect_identical(p@plot@layers[[1]]$computed_geom_params$legend, "point") p <- ggplot_build( ggplot(d_sf) + geom_sf(aes(geometry = g_line, colour = "a")) ) - expect_identical(p$plot@layers[[1]]$computed_geom_params$legend, "line") + expect_identical(p@plot@layers[[1]]$computed_geom_params$legend, "line") }) test_that("geom_sf() removes rows containing missing aes", { diff --git a/tests/testthat/test-guide-colorbar.R b/tests/testthat/test-guide-colorbar.R index b13d4d1b48..e9602a4c73 100644 --- a/tests/testthat/test-guide-colorbar.R +++ b/tests/testthat/test-guide-colorbar.R @@ -12,10 +12,10 @@ test_that("Colorbar respects show.legend in layer", { df <- data_frame(x = 1:3, y = 1) p <- ggplot(df, aes(x = x, y = y, color = x)) + geom_point(size = 20, shape = 21, show.legend = FALSE) - expect_length(ggplot_build(p)$plot@guides$guides, 0L) + expect_length(ggplot_build(p)@plot@guides$guides, 0L) p <- ggplot(df, aes(x = x, y = y, color = x)) + geom_point(size = 20, shape = 21, show.legend = TRUE) - expect_length(ggplot_build(p)$plot@guides$guides, 1L) + expect_length(ggplot_build(p)@plot@guides$guides, 1L) }) test_that("colorsteps and bins checks the breaks format", { diff --git a/tests/testthat/test-guide-legend.R b/tests/testthat/test-guide-legend.R index d877853649..dcc7c25e64 100644 --- a/tests/testthat/test-guide-legend.R +++ b/tests/testthat/test-guide-legend.R @@ -128,7 +128,7 @@ test_that("legends can be forced to display unrelated geoms", { ) b <- ggplot_build(p) - legend <- b$plot@guides$params[[1]] + legend <- b@plot@guides$params[[1]] expect_equal( legend$decor[[1]]$data$fill, diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index a0763f82b8..e939b5427e 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -6,7 +6,7 @@ test_that("guide_none() can be used in non-position scales", { scale_color_discrete(guide = guide_none()) built <- ggplot_build(p) - plot <- built$plot + plot <- built@plot guides <- guides_list(plot@guides) guides <- guides$build( plot@scales, @@ -156,7 +156,7 @@ test_that("empty guides are dropped", { expect_equal(nrow(gd), 0) # Draw guides - guides <- p$plot@guides$assemble(theme_gray()) + guides <- p@plot@guides$assemble(theme_gray()) # All guide-boxes should be empty expect_true(is.zero(guides)) diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 77b1b845b6..0fb469817e 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -134,15 +134,15 @@ test_that("position axis label hierarchy works as intended", { geom_point(size = 5) p <- ggplot_build(p) - resolve_label <- function(x) p$layout$resolve_label(x, p$plot@labels) + resolve_label <- function(x) p@layout$resolve_label(x, p@plot@labels) # In absence of explicit title, get title from mapping expect_identical( - resolve_label(p$layout$panel_scales_x[[1]]), + resolve_label(p@layout$panel_scales_x[[1]]), list(secondary = NULL, primary = "foo") ) expect_identical( - resolve_label(p$layout$panel_scales_y[[1]]), + resolve_label(p@layout$panel_scales_y[[1]]), list(primary = "bar", secondary = NULL) ) @@ -157,9 +157,9 @@ test_that("position axis label hierarchy works as intended", { ) # Guide titles overrule scale names - p$layout$setup_panel_guides( + p@layout$setup_panel_guides( guides_list(list(x = guide_axis("quuX"), y = guide_axis("corgE"))), - p$plot@layers + p@plot@layers ) expect_identical( resolve_label(scale_x_continuous("Baz")), @@ -183,10 +183,10 @@ test_that("position axis label hierarchy works as intended", { ) # Secondary guide titles override secondary axis names - p$layout$setup_panel_guides( + p@layout$setup_panel_guides( guides_list(list(x = guide_axis("quuX"), y = guide_axis("corgE"), x.sec = guide_axis("waldo"), y.sec = guide_axis("fred"))), - p$plot@layers + p@plot@layers ) expect_identical( resolve_label(xsec), @@ -231,38 +231,38 @@ test_that("moving guide positions lets titles follow", { p <- ggplot_build(p) # Default guide positions - p$layout$setup_panel_guides( + p@layout$setup_panel_guides( guides_list( list(x = guide_axis("baz", position = "bottom"), y = guide_axis("qux", position = "left")) ), - p$plot@layers + p@plot@layers ) labs <- get_labs(p) expect <- list(x = "baz", x.sec = NULL, y = "qux", y.sec = NULL) expect_identical(labs[names(expect)], expect) # Guides at secondary positions - p$layout$setup_panel_guides( + p@layout$setup_panel_guides( guides_list( list(x = guide_axis("baz", position = "top"), y = guide_axis("qux", position = "right")) ), - p$plot@layers + p@plot@layers ) labs <- get_labs(p) expect_identical(labs[names(expect)], expect) # Primary guides at secondary positions with # secondary guides at primary positions - p$layout$setup_panel_guides( + p@layout$setup_panel_guides( guides_list( list(x = guide_axis("baz", position = "top"), y = guide_axis("qux", position = "right"), x.sec = guide_axis("quux"), y.sec = guide_axis("corge")) ), - p$plot@layers + p@plot@layers ) labs <- get_labs(p) expect[c("x.sec", "y.sec")] <- list("quux", "corge") @@ -281,16 +281,16 @@ test_that("label dictionaries work", { )) p <- ggplot_build(p) - x <- p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot@labels) + x <- p@layout$resolve_label(p@layout$panel_scales_x[[1]], p@plot@labels) expect_equal(x$primary, "Displacement") - y <- p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot@labels) + y <- p@layout$resolve_label(p@layout$panel_scales_y[[1]], p@plot@labels) expect_equal(y$primary, "Miles per gallon") - shape <- p$plot@guides$get_params("shape")$title + shape <- p@plot@guides$get_params("shape")$title expect_equal(shape, "Number of cylinders") - size <- p$plot@guides$get_params("size")$title + size <- p@plot@guides$get_params("size")$title expect_equal(size, "Rear axle ratio") }) diff --git a/tests/testthat/test-scale-discrete.R b/tests/testthat/test-scale-discrete.R index 50f7b585fe..46e5c83d16 100644 --- a/tests/testthat/test-scale-discrete.R +++ b/tests/testthat/test-scale-discrete.R @@ -180,7 +180,7 @@ test_that("palettes work for discrete scales", { # Check discsrete expansion is applied b <- ggplot_build(p) expect_equal( - b$layout$panel_params[[1]]$x.range, + b@layout$panel_params[[1]]$x.range, range(values) + c(-0.6, 0.6) ) }) diff --git a/tests/testthat/test-scale-manual.R b/tests/testthat/test-scale-manual.R index 324485952b..75f4879607 100644 --- a/tests/testthat/test-scale-manual.R +++ b/tests/testthat/test-scale-manual.R @@ -26,7 +26,7 @@ dat <- data_frame(g = c("B","A","A")) p <- ggplot(dat, aes(g, fill = g)) + geom_bar() col <- c("A" = "red", "B" = "green", "C" = "blue") -cols <- function(x) ggplot_build(x)$data[[1]][, "fill"] +cols <- function(x) ggplot_build(x)@data[[1]][, "fill"] test_that("named values work regardless of order", { fill_scale <- function(order) scale_fill_manual(values = col[order], diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 7670bdf1c7..3582439d48 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -146,18 +146,18 @@ test_that("all-Inf layers are not used for determining the type of scale", { geom_point() b1 <- ggplot_build(p1) - expect_s3_class(b1$layout$panel_scales_x[[1]], "ScaleDiscretePosition") + expect_s3_class(b1@layout$panel_scales_x[[1]], "ScaleDiscretePosition") p2 <- ggplot() + # If the layer non-Inf value, it's considered annotate("rect", xmin = -Inf, xmax = 0, ymin = -Inf, ymax = Inf, fill = "black") b2 <- ggplot_build(p2) - expect_s3_class(b2$layout$panel_scales_x[[1]], "ScaleContinuousPosition") + expect_s3_class(b2@layout$panel_scales_x[[1]], "ScaleContinuousPosition") }) test_that("scales are looked for in appropriate place", { - xlabel <- function(x) ggplot_build(x)$layout$panel_scales_x[[1]]$name + xlabel <- function(x) ggplot_build(x)@layout$panel_scales_x[[1]]$name p0 <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + scale_x_continuous("0") expect_equal(xlabel(p0), "0") @@ -343,12 +343,12 @@ test_that("scale_apply preserves class and attributes", { # Perform identity transformation via `scale_apply` out <- with_bindings(scale_apply( - df, "x", "transform", 1:2, plot$layout$panel_scales_x + df, "x", "transform", 1:2, plot@layout$panel_scales_x )[[1]], `c.baz` = `c.baz`, `[.baz` = `[.baz`, .env = global_env()) # Check that it errors on bad scale ids expect_snapshot_error(scale_apply( - df, "x", "transform", c(NA, 1), plot$layout$panel_scales_x + df, "x", "transform", c(NA, 1), plot@layout$panel_scales_x )) # Check class preservation @@ -362,7 +362,7 @@ test_that("scale_apply preserves class and attributes", { class(df$x) <- "foobar" out <- with_bindings(scale_apply( - df, "x", "transform", 1:2, plot$layout$panel_scales_x + df, "x", "transform", 1:2, plot@layout$panel_scales_x )[[1]], `c.baz` = `c.baz`, `[.baz` = `[.baz`, .env = global_env()) expect_false(inherits(out, "foobar")) diff --git a/tests/testthat/test-stat-bin.R b/tests/testthat/test-stat-bin.R index 3df87821b8..7d29dbb2b8 100644 --- a/tests/testthat/test-stat-bin.R +++ b/tests/testthat/test-stat-bin.R @@ -241,19 +241,19 @@ test_that("stat_count throws error when both x and y aesthetic present", { test_that("stat_count preserves x order for continuous and discrete", { # x is numeric b <- ggplot_build(ggplot(mtcars, aes(carb)) + geom_bar()) - expect_identical(b$data[[1]]$x, c(1,2,3,4,6,8)) - expect_identical(b$data[[1]]$y, c(7,10,3,10,1,1)) + expect_identical(b@data[[1]]$x, c(1,2,3,4,6,8)) + expect_identical(b@data[[1]]$y, c(7,10,3,10,1,1)) # x is factor where levels match numeric order mtcars$carb2 <- factor(mtcars$carb) b <- ggplot_build(ggplot(mtcars, aes(carb2)) + geom_bar()) - expect_identical(b$data[[1]]$x, mapped_discrete(1:6)) - expect_identical(b$data[[1]]$y, c(7,10,3,10,1,1)) + expect_identical(b@data[[1]]$x, mapped_discrete(1:6)) + expect_identical(b@data[[1]]$y, c(7,10,3,10,1,1)) # x is factor levels differ from numeric order mtcars$carb3 <- factor(mtcars$carb, levels = c(4,1,2,3,6,8)) b <- ggplot_build(ggplot(mtcars, aes(carb3)) + geom_bar()) - expect_identical(b$data[[1]]$x, mapped_discrete(1:6)) - expect_identical(b$layout$panel_params[[1]]$x$get_labels(), c("4","1","2","3","6","8")) - expect_identical(b$data[[1]]$y, c(10,7,10,3,1,1)) + expect_identical(b@data[[1]]$x, mapped_discrete(1:6)) + expect_identical(b@layout$panel_params[[1]]$x$get_labels(), c("4","1","2","3","6","8")) + expect_identical(b@data[[1]]$y, c(10,7,10,3,1,1)) }) diff --git a/tests/testthat/test-stats.R b/tests/testthat/test-stats.R index 8545b485fd..76b4ea0296 100644 --- a/tests/testthat/test-stats.R +++ b/tests/testthat/test-stats.R @@ -3,12 +3,12 @@ test_that("plot succeeds even if some computation fails", { p1 <- ggplot(df, aes(x, y)) + geom_point() b1 <- ggplot_build(p1) - expect_length(b1$data, 1) + expect_length(b1@data, 1) p2 <- p1 + stat_summary(fun = function(x) stop("Failed computation")) expect_snapshot_warning(b2 <- ggplot_build(p2)) - expect_length(b2$data, 2) + expect_length(b2@data, 2) }) test_that("error message is thrown when aesthetics are missing", { @@ -45,9 +45,9 @@ test_that("erroneously dropped aesthetics are found and issue a warning", { ) # colour is dropped because group a's colour is not constant (GeomBar$default_aes$colour is NA) - expect_true(all(is.na(b2$data[[1]]$colour))) + expect_true(all(is.na(b2@data[[1]]$colour))) # fill is dropped because group b's fill is not constant - expect_true(all(b2$data[[1]]$fill == "#595959FF")) + expect_true(all(b2@data[[1]]$fill == "#595959FF")) # case 2-1) dropped partially with NA @@ -62,10 +62,10 @@ test_that("erroneously dropped aesthetics are found and issue a warning", { expect_snapshot_warning(b3 <- ggplot_build(p3)) # colour is dropped because group a's colour is not constant (GeomBar$default_aes$colour is NA) - expect_true(all(is.na(b3$data[[1]]$colour))) + expect_true(all(is.na(b3@data[[1]]$colour))) # fill is NOT dropped. Group a's fill is na.value, but others are mapped. expect_equal( - b3$data[[1]]$fill == "#123", + b3@data[[1]]$fill == "#123", c(TRUE, FALSE, FALSE) ) }) diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 5af8e74b5c..a150201896 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -221,33 +221,33 @@ test_that("complete and non-complete themes interact correctly with ggplot objec # Check that adding two theme successive theme objects to a ggplot object # works like adding the two theme object to each other p <- ggplot_build(base + theme_bw() + theme(text = element_text(colour = 'red'))) - expect_true(attr(p$plot@theme, "complete")) + expect_true(attr(p@plot@theme, "complete")) # Compare the theme objects, after sorting the items, because item order can differ - pt <- p$plot@theme + pt <- p@plot@theme tt <- theme_bw() + theme(text = element_text(colour = 'red')) pt <- pt[order(names(pt))] tt <- tt[order(names(tt))] expect_identical(pt, tt) p <- ggplot_build(base + theme(text = element_text(colour = 'red')) + theme_bw()) - expect_true(attr(p$plot@theme, "complete")) + expect_true(attr(p@plot@theme, "complete")) # Compare the theme objects, after sorting the items, because item order can differ - pt <- p$plot@theme + pt <- p@plot@theme tt <- theme(text = element_text(colour = 'red')) + theme_bw() pt <- pt[order(names(pt))] tt <- tt[order(names(tt))] expect_identical(pt, tt) p <- ggplot_build(base + theme(text = element_text(colour = 'red', face = 'italic'))) - expect_equal(p$plot@theme$text$colour, "red") - expect_equal(p$plot@theme$text$face, "italic") + expect_equal(p@plot@theme$text$colour, "red") + expect_equal(p@plot@theme$text$face, "italic") p <- ggplot_build(base + theme(text = element_text(colour = 'red')) + theme(text = element_text(face = 'italic'))) - expect_equal(p$plot@theme$text$colour, "red") - expect_equal(p$plot@theme$text$face, "italic") + expect_equal(p@plot@theme$text$colour, "red") + expect_equal(p@plot@theme$text$face, "italic") }) test_that("theme(validate=FALSE) means do not check_element", { From ef5db54fec83c4127b044aea488d1e01b34316f7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 14 Mar 2025 10:27:51 +0100 Subject: [PATCH 11/30] implement `as.gtable` methods --- DESCRIPTION | 2 +- R/plot-build.R | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index de58fdc300..50c5d71a21 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,7 +35,7 @@ Imports: cli, grDevices, grid, - gtable (>= 0.1.1), + gtable (>= 0.3.6), isoband, lifecycle (> 1.0.1), rlang (>= 1.1.0), diff --git a/R/plot-build.R b/R/plot-build.R index acaa82b09b..2b08862392 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -320,6 +320,9 @@ ggplotGrob <- function(x) { ggplot_gtable(ggplot_build(x)) } +S7::method(as.gtable, class_ggplot) <- ggplotGrob +S7::method(as.gtable, class_ggplot_built) <- ggplotGrob + # Apply function to layer and matching data by_layer <- function(f, layers, data, step = NULL) { ordinal <- label_ordinal() From 206c394fcd111f39f4e2e8821d6c3c5dd83125af Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 14 Mar 2025 11:26:58 +0100 Subject: [PATCH 12/30] rename mapping to class_mapping --- NAMESPACE | 1 + R/aes.R | 34 ++++++++++++++++++++++------------ R/layer.R | 4 ++-- R/plot-construction.R | 4 ++-- R/plot.R | 2 +- R/quick-plot.R | 2 +- man/class_mapping.Rd | 18 ++++++++++++++++++ tests/testthat/_snaps/aes.md | 2 +- tests/testthat/test-add.R | 2 +- tests/testthat/test-aes.R | 4 ++-- tests/testthat/test-geom-.R | 4 ++-- 11 files changed, 53 insertions(+), 24 deletions(-) create mode 100644 man/class_mapping.Rd diff --git a/NAMESPACE b/NAMESPACE index 0d7e663d74..0684951242 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -292,6 +292,7 @@ export(binned_scale) export(borders) export(calc_element) export(check_device) +export(class_mapping) export(combine_vars) export(complete_theme) export(continuous_scale) diff --git a/R/aes.R b/R/aes.R index d02282eb5a..d85880d57b 100644 --- a/R/aes.R +++ b/R/aes.R @@ -105,10 +105,20 @@ aes <- function(x, y, ...) { inject(aes(!!!args)) }) - mapping(rename_aes(args), env = parent.frame()) + class_mapping(rename_aes(args), env = parent.frame()) } -mapping <- S7::new_class( +#' The mapping class +#' +#' The mapping class holds a list of quoted expressions +#' ([quosures][rlang::topic-quosure]) or constants. An object is typically +#' constructed using the [`aes()`] function. +#' +#' @param x A list of quosures and constants. +#' @param env An environment for symbols that are not quosures or constants. +#' +#' @export +class_mapping <- S7::new_class( "mapping", parent = S7::new_S3_class("gg"), constructor = function(x, env = globalenv()) { check_object(x, is.list, "a {.cls list}") @@ -119,7 +129,7 @@ mapping <- S7::new_class( #' @export #' @rdname is_tests -is.mapping <- function(x) S7::S7_inherits(x, mapping) +is.mapping <- function(x) S7::S7_inherits(x, class_mapping) # Wrap symbolic objects in quosures but pull out constants out of # quosures for backward-compatibility @@ -157,21 +167,21 @@ new_aesthetic <- function(x, env = globalenv()) { #' @export "[.ggplot2::mapping" <- function(x, i, ...) { - mapping(NextMethod()) + class_mapping(NextMethod()) } # If necessary coerce replacements to quosures for compatibility #' @export "[[<-.ggplot2::mapping" <- function(x, i, value) { - mapping(NextMethod()) + class_mapping(NextMethod()) } #' @export "$<-.ggplot2::mapping" <- function(x, i, value) { - mapping(NextMethod()) + class_mapping(NextMethod()) } #' @export "[<-.ggplot2::mapping" <- function(x, i, value) { - mapping(NextMethod()) + class_mapping(NextMethod()) } #' Standardise aesthetic names @@ -212,7 +222,7 @@ substitute_aes <- function(x, fun = standardise_aes_symbols, ...) { x <- lapply(x, function(aesthetic) { as_quosure(fun(quo_get_expr(aesthetic), ...), env = environment(aesthetic)) }) - mapping(x) + class_mapping(x) } # x is a quoted expression from inside aes() standardise_aes_symbols <- function(x) { @@ -310,7 +320,7 @@ aes_ <- function(x, y, ...) { } } mapping <- lapply(mapping, as_quosure_aes) - mapping(rename_aes(mapping)) + class_mapping(rename_aes(mapping)) } #' @rdname aes_ @@ -336,7 +346,7 @@ aes_string <- function(x, y, ...) { new_aesthetic(x, env = caller_env) }) - mapping(rename_aes(mapping)) + class_mapping(rename_aes(mapping)) } #' @export @@ -357,7 +367,7 @@ aes_all <- function(vars) { # Quosure the symbols in the empty environment because they can only # refer to the data mask - mapping(lapply(vars, function(x) new_quosure(as.name(x), emptyenv()))) + class_mapping(lapply(vars, function(x) new_quosure(as.name(x), emptyenv()))) } #' Automatic aesthetic mapping @@ -392,7 +402,7 @@ aes_auto <- function(data = NULL, ...) { aes <- c(aes, args[names(args) != "data"]) } - mapping(rename_aes(aes)) + class_mapping(rename_aes(aes)) } mapped_aesthetics <- function(x) { diff --git a/R/layer.R b/R/layer.R index 49e53f35d9..ae255dfd70 100644 --- a/R/layer.R +++ b/R/layer.R @@ -213,7 +213,7 @@ validate_mapping <- function(mapping, call = caller_env()) { } # For backward compatibility with pre-tidy-eval layers - mapping(mapping) + class_mapping(mapping) } Layer <- ggproto("Layer", NULL, @@ -265,7 +265,7 @@ Layer <- ggproto("Layer", NULL, setup_layer = function(self, data, plot) { # For annotation geoms, it is useful to be able to ignore the default aes if (isTRUE(self$inherit.aes)) { - self$computed_mapping <- mapping(defaults(self$mapping, plot@mapping)) + self$computed_mapping <- class_mapping(defaults(self$mapping, plot@mapping)) # Inherit size as linewidth from global mapping if (self$geom$rename_size && diff --git a/R/plot-construction.R b/R/plot-construction.R index 301f3d4361..ab5ec1b267 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -156,9 +156,9 @@ S7::method(ggplot_add, list(class_guides, class_ggplot)) <- plot } -S7::method(ggplot_add, list(mapping, class_ggplot)) <- +S7::method(ggplot_add, list(class_mapping, class_ggplot)) <- function(object, plot, ...) { - S7::set_props(plot, mapping = mapping(defaults(object, plot@mapping))) + S7::set_props(plot, mapping = class_mapping(defaults(object, plot@mapping))) } S7::method(ggplot_add, list(theme, class_ggplot)) <- diff --git a/R/plot.R b/R/plot.R index e532661e3c..687c8919cd 100644 --- a/R/plot.R +++ b/R/plot.R @@ -8,7 +8,7 @@ class_ggplot <- S7::new_class( layers = S7::class_list, scales = class_scales_list, guides = class_guides, - mapping = mapping, + mapping = class_mapping, theme = theme, coordinates = class_coord, facet = class_facet, diff --git a/R/quick-plot.R b/R/quick-plot.R index cf0b68d788..cd5a7b201e 100644 --- a/R/quick-plot.R +++ b/R/quick-plot.R @@ -78,7 +78,7 @@ qplot <- function(x, y, ..., data, facets = NULL, margins = FALSE, is_constant <- (!names(exprs) %in% ggplot_global$all_aesthetics) | vapply(exprs, quo_is_call, logical(1), name = "I") - mapping <- mapping(exprs[!is_missing & !is_constant], env = parent.frame()) + mapping <- class_mapping(exprs[!is_missing & !is_constant], env = parent.frame()) consts <- exprs[is_constant] diff --git a/man/class_mapping.Rd b/man/class_mapping.Rd new file mode 100644 index 0000000000..869b95d34e --- /dev/null +++ b/man/class_mapping.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/aes.R +\name{class_mapping} +\alias{class_mapping} +\title{The mapping class} +\usage{ +class_mapping(x, env = globalenv()) +} +\arguments{ +\item{x}{A list of quosures and constants.} + +\item{env}{An environment for symbols that are not quosures or constants.} +} +\description{ +The mapping class holds a list of quoted expressions +(\link[rlang:topic-quosure]{quosures}) or constants. An object is typically +constructed using the \code{\link[=aes]{aes()}} function. +} diff --git a/tests/testthat/_snaps/aes.md b/tests/testthat/_snaps/aes.md index 46d72876e7..c4b534a453 100644 --- a/tests/testthat/_snaps/aes.md +++ b/tests/testthat/_snaps/aes.md @@ -54,7 +54,7 @@ Don't know how to get alternative usage for `foo`. -# mapping() checks its inputs +# class_mapping() checks its inputs `x` must be a , not an integer vector. diff --git a/tests/testthat/test-add.R b/tests/testthat/test-add.R index 1f08648e49..0c318e6c9e 100644 --- a/tests/testthat/test-add.R +++ b/tests/testthat/test-add.R @@ -1,4 +1,4 @@ test_that("mapping class is preserved when adding mapping objects", { p <- ggplot(mtcars) + aes(wt, mpg) - expect_s7_class(p@mapping, mapping) + expect_s7_class(p@mapping, class_mapping) }) diff --git a/tests/testthat/test-aes.R b/tests/testthat/test-aes.R index c4f479d02c..8b0b95882f 100644 --- a/tests/testthat/test-aes.R +++ b/tests/testthat/test-aes.R @@ -195,8 +195,8 @@ test_that("alternative_aes_extract_usage() can inspect the call", { expect_snapshot_error(alternative_aes_extract_usage(x)) }) -test_that("mapping() checks its inputs", { - expect_snapshot_error(mapping(1:5)) +test_that("class_mapping() checks its inputs", { + expect_snapshot_error(class_mapping(1:5)) }) # Visual tests ------------------------------------------------------------ diff --git a/tests/testthat/test-geom-.R b/tests/testthat/test-geom-.R index 3c22324c91..02e0ed9710 100644 --- a/tests/testthat/test-geom-.R +++ b/tests/testthat/test-geom-.R @@ -53,7 +53,7 @@ test_that("updating geom aesthetic defaults preserves class and order", { updated_defaults <- GeomPoint$default_aes - expect_s7_class(updated_defaults, mapping) + expect_s7_class(updated_defaults, class_mapping) intended_defaults <- original_defaults intended_defaults[["colour"]] <- "red" @@ -75,7 +75,7 @@ test_that("updating stat aesthetic defaults preserves class and order", { updated_defaults <- StatBin$default_aes - expect_s7_class(updated_defaults, mapping) + expect_s7_class(updated_defaults, class_mapping) intended_defaults <- original_defaults intended_defaults[["y"]] <- expr(after_stat(density)) From 53504c3fe7798187ab78045bfccdc07a1f101d10 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 14 Mar 2025 14:31:45 +0100 Subject: [PATCH 13/30] refine class_ggplot_built and related functions --- NAMESPACE | 7 +- R/all-classes.R | 1 - R/plot-build.R | 64 +++++++++----- R/plot.R | 86 +++++++++++++------ man/class_ggplot.Rd | 49 +++++++++++ man/class_ggplot_built.Rd | 22 +++++ man/ggplot.Rd | 2 +- tests/testthat/_snaps/prohibited-functions.md | 3 + 8 files changed, 179 insertions(+), 55 deletions(-) create mode 100644 man/class_ggplot.Rd create mode 100644 man/class_ggplot_built.Rd diff --git a/NAMESPACE b/NAMESPACE index 0684951242..483d85c465 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -58,11 +58,6 @@ S3method(fortify,tbl_df) S3method(get_alt_text,ggplot) S3method(get_alt_text,ggplot_built) S3method(get_alt_text,gtable) -S3method(ggplot,"function") -S3method(ggplot,default) -S3method(ggplot_build,ggplot) -S3method(ggplot_build,ggplot_built) -S3method(ggplot_gtable,ggplot_built) S3method(grid.draw,absoluteGrob) S3method(grobHeight,absoluteGrob) S3method(grobHeight,zeroGrob) @@ -292,6 +287,8 @@ export(binned_scale) export(borders) export(calc_element) export(check_device) +export(class_ggplot) +export(class_ggplot_built) export(class_mapping) export(combine_vars) export(complete_theme) diff --git a/R/all-classes.R b/R/all-classes.R index 88fc6db554..23a61af504 100644 --- a/R/all-classes.R +++ b/R/all-classes.R @@ -7,6 +7,5 @@ class_facet <- S7::new_S3_class("Facet") class_layer <- S7::new_S3_class("Layer") class_layout <- S7::new_S3_class("Layout") class_scales_list <- S7::new_S3_class("ScalesList") -class_layout <- S7::new_S3_class("Layout") class_ggproto <- S7::new_S3_class("ggproto") class_gtable <- S7::new_S3_class("gtable") diff --git a/R/plot-build.R b/R/plot-build.R index 2b08862392..f6b4ecb77a 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -1,12 +1,37 @@ #' @include plot.R +NULL +#' The ggplot built class +#' +#' The ggplot built class is an intermediate class and represents a processed +#' ggplot object ready for rendering. It is constructed by calling +#' [`ggplot_build()`] on a [ggplot][class_ggplot] object and is not meant to be +#' instantiated directly. The class can be rendered to a gtable object by +#' calling the [`ggplot_gtable()`] function on a ggplot built class object. +#' +#' @param data A list of plain data frames; one for each layer. +#' @param layout A Layout ggproto object. +#' @param plot A completed ggplot class object. +#' +#' @export class_ggplot_built <- S7::new_class( "ggplot_built", properties = list( - data = S7::class_list, + data = S7::class_list, layout = class_layout, - plot = class_ggplot - ) + plot = class_ggplot + ), + constructor = function(data = NULL, layout = NULL, plot = NULL) { + if (is.null(data) || is.null(layout) || is.null(plot)) { + cli::cli_abort( + "The {.cls ggplot_built} class should be constructed by {.fn ggplot_build}." + ) + } + S7::new_object( + S7::S7_object(), + data = data, layout = layout, plot = plot + ) + } ) #' Build ggplot for rendering. @@ -34,21 +59,19 @@ class_ggplot_built <- S7::new_class( #' The `r link_book("build step section", "internals#sec-ggplotbuild")` #' @keywords internal #' @export -ggplot_build <- function(plot) { +ggplot_build <- S7::new_generic("ggplot_build", "plot", fun = function(plot) { # Attaching the plot env to be fetched by deprecations etc. - attach_plot_env(plot$plot_env) + if (S7::S7_inherits(plot) && S7::prop_exists(plot, "plot_env")) { + attach_plot_env(plot@plot_env) + } + S7::S7_dispatch() +}) - UseMethod('ggplot_build') +S7::method(ggplot_build, class_ggplot_built) <- function(plot) { + plot # This is a no-op } -#' @export -ggplot_build.ggplot_built <- function(plot) { - # This is a no-op - plot -} - -#' @export -ggplot_build.ggplot <- function(plot) { +S7::method(ggplot_build, class_ggplot) <- function(plot) { plot <- plot_clone(plot) if (length(plot@layers) == 0) { plot <- plot + geom_blank() @@ -202,15 +225,12 @@ layer_grob <- get_layer_grob #' @keywords internal #' @param data plot data generated by [ggplot_build()] #' @export -ggplot_gtable <- function(data) { - # Attaching the plot env to be fetched by deprecations etc. - attach_plot_env(data$plot@plot_env) - - UseMethod('ggplot_gtable') -} +ggplot_gtable <- S7::new_generic("ggplot_gtable", "data", function(data) { + attach_plot_env(data@plot@plot_env) + S7::S7_dispatch() +}) -#' @export -ggplot_gtable.ggplot_built <- function(data) { +S7::method(ggplot_gtable, class_ggplot_built) <- function(data) { plot <- data@plot layout <- data@layout data <- data@data diff --git a/R/plot.R b/R/plot.R index 687c8919cd..ee86a210fc 100644 --- a/R/plot.R +++ b/R/plot.R @@ -1,6 +1,27 @@ #' @include all-classes.R #' @include theme.R +NULL +#' The ggplot class +#' +#' The ggplot class collects the needed information to render a plot. +#' This class can be constructed using the [`ggplot()`] function. +#' +#' @param data A property containing any data coerced by [`fortify()`]. +#' @param layers A list of layer instances created by [`layer()`]. +#' @param scales A ScalesList ggproto object. +#' @param guides A Guides ggproto object created by [`guides()`]. +#' @param mapping A mapping class object created by [`aes()`]. +#' @param theme A theme class object created by [`theme()`]. +#' @param coordinates A Coord ggproto object created by `coord_*()` family of +#' functions. +#' @param facet A Facet ggproto object created by `facet_*()` family of +#' functions. +#' @param layout A Layout ggproto object. +#' @param labels A labels object created by [`labs()`]. +#' @param plot_env An environment. +#' +#' @export class_ggplot <- S7::new_class( name = "ggplot", parent = class_gg, properties = list( @@ -15,7 +36,23 @@ class_ggplot <- S7::new_class( layout = class_layout, labels = labs, plot_env = S7::class_environment - ) + ), + constructor = function(data = waiver(), layers = list(), scales = NULL, + guides = NULL, mapping = aes(), theme = NULL, + coordinates = coord_cartesian(default = TRUE), + facet = facet_null(), layout = NULL, + labels = labs(), plot_env = parent.frame()) { + S7::new_object( + S7::S7_object(), + data = data, layers = layers, + scales = scales %||% scales_list(), + guides = guides %||% guides_list(), + mapping = mapping, theme = theme %||% theme(), + coordinates = coordinates, facet = facet, + layout = layout %||% ggproto(NULL, Layout), + labels = labels, plot_env = plot_env + ) + } ) #' Create a new ggplot @@ -123,35 +160,32 @@ class_ggplot <- S7::new_class( #' mapping = aes(x = group, y = group_mean), data = group_means_df, #' colour = 'red', size = 3 #' ) -ggplot <- function(data = NULL, mapping = aes(), ..., - environment = parent.frame()) { - UseMethod("ggplot") -} +ggplot <- S7::new_generic( + "ggplot2", "data", + fun = function(data, mapping = aes(), ..., environment = parent.frame()) { + S7::S7_dispatch() + } +) -#' @export -ggplot.default <- function(data = NULL, mapping = aes(), ..., - environment = parent.frame()) { +S7::method(ggplot, S7::class_any) <- function( + data, mapping = aes(), ..., + environment = parent.frame()) { 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}}." )) } + if (missing(data)) { + data <- NULL + } data <- fortify(data, ...) p <- class_ggplot( data = data, - layers = list(), - scales = scales_list(), - guides = guides_list(), mapping = mapping, - theme = theme(), - coordinates = coord_cartesian(default = TRUE), - facet = facet_null(), - plot_env = environment, - layout = ggproto(NULL, Layout), - labels = labs() + plot_env = environment ) class(p) <- union("ggplot", class(p)) @@ -159,15 +193,15 @@ ggplot.default <- function(data = NULL, mapping = aes(), ..., p } -#' @export -ggplot.function <- function(data = NULL, mapping = aes(), ..., - environment = parent.frame()) { - # Added to avoid functions end in ggplot.default - cli::cli_abort(c( - "{.arg data} cannot be a function.", - "i" = "Have you misspelled the {.arg data} argument in {.fn ggplot}" - )) -} +S7::method(ggplot, S7::class_function) <- + function(data, mapping = aes(), ..., + environment = parent.frame()) { + # Added to avoid functions end in ggplot.default + cli::cli_abort(c( + "{.arg data} cannot be a function.", + "i" = "Have you misspelled the {.arg data} argument in {.fn ggplot}" + )) + } #' Reports whether x is a type of object #' @param x An object to test diff --git a/man/class_ggplot.Rd b/man/class_ggplot.Rd new file mode 100644 index 0000000000..2113d767ad --- /dev/null +++ b/man/class_ggplot.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.R +\name{class_ggplot} +\alias{class_ggplot} +\title{The ggplot class} +\usage{ +class_ggplot( + data = waiver(), + layers = list(), + scales = NULL, + guides = NULL, + mapping = aes(), + theme = NULL, + coordinates = coord_cartesian(default = TRUE), + facet = facet_null(), + layout = NULL, + labels = labs(), + plot_env = parent.frame() +) +} +\arguments{ +\item{data}{A property containing any data coerced by \code{\link[=fortify]{fortify()}}.} + +\item{layers}{A list of layer instances created by \code{\link[=layer]{layer()}}.} + +\item{scales}{A ScalesList ggproto object.} + +\item{guides}{A Guides ggproto object created by \code{\link[=guides]{guides()}}.} + +\item{mapping}{A mapping class object created by \code{\link[=aes]{aes()}}.} + +\item{theme}{A theme class object created by \code{\link[=theme]{theme()}}.} + +\item{coordinates}{A Coord ggproto object created by \verb{coord_*()} family of +functions.} + +\item{facet}{A Facet ggproto object created by \verb{facet_*()} family of +functions.} + +\item{layout}{A Layout ggproto object.} + +\item{labels}{A labels object created by \code{\link[=labs]{labs()}}.} + +\item{plot_env}{An environment.} +} +\description{ +The ggplot class collects the needed information to render a plot. +This class can be constructed using the \code{\link[=ggplot]{ggplot()}} function. +} diff --git a/man/class_ggplot_built.Rd b/man/class_ggplot_built.Rd new file mode 100644 index 0000000000..010d01c22f --- /dev/null +++ b/man/class_ggplot_built.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-build.R +\name{class_ggplot_built} +\alias{class_ggplot_built} +\title{The ggplot built class} +\usage{ +class_ggplot_built(data = NULL, layout = NULL, plot = NULL) +} +\arguments{ +\item{data}{A list of plain data frames; one for each layer.} + +\item{layout}{A Layout ggproto object.} + +\item{plot}{A completed ggplot class object.} +} +\description{ +The ggplot built class is an intermediate class and represents a processed +ggplot object ready for rendering. It is constructed by calling +\code{\link[=ggplot_build]{ggplot_build()}} on a \link[=class_ggplot]{ggplot} object and is not meant to be +instantiated directly. The class can be rendered to a gtable object by +calling the \code{\link[=ggplot_gtable]{ggplot_gtable()}} function on a ggplot built class object. +} diff --git a/man/ggplot.Rd b/man/ggplot.Rd index ecb7fe5401..2a119981e7 100644 --- a/man/ggplot.Rd +++ b/man/ggplot.Rd @@ -4,7 +4,7 @@ \alias{ggplot} \title{Create a new ggplot} \usage{ -ggplot(data = NULL, mapping = aes(), ..., environment = parent.frame()) +ggplot(data, mapping = aes(), ..., environment = parent.frame()) } \arguments{ \item{data}{Default dataset to use for plot. If not already a data.frame, diff --git a/tests/testthat/_snaps/prohibited-functions.md b/tests/testthat/_snaps/prohibited-functions.md index aa82e6dd65..7aa3fc64c6 100644 --- a/tests/testthat/_snaps/prohibited-functions.md +++ b/tests/testthat/_snaps/prohibited-functions.md @@ -12,6 +12,9 @@ $calc_element [1] "skip_blank" + $class_ggplot + [1] "plot_env" + $continuous_scale [1] "scale_name" "minor_breaks" From bbdc7a59c1b50e64fd0771d4e361409b6045f011 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 14 Mar 2025 15:25:36 +0100 Subject: [PATCH 14/30] also access ggplot_built slots with normal extractors --- NAMESPACE | 12 ++++++------ R/plot.R | 12 ++++++------ 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 483d85c465..a5f4b5d5d3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,21 +1,21 @@ # Generated by roxygen2: do not edit by hand -S3method("$","ggplot2::ggplot") +S3method("$","ggplot2::gg") S3method("$","ggplot2::theme") S3method("$",ggproto) S3method("$",ggproto_parent) -S3method("$<-","ggplot2::ggplot") +S3method("$<-","ggplot2::gg") S3method("$<-","ggplot2::mapping") S3method("+",gg) -S3method("[","ggplot2::ggplot") +S3method("[","ggplot2::gg") S3method("[","ggplot2::mapping") S3method("[",mapped_discrete) -S3method("[<-","ggplot2::ggplot") +S3method("[<-","ggplot2::gg") S3method("[<-","ggplot2::mapping") S3method("[<-",mapped_discrete) -S3method("[[","ggplot2::ggplot") +S3method("[[","ggplot2::gg") S3method("[[",ggproto) -S3method("[[<-","ggplot2::ggplot") +S3method("[[<-","ggplot2::gg") S3method("[[<-","ggplot2::mapping") S3method(.DollarNames,ggproto) S3method(as.data.frame,mapped_discrete) diff --git a/R/plot.R b/R/plot.R index ee86a210fc..3f4830f9a3 100644 --- a/R/plot.R +++ b/R/plot.R @@ -280,34 +280,34 @@ S7::method(print, class_ggplot) <- } #' @export -`$.ggplot2::ggplot` <- function(x, i) { +`$.ggplot2::gg` <- function(x, i) { `[[`(S7::props(x), i) } #' @export -`$<-.ggplot2::ggplot` <- function(x, i, value) { +`$<-.ggplot2::gg` <- function(x, i, value) { S7::props(x) <- `$<-`(S7::props(x), i, value) x } #' @export -`[.ggplot2::ggplot` <- function(x, i) { +`[.ggplot2::gg` <- function(x, i) { `[`(S7::props(x), i) } #' @export -`[<-.ggplot2::ggplot` <- function(x, i, value) { +`[<-.ggplot2::gg` <- function(x, i, value) { S7::props(x) <- `[<-`(S7::props(x), i, value) x } #' @export -`[[.ggplot2::ggplot` <- function(x, i) { +`[[.ggplot2::gg` <- function(x, i) { `[[`(S7::props(x), i) } #' @export -`[[<-.ggplot2::ggplot` <- function(x, i, value) { +`[[<-.ggplot2::gg` <- function(x, i, value) { S7::props(x) <- `[[<-`(S7::props(x), i, value) x } From 2f06dd5ebac181cb89542a7efd45d504d6f7a4e4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 14 Mar 2025 16:09:35 +0100 Subject: [PATCH 15/30] resolve gnarlyness in S3/S7 method conflicts --- NAMESPACE | 6 ++++-- R/labels.R | 4 ++-- R/plot.R | 5 +++-- R/theme.R | 3 ++- man/is_tests.Rd | 8 ++++---- ...rint.ggplot.Rd => print.ggplot2-colon-colon-ggplot.Rd} | 4 ++-- 6 files changed, 17 insertions(+), 13 deletions(-) rename man/{print.ggplot.Rd => print.ggplot2-colon-colon-ggplot.Rd} (94%) diff --git a/NAMESPACE b/NAMESPACE index a5f4b5d5d3..692d2c3055 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -55,8 +55,8 @@ S3method(fortify,sfg) S3method(fortify,summary.glht) S3method(fortify,tbl) S3method(fortify,tbl_df) -S3method(get_alt_text,ggplot) -S3method(get_alt_text,ggplot_built) +S3method(get_alt_text,"ggplot2::ggplot") +S3method(get_alt_text,"ggplot2::ggplot_built") S3method(get_alt_text,gtable) S3method(grid.draw,absoluteGrob) S3method(grobHeight,absoluteGrob) @@ -91,7 +91,9 @@ S3method(predictdf,default) S3method(predictdf,glm) S3method(predictdf,locfit) S3method(predictdf,loess) +S3method(print,"ggplot2::ggplot") S3method(print,"ggplot2::mapping") +S3method(print,"ggplot2::theme") S3method(print,element) S3method(print,ggplot2_bins) S3method(print,ggproto) diff --git a/R/labels.R b/R/labels.R index 6ec8ae5535..c82fb0933b 100644 --- a/R/labels.R +++ b/R/labels.R @@ -280,7 +280,7 @@ get_alt_text <- function(p, ...) { UseMethod("get_alt_text") } #' @export -get_alt_text.ggplot <- function(p, ...) { +`get_alt_text.ggplot2::ggplot` <- function(p, ...) { alt <- p@labels[["alt"]] %||% "" if (!is.function(alt)) { return(alt) @@ -291,7 +291,7 @@ get_alt_text.ggplot <- function(p, ...) { get_alt_text(build) } #' @export -get_alt_text.ggplot_built <- function(p, ...) { +`get_alt_text.ggplot2::ggplot_built` <- function(p, ...) { alt <- p@plot@labels[["alt"]] %||% "" p@plot@labels[["alt"]] <- NULL if (is.function(alt)) alt(p@plot) else alt diff --git a/R/plot.R b/R/plot.R index 3f4830f9a3..b75f4b5e7e 100644 --- a/R/plot.R +++ b/R/plot.R @@ -229,7 +229,8 @@ plot_clone <- function(plot) { #' @param ... other arguments not used by this method #' @keywords hplot #' @return Invisibly returns the original plot. -#' @name print.ggplot +#' @export +#' @method print ggplot2::ggplot #' @usage #' print(x, newpage = is.null(vp), vp = NULL, ...) #' plot(x, newpage = is.null(vp), vp = NULL, ...) @@ -247,7 +248,7 @@ plot_clone <- function(plot) { #' print(ggplot(mpg, aes_(~ displ, ~ hwy, colour = colour)) + #' geom_point()) #' } -S7::method(print, class_ggplot) <- +`print.ggplot2::ggplot` <- S7::method(plot, class_ggplot) <- function(x, newpage = is.null(vp), vp = NULL, ...) { set_last_plot(x) diff --git a/R/theme.R b/R/theme.R index a857ef8e92..45599434e7 100644 --- a/R/theme.R +++ b/R/theme.R @@ -959,4 +959,5 @@ combine_elements <- function(e1, e2) { .subset2(x, ...) } -S7::method(print, theme) <- function(x, ...) utils::str(x) +#' @export +`print.ggplot2::theme` <- function(x, ...) utils::str(x) diff --git a/man/is_tests.Rd b/man/is_tests.Rd index bcb7bf0683..05f80a38e4 100644 --- a/man/is_tests.Rd +++ b/man/is_tests.Rd @@ -1,7 +1,7 @@ % Generated by roxygen2: do not edit by hand % 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 +% R/guides-.R, R/margins.R, R/theme.R, R/plot.R, R/position-.R, R/scale-.R \name{is.ggproto} \alias{is.ggproto} \alias{is.mapping} @@ -15,11 +15,11 @@ \alias{is.layer} \alias{is.guides} \alias{is.margin} +\alias{is.theme} \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.ggproto(x) @@ -46,13 +46,13 @@ is.guides(x) is.margin(x) +is.theme(x) + is.ggplot(x) is.position(x) is.scale(x) - -is.theme(x) } \arguments{ \item{x}{An object to test} diff --git a/man/print.ggplot.Rd b/man/print.ggplot2-colon-colon-ggplot.Rd similarity index 94% rename from man/print.ggplot.Rd rename to man/print.ggplot2-colon-colon-ggplot.Rd index 4981fe41c1..c167d0c466 100644 --- a/man/print.ggplot.Rd +++ b/man/print.ggplot2-colon-colon-ggplot.Rd @@ -1,7 +1,7 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot.R -\name{print.ggplot} -\alias{print.ggplot} +\name{print.ggplot2::ggplot} +\alias{print.ggplot2::ggplot} \title{Explicitly draw plot} \usage{ print(x, newpage = is.null(vp), vp = NULL, ...) From 39765cdfbd33af4e01b476a80f07e19336d7a1a8 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 17 Mar 2025 10:58:04 +0100 Subject: [PATCH 16/30] fix esoteric 'promise already under evaluation' error --- R/plot.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/plot.R b/R/plot.R index b75f4b5e7e..a320b43399 100644 --- a/R/plot.R +++ b/R/plot.R @@ -163,6 +163,7 @@ class_ggplot <- S7::new_class( ggplot <- S7::new_generic( "ggplot2", "data", fun = function(data, mapping = aes(), ..., environment = parent.frame()) { + force(mapping) S7::S7_dispatch() } ) From 07ebce6e4e97a2f9184c4ea309d4f090c17a77e3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 17 Mar 2025 11:30:48 +0100 Subject: [PATCH 17/30] fix series of minor issues --- R/plot-build.R | 4 ++-- R/plot-construction.R | 17 ++++++++------ R/plot.R | 11 +++++----- R/summary.R | 2 ++ man/ggplot_add.Rd | 13 +++++------ ...-colon-colon-ggplot.Rd => print.ggplot.Rd} | 7 +++--- man/summary.ggplot.Rd | 22 ------------------- 7 files changed, 28 insertions(+), 48 deletions(-) rename man/{print.ggplot2-colon-colon-ggplot.Rd => print.ggplot.Rd} (87%) delete mode 100644 man/summary.ggplot.Rd diff --git a/R/plot-build.R b/R/plot-build.R index f6b4ecb77a..4366052df3 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -340,8 +340,8 @@ ggplotGrob <- function(x) { ggplot_gtable(ggplot_build(x)) } -S7::method(as.gtable, class_ggplot) <- ggplotGrob -S7::method(as.gtable, class_ggplot_built) <- ggplotGrob +S7::method(as.gtable, class_ggplot) <- function(x, ...) ggplotGrob(x) +S7::method(as.gtable, class_ggplot_built) <- function(x, ...) ggplotGrob(x) # Apply function to layer and matching data by_layer <- function(f, layers, data, step = NULL) { diff --git a/R/plot-construction.R b/R/plot-construction.R index ab5ec1b267..b33a6bd465 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -68,6 +68,11 @@ S7::method(`+`, list(class_ggplot, S7::class_any)) <- function(e1, e2) { add_ggplot(e1, e2, e2name) } +S7::method(`+`, list(theme, S7::class_any)) <- function(e1, e2) { + e2name <- deparse(substitute(e2, env = caller_env(2))) + add_theme(e1, e2, e2name) +} + #' @rdname gg-add #' @export @@ -88,7 +93,6 @@ add_ggplot <- function(p, object, objectname) { #' #' @param object An object to add to the plot #' @param plot The ggplot object to add `object` to -#' @param object_name The name of the object to add #' #' @return A modified ggplot object #' @details @@ -104,11 +108,10 @@ add_ggplot <- function(p, object, objectname) { #' @keywords internal #' @export #' @examples -#' # making a new method for the generic -#' # in this example, we apply a text element to the text theme setting -#' ggplot_add.element_text <- function(object, plot, object_name) { -#' plot + theme(text = object) -#' } +#' S7::method(ggplot_add, list(S7::new_S3_class("element_text"), class_ggplot)) <- +#' function(object, plot, ...) { +#' plot + theme(text = object) +#' } #' #' # we can now use `+` to add our object to a plot #' ggplot(mpg, aes(displ, cty)) + @@ -116,7 +119,7 @@ add_ggplot <- function(p, object, objectname) { #' element_text(colour = "red") #' #' # clean-up -#' rm(ggplot_add.element_text) +#' rm("element_text", envir = ggplot_add@methods) ggplot_add <- S7::new_generic("ggplot_add", c("object", "plot")) S7::method(ggplot_add, list(S7::class_any, class_ggplot)) <- diff --git a/R/plot.R b/R/plot.R index a320b43399..33a0df5cb7 100644 --- a/R/plot.R +++ b/R/plot.R @@ -232,9 +232,8 @@ plot_clone <- function(plot) { #' @return Invisibly returns the original plot. #' @export #' @method print ggplot2::ggplot -#' @usage -#' print(x, newpage = is.null(vp), vp = NULL, ...) -#' plot(x, newpage = is.null(vp), vp = NULL, ...) +#' @name print.ggplot +#' @aliases print.ggplot2::ggplot plot.ggplot2::ggplot #' @examples #' colours <- list(~class, ~drv, ~fl) #' @@ -249,9 +248,7 @@ plot_clone <- function(plot) { #' print(ggplot(mpg, aes_(~ displ, ~ hwy, colour = colour)) + #' geom_point()) #' } -`print.ggplot2::ggplot` <- - S7::method(plot, class_ggplot) <- - function(x, newpage = is.null(vp), vp = NULL, ...) { +`print.ggplot2::ggplot` <- function(x, newpage = is.null(vp), vp = NULL, ...) { set_last_plot(x) if (newpage) grid.newpage() @@ -281,6 +278,8 @@ plot_clone <- function(plot) { invisible(x) } +S7::method(plot, class_ggplot) <- `print.ggplot2::ggplot` + #' @export `$.ggplot2::gg` <- function(x, i) { `[[`(S7::props(x), i) diff --git a/R/summary.R b/R/summary.R index 6feb565600..8c3d252906 100644 --- a/R/summary.R +++ b/R/summary.R @@ -1,9 +1,11 @@ #' Displays a useful description of a ggplot object #' +#' @noRd #' @param object ggplot2 object to summarise #' @param ... other arguments ignored (for compatibility with generic) #' @keywords internal #' @name summary.ggplot +#' @aliases summary.ggplot summary.ggplot2::ggplot #' @usage summary(object, ...) #' @examples #' p <- ggplot(mtcars, aes(mpg, wt)) + diff --git a/man/ggplot_add.Rd b/man/ggplot_add.Rd index 91f386c306..af044e1748 100644 --- a/man/ggplot_add.Rd +++ b/man/ggplot_add.Rd @@ -10,8 +10,6 @@ ggplot_add(object, plot, ...) \item{object}{An object to add to the plot} \item{plot}{The ggplot object to add \code{object} to} - -\item{object_name}{The name of the object to add} } \value{ A modified ggplot object @@ -31,11 +29,10 @@ exposed at this point, which comes with the responsibility of returning the plot intact. } \examples{ -# making a new method for the generic -# in this example, we apply a text element to the text theme setting -ggplot_add.element_text <- function(object, plot, object_name) { - plot + theme(text = object) -} +S7::method(ggplot_add, list(S7::new_S3_class("element_text"), class_ggplot)) <- + function(object, plot, ...) { + plot + theme(text = object) + } # we can now use `+` to add our object to a plot ggplot(mpg, aes(displ, cty)) + @@ -43,6 +40,6 @@ ggplot(mpg, aes(displ, cty)) + element_text(colour = "red") # clean-up -rm(ggplot_add.element_text) +rm("element_text", envir = ggplot_add@methods) } \keyword{internal} diff --git a/man/print.ggplot2-colon-colon-ggplot.Rd b/man/print.ggplot.Rd similarity index 87% rename from man/print.ggplot2-colon-colon-ggplot.Rd rename to man/print.ggplot.Rd index c167d0c466..f298f9f716 100644 --- a/man/print.ggplot2-colon-colon-ggplot.Rd +++ b/man/print.ggplot.Rd @@ -1,11 +1,12 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot.R -\name{print.ggplot2::ggplot} +\name{print.ggplot} +\alias{print.ggplot} \alias{print.ggplot2::ggplot} +\alias{plot.ggplot2::ggplot} \title{Explicitly draw plot} \usage{ -print(x, newpage = is.null(vp), vp = NULL, ...) -plot(x, newpage = is.null(vp), vp = NULL, ...) +\method{print}{`ggplot2::ggplot`}(x, newpage = is.null(vp), vp = NULL, ...) } \arguments{ \item{x}{plot to display} diff --git a/man/summary.ggplot.Rd b/man/summary.ggplot.Rd deleted file mode 100644 index 62b8a900db..0000000000 --- a/man/summary.ggplot.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/summary.R -\name{summary.ggplot} -\alias{summary.ggplot} -\title{Displays a useful description of a ggplot object} -\usage{ -summary(object, ...) -} -\arguments{ -\item{object}{ggplot2 object to summarise} - -\item{...}{other arguments ignored (for compatibility with generic)} -} -\description{ -Displays a useful description of a ggplot object -} -\examples{ -p <- ggplot(mtcars, aes(mpg, wt)) + - geom_point() -summary(p) -} -\keyword{internal} From fece790d43df6e18826dd43e165a2c68834903d1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 17 Mar 2025 13:03:38 +0100 Subject: [PATCH 18/30] export theme as class --- NAMESPACE | 1 + R/plot-construction.R | 4 ++-- R/plot.R | 2 +- R/theme.R | 30 ++++++++++++++++++++++-------- man/class_theme.Rd | 21 +++++++++++++++++++++ 5 files changed, 47 insertions(+), 11 deletions(-) create mode 100644 man/class_theme.Rd diff --git a/NAMESPACE b/NAMESPACE index 692d2c3055..484a4cecae 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -292,6 +292,7 @@ export(check_device) export(class_ggplot) export(class_ggplot_built) export(class_mapping) +export(class_theme) export(combine_vars) export(complete_theme) export(continuous_scale) diff --git a/R/plot-construction.R b/R/plot-construction.R index b33a6bd465..2acfb195a3 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -68,7 +68,7 @@ S7::method(`+`, list(class_ggplot, S7::class_any)) <- function(e1, e2) { add_ggplot(e1, e2, e2name) } -S7::method(`+`, list(theme, S7::class_any)) <- function(e1, e2) { +S7::method(`+`, list(class_theme, S7::class_any)) <- function(e1, e2) { e2name <- deparse(substitute(e2, env = caller_env(2))) add_theme(e1, e2, e2name) } @@ -164,7 +164,7 @@ S7::method(ggplot_add, list(class_mapping, class_ggplot)) <- S7::set_props(plot, mapping = class_mapping(defaults(object, plot@mapping))) } -S7::method(ggplot_add, list(theme, class_ggplot)) <- +S7::method(ggplot_add, list(class_theme, class_ggplot)) <- function(object, plot, ...) { S7::set_props(plot, theme = add_theme(plot@theme, object)) } diff --git a/R/plot.R b/R/plot.R index 33a0df5cb7..0e0f318522 100644 --- a/R/plot.R +++ b/R/plot.R @@ -30,7 +30,7 @@ class_ggplot <- S7::new_class( scales = class_scales_list, guides = class_guides, mapping = class_mapping, - theme = theme, + theme = class_theme, coordinates = class_coord, facet = class_facet, layout = class_layout, diff --git a/R/theme.R b/R/theme.R index 45599434e7..b7a95fd424 100644 --- a/R/theme.R +++ b/R/theme.R @@ -549,25 +549,39 @@ theme <- function(..., el }) } - S7::new_object( - elements, - complete = complete, - validate = validate - ) + class_theme(elements, complete = complete, validate = validate) } -theme <- S7::new_class( +#' The theme class +#' +#' The theme class holds information on how non-data elements of the plot +#' should be rendered. The preferred way to construct an object of this class +#' is through the [`theme()`] function. +#' +#' @param elements A named list containing theme elements. +#' @param complete A boolean value stating whether a theme is complete. +#' @param validate A boolean value stating whether a theme should still be +#' validated. +#' +#' @export +class_theme <- S7::new_class( "theme", S7::new_S3_class("gg"), properties = list( complete = S7::class_logical, validate = S7::class_logical ), - constructor = theme + constructor = function(elements, complete, validate) { + S7::new_object( + elements, + complete = complete, + validate = validate + ) + } ) #' @export #' @rdname is_tests -is.theme <- function(x) S7::S7_inherits(x, theme) +is.theme <- function(x) S7::S7_inherits(x, class_theme) # check whether theme is complete is_theme_complete <- function(x) { diff --git a/man/class_theme.Rd b/man/class_theme.Rd new file mode 100644 index 0000000000..a996ead093 --- /dev/null +++ b/man/class_theme.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/theme.R +\name{class_theme} +\alias{class_theme} +\title{The theme class} +\usage{ +class_theme(elements, complete, validate) +} +\arguments{ +\item{elements}{A named list containing theme elements.} + +\item{complete}{A boolean value stating whether a theme is complete.} + +\item{validate}{A boolean value stating whether a theme should still be +validated.} +} +\description{ +The theme class holds information on how non-data elements of the plot +should be rendered. The preferred way to construct an object of this class +is through the \code{\link[=theme]{theme()}} function. +} From f8ed25280749fd506a4b95b3dc80fac44b703a2f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 17 Mar 2025 13:28:47 +0100 Subject: [PATCH 19/30] export labels class --- NAMESPACE | 1 + R/labels.R | 57 +++++++++++++++++++++++++++++++------------ R/plot-construction.R | 2 +- R/plot.R | 2 +- man/class_labels.Rd | 16 ++++++++++++ 5 files changed, 61 insertions(+), 17 deletions(-) create mode 100644 man/class_labels.Rd diff --git a/NAMESPACE b/NAMESPACE index 484a4cecae..83b65e12f0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -291,6 +291,7 @@ export(calc_element) export(check_device) export(class_ggplot) export(class_ggplot_built) +export(class_labels) export(class_mapping) export(class_theme) export(combine_vars) diff --git a/R/labels.R b/R/labels.R index c82fb0933b..48d02f7025 100644 --- a/R/labels.R +++ b/R/labels.R @@ -175,22 +175,49 @@ setup_plot_labels <- function(plot, layers, data) { #' p + #' labs(title = "title") + #' labs(title = NULL) -labs <- S7::new_class( - "labels", parent = S7::new_S3_class("gg"), - constructor = function(..., title = waiver(), subtitle = waiver(), - caption = waiver(), tag = waiver(), dictionary = waiver(), - alt = waiver(), alt_insight = waiver()) { - # .ignore_empty = "all" is needed to allow trailing commas, which is NOT a trailing comma for dots_list() as it's in ... - args <- dots_list(..., title = title, subtitle = subtitle, caption = caption, - tag = tag, alt = allow_lambda(alt), alt_insight = alt_insight, - dictionary = dictionary, .ignore_empty = "all") +labs <- function(..., title = waiver(), subtitle = waiver(), + caption = waiver(), tag = waiver(), dictionary = waiver(), + alt = waiver(), alt_insight = waiver()) { + # .ignore_empty = "all" is needed to allow trailing commas, which is NOT a trailing comma for dots_list() as it's in ... + args <- dots_list(..., title = title, subtitle = subtitle, caption = caption, + tag = tag, alt = allow_lambda(alt), alt_insight = alt_insight, + dictionary = dictionary, .ignore_empty = "all") + + is_waive <- vapply(args, is.waiver, logical(1)) + args <- args[!is_waive] + # remove duplicated arguments + args <- args[!duplicated(names(args))] + args <- rename_aes(args) + class_labels(args) +} - is_waive <- vapply(args, is.waiver, logical(1)) - args <- args[!is_waive] - # remove duplicated arguments - args <- args[!duplicated(names(args))] - args <- rename_aes(args) - S7::new_object(args) +#' The labels class +#' +#' The labels class holds a list with label information to display as titles +#' of plot components. The preferred way to construct an object of the labels +#' class is to use the [`labs()`] function. +#' +#' @param labels A named list. +#' +#' @export +class_labels <- S7::new_class( + "labels", parent = S7::new_S3_class("gg"), + constructor = function(labels) { + S7::new_object(labels) + }, + validator = function(self) { + if (!is.list(self)) { + return("labels must be a list.") + } + if (!is_named2(self)) { + return("every label must be named.") + } + dups <- unique(names(self)[duplicated(names(self))]) + if (length(dups) > 0) { + dups <- oxford_comma(dups, final = "and") + return(paste0("labels cannot contain duplicate names (", dups, ").")) + } + return(NULL) } ) diff --git a/R/plot-construction.R b/R/plot-construction.R index 2acfb195a3..c630cae58b 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -147,7 +147,7 @@ S7::method(ggplot_add, list(class_scale, class_ggplot)) <- plot } -S7::method(ggplot_add, list(labs, class_ggplot)) <- +S7::method(ggplot_add, list(class_labels, class_ggplot)) <- function(object, plot, ...) { update_labels(plot, object) } S7::method(ggplot_add, list(class_guides, class_ggplot)) <- diff --git a/R/plot.R b/R/plot.R index 0e0f318522..23142fc456 100644 --- a/R/plot.R +++ b/R/plot.R @@ -34,7 +34,7 @@ class_ggplot <- S7::new_class( coordinates = class_coord, facet = class_facet, layout = class_layout, - labels = labs, + labels = class_labels, plot_env = S7::class_environment ), constructor = function(data = waiver(), layers = list(), scales = NULL, diff --git a/man/class_labels.Rd b/man/class_labels.Rd new file mode 100644 index 0000000000..7bc800ebf3 --- /dev/null +++ b/man/class_labels.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/labels.R +\name{class_labels} +\alias{class_labels} +\title{The labels class} +\usage{ +class_labels(labels) +} +\arguments{ +\item{labels}{A named list.} +} +\description{ +The labels class holds a list with label information to display as titles +of plot components. The preferred way to construct an object of the labels +class is to use the \code{\link[=labs]{labs()}} function. +} From 8fde6e85012e71aecd518463fa9dc9ca773873a8 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 17 Mar 2025 13:50:11 +0100 Subject: [PATCH 20/30] collect classes in one place --- R/aes.R | 19 ----- R/all-classes.R | 161 ++++++++++++++++++++++++++++++++++++++ R/labels.R | 30 ------- R/plot-build.R | 33 -------- R/plot.R | 53 ------------- R/theme.R | 27 ------- man/class_ggplot.Rd | 2 +- man/class_ggplot_built.Rd | 2 +- man/class_labels.Rd | 2 +- man/class_mapping.Rd | 2 +- man/class_theme.Rd | 2 +- 11 files changed, 166 insertions(+), 167 deletions(-) diff --git a/R/aes.R b/R/aes.R index d85880d57b..f365ad9883 100644 --- a/R/aes.R +++ b/R/aes.R @@ -108,25 +108,6 @@ aes <- function(x, y, ...) { class_mapping(rename_aes(args), env = parent.frame()) } -#' The mapping class -#' -#' The mapping class holds a list of quoted expressions -#' ([quosures][rlang::topic-quosure]) or constants. An object is typically -#' constructed using the [`aes()`] function. -#' -#' @param x A list of quosures and constants. -#' @param env An environment for symbols that are not quosures or constants. -#' -#' @export -class_mapping <- S7::new_class( - "mapping", parent = S7::new_S3_class("gg"), - constructor = function(x, env = globalenv()) { - check_object(x, is.list, "a {.cls list}") - x <- lapply(x, new_aesthetic, env = env) - S7::new_object(x) - } -) - #' @export #' @rdname is_tests is.mapping <- function(x) S7::S7_inherits(x, class_mapping) diff --git a/R/all-classes.R b/R/all-classes.R index 23a61af504..7186fa8715 100644 --- a/R/all-classes.R +++ b/R/all-classes.R @@ -1,5 +1,6 @@ class_gg <- S7::new_class("gg", abstract = TRUE) +class_S3_gg <- S7::new_S3_class("gg") class_scale <- S7::new_S3_class("Scale") class_guides <- S7::new_S3_class("Guides") class_coord <- S7::new_S3_class("Coord") @@ -9,3 +10,163 @@ class_layout <- S7::new_S3_class("Layout") class_scales_list <- S7::new_S3_class("ScalesList") class_ggproto <- S7::new_S3_class("ggproto") class_gtable <- S7::new_S3_class("gtable") + +#' The theme class +#' +#' The theme class holds information on how non-data elements of the plot +#' should be rendered. The preferred way to construct an object of this class +#' is through the [`theme()`] function. +#' +#' @param elements A named list containing theme elements. +#' @param complete A boolean value stating whether a theme is complete. +#' @param validate A boolean value stating whether a theme should still be +#' validated. +#' +#' @export +class_theme <- S7::new_class( + "theme", class_S3_gg, + properties = list( + complete = S7::class_logical, + validate = S7::class_logical + ), + constructor = function(elements, complete, validate) { + S7::new_object( + elements, + complete = complete, + validate = validate + ) + } +) + +#' The labels class +#' +#' The labels class holds a list with label information to display as titles +#' of plot components. The preferred way to construct an object of the labels +#' class is to use the [`labs()`] function. +#' +#' @param labels A named list. +#' +#' @export +class_labels <- S7::new_class( + "labels", parent = class_S3_gg, + constructor = function(labels) S7::new_object(labels), + validator = function(self) { + if (!is.list(self)) { + return("labels must be a list.") + } + if (!is_named2(self)) { + return("every label must be named.") + } + dups <- unique(names(self)[duplicated(names(self))]) + if (length(dups) > 0) { + dups <- oxford_comma(dups, final = "and") + return(paste0("labels cannot contain duplicate names (", dups, ").")) + } + return(NULL) + } +) + +#' The mapping class +#' +#' The mapping class holds a list of quoted expressions +#' ([quosures][rlang::topic-quosure]) or constants. An object is typically +#' constructed using the [`aes()`] function. +#' +#' @param x A list of quosures and constants. +#' @param env An environment for symbols that are not quosures or constants. +#' +#' @export +class_mapping <- S7::new_class( + "mapping", parent = class_S3_gg, + constructor = function(x, env = globalenv()) { + check_object(x, is.list, "a {.cls list}") + x <- lapply(x, new_aesthetic, env = env) + S7::new_object(x) + } +) + +#' The ggplot class +#' +#' The ggplot class collects the needed information to render a plot. +#' This class can be constructed using the [`ggplot()`] function. +#' +#' @param data A property containing any data coerced by [`fortify()`]. +#' @param layers A list of layer instances created by [`layer()`]. +#' @param scales A ScalesList ggproto object. +#' @param guides A Guides ggproto object created by [`guides()`]. +#' @param mapping A mapping class object created by [`aes()`]. +#' @param theme A theme class object created by [`theme()`]. +#' @param coordinates A Coord ggproto object created by `coord_*()` family of +#' functions. +#' @param facet A Facet ggproto object created by `facet_*()` family of +#' functions. +#' @param layout A Layout ggproto object. +#' @param labels A labels object created by [`labs()`]. +#' @param plot_env An environment. +#' +#' @export +class_ggplot <- S7::new_class( + name = "ggplot", parent = class_gg, + properties = list( + data = S7::class_any, + layers = S7::class_list, + scales = class_scales_list, + guides = class_guides, + mapping = class_mapping, + theme = class_theme, + coordinates = class_coord, + facet = class_facet, + layout = class_layout, + labels = class_labels, + plot_env = S7::class_environment + ), + constructor = function(data = waiver(), layers = list(), scales = NULL, + guides = NULL, mapping = aes(), theme = NULL, + coordinates = coord_cartesian(default = TRUE), + facet = facet_null(), layout = NULL, + labels = labs(), plot_env = parent.frame()) { + S7::new_object( + S7::S7_object(), + data = data, layers = layers, + scales = scales %||% scales_list(), + guides = guides %||% guides_list(), + mapping = mapping, theme = theme %||% theme(), + coordinates = coordinates, facet = facet, + layout = layout %||% ggproto(NULL, Layout), + labels = labels, plot_env = plot_env + ) + } +) + +#' The ggplot built class +#' +#' The ggplot built class is an intermediate class and represents a processed +#' ggplot object ready for rendering. It is constructed by calling +#' [`ggplot_build()`] on a [ggplot][class_ggplot] object and is not meant to be +#' instantiated directly. The class can be rendered to a gtable object by +#' calling the [`ggplot_gtable()`] function on a ggplot built class object. +#' +#' @param data A list of plain data frames; one for each layer. +#' @param layout A Layout ggproto object. +#' @param plot A completed ggplot class object. +#' +#' @export +class_ggplot_built <- S7::new_class( + "ggplot_built", + properties = list( + data = S7::class_list, + layout = class_layout, + plot = class_ggplot + ), + constructor = function(data = NULL, layout = NULL, plot = NULL) { + if (is.null(data) || is.null(layout) || is.null(plot)) { + cli::cli_abort( + "The {.cls ggplot_built} class should be constructed by {.fn ggplot_build}." + ) + } + S7::new_object( + S7::S7_object(), + data = data, layout = layout, plot = plot + ) + } +) diff --git a/R/labels.R b/R/labels.R index 48d02f7025..2cbe9a1f97 100644 --- a/R/labels.R +++ b/R/labels.R @@ -191,36 +191,6 @@ labs <- function(..., title = waiver(), subtitle = waiver(), class_labels(args) } -#' The labels class -#' -#' The labels class holds a list with label information to display as titles -#' of plot components. The preferred way to construct an object of the labels -#' class is to use the [`labs()`] function. -#' -#' @param labels A named list. -#' -#' @export -class_labels <- S7::new_class( - "labels", parent = S7::new_S3_class("gg"), - constructor = function(labels) { - S7::new_object(labels) - }, - validator = function(self) { - if (!is.list(self)) { - return("labels must be a list.") - } - if (!is_named2(self)) { - return("every label must be named.") - } - dups <- unique(names(self)[duplicated(names(self))]) - if (length(dups) > 0) { - dups <- oxford_comma(dups, final = "and") - return(paste0("labels cannot contain duplicate names (", dups, ").")) - } - return(NULL) - } -) - #' @rdname labs #' @export xlab <- function(label) { diff --git a/R/plot-build.R b/R/plot-build.R index 4366052df3..bb9f4eb700 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -1,39 +1,6 @@ #' @include plot.R NULL -#' The ggplot built class -#' -#' The ggplot built class is an intermediate class and represents a processed -#' ggplot object ready for rendering. It is constructed by calling -#' [`ggplot_build()`] on a [ggplot][class_ggplot] object and is not meant to be -#' instantiated directly. The class can be rendered to a gtable object by -#' calling the [`ggplot_gtable()`] function on a ggplot built class object. -#' -#' @param data A list of plain data frames; one for each layer. -#' @param layout A Layout ggproto object. -#' @param plot A completed ggplot class object. -#' -#' @export -class_ggplot_built <- S7::new_class( - "ggplot_built", - properties = list( - data = S7::class_list, - layout = class_layout, - plot = class_ggplot - ), - constructor = function(data = NULL, layout = NULL, plot = NULL) { - if (is.null(data) || is.null(layout) || is.null(plot)) { - cli::cli_abort( - "The {.cls ggplot_built} class should be constructed by {.fn ggplot_build}." - ) - } - S7::new_object( - S7::S7_object(), - data = data, layout = layout, plot = plot - ) - } -) - #' Build ggplot for rendering. #' #' `ggplot_build()` takes the plot object, and performs all steps necessary diff --git a/R/plot.R b/R/plot.R index 23142fc456..6eceb00648 100644 --- a/R/plot.R +++ b/R/plot.R @@ -2,59 +2,6 @@ #' @include theme.R NULL -#' The ggplot class -#' -#' The ggplot class collects the needed information to render a plot. -#' This class can be constructed using the [`ggplot()`] function. -#' -#' @param data A property containing any data coerced by [`fortify()`]. -#' @param layers A list of layer instances created by [`layer()`]. -#' @param scales A ScalesList ggproto object. -#' @param guides A Guides ggproto object created by [`guides()`]. -#' @param mapping A mapping class object created by [`aes()`]. -#' @param theme A theme class object created by [`theme()`]. -#' @param coordinates A Coord ggproto object created by `coord_*()` family of -#' functions. -#' @param facet A Facet ggproto object created by `facet_*()` family of -#' functions. -#' @param layout A Layout ggproto object. -#' @param labels A labels object created by [`labs()`]. -#' @param plot_env An environment. -#' -#' @export -class_ggplot <- S7::new_class( - name = "ggplot", parent = class_gg, - properties = list( - data = S7::class_any, - layers = S7::class_list, - scales = class_scales_list, - guides = class_guides, - mapping = class_mapping, - theme = class_theme, - coordinates = class_coord, - facet = class_facet, - layout = class_layout, - labels = class_labels, - plot_env = S7::class_environment - ), - constructor = function(data = waiver(), layers = list(), scales = NULL, - guides = NULL, mapping = aes(), theme = NULL, - coordinates = coord_cartesian(default = TRUE), - facet = facet_null(), layout = NULL, - labels = labs(), plot_env = parent.frame()) { - S7::new_object( - S7::S7_object(), - data = data, layers = layers, - scales = scales %||% scales_list(), - guides = guides %||% guides_list(), - mapping = mapping, theme = theme %||% theme(), - coordinates = coordinates, facet = facet, - layout = layout %||% ggproto(NULL, Layout), - labels = labels, plot_env = plot_env - ) - } -) - #' Create a new ggplot #' #' `ggplot()` initializes a ggplot object. It can be used to diff --git a/R/theme.R b/R/theme.R index b7a95fd424..6f98b7177e 100644 --- a/R/theme.R +++ b/R/theme.R @@ -552,33 +552,6 @@ theme <- function(..., class_theme(elements, complete = complete, validate = validate) } -#' The theme class -#' -#' The theme class holds information on how non-data elements of the plot -#' should be rendered. The preferred way to construct an object of this class -#' is through the [`theme()`] function. -#' -#' @param elements A named list containing theme elements. -#' @param complete A boolean value stating whether a theme is complete. -#' @param validate A boolean value stating whether a theme should still be -#' validated. -#' -#' @export -class_theme <- S7::new_class( - "theme", S7::new_S3_class("gg"), - properties = list( - complete = S7::class_logical, - validate = S7::class_logical - ), - constructor = function(elements, complete, validate) { - S7::new_object( - elements, - complete = complete, - validate = validate - ) - } -) - #' @export #' @rdname is_tests is.theme <- function(x) S7::S7_inherits(x, class_theme) diff --git a/man/class_ggplot.Rd b/man/class_ggplot.Rd index 2113d767ad..1d92af60b6 100644 --- a/man/class_ggplot.Rd +++ b/man/class_ggplot.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R +% Please edit documentation in R/all-classes.R \name{class_ggplot} \alias{class_ggplot} \title{The ggplot class} diff --git a/man/class_ggplot_built.Rd b/man/class_ggplot_built.Rd index 010d01c22f..98bca28a73 100644 --- a/man/class_ggplot_built.Rd +++ b/man/class_ggplot_built.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot-build.R +% Please edit documentation in R/all-classes.R \name{class_ggplot_built} \alias{class_ggplot_built} \title{The ggplot built class} diff --git a/man/class_labels.Rd b/man/class_labels.Rd index 7bc800ebf3..d863f6bc58 100644 --- a/man/class_labels.Rd +++ b/man/class_labels.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/labels.R +% Please edit documentation in R/all-classes.R \name{class_labels} \alias{class_labels} \title{The labels class} diff --git a/man/class_mapping.Rd b/man/class_mapping.Rd index 869b95d34e..4d2d40995d 100644 --- a/man/class_mapping.Rd +++ b/man/class_mapping.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aes.R +% Please edit documentation in R/all-classes.R \name{class_mapping} \alias{class_mapping} \title{The mapping class} diff --git a/man/class_theme.Rd b/man/class_theme.Rd index a996ead093..f6465dc37c 100644 --- a/man/class_theme.Rd +++ b/man/class_theme.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/theme.R +% Please edit documentation in R/all-classes.R \name{class_theme} \alias{class_theme} \title{The theme class} From 5453b2891c4a887a95d419b89580308767084491 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 17 Mar 2025 14:01:16 +0100 Subject: [PATCH 21/30] revert @include decisions --- DESCRIPTION | 4 ++-- R/plot-build.R | 3 --- R/plot-construction.R | 3 --- R/plot.R | 4 ---- man/is_tests.Rd | 8 ++++---- 5 files changed, 6 insertions(+), 16 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 50c5d71a21..37c943ff40 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -203,11 +203,10 @@ Collate: 'limits.R' 'margins.R' 'performance.R' - 'theme.R' - 'plot.R' 'plot-build.R' 'plot-construction.R' 'plot-last.R' + 'plot.R' 'position-.R' 'position-collide.R' 'position-dodge.R' @@ -274,6 +273,7 @@ Collate: 'stat-ydensity.R' 'summarise-plot.R' 'summary.R' + 'theme.R' 'theme-defaults.R' 'theme-current.R' 'theme-sub.R' diff --git a/R/plot-build.R b/R/plot-build.R index bb9f4eb700..5ee38cf7ec 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -1,6 +1,3 @@ -#' @include plot.R -NULL - #' Build ggplot for rendering. #' #' `ggplot_build()` takes the plot object, and performs all steps necessary diff --git a/R/plot-construction.R b/R/plot-construction.R index c630cae58b..051d3f1442 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -1,6 +1,3 @@ -#' @include plot.R -NULL - #' Add components to a plot #' #' `+` is the key to constructing sophisticated ggplot2 graphics. It diff --git a/R/plot.R b/R/plot.R index 6eceb00648..9759024eae 100644 --- a/R/plot.R +++ b/R/plot.R @@ -1,7 +1,3 @@ -#' @include all-classes.R -#' @include theme.R -NULL - #' Create a new ggplot #' #' `ggplot()` initializes a ggplot object. It can be used to diff --git a/man/is_tests.Rd b/man/is_tests.Rd index 05f80a38e4..bcb7bf0683 100644 --- a/man/is_tests.Rd +++ b/man/is_tests.Rd @@ -1,7 +1,7 @@ % Generated by roxygen2: do not edit by hand % 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/theme.R, R/plot.R, R/position-.R, R/scale-.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} @@ -15,11 +15,11 @@ \alias{is.layer} \alias{is.guides} \alias{is.margin} -\alias{is.theme} \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.ggproto(x) @@ -46,13 +46,13 @@ is.guides(x) is.margin(x) -is.theme(x) - is.ggplot(x) is.position(x) is.scale(x) + +is.theme(x) } \arguments{ \item{x}{An object to test} From 9736300eb02bbc17f028495d31e7cff6a70f705a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 17 Mar 2025 14:15:53 +0100 Subject: [PATCH 22/30] Make S7 generic of `get_alt_text()` --- NAMESPACE | 3 --- R/labels.R | 18 +++++++++--------- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 83b65e12f0..ae29f68b8a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -55,9 +55,6 @@ S3method(fortify,sfg) S3method(fortify,summary.glht) S3method(fortify,tbl) S3method(fortify,tbl_df) -S3method(get_alt_text,"ggplot2::ggplot") -S3method(get_alt_text,"ggplot2::ggplot_built") -S3method(get_alt_text,gtable) S3method(grid.draw,absoluteGrob) S3method(grobHeight,absoluteGrob) S3method(grobHeight,zeroGrob) diff --git a/R/labels.R b/R/labels.R index 2cbe9a1f97..e585059602 100644 --- a/R/labels.R +++ b/R/labels.R @@ -272,12 +272,12 @@ get_labs <- function(plot = get_last_plot()) { #' #' get_alt_text(p) #' -get_alt_text <- function(p, ...) { +get_alt_text <- S7::new_generic("get_alt_text", "p", fun = function(p, ...) { warn_dots_used() - UseMethod("get_alt_text") -} -#' @export -`get_alt_text.ggplot2::ggplot` <- function(p, ...) { + S7::S7_dispatch() +}) + +S7::method(get_alt_text, class_ggplot) <- function(p, ...) { alt <- p@labels[["alt"]] %||% "" if (!is.function(alt)) { return(alt) @@ -287,14 +287,14 @@ get_alt_text <- function(p, ...) { build@plot@labels[["alt"]] <- alt get_alt_text(build) } -#' @export -`get_alt_text.ggplot2::ggplot_built` <- function(p, ...) { + +S7::method(get_alt_text, class_ggplot_built) <- function(p, ...) { alt <- p@plot@labels[["alt"]] %||% "" p@plot@labels[["alt"]] <- NULL if (is.function(alt)) alt(p@plot) else alt } -#' @export -get_alt_text.gtable <- function(p, ...) { + +S7::method(get_alt_text, class_gtable) <- function(p, ...) { attr(p, "alt-label") %||% "" } From 028068fc35904a5d93c5c034e7f597f970de1c82 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 17 Mar 2025 14:18:22 +0100 Subject: [PATCH 23/30] backport `@` --- NAMESPACE | 1 + R/backports.R | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index ae29f68b8a..9d7044a7e1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -745,6 +745,7 @@ export(xlim) export(ylab) export(ylim) export(zeroGrob) +if (getRversion() < "4.3.0") importFrom("S7", "@") import(grid) import(gtable) import(rlang) diff --git a/R/backports.R b/R/backports.R index 7ccedc4296..53ab2a6f7e 100644 --- a/R/backports.R +++ b/R/backports.R @@ -15,6 +15,10 @@ if (getRversion() < "3.3") { backport_unit_methods <- function() {} } +# enable usage of @name in package code +#' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@") +NULL + on_load(backport_unit_methods()) unitType <- function(x) { From c754551c64a15a0cafca81bee776cea89be691d4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 17 Mar 2025 14:21:11 +0100 Subject: [PATCH 24/30] exempt classes from pkgdown --- R/all-classes.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/all-classes.R b/R/all-classes.R index 7186fa8715..ff422fbe63 100644 --- a/R/all-classes.R +++ b/R/all-classes.R @@ -22,6 +22,7 @@ class_gtable <- S7::new_S3_class("gtable") #' @param validate A boolean value stating whether a theme should still be #' validated. #' +#' @keywords internal #' @export class_theme <- S7::new_class( "theme", class_S3_gg, @@ -46,6 +47,7 @@ class_theme <- S7::new_class( #' #' @param labels A named list. #' +#' @keywords internal #' @export class_labels <- S7::new_class( "labels", parent = class_S3_gg, @@ -75,6 +77,7 @@ class_labels <- S7::new_class( #' @param x A list of quosures and constants. #' @param env An environment for symbols that are not quosures or constants. #' +#' @keywords internal #' @export class_mapping <- S7::new_class( "mapping", parent = class_S3_gg, @@ -104,6 +107,7 @@ class_mapping <- S7::new_class( #' @param labels A labels object created by [`labs()`]. #' @param plot_env An environment. #' +#' @keywords internal #' @export class_ggplot <- S7::new_class( name = "ggplot", parent = class_gg, @@ -150,6 +154,7 @@ class_ggplot <- S7::new_class( #' @param layout A Layout ggproto object. #' @param plot A completed ggplot class object. #' +#' @keywords internal #' @export class_ggplot_built <- S7::new_class( "ggplot_built", From 9acc1ee2db248d0f6f95cb29f4004ab070e95470 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 17 Mar 2025 15:25:30 +0100 Subject: [PATCH 25/30] lol at my incompetence --- man/class_ggplot.Rd | 1 + man/class_ggplot_built.Rd | 1 + man/class_labels.Rd | 1 + man/class_mapping.Rd | 1 + man/class_theme.Rd | 1 + 5 files changed, 5 insertions(+) diff --git a/man/class_ggplot.Rd b/man/class_ggplot.Rd index 1d92af60b6..5c299b9d60 100644 --- a/man/class_ggplot.Rd +++ b/man/class_ggplot.Rd @@ -47,3 +47,4 @@ functions.} The ggplot class collects the needed information to render a plot. This class can be constructed using the \code{\link[=ggplot]{ggplot()}} function. } +\keyword{internal} diff --git a/man/class_ggplot_built.Rd b/man/class_ggplot_built.Rd index 98bca28a73..4e87451998 100644 --- a/man/class_ggplot_built.Rd +++ b/man/class_ggplot_built.Rd @@ -20,3 +20,4 @@ ggplot object ready for rendering. It is constructed by calling instantiated directly. The class can be rendered to a gtable object by calling the \code{\link[=ggplot_gtable]{ggplot_gtable()}} function on a ggplot built class object. } +\keyword{internal} diff --git a/man/class_labels.Rd b/man/class_labels.Rd index d863f6bc58..57788e666d 100644 --- a/man/class_labels.Rd +++ b/man/class_labels.Rd @@ -14,3 +14,4 @@ The labels class holds a list with label information to display as titles of plot components. The preferred way to construct an object of the labels class is to use the \code{\link[=labs]{labs()}} function. } +\keyword{internal} diff --git a/man/class_mapping.Rd b/man/class_mapping.Rd index 4d2d40995d..63f75456d3 100644 --- a/man/class_mapping.Rd +++ b/man/class_mapping.Rd @@ -16,3 +16,4 @@ The mapping class holds a list of quoted expressions (\link[rlang:topic-quosure]{quosures}) or constants. An object is typically constructed using the \code{\link[=aes]{aes()}} function. } +\keyword{internal} diff --git a/man/class_theme.Rd b/man/class_theme.Rd index f6465dc37c..ab3a03ef1d 100644 --- a/man/class_theme.Rd +++ b/man/class_theme.Rd @@ -19,3 +19,4 @@ The theme class holds information on how non-data elements of the plot should be rendered. The preferred way to construct an object of this class is through the \code{\link[=theme]{theme()}} function. } +\keyword{internal} From 5d41f0ef434d8c981caf372972933db53ae2ab4c Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 31 Mar 2025 16:52:07 +0200 Subject: [PATCH 26/30] allow variant error messages --- tests/testthat/_snaps/4.0/theme.md | 8 ++++++++ tests/testthat/_snaps/4.4/theme.md | 8 ++++++++ tests/testthat/_snaps/error.md | 10 ---------- tests/testthat/_snaps/theme.md | 16 ---------------- tests/testthat/test-error.R | 12 ------------ tests/testthat/test-plot.R | 1 + tests/testthat/test-theme.R | 8 +++++--- 7 files changed, 22 insertions(+), 41 deletions(-) create mode 100644 tests/testthat/_snaps/4.0/theme.md create mode 100644 tests/testthat/_snaps/4.4/theme.md delete mode 100644 tests/testthat/_snaps/error.md delete mode 100644 tests/testthat/test-error.R diff --git a/tests/testthat/_snaps/4.0/theme.md b/tests/testthat/_snaps/4.0/theme.md new file mode 100644 index 0000000000..e4df8865e7 --- /dev/null +++ b/tests/testthat/_snaps/4.0/theme.md @@ -0,0 +1,8 @@ +# modifying theme element properties with + operator works + + Code + theme_grey() + "asdf" + Condition + Error in `method(+, list(ggplot2::theme, class_any))`: + ! Can't add `"asdf"` to a theme object. + diff --git a/tests/testthat/_snaps/4.4/theme.md b/tests/testthat/_snaps/4.4/theme.md new file mode 100644 index 0000000000..ee5f23ab56 --- /dev/null +++ b/tests/testthat/_snaps/4.4/theme.md @@ -0,0 +1,8 @@ +# modifying theme element properties with + operator works + + Code + theme_grey() + "asdf" + Condition + Error: + ! Can't add `"asdf"` to a theme object. + diff --git a/tests/testthat/_snaps/error.md b/tests/testthat/_snaps/error.md deleted file mode 100644 index a8cb5172df..0000000000 --- a/tests/testthat/_snaps/error.md +++ /dev/null @@ -1,10 +0,0 @@ -# various misuses of +.gg (#2638) - - Cannot use `+` with a single argument. - i Did you accidentally put `+` on a new line? - ---- - - Cannot add objects together. - i Did you forget to add this object to a object? - diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index 0218bbef51..3694f73097 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -1,19 +1,3 @@ -# modifying theme element properties with + operator works - - Code - theme_grey() + "asdf" - Condition - Error: - ! Can't add `"asdf"` to a theme object. - -# replacing theme elements with %+replace% operator works - - Code - theme_grey() + "asdf" - Condition - Error: - ! Can't add `"asdf"` to a theme object. - # theme validation happens at build stage The `text` theme element must be a object. diff --git a/tests/testthat/test-error.R b/tests/testthat/test-error.R deleted file mode 100644 index 8e1424a7f1..0000000000 --- a/tests/testthat/test-error.R +++ /dev/null @@ -1,12 +0,0 @@ -test_that("various misuses of +.gg (#2638)", { - expect_snapshot_error( - { - ggplot(mtcars, aes(hwy, displ)) - + geom_point() - } - ) - - expect_snapshot_error( - geom_point() + geom_point() - ) -}) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 2cccf79034..45a3e1cede 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -5,6 +5,7 @@ test_that("ggplot() throws informative errors", { }) test_that("construction have user friendly errors", { + skip_if(getRversion() < "4.3.0") expect_snapshot_error(+ geom_point()) expect_snapshot_error(geom_point() + geom_bar()) expect_snapshot_error(ggplot() + 1) diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 5be33bfc31..ff20cd36cf 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -49,7 +49,11 @@ test_that("modifying theme element properties with + operator works", { t <- theme_grey() + theme() expect_identical(t, theme_grey()) - expect_snapshot(theme_grey() + "asdf", error = TRUE) + expect_snapshot( + theme_grey() + "asdf", + error = TRUE, + variant = substr(as.character(getRversion()), start = 1, stop = 3) + ) }) test_that("adding theme object to ggplot object with + operator works", { @@ -114,8 +118,6 @@ test_that("replacing theme elements with %+replace% operator works", { # Adding empty theme() has no effect t <- theme_grey() %+replace% theme() expect_identical(t, theme_grey()) - - expect_snapshot(theme_grey() + "asdf", error = TRUE) }) test_that("calculating theme element inheritance works", { From 77cb52d96678492c268757780fb9032525e3c883 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 31 Mar 2025 16:54:12 +0200 Subject: [PATCH 27/30] workaround for old R versions --- NAMESPACE | 1 - R/plot-construction.R | 18 ++++++++++++++---- R/zzz.R | 3 +++ man/gg-add.Rd | 6 +++--- 4 files changed, 20 insertions(+), 8 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c1075b4bc0..aa0496b035 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,7 +6,6 @@ S3method("$",ggproto) S3method("$",ggproto_parent) S3method("$<-","ggplot2::gg") S3method("$<-","ggplot2::mapping") -S3method("+",gg) S3method("[","ggplot2::gg") S3method("[","ggplot2::mapping") S3method("[",mapped_discrete) diff --git a/R/plot-construction.R b/R/plot-construction.R index 051d3f1442..defc8cf772 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -24,8 +24,6 @@ #' @param e1 An object of class [ggplot()] or a [theme()]. #' @param e2 A plot component, as described below. #' @seealso [theme()] -#' @export -#' @method + gg #' @rdname gg-add #' @examples #' base <- @@ -39,7 +37,7 @@ #' # Alternatively, you can add multiple components with a list. #' # This can be useful to return from a function. #' base + list(subset(mpg, fl == "p"), geom_smooth()) -"+.gg" <- function(e1, e2) { +add_gg <- function(e1, e2) { if (missing(e2)) { cli::cli_abort(c( "Cannot use {.code +} with a single argument.", @@ -52,6 +50,8 @@ e2name <- deparse(substitute(e2)) if (is.theme(e1)) add_theme(e1, e2, e2name) + # The `add_ggplot()` branch here is for backward compatibility with R < 4.3.0 + else if (is.ggplot(e1)) add_ggplot(e1, e2, e2name) else if (is.ggproto(e1)) { cli::cli_abort(c( "Cannot add {.cls ggproto} objects together.", @@ -60,6 +60,10 @@ } } +if (getRversion() < "4.3.0") { + S7::method(`+`, list(class_S3_gg, S7::class_any)) <- add_gg +} + S7::method(`+`, list(class_ggplot, S7::class_any)) <- function(e1, e2) { e2name <- deparse(substitute(e2, env = caller_env(2))) add_ggplot(e1, e2, e2name) @@ -73,7 +77,13 @@ S7::method(`+`, list(class_theme, S7::class_any)) <- function(e1, e2) { #' @rdname gg-add #' @export -"%+%" <- function(e1, e2) e1 + e2 +"%+%" <- function(e1, e2) { + if (getRversion() < "4.3.0") { + add_gg(e1, e2) + } else { + `+`(e1, e2) + } +} add_ggplot <- function(p, object, objectname) { if (is.null(object)) return(p) diff --git a/R/zzz.R b/R/zzz.R index 249d96a1be..e15bcbd2af 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -30,6 +30,9 @@ on_load( vars <- dplyr::vars } ) +on_load( + if (getRversion() > "4.3.0") registerS3method("+", "gg", add_gg) +) on_load(S7::methods_register()) .onLoad <- function(...) { run_on_load() diff --git a/man/gg-add.Rd b/man/gg-add.Rd index bd5e374caa..560f74de68 100644 --- a/man/gg-add.Rd +++ b/man/gg-add.Rd @@ -1,11 +1,11 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot-construction.R -\name{+.gg} -\alias{+.gg} +\name{add_gg} +\alias{add_gg} \alias{\%+\%} \title{Add components to a plot} \usage{ -\method{+}{gg}(e1, e2) +add_gg(e1, e2) e1 \%+\% e2 } From 8177f06d95c14f82912f81b19e614b04d238581f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 31 Mar 2025 16:57:55 +0200 Subject: [PATCH 28/30] update pkgdown index --- _pkgdown.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/_pkgdown.yml b/_pkgdown.yml index 5b0505afd8..bd721a1b3d 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -37,7 +37,7 @@ reference: contents: - ggplot - aes - - "`+.gg`" + - add_gg - ggsave - qplot From 69ae934362f3649380355aa7d1df961c6d055d09 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 16 Apr 2025 15:54:07 +0200 Subject: [PATCH 29/30] use `is_theme()` --- R/theme.R | 6 +++--- tests/testthat/_snaps/4.5/theme.md | 8 ++++++++ tests/testthat/test-theme.R | 4 ++-- 3 files changed, 13 insertions(+), 5 deletions(-) create mode 100644 tests/testthat/_snaps/4.5/theme.md diff --git a/R/theme.R b/R/theme.R index 9401c35779..471d030882 100644 --- a/R/theme.R +++ b/R/theme.R @@ -584,12 +584,12 @@ is.theme <- function(x) { # check whether theme is complete is_theme_complete <- function(x) { - is.theme(x) && isTRUE(x@complete) + is_theme(x) && isTRUE(x@complete) } # check whether theme should be validated is_theme_validate <- function(x) { - !is.theme(x) || isTRUE(x@validate) + !is_theme(x) || isTRUE(x@validate) } check_theme <- function(theme, tree = get_element_tree(), call = caller_env()) { @@ -703,7 +703,7 @@ add_theme <- function(t1, t2, t2name, call = caller_env()) { } ) - if (!is.theme(t1) && is.list(t1)) { + if (!is_theme(t1) && is.list(t1)) { t1 <- theme(!!!t1) } diff --git a/tests/testthat/_snaps/4.5/theme.md b/tests/testthat/_snaps/4.5/theme.md new file mode 100644 index 0000000000..ee5f23ab56 --- /dev/null +++ b/tests/testthat/_snaps/4.5/theme.md @@ -0,0 +1,8 @@ +# modifying theme element properties with + operator works + + Code + theme_grey() + "asdf" + Condition + Error: + ! Can't add `"asdf"` to a theme object. + diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index af6aacf162..7267fb48dc 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -19,7 +19,7 @@ test_that("modifying theme element properties with + operator works", { t <- theme_grey() + theme(axis.title.x = element_text(colour = 'red', margin = margin())) expect_identical(t$axis.title.x, element_text(colour = 'red', margin = margin(), vjust = 1)) # Make sure the theme class didn't change or get dropped - expect_s3_class(t, "theme") + expect_s7_class(t, class_theme) # Make sure the element class didn't change or get dropped expect_s3_class(t$axis.title.x, "element") expect_s3_class(t$axis.title.x, "element_text") @@ -107,7 +107,7 @@ test_that("replacing theme elements with %+replace% operator works", { t <- theme_grey() %+replace% theme(axis.title.x = element_text(colour = 'red')) expect_identical(t$axis.title.x, element_text(colour = 'red')) # Make sure the class didn't change or get dropped - expect_s3_class(t, "theme") + expect_s7_class(t, class_theme) # Changing an intermediate node works t <- theme_grey() %+replace% theme(axis.title = element_text(colour = 'red')) From 67dae2de0dc6793e864c4cc45c97046417cf8d9a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 16 Apr 2025 16:40:43 +0200 Subject: [PATCH 30/30] sprinkle notes --- R/aes.R | 2 ++ R/all-classes.R | 19 +++++++++++++++---- R/plot.R | 5 +++++ 3 files changed, 22 insertions(+), 4 deletions(-) diff --git a/R/aes.R b/R/aes.R index 4e7ba7583b..8641a952cb 100644 --- a/R/aes.R +++ b/R/aes.R @@ -131,6 +131,7 @@ new_aesthetic <- function(x, env = globalenv()) { } #' @export +# TODO: should convert to proper S7 method once bug in S7 is resolved `print.ggplot2::mapping` <- function(x, ...) { cat("Aesthetic mapping: \n") @@ -146,6 +147,7 @@ new_aesthetic <- function(x, env = globalenv()) { invisible(x) } +# TODO: should convert to proper S7 method once bug in S7 is resolved #' @export "[.ggplot2::mapping" <- function(x, i, ...) { class_mapping(NextMethod()) diff --git a/R/all-classes.R b/R/all-classes.R index ff422fbe63..586988d665 100644 --- a/R/all-classes.R +++ b/R/all-classes.R @@ -1,6 +1,17 @@ +# S3 classes -------------------------------------------------------------- -class_gg <- S7::new_class("gg", abstract = TRUE) -class_S3_gg <- S7::new_S3_class("gg") +# Meta classes: +# TODO: These should be replaced once R 4.3.0 is the minimum version as `+` +# dispatch should work as intended. +class_gg <- S7::new_class("gg", abstract = TRUE) +class_S3_gg <- S7::new_S3_class("gg") + +# Proper S3 classes we need awareness for +class_ggproto <- S7::new_S3_class("ggproto") +class_gtable <- S7::new_S3_class("gtable") + +# The important ggproto classes that we treat as S3 classes in S7 even though +# they are their own thing. class_scale <- S7::new_S3_class("Scale") class_guides <- S7::new_S3_class("Guides") class_coord <- S7::new_S3_class("Coord") @@ -8,8 +19,8 @@ class_facet <- S7::new_S3_class("Facet") class_layer <- S7::new_S3_class("Layer") class_layout <- S7::new_S3_class("Layout") class_scales_list <- S7::new_S3_class("ScalesList") -class_ggproto <- S7::new_S3_class("ggproto") -class_gtable <- S7::new_S3_class("gtable") + +# User facing classes ----------------------------------------------------- #' The theme class #' diff --git a/R/plot.R b/R/plot.R index 6b49cf7d26..d66e040d46 100644 --- a/R/plot.R +++ b/R/plot.R @@ -198,6 +198,7 @@ is.ggplot <- function(x) { #' print(ggplot(mpg, aes(displ, hwy, colour = .data[[colour]])) + #' geom_point()) #' } +# TODO: should convert to proper S7 method once bug in S7 is resolved `print.ggplot2::ggplot` <- function(x, newpage = is.null(vp), vp = NULL, ...) { set_last_plot(x) if (newpage) grid.newpage() @@ -230,6 +231,10 @@ is.ggplot <- function(x) { S7::method(plot, class_ggplot) <- `print.ggplot2::ggplot` +# The following extractors and subassignment operators are for a smooth +# transition and should be deprecated in the release cycle after 4.0.0 +# TODO: should convert to proper S7 method once bug in S7 is resolved + #' @export `$.ggplot2::gg` <- function(x, i) { `[[`(S7::props(x), i)