Skip to content

Commit

Permalink
ScalesList methods (#5144)
Browse files Browse the repository at this point in the history 
* Convert `scales_*()` functions to ScalesList methods

* Use ScalesList methods instead of functions

* Decommission `scales_*()` functions
  • Loading branch information
@teunbrand
teunbrand authored Apr 22, 2023
1 parent cb39362 commit f6e87ac
Show file tree
Hide file tree
Showing 3 changed files with 101 additions and 86 deletions.
8 changes: 4 additions & 4 deletions R/layer.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -348,7 +348,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)
Expand Down Expand Up @@ -376,11 +376,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)
Expand Down
8 changes: 4 additions & 4 deletions R/plot-build.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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")
Expand All @@ -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.
Expand Down
171 changes: 93 additions & 78 deletions R/scales-.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -59,102 +59,117 @@ ScalesList <- ggproto("ScalesList", NULL,
scale <- self$scales[self$find(output)]
if (length(scale) == 0) return()
scale[[1]]
}
)

# 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]
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))
},

if (length(scale_list) == 0L) return(df)
map_df = function(self, df) {
if (empty(df) || length(self$scales) == 0) {
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)
}
mapped <- unlist(lapply(
self$scales,
function(scale) scale$map_df(df = df)
), recursive = FALSE)

scales_backtransform_df <- function(scales, df) {
# NOTE: no need to check empty(data) because it should be already checked
# before this function is called.
data_frame0(!!!mapped, df[setdiff(names(df), names(mapped))])
},

# 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]
transform_df = function(self, df) {
if (empty(df)) {
return(df)
}

if (length(scale_list) == 0L) 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]

backtransformed <- unlist(lapply(scale_list, function(scale) {
aesthetics <- intersect(scale$aesthetics, names(df))
if (length(scales) == 0) {
return(df)
}

if (length(aesthetics) == 0) return()
transformed <- unlist(lapply(
scales,
function(scale) scale$transform_df(df = df)
), recursive = FALSE)

lapply(df[aesthetics], scale$trans$inverse)
}), recursive = FALSE)
data_frame0(!!!transformed, df[setdiff(names(df), names(transformed))])
},

new_data_frame(c(backtransformed, df[setdiff(names(df), names(backtransformed))]))
}
backtransform_df = function(self, df) {
# NOTE: no need to check empty(df) because it should be already checked
# before this method is called.

# @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))
# 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]

new_aesthetics <- setdiff(names(aesthetics), scales$input())
# No new aesthetics, so no new scales to add
if (is.null(new_aesthetics)) return()
if (length(scales) == 0) {
return(df)
}

datacols <- lapply(aesthetics[new_aesthetics], eval_tidy, data = data)
datacols <- compact(datacols)
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))]
)
},

for (aes in names(datacols)) {
scales$add(find_scale(aes, datacols[[aes]], env))
}
# `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()
}

# Add missing but required scales.
# @param aesthetics A character vector of aesthetics. Typically c("x", "y").
scales_add_missing <- function(plot, aesthetics, env) {
data_cols <- lapply(aesthetics[new_aesthetics], eval_tidy, data = data)
data_cols <- compact(data_cols)

# Keep only aesthetics that aren't already in plot$scales
aesthetics <- setdiff(aesthetics, plot$scales$input())
for (aes in names(data_cols)) {
self$add(find_scale(aes, data_cols[[aes]], env))
}
},

for (aes in aesthetics) {
scale_name <- paste("scale", aes, "continuous", sep = "_")
# 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())

scale_f <- find_global(scale_name, env, mode = "function")
plot$scales$add(scale_f())
for (aes in aesthetics) {
scale_name <- paste("scale", aes, "continuous", sep = "_")
self$add(find_global(scale_name, env, mode = "function")())
}
}
}

)

0 comments on commit f6e87ac

Please sign in to comment.