13  Adult Dataset

Objectives

In this chapter, we extend the analysis from the previous part to the Adult Income dataset from the UCI Machine Learning Repository. 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

The adult dataset contains information that allow to predict whether a person’s income (Y) is over $50,000 a year. We will use gender as the protected binary variable here (S). Other characteristics such as the age, the native country, the marital status and so on will be used. Note that unlike previously, the set of covariates includes both numerical and categorical variables.

vars <- c(
  "sex", "age", "native_country", "marital_status", "education_num",
  "workclass", "hours_per_week", "occupation", "income"
)
s <- "sex"
y <- "income"

The data can be loaded as follows:

library(fairadapt)
# reading in the UCI Adult data
adult <- readRDS(
  system.file("extdata", "uci_adult.rds", package = "fairadapt")
) |>
  as_tibble() |> 
  select(!!vars)

We can have a quick glance at the proportion of women and men among people who earn more, or less, than $50k a year.

adult |> count(income, sex) |> 
  group_by(income) |> 
  mutate(pct_gender = round(100* n / sum(n), 2))
# A tibble: 4 × 4
# Groups:   income [2]
  income sex        n pct_gender
  <fct>  <fct>  <int>      <dbl>
1 <=50K  Female   608       39.3
2 <=50K  Male     938       60.7
3 >50K   Female    54       11.9
4 >50K   Male     400       88.1

We will assume the same causal graph as in Plečko and Meinshausen (2020) (Figure 4, p. 27).

# Adjacency matrix
adj_mat <- c(
  0, 0, 0, 1, 1, 1, 1, 1, 1, # sex
  0, 0, 0, 1, 1, 1, 1, 1, 1, # age
  0, 0, 0, 1, 1, 1, 1, 1, 1, # native_country
  0, 0, 0, 0, 1, 1, 1, 1, 1, # marital_status
  0, 0, 0, 0, 0, 1, 1, 1, 1, # education_num
  0, 0, 0, 0, 0, 0, 0, 0, 1, # workclass
  0, 0, 0, 0, 0, 0, 0, 0, 1, # hours_per_week
  0, 0, 0, 0, 0, 0, 0, 0, 1, # occupation
  0, 0, 0, 0, 0, 0, 0, 0, 0  # income
) |> matrix(
  nrow = length(vars), ncol = length(vars),
  dimnames = list(vars, vars), byrow = TRUE
)
causal_graph <- fairadapt::graphModel(adj_mat)
plot(causal_graph)
Figure 13.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(
  "sex" = "red!30",
  "age" = "yellow!60", 
  "native_country" = "yellow!60", 
  "marital_status" = "yellow!60", 
  "education_num" = "yellow!60", 
  "workclass" = "yellow!60", 
  "hours_per_week" = "yellow!60", 
  "occupation" = "yellow!60", 
  "income" = "blue!30"
)

# Then, in the document:
# `r add_tikz_graph(tikz_code = causal_graph_tikz(adj_mat,colour_nodes), label = "fig-causal-graph-adult-2", caption = "\"Assumed Causal Graph\"", echo = "true")`
Tikz code 
\usetikzlibrary{arrows}
\begin{tikzpicture}
\node[fill=red!30] (n1) at (3.8, 0.0) {sex};
\node[fill=yellow!60] (n2) at (7.5, 0.1) {age};
\node[fill=yellow!60] (n3) at (5.1, 5.0) {native country};
\node[fill=yellow!60] (n4) at (3.3, 3.1) {marital status};
\node[fill=yellow!60] (n5) at (6.4, 2.8) {education num};
\node[fill=yellow!60] (n6) at (9.5, 3.4) {workclass};
\node[fill=yellow!60] (n7) at (10.0, 1.6) {hours per week};
\node[fill=yellow!60] (n8) at (0.0, 1.9) {occupation};
\node[fill=blue!30] (n9) at (4.5, 1.6) {income};
\draw[->, black] (n1) -- (n4);
\draw[->, black] (n1) -- (n5);
\draw[->, black] (n1) -- (n6);
\draw[->, black] (n1) -- (n7);
\draw[->, black] (n1) -- (n8);
\draw[->, black] (n1) -- (n9);
\draw[->, black] (n2) -- (n4);
\draw[->, black] (n2) -- (n5);
\draw[->, black] (n2) -- (n6);
\draw[->, black] (n2) -- (n7);
\draw[->, black] (n2) -- (n8);
\draw[->, black] (n2) -- (n9);
\draw[->, black] (n3) -- (n4);
\draw[->, black] (n3) -- (n5);
\draw[->, black] (n3) -- (n6);
\draw[->, black] (n3) -- (n7);
\draw[->, black] (n3) -- (n8);
\draw[->, black] (n3) -- (n9);
\draw[->, black] (n4) -- (n5);
\draw[->, black] (n4) -- (n6);
\draw[->, black] (n4) -- (n7);
\draw[->, black] (n4) -- (n8);
\draw[->, black] (n4) -- (n9);
\draw[->, black] (n5) -- (n6);
\draw[->, black] (n5) -- (n7);
\draw[->, black] (n5) -- (n8);
\draw[->, black] (n5) -- (n9);
\draw[->, black] (n6) -- (n9);
\draw[->, black] (n7) -- (n9);
\draw[->, black] (n8) -- (n9);
\end{tikzpicture}
Figure 13.2: Assumed Causal Graph

