teal.code coverage - 90.43%

Files
Source

#' Evaluate code in `qenv`
#'
#' @details
#' `eval_code` evaluates given code in the `qenv` environment and appends it to the `code` slot.
#' Thus, if the `qenv` had been instantiated empty, contents of the environment are always a result of the stored code.
#'
#' @param object (`qenv`)
#' @param code (`character` or `language`) code to evaluate. If `character`, comments are retained.
#'
#' @return
#' `eval_code` returns a `qenv` object with `expr` evaluated or `qenv.error` if evaluation fails.
#'
#' @examples
#' # evaluate code in qenv
#' q <- qenv()
#' q <- eval_code(q, "a <- 1")
#' q <- eval_code(q, quote(library(checkmate)))
#' q <- eval_code(q, expression(assert_number(a)))
#'
#' @name eval_code
#' @rdname qenv
#' @aliases eval_code,qenv,character-method
#' @aliases eval_code,qenv,language-method
#' @aliases eval_code,qenv,expression-method
#' @aliases eval_code,qenv.error,ANY-method
#'
#' @export
setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))

setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
  id <- sample.int(.Machine$integer.max, size = 1)

  object@id <- c(object@id, id)
  object@env <- rlang::env_clone(object@env, parent = parent.env(.GlobalEnv))
  code <- paste(code, collapse = "\n")
  object@code <- c(object@code, code)

  current_warnings <- ""
  current_messages <- ""

  parsed_code <- parse(text = code, keep.source = TRUE)
  for (single_call in parsed_code) {
    # Using withCallingHandlers to capture warnings and messages.
    # Using tryCatch to capture the error and abort further evaluation.
    x <- withCallingHandlers(
      tryCatch(
        {
          eval(single_call, envir = object@env)
          if (!identical(parent.env(object@env), parent.env(.GlobalEnv))) {
            # needed to make sure that @env is always a sibling of .GlobalEnv
            # could be changed when any new package is added to search path (through library or require call)
            parent.env(object@env) <- parent.env(.GlobalEnv)
          }
          NULL
        },
        error = function(e) {
          errorCondition(
            message = sprintf(
              "%s \n when evaluating qenv code:\n%s",
              .ansi_strip(conditionMessage(e)),
              deparse1(single_call)
            ),
            class = c("qenv.error", "try-error", "simpleError"),
            trace = object@code
          )
        }
      ),
      warning = function(w) {
        current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w))))
        invokeRestart("muffleWarning")
      },
      message = function(m) {
        current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m))))
        invokeRestart("muffleMessage")
      }
    )

    if (!is.null(x)) {
      return(x)
    }
  }


  object@warnings <- c(object@warnings, current_warnings)
  object@messages <- c(object@messages, current_messages)

  lockEnvironment(object@env, bindings = TRUE)
  object
})

setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
  eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
})

setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
  eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
})

setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {
  object
})

# if cli is installed rlang adds terminal printing characters
# which need to be removed
.ansi_strip <- function(chr) {
  if (requireNamespace("cli", quietly = TRUE)) {
    cli::ansi_strip(chr)
  } else {
    chr
  }
}

#' Join `qenv` objects
#'
#' Checks and merges two `qenv` objects into one `qenv` object.
#'
#' Any common code at the start of the `qenvs` is only placed once at the start of the joined `qenv`.
#' This allows consistent behavior when joining `qenvs` which share a common ancestor.
#' See below for an example.
#'
#' There are some situations where `join()` cannot be properly performed, such as these three scenarios:
#' 1. Both `qenv` objects contain an object of the same name but are not identical.
#'
#'    Example:
#'
#'    ```r
#'    x <- eval_code(qenv(), expression(mtcars1 <- mtcars))
#'    y <- eval_code(qenv(), expression(mtcars1 <- mtcars['wt']))
#'
#'    z <- join(x, y)
#'    # Error message will occur
#'    ```
#'    In this example, `mtcars1` object exists in both `x` and `y` objects but the content are not identical.
#'    `mtcars1` in the `x qenv` object has more columns than `mtcars1` in the `y qenv` object (only has one column).
#'
#' 2. `join()` will look for identical `@id` values in both `qenv` objects.
#'    The index position of these `@id`s must be the same to determine the evaluation order.
#'    Otherwise, `join()` will throw an error message.
#'
#'    Example:
#'    ```r
#'    common_q <- eval_code(qenv(), expression(v <- 1))
#'    x <- eval_code(
#'      common_q,
#'      "x <- v"
#'    )
#'    y <- eval_code(
#'      common_q,
#'      "y <- v"
#'    )
#'    z <- eval_code(
#'      y,
#'      "z <- v"
#'    )
#'    q <- join(x, y)
#'    join_q <- join(q, z)
#'    # Error message will occur
#'
#'    # Check the order of evaluation based on the id slot
#'    shared_ids <- intersect(q@id, z@id)
#'    match(shared_ids, q@id) # Output: 1 3
#'    match(shared_ids, z@id) # Output: 1 2
#'    ```
#'    The error occurs because the index position of identical `@id` between the two objects is not the same.
#'
#' 3. The usage of temporary variable in the code expression could cause `join()` to fail.
#'
#'    Example:
#'    ```r
#'    common_q <- qenv()
#'    x <- eval_code(
#'      common_q,
#'      "x <- numeric(0)
#'       for (i in 1:2) {
#'         x <- c(x, i)
#'       }"
#'    )
#'    y <- eval_code(
#'      common_q,
#'      "y <- numeric(0)
#'       for (i in 1:3) {
#'         y <- c(y, i)
#'       }"
#'    )
#'    q <- join(x,y)
#'    # Error message will occur
#'
#'    # Check the value of temporary variable i in both objects
#'    x@env$i # Output: 2
#'    y@env$i # Output: 3
#'    ```
#'    `join()` fails to provide a proper result because of the temporary variable `i` exists
#'    in both objects but has different value.
#'    To fix this, we can set `i <- NULL` in the code expression for both objects.
#'    ```r
#'    common_q <- qenv()
#'    x <- eval_code(
#'      common_q,
#'      "x <- numeric(0)
#'       for (i in 1:2) {
#'         x <- c(x, i)
#'       }
#'       # dummy i variable to fix it
#'       i <- NULL"
#'    )
#'    y <- eval_code(
#'      common_q,
#'      "y <- numeric(0)
#'       for (i in 1:3) {
#'         y <- c(y, i)
#'       }
#'       # dummy i variable to fix it
#'       i <- NULL"
#'    )
#'    q <- join(x,y)
#'    ```
#'
#' @param x (`qenv`)
#' @param y (`qenv`)
#'
#' @return `qenv` object.
#'
#' @examples
#' q <- qenv()
#' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
#' q2 <- q1
#' q1 <- eval_code(q1, "iris2 <- iris")
#' q2 <- eval_code(q2, "mtcars2 <- mtcars")
#' qq <- join(q1, q2)
#' get_code(qq)
#'
#' common_q <- eval_code(q, quote(x <- 1))
#' y_q <- eval_code(common_q, quote(y <- x * 2))
#' z_q <- eval_code(common_q, quote(z <- x * 3))
#' join_q <- join(y_q, z_q)
#' # get_code only has "x <- 1" occurring once
#' get_code(join_q)
#'
#' @include qenv-errors.R
#'
#' @name join
#' @rdname join
#' @aliases join,qenv,qenv-method
#' @aliases join,qenv,qenv.error-method
#' @aliases join,qenv.error,ANY-method
#'
#' @export
setGeneric("join", function(x, y) standardGeneric("join"))

setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
  join_validation <- .check_joinable(x, y)

  # join expressions
  if (!isTRUE(join_validation)) {
    stop(join_validation)
  }

  id_unique <- !y@id %in% x@id
  x@id <- c(x@id, y@id[id_unique])
  x@code <- c(x@code, y@code[id_unique])
  x@warnings <- c(x@warnings, y@warnings[id_unique])
  x@messages <- c(x@messages, y@messages[id_unique])

  # insert (and overwrite) objects from y to x
  x@env <- rlang::env_clone(x@env, parent = parent.env(.GlobalEnv))
  rlang::env_coalesce(env = x@env, from = y@env)
  x
})

setMethod("join", signature = c("qenv", "qenv.error"), function(x, y) {
  y
})

setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
  x
})

#' If two `qenv` can be joined
#'
#' Checks if two `qenv` objects can be combined.
#' For more information, please see [`join`]
#' @param x (`qenv`)
#' @param y (`qenv`)
#' @return `TRUE` if able to join or `character` used to print error message.
#' @keywords internal
.check_joinable <- function(x, y) {
  checkmate::assert_class(x, "qenv")
  checkmate::assert_class(y, "qenv")

  common_names <- intersect(rlang::env_names(x@env), rlang::env_names(y@env))
  is_overwritten <- vapply(common_names, function(el) {
    !identical(get(el, x@env), get(el, y@env))
  }, logical(1))
  if (any(is_overwritten)) {
    return(
      paste(
        "Not possible to join qenv objects if anything in their environment has been modified.\n",
        "Following object(s) have been modified:\n - ",
        paste(common_names[is_overwritten], collapse = "\n - ")
      )
    )
  }

  shared_ids <- intersect(x@id, y@id)
  if (length(shared_ids) == 0) {
    return(TRUE)
  }

  shared_in_x <- match(shared_ids, x@id)
  shared_in_y <- match(shared_ids, y@id)

  # indices of shared ids should be 1:n in both slots
  if (identical(shared_in_x, shared_in_y) && identical(shared_in_x, seq_along(shared_ids))) {
    TRUE
  } else if (!identical(shared_in_x, shared_in_y)) {
    paste(
      "The common shared code of the qenvs does not occur in the same position in both qenv objects",
      "so they cannot be joined together as it's impossible to determine the evaluation's order.",
      collapse = ""
    )
  } else {
    paste(
      "There is code in the qenv objects before their common shared code",
      "which means these objects cannot be joined.",
      collapse = ""
    )
  }
}

#' Code tracking with `qenv` object
#'
#' @description
#' `r badge("stable")`
#'
#' Create a `qenv` object and evaluate code in it to track code history.
#'
#' @details
#'
#' `qenv()` instantiates a `qenv` with an empty environment.
#' Any changes must be made by evaluating code in it with `eval_code` or `within`, thereby ensuring reproducibility.
#'
#' `new_qenv()` (`r badge("deprecated")` and not recommended)
#' can instantiate a `qenv` object with data in the environment and code registered.
#'
#' @name qenv
#'
#' @return `qenv` and `new_qenv` return a `qenv` object.
#'
#' @examples
#' # create empty qenv
#' qenv()
#'
#' @export
qenv <- function() {
  q_env <- new.env(parent = parent.env(.GlobalEnv))
  lockEnvironment(q_env, bindings = TRUE)
  methods::new("qenv", env = q_env)
}


#' @param code `r badge("deprecated")`
#'  (`character(1)` or `language`) code to evaluate. Accepts and stores comments also.
#' @param env `r badge("deprecated")` (`environment`)
#'  Environment being a result of the `code` evaluation.
#'
#' @examples
#' # create qenv with data and code (deprecated)
#' new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
#' new_qenv(env = list2env(list(a = 1)), code = parse(text = "a <- 1", keep.source = TRUE))
#' new_qenv(env = list2env(list(a = 1)), code = "a <- 1")
#'
#' @rdname qenv
#' @aliases new_qenv,environment,expression-method
#' @aliases new_qenv,environment,character-method
#' @aliases new_qenv,environment,language-method
#' @aliases new_qenv,environment,missing-method
#' @aliases new_qenv,missing,missing-method
#'
#' @seealso [`base::within()`], [`get_var()`], [`get_env()`], [`get_warnings()`], [`join()`], [`concat()`]
#'
#' @export
setGeneric("new_qenv", function(env = new.env(parent = parent.env(.GlobalEnv)), code = character()) {
  lifecycle::deprecate_warn(when = " 0.5.0", what = "new_qenv()", with = "qenv()", always = TRUE)
  standardGeneric("new_qenv")
})

setMethod(
  "new_qenv",
  signature = c(env = "environment", code = "expression"),
  function(env, code) {
    new_qenv(env, paste(lang2calls(code), collapse = "\n"))
  }
)

setMethod(
  "new_qenv",
  signature = c(env = "environment", code = "character"),
  function(env, code) {
    new_env <- rlang::env_clone(env, parent = parent.env(.GlobalEnv))
    lockEnvironment(new_env, bindings = TRUE)
    if (length(code) > 0) code <- paste(code, collapse = "\n")
    id <- sample.int(.Machine$integer.max, size = length(code))
    methods::new(
      "qenv",
      env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id
    )
  }
)

setMethod(
  "new_qenv",
  signature = c(env = "environment", code = "language"),
  function(env, code) {
    new_qenv(env = env, code = paste(lang2calls(code), collapse = "\n"))
  }
)

setMethod(
  "new_qenv",
  signature = c(code = "missing", env = "missing"),
  function(env, code) {
    new_qenv(env = env, code = code)
  }
)

#' Concatenate two `qenv` objects
#'
#' Combine two `qenv` objects by simple concatenate their environments and the code.
#'
#' We recommend to use the `join` method to have a stricter control
#' in case `x` and `y` contain duplicated bindings and code.
#' RHS argument content has priority over the LHS one.
#'
#' @param x (`qenv`)
#' @param y (`qenv`)
#'
#' @return `qenv` object.
#'
#' @examples
#' q <- qenv()
#' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
#' q2 <- q1
#' q1 <- eval_code(q1, "iris2 <- iris")
#' q2 <- eval_code(q2, "mtcars2 <- mtcars")
#' qq <- concat(q1, q2)
#' get_code(qq)
#'
#' @include qenv-errors.R
#'
#' @name concat
#' @rdname concat
#' @aliases concat,qenv,qenv-method
#' @aliases concat,qenv.error,ANY-method
#' @aliases concat,qenv,qenv.error-method
#'
#' @export
setGeneric("concat", function(x, y) standardGeneric("concat"))

