teal.code coverage - 95.10%

Files
Source

#' 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`)
#' @include qenv-errors.R
#' @return `qenv` object.
#' @examples
#' q1 <- new_qenv(
#'   code = c(iris1 = "iris1 <- iris", mtcars1 = "mtcars1 <- mtcars"),
#'   env = list2env(list(
#'     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)
#' @export
setGeneric("concat", function(x, y) standardGeneric("concat"))

#' @rdname concat
#' @export
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
})

#' @rdname concat
#' @export
setMethod("concat", signature = c("qenv.error"), function(x, y) {
  x
})

#' @rdname concat
#' @export
setMethod("concat", signature = c("qenv", "qenv.error"), function(x, y) {
  y
})

#' Evaluate the code in the `qenv` environment
#'
#' Given code is evaluated in the `qenv` environment and appended to the `code` slot. This means
#' that state of the environment is always a result of the stored code (if `qenv` was initialized)
#' with reproducible code.
#'
#' @name eval_code
#'
#' @param object (`qenv`)
#' @param code (`character` or `language`) code to evaluate. Also accepts and stores comments
#'
#' @examples
#' q1 <- new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
#' q2 <- eval_code(q1, quote(library(checkmate)))
#' q3 <- eval_code(q2, quote(assert_number(a)))
#'
#' @return `qenv` object.
#'
#' @export
setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))

#' @rdname eval_code
#' @export
setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
  id <- sample.int(.Machine$integer.max, size = length(code))

  object@id <- c(object@id, id)
  object@env <- rlang::env_clone(object@env, parent = parent.env(.GlobalEnv))
  object@code <- c(object@code, code)

  current_warnings <- ""
  current_messages <- ""

  for (code_line in code) {
    # Using withCallingHandlers to capture ALL warnings and messages.
    # Using tryCatch to capture the FIRST error and abort further evaluation.
    x <- withCallingHandlers(
      tryCatch(
        {
          eval(code_line, envir = object@env)
          NULL
        },
        error = function(e) {
          errorCondition(
            message = sprintf(
              "%s \n when evaluating qenv code:\n%s",
              .ansi_strip(conditionMessage(e)),
              paste(format_expression(code), collapse = "\n")
            ),
            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
})

#' @rdname eval_code
#' @export
setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
  code_char <- as.expression(code)
  eval_code(object, code_char)
})

#' @rdname eval_code
#' @export
setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
  eval_code(object, code = parse(text = code, keep.source = FALSE))
})

#' @rdname eval_code
#' @export
setMethod("eval_code", signature = "qenv.error", 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 two `qenv` objects
#'
#' `join()` perform 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:
#' \enumerate{
#'   \item Both `qenv` objects contain an object of the same name but are not identical. \cr\cr
#'   Example:
#'   \preformatted{
#'   x <- new_qenv(
#'     code = c(mtcars1 = "mtcars1 <- mtcars"),
#'     env = list2env(list(mtcars1 = mtcars))
#'   )
#'   y <- new_qenv(
#'     code = c(mtcars1 = "mtcars1 <- mtcars['wt']"),
#'     env = list2env(list(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.\cr
#'   `mtcars1` in the `x qenv` object has more columns than `mtcars1` in the `y qenv` object (only has one column).
#'   \item `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.\cr\cr
#'   Example:
#'   \preformatted{
#'   common_q <- new_qenv(code = "v <- 1", env = list2env(list(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.
#'   \item The usage of temporary variable in the code expression could cause `join()` to fail. \cr\cr
#'   Example:
#'   \preformatted{
#'   common_q <- new_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.\cr
#'   To fix this, we can set `i <- NULL` in the code expression for both objects.
#'   \preformatted{
#'   common_q <- new_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`)
#' @include qenv-errors.R
#' @return `qenv` object.
#' @examples
#' q1 <- new_qenv(
#'   code = c(iris1 = "iris1 <- iris", mtcars1 = "mtcars1 <- mtcars"),
#'   env = list2env(list(
#'     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 <- new_qenv(list2env(list(x = 1)), 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)
#'
#' @export
setGeneric("join", function(x, y) standardGeneric("join"))

#' @rdname join
#' @export
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
})

