0029 feedback create iso8601

.github/CONTRIBUTING.md

@@ -19,4 +19,4 @@ with the `{sdtm.oak}` philosophy and programming strategy. The team will try to
 review the issues within the next backlog meeting and give some initial
 feedback. Since we are not a 100% fully resourced software development team it
 might be that some issues will take longer to respond to depending on the amount
-of overall issues.
+of overall issues.

DESCRIPTION

@@ -19,7 +19,13 @@ Authors@R: c(
     person("Pfizer Inc", role = c("cph", "fnd"))
     )
 Maintainer: Rammprasad Ganapathy <[email protected]>
-Description: An EDC and Data Standard-agnostic SDTM data transformation engine designed for SDTM programming in R. Powered by metadata sdtm.oak can automate the conversion of raw clinical data to SDTM through standardized mapping  algorithms. SDTM is one of the required standards for data submission to  FDA (U.S.) and PMDA (Japan). SDTM standards are implemented in accordance with the SDTM Implemetation guide as defined by CDISC <https://www.cdisc.org/standards/foundational/sdtmig>
+Description: An EDC and Data Standard-agnostic SDTM data transformation engine
+    designed for SDTM programming in R. Powered by metadata sdtm.oak can
+    automate the conversion of raw clinical data to SDTM through standardized
+    mapping  algorithms. SDTM is one of the required standards for data
+    submission to  FDA (U.S.) and PMDA (Japan). SDTM standards are implemented
+    in accordance with the SDTM Implementation guide as defined by CDISC
+    <https://www.cdisc.org/standards/foundational/sdtmig>.
 Language: en-US
 License: Apache License (>= 2)
 BugReports: https://github.com/pharmaverse/sdtm.oak/issues

NAMESPACE

@@ -1,6 +1,8 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(print,iso8601)
 export(create_iso8601)
 export(fmt_cmp)
+export(problems)
 importFrom(rlang,.data)
 importFrom(tibble,tibble)

R/dtc_create_iso8601.R