setMethod("concat", signature = c("qenv", "qenv"), function(x, y) {
  y@id <- c(x@id, y@id)
  y@code <- c(x@code, y@code)
  y@warnings <- c(x@warnings, y@warnings)
  y@messages <- c(x@messages, y@messages)

  # insert (and overwrite) objects from y to x
  y@env <- rlang::env_clone(y@env, parent = parent.env(.GlobalEnv))
  rlang::env_coalesce(env = y@env, from = x@env)
  y
})

setMethod("concat", signature = c("qenv.error", "ANY"), function(x, y) {
  x
})

setMethod("concat", signature = c("qenv", "qenv.error"), function(x, y) {
  y
})

#' Evaluate Expression in `qenv`
#'
#' @details
#' `within` is a convenience function for evaluating inline code inside the environment of a `qenv`.
#' It is a method for the `base` generic that wraps `eval_code` to provide a simplified way of passing code.
#' `within` accepts only inline expressions (both simple and compound) and allows for injecting values into `expr`
#' through the `...` argument:
#' as `name:value` pairs are passed to `...`, `name` in `expr` will be replaced with `value`.
#'
#' @section Using language objects with `within`:
#' Passing language objects to `expr` is generally not intended but can be achieved with `do.call`.
#' Only single `expression`s will work and substitution is not available. See examples.
#'
#' @param data (`qenv`)
#' @param expr (`expression`) to evaluate. Must be inline code, see `Using language objects...`
#' @param ... see `Details`
#'
#' @return
#' `within` returns a `qenv` object with `expr` evaluated or `qenv.error` if evaluation fails.
#'
#' @examples
#' # evaluate code using within
#' q <- qenv()
#' q <- within(q, {
#'   i <- iris
#' })
#' q <- within(q, {
#'   m <- mtcars
#'   f <- faithful
#' })
#' q
#' get_code(q)
#'
#' # inject values into code
#' q <- qenv()
#' q <- within(q, i <- iris)
#' within(q, print(dim(subset(i, Species == "virginica"))))
#' within(q, print(dim(subset(i, Species == species)))) # fails
#' within(q, print(dim(subset(i, Species == species))), species = "versicolor")
#' species_external <- "versicolor"
#' within(q, print(dim(subset(i, Species == species))), species = species_external)
#'
#' # pass language objects
#' expr <- expression(i <- iris, m <- mtcars)
#' within(q, expr) # fails
#' do.call(within, list(q, expr))
#'
#' exprlist <- list(expression(i <- iris), expression(m <- mtcars))
#' within(q, exprlist) # fails
#' do.call(within, list(q, do.call(c, exprlist)))
#'
#' @rdname qenv
#'
#' @export
#'
within.qenv <- function(data, expr, ...) {
  expr <- substitute(expr)
  extras <- list(...)

  # Add braces for consistency.
  if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
    expr <- call("{", expr)
  }

  calls <- as.list(expr)[-1]

  # Inject extra values into expressions.
  calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))

  eval_code(object = data, code = as.expression(calls))
}


#' @keywords internal
#'
#' @export
within.qenv.error <- function(data, expr, ...) {
  data
}

#' Display `qenv` object
#'
#' Prints the `qenv` object.
#'
#' @param object (`qenv`)
#'
#' @return `object`, invisibly.
#'
#' @examples
#' q <- qenv()
#' q1 <- eval_code(q, expression(a <- 5, b <- data.frame(x = 1:10)))
#' q1
#'
#' @aliases show-qenv
#'
#' @importFrom methods show
#' @export
setMethod("show", "qenv", function(object) {
  rlang::env_print(object@env)
})

#' Suppresses plot display in the IDE by opening a PDF graphics device
#'
#' This function opens a PDF graphics device using [`grDevices::pdf`] to suppress
#' the plot display in the IDE. The purpose of this function is to avoid opening graphic devices
#' directly in the IDE.
#'
#' @param x lazy binding which generates the plot(s)
#'
#' @details The function uses [`base::on.exit`] to ensure that the PDF graphics
#'          device is closed (using [`grDevices::dev.off`]) when the function exits,
#'          regardless of whether it exits normally or due to an error. This is necessary to
#'          clean up the graphics device properly and avoid any potential issues.
#'
#' @return No return value, called for side effects.
#'
#' @examples
#' dev_suppress(plot(1:10))
#' @export
dev_suppress <- function(x) {
  grDevices::pdf(nullfile())
  on.exit(grDevices::dev.off())
  force(x)
}

#' Separate calls
#'
#' Converts language object or lists of language objects to list of simple calls.
#'
#' @param x `language` object or a list of thereof
#' @return
#' Given a `call`, an `expression`, a list of `call`s or a list of `expression`s, returns a list of `calls`.
#' Symbols and atomic vectors (which may get mixed up in a list) are returned wrapped in list.
#' @examples
#' # use non-exported function from teal.code
#' lang2calls <- getFromNamespace("lang2calls", "teal.code")
#' expr <- expression(
#'   i <- iris,
#'   m <- mtcars
#' )
#' lang2calls(expr)
#' @keywords internal
lang2calls <- function(x) {
  if (is.atomic(x) || is.symbol(x)) {
    return(list(x))
  }
  if (is.call(x)) {
    if (identical(as.list(x)[[1L]], as.symbol("{"))) {
      as.list(x)[-1L]
    } else {
      list(x)
    }
  } else {
    unlist(lapply(x, lang2calls), recursive = FALSE)
  }
}

#' Get warnings from `qenv` object
#'
#' Retrieve all warnings raised during code evaluation in a `qenv`.
#'
#' @param object (`qenv`)
#'
#' @return `character` containing warning information or `NULL` if no warnings.
#'
#' @examples
#' data_q <- qenv()
#' data_q <- eval_code(data_q, "iris_data <- iris")
#' warning_qenv <- eval_code(
#'   data_q,
#'   bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
#' )
#' cat(get_warnings(warning_qenv))
#'
#' @name get_warnings
#' @rdname get_warnings
#' @aliases get_warnings,qenv-method
#' @aliases get_warnings,qenv.error-method
#' @aliases get_warnings,NULL-method
#'
#' @export
setGeneric("get_warnings", function(object) {
  # this line forces evaluation of object before passing to the generic
  # needed for error handling to work properly
  grDevices::pdf(nullfile())
  on.exit(grDevices::dev.off())
  object

  standardGeneric("get_warnings")
})

