Задача

Этот проект нацелен на анализ оттока клиентов банка, в частности клиентов возрастной группы 40+ лет. С помощью предсказательной модели выявлены переменные, которые больше всего влияют на уход клиентов. Далее предложены рекомендации по изменениям для предотвращения большого процента оттока у банка в выбранном сегменте.

Анализ

Данные и логика анализа

library(DBI)
library(RMariaDB)
con <- dbConnect(RMariaDB::MariaDB(), 
                 user='studentminor', 
                 password='DataMinorHSE!2020', 
                 dbname='bank', 
                 host='34.88.193.134',
                 port = 3306)

library(dplyr)
library(ggplot2)
library(tidymodels)
library(rpart.plot)
library(vip)
library(fastDummies)
library(plotly)

Сначала выясняем общий процент оттока клиентов у банка.

churn <- dbGetQuery(con, "SELECT Exited, COUNT(*) AS num
                  FROM portfolio
                  GROUP BY Exited")

churn %>% mutate(pct=num/sum(num)*100)

Общий процент оттока - 20.37%. Это 2037 из 10.000 людей в представленных данных. Достаточно критичное число ушедших людей.

Далее посмотрим клиенты каких возрастных групп представлены в данных.

dbGetQuery(con, "SELECT MIN(Age) AS MinAge, MAX(Age) AS MaxAge, AVG(Age) AS AvgAge
                  FROM profile")
age <- dbGetQuery(con, "SELECT Age
                  FROM profile")

age %>% ggplot() +
   geom_histogram(aes(x=Age)) +
   ggtitle("Распределение возраста") +
   xlab("Возраст") +
   ylab("Количество клиентов") +
   theme_minimal()

quantile(age$Age)
##   0%  25%  50%  75% 100% 
##   18   32   37   44   92

Минимальный возраст 18 лет, а максимальный достигает 92 лет. Всего в данных больше клиентов в диопазоне 32-44, со средним значением около 39 лет.

Теперь посмотрим и сравним проценты оттока клиентов в возрастной группе младше 40 лет и в группе 40+ лет. (то есть младше или старше округленного среднего возраста клиентов)

churn.b40 <- dbGetQuery(con, "SELECT Exited, COUNT(*) AS num
                  FROM portfolio
                  INNER JOIN profile USING(CustomerId)
                  WHERE Age < 40
                  GROUP BY Exited")

churn.b40 %>% mutate(pct=num/sum(num)*100)
churn.a40 <- dbGetQuery(con, "SELECT Exited, COUNT(*) AS num
                  FROM portfolio
                  INNER JOIN profile USING(CustomerId)
                  WHERE Age >= 40 
                  GROUP BY Exited")

churn.a40 %>% mutate(pct=num/sum(num)*100)
  • Процент ухода среди клиентов до 40 лет маленький - 10%
  • Процент ухода среди клиентов после 40 лет критичный - 35.9%

Именно поэтому мы сфокусируемся на более проблемном сегменте - 40+ лет. Для этого сегмента будет построена предсказательная модель и сделаны рекомендации по улучшению.

Модель

Для модели использованы следующие переменные:

  • Является ли клиент активным, так как активные клиенты скорее всего довольны сервисом и более мотивированы остаться в банке
  • Страна, так как в какой-либо конкретной стране может быть больше уходящих клиентов и возможно нужны более локальные решения
  • Количество продуктов, так как определенное число продуктов может быть выгоднее клиентам
  • Баланс, возможно уходят важные клиенты с большими балансами
  • Наличие кредитной карты, наличие кредитной карты возможно тоже влияет
  • Пребывание в банке, обычно клиенты которые долго пользуются сервисом имеют меньше вероятность уйти
  • Зарплата, возможно зарплата влияет на уход
  • Кредитный скоринг, а также кредитный скоринг может оказаться важным
df <- dbGetQuery(con, "SELECT EstimatedSalary, CreditScore, Tenure, Balance, NumOfProducts, Exited, HasCrCard,                             IsActiveMember, Country
                       FROM portfolio
                       INNER JOIN profile USING(CustomerId)
                       INNER JOIN country ON profile.CountryId = country.CountryId
                       WHERE Age >= 40")
dbDisconnect(con)
Дерево решений

Переводим необходимые переменные в факторные.

df$Exited <- as.factor(df$Exited)
df$Exited <- relevel(df$Exited, "1")
df$HasCrCard <- as.factor(df$HasCrCard)
df$IsActiveMember <- as.factor(df$IsActiveMember)
df$Country <- as.factor(df$Country)

И далее делим данные на тренировочную и тестовую выборки.

set.seed(123) 
split = initial_split(df, prop = 0.8, strata = Exited) 
train = training(split) 
test = testing(split)

Сначала первую модель строим с помощью метода дерево решений.

tree <- decision_tree(
  mode = "classification") %>%
  set_engine("rpart")

tree.wf <- workflow() %>% 
  add_model(tree) %>% 
  add_formula(Exited ~.) %>% 
  fit(data = train)

rpart.plot(tree.wf$fit$fit$fit, roundint=F)

Доля правильных ответов, то есть точность модели, на тренировочной выборке 0.75, что неплохо. При этом доля истинно положительных классификаций - 0.68, а доля истинно отрицательных случаев - 0.8.

Показатели довольно хорошие и модель неплохо справляется с предсказание ухода клиентов.

train = train %>% 
  mutate(Prediction = predict(tree.wf, train)$.pred_class)

train %>% 
  conf_mat(truth = Exited, estimate = Prediction)  %>% 
  summary()

Точность модели на тестовой выборке 0.74, что тоже неплохо. Доля истинно положительных классификаций - 0.65, а доля истинно отрицательных случаев - 0.8.

На тестовой выборке модель работет так же, как и на тренировочной. Переобучения не наблюдается.

test = test %>% 
  mutate(Prediction = predict(tree.wf, test)$.pred_class)

test %>% 
  conf_mat(truth = Exited, estimate = Prediction)  %>% 
  summary()

Самыми важными переменными для предсказания стали: количество продуктов, является ли клиент активным, баланс и страна.

tree.wf %>%
  extract_fit_parsnip() %>%
  vip()

Логистическая регрессия

Теперь попробуем осуществить предсказания с помощью другого алгоритма - логистической регрессии.

df_dummy = dummy_cols(df,
select_columns = c(
"HasCrCard", "IsActiveMember", "Country"))

df_dummy <- df_dummy %>% select(-HasCrCard, -IsActiveMember, -Country)

Снова делим на тестовую и тренировочную выборки.

set.seed(123) 
split1 = initial_split(df_dummy, prop = 0.8, strata = Exited) 
train1 = training(split) 
test1 = testing(split)

И строим саму модель.

log = logistic_reg() %>% 
    fit(Exited~., data = train1)

summary(log$fit)
## 
## Call:
## stats::glm(formula = Exited ~ ., family = stats::binomial, data = data)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -2.1418  -1.1761   0.6475   0.9473   1.5536  
## 
## Coefficients:
##                   Estimate Std. Error z value Pr(>|z|)    
## (Intercept)     -3.085e-01  3.113e-01  -0.991  0.32166    
## EstimatedSalary -7.939e-07  6.787e-07  -1.170  0.24213    
## CreditScore      4.525e-04  4.006e-04   1.130  0.25862    
## Tenure           2.432e-02  1.337e-02   1.819  0.06889 .  
## Balance         -1.897e-06  7.258e-07  -2.614  0.00895 ** 
## NumOfProducts    1.832e-01  6.458e-02   2.836  0.00457 ** 
## HasCrCard1       8.507e-02  8.465e-02   1.005  0.31487    
## IsActiveMember1  1.114e+00  7.843e-02  14.198  < 2e-16 ***
## CountryGermany  -6.587e-01  9.826e-02  -6.704 2.03e-11 ***
## CountrySpain     1.368e-01  1.004e-01   1.363  0.17304    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 4190.8  on 3209  degrees of freedom
## Residual deviance: 3843.3  on 3200  degrees of freedom
## AIC: 3863.3
## 
## Number of Fisher Scoring iterations: 4

Точность модели на тренировочной выборке 0.67. Доля истинно положительных классификаций - 0.3, а доля истинно отрицательных случаев - 0.88.

train1 = train1 %>% 
  mutate(Prediction = predict(log, train)$.pred_class)

train1 %>% 
  conf_mat(truth = Exited, estimate = Prediction)  %>% 
  summary()

А на тестовой выборке точность 0.7, доля истинно положительных классификаций - 0.34, а доля истинно отрицательных случаев - 0.9.

Модель намного хуже предсказывает действительно ушедших клиентов.

test1 = test1 %>% 
  mutate(Prediction = predict(log, test1)$.pred_class)

test1 %>% 
  conf_mat(truth = Exited, estimate = Prediction)  %>% 
  summary()

Хоть модель предсказывает хуже, важными для предсказания она считает те же переменные, что и дерево решений: активность клиента, страна, количество продуктов и баланс.

vip:::vip.model_fit(log)

Симуляция

Анализ важных переменных

Теперь проанализируем отток по четырем выделенным переменным и проведем некоторые симуляции с ними.

  1. Посмотрим на доли ушедших клиентов среди активных и неактивных людей.
ggplot(train) + 
  geom_bar(aes(x = IsActiveMember, fill = Exited), position = "fill") + 
  scale_fill_manual(name="Ушел", labels=c("Да", "Нет"), values = c("#d64747", "#83B44B")) +
  ggtitle("Тренировочная выборка") +
  xlab("Является активным клиентом") +
  ylab("Доля клиентов") +
  scale_x_discrete(labels=c("Нет", "Да")) +
  theme_minimal()

ggplot(test) + 
  geom_bar(aes(x = IsActiveMember, fill = Exited), position = "fill") + 
  scale_fill_manual(name="Ушел", labels=c("Да", "Нет"), values = c("#d64747", "#83B44B")) +
  ggtitle("Тестовая выборка") +
  xlab("Является активным клиентом") +
  ylab("Доля клиентов") +
  scale_x_discrete(labels=c("Нет", "Да")) +
  theme_minimal()

Неактивные клиенты намного больше уходят, в 50% случаев в тренировочной и тестовой выборках

  1. Далее посмотрим на количество продуктов.
ggplot(train) + 
  geom_bar(aes(x = NumOfProducts, fill = Exited), position = "fill") +
  scale_fill_manual(name="Ушел", labels=c("Да", "Нет"), values = c("#d64747", "#83B44B")) +
  ggtitle("Тренировочная выборка") +
  xlab("Количество используемых продуктов") +
  ylab("Доля клиентов") +
  theme_minimal()

ggplot(test) + 
  geom_bar(aes(x = NumOfProducts, fill = Exited), position = "fill") +
  scale_fill_manual(name="Ушел", labels=c("Да", "Нет"), values = c("#d64747", "#83B44B")) +
  ggtitle("Тестовая выборка") +
  xlab("Количество используемых продуктов") +
  ylab("Доля клиентов") +
  theme_minimal()

Уходят люди у кого больше продуктов (3-4 продукта)

  1. Также посмотрим на отток в трех странах.
ggplot(train) + 
  geom_bar(aes(x = Country, fill = Exited), position = "fill") +
  scale_fill_manual(name="Ушел", labels=c("Да", "Нет"), values = c("#d64747", "#83B44B")) +
  ggtitle("Тренировочная выборка") +
  xlab(" ") +
  ylab("Доля клиентов") +
  scale_x_discrete(labels=c("Франция", "Германия", "Испания")) +
  theme_minimal()

ggplot(test) + 
  geom_bar(aes(x = Country, fill = Exited), position = "fill") +
  scale_fill_manual(name="Ушел", labels=c("Да", "Нет"), values = c("#d64747", "#83B44B")) +
  ggtitle("Тестовая выборка") +
  xlab(" ") +
  ylab("Доля клиентов") +
  scale_x_discrete(labels=c("Франция", "Германия", "Испания")) +
  theme_minimal()

В Германии очень много клиентов, которые ушли

  1. И наконец посмотрим как баланс связан с оттоком.
ggplot(train) + 
  geom_boxplot(aes(x = Exited, y = Balance, fill = Exited), show.legend = F) +
  scale_fill_manual(values = c("#d64747", "#83B44B")) +
  ggtitle("Тренировочная выборка") +
  xlab("Ушел") +
  scale_x_discrete(labels=c("Да", "Нет")) +
  ylab("Доля клиентов") +
  theme_minimal()

ggplot(test) + 
  geom_boxplot(aes(x = Exited, y = Balance, fill = Exited), show.legend = F) +
  scale_fill_manual(values = c("#d64747", "#83B44B")) +
  ggtitle("Тестовая выборка") +
  xlab("Ушел") +
  scale_x_discrete(labels=c("Да", "Нет")) +
  ylab("Доля клиентов") +
  theme_minimal()

Заметим, что уходят у кого в среднем больший баланс

Симуляции и рекомендации
  1. Во-первых, мы заметили, что активные клиенты меньше склонны к уходу. Соответственно первым возможным решением будет увеличение активности некоторых клиентов. “Спящие клиенты” могут быть привлечены и удержаны с помощью рассылок, специальных предложений и выгодных тарифов лояльности. Итак, взбодрить клиентов можно с помощью специальных или сезонных предложений. Например, бонусные начисления за определенные действия и покупки, выгодные ставки на последующие кредиты/счета и т.д.

Если таким образом получится действительно взбодрить некоторых неактивных клиентов, допустим с вероятностью 30% неактивные клиенты станут активными, то уровень ухода снизится.

test2 = test
set.seed(123)
test2$IsActiveMember[test2$IsActiveMember == "0"] = 
  sample(c("0", "1"), 
         size = length(test2$IsActiveMember[test2$IsActiveMember == "0"]),
         replace = T, prob = c(0.7, 0.3))

predTest1 = predict(tree.wf, test2)$.pred_class

table(predTest1)
## predTest1
##   1   0 
## 243 560
table(test$Exited)
## 
##   1   0 
## 288 515
ggplot(data.frame(predTest1)) + geom_bar(aes(x = predTest1), alpha = 0.5, fill = "red") +
  geom_bar(data = test, aes(x = Exited), alpha = 0.5) + xlab("Ушли") +
  ylab("Количество клиентов") +
  ggtitle("Симуляция с увеличением активности") +
  scale_x_discrete(labels = c("Да", "Нет")) +
  theme_minimal()

  1. Во-вторых, уходят клиенты с 3-4 продуктами. Эти клиенты нам важны, они использовали много продуктов, но почему-то они почти все ушли. Вероятно в банке не выгодно иметь 3-4 продукта или в банке-конкуренте выгоднее. Поэтому возможно нужны изменения для пользователей многих продуктов, более выгодные предложения для удержания этих клиентов.

Манипуляции с числом продуктов показать не получится.

  1. В-третьих, проблемной оказалась Германия. Возможно проблему нужно решать именно там, так как больше половины уходящих клиентов это очень критично. Возможно в Германии есть серьезный конкурент для нашего банка. Нужны срочные политики по удержанию клиентов, также можно спросить у всех ушедших напрямую причины, чтобы улучшить сервис на основании этих ответов.

Манипуляции со страной также не получится показать.

  1. И наконец, уходят люди с большим балансом. Опять же это может говорить о невыгодных условиях в сравнении с конкурентами. Если люди еще работающие и пенсионеры пользуются банком чтобы хранить там крупные суммы на сберегательном счету, им приятна будет выгодная ставка. Если у конкурентов она выше, то люди из нашего банка уходят.

С балансом также нельзя представить симуляции, это зависит от клиентов.

Дэшборд

Этот дэшборд предназначен для руководителей банка, чтобы обратить их внимание на проблемный сегмент и сообщить основные паттерны ушедших клиентов для проведения политик по уменьшению оттока.

  1. Сначала показать общий уровень оттока в виде valueBox

  2. Затем обратить внимание на больший уровень оттока в сегменте 40+ лет также в виде valueBox

  3. Далее сделать интерактивный график количество ушедших и оставшихся людей в сегменте 40+

  4. Фильтры по 4-м главным переменным (кол-во продуктов, страна, баланс, активность), которые меняют график оттока в сегменте. То есть можно посмотреть на все паттерны и закономерности.

  5. Главные выводы из модели, чтобы клиент понимал на что смотреть в дэшборде:

  • Больше ушедших среди людей с большим балансом

  • Наибольшая доля ушедших в Германии

  • Больше ушедших с большим количеством продуктов (3-4 шт.)

  • Большая доля ушедших среди неактивных клиентов

Общие выводы

Таким образом, в ходе анализа сегмента 40+ лет были выделены основные паттерны уходящих. Это неактивные клиенты, больше клиенты из Германии, клиенты с большим балансом в среднем и имеющие 3-4 продукта в банке. Далее были предложены рекомендации по улучшению и приведены возможные симуляции для наглядности. Также с помощью дэшборда можно самостоятельно оценить влияние четырех главных переменных на уровень оттока в сегменте и посмотреть их взаимные закономерности.