standalone-ggcall.R

# ---
# repo: polkas/ggcall
# file: ggcall.R
# last-updated: 2024-11-21
# license: https://unlicense.org
# imports: ggplot2
# ---
#
# This file provides a minimal shim to provide a ggcall functionality on top of
# ggplot2.
#
# ## Changelog
#

# nocov start

#' Enhanced `ggplot` Function with History Tracking
#'
#' Overrides the default `ggplot` function from the ggplot2 package, adding the
#' capability to track the history of plot construction.
#' This function initializes a history attribute in the `ggplot` object.
#'
#' @param ... Arguments passed to the original ggplot function from ggplot2.
#'
#' @return A ggplot object of class 'ggcall', with an additional
#' attribute 'ggcall' that stores the history of plot construction.
#'
#' @seealso \code{\link[ggplot2]{ggplot}}
#' @rawNamespace import(ggplot2, except = c(ggplot))
#' @examples
#' library(ggplot2, exclude = "ggplot")
#' p <- ggplot(mtcars, aes(x = wt, y = mpg))
#' # the + function has to come from ggcall package
#' attr(p + geom_point(), "ggcall")
#'
#' @export
#'
ggplot <- function(...) {
  validate_ggplot()
  plot <- ggplot2::ggplot(...)

  # Initialize the history with the first call
  attr(plot, "ggcall") <- match.call()
  attr(plot, "ggcall_env") <- parent.frame()
  attr(plot, "ggcall_env_last") <- attr(plot, "ggcall_env")
  class(plot) <- c("ggcall", class(plot))

  plot
}

#' Custom '+' Operator for ggcall Objects
#'
#' Enhances the '+' operator for ggplot objects to track the history of
#' plot layers and modifications. This function is meant to be used in
#' conjunction with the enhanced ggplot function provided by this package.
#'
#' @param e1 A ggplot object of class 'ggcall'.
#' @param e2 A layer, theme or ggcall to add.
#'
#' @return A modified ggplot object with updated plot history.
#' @rdname ggcall-add-operator
#' @examples
#' library(ggplot2, exclude = "ggplot")
#' p <- ggplot(mtcars, aes(x = wt, y = mpg)) +
#'   geom_point()
#' attr(p, "ggcall") # View the plot call
#'
#' @export
#'
`+.gg` <- function(e1, e2) {
  validate_ggplot()

  gg_plus_function <- utils::getFromNamespace("+.gg", "ggplot2")

  if (inherits(e1, "ggcall")) {
    if (inherits(e2, "ggcall")) {
      if (!requireNamespace("patchwork", quietly = TRUE)) {
        stop("patchwork package has to be installed.")
      }
      newcall <- ggcall(e2)
    } else {
      newcall <- substitute(e2)
    }

    plot <- gg_plus_function(e1, e2)
    # substitute is faster than bquote
    attr(plot, "ggcall") <- substitute(lhs + rhs, env = list(lhs = ggcall(e1), rhs = newcall))

    if (!identical(attr(e1, "ggcall_env_last"), parent.frame())) {
      attr(plot, "ggcall_env") <- merge_env(attr(e1, "ggcall_env"), parent.frame())
    }

    attr(plot, "ggcall_env_last") <- parent.frame()
    class(plot) <- unique(c("ggcall", class(plot)))
  } else {
    plot <- gg_plus_function(e1, e2)
  }

  plot
}

