0029 feedback create iso8601

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,71 @@ 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)
+    iso8601 <- add_problems(iso8601, 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,103 @@
+add_problems <- function(x, dtc) {
+  is_x_na <- is.na(x)
+  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_x_na)
+  problems <- tibble::as_tibble(dtc)[is_x_na, ]
+  problems <- tibble::add_column(problems, ..i = index, .before = 1L)
+  attr(x, "problems") <- problems
+  x
+}
+
+#' 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 inspect the problematic dates it can be understood that
+#' # the `.format` parameter needs to update 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)
+#'
+#' @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 parsing %d 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)