#' @rdname join
#' @export
setMethod("join", signature = "qenv.error", function(x, y) {
  x
})

#' @rdname join
#' @export
setMethod("join", signature = c("qenv", "qenv.error"), function(x, y) {
  y
})

#' If two `qenv` can be joined
#'
#' Checks if two `qenv` objects can be combined.
#' For more information, please see \code{\link{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 = ""
    )
  }
}

#' Get the warnings of `qenv` object
#'
#' @param object (`qenv`)
#'
#' @return `character` containing warning information or `NULL` if no warnings
#' @export
#'
#' @examples
#' data_q <- new_qenv()
#' data_q <- eval_code(new_qenv(), "iris_data <- iris")
#' warning_qenv <- eval_code(
#'   data_q,
#'   bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
#' )
#' cat(get_warnings(warning_qenv))
#' @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")
})

#' @rdname get_warnings
#' @export
setMethod("get_warnings", signature = c("qenv.error"), function(object) {
  NULL
})

#' @rdname get_warnings
#' @export
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(format_expression(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"),
    paste(get_code(object), collapse = "\n")
  )
})

#' @rdname get_warnings
#' @export
setMethod("get_warnings", "NULL", function(object) {
  NULL
})

#' Removes leading and trailing curly brackets from character
#' string and removes indentation of remaining contents
#'
#' @description `r lifecycle::badge("stable")`
#' @param x (`character`)\cr
#'
#' @return character string without curly braces
#' @keywords internal
remove_enclosing_curly_braces <- function(x) {
  checkmate::assert_character(x)
  if (length(x) == 0) {
    return(x)
  }

  open_bracket_and_spaces <- "^[[:blank:]]*\\{[[:blank:]]*$"
  close_bracket_and_spaces <- "^[[:blank:]]*\\}[[:blank:]]*$"
  blank_line <- "^[[:blank:]]*$"
  four_spaces_at_start_of_line <- "^[[:blank:]]{4}"

  split_text <- unlist(strsplit(x, "\n", fixed = TRUE))

  # if text begins with "{   \n" and ends with "\n}   "
  if (grepl(open_bracket_and_spaces, utils::head(split_text, 1)) &&
    grepl(close_bracket_and_spaces, utils::tail(split_text, 1))) {
    # remove the first and last line
    split_text <- split_text[-c(1, length(split_text))]

    # if any line is not blank then indent
    if (!all(grepl(blank_line, split_text))) {
      return(gsub(four_spaces_at_start_of_line, "", split_text))
    } else {
      return(split_text)
    }
  } else {
    return(split_text)
  }
}

#' Suppresses plot display in the IDE by opening a PDF graphics device
#'
#' This function opens a PDF graphics device using \code{\link[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 \code{\link[base]{on.exit}} to ensure that the PDF graphics
#'          device is closed (using \code{\link[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.
#'
#' @import grDevices
#'
#'
#' @examples
#' dev_suppress(plot(1:10))
#' @export
dev_suppress <- function(x) {
  grDevices::pdf(nullfile())
  on.exit(grDevices::dev.off())
  force(x)
}

# converts vector of expressions to character
format_expression <- function(code) {
  as.character(styler::style_text(unlist(lapply(as.character(code), remove_enclosing_curly_braces))))
}

#' Include `CSS` files from `/inst/css/` package directory to application header
#'
#' `system.file` should not be used to access files in other packages, it does
#' not work with `devtools`. Therefore, we redefine this method in each package
#' as needed. Thus, we do not export this method
#'
#' @param pattern (`character`) pattern of files to be included
#'
#' @return HTML code that includes `CSS` files
#' @keywords internal
include_css_files <- function(pattern = "*") {
  css_files <- list.files(
    system.file("css", package = "teal.code", mustWork = TRUE),
    pattern = pattern, full.names = TRUE
  )
  if (length(css_files) == 0) {
    return(NULL)
  }

  shiny::singleton(lapply(css_files, shiny::includeCSS))
}

