Merge pull request #9 from Boehringer-Ingelheim/add_specs

Add specs

.gitignore

@@ -8,4 +8,7 @@
 docs/
 README.html
 vignettes/*\.html
-vignettes/*\.R
+vignettes/*\.R
+inst/validation/results/val_param.rds
+inst/validation/results/val_report.html
+tests/testthat/app/shiny_bookmarks

R/utils-startup.R

@@ -17,7 +17,7 @@ get_raw_config <- function(app) {
 
 insert_header_add_resources <- function(app_title = NULL, ...) {
   shiny::tags$head(
-    title = app_title,
+    shiny::tags$title(app_title),
     shinyjs::useShinyjs(),
     add_manager_dependency(),
     add_scoper_dependency(),

inst/validation/run_validation.R

@@ -1,4 +1,8 @@
-local({
+pkg_name <- read.dcf("DESCRIPTION")[, "Package"]
+pkg_version <- read.dcf("DESCRIPTION")[, "Version"]
+test_results <- tibble::as_tibble(devtools::test(stop_on_failure = FALSE))
+
+v <- local({
   # This is evaluated inside a local because, otherwise, all the variables created in the chunks of the rendered
   # document leak into the environment
 
@@ -34,7 +38,5 @@ local({
     output_file = validation_report_html
   )
 
-  # We use one of the leaked variables, created inside the validation report to asses if the validation is
-  # succesful or not
-  VALIDATION_PASSED
+  uncovered_spec
 })

inst/validation/specs.R

@@ -1,7 +1,105 @@
 # Use a list to declare the specs
+#nolint start
 
 specs_list <- list
 
-example_spec <- specs_list(
-  a_spec = "spec"
+fs_spec <- specs_list(
+  "display_modules" = "dv.manager receives a list of modules and displays it in a application.",
+  "sidebar_menu_display" = "A sidebar menu will displayed (GUI).",
+  "top_navigation_bar_module_list" = "The list of the included modules will appear in a top navigation bar (GUI) in the same order as specified.",
+  "module_content_display" = "The content of each module will be presented when selected.",
+  "custom_title_display" = "dv.manager will show a custom title that appear in the browser's title bar or in the page's tab",
+  "custom_startup_message" = "dv.manager will allow showing a custom startup message",
+  "dataset_list_availability" = "dv.manager receives a list of datasets and make it available for the modules in the application.",
+  "dataset_label_display" = "dv.manager allows datasets to be labeled and displays lables in the application.",
+  "dataset_switching" = "Datasets can be switched during the application execution.",
+  "dataset_selection_sidebar_menu" = "The sidebar menu will allow for selecting among the different datasets passed as parameters to modulemanager (GUI).",
+  "single_dataset_display" = "Only one dataset is displayed in the application at a given time, from now on active dataset.",
+  "modification_dates_display" = "The earliest and latest modification dates of all the data tables are displayed for the active dataset",
+  "date_unavailability_message" = "If no date is available for any of the data tables in the loaded dataset the system displays a 'Date unavailable' message",
+  "data_reloading" = "dv.manager allows the reloading of the data after a specific amount of time.",
+  "filtering_menu_display" = "The sidebar menu will display a filtering menu using the datafilter module (GUI).",
+  "active_dataset_filtering" = "The active dataset can be filtered through the datafilter module.",
+  "bookmarking_features" = "Bookmarking will include:
+- the identity of the loaded dataset
+- the set of filters applied to the loaded dataset
+- the inner state of all modules that support bookmarking included in the app
+- which module is active",
+  "bookmarking_button_display" = "dv.manager will display a bookmarking button",
+  "unfiltered_dataset_access" = "Modules will have access to the unfiltered dataset.",
+  "filtered_dataset_access" = "Modules will have access to the filtered dataset",
+  "other_module_output_access" = "Modules will have access to the output of other modules",
+  "selected_dataset_name_access" = "Modules will have access to the name of the selected dataset",
+  "module_name_access" = "Modules will have access to its name and the name of the other modules",
+  "modification_dates_access" = "Modules will have access to the earliest and latest modification dates of all the data tables.",
+  "module_tab_switching" = "dv.manager allows programatically switching from one module tab to another",  
+  "SSO_authentication_option" = "Modulemanager provides the option to enable the authentication of App Users with SSO to access the app."
 )
+
+sds_spec <- specs_list(
+  "primary_interface_run_app" = "Primary interface:
+The primary interface for modulemanager is based on its 'run_app()'' function that returns an app object.",
+  "module_list_structure" = "- module_list: A named list.
+    -  Each of its entries will contain a list with three entries named:
+        - ['ui']: contains a function with a single parameter that will be the module_id
+        - ['server']: a function with one argument, that will internally call to the corresponding server function.
+        - ['module_id']: a string that will serve as the module_id.
+    - The name of of each entry will act as the name of the module displayed in the UI.",
+  "data_list_structure" = "- data: a named list of datasets to be used in the R/Shiny application.
+    -   Each entry can be:
+        -  A list of data tables.
+        -  A list of functions that return a list of data tables.
+    - All datasets must contain the same data tables.
+    - The name of of each entry will act as the name of the dataset displayed in the UI.
+    - The list can be empty
+    - The list cannot be NULL",
+  "app_title" = "- title: the title of the app that will be displayed in the window name/tab in the browser. Default: 'Untitled'",
+  "filter_data" = "- filter_data: a string indicating which of all the data tables available in each dataset will be used for filtering",
+  "filter_key" = "- filter_key: a string specifying a common field across all datasets that will be used to apply the filtering to all data tables. Default = 'USUBJID'",
+  "startup_message" = "- startup_message:  a message to be displayed at the start of the application. It can be either NULL or a modal message defined with shiny::modalDialog",
+  "azure_options" = "-azure_options: a list with the necessary information for an Azure SSO login. Required entries are redirect, resource, tenant, app, version, password. As defined in the package AzureAuth functions get_azure_token and build_authorization_uri. Or NULL for no login.",
+  "data_reload" = "- data_reload: Either a lubridate object to specify a duration
+or a positive numeric value which is then interpreted as a lubridate duration object in days. By default NULL",
+  "filter_key_check" = "- filter_key must be a field in all data tables in all datasets. Otherwise the application throws an error. If data is empty checking is skipped.",
+  "filter_data_check" = "- filter_data must be a data table in all datasets. Otherwise the application throws an error. If data is empty checking is skipped.",
+  "data_table_meta_check" = "- All data tables in all datasets must have an attribute meta which contains a list with an entry mtime indicating the last modification time. This mtime must contain a POSIXct object. Otherwise the application:
+    -  shows a warning in the application log if is NULL
+    - throws an error if it not POSIXct or NULL
+",
+  "data_structure_check" = "- data is a list of lists of dataframes, or a list of functions. Otherwise throw an informative error.
+- data is not NULL. Otherwise it throws an informative error.
+- Elements in the list data are named. Otherwise it throws an informative error.",
+  "module_list_check" = "- Elements in module_list are named. Otherwise it throws an informative error.
+- module_list is not empty. Otherwise it throws an informative warning.
+- names in module_list are not repeated. Otherwise it throws an informative error.
+- ids of the modules in module_list are not repeated. Otherwise it throws an informative error.",
+  "startup_message_check" = "- startup_message is null or a shiny::modalDialog. Otherwise it throws an informative error.",
+  "azure_options_check" = "-azure_options: must be a list with all the required fields or NULL. Otherwise an error is thrown.",
+  "filtering_menu" = "- A filtering menu that is an instance of datafilter",
+  "dataset_selector" = "- A dataset selector that:
+    - contains one entry per entry in the data parameters list
+    - when changed will load the selected dataset in the application
+    - When one or none dataset are loaded this selector will not be displayed",
+  "tab_selector" = "- a tab selector with one entry per entry in the module_list parameter",
+  "bookmark_button" = "- A bookmark button that starts the bookmarking process",
+  "modification_date_display" = "- The date of modification of the selected dataset as specified by the mtime entry in the meta attribute of the data tables:
+    - The format for the dates is 'Year-Month-Day (UTC)' similar to '2022-Jan-14 (UTC)'
+    - If all data tables have the same modification time only one data is presented
+    - If not all data table have the same modification time, earliest and latest datas are presented, separated by a hyphen
+    - If no date is available for any of the data tables in the loaded dataset the system    displays a 'Date unavailable' message
+    - If no date is available for any of the data tables in any of the datasets, active or not,  an informative log will be provided for the correction of the offending data tables",
+  "selected_dataset_name" = "- The name of the selected dataset",
+  "css_namespacing" = "Module manager by default adds a namespace to the css rules that can be included by the modules. This namespacing can be deactivated by using the option `options('dv.manager.disable_css_namespacing')`",
+  "module_output" = "- module_output is a named list. Each entry of this list contains the output of a module and the name of each entry is the module_id of each module. The nature of the returned values is specified by each module",
+  "dispatchers" = "- dispatchers: A dispatcher function that simplifies the acces to datasets from the module invocation in the module list.",
+  "SSO_login_option" = "module manager offers the option of providing an SSO login. For this the app uses the AzureAuth package.",
+  "AzureAuth_integration" = "module manager just passes the information to AzureAuth therefore no development testing is done at this level, as it requires an Azure AD in place and it is not available at build time in Jenkins.",
+  "data_reloading" = "Module Manager allows reloading the data after a given amount of time. The data_reload parameter will be specified by the App Creator."
+)
+
+specs <- c(
+  fs_spec,
+  sds_spec
+)
+
+#nolint end

inst/validation/utils-validation.R

@@ -1,32 +1,18 @@
 #' Setting up the validation
-#'
-#' 1. Add package_name
-#' 2. Copy that variable and the contents of if block to tests/testthat/setup.R
-#' (If you are using the template this may already be in place for you)
-
-package_name <- "dv.manager"
 
-if (FALSE) {
-  # validation (S)
-  vdoc <- source(
-    system.file("validation", "utils-validation.R", package = package_name, mustWork = TRUE),
-    local = TRUE
-  )[["value"]]
-  specs <- vdoc[["specs"]]
-  # validation (F)
-}
+if (!exists("package_name")) stop("package name must be in the environment when this script is sourced")
 
-#' 2. For those tests that cover an specific spec
+#' How to link tests and specs
 
 if (FALSE) {
   test_that(
-    vdoc[["add_spec"]]("my test description", specs[["a_spec"]]),
+    vdoc[["add_spec"]]("my test description", specs$a_spec),
     {
       expect_true(TRUE)
     }
   )
 }
-#' The specs variable on the call references the one declared in point 1
+#' The specs variable on the call references the one declared in specs.R
 
 #' 3. For those tests covering more than one spec.
 #' NOTE: It must be c() and not list()
@@ -47,7 +33,11 @@ if (FALSE) {
 
 if (FALSE) {
   my_spec <- specs$my$hier$spec
-  test_that(vdoc$parse_spec(my_spec, "my test_description"), {
+  test_that(vdoc[["add_spec"]]("my test_description", my_spec), {
+    ...
+  })
+
+  test_that(vdoc[["add_spec"]]("my test_description", specs[["my"]][["hier"]][["spec"]]), {
     ...
   })
 }
@@ -66,7 +56,7 @@ if (FALSE) {
 }
 
 # Validation code
-
+# nolint start cyclocomp_linter
 local({
   specs <- source(
     system.file("validation", "specs.R", package = package_name, mustWork = TRUE),
@@ -122,27 +112,44 @@ local({
         } # This should be covered by pack of constants but just in case
       } else {
         spec_id_chr <- spec_id
-      }
-      structure(desc, spec_id = spec_id_chr, spec = spec)
+      }      
+      paste0(desc, "__spec_ids{", paste0(spec_id_chr, collapse = ";"), "}")
     },
-    get_spec = function(result) {
-      lapply(
-        result,
-        function(x) {
-          first_result <- try(
-            x[[1]][["test"]],
-            silent = TRUE
-          )
-          if (inherits(first_result, "try-error")) {
-            list(spec_id = NULL, desc = NULL)
-          } else {
-            list(
-              spec_id = attr(first_result, "spec_id", exact = TRUE),
-              spec = attr(first_result, "spec", exact = TRUE)
-            )
-          }
+    get_spec = function(test, specs) {
+      spec_ids <- utils::strcapture(
+            pattern = "__spec_ids\\{(.*)\\}",
+            x = test,
+            proto = list(spec = character())
+          )[["spec"]]
+
+      spec_ids <- strsplit(spec_ids, split = ";")
+
+      specs_and_id <- list()
+
+      for (idx in seq_along(spec_ids)){        
+        ids <- spec_ids[[idx]]        
+        if (all(!is.na(ids))) {
+          this_specs <- list()
+        for (sub_idx in seq_along(ids)) {
+          id <- ids[[sub_idx]]       
+          this_specs[[sub_idx]] <- eval(str2expression(paste0("specs$", id)))
         }
-      )
+        specs_and_id[[idx]] <- list(
+          spec_id = ids,
+          spec = this_specs
+        )
+        } else {
+          specs_and_id[[idx]] <- list(
+          spec_id = NULL,
+          spec = NULL
+        )          
+        }        
+      }      
+      specs_and_id
     }
+
+
   )
 })
+
+# nolint end cyclocomp_linter

inst/validation/val_report_child.Rmd

@@ -14,10 +14,14 @@
 
 ```{r setup, message = FALSE}
 # Import vdoc functions ----
-vdoc <- source(
-  system.file("validation", "utils-validation.R", package = params[["package"]], mustWork = TRUE),
-  local = TRUE
-)[["value"]]
+vdoc <- local({
+  #                      ##########
+  # package_name is used # INSIDE # the sourced file below
+  #                      ##########  
+  package_name <- params[["package"]]
+  utils_file_path <- system.file("validation", "utils-validation.R", package = package_name, mustWork = TRUE)
+  source(utils_file_path, local = TRUE)[["value"]]
+})
 
 # Set required packages ----
 suppressPackageStartupMessages(stopifnot(requireNamespace("DT")))
@@ -26,7 +30,7 @@ suppressPackageStartupMessages(stopifnot(requireNamespace("devtools")))
 # Parse tests ----
 
 tests <- as.data.frame(params[["tests"]])
-tests[["validation_data"]] <- vdoc[["get_spec"]](tests[["result"]])
+tests[["validation_data"]] <- vdoc[["get_spec"]](tests[["test"]], vdoc[["specs"]])
 tests[["spec_id"]] <- sapply(tests[["validation_data"]], function(x) x[["spec_id"]])
 tests[["spec"]] <- sapply(tests[["validation_data"]], function(x) x[["spec"]])
 tests[["spec_id_paste"]] <- vapply(tests[["spec_id"]], function(x) paste(x, collapse = "\n"), FUN.VALUE = character(1))
@@ -45,8 +49,7 @@ undeclared_spec <- tested_spec[!tested_spec %in% declared_spec]
 spec_tests[["are_declared"]] <- sapply(spec_tests[["spec_id"]], function(x) all(x %in% declared_spec))
 
 # Count tests in the different categories ----
-
-mask_failed <- !!spec_tests[["failed"]]
+mask_failed <- !!spec_tests[["failed"]] | spec_tests[["error"]]
 mask_skipped <- !!spec_tests[["skipped"]]
 mask_declared <- spec_tests[["are_declared"]]
 n_pass_dec <- sum(!mask_failed & !mask_skipped & mask_declared)
@@ -82,6 +85,7 @@ title <- paste(result_symbol, params[["package"]], params[["version"]])
 ```
 
 ## `r title`
+Date: `r format(Sys.time(), "%Y-%b-%d %H:%M:%S")`
 
 The following document generates a report for R packages, to satisfy the criteria of a "Released" status under the **Non-GxP** project. The QC report contains the following information:
 

tests/testthat/app/app.R

@@ -12,5 +12,6 @@ if (use_load_all) {
   devtools::load_all(pkg_path, quiet = TRUE)
 }
 
-fn_expr <- getOption("__test_fn_expr")
-eval(parse(text = fn_expr))
+temp <- getOption("__quo_file")
+fn_expr <- readRDS(temp)
+rlang::eval_tidy(fn_expr)

tests/testthat/setup.R

@@ -1,10 +1,15 @@
-package_name <- "dv.manager"
-
 # validation (S)
-vdoc <- source(
-  system.file("validation", "utils-validation.R", package = package_name, mustWork = TRUE),
-  local = TRUE
-)[["value"]]
+vdoc <- local({
+  #                      ##########
+  # package_name is used # INSIDE # the sourced file below
+  #                      ##########
+  package_name <- read.dcf("../../DESCRIPTION")[, "Package"]
+
+  source(
+    system.file("validation", "utils-validation.R", package = package_name, mustWork = TRUE),
+    local = TRUE
+  )[["value"]]
+})
 specs <- vdoc[["specs"]]
 #  validation (F)
 
@@ -26,16 +31,19 @@ start_app_driver <- function(expr, defer = TRUE) {
       "tests/testthat/app/app.R"
     }
 
-    call <- if (rlang::is_quosure(expr)) rlang::get_expr(expr) else substitute(expr)
+    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(
-            "__test_fn_expr" = deparse1(call, collapse = "\n"),
+            "__quo_file" = temp,
             "__use_load_all" = isTRUE(as.logical(Sys.getenv("LOCAL_SHINY_TESTS")))
           )
         )