diff --git a/DESCRIPTION b/DESCRIPTION
index 4f7b2f3..5c63b84 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -15,7 +15,7 @@ BugReports: https://github.com/eliocamp/ggnewscale/issues
Encoding: UTF-8
Imports:
ggplot2 (>= 3.0.0)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.2
Roxygen: list(markdown = TRUE)
Suggests:
testthat,
diff --git a/R/bump-aes-guides.R b/R/bump-aes-guides.R
new file mode 100644
index 0000000..969d205
--- /dev/null
+++ b/R/bump-aes-guides.R
@@ -0,0 +1,15 @@
+
+bump_aes_guides <- function(guides, original_aes, new_aes) {
+ for (g in seq_along(guides)) {
+ if (is_protected(guides[[g]], original_aes)) {
+ next
+ }
+
+ if (names(guides)[[g]] == original_aes) {
+ names(guides)[[g]] <- new_aes
+ guides[[g]] <- protect(guides[[g]], original_aes)
+ }
+ }
+
+ guides
+}
diff --git a/R/bump-aes-labels.R b/R/bump-aes-labels.R
new file mode 100644
index 0000000..6e9cd1c
--- /dev/null
+++ b/R/bump-aes-labels.R
@@ -0,0 +1,17 @@
+
+bump_aes_labels <- function(labels, original_aes, new_aes) {
+ for (l in seq_along(labels)) {
+ if (is_protected(labels[[l]], original_aes)) {
+ next
+ }
+
+ if (names(labels)[[l]] == original_aes) {
+ names(labels)[[l]] <- new_aes
+ labels[[l]] <- protect(labels[[l]], original_aes)
+ }
+ }
+
+ labels
+}
+
+
diff --git a/R/bump-aes-layers.R b/R/bump-aes-layers.R
new file mode 100644
index 0000000..9d8c768
--- /dev/null
+++ b/R/bump-aes-layers.R
@@ -0,0 +1,107 @@
+bump_aes_layer <- function(layer, original_aes, new_aes) {
+ # Don't touch it if it has been renamed previously
+ if (is_protected(layer, original_aes)) {
+ return(layer)
+ }
+
+ new_layer <- ggplot2::ggproto(NULL, layer)
+
+ # Get explicit mapping
+ old_aes <- names(new_layer$mapping)[names(new_layer$mapping) %in% original_aes]
+
+ # If not explicit, get the default
+ if (length(old_aes) == 0) {
+ old_aes <- names(new_layer$stat$default_aes)[names(new_layer$stat$default_aes) %in% original_aes]
+ if (length(old_aes) == 0) {
+ old_aes <- names(new_layer$geom$default_aes)[names(new_layer$geom$default_aes) %in% original_aes]
+ }
+ }
+ # Return unchanged layer if it doens't use this aes
+ if (length(old_aes) == 0) {
+ return(new_layer)
+ }
+
+ old_geom <- new_layer$geom
+
+ old_handle_na <- old_geom$handle_na
+ new_handle_na <- function(self, data, params) {
+ colnames(data)[colnames(data) %in% new_aes] <- original_aes
+ old_handle_na(data, params)
+ }
+
+ new_geom <- ggplot2::ggproto(paste0("New", class(old_geom)[1]), old_geom,
+ handle_na = new_handle_na)
+
+ new_geom$default_aes <- change_name(new_geom$default_aes, old_aes, new_aes)
+ new_geom$non_missing_aes <- change_name(new_geom$non_missing_aes, old_aes, new_aes)
+ new_geom$required_aes <- change_name(new_geom$required_aes, old_aes, new_aes)
+ new_geom$optional_aes <- change_name(new_geom$optional_aes, old_aes, new_aes)
+
+ draw_key <- new_geom$draw_key
+ new_draw_key <- function(data, params, size) {
+ colnames(data)[colnames(data) == new_aes] <- original_aes
+ draw_key(data, params, size)
+ }
+ new_geom$draw_key <- new_draw_key
+
+ new_layer$geom <- new_geom
+
+ old_stat <- new_layer$stat
+
+ new_handle_na <- function(self, data, params) {
+ colnames(data)[colnames(data) %in% new_aes] <- original_aes
+ ggplot2::ggproto_parent(self$super(), self)$handle_na(data, params)
+ }
+
+ new_setup_data <- function(self, data, scales, ...) {
+ # After setup data, I need to go back to the new aes names, otherwise
+ # scales are not applied.
+ colnames(data)[colnames(data) %in% new_aes] <- original_aes
+ data <- ggplot2::ggproto_parent(self$super(), self)$setup_data(data, scales, ...)
+ colnames(data)[colnames(data) %in% original_aes] <- new_aes
+ data
+ }
+
+ if (!is.null(old_stat$is_new)) {
+ parent <- old_stat$super()
+ } else {
+ parent <- ggplot2::ggproto(NULL, old_stat)
+ }
+
+ new_stat <- ggplot2::ggproto(paste0("New", class(old_stat)[1]), parent,
+ setup_data = new_setup_data,
+ handle_na = new_handle_na,
+ is_new = TRUE)
+
+ new_stat$default_aes <- change_name(new_stat$default_aes, old_aes, new_aes)
+ new_stat$non_missing_aes <- change_name(new_stat$non_missing_aes, old_aes, new_aes)
+ new_stat$required_aes <- change_name(new_stat$required_aes, old_aes, new_aes)
+ new_stat$optional_aes <- change_name(new_stat$optional_aes, old_aes, new_aes)
+
+ new_layer$stat <- new_stat
+
+ # Make implicit mapping explicit.
+ # This fixes https://github.com/eliocamp/ggnewscale/issues/45 but it feels
+ # wrong. I don't understand why implicit mapping breaks when adding more than
+ # one extra scale.
+ if (is.null(new_layer$mapping[[old_aes]])) {
+ new_layer$mapping[[old_aes]] <- new_stat$default_aes[[new_aes]]
+ }
+ new_layer$mapping <- change_name(new_layer$mapping, old_aes, new_aes)
+ new_layer$aes_params <- change_name(new_layer$aes_params, old_aes, new_aes)
+
+ # Restore custom attributes
+ attributes_old <- attributes(layer)
+ attributes_new <- attributes(new_layer)
+ attributes_replace <- attributes_old[setdiff(names(attributes_old), names(attributes_new))]
+ attributes(new_layer)[names(attributes_replace)] <- attributes_replace
+
+ new_layer <- protect(new_layer, original_aes)
+ new_layer
+}
+
+
+bump_aes_layers <- function(layers, original_aes, new_aes) {
+ lapply(layers, bump_aes_layer, original_aes = original_aes, new_aes = new_aes)
+
+}
diff --git a/R/bump-aes-scales.R b/R/bump-aes-scales.R
new file mode 100644
index 0000000..8ed12b0
--- /dev/null
+++ b/R/bump-aes-scales.R
@@ -0,0 +1,59 @@
+#' @importFrom ggplot2 guide_colourbar guide_colorbar guide_legend
+bump_aes_scale <- function(scale, original_aes, new_aes) {
+ if (is.null(scale)) {
+ return(scale)
+ }
+
+ if (is_protected(scale, original_aes)) {
+ return(scale)
+ }
+
+ old_aes <- scale$aesthetics[scale$aesthetics %in% original_aes]
+ if (length(old_aes) != 0) {
+ scale$aesthetics[scale$aesthetics %in% original_aes] <- new_aes
+
+ if (is.character(scale$guide)) {
+ no_guide <- isTRUE(scale$guide == "none")
+ } else {
+ no_guide <- isFALSE(scale$guide) ||
+ isTRUE(inherits(scale$guide, c("guide_none", "GuideNone")))
+ }
+ if (!no_guide) {
+ if (is.character(scale$guide)) {
+ scale$guide <- get(paste0("guide_", scale$guide), mode = "function")()
+ }
+ if (inherits(scale$guide, "Guide")) {
+ # Make clone of guie
+ old <- scale$guide
+ new <- ggplot2::ggproto(NULL, old)
+
+ # Change available aesthetics
+ new$available_aes <- change_name(new$available_aes, old_aes, new_aes)
+ new$available_aes[new$available_aes %in% old_aes] <- new_aes
+
+ # Update aesthetic override
+ if (!is.null(new$params$override.aes)) {
+ new$params$override.aes <- change_name(new$params$override.aes, old_aes, new_aes)
+ }
+
+ # Re-assign updated guide
+ scale$guide <- new
+ } else {
+ scale$guide$available_aes[scale$guide$available_aes %in% old_aes] <- new_aes
+
+ if (!is.null(scale$guide$override.aes)) {
+ names(scale$guide$override.aes)[names(scale$guide$override.aes) == old_aes] <- new_aes
+ }
+ }
+
+ }
+ }
+
+ scale <- protect(scale, original_aes)
+ scale
+}
+
+
+bump_aes_scales <- function(scales, original_aes, new_aes) {
+ lapply(scales, bump_aes_scale, original_aes = original_aes, new_aes = new_aes)
+}
diff --git a/R/ggplot-add.R b/R/ggplot-add.R
new file mode 100644
index 0000000..28d074a
--- /dev/null
+++ b/R/ggplot-add.R
@@ -0,0 +1,30 @@
+
+#' @export
+#' @importFrom ggplot2 ggplot_add
+ggplot_add.new_aes <- function(object, plot, object_name) {
+ # To add default scales (I need to build the whole plot because they might be computed aesthetics)
+ if (is.null(plot$scales$get_scales(object))) {
+ built <- ggplot2::ggplot_build(plot)
+ plot$scales$add(built$plot$scales$get_scales(object))
+ }
+
+ scale_number <- (plot$ggnewscale_scales[[object]] %||% 0) + 1
+ new_aes <- aes_name(object, scale_number)
+
+ # Global aes
+ old_aes <- names(plot$mapping)[names(plot$mapping) %in% object]
+ names(plot$mapping)[names(plot$mapping) == old_aes] <- new_aes
+
+ plot$layers <- bump_aes_layers(plot$layers, original_aes = object, new_aes = new_aes)
+ plot$scales$scales <- bump_aes_scales(plot$scales$scales, original_aes = object, new_aes = new_aes)
+ plot$labels <- bump_aes_labels(plot$labels, original_aes = object, new_aes = new_aes)
+ plot$guides$guides <- bump_aes_guides(plot$guides$guides, original_aes = object, new_aes = new_aes)
+
+ if (is.null(plot$ggnewscale_scales[[object]])) {
+ plot$ggnewscale_scales[[object]] <- 1
+ } else {
+ plot$ggnewscale_scales[[object]] <- plot$ggnewscale_scales[[object]] + 1
+ }
+
+ plot
+}
\ No newline at end of file
diff --git a/R/new-scale.R b/R/new-scale.R
index 7a5b438..ba719e8 100644
--- a/R/new-scale.R
+++ b/R/new-scale.R
@@ -56,237 +56,6 @@ new_scale_colour <- function() {
new_scale("colour")
}
-#' @export
-#' @importFrom ggplot2 ggplot_add
-ggplot_add.new_aes <- function(object, plot, object_name) {
- # To add default scales (I need to build the whole plot because they might be computed aesthetics)
- if (is.null(plot$scales$get_scales(object))) {
- plot$scales <- ggplot2::ggplot_build(plot)$plot$scales
- }
- # Global aes
- old_aes <- names(plot$mapping)[remove_new(names(plot$mapping)) %in% object]
- new_aes <- paste0(old_aes, "_new")
- names(plot$mapping)[names(plot$mapping) == old_aes] <- new_aes
-
- plot$layers <- bump_aes_layers(plot$layers, new_aes = object)
- plot$scales$scales <- bump_aes_scales(plot$scales$scales, new_aes = object)
- plot$labels <- bump_aes_labels(plot$labels, new_aes = object)
- plot$guides <- bump_aes_guides(plot$guides, new_aes = object)
-
- plot
-}
-
-
-bump_aes_guides <- function(guides, new_aes) {
- original_aes <- new_aes
-
- if (inherits(guides, "Guides")) {
- to_change <- remove_new(names(guides$guides)) == original_aes
-
- if (any(to_change)) {
- names(guides$guides)[to_change] <- paste0(names(guides$guides), "_new")
- }
- } else {
- to_change <- remove_new(names(guides)) == original_aes
-
- if (any(to_change)) {
- names(guides)[to_change] <- paste0(names(guides), "_new")
- }
- }
-
- return(guides)
-}
-
-bump_aes_layers <- function(layers, new_aes) {
- lapply(layers, bump_aes_layer, new_aes = new_aes)
-
-}
-
-bump_aes_layer <- function(layer, new_aes) {
- original_aes <- new_aes
-
- new_layer <- ggplot2::ggproto(NULL, layer)
-
- # Get explicit mapping
- old_aes <- names(new_layer$mapping)[remove_new(names(new_layer$mapping)) %in% new_aes]
-
- # If not explicit, get the default
- if (length(old_aes) == 0) {
- old_aes <- names(new_layer$stat$default_aes)[remove_new(names(new_layer$stat$default_aes)) %in% new_aes]
- if (length(old_aes) == 0) {
- old_aes <- names(new_layer$geom$default_aes)[remove_new(names(new_layer$geom$default_aes)) %in% new_aes]
- }
- }
- # Return unchanged layer if it doens't use this aes
- if (length(old_aes) == 0) {
- return(new_layer)
- }
-
- new_aes <- paste0(old_aes, "_new")
-
- old_geom <- new_layer$geom
-
- old_handle_na <- old_geom$handle_na
- new_handle_na <- function(self, data, params) {
- colnames(data)[colnames(data) %in% new_aes] <- original_aes
- old_handle_na(data, params)
- }
-
- new_geom <- ggplot2::ggproto(paste0("New", class(old_geom)[1]), old_geom,
- handle_na = new_handle_na)
-
- new_geom$default_aes <- change_name(new_geom$default_aes, old_aes, new_aes)
- new_geom$non_missing_aes <- change_name(new_geom$non_missing_aes, old_aes, new_aes)
- new_geom$required_aes <- change_name(new_geom$required_aes, old_aes, new_aes)
- new_geom$optional_aes <- change_name(new_geom$optional_aes, old_aes, new_aes)
-
- draw_key <- new_geom$draw_key
- new_draw_key <- function(data, params, size) {
- colnames(data)[colnames(data) == new_aes] <- original_aes
- draw_key(data, params, size)
- }
- new_geom$draw_key <- new_draw_key
-
- new_layer$geom <- new_geom
-
- old_stat <- new_layer$stat
-
- new_handle_na <- function(self, data, params) {
- colnames(data)[colnames(data) %in% new_aes] <- original_aes
- ggplot2::ggproto_parent(self$super(), self)$handle_na(data, params)
- }
-
- new_setup_data <- function(self, data, scales, ...) {
- # After setup data, I need to go back to the new aes names, otherwise
- # scales are not applied.
- colnames(data)[colnames(data) %in% new_aes] <- original_aes
- data <- ggplot2::ggproto_parent(self$super(), self)$setup_data(data, scales, ...)
- colnames(data)[colnames(data) %in% original_aes] <- new_aes
- data
- }
-
- if (!is.null(old_stat$is_new)) {
- parent <- old_stat$super()
- } else {
- parent <- ggplot2::ggproto(NULL, old_stat)
- }
-
- new_stat <- ggplot2::ggproto(paste0("New", class(old_stat)[1]), parent,
- setup_data = new_setup_data,
- handle_na = new_handle_na,
- is_new = TRUE)
-
- new_stat$default_aes <- change_name(new_stat$default_aes, old_aes, new_aes)
- new_stat$non_missing_aes <- change_name(new_stat$non_missing_aes, old_aes, new_aes)
- new_stat$required_aes <- change_name(new_stat$required_aes, old_aes, new_aes)
- new_stat$optional_aes <- change_name(new_stat$optional_aes, old_aes, new_aes)
- new_layer$stat <- new_stat
-
- # Make implicit mapping explicit.
- # This fixes https://github.com/eliocamp/ggnewscale/issues/45 but it feels
- # wrong. I don't understand why implicit mapping breaks when adding more than
- # one extra scale.
- if (is.null(new_layer$mapping[[old_aes]])) {
- new_layer$mapping[[old_aes]] <- new_stat$default_aes[[new_aes]]
- }
- new_layer$mapping <- change_name(new_layer$mapping, old_aes, new_aes)
- new_layer$aes_params <- change_name(new_layer$aes_params, old_aes, new_aes)
-
- # Restore custom attributes
- attributes_old <- attributes(layer)
- attributes_new <- attributes(new_layer)
- attributes_replace <- attributes_old[setdiff(names(attributes_old), names(attributes_new))]
-
- attributes(new_layer)[names(attributes_replace)] <- attributes_replace
- new_layer
-}
-
-bump_aes_scales <- function(scales, new_aes) {
- lapply(scales, bump_aes_scale, new_aes = new_aes)
-}
-
-#' @importFrom ggplot2 guide_colourbar guide_colorbar guide_legend
-bump_aes_scale <- function(scale, new_aes) {
- old_aes <- scale$aesthetics[remove_new(scale$aesthetics) %in% new_aes]
- if (length(old_aes) != 0) {
- new_aes <- paste0(old_aes, "_new")
-
- scale$aesthetics[scale$aesthetics %in% old_aes] <- new_aes
-
- if (is.character(scale$guide)) {
- no_guide <- isTRUE(scale$guide == "none")
- } else {
- no_guide <- isFALSE(scale$guide) ||
- isTRUE(inherits(scale$guide, c("guide_none", "GuideNone")))
- }
- if (!no_guide) {
- if (is.character(scale$guide)) {
- scale$guide <- get(paste0("guide_", scale$guide), mode = "function")()
- }
- if (inherits(scale$guide, "Guide")) {
- # Make clone of guie
- old <- scale$guide
- new <- ggplot2::ggproto(NULL, old)
-
- # Change available aesthetics
- new$available_aes <- change_name(new$available_aes, old_aes, new_aes)
- new$available_aes[new$available_aes %in% old_aes] <- new_aes
-
- # Update aesthetic override
- if (!is.null(new$params$override.aes)) {
- new$params$override.aes <- change_name(new$params$override.aes, old_aes, new_aes)
- }
-
- # Re-assign updated guide
- scale$guide <- new
- } else {
- scale$guide$available_aes[scale$guide$available_aes %in% old_aes] <- new_aes
-
- if (!is.null(scale$guide$override.aes)) {
- names(scale$guide$override.aes)[names(scale$guide$override.aes) == old_aes] <- new_aes
- }
- }
-
- }
- }
-
- scale
-}
-
-bump_aes_labels <- function(labels, new_aes) {
- old_aes <- names(labels)[remove_new(names(labels)) %in% new_aes]
- new_aes <- paste0(old_aes, "_new")
-
- names(labels)[names(labels) %in% old_aes] <- new_aes
- labels
-}
-
-
-change_name <- function(list, old, new) {
- UseMethod("change_name")
-}
-
-change_name.character <- function(list, old, new) {
- list[list %in% old] <- new
- list
-}
-
-change_name.default <- function(list, old, new) {
- nam <- names(list)
- nam[nam %in% old] <- new
- names(list) <- nam
- list
-}
-
-change_name.NULL <- function(list, old, new) {
- NULL
-}
-
-
-remove_new <- function(aes) {
- gsub("(_new)*", "", aes, fixed = FALSE)
- # stringi::stri_replace_all(aes, "", regex = "(_new)*")
-}
diff --git a/R/utils.R b/R/utils.R
index f984324..5cdb313 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -5,4 +5,67 @@ isTRUE <- function (x) {
isFALSE <- function (x) {
is.logical(x) && length(x) == 1L && !is.na(x) && !x
-}
\ No newline at end of file
+}
+
+
+`%||%` <- function(x, default) {
+ if (is.null(x)) default else x
+}
+
+remove_new <- function(aes) {
+ gsub("_ggnewscale_\\d+", "", aes, fixed = FALSE)
+}
+
+aes_name <- function(aes, scale_number) {
+ paste0(aes, "_ggnewscale_", scale_number)
+}
+
+
+change_name <- function(list, old, new) {
+ UseMethod("change_name")
+}
+
+change_name.character <- function(list, old, new) {
+ list[list %in% old] <- new
+ list
+}
+
+change_name.default <- function(list, old, new) {
+ nam <- names(list)
+ nam[nam %in% old] <- new
+ names(list) <- nam
+ list
+}
+
+change_name.NULL <- function(list, old, new) {
+ NULL
+}
+
+
+protect <- function(object, aes) {
+ UseMethod("protect")
+}
+
+protect.default <- function(object, aes) {
+ object$ggnewscale_renamed <- unique(c(object$ggnewscale_renamed, aes))
+ return(object)
+}
+
+protect.character <- function(object, aes) {
+ attr(object, "ggnewscale_renamed") <- unique(c(attr(object, "ggnewscale_renamed"), aes))
+ return(object)
+}
+
+
+
+is_protected <- function(object, aes) {
+ UseMethod("is_protected")
+}
+
+is_protected.default <- function(object, aes) {
+ aes %in% object$ggnewscale_renamed
+}
+
+is_protected.character <- function(object, aes) {
+ aes %in% attr(object, "ggnewscale_renamed")
+}
diff --git a/tests/testthat/_snaps/newscale/implicit-mapping.svg b/tests/testthat/_snaps/newscale/implicit-mapping.svg
index e60b8ee..2267e08 100644
--- a/tests/testthat/_snaps/newscale/implicit-mapping.svg
+++ b/tests/testthat/_snaps/newscale/implicit-mapping.svg
@@ -339,105 +339,105 @@
-
+
-
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-
+
-
+
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
-
-
+
+
+
+
-
-
+
+
-
-
-
-
-
+
+
+
+
+
-
+
-
-
+
+
@@ -463,56 +463,59 @@
12
x
y
-
-1
-
-
-
-
-
-
-5
-10
-15
-
-2
-
-
-
-
-
-
-
-
-2.5
-5.0
-7.5
-10.0
-
-3
-
-
-
-
-
-
-
-
-2.5
-5.0
-7.5
-10.0
-
-4
-
-
-
-
-
-
-5
-10
-15
+
+1
+
+
+
+
+
+
+5
+10
+15
+
+2
+
+
+
+
+
+
+
+
+2.5
+5.0
+7.5
+10.0
+
+3
+
+
+
+
+
+
+
+
+2.5
+5.0
+7.5
+10.0
+
+4
+
+
+
+
+
+
+
+
+3
+6
+9
+12
implicit mapping
diff --git a/tests/testthat/test-newscale.R b/tests/testthat/test-newscale.R
index dcbdf36..3a7884a 100644
--- a/tests/testthat/test-newscale.R
+++ b/tests/testthat/test-newscale.R
@@ -111,6 +111,28 @@ test_that("works with many layers", {
})
+test_that("previous layers don't change" , {
+ data <- expand.grid(y = 1:4, x = 1:4)
+ data$z <- c("a", "b")
+
+ layer <- function(number) {
+ list(new_scale_fill(),
+ geom_tile(data = ~.x[.x$x == number, ], aes(fill = z)),
+ scale_fill_brewer(name = number, palette = number*2, guide = guide_legend(order = number))
+ )
+ }
+ g1 <- ggplot(data, aes(x, y)) +
+ layer(1) +
+ layer(2)
+
+ g2 <- g1 +
+ layer(3) +
+ layer(4)
+
+ expect_equal(g2$layers[[1]]$mapping, g1$layers[[1]]$mapping)
+})
+
+
test_that("changes override.aes", {
skip_if_not_installed("vdiffr")
# from https://github.com/r-lib/vdiffr/issues/98