Churn Analysis
Методи Симеонов
6/13/2021
Синопсис
Пазарът на телекомуникационни услуги в страната е наситен, а темповете на растеж на клиентската база са ниски. Следователно основният фокус на телекомите би следвало да е върху задържането на текущата клеинтска база. Този проект изследва извадка от данни като целта му е да идентифицира ключови предиктори за напускането на клиенти и да изготви добър прогнозен модел за предвиждане на отлива на клиенти. Предложението се оценява спрямо няколко различни по тип модела, използвайки стандартни и утвърдени метрики.
library(tidyverse)
library(plyr)
library(lubridate)
library(skimr)
library(visdat)
library(naniar)
library(simputation)
library(correlationfunnel)
library(DataExplorer)
library(gridExtra)
library(corrplot)
library(gridExtra)
library(pROC)
library(C50)
library(caret)
library(rpart)
library(WRS2)
library(afex)
library(ggthemes)
library(ggstatsplot)SDV_DAT_JAN <- read.csv("SDV_DAT_JAN.csv", header = TRUE, sep =";")skim(SDV_DAT_JAN)| Name | SDV_DAT_JAN |
| Number of rows | 500000 |
| Number of columns | 47 |
| _______________________ | |
| Column type frequency: | |
| character | 15 |
| logical | 1 |
| numeric | 31 |
| ________________________ | |
| Group variables | None |
Variable type: character
| skim_variable | n_missing | complete_rate | min | max | empty | n_unique | whitespace |
|---|---|---|---|---|---|---|---|
| PP_GROUP_NAME | 0 | 1 | 7 | 9 | 0 | 2 | 0 |
| SUBSCRIPTION_STATUS | 0 | 1 | 1 | 1 | 0 | 1 | 0 |
| GENDER | 0 | 1 | 0 | 6 | 7799 | 3 | 0 |
| PRICE_PLAN_DESC | 0 | 1 | 10 | 20 | 0 | 36 | 0 |
| PORTIN_COMPETITOR_NAME_ENG | 0 | 1 | 0 | 7 | 440437 | 3 | 0 |
| REF_PRICE_PLAN_DESC | 0 | 1 | 0 | 46 | 44749 | 36 | 0 |
| LE_TYPE_DESC | 0 | 1 | 7 | 22 | 0 | 7 | 0 |
| TERMINAL_TYPE | 0 | 1 | 0 | 16 | 282133 | 4 | 0 |
| TERMINAL_BRAND | 0 | 1 | 0 | 9 | 291555 | 21 | 0 |
| TERMINAL_CAT | 0 | 1 | 0 | 15 | 291231 | 6 | 0 |
| DEVICE_TYPE_DESC | 0 | 1 | 0 | 25 | 9728 | 11 | 0 |
| DEVICE_MANUFACTURER_DESC | 0 | 1 | 0 | 25 | 14564 | 26 | 0 |
| SILENT_SMS | 0 | 1 | 1 | 3 | 0 | 26 | 0 |
| SILENT_DATA | 0 | 1 | 1 | 3 | 0 | 26 | 0 |
| MTA_MAU_CURRENT | 0 | 1 | 1 | 1 | 0 | 2 | 0 |
Variable type: logical
| skim_variable | n_missing | complete_rate | mean | count |
|---|---|---|---|---|
| SUBSCRIPTION_STATUS_NEXT_MNT | 5e+05 | 0 | NaN | : |
Variable type: numeric
| skim_variable | n_missing | complete_rate | mean | sd | p0 | p25 | p50 | p75 | p100 | hist |
|---|---|---|---|---|---|---|---|---|---|---|
| DATE_ID_CALC | 0 | 1.00 | 20210131.00 | 0.00 | 20210131.00 | 20210131.00 | 20210131.00 | 20210131.00 | 20210131.00 | ▁▁▇▁▁ |
| CNT_BARRED_STATUS | 262485 | 0.48 | 9.26 | 7.61 | 1.00 | 2.00 | 7.00 | 14.00 | 38.00 | ▇▅▂▁▁ |
| CNT_BARRED_DAYS | 263417 | 0.47 | 23.39 | 29.75 | 0.00 | 1.27 | 12.82 | 40.25 | 303.71 | ▇▁▁▁▁ |
| CNT_SUSPENDED_STATUS | 259637 | 0.48 | 0.02 | 0.15 | 0.00 | 0.00 | 0.00 | 0.00 | 1.00 | ▇▁▁▁▁ |
| CNT_SUSPENDED_DAYS | 264225 | 0.47 | 1.15 | 4.72 | 0.00 | 0.00 | 0.00 | 0.01 | 39.12 | ▇▁▁▁▁ |
| CNT_SUB_CUST | 0 | 1.00 | 1.81 | 1.27 | 0.00 | 1.00 | 2.00 | 3.00 | 8.00 | ▇▆▂▁▁ |
| NETWORK_AGE | 0 | 1.00 | 94.20 | 56.79 | 16.95 | 40.97 | 86.59 | 149.64 | 235.69 | ▇▃▅▅▁ |
| CUST_AGE | 19628 | 0.96 | 45.20 | 15.31 | 14.00 | 33.00 | 43.00 | 59.00 | 91.00 | ▅▇▆▅▁ |
| REAL_MF_WITH_VAT | 0 | 1.00 | 20.72 | 10.56 | 3.46 | 12.28 | 17.90 | 30.56 | 54.52 | ▇▇▇▁▁ |
| GA_TYPE_FLAG | 242133 | 0.52 | 4.35 | 2.38 | 1.00 | 1.00 | 5.00 | 7.00 | 7.00 | ▇▁▃▆▇ |
| MONTHS_TO_EXPIRY_CRNT | 0 | 1.00 | 2.43 | 0.22 | 1.94 | 2.28 | 2.45 | 2.56 | 3.04 | ▂▇▇▃▁ |
| REF_REAL_MF_WITH_VAT | 56800 | 0.89 | 19.24 | 8.52 | 0.00 | 11.29 | 19.24 | 21.13 | 66.29 | ▅▇▁▁▁ |
| LEASING_CNT | 288866 | 0.42 | 1.87 | 1.08 | 1.00 | 1.00 | 2.00 | 2.00 | 5.00 | ▇▅▂▁▁ |
| TERMINAL_CNT | 150379 | 0.70 | 1.64 | 0.68 | 1.00 | 1.00 | 2.00 | 2.00 | 4.00 | ▇▇▁▂▁ |
| AVG_MONTHLY_BILL_6M_NO_VAT | 0 | 1.00 | 36.28 | 32.08 | 0.88 | 18.84 | 24.80 | 43.71 | 224.58 | ▇▂▁▁▁ |
| INVOICE_CNT | 0 | 1.00 | 5.79 | 0.41 | 5.00 | 6.00 | 6.00 | 6.00 | 6.00 | ▂▁▁▁▇ |
| ROAMING_MIN_CHARGE_6M | 0 | 1.00 | 0.08 | 0.55 | 0.00 | 0.00 | 0.00 | 0.00 | 8.55 | ▇▁▁▁▁ |
| ROAMING_GPRS_CHARGE_6M | 0 | 1.00 | 0.13 | 1.14 | 0.00 | 0.00 | 0.00 | 0.01 | 23.00 | ▇▁▁▁▁ |
| VAS_CHARGE_6M | 0 | 1.00 | 0.00 | 0.00 | 0.00 | 0.00 | 0.00 | 0.00 | 0.01 | ▇▂▁▁▁ |
| DOB_CHARGE_6M | 488003 | 0.02 | 12.50 | 4.34 | 1.68 | 12.30 | 12.31 | 12.32 | 29.91 | ▁▇▁▁▁ |
| GPRS_USAGE_MB_L3M | 0 | 1.00 | 1776.90 | 2859.71 | 0.00 | 0.00 | 239.21 | 2850.23 | 21289.22 | ▇▁▁▁▁ |
| ROAMING_GPRS_USAGE_L3M | 0 | 1.00 | 33.93 | 293.06 | 0.00 | 0.00 | 0.00 | 0.00 | 6053.26 | ▇▁▁▁▁ |
| CNT_PAYMENTS_L12M | 0 | 1.00 | 11.27 | 1.62 | 1.00 | 11.00 | 11.00 | 12.00 | 25.00 | ▁▁▇▁▁ |
| TNSHOPS_PAY_L12M | 165812 | 0.67 | 5.80 | 3.77 | 1.00 | 3.00 | 5.00 | 8.00 | 28.00 | ▇▃▂▁▁ |
| EASYPAY_PAY_L12M | 254293 | 0.49 | 6.69 | 3.85 | 0.54 | 3.10 | 7.41 | 10.25 | 12.66 | ▇▅▇▂▇ |
| EPAY_PAY_L12M | 408505 | 0.18 | 7.90 | 3.64 | 0.00 | 6.00 | 8.00 | 12.00 | 12.00 | ▃▂▂▇▇ |
| MTAPP_PAY_L12M | 411465 | 0.18 | 4.06 | 2.23 | 1.00 | 3.00 | 4.00 | 4.00 | 15.00 | ▅▇▂▁▁ |
| BGPOST_PAY_L12M | 400421 | 0.20 | 6.19 | 3.25 | 1.00 | 4.00 | 6.00 | 8.00 | 12.00 | ▃▁▇▂▃ |
| OTHER_PAY_L12M | 415186 | 0.17 | 5.21 | 2.75 | 1.00 | 4.00 | 5.00 | 5.00 | 13.00 | ▂▇▁▂▁ |
| PLAY_DIEMA_XTRA_YES | 0 | 1.00 | 0.00 | 0.00 | 0.00 | 0.00 | 0.00 | 0.00 | 0.00 | ▁▁▇▁▁ |
| churn_flag | 0 | 1.00 | 0.01 | 0.09 | 0.00 | 0.00 | 0.00 | 0.00 | 1.00 | ▇▁▁▁▁ |
SDV_DAT_JAN %>% plot_intro()
Първи изводи
Предварителният анализ на данните показва, че някои колони могат да бъдат премахнати, най-вече поради следните причини:
- техните стойности нямат пряко значение относно напускането на абонатите
- броят на липсващи елементи е твърде голям, за да бъдат използвани техники за imputation.
Подобни колони са: DATE_ID_CALC, SUBSCRIPTION_STATUS - липса на релеватност към модела; и SUBSCRIPTION_STATUS_NEXT_MNT - празна колона.
SDV_DAT_JAN %>% plot_missing()
SDV_DAT_JAN %>% vis_miss(warn_large_data = FALSE)
SDV_DAT_JAN %>% gg_miss_upset()
За да се осъществи достатъчно задълбочен анализ на всички независими променливи и тяхната значимост като предиктори, определени колони налагат манипулация, за да бъдат включени в модела, например:
- CNT_SUSPENDED_STATUS ще бъде прекодирана по следния начин: 0 => 1, NA => 0
- PP_GROUP_NAME ще бъде конвертирана във фактор
- NA редове в колони като CNT_BARRED_STATUS и CNT_SUSPENDED_DAYS ще бъдат конвертирани в нули
- Колоните с null ще бъдат конвертирани в character вид и ще бъдат запълнени с “NoData”.
По този начин става възможно тези колони да се включат в последващ корелационен и т-тест анализ и накрая да бъдат оценени за предиктивност и статистическа значимост. Алтернативен подход е те да бъдат напълно премахнати от модела, но това води до риска от изпускането на потенциално важни фактори.
DF <- within(SDV_DAT_JAN, rm(DATE_ID_CALC,
SUBSCRIPTION_STATUS,
SUBSCRIPTION_STATUS_NEXT_MNT,
DOB_CHARGE_6M,
OTHER_PAY_L12M,
MTAPP_PAY_L12M,
EPAY_PAY_L12M,
BGPOST_PAY_L12M,
PLAY_DIEMA_XTRA_YES))
churn_yes <- DF %>%
filter(churn_flag == "1")
churn_no <- DF %>%
filter(churn_flag == "0") %>%
na.omit()
clean_df <- join(churn_no, churn_yes, type = "full")Тази процедура групира всичките абонати с положителен churn флаг (1) в отделна раблица, която съдържа 4300 реда. Това се прави с цел запазването на всички true positive наблюдения. Всички други абонати се групират в друга таблица на база churn = no флаг (0), след което всички редове с липсващи данни в churn_no таблицата се премахват. Това редуцира общия брой наблюдения до едва 9995 от началните 495 700. Прилагането на този метод над churn_yes таблицата не е приложим, защото моделът оувърфитва и на практика става неприложим. Допълнително, едва 163 наблюдения в churn_yes таблицата съдържат пълен набор от данни, което е под 2% от общия им брой.
Тази операция спомага за санитаизиране на данните и предоставя по-точен преглед над разпределението им. Разделянето и сливането на двeте таблици позволява работа с изчестени данни, което улеснява тяхното моделиране.
# Wrangle, Transform & Impute
clean_tbl <- clean_df %>%
# Round all numerical columns across the dataset
mutate_if(is.numeric, round, digits = 3) %>%
# Revert data coding from 0 to 1 in CNT_SUSPENDED_STATUS
mutate(CNT_SUSPENDED_STATUS = ifelse(CNT_SUSPENDED_STATUS == "0", 1,0)) %>%
# Replace all NAs across the dataset using base R
replace(is.na(.), 0) %>%
# Convert the churn flag from 1 and 0 to Yes and No
mutate(churn_flag = ifelse(churn_flag == "1", "Yes", "No")) %>%
# Convert churn to factor post imputation
mutate(churn_flag = as.factor(churn_flag))
# Fill in null rows with "NoData" character value
clean_tbl[clean_tbl == ""] <- "NoData" Графично разпределение по категорийни предиктори
exp1 <- clean_tbl %>%
filter(GENDER != "NoData") %>%
ggplot(aes(GENDER, fill = churn_flag)) +
geom_bar(position = "fill") +
labs(x = "Gender", y = "") +
theme(legend.position = "none")
exp3 <- clean_tbl %>%
filter(GA_TYPE_FLAG != "0") %>%
ggplot(aes(GA_TYPE_FLAG, fill = churn_flag)) +
geom_bar(position = "fill") +
labs(x = "How the sub joined", y = "") +
theme(legend.position = "none")
exp4 <- ggplot(clean_tbl, aes(PP_GROUP_NAME, fill = churn_flag)) +
geom_bar(position = "fill") +
labs(x = "Segment", y = "") +
theme(legend.position = "none")
grid.arrange(exp1, exp3, exp4, ncol = 4, nrow = 1, top = "Churn/Non-churn Proportion")
exp2 <- ggplot(clean_tbl, aes(LE_TYPE_DESC, fill = churn_flag)) +
geom_bar(position = "fill") +
labs(x = "Last Event Type", y = "") +
theme(legend.position = "none")
grid.arrange(exp2, ncol = 1, nrow = 1, top = "Churn/Non-churn Proportion")
Сред тези променливи прави впечатление, че дали даден клиент ще спре да използва услугите на телекома, зависи в голяма степен от вида договор.
Изглежда абонатите, които използват основно гласови услуги без интернет, е много по-вероятно да си тръгнат, отколкото абонатите, които използват пълен пакет данни и гласови услуги.
Допълнително, начинът, по който абонатите се присъединяват към телекома също оказва влияние. Колоната GA_TYPE_FLAG онагледява, че при код с номер 4 и 5, абонатите се различават по общ брой churn. За жалост липсва пълно описание на прилежащите кодове.
Също така, начинът, по който абонатите променят своя план от REF_PRICE_PLAN към PRICE_PLAN - със следните възможности - Migration/Retention/Saving и др, изглежда оказва влияние върху нивото на churn.
Важно е да се отбележи, че тези хипотези се базират единствено на графично разпрделение. Без те да бъдат тествани за значимост, не би било разумно да се правят каквито и да било изводи. В последствие чрез корелационен анализ и т-тест, част от тези хипотези се проверяват.
exp5 <- ggplot(clean_tbl, aes(churn_flag, CNT_BARRED_STATUS, fill = churn_flag)) +
geom_boxplot(alpha = 0.8) +
theme(legend.position = "null")
exp6 <- ggplot(clean_tbl, aes(churn_flag, GPRS_USAGE_MB_L3M, fill = churn_flag)) +
geom_boxplot(alpha = 0.8) +
theme(legend.position = "null")
exp7 <- ggplot(clean_tbl, aes(churn_flag, TERMINAL_CNT, fill = churn_flag)) +
geom_boxplot(alpha = 0.8) +
theme(legend.position = "null")
exp8 <- ggplot(clean_tbl, aes(churn_flag, MONTHS_TO_EXPIRY_CRNT, fill = churn_flag)) +
geom_boxplot(alpha = 0.8) +
theme(legend.position = "null")
exp9 <- ggplot(clean_tbl, aes(churn_flag, CNT_SUB_CUST, fill = churn_flag)) +
geom_boxplot(alpha = 0.8) +
theme(legend.position = "null")
exp10 <- ggplot(clean_tbl, aes(churn_flag, CUST_AGE, fill = churn_flag)) +
geom_boxplot(alpha = 0.8) +
theme(legend.position = "null")
grid.arrange(exp5, exp6, exp7,
exp8, exp9, exp10,
ncol = 3, nrow = 2)
В тази редица фактори е трудно да се направят заключения. Графично разликите изглеждат нищожно малки. Провеждането на т-тест може да разкрие други изводи.
T-test анализ
В реални условия, т-тест е стандартен иснтрумент за проверка на хипотези. В този анализ, употребата му има за цел да покаже разбиране и умения за работа с такива методи, отколкото да потвърди / отхвърли дадени допускания и хипотези.
Това е примерен анализ за разпределението между промяната на договор (Migration/Retention/Saving) и възрастта на клиентите. Графиката съдържа множество статистически показатели, например: коефициент за значимост, доверителни интервали и др.
s <- clean_df %>%
mutate(id = rownames(.)) %>%
select(id, CUST_AGE, GENDER, NETWORK_AGE, LE_TYPE_DESC, churn_flag) %>%
mutate(churn_flag ) %>%
filter(GENDER != "")
ggwithinstats(
data = s,
x = LE_TYPE_DESC,
y = CUST_AGE,
type = "r", # robust statistics
xlab = "REF_PRICE_PLAN to PRICE_PLAN",
ylab = "Customer Age",
outlier.tagging = FALSE)
Този т-тест е над продължителността на договора и churn.
w <- clean_df %>%
mutate(id = rownames(.)) %>%
select(id, CUST_AGE, GENDER, NETWORK_AGE, LE_TYPE_DESC, churn_flag) %>%
mutate(churn_flag ) %>%
filter(GENDER != "")
ggwithinstats(
data = w,
x = churn_flag,
y = NETWORK_AGE,
type = "p", # Parametric test
xlab = "Churn",
ylab = "Subscription duration in months",
outlier.tagging = FALSE)
За целта на този последен т-тест се формулират следните хипотези.
- H0 - възрастта на абонатите не оказва влияние над това дали те са склонни към churn.
- Ha - възрастта на абонатите оказва влияние над това дали те са склонни към churn.
ggbetweenstats(s,
churn_flag,
CUST_AGE
)
T-тестът на Welch разкрива, че при 13843 наблюдения, разликата във възрастта на абонатите, и това дали те са склонни да се откажат от услугите на телекома, не е статистически значима.
Размерът на ефекта (g = -0,08) е много нисък, практически нулев. Съгласно конвенциите на Коен (1988), този показател не е статистически значим. Факторът на Bayes разкрива, че данните отхвърлят напълно алтернативната хипотеза (BF = -4.96). Това може да се счита за сериозно доказателство (Jeffreys, 1961) в полза на нулевата хипотеза.
Корелационен анализ
Прилагането на корелационен анализ спомага за идентификация на факторите, свързани с напускането на абонати. това е добър метод за онагледяване на потенциални взаимовръзки.
corrplot(cor(clean_tbl[sapply(clean_tbl, is.numeric)]))
Прилежащата корелограма допълва заключенията направени по-горе с корелационен коефициент. Взаимовръзките варират от ниски (r = +-0,4), до умерени (r = +-0,5-0,7). Важно е да се отбележи, че някой от умерените коефициенти на корелация са между пряко свързани променливи, например: CNT_BARRED и CNT_SUSPENDED, които не носят никаква стойност за целта на анализа.
Алтернативен подход за корелационен анализ е пакетът CORRELATION FUNNEL
- Плюсове:
- Работи с категории (конвертира в бинове с цифрова стойност)
- Показва позитивна и негативна взаимовръзка
- Работи с нелинейни данни (използва конвертирането в бинове)
- Бърза операция - Използва корелационната формула на Пиърсън
- Минуси:
- Нелинейна взаимовръзка се базира на биновете
- Може да влоши резултата ако данните не са нормално разпределени (skew, kurtosis)
churn_bin_tbl <- clean_tbl %>% binarize()options(ggrepel.max.overlaps = 20)
churn_bin_tbl %>%
correlate(target = churn_flag__Yes) %>%
plot_correlation_funnel() +
geom_point(size = 2, color = "#2c3e50")
Бинарна версия на корелационна матрица
Корелационнен коефициент до +-0,7 се счита за умерена връзка. Предвид целта на поставената задача, не е необходимо по-задълбочено изследване, но по-всичко личи, че с тази структура на данните и в тази извадка, не би могло да се говори за висока/много висока корелационна взаимовръзка между наличните фактои и churn. В реалния свят много високи взаимовръзки са трудно откриваеми, тъй като в природата съществуват безброй фактори с потенциално влияние над изследваните променливи.
Моделиране
За целта на текущия анализ, всички модели подлежат на три-степенна крос(кръстосана) валидация.
При k-кратно кръстосано валидиране оригиналната извадка се разделя на случаен принцип в k еднакви по големина подпроби. От k подпроби, една подпроба се запазва като данни за валидиране и тестване на модела, а останалите k - 1 подпроби се използват като данни за обучение на модела.
По този начин се гарантира, че всяко наблюдение от оригиналния набор от данни има шанс да се появи в training и test извадка. Това е един от най-добрите и утвърдени подходи за валидиране на модели.
Преди да се пристъпи към разделянето на данните за крос валидация, те се разделят на churnTrain (10720 наблюдения) and churnTest (3537 наблюдения). churnTrain ще се използва за изработването на модели, докато churnTest се използва за тяхното оценяване.
## 75% of the sample size
smp_size <- floor(0.75 * nrow(clean_tbl))
set.seed(123)
train_ind <- sample(seq_len(nrow(clean_tbl)), size = smp_size)
churnTrain <- clean_tbl[train_ind, ] %>% filter(TERMINAL_BRAND != "LENOVO")
churnTrain <- clean_tbl[train_ind, ] %>% filter(TERMINAL_BRAND != "PHILIPS")
churnTest <- clean_tbl[-train_ind, ] %>% filter(TERMINAL_BRAND != "LENOVO")
churnTest <- clean_tbl[-train_ind, ] %>% filter(TERMINAL_BRAND != "PHILIPS")Моделите за логистична регресия са бързи и лесно интерпретируеми. Като цяло този тип моделиране не налага скалиране на входните променливи, не са небходими допълнителни настройки (хиперпараметри), лесно се регулират и извеждат добре калибрирани вероятности.
modelCtrl <- trainControl(method = "cv", number = 3)Логистична регресия
set.seed(123)
glm.model <- train(churn_flag ~ .,
method = "glm",
family = "binomial",
data = churnTrain,
trControl = modelCtrl)
# summary(glm.model)Преглед на статистически значими предиктори на churn
# Deviance Residuals:
# Min 1Q Median 3Q Max
# -3.5160 -0.3849 -0.1697 0.0405 3.8338
#
# Coefficients:
# Estimate Std. Error z value Pr(>|z|)
# CNT_BARRED_STATUS -1.799e-02 5.107e-03 -3.523 0.000426 ***
# CNT_SUSPENDED_STATUS -3.640e+00 1.446e-01 -25.165 < 2e-16 ***
# NETWORK_AGE 3.078e-03 8.740e-04 3.521 0.000429 ***
# CUST_AGE -1.124e-02 2.875e-03 -3.908 9.31e-05 ***
# GA_TYPE_FLAG -2.269e-01 1.496e-02 -15.168 < 2e-16 ***
# PORTIN_COMPETITOR_NAME_ENGNoData -6.804e-01 1.623e-01 -4.192 2.77e-05 ***
# LE_TYPE_DESCHandset only Migration -8.689e-01 2.029e-01 -4.282 1.85e-05 ***
# LE_TYPE_DESCPrice Plan Migration -8.962e-01 1.689e-01 -5.306 1.12e-07 ***
# LE_TYPE_DESCRetention -8.226e-01 1.778e-01 -4.626 3.74e-06 ***
# TERMINAL_BRANDAPPLE 1.441e+00 3.759e-01 3.835 0.000126 ***
# LEASING_CNT -9.881e-01 4.456e-02 -22.175 < 2e-16 ***
# TERMINAL_CNT -2.693e-01 5.019e-02 -5.366 8.04e-08 ***
# INVOICE_CNT -3.080e-01 8.332e-02 -3.696 0.000219 ***
#
# ---
# Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
# (Dispersion parameter for binomial family taken to be 1)
#
# Null deviance: 13021.5 on 10719 degrees of freedom
# Residual deviance: 5147.8 on 10514 degrees of freedom
# AIC: 5559.8
#
# Number of Fisher Scoring iterations: 17Резултат от glm модел
Обобщението на логистичния модел разкрива основните предиктори на churn. При ниво на значимост от 5% (0,05) и за размер на извадката от 10720, променливите обозначени с *** (p = 0,001), показват статистически значима връзка между churn и предикторните променливи.
varImp(glm.model)## glm variable importance
##
## only 20 most important variables shown (out of 205)
##
## Overall
## EASYPAY_PAY_L12M 100.000
## CNT_SUSPENDED_STATUS 78.574
## LEASING_CNT 69.237
## GA_TYPE_FLAG 47.361
## MTA_MAU_CURRENTY 20.986
## TNSHOPS_PAY_L12M 19.696
## TERMINAL_CNT 16.755
## `LE_TYPE_DESCPrice Plan Migration` 16.567
## GPRS_USAGE_MB_L3M 15.549
## LE_TYPE_DESCRetention 14.443
## `LE_TYPE_DESCHandset only Migration` 13.371
## PORTIN_COMPETITOR_NAME_ENGNoData 13.088
## CUST_AGE 12.202
## TERMINAL_BRANDAPPLE 11.974
## INVOICE_CNT 11.541
## CNT_BARRED_STATUS 11.001
## NETWORK_AGE 10.995
## CNT_BARRED_DAYS 10.193
## TERMINAL_BRANDHONOR 9.839
## TERMINAL_BRANDNoData 9.815Резултатите от статистическия модел частично се свързват с предходините наблюдения в началната фаза на анализа и проверката за корелация между зависимата (прогнозната) и независимите (предикторни) променливи.
Важен предиктор е CNT_SUSPENDED_STATUS, който пряко показва колко пъти услугата на абоната е била спирана.
Други значими предиктори за churn са факторите дали абонатите използват лизингови услуги, как абонатите са сключили договор с оператора (PortIN / from Sales / Pre2Post Migration), дължината на периода, в който клиента е активен абонат, дали използва мобилен интернет или само гласови услуги и други.
Оценяване на модела
Общоприета практика за оценяването на модели е оценяването им спрямо нови, “невиждани” от модела данни. В този случай за да се оцени и измери ефективността на модела се използва таблицата churnTest.
glm.pred <- predict(glm.model, newdata = churnTest)
glm.accuracy <- round(1 - mean(glm.pred != churnTest$churn_flag), 2)
table(actual = churnTest$churn_flag, predicted = glm.pred)## predicted
## actual No Yes
## No 2353 92
## Yes 244 884Резултатът от confusion матрица се използва за оценяване на prediction vs actual. Важно е да се отбележи, че макар и докато точността на модела да изглежда висока, голяма част от този резултат се атрибутира на диспропорционалния брой non-churn правилни предсказания. За да се оцени пълноценнно логистичният модел, неговите резултати се сравняват спрямо резултатите от втори модел, базиран на дърво на решенията (CART).
Истински положителни резултати (TP): Това са случаи, в които се предвижда Yes (абонатите са напуснали) и те в действителност са.
Истински негативи (TN): Предвиждаме No (не са си тръгнали) и те наистина не са.
Фалшиви положителни (FP): Предвиждаме Yes, но те всъщност не са напуснали. (грешка от пъряви тип)
Фалшиви отрицателни (FN): Предвиждаме No, но те всъщност са напуснали. (грешка от втори тип)
Точност: колко често класификаторът е правилен? (TP + TN) / общо = (2353 + 884) / 3573 = 0,91
Процент на погрешно класифициране: колко често класификаторът греши? (FP + FN) / общо = (92 + 244) / 3573 = 0,09
Още няколко метрики могат да бъдат изведени от confusion матрицата, но в този случай те няма да бъдат разгледани.
set.seed(123)
cart.model <- train(churn_flag ~ ., method = "rpart2", data = churnTrain, trControl = modelCtrl)
cart.pred <- predict(cart.model, newdata = churnTest)
cart.accuracy <- 1-mean(cart.pred != churnTest$churn_flag)
table(actual = churnTest$churn_flag, predicted = cart.pred)## predicted
## actual No Yes
## No 2445 0
## Yes 76 1052Точност: колко често класификаторът е правилен? (TP + TN) / общо = (2445 + 1052) / 3573 = 0,98
Процент на погрешно класифициране: колко често класификаторът греши? (FP + FN) / общо = (76 + 0) / 3573 = 0,02
По всичко личи, че вторият CART модел подобрява точността. По-важното е, че по-висока степен на истински положителни резултати съставляват тази точност. Това е значително подобрение спрямо предишния логистичен модел.
Съществува възможност за подобряване на прогнозните резултати и по-специално в истинския положителен процент (специфичност). Би било логично да продължим търсенето на по-ефективен и точен модел :)
Избор на най-добър модел
За да се идентифицира най-добрият модел, ще се сравнени точността между следните модели: Single Decision Tree (CART), Bagged Trees, Boosted Tree and Random Forest.
#CART (Classification And Regression Tree) - gini
set.seed(123)
gini.cart.model <- train(churn_flag ~ ., method = "rpart", data = churnTrain, parms = list(split = "gini"), trControl = modelCtrl)
#Bagging
set.seed(123)
treebag.model <- train(churn_flag ~ ., method = "treebag", data = churnTrain, trControl = modelCtrl)
# Boosted Tree
set.seed(123)
C5.model <- train(churn_flag ~ ., method = "C5.0", data = churnTrain, trControl = modelCtrl)
#Random Forest
set.seed(123)
rf.model <- train(churn_flag ~ ., method = "rf", data = churnTrain, trControl = modelCtrl)
results <- resamples(list(CART=gini.cart.model, BAG=treebag.model, BOOST=C5.model, RF=rf.model))
dotplot(results)
Bagging (от bootstrap agregating), е мета-алгоритъм на ансамбъл за машинно обучение, предназначен да подобри стабилността и точността използвани в статистическата класификация и регресия. Този метод намалява отклоненията и помага да се избегне overfitting.
Gradient Boosting е техника за регресия и класификация, която създава модел за прогнозиране под формата на ансамбъл от слаби модели за прогнозиране, обикновено decision trees.
Random Forest е ансамблов метод за класификация и регресия, който действа чрез изграждане на множество дървета за решение по време на обучение. За класификационни задачи резултатът от random forest модел е класът, избран от повечето дървета.
Моделите Boosted tree, Random Forest и Bagged Trees изглежда имат най-висока точност. За да се избере победителя, моделите се сравняват посредством ROC крива.
gb.pred <- predict(C5.model, newdata = churnTest)
gb.accuracy <- 1-mean(gb.pred != churnTest$churn_flag)
rf.pred1 <- predict(rf.model, newdata = churnTest)
rf.accuracy <- 1-mean(rf.pred1 != churnTest$churn_flag)
glm.roc <- roc(response = churnTest$churn_flag, predictor = as.numeric(glm.pred))## Setting levels: control = No, case = Yes## Setting direction: controls < casesgb.roc <- roc(response = churnTest$churn_flag, predictor = as.numeric(gb.pred))## Setting levels: control = No, case = Yes
## Setting direction: controls < casesrf.roc <- roc(response = churnTest$churn_flag, predictor = as.numeric(rf.pred1))## Setting levels: control = No, case = Yes
## Setting direction: controls < casesplot(glm.roc, legacy.axes = TRUE, print.auc.y = 0.4, print.auc = TRUE)
plot(gb.roc, col = "blue", add = TRUE, print.auc.y = 0.5, print.auc = TRUE)
plot(rf.roc, col = "red" , add = TRUE, print.auc.y = 0.6, print.auc = TRUE)
legend(0.0,0.2, c("Random Forest", "Boosted Tree", "Logistic"), lty = c(1,1), lwd = c(2, 2), col = c("red", "blue", "black"), cex = 0.75)
Резултати
ROC кривата (receiver operating characteristic curve) е графичен начин за преглед на ефективността на класификационните модели. ROC е добър показател за ефективност, особено когато на фокус е истинският положителен (true positive) процент от моделите. Площта под кривата (AUC) измерва способността на моделите да класифицират правилно. Колкото по-висока е коефициентът AUC, толкова по-точен е моделът.
В научните среди, Общоприети стойности на AUC са както следва:
# 0.5 = This suggests no discrimination, so we might as well flip a coin.
# 0.5-0.7 = We consider this poor discrimination, not much better than a coin toss.
# 0.7-0.8 = Acceptable discrimination
# 0.8-0.9 = Excellent discrimination
# > 0.9 = Outstanding discriminationСпоред резултата от ROC кивата, разликата между Random Forest и Boosted Tree е незначителна, но и двата модела показват подобрение спрямо логистичния модел. В тази извадка и с тези параметри, Random Forest е най-добрият прогнозен модел.
Подобрение на модела и заключение
Съществуват множество варианти за допълнителна оптимизация и по-задълбочено почистване на данните. Струва си да се помисли дали е възможно допълнителни фактори да бъдат въведени в моделирането, например чрез добавянето на нови таблици и тн.
Относно самото моделиране, този анализ използва сравнително стари и “прости” алгоритми за логистична регресия. В реални условия, моделиране посредством H2O, TidyModels в комбинация с Parsnip би била оптимална, тъй като би намалила значително времето необходимо за Processing и би било в унисон с актуалните тенденции в машинното обучение с R.
Като допълнителна функционалност и с цел пълното завършване на подобен проект, възможно е разработването на специфична функция, която да оценява вероятни печалби за телекома, в следствие на прилагане на anti-churn стратегия посредством различни промоционални кампании насочени към рисковите абонати. В текущия анализ такава функционалност няма да се разработи, тъй като би отнела твърде много време. Като допълнение, за да е успешно едно такова начинание е необходимо формирането на значителен брой допускания и наличието на допълнителни данни.
Примерна фукнция за подобно изчисление е:
benefit <- function(confMatrix) {
tp <- confMatrix[1,1]; fn <- confMatrix[1,2]
fp <- confMatrix[2,1]; tn <- confMatrix[2,2]
# Хипотезирани стойности на приход от абонат за период от една година при успешен upsell
tp.bnft <- 1000 ; fn.cost <- -2000
fp.cost <- -250 ; tn.bnft <- 50
return(0.75*tp*tp.bnft +
(1-0.75)*tp*fn.cost + fn*fn.cost +
tn*tn.bnft +
0.90*fp*fp.cost + (1-0.9)*fp*tn.bnft)
}С цел употребата на подобен модел в production, възможно е внедрянето на Targets pipeline (https://github.com/ropensci/targets), който е много сходен с Airflow в Python.
Също така, възможно е разработването на Shiny Web App, който да направи работата и манипулирането на данните интерактивно и “живо”.
Backup code
# Linear Imputation - impute_lm() ----
# DF %>%
#
# # Label if Ozone is missing
# add_label_missings(Ozone) %>%
#
# # Imputation - Linear Regression
# mutate(Ozone = as.double(Ozone)) %>%
# impute_lm(Ozone ~ Temp + Wind) %>%
#
# # Visualize
# ggplot(aes(Solar.R, Ozone, color = any_missing)) +
# geom_point()
#
# # Random Forest - impute_rf() ----
#
# air_quality_tbl %>%
#
# # Label if Ozone is missing
# add_label_missings(Ozone) %>%
#
# # Imputation - Ozone
# mutate(Ozone = as.double(Ozone)) %>%
# impute_rf(Ozone ~ Temp + Wind) %>%
#
# # Imputation - Solar.R
# mutate(Solar.R = as.double(Solar.R)) %>%
# impute_rf(Solar.R ~ Temp + Wind) %>%
#
# # Visualize
# ggplot(aes(Solar.R, Ozone, color = any_missing)) +
# geom_point()
# # Churn <- DF %>%
# select(-RowNumber, -CustomerId) %>% #remove unwanted column
# mutate(Geography = as.factor(Geography),
# Gender = as.factor(Gender),
# HasCrCard = as.factor(HasCrCard),
# IsActiveMember = as.factor(IsActiveMember),
# Exited = as.factor(Exited),
# Tenure = as.factor(Tenure),
# NumOfProducts = as.factor(NumOfProducts))# mutate(LE_TYPE_DESC %in% "Price Plan Migration" <- "Mig")
# Transform and impute the Gender column
# mutate(GENDER = ifelse(GENDER == "Male", 1,0)) %>%
# Replace all NAs across the dataset using dplyr
# mutate(across(where(anyNA), ~ replace_na(., 0))) %>%
# Populate blank rows with dummy data
# mutate(across(c("PORTIN_COMPETITOR_NAME_ENG",
# "REF_PRICE_PLAN_DESC",
# "LE_TYPE_DESC",
# "TERMINAL_TYPE",
# "TERMINAL_BRAND",
# "TERMINAL_CAT",
# "DEVICE_TYPE_DESC",
# "DEVICE_MANUFACTURER_DESC",
# "CNT_BARRED_STATUS"), ~ifelse(. == "", "NoData", as.character(.)))) %>%
# Convert churn to factor post imputation
#mutate(GENDER = as.factor(GENDER))
#mutate_if(is.character, as.factor)
# churnTrain %>%
# filter(TERMINAL_BRAND == "LENOVO")
# Generate ID column using row_number
# mutate(id = row_number())
# churn_no_clean_tbl <- DF[rowSums(is.na(churn_no)) == 0,]