R/first_dose.R

In billdenney/Rsdtm: Study Data Tabulation Model (SDTM) import, export, and management assistance

#' Find the time of the first dose
#'
#' @param x The EX domain from SDTM or a list with the EX domain in an element
#'   named "EX" that contains the EX domain.
#' @param trt_value A vector of treatments (from the \code{trt_col}) that could
#'   be the first dose for a subject.
#' @param trt_col A vector of column names to search for \code{trt_value}.  Only
#'   one of these columns can be in \code{x}, and all others are ignored.
#' @param dtc_col The column to search for the dosing time.  Only one of these
#'   columns can be in \code{x}, and all others are ignored.
#' @param ... Arguments passed to methods.
#' @return A data frame with one column for each grouping level as generated by
#'   \code{dplyr::group_by} (the USUBJID column is used as the grouping if no
#'   groups are present) and one additional column named "DTC_first_dose"
#'   containing the date and time of the first dose.
#' @importFrom dplyr is_grouped_df group_by_at rename_at summarize_at
#' @importFrom lubridate is.POSIXt ymd_hms
#' @export
#' @family Date management and conversion
sdtm_first_dose <- function(x, ...)
  UseMethod("sdtm_first_dose")

#' @rdname sdtm_first_dose
#' @export
sdtm_first_dose.list <- function(x, ...) {
  if (!("EX" %in% names(x))) {
    stop("The list does not have an element named 'EX'")
  }
  sdtm_first_dose(x$EX, ...)
}

#' @rdname sdtm_first_dose
#' @export
sdtm_first_dose.data.frame <- function(x,
                                       trt_value=NULL,
                                       trt_col=c("EXTRT", "TRT"),
                                       dtc_col=c("EXSTDTC", "EXDTC", "STDTC", "DTC"),
                                       ...) {
  trt_col <- intersect(trt_col, names(x))
  dtc_col <- intersect(dtc_col, names(x))
  if (!(length(trt_col) == 1)) {
    stop("trt_col must only match a single column in x")
  } else if (!(length(dtc_col) == 1)) {
    stop("dtc_col must only match a single column in x")
  }
  if (is.null(trt_value)) {
    trt_value <- unique(stats::na.omit(x[[trt_col]]))
    if (length(trt_value) != 1) {
      stop("Only one value is expected in the trt_col (", trt_col, "), but ",
           length(trt_value), " different values found.  Please specify trt_value.")
    }
  }
  # Filter for the treatment of interest
  x <- x[x[[trt_col]] %in% trt_value,,drop=FALSE]
  # Group by subject if not already grouped
  if (!dplyr::is_grouped_df(x)) {
    x <- dplyr::group_by_at(.tbl=x, .vars="USUBJID")
  }
  x <- dplyr::rename_at(.tbl=x, .vars=dtc_col, .funs=function(x) "DTC_first_dose")
  ret <- dplyr::summarize_at(.tbl=x, .vars="DTC_first_dose", .funs=min, na.rm=TRUE)
  if (!lubridate::is.POSIXt(ret$DTC_first_dose)) {
    ret$DTC_first_dose <- lubridate::ymd_hms(ret$DTC_first_dose, truncated=5)
  }
  ret
}