Add function to remove environments tracked by ggplot2

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: jaspGraphs
 Type: Package
 Title: Custom Graphs for JASP
-Version: 0.5.2.12
+Version: 0.5.2.14
 Author: Don van den Bergh
 Maintainer: JASP-team <[email protected]>
 Description: Graph making functions and wrappers for JASP.

NAMESPACE

@@ -24,6 +24,9 @@ S3method(plot,jaspGraphs)
 S3method(plot,jaspGraphsPlot)
 S3method(print,jaspGraphs)
 S3method(print,jaspGraphsPlot)
+S3method(removeEnvironments,default)
+S3method(removeEnvironments,ggplot)
+S3method(removeEnvironments,jaspGraphsPlot)
 export(.graphOptions)
 export(GeomAbline2)
 export(GeomAlignedText)
@@ -58,6 +61,7 @@ export(plotEditing)
 export(plotEditingOptions)
 export(plotPieChart)
 export(plotQQnorm)
+export(removeEnvironments)
 export(scale_JASPcolor_continuous)
 export(scale_JASPcolor_discrete)
 export(scale_JASPfill_continuous)

R/removeEnvironments.R

@@ -0,0 +1,169 @@
+#' @title removeEnvironments - remove environments from ggplot2 objects
+#' @param x a plot object. Currently, only ggplot2 objects and jaspGraphsPlot are supported, other objects are returned unchanged
+#' @param debugInfo Should debugInfo be printed? Possible values are 0, no info is shown; 1, some info is shown; or 2, a lot of info is shown.
+#' @param ... internal.
+#'
+#' @details This function may breaks ggplot2 objects that rely on looking up values in environments.
+#' see also https://github.com/tidyverse/ggplot2/issues/3994 and https://github.com/tidyverse/ggplot2/issues/4056
+#'
+#' @example inst/examples/ex-removeEnvironments.R
+#' @returns an object of the same class as the input
+#' @export
+removeEnvironments <- function(x, debugInfo = 0,...) {
+  UseMethod("removeEnvironments", x)
+}
+
+#' @export
+removeEnvironments.ggplot <- function(x, debugInfo = 0, ...) {
+  x$plot_env <- rlang::new_environment()
+  return(removeEnvironmentsInner(x, debugInfo = debugInfo, ...))
+}
+
+#' @export
+removeEnvironments.jaspGraphsPlot <- function(x, debugInfo = 0, ...) {
+
+  for (i in seq_along(x)) {
+    if (debugInfo >= 1) cat("subplot", i, "\n")
+    x[[i]] <- removeEnvironmentsInner(x, debugInfo = debugInfo, ...)
+  }
+  return(x)
+}
+
+#' @export
+removeEnvironments.default <- function(x, debugInfo = 0, ...) {
+  if (debugInfo >= 1) cat("dispatched to removeEnvironments.default\n")
+  return(x)
+}
+
+removeEnvironmentsInner <- function(
+    x,
+    exitEarlyClasses = c("unit", "element", "data.frame", "FacetNull"),
+    replacementEnv = rlang::new_environment(parent = baseenv()),
+    environmentsAlreadyVisited = rlang::new_environment(),
+    debugInfo = 1,
+    level = deparse1(substitute(x))) {
+
+  if (inherits(x, exitEarlyClasses) || isNamespace(x))
+    return(x)
+
+  if (debugInfo >= 2) {
+    cat("level:", level, "\n")
+    cat("class:", paste(class(x), collapse = ", "), "\n")
+  }
+
+  if (inherits(x, "uneval")) { # returned by ggplot2::aes
+
+    if (debugInfo >= 1) {
+      cat("level:", level, "\n")
+      cat("class:", paste(class(x), collapse = ", "), "\n")
+      cat("replacing environment of subelements of x\n")
+    }
+
+    for (i in seq_along(x)) {
+      environment(x[[i]]) <- replacementEnv
+    }
+
+  } else if (inherits(x, "gtable")) {
+
+    # gtable has special indexing with [[ and integers so we use names
+    for (i in setdiff(names(x), c("widths", "heights"))) {
+      if (!is.null(x[[i]])) {
+        level <- paste0(level, "$", i)
+        x[[i]] <- Recall(x[[i]], exitEarlyClasses, replacementEnv, environmentsAlreadyVisited, debugInfo, level)
+      }
+    }
+
+  } else if (is.list(x)) {
+
+    if (!is.null(environment(x)) && !isNamespace(environment(x))) {
+      if (debugInfo >= 1) {
+        cat("level:", level, "\n")
+        cat("class:", paste(class(x), collapse = ", "), "\n")
+        cat("replacing environment(x)\n")
+      }
+      environment(x) <- replacementEnv
+    }
+
+    nms <- names(x)
+    for (i in seq_along(x)) {
+      if (!is.null(x[[i]])) {
+
+        if (is.null(nms) || nms[i] == "") {
+          newlevel <- paste0(level, "[[", i, "]]")
+        } else {
+          newlevel <- paste0(level, "$", nms[i])
+        }
+        x[[i]] <- Recall(x[[i]], exitEarlyClasses, replacementEnv, environmentsAlreadyVisited, debugInfo, newlevel)
+      }
+    }
+
+  } else if (ggplot2::is.ggproto(x)) {
+
+    if (inherits(x, "LayerInstance") && inherits(x$geom, "GeomCustomAnn")) {
+
+      # cowplot saves unnecessary stuff
+      super <- .subset2(x, "super")
+      superEnv <- environment(super)
+      superEnv$env$geom_params <- NULL
+      superEnv$env$params <- NULL
+      superEnv$env$geom <- NULL
+
+    }
+
+    hash <- rlang::hash(x)
+    if (!exists(hash, envir = environmentsAlreadyVisited)) {
+
+      environmentsAlreadyVisited[[hash]] <- NULL
+      nms <- union(names(x), names(as.list(x)))
+      for (i in nms) {
+        if (!is.null(.subset2(x, i)) && !isNamespace(environment(.subset2(x, i)))) {
+          newlevel <- paste0(level, "$", i)
+          x[[i]] <- Recall(.subset2(x, i), exitEarlyClasses, replacementEnv, environmentsAlreadyVisited, debugInfo, newlevel)
+        }
+      }
+
+    }
+
+  } else if (is.environment(x) && !isNamespace(x) && !identical(x, .GlobalEnv)) {
+
+    hash <- rlang::hash(x)
+    if (!exists(hash, envir = environmentsAlreadyVisited)) {
+
+      environmentsAlreadyVisited[[hash]] <- NULL
+      for (i in names(x)) {
+        newlevel <- paste0(level, "$", i)
+        x[[i]] <- Recall(x[[i]], exitEarlyClasses, replacementEnv, environmentsAlreadyVisited, debugInfo, newlevel)
+      }
+    }
+
+  } else if (is.function(x)) {
+
+    hash <- rlang::hash(x)
+    if (!exists(hash, envir = environmentsAlreadyVisited)) {
+
+      environmentsAlreadyVisited[[hash]] <- NULL
+      newlevel <- paste0("environment(", level, ")")
+      environment(x) <- Recall(environment(x), exitEarlyClasses, replacementEnv, environmentsAlreadyVisited, debugInfo, newlevel)
+
+    }
+
+  } else if (!is.null(x) && !is.function(x) && !is.null(environment(x)) && !isNamespace(environment(x))) {
+    if (debugInfo >= 1) {
+      cat("level:", level, "\n")
+      cat("class:", paste(class(x), collapse = ", "), "\n")
+      cat("replacing environment(x)\n")
+    }
+    environment(x) <- replacementEnv
+  } else if (mode(x) == "...") {
+    # DOTSXP objects...
+    if (debugInfo >= 1) {
+      cat("level:", level, "\n")
+      cat("class:", paste(class(x), collapse = ", "), "\n")
+      cat("replacing DOTSXP with NULL\n")
+    }
+    return(NULL)
+  }
+
+  return(x)
+
+}

