Closes #2481 bug the result of derive param tte depends on the sort o…

…rder of the input (#2569) * Added order arguments to censor_source and event_source. Also added signal_duplicate_records to derive_param_tte. Still troubleshooting the test-derive_param_tte script. Failed tests have a "Required variable `AEDECOD` is missing in `dataset`" error. * Added order argument to tte_source as part of development and error fixes. * Fixed previous erros but still need to address failed tests for Test 9, 15, and 16 in test-derive_param_tte * added check_type arg_match to derive_param_tte so user has to input a valid argument * Changed position of signal_duplicate_records function in derive_param_tte to fix missing data error * lintr changes by removing whitespace. * styler fix. Pushing again and confirmed check_type argument is in derive_var_obs_number in derive_joined.R scripts * updated NEWS.md with changes to derive_param_tte,. Removed Test 17 from test-derive_param_tte as it was redundant, and ran pharmaverse4devs format test script addin to format testest-derive_param_tte. * changed the signal_duplicate_records within derive_parame_tte to handle dataset_adsl and source_datasets by combining them with bind_rows before to address error of AEDECOD missing from the dataset when just calling dataset_adsl. This starts on line 381 of derive_param_tte.R * added a tryCatch() to filter_date_sources to catch duplicates to address failed runs in Test 16 of test-derive_param_tte. removed signal_duplicate_records() from within derive_param_tte Still need to troubleshoot errors in test script. * Moved duplication check to filter_date_sources in tryCatch() and rewrote Test 15 and 16 on test-derive_param_tte to deal with update to duplicate warnings within tryCatch and not directly by signal_duplicate_records inside derive_param_tte function. Accepted snapshots from devtools::check * 1. Moved updates in News section to admiral dev section 2. Made suggested fixes to derive_param_tte script. * Ran styler, lintr fixes, and devtools check. * styler changes * accepted snapshots from testthat and addressed bds_tte.Rmd error for devtool checks() * added documentation for order and check_type arguments added to functions. Directly called rlang::try_fetch in derive_param_tte script. * requested updates to documentation and test script for derive_param_tte * corrected documentation and removed rlang from bds_tte.Rmd * updated derive_param_tte documentation and added test to derive_param_tte test script. * fixed spelling error * updates to derive_param_tte documentation and test examples. * Update NEWS.md Co-authored-by: Stefan Bundfuss <[email protected]> * update to derive_param_tte test, function examples, and documentation. * snapshots accepted * passed local checks. Pushing again * ran styler * added "message" as a option for check_type in derive_var_obs_number * Update NEWS.md Co-authored-by: Ben Straub <[email protected]> * #2481: cosmetics * #2481: fix lintr --------- Co-authored-by: Stefan Bundfuss <[email protected]> Co-authored-by: Ben Straub <[email protected]> Co-authored-by: Stefan Bundfuss <[email protected]>
pharmaverse · Jan 13, 2025 · 018451c · 018451c
1 parent c75aff0
commit 018451c
Show file tree

Hide file tree

Showing 16 changed files with 587 additions and 53 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -14,6 +14,14 @@ target range. (#2571)
 - Update `ADEG` template to flag `ABLFL` and `ANL01FL` based on `DTYPE == "AVERAGE"` records. (#2561)
 
 ## Updates of Existing Functions
+- added `"message"` as option for `check_type` argument in `derive_var_obs_number()` function. (#2481)
+
+- added `"message"` as option for `check_type` argument in `filter_extreme()` function. (#2481)
+
+- Users can now specify how duplicate records are handled in `derive_param_tte()` using the `check_type` argument, with options including `"error"`, `"warning"`, `"message"`, or `"none"`, allowing for greater flexibility in managing duplicate data scenarios. (#2481)
+
+- `order` argument has been added to `event_source()` and `censor_source()` and  
+  defaulted to `NULL` to allow specifying variables in addition to the date variable. This can be used to ensure the uniqueness of the select records if there is more than one record per date.  (#2481)  
 
 - NCICTCAEv5 grading criteria (`atoxgr_criteria_ctcv5`):
 

diff --git a/R/derive_merged.R b/R/derive_merged.R
@@ -112,15 +112,15 @@
 #'
 #' @param check_type Check uniqueness?
 #'
-#'   If `"warning"` or `"error"` is specified, the specified message is issued
+#'   If `"warning"`, `"message"`, or `"error"` is specified, the specified message is issued
 #'   if the observations of the (restricted) additional dataset are not unique
 #'   with respect to the by variables and the order.
 #'
 #'   If the `order` argument is not specified, the `check_type` argument is ignored:
-#'    if the observations of the (restricted) additional dataset are not unique with respect
-#'    to the by variables, an error is issued.
+#'   if the observations of the (restricted) additional dataset are not unique with respect
+#'   to the by variables, an error is issued.
 #'
-#'   *Permitted Values*: `"none"`, `"warning"`, `"error"`
+#'   *Permitted Values*: `"none"`, `"message"`, `"warning"`, `"error"`
 #'
 #' @param duplicate_msg Message of unique check
 #'

diff --git a/R/derive_param_tte.R b/R/derive_param_tte.R
@@ -60,6 +60,15 @@
 #'
 #'   A list of symbols created using `exprs()` is expected.
 #'
+#' @param check_type Check uniqueness
+#'
+#'   If `"warning"`, `"message"`, or `"error"` is specified, the specified message is issued
+#'   if the observations of the source datasets are not unique with respect to the
+#'   by variables and the date and order specified in the `event_source()` and
+#'   `censor_source()` objects.
+#'
+#'   *Permitted Values*: `"none"`, `"message"`, `"warning"`, `"error"`
+#'
 #' @details The following steps are performed to create the observations of the
 #'   new parameter:
 #'
@@ -263,9 +272,9 @@
 #'
 #' ae <- tribble(
 #'   ~USUBJID, ~AESTDTC,           ~AESEQ, ~AEDECOD,
-#'   "01",     "2021-01-03T10:56", 1,      "Flu",
-#'   "01",     "2021-03-04",       2,      "Cough",
-#'   "01",     "2021",             3,      "Flu"
+#'   "01",     "2021-01-03T10:56",      1, "Flu",
+#'   "01",     "2021-03-04",            2, "Cough",
+#'   "01",     "2021",                  3, "Flu"
 #' ) %>%
 #'   mutate(STUDYID = "AB42")
 #'
@@ -313,6 +322,50 @@
 #'   )
 #' ) %>%
 #'   select(USUBJID, STARTDT, PARAMCD, PARAM, ADT, CNSR, SRCSEQ)
+#'
+#' # Resolve tie when serious AE share a date by sorting with order argument
+#' adsl <- tribble(
+#'   ~USUBJID, ~TRTSDT,           ~EOSDT,
+#'   "01",     ymd("2020-12-06"), ymd("2021-03-06"),
+#'   "02",     ymd("2021-01-16"), ymd("2021-02-03")
+#' ) %>% mutate(STUDYID = "AB42")
+#'
+#' ae <- tribble(
+#'   ~USUBJID, ~AESTDTC,     ~AESEQ, ~AESER, ~AEDECOD,
+#'   "01",     "2021-01-03",      1, "Y",    "Flu",
+#'   "01",     "2021-01-03",      2, "Y",    "Cough",
+#'   "01",     "2021-01-20",      3, "N",    "Headache"
+#' ) %>% mutate(
+#'   AESTDT = ymd(AESTDTC),
+#'   STUDYID = "AB42"
+#' )
+#'
+#' derive_param_tte(
+#'   dataset_adsl = adsl,
+#'   start_date = TRTSDT,
+#'   source_datasets = list(adsl = adsl, ae = ae),
+#'   event_conditions = list(event_source(
+#'     dataset_name = "ae",
+#'     date = AESTDT,
+#'     set_values_to = exprs(
+#'       EVENTDESC = "Serious AE",
+#'       SRCSEQ = AESEQ
+#'     ),
+#'     filter = AESER == "Y",
+#'     order = exprs(AESEQ)
+#'   )),
+#'   censor_conditions = list(censor_source(
+#'     dataset_name = "adsl",
+#'     date = EOSDT,
+#'     censor = 1,
+#'     set_values_to = exprs(EVENTDESC = "End of Study")
+#'   )),
+#'   set_values_to = exprs(
+#'     PARAMCD = "TTSAE",
+#'     PARAM = "Time to First Serious AE"
+#'   )
+#' )
+#'
 derive_param_tte <- function(dataset = NULL,
                              dataset_adsl,
                              source_datasets,
@@ -322,8 +375,14 @@ derive_param_tte <- function(dataset = NULL,
                              censor_conditions,
                              create_datetime = FALSE,
                              set_values_to,
-                             subject_keys = get_admiral_option("subject_keys")) {
+                             subject_keys = get_admiral_option("subject_keys"),
+                             check_type = "warning") {
   # checking and quoting #
+  check_type <- assert_character_scalar(
+    check_type,
+    values = c("warning", "message", "error", "none"),
+    case_sensitive = FALSE
+  )
   assert_data_frame(dataset, optional = TRUE)
   assert_vars(by_vars, optional = TRUE)
   start_date <- assert_symbol(enexpr(start_date))
@@ -373,16 +432,17 @@ derive_param_tte <- function(dataset = NULL,
       by_vars = by_vars
     )
   }
-
   tmp_event <- get_new_tmp_var(dataset)
+
   # determine events #
   event_data <- filter_date_sources(
     sources = event_conditions,
     source_datasets = source_datasets,
     by_vars = by_vars,
     create_datetime = create_datetime,
     subject_keys = subject_keys,
-    mode = "first"
+    mode = "first",
+    check_type = check_type
   ) %>%
     mutate(!!tmp_event := 1L)
 
@@ -393,7 +453,8 @@ derive_param_tte <- function(dataset = NULL,
     by_vars = by_vars,
     create_datetime = create_datetime,
     subject_keys = subject_keys,
-    mode = "last"
+    mode = "last",
+    check_type = check_type
   ) %>%
     mutate(!!tmp_event := 0L)
 
@@ -436,7 +497,8 @@ derive_param_tte <- function(dataset = NULL,
     bind_rows(event_data, censor_data),
     by_vars = expr_c(subject_keys, by_vars),
     order = exprs(!!tmp_event),
-    mode = "last"
+    mode = "last",
+    check_type = check_type
   ) %>%
     inner_join(
       adsl,
@@ -503,7 +565,15 @@ derive_param_tte <- function(dataset = NULL,
 #'   respect to the date is included in the output dataset. If `"last"` is
 #'   specified, the last observation is included in the output dataset.
 #'
-#'   Permitted Values:  `"first"`, `"last"`
+#'   *Permitted Values*:  `"first"`, `"last"`
+#'
+#' @param check_type Check uniqueness
+#'
+#'   If `"warning"`, `"message"`, or `"error"` is specified, the specified message is issued
+#'   if the observations of the source datasets are not unique with respect to the
+#'   by variables and the date and order specified in the `tte_source()` objects.
+#'
+#'   *Permitted Values*: `"none"`, `"warning"`, `"error"`, `"message"`
 #'
 #' @details The following steps are performed to create the output dataset:
 #'
@@ -529,7 +599,7 @@ derive_param_tte <- function(dataset = NULL,
 #' @return A dataset with one observation per subject as described in the
 #'   "Details" section.
 #'
-#' @noRd
+#' @keywords internal
 #'
 #' @examples
 #' library(tibble)
@@ -565,20 +635,22 @@ derive_param_tte <- function(dataset = NULL,
 #'   )
 #' )
 #'
-#' filter_date_sources(
+#' admiral:::filter_date_sources(
 #'   sources = list(ttae),
 #'   source_datasets = list(adsl = adsl, ae = ae),
 #'   by_vars = exprs(AEDECOD),
 #'   create_datetime = FALSE,
 #'   subject_keys = get_admiral_option("subject_keys"),
-#'   mode = "first"
+#'   mode = "first",
+#'   check_type = "none"
 #' )
 filter_date_sources <- function(sources,
                                 source_datasets,
                                 by_vars,
                                 create_datetime = FALSE,
                                 subject_keys,
-                                mode) {
+                                mode,
+                                check_type = "none") {
   assert_list_of(sources, "tte_source")
   assert_list_of(source_datasets, "data.frame")
   assert_logical_scalar(create_datetime)
@@ -613,17 +685,34 @@ filter_date_sources <- function(sources,
       var = !!source_date_var,
       dataset_name = sources[[i]]$dataset_name
     )
-    data[[i]] <- source_dataset %>%
-      filter_if(sources[[i]]$filter) %>%
-      filter_extreme(
-        order = exprs(!!source_date_var),
-        by_vars = expr_c(subject_keys, by_vars),
-        mode = mode,
-        check_type = "none"
-      )
-
+    # wrap filter_extreme in tryCatch to catch duplicate records and create a message
+    data[[i]] <- rlang::try_fetch(
+      {
+        source_dataset %>%
+          filter_if(sources[[i]]$filter) %>%
+          filter_extreme(
+            order = expr_c(exprs(!!source_date_var), sources[[i]]$order),
+            by_vars = expr_c(subject_keys, by_vars),
+            mode = mode,
+            check_type = check_type
+          )
+      },
+      duplicate_records = function(cnd) {
+        cnd_funs <- list(message = cli_inform, warning = cli_warn, error = cli_abort)
+        cnd_funs[[check_type]](
+          c(
+            paste(
+              "Dataset {.val {sources[[i]]$dataset_name}} contains duplicate",
+              "records with respect to {.var {cnd$by_vars}}"
+            ),
+            i = "Run {.run admiral::get_duplicates_dataset()} to access the duplicate records"
+          ),
+          class = class(cnd))
+        cnd_muffle(cnd)
+        zap()
+      }
+    )
     # add date variable and accompanying variables
-
     if (create_datetime) {
       date_derv <- exprs(!!date_var := as_datetime(!!source_date_var))
     } else {
@@ -649,7 +738,7 @@ filter_date_sources <- function(sources,
       by_vars = expr_c(subject_keys, by_vars),
       order = exprs(!!date_var),
       mode = mode,
-      check_type = "none"
+      check_type = check_type
     )
 }
 
@@ -782,6 +871,12 @@ extend_source_datasets <- function(source_datasets,
 #'   SRCDOM = "ADSL", SRCVAR = "DTHDT")`. The values must be a symbol, a
 #'   character string, a numeric value, an expression, or `NA`.
 #'
+#' @param order Sort order
+#'
+#'   An optional named list returned by `exprs()` defining additional variables
+#'   that the source dataset is sorted on after `date`.
+#'
+#'   *Permitted Values:* list of variables created by `exprs()` e.g. `exprs(ASEQ)`.
 #'
 #' @keywords source_specifications
 #' @family source_specifications
@@ -793,7 +888,8 @@ tte_source <- function(dataset_name,
                        filter = NULL,
                        date,
                        censor = 0,
-                       set_values_to = NULL) {
+                       set_values_to = NULL,
+                       order = order) {
   out <- list(
     dataset_name = assert_character_scalar(dataset_name),
     filter = assert_filter_cond(enexpr(filter), optional = TRUE),
@@ -803,7 +899,8 @@ tte_source <- function(dataset_name,
       set_values_to,
       named = TRUE,
       optional = TRUE
-    )
+    ),
+    order = order
   )
   class(out) <- c("tte_source", "source", "list")
   out
@@ -844,13 +941,15 @@ tte_source <- function(dataset_name,
 event_source <- function(dataset_name,
                          filter = NULL,
                          date,
-                         set_values_to = NULL) {
+                         set_values_to = NULL,
+                         order = NULL) {
   out <- tte_source(
     dataset_name = assert_character_scalar(dataset_name),
     filter = !!enexpr(filter),
     date = !!assert_expr(enexpr(date)),
     censor = 0,
-    set_values_to = set_values_to
+    set_values_to = set_values_to,
+    order = order
   )
   class(out) <- c("event_source", class(out))
   out
@@ -891,13 +990,15 @@ censor_source <- function(dataset_name,
                           filter = NULL,
                           date,
                           censor = 1,
-                          set_values_to = NULL) {
+                          set_values_to = NULL,
+                          order = NULL) {
   out <- tte_source(
     dataset_name = assert_character_scalar(dataset_name),
     filter = !!enexpr(filter),
     date = !!assert_expr(enexpr(date)),
     censor = assert_integer_scalar(censor, subset = "positive"),
-    set_values_to = set_values_to
+    set_values_to = set_values_to,
+    order = order
   )
   class(out) <- c("censor_source", class(out))
   out

diff --git a/R/derive_var_obs_number.R b/R/derive_var_obs_number.R
@@ -104,7 +104,7 @@ derive_var_obs_number <- function(dataset,
   check_type <-
     assert_character_scalar(
       check_type,
-      values = c("none", "warning", "error"),
+      values = c("none", "warning", "error", "message"),
       case_sensitive = FALSE
     )
 

diff --git a/R/filter_extreme.R b/R/filter_extreme.R
@@ -106,7 +106,7 @@ filter_extreme <- function(dataset,
   check_type <-
     assert_character_scalar(
       check_type,
-      values = c("none", "warning", "error"),
+      values = c("none", "warning", "error", "message"),
       case_sensitive = FALSE
     )
   assert_data_frame(dataset, required_vars = by_vars)

diff --git a/inst/WORDLIST b/inst/WORDLIST
@@ -312,6 +312,7 @@ msec
 nd
 occds
 onwards
+param
 parttime
 pharmaverse
 pharmaverseadam

diff --git a/man/censor_source.Rd b/man/censor_source.Rd
-Original file line number
+Diff line change
@@ Expand Up / @@ -312,6 +312,7 @@ msec @@
     nd
     occds
     onwards
+    param
     parttime
     pharmaverse
     pharmaverseadam
@@ Expand Down @@