add haven option to labels

DESCRIPTION

@@ -33,15 +33,15 @@ Imports:
     tidyselect,
     formattable,
     pillar,
-    vctrs
+    vctrs,
+    readr
 Suggests: 
     covr,
     knitr,
     labelled,
     lintr,
     openxlsx2 (>= 0.8),
     prettyunits,
-    readr,
     rmarkdown,
     skimr,
     testthat (>= 3.0.0),

NAMESPACE

@@ -56,6 +56,8 @@ importFrom(dplyr,slice)
 importFrom(dplyr,summarise)
 importFrom(formattable,percent)
 importFrom(lobstr,obj_size)
+importFrom(lubridate,is.Date)
+importFrom(lubridate,is.POSIXt)
 importFrom(lubridate,is.difftime)
 importFrom(lubridate,is.period)
 importFrom(pillar,tbl_sum)
@@ -67,6 +69,13 @@ importFrom(purrr,map_lgl)
 importFrom(purrr,pluck)
 importFrom(purrr,pmap_chr)
 importFrom(purrr,some)
+importFrom(readr,parse_character)
+importFrom(readr,parse_date)
+importFrom(readr,parse_datetime)
+importFrom(readr,parse_double)
+importFrom(readr,parse_integer)
+importFrom(readr,parse_logical)
+importFrom(readr,parse_time)
 importFrom(rlang,"!!!")
 importFrom(rlang,.data)
 importFrom(rlang,abort)
@@ -117,4 +126,5 @@ importFrom(tidyselect,eval_select)
 importFrom(tidyselect,everything)
 importFrom(tidyselect,starts_with)
 importFrom(tidyselect,where)
+importFrom(vctrs,vec_ptype)
 importFrom(vctrs,vec_ptype_abbr)

R/REDCapTidieR-package.R

@@ -8,7 +8,7 @@
 #' left_join mutate pull recode relocate rename row_number select slice summarise
 #' @importFrom formattable percent
 #' @importFrom lobstr obj_size
-#' @importFrom lubridate is.difftime is.period
+#' @importFrom lubridate is.difftime is.period is.POSIXt is.Date
 #' @importFrom purrr compose map map2 map_int map_lgl pluck pmap_chr some
 #' @importFrom REDCapR redcap_arm_export redcap_event_instruments redcap_instruments
 #' redcap_metadata_read redcap_read_oneshot sanitize_token
@@ -23,8 +23,10 @@
 #' @importFrom tidyr complete fill pivot_wider nest unnest unnest_wider
 #' @importFrom tidyselect all_of any_of ends_with eval_select everything
 #' starts_with where
-#' @importFrom vctrs vec_ptype_abbr
+#' @importFrom vctrs vec_ptype_abbr vec_ptype
 #' @importFrom pillar tbl_sum
+#' @importFrom readr parse_logical parse_integer parse_double parse_date parse_time
+#' parse_datetime parse_character
 "_PACKAGE"
 
 ## usethis namespace: start

R/read_redcap.R

@@ -36,9 +36,10 @@
 #' "https://server.org/apps/redcap/api/"). Required.
 #' @param token The user-specific string that serves as the password for a
 #' project. Required.
-#' @param raw_or_label A string (either 'raw' or 'label') that specifies whether
+#' @param raw_or_label A string (either 'raw', 'label', or 'haven') that specifies whether
 #' to export the raw coded values or the labels for the options of categorical
-#' fields. Default is 'label'.
+#' fields. Default is 'label'. If 'haven' is supplied, categorical fields are converted
+#' to `haven_labelled` vectors.
 #' @param forms A character vector of REDCap instrument names that specifies
 #' which instruments to import. Default is `NULL` which imports all instruments
 #' in the project.
