tests/testthat/test-examples.R

In teal.modules.general: General Modules for 'teal' Applications

# 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() && identical(Sys.getenv("R_COVR"), "true")) {
    testthat::test_path("man")
  } else if (testthat::is_checking()) {
    testthat::test_path("..", "..", "00_pkg_src", testthat::testing_package(), "man")
  } else {
    testthat::test_path("..", "..", "man")
  }

  testthat::skip_if_not(dir.exists(man_path), "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 <- tryCatch(
      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
      ),
      error = function(e) {
        e$app$stop() # Ensure the R instance is stopped
        stop(e)
      }
    )

    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)),
    {
      testthat::skip_on_cran()
      skip_if_too_deep(5)
      testthat::skip_if_not_installed("pkgload")
      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"
        )
      )
    }
  )
}