#==========================================================
# Apply Audit Rules
#==========================================================

#' Apply Data Audit Rules
#'
#' Applies a set of validation rules created by
#' \code{\link{audit_rules}} to a data frame.
#'
#' @param data A data.frame.
#' @param rules An object of class \code{DataAuditRules}
#'   created by \code{\link{audit_rules}}.
#'
#' @return An object of class \code{DataAuditRuleResult}.
#'
#' @details
#' The function evaluates range, category, uniqueness,
#' required-value, and regular-expression rules.
#'
#' Rules referring to variables that are not present in
#' \code{data} produce an error.
#'
#' @examples
#' dat <- data.frame(
#'   Animal_ID = c("A001", "A002", "A002", NA),
#'   Species = c("Dog", "Cat", "Horse", "Dog"),
#'   Age = c(5, 3, 40, 2),
#'   stringsAsFactors = FALSE
#' )
#'
#' rules <- audit_rules(
#'   range = list(
#'     Age = c(0, 30)
#'   ),
#'   category = list(
#'     Species = c("Dog", "Cat", "Cattle")
#'   ),
#'   unique = "Animal_ID",
#'   required = "Animal_ID",
#'   pattern = list(
#'     Animal_ID = "^A[0-9]+$"
#'   )
#' )
#'
#' apply_audit_rules(dat, rules)
#'
#' @export

