Merge pull request #1 from Boehringer-Ingelheim/rc

Rc version 1.0.3

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

inst/validation/utils-validation.R

@@ -1,40 +1,26 @@
 #' 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.edish"
 
-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"]](specs$my$hier$spec, "my test description"),
+    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()
 #'
 
 if (FALSE) {
   test_that(
-    vdoc[["add_spec"]](c(specs$my$hier$spec, vdoc_specs$my$hier$other_spec), "my test_description"),
+    vdoc[["add_spec"]]("my test_description", c(specs$my$hier$spec, vdoc_specs$my$hier$other_spec)),
     {
       expect_true(TRUE)
     }
@@ -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.Rmd

@@ -1,4 +1,5 @@
 ---
+title: "Quality Control"
 output:
   html_document:
     toc: true