Merge pull request #16 from zsigmas/fix_test_qc_pr

fix test so they can run on the installed package

README.md

@@ -1,6 +1,7 @@
 # dv.templates <img src="man/figures/repo-logo.svg" align="right" height="138" alt="" />
 
 [![Build status](https://github.com/boehringer-ingelheim/dv.templates/actions/workflows/check.yml/badge.svg)](https://github.com/boehringer-ingelheim/dv.templates/actions/workflows/check.yml?query=workflow)
+[![Build status](https://github.com/boehringer-ingelheim/dv.templates/actions/workflows/test.yml/badge.svg)](https://github.com/boehringer-ingelheim/dv.templates/actions/workflows/test.yml?query=workflow)
 [![Build status](https://github.com/boehringer-ingelheim/dv.templates/actions/workflows/gitleaks.yml/badge.svg)](https://github.com/boehringer-ingelheim/dv.templates/actions/workflows/gitleaks.yml?query=workflow)
 [![Build status](https://github.com/boehringer-ingelheim/dv.templates/actions/workflows/lintr.yml/badge.svg)](https://github.com/boehringer-ingelheim/dv.templates/actions/workflows/lintr.yml?query=workflow)
 [![Build status](https://github.com/boehringer-ingelheim/dv.templates/actions/workflows/pkgdown.yml/badge.svg)](https://github.com/boehringer-ingelheim/dv.templates/actions/workflows/pkgdown.yml?query=workflow)

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
+})

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

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.templates"
+
+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)
+            )
+          }
+        }
+      )
+    }
+  )
+})

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"}
+```