Statistical Methods in Customer Relationship Management
Chapter 4. Customer Retention
Alexander Rodionov
6 июня 2018 г.
- Глава 4. Удержание клиентов
- Данные для эмпирических примеров
- Эмпирический пример: Повторная покупка или нет (остаться или уйти)
- Эмпирический пример: Продолжительность сотрудничества с клиентом
- Эмпирический пример: величина заказа
- Эмпирический пример: перекрестные продажи
- Эмпирический пример: доля покупок в кошельке
- Эмпирический пример: Рентабельность или Пожизненная финансовая ценность клиента (CLV)
- Дискуссия по RFM Модели вероятности повторной покупки
- Выводы по главе 4
Мы продолжаем рассматриваем в R примеры SAS на наборах данных из книги Kumar V., Petersen Andrew J. “Statistical Methods in Customer Relationship Management”.
Глава 4. Удержание клиентов
После того, как клиенты были приобретены, важно обсудить второй шаг CRM - сохранить клиентов. Стратегии удержания клиентов используются как в договорных условиях (когда клиенты привязаны к контрактам, таким как догвор на мобильный телефон с пакетом связи или подписка на журнал) и внедоговорные условия (где клиенты не связаны контрактами, такими как покупки в продуктах или покупки одежды). Рейхельд и Сассер (Reichheld and Sasser, 1990) заявили, что 5% -ное улучшение удержания клиентов может привести к увеличению рентабельности в пределах от 25 до 85% с точки зрения чистой текущей стоимости в зависимости от отрасли. С тех пор компании постоянно выделяют ресурсы на управление удержанием клиентов, и исследователи уделяют большое внимание изучению сохранению клиентов.
Исследования по сохранению клиентов имеют два основных направления. Одно направление заинтересовано в исследовании влияния различных маркетинговых переменных на удержание клиентов, что, в свою очередь, влияет на производительность фирмы. Другое напарвление заинтересовано в создании эконометрических и статистических моделей для оценки или прогнозирования решений о сохранении клиентов как со стороны клиента, так и со стороны компании.
The Picture 1
На рисунке 1 показана интегрированная структура, которая описывает различные отношения, рассмотренные в разных исследованиях во многих отраслях. Эти отрасли включают в себя, в частности, телекоммуникации, финансовые услуги, сферу услуг, рестораны и розничную торговлю. Общей темой этих отношений является мышление, которое направлено на:
- повышение качества продукции и услуг, приводящее к повышению удовлетворенности клиентов;
б) всемерная удовлетворенность клиентов приводит к увеличению удержания клиентов (что обусловлено качеством отношений, так что более высокое качество отношений положительно улучшает связь между удовлетворением и удержанием) и
- увеличение удержания клиентов приводит к повышению эффективности работы фирмы.
The Picture 2
Авторам книги по понятным причинам импонирует второе направление исследований по удержанию клиентов (см. рисунок 2), которое влияет на решения, принимаемых менеджерами по текущим клиентам. Часто возникает несколько ключевых вопросов, в разрешении которых менеджеры заинтересованы при формировании ответа после привлечения клиента. К ним относятся:
Будет ли недавно приобретенный покупатель купать или нет в дальнейшем?
Какова будет продолжительность жизни клиента (т. е. когда клиент завершит сотрудничество с фирмой)?
Учитывая, что клиент собирается выкупить:
Сколько предметов покупает клиент?
Сколько этот клиент способен потратить?
Будет ли этот клиент покупать / заказывать в нескольких категориях продуктов?
Покупает ли потребитель в основном у одной фирмы (значительная доля в кошельке) или у многих разных фирм (низкая доля в кошельке)?
Какое долгосрочное влияние покупательского поведения клиента на стоимость фирмы?
Чтобы дать полное понимание того, как моделировать процесс удержание клиентов, авторы рассматривают вышеперечисленные вопросы в исследованиях один за другим вместе с соответствующими методами моделирования. Они также представляют эмпирические примеры в конце каждого подраздела, чтобы продемонстрировать, как применять эти знания к представительной выборке клиентов из фирмы B2C.
Подобно моделям приобретения клиентов, первый вопрос, на который необходимо ответить при выборе модели, заключается в том, встпуют ли клиенты договорные и внедоговорные отношения с фирмой. В большинстве случаев это определяет тип статистической модели, который необходимо использовать для получения информации из данных.
Данные для эмпирических примеров
В этой главе авторы дают описание основных этапов моделирования, в ходе которого пытаются ответить на каждый ключевой вопрос исследования, поднятый в начале главы. Они также предоставляют по крайней мере один эмпирический пример в конце каждого подраздела, который покажет, какие данные могут использоваться для формирования ответа на эти ключевые вопросы исследования. Для всех эмпирических примеров в этой главе авторы предлагают набор данных под названием «Удержание клиентов», который разбит на две связанные таблицы данных. В этом наборе данных вы найдете две таблицы данных, которые включают репрезентативную выборку из 500 клиентов из типичной фирмы B2C, где все клиенты принадлежат к одной когорте. В этом случае когорта состоит из случайной выборки из 500 клиентов, которые совершили первую покупку у фирмы в четвертом квартале. В первой таблице данных предоставлена информацию о транзакциях для каждого клиента в течение 12 кварталов (“customerRetentionTransactions”). Таким образом, таблица данных состоит из 6000 строк (500 клиентов * 12 кварталов) и 8 столбцов. Во второй таблице данных предоставлена демографическая информация по каждому клиенту (“customerRetentionDemographics”). Таким образом, таблица данных состоит из 500 строк (500 клиентов) и 6 столбцов.
Первая таблица данных (“customerRetentionTransactions”) включает нижеследующие переменные, которые будут использоваться в некоторой комбинации в ходе каждого последующего этапа анализа:
| Переменные | Описание |
|---|---|
| Customer | Номер клиента клиента (от 1 до 500) |
| Quarter | Квартал (от 1 до 12), когда произошла транзакция |
| Purchase | если 1, когда покупатель приобрел в данном квартале, 0, если в этом квартале не произошло покупок |
| Order_quantity | Долларовая стоимость покупок в данном квартале |
| Crossbuy | Количество различных категорий товаров / услуг, приобретенных в данном квартале |
| Ret_Expense | Доллары потраченные на маркетинговые усилия по удержанию этого клиента в данном квартале |
| Ret_Expense_SQ | Квадрат затрат на маркетинговые усилияпо удержанию этого клиента в данном квартале |
Вторая таблица данных (“customerRetentionDemographics”) включает следующие переменные которые будут использоваться в некоторой комбинации в ходе каждого последующего этапа анализа:
| Переменные | Описание |
|---|---|
| Customer | Номер клиента клиента (от 1 до 500) |
| Gender | 1, если клиент является мужчиной, 0, если клиент является женщиной |
| Married | 1, если клиент женат, 0, если клиент не состоял в браке |
| Income | 1, если доход < 30 000 долл. США, 2; если 30 001 долл. США < доход < 45 000 долл. США; 3, если 45 001 долл. США < доход < 60 000 долл. США; 4, если 60 001 долл. США < доход < 75 000 долл. США; 5, если 75 001 долл. США < доход < 90 000 долл. США; 6, если доход > 90 001 долл. США |
| First_Purchase | Стоимость первой покупки, сделанной клиентом в 1 квартале |
| Loyalty | 1, если клиент является членом программы лояльности, 0, если нет |
| Share-of-Wallet (SOW) | Процент покупок клиента от данной фирмы, учитывая общий объем покупок по всем фирмам в этой категории |
| CLV | Дисконтированная стоимость всех ожидаемых будущих прибылей или стоимости жизни клиента |
Эти примеры будут охватывать темы “повторная покупка или нет”“,”количество заказов“,”размер заказа“,”перекрестные покупки“,”доля в кошельке (SOW)" и “доходность (CLV)”.
library('tidyverse')## -- Attaching packages ----------------------------------------------------------------------------- tidyverse 1.2.1 --## v ggplot2 2.2.1 v purrr 0.2.4
## v tibble 1.4.2 v dplyr 0.7.5
## v tidyr 0.8.1 v stringr 1.3.1
## v readr 1.1.1 v forcats 0.3.0## -- Conflicts -------------------------------------------------------------------------------- tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()library('caret')## Loading required package: lattice##
## Attaching package: 'caret'## The following object is masked from 'package:purrr':
##
## liftlibrary('car')## Loading required package: carData##
## Attaching package: 'car'## The following object is masked from 'package:dplyr':
##
## recode## The following object is masked from 'package:purrr':
##
## someutils::data('customerRetentionTransactions', package = 'SMCRM')
utils::data('customerRetentionDemographics', package = 'SMCRM')Странно, но в авторском наборе данных отсутствует важнейший демографический показатель возраст.
Эмпирический пример: Повторная покупка или нет (остаться или уйти)
Один из ключевых вопросов, на который авторы хотят ответить по удержанию клиентов, заключается в том, можем ли мы определить, какие клиенты имеют наибольшую вероятность повторной покупки (“repurchase”). Для этого сначала нужно узнать, какие текущие клиенты фактически совершили дополнительные покупки после их первоначальной первой покупки. В наборе данных, предоставленном для этой главы, имеется бинарная переменная, которая идентифицирует, покупает ли покупатель за данный период времени, в этом случае - квартале. Авторы также предоставляютм набор предикторов, которые могут помочь объяснить решение клиента о повторной покупке. В конце этого примера вы сможете сделать следующее:
Определите драйверы поведения клиентов для повторной покупки.
Интерпретируйте оценки параметров из модели повторной покупки.
Предскажите количество повторных покупок клиентами.
Определить предиктивную точность модели повторной покупки.
Авторы в обзоре литературы указали, что ряд исследователей включают в число предикторов в подобные модели показатели RFM (англ. Recency – How recently did the customer purchase? Frequency – How often do they purchase? Monetary Value – How much do they spend?) - CRM метрики, которая позволяет детально описать в трех переменных ранжированную совокупность клиентов. Однако сами авторы книги решили не прибегать к ее применению.
Компания B2C хочет увеличить доля клиентов, совершивших повторную покупку и сократить расходы на удержание клиентов, лучше понимая при этом, какие клиенты чаще всего покупают повторно за определенный период времени. Случайная выборка из 500 клиентов из одной когорты была взята из базы данных фирмы. Информация, необходимая для нашей модели, включает следующий список переменных:
| Переменные | Описание |
|---|---|
| Зависимая переменная | |
| Purchase | если 1, когда покупатель приобрел в данном квартале, 0, если в этом квартале не произошло покупок |
| Предикторы | |
| Lag_Purchase | 1, если клиент приобрел в предыдущем квартале, 0, если в предыдущем квартале покупка не произошла |
| Avg_Order_Quantity | Средняя долларовая стоимость покупок во всех предыдущих кварталах |
| Ret_Expense | Доллары потраченные на маркетинговые усилия по удержанию этого клиента в данном квартале |
| Ret_Expense_SQ | Квадрат затрат на маркетинговые усилияпо удержанию этого клиента в данном квартале |
| Gender | 1, если клиент является мужчиной, 0, если клиент является женщиной |
| Married | 1, если клиент женат, 0, если клиент не состоял в браке |
| Income | 1, если доход < 30 000 долл. США, 2; если 30 001 долл. США < доход < 45 000 долл. США; 3, если 45 001 долл. США < доход < 60 000 долл. США; 4, если 60 001 долл. США < доход < 75 000 долл. США; 5, если 75 001 долл. США < доход < 90 000 долл. США; 6, если доход > 90 001 долл. США |
| First_Purchase | Стоимость первой покупки, сделанной клиентом в 1 квартале |
| Loyalty | 1, если клиент является членом программы лояльности, 0, если нет |
# Combine Data
library('sqldf') # Manipulate R Data Frames Using SQL## Loading required package: gsubfn## Loading required package: proto## Loading required package: RSQLitecustomerRetention <- sqldf("select distinct a.*, b.*
from customerRetentionTransactions a left join customerRetentionDemographics
b on a.customer = b.customer order by customer;")
# Repurchase Probability
customerRetentionRepurchase <- customerRetention %>%
mutate(lcustomer = lag(customer, 1), cb = if_else(crossbuy > 1, 1, 0)) %>% # Lag by customer
mutate(lpurchase = if_else(customer == lcustomer, lag(purchase), 0),
lcb = if_else(customer == lcustomer, lag(cb), 0),
lcrossbuy = if_else(customer == lcustomer, lag(crossbuy), 0)) %>%
mutate(lpurchase = if_else((quarter == 2), 1, lpurchase),
lcrossbuy = if_else((quarter == 2), 1, lcrossbuy),
lcb = if_else((quarter == 2), 0, lcb)) %>%
group_by(customer) %>%
mutate(quantity_sum = cumsum(order_quantity)) %>%
mutate(avg_order_quantity = quantity_sum / quarter) %>%
ungroup %>%
mutate(lavg_order_quantity = lag(avg_order_quantity, 1)) %>% # should `avg_order_quantity` by lag 1
mutate(ID = row_number()) %>%
arrange(desc(ID)) %>%
select(-one_of("ID", "quantity_sum", "customer..8")) %>%
filter(quarter != 1)
# Check for Class Imbalances
customerRetentionRepurchase$purchase %>%
factor() %>%
table() %>%
prop.test()##
## 1-sample proportions test with continuity correction
##
## data: ., null probability 0.5
## X-squared = 3.718, df = 1, p-value = 0.05383
## alternative hypothesis: true p is not equal to 0.5
## 95 percent confidence interval:
## 0.4997859 0.5263775
## sample estimates:
## p
## 0.5130909# ## Open workbook into temporary file
# openxlsx::addWorksheet(wb0 <- openxlsx::createWorkbook(), sheetName = "Output", gridLines = FALSE)
# openxlsx::writeData(wb0, sheet = 1, x = customerRetentionRepurchase, withFilter = TRUE); openxlsx::openXL(wb0)Бинарный класс “Повторной покупки” получился сбалансированный - нулевую гипотезу о равном разбиении после теста пропорций долей следует признать верной.
Нужно смоделировать вероятность того, что клиент купит за данный период времени. Поскольку зависимая переменная (purchase) является бинарной, выбирают логическую регрессию для оценки модели. Также можно выбрать модель пробита и в целом достичь тех же результатов. В этом случае зависимая переменная представляет собой Purchase, а предикторы представляют девять независимых переменных.
Построение и верификация модели повторной покупки
Logit
# # Fit Logistic Regression Model for Customer Retention by Authors
Ch04.logit <- glm(purchase ~ lpurchase + avg_order_quantity + ret_expense + ret_expense_sq +
gender + married + income + first_purchase + loyalty,
# lavg_order_quantity + factor(income) + factor(loyalty),
data = customerRetentionRepurchase, family = binomial(link = 'logit'))
summary(Ch04.logit)##
## Call:
## glm(formula = purchase ~ lpurchase + avg_order_quantity + ret_expense +
## ret_expense_sq + gender + married + income + first_purchase +
## loyalty, family = binomial(link = "logit"), data = customerRetentionRepurchase)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.7259 -0.2728 -0.1112 0.3817 3.0999
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -5.5953781 0.2493063 -22.444 < 2e-16 ***
## lpurchase 3.1429323 0.1245278 25.239 < 2e-16 ***
## avg_order_quantity 0.0153138 0.0007000 21.876 < 2e-16 ***
## ret_expense 0.1290926 0.0110355 11.698 < 2e-16 ***
## ret_expense_sq -0.0027957 0.0002352 -11.887 < 2e-16 ***
## gender -0.1767274 0.0992250 -1.781 0.0749 .
## married -0.0125407 0.1153743 -0.109 0.9134
## income 0.1593555 0.0339781 4.690 2.73e-06 ***
## first_purchase 0.0012845 0.0010746 1.195 0.2319
## loyalty 0.2707511 0.1067446 2.536 0.0112 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 7620.8 on 5499 degrees of freedom
## Residual deviance: 2848.9 on 5490 degrees of freedom
## AIC: 2868.9
##
## Number of Fisher Scoring iterations: 6writeLines(sprintf("-2 Log L of Intercept and Only Covariates: %.3f", -2 * logLik(Ch04.logit)[1]))## -2 Log L of Intercept and Only Covariates: 2848.857writeLines(sprintf(" AIC (smaller is better): %.3f", extractAIC(Ch04.logit)[2]))## AIC (smaller is better): 2868.857# Odds Ratio Estimates and 95% CI
writeLines("\n Odds Ratio Estimates and 95% CI")##
## Odds Ratio Estimates and 95% CIcar::Confint(Ch04.logit) %>%
exp() %>%
arm::pfround(digits = 3)## Estimate 2.5 % 97.5 %
## (Intercept) 0.004 0.002 0.006
## lpurchase 23.172 18.213 29.683
## avg_order_quantity 1.015 1.014 1.017
## ret_expense 1.138 1.114 1.163
## ret_expense_sq 0.997 0.997 0.998
## gender 0.838 0.690 1.018
## married 0.988 0.788 1.239
## income 1.173 1.097 1.254
## first_purchase 1.001 0.999 1.003
## loyalty 1.311 1.063 1.616writeLines("\n Wald test of predictors")##
## Wald test of predictorscar::Anova(Ch04.logit, type="II", test="Wald")## Analysis of Deviance Table (Type II tests)
##
## Response: purchase
## Df Chisq Pr(>Chisq)
## lpurchase 1 636.9968 < 2.2e-16 ***
## avg_order_quantity 1 478.5754 < 2.2e-16 ***
## ret_expense 1 136.8421 < 2.2e-16 ***
## ret_expense_sq 1 141.3004 < 2.2e-16 ***
## gender 1 3.1722 0.0749 .
## married 1 0.0118 0.9134
## income 1 21.9956 2.733e-06 ***
## first_purchase 1 1.4289 0.2319
## loyalty 1 6.4335 0.0112 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1writeLines("\n Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")##
## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04.logit) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity## lpurchase avg_order_quantity ret_expense ret_expense_sq gender married
## 1.298839 1.203369 16.111829 15.988944 1.015232 1.006399
## income first_purchase loyalty
## 1.018219 1.008979 1.008289writeLines("\n Repurchase Probability (Logit): Association of Predicted Probabilities and Observed Responses \n")##
## Repurchase Probability (Logit): Association of Predicted Probabilities and Observed Responsesprob <- predict(Ch04.logit, newdata = customerRetentionRepurchase, type = "response")
caret::confusionMatrix(data = ifelse(prob > 0.5, "1", "0") %>% factor,
reference = customerRetentionRepurchase$purchase %>% factor,
positive = "1", mode = "everything")## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 2503 206
## 1 319 2472
##
## Accuracy : 0.9045
## 95% CI : (0.8965, 0.9122)
## No Information Rate : 0.5131
## P-Value [Acc > NIR] : < 2.2e-16
##
## Kappa : 0.8092
## Mcnemar's Test P-Value : 1.018e-06
##
## Sensitivity : 0.9231
## Specificity : 0.8870
## Pos Pred Value : 0.8857
## Neg Pred Value : 0.9240
## Precision : 0.8857
## Recall : 0.9231
## F1 : 0.9040
## Prevalence : 0.4869
## Detection Rate : 0.4495
## Detection Prevalence : 0.5075
## Balanced Accuracy : 0.9050
##
## 'Positive' Class : 1
## Во-первых, это означает, что Lag_Purchase оказывает положительное влияние на текущую покупку, то есть клиенты, совершившие покупку в предыдущем квартале, с большей вероятностью совершают покупку в текущем квартале. Во-вторых, поскольку коэффициент по Avg_Order_Quantity является положительным и статистически значимым, это означает, что клиенты, которые в прошлом потратили больше в среднем, также чаще покупают в текущем периоде времени. В-третьих, авторы обнаружилм положительный, но уменьшающий доход от эффекта удерживающих расходов (Ret_Expense) при покупке в том же квартале, поскольку коэффициент на Ret_Expense положителен, а коэффициент Ret_Expense_SQ отрицателен. В-четвертых, нашли небольшой положительный эффект для женщин (отрицательный коэффициент по полу), что означает, что женщины, как правило, чаще приобретают, чем мужчины. В-пятых, обнаружен положительный эффект дохода, предполагающий, что клиенты, имеющие более высокий доход, с большей вероятностью будут покупать в текущем квартале. Наконец, поскольку коэффициент при лояльности положителен, это говорит о том, что клиенты, которые являются членами программы лояльности, с большей вероятностью будут покупать в текущем квартале.
Поскольку проблема несбалансированности классов практически отсутствует, то в качестве меры точности модели можно рекомендовать коэффициента Cohen’s Kappa и коэффициент аккуратности.
Logit (Version AR)
Следует заметить, что расчет среднеквартального объема заказа avg_order_quantity при подсчете по приведенному в книге коду SAS фактически включает также текущий квартал. Хотя в описании авторы указали, что среднеквартальных объем заказа относиться только в предыдущим месяцам. В результате возникает смещение, учитывающее влияние объема заказа текущего квартала, которые и следует предсказывать, что особенно заметно проявляется в первых кварталах наблюдений. На мой взгляд было бы более точным брать предиктором avg_order_quantity с однопериодным лагом (кварталом).
Замечено, что если предикторы income и loyalty объявить порядковым и бинарным факторами, соответствено, а незначимые признаки married, first_purchase вовсе удалить, то и с меньшим числом предикторов можно получить устойчивую логистическую модель, но без смещения средних продаж на текущий квартал. Кроме того, в связи со значительной мультиколлинеарностью показателей затрат на удержание в текущем квартале и их квадрата - ret_expense и ret_expense_sq следует исключить.
# Fit Logit Regression Model for Customer Repurchase (Improved)
uno = 'logit'
set.seed(2018) #From random.org
(Ch04lg.AR <- train(factor(purchase) ~ lpurchase + lavg_order_quantity + ret_expense +
ordered(income) + first_purchase + factor(loyalty), metric = 'Kappa',
data = customerRetentionRepurchase, method = "glm", family = binomial(link = uno)))#,## Generalized Linear Model
##
## 5500 samples
## 6 predictor
## 2 classes: '0', '1'
##
## No pre-processing
## Resampling: Bootstrapped (25 reps)
## Summary of sample sizes: 5500, 5500, 5500, 5500, 5500, 5500, ...
## Resampling results:
##
## Accuracy Kappa
## 0.8903399 0.7810851 # trControl = trainControl(method = "none", number = 1)))
summary(Ch04lg.AR)##
## Call:
## NULL
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.4660 -0.3369 -0.1904 0.5232 2.8463
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.8946824 0.1844004 -21.121 < 2e-16 ***
## lpurchase 3.7605100 0.1200863 31.315 < 2e-16 ***
## lavg_order_quantity 0.0056745 0.0005988 9.477 < 2e-16 ***
## ret_expense 0.0039790 0.0025958 1.533 0.12531
## `ordered(income).L` 0.9911790 0.1360023 7.288 3.15e-13 ***
## `ordered(income).Q` -0.2308942 0.1291395 -1.788 0.07379 .
## `ordered(income).C` 0.0590448 0.1154560 0.511 0.60907
## `ordered(income)^4` -0.0310445 0.1042508 -0.298 0.76587
## `ordered(income)^5` 0.0616015 0.0990047 0.622 0.53381
## first_purchase 0.0021954 0.0009785 2.244 0.02486 *
## `factor(loyalty)1` 0.2630438 0.0980694 2.682 0.00731 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 7620.8 on 5499 degrees of freedom
## Residual deviance: 3473.4 on 5489 degrees of freedom
## AIC: 3495.4
##
## Number of Fisher Scoring iterations: 5# Odds Ratio Estimates and 95% CI
writeLines("\n Odds Ratio Estimates and 95% CI")##
## Odds Ratio Estimates and 95% CIcar::Confint(Ch04lg.AR$finalModel) %>%
exp() %>%
arm::pfround(digits = 3)## Estimate 2.5 % 97.5 %
## (Intercept) 0.020 0.014 0.029
## lpurchase 42.970 34.080 54.581
## lavg_order_quantity 1.006 1.005 1.007
## ret_expense 1.004 0.999 1.009
## `ordered(income).L` 2.694 2.066 3.521
## `ordered(income).Q` 0.794 0.617 1.023
## `ordered(income).C` 1.061 0.846 1.330
## `ordered(income)^4` 0.969 0.790 1.189
## `ordered(income)^5` 1.064 0.876 1.291
## first_purchase 1.002 1.000 1.004
## `factor(loyalty)1` 1.301 1.073 1.576# Logistic regression diagnostics
writeLines("\n Wald test of predictors")##
## Wald test of predictorscar::Anova(Ch04lg.AR$finalModel, type="II", test="Wald")## Analysis of Deviance Table (Type II tests)
##
## Response: .outcome
## Df Chisq Pr(>Chisq)
## lpurchase 1 980.6338 < 2.2e-16 ***
## lavg_order_quantity 1 89.8128 < 2.2e-16 ***
## ret_expense 1 2.3496 0.125313
## `ordered(income).L` 1 53.1144 3.147e-13 ***
## `ordered(income).Q` 1 3.1967 0.073785 .
## `ordered(income).C` 1 0.2615 0.609067
## `ordered(income)^4` 1 0.0887 0.765866
## `ordered(income)^5` 1 0.3871 0.533805
## first_purchase 1 5.0336 0.024860 *
## `factor(loyalty)1` 1 7.1943 0.007314 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1writeLines("\n Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")##
## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04lg.AR$finalModel) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity## lpurchase lavg_order_quantity ret_expense `ordered(income).L` `ordered(income).Q` `ordered(income).C`
## 1.379228 1.381815 1.005090 1.148599 1.046745 1.139748
## `ordered(income)^4` `ordered(income)^5` first_purchase `factor(loyalty)1`
## 1.046886 1.008112 1.013061 1.026975writeLines("\n Variable Importance for Model \n")##
## Variable Importance for Modelcaret::varImp(Ch04lg.AR) %>% .$importance %>% print.AsIs()## Overall
## lpurchase 100.000000
## lavg_order_quantity 29.593736
## ret_expense 3.981853
## `ordered(income).L` 22.536380
## `ordered(income).Q` 4.804281
## `ordered(income).C` 0.688708
## `ordered(income)^4` 0.000000
## `ordered(income)^5` 1.045936
## first_purchase 6.273230
## `factor(loyalty)1` 7.687435# Create the scatter plots Logit versus model predictors
# prob <- predict(Mod04lg.AR, newdata = customerRetentionRepurchase, type = "prob")[, "1"]
# mutate(logit = log(prob / (1 - prob))) %>%
set.seed(2018)
Ch04LG.AR <- train(factor(purchase) ~ lpurchase + lavg_order_quantity + ret_expense +
income + first_purchase + loyalty, metric = 'Kappa',
data = customerRetentionRepurchase, method = "glm", family = binomial(link = uno))
predictors <- Ch04LG.AR$coefnames
Ch04LG.AR$trainingData %>%
dplyr::select(one_of(predictors)) %>%
mutate(link = predict(Ch04LG.AR$finalModel, newdata = customerRetentionRepurchase, type = "link")) %>%
gather(key = "predictors", value = "predictor.value", -link) %>%
ggplot(aes(predictor.value, link))+
geom_point(size = 0.05, alpha = 0.05) +
geom_smooth(method = "loess") +
facet_wrap(~ predictors, scales = "free_x") +
ylab(stringr::str_to_title(uno))
remove(Ch04LG.AR)
# Plot matrix of statistical model diagnostics
GGally::ggnostic(Ch04lg.AR$finalModel, title = paste(paste(formula(Ch04lg.AR)[c(2, 1, 3)], collapse = " ")))## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
# wide variety of diagnostic plots for checking the quality of regression fit
# https://bookdown.org/jefftemplewebb/IS-6489/logistic-regression.html
car::influenceIndexPlot(Ch04lg.AR$finalModel)
writeLines("\n Improved Logit Model: Association of Predicted Probabilities and Observed Responses \n")##
## Improved Logit Model: Association of Predicted Probabilities and Observed Responsescaret::confusionMatrix(data = predict(Ch04lg.AR, newdata = customerRetentionRepurchase),
reference = customerRetentionRepurchase$purchase %>% factor,
positive = "1", mode = "everything")## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 2363 143
## 1 459 2535
##
## Accuracy : 0.8905
## 95% CI : (0.882, 0.8987)
## No Information Rate : 0.5131
## P-Value [Acc > NIR] : < 2.2e-16
##
## Kappa : 0.7816
## Mcnemar's Test P-Value : < 2.2e-16
##
## Sensitivity : 0.9466
## Specificity : 0.8373
## Pos Pred Value : 0.8467
## Neg Pred Value : 0.9429
## Precision : 0.8467
## Recall : 0.9466
## F1 : 0.8939
## Prevalence : 0.4869
## Detection Rate : 0.4609
## Detection Prevalence : 0.5444
## Balanced Accuracy : 0.8920
##
## 'Positive' Class : 1
## qplot(`Observed Classes`, `Predicted Classes`,
data=bind_cols(`Observed Classes`= factor(customerRetentionRepurchase$purchase),
`Predicted Classes` = predict(Ch04lg.AR, newdata = customerRetentionRepurchase)),
colour= `Observed Classes`, geom = c("boxplot", "jitter"),
main = "Predicted Classes vs. Observed Classes", xlab = "Observed Classes", ylab = "Predicted Classes")
Но авторы на такие шаги не пошли, вероятно, для большей дидактической ясности. Правда, аккуратность модели с лагом, т. е. **l**avg_order_quantity будет немного ниже, но зато устойчивость (модель получена бутстреп-методом - англ. bootstrap с 25-тью “псевдовыборок”) станет существенной.
Как это использовать?
Авторы полагали, что поведение при проведении транзакций в прошлом, скорее всего, объяснит будущее поведение покупателей. В результате в этом примере они использовали несколько операций из предыдущего квартала по отношению текущему в качестве независимых переменных (предикторов). В дальнейшем менеджерам будет полезно знать какие драйверы влияют на поведения последующих покупок клиентами.
Во-первых, авторы знают, приобрел ли покупатель в последнем квартале (Lag_Purchase). Эта переменная может быть получена путем принятия запаздывающего значения переменной индикатора покупки, отмечая, что одно наблюдение будет потеряно для каждого клиента. В этом случае мы используем только однопериодное отставание - квартальное. Во-вторых, мы имеем среднюю величину прошлых заказов (Avg_Order_Quantity). В этом случае значение для среднего количества заказа является средним значением переменной Order_Quantity во всех кварталах до текущего периода времени (как я показал выше, фактически это нет и текущий период авторами включается в расчет средней). В-третьих, у авторам известно, сколько долларов фирма потратила на каждого клиента (Ret_Expense) за каждый период времени и квадрат значения этой переменной (Ret_Expense_SQ). Авторы хотили использовать как линейные, так и квадратичные термины, так как ожидали, что для каждого дополнительного доллара, потраченного на усилия по удержанию для данного клиента, будет уменьшаться возврат к стоимости этого доллара (“закон убывающей доходности”). Наконец, поскольку фирма этого примера относится к сектору B2C, остальные пять переменных являются социально-демографическими характеристиками клиентов. К ним относятся пол клиента gender, является ли клиент женатым (married), порядковый ранг дохода клиента (income), стоимость первой покупки клиента (First_Purchase) и является ли клиент членом программы лояльности (loyalty).
В результате мы теперь знаем, как изменения в расходах на удержание, прошлые транзакции клиентов и характеристики клиентов могут либо увеличить, либо уменьшить вероятность последующих покупок. И мы также знаем, что эти драйверы споосбы быть полезными, помогая нам предсказать, собирается ли клиент купать или нет. Эта информация может дать значительную информацию руководителям, которым поручено определить оптимальный объем ресурсов для проведения усилий по удержанию.
Эмпирический пример: Продолжительность сотрудничества с клиентом
Один из ключевых вопросов, на которые авторы хотят ответить в отношении продолжительности жизни, заключается в том, можем ли мы определить, какие клиенты имеют наибольшую вероятность быть активными в будущем. В условиях без контракта это означает оценку вероятности того, что клиент в настоящее время активен, учитывая его прошлую историю покупок. В случае контрактных установок это означает оценку ожидаемого срока службы клиентов, которые еще не получили недостатков, учитывая историческую информацию обо всех клиентах в прошлом (в том числе тех, кто уже отказался от сотрудничества). Это часто делается с использованием моделей Времени Ускореннного Отказа (англ. Accelerated Failure Time (AFT) Models) или Пропорциональной Опасности (англ. Proportional Hazards (PH) models). Поскольку данные, приведенные в этой главе, представляют собой неконтрактную установку (т. е. авторы не наблюдали непосредственно завершение сотрудничества с клиентами), их цель - определить вероятность того, что клиент активен, учитывая прошлую историю покупок клиента. Для этого нам необходимо иметь информацию о поведении транзакций каждого клиента, включая время первой покупки, время последней покупки и количество транзакций, которые произошли во время окна наблюдения. В наборе данных, приведенном в этой главе, авторы подробно описывали историю транзакций для каждого клиента. Просто нужно вычислить значения для каждой из трех требуемых переменных. В ходе этого примера можно определить следующее:
- Вероятность того, что клиент активен в конце конца наблюдений (12-го квартала).
Компания B2C хочет улучшить свою способность идентифицировать клиентов, которые, вероятно, будут активно участвовать в отношениях с фирмой. Случайная выборка из 500 клиентов из одной когорты была взята из базы данных клиентов. Информация, необходимая для модели авторов, включает следующий список переменных:
| Переменные | Описание |
|---|---|
| x | Количество транзакций данного клиента за все периоды времени. Здесь мы предполагаем, что это сумма переменной Purchase, где клиенты в наибольшей степени совершили 1 покупку за квартал |
| tx | Это время последней транзакции, то есть последний квартал, где наблюдалось Purchase == 1 |
| T | Общее время между первой покупкой и окончанием окна наблюдения, то есть 12 кварталов для всех клиентов |
В этом случае авторы не имели зависимую переменную, так как фактически не наблюдали отток клиентов. Вместо этого они использовали атрибуты информации о транзакции клиента для формирования вероятности того, что клиент активен. Во первых, в этом случае нам требуется количество транзакций, которые клиент имел в окне наблюдения (x), в данном примере - 12 кварталов. Чтобы упростить этот случай, предполагается, что клиенты покупают не более одного раза в любом квартале. Таким образом, при Purchase == 1 наблюдается как бы одну транзакция. Во-вторых, требуется, чтобы последний раз, когда у клиента была транзакция с фирмой (tx). В этом случае это последний квартал, где наблюдалось Purchase == 1. Наконец, также требуется продолжительность времени, когда клиент мог быть активным. Поскольку это когорта клиентов, которые сделали первые покупки в первом квартале, все они получают значение 12 для T.
Так как в сегменте B2C фирмы зачастую не имеют долгосрочных контрактов, то для построения модели продолжительности сотрудничества с клиентом без контрактных установок применяют подход BG/NBD (от англ. "Beta Gamma / Negative Binomial Distribution"), описанный в 2005 г.:
\[ L(r, \alpha, a, b|X=x, t_x, T) = \dfrac{B(a, b + x + 1)}{B(a, b)} \dfrac{\Gamma(r + x) \alpha ^r }{\Gamma(r)(\alpha + T) ^{r + x} } + \dfrac{B(a + 1, x)}{B(a, b)} \dfrac{\Gamma(r + x) \alpha ^r }{\Gamma(r)(\alpha + t_x) ^{r + x}} , \]
где B(˚) - функция бета-распределения,
G(˚) - функция гамма-распределения,
a и b - параметры функции бета-распределения,
r и \(\alpha\) - параметры функции гамма-распределения, и
x, tx, и T - данные по клиентам без контрактных установок от фирмы.
Описание в MS Excel данного подхода к построению модели BG/NBD, благодаря Брюсу Харди, имеется на странице Implementing the BG/NBD Model for Customer Base Analysis in Excel
Несложно заметить, что показатель tx соответствует признаку Recency из упоминавшейся выше модели RFM, а x - Frequency. В стороне остается только Monetary Value, сумма сделок order_quantity по каждому клиенту за весь период наблюдений T, т.е. за 12 кварталов. Далее мы рассчитаем недостающий показатель и полноценно применим эти сведения для прогнозирования.
Бельгийский исследователь Тобиас Вербеке предусмотрительно подготовил обозначенный авторами набор данных в пакете SMCRM - customerRetentionLifetimeDuration, содержащий сведения о продолжительности сотрудничества клиентов с фирмой. Однако мы можем его получить самостоятельно прямо исполнив команды SQL из приведенного кода SAS благодаря пакету sqldf в составе R.
# P(Alive)
palive_x <- sqldf("select customer, sum(purchase) as x
from customerRetentionTransactions
group by customer order by customer;")
palive_tx <- sqldf("select customer, max(quarter) as tx
from customerRetentionTransactions
where purchase = 1 group by customer order by customer;")
palive_T <- sqldf("select customer, max(quarter) as T, sum(order_quantity) as M
from customerRetentionTransactions group by customer order by customer;")
palive_xtx <- sqldf("select a.*, b.tx
from palive_x a left join palive_tx b
on a.customer = b.customer;")
customerRetentionLTDuration <- sqldf("select distinct a.*, b.T, b.M
from palive_xtx a left join palive_T b
on a.customer = b.customer order by customer;")
remove(palive_x, palive_tx, palive_T, palive_xtx)
# Description of an empirical distribution for non-censored data using Cullen & Frey graph
library('fitdistrplus')## Loading required package: MASS##
## Attaching package: 'MASS'## The following object is masked from 'package:dplyr':
##
## select## Loading required package: survival##
## Attaching package: 'survival'## The following object is masked from 'package:caret':
##
## clusterfitdistrplus::descdist(customerRetentionLTDuration$x, boot = 500, discrete = FALSE)
## summary statistics
## ------
## min: 1 max: 12
## median: 6
## mean: 6.356
## estimated sd: 4.022141
## estimated skewness: 0.2090908
## estimated kurtosis: 1.564647x <- fitdist((customerRetentionLTDuration$x / max(customerRetentionLTDuration$x)),
"beta", method = "mme", discrete = FALSE)
plot(x)
writeLines("\n Beta distribution of `customerRetentionLTDuration$x`")##
## Beta distribution of `customerRetentionLTDuration$x`gofstat(x)## Goodness-of-fit statistics
## 1-mme-beta
## Kolmogorov-Smirnov statistic 0.222000
## Cramer-von Mises statistic 2.957749
## Anderson-Darling statistic Inf
##
## Goodness-of-fit criteria
## 1-mme-beta
## Akaike's Information Criterion -Inf
## Bayesian Information Criterion -Inffitdistrplus::descdist(customerRetentionLTDuration$tx, boot = 500, discrete = FALSE)
## summary statistics
## ------
## min: 1 max: 12
## median: 9
## mean: 7.62
## estimated sd: 4.218435
## estimated skewness: -0.3335277
## estimated kurtosis: 1.515827(x <- fitdist((customerRetentionLTDuration$tx / max(customerRetentionLTDuration$tx)),
"beta", method = "mme", discrete = FALSE))## Fitting of the distribution ' beta ' by matching moments
## Parameters:
## estimate
## shape1 0.5583549
## shape2 0.3209442plot(x)
writeLines("\n Beta distribution of `customerRetentionLTDuration$x`")##
## Beta distribution of `customerRetentionLTDuration$x`gofstat(x)## Goodness-of-fit statistics
## 1-mme-beta
## Kolmogorov-Smirnov statistic 0.348000
## Cramer-von Mises statistic 7.502301
## Anderson-Darling statistic Inf
##
## Goodness-of-fit criteria
## 1-mme-beta
## Akaike's Information Criterion -Inf
## Bayesian Information Criterion -InfНезависимые переменные x, tx, M из нового набора данных customerRetentionLTDuration распределены по непрерывному бета-распределению
Теперь у нас в распоряжении полный набор данных для построения модели продолжительности сотрудничества с клиентом и при помощи пакета Buy ’Til You Die - BTYD. Должен заметить, что в пакете SAS нельзя напрямую рассчитать эти параметры.
Вероятность активности на момент времени T клиента без контрактных установок рассчитывается по формуле:
\[ P(Alive \enspace | \enspace r, \alpha, a, b, x, t_x, T) = 1 / \left\{ 1 + \dfrac{a}{b + x} \left( \dfrac{\alpha + T }{\alpha + t_x }\right) ^{r + x} \right\} \]
# Customers without contractual settings : Buy ’Til You Die - Beta Gamma / Negative Binomial Distribution
# http://srepho.github.io/CLV/CLV
library('BTYD') # Implementing Buy 'Til You Die Models## Loading required package: hypergeocal.cbs <- customerRetentionLTDuration %>%
dplyr::select(x, tx, `T`) %>% # calibration period CBS (customer by sufficient statistic)
dplyr::rename(x = x, t.x = tx, T.cal = `T`)
params <- BTYD::bgnbd.EstimateParameters(cal.cbs)
LL <- BTYD::bgnbd.cbs.LL(params, cal.cbs)
params <- c(params, LL)
names(params) <- c("r", "alpha", "a", "b", "LL (Log-likelihood)")
# Parameters from the book
params0 <- c(126.5368069, 159.8644711, 0.512114268, 3.328751451, -4676.1)
names(params0) <- c("r", "alpha", "a", "b", "LL (Log-likelihood)")
writeLines("\n BG/NBD Model: Parametres of AR Prediction \n")##
## BG/NBD Model: Parametres of AR Predictionparams## r alpha a b LL (Log-likelihood)
## 7818.4528713 9855.5660924 0.6128167 4.0932195 -4670.0651703writeLines("\n BG/NBD Model: Parametres of V. Kumar, J. Andrew Petersen Prediction \n")##
## BG/NBD Model: Parametres of V. Kumar, J. Andrew Petersen Predictionparams0## r alpha a b LL (Log-likelihood)
## 126.5368069 159.8644711 0.5121143 3.3287515 -4676.1000000P_Alive <- customerRetentionLTDuration %>%
mutate(p = 1/(1+(params["a"]/(params["b"] + x))*
((params["alpha"] + `T`)/(params["alpha"] + tx))^(params["r"] + x)))
utils::data(customerRetentionLifetimeDuration, package = 'SMCRM')
P_Alive0 <- customerRetentionLifetimeDuration %>%
mutate(p = 1/(1+(params0["a"]/(params0["b"] + x))*
((params0["alpha"] + `T`)/(params0["alpha"] + tx))^(params0["r"] + x)))
writeLines("\n BG/NBD Model: Association of AR Prediction vs. V. Kumar, J. Andrew Petersen Prediction \n")##
## BG/NBD Model: Association of AR Prediction vs. V. Kumar, J. Andrew Petersen Predictioncaret::confusionMatrix(data = ifelse(P_Alive$p > 0.5, "1", "0") %>% factor,
reference = ifelse(P_Alive0$p > 0.5, "1", "0") %>% factor,
dnn = c("AR Prediction", "V. Kumar, J. Andrew Petersen Prediction"),
positive = "1", mode = "everything")## Confusion Matrix and Statistics
##
## V. Kumar, J. Andrew Petersen Prediction
## AR Prediction 0 1
## 0 249 2
## 1 0 249
##
## Accuracy : 0.996
## 95% CI : (0.9856, 0.9995)
## No Information Rate : 0.502
## P-Value [Acc > NIR] : <2e-16
##
## Kappa : 0.992
## Mcnemar's Test P-Value : 0.4795
##
## Sensitivity : 0.992
## Specificity : 1.000
## Pos Pred Value : 1.000
## Neg Pred Value : 0.992
## Precision : 1.000
## Recall : 0.992
## F1 : 0.996
## Prevalence : 0.502
## Detection Rate : 0.498
## Detection Prevalence : 0.498
## Balanced Accuracy : 0.996
##
## 'Positive' Class : 1
## customerRetentionLTDuration$p <- P_Alive0$p
remove(params, P_Alive, params0, P_Alive0)Хотя в моих расчетах, которые производились не в MS Excel, а в специализированном пакете BTYD для R, получены неcколько иные параметры бета- и гамма- распределений. Возможно из-за разных алгоритмов оптимизации, во всяком случае логарифмическое правдоподобие (англ. “Log-likelihood [LL]”) у них практически совпадают. Схоже и попадание в классы по авторскому разбиению. Разница лишь в том, что по авторской модели BG/NBD клиенты которые совершили лишь две покупки (в начале окна наблюдения - в 1 квартале и почти за год до его завершения - в 9 квартале) по-прежнему считаются активными, а по более строгому алгоритму оптимизации нужно совершить между этими двумя крайними трансакциями хотя бы еще одну покупку. Это представляется более разумным при построении модели продолжительности сотрудничества с клиентом, чем опора только на две точки взаимодействия с фирмой.
Как это использовать?
Такой подход к моделированию продолжительности сотрудничества с клиентом в условия отсутстия контрактных установок представляется крайне полезным для менеджемента, давая ему возможность оптимально управлять расходами на удержание клиентов.
Эмпирический пример: величина заказа
Многие фирмы поняли, что недостаточно просто сосредоточиться только на попытке заставить клиента выкупить. Фирма также должна обратить внимание на то, каким размером может оказать покупка. Исследования в области маркетинга показали, что стоимость заказа может быть ценным предиктором в будущей стоимости клиента для фирмы - или, по крайней мере, оправдать сумму денег, затрачиваемую на усилия по удержанию клиентов. Таким образом, может быть полезно понять драйверы величины заказов и, в свою очередь, иметь возможность прогнозировать ожидаемую величину заказов каждого потенциального клиента при условии, что заказ будет иметь место. В конце этого примера мы должны иметь возможность сделать следующее:
Определить драйверы величину заказа (по стоимости).
Предсказать ожидаемую величину заказа для каждого клиента.
Измерить предиктивную точность модели.
Информация, необходимая для этой модели, включает следующий список переменных:
| Переменные | Описание |
|---|---|
| Зависимая переменная | |
| Purchase | если 1, когда покупатель приобрел в данном квартале, 0, если в этом квартале не произошло покупок |
| Order_quantity | Долларовая стоимость покупок в данном квартале |
| Предикторы | |
| imr_purchase или Lambda (\(\lambda\)) | Рассчитанное обратное отношение Миллса из модели повторного заказа клиента |
| Lag_Purchase | 1, если клиент приобрел в предыдущем квартале, 0, если в предыдущем квартале покупка не произошла |
| Avg_Order_Quantity | Средняя долларовая стоимость покупок во всех предыдущих кварталах |
| Ret_Expense | Доллары потраченные на маркетинговые усилия по удержанию этого клиента в данном квартале |
| Ret_Expense_SQ | Квадрат затрат на маркетинговые усилияпо удержанию этого клиента в данном квартале |
| Gender | 1, если клиент является мужчиной, 0, если клиент является женщиной |
| Married | 1, если клиент женат, 0, если клиент не состоял в браке |
| Income | 1, если доход < 30 000 долл. США, 2; если 30 001 долл. США < доход < 45 000 долл. США; 3, если 45 001 долл. США < доход < 60 000 долл. США; 4, если 60 001 долл. США < доход < 75 000 долл. США; 5, если 75 001 долл. США < доход < 90 000 долл. США; 6, если доход > 90 001 долл. США |
| First_Purchase | Стоимость первой покупки, сделанной клиентом в 1 квартале |
| Loyalty | 1, если клиент является членом программы лояльности, 0, если нет |
Из вышеописанных перменных мы видим, что для определения драйверов величины заказов нам нужно иметь две зависимые переменные: Purchase and Order_Quantity. Это связано с тем, что ожидаемая величина заказа получается из следующего уравнения:
\[ E(Order \enspace Quantity) = P(Purchase = 1) * E(Order \text _ quantity | Purchase = 1) \]
Смещение выборки является проблемой, которая распространена во многих маркетинговых проблемах и должна быть статистически учтена во многих процессах моделирования. В этом случае у клиента есть выбор: покупать или не покупать, прежде чем принимать решение о покупке. Если бы мы проигнорировали этот выбор, мы бы смещали оценки от модели, и у нас были бы менее точные предсказания для значения Order_Quantity. Чтобы учесть эту проблему, мы должны иметь возможность предсказать величину как вероятности покупки (аналогично тому, что мы сделали для первого эмпирического примера в этой главе), так и ожидаемого значения Order_Quantity, учитывая, что клиент должен сделать покупку. Важно отметить, что мы не можем просто запускать две модели независимо, так как, вероятно, существует корреляция между условиями ошибки двух моделей. Таким образом, авторы указывают на необходимость использовать структуру моделирования, которая может одновременно оценивать коэффициенты двух моделей или, по крайней мере, учитывать соотношение между Order_Quantity и Purchase. Для этого мы используем двухэтапную структуру моделирования, аналогичную описанной ранее в третьей главе. Первым этапом идет формирование пробит-модели, дающей нам обратное отношение Миллса (\(\lambda\)).
Первый этап построения и верификации величины заказа
Probit
# Fit Probit Model for Customer Repurchase by Authors
Ch04.probit <- glm(purchase ~ lpurchase + avg_order_quantity + ret_expense + ret_expense_sq +
gender + married + income + first_purchase + loyalty,
data = customerRetentionRepurchase, family = binomial(link = 'probit'))
summary(Ch04.probit)##
## Call:
## glm(formula = purchase ~ lpurchase + avg_order_quantity + ret_expense +
## ret_expense_sq + gender + married + income + first_purchase +
## loyalty, family = binomial(link = "probit"), data = customerRetentionRepurchase)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.7871 -0.2836 -0.0787 0.3877 3.2420
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.0146293 0.1262108 -23.886 < 2e-16 ***
## lpurchase 1.7553141 0.0657516 26.696 < 2e-16 ***
## avg_order_quantity 0.0082081 0.0003723 22.049 < 2e-16 ***
## ret_expense 0.0681527 0.0056287 12.108 < 2e-16 ***
## ret_expense_sq -0.0014927 0.0001218 -12.258 < 2e-16 ***
## gender -0.0938153 0.0523214 -1.793 0.07296 .
## married -0.0052075 0.0605241 -0.086 0.93143
## income 0.0867476 0.0179195 4.841 1.29e-06 ***
## first_purchase 0.0007990 0.0005667 1.410 0.15854
## loyalty 0.1543215 0.0565840 2.727 0.00639 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 7620.8 on 5499 degrees of freedom
## Residual deviance: 2863.9 on 5490 degrees of freedom
## AIC: 2883.9
##
## Number of Fisher Scoring iterations: 6writeLines(sprintf("-2 Log L of Intercept and Only Covariates: %.3f", -2 * logLik(Ch04.probit)[1]))## -2 Log L of Intercept and Only Covariates: 2863.895writeLines(sprintf(" AIC (smaller is better): %.3f", extractAIC(Ch04.probit)[2]))## AIC (smaller is better): 2883.895writeLines("\n Wald test of predictors")##
## Wald test of predictorscar::Anova(Ch04.probit, type="II", test="Wald")## Analysis of Deviance Table (Type II tests)
##
## Response: purchase
## Df Chisq Pr(>Chisq)
## lpurchase 1 712.6831 < 2.2e-16 ***
## avg_order_quantity 1 486.1571 < 2.2e-16 ***
## ret_expense 1 146.6039 < 2.2e-16 ***
## ret_expense_sq 1 150.2561 < 2.2e-16 ***
## gender 1 3.2151 0.072964 .
## married 1 0.0074 0.931434
## income 1 23.4349 1.292e-06 ***
## first_purchase 1 1.9881 0.158539
## loyalty 1 7.4382 0.006386 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1writeLines("\n Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")##
## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04.probit) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity ## lpurchase avg_order_quantity ret_expense ret_expense_sq gender married
## 1.429719 1.402097 14.666982 14.604080 1.015471 1.006516
## income first_purchase loyalty
## 1.023425 1.009566 1.008419writeLines("\n Probit Model: Association of Predicted Probabilities and Observed Responses \n")##
## Probit Model: Association of Predicted Probabilities and Observed Responsesprob <- predict(Ch04.probit, newdata = customerRetentionRepurchase, type = "response")
caret::confusionMatrix(data = ifelse(prob > 0.5, "1", "0") %>% factor,
reference = customerRetentionRepurchase$purchase %>% factor,
positive = "1", mode = "everything")## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 2485 188
## 1 337 2490
##
## Accuracy : 0.9045
## 95% CI : (0.8965, 0.9122)
## No Information Rate : 0.5131
## P-Value [Acc > NIR] : < 2.2e-16
##
## Kappa : 0.8092
## Mcnemar's Test P-Value : 1.052e-10
##
## Sensitivity : 0.9298
## Specificity : 0.8806
## Pos Pred Value : 0.8808
## Neg Pred Value : 0.9297
## Precision : 0.8808
## Recall : 0.9298
## F1 : 0.9046
## Prevalence : 0.4869
## Detection Rate : 0.4527
## Detection Prevalence : 0.5140
## Balanced Accuracy : 0.9052
##
## 'Positive' Class : 1
## Качество решения классификационной задачи повторной покупки довольно высокое.
Probit (AR Version)
Вместе с тем очевидно, что предикторы married и first_purchase не значимы в пробит-регрессии, что отмечают даже авторы. Недалеко от них ушел по значимости фактор gender. Также вместо полученной со смещением переменной avg_order_quantity я буду использовать корректно рассчитанную lavg_order_quantity. Кроме того, проверка по VIF демонстрирует большие значения по признакам acq_expense и acq_expense_sq. Однако, принимая во внимание проявление закона убывающей доходности мы должны оставить оба мультиколлинеарных предиктора в этой модели. Теперь бинарную модель мы проверяем более тщательно, оставля только значимые предикторы.
# Fit Probit Regression Model for Customer Repurchase (Improved)
uno = 'probit'
set.seed(2018)
(Ch04pr.AR <- train(factor(purchase) ~ lpurchase + lavg_order_quantity + ret_expense + ret_expense_sq +
income + loyalty, metric = 'Kappa',
data = customerRetentionRepurchase, method = "glm", family = binomial(link = uno)))#,## Generalized Linear Model
##
## 5500 samples
## 6 predictor
## 2 classes: '0', '1'
##
## No pre-processing
## Resampling: Bootstrapped (25 reps)
## Summary of sample sizes: 5500, 5500, 5500, 5500, 5500, 5500, ...
## Resampling results:
##
## Accuracy Kappa
## 0.8913836 0.7831376 # trControl = trainControl(method = "none", number = 1)))
summary(Ch04pr.AR)##
## Call:
## NULL
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.7327 -0.3135 -0.1194 0.5090 2.9424
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.6538486 0.0934889 -28.387 < 2e-16 ***
## lpurchase 2.2815968 0.0664053 34.359 < 2e-16 ***
## lavg_order_quantity 0.0032023 0.0003307 9.682 < 2e-16 ***
## ret_expense 0.0655880 0.0052312 12.538 < 2e-16 ***
## ret_expense_sq -0.0014362 0.0001132 -12.689 < 2e-16 ***
## income 0.1258149 0.0166998 7.534 4.92e-14 ***
## loyalty 0.1551696 0.0526089 2.949 0.00318 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 7620.8 on 5499 degrees of freedom
## Residual deviance: 3317.6 on 5493 degrees of freedom
## AIC: 3331.6
##
## Number of Fisher Scoring iterations: 6# Odds Ratio Estimates and 95% CI
writeLines("\n Odds Ratio Estimates and 95% CI")##
## Odds Ratio Estimates and 95% CIcar::Confint(Ch04pr.AR$finalModel) %>%
exp() %>%
arm::pfround(digits = 3)## Estimate 2.5 % 97.5 %
## (Intercept) 0.070 0.058 0.084
## lpurchase 9.792 8.595 11.181
## lavg_order_quantity 1.003 1.003 1.004
## ret_expense 1.068 1.057 1.079
## ret_expense_sq 0.999 0.998 0.999
## income 1.134 1.097 1.172
## loyalty 1.168 1.053 1.295# Logistic regression diagnostics
writeLines("\n Wald test of predictors")##
## Wald test of predictorscar::Anova(Ch04pr.AR$finalModel, type="II", test="Wald")## Analysis of Deviance Table (Type II tests)
##
## Response: .outcome
## Df Chisq Pr(>Chisq)
## lpurchase 1 1180.5155 < 2.2e-16 ***
## lavg_order_quantity 1 93.7488 < 2.2e-16 ***
## ret_expense 1 157.1980 < 2.2e-16 ***
## ret_expense_sq 1 161.0176 < 2.2e-16 ***
## income 1 56.7599 4.924e-14 ***
## loyalty 1 8.6995 0.003183 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1writeLines("\n Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")##
## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04pr.AR$finalModel) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity## lpurchase lavg_order_quantity ret_expense ret_expense_sq income loyalty
## 1.623466 1.583693 14.571254 14.517482 1.022493 1.004603writeLines("\n Variable Importance for Model \n")##
## Variable Importance for Modelcaret::varImp(Ch04pr.AR) %>% .$importance %>% print.AsIs()## Overall
## lpurchase 100.00000
## lavg_order_quantity 21.43612
## ret_expense 30.52732
## ret_expense_sq 31.00937
## income 14.59582
## loyalty 0.00000# Create the scatter plots Probit versus model predictors
predictors <- Ch04pr.AR$coefnames
Ch04pr.AR$trainingData %>%
dplyr::select(one_of(predictors)) %>%
mutate(link = predict(Ch04pr.AR$finalModel, newdata = customerRetentionRepurchase, type = "link")) %>%
gather(key = "predictors", value = "predictor.value", -link) %>%
ggplot(aes(predictor.value, link))+
geom_point(size = 0.05, alpha = 0.05) +
geom_smooth(method = "loess") +
facet_wrap(~ predictors, scales = "free_x") +
ylab(stringr::str_to_title(uno))
# Plot matrix of statistical model diagnostics
GGally::ggnostic(Ch04pr.AR$finalModel, title = paste(paste(formula(Ch04pr.AR)[c(2, 1, 3)], collapse = " ")))## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
# wide variety of diagnostic plots for checking the quality of regression fit
# https://bookdown.org/jefftemplewebb/IS-6489/logistic-regression.html
car::influenceIndexPlot(Ch04pr.AR$finalModel)
writeLines("\n Improved Probit Model: Association of Predicted Probabilities and Observed Responses \n")##
## Improved Probit Model: Association of Predicted Probabilities and Observed Responsescaret::confusionMatrix(data = predict(Ch04pr.AR, newdata = customerRetentionRepurchase),
reference = customerRetentionRepurchase$purchase %>% factor,
positive = "1", mode = "everything")## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 2372 150
## 1 450 2528
##
## Accuracy : 0.8909
## 95% CI : (0.8824, 0.899)
## No Information Rate : 0.5131
## P-Value [Acc > NIR] : < 2.2e-16
##
## Kappa : 0.7823
## Mcnemar's Test P-Value : < 2.2e-16
##
## Sensitivity : 0.9440
## Specificity : 0.8405
## Pos Pred Value : 0.8489
## Neg Pred Value : 0.9405
## Precision : 0.8489
## Recall : 0.9440
## F1 : 0.8939
## Prevalence : 0.4869
## Detection Rate : 0.4596
## Detection Prevalence : 0.5415
## Balanced Accuracy : 0.8923
##
## 'Positive' Class : 1
## qplot(`Observed Classes`, `Predicted Classes`,
data=bind_cols(`Observed Classes`= factor(customerRetentionRepurchase$purchase),
`Predicted Classes` = predict(Ch04pr.AR, newdata = customerRetentionRepurchase)),
colour= `Observed Classes`, geom = c("boxplot", "jitter"),
main = "Predicted Classes vs. Observed Classes", xlab = "Observed Classes", ylab = "Predicted Classes")
Улучшенная пробит-регрессия вероятности повторной покупки хотя и снизила немного качества, получена без незначимых факторов gender и married, а также предиктора first_purchase, поэтому мне представляется более надежной, так как избавилась от этих малозначимых признаков и более устойчивой, так как модель построена бутстреп-методом - англ. bootstrap с 25-тью “псевдовыборок”.
Второй этап построения и верификации модели величины заказа
Переходим ко второму этапу модели величины заказа, которая использует в качестве предиктора результаты пробит-модели из первого этапа, обозначенное как обратное отношение Миллса (\(\lambda\)).
Linear
# Fit Linear Regression Model for Order quantity by Authors
# SAS Code: imr_acquisition = (pdf(’Normal’, xb_probit))/(probnorm(xb_probit));
xbeta <- predict(Ch04.probit, newdata = customerRetentionRepurchase, type = "link")
customerRetentionRepurchase <- customerRetentionRepurchase %>%
mutate(imr_purchase = dnorm(xbeta) / pnorm(xbeta)) # Cumulative normal pdf
(Ch04.linear <- lm(order_quantity ~ lpurchase + avg_order_quantity + ret_expense +
ret_expense_sq + gender + married + income + first_purchase + loyalty + imr_purchase,
data = filter(customerRetentionRepurchase, order_quantity > 0) )) %>%
summary##
## Call:
## lm(formula = order_quantity ~ lpurchase + avg_order_quantity +
## ret_expense + ret_expense_sq + gender + married + income +
## first_purchase + loyalty + imr_purchase, data = filter(customerRetentionRepurchase,
## order_quantity > 0))
##
## Residuals:
## Min 1Q Median 3Q Max
## -210.10 -46.08 -11.73 37.11 317.84
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -2.906e+02 2.896e+01 -10.034 < 2e-16 ***
## lpurchase 2.062e+02 1.738e+01 11.864 < 2e-16 ***
## avg_order_quantity 9.313e-01 3.643e-02 25.563 < 2e-16 ***
## ret_expense 3.064e+00 3.456e-01 8.865 < 2e-16 ***
## ret_expense_sq -7.451e-02 7.737e-03 -9.630 < 2e-16 ***
## gender 9.943e+00 2.664e+00 3.733 0.000193 ***
## married -2.110e+00 2.998e+00 -0.704 0.481619
## income 1.346e+01 9.706e-01 13.867 < 2e-16 ***
## first_purchase 2.650e-01 2.834e-02 9.350 < 2e-16 ***
## loyalty 1.026e+01 2.986e+00 3.437 0.000598 ***
## imr_purchase 1.133e+02 1.198e+01 9.459 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 67.31 on 2667 degrees of freedom
## Multiple R-squared: 0.4898, Adjusted R-squared: 0.4879
## F-statistic: 256 on 10 and 2667 DF, p-value: < 2.2e-16writeLines("Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04.linear) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity## lpurchase avg_order_quantity ret_expense ret_expense_sq gender married
## 8.784204 4.595564 20.114598 19.876307 1.048310 1.012157
## income first_purchase loyalty imr_purchase
## 1.114912 1.043600 1.065203 16.183954Авторы получили результаты, говорящие что регрессионная задача решена удовлетворительно. Мы видим, что \(\lambda\) является положительной и значимой. Можно её интерпретировать так, что существует потенциальная проблема смещения выбора, поскольку коэффициент ошибки нашего уравнения выбора положительно коррелирует с погрешностью нашего уравнения пробит-регрессии. Также видно, что все другие переменные модели величины заказов являются значимыми, за исключением Married, что означает, вероятно, обнаружение многие из драйверов величины заказа.
Linear (AR version)
Теперь попробуем исключить из линейной модели незначимый фактор married, а вместо полученной со смещением переменной avg_order_quantity использовать корректно рассчитанную lavg_order_quantity.
# Fit Linear Regression Model for Customer Order quantity (Improved)
uno = 'y_hat'
# Log Transformation of Order_Quantity
customerRetentionRepurchase <- customerRetentionRepurchase %>%
mutate(log_order_quantity = log(order_quantity))
set.seed(2018)
(Ch04ln.AR <- train(log_order_quantity ~ lpurchase + lavg_order_quantity + ret_expense + ret_expense_sq +
gender + income + first_purchase + imr_purchase,
data = filter(customerRetentionRepurchase, order_quantity > 0), method = "lm"))#,## Linear Regression
##
## 2678 samples
## 8 predictor
##
## No pre-processing
## Resampling: Bootstrapped (25 reps)
## Summary of sample sizes: 2678, 2678, 2678, 2678, 2678, 2678, ...
## Resampling results:
##
## RMSE Rsquared MAE
## 0.2616214 0.4851885 0.2078147
##
## Tuning parameter 'intercept' was held constant at a value of TRUE # trControl = trainControl(method = "none", number = 1)))
summary(Ch04ln.AR)##
## Call:
## lm(formula = .outcome ~ ., data = dat)
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.11559 -0.18070 -0.02235 0.17355 0.84368
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 5.236e+00 1.031e-01 50.814 < 2e-16 ***
## lpurchase 3.672e-03 6.490e-02 0.057 0.954893
## lavg_order_quantity 2.371e-04 1.191e-04 1.990 0.046694 *
## ret_expense -4.531e-03 1.308e-03 -3.465 0.000538 ***
## ret_expense_sq 7.776e-05 2.940e-05 2.645 0.008209 **
## gender 9.092e-02 1.016e-02 8.947 < 2e-16 ***
## income 5.070e-02 3.748e-03 13.529 < 2e-16 ***
## first_purchase 1.095e-03 1.087e-04 10.076 < 2e-16 ***
## imr_purchase -4.769e-01 4.297e-02 -11.097 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.2596 on 2669 degrees of freedom
## Multiple R-squared: 0.5, Adjusted R-squared: 0.4985
## F-statistic: 333.6 on 8 and 2669 DF, p-value: < 2.2e-16#Coefficient Estimates and 95% CI
writeLines("\n Coefficient Estimates and 95% CI")##
## Coefficient Estimates and 95% CIcar::Confint(Ch04ln.AR$finalModel) %>%
exp() %>%
arm::pfround(digits = 3)## Estimate 2.5 % 97.5 %
## (Intercept) 188.003 153.606 230.103
## lpurchase 1.004 0.884 1.140
## lavg_order_quantity 1.000 1.000 1.000
## ret_expense 0.995 0.993 0.998
## ret_expense_sq 1.000 1.000 1.000
## gender 1.095 1.074 1.117
## income 1.052 1.044 1.060
## first_purchase 1.001 1.001 1.001
## imr_purchase 0.621 0.571 0.675# Linear regression diagnostics
writeLines("\n Chisq test of predictors")##
## Chisq test of predictorscar::Anova(Ch04ln.AR$finalModel, type="II", test="Chisq")## Anova Table (Type II tests)
##
## Response: .outcome
## Sum Sq Df F value Pr(>F)
## lpurchase 0.000 1 0.0032 0.9548931
## lavg_order_quantity 0.267 1 3.9601 0.0466941 *
## ret_expense 0.809 1 12.0067 0.0005385 ***
## ret_expense_sq 0.472 1 6.9977 0.0082092 **
## gender 5.395 1 80.0511 < 2.2e-16 ***
## income 12.334 1 183.0242 < 2.2e-16 ***
## first_purchase 6.841 1 101.5181 < 2.2e-16 ***
## imr_purchase 8.299 1 123.1475 < 2.2e-16 ***
## Residuals 179.866 2669
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1writeLines("\n Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")##
## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04ln.AR$finalModel) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity## lpurchase lavg_order_quantity ret_expense ret_expense_sq gender income
## 8.237756 3.715779 19.357079 19.289543 1.025573 1.117416
## first_purchase imr_purchase
## 1.032449 13.990053writeLines("\n Variable Importance for Model \n")##
## Variable Importance for Modelcaret::varImp(Ch04ln.AR) %>% .$importance %>% print.AsIs()## Overall
## lpurchase 0.00000
## lavg_order_quantity 14.35131
## ret_expense 25.30044
## ret_expense_sq 19.21569
## gender 65.99249
## income 100.00000
## first_purchase 74.36904
## imr_purchase 81.95185# Create the scatter plots Linear Model versus model predictors
# https://stats.idre.ucla.edu/r/seminars/ggplot2_intro/
predictors <- Ch04ln.AR$trainingData %>% colnames(.) %>% .[-1]
Ch04ln.AR$trainingData %>%
rename(y_hat = `.outcome`) %>%
gather(key = "predictors", value = "predictor.value", -y_hat) %>%
ggplot(aes(predictor.value, y_hat))+
geom_point(size = 0.5, alpha = 0.5) +
geom_smooth(method = "loess") +
facet_wrap(~ predictors, scales = "free_x") +
ylab(stringr::str_to_title(uno))
# Plot matrix of statistical model diagnostics
GGally::ggnostic(Ch04ln.AR$finalModel, title = paste(paste(formula(Ch04ln.AR)[c(2, 1, 3)], collapse = " ")))## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
# wide variety of diagnostic plots for checking the quality of regression fit
# https://bookdown.org/jefftemplewebb/IS-6489/linear-regression.html
car::influenceIndexPlot(Ch04ln.AR$finalModel)
Исключение из модели факторов married и даже loyalty не нанесло какого-либо вреда качеству модели. Однако избавление от смещения по независимой переменной avg_order_quantity понизило качество линейной модели. Чтобы его поднять пришлось прибегнуть к логарифмированию зависимой переменной order_quantity и независимой lavg_order_quantity, что часто применяется в эконометрических моделях на стоимостных показателях, имеющих склонность к лог-нормальному распределению.
Как это использовать?
Авторы нашли, что Lag_Purchase положительна, предполагая, что покупатели, купившие в предыдущем квартале, с большей вероятностью потратят также в текущем квартале. Также обнаружено, что Avg_Order_Quantity как и Lag_Avg_Order_Quantity также является положительным, предполагая, что чем выше средние значения прошлые величины заказов клиента, тем выше текущее значение значение. Очевидно, что Ret_Expense имеет положителеный коэфициент с уменьшающимся возвратом, как отмечено положительным коэффициентом на Ret_Expense и отрицательным коэффициент для Ret_Expense_SQ. Это означает, что маркетинговые усилия, направленные на сохранение и построение отношений с клиентом, заставляют клиента приобретать больше, лишь до определенной степени. Затем, после достижения некоторого порога, маркетинговые усилия фактически снижают стоимость покупки в среднем. Вероятно, это связано с тем, что чрезмерное общение с клиентами может часто напрягать клиентов и подвергать эрозии отношения между ними и фирмой. Авторы обнаружили, что несколько характеристик клиента являются положительными (Income, First_Purchase), давая менеджерам вполне разумную мысль о том, что клиенты, которые имеют более высокий доход, как впрочем имеющие более высокую стоимость первой покупки, как правило, имеют большую величину заказа.
Следующий шаг - предсказать значение Order_Quantity, чтобы увидеть, насколько авторская модель совпадает с фактическими значениями.
# Computing the Mean Absolute Deviation (MAD) and Mean Absolute Percent Error (MAPE)
with(customerRetentionRepurchase, {
# pred_oq <- predict(Ch04pr.AR$finalModel, newdata = customerRetentionRepurchase, type = "link") %>% pnorm() *
# exp(predict(Ch04ln.AR$finalModel, newdata = customerRetentionRepurchase))
pred_oq <- predict(Ch04.probit, newdata = customerRetentionRepurchase, type = "link") %>% pnorm() *
predict(Ch04.linear, newdata = customerRetentionRepurchase)
# mean_order_quantity
writeLines(sprintf("Mean of Order_Quantity: %.2f долл.", mean(customerRetentionRepurchase$order_quantity)))
# mad = mean(abs(first_purchase - pred_oq));
writeLines(sprintf("Mean Absolute Deviation (MAD): %.2f долл.", mean(abs(order_quantity - pred_oq))))
# mad1 = mean(abs(order_quantity - mean(order_quantity));
mad1 <- mean(abs(order_quantity - mean(order_quantity)))
writeLines(sprintf("Naive Mean Absolute Deviation (MAD1): %.2f долл.", mad1))
})## Mean of Order_Quantity: 129.10 долл.
## Mean Absolute Deviation (MAD): 44.04 долл.
## Naive Mean Absolute Deviation (MAD1): 133.71 долл.Поскольку значительное количество клиентов не заказывало ещеквартально повторные заказы, то метрику MAPE рассчитать авторам не удалось. Среднее значение по всей выборочной совокупности заказов (без первого квартала) составило 129.10 долл. Этот показатель авторы применили в качестве наивного прогноза. Созданная ими модель величины заказов оказалось заметно аккуратнее наивной модели среднего, у которого MAD1 = 133.71 долл.
Эмпирический пример: перекрестные продажи
Перекрестные продажи (англ. “Cross-buying”) - это наиболее распространенная технология, используемая компаниями для увеличения числа случаев повторного приобретения, величины заказа и доходов компаний. После того, как компании создали определенный уровень лояльности с существующими клиентами, эти клиенты с большей вероятностью будут перекрестно покупать у компании.
Еще один ключевой вопрос, на который авторы книги хотели ответить в отношении удержания клиентов, заключается в том, можно ли определить, какие клиенты имеют наивысшую вероятность перекрестых продаж в нескольких категориях. Для этого сначала нужно знать, какие текущие клиенты фактически приобретали в нескольких категориях, когда они совершили покупку.
В наборе данных, представленном в этой главе, имеется переменная Crossbuy, которая идентифицирует, сколько категорий продуктов покупает покупатель за определенный период времени. Также предоставляется набор драйверов, которые, вероятно, помогут объяснить решение клиента о перекрестной покупке. В конце этого примера читатели смогут сделать следующее:
Определить драйверы поведения при перекрестных покупок клиента.
Интерпретировать оценки параметров из модели перекрестной покупки.
Предсказать может ли клиент перекрестно купить или нет.
Определить предиктивную точность модели перекрестной покупки.
Компания B2C хочет понять, какие клиенты, скорее всего, перекрестно покупают за данный период времени. Это важно знать, поскольку многие исследования показали, что клиенты, покупающие по нескольким категориям, с большей вероятностью будут более прибыльными, чем покупатели, которые покупают меньшее количество категорий. Случайная выборка из 500 клиентов из одной когорты была взята из базы данных клиентов. Информация, необходимая для нашей модели, включает следующий список переменных:
| Переменные | Описание |
|---|---|
| Зависимая переменная | |
| Crossbuy | Количество различных категорий товаро / услуг, приобретенных в данном квартале |
| Предикторы | |
| Lag_Purchase | 1, если клиент приобрел в предыдущем квартале, 0, если в предыдущем квартале покупка не произошла |
| Lag_Crossbuy | Количество различных категорий товаров / услуг, приобретенных в предыдущем квартале |
| Ret_Expense | Доллары потраченные на маркетинговые усилия по удержанию этого клиента в данном квартале |
| Ret_Expense_SQ | Квадрат затрат на маркетинговые усилияпо удержанию этого клиента в данном квартале |
| Gender | 1, если клиент является мужчиной, 0, если клиент является женщиной |
| Married | 1, если клиент женат, 0, если клиент не состоял в браке |
| Income | 1, если доход < 30 000 долл. США, 2; если 30 001 долл. США < доход < 45 000 долл. США; 3, если 45 001 долл. США < доход < 60 000 долл. США; 4, если 60 001 долл. США < доход < 75 000 долл. США; 5, если 75 001 долл. США < доход < 90 000 долл. США; 6, если доход > 90 001 долл. США |
| First_Purchase | Стоимость первой покупки, сделанной клиентом в 1 квартале |
| Loyalty | 1, если клиент является членом программы лояльности, 0, если нет |
В этом случае автору упоминают о дискретной зависимлй переменной (Crossbuy), которая сообщает сколько категорий покупает покупатель в данном квартале. Чтобы понять вероятность перекрестного покупки, следует преобразовать эту дискретную переменную в двоичную переменную. Авторы делали это, устанавливая CB равным 1, когда Crossbuy > 1 и CB равны 0 в противном случае. Также имеется девять независимых переменных, которые, по мнению авторов, станут драйверами поведения повторной покупки.
Авторы полагали, что поведение клиентов на транзакциях в прошлом, скорее всего, объяснит поведение покупателей с перекрестными покупками. В результате в этом примере авторы использовали несколько отложенных переменных, т.е. взятых с лагом, в качестве независимых переменных. Во-первых, имеется информация о том, приобрел ли покупатель в предыдущем квартале (Lag_Purchase). Также имеется переменная для количества категорий товаров, приобретенных покупателем в предыдущем квартале (Lag_Crossbuy). Эти две переменные могут быть получены путем взятия стоимости покупки / cross-buy с отставание в один месяц, отметив, что одно наблюдение будет потеряно для каждого клиента. В этом случае мы используем однопериодное (квартальное) отставание для обеих переменных. Во-вторых, имеется среднеквартальное количество прошлых заказов (Avg_Order_Quantity). В этом случае значение для среднего количества заказа является средним значением переменной Order_Quantity во всех кварталах до текущего периода времени. В-третьих, есть информация сколько долларов фирма потратила на каждого клиента (Ret_Expense) за каждый период времени и квадрат значения этой переменной (Ret_Expense_SQ). Авторы хотели использовать как линейные, так и квадратичные термины, так как ожидали, что для каждого дополнительного доллара, потраченного на усилия по удержанию для данного клиента, будет уменьшаться возврат к стоимости этого доллара. Наконец, поскольку фокусная фирма этого примера является фирмой B2C, остальные пять переменных являлись социально-демографическими характеристиками клиентов. К ним относятся Gender клиента, является ли клиент Married, Income клиента, стоимость первой покупки клиента (First_Purchase) и является ли клиент членом программы лояльности (Loyalty).
Во-первых, авторы смоделировали вероятность того, что клиент будет перекрестно покупать в данный период времени. Поскольку зависимая переменная (CB) является бинарной, авторы остановились на логистической регрессии для оценки модели. Авторы упоминали, что могли бы также выбрать пробит-модель и в целом добиться тех же результатов. В этом случае переменная y является CB, а предикторы представляют 10 независимых переменных в базе данных. Следует также выбирать только те случаи, когда покупка произошла, так как фирмы заинтересованы в том, чтобы клиенты перекрестно покупали в условиях покупки. Это дает нам 2678 наблюдений для построения этой модели.
Построение и верификация модели перекрестных продаж
Logit
# # Fit Logistic Regression Model for Customer Crossbuy by Authors
Ch04.cb <- glm(cb ~ lpurchase + lcrossbuy + avg_order_quantity + ret_expense + ret_expense_sq +
gender + married + income + first_purchase + loyalty,
data = filter(customerRetentionRepurchase, purchase == 1), family = binomial(link = 'logit'))
summary(Ch04.cb)##
## Call:
## glm(formula = cb ~ lpurchase + lcrossbuy + avg_order_quantity +
## ret_expense + ret_expense_sq + gender + married + income +
## first_purchase + loyalty, family = binomial(link = "logit"),
## data = filter(customerRetentionRepurchase, purchase == 1))
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.5888 -0.7894 0.2013 0.8016 2.6374
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -9.0193030 0.5017960 -17.974 < 2e-16 ***
## lpurchase 1.7276427 0.3953724 4.370 1.24e-05 ***
## lcrossbuy 0.1794972 0.0440364 4.076 4.58e-05 ***
## avg_order_quantity 0.0102792 0.0008769 11.722 < 2e-16 ***
## ret_expense 0.0434174 0.0098177 4.422 9.76e-06 ***
## ret_expense_sq -0.0008815 0.0002206 -3.995 6.46e-05 ***
## gender 0.2904985 0.0976352 2.975 0.00293 **
## married 0.1858900 0.1111050 1.673 0.09431 .
## income 0.2466805 0.0356570 6.918 4.58e-12 ***
## first_purchase 0.0246237 0.0012455 19.770 < 2e-16 ***
## loyalty 0.2686608 0.1083036 2.481 0.01312 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 3711.8 on 2677 degrees of freedom
## Residual deviance: 2605.6 on 2667 degrees of freedom
## AIC: 2627.6
##
## Number of Fisher Scoring iterations: 5writeLines(sprintf("-2 Log L of Intercept and Only Covariates: %.3f", -2 * logLik(Ch04.cb)[1]))## -2 Log L of Intercept and Only Covariates: 2605.642writeLines(sprintf(" AIC (smaller is better): %.3f", extractAIC(Ch04.cb)[2]))## AIC (smaller is better): 2627.642# Odds Ratio Estimates and 95% CI
writeLines("\n Odds Ratio Estimates and 95% CI")##
## Odds Ratio Estimates and 95% CIcar::Confint(Ch04.cb) %>%
exp() %>%
arm::pfround(digits = 3)## Estimate 2.5 % 97.5 %
## (Intercept) 0.000 0.000 0.000
## lpurchase 5.627 2.712 12.969
## lcrossbuy 1.197 1.098 1.305
## avg_order_quantity 1.010 1.009 1.012
## ret_expense 1.044 1.025 1.065
## ret_expense_sq 0.999 0.999 1.000
## gender 1.337 1.104 1.619
## married 1.204 0.969 1.498
## income 1.280 1.194 1.373
## first_purchase 1.025 1.022 1.027
## loyalty 1.308 1.058 1.618writeLines("\n Wald test of predictors")##
## Wald test of predictorscar::Anova(Ch04.cb, type="II", test="Wald")## Analysis of Deviance Table (Type II tests)
##
## Response: cb
## Df Chisq Pr(>Chisq)
## lpurchase 1 19.0939 1.244e-05 ***
## lcrossbuy 1 16.6147 4.580e-05 ***
## avg_order_quantity 1 137.4149 < 2.2e-16 ***
## ret_expense 1 19.5572 9.763e-06 ***
## ret_expense_sq 1 15.9634 6.458e-05 ***
## gender 1 8.8527 0.002927 **
## married 1 2.7993 0.094307 .
## income 1 47.8609 4.576e-12 ***
## first_purchase 1 390.8717 < 2.2e-16 ***
## loyalty 1 6.1535 0.013115 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1writeLines("\n Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")##
## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04.cb) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity## lpurchase lcrossbuy avg_order_quantity ret_expense ret_expense_sq gender
## 1.132613 1.128993 1.243020 11.911055 11.848060 1.023444
## married income first_purchase loyalty
## 1.016901 1.093221 1.165158 1.024614writeLines("\n Crossbuy Probability (Logit): Association of Predicted Probabilities and Observed Responses \n")##
## Crossbuy Probability (Logit): Association of Predicted Probabilities and Observed Responsesprob <- predict(Ch04.cb, newdata = filter(customerRetentionRepurchase, purchase == 1), type = "response")
caret::confusionMatrix(data = ifelse(prob > 0.5, "1", "0") %>% factor,
reference = filter(customerRetentionRepurchase, purchase == 1) %>% .$cb %>% factor,
positive = "1", mode = "everything")## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 988 294
## 1 329 1067
##
## Accuracy : 0.7674
## 95% CI : (0.7509, 0.7833)
## No Information Rate : 0.5082
## P-Value [Acc > NIR] : <2e-16
##
## Kappa : 0.5344
## Mcnemar's Test P-Value : 0.1731
##
## Sensitivity : 0.7840
## Specificity : 0.7502
## Pos Pred Value : 0.7643
## Neg Pred Value : 0.7707
## Precision : 0.7643
## Recall : 0.7840
## F1 : 0.7740
## Prevalence : 0.5082
## Detection Rate : 0.3984
## Detection Prevalence : 0.5213
## Balanced Accuracy : 0.7671
##
## 'Positive' Class : 1
## Авторы получили логистическую регрессию довольно хорошего качества для описательных целей. Несмотря на то, что признак married является малозначимым предиктором в этой модели.
Во-первых, это означает, что Lag_Crossbuy положительно влияет на текущую кросс-покупку, то есть клиенты, которые приобрели больше категорий в предыдущем квартале, с большей вероятностью перекрестно покупают в текущем квартале. Во-вторых, поскольку коэффициент по Avg_Order_Quantity является положительным и статистически значимым, то клиенты, которые в прошлом тратили больше средств, чем в среднем, также чаще перекрестно покупают в текущем периоде времени. В-третьих, авторы обнаружили положительную, но уменьшающуюся отдачу от эффекта удерживающих расходов (Ret_Expense) при перекрестной покупке в том же квартале, поскольку коэффициент на Ret_Expense положителен, а коэффициент Ret_Expense_SQ отрицателен. В-четвертых, авторы отметили, что мужчины чаще совершают перекрестные покупку, чем женщины. В-пятых, авторы нашли положительный эффект от клиентского дохода, т.е. клиенты, имеющие более высокий доход, с большей вероятностью будут перекрестно покупать в текущем квартале. В-шестых, авторы определили, что клиенты, у которых была более высокая First_Purchase, с большей вероятностью закупят несколько категорий продуктов / услуг. Наконец, поскольку коэффициент для Loyality положителен, это говорит о том, что клиенты, которые являются членами программы лояльности, чаще всего перекрестно покупают в текущем квартале.
Logit (AR version)
Авторы по-прежнему прибегают в Avg_Order_Quantity, который в их примере охватывает текущий квартал и тем самым дает смещение в оценке модели в сторону увеличения качества модели. Я рассмотрю эту модель с более корректным предиктором с однопериодным лагом - Lag_Avg_Order_Quantity.
# Fit Logit Regression Model for Customer Crossbuy (Improved)
uno = 'logit'
set.seed(2018) #From random.org
(Ch04cb.AR <- train(factor(cb) ~ lpurchase + lcrossbuy + lavg_order_quantity + ret_expense + ret_expense_sq +
gender + married + income + first_purchase + loyalty, metric = 'Kappa',
data = filter(customerRetentionRepurchase, purchase == 1), method = "glm", family = binomial(link = uno)))#,## Generalized Linear Model
##
## 2678 samples
## 10 predictor
## 2 classes: '0', '1'
##
## No pre-processing
## Resampling: Bootstrapped (25 reps)
## Summary of sample sizes: 2678, 2678, 2678, 2678, 2678, 2678, ...
## Resampling results:
##
## Accuracy Kappa
## 0.7467482 0.4929881 # trControl = trainControl(method = "none", number = 1)))
summary(Ch04cb.AR)##
## Call:
## NULL
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.6058 -0.8225 0.2697 0.8296 2.5297
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -8.5112856 0.4840649 -17.583 < 2e-16 ***
## lpurchase 2.3352505 0.3866021 6.040 1.54e-09 ***
## lcrossbuy 0.2422344 0.0438572 5.523 3.33e-08 ***
## lavg_order_quantity 0.0048317 0.0007242 6.672 2.53e-11 ***
## ret_expense 0.0419413 0.0095937 4.372 1.23e-05 ***
## ret_expense_sq -0.0008518 0.0002155 -3.953 7.72e-05 ***
## gender 0.3740427 0.0950964 3.933 8.38e-05 ***
## married 0.2370931 0.1085674 2.184 0.0290 *
## income 0.2939489 0.0347567 8.457 < 2e-16 ***
## first_purchase 0.0239746 0.0012035 19.920 < 2e-16 ***
## loyalty 0.2538869 0.1057651 2.400 0.0164 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 3711.8 on 2677 degrees of freedom
## Residual deviance: 2714.6 on 2667 degrees of freedom
## AIC: 2736.6
##
## Number of Fisher Scoring iterations: 5# Odds Ratio Estimates and 95% CI
writeLines("\n Odds Ratio Estimates and 95% CI")##
## Odds Ratio Estimates and 95% CIcar::Confint(Ch04cb.AR$finalModel) %>%
exp() %>%
arm::pfround(digits = 3)## Estimate 2.5 % 97.5 %
## (Intercept) 0.000 0.000 0.000
## lpurchase 10.332 5.078 23.460
## lcrossbuy 1.274 1.170 1.389
## lavg_order_quantity 1.005 1.003 1.006
## ret_expense 1.043 1.023 1.063
## ret_expense_sq 0.999 0.999 1.000
## gender 1.454 1.207 1.752
## married 1.268 1.025 1.569
## income 1.342 1.254 1.437
## first_purchase 1.024 1.022 1.027
## loyalty 1.289 1.048 1.587# Logistic regression diagnostics
writeLines("\n Wald test of predictors")##
## Wald test of predictorscar::Anova(Ch04cb.AR$finalModel, type="II", test="Wald")## Analysis of Deviance Table (Type II tests)
##
## Response: .outcome
## Df Chisq Pr(>Chisq)
## lpurchase 1 36.4870 1.537e-09 ***
## lcrossbuy 1 30.5064 3.328e-08 ***
## lavg_order_quantity 1 44.5098 2.531e-11 ***
## ret_expense 1 19.1123 1.233e-05 ***
## ret_expense_sq 1 15.6254 7.721e-05 ***
## gender 1 15.4709 8.379e-05 ***
## married 1 4.7691 0.02897 *
## income 1 71.5265 < 2.2e-16 ***
## first_purchase 1 396.8184 < 2.2e-16 ***
## loyalty 1 5.7623 0.01637 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1writeLines("\n Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")##
## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04cb.AR$finalModel) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity## lpurchase lcrossbuy lavg_order_quantity ret_expense ret_expense_sq gender
## 1.124863 1.140585 1.199859 11.985194 11.933017 1.017409
## married income first_purchase loyalty
## 1.014375 1.085612 1.136428 1.023667writeLines("\n Variable Importance for Model \n")##
## Variable Importance for Modelcaret::varImp(Ch04cb.AR) %>% .$importance %>% print.AsIs()## Overall
## lpurchase 21.743999
## lcrossbuy 18.828019
## lavg_order_quantity 25.302301
## ret_expense 12.335735
## ret_expense_sq 9.974194
## gender 9.863686
## married 0.000000
## income 35.370626
## first_purchase 100.000000
## loyalty 1.221469# Create the scatter plots Logit versus model predictors
predictors <- Ch04cb.AR$coefnames
Ch04cb.AR$trainingData %>%
dplyr::select(one_of(predictors)) %>%
mutate(link = predict(Ch04cb.AR$finalModel, newdata = filter(customerRetentionRepurchase, purchase == 1), type = "link")) %>%
gather(key = "predictors", value = "predictor.value", -link) %>%
ggplot(aes(predictor.value, link))+
geom_point(size = 0.05, alpha = 0.05) +
geom_smooth(method = "loess") +
facet_wrap(~ predictors, scales = "free_x") +
ylab(stringr::str_to_title(uno))
# Plot matrix of statistical model diagnostics
GGally::ggnostic(Ch04cb.AR$finalModel, title = paste(paste(formula(Ch04cb.AR)[c(2, 1, 3)], collapse = " ")))## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
## `geom_smooth()` using method = 'gam'
# wide variety of diagnostic plots for checking the quality of regression fit
# https://bookdown.org/jefftemplewebb/IS-6489/logistic-regression.html
car::influenceIndexPlot(Ch04cb.AR$finalModel)
writeLines("\n Improved Logit Model: Association of Predicted Probabilities and Observed Responses \n")##
## Improved Logit Model: Association of Predicted Probabilities and Observed Responsescaret::confusionMatrix(data = predict(Ch04cb.AR, newdata = filter(customerRetentionRepurchase, purchase == 1)),
reference = filter(customerRetentionRepurchase, purchase == 1) %>% .$cb %>% factor,
positive = "1", mode = "everything")## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 984 335
## 1 333 1026
##
## Accuracy : 0.7506
## 95% CI : (0.7337, 0.7669)
## No Information Rate : 0.5082
## P-Value [Acc > NIR] : <2e-16
##
## Kappa : 0.501
## Mcnemar's Test P-Value : 0.9691
##
## Sensitivity : 0.7539
## Specificity : 0.7472
## Pos Pred Value : 0.7550
## Neg Pred Value : 0.7460
## Precision : 0.7550
## Recall : 0.7539
## F1 : 0.7544
## Prevalence : 0.5082
## Detection Rate : 0.3831
## Detection Prevalence : 0.5075
## Balanced Accuracy : 0.7505
##
## 'Positive' Class : 1
## qplot(`Observed Classes`, `Predicted Classes`,
data=bind_cols(`Observed Classes`= filter(customerRetentionRepurchase, purchase == 1) %>% .$cb %>% factor,
`Predicted Classes` = predict(Ch04cb.AR, newdata = filter(customerRetentionRepurchase, purchase == 1))),
colour= `Observed Classes`, geom = c("boxplot", "jitter"),
main = "Predicted Classes vs. Observed Classes", xlab = "Observed Classes", ylab = "Predicted Classes")
Конечно, без смещения качество модели немного пострадает, зато она будет более правдоподобной и безусловно устойчивой. При этом даже значимость переменной Married повысилось.
Как это использовать?
Полезно рассмотреть значения коэффициентов отношения шансов (англ. “odds ratio”). Что касается Lag_Crossbuy, мы видим, что каждая дополнительная категория, купленная покупателем в предыдущем квартале, делает клиента на 19,7% более вероятным для перекрестную покупку в текущем квартале. Что касается Avg_Order_Quantity, авторы отмечали, что при каждом увеличении на 1 доллар шанс перекрестной покупки в текущем квартале увеличивается на 1,0%. Что касается расходов на удержание клиентов Ret_Expense, то и отношение шансов зависит от уровня Ret_Expense. Это связано с тем, что мы включаем как собственно его уровень, так и его квадрат Ret_Expense_SQ. Например, если обычно в этой выборке тратили 12 долл. ежеквартально на данного клиента, тратя больше долларов, мы должны увидеть увеличение вероятности перекрестной покупки.
И важно отметить, что это будет зависеть от начального уровня Ret_Expense. Что касается гендерных факторов, авторы указывают, что мужчины на 33,7% имеют шансов чаще покупают перекрестно, чем женщины. Что касается клиентского дохода, мы видим, что при каждом повышении уровня доходов на один уровень (Income) вероятность шанса кросс-покупки увеличится на 28,2%. Что касается First_Purchase, авторы пишут, что при каждом увеличении на 1 долл. вероятность кросс-покупки увеличивается на 2,5%. Наконец, что касается лояльности (Loyalty), становится ясным, что, будучи членом программы лояльности, вероятность перекрестной покупки в данном квартале на 30,8% выше, чем у клиента, который не входит в программу лояльности.
Менеджерам будет полезно знать, как изменения в расходах на удержание, прошлые транзакции клиентов и характеристики клиентов могут либо увеличить, либо уменьшить вероятность шанса перекрестной покупки. Эта модель поможет предсказать, собирается ли клиент покупать в другой категории или нет. Эта информация может дать существенную информацию руководителям, которым поручено определить, какие клиенты, скорее всего, склонны к кросс-покупкам.
Эмпирический пример: доля покупок в кошельке
Программы лояльности и прямые рассылки - это два способа, которыми компании используют для управления отношениями с клиентами. Цель состоит в том, чтобы установить тесные отношения с клиентами и таким образом улучшить восприятие отношений с клиентами. Помимо понимания моделей покупки клиента у данной фирмы, многие фирмы также хотят знать, как клиент распределяют покупки в данной категории среди всех фирм. Для этого надо знать доля покупок в кошельке клиента (англ. "Share-of-Wallet, SOW"). Исследования показали, что понимание SOW клиента в данной фирме может помочь понять вероятность того, что клиент собирается купить у данной фирмы и неизбежно долгосрочную ценность клиента для фирмы (CVL). Таким образом, может быть полезно понять драйверы SOW и, в свою очередь, иметь возможность прогнозировать ожидаемое SOW каждого клиента. В этом примере авторы дают возможность возможность:
Определите драйверы SOW.
Предскажите ожидаемое SOW для каждого клиента.
Определите предиктивную точность модели.
Информация, необходимая для этой модели, включает следующий список переменных:
| Переменные | Описание |
|---|---|
| Зависимая переменная | |
| Share-of-Wallet (SOW) | Процент покупок клиента от данной фирмы, учитывая общий объем покупок по всем фирмам в этой категории |
| Предикторы | |
| Purchase_Rate | Средняя доля кварталов с покупками во всех 12 кварталах |
| Avg_Order_Quantity | Средняя долларовая стоимость покупок за все 12 кварталов |
| Avg_Crossbuy | Среднее значение для кросс-покупки за все 12 кварталов |
| Avg_Ret_Expense | Средние расходы, потраченные на маркетинговые усилия по удержанию данного клиента за все 12 кварталов |
| Avg_Ret_Expense_SQ | Квадрат средних расходов, потраченные на маркетинговые усилия по удержанию данного клиента за все 12 кварталов |
Для получения этих агрегированных показателей необходимо получить массив данных, обобщенный за все 12 кварталов:
# Calculation Share-of-Wallet (SOW) Database
library('sqldf')
customerRetentionSOW <- sqldf("select customer, avg(purchase) as purchase_rate,
avg(order_quantity) as avg_order_quantity,
avg(crossbuy) as avg_crossbuy, avg(ret_expense) as avg_ret_exp,
(avg(ret_expense) * avg(ret_expense)) as avg_ret_exp_sq, gender,
married, income, first_purchase, sow, loyalty
from customerRetentionRepurchase group by customer, gender,
married, income, first_purchase, sow, loyalty order by customer;")
ggplot(customerRetentionSOW, aes(x = purchase_rate)) +
geom_histogram(breaks = seq(0, 1, by = .1), col = "gray", aes(fill = ..count..)) +
scale_fill_gradient("Count", low = "green", high = "red") +
geom_density(adjust = 1/5, alpha = .2, fill = "#FF6666") +
geom_vline(xintercept = mean(customerRetentionSOW$purchase_rate), linetype="dashed", color = "coral")
# Description of an empirical distribution for non-censored data using Cullen & Frey graph
library('fitdistrplus')
descdist(customerRetentionSOW$purchase_rate, boot = 500, discrete = FALSE)
## summary statistics
## ------
## min: 0 max: 1
## median: 0.4545455
## mean: 0.4869091
## estimated sd: 0.3656492
## estimated skewness: 0.2090908
## estimated kurtosis: 1.564647x <- fitdist(customerRetentionSOW$purchase_rate, "unif", method = "mle", discrete = FALSE)
plot(x)
writeLines("\n Uniform distribution of `customerRetentionSOW$purchase_rate`")##
## Uniform distribution of `customerRetentionSOW$purchase_rate`gofstat(x)## Goodness-of-fit statistics
## 1-mle-unif
## Kolmogorov-Smirnov statistic 0.222000
## Cramer-von Mises statistic 4.766865
## Anderson-Darling statistic Inf
##
## Goodness-of-fit criteria
## 1-mle-unif
## Akaike's Information Criterion NA
## Bayesian Information Criterion NAПолученный непрерывный признак Purchase_Rate представлен на графике выше - очевидно, что он имеет равномерное распределение (англ. “Uniform distribution”). Это подтвержает тест при помощи графика Cullen & Frey.
В этом случае мы имеем цензуированную зависимую переменную (SOW), которая падает на континуум между 1 и 100. Минимальный размер этого случая составляет 1%, поскольку все клиенты в нашей базе данных совершили по крайней мере одну покупку у данной фирмы, а максимальный составляет 100%, поскольку все клиенты в базе данных могут потенциально покупать эти продукты только у этой фирмы. Таким образом, мы должны учитывать эту цензуированную зависимую переменную. В этом случае авторы предлагали использовать вариацию тобит-модели, которую использовали в предыдущих примерах в третьей главе. В стандартном случае тобит-модель имеет ситуацию, когда нижняя граница зависимой переменной определяется, как правило, равной 0, а верхняя граница тобит-модель бесконечна. Однако в этом случае нам нужно учитывать цензуирование как с нижней границей, так и верхней границы, где нижняя граница равна 1, а верхняя граница равна 100. Таким образом, мы имеем следующее определение для SOW:
\[ \displaystyle \begin{array}{ll} SOW_i = \begin{cases} 100 & {\text{if}}\ SOW ^* _i \geq 100 \\ SOW ^* _i & {\text{if}}\ 1 < SOW ^* _i < 100 \\ 1 & {\text{if}}\ SOW ^* _i \leq 1 \\ \end{cases} \end{array} \]
Построение и верификация модели доли покупок в кошельке
Tobit
# Censored Regression of Accelerated Failure Time (AFT) model on Time-to-Failure Data
# https://stats.idre.ucla.edu/sas/dae/tobit-analysis/ & https://stats.idre.ucla.edu/r/dae/tobit-models/ & http://rpubs.com/Joaquin_AR/381600
library('VGAM') # Vector Generalized Linear and Additive Models## Loading required package: stats4## Loading required package: splines##
## Attaching package: 'VGAM'## The following object is masked from 'package:hypergeo':
##
## is.zero## The following object is masked from 'package:car':
##
## logit## The following object is masked from 'package:caret':
##
## predictors## The following object is masked from 'package:tidyr':
##
## fill# Left- & Right-Censored Tobit (Normally distributed error term) AFT Model from 'VGAM' package
(Ch04.tb <- VGAM::vglm(sow ~ purchase_rate + avg_order_quantity + avg_crossbuy + avg_ret_exp + avg_ret_exp_sq +
gender + married + income + first_purchase + loyalty,
family = tobit(Lower = 1, Upper = 100, type.fitted = "censored"),
data = customerRetentionSOW)) %>%
summary##
## Call:
## VGAM::vglm(formula = sow ~ purchase_rate + avg_order_quantity +
## avg_crossbuy + avg_ret_exp + avg_ret_exp_sq + gender + married +
## income + first_purchase + loyalty, family = tobit(Lower = 1,
## Upper = 100, type.fitted = "censored"), data = customerRetentionSOW)
##
##
## Pearson residuals:
## Min 1Q Median 3Q Max
## mu -9.5278 -0.5892 0.03388 0.7205 2.483
## loge(sd) -0.9874 -0.6404 -0.31277 0.2466 10.587
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept):1 4.05628 3.56782 1.137 0.255577
## (Intercept):2 2.39092 0.03367 71.011 < 2e-16 ***
## purchase_rate 6.74423 6.23120 1.082 0.279105
## avg_order_quantity 0.17791 0.02507 7.097 1.28e-12 ***
## avg_crossbuy 6.89457 1.89449 3.639 0.000273 ***
## avg_ret_exp 0.67754 0.37703 1.797 0.072325 .
## avg_ret_exp_sq -0.04018 0.01382 -2.907 0.003647 **
## gender 0.51607 1.04293 0.495 0.620720
## married 0.96764 1.16902 0.828 0.407824
## income 1.75409 0.36922 4.751 2.03e-06 ***
## first_purchase 0.04970 0.01267 3.922 8.79e-05 ***
## loyalty 4.72816 1.09928 4.301 1.70e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Number of linear predictors: 2
##
## Names of linear predictors: mu, loge(sd)
##
## Log-likelihood: -1701.619 on 988 degrees of freedom
##
## Number of iterations: 6
##
## No Hauck-Donner effect found in any of the estimates# # Censored Normal Distribution of error term Or Censored Tobit
# Extra <- with(customerRetentionSOW,
# list(leftcensored = (sow < 1), rightcensored = (sow > 100)))
#
# (Ch04.nr <- VGAM::vglm(sow ~ purchase_rate + avg_order_quantity + avg_crossbuy + avg_ret_exp + avg_ret_exp_sq +
# gender + married + income + first_purchase + loyalty,
# family = cens.normal(), extra = Extra,
# data = customerRetentionSOW)) %>%
# summaryЗадача авторов состояла в том, чтобы максимизировать функцию логарифмического правдоподобия путем оценки коэффициентов и стандартной ошибки уравнения. При оценке модели получаны вышеприведенные результаты.
Авторы нашли, что все переменные, за исключением Purchase_Rate, Gender и Married, статистически значимы при p < 0,05.
Следующий шаг - предсказать значение SOW, чтобы увидеть, насколько хорошо наша модель сравнивается с фактическими значениями. Авторы сделали это, сравненивая предсказания по двухстороннему цензуированному регрессионому уравнению с фактическими значениями SOW.
Error of SOW
# mean_order_quantity
y <- customerRetentionSOW$sow
writeLines(sprintf("Mean of Share-of-Wallet (SOW): %.2f", mean(y)))## Mean of Share-of-Wallet (SOW): 52.98# Accuracy measures for Naïve AFT Model
m <- forecast::accuracy(rep(mean(customerRetentionSOW$sow), length(y)), y)
attributes(m)$ dimnames[[1]] <- " Naïve Model (Mean) Accuracy: "; m## ME RMSE MAE MPE MAPE
## Naive Model (Mean) Accuracy: -1.760536e-15 29.6507 25.7024 -123.2185 152.0989# Accuracy measures for Censored Tobit
y_hat <- fitted(Ch04.tb)[, 1]
m <- forecast::accuracy(y_hat, y); attributes(m)$ dimnames[[1]] <- " Censored Tobit's Accuracy: "; m## ME RMSE MAE MPE MAPE
## Censored Tobit's Accuracy: -0.301939 9.753828 7.408359 -31.43513 45.86385# # Accuracy measures for Censored Normal Distribution AFT Model
# y_hat <- if_else(fitted(Ch04.nr) > 100, 100, if_else(fitted(Ch04.nr) < 1, 1, fitted(Ch04.nr)))
# m <- forecast::accuracy(y_hat, y); attributes(m)$ dimnames[[1]] <- "Censored Normal Model's Accuracy: "; mПолученная авторами модель дает для приобретенных клиентов MAD = 7.41 или в среднем 45.86% от фактического SOW. Если бы мы вместо этого использовали среднее значение SOW (52.98) для всех клиентов в качестве нашего прогноза для всех клиентов (это было бы наивным примером модели), мы бы обнаружили, что MAD 25.70 или в среднем на 25.70% от фактического SOW. Следовательно, авторская модель значительно улучшает работу по прогнозированию значения SOW, чем прогнозирование по среднему значению SOW.
Tobit (AR version)
# Censored Regression of Accelerated Failure Time (AFT) model on Time-to-Failure Data
# Left- & Right-Censored Tobit (Normally distributed error term) AFT Model from 'VGAM' package
(Ch04tb.AR <- VGAM::vglm(sow ~ avg_order_quantity + avg_crossbuy + avg_ret_exp_sq +
income + first_purchase + loyalty,
family = tobit(Lower = 1, Upper = 100, type.fitted = "censored"),
data = customerRetentionSOW)) %>%
summary##
## Call:
## VGAM::vglm(formula = sow ~ avg_order_quantity + avg_crossbuy +
## avg_ret_exp_sq + income + first_purchase + loyalty, family = tobit(Lower = 1,
## Upper = 100, type.fitted = "censored"), data = customerRetentionSOW)
##
##
## Pearson residuals:
## Min 1Q Median 3Q Max
## mu -19.2759 -0.6052 0.0373 0.7308 2.487
## loge(sd) -0.9917 -0.6490 -0.3192 0.2159 20.556
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept):1 10.026043 2.327982 4.307 1.66e-05 ***
## (Intercept):2 2.399005 0.033685 71.218 < 2e-16 ***
## avg_order_quantity 0.200225 0.014739 13.585 < 2e-16 ***
## avg_crossbuy 7.018201 1.901100 3.692 0.000223 ***
## avg_ret_exp_sq -0.016212 0.003687 -4.397 1.10e-05 ***
## income 1.612203 0.363555 4.435 9.23e-06 ***
## first_purchase 0.046279 0.012561 3.684 0.000229 ***
## loyalty 4.585501 1.106101 4.146 3.39e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Number of linear predictors: 2
##
## Names of linear predictors: mu, loge(sd)
##
## Log-likelihood: -1704.184 on 992 degrees of freedom
##
## Number of iterations: 6
##
## No Hauck-Donner effect found in any of the estimates# Calculate the upper and lower 95% confidence intervals for the coefficients.
b <- coef(Ch04tb.AR)
se <- sqrt(diag(vcov(Ch04tb.AR)))
writeLines("\n The Upper and Lower 95% confidence intervals for the coefficients of Left- & Right-Censored Tobit")##
## The Upper and Lower 95% confidence intervals for the coefficients of Left- & Right-Censored Tobitcbind(`Lower Intervals` = b - qnorm(0.975) * se, `Upper Intervals` = b + qnorm(0.975) * se)## Lower Intervals Upper Intervals
## (Intercept):1 5.46328217 14.588804390
## (Intercept):2 2.33298357 2.465027071
## avg_order_quantity 0.17133690 0.229113671
## avg_crossbuy 3.29211302 10.744288403
## avg_ret_exp_sq -0.02343729 -0.008986081
## income 0.89964836 2.324758268
## first_purchase 0.02166055 0.070896874
## loyalty 2.41758374 6.753418053dat <- customerRetentionSOW
dat$yhat <- fitted(Ch04tb.AR)[, 1]
dat$rr <- resid(Ch04tb.AR, type = "response")
dat$rp <- resid(Ch04tb.AR, type = "pearson")[, "mu"]
# Goodness-of-fit of normal distributions to residuals of Tobit-Model (if Kolmogorov-Smirnov statistic < 0.05)
resid(Ch04tb.AR, type = "response")[, 1] %>% fitdist("norm") %>% gofstat()## Goodness-of-fit statistics
## 1-mle-norm
## Kolmogorov-Smirnov statistic 0.05582187
## Cramer-von Mises statistic 0.29926225
## Anderson-Darling statistic 1.40259960
##
## Goodness-of-fit criteria
## 1-mle-norm
## Akaike's Information Criterion 3701.259
## Bayesian Information Criterion 3709.688par(mfcol = c(2, 3))
with(dat, {
plot(yhat, rr, main = "Fitted vs Residuals")
qqnorm(rr, main = "Normal Q-Q Plot of Residuals")
plot(yhat, rp, main = "Fitted vs Pearson Residuals")
qqnorm(rp, main = "Normal Q-Q Plot of Pearson Residuals (mu)")
plot(sow, rp, main = "Actual vs Pearson Residuals")
plot(sow, yhat, main = "Actual vs Fitted")
})
par(mfcol = c(1, 1))
# Accuracy measures for Censored Tobit Improved
y <- customerRetentionSOW$sow
y_hat <- fitted(Ch04tb.AR)[, 1]
m <- forecast::accuracy(y_hat, y); attributes(m)$ dimnames[[1]] <- "Censored Tobit Improved Accuracy: "; m## ME RMSE MAE MPE MAPE
## Censored Tobit Improved Accuracy: -0.2663836 9.763911 7.428771 -32.27628 46.57864remove(y, y_hat, m, b, se)Если исключить три незначащие признаки Purchase_Rate, Gender и Married из числа предикторов, то получилась более устойчивую модель c незначительно увеличившейся ошибкой по MAE и MAPE. Первый свободный член (Intercept):1 равный 10 надо интерепретировать как обычный сводобный член линейного уравнения, а второй сводобный член (Intercept):2 равный 2.4 следует проэкспоненцировать и применить полученное число 11.0 = exp(2.4) как стандартное отклонение, задаваемое при формировании нормально распределенных остатков sd в этом линейном уравнении. При этом следует признать, что что остатки улучшинной тобит-модели и в самом деле распределяются по нормальному распределению, поскольку значение статистики Колмогорова-Смирнова близко p < 0.05
Как это использовать?
Авторы обнаружили, что коэффициент Avg_Order_Quantity положителен, что указывает на то, что чем выше средние значения заказа клиента в прошлом, тем выше значение SOW. Авторы также нашли, что Avg_Crossbuy позитивен, предполагая, что чем больше клиент закупил в нескольких категориях в прошлом, тем выше клиентский SOW. Мы находим, что Ret_Expense положителен с уменьшающимся возвратом, как отмечено положительным коэффициентом на Ret_Expense и отрицательным коэффициентом на Ret_Expense_SQ. Это означает, что маркетинговые усилия, направленные на сохранение и построение отношений с клиентом, заставляют клиента иметь более высокое значение SOW. Затем, после достижения порога, маркетинговые усилия фактически уменьшают SOW в среднем. Вероятно, это связано с тем, что чрезмерное общение с клиентами может часто напрягать отношения между клиентом и фирмой. Оказывается, что три из характеристики клиента являются положительными (Income, First_Purchase и Loyalty), предполагая, что клиенты с более высоким доходом, более высокая стоимость первой покупки и кто являются членами программы лояльности, вероятно, будут иметь более высокое значениеSOW.
Эмпирический пример: Рентабельность или Пожизненная финансовая ценность клиента (CLV)
Конечный вопрос для фирм, заинтересованных в удержании клиентов, связан с тем, насколько рентабельным может быть нынешний клиент в будущем. В этом примере авторы не фокусировались на прогнозе ожидаемой будущей прибыльности клиента или CLV (англ. “Customer Lifetime Value”) или Пожизненная финансовая ценность клиента. Вместо этого попробуем сосредоточиться на драйверах CLV. Таким образом, авторы построили прогноз CLV для каждого из клиентов в выборке из 500. Затем авторы использовали это предсказание, чтобы понять, какая из переменных в данной базе данных поможет объяснить будущую ценность клиента. Если драйверы эффективно объясняют будущую ценность клиента, можно иметь возможность использовать результаты оценки в предсказании CLV для любого клиента, не входящего в текущую выборку. В конце этой главы авторы книги должны иметь возможность сделать следующее:
Определить драйверы
CLV.Предскажить ожидаемый
CLVдля каждого клиента.Рассчитать предиктивную точность модели.
Информация, необходимая для этой модели, включает следующий список переменных:
| Переменные | Описание |
|---|---|
| Зависимая переменная | |
| CLV | Дисконтированная стоимость всех ожидаемых будущих прибылей или стоимости жизни клиента |
| Предикторы | |
| Purchase_Rate | Средняя доля кварталов с покупками во всех 12 кварталах |
| Avg_Order_Quantity | Средняя долларовая стоимость покупок за все 12 кварталов |
| Avg_Crossbuy | Среднее значение для кросс-покупки за все 12 кварталов |
| Avg_Ret_Expense | Средние расходы, потраченные на маркетинговые усилия по удержанию данного клиента за все 12 кварталов |
| Avg_Ret_Expense_SQ | Квадрат средних расходов, потраченные на маркетинговые усилия по удержанию данного клиента за все 12 кварталов |
| Gender | 1, если клиент является мужчиной, 0, если клиент является женщиной |
| Married | 1, если клиент женат, 0, если клиент не состоял в браке |
| Income | 1, если доход < 30 000 долл. США, 2; если 30 001 долл. США < доход < 45 000 долл. США; 3, если 45 001 долл. США < доход < 60 000 долл. США; 4, если 60 001 долл. США < доход < 75 000 долл. США; 5, если 75 001 долл. США < доход < 90 000 долл. США; 6, если доход > 90 001 долл. США |
| First_Purchase | Стоимость первой покупки, сделанной клиентом в 1 квартале |
| Loyalty | 1, если клиент является членом программы лояльности, 0, если нет |
| Share-of-Wallet (SOW) | Процент покупок клиента от данной фирмы, учитывая общий объем покупок по всем фирмам в этой категории |
# Calculation Customer Lifetime Value (CLV) Database
library('sqldf')
customerRetentionCLV <- sqldf("select customer, avg(purchase) as
purchase_rate, avg(order_quantity) as avg_order_quantity,
avg(crossbuy) as avg_crossbuy, avg(ret_expense) as avg_ret_exp,
(avg(ret_expense) * avg(ret_expense)) as avg_ret_exp_sq, gender,
married, income, first_purchase, sow, clv, loyalty
from customerRetentionRepurchase group by customer, gender,
married, income, first_purchase, sow, clv, loyalty order by customer;")
ggplot(customerRetentionCLV, aes(x = clv)) +
geom_histogram(bins = 20, col = "gray", aes(fill = ..count..)) +
scale_fill_gradient("Count", low = "green", high = "red") +
geom_density(adjust = 1/5, alpha = .2, fill = "#FF6666") +
geom_vline(xintercept = mean(customerRetentionCLV$clv), linetype="dashed", color = "coral")
# Description of an empirical distribution for non-censored data using Cullen & Frey graph
library('fitdistrplus')
descdist(customerRetentionCLV$clv, boot = 500, discrete = FALSE)
## summary statistics
## ------
## min: -80.84 max: 4257.57
## median: 871.41
## mean: 1126.734
## estimated sd: 850.5878
## estimated skewness: 0.656815
## estimated kurtosis: 2.428219min(customerRetentionCLV$clv) # clv < 0 !!!!!, but values must be in [0-1] to fit a beta distribution## [1] -80.84(x <- fitdist(((customerRetentionCLV$clv - min(customerRetentionCLV$clv)) /
(max(customerRetentionCLV$clv) - min(customerRetentionCLV$clv))),
"beta", method = "mme", discrete = FALSE))## Fitting of the distribution ' beta ' by matching moments
## Parameters:
## estimate
## shape1 1.179088
## shape2 3.056980plot(x)
writeLines("\n Beta distribution of `customerRetentionCLV$clv`")##
## Beta distribution of `customerRetentionCLV$clv`gofstat(x)## Goodness-of-fit statistics
## 1-mme-beta
## Kolmogorov-Smirnov statistic 0.06316199
## Cramer-von Mises statistic 0.58815120
## Anderson-Darling statistic Inf
##
## Goodness-of-fit criteria
## 1-mme-beta
## Akaike's Information Criterion Inf
## Bayesian Information Criterion Inf# (x <- fitdist(customerRetentionCLV$clv, "gamma", method = "mme", discrete = FALSE))
# plot(x)
# writeLines("\n Gamma distribution of `customerRetentionCLV$clv`")
# gofstat(x)
#
# library('actuar') # 19 continuous tailed distributions (Burr, Gumbel, Inverse..., Paralogistic, Pareto, etc)
# (x <- fitdist(((customerRetentionCLV$clv - min(customerRetentionCLV$clv)) /
# (max(customerRetentionCLV$clv) - min(customerRetentionCLV$clv))),
# "pareto", start = list(shape = 1, scale = 500)))
# plot(x)
# writeLines("\n Pareto distribution of `customerRetentionSOW$clv`")
# gofstat(x)
# # fitting a non-standard distribution to data and initial values
# set.seed(2018); x <- rweibull(500, shape = .5, scale = 1)
# x = (x - min(x) + 1) / (max(x) + 1)
# descdist(x, boot = 500, discrete = FALSE)
#
# fitLog <- fitdist(x, "logis")
# fitln <- fitdist(x, "lnorm")
# fitW <- fitdist(x, "weibull")
# fitg <- fitdist(x, "gamma")
# fitn <- fitdist(x, "norm")
# fitexp <- fitdist(x, "exp")
# fitB <- fitdist(x, "beta", method = "mme")
# fitUni <- fitdist(x, "unif")
# fitP <- fitdist(x, "pareto", start = list(shape = 1, scale = 500))
#
# (z <- gofstat(list(fitLog, fitln, fitW, fitg, fitn, fitexp, fitB, fitUni, fitP),
# fitnames = c("Logistic", "Log-normal", "Weibull", "Gamma", "Normal", "Exponential", "Beta",
# "Uniform", "Pareto")))
# writeLines("\n Reference distribution of Sample is defined as:")
# which.min(z$cvm)В этом случае имеется зависимая переменная CLV (ее гистограмма приведена на графике выше), которая представляет ожидаемую дисконтированную будущую прибыль от каждого клиента, распределенную по непрерывному бета-распределению. Переменная CLV непрерывна и не связана никаким порогом (и даже меньше нуля - AR). Таким образом, учитывая предположение, что CLV нормально распреден вокруг определенного среднего, авторы просто предложили построить линейную регрессию методом наименьших квадратов, чтобы выявить драйверы CLV. Поэтому авторы предлагают уравнение линейной регрессии в следующем формате:
\[ \bf CLV_i = X' \boldsymbol \beta + \varepsilon, \enspace \varepsilon = \bf \textit{ N } \boldsymbol (0, \enspace \sigma^2 ), \]
где CLV - значение жизненного цикла клиента для данного клиента,
X - матрица независимых переменных,
\(\beta\) - вектор коэффициентов независимых переменных,
\(\varepsilon\) - случайная ошибка модели, который нормально распределен со средним значением 0 и дисперсией \(\sigma^2\).
Построение и верификация модели Пожизненной финансовой ценности клиента
При оценке модели CLV авторы получили следующие результаты:
Linear
# Fit Linear Regression Model for Customer Lifetime Value (CLV) by Authors
(Ch04.clv <- lm(clv ~ purchase_rate + avg_order_quantity + avg_crossbuy + avg_ret_exp + avg_ret_exp_sq +
gender + married + income + first_purchase + loyalty + sow,
data = customerRetentionCLV)) %>%
summary##
## Call:
## lm(formula = clv ~ purchase_rate + avg_order_quantity + avg_crossbuy +
## avg_ret_exp + avg_ret_exp_sq + gender + married + income +
## first_purchase + loyalty + sow, data = customerRetentionCLV)
##
## Residuals:
## Min 1Q Median 3Q Max
## -187.850 -43.197 -4.305 47.507 162.744
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -100.40340 20.83500 -4.819 1.93e-06 ***
## purchase_rate -57.16550 31.07834 -1.839 0.06646 .
## avg_order_quantity 6.93639 0.11754 59.012 < 2e-16 ***
## avg_crossbuy 19.99788 10.77503 1.856 0.06406 .
## avg_ret_exp 4.80130 2.18613 2.196 0.02854 *
## avg_ret_exp_sq -0.19616 0.08139 -2.410 0.01631 *
## gender 20.10207 6.06686 3.313 0.00099 ***
## married 2.72447 6.84432 0.398 0.69076
## income 3.39694 2.25280 1.508 0.13223
## first_purchase 1.74358 0.07586 22.985 < 2e-16 ***
## loyalty 14.28240 6.59139 2.167 0.03073 *
## sow 1.28062 0.28621 4.474 9.55e-06 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 65.97 on 488 degrees of freedom
## Multiple R-squared: 0.9941, Adjusted R-squared: 0.994
## F-statistic: 7497 on 11 and 488 DF, p-value: < 2.2e-16writeLines("Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04.clv) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity## purchase_rate avg_order_quantity avg_crossbuy avg_ret_exp avg_ret_exp_sq gender
## 14.806047 20.944428 10.687320 14.253859 14.369290 1.056717
## married income first_purchase loyalty sow
## 1.019757 1.321702 1.409297 1.059983 8.273820Мы получаем следующие данные из этих результатов. Мы находим, что все переменные, за исключением Purchase_Rate и Married, статистически значимы при p < 0,05. Тем не менее сама модель имеет очень большую точность, но вот о ее устойчивости сказать сложно. Возможно имела место переподгонка под конкретные данные и требуется пройдти процедуры обеспечивающие устойчивость.
Linear (AR version)
Теперь попробуем исключить из линейной модели незначимые факторы married и income и провести построение устойчивой регресии посредством бустинга.
# Fit Linear Regression Model for Customer Lifetime Value (CLV) (Improved)
uno = 'y_hat'
set.seed(2018)
(Ch04clv.AR <- train(clv ~ purchase_rate + avg_order_quantity + avg_ret_exp + avg_ret_exp_sq +
gender + first_purchase + loyalty + sow,
data = customerRetentionCLV, method = "lm"))#,## Linear Regression
##
## 500 samples
## 8 predictor
##
## No pre-processing
## Resampling: Bootstrapped (25 reps)
## Summary of sample sizes: 500, 500, 500, 500, 500, 500, ...
## Resampling results:
##
## RMSE Rsquared MAE
## 67.83431 0.9937059 54.7472
##
## Tuning parameter 'intercept' was held constant at a value of TRUE # trControl = trainControl(method = "none", number = 1)))
summary(Ch04clv.AR)##
## Call:
## lm(formula = .outcome ~ ., data = dat)
##
## Residuals:
## Min 1Q Median 3Q Max
## -207.150 -45.528 -4.152 47.493 158.469
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -94.81898 18.20129 -5.209 2.79e-07 ***
## purchase_rate -62.56875 30.06511 -2.081 0.03794 *
## avg_order_quantity 7.06835 0.10170 69.501 < 2e-16 ***
## avg_ret_exp 4.39866 2.18444 2.014 0.04459 *
## avg_ret_exp_sq -0.17836 0.08126 -2.195 0.02863 *
## gender 19.21921 6.05376 3.175 0.00159 **
## first_purchase 1.78414 0.06816 26.177 < 2e-16 ***
## loyalty 12.84451 6.56106 1.958 0.05083 .
## sow 1.47456 0.27426 5.377 1.18e-07 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 66.15 on 491 degrees of freedom
## Multiple R-squared: 0.994, Adjusted R-squared: 0.994
## F-statistic: 1.025e+04 on 8 and 491 DF, p-value: < 2.2e-16# Coefficient Estimates and 95% CI
writeLines("\n Coefficient Estimates and 95% CI")##
## Coefficient Estimates and 95% CIcar::Confint(Ch04clv.AR$finalModel) %>%
exp() %>%
arm::pfround(digits = 3)## Estimate 2.5 % 97.5 %
## (Intercept) 0.000000e+00 0.000000e+00 0.000000e+00
## purchase_rate 0.000000e+00 0.000000e+00 3.000000e-02
## avg_order_quantity 1.174212e+03 9.615320e+02 1.433934e+03
## avg_ret_exp 8.134200e+01 1.113000e+00 5.947178e+03
## avg_ret_exp_sq 8.370000e-01 7.130000e-01 9.810000e-01
## gender 2.222270e+08 1.517367e+03 3.254641e+13
## first_purchase 5.954000e+00 5.208000e+00 6.808000e+00
## loyalty 3.787028e+05 9.540000e-01 1.502739e+11
## sow 4.369000e+00 2.549000e+00 7.489000e+00# Linear regression diagnostics
writeLines("\n Chisq test of predictors")##
## Chisq test of predictorscar::Anova(Ch04clv.AR$finalModel, type="II", test="Chisq")## Anova Table (Type II tests)
##
## Response: .outcome
## Sum Sq Df F value Pr(>F)
## purchase_rate 18954 1 4.3310 0.037942 *
## avg_order_quantity 21139025 1 4830.3439 < 2.2e-16 ***
## avg_ret_exp 17745 1 4.0547 0.044593 *
## avg_ret_exp_sq 21086 1 4.8181 0.028629 *
## gender 44109 1 10.0791 0.001594 **
## first_purchase 2998835 1 685.2448 < 2.2e-16 ***
## loyalty 16772 1 3.8325 0.050833 .
## sow 126507 1 28.9074 1.176e-07 ***
## Residuals 2148762 491
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1writeLines("\n Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")##
## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04clv.AR$finalModel) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity## purchase_rate avg_order_quantity avg_ret_exp avg_ret_exp_sq gender first_purchase
## 13.779975 15.593127 14.153349 14.243731 1.046358 1.131373
## loyalty sow
## 1.044461 7.555266writeLines("\n Variable Importance for Model \n")##
## Variable Importance for Modelcaret::varImp(Ch04clv.AR) %>% .$importance %>% print.AsIs()## Overall
## purchase_rate 0.18272895
## avg_order_quantity 100.00000000
## avg_ret_exp 0.08282756
## avg_ret_exp_sq 0.35138399
## gender 1.80191363
## first_purchase 35.85789384
## loyalty 0.00000000
## sow 5.06176772# Create the scatter plots Linear Model versus model predictors
# https://stats.idre.ucla.edu/r/seminars/ggplot2_intro/
predictors <- Ch04clv.AR$trainingData %>% colnames(.) %>% .[-1]
Ch04clv.AR$trainingData %>%
rename(y_hat = `.outcome`) %>%
gather(key = "predictors", value = "predictor.value", -y_hat) %>%
ggplot(aes(predictor.value, y_hat))+
geom_point(size = 0.5, alpha = 0.5) +
geom_smooth(method = "loess") +
facet_wrap(~ predictors, scales = "free_x") +
ylab(stringr::str_to_title(uno))
# Plot matrix of statistical model diagnostics
GGally::ggnostic(Ch04clv.AR$finalModel, title = paste(paste(formula(Ch04clv.AR)[c(2, 1, 3)], collapse = " ")))## `geom_smooth()` using method = 'loess'
## `geom_smooth()` using method = 'loess'
## `geom_smooth()` using method = 'loess'
## `geom_smooth()` using method = 'loess'
## `geom_smooth()` using method = 'loess'
## `geom_smooth()` using method = 'loess'
## `geom_smooth()` using method = 'loess'
# wide variety of diagnostic plots for checking the quality of regression fit
car::influenceIndexPlot(Ch04clv.AR$finalModel)
# Goodness-of-fit of normal distributions to residuals of Linear Model (if Kolmogorov-Smirnov statistic < 0.05)
residuals(Ch04clv.AR) %>% fitdist("norm") %>% gofstat()## Goodness-of-fit statistics
## 1-mle-norm
## Kolmogorov-Smirnov statistic 0.02919682
## Cramer-von Mises statistic 0.07920009
## Anderson-Darling statistic 0.55114023
##
## Goodness-of-fit criteria
## 1-mle-norm
## Akaike's Information Criterion 5605.836
## Bayesian Information Criterion 5614.265Улучшенная модель без признаков avg_crossbuy, married и income стала устойчивее и не практически не потеряла своей точности. Следует признать, что остатки линейной модели и в самом деле распределяются по нормальному распределению, поскольку значение статистики Колмогорова-Смирнова p < 0.05.
Error of CLV Models
Последний шаг - предсказать значение Customer Lifetime Value (CLV), чтобы увидеть, насколько авторская и моя модели совпадают с фактическими значениями и в какой мере они превосходят наивную модель по среднему значению.
# Computing the Mean Absolute Deviation (MAD) and Mean Absolute Percent Error (MAPE)
# mean_clv
y <- customerRetentionCLV$clv
writeLines(sprintf("Mean of Customer Lifetime Value (CLV): %.2f", mean(y)))## Mean of Customer Lifetime Value (CLV): 1126.73# Accuracy measures for Naïve AFT Model
m <- forecast::accuracy(rep(mean(customerRetentionCLV$clv), length(y)), y)
attributes(m)$ dimnames[[1]] <- " Naïve Model (Mean) Accuracy: "; m## ME RMSE MAE MPE MAPE
## Naive Model (Mean) Accuracy: -1.009504e-13 849.7368 734.5075 1092.542 2294.315# Accuracy measures for Linear CLV Model
y_hat <- predict(Ch04.clv, newdata = customerRetentionCLV)
m <- forecast::accuracy(y_hat, y); attributes(m)$ dimnames[[1]] <- " Linear CLV Model's Accuracy: "; m## ME RMSE MAE MPE MAPE
## Linear CLV Model's Accuracy: 7.431455e-14 65.17454 52.56327 60.94577 91.02959# Accuracy measures for Linear CLV Improved Model
y_hat <- predict(Ch04clv.AR, newdata = customerRetentionCLV)
m <- forecast::accuracy(y_hat, y); attributes(m)$ dimnames[[1]] <- "Linear Improved Model's Accuracy: "; m## ME RMSE MAE MPE MAPE
## Linear Improved Model's Accuracy: 2.260619e-14 65.55551 53.116 67.8433 91.54033Среднее значение Пожизненная финансовая ценность клиента в данной выборке составляет 1126.73 долл. Этот показатель авторы применили в качестве наивного прогноза. Созданная ими модель, а также моя модель CLV оказалось заметно аккуратнее наивной модели среднего: MAD = 53.12 долл. или в среднем 91.54% от фактического CLV.
Как это использовать?
Надо отметить, что коэффициент Avg_Order_Quantity положителен, что указывает на то, что чем выше средние значения прошлых заказов клиента, тем выше CLV. Также оказалось, что в авторском модели коэффициент Avg_Crossbuy позитивен, поэтому следует предполагать, что чем больше клиент купил в нескольких категориях в прошлом, тем выше CLV клиента. Мы находим, что Ret_Expense положителен с уменьшающимся возвратом, как отмечено положительным коэффициентом на Ret_Expense и отрицательным коэффициентом на Ret_Expense_SQ. Это означает, что маркетинговые усилия, направленные на сохранение и установление отношений с клиентом, заставляют клиента иметь более высокий CLV. Затем, после достижения порога, маркетинговые усилия на самом деле уменьшают CLV в среднем. Вероятно, это связано с тем, что чрезмерное общение с клиентами может часто напрягать отношения между клиентом и фирмой, а поскольку, когда маркетинговые усилия теряют эффективность, затраты продолжают расти без соответствующего увеличения прибыли. Мы обнаруживаем, что характеристики клиента являются положительными (Gender, First_Purshase и Loyality), предполагая, что клиенты, которые являются мужчинами, с более высокой суммой первой покупки и являясь членами программы лояльности, скорее всего, будут иметь более высокую CLV.
Несколько сложнее понять чем вызван отрицательный коэффициент Purchase_rate, высокий уровень которого свидетельствует о высокой доли кварталов, в которые клиентом проводилась закупка. Однако невысокая значимость этого члена регрессионного уравнения в обоих моделях позволяет его проигнорировать.
Дискуссия по RFM Модели вероятности повторной покупки
Наконец, рассмотрим модель вероятности повторной покупки для последнего - 12-го квартала с использованием RFM данных, рассчитанных за предыдущие 11 кварталов. Кроме трех предикторов: recency_score, frequency_score и monetary_score в пробит-модель включены расходы на удержание клиента в 12 квартале и их квадрат: ret_expense и ret_expense_sq.
# RFM: Recency, Frequency and Monetary Value Analysis - Customer Level Data
# https://rdrr.io/cran/rfm/f/vignettes/rfm-customer-level-data.Rmd
library('rfm')
analysis_date <- lubridate::as_date((Sys.Date() - 91), tz = 'UTC')
CH04.rfm <- rfm_table_customer(data = customerRetentionTransactions %>%
filter(quarter < 12 & purchase == 1) %>%
group_by(customer) %>%
summarise(n_transactions = sum(purchase), recency_days = (11-max(quarter)) * 91,
total_revenue = sum(order_quantity) ),
customer_id = customer, n_transactions = n_transactions,
recency_days = recency_days, total_revenue = total_revenue,
analysis_date = lubridate::as_date((Sys.Date() - 91), tz = 'UTC'))
# RFM Score Charts
rfm_heatmap(CH04.rfm)
rfm_histograms(CH04.rfm)
# Scatter Plots
rfm_rm_plot(CH04.rfm) # Recency vs Monetary Value
rfm_fm_plot(CH04.rfm) # Frequency vs Monetary Value
rfm_rf_plot(CH04.rfm) # Recency vs Frequency
# 11 Segments of Customers
segment <- c(
"Champions", "Loyal Customers", "Potential Loyalist",
"New Customers", "Promising", "Need Attention",
"About To Sleep", "At Risk", "Can't Lose Them", "Hibernating",
"Lost"
)
description <- c(
"Bought recently, buy often and spend the most",
"Spend good money. Responsive to promotions",
"Recent customers, spent good amount, bought more than once",
"Bought more recently, but not often",
"Recent shoppers, but haven't spent much",
"Above average recency, frequency & monetary values",
"Below average recency, frequency & monetary values",
"Spent big money, purchased often but long time ago",
"Made big purchases and often, but long time ago",
"Low spenders, low frequency, purchased long time ago",
"Lowest recency, frequency & monetary scores"
)
recency <- c("4 - 5", "2 - 5", "3 - 5", "4 - 5", "3 - 4", "2 - 3", "2 - 3", "<= 2", "<= 1", "1 - 2", "<= 2")
frequency <- c("4 - 5", "3 - 5", "1 - 3", "<= 1", "<= 1", "2 - 3", "<= 2", "2 - 5", "4 - 5", "1 - 2", "<= 2")
monetary <- c("4 - 5", "3 - 5", "1 - 3", "<= 1", "<= 1", "2 - 3", "<= 2", "2 - 5", "4 - 5", "1 - 2", "<= 2")
segments <- tibble(
Segment = segment, Description = description,
R = recency, `F` = frequency, M = monetary
)
rfm_segments <- CH04.rfm %>%
magrittr::use_series(rfm) %>%
mutate(
segment = case_when(
(recency_score %>% between(4, 5)) & (frequency_score %>% between(4, 5)) &
(monetary_score %>% between(4, 5)) ~ "Champions",
(recency_score %>% between(2, 5)) & (frequency_score %>% between(3, 5)) &
(monetary_score %>% between(3, 5)) ~ "Loyal Customers",
(recency_score %>% between(3, 5)) & (frequency_score %>% between(1, 3)) &
(monetary_score %>% between(1, 3)) ~ "Potential Loyalist",
(recency_score %>% between(4, 5)) & (frequency_score == 1) &
(monetary_score == 1) ~ "New Customers",
(recency_score %>% between(3, 4)) & (frequency_score == 1) &
(monetary_score == 1) ~ "Promising",
(recency_score %>% between(2, 3)) & (frequency_score %>% between(2, 3)) &
(monetary_score %>% between(2, 3)) ~ "Needs Attention",
(recency_score %>% between(2, 3)) & (frequency_score <= 2) &
(monetary_score <= 2) ~ "About To Sleep",
(recency_score <= 2) & (frequency_score %>% between(2, 5)) &
(monetary_score %>% between(2, 5)) ~ "At Risk",
(recency_score == 1) & (frequency_score %>% between(4, 5)) &
(monetary_score %>% between(4, 5)) ~ "Cant Lose Them",
(recency_score %>% between(1, 2)) & (frequency_score %>% between(1, 2)) &
(monetary_score %>% between(1, 2)) ~ "Hibernating",
(recency_score <= 2) & (frequency_score <= 2) &
(monetary_score <= 2) ~ "Lost",
TRUE ~ "Others"
)
) %>%
dplyr::select(
customer_id, segment, rfm_score, transaction_count, recency_days,
amount
)
# use datatable
rfm_segments %>%
DT::datatable(
filter = "top",
options = list(pageLength = 5, autoWidth = TRUE),
colnames = c(
"Customer", "Segment", "RFM",
"Orders", "Recency", "Total Spend"
)
)rfm_top_segments <- rfm_segments %>%
count(segment) %>%
arrange(desc(n)) %>%
rename(Segment = segment, Count = n)
z <- bind_cols(CH04.rfm$rfm,
filter(customerRetentionTransactions, quarter == 12) %>%
dplyr::select(purchase, order_quantity, ret_expense, ret_expense_sq))
# Fit Probit Regression Model for Customer Repurchase (Recency, Frequency and Monetary Value Analysis)
set.seed(2018)
uno = 'probit'
Ch04RFM.pr <- train(factor(purchase) ~ # recency_score + frequency_score + monetary_score +
factor(rfm_score) + ret_expense + ret_expense_sq,
metric = 'Kappa', data = z, method = "glm", family = binomial(link = uno))
summary(Ch04RFM.pr)##
## Call:
## NULL
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.22552 -0.39918 -0.06823 0.41900 2.74856
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.360e+00 2.270e-01 -5.992 2.07e-09 ***
## `factor(rfm_score)211` -8.549e-02 4.808e-01 -0.178 0.8589
## `factor(rfm_score)212` -6.346e-01 5.439e-01 -1.167 0.2433
## `factor(rfm_score)221` -3.839e+00 1.569e+03 -0.002 0.9980
## `factor(rfm_score)222` -6.372e-01 3.996e-01 -1.595 0.1108
## `factor(rfm_score)223` -4.860e+00 3.465e+02 -0.014 0.9888
## `factor(rfm_score)232` -4.876e+00 8.684e+02 -0.006 0.9955
## `factor(rfm_score)233` -7.668e-01 5.418e-01 -1.415 0.1570
## `factor(rfm_score)311` -4.364e+00 5.501e+02 -0.008 0.9937
## `factor(rfm_score)312` -4.390e+00 1.109e+03 -0.004 0.9968
## `factor(rfm_score)321` -4.349e+00 9.677e+02 -0.004 0.9964
## `factor(rfm_score)322` -4.729e+00 5.310e+02 -0.009 0.9929
## `factor(rfm_score)323` -4.390e+00 1.569e+03 -0.003 0.9978
## `factor(rfm_score)333` -4.963e-01 4.186e-01 -1.186 0.2357
## `factor(rfm_score)334` -4.996e-02 5.612e-01 -0.089 0.9291
## `factor(rfm_score)343` -4.390e+00 1.569e+03 -0.003 0.9978
## `factor(rfm_score)344` -8.629e-01 5.298e-01 -1.629 0.1033
## `factor(rfm_score)411` -5.271e+00 1.569e+03 -0.003 0.9973
## `factor(rfm_score)422` -4.974e+00 1.569e+03 -0.003 0.9975
## `factor(rfm_score)432` -4.800e+00 7.466e+02 -0.006 0.9949
## `factor(rfm_score)433` -4.807e+00 7.146e+02 -0.007 0.9946
## `factor(rfm_score)434` -4.390e+00 1.569e+03 -0.003 0.9978
## `factor(rfm_score)443` -4.390e+00 1.569e+03 -0.003 0.9978
## `factor(rfm_score)444` -4.913e+00 5.185e+02 -0.009 0.9924
## `factor(rfm_score)445` -4.999e+00 6.947e+02 -0.007 0.9943
## `factor(rfm_score)511` 1.221e+00 6.666e-01 1.832 0.0669 .
## `factor(rfm_score)522` 2.578e+00 5.864e-01 4.396 1.10e-05 ***
## `factor(rfm_score)523` 6.259e+00 1.569e+03 0.004 0.9968
## `factor(rfm_score)532` 7.110e+00 1.109e+03 0.006 0.9949
## `factor(rfm_score)533` 1.949e+00 4.169e-01 4.675 2.93e-06 ***
## `factor(rfm_score)534` 1.851e+00 7.853e-01 2.358 0.0184 *
## `factor(rfm_score)543` 1.360e+00 6.665e-01 2.041 0.0413 *
## `factor(rfm_score)544` 2.106e+00 2.980e-01 7.068 1.58e-12 ***
## `factor(rfm_score)545` 2.739e+00 2.960e-01 9.252 < 2e-16 ***
## ret_expense 8.938e-02 2.054e-02 4.352 1.35e-05 ***
## ret_expense_sq -2.181e-03 4.689e-04 -4.652 3.29e-06 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 646.20 on 499 degrees of freedom
## Residual deviance: 258.81 on 464 degrees of freedom
## AIC: 330.81
##
## Number of Fisher Scoring iterations: 17# Odds Ratio Estimates and 95% CI
writeLines("\n Odds Ratio Estimates and 95% CI")##
## Odds Ratio Estimates and 95% CIcar::Confint(Ch04RFM.pr$finalModel) %>%
exp() %>%
arm::pfround(digits = 3)## Estimate 2.5 % 97.5 %
## (Intercept) 2.570000e-01 1.630000e-01 3.900000e-01
## `factor(rfm_score)211` 9.180000e-01 3.320000e-01 2.248000e+00
## `factor(rfm_score)212` 5.300000e-01 1.480000e-01 1.371000e+00
## `factor(rfm_score)221` 2.200000e-02 NA 1.290356e+137
## `factor(rfm_score)222` 5.290000e-01 2.270000e-01 1.103000e+00
## `factor(rfm_score)223` 8.000000e-03 NA 9.189290e+06
## `factor(rfm_score)232` 8.000000e-03 NA 1.149042e+47
## `factor(rfm_score)233` 4.640000e-01 1.350000e-01 1.205000e+00
## `factor(rfm_score)311` 1.300000e-02 NA 1.975876e+18
## `factor(rfm_score)312` 1.200000e-02 NA 4.727406e+73
## `factor(rfm_score)321` 1.300000e-02 NA 1.002179e+64
## `factor(rfm_score)322` 9.000000e-03 NA 2.777987e+17
## `factor(rfm_score)323` 1.200000e-02 NA 7.983937e+136
## `factor(rfm_score)333` 6.090000e-01 2.470000e-01 1.316000e+00
## `factor(rfm_score)334` 9.510000e-01 2.720000e-01 2.605000e+00
## `factor(rfm_score)343` 1.200000e-02 NA 7.983937e+136
## `factor(rfm_score)344` 4.220000e-01 1.230000e-01 1.064000e+00
## `factor(rfm_score)411` 5.000000e-03 NA 3.303913e+136
## `factor(rfm_score)422` 7.000000e-03 NA 4.426569e+136
## `factor(rfm_score)432` 8.000000e-03 NA 1.147935e+35
## `factor(rfm_score)433` 8.000000e-03 NA 2.888606e+33
## `factor(rfm_score)434` 1.200000e-02 NA 7.983937e+136
## `factor(rfm_score)443` 1.200000e-02 NA 7.983937e+136
## `factor(rfm_score)444` 7.000000e-03 NA 8.141016e+16
## `factor(rfm_score)445` 7.000000e-03 NA 2.457549e+32
## `factor(rfm_score)511` 3.392000e+00 8.930000e-01 1.298200e+01
## `factor(rfm_score)522` 1.317300e+01 4.627000e+00 4.878600e+01
## `factor(rfm_score)523` 5.225490e+02 0.000000e+00 NA
## `factor(rfm_score)532` 1.224488e+03 0.000000e+00 NA
## `factor(rfm_score)533` 7.022000e+00 3.160000e+00 1.645400e+01
## `factor(rfm_score)534` 6.369000e+00 1.410000e+00 3.363400e+01
## `factor(rfm_score)543` 3.898000e+00 1.049000e+00 1.453800e+01
## `factor(rfm_score)544` 8.215000e+00 4.662000e+00 1.493000e+01
## `factor(rfm_score)545` 1.546800e+01 8.886000e+00 2.811500e+01
## ret_expense 1.093000e+00 1.051000e+00 1.141000e+00
## ret_expense_sq 9.980000e-01 9.970000e-01 9.990000e-01# Logistic regression diagnostics
writeLines("\n Wald test of predictors")##
## Wald test of predictorscar::Anova(Ch04RFM.pr$finalModel, type="II", test="Wald")## Analysis of Deviance Table (Type II tests)
##
## Response: .outcome
## Df Chisq Pr(>Chisq)
## `factor(rfm_score)211` 1 0.0316 0.85888
## `factor(rfm_score)212` 1 1.3611 0.24334
## `factor(rfm_score)221` 1 0.0000 0.99805
## `factor(rfm_score)222` 1 2.5425 0.11082
## `factor(rfm_score)223` 1 0.0002 0.98881
## `factor(rfm_score)232` 1 0.0000 0.99552
## `factor(rfm_score)233` 1 2.0030 0.15699
## `factor(rfm_score)311` 1 0.0001 0.99367
## `factor(rfm_score)312` 1 0.0000 0.99684
## `factor(rfm_score)321` 1 0.0000 0.99641
## `factor(rfm_score)322` 1 0.0001 0.99289
## `factor(rfm_score)323` 1 0.0000 0.99777
## `factor(rfm_score)333` 1 1.4060 0.23573
## `factor(rfm_score)334` 1 0.0079 0.92906
## `factor(rfm_score)343` 1 0.0000 0.99777
## `factor(rfm_score)344` 1 2.6531 0.10335
## `factor(rfm_score)411` 1 0.0000 0.99732
## `factor(rfm_score)422` 1 0.0000 0.99747
## `factor(rfm_score)432` 1 0.0000 0.99487
## `factor(rfm_score)433` 1 0.0000 0.99463
## `factor(rfm_score)434` 1 0.0000 0.99777
## `factor(rfm_score)443` 1 0.0000 0.99777
## `factor(rfm_score)444` 1 0.0001 0.99244
## `factor(rfm_score)445` 1 0.0001 0.99426
## `factor(rfm_score)511` 1 3.3568 0.06693 .
## `factor(rfm_score)522` 1 19.3274 1.101e-05 ***
## `factor(rfm_score)523` 1 0.0000 0.99682
## `factor(rfm_score)532` 1 0.0000 0.99488
## `factor(rfm_score)533` 1 21.8595 2.934e-06 ***
## `factor(rfm_score)534` 1 5.5588 0.01839 *
## `factor(rfm_score)543` 1 4.1656 0.04125 *
## `factor(rfm_score)544` 1 49.9501 1.577e-12 ***
## `factor(rfm_score)545` 1 85.5985 < 2.2e-16 ***
## ret_expense 1 18.9377 1.351e-05 ***
## ret_expense_sq 1 21.6395 3.290e-06 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1writeLines("\n Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with others")##
## Variance Inflation Factors - if vif() > 2 - feature has multicollinearity with otherscar::vif(Ch04RFM.pr$finalModel) # Variance Inflation Factors - if vif() > 2 - feature has multicollinearity## `factor(rfm_score)211` `factor(rfm_score)212` `factor(rfm_score)221` `factor(rfm_score)222` `factor(rfm_score)223`
## 1.151941 1.118274 1.000000 1.238242 1.000000
## `factor(rfm_score)232` `factor(rfm_score)233` `factor(rfm_score)311` `factor(rfm_score)312` `factor(rfm_score)321`
## 1.000000 1.123019 1.000000 1.000000 1.000000
## `factor(rfm_score)322` `factor(rfm_score)323` `factor(rfm_score)333` `factor(rfm_score)334` `factor(rfm_score)343`
## 1.000000 1.000000 1.213434 1.137903 1.000000
## `factor(rfm_score)344` `factor(rfm_score)411` `factor(rfm_score)422` `factor(rfm_score)432` `factor(rfm_score)433`
## 1.123669 1.000000 1.000000 1.000000 1.000000
## `factor(rfm_score)434` `factor(rfm_score)443` `factor(rfm_score)444` `factor(rfm_score)445` `factor(rfm_score)511`
## 1.000000 1.000000 1.000000 1.000000 1.084532
## `factor(rfm_score)522` `factor(rfm_score)523` `factor(rfm_score)532` `factor(rfm_score)533` `factor(rfm_score)534`
## 1.129375 1.000000 1.000000 1.272553 1.079375
## `factor(rfm_score)543` `factor(rfm_score)544` `factor(rfm_score)545` ret_expense ret_expense_sq
## 1.109381 1.714961 1.912317 15.257243 15.403409writeLines("\n Variable Importance for Model \n")##
## Variable Importance for Modelcaret::varImp(Ch04RFM.pr) %>% .$importance %>% print.AsIs()## Overall
## `factor(rfm_score)211` 1.895869e+00
## `factor(rfm_score)212` 1.258694e+01
## `factor(rfm_score)221` 0.000000e+00
## `factor(rfm_score)222` 1.721245e+01
## `factor(rfm_score)223` 1.251631e-01
## `factor(rfm_score)232` 3.423878e-02
## `factor(rfm_score)233` 1.527471e+01
## `factor(rfm_score)311` 5.932194e-02
## `factor(rfm_score)312` 1.632945e-02
## `factor(rfm_score)321` 2.213085e-02
## `factor(rfm_score)322` 6.983384e-02
## `factor(rfm_score)323` 3.796830e-03
## `factor(rfm_score)333` 1.279303e+01
## `factor(rfm_score)334` 9.360576e-01
## `factor(rfm_score)343` 3.796830e-03
## `factor(rfm_score)344` 1.758345e+01
## `factor(rfm_score)411` 9.870055e-03
## `factor(rfm_score)422` 7.822558e-03
## `factor(rfm_score)432` 4.304101e-02
## `factor(rfm_score)433` 4.627397e-02
## `factor(rfm_score)434` 3.796830e-03
## `factor(rfm_score)443` 3.796830e-03
## `factor(rfm_score)444` 7.597342e-02
## `factor(rfm_score)445` 5.133904e-02
## `factor(rfm_score)511` 1.978176e+01
## `factor(rfm_score)522` 4.750362e+01
## `factor(rfm_score)523` 1.668032e-02
## `factor(rfm_score)532` 4.285032e-02
## `factor(rfm_score)533` 5.052127e+01
## `factor(rfm_score)534` 2.546362e+01
## `factor(rfm_score)543` 2.203941e+01
## `factor(rfm_score)544` 7.638354e+01
## `factor(rfm_score)545` 1.000000e+02
## ret_expense 4.702200e+01
## ret_expense_sq 5.026626e+01# # Create the scatter plots Probit versus model predictors
# predictors <- Ch04RFM.pr$coefnames
# Ch04RFM.pr$trainingData %>%
# dplyr::select(one_of(predictors)) %>%
# mutate(link = predict(Ch04RFM.pr$finalModel, newdata = z, type = "link")) %>%
# gather(key = "predictors", value = "predictor.value", -link) %>%
# ggplot(aes(predictor.value, link))+
# geom_point(size = 0.05, alpha = 0.05) +
# geom_smooth(method = "loess") +
# facet_wrap(~ predictors, scales = "free_x") +
# ylab(stringr::str_to_title(uno))
#
#
# # Plot matrix of statistical model diagnostics
# GGally::ggnostic(Ch04RFM.pr$finalModel, title = paste(paste(formula(Ch04RFM.pr)[c(2, 1, 3)], collapse = " ")))
#
# # wide variety of diagnostic plots for checking the quality of regression fit
# # https://bookdown.org/jefftemplewebb/IS-6489/logistic-regression.html
# car::influenceIndexPlot(Ch04RFM.pr$finalModel)
caret::confusionMatrix(data = predict((Ch04RFM.pr), newdata = z),
reference = z$purchase %>% factor,
positive = "1", mode = "everything")## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 299 24
## 1 27 150
##
## Accuracy : 0.898
## 95% CI : (0.8681, 0.9231)
## No Information Rate : 0.652
## P-Value [Acc > NIR] : <2e-16
##
## Kappa : 0.7761
## Mcnemar's Test P-Value : 0.7794
##
## Sensitivity : 0.8621
## Specificity : 0.9172
## Pos Pred Value : 0.8475
## Neg Pred Value : 0.9257
## Precision : 0.8475
## Recall : 0.8621
## F1 : 0.8547
## Prevalence : 0.3480
## Detection Rate : 0.3000
## Detection Prevalence : 0.3540
## Balanced Accuracy : 0.8896
##
## 'Positive' Class : 1
## Ниже представлены гистограмма сегментов в полярных координатах и классический вариант графика “Итогового RFM Отчета”.
d = data_frame(ID = c(11, 2, 3, 4, 5, 6, 7, 8, 9, 10, 1),
x1 = c(0, 2, 3, 4, 3, 2, 2, 0, 0, 1, 4), x2 = c(2, 5, 5, 5, 4, 3, 3, 2, 1, 2, 5),
y1 = c(0, 3, 1, 0, 0, 2, 0, 2, 4, 1, 4), y2 = c(2, 5, 3, 1, 1, 3, 2, 5, 5, 2, 5),
t = c('Lost', 'Loyal Customers', 'Potential Loyalist', 'New Customers', 'Promising',
'Needs Attention', 'About To Sleep', 'At Risk', 'Can`t Lose Them', 'Hibernating', 'Champions'))
segmentcolors <- c('slategray3', 'lightgoldenrod1', 'violet', 'chartreuse', 'lightcyan2', 'cadetblue3', 'darkseagreen1', 'turquoise3', 'pink', 'darkslategray1', 'lightskyblue2')
d <- d %>%
dplyr::full_join(rfm_top_segments, by = c("t" = "Segment")) %>%
mutate(Count = coalesce(Count, 0L), a = Count / sum(Count),
l = paste0(t, if_else(Count == 0, sprintf(" %.0f", Count),
sprintf("\n%.0f (%.1f%%)", Count, a * 100)))) %>%
arrange(ID)
## 1. Plotting of Correlation Matrix for Feartures
library("GGally")##
## Attaching package: 'GGally'## The following object is masked from 'package:dplyr':
##
## nasaRFMLabels <- c("Recency", "Frequency", "Monetary")
p <- z %>%
dplyr::select(recency_score:monetary_score) %>%
GGally::ggpairs(., xlab = "Scores", ylab = "Scores",
title = "Correlations Between Scores",
lower = list(continuous = wrap("smooth_loess", alpha = 0.3),
combo = wrap("dot_no_facet", alpha = 0.4)),
columnLabels = RFMLabels)
p[2, 1] <- z %>% # Recency vs. Frequency
ggplot(aes(x = recency_score, y = frequency_score)) +
stat_smooth(method = 'loess', col = 'coral') +
geom_jitter(aes(color = rfm_segments$segment), width = 0.2, height = 0.2) +
scale_color_manual(values = segmentcolors, breaks = d$l)
p[3, 1] <- z %>% # Recency vs. Monetary
ggplot(aes(x = recency_score, y = monetary_score)) +
stat_smooth(method = 'loess', col = 'dodgerblue') +
geom_jitter(aes(color = rfm_segments$segment), width = 0.2, height = 0.2) +
scale_color_manual(values = segmentcolors, breaks = d$l)
p[3, 2] <- z %>% # Frequency vs. Monetary
ggplot(aes(x = frequency_score, y = monetary_score)) +
stat_smooth(method = 'loess', col = 'gold') +
geom_jitter(aes(color = rfm_segments$segment), width = 0.2, height = 0.2) +
scale_color_manual(values = segmentcolors, breaks = d$l)
p[1, 1] <- z %>%
ggplot(aes(recency_score)) +
stat_density(fill = 'coral')
p[2, 2] <- z %>%
ggplot(aes(frequency_score)) +
stat_density(fill = 'dodgerblue')
p[3, 3] <- z %>%
ggplot(aes(monetary_score)) +
stat_density(fill = 'gold')
p
# Compute hierarchical clustering of clients
K = 5
cln.hc <- z %>% filter(frequency_score > 0) %>%
# scale() %>% # Scale the data
dist(method = "euclidean") %>% # Compute dissimilarity matrix
hclust(method = "ward.D") # Compute hierachical clustering
z <- z %>% mutate(clusters = cutree(cln.hc, k = K))
# Print of The Hierarchical Clustering of Clients by RFM Model
library('kableExtra') # Construct Complex Table with 'kable' and Pipe Syntax
library('formattable') # Create 'Formattable' Data Structures##
## Attaching package: 'formattable'## The following object is masked from 'package:MASS':
##
## areabind_cols( z %>% group_by(clusters) %>%
summarise(count = n()),
z %>% group_by(clusters) %>%
summarise_at(.vars = vars(recency_score:monetary_score),
.funs = c(Mean = "mean", Sd = "sd")) %>%
.[, -1]) %>%
mutate(clusters = cell_spec(clusters, "html",
color = ifelse(count <= (arrange(., count)[1, 'count'] %>% as.numeric), "red", "auto")),
count = color_bar("thistle")(accounting(count, digits = 0)),
recency_score_Mean = color_tile("ivory1", "coral")(digits(recency_score_Mean, digits = 2)),
frequency_score_Mean = color_tile("thistle1", "dodgerblue")(digits(frequency_score_Mean, digits = 2)),
monetary_score_Mean = color_tile("chartreuse", "gold")(digits(monetary_score_Mean, digits = 2)),
recency_score_Sd, frequency_score_Sd, monetary_score_Sd
) %>%
kable(format = "html", digits = c(0, 0, 2, 2, 2, 2, 2, 2), longtable = TRUE, booktabs = TRUE, escape = F,
col.names = c("No Clusters", "Counts of Clients", "Recency Scores", "Frequency Scores",
"Monetary Scores", "Recency Scores", "Frequency Scores", "Monetary Scores"),
caption="The Hierarchical Clustering of Clients by RFM Model") %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive", full_width = FALSE)) %>%
column_spec(2, width = "4 cm") %>%
add_header_above(c(" ", " ", "Mean Of" = 3, "Standard Deviation Of" = 3)) %>%
group_rows(index = c("Low" = 2, "High" = 2, "Mid" = 1))| No Clusters | Counts of Clients | Recency Scores | Frequency Scores | Monetary Scores | Recency Scores | Frequency Scores | Monetary Scores |
|---|---|---|---|---|---|---|---|
| Low | |||||||
| 1 | 58 | 2.50 | 2.02 | 2.17 | 1.17 | 0.85 | 0.90 |
| 2 | 209 | 2.22 | 1.66 | 1.80 | 1.21 | 0.75 | 0.76 |
| High | |||||||
| 3 | 136 | 4.78 | 3.99 | 4.65 | 0.57 | 0.09 | 0.48 |
| 4 | 25 | 4.68 | 3.92 | 4.44 | 0.69 | 0.28 | 0.51 |
| Mid | |||||||
| 5 | 72 | 3.47 | 3.43 | 3.50 | 0.99 | 0.50 | 0.50 |
# 2. Plotting of Clients Dendrogram by RFM scores in K groups and color by Clusters
library('factoextra') # Extract and Visualize the Results of Multivariate Data Analyses## Welcome! Related Books: `Practical Guide To Cluster Analysis in R` at https://goo.gl/13EFCZdend <- fviz_dend(cln.hc, k = K, # Cut in K Clusters
cex = 0.5, # label size
k_colors = c("deepskyblue", "deepskyblue3", "yellow3", "goldenrod", "gold"),
show_labels = FALSE,
color_labels_by_k = TRUE, # color labels by groups
main = "Dendrogram of clusters", xlab = "Clients", ylab = "Distance",
rect = TRUE) # Add rectangle around groups
dend + annotate("text", x = c(35, 140, 310, 430, 470), y = rep(-15000, 5),
label = c("Five\ncluster", "Three\ncluster", "Second\ncluster", "Four\nclus.", "First\ncluster"))
# 3. Plotting Customer Clusters by Interactive Web Graphics using plotly
library('plotly')##
## Attaching package: 'plotly'## The following object is masked from 'package:formattable':
##
## style## The following object is masked from 'package:MASS':
##
## select## The following object is masked from 'package:ggplot2':
##
## last_plot## The following object is masked from 'package:stats':
##
## filter## The following object is masked from 'package:graphics':
##
## layoutplot_ly(data = z, x = z$recency_score + rnorm(500) / 8, y = z$monetary_score + rnorm(500) / 8,
z = z$frequency_score + rnorm(500)/8, type = "scatter3d", mode = "markers", color = cutree(cln.hc, k = K)) %>%
layout(title = "Customer clustering",
scene = list(xaxis = list(title = "Recency"),
yaxis = list(title = "Monetary"),
zaxis = list(title = "Frequency"),
camera = list(eye = list(x = 1, y = 2, z = -1),
center = list(x = 0, y = 0, z = 0)))
)# 4. Plotting The RFM Polar Report
ggplot(d, aes(x = ID, y = Count, fill = l)) +
geom_bar(width = 1, stat = "identity", color = "white") +
scale_fill_manual(values = segmentcolors, name = "Segments", breaks = rev(d$l),
guide = guide_legend(label.theme = element_text(size = 8, angle = 0))) +
theme(axis.ticks = element_blank(),
axis.text = element_blank(),
axis.title = element_blank(),
axis.line = element_blank()) +
geom_text(data = filter(d, Count > 0), aes(label = l), lineheight = 0.8, size = 3, show.legend = FALSE) +
coord_polar() +
ggtitle("RFM Polar Report")
# 5. Plotting The RFM Summary Report
ggplot() +
geom_rect(data = d, aes(xmin = x1, xmax = x2, ymin = y1, ymax = y2, fill = t), color = "dark gray",
alpha = if_else(d$a == 0, 1 / max(d$a) * min(d$a[d$a > 0]) - 0.01, 1 / max(d$a) * d$a) ) +
geom_text(data = d, aes(x = x1 + (x2 - x1) / 2, y = y1 + (y2 - y1) / 2 + if_else(t == 'Lost', -0.3, 0),
label = l), size = 4) +
scale_fill_manual(values = segmentcolors, name="Segments") +
labs(title = "RFM Summary Report", x = "Recency Score", y = "Frequency Score") +
theme_classic() + theme(legend.position="none")
Как видно во многих категориях клиенты не представлены. И если отсутствие в группах ‘At Risk’, ‘Can`t Lose Them’ или ‘Lost’ не вызывает опасений, то нули в ‘New Customers’ либо ‘Promising’ должно настораживать.
Как это использовать?
Основная задача менеджмента переводить клиентов из голубых и розовых зон в зеленную зону.
Что касается новых (розовых) клиентов, то важнейший пункт - вернуть покупателей за второй покупкой — обратиться к ним как можно быстрее. Но не слишком рано и весьма деликатно. Что включить в содержание письма:
Текст: «Поздравляем с первой покупкой»
Подборка: «Персональные товарные рекомендации»
Баннер: «Знакомство с категориями»
Блок: «Описание Программы лояльности»
Некоторыми шагами могут стать:
Реактивация клиента (для фиолетовых и красных клиентов, склонных к уходу в отток), направлять 1 раз в месяц. “Мы соскучились. Вот вам суперскидка на 3 дня”.
Клиентам, которым необходимо внимание направить специальное предложение, котоырей действует 1-2 дня.
Для перспективных клиентов голубой и бледно-зеленой зоны направить сообщение “Вам может понравиться этот товар”, а также периодически рассылать обзор “Знакомство с категориями”, “Знакомство с новинками”.
Для зеленых, самых лояльных клиентов, предложение дать рекомендациии фирме.
Триггеры для всех клиентов:
брошенная корзина, положил товар в корзину, но через 30 минут так ничего не купил;
брошенный просмотр, смотрел товары, но ничего в корзину не положил;
прошенный поиск, искал на сайте, придя по поисковику или каталогу, но ничего не положил в корзину.
devtools::session_info()## Session info ----------------------------------------------------------------------------------------------------------## setting value
## version R version 3.5.0 (2018-04-23)
## system x86_64, mingw32
## ui RTerm
## language (EN)
## collate Russian_Russia.1251
## tz Asia/Dhaka
## date 2018-07-20## Packages --------------------------------------------------------------------------------------------------------------## package * version date source
## abind 1.4-5 2016-07-21 CRAN (R 3.5.0)
## arm 1.10-1 2018-04-13 CRAN (R 3.5.0)
## assertthat 0.2.0 2017-04-11 CRAN (R 3.5.0)
## backports 1.1.2 2017-12-13 CRAN (R 3.5.0)
## base * 3.5.0 2018-04-23 local
## bindr 0.1.1 2018-03-13 CRAN (R 3.5.0)
## bindrcpp * 0.2.2 2018-03-29 CRAN (R 3.5.0)
## bit 1.1-13 2018-05-15 CRAN (R 3.5.0)
## bit64 0.9-7 2017-05-08 CRAN (R 3.5.0)
## blob 1.1.1 2018-03-25 CRAN (R 3.5.0)
## broom 0.4.4 2018-03-29 CRAN (R 3.5.0)
## BTYD * 2.4 2014-11-07 CRAN (R 3.5.0)
## car * 3.0-0 2018-04-02 CRAN (R 3.5.0)
## carData * 3.0-1 2018-03-28 CRAN (R 3.5.0)
## caret * 6.0-79 2018-03-29 CRAN (R 3.5.0)
## cellranger 1.1.0 2016-07-27 CRAN (R 3.5.0)
## chron 2.3-52 2018-01-06 CRAN (R 3.5.0)
## class 7.3-14 2015-08-30 CRAN (R 3.5.0)
## cli 1.0.0 2017-11-05 CRAN (R 3.5.0)
## cluster 2.0.7-1 2018-04-13 CRAN (R 3.5.0)
## coda 0.19-1 2016-12-08 CRAN (R 3.5.0)
## codetools 0.2-15 2016-10-05 CRAN (R 3.5.0)
## colorspace 1.3-2 2016-12-14 CRAN (R 3.5.0)
## compiler 3.5.0 2018-04-23 local
## contfrac 1.1-12 2018-05-17 CRAN (R 3.5.0)
## crayon 1.3.4 2017-09-16 CRAN (R 3.5.0)
## crosstalk 1.0.0 2016-12-21 CRAN (R 3.5.0)
## curl 3.2 2018-03-28 CRAN (R 3.5.0)
## CVST 0.2-1 2013-12-10 CRAN (R 3.5.0)
## data.table 1.11.2 2018-05-08 CRAN (R 3.5.0)
## datasets * 3.5.0 2018-04-23 local
## DBI 1.0.0 2018-05-02 CRAN (R 3.5.0)
## ddalpha 1.3.3 2018-04-30 CRAN (R 3.5.0)
## dendextend 1.8.0 2018-05-03 CRAN (R 3.5.0)
## DEoptimR 1.0-8 2016-11-19 CRAN (R 3.5.0)
## deSolve 1.21 2018-05-09 CRAN (R 3.5.0)
## devtools 1.13.5 2018-02-18 CRAN (R 3.5.0)
## digest 0.6.15 2018-01-28 CRAN (R 3.5.0)
## dimRed 0.1.0 2017-05-04 CRAN (R 3.5.0)
## diptest 0.75-7 2016-12-05 CRAN (R 3.5.0)
## dplyr * 0.7.5 2018-05-19 CRAN (R 3.5.0)
## DRR 0.0.3 2018-01-06 CRAN (R 3.5.0)
## DT 0.4 2018-01-30 CRAN (R 3.5.0)
## e1071 1.6-8 2017-02-02 CRAN (R 3.5.0)
## elliptic 1.3-7 2016-05-26 CRAN (R 3.5.0)
## evaluate 0.10.1 2017-06-24 CRAN (R 3.5.0)
## factoextra * 1.0.5 2017-08-22 CRAN (R 3.5.0)
## fitdistrplus * 1.0-9 2017-03-24 CRAN (R 3.5.0)
## flexmix 2.3-14 2017-04-28 CRAN (R 3.5.0)
## forcats * 0.3.0 2018-02-19 CRAN (R 3.5.0)
## foreach 1.4.4 2017-12-12 CRAN (R 3.5.0)
## forecast 8.3 2018-04-11 CRAN (R 3.5.0)
## foreign 0.8-70 2017-11-28 CRAN (R 3.5.0)
## formattable * 0.2.0.1 2016-08-05 CRAN (R 3.5.0)
## fpc 2.1-11 2018-01-13 CRAN (R 3.5.0)
## fracdiff 1.4-2 2012-12-02 CRAN (R 3.5.0)
## geometry 0.3-6 2015-09-09 CRAN (R 3.5.0)
## GGally * 1.4.0 2018-05-17 CRAN (R 3.5.0)
## ggplot2 * 2.2.1 2016-12-30 CRAN (R 3.5.0)
## ggpubr 0.1.6 2017-11-14 CRAN (R 3.5.0)
## ggrepel 0.8.0 2018-05-09 CRAN (R 3.5.0)
## glue 1.2.0 2017-10-29 CRAN (R 3.5.0)
## gower 0.1.2 2017-02-23 CRAN (R 3.5.0)
## graphics * 3.5.0 2018-04-23 local
## grDevices * 3.5.0 2018-04-23 local
## grid 3.5.0 2018-04-23 local
## gridExtra 2.3 2017-09-09 CRAN (R 3.5.0)
## gsubfn * 0.7 2018-03-16 CRAN (R 3.5.0)
## gtable 0.2.0 2016-02-26 CRAN (R 3.5.0)
## haven 1.1.1 2018-01-18 CRAN (R 3.5.0)
## highr 0.6 2016-05-09 CRAN (R 3.5.0)
## hms 0.4.2 2018-03-10 CRAN (R 3.5.0)
## htmltools 0.3.6 2017-04-28 CRAN (R 3.5.0)
## htmlwidgets 1.2 2018-04-19 CRAN (R 3.5.0)
## httpuv 1.4.3 2018-05-10 CRAN (R 3.5.0)
## httr 1.3.1 2017-08-20 CRAN (R 3.5.0)
## hypergeo * 1.2-13 2016-04-07 CRAN (R 3.5.0)
## ipred 0.9-6 2017-03-01 CRAN (R 3.5.0)
## iterators 1.0.9 2017-12-12 CRAN (R 3.5.0)
## jsonlite 1.5 2017-06-01 CRAN (R 3.5.0)
## kableExtra * 0.9.0 2018-05-21 CRAN (R 3.5.0)
## kernlab 0.9-26 2018-04-30 CRAN (R 3.5.0)
## knitr 1.20 2018-02-20 CRAN (R 3.5.0)
## labeling 0.3 2014-08-23 CRAN (R 3.5.0)
## later 0.7.2 2018-05-01 CRAN (R 3.5.0)
## lattice * 0.20-35 2017-03-25 CRAN (R 3.5.0)
## lava 1.6.1 2018-03-28 CRAN (R 3.5.0)
## lazyeval 0.2.1 2017-10-29 CRAN (R 3.5.0)
## lme4 1.1-17 2018-04-03 CRAN (R 3.5.0)
## lmtest 0.9-36 2018-04-04 CRAN (R 3.5.0)
## lubridate 1.7.4 2018-04-11 CRAN (R 3.5.0)
## magic 1.5-8 2018-01-26 CRAN (R 3.5.0)
## magrittr 1.5 2014-11-22 CRAN (R 3.5.0)
## MASS * 7.3-49 2018-02-23 CRAN (R 3.5.0)
## Matrix 1.2-14 2018-04-13 CRAN (R 3.5.0)
## mclust 5.4 2017-11-22 CRAN (R 3.5.0)
## memoise 1.1.0 2017-04-21 CRAN (R 3.5.0)
## methods * 3.5.0 2018-04-23 local
## mgcv 1.8-23 2018-01-21 CRAN (R 3.5.0)
## mime 0.5 2016-07-07 CRAN (R 3.5.0)
## minqa 1.2.4 2014-10-09 CRAN (R 3.5.0)
## mnormt 1.5-5 2016-10-15 CRAN (R 3.5.0)
## ModelMetrics 1.1.0 2016-08-26 CRAN (R 3.5.0)
## modelr 0.1.2 2018-05-11 CRAN (R 3.5.0)
## modeltools 0.2-21 2013-09-02 CRAN (R 3.5.0)
## munsell 0.4.3 2016-02-13 CRAN (R 3.5.0)
## mvtnorm 1.0-7 2018-01-25 CRAN (R 3.5.0)
## nlme 3.1-137 2018-04-07 CRAN (R 3.5.0)
## nloptr 1.0.4 2017-08-22 CRAN (R 3.5.0)
## nnet 7.3-12 2016-02-02 CRAN (R 3.5.0)
## openxlsx 4.0.17 2017-03-23 CRAN (R 3.5.0)
## parallel 3.5.0 2018-04-23 local
## pillar 1.2.2 2018-04-26 CRAN (R 3.5.0)
## pkgconfig 2.0.1 2017-03-21 CRAN (R 3.5.0)
## plotly * 4.7.1 2017-07-29 CRAN (R 3.5.0)
## plyr 1.8.4 2016-06-08 CRAN (R 3.5.0)
## prabclus 2.2-6 2015-01-14 CRAN (R 3.5.0)
## prodlim 2018.04.18 2018-04-18 CRAN (R 3.5.0)
## promises 1.0.1 2018-04-13 CRAN (R 3.5.0)
## proto * 1.0.0 2016-10-29 CRAN (R 3.5.0)
## psych 1.8.4 2018-05-06 CRAN (R 3.5.0)
## purrr * 0.2.4 2017-10-18 CRAN (R 3.5.0)
## quadprog 1.5-5 2013-04-17 CRAN (R 3.5.0)
## quantmod 0.4-13 2018-04-13 CRAN (R 3.5.0)
## R6 2.2.2 2017-06-17 CRAN (R 3.5.0)
## RColorBrewer 1.1-2 2014-12-07 CRAN (R 3.5.0)
## Rcpp 0.12.17 2018-05-18 CRAN (R 3.5.0)
## RcppRoll 0.2.2 2015-04-05 CRAN (R 3.5.0)
## readr * 1.1.1 2017-05-16 CRAN (R 3.5.0)
## readxl 1.1.0 2018-04-20 CRAN (R 3.5.0)
## recipes 0.1.2 2018-01-11 CRAN (R 3.5.0)
## reshape 0.8.7 2017-08-06 CRAN (R 3.5.0)
## reshape2 1.4.3 2017-12-11 CRAN (R 3.5.0)
## rfm * 0.1.0 2018-04-09 CRAN (R 3.5.0)
## rio 0.5.10 2018-03-29 CRAN (R 3.5.0)
## rlang 0.2.0 2018-02-20 CRAN (R 3.5.0)
## rmarkdown 1.9 2018-03-01 CRAN (R 3.5.0)
## robustbase 0.93-0 2018-04-24 CRAN (R 3.5.0)
## rpart 4.1-13 2018-02-23 CRAN (R 3.5.0)
## rprojroot 1.3-2 2018-01-03 CRAN (R 3.5.0)
## RSQLite * 2.1.1 2018-05-06 CRAN (R 3.5.0)
## rstudioapi 0.7 2017-09-07 CRAN (R 3.5.0)
## rvest 0.3.2 2016-06-17 CRAN (R 3.5.0)
## scales 0.5.0 2017-08-24 CRAN (R 3.5.0)
## sfsmisc 1.1-2 2018-03-05 CRAN (R 3.5.0)
## shiny 1.1.0 2018-05-17 CRAN (R 3.5.0)
## splines * 3.5.0 2018-04-23 local
## sqldf * 0.4-11 2017-06-28 CRAN (R 3.5.0)
## stats * 3.5.0 2018-04-23 local
## stats4 * 3.5.0 2018-04-23 local
## stringi 1.1.7 2018-03-12 CRAN (R 3.5.0)
## stringr * 1.3.1 2018-05-10 CRAN (R 3.5.0)
## survival * 2.41-3 2017-04-04 CRAN (R 3.5.0)
## tcltk 3.5.0 2018-04-23 local
## tibble * 1.4.2 2018-01-22 CRAN (R 3.5.0)
## tidyr * 0.8.1 2018-05-18 CRAN (R 3.5.0)
## tidyselect 0.2.4 2018-02-26 CRAN (R 3.5.0)
## tidyverse * 1.2.1 2017-11-14 CRAN (R 3.5.0)
## timeDate 3043.102 2018-02-21 CRAN (R 3.5.0)
## tools 3.5.0 2018-04-23 local
## trimcluster 0.1-2 2012-10-29 CRAN (R 3.5.0)
## tseries 0.10-44 2018-04-15 CRAN (R 3.5.0)
## TTR 0.23-3 2018-01-24 CRAN (R 3.5.0)
## urca 1.3-0 2016-09-06 CRAN (R 3.5.0)
## uroot 2.0-9 2017-01-29 CRAN (R 3.5.0)
## utils * 3.5.0 2018-04-23 local
## VGAM * 1.0-5 2018-02-07 CRAN (R 3.5.0)
## viridis 0.5.1 2018-03-29 CRAN (R 3.5.0)
## viridisLite 0.3.0 2018-02-01 CRAN (R 3.5.0)
## whisker 0.3-2 2013-04-28 CRAN (R 3.5.0)
## withr 2.1.2 2018-03-15 CRAN (R 3.5.0)
## xml2 1.2.0 2018-01-24 CRAN (R 3.5.0)
## xtable 1.8-2 2016-02-05 CRAN (R 3.5.0)
## xts 0.10-2 2018-03-14 CRAN (R 3.5.0)
## yaml 2.1.19 2018-05-01 CRAN (R 3.5.0)
## zoo 1.8-1 2018-01-08 CRAN (R 3.5.0)Выводы по главе 4
Цель этой главы состояла в том, чтобы изучить эконометрические модели удержания клиентов и предоставить некоторые эмпирические примеры того, как фирмы могут применять эти знания к своим собственным базам данных клиентов. И авторы показали, что когда фирмы могут понять каждый аспектов удержания клиентов, то они могут эффективно управлять своими текущими клиентами для получения прибыли.