Merge branch 'main' into 333_fix_datanames_assigment@main

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: teal.data
 Title: Data Model for 'teal' Applications
-Version: 0.6.0.9016
+Version: 0.6.0.9017
 Date: 2024-11-08
 Authors@R: c(
     person("Dawid", "Kaledkowski", , "[email protected]", role = c("aut", "cre"),
@@ -72,10 +72,11 @@ Collate:
     'join_keys.R'
     'teal.data.R'
     'teal_data-class.R'
+    'teal_data-constructor.R'
+    'teal_data-extract.R'
     'teal_data-get_code.R'
     'teal_data-names.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)

NEWS.md

@@ -1,4 +1,4 @@
-# teal.data 0.6.0.9016
+# teal.data 0.6.0.9017
 
 ### Breaking changes
 

R/join_keys-extract.R

@@ -2,9 +2,9 @@
 #' @order 2
 #'
 #' @section Functions:
-#' - `x[datanames]`: Returns a subset of the `join_keys` object for
-#' given `datanames`, including parent `datanames` and symmetric mirror keys between
-#' `datanames` in the result.
+#' - `x[names]`: Returns a subset of the `join_keys` object for
+#' given `names`, including parent `names` and symmetric mirror keys between
+#' `names` in the result.
 #' - `x[i, j]`: Returns join keys between datasets `i` and `j`,
 #'   including implicit keys inferred from their relationship with a parent.
 #'

R/teal_data-class.R

@@ -18,22 +18,25 @@ setOldClass("join_keys")
 #'  auxiliary variables.
 #'  Access variables with [get()], [`$`], [get_var()] or [`[[`].
 #'  No setter provided. Evaluate code to add variables into `@.xData`.
-#' @slot code (`character`) vector representing code necessary to reproduce the
-#'  contents of `@.xData`.
+#' @slot code (`list` of `character`) representing code necessary to reproduce the contents of `qenv`.
 #'  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.
 #' @slot join_keys (`join_keys`) object specifying joining keys for data sets in
 #' `@.xData`.
 #'  Access or modify with [join_keys()].
 #' @slot verified (`logical(1)`) flag signifying that code in `@code` has been
 #'  proven to yield contents of `@.xData`.
 #'  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(
@@ -54,7 +57,7 @@ setClass(
 setMethod(
   "initialize",
   "teal_data",
-  function(.Object, .xData = list(), join_keys = join_keys(), ...) { # nolint: object_name.
+  function(.Object, .xData = list(), join_keys = join_keys(), code = list(), ...) { # nolint: object_name.
     # Allow .xData to be a list and convert it to an environment
     if (!missing(.xData) && inherits(.xData, "list")) {
       .xData <- rlang::env_clone(list2env(.xData), parent = parent.env(.GlobalEnv)) # nolint: object_name.
@@ -64,12 +67,57 @@ setMethod(
     checkmate::assert_environment(.xData)
     checkmate::assert_class(join_keys, "join_keys")
     checkmate::assert_list(args, names = "named")
+    if (!any(is.language(code), is.character(code))) {
+      stop("`code` must be a character or language object.")
+    }
+
+    if (is.language(code)) {
+      code <- paste(lang2calls(code), collapse = "\n")
+    }
+    if (length(code)) {
+      code <- paste(code, collapse = "\n")
+    }
+
     methods::callNextMethod(
       .Object,
       .xData,
       join_keys = join_keys,
       verified = (length(args$code) == 0L && length(.xData) == 0L),
+      code = code2list(code),
       ...
     )
   }
 )
+
+#' 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,30 @@
+#'
+#' @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_code_names = x@verified) # unverified doesn't need warning for code inconsistency
+  x@join_keys <- x@join_keys[names]
+  x
+}

R/teal_data-get_code.R

@@ -121,7 +121,7 @@ setMethod("get_code",
     }
 
     if (!is.null(names) && lifecycle::is_present(datanames)) {
-      stop("Please use either 'names' (recommended) or 'datanames' parameter.")
+      stop("'names' shouldn't be specified with deprecated 'datanames' parameter.")
     }
 
     checkmate::assert_character(names, min.len = 1L, null.ok = TRUE)

R/teal_data-names.R

@@ -24,18 +24,18 @@ names.teal_data <- function(x) {
   # Sorting from `ls` can be safely done as environments don't have any order
   # nor support numeric-index subsetting
   envir <- as.environment(x)
-  .get_sorted_names(ls(envir = envir), join_keys(x), envir)
+  .get_sorted_names(names = ls(envir = envir), join_keys = join_keys(x), env = envir)
 }
 
 #' @export
 length.teal.data <- function(x) length(ls(x))
 
 #' @keywords internal
-.get_sorted_names <- function(datanames, join_keys, env) {
-  child_parent <- sapply(datanames, parent, x = join_keys, USE.NAMES = TRUE, simplify = FALSE)
+.get_sorted_names <- function(names, join_keys, env) {
+  child_parent <- sapply(names, parent, x = join_keys, USE.NAMES = TRUE, simplify = FALSE)
 
   union(
     intersect(unlist(topological_sort(child_parent)), ls(env, all.names = TRUE)),
-    datanames
+    names
   )
 }

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,20 @@
+testthat::test_that("`[.` subsets join_keys also", {
+  data <- teal_data(a = 1, b = 2)
+  join_keys(data) <- join_keys(join_key("a", "b", "x"))
+  testthat::expect_length(join_keys(data["a"]), 0)
+})
+
+testthat::test_that("`[.` preserves @verified field", {
+  testthat::expect_false(teal_data(a = 1, b = 2)["a"]@verified)
+  testthat::expect_true(within(teal_data(), a <- 1)["a"]@verified)
+})
+
+testthat::test_that("`[.` warns and subsets if names are present in code", {
+  data <- teal_data(a = 1, b = 2, code = "a <- 1; b <- 2; c <- 3; d <- 4")
+  testthat::expect_warning(
+    subset <- data[c("a", "c", "d")],
+    "Some 'names' do not exist in the environment of the 'teal_data'. Skipping those: c, d."
+  )
+  testthat::expect_identical(subset@code, data@code[c(1, 3, 4)])
+  testthat::expect_identical(as.list(subset), as.list(data)[1])
+})

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())
   testthat::expect_identical(teal_data()@verified, TRUE)
 })
 
@@ -71,16 +68,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"
   )
 })

tests/testthat/test-verify.R

@@ -20,7 +20,7 @@ testthat::test_that("verify returns the same object with changed @verified field
   testthat::expect_identical(teal.code::get_env(tdata2_ver), teal.code::get_env(tdata2))
 })
 
-testthat::test_that("verify raises error if @code does not restore objects in @env", {
+testthat::test_that("verify raises error if @code does not restore objects in @.xData", {
   tdata3 <- teal_data(x1 = iris, code = "x1 = mtcars")
 
   testthat::expect_error(verify(tdata3), "Code verification failed.")