Merge branch 'master' of https://github.com/kozodoi/Fairness

.gitignore

@@ -5,3 +5,5 @@ inst/doc
 .Rhistory
 .RData
 .Ruserdata
+.DS_Store
+cran-comments.md

DESCRIPTION

@@ -1,25 +1,16 @@
 Package: fairness
 Title: Algorithmic Fairness Metrics
-Version: 1.0.1
-Authors@R: c(person("Nikita", "Kozodoi", email = "[email protected]", role = c("aut", "cre")),
-            person("Tibor", "V. Varga", email = "[email protected]", role = c("aut"), comment = c(ORCID = "0000-0002-2383-699X")))
-Maintainer: Nikita Kozodoi <[email protected]>
-Description: Offers various metrics of algorithmic fairness. Fairness in machine learning is an emerging 
-  topic with the overarching aim to critically assess algorithms (predictive and classification models) whether
-  their results reinforce existing social biases. While unfair algorithms can propagate such biases and offer
-  prediction or classification results with a disparate impact on various sensitive subgroups of populations (defined
-  by sex, gender, ethnicity, religion, income, socioeconomic status, physical or mental disabilities), fair algorithms possess
-  the underlying foundation that these groups should be treated similarly / should have similar outcomes. The fairness
-  R package offers the calculation and comparisons of commonly and less commonly used fairness metrics in population
-  subgroups. These methods are described by Calders and Verwer (2010) <doi:10.1007/s10618-010-0190-x>, Chouldechova 
-  (2017) <doi:10.1089/big.2016.0047>, Feldman et al. (2015) <doi:10.1145/2783258.2783311> , Friedler et al. 
-  (2018) <doi:10.1145/3287560.3287589> and Zafar et al. (2017) <doi:10.1145/3038912.3052660>. The package also 
-  offers convenient visualizations to help understand fairness metrics.
+Version: 1.1.0
+Authors@R: c(person('Nikita', 'Kozodoi', email = '[email protected]', role = c('aut', 'cre')),
+            person('Tibor', 'V. Varga', email = '[email protected]', role = c('aut'), comment = c(ORCID = '0000-0002-2383-699X')))
+Maintainer: Nikita Kozodoi <[email protected]>
+Description: Offers various metrics of algorithmic fairness. Fairness in machine learning is an emerging topic with the overarching aim to critically assess algorithms (predictive and classification models) whether their results reinforce existing social biases. While unfair algorithms can propagate such biases and offer prediction or classification results with a disparate impact on various sensitive subgroups of populations (defined by sex, gender, ethnicity, religion, income, socioeconomic status, physical or mental disabilities), fair algorithms possess the underlying foundation that these groups should be treated similarly / should have similar outcomes. The fairness R package offers the calculation and comparisons of commonly and less commonly used fairness metrics in population subgroups. These methods are described by Calders and Verwer (2010) <doi:10.1007/s10618-010-0190-x>, Chouldechova (2017) <doi:10.1089/big.2016.0047>, Feldman et al. (2015) <doi:10.1145/2783258.2783311> , Friedler et al. (2018) <doi:10.1145/3287560.3287589> and Zafar et al. (2017) <doi:10.1145/3038912.3052660>. The package also offers convenient visualizations to help understand fairness metrics.
 License: MIT + file LICENSE
+Language: en-US
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 6.1.1
-BugReports: https://github.com/kozodoi/Fairness/issues
+RoxygenNote: 7.1.0
+BugReports: https://github.com/kozodoi/fairness/issues
 Depends: R (>= 3.5.0)
 Imports:
     caret,

LICENSE

@@ -1,2 +1,2 @@
-YEAR: 2019
-COPYRIGHT HOLDER: Nikita Kozodoi
+YEAR: 2020
+COPYRIGHT HOLDER: Nikita Kozodoi

NEWS.md