@@ -337,6 +337,7 @@ format_iso8601 <- function(m, .cutoff_2000 = 68L) {
 #'   meaning to check against a selection of validated formats in
 #'   [dtc_formats][sdtm.oak::dtc_formats]; or to have a more permissible
 #'   interpretation of the formats.
+#' @param .warn Whether to warn about parsing failures.
 #'
 #' @examples
 #' # Converting dates
@@ -395,36 +396,75 @@ format_iso8601 <- function(m, .cutoff_2000 = 68L) {
 #' create_iso8601("05 feb 1985 12 55 02", .format = fmt, .fmt_c = fmt_cmp)
 #'
 #' @export
-create_iso8601 <- function(..., .format, .fmt_c = fmt_cmp(), .na = NULL, .cutoff_2000 = 68L, .check_format = FALSE) {
-  assert_fmt_c(.fmt_c)
+create_iso8601 <-
+  function(...,
+           .format,
+           .fmt_c = fmt_cmp(),
+           .na = NULL,
+           .cutoff_2000 = 68L,
+           .check_format = FALSE,
+           .warn = TRUE) {
+    assert_fmt_c(.fmt_c)
+    admiraldev::assert_logical_scalar(.check_format)
+    admiraldev::assert_logical_scalar(.warn)
 
-  dots <- rlang::dots_list(...)
+    dots <- rlang::dots_list(...)
 
-  if (rlang::is_empty(dots)) {
-    return(character())
-  }
+    if (rlang::is_empty(dots)) {
+      return(character())
+    }
 
-  # Check if all vectors in `dots` are of character type.
-  if (!identical(unique(sapply(dots, typeof)), "character")) {
-    rlang::abort("All vectors in `...` must be of type character.")
-  }
+    # Check if all vectors in `dots` are of character type.
+    if (!identical(unique(sapply(dots, typeof)), "character")) {
+      rlang::abort("All vectors in `...` must be of type character.")
+    }
 
-  # Check if all vectors in `dots` are of the same length.
-  n <- unique(lengths(dots))
-  if (!identical(length(n), 1L)) {
-    rlang::abort("All vectors in `...` must be of the same length.")
-  }
+    # Check if all vectors in `dots` are of the same length.
+    n <- unique(lengths(dots))
+    if (!identical(length(n), 1L)) {
+      rlang::abort("All vectors in `...` must be of the same length.")
+    }
 
-  if (!identical(length(dots), length(.format))) {
-    rlang::abort("Number of vectors in `...` should match length of `.format`.")
-  }
+    if (!identical(length(dots), length(.format))) {
+      rlang::abort("Number of vectors in `...` should match length of `.format`.")
+    }
+
+    # Check that the `.format` is either a character vector or a list of
+    # character vectors, and that each string is one of the possible formats.
+    if (.check_format) {
+      assert_dtc_format(.format)
+    }
 
-  # Check that the `.format` is either a character vector or a list of
-  # character vectors, and that each string is one of the possible formats.
-  if (.check_format) assert_dtc_format(.format)
+    cap_matrices <-
+      purrr::map2(
+        dots,
+        .format,
+        ~ parse_dttm(
+          dttm = .x,
+          fmt = .y,
+          na = .na,
+          fmt_c = .fmt_c
+        )
+      )
+    cap_matrix <- coalesce_capture_matrices(!!!cap_matrices)
 
-  cap_matrices <- purrr::map2(dots, .format, ~ parse_dttm(dttm = .x, fmt = .y, na = .na, fmt_c = .fmt_c))
-  cap_matrix <- coalesce_capture_matrices(!!!cap_matrices)
+    iso8601 <- format_iso8601(cap_matrix, .cutoff_2000 = .cutoff_2000)
+    any_prob <- any_problems(cap_matrices, .cutoff_2000 = .cutoff_2000)
+    iso8601 <- add_problems(iso8601, any_prob, dots)
+    class(iso8601) <- "iso8601"
 
-  format_iso8601(cap_matrix, .cutoff_2000 = .cutoff_2000)
+    if (.warn && rlang::is_interactive()) {
+      warn_problems(iso8601)
+    }
+
+    iso8601
+  }
+
+#' @export
+print.iso8601 <- function(x, ...) {
+  # Here we take advantage of the subset operator `[` dropping
+  # attributes. Also, using `seq_along()` should not force a copy of `x` thus
+  # being memory-efficient.
+  print(x[seq_along(x)])
+  invisible(x)
 }

R/dtc_parse_dttm.R

@@ -83,6 +83,9 @@ parse_dttm_ <- function(dttm,
 #' sdtm.oak:::parse_dttm(c("2002-05-11 11:45", "-05-11 11:45"), "-m-d H:M")
 #' sdtm.oak:::parse_dttm(c("2002-05-11 11:45", "-05-11 11:45"), c("y-m-d H:M", "-m-d H:M"))
 #'
+#' sdtm.oak:::parse_dttm("05 feb 1985 12 55 02", "d m y H M S")
+#' sdtm.oak:::parse_dttm("12 55 02 05 feb 1985", "H M S d m y")
+#'
 #' sdtm.oak:::parse_dttm(c("2020-05-18", "2020-UN-18", "2020-UNK-UN"), "y-m-d")
 #' sdtm.oak:::parse_dttm(c("2020-05-18", "2020-UN-18", "2020-UNK-UN"), "y-m-d", na = "UN")
 #' sdtm.oak:::parse_dttm(c("2020-05-18", "2020-UN-18", "2020-UNK-UN"), "y-m-d", na = c("UN", "UNK"))

R/dtc_problems.R

@@ -0,0 +1,209 @@
+#' Add ISO 8601 parsing problems
+#'
+#' @description
+#' [add_problems()] annotates the returned value of [create_iso8601()] with
+#' possible parsing problems. This annotation consists of a
+#' [tibble][tibble::tibble-package] of problems, one row for each parsing
+#' failure (see Details section).
+#'
+#' @details
+#' This function annotates its input `x`, a vector date-times in ISO 8601
+#' format, by creating an attribute named `problems`. This attribute's value
+#' is a [tibble][tibble::tibble-package] of parsing problems. The problematic
+#' date/times are indicated by the `logical` vector passed as argument to
+#' `is_problem`.
+#'
+#' The attribute `problems` in the returned value will contain a first column
+#' named `..i` that indicates the date/time index of the problematic date/time
+#' in `x`, and as many extra columns as there were inputs (passed in `dtc`). If
+#' `dtc` is named, then those names are used to name the extra columns,
+#' otherwise they get named sequentially like so `..var1`, `..var2`, etc..
+#'
+#' @param x A character vector of date-times in ISO 8601 format; typically, the
+#'   output of [format_iso8601()].
+#' @param is_problem A `logical` indicating which date/time inputs are
+#'   associated with parsing failures.
+#' @param dtc A list of `character` vectors of dates, times or date-times'
+#'   components. Typically, this parameter takes the value passed in `...` to
+#'   a [create_iso8601()] call.
+#'
+#' @returns Either `x` without any modification, if no parsing problems exist,
+#'   or an annotated `x`, meaning having a `problems` attribute that holds
+#'   parsing issues (see the Details section).
+#'
+#' @examples
+#' date <- c("2000-01-05", "", "1980-06-18", "1979-09-07")
+#' time <- c("001221", "22:35:05", "03:00:15", "07:09:00")
+#' dtc <- list(date, time)
+#' dttm <- c("2000-01-05", "T22:35:05", "1980-06-18T03:00:15", "1979-09-07T07:09:00")
+#' is_problem <- c(TRUE, TRUE, FALSE, FALSE)
+#'
+#' dttm2 <- sdtm.oak:::add_problems(dttm, is_problem, dtc)
+#' sdtm.oak:::problems(dttm2)
+#'
+#' @keywords internal
+add_problems <- function(x, is_problem, dtc) {
+  is_x_na <- is_problem
+  if (!any(is_x_na)) {
+    return(x)
+  }
+
+  names <- names(dtc)
+  bad_names <- duplicated(names) | names == ""
+  compat_names <- paste0("..var", seq_along(dtc))
+
+  if (is.null(names)) {
+    names <- compat_names
+  } else {
+    names[bad_names] <- compat_names[bad_names]
+  }
+
+  names(dtc) <- names
+
+  index <- which(is_problem)
+  problems <- tibble::as_tibble(dtc)[is_problem, ]
+  problems <- tibble::add_column(problems, ..i = index, .before = 1L)
+  attr(x, "problems") <- problems
+  x
+}
+
+#' Detect problems with the parsing of date/times
+#'
+#' @description
+#'
+#' [any_problems()] takes a list of capture matrices (see [parse_dttm()]) and
+#' reports on parsing problems by means of predicate values. A `FALSE` value
+#' indicates that the parsing was successful and a `TRUE` value a parsing
+#' failure in at least one of the inputs to [create_iso8601()]. Note that this
+#' is an internal function to be used in the context of [create_iso8601()]
+#' source code and hence each capture matrix corresponds to one input to
+#' [create_iso8601()].
+#'
+#' @param cap_matrices A list of capture matrices in the sense of the returned
+#' value by [parse_dttm()].
+#' @param .cutoff_2000 An integer value. Two-digit years smaller or equal to
+#'   `.cutoff_2000` are parsed as though starting with `20`, otherwise parsed as
+#'   though starting with `19`.
+#'
+#' @returns A `logical` whose length matches the number of underlying date/times
+#'   passed as inputs to [create_iso8601()], i.e. whose length matches the
+#'   number of rows of the capture matrices in `cap_matrices`.
+#'
+#' @examples
+#' # No problem (return value is `FALSE`).
+#' sdtm.oak:::any_problems(list(sdtm.oak:::parse_dttm("1980-06-18", "y-m-d")))
+#'
+#' # Now the parsing fails (return value is `TRUE`).
+#' sdtm.oak:::any_problems(list(sdtm.oak:::parse_dttm("1980-06-18", "ymd")))
+#'
+#' # Find if there has been a problem in either in the `date` or `time` inputs.
+#' # The following problems are expected with:
+#' #   - `"2001/12/25"` as it won't be parsed with the format `"y-m-d"`
+#' #   - `"00h12m21"` as it won't be parsed with the format `"H:M:S"`.
+#' #
+#' date <- c("2000-01-05", "2001/12/25", "1980-06-18", "1979-09-07")
+#' time <- c("00h12m21", "22:35:05", "03:00:15", "07:09:00")
+#'
+#' cap_matrix_date <- sdtm.oak:::parse_dttm(date, "y-m-d")
+#' cap_matrix_time <- sdtm.oak:::parse_dttm(time, "H:M:S")
+#'
+#' (cap_matrices <- list(cap_matrix_date, cap_matrix_time))
+#'
+#' # `any_problems()` returns `TRUE` for the first two elements because of the
+#' # failure to parse `"2001/12/25"` and `"00h12m21"`, respectively.
+#' sdtm.oak:::any_problems(cap_matrices)
+#'
+#' @keywords internal
+any_problems <- function(cap_matrices, .cutoff_2000 = 68L) {
+  cap_matrices |>
+    purrr::map(~ format_iso8601(.x, .cutoff_2000 = .cutoff_2000)) |>
+    unlist() |>
+    matrix(ncol = length(cap_matrices)) |>
+    is.na() |>
+    rowSums() |>
+    as.logical()
+}
+
+#' Retrieve date/time parsing problems
+#'
+#' [problems()] is a companion helper function to [create_iso8601()]. It
+#' retrieves ISO 8601 parsing problems from an object of class iso8601, which is
+#' [create_iso8601()]'s return value and that might contain a `problems`
+#' attribute in case of parsing failures. [problems()] is a helper function that
+#' provides easy access to these parsing problems.
+#'
+#' @param x An object of class iso8601, as typically obtained from a call to
+#'   [create_iso8601()]. The argument can also be left empty, in that case it
+#'   `problems()` will use the last returned value, making it convenient to use
+#'   immediately after [create_iso8601()].
+#'
+#' @returns If there are no parsing problems in `x`, then the returned value is
+#'   `NULL`; otherwise, a [tibble][tibble::tibble-package] of parsing failures
+#'   is returned. Each row corresponds to a parsing problem. There will be a
+#'   first column named `..i` indicating the position(s) in the inputs to the
+#'   [create_iso8601()] call that resulted in failures; remaining columns
+#'   correspond to the original input values passed on to [create_iso8601()],
+#'   with columns being automatically named `..var1`, `..var2`, and so on, if
+#'   the inputs to [create_iso8601()] were unnamed, otherwise, the original
+#'   variable names are used instead.
+#'
+#' @examples
+#' dates <-
+#'   c(
+#'     "2020-01-01",
+#'     "2020-02-11",
+#'     "2020-01-06",
+#'     "2020-0921",
+#'     "2020/10/30",
+#'     "2020-12-05",
+#'     "20231225"
+#'   )
+#'
+#' #' # By inspecting the problematic dates it can be understood that
+#' # the `.format` parameter needs to updated to include other variations.
+#' iso8601_dttm <- create_iso8601(dates, .format = "y-m-d")
+#' problems(iso8601_dttm)
+#'
+#' # Including more parsing formats addresses the previous problems
+#' formats <- c("y-m-d", "y-md", "y/m/d", "ymd")
+#' iso8601_dttm2 <- create_iso8601(dates, .format = list(formats))
+#'
+#' # So now `problems()` returns `NULL` because there are no more parsing issues.
+#' problems(iso8601_dttm2)
+#'
+#' # If you pass named arguments when calling `create_iso8601()` then they will
+#' # be used to create the problems object.
+#' iso8601_dttm3 <- create_iso8601(date = dates, .format = "y-m-d")
+#' problems(iso8601_dttm3)
+#'
+#' @export
+problems <- function(x = .Last.value) {
+  probs <- attr(x, "problems")
+  if (!is.null(probs)) {
+    probs
+  } else {
+    invisible(NULL)
+  }
+}
+
+n_problems <- function(x) {
+  probs <- problems(x)
+  if (is.null(probs)) {
+    return(0L)
+  } else {
+    nrow(probs)
+  }
+}
+
+warn_problems <- function(x) {
+  n_probs <- n_problems(x)
+  if (n_probs > 0L) {
+    msg <- paste(
+      sprintf("There were %d parsing problems.", n_probs),
+      "Run `problems()` on parsed results for details."
+    )
+    rlang::warn(msg)
+  }
+
+  invisible(NULL)
+}

R/dtc_utils.R

@@ -102,7 +102,7 @@ assert_capture_matrix <- function(m) {
 
   col_names <- c("year", "mon", "mday", "hour", "min", "sec")
   m_col_names <- colnames(m)
-  if (is.null(m_col_names) || !all(m_col_names %in% col_names)) {
+  if (is.null(m_col_names) || !all(m_col_names == col_names)) {
     rlang::abort("`m` must have the following colnames: `year`, `mon`, `mday`, `hour`, `min` and `sec`.")
   }
 
@@ -139,10 +139,17 @@ complete_capture_matrix <-
   function(m) {
     col_names <- c("year", "mon", "mday", "hour", "min", "sec")
 
-    if (setequal(col_names, colnames(m))) {
+    # If all columns are already present, and in the correct order,
+    # then simply return.
+    if (identical(col_names, colnames(m))) {
       return(m)
     }
 
+    # If all columns are present but not in the right order, then reorder.
+    if (setequal(col_names, colnames(m))) {
+      return(m[, col_names, drop = FALSE])
+    }
+
     miss_cols <- setdiff(col_names, colnames(m))
     miss_n_cols <- length(miss_cols)
 

inst/WORDLIST

@@ -7,3 +7,4 @@ dtc
 funder
 vectorized
 ORCID
+iso