Merge pull request #6 from Boehringer-Ingelheim/rc

Add missing qc.Rmd

_pkgdown.yml

@@ -1,10 +1,20 @@
----
-url: https://Boehringer-Ingelheim.github.io/dv.filter
-
 template:
   bootstrap: 5
 
 navbar:
-  right:
-    - icon: fa-github
+  type: inverse
+  structure:
+    left: [intro, reference, articles, tutorials, news, qc]
+  components:
+    qc:
+      text: Quality Control
+      href: articles/qc.html
+home:
+  title: dv.filter
+  links:
+    - text: Browse source code
       href: https://github.com/Boehringer-Ingelheim/dv.filter
+
+repo:
+  url:
+    home: https://github.com/Boehringer-Ingelheim/dv.filter

inst/validation/run_validation.R

@@ -5,19 +5,19 @@ 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,
@@ -26,7 +26,7 @@ local({
     ),
     val_param_rds
   )
-  
+
   rmarkdown::render(
     input = validation_report_rmd,
     params = list(
@@ -37,7 +37,7 @@ local({
     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

@@ -67,29 +67,29 @@ local({
       return(parent)
     }
     unlist(mapply(recursive_ids,
-                  x,
-                  paste(parent, names(x),
-                        sep = if (identical(parent, character(0))) "" else "$"
-                  ),
-                  SIMPLIFY = FALSE, USE.NAMES = FALSE
+      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
+      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,
@@ -102,11 +102,11 @@ local({
         } 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
@@ -117,39 +117,39 @@ local({
     },
     get_spec = function(test, specs) {
       spec_ids <- utils::strcapture(
-        pattern = "__spec_ids\\{(.*)\\}",
-        x = test,
-        proto = list(spec = character())
-      )[["spec"]]
+            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
-          )
+        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
-          )          
+          spec_id = NULL,
+          spec = NULL
+        )          
         }        
       }      
       specs_and_id
     }
-    
+
 
   )
 })
 
-# nolint end cyclocomp_linter
+# nolint end cyclocomp_linter

vignettes/dv_filter.Rmd

@@ -0,0 +1,48 @@
+---
+title: "Getting Started"
+output: rmarkdown::html_vignette
+vignette: >
+  %\VignetteIndexEntry{Getting Started}
+  %\VignetteEngine{knitr::rmarkdown}
+  %\VignetteEncoding{UTF-8}
+---
+
+```{r setup, include = FALSE}
+knitr::opts_chunk$set(
+  eval = FALSE,
+  collapse = TRUE,
+  comment = "#>"
+)
+```
+
+Run the code below to launch a demo app.
+
+```{r, eval=FALSE}
+data <- shiny::reactive(pharmaverseadam::adsl)
+
+ui <- shiny::fluidPage(
+  shiny::sidebarLayout(
+    shiny::sidebarPanel(
+      dv.filter::data_filter_ui("data_filter")
+    ),
+    shiny::mainPanel(
+      shiny::dataTableOutput("data_table")
+    )
+  )
+)
+
+server <- function(input, output, session) {
+  selected <- dv.filter::data_filter_server("data_filter", data = data)
+
+  output$data_table <- shiny::renderDataTable({
+    data()[selected(), ]
+  })
+}
+
+shiny::shinyApp(ui, server)
+```
+
+Inside the app, `dv.filter::data_filter_ui()` and `dv.filter::data_filter_server()` 
+are called to invoke the module.  
+
+![](../man/figures/demo.png){width=100%}

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