Refactor: layers are touched only once.

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,

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
+}

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
+}
+
+

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)
+
+}

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)
+}

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
+}