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" + ) + ) + } + ) +}