@@ -1,5 +1,16 @@
+# fairness 1.1.0
+- fixed `outcome_levels` issue when levels of provided predictions do not match outcome levels
+- renamed `outcome_levels` to `preds_levels` to improve clarity
+- added `outcome_base` argument to set base level for target variable used to compute fairness metrics
+- fixed `fnr_parity()` and `fpr_parity()` calculations for different outcome bases
+- updates in package documentation
+
+# fairness 1.0.2
+- small fixes in documentation
+
 # fairness 1.0.1
-CRAN resubmission of fairness. Fix of DESCRIPTION and LICENSE files.
+- CRAN resubmission of fairness
+- fix of `DESCRIPTION` and `LICENSE` files
 
 # fairness 1.0.0
-The first stable version of fairness.
+- the first stable version of fairness

R/acc_parity.R

@@ -16,8 +16,9 @@
 #' @param outcome The column name of the actual outcomes.
 #' @param group Sensitive group to examine.
 #' @param probs The column name or vector of the predicted probabilities (numeric between 0 - 1). If not defined, argument preds needs to be defined.
-#' @param preds The column name or vector of the predicted outcome (categorical outcome). If not defined, argument probs needs to be defined.
-#' @param outcome_levels The desired levels of the predicted outcome (categorical outcome). If not defined, all unique values of outcome are used.
+#' @param preds The column name or vector of the predicted binary outcome (0 or 1). If not defined, argument probs needs to be defined.
+#' @param preds_levels The desired levels of the predicted binary outcome. If not defined, levels of the outcome variable are used.
+#' @param outcome_base Base level for the target variable used to compute fairness metrics. Default is the first level of the outcome variable.
 #' @param cutoff Cutoff to generate predicted outcomes from predicted probabilities. Default set to 0.5.
 #' @param base Base level for sensitive group comparison
 #'
@@ -31,26 +32,21 @@
 #' @examples
 #' data(compas)
 #' acc_parity(data = compas, outcome = 'Two_yr_Recidivism', group = 'ethnicity',
-#' probs = 'probability', preds = NULL, outcome_levels = c('no', 'yes'),
+#' probs = 'probability', preds = NULL, preds_levels = c('no', 'yes'),
 #' cutoff = 0.4, base = 'Caucasian')
 #' acc_parity(data = compas, outcome = 'Two_yr_Recidivism', group = 'ethnicity',