apply_audit_rules <- function(
    data,
    rules
) {

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

  #---------------------------------------------
  # Validate rules
  #---------------------------------------------
  if (!inherits(rules, "DataAuditRules")) {
    stop(
      "'rules' must be an object created by audit_rules().",
      call. = FALSE
    )
  }

  required_components <- c(
    "range",
    "category",
    "unique",
    "required",
    "pattern"
  )

  if (
    !all(
      required_components %in% names(rules)
    )
  ) {
    stop(
      "Invalid 'DataAuditRules' object.",
      call. = FALSE
    )
  }

  #---------------------------------------------
  # Determine variables used by rules
  #---------------------------------------------
  rule_variables <- unique(
    c(
      names(rules$range),
      names(rules$category),
      rules$unique,
      rules$required,
      names(rules$pattern)
    )
  )

  rule_variables <- rule_variables[
    !is.na(rule_variables) &
      nzchar(rule_variables)
  ]

  #---------------------------------------------
  # Check variables exist
  #---------------------------------------------
  missing_variables <- setdiff(
    rule_variables,
    names(data)
  )

  if (length(missing_variables) > 0L) {

    stop(
      sprintf(
        "Variable(s) referenced by rules not found in 'data': %s.",
        paste(
          missing_variables,
          collapse = ", "
        )
      ),
      call. = FALSE
    )
  }

  #---------------------------------------------
  # Storage
  #---------------------------------------------
  range_results <- list()
  category_results <- list()
  unique_results <- list()
  required_results <- list()
  pattern_results <- list()

  #---------------------------------------------
  # Range rules
  #---------------------------------------------
  if (
    !is.null(rules$range) &&
    length(rules$range) > 0L
  ) {

    for (variable in names(rules$range)) {

      limits <- rules$range[[variable]]

      x <- data[[variable]]

      if (!is.numeric(x)) {
        stop(
          sprintf(
            "Range rule requires '%s' to be numeric.",
            variable
          ),
          call. = FALSE
        )
      }

      invalid <-
        !is.na(x) &
        (
          x < limits[1L] |
            x > limits[2L]
        )

      range_results[[variable]] <- data.frame(
        Row = seq_len(nrow(data)),
        Variable = variable,
        Value = x,
        Minimum = limits[1L],
        Maximum = limits[2L],
        Violation = invalid,
        stringsAsFactors = FALSE,
        check.names = FALSE
      )
    }
  }

  #---------------------------------------------
  # Category rules
  #---------------------------------------------
  if (
    !is.null(rules$category) &&
    length(rules$category) > 0L
  ) {

    for (variable in names(rules$category)) {

      allowed <- rules$category[[variable]]

      x <- data[[variable]]

      invalid <-
        !is.na(x) &
        !(x %in% allowed)

      category_results[[variable]] <- data.frame(
        Row = seq_len(nrow(data)),
        Variable = variable,
        Value = as.character(x),
        Violation = invalid,
        stringsAsFactors = FALSE,
        check.names = FALSE
      )
    }
  }

  #---------------------------------------------
  # Unique rules
  #---------------------------------------------
  if (
    !is.null(rules$unique) &&
    length(rules$unique) > 0L
  ) {

    for (variable in rules$unique) {

      x <- data[[variable]]

      invalid <-
        !is.na(x) &
        (
          duplicated(x) |
            duplicated(
              x,
              fromLast = TRUE
            )
        )

      unique_results[[variable]] <- data.frame(
        Row = seq_len(nrow(data)),
        Variable = variable,
        Value = x,
        Violation = invalid,
        stringsAsFactors = FALSE,
        check.names = FALSE
      )
    }
  }

  #---------------------------------------------
  # Required rules
  #---------------------------------------------
  if (
    !is.null(rules$required) &&
    length(rules$required) > 0L
  ) {

    for (variable in rules$required) {

      x <- data[[variable]]

      invalid <- is.na(x)

      # Treat blank character/factor values as missing
      if (
        is.character(x) ||
        is.factor(x)
      ) {

        y <- as.character(x)

        invalid <-
          invalid |
          (
            !is.na(y) &
              grepl(
                "^[[:space:]]*$",
                y
              )
          )
      }

      required_results[[variable]] <- data.frame(
        Row = seq_len(nrow(data)),
        Variable = variable,
        Value = as.character(x),
        Violation = invalid,
        stringsAsFactors = FALSE,
        check.names = FALSE
      )
    }
  }

  #---------------------------------------------
  # Pattern rules
  #---------------------------------------------
  if (
    !is.null(rules$pattern) &&
    length(rules$pattern) > 0L
  ) {

    for (variable in names(rules$pattern)) {

      regex <- rules$pattern[[variable]]

      x <- data[[variable]]

      y <- as.character(x)

      invalid <- rep(
        FALSE,
        length(y)
      )

      non_missing <- !is.na(y)

      invalid[non_missing] <-
        !grepl(
          regex,
          y[non_missing],
          perl = TRUE
        )

      pattern_results[[variable]] <- data.frame(
        Row = seq_len(nrow(data)),
        Variable = variable,
        Value = y,
        Pattern = regex,
        Violation = invalid,
        stringsAsFactors = FALSE,
        check.names = FALSE
      )
    }
  }

  #---------------------------------------------
  # Helper: count violations
  #---------------------------------------------
  count_violations <- function(x) {

    if (length(x) == 0L) {
      return(0L)
    }

    as.integer(
      sum(
        vapply(
          x,
          function(z) {
            sum(z$Violation)
          },
          numeric(1)
        )
      )
    )
  }

  #---------------------------------------------
  # Counts
  #---------------------------------------------
  range_n <-
    count_violations(range_results)

  category_n <-
    count_violations(category_results)

  unique_n <-
    count_violations(unique_results)

  required_n <-
    count_violations(required_results)

  pattern_n <-
    count_violations(pattern_results)

  total_violations <-
    range_n +
    category_n +
    unique_n +
    required_n +
    pattern_n

  #---------------------------------------------
  # Summary
  #---------------------------------------------
  summary <- data.frame(
    Rule = c(
      "Range",
      "Category",
      "Unique",
      "Required",
      "Pattern"
    ),
    Violations = c(
      range_n,
      category_n,
      unique_n,
      required_n,
      pattern_n
    ),
    stringsAsFactors = FALSE
  )

  #---------------------------------------------
  # Overall status
  #---------------------------------------------
  status <- if (
    total_violations == 0L
  ) {
    "Passed"
  } else {
    "Violations detected"
  }

  #---------------------------------------------
  # Construct result
  #---------------------------------------------
  result <- list(
    status = status,
    total_violations =
      total_violations,
    summary = summary,
    range = range_results,
    category = category_results,
    unique = unique_results,
    required = required_results,
    pattern = pattern_results
  )

  class(result) <- c(
    "DataAuditRuleResult",
    "list"
  )

  result
}
