R/robKappa.R

In RobustMetrics: Calculates Robust Performance Metrics for Imbalanced Classification Problems

#' Robust Cohen's Kappa
#'
#' Compute a robust version of Cohen's Kappa coefficient.
#'
#' @param actual A vector of actual values (1/0 or TRUE/FALSE)
#' @param predicted A vector of prediction values (1/0 or TRUE/FALSE)
#' @param TP Count of true positives (correctly predicted 1/TRUE)
#' @param FN Count of false negatives (predicted 0/FALSE, but actually 1/TRUE)
#' @param FP Count of false positives (predicted 1/TRUE, but actually 0/FALSE)
#' @param TN Count of true negatives (correctly predicted 0/FALSE)
#' @param d Nonnegative robustness parameter. With `d = 0`, the result is Cohen's Kappa.
#'
#' @details
#' Calculate the robust Cohen's Kappa coefficient. Provide either:
#' * `actual` and `predicted` or
#' * `TP`, `FN`, `FP` and `TN`.
#'
#' If \eqn{d=0}, the robust Cohen's Kappa coefficient coincides with Cohen's Kappa.
#' @md
#'
#' @return Robust Cohen's Kappa coefficient.
#'
#' @references
#' Holzmann, H., Klar, B. (2026). Robust performance metrics for imbalanced classification problems.
#' arXiv:2404.07661. \href{https://arxiv.org/abs/2404.07661}{LINK}
#'
#' @examples
#' actual <- c(1,1,1,1,1,1,0,0,0,0)
#' predicted <- c(1,1,1,1,0,0,1,0,0,0)
#' robKappa(actual, predicted, d=0.1)
#' robKappa(TP=4, FN=2, FP=1, TN=3, d=0.1)
#'
#' @export
robKappa = function(actual = NULL, predicted = NULL, TP = NULL, FN = NULL,
                    FP = NULL, TN = NULL, d = 0.1) {
  valid_input <- FALSE
  if (!is.null(predicted) && !is.null(actual) && is.null(TP) && is.null(FN) &&
      is.null(FP) && is.null(TN))
    valid_input <- TRUE
  if ((!is.null(TP) && !is.null(FN) && !is.null(FP) && !is.null(TN)) &&
      is.null(predicted) && is.null(actual))
    valid_input <- TRUE
  if (!valid_input)
    stop("Either {'predicted' and 'actual'} or {'TP', 'FN', 'FP', 'TN'} should be provided.")
  if (!is.numeric(d) || length(d) != 1L || is.na(d) || d < 0)
    stop("'d' should be a nonnegative number.")

  if (is.null(TP)) {
    if (length(actual) != length(predicted))
      stop("'actual' and 'predicted' should have the same length.")
    if (!(is.logical(actual) || is.numeric(actual)) || !all(actual %in% c(0L, 1L)))
      stop("'actual' should only consist of TRUE/FALSE or 1/0.")
    if (!(is.logical(predicted) || is.numeric(predicted)) || !all(predicted %in% c(0L, 1L)))
      stop("'predicted' should only consist of TRUE/FALSE or 1/0.")
    TP <- sum(actual & predicted)
    FN <- sum(actual & !predicted)
    FP <- sum(!actual & predicted)
    TN <- sum(!actual & !predicted)
  } else {
    TP <- as.double(TP)
    FP <- as.double(FP)
    TN <- as.double(TN)
    FN <- as.double(FN)
  }

  total <- TP + FN + FP + TN
  prevalence <- (TP + FN) / total
  predicted_prevalence <- (TP + FP) / total
  true_positive_probability <- TP / total
  chance_agreement <- prevalence * (1 - predicted_prevalence) +
    (1 - prevalence) * predicted_prevalence
  kappa <- (d / (2 * prevalence * (1 - prevalence)) + 1) *
    2 * (true_positive_probability - prevalence * predicted_prevalence) /
    (d + chance_agreement)
  return(kappa)
}