#' Get code from `qenv`
#'
#' @name get_code
#' @param object (`qenv`)
#' @param deparse (`logical(1)`) if the returned code should be converted to character.
#' @return named `character` with the reproducible code.
#' @examples
#' q1 <- new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
#' q2 <- eval_code(q1, code = quote(b <- a))
#' q3 <- eval_code(q2, code = quote(d <- 2))
#' get_code(q3)
#' get_code(q3, deparse = FALSE)
#' @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")
})

#' @rdname get_code
#' @export
setMethod("get_code", signature = "qenv", function(object, deparse = TRUE) {
  checkmate::assert_flag(deparse)
  if (deparse) {
    format_expression(object@code)
  } else {
    object@code
  }
})

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

#' Get object from the `qenv` environment
#'
#' Get object from the `qenv` environment.
#' @param object (`qenv`)
#' @param var (`character(1)`) name of the variable to pull from the environment.
#' @name get_var
#' @return The value of required variable (`var`) within `qenv` object.
#' @examples
#' q1 <- new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
#' q2 <- eval_code(q1, code = "b <- a")
#' get_var(q2, "b")
#' q2[["b"]]
#'
#' @export
setGeneric("get_var", function(object, var) {
  grDevices::pdf(nullfile())
  on.exit(grDevices::dev.off())
  standardGeneric("get_var")
})


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

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


#' @param x (`qenv`)
#' @param i (`character`) name of the binding in environment (name of the variable)
#' @param j not used
#' @param ... not used
#' @rdname get_var
#' @export
setMethod("[[", signature = c("qenv", "ANY", "missing"), function(x, i, j, ...) {
  get_var(x, i)
})

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

#' Initialize `qenv` object
#'
#' Initialize `qenv` object with `code` and `env`. In order to have `qenv` reproducible
#' one needs to initialize with `env` which can be reproduced by the `code`. Alternatively, one
#' can create an empty `qenv` and evaluate the expressions in this object using `eval_code`.
#' @name new_qenv
#'
#' @param code (`character(1)` or `language`) code to evaluate. Accepts and stores comments also.
#' @param env (`environment`) Environment being a result of the `code` evaluation.
#'
#' @examples
#' new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
#' new_qenv(env = list2env(list(a = 1)), code = parse(text = "a <- 1"))
#' new_qenv(env = list2env(list(a = 1)), code = "a <- 1")
#'
#' @return `qenv` object.
#'
#' @export
setGeneric("new_qenv", function(env = new.env(parent = parent.env(.GlobalEnv)), code = expression()) standardGeneric("new_qenv")) # nolint

#' @rdname new_qenv
#' @export
setMethod(
  "new_qenv",
  signature = c(env = "environment", code = "expression"),
  function(env, code) {
    new_env <- rlang::env_clone(env, parent = parent.env(.GlobalEnv))
    lockEnvironment(new_env, bindings = TRUE)
    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
    )
  }
)

#' @rdname new_qenv
#' @export
setMethod(
  "new_qenv",
  signature = c(env = "environment", code = "character"),
  function(env, code) {
    new_qenv(env, code = parse(text = code, keep.source = FALSE))
  }
)

#' @rdname new_qenv
#' @export
setMethod(
  "new_qenv",
  signature = c(env = "environment", code = "language"),
  function(env, code) {
    code_expr <- as.expression(code)
    new_qenv(env = env, code = code_expr)
  }
)

#' @rdname new_qenv
#' @export
setMethod(
  "new_qenv",
  signature = c(code = "missing", env = "missing"),
  function(env, code) {
    new_qenv(env = env, code = code)
  }
)

#' Show the `qenv` object
#'
#' Prints the `qenv` object
#' @param object (`qenv`)
#' @return nothing
#' @importFrom methods show
#' @examples
#' q1 <- new_qenv(
#'   code = "a <- 5
#'     b <- data.frame(x = 1:10)",
#'   env = list2env(list(a = 5, b = data.frame(x = 1:10)))
#' )
#' q1
#' @export
setMethod("show", "qenv", function(object) {
  rlang::env_print(object@env)
})

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