#' Retrieve Construction Call from ggplot Object
#'
#' Extracts the complete history of a ggplot object's construction,
#' providing a way to reproduce or inspect the plot. Designed to work
#' with ggplot objects of class 'ggcall'.
#'
#' @param plot A ggplot object of class 'ggcall'.
#'
#' @return Depending on the value of 'call', either a callable expression or
#' a list representing the history of the ggplot object.
#'
#' @examples
#' library(ggplot2, exclude = "ggplot")
#' # Example: Create a function which combines a few ggplot layers
#' # Typically, it will be a function from your R package where you implemented ggcall
#' func <- function(data, x, y, bool = TRUE) {
#'   # layers have to be added with +
#'   gg <- ggplot(data, aes(x = !!as.name(x), y = !!as.name(y))) +
#'     geom_point(alpha = 0.4) +
#'     facet_grid(~gear)
#'
#'   if (bool) {
#'     gg <- gg + theme(axis.title.x = element_blank())
#'   }
#'
#'   func_internal <- function(gg) {
#'     gg + labs(x = "custom xlab")
#'   }
#'
#'   func_internal(gg)
#' }
#' plot_call <- ggcall(func(mtcars, "wt", "mpg"))
#' # Optionally: Style the code with styler
#' # deparse1 is recommended and available in R>=4.0.0
#' \dontrun{
#' styler::style_text(
#'   paste(deparse(plot_call), collapse = "\n")
#' )
#' }
#' @export
#'
ggcall <- function(plot) {
  stopifnot(inherits(plot, "ggcall"))
  res <- attr(plot, "ggcall")
  class(res) <- "ggcall_code"
  attr(res, "ggcall_env") <- attr(plot, "ggcall_env")
  res
}

#' Add Assignments to ggplot Construction Code
#'
#' This function modifies a `ggcall()` object by adding variable assignments
#' to it, ensuring that any atomic variables or non-atomic objects referenced
#' in the environment are explicitly assigned in the construction code.
#'
#' @param call A symbol (variable name) pointing a `ggcall_code` object, which represents a ggplot construction
#'             call generated by the `ggcall()` function.
#'
#' @param vars a `character` value. Optional vector of variable names to include from ggcall environment.
#' By default all environment variables connected with the call are added.
#' Please be careful when updating this argument.
#' @return A modified call with additional assignments for all the variables
#'         used in the construction code, ensuring the plot can be fully
#'         reconstructed from the code.
#' @note Currently only atomic variables are supported to be assign directly.
#' More complex variables are referenced to ggcall environment.
#'
#' @examples
#' library(ggplot2, exclude = "ggplot")
#' # Example: Create a function which combines a few ggplot layers
#' # Typically, it will be a function from your R package where you implemented ggcall
#' func <- function(data, x, y, bool = TRUE) {
#'   # layers have to be added with +
#'   gg <- ggplot(data, aes(x = !!as.name(x), y = !!as.name(y))) +
#'     geom_point(alpha = 0.4) +
#'     facet_grid(~gear)
#'
#'   if (bool) {
#'     gg <- gg + theme(axis.title.x = element_blank())
#'   }
#'
#'   func_internal <- function(gg) {
#'     gg + labs(x = "custom xlab")
#'   }
#'
#'   func_internal(gg)
#' }
#' plot_call <- ggcall(func(mtcars, "wt", "mpg"))
#' # Optionally: Add assignments
#' plot_call_with_assignments <- ggcall_add_assignments(plot_call)
#' \dontrun{
#' styler::style_text(
#'   paste(deparse(plot_call_with_assignments), collapse = "\n")
#' )
#' }
#' eval_ggcall(plot_call_with_assignments)
#'
#' # Will Fail as data is needed and skipped
#' \dontrun{
#' eval_ggcall(ggcall_add_assignments(plot_call, vars = c("x", "y")))
#' }
#' @export
ggcall_add_assignments <- function(call, vars = extract_names(call)) {
  stopifnot(inherits(call, "ggcall_code"))
  stopifnot(inherits(vars, "character"))

  ggcall_name <- substitute(call)
  if (!is.symbol(ggcall_name)) {
    stop("call argument has to be a symbol (variable name) pointing a ggcall() object.")
  }

  env <- ggcall_env(call)
  if (length(vars)) {
    var_names <- intersect(vars, ls(env))
  } else {
    var_names <- ls(env)
  }

  new_env <- new.env(parent = parent.env(.GlobalEnv))
  output <- list()
  for (var in var_names) {
    value <- get(var, envir = env)
    new_env[[var]] <- value
    if (is.atomic(value)) {
      output <- c(var = substitute(lhs <- rhs, list(lhs = as.name(var), rhs = value)), output)
    } else {
      output <- c(
        output,
        sprintf("# %s is %s", var, paste(class(value), collapse = ", ")),
        var = substitute(
          lhs <- ggcall_env(name)[[lhs_string]],
          list(lhs = as.name(var), lhs_string = var, name = as.name(ggcall_name))
        )
      )
    }
  }

  new_env[[as.character(ggcall_name)]] <- call

  structure(
    as.call(c(as.name("{"), c(output, "# ggcall call", call))),
    class = "ggcall_code",
    ggcall_env = new_env
  )
}

