diff --git a/R/coord-.R b/R/coord-.R index 0d0bb5ecb9..381a8a8824 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) { @@ -93,12 +95,12 @@ 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() }, 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] @@ -119,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] ) @@ -146,7 +144,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)) @@ -200,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)]) ) }, diff --git a/R/facet-.R b/R/facet-.R index 2e349f6f97..f88201f4cc 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -90,50 +90,39 @@ 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()) - } - if (!is.null(y_scale)) { - scales$y <- lapply(seq_len(max(layout$SCALE_Y)), function(i) y_scale$clone()) + init_scales = function(layout, scales, params) { + for (aes in names(scales)) { + if (is.null(scales[[aes]])) { + next + } + 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]]) } } }, - 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 +152,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 +186,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..67792c6e99 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 ) @@ -86,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, @@ -97,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, @@ -118,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 - } - 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 + + 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 + ) + } } self$facet$train_scales( - self$panel_scales_x, - self$panel_scales_y, + self$panel_scales, layout, data, self$facet_params @@ -141,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 - # 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) + for (aes in aesthetics) { + vars <- intersect(self$panel_scales[[aes]][[1]]$aesthetics, names(layer_data)) + if (length(vars) < 1) { + next } - 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 + # Loop through each variable, mapping across each scale, then joining + # back together + 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 @@ -173,49 +158,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) { diff --git a/R/plot-build.R b/R/plot-build.R index 36f33616fd..5e1e049e23 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -68,10 +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) @@ -80,7 +83,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") @@ -93,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) @@ -104,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) @@ -154,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/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) { 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")) 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) {