setMethod("get_warnings", signature = c("qenv"), function(object) {
  if (all(object@warnings == "")) {
    return(NULL)
  }

  lines <- mapply(
    function(warn, expr) {
      if (warn == "") {
        return(NULL)
      }
      sprintf("%swhen running code:\n%s", warn, paste(lang2calls(expr), collapse = "\n"))
    },
    warn = as.list(object@warnings),
    expr = as.list(as.character(object@code))
  )
  lines <- Filter(Negate(is.null), lines)

  sprintf(
    "~~~ Warnings ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
    paste(lines, collapse = "\n\n"),
    get_code(object)
  )
})

setMethod("get_warnings", signature = c("qenv.error"), function(object) {
  NULL
})

setMethod("get_warnings", "NULL", function(object) {
  NULL
})

#' Access environment included in `qenv`
#'
#' The access of environment included in `qenv@env` allows to e.g. list object names included in `qenv@env` slot.
#'
#' @param object (`qenv`)
#'
#' @return An `environment` stored in `qenv@env` slot.
#'
#' @examples
#' q <- qenv()
#' q1 <- within(q, {
#'   a <- 5
#'   b <- data.frame(x = 1:10)
#' })
#' get_env(q1)
#' ls(get_env(q1))
#'
#' @aliases get_env,qenv-method
#' @aliases get_env,qenv.error-method
#'
#' @export
setGeneric("get_env", function(object) {
  standardGeneric("get_env")
})

setMethod("get_env", "qenv", function(object) {
  object@env
})

setMethod("get_env", "qenv.error", function(object) {
  object
})

#' Get code from `qenv`
#'
#' @details
#' `get_code` retrieves the code stored in the `qenv`. `...` passes arguments to methods.
#'
#' @param object (`qenv`)
#' @param deparse (`logical(1)`) flag specifying whether to return code as `character` or `expression`.
#' @param ... see `Details`
#'
#' @return
#' `get_code` returns the traced code (from `@code` slot) in the form specified by `deparse`.
#'
#' @examples
#' # retrieve code
#' get_code(q)
#' get_code(q, deparse = FALSE)
#'
#' @name get_code
#' @rdname qenv
#' @aliases get_code,qenv-method
#' @aliases get_code,qenv.error-method
#'
#' @export
setGeneric("get_code", function(object, deparse = TRUE, ...) {
  # this line forces evaluation of object before passing to the generic
  # needed for error handling to work properly
  grDevices::pdf(nullfile())
  on.exit(grDevices::dev.off())
  object

  standardGeneric("get_code")
})

setMethod("get_code", signature = "qenv", function(object, deparse = TRUE) {
  checkmate::assert_flag(deparse)
  if (deparse) {
    if (length(object@code) == 0) {
      object@code
    } else {
      paste(object@code, collapse = "\n")
    }
  } else {
    parse(text = paste(c("{", object@code, "}"), collapse = "\n"), keep.source = TRUE)
  }
})

setMethod("get_code", signature = "qenv.error", function(object, ...) {
  stop(
    errorCondition(
      sprintf(
        "%s\n\ntrace: \n %s\n",
        conditionMessage(object),
        paste(object$trace, collapse = "\n ")
      ),
      class = c("validation", "try-error", "simpleError")
    )
  )
})

#' Get object from `qenv`
#'
#' Retrieve variables from the `qenv` environment.
#'
#' @param object,x (`qenv`)
#' @param var,i (`character(1)`) variable name.
#'
#' @return The value of required variable (`var`) within `qenv` object.
#'
#' @examples
#' q <- qenv()
#' q1 <- eval_code(q, code = quote(a <- 1))
#' q2 <- eval_code(q1, code = "b <- a")
#' get_var(q2, "b")
#' q2[["b"]]
#'
#' @name get_var
#' @rdname get_var
#' @aliases get_var,qenv,character-method
#' @aliases get_var,qenv.error,ANY-method
#'
#' @export
setGeneric("get_var", function(object, var) {
  grDevices::pdf(nullfile())
  on.exit(grDevices::dev.off())
  standardGeneric("get_var")
})

setMethod("get_var", signature = c("qenv", "character"), function(object, var) {
  tryCatch(
    get(var, envir = object@env, inherits = FALSE),
    error = function(e) {
      message(conditionMessage(e))
      NULL
    }
  )
})

setMethod("get_var", signature = c("qenv.error", "ANY"), function(object, var) {
  stop(errorCondition(
    list(message = conditionMessage(object)),
    class = c("validation", "try-error", "simpleError")
  ))
})

#' @rdname get_var
setMethod("[[", signature = c("qenv", "ANY"), function(x, i) {
  get_var(x, i)
})

#' @export
`[[.qenv.error` <- function(x, i) {
  stop(errorCondition(
    list(message = conditionMessage(x)),
    class = c("validation", "try-error", "simpleError")
  ))
}

1		#' Evaluate code in `qenv`
2		#'
3		#' @details
4		#' `eval_code` evaluates given code in the `qenv` environment and appends it to the `code` slot.
5		#' Thus, if the `qenv` had been instantiated empty, contents of the environment are always a result of the stored code.
6		#'
7		#' @param object (`qenv`)
8		#' @param code (`character` or `language`) code to evaluate. If `character`, comments are retained.
9		#'
10		#' @return
11		#' `eval_code` returns a `qenv` object with `expr` evaluated or `qenv.error` if evaluation fails.
12		#'
13		#' @examples
14		#' # evaluate code in qenv
15		#' q <- qenv()
16		#' q <- eval_code(q, "a <- 1")
17		#' q <- eval_code(q, quote(library(checkmate)))
18		#' q <- eval_code(q, expression(assert_number(a)))
19		#'
20		#' @name eval_code
21		#' @rdname qenv
22		#' @aliases eval_code,qenv,character-method
23		#' @aliases eval_code,qenv,language-method
24		#' @aliases eval_code,qenv,expression-method
25		#' @aliases eval_code,qenv.error,ANY-method
26		#'
27		#' @export
28	196x	setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
29
30		setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
31	106x	id <- sample.int(.Machine$integer.max, size = 1)
32
33	106x	object@id <- c(object@id, id)
34	106x	object@env <- rlang::env_clone(object@env, parent = parent.env(.GlobalEnv))
35	106x	code <- paste(code, collapse = "\n")
36	106x	object@code <- c(object@code, code)
37
38	106x	current_warnings <- ""
39	106x	current_messages <- ""
40
41	106x	parsed_code <- parse(text = code, keep.source = TRUE)
42	106x	for (single_call in parsed_code) {
43		# Using withCallingHandlers to capture warnings and messages.
44		# Using tryCatch to capture the error and abort further evaluation.
45	120x	x <- withCallingHandlers(
46	120x	tryCatch(
47		{
48	120x	eval(single_call, envir = object@env)
49	108x	if (!identical(parent.env(object@env), parent.env(.GlobalEnv))) {
50		# needed to make sure that @env is always a sibling of .GlobalEnv
51		# could be changed when any new package is added to search path (through library or require call)
52	1x	parent.env(object@env) <- parent.env(.GlobalEnv)
53		}
54	108x	NULL
55		},
56	120x	error = function(e) {
57	12x	errorCondition(
58	12x	message = sprintf(
59	12x	"%s \n when evaluating qenv code:\n%s",
60	12x	.ansi_strip(conditionMessage(e)),
61	12x	deparse1(single_call)
62		),
63	12x	class = c("qenv.error", "try-error", "simpleError"),
64	12x	trace = object@code
65		)
66		}
67		),
68	120x	warning = function(w) {
69	15x	current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w))))
70	15x	invokeRestart("muffleWarning")
71		},
72	120x	message = function(m) {
73	5x	current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m))))
74	5x	invokeRestart("muffleMessage")
75		}
76		)
77
78	120x	if (!is.null(x)) {
79	12x	return(x)
80		}
81		}
82
83
84	94x	object@warnings <- c(object@warnings, current_warnings)
85	94x	object@messages <- c(object@messages, current_messages)
86
87	94x	lockEnvironment(object@env, bindings = TRUE)
88	94x	object
89		})
90
91		setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
92	63x	eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
93		})
94
95		setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
96	26x	eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
97		})
98
99		setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {
100	!	object
101		})
102
103		# if cli is installed rlang adds terminal printing characters
104		# which need to be removed
105		.ansi_strip <- function(chr) {
106	32x	if (requireNamespace("cli", quietly = TRUE)) {
107	32x	cli::ansi_strip(chr)
108		} else {
109	!	chr
110		}
111		}

