From 8a5b03c1ce1d8c1d369eaea2fa6489f626fd6b1d Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 24 May 2024 16:13:15 +0200 Subject: [PATCH 01/12] use scale class constructors --- R/scale-.R | 236 ++++++++++++++++++++--------------------------------- 1 file changed, 90 insertions(+), 146 deletions(-) diff --git a/R/scale-.R b/R/scale-.R index 9eaa153590..fae48dc24a 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -107,7 +107,6 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam guide = "legend", position = "left", call = caller_call(), super = ScaleContinuous) { - call <- call %||% current_call() if (lifecycle::is_present(scale_name)) { deprecate_soft0("3.5.0", "continuous_scale(scale_name)") } @@ -115,54 +114,8 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam deprecate_soft0("3.5.0", "continuous_scale(trans)", "continuous_scale(transform)") transform <- trans } - - aesthetics <- standardise_aes_names(aesthetics) - - check_breaks_labels(breaks, labels, call = call) - - position <- arg_match0(position, c("left", "right", "top", "bottom")) - - # If the scale is non-positional, break = NULL means removing the guide - if (is.null(breaks) && all(!is_position_aes(aesthetics))) { - guide <- "none" - } - - transform <- as.transform(transform) - if (!is.null(limits) && !is.function(limits)) { - limits <- transform$transform(limits) - } - - # Convert formula to function if appropriate - limits <- allow_lambda(limits) - breaks <- allow_lambda(breaks) - labels <- allow_lambda(labels) - rescaler <- allow_lambda(rescaler) - oob <- allow_lambda(oob) - minor_breaks <- allow_lambda(minor_breaks) - - ggproto(NULL, super, - call = call, - - aesthetics = aesthetics, - palette = palette, - - range = ContinuousRange$new(), - limits = limits, - trans = transform, - na.value = na.value, - expand = expand, - rescaler = rescaler, - oob = oob, - - name = name, - breaks = breaks, - minor_breaks = minor_breaks, - n.breaks = n.breaks, - - labels = labels, - guide = guide, - position = position - ) + args <- find_args(call = NULL, scale_name = NULL, trans = NULL) + inject(super$new(!!!args, call = call %||% current_call())) } #' Discrete scale constructor @@ -206,55 +159,11 @@ discrete_scale <- function(aesthetics, scale_name = deprecated(), palette, name guide = "legend", position = "left", call = caller_call(), super = ScaleDiscrete) { - call <- call %||% current_call() if (lifecycle::is_present(scale_name)) { deprecate_soft0("3.5.0", "discrete_scale(scale_name)") } - - aesthetics <- standardise_aes_names(aesthetics) - - check_breaks_labels(breaks, labels, call = call) - - # Convert formula input to function if appropriate - limits <- allow_lambda(limits) - breaks <- allow_lambda(breaks) - labels <- allow_lambda(labels) - minor_breaks <- allow_lambda(minor_breaks) - - if (!is.function(limits) && (length(limits) > 0) && !is.discrete(limits)) { - cli::cli_warn(c( - "Continuous limits supplied to discrete scale.", - "i" = "Did you mean {.code limits = factor(...)} or {.fn scale_*_continuous}?" - ), call = call) - } - - position <- arg_match0(position, c("left", "right", "top", "bottom")) - - # If the scale is non-positional, break = NULL means removing the guide - if (is.null(breaks) && all(!is_position_aes(aesthetics))) { - guide <- "none" - } - - ggproto(NULL, super, - call = call, - - aesthetics = aesthetics, - palette = palette, - - range = DiscreteRange$new(), - limits = limits, - na.value = na.value, - na.translate = na.translate, - expand = expand, - - name = name, - breaks = breaks, - minor_breaks = minor_breaks, - labels = labels, - drop = drop, - guide = guide, - position = position - ) + args <- find_args(call = NULL, scale_name = NULL) + inject(super$new(!!!args, call = call %||% current_call())) } #' Binning scale constructor @@ -301,56 +210,8 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name = deprecate_soft0("3.5.0", "binned_scale(trans)", "binned_scale(transform)") transform <- trans } - - call <- call %||% current_call() - - aesthetics <- standardise_aes_names(aesthetics) - - check_breaks_labels(breaks, labels, call = call) - - position <- arg_match0(position, c("left", "right", "top", "bottom")) - - if (is.null(breaks) && !is_position_aes(aesthetics) && guide != "none") { - guide <- "none" - } - - transform <- as.transform(transform) - if (!is.null(limits)) { - limits <- transform$transform(limits) - } - - # Convert formula input to function if appropriate - limits <- allow_lambda(limits) - breaks <- allow_lambda(breaks) - labels <- allow_lambda(labels) - rescaler <- allow_lambda(rescaler) - oob <- allow_lambda(oob) - - ggproto(NULL, super, - call = call, - - aesthetics = aesthetics, - palette = palette, - - range = ContinuousRange$new(), - limits = limits, - trans = transform, - na.value = na.value, - expand = expand, - rescaler = rescaler, - oob = oob, - n.breaks = n.breaks, - nice.breaks = nice.breaks, - right = right, - show.limits = show.limits, - - name = name, - breaks = breaks, - - labels = labels, - guide = guide, - position = position - ) + args <- find_args(call = NULL, scale_name = NULL, trans = NULL) + inject(super$new(!!!args, call = call %||% current_call())) } #' @section Scales: @@ -600,6 +461,42 @@ Scale <- ggproto("Scale", NULL, make_sec_title = function(title) { title + }, + + new = function(self, aesthetics, palette, name = waiver(), breaks = waiver(), + minor_breaks = waiver(), labels = waiver(), limits = NULL, + expand = waiver(), guide = "legend", position = "left", + call = caller_call(), ..., super = NULL) { + + call <- call %||% current_call() + aesthetics <- standardise_aes_names(aesthetics) + check_breaks_labels(breaks, labels, call = call) + limits <- allow_lambda(limits) + breaks <- allow_lambda(breaks) + labels <- allow_lambda(labels) + minor_breaks <- allow_lambda(minor_breaks) + position <- arg_match0(position, .trbl) + if (is.null(breaks) & all(!is_position_aes(aesthetics))) { + guide <- "none" + } + + super <- super %||% self + ggproto( + NULL, super, + call = call, + aesthetics = aesthetics, + palette = palette, + limits = limits, + expand = expand, + name = name, + breaks = breaks, + minor_breaks = minor_breaks, + labels = labels, + guide = guide, + position = position, + ... + ) + } ) @@ -912,10 +809,33 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, } else { cat(" Limits: ", show_range(self$dimension()), "\n", sep = "") } + }, + + new = function(self, rescaler = rescale, oob = censor, + range = ContinuousRange$new(), + transform = "identity", limits = NULL, ..., + super = NULL) { + + transform <- as.transform(transform) + if (!is.null(limits) && !is.function(limits) && !is.formula(limits)) { + limits = transform$transform(limits) + } + + rescaler <- allow_lambda(rescaler) + oob <- allow_lambda(oob) + + ggproto_parent(Scale, self)$new( + rescaler = rescaler, + range = range, + oob = oob, + trans = transform, + limits = limits, + ..., + super = super %||% self + ) } ) - #' @rdname ggplot2-ggproto #' @format NULL #' @usage NULL @@ -1136,6 +1056,26 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, major_source = major, minor_source = NULL ) + }, + + new = function(self, limits = NULL, call = caller_call(), + range = DiscreteRange$new(), + ..., super = NULL) { + call <- call %||% current_call() + limits <- allow_lambda(limits) + if (!is.function(limits) && (length(limits) > 0 && !is.discrete(limits))) { + cli::cli_warn(c( + "Continuous limits supplied to discrete scale.", + i = "Did you mean {.code limits = factor(...)} or {.fn scale_*_continuous}?" + ), call = call) + } + ggproto_parent(Scale, self)$new( + limits = limits, + range = range, + call = call, + ..., + super = super %||% self + ) } ) @@ -1370,6 +1310,10 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, list(range = range, labels = labels, major = pal, minor = NULL, major_source = major, minor_source = NULL) + }, + + new = function(self, ..., super = NULL) { + ggproto_parent(ScaleContinuous, self)$new(..., super = super %||% self) } ) From f3a6fde0811aee1854e27a0d3922d5bf90fa788f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 27 May 2024 09:48:04 +0200 Subject: [PATCH 02/12] update mechanism --- R/scale-.R | 59 ++++++++++++++++++++++++++++++++--------------------- R/scales-.R | 20 +++++++++++++++++- 2 files changed, 55 insertions(+), 24 deletions(-) diff --git a/R/scale-.R b/R/scale-.R index fae48dc24a..4b75c02e4e 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -463,40 +463,40 @@ Scale <- ggproto("Scale", NULL, title }, - new = function(self, aesthetics, palette, name = waiver(), breaks = waiver(), + new = function(self, aesthetics = NULL, breaks = waiver(), minor_breaks = waiver(), labels = waiver(), limits = NULL, - expand = waiver(), guide = "legend", position = "left", + guide = NULL, position = NULL, call = caller_call(), ..., super = NULL) { - call <- call %||% current_call() - aesthetics <- standardise_aes_names(aesthetics) + super <- super %||% self + call <- call %||% super$call() %||% current_call() + aesthetics <- standardise_aes_names(aesthetics %||% super$aesthetics) + limits <- allow_lambda(limits %||% super$limits) + breaks <- allow_lambda(breaks %|W|% super$breaks) + labels <- allow_lambda(labels %|W|% super$labels) + minor_breaks <- allow_lambda(minor_breaks %|W|% super$minor_breaks) check_breaks_labels(breaks, labels, call = call) - limits <- allow_lambda(limits) - breaks <- allow_lambda(breaks) - labels <- allow_lambda(labels) - minor_breaks <- allow_lambda(minor_breaks) - position <- arg_match0(position, .trbl) + position <- arg_match0(position %||% super$position, .trbl) if (is.null(breaks) & all(!is_position_aes(aesthetics))) { guide <- "none" } - super <- super %||% self ggproto( NULL, super, call = call, aesthetics = aesthetics, - palette = palette, limits = limits, - expand = expand, - name = name, breaks = breaks, minor_breaks = minor_breaks, labels = labels, - guide = guide, + guide = guide %||% super$guide, position = position, ... ) + }, + update = function(self, params) { + inject(self$new(!!!params)) } ) @@ -811,18 +811,19 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, } }, - new = function(self, rescaler = rescale, oob = censor, + new = function(self, rescaler = NULL, oob = NULL, range = ContinuousRange$new(), - transform = "identity", limits = NULL, ..., + transform = NULL, limits = NULL, ..., super = NULL) { - - transform <- as.transform(transform) - if (!is.null(limits) && !is.function(limits) && !is.formula(limits)) { - limits = transform$transform(limits) + super <- super %||% self + transform <- as.transform(transform %||% super$trans) + limits <- allow_lambda(limits %||% super$limits) + if (!is.null(limits) && !is.function(limits)) { + limits <- transform$transform(limits) } - rescaler <- allow_lambda(rescaler) - oob <- allow_lambda(oob) + rescaler <- allow_lambda(rescaler %||% super$rescaler) + oob <- allow_lambda(oob %||% super$oob) ggproto_parent(Scale, self)$new( rescaler = rescaler, @@ -831,8 +832,20 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, trans = transform, limits = limits, ..., - super = super %||% self + super = super ) + }, + + update = function(self, params) { + # We may need to update limits when previously transformed and + # a new transformation is coming in + if ("transform" %in% names(params) && + self$trans$name != "identity" && + (!"limits" %in% names(params)) && + !is.null(self$limits) && !is.function(self$limits)) { + params$limits <- self$trans$inverse(self$limits) + } + inject(self$new(!!!params)) } ) diff --git a/R/scales-.R b/R/scales-.R index e62eb0e8cb..e1fea4a6c1 100644 --- a/R/scales-.R +++ b/R/scales-.R @@ -8,6 +8,7 @@ scales_list <- function() { ScalesList <- ggproto("ScalesList", NULL, scales = NULL, + params = list(), find = function(self, aesthetic) { vapply(self$scales, function(x) any(aesthetic %in% x$aesthetics), logical(1)) @@ -21,7 +22,10 @@ ScalesList <- ggproto("ScalesList", NULL, if (is.null(scale)) { return() } - + aes <- intersect(scale$aesthetics, names(self$params)) + for (i in aes) { + scale <- scale$update(self$params[[aes]]) + } prev_aes <- self$find(scale$aesthetics) if (any(prev_aes)) { # Get only the first aesthetic name in the returned vector -- it can @@ -168,6 +172,20 @@ ScalesList <- ggproto("ScalesList", NULL, scale_name <- paste("scale", aes, "continuous", sep = "_") self$add(find_global(scale_name, env, mode = "function")()) } + }, + + add_params = function(self, aesthetic, params = NULL) { + if (is.null(params) || is.null(aesthetic)) { + return() + } + index <- which(self$find(aesthetic)) + if (length(index) > 0) { + for (i in index) { + self$scales[[i]] <- self$scales[[i]]$update(params) + } + } else { + self$params[[aesthetic]] <- defaults(params, self$params[[aesthetic]]) + } } ) From ded2b47b31c99bc5e271cf066349c4701df4d611 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 27 May 2024 10:05:18 +0200 Subject: [PATCH 03/12] user-facing function --- R/plot-construction.R | 7 +++++++ R/scale-.R | 22 ++++++++++++++++++++++ 2 files changed, 29 insertions(+) diff --git a/R/plot-construction.R b/R/plot-construction.R index b6d83fe1f0..5cf7e5d842 100644 --- a/R/plot-construction.R +++ b/R/plot-construction.R @@ -120,6 +120,13 @@ ggplot_add.Scale <- function(object, plot, object_name) { plot$scales$add(object) plot } + +#' @export +ggplot_add.scale_params <- function(object, plot, object_name) { + plot$scales$add_params(object$aesthetics, object$params) + plot +} + #' @export ggplot_add.labels <- function(object, plot, object_name) { update_labels(plot, object) diff --git a/R/scale-.R b/R/scale-.R index 4b75c02e4e..a0e3b81ab2 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -214,6 +214,28 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name = inject(super$new(!!!args, call = call %||% current_call())) } + +#' Setting scale parameters +#' +#' @param aesthetics The name of the aesthetics for which to update the scale. +#' @param ... Named arguments to one of the scale constructors, +#' [`continuous_scale()`], [`discrete_scale()`] or [`binned_scale()`]. +#' +#' @return A `scale_params` object that can be added to a plot. +#' @export +#' +#' @examples +#' ggplot(mpg, aes(displ, hwy)) + +#' geom_point() + +#' scale_params("x", limits = c(0, 10)) + +#' scale_params("y", transform = "sqrt") +scale_params <- function(aesthetics, ...) { + structure( + list(aesthetics = aesthetics, params = list2(...)), + class = "scale_params" + ) +} + #' @section Scales: #' #' All `scale_*` functions like [scale_x_continuous()] return a `Scale*` From f566c0aab13635cee99b24382bf81cd391e2e02a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 27 May 2024 10:05:27 +0200 Subject: [PATCH 04/12] document --- NAMESPACE | 2 ++ man/scale_params.Rd | 26 ++++++++++++++++++++++++++ 2 files changed, 28 insertions(+) create mode 100644 man/scale_params.Rd diff --git a/NAMESPACE b/NAMESPACE index 9068973de0..90fadaec7b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -64,6 +64,7 @@ S3method(ggplot_add,data.frame) S3method(ggplot_add,default) S3method(ggplot_add,labels) S3method(ggplot_add,list) +S3method(ggplot_add,scale_params) S3method(ggplot_add,theme) S3method(ggplot_add,uneval) S3method(ggplot_build,ggplot) @@ -607,6 +608,7 @@ export(scale_linewidth_discrete) export(scale_linewidth_identity) export(scale_linewidth_manual) export(scale_linewidth_ordinal) +export(scale_params) export(scale_radius) export(scale_shape) export(scale_shape_binned) diff --git a/man/scale_params.Rd b/man/scale_params.Rd new file mode 100644 index 0000000000..859ae22d0d --- /dev/null +++ b/man/scale_params.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scale-.R +\name{scale_params} +\alias{scale_params} +\title{Setting scale parameters} +\usage{ +scale_params(aesthetics, ...) +} +\arguments{ +\item{aesthetics}{The name of the aesthetics for which to update the scale.} + +\item{...}{Named arguments to one of the scale constructors, +\code{\link[=continuous_scale]{continuous_scale()}}, \code{\link[=discrete_scale]{discrete_scale()}} or \code{\link[=binned_scale]{binned_scale()}}.} +} +\value{ +A \code{scale_params} object that can be added to a plot. +} +\description{ +Setting scale parameters +} +\examples{ +ggplot(mpg, aes(displ, hwy)) + + geom_point() + + scale_params("x", limits = c(0, 10)) + + scale_params("y", transform = "sqrt") +} From 7ec9d4d6a67c45c0873652f0401e0a66e9e7ad1f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 22 Nov 2024 11:30:34 +0100 Subject: [PATCH 05/12] restore #5933 --- R/scale-.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/scale-.R b/R/scale-.R index 9c50b217ba..dc36923967 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -1103,10 +1103,11 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, ) }, - new = function(self, aesthetics, palette = NULL, limits = NULL, call = caller_call(), + new = function(self, aesthetics = NULL, palette = NULL, limits = NULL, call = caller_call(), range = DiscreteRange$new(), ..., super = NULL) { call <- call %||% current_call() + super <- super %||% self limits <- allow_lambda(limits) if (!is.function(limits) && (length(limits) > 0 && !is.discrete(limits))) { cli::cli_warn(c( @@ -1114,6 +1115,8 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, i = "Did you mean {.code limits = factor(...)} or {.fn scale_*_continuous}?" ), call = call) } + aesthetics <- aesthetics %||% super$aesthetics + palette <- palette %||% .subset2(super, "palette") if (identical(palette, identity) && any(is_position_aes(aesthetics))) { palette <- seq_len } From 47a6b57d1ff35550ff180a70a87e213d8b8b82d3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 22 Nov 2024 11:31:25 +0100 Subject: [PATCH 06/12] fix vectorised aesthetics case --- R/scales-.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/scales-.R b/R/scales-.R index e1fea4a6c1..59b9e1b925 100644 --- a/R/scales-.R +++ b/R/scales-.R @@ -184,7 +184,9 @@ ScalesList <- ggproto("ScalesList", NULL, self$scales[[i]] <- self$scales[[i]]$update(params) } } else { - self$params[[aesthetic]] <- defaults(params, self$params[[aesthetic]]) + for (i in aesthetic) { + self$params[[i]] <- defaults(params, self$params[[i]]) + } } } ) From b6748c26b6c89a508cf2054712341390babf100f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 22 Nov 2024 12:12:54 +0100 Subject: [PATCH 07/12] protect against invalid arguments --- R/scale-.R | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/R/scale-.R b/R/scale-.R index dc36923967..4aa8a38a58 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -522,6 +522,7 @@ Scale <- ggproto("Scale", NULL, }, update = function(self, params) { + check_update_params(self, params) inject(self$new(!!!params)) } ) @@ -546,6 +547,29 @@ check_breaks_labels <- function(breaks, labels, call = NULL) { TRUE } +check_update_params <- function(scale, params) { + if (inherits(scale, "ScaleContinuous")) { + args <- fn_fmls_names(continuous_scale) + } else if (inherits(scale, "ScaleDiscrete")) { + args <- fn_fmls_names(discrete_scale) + } else if (inherits(scale, "ScaleBinned")) { + args <- fn_fmls_names(binned_scale) + } else { + # We don't know what valid parameters are of custom scale types + return(invisible(NULL)) + } + extra <- setdiff(names(params), args) + if (length(extra) == 0) { + return(invisible(NULL)) + } + extra <- paste0("{.val ", extra, "}") + names(extra) <- rep("*", length(extra)) + cli::cli_abort( + c("Cannot update scale with the unknown {cli::qty(extra)} argument{?s}:", extra), + call = scale$call + ) +} + default_transform <- function(self, x) { transformation <- self$get_transformation() new_x <- transformation$transform(x) @@ -865,6 +889,7 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, }, update = function(self, params) { + check_update_params(self, params) # We may need to update limits when previously transformed and # a new transformation is coming in if ("transform" %in% names(params) && From 369079a8c34e3c693436053800bc2faa530f066e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 22 Nov 2024 13:00:30 +0100 Subject: [PATCH 08/12] fix bug where limits is transformed every time --- R/scale-.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/scale-.R b/R/scale-.R index 4aa8a38a58..2f13dda57c 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -867,10 +867,11 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, call = NULL, super = NULL) { super <- super %||% self transform <- as.transform(transform %||% super$trans) - limits <- allow_lambda(limits %||% super$limits) + limits <- allow_lambda(limits) if (!is.null(limits) && !is.function(limits)) { limits <- transform$transform(limits) } + limits <- limits %||% super$limits check_continuous_limits(limits, call = call) rescaler <- allow_lambda(rescaler %||% super$rescaler) From 8d5c69d3639cf8bb81958d8b74bfd24bd8dfac6a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 22 Nov 2024 13:00:36 +0100 Subject: [PATCH 09/12] add test --- tests/testthat/test-scales.R | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index d9286b513f..75141a0b18 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -758,3 +758,37 @@ test_that("discrete scales work with NAs in arbitrary positions", { expect_equal(test, output) }) + +test_that("scale updating mechanism works", { + p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl), shape = factor(gear))) + + geom_point(na.rm = TRUE) + + scales <- get_panel_scales( + p + + scale_params("y", name = "Miles per gallon") + + scale_params("y", limits = c(10, 40)) + + scale_y_continuous(transform = "sqrt") + + scale_params("y", expand = expansion()) + ) + y <- scales$y + expect_equal(y$get_limits(), sqrt(c(10, 40))) + expect_equal(y$expand, c(0, 0, 0, 0)) + expect_equal(y$name, "Miles per gallon") + + b <- ggplot_build( + p + + scale_params("colour", labels = identity, breaks = c(8, 4, 6)) + + scale_params(c("colour", "shape"), labels = function(x) as.character(as.roman(x))) + + scale_params("shape", limits = as.character(c(3, 5)), labels = identity) + ) + + # Roman label should override identity labels + # Order should be unnatural + l <- get_guide_data(b, "colour") + expect_equal(l$.label, c("VIII", "IV", "VI")) + + # Identity labels should override roman labels + # gear = 4 should be missing from legend + l <- get_guide_data(b, "shape") + expect_equal(l$.label, as.character(c(3, 5)), ignore_attr = "pos") +}) From 3b4c3a91e23431dd75c4b6e4c4790806a6e4b9b3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 4 Feb 2025 14:46:14 +0100 Subject: [PATCH 10/12] use field to store params to update --- R/scale-.R | 33 +++++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/R/scale-.R b/R/scale-.R index 152bd7d8a3..c1ffec5afc 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -532,6 +532,12 @@ Scale <- ggproto("Scale", NULL, ) }, + updatable_params = c( + "aesthetics", "scale_name", "palette", "name", "breaks", "labels", + "limits", "expand", "na.value", "guide", "position", "call", + "super" + ), + update = function(self, params) { check_update_params(self, params) inject(self$new(!!!params)) @@ -560,16 +566,7 @@ check_breaks_labels <- function(breaks, labels, call = NULL) { } check_update_params <- function(scale, params) { - if (inherits(scale, "ScaleContinuous")) { - args <- fn_fmls_names(continuous_scale) - } else if (inherits(scale, "ScaleDiscrete")) { - args <- fn_fmls_names(discrete_scale) - } else if (inherits(scale, "ScaleBinned")) { - args <- fn_fmls_names(binned_scale) - } else { - # We don't know what valid parameters are of custom scale types - return(invisible(NULL)) - } + args <- scale$updatable_params extra <- setdiff(names(params), args) if (length(extra) == 0) { return(invisible(NULL)) @@ -902,6 +899,11 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale, ) }, + updatable_params = c( + Scale$updatable_params, + "minor_breaks", "n.breaks", "rescaler", "oob", "transform" + ), + update = function(self, params) { check_update_params(self, params) # We may need to update limits when previously transformed and @@ -1145,6 +1147,11 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, ) }, + updatable_params = c( + Scale$updatable_params, + "minor_breaks", "na.translate", "drop" + ), + new = function(self, aesthetics = NULL, palette = NULL, limits = NULL, call = caller_call(), range = DiscreteRange$new(), ..., super = NULL) { @@ -1416,6 +1423,12 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, major_source = major, minor_source = NULL) }, + updatable_params = c( + Scale$updatable_params, + "rescaler", "oob", "n.breaks", "nice.breaks", + "right", "transform", "show.limits" + ), + new = function(self, ..., super = NULL) { ggproto_parent(ScaleContinuous, self)$new(..., super = super %||% self) } From 226d86be89cf23d8dcfa83307a26427caf000d85 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 4 Feb 2025 14:46:33 +0100 Subject: [PATCH 11/12] add test for re-transforming --- tests/testthat/test-scales.R | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index eef1da5998..b45e55addc 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -748,6 +748,16 @@ test_that("discrete scales work with NAs in arbitrary positions", { }) +test_that("continuous scales update limits when changing transforms", { + + x <- scale_x_continuous(limits = c(10, 100), trans = "sqrt") + expect_equal(x$limits, sqrt(c(10, 100))) + + x <- x$update(list(transform = "log10")) + expect_equal(x$limits, c(1, 2)) + +}) + test_that("scale updating mechanism works", { p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl), shape = factor(gear))) + geom_point(na.rm = TRUE) From 1cc17022731e6cd458e0d50f19ee1f01cf81685a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 4 Feb 2025 14:47:06 +0100 Subject: [PATCH 12/12] add test for consistency of `updatable params` field --- tests/testthat/test-scales.R | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index b45e55addc..49408fb1c2 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -792,6 +792,27 @@ test_that("scale updating mechanism works", { expect_equal(l$.label, as.character(c(3, 5)), ignore_attr = "pos") }) +test_that("scale updateable params is consistent with constructors", { + + # Note: 'trans' is deprecated in favour of 'transform' + constr_params <- function(fun) setdiff(fn_fmls_names(fun), "trans") + + expect_setequal( + ScaleContinuous$updatable_params, + constr_params(continuous_scale) + ) + + expect_setequal( + ScaleDiscrete$updatable_params, + constr_params(discrete_scale) + ) + + expect_setequal( + ScaleBinned$updatable_params, + constr_params(binned_scale) + ) +}) + test_that("discrete scales can map to 2D structures", { p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) +