diff --git a/.lintr b/.lintr new file mode 100644 index 0000000..d2d542e --- /dev/null +++ b/.lintr @@ -0,0 +1,6 @@ +linters: linters_with_defaults( + line_length_linter(120), + object_usage_linter = NULL, + indentation_linter = NULL, + trailing_whitespace_linter = NULL + ) diff --git a/DESCRIPTION b/DESCRIPTION index cb07808..301b298 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: dv.filter Title: Dynamic Data Filtering Module -Version: 2.1.1 +Version: 3.0.0 Authors@R: c( person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")), person("Ming", "Yang", email = "ming.yang.ext@boehringer-ingelheim.com", role = c("aut", "cre")), diff --git a/NEWS.md b/NEWS.md index 67304c9..219159b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# dv.filter 3.0.0 + +- GitHub release with QC report + # dv.filter 2.1.1 - Initial release to GitHub diff --git a/inst/validation/results/.gitempty b/inst/validation/results/.gitempty new file mode 100644 index 0000000..e69de29 diff --git a/inst/validation/run_validation.R b/inst/validation/run_validation.R new file mode 100644 index 0000000..66396c0 --- /dev/null +++ b/inst/validation/run_validation.R @@ -0,0 +1,44 @@ +pkg_name <- read.dcf("DESCRIPTION")[, "Package"] +pkg_version <- read.dcf("DESCRIPTION")[, "Version"] +test_results <- tibble::as_tibble(devtools::test()) + +local({ + # This is evaluated inside a local because, otherwise, all the variables created in the chunks of the rendered + # document leak into the environment + + validation_root <- "./inst/validation" + validation_report_rmd <- file.path(validation_root, "val_report.Rmd") + validation_report_html <- "val_report.html" + validation_results <- file.path(validation_root, "results") + val_param_rds <- file.path(validation_results, "val_param.rds") + + stopifnot(dir.exists(validation_root)) + stopifnot(file.exists(validation_report_rmd)) + + stopifnot(dir.exists(validation_results)) + unlink(list.files(validation_results)) + + saveRDS( + list( + package = pkg_name, + tests = test_results, + version = pkg_version + ), + val_param_rds + ) + + rmarkdown::render( + input = validation_report_rmd, + params = list( + package = pkg_name, + tests = test_results, + version = pkg_version + ), + output_dir = validation_results, + 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 +}) diff --git a/inst/validation/specs.R b/inst/validation/specs.R new file mode 100644 index 0000000..42858b7 --- /dev/null +++ b/inst/validation/specs.R @@ -0,0 +1,25 @@ +# Use a list to declare the specs +# nolint start line_length_linter +specs_list <- list + +filter_general <- specs_list( + "filter_add_remove" = "dv.filter allows users to add or remove filter(s).", + "filter_ui_server" = "dv.filter contains a UI and server component.", + "filter_nrows" = "dv.filter displays the number of rows selected in the UI." +) + +filter_numeric <- specs_list( + "filter_numeric" = "dv.filter enables filtering of a numeric filter via a range slider.", + "filter_numeric_missing" = "dv.filter allows users to include or exclude missing values of a numeric filter." +) + +filter_categorical <- specs_list( + "filter_categorical" = "dv.filter enables filtering of a categorical filter via a dropdown menu", + "filter_categorical_missing" = "dv.filter allows users to include or exclude missing values of a categorical filter." +) + +specs <- c( + filter_general, + filter_numeric, + filter_categorical +) diff --git a/inst/validation/utils-validation.R b/inst/validation/utils-validation.R new file mode 100644 index 0000000..eeb9356 --- /dev/null +++ b/inst/validation/utils-validation.R @@ -0,0 +1,155 @@ +#' Setting up the validation + +if (!exists("package_name")) stop("package name must be in the environment when this script is sourced") + +#' How to link tests and specs + +if (FALSE) { + test_that( + vdoc[["add_spec"]]("my test description", specs$a_spec), + { + expect_true(TRUE) + } + ) +} +#' 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() +#' + +if (FALSE) { + test_that( + vdoc[["add_spec"]]("my test_description", c(specs$my$hier$spec, vdoc_specs$my$hier$other_spec)), + { + expect_true(TRUE) + } + ) +} + +#' Considerations: +#' - parse_spec uses deparse(substitute()). These spec_ids are later used to check if all requirements +#' are covered or not, therefore those calls cannot by substituted for: + +if (FALSE) { + my_spec <- specs$my$hier$spec + test_that(vdoc[["add_spec"]]("my test_description", my_spec), { + ... + }) + + test_that(vdoc[["add_spec"]]("my test_description", specs[["my"]][["hier"]][["spec"]]), { + ... + }) +} + +# In this case the substitute captures my_spec and cannot be used later. +# If you want to do this you must use the spec_id parameter where you pass a +# character vector with the ids. +# Notice that the ids in character form do no longer have the specs particle +# at the beginning, only the pathing of the spec is needed. + +if (FALSE) { + my_spec <- specs$my$hier$spec + test_that(vdoc$parse_spec(my_spec, "my test_description", spec_id = c("my$hier$spec")), { + ... + }) +} + +# Validation code +# nolint start cyclocomp_linter +local({ + specs <- source( + system.file("validation", "specs.R", package = package_name, mustWork = TRUE), + local = TRUE + )[["value"]] + recursive_ids <- function(x, parent = character(0)) { + if (!is.list(x)) { + return(parent) + } + unlist(mapply(recursive_ids, + x, + paste(parent, names(x), + sep = if (identical(parent, character(0))) "" else "$" + ), + SIMPLIFY = FALSE, USE.NAMES = FALSE + )) + } + + recursive_ids <- function(x, parent = character(0)) { + if (!is.list(x)) { + return(parent) + } + unlist(mapply(recursive_ids, x, + paste(parent, names(x), + sep = if (identical(parent, character(0))) "" else "$" + ), + SIMPLIFY = FALSE, USE.NAMES = FALSE + )) + } + + + spec_id_list <- recursive_ids(specs) + + list( + specs = specs, + spec_id_list = spec_id_list, + add_spec = function(desc, spec, spec_id) { + if (missing(spec_id)) { + if (!is.character(spec) || length(spec) == 0) stop("spec must be a non-empty character vector") + s_spec <- substitute(spec) + if (s_spec[[1]] == "c") { + spec_id <- sapply(s_spec[2:length(s_spec)], identity) + } else { + spec_id <- list(s_spec) # Otherwise the posterior vapply iterates over the expression + } + + spec_id_chr <- vapply(spec_id, function(x) { + sub("^[^$]*\\$", "", deparse(x)) + }, FUN.VALUE = character(1)) + + if (!all(spec_id_chr %in% spec_id_list)) { + stop("At least one spec is not declared in the spec list") + } # This should be covered by pack of constants but just in case + } else { + spec_id_chr <- spec_id + } + paste0(desc, "__spec_ids{", paste0(spec_id_chr, collapse = ";"), "}") + }, + 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 diff --git a/inst/validation/val_report.Rmd b/inst/validation/val_report.Rmd new file mode 100644 index 0000000..26a97e9 --- /dev/null +++ b/inst/validation/val_report.Rmd @@ -0,0 +1,17 @@ +--- +title: "Quality Control" +output: + html_document: + toc: true + toc_depth: 2 + code_folding: hide +toc-title: "----\nIndex" + +params: + package: NULL + tests: NULL + version: NULL +--- + +```{r, child = "val_report_child.Rmd"} +``` diff --git a/inst/validation/val_report_child.Rmd b/inst/validation/val_report_child.Rmd new file mode 100644 index 0000000..bf7f1bc --- /dev/null +++ b/inst/validation/val_report_child.Rmd @@ -0,0 +1,209 @@ + + + +```{r setup, message = FALSE} +# Import vdoc functions ---- +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"))) +suppressPackageStartupMessages(stopifnot(requireNamespace("devtools"))) + +# Parse tests ---- + +tests <- as.data.frame(params[["tests"]]) +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)) +tests[["spec_paste"]] <- vapply(tests[["spec"]], function(x) paste(x, collapse = "\n"), FUN.VALUE = character(1)) +tests[["desc"]] <- paste0("(#", seq_len(nrow(tests)), "): ", tests[["test"]]) +tests[["with_spec"]] <- vapply(tests[["spec_id"]], Negate(is.null), FUN.VALUE = logical(1)) + +spec_tests <- tests[tests[["with_spec"]], ] +no_spec_tests <- tests[!tests[["with_spec"]], ] + +declared_spec <- vdoc[["spec_id_list"]] +tested_spec <- unique(unlist(tests[["spec_id"]])) +uncovered_spec <- declared_spec[!declared_spec %in% tested_spec] +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"]] | spec_tests[["error"]] +mask_skipped <- !!spec_tests[["skipped"]] +mask_declared <- spec_tests[["are_declared"]] +n_pass_dec <- sum(!mask_failed & !mask_skipped & mask_declared) +n_fail_dec <- sum(mask_failed & mask_declared) +n_skip_dec <- sum(mask_skipped & mask_declared) +n_uncov <- length(uncovered_spec) +n_undec <- sum(!mask_declared) + +render_spec_table <- function(t) { + t <- t[trac_matrix_col] + colnames(t) <- names(trac_matrix_col) + t <- t[order(t[["Spec ID"]]), ] + DT::datatable(t, options = list(dom = "ltp"), filter = list(position = "top")) +} + +data_frame_by_row <- function(colnames, data) { + n <- length(data) + n_cols <- length(colnames) + stopifnot(n %% n_cols == 0) + columns <- vector("list", length = n_cols) + for (i in 1:n_cols) columns[[i]] <- unlist(data[seq(i, n, n_cols)]) + do.call(data.frame, setNames(columns, colnames)) +} + +# Select columns to be included in the tables ---- +trac_matrix_col <- c("Spec ID" = "spec_id_paste", "Spec" = "spec_paste", "Test Desc" = "desc", "File" = "file") + +# Check that validation passes and set title ---- +VALIDATION_PASSED <- n_fail_dec == 0 && n_uncov == 0 && n_undec == 0 && n_uncov == 0 # nolint + +result_symbol <- if (VALIDATION_PASSED) "\U02705" else "\U274C" +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: + +- **Specifications (specs):** These can be attached to every test that the user adds. +- **Traceability matrix:** Contains test cases with passed, failed, or skipped expectations. +- **Uncovered or undeclared specs** +- **Session Info and System Configuration** + +::: {.infobox .warning} +Please be advised that the QC report generated for this module does not imply validation according to any other GxP criteria. +The QC report only satisfies our internally developed quality checks for non-GxP criteria. +For clinical reporting purposes, it is essential to note that any outputs generated using this module must be checked and verified within a validated system that adheres to the appropriate GxP guidelines. +::: + +---- +# Traceability matrix + +In this traceability matrix only those tests that point to an specification are included. + +Test cases can contain several expectations a test is considered: + + - **passed** if all expectations in the test pass. + + - **failed** if at least one expectation in the test fails. + + - **skipped** if at least one expectation in the test is skipped. + +A test can be both **failed** and **skipped**. + +## Summary + +```{r summary} +data_frame_by_row( + colnames = c("Spec Exists", "Test", "Count", "color"), + data = list( + "Yes", "Pass", n_pass_dec, "white", + "Yes", "Failed", n_fail_dec, if (n_fail_dec > 0) "red" else "green", + "Yes", "Skipped", n_skip_dec, if (n_skip_dec > 0) "red" else "green", + "Yes", "No Test", n_uncov, if (n_uncov > 0) "red" else "green", + "No", "NA", n_undec, if (n_undec > 0) "red" else "green" + ) +) |> + DT::datatable( + rownames = FALSE, + options = list(columnDefs = list(list(visible = FALSE, targets = c(3))), dom = "tp"), + filter = list(position = "top") + ) |> + DT::formatStyle( + c("Count"), + valueColumns = "color", + backgroundColor = DT::JS("value") + ) +``` + +## Passed tests + +```{r passed_test} +render_spec_table(spec_tests[!mask_failed & !mask_skipped & mask_declared, ]) +``` + +## Failed tests + +```{r failed_test} +render_spec_table(spec_tests[mask_failed & mask_declared, ]) +``` + +## Skipped tests + +```{r skipped_test} +render_spec_table(spec_tests[mask_skipped & mask_declared, ]) +``` + +## Uncovered specifications + +```{r uncovered_spec, echo=FALSE} +data.frame("Uncovered Specifications" = uncovered_spec) |> + DT::datatable( + options = list(dom = "ltp"), + filter = list(position = "top") + ) +``` + +## Undeclared specifications + +This should always be empty, as non existant specs are controlled during test execution. + +```{r undeclared_spec, echo=FALSE, results = "asis"} +render_spec_table(spec_tests[!mask_declared, ]) +``` + +# Session Info and System Configuration + +```{r system_conf} +devtools::session_info() +``` + +# List of specifications +```{r spec_list} +j <- vapply( + vdoc[["spec_id_list"]], + function(x) { + eval( + str2expression( + paste0("vdoc[[\"specs\"]]$", x) + ) + ) + }, + FUN.VALUE = character(1) +) |> + gsub("\n", "
", x = _, fixed = TRUE) + +data.frame(spec_id = names(j), spec = j) |> + DT::datatable( + rownames = FALSE, + options = list( + dom = "ltp" + ), + filter = list(position = "top"), + escape = FALSE + ) +``` diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R new file mode 100644 index 0000000..fb131cf --- /dev/null +++ b/tests/testthat/setup.R @@ -0,0 +1,11 @@ +# 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) diff --git a/tests/testthat/test-add-remove-filter.R b/tests/testthat/test-add-remove-filter.R index d800885..1f029be 100644 --- a/tests/testthat/test-add-remove-filter.R +++ b/tests/testthat/test-add-remove-filter.R @@ -1,4 +1,5 @@ -test_that("The data filter module enables users to add or remove a filter variable.", { +test_that("The data filter module enables users to add or remove a filter variable." %>% + vdoc[["add_spec"]](specs$filter_add_remove), { app <- shinytest2::AppDriver$new(app_dir = "shiny/adam/") app$wait_for_idle(1000) diff --git a/tests/testthat/test-categorical-filter-missing.R b/tests/testthat/test-categorical-filter-missing.R index 01c7b63..b96ae77 100644 --- a/tests/testthat/test-categorical-filter-missing.R +++ b/tests/testthat/test-categorical-filter-missing.R @@ -1,4 +1,6 @@ -test_that("For a chosen categorical filter with missing values, an item signifying missingness is incorporated at the top of the filter dropdown menu. By default, all missing values are included.", { # nolint +test_that("For a chosen categorical filter with missing values, an item signifying missingness is incorporated at the + top of the filter dropdown menu. By default, all missing values are included." %>% + vdoc[["add_spec"]](specs$filter_categorical_missing), { # nolint adsl <- pharmaverseadam::adsl expect_true(sum(is.na(adsl$EOSSTT)) > 0) diff --git a/tests/testthat/test-categorical-filter.R b/tests/testthat/test-categorical-filter.R index 34e5b60..5ae1ede 100644 --- a/tests/testthat/test-categorical-filter.R +++ b/tests/testthat/test-categorical-filter.R @@ -1,4 +1,6 @@ -test_that("For a chosen categorical fitler, the data filter module provides users with the capability to deselect all categories.", { # nolint +test_that("For a chosen categorical fitler, the data filter module provides users with the capability to + deselect all categories." %>% + vdoc[["add_spec"]](specs$filter_categorical), { # nolint app <- shinytest2::AppDriver$new(app_dir = "shiny/adam/") app$set_inputs(`data_filter-vars` = "SEX") diff --git a/tests/testthat/test-filter-ui-server.R b/tests/testthat/test-filter-ui-server.R index da33f27..30897fc 100644 --- a/tests/testthat/test-filter-ui-server.R +++ b/tests/testthat/test-filter-ui-server.R @@ -7,7 +7,9 @@ get_id <- function(html, name) { adsl <- pharmaverseadam::adsl test_that( - "The UI of the data filter module includes selection and input controls, allowing users to establish and modify filtering criteria.", # nolint + "The UI of the data filter module includes selection and input controls, allowing users to establish and + modify filtering criteria." %>% + vdoc[["add_spec"]](specs$filter_ui_server), # nolint { id <- "data_filter" ns <- shiny::NS(id) @@ -21,7 +23,9 @@ test_that( ) test_that( - "The server component of the data filter module generates a logical vector, signifying if a row of data should be selected (TRUE) or disregarded (FALSE).", # nolint + "The server component of the data filter module generates a logical vector, signifying if a row of data should be + selected (TRUE) or disregarded (FALSE)." %>% + vdoc[["add_spec"]](specs$filter_ui_server), # nolint { data <- shiny::reactive(adsl) shiny::testServer( @@ -35,7 +39,8 @@ test_that( } ) -test_that("The data filter module generates an error if the input data is not reactive or metareactive.", { +test_that("The data filter module generates an error if the input data is not reactive or metareactive." %>% + vdoc[["add_spec"]](specs$filter_ui_server), { shiny::testServer( data_filter_server, args = list(data = adsl) # non-reactive data @@ -44,7 +49,8 @@ test_that("The data filter module generates an error if the input data is not re ) }) -test_that("The data filter module generates an error if the input data is NULL.", { +test_that("The data filter module generates an error if the input data is NULL." %>% + vdoc[["add_spec"]](specs$filter_ui_server), { shiny::testServer( data_filter_server, args = list(data = shiny::reactive(NULL)), diff --git a/tests/testthat/test-filtered-rows.R b/tests/testthat/test-filtered-nrows.R similarity index 82% rename from tests/testthat/test-filtered-rows.R rename to tests/testthat/test-filtered-nrows.R index f185bad..100f932 100644 --- a/tests/testthat/test-filtered-rows.R +++ b/tests/testthat/test-filtered-nrows.R @@ -1,4 +1,6 @@ -test_that("The data filter module presents a text output, signifying the number of entries selected in the filtered data.", { # nolint +test_that("The data filter module presents a text output, signifying the number of entries selected in + the filtered data." %>% + vdoc[["add_spec"]](specs$filter_nrows), { # nolint adsl <- pharmaverseadam::adsl n <- nrow(adsl) diff --git a/tests/testthat/test-numeric-filter-missing.R b/tests/testthat/test-numeric-filter-missing.R index 2711d0c..57c6503 100644 --- a/tests/testthat/test-numeric-filter-missing.R +++ b/tests/testthat/test-numeric-filter-missing.R @@ -1,4 +1,6 @@ -test_that("For a chosen numeric filter with missing values, the data filter module includes a checkbox enabling users to either incorporate or omit missing values. By default, all missing values are included.", { # nolint +test_that("For a chosen numeric filter with missing values, the data filter module includes a checkbox enabling + users to either incorporate or omit missing values. By default, all missing values are included." %>% + vdoc[["add_spec"]](specs$filter_numeric_missing), { # nolint adsl <- pharmaverseadam::adsl expect_true(sum(is.na(adsl$EOSDT)) > 0) diff --git a/tests/testthat/test-numeric-filter.R b/tests/testthat/test-numeric-filter.R index c4719f9..3f999fa 100644 --- a/tests/testthat/test-numeric-filter.R +++ b/tests/testthat/test-numeric-filter.R @@ -1,4 +1,6 @@ -test_that("For a chosen numeric filter, the data filter module provides a range slider and displays a histogram of the numeric variable.", { # nolint +test_that("For a chosen numeric filter, the data filter module provides a range slider and displays a + histogram of the numeric variable." %>% + vdoc[["add_spec"]](specs$filter_numeric), { # nolint adsl <- pharmaverseadam::adsl app <- shinytest2::AppDriver$new(app_dir = "shiny/adam/") diff --git a/tests/testthat/test-remove-all-filters.R b/tests/testthat/test-remove-all-filters.R index 37007c8..491634f 100644 --- a/tests/testthat/test-remove-all-filters.R +++ b/tests/testthat/test-remove-all-filters.R @@ -1,4 +1,5 @@ -test_that("The data filter module allow users to remove all chosen filters simultaneously.", { +test_that("The data filter module allows users to remove all chosen filters simultaneously." %>% + vdoc[["add_spec"]](specs$filter_add_remove), { app <- shinytest2::AppDriver$new(app_dir = "shiny/adam/") app$set_inputs(`data_filter-vars` = "AGE")