1		#' Code tracking with `qenv` object
2		#'
3		#' @description
4		#' `r badge("stable")`
5		#'
6		#' Create a `qenv` object and evaluate code in it to track code history.
7		#'
8		#' @details
9		#'
10		#' `qenv()` instantiates a `qenv` with an empty environment.
11		#' Any changes must be made by evaluating code in it with `eval_code` or `within`, thereby ensuring reproducibility.
12		#'
13		#' `new_qenv()` (`r badge("deprecated")` and not recommended)
14		#' can instantiate a `qenv` object with data in the environment and code registered.
15		#'
16		#' @name qenv
17		#'
18		#' @return `qenv` and `new_qenv` return a `qenv` object.
19		#'
20		#' @examples
21		#' # create empty qenv
22		#' qenv()
23		#'
24		#' @export
25		qenv <- function() {
26	76x	q_env <- new.env(parent = parent.env(.GlobalEnv))
27	76x	lockEnvironment(q_env, bindings = TRUE)
28	76x	methods::new("qenv", env = q_env)
29		}
30
31
32		#' @param code `r badge("deprecated")`
33		#' (`character(1)` or `language`) code to evaluate. Accepts and stores comments also.
34		#' @param env `r badge("deprecated")` (`environment`)
35		#' Environment being a result of the `code` evaluation.
36		#'
37		#' @examples
38		#' # create qenv with data and code (deprecated)
39		#' new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
40		#' new_qenv(env = list2env(list(a = 1)), code = parse(text = "a <- 1", keep.source = TRUE))
41		#' new_qenv(env = list2env(list(a = 1)), code = "a <- 1")
42		#'
43		#' @rdname qenv
44		#' @aliases new_qenv,environment,expression-method
45		#' @aliases new_qenv,environment,character-method
46		#' @aliases new_qenv,environment,language-method
47		#' @aliases new_qenv,environment,missing-method
48		#' @aliases new_qenv,missing,missing-method
49		#'
50		#' @seealso [`base::within()`], [`get_var()`], [`get_env()`], [`get_warnings()`], [`join()`], [`concat()`]
51		#'
52		#' @export
53		setGeneric("new_qenv", function(env = new.env(parent = parent.env(.GlobalEnv)), code = character()) {
54	!	lifecycle::deprecate_warn(when = " 0.5.0", what = "new_qenv()", with = "qenv()", always = TRUE)
55	!	standardGeneric("new_qenv")
56		})
57
58		setMethod(
59		"new_qenv",
60		signature = c(env = "environment", code = "expression"),
61		function(env, code) {
62	!	new_qenv(env, paste(lang2calls(code), collapse = "\n"))
63		}
64		)
65
66		setMethod(
67		"new_qenv",
68		signature = c(env = "environment", code = "character"),
69		function(env, code) {
70	!	new_env <- rlang::env_clone(env, parent = parent.env(.GlobalEnv))
71	!	lockEnvironment(new_env, bindings = TRUE)
72	!	if (length(code) > 0) code <- paste(code, collapse = "\n")
73	!	id <- sample.int(.Machine$integer.max, size = length(code))
74	!	methods::new(
75	!	"qenv",
76	!	env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id
77		)
78		}
79		)
80
81		setMethod(
82		"new_qenv",
83		signature = c(env = "environment", code = "language"),
84		function(env, code) {
85	!	new_qenv(env = env, code = paste(lang2calls(code), collapse = "\n"))
86		}
87		)
88
89		setMethod(
90		"new_qenv",
91		signature = c(code = "missing", env = "missing"),
92		function(env, code) {
93	!	new_qenv(env = env, code = code)
94		}
95		)

1		#' Concatenate two `qenv` objects
2		#'
3		#' Combine two `qenv` objects by simple concatenate their environments and the code.
4		#'
5		#' We recommend to use the `join` method to have a stricter control
6		#' in case `x` and `y` contain duplicated bindings and code.
7		#' RHS argument content has priority over the LHS one.
8		#'
9		#' @param x (`qenv`)
10		#' @param y (`qenv`)
11		#'
12		#' @return `qenv` object.
13		#'
14		#' @examples
15		#' q <- qenv()
16		#' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
17		#' q2 <- q1
18		#' q1 <- eval_code(q1, "iris2 <- iris")
19		#' q2 <- eval_code(q2, "mtcars2 <- mtcars")
20		#' qq <- concat(q1, q2)
21		#' get_code(qq)
22		#'
23		#' @include qenv-errors.R
24		#'
25		#' @name concat
26		#' @rdname concat
27		#' @aliases concat,qenv,qenv-method
28		#' @aliases concat,qenv.error,ANY-method
29		#' @aliases concat,qenv,qenv.error-method
30		#'
31		#' @export
32	9x	setGeneric("concat", function(x, y) standardGeneric("concat"))
33
34		setMethod("concat", signature = c("qenv", "qenv"), function(x, y) {
35	5x	y@id <- c(x@id, y@id)
36	5x	y@code <- c(x@code, y@code)
37	5x	y@warnings <- c(x@warnings, y@warnings)
38	5x	y@messages <- c(x@messages, y@messages)
39
40		# insert (and overwrite) objects from y to x
41	5x	y@env <- rlang::env_clone(y@env, parent = parent.env(.GlobalEnv))
42	5x	rlang::env_coalesce(env = y@env, from = x@env)
43	5x	y
44		})
45
46		setMethod("concat", signature = c("qenv.error", "ANY"), function(x, y) {
47	3x	x
48		})
49
50		setMethod("concat", signature = c("qenv", "qenv.error"), function(x, y) {
51	1x	y
52		})

