Exercise: who will leave — and what a mistake costs

Session 11 — Applied Data Science 2026

Author
Affiliation

Claudius Gräbner-Radkowitsch

EUF and JKU

Published

07 12 2026

NoteThe setting

The telecom company from session 10 is back. Its segments described who leaves; now it wants to know, a month ahead, which customers will leave (churn), so that it can offer them a discount to stay. A colleague reports that her churn model is “pretty accurate”. The marketing director is suspicious. Your job: build the models of the live coding on these data, show what they can and cannot do — and which decision rule the company should use.

ImportantStart here

Three new packages — install them once:

install.packages(c("rpart.plot", "ranger", "pROC"))

Download telco-customers.csv from the session page into data/ — the same file as in session 10 — create session11.qmd, and start with this setup chunk.

```{r}
#| label: setup
#| include: false
library(tidyverse)
library(rpart)
library(rpart.plot)
library(ranger)
library(pROC)
library(here)

i_am("session11.qmd")

# Customers without total charges have not been billed yet (session 10);
# churn becomes 0/1, the text columns become factors
customers <- read_csv(here("data", "telco-customers.csv")) |>
  filter(!is.na(total_charges)) |>
  mutate(churn = as.integer(churn == "Yes"),
         across(where(is.character), factor))

# The holdout: set aside now, used once; five folds for the rest
set.seed(2026)
holdout_rows <- sample(nrow(customers), round(0.2 * nrow(customers)))
holdout <- customers |> slice(holdout_rows)
train   <- customers |> slice(-holdout_rows)

set.seed(1)
train <- train |>
  mutate(fold = sample(rep(1:5, length.out = n())))

# All predictors except total charges (≈ tenure × monthly bill, session 10)
model <- churn ~ tenure + monthly_charges + contract + internet_service +
  payment_method + paperless_billing + senior_citizen + partner +
  dependents + female + phone_service + multiple_lines + online_security +
  online_backup + device_protection + tech_support + streaming_tv +
  streaming_movies
```

Part A — Three models

A1 · The base rate

What share of the training customers churned? What accuracy does the rule “nobody churns” reach on the training customers? Compare with the firms of the live coding: are churners as rare as exits?

A2 · Logistic regression

Fit glm(model, data = train, family = binomial) and predict the probability of churn for the holdout customers (type = "response"). What is the highest predicted probability? Then fit the straight line lm(model, data = train): how many of its holdout predictions are below 0?

A3 · A tree

  1. Grow a large tree with cross-validation on our folds, and plot the cross-validated error (xerror) against the number of leaves (nsplit + 1):

    tree_full <- rpart(model, data = train, method = "anova",
                   cp = 0.0005, xval = train$fold)
cp_table <- as_tibble(tree_full$cptable)

  2. Prune the tree at the CP with the lowest xerror and draw it with rpart.plot(). How many leaves does it have?

  3. Which leaf has the highest share of churners? Describe these customers in one sentence for the marketing director.

  4. Which variables does the tree use? Session 10 clustered the customers on tenure and monthly bill only — does the tree agree that these two matter?

  5. Now grow a tree to the end: rpart(model, data = train, method = "anova", cp = 0, minsplit = 2, minbucket = 1). Compute its AUC on the training customers and on the holdout customers with auc(actual, predicted) from pROC. What has happened?

prune(tree_full, cp = ...) cuts the tree back. The CP with the lowest error: cp_table$CP[which.min(cp_table$xerror)]. predict(tree, newdata) returns the churn share of each customer’s leaf.

A4 · A forest

Grow a random forest with 500 trees:

train_f <- train |> mutate(churn = factor(churn))

set.seed(1)
forest <- ranger(model, data = train_f, num.trees = 500,
                 probability = TRUE, importance = "permutation")
  1. Plot forest$variable.importance as a bar chart. Which four predictors does the forest rely on most? Are they the ones your tree uses?
  2. Does a high importance mean that, say, a longer contract causes customers to stay? Why not?

Part B — Decisions

B1 · “Pretty accurate”

Predict the forest’s probabilities for the holdout customers (predict(forest, holdout)$predictions[, "1"]) and classify with a threshold of 0.5. Make the confusion matrix with table() and compute the accuracy. Compare it with “nobody churns”. How many of the churners does the model catch at 0.5? What do you tell the marketing director?

