diff --git a/DESCRIPTION b/DESCRIPTION index 105d3fc..c25adc3 100755 --- a/DESCRIPTION +++ b/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 Description: Graph making functions and wrappers for JASP. diff --git a/NAMESPACE b/NAMESPACE index d1768de..09da007 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/removeEnvironments.R b/R/removeEnvironments.R new file mode 100644 index 0000000..8b1fa7f --- /dev/null +++ b/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) + +} diff --git a/inst/examples/ex-removeEnvironments.R b/inst/examples/ex-removeEnvironments.R new file mode 100644 index 0000000..c7d9214 --- /dev/null +++ b/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 + +} diff --git a/man/removeEnvironments.Rd b/man/removeEnvironments.Rd new file mode 100644 index 0000000..9d8e313 --- /dev/null +++ b/man/removeEnvironments.Rd @@ -0,0 +1,62 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/removeEnvironments.R +\name{removeEnvironments} +\alias{removeEnvironments} +\title{removeEnvironments - remove environments from ggplot2 objects} +\usage{ +removeEnvironments(x, debugInfo = 0, ...) +} +\arguments{ +\item{x}{a plot object. Currently, only ggplot2 objects and jaspGraphsPlot are supported, other objects are returned unchanged} + +\item{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.} + +\item{...}{internal.} +} +\value{ +an object of the same class as the input +} +\description{ +removeEnvironments - remove environments from ggplot2 objects +} +\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 +} +\examples{ +# adapted from https://github.com/tidyverse/ggplot2/issues/4056 +\dontrun{ +demo <- function(n = 1e5) { + big_object <- rnorm(n) + dt <- data.frame(x = 1:10) + p <- ggplot2::ggplot(dt, ggplot2::aes(x, y)) + + ggplot2::geom_point() + + ggplot2::geom_point(ggplot2::aes(x = x+1, y = y+1)) +} + +sizeOnDisk <- function(obj) { + f <- tempfile() + saveRDS(obj) + res <- file.size(f) + file.remove(f) + res +} + +obj <- demo() +# object.size lies, but lobstr::obj_size does not +object.size(obj) +object.size(obj$plot_env$big_object) + +if (require("lobstr")) + lobstr::obj_size(obj) + +sizeOnDisk(obj) + +# note that to an extent, removeEnvironments modifies in place +obj <- removeEnvironments(obj) + +sizeOnDisk(obj) + + +} +}