We are loading an xgboost (extreme gradient boosting) model - its a different type of tree model. It creates small trees (stumps) that correct for previous trees (compared to random forests, where each gradient-boosted tree is independent)

We will use the full mailing.csv set from your assignment.

load('./mailing_expected_benefit.rda')
mailing_xgb <- xgb.load('./mailing_response_model.xgb')

Expected Benefit

Individual-level profitability based on predicted probabilities.
Helps determine precisely who to mail.

Expected benefit of targeting somebody - we will look now at the probability of responding given all the data (p(R|x)):

Create $P(R|\textbf{x})$

o <- mailing %>% 
    dplyr::select(all_of(colnames(mailing_xs_train))) %>% 
    as.matrix()

mailing$prob_response <- predict(mailing_xgb, newdata = o) 

# look at highest probability of donating
max(mailing$prob_response)

## [1] 0.228673

How much they donate: v(x)

The value of a response, $v_R(\textbf{x})$, is equal to gavr, the average gift size that they do give.

We’ll set the mailing cost to £1

#cost is £1 to post a request (what other costs are involved?)
mailing_cost <- 1

#gavr is average donation
mailing <- mailing %>% 
  mutate(response_value = gavr - mailing_cost) %>% 
  mutate(expected_benefit = prob_response * response_value) %>% 
  arrange(desc(expected_benefit))

#total possible amount of net benefit if everyone is targeted.
# Positive total indicates the campaign as a whole is financially beneficial.
sum(mailing$expected_benefit)

## [1] 105189

#how many below 0?
mailing %>% filter(expected_benefit < 0)

## # A tibble: 0 × 21
## # ℹ 21 variables: Income <dbl>, Firstdate <dbl>, Lastdate <dbl>, Amount <dbl>,
## #   glast <dbl>, gavr <dbl>, class <fct>, rfaf2_1 <int>, rfaf2_4 <int>,
## #   rfaf2_2 <int>, rfaf2_3 <int>, rfaa2_G <int>, rfaa2_E <int>, rfaa2_F <int>,
## #   rfaa2_D <int>, pepstrfl_0 <int>, pepstrfl_X <int>, cv_part <int>,
## #   prob_response <dbl>, response_value <dbl>, expected_benefit <dbl>

#plot histogram of expected benefit
ggplot(mailing, aes(x = expected_benefit)) +
  geom_histogram(bins = 10, fill = "steelblue", color = "white") +
  labs(title = "Histogram of Expected Benefit per Mailing",
       x = "Expected Benefit (£)",
       y = "Number of Individuals") +
  theme_minimal()

There’s a net benefit to reaching to everyone.

But what if costs increase? For some it’s no longer worth targetting them.

mailing_cost <- 2

mailing_cost_change <- mailing %>% 
  mutate(response_value = gavr - mailing_cost) %>% 
  mutate(expected_benefit = prob_response * response_value) #%>% 

# negative benefit count - the number of people it is not profitable to target 
sum(mailing_cost_change$expected_benefit < 0)

## [1] 36

#total possible amount of net benefit if we target everyone
sum(mailing_cost_change$expected_benefit)

## [1] 95445.62

We can put all this inside a function (default mailing cost = 1) The effect of mailing costs on our campaign - after around £2.50 costs,

mailing_benefit <- function(mailing_cost = 1) {
  o <- mailing %>% 
    dplyr::mutate(response_value = gavr - mailing_cost) %>%               #response value
    dplyr::mutate(expected_benefit = prob_response * response_value) %>%  #expected beneift
    dplyr::mutate(ben = ifelse(expected_benefit < 0, 0, 1)) %>%           #binary change point
    dplyr::count(ben) %>%                                                 #no benefit/benefit counts (count 1s and 0s)
    dplyr::mutate(mailing_cost = mailing_cost)                            #mailing_cost may change as argument in function
  return(o)
}

i <- seq(0, 10, length.out = 100)                                         #apply for mailing costs 0-10 (increments up to 100)

d <- lapply(i, mailing_benefit) %>% 
  bind_rows() %>%                                                         #  bind into a single dataset
  mutate(n = ifelse(ben == 0, -n, n))

ggplot(d, aes(x = mailing_cost, y = n, fill = ben)) +
  geom_col()

Profit Curves

Uses actual outcomes (confusion matrices) at different probability thresholds.
Helps determine the optimal overall mailing strategy (at which threshold to mail), balancing false positives (wasted mail costs) and false negatives (missed donations).

