14  COMPAS Dataset

Objectives

In this chapter, we extend the analysis from the previous part to the COMPAS dataset (Larson, Kirchner, and Angwin (2016)). We use a cleaned version of this dataset available in the {fairadapt} R package.

Required packages and definition of colours. 
# Required packages----
library(tidyverse)
library(devtools)

# Graphs----
font_main = font_title = 'Times New Roman'
extrafont::loadfonts(quiet = T)
face_text='plain'
face_title='plain'
size_title = 14
size_text = 11
legend_size = 11

global_theme <- function() {
  theme_minimal() %+replace%
    theme(
      text = element_text(family = font_main, size = size_text, face = face_text),
      legend.text = element_text(family = font_main, size = legend_size),
      axis.text = element_text(size = size_text, face = face_text), 
      plot.title = element_text(
        family = font_title, 
        size = size_title, 
        hjust = 0.5
      ),
      plot.subtitle = element_text(hjust = 0.5)
    )
}

# Seed
set.seed(2025)

colours_all <- c(
  "factual" = "black",
  "source" = "#00A08A",
  "reference" = "#F2AD00",
  "naive" = "gray",
  "ot" = "#0072B2",
  "fairadapt" = '#D55E00',
  "seq" = "#CC79A7"
)
load_all("../seqtransfairness/")
ℹ Loading seqtransfairness
# if the package is installed, it is possible to use
# library(seqtransfairness)

The COMPAS (Correctional Offender Management Profiling for Alternative Sanctions) dataset contains information used to predict whether criminal defendants are likely of recidivism (Y). The data contains real observations from Broward County, Florida. Each row gives information on individuals released on parole and whether they reoffended within two years (Y). Other characteristics such as the sex of the individual, the number of juvenile felonies, the number of juvenile misdemeanors, the number of other juvenile offenses, the number of prior offenses and the degree of charge (with two values F for felony, and M for misdemeanor). We will use the race of individuals as the sensitive attribute (S).

vars <- c(
  "age", "sex", "juv_fel_count",
  "juv_misd_count", "juv_other_count", "priors_count",
  "c_charge_degree", "race", "two_year_recid"
)
s <- "race"
y <- "two_year_recid"

The data can be loaded as follows:

library(fairadapt)
# reading in the COMPAS data
data("compas", package = "fairadapt")
compas <- 
  compas |> 
  as_tibble() |> 
  select(!!vars) |> 
  mutate(race = fct_relevel(race, "Non-White", "White"))

We can have a quick glance at the proportion of Non-White individuals and White individuals among people who reoffended or not.

compas |> count(two_year_recid, race) |> 
  group_by(two_year_recid) |> 
  mutate(pct_race = round(100* n / sum(n), 2))
# A tibble: 4 × 4
# Groups:   two_year_recid [2]
  two_year_recid race          n pct_race
           <int> <fct>     <int>    <dbl>
1              0 Non-White  2475     62.4
2              0 White      1488     37.6
3              1 Non-White  2285     70.3
4              1 White       966     29.7

We will assume the same causal graph as in Plečko and Meinshausen (2020) (Figure 4, p. 27) and use their codes from their Github to create the adjacency matrix.

# Adjacency matrix
adj_mat <- matrix(
  0, 
  ncol = ncol(compas), nrow = ncol(compas),
  dimnames = list(vars, vars)
)

# adding the edges to the matrix
adj_mat[
  c("race", "sex", "age"), 
  c("juv_fel_count", "juv_misd_count", "juv_other_count", "priors_count",
    "c_charge_degree", "two_year_recid")
] <- 1
adj_mat[c("juv_fel_count", "juv_misd_count", "juv_other_count"),
        c("priors_count", "c_charge_degree", "two_year_recid")] <- 1
adj_mat["priors_count", c("c_charge_degree", "two_year_recid")] <- 1
adj_mat["c_charge_degree", "two_year_recid"] <- 1

adj_mat
                age sex juv_fel_count juv_misd_count juv_other_count
age               0   0             1              1               1
sex               0   0             1              1               1
juv_fel_count     0   0             0              0               0
juv_misd_count    0   0             0              0               0
juv_other_count   0   0             0              0               0
priors_count      0   0             0              0               0
c_charge_degree   0   0             0              0               0
race              0   0             1              1               1
two_year_recid    0   0             0              0               0
                priors_count c_charge_degree race two_year_recid
age                        1               1    0              1
sex                        1               1    0              1
juv_fel_count              1               1    0              1
juv_misd_count             1               1    0              1
juv_other_count            1               1    0              1
priors_count               0               1    0              1
c_charge_degree            0               0    0              1
race                       1               1    0              1
two_year_recid             0               0    0              0
causal_graph <- fairadapt::graphModel(adj_mat)
plot(causal_graph)
Figure 14.1: Assumed Causal Graph

We can visualize this causal graph with a prettier representation, using a tikz picture.

Codes to create Tikz from an adjacency matrix. 
#' Add a tikz graph in a quarto HTML document
#'
#' @param tikz_code Tikz code.
add_tikz_graph <- function(tikz_code,
                           label,
                           caption = "Causal Graph",
                           echo = "true",
                           code_fold = "true",
                           fig_ext = "png",
                           code_summary = "Tikz code") {
  
  res <- knitr::knit_child(
    text = glue::glue(r"(
             ```{tikz}
             #| echo: {echo}
             #| label: {label}
             #| fig-cap: {caption}
             #| fig-ext: {fig_ext}
             #| code-fold: {code_fold}
             #| code-summary: {code_summary}
             \usetikzlibrary{{arrows}}
             {tikz_code}
             ```)"
    ),
    quiet = TRUE
  )
  knitr::asis_output(res)
}

colour_nodes <- c(
  "age" = "yellow!60", 
  "sex" = "yellow!60", 
  "juv_fel_count" = "yellow!60",
  "juv_misd_count" = "yellow!60", 
  "juv_other_count" = "yellow!60",
  "priors_count" = "yellow!60",
  "c_charge_degree" = "yellow!60", 
  "race" = "red!30",
  "two_year_recid" = "blue!30"
)

# Then, in the document:
# `r add_tikz_graph(tikz_code = causal_graph_tikz(adj_mat, colour_nodes), label = "fig-causal-graph-compas-2", caption = "\"Assumed Causal Graph\"", echo = "true")`
Tikz code 
\usetikzlibrary{arrows}
\begin{tikzpicture}
\node[fill=yellow!60] (n1) at (4.8, 5.0) {age};
\node[fill=yellow!60] (n2) at (2.5, 0.1) {sex};
\node[fill=yellow!60] (n3) at (10.0, 1.9) {juv fel count};
\node[fill=yellow!60] (n4) at (0.4, 3.4) {juv misd count};
\node[fill=yellow!60] (n5) at (0.0, 1.6) {juv other count};
\node[fill=yellow!60] (n6) at (3.4, 2.8) {priors count};
\node[fill=yellow!60] (n7) at (6.7, 3.2) {c charge degree};
\node[fill=red!30] (n8) at (6.2, 0.0) {race};
\node[fill=blue!30] (n9) at (5.5, 1.6) {two year recid};
\draw[->, black] (n1) -- (n3);
\draw[->, black] (n1) -- (n4);
\draw[->, black] (n1) -- (n5);
\draw[->, black] (n1) -- (n6);
\draw[->, black] (n1) -- (n7);
\draw[->, black] (n1) -- (n9);
\draw[->, black] (n2) -- (n3);
\draw[->, black] (n2) -- (n4);
\draw[->, black] (n2) -- (n5);
\draw[->, black] (n2) -- (n6);
\draw[->, black] (n2) -- (n7);
\draw[->, black] (n2) -- (n9);
\draw[->, black] (n3) -- (n6);
\draw[->, black] (n3) -- (n7);
\draw[->, black] (n3) -- (n9);
\draw[->, black] (n4) -- (n6);
\draw[->, black] (n4) -- (n7);
\draw[->, black] (n4) -- (n9);
\draw[->, black] (n5) -- (n6);
\draw[->, black] (n5) -- (n7);
\draw[->, black] (n5) -- (n9);
\draw[->, black] (n6) -- (n7);
\draw[->, black] (n6) -- (n9);
\draw[->, black] (n7) -- (n9);
\draw[->, black] (n8) -- (n3);
\draw[->, black] (n8) -- (n4);
\draw[->, black] (n8) -- (n5);
\draw[->, black] (n8) -- (n6);
\draw[->, black] (n8) -- (n7);
\draw[->, black] (n8) -- (n9);
\end{tikzpicture}
Figure 14.2: Assumed Causal Graph

