Initial commit

.Rbuildignore

@@ -0,0 +1,2 @@
+^fairness\.Rproj$
+^\.Rproj\.user$

.gitattributes

@@ -0,0 +1,2 @@
+# Auto detect text files and perform LF normalization
+* text=auto

.gitignore

@@ -0,0 +1 @@
+.Rproj.user

DESCRIPTION

@@ -0,0 +1,10 @@
+Package: fairness
+Title: Algorithmic Fairness Measures
+Version: 0.0.0.1
+Authors@R: person("Nikita", "Kozodoi", email = "[email protected]", role = c("aut", "cre"))
+Description: This package computes different measures of algorithmic fairness based on a confusion matrix.
+Depends: R (>= 3.5.1)
+License: What license is it under?
+Encoding: UTF-8
+LazyData: true
+RoxygenNote: 6.1.1

NAMESPACE

@@ -0,0 +1,9 @@
+# Generated by roxygen2: do not edit by hand
+
+export(acc_parity)
+export(dem_parity)
+export(dis_impact)
+export(fnr_parity)
+export(fpr_parity)
+export(npv_parity)
+export(ppv_parity)

R/measures.R

@@ -0,0 +1,346 @@
+#' Disparate Impact
+#'
+#' This function computes the Disparate Impact metric (Feldman et al. 2015; Zafar et al. 2017)
+#' 
+#' 
+#' @param predicted Vector of predicted target values
+#' @param group Sensitive group (binary or factor)
+#' @param cutoff Cutoff for rounding the probabilities
+#' @return DI metric
+#' @export
+#' @examples
+#' df = fairness::compas
+#' dis_impact(df$label_value, df$score, df$race, "Caucasian")
+dis_impact <- function(predicted, group, cutoff = 0.5, base = NULL) {
+
+  # check lengths
+  if (length(predicted) != length(group)) {
+    stop("Predictions and groups must be of the same length")
+  }
+
+  # convert types
+  group     <- as.factor(group) 
+  predicted <- as.numeric(predicted >= cutoff)
+
+  # relevel group
+  if (is.null(base)) {base <- levels(group)[1]}
+  group <- relevel(group, base)
+
+  # placeholder
+  val <- rep(NA, length(levels(group)))
+  names(val) <- levels(group)
+
+  # compute value for group 1
+  cv1 <- mean(predicted[group == levels(group)[1]])
+
+  # compute value for other groups
+  for (i in 1:length(levels(group))) {
+    val[i] <- mean(predicted[group == levels(group)[i]]) / cv1
+  }
+
+  return(val)
+}
+
+
+
+#' Demographic Parity
+#'
+#' This function computes the Demographic Parity metric (Calders and Verwer 2010)
+#'
+#' 
+#' @param predicted Vector of predicted target values
+#' @param group Sensitive group (binary or factor)
+#' @param cutoff Cutoff for rounding the probabilities
+#' @return DP metric
+#' @export
+#' @examples
+#' df = fairness::compas
+#' dem_parity(df$score, df$race, "Caucasian")
+dem_parity <- function(predicted, group, cutoff = 0.5, base = NULL) {
+
+  # check lengths
+  if (length(predicted) != length(group)) {
+    stop("Predictions and groups must be of the same length")
+  }
+
+  # convert types
+  group     <- as.factor(group) 
+  predicted <- as.numeric(predicted >= cutoff)
+
+  # relevel group
+  if (is.null(base)) {base <- levels(group)[1]}
+  group <- relevel(group, base)
+
+  # placeholder
+  val <- rep(NA, length(levels(group)))
+  names(val) <- levels(group)
+
+  # compute value for gorup 1
+  cv1 <- mean(predicted[group == levels(group)[1]])
+
+  # compute value for other groups
+  for (i in 1:length(levels(group))) {
+    val[i] <- 1 - (mean(predicted[group == levels(group)[i]]) - cv1)
+  }
+
+  return(val)
+}
+
+
+
+#' FPR Parity
+#'
+#' This function computes the False Positive Rate Parity metric (Chouldechova 2017)
+#' 
+#' 
+#' @param actuals Vector of actual target values
+#' @param predicted Vector of predicted target values
+#' @param group Sensitive group (binary or factor)
+#' @param cutoff Cutoff for rounding the probabilities
+#' @return FPR Parity metric
+#' @examples
+#' df = fairness::compas
+#' fpr_parity(df$label_value, df$score, df$race, "Caucasian")
+#' @export
+fpr_parity <- function(actuals, predicted, group, cutoff = 0.5, base = NULL) {
+
+  # check lengths
+  if ((length(actuals) != length(predicted)) | (length(actuals) != length(group))) {
+    stop("Actuals, predictions and groups must be of the same length")
+  }
+
+  # convert types
+  group     <- as.factor(group) 
+  actuals   <- as.numeric(actuals)
+  predicted <- as.numeric(predicted >= cutoff)
+
+  # relevel group
+  if (is.null(base)) {base <- levels(group)[1]}
+  group <- relevel(group, base)
+
+  # placeholder
+  val <- rep(NA, length(levels(group)))
+  names(val) <- levels(group)
+
+  # compute value for group 1
+  fpr1 <- sum(actuals == 0 & predicted == 1 & group == levels(group)[1]) / 
+    sum(actuals ==0 & group == levels(group)[1])
+
+  # compute value for other groups
+  for (i in 1:length(levels(group))) {
+    fpr1 <- sum(actuals == 0 & predicted == 1 & group == levels(group)[1]) / 
+      sum(actuals == 0 & group == levels(group)[1])
+    fpri <- sum(actuals == 0 & predicted == 1 & group == levels(group)[i]) / 
+      sum(actuals == 0 & group == levels(group)[i])
+    val[i] <- fpri / fpr1
+  }
+
+  return(val)
+}
+
+
+
+#' FNR Parity
+#'
+#' This function computes the False Negative Rate Parity metric (Chouldechova 2017)
+#' 
+#' 
+#' @param actuals Vector of actual target values
+#' @param predicted Vector of predicted target values
+#' @param group Sensitive group (binary or factor)
+#' @param cutoff Cutoff for rounding the probabilities
+#' @return FNR Parity metric
+#' @examples
+#' df = fairness::compas
+#' fnr_parity(df$label_value, df$score, df$race, "Caucasian")
+#' @export
+fnr_parity <- function(actuals, predicted, group, cutoff = 0.5, base = NULL) {
+
+  # check lengths
+  if ((length(actuals) != length(predicted)) | (length(actuals) != length(group))) {
+    stop("Actuals, predictions and groups must be of the same length")
+  }
+
+  # convert types
+  group     <- as.factor(group) 
+  actuals   <- as.numeric(actuals)
+  predicted <- as.numeric(predicted >= cutoff)
+
+  # relevel group
+  if (is.null(base)) {base <- levels(group)[1]}
+  group <- relevel(group, base)
+
+  # placeholder
+  val <- rep(NA, length(levels(group)))
+  names(val) <- levels(group)
+
+  # compute value for gorup 1
+  fnr1 <- sum(actuals == 1 & predicted == 0 & group == levels(group)[1]) / 
+    sum(actuals == 1 & group == levels(group)[1])
+
+  # compute value for other groups
+  for (i in 1:length(levels(group))) {
+    fnr1 <- sum(actuals == 1 & predicted == 0 & group == levels(group)[1]) / 
+      sum(actuals == 1 & group == levels(group)[1])
+    fnri <- sum(actuals == 1 & predicted == 0 & group == levels(group)[i]) / 
+      sum(actuals == 1 & group == levels(group)[i])
+    val[i] <- fnri / fnr1
+  }
+
+  return(val)
+}
+
+
+
+#' PPV Parity
+#'
+#' This function computes the Positive Predicted Value Parity metric (see Aeuquitas bias audit toolkit)
+#' 
+#' 
+#' @param actuals Vector of actual target values
+#' @param predicted Vector of predicted target values
+#' @param group Sensitive group (binary or factor)
+#' @param cutoff Cutoff for rounding the probabilities
+#' @return FNR Parity metric
+#' @examples
+#' df = fairness::compas
+#' ppv_pariy(df$label_value, df$score, df$race, "Caucasian")
+#' @export
+ppv_parity <- function(actuals, predicted, group, cutoff = 0.5, base = NULL) {
+
+  # check lengths
+  if ((length(actuals) != length(predicted)) | (length(actuals) != length(group))) {
+    stop("Actuals, predictions and groups must be of the same length")
+  }
+
+  # convert types
+  group     <- as.factor(group) 
+  actuals   <- as.numeric(actuals)
+  predicted <- as.numeric(predicted >= cutoff)
+
+  # relevel group
+  if (is.null(base)) {base <- levels(group)[1]}
+  group <- relevel(group, base)
+
+  # placeholder
+  val <- rep(NA, length(levels(group)))
+  names(val) <- levels(group)
+
+  # compute value for group 1
+  ppv1 <- sum(actuals == 1 & predicted == 1 & group == levels(group)[1]) / 
+    sum(predicted == 1 & group == levels(group)[1])
+
+  # compute value for other groups
+  for (i in 1:length(levels(group))) {
+
+    ppv1 <- sum(actuals == 1 & predicted == 1 & group == levels(group)[1]) / 
+      sum(predicted == 1 & group == levels(group)[1])
+    ppvi <- sum(actuals == 1 & predicted == 1 & group == levels(group)[i]) / 
+      sum(predicted == 1 & group == levels(group)[i])
+    val[i] <- ppvi / ppv1
+  }
+
+  return(val)
+}
+
+
+
+#' NPV Parity
+#'
+#' This function computes the Negative Positive Value Parity metric (see Aeuquitas bias audit toolkit)
+#' 
+#' 
+#' @param actuals Vector of actual target values
+#' @param predicted Vector of predicted target values
+#' @param group Sensitive group (binary or factor)
+#' @param cutoff Cutoff for rounding the probabilities
+#' @return FNR Parity metric
+#' @examples
+#' df = fairness::compas
+#' npv_parity(df$label_value, df$score, df$race, "Caucasian")
+#' @export
+npv_parity <- function(actuals, predicted, group, cutoff = 0.5, base = NULL) {
+
+  # check lengths
+  if ((length(actuals) != length(predicted)) | (length(actuals) != length(group))) {
+    stop("Actuals, predictions and groups must be of the same length")
+  }
+
+  # convert types
+  group     <- as.factor(group) 
+  actuals   <- as.numeric(actuals)
+  predicted <- as.numeric(predicted >= cutoff)
+
+  # relevel group
+  if (is.null(base)) {base <- levels(group)[1]}
+  group <- relevel(group, base)
+
+  # placeholder
+  val <- rep(NA, length(levels(group)))
+  names(val) <- levels(group)
+
+  # compute value for group 1
+  npv1 <- sum(actuals == 0 & predicted == 0 & group == levels(group)[1]) / 
+    sum(predicted == 0 & group == levels(group)[1])
+
+  # compute value for other groups
+  for (i in 1:length(levels(group))) {
+    npvi <- sum(actuals == 0 & predicted == 0 & group == levels(group)[i]) / 
+      sum(predicted == 0 & group == levels(group)[i])
+    val[i] <- npvi / npv1
+  }
+
+  return(val)
+}
+
+
+
+#' Accuracy Parity
+#'
+#' This function computes the Accuracy Parity metric (Friedler et al. 2018)
+#' 
+#' 
+#' @param actuals Vector of actual target values
+#' @param predicted Vector of predicted target values
+#' @param group Sensitive group (binary or factor)
+#' @param cutoff Cutoff for rounding the probabilities
+#' @return Accuracy Parity metric
+#' @examples
+#' df = fairness::compas
+#' acc_parity(df$label_value, df$score, df$race, "Caucasian")
+#' @export
+acc_parity <- function(actuals, predicted, group, cutoff = 0.5, base = NULL) {
+
+  # check lengths
+  if ((length(actuals) != length(predicted)) | (length(actuals) != length(group))) {
+    stop("Actuals, predictions and groups must be of the same length")
+  }
+
+  # convert types
+  group     <- as.factor(group) 
+  actuals   <- as.numeric(actuals)
+  predicted <- as.numeric(predicted >= cutoff)
+
+  # relevel group
+  if (is.null(base)) {base <- levels(group)[1]}
+  group <- relevel(group, base)
+
+  # placeholder
+  val <- rep(NA, length(levels(group)))
+  names(val) <- levels(group)
+
+  # compute value for group 1
+  ac1 <- sum(actuals[group == levels(group)[1]] == predicted[group == levels(group)[1]]) / 
+    sum(group == levels(group)[1])
+
+  # compute value for other groups
+  for (i in 1:length(levels(group))) {
+    ac1 <- sum(actuals[group == levels(group)[1]] == predicted[group == levels(group)[1]]) / 
+      sum(group == levels(group)[1])
+    aci <- sum(actuals[group == levels(group)[i]] == predicted[group == levels(group)[i]]) / 
+      sum(group == levels(group)[i])
+    val[i] <- aci / ac1
+  }
+
+  return(val)
+}

README.md

@@ -0,0 +1 @@
+# Fairness

fairness.Rproj

@@ -0,0 +1,16 @@
+Version: 1.0
+
+RestoreWorkspace: No
+SaveWorkspace: No
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+Encoding: UTF-8
+
+AutoAppendNewline: Yes
+StripTrailingWhitespace: Yes
+
+BuildType: Package
+PackageUseDevtools: Yes
+PackageInstallArgs: --no-multiarch --with-keep.source
+PackageRoxygenize: rd,collate,namespace