run examples using shinytest2

DESCRIPTION

@@ -70,6 +70,8 @@ Suggests:
     logger (>= 0.2.0),
     lubridate (>= 1.7.9),
     nestcolor (>= 0.1.0),
+    pkgload,
+    shinytest2,
     styler,
     testthat (>= 3.1.5),
     withr (> 2.0.1.5)
@@ -87,8 +89,8 @@ Config/Needs/verdepcheck: insightsengineering/teal,
     insightsengineering/teal.reporter, insightsengineering/teal.widgets,
     insightsengineering/tern.gee, insightsengineering/tern.mmrm,
     tidyverse/tidyr, shosaco/vistime, tidyverse/forcats, yihui/knitr,
-    tidyverse/lubridate, insightsengineering/nestcolor, r-lib/styler,
-    r-lib/testthat, r-lib/withr
+    tidyverse/lubridate, insightsengineering/nestcolor, r-lib/pkgload,
+    rstudio/shinytest2, r-lib/styler, r-lib/testthat, r-lib/withr
 Config/Needs/website: insightsengineering/nesttemplate
 Config/testthat/edition: 3
 Encoding: UTF-8

R/utils.R

@@ -943,3 +943,6 @@ set_default_total_label <- function(total_label) {
   checkmate::assert_character(total_label, len = 1, null.ok = TRUE)
   options("tmc_default_total_label" = total_label)
 }
+
+# for mocking in tests
+interactive <- NULL

tests/testthat/test-examples.R

@@ -0,0 +1,141 @@
+# 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_linter.
+
+  # 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_name_linter.
+    functionBody(server) <- bquote({
+      pkgload::load_all(
+        .(normalizePath(file.path(testthat::test_path(), "..", ".."))),
+        export_all = FALSE,
+        attach_testthat = FALSE,
+        warn_conflicts = FALSE
+      )
+      .(functionBody(server))
+    })
+    print(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,
+      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)
+
+    # 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"]]
+    # 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()
+
+    ## 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"))) {
+      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_g_barchart_simple.Rd",
+  "tm_g_ci.Rd",
+  "tm_g_ipp.Rd",
+  "tm_g_pp_adverse_events.Rd",
+  "tm_g_pp_vitals.Rd"
+)
+
+for (i in rd_files()) {
+  testthat::test_that(
+    paste0("example-", basename(i)),
+    {
+      testthat::skip_on_cran()
+      if (basename(i) %in% strict_exceptions) {
+        op <- options()
+        withr::local_options(opts_partial_match_old)
+        withr::defer(options(op))
+      }
+      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"
+        )
+      )
+    }
+  )
+}