#==========================================================
# Identifier Check
#==========================================================

#' Check Identifier Integrity
#'
#' Checks an identifier variable for missing values, blank
#' values, duplicates, leading or trailing whitespace, and
#' optionally values that do not match a regular expression.
#'
#' @param data A data.frame.
#' @param variable A single character string specifying the
#'   identifier variable to check.
#' @param pattern Optional regular expression that valid
#'   identifiers must match.
#'
#' @return A data.frame of class \code{IDCheck} containing
#'   row-level identifier diagnostics.
#'
#' @details
#' Character, factor, numeric, and integer identifier
#' variables are supported.
#'
#' Duplicate detection excludes missing and blank values.
#'
#' Whitespace checks are performed on the character
#' representation of the identifier.
#'
#' If \code{pattern} is supplied, non-missing and non-blank
#' identifiers that do not match the pattern are flagged.
#'
#' The function does not modify the original data.
#'
#' @examples
#' dat <- data.frame(
#'   Animal_ID = c(
#'     "A001",
#'     "A002",
#'     "A002",
#'     " A003",
#'     "",
#'     NA
#'   )
#' )
#'
#' id_check(
#'   dat,
#'   variable = "Animal_ID",
#'   pattern = "^A[0-9]{3}$"
#' )
#'
#' @export

id_check <- function(
    data,
    variable,
    pattern = NULL
) {

  #---------------------------------------------
  # Validate data
  #---------------------------------------------
  validate_data(data)

  #---------------------------------------------
  # Validate variable
  #---------------------------------------------
  if (
    missing(variable) ||
    !is.character(variable) ||
    length(variable) != 1L ||
    is.na(variable) ||
    !nzchar(variable)
  ) {
    stop(
      "'variable' must be a single non-empty character string.",
      call. = FALSE
    )
  }

  #---------------------------------------------
  # Check variable exists
  #---------------------------------------------
  if (!variable %in% names(data)) {
    stop(
      sprintf(
        "Variable '%s' was not found in 'data'.",
        variable
      ),
      call. = FALSE
    )
  }

  #---------------------------------------------
  # Validate pattern
  #---------------------------------------------
  if (!is.null(pattern)) {

    if (
      !is.character(pattern) ||
      length(pattern) != 1L ||
      is.na(pattern) ||
      !nzchar(pattern)
    ) {
      stop(
        "'pattern' must be NULL or a single non-empty character string.",
        call. = FALSE
      )
    }

    pattern_valid <- tryCatch(
      {
        suppressWarnings(
          grepl(
            pattern,
            "",
            perl = TRUE
          )
        )
        TRUE
      },
      warning = function(w) {
        FALSE
      },
      error = function(e) {
        FALSE
      }
    )

    if (!pattern_valid) {
      stop(
        "'pattern' is not a valid regular expression.",
        call. = FALSE
      )
    }
  }

  #---------------------------------------------
  # Extract variable
  #---------------------------------------------
  x <- data[[variable]]

  #---------------------------------------------
  # Validate identifier type
  #---------------------------------------------
  if (
    !is.character(x) &&
    !is.factor(x) &&
    !is.numeric(x)
  ) {
    stop(
      paste0(
        "'variable' must refer to a character, factor, ",
        "numeric, or integer variable."
      ),
      call. = FALSE
    )
  }

  #---------------------------------------------
  # Character representation
  #---------------------------------------------
  value <- as.character(x)

  #---------------------------------------------
  # Missing
  #---------------------------------------------
  missing_value <- is.na(value)

  #---------------------------------------------
  # Blank
  #---------------------------------------------
  blank <- rep(
    FALSE,
    length(value)
  )

  blank[!missing_value] <-
    value[!missing_value] == ""

  #---------------------------------------------
  # Whitespace only
  #---------------------------------------------
  whitespace_only <- rep(
    FALSE,
    length(value)
  )

  whitespace_only[!missing_value] <-
    grepl(
      "^[[:space:]]+$",
      value[!missing_value]
    )

  #---------------------------------------------
  # Leading whitespace
  #---------------------------------------------
  leading_whitespace <- rep(
    FALSE,
    length(value)
  )

  leading_whitespace[!missing_value] <-
    grepl(
      "^[[:space:]]+",
      value[!missing_value]
    )

  #---------------------------------------------
  # Trailing whitespace
  #---------------------------------------------
  trailing_whitespace <- rep(
    FALSE,
    length(value)
  )

  trailing_whitespace[!missing_value] <-
    grepl(
      "[[:space:]]+$",
      value[!missing_value]
    )

  #---------------------------------------------
  # Duplicate identifiers
  #---------------------------------------------
  duplicate <- rep(
    FALSE,
    length(value)
  )

  duplicate_candidates <-
    !missing_value &
    !blank &
    !whitespace_only

  duplicate[duplicate_candidates] <-
    duplicated(
      value[duplicate_candidates]
    ) |
    duplicated(
      value[duplicate_candidates],
      fromLast = TRUE
    )

  #---------------------------------------------
  # Pattern mismatch
  #---------------------------------------------
  pattern_mismatch <- rep(
    FALSE,
    length(value)
  )

  if (!is.null(pattern)) {

    pattern_candidates <-
      !missing_value &
      !blank &
      !whitespace_only

    pattern_mismatch[pattern_candidates] <-
      !grepl(
        pattern,
        value[pattern_candidates],
        perl = TRUE
      )
  }

  #---------------------------------------------
  # Overall validity
  #---------------------------------------------
  valid_id <-
    !missing_value &
    !blank &
    !whitespace_only &
    !leading_whitespace &
    !trailing_whitespace &
    !duplicate &
    !pattern_mismatch

  #---------------------------------------------
  # Construct result
  #---------------------------------------------
  result <- data.frame(
    Row = seq_along(x),
    Value = value,
    Missing = missing_value,
    Blank = blank,
    WhitespaceOnly = whitespace_only,
    LeadingWhitespace = leading_whitespace,
    TrailingWhitespace = trailing_whitespace,
    Duplicate = duplicate,
    PatternMismatch = pattern_mismatch,
    ValidID = valid_id,
    stringsAsFactors = FALSE,
    check.names = FALSE
  )

  #---------------------------------------------
  # Assign class
  #---------------------------------------------
  class(result) <- c(
    "IDCheck",
    "data.frame"
  )

  result
}
