fix tests

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

tests/testthat/_snaps/event_count.md

@@ -234,7 +234,7 @@
         </table>
       </div>
 
-# 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

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

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" |>