#==========================================================
# Category Check
#==========================================================

#' Check Categorical Values
#'
#' Checks whether values in a variable belong to a
#' user-defined set of allowed categories.
#'
#' @param data A data.frame.
#' @param variable A single character string specifying the
#'   variable to check.
#' @param allowed A non-empty vector containing the allowed
#'   values.
#'
#' @return A data.frame of class \code{CategoryCheck}
#'   containing row-level category diagnostics.
#'
#' @details
#' Missing values are reported separately and are not
#' classified as invalid categories.
#'
#' The supplied \code{allowed} values are compared with the
#' observed values using their underlying values. Character,
#' factor, numeric, integer, and logical variables are
#' supported.
#'
#' @examples
#' dat <- data.frame(
#'   Species = c("Dog", "Cat", "Horse", NA),
#'   stringsAsFactors = FALSE
#' )
#'
#' category_check(
#'   dat,
#'   variable = "Species",
#'   allowed = c("Dog", "Cat", "Cattle")
#' )
#'
#' @export

category_check <- function(data, variable, allowed) {

  #---------------------------------------------
  # 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 allowed
  #---------------------------------------------
  if (missing(allowed) ||
      is.null(allowed) ||
      length(allowed) == 0L) {

    stop(
      "'allowed' must contain at least one value.",
      call. = FALSE
    )
  }

  #---------------------------------------------
  # Reject unsupported allowed objects
  #---------------------------------------------
  if (is.list(allowed) ||
      is.data.frame(allowed) ||
      is.matrix(allowed)) {

    stop(
      "'allowed' must be an atomic vector.",
      call. = FALSE
    )
  }



  #---------------------------------------------
  # NA is not an allowed category
  #---------------------------------------------
  if (anyNA(allowed)) {

    stop(
      "'allowed' must not contain missing values.",
      call. = FALSE
    )
  }

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

  #---------------------------------------------
  # Supported variable types
  #---------------------------------------------
  supported <-
    is.character(x) ||
    is.factor(x) ||
    is.numeric(x) ||
    is.logical(x)

  if (!supported) {

    stop(
      "'variable' must be character, factor, numeric, integer, or logical.",
      call. = FALSE
    )
  }

  #---------------------------------------------
  # Convert factors for comparison
  #---------------------------------------------
  if (is.factor(x)) {

    compare_x <- as.character(x)

  } else {

    compare_x <- x
  }

  if (is.factor(allowed)) {

    compare_allowed <- as.character(allowed)

  } else {

    compare_allowed <- allowed
  }

  #---------------------------------------------
  # Missing values
  #---------------------------------------------
  missing_value <- is.na(compare_x)

  #---------------------------------------------
  # Valid categories
  #---------------------------------------------
  valid_category <-
    !missing_value &
    compare_x %in% compare_allowed

  #---------------------------------------------
  # Invalid categories
  #---------------------------------------------
  invalid_category <-
    !missing_value &
    !valid_category

  #---------------------------------------------
  # Construct result
  #---------------------------------------------
  result <- data.frame(
    Row = seq_along(x),
    Value = x,
    Missing = missing_value,
    ValidCategory = valid_category,
    InvalidCategory = invalid_category,
    stringsAsFactors = FALSE,
    check.names = FALSE
  )

  #---------------------------------------------
  # Class
  #---------------------------------------------
  class(result) <- c(
    "CategoryCheck",
    "data.frame"
  )

  result
}