13.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(adult, 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 define the training function, log_reg_train().

The log_reg_train() function. 
#' @param train_data Train set.
#' @param test_data Test set.
#' @param s Name of the sensitive attribute.
#' @param y Name of the target variable.
#' @param type If `"type=aware"`, the model includes the sensitive attributes,
#'        otherwise, if `type=unaware`, it does not.
#' 
#' @returns A list with three elements:
#' * `model`: The estimated logistic regression model.
#' * `pred_train`: Estimated scores on the train set.
#' * `pred_test`: Estimated scores on the test set.
#' 
#' @importFrom dplyr select
#' @importFrom rlang !!
#' @importFrom stats glm predict as.formula
log_reg_train <- function(train_data,
                          test_data,
                          s,
                          y,
                          type = c("aware", "unaware")) {
  if (type == "unaware") {
    train_data_ <- train_data %>% select(-!!s)
    test_data_ <- test_data %>% select(-!!s)
  } else {
    train_data_ <- train_data
    test_data_ <- test_data
  }
  # Train the logistic regression model
  form <- paste0(y, "~.")
  model <- glm(as.formula(form), data = train_data_, family = binomial)
  # Predictions on train and test sets
  pred_train <- predict(model, newdata = train_data_, type = "response")
  pred_test <- predict(model, newdata = test_data_, type = "response")
  list(
    model = model,
    pred_train = pred_train,
    pred_test = pred_test
  )
}

Let us train the two models. Then, 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")
Warning in predict.lm(object, newdata, se.fit, scale = 1, type = if (type == :
prediction from rank-deficient fit; attr(*, "non-estim") has doubtful cases
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")
Warning in predict.lm(object, newdata, se.fit, scale = 1, type = if (type == :
prediction from rank-deficient fit; attr(*, "non-estim") has doubtful cases
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
)

13.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 = adult,
  type = "response"
)
Warning in predict.lm(object, newdata, se.fit, scale = 1, type = if (type == :
prediction from rank-deficient fit; attr(*, "non-estim") has doubtful cases

And with the aware model:

model_aware <- pred_aware$model
pred_aware_all <- predict(
  model_aware,
  newdata = adult,
  type = "response"
)
Warning in predict.lm(object, newdata, se.fit, scale = 1, type = if (type == :
prediction from rank-deficient fit; attr(*, "non-estim") has doubtful cases

13.1.2 Saving Objects

save(pred_aware, file = "../data/pred_aware_adult.rda")
save(pred_unaware, file = "../data/pred_unaware_adult.rda")
save(pred_unaware_all, file = "../data/pred_unaware_all_adult.rda")
save(pred_aware_all, file = "../data/pred_aware_all_adult.rda")

13.2 Naive approach: ceteris paribus

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

pred_unaware_naive_women <- predict(
  model_unaware,
  newdata = adult |> filter(sex == "Female") |> mutate(sex = "Male"),
  type = "response"
)
pred_aware_naive_women <- predict(
  model_aware,
  newdata = adult |> filter(sex == "Female") |>  mutate(sex = "Male"),
  type = "response"
)

ind_women <- which(adult$sex == "Female")
ind_men <- which(adult$sex == "Male")

counterfactuals_unaware_naive_women <- 
  adult |> filter(sex == "Female") |> 
  mutate(
    sex_origin = sex,
    sex = "Male",
    pred = pred_unaware_naive_women,
    type = "counterfactual",
    id_indiv = ind_women
  )
counterfactuals_aware_naive_women <- 
  adult |> filter(sex == "Female") |> 
  mutate(
    sex_origin = sex,
    sex = "Male",
    pred = pred_aware_naive_women,
    type = "counterfactual",
    id_indiv = ind_women
  )

13.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 sex attribute of all women to “Male”. 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 <-
  adult |> 
  as_tibble() |>
  mutate(
    sex_origin = sex,
    pred = pred_unaware_all,
    type = "factual"
  ) |> 
    mutate(id_indiv = row_number())
unaware_naive_women <- 
  factuals_unaware |> mutate(sex_origin = sex) |> 
  bind_rows(counterfactuals_unaware_naive_women)

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

ggplot(
  unaware_naive_women |> mutate(
    group = case_when(
      sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
      sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
      sex_origin == "Male" & sex == "Male" ~ "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(~sex) +
  scale_fill_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["naive"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["naive"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.3: Unaware model, Sensitive: Sex, Woman -> Man

Then, we focus on the distribution of predicted scores for ccounterfactual of Women and factuals of men. 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_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ) |> 
    filter(sex_origin == "Female"),
  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[["naive"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["naive"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.4: Distribution of Predicted Scores for Minority Class (Women), Unaware model, Sensitive: Race, Woman -> Man

13.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 <-
  adult |> 
  as_tibble() |>
  mutate(
    sex_origin = sex,
    pred = pred_aware_all,
    type = "factual"
  ) |> 
    mutate(id_indiv = row_number())
aware_naive_women <- 
  factuals_aware |> mutate(sex_origin = sex) |> 
  bind_rows(counterfactuals_aware_naive_women)
ggplot(
  aware_naive_women |> mutate(
    group = case_when(
      sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
      sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
      sex_origin == "Male" & sex == "Male" ~ "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(~sex) +
  scale_fill_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["naive"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["naive"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.5: Aware model, Sensitive: Sex, Woman -> Man

Then, we focus on the distribution of predicted scores for ccounterfactual of Women and factuals of men.

Codes used to create the Figure. 
ggplot(
  data = aware_naive_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ) |> 
    filter(sex_origin == "Female"),
  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[["naive"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["naive"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.6: Distribution of Predicted Scores for Minority Class (Women), Aware model, Sensitive: Race, Woman -> Man

13.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-adult.csv", 
  row.names = FALSE
)

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

library(reticulate)
use_virtualenv("~/quarto-python-env", required = TRUE)
# reticulate::install_miniconda(force = TRUE)
# py_install("POT")
# py_install("scikit-learn")
# py_install("pandas")
# py_install("numpy")
# py_install("matplotlib")
# py_install("scipy")

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-adult.csv')
x_S = df_aware.drop(columns=['sex_origin', 'pred', 'type', 'id_indiv', 'income'])

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

x_S_0 = x_S[x_S['sex'] == 'Female']
x_S_1 = x_S[x_S['sex'] == 'Male']

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

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)

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-women-adult.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_women <- read_csv('../data/counterfactuals-ot-women-adult.csv') |> 
  mutate(
    id_indiv = ind_women,
    sex_origin = "Female",
    sex = "Male"
  ) |> 
  mutate(
    native_country = str_remove(native_country, "^country_"),
    marital_status = str_remove(marital_status, "^status_"),
  )
Rows: 662 Columns: 7
── Column specification ────────────────────────────────────────────────────────
Delimiter: ","
chr (4): native_country, marital_status, workclass, occupation
dbl (3): age, education_num, hours_per_week

ℹ 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_women, type = "response"
)

pred_ot_aware <- predict(
  model_aware, newdata = df_counterfactuals_ot_women, type = "response"
)
counterfactuals_unaware_ot_women <- 
  df_counterfactuals_ot_women |> 
  mutate(pred = pred_ot_unaware, type = "counterfactual")
counterfactuals_aware_ot_women <- 
  df_counterfactuals_ot_women |> 
  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_women <- bind_rows(
  factuals_aware |> mutate(id_indiv = row_number(), sex_origin = sex), 
  counterfactuals_aware_ot_women |> mutate(S_origin = "Female")
)
unaware_ot_women <- bind_rows(
  factuals_unaware |> mutate(id_indiv = row_number(), sex_origin = sex), 
  counterfactuals_unaware_ot_women |> mutate(S_origin = "Female")
)
Codes used to create the Figure. 
ggplot(
  data = unaware_ot_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "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(~sex) +
  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 13.7: Unaware model, Sensitive: Race, Woman -> Man
Codes used to create the Figure. 
ggplot(
  data = aware_ot_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "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(~sex) +
  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 13.8: Aware model, Sensitive: Race, Woman -> Man

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

Codes used to create the Figure. 
ggplot(
  data = unaware_ot_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ) |> 
    filter(sex_origin == "Female"),
  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 13.9: Distribution of Predicted Scores for Minority Class (Women), Unaware model, Sensitive: Race, Woman -> Man
Codes used to create the Figure. 
ggplot(
  data = aware_ot_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ) |> 
    filter(sex_origin == "Female"),
  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 13.10: Distribution of Predicted Scores for Minority Class (Women), Aware model, Sensitive: Race, Woman -> Man

13.4 Fairadapt

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

Let us consider that we want to build counterfactuals for women: what if the individual had been a man and not a woman?

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

levels(adult |> pull(!!s))
[1] "Female" "Male"

Two configurations will be considered in turn:

  1. The reference class consists of men, and fairadapt will be used to obtain the counterfactual values for women as if they had been men.
  2. The reference class consists of women, and fairadapt will be used to obtain the counterfactual values for men as if they had been women.
# Women (factuals) --> Men (counterfactuals)
df_fpt <- adult |> mutate(sex = fct_relevel(sex, "Female", after = Inf))
fpt_model_women <- fairadapt(
  income ~ .,
  train.data = df_fpt,
  prot.attr = "sex", adj.mat = adj_mat,
  quant.method = rangerQuants
)
adapt_df_women <- adaptedData(fpt_model_women)

# Men (factuals) --> Women (counterfactuals)
df_fpt <- df_fpt |> mutate(sex = fct_relevel(sex, "Male", after = Inf))
fpt_model_men <- fairadapt(
  income ~ .,
  train.data = df_fpt,
  prot.attr = "sex", adj.mat = adj_mat,
  quant.method = rangerQuants
)
adapt_df_men <- adaptedData(fpt_model_men)

Let us wrap up:

  • we have two predictive models for the income variable (greater than 50k per year, or lower than or equal to 50k per year):

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

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

    • women individuals as reference
    • men 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).

13.4.1 Unaware Model

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

pred_unaware_fpt_women <- predict(
  model_unaware, 
  newdata = adapt_df_women[ind_women, ], 
  type = "response"
)
pred_unaware_fpt_men <- predict(
  model_unaware, 
  newdata = adapt_df_men[ind_men, ],
  type = "response"
)

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

counterfactuals_unaware_fpt_women <- 
  as_tibble(adapt_df_women[ind_women, ]) |> 
  mutate(
    sex_origin = adult$sex[ind_women],
    pred = pred_unaware_fpt_women,
    type = "counterfactual",
    id_indiv = ind_women
  )

counterfactuals_unaware_fpt_men <- 
  as_tibble(adapt_df_men[ind_men, ]) |> 
  mutate(
    sex_origin = adult$sex[ind_men],
    pred = pred_unaware_fpt_men,
    type = "counterfactual",
    id_indiv = ind_men
  )

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

unaware_fpt_women <- 
  factuals_unaware |> mutate(sex_origin = sex) |> 
  bind_rows(counterfactuals_unaware_fpt_women)
  
unaware_fpt_men <- 
  factuals_unaware |> mutate(sex_origin = sex) |> 
  bind_rows(counterfactuals_unaware_fpt_men)
Codes used to create the Figure. 
ggplot(
  data = unaware_fpt_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "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(~sex) +
  scale_fill_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["fairadapt"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["fairadapt"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.11: Unaware model, Sensitive: Sex, Woman -> Man
Codes used to create the Figure. 
ggplot(
  data = unaware_fpt_men |> 
    mutate(
      group = case_when(
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)",
        sex_origin == "Male" & sex == "Female" ~ "Men -> Women (Counterfactual)",
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Men (Original)", "Men -> Women (Counterfactual)", "Women (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(~sex) +
  scale_fill_manual(
    NULL, values = c(
      "Men (Original)" = colours_all[["source"]],
      "Men -> Women (Counterfactual)" = colours_all[["fairadapt"]],
      "Women (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Men (Original)" = colours_all[["source"]],
      "Men -> Women (Counterfactual)" = colours_all[["fairadapt"]],
      "Women (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.12: Unaware model, Sensitive: Sex, Man -> Woman

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

Codes used to create the Figure. 
ggplot(
  data = unaware_fpt_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ) |> 
    filter(sex_origin == "Female"),
  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[["fairadapt"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["fairadapt"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.13: Distribution of Predicted Scores for Minority Class (Women), Unaware model, Sensitive: Sex, Woman -> Man
Codes used to create the Figure. 
ggplot(
  data = unaware_fpt_men |> 
    mutate(
      group = case_when(
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)",
        sex_origin == "Male" & sex == "Female" ~ "Men -> Women (Counterfactual)",
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Men (Original)", "Men -> Women (Counterfactual)", "Women (Original)"
        )
      )
    ) |> 
    filter(sex_origin == "Male"),
  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(
      "Men (Original)" = colours_all[["source"]],
      "Men -> Women (Counterfactual)" = colours_all[["fairadapt"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Men (Original)" = colours_all[["source"]],
      "Men -> Women (Counterfactual)" = colours_all[["fairadapt"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.14: Distribution of Predicted Scores for Minority Class (White), Unaware model, Sensitive: Race, Man -> Woman

13.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_women <- predict(
  model_aware, 
  newdata = adapt_df_women[ind_women, ], 
  type = "response"
)
pred_aware_fpt_men <- predict(
  model_aware, 
  newdata = adapt_df_men[ind_men, ],
  type = "response"
)

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

counterfactuals_aware_fpt_women <- 
  as_tibble(adapt_df_women[ind_women, ]) |> 
  mutate(
    sex_origin = adult$sex[ind_women],
    pred = pred_aware_fpt_women,
    type = "counterfactual",
    id_indiv = ind_women
  )

counterfactuals_aware_fpt_men <- 
  as_tibble(adapt_df_men[ind_men, ]) |> 
  mutate(
    sex_origin = adult$sex[ind_men],
    pred = pred_aware_fpt_men,
    type = "counterfactual",
    id_indiv = ind_men
  )

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

# dataset with counterfactuals, for aware model
aware_fpt_women <- 
  factuals_aware |> mutate(sex_origin = sex) |> 
  bind_rows(counterfactuals_aware_fpt_women)
  
aware_fpt_men <- 
  factuals_aware |> mutate(sex_origin = sex) |> 
  bind_rows(counterfactuals_aware_fpt_men)
Codes used to create the Figure. 
ggplot(
  data = aware_fpt_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "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(~sex) +
  scale_fill_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["fairadapt"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["fairadapt"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.15: Aware model, Sensitive: Race, Reference: Men individuals
Codes used to create the Figure. 
ggplot(
  data = aware_fpt_men |> 
    mutate(
      group = case_when(
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)",
        sex_origin == "Male" & sex == "Female" ~ "Men -> Women (Counterfactual)",
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Men (Original)", "Men -> Women (Counterfactual)", "Women (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(~sex) +
  scale_fill_manual(
    NULL, values = c(
      "Men (Original)" = colours_all[["source"]],
      "Men -> Women (Counterfactual)" = colours_all[["fairadapt"]],
      "Women (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Men (Original)" = colours_all[["source"]],
      "Men -> Women (Counterfactual)" = colours_all[["fairadapt"]],
      "Women (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.16: Aware model, Sensitive: Race, Reference: Women individuals

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

Codes used to create the Figure. 
ggplot(
  data = aware_fpt_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ) |> 
    filter(sex_origin == "Female"),
  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[["fairadapt"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["fairadapt"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.17: Distribution of Predicted Scores for Minority Class (Women), Aware model, Sensitive: Race, Reference: Men individuals
Codes used to create the Figure. 
ggplot(
  data = aware_fpt_men |> 
    mutate(
      group = case_when(
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)",
        sex_origin == "Male" & sex == "Female" ~ "Men -> Women (Counterfactual)",
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Men (Original)", "Men -> Women (Counterfactual)", "Women (Original)"
        )
      )
    ) |> 
    filter(sex_origin == "Male"),
  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(
      "Men (Original)" = colours_all[["source"]],
      "Men -> Women (Counterfactual)" = colours_all[["fairadapt"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Men (Original)" = colours_all[["source"]],
      "Men -> Women (Counterfactual)" = colours_all[["fairadapt"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.18: Distribution of Predicted Scores for Minority Class (Men), Aware model, Sensitive: Race, Reference: Women individuals

13.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 13.4.

sequential_transport <- seq_trans(
  data = adult, adj = adj_mat, s = "sex", S_0 = "Female", y = "income"
)
Transporting  age 
Transporting  native_country 
Transporting  marital_status 
# weights:  4 (3 variable)
initial  value 927.430928 
final  value 779.199404 
converged
Transporting  education_num 
Transporting  workclass 
# weights:  24 (15 variable)
initial  value 1854.861855 
iter  10 value 1418.843645
iter  20 value 1226.860388
final  value 1224.646984 
converged
Transporting  hours_per_week 
Transporting  occupation 
Warning in nnet::multinom(x_S0 ~ ., data = mutate(data_1_parents, x_S0 =
x_S1)): group 'Armed-Forces' is empty
# weights:  84 (65 variable)
initial  value 3531.058707 
iter  10 value 3268.247749
iter  20 value 3150.146313
iter  30 value 3013.347818
iter  40 value 2880.348969
iter  50 value 2868.888514
iter  60 value 2865.551923
iter  70 value 2864.693363
iter  80 value 2864.661456
iter  90 value 2864.641525
final  value 2864.640591 
converged

We build a dataset with the sensitive attribute of Women changed to Male, and their characteristics changed to their transported characteristics:

df_counterfactuals_seq_women <- 
  as_tibble(sequential_transport$transported) |> 
  mutate(
    id_indiv = ind_women,
    sex_origin = "Female",
    sex = "Male"
  )

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_women, type = "response"
)

pred_seq_aware <- predict(
  model_aware, newdata = df_counterfactuals_seq_women, type = "response"
)
counterfactuals_unaware_seq_women <- 
  df_counterfactuals_seq_women |> 
  mutate(pred = pred_seq_unaware, type = "counterfactual")
counterfactuals_aware_seq_women <- 
  df_counterfactuals_seq_women |> 
  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 Women based on their factual characteristics, and those made based on the counterfactuals:

aware_seq_women <- bind_rows(
  factuals_aware |> mutate(id_indiv = row_number(), sex_origin = sex), 
  counterfactuals_aware_seq_women |> mutate(S_origin = "Female")
)
unaware_seq_women <- bind_rows(
  factuals_unaware |> mutate(id_indiv = row_number(), sex_origin = sex), 
  counterfactuals_unaware_seq_women |> mutate(S_origin = "Female")
)
Codes used to create the Figure. 
ggplot(
  data = unaware_seq_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "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(~sex) +
  scale_fill_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["seq"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["seq"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.19: Unaware model, Sensitive: Race, Woman -> Man
Codes used to create the Figure. 
ggplot(
  data = aware_seq_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "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(~sex) +
  scale_fill_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["seq"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["seq"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.20: Aware model, Sensitive: Race, Woman -> Man

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

Codes used to create the Figure. 
ggplot(
  data = unaware_seq_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ) |> 
    filter(sex_origin == "Female"),
  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[["seq"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["seq"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.21: Distribution of Predicted Scores for Minority Class (Women), Unaware model, Sensitive: Race, Woman -> Man
Codes used to create the Figure. 
ggplot(
  data = aware_seq_women |> 
    mutate(
      group = case_when(
        sex_origin == "Female" & sex == "Female" ~ "Women (Original)",
        sex_origin == "Female" & sex == "Male" ~ "Women -> Men (Counterfactual)",
        sex_origin == "Male" & sex == "Male" ~ "Men (Original)"
      ),
      group = factor(
        group, 
        levels = c(
          "Women (Original)", "Women -> Men (Counterfactual)", "Men (Original)"
        )
      )
    ) |> 
    filter(sex_origin == "Female"),
  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[["seq"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  scale_colour_manual(
    NULL, values = c(
      "Women (Original)" = colours_all[["source"]],
      "Women -> Men (Counterfactual)" = colours_all[["seq"]],
      "Men (Original)" = colours_all[["reference"]]
    )
  ) +
  labs(
    x = "Predictions for Y",
    y = "Density"
  ) +
  global_theme() +
  theme(legend.position = "bottom")
Figure 13.22: Distribution of Predicted Scores for Minority Class (Women), Aware model, Sensitive: Race, Woman -> Man

13.6 Comparison

Let us now compare the results.

tb_unaware <- 
  factuals_unaware |> mutate(counterfactual = "none") |>
  # Naive
  bind_rows(
    counterfactuals_unaware_naive_women |> mutate(counterfactual = "naive")
  ) |> 
  # OT
  bind_rows(
    counterfactuals_unaware_ot_women |> mutate(counterfactual = "ot")
  ) |> 
  # Fairadapt
  bind_rows(
    counterfactuals_unaware_fpt_women |> mutate(counterfactual = "fpt")
  ) |> 
  # Sequential transport
  bind_rows(
    counterfactuals_unaware_seq_women |> mutate(counterfactual = "seq")
  )
tb_aware <- 
  factuals_aware |> mutate(counterfactual = "none") |> 
  # Naive
  bind_rows(
    counterfactuals_aware_naive_women |> mutate(counterfactual = "naive")
  ) |> 
  # OT
  bind_rows(
    counterfactuals_aware_ot_women |> mutate(counterfactual = "ot")
  ) |> 
  # Fairadapt
  bind_rows(
    counterfactuals_aware_fpt_women |> mutate(counterfactual = "fpt")
  ) |> 
  # Sequential transport
  bind_rows(
    counterfactuals_aware_seq_women |> 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_women <- tb_unaware_factuals |> filter(sex == "Female") |> pull("pred")
pred_unaware_factuals_men <- tb_unaware_factuals |> filter(sex == "Male") |> pull("pred")
# Estimated densities
d_unaware_factuals_women <- density(pred_unaware_factuals_women)
d_unaware_factuals_men <- density(pred_unaware_factuals_men)

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

# OT
tb_unaware_ot <- tb_unaware |> filter(counterfactual == "ot")
# Predicted values, focusing on Black --> White
pred_unaware_ot_women_star <- tb_unaware_ot |> filter(sex_origin == "Female") |> pull("pred")
# Estimated densities
d_unaware_ot_women_star <- density(pred_unaware_ot_women_star)

plot(
  d_unaware_factuals_women,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_unaware_factuals_women, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_unaware_factuals_men, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_unaware_ot_women_star, col = alpha(colours_all[["ot"]], .5), border = NA)
text(x = .2, y = 6.5, "Factuals - Women", col = colours_all[["source"]])
pos_arrow <- .07
ind_min <- which.min(abs(d_unaware_factuals_women$x - pos_arrow))
arrows(
  x1 = d_unaware_factuals_women$x[ind_min],
  y1 = d_unaware_factuals_women$y[ind_min],
  x0 = .2, 
  y0 = 5,
  length = 0.05, col = colours_all[["source"]]
)

pos_arrow_ref <- .5
text(x = pos_arrow_ref, y = 6.5, "Factuals - Men", col = colours_all[["reference"]])
ind_min_ref <- which.min(abs(d_unaware_factuals_men$x - pos_arrow_ref))
arrows(
  x1 = d_unaware_factuals_men$x[ind_min_ref],
  y1 = d_unaware_factuals_men$y[ind_min_ref],
  x0 = pos_arrow_ref, 
  y0 = 5,
  length = 0.05, col = colours_all[["reference"]]
)
text(x = .7, y = 6.5, "Multi. OT", col = colours_all[["ot"]])


# Naive
tb_unaware_naive <- tb_unaware |> filter(counterfactual == "naive")
# Predicted values, focusing on Black --> White
pred_unaware_naive_women_star <- tb_unaware_naive |> filter(sex == "Male") |> pull("pred")
# Estimated densities
d_unaware_naive_women_star <- density(pred_unaware_naive_women_star)
plot(
  d_unaware_factuals_women,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_unaware_factuals_women, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_unaware_factuals_men, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_unaware_naive_women_star, col = alpha(colours_all[["naive"]], .5), border = NA)
text(x = .7, y = 6.5, "Naive", col = colours_all[["naive"]])


# Fairadapt
tb_unaware_fpt <- tb_unaware |> filter(counterfactual == "fpt")
# Predicted values, focusing on Black --> White
pred_unaware_fpt_women_star <- 
  tb_unaware_fpt |> filter(sex == "Male") |> pull("pred")
# Estimated densities
d_unaware_fpt_women_star <- density(pred_unaware_fpt_women_star)

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


# Sequential transport
tb_unaware_seq <- tb_unaware |> filter(counterfactual == "seq")
# Predicted values, focusing on Black --> White
pred_unaware_seq_women_star <- tb_unaware_seq |> filter(sex == "Male") |> pull("pred")
# Estimated densities
d_unaware_seq_women_star <- density(pred_unaware_seq_women_star)

plot(
  d_unaware_factuals_women,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_unaware_factuals_women, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_unaware_factuals_men, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_unaware_seq_women_star, col = alpha(colours_all[["seq"]], .5), border = NA)
text(x = .7, y = 6.5, "Seq. T.", col = colours_all[["seq"]])
Figure 13.23: Densities of predicted scores for Women with factuals and with counterfactuals. The yellow dashed line corresponds to the density of predicted scores for Women, using factuals.
Codes used to create the Figure. 
tb_aware_factuals <- tb_aware |> filter(counterfactual == "none")
# Predicted values
pred_aware_factuals_women <- tb_aware_factuals |> filter(sex == "Female") |> pull("pred")
pred_aware_factuals_men <- tb_aware_factuals |> filter(sex == "Male") |> pull("pred")
# Estimated densities
d_aware_factuals_women <- density(pred_aware_factuals_women)
d_aware_factuals_men <- density(pred_aware_factuals_men)

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


# OT
tb_aware_ot <- tb_aware |> filter(counterfactual == "ot")
# Predicted values, focusing on Black --> White
pred_aware_ot_women_star <- tb_aware_ot |> filter(sex_origin == "Female") |> pull("pred")
# Estimated densities
d_aware_ot_women_star <- density(pred_aware_ot_women_star)

plot(
  d_aware_factuals_women,
  main = "", xlab = "", ylab = "",
  axes = FALSE, col = NA,
  xlim = x_lim, ylim = y_lim
)
axis(1)
axis(2)
polygon(d_aware_factuals_women, col = alpha(colours_all[["source"]], .5), border = NA)
lines(d_aware_factuals_men, col = colours_all[["reference"]], lty = 2, lwd = 2)
polygon(d_aware_ot_women_star, col = alpha(colours_all[["ot"]], .5), border = NA)
text(x = .2, y = 12, "Factuals - Women", col = colours_all[["source"]])
pos_arrow <- .07
ind_min <- which.min(abs(d_aware_factuals_women$x - pos_arrow))
arrows(
  x1 = d_aware_factuals_women$x[ind_min],
  y1 = d_aware_factuals_women$y[ind_min],
  x0 = .2, 
  y0 = 10,
  length = 0.05, col = colours_all[["source"]]
)

pos_arrow_ref <- .5
text(x = pos_arrow_ref, y = 12, "Factuals - Men", col = colours_all[["reference"]])
ind_min_ref <- which.min(abs(d_aware_factuals_men$x - pos_arrow_ref))
arrows(
  x1 = d_aware_factuals_men$x[ind_min_ref],
  y1 = d_aware_factuals_men$y[ind_min_ref],
  x0 = pos_arrow_ref, 
  y0 = 10,
  length = 0.05, col = colours_all[["reference"]]
)
text(x = .7, y = 12, "Multi. OT", col = colours_all[["ot"]])

# Naive
tb_aware_naive <- tb_aware |> filter(counterfactual == "naive")
# Predicted values, focusing on Black --> White
pred_aware_naive_women_star <- tb_aware_naive |> filter(sex == "Male") |> pull("pred")
# Estimated densities
d_aware_naive_women_star <- density(pred_aware_naive_women_star)

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


# Fairadapt
tb_aware_fpt <- tb_aware |> filter(counterfactual == "fpt")
# Predicted values, focusing on Black --> White
pred_aware_fpt_women_star <- 
  tb_aware_fpt |> filter(sex == "Male") |> pull("pred")
# Estimated densities
d_aware_fpt_women_star <- density(pred_aware_fpt_women_star)

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


# Sequential transport
tb_aware_seq <- tb_aware |> filter(counterfactual == "seq")
# Predicted values, focusing on Black --> White
pred_aware_seq_women_star <- tb_aware_seq |> filter(sex == "Male") |> pull("pred")
# Estimated densities
d_aware_seq_women_star <- density(pred_aware_seq_women_star)

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

13.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 Women \(\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(sex_origin == "Female") |> pull("income")
obs_1 <- factuals_aware |> filter(sex_origin == "Male") |> pull("income")
# Scores using factuals
pred_0_aware <- factuals_aware |> filter(sex_origin == "Female") |> pull("pred")
pred_1_aware <- factuals_aware |> filter(sex_origin == "Male") |> pull("pred")
pred_0_unaware <- factuals_unaware |> filter(sex_origin == "Female") |> pull("pred")
pred_1_unaware <- factuals_unaware |> filter(sex_origin == "Male") |> pull("pred")
# Scores in groups S="Female" using naive counterfactuals
pred_0_naive_aware <- pred_aware_naive_women
pred_0_naive_unaware <- pred_unaware_naive_women
# Scores in groups S="Female" using multivariate optimal transport counterfactuals
pred_0_ot_aware <- pred_ot_aware
pred_0_ot_unaware <- pred_ot_unaware
# Scores in groups S="Female" using fairadapt counterfactuals
pred_0_fpt_aware <- pred_aware_fpt_women
pred_0_fpt_unaware <- pred_unaware_fpt_women
# Scores in groups S="Female" 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 13.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 13.1: Metrics to Assess Fairness of the Model (adult dataset).
S=0 Naive OT Fairadapt Seq S=1
Aware
TPR 0.26 0.44 0.67 0.74 0.61 0.54
FPR 0.01 0.02 0.15 0.23 0.32 0.10
n_obs 662.00 662.00 662.00 662.00 662.00 1338.00
c_demog_parity 0.05 0.17 0.24 0.29
c_eq_op 0.19 0.41 0.48 0.35
class_bal_fnr 0.75 0.45 0.35 0.52
c_eq_treatment 0.04 0.44 0.86 0.81
Unaware
TPR 0.41 0.41 0.63 0.74 0.56 0.54
FPR 0.02 0.02 0.14 0.21 0.31 0.10
n_obs 662.00 662.00 662.00 662.00 662.00 1338.00
c_demog_parity 0.00 0.12 0.20 0.25
c_eq_op 0.00 0.22 0.33 0.15
class_bal_fnr 1.00 0.62 0.44 0.75
c_eq_treatment 0.00 0.35 0.80 0.67
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))