From 46dc21951b7b44a8d36513eb2a8eb94c3f56da6e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?=
 <211358+averissimo@users.noreply.github.com>
Date: Mon, 22 Apr 2024 16:07:03 +0200
Subject: [PATCH] 712 - `shinytest2` Run all example apps (#721)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

# Pull Request

<!--- Replace `#nnn` with your issue link for reference. -->

Part of #712

#### Changes description

- Adds tests that iterate on each documentation file and runs the
examples apps by mocking `interactive` and
`shinyApp` functions.
- Checks if there are no errors nor validation errors (with exceptions)
- Implements
https://github.com/insightsengineering/teal.modules.clinical/pull/983 on
this repository

#### Changes from
https://github.com/insightsengineering/teal.modules.clinical/pull/983

- Adds:
  - Regex rules define "accepted" validation errors
- Fixes:
- Reverts to use `library` instead of `pkgload::load_all` due to
problems with `system.file` call that cannot find package files.

```diff
diff -u teal.modules.clinical/tests/testthat/test-examples.R teal.modules.general/tests/testthat/test-examples.R
--- teal.modules.clinical/tests/testthat/test-examples.R	2024-04-12 10:32:33.100707738 +0200
+++ teal.modules.general/tests/testthat/test-examples.R	2024-04-12 10:26:27.645642183 +0200
@@ -38,12 +38,7 @@ with_mocked_app_bindings <- function(code) {
   # change to `print(shiny__shinyApp(...))` and remove allow warning once fixed
   mocked_shinyApp <- function(ui, server, ...) { # nolint object_name_linter.
     functionBody(server) <- bquote({
-      pkgload::load_all(
-        .(normalizePath(file.path(testthat::test_path(), "..", ".."))),
-        export_all = FALSE,
-        attach_testthat = FALSE,
-        warn_conflicts = FALSE
-      )
+      library(.(testthat::testing_package()), character.only = TRUE)
       .(functionBody(server))
     })
     print(do.call(shiny__shinyApp, append(x = list(ui = ui, server = server), list(...))))
@@ -56,16 +51,34 @@ with_mocked_app_bindings <- function(code) {
     app_driver <- shinytest2::AppDriver$new(
       x,
       shiny_args = args,
+      timeout = 20 * 1000,
+      load_timeout = 30 * 1000,
       check_names = FALSE, # explicit check below
       options = options() # https://github.com/rstudio/shinytest2/issues/377
     )
     on.exit(app_driver$stop(), add = TRUE)
-    app_driver$wait_for_idle(timeout = 20000)
+    app_driver$wait_for_idle()

     # Simple testing
     ## warning in the app does not invoke a warning in the test
     ## https://github.com/rstudio/shinytest2/issues/378
     app_logs <- subset(app_driver$get_logs(), location == "shiny")[["message"]]
+
+    # Check if the teal app has content (indicator of a Shiny App fatal error)
+    if (identical(trimws(app_driver$get_text("#teal-main_ui_container")), "")) {
+      tryCatch(
+        app_driver$wait_for_idle(duration = 2000), # wait 2 seconds for session to disconnect
+        error = function(err) {
+          stop(
+            sprintf(
+              "Teal Application is empty. An Error may have occured:\n%s",
+              paste0(subset(app_driver$get_logs(), location == "shiny")[["message"]], collapse = "\n")
+            )
+          )
+        }
+      )
+    }
+
     # allow `Warning in file(con, "r")` warning coming from pkgload::load_all()
     if (any(grepl("Warning in.*", app_logs) & !grepl("Warning in file\\(con, \"r\"\\)", app_logs))) {
       warning(
@@ -79,9 +92,17 @@ with_mocked_app_bindings <- function(code) {
     ## Throw an error instead of a warning (default `AppDriver$new(..., check_names = TRUE)` throws a warning)
     app_driver$expect_unique_names()

+    err_el <- Filter(
+      function(x) {
+        allowed_errors <- getOption("test_examples.discard_error_regex", "")
+        identical(allowed_errors, "") || !grepl(allowed_errors, x)
+      },
+      app_driver$get_html(".shiny-output-error")
+    )
+
     ## shinytest2 captures app crash but teal continues on error inside the module
     ## we need to use a different way to check if there are errors
-    if (!is.null(err_el <- app_driver$get_html(".shiny-output-error"))) {
+    if (!is.null(err_el) && length(err_el) > 0) {
       stop(sprintf("Module error is observed:\n%s", err_el))
     }

@@ -110,11 +131,14 @@ with_mocked_app_bindings <- function(code) {

 strict_exceptions <- c(
   # https://github.com/r-lib/gtable/pull/94
-  "tm_g_barchart_simple.Rd",
-  "tm_g_ci.Rd",
-  "tm_g_ipp.Rd",
-  "tm_g_pp_adverse_events.Rd",
-  "tm_g_pp_vitals.Rd"
+  "tm_outliers.Rd",
+  "tm_g_response.Rd",
+  "tm_a_pca.Rd"
+)
+
+discard_validation_regex <- list(
+  "tm_file_viewer.Rd" = "Please select a file\\.",
+  "tm_g_distribution.Rd" = "Please select a test"
 )

 for (i in rd_files()) {
@@ -122,11 +146,18 @@ for (i in rd_files()) {
     paste0("example-", basename(i)),
     {
       testthat::skip_on_cran()
+      skip_if_too_deep(5)
       if (basename(i) %in% strict_exceptions) {
         op <- options()
         withr::local_options(opts_partial_match_old)
         withr::defer(options(op))
       }
+      # Allow for specific validation errors for individual examples
+      withr::local_options(
+        list(
+          "test_examples.discard_error_regex" = discard_validation_regex[[basename(i)]]
+        )
+      )
       with_mocked_app_bindings(
         # suppress warnings coming from saving qenv https://github.com/insightsengineering/teal.code/issues/194
         suppress_warnings(```

---------

Signed-off-by: André Veríssimo <211358+averissimo@users.noreply.github.com>
Co-authored-by: kartikeya kirar <kirar.kartikeya1@gmail.com>
Co-authored-by: Vedha Viyash <49812166+vedhav@users.noreply.github.com>
---
 DESCRIPTION                    |   1 +
 R/tm_a_pca.R                   |   2 +-
 R/zzz.R                        |   2 +
 tests/testthat/man             |   1 +
 tests/testthat/test-examples.R | 170 +++++++++++++++++++++++++++++++++
 5 files changed, 175 insertions(+), 1 deletion(-)
 create mode 120000 tests/testthat/man
 create mode 100644 tests/testthat/test-examples.R

diff --git a/DESCRIPTION b/DESCRIPTION
index 62833cfd9..6db6d7e0d 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -72,6 +72,7 @@ Suggests:
     rtables (>= 0.6.6),
     rvest,
     shinytest2,
+    pkgload,
     sparkline,
     testthat (>= 3.0.4),
     withr (>= 2.0.0)
diff --git a/R/tm_a_pca.R b/R/tm_a_pca.R
index 20e2c1cb9..a87a437cf 100644
--- a/R/tm_a_pca.R
+++ b/R/tm_a_pca.R
@@ -307,7 +307,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
       all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]])
       ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]])
       color_cols <- all_cols[!names(all_cols) %in% ignore_cols]
