Improvements (i hope so)

R/qenv-eval_code.R

@@ -25,19 +25,27 @@
 #' 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"))
 
 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, ...)
 })
 
 setMethod("eval_code", signature = c(object = "qenv.error"), function(object, code, cache = FALSE, ...) object)
 
 #' @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"
+    )
   }
 })

R/qenv-within.R

@@ -48,20 +48,15 @@
 #' @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)))
-
-  eval_code(object = data, code = as.expression(calls))
+  calls <- lapply(expr, function(x) do.call(substitute, list(x, env = extras)))
+  do.call(
+    eval_code,
+    utils::modifyList(extras, list(object = data, code = as.expression(calls)))
+  )
 }
 
 

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")
-})

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")
+})