From 8bd9f31f032e72c601f63096785de152a978f53b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 4 Mar 2025 15:19:19 +0100 Subject: [PATCH 01/58] add S7 as import --- 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 d54e46444f736aba3abc53fc5777b28d1e17180b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 5 Mar 2025 11:18:20 +0100 Subject: [PATCH 02/58] custom properties for theme elements --- DESCRIPTION | 1 + R/properties.R | 102 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 103 insertions(+) create mode 100644 R/properties.R diff --git a/DESCRIPTION b/DESCRIPTION index 0a33c39ea4..a632b6fcf6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -176,6 +176,7 @@ Collate: 'grob-dotstack.R' 'grob-null.R' 'grouping.R' + 'properties.R' 'theme-elements.R' 'guide-.R' 'guide-axis.R' diff --git a/R/properties.R b/R/properties.R new file mode 100644 index 0000000000..be857393b0 --- /dev/null +++ b/R/properties.R @@ -0,0 +1,102 @@ + +property_boolean <- function(allow_null = FALSE, default = TRUE) { + class <- S7::class_logical + class <- if (allow_null) S7::new_union(class, NULL) else class + validator <- function(value) { + if ((allow_null && is.null(value)) || is_bool(value)) { + return(character()) + } + "must be a boolean" + } + S7::new_property( + class = class, + validator = validator, + default = default + ) +} + +property_choice <- function(options, allow_null = FALSE, default = NULL) { + force(options) + class <- S7::class_character + class <- if (allow_null) S7::new_union(class, NULL) else class + validator <- function(value) { + if (allow_null && is.null(value)) { + return(character()) + } + if (!is_string(value)) { + return(as_cli("must be a string, not {.obj_type_friendly {value}}")) + } + if (value %in% options) { + return(character()) + } + as_cli("must be one of {.or {.val {options}}}") + } + S7::new_property( + class = class, + validator = validator, + default = default + ) +} + +element_props <- list( + fill = S7::new_property( + S7::new_union(S7::class_character, S7::new_S3_class("GridPattern"), S7::class_logical, NULL), + default = NULL + ), + colour = S7::new_property( + S7::new_union(S7::class_character, S7::class_logical, NULL), + default = NULL + ), + family = S7::new_property( + S7::new_union(S7::class_character, NULL), + default = NULL + ), + hjust = S7::new_property( + S7::new_union(S7::class_numeric, NULL), + default = NULL + ), + vjust = S7::new_property( + S7::new_union(S7::class_numeric, NULL), + default = NULL + ), + angle = S7::new_property( + S7::new_union(S7::class_numeric, NULL), + default = NULL + ), + size = S7::new_property( + S7::new_union(S7::class_numeric, NULL), + default = NULL + ), + lineheight = S7::new_property( + S7::new_union(S7::class_numeric, NULL), + default = NULL + ), + margin = S7::new_property( + S7::new_union(S7::new_S3_class("margin"), NULL), + default = NULL + ), + face = property_choice(c("plain", "bold", "italic", "oblique", "bold.italic"), allow_null = TRUE), + linewidth = S7::new_property( + S7::new_union(S7::class_numeric, NULL), + default = NULL + ), + linetype = S7::new_property( + S7::new_union(S7::class_numeric, S7::class_character, NULL), + default = NULL + ), + lineend = property_choice(c("round", "butt", "square"), allow_null = TRUE), + shape = S7::new_property( + S7::new_union(S7::class_numeric, S7::class_character, NULL), + default = NULL + ), + arrow = S7::new_property( + S7::new_union(S7::new_S3_class("arrow"), S7::class_logical, NULL), + default = NULL + ), + arrow.fill = S7::new_property( + S7::new_union(S7::class_character, S7::class_logical, NULL), + default = NULL + ), + debug = property_boolean(allow_null = TRUE, default = NULL), + inherit.blank = property_boolean(default = FALSE) +) From 91302e0c21e835cabb258f60b6c0bffdfe346601 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 5 Mar 2025 11:18:57 +0100 Subject: [PATCH 03/58] convert theme elements to S7 classes --- NAMESPACE | 2 +- R/theme-elements.R | 245 +++++++++++++++++++++++++-------------------- R/theme.R | 4 +- man/element.Rd | 3 + 4 files changed, 142 insertions(+), 112 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index b58765ecc1..5e4384df4e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -106,7 +106,6 @@ S3method(predictdf,default) S3method(predictdf,glm) S3method(predictdf,locfit) S3method(predictdf,loess) -S3method(print,element) S3method(print,ggplot) S3method(print,ggplot2_bins) S3method(print,ggproto) @@ -344,6 +343,7 @@ export(draw_key_vline) export(draw_key_vpath) export(dup_axis) export(el_def) +export(element) export(element_blank) export(element_geom) export(element_grob) diff --git a/R/theme-elements.R b/R/theme-elements.R index c3b6ded319..c479aa6e3a 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -81,55 +81,63 @@ NULL #' @export #' @rdname element -element_blank <- function() { - structure( - list(), - class = c("element_blank", "element") - ) -} +element <- S7::new_class("element", abstract = TRUE) #' @export #' @rdname element -element_rect <- function(fill = NULL, colour = NULL, linewidth = NULL, - linetype = NULL, color = NULL, inherit.blank = FALSE, size = deprecated()) { +element_blank <- S7::new_class("element_blank", parent = element) - if (lifecycle::is_present(size)) { - deprecate_soft0("3.4.0", "element_rect(size)", "element_rect(linewidth)") - linewidth <- size - } +#' @include properties.R - if (!is.null(color)) colour <- color - structure( - list(fill = fill, colour = colour, linewidth = linewidth, linetype = linetype, - inherit.blank = inherit.blank), - class = c("element_rect", "element") - ) -} +#' @export +#' @rdname element +element_rect <- S7::new_class( + "element_rect", parent = element, + properties = element_props[c("fill", "colour", "linewidth", "linetype", "inherit.blank")], + constructor = function(fill = NULL, colour = NULL, linewidth = NULL, + linetype = NULL, color = NULL, inherit.blank = FALSE, + size = deprecated()){ + if (lifecycle::is_present(size)) { + deprecate_soft0("3.4.0", "element_rect(size)", "element_rect(linewidth)") + linewidth <- size + } + S7::new_object( + S7::S7_object(), + fill = fill, colour = color %||% colour, + linewidth = linewidth, linetype = linetype, + inherit.blank = inherit.blank + ) + } +) #' @export #' @rdname element #' @param lineend Line end Line end style (round, butt, square) #' @param arrow Arrow specification, as created by [grid::arrow()] -element_line <- function(colour = NULL, linewidth = NULL, linetype = NULL, - lineend = NULL, color = NULL, arrow = NULL, arrow.fill = NULL, - inherit.blank = FALSE, size = deprecated()) { - - if (lifecycle::is_present(size)) { - deprecate_soft0("3.4.0", "element_line(size)", "element_line(linewidth)") - linewidth <- size +element_line <- S7::new_class( + "element_line", parent = element, + properties = element_props[c( + "colour", "linewidth", "linetype", "lineend", "arrow", "arrow.fill", + "inherit.blank" + )], + constructor = function(colour = NULL, linewidth = NULL, linetype = NULL, + lineend = NULL, color = NULL, arrow = NULL, + arrow.fill = NULL, inherit.blank = FALSE, size = deprecated()) { + if (lifecycle::is_present(size)) { + deprecate_soft0("3.4.0", "element_line(size)", "element_line(linewidth)") + linewidth <- size + } + colour <- color %||% colour + S7::new_object( + S7::S7_object(), + colour = colour, + linewidth = linewidth, linetype = linetype, lineend = lineend, + arrow = arrow %||% FALSE, + arrow.fill = arrow.fill %||% colour, + inherit.blank = inherit.blank + ) } - - colour <- color %||% colour - arrow.fill <- arrow.fill %||% colour - arrow <- arrow %||% FALSE - - structure( - list(colour = colour, linewidth = linewidth, linetype = linetype, lineend = lineend, - arrow = arrow, arrow.fill = arrow.fill, inherit.blank = inherit.blank), - class = c("element_line", "element") - ) -} - +) #' @param family Font family #' @param face Font face ("plain", "italic", "bold", "bold.italic") @@ -145,93 +153,116 @@ element_line <- function(colour = NULL, linewidth = NULL, linetype = NULL, #' is anchored. #' @export #' @rdname element -element_text <- function(family = NULL, face = NULL, colour = NULL, - size = NULL, hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL, - color = NULL, margin = NULL, debug = NULL, inherit.blank = FALSE) { - - if (!is.null(color)) colour <- color - - n <- max( - length(family), length(face), length(colour), length(size), - length(hjust), length(vjust), length(angle), length(lineheight) - ) - if (n > 1) { - cli::cli_warn(c( - "Vectorized input to {.fn element_text} is not officially supported.", - "i" = "Results may be unexpected or may change in future versions of ggplot2." - )) - } - - - structure( - list(family = family, face = face, colour = colour, size = size, +element_text <- S7::new_class( + "element_text", parent = element, + properties = element_props[c( + "family", "face", "colour", "size", "hjust", "vjust", "angle", "lineheight", + "margin", "debug", "inherit.blank" + )], + constructor = function(family = NULL, face = NULL, colour = NULL, + size = NULL, hjust = NULL, vjust = NULL, angle = NULL, + lineheight = NULL, color = NULL, margin = NULL, + debug = NULL, inherit.blank = FALSE) { + n <- max( + length(family), length(face), length(colour), length(size), + length(hjust), length(vjust), length(angle), length(lineheight) + ) + if (n > 1) { + cli::cli_warn(c( + "Vectorized input to {.fn element_text} is not officially supported.", + "i" = "Results may be unexpected or may change in future versions of ggplot2." + )) + } + + colour <- color %||% colour + S7::new_object( + S7::S7_object(), + family = family, face = face, colour = colour, size = size, hjust = hjust, vjust = vjust, angle = angle, lineheight = lineheight, - margin = margin, debug = debug, inherit.blank = inherit.blank), - class = c("element_text", "element") - ) -} + margin = margin, debug = debug, inherit.blank = inherit.blank + ) + } +) #' @export #' @rdname element -element_polygon <- function(fill = NULL, colour = NULL, linewidth = NULL, - linetype = NULL, color = NULL, - inherit.blank = FALSE) { - structure( - list( +element_polygon <- S7::new_class( + "element_polygon", parent = element, + properties = element_props[c( + "fill", "colour", "linewidth", "linetype", "inherit.blank" + )], + constructor = function(fill = NULL, colour = NULL, linewidth = NULL, + linetype = NULL, color = NULL, inherit.blank = FALSE) { + colour <- color %||% colour + S7::new_object( + S7::S7_object(), fill = fill, colour = color %||% colour, linewidth = linewidth, linetype = linetype, inherit.blank = inherit.blank - ), - class = c("element_polygon", "element") - ) -} + ) + } +) #' @export #' @rdname element -element_point <- function(colour = NULL, shape = NULL, size = NULL, fill = NULL, - stroke = NULL, color = NULL, inherit.blank = FALSE) { - structure( - list( +element_point <- S7::new_class( + "element_point", parent = element, + properties = rename( + element_props[c( + "colour", "shape", "size", "fill", "linewidth", "inherit.blank" + )], + c("linewidth" = "stroke") + ), + constructor = function(colour = NULL, shape = NULL, size = NULL, fill = NULL, + stroke = NULL, color = NULL, inherit.blank = FALSE) { + S7::new_object( + S7::S7_object(), colour = color %||% colour, fill = fill, shape = shape, size = size, stroke = stroke, inherit.blank = inherit.blank - ), - class = c("element_point", "element") - ) -} + ) + } +) #' @param ink Foreground colour. #' @param paper Background colour. #' @param accent Accent colour. #' @export #' @rdname element -element_geom <- function( - # colours - ink = NULL, paper = NULL, accent = NULL, - # linewidth - linewidth = NULL, borderwidth = NULL, - # linetype - linetype = NULL, bordertype = NULL, - # text - family = NULL, fontsize = NULL, - # points - pointsize = NULL, pointshape = NULL) { - - if (!is.null(fontsize)) { - fontsize <- fontsize / .pt - } - - structure( - list( - ink = ink, - paper = paper, - accent = accent, +element_geom <- S7::new_class( + "element_geom", parent = element, + properties = list( + ink = element_props$colour, + paper = element_props$colour, + accent = element_props$colour, + linewidth = element_props$linewidth, + borderwidth = element_props$linewidth, + linetype = element_props$linetype, + bordertype = element_props$linetype, + family = element_props$family, + fontsize = element_props$size, + pointsize = element_props$size, + pointshape = element_props$shape + ), + constructor = function( + ink = NULL, paper = NULL, accent = NULL, + linewidth = NULL, borderwidth = NULL, + linetype = NULL, bordertype = NULL, + family = NULL, fontsize = NULL, + pointsize = NULL, pointshape = NULL) { + + if (!is.null(fontsize)) { + fontsize <- fontsize / .pt + } + + S7::new_object( + S7::S7_object(), + ink = ink, paper = paper, accent = accent, linewidth = linewidth, borderwidth = borderwidth, linetype = linetype, bordertype = bordertype, family = family, fontsize = fontsize, pointsize = pointsize, pointshape = pointshape - ), - class = c("element_geom", "element") - ) -} + ) + } +) .default_geom_element <- element_geom( ink = "black", paper = "white", accent = "#3366FF", @@ -243,11 +274,7 @@ element_geom <- function( #' @export #' @rdname is_tests -is.theme_element <- function(x) inherits(x, "element") - -#' @export -print.element <- function(x, ...) utils::str(x) - +is.theme_element <- function(x) S7::S7_inherits(x, element) #' @param x A single number specifying size relative to parent element. #' @rdname element diff --git a/R/theme.R b/R/theme.R index dfe986fc62..1c16c85656 100644 --- a/R/theme.R +++ b/R/theme.R @@ -543,8 +543,8 @@ theme <- function(..., # If complete theme set all non-blank elements to inherit from blanks if (complete) { elements <- lapply(elements, function(el) { - if (is.theme_element(el) && !inherits(el, "element_blank")) { - el$inherit.blank <- TRUE + if (is.theme_element(el) && S7::prop_exists(el, "inherit.blank")) { + S7::prop(el, "inherit.blank") <- TRUE } el }) diff --git a/man/element.Rd b/man/element.Rd index 99e56f0e94..72d8c2b601 100644 --- a/man/element.Rd +++ b/man/element.Rd @@ -1,6 +1,7 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/theme-elements.R, R/margins.R \name{element} +\alias{element} \alias{element_blank} \alias{element_rect} \alias{element_line} @@ -14,6 +15,8 @@ \alias{margin_auto} \title{Theme elements} \usage{ +element() + element_blank() element_rect( From 8c199a16232fd491702aa234739094aa7c632030 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 5 Mar 2025 13:30:38 +0100 Subject: [PATCH 04/58] adapt element definitions --- R/theme-elements.R | 183 +++++++++++++++++---------------- man/register_theme_elements.Rd | 6 +- 2 files changed, 98 insertions(+), 91 deletions(-) diff --git a/R/theme-elements.R b/R/theme-elements.R index c479aa6e3a..5e3a016e69 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -483,7 +483,7 @@ element_grob.element_point <- function(element, x = 0.5, y = 0.5, colour = NULL, #' # plot panels. To do so, it registers a new theme element `ggxyz.panel.annotation` #' register_theme_elements( #' ggxyz.panel.annotation = element_text(color = "blue", hjust = 0.95, vjust = 0.05), -#' element_tree = list(ggxyz.panel.annotation = el_def("element_text", "text")) +#' element_tree = list(ggxyz.panel.annotation = el_def(element_text, "text")) #' ) #' #' # Now the package can define a new coord that includes a panel annotation @@ -602,8 +602,8 @@ check_element_tree <- function(x, arg = caller_arg(x), call = caller_env()) { #' @details #' The function `el_def()` is used to define new or modified element types and #' element inheritance relationships for the element tree. -#' @param class The name of the element class. Examples are "element_line" or -#' "element_text" or "unit", or one of the two reserved keywords "character" or +#' @param class The name of the element class. Examples are `element_line` or +#' `element_text` or "unit", or one of the two reserved keywords "character" or #' "margin". The reserved keyword "character" implies a character #' or numeric vector, not a class called "character". The keyword #' "margin" implies a unit vector of length 4, as created by [margin()]. @@ -622,43 +622,43 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { # among them. It should not be read from directly, since users may modify the # current element tree stored in ggplot_global$element_tree .element_tree <- list( - line = el_def("element_line"), - rect = el_def("element_rect"), - text = el_def("element_text"), - point = el_def("element_point"), - polygon = el_def("element_polygon"), - geom = el_def("element_geom"), - title = el_def("element_text", "text"), + line = el_def(element_line), + rect = el_def(element_rect), + text = el_def(element_text), + point = el_def(element_point), + polygon = el_def(element_polygon), + geom = el_def(element_geom), + title = el_def(element_text, "text"), spacing = el_def("unit"), margins = el_def(c("margin", "unit")), - axis.line = el_def("element_line", "line"), - axis.text = el_def("element_text", "text"), - axis.title = el_def("element_text", "title"), - axis.ticks = el_def("element_line", "line"), + axis.line = el_def(element_line, "line"), + axis.text = el_def(element_text, "text"), + axis.title = el_def(element_text, "title"), + axis.ticks = el_def(element_line, "line"), legend.key.size = el_def(c("unit", "rel"), "spacing"), - panel.grid = el_def("element_line", "line"), - panel.grid.major = el_def("element_line", "panel.grid"), - panel.grid.minor = el_def("element_line", "panel.grid"), - strip.text = el_def("element_text", "text"), - - axis.line.x = el_def("element_line", "axis.line"), - axis.line.x.top = el_def("element_line", "axis.line.x"), - axis.line.x.bottom = el_def("element_line", "axis.line.x"), - axis.line.y = el_def("element_line", "axis.line"), - axis.line.y.left = el_def("element_line", "axis.line.y"), - axis.line.y.right = el_def("element_line", "axis.line.y"), - axis.line.theta = el_def("element_line", "axis.line.x"), - axis.line.r = el_def("element_line", "axis.line.y"), - - axis.text.x = el_def("element_text", "axis.text"), - axis.text.x.top = el_def("element_text", "axis.text.x"), - axis.text.x.bottom = el_def("element_text", "axis.text.x"), - axis.text.y = el_def("element_text", "axis.text"), - axis.text.y.left = el_def("element_text", "axis.text.y"), - axis.text.y.right = el_def("element_text", "axis.text.y"), - axis.text.theta = el_def("element_text", "axis.text.x"), - axis.text.r = el_def("element_text", "axis.text.y"), + panel.grid = el_def(element_line, "line"), + panel.grid.major = el_def(element_line, "panel.grid"), + panel.grid.minor = el_def(element_line, "panel.grid"), + strip.text = el_def(element_text, "text"), + + axis.line.x = el_def(element_line, "axis.line"), + axis.line.x.top = el_def(element_line, "axis.line.x"), + axis.line.x.bottom = el_def(element_line, "axis.line.x"), + axis.line.y = el_def(element_line, "axis.line"), + axis.line.y.left = el_def(element_line, "axis.line.y"), + axis.line.y.right = el_def(element_line, "axis.line.y"), + axis.line.theta = el_def(element_line, "axis.line.x"), + axis.line.r = el_def(element_line, "axis.line.y"), + + axis.text.x = el_def(element_text, "axis.text"), + axis.text.x.top = el_def(element_text, "axis.text.x"), + axis.text.x.bottom = el_def(element_text, "axis.text.x"), + axis.text.y = el_def(element_text, "axis.text"), + axis.text.y.left = el_def(element_text, "axis.text.y"), + axis.text.y.right = el_def(element_text, "axis.text.y"), + axis.text.theta = el_def(element_text, "axis.text.x"), + axis.text.r = el_def(element_text, "axis.text.y"), axis.ticks.length = el_def(c("unit", "rel"), "spacing"), axis.ticks.length.x = el_def(c("unit", "rel"), "axis.ticks.length"), @@ -670,28 +670,28 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { axis.ticks.length.theta = el_def(c("unit", "rel"), "axis.ticks.length.x"), axis.ticks.length.r = el_def(c("unit", "rel"), "axis.ticks.length.y"), - axis.ticks.x = el_def("element_line", "axis.ticks"), - axis.ticks.x.top = el_def("element_line", "axis.ticks.x"), - axis.ticks.x.bottom = el_def("element_line", "axis.ticks.x"), - axis.ticks.y = el_def("element_line", "axis.ticks"), - axis.ticks.y.left = el_def("element_line", "axis.ticks.y"), - axis.ticks.y.right = el_def("element_line", "axis.ticks.y"), - axis.ticks.theta = el_def("element_line", "axis.ticks.x"), - axis.ticks.r = el_def("element_line", "axis.ticks.y"), - - axis.title.x = el_def("element_text", "axis.title"), - axis.title.x.top = el_def("element_text", "axis.title.x"), - axis.title.x.bottom = el_def("element_text", "axis.title.x"), - axis.title.y = el_def("element_text", "axis.title"), - axis.title.y.left = el_def("element_text", "axis.title.y"), - axis.title.y.right = el_def("element_text", "axis.title.y"), - - axis.minor.ticks.x.top = el_def("element_line", "axis.ticks.x.top"), - axis.minor.ticks.x.bottom = el_def("element_line", "axis.ticks.x.bottom"), - axis.minor.ticks.y.left = el_def("element_line", "axis.ticks.y.left"), - axis.minor.ticks.y.right = el_def("element_line", "axis.ticks.y.right"), - axis.minor.ticks.theta = el_def("element_line", "axis.ticks.theta"), - axis.minor.ticks.r = el_def("element_line", "axis.ticks.r"), + axis.ticks.x = el_def(element_line, "axis.ticks"), + axis.ticks.x.top = el_def(element_line, "axis.ticks.x"), + axis.ticks.x.bottom = el_def(element_line, "axis.ticks.x"), + axis.ticks.y = el_def(element_line, "axis.ticks"), + axis.ticks.y.left = el_def(element_line, "axis.ticks.y"), + axis.ticks.y.right = el_def(element_line, "axis.ticks.y"), + axis.ticks.theta = el_def(element_line, "axis.ticks.x"), + axis.ticks.r = el_def(element_line, "axis.ticks.y"), + + axis.title.x = el_def(element_text, "axis.title"), + axis.title.x.top = el_def(element_text, "axis.title.x"), + axis.title.x.bottom = el_def(element_text, "axis.title.x"), + axis.title.y = el_def(element_text, "axis.title"), + axis.title.y.left = el_def(element_text, "axis.title.y"), + axis.title.y.right = el_def(element_text, "axis.title.y"), + + axis.minor.ticks.x.top = el_def(element_line, "axis.ticks.x.top"), + axis.minor.ticks.x.bottom = el_def(element_line, "axis.ticks.x.bottom"), + axis.minor.ticks.y.left = el_def(element_line, "axis.ticks.y.left"), + axis.minor.ticks.y.right = el_def(element_line, "axis.ticks.y.right"), + axis.minor.ticks.theta = el_def(element_line, "axis.ticks.theta"), + axis.minor.ticks.r = el_def(element_line, "axis.ticks.r"), axis.minor.ticks.length = el_def(c("unit", "rel")), axis.minor.ticks.length.x = el_def(c("unit", "rel"), "axis.minor.ticks.length"), @@ -715,25 +715,25 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { c("unit", "rel"), c("axis.minor.ticks.length.y", "axis.ticks.length.r") ), - legend.background = el_def("element_rect", "rect"), + legend.background = el_def(element_rect, "rect"), legend.margin = el_def(c("margin", "unit", "rel"), "margins"), legend.spacing = el_def(c("unit", "rel"), "spacing"), legend.spacing.x = el_def(c("unit", "rel"), "legend.spacing"), legend.spacing.y = el_def(c("unit", "rel"), "legend.spacing"), - legend.key = el_def("element_rect", "panel.background"), + legend.key = el_def(element_rect, "panel.background"), legend.key.height = el_def(c("unit", "rel"), "legend.key.size"), legend.key.width = el_def(c("unit", "rel"), "legend.key.size"), legend.key.spacing = el_def(c("unit", "rel"), "spacing"), legend.key.spacing.x = el_def(c("unit", "rel"), "legend.key.spacing"), legend.key.spacing.y = el_def(c("unit", "rel"), "legend.key.spacing"), legend.key.justification = el_def(c("character", "numeric", "integer")), - legend.frame = el_def("element_rect", "rect"), - legend.axis.line = el_def("element_line", "line"), - legend.ticks = el_def("element_line", "legend.axis.line"), + legend.frame = el_def(element_rect, "rect"), + legend.axis.line = el_def(element_line, "line"), + legend.ticks = el_def(element_line, "legend.axis.line"), legend.ticks.length = el_def(c("rel", "unit"), "legend.key.size"), - legend.text = el_def("element_text", "text"), + legend.text = el_def(element_text, "text"), legend.text.position = el_def("character"), - legend.title = el_def("element_text", "title"), + legend.title = el_def(element_text, "title"), legend.title.position = el_def("character"), legend.byrow = el_def("logical"), legend.position = el_def("character"), @@ -767,45 +767,45 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { legend.box = el_def("character"), legend.box.just = el_def("character"), legend.box.margin = el_def(c("margin", "unit", "rel"), "margins"), - legend.box.background = el_def("element_rect", "rect"), + legend.box.background = el_def(element_rect, "rect"), legend.box.spacing = el_def(c("unit", "rel"), "spacing"), - panel.background = el_def("element_rect", "rect"), - panel.border = el_def("element_rect", "rect"), + panel.background = el_def(element_rect, "rect"), + panel.border = el_def(element_rect, "rect"), panel.spacing = el_def(c("unit", "rel"), "spacing"), panel.spacing.x = el_def(c("unit", "rel"), "panel.spacing"), panel.spacing.y = el_def(c("unit", "rel"), "panel.spacing"), - panel.grid.major.x = el_def("element_line", "panel.grid.major"), - panel.grid.major.y = el_def("element_line", "panel.grid.major"), - panel.grid.minor.x = el_def("element_line", "panel.grid.minor"), - panel.grid.minor.y = el_def("element_line", "panel.grid.minor"), + panel.grid.major.x = el_def(element_line, "panel.grid.major"), + panel.grid.major.y = el_def(element_line, "panel.grid.major"), + panel.grid.minor.x = el_def(element_line, "panel.grid.minor"), + panel.grid.minor.y = el_def(element_line, "panel.grid.minor"), panel.ontop = el_def("logical"), panel.widths = el_def("unit"), panel.heights = el_def("unit"), - strip.background = el_def("element_rect", "rect"), - strip.background.x = el_def("element_rect", "strip.background"), - strip.background.y = el_def("element_rect", "strip.background"), + strip.background = el_def(element_rect, "rect"), + strip.background.x = el_def(element_rect, "strip.background"), + strip.background.y = el_def(element_rect, "strip.background"), strip.clip = el_def("character"), - strip.text.x = el_def("element_text", "strip.text"), - strip.text.x.top = el_def("element_text", "strip.text.x"), - strip.text.x.bottom = el_def("element_text", "strip.text.x"), - strip.text.y = el_def("element_text", "strip.text"), - strip.text.y.left = el_def("element_text", "strip.text.y"), - strip.text.y.right = el_def("element_text", "strip.text.y"), + strip.text.x = el_def(element_text, "strip.text"), + strip.text.x.top = el_def(element_text, "strip.text.x"), + strip.text.x.bottom = el_def(element_text, "strip.text.x"), + strip.text.y = el_def(element_text, "strip.text"), + strip.text.y.left = el_def(element_text, "strip.text.y"), + strip.text.y.right = el_def(element_text, "strip.text.y"), strip.placement = el_def("character"), strip.placement.x = el_def("character", "strip.placement"), strip.placement.y = el_def("character", "strip.placement"), strip.switch.pad.grid = el_def(c("unit", "rel"), "spacing"), strip.switch.pad.wrap = el_def(c("unit", "rel"), "spacing"), - plot.background = el_def("element_rect", "rect"), - plot.title = el_def("element_text", "title"), + plot.background = el_def(element_rect, "rect"), + plot.title = el_def(element_text, "title"), plot.title.position = el_def("character"), - plot.subtitle = el_def("element_text", "text"), - plot.caption = el_def("element_text", "text"), + plot.subtitle = el_def(element_text, "text"), + plot.caption = el_def(element_text, "text"), plot.caption.position = el_def("character"), - plot.tag = el_def("element_text", "text"), + plot.tag = el_def(element_text, "text"), plot.tag.position = el_def(c("character", "numeric", "integer")), # Need to also accept numbers plot.tag.location = el_def("character"), plot.margin = el_def(c("margin", "unit", "rel"), "margins"), @@ -849,11 +849,18 @@ check_element <- function(el, elname, element_tree, call = caller_env()) { # NULL values for elements are OK if (is.null(el)) return() + class <- eldef$class + if (inherits(class, "S7_class") && S7::S7_inherits(el)) { + if (S7::S7_inherits(el, class) || + (S7::S7_inherits(el, element) && S7::S7_inherits(el, element_blank))) { + return() + } + } - if ("margin" %in% eldef$class) { + if ("margin" %in% class) { if (!is.unit(el) && length(el) == 4) cli::cli_abort("The {.var {elname}} theme element must be a {.cls unit} vector of length 4.", call = call) - } else if (!inherits(el, eldef$class) && !inherits(el, "element_blank")) { + } else if (!inherits(el, class) && !inherits(el, "element_blank")) { cli::cli_abort("The {.var {elname}} theme element must be a {.cls {eldef$class}} object.", call = call) } invisible() diff --git a/man/register_theme_elements.Rd b/man/register_theme_elements.Rd index cdbbb25d70..0cb822e686 100644 --- a/man/register_theme_elements.Rd +++ b/man/register_theme_elements.Rd @@ -27,8 +27,8 @@ a list of named element definitions created with el_def().} \item{reset_current}{If \code{TRUE} (the default), the currently active theme is reset to the default theme.} -\item{class}{The name of the element class. Examples are "element_line" or -"element_text" or "unit", or one of the two reserved keywords "character" or +\item{class}{The name of the element class. Examples are \code{element_line} or +\code{element_text} or "unit", or one of the two reserved keywords "character" or "margin". The reserved keyword "character" implies a character or numeric vector, not a class called "character". The keyword "margin" implies a unit vector of length 4, as created by \code{\link[=margin]{margin()}}.} @@ -76,7 +76,7 @@ element inheritance relationships for the element tree. # plot panels. To do so, it registers a new theme element `ggxyz.panel.annotation` register_theme_elements( ggxyz.panel.annotation = element_text(color = "blue", hjust = 0.95, vjust = 0.05), - element_tree = list(ggxyz.panel.annotation = el_def("element_text", "text")) + element_tree = list(ggxyz.panel.annotation = el_def(element_text, "text")) ) # Now the package can define a new coord that includes a panel annotation From 202b80d36ec06db7984ffab6083c5797576d9e21 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 5 Mar 2025 14:28:17 +0100 Subject: [PATCH 05/58] convert element_grob to S7 generic --- NAMESPACE | 6 -- R/theme-elements.R | 211 ++++++++++++++++++++++----------------------- R/zzz.R | 1 + 3 files changed, 103 insertions(+), 115 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 5e4384df4e..0d77b59701 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,12 +18,6 @@ S3method(autolayer,default) S3method(autoplot,default) S3method(c,mapped_discrete) S3method(drawDetails,zeroGrob) -S3method(element_grob,element_blank) -S3method(element_grob,element_line) -S3method(element_grob,element_point) -S3method(element_grob,element_polygon) -S3method(element_grob,element_rect) -S3method(element_grob,element_text) S3method(format,ggproto) S3method(format,ggproto_method) S3method(fortify,"NULL") diff --git a/R/theme-elements.R b/R/theme-elements.R index 5e3a016e69..b451a963cc 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -321,134 +321,127 @@ element_render <- function(theme, element, ..., name = NULL) { #' usually at least position. See the source code for individual methods. #' @keywords internal #' @export -element_grob <- function(element, ...) { - UseMethod("element_grob") -} +element_grob <- S7::new_generic("element_grob", "element") -#' @export -element_grob.element_blank <- function(element, ...) zeroGrob() +S7::method(element_grob, element_blank) <- function(element, ...) zeroGrob() -#' @export -element_grob.element_rect <- function(element, x = 0.5, y = 0.5, - width = 1, height = 1, - fill = NULL, colour = NULL, linewidth = NULL, linetype = NULL, ..., size = deprecated()) { +S7::method(element_grob, element_rect) <- + function(element, x = 0.5, y = 0.5, width = 1, height = 1, + fill = NULL, colour = NULL, linewidth = NULL, linetype = NULL, + ..., size = deprecated()) { - if (lifecycle::is_present(size)) { - deprecate_soft0("3.4.0", "element_grob.element_rect(size)", "element_grob.element_rect(linewidth)") - linewidth <- size - } + if (lifecycle::is_present(size)) { + deprecate_soft0("3.4.0", "element_grob.element_rect(size)", "element_grob.element_rect(linewidth)") + linewidth <- size + } - # The gp settings can override element_gp - gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype) - element_gp <- gg_par(lwd = element$linewidth, col = element$colour, - fill = element$fill, lty = element$linetype) + gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype) + element_gp <- gg_par(lwd = element@linewidth, col = element@colour, + fill = element@fill, lty = element@linetype) - rectGrob(x, y, width, height, gp = modify_list(element_gp, gp), ...) -} + rectGrob(x, y, width, height, gp = modify_list(element_gp, gp), ...) + } +S7::method(element_grob, element_text) <- + function(element, label = "", x = NULL, y = NULL, + family = NULL, face = NULL, colour = NULL, size = NULL, + hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL, + margin = NULL, margin_x = FALSE, margin_y = FALSE, ...) { -#' @export -element_grob.element_text <- function(element, label = "", x = NULL, y = NULL, - family = NULL, face = NULL, colour = NULL, size = NULL, - hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL, - margin = NULL, margin_x = FALSE, margin_y = FALSE, ...) { + if (is.null(label)) + return(zeroGrob()) - if (is.null(label)) - return(zeroGrob()) + vj <- vjust %||% element@vjust + hj <- hjust %||% element@hjust + margin <- margin %||% element@margin - vj <- vjust %||% element$vjust - hj <- hjust %||% element$hjust - margin <- margin %||% element$margin + angle <- angle %||% element@angle %||% 0 - angle <- angle %||% element$angle %||% 0 + # The gp settings can override element_gp + gp <- gg_par(fontsize = size, col = colour, + fontfamily = family, fontface = face, + lineheight = lineheight) + element_gp <- gg_par(fontsize = element@size, col = element@colour, + fontfamily = element@family, fontface = element@face, + lineheight = element@lineheight) - # The gp settings can override element_gp - gp <- gg_par(fontsize = size, col = colour, - fontfamily = family, fontface = face, - lineheight = lineheight) - element_gp <- gg_par(fontsize = element$size, col = element$colour, - fontfamily = element$family, fontface = element$face, - lineheight = element$lineheight) + titleGrob(label, x, y, hjust = hj, vjust = vj, angle = angle, + gp = modify_list(element_gp, gp), margin = margin, + margin_x = margin_x, margin_y = margin_y, debug = element@debug, ...) + } - titleGrob(label, x, y, hjust = hj, vjust = vj, angle = angle, - gp = modify_list(element_gp, gp), margin = margin, - margin_x = margin_x, margin_y = margin_y, debug = element$debug, ...) -} +S7::method(element_grob, element_line) <- + function(element, x = 0:1, y = 0:1, + colour = NULL, linewidth = NULL, linetype = NULL, lineend = NULL, + arrow.fill = NULL, + default.units = "npc", id.lengths = NULL, ..., size = deprecated()) { + if (lifecycle::is_present(size)) { + deprecate_soft0("3.4.0", "element_grob.element_line(size)", "element_grob.element_line(linewidth)") + linewidth <- size + } + arrow <- if (is.logical(element@arrow) && !element@arrow) { + NULL + } else { + element@arrow + } + if (is.null(arrow)) { + arrow.fill <- colour + element@arrow.fill <- element@colour + } -#' @export -element_grob.element_line <- function(element, x = 0:1, y = 0:1, - colour = NULL, linewidth = NULL, linetype = NULL, lineend = NULL, - arrow.fill = NULL, - default.units = "npc", id.lengths = NULL, ..., size = deprecated()) { - - if (lifecycle::is_present(size)) { - deprecate_soft0("3.4.0", "element_grob.element_line(size)", "element_grob.element_line(linewidth)") - linewidth <- size - } + # The gp settings can override element_gp + gp <- gg_par( + col = colour, fill = arrow.fill %||% colour, + lwd = linewidth, lty = linetype, lineend = lineend + ) + element_gp <- gg_par( + col = element@colour, fill = element@arrow.fill %||% element@colour, + lwd = element@linewidth, lty = element@linetype, + lineend = element@lineend + ) - arrow <- if (is.logical(element$arrow) && !element$arrow) { - NULL - } else { - element$arrow - } - if (is.null(arrow)) { - arrow.fill <- colour - element$arrow.fill <- element$colour + polylineGrob( + x, y, default.units = default.units, + gp = modify_list(element_gp, gp), + id.lengths = id.lengths, arrow = arrow, ... + ) } - # The gp settings can override element_gp - gp <- gg_par( - col = colour, fill = arrow.fill %||% colour, - lwd = linewidth, lty = linetype, lineend = lineend - ) - element_gp <- gg_par( - col = element$colour, fill = element$arrow.fill %||% element$colour, - lwd = element$linewidth, lty = element$linetype, - lineend = element$lineend - ) - - polylineGrob( - x, y, default.units = default.units, - gp = modify_list(element_gp, gp), - id.lengths = id.lengths, arrow = arrow, ... - ) -} - -#' @export -element_grob.element_polygon <- function(element, x = c(0, 0.5, 1, 0.5), - y = c(0.5, 1, 0.5, 0), fill = NULL, - colour = NULL, linewidth = NULL, - linetype = NULL, ..., - id = NULL, id.lengths = NULL, - pathId = NULL, pathId.lengths = NULL) { - - gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype) - element_gp <- gg_par(lwd = element$linewidth, col = element$colour, - fill = element$fill, lty = element$linetype) - pathGrob( - x = x, y = y, gp = modify_list(element_gp, gp), ..., - # We swap the id logic so that `id` is always the (super)group id - # (consistent with `polygonGrob()`) and `pathId` always the subgroup id. - pathId = id, pathId.lengths = id.lengths, - id = pathId, id.lengths = pathId.lengths - ) -} +S7::method(element_grob, element_polygon) <- + function(element, x = c(0, 0.5, 1, 0.5), + y = c(0.5, 1, 0.5, 0), fill = NULL, + colour = NULL, linewidth = NULL, + linetype = NULL, ..., + id = NULL, id.lengths = NULL, + pathId = NULL, pathId.lengths = NULL) { + + gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype) + element_gp <- gg_par(lwd = element@linewidth, col = element@colour, + fill = element@fill, lty = element@linetype) + pathGrob( + x = x, y = y, gp = modify_list(element_gp, gp), ..., + # We swap the id logic so that `id` is always the (super)group id + # (consistent with `polygonGrob()`) and `pathId` always the subgroup id. + pathId = id, pathId.lengths = id.lengths, + id = pathId, id.lengths = pathId.lengths + ) + } -#' @export -element_grob.element_point <- function(element, x = 0.5, y = 0.5, colour = NULL, - shape = NULL, fill = NULL, size = NULL, - stroke = NULL, ..., - default.units = "npc") { - - gp <- gg_par(col = colour, fill = fill, pointsize = size, stroke = stroke) - element_gp <- gg_par(col = element$colour, fill = element$fill, - pointsize = element$size, stroke = element$stroke) - shape <- translate_shape_string(shape %||% element$shape %||% 19) - pointsGrob(x = x, y = y, pch = shape, gp = modify_list(element_gp, gp), - default.units = default.units, ...) -} +S7::method(element_grob, element_point) <- + function(element, x = 0.5, y = 0.5, colour = NULL, + shape = NULL, fill = NULL, size = NULL, + stroke = NULL, ..., + default.units = "npc") { + + gp <- gg_par(col = colour, fill = fill, pointsize = size, stroke = stroke) + element_gp <- gg_par(col = element@colour, fill = element@fill, + pointsize = element@size, stroke = element@stroke) + shape <- translate_shape_string(shape %||% element@shape %||% 19) + pointsGrob(x = x, y = y, pch = shape, gp = modify_list(element_gp, gp), + default.units = default.units, ...) + } #' Define and register new theme elements #' 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() } From df02b37acd372d5bf0bfaa02fb119079e7fd96db Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 5 Mar 2025 17:37:27 +0100 Subject: [PATCH 06/58] replace merge_element by S7 --- NAMESPACE | 4 -- R/theme.R | 124 ++++++++++++++++++++----------------------- man/merge_element.Rd | 14 +---- 3 files changed, 60 insertions(+), 82 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 0d77b59701..04986e15bb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -87,10 +87,6 @@ S3method(limits,character) S3method(limits,factor) S3method(limits,numeric) S3method(makeContext,dotstackGrob) -S3method(merge_element,default) -S3method(merge_element,element) -S3method(merge_element,element_blank) -S3method(merge_element,margin) S3method(pattern_alpha,GridPattern) S3method(pattern_alpha,GridTilingPattern) S3method(pattern_alpha,default) diff --git a/R/theme.R b/R/theme.R index 1c16c85656..3478c45b7c 100644 --- a/R/theme.R +++ b/R/theme.R @@ -797,69 +797,63 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, #' # Adopt size but ignore colour #' merge_element(new, old) #' -merge_element <- function(new, old) { - UseMethod("merge_element") -} +merge_element <- S7::new_generic("merge_element", c("new", "old")) + +S7::method(merge_element, list(S7::class_any, S7::class_any)) <- + function(new, old, ...) { + if (is.null(old) || S7::S7_inherits(old, element_blank)) { + # If old is NULL or element_blank, then just return new + return(new) + } else if (is.null(new) || is.character(new) || is.numeric(new) || is.unit(new) || + is.logical(new)) { + # If new is NULL, or a string, numeric vector, unit, or logical, just return it + return(new) + } -#' @rdname merge_element -#' @export -merge_element.default <- function(new, old) { - if (is.null(old) || inherits(old, "element_blank")) { - # If old is NULL or element_blank, then just return new - return(new) - } else if (is.null(new) || is.character(new) || is.numeric(new) || is.unit(new) || - is.logical(new)) { - # If new is NULL, or a string, numeric vector, unit, or logical, just return it - return(new) + # otherwise we can't merge + cli::cli_abort("No method for merging {.cls {class(new)[1]}} into {.cls {class(old)[1]}}.") } - # otherwise we can't merge - cli::cli_abort("No method for merging {.cls {class(new)[1]}} into {.cls {class(old)[1]}}.") -} - -#' @rdname merge_element -#' @export -merge_element.element_blank <- function(new, old) { - # If new is element_blank, just return it - new -} - -#' @rdname merge_element -#' @export -merge_element.element <- function(new, old) { - if (is.null(old) || inherits(old, "element_blank")) { - # If old is NULL or element_blank, then just return new - return(new) +S7::method(merge_element, list(element_blank, S7::class_any)) <- + function(new, old, ...) { + # If new is element_blank, just return it + new } - # actual merging can only happen if classes match - if (!inherits(new, class(old)[1])) { - cli::cli_abort("Only elements of the same class can be merged.") - } +S7::method(merge_element, list(element, S7::class_any)) <- + function(new, old, ...) { + if (is.null(old) || S7::S7_inherits(old, element_blank)) { + # If old is NULL or element_blank, then just return new + return(new) + } - # Override NULL properties of new with the values in old - # Get logical vector of NULL properties in new - idx <- vapply(new, is.null, logical(1)) - # Get the names of TRUE items - idx <- names(idx[idx]) + # actual merging can only happen if classes match + if (!inherits(new, class(old)[1])) { + cli::cli_abort("Only elements of the same class can be merged.") + } - # Update non-NULL items - new[idx] <- old[idx] + # Override NULL properties of new with the values in old + # Get logical vector of NULL properties in new + idx <- lengths(S7::props(new)) == 0 + # Get the names of TRUE items + idx <- names(idx[idx]) - new + # Update non-NULL items + S7::props(new)[idx] <- S7::props(old, idx) + + new } -#' @rdname merge_element -#' @export -merge_element.margin <- function(new, old) { - if (is.null(old) || inherits(old, "element_blank")) { - return(new) - } - if (anyNA(new)) { - new[is.na(new)] <- old[is.na(new)] +S7::method(merge_element, list(S7::new_S3_class("margin"), S7::class_any)) <- + function(new, old, ...) { + if (is.null(old) || S7::S7_inherits(old, element_blank)) { + return(new) + } + if (anyNA(new)) { + new[is.na(new)] <- old[is.na(new)] + } + new } - new -} #' Combine the properties of two elements #' @@ -871,7 +865,7 @@ merge_element.margin <- function(new, old) { combine_elements <- function(e1, e2) { # If e2 is NULL, nothing to inherit - if (is.null(e2) || inherits(e1, "element_blank")) { + if (is.null(e2) || S7::S7_inherits(e1, element_blank)) { return(e1) } @@ -904,14 +898,14 @@ combine_elements <- function(e1, e2) { } # If neither of e1 or e2 are element_* objects, return e1 - if (!inherits(e1, "element") && !inherits(e2, "element")) { + if (!S7::S7_inherits(e1, element) && !S7::S7_inherits(e2, element)) { return(e1) } # If e2 is element_blank, and e1 inherits blank inherit everything from e2, # otherwise ignore e2 - if (inherits(e2, "element_blank")) { - if (e1$inherit.blank) { + if (S7::S7_inherits(e2, element_blank)) { + if (S7::prop_exists(e1, "inherit.blank") && e1@inherit.blank) { return(e2) } else { return(e1) @@ -919,29 +913,29 @@ combine_elements <- function(e1, e2) { } # If e1 has any NULL properties, inherit them from e2 - n <- names(e1)[vapply(e1, is.null, logical(1))] - e1[n] <- e2[n] + n <- S7::prop_names(e1)[lengths(S7::props(e1)) == 0] + S7::props(e1)[n] <- S7::props(e2)[n] # Calculate relative sizes - if (is.rel(e1$size)) { - e1$size <- e2$size * unclass(e1$size) + if (S7::prop_exists(e1, "size") && is.rel(e1@size)) { + e1@size <- e2@size * unclass(e1@size) } # Calculate relative linewidth - if (is.rel(e1$linewidth)) { - e1$linewidth <- e2$linewidth * unclass(e1$linewidth) + if (S7::prop_exists(e1, "linewidth") && is.rel(e1@linewidth)) { + e1@linewidth <- e2@linewidth * unclass(e1@linewidth) } if (inherits(e1, "element_text")) { - e1$margin <- combine_elements(e1$margin, e2$margin) + e1@margin <- combine_elements(e1@margin, e2@margin) } # If e2 is 'richer' than e1, fill e2 with e1 parameters is_subclass <- !any(inherits(e2, class(e1), which = TRUE) == 0) is_subclass <- is_subclass && length(setdiff(class(e2), class(e1)) > 0) if (is_subclass) { - new <- defaults(e1, e2) - e2[names(new)] <- new + new <- defaults(S7::props(e1), S7::props(e2)) + S7::props(e2)[names(new)] <- new return(e2) } diff --git a/man/merge_element.Rd b/man/merge_element.Rd index ca993eeec3..3060360dc0 100644 --- a/man/merge_element.Rd +++ b/man/merge_element.Rd @@ -2,21 +2,9 @@ % Please edit documentation in R/theme.R \name{merge_element} \alias{merge_element} -\alias{merge_element.default} -\alias{merge_element.element_blank} -\alias{merge_element.element} -\alias{merge_element.margin} \title{Merge a parent element into a child element} \usage{ -merge_element(new, old) - -\method{merge_element}{default}(new, old) - -\method{merge_element}{element_blank}(new, old) - -\method{merge_element}{element}(new, old) - -\method{merge_element}{margin}(new, old) +merge_element(new, old, ...) } \arguments{ \item{new}{The child element in the theme hierarchy} From b038e8f633d8526f6e20ee9bf4549634cc38d565 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Mar 2025 10:49:48 +0100 Subject: [PATCH 07/58] implement `$.element` for backward compatibility --- NAMESPACE | 6 +++--- R/ggproto.R | 5 +++-- R/theme-elements.R | 8 ++++++++ R/theme.R | 3 ++- 4 files changed, 16 insertions(+), 6 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 04986e15bb..a88e3f341d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,8 +1,5 @@ # Generated by roxygen2: do not edit by hand -S3method("$",ggproto) -S3method("$",ggproto_parent) -S3method("$",theme) S3method("$<-",uneval) S3method("+",gg) S3method("[",mapped_discrete) @@ -16,6 +13,9 @@ S3method(as.data.frame,mapped_discrete) S3method(as.list,ggproto) S3method(autolayer,default) S3method(autoplot,default) +S3method(base::`$`, ggproto) +S3method(base::`$`, ggproto_parent) +S3method(base::`$`, theme) S3method(c,mapped_discrete) S3method(drawDetails,zeroGrob) S3method(format,ggproto) diff --git a/R/ggproto.R b/R/ggproto.R index 6165a9707d..3de50401c3 100644 --- a/R/ggproto.R +++ b/R/ggproto.R @@ -152,7 +152,8 @@ fetch_ggproto <- function(x, name) { } -#' @export +# Prevents bug described in S7/#390 +#' @rawNamespace S3method(base::`$`, ggproto) `$.ggproto` <- function(x, name) { res <- fetch_ggproto(x, name) if (!is.function(res)) { @@ -162,7 +163,7 @@ fetch_ggproto <- function(x, name) { make_proto_method(x, res, name) } -#' @export +#' @rawNamespace S3method(base::`$`, ggproto_parent) `$.ggproto_parent` <- function(x, name) { res <- fetch_ggproto(.subset2(x, "parent"), name) if (!is.function(res)) { diff --git a/R/theme-elements.R b/R/theme-elements.R index b451a963cc..4118948e07 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -83,6 +83,14 @@ NULL #' @rdname element element <- S7::new_class("element", abstract = TRUE) +S7::method(`$`, element) <- + function(x, i) { + if (!S7::prop_exists(x, i)) { + return(NULL) + } + S7::prop(x, i) + } + #' @export #' @rdname element element_blank <- S7::new_class("element_blank", parent = element) diff --git a/R/theme.R b/R/theme.R index 3478c45b7c..d63b126e84 100644 --- a/R/theme.R +++ b/R/theme.R @@ -942,7 +942,8 @@ combine_elements <- function(e1, e2) { e1 } -#' @export +# Prevents bug described in S7/#390 +#' @rawNamespace S3method(base::`$`, theme) `$.theme` <- function(x, ...) { .subset2(x, ...) } From 09eef8dae6931296b0123794e23a1259466ea928 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Mar 2025 10:56:02 +0100 Subject: [PATCH 08/58] Use S7 properties --- R/coord-sf.R | 8 +-- R/geom-.R | 2 +- R/guide-axis-theta.R | 8 +-- R/guide-axis.R | 10 ++-- R/guide-custom.R | 2 +- R/guide-legend.R | 4 +- R/plot-build.R | 8 +-- R/theme.R | 12 +++- tests/testthat/_snaps/theme.md | 4 +- tests/testthat/test-theme.R | 100 ++++++++++++++++----------------- 10 files changed, 83 insertions(+), 75 deletions(-) diff --git a/R/coord-sf.R b/R/coord-sf.R index d603d57de7..0bcfafa4c3 100644 --- a/R/coord-sf.R +++ b/R/coord-sf.R @@ -334,13 +334,13 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, # we don't draw the graticules if the major panel grid is # turned off - if (inherits(el, "element_blank")) { + if (S7::S7_inherits(el, element_blank)) { grobs <- list(element_render(theme, "panel.background")) } else { line_gp <- gg_par( - col = el$colour, - lwd = el$linewidth, - lty = el$linetype + col = el@colour, + lwd = el@linewidth, + lty = el@linetype ) grobs <- c( list(element_render(theme, "panel.background")), diff --git a/R/geom-.R b/R/geom-.R index 843bd4c11c..52e36b9121 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -248,7 +248,7 @@ eval_from_theme <- function(aesthetics, theme) { return(aesthetics) } settings <- calc_element("geom", theme) %||% .default_geom_element - lapply(aesthetics[themed], eval_tidy, data = settings) + lapply(aesthetics[themed], eval_tidy, data = S7::props(settings)) } #' Graphical units diff --git a/R/guide-axis-theta.R b/R/guide-axis-theta.R index af96a337b6..492fd53482 100644 --- a/R/guide-axis-theta.R +++ b/R/guide-axis-theta.R @@ -153,7 +153,7 @@ GuideAxisTheta <- ggproto( } offset <- max(unit(0, "pt"), elements$major_length, elements$minor_length) - elements$offset <- offset + max(elements$text$margin %||% unit(0, "pt")) + elements$offset <- offset + max(elements$text@margin %||% unit(0, "pt")) elements }, @@ -197,7 +197,7 @@ GuideAxisTheta <- ggproto( # Resolve text angle if (is.waiver(params$angle) || is.null(params$angle)) { - angle <- elements$text$angle + angle <- elements$text@angle } else { angle <- flip_text_angle(params$angle - rad2deg(key$theta)) } @@ -273,14 +273,14 @@ GuideAxisTheta <- ggproto( # Resolve text angle if (is.waiver(params$angle %||% waiver())) { - angle <- elements$text$angle + angle <- elements$text@angle } else { angle <- flip_text_angle(params$angle - rad2deg(key$theta)) } angle <- key$theta + deg2rad(angle) # Set margin - margin <- rep(max(elements$text$margin), length.out = 4) + margin <- rep(max(elements$text@margin), length.out = 4) # Measure size of each individual label single_labels <- lapply(labels, function(lab) { diff --git a/R/guide-axis.R b/R/guide-axis.R index d445900071..32398bf3bc 100644 --- a/R/guide-axis.R +++ b/R/guide-axis.R @@ -450,13 +450,13 @@ GuideAxis <- ggproto( # rather than dimensions of this axis alone. if (has_labels && params$position %in% c("left", "right")) { where <- layout$l[-c(1, length(layout$l))] - just <- with(elements$text, rotate_just(angle, hjust, vjust))$hjust %||% 0.5 + just <- with(S7::props(elements$text), rotate_just(angle, hjust, vjust))$hjust %||% 0.5 gt <- gtable_add_cols(gt, unit(just, "null"), pos = min(where) - 1) gt <- gtable_add_cols(gt, unit(1 - just, "null"), pos = max(where) + 1) } if (has_labels && params$position %in% c("top", "bottom")) { where <- layout$t[-c(1, length(layout$t))] - just <- with(elements$text, rotate_just(angle, hjust, vjust))$vjust %||% 0.5 + just <- with(S7::props(elements$text), rotate_just(angle, hjust, vjust))$vjust %||% 0.5 gt <- gtable_add_rows(gt, unit(1 - just, "null"), pos = min(where) - 1) gt <- gtable_add_rows(gt, unit(just, "null"), pos = max(where) + 1) } @@ -612,8 +612,8 @@ label_angle_heuristic <- function(element, position, angle) { hjust <- switch(position, left = cosine, right = 1 - cosine, top = 1 - sine, sine) vjust <- switch(position, left = 1 - sine, right = sine, top = 1 - cosine, cosine) - element$angle <- angle %||% element$angle - element$hjust <- hjust %||% element$hjust - element$vjust <- vjust %||% element$vjust + element@angle <- angle %||% element@angle + element@hjust <- hjust %||% element@hjust + element@vjust <- vjust %||% element@vjust element } diff --git a/R/guide-custom.R b/R/guide-custom.R index f602bfc843..1a6d977c7f 100644 --- a/R/guide-custom.R +++ b/R/guide-custom.R @@ -113,7 +113,7 @@ GuideCustom <- ggproto( gt <- self$add_title( gt, title, title_position, - with(elems$title, rotate_just(angle, hjust, vjust)) + with(S7::props(elems$title), rotate_just(angle, hjust, vjust)) ) # Add padding and background diff --git a/R/guide-legend.R b/R/guide-legend.R index c8bf395f0a..b37e210a78 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -325,7 +325,7 @@ GuideLegend <- ggproto( # Resolve title. The trick here is to override the main text element, so # that any settings declared in `legend.title` will be honoured but we have # custom defaults for the guide. - margin <- calc_element("text", theme)$margin + margin <- calc_element("text", theme)@margin title <- theme(text = element_text( hjust = 0, vjust = 0.5, margin = position_margin(title_position, margin, gap) @@ -573,7 +573,7 @@ GuideLegend <- ggproto( gt <- self$add_title( gt, grobs$title, elements$title_position, - with(elements$title, rotate_just(angle, hjust, vjust)) + with(S7::props(elements$title), rotate_just(angle, hjust, vjust)) ) gt <- gtable_add_padding(gt, unit(elements$padding, "cm")) diff --git a/R/plot-build.R b/R/plot-build.R index f855dddd78..45cf53571c 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -387,20 +387,20 @@ table_add_tag <- function(table, label, theme) { if (location %in% c("plot", "panel")) { if (!is.numeric(position)) { if (right || left) { - x <- (1 - element$hjust) * width + x <- (1 - element@hjust) * width if (right) { x <- unit(1, "npc") - x } } else { - x <- unit(element$hjust, "npc") + x <- unit(element@hjust, "npc") } if (top || bottom) { - y <- (1 - element$vjust) * height + y <- (1 - element@vjust) * height if (top) { y <- unit(1, "npc") - y } } else { - y <- unit(element$vjust, "npc") + y <- unit(element@vjust, "npc") } } else { x <- unit(position[1], "npc") diff --git a/R/theme.R b/R/theme.R index d63b126e84..dd08ceb926 100644 --- a/R/theme.R +++ b/R/theme.R @@ -746,14 +746,22 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, if (verbose) cli::cli_inform("nothing (top level)") # Check that all the properties of this element are non-NULL - nullprops <- vapply(el_out, is.null, logical(1)) + if (inherits(el_out, "ggplot2::element")) { + nullprops <- lengths(S7::props(el_out)) == 0 + } else { + nullprops <- vapply(el_out, is.null, logical(1)) + } if (!any(nullprops)) { return(el_out) # no null properties, return element as is } # if we have null properties, try to fill in from ggplot_global$theme_default el_out <- combine_elements(el_out, ggplot_global$theme_default[[element]]) - nullprops <- vapply(el_out, is.null, logical(1)) + if (inherits(el_out, "ggplot2::element")) { + nullprops <- lengths(S7::props(el_out)) == 0 + } else { + nullprops <- vapply(el_out, is.null, logical(1)) + } if (!any(nullprops)) { return(el_out) # no null properties remaining, return element } diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index 005e1b2abd..37657e09b5 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -25,7 +25,7 @@ # incorrect theme specifications throw meaningful errors Can't merge the `line` theme element. - Caused by error in `merge_element()`: + Caused by error in `method(merge_element, list(ggplot2::element, class_any))`: ! Only elements of the same class can be merged. --- @@ -74,7 +74,7 @@ Code merge_element(text_base, rect_base) Condition - Error in `merge_element()`: + Error in `method(merge_element, list(ggplot2::element, class_any))`: ! Only elements of the same class can be merged. # Theme elements are checked during build diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 8d74b4038f..86cb19853f 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -30,10 +30,10 @@ test_that("modifying theme element properties with + operator works", { # Modifying a root node changes only the specified properties t <- theme_grey() + theme(text = element_text(colour = 'red')) - expect_identical(t$text$colour, 'red') - expect_identical(t$text$family, theme_grey()$text$family) - expect_identical(t$text$face, theme_grey()$text$face) - expect_identical(t$text$size, theme_grey()$text$size) + expect_identical(t$text@colour, 'red') + expect_identical(t$text@family, theme_grey()$text@family) + expect_identical(t$text@face, theme_grey()$text@face) + expect_identical(t$text@size, theme_grey()$text@size) # Descendent is unchanged expect_identical(t$axis.title.x, theme_grey()$axis.title.x) @@ -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 + tt@colour <- 'red' + expect_true(tt@inherit.blank) + tt@inherit.blank <- FALSE 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() @@ -123,19 +123,19 @@ test_that("calculating theme element inheritance works", { # Check that properties are passed along from axis.title to axis.title.x e <- calc_element('axis.title.x', t) - expect_identical(e$colour, 'red') - expect_false(is.null(e$family)) - expect_false(is.null(e$face)) - expect_false(is.null(e$size)) + expect_identical(e@colour, 'red') + expect_false(is.null(e@family)) + expect_false(is.null(e@face)) + expect_false(is.null(e@size)) # Check that rel() works for relative sizing, and is applied at each level t <- theme_grey(base_size = 12) + theme(axis.title = element_text(size = rel(0.5))) + theme(axis.title.x = element_text(size = rel(0.5))) e <- calc_element('axis.title', t) - expect_identical(e$size, 6) + expect_identical(e@size, 6) ex <- calc_element('axis.title.x', t) - expect_identical(ex$size, 3) + expect_identical(ex@size, 3) # Check that a theme_blank in a parent node gets passed along to children t <- theme_grey() + theme(text = element_blank()) @@ -175,7 +175,7 @@ test_that("calculating theme element inheritance works", { ) e1 <- calc_element("strip.text.x", t) e2 <- calc_element("text", t) - e2$inherit.blank <- FALSE # b/c inherit.blank = TRUE for complete themes + e2@inherit.blank <- FALSE # b/c inherit.blank = TRUE for complete themes expect_identical(e1, e2) theme <- theme_gray() + @@ -201,18 +201,18 @@ test_that("complete and non-complete themes interact correctly with each other", # But for _element properties_, the one on the right modifies the one on the left. t <- theme_bw() + theme(text = element_text(colour = 'red')) expect_true(attr(t, "complete")) - expect_equal(t$text$colour, 'red') + expect_equal(t$text@colour, 'red') # A complete theme object (like theme_bw) always trumps a non-complete theme object t <- theme(text = element_text(colour = 'red')) + theme_bw() expect_true(attr(t, "complete")) - expect_equal(t$text$colour, theme_bw()$text$colour) + expect_equal(t$text@colour, theme_bw()$text@colour) # Adding two non-complete themes: the one on the right modifies the one on the left. t <- theme(text = element_text(colour = 'blue')) + theme(text = element_text(colour = 'red')) expect_false(attr(t, "complete")) - expect_equal(t$text$colour, 'red') + expect_equal(t$text@colour, 'red') }) test_that("complete and non-complete themes interact correctly with ggplot objects", { @@ -240,14 +240,14 @@ test_that("complete and non-complete themes interact correctly with ggplot objec 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", { @@ -327,11 +327,11 @@ test_that("element tree can be modified", { final_theme <- ggplot2:::plot_theme(p, theme_gray()) e1 <- calc_element("blablabla", final_theme) e2 <- calc_element("text", final_theme) - expect_identical(e1$family, e2$family) - expect_identical(e1$face, e2$face) - expect_identical(e1$size, e2$size) - expect_identical(e1$lineheight, e2$lineheight) - expect_identical(e1$colour, "red") # not inherited from element_text + expect_identical(e1@family, e2@family) + expect_identical(e1@face, e2@face) + expect_identical(e1@size, e2@size) + expect_identical(e1@lineheight, e2@lineheight) + expect_identical(e1@colour, "red") # not inherited from element_text # existing elements can be overwritten ed <- el_def("element_rect", "rect") @@ -394,7 +394,7 @@ test_that("complete plot themes shouldn't inherit from default", { base <- ggplot(data.frame(x = 1), aes(x, x)) + geom_point() ptheme <- plot_theme(base + theme(axis.text.x = element_text(colour = "blue")), default_theme) - expect_equal(ptheme$axis.text.x$colour, "blue") + expect_equal(ptheme$axis.text.x@colour, "blue") ptheme <- plot_theme(base + theme_void(), default_theme) expect_null(ptheme$axis.text.x) @@ -429,9 +429,9 @@ test_that("current theme can be updated with new elements", { e1 <- calc_element("abcde", plot_theme(b2)) e2 <- calc_element("text", plot_theme(b2)) - e2$colour <- "blue" - e2$hjust <- 0 - e2$vjust <- 1 + e2@colour <- "blue" + e2@hjust <- 0 + e2@vjust <- 1 expect_identical(e1, e2) reset_theme_settings() @@ -569,7 +569,7 @@ test_that("Element subclasses are inherited", { test <- combine_elements(poor, rich) expect_s3_class(test, "element_rich") expect_equal( - test[c("colour", "linetype", "linewidth")], + S7::props(test)[c("colour", "linetype", "linewidth")], list(colour = "red", linetype = 3, linewidth = 2) ) @@ -577,7 +577,7 @@ test_that("Element subclasses are inherited", { test <- combine_elements(rich, poor) expect_s3_class(test, "element_rich") expect_equal( - test[c("colour", "linetype", "linewidth")], + S7::props(test)[c("colour", "linetype", "linewidth")], list(colour = "red", linetype = 2, linewidth = 2) ) @@ -589,7 +589,7 @@ test_that("Element subclasses are inherited", { test <- combine_elements(sibling, rich) expect_s3_class(test, "element_sibling") expect_equal( - test[c("colour", "linetype", "linewidth")], + S7::props(test)[c("colour", "linetype", "linewidth")], list(colour = "red", linetype = 3, linewidth = 2) ) @@ -597,7 +597,7 @@ test_that("Element subclasses are inherited", { test <- combine_elements(rich, sibling) expect_s3_class(test, "element_rich") expect_equal( - test[c("colour", "linetype", "linewidth")], + S7::props(test)[c("colour", "linetype", "linewidth")], list(colour = "red", linetype = 2, linewidth = 2) ) }) @@ -624,10 +624,10 @@ test_that("header_family is passed on correctly", { td <- theme_dark(base_family = "x", header_family = "y") test <- calc_element("plot.title", td) - expect_equal(test$family, "y") + expect_equal(test@family, "y") test <- calc_element("plot.subtitle", td) - expect_equal(test$family, "x") + expect_equal(test@family, "x") }) test_that("complete_theme completes a theme", { @@ -638,7 +638,7 @@ test_that("complete_theme completes a theme", { # Elements are propagated new <- complete_theme(theme(axis.line = element_line("red")), gray) - expect_equal(new$axis.line$colour, "red") + expect_equal(new$axis.line@colour, "red") # Missing elements are filled in if default theme is incomplete new <- complete_theme(default = theme()) From 62d8db489ce59d06c764c528465362e63db8b968 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Mar 2025 10:59:07 +0100 Subject: [PATCH 09/58] fix `inherits()` issues --- R/guide-.R | 2 +- R/guide-axis-logticks.R | 2 +- R/guide-axis-theta.R | 6 +++--- R/guide-axis.R | 8 ++++---- R/plot-build.R | 2 +- R/theme-elements.R | 7 +++++-- R/theme.R | 16 ++++++++++++---- tests/testthat/test-theme.R | 10 +++++----- 8 files changed, 32 insertions(+), 21 deletions(-) diff --git a/R/guide-.R b/R/guide-.R index 54cae7c873..813c722b4a 100644 --- a/R/guide-.R +++ b/R/guide-.R @@ -379,7 +379,7 @@ Guide <- ggproto( if (!is.theme_element(elements)) { elements <- elements$ticks } - if (!inherits(elements, "element_line")) { + if (!S7::S7_inherits(elements, element_line)) { return(zeroGrob()) } diff --git a/R/guide-axis-logticks.R b/R/guide-axis-logticks.R index 37273cba06..9da147870d 100644 --- a/R/guide-axis-logticks.R +++ b/R/guide-axis-logticks.R @@ -119,7 +119,7 @@ guide_axis_logticks <- function( allow_null = TRUE ) check_bool(expanded) - check_inherits(short.theme, c("element_blank", "element_line")) + check_inherits(short.theme, c("ggplot2::element_blank", "ggplot2::element_line")) new_guide( available_aes = c("x", "y"), diff --git a/R/guide-axis-theta.R b/R/guide-axis-theta.R index 492fd53482..678b75d2a8 100644 --- a/R/guide-axis-theta.R +++ b/R/guide-axis-theta.R @@ -183,7 +183,7 @@ GuideAxisTheta <- ggproto( build_labels = function(key, elements, params) { - if (inherits(elements$text, "element_blank")) { + if (S7::S7_inherits(elements$text, element_blank)) { return(zeroGrob()) } @@ -267,7 +267,7 @@ GuideAxisTheta <- ggproto( key <- params$key key <- vec_slice(key, !is.na(key$.label) & nzchar(key$.label)) labels <- validate_labels(key$.label) - if (length(labels) == 0 || inherits(elements$text, "element_blank")) { + if (length(labels) == 0 || S7::S7_inherits(elements$text, element_blank)) { return(list(offset = offset)) } @@ -364,7 +364,7 @@ GuideAxisTheta <- ggproto( theta_tickmarks <- function(key, element, length, offset = NULL) { n_breaks <- nrow(key) - if (n_breaks < 1 || inherits(element, "element_blank")) { + if (n_breaks < 1 || S7::S7_inherits(element, element_blank)) { return(zeroGrob()) } diff --git a/R/guide-axis.R b/R/guide-axis.R index 32398bf3bc..4cf00f2a25 100644 --- a/R/guide-axis.R +++ b/R/guide-axis.R @@ -259,10 +259,10 @@ GuideAxis <- ggproto( override_elements = function(params, elements, theme) { elements$text <- label_angle_heuristic(elements$text, params$position, params$angle) - if (inherits(elements$ticks, "element_blank")) { + if (S7::S7_inherits(elements$ticks, element_blank)) { elements$major_length <- unit(0, "cm") } - if (inherits(elements$minor, "element_blank") || isFALSE(params$minor.ticks)) { + if (S7::S7_inherits(elements$minor, element_blank) || isFALSE(params$minor.ticks)) { elements$minor_length <- unit(0, "cm") } return(elements) @@ -379,7 +379,7 @@ GuideAxis <- ggproto( # Ticks major_cm <- convertUnit(elements$major_length, "cm", valueOnly = TRUE) range <- range(0, major_cm) - if (params$minor.ticks && !inherits(elements$minor, "element_blank")) { + if (params$minor.ticks && !S7::S7_inherits(elements$minor, element_blank)) { minor_cm <- convertUnit(elements$minor_length, "cm", valueOnly = TRUE) range <- range(range, minor_cm) } @@ -590,7 +590,7 @@ axis_label_priority_between <- function(x, y) { #' overridden from the user- or theme-supplied element. #' @noRd label_angle_heuristic <- function(element, position, angle) { - if (!inherits(element, "element_text") + if (!S7::S7_inherits(element, element_text) || is.null(position) || is.null(angle %|W|% NULL)) { return(element) diff --git a/R/plot-build.R b/R/plot-build.R index 45cf53571c..40b99d46e5 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -342,7 +342,7 @@ table_add_tag <- function(table, label, theme) { return(table) } element <- calc_element("plot.tag", theme) - if (inherits(element, "element_blank")) { + if (S7::S7_inherits(element, element_blank)) { return(table) } diff --git a/R/theme-elements.R b/R/theme-elements.R index 4118948e07..e8bfba0132 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -861,8 +861,11 @@ check_element <- function(el, elname, element_tree, call = caller_env()) { if ("margin" %in% class) { if (!is.unit(el) && length(el) == 4) cli::cli_abort("The {.var {elname}} theme element must be a {.cls unit} vector of length 4.", call = call) - } else if (!inherits(el, class) && !inherits(el, "element_blank")) { - cli::cli_abort("The {.var {elname}} theme element must be a {.cls {eldef$class}} object.", call = call) + } else if (!inherits(el, class) && !S7::S7_inherits(el, element_blank)) { + if (inherits(class, "S7_class")) { + class <- class@name + } + cli::cli_abort("The {.var {elname}} theme element must be a {.cls {class}} object.", call = call) } invisible() } diff --git a/R/theme.R b/R/theme.R index dd08ceb926..de8a7a5fda 100644 --- a/R/theme.R +++ b/R/theme.R @@ -719,7 +719,7 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, # If result is element_blank, we skip it if `skip_blank` is `TRUE`, # and otherwise we don't inherit anything from parents - if (inherits(el_out, "element_blank")) { + if (S7::S7_inherits(el_out, element_blank)) { if (isTRUE(skip_blank)) { el_out <- NULL } else { @@ -733,9 +733,17 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, # If the element is defined (and not just inherited), check that # it is of the class specified in element_tree - if (!is.null(el_out) && - !inherits(el_out, element_tree[[element]]$class)) { - cli::cli_abort("Theme element {.var {element}} must have class {.cls {ggplot_global$element_tree[[element]]$class}}.", call = call) + if (!is.null(el_out)) { + class <- element_tree[[element]]$class + if (inherits(class, "S7_class")) { + if (!S7::S7_inherits(el_out, class)) { + cli::cli_abort("Theme element {.var {element}} must have class {.cls {class@name}}.", call = call) + } + } else { + if (!inherits(el_out, class)) { + cli::cli_abort("Theme element {.var {element}} must have class {.cls {ggplot_global$element_tree[[element]]$class}}.", call = call) + } + } } # Get the names of parents from the inheritance tree diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 86cb19853f..a9c38f2ed4 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -21,8 +21,8 @@ test_that("modifying theme element properties with + operator works", { # Make sure the theme class didn't change or get dropped expect_true(is.theme(t)) # Make sure the element class didn't change or get dropped - expect_true(inherits(t$axis.title.x, "element")) - expect_true(inherits(t$axis.title.x, "element_text")) + expect_s3_class(t$axis.title.x, "ggplot2::element") + expect_s3_class(t$axis.title.x, "ggplot2::element_text") # Modifying an intermediate node works t <- theme_grey() + theme(axis.title = element_text(colour = 'red')) @@ -346,7 +346,7 @@ test_that("element tree can be modified", { test_that("all elements in complete themes have inherit.blank=TRUE", { inherit_blanks <- function(theme) { all(vapply(theme, function(el) { - if (inherits(el, "element") && !inherits(el, "element_blank")) { + if (inherits(el, "element") && !S7::S7_inherits(el, element_blank)) { el$inherit.blank } else { TRUE @@ -642,7 +642,7 @@ test_that("complete_theme completes a theme", { # Missing elements are filled in if default theme is incomplete new <- complete_theme(default = theme()) - expect_s3_class(new$axis.line, "element_blank") + expect_s3_class(new$axis.line, "ggplot2::element_blank") # Registered elements are included register_theme_elements( @@ -650,7 +650,7 @@ test_that("complete_theme completes a theme", { element_tree = list(test = el_def("element_text", "text")) ) new <- complete_theme(default = gray) - expect_s3_class(new$test, "element_text") + expect_s3_class(new$test, "ggplot2::element_text") reset_theme_settings() }) From 27cdb73660c38647072317bf8331ae502f6b6eeb Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Mar 2025 10:59:55 +0100 Subject: [PATCH 10/58] fix misc issues --- R/guide-.R | 1 + R/guide-legend.R | 4 +++- R/theme-elements.R | 2 +- tests/testthat/test-theme.R | 41 ++++++++++++++++--------------------- 4 files changed, 23 insertions(+), 25 deletions(-) diff --git a/R/guide-.R b/R/guide-.R index 813c722b4a..0b8a339222 100644 --- a/R/guide-.R +++ b/R/guide-.R @@ -376,6 +376,7 @@ Guide <- ggproto( # Renders tickmarks build_ticks = function(key, elements, params, position = params$position, length = elements$ticks_length) { + force(length) if (!is.theme_element(elements)) { elements <- elements$ticks } diff --git a/R/guide-legend.R b/R/guide-legend.R index b37e210a78..5fd148f509 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -690,13 +690,15 @@ keep_key_data <- function(key, data, aes, show) { position_margin <- function(position, margin = NULL, gap = unit(0, "pt")) { margin <- margin %||% margin() - switch( + margin <- switch( position, top = replace(margin, 3, margin[3] + gap), bottom = replace(margin, 1, margin[1] + gap), left = replace(margin, 2, margin[2] + gap), right = replace(margin, 4, margin[4] + gap) ) + class(margin) <- union("margin", class(margin)) + margin } # Function implementing backward compatibility with the old way of specifying diff --git a/R/theme-elements.R b/R/theme-elements.R index e8bfba0132..30cc44100a 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -858,7 +858,7 @@ check_element <- function(el, elname, element_tree, call = caller_env()) { } } - if ("margin" %in% class) { + if (is.character(class) && "margin" %in% class) { if (!is.unit(el) && length(el) == 4) cli::cli_abort("The {.var {elname}} theme element must be a {.cls unit} vector of length 4.", call = call) } else if (!inherits(el, class) && !S7::S7_inherits(el, element_blank)) { diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index a9c38f2ed4..dff6b0dc50 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -142,12 +142,10 @@ test_that("calculating theme element inheritance works", { expect_identical(calc_element('axis.title.x', t), element_blank()) # Check that inheritance from derived class works - element_dummyrect <- function(dummy) { # like element_rect but w/ dummy argument - structure(list( - fill = NULL, colour = NULL, dummy = dummy, linewidth = NULL, - linetype = NULL, inherit.blank = FALSE - ), class = c("element_dummyrect", "element_rect", "element")) - } + element_dummyrect <- S7::new_class( + "element_dummyrect", parent = element_rect, + properties = c(element_rect@properties, list(dummy = S7::class_any)) + ) e <- calc_element( "panel.background", @@ -160,10 +158,10 @@ test_that("calculating theme element inheritance works", { expect_identical( e, - structure(list( + element_dummyrect( fill = "white", colour = "black", dummy = 5, linewidth = 0.5, linetype = 1, inherit.blank = TRUE # this is true because we're requesting a complete theme - ), class = c("element_dummyrect", "element_rect", "element")) + ) ) # Check that blank elements are skipped in inheritance tree if and only if elements @@ -283,9 +281,10 @@ test_that("theme validation happens at build stage", { test_that("incorrect theme specifications throw meaningful errors", { expect_snapshot_error(add_theme(theme_grey(), theme(line = element_rect()))) expect_snapshot_error(calc_element("line", theme(line = element_rect()))) - register_theme_elements(element_tree = list(test = el_def("element_rect"))) + register_theme_elements(element_tree = list(test = el_def(element_rect))) expect_snapshot_error(calc_element("test", theme_gray() + theme(test = element_rect()))) expect_snapshot_error(set_theme("foo")) + reset_theme_settings() }) test_that("element tree can be modified", { @@ -305,7 +304,7 @@ test_that("element tree can be modified", { # things work once we add a new element to the element tree register_theme_elements( - element_tree = list(blablabla = el_def("element_text", "text")) + element_tree = list(blablabla = el_def(element_text, "text")) ) expect_silent(ggplotGrob(p)) @@ -334,13 +333,13 @@ test_that("element tree can be modified", { expect_identical(e1@colour, "red") # not inherited from element_text # existing elements can be overwritten - ed <- el_def("element_rect", "rect") + ed <- el_def(element_rect, "rect") register_theme_elements( element_tree = list(axis.title = ed) ) expect_identical(get_element_tree()$axis.title, ed) - reset_theme_settings(reset_current = FALSE) # revert back to defaults + reset_theme_settings() # revert back to defaults }) test_that("all elements in complete themes have inherit.blank=TRUE", { @@ -424,7 +423,7 @@ test_that("current theme can be updated with new elements", { # element tree gets merged properly register_theme_elements( abcde = element_text(color = "blue", hjust = 0, vjust = 1), - element_tree = list(abcde = el_def("element_text", "text")) + element_tree = list(abcde = el_def(element_text, "text")) ) e1 <- calc_element("abcde", plot_theme(b2)) @@ -647,7 +646,7 @@ test_that("complete_theme completes a theme", { # Registered elements are included register_theme_elements( test = element_text(), - element_tree = list(test = el_def("element_text", "text")) + element_tree = list(test = el_def(element_text, "text")) ) new <- complete_theme(default = gray) expect_s3_class(new$test, "ggplot2::element_text") @@ -959,15 +958,11 @@ test_that("Legends can on all sides of the plot with custom justification", { }) test_that("Strips can render custom elements", { - element_test <- function(...) { - el <- element_text(...) - class(el) <- c('element_test', 'element_text', 'element') - el - } - element_grob.element_test <- function(element, label = "", x = NULL, y = NULL, ...) { - rectGrob(width = unit(1, "cm"), height = unit(1, "cm")) - } - registerS3method("element_grob", "element_test", element_grob.element_test) + element_test <- S7::new_class("element_test", element_text) + S7::method(element_grob, element_test) <- + function(element, label = "", x = NULL, y = NULL, ...) { + rectGrob(width = unit(1, "cm"), height = unit(1, "cm")) + } df <- data_frame(x = 1:3, y = 1:3, a = letters[1:3]) plot <- ggplot(df, aes(x, y)) + From 3bc0d63ebcfbf16a2857a171131c5a564873ebbd Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Mar 2025 15:02:47 +0100 Subject: [PATCH 11/58] Revert "implement `$.element` for backward compatibility" This reverts commit b038e8f633d8526f6e20ee9bf4549634cc38d565. --- NAMESPACE | 6 +++--- R/ggproto.R | 5 ++--- R/theme-elements.R | 8 -------- R/theme.R | 3 +-- 4 files changed, 6 insertions(+), 16 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a88e3f341d..04986e15bb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,8 @@ # Generated by roxygen2: do not edit by hand +S3method("$",ggproto) +S3method("$",ggproto_parent) +S3method("$",theme) S3method("$<-",uneval) S3method("+",gg) S3method("[",mapped_discrete) @@ -13,9 +16,6 @@ S3method(as.data.frame,mapped_discrete) S3method(as.list,ggproto) S3method(autolayer,default) S3method(autoplot,default) -S3method(base::`$`, ggproto) -S3method(base::`$`, ggproto_parent) -S3method(base::`$`, theme) S3method(c,mapped_discrete) S3method(drawDetails,zeroGrob) S3method(format,ggproto) diff --git a/R/ggproto.R b/R/ggproto.R index 3de50401c3..6165a9707d 100644 --- a/R/ggproto.R +++ b/R/ggproto.R @@ -152,8 +152,7 @@ fetch_ggproto <- function(x, name) { } -# Prevents bug described in S7/#390 -#' @rawNamespace S3method(base::`$`, ggproto) +#' @export `$.ggproto` <- function(x, name) { res <- fetch_ggproto(x, name) if (!is.function(res)) { @@ -163,7 +162,7 @@ fetch_ggproto <- function(x, name) { make_proto_method(x, res, name) } -#' @rawNamespace S3method(base::`$`, ggproto_parent) +#' @export `$.ggproto_parent` <- function(x, name) { res <- fetch_ggproto(.subset2(x, "parent"), name) if (!is.function(res)) { diff --git a/R/theme-elements.R b/R/theme-elements.R index 30cc44100a..268457d116 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -83,14 +83,6 @@ NULL #' @rdname element element <- S7::new_class("element", abstract = TRUE) -S7::method(`$`, element) <- - function(x, i) { - if (!S7::prop_exists(x, i)) { - return(NULL) - } - S7::prop(x, i) - } - #' @export #' @rdname element element_blank <- S7::new_class("element_blank", parent = element) diff --git a/R/theme.R b/R/theme.R index de8a7a5fda..609c1eaf4e 100644 --- a/R/theme.R +++ b/R/theme.R @@ -958,8 +958,7 @@ combine_elements <- function(e1, e2) { e1 } -# Prevents bug described in S7/#390 -#' @rawNamespace S3method(base::`$`, theme) +#' @export `$.theme` <- function(x, ...) { .subset2(x, ...) } From 360c97528e6cbf7a8d05dfaa4de21bb1e6fa0606 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Mar 2025 15:41:18 +0100 Subject: [PATCH 12/58] don't rely on `element$prop` --- R/save.R | 4 +++- R/theme.R | 15 +++++++++++---- tests/testthat/test-theme.R | 2 +- 3 files changed, 15 insertions(+), 6 deletions(-) diff --git a/R/save.R b/R/save.R index 5e1ef5983a..7a6184e5ba 100644 --- a/R/save.R +++ b/R/save.R @@ -103,7 +103,9 @@ ggsave <- function(filename, plot = get_last_plot(), limitsize = limitsize, dpi = dpi) if (is_null(bg)) { - bg <- calc_element("plot.background", plot_theme(plot))$fill %||% "transparent" + bg <- calc_element("plot.background", plot_theme(plot)) + bg <- if (S7::prop_exists(bg, "fill")) bg@fill else NULL + bg <- bg %||% "transparent" } old_dev <- grDevices::dev.cur() dev(filename = filename, width = dim[1], height = dim[2], bg = bg, ...) diff --git a/R/theme.R b/R/theme.R index 609c1eaf4e..2df99014f8 100644 --- a/R/theme.R +++ b/R/theme.R @@ -779,15 +779,22 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, # Calculate the parent objects' inheritance if (verbose) cli::cli_inform("{pnames}") + + # once we've started skipping blanks, we continue doing so until the end of the + # recursion; we initiate skipping blanks if we encounter an element that + # doesn't inherit blank. + skip_blank <- skip_blank || + (!is.null(el_out) && + !isTRUE(S7::S7_inherits(el_out) && + S7::prop_exists(el_out, "inherit.blank") && + el_out@inherit.blank)) + parents <- lapply( pnames, calc_element, theme, verbose = verbose, - # once we've started skipping blanks, we continue doing so until the end of the - # recursion; we initiate skipping blanks if we encounter an element that - # doesn't inherit blank. - skip_blank = skip_blank || (!is.null(el_out) && !isTRUE(el_out$inherit.blank)), + skip_blank = skip_blank, call = call ) diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index dff6b0dc50..81674c705d 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -346,7 +346,7 @@ test_that("all elements in complete themes have inherit.blank=TRUE", { inherit_blanks <- function(theme) { all(vapply(theme, function(el) { if (inherits(el, "element") && !S7::S7_inherits(el, element_blank)) { - el$inherit.blank + el@inherit.blank } else { TRUE } From 68fe80bd1ccd8aa48a48528bc365d7259087d5d0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Mar 2025 10:02:07 +0100 Subject: [PATCH 13/58] move element properties --- R/properties.R | 69 ++++------------------------------------------ R/theme-elements.R | 23 +++++++++++++++- 2 files changed, 28 insertions(+), 64 deletions(-) diff --git a/R/properties.R b/R/properties.R index be857393b0..493d787f05 100644 --- a/R/properties.R +++ b/R/properties.R @@ -1,4 +1,3 @@ - property_boolean <- function(allow_null = FALSE, default = TRUE) { class <- S7::class_logical class <- if (allow_null) S7::new_union(class, NULL) else class @@ -38,65 +37,9 @@ property_choice <- function(options, allow_null = FALSE, default = NULL) { ) } -element_props <- list( - fill = S7::new_property( - S7::new_union(S7::class_character, S7::new_S3_class("GridPattern"), S7::class_logical, NULL), - default = NULL - ), - colour = S7::new_property( - S7::new_union(S7::class_character, S7::class_logical, NULL), - default = NULL - ), - family = S7::new_property( - S7::new_union(S7::class_character, NULL), - default = NULL - ), - hjust = S7::new_property( - S7::new_union(S7::class_numeric, NULL), - default = NULL - ), - vjust = S7::new_property( - S7::new_union(S7::class_numeric, NULL), - default = NULL - ), - angle = S7::new_property( - S7::new_union(S7::class_numeric, NULL), - default = NULL - ), - size = S7::new_property( - S7::new_union(S7::class_numeric, NULL), - default = NULL - ), - lineheight = S7::new_property( - S7::new_union(S7::class_numeric, NULL), - default = NULL - ), - margin = S7::new_property( - S7::new_union(S7::new_S3_class("margin"), NULL), - default = NULL - ), - face = property_choice(c("plain", "bold", "italic", "oblique", "bold.italic"), allow_null = TRUE), - linewidth = S7::new_property( - S7::new_union(S7::class_numeric, NULL), - default = NULL - ), - linetype = S7::new_property( - S7::new_union(S7::class_numeric, S7::class_character, NULL), - default = NULL - ), - lineend = property_choice(c("round", "butt", "square"), allow_null = TRUE), - shape = S7::new_property( - S7::new_union(S7::class_numeric, S7::class_character, NULL), - default = NULL - ), - arrow = S7::new_property( - S7::new_union(S7::new_S3_class("arrow"), S7::class_logical, NULL), - default = NULL - ), - arrow.fill = S7::new_property( - S7::new_union(S7::class_character, S7::class_logical, NULL), - default = NULL - ), - debug = property_boolean(allow_null = TRUE, default = NULL), - inherit.blank = property_boolean(default = FALSE) -) +property_nullable <- function(class = S7::class_any, ...) { + S7::new_property( + class = S7::new_union(NULL, class), + ... + ) +} diff --git a/R/theme-elements.R b/R/theme-elements.R index 268457d116..540c19fed9 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -87,7 +87,28 @@ element <- S7::new_class("element", abstract = TRUE) #' @rdname element element_blank <- S7::new_class("element_blank", parent = element) -#' @include properties.R +# All properties are listed here so they can easily be recycled in the different +# element classes +element_props <- list( + fill = property_nullable(S7::class_character | S7::new_S3_class("GridPattern") | S7::class_logical), + colour = property_nullable(S7::class_character | S7::class_logical), + family = property_nullable(S7::class_character), + hjust = property_nullable(S7::class_numeric), + vjust = property_nullable(S7::class_numeric), + angle = property_nullable(S7::class_numeric), + size = property_nullable(S7::class_numeric), + lineheight = property_nullable(S7::class_numeric), + margin = property_nullable(margin), + face = property_choice(c("plain", "bold", "italic", "oblique", "bold.italic"), allow_null = TRUE), + linewidth = property_nullable(S7::class_numeric), + linetype = property_nullable(S7::class_numeric | S7::class_character), + lineend = property_choice(c("round", "butt", "square"), allow_null = TRUE), + shape = property_nullable(S7::class_numeric | S7::class_character), + arrow = property_nullable(S7::new_S3_class("arrow") | S7::class_logical), + arrow.fill = property_nullable(S7::class_character | S7::class_logical), + debug = property_boolean(allow_null = TRUE, default = NULL), + inherit.blank = property_boolean(default = FALSE) +) #' @export #' @rdname element From 8c3471e1adfe97f8dfdcfc50dd80904e5c530dc4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Mar 2025 14:06:24 +0100 Subject: [PATCH 14/58] convert `margin` to S7 --- DESCRIPTION | 2 +- R/geom-label.R | 2 +- R/guide-legend.R | 4 +++- R/margins.R | 22 ++++++++++++++++------ R/properties.R | 13 +++++++++++++ R/theme-elements.R | 3 +++ R/theme.R | 8 ++++---- man/element.Rd | 32 ++++++++++++++++---------------- man/is_tests.Rd | 10 +++++----- 9 files changed, 62 insertions(+), 34 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a632b6fcf6..c734a5f689 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -177,6 +177,7 @@ Collate: 'grob-null.R' 'grouping.R' 'properties.R' + 'margins.R' 'theme-elements.R' 'guide-.R' 'guide-axis.R' @@ -201,7 +202,6 @@ Collate: 'layer-sf.R' 'layout.R' 'limits.R' - 'margins.R' 'performance.R' 'plot-build.R' 'plot-construction.R' diff --git a/R/geom-label.R b/R/geom-label.R index ae21a48df3..73f1d8bedf 100644 --- a/R/geom-label.R +++ b/R/geom-label.R @@ -87,7 +87,7 @@ GeomLabel <- ggproto("GeomLabel", Geom, data <- coord$transform(data, panel_params) data$vjust <- compute_just(data$vjust, data$y, data$x, data$angle) data$hjust <- compute_just(data$hjust, data$x, data$y, data$angle) - if (!is.margin("margin")) { + if (!is.margin(label.padding)) { label.padding <- rep(label.padding, length.out = 4) } diff --git a/R/guide-legend.R b/R/guide-legend.R index 5fd148f509..090dccc0f6 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -697,7 +697,9 @@ position_margin <- function(position, margin = NULL, gap = unit(0, "pt")) { left = replace(margin, 2, margin[2] + gap), right = replace(margin, 4, margin[4] + gap) ) - class(margin) <- union("margin", class(margin)) + # We have to manually reconstitute the class because the 'simpleUnit' class + # might be dropped by the replacement operation. + class(margin) <- c("ggplot2::margin", class(margin), "S7_object") margin } diff --git a/R/margins.R b/R/margins.R index 61ea1dab43..643cc95374 100644 --- a/R/margins.R +++ b/R/margins.R @@ -1,13 +1,23 @@ +#' @include properties.R + #' @param t,r,b,l Dimensions of each margin. (To remember order, think trouble). #' @param unit Default units of dimensions. Defaults to "pt" so it #' can be most easily scaled with the text. #' @rdname element #' @export -margin <- function(t = 0, r = 0, b = 0, l = 0, unit = "pt") { - u <- unit(c(t, r, b, l), unit) - class(u) <- c("margin", class(u)) - u -} +margin <- S7::new_class( + "margin", parent = S7::new_S3_class(c("simpleUnit", "unit", "unit_v2")), + constructor = function(t = 0, r = 0, b = 0, l = 0, unit = "pt") { + u <- unit(c(t, r, b, l), unit) + S7::new_object(u) + }, + properties = list( + top = property_index(1L), + right = property_index(2L), + bottom = property_index(3L), + left = property_index(4L) + ) +) #' @rdname element #' @export @@ -23,7 +33,7 @@ margin_auto <- function(t = 0, r = t, b = t, l = r, unit = "pt") { #' @export #' @rdname is_tests -is.margin <- function(x) inherits(x, "margin") +is.margin <- function(x) S7::S7_inherits(x, margin) #' Create a text grob with the proper location and margins #' diff --git a/R/properties.R b/R/properties.R index 493d787f05..d7df34fd0a 100644 --- a/R/properties.R +++ b/R/properties.R @@ -43,3 +43,16 @@ property_nullable <- function(class = S7::class_any, ...) { ... ) } + +property_index <- function(i) { + force(i) + S7::new_property( + getter = function(self) { + self[i] + }, + setter = function(self, value) { + self[i] <- value + self + } + ) +} diff --git a/R/theme-elements.R b/R/theme-elements.R index 540c19fed9..28b28dca94 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -87,8 +87,11 @@ element <- S7::new_class("element", abstract = TRUE) #' @rdname element element_blank <- S7::new_class("element_blank", parent = element) + # All properties are listed here so they can easily be recycled in the different # element classes +#' @include properties.R +#' @include margins.R element_props <- list( fill = property_nullable(S7::class_character | S7::new_S3_class("GridPattern") | S7::class_logical), colour = property_nullable(S7::class_character | S7::class_logical), diff --git a/R/theme.R b/R/theme.R index 2df99014f8..05cae4be30 100644 --- a/R/theme.R +++ b/R/theme.R @@ -867,7 +867,7 @@ S7::method(merge_element, list(element, S7::class_any)) <- new } -S7::method(merge_element, list(S7::new_S3_class("margin"), S7::class_any)) <- +S7::method(merge_element, list(margin, S7::class_any)) <- function(new, old, ...) { if (is.null(old) || S7::S7_inherits(old, element_blank)) { return(new) @@ -911,7 +911,7 @@ combine_elements <- function(e1, e2) { return(e1) } - if (inherits(e1, "margin") && inherits(e2, "margin")) { + if (is.margin(e1) && is.margin(e2)) { if (anyNA(e2)) { e2[is.na(e2)] <- unit(0, "pt") } @@ -921,7 +921,7 @@ combine_elements <- function(e1, e2) { } # If neither of e1 or e2 are element_* objects, return e1 - if (!S7::S7_inherits(e1, element) && !S7::S7_inherits(e2, element)) { + if (!is.theme_element(e1) && !is.theme_element(e2)) { return(e1) } @@ -949,7 +949,7 @@ combine_elements <- function(e1, e2) { e1@linewidth <- e2@linewidth * unclass(e1@linewidth) } - if (inherits(e1, "element_text")) { + if (S7::S7_inherits(e1, element_text)) { e1@margin <- combine_elements(e1@margin, e2@margin) } diff --git a/man/element.Rd b/man/element.Rd index 72d8c2b601..7bc21e1c74 100644 --- a/man/element.Rd +++ b/man/element.Rd @@ -1,6 +1,9 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/theme-elements.R, R/margins.R -\name{element} +% Please edit documentation in R/margins.R, R/theme-elements.R +\name{margin} +\alias{margin} +\alias{margin_part} +\alias{margin_auto} \alias{element} \alias{element_blank} \alias{element_rect} @@ -10,11 +13,14 @@ \alias{element_point} \alias{element_geom} \alias{rel} -\alias{margin} -\alias{margin_part} -\alias{margin_auto} \title{Theme elements} \usage{ +margin(t = 0, r = 0, b = 0, l = 0, unit = "pt") + +margin_part(t = NA, r = NA, b = NA, l = NA, unit = "pt") + +margin_auto(t = 0, r = t, b = t, l = r, unit = "pt") + element() element_blank() @@ -90,14 +96,13 @@ element_geom( ) rel(x) - -margin(t = 0, r = 0, b = 0, l = 0, unit = "pt") - -margin_part(t = NA, r = NA, b = NA, l = NA, unit = "pt") - -margin_auto(t = 0, r = t, b = t, l = r, unit = "pt") } \arguments{ +\item{t, r, b, l}{Dimensions of each margin. (To remember order, think trouble).} + +\item{unit}{Default units of dimensions. Defaults to "pt" so it +can be most easily scaled with the text.} + \item{fill}{Fill colour. \code{fill_alpha()} can be used to set the transparency of the fill.} @@ -154,11 +159,6 @@ is anchored.} \item{accent}{Accent colour.} \item{x}{A single number specifying size relative to parent element.} - -\item{t, r, b, l}{Dimensions of each margin. (To remember order, think trouble).} - -\item{unit}{Default units of dimensions. Defaults to "pt" so it -can be most easily scaled with the text.} } \value{ An S3 object of class \code{element}, \code{rel}, or \code{margin}. diff --git a/man/is_tests.Rd b/man/is_tests.Rd index bcb7bf0683..10fa48db7a 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/facet-.R, R/stat-.R, R/margins.R, R/theme-elements.R, R/guide-.R, +% R/layer.R, R/guides-.R, R/plot.R, R/position-.R, R/scale-.R, R/theme.R \name{is.ggproto} \alias{is.ggproto} \alias{is.mapping} @@ -10,11 +10,11 @@ \alias{is.Coord} \alias{is.facet} \alias{is.stat} +\alias{is.margin} \alias{is.theme_element} \alias{is.guide} \alias{is.layer} \alias{is.guides} -\alias{is.margin} \alias{is_tests} \alias{is.ggplot} \alias{is.position} @@ -36,6 +36,8 @@ is.facet(x) is.stat(x) +is.margin(x) + is.theme_element(x) is.guide(x) @@ -44,8 +46,6 @@ is.layer(x) is.guides(x) -is.margin(x) - is.ggplot(x) is.position(x) From 9f69323b4b7111ac5a21098830a38e262bc70288 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Mar 2025 15:49:59 +0100 Subject: [PATCH 15/58] I liked index properties as an idea but apparently they print badly --- R/margins.R | 8 +------- R/properties.R | 13 ------------- 2 files changed, 1 insertion(+), 20 deletions(-) diff --git a/R/margins.R b/R/margins.R index 643cc95374..46e075d103 100644 --- a/R/margins.R +++ b/R/margins.R @@ -10,13 +10,7 @@ margin <- S7::new_class( constructor = function(t = 0, r = 0, b = 0, l = 0, unit = "pt") { u <- unit(c(t, r, b, l), unit) S7::new_object(u) - }, - properties = list( - top = property_index(1L), - right = property_index(2L), - bottom = property_index(3L), - left = property_index(4L) - ) + } ) #' @rdname element diff --git a/R/properties.R b/R/properties.R index d7df34fd0a..493d787f05 100644 --- a/R/properties.R +++ b/R/properties.R @@ -43,16 +43,3 @@ property_nullable <- function(class = S7::class_any, ...) { ... ) } - -property_index <- function(i) { - force(i) - S7::new_property( - getter = function(self) { - self[i] - }, - setter = function(self, value) { - self[i] <- value - self - } - ) -} From e4b870b2929bb07a382f40fa733a33bc164c2c7b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Mar 2025 15:55:01 +0100 Subject: [PATCH 16/58] adapt failing example --- R/plot-construction.R | 10 +++++----- man/ggplot_add.Rd | 10 +++++----- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/R/plot-construction.R b/R/plot-construction.R index cd18fc8310..d8d3234be4 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -98,18 +98,18 @@ add_ggplot <- function(p, object, objectname) { #' @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) +#' # in this example, we apply a colour to the plot background +#' ggplot_add.character <- function(object, plot, object_name) { +#' plot + theme(plot.background = element_rect(fill = object)) #' } #' #' # we can now use `+` to add our object to a plot #' ggplot(mpg, aes(displ, cty)) + #' geom_point() + -#' element_text(colour = "red") +#' "cornsilk" #' #' # clean-up -#' rm(ggplot_add.element_text) +#' rm(ggplot_add.character) ggplot_add <- function(object, plot, object_name) { UseMethod("ggplot_add") } diff --git a/man/ggplot_add.Rd b/man/ggplot_add.Rd index c71d6f863e..2584ba7602 100644 --- a/man/ggplot_add.Rd +++ b/man/ggplot_add.Rd @@ -32,17 +32,17 @@ 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) +# in this example, we apply a colour to the plot background +ggplot_add.character <- function(object, plot, object_name) { + plot + theme(plot.background = element_rect(fill = object)) } # we can now use `+` to add our object to a plot ggplot(mpg, aes(displ, cty)) + geom_point() + - element_text(colour = "red") + "cornsilk" # clean-up -rm(ggplot_add.element_text) +rm(ggplot_add.character) } \keyword{internal} 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 17/58] 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 18/58] 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 19/58] 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 20/58] 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 21/58] 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 22/58] 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 23/58] 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 24/58] 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 25/58] 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 26/58] 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 27/58] 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 28/58] 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 29/58] 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 30/58] 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 31/58] 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 32/58] 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 33/58] 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 34/58] 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 35/58] 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 36/58] 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 37/58] 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 38/58] 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 39/58] 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 40/58] 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 41/58] 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 42/58] 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 43/58] 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 44/58] 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 b2f143ed80d11858b8a998756223d6c7aa57386a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 1 Apr 2025 16:53:43 +0200 Subject: [PATCH 45/58] backport `@` --- NAMESPACE | 1 + R/backports.R | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 99c6e874c6..3725f12aac 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -752,6 +752,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 98fb83efe8c7d891f501f1e8b43f7492f7b68193 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 16 Apr 2025 11:14:25 +0200 Subject: [PATCH 46/58] S7-aware `is_theme_element()` --- R/coord-sf.R | 2 +- R/guide-axis-theta.R | 6 +++--- R/guide-axis.R | 8 +++---- R/plot-build.R | 2 +- R/theme-elements.R | 43 ++++++++++++++++++------------------- R/theme.R | 20 ++++++++--------- man/is_tests.Rd | 2 +- tests/testthat/test-theme.R | 2 +- 8 files changed, 42 insertions(+), 43 deletions(-) diff --git a/R/coord-sf.R b/R/coord-sf.R index 0bcfafa4c3..63e5ed4a26 100644 --- a/R/coord-sf.R +++ b/R/coord-sf.R @@ -334,7 +334,7 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, # we don't draw the graticules if the major panel grid is # turned off - if (S7::S7_inherits(el, element_blank)) { + if (is_theme_element(el, "blank")) { grobs <- list(element_render(theme, "panel.background")) } else { line_gp <- gg_par( diff --git a/R/guide-axis-theta.R b/R/guide-axis-theta.R index b67026662b..b75528d347 100644 --- a/R/guide-axis-theta.R +++ b/R/guide-axis-theta.R @@ -184,7 +184,7 @@ GuideAxisTheta <- ggproto( build_labels = function(key, elements, params) { - if (S7::S7_inherits(elements$text, element_blank)) { + if (is_theme_element(elements$text, "blank")) { return(zeroGrob()) } @@ -268,7 +268,7 @@ GuideAxisTheta <- ggproto( key <- params$key key <- vec_slice(key, !is.na(key$.label) & nzchar(key$.label)) labels <- validate_labels(key$.label) - if (length(labels) == 0 || S7::S7_inherits(elements$text, element_blank)) { + if (length(labels) == 0 || is_theme_element(elements$text, "blank")) { return(list(offset = offset)) } @@ -365,7 +365,7 @@ GuideAxisTheta <- ggproto( theta_tickmarks <- function(key, element, length, offset = NULL) { n_breaks <- nrow(key) - if (n_breaks < 1 || S7::S7_inherits(element, element_blank)) { + if (n_breaks < 1 || is_theme_element(element, "blank")) { return(zeroGrob()) } diff --git a/R/guide-axis.R b/R/guide-axis.R index 4cf00f2a25..03dffcaebd 100644 --- a/R/guide-axis.R +++ b/R/guide-axis.R @@ -259,10 +259,10 @@ GuideAxis <- ggproto( override_elements = function(params, elements, theme) { elements$text <- label_angle_heuristic(elements$text, params$position, params$angle) - if (S7::S7_inherits(elements$ticks, element_blank)) { + if (is_theme_element(elements$ticks, "blank")) { elements$major_length <- unit(0, "cm") } - if (S7::S7_inherits(elements$minor, element_blank) || isFALSE(params$minor.ticks)) { + if (is_theme_element(elements$minor, "blank") || isFALSE(params$minor.ticks)) { elements$minor_length <- unit(0, "cm") } return(elements) @@ -379,7 +379,7 @@ GuideAxis <- ggproto( # Ticks major_cm <- convertUnit(elements$major_length, "cm", valueOnly = TRUE) range <- range(0, major_cm) - if (params$minor.ticks && !S7::S7_inherits(elements$minor, element_blank)) { + if (params$minor.ticks && !is_theme_element(elements$minor, "blank")) { minor_cm <- convertUnit(elements$minor_length, "cm", valueOnly = TRUE) range <- range(range, minor_cm) } @@ -590,7 +590,7 @@ axis_label_priority_between <- function(x, y) { #' overridden from the user- or theme-supplied element. #' @noRd label_angle_heuristic <- function(element, position, angle) { - if (!S7::S7_inherits(element, element_text) + if (!is_theme_element(element, "text") || is.null(position) || is.null(angle %|W|% NULL)) { return(element) diff --git a/R/plot-build.R b/R/plot-build.R index 2901f8d57e..e09134fe21 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -348,7 +348,7 @@ table_add_tag <- function(table, label, theme) { return(table) } element <- calc_element("plot.tag", theme) - if (S7::S7_inherits(element, element_blank)) { + if (is_theme_element(element, "blank")) { return(table) } diff --git a/R/theme-elements.R b/R/theme-elements.R index 39319c9352..15751c5319 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -207,25 +207,6 @@ element_text <- S7::new_class( } ) -#' @export -#' @param type For testing elements: the type of element to expect. One of -#' `"blank"`, `"rect"`, `"line"` or `"text"`. -#' @rdname is_tests -is_theme_element <- function(x, type = "any") { - switch( - type %||% "any", - any = inherits(x, "element"), - rect = inherits(x, "element_rect"), - line = inherits(x, "element_line"), - text = inherits(x, "element_text"), - blank = inherits(x, "element_blank"), - # TODO: ideally we accept more elements from extensions. We need to - # consider how this will work with S7 classes, where ggplot2 doesn't know - # about the extension's class objects. - FALSE - ) -} - #' @export #' @rdname element element_polygon <- S7::new_class( @@ -322,6 +303,25 @@ element_geom <- S7::new_class( #' @export print.element <- function(x, ...) utils::str(x) +#' @export +#' @param type For testing elements: the type of element to expect. One of +#' `"blank"`, `"rect"`, `"line"`, `"text"`, `"polygon"`, `"point"` or `"geom"`. +#' @rdname is_tests +is_theme_element <- function(x, type = "any") { + switch( + type %||% "any", + any = S7::S7_inherits(x, element), + blank = S7::S7_inherits(x, element_blank), + rect = S7::S7_inherits(x, element_rect), + line = S7::S7_inherits(x, element_line), + text = S7::S7_inherits(x, element_text), + polygon = S7::S7_inherits(x, element_polygon), + point = S7::S7_inherits(x, element_point), + geom = S7::S7_inherits(x, element_geom), + FALSE + ) +} + #' @param x A single number specifying size relative to parent element. #' @rdname element #' @export @@ -890,8 +890,7 @@ check_element <- function(el, elname, element_tree, call = caller_env()) { if (is.null(el)) return() class <- eldef$class if (inherits(class, "S7_class") && S7::S7_inherits(el)) { - if (S7::S7_inherits(el, class) || - (S7::S7_inherits(el, element) && S7::S7_inherits(el, element_blank))) { + if (S7::S7_inherits(el, class) || is_theme_element(el, "blank")) { return() } } @@ -899,7 +898,7 @@ check_element <- function(el, elname, element_tree, call = caller_env()) { if (is.character(class) && "margin" %in% class) { if (!is.unit(el) && length(el) == 4) cli::cli_abort("The {.var {elname}} theme element must be a {.cls unit} vector of length 4.", call = call) - } else if (!inherits(el, class) && !S7::S7_inherits(el, element_blank)) { + } else if (!inherits(el, class) && !is_theme_element(el, "blank")) { if (inherits(class, "S7_class")) { class <- class@name } diff --git a/R/theme.R b/R/theme.R index 128707107e..18f3bf76e4 100644 --- a/R/theme.R +++ b/R/theme.R @@ -751,7 +751,7 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, # If result is element_blank, we skip it if `skip_blank` is `TRUE`, # and otherwise we don't inherit anything from parents - if (S7::S7_inherits(el_out, element_blank)) { + if (is_theme_element(el_out, "blank")) { if (isTRUE(skip_blank)) { el_out <- NULL } else { @@ -786,7 +786,7 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, if (verbose) cli::cli_inform("nothing (top level)") # Check that all the properties of this element are non-NULL - if (inherits(el_out, "ggplot2::element")) { + if (is_theme_element(el_out)) { nullprops <- lengths(S7::props(el_out)) == 0 } else { nullprops <- vapply(el_out, is.null, logical(1)) @@ -797,12 +797,12 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, # if we have null properties, try to fill in from ggplot_global$theme_default el_out <- combine_elements(el_out, ggplot_global$theme_default[[element]]) - if (is.theme_element(el_out)) { + if (is_theme_element(el_out)) { nullprops <- lengths(S7::props(el_out)) == 0 } else { nullprops <- vapply(el_out, is.null, logical(1)) } - if (S7::S7_inherits(el_out, element_geom)) { + if (is_theme_element(el_out, "geom")) { # Geom elements are expected to have NULL fill/colour, so allow these # to be missing nullprops[c("colour", "fill")] <- FALSE @@ -861,7 +861,7 @@ merge_element <- S7::new_generic("merge_element", c("new", "old")) S7::method(merge_element, list(S7::class_any, S7::class_any)) <- function(new, old, ...) { - if (is.null(old) || S7::S7_inherits(old, element_blank)) { + if (is.null(old) || is_theme_element(old, "blank")) { # If old is NULL or element_blank, then just return new return(new) } else if (is.null(new) || is.character(new) || is.numeric(new) || is.unit(new) || @@ -882,7 +882,7 @@ S7::method(merge_element, list(element_blank, S7::class_any)) <- S7::method(merge_element, list(element, S7::class_any)) <- function(new, old, ...) { - if (is.null(old) || S7::S7_inherits(old, element_blank)) { + if (is.null(old) || is_theme_element(old, "blank")) { # If old is NULL or element_blank, then just return new return(new) } @@ -906,7 +906,7 @@ S7::method(merge_element, list(element, S7::class_any)) <- S7::method(merge_element, list(margin, S7::class_any)) <- function(new, old, ...) { - if (is.null(old) || S7::S7_inherits(old, element_blank)) { + if (is.null(old) || is_theme_element(old, "blank")) { return(new) } if (anyNA(new)) { @@ -925,7 +925,7 @@ S7::method(merge_element, list(margin, S7::class_any)) <- combine_elements <- function(e1, e2) { # If e2 is NULL, nothing to inherit - if (is.null(e2) || S7::S7_inherits(e1, element_blank)) { + if (is.null(e2) || is_theme_element(e1, "blank")) { return(e1) } @@ -948,7 +948,7 @@ combine_elements <- function(e1, e2) { return(e1) } - if (is.margin(e1) && is.margin(e2)) { + if (is_margin(e1) && is_margin(e2)) { if (anyNA(e2)) { e2[is.na(e2)] <- unit(0, "pt") } @@ -986,7 +986,7 @@ combine_elements <- function(e1, e2) { e1@linewidth <- e2@linewidth * unclass(e1@linewidth) } - if (S7::S7_inherits(e1, element_text)) { + if (is_theme_element(e1, "text")) { e1@margin <- combine_elements(e1@margin, e2@margin) } diff --git a/man/is_tests.Rd b/man/is_tests.Rd index 801ca7db0c..c3c0630915 100644 --- a/man/is_tests.Rd +++ b/man/is_tests.Rd @@ -70,7 +70,7 @@ is.theme(x) # Deprecated \item{x}{An object to test} \item{type}{For testing elements: the type of element to expect. One of -\code{"blank"}, \code{"rect"}, \code{"line"} or \code{"text"}.} +\code{"blank"}, \code{"rect"}, \code{"line"}, \code{"text"}, \code{"polygon"}, \code{"point"} or \code{"geom"}.} } \description{ Reports wether \code{x} is a type of object diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 8c1c6787b8..8000d25946 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -345,7 +345,7 @@ test_that("element tree can be modified", { test_that("all elements in complete themes have inherit.blank=TRUE", { inherit_blanks <- function(theme) { all(vapply(theme, function(el) { - if (is_theme_element(el) && !is_theme_element(el, "blank")) { + if (is_theme_element(el) && S7::prop_exists(el, "inherit.blank")) { el@inherit.blank } else { TRUE From f56a504923f7c96a9250485d24b1f55cdee64f57 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 16 Apr 2025 12:56:59 +0200 Subject: [PATCH 47/58] utility for grabbing props --- R/save.R | 3 +-- R/theme.R | 13 +++++-------- R/utilities.R | 10 ++++++++++ tests/testthat/test-theme.R | 12 +++++------- 4 files changed, 21 insertions(+), 17 deletions(-) diff --git a/R/save.R b/R/save.R index e0d63131af..4ebf9dae3e 100644 --- a/R/save.R +++ b/R/save.R @@ -245,8 +245,7 @@ get_plot_background <- function(plot, bg = NULL, default = "transparent") { return(default) } bg <- calc_element("plot.background", plot_theme(plot)) - bg <- if (S7::prop_exists(bg, "fill")) bg@fill else NULL - bg %||% "transparent" + try_prop(bg, "fill") %||% "transparent" } validate_device <- function(device, filename = NULL, dpi = 300, call = caller_env()) { diff --git a/R/theme.R b/R/theme.R index 18f3bf76e4..3270ded02c 100644 --- a/R/theme.R +++ b/R/theme.R @@ -821,10 +821,7 @@ calc_element <- function(element, theme, verbose = FALSE, skip_blank = FALSE, # recursion; we initiate skipping blanks if we encounter an element that # doesn't inherit blank. skip_blank <- skip_blank || - (!is.null(el_out) && - !isTRUE(S7::S7_inherits(el_out) && - S7::prop_exists(el_out, "inherit.blank") && - el_out@inherit.blank)) + (!is.null(el_out) && !isTRUE(try_prop(el_out, "inherit.blank"))) parents <- lapply( pnames, @@ -964,8 +961,8 @@ combine_elements <- function(e1, e2) { # If e2 is element_blank, and e1 inherits blank inherit everything from e2, # otherwise ignore e2 - if (S7::S7_inherits(e2, element_blank)) { - if (S7::prop_exists(e1, "inherit.blank") && e1@inherit.blank) { + if (is_theme_element(e2, "blank")) { + if (isTRUE(try_prop(e1, "inherit.blank"))) { return(e2) } else { return(e1) @@ -977,12 +974,12 @@ combine_elements <- function(e1, e2) { S7::props(e1)[n] <- S7::props(e2)[n] # Calculate relative sizes - if (S7::prop_exists(e1, "size") && is.rel(e1@size)) { + if (is.rel(try_prop(e1, "size"))) { e1@size <- e2@size * unclass(e1@size) } # Calculate relative linewidth - if (S7::prop_exists(e1, "linewidth") && is.rel(e1@linewidth)) { + if (is.rel(try_prop(e1, "linewidth"))) { e1@linewidth <- e2@linewidth * unclass(e1@linewidth) } diff --git a/R/utilities.R b/R/utilities.R index ff623df1a8..df642f3182 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -959,3 +959,13 @@ compute_data_size <- function(data, size, default = 0.9, data[[target]] <- res * (default %||% 0.9) data } + +try_prop <- function(object, name, default = NULL) { + if (!S7::S7_inherits(object)) { + return(default) + } + if (!S7::prop_exists(object, name)) { + return(default) + } + S7::prop(object, name) +} diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 8000d25946..e83f69c521 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -344,13 +344,11 @@ test_that("element tree can be modified", { test_that("all elements in complete themes have inherit.blank=TRUE", { inherit_blanks <- function(theme) { - all(vapply(theme, function(el) { - if (is_theme_element(el) && S7::prop_exists(el, "inherit.blank")) { - el@inherit.blank - } else { - TRUE - } - }, logical(1))) + all(vapply( + theme, try_prop, + name = "inherit.blank", default = TRUE, + logical(1) + )) } expect_true(inherit_blanks(theme_grey())) expect_true(inherit_blanks(theme_bw())) From a7756357e9d46ff6627d90a5157a48e1d0a1cce1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 16 Apr 2025 12:58:50 +0200 Subject: [PATCH 48/58] use classic extractors and subassignment --- NAMESPACE | 6 ++++++ R/theme-elements.R | 39 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 45 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 3fa5bc812b..4d09ba2414 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,15 +1,21 @@ # Generated by roxygen2: do not edit by hand +S3method("$","ggplot2::element") S3method("$",ggproto) S3method("$",ggproto_parent) S3method("$",theme) +S3method("$<-","ggplot2::element") S3method("$<-",uneval) S3method("+",gg) +S3method("[","ggplot2::element") S3method("[",mapped_discrete) S3method("[",uneval) +S3method("[<-","ggplot2::element") S3method("[<-",mapped_discrete) S3method("[<-",uneval) +S3method("[[","ggplot2::element") S3method("[[",ggproto) +S3method("[[<-","ggplot2::element") S3method("[[<-",uneval) S3method(.DollarNames,ggproto) S3method(as.data.frame,mapped_discrete) diff --git a/R/theme-elements.R b/R/theme-elements.R index 15751c5319..5efad37745 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -329,6 +329,45 @@ rel <- function(x) { structure(x, class = "rel") } +#' @export +`$.ggplot2::element` <- function(x, i) { + # deprecate_soft0("4.0.0", I("`$i`"), I("`@i`")) + `[[`(S7::props(x), i) +} + +#' @export +`[.ggplot2::element` <- function(x, i) { + # deprecate_soft0("4.0.0", I("`[i]`"), I("`S7::props(, i)`")) + `[`(S7::props(x), i) +} + +#' @export +`[[.ggplot2::element` <- function(x, i) { + # deprecate_soft0("4.0.0", I("`[[i]]`"), I("`S7::prop(, i)`")) + `[[`(S7::props(x), i) +} + +#' @export +`$<-.ggplot2::element` <- function(x, i, value) { + # deprecate_soft0("4.0.0", I("`$i <- value`"), I("`@i <- value`")) + S7::props(x) <- `[[<-`(S7::props(x), i, value) + x +} + +#' @export +`[<-.ggplot2::element` <- function(x, i, value) { + # deprecate_soft0("4.0.0", I("`[i] <- value`"), I("`S7::props()[i] <- value`")) + S7::props(x) <- `[<-`(S7::props(x), i, value) + x +} + +#' @export +`[[<-.ggplot2::element` <- function(x, i, value) { + # deprecate_soft0("4.0.0", I("`[[i]] <- value`"), I("S7::prop(, i) <- value")) + S7::props(x) <- `[[<-`(S7::props(x), i, value) + x +} + #' @export print.rel <- function(x, ...) print(noquote(paste(x, " *", sep = ""))) From b38f3e523f92ba47d39e509ab271627d20cad8b5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 16 Apr 2025 13:14:02 +0200 Subject: [PATCH 49/58] fallback for `register_theme_elements()` --- R/theme-elements.R | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/R/theme-elements.R b/R/theme-elements.R index 5efad37745..7cddb0afd4 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -692,6 +692,27 @@ check_element_tree <- function(x, arg = caller_arg(x), call = caller_env()) { #' @keywords internal #' @export el_def <- function(class = NULL, inherit = NULL, description = NULL) { + if (is.character(class) && length(class) == 1) { + # Swap S3 class name for S7 class object + class <- switch( + class, + element = element, + element_blank = element_blank, + element_rect = element_rect, + element_line = element_line, + element_text = element_text, + element_polygon = element_polygon, + element_point = element_point, + element_geom = element_geom, + margin = margin, + class + ) + } + # margins often occur in c("unit", "margin", "rel"), we cannot use the + # S7 class here because we don't support heterogeneous lists + if (is.character(class) && length(class) > 1) { + class[class == "margin"] <- "ggplot2::margin" + } list(class = class, inherit = inherit, description = description) } From aa14c8811073485d46b0d992b2dd838a3451d96b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 16 Apr 2025 14:37:31 +0200 Subject: [PATCH 50/58] contingencies for `inherits(x, )` on old R versions --- R/theme-elements.R | 37 ++++++++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/R/theme-elements.R b/R/theme-elements.R index 7cddb0afd4..a8d99e6466 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -948,21 +948,36 @@ check_element <- function(el, elname, element_tree, call = caller_env()) { # NULL values for elements are OK if (is.null(el)) return() + class <- eldef$class - if (inherits(class, "S7_class") && S7::S7_inherits(el)) { - if (S7::S7_inherits(el, class) || is_theme_element(el, "blank")) { + if (inherits(class, "S7_class")) { + inherit_ok <- S7::S7_inherits(el, class) + } else { + inherit_ok <- inherits(el, class) + } + + if (is.character(class) && any(c("margin", "ggplot2::margin") %in% class)) { + if ("rel" %in% class && is.rel(el)) { return() } + if (is.unit(el) && length(el) == 4) { + return() + } + cli::cli_abort( + "The {.var {elname}} theme element must be a {.cls unit} vector of length 4", + call = call + ) } - if (is.character(class) && "margin" %in% class) { - if (!is.unit(el) && length(el) == 4) - cli::cli_abort("The {.var {elname}} theme element must be a {.cls unit} vector of length 4.", call = call) - } else if (!inherits(el, class) && !is_theme_element(el, "blank")) { - if (inherits(class, "S7_class")) { - class <- class@name - } - cli::cli_abort("The {.var {elname}} theme element must be a {.cls {class}} object.", call = call) + # Maybe we should check that `class` is an element class before approving of + # blank elements? + if (inherit_ok || is_theme_element(el, "blank")) { + return() } - invisible() + + class_name <- if (inherits(class, "S7_class")) class@name else class + cli::cli_abort( + "The {.var {elname}} theme element must be a {.cls {class_name}} object.", + call = call + ) } 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 51/58] 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 52/58] 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) From fcfdc6940b1358fa8ab3e0872806cf30734d2882 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 14 May 2025 09:14:19 +0200 Subject: [PATCH 53/58] bump staged deprecations --- R/theme-elements.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/theme-elements.R b/R/theme-elements.R index a8d99e6466..b2f37dc37d 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -331,39 +331,39 @@ rel <- function(x) { #' @export `$.ggplot2::element` <- function(x, i) { - # deprecate_soft0("4.0.0", I("`$i`"), I("`@i`")) + # deprecate_soft0("4.1.0", I("`$i`"), I("`@i`")) `[[`(S7::props(x), i) } #' @export `[.ggplot2::element` <- function(x, i) { - # deprecate_soft0("4.0.0", I("`[i]`"), I("`S7::props(, i)`")) + # deprecate_soft0("4.1.0", I("`[i]`"), I("`S7::props(, i)`")) `[`(S7::props(x), i) } #' @export `[[.ggplot2::element` <- function(x, i) { - # deprecate_soft0("4.0.0", I("`[[i]]`"), I("`S7::prop(, i)`")) + # deprecate_soft0("4.1.0", I("`[[i]]`"), I("`S7::prop(, i)`")) `[[`(S7::props(x), i) } #' @export `$<-.ggplot2::element` <- function(x, i, value) { - # deprecate_soft0("4.0.0", I("`$i <- value`"), I("`@i <- value`")) + # deprecate_soft0("4.1.0", I("`$i <- value`"), I("`@i <- value`")) S7::props(x) <- `[[<-`(S7::props(x), i, value) x } #' @export `[<-.ggplot2::element` <- function(x, i, value) { - # deprecate_soft0("4.0.0", I("`[i] <- value`"), I("`S7::props()[i] <- value`")) + # deprecate_soft0("4.1.0", I("`[i] <- value`"), I("`S7::props()[i] <- value`")) S7::props(x) <- `[<-`(S7::props(x), i, value) x } #' @export `[[<-.ggplot2::element` <- function(x, i, value) { - # deprecate_soft0("4.0.0", I("`[[i]] <- value`"), I("S7::prop(, i) <- value")) + # deprecate_soft0("4.1.0", I("`[[i]] <- value`"), I("S7::prop(, i) <- value")) S7::props(x) <- `[[<-`(S7::props(x), i, value) x } From 924b8b64a52e6e905300199c2655761120f12d81 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 14 May 2025 09:25:21 +0200 Subject: [PATCH 54/58] add linejoins --- R/theme-defaults.R | 15 +++++++------- R/theme-elements.R | 49 ++++++++++++++++++++++++++++------------------ 2 files changed, 38 insertions(+), 26 deletions(-) diff --git a/R/theme-defaults.R b/R/theme-defaults.R index 6f32012cd0..1646ffcdc9 100644 --- a/R/theme-defaults.R +++ b/R/theme-defaults.R @@ -127,11 +127,12 @@ theme_grey <- function(base_size = 11, base_family = "", # by others line = element_line( colour = ink, linewidth = base_line_size, - linetype = 1, lineend = "butt" + linetype = 1, lineend = "butt", linejoin = "round" ), rect = element_rect( fill = paper, colour = ink, - linewidth = base_rect_size, linetype = 1 + linewidth = base_rect_size, linetype = 1, + linejoin = "round" ), text = element_text( family = base_family, face = "plain", @@ -153,7 +154,7 @@ theme_grey <- function(base_size = 11, base_family = "", polygon = element_polygon( fill = paper, colour = ink, - linewidth = base_rect_size, linetype = 1 + linewidth = base_rect_size, linetype = 1, linejoin = "round" ), geom = element_geom( @@ -525,7 +526,7 @@ theme_void <- function(base_size = 11, base_family = "", line = element_blank(), rect = element_rect( fill = paper, colour = NA, linewidth = 0, linetype = 1, - inherit.blank = FALSE + inherit.blank = FALSE, linejoin = "round" ), polygon = element_blank(), point = element_blank(), @@ -614,11 +615,11 @@ theme_test <- function(base_size = 11, base_family = "", t <- theme( line = element_line( colour = ink, linewidth = base_line_size, - linetype = 1, lineend = "butt" + linetype = 1, lineend = "butt", linejoin = "round" ), rect = element_rect( fill = paper, colour = ink, - linewidth = base_rect_size, linetype = 1 + linewidth = base_rect_size, linetype = 1, linejoin = "round" ), text = element_text( family = base_family, face = "plain", @@ -633,7 +634,7 @@ theme_test <- function(base_size = 11, base_family = "", ), polygon = element_polygon( fill = paper, colour = ink, - linewidth = base_rect_size, linetype = 1 + linewidth = base_rect_size, linetype = 1, linejoin = "round" ), title = element_text(family = header_family), spacing = unit(half_line, "pt"), diff --git a/R/theme-elements.R b/R/theme-elements.R index b2f37dc37d..650fd6567b 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -105,6 +105,7 @@ element_props <- list( linewidth = property_nullable(S7::class_numeric), linetype = property_nullable(S7::class_numeric | S7::class_character), lineend = property_choice(c("round", "butt", "square"), allow_null = TRUE), + linejoin = property_choice(c("round", "mitre", "bevel"), allow_null = TRUE), shape = property_nullable(S7::class_numeric | S7::class_character), arrow = property_nullable(S7::new_S3_class("arrow") | S7::class_logical), arrow.fill = property_nullable(S7::class_character | S7::class_logical), @@ -116,10 +117,12 @@ element_props <- list( #' @rdname element element_rect <- S7::new_class( "element_rect", parent = element, - properties = element_props[c("fill", "colour", "linewidth", "linetype", "inherit.blank")], + properties = element_props[c("fill", "colour", + "linewidth", "linetype", "linejoin", + "inherit.blank")], constructor = function(fill = NULL, colour = NULL, linewidth = NULL, - linetype = NULL, color = NULL, inherit.blank = FALSE, - size = deprecated()){ + linetype = NULL, color = NULL, linejoin = NULL, + inherit.blank = FALSE, size = deprecated()){ if (lifecycle::is_present(size)) { deprecate_warn0("3.4.0", "element_rect(size)", "element_rect(linewidth)") linewidth <- size @@ -127,7 +130,7 @@ element_rect <- S7::new_class( S7::new_object( S7::S7_object(), fill = fill, colour = color %||% colour, - linewidth = linewidth, linetype = linetype, + linewidth = linewidth, linetype = linetype, linejoin = linejoin, inherit.blank = inherit.blank ) } @@ -140,12 +143,14 @@ element_rect <- S7::new_class( element_line <- S7::new_class( "element_line", parent = element, properties = element_props[c( - "colour", "linewidth", "linetype", "lineend", "arrow", "arrow.fill", + "colour", "linewidth", "linetype", "lineend", "linejoin", + "arrow", "arrow.fill", "inherit.blank" )], constructor = function(colour = NULL, linewidth = NULL, linetype = NULL, - lineend = NULL, color = NULL, arrow = NULL, - arrow.fill = NULL, inherit.blank = FALSE, size = deprecated()) { + lineend = NULL, color = NULL, linejoin = NULL, + arrow = NULL, arrow.fill = NULL, + inherit.blank = FALSE, size = deprecated()) { if (lifecycle::is_present(size)) { deprecate_warn0("3.4.0", "element_line(size)", "element_line(linewidth)") linewidth <- size @@ -155,6 +160,7 @@ element_line <- S7::new_class( S7::S7_object(), colour = colour, linewidth = linewidth, linetype = linetype, lineend = lineend, + linejoin = linejoin, arrow = arrow %||% FALSE, arrow.fill = arrow.fill %||% colour, inherit.blank = inherit.blank @@ -212,15 +218,16 @@ element_text <- S7::new_class( element_polygon <- S7::new_class( "element_polygon", parent = element, properties = element_props[c( - "fill", "colour", "linewidth", "linetype", "inherit.blank" + "fill", "colour", "linewidth", "linetype", "linejoin", "inherit.blank" )], constructor = function(fill = NULL, colour = NULL, linewidth = NULL, - linetype = NULL, color = NULL, inherit.blank = FALSE) { + linetype = NULL, color = NULL, linejoin = NULL, + inherit.blank = FALSE) { colour <- color %||% colour S7::new_object( S7::S7_object(), fill = fill, colour = color %||% colour, linewidth = linewidth, - linetype = linetype, inherit.blank = inherit.blank + linetype = linetype, linejoin = linejoin, inherit.blank = inherit.blank ) } ) @@ -412,7 +419,8 @@ S7::method(element_grob, element_blank) <- function(element, ...) zeroGrob() S7::method(element_grob, element_rect) <- function(element, x = 0.5, y = 0.5, width = 1, height = 1, - fill = NULL, colour = NULL, linewidth = NULL, linetype = NULL, + fill = NULL, colour = NULL, + linewidth = NULL, linetype = NULL, linejoin = NULL, ..., size = deprecated()) { if (lifecycle::is_present(size)) { @@ -420,9 +428,10 @@ S7::method(element_grob, element_rect) <- linewidth <- size } - gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype) + gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype, linejoin = linejoin) element_gp <- gg_par(lwd = element@linewidth, col = element@colour, - fill = element@fill, lty = element@linetype) + fill = element@fill, lty = element@linetype, + linejoin = element@linejoin) rectGrob(x, y, width, height, gp = modify_list(element_gp, gp), ...) } @@ -458,7 +467,7 @@ S7::method(element_grob, element_text) <- S7::method(element_grob, element_line) <- function(element, x = 0:1, y = 0:1, colour = NULL, linewidth = NULL, linetype = NULL, lineend = NULL, - arrow.fill = NULL, + linejoin = NULL, arrow.fill = NULL, default.units = "npc", id.lengths = NULL, ..., size = deprecated()) { if (lifecycle::is_present(size)) { @@ -479,12 +488,12 @@ S7::method(element_grob, element_line) <- # The gp settings can override element_gp gp <- gg_par( col = colour, fill = arrow.fill %||% colour, - lwd = linewidth, lty = linetype, lineend = lineend + lwd = linewidth, lty = linetype, lineend = lineend, linejoin = linejoin ) element_gp <- gg_par( col = element@colour, fill = element@arrow.fill %||% element@colour, lwd = element@linewidth, lty = element@linetype, - lineend = element@lineend + lineend = element@lineend, linejoin = element@linejoin ) polylineGrob( @@ -498,13 +507,15 @@ S7::method(element_grob, element_polygon) <- function(element, x = c(0, 0.5, 1, 0.5), y = c(0.5, 1, 0.5, 0), fill = NULL, colour = NULL, linewidth = NULL, - linetype = NULL, ..., + linetype = NULL, linejoin = NULL, ..., id = NULL, id.lengths = NULL, pathId = NULL, pathId.lengths = NULL) { - gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype) + gp <- gg_par(lwd = linewidth, col = colour, fill = fill, + lty = linetype, linejoin = linejoin) element_gp <- gg_par(lwd = element@linewidth, col = element@colour, - fill = element@fill, lty = element@linetype) + fill = element@fill, lty = element@linetype, + linejoin = element@linejoin) pathGrob( x = x, y = y, gp = modify_list(element_gp, gp), ..., # We swap the id logic so that `id` is always the (super)group id From 6eb226453bd559945d567af6f61b9046d4d305be Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 14 May 2025 09:30:21 +0200 Subject: [PATCH 55/58] Disable `ggtext::element_markdown()` example --- vignettes/articles/faq-axes.Rmd | 3 +++ 1 file changed, 3 insertions(+) diff --git a/vignettes/articles/faq-axes.Rmd b/vignettes/articles/faq-axes.Rmd index cf88240cfa..1f08b48dce 100644 --- a/vignettes/articles/faq-axes.Rmd +++ b/vignettes/articles/faq-axes.Rmd @@ -444,6 +444,8 @@ ggplot(mpg, aes(x = cty^2, y = log(hwy, base = 10))) + ) ``` + From 759555652d99e67f8a286d9003b7ddb71569b2ea Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 14 May 2025 09:51:03 +0200 Subject: [PATCH 56/58] fix failing tests --- tests/testthat/_snaps/theme.md | 2 +- tests/testthat/test-theme.R | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index 5f416bd544..2a3f1044b5 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -34,7 +34,7 @@ --- - Theme element `test` has `NULL` property without default: fill, colour, linewidth, and linetype. + Theme element `test` has `NULL` property without default: fill, colour, linewidth, linetype, and linejoin. --- diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index e83f69c521..2ff7630e49 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -150,7 +150,7 @@ test_that("calculating theme element inheritance works", { e <- calc_element( "panel.background", theme( - rect = element_rect(fill = "white", colour = "black", linewidth = 0.5, linetype = 1), + rect = element_rect(fill = "white", colour = "black", linewidth = 0.5, linetype = 1, linejoin = "round"), panel.background = element_dummyrect(dummy = 5), complete = TRUE # need to prevent pulling in default theme ) @@ -159,7 +159,7 @@ test_that("calculating theme element inheritance works", { expect_identical( e, element_dummyrect( - fill = "white", colour = "black", dummy = 5, linewidth = 0.5, linetype = 1, + fill = "white", colour = "black", dummy = 5, linewidth = 0.5, linetype = 1, linejoin = "round", inherit.blank = TRUE # this is true because we're requesting a complete theme ) ) From 5797664cc05a0d18161cc92bbdd386a405afbb8e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 14 May 2025 11:00:48 +0200 Subject: [PATCH 57/58] redocument --- R/theme-elements.R | 3 ++- man/element.Rd | 7 ++++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/R/theme-elements.R b/R/theme-elements.R index 650fd6567b..0698bb12dd 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -138,7 +138,8 @@ element_rect <- S7::new_class( #' @export #' @rdname element -#' @param lineend Line end Line end style (round, butt, square) +#' @param linejoin Line join style, one of `"round"`, `"mitre"` or `"bevel"`. +#' @param lineend Line end style, one of `"round"`, `"butt"` or `"square"`. #' @param arrow Arrow specification, as created by [grid::arrow()] element_line <- S7::new_class( "element_line", parent = element, diff --git a/man/element.Rd b/man/element.Rd index d5c0f10e60..92046f8267 100644 --- a/man/element.Rd +++ b/man/element.Rd @@ -31,6 +31,7 @@ element_rect( linewidth = NULL, linetype = NULL, color = NULL, + linejoin = NULL, inherit.blank = FALSE, size = deprecated() ) @@ -41,6 +42,7 @@ element_line( linetype = NULL, lineend = NULL, color = NULL, + linejoin = NULL, arrow = NULL, arrow.fill = NULL, inherit.blank = FALSE, @@ -68,6 +70,7 @@ element_polygon( linewidth = NULL, linetype = NULL, color = NULL, + linejoin = NULL, inherit.blank = FALSE ) @@ -119,6 +122,8 @@ integer (0:8), a name (blank, solid, dashed, dotted, dotdash, longdash, twodash), or a string with an even number (up to eight) of hexadecimal digits which give the lengths in consecutive positions in the string.} +\item{linejoin}{Line join style, one of \code{"round"}, \code{"mitre"} or \code{"bevel"}.} + \item{inherit.blank}{Should this element inherit the existence of an \code{element_blank} among its parents? If \code{TRUE} the existence of a blank element among its parents will cause this element to be blank as @@ -127,7 +132,7 @@ calculating final element state.} \item{size, fontsize, pointsize}{text size in pts, point size in mm.} -\item{lineend}{Line end Line end style (round, butt, square)} +\item{lineend}{Line end style, one of \code{"round"}, \code{"butt"} or \code{"square"}.} \item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}} From 4b7a189b28c759b7f314c7fb82cb43e36e048ac9 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Wed, 14 May 2025 11:35:33 +0200 Subject: [PATCH 58/58] fix doc links --- R/plot-construction.R | 2 +- R/theme-current.R | 2 +- R/theme.R | 2 +- man/get_theme.Rd | 2 +- man/ggplot_add.Rd | 2 +- man/theme.Rd | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/R/plot-construction.R b/R/plot-construction.R index 47c1fc17f4..5d9b550812 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -96,7 +96,7 @@ add_ggplot <- function(p, object, objectname) { #' Add custom objects to ggplot #' #' This generic allows you to add your own methods for adding custom objects to -#' a ggplot with [+.gg]. +#' a ggplot with [+.gg][add_gg]. #' #' @param object An object to add to the plot #' @param plot The ggplot object to add `object` to diff --git a/R/theme-current.R b/R/theme-current.R index c6848c7d76..e42f8c1e68 100644 --- a/R/theme-current.R +++ b/R/theme-current.R @@ -40,7 +40,7 @@ NULL #' @return `set_theme()`, `update_theme()`, and `replace_theme()` #' invisibly return the previous theme so you can easily save it, then #' later restore it. -#' @seealso [+.gg()] +#' @seealso [add_gg()] #' @export #' @examples #' p <- ggplot(mtcars, aes(mpg, wt)) + diff --git a/R/theme.R b/R/theme.R index c2b802cb0f..5f5121d4fd 100644 --- a/R/theme.R +++ b/R/theme.R @@ -217,7 +217,7 @@ #' @param validate `TRUE` to run `check_element()`, `FALSE` to bypass checks. #' @export #' @seealso -#' [+.gg()] and [%+replace%], +#' [add_gg()] and [%+replace%], #' [element_blank()], [element_line()], #' [element_rect()], and [element_text()] for #' details of the specific theme elements. diff --git a/man/get_theme.Rd b/man/get_theme.Rd index d3283d0e67..d8198c4197 100644 --- a/man/get_theme.Rd +++ b/man/get_theme.Rd @@ -120,5 +120,5 @@ rep_el$text } \seealso{ -\code{\link[=+.gg]{+.gg()}} +\code{\link[=add_gg]{add_gg()}} } diff --git a/man/ggplot_add.Rd b/man/ggplot_add.Rd index c0b8d9d535..d1133d26e2 100644 --- a/man/ggplot_add.Rd +++ b/man/ggplot_add.Rd @@ -16,7 +16,7 @@ A modified ggplot object } \description{ This generic allows you to add your own methods for adding custom objects to -a ggplot with \link{+.gg}. +a ggplot with \link[=add_gg]{+.gg}. } \details{ Custom methods for \code{ggplot_add()} are intended to update the \code{plot} variable diff --git a/man/theme.Rd b/man/theme.Rd index 2766a3f8ca..f2a9bdf33f 100644 --- a/man/theme.Rd +++ b/man/theme.Rd @@ -519,7 +519,7 @@ p3 + theme(panel.spacing = unit(1, "lines")) } } \seealso{ -\code{\link[=+.gg]{+.gg()}} and \link{\%+replace\%}, +\code{\link[=add_gg]{add_gg()}} and \link{\%+replace\%}, \code{\link[=element_blank]{element_blank()}}, \code{\link[=element_line]{element_line()}}, \code{\link[=element_rect]{element_rect()}}, and \code{\link[=element_text]{element_text()}} for details of the specific theme elements.