From 62fa830be803176858d7fbdca35b0ff4e9d9ec88 Mon Sep 17 00:00:00 2001 From: Luis Moris Fernandez Date: Tue, 22 Oct 2024 18:09:37 +0200 Subject: [PATCH] fix tests --- inst/validation/specs.R | 3 +- tests/testthat/_snaps/event_count.md | 2 +- tests/testthat/setup.R | 86 ++++++++++++++++++++++++++++ tests/testthat/test-event_count.R | 8 ++- 4 files changed, 95 insertions(+), 4 deletions(-) create mode 100644 tests/testthat/setup.R diff --git a/inst/validation/specs.R b/inst/validation/specs.R index 5cc4757..c8fe954 100644 --- a/inst/validation/specs.R +++ b/inst/validation/specs.R @@ -1,5 +1,5 @@ # nolint start -spewcs <- list() +specs <- list() specs[["hierarchical_count_table"]] <- list( "event_count_display" = "The event count module displays event counts grouped by selected hierarchy and population grouping variables. It calculates the number of unique subjects within each group and hierarchy level.", "events_table_display" = "A table will be displayed, showing the event counts and the percentage of subjects that meet the criteria for each combination of hierarchy and group variable.", @@ -11,5 +11,6 @@ specs[["hierarchical_count_table"]] <- list( "total_column_display" = "The app includes a 'Total' column in the event table, which shows the total event count for all groups combined.", "sorted_table_display" = "The event table is sorted by the highest number of subjects with an event within each hierarchy level. The overall hierarchy is ranked based on the highest event counts." ) + specs # nolint end \ No newline at end of file diff --git a/tests/testthat/_snaps/event_count.md b/tests/testthat/_snaps/event_count.md index 8984a0c..c553fa9 100644 --- a/tests/testthat/_snaps/event_count.md +++ b/tests/testthat/_snaps/event_count.md @@ -234,7 +234,7 @@ -# counting is correct, sorting, against (snapshot)__spec_ids{hierarchical_count_table$hierarchical_count_tablel_count_tablel_count_tablel_count_tablel_count_table;hierarchical_count_table$hierarchical_count_table_display;hierarchical_count_table$sorted_table_display} +# counting is correct, sorting, against (snapshot)__spec_ids{hierarchical_count_table$event_count;hierarchical_count_table$event_count_display;hierarchical_count_table$sorted_table_display} Code x diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R new file mode 100644 index 0000000..2301a79 --- /dev/null +++ b/tests/testthat/setup.R @@ -0,0 +1,86 @@ +# nolint start +# validation (S) +vdoc <- local({ + # ########## + # package_name is used # INSIDE # the sourced file below + # ########## + package_name <- read.dcf("../../DESCRIPTION")[, "Package"] + utils_file_path <- system.file("validation", "utils-validation.R", package = package_name, mustWork = TRUE) + source(utils_file_path, local = TRUE)[["value"]] +}) +specs <- vdoc[["specs"]] +# validation (F) + +run_shiny_tests <- !isFALSE(as.logical(Sys.getenv("SKIP_SHINY_TESTS"))) +suspect_check <- any(names(Sys.getenv()) == "_R_CHECK_CRAN_INCOMING_") + +skip_if_not_running_shiny_tests <- function() testthat::skip_if_not(run_shiny_tests, message = "Skip tests") # nolint +skip_if_suspect_check <- function() testthat::skip_if(suspect_check, message = "Suspected check") + +tns_factory <- function(id) function(...) paste0(c(id, as.character(list(...))), collapse = "-") + +# `expr` must be a quosure or a regular call, in both cases they must be self-contained as they will be deparsed +# and run in another process +start_app_driver <- function(expr) { + root_app <- if (run_shiny_tests && !suspect_check) { + app_dir <- if (testthat::is_testing()) { + "app/app.R" + } else { + "tests/testthat/app/app.R" + } + + call <- if (rlang::is_quosure(expr) || rlang::is_expression(expr)) expr else substitute(expr) + + # tryCatch to avoid snapshots being deleted when the app cannot be started + tryCatch( + { + temp <- tempfile() + saveRDS(expr, temp) + + app <- shinytest2::AppDriver$new( + app_dir = app_dir, + seed = 1, + options = list( + "__quo_file" = temp, + "__use_load_all" = isTRUE(as.logical(Sys.getenv("LOCAL_SHINY_TESTS"))) + ) + ) + app$wait_for_idle() + app + }, + condition = function(e) { + if (exists("app") && "stop" %in% names(app)) app$stop() + print(e) + NULL + } + ) + } else { + NULL + } + root_app +} + +# SVG EXPECTATION +# When an error occurs over an r2d3 svg it is not neccesarily removed from the DOM but its visibility is hidden, therefore if we expect the graph +# we expect that it is there, that it is visible and that there are no errors inside the container. +expect_r2d3_svg <- function(app, query_list) { + purrr::walk(query_list, function(query) { + # Check there is an SVG + svg_vec <- rvest::read_html(app$get_js(query[["svg"]])) %>% + rvest::html_elements("svg") + expect_length(svg_vec, query[["n"]]) + + # Check that is visible + is_hidden <- rvest::read_html(app$get_html(query[["container"]])) %>% + rvest::html_element("div .r2d3") %>% + rvest::html_attr("style") %>% + stringr::str_detect("visibility: hidden;") + expect_false(is_hidden) + + # Check that there is no error inside the div + error_vec <- rvest::read_html(app$get_html(query[["container"]])) %>% + rvest::html_element("div .shiny-output-error") + expect_length(error_vec, 0) + }) +} +# nolint end diff --git a/tests/testthat/test-event_count.R b/tests/testthat/test-event_count.R index 197b41c..ab615dc 100644 --- a/tests/testthat/test-event_count.R +++ b/tests/testthat/test-event_count.R @@ -37,10 +37,9 @@ local({ # Testing is done in a simpler way at the end of the count and sorting # We will test against an snapshot that we have checked is correct - test_that("counting is correct, sorting, against (snapshot)" |> vdoc[["add_spec"]]( - c(specs$hierarchical_count_table$hierarchical_count_table, specs$hierarchical_count_table$hierarchical_count_table_display, specs$hierarchical_count_table$sorted_table_display) + c(specs$hierarchical_count_table$event_count, specs$hierarchical_count_table$event_count_display, specs$hierarchical_count_table$sorted_table_display) ), { expect_snapshot(x) }) @@ -73,6 +72,11 @@ local({ if (is.null(root_app)) rlang::abort("App could not be started") } + fail_if_app_not_started() + skip_if_not_running_shiny_tests <- function() testthat::skip_if_not(run_shiny_tests, message = "Skip tests") # nolint + skip_if_suspect_check <- function() testthat::skip_if(suspect_check, message = "Suspected check") + + app <- shinytest2::AppDriver$new(root_app$get_url()) test_that("hierarchy levels can be selected" |>