1		#' Evaluate the code in the `qenv` environment
2		#'
3		#' Given code is evaluated in the `qenv` environment and appended to the `code` slot. This means
4		#' that state of the environment is always a result of the stored code (if `qenv` was initialized)
5		#' with reproducible code.
6		#'
7		#' @name eval_code
8		#'
9		#' @param object (`qenv`)
10		#' @param code (`character` or `language`) code to evaluate. Also accepts and stores comments
11		#'
12		#' @examples
13		#' q1 <- new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
14		#' q2 <- eval_code(q1, quote(library(checkmate)))
15		#' q3 <- eval_code(q2, quote(assert_number(a)))
16		#'
17		#' @return `qenv` object.
18		#'
19		#' @export
20	125x	setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
21
22		#' @rdname eval_code
23		#' @export
24		setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
25	63x	id <- sample.int(.Machine$integer.max, size = length(code))
26
27	63x	object@id <- c(object@id, id)
28	63x	object@env <- rlang::env_clone(object@env, parent = parent.env(.GlobalEnv))
29	63x	object@code <- c(object@code, code)
30
31	63x	current_warnings <- ""
32	63x	current_messages <- ""
33
34	63x	for (code_line in code) {
35		# Using withCallingHandlers to capture ALL warnings and messages.
36		# Using tryCatch to capture the FIRST error and abort further evaluation.
37	66x	x <- withCallingHandlers(
38	66x	tryCatch(
39		{
40	66x	eval(code_line, envir = object@env)
41	56x	NULL
42		},
43	66x	error = function(e) {
44	10x	errorCondition(
45	10x	message = sprintf(
46	10x	"%s \n when evaluating qenv code:\n%s",
47	10x	.ansi_strip(conditionMessage(e)),
48	10x	paste(format_expression(code), collapse = "\n")
49		),
50	10x	class = c("qenv.error", "try-error", "simpleError"),
51	10x	trace = object@code
52		)
53		}
54		),
55	66x	warning = function(w) {
56	15x	current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w))))
57	15x	invokeRestart("muffleWarning")
58		},
59	66x	message = function(m) {
60	5x	current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m))))
61	5x	invokeRestart("muffleMessage")
62		}
63		)
64	66x	if (!is.null(x)) {
65	10x	return(x)
66		}
67
68	56x	object@warnings <- c(object@warnings, current_warnings)
69	56x	object@messages <- c(object@messages, current_messages)
70		}
71	53x	lockEnvironment(object@env, bindings = TRUE)
72	53x	object
73		})
74
75		#' @rdname eval_code
76		#' @export
77		setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
78	44x	code_char <- as.expression(code)
79	44x	eval_code(object, code_char)
80		})
81
82		#' @rdname eval_code
83		#' @export
84		setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
85	17x	eval_code(object, code = parse(text = code, keep.source = FALSE))
86		})
87
88		#' @rdname eval_code
89		#' @export
90		setMethod("eval_code", signature = "qenv.error", function(object, code) {
91	!	object
92		})
93
94		# if cli is installed rlang adds terminal printing characters
95		# which need to be removed
96		.ansi_strip <- function(chr) {
97	30x	if (requireNamespace("cli", quietly = TRUE)) {
98	30x	cli::ansi_strip(chr)
99		} else {
100	!	chr
101		}
102		}

1		#' Get the warnings of `qenv` object
2		#'
3		#' @param object (`qenv`)
4		#'
5		#' @return `character` containing warning information or `NULL` if no warnings
6		#' @export
7		#'
8		#' @examples
9		#' data_q <- new_qenv()
10		#' data_q <- eval_code(new_qenv(), "iris_data <- iris")
11		#' warning_qenv <- eval_code(
12		#' data_q,
13		#' bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
14		#' )
15		#' cat(get_warnings(warning_qenv))
16		#' @export
17		setGeneric("get_warnings", function(object) {
18		# this line forces evaluation of object before passing to the generic
19		# needed for error handling to work properly
20	7x	grDevices::pdf(nullfile())
21	7x	on.exit(grDevices::dev.off())
22	7x	object
23
24	7x	standardGeneric("get_warnings")
25		})
26
27		#' @rdname get_warnings
28		#' @export
29		setMethod("get_warnings", signature = c("qenv.error"), function(object) {
30	1x	NULL
31		})
32
33		#' @rdname get_warnings
34		#' @export
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(format_expression(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	paste(get_code(object), collapse = "\n")
56		)
57		})
58
59		#' @rdname get_warnings
60		#' @export
61		setMethod("get_warnings", "NULL", function(object) {
62	1x	NULL
63		})

