211 [.teal_data S3 method

DESCRIPTION

@@ -72,10 +72,11 @@ Collate:
     'join_keys.R'
     'teal.data.R'
     'teal_data-class.R'
+    'teal_data-constructor.R'
     'teal_data-datanames.R'
+    'teal_data-extract.R'
     'teal_data-get_code.R'
     'teal_data-show.R'
-    'teal_data.R'
     'testhat-helpers.R'
     'topological_sort.R'
     'verify.R'

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method("[",join_keys)
+S3method("[",teal_data)
 S3method("[<-",join_keys)
 S3method("[[<-",join_keys)
 S3method("join_keys<-",join_keys)

R/teal_data-class.R

@@ -17,13 +17,10 @@ setOldClass("join_keys")
 #' @slot env (`environment`) environment containing data sets and possibly auxiliary variables.
 #'  Access variables with [get_var()] or [`[[`].
 #'  No setter provided. Evaluate code to add variables into `@env`.
-#' @slot code (`character`) vector representing code necessary to reproduce the contents of `@env`.
+#' @slot code (`list` of `character`) representing code necessary to reproduce the contents of `@env`.
 #'  Access with [get_code()].
 #'  No setter provided. Evaluate code to append code to the slot.
-#' @slot id (`integer`) random identifier assigned to each element of `@code`. Used internally.
-#' @slot warnings (`character`) vector of warnings raised when evaluating code.
-#'  Access with [get_warnings()].
-#' @slot messages (`character`) vector of messages raised when evaluating code.
+#'  Read more in Code section.
 #' @slot join_keys (`join_keys`) object specifying joining keys for data sets in `@env`.
 #'  Access or modify with [join_keys()].
 #' @slot datanames (`character`) vector of names of data sets in `@env`.
@@ -32,6 +29,15 @@ setOldClass("join_keys")
 #' @slot verified (`logical(1)`) flag signifying that code in `@code` has been proven to yield contents of `@env`.
 #'  Used internally. See [`verify()`] for more details.
 #'
+#' @section Code:
+#'
+#' Each code element is a character representing one call. Each element has possible attributes:
+#' - `warnings` (`character`) the warnings output when evaluating the code element
+#' - `messages` (`character`) the messages output when evaluating the code element
+#' - `id (`integer`) random identifier of the code element to make sure uniqueness when joining
+#' - `dependency` (`character`) names of objects that appear in this call and gets affected by this call,
+#' separated by `<-` (objects on LHS of `<-` are affected by this line, and objects on RHS are affecting this line)
+#'
 #' @import teal.code
 #' @keywords internal
 setClass(
@@ -77,8 +83,6 @@ new_teal_data <- function(data,
   }
   verified <- (length(code) == 0L && length(data) == 0L)
 
-  id <- sample.int(.Machine$integer.max, size = length(code))
-
   new_env <- rlang::env_clone(list2env(data), parent = parent.env(.GlobalEnv))
   lockEnvironment(new_env, bindings = TRUE)
 
@@ -87,12 +91,41 @@ new_teal_data <- function(data,
   methods::new(
     "teal_data",
     env = new_env,
-    code = code,
-    warnings = rep("", length(code)),
-    messages = rep("", length(code)),
-    id = id,
+    code = code2list(code),
     join_keys = join_keys,
     datanames = datanames,
     verified = verified
   )
 }
+
+
+#' Reshape code to the list
+#'
+#' List will be divided by the calls. Each element of the list contains `id` and `dependency` attributes.
+#'
+#' @param code `character` with the code.
+#'
+#' @return list of `character`s of the length equal to the number of calls in `code`.
+#'
+#' @keywords internal
+#' @noRd
+code2list <- function(code) {
+  checkmate::assert_character(code, null.ok = TRUE)
+  if (length(code) == 0) return(list())
+
+  parsed_code <- parse(text = code, keep.source = TRUE)
+
+  if (length(parsed_code)) {
+    lapply(split_code(code), function(current_code) {
+      attr(current_code, "id") <- sample.int(.Machine$integer.max, 1)
+      parsed_code <- parse(text = current_code, keep.source = TRUE)
+      attr(current_code, "dependency") <- extract_dependency(parsed_code)
+      current_code
+    })
+  } else {
+    # empty code like "", or just comments
+    attr(code, "id") <- sample.int(.Machine$integer.max, size = 1)
+    attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag
+    list(code)
+  }
+}

R/teal_data-extract.R

@@ -0,0 +1,33 @@
+#'
+#' @section Subsetting:
+#' `x[names]` subsets objects in `teal_data` environment and limit the code to the necessary needed to build limited
+#' objects.
+#'
+#' @param names (`character`) names of objects included in `teal_subset` to subset
+#' @param x (`teal_data`)
+#'
+#' @examples
+#'
+#' # Subsetting
+#' data <- teal_data()
+#' data <- eval_code(data, "a <- 1;b<-2")
+#' data["a"]
+#' data[c("a", "b")]
+#'
+#' join_keys(data) <- join_keys(join_key("a", "b", "x"))
+#' join_keys(data["a"]) # should show empty keys
+#' join_keys(data["b"])
+#' join_keys(data)["a"] # should show empty keys
+#' join_keys(data)["b"]
+#'
+#' @rdname teal_data
+#'
+#' @export
+`[.teal_data` <- function(x, names) {
+  x <- NextMethod("`[`", x, check_names = FALSE) # takes 'names' from function's environment
+  if (inherits(x, "qenv")) {
+    return(teal_data())
+  } # all 'names' not in object
+  x@join_keys <- x@join_keys[names]
+  x
+}

R/zzz.R

@@ -1,2 +1,4 @@
 # use non-exported function from teal.code
 lang2calls <- getFromNamespace("lang2calls", "teal.code")
+extract_dependency <- getFromNamespace("extract_dependency", "teal.code")
+split_code <- getFromNamespace("split_code", "teal.code")

tests/testthat/test-extract.R

@@ -0,0 +1,39 @@
+testthat::test_that("`[.` handles empty names", {
+  data <- teal_data(x = 1, a = 2)
+  testthat::expect_warning(
+    testthat::expect_equal(data[character(0)], teal_data())
+  )
+})
+
+testthat::test_that("`[.` handles names as NA_character_", {
+  data <- teal_data(x = 1, a = 2)
+  testthat::expect_warning(
+    testthat::expect_equal(data[NA_character_], teal_data())
+  )
+})
+
+testthat::test_that("`[.` throws warning if names is NULL", {
+  data <- teal_data(x = 1, a = 2)
+  testthat::expect_error(
+    data[NULL],
+    "Assertion on 'names' failed: Must inherit from class 'character', but has class 'NULL'."
+  )
+})
+
+testthat::test_that("`[.` thorws warnings if names is numeric", {
+  data <- teal_data(x = 1, a = 2)
+  testthat::expect_error(
+    data[1],
+    "Assertion on 'names' failed: Must inherit from class 'character', but has class 'numeric'."
+  )
+})
+
+testthat::test_that("`[.` returns limited join_keys", {
+  data <- teal_data(a = 1, b = 2)
+
+  join_keys(data) <- join_keys(join_key("a", "b", "x"))
+  testthat::expect_equal(
+    join_keys(data["a"]),
+    join_keys()
+  )
+})

tests/testthat/test-teal_data.R

@@ -2,11 +2,8 @@ testthat::test_that("teal_data allows to initialize empty teal_data object", {
   testthat::expect_s4_class(teal_data(), "teal_data")
 })
 
-testthat::test_that("empty teal_data returns empty code, id, wartnings and messages and verified=TRUE", {
-  testthat::expect_identical(teal_data()@code, character(0))
-  testthat::expect_identical(teal_data()@id, integer(0))
-  testthat::expect_identical(teal_data()@messages, character(0))
-  testthat::expect_identical(teal_data()@warnings, character(0))
+testthat::test_that("empty teal_data returns empty code and verified=TRUE", {
+  testthat::expect_identical(teal_data()@code, list(character(0)))
   testthat::expect_identical(teal_data()@verified, TRUE)
 })
 
@@ -79,16 +76,16 @@ testthat::test_that("teal_data accepts code as language", {
 
 testthat::test_that("teal_data code unfolds code-block wrapped in '{'", {
   testthat::expect_identical(
-    teal_data(iris1 = iris, code = quote({
+    get_code(teal_data(iris1 = iris, code = quote({
       iris1 <- iris
-    }))@code,
+    }))),
     "iris1 <- iris"
   )
 })
 
 testthat::test_that("teal_data code is concatenated into single string", {
   testthat::expect_identical(
-    teal_data(iris1 = iris, code = c("iris1 <- iris", "iris2 <- iris1"))@code,
+    get_code(teal_data(iris1 = iris, code = c("iris1 <- iris", "iris2 <- iris1"))),
     "iris1 <- iris\niris2 <- iris1"
   )
 })

vignettes/teal-data.Rmd

@@ -30,18 +30,25 @@ my_data <- within(
   {
     data1 <- data.frame(id = 1:10, x = 11:20)
     data2 <- data.frame(id = 1:10, x = 21:30)
+    data3 <- data.frame(id = 1:10, x = 31:40)
   }
 )
 
 # get objects stored in teal_data
 my_data[["data1"]]
-my_data[["data1"]]
+my_data[["data2"]]
+
+# limit objects stored in teal_data
+my_data[c("data1", "data3")]
 
 # get reproducible code
 get_code(my_data)
 
+# get code just for specific object
+get_code(my_data, names = "data2")
+
 # get or set datanames
-datanames(my_data) <- c("data1", "data2")
+datanames(my_data) <- c("data1", "data2", "data3")
 datanames(my_data)
 
 # print
@@ -93,4 +100,7 @@ join_keys(my_data) <- join_keys(
 )
 
 join_keys(my_data)
+
+# join_keys for limited object
+join_keys(my_data["child"])
 ```