-#' probs = NULL, preds = 'predicted', outcome_levels = c('no', 'yes'),
+#' probs = NULL, preds = 'predicted', preds_levels = c('no', 'yes'),
 #' cutoff = 0.5, base = 'Hispanic')
 #'
 #' @export
 
 acc_parity <- function(data, outcome, group,
-                       probs = NULL, preds = NULL, outcome_levels = NULL, cutoff = 0.5, base = NULL) {
+                       probs = NULL, preds = NULL, preds_levels = NULL, outcome_base = NULL, 
+                       cutoff = 0.5, base = NULL) {
 
     # convert types, sync levels
-    group_status <- as.factor(data[, group])
-    outcome_status <- as.factor(data[, outcome])
-    if (is.null(outcome_levels)) {
-        outcome_levels <- unique(outcome_status)
-    }
-    levels(outcome_status) <- outcome_levels
     if (is.null(probs) & is.null(preds)) {
-        stop({"Either probs or preds have to be supplied"})
+        stop({'Either probs or preds have to be supplied'})
     }
     if (is.null(probs)) {
         if (length(preds) == 1) {
@@ -63,12 +59,21 @@ acc_parity <- function(data, outcome, group,
         }
         preds_status <- as.factor(as.numeric(probs > cutoff))
     }
-    levels(preds_status) <- outcome_levels
+
+    group_status   <- as.factor(data[, group])
+    outcome_status <- as.factor(data[, outcome])
+
+    if (is.null(preds_levels)) {
+        preds_levels <- levels(outcome_status)
+    }
+    levels(preds_status) <- preds_levels
+    outcome_status <- relevel(outcome_status, preds_levels[1])
+    preds_status   <- relevel(preds_status,   preds_levels[1])
 
     # check lengths
     if ((length(outcome_status) != length(preds_status)) | (length(outcome_status) !=
         length(group_status))) {
-        stop("Outcomes, predictions/probabilities and group status must be of the same length")
+        stop('Outcomes, predictions/probabilities and group status must be of the same length')
     }
 
     # relevel group
@@ -80,21 +85,28 @@ acc_parity <- function(data, outcome, group,
     # placeholder
     val <- rep(NA, length(levels(group_status)))
     names(val) <- levels(group_status)
+
+    # set outcome base
+    if (is.null(outcome_base)) {
+        outcome_base <- levels(preds_status)[1]
+    }
 
     # compute value for all groups
     for (i in levels(group_status)) {
-        cm <- caret::confusionMatrix(preds_status[group_status == i], outcome_status[group_status ==
-            i], mode = "everything")
-        metric_i <- cm$overall[1]
+        cm <- caret::confusionMatrix(preds_status[group_status == i], 
+                                     outcome_status[group_status == i], 
+                                     mode = 'everything',
+                                     positive = outcome_base)
+        metric_i <- cm$overall['Accuracy']
         val[i] <- metric_i
     }
 
     res_table <- rbind(val, val/val[[1]])
-    rownames(res_table) <- c("Accuracy", "Accuracy Parity")
+    rownames(res_table) <- c('Accuracy', 'Accuracy Parity')
 
     # conversion of metrics to df
     val_df <- as.data.frame(res_table[2, ])
-    colnames(val_df) <- c("val")
+    colnames(val_df) <- c('val')
     val_df$groupst <- rownames(val_df)
     val_df$groupst <- as.factor(val_df$groupst)
 
@@ -105,14 +117,14 @@ acc_parity <- function(data, outcome, group,
     val_df$groupst <- relevel(val_df$groupst, base)
 
     p <- ggplot(val_df, aes(x = groupst, weight = val, fill = groupst)) + geom_bar(alpha = 0.5) +
-        coord_flip() + theme(legend.position = "none") + labs(x = "", y = "Accuracy Parity")
+        coord_flip() + theme(legend.position = 'none') + labs(x = '', y = 'Accuracy Parity')
 
     # plotting
     if (!is.null(probs)) {
         q <- ggplot(data, aes(x = probs, fill = group_status)) + geom_density(alpha = 0.5) +
-            labs(x = "Predicted probabilities") + guides(fill = guide_legend(title = "")) +
+            labs(x = 'Predicted probabilities') + guides(fill = guide_legend(title = '')) +
             theme(plot.title = element_text(hjust = 0.5)) + xlim(0, 1) + geom_vline(xintercept = cutoff,
-            linetype = "dashed")
+            linetype = 'dashed')
     }
 
     if (is.null(probs)) {

R/dem_parity.R

@@ -12,9 +12,12 @@
 #' proportions will be reflected in numbers lower than 1 in the returned named vector.
 #'
 #' @param data The dataframe that contains the necessary columns.
+#' @param outcome The column name of the actual outcomes.
 #' @param group Sensitive group to examine.
 #' @param probs The column name or vector of the predicted probabilities (numeric between 0 - 1). If not defined, argument preds needs to be defined.
-#' @param preds The column name or vector of the predicted outcome (categorical outcome). If not defined, argument probs needs to be defined.
+#' @param preds The column name or vector of the predicted binary outcome (0 or 1). If not defined, argument probs needs to be defined.
+#' @param preds_levels The desired levels of the predicted binary outcome. If not defined, levels of the outcome variable are used.
+#' @param outcome_base Base level for the target variable used to compute fairness metrics. Default is the first level of the outcome variable.
 #' @param cutoff Cutoff to generate predicted outcomes from predicted probabilities. Default set to 0.5.
 #' @param base Base level for sensitive group comparison
 #'
@@ -27,35 +30,50 @@
 #'
 #' @examples
 #' data(compas)
-#' dem_parity(data = compas, group = 'ethnicity',
+#' dem_parity(data = compas, outcome = 'Two_yr_Recidivism', group = 'ethnicity',
 #' probs = 'probability', preds = NULL,
 #' cutoff = 0.4, base = 'Caucasian')
-#' dem_parity(data = compas, group = 'ethnicity',
+#' dem_parity(data = compas, outcome = 'Two_yr_Recidivism', group = 'ethnicity',
 #' probs = NULL, preds = 'predicted',
 #' cutoff = 0.5, base = 'Hispanic')
 #'
 #' @export
 
 
-dem_parity <- function(data, group, probs = NULL, preds = NULL, cutoff = 0.5, base = NULL) {
+dem_parity <- function(data, outcome, group, probs = NULL, preds = NULL, preds_levels = NULL, outcome_base = NULL, cutoff = 0.5, base = NULL) {
 
     # convert types, sync levels
-    group_status <- as.factor(data[, group])
     if (is.null(probs) & is.null(preds)) {
         stop({"Either probs or preds have to be supplied"})
     }
     if (is.null(probs)) {
         if (length(preds) == 1) {
             preds <- data[, preds]
         }
-        levels(preds) <- c(0, 1)
-        preds_status <- as.numeric(as.character(preds))
+        preds_status <- as.factor(preds)
     } else {
         if (length(probs) == 1) {
             probs <- data[, probs]
         }
-        preds_status <- as.numeric(probs > cutoff)
+        preds_status <- as.factor(as.numeric(probs > cutoff))
     }
+
+    group_status   <- as.factor(data[, group])
+    outcome_status <- as.factor(data[, outcome])
+
+    if (is.null(preds_levels)) {
+        preds_levels <- levels(outcome_status)
+    }
+    levels(preds_status) <- preds_levels
+    if (is.null(outcome_base)) {
+        outcome_base <- levels(outcome_status)[1]
+    }
+    outcome_status <- relevel(outcome_status, outcome_base)
+    preds_status   <- relevel(preds_status,   outcome_base)
+
+    # convert to numeric
+    preds_status   <- as.numeric(preds_status) - 1
+    outcome_status <- as.numeric(outcome_status) - 1
 
     # check lengths
     if (length(group_status) != length(preds_status)) {

R/equal_odds.R

@@ -16,8 +16,9 @@
 #' @param outcome The column name of the actual outcomes.
 #' @param group Sensitive group to examine.
 #' @param probs The column name or vector of the predicted probabilities (numeric between 0 - 1). If not defined, argument preds needs to be defined.
-#' @param preds The column name or vector of the predicted outcome (categorical outcome). If not defined, argument probs needs to be defined.
-#' @param outcome_levels The desired levels of the predicted outcome (categorical outcome). If not defined, all unique values of outcome are used.
+#' @param preds The column name or vector of the predicted binary outcome (0 or 1). If not defined, argument probs needs to be defined.
+#' @param preds_levels The desired levels of the predicted binary outcome. If not defined, levels of the outcome variable are used.
+#' @param outcome_base Base level for the target variable used to compute fairness metrics. Default is the first level of the outcome variable.
 #' @param cutoff Cutoff to generate predicted outcomes from predicted probabilities. Default set to 0.5.
 #' @param base Base level for sensitive group comparison
 #'
@@ -32,26 +33,21 @@
 #' @examples
 #' data(compas)
 #' equal_odds(data = compas, outcome = 'Two_yr_Recidivism', group = 'ethnicity',
-#' probs = 'probability', preds = NULL, outcome_levels = c('no', 'yes'),
+#' probs = 'probability', preds = NULL, preds_levels = c('no', 'yes'),
 #' cutoff = 0.4, base = 'Caucasian')
 #' equal_odds(data = compas, outcome = 'Two_yr_Recidivism', group = 'ethnicity',
-#' probs = NULL, preds = 'predicted', outcome_levels = c('no', 'yes'),
+#' probs = NULL, preds = 'predicted', preds_levels = c('no', 'yes'),
 #' cutoff = 0.5, base = 'Hispanic')
 #'
 #' @export
 
 equal_odds <- function(data, outcome, group,
-                       probs = NULL, preds = NULL, outcome_levels = NULL, cutoff = 0.5, base = NULL) {
+                       probs = NULL, preds = NULL, preds_levels = NULL, outcome_base = NULL, 
+                       cutoff = 0.5, base = NULL) {
 
     # convert types, sync levels
-    group_status <- as.factor(data[, group])
-    outcome_status <- as.factor(data[, outcome])
-    if (is.null(outcome_levels)) {
-        outcome_levels <- unique(outcome_status)
-    }
-    levels(outcome_status) <- outcome_levels
     if (is.null(probs) & is.null(preds)) {
-        stop({"Either probs or preds have to be supplied"})
+        stop({'Either probs or preds have to be supplied'})
     }
     if (is.null(probs)) {
         if (length(preds) == 1) {
@@ -64,12 +60,21 @@ equal_odds <- function(data, outcome, group,
         }
         preds_status <- as.factor(as.numeric(probs > cutoff))
     }
-    levels(preds_status) <- outcome_levels
-
+
+    group_status   <- as.factor(data[, group])
+    outcome_status <- as.factor(data[, outcome])
+
+    if (is.null(preds_levels)) {
+        preds_levels <- levels(outcome_status)
+    }
+    levels(preds_status) <- preds_levels
+    outcome_status <- relevel(outcome_status, preds_levels[1])
+    preds_status   <- relevel(preds_status,   preds_levels[1])
+
     # check lengths
     if ((length(outcome_status) != length(preds_status)) | (length(outcome_status) !=
         length(group_status))) {
-        stop("Outcomes, predictions/probabilities and group status must be of the same length")
+        stop('Outcomes, predictions/probabilities and group status must be of the same length')
     }
 
     # relevel group
@@ -81,21 +86,28 @@ equal_odds <- function(data, outcome, group,
     # placeholder
     val <- rep(NA, length(levels(group_status)))
     names(val) <- levels(group_status)
+
+    # set outcome base
+    if (is.null(outcome_base)) {
+        outcome_base <- levels(preds_status)[1]
+    }
 
     # compute value for all groups
     for (i in levels(group_status)) {
-        cm <- caret::confusionMatrix(preds_status[group_status == i], outcome_status[group_status ==
-            i], mode = "everything")
-        metric_i <- cm$byClass[1]
+        cm <- caret::confusionMatrix(preds_status[group_status   == i], 
+                                     outcome_status[group_status == i], 
+                                     mode = 'everything', 
+                                     positive = outcome_base)
+        metric_i <- cm$byClass['Sensitivity']
         val[i] <- metric_i
     }
-
+    
     res_table <- rbind(val, val/val[[1]])
-    rownames(res_table) <- c("Sensitivity", "Equalized odds")
+    rownames(res_table) <- c('Sensitivity', 'Equalized odds')
 
     # conversion of metrics to df
     val_df <- as.data.frame(res_table[2, ])
-    colnames(val_df) <- c("val")
+    colnames(val_df) <- c('val')
     val_df$groupst <- rownames(val_df)
     val_df$groupst <- as.factor(val_df$groupst)
 
@@ -106,20 +118,19 @@ equal_odds <- function(data, outcome, group,
     val_df$groupst <- relevel(val_df$groupst, base)
 
     p <- ggplot(val_df, aes(x = groupst, weight = val, fill = groupst)) + geom_bar(alpha = 0.5) +
-        coord_flip() + theme(legend.position = "none") + labs(x = "", y = "Equalized Odds")
+        coord_flip() + theme(legend.position = 'none') + labs(x = '', y = 'Equalized Odds')
 
     # plotting
     if (!is.null(probs)) {
         q <- ggplot(data, aes(x = probs, fill = group_status)) + geom_density(alpha = 0.5) +
-            labs(x = "Predicted probabilities") + guides(fill = guide_legend(title = "")) +
+            labs(x = 'Predicted probabilities') + guides(fill = guide_legend(title = '')) +
             theme(plot.title = element_text(hjust = 0.5)) + xlim(0, 1) + geom_vline(xintercept = cutoff,
-            linetype = "dashed")
+            linetype = 'dashed')
     }
 
     if (is.null(probs)) {
         list(Metric = res_table, Metric_plot = p)
     } else {
         list(Metric = res_table, Metric_plot = p, Probability_plot = q)
     }
-
 }