B2 · Which model ranks best?

The models are compared on the training customers, by cross-validation — the holdout waits. This code gives every training customer a predicted probability from each model, fitted without that customer’s fold:

predict_with <- function(method, fit_data, new_data) {
  if (method == "logit") {
    fit <- glm(model, data = fit_data, family = binomial)
    predict(fit, new_data, type = "response")
  } else if (method == "tree") {
    fit <- rpart(model, data = fit_data, method = "anova", cp = best_cp)
    predict(fit, new_data)
  } else {
    set.seed(1)
    fit <- ranger(model, data = mutate(fit_data, churn = factor(churn)),
                  num.trees = 500, probability = TRUE)
    predict(fit, new_data)$predictions[, "1"]
  }
}

oof <- expand_grid(method = c("logit", "tree", "forest"), k = 1:5) |>
  mutate(
    p = purrr::map2(method, k, \(m, k) {
      predict_with(m, filter(train, fold != k), filter(train, fold == k))
    }),
    churn = purrr::map(k, \(k) train |> filter(fold == k) |> pull(churn))
  ) |>
  unnest(c(p, churn))

(best_cp is the CP you chose in A3.) For each model, compute the AUC and draw the ROC curves with roc(). Which model ranks best? By how much? Compare with the firm data of the live coding.

oof |>
  group_by(method) |>
  summarise(auc = as.numeric(auc(churn, p, quiet = TRUE)))

For the curves, roc() returns sensitivities and specificities; plot sensitivities against 1 - specificities.

B3 · Choose a threshold: 5 to 1

A customer who leaves costs the company 5 (the profit it loses); a discount offered to a customer who would have stayed anyway costs 1. For each model, find the threshold with the lowest loss on the out-of-fold probabilities, among seq(0.02, 0.9, by = 0.01), and compare it with the rule of thumb 1 / (1 + 5). Then — once — fit each model on all training customers and compute on the holdout customers, at its threshold: the loss, the accuracy, the number of churners caught and the number of discounts given to customers who would have stayed. Add the rule “nobody churns”.

A loss function:

loss <- function(p, actual, t, cost_missed = 5, cost_alarm = 1) {
  cost_missed * sum(p < t & actual == 1) +
    cost_alarm * sum(p >= t & actual == 0)
}

B4 · Choose a threshold: 1 to 1

Now the discount is as expensive as a lost customer: both mistakes cost 1. Repeat B3. Where does the best threshold lie now? Compare the loss-minimising rule with the rule that maximises accuracy — what do you notice? In two sentences: when is accuracy the right yardstick, and when is it not?

If you finish early

a) k nearest neighbours

kNN predicts with the k most similar training customers: the share of churners among them is the probability. It needs numbers on comparable scales — standardise with the training customers’ means and standard deviations, as in session 10:

library(class)       # comes with R

X_train   <- model.matrix(model, data = train)[, -1]
X_holdout <- model.matrix(model, data = holdout)[, -1]
centre <- colMeans(X_train)
spread <- apply(X_train, 2, sd)
Z_train   <- scale(X_train, centre, spread)
Z_holdout <- scale(X_holdout, centre, spread)

knn_probability <- function(k) {
  vote <- knn(Z_train, Z_holdout, cl = factor(train$churn), k = k,
              prob = TRUE)
  share <- attr(vote, "prob")            # share of the winning class
  if_else(vote == "1", share, 1 - share) # turn it into P(churn)
}

Compute the holdout AUC for k = 10, 50 and 200. Which k works best, and why does a small k do worse? What plays the role of the tree’s size here?

b) ROC and AUC by hand

The live coding’s optional part computes the ROC curve and the AUC without pROC. Do it for the forest’s out-of-fold probabilities, and check that you get the same AUC as pROC.

c) Lasso logistic regression

The lasso from session 9 works for classification too:

library(glmnet)

set.seed(1)
lasso_logit <- cv.glmnet(X_train, train$churn, family = "binomial",
                         type.measure = "auc", foldid = train$fold)
p_lasso <- predict(lasso_logit, X_holdout, s = "lambda.min",
                   type = "response")

Which predictors does it drop? Is its holdout AUC better than the logistic regression’s?