fix warn for env and code in extract

Author: gogonzo

R/qenv-extract.R

@@ -19,32 +19,34 @@
 `[.qenv` <- function(x, names, ...) {
   checkmate::assert_class(names, "character")
   possible_names <- ls(get_env(x), all.names = TRUE)
-  names_warn <- setdiff(names, possible_names)
-  names <- intersect(names, possible_names)
-  if (!length(names)) {
-    warning(
-      sprintf(
-        "None of 'names' elements exist in '%s'. Returning empty '%s'.",
-        class(x)[1],
-        class(x)[1]
+  names_corrected <- intersect(names, possible_names)
+  env <- if (length(names_corrected)) {
+    names_missing <- setdiff(names, possible_names)
+    if (length(names_missing)) {
+      warning(
+        sprintf(
+          "Some elements of 'names' do not exist in the environment of the '%s'. Skipping those: %s.",
+          class(x)[1],
+          paste(names_missing, collapse = ", ")
+        )
       )
-    )
-    return(qenv())
-  }
-
-  if (length(names_warn)) {
+    }
+    list2env(as.list(x, all.names = TRUE)[names_corrected], parent = parent.env(.GlobalEnv))
+  } else {
     warning(
       sprintf(
-        "Some elements of 'names' do not exist in '%s'. Skipping those: %s.",
-        class(x)[1],
-        paste(names_warn, collapse = ", ")
-      )
+        "None of 'names' exist in the environment of the '%1$s'. Returning empty '%1$s'.",
+        class(x)[1]
+      ),
+      call. = FALSE
     )
+    new.env(parent = parent.env(.GlobalEnv))
   }
+  lockEnvironment(env)
+  x@.xData <- env
 
-  x@.xData <- list2env(as.list(x, all.names = TRUE)[names])
-  names <- gsub("^`(.*)`$", "\\1", names)
-  x@code <- get_code_dependency(x@code, names = names, ...)
+  normalized_names <- gsub("^`(.*)`$", "\\1", names)
+  x@code <- get_code_dependency(x@code, names = normalized_names, ...)
 
   x
 }

R/utils-get_code_dependency.R

@@ -38,7 +38,7 @@ get_code_dependency <- function(code, names, check_names = TRUE) {
     }))
 
     if (!all(names %in% unique(symbols))) {
-      warning("Object(s) not found in code: ", toString(setdiff(names, symbols)))
+      warning("Object(s) not found in code: ", toString(setdiff(names, symbols)), call. = FALSE)
     }
   }
 

tests/testthat/test-qenv_extract.R

@@ -5,7 +5,7 @@ testthat::test_that("`[.` returns empty qenv for names not in qenv", {
   })
   testthat::expect_warning(
     testthat::expect_equal(data["y"], qenv()),
-    "None of 'names' elements exist in 'qenv'. Returning empty 'qenv'."
+    "None of 'names' exist in the environment of the 'qenv'. Returning empty 'qenv."
   )
 })
 
@@ -16,10 +16,23 @@ testthat::test_that("`[.` returns limited qenv for some names not in qenv", {
   })
   testthat::expect_warning(
     testthat::expect_equal(data[c("y", "a")], data["a"]),
-    "Some elements of 'names' do not exist in 'qenv'. Skipping those: y."
+    "Some elements of 'names' do not exist in the environment of the 'qenv'. Skipping those: y."
   )
 })
 
+testthat::test_that("`[.` limits code for some names not in code", {
+  data <- within(qenv(), {
+    x <- 1
+    a <- 2
+    rm(x)
+  })
+  testthat::expect_warning(
+    testthat::expect_equal(data[c("a", "x")], data["a"]),
+    "Some elements of 'names' do not exist in the environment of the 'qenv'. Skipping those: x."
+  )
+})
+
+
 testthat::test_that("`[.` subsets environment and code to specified object names", {
   q <- qenv()
   code <- c("x<-1", "a<-1;b<-2")