Improve testing

DESCRIPTION

@@ -11,15 +11,17 @@ Description: Assist with management of clinical trial data in the SDTM and ADaM
   and verification of SDTM data.
 Depends: R (>= 3.5)
 Imports:
- dplyr,
- ggplot2,
- labeling,
- lubridate,
- methods,
- readr,
- rio,
- rlang,
- tidyr
+    dplyr,
+    ggplot2,
+    labeling,
+    lifecycle,
+    lubridate,
+    metatools,
+    methods,
+    readr,
+    rio,
+    rlang,
+    tidyr
 Suggests:
     covr,
     scales,

NAMESPACE

@@ -1,6 +1,14 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(c_to_n,character)
+S3method(c_to_n,data.frame)
+S3method(c_to_n,factor)
+S3method(c_to_n,integer)
+S3method(c_to_n,logical)
+S3method(c_to_n,numeric)
+S3method(sdtm_dtc_to_datetime,Date)
+S3method(sdtm_dtc_to_datetime,POSIXt)
+S3method(sdtm_dtc_to_datetime,character)
 S3method(sdtm_dtc_to_datetime,data.frame)
 S3method(sdtm_dtc_to_datetime,list)
 S3method(sdtm_first_dose,data.frame)
@@ -42,22 +50,14 @@ export(sdtm_first_dose)
 export(sdtm_time_actual)
 export(simplify_sdtm_names)
 export(standardize_sdtm_id)
-export(strip_attributes)
-export(supp_reformat)
-importFrom(dplyr,anti_join)
 importFrom(dplyr,case_when)
 importFrom(dplyr,group_by_at)
 importFrom(dplyr,is_grouped_df)
-importFrom(dplyr,recode)
 importFrom(dplyr,rename_all)
 importFrom(dplyr,rename_at)
 importFrom(dplyr,summarize_at)
 importFrom(lubridate,format_ISO8601)
 importFrom(lubridate,is.POSIXt)
 importFrom(lubridate,ymd_hms)
-importFrom(readr,type_convert)
 importFrom(rio,import)
-importFrom(rlang,abort)
-importFrom(rlang,inform)
-importFrom(tidyr,spread)
 importFrom(tools,file_path_sans_ext)

NEWS.md

@@ -0,0 +1,4 @@
+# Rsdtm 0.0.9017
+
+* Added `auto_supp` and `auto_dtc` arguments to `import_sdtm()`
+* Removed `merge_supp()` and related functions in favor of `metatools::combine_supp()`

R/c_to_n.R

@@ -57,23 +57,27 @@ c_to_n.character <- function(x, ...,
 }
 
 #' @describeIn c_to_n For factors.
+#' @export
 c_to_n.factor <- function(x, ...) {
   c_to_n.character(as.character(x), ...)
 }
 
 #' @describeIn c_to_n For numeric vectors.
+#' @export
 c_to_n.numeric <- function(x, ...) {
   warning("`c_to_n` is generally not called on a numeric vector.  Please verify code.")
   x
 }
 
 #' @describeIn c_to_n For integer vectors.
+#' @export
 c_to_n.integer <- function(x, ...) {
   warning("`c_to_n` is generally not called on an integer vector.  Please verify code.")
   x
 }
 
 #' @describeIn c_to_n For logical vectors (only handles all-NA case).
