diff --git a/.lintr b/.lintr new file mode 100644 index 0000000..89fa036 --- /dev/null +++ b/.lintr @@ -0,0 +1,7 @@ +linters: linters_with_defaults( + line_length_linter(120), + object_usage_linter = NULL, + indentation_linter = NULL, + trailing_whitespace_linter = NULL + ) + diff --git a/_pkgdown.yml b/_pkgdown.yml index dbff54c..d0514e8 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -2,7 +2,13 @@ template: bootstrap: 5 navbar: - type: inverse + type: inverted + structure: + left: [intro, reference, articles, tutorials, news, qc] + components: + qc: + text: Quality Control + href: articles/qc.html home: title: Build complex Shiny apps in a simple way @@ -53,3 +59,8 @@ articles: desc: Common errors contents: - dv-manager + +- title: Quality Control + desc: Quality Control + contents: + - qc 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..e66e4c0 --- /dev/null +++ b/inst/validation/run_validation.R @@ -0,0 +1,40 @@ +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..4903b4f --- /dev/null +++ b/inst/validation/specs.R @@ -0,0 +1,7 @@ +# Use a list to declare the specs + +specs_list <- list + +example_spec <- specs_list( + a_spec = "spec" +) diff --git a/inst/validation/utils-validation.R b/inst/validation/utils-validation.R new file mode 100644 index 0000000..8504b9c --- /dev/null +++ b/inst/validation/utils-validation.R @@ -0,0 +1,148 @@ +#' 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) +} + +#' 2. For those tests that cover an specific spec + +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 point 1 + +#' 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$parse_spec(my_spec, "my test_description"), { + ... + }) +} + +# 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 + +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 + } + structure(desc, spec_id = spec_id_chr, spec = spec) + }, + 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) + ) + } + } + ) + } + ) +}) 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..38e631f --- /dev/null +++ b/inst/validation/val_report_child.Rmd @@ -0,0 +1,205 @@ + + + +```{r setup, message = FALSE} +# Import vdoc functions ---- +vdoc <- source( + system.file("validation", "utils-validation.R", package = params[["package"]], mustWork = TRUE), + 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[["result"]]) +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"]] +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` + +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/test-utils_check.R b/tests/testthat/test-utils_check.R index ab76f65..e010542 100644 --- a/tests/testthat/test-utils_check.R +++ b/tests/testthat/test-utils_check.R @@ -40,7 +40,7 @@ test_that( ) test_that( - vdoc[["add_spec"]](specs[["a_spec"]], "my test description"), + vdoc[["add_spec"]]("my test description", specs$a_spec), { expect_true(TRUE) } diff --git a/vignettes/qc.Rmd b/vignettes/qc.Rmd new file mode 100644 index 0000000..87bb735 --- /dev/null +++ b/vignettes/qc.Rmd @@ -0,0 +1,32 @@ +--- +title: "Quality Control" +output: + rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Quality Control} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + echo = FALSE +) +``` + +```{r, params, echo = FALSE, include = FALSE} +val_param_rds <- "../inst/validation/results/val_param.rds" +val_param_rds_exists <- file.exists(val_param_rds) +if (file.exists(val_param_rds)) params <- readRDS(val_param_rds) +``` + +```{r, results = "asis", echo = FALSE} +if (val_param_rds_exists) { + res <- knitr::knit_child("../inst/validation/val_report_child.Rmd", quiet = TRUE, envir = environment()) + cat(res, sep = "\n") +} else { + "No quality control results found" +} +```