999 set default datanames to ls(data@env) (#1004)

this fixes #999

~~Here, I am assigning the default dataset of data types as "data.frame"
and "MultiAssayExperiment", which can be altered to any other class type
as needed.~~

~~Edit: added function `update_default_dataname`, is designed to
retrieve and update default `datanames` from a `teal_data` object.
Purpose of this function is to extract environment object from a
`teal_data` object. If the object does not already have predefined
dataset names, the function sets default names based on the
environment.~~

Edit: Based on the suggestion, the `init` function has been updated to
avoid modifying the `teal_data` object. Instead, if `datanames` are not
specified, it now passes the app through. Moreover, the
`teal_data_to_filtered_data` function has been adjusted to handle cases
where `datanames` are not pre-defined in the `teal_data` object. In such
case, this function assigns default `datanames` from the environment of
the `teal_data` object.

~~Assertion~~ Different data types in `FilteredData `will be addressed
in issue insightsengineering/teal.slice#493

---------

Signed-off-by: kartikeya kirar <[email protected]>
Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>
Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com>
Co-authored-by: Dawid Kałędkowski <[email protected]>

R/init.R

@@ -10,6 +10,10 @@
 #' End-users: This is the most important function for you to start a
 #' teal app that is composed out of teal modules.
 #'
+#' @details
+#' When initializing the `teal` app, if `datanames` are not set for the `teal_data` object,
+#' defaults from the `teal_data` environment will be used.
+#'
 #' @param data (`teal_data`, `teal_data_module`, `named list`)\cr
 #' `teal_data` object as returned by [teal.data::teal_data()] or
 #' `teal_data_modules` or simply a list of a named list of objects
@@ -183,19 +187,17 @@ init <- function(data,
   }
 
   if (inherits(data, "teal_data")) {
-    if (length(teal.data::datanames(data)) == 0) {
-      stop("`data` object has no datanames. Specify `datanames(data)` and try again.")
+    if (length(teal_data_datanames(data)) == 0) {
+      stop("`data` object has no datanames and its environment is empty. Specify `datanames(data)` and try again.")
     }
-
     # in case of teal_data_module this check is postponed to the srv_teal_with_splash
-    is_modules_ok <- check_modules_datanames(modules, teal.data::datanames(data))
+    is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
     if (!isTRUE(is_modules_ok)) {
       logger::log_error(is_modules_ok)
       checkmate::assert(is_modules_ok, .var.name = "modules")
     }
 
-
-    is_filter_ok <- check_filter_datanames(filter, teal.data::datanames(data))
+    is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))
     if (!isTRUE(is_filter_ok)) {
       logger::log_warn(is_filter_ok)
       # we allow app to continue if applied filters are outside

R/module_teal.R

@@ -189,8 +189,8 @@ srv_teal <- function(id, modules, teal_data_rv, filter = teal_slices()) {
           # null controls a display of filter panel but data should be still passed
           datanames <- if (is.null(modules$datanames) || modules$datanames == "all") {
             include_parent_datanames(
-              teal.data::datanames(teal_data_rv()),
-              teal_data_rv()@join_keys
+              teal_data_datanames(teal_data_rv()),
+              teal.data::join_keys(teal_data_rv())
             )
           } else {
             modules$datanames

R/module_teal_with_splash.R

@@ -126,13 +126,17 @@ srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
         )
       )
 
-      validate(need(teal.data::datanames(data), "Data has no datanames. Contact app developer."))
-
+      if (!length(teal.data::datanames(data))) {
+        warning("`data` object has no datanames. Default datanames are set using `teal_data`'s environment.")
+      }
 
-      is_modules_ok <- check_modules_datanames(modules, teal.data::datanames(data))
-      validate(need(isTRUE(is_modules_ok), is_modules_ok))
+      is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
+      if (!isTRUE(is_modules_ok)) {
+        logger::log_warn(is_modules_ok)
+        validate(need(isTRUE(is_modules_ok), sprintf("%s. Contact app developer.", is_modules_ok)))
+      }
 
-      is_filter_ok <- check_filter_datanames(filter, teal.data::datanames(data))
+      is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))
       if (!isTRUE(is_filter_ok)) {
         showNotification(
           "Some filters were not applied because of incompatibility with data. Contact app developer.",

R/tdata.R

@@ -72,13 +72,6 @@ new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
   for (x in names(data)) {
     if (!is.reactive(data[[x]])) {
       data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x]))
-    } else {
-      isolate(
-        checkmate::assert_multi_class(
-          data[[x]](), c("data.frame", "MultiAssayExperiment"),
-          .var.name = "data"
-        )
-      )
     }
   }
 
