R/checks.R

In REDCapTidieR: Extract 'REDCap' Databases into Tidy 'Tibble's

#' @title
#' Check for possible API user privilege issues

#' @description
#' Check for potential user access privilege issues and provide an appropriate
#' warning message. This can occur when metadata forms/field names do not appear
#' in a database export.
#'
#' @return
#' A helpful error message alerting the user to check their API privileges.
#'
#' @param db_data The REDCap database output generated by
#' \code{REDCapR::redcap_read_oneshot()$data}
#' @param db_metadata The REDCap metadata output generated by \code{REDCapR::redcap_metadata_read()$data}
#' @param call the calling environment to use in the warning message
#'
#' @keywords internal

check_user_rights <- function(db_data,
                              db_metadata,
                              call = caller_env()) {
  # Set condition components used in both error and warning
  msg_info <- c("i" = "This can happen when the user privileges are not set to allow exporting certain
    instruments via the API.")
  cond_class <- c("redcap_user_rights", "REDCapTidieR_cond")

  db_fields <- names(db_data)
  # Fields in metadata excluding record ID
  metadata_fields <- setdiff(db_metadata$field_name_updated, get_record_id_field(db_data))

  # If no data fields were returned the user has no data access
  if (length(intersect(db_fields, metadata_fields)) == 0) {
    cli_abort(
      c(
        "x" = "The REDCap API returned no data for any of the requested instruments.",
        msg_info
      ),
      class = c("no_data_access", cond_class),
      call = call
    )
  }

  missing_db_metadata <- db_metadata %>%
    select("field_name_updated", "form_name") %>%
    group_by(.data$form_name) %>%
    filter(!all(.data$field_name_updated %in% db_fields)) %>%
    summarise(
      # record if all fields missing for custom warning message
      all_fields_missing = !any(.data$field_name_updated %in% db_fields),
      missing_fields = list(setdiff(.data$field_name_updated, db_fields))
    )

  # Build message for each instrument
  msg <- pmap_chr(
    missing_db_metadata,
    .f = function(form_name, missing_fields, all_fields_missing) {
      if (all_fields_missing) {
        cli_text("Instrument {.code {form_name}} returned no data and will be removed from the output.") %>%
          cli_fmt(collapse = TRUE, strip_newline = TRUE)
      } else {
        cli_text("Instrument {.code {form_name}} is missing {qty(missing_fields)} field{?s}
                 {.code {missing_fields}}.") %>%
          cli_fmt(collapse = TRUE, strip_newline = TRUE)
      }
    }
  )

  names(msg) <- rep("!", length(msg))

  msg <- c(
    "!" = "{qty(missing_db_metadata$form_name)}{?An/Some} instrument{?s} exist{?s/} in the
    metadata but {?is/are} not found in the database export.",
    msg_info,
    msg
  )

  cli_warn(
    msg,
    class = c("partial_data_access", cond_class),
    call = call
  )
}

#' @title
#' Check for instruments that have both repeating and non-repeating structure
#'
#' @description
#' Check for potential instruments that are given both repeating and
#' nonrepeating structure. \code{REDCapTidieR} does not support database
#' structures built this way.
#'
#' @return
#' A helpful error message alerting the user to existence of an instrument
#' that was designated both as repeating and non-repeating.
#'
#' @param db_data The REDCap database output generated by
#' \code{REDCapR::redcap_read_oneshot()$data}
#' @param call the calling environment to use in the error message
#'
#' @keywords internal


check_repeat_and_nonrepeat <- function(db_data, call = caller_env()) {
  out <- get_mixed_structure_fields(db_data = db_data)

  # Filter for violations
  out <- out %>%
    filter(.data$rep_and_nonrep)

  # Produce error message if violations detected
  if (nrow(out) > 0) {
    cli_abort(
      c(
        "x" = "Instrument{?s} detected that ha{?s/ve} both repeating and
      nonrepeating instances defined in the project: {out$field}",
        "i" = paste0(
          "Set {.code allow_mixed_structure} to {.code TRUE} to override. ",
          "See ",
          "{.href [Mixed Structure Instruments](https://chop-cgtinformatics.github.io/REDCapTidieR/articles/diving_deeper.html#mixed-structure-instruments)} ", # nolint line_length_linter
          "for more information."
        )
      ),
      class = c("repeat_nonrepeat_instrument", "REDCapTidieR_cond"),
      call = call
    )
  }
}

#' @title
#' Check that a supplied REDCap database is populated

#' @description
#' Check for potential outputs where metadata is present, but \code{nrow} and
#' \code{ncol} equal `0`. This causes \code{multi_choice_to_labels} to fail, but
#' a helpful error message should be provided.
#'
#' @return
#' A helpful error message alerting the user to check their API privileges.
#'
#' @param db_data The REDCap database output generated by
#' \code{REDCapR::redcap_read_oneshot()$data}
#' @param call the calling environment to use in the error message
#'
#' @keywords internal

check_redcap_populated <- function(db_data, call = caller_env()) {
  if (ncol(db_data) == 0) {
    cli_abort(
      "The REDCap API did not return any data. This can happen when there are no
      data entered or when the access isn't configured to allow data export
      through the API.",
      class = c("redcap_unpopulated", "REDCapTidieR_cond"),
      call = call
    )
  }
}


#' @title
#' Check that all requested instruments are in REDCap project metadata
#'
#' @description
#' Provide an error message when any instrument names are passed to
#' \code{read_redcap()} that do not exist in the project metadata.
#'
#' @return
#' An error message listing the requested instruments that don't exist
#'
#' @param db_metadata The metadata file read by
#' \code{REDCapR::redcap_metadata_read()}
#' @param forms The character vector of instrument names passed to
#' \code{read_redcap()}
#' @param call the calling environment to use in the error message
#'
#' @keywords internal
check_forms_exist <- function(db_metadata, forms, call = caller_env()) {
  missing_forms <- setdiff(forms, unique(db_metadata$form_name))

  if (length(missing_forms) > 0) {
    cli_abort(
      c("x" = "Instrument{?s} {missing_forms} {?does/do} not exist in REDCap
        project"),
      class = c("form_does_not_exist", "REDCapTidieR_cond"),
      call = call
    )
  }
}

#' @title
#' Check that all metadata tibbles within a supertibble contain
#' \code{field_name} and \code{field_label} columns
#'
#' @param supertbl a supertibble containing a \code{redcap_metadata} column
#' @param call the calling environment to use in the error message
#'
#' @return
#' an error message alerting that instrument metadata is incomplete
#'
#' @keywords internal
check_req_labelled_metadata_fields <- function(supertbl, call = caller_env()) {
  req_fields <- c("field_name", "field_label") # nolint: object_usage_linter

  # map over each metadata tibble and return list element with missing fields
  missing_fields <- supertbl$redcap_metadata %>%
    map(~ setdiff(req_fields, colnames(.)))

  # If any missing fields were found error
  if (length(unlist(missing_fields)) > 0) {
    # Build error message bullets of the form:
    # x: {form} is missing {missing fields}
    msg_data <- tibble(missing_fields = missing_fields)

    # Instrument names to use in message. Use redcap_form_name if available
    # but don't assume it's in the data
    if ("redcap_form_name" %in% colnames(supertbl)) {
      msg_data$form <- supertbl$redcap_form_name
    } else {
      msg_data$form <- paste0(
        "supertbl$redcap_metadata[[", seq_along(missing_fields), "]]"
      )
    }

    # Drop rows without missing fields
    msg_data <- msg_data %>%
      filter(map_int(.data$missing_fields, length) > 0)

    # Create vector of messages and apply 'x' label
    msg <- paste0(
      "{.code {msg_data$form[[", seq_len(nrow(msg_data)), "]]}} ",
      "is missing {.code {msg_data$missing_fields[[", seq_len(nrow(msg_data)), "]]}}"
    )

    names(msg) <- rep("x", length(msg))

    # Prepend note about required fields
    msg <- c(
      "!" = "All elements of {.arg supertbl$redcap_metadata} must contain {.code {req_fields}}",
      msg
    )

    cli_abort(
      msg,
      class = c("missing_req_labelled_metadata_fields", "REDCapTidieR_cond"),
      call = call
    )
  }
}


#' @title
#' Check that parsed labels are not duplicated
#'
#' @param parsed_labels_output a vector of parsed labels produced by `parse_labels()`
#' @param field_name the name of the field associated with the labels to use in the warning message
#' @param warn_stripped_text logical for whether to include a note about HTML tag stripping in the message
#' @param call the calling environment to use in the error message. The parent of calling environment
#' by default because this check usually occurs 2 frames below the relevant context for the user
#'
#' @return
#' a warning message alerting specifying the duplicate labels and REDCap field affected
#'
#' @keywords internal
check_parsed_labels <- function(parsed_labels_output,
                                field_name,
                                warn_stripped_text = FALSE,
                                call = caller_env(n = 2)) {
  # Are any labels ""
  blank_labs <- any(parsed_labels_output == "", na.rm = TRUE)
  # Are any labels duplicated
  dup_labs <- any(duplicated(parsed_labels_output), na.rm = TRUE)

  # If neither early return
  if (!blank_labs && !dup_labs) {
    return(NULL)
  }

  # Only issue duplicate label warning if not issuing blank label warning
  if (blank_labs) {
    vals <- names(parsed_labels_output[parsed_labels_output == ""]) # nolint: object_usage_linter

    msg <- c(
      "!" = "The {qty(vals)} value{?s} {.code {vals}} in field {.code {field_name}} are mapped to a blank label `''`"
    )

    msg_info <- c(
      "i" = "Consider providing labels or setting `raw_or_label = 'raw'`"
    )

    class <- "blank_labels"
  } else {
    dups <- parsed_labels_output[duplicated(parsed_labels_output)] # nolint: object_usage_linter

    msg <- c(
      "!" = "Multiple values are mapped to the {qty(dups)} label{?s} {.code {dups}} in field {.code {field_name}}"
    )

    msg_info <- c(
      "i" = "Consider making the labels for {.code {field_name}} unique in your REDCap project"
    )

    class <- "duplicate_labels"
  }

  # Add additional info if we stripped text from the labels
  if (warn_stripped_text) {
    msg_info <- c(
      c("i" = "This may happen if the label only contains HTML"),
      msg_info
    )
  }

  cli_warn(
    c(msg, msg_info),
    class = c(class, "REDCapTidieR_cond"),
    call = call,
    field = field_name
  )
}

#' @title
#' Check an argument with checkmate
#'
#' @param x An object to check
#' @param arg The name of the argument to include in an error message. Captured
#' by `rlang::caller_arg()` by default
#' @param call the calling environment to use in the error message
#' @param req_cols required fields for `check_arg_is_supertbl()`
#' @param ... additional arguments passed on to checkmate
#'
#' @return
#' `TRUE` if `x` passes the checkmate check. An error otherwise with the name of
#' the checkmate function as a `class`
#'
#' @name checkmate
#' @keywords internal
NULL

# Function factory to wrap checkmate functions
#' @noRd
wrap_checkmate <- function(f) {
  error_class <- caller_arg(f)

  function(x, ..., arg = caller_arg(x), call = caller_env()) {
    out <- f(x, ...)

    if (isTRUE(out)) {
      return(TRUE)
    }

    cli_abort(
      message = c(
        "x" = "You've supplied {.code {format_error_val(x)}} for {.arg {arg}} which is not a valid value",
        "!" = "{out}"
      ),
      class = c(error_class, "REDCapTidieR_cond"),
      call = call
    )
  }
}

#' @rdname checkmate
check_arg_is_supertbl <- function(x,
                                  req_cols = c("redcap_data", "redcap_metadata"),
                                  arg = caller_arg(x),
                                  call = caller_env()) {
  # shared data for all messages
  msg_x <- "You've supplied {.code {format_error_val(x)}} for {.arg {arg}} which is not a valid value"
  msg_info <- "{.arg {arg}} must be a {.pkg REDCapTidieR} supertibble, generated using {.code read_redcap()}"
  msg_class <- c("check_supertbl", "REDCapTidieR_cond")

  if (!inherits(x, "redcap_supertbl")) {
    cli_abort(
      message = c(
        "x" = msg_x,
        "!" = "Must be of class {.cls redcap_supertbl}",
        "i" = msg_info
      ),
      class = msg_class,
      call = call
    )
  }

  missing_cols <- setdiff(req_cols, colnames(x))

  # If any are missing give an error message
  if (length(missing_cols) > 0) {
    cli_abort(
      message = c(
        "x" = msg_x,
        "!" = "Must contain {.code {paste0(arg, '$', missing_cols)}}",
        "i" = msg_info
      ),
      class = c("missing_req_cols", msg_class),
      call = call,
      missing_cols = missing_cols
    )
  }

  non_list_cols <- map_lgl(x[req_cols], ~ !is_bare_list(.))
  non_list_cols <- req_cols[non_list_cols]

  if (length(non_list_cols) > 0) {
    cli_abort(
      message = c(
        "x" = msg_x,
        "!" = "{.code {paste0(arg, '$', non_list_cols)}} must be of type 'list'",
        "i" = msg_info
      ),
      class = c("missing_req_list_cols", msg_class),
      call = call,
      non_list_cols = non_list_cols
    )
  }

  return(TRUE)
}

#' @rdname checkmate
check_arg_is_env <- wrap_checkmate(check_environment)

#' @rdname checkmate
check_arg_is_character <- wrap_checkmate(check_character)

#' @rdname checkmate
check_arg_is_logical <- wrap_checkmate(check_logical)

#' @rdname checkmate
check_arg_choices <- wrap_checkmate(check_choice)

#' @rdname checkmate
check_arg_is_valid_token <- function(x,
                                     arg = caller_arg(x),
                                     call = caller_env()) {
  try_fetch(
    sanitize_token(x),
    error = function(cnd) {
      cli_abort(
        message = c(
          "x" = "{cnd$message}",
          "i" = "API token: `{x}`"
        ),
        class = c("invalid_token", "REDCapTidieR_cond"),
        call = call
      )
    }
  )

  return(TRUE)
}

#' @title
#' Format value for error message
#'
#' @param x value to format
#'
#' @return
#' If x is atomic, x with cli formatting to truncate to 5 values. Otherwise,
#' a string summarizing x produced by as_label
#'
#' @keywords internal
format_error_val <- function(x) {
  if (is_atomic(x)) {
    out <- cli_vec(x, style = list("vec-trunc" = 5, "vec-last" = ", "))
  } else {
    out <- as_label(x)
  }
  out
}

#' @rdname checkmate
check_arg_is_valid_extension <- function(x,
                                         valid_extensions,
                                         arg = caller_arg(x),
                                         call = caller_env()) {
  ext <- sub(".*\\.", "", x)

  if (ext == x) {
    msg_x <- "No extension provided for {.arg file}: '{x}'"
    msg_i <- "The extension '.xlsx' will be appended to the file name."
  } else {
    msg_x <- "Invalid file extension provided for {.arg file}: {ext}"
    msg_i <- "The file extension should be '.xlsx'"
  }

  if (!ext %in% valid_extensions) {
    cli_warn(
      message = c(
        "!" = msg_x,
        "i" = msg_i
      ),
      class = c("invalid_file_extension", "REDCapTidieR_cond"),
      call = call
    )
  }

  return(TRUE)
}


#' @title
#' Check requested data argument exists in REDCap data
#'
#' @description
#' Provide an error message when an argument is requested, but is not found in
#' any \code{read_redcap()} `redcap_data` output.
#'
#' @details
#' Currently used for the following arguments:
##' \itemize{
#'  \item{`export_survey_fields`: `*_timestamp`}
#'  \item{`export_data_access_groups`: `redcap_data_access_group`}
#' }
#'
#' @return
#' An error message saying the requested data does not exist
#'
#' @param db_data The REDCap database output generated by
#' \code{REDCapR::redcap_read_oneshot()$data}
#' @param col The column to check for in `redcap_data`
#' @param arg The argument used for the column check
#' @param call The calling environment to use in the error message
#'
#' @keywords internal
check_data_arg_exists <- function(db_data, col, arg, call = caller_env()) {
  if (arg == "export_survey_fields") {
    msg_x <- "Project survey fields requested, but none found."
    msg_i <- "Are you sure the project has at least one instrument configured as a survey?"
  } else {
    msg_x <- "Data access groups requested, but none found."
    msg_i <- "Are you sure the project has data access groups (DAGs) enabled?"
  }

  if (!col %in% names(db_data)) {
    cli_abort(
      message = c(
        "x" = msg_x,
        "i" = msg_i
      ),
      class = c("nonexistent_arg_requested", "REDCapTidieR_cond"),
      call = call
    )
  }
}

#' @title
#' Check if file already exists
#'
#' @description
#' Provide an error message when a file is declared for writing that already
#' exists.
#'
#' @details
#' In the case of `write_redcap_xlsx()`, this should only error when a file
#' already exists and is not declared for `overwite`.
#'
#' @return
#' An error message saying the requested file already exists
#'
#' @param file The file that is being checked
#' @param overwrite Whether the file was declared to be overwritten
#' @param call The calling environment to use in the error message
#'
#' @keywords internal
check_file_exists <- function(file, overwrite, call = caller_env()) {
  msg_x <- "File '{.file {file}}' already exists."
  msg_i <- "Overwriting files is disabled by default. Set {.arg overwrite = TRUE}
  to overwrite existing file."

  if (file.exists(file) && !overwrite) {
    cli_abort(
      message = c(
        "x" = msg_x,
        "i" = msg_i
      ),
      class = c("check_file_overwrite", "REDCapTidieR_cond"),
      call = call
    )
  }
}

#' @title
#' Parse logical field and compile data for warning if parsing errors occurred
#'
#' @param x vector to parse
#'
#' @keywords internal
check_field_is_logical <- function(x) {
  out <- list(parsed = NULL, problems = NULL)
  # If already logical just return it
  if (is.logical(x)) {
    out$parsed <- x
    return(out)
  }
  # Parse
  cnd <- NULL
  out$parsed <- withCallingHandlers(
    {
      parse_logical(as.character(x))
    },
    warning = function(w) {
      cnd <<- w
      cnd_muffle(w)
    }
  )
  # Check for parsing failures and warn if found
  probs <- attr(out$parsed, "problems")
  if (!is.null(probs)) {
    if (!getOption("redcaptidier.allow.mdc", FALSE)) {
      out$problems <- unique(probs$actual)
    }
    attr(out$parsed, "problems") <- NULL
  } else if (!is.null(cnd)) {
    # If there was some other warning we didn't mean to catch it, so re-raise
    cli_warn(cnd)
  }
  out
}

#' @title
#' Check data field for field values not in metadata
#'
#' @param x data field
#' @param values expected field values
#'
#' @keywords internal
check_extra_field_values <- function(x, values) {
  extra_vals <- setdiff(as.character(x), values) %>% na.omit()
  if (length(extra_vals) == 0) {
    return(NULL)
  }
  as.character(extra_vals)
}

check_extra_field_values_message <- function(extra_field_values, call = caller_env()) {
  extra_field_values <- extra_field_values %>%
    discard(is.null)

  if (length(extra_field_values) == 0) {
    return(NULL)
  }

  fields <- names(extra_field_values)
  values <- flatten_chr(extra_field_values) %>% unique()

  msg <- c(
    `!` = "{.code {fields}} contain{?s/} values with no labels: {values}",
    i = "These were converted to {.code NA} resulting in possible data loss",
    i = "Does your REDCap project utilize missing data codes?",
    i = paste(
      "Silence this warning with {.code options(redcaptidier.allow.mdc = TRUE)} or",
      "set {.code raw_or_label = 'raw'} to access missing data codes"
    )
  )
  cli_warn(
    msg,
    class = c("extra_field_values", "REDCapTidieR_cond"),
    call = call,
    fields = fields,
    values = values
  )
}

#' @title
#' Check fields exist for checkbox combination
#'
#' @param fields Vector of character strings to check the length of
#' @param expr An expression
#' @param call The calling environment to use in the error message
#'
#' @keywords internal
check_fields_exist <- function(fields, expr, call = caller_env()) {
  expr <- quo_name(expr)

  if (length(fields) == 0) {
    msg <- c(
      x = "No fields detected using `{expr}`.",
      i = "Ensure that the column names specified in {.arg cols} match the columns in your data. Check for typos or use {.pkg tidyselect} helpers like {.code starts_with()}, `contains()`, etc." # nolint: line_length_linter
    )

    cli_abort(
      msg,
      class = c("missing_checkbox_fields", "REDCapTidieR_cond")
    )
  }
}

#' @title
#' Check metadata fields exist for checkbox combination
#'
#' @description
#' Similar to [check_fields_exist()], but instead of verifying fields that exist
#' in the data tibble this seeks to verify their existence under the metadata
#' tibble `field_name`s.
#'
#' @param metadata_tbl A metadata tibble from the supertibble generated by [read_redcap()].
#' @param cols Selected columns identified for [`combine_checkboxes()`] to be
#' cross checked against `metadata_tibble$field_name`
#' @param call The calling environment to use in the error message
#'
#' @keywords internal
check_metadata_fields_exist <- function(metadata_tbl, cols, call = caller_env()) {
  if (!all(cols %in% metadata_tbl$field_name)) {
    msg <- c(
      x = "Fields detected not present in metadata.",
      `!` = "Column{?s} {.code {cols[!cols %in% metadata_tbl$field_name]}} detected as valid in the data tibble, but not found present in the metadata tibble.", # nolint: line_length_linter
      `i` = "This may occur if either the names of the data tibble or the metadata tibble `field_name`s were edited."
    )

    cli_abort(
      msg,
      class = c("missing_metadata_checkbox_fields", "REDCapTidieR_cond")
    )
  }
}


#' @title
#' Check fields are of checkbox field type
#'
#' @param metadata_tbl A metadata tibble from a supertibble
#' @param call The calling environment to use in the error message
#'
#' @keywords internal

check_fields_are_checkboxes <- function(metadata_tbl, call = caller_env()) {
  non_checkboxes <- metadata_tbl %>%
    filter(.data$field_type != "checkbox")

  if (nrow(non_checkboxes) > 0) {
    non_checkboxes <- non_checkboxes %>%
      pull(.data$field_name)

    msg <- c(
      x = "Non-checkbox fields selected for {.code form_name}",
      `!` = "The following fields returned as non-checkbox field types: {.code {non_checkboxes}}"
    )

    cli_abort(
      msg,
      class = c("non_checkbox_fields", "REDCapTidieR_cond")
    )
  }
}

#' @title Check equal distinct values between two columns
#'
#' @description
#' Takes a dataframe and two columns and checks if `n_distinct` of the second
#' column is all unique based on grouping of the first column.
#'
#' @param data a dataframe
#' @param col1 a column to group by
#' @param col2 a column to check for uniqueness
#'
#' @keywords internal

check_equal_col_summaries <- function(data, col1, col2, call = caller_env()) {
  summary <- data %>%
    summarise(
      .by = {{ col1 }},
      n = n_distinct({{ col2 }})
    )

  total_n <- summary %>%
    pull(.data$n)

  if (!all(total_n == 1)) {
    col1_n_vals <- summary %>%
      filter(.data$n > 1) %>%
      pull({{ col1 }})

    col2_n_vals <- data %>% # nolint: object_usage_linter
      filter({{ col1 }} %in% col1_n_vals) %>%
      pull({{ col2 }})

    msg <- c(
      x = "{.code {col1_n_vals}} checkbox field{?s} resulted in multiple output columns: {.code {col2_n_vals}}.",
      `!` = "Check that {.code names_glue} defines only 1 output column for each checkbox field." # nolint: line_length_linter
    )

    cli_abort(
      msg,
      class = c("names_glue_multi_checkbox", "REDCapTidieR_cond")
    )
  }
}