TSA Case Study: Telco Churn Prevention
Farhan Abdillah Harahap
Persiapan Data
# Baca data
data <- read.csv("C:\\Users\\FARHAN ABDILLAH\\Downloads\\telco_churn_sample.csv")
# Lihat struktur data
str(data)## 'data.frame': 5000 obs. of 16 variables:
## $ MSISDN : int 31441 31944 82538 86957 27618 96313 21363 85847 56880 83060 ...
## $ los : int 534 589 1223 1221 60 188 255 594 3190 357 ...
## $ voice_rev : num 5860 0 3744 231 12073 ...
## $ voice_trx : int 57 0 6 52 36 7 8 1 0 37 ...
## $ voice_mou : int 251 0 5 188 588 261 207 0 0 67 ...
## $ voice_dou : int 7 0 2 6 6 3 4 1 0 7 ...
## $ sms_rev : int 3465 0 2475 0 2100 0 20430 0 1505 2150 ...
## $ sms_trx : int 16 0 13 2 20 0 97 0 7 16 ...
## $ sms_dou : int 5 0 5 2 5 0 7 0 4 6 ...
## $ broadband_rev : num 35000 0 0 0 0 0 0 9000 0 0 ...
## $ broadband_usg : num 1713 0 0 342 0 ...
## $ broadband_dou : int 6 0 0 7 0 0 0 7 0 7 ...
## $ voice_package_rev: int 34200 8350 8200 7950 26600 4550 15800 17900 16650 8700 ...
## $ voice_package_trx: int 8 2 2 2 6 1 4 4 4 2 ...
## $ voice_package_dou: int 6 2 2 2 5 1 4 2 4 2 ...
## $ churn : int 0 1 0 0 1 0 0 0 0 0 ...# Lihat ringkasan statistik
summary(data)## MSISDN los voice_rev voice_trx
## Min. : 23 Min. : 19 Min. : 0 Min. : 0.00
## 1st Qu.:24788 1st Qu.: 341 1st Qu.: 435 1st Qu.: 4.00
## Median :49573 Median : 956 Median : 3664 Median : 15.00
## Mean :49784 Mean :1224 Mean : 7962 Mean : 28.57
## 3rd Qu.:75005 3rd Qu.:2097 3rd Qu.: 9955 3rd Qu.: 37.00
## Max. :99992 Max. :3220 Max. :397101 Max. :507.00
## voice_mou voice_dou sms_rev sms_trx
## Min. : 0.0 Min. :0.000 Min. : 0 Min. : 0.00
## 1st Qu.: 4.0 1st Qu.:2.000 1st Qu.: 415 1st Qu.: 3.00
## Median : 44.0 Median :4.000 Median : 1980 Median : 12.00
## Mean : 117.8 Mean :3.941 Mean : 4551 Mean : 35.26
## 3rd Qu.: 137.0 3rd Qu.:6.000 3rd Qu.: 5746 3rd Qu.: 34.00
## Max. :3477.0 Max. :7.000 Max. :72430 Max. :1449.00
## sms_dou broadband_rev broadband_usg broadband_dou
## Min. :0.000 Min. : 0 Min. : 0.000 Min. :0.000
## 1st Qu.:2.000 1st Qu.: 0 1st Qu.: 0.000 1st Qu.:0.000
## Median :4.000 Median : 0 Median : 0.000 Median :0.000
## Mean :3.915 Mean : 3952 Mean : 104.874 Mean :1.207
## 3rd Qu.:6.000 3rd Qu.: 0 3rd Qu.: 0.012 3rd Qu.:1.000
## Max. :7.000 Max. :424720 Max. :9882.606 Max. :7.000
## voice_package_rev voice_package_trx voice_package_dou churn
## Min. : 0 Min. : 1.000 Min. :1.000 Min. :0.000
## 1st Qu.: 4350 1st Qu.: 1.000 1st Qu.:1.000 1st Qu.:0.000
## Median : 8200 Median : 2.000 Median :2.000 Median :0.000
## Mean :12065 Mean : 3.201 Mean :2.625 Mean :0.337
## 3rd Qu.:16475 3rd Qu.: 4.000 3rd Qu.:4.000 3rd Qu.:1.000
## Max. :88000 Max. :24.000 Max. :7.000 Max. :1.000# Lihat beberapa baris pertama data
head(data)## MSISDN los voice_rev voice_trx voice_mou voice_dou sms_rev sms_trx sms_dou
## 1 31441 534 5860 57 251 7 3465 16 5
## 2 31944 589 0 0 0 0 0 0 0
## 3 82538 1223 3744 6 5 2 2475 13 5
## 4 86957 1221 231 52 188 6 0 2 2
## 5 27618 60 12073 36 588 6 2100 20 5
## 6 96313 188 3829 7 261 3 0 0 0
## broadband_rev broadband_usg broadband_dou voice_package_rev voice_package_trx
## 1 35000 1713.2028 6 34200 8
## 2 0 0.0000 0 8350 2
## 3 0 0.0000 0 8200 2
## 4 0 341.6926 7 7950 2
## 5 0 0.0000 0 26600 6
## 6 0 0.0000 0 4550 1
## voice_package_dou churn
## 1 6 0
## 2 2 1
## 3 2 0
## 4 2 0
## 5 5 1
## 6 1 0Eksplorasi Data
library(ggplot2)
numeric_columns <- sapply(data, is.numeric)
# Create a histogram for each numeric column
for(col in names(data)[numeric_columns]) {
print(
ggplot(data, aes_string(col)) +
geom_histogram(bins = 30, fill = 'blue', color = 'black') +
theme_minimal() +
labs(title = paste('Histogram of', col), x = col, y = 'Frequency')
)
}## Warning: `aes_string()` was deprecated in ggplot2 3.0.0.
## ℹ Please use tidy evaluation ideoms with `aes()`
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
Regresi Logistik
# Memuat library yang diperlukan
library(caret)## Warning: package 'caret' was built under R version 4.2.3## Loading required package: lattice# Membagi data menjadi set pelatihan dan pengujian
set.seed(123)
trainIndex <- createDataPartition(data$churn, p = .8,
list = FALSE,
times = 1)
trainSet <- data[ trainIndex,]
testSet <- data[-trainIndex,]
# Melatih model regresi logistik
model <- glm(churn ~ ., family = binomial(link = 'logit'), data = trainSet)
model##
## Call: glm(formula = churn ~ ., family = binomial(link = "logit"), data = trainSet)
##
## Coefficients:
## (Intercept) MSISDN los voice_rev
## 1.578e+00 2.457e-07 -1.318e-04 2.162e-05
## voice_trx voice_mou voice_dou sms_rev
## -2.059e-02 -2.732e-03 -1.268e-01 8.842e-06
## sms_trx sms_dou broadband_rev broadband_usg
## -2.481e-05 -9.819e-02 -9.998e-08 4.898e-06
## broadband_dou voice_package_rev voice_package_trx voice_package_dou
## 9.968e-03 -3.611e-06 9.341e-02 -5.110e-01
##
## Degrees of Freedom: 3999 Total (i.e. Null); 3984 Residual
## Null Deviance: 5122
## Residual Deviance: 3950 AIC: 3982summary(model)##
## Call:
## glm(formula = churn ~ ., family = binomial(link = "logit"), data = trainSet)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.7269 -0.8551 -0.3127 0.9267 3.1991
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 1.578e+00 1.217e-01 12.966 < 2e-16 ***
## MSISDN 2.457e-07 1.350e-06 0.182 0.85553
## los -1.318e-04 4.282e-05 -3.077 0.00209 **
## voice_rev 2.162e-05 3.652e-06 5.919 3.24e-09 ***
## voice_trx -2.059e-02 3.703e-03 -5.560 2.69e-08 ***
## voice_mou -2.732e-03 5.302e-04 -5.152 2.57e-07 ***
## voice_dou -1.268e-01 2.680e-02 -4.732 2.22e-06 ***
## sms_rev 8.842e-06 9.319e-06 0.949 0.34271
## sms_trx -2.481e-05 6.202e-04 -0.040 0.96810
## sms_dou -9.819e-02 2.332e-02 -4.211 2.55e-05 ***
## broadband_rev -9.998e-08 2.933e-06 -0.034 0.97281
## broadband_usg 4.898e-06 1.000e-04 0.049 0.96094
## broadband_dou 9.968e-03 1.992e-02 0.500 0.61675
## voice_package_rev -3.611e-06 1.298e-05 -0.278 0.78086
## voice_package_trx 9.341e-02 5.519e-02 1.693 0.09051 .
## voice_package_dou -5.110e-01 8.129e-02 -6.287 3.24e-10 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 5121.6 on 3999 degrees of freedom
## Residual deviance: 3950.2 on 3984 degrees of freedom
## AIC: 3982.2
##
## Number of Fisher Scoring iterations: 6Evaluasi Model
pred <- predict(model, newdata = testSet, type = "response")
pred_class <- ifelse(pred > 0.5, 1, 0)
cm <- confusionMatrix(as.factor(pred_class), as.factor(testSet$churn))
cm## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 574 126
## 1 96 204
##
## Accuracy : 0.778
## 95% CI : (0.7509, 0.8034)
## No Information Rate : 0.67
## P-Value [Acc > NIR] : 3.773e-14
##
## Kappa : 0.4861
##
## Mcnemar's Test P-Value : 0.05161
##
## Sensitivity : 0.8567
## Specificity : 0.6182
## Pos Pred Value : 0.8200
## Neg Pred Value : 0.6800
## Prevalence : 0.6700
## Detection Rate : 0.5740
## Detection Prevalence : 0.7000
## Balanced Accuracy : 0.7374
##
## 'Positive' Class : 0
## Evaluasi model menunjukkan bahwa model regresi logistik memiliki akurasi sebesar 77,8%, yang berarti model berhasil memprediksi status churn (tidak berlangganan atau berlangganan) pelanggan dengan benar untuk sekitar 78% pelanggan dalam set pengujian. Model memiliki sensitivitas (atau tingkat positif benar) sebesar 85,67%, yang menunjukkan model berhasil mengidentifikasi sekitar 86% pelanggan yang tidak berlangganan (churn). Spesifisitas (atau tingkat negatif benar) adalah 61,82%, yang berarti model berhasil mengidentifikasi sekitar 62% pelanggan yang berlangganan (non churn). Nilai prediksi positif (atau presisi) adalah 82%, yang menunjukkan bahwa ketika model memprediksi pelanggan akan tidak berlangganan (churn), model benar 82% dari waktu. Nilai prediksi negatif adalah 68%, yang berarti ketika model memprediksi pelanggan berlangganan (non churn), model benar 68% dari waktu. Akurasi seimbang, yang merupakan rata-rata sensitivitas dan spesifisitas, adalah 73,74%. Ini menunjukkan bahwa model cukup baik dalam memprediksi kedua kelas, tetapi masih ada ruang untuk peningkatan, terutama dalam mengidentifikasi dengan benar pelanggan yang berlangganan (non churn). Statistik Kappa sebesar 0,4861 menunjukkan tingkat kesepakatan yang moderat antara prediksi model dan status churn aktual. Model secara signifikan mengungguli Tingkat Informasi Tidak Ada, yang merupakan proporsi kelas terbesar dalam data (67%). Secara keseluruhan, model menunjukkan kinerja yang layak dalam memprediksi churn pelanggan.
Plot ROC AUC
library(pROC)## Warning: package 'pROC' was built under R version 4.2.3## Type 'citation("pROC")' for a citation.##
## Attaching package: 'pROC'## The following objects are masked from 'package:stats':
##
## cov, smooth, varroc_obj <- roc(testSet$churn, pred)## Setting levels: control = 0, case = 1## Setting direction: controls < casesplot(roc_obj, main="ROC Curve")
auc(roc_obj)## Area under the curve: 0.8381Nilai Area Under the Curve (AUC) sebesar 0.8381 menunjukkan bahwa model memiliki kinerja yang baik dalam membedakan antara kelas positif dan negatif. Nilai ini lebih dekat ke 1 daripada ke 0.5, yang menunjukkan bahwa model ini jauh lebih baik daripada tebakan acak.
Cross Validation
train_control <- trainControl(method = "cv", number = 10)
model_cv <- train(churn ~ ., data = trainSet, trControl = train_control, method = "glm", family = binomial(link = 'logit'))## Warning in train.default(x, y, weights = w, ...): You are trying to do
## regression and your outcome only has two possible values Are you trying to do
## classification? If so, use a 2 level factor as your outcome column.print(model_cv)## Generalized Linear Model
##
## 4000 samples
## 15 predictor
##
## No pre-processing
## Resampling: Cross-Validated (10 fold)
## Summary of sample sizes: 3600, 3600, 3600, 3600, 3600, 3600, ...
## Resampling results:
##
## RMSE Rsquared MAE
## 0.4093312 0.252199 0.334619Hasil validasi silang (cross-validation) 10 kali lipat pada sampel sebanyak 4000 dengan 15 prediktor menunjukkan bahwa model memiliki Root Mean Square Error (RMSE) sebesar 0.4093312, R-squared sebesar 0.252199, dan Mean Absolute Error (MAE) sebesar 0.334619.
Feature Importance
importance <- summary(model)$coefficients[, "z value"]
importance <- data.frame(Feature = names(importance), Importance = abs(importance))
importance <- importance[order(-importance$Importance), ]
print(importance)## Feature Importance
## (Intercept) (Intercept) 12.96648258
## voice_package_dou voice_package_dou 6.28676803
## voice_rev voice_rev 5.91871506
## voice_trx voice_trx 5.56046503
## voice_mou voice_mou 5.15244731
## voice_dou voice_dou 4.73185390
## sms_dou sms_dou 4.21066896
## los los 3.07676153
## voice_package_trx voice_package_trx 1.69269526
## sms_rev sms_rev 0.94883100
## broadband_dou broadband_dou 0.50045467
## voice_package_rev voice_package_rev 0.27820191
## MSISDN MSISDN 0.18207066
## broadband_usg broadband_usg 0.04896868
## sms_trx sms_trx 0.03999564
## broadband_rev broadband_rev 0.03408317Signifikansi Feature Importance
importance <- summary(model)$coefficients[, "z value"]
importance <- data.frame(Feature = names(importance), Importance = abs(importance))
importance$Significant <- ifelse(importance$Importance > 1.96, "Yes", "No")
importance <- importance[order(-importance$Importance), ]
print(importance)## Feature Importance Significant
## (Intercept) (Intercept) 12.96648258 Yes
## voice_package_dou voice_package_dou 6.28676803 Yes
## voice_rev voice_rev 5.91871506 Yes
## voice_trx voice_trx 5.56046503 Yes
## voice_mou voice_mou 5.15244731 Yes
## voice_dou voice_dou 4.73185390 Yes
## sms_dou sms_dou 4.21066896 Yes
## los los 3.07676153 Yes
## voice_package_trx voice_package_trx 1.69269526 No
## sms_rev sms_rev 0.94883100 No
## broadband_dou broadband_dou 0.50045467 No
## voice_package_rev voice_package_rev 0.27820191 No
## MSISDN MSISDN 0.18207066 No
## broadband_usg broadband_usg 0.04896868 No
## sms_trx sms_trx 0.03999564 No
## broadband_rev broadband_rev 0.03408317 NoIdentifikasi Ide Bisnis
Berdasarkan variabel yang signifikan, berikut adalah beberapa ide bisnis yang dapat dipertimbangkan:
Banyaknya hari menggunakan paket telepon dalam sebulan terakhir (voice_package_dou): Menciptakan berbagai paket telepon yang menarik dan unik yang dapat digunakan oleh pengguna selama sebulan. Paket ini bisa berisi berbagai jenis layanan yang bisa digunakan untuk personalisasi lebih lanjut.
Penghasilan dari jasa voice/telepon dalam sebulan terakhir (voice_rev): Mencoba meningkatkan pendapatan dari layanan suara dengan menawarkan fitur atau layanan tambahan, seperti kualitas suara yang lebih baik, panggilan internasional, atau layanan lain yang mungkin diminati oleh pengguna.
Banyaknya transaksi jasa voice/telepon dalam sebulan terakhir (voice_trx): Mencoba meningkatkan jumlah transaksi suara dengan menawarkan promosi atau diskon untuk penggunaan layanan suara.
Lamanya waktu penggunaan jasa voice/telepon dalam sebulan terakhir (voice_mou): Mencoba meningkatkan menit penggunaan suara dengan menawarkan paket waktu bicara yang lebih lama atau dengan memberikan bonus menit bicara untuk penggunaan tertentu.
Banyaknya hari menggunakan layanan voice/telepon dalam sebulan terakhir (voice_dou): Mencoba meningkatkan penggunaan layanan suara dengan menawarkan paket layanan suara yang lebih besar atau dengan memberikan bonus layanan untuk penggunaan tertentu.
Banyaknya hari menggunakan SMS dalam sebulan terakhir (sms_dou): Mencoba meningkatkan penggunaan SMS dengan menawarkan paket SMS yang lebih besar atau dengan memberikan bonus SMS untuk penggunaan tertentu.
Length of Stay/Lamanya menjadi customer (los): Mencoba meningkatkan durasi layanan dengan menawarkan insentif untuk pengguna jangka panjang atau dengan menciptakan program loyalitas yang menarik.