The Red Car

Generate data from red car graph:

n <- 1e5
aX <- 1/3
uX <- 1/3
uY <- 1/3
sY <- 1/10

A <- c(rep(T, n), rep(F, n))  # 1000 black, 1000 non-black drivers
U <- rbinom(2*n, 1, 0.5)
X <- rbinom(2*n, 1, aX * A + uX * U)
Y <- rnorm(2*n, 0.2 + uY * U, sY)

Models:

ftu <- lm(Y ~ X)
race <- lm(Y ~ A)
fta <- lm(Y ~ A + X)

Note that the set of variables \(U\) from Kusner et al. (2017) is empty here. We seek a counterfactually fair algorithm through simple regression.

Check model predictions:

testData <- data.frame(A = A, X = X)

testCombos <- rbind(expand.grid(A = c(F,T), X = c(0,1)),
                    data.frame(A = T, X = aX))
testCombos
##       A         X
## 1 FALSE 0.0000000
## 2  TRUE 0.0000000
## 3 FALSE 1.0000000
## 4  TRUE 1.0000000
## 5  TRUE 0.3333333

First 4 rows are the race/red car combos. Last row represents the expected value of X if we consider a person with \((A,X) = (0, 0)\) and intervene to set \(A = 1\).

Fairness through Unawareness:

cbind(testCombos, Yhat = predict(ftu, testCombos))
##       A         X      Yhat
## 1 FALSE 0.0000000 0.3250383
## 2  TRUE 0.0000000 0.3250383
## 3 FALSE 1.0000000 0.4503317
## 4  TRUE 1.0000000 0.4503317
## 5  TRUE 0.3333333 0.3668028

Not counterfactually fair, because first and last row have different predictions.

ftu_costs <- predict(ftu, testData)
cat('average insurance cost for black people:', mean(ftu_costs[A]), '\n')
## average insurance cost for black people: 0.3876161
cat('average insurance cost for white people:', mean(ftu_costs[!A]), '\n')
## average insurance cost for white people: 0.3460914

Charges black people more despite no causal effect of race on accident rate.

Race-only model (super illegal):

cbind(testCombos, Yhat = predict(race, testCombos))
##       A         X      Yhat
## 1 FALSE 0.0000000 0.3665724
## 2  TRUE 0.0000000 0.3671351
## 3 FALSE 1.0000000 0.3665724
## 4  TRUE 1.0000000 0.3671351
## 5  TRUE 0.3333333 0.3671351

Counterfactually fair, but only because no causal effect of race on accident rate. But no price discrimination of any kind ruins your insurance business.

Fairness through Awareness (illegal):

cbind(testCombos, Yhat = predict(fta, testCombos))
##       A         X      Yhat
## 1 FALSE 0.0000000 0.3425933
## 2  TRUE 0.0000000 0.2958600
## 3 FALSE 1.0000000 0.4853004
## 4  TRUE 1.0000000 0.4385672
## 5  TRUE 0.3333333 0.3434291

Counterfactually fair, because the first and last rows are (in expectation) the same(!). Black people get both a discount (through the race coefficient) and a penalty (by being more likely to have a red car—remember, car color has no causal effect on accident rate). The discount and the penalty cancel out on average.

fta_costs <- predict(fta, testData)
cat('average insurance cost for black people:', mean(fta_costs[A]), '\n')
## average insurance cost for black people: 0.3671351
cat('average insurance cost for white people:', mean(fta_costs[!A]), '\n')
## average insurance cost for white people: 0.3665724

Despite highly descriminative (and therefore profitable) insurance pricing, black and white people pay the same amount on average.