@@ -191,12 +184,12 @@ as_tdata <- function(x) {
   }
   if (is.reactive(x)) {
     checkmate::assert_class(isolate(x()), "teal_data")
-    datanames <- isolate(teal.data::datanames(x()))
+    datanames <- isolate(teal_data_datanames(x()))
     datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE)
     code <- reactive(teal.code::get_code(x()))
     join_keys <- isolate(teal.data::join_keys(x()))
   } else if (inherits(x, "teal_data")) {
-    datanames <- teal.data::datanames(x)
+    datanames <- teal_data_datanames(x)
     datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE)
     code <- reactive(teal.code::get_code(x))
     join_keys <- isolate(teal.data::join_keys(x))

R/utils.R

@@ -56,10 +56,9 @@ include_parent_datanames <- function(dataname, join_keys) {
 #' @param datanames (`character`) vector of data set names to include; must be subset of `datanames(x)`
 #' @return (`FilteredData`) object
 #' @keywords internal
-teal_data_to_filtered_data <- function(x, datanames = teal.data::datanames(x)) {
+teal_data_to_filtered_data <- function(x, datanames = teal_data_datanames(x)) {
   checkmate::assert_class(x, "teal_data")
-  checkmate::assert_character(datanames, min.len = 1L, any.missing = FALSE)
-  checkmate::assert_subset(datanames, teal.data::datanames(x))
+  checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)
 
   ans <- teal.slice::init_filtered_data(
     x = sapply(datanames, function(dn) x[[dn]], simplify = FALSE),
@@ -215,3 +214,19 @@ check_filter_datanames <- function(filters, datanames) {
     TRUE
   }
 }
+
+#' Wrapper on `teal.data::datanames`
+#'
+#' Special function used in internals of `teal` to return names of datasets even if `datanames`
+#' has not been set.
+#' @param data (`teal_data`)
+#' @return `character`
+#' @keywords internal
+teal_data_datanames <- function(data) {
+  checkmate::assert_class(data, "teal_data")
+  if (length(teal.data::datanames(data))) {
+    teal.data::datanames(data)
+  } else {
+    names(data@env)
+  }
+}

tests/testthat/test-init.R

@@ -84,18 +84,18 @@ testthat::test_that("init filter accepts `teal_slices`", {
 testthat::test_that("init throws when data has no datanames", {
   testthat::expect_error(
     init(data = teal_data(), modules = list(example_module())),
-    "has no datanames"
+    "`data` object has no datanames and its environment is empty"
   )
 })
 
 testthat::test_that("init throws when incompatible module's datanames", {
   msg <- "Module 'example teal module' uses datanames not available in 'data'"
-  testthat::expect_output(
-    testthat::expect_error(
-      init(data = teal_data(mtcars = mtcars), modules = list(example_module(datanames = "iris"))),
-      msg
+  testthat::expect_error(
+    init(
+      data = teal_data(mtcars = mtcars),
+      modules = list(example_module(datanames = "iris"))
     ),
-    msg
+    "Module 'example teal module' uses datanames not available in 'data'"
   )
 })
 

tests/testthat/test-module_teal_with_splash.R

@@ -57,17 +57,21 @@ testthat::test_that("srv_teal_with_splash passes teal_data to reactive", {
   )
 })
 
-testthat::test_that("srv_teal_with_splash throws when datanames are empty", {
-  shiny::testServer(
-    app = srv_teal_with_splash,
-    args = list(
-      id = "test",
-      data = teal_data(),
-      modules = modules(example_module())
+testthat::test_that("srv_teal_with_splash passes when datanames are empty with warning", {
+  testthat::expect_warning(
+    shiny::testServer(
+      app = srv_teal_with_splash,
+      args = list(
+        id = "test",
+        data = teal_data(),
+        modules = modules(example_module())
+      ),
+      expr = {
+        testthat::expect_is(teal_data_rv_validate, "reactive")
+        testthat::expect_s4_class(teal_data_rv_validate(), "teal_data")
+      }
     ),
-    expr = {
-      testthat::expect_error(teal_data_rv_validate(), "Data has no datanames")
-    }
+    "`data` object has no datanames. Default datanames are set using `teal_data`'s environment."
   )
 })
 
@@ -133,8 +137,8 @@ testthat::test_that("srv_teal_with_splash teal_data_rv_validate throws when inco
     app = srv_teal_with_splash,
     args = list(
       id = "test",
-      data = teal_data(mtcars = mtcars),
-      modules = modules(example_module(datanames = "iris"))
+      data = teal_data(mtcars = mtcars, iris = iris, npk = npk),
+      modules = modules(example_module(datanames = "non-existing"))
     ),
     expr = {
       testthat::expect_is(teal_data_rv_validate, "reactive")
@@ -157,6 +161,10 @@ testthat::test_that("srv_teal_with_splash teal_data_rv_validate returns teal_dat
     ),
     expr = {
       testthat::expect_is(teal_data_rv_validate, "reactive")
+      testthat::expect_output(
+        teal_data_rv_validate(),
+        "Filter 'iris Species' refers to dataname not available in 'data'"
+      )
       testthat::expect_s4_class(teal_data_rv_validate(), "teal_data")
     }
   )

tests/testthat/test-tdata.R

@@ -35,11 +35,6 @@ testthat::test_that("new_tdata throws error if contents of data list are not of
   testthat::expect_error(
     new_tdata(list(x = 1)), "May only contain the following types: \\{data.frame,reactive,MultiAssayExperiment\\}"
   )
-
-  testthat::expect_error(
-    new_tdata(list(x = reactive(1))),
-    "Must inherit from class 'data.frame'/'MultiAssayExperiment'"
-  )
 })
 
 testthat::test_that("new_tdata throws error if code is not character or reactive character", {

tests/testthat/test-utils.R

@@ -36,3 +36,30 @@ testthat::test_that("report_card_template function returns TealReportCard object
   testthat::expect_equal(card$get_name(), "Card title")
   testthat::expect_length(card$get_content(), 1)
 })
+
+test_that("teal_data_to_filtered_data return FilteredData class", {
+  teal_data <- teal.data::teal_data()
+  teal_data <- within(teal_data, iris <- head(iris))
+  datanames(teal_data) <- "iris"
+
+  testthat::expect_s3_class(teal_data_to_filtered_data(teal_data), "FilteredData")
+})
+
+test_that("teal_data_datanames returns names of the @env's objects when datanames not set", {
+  teal_data <- teal.data::teal_data()
+  teal_data <- within(teal_data, {
+    iris <- head(iris)
+    mtcars <- head(mtcars)
+  })
+  testthat::expect_equal(teal_data_datanames(teal_data), c("mtcars", "iris"))
+})
+
+test_that("teal_data_datanames returns datanames which are set by teal.data::datanames", {
+  teal_data <- teal.data::teal_data()
+  teal_data <- within(teal_data, {
+    iris <- head(iris)
+    mtcars <- head(mtcars)
+  })
+  datanames(teal_data) <- "iris"
+  testthat::expect_equal(teal_data_datanames(teal_data), "iris")
+})