14.1 Classifier

We load functions defined in our small package (notably, split_dataset()):

library(devtools)
load_all("../seqtransfairness/")
ℹ Loading seqtransfairness

We fit a logistic regression model on the data to predict the outcome binary variable. First, we split the dataset into two sets: train (70%) and test (30%).

seed <- 2025
sets <- split_dataset(compas, seed, train_ratio = 0.7)
data_train <- sets$data_train
data_test <- sets$data_test

As in Chapter 7, we train two models:

  1. unaware logistic regression classifier: model without including the sensitive attribute.
  2. aware logistic regression classifier: model with the sensitive attribute included in the set of features.

To do so, we use the training function, log_reg_train(), defined in our small package. When the two models are trained, we extract the predicted values on both the train set and the test set.

# Unaware logistic regression classifier (model without S)
pred_unaware <- log_reg_train(
  data_train, data_test, s = s, y = y, type = "unaware"
)
pred_unaware_train <- pred_unaware$pred_train
pred_unaware_test <- pred_unaware$pred_test

# Aware logistic regression classifier (model with S)
pred_aware <- log_reg_train(
  data_train, data_test, s = s, y = y, type = "aware"
)
pred_aware_train <- pred_aware$pred_train
pred_aware_test <- pred_aware$pred_test

We create a table for each model, with the sensitive attribute and the predicted value by the model (\(\hat{y}\)), only for observations from the test set.

df_test_unaware <- tibble(
  S = data_test |> pull(!!s),
  pred = pred_unaware_test
)

df_test_aware <- tibble(
  S = data_test |> pull(!!s),
  pred = pred_aware_test
)

14.1.1 Predictions

We predict values with the unaware model on the factuals:

model_unaware <- pred_unaware$model
pred_unaware_all <- predict(
  model_unaware,
  newdata = compas,
  type = "response"
)

And with the aware model:

model_aware <- pred_aware$model
pred_aware_all <- predict(
  model_aware,
  newdata = compas,
  type = "response"
)

14.1.2 Saving Objects

save(pred_aware, file = "../data/pred_aware_compas.rda")
save(pred_unaware, file = "../data/pred_unaware_compas.rda")
save(pred_unaware_all, file = "../data/pred_unaware_all_compas.rda")
save(pred_aware_all, file = "../data/pred_aware_all_compas.rda")

14.2 Naive approach: ceteris paribus

Let us change the sensitive attribute of individuals from the source group (Non-White) to the target group (White). Then, we use both models (unaware and aware) to predict the target binary variable.

pred_unaware_naive_nonwhite <- predict(
  model_unaware,
  newdata = compas |> filter(race == "Non-White") |> mutate(race = "White"),
  type = "response"
)
pred_aware_naive_nonwhite <- predict(
  model_aware,
  newdata = compas |> filter(race == "Non-White") |>  mutate(race = "White"),
  type = "response"
)

ind_nonwhite <- which(compas$race == "Non-White")
ind_white <- which(compas$race == "White")

counterfactuals_unaware_naive_nonwhite <- 
  compas |> filter(race == "Non-White") |> 
  mutate(
    race_origin = race,
    race = "White",
    pred = pred_unaware_naive_nonwhite,
    type = "counterfactual",
    id_indiv = ind_nonwhite
  )
counterfactuals_aware_naive_nonwhite <- 
  compas |> filter(race == "Non-White") |> 
  mutate(
    race_origin = race,
    race = "White",
    pred = pred_aware_naive_nonwhite,
    type = "counterfactual",
    id_indiv = ind_nonwhite
  )

14.2.1 Unaware Model

Let us have a look at the distribution of the predicted scores of the classifier in both groups, when the predictions are made after setting the race attribute of all Non-White to White. Since the model does not use the sensitive attribute, changing it will result in absolutely no change in its predictions in this case.

The predicted values using the initial characteristics (the factuals), for the unaware model are stored in the object pred_unaware_all. We put in a table the initial characteristics (factuals) and the prediction made by the unaware model:

factuals_unaware <-
  compas |> 
  as_tibble() |>
  mutate(
    race_origin = race,
    pred = pred_unaware_all,
    type = "factual"
  ) |> 
    mutate(id_indiv = row_number())
unaware_naive_nonwhite <- 
  factuals_unaware |> mutate(race_origin = race) |> 
  bind_rows(counterfactuals_unaware_naive_nonwhite)

The unaware model is blind to the sensitive attribute. Hence, changing the sensitive attribute does not affect the predicted scores.

