options for strict tests; few enhancements

DESCRIPTION

@@ -40,17 +40,18 @@ Suggests:
     knitr (>= 1.42),
     rmarkdown (>= 2.19),
     teal.code (>= 0.5.0),
-    testthat (>= 3.1.5)
+    testthat (>= 3.1.5),
+    withr (>= 2.0.0)
 VignetteBuilder:
     knitr
 RdMacros:
     lifecycle
 Config/Needs/verdepcheck: mllg/checkmate, tidyverse/dplyr,
-    r-lib/lifecycle, daroczig/logger, r-lib/rlang, rstudio/rmarkdown,
+    r-lib/lifecycle, daroczig/logger, r-lib/rlang,
     rstudio/shiny, daattali/shinyjs, rstudio/shinyvalidate,
     insightsengineering/teal.data, insightsengineering/teal.logger,
     insightsengineering/teal.widgets, tidyverse/tidyr, r-lib/tidyselect,
-    yihui/knitr, insightsengineering/teal.code, r-lib/testthat
+    yihui/knitr, rstudio/rmarkdown, insightsengineering/teal.code, r-lib/testthat, r-lib/withr
 Config/Needs/website: insightsengineering/nesttemplate
 Encoding: UTF-8
 Language: en-US

R/choices_labeled.R

@@ -26,8 +26,8 @@
 #' library(shiny)
 #' library(teal.data)
 #'
-#' ADSL <- teal.transform::rADSL
-#' ADTTE <- teal.transform::rADTTE
+#' ADSL <- rADSL
+#' ADTTE <- rADTTE
 #'
 #' choices1 <- choices_labeled(names(ADSL), col_labels(ADSL, fill = FALSE))
 #' choices2 <- choices_labeled(ADTTE$PARAMCD, ADTTE$PARAM)
@@ -152,7 +152,7 @@ choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
 #' @examples
 #' library(teal.data)
 #'
-#' ADRS <- teal.transform::rADRS
+#' ADRS <- rADRS
 #' variable_choices(ADRS)
 #' variable_choices(ADRS, subset = c("PARAM", "PARAMCD"))
 #' variable_choices(ADRS, subset = c("", "PARAM", "PARAMCD"))