1		#' Evaluate Expression in `qenv`
2		#'
3		#' @details
4		#' `within` is a convenience function for evaluating inline code inside the environment of a `qenv`.
5		#' It is a method for the `base` generic that wraps `eval_code` to provide a simplified way of passing code.
6		#' `within` accepts only inline expressions (both simple and compound) and allows for injecting values into `expr`
7		#' through the `...` argument:
8		#' as `name:value` pairs are passed to `...`, `name` in `expr` will be replaced with `value`.
9		#'
10		#' @section Using language objects with `within`:
11		#' Passing language objects to `expr` is generally not intended but can be achieved with `do.call`.
12		#' Only single `expression`s will work and substitution is not available. See examples.
13		#'
14		#' @param data (`qenv`)
15		#' @param expr (`expression`) to evaluate. Must be inline code, see `Using language objects...`
16		#' @param ... see `Details`
17		#'
18		#' @return
19		#' `within` returns a `qenv` object with `expr` evaluated or `qenv.error` if evaluation fails.
20		#'
21		#' @examples
22		#' # evaluate code using within
23		#' q <- qenv()
24		#' q <- within(q, {
25		#' i <- iris
26		#' })
27		#' q <- within(q, {
28		#' m <- mtcars
29		#' f <- faithful
30		#' })
31		#' q
32		#' get_code(q)
33		#'
34		#' # inject values into code
35		#' q <- qenv()
36		#' q <- within(q, i <- iris)
37		#' within(q, print(dim(subset(i, Species == "virginica"))))
38		#' within(q, print(dim(subset(i, Species == species)))) # fails
39		#' within(q, print(dim(subset(i, Species == species))), species = "versicolor")
40		#' species_external <- "versicolor"
41		#' within(q, print(dim(subset(i, Species == species))), species = species_external)
42		#'
43		#' # pass language objects
44		#' expr <- expression(i <- iris, m <- mtcars)
45		#' within(q, expr) # fails
46		#' do.call(within, list(q, expr))
47		#'
48		#' exprlist <- list(expression(i <- iris), expression(m <- mtcars))
49		#' within(q, exprlist) # fails
50		#' do.call(within, list(q, do.call(c, exprlist)))
51		#'
52		#' @rdname qenv
53		#'
54		#' @export
55		#'
56		within.qenv <- function(data, expr, ...) {
57	19x	expr <- substitute(expr)
58	19x	extras <- list(...)
59
60		# Add braces for consistency.
61	19x	if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
62	7x	expr <- call("{", expr)
63		}
64
65	19x	calls <- as.list(expr)[-1]
66
67		# Inject extra values into expressions.
68	19x	calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))
69
70	19x	eval_code(object = data, code = as.expression(calls))
71		}
72
73
74		#' @keywords internal
75		#'
76		#' @export
77		within.qenv.error <- function(data, expr, ...) {
78	1x	data
79		}

1		#' Suppresses plot display in the IDE by opening a PDF graphics device
2		#'
3		#' This function opens a PDF graphics device using [`grDevices::pdf`] to suppress
4		#' the plot display in the IDE. The purpose of this function is to avoid opening graphic devices
5		#' directly in the IDE.
6		#'
7		#' @param x lazy binding which generates the plot(s)
8		#'
9		#' @details The function uses [`base::on.exit`] to ensure that the PDF graphics
10		#' device is closed (using [`grDevices::dev.off`]) when the function exits,
11		#' regardless of whether it exits normally or due to an error. This is necessary to
12		#' clean up the graphics device properly and avoid any potential issues.
13		#'
14		#' @return No return value, called for side effects.
15		#'
16		#' @examples
17		#' dev_suppress(plot(1:10))
18		#' @export
19		dev_suppress <- function(x) {
20	2x	grDevices::pdf(nullfile())
21	2x	on.exit(grDevices::dev.off())
22	2x	force(x)
23		}
24
25		#' Separate calls
26		#'
27		#' Converts language object or lists of language objects to list of simple calls.
28		#'
29		#' @param x `language` object or a list of thereof
30		#' @return
31		#' Given a `call`, an `expression`, a list of `call`s or a list of `expression`s, returns a list of `calls`.
32		#' Symbols and atomic vectors (which may get mixed up in a list) are returned wrapped in list.
33		#' @examples
34		#' # use non-exported function from teal.code
35		#' lang2calls <- getFromNamespace("lang2calls", "teal.code")
36		#' expr <- expression(
37		#' i <- iris,
38		#' m <- mtcars
39		#' )
40		#' lang2calls(expr)
41		#' @keywords internal
42		lang2calls <- function(x) {
43	167x	if (is.atomic(x) \|\| is.symbol(x)) {
44	9x	return(list(x))
45		}
46	158x	if (is.call(x)) {
47	118x	if (identical(as.list(x)[[1L]], as.symbol("{"))) {
48	7x	as.list(x)[-1L]
49		} else {
50	111x	list(x)
51		}
52		} else {
53	40x	unlist(lapply(x, lang2calls), recursive = FALSE)
54		}
55		}