1		#' Removes leading and trailing curly brackets from character
2		#' string and removes indentation of remaining contents
3		#'
4		#' @description `r lifecycle::badge("stable")`
5		#' @param x (`character`)\cr
6		#'
7		#' @return character string without curly braces
8		#' @keywords internal
9		remove_enclosing_curly_braces <- function(x) {
10	48x	checkmate::assert_character(x)
11	47x	if (length(x) == 0) {
12	1x	return(x)
13		}
14
15	46x	open_bracket_and_spaces <- "^[[:blank:]]\\{[[:blank:]]$"
16	46x	close_bracket_and_spaces <- "^[[:blank:]]\\}[[:blank:]]$"
17	46x	blank_line <- "^[[:blank:]]*$"
18	46x	four_spaces_at_start_of_line <- "^[[:blank:]]{4}"
19
20	46x	split_text <- unlist(strsplit(x, "\n", fixed = TRUE))
21
22		# if text begins with "{ \n" and ends with "\n} "
23	46x	if (grepl(open_bracket_and_spaces, utils::head(split_text, 1)) &&
24	46x	grepl(close_bracket_and_spaces, utils::tail(split_text, 1))) {
25		# remove the first and last line
26	13x	split_text <- split_text[-c(1, length(split_text))]
27
28		# if any line is not blank then indent
29	13x	if (!all(grepl(blank_line, split_text))) {
30	11x	return(gsub(four_spaces_at_start_of_line, "", split_text))
31		} else {
32	2x	return(split_text)
33		}
34		} else {
35	33x	return(split_text)
36		}
37		}
38
39		#' Suppresses plot display in the IDE by opening a PDF graphics device
40		#'
41		#' This function opens a PDF graphics device using \code{\link[grDevices]{pdf}} to suppress
42		#' the plot display in the IDE. The purpose of this function is to avoid opening graphic devices
43		#' directly in the IDE.
44		#'
45		#' @param x lazy binding which generates the plot(s)
46		#'
47		#' @details The function uses \code{\link[base]{on.exit}} to ensure that the PDF graphics
48		#' device is closed (using \code{\link[grDevices]{dev.off}}) when the function exits,
49		#' regardless of whether it exits normally or due to an error. This is necessary to
50		#' clean up the graphics device properly and avoid any potential issues.
51		#'
52		#' @import grDevices
53		#'
54		#'
55		#' @examples
56		#' dev_suppress(plot(1:10))
57		#' @export
58		dev_suppress <- function(x) {
59	2x	grDevices::pdf(nullfile())
60	2x	on.exit(grDevices::dev.off())
61	2x	force(x)
62		}
63
64		# converts vector of expressions to character
65		format_expression <- function(code) {
66	23x	as.character(styler::style_text(unlist(lapply(as.character(code), remove_enclosing_curly_braces))))
67		}

1		#' Get code from `qenv`
2		#'
3		#' @name get_code
4		#' @param object (`qenv`)
5		#' @param deparse (`logical(1)`) if the returned code should be converted to character.
6		#' @return named `character` with the reproducible code.
7		#' @examples
8		#' q1 <- new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
9		#' q2 <- eval_code(q1, code = quote(b <- a))
10		#' q3 <- eval_code(q2, code = quote(d <- 2))
11		#' get_code(q3)
12		#' get_code(q3, deparse = FALSE)
13		#' @export
14		setGeneric("get_code", function(object, deparse = TRUE) {
15		# this line forces evaluation of object before passing to the generic
16		# needed for error handling to work properly
17	8x	grDevices::pdf(nullfile())
18	8x	on.exit(grDevices::dev.off())
19	8x	object
20
21	8x	standardGeneric("get_code")
22		})
23
24		#' @rdname get_code
25		#' @export
26		setMethod("get_code", signature = "qenv", function(object, deparse = TRUE) {
27	7x	checkmate::assert_flag(deparse)
28	7x	if (deparse) {
29	6x	format_expression(object@code)
30		} else {
31	1x	object@code
32		}
33		})
34
35		#' @rdname get_code
36		#' @export
37		setMethod("get_code", signature = "qenv.error", function(object) {
38	1x	stop(
39	1x	errorCondition(
40	1x	sprintf(
41	1x	"%s\n\ntrace: \n %s\n",
42	1x	conditionMessage(object),
43	1x	paste(format_expression(object$trace), collapse = "\n ")
44		),
45	1x	class = c("validation", "try-error", "simpleError")
46		)
47		)
48		})

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