ggplot(
  unaware_naive_nonwhite |> mutate(
    group = case_when(
      race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
      race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
      race_origin =="White" & race == "White" ~ "White (Original)"
    ),
    group = factor(
      group, 
      levels = c(
        "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
      )
    )
  ),
  aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(
      y = after_stat(density)), alpha = 0.5, colour = NA,
    position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.3, linewidth = 1) +
  facet_wrap(~race) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["naive"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["naive"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.3: Unaware model, Sensitive: Race, Non-White -> White

Then, we focus on the distribution of predicted scores for ccounterfactual of Non-White individuals and factuals of White individuals Again, since the model is blind to the sensitive attribute, the distributions are perfectly aligned.

Codes used to create the Figure. 
ggplot(
  data = unaware_naive_nonwhite |> 
    mutate(
      group = case_when(
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
        race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
        race_origin =="White" & race == "White" ~ "White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
        )
      )
    ) |> 
    filter(race_origin =="Non-White"),
  mapping = aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(y = after_stat(density)), 
    alpha = 0.5, position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.5, linewidth = 1) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["naive"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["naive"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.4: Distribution of Predicted Scores for Minority Class (Non-White), Unaware model, Sensitive: Race, Non-White -> White

14.2.2 Aware Model

We turn to the aware model. This time, the sensitive attribute is used by the classifier when it is trained. Hence, changing the sensitive attribute of individuals in the source group to that of the target group may change the predicted values for the binary outcome variable.

The predicted values by the model, on the initial characteristics (on the factuals) are stored in the pred_aware_all object.

We create a tibble with the factuals and the predictions by the aware model:

factuals_aware <-
  compas |> 
  as_tibble() |>
  mutate(
    race_origin = race,
    pred = pred_aware_all,
    type = "factual"
  ) |> 
    mutate(id_indiv = row_number())
aware_naive_nonwhite <- 
  factuals_aware |> mutate(race_origin = race) |> 
  bind_rows(counterfactuals_aware_naive_nonwhite)
ggplot(
  aware_naive_nonwhite |> mutate(
    group = case_when(
      race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
      race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
      race_origin =="White" & race == "White" ~ "White (Original)"
    ),
    group = factor(
      group, 
      levels = c(
        "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
      )
    )
  ),
  aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(
      y = after_stat(density)), alpha = 0.5, colour = NA,
    position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.3, linewidth = 1) +
  facet_wrap(~race) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["naive"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["naive"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.5: Aware model, Sensitive: Race, Non-White -> White

Then, we focus on the distribution of predicted scores for counterfactual of Non-White individuals and factuals of White individuals

Codes used to create the Figure. 
ggplot(
  data = aware_naive_nonwhite |> 
    mutate(
      group = case_when(
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
        race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
        race_origin =="White" & race == "White" ~ "White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
        )
      )
    ) |> 
    filter(race_origin =="Non-White"),
  mapping = aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(y = after_stat(density)), 
    alpha = 0.5, position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.5, linewidth = 1) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["naive"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["naive"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.6: Distribution of Predicted Scores for Minority Class (Non-White), Aware model, Sensitive: Race, Non-White -> White

14.3 Multivariate Optimal Transport

We apply multivariate optimal transport (OT), following the methodology developed in De Lara et al. (2024).

The codes are run in python. We use the {reticulate} R package to call python in this notebook. Let us save the dataset in a CSV format so we can easily import in in python.

write.csv(
  factuals_aware, file = "../data/factuals_aware-compas.csv", 
  row.names = FALSE
)

In this quarto document, we work on a virtual environment.

library(reticulate)
use_virtualenv("~/quarto-python-env", required = TRUE)
#reticulate::install_miniconda(force = TRUE)
#py_install("POT")

Some libraries need to be loaded (including POT called ot).

import ot
import pandas as pd
import numpy as np
import matplotlib.pyplot as pl
import ot.plot
from scipy.spatial.distance import cdist
import sklearn as sk

First, we import the data, and drop characteristics that do not need to be transported.

df_aware = pd.read_csv('../data/factuals_aware-compas.csv')
x_S = df_aware.drop(columns=['race_origin', 'pred', 'type', 'id_indiv'])

We split the dataset into two subsets based on the sensitive attribute.

x_S_0 = x_S[x_S['race'] == 'Non-White']
x_S_1 = x_S[x_S['race'] == 'White']

x_S_0 = x_S_0.drop(columns=['race'])
x_S_1 = x_S_1.drop(columns=['race'])

The number of individuals in each subset:

n_0 = len(x_S_0)
n_1 = len(x_S_1)

We split numerical and categorical data and keep track of the names of numerical and categorical variables:

num_cols = x_S_0.select_dtypes(include=[np.number]).columns
cat_cols = x_S_0.select_dtypes(include=[object, 'category']).columns
num_0, num_1 = x_S_0[num_cols], x_S_1[num_cols]
cat_0, cat_1 = x_S_0[cat_cols], x_S_1[cat_cols]

category_counts = x_S_0[cat_cols].nunique()

Categorical variables are one-hot encoded:

cat_0_encoded, cat_1_encoded = {}, {}
for col in cat_cols:
    cat_0_encoded[col] = pd.get_dummies(cat_0[col], prefix=col)
    cat_1_encoded[col] = pd.get_dummies(cat_1[col], prefix=col)

    columns_0 = cat_0_encoded[col].columns
    cat_0_encoded_np_col = sk.preprocessing.scale(cat_0_encoded[col])
    cat_0_encoded[col] = pd.DataFrame(cat_0_encoded_np_col, columns=columns_0)

    columns_1 = cat_1_encoded[col].columns
    cat_1_encoded_np_col = sk.preprocessing.scale(cat_1_encoded[col])
    cat_1_encoded[col] = pd.DataFrame(cat_1_encoded_np_col, columns=columns_1)
    
    # Align categories for the current column
    cat_0_encoded[col], cat_1_encoded[col] = cat_0_encoded[col].align(
        cat_1_encoded[col], join='outer', axis=1, fill_value=0
    )

For numerical variables, we compute the Euclidean distance.

num_dist = cdist(num_0.to_numpy(), num_1.to_numpy(), metric='euclidean')

For categorical variables, we use the hamming distance.

cat_dists = list()
for col in cat_cols:
    dist = cdist(cat_0_encoded[col].to_numpy(), cat_1_encoded[col].to_numpy(), metric='euclidean')
    cat_dists.append(dist)

Then we need to combine the two distance matrices. We use weights equal to the proportion of numerical variables and the proportion of categorical variables, respectively for distances based on numerical and categorical variables.

# Weight for numerical distance
#alpha = len(num_cols) / (len(num_cols) + len(cat_cols))

#combined_cost = alpha * num_dist

#for i in range(len(cat_dists)):
#  beta = .5 / category_counts.iloc[i]
#  combined_cost += beta * cat_dists[i]

combined_cost = num_dist

for i in range(len(cat_dists)):
  combined_cost += cat_dists[i]

Then, we can compute the transport map:

# Uniform weights (equal distribution)
w_0 = ot.unif(len(x_S_0)) # Source weights
w_1 = ot.unif(len(x_S_1)) # Target weights

# Compute transport plan
transport_plan = ot.emd(w_0, w_1, combined_cost, numItermax=1e8)

Using this transport plan, we transport the numerical variables (only for individuals from the protected group):

num_transported = n_0 * transport_plan @ num_1.to_numpy()

We do the same for categorical data, and we reconstruct labels (the label reconstruction is not perfect here):

transported_cats = {}

for col in cat_cols:
    cat_probs = transport_plan @ cat_1_encoded[col].to_numpy()
    cat_columns = cat_1_encoded[col].columns
    transported_cats[col] = pd.Series(cat_probs.argmax(axis=1)).map(lambda x: cat_columns[x].split('_', 1)[1])

We combine the transported numerical data and the transported categorical data:

transformed_data = pd.DataFrame(num_transported, columns=num_cols)
for col in cat_cols:
    transformed_data[col] = transported_cats[col].values

Laslt, we export the data to a CSV file.

csv_file_path = '../data/counterfactuals-ot-nonwhite-compas.csv'
transformed_data.to_csv(csv_file_path, index=False)

Then, we can get back to using R. We load the transported data.

df_counterfactuals_ot_nonwhite <- read_csv('../data/counterfactuals-ot-nonwhite-compas.csv') |> 
  mutate(
    id_indiv = ind_nonwhite,
    race_origin = "Non-White",
    race = "White"
  ) |> 
  mutate(
    c_charge_degree = str_remove(c_charge_degree, "^charge_degree_")
  )
Rows: 4760 Columns: 8
── Column specification ────────────────────────────────────────────────────────
Delimiter: ","
chr (2): sex, c_charge_degree
dbl (6): age, juv_fel_count, juv_misd_count, juv_other_count, priors_count, ...

ℹ Use `spec()` to retrieve the full column specification for this data.
ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

We make predictions based on those counterfactuals obtained with multivariate optimal transport, on both models (the unaware model, and the aware model):

pred_ot_unaware <- predict(
  model_unaware, newdata = df_counterfactuals_ot_nonwhite, type = "response"
)

pred_ot_aware <- predict(
  model_aware, newdata = df_counterfactuals_ot_nonwhite, type = "response"
)
counterfactuals_unaware_ot_nonwhite <- 
  df_counterfactuals_ot_nonwhite |> 
  mutate(pred = pred_ot_unaware, type = "counterfactual")
counterfactuals_aware_ot_nonwhite <- 
  df_counterfactuals_ot_nonwhite |> 
  mutate(pred = pred_ot_aware, type = "counterfactual")

Let us put in a single table the predictions made by the classifier (either aware or unaware) on Women based on their factual characteristics, and those made based on the counterfactuals:

aware_ot_nonwhite <- bind_rows(
  factuals_aware |> mutate(id_indiv = row_number(), race_origin = race), 
  counterfactuals_aware_ot_nonwhite |> mutate(S_origin = "Non-White")
)
unaware_ot_nonwhite <- bind_rows(
  factuals_unaware |> mutate(id_indiv = row_number(), race_origin = race), 
  counterfactuals_unaware_ot_nonwhite |> mutate(S_origin = "Non-White")
)
Codes used to create the Figure. 
ggplot(
  data = unaware_ot_nonwhite |> 
    mutate(
      group = case_when(
        race_origin == "Non-White" & race == "Non-White" ~ "Women (Original)",
        race_origin == "Non-White" & race == "White" ~ "Women -> Men (Counterfactual)",
        race_origin == "White" & race == "White" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ),
  aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(
      y = after_stat(density)), alpha = 0.5, colour = NA,
    position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.3, linewidth = 1) +
  facet_wrap(~race) +
  scale_fill_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["ot"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["ot"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.7: Unaware model, Sensitive: Race, Non-White -> White
Codes used to create the Figure. 
ggplot(
  data = aware_ot_nonwhite |> 
    mutate(
      group = case_when(
        race_origin == "Non-White" & race == "Non-White" ~ "Women (Original)",
        race_origin == "Non-White" & race == "White" ~ "Women -> Men (Counterfactual)",
        race_origin == "White" & race == "White" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ),
  aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(
      y = after_stat(density)), alpha = 0.5, colour = NA,
    position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.3, linewidth = 1) +
  facet_wrap(~race) +
  scale_fill_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["ot"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["ot"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.8: Aware model, Sensitive: Race, Non-White -> White

Then, we focus on the distribution of predicted scores for counterfactual of nonwhite and factuals of men.

Codes used to create the Figure. 
ggplot(
  data = unaware_ot_nonwhite |> 
    mutate(
      group = case_when(
        race_origin == "Non-White" & race == "Non-White" ~ "Women (Original)",
        race_origin == "Non-White" & race == "White" ~ "Women -> Men (Counterfactual)",
        race_origin == "White" & race == "White" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ) |> 
    filter(race_origin == "Non-White"),
  mapping = aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(y = after_stat(density)), 
    alpha = 0.5, position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.5, linewidth = 1) +
  scale_fill_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["ot"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["ot"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.9: Distribution of Predicted Scores for Minority Class (Women), Unaware model, Sensitive: Race, Non-White -> White
Codes used to create the Figure. 
ggplot(
  data = aware_ot_nonwhite |> 
    mutate(
      group = case_when(
        race_origin == "Non-White" & race == "Non-White" ~ "Women (Original)",
        race_origin == "Non-White" & race == "White" ~ "Women -> Men (Counterfactual)",
        race_origin == "White" & race == "White" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ) |> 
    filter(race_origin == "Non-White"),
  mapping = aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(y = after_stat(density)), 
    alpha = 0.5, position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.5, linewidth = 1) +
  scale_fill_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["ot"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["ot"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.10: Distribution of Predicted Scores for Minority Class (Women), Aware model, Sensitive: Race, Non-White -> White

14.4 Fairadapt

We have already assumed a causal graph (see Figure 14.2).

Let us consider that we want to build counterfactuals for Non-White individuals: what if the individual had been White and not Non-White?

Let us have a look at the levels of our sensitive variable:

levels(compas |> pull(!!s))
[1] "Non-White" "White"

Two configurations will be considered in turn:

  1. The reference class consists of White individuals, and fairadapt will be used to obtain the counterfactual values for Non-White individuals as if they had been White individuals.
  2. The reference class consists of Non-White individuals, and fairadapt will be used to obtain the counterfactual values for White individuals as if they had been Non-White individuals.
# Non-White (factuals) --> White (counterfactuals)
df_fpt <- compas |> mutate(race = fct_relevel(race, "Non-White", after = Inf))
fpt_model_nonwhite <- fairadapt(
  two_year_recid ~ .,
  train.data = df_fpt,
  prot.attr = "race", adj.mat = adj_mat,
  quant.method = rangerQuants
)
adapt_df_nonwhite <- adaptedData(fpt_model_nonwhite)

# White (factuals) --> Non-White (counterfactuals)
df_fpt <- df_fpt |> mutate(race = fct_relevel(race, "White", after = Inf))
fpt_model_white <- fairadapt(
  two_year_recid ~ .,
  train.data = df_fpt,
  prot.attr = "race", adj.mat = adj_mat,
  quant.method = rangerQuants
)
adapt_df_white <- adaptedData(fpt_model_white)

Let us wrap up:

  • we have two predictive models for the target variable (whether the person has re-offended within two years):

    • unaware (without S)
    • aware (with S)

  • we have the counterfactual characteristics obtained with fairadapt in two situations depending on the reference class:

    • Non-White individuals as reference
    • White individuals as reference.

The predictive models will be used to compare predictions made using:

  • Raw characteristics (initial characteristics).
  • Characteristics possibly altered through fairadapt for individuals who were not in the reference group (i.e., using counterfactuals).

14.4.1 Unaware Model

Let us build a dataset containing only counterfactual characteristics obtained with fairadapt.

pred_unaware_fpt_nonwhite <- predict(
  model_unaware, 
  newdata = adapt_df_nonwhite[ind_nonwhite, ], 
  type = "response"
)
pred_unaware_fpt_white <- predict(
  model_unaware, 
  newdata = adapt_df_white[ind_white, ],
  type = "response"
)

We create a table with the counterfactual characteristics and the prediction by the unaware model:

counterfactuals_unaware_fpt_nonwhite <- 
  as_tibble(adapt_df_nonwhite[ind_nonwhite, ]) |> 
  mutate(
    race_origin = compas$race[ind_nonwhite],
    pred = pred_unaware_fpt_nonwhite,
    type = "counterfactual",
    id_indiv = ind_nonwhite
  )

counterfactuals_unaware_fpt_white <- 
  as_tibble(adapt_df_white[ind_white, ]) |> 
  mutate(
    race_origin = compas$race[ind_white],
    pred = pred_unaware_fpt_white,
    type = "counterfactual",
    id_indiv = ind_white
  )

We merge the two datasets, factuals_unaware and counterfactuals_unaware_fpt_nonwhite (or counterfactuals_unaware_fpt_white) in a single one.

unaware_fpt_nonwhite <- 
  factuals_unaware |> mutate(race_origin = race) |> 
  bind_rows(counterfactuals_unaware_fpt_nonwhite)
  
unaware_fpt_white <- 
  factuals_unaware |> mutate(race_origin = race) |> 
  bind_rows(counterfactuals_unaware_fpt_white)
Codes used to create the Figure. 
ggplot(
  data = unaware_fpt_nonwhite |> 
    mutate(
      group = case_when(
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
        race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
        race_origin =="White" & race == "White" ~ "White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
        )
      )
    ),
  aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(
      y = after_stat(density)), alpha = 0.5, colour = NA,
    position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.3, linewidth = 1) +
  facet_wrap(~race) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["fairadapt"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["fairadapt"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.11: Unaware model, Sensitive: Race, Non-White -> White
Codes used to create the Figure. 
ggplot(
  data = unaware_fpt_white |> 
    mutate(
      group = case_when(
        race_origin =="White" & race == "White" ~ "White (Original)",
        race_origin =="White" & race == "Non-White" ~ "White -> Non-White (Counterfactual)",
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "White (Original)", "White -> Non-White (Counterfactual)", "Non-White (Original)"
        )
      )
    ),
  aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(
      y = after_stat(density)), alpha = 0.5, colour = NA,
    position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.3, linewidth = 1) +
  facet_wrap(~race) +
  scale_fill_manual(
    NULL, values = c(
      "White (Original)" = colours_all[["source"]],
      "White -> Non-White (Counterfactual)" = colours_all[["fairadapt"]],
      "Non-White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "White (Original)" = colours_all[["source"]],
      "White -> Non-White (Counterfactual)" = colours_all[["fairadapt"]],
      "Non-White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.12: Unaware model, Sensitive: Race, White -> Non-White

Then, we focus on the distribution of predicted scores for counterfactual of Non-White individuals and factuals of White individuals.

Codes used to create the Figure. 
ggplot(
  data = unaware_fpt_nonwhite |> 
    mutate(
      group = case_when(
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
        race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
        race_origin =="White" & race == "White" ~ "White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
        )
      )
    ) |> 
    filter(race_origin =="Non-White"),
  mapping = aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(y = after_stat(density)), 
    alpha = 0.5, position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.5, linewidth = 1) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["fairadapt"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["fairadapt"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.13: Distribution of Predicted Scores for Minority Class (Non-White), Unaware model, Sensitive: Race, Non-White -> White
Codes used to create the Figure. 
ggplot(
  data = unaware_fpt_white |> 
    mutate(
      group = case_when(
        race_origin =="White" & race == "White" ~ "White (Original)",
        race_origin =="White" & race == "Non-White" ~ "White -> Non-White (Counterfactual)",
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "White (Original)", "White -> Non-White (Counterfactual)", "Non-White (Original)"
        )
      )
    ) |> 
    filter(race_origin =="White"),
  mapping = aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(y = after_stat(density)), 
    alpha = 0.5, position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.5, linewidth = 1) +
  scale_fill_manual(
    NULL, values = c(
      "White (Original)" = colours_all[["source"]],
      "White -> Non-White (Counterfactual)" = colours_all[["fairadapt"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "White (Original)" = colours_all[["source"]],
      "White -> Non-White (Counterfactual)" = colours_all[["fairadapt"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.14: Distribution of Predicted Scores for Minority Class (White), Unaware model, Sensitive: Race, White -> Non-White

14.4.2 Aware Model

Now, we turn to the model that includes the sensitive attribute, i.e., the aware model. Let us get the predicted values for the counterfactuals, using the aware model:

pred_aware_fpt_nonwhite <- predict(
  model_aware, 
  newdata = adapt_df_nonwhite[ind_nonwhite, ], 
  type = "response"
)
pred_aware_fpt_white <- predict(
  model_aware, 
  newdata = adapt_df_white[ind_white, ],
  type = "response"
)

Then, we create a table with the counterfactuals and the predicted value by the aware model:

counterfactuals_aware_fpt_nonwhite <- 
  as_tibble(adapt_df_nonwhite[ind_nonwhite, ]) |> 
  mutate(
    race_origin = compas$race[ind_nonwhite],
    pred = pred_aware_fpt_nonwhite,
    type = "counterfactual",
    id_indiv = ind_nonwhite
  )

counterfactuals_aware_fpt_white <- 
  as_tibble(adapt_df_white[ind_white, ]) |> 
  mutate(
    race_origin = compas$race[ind_white],
    pred = pred_aware_fpt_white,
    type = "counterfactual",
    id_indiv = ind_white
  )

We merge the two datasets, factuals_unaware and counterfactuals_aware_fpt_nonwhite (or counterfactuals_aware_fpt_white) in a single one.

# dataset with counterfactuals, for aware model
aware_fpt_nonwhite <- 
  factuals_aware |> mutate(rac_origin = race) |> 
  bind_rows(counterfactuals_aware_fpt_nonwhite)
  
aware_fpt_white <- 
  factuals_aware |> mutate(race_origin = race) |> 
  bind_rows(counterfactuals_aware_fpt_white)
Codes used to create the Figure. 
ggplot(
  data = aware_fpt_nonwhite |> 
    mutate(
      group = case_when(
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
        race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
        race_origin =="White" & race == "White" ~ "White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
        )
      )
    ),
  aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(
      y = after_stat(density)), alpha = 0.5, colour = NA,
    position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.3, linewidth = 1) +
  facet_wrap(~race) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["fairadapt"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["fairadapt"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.15: Aware model, Sensitive: Race, Reference: White individuals
Codes used to create the Figure. 
ggplot(
  data = aware_fpt_white |> 
    mutate(
      group = case_when(
        race_origin =="White" & race == "White" ~ "White (Original)",
        race_origin =="White" & race == "Non-White" ~ "White -> Non-White (Counterfactual)",
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "White (Original)", "White -> Non-White (Counterfactual)", "Non-White (Original)"
        )
      )
    ),
  aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(
      y = after_stat(density)), alpha = 0.5, colour = NA,
    position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.3, linewidth = 1) +
  facet_wrap(~race) +
  scale_fill_manual(
    NULL, values = c(
      "White (Original)" = colours_all[["source"]],
      "White -> Non-White (Counterfactual)" = colours_all[["fairadapt"]],
      "Non-White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "White (Original)" = colours_all[["source"]],
      "White -> Non-White (Counterfactual)" = colours_all[["fairadapt"]],
      "Non-White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.16: Aware model, Sensitive: Race, Reference: Non-White individuals

Then, we focus on the distribution of predicted scores for counterfactual of Non-White individuals and factuals of White individuals.

Codes used to create the Figure. 
ggplot(
  data = aware_fpt_nonwhite |> 
    mutate(
      group = case_when(
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
        race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
        race_origin =="White" & race == "White" ~ "White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
        )
      )
    ) |> 
    filter(race_origin =="Non-White"),
  mapping = aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(y = after_stat(density)), 
    alpha = 0.5, position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.5, linewidth = 1) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["fairadapt"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["fairadapt"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.17: Distribution of Predicted Scores for Minority Class (Non-White), Aware model, Sensitive: Race, Reference: White individuals
Codes used to create the Figure. 
ggplot(
  data = aware_fpt_white |> 
    mutate(
      group = case_when(
        race_origin =="White" & race == "White" ~ "White (Original)",
        race_origin =="White" & race == "Non-White" ~ "White -> Non-White (Counterfactual)",
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "White (Original)", "White -> Non-White (Counterfactual)", "Non-White (Original)"
        )
      )
    ) |> 
    filter(race_origin =="White"),
  mapping = aes(x = pred, fill = group, colour = group)
  ) +
  geom_histogram(
    mapping = aes(y = after_stat(density)), 
    alpha = 0.5, position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.5, linewidth = 1) +
  scale_fill_manual(
    NULL, values = c(
      "White (Original)" = colours_all[["source"]],
      "White -> Non-White (Counterfactual)" = colours_all[["fairadapt"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "White (Original)" = colours_all[["source"]],
      "White -> Non-White (Counterfactual)" = colours_all[["fairadapt"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.18: Distribution of Predicted Scores for Minority Class (White), Aware model, Sensitive: Race, Reference: Non-White individuals

14.5 Sequential Transport

We now turn to sequential transport (the methodology developed in our paper). We use the seq_trans() function defined in our small package to perform a fast sequential transport on causal graph.

We use the same causal graph as in Section 14.4.

sequential_transport <- seq_trans(
  data = compas, adj = adj_mat,
  s = "race", S_0 = "Non-White", y = "two_year_recid"
)
Transporting  age 
Transporting  sex 
Transporting  juv_misd_count 
Transporting  juv_other_count 
Transporting  juv_fel_count 
Transporting  priors_count 
Transporting  c_charge_degree 
# weights:  8 (7 variable)
initial  value 1700.983181 
iter  10 value 1591.143276
final  value 1591.092129 
converged

We build a dataset with the sensitive attribute of Non-White individuals changed to White individuals, and their characteristics changed to their transported characteristics:

df_counterfactuals_seq_nonwhite <- 
  as_tibble(sequential_transport$transported) |> 
  mutate(
    id_indiv = ind_nonwhite,
    race_origin = "Non-White",
    race = "White"
  )

We make predictions based on those counterfactuals obtained with sequential transport, on both models (the unaware model, and the aware model):

pred_seq_unaware <- predict(
  model_unaware, newdata = df_counterfactuals_seq_nonwhite, type = "response"
)

pred_seq_aware <- predict(
  model_aware, newdata = df_counterfactuals_seq_nonwhite, type = "response"
)
counterfactuals_unaware_seq_nonwhite <- 
  df_counterfactuals_seq_nonwhite |> 
  mutate(pred = pred_seq_unaware, type = "counterfactual")
counterfactuals_aware_seq_nonwhite <- 
  df_counterfactuals_seq_nonwhite |> 
  mutate(pred = pred_seq_aware, type = "counterfactual")

Let us put in a single table the predictions made by the classifier (either aware or unaware) on Non-White individuals based on their factual characteristics, and those made based on the counterfactuals:

aware_seq_nonwhite <- bind_rows(
  factuals_aware |> mutate(id_indiv = row_number(), race_origin = race), 
  counterfactuals_aware_seq_nonwhite |> mutate(S_origin = "Non-White")
)
unaware_seq_nonwhite <- bind_rows(
  factuals_unaware |> mutate(id_indiv = row_number(), race_origin = race), 
  counterfactuals_unaware_seq_nonwhite |> mutate(S_origin = "Non-White")
)
Codes used to create the Figure. 
ggplot(
  data = unaware_seq_nonwhite |> 
    mutate(
      group = case_when(
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
        race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
        race_origin =="White" & race == "White" ~ "White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
        )
      )
    ),
  aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(
      y = after_stat(density)), alpha = 0.5, colour = NA,
    position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.3, linewidth = 1) +
  facet_wrap(~race) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["seq"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["seq"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.19: Unaware model, Sensitive: Race, Non-White -> White
Codes used to create the Figure. 
ggplot(
  data = aware_seq_nonwhite |> 
    mutate(
      group = case_when(
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
        race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
        race_origin =="White" & race == "White" ~ "White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
        )
      )
    ),
  aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(
      y = after_stat(density)), alpha = 0.5, colour = NA,
    position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.3, linewidth = 1) +
  facet_wrap(~race) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["seq"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["seq"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.20: Aware model, Sensitive: Race, Non-White -> White

Then, we focus on the distribution of predicted scores forcounterfactual of Non-White individuals and factuals of White individuals.

Codes used to create the Figure. 
ggplot(
  data = unaware_seq_nonwhite |> 
    mutate(
      group = case_when(
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
        race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
        race_origin =="White" & race == "White" ~ "White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
        )
      )
    ) |> 
    filter(race_origin =="Non-White"),
  mapping = aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(y = after_stat(density)), 
    alpha = 0.5, position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.5, linewidth = 1) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["seq"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["seq"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.21: Distribution of Predicted Scores for Minority Class (Non-White), Unaware model, Sensitive: Race, Non-White -> White
Codes used to create the Figure. 
ggplot(
  data = aware_seq_nonwhite |> 
    mutate(
      group = case_when(
        race_origin =="Non-White" & race == "Non-White" ~ "Non-White (Original)",
        race_origin =="Non-White" & race == "White" ~ "Non-White -> White (Counterfactual)",
        race_origin =="White" & race == "White" ~ "White (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Non-White (Original)", "Non-White -> White (Counterfactual)", "White (Original)"
        )
      )
    ) |> 
    filter(race_origin =="Non-White"),
  mapping = aes(x = pred, fill = group, colour = group)
) +
  geom_histogram(
    mapping = aes(y = after_stat(density)), 
    alpha = 0.5, position = "identity", binwidth = 0.05
  ) +
  geom_density(alpha = 0.5, linewidth = 1) +
  scale_fill_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["seq"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Non-White (Original)" = colours_all[["source"]],
      "Non-White -> White (Counterfactual)" = colours_all[["seq"]],
      "White (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 14.22: Distribution of Predicted Scores for Minority Class (Non-White), Aware model, Sensitive: Race, Non-White -> White

14.6 Comparison

Let us now compare the results.

tb_unaware <- 
  factuals_unaware |> mutate(counterfactual = "none") |>
  # Naive
  bind_rows(
    counterfactuals_unaware_naive_nonwhite |> mutate(counterfactual = "naive")
  ) |> 
  # Multivariate Optimal Transport
  bind_rows(
    counterfactuals_unaware_ot_nonwhite |> mutate(counterfactual = "ot")
  ) |> 
  # Fairadapt
  bind_rows(
    counterfactuals_unaware_fpt_nonwhite |> mutate(counterfactual = "fpt")
  ) |> 
  # Sequential transport
  bind_rows(
    counterfactuals_unaware_seq_nonwhite |> mutate(counterfactual = "seq")
  )
tb_aware <- 
  factuals_aware |> mutate(counterfactual = "none") |> 
  # Naive
  bind_rows(
    counterfactuals_aware_naive_nonwhite |> mutate(counterfactual = "naive")
  ) |> 
  # Multivariate Optimal Transport
  bind_rows(
    counterfactuals_aware_ot_nonwhite |> mutate(counterfactual = "ot")
  ) |> 
  # Fairadapt
  bind_rows(
    counterfactuals_aware_fpt_nonwhite |> mutate(counterfactual = "fpt")
  ) |> 
  # Sequential transport
  bind_rows(
    counterfactuals_aware_seq_nonwhite |> mutate(counterfactual = "seq")
  )

Let us compare the densities of the predicted values.

Codes used to create the Figure. 
# Factuals
tb_unaware_factuals <- tb_unaware |> filter(counterfactual == "none")
# Predicted values
pred_unaware_factuals_nonwhite <- tb_unaware_factuals |> filter(race == "Non-White") |> pull("pred")
pred_unaware_factuals_white <- tb_unaware_factuals |> filter(race == "White") |> pull("pred")
# Estimated densities
d_unaware_factuals_nonwhite <- density(pred_unaware_factuals_nonwhite)
d_unaware_factuals_white <- density(pred_unaware_factuals_white)

par(mfrow = c(4, 1), mar = c(2, 2, 1, 0))
x_lim <- c(0, .8)
y_lim <- c(0, 4)

# OT
tb_unaware_ot <- tb_unaware |> filter(counterfactual == "ot")
# Predicted values, focusing on Non-White --> White
pred_unaware_ot_nonwhite_star <- tb_unaware_ot |> filter(race_origin == "Non-White") |> pull("pred")
# Estimated densities
d_unaware_ot_nonwhite_star <- density(pred_unaware_ot_nonwhite_star)

plot(
  d_unaware_factuals_nonwhite,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_unaware_factuals_nonwhite, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_unaware_factuals_white, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_unaware_ot_nonwhite_star, col = alpha(colours_all[["ot"]], .5), border = NA)
pos_arrow_ref <- .1
text(x = pos_arrow_ref, y = 3.5, "Factuals - White", col = colours_all[["reference"]])
ind_min_ref <- which.min(abs(d_unaware_factuals_white$x - pos_arrow_ref))
arrows(
  x1 = d_unaware_factuals_white$x[ind_min_ref],
  y1 = d_unaware_factuals_white$y[ind_min_ref],
  x0 = pos_arrow_ref, 
  y0 = 3,
  length = 0.05, col = colours_all[["reference"]]
)

pos_arrow_ref <- .47
text(x = .4, y = 3.5, "Factuals - Non-White", col = colours_all[["source"]])
ind_min_ref <- which.min(abs(d_unaware_factuals_white$x - pos_arrow_ref))
arrows(
  x1 = d_unaware_factuals_nonwhite$x[ind_min_ref],
  y1 = d_unaware_factuals_nonwhite$y[ind_min_ref],
  x0 = .4, 
  y0 = 3,
  length = 0.05, col = colours_all[["source"]]
)
text(x = .7, y = 3.5, "Multi. OT", col = colours_all[["ot"]])


# Naive
tb_unaware_naive <- tb_unaware |> filter(counterfactual == "naive")
# Predicted values, focusing on Non-White --> White
pred_unaware_naive_nonwhite_star <- tb_unaware_naive |> filter(race == "White") |> pull("pred")
# Estimated densities
d_unaware_naive_nonwhite_star <- density(pred_unaware_naive_nonwhite_star)

plot(
  d_unaware_factuals_nonwhite,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_unaware_factuals_nonwhite, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_unaware_factuals_white, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_unaware_naive_nonwhite_star, col = alpha(colours_all[["naive"]], .5), border = NA)
text(x = .7, y = 3.5, "Naive", col = colours_all[["naive"]])


# Fairadapt
tb_unaware_fpt <- tb_unaware |> filter(counterfactual == "fpt")
# Predicted values, focusing on Non-White --> White
pred_unaware_fpt_nonwhite_star <- 
  tb_unaware_fpt |> filter(race == "White") |> pull("pred")
# Estimated densities
d_unaware_fpt_nonwhite_star <- density(pred_unaware_fpt_nonwhite_star)

plot(
  d_unaware_factuals_nonwhite,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_unaware_factuals_nonwhite, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_unaware_factuals_white, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_unaware_fpt_nonwhite_star, col = alpha(colours_all[["fairadapt"]], .5), border = NA)
text(x = .7, y = 3.5, "fairadapt", col = colours_all[["fairadapt"]])


# Sequential transport
tb_unaware_seq <- tb_unaware |> filter(counterfactual == "seq")
# Predicted values, focusing on Non-White --> White
pred_unaware_seq_nonwhite_star <- tb_unaware_seq |> filter(race == "White") |> pull("pred")
# Estimated densities
d_unaware_seq_nonwhite_star <- density(pred_unaware_seq_nonwhite_star)

plot(
  d_unaware_factuals_nonwhite,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_unaware_factuals_nonwhite, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_unaware_factuals_white, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_unaware_seq_nonwhite_star, col = alpha(colours_all[["seq"]], .5), border = NA)
text(x = .7, y = 3.5, "Seq. T.", col = colours_all[["seq"]])
Figure 14.23: Densities of predicted scores for Non-White individuals with factuals and White individuals counterfactuals. The yellow dashed line corresponds to the density of predicted scores for Non-White individuals, using factuals.
Codes used to create the Figure. 
# Factuals
tb_aware_factuals <- tb_aware |> filter(counterfactual == "none")
# Predicted values
pred_aware_factuals_nonwhite <- tb_aware_factuals |> filter(race == "Non-White") |> pull("pred")
pred_aware_factuals_white <- tb_aware_factuals |> filter(race == "White") |> pull("pred")
# Estimated densities
d_aware_factuals_nonwhite <- density(pred_aware_factuals_nonwhite)
d_aware_factuals_white <- density(pred_aware_factuals_white)

par(mfrow = c(4, 1), mar = c(2, 2, 1, 0))
x_lim <- c(0, .8)
y_lim <- c(0, 4)


# OT
tb_aware_ot <- tb_aware |> filter(counterfactual == "ot")
# Predicted values, focusing on Non-White --> White
pred_aware_ot_nonwhite_star <- tb_aware_ot |> filter(race_origin == "Non-White") |> pull("pred")
# Estimated densities
d_aware_ot_nonwhite_star <- density(pred_aware_ot_nonwhite_star)

plot(
  d_aware_factuals_nonwhite,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_aware_factuals_nonwhite, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_aware_factuals_white, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_aware_ot_nonwhite_star, col = alpha(colours_all[["ot"]], .5), border = NA)

text(x = .4, y = 3.5, "Factuals - Non-White", col = colours_all[["source"]])
pos_arrow <- .45
ind_min <- which.min(abs(d_aware_factuals_nonwhite$x - pos_arrow))
arrows(
  x1 = d_aware_factuals_nonwhite$x[ind_min],
  y1 = d_aware_factuals_nonwhite$y[ind_min],
  x0 = .4, 
  y0 = 3,
  length = 0.05, col = colours_all[["source"]]
)
pos_arrow_ref <- .2
text(x = .1, y = 3.5, "Factuals - White", col = colours_all[["reference"]])
ind_min_ref <- which.min(abs(d_aware_factuals_white$x - pos_arrow_ref))
arrows(
  x1 = d_aware_factuals_white$x[ind_min_ref],
  y1 = d_aware_factuals_white$y[ind_min_ref],
  x0 = .1, 
  y0 = 3,
  length = 0.05, col = colours_all[["reference"]]
)
text(x = .7, y = 3.5, "Multi. OT", col = colours_all[["ot"]])

# Naive
tb_aware_naive <- tb_aware |> filter(counterfactual == "naive")
# Predicted values, focusing on Non-White --> White
pred_aware_naive_nonwhite_star <- tb_aware_naive |> filter(race == "White") |> pull("pred")
# Estimated densities
d_aware_naive_nonwhite_star <- density(pred_aware_naive_nonwhite_star)

plot(
  d_aware_factuals_nonwhite,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_aware_factuals_nonwhite, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_aware_factuals_white, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_aware_naive_nonwhite_star, col = alpha(colours_all[["naive"]], .5), border = NA)
text(x = .7, y = 3.5, "Naive", col = colours_all[["naive"]])


# Fairadapt
tb_aware_fpt <- tb_aware |> filter(counterfactual == "fpt")
# Predicted values, focusing on Non-White --> White
pred_aware_fpt_nonwhite_star <- 
  tb_aware_fpt |> filter(race == "White") |> pull("pred")
# Estimated densities
d_aware_fpt_nonwhite_star <- density(pred_aware_fpt_nonwhite_star)

plot(
  d_aware_factuals_nonwhite,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_aware_factuals_nonwhite, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_aware_factuals_white, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_aware_fpt_nonwhite_star, col = alpha(colours_all[["fairadapt"]], .5), border = NA)
text(x = .7, y = 3.5, "fairadapt", col = colours_all[["fairadapt"]])


# Sequential transport
tb_aware_seq <- tb_aware |> filter(counterfactual == "seq")
# Predicted values, focusing on Non-White --> White
pred_aware_seq_nonwhite_star <- tb_aware_seq |> filter(race == "White") |> pull("pred")
# Estimated densities
d_aware_seq_nonwhite_star <- density(pred_aware_seq_nonwhite_star)

plot(
  d_aware_factuals_nonwhite,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_aware_factuals_nonwhite, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_aware_factuals_white, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_aware_seq_nonwhite_star, col = alpha(colours_all[["seq"]], .5), border = NA)
text(x = .7, y = 3.5, "Seq. T.", col = colours_all[["seq"]])
Figure 14.24: Densities of predicted scores for Non-White individuals with factuals and with counterfactuals. The yellow dashed line corresponds to the density of predicted scores for Non-White individuals, using factuals.

14.7 Metrics

We now turn to some metrics based on the predictions made for each model, based on the factual values in each group \(\boldsymbol{x}\), and on the counterfactual values \(\boldsymbol{x}^\star\) for individuals from the group of Non-White individuals \(\mathcal{D}_0\). For most metrics, the scoring classifier \(m(\cdot)\) is transformed into a threshold-based classifier \(m_t(\cdot)\), where \(m_t(\cdot)=1\) if \(m(\cdot) > t\), and \(m_t(\cdot)=0\) otherwise. We set the threshold to \(t=.5\).

threshold <- .5

Let us get vectors of observes values \(x_i \in \mathcal{D}\) as well as predicted scores for factual observations \(m(s_i, \boldsymbol{x}_i)\) and for counterfactual observations for individuals in \(\mathcal{D_0}\), i.e., \(m(1, \boldsymbol{x}_i^\star)\).

# Observed target variable
obs_0 <- factuals_aware |> filter(race_origin == "Non-White") |> pull("two_year_recid")
obs_1 <- factuals_aware |> filter(race_origin == "White") |> pull("two_year_recid")
# Scores using factuals
pred_0_aware <- factuals_aware |> filter(race_origin == "Non-White") |> pull("pred")
pred_1_aware <- factuals_aware |> filter(race_origin == "White") |> pull("pred")
pred_0_unaware <- factuals_unaware |> filter(race_origin == "Non-White") |> pull("pred")
pred_1_unaware <- factuals_unaware |> filter(race_origin == "White") |> pull("pred")
# Scores in groups S="Non-White" using naive counterfactuals
pred_0_naive_aware <- pred_aware_naive_nonwhite
pred_0_naive_unaware <- pred_unaware_naive_nonwhite
# Scores in groups S="Non-White" using OT counterfactuals
pred_0_ot_aware <- tb_aware_ot |> filter(race_origin == "Non-White") |> pull("pred")
pred_0_ot_unaware <- tb_unaware_ot |> filter(race_origin == "Non-White") |> pull("pred")
# Scores in groups S="Non-White" using fairadapt counterfactuals
pred_0_fpt_aware <- pred_aware_fpt_nonwhite
pred_0_fpt_unaware <- pred_unaware_fpt_nonwhite
# Scores in groups S="Non-White" using sequential transport counterfactuals
pred_0_seq_aware <- pred_seq_aware
pred_0_seq_unaware <- pred_seq_unaware

Then, we use the counter_fair_metrics() function from our package to compute the metrics presented in Section 12.4.

names_pred <- rep(c("naive", "ot", "fpt", "seq"), each = 2)
names_model <- rep(c("aware", "unaware"), length(names_pred)/2)
metrics_all <- map2(
  .x = list(
    pred_0_naive_aware, pred_0_naive_unaware,
    pred_0_ot_aware, pred_0_ot_unaware,
    pred_0_fpt_aware, pred_0_fpt_unaware,
    pred_0_seq_aware, pred_0_seq_unaware
  ),
  .y = names_model,
  .f = ~{
    if (.y == "aware") {
      pred_0 <- pred_0_aware
      pred_1 <- pred_1_aware
    } else {
      pred_0 <- pred_0_unaware
      pred_1 <- pred_1_unaware
    }
    counter_fair_metrics(
      obs_0 = obs_0, obs_1 = obs_1, 
      pred_0 = pred_0, 
      pred_0_t = .x, 
      pred_1 = pred_1, 
      threshold = threshold
    )
  }
)
names(metrics_all) <- str_c(names_pred, "_", names_model)

Then, we format the results to be able to procude a summary table.

Format results. 
group_metrics <-
  map(metrics_all, "group_metrics") |> 
  list_rbind(names_to = "model") |> 
  mutate(
    cf_type = str_extract(model, "^(.*)_") |> str_remove("_$"),
    model = str_remove(model, "^(.*)_")
  ) |> 
  mutate(
    model = factor(
      model, levels = c("aware", "unaware"), labels = c("Aware", "Unaware")
    )
  ) |> 
  filter(
    metric %in% c("n_obs", "TPR", "FPR")
  ) |>
  pivot_wider(names_from = "cf_type", values_from = "group_0_t") |> 
  relocate(group_1, .after = "seq")

counter_metrics <-
  map(metrics_all, ~enframe(.x[["counter_metrics_0"]])) |> 
  list_rbind(names_to = "model") |> 
  mutate(
    cf_type = str_extract(model, "^(.*)_") |> str_remove("_$"),
    model = str_remove(model, "^(.*)_")
  ) |> 
  mutate(
    model = factor(
      model, levels = c("aware", "unaware"), labels = c("Aware", "Unaware")
    )
  ) |> 
  pivot_wider(names_from = "cf_type", values_from = "value") |> 
  rename(metric = name) |> 
  filter(metric %in% c("c_demog_parity", "c_eq_op", "class_bal_fnr", "c_eq_treatment"))

tb_metrics <- 
  group_metrics |> mutate(type = "groups") |> 
  bind_rows(counter_metrics |> mutate(type = "cf")) |> 
  mutate(
    metric = factor(
      metric, 
      levels = c(
        "TPR", "FPR", "c_demog_parity", "c_eq_op", "class_bal_fnr",
        "c_eq_treatment", "n_obs"
      )
    ),
    type = factor(type, levels = c("groups", "cf"))
  ) |> 
  arrange(model, type, metric) |> 
  relocate(type, .after = "model")

The results are shown in Table 14.1

Codes used to create the Table. 
options(knitr.kable.NA = '')

tb_metrics |>
  select(-model, -type) |>
  # select(-type) |>
  knitr::kable(
    col.names = c("", "S=0", "Naive", "OT", "Fairadapt", "Seq", "S=1"),
    digits = 2,
    booktabs = TRUE
  ) |> 
  kableExtra::kable_styling() |> 
  kableExtra::pack_rows(index = table(tb_metrics$model))
Table 14.1: Metrics to Assess Fairness of the Model (COMPAS dataset).
S=0 Naive OT Fairadapt Seq S=1
Aware
TPR 0.57 0.67 0.39 0.53 0.65 0.45
FPR 0.23 0.31 0.18 0.22 0.41 0.19
n_obs 4760.00 4760.00 4760.00 4760.00 4760.00 2454.00
c_demog_parity 0.02 -0.07 -0.02 0.02
c_eq_op 0.10 -0.18 -0.04 0.08
class_bal_fnr 0.76 1.42 1.10 0.82
c_eq_treatment 0.41 -0.23 -0.07 0.62
Unaware
TPR 0.61 0.61 0.35 0.47 0.62 0.40
FPR 0.25 0.25 0.14 0.17 0.38 0.15
n_obs 4760.00 4760.00 4760.00 4760.00 4760.00 2454.00
c_demog_parity 0.00 -0.09 -0.05 0.00
c_eq_op 0.00 -0.26 -0.14 0.02
class_bal_fnr 1.00 1.66 1.36 0.96
c_eq_treatment 0.00 -0.42 -0.33 0.36
LaTeX code for the table. 
tb_metrics |>
  select(-model, -type) |>
  # select(-type) |>
  knitr::kable(
    col.names = c("Metric", "S=0", "Naive", "OT", "Fairadapt", "Seq", "S=1"),
    digits = 2, format = "latex",
    booktabs = TRUE
  ) |> 
  kableExtra::kable_styling() |> 
  kableExtra::pack_rows(index = table(tb_metrics$model))