-      response[[i]]$select$choices <- choices_labeled(names(color_cols), color_cols)
+      response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols)
     }
 
     selector_list <- teal.transform::data_extract_multiple_srv(
diff --git a/R/zzz.R b/R/zzz.R
index 40357643e..66210152b 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -5,3 +5,5 @@
 
 ### global variables
 ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void")
+
+interactive <- NULL
diff --git a/tests/testthat/man b/tests/testthat/man
new file mode 120000
index 000000000..ee201c193
--- /dev/null
+++ b/tests/testthat/man
@@ -0,0 +1 @@
+../../man
\ No newline at end of file
diff --git a/tests/testthat/test-examples.R b/tests/testthat/test-examples.R
new file mode 100644
index 000000000..668f51da0
--- /dev/null
+++ b/tests/testthat/test-examples.R
@@ -0,0 +1,170 @@
+# this test requires a `man` directory in the `tests/testthat` directory
+# (presumably symlinked to the package root `man` directory to avoid duplication)
+# this also requires `devtools::document()` to be run before running the tests
+
+rd_files <- function() {
+  man_path <- if (testthat::is_checking()) {
+    testthat::test_path("..", "..", "00_pkg_src", testthat::testing_package(), "man")
+  } else {
+    testthat::test_path("..", "..", "man")
+  }
+
+  if (!dir.exists(man_path)) {
+    stop("Cannot find path to `man` directory.")
+  }
+
+  list.files(
+    man_path,
+    pattern = "\\.[Rr]d$",
+    full.names = TRUE
+  )
+}
+
+suppress_warnings <- function(expr, pattern = "*", ...) {
+  withCallingHandlers(
+    expr,
+    warning = function(w) {
+      if (grepl(pattern, conditionMessage(w))) {
+        invokeRestart("muffleWarning")
+      }
+    }
+  )
+}
+
+with_mocked_app_bindings <- function(code) {
+  shiny__shinyApp <- shiny::shinyApp # nolint object_name.
+  # workaround of https://github.com/rstudio/shinytest2/issues/381
+  # change to `print(shiny__shinyApp(...))` and remove allow warning once fixed
+  mocked_shinyApp <- function(ui, server, ...) { # nolint object_linter.
+    functionBody(server) <- bquote({
+      .hint_to_load_package <- add_facet_labels # Hint to shinytest2 when looking for packages in globals
+      .(functionBody(server))
+    })
+    mocked_runApp(do.call(shiny__shinyApp, append(x = list(ui = ui, server = server), list(...))))
+  }
+
+  mocked_runApp <- function(x, ...) { # nolint object_name_linter.
+    args <- list(...)
+    args[["launch.browser"]] <- FALSE # needed for RStudio
+
+    app_driver <- shinytest2::AppDriver$new(
+      x,
+      shiny_args = args,
+      timeout = 20 * 1000,
+      load_timeout = 30 * 1000,
+      check_names = FALSE, # explicit check below
+      options = options() # https://github.com/rstudio/shinytest2/issues/377
+    )
+    on.exit(app_driver$stop(), add = TRUE)
+    app_driver$wait_for_idle()
+
+    # Simple testing
+    ## warning in the app does not invoke a warning in the test
+    ## https://github.com/rstudio/shinytest2/issues/378
+    app_logs <- subset(app_driver$get_logs(), location == "shiny")[["message"]]
+
+    # Check if the teal app has content (indicator of a Shiny App fatal error)
+    if (identical(trimws(app_driver$get_text("#teal-main_ui_container")), "")) {
+      tryCatch(
+        app_driver$wait_for_idle(duration = 2000), # wait 2 seconds for session to disconnect
+        error = function(err) {
+          stop(
+            sprintf(
+              "Teal Application is empty. An Error may have occured:\n%s",
+              paste0(subset(app_driver$get_logs(), location == "shiny")[["message"]], collapse = "\n")
+            )
+          )
+        }
+      )
+    }
+
+    # allow `Warning in file(con, "r")` warning coming from pkgload::load_all()
+    if (any(grepl("Warning in.*", app_logs) & !grepl("Warning in file\\(con, \"r\"\\)", app_logs))) {
+      warning(
+        sprintf(
+          "Detected a warning in the application logs:\n%s",
+          paste0(app_logs, collapse = "\n")
+        )
+      )
+    }
+
+    ## Throw an error instead of a warning (default `AppDriver$new(..., check_names = TRUE)` throws a warning)
+    app_driver$expect_unique_names()
+
+    err_el <- Filter(
+      function(x) {
+        allowed_errors <- getOption("test_examples.discard_error_regex", "")
+        identical(allowed_errors, "") || !grepl(allowed_errors, x)
+      },
+      app_driver$get_html(".shiny-output-error")
+    )
+
+    ## shinytest2 captures app crash but teal continues on error inside the module
+    ## we need to use a different way to check if there are errors
+    if (!is.null(err_el) && length(err_el) > 0) {
+      stop(sprintf("Module error is observed:\n%s", err_el))
+    }
+
+    ## validation errors from shinyvalidate - added by default to assure the examples are "clean"
+    if (!is.null(err_el <- app_driver$get_html(".shiny-input-container.has-error:not(.shiny-output-error-validation)"))) { # nolint line_length_linter.
+      stop(sprintf("shinyvalidate error is observed:\n%s", err_el))
+    }
+  }
+
+  # support both `shinyApp(...)` as well as prefixed `shiny::shinyApp(...)` calls
+  # mock `shinyApp` to `shiny::shinyApp` and `shiny::shinyApp` to custom function
+  # same for `runApp(...)` and `shiny::runApp`
+  # additionally mock `interactive()`
+  testthat::with_mocked_bindings(
+    testthat::with_mocked_bindings(
+      code,
+      shinyApp = shiny::shinyApp,
+      runApp = shiny::runApp,
+      interactive = function() TRUE
+    ),
+    shinyApp = mocked_shinyApp,
+    runApp = mocked_runApp,
+    .package = "shiny"
+  )
+}
+
+strict_exceptions <- c(
+  # https://github.com/r-lib/gtable/pull/94
+  "tm_outliers.Rd",
+  "tm_g_response.Rd",
+  "tm_a_pca.Rd"
+)
+
+discard_validation_regex <- list(
+  "tm_file_viewer.Rd" = "Please select a file\\.",
+  "tm_g_distribution.Rd" = "Please select a test"
+)
+
+for (i in rd_files()) {
+  testthat::test_that(
+    paste0("example-", basename(i)),
+    {
+      skip_if_too_deep(5)
+      if (basename(i) %in% strict_exceptions) {
+        op <- options()
+        withr::local_options(opts_partial_match_old)
+        withr::defer(options(op))
+      }
+      # Allow for specific validation errors for individual examples
+      withr::local_options(
+        list(
+          "test_examples.discard_error_regex" = discard_validation_regex[[basename(i)]]
+        )
+      )
+      with_mocked_app_bindings(
+        # suppress warnings coming from saving qenv https://github.com/insightsengineering/teal.code/issues/194
+        suppress_warnings(
+          testthat::expect_no_error(
+            pkgload::run_example(i, run_donttest = TRUE, run_dontrun = FALSE, quiet = TRUE)
+          ),
+          "may not be available when loading"
+        )
+      )
+    }
+  )
+}