Let’s say that our profit margin is small: each offer costs £1 to make and market, and each accepted offer earns £18, for a profit of £17. We can produce a profit matrix where if we send a postcard, and they respond we get £17, and if we send a post-card and they fail to respond we lose the £1 we invested. And if we send nothing, we get nothing and lose nothing.

False positive - we thought they’d donate, but they didn’t.
False negative - we thought they wouldn’t donate, but they would have

# should P-Ignored / Donated be -17? I think it should.

prof_matrix <- matrix(c(0, 0, -1, 17), byrow = T, nrow=2,
                      dimnames = list(c("P-Ignored", "P-Donated"), c("Ignored", "Donated")))
prof_matrix

##           Ignored Donated
## P-Ignored       0       0
## P-Donated      -1      17

We can change the thresholds using our mailing data using the XGBoost model OUr cost matrix assigns values to a FP, FN, TP, TN

p_thresh <- 0.50
the_model_results <- factor(ifelse(mailing$prob_response > p_thresh, 1, 0), levels = c(0, 1))
the_actual_data <- mailing$class
cm_50 <- caret::confusionMatrix(the_model_results, the_actual_data)

p_thresh <- 0.05
the_model_results <- factor(ifelse(mailing$prob_response > p_thresh, 1, 0), levels = c(0, 1))
the_actual_data <- mailing$class
cm_05 <- caret::confusionMatrix(the_model_results, the_actual_data)

cm_50$table

##           Reference
## Prediction      0      1
##          0 182063   9716
##          1      0      0

cm_05$table

##           Reference
## Prediction      0      1
##          0 109162   4010
##          1  72901   5706

Average profit per person at the 5% threshold is $0.13 / person, if we use the values defined

n_cases <- nrow(mailing)
sum((cm_05$table/n_cases) * prof_matrix)

## [1] 0.1256707

At the 50% threshold, we just don’t send anything. Should we have an opportunity cost though, as we lost £17 with our false negatives!?

n_cases <- nrow(mailing)
sum((cm_50$table/n_cases) * prof_matrix)

## [1] 0

Write a function that will compute this for any threshold (total profit):

prof_threshold <- function(p_thresh, prof_matrix) {
  the_model_results <- factor(ifelse(mailing$prob_response > p_thresh, 1, 0), 
                              levels = c(0, 1))
  the_actual_data <- mailing$class
  cm <- caret::confusionMatrix(the_model_results, the_actual_data)
  sum(cm$table * prof_matrix)
}
prof_threshold(0.05, prof_matrix)

## [1] 24101

Plot to visualize and quantify the trade-offs between taking different actions based on our predictive model

i <- seq(0,0.5, length.out = 100)
profits <- sapply(i, prof_threshold, prof_matrix = prof_matrix)
d <- tibble(i, profits)

max_prof <- which.max(d$profits)

ggplot(d, aes(x = i, y = profits)) +
  geom_line(linewidth = 1) +
  geom_hline(yintercept = 0, color = 'grey50') +
  theme_minimal() +
  annotate(geom = "point", color = 'red', 
           x = d$i[max_prof], y = d$profits[max_prof]) +
  annotate(geom = "text", color = 'grey40', 
           x = d$i[max_prof] + 0.01, y = d$profits[max_prof],  label = d$profits[max_prof],
           hjust = "left") +
  annotate(geom = "segment", x = d$i[max_prof], y = d$profits[max_prof],
           xend = d$i[max_prof], yend = 0, linetype = 2) +
  xlab("Model p-threshold") +
  ylab("Predicted profit")

What if we included opportunity costs? If we don’t target someone who would have donated it is a cost to us.

prof_matrix2 <- matrix(c(0, -17, -1, 17), byrow = T, nrow=2,
                      dimnames = list(c("P-Ignored", "P-Donated"), c("Ignored", "Donated")))
prof_matrix2

##           Ignored Donated
## P-Ignored       0     -17
## P-Donated      -1      17

d$profits2 <- sapply(i, prof_threshold, prof_matrix = prof_matrix2)

Opportunity cost maybe isn’t the best way to model this. So we need better data - so we can include opportunity cost. It seems the data isn’t sufficient to target people.

ggplot(d, aes(x = i, y = profits2)) +
  geom_line(linewidth = 1) +
  geom_hline(yintercept = 0, color = 'grey50') +
  theme_minimal() +
  xlab("Model p-threshold") +
  ylab("Predicted profit")

Week 09: Mailer Benefits

Alison

2025-03-13

Expected Benefit

Profit Curves