From 7851475ad45b24e565e5a97e488552752cebfd47 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 10 Jan 2023 21:18:14 +0100 Subject: [PATCH 1/3] Convert `scales_*()` functions to ScalesList methods --- R/scales-.r | 111 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 111 insertions(+) diff --git a/R/scales-.r b/R/scales-.r index cb1e784670..2311335baa 100644 --- a/R/scales-.r +++ b/R/scales-.r @@ -59,6 +59,117 @@ ScalesList <- ggproto("ScalesList", NULL, scale <- self$scales[self$find(output)] if (length(scale) == 0) return() scale[[1]] + }, + + train_df = function(self, df, drop = FALSE) { + if (empty(df) || length(self$scales) == 0) { + return() + } + lapply(self$scales, function(scale) scale$train_df(df = df)) + }, + + map_df = function(self, df) { + if (empty(df) || length(self$scales) == 0) { + return(df) + } + + mapped <- unlist(lapply( + self$scales, + function(scale) scale$map_df(df = df) + ), recursive = FALSE) + + data_frame0(!!!mapped, df[setdiff(names(df), names(mapped))]) + }, + + transform_df = function(self, df) { + if (empty(df)) { + return(df) + } + + # If the scale contains to trans or trans is identity, there is no need + # to transform anything + idx_skip <- vapply(self$scales, function(x) { + has_default_transform(x) && + (is.null(x$trans) || identical(x$trans$transform, identity)) + }, logical(1L)) + scales <- self$scales[!idx_skip] + + if (length(scales) == 0) { + return(df) + } + + transformed <- unlist(lapply( + scales, + function(scale) scale$transform_df(df = df) + ), recursive = FALSE) + + data_frame0(!!!transformed, df[setdiff(names(df), names(transformed))]) + }, + + backtransform_df = function(self, df) { + # NOTE: no need to check empty(df) because it should be already checked + # before this method is called. + + # If the scale contains to trans or trans is identity, there is no need + # to transform anything + idx_skip <- vapply(self$scales, function(x) { + has_default_transform(x) && + (is.null(x$trans) || identical(x$trans$transform, identity)) + }, logical(1)) + scales <- self$scales[!idx_skip] + + if (length(scales) == 0) { + return(df) + } + + backtransformed <- unlist(lapply( + scales, + function(scale) { + aesthetics <- intersect(scale$aesthetics, names(df)) + if (length(aesthetics) == 0) { + return() + } + lapply(df[aesthetics], scale$trans$inverse) + } + ), recursive = FALSE) + + data_frame0( + !!!backtransformed, + df[setdiff(names(df), names(backtransformed))] + ) + }, + + # `aesthetics` is a list of aesthetic-variable mappings. The name of each + # item is the aesthetic, and the value of each item is the variable in data. + add_defaults = function(self, data, aesthetics, env) { + if (is.null(aesthetics)) { + return() + } + names(aesthetics) <- unlist(lapply(names(aesthetics), aes_to_scale)) + + new_aesthetics <- setdiff(names(aesthetics), self$input()) + # No new aesthetics, so no new scales to add + if (is.null(new_aesthetics)) { + return() + } + + data_cols <- lapply(aesthetics[new_aesthetics], eval_tidy, data = data) + data_cols <- compact(data_cols) + + for (aes in names(data_cols)) { + self$add(find_scale(aes, data_cols[[aes]], env)) + } + }, + + # Add missing but required scales + # `aesthetics` is a character vector of aesthetics. Typically c("x", "y") + add_missing = function(self, aesthetics, env) { + aesthetics <- setdiff(aesthetics, self$input()) + + for (aes in aesthetics) { + scale_name <- paste("scale", aes, "continuous", sep = "_") + self$add(find_global(scale_name, env, mode = "function")()) + } } ) From a38fd95cfd400e272da4849854d0a7770dd8eec5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 10 Jan 2023 21:19:02 +0100 Subject: [PATCH 2/3] Use ScalesList methods instead of functions --- R/layer.r | 8 ++++---- R/plot-build.r | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/R/layer.r b/R/layer.r index 89ccb58028..f76bcf4300 100644 --- a/R/layer.r +++ b/R/layer.r @@ -268,7 +268,7 @@ Layer <- ggproto("Layer", NULL, aesthetics[["group"]] <- self$aes_params$group } - scales_add_defaults(plot$scales, data, aesthetics, plot$plot_env) + plot$scales$add_defaults(data, aesthetics, plot$plot_env) # Evaluate aesthetics env <- child_env(baseenv(), stage = stage) @@ -341,7 +341,7 @@ Layer <- ggproto("Layer", NULL, if (length(new) == 0) return(data) # data needs to be non-scaled - data_orig <- scales_backtransform_df(plot$scales, data) + data_orig <- plot$scales$backtransform_df(data) # Add map stat output to aesthetics env <- child_env(baseenv(), stat = stat, after_stat = after_stat) @@ -369,11 +369,11 @@ Layer <- ggproto("Layer", NULL, stat_data <- data_frame0(!!!compact(stat_data)) # Add any new scales, if needed - scales_add_defaults(plot$scales, data, new, plot$plot_env) + plot$scales$add_defaults(data, new, 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 <- scales_transform_df(plot$scales, stat_data) + stat_data <- plot$scales$transform_df(stat_data) } cunion(stat_data, data) diff --git a/R/plot-build.r b/R/plot-build.r index b6102eed6e..56a74d0d76 100644 --- a/R/plot-build.r +++ b/R/plot-build.r @@ -53,7 +53,7 @@ ggplot_build.ggplot <- function(plot) { data <- by_layer(function(l, d) l$compute_aesthetics(d, plot), layers, data, "computing aesthetics") # Transform all scales - data <- lapply(data, scales_transform_df, scales = scales) + data <- lapply(data, scales$transform_df) # Map and train positions so that statistics have access to ranges # and all positions are numeric @@ -68,7 +68,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 - scales_add_missing(plot, 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") @@ -87,8 +87,8 @@ ggplot_build.ggplot <- function(plot) { # Train and map non-position scales npscales <- scales$non_position_scales() if (npscales$n() > 0) { - lapply(data, scales_train_df, scales = npscales) - data <- lapply(data, scales_map_df, scales = npscales) + lapply(data, npscales$train_df) + data <- lapply(data, npscales$map_df) } # Fill in defaults etc. From 351abf71dc21c1fcd1796508678035d3017a1297 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 10 Jan 2023 21:22:41 +0100 Subject: [PATCH 3/3] Decommission `scales_*()` functions --- R/scales-.r | 96 ----------------------------------------------------- 1 file changed, 96 deletions(-) diff --git a/R/scales-.r b/R/scales-.r index 2311335baa..73c490c8a2 100644 --- a/R/scales-.r +++ b/R/scales-.r @@ -173,99 +173,3 @@ ScalesList <- ggproto("ScalesList", NULL, } ) -# Train scale from a data frame -scales_train_df <- function(scales, df, drop = FALSE) { - if (empty(df) || length(scales$scales) == 0) return() - - lapply(scales$scales, function(scale) scale$train_df(df = df)) -} - -# Map values from a data.frame. Returns data.frame -scales_map_df <- function(scales, df) { - if (empty(df) || length(scales$scales) == 0) return(df) - - mapped <- unlist(lapply(scales$scales, function(scale) scale$map_df(df = df)), recursive = FALSE) - - data_frame0(!!!mapped, df[setdiff(names(df), names(mapped))]) -} - -# Transform values to cardinal representation -scales_transform_df <- function(scales, df) { - if (empty(df)) return(df) - - # if the scale contains no trans or the trans is of identity, it doesn't need - # to be transformed. - idx_skip <- vapply(scales$scales, function(x) { - has_default_transform(x) && - (is.null(x$trans) || identical(x$trans$transform, identity)) - }, logical(1L)) - scale_list <- scales$scales[!idx_skip] - - if (length(scale_list) == 0L) return(df) - - transformed <- unlist(lapply(scale_list, function(s) s$transform_df(df = df)), - recursive = FALSE) - untransformed <- df[setdiff(names(df), names(transformed))] - data_frame0(!!!transformed, untransformed) -} - -scales_backtransform_df <- function(scales, df) { - # NOTE: no need to check empty(data) because it should be already checked - # before this function is called. - - # if the scale contains no trans or the trans is of identity, it doesn't need - # to be backtransformed. - idx_skip <- vapply(scales$scales, function(x) { - is.null(x$trans) || - identical(x$trans$inverse, identity) - }, logical(1L)) - scale_list <- scales$scales[!idx_skip] - - if (length(scale_list) == 0L) return(df) - - backtransformed <- unlist(lapply(scale_list, function(scale) { - aesthetics <- intersect(scale$aesthetics, names(df)) - - if (length(aesthetics) == 0) return() - - lapply(df[aesthetics], scale$trans$inverse) - }), recursive = FALSE) - - new_data_frame(c(backtransformed, df[setdiff(names(df), names(backtransformed))])) -} - -# @param aesthetics A list of aesthetic-variable mappings. The name of each -# item is the aesthetic, and the value of each item is the variable in data. -scales_add_defaults <- function(scales, data, aesthetics, env) { - if (is.null(aesthetics)) return() - names(aesthetics) <- unlist(lapply(names(aesthetics), aes_to_scale)) - - new_aesthetics <- setdiff(names(aesthetics), scales$input()) - # No new aesthetics, so no new scales to add - if (is.null(new_aesthetics)) return() - - datacols <- lapply(aesthetics[new_aesthetics], eval_tidy, data = data) - datacols <- compact(datacols) - - for (aes in names(datacols)) { - scales$add(find_scale(aes, datacols[[aes]], env)) - } - -} - -# Add missing but required scales. -# @param aesthetics A character vector of aesthetics. Typically c("x", "y"). -scales_add_missing <- function(plot, aesthetics, env) { - - # Keep only aesthetics that aren't already in plot$scales - aesthetics <- setdiff(aesthetics, plot$scales$input()) - - for (aes in aesthetics) { - scale_name <- paste("scale", aes, "continuous", sep = "_") - - scale_f <- find_global(scale_name, env, mode = "function") - plot$scales$add(scale_f()) - } -} - -