Merge remote-tracking branch 'origin/main' into refactor

DESCRIPTION

@@ -1,8 +1,8 @@
 Type: Package
 Package: teal
 Title: Exploratory Web Apps for Analyzing Clinical Trials Data
-Version: 0.14.0.9025
-Date: 2023-11-28
+Version: 0.14.0.9026
+Date: 2023-12-05
 Authors@R: c(
     person("Dawid", "Kaledkowski", , "[email protected]", role = c("aut", "cre")),
     person("Pawel", "Rucki", , "[email protected]", role = "aut"),
@@ -40,9 +40,11 @@ Imports:
     lifecycle (>= 0.2.0),
     logger (>= 0.2.0),
     magrittr (>= 1.5),
+    methods,
     rlang (>= 1.0.0),
     shinyjs,
     stats,
+    teal.code (>= 0.3.0.9009),
     teal.logger (>= 0.1.1),
     teal.reporter (>= 0.2.0),
     teal.widgets (>= 0.4.0),
@@ -56,7 +58,6 @@ Suggests:
     R6,
     rmarkdown (>= 2.19),
     shinyvalidate,
-    teal.code (>= 0.3.0.9009),
     testthat (>= 3.1.5),
     withr (>= 2.1.0),
     yaml (>= 1.1.0)
@@ -98,6 +99,7 @@ Collate:
     'show_rcode_modal.R'
     'tdata.R'
     'teal.R'
+    'teal_data_module-eval_code.R'
     'teal_data_module.R'
     'teal_reporter.R'
     'teal_slices-store.R'

NAMESPACE

@@ -14,6 +14,7 @@ S3method(toString,teal_modules)
 S3method(ui_nested_tabs,default)
 S3method(ui_nested_tabs,teal_module)
 S3method(ui_nested_tabs,teal_modules)
+S3method(within,teal_data_module)
 export("%>%")
 export(TealReportCard)
 export(as.teal_slices)
@@ -42,10 +43,13 @@ export(validate_inputs)
 export(validate_n_levels)
 export(validate_no_intersection)
 export(validate_one_row_per_id)
+exportMethods(eval_code)
 import(shiny)
 import(teal.data)
 import(teal.slice)
 import(teal.transform)
 importFrom(lifecycle,badge)
 importFrom(magrittr,"%>%")
+importFrom(methods,setMethod)
 importFrom(stats,setNames)
+importMethodsFrom(teal.code,eval_code)

NEWS.md

@@ -1,4 +1,4 @@
-# teal 0.14.0.9025
+# teal 0.14.0.9026
 
 ### New features
 

R/teal_data_module-eval_code.R

@@ -0,0 +1,104 @@
+setOldClass("teal_data_module")
+
+#' Evaluate the code in the qenv environment
+#' @name eval_code
+#' @description
+#' Given code is evaluated in the `qenv` environment of `teal_data` reactive defined in `teal_data_module`.
+#' @param object (`teal_data_module`)
+#' @inheritParams teal.code::eval_code
+#' @return Returns a `teal_data_module` object.
+#' @importMethodsFrom teal.code eval_code
+#' @importFrom methods setMethod
+NULL
+
+#' @rdname eval_code
+#' @export
+#'
+#' @examples
+#' tdm <- teal_data_module(
+#'   ui = function(id) div(id = shiny::NS(id)("div_id")),
+#'   server = function(id) {
+#'     shiny::moduleServer(id, function(input, output, session) {
+#'       shiny::reactive(teal_data(IRIS = iris))
+#'     })
+#'   }
+#' )
+#' eval_code(tdm, "IRIS <- subset(IRIS, Species == 'virginica')")
+setMethod("eval_code", signature = c("teal_data_module", "character"), function(object, code) {
+  teal_data_module(
+    ui = function(id) {
+      ns <- NS(id)
+      object$ui(ns("mutate_inner"))
+    },
+    server = function(id) {
+      moduleServer(id, function(input, output, session) {
+        teal_data_rv <- object$server("mutate_inner")
+
+        if (!is.reactive(teal_data_rv)) {
+          stop("The `teal_data_module` must return a reactive expression.", call. = FALSE)
+        }
+
+        td <- eventReactive(teal_data_rv(),
+          {
+            if (inherits(teal_data_rv(), c("teal_data", "qenv.error"))) {
+              eval_code(teal_data_rv(), code)
+            } else {
+              teal_data_rv()
+            }
+          },
+          ignoreNULL = FALSE
+        )
+        td
+      })
+    }
+  )
+})
+
+#' @rdname eval_code
+#' @export
+setMethod("eval_code", signature = c("teal_data_module", "language"), function(object, code) {
+  eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
+})
+
+#' @rdname eval_code
+#' @export
+setMethod("eval_code", signature = c("teal_data_module", "expression"), function(object, code) {
+  eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
+})
+
+#' @inherit teal.code::within.qenv params title details
+#' @description
+#' Convenience function for evaluating inline code inside the environment of a
+#' `teal_data_module`
+#'
+#' @param data (`teal_data_module`) object
+#' @return Returns a `teal_data_module` object with a delayed evaluation of `expr`
+#' when module.
+#' @export
+#' @seealso [base::within()], [teal_data_module()]
+#' @examples
+#' tdm <- teal_data_module(
+#'   ui = function(id) div(id = shiny::NS(id)("div_id")),
+#'   server = function(id) {
+#'     shiny::moduleServer(id, function(input, output, session) {
+#'       shiny::reactive(teal_data(IRIS = iris))
+#'     })
+#'   }
+#' )
+#' within(tdm, IRIS <- subset(IRIS, Species == "virginica"))
+within.teal_data_module <- function(data, expr, ...) {
+  expr <- 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))
+}

