redirection layer for test projects

ref #539

DESCRIPTION

@@ -61,7 +61,8 @@ Suggests:
     rmarkdown (>= 2.0),
     sessioninfo (>= 1.1.1),
     testthat (>= 3.0),
-    tidyselect
+    tidyselect,
+    yaml
 License: MIT + file LICENSE
 VignetteBuilder: knitr
 Encoding: UTF-8

R/helpers-testing.R

@@ -1,8 +1,52 @@
-retrieve_credential_testing <- function(project_id = 153L, username = NA_character_) {
-  checkmate::assert_integer(project_id, lower = 1, len = 1, any.missing = FALSE)
+retrieve_credential_testing <- function(project_tag = "simple", server_instance = "bbmc", username = NA_character_) {
+  checkmate::assert_character(project_tag     , any.missing = FALSE, min.chars = 2, max.chars = 50)
+  checkmate::assert_character(server_instance , any.missing = FALSE, min.chars = 2, max.chars = 50)
+  checkmate::assert_character(username        , any.missing = TRUE , min.chars = 2, max.chars = 50)
+
+  # This line avoids a warning from the package check.
+  projects <- project_id <- instance <- tag <- NULL
+
+  if (!requireNamespace("yaml", quietly = TRUE)) {
+    stop(
+      "Package `yaml` must be installed to use this function.",
+      call. = FALSE
+    )
+  }
+
+  d_map <-
+    system.file("misc/project-redirection.yml", package = "REDCapR") |>
+    yaml::yaml.load_file(
+      handlers = list(map = \(x) tibble::as_tibble(x))
+    ) |>
+    dplyr::bind_rows() |>
+    tidyr::unnest(projects) |>
+    tidyr::pivot_longer(
+      cols      = -c("instance", "credential_file"),
+      names_to  = "tag",
+      values_to = "project_id"
+    ) |>
+    tidyr::drop_na(project_id) |>
+    dplyr::filter(instance == server_instance) |>
+    dplyr::filter(tag      == project_tag)
+
+  if (nrow(d_map) == 0L) {
+    stop("A credential mapping entry does not exist for the desired arguments.")
+  }
+
+  path_credential <- system.file(d_map$credential_file, package = "REDCapR")
+  if (!base::file.exists(path_credential)) {
+    stop(
+      "The credential file `",
+      d_map$credential_file,
+      "` associated with the `",
+      server_instance,
+      "` does not exist on this machine."
+    )
+  }
+
   REDCapR::retrieve_credential_local(
-    path_credential = system.file("misc/example.credentials", package = "REDCapR"),
-    project_id      = project_id,
+    path_credential = path_credential, # "misc/example.credentials"
+    project_id      = d_map$project_id,
     username        = username
   )
 }

R/project-dag-write.R

@@ -12,7 +12,7 @@ populate_project_dag_write <- function(batch = FALSE, verbose = FALSE) {
     # nocov end
   }
 
-  credential  <- retrieve_credential_testing(2545L, "admin")
+  credential  <- retrieve_credential_testing("dag-write", username = "admin")
 
   project <- REDCapR::redcap_project$new(
     redcap_uri    = credential$redcap_uri,

R/project-delete-multiple-arm.R

@@ -10,7 +10,7 @@ populate_project_delete_multiple_arm <- function(verbose = FALSE) {
     # nocov end
   }
 
-  credential  <- retrieve_credential_testing(2627L)
+  credential  <- retrieve_credential_testing("arm-multiple-delete")
 
   project <- REDCapR::redcap_project$new(
     redcap_uri    = credential$redcap_uri,

R/project-delete-single-arm.R

@@ -10,7 +10,7 @@ populate_project_delete_single_arm <- function(verbose = FALSE) {
     # nocov end
   }
 
-  credential  <- retrieve_credential_testing(2626L)
+  credential  <- retrieve_credential_testing("arm-single-delete")
 
   project <- REDCapR::redcap_project$new(
     redcap_uri    = credential$redcap_uri,

R/project-simple.R

@@ -12,7 +12,7 @@ populate_project_simple <- function(batch = FALSE, verbose = TRUE) {
     # nocov end
   }
 
-  credential  <- retrieve_credential_testing(213L)
+  credential  <- retrieve_credential_testing("simple-write")
 
   project <- REDCapR::redcap_project$new(
     redcap_uri    = credential$redcap_uri,

inst/misc/project-redirection.yml

@@ -0,0 +1,41 @@
+-
+  instance: bbmc
+  credential_file: "misc/example.credentials"
+  projects:
+    - simple: 153
+    - longitudinal: 212
+    - simple-write: 213
+    - russian: 268
+    - empty-rows: 690
+    - single-column: 691
+    - super-wide-1: 753
+    - static-survey: 817
+    - clinical-trial: 977
+    # 0
+    - nonnumeric-record_id: 998
+    - dag: 999
+    - potentially-problematic-values: 1396
+    - repeating-instruments: 1400
+    - potentially-problematic-dictionary: 1425
+    - metadata-write: 1490
+    - dag-write: 2545
+    - super-wide-2: 2593
+    - super-wide-3: 2597
+    - repeating-instruments-sparse: 2603
+    - arm-single-delete: 2626
+    - arm-multiple-delete: 2627
+    - arm-single-longitudinal: 2629
+    - decimal-comma-and-dot: 2630
+    - decimal-comma: 2631
+    - decimal-dot: 2632
+    - validation-types: 2634
+    - blank-for-gray-status: 3003
+    - checkboxes-1: 3074
+    - vignette-repeating: 3181
+-
+  instance: dev-2
+  credential_file: "misc/example.credentials"
+  projects:
+    - simple: 953
+    - longitudinal: 912
+    - simple-write: 913

inst/test-data/super-wide-3/generate-dictionary.R

@@ -91,7 +91,7 @@ ds <-
   )
 
 # takes ~10 min to upload
-credential <- retrieve_credential_testing(2597L)
+credential <- retrieve_credential_testing("super-wide-3")
 REDCapR::redcap_write(
   ds          = ds,
   redcap_uri  = credential$redcap_uri,

inst/test-data/validation-types-v1/data.csv

@@ -1,2 +1 @@
-record_id,alpha_only,date_dmy  ,date_mdy  ,date_ymd  ,datetime_dmy    ,datetime_mdy    ,datetime_seconds_dmy,datetime_seconds_mdy,datetime_seconds_ymd,datetime_ymd         ,email         ,integer,mrn_10d   ,mrn_generic,number,number_1dp,number_1dp_comma_decimal,number_2dp,number_2dp_comma_decimal,number_3dp,number_3dp_comma_decimal,number_4dp,number_4dp_comma_decimal,number_comma_decimal,phone           ,phone_australia,postalcode_australia,postalcode_canada,postalcode_french,postalcode_germany,ssn        ,time,time_mm_ss,vmrn,zipcode
-1        ,abcde     ,2023-12-31,2023-12-31,2023-12-31,2023-12-31 11:45,2023-12-31 11:45,2023-12-31 11:45:55 ,2023-12-31 11:45:55 ,2023-12-31 11:45:55 ,2023-12-31  11:45:55 ,[email protected],1234567,0123456789,abcd-_12345,12.345,1234.5    ,"1234,5"                ,1234.56   ,"1234,56"               ,1234.567  ,"1234,567"              ,1234.5678 ,"1234,5678"             ,"1234,56"           ,"(321) 222-4444","(04) 4321 4321"    ,0123               ,A2C1B3           ,12345            ,12345             ,123-12-1234,12:34,59:59    ,01234,01234
+alpha_only,date_dmy,date_mdy,date_ymd,datetime_dmy,datetime_mdy,datetime_seconds_dmy,datetime_seconds_mdy,datetime_seconds_ymd,datetime_ymd,email,integer,mrn_10d,mrn_generic,number,number_1dp,number_1dp_comma_decimal,number_2dp,number_2dp_comma_decimal,number_3dp,number_3dp_comma_decimal,number_4dp,number_4dp_comma_decimal,number_comma_decimal,phone,phone_australia,postalcode_australia,postalcode_canada,postalcode_french,postalcode_germany,ssn,time,time_mm_ss,vmrn,zipcode

inst/test-data/validation-types-v1/dictionary.csv

@@ -1,5 +1,4 @@
 field_name,form_name,section_header,field_type,field_label,select_choices_or_calculations,field_note,text_validation_type_or_show_slider_number,text_validation_min,text_validation_max,identifier,branching_logic,required_field,custom_alignment,question_number,matrix_group_name,matrix_ranking,field_annotation
-record_id,form_1,,text,"Record ID",,,,,,,,,,,,,
 alpha_only,form_1,,text,Letters only,,,alpha_only,,,,,,,,,,
 date_dmy,form_1,,text,Date (D-M-Y),,,date_dmy,,,,,,,,,,
 date_mdy,form_1,,text,Date (M-D-Y),,,date_mdy,,,,,,,,,,

playgrounds/metadata-2.R

@@ -1,5 +1,5 @@
 # ---- commas-as-decimals ------------------------------------------------------
-credential  <- retrieve_credential_testing(2630L)
+credential  <- retrieve_credential_testing("decimal-comma-and-dot")
 m <- redcap_metadata_read(credential$redcap_uri, credential$token)$data
 m$text_validation_type_or_show_slider_number
 
@@ -19,7 +19,7 @@ for (variable in colnames(d)) {
 d
 
 # ---- longitudinal ------------------------------------------------------
-credential  <- retrieve_credential_testing(212L)
+credential  <- retrieve_credential_testing("longitudinal")
 d <- redcap_read_oneshot(credential$redcap_uri, credential$token, col_types = readr::cols(.default = readr::col_character()))$data
 d_m <- redcap_metadata_read(credential$redcap_uri, credential$token)$data
 d_m$text_validation_type_or_show_slider_number

tests/testthat/test-arm-export.R

@@ -25,7 +25,7 @@ empty_data_frame <-
 
 test_that("delete-multiple-arm", {
   testthat::skip_on_cran()
-  credential  <- retrieve_credential_testing(2627L)
+  credential  <- retrieve_credential_testing("arm-multiple-delete")
 
   path_expected <- "test-data/delete-multiple-arm/arm.csv"
   expected_data_frame <- read_arms(path_expected)
@@ -48,7 +48,7 @@ test_that("delete-multiple-arm", {
 
 test_that("delete-single-arm", {
   testthat::skip_on_cran()
-  credential  <- retrieve_credential_testing(2626L)
+  credential  <- retrieve_credential_testing("arm-single-delete")
 
   expected_outcome_message <- "A 'classic' REDCap project has no arms.  Retrieved in \\d+(\\.\\d+\\W|\\W)seconds\\."
   expect_message({
@@ -69,7 +69,7 @@ test_that("delete-single-arm", {
 
 test_that("Longitudinal Two Arms", {
   testthat::skip_on_cran()
-  credential  <- retrieve_credential_testing(212L)
+  credential  <- retrieve_credential_testing("longitudinal")
 
   path_expected <- "test-data/project-longitudinal/arm.csv"
   expected_data_frame <- read_arms(path_expected)
@@ -91,7 +91,7 @@ test_that("Longitudinal Two Arms", {
 
 test_that("Longitudinal Single Arm", {
   testthat::skip_on_cran()
-  credential  <- retrieve_credential_testing(2629L)
+  credential  <- retrieve_credential_testing("arm-single-longitudinal")
 
   path_expected <- "test-data/longitudinal-single-arm/arm.csv"
   expected_data_frame <- read_arms(path_expected)
@@ -113,7 +113,7 @@ test_that("Longitudinal Single Arm", {
 
 test_that("Bad Token", {
   testthat::skip_on_cran()
-  credential  <- retrieve_credential_testing(2629L)
+  credential  <- retrieve_credential_testing("arm-single-longitudinal")
   bad_token   <- "1234567890ABCDEF1234567890ABCDEF"
 
   expected_error_message <- "The REDCapR arm export failed\\. The http status code was 403. The error message was: 'ERROR: You do not have permissions to use the API'"

tests/testthat/test-dag-read.R

@@ -1,7 +1,7 @@
 library(testthat)
 
 credential_1        <- retrieve_credential_testing()
-credential_no_dag   <- retrieve_credential_testing(2597L)
+credential_no_dag   <- retrieve_credential_testing("super-wide-3")
 
 test_that("smoke", {
   testthat::skip_on_cran()

tests/testthat/test-delete.R

@@ -108,7 +108,7 @@ test_that("multiple-arm-four-records", {
 test_that("no-delete-permissions", {
   testthat::skip_on_cran()
   skip_if_onlyread()
-  credential  <- retrieve_credential_testing(213L) # Write-project, but  no privileges for deleting records
+  credential  <- retrieve_credential_testing("simple-write") # Write-project, but  no privileges for deleting records
 
   records_to_delete <- 1
 
@@ -127,7 +127,7 @@ test_that("no-delete-permissions", {
 test_that("Delete records that don't exist", {
   testthat::skip_on_cran()
   skip_if_onlyread()
-  credential  <- retrieve_credential_testing(2626L)
+  credential  <- retrieve_credential_testing("arm-single-delete")
 
   records_to_delete <- 1
 
@@ -146,7 +146,7 @@ test_that("Delete records that don't exist", {
 test_that("unnecessarily specify arm", {
   testthat::skip_on_cran()
   skip_if_onlyread()
-  credential  <- retrieve_credential_testing(2626L) # This project has no arms
+  credential  <- retrieve_credential_testing("arm-single-delete") # This project has no arms
 
   records_to_delete <- 101
   arm_number        <- 1L
@@ -167,7 +167,7 @@ test_that("unnecessarily specify arm", {
 test_that("unspecified required arm", {
   testthat::skip_on_cran()
   skip_if_onlyread()
-  credential  <- retrieve_credential_testing(2627L) # This project has three arms
+  credential  <- retrieve_credential_testing("arm-multiple-delete") # This project has three arms
 
   records_to_delete <- 101
   arm_number        <- 1L
@@ -186,7 +186,7 @@ test_that("unspecified required arm", {
 
 test_that("Bad Token", {
   testthat::skip_on_cran()
-  credential  <- retrieve_credential_testing(153L)
+  credential  <- retrieve_credential_testing()
   bad_token   <- "1234567890ABCDEF1234567890ABCDEF"
   records_to_delete <- 101