1		#' Include `CSS` files from `/inst/css/` package directory to application header
2		#'
3		#' `system.file` should not be used to access files in other packages, it does
4		#' not work with `devtools`. Therefore, we redefine this method in each package
5		#' as needed. Thus, we do not export this method
6		#'
7		#' @param pattern (`character`) pattern of files to be included
8		#'
9		#' @return HTML code that includes `CSS` files
10		#' @keywords internal
11		include_css_files <- function(pattern = "*") {
12	!	css_files <- list.files(
13	!	system.file("css", package = "teal.code", mustWork = TRUE),
14	!	pattern = pattern, full.names = TRUE
15		)
16	!	if (length(css_files) == 0) {
17	!	return(NULL)
18		}
19
20	!	shiny::singleton(lapply(css_files, shiny::includeCSS))
21		}

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

1		#' Initialize `qenv` object
2		#'
3		#' Initialize `qenv` object with `code` and `env`. In order to have `qenv` reproducible
4		#' one needs to initialize with `env` which can be reproduced by the `code`. Alternatively, one
5		#' can create an empty `qenv` and evaluate the expressions in this object using `eval_code`.
6		#' @name new_qenv
7		#'
8		#' @param code (`character(1)` or `language`) code to evaluate. Accepts and stores comments also.
9		#' @param env (`environment`) Environment being a result of the `code` evaluation.
10		#'
11		#' @examples
12		#' new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
13		#' new_qenv(env = list2env(list(a = 1)), code = parse(text = "a <- 1"))
14		#' new_qenv(env = list2env(list(a = 1)), code = "a <- 1")
15		#'
16		#' @return `qenv` object.
17		#'
18		#' @export
19	143x	setGeneric("new_qenv", function(env = new.env(parent = parent.env(.GlobalEnv)), code = expression()) standardGeneric("new_qenv")) # nolint
20
21		#' @rdname new_qenv
22		#' @export
23		setMethod(
24		"new_qenv",
25		signature = c(env = "environment", code = "expression"),
26		function(env, code) {
27	73x	new_env <- rlang::env_clone(env, parent = parent.env(.GlobalEnv))
28	73x	lockEnvironment(new_env, bindings = TRUE)
29	73x	id <- sample.int(.Machine$integer.max, size = length(code))
30	73x	methods::new(
31	73x	"qenv",
32	73x	env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id
33		)
34		}
35		)
36
37		#' @rdname new_qenv
38		#' @export
39		setMethod(
40		"new_qenv",
41		signature = c(env = "environment", code = "character"),
42		function(env, code) {
43	1x	new_qenv(env, code = parse(text = code, keep.source = FALSE))
44		}
45		)
46
47		#' @rdname new_qenv
48		#' @export
49		setMethod(
50		"new_qenv",
51		signature = c(env = "environment", code = "language"),
52		function(env, code) {
53	27x	code_expr <- as.expression(code)
54	27x	new_qenv(env = env, code = code_expr)
55		}
56		)
57
58		#' @rdname new_qenv
59		#' @export
60		setMethod(
61		"new_qenv",
62		signature = c(code = "missing", env = "missing"),
63		function(env, code) {
64	40x	new_qenv(env = env, code = code)
65		}
66		)

1		#' Show the `qenv` object
2		#'
3		#' Prints the `qenv` object
4		#' @param object (`qenv`)
5		#' @return nothing
6		#' @importFrom methods show
7		#' @examples
8		#' q1 <- new_qenv(
9		#' code = "a <- 5
10		#' b <- data.frame(x = 1:10)",
11		#' env = list2env(list(a = 5, b = data.frame(x = 1:10)))
12		#' )
13		#' q1
14		#' @export
15		setMethod("show", "qenv", function(object) {
16	!	rlang::env_print(object@env)
17		})