#' Evaluate ggcall
#'
#' This function evaluates an expression representing a ggplot construction code.
#' It specifically uses the environment stored in the 'ggcall_env' attribute
#' of the expression, ensuring that the plot is reconstructed in the correct context.
#'
#' @param call An expression representing the ggplot construction call, typically
#'          generated by `ggcall()`. This expression should have an
#'          attribute 'ggcall_env' that stores the environment in which
#'          the plot was originally created.
#' @param ... Additional variables passed to the evaluation environment.
#'
#' @return The resulting ggplot object produced by evaluating the expression `x`.
#'
#' @examples
#' library(ggplot2, exclude = "ggplot")
#'
#' func <- function() {
#'   ggplot(mtcars, aes(x = wt, y = mpg)) +
#'     geom_point()
#' }
#' gplot <- func()
#' plot_call <- ggcall(gplot)
#' reconstructed_plot <- eval_ggcall(plot_call)
#' print(reconstructed_plot)
#'
#' @export
#'
eval_ggcall <- function(call, ...) {
  stopifnot(inherits(call, "ggcall_code"))
  validate_ggplot()
  eval_env <- new.env(parent = attr(call, "ggcall_env"))
  ellipsis <- list(...)
  for (nam in names(ellipsis)) {
    eval_env[[nam]] <- ellipsis[[nam]]
  }
  if (is.null(eval_env[["..."]])) eval_env[["..."]] <- NULL
  eval(call, eval_env)
}

#' Retrieve Environment from ggcall
#' @description Extracts the environment in which the ggplot construction code
#' was originally created. This function is designed to work with expressions
#' generated by `ggcall`.
#' @param call An expression representing the ggplot construction code.
#' @return The environment in which the ggplot construction code was created.
#' @examples
#' library(ggplot2, exclude = "ggplot")
#' fun <- function(data, x, y) {
#'   ggplot(data, aes(x = !!as.name(x), y = !!as.name(y))) +
#'     geom_point()
#' }
#' gplot <- fun(mtcars, "wt", "mpg")
#' plot_call <- ggcall(gplot)
#' env <- ggcall_env(plot_call)
#' ls(env)
#' env[["data"]]
#' as.list(env)
#' @export
ggcall_env <- function(call) {
  stopifnot(inherits(call, "ggcall_code"))
  attr(call, "ggcall_env")
}

#' @keywords internal
validate_ggplot <- function() {
  if (!requireNamespace("ggplot2")) {
    stop("ggplot2 package has to be installed.")
  }
}

#' @keywords internal
merge_env <- function(to_env, from_env) {
  stopifnot(is.environment(to_env), is.environment(from_env))

  inter_env <- intersect(ls(to_env), ls(from_env))

  for (name in setdiff(ls(from_env), inter_env)) {
    to_env[[name]] <- from_env[[name]]
  }

  to_env
}

#' @keywords internal
extract_names <- function(expr) {
  if (is.symbol(expr)) {
    return(as.character(expr))
  }

  if (is.call(expr)) {
    func_name <- as.character(expr[[1]])
    args <- as.list(expr)[-1]
    arg_names <- unlist(lapply(args, extract_names))
    return(unique(c(func_name, arg_names)))
  }

  return(character())
}

# nocov end