From 97260f6a3ed9e298e842c13165b2ea40a1591db3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 5 Sep 2024 20:58:38 +0200 Subject: [PATCH 1/7] New `Coord$aesthetics` field for position aesthetics --- R/coord-.R | 6 ++++-- R/plot-build.R | 4 +++- R/scales-.R | 5 +++-- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/R/coord-.R b/R/coord-.R index 0d0bb5ecb9..39007aa739 100644 --- a/R/coord-.R +++ b/R/coord-.R @@ -59,6 +59,8 @@ Coord <- ggproto("Coord", # "on" = yes, "off" = no clip = "on", + aesthetics = c("x", "y"), + aspect = function(ranges) NULL, labels = function(self, labels, panel_params) { @@ -98,7 +100,7 @@ Coord <- ggproto("Coord", }, setup_panel_guides = function(self, panel_params, guides, params = list()) { - aesthetics <- c("x", "y", "x.sec", "y.sec") + aesthetics <- c(self$aesthetics, paste0(self$aesthetics, ".sec")) names(aesthetics) <- aesthetics is_sec <- grepl("sec$", aesthetics) scales <- panel_params[aesthetics] @@ -146,7 +148,7 @@ Coord <- ggproto("Coord", train_panel_guides = function(self, panel_params, layers, params = list()) { - aesthetics <- c("x", "y", "x.sec", "y.sec") + aesthetics <- c(self$aesthetics, paste0(self$aesthetics, ".sec")) # If the panel_params doesn't contain the scale, there's no guide for the aesthetic aesthetics <- intersect(aesthetics, names(panel_params$guides$aesthetics)) diff --git a/R/plot-build.R b/R/plot-build.R index 36f33616fd..ae989146aa 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -70,6 +70,8 @@ ggplot_build.ggplot <- function(plot) { # and all positions are numeric scale_x <- function() scales$get_scales("x") scale_y <- function() scales$get_scales("y") + pos_aes <- layout$coord$aesthetics %||% c("x", "y") + pos_aes <- vec_set_names(pos_aes, pos_aes) layout$train_position(data, scale_x(), scale_y()) data <- layout$map_position(data) @@ -80,7 +82,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(pos_aes, 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") diff --git a/R/scales-.R b/R/scales-.R index e62eb0e8cb..e2853a1fe9 100644 --- a/R/scales-.R +++ b/R/scales-.R @@ -51,8 +51,9 @@ ScalesList <- ggproto("ScalesList", NULL, ggproto(NULL, self, scales = lapply(self$scales, function(s) s$clone())) }, - non_position_scales = function(self) { - ggproto(NULL, self, scales = self$scales[!self$find("x") & !self$find("y")]) + non_position_scales = function(self, positions = c("x", "y")) { + keep <- Reduce(`&`, lapply(positions, function(aes) !self$find(aes))) + ggproto(NULL, self, scales = self$scales[keep]) }, get_scales = function(self, output) { From be81d2c085ea652057f8fc0ae40fd5532e44f60a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 5 Sep 2024 21:03:15 +0200 Subject: [PATCH 2/7] facet methods take 1 list of scales --- R/facet-.R | 12 ++++++------ R/facet-null.R | 2 +- R/facet-wrap.R | 2 +- R/layout.R | 9 +++------ 4 files changed, 11 insertions(+), 14 deletions(-) diff --git a/R/facet-.R b/R/facet-.R index 2e349f6f97..828698bd7f 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -94,7 +94,7 @@ Facet <- ggproto("Facet", NULL, scales <- list() if (!is.null(x_scale)) { scales$x <- lapply(seq_len(max(layout$SCALE_X)), function(i) x_scale$clone()) - } + } if (!is.null(y_scale)) { scales$y <- lapply(seq_len(max(layout$SCALE_Y)), function(i) y_scale$clone()) } @@ -127,13 +127,13 @@ Facet <- ggproto("Facet", NULL, } } }, - draw_back = function(data, layout, x_scales, y_scales, theme, params) { + draw_back = function(data, layout, scales, theme, params) { rep(list(zeroGrob()), vec_unique_count(layout$PANEL)) }, - draw_front = function(data, layout, x_scales, y_scales, theme, params) { + draw_front = function(data, layout, scales, theme, params) { rep(list(zeroGrob()), vec_unique_count(layout$PANEL)) }, - draw_panels = function(self, panels, layout, x_scales = NULL, y_scales = NULL, + draw_panels = function(self, panels, layout, scales = NULL, ranges, coord, data = NULL, theme, params) { free <- params$free %||% list(x = FALSE, y = FALSE) @@ -163,7 +163,7 @@ Facet <- ggproto("Facet", NULL, table <- self$attach_axes(table, layout, ranges, coord, theme, params) self$attach_strips(table, layout, params, theme) }, - draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels, params) { + draw_labels = function(panels, layout, scales, ranges, coord, data, theme, labels, params) { panel_dim <- find_panel(panels) xlab_height_top <- grobHeight(labels$x[[1]]) @@ -197,7 +197,7 @@ Facet <- ggproto("Facet", NULL, setup_data = function(data, params) { data }, - finish_data = function(data, layout, x_scales, y_scales, params) { + finish_data = function(data, layout, scales, params) { data }, init_gtable = function(panels, layout, theme, ranges, params, diff --git a/R/facet-null.R b/R/facet-null.R index c66f39fa03..9f294fab14 100644 --- a/R/facet-null.R +++ b/R/facet-null.R @@ -39,7 +39,7 @@ FacetNull <- ggproto("FacetNull", Facet, data$PANEL <- factor(1) data }, - draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { + draw_panels = function(panels, layout, scales, ranges, coord, data, theme, params) { range <- ranges[[1]] diff --git a/R/facet-wrap.R b/R/facet-wrap.R index 8564f319b7..a7d14c9c64 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -451,7 +451,7 @@ FacetWrap <- ggproto("FacetWrap", Facet, table }, - draw_panels = function(self, panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) { + draw_panels = function(self, panels, layout, scales, ranges, coord, data, theme, params) { if (inherits(coord, "CoordFlip")) { if (params$free$x) { layout$SCALE_X <- seq_len(nrow(layout)) diff --git a/R/layout.R b/R/layout.R index 1b578111b2..95bf991658 100644 --- a/R/layout.R +++ b/R/layout.R @@ -29,8 +29,7 @@ Layout <- ggproto("Layout", NULL, layout = NULL, # Per panel scales and params - panel_scales_x = NULL, - panel_scales_y = NULL, + panel_scales = NULL, panel_params = NULL, setup = function(self, data, plot_data = data_frame0(), plot_env = emptyenv()) { @@ -62,16 +61,14 @@ Layout <- ggproto("Layout", NULL, render = function(self, panels, data, theme, labels) { facet_bg <- self$facet$draw_back(data, self$layout, - self$panel_scales_x, - self$panel_scales_y, + self$panel_scales, theme, self$facet_params ) facet_fg <- self$facet$draw_front( data, self$layout, - self$panel_scales_x, - self$panel_scales_y, + self$panel_scales, theme, self$facet_params ) From 1105aa9b82c36fc1a7b0d4d2596e4e3d5b3fc064 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 5 Sep 2024 21:05:23 +0200 Subject: [PATCH 3/7] layout carries panel_scales list instead of x/y lists --- R/layout.R | 48 +++++++++++++++++++++++------------------------- 1 file changed, 23 insertions(+), 25 deletions(-) diff --git a/R/layout.R b/R/layout.R index 95bf991658..6bd6bdb230 100644 --- a/R/layout.R +++ b/R/layout.R @@ -83,8 +83,7 @@ Layout <- ggproto("Layout", NULL, plot_table <- self$facet$draw_panels( panels, self$layout, - self$panel_scales_x, - self$panel_scales_y, + self$panel_scales, self$panel_params, self$coord, data, @@ -94,18 +93,14 @@ Layout <- ggproto("Layout", NULL, # Draw individual labels, then add to gtable labels <- self$coord$labels( - list( - x = self$resolve_label(self$panel_scales_x[[1]], labels), - y = self$resolve_label(self$panel_scales_y[[1]], labels) - ), + lapply(lapply(self$panel_scales, `[[`, 1), self$resolve_label, labels), self$panel_params[[1]] ) labels <- self$render_labels(labels, theme) self$facet$draw_labels( plot_table, self$layout, - self$panel_scales_x, - self$panel_scales_y, + self$panel_scales, self$panel_params, self$coord, data, @@ -121,7 +116,7 @@ Layout <- ggproto("Layout", NULL, if (is.null(self$panel_scales_x)) { self$panel_scales_x <- self$facet$init_scales(layout, x_scale = x_scale, params = self$facet_params)$x - } + } if (is.null(self$panel_scales_y)) { self$panel_scales_y <- self$facet$init_scales(layout, y_scale = y_scale, params = self$facet_params)$y @@ -142,8 +137,8 @@ Layout <- ggproto("Layout", NULL, lapply(data, function(layer_data) { match_id <- NULL - # Loop through each variable, mapping across each scale, then joining - # back together + # Loop through each variable, mapping across each scale, then joining + # back together x_vars <- intersect(self$panel_scales_x[[1]]$aesthetics, names(layer_data)) if (length(x_vars) > 0) { match_id <- match(layer_data$PANEL, layout$PANEL) @@ -170,49 +165,52 @@ Layout <- ggproto("Layout", NULL, reset_scales = function(self) { if (!self$facet$shrink) return() - lapply(self$panel_scales_x, function(s) s$reset()) - lapply(self$panel_scales_y, function(s) s$reset()) + lapply(self$panel_scales, lapply, function(s) s$reset()) invisible() }, finish_data = function(self, data) { lapply(data, self$facet$finish_data, layout = self$layout, - x_scales = self$panel_scales_x, - y_scales = self$panel_scales_y, + scales = self$panel_scales, params = self$facet_params ) }, get_scales = function(self, i) { this_panel <- self$layout[self$layout$PANEL == i, ] + aesthetics <- self$coord$aesthetics - list( - x = self$panel_scales_x[[this_panel$SCALE_X]], - y = self$panel_scales_y[[this_panel$SCALE_Y]] + lapply( + vec_set_names(aesthetics, aesthetics), + function(aes) { + self$panel_scales[[aes]][[this_panel[[paste0("SCALE_", to_upper_ascii(aes))]]]] + } ) }, setup_panel_params = function(self) { # Fudge for CoordFlip and CoordPolar - in place modification of # scales is not elegant, but it is pragmatic - self$coord$modify_scales(self$panel_scales_x, self$panel_scales_y) + self$coord$modify_scales(self$panel_scales) # We only need to setup panel params once for unique combinations of x/y # scales. These will be repeated for duplicated combinations. index <- vec_unique_loc(self$layout$COORD) order <- vec_match(self$layout$COORD, self$layout$COORD[index]) - scales_x <- self$panel_scales_x[self$layout$SCALE_X[index]] - scales_y <- self$panel_scales_y[self$layout$SCALE_Y[index]] + scales <- vector("list", length(index)) + for (aes in self$coord$aesthetics) { + idx <- self$layout[[paste0("SCALE_", to_upper_ascii(aes))]][index] + for (i in seq_along(idx)) { + scales[[i]][[aes]] <- self$panel_scales[[aes]][[idx[i]]] + } + } self$panel_params <- Map( - self$coord$setup_panel_params, - scales_x, scales_y, + self$coord$setup_panel_params, scales, MoreArgs = list(params = self$coord_params) )[order] # `[order]` does the repeating - - invisible() }, setup_panel_guides = function(self, guides, layers) { From a35cfd9b977ecebbf6a6882bc71bdb5b69e71c94 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 5 Sep 2024 21:06:01 +0200 Subject: [PATCH 4/7] fix scale initialisation and training --- R/facet-.R | 39 ++++++++++++++------------------------- R/layout.R | 47 ++++++++++++++++++++--------------------------- R/plot-build.R | 11 ++++++----- 3 files changed, 40 insertions(+), 57 deletions(-) diff --git a/R/facet-.R b/R/facet-.R index 828698bd7f..f88201f4cc 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -90,40 +90,29 @@ Facet <- ggproto("Facet", NULL, map_data = function(data, layout, params) { cli::cli_abort("Not implemented.") }, - init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { - scales <- list() - if (!is.null(x_scale)) { - scales$x <- lapply(seq_len(max(layout$SCALE_X)), function(i) x_scale$clone()) + init_scales = function(layout, scales, params) { + for (aes in names(scales)) { + if (is.null(scales[[aes]])) { + next } - if (!is.null(y_scale)) { - scales$y <- lapply(seq_len(max(layout$SCALE_Y)), function(i) y_scale$clone()) + n <- max(layout[[paste0("SCALE_", to_upper_ascii(aes))]]) + scales[[aes]] <- lapply(seq_len(n), function(i) scales[[aes]]$clone()) } scales }, - train_scales = function(x_scales, y_scales, layout, data, params) { + train_scales = function(scales, layout, data, params) { # loop over each layer, training x and y scales in turn for (layer_data in data) { match_id <- NULL - if (!is.null(x_scales)) { - x_vars <- intersect(x_scales[[1]]$aesthetics, names(layer_data)) - if (length(x_vars) > 0) { - match_id <- match(layer_data$PANEL, layout$PANEL) - SCALE_X <- layout$SCALE_X[match_id] - scale_apply(layer_data, x_vars, "train", SCALE_X, x_scales) - } - } - - if (!is.null(y_scales)) { - y_vars <- intersect(y_scales[[1]]$aesthetics, names(layer_data)) - if (length(y_vars) > 0) { - if (is.null(match_id)) { - match_id <- match(layer_data$PANEL, layout$PANEL) - } - SCALE_Y <- layout$SCALE_Y[match_id] - - scale_apply(layer_data, y_vars, "train", SCALE_Y, y_scales) + for (aes in names(scales)) { + vars <- intersect(scales[[aes]][[1]]$aesthetics, names(layer_data)) + if (length(vars) < 1) { + next } + match_id <- match_id %||% match(layer_data$PANEL, layout$PANEL) + SCALE <- layout[[paste0("SCALE_", to_upper_ascii(aes))]][match_id] + scale_apply(layer_data, vars, "train", SCALE, scales[[aes]]) } } }, diff --git a/R/layout.R b/R/layout.R index 6bd6bdb230..67792c6e99 100644 --- a/R/layout.R +++ b/R/layout.R @@ -110,21 +110,21 @@ Layout <- ggproto("Layout", NULL, ) }, - train_position = function(self, data, x_scale, y_scale) { + train_position = function(self, data, scales) { # Initialise scales if needed, and possible. + aesthetics <- self$coord$aesthetics %||% c("x", "y") layout <- self$layout - if (is.null(self$panel_scales_x)) { - self$panel_scales_x <- self$facet$init_scales(layout, x_scale = x_scale, - params = self$facet_params)$x + + for (aes in aesthetics) { + if (is.null(self$panel_scales[[aes]])) { + self$panel_scales[aes] <- self$facet$init_scales( + layout, scales[aes], params = self$facet_params + ) } - if (is.null(self$panel_scales_y)) { - self$panel_scales_y <- self$facet$init_scales(layout, y_scale = y_scale, - params = self$facet_params)$y } self$facet$train_scales( - self$panel_scales_x, - self$panel_scales_y, + self$panel_scales, layout, data, self$facet_params @@ -133,30 +133,23 @@ Layout <- ggproto("Layout", NULL, map_position = function(self, data) { layout <- self$layout + aesthetics <- self$coord$aesthetics lapply(data, function(layer_data) { match_id <- NULL + for (aes in aesthetics) { + vars <- intersect(self$panel_scales[[aes]][[1]]$aesthetics, names(layer_data)) + if (length(vars) < 1) { + next + } # Loop through each variable, mapping across each scale, then joining # back together - x_vars <- intersect(self$panel_scales_x[[1]]$aesthetics, names(layer_data)) - if (length(x_vars) > 0) { - match_id <- match(layer_data$PANEL, layout$PANEL) - names(x_vars) <- x_vars - SCALE_X <- layout$SCALE_X[match_id] - new_x <- scale_apply(layer_data, x_vars, "map", SCALE_X, self$panel_scales_x) - layer_data[, x_vars] <- new_x - } - - y_vars <- intersect(self$panel_scales_y[[1]]$aesthetics, names(layer_data)) - if (length(y_vars) > 0) { - if (is.null(match_id)) { - match_id <- match(layer_data$PANEL, layout$PANEL) - } - names(y_vars) <- y_vars - SCALE_Y <- layout$SCALE_Y[match_id] - new_y <- scale_apply(layer_data, y_vars, "map", SCALE_Y, self$panel_scales_y) - layer_data[, y_vars] <- new_y + match_id <- match_id %||% match(layer_data$PANEL, layout$PANEL) + names(vars) <- vars + SCALE <- layout[[paste0("SCALE_", to_upper_ascii(aes))]][match_id] + new <- scale_apply(layer_data, vars, "map", SCALE, self$panel_scales[[aes]]) + layer_data[, vars] <- new } layer_data diff --git a/R/plot-build.R b/R/plot-build.R index ae989146aa..354fc8426d 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -68,12 +68,13 @@ ggplot_build.ggplot <- function(plot) { # Map and train positions so that statistics have access to ranges # and all positions are numeric - scale_x <- function() scales$get_scales("x") - scale_y <- function() scales$get_scales("y") pos_aes <- layout$coord$aesthetics %||% c("x", "y") pos_aes <- vec_set_names(pos_aes, pos_aes) + pos_scales <- lapply(pos_aes, function(aes) { + function() scales$get_scales(aes) + }) - layout$train_position(data, scale_x(), scale_y()) + layout$train_position(data, lapply(pos_scales, function(f) f())) data <- layout$map_position(data) data <- .expose_data(data) @@ -95,7 +96,7 @@ ggplot_build.ggplot <- function(plot) { # displayed, or does it include the range of underlying data data <- .ignore_data(data) layout$reset_scales() - layout$train_position(data, scale_x(), scale_y()) + layout$train_position(data, lapply(pos_scales, function(f) f())) layout$setup_panel_params() data <- layout$map_position(data) @@ -106,7 +107,7 @@ ggplot_build.ggplot <- function(plot) { plot$theme <- plot_theme(plot) # Train and map non-position scales and guides - npscales <- scales$non_position_scales() + npscales <- scales$non_position_scales(pos_aes) if (npscales$n() > 0) { lapply(data, npscales$train_df) plot$guides <- plot$guides$build(npscales, plot$layers, plot$labels, data, plot$theme) From 7e225a664b6a744e300b4b6ba7ece77d43aeee0f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 5 Sep 2024 21:06:22 +0200 Subject: [PATCH 5/7] adapt coord methods --- R/coord-.R | 12 ++++-------- R/coord-cartesian-.R | 6 +++--- R/coord-flip.R | 9 ++++----- R/coord-map.R | 8 ++++---- R/coord-polar.R | 14 +++++++------- R/coord-radial.R | 14 +++++++------- R/coord-sf.R | 18 +++++++++--------- R/coord-transform.R | 6 +++--- 8 files changed, 41 insertions(+), 46 deletions(-) diff --git a/R/coord-.R b/R/coord-.R index 39007aa739..381a8a8824 100644 --- a/R/coord-.R +++ b/R/coord-.R @@ -95,7 +95,7 @@ Coord <- ggproto("Coord", cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn range} method.") }, - setup_panel_params = function(scale_x, scale_y, params = list()) { + setup_panel_params = function(scales, params = list()) { list() }, @@ -121,12 +121,8 @@ Coord <- ggproto("Coord", guide = guide_position[!is_sec], scale = scale_position[!is_sec] ) - opposite <- c( - "top" = "bottom", "bottom" = "top", - "left" = "right", "right" = "left" - ) guide_position[is_sec] <- Map( - function(sec, prim) sec %|W|% unname(opposite[prim]), + function(sec, prim) sec %|W|% opposite_position(prim %||% "top"), sec = guide_position[is_sec], prim = guide_position[!is_sec] ) @@ -202,14 +198,14 @@ Coord <- ggproto("Coord", # We're appending a COORD variable to the layout that determines the # uniqueness of panel parameters. The layout uses this to prevent redundant # setups of these parameters. - scales <- layout[c("SCALE_X", "SCALE_Y")] + scales <- layout[grep("^SCALE_", names(layout), value = TRUE)] layout$COORD <- vec_match(scales, unique0(scales)) layout }, # Optionally, modify list of x and y scales in place. Currently # used as a fudge for CoordFlip and CoordPolar - modify_scales = function(scales_x, scales_y) { + modify_scales = function(...) { invisible() }, diff --git a/R/coord-cartesian-.R b/R/coord-cartesian-.R index 885918c3d1..d36f5ec368 100644 --- a/R/coord-cartesian-.R +++ b/R/coord-cartesian-.R @@ -102,10 +102,10 @@ CoordCartesian <- ggproto("CoordCartesian", Coord, transform_position(data, squish_infinite, squish_infinite) }, - setup_panel_params = function(self, scale_x, scale_y, params = list()) { + setup_panel_params = function(self, scales, params = list()) { c( - view_scales_from_scale(scale_x, self$limits$x, params$expand[c(4, 2)]), - view_scales_from_scale(scale_y, self$limits$y, params$expand[c(3, 1)]) + view_scales_from_scale(scales$x, self$limits$x, params$expand[c(4, 2)]), + view_scales_from_scale(scales$y, self$limits$y, params$expand[c(3, 1)]) ) }, diff --git a/R/coord-flip.R b/R/coord-flip.R index 502ff56f88..4e075c4e8f 100644 --- a/R/coord-flip.R +++ b/R/coord-flip.R @@ -88,10 +88,10 @@ CoordFlip <- ggproto("CoordFlip", CoordCartesian, list(x = un_flipped_range$y, y = un_flipped_range$x) }, - setup_panel_params = function(self, scale_x, scale_y, params = list()) { + setup_panel_params = function(self, scales, params = list()) { params$expand <- params$expand[c(2, 1, 4, 3)] parent <- ggproto_parent(CoordCartesian, self) - panel_params <- parent$setup_panel_params(scale_x, scale_y, params) + panel_params <- parent$setup_panel_params(scales, params) flip_axis_labels(panel_params) }, @@ -106,9 +106,8 @@ CoordFlip <- ggproto("CoordFlip", CoordCartesian, layout }, - modify_scales = function(scales_x, scales_y) { - lapply(scales_x, scale_flip_axis) - lapply(scales_y, scale_flip_axis) + modify_scales = function(scales) { + lapply(scales, lapply, scale_flip_axis) } ) diff --git a/R/coord-map.R b/R/coord-map.R index d300d33dce..36b26b061f 100644 --- a/R/coord-map.R +++ b/R/coord-map.R @@ -190,12 +190,12 @@ CoordMap <- ggproto("CoordMap", Coord, diff(ranges$y.proj) / diff(ranges$x.proj) }, - setup_panel_params = function(self, scale_x, scale_y, params = list()) { + setup_panel_params = function(self, scales, params = list()) { # range in scale ranges <- list() for (n in c("x", "y")) { - scale <- get(paste0("scale_", n)) + scale <- scales[[n]] limits <- self$limits[[n]] range <- expand_limits_scale(scale, default_expansion(scale), coord_limits = limits) ranges[[n]] <- range @@ -217,7 +217,7 @@ CoordMap <- ggproto("CoordMap", Coord, ret$y$proj <- proj[3:4] for (n in c("x", "y")) { - out <- get(paste0("scale_", n))$break_info(ranges[[n]]) + out <- scales[[n]]$break_info(ranges[[n]]) ret[[n]]$range <- out$range ret[[n]]$major <- out$major_source ret[[n]]$minor <- out$minor_source @@ -230,7 +230,7 @@ CoordMap <- ggproto("CoordMap", Coord, x.proj = ret$x$proj, y.proj = ret$y$proj, x.major = ret$x$major, x.minor = ret$x$minor, x.labels = ret$x$labels, y.major = ret$y$major, y.minor = ret$y$minor, y.labels = ret$y$labels, - x.arrange = scale_x$axis_order(), y.arrange = scale_y$axis_order() + x.arrange = scales$x$axis_order(), y.arrange = scales$y$axis_order() ) details }, diff --git a/R/coord-polar.R b/R/coord-polar.R index f1c8108ddf..455833dd06 100644 --- a/R/coord-polar.R +++ b/R/coord-polar.R @@ -111,12 +111,12 @@ CoordPolar <- ggproto("CoordPolar", Coord, ) }, - setup_panel_params = function(self, scale_x, scale_y, params = list()) { + setup_panel_params = function(self, scales, params = list()) { ret <- list(x = list(), y = list()) for (n in c("x", "y")) { - scale <- get(paste0("scale_", n)) + scale <- scales[[n]] limits <- self$limits[[n]] if (self$theta == n) { @@ -151,11 +151,11 @@ CoordPolar <- ggproto("CoordPolar", Coord, if (self$theta == "y") { names(details) <- gsub("x\\.", "r.", names(details)) names(details) <- gsub("y\\.", "theta.", names(details)) - details$r.arrange <- scale_x$axis_order() + details$r.arrange <- scales[["x"]]$axis_order() } else { names(details) <- gsub("x\\.", "theta.", names(details)) names(details) <- gsub("y\\.", "r.", names(details)) - details$r.arrange <- scale_y$axis_order() + details$r.arrange <- scales[["y"]]$axis_order() } details @@ -309,12 +309,12 @@ CoordPolar <- ggproto("CoordPolar", Coord, } }, - modify_scales = function(self, scales_x, scales_y) { + modify_scales = function(self, scales) { if (self$theta != "y") return() - lapply(scales_x, scale_flip_position) - lapply(scales_y, scale_flip_position) + lapply(scales$x, scale_flip_position) + lapply(scales$y, scale_flip_position) } ) diff --git a/R/coord-radial.R b/R/coord-radial.R index 3a5ccf1ee2..4189dd421d 100644 --- a/R/coord-radial.R +++ b/R/coord-radial.R @@ -135,18 +135,18 @@ CoordRadial <- ggproto("CoordRadial", Coord, ) }, - setup_panel_params = function(self, scale_x, scale_y, params = list()) { + setup_panel_params = function(self, scales, params = list()) { params <- c( - view_scales_polar(scale_x, self$theta, expand = params$expand[c(4, 2)]), - view_scales_polar(scale_y, self$theta, expand = params$expand[c(3, 1)]), + view_scales_polar(scales$x, self$theta, expand = params$expand[c(4, 2)]), + view_scales_polar(scales$y, self$theta, expand = params$expand[c(3, 1)]), list(bbox = polar_bbox(self$arc, inner_radius = self$inner_radius), arc = self$arc, inner_radius = self$inner_radius) ) axis_rotation <- self$r_axis_inside if (is.numeric(axis_rotation)) { - theta_scale <- switch(self$theta, x = scale_x, y = scale_y) + theta_scale <- switch(self$theta, x = scales$x, y = scales$y) axis_rotation <- theta_scale$transform(axis_rotation) axis_rotation <- oob_squish(axis_rotation, params$theta.range) axis_rotation <- theta_rescale( @@ -459,12 +459,12 @@ CoordRadial <- ggproto("CoordRadial", Coord, labels }, - modify_scales = function(self, scales_x, scales_y) { + modify_scales = function(self, scales) { if (self$theta != "y") return() - lapply(scales_x, scale_flip_position) - lapply(scales_y, scale_flip_position) + lapply(scales$x, scale_flip_position) + lapply(scales$y, scale_flip_position) }, setup_params = function(self, data) { diff --git a/R/coord-sf.R b/R/coord-sf.R index f129947dc0..ef01292478 100644 --- a/R/coord-sf.R +++ b/R/coord-sf.R @@ -166,15 +166,15 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, graticule }, - setup_panel_params = function(self, scale_x, scale_y, params = list()) { + setup_panel_params = function(self, scales, params = list()) { # expansion factors for scale limits - expansion_x <- default_expansion(scale_x, expand = params$expand[c(4, 2)]) - expansion_y <- default_expansion(scale_y, expand = params$expand[c(3, 1)]) + expansion_x <- default_expansion(scales$x, expand = params$expand[c(4, 2)]) + expansion_y <- default_expansion(scales$y, expand = params$expand[c(3, 1)]) # get scale limits and coord limits and merge together # coord limits take precedence over scale limits - scale_xlim <- scale_x$get_limits() - scale_ylim <- scale_y$get_limits() + scale_xlim <- scales$x$get_limits() + scale_ylim <- scales$y$get_limits() coord_xlim <- self$limits$x %||% c(NA_real_, NA_real_) coord_ylim <- self$limits$y %||% c(NA_real_, NA_real_) @@ -193,7 +193,7 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, # merge coord bbox into scale limits if scale limits not explicitly set if (is.null(self$limits$x) && is.null(self$limits$y) && - is.null(scale_x$limits) && is.null(scale_y$limits)) { + is.null(scales$x$limits) && is.null(scales$y$limits)) { coord_bbox <- self$params$bbox scales_xrange <- range(scales_bbox$x, coord_bbox$xmin, coord_bbox$xmax, na.rm = TRUE) scales_yrange <- range(scales_bbox$y, coord_bbox$ymin, coord_bbox$ymax, na.rm = TRUE) @@ -220,7 +220,7 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, x_range[2], y_range[2] ) - breaks <- sf_breaks(scale_x, scale_y, bbox, params$crs) + breaks <- sf_breaks(scales$x, scales$y, bbox, params$crs) # Generate graticule and rescale to plot coords graticule <- sf::st_graticule( @@ -240,12 +240,12 @@ CoordSf <- ggproto("CoordSf", CoordCartesian, } # override graticule labels provided by sf::st_graticule() if necessary - graticule <- self$fixup_graticule_labels(graticule, scale_x, scale_y, params) + graticule <- self$fixup_graticule_labels(graticule, scales$x, scales$y, params) # Convert graticule to viewscales for axis guides viewscales <- Map( view_scales_from_graticule, - scale = list(x = scale_x, y = scale_y, x.sec = scale_x, y.sec = scale_y), + scale = list(x = scales$x, y = scales$y, x.sec = scales$x, y.sec = scales$y), aesthetic = c("x", "y", "x.sec", "y.sec"), label = self$label_axes[c("bottom", "left", "top", "right")], MoreArgs = list( diff --git a/R/coord-transform.R b/R/coord-transform.R index 1253529fdd..62e3d0b74e 100644 --- a/R/coord-transform.R +++ b/R/coord-transform.R @@ -151,10 +151,10 @@ CoordTrans <- ggproto("CoordTrans", Coord, transform_position(new_data, squish_infinite, squish_infinite) }, - setup_panel_params = function(self, scale_x, scale_y, params = list()) { + setup_panel_params = function(self, scales, params = list()) { c( - view_scales_from_scale_with_coord_trans(scale_x, self$limits$x, self$trans$x, params$expand[c(4, 2)]), - view_scales_from_scale_with_coord_trans(scale_y, self$limits$y, self$trans$y, params$expand[c(3, 1)]) + view_scales_from_scale_with_coord_trans(scales$x, self$limits$x, self$trans$x, params$expand[c(4, 2)]), + view_scales_from_scale_with_coord_trans(scales$y, self$limits$y, self$trans$y, params$expand[c(3, 1)]) ) }, From 041509b1e7645ab9656008110130211357ad5ea1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 5 Sep 2024 21:06:33 +0200 Subject: [PATCH 6/7] adapt tests --- R/plot-build.R | 4 ++-- tests/testthat/helper-plot-data.R | 6 +++--- tests/testthat/test-coord-polar.R | 2 +- tests/testthat/test-coord-train.R | 11 ++++++----- tests/testthat/test-labels.R | 16 ++++++++-------- tests/testthat/test-scales.R | 12 ++++++------ 6 files changed, 26 insertions(+), 25 deletions(-) diff --git a/R/plot-build.R b/R/plot-build.R index 354fc8426d..5e1e049e23 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -157,8 +157,8 @@ get_panel_scales <- function(plot = get_last_plot(), i = 1L, j = 1L) { 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]] ) } diff --git a/tests/testthat/helper-plot-data.R b/tests/testthat/helper-plot-data.R index 13e36d861a..aaefc9c27c 100644 --- a/tests/testthat/helper-plot-data.R +++ b/tests/testthat/helper-plot-data.R @@ -5,7 +5,7 @@ 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) + panel_params <- plot$coordinates$setup_panel_params(scales, params = pieces$layout$coord_params) plot$coordinates$transform(panel_data, panel_params) }) }) @@ -14,8 +14,8 @@ cdata <- function(plot) { pranges <- function(plot) { 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()) + x_ranges <- lapply(layout$panel_scales$x, function(scale) scale$get_limits()) + y_ranges <- lapply(layout$panel_scales$y, function(scale) scale$get_limits()) npscales <- plot$scales$non_position_scales() diff --git a/tests/testthat/test-coord-polar.R b/tests/testthat/test-coord-polar.R index da49368108..f713bb4363 100644 --- a/tests/testthat/test-coord-polar.R +++ b/tests/testthat/test-coord-polar.R @@ -8,7 +8,7 @@ test_that("polar distance is calculated correctly", { y = scale_y_continuous(limits = c(0, 1)) ) coord <- coord_polar() - panel_params <- coord$setup_panel_params(scales$x, scales$y) + panel_params <- coord$setup_panel_params(scales) dists <- coord$distance(dat$theta, dat$r, panel_params) # dists is normalized by dividing by this value, so we'll add it back diff --git a/tests/testthat/test-coord-train.R b/tests/testthat/test-coord-train.R index 9d42ec3c79..257c3f76ba 100644 --- a/tests/testthat/test-coord-train.R +++ b/tests/testthat/test-coord-train.R @@ -23,11 +23,12 @@ test_that("NA's don't appear in breaks", { expect_true(anyNA(scale_y$break_positions())) # Check the various types of coords to make sure they don't have NA breaks - expect_false(any_NA_major_minor(coord_polar()$setup_panel_params(scale_x, scale_y))) - expect_false(any_NA_major_minor(coord_cartesian()$setup_panel_params(scale_x, scale_y))) - expect_false(any_NA_major_minor(coord_trans()$setup_panel_params(scale_x, scale_y))) - expect_false(any_NA_major_minor(coord_fixed()$setup_panel_params(scale_x, scale_y))) + scales <- list(x = scale_x, y = scale_y) + expect_false(any_NA_major_minor(coord_polar()$setup_panel_params(scales))) + expect_false(any_NA_major_minor(coord_cartesian()$setup_panel_params(scales))) + expect_false(any_NA_major_minor(coord_trans()$setup_panel_params(scales))) + expect_false(any_NA_major_minor(coord_fixed()$setup_panel_params(scales))) skip_if_not_installed("mapproj") - expect_false(any_NA_major_minor(coord_map()$setup_panel_params(scale_x, scale_y))) + expect_false(any_NA_major_minor(coord_map()$setup_panel_params(scales))) }) diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 60f5165c1b..4b2b2fbb36 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -143,11 +143,11 @@ test_that("position axis label hierarchy works as intended", { # In absence of explicit title, get title from mapping expect_identical( - p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels), + p$layout$resolve_label(p$layout$panel_scales$x[[1]], p$plot$labels), list(secondary = NULL, primary = "foo") ) expect_identical( - p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels), + p$layout$resolve_label(p$layout$panel_scales$y[[1]], p$plot$labels), list(primary = "bar", secondary = NULL) ) @@ -221,11 +221,11 @@ test_that("moving guide positions lets titles follow", { p$plot$layers ) expect_identical( - p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels), + p$layout$resolve_label(p$layout$panel_scales$x[[1]], p$plot$labels), list(secondary = NULL, primary = "baz") ) expect_identical( - p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels), + p$layout$resolve_label(p$layout$panel_scales$y[[1]], p$plot$labels), list(primary = "qux", secondary = NULL) ) @@ -238,11 +238,11 @@ test_that("moving guide positions lets titles follow", { p$plot$layers ) expect_identical( - p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels), + p$layout$resolve_label(p$layout$panel_scales$x[[1]], p$plot$labels), list(primary = "baz", secondary = NULL) ) expect_identical( - p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels), + p$layout$resolve_label(p$layout$panel_scales$y[[1]], p$plot$labels), list(secondary = NULL, primary = "qux") ) @@ -258,11 +258,11 @@ test_that("moving guide positions lets titles follow", { p$plot$layers ) expect_identical( - p$layout$resolve_label(p$layout$panel_scales_x[[1]], p$plot$labels), + p$layout$resolve_label(p$layout$panel_scales$x[[1]], p$plot$labels), list(primary = "baz", secondary = "quux") ) expect_identical( - p$layout$resolve_label(p$layout$panel_scales_y[[1]], p$plot$labels), + p$layout$resolve_label(p$layout$panel_scales$y[[1]], p$plot$labels), list(secondary = "corge", primary = "qux") ) }) diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 0ba2989e39..e63b27887e 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -144,18 +144,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") @@ -345,12 +345,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 @@ -364,7 +364,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")) From 226ad69f270d37b6c4058c93a4c828186ece4497 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 5 Sep 2024 22:05:11 +0200 Subject: [PATCH 7/7] fix failing vignette --- vignettes/extending-ggplot2.Rmd | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/vignettes/extending-ggplot2.Rmd b/vignettes/extending-ggplot2.Rmd index 6ee65ae718..3b4df4cee7 100644 --- a/vignettes/extending-ggplot2.Rmd +++ b/vignettes/extending-ggplot2.Rmd @@ -715,7 +715,7 @@ here we first investigate whether we have gotten an empty `data.frame` and if no While the two functions above have been deceivingly simple, this last one is going to take some more work. Our goal is to draw two panels beside (or above) each other with axes etc. ```{r} -render <- function(panels, layout, x_scales, y_scales, ranges, coord, data, +render <- function(panels, layout, scales, ranges, coord, data, theme, params) { # Place panels according to settings if (params$horizontal) { @@ -852,14 +852,13 @@ FacetTrans <- ggproto("FacetTrans", Facet, ) }, # This is new. We create a new scale with the defined transformation - init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) { - scales <- list() - if (!is.null(x_scale)) { - scales$x <- lapply(seq_len(max(layout$SCALE_X)), function(i) x_scale$clone()) + init_scales = function(layout, scales, params) { + if (!is.null(scales$x)) { + scales$x <- lapply(seq_len(max(layout$SCALE_X)), function(i) scales$x$clone()) } - if (!is.null(y_scale)) { - y_scale_orig <- y_scale$clone() - y_scale_new <- y_scale$clone() + if (!is.null(scales$y)) { + y_scale_orig <- scales$y$clone() + y_scale_new <- scales$y$clone() y_scale_new$trans <- params$trans # Make sure that oob values are kept y_scale_new$oob <- function(x, ...) x @@ -868,8 +867,9 @@ FacetTrans <- ggproto("FacetTrans", Facet, scales }, # We must make sure that the second scale is trained on transformed data - train_scales = function(x_scales, y_scales, layout, data, params) { + train_scales = function(scales, layout, data, params) { # Transform data for second panel prior to scale training + y_scales <- scales$y if (!is.null(y_scales)) { data <- lapply(data, function(layer_data) { match_id <- match(layer_data$PANEL, layout$PANEL) @@ -881,22 +881,22 @@ FacetTrans <- ggproto("FacetTrans", Facet, layer_data }) } - Facet$train_scales(x_scales, y_scales, layout, data, params) + Facet$train_scales(scales, layout, data, params) }, # this is where we actually modify the data. It cannot be done in $map_data as that function # doesn't have access to the scales - finish_data = function(data, layout, x_scales, y_scales, params) { + finish_data = function(data, layout, scales, params) { match_id <- match(data$PANEL, layout$PANEL) - y_vars <- intersect(y_scales[[1]]$aesthetics, names(data)) + y_vars <- intersect(scales$y[[1]]$aesthetics, names(data)) trans_scale <- data$PANEL == 2L for (i in y_vars) { - data[trans_scale, i] <- y_scales[[2]]$transform(data[trans_scale, i]) + data[trans_scale, i] <- scales$y[[2]]$transform(data[trans_scale, i]) } data }, # A few changes from before to accommodate that axes are now not duplicate of each other # We also add a panel strip to annotate the different panels - draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, + draw_panels = function(panels, layout, scales, ranges, coord, data, theme, params) { # Place panels according to settings if (params$horizontal) {