diff --git a/.github/ISSUE_TEMPLATE/cran-release.yaml b/.github/ISSUE_TEMPLATE/cran-release.yaml new file mode 100644 index 000000000..49a81e67c --- /dev/null +++ b/.github/ISSUE_TEMPLATE/cran-release.yaml @@ -0,0 +1,101 @@ +--- +name: 🎉 CRAN Release +description: Template for release to CRAN +title: "[Release]: " +labels: ["release"] +assignees: + - KlaudiaBB + - cicdguy + - shajoezhu +body: + - type: markdown + attributes: + value: | + ⚠️ Please do not link or mention any internal references in this issue. This includes internal URLs, intellectual property and references. + - type: textarea + id: blocked-by + attributes: + label: Blocked by + description: Any PRs or issues that this release is blocked by. + placeholder: Add a list of blocking PRs or issues here. + value: | + ### PRs + + - [ ] PR 1 + + ### Issues + + - [ ] Issue 1 + validations: + required: true + - type: textarea + id: pre-requisites + attributes: + label: Pre-requisites + description: Pre-requisites that must be fulfilled before initiating the release process. + placeholder: Add your list of pre-requisites here. + value: | + - [ ] Make sure that high priority bugs (label "priority" + "bug") have been resolved before going into the release. + - [ ] Review old/hanging PRs before going into the release (Optional). + - [ ] Revisit R-package's lifecycle badges (Optional). + - [ ] Make sure that all upstream dependencies of this package that need to be submitted to CRAN were accepted before going into release activities. + - [ ] Make sure integration tests are green 2-3 days before the release. Look carefully through logs (check for warnings and notes). + - [ ] Decide what gets merged in before starting release activities. + - type: textarea + id: release-checklist + attributes: + label: Release Checklist + description: The steps to be taken in order to create a release. + placeholder: Steps to create a release. + value: | + - [ ] Update NEWS.md file: make sure it reflects a holistic summary of what has changed in the package. + - [ ] Remove the additional fields (`Remotes` and `Config/Needs/*`) from the DESCRIPTION file where applicable. + - [ ] Increase versioned dependency on {package name} to >=X.X.X (Optional). + - [ ] Make sure that the minimum dependency versions are updated in the DESCRIPTION file for the package and its reverse dependencies (Optional). + - [ ] Create a pull request to make necessary bug fixes/changes (add "[skip vbump]" in the pr title), and after merging the PR, tag the update(s) as a release candidate v < intended release version > -rc < release candidate iteration > on the main branch. + - [ ] Build the package locally using the command:`R CMD build .` which will generate a .tar.gz file necessary for the CRAN submission. + - [ ] Submit the package that was build in the previous step via this form: https://cran.r-project.org/submit.html. + - [ ] Address CRAN feedback, tag the package vX.X.X-rc(n+1) and repeat the submission to CRAN whenever necessary. + - [ ] Get the package accepted and published on CRAN. + - [ ] If the additional fields were removed, add them back in a separate PR, and then merge the PR back to main. Note: Take precautionary measures to ensure that the version bump does not take place on a merge. + - [ ] Create a git tag with the final version set to X.X.X on the main branch. + - type: textarea + id: testing + attributes: + label: Testing + description: Summary of testing activities - integration tests, UAT, other + placeholder: Tests results + value: | + - [ ] Integration tests results - accepted. + - [ ] UAT results - accepted. + - [ ] All testing activities are finalized. + - type: textarea + id: feedback + attributes: + label: Release Feedback + description: Feedback received from CRAN/testers. + placeholder: Feedback to be implemented after CRAN submission/testing. + value: | + - [ ] Fix 1 + - [ ] Enhancement 1 + - [ ] Defect 1 + - type: textarea + id: post-release + attributes: + label: Post-release Checklist + description: The list of activities to be completed after the release. + placeholder: The steps that must be taken after the release. + value: | + - [ ] Make sure that the package is published to internal repositories. + - [ ] Review and update installation instructions for the package wherever needed (Optional). + - [ ] Update all integration tests to reference the new release. + - [ ] Ensure a new dev version (.9XXX) is added to the NEWS.md file and DESCRIPTION file as a placeholder for release notes. + - [ ] Announce the release on ________. + - type: textarea + id: decision-tree + attributes: + label: Decision tree + description: Any decision tree(s) that would aid release management + placeholder: Any decision tree(s) that would aid release management. + value: | + Click [here](https://github.com/insightsengineering/.github/blob/main/.github/ISSUE_TEMPLATE/RELEASE_DECISION_TREE.md) to see the release decision tree. diff --git a/DESCRIPTION b/DESCRIPTION index 4f7246f80..96f9ff983 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Type: Package Package: teal.code Title: Code Storage and Execution Class for `teal` Applications -Version: 0.4.0.9001 -Date: 2023-08-21 +Version: 0.4.0.9003 +Date: 2023-08-25 Authors@R: c( person("Dawid", "Kaledkowski", , "dawid.kaledkowski@roche.com", role = c("aut", "cre")), person("Pawel", "Rucki", , "pawel.rucki@roche.com", role = "aut"), @@ -54,3 +54,4 @@ Collate: 'qenv-show.R' 'teal.code-package.R' 'utils.R' + 'with-qenv.R' diff --git a/NAMESPACE b/NAMESPACE index aa2789359..bcb7acdca 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,14 +1,31 @@ # Generated by roxygen2: do not edit by hand +S3method("$<-",quenv) +S3method("[",quenv) S3method("[[",qenv.error) +S3method("[[<-",quenv) +S3method(.object_info,character) +S3method(.object_info,data.frame) +S3method(.object_info,default) +S3method(.object_info,factor) +S3method(.object_info,matrix) +S3method(.object_info,numeric) +S3method(format,quenv) +S3method(print,quenv) +S3method(with,quenv) +S3method(within,quenv) +export(.object_info) export(concat) export(dev_suppress) export(eval_code) export(get_code) +export(get_code_quenv) +export(get_conditions) export(get_var) export(get_warnings) export(join) export(new_qenv) +export(quenv) exportMethods("[[") exportMethods(concat) exportMethods(eval_code) diff --git a/NEWS.md b/NEWS.md index f1d70f7cf..8a5032e8d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,11 @@ -# teal.code 0.4.0.9001 +# teal.code 0.4.0.9003 + +### Miscellaneous +* Fix NEWS # teal.code 0.4.0 -# Breaking Change +### Breaking Change * `chunks` have been removed. The new `qenv` object should be used instead. See the new `qenv` vignette in the package for further details. ### Miscellaneous diff --git a/R/with-qenv.R b/R/with-qenv.R new file mode 100644 index 000000000..3bbc74a92 --- /dev/null +++ b/R/with-qenv.R @@ -0,0 +1,410 @@ +#' qenv refactor prototype +#' +#' Simple to use environment with history tracking. +#' +#' @details +#' Create a `quenv` object, which is an environment, and execute code inside. +#' Code can be supplied as expressions, literal character vectors, as well as name-bound character vectors. +#' External values can be injected into the code with the ellipsis. +#' +#' `quenv` creates `quenv` object. +#' `with` acts in `quenv` object. +#' `within` creates and modifies a (deep) copy of `quenv` object. +#' `get_code` returns list of function calls or a data.frame with code and the conditions it raised. +#' `get_conditions` returns list of condition messages (character strings). +#' +#' @param data,x (`quenv`) +#' @param expr (`language`) simple or compound expression to evaluate in `data` +#' @param text (`character`) character vector of expressions to evaluate in `data` +#' @param ... `name:value` pairs to inject values into `expr` +#' +#' @return +#' `quenv` returns a `quenv` object. `with` returns NULL invisibly. `within` returns a modified deep copy of `data`. +#' +#' @name quenv +#' +#' @examples +#' +#' q <- quenv() +#' +#' # execute code +#' with(q, { +#' i <- iris +#' m <- mtcars +#' }) +#' q +#' +#' # supply code as strings +#' q <- quenv() +#' with(q, text = "c <- cars") +#' code_as_text <- "w <- warpbreaks" +#' with(q, text = code_as_text) +#' +#' # error messages are stored +#' try( +#' with(q, { +#' subset(i, Species == species) # raises error and stops evaluation +#' ms <- subset(m, cyl == 4) # not evaluated +#' }) +#' ) +#' q +#' +#' # warnings and messages are also stored +#' with(q, { +#' warning("this is a warning") +#' }) +#' with(q, { +#' message("this is a message") +#' }) +#' q +#' +#' # access variables and environment history +#' q$m +#' get_code(q) +#' get_conditions(q, "error") +#' +#' # inject values into code +#' q <- quenv() +#' with(q, i <- iris) +#' with(q, print(dim(subset(i, Species == "virginica")))) +#' try( +#' with(q, print(dim(subset(i, Species == species)))) # fails +#' ) +#' with(q, print(dim(subset(i, Species == species))), species = "versicolor") +#' species_external <- "versicolor" +#' with(q, print(dim(subset(i, Species == species))), species = species_external) +#' +#' # execute code in copy of `quenv` and return modified copy +#' q <- quenv() +#' with(q, i <- iris) +#' qq <- within(q, m <- mtcars) +#' + +#' @rdname quenv +#' @export +quenv <- function() { + ans <- new.env() + attr(ans, "code") <- list() + attr(ans, "errors") <- list() + attr(ans, "warnings") <- list() + attr(ans, "messages") <- list() + class(ans) <- c("quenv", class(ans)) + ans +} + + +#' @rdname quenv +#' @export +with.quenv <- function(data, expr, text, ...) { + code <- .prepare_code(if (!missing(expr)) substitute(expr), if (!missing(text)) text) + extras <- list(...) + lapply(code, .eval_one, envir = data, enclos = parent.frame(), extras = extras) + invisible(NULL) +} + + +#' @rdname quenv +#' @export +within.quenv <- function(data, expr, text, ...) { + # Force a return even if some evaluation fails. + on.exit(return(data)) + data <- .clone_quenv(data) + code <- .prepare_code(if (!missing(expr)) substitute(expr), if (!missing(text)) text) + extras <- list(...) + lapply(code, .eval_one, envir = data, enclos = parent.frame(), extras = extras) +} + + +#' @rdname quenv +#' @export +#' @keywords internal +format.quenv <- function(x) { + # opening message + header <- paste( + "`quenv` object (environment)", + " Use `with(quenv, { })` to evaluate code in the quenv.", + " Use `get_code(quenv)` to access all code run in the quenv since instantiation.", + " Use `quenv$` or `quenv[[\"\"]]`to access variables.", + sep = "\n" + ) + + # contents/bindings # nolint + var_names <- ls(x) + var_names_hidden <- setdiff(ls(x, all.names = TRUE), var_names) + + if (length(var_names) + length(var_names_hidden) > 0L) { + var_classes <- sapply(var_names, function(vn) toString(class(get(vn, envir = x, inherits = FALSE)))) + var_classes_hidden <- sapply(var_names_hidden, function(vn) toString(class(get(vn, envir = x, inherits = FALSE)))) + + + longest_name <- max(nchar(c(var_names, var_names_hidden))) + longest_class <- max(nchar(c(var_classes, var_classes_hidden))) + + contents <- if (is.finite(longest_name)) { + paste( + sprintf(sprintf(" $ %%-0%is", longest_name), var_names), + sprintf(sprintf("%%-0%is", longest_class), var_classes), + vapply(var_names, function(v) .object_info(get(v, envir = x)), character(1)), + sep = " : ", collapse = "\n" + ) + } + + contents_hidden <- paste( + sprintf(sprintf(" $ %%-0%is", longest_name), var_names_hidden), + sprintf(sprintf("%%-0%is", longest_class), var_classes_hidden), + vapply(var_names_hidden, function(v) .object_info(get(v, envir = x)), character(1)), + sep = " : ", collapse = "\n" + ) + + contents_all <- c( + if (!identical(contents, "")) sprintf("bindings:\n%s", contents), + if (!identical(contents_hidden, "")) sprintf("hidden bindings:\n%s", contents_hidden) + ) + } else { + contents_all <- "This quenv is empty." + } + + # code + code <- attr(x, "code") + code <- + if (identical(code, list())) { + "" + } else { + expressions <- vapply(code, function(x) paste(sprintf(" %s", deparse(x)), collapse = "\n"), character(1L)) + paste( + " {", + paste(expressions, collapse = "\n"), + " }", + sep = "\n" + ) + } + code <- if (!identical(code, "")) sprintf("code:\n%s", code) + + # conditions + conditions <- lapply(get_conditions(x, "all"), sprintf, fmt = " %s") + conditions <- unlist( + mapply( + function(value, name) sprintf("%s:\n%s", name, paste(value, collapse = "\n")), + value = conditions, name = names(conditions) + ) + ) + + # closing message + footer <- sprintf("parent: %s", format(parent.env(x))) + + c( + header, + "", + contents_all, + "", + code, + "", + conditions, + "", + footer + ) +} + + +#' @rdname quenv +#' @export +#' @keywords internal +print.quenv <- function(x, ...) { + cat(format(x, ...), sep = "\n") +} + + +#' @export +#' @keywords internal +`[.quenv` <- function(x, ...) { # nolint + stop("Use `quenv$` or `quenv[[\"\"]]`to access variables.") +} + + +#' @export +#' @keywords internal +`$<-.quenv` <- function(x, name, value) { # nolint + stop( + "Direct assignment is forbidden as it cannot be tracked. ", + "Use `with( , { <- })` instead." + ) +} + + +#' @export +#' @keywords internal +`[[<-.quenv` <- function(x, name, value) { # nolint + stop( + "Direct assignment is forbidden as it cannot be tracked. ", + "Use `with( , { <- })` instead." + ) +} + + +#' @rdname quenv +#' @export +#' @keywords internal +get_code_quenv <- function(x, include_messages = FALSE) { + checkmate::assert_class(x, "quenv") + if (include_messages) { + collected <- list( + code = lapply(attr(x, "code"), deparse1), + error = attr(x, "errors"), + warning = attr(x, "warnings"), + message = attr(x, "messages") + ) + as.data.frame(lapply(collected, unlist)) + } else { + attr(x, "code") + } +} + + +#' @rdname quenv +#' @export +#' @keywords internal +get_conditions <- function(x, condition = c("errors", "warnings", "messages", "all")) { + checkmate::assert_class(x, "quenv") + condition <- match.arg(condition) + + if (condition == "all") { + Filter( + function(xxx) !identical(xxx, list()), + lapply( + attributes(x)[c("errors", "warnings", "messages")], + function(xx) Filter(function(x) !identical(x, ""), xx) + ) + ) + } else { + Filter(function(x) !identical(x, ""), attr(x, condition)) + } +} + + +#' @keywords internal +# prepare expression(s) for evaluation +.prepare_code <- function(expr, text) { + # This function cannot handle missing arguments, so the caller passes if statements that return NULL if FALSE. + + # Get parent call to use in error messages. + parent_call <- deparse1(match.call(definition = sys.function(2), call = sys.call(2))) + + if ((is.null(expr) && is.null(text)) || (!is.null(expr) && !is.null(text))) { + stop("specify either \"expr\" or \"text\": ", parent_call, call. = FALSE) + } + + if (!is.null(expr) && is.character(expr)) { + stop( + "character vector passed to \"expr\": ", parent_call, "\n use the \"text\" argument instead", + call. = FALSE + ) + } + + code <- + if (is.null(text)) { + # Add braces to expressions. Necessary for proper storage of some expressions (e.g. rm(x)). + if (!grepl("^\\{", deparse1(expr))) { + expr <- call("{", expr) + } + # Drop strings from compound expressions. + Filter(Negate(is.character), as.list(expr)[-1]) + } else if (is.null(expr)) { + expr <- as.list(str2expression(text)) + unpack <- function(x) { + if (identical(x[[1L]], as.symbol("{"))) { + as.character(x[-1L]) + } else { + deparse1(x) + } + } + unlist(lapply(expr, unpack)) + } + code +} + + +#' @keywords internal +# evaluate one expression, log any conditions raised +.eval_one <- function(expression, envir, enclos, extras) { + # Add empty string if no condition raised during evaluation. + on.exit( + lapply(c("errors", "warnings", "messages"), function(c) { + if (length(attr(envir, c)) < length(attr(envir, "code"))) { + attr(envir, c) <- append(attr(envir, c), "") + } + }) + ) + + if (is.character(expression)) { + expression <- str2lang(expression) + } + expression <- do.call(substitute, list(expr = expression, env = extras)) + + attr(envir, "code") <- append(attr(envir, "code"), expression) + tryCatch( + eval(expression, envir = envir, enclos = enclos), + message = function(m) attr(envir, "messages") <- append(attr(envir, "messages"), trimws(m$message)), + warning = function(w) attr(envir, "warnings") <- append(attr(envir, "warnings"), w$message), + error = function(e) { + attr(envir, "errors") <- append(attr(envir, "errors"), e$message) + stop(sprintf("Evaluation failed: %s", deparse1(expression)), call. = FALSE) + } + ) +} + + +#' @keywords internal +# deep copy a `quenv` +.clone_quenv <- function(x) { + if (!inherits(x, "quenv")) stop("\"x\" must be a quenv object") + ans <- list2env(mget(ls(envir = x, all.names = TRUE, sorted = FALSE), envir = x), parent = parent.env(x)) + attributes(ans) <- attributes(x) + ans +} + + + +# helper for `format.quenv` +# briefly summarize object +#' @export +#' @keywords internal +.object_info <- function(x) { # nolint + # nolint + UseMethod(".object_info") +} +#' @export +#' @keywords internal +.object_info.data.frame <- function(x) { # nolint + # nolint + sprintf("%d x %d", dim(x)[1], dim(x)[2]) +} +#' @export +#' @keywords internal +.object_info.matrix <- function(x) { # nolint + # nolint + sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) +} +#' @export +#' @keywords internal +.object_info.factor <- function(x) { # nolint + # nolint + sprintf("%d levels, [%d]", length(levels(x)), length(x)) +} +#' @export +#' @keywords internal +.object_info.character <- function(x) { # nolint + # nolint + sprintf("%d item(s), %d value(s)", length(x), length(unique(x))) +} +#' @export +#' @keywords internal +.object_info.numeric <- function(x) { # nolint + # nolint + sprintf("%d item(s)", length(x)) +} +#' @export +#' @keywords internal +.object_info.default <- function(x) { # nolint + # nolint + "" +} diff --git a/man/quenv.Rd b/man/quenv.Rd new file mode 100644 index 000000000..12c669757 --- /dev/null +++ b/man/quenv.Rd @@ -0,0 +1,110 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/with-qenv.R +\name{quenv} +\alias{quenv} +\alias{with.quenv} +\alias{within.quenv} +\alias{format.quenv} +\alias{print.quenv} +\alias{get_code_quenv} +\alias{get_conditions} +\title{qenv refactor prototype} +\usage{ +quenv() + +\method{with}{quenv}(data, expr, text, ...) + +\method{within}{quenv}(data, expr, text, ...) + +\method{format}{quenv}(x) + +\method{print}{quenv}(x, ...) + +get_code_quenv(x, include_messages = FALSE) + +get_conditions(x, condition = c("errors", "warnings", "messages", "all")) +} +\arguments{ +\item{data, x}{(\code{quenv})} + +\item{expr}{(\code{language}) simple or compound expression to evaluate in \code{data}} + +\item{text}{(\code{character}) character vector of expressions to evaluate in \code{data}} + +\item{...}{\code{name:value} pairs to inject values into \code{expr}} +} +\value{ +\code{quenv} returns a \code{quenv} object. \code{with} returns NULL invisibly. \code{within} returns a modified deep copy of \code{data}. +} +\description{ +Simple to use environment with history tracking. +} +\details{ +Create a \code{quenv} object, which is an environment, and execute code inside. +Code can be supplied as expressions, literal character vectors, as well as name-bound character vectors. +External values can be injected into the code with the ellipsis. + +\code{quenv} creates \code{quenv} object. +\code{with} acts in \code{quenv} object. +\code{within} creates and modifies a (deep) copy of \code{quenv} object. +\code{get_code} returns list of function calls or a data.frame with code and the conditions it raised. +\code{get_conditions} returns list of condition messages (character strings). +} +\examples{ + +q <- quenv() + +# execute code +with(q, { + i <- iris + m <- mtcars +}) +q + +# supply code as strings +q <- quenv() +with(q, text = "c <- cars") +code_as_text <- "w <- warpbreaks" +with(q, text = code_as_text) + +# error messages are stored +try( + with(q, { + subset(i, Species == species) # raises error and stops evaluation + ms <- subset(m, cyl == 4) # not evaluated + }) +) +q + +# warnings and messages are also stored +with(q, { + warning("this is a warning") +}) +with(q, { + message("this is a message") +}) +q + +# access variables and environment history +q$m +get_code(q) +get_conditions(q, "error") + +# inject values into code +q <- quenv() +with(q, i <- iris) +with(q, print(dim(subset(i, Species == "virginica")))) +try( + with(q, print(dim(subset(i, Species == species)))) # fails +) +with(q, print(dim(subset(i, Species == species))), species = "versicolor") +species_external <- "versicolor" +with(q, print(dim(subset(i, Species == species))), species = species_external) + +# execute code in copy of `quenv` and return modified copy +q <- quenv() +with(q, i <- iris) +qq <- within(q, m <- mtcars) + +} +\keyword{internal} diff --git a/tests/testthat/test-with.eqnv.R b/tests/testthat/test-with.eqnv.R new file mode 100644 index 000000000..e54a52b37 --- /dev/null +++ b/tests/testthat/test-with.eqnv.R @@ -0,0 +1,572 @@ +# styler: off +# nolint start + +# creation ---- +testthat::test_that("quenv is created empty with attributes as empty lists", { + testthat::expect_no_error(q <- quenv()) + testthat::expect_s3_class(q, "quenv") + testthat::expect_identical( + attributes(q), + list( + code = list(), + errors = list(), + warnings = list(), + messages = list(), + class = c("quenv", "environment") + ) + ) +}) + + +# evaluation ---- +## code acceptance ---- +# internal functions .prepare_code and .eval_one are tested by running `with` +testthat::test_that("simple expressions passed `expr` are evaluated", { + q <- quenv() + testthat::expect_no_error(with(q, 1 + 1)) + testthat::expect_no_error(with(q, iris)) +}) + +testthat::test_that("compound expressions passed to `expr` are evaluated", { + q <- quenv() + testthat::expect_no_error( + with(q, { + 1 + 1 + }) + ) + testthat::expect_no_error( + with(q, { + 1 + 1 + 2 + 2 + }) + ) + testthat::expect_no_error( + with(q, { + 1 + 1; 2 + 2 + }) + ) + testthat::expect_no_error( + with(q, { + 1 + + 1 + }) + ) +}) + +testthat::test_that("sipmle expressions as literal strings passed to `text` are evaluated", { + q <- quenv() + testthat::expect_no_error(with(q, text = "1 + 1")) +}) + +testthat::test_that("compound expressions as literal strings passed to `text` are evaluated", { + q <- quenv() + testthat::expect_no_error( + with(q, text = "{ + 1 + 1 + }") + ) + testthat::expect_no_error( + with(q, text = "{ + 1 + 1 + 2 + 2 + }") + ) + testthat::expect_no_error( + with(q, text = "{ + 1 + 1; 2 + 2 + }") + ) + testthat::expect_no_error( + with(q, text = "{ + 1 + + 1 + }") + ) +}) + +testthat::test_that("simple expressions as character vectors passed to `text` are evaluated", { + q <- quenv() + expressions <- c( + "1 + 1", + "1 + 1 + 2 + 2", + "1 + 1; 2 + 2", + "1 + + 1" + ) + testthat::expect_no_error( + with(q, text = expressions) + ) +}) + +testthat::test_that("compound expressions as character vectors passed to `text` are evaluated", { + q <- quenv() + expressions <- c( + "{1 + 1}", + "{1 + 1 + 2 + 2}", + "{ + 1 + 1 + 2 + 2 + }", + "{ + 1 + + 1 + }" + ) + testthat::expect_no_error( + with(q, text = expressions) + ) +}) + +testthat::test_that("sipmle expressions from file passed to `text` are evaluated", { + q <- quenv() + expressions <- c( + "1 + 1", + "1 + 1 + 2 + 2", + "1 + 1; 2 + 2", + "1 + + 1" + ) + file <- tempfile() + writeLines(expressions, file) + testthat::expect_no_error( + with(q, text = readLines(file)) + ) + unlink(file) +}) + +testthat::test_that("compound expressions from file passed to `text` are evaluated", { + q <- quenv() + expressions <- c( + "{1 + 1}", + "{1 + 1 + 2 + 2}", + "{ + 1 + 1 + 2 + 2 + }", + "{ + 1 + + 1 + }" + ) + file <- tempfile() + writeLines(expressions, file) + testthat::expect_no_error( + with(q, text = readLines(file)) + ) + unlink(file) +}) + +testthat::test_that("characters passed to `expr` raise errors", { + q <- quenv() + testthat::expect_error(with(q, "1 + 1"), "character vector passed to \"expr\":.+use the \"text\" argument instead") +}) + +testthat::test_that("character-only compound expressions passed `expr` are ignored", { + q <- quenv() + with(q, {"1 + 1"}) + testthat::expect_identical(attributes(q), attributes(quenv())) +}) + + +# variable assignment ---- +testthat::test_that("direct assignment to quenv is forbidden", { + q <- quenv() + testthat::expect_error(q$i <- iris, regexp = "Direct assignment is forbidden") + testthat::expect_error(q[["i"]] <- iris, regexp = "Direct assignment is forbidden") + testthat::expect_no_error(with(q, i <- iris)) +}) + + +# variable access ---- +testthat::test_that("variables in quenv can be accessed", { + q <- quenv() + with(q, i <- iris) + testthat::expect_no_error(q$i) + testthat::expect_no_error(q[["i"]]) + testthat::expect_identical(q$i, iris) + testthat::expect_identical(q[["i"]], iris) + testthat::expect_error(q["i"], "Use.+to access variables.") +}) + + +# extracting conditions ---- +testthat::test_that("get_conditions extracts requested conditions as lists of strings", { + q <- quenv() + testthat::expect_error({ + with(q, { + i <- iris + m <- mtcars + mm <- m[m$cyl == 4, ] + message("this is a message") + warning("this is a warning") + stop("this is an error") + }) + }) + + testthat::expect_identical( + get_conditions(q, "messages"), + list( + "this is a message" + ) + ) + testthat::expect_identical( + get_conditions(q, "warnings"), + list( + "this is a warning" + ) + ) + testthat::expect_identical( + get_conditions(q, "errors"), + list( + "this is an error" + ) + ) + testthat::expect_identical( + get_conditions(q, "all"), + list( + errors = list( + "this is an error" + ), + warnings = list( + "this is a warning" + ), + messages = list( + "this is a message" + ) + ) + ) +}) + + +# extracting code ---- +testthat::test_that("get_code_quenv extracts code identical to the evaluated one", { + q <- quenv() + with(q, { + i <- iris + m <- mtcars + mm <- m[m$cyl == 4, ] + }) + + testthat::expect_identical( + get_code_quenv(q), + list( + quote(i <- iris), + quote(m <- mtcars), + quote(mm <- m[m$cyl == 4, ]) + ) + ) +}) + +testthat::test_that("get_code_quenv juxtaposes expressions with their respective conditions", { + q <- quenv() + testthat::expect_error({ + with(q, { + i <- iris + m <- mtcars + mm <- m[m$cyl == 4, ] + message("this is a message") + warning("this is a warning") + stop("this is an error") + }) + }) + + summary <- get_code_quenv(q, include_messages = TRUE) + testthat::expect_s3_class(summary, "data.frame") + testthat::expect_named(summary, c("code", "error", "warning", "message")) + lapply(summary, testthat::expect_type, type = "character") + testthat::expect_identical( + summary[["code"]], + c( + "i <- iris", + "m <- mtcars", + "mm <- m[m$cyl == 4, ]", + "message(\"this is a message\")", + "warning(\"this is a warning\")", + "stop(\"this is an error\")" + ) + ) + testthat::expect_identical( + summary[["error"]], + c("", "", "", "", "", "this is an error") + ) + testthat::expect_identical( + summary[["warning"]], + c("", "", "", "", "this is a warning", "") + ) + testthat::expect_identical( + summary[["message"]], + c("", "", "", "this is a message", "", "") + ) +}) + + +# evaluation, ctd. ---- +## code identity ---- +testthat::test_that("code passed as expression or character is evaluated as identical", { + q1 <- quenv() + with(q1, 1 + 1) + with(q1, { + 1 + 1 + }) + with(q1, { + 1 + 1 + 2 + 2 + }) + with(q1, { + 1 + 1; 2 + 2 + }) + with(q1, { + 1 + + 1 + }) + with(q1, { + if (1 + 1) { + "> 0" + } else { + "== 0" + } + }) + + q2 <- quenv() + with(q2, text = "1 + 1") + with(q2, text = "{ + 1 + 1 + }") + with(q2, text = "{ + 1 + 1 + 2 + 2 + }") + with(q2, text = "{ + 1 + 1; 2 + 2 + }") + with(q2, text = "{ + 1 + + 1 + }") + with(q2, text = "{ + if (1 + 1) { + \"> 0\" + } else { + \"== 0\" + } + }") + + expressions <- c( + "1 + 1", + "{ + 1 + 1 + }", + "{ + 1 + 1 + 2 + 2 + }", + "{ + 1 + 1; 2 + 2 + }", + "{ + 1 + + 1 + }", + "{ + if (1 + 1) { + \"> 0\" + } else { + \"== 0\" + } + }" + ) + q3 <- quenv() + with(q3, text = expressions) + testthat::expect_identical( + get_code_quenv(q1), + get_code_quenv(q2) + ) + testthat::expect_identical( + get_code_quenv(q2), + get_code_quenv(q3) + ) +}) + +testthat::test_that("differently formulated expressions yield the same code", { + q <- quenv() + with(q, 1 + 1) + with(q, {1 + 1}) + with(q, { + 1 + 1 + }) + with(q, { + 1 + + 1 + }) + all_code <- get_code_quenv(q) + testthat::expect_identical( + all_code, + rep(list(quote(1 + 1)), 4L) + ) + + q <- quenv() + with(q, {1 + 1; 2 + 2}) + with(q, { + 1 + 1; 2 + 2 + }) + with(q, { + 1 + 1 + 2 + 2 + }) + with(q, { + 1 + 1; + 2 + 2 + }) + all_code <- get_code_quenv(q) + all_code_pairs <- lapply(seq_len(4L), function(x) all_code[((x - 1L) * 2L) + 1:2]) + testthat::expect_identical( + all_code, + rep(list(quote(1 + 1), quote(2 + 2)), 4L) + ) +}) + +## injecting values ---- +testthat::test_that("external values can be injected into native expressions through `...`", { + q <- quenv() + + with(q, { + i <- subset(iris, Species == "setosa") + }) + + testthat::expect_error( + with(q, { + ii <- subset(iris, Species == species) + }), + "Evaluation failed" + ) + testthat::expect_identical( + get_conditions(q, "errors"), + list( + "object 'species' not found" + ) + ) + + with(q, { + iii <- subset(iris, Species == species) + }, + species = "virginica") + + external_value <- "versicolor" + with(q, { + iiii <- subset(iris, Species == species) + }, + species = external_value) + + testthat::expect_identical( + get_code_quenv(q), + list( + quote(i <- subset(iris, Species == "setosa")), + quote(ii <- subset(iris, Species == species)), + quote(iii <- subset(iris, Species == "virginica")), + quote(iiii <- subset(iris, Species == "versicolor")) + ) + ) +}) + +testthat::test_that("external values can be injected into (literal) character expressions through `...`", { + q <- quenv() + + with(q, text = "i <- subset(iris, Species == \"setosa\")") + + testthat::expect_error( + with(q, text = "ii <- subset(iris, Species == species)"), + "Evaluation failed" + ) + testthat::expect_identical( + get_conditions(q, "errors"), + list( + "object 'species' not found" + ) + ) + + with(q, text = "iii <- subset(iris, Species == species)", species = "virginica") + + external_value <- "versicolor" + with(q, text = "iiii <- subset(iris, Species == species)", species = external_value) + + testthat::expect_identical( + get_code_quenv(q), + list( + quote(i <- subset(iris, Species == "setosa")), + quote(ii <- subset(iris, Species == species)), + quote(iii <- subset(iris, Species == "virginica")), + quote(iiii <- subset(iris, Species == "versicolor")) + ) + ) +}) + +testthat::test_that("external values can be injected into (value) character expressions through `...`", { + q <- quenv() + + expression <- "i <- subset(iris, Species == \"setosa\")" + with(q, text = expression) + + expression <- "ii <- subset(iris, Species == species)" + testthat::expect_error( + with(q, text = expression), + "Evaluation failed" + ) + testthat::expect_identical( + get_conditions(q, "errors"), + list( + "object 'species' not found" + ) + ) + + expression <- "iii <- subset(iris, Species == species)" + with(q, text = expression, species = "virginica") + + expression <- "iiii <- subset(iris, Species == species)" + external_value <- "versicolor" + with(q, text = expression, species = external_value) + + testthat::expect_identical( + get_code_quenv(q), + list( + quote(i <- subset(iris, Species == "setosa")), + quote(ii <- subset(iris, Species == species)), + quote(iii <- subset(iris, Species == "virginica")), + quote(iiii <- subset(iris, Species == "versicolor")) + ) + ) +}) + + +# format ---- +# no tests for format method yet + +# within ---- +testthat::test_that("within.quenv renturns a deep copy of `data`", { + q <- quenv() + with(q, i <- iris) + qq <- within(q, text = "") + testthat::expect_equal(q, qq) + + q <- quenv() + with(q, i <- iris) + qq <- within(q, m <- mtcars) + testthat::expect_failure( + testthat::expect_equal(q, qq) + ) +}) + +testthat::test_that("within.quenv renturns even if evaluation raises error", { + q <- quenv() + with(q, i <- iris) + try(qq <- within(q, stop("right there"))) + testthat::expect_true( + exists("qq", mode = "environment", inherits = FALSE) + ) +}) + +# nolint end +# styler: on