closes #2481 bug the result of derive param tte depends on the sort order of the input

NEWS.md

@@ -12,6 +12,12 @@
 - 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 `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)  
 
 - The `keep_nas` argument of `derive_param_computed()` was enhanced such that it
 is now possible to specify a list of variables for which `NA`s are acceptable.

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
 #'

R/derive_param_tte.R

@@ -60,6 +60,14 @@
 #'
 #'   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 input dataset are not unique with respect to the
+#'   by variables and the order.
+#'
+#'  Default: `"none"`
+#'
 #' @details The following steps are performed to create the observations of the
 #'   new parameter:
 #'
@@ -322,8 +330,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 +387,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 +408,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 +452,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,
@@ -505,6 +522,16 @@ derive_param_tte <- function(dataset = NULL,
 #'
 #'   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 input dataset are not unique with respect to the
+#'   by variables and the order.
+#'
+#'  Default: `"none"`
+#'
+#'  Permitted Values: `"none"`, `"warning"`, `"error"`, `"message"`
+#'
 #' @details The following steps are performed to create the output dataset:
 #'
 #'   \enumerate{ \item For each source dataset the observations as specified by
@@ -529,7 +556,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)
@@ -571,14 +598,16 @@ derive_param_tte <- function(dataset = NULL,
 #'   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 +642,49 @@ 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
+          )
+      },
+      warning = function(cnd) {
+        # Handle warnings
+        if (grepl("duplicate records", conditionMessage(cnd))) {
+          cli::cli_warn(c(
+            "Dataset '{.val {sources[[i]]$dataset_name}}' contains duplicate records.",
+            "i Duplicates were identified based on variables:
+               {.val {paste(c(subject_keys, by_vars, source_date_var), collapse = ', ')}}."
+          ))
+        }
+        source_dataset %>%
+          filter_if(sources[[i]]$filter) %>%
+          arrange(!!!sources[[i]]$order) # Return filtered dataset even if a warning occurred
+      },
+      error = function(err) {
+        cli::cli_abort(c(
+          "Duplicate records detected during processing.",
+          "x Duplicate records were found in dataset {.val {sources[[i]]$dataset_name}}.",
+          "i The duplicates were identified based on the following variables:
+            {.val {paste(c(subject_keys, by_vars, source_date_var), collapse = ', ')}}.",
+          "i Consider reviewing your `by_vars` or `order` argument to ensure uniqueness."
+        ))
+      },
+      message = function(msg) {
+        cli::cli_inform(c(
+          "Processing dataset '{.val {sources[[i]]$dataset_name}}'...",
+          "i Filter and order criteria: {.val {paste(c(subject_keys, by_vars,
+          sources[[i]]$order), collapse = ', ')}}."
+        ))
+      }
+    )
     # add date variable and accompanying variables
-
     if (create_datetime) {
       date_derv <- exprs(!!date_var := as_datetime(!!source_date_var))
     } else {
@@ -649,7 +710,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 +843,10 @@ 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
+#'
+#'   If the argument is set to a non-null value, for each by group the first or
+#'   last observation
 #'
 #' @keywords source_specifications
 #' @family source_specifications
@@ -793,7 +858,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 +869,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 +911,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 +960,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

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)

inst/WORDLIST

@@ -304,6 +304,7 @@ msec
 nd
 occds
 onwards
+param
 parttime
 pharmaverse
 pharmaverseadam