inst/examples/ex-removeEnvironments.R

@@ -0,0 +1,64 @@
+\dontrun{
+demo <- function(n = 1e6) {
+  # adapted from https://github.com/tidyverse/ggplot2/issues/4056
+  big_object <- rnorm(n)
+  df <- data.frame(x = -5:5, y = abs(-5:5))
+  ggplot2::ggplot(df, ggplot2::aes(x, y)) +
+    ggplot2::geom_point() +
+    ggplot2::geom_point(ggplot2::aes(x = x+1, y = y+1), color = "green")
+}
+
+sizeOnDisk <- function(obj) {
+  f <- tempfile()
+  saveRDS(obj, file = f)
+  sz <- file.size(f)
+  file.remove(f)
+  class(sz) <- "object_size"
+  sz
+}
+
+obj <- demo()
+obj
+
+# object.size lies about the size but
+print(object.size(obj), units = "auto")
+# 7.1 Kb
+
+print(object.size(obj$plot_env$big_object), units = "auto")
+# 7.6 Mb
+
+# lobstr::obj_size follows environments and does not lie about the size
+if (require("lobstr")) {
+  sz <- lobstr::obj_size(obj)
+  class(sz) <- "object_size"
+  print(sz, units = "auto")
+  # 8.5 Mb
+}
+
+print(sizeOnDisk(obj), units = "auto")
+# 7.4 Mb
+
+# note that to an extent, removeEnvironments modifies in place
+obj <- removeEnvironments(obj)
+
+obj # still works
+
+print(sizeOnDisk(obj), units = "auto")
+# 33 Kb
+
+# removeEnvironments may break plots that rely on looking things up in the parent environment
+demoBad <- function() {
+  x = -5:5
+  y = abs(-5:5)
+  ggplot2::ggplot(mapping = ggplot2::aes(x, y)) +
+    ggplot2::geom_point() +
+    ggplot2::geom_point(ggplot2::aes(x = x+1, y = y+1), color = "red")
+}
+
+obj <- demoBad()
+obj # works
+
+obj <- removeEnvironments(obj)
+obj # Error in FUN(X[[i]], ...) : object 'x' not found
+
+}