@@ -84,13 +85,17 @@ read_redcap <- function(redcap_uri,
   check_arg_is_character(redcap_uri, len = 1, any.missing = FALSE)
   check_arg_is_character(token, len = 1, any.missing = FALSE)
   check_arg_is_valid_token(token)
-  check_arg_choices(raw_or_label, choices = c("label", "raw"))
+  check_arg_choices(raw_or_label, choices = c("label", "raw", "haven"))
   check_arg_is_character(forms, min.len = 1, null.ok = TRUE, any.missing = FALSE)
   check_arg_is_logical(export_survey_fields, len = 1, any.missing = FALSE, null.ok = TRUE)
   check_arg_is_logical(export_data_access_groups, len = 1, any.missing = FALSE, null.ok = TRUE)
   check_arg_is_logical(suppress_redcapr_messages, len = 1, any.missing = FALSE)
   check_arg_is_logical(allow_mixed_structure, len = 1, any.missing = FALSE)
 
+  if (raw_or_label == "haven") {
+    check_installed("labelled", reason = "to use `read_redcap()` with `raw_or_label = 'haven'`")
+  }
+
   # Load REDCap Metadata ----
   # Capture unexpected metadata API call errors
   db_metadata <- try_redcapr({
@@ -251,8 +256,8 @@ read_redcap <- function(redcap_uri,
       filter(.data$field_name_updated %in% names(db_data))
   }
 
-  if (raw_or_label == "label") {
-    db_data <- multi_choice_to_labels(db_data, db_metadata)
+  if (raw_or_label != "raw") {
+    db_data <- multi_choice_to_labels(db_data, db_metadata, raw_or_label)
   }
 
   # Longitudinal Arms Check and Cleaning Application ----

R/utils.R

@@ -397,10 +397,17 @@ update_data_col_names <- function(db_data, db_metadata) {
 #'
 #' @param db_data A REDCap database object
 #' @param db_metadata A REDCap metadata object
+#' @inheritParams read_redcap
 #'
 #' @keywords internal
 
-multi_choice_to_labels <- function(db_data, db_metadata) {
+multi_choice_to_labels <- function(db_data, db_metadata, raw_or_label = "label") {
+
+  if (raw_or_label == "label") {
+    label_handler <- apply_labs_factor
+  } else if (raw_or_label == "haven") {
+    label_handler <- apply_labs_haven
+  }
   # form_status_complete Column Handling ----
   # Must be done before the creation of form_status_complete
   # select columns that don't appear in field_name_updated and end with
@@ -411,28 +418,9 @@ multi_choice_to_labels <- function(db_data, db_metadata) {
 
   db_data <- db_data %>%
     mutate(
-      # Change double output of raw data to character
-      across(
-        .cols = all_of(form_status_cols),
-        .fns = ~ as.character(.)
-      ),
-      # Map constant values to raw values
-      across(
-        .cols = all_of(form_status_cols),
-        .fns = ~ case_when(
-          . == "0" ~ "Incomplete",
-          . == "1" ~ "Unverified",
-          . == "2" ~ "Complete"
-        )
-      ),
-      # Convert to factor
-      # Map constant values to raw values
       across(
         .cols = all_of(form_status_cols),
-        .fns = ~ factor(
-          .,
-          levels = c("Incomplete", "Unverified", "Complete")
-        )
+        .fns = ~ label_handler(., c("0" = "Incomplete", "1" = "Unverified", "2" = "Complete"), integer(0))
       )
     )
 
@@ -485,15 +473,120 @@ multi_choice_to_labels <- function(db_data, db_metadata) {
 
       # Replace values from db_data$(field_name) with label values from
       # parse_labels key
-      db_data[[field_name]] <- db_data[[field_name]] %>%
-        as.character() %>%
-        recode(!!!parse_labels_output) %>%
-        factor(levels = unique(parse_labels_output))
+
+      db_data[[field_name]] <- label_handler(
+        x = db_data[[field_name]],
+        labels = parse_labels_output,
+        ptype = db_data[[field_name]]
+      )
     }
   }
   db_data
 }
 
+#' @title
+#' Apply factor labels to a vector
+#'
+#' @param x a vector to label
+#' @param labels a named vector of labels in the format `c(value = label)`
+#' @param \dots unused
+#'
+#' @return
+#' factor
+#'
+#' @keywords internal
+apply_labs_factor <- function(x, labels, ...) {
+  as.character(x) %>%
+    recode(!!!labels) %>%
+    factor(levels = unique(labels))
+}
+
+#' @title
+#' Apply haven value labels to a vector
+#'
+#' @details
+#' Assumes a check_installed() has been run for `labelled`. Since `haven` preserves the
+#' underlying data values we need to make sure the data type of the value options in the metadata matches
+#' the data type of the values in the actual data. This function accepts a prototype, usually a column
+#' from db_data, and uses `force_cast()` to do a best-effort casting of the value options in the metadata
+#' to the same data type as `ptype`. The fallback is to convert `x` and the value labels to character.
+#'
+#' @param x a vector to label
+#' @param labels a named vector of labels in the format `c(value = label)`
+#' @param ptype vector to serve as prototype for label values
+#' @param \dots unused
+#'
+#' @return
+#' `haven_labelled` vector
+#'
+#' @keywords internal
+#'
+apply_labs_haven <- function(x, labels, ptype, ...) {
+  # set_value_labels expects labels in c(label = value) format so reverse them
+  labels <- invert_vec(labels)
+  # Try to cast values to match data type in data, catching any parsing warnings
+  cnd <- NULL
+  labels_cast <- withCallingHandlers({
+    force_cast(labels, ptype)
+  },
+  warning = function(w) {
+    cnd <- w
+    cnd_muffle(w)
+  })
+  if (!is.null(attr(labels_cast, "problems"))) {
+    # If there was parsing problem fall back to character
+    x <- as.character(x)
+    labels_cast <- force_cast(labels, character())
+  } else if (!is.null(cnd)) {
+    # If there was some other warning we didn't mean to catch it, so re-raise
+    cli_warn(cnd)
+  }
+
+  labelled::set_value_labels(x, .labels = labels_cast)
+}
+
+#' @title
+#' Swap vector names for values
+#'
+#' @param x a vector
+#'
+#' @return
+#' Vector with names and values reversed
+#'
+#' @keywords internal
+#'
+invert_vec <- function(x) {
+  out <- names(x)
+  # If there were no names do nothing
+  if (is.null(out)) {
+    return(x)
+  }
+  names(out) <- x
+  out
+}
+
+force_cast <- function(x, ptype) {
+  ptype <- vec_ptype(ptype)
+  if (is.logical(ptype)) {
+    out <- parse_logical(x)
+  } else if (is.integer(ptype)) {
+    out <- parse_integer(x)
+  } else if (is.numeric(ptype)) {
+    out <- parse_double(x)
+  } else if (is.Date(ptype)) {
+    out <- parse_date(x)
+  } else if (is.difftime(ptype)) {
+    out <- parse_time(x)
+  } else if (is.POSIXt(ptype)) {
+    out <- parse_datetime(x)
+  } else {
+    out <- parse_character(x)
+  }
+
+  names(out) <- names(x)
+  out
+}
+
 #' @title
 #' Utility function to extract the name of the project identifier field for
 #' a tibble of REDCap data