From 30c6d78b3c7b5587186883822404433a8678fd9f Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 21 Aug 2023 14:59:55 +0200 Subject: [PATCH 01/50] prototype: with --- __new_qenv.R | 248 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 248 insertions(+) create mode 100644 __new_qenv.R diff --git a/__new_qenv.R b/__new_qenv.R new file mode 100644 index 000000000..600b4c04c --- /dev/null +++ b/__new_qenv.R @@ -0,0 +1,248 @@ + +#' qenv refactor prototype +#' +#' Simple to use environment with history tracking. +#' +#' @param data (`qenv`) +#' @param expr (`language`) simple or compound expression to evaluate in `data` +#' @param ... (`pair-list`) `name:value` pairs to inject values into `expr` +#' @param ... x (`qenv`) +#' +#' @return +#' `qenv` returns a `qenv` object. `with` returns NULL invisibly. +#' +#' @describeIn qenv create `qenv` object +#' @export +qenv <- function() { + ans <- new.env() + attr(ans, "code") <- list() + attr(ans, "errors") <- list() + attr(ans, "warnings") <- list() + attr(ans, "messages") <- list() + class(ans) <- c("qenv", class(ans)) + ans +} + + +#' @describeIn qenv act in `qenv` object +#' @export +with.qenv <- function(data, expr, ...) { + if (!grepl("^\\{", deparse1(substitute(expr)))) { + expr <- call("{", match.call()$expr) + } + + extras <- list(...) + + expr <- as.list(substitute(expr))[-1] + + on.exit( + lapply(c("errors", "warnings", "messages"), function(c) { + if (length(attr(data, c)) < length(attr(data, "code"))) { + attr(data, c) <- append(attr(data, c), "") + } + }) + ) + + lapply(expr, function(expression) { + attr(data, "code") <- append(attr(data, "code"), do.call(substitute, list(expr = expression, env = extras))) + tryCatch( + eval(do.call(substitute, list(expr = expression, env = extras)), envir = data, enclos = parent.frame()), + message = function(m) attr(data, "messages") <- append(attr(data, "messages"), trimws(m$message)), + warning = function(w) attr(data, "warnings") <- append(attr(data, "warnings"), w$message), + error = function(e) { + attr(data, "errors") <- append(attr(data, "errors"), e$message) + stop(sprintf("Evaluation failed: %s", deparse1(expression)), call. = FALSE) + } + ) + }) + + invisible(NULL) +} + + +#' @export +format.qenv <- function(x) { + # opening message + header <- paste( + "`qenv` object (environment)", + " Use `with(qenv, { })` to evaluate code in the qenv.", + " Use `get_code(qenv)` to access all code run in the qenv since instantiation.", + " Use `qenv$` or `qenv[[\"\"]]`to access variables.", + sep = "\n" + ) + + # contents/bindings + 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), + sep = " : ", collapse = "\n") + + contents_hidden <- paste( + sprintf(sprintf(" $ %%-0%is", longest_name), var_names_hidden), + sprintf(sprintf("%%-0%is", longest_class), var_classes_hidden), + 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 qenv is empty." + } + + # code + code <- attr(x, "code") + code <- + if (identical(code, list())) { + "" + } else { + paste( + " {", + paste(sprintf(" %s", lapply(code, deparse)), 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 + ) +} + + +#' @export +print.qenv <- function(x, ...) { + cat(format(x, ...), sep = "\n") +} + + +#' @export +`[.qenv` <- function(x, ...) { + stop("Use `qenv$` or `qenv[[\"\"]]`to access variables.") +} + + +#' @export +`$<-.qenv` <- function(x, name, value) { + stop( + "Direct assignment is forbidden as it cannot be tracked. ", + "Use", sprintf("`with( , { %s <- %s })`", name, deparse(value)), " instead." + ) +} + + +#' @describeIn qenv Returns list of function calls or a data.frame with code and the conditions it raised. +#' @export +get_code <- function(x, include_messages = FALSE) { + 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") + } +} + + +#' @describeIn qenv Returns list of condition messages (character strings). +#' @export +get_conditions <- function(x, condition = c("errors", "warnings", "messages", "all")) { + 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)) + } +} + + +#' @examples +#' +#' q <- qenv() +#' # execute code +#' with(q, { +#' i <- iris +#' m <- mtcars +#' }) +#' q +#' # error messages are stored +#' 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") +#' +#' # injecting values into code +#' q <- qenv() +#' with(q, i <- iris) +#' with(q, print(dim(subset(i, Species == "virginica")))) +#' \dontrun{ +#' 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) + + +# internal; work in progress +object_info <- function(x) UseMethod("object_info") +object_info.data.frame <- function(x) sprintf("%d x %d", dim(x)[1], dim(x)[2]) # nolint +object_info.matrix <- function(x) sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) # nolint +object_info.factor <- function(x) sprintf("%d levels, [%d]", length(levels(x)), length(x)) # nolint +object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) # nolint From 14f8eed736e9b29fa485723bf272fbe656d87ef5 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 21 Aug 2023 17:12:43 +0200 Subject: [PATCH 02/50] move evaluation of expressions to internal function defined outside of with method --- __new_qenv.R | 50 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 30 insertions(+), 20 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 600b4c04c..42fd1f31d 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -35,26 +35,7 @@ with.qenv <- function(data, expr, ...) { expr <- as.list(substitute(expr))[-1] - on.exit( - lapply(c("errors", "warnings", "messages"), function(c) { - if (length(attr(data, c)) < length(attr(data, "code"))) { - attr(data, c) <- append(attr(data, c), "") - } - }) - ) - - lapply(expr, function(expression) { - attr(data, "code") <- append(attr(data, "code"), do.call(substitute, list(expr = expression, env = extras))) - tryCatch( - eval(do.call(substitute, list(expr = expression, env = extras)), envir = data, enclos = parent.frame()), - message = function(m) attr(data, "messages") <- append(attr(data, "messages"), trimws(m$message)), - warning = function(w) attr(data, "warnings") <- append(attr(data, "warnings"), w$message), - error = function(e) { - attr(data, "errors") <- append(attr(data, "errors"), e$message) - stop(sprintf("Evaluation failed: %s", deparse1(expression)), call. = FALSE) - } - ) - }) + lapply(expr, .eval_one, envir = data, enclos = parent.frame(), extras = extras) invisible(NULL) } @@ -246,3 +227,32 @@ object_info.data.frame <- function(x) sprintf("%d x %d", dim(x)[1], dim(x)[2]) object_info.matrix <- function(x) sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) # nolint object_info.factor <- function(x) sprintf("%d levels, [%d]", length(levels(x)), length(x)) # nolint object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) # nolint + + +#' @keywords internal +# internal funciton to evaluate one expression +# used in `qenv` and in `with.qenv` +.eval_one <- function(expression, envir, enclos, extras) { + 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 <- 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) + } + ) +} From 85f4e2f2da1ec5091d312403d6eb2e1b792e1f14 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 21 Aug 2023 17:14:40 +0200 Subject: [PATCH 03/50] add evaluating code from file in constructor --- __new_qenv.R | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 42fd1f31d..1a64c7512 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -3,23 +3,40 @@ #' #' Simple to use environment with history tracking. #' +#' @param file (`character`) optional path to file that contains R code to evaluate upon instantiation #' @param data (`qenv`) #' @param expr (`language`) simple or compound expression to evaluate in `data` #' @param ... (`pair-list`) `name:value` pairs to inject values into `expr` -#' @param ... x (`qenv`) +#' @param x (`qenv`) #' #' @return #' `qenv` returns a `qenv` object. `with` returns NULL invisibly. #' #' @describeIn qenv create `qenv` object #' @export -qenv <- function() { +qenv <- function(file) { ans <- new.env() attr(ans, "code") <- list() attr(ans, "errors") <- list() attr(ans, "warnings") <- list() attr(ans, "messages") <- list() class(ans) <- c("qenv", class(ans)) + + if (!missing(file)) { + tryCatch( + stopifnot( + is.character(file) && + length(file) == 1L && + file.access(file, mode = 0) == 0L && + file.access(file, mode = 4) == 0L + ), + error = function(e) stop("\"file\" must be a readable file") + ) + code <- readLines("codefile") + + lapply(code, .eval_one, envir = ans, enclos = parent.frame()) + } + ans } From ad505e9bf756b78a978285d9f40a4ca14c35e9f9 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 21 Aug 2023 17:47:53 +0200 Subject: [PATCH 04/50] gub fix in .eval_one --- __new_qenv.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 1a64c7512..31c7622e7 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -258,9 +258,12 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) }) ) - if (!is.character(expression)) { - expression <- do.call(substitute, list(expr = expression, env = extras)) - } + expression <- + if (is.character(expression)) { + str2expression(expression) + } else { + do.call(substitute, list(expr = expression, env = extras)) + } attr(envir, "code") <- append(attr(envir, "code"), expression) tryCatch( From 923280cb632589aa7b499a47e2c86ba3eddab5ba Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 22 Aug 2023 09:44:34 +0200 Subject: [PATCH 05/50] add support for code as non-literal character strings --- __new_qenv.R | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 31c7622e7..e4582b199 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -43,16 +43,32 @@ qenv <- function(file) { #' @describeIn qenv act in `qenv` object #' @export -with.qenv <- function(data, expr, ...) { - if (!grepl("^\\{", deparse1(substitute(expr)))) { +with.qenv <- function(data, expr, text, ...) { + + if ((missing(expr) && missing(text)) || (!missing(expr) && !missing(text))) { + stop("specify either \"expr\" or \"text\"") + } + + if (!missing(expr) && !grepl("^\\{", deparse1(substitute(expr)))) { expr <- call("{", match.call()$expr) } + if (!missing(text) && length(text) == 1L && grepl("^\\{", text)) { + text <- strsplit(text, split = "\n")[[1]] + text <- trimws(text, whitespace = "[ \t\r\n\\{\\}]") + text <- Filter(Negate(function(x) identical(x, "")), text) + } + extras <- list(...) - expr <- as.list(substitute(expr))[-1] + code <- + if (missing(text)) { + as.list(substitute(expr))[-1] + } else if (missing(expr)) { + text + } - lapply(expr, .eval_one, envir = data, enclos = parent.frame(), extras = extras) + lapply(code, .eval_one, envir = data, enclos = parent.frame(), extras = extras) invisible(NULL) } @@ -247,7 +263,7 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) #' @keywords internal -# internal funciton to evaluate one expression +# internal function to evaluate one expression # used in `qenv` and in `with.qenv` .eval_one <- function(expression, envir, enclos, extras) { on.exit( @@ -260,7 +276,7 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) expression <- if (is.character(expression)) { - str2expression(expression) + str2lang(expression) } else { do.call(substitute, list(expr = expression, env = extras)) } From fa95c53dff56b143d180d5b9bbbcbe258b6bf3b2 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 22 Aug 2023 10:05:21 +0200 Subject: [PATCH 06/50] add support for code as non-literal character strings --- __new_qenv.R | 18 +----------------- 1 file changed, 1 insertion(+), 17 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index e4582b199..3361be554 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -3,9 +3,9 @@ #' #' Simple to use environment with history tracking. #' -#' @param file (`character`) optional path to file that contains R code to evaluate upon instantiation #' @param data (`qenv`) #' @param expr (`language`) simple or compound expression to evaluate in `data` +#' @param text (`character`) character vector of expressions to evaluate in `data` #' @param ... (`pair-list`) `name:value` pairs to inject values into `expr` #' @param x (`qenv`) #' @@ -21,22 +21,6 @@ qenv <- function(file) { attr(ans, "warnings") <- list() attr(ans, "messages") <- list() class(ans) <- c("qenv", class(ans)) - - if (!missing(file)) { - tryCatch( - stopifnot( - is.character(file) && - length(file) == 1L && - file.access(file, mode = 0) == 0L && - file.access(file, mode = 4) == 0L - ), - error = function(e) stop("\"file\" must be a readable file") - ) - code <- readLines("codefile") - - lapply(code, .eval_one, envir = ans, enclos = parent.frame()) - } - ans } From 061a43e9aefd7a086f5bcad1feb284f502de89df Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 22 Aug 2023 10:05:51 +0200 Subject: [PATCH 07/50] minor cleanup --- __new_qenv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 3361be554..f5a367c11 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -43,8 +43,6 @@ with.qenv <- function(data, expr, text, ...) { text <- Filter(Negate(function(x) identical(x, "")), text) } - extras <- list(...) - code <- if (missing(text)) { as.list(substitute(expr))[-1] @@ -52,6 +50,8 @@ with.qenv <- function(data, expr, text, ...) { text } + extras <- list(...) + lapply(code, .eval_one, envir = data, enclos = parent.frame(), extras = extras) invisible(NULL) From 841d14312ee4b74c29ab40390d77c1c78c6ff03c Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 22 Aug 2023 10:52:41 +0200 Subject: [PATCH 08/50] move code preparation to internal function --- __new_qenv.R | 57 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 36 insertions(+), 21 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index f5a367c11..898879d3c 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -29,26 +29,7 @@ qenv <- function(file) { #' @export with.qenv <- function(data, expr, text, ...) { - if ((missing(expr) && missing(text)) || (!missing(expr) && !missing(text))) { - stop("specify either \"expr\" or \"text\"") - } - - if (!missing(expr) && !grepl("^\\{", deparse1(substitute(expr)))) { - expr <- call("{", match.call()$expr) - } - - if (!missing(text) && length(text) == 1L && grepl("^\\{", text)) { - text <- strsplit(text, split = "\n")[[1]] - text <- trimws(text, whitespace = "[ \t\r\n\\{\\}]") - text <- Filter(Negate(function(x) identical(x, "")), text) - } - - code <- - if (missing(text)) { - as.list(substitute(expr))[-1] - } else if (missing(expr)) { - text - } + code <- .prepare_code(if (!missing(expr)) substitute(expr), if (!missing(text)) text) extras <- list(...) @@ -246,9 +227,43 @@ object_info.factor <- function(x) sprintf("%d levels, [%d]", length(levels(x)), object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) # nolint +#' @keywords internal +# internal function to prepare expression(s) for evaluation +.prepare_code <- function(expr, text) { + + parent_call <- 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\": ", deparse1(parent_call), call. = FALSE) + } + + if (!is.null(expr) && is.character(expr)) { + stop("character vector passed to \"expr\": ", deparse1(parent_call), call. = FALSE) + } + + if (!is.null(expr) && !grepl("^\\{", deparse1(expr))) { + expr <- call("{", expr) + } + + if (!is.null(text) && length(text) == 1L && grepl("^\\{", text)) { + text <- strsplit(text, split = "\n")[[1]] + text <- trimws(text, whitespace = "[ \t\r\n\\{\\}]") + text <- Filter(Negate(function(x) identical(x, "")), text) + } + + code <- + if (is.null(text)) { + as.list(expr)[-1] + } else if (is.null(expr)) { + text + } + + code +} + + #' @keywords internal # internal function to evaluate one expression -# used in `qenv` and in `with.qenv` .eval_one <- function(expression, envir, enclos, extras) { on.exit( lapply(c("errors", "warnings", "messages"), function(c) { From 40f0a17c5435ea9f1180d7b53e2203e75a0316b4 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 22 Aug 2023 14:27:30 +0200 Subject: [PATCH 09/50] prevent evaluating strings in expr argument --- __new_qenv.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/__new_qenv.R b/__new_qenv.R index 898879d3c..4f5140a49 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -253,7 +253,7 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) code <- if (is.null(text)) { - as.list(expr)[-1] + Filter(Negate(is.character), as.list(expr)[-1]) } else if (is.null(expr)) { text } From f8c37e26a277e06b58e7aed5a51356f993ae66c1 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 22 Aug 2023 15:19:53 +0200 Subject: [PATCH 10/50] add within method --- __new_qenv.R | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 4f5140a49..fd0edf9a3 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -10,7 +10,7 @@ #' @param x (`qenv`) #' #' @return -#' `qenv` returns a `qenv` object. `with` returns NULL invisibly. +#' `qenv` returns a `qenv` object. `with` returns NULL invisibly. `within` returns a modified deep copy of `data`. #' #' @describeIn qenv create `qenv` object #' @export @@ -28,17 +28,24 @@ qenv <- function(file) { #' @describeIn qenv act in `qenv` object #' @export with.qenv <- 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) } +#' @describeIn qenv create and modify a (deep) copy of a qenv +#' @export +within.qenv <- function(data, expr, text, ...) { + data <- .clone_qenv(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) + data +} + + #' @export format.qenv <- function(x) { # opening message @@ -291,3 +298,13 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) } ) } + + +#' @keywords internal +# deep copy a qenv +.clone_qenv <- function(x) { + if (!inherits(x, "qenv")) stop("\"x\" must be a qenv object") + ans <- list2env(mget(ls(envir = x, all.names = TRUE, sorted = FALSE), envir = x), parent = parent.env(x)) + attributes(ans) <- attributes(x) + ans +} From a2051bb05f8b4aca846d53ccf1cfbab748143f55 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 22 Aug 2023 15:20:14 +0200 Subject: [PATCH 11/50] edit documentation --- __new_qenv.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index fd0edf9a3..2cde5fa91 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -3,11 +3,10 @@ #' #' Simple to use environment with history tracking. #' -#' @param data (`qenv`) +#' @param data,x (`qenv`) #' @param expr (`language`) simple or compound expression to evaluate in `data` #' @param text (`character`) character vector of expressions to evaluate in `data` -#' @param ... (`pair-list`) `name:value` pairs to inject values into `expr` -#' @param x (`qenv`) +#' @param ... `name:value` pairs to inject values into `expr` #' #' @return #' `qenv` returns a `qenv` object. `with` returns NULL invisibly. `within` returns a modified deep copy of `data`. From ab429ea4dc710648291a1ab1dbebc2ed3e87b36a Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 22 Aug 2023 15:44:32 +0200 Subject: [PATCH 12/50] add code comments --- __new_qenv.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/__new_qenv.R b/__new_qenv.R index 2cde5fa91..b00f2f0f6 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -236,7 +236,9 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) #' @keywords internal # internal function to 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 <- match.call(definition = sys.function(2), call = sys.call(2)) if ((is.null(expr) && is.null(text)) || (!is.null(expr) && !is.null(text))) { @@ -247,10 +249,12 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) stop("character vector passed to \"expr\": ", deparse1(parent_call), call. = FALSE) } + # Add braces to expressions. Necessary for proper storage of some expressions (e.g. rm(x)). if (!is.null(expr) && !grepl("^\\{", deparse1(expr))) { expr <- call("{", expr) } + # Process compound expression string: split lines, remove braces and white space, ignore empty strings. if (!is.null(text) && length(text) == 1L && grepl("^\\{", text)) { text <- strsplit(text, split = "\n")[[1]] text <- trimws(text, whitespace = "[ \t\r\n\\{\\}]") @@ -259,6 +263,7 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) code <- if (is.null(text)) { + # Drop strings from compound expressions. Filter(Negate(is.character), as.list(expr)[-1]) } else if (is.null(expr)) { text @@ -271,6 +276,7 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) #' @keywords internal # internal function to evaluate one expression .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"))) { From 08a79bf409065f941a25bbcb0b623c9175726490 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 22 Aug 2023 16:14:21 +0200 Subject: [PATCH 13/50] force return from within.qenv --- __new_qenv.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/__new_qenv.R b/__new_qenv.R index b00f2f0f6..ac5215e67 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -41,7 +41,8 @@ within.qenv <- 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) - data + # Force a return even if some evaluation fails. + on.exit(return(data)) } From 490463f3a22df92f1367c33a1406b8f7733e8569 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 23 Aug 2023 13:23:56 +0200 Subject: [PATCH 14/50] simplify error message --- __new_qenv.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/__new_qenv.R b/__new_qenv.R index ac5215e67..1266251d8 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -144,7 +144,7 @@ print.qenv <- function(x, ...) { `$<-.qenv` <- function(x, name, value) { stop( "Direct assignment is forbidden as it cannot be tracked. ", - "Use", sprintf("`with( , { %s <- %s })`", name, deparse(value)), " instead." + "Use `with( , { <- })` instead." ) } From decf1db79e152101d33bd396d779f9a4b2f45494 Mon Sep 17 00:00:00 2001 From: Dony Unardi Date: Wed, 23 Aug 2023 07:15:39 -0700 Subject: [PATCH 15/50] fix news (#138) Fixes #137 --- NEWS.md | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index f1d70f7cf..7edf625a7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,11 @@ # teal.code 0.4.0.9001 +### 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 From e94c9d29395ccb7dc997656f5a1dfce37d35d5a1 Mon Sep 17 00:00:00 2001 From: donyunardi Date: Wed, 23 Aug 2023 14:16:51 +0000 Subject: [PATCH 16/50] [skip actions] Bump version to 0.4.0.9002 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4f7246f80..abe3c2f7e 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.9002 +Date: 2023-08-23 Authors@R: c( person("Dawid", "Kaledkowski", , "dawid.kaledkowski@roche.com", role = c("aut", "cre")), person("Pawel", "Rucki", , "pawel.rucki@roche.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 7edf625a7..e8f011f24 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# teal.code 0.4.0.9001 +# teal.code 0.4.0.9002 ### Miscellaneous * Fix NEWS From 57fd6e7f908ebed79bef5a858ab19e300010a2bb Mon Sep 17 00:00:00 2001 From: walkowif <59475134+walkowif@users.noreply.github.com> Date: Fri, 25 Aug 2023 15:37:01 +0200 Subject: [PATCH 17/50] Add CRAN release template (#140) https://github.com/insightsengineering/idr-tasks/issues/648 --- .github/ISSUE_TEMPLATE/cran-release.yaml | 101 +++++++++++++++++++++++ 1 file changed, 101 insertions(+) create mode 100644 .github/ISSUE_TEMPLATE/cran-release.yaml 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. From dfa4c5b52f58d184853d30624c775a5875eac62b Mon Sep 17 00:00:00 2001 From: walkowif Date: Fri, 25 Aug 2023 13:38:19 +0000 Subject: [PATCH 18/50] [skip actions] Bump version to 0.4.0.9003 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index abe3c2f7e..632776034 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.9002 -Date: 2023-08-23 +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"), diff --git a/NEWS.md b/NEWS.md index e8f011f24..8a5032e8d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# teal.code 0.4.0.9002 +# teal.code 0.4.0.9003 ### Miscellaneous * Fix NEWS From bd4c2a17111e3a74ba79851df8147cfb46755ac0 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 28 Aug 2023 19:44:03 +0200 Subject: [PATCH 19/50] upgrade by averissimo --- __new_qenv.R | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 1266251d8..c388cd831 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -235,39 +235,39 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) #' @keywords internal -# internal function to prepare expression(s) for evaluation +# 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 <- match.call(definition = sys.function(2), call = sys.call(2)) + 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\": ", deparse1(parent_call), call. = FALSE) + stop("specify either \"expr\" or \"text\": ", parent_call, call. = FALSE) } if (!is.null(expr) && is.character(expr)) { - stop("character vector passed to \"expr\": ", deparse1(parent_call), call. = FALSE) + stop( + "character vector passed to \"expr\": ", parent_call, "\n use the \"text\" argument instead", + call. = FALSE + ) } # Add braces to expressions. Necessary for proper storage of some expressions (e.g. rm(x)). - if (!is.null(expr) && !grepl("^\\{", deparse1(expr))) { + if (!is.null(expr) && identical(expr[[1]], as.symbol("{"))) { expr <- call("{", expr) } - # Process compound expression string: split lines, remove braces and white space, ignore empty strings. - if (!is.null(text) && length(text) == 1L && grepl("^\\{", text)) { - text <- strsplit(text, split = "\n")[[1]] - text <- trimws(text, whitespace = "[ \t\r\n\\{\\}]") - text <- Filter(Negate(function(x) identical(x, "")), text) - } - code <- if (is.null(text)) { # Drop strings from compound expressions. Filter(Negate(is.character), as.list(expr)[-1]) } else if (is.null(expr)) { - text + text <- str2expression(text) + if (length(text) == 1L && identical(text[[1L]][[1L]], "{")) { + text <- text[[1L]][-1L] + } + as.character(text) } code From e975c673453b3a6bab1e27c6e5e2483d02f5113a Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 28 Aug 2023 19:44:41 +0200 Subject: [PATCH 20/50] edit comments --- __new_qenv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index c388cd831..eba09cc88 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -34,7 +34,7 @@ with.qenv <- function(data, expr, text, ...) { } -#' @describeIn qenv create and modify a (deep) copy of a qenv +#' @describeIn qenv create and modify a (deep) copy of a `qenv` #' @export within.qenv <- function(data, expr, text, ...) { data <- .clone_qenv(data) @@ -275,7 +275,7 @@ object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) #' @keywords internal -# internal function to evaluate one expression +# 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( From fc996172bb290aa51f60401f160d137656f3a770 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 28 Aug 2023 19:45:44 +0200 Subject: [PATCH 21/50] improve format --- __new_qenv.R | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index eba09cc88..577763daf 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -72,11 +72,13 @@ format.qenv <- function(x) { 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( @@ -226,12 +228,23 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a #' with(q, print(dim(subset(i, Species == species))), species = species_external) -# internal; work in progress -object_info <- function(x) UseMethod("object_info") -object_info.data.frame <- function(x) sprintf("%d x %d", dim(x)[1], dim(x)[2]) # nolint -object_info.matrix <- function(x) sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) # nolint -object_info.factor <- function(x) sprintf("%d levels, [%d]", length(levels(x)), length(x)) # nolint -object_info.default <- function(x) sprintf("%s, [%d]", typeof(x), length(x)) # nolint +#' @keywords internal +#' helper for fotmat.qenv +#' briefly summarize object +#' @export +.object_info <- function(x) UseMethod(".object_info") +#' @export +.object_info.data.frame <- function(x) sprintf("%d x %d", dim(x)[1], dim(x)[2]) # nolint +#' @export +.object_info.matrix <- function(x) sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) # nolint +#' @export +.object_info.factor <- function(x) sprintf("%d levels, [%d]", length(levels(x)), length(x)) # nolint +#' @export +.object_info.character <- function(x) sprintf("%d item(s), %d value(s)", length(x), length(unique(x))) # nolint +#' @export +.object_info.numeric <- function(x) sprintf("%d item(s)", length(x)) # nolint +#' @export +.object_info.default <- function(x) NULL # nolint #' @keywords internal From 087b05f3de1bad0600ddd5a34f3c587652e0f8e8 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Mon, 28 Aug 2023 19:54:01 +0200 Subject: [PATCH 22/50] minor rollback --- __new_qenv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 577763daf..821b94258 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -244,7 +244,7 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a #' @export .object_info.numeric <- function(x) sprintf("%d item(s)", length(x)) # nolint #' @export -.object_info.default <- function(x) NULL # nolint +.object_info.default <- function(x) "" # nolint #' @keywords internal @@ -267,7 +267,7 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a } # Add braces to expressions. Necessary for proper storage of some expressions (e.g. rm(x)). - if (!is.null(expr) && identical(expr[[1]], as.symbol("{"))) { + if (!is.null(expr) && !grepl("^\\{", deparse1(expr))) { expr <- call("{", expr) } From 44e80d3cd2abb9d0f4ad9cb91f30097d29866ca6 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Aug 2023 12:28:11 +0200 Subject: [PATCH 23/50] patch format --- __new_qenv.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/__new_qenv.R b/__new_qenv.R index 821b94258..87ab941e2 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -97,7 +97,7 @@ format.qenv <- function(x) { } else { paste( " {", - paste(sprintf(" %s", lapply(code, deparse)), collapse = "\n"), + paste(sprintf(" %s", lapply(code, deparse1)), collapse = "\n"), " }", sep = "\n" ) From 6bca793f60122521a3a1610d279b562734b9c974 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Aug 2023 12:39:24 +0200 Subject: [PATCH 24/50] improve condotion --- __new_qenv.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/__new_qenv.R b/__new_qenv.R index 87ab941e2..f73d6f825 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -277,7 +277,7 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a Filter(Negate(is.character), as.list(expr)[-1]) } else if (is.null(expr)) { text <- str2expression(text) - if (length(text) == 1L && identical(text[[1L]][[1L]], "{")) { + if (length(text) == 1L && identical(text[[1L]][[1L]], as.symbol("{"))) { text <- text[[1L]][-1L] } as.character(text) From 5fb5fed8030ccdbbe7f3598709e2586c57c3efaf Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Aug 2023 12:42:32 +0200 Subject: [PATCH 25/50] typo --- __new_qenv.R | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index f73d6f825..1b3d6125e 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -228,25 +228,6 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a #' with(q, print(dim(subset(i, Species == species))), species = species_external) -#' @keywords internal -#' helper for fotmat.qenv -#' briefly summarize object -#' @export -.object_info <- function(x) UseMethod(".object_info") -#' @export -.object_info.data.frame <- function(x) sprintf("%d x %d", dim(x)[1], dim(x)[2]) # nolint -#' @export -.object_info.matrix <- function(x) sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) # nolint -#' @export -.object_info.factor <- function(x) sprintf("%d levels, [%d]", length(levels(x)), length(x)) # nolint -#' @export -.object_info.character <- function(x) sprintf("%d item(s), %d value(s)", length(x), length(unique(x))) # nolint -#' @export -.object_info.numeric <- function(x) sprintf("%d item(s)", length(x)) # nolint -#' @export -.object_info.default <- function(x) "" # nolint - - #' @keywords internal # prepare expression(s) for evaluation .prepare_code <- function(expr, text) { @@ -327,3 +308,22 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a attributes(ans) <- attributes(x) ans } + + +#' @keywords internal +#' helper for format.qenv +#' briefly summarize object +#' @export +.object_info <- function(x) UseMethod(".object_info") +#' @export +.object_info.data.frame <- function(x) sprintf("%d x %d", dim(x)[1], dim(x)[2]) # nolint +#' @export +.object_info.matrix <- function(x) sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) # nolint +#' @export +.object_info.factor <- function(x) sprintf("%d levels, [%d]", length(levels(x)), length(x)) # nolint +#' @export +.object_info.character <- function(x) sprintf("%d item(s), %d value(s)", length(x), length(unique(x))) # nolint +#' @export +.object_info.numeric <- function(x) sprintf("%d item(s)", length(x)) # nolint +#' @export +.object_info.default <- function(x) "" # nolint From d8a8c21a7f7a9d2b916fb25791a198951a5a1cfc Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Aug 2023 12:50:34 +0200 Subject: [PATCH 26/50] clean up --- __new_qenv.R | 28 +++++++++++++++++++++------- 1 file changed, 21 insertions(+), 7 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 1b3d6125e..08fe8fc6d 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -314,16 +314,30 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a #' helper for format.qenv #' briefly summarize object #' @export -.object_info <- function(x) UseMethod(".object_info") +.object_info <- function(x) { + UseMethod(".object_info") +} #' @export -.object_info.data.frame <- function(x) sprintf("%d x %d", dim(x)[1], dim(x)[2]) # nolint +.object_info.data.frame <- function(x) { + sprintf("%d x %d", dim(x)[1], dim(x)[2]) +} #' @export -.object_info.matrix <- function(x) sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) # nolint +.object_info.matrix <- function(x) { + sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) +} #' @export -.object_info.factor <- function(x) sprintf("%d levels, [%d]", length(levels(x)), length(x)) # nolint +.object_info.factor <- function(x) { + sprintf("%d levels, [%d]", length(levels(x)), length(x)) +} #' @export -.object_info.character <- function(x) sprintf("%d item(s), %d value(s)", length(x), length(unique(x))) # nolint +.object_info.character <- function(x) { + sprintf("%d item(s), %d value(s)", length(x), length(unique(x))) +} #' @export -.object_info.numeric <- function(x) sprintf("%d item(s)", length(x)) # nolint +.object_info.numeric <- function(x) { + sprintf("%d item(s)", length(x)) +} #' @export -.object_info.default <- function(x) "" # nolint +.object_info.default <- function(x) { + "" +} From fdbcc8008dbdae1334e55f01fe876a4c785e6358 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Aug 2023 13:00:07 +0200 Subject: [PATCH 27/50] clean up --- __new_qenv.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/__new_qenv.R b/__new_qenv.R index 08fe8fc6d..b4d4217a7 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -13,7 +13,7 @@ #' #' @describeIn qenv create `qenv` object #' @export -qenv <- function(file) { +qenv <- function() { ans <- new.env() attr(ans, "code") <- list() attr(ans, "errors") <- list() From d2c8e76ff2613b6f3d892c4d6dc72835815cd61d Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Aug 2023 14:17:09 +0200 Subject: [PATCH 28/50] add [[ method --- __new_qenv.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/__new_qenv.R b/__new_qenv.R index b4d4217a7..32357e557 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -151,6 +151,15 @@ print.qenv <- function(x, ...) { } +#' @export +`[[<-.qenv` <- function(x, name, value) { + stop( + "Direct assignment is forbidden as it cannot be tracked. ", + "Use `with( , { <- })` instead." + ) +} + + #' @describeIn qenv Returns list of function calls or a data.frame with code and the conditions it raised. #' @export get_code <- function(x, include_messages = FALSE) { From 3c6eed2a3d49a01308353fc65fd69f988c2445c0 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Aug 2023 17:17:38 +0200 Subject: [PATCH 29/50] improve text processing --- __new_qenv.R | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 32357e557..83b3308a6 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -266,13 +266,16 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a # Drop strings from compound expressions. Filter(Negate(is.character), as.list(expr)[-1]) } else if (is.null(expr)) { - text <- str2expression(text) - if (length(text) == 1L && identical(text[[1L]][[1L]], as.symbol("{"))) { - text <- text[[1L]][-1L] - } - as.character(text) + unlist( + lapply(text, function(x) { + expr <- str2expression(x) + if (length(expr) == 1L && identical(expr[[1L]][[1L]], as.symbol("{"))) { + expr <- expr[[1L]][-1L] + } + as.character(expr) + }) + ) } - code } From 3e5410bcaccfd6d309c1ed9853f9c2baf8cd9c2c Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Aug 2023 20:38:24 +0200 Subject: [PATCH 30/50] further improve text processing --- __new_qenv.R | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 83b3308a6..5a00431cd 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -266,15 +266,15 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a # Drop strings from compound expressions. Filter(Negate(is.character), as.list(expr)[-1]) } else if (is.null(expr)) { - unlist( - lapply(text, function(x) { - expr <- str2expression(x) - if (length(expr) == 1L && identical(expr[[1L]][[1L]], as.symbol("{"))) { - expr <- expr[[1L]][-1L] - } - as.character(expr) - }) - ) + expr <- as.list(str2expression(text)) + disarm <- function(x) { + if (identical(expr[[1L]][[1L]], as.symbol("{"))) { + as.character(expr[[1L]][-1L]) + } else { + deparse1(x) + } + } + unlist(lapply(expr, disarm)) } code } From 44d92888726434792747cd69be74caeee7eb8780 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Aug 2023 21:08:26 +0200 Subject: [PATCH 31/50] fix return in within --- __new_qenv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 5a00431cd..722923b6e 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -37,12 +37,12 @@ with.qenv <- function(data, expr, text, ...) { #' @describeIn qenv create and modify a (deep) copy of a `qenv` #' @export within.qenv <- function(data, expr, text, ...) { + # Force a return even if some evaluation fails. + on.exit(return(data)) data <- .clone_qenv(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) - # Force a return even if some evaluation fails. - on.exit(return(data)) } From 46e9f9440b5afa2d83f82b104b29c9cd71926953 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Tue, 29 Aug 2023 21:08:57 +0200 Subject: [PATCH 32/50] add substitution for string expressions --- __new_qenv.R | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 722923b6e..7f0b93955 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -292,12 +292,10 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a }) ) - expression <- - if (is.character(expression)) { - str2lang(expression) - } else { - do.call(substitute, list(expr = expression, env = extras)) - } + 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( From 7d5f55ca6e50cad25f8f515ca7a18f5d2c91fb11 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 13:53:18 +0200 Subject: [PATCH 33/50] bug fix --- __new_qenv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 7f0b93955..382316dee 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -268,8 +268,8 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a } else if (is.null(expr)) { expr <- as.list(str2expression(text)) disarm <- function(x) { - if (identical(expr[[1L]][[1L]], as.symbol("{"))) { - as.character(expr[[1L]][-1L]) + if (identical(x[[1L]], as.symbol("{"))) { + as.character(x[-1L]) } else { deparse1(x) } From e71143fc1f6a2bac177a86f03e570e994d107815 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 13:53:31 +0200 Subject: [PATCH 34/50] add argument checks --- __new_qenv.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/__new_qenv.R b/__new_qenv.R index 382316dee..2148b845e 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -163,6 +163,7 @@ print.qenv <- function(x, ...) { #' @describeIn qenv Returns list of function calls or a data.frame with code and the conditions it raised. #' @export get_code <- function(x, include_messages = FALSE) { + checkmate::assert_class(x, "qenv") if (include_messages) { collected <- list( code = lapply(attr(x, "code"), deparse1), @@ -180,6 +181,7 @@ get_code <- function(x, include_messages = FALSE) { #' @describeIn qenv Returns list of condition messages (character strings). #' @export get_conditions <- function(x, condition = c("errors", "warnings", "messages", "all")) { + checkmate::assert_class(x, "qenv") condition <- match.arg(condition) if (condition == "all") { From 4b81c845e4134f32b2a77977a8a7dd066ec99cc2 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 13:53:53 +0200 Subject: [PATCH 35/50] improve format --- __new_qenv.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/__new_qenv.R b/__new_qenv.R index 2148b845e..b448eff31 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -95,9 +95,10 @@ format.qenv <- function(x) { if (identical(code, list())) { "" } else { + expressions <- vapply(code, function(x) paste(sprintf(" %s", deparse(x)), collapse = "\n"), character(1L)) paste( " {", - paste(sprintf(" %s", lapply(code, deparse1)), collapse = "\n"), + paste(expressions, collapse = "\n"), " }", sep = "\n" ) From 9d6f93a47862ecb27b63844c7fc6ecb9157cafe6 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 15:28:32 +0200 Subject: [PATCH 36/50] rename internal --- __new_qenv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index b448eff31..107c2812a 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -270,14 +270,14 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a Filter(Negate(is.character), as.list(expr)[-1]) } else if (is.null(expr)) { expr <- as.list(str2expression(text)) - disarm <- function(x) { + unpack <- function(x) { if (identical(x[[1L]], as.symbol("{"))) { as.character(x[-1L]) } else { deparse1(x) } } - unlist(lapply(expr, disarm)) + unlist(lapply(expr, unpack)) } code } From 6c67829a4d1276c75425ff0109300ae19fd33b8a Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 15:28:49 +0200 Subject: [PATCH 37/50] linter and polish documentation --- __new_qenv.R | 159 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 102 insertions(+), 57 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 107c2812a..bedb0bdbf 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -3,6 +3,17 @@ #' #' Simple to use environment with history tracking. #' +#' @details +#' Create a `qenv` 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. +#' +#' `qenv` creates `qenv` object. +#' `with` acts in `qenv` object. +#' `within` creates and modifies a (deep) copy of `qenv` 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 (`qenv`) #' @param expr (`language`) simple or compound expression to evaluate in `data` #' @param text (`character`) character vector of expressions to evaluate in `data` @@ -11,7 +22,67 @@ #' @return #' `qenv` returns a `qenv` object. `with` returns NULL invisibly. `within` returns a modified deep copy of `data`. #' -#' @describeIn qenv create `qenv` object +#' @name qenv +#' +#' @examples +#' +#' q <- qenv() +#' +#' # execute code +#' with(q, { +#' i <- iris +#' m <- mtcars +#' }) +#' q +#' +#' # supply code as strings +#' q <- qenv() +#' 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 <- qenv() +#' 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 `qenv` and return modified copy +#' q <- qenv() +#' with(q, i <- iris) +#' qq <- within(q, m <- mtcars) +#' + + +#' @rdname qenv #' @export qenv <- function() { ans <- new.env() @@ -24,7 +95,7 @@ qenv <- function() { } -#' @describeIn qenv act in `qenv` object +#' @rdname qenv #' @export with.qenv <- function(data, expr, text, ...) { code <- .prepare_code(if (!missing(expr)) substitute(expr), if (!missing(text)) text) @@ -34,7 +105,7 @@ with.qenv <- function(data, expr, text, ...) { } -#' @describeIn qenv create and modify a (deep) copy of a `qenv` +#' @rdname qenv #' @export within.qenv <- function(data, expr, text, ...) { # Force a return even if some evaluation fails. @@ -46,7 +117,9 @@ within.qenv <- function(data, expr, text, ...) { } +#' @rdname qenv #' @export +#' @keywords internal format.qenv <- function(x) { # opening message header <- paste( @@ -131,19 +204,23 @@ format.qenv <- function(x) { } +#' @rdname qenv #' @export +#' @keywords internal print.qenv <- function(x, ...) { cat(format(x, ...), sep = "\n") } #' @export +#' @keywords internal `[.qenv` <- function(x, ...) { stop("Use `qenv$` or `qenv[[\"\"]]`to access variables.") } #' @export +#' @keywords internal `$<-.qenv` <- function(x, name, value) { stop( "Direct assignment is forbidden as it cannot be tracked. ", @@ -153,6 +230,7 @@ print.qenv <- function(x, ...) { #' @export +#' @keywords internal `[[<-.qenv` <- function(x, name, value) { stop( "Direct assignment is forbidden as it cannot be tracked. ", @@ -161,8 +239,9 @@ print.qenv <- function(x, ...) { } -#' @describeIn qenv Returns list of function calls or a data.frame with code and the conditions it raised. +#' @rdname qenv #' @export +#' @keywords internal get_code <- function(x, include_messages = FALSE) { checkmate::assert_class(x, "qenv") if (include_messages) { @@ -179,8 +258,9 @@ get_code <- function(x, include_messages = FALSE) { } -#' @describeIn qenv Returns list of condition messages (character strings). +#' @rdname qenv #' @export +#' @keywords internal get_conditions <- function(x, condition = c("errors", "warnings", "messages", "all")) { checkmate::assert_class(x, "qenv") condition <- match.arg(condition) @@ -199,47 +279,6 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a } -#' @examples -#' -#' q <- qenv() -#' # execute code -#' with(q, { -#' i <- iris -#' m <- mtcars -#' }) -#' q -#' # error messages are stored -#' 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") -#' -#' # injecting values into code -#' q <- qenv() -#' with(q, i <- iris) -#' with(q, print(dim(subset(i, Species == "virginica")))) -#' \dontrun{ -#' 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) - - #' @keywords internal # prepare expression(s) for evaluation .prepare_code <- function(expr, text) { @@ -314,7 +353,7 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a #' @keywords internal -# deep copy a qenv +# deep copy a `qenv` .clone_qenv <- function(x) { if (!inherits(x, "qenv")) stop("\"x\" must be a qenv object") ans <- list2env(mget(ls(envir = x, all.names = TRUE, sorted = FALSE), envir = x), parent = parent.env(x)) @@ -323,34 +362,40 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a } -#' @keywords internal -#' helper for format.qenv -#' briefly summarize object +# helper for `format.qenv` +# briefly summarize object #' @export -.object_info <- function(x) { +#' @keywords internal +.object_info <- function(x) { # nolint UseMethod(".object_info") } #' @export -.object_info.data.frame <- function(x) { +#' @keywords internal +.object_info.data.frame <- function(x) { # nolint sprintf("%d x %d", dim(x)[1], dim(x)[2]) } #' @export -.object_info.matrix <- function(x) { +#' @keywords internal +.object_info.matrix <- function(x) { # nolint sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) } #' @export -.object_info.factor <- function(x) { +#' @keywords internal +.object_info.factor <- function(x) { # nolint sprintf("%d levels, [%d]", length(levels(x)), length(x)) } #' @export -.object_info.character <- function(x) { +#' @keywords internal +.object_info.character <- function(x) { # nolint sprintf("%d item(s), %d value(s)", length(x), length(unique(x))) } #' @export -.object_info.numeric <- function(x) { +#' @keywords internal +.object_info.numeric <- function(x) { # nolint sprintf("%d item(s)", length(x)) } #' @export -.object_info.default <- function(x) { +#' @keywords internal +.object_info.default <- function(x) { # nolint "" } From abe3957d140860dcd964963ba449b01e91abcc85 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 15:30:22 +0200 Subject: [PATCH 38/50] add unit tests --- tests/testthat/test-with.eqnv.R | 568 ++++++++++++++++++++++++++++++++ 1 file changed, 568 insertions(+) create mode 100644 tests/testthat/test-with.eqnv.R diff --git a/tests/testthat/test-with.eqnv.R b/tests/testthat/test-with.eqnv.R new file mode 100644 index 000000000..d9665242f --- /dev/null +++ b/tests/testthat/test-with.eqnv.R @@ -0,0 +1,568 @@ + +# creation ---- +testthat::test_that("qenv is created empty with attributes as empty lists", { + testthat::expect_no_error(q <- qenv()) + testthat::expect_s3_class(q, "qenv") + testthat::expect_identical( + attributes(q), + list( + code = list(), + errors = list(), + warnings = list(), + messages = list(), + class = c("qenv", "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 <- qenv() + 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 <- qenv() + 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 <- qenv() + testthat::expect_no_error(with(q, text = "1 + 1")) +}) + +testthat::test_that("compound expressions as literal strings passed to `text` are evaluated", { + q <- qenv() + 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 <- qenv() + 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 <- qenv() + 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 <- qenv() + 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 <- qenv() + 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 <- qenv() + 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 <- qenv() + with(q, {"1 + 1"}) + testthat::expect_identical(attributes(q), attributes(qenv())) +}) + + +# variable assignment ---- +testthat::test_that("direct assignment to qenv is forbidden", { + q <- qenv() + 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 qenv can be accessed", { + q <- qenv() + 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 <- qenv() + 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 extracts code identical to the evaluated one", { + q <- qenv() + with(q, { + i <- iris + m <- mtcars + mm <- m[m$cyl == 4, ] + }) + + testthat::expect_identical( + get_code(q), + list( + quote(i <- iris), + quote(m <- mtcars), + quote(mm <- m[m$cyl == 4, ]) + ) + ) +}) + +testthat::test_that("get_code juxtaposes expressions with their respective conditions", { + q <- qenv() + 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(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 <- qenv() + 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 <- qenv() + 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 <- qenv() + with(q3, text = expressions) + testthat::expect_identical( + get_code(q1), + get_code(q2) + ) + testthat::expect_identical( + get_code(q2), + get_code(q3) + ) +}) + +testthat::test_that("differently formulated expressions yield the same code", { + q <- qenv() + with(q, 1 + 1) + with(q, {1 + 1}) + with(q, { + 1 + 1 + }) + with(q, { + 1 + + 1 + }) + all_code <- get_code(q) + testthat::expect_identical( + all_code, + rep(list(quote(1 + 1)), 4L) + ) + + q <- qenv() + 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(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 <- qenv() + + 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(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 <- qenv() + + 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(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 <- qenv() + + 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(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.qenv renturns a deep copy of `data`", { + q <- qenv() + with(q, i <- iris) + qq <- within(q, text = "") + testthat::expect_equal(q, qq) + + q <- qenv() + with(q, i <- iris) + qq <- within(q, m <- mtcars) + testthat::expect_failure( + testthat::expect_equal(q, qq) + ) +}) + +testthat::test_that("within.qenv renturns even if evaluation raises error", { + q <- qenv() + with(q, i <- iris) + try(qq <- within(q, stop("right there"))) + testthat::expect_true( + exists("qq", mode = "environment", inherits = FALSE) + ) +}) From 48687531814bcbed5f8883069f59a7f96d757ace Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 30 Aug 2023 13:33:42 +0000 Subject: [PATCH 39/50] [skip actions] Restyle files --- __new_qenv.R | 18 +++++++------ tests/testthat/test-with.eqnv.R | 46 +++++++++++++++++++++------------ 2 files changed, 39 insertions(+), 25 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index bedb0bdbf..3e09a16c9 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -1,4 +1,3 @@ - #' qenv refactor prototype #' #' Simple to use environment with history tracking. @@ -81,7 +80,6 @@ #' qq <- within(q, m <- mtcars) #' - #' @rdname qenv #' @export qenv <- function() { @@ -142,17 +140,21 @@ format.qenv <- function(x) { 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 <- 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") + sep = " : ", collapse = "\n" + ) contents_all <- c( if (!identical(contents, "")) sprintf("bindings:\n%s", contents), diff --git a/tests/testthat/test-with.eqnv.R b/tests/testthat/test-with.eqnv.R index d9665242f..ee5fd9809 100644 --- a/tests/testthat/test-with.eqnv.R +++ b/tests/testthat/test-with.eqnv.R @@ -1,4 +1,3 @@ - # creation ---- testthat::test_that("qenv is created empty with attributes as empty lists", { testthat::expect_no_error(q <- qenv()) @@ -40,7 +39,8 @@ testthat::test_that("compound expressions passed to `expr` are evaluated", { ) testthat::expect_no_error( with(q, { - 1 + 1; 2 + 2 + 1 + 1 + 2 + 2 }) ) testthat::expect_no_error( @@ -165,7 +165,9 @@ testthat::test_that("characters passed to `expr` raise errors", { testthat::test_that("character-only compound expressions passed `expr` are ignored", { q <- qenv() - with(q, {"1 + 1"}) + with(q, { + "1 + 1" + }) testthat::expect_identical(attributes(q), attributes(qenv())) }) @@ -237,7 +239,6 @@ testthat::test_that("get_conditions extracts requested conditions as lists of st ) ) ) - }) @@ -316,7 +317,8 @@ testthat::test_that("code passed as expression or character is evaluated as iden 2 + 2 }) with(q1, { - 1 + 1; 2 + 2 + 1 + 1 + 2 + 2 }) with(q1, { 1 + @@ -393,7 +395,9 @@ testthat::test_that("code passed as expression or character is evaluated as iden testthat::test_that("differently formulated expressions yield the same code", { q <- qenv() with(q, 1 + 1) - with(q, {1 + 1}) + with(q, { + 1 + 1 + }) with(q, { 1 + 1 }) @@ -408,16 +412,20 @@ testthat::test_that("differently formulated expressions yield the same code", { ) q <- qenv() - with(q, {1 + 1; 2 + 2}) with(q, { - 1 + 1; 2 + 2 + 1 + 1 + 2 + 2 + }) + with(q, { + 1 + 1 + 2 + 2 }) with(q, { 1 + 1 2 + 2 }) with(q, { - 1 + 1; + 1 + 1 2 + 2 }) all_code <- get_code(q) @@ -449,16 +457,20 @@ testthat::test_that("external values can be injected into native expressions thr ) ) - with(q, { - iii <- subset(iris, Species == species) - }, - species = "virginica") + with(q, + { + iii <- subset(iris, Species == species) + }, + species = "virginica" + ) external_value <- "versicolor" - with(q, { - iiii <- subset(iris, Species == species) - }, - species = external_value) + with(q, + { + iiii <- subset(iris, Species == species) + }, + species = external_value + ) testthat::expect_identical( get_code(q), From 2a2f62d4988992d15055014161e1eeadee933e4a Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 16:52:27 +0200 Subject: [PATCH 40/50] rool back automated styling in test file --- tests/testthat/test-with.eqnv.R | 50 ++++++++++++++------------------- 1 file changed, 21 insertions(+), 29 deletions(-) diff --git a/tests/testthat/test-with.eqnv.R b/tests/testthat/test-with.eqnv.R index ee5fd9809..ee033fb84 100644 --- a/tests/testthat/test-with.eqnv.R +++ b/tests/testthat/test-with.eqnv.R @@ -1,3 +1,6 @@ +# styler: off +# nolint start + # creation ---- testthat::test_that("qenv is created empty with attributes as empty lists", { testthat::expect_no_error(q <- qenv()) @@ -39,8 +42,7 @@ testthat::test_that("compound expressions passed to `expr` are evaluated", { ) testthat::expect_no_error( with(q, { - 1 + 1 - 2 + 2 + 1 + 1; 2 + 2 }) ) testthat::expect_no_error( @@ -165,9 +167,7 @@ testthat::test_that("characters passed to `expr` raise errors", { testthat::test_that("character-only compound expressions passed `expr` are ignored", { q <- qenv() - with(q, { - "1 + 1" - }) + with(q, {"1 + 1"}) testthat::expect_identical(attributes(q), attributes(qenv())) }) @@ -317,8 +317,7 @@ testthat::test_that("code passed as expression or character is evaluated as iden 2 + 2 }) with(q1, { - 1 + 1 - 2 + 2 + 1 + 1; 2 + 2 }) with(q1, { 1 + @@ -395,9 +394,7 @@ testthat::test_that("code passed as expression or character is evaluated as iden testthat::test_that("differently formulated expressions yield the same code", { q <- qenv() with(q, 1 + 1) - with(q, { - 1 + 1 - }) + with(q, {1 + 1}) with(q, { 1 + 1 }) @@ -412,20 +409,16 @@ testthat::test_that("differently formulated expressions yield the same code", { ) q <- qenv() + with(q, {1 + 1; 2 + 2}) with(q, { - 1 + 1 - 2 + 2 - }) - with(q, { - 1 + 1 - 2 + 2 + 1 + 1; 2 + 2 }) with(q, { 1 + 1 2 + 2 }) with(q, { - 1 + 1 + 1 + 1; 2 + 2 }) all_code <- get_code(q) @@ -457,20 +450,16 @@ testthat::test_that("external values can be injected into native expressions thr ) ) - with(q, - { - iii <- subset(iris, Species == species) - }, - species = "virginica" - ) + with(q, { + iii <- subset(iris, Species == species) + }, + species = "virginica") external_value <- "versicolor" - with(q, - { - iiii <- subset(iris, Species == species) - }, - species = external_value - ) + with(q, { + iiii <- subset(iris, Species == species) + }, + species = external_value) testthat::expect_identical( get_code(q), @@ -578,3 +567,6 @@ testthat::test_that("within.qenv renturns even if evaluation raises error", { exists("qq", mode = "environment", inherits = FALSE) ) }) + +# nolint start +# styler: on From 32489ae9d2c853972aa654299f7d374467fdc6b5 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 16:57:47 +0200 Subject: [PATCH 41/50] linter --- __new_qenv.R | 6 +++--- tests/testthat/test-with.eqnv.R | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/__new_qenv.R b/__new_qenv.R index 3e09a16c9..c60c6499e 100644 --- a/__new_qenv.R +++ b/__new_qenv.R @@ -216,14 +216,14 @@ print.qenv <- function(x, ...) { #' @export #' @keywords internal -`[.qenv` <- function(x, ...) { +`[.qenv` <- function(x, ...) { # nolint stop("Use `qenv$` or `qenv[[\"\"]]`to access variables.") } #' @export #' @keywords internal -`$<-.qenv` <- function(x, name, value) { +`$<-.qenv` <- function(x, name, value) { # nolint stop( "Direct assignment is forbidden as it cannot be tracked. ", "Use `with( , { <- })` instead." @@ -233,7 +233,7 @@ print.qenv <- function(x, ...) { #' @export #' @keywords internal -`[[<-.qenv` <- function(x, name, value) { +`[[<-.qenv` <- function(x, name, value) { # nolint stop( "Direct assignment is forbidden as it cannot be tracked. ", "Use `with( , { <- })` instead." diff --git a/tests/testthat/test-with.eqnv.R b/tests/testthat/test-with.eqnv.R index ee033fb84..b19fd53e2 100644 --- a/tests/testthat/test-with.eqnv.R +++ b/tests/testthat/test-with.eqnv.R @@ -568,5 +568,5 @@ testthat::test_that("within.qenv renturns even if evaluation raises error", { ) }) -# nolint start +# nolint end # styler: on From 4a0dfc6f0817a0e0918c6772edf56771c04deaf8 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 17:06:42 +0200 Subject: [PATCH 42/50] rename file --- __new_qenv.R => R/with-qenv.R | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename __new_qenv.R => R/with-qenv.R (100%) diff --git a/__new_qenv.R b/R/with-qenv.R similarity index 100% rename from __new_qenv.R rename to R/with-qenv.R From ff7f002628a029314be78996055ff8d27e206435 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 17:08:24 +0200 Subject: [PATCH 43/50] more linter --- R/with-qenv.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/with-qenv.R b/R/with-qenv.R index c60c6499e..1188f3b81 100644 --- a/R/with-qenv.R +++ b/R/with-qenv.R @@ -128,7 +128,7 @@ format.qenv <- function(x) { sep = "\n" ) - # contents/bindings + # contents/bindings # nolint var_names <- ls(x) var_names_hidden <- setdiff(ls(x, all.names = TRUE), var_names) From f6b7d36364c92f5cb90c003465e948409f52c03c Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 17:31:32 +0200 Subject: [PATCH 44/50] modify DESCRIPTION --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 632776034..96f9ff983 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -54,3 +54,4 @@ Collate: 'qenv-show.R' 'teal.code-package.R' 'utils.R' + 'with-qenv.R' From 6cfd05742179483bb8b16c1a3e7782d00f62d5eb Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 17:40:00 +0200 Subject: [PATCH 45/50] rename class to avoid conflicts --- R/with-qenv.R | 112 +++++++++++++++++--------------- tests/testthat/test-with.eqnv.R | 96 +++++++++++++-------------- 2 files changed, 108 insertions(+), 100 deletions(-) diff --git a/R/with-qenv.R b/R/with-qenv.R index 1188f3b81..a488e52a0 100644 --- a/R/with-qenv.R +++ b/R/with-qenv.R @@ -1,31 +1,31 @@ -#' qenv refactor prototype +#' quenv refactor prototype #' #' Simple to use environment with history tracking. #' #' @details -#' Create a `qenv` object, which is an environment, and execute code inside. +#' 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. #' -#' `qenv` creates `qenv` object. -#' `with` acts in `qenv` object. -#' `within` creates and modifies a (deep) copy of `qenv` object. +#' `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 (`qenv`) +#' @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 -#' `qenv` returns a `qenv` object. `with` returns NULL invisibly. `within` returns a modified deep copy of `data`. +#' `quenv` returns a `quenv` object. `with` returns NULL invisibly. `within` returns a modified deep copy of `data`. #' -#' @name qenv +#' @name quenv #' #' @examples #' -#' q <- qenv() +#' q <- quenv() #' #' # execute code #' with(q, { @@ -35,7 +35,7 @@ #' q #' #' # supply code as strings -#' q <- qenv() +#' q <- quenv() #' with(q, text = "c <- cars") #' code_as_text <- "w <- warpbreaks" #' with(q, text = code_as_text) @@ -64,7 +64,7 @@ #' get_conditions(q, "error") #' #' # inject values into code -#' q <- qenv() +#' q <- quenv() #' with(q, i <- iris) #' with(q, print(dim(subset(i, Species == "virginica")))) #' try( @@ -74,28 +74,28 @@ #' species_external <- "versicolor" #' with(q, print(dim(subset(i, Species == species))), species = species_external) #' -#' # execute code in copy of `qenv` and return modified copy -#' q <- qenv() +#' # execute code in copy of `quenv` and return modified copy +#' q <- quenv() #' with(q, i <- iris) #' qq <- within(q, m <- mtcars) #' -#' @rdname qenv +#' @rdname quenv #' @export -qenv <- function() { +quenv <- function() { ans <- new.env() attr(ans, "code") <- list() attr(ans, "errors") <- list() attr(ans, "warnings") <- list() attr(ans, "messages") <- list() - class(ans) <- c("qenv", class(ans)) + class(ans) <- c("quenv", class(ans)) ans } -#' @rdname qenv +#' @rdname quenv #' @export -with.qenv <- function(data, expr, text, ...) { +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) @@ -103,28 +103,28 @@ with.qenv <- function(data, expr, text, ...) { } -#' @rdname qenv +#' @rdname quenv #' @export -within.qenv <- function(data, expr, text, ...) { +within.quenv <- function(data, expr, text, ...) { # Force a return even if some evaluation fails. on.exit(return(data)) - data <- .clone_qenv(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 qenv +#' @rdname quenv #' @export #' @keywords internal -format.qenv <- function(x) { +format.quenv <- function(x) { # opening message header <- paste( - "`qenv` object (environment)", - " Use `with(qenv, { })` to evaluate code in the qenv.", - " Use `get_code(qenv)` to access all code run in the qenv since instantiation.", - " Use `qenv$` or `qenv[[\"\"]]`to access variables.", + "`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" ) @@ -161,7 +161,7 @@ format.qenv <- function(x) { if (!identical(contents_hidden, "")) sprintf("hidden bindings:\n%s", contents_hidden) ) } else { - contents_all <- "This qenv is empty." + contents_all <- "This quenv is empty." } # code @@ -206,46 +206,46 @@ format.qenv <- function(x) { } -#' @rdname qenv +#' @rdname quenv #' @export #' @keywords internal -print.qenv <- function(x, ...) { +print.quenv <- function(x, ...) { cat(format(x, ...), sep = "\n") } #' @export #' @keywords internal -`[.qenv` <- function(x, ...) { # nolint - stop("Use `qenv$` or `qenv[[\"\"]]`to access variables.") +`[.quenv` <- function(x, ...) { # nolint + stop("Use `quenv$` or `quenv[[\"\"]]`to access variables.") } #' @export #' @keywords internal -`$<-.qenv` <- function(x, name, value) { # nolint +`$<-.quenv` <- function(x, name, value) { # nolint stop( "Direct assignment is forbidden as it cannot be tracked. ", - "Use `with( , { <- })` instead." + "Use `with( , { <- })` instead." ) } #' @export #' @keywords internal -`[[<-.qenv` <- function(x, name, value) { # nolint +`[[<-.quenv` <- function(x, name, value) { # nolint stop( "Direct assignment is forbidden as it cannot be tracked. ", - "Use `with( , { <- })` instead." + "Use `with( , { <- })` instead." ) } -#' @rdname qenv +#' @rdname quenv #' @export #' @keywords internal -get_code <- function(x, include_messages = FALSE) { - checkmate::assert_class(x, "qenv") +get_code_quenv <- function(x, include_messages = FALSE) { + checkmate::assert_class(x, "quenv") if (include_messages) { collected <- list( code = lapply(attr(x, "code"), deparse1), @@ -260,11 +260,11 @@ get_code <- function(x, include_messages = FALSE) { } -#' @rdname qenv +#' @rdname quenv #' @export #' @keywords internal get_conditions <- function(x, condition = c("errors", "warnings", "messages", "all")) { - checkmate::assert_class(x, "qenv") + checkmate::assert_class(x, "quenv") condition <- match.arg(condition) if (condition == "all") { @@ -355,49 +355,57 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a #' @keywords internal -# deep copy a `qenv` -.clone_qenv <- function(x) { - if (!inherits(x, "qenv")) stop("\"x\" must be a qenv object") +# 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.qenv` + +# helper for `format.quenv` # briefly summarize object #' @export #' @keywords internal -.object_info <- function(x) { # nolint +.object_info <- function(x) { + # nolint UseMethod(".object_info") } #' @export #' @keywords internal -.object_info.data.frame <- function(x) { # nolint +.object_info.data.frame <- function(x) { + # nolint sprintf("%d x %d", dim(x)[1], dim(x)[2]) } #' @export #' @keywords internal -.object_info.matrix <- function(x) { # nolint +.object_info.matrix <- function(x) { + # nolint sprintf("%s, %d x %d", typeof(x), dim(x)[1], dim(x)[2]) } #' @export #' @keywords internal -.object_info.factor <- function(x) { # nolint +.object_info.factor <- function(x) { + # nolint sprintf("%d levels, [%d]", length(levels(x)), length(x)) } #' @export #' @keywords internal -.object_info.character <- function(x) { # nolint +.object_info.character <- function(x) { + # nolint sprintf("%d item(s), %d value(s)", length(x), length(unique(x))) } #' @export #' @keywords internal -.object_info.numeric <- function(x) { # nolint +.object_info.numeric <- function(x) { + # nolint sprintf("%d item(s)", length(x)) } #' @export #' @keywords internal -.object_info.default <- function(x) { # nolint +.object_info.default <- function(x) { + # nolint "" } diff --git a/tests/testthat/test-with.eqnv.R b/tests/testthat/test-with.eqnv.R index b19fd53e2..e54a52b37 100644 --- a/tests/testthat/test-with.eqnv.R +++ b/tests/testthat/test-with.eqnv.R @@ -2,9 +2,9 @@ # nolint start # creation ---- -testthat::test_that("qenv is created empty with attributes as empty lists", { - testthat::expect_no_error(q <- qenv()) - testthat::expect_s3_class(q, "qenv") +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( @@ -12,7 +12,7 @@ testthat::test_that("qenv is created empty with attributes as empty lists", { errors = list(), warnings = list(), messages = list(), - class = c("qenv", "environment") + class = c("quenv", "environment") ) ) }) @@ -22,13 +22,13 @@ testthat::test_that("qenv is created empty with attributes as empty lists", { ## code acceptance ---- # internal functions .prepare_code and .eval_one are tested by running `with` testthat::test_that("simple expressions passed `expr` are evaluated", { - q <- qenv() + 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 <- qenv() + q <- quenv() testthat::expect_no_error( with(q, { 1 + 1 @@ -54,12 +54,12 @@ testthat::test_that("compound expressions passed to `expr` are evaluated", { }) testthat::test_that("sipmle expressions as literal strings passed to `text` are evaluated", { - q <- qenv() + 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 <- qenv() + q <- quenv() testthat::expect_no_error( with(q, text = "{ 1 + 1 @@ -85,7 +85,7 @@ testthat::test_that("compound expressions as literal strings passed to `text` ar }) testthat::test_that("simple expressions as character vectors passed to `text` are evaluated", { - q <- qenv() + q <- quenv() expressions <- c( "1 + 1", "1 + 1 @@ -100,7 +100,7 @@ testthat::test_that("simple expressions as character vectors passed to `text` ar }) testthat::test_that("compound expressions as character vectors passed to `text` are evaluated", { - q <- qenv() + q <- quenv() expressions <- c( "{1 + 1}", "{1 + 1 @@ -120,7 +120,7 @@ testthat::test_that("compound expressions as character vectors passed to `text` }) testthat::test_that("sipmle expressions from file passed to `text` are evaluated", { - q <- qenv() + q <- quenv() expressions <- c( "1 + 1", "1 + 1 @@ -138,7 +138,7 @@ testthat::test_that("sipmle expressions from file passed to `text` are evaluated }) testthat::test_that("compound expressions from file passed to `text` are evaluated", { - q <- qenv() + q <- quenv() expressions <- c( "{1 + 1}", "{1 + 1 @@ -161,20 +161,20 @@ testthat::test_that("compound expressions from file passed to `text` are evaluat }) testthat::test_that("characters passed to `expr` raise errors", { - q <- qenv() + 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 <- qenv() + q <- quenv() with(q, {"1 + 1"}) - testthat::expect_identical(attributes(q), attributes(qenv())) + testthat::expect_identical(attributes(q), attributes(quenv())) }) # variable assignment ---- -testthat::test_that("direct assignment to qenv is forbidden", { - q <- qenv() +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)) @@ -182,8 +182,8 @@ testthat::test_that("direct assignment to qenv is forbidden", { # variable access ---- -testthat::test_that("variables in qenv can be accessed", { - q <- qenv() +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"]]) @@ -195,7 +195,7 @@ testthat::test_that("variables in qenv can be accessed", { # extracting conditions ---- testthat::test_that("get_conditions extracts requested conditions as lists of strings", { - q <- qenv() + q <- quenv() testthat::expect_error({ with(q, { i <- iris @@ -243,8 +243,8 @@ testthat::test_that("get_conditions extracts requested conditions as lists of st # extracting code ---- -testthat::test_that("get_code extracts code identical to the evaluated one", { - q <- qenv() +testthat::test_that("get_code_quenv extracts code identical to the evaluated one", { + q <- quenv() with(q, { i <- iris m <- mtcars @@ -252,7 +252,7 @@ testthat::test_that("get_code extracts code identical to the evaluated one", { }) testthat::expect_identical( - get_code(q), + get_code_quenv(q), list( quote(i <- iris), quote(m <- mtcars), @@ -261,8 +261,8 @@ testthat::test_that("get_code extracts code identical to the evaluated one", { ) }) -testthat::test_that("get_code juxtaposes expressions with their respective conditions", { - q <- qenv() +testthat::test_that("get_code_quenv juxtaposes expressions with their respective conditions", { + q <- quenv() testthat::expect_error({ with(q, { i <- iris @@ -274,7 +274,7 @@ testthat::test_that("get_code juxtaposes expressions with their respective condi }) }) - summary <- get_code(q, include_messages = TRUE) + 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") @@ -307,7 +307,7 @@ testthat::test_that("get_code juxtaposes expressions with their respective condi # evaluation, ctd. ---- ## code identity ---- testthat::test_that("code passed as expression or character is evaluated as identical", { - q1 <- qenv() + q1 <- quenv() with(q1, 1 + 1) with(q1, { 1 + 1 @@ -331,7 +331,7 @@ testthat::test_that("code passed as expression or character is evaluated as iden } }) - q2 <- qenv() + q2 <- quenv() with(q2, text = "1 + 1") with(q2, text = "{ 1 + 1 @@ -379,20 +379,20 @@ testthat::test_that("code passed as expression or character is evaluated as iden } }" ) - q3 <- qenv() + q3 <- quenv() with(q3, text = expressions) testthat::expect_identical( - get_code(q1), - get_code(q2) + get_code_quenv(q1), + get_code_quenv(q2) ) testthat::expect_identical( - get_code(q2), - get_code(q3) + get_code_quenv(q2), + get_code_quenv(q3) ) }) testthat::test_that("differently formulated expressions yield the same code", { - q <- qenv() + q <- quenv() with(q, 1 + 1) with(q, {1 + 1}) with(q, { @@ -402,13 +402,13 @@ testthat::test_that("differently formulated expressions yield the same code", { 1 + 1 }) - all_code <- get_code(q) + all_code <- get_code_quenv(q) testthat::expect_identical( all_code, rep(list(quote(1 + 1)), 4L) ) - q <- qenv() + q <- quenv() with(q, {1 + 1; 2 + 2}) with(q, { 1 + 1; 2 + 2 @@ -421,7 +421,7 @@ testthat::test_that("differently formulated expressions yield the same code", { 1 + 1; 2 + 2 }) - all_code <- get_code(q) + 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, @@ -431,7 +431,7 @@ testthat::test_that("differently formulated expressions yield the same code", { ## injecting values ---- testthat::test_that("external values can be injected into native expressions through `...`", { - q <- qenv() + q <- quenv() with(q, { i <- subset(iris, Species == "setosa") @@ -462,7 +462,7 @@ testthat::test_that("external values can be injected into native expressions thr species = external_value) testthat::expect_identical( - get_code(q), + get_code_quenv(q), list( quote(i <- subset(iris, Species == "setosa")), quote(ii <- subset(iris, Species == species)), @@ -473,7 +473,7 @@ testthat::test_that("external values can be injected into native expressions thr }) testthat::test_that("external values can be injected into (literal) character expressions through `...`", { - q <- qenv() + q <- quenv() with(q, text = "i <- subset(iris, Species == \"setosa\")") @@ -494,7 +494,7 @@ testthat::test_that("external values can be injected into (literal) character ex with(q, text = "iiii <- subset(iris, Species == species)", species = external_value) testthat::expect_identical( - get_code(q), + get_code_quenv(q), list( quote(i <- subset(iris, Species == "setosa")), quote(ii <- subset(iris, Species == species)), @@ -505,7 +505,7 @@ testthat::test_that("external values can be injected into (literal) character ex }) testthat::test_that("external values can be injected into (value) character expressions through `...`", { - q <- qenv() + q <- quenv() expression <- "i <- subset(iris, Species == \"setosa\")" with(q, text = expression) @@ -530,7 +530,7 @@ testthat::test_that("external values can be injected into (value) character expr with(q, text = expression, species = external_value) testthat::expect_identical( - get_code(q), + get_code_quenv(q), list( quote(i <- subset(iris, Species == "setosa")), quote(ii <- subset(iris, Species == species)), @@ -545,13 +545,13 @@ testthat::test_that("external values can be injected into (value) character expr # no tests for format method yet # within ---- -testthat::test_that("within.qenv renturns a deep copy of `data`", { - q <- qenv() +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 <- qenv() + q <- quenv() with(q, i <- iris) qq <- within(q, m <- mtcars) testthat::expect_failure( @@ -559,8 +559,8 @@ testthat::test_that("within.qenv renturns a deep copy of `data`", { ) }) -testthat::test_that("within.qenv renturns even if evaluation raises error", { - q <- qenv() +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( From 4865ef14c85fd4685e5dc7816ee0735d3803510a Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 17:40:10 +0200 Subject: [PATCH 46/50] modify NAMESPACE --- NAMESPACE | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) 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) From ab846bd967cfe6bca2f5940550ab195ecb45a3d0 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 17:42:26 +0200 Subject: [PATCH 47/50] create docs --- man/quenv.Rd | 110 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 110 insertions(+) create mode 100644 man/quenv.Rd diff --git a/man/quenv.Rd b/man/quenv.Rd new file mode 100644 index 000000000..43c1b87ff --- /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{quenv 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} From d2455ada45e1eecef49e8bb2ffb3f4473cdd0ee7 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Wed, 30 Aug 2023 17:53:58 +0200 Subject: [PATCH 48/50] fix checks --- R/with-qenv.R | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/R/with-qenv.R b/R/with-qenv.R index a488e52a0..b33b5caea 100644 --- a/R/with-qenv.R +++ b/R/with-qenv.R @@ -1,4 +1,4 @@ -#' quenv refactor prototype +#' qenv refactor prototype #' #' Simple to use environment with history tracking. #' @@ -369,43 +369,43 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a # briefly summarize object #' @export #' @keywords internal -.object_info <- function(x) { +.object_info <- function(x) { # nolint # nolint UseMethod(".object_info") } #' @export #' @keywords internal -.object_info.data.frame <- function(x) { +.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) { +.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) { +.object_info.factor <- function(x) { # nolint # nolint sprintf("%d levels, [%d]", length(levels(x)), length(x)) } #' @export #' @keywords internal -.object_info.character <- function(x) { +.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) { +.object_info.numeric <- function(x) { # nolint # nolint sprintf("%d item(s)", length(x)) } #' @export #' @keywords internal -.object_info.default <- function(x) { +.object_info.default <- function(x) { # nolint # nolint "" } From 5dc2207bd41b0bec93d1840b54a45ddc135c4c0b Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Wed, 30 Aug 2023 15:57:11 +0000 Subject: [PATCH 49/50] [skip actions] Roxygen Man Pages Auto Update --- man/quenv.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/quenv.Rd b/man/quenv.Rd index 43c1b87ff..12c669757 100644 --- a/man/quenv.Rd +++ b/man/quenv.Rd @@ -8,7 +8,7 @@ \alias{print.quenv} \alias{get_code_quenv} \alias{get_conditions} -\title{quenv refactor prototype} +\title{qenv refactor prototype} \usage{ quenv() From 0ebc5e75e657b1bba38826bb92fca8324f3ad79b Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Thu, 7 Sep 2023 17:26:23 +0200 Subject: [PATCH 50/50] minor change to logic --- R/with-qenv.R | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/R/with-qenv.R b/R/with-qenv.R index b33b5caea..3bbc74a92 100644 --- a/R/with-qenv.R +++ b/R/with-qenv.R @@ -300,13 +300,12 @@ get_conditions <- function(x, condition = c("errors", "warnings", "messages", "a ) } - # Add braces to expressions. Necessary for proper storage of some expressions (e.g. rm(x)). - if (!is.null(expr) && !grepl("^\\{", deparse1(expr))) { - expr <- call("{", expr) - } - 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)) {