@@ -267,7 +267,7 @@ variable_choices.data.frame <- function(data, subset = NULL, fill = TRUE, key =
 #' @return named character vector or `delayed_data` object.
 #'
 #' @examples
-#' ADRS <- teal.transform::rADRS
+#' ADRS <- rADRS
 #' value_choices(ADRS, "PARAMCD", "PARAM", subset = c("BESRSPI", "INVET"))
 #' value_choices(ADRS, c("PARAMCD", "ARMCD"), c("PARAM", "ARM"))
 #' value_choices(ADRS, c("PARAMCD", "ARMCD"), c("PARAM", "ARM"),

R/choices_selected.R

@@ -50,7 +50,7 @@ no_select_keyword <- "-- no selection --"
 #'   selected = "C"
 #' )
 #'
-#' ADSL <- teal.transform::rADSL
+#' ADSL <- rADSL
 #' choices_selected(variable_choices(ADSL), "SEX")
 #'
 #' # How to select nothing

R/data_extract_module.R

@@ -119,7 +119,6 @@ cond_data_extract_single_ui <- function(ns, single_data_extract_spec) {
 #'     )
 #'   )
 #' )
-#'
 #' @export
 #'
 data_extract_ui <- function(id, label, data_extract_spec, is_single_dataset = FALSE) {
@@ -391,7 +390,6 @@ check_data_extract_spec_react <- function(datasets, data_extract) {
 #' if (interactive()) {
 #'   shinyApp(ui, server)
 #' }
-#'
 #' @export
 #'
 data_extract_srv <- function(id, datasets, data_extract_spec, ...) {
@@ -635,11 +633,6 @@ data_extract_srv.list <- function(id,
 #' )
 #'
 #' server <- function(input, output, session) {
-#'   exactly_2_validation <- function(msg) {
-#'     ~ if (length(.) != 2) msg
-#'   }
-#'
-#'
 #'   selector_list <- data_extract_multiple_srv(
 #'     list(x_var = iris_select, species_var = iris_filter),
 #'     datasets = data_list,
@@ -649,7 +642,7 @@ data_extract_srv.list <- function(id,
 #'     filter_validation_rule = list(
 #'       species_var = compose_rules(
 #'         sv_required("Exactly 2 Species must be chosen"),
-#'         exactly_2_validation("Exactly 2 Species must be chosen")
+#'         function(x) if (length(x) != 2) "Exactly 2 Species must be chosen"
 #'       )
 #'     )
 #'   )

R/data_extract_spec.R

@@ -81,7 +81,6 @@
 #'   dataname = "ADSL",
 #'   filter = dynamic_filter
 #' )
-#'
 #' @export
 #'
 data_extract_spec <- function(dataname, select = NULL, filter = NULL, reshape = FALSE) {

R/format_data_extract.R

@@ -11,6 +11,7 @@
 #'
 #' @examples
 #' library(shiny)
+#'
 #' simple_des <- data_extract_spec(
 #'   dataname = "iris",
 #'   filter = filter_spec(vars = "Petal.Length", choices = c("1.4", "1.5")),

R/resolve.R

@@ -60,7 +60,7 @@ resolve.delayed_choices_selected <- function(x, datasets, keys) {
   x$choices <- resolve(x$choices, datasets = datasets, keys)
 
   if (!all(x$selected %in% x$choices)) {
-    logger::log_warn(paste(
+    warning(paste(
       "Removing",
       paste(x$selected[which(!x$selected %in% x$choices)]),
       "from 'selected' as not in 'choices' when resolving delayed choices_selected"

R/resolve_delayed.R

@@ -11,7 +11,8 @@
 #'
 #' @examples
 #' library(shiny)
-#' ADSL <- teal.transform::rADSL
+#'
+#' ADSL <- rADSL
 #' isolate({
 #'   data_list <- list(ADSL = reactive(ADSL))
 #'

R/utils.R

@@ -107,18 +107,14 @@ extract_choices_labels <- function(choices, values = NULL) {
 #' )
 #'
 #' server <- function(input, output, session) {
-#'   exactly_2_validation <- function() {
-#'     ~ if (length(.) != 2) "Exactly 2 'Y' column variables must be chosen"
-#'   }
-#'
 #'   selector_list <- data_extract_multiple_srv(
 #'     list(x_var = iris_extract, y_var = iris_extract, col_var = iris_extract),
 #'     datasets = data_list,
 #'     select_validation_rule = list(
 #'       x_var = sv_required("Please select an X column"),
 #'       y_var = compose_rules(
 #'         sv_required("Exactly 2 'Y' column variables must be chosen"),
-#'         exactly_2_validation()
+#'         function(x) if (length(x) != 2) "Exactly 2 'Y' column variables must be chosen"
 #'       )
 #'     )
 #'   )
@@ -147,7 +143,6 @@ extract_choices_labels <- function(choices, values = NULL) {
 #' if (interactive()) {
 #'   shinyApp(ui, server)
 #' }
-#'
 #' @export
 #'
 compose_and_enable_validators <- function(iv, selector_list, validator_names = NULL) {

README.md

@@ -54,7 +54,7 @@ Below is a small example usage:
 
 ```r
 library(teal.transform)
-ADSL <- teal.transform::rADSL
+ADSL <- rADSL
 
 adsl_extract <- data_extract_spec(
   dataname = "ADSL",

tests/testthat/setup-logger.R

@@ -0,0 +1 @@
+logger::log_appender(function(...) {}, namespace = "teal.transform")

tests/testthat/setup-options.R

@@ -0,0 +1,20 @@
+# `opts_partial_match_old` is left for exclusions due to partial matching in dependent packages (i.e. not fixable here)
+# it might happen that it is not used right now, but it is left for possible future use
+# use with: `withr::with_options(opts_partial_match_old, { ... })` inside the test
+opts_partial_match_old <- list(
+  warnPartialMatchDollar = getOption("warnPartialMatchDollar"),
+  warnPartialMatchArgs = getOption("warnPartialMatchArgs"),
+  warnPartialMatchAttr = getOption("warnPartialMatchAttr")
+)
+opts_partial_match_new <- list(
+  warnPartialMatchDollar = TRUE,
+  warnPartialMatchArgs = TRUE,
+  warnPartialMatchAttr = TRUE
+)
+
+if (isFALSE(getFromNamespace("on_cran", "testthat")()) && requireNamespace("withr", quietly = TRUE)) {
+  withr::local_options(
+    opts_partial_match_new,
+    .local_envir = testthat::teardown_env()
+  )
+}

tests/testthat/test-data_extract_module.R

@@ -1,5 +1,5 @@
-ADLB <- teal.transform::rADLB
-ADTTE <- teal.transform::rADTTE
+ADLB <- rADLB
+ADTTE <- rADTTE
 
 testthat::test_that("Single filter", {
   data_extract <- data_extract_spec(

tests/testthat/test-data_extract_multiple_srv.R

@@ -1,6 +1,6 @@
-ADSL <- teal.transform::rADSL
-ADLB <- teal.transform::rADLB
-ADTTE <- teal.transform::rADTTE
+ADSL <- rADSL
+ADLB <- rADLB
+ADTTE <- rADTTE
 
 data_list <- list(ADSL = reactive(ADSL), ADTTE = reactive(ADTTE), ADLB = reactive(ADLB))
 join_keys <- teal.data::default_cdisc_join_keys[c("ADSL", "ADTTE", "ADLB")]

tests/testthat/test-data_extract_spec.R

@@ -1,5 +1,5 @@
-ADSL <- teal.transform::rADSL
-ADTTE <- teal.transform::rADTTE
+ADSL <- rADSL
+ADTTE <- rADTTE
 data_list <- list(ADSL = reactive(ADSL), ADTTE = reactive(ADTTE))
 key_list <- list(ADSL = c("STUDYID", "USUBJID"), ADTTE = c("STUDYID", "USUBJID", "PARAMCD"))
 

tests/testthat/test-data_extract_srv.R

@@ -1,6 +1,6 @@
-ADSL <- teal.transform::rADSL
-ADLB <- teal.transform::rADLB
-ADTTE <- teal.transform::rADTTE
+ADSL <- rADSL
+ADLB <- rADLB
+ADTTE <- rADTTE
 
 data_list <- list(ADSL = reactive(ADSL), ADTTE = reactive(ADTTE), ADLB = reactive(ADLB))
 join_keys <- teal.data::default_cdisc_join_keys[c("ADSL", "ADTTE", "ADLB")]
@@ -493,7 +493,7 @@ testthat::test_that("select validation accepts function as validator", {
       datasets = data_list,
       data_extract_spec = adsl_extract,
       join_keys = join_keys,
-      select_validation_rule = ~ if (nchar(.) == 0) "error"
+      select_validation_rule = function(x) if (nchar(x) == 0) "error"
     )
 
     iv_r <- reactive({
@@ -547,11 +547,6 @@ testthat::test_that("data_extract_multiple_srv input validation", {
   data_list <- list(iris = reactive(iris))
 
   server <- function(input, output, session) {
-    exactly_2_validation <- function(msg) {
-      ~ if (length(.) != 2) msg
-    }
-
-
     selector_list <- data_extract_multiple_srv(
       list(x_var = iris_select, species_var = iris_filter),
       datasets = data_list,
@@ -561,7 +556,7 @@ testthat::test_that("data_extract_multiple_srv input validation", {
       filter_validation_rule = list(
         species_var = shinyvalidate::compose_rules(
           shinyvalidate::sv_required("Exactly 2 Species must be chosen"),
-          exactly_2_validation("Exactly 2 Species must be chosen")
+          function(x) if (length(x) != 2) "Exactly 2 Species must be chosen"
         )
       )
     )

tests/testthat/test-delayed_data_extract.R

@@ -1,9 +1,9 @@
 # Contains integration tests between delayed data loading objects and
 # the objects responsible for loading, pulling and filtering the data
-ADSL <- teal.transform::rADSL
-ADTTE <- teal.transform::rADTTE
-ADAE <- teal.transform::rADAE
-ADRS <- teal.transform::rADRS
+ADSL <- rADSL
+ADTTE <- rADTTE
+ADAE <- rADAE
+ADRS <- rADRS
 
 data_list <- list(ADSL = reactive(ADSL), ADTTE = reactive(ADTTE), ADAE = reactive(ADAE), ADRS = reactive(ADRS))
 join_keys <- teal.data::default_cdisc_join_keys[c("ADSL", "ADTTE", "ADAE", "ADRS")]