Merge pull request #151 from Roche-GSK/112_bundfuss

Updates to be in line with the programming strategy
pharmaverse · May 4, 2021 · c3bfa89 · c3bfa89
2 parents 8fdad95 + f970a75
commit c3bfa89
Show file tree

Hide file tree

Showing 39 changed files with 342 additions and 116 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -33,6 +33,7 @@ export(expect_dfs_equal)
 export(expr)
 export(exprs)
 export(filter_extreme)
+export(has_unique_records)
 export(impute_dtc)
 export(initialize)
 export(is_character)
@@ -45,6 +46,7 @@ export(is_valid_month)
 export(is_valid_sec_min)
 export(is_valid_time_entry)
 export(read_dap_m3)
+export(warn_has_unique_records)
 export(warn_if_invalid_dtc)
 export(warn_if_vars_exist)
 importFrom(assertthat,"on_failure<-")

diff --git a/R/assertions.R b/R/assertions.R
@@ -12,6 +12,8 @@
 #'
 #' @export
 #'
+#' @keywords assertion
+#'
 #' @examples
 #' data(dm)
 #' assert_has_variables(dm, "STUDYID")
@@ -48,6 +50,8 @@ assert_has_variables <- function(dataset, required_vars) {
 #' @return The function throws an error if a subject has multiple baseline
 #' records
 #'
+#' @keywords assertion
+#'
 #' @export
 assert_has_only_one_baseline_record <- function(dataset, by) { # nolint
   is_duplicate <- duplicated(select(dataset, !!!syms(by)))
@@ -66,7 +70,7 @@ assert_has_only_one_baseline_record <- function(dataset, by) { # nolint
 
 #' Are records unique?
 #'
-#' Checks if the reords of a dateset are unique with respect to the specified
+#' Checks if the records of a dateset are unique with respect to the specified
 #' list of by variables and order.
 #'
 #' @param dataset The input dataset to check
@@ -87,20 +91,23 @@ assert_has_only_one_baseline_record <- function(dataset, by) { # nolint
 #'
 #' @author Stefan Bundfuss
 #'
-#' @return `TRUE` if the argument is a date or date-time, `FALSE` otherwise
+#' @return `TRUE` if the records are unique, `FALSE` otherwise
+#'
+#' @keywords check
 #'
 #' @export
 #'
 #' @examples
 #' data(ex)
-#' assert_has_unique_records(ex,
-#'                           by_vars = exprs(USUBJID) ,
-#'                           order = exprs(desc(EXENDTC)))
-assert_has_unique_records <- function(dataset,
-                                      by_vars = NULL,
-                                      order = NULL,
-                                      message = NULL,
-                                      message_type = "error") {
+#' has_unique_records(ex,
+#'                    by_vars = exprs(USUBJID) ,
+#'                    order = exprs(desc(EXENDTC)))
+has_unique_records <- function(dataset,
+                               by_vars = NULL,
+                               order = NULL,
+                               message = NULL,
+                               message_type = "error") {
+  arg_match(message_type, c("none", "warning", "error"))
   # variables used for check
   all_vars <- list()
 
@@ -135,32 +142,78 @@ assert_has_unique_records <- function(dataset,
   # check for duplicates
   is_duplicate <- duplicated(data_by) | duplicated(data_by, fromLast = TRUE)
   if (any(is_duplicate)) {
-    # filter out duplicate observations of the input dataset
-    duplicates <- data_ext %>%
-      filter(is_duplicate)
+    if (message_type != "none") {
+      # filter out duplicate observations of the input dataset
+      duplicates <- data_ext %>%
+        filter(is_duplicate)
 
-    # create message
-    tbl <- capture.output(print(duplicates))
-    if (is.null(message)) {
-      message <- paste0("Dataset contains multiple records with respect to ",
-                       paste(all_vars_msg, collapse = ", "),
-                       ".")
-    }
-    err_msg <- paste0(
-      message,
-      "\n",
-      paste(tbl[-c(1, 3)], collapse = "\n")
-    )
+      # create message
+      tbl <- capture.output(print(duplicates))
+      if (missing(message)) {
+        message <- paste0("Dataset contains multiple records with respect to ",
+                          paste(all_vars_msg, collapse = ", "),
+                          ".")
+      }
+      err_msg <- paste0(
+        message,
+        "\n",
+        paste(tbl[-c(1, 3)], collapse = "\n")
+      )
 
-    # issue message
-    if (message_type == "error") {
-      abort(err_msg)
-    } else {
-      warn(err_msg)
+      # issue message
+      if (message_type == "error") {
+        abort(err_msg)
+      } else {
+        warn(err_msg)
+      }
     }
+    TRUE
+  }
+  else{
+    FALSE
   }
 }
 
+#' Are records unique?
+#'
+#' Checks if the records of a dateset are unique with respect to the specified
+#' list of by variables and order. If the check fails, an error is issued.
+#'
+#' @param dataset The input dataset to check
+#'
+#' @param by_vars List of by variables
+#'
+#' @param order Order of observation
+#'   If the parameter is specified, it is checked if the observations are unique
+#'   with respect to the by variables and the order. If the check fails, the
+#'   order values are written as variables in the output.
+#'
+#' @param message Error message
+#'   The message to be displayed if the check fails.
+#'
+#' @author Stefan Bundfuss
+#'
+#' @return `TRUE` if the records are unique, `FALSE` otherwise
+#'
+#' @keywords assertion
+#'
+#' @export
+#'
+#' @examples
+#' data(ex)
+#' assert_has_unique_records(ex,
+#'                           by_vars = exprs(USUBJID) ,
+#'                           order = exprs(desc(EXENDTC)))
+assert_has_unique_records <- function(dataset,
+                                      by_vars = NULL,
+                                      order = NULL,
+                                      message) {
+  has_unique_records(dataset = dataset,
+                     by_vars = by_vars,
+                     order = order,
+                     message_type = "error")
+}
+
 #' Is Date/Date-time?
 #'
 #' Checks if a date or date-time vector was specified
@@ -171,6 +224,8 @@ assert_has_unique_records <- function(dataset,
 #'
 #' @return `TRUE` if the argument is a date or date-time, `FALSE` otherwise
 #'
+#' @keywords check
+#'
 #' @export
 #'
 #' @examples
@@ -201,6 +256,8 @@ on_failure(is_date) <- function(call, env) {
 #'
 #' @return `TRUE` if the argument is a time unit, `FALSE` otherwise
 #'
+#' @keywords check
+#'
 #' @export
 #'
 #' @examples
@@ -231,6 +288,8 @@ on_failure(is_timeunit) <- function(call, env) {
 #'
 #' @return `TRUE` if the argument is a valid date_imputation input, `FALSE` otherwise
 #'
+#' @keywords check
+#'
 #' @export
 #'
 #' @examples
@@ -263,6 +322,8 @@ on_failure(is_valid_date_entry) <- function(call, env) {
 #'
 #' @return `TRUE` if the argument is a valid time_imputation input, `FALSE` otherwise
 #'
+#' @keywords check
+#'
 #' @export
 #'
 #' @examples
@@ -294,6 +355,8 @@ on_failure(is_valid_time_entry) <- function(call, env) {
 #'
 #' @return `TRUE` if the argument is a valid min/sec input, `FALSE` otherwise
 #'
+#' @keywords check
+#'
 #' @export
 #'
 #' @examples
@@ -322,6 +385,8 @@ on_failure(is_valid_sec_min) <- function(call, env) {
 #'
 #' @return `TRUE` if the argument is a valid hour input, `FALSE` otherwise
 #'
+#' @keywords check
+#'
 #' @export
 #'
 #' @examples
@@ -350,6 +415,8 @@ on_failure(is_valid_hour) <- function(call, env) {
 #'
 #' @return `TRUE` if the argument is a day input, `FALSE` otherwise
 #'
+#' @keywords check
+#'
 #' @export
 #'
 #' @examples
@@ -378,6 +445,8 @@ on_failure(is_valid_day) <- function(call, env) {
 #'
 #' @return `TRUE` if the argument is a month input, `FALSE` otherwise
 #'
+#' @keywords check
+#'
 #' @export
 #'
 #' @examples

diff --git a/R/compute_duration.R b/R/compute_duration.R
@@ -62,7 +62,7 @@
 #'
 #' @return The duration between the two date in the specified unit
 #'
-#' @keywords general time
+#' @keywords computation adam timing
 #'
 #' @export
 #'
@@ -89,7 +89,6 @@
 #'   out_unit = "years",
 #'   add_one = FALSE
 #' )
-
 compute_duration <- function(start_date,
                              end_date,
                              in_unit = "days",

diff --git a/R/data.R b/R/data.R
@@ -66,6 +66,6 @@
 #' An example subject level analysis dataset
 #'
 #' @source
-#' Derived from the [dm] and [ds] datasets using `{admiral}`
+#' Derived from the [dm] and [ds] datasets using `{admiral}` (\url{https://github.com/Roche-GSK/admiral/blob/master/inst/example_scripts/ad_adsl.R})
 #'
 "adsl"
diff --git a/R/derive_extreme_flag.R b/R/derive_extreme_flag.R
@@ -24,8 +24,6 @@
 #'
 #'   Determines of the first or last observation is flagged.
 #'
-#'   Default: `"last"`
-#'
 #'   Permitted Values: `"first"`, `"last"`
 #'
 #' @param by_vars Grouping variables
@@ -72,6 +70,7 @@
 #'                     new_var = LASTFL,
 #'                     by_vars = rlang::exprs(USUBJID, VSTESTCD, VISIT),
 #'                     order = rlang::exprs(VSTPTNUM),
+#'                     mode = "last",
 #'                     flag_filter = rlang::expr(VISIT != "BASELINE")) %>%
 #'   arrange(USUBJID, VSTESTCD, VISITNUM, VSTPTNUM) %>%
 #'   select(USUBJID, VSTESTCD, VISIT, VSTPTNUM, VSSTRESN, LASTFL)
@@ -111,6 +110,7 @@
 #'   new_var = ABLFL,
 #'   by_vars = exprs(USUBJID, PARAMCD),
 #'   order = exprs(ADT),
+#'   mode = "last",
 #'   flag_filter = expr(AVISIT == "BASELINE")
 #' )
 #'
@@ -120,6 +120,7 @@
 #'   new_var = ABLFL,
 #'   by_vars = exprs(USUBJID, PARAMCD),
 #'   order = exprs(AVAL, ADT),
+#'   mode = "last",
 #'   flag_filter = expr(AVISIT == "BASELINE")
 #' )
 #'
@@ -129,6 +130,7 @@
 #'   new_var = ABLFL,
 #'   by_vars = exprs(USUBJID, PARAMCD),
 #'   order = exprs(desc(AVAL), ADT),
+#'   mode = "last",
 #'   flag_filter = expr(AVISIT == "BASELINE")
 #' )
 #'
@@ -138,15 +140,15 @@
 #'   new_var = ABLFL,
 #'   by_vars = exprs(USUBJID, PARAMCD),
 #'   order = exprs(ADT, desc(AVAL)),
+#'   mode = "last",
 #'   flag_filter = expr(AVISIT == "BASELINE" & DTYPE == "AVERAGE")
 #' )
 #'
-
 derive_extreme_flag <- function(dataset,
                                 new_var,
                                 by_vars,
                                 order,
-                                mode = "last",
+                                mode,
                                 flag_filter,
                                 check_type = "warning") {
   # check input parameters
@@ -166,7 +168,8 @@ derive_extreme_flag <- function(dataset,
 
   # create flag
   data <- data %>%
-    derive_obs_number(order = order,
+    derive_obs_number(new_var = temp_obs_nr,
+                      order = order,
                       by_vars = by_vars,
                       check_type = check_type)
 

diff --git a/R/derive_merged_vars.R b/R/derive_merged_vars.R
@@ -40,8 +40,6 @@
 #'   If the `filter_order` parameter is specified, the filter mode determines if
 #'   the first or last observation of each by group is selected.
 #'
-#'   Default: `"last"`
-#'
 #'   Permitted Values: `"first"`, `"last"`
 #'
 #' @param by_vars Grouping variables
@@ -83,7 +81,7 @@ derive_merged_vars <- function(dataset,
                                new_vars,
                                by_vars = exprs(USUBJID),
                                filter_order = NULL,
-                               filter_mode = "last") {
+                               filter_mode) {
   assert_has_variables(dataset, map_chr(by_vars, as_string))
   assert_has_variables(dataset_add, map_chr(by_vars, as_string))