Merge pull request #7 from Boehringer-Ingelheim/rc/4.0.0

Rc/4.0.0

Author: mattkorb

.gitignore

@@ -1,6 +1,14 @@
-.Rproj.user/
-README.html
+.Rproj.user
 .Rhistory
-.lintr
+.RData
+.Ruserdata
+.directory
+.Renviron
+.Rprofile
 docs/
-
+README.html
+vignettes/*\.html
+vignettes/*\.R
+inst/validation/results/val_param.rds
+inst/validation/results/val_report.html
+tests/testthat/app/shiny_bookmarks

.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 @@
 Package: dv.listings
 Type: Package
 Title: Data listings module
-Version: 3.1.0
+Version: 4.0.0
 Authors@R: 
     c(
       person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")),

NEWS.md

@@ -1,4 +1,4 @@
-# dv.listings 3.1.0
+# dv.listings 4.0.0
 
 Package was renamed to dv.listings.
 

_pkgdown.yml

@@ -3,7 +3,12 @@ template:
 
 navbar:
   type: inverse
-
+  structure:
+    left: [intro, reference, articles, tutorials, news, qc]
+  components:
+    qc:
+      text: Quality Control
+      href: articles/qc.html
 home:
   title: dv.listings
   links:

inst/validation/results/.gitempty

@@ -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/run_validation.R

@@ -0,0 +1,28 @@
+# Use a list to declare the specs
+# nolint start line_length_linter
+specs_list <- list
+
+listing <- specs_list(
+  "display_listing" = "dv.listings displays a dataset as listing",
+  "listing_selection" = "dv.listings includes a dropdown menu to select which dataset to be shown.",
+  "listings_label" = "dv.listings displays the label of a dataset if available. The label is concatenated to the dataset name and the resulting strings are provided as choices in the module's dropdown menu.",
+  "column_selection" = "dv.listings includes a dropdown menu to select the columns from the selected listing to be shown and arrange their order.",
+  "column_label" = "dv.listings displays extended column headers consisting of the variable name pasted together with its label, if available. These extended column headers replace the original variable names in the column dropdown menu.",
+  "sorting_columns" = "dv.listings includes sorting functionality for each of the column.",
+  "restore_row_order" = "dv.listings includes a button to restore the row order of a listing to the state as it is in the original data.",
+  "default_vars" = "If pre-specifications for default columns are available, dv.listings will display them at app launch for the respective listing. If not, dv.listings will show the first six columns of the listing - or all columns, in case the number of columns is less than six.",
+  "retain_last_selection" = "dv.listings can remember and retain the last column selections after switching listings during the current session. It also restores the remembered selections for all listings after bookmarking.",
+  "bookmarking" = "The module is compatible with the bookmarking feature of the dv.manager."
+)
+export <- specs_list(
+  "export" = "dv.listings includes a button to export the listing(s). A click to the button envokes a pop-up to appear that allows the user to decide whether the download should only contain the displayed listing or all available listings, provide a file name (defaulted to the dataset name), and select from available file types.",
+  "export_active_listing" = "For downloading only the currently active listing, the listing will be saved as it is displayed, either in .xlsx or .pdf format. In case filters were applied, the downloaded output will only contain the filtered data.",
+  "export_excel" = "For downloading all listings, the tables can be saved in .xlsx format only without considering local filters. Each listing will be placed in an individual worksheet within the file.",
+  "export_pdf" = "For downloading in .pdf format, users can select one or multiple reference column(s), which will be displayed on all document pages."
+)
+# nolint end line_length_linter
+
+specs <- c(
+  listing,
+  export
+)

inst/validation/specs.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/utils-validation.R

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