Add text validation and choice consistency checks

NAMESPACE

@@ -64,6 +64,7 @@ importFrom(htmltools,tags)
 importFrom(purrr,flatten_chr)
 importFrom(purrr,map)
 importFrom(purrr,map_chr)
+importFrom(purrr,map_dbl)
 importFrom(purrr,map_lgl)
 importFrom(rlang,"!!!")
 importFrom(rlang,":=")

R/REDCapExploreR-package.R

@@ -9,7 +9,7 @@
 #' @importFrom ggplot2 aes element_blank element_text geom_tile ggplot labs
 #' scale_fill_gradientn scale_x_discrete scale_y_discrete theme theme_minimal
 #' @importFrom htmltools browsable htmlDependency tagList tags
-#' @importFrom purrr flatten_chr map map_chr map_lgl
+#' @importFrom purrr flatten_chr map map_chr map_dbl map_lgl
 #' @importFrom REDCapR redcap_arm_export redcap_event_instruments
 #' redcap_instruments redcap_event_read redcap_instrument_repeating
 #' redcap_metadata_read redcap_project_info_read redcap_read_oneshot

R/choices.R

@@ -47,18 +47,91 @@ get_choice_rows <- function(metadata) {
       metadata$choice_definition[[index]],
       "\\|"
     )[[1]]
+    parts <- strsplit(choices, ",", fixed = TRUE)
+    tibble(
+      field_order = metadata$field_order[[index]],
+      field_name = metadata$field_name[[index]],
+      form_name = metadata$form_name[[index]],
+      choice_type = tolower(metadata$field_type[[index]]),
+      choice_order = seq_along(choices),
+      choice_value = map_chr(parts, \(part) str_trim(part[[1]])),
+      choice_label = map_chr(parts, \(part) {
+        str_trim(paste(part[-1], collapse = ","))
+      })
+    )
+  }))
+}
 
-    bind_rows(map(seq_along(choices), \(choice_index) {
-      parts <- strsplit(choices[[choice_index]], ",", fixed = TRUE)[[1]]
-      tibble(
-        field_order = metadata$field_order[[index]],
-        field_name = metadata$field_name[[index]],
-        form_name = metadata$form_name[[index]],
-        choice_type = tolower(metadata$field_type[[index]]),
-        choice_order = choice_index,
-        choice_value = str_trim(parts[[1]]),
-        choice_label = str_trim(paste(parts[-1], collapse = ","))
-      )
-    }))
+get_project_choice_rows <- function(project) {
+  if ("choices" %in% names(project)) {
+    return(project$choices)
+  }
+
+  get_choice_rows(project$metadata)
+}
+
+get_invalid_choice_findings <- function(project) {
+  choices <- get_project_choice_rows(project)
+  fields <- choices |>
+    filter(.data$choice_type != "checkbox") |>
+    distinct(
+      .data$field_name,
+      .data$form_name,
+      .data$choice_type
+    )
+
+  bind_rows(map(seq_len(nrow(fields)), \(index) {
+    field <- fields$field_name[[index]]
+    allowed <- choices |>
+      filter(.data$field_name == .env$field) |>
+      pull(.data$choice_value)
+
+    if (!field %in% names(project$data)) {
+      return(get_empty_findings())
+    }
+
+    value <- as.character(project$data[[field]])
+    applicable <- get_form_applicable_rows(
+      project,
+      fields$form_name[[index]]
+    )
+    invalid <- applicable & !get_is_missing(value) & !value %in% allowed
+    get_invalid_choice_finding_rows(
+      project,
+      field,
+      fields$form_name[[index]],
+      invalid,
+      value[invalid],
+      allowed
+    )
   }))
 }
+
+get_invalid_choice_finding_rows <- function(
+  project,
+  field,
+  form_name,
+  invalid,
+  value,
+  allowed
+) {
+  if (!any(invalid)) {
+    return(get_empty_findings())
+  }
+
+  tibble(
+    check = "consistency",
+    issue = "invalid_choice_value",
+    severity = "warning",
+    scope = "record_field",
+    record_id = as.character(project$data[[project$record_id_field]][invalid]),
+    form_name = form_name,
+    event_name = get_event_values(project$data, invalid),
+    repeat_instrument = get_repeat_instrument_values(project$data, invalid),
+    repeat_instance = get_repeat_instance_values(project$data, invalid),
+    field_name = field,
+    value = value,
+    expected = paste("One of:", paste(allowed, collapse = ", ")),
+    message = paste("Field", field, "contains an invalid REDCap choice value.")
+  )
+}