1		#' Join `qenv` objects
2		#'
3		#' Checks and merges two `qenv` objects into one `qenv` object.
4		#'
5		#' Any common code at the start of the `qenvs` is only placed once at the start of the joined `qenv`.
6		#' This allows consistent behavior when joining `qenvs` which share a common ancestor.
7		#' See below for an example.
8		#'
9		#' There are some situations where `join()` cannot be properly performed, such as these three scenarios:
10		#' 1. Both `qenv` objects contain an object of the same name but are not identical.
11		#'
12		#' Example:
13		#'
14		#' ```r
15		#' x <- eval_code(qenv(), expression(mtcars1 <- mtcars))
16		#' y <- eval_code(qenv(), expression(mtcars1 <- mtcars['wt']))
17		#'
18		#' z <- join(x, y)
19		#' # Error message will occur
20		#' ```
21		#' In this example, `mtcars1` object exists in both `x` and `y` objects but the content are not identical.
22		#' `mtcars1` in the `x qenv` object has more columns than `mtcars1` in the `y qenv` object (only has one column).
23		#'
24		#' 2. `join()` will look for identical `@id` values in both `qenv` objects.
25		#' The index position of these `@id`s must be the same to determine the evaluation order.
26		#' Otherwise, `join()` will throw an error message.
27		#'
28		#' Example:
29		#' ```r
30		#' common_q <- eval_code(qenv(), expression(v <- 1))
31		#' x <- eval_code(
32		#' common_q,
33		#' "x <- v"
34		#' )
35		#' y <- eval_code(
36		#' common_q,
37		#' "y <- v"
38		#' )
39		#' z <- eval_code(
40		#' y,
41		#' "z <- v"
42		#' )
43		#' q <- join(x, y)
44		#' join_q <- join(q, z)
45		#' # Error message will occur
46		#'
47		#' # Check the order of evaluation based on the id slot
48		#' shared_ids <- intersect(q@id, z@id)
49		#' match(shared_ids, q@id) # Output: 1 3
50		#' match(shared_ids, z@id) # Output: 1 2
51		#' ```
52		#' The error occurs because the index position of identical `@id` between the two objects is not the same.
53		#'
54		#' 3. The usage of temporary variable in the code expression could cause `join()` to fail.
55		#'
56		#' Example:
57		#' ```r
58		#' common_q <- qenv()
59		#' x <- eval_code(
60		#' common_q,
61		#' "x <- numeric(0)
62		#' for (i in 1:2) {
63		#' x <- c(x, i)
64		#' }"
65		#' )
66		#' y <- eval_code(
67		#' common_q,
68		#' "y <- numeric(0)
69		#' for (i in 1:3) {
70		#' y <- c(y, i)
71		#' }"
72		#' )
73		#' q <- join(x,y)
74		#' # Error message will occur
75		#'
76		#' # Check the value of temporary variable i in both objects
77		#' x@env$i # Output: 2
78		#' y@env$i # Output: 3
79		#' ```
80		#' `join()` fails to provide a proper result because of the temporary variable `i` exists
81		#' in both objects but has different value.
82		#' To fix this, we can set `i <- NULL` in the code expression for both objects.
83		#' ```r
84		#' common_q <- qenv()
85		#' x <- eval_code(
86		#' common_q,
87		#' "x <- numeric(0)
88		#' for (i in 1:2) {
89		#' x <- c(x, i)
90		#' }
91		#' # dummy i variable to fix it
92		#' i <- NULL"
93		#' )
94		#' y <- eval_code(
95		#' common_q,
96		#' "y <- numeric(0)
97		#' for (i in 1:3) {
98		#' y <- c(y, i)
99		#' }
100		#' # dummy i variable to fix it
101		#' i <- NULL"
102		#' )
103		#' q <- join(x,y)
104		#' ```
105		#'
106		#' @param x (`qenv`)
107		#' @param y (`qenv`)
108		#'
109		#' @return `qenv` object.
110		#'
111		#' @examples
112		#' q <- qenv()
113		#' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
114		#' q2 <- q1
115		#' q1 <- eval_code(q1, "iris2 <- iris")
116		#' q2 <- eval_code(q2, "mtcars2 <- mtcars")
117		#' qq <- join(q1, q2)
118		#' get_code(qq)
119		#'
120		#' common_q <- eval_code(q, quote(x <- 1))
121		#' y_q <- eval_code(common_q, quote(y <- x * 2))
122		#' z_q <- eval_code(common_q, quote(z <- x * 3))
123		#' join_q <- join(y_q, z_q)
124		#' # get_code only has "x <- 1" occurring once
125		#' get_code(join_q)
126		#'
127		#' @include qenv-errors.R
128		#'
129		#' @name join
130		#' @rdname join
131		#' @aliases join,qenv,qenv-method
132		#' @aliases join,qenv,qenv.error-method
133		#' @aliases join,qenv.error,ANY-method
134		#'
135		#' @export
136	20x	setGeneric("join", function(x, y) standardGeneric("join"))
137
138		setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
139	16x	join_validation <- .check_joinable(x, y)
140
141		# join expressions
142	16x	if (!isTRUE(join_validation)) {
143	4x	stop(join_validation)
144		}
145
146	12x	id_unique <- !y@id %in% x@id
147	12x	x@id <- c(x@id, y@id[id_unique])
148	12x	x@code <- c(x@code, y@code[id_unique])
149	12x	x@warnings <- c(x@warnings, y@warnings[id_unique])
150	12x	x@messages <- c(x@messages, y@messages[id_unique])
151
152		# insert (and overwrite) objects from y to x
153	12x	x@env <- rlang::env_clone(x@env, parent = parent.env(.GlobalEnv))
154	12x	rlang::env_coalesce(env = x@env, from = y@env)
155	12x	x
156		})
157
158		setMethod("join", signature = c("qenv", "qenv.error"), function(x, y) {
159	1x	y
160		})
161
162		setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
163	3x	x
164		})
165
166		#' If two `qenv` can be joined
167		#'
168		#' Checks if two `qenv` objects can be combined.
169		#' For more information, please see [`join`]
170		#' @param x (`qenv`)
171		#' @param y (`qenv`)
172		#' @return `TRUE` if able to join or `character` used to print error message.
173		#' @keywords internal
174		.check_joinable <- function(x, y) {
175	30x	checkmate::assert_class(x, "qenv")
176	30x	checkmate::assert_class(y, "qenv")
177
178	30x	common_names <- intersect(rlang::env_names(x@env), rlang::env_names(y@env))
179	30x	is_overwritten <- vapply(common_names, function(el) {
180	28x	!identical(get(el, x@env), get(el, y@env))
181	30x	}, logical(1))
182	30x	if (any(is_overwritten)) {
183	4x	return(
184	4x	paste(
185	4x	"Not possible to join qenv objects if anything in their environment has been modified.\n",
186	4x	"Following object(s) have been modified:\n - ",
187	4x	paste(common_names[is_overwritten], collapse = "\n - ")
188		)
189		)
190		}
191
192	26x	shared_ids <- intersect(x@id, y@id)
193	26x	if (length(shared_ids) == 0) {
194	12x	return(TRUE)
195		}
196
197	14x	shared_in_x <- match(shared_ids, x@id)
198	14x	shared_in_y <- match(shared_ids, y@id)
199
200		# indices of shared ids should be 1:n in both slots
201	14x	if (identical(shared_in_x, shared_in_y) && identical(shared_in_x, seq_along(shared_ids))) {
202	8x	TRUE
203	6x	} else if (!identical(shared_in_x, shared_in_y)) {
204	3x	paste(
205	3x	"The common shared code of the qenvs does not occur in the same position in both qenv objects",
206	3x	"so they cannot be joined together as it's impossible to determine the evaluation's order.",
207	3x	collapse = ""
208		)
209		} else {
210	3x	paste(
211	3x	"There is code in the qenv objects before their common shared code",
212	3x	"which means these objects cannot be joined.",
213	3x	collapse = ""
214		)
215		}
216		}

1		#' Display `qenv` object
2		#'
3		#' Prints the `qenv` object.
4		#'
5		#' @param object (`qenv`)
6		#'
7		#' @return `object`, invisibly.
8		#'
9		#' @examples
10		#' q <- qenv()
11		#' q1 <- eval_code(q, expression(a <- 5, b <- data.frame(x = 1:10)))
12		#' q1
13		#'
14		#' @aliases show-qenv
15		#'
16		#' @importFrom methods show
17		#' @export
18		setMethod("show", "qenv", function(object) {
19	!	rlang::env_print(object@env)
20		})

