Survival Model
Introduction
Kamu pasti pernah merasa kurang puas dengan sebuah perusahaan perbankan dan akhirnya memutuskan pindah ke perusahaan lain? Entah karena system kerjanya kurang bagus , ketidaknyamanan sebagai nasabah karena alasan tertentu, atau karena pelayanannya yang kurang baik. Nah hal itu disebut dengan Customer Churn. Customer churn didefinisikan sebagai kecenderungan pelanggan untuk berhenti melakukan interaksi dengan sebuah perusahaan. Perusahaan perbankan memiliki kebutuhan untuk mengetahui apakah pelanggan akan berhenti berlangganan atau tidak, karena biaya untuk mempertahankan pelanggan yang sudah ada jauh lebih sedikit dibandingkan memperoleh pelanggan baru. Perusahaan biasanya mendefinisikan 2 tipe customer churn, yaitu voluntary dan involuntary. Voluntary churn merupakan pelanggan yang dengan sengaja berhenti dan beralih ke perusahaan lain, sedangkan involuntary churn merupakan pelanggan yang berhenti karena sebab eksternal seperti berpindah lokasi, kematian, atau alasan lainnya. Diantara kedua tipe tersebut, voluntary churn lah yang tidak sulit untuk dilakukan karena kita dapat mempelajari karakteristik pelanggan yang dapat dilihat dari profil pelanggan. Permasalahan ini dapat dijawab dengan membuat sebuah model Machine Learning yang dapat memprediksi Dengan menggunakan Analisis Survival, tidak hanya perusahaan yang dapat memprediksi apakah pelanggan akan churn atau tidak, tetapi juga kapan peristiwa itu mungkin terjadi.
Dataset
Description and Overview
| Feature Category | Feature Name | Type | Description |
|---|---|---|---|
| Time | Tenure | Numerical | Lama menjadi nasabah dalam bulan |
| Event | Exited | Categorical | Penunjuk nasabah telah churn atau tidak |
| Customer information | CustomerID | Categorical | ID unik tiap nasabah |
| Customer information | Surname | Categorical | Nama Belakang nasabah |
| Customer information | Geography | Categorical | Tempat asal nasabah |
| Customer information | Gender | Categorical | Jenis Kelamin nasabah |
| Customer Information | Age | Numerical | Usia nasabah |
| Customer Information | EstimatedSalary | Numerical | Perkiraan Gaji Nasabah |
| Product | CreditScore | Numerical | Nilai kelayakan nasabah untuk kredit |
| Product | Balance | Numerical | Jumlah simpanan nasabah |
| Product | HasCrCard | Categorical | Indikasi apakah nasabah memiliki kartu kredit atau tidak |
| Satisfication | NumofProducts | Numerical | Jumlah Produk yang digunakan nasabah |
| Satisfication | IsActiveMember | Categorical | Indikasi apakah nasabah aktif menggunakan produk atau tidak |
#Import Data
Churn <- read.csv("churn1.csv")
# Overview of the dataset
head(Churn)## RowNumber CustomerId Surname CreditScore Geography Gender Age Tenure
## 1 1 15634602 Hargrave 619 France Female 42 2
## 2 2 15647311 Hill 608 Spain Female 41 1
## 3 3 15619304 Onio 502 France Female 42 8
## 4 4 15701354 Boni 699 France Female 39 1
## 5 5 15737888 Mitchell 850 Spain Female 43 2
## 6 6 15574012 Chu 645 Spain Male 44 8
## Balance NumOfProducts HasCrCard IsActiveMember EstimatedSalary Exited
## 1 0.00 1 1 1 101348.88 1
## 2 83807.86 1 0 1 112542.58 0
## 3 159660.80 3 1 0 113931.57 1
## 4 0.00 2 0 0 93826.63 0
## 5 125510.82 1 1 1 79084.10 0
## 6 113755.78 2 1 0 149756.71 1From categorical to numerical
Kita akan mengkategorikan EstimatedSalary dan Balance ke beberapa segmen sebagai berikut:
- 0-10,000
- 10,001-40,000
- 40,001-80,000
- 80,001-120,000
- 120,001-200,000
- 200,001-280,000
finance_category <- function(x){
if (x >= 0 && x <= 10000){
return('0-10000')
}else if(x > 10001 && x <= 40000){
return('10001-40000')
}else if (x > 40001 && x <= 80000){
return('40001-80000')
}else if (x > 80001 && x <=120000){
return('80001-120000')
}else if (x > 120001 && x <=200000){
return('120001-200000')
}else if (x > 200000){
return('> 200000')
}
}
Churn$Tenure <- as.numeric(Churn$Tenure)
Churn$Balance <- sapply(Churn$Balance,finance_category)
Churn$EstimatedSalary <- sapply(Churn$EstimatedSalary,finance_category)library("fastDummies")
Churn$Gender[Churn$Gender=='Male'] <- 1
Churn$Gender[Churn$Gender=='Female'] <- 2
Churn$Gender <- as.integer(Churn$Gender)
Churnnew <- dummy_cols(Churn,
select_columns = c("EstimatedSalary","Balance","Geography"),
remove_selected_columns = TRUE)
# extracting features
time_column <- 'Tenure'
event_column <- 'Exited'
features <-colnames(Churnnew)[!colnames(Churnnew)
%in%
c(time_column,event_column)]Exploratory Data Analysis
Null Values and Duplicates
# cek apakah ada nilai NA
sapply(Churnnew, function(x) sum(is.na(x)))## RowNumber CustomerId
## 0 0
## Surname CreditScore
## 0 0
## Gender Age
## 0 0
## Tenure NumOfProducts
## 0 0
## HasCrCard IsActiveMember
## 0 0
## Exited EstimatedSalary_0-10000
## 0 0
## EstimatedSalary_10001-40000 EstimatedSalary_40001-80000
## 0 0
## EstimatedSalary_80001-120000 EstimatedSalary_120001-200000
## 0 0
## Balance_> 200000 Balance_0-10000
## 0 0
## Balance_10001-40000 Balance_40001-80000
## 0 0
## Balance_80001-120000 Balance_120001-200000
## 0 0
## Geography_France Geography_Germany
## 0 0
## Geography_Spain
## 0Dari hasil di atas bisa dilihat bahwa tidak ada null value terdeteksi
# cek apakah ada nilai Duplicates
sapply(Churnnew, function(x) sum(duplicated(x)))## RowNumber CustomerId
## 0 0
## Surname CreditScore
## 2208 3560
## Gender Age
## 3997 3933
## Tenure NumOfProducts
## 3988 3995
## HasCrCard IsActiveMember
## 3997 3997
## Exited EstimatedSalary_0-10000
## 3997 3997
## EstimatedSalary_10001-40000 EstimatedSalary_40001-80000
## 3997 3997
## EstimatedSalary_80001-120000 EstimatedSalary_120001-200000
## 3997 3997
## Balance_> 200000 Balance_0-10000
## 3997 3997
## Balance_10001-40000 Balance_40001-80000
## 3997 3997
## Balance_80001-120000 Balance_120001-200000
## 3997 3997
## Geography_France Geography_Germany
## 3997 3997
## Geography_Spain
## 3997Dari hasil di atas dilihat banyak nilai duplikat, tapi hal itu merupakan hal yang lumrah. Yang penting adalah CustomerID unik. Untuk kolom yang lain, duplikat adalah hal yang wajar. CustomerID, RowNumber, dan Surname tidak memiliki fungsi dalam analysis ini, sehingga akan dihilangkan
Churnnew <- Churnnew[-c(1:3)]
features <-colnames(Churnnew)[!colnames(Churnnew)
%in%
c(time_column,event_column)]Correlations
library(corrplot)
corrplot(cor(Churnnew[features]),
title = "Correlation Plot",
method = "color",
tl.cex = 0.5,
tl.srt = 45,
number.cex = 0.35,
col = COL2('BrBG',10),
addCoef.col = "grey50",
mar = c(0,0,2,0))
Tidak ada korelasi signifikan (>0.6) antar variabel.
Modelling
Building the Model
# Membuat set training dan testing
library('caret')
set.seed(3456)
trainIndex <- createDataPartition(Churnnew$Tenure, p = .7,
list = FALSE,
times = 1)
Train <- Churnnew[ trainIndex,]
Test <- Churnnew[-trainIndex,]Selanjutnya kita menerapkan Random Forest Model
library(randomForestSRC)
library(randomForest)
library(survival)
library(dplyr)
set.seed(3456)
#fit <- rfsrc(Surv(time = Tenure, event = Exited==1)~.,
# data = Train,
# ntree=1000,
# mtry = sqrt(20),
# importance = TRUE)
#saveRDS(fit, "fit.rds")
fit <- readRDS("fit.rds")Model kita simpan ke dalam format rds untuk mengurangi waktu load model.
Variable Importance
Hasil dari menerapkan Random Forest Model, kita bisa mendapatkan Importance Variable, yaitu nilai-nilai yang menunjukkan pentingnya suatu variabel dari yang tertinggi sampai terendah.
importance<-fit$importance %>% data.frame()
colnames(importance) <- "ImportanceValue"
importance %>% arrange(desc(ImportanceValue)) %>% head()## ImportanceValue
## Age 0.18811953
## NumOfProducts 0.16968063
## Balance_> 200000 0.06985201
## IsActiveMember 0.05322681
## CreditScore 0.04415604
## Balance_0-10000 0.03160698Dapat kita lihat yang paling mempengaruhi churn disini adalah Age dan NumofProducts
Cross Validation
Selanjutnya kita akan menguji performa model yang telah kita bangun menggunakan data yang telah kita bagi sebelumnya menjadi Train dan Test.
C-Index
C-Index mewakili penilaian kemampuan diskriminasi secara global. Secara umum ketika C-index mendekati 1, maka model memiliki kemampuan diskriminasi yang tinggi, tetapi di saat mendekati 0.5, maka model tidak memilki kemampuan untuk menentukan subjek dengan risiko tinggi atau rendah.
library(pec)
cindex(fit, formula =Surv(time = Tenure, event = Exited==1)~.,data = Train )$AppCindex## $rfsrc
## [1] 0.8559559Nilai C-Index adalah 0.8559559, yang mana lebih mendekati 1 dibanding 0.5. Sehingga model ini dinyatakan memiliki kemampuan determinasi yang baik.
Brier Score
Brier score mengukur perbedaan rata-rata antara status dan perkiraan probabilitas pada waktu tertentu. Dengan demikian, semakin rendah skor (biasanya di bawah 0,25), semakin baik kinerja prediktif.
\[BS=\frac{1}{N}\sum^N_{t=1}{(f_t-o_t)^2}\]
bs <- get.brier.survival(fit)
bs$brier.score %>% tail(1)## time brier.score
## 11 10 0.101717plot(c(1,9.7), c(0,.3),type = 'n', xlab = "Time", ylab = "")
lines(bs$brier.score, col = "blue")
abline(h=.25, col = "red", lwd = 3)
text(10,.26,"0.25 Limit", col = "red", lty = 5, adj = c(1,0))
Brier score yang didapatkan adalah 0.1033 pada keseluruhan model yang mengindikasikan bahwa model sangat bagus untuk melakukan prediksi.
Predictions
Overall Predictions
Setelah membuat model untuk data kita, kita dapat membandingkan hasil prediksi dengan data aktual. Perbandingan dapat kita lakukan secara visual, yaitu dengan plot hasil prediksi model terhadap data Test
#Membuat prediksi dengan model dari data train terhadap data test
y.pred <- predict(fit,newdata = Test)
times <- y.pred$time.interest
survprob <- data.frame(y.pred$survival)
avgprob <- sapply(survprob,mean)
#Membangun model test untuk mengekstrak probability survival
#fittest <- rfsrc(Surv(time = Tenure, event = Exited==1)~.,
# data = Test,
# ntree=1000,
# mtry = sqrt(20),
# importance = TRUE)
#saveRDS(fittest, "fittest.rds")
fittest <- readRDS('fittest.rds')
survprobtest <- data.frame(fittest$survival)
avgprobtest <- sapply(survprobtest,mean)#PLOT
plot(times,
avgprob,
type="l",
xlab="Time (Year)",
ylab="Survival", col=1, lty=1, lwd=2,
main = "Perbandingan antara aktual dan prediksi")
lines(times, avgprobtest, col=2, lty=2, lwd=2)
legend("topright", legend = c("Predicted", "Actual"), col = c(1:2), lty = c(1:2))
Hasil Plot survival prediksi tidak jauh berbeda dengan aktual. Membuktikan hasil prediksi model sudah baik.
Individuals Predictions
Variabel terpenting dari hasil analisa di atas adalah Age, sehingga kita akan memplot survival rate berdasarkan Usia.
newdata <- data.frame(lapply(1:ncol(fit$xvar),function(i){median(fit$xvar[,i])}))
colnames(newdata) <- fit$xvar.names
newdata1 <- newdata2 <- newdata3 <- newdata4 <- newdata5 <- newdata6 <- newdata7 <- newdata8 <- newdata9 <- newdata
newdata1[,which(fit$xvar.names == "Age")] <- quantile(fit$xvar$Age, 0.1)
newdata2[,which(fit$xvar.names == "Age")] <- quantile(fit$xvar$Age, 0.2)
newdata3[,which(fit$xvar.names == "Age")] <- quantile(fit$xvar$Age, 0.3)
newdata4[,which(fit$xvar.names == "Age")] <- quantile(fit$xvar$Age, 0.4)
newdata5[,which(fit$xvar.names == "Age")] <- quantile(fit$xvar$Age, 0.5)
newdata6[,which(fit$xvar.names == "Age")] <- quantile(fit$xvar$Age, 0.6)
newdata7[,which(fit$xvar.names == "Age")] <- quantile(fit$xvar$Age, 0.7)
newdata8[,which(fit$xvar.names == "Age")] <- quantile(fit$xvar$Age, 0.8)
newdata9[,which(fit$xvar.names == "Age")] <- quantile(fit$xvar$Age, 0.9)
newdata <- rbind(newdata1,newdata2, newdata3, newdata4, newdata5, newdata6, newdata7, newdata8, newdata9)
y.pred <- predict(fit,newdata = newdata)
#PLOT
cols <- colors()
plot(times,
y.pred$survival[1,],
type = 'l',
ylim = c(0,1),
xlab="Time (Year)",
ylab="Survival", col=1, lty=1, lwd = 2,
main = "Bank's Customer Survival Curves by Age")
for (n in 2:9) {
lines(times, y.pred$survival[n,], type = 'l', col = cols[n], lwd = 2)
}
legend("bottomleft",
legend=c("Usia sekitar 27 Tahun",
"Usia sekitar 30 Tahun",
"Usia sekitar 33 Tahun",
"Usia sekitar 35 Tahun",
"Usia sekitar 37 Tahun",
"Usia sekitar 37 Tahun",
"Usia sekitar 37 Tahun",
"Usia sekitar 46 Tahun",
"Usia sekitar 53 Tahun"),
col=c(1:9), cex=1, lwd=2)
Dari plot di atas, bisa dilihat bahwa semakin muda seseorang, kemungkinan untuk mereka churned pun semakin kecil.
set.seed(28)
exited_times <- fit$time.interest
surv_prob <- data.frame(fit$survival)
avg_prob <- sapply(surv_prob,mean)
# Plot the survival models for each patient
plot(fit$time.interest,fit$survival[1,],
type = "l",
ylim = c(0,1),
col = "red",
xlab = "Tenure",
ylab = "survival",
main = "Bank's Customer Survival Curves")
cols <- colors()
for (n in sample(c(2:dim(Train)[1]), 20)){
lines(fit$time.interest, fit$survival[n,], type = "l", col = cols[n])
}
lines(exited_times, avg_prob, lwd = 2)
legend("bottomleft", legend = c('Average = black'), lty = 1, lwd = 2)
Dari hasil ini dapat dilihat dari rataan bahwa sampai sepuluh tahun kemudian, sekitar 60% nasabah masih akan bertahan.
Conclusion
Dapat disimpulkan bahwa model ini dapat digunakan untuk memprediksi nasabah seperti apa yang akan berhenti menjadi nasabah, dan dalam jangka waktu berapa lama. Analisa ini akan membantu bank untuk mengetahui nasabah-nasabah yang kemungkinan akan Churned, dan dapat memahami alasan-alasan yang dapat menyebabkan nasabah mereka Churned