R/measure_wkappa.R

Defines functions measure_wkappa

Documented in measure_wkappa

#' Weighted Cohen's kappa
#'
#' This function is based on function `measureWKAPPA` from `mlr` package.
#'
#' @param truth a vector with true (reference) values.
#' @param response a vector with response (predicted) values.
#' @param conf_mat a table similar to (\code{table(truth, response, useNA = "no")}).
#'
#' @return [!!!]
#'
#' @export
#' @family measures_
#'
#' @examples
#'      truth <- rep(1:3, times = 50)
#' prediction <- rep(3:1, each = 50)
#'
#' measure_wkappa(truth, prediction)
#'
#' square_matrix <- table(truth, prediction)
#' measure_wkappa(conf_mat = square_matrix)
#'
measure_wkappa <- function(truth = NULL, response = NULL, conf_mat = NULL) {

    # "wkappa" might be incorrect if NA values exist in any
    #  of `truth`, `response`, `conf_mat`

    if (is.null(conf_mat)) {
        conf_mat <- table(truth, response)
    }
    if (nrow(conf_mat) != ncol(conf_mat)) {
        stop("Confusion matrix `conf_mat` must be square.")
    }
    ## Original code line:
    # class_values <- seq_along(levels(truth)) - 1L
    class_values  <- seq_along(1:nrow(conf_mat)) - 1L

    conf_mat <- conf_mat/sum(conf_mat)
    rowsum <- rowSums(conf_mat)
    colsum <- colSums(conf_mat)
    expected_mat <- rowsum %*% t(colsum)

    weights <- outer(class_values,
                     class_values,
                     FUN = function(x, y) (x - y)^2)

    # Weighted Cohen's kappa
    (1 - sum(weights * conf_mat)/sum(weights * expected_mat))
}
GegznaV/multiROC documentation built on Sept. 24, 2018, 8:17 p.m.