cleanup for CMD-check

DanChaltiel · Nov 30, 2023 · 0e5434f · 0e5434f
1 parent 84ce762
commit 0e5434f
Show file tree

Hide file tree

Showing 14 changed files with 44 additions and 30 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -84,6 +84,7 @@ importFrom(rlang,":=")
 importFrom(rlang,as_function)
 importFrom(rlang,as_name)
 importFrom(rlang,caller_arg)
+importFrom(rlang,caller_env)
 importFrom(rlang,check_dots_empty)
 importFrom(rlang,check_installed)
 importFrom(rlang,current_env)
@@ -92,6 +93,7 @@ importFrom(rlang,is_error)
 importFrom(rlang,is_formula)
 importFrom(rlang,is_installed)
 importFrom(rlang,is_named)
+importFrom(rlang,local_options)
 importFrom(rlang,peek_options)
 importFrom(rlang,set_names)
 importFrom(rlang,sym)
@@ -101,12 +103,15 @@ importFrom(stats,runif)
 importFrom(stringr,regex)
 importFrom(stringr,str_detect)
 importFrom(stringr,str_ends)
+importFrom(stringr,str_extract)
+importFrom(stringr,str_extract_all)
 importFrom(stringr,str_match)
 importFrom(stringr,str_remove)
 importFrom(stringr,str_remove_all)
 importFrom(stringr,str_replace_all)
 importFrom(stringr,str_split)
 importFrom(stringr,str_starts)
+importFrom(stringr,str_subset)
 importFrom(stringr,str_trim)
 importFrom(tibble,as_tibble)
 importFrom(tibble,lst)

diff --git a/R/helpers.R b/R/helpers.R
@@ -41,7 +41,7 @@
 #' @importFrom purrr map2_chr
 #' @importFrom stringr str_detect
 #' @importFrom tidyr unite unnest