R/zzz.R

@@ -29,3 +29,7 @@ setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
 coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
 # all *Block objects are private in teal.reporter
 RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint
+
+# Use non-exported function(s) from teal.code
+# This one is here because lang2calls should not be exported from teal.code
+lang2calls <- getFromNamespace("lang2calls", "teal.code")

_pkgdown.yml

@@ -116,6 +116,8 @@ reference:
       - get_code_tdata
       - get_metadata
       - tdata2env
+      - eval_code
+      - within.teal_data_module
       - show_rcode_modal
       - join_keys.tdata
   # - title: Functions Moved to Other Packages

tests/testthat/test-module_nested_tabs.R

@@ -1,6 +1,5 @@
 teal_data <- teal.data::teal_data()
 teal_data <- within(teal_data, iris <- head(iris))
-teal_data <- teal.data::teal_data() |> within(iris <- head(iris))
 datanames(teal_data) <- "iris"
 filtered_data <- teal_data_to_filtered_data(teal_data)
 

tests/testthat/test-module_teal_with_splash.R

@@ -96,7 +96,7 @@ testthat::test_that("srv_teal_with_splash teal_data_rv_validate throws then qenv
       id = "test",
       data = teal_data_module(
         ui = function(id) div(),
-        server = function(id) reactive(teal_data() %>% within(stop("not good")))
+        server = function(id) reactive(within(teal_data(), stop("not good")))
       ),
       modules = modules(example_module())
     ),
@@ -175,3 +175,98 @@ testthat::test_that("srv_teal_with_splash gets observe event from srv_teal", {
     }
   )
 })
+
+testthat::test_that("srv_teal_with_splash accepts data after within.teal_data_module", {
+  tdm <- teal_data_module(ui = function(id) div(), server = function(id) reactive(teal_data(IRIS = iris)))
+  tdm2 <- within(tdm, IRIS$id <- seq_len(NROW(IRIS$Species))) # nolint: object_name_linter.
+
+  testthat::expect_no_error(
+    shiny::testServer(
+      app = srv_teal_with_splash,
+      args = list(
+        id = "id",
+        data = tdm2,
+        modules = modules(example_module())
+      ),
+      expr = {
+        testthat::expect_s3_class(teal_data_rv, "reactive")
+        testthat::expect_s3_class(teal_data_rv_validate, "reactive")
+        testthat::expect_s4_class(teal_data_rv_validate(), "teal_data")
+        testthat::expect_identical(
+          teal_data_rv_validate()[["IRIS"]],
+          within(iris, id <- seq_len(NROW(Species)))
+        )
+      }
+    )
+  )
+})
+
+testthat::test_that("srv_teal_with_splash throws error when within.teal_data_module returns qenv.error", {
+  tdm <- teal_data_module(ui = function(id) div(), server = function(id) reactive(teal_data(IRIS = iris)))
+  tdm2 <- within(tdm, non_existing_var + 1)
+
+  testthat::expect_no_error(
+    shiny::testServer(
+      app = srv_teal_with_splash,
+      args = list(
+        id = "id",
+        data = tdm2,
+        modules = modules(example_module())
+      ),
+      expr = {
+        testthat::expect_s3_class(teal_data_rv, "reactive")
+        testthat::expect_s3_class(teal_data_rv(), "qenv.error")
+        testthat::expect_s3_class(teal_data_rv_validate, "reactive")
+        testthat::expect_error(teal_data_rv_validate(), "when evaluating qenv code")
+      }
+    )
+  )
+})
+
+testthat::test_that("srv_teal_with_splash throws error when within.teal_data_module returns NULL", {
+  tdm <- teal_data_module(ui = function(id) div(), server = function(id) reactive(NULL))
+  tdm2 <- within(tdm, within(1 + 1))
+  testthat::expect_no_error(
+    shiny::testServer(
+      app = srv_teal_with_splash,
+      args = list(
+        id = "id",
+        data = tdm2,
+        modules = modules(example_module())
+      ),
+      expr = {
+        testthat::expect_s3_class(teal_data_rv, "reactive")
+        testthat::expect_null(teal_data_rv())
+        testthat::expect_s3_class(teal_data_rv_validate, "reactive")
+        testthat::expect_error(teal_data_rv_validate(), "`teal_data_module` did not return `teal_data` object ")
+      }
+    )
+  )
+})
+
+testthat::test_that(
+  paste(
+    "srv_teal_with_splash throws error when within.teal_data_module returns arbitrary object",
+    "(other than `teal_data` or `qenv.error`)"
+  ),
+  {
+    tdm <- teal_data_module(ui = function(id) div(), server = function(id) reactive(NULL))
+    tdm2 <- within(tdm, 1 + 1)
+    testthat::expect_no_error(
+      shiny::testServer(
+        app = srv_teal_with_splash,
+        args = list(
+          id = "id",
+          data = tdm2,
+          modules = modules(example_module())
+        ),
+        expr = {
+          testthat::expect_s3_class(teal_data_rv, "reactive")
+          testthat::expect_null(teal_data_rv())
+          testthat::expect_s3_class(teal_data_rv_validate, "reactive")
+          testthat::expect_error(teal_data_rv_validate(), "`teal_data_module` did not return `teal_data` object ")
+        }
+      )
+    )
+  }
+)