+#' @export
 c_to_n.logical <- function(x, ...) {
   if (!all(is.na(x))) {
     warning("`c_to_n` does not set non-NA logical values to numeric.")
@@ -84,6 +88,7 @@ c_to_n.logical <- function(x, ...) {
 #' @describeIn c_to_n For data.frames and similar, finds columns matching the
 #'   regular expression pattern `"^..(ST|OR).*C$"`.  data.frame method does not
 #'   replace numeric columns that already exist.
+#' @export
 c_to_n.data.frame <- function(x, ..., verbose=TRUE) {
   columns_named_c <- grep(pattern="^..(ST|OR).*C$", x=names(x), value=TRUE)
   columns_named_n <- grep(pattern="^..(ST|OR).*N$", x=names(x), value=TRUE)

R/date_conversion.R

@@ -3,8 +3,11 @@
 #'
 #' @param x The data to convert
 #' @param date_col_pattern A regex to search column names for dates to convert.
-#' @param truncated Passed to \code{lubridate::ymd_hms}
-#' @param ... Additional arguments passed to \code{lubridate::ymd_hms}
+#' @param truncated Passed to `lubridate::ymd_hms()` or `lubridate::ymd()`; the
+#'   `truncated` argument is always considered relative to `ymd_hms` formatting,
+#'   so it is used as `truncated - 3` for dates.
+#' @param ... Additional arguments passed to `lubridate::ymd_hms()` or
+#'   `lubridate::ymd()`
 #' @return The data with the date converted.  Note that all dates will be
 #'   returned as POSIXct objects, so partial dates will appear as the
 #' @family Date management and conversion
@@ -16,21 +19,51 @@
 #' @rdname sdtm_dtc_to_datetime
 #' @export
 sdtm_dtc_to_datetime.list <- function(x, ...) {
-  lapply(X=x,
-         FUN=sdtm_dtc_to_datetime,
-         ...)
+  lapply(X=x, FUN=sdtm_dtc_to_datetime, ...)
 }
 
 #' @rdname sdtm_dtc_to_datetime
 #' @export
-sdtm_dtc_to_datetime.data.frame <- function(x, date_col_pattern="DTC$", truncated=5, ...) {
+sdtm_dtc_to_datetime.Date <- function(x, ...) {
+  x
+}
+
+#' @rdname sdtm_dtc_to_datetime
+#' @export
+sdtm_dtc_to_datetime.POSIXt <- function(x, ...) {
+  x
+}
+
+#' @rdname sdtm_dtc_to_datetime
+#' @export
+sdtm_dtc_to_datetime.character <- function(x, truncated=5, ...) {
+  # Treat empty strings as NA
+  x_current <- x
+  x_current[x_current %in% ""] <- NA_character_
+
+  # Detect columns that only contain dates and load them as dates rather than
+  # datetimes
+  is_date <-
+    grepl(
+      x = x_current,
+      pattern = paste0("^", pattern_ISO8601_calendar_date(), "$")
+    )
+  if (all(is.na(x_current) | is_date)) {
+    # If it is a date
+    x <- lubridate::ymd(x_current, truncated=max(truncated - 3, 0), ...)
+  } else {
+    # Otherwise try to consider it a datetime
+    x <- lubridate::ymd_hms(x_current, truncated=truncated, ...)
+  }
+  x
+}
+
+#' @rdname sdtm_dtc_to_datetime
+#' @export
+sdtm_dtc_to_datetime.data.frame <- function(x, date_col_pattern="DTC$", ...) {
   date_col_names <- grep(names(x), pattern=date_col_pattern, value=TRUE)
   for (current_name in date_col_names) {
-    if (!lubridate::is.POSIXt(x[[current_name]])) {
-      x[[current_name]] <- ymd_hms(x[[current_name]], truncated=truncated, ...)
-    } else {
-      message("Column ", current_name, " is already a datetime object.")
-    }
+    x[[current_name]] <- sdtm_dtc_to_datetime(x[[current_name]])
   }
   x
 }

R/import_sdtm.R

@@ -6,6 +6,9 @@
 #'   first extension in \code{extension_choice} with a usable file will be used,
 #'   and a warning will be given for subsequent files.
 #' @param ignore_case Passed to \code{list.files} when loading a directory.
+#' @param auto_supp Automatically combine --SUPP data with the main SDTM domain
+#'   and remove the --SUPP data from the returned list of data.frames.
+#' @param auto_dtc Automatically convert --DTC columns to date/times?
 #' @param return_type When loading a single file, what type of output should be
 #'   provided?
 #' @param ... Arguments passed to \code{rio::import}
@@ -22,6 +25,8 @@
 import_sdtm <- function(path,
                         extension_choice = c(".sas7bdat", ".xpt"),
                         ignore_case = TRUE,
+                        auto_supp = FALSE,
+                        auto_dtc = FALSE,
                         ...) {
   stopifnot(
     is.character(path),
@@ -54,6 +59,22 @@ import_sdtm <- function(path,
     )
     ret <- append_no_duplicate_names(ret, tmp_ret, method=stop)
   }
+
+  if (auto_supp) {
+    supp_domains <- names(ret)[startsWith(names(ret), "SUPP")]
+    for (current_supp in supp_domains) {
+      current_domain <- gsub(x = current_supp, pattern = "^SUPP", replacement = "")
+      if (!(current_domain %in% names(ret))) {
+        stop("Domain ", current_domain, " was not found when trying to auto-combine --SUPP data with ", current_supp)
+      }
+      ret[[current_domain]] <- metatools::combine_supp(ret[[current_domain]], supp = ret[[current_supp]])
+      ret[[current_supp]] <- NULL
+    }
+  }
+
+  if (auto_dtc) {
+    ret <- sdtm_dtc_to_datetime(ret, ...)
+  }
   ret
 }