-find_keyword = function(keyword, data=getOption("edc_lookup", NULL), ignore_case=TRUE){
+find_keyword = function(keyword, data=getOption("edc_lookup"), ignore_case=TRUE){
   stopifnot(!is.null(data))
   invalid=names2=labels2=x=NULL
   f = if(isTRUE(ignore_case)) tolower else identity
@@ -255,7 +255,7 @@ reset_manual_correction = function(){
 #' @export
 #' @importFrom purrr map
 #' @importFrom rlang set_names
-get_datasets = function(lookup=getOption("edc_lookup", NULL), envir=parent.frame()){
+get_datasets = function(lookup=getOption("edc_lookup"), envir=parent.frame()){
   lookup$dataset %>% 
     set_names() %>% 
     map(~get(.x, envir=envir))
@@ -274,7 +274,7 @@ get_datasets = function(lookup=getOption("edc_lookup", NULL), envir=parent.frame
 #' @importFrom dplyr mutate select
 #' @importFrom purrr map map_chr
 #' @importFrom tibble lst
-get_key_cols = function(lookup=getOption("edc_lookup", NULL)){
+get_key_cols = function(lookup=getOption("edc_lookup")){
   patient_id = getOption("edc_cols_id", c("PTNO", "SUBJID"))
   crfname = getOption("edc_cols_crfname", "CRFNAME")
   if(is.null(lookup)) return(lst(patient_id, crfname))
@@ -443,7 +443,8 @@ get_lookup = function(data_list){
 #' @noRd
 #' @keywords internal
 set_lookup = function(lookup){
-  if(!is.null(getOption("edc_lookup", NULL))){
+  verbose = getOption("edc_lookup_overwrite_warn", TRUE)
+  if(verbose && !is.null(getOption("edc_lookup"))){
     cli_warn("Option {.val edc_lookup} has been overwritten.", 
              class="edc_lookup_overwrite_warn")
   }

diff --git a/R/options.R b/R/options.R
@@ -13,9 +13,11 @@
 #' @param edc_subjid_ref **used in [check_subjid]** the vector of the reference subject IDs. You should usually write `edc_options(edc_subjid_ref=enrolres$subjid)`.
 #' @param edc_cols_id,edc_cols_crfname **used in [get_key_cols]** the name of the columns holding the subject id (default to `c("ptno", "subjid")`) and the crf form name (default to `c("crfname")`). It is case-insensitive.
 #' @param edc_read_verbose,edc_correction_verbose,edc_get_key_cols_verbose the verbosity of the output of functions [read_trialmaster] and [read_tm_all_xpt], [manual_correction], and [get_key_cols]. For example, set `edc_options(edc_read_verbose=0)` to silence the first 2.
+#' @param edc_lookup_overwrite_warn default to TRUE. Whether there should be warning when overwriting `.lookup` (like when reading 2 databases successively)
 #' @param .local  if TRUE, the effect will only apply to the local frame (internally using `rlang::local_options()`)
 #'
 #' @return Nothing, called for its side effects
+#' @importFrom rlang caller_env local_options
 #' @export
 edc_options = function(
     ...,
@@ -28,6 +30,7 @@ edc_options = function(
     edc_read_verbose,
     edc_correction_verbose,
     edc_get_key_cols_verbose,
+    edc_lookup_overwrite_warn,
     .local=FALSE){
   rlang::check_dots_empty()
   argg = as.list(match.call()) %>% discard(is.name)
@@ -81,6 +84,7 @@ edc_reset_options = function(except=c("edc_lookup", "trialmaster_pw", "path_7zip
 }
 
 
+#' @importFrom stringr str_extract str_extract_all str_remove_all str_subset
 #' @noRd
 #' @keywords internal
 missing_options_helper = function(){

diff --git a/R/swimmerplot.R b/R/swimmerplot.R
@@ -7,7 +7,7 @@
 #' 
 #' Join all tables from `.lookup$dataset` on `id` 
 #'
-#' @param .lookup the lookup table, loaded along with the database or result of [get_lookup()]
+#' @param .lookup the lookup table, default to `getOption("edc_lookup")`
 #' @param id the patient identifier. Will be coerced as numeric.
 #' @param group a grouping variable, given as "dataset$column"
 #' @param origin a variable to consider as time 0, given as "dataset$column"
@@ -44,8 +44,9 @@
 #' @importFrom stringr str_detect str_ends str_remove
 #' @importFrom tidyr pivot_longer
 #' @importFrom tidyselect where
-edc_swimmerplot = function(.lookup=getOption("edc_lookup", NULL), ..., 
-                           id=c("SUBJID", "PATNO"), group=NULL, origin=NULL, 
+edc_swimmerplot = function(.lookup=getOption("edc_lookup"), ..., 
+                           id=get_key_cols()$patient_id, 
+                           group=NULL, origin=NULL, 
                            id_lim=NULL,
                            exclude=NULL,
                            time_unit=c("days", "weeks", "months", "years"),

diff --git a/man/edc_options.Rd b/man/edc_options.Rd
diff --git a/man/edc_swimmerplot.Rd b/man/edc_swimmerplot.Rd
diff --git a/man/find_keyword.Rd b/man/find_keyword.Rd
diff --git a/man/get_datasets.Rd b/man/get_datasets.Rd
diff --git a/man/get_key_cols.Rd b/man/get_key_cols.Rd
diff --git a/man/split_mixed_datasets.Rd b/man/split_mixed_datasets.Rd
diff --git a/tests/testthat/helper-init.R b/tests/testthat/helper-init.R
@@ -23,8 +23,12 @@ options(
 
 library(rlang, warn.conflicts=FALSE)
 
-options(trialmaster_pw="0")
-options(edc="TRNO")
+
+edc_options(
+  trialmaster_pw="0", 
+  edc_lookup_overwrite_warn=FALSE
+)
+
 # getOption("trialmaster_pw")
 
 # cachename="trialmaster_export_2022-08-25 15h16.rds"
@@ -126,4 +130,5 @@ expect_classed_conditions = function(expr, message_class=NULL, warning_class=NUL
 }
 
 clean_cache()
-message("Helper-init loaded")
+cli::cli_inform(c(v="Initializer {.file helper-init_dataset.R} loaded: 
+                     is_testing={is_testing()}, is_parallel={is_parallel()}"))
diff --git a/tests/testthat/test-split_mixed.R b/tests/testthat/test-split_mixed.R
@@ -28,30 +28,28 @@ if(FALSE){
 test_that("Split mixed outside read_trialmaster()", {
   tm = edc_example_mixed()
   mixed_data = split_mixed_datasets(tm, id="SUBJID", verbose=FALSE)
-  mixed_data %>% map_dbl(nrow) %>% unname() %>% expect_equal(c(100, 300, 100, 200))
-  mixed_data %>% map_dbl(ncol) %>% unname() %>% expect_equal(c(2, 3, 3, 3))
+  mixed_data %>% names() %>% expect_equal(c("long_mixed_short", "long_mixed_long" ))
+  mixed_data %>% map_dbl(nrow) %>% unname() %>% expect_equal(c(100, 200))
+  mixed_data %>% map_dbl(ncol) %>% unname() %>% expect_equal(c(3, 3))
 })
 
 
 test_that("Split mixed inside read_trialmaster()", {
 
-  local_options(edc_read_verbose=0, edc_lookup=NULL)
+  edc_options(edc_read_verbose=0, edc_lookup=NULL, .local=TRUE)
   common = c("date_extraction", "datetime_extraction", ".lookup")
   f = test_path("edc_example_mixed_SAS_XPORT_2000_01_01_00_00.zip")
   tm1 = read_trialmaster(f, pw="foobar")
   # names(tm1) %>% dput()
   expect_equal(names(tm1), c("long_mixed", "long_pure", "short", common))
-  local_options(edc_lookup=NULL)
 
   tm2 = read_trialmaster(f, pw="foobar", split_mixed="short") %>% 
     expect_classed_conditions(warning_class="edc_read_cannot_split_mixed_warn")#no effect
   # names(tm2) %>% dput()
   expect_equal(names(tm2), c("long_mixed", "long_pure", "short", common))
-  local_options(edc_lookup=NULL)
 
   tm3 = read_trialmaster(f, pw="foobar", split_mixed=c("long_pure", "long_mixed"))
   # names(tm3) %>% dput()
   expect_equal(names(tm3), c("long_mixed", "long_pure", "short", "long_mixed_short", 
-                            "long_mixed_long", "long_pure_short", "long_pure_long", 
-                            common))
+                            "long_mixed_long", common))
 })
diff --git a/tests/testthat/test-trialmaster.R b/tests/testthat/test-trialmaster.R
@@ -11,7 +11,7 @@ filename_bad = test_path("CRF_Dan_Export.zip")
 
 test_that("Read an archive", {
   clean_cache()
-
+  edc_options(edc_lookup_overwrite_warn=TRUE, .local=TRUE)
   w = read_trialmaster(filename) %>% 
     expect_classed_conditions(message_class="read_tm_zip")
   w = read_trialmaster(filename, use_cache=TRUE) %>% 
@@ -82,7 +82,6 @@ test_that("Read an archive with a bad name", {
 
 
 test_that("Use cache only if permitted", {
-  edc_reset_options(except=c("trialmaster_pw", "path_7zip"), quiet=F)
   w  = read_trialmaster(filename, use_cache="write", verbose=0)
   w2 = read_trialmaster(filename, use_cache="read", verbose=0) %>% expect_silent()
   w2 = read_trialmaster(filename, use_cache="read", verbose=0, clean_names_fun=tolower, split_mixed=TRUE) %>% 

diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R
@@ -82,9 +82,7 @@ test_that("find_keyword() works", {
 
 
 test_that("find_keyword() works with read_trialmaster()", {
-  clean_cache()
-  expect_message(w <- read_trialmaster(filename),
-                 class="read_tm_zip")
+  w = read_trialmaster(filename, use_cache=FALSE)
   local_options(edc_lookup=w$.lookup)
   x1=find_keyword("sex")
   expect_equal(x1$names, "SEX")
@@ -193,3 +191,4 @@ test_that("expect_classed_conditions()", {
                             error_class="error1") %>% 
     expect_error("message3.*xxxx")
 })
+