From 2d3fd81c0e3ed3516f79c3e6f2aea15389b34378 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 3 Jun 2025 12:57:25 +0200 Subject: [PATCH 1/5] Improvements (i hope so) --- R/qenv-eval_code.R | 31 ++++++++++++++++------------ R/qenv-within.R | 13 +++--------- man/eval_code.Rd | 1 + tests/testthat/test-qenv_eval_code.R | 21 +++++++++---------- tests/testthat/test-qenv_within.R | 5 +++++ 5 files changed, 37 insertions(+), 34 deletions(-) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index 91a89923a..847134f1e 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -25,12 +25,17 @@ #' q <- eval_code(q, expression(assert_number(a))) #' #' @aliases eval_code,qenv-method +#' @aliases eval_code,qenv.error-method #' #' @export -setGeneric("eval_code", function(object, code, cache = FALSE, ...) standardGeneric("eval_code")) +setGeneric("eval_code", function(object, code, cache = FALSE, callback, ...) standardGeneric("eval_code")) setMethod("eval_code", signature = c(object = "qenv"), function(object, code, cache = FALSE, ...) { - code <- .preprocess_code(code) # preprocess code to ensure it is a character vector + if (!is.language(code) && !is.character(code)) { + stop("eval_code accepts code being language or character") + } + code <- .preprocess_code(code) + # preprocess code to ensure it is a character vector .eval_code(object = object, code = code, cache = cache, ...) }) @@ -38,6 +43,9 @@ setMethod("eval_code", signature = c(object = "qenv.error"), function(object, co #' @keywords internal .eval_code <- function(object, code, cache = FALSE, ...) { + if (identical(code, "")) { + return(object) + } parsed_code <- parse(text = code, keep.source = TRUE) object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv)) if (length(parsed_code) == 0) { @@ -100,17 +108,14 @@ setMethod("eval_code", signature = c(object = "qenv.error"), function(object, co } setGeneric(".preprocess_code", function(code) standardGeneric(".preprocess_code")) -setMethod(".preprocess_code", signature = c("ANY"), function(code) paste(code, collapse = "\n")) -setMethod(".preprocess_code", signature = c("language"), function(code) { - paste( - vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), - collapse = "\n" - ) -}) -setMethod(".preprocess_code", signature = c("expression"), function(code) { - if (length(attr(code, "wholeSrcref")) == 0L) { - paste(lang2calls(code), collapse = "\n") - } else { +setMethod(".preprocess_code", signature = c("character"), function(code) paste(code, collapse = "\n")) +setMethod(".preprocess_code", signature = c("ANY"), function(code) { + if (is.expression(code) && length(attr(code, "wholeSrcref"))) { paste(attr(code, "wholeSrcref"), collapse = "\n") + } else { + paste( + vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), + collapse = "\n" + ) } }) diff --git a/R/qenv-within.R b/R/qenv-within.R index ef68da14b..739464a1c 100644 --- a/R/qenv-within.R +++ b/R/qenv-within.R @@ -48,20 +48,13 @@ #' @export #' within.qenv <- function(data, expr, ...) { - expr <- substitute(expr) + expr <- as.expression(substitute(expr)) extras <- list(...) - # Add braces for consistency. - if (!identical(as.list(expr)[[1L]], as.symbol("{"))) { - expr <- call("{", expr) - } - - calls <- as.list(expr)[-1] - # Inject extra values into expressions. - calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras))) + calls <- lapply(expr, function(x) do.call(substitute, list(x, env = extras))) - eval_code(object = data, code = as.expression(calls)) + eval_code(object = data, code = as.expression(calls), ...) } diff --git a/man/eval_code.Rd b/man/eval_code.Rd index 347fe0047..8c697e40f 100644 --- a/man/eval_code.Rd +++ b/man/eval_code.Rd @@ -3,6 +3,7 @@ \name{eval_code} \alias{eval_code} \alias{eval_code,qenv-method} +\alias{eval_code,qenv.error-method} \alias{within.qenv} \title{Evaluate code in \code{qenv}} \usage{ diff --git a/tests/testthat/test-qenv_eval_code.R b/tests/testthat/test-qenv_eval_code.R index 689ee170b..b16ddbdf6 100644 --- a/tests/testthat/test-qenv_eval_code.R +++ b/tests/testthat/test-qenv_eval_code.R @@ -45,6 +45,11 @@ testthat::test_that("eval_code works with expression", { testthat::expect_equal(q1, list2env(list(a = 1, b = 2))) }) +testthat::test_that("eval_code ignores empty code", { + q <- qenv() + testthat::expect_identical(q, eval_code(q, "")) +}) + testthat::test_that("eval_code preserves original formatting when `srcref` is present in the expression", { code <- "# comment a <- 1L" @@ -77,12 +82,11 @@ testthat::test_that("eval_code works with quoted code block", { testthat::expect_equal(q1, list2env(list(a = 1, b = 2))) }) -testthat::test_that("eval_code fails with unquoted expression", { - b <- 3 - testthat::expect_error( - eval_code(qenv(), a <- b), - "unable to find an inherited method for function .eval_code. for signature" - ) +testthat::test_that("eval_code fails with code not being language nor character", { + msg <- "eval_code accepts code being language or character" + testthat::expect_error(eval_code(qenv(), NULL), msg) + testthat::expect_error(eval_code(qenv(), 1), msg) + testthat::expect_error(eval_code(qenv(), list()), msg) }) testthat::test_that("an error when calling eval_code returns a qenv.error object which has message and trace", { @@ -182,8 +186,3 @@ testthat::test_that("comments passed alone to eval_code that contain @linksto ta "x" ) }) - -testthat::test_that("Code executed with integer shorthand (1L) is the same as original", { - q <- within(qenv(), a <- 1L) - testthat::expect_identical(get_code(q), "a <- 1L") -}) diff --git a/tests/testthat/test-qenv_within.R b/tests/testthat/test-qenv_within.R index 9853b4608..14a311a38 100644 --- a/tests/testthat/test-qenv_within.R +++ b/tests/testthat/test-qenv_within.R @@ -149,3 +149,8 @@ testthat::describe("within run with `=`", { testthat::expect_equal(q$i, 1) }) }) + +testthat::test_that("Code executed with integer shorthand (1L) is the same as original", { + q <- within(qenv(), a <- 1L) + testthat::expect_identical(get_code(q), "a <- 1L") +}) From ab512920099b73b9334655cae0589a8c6a449810 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 3 Jun 2025 13:00:03 +0200 Subject: [PATCH 2/5] no callback (sorry) --- R/qenv-eval_code.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index 847134f1e..e53b2cf23 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -28,7 +28,7 @@ #' @aliases eval_code,qenv.error-method #' #' @export -setGeneric("eval_code", function(object, code, cache = FALSE, callback, ...) standardGeneric("eval_code")) +setGeneric("eval_code", function(object, code, cache = FALSE, ...) standardGeneric("eval_code")) setMethod("eval_code", signature = c(object = "qenv"), function(object, code, cache = FALSE, ...) { if (!is.language(code) && !is.character(code)) { From f491c9c1409e07d294672db5318fa304095e4980 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 3 Jun 2025 19:23:33 +0200 Subject: [PATCH 3/5] suggestion --- R/qenv-within.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/qenv-within.R b/R/qenv-within.R index 739464a1c..48409fe71 100644 --- a/R/qenv-within.R +++ b/R/qenv-within.R @@ -53,8 +53,10 @@ within.qenv <- function(data, expr, ...) { # Inject extra values into expressions. calls <- lapply(expr, function(x) do.call(substitute, list(x, env = extras))) - - eval_code(object = data, code = as.expression(calls), ...) + do.call( + eval_code, + modifyList(list(...), list(object = data, code = as.expression(calls))) + ) } From 15f2f8e5c073b201395d2de3a2f98430e41f9e35 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 3 Jun 2025 19:28:46 +0200 Subject: [PATCH 4/5] reuse existing --- R/qenv-within.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-within.R b/R/qenv-within.R index 48409fe71..edcc0bb9a 100644 --- a/R/qenv-within.R +++ b/R/qenv-within.R @@ -55,7 +55,7 @@ within.qenv <- function(data, expr, ...) { calls <- lapply(expr, function(x) do.call(substitute, list(x, env = extras))) do.call( eval_code, - modifyList(list(...), list(object = data, code = as.expression(calls))) + modifyList(extras, list(object = data, code = as.expression(calls))) ) } From e5d78bc2e84820b00d6ad2b3a1d04b864ae03159 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 4 Jun 2025 09:11:54 +0200 Subject: [PATCH 5/5] fix checks (prefix modifyList) --- R/qenv-within.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-within.R b/R/qenv-within.R index edcc0bb9a..33b8ebdcd 100644 --- a/R/qenv-within.R +++ b/R/qenv-within.R @@ -55,7 +55,7 @@ within.qenv <- function(data, expr, ...) { calls <- lapply(expr, function(x) do.call(substitute, list(x, env = extras))) do.call( eval_code, - modifyList(extras, list(object = data, code = as.expression(calls))) + utils::modifyList(extras, list(object = data, code = as.expression(calls))) ) }