Merge pull request #5 from Boehringer-Ingelheim/rc

GitHub release with QC report

.lintr

@@ -0,0 +1,6 @@
+linters: linters_with_defaults(
+  line_length_linter(120),
+  object_usage_linter = NULL,
+  indentation_linter = NULL,
+  trailing_whitespace_linter = NULL
+  )

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 = "[email protected]", role = c("aut", "cre")),

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

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

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

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