1		#' Get warnings from `qenv` object
2		#'
3		#' Retrieve all warnings raised during code evaluation in a `qenv`.
4		#'
5		#' @param object (`qenv`)
6		#'
7		#' @return `character` containing warning information or `NULL` if no warnings.
8		#'
9		#' @examples
10		#' data_q <- qenv()
11		#' data_q <- eval_code(data_q, "iris_data <- iris")
12		#' warning_qenv <- eval_code(
13		#' data_q,
14		#' bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
15		#' )
16		#' cat(get_warnings(warning_qenv))
17		#'
18		#' @name get_warnings
19		#' @rdname get_warnings
20		#' @aliases get_warnings,qenv-method
21		#' @aliases get_warnings,qenv.error-method
22		#' @aliases get_warnings,NULL-method
23		#'
24		#' @export
25		setGeneric("get_warnings", function(object) {
26		# this line forces evaluation of object before passing to the generic
27		# needed for error handling to work properly
28	7x	grDevices::pdf(nullfile())
29	7x	on.exit(grDevices::dev.off())
30	7x	object
31
32	7x	standardGeneric("get_warnings")
33		})
34
35		setMethod("get_warnings", signature = c("qenv"), function(object) {
36	5x	if (all(object@warnings == "")) {
37	1x	return(NULL)
38		}
39
40	4x	lines <- mapply(
41	4x	function(warn, expr) {
42	6x	if (warn == "") {
43	1x	return(NULL)
44		}
45	5x	sprintf("%swhen running code:\n%s", warn, paste(lang2calls(expr), collapse = "\n"))
46		},
47	4x	warn = as.list(object@warnings),
48	4x	expr = as.list(as.character(object@code))
49		)
50	4x	lines <- Filter(Negate(is.null), lines)
51
52	4x	sprintf(
53	4x	"~~~ Warnings ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
54	4x	paste(lines, collapse = "\n\n"),
55	4x	get_code(object)
56		)
57		})
58
59		setMethod("get_warnings", signature = c("qenv.error"), function(object) {
60	1x	NULL
61		})
62
63		setMethod("get_warnings", "NULL", function(object) {
64	1x	NULL
65		})

1		#' Access environment included in `qenv`
2		#'
3		#' The access of environment included in `qenv@env` allows to e.g. list object names included in `qenv@env` slot.
4		#'
5		#' @param object (`qenv`)
6		#'
7		#' @return An `environment` stored in `qenv@env` slot.
8		#'
9		#' @examples
10		#' q <- qenv()
11		#' q1 <- within(q, {
12		#' a <- 5
13		#' b <- data.frame(x = 1:10)
14		#' })
15		#' get_env(q1)
16		#' ls(get_env(q1))
17		#'
18		#' @aliases get_env,qenv-method
19		#' @aliases get_env,qenv.error-method
20		#'
21		#' @export
22		setGeneric("get_env", function(object) {
23	!	standardGeneric("get_env")
24		})
25
26		setMethod("get_env", "qenv", function(object) {
27	!	object@env
28		})
29
30		setMethod("get_env", "qenv.error", function(object) {
31	!	object
32		})

1		#' Get code from `qenv`
2		#'
3		#' @details
4		#' `get_code` retrieves the code stored in the `qenv`. `...` passes arguments to methods.
5		#'
6		#' @param object (`qenv`)
7		#' @param deparse (`logical(1)`) flag specifying whether to return code as `character` or `expression`.
8		#' @param ... see `Details`
9		#'
10		#' @return
11		#' `get_code` returns the traced code (from `@code` slot) in the form specified by `deparse`.
12		#'
13		#' @examples
14		#' # retrieve code
15		#' get_code(q)
16		#' get_code(q, deparse = FALSE)
17		#'
18		#' @name get_code
19		#' @rdname qenv
20		#' @aliases get_code,qenv-method
21		#' @aliases get_code,qenv.error-method
22		#'
23		#' @export
24		setGeneric("get_code", function(object, deparse = TRUE, ...) {
25		# this line forces evaluation of object before passing to the generic
26		# needed for error handling to work properly
27	13x	grDevices::pdf(nullfile())
28	13x	on.exit(grDevices::dev.off())
29	13x	object
30
31	13x	standardGeneric("get_code")
32		})
33
34		setMethod("get_code", signature = "qenv", function(object, deparse = TRUE) {
35	11x	checkmate::assert_flag(deparse)
36	11x	if (deparse) {
37	10x	if (length(object@code) == 0) {
38	!	object@code
39		} else {
40	10x	paste(object@code, collapse = "\n")
41		}
42		} else {
43	1x	parse(text = paste(c("{", object@code, "}"), collapse = "\n"), keep.source = TRUE)
44		}
45		})
46
47		setMethod("get_code", signature = "qenv.error", function(object, ...) {
48	2x	stop(
49	2x	errorCondition(
50	2x	sprintf(
51	2x	"%s\n\ntrace: \n %s\n",
52	2x	conditionMessage(object),
53	2x	paste(object$trace, collapse = "\n ")
54		),
55	2x	class = c("validation", "try-error", "simpleError")
56		)
57		)
58		})

1		#' Get object from `qenv`
2		#'
3		#' Retrieve variables from the `qenv` environment.
4		#'
5		#' @param object,x (`qenv`)
6		#' @param var,i (`character(1)`) variable name.
7		#'
8		#' @return The value of required variable (`var`) within `qenv` object.
9		#'
10		#' @examples
11		#' q <- qenv()
12		#' q1 <- eval_code(q, code = quote(a <- 1))
13		#' q2 <- eval_code(q1, code = "b <- a")
14		#' get_var(q2, "b")
15		#' q2[["b"]]
16		#'
17		#' @name get_var
18		#' @rdname get_var
19		#' @aliases get_var,qenv,character-method
20		#' @aliases get_var,qenv.error,ANY-method
21		#'
22		#' @export
23		setGeneric("get_var", function(object, var) {
24	11x	grDevices::pdf(nullfile())
25	11x	on.exit(grDevices::dev.off())
26	11x	standardGeneric("get_var")
27		})
28
29		setMethod("get_var", signature = c("qenv", "character"), function(object, var) {
30	10x	tryCatch(
31	10x	get(var, envir = object@env, inherits = FALSE),
32	10x	error = function(e) {
33	6x	message(conditionMessage(e))
34	6x	NULL
35		}
36		)
37		})
38
39		setMethod("get_var", signature = c("qenv.error", "ANY"), function(object, var) {
40	1x	stop(errorCondition(
41	1x	list(message = conditionMessage(object)),
42	1x	class = c("validation", "try-error", "simpleError")
43		))
44		})
45
46		#' @rdname get_var
47		setMethod("[[", signature = c("qenv", "ANY"), function(x, i) {
48	5x	get_var(x, i)
49		})
50
51		#' @export
52		`[[.qenv.error` <- function(x, i) {
53	1x	stop(errorCondition(
54	1x	list(message = conditionMessage(x)),
55	1x	class = c("validation", "try-error", "simpleError")
56		))
57		}