LBB C1

library(tidyverse)
## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.2 ──
## ✔ ggplot2 3.4.0      ✔ purrr   0.3.4 
## ✔ tibble  3.1.8      ✔ dplyr   1.0.10
## ✔ tidyr   1.2.1      ✔ stringr 1.4.1 
## ✔ readr   2.1.3      ✔ forcats 0.5.2
## Warning: package 'ggplot2' was built under R version 4.2.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
library(dplyr)
library(class)
library(caret)
## Warning: package 'caret' was built under R version 4.2.2
## Loading required package: lattice
## 
## Attaching package: 'caret'
## 
## The following object is masked from 'package:purrr':
## 
##     lift
library(gtools)
## Warning: package 'gtools' was built under R version 4.2.2

Analisis regresi ini bertujuan untuk membuat model dengan metode logistic regression dan k-NN dengan target variable kategorik untuk memprediksi nasabah bank churn atau tidak churn. Dataset yang digunakan adalah: “Bank Customer Churn Prediction.csv” dari Kaggle.

READ DATA

bank <- read.csv("Bank Customer Churn Prediction.csv")
str(bank)
## 'data.frame':    10000 obs. of  12 variables:
##  $ customer_id     : int  15634602 15647311 15619304 15701354 15737888 15574012 15592531 15656148 15792365 15592389 ...
##  $ credit_score    : int  619 608 502 699 850 645 822 376 501 684 ...
##  $ country         : chr  "France" "Spain" "France" "France" ...
##  $ gender          : chr  "Female" "Female" "Female" "Female" ...
##  $ age             : int  42 41 42 39 43 44 50 29 44 27 ...
##  $ tenure          : int  2 1 8 1 2 8 7 4 4 2 ...
##  $ balance         : num  0 83808 159661 0 125511 ...
##  $ products_number : int  1 1 3 2 1 2 2 4 2 1 ...
##  $ credit_card     : int  1 0 1 0 1 1 1 1 0 1 ...
##  $ active_member   : int  1 1 0 0 1 0 1 0 1 1 ...
##  $ estimated_salary: num  101349 112543 113932 93827 79084 ...
##  $ churn           : int  1 0 1 0 0 1 0 1 0 0 ...

Deskripsi :

credit_score : nilai angka kredit

country : negara asal

gender : jenis kelamin

age : usia

tenure: lamanya seseorang menjadi customer bank

balance : nilai tabungan yang dimiliki

products_number : nomor produk

credit_card : punya credit card (1), tidak punya credit card(0)

active_member: member aktif (1), tidak aktif (0)

estimated_salary : perkiraan gaji

churn: churn (1), not churn (0)

EDA

Data coercion

Tujuan langkah ini adalah mengubah tipe data yang belum sesuai untuk dilakukan analisa.

bank_clean <- bank %>% 
  select(-c(customer_id, products_number)) %>% 
  mutate (country = as.factor(country),
          gender = as.factor(gender),
          credit_card = as.factor(credit_card),
          active_member = as.factor(active_member),
          churn = as.factor(churn)
          )
str(bank_clean)
## 'data.frame':    10000 obs. of  10 variables:
##  $ credit_score    : int  619 608 502 699 850 645 822 376 501 684 ...
##  $ country         : Factor w/ 3 levels "France","Germany",..: 1 3 1 1 3 3 1 2 1 1 ...
##  $ gender          : Factor w/ 2 levels "Female","Male": 1 1 1 1 1 2 2 1 2 2 ...
##  $ age             : int  42 41 42 39 43 44 50 29 44 27 ...
##  $ tenure          : int  2 1 8 1 2 8 7 4 4 2 ...
##  $ balance         : num  0 83808 159661 0 125511 ...
##  $ credit_card     : Factor w/ 2 levels "0","1": 2 1 2 1 2 2 2 2 1 2 ...
##  $ active_member   : Factor w/ 2 levels "0","1": 2 2 1 1 2 1 2 1 2 2 ...
##  $ estimated_salary: num  101349 112543 113932 93827 79084 ...
##  $ churn           : Factor w/ 2 levels "0","1": 2 1 2 1 1 2 1 2 1 1 ...

Check missing value.

is.na(bank_clean) %>% colSums()
##     credit_score          country           gender              age 
##                0                0                0                0 
##           tenure          balance      credit_card    active_member 
##                0                0                0                0 
## estimated_salary            churn 
##                0                0

Check data distribution dan outliers

summary(bank_clean)
##   credit_score      country        gender          age            tenure      
##  Min.   :350.0   France :5014   Female:4543   Min.   :18.00   Min.   : 0.000  
##  1st Qu.:584.0   Germany:2509   Male  :5457   1st Qu.:32.00   1st Qu.: 3.000  
##  Median :652.0   Spain  :2477                 Median :37.00   Median : 5.000  
##  Mean   :650.5                                Mean   :38.92   Mean   : 5.013  
##  3rd Qu.:718.0                                3rd Qu.:44.00   3rd Qu.: 7.000  
##  Max.   :850.0                                Max.   :92.00   Max.   :10.000  
##     balance       credit_card active_member estimated_salary    churn   
##  Min.   :     0   0:2945      0:4849        Min.   :    11.58   0:7963  
##  1st Qu.:     0   1:7055      1:5151        1st Qu.: 51002.11   1:2037  
##  Median : 97199                             Median :100193.91           
##  Mean   : 76486                             Mean   :100090.24           
##  3rd Qu.:127644                             3rd Qu.:149388.25           
##  Max.   :250898                             Max.   :199992.48
# Data numerik

boxplot(bank_clean$credit_score, xlab= "credit_score")

boxplot(bank_clean$age, xlab= "age")

boxplot(bank_clean$tenure, xlab= "tenure")

boxplot(bank_clean$balance, xlab= "balance")

boxplot(bank_clean$estimated_salary, xlab= "estimated_salary")

Terdapat outliers pada variabel age, maka kita filter data yang tidak mengandung outliers (kita gunakan data tanpa outliers).

# Hilangkan outliers pada variable age

bank_clean <- bank_clean %>% 
  filter(age < 65)

Check Class Imbalance

Untuk memastikan model belajar dengan baik, kita harus memastikan bahwa data (terutama data train) proporsinya harus seimbang. Jika proporsi data tidak seimbang, dikhawatirkan hasilnya bias.

prop.table(table(bank_clean$churn))
## 
##         0         1 
## 0.7948137 0.2051863

Proporsi data tidak seimbang.

Cross Validation

Di langkah ini kita bagi data menjadi data train dan data test.

Jika kita ingin melakukan sebuah prediksi, maka kita tidak disarankan melihat nilai error pada data yang digunakan untuk melatih model, karena itu hanya menunjukkan bahwa model dapat memprediksi data lama tetapi belum tentu dapat memprediksi data baru. Data yang digunakan untuk melatih model kita sebut dengan data train, sedangkan data yang digunakan untuk mengevaluasi model disebut dengan data test.

Berikut beberapa kondisi yang dapat terjadi pada model:

  • Overfitting: Model terlalu bagus dalam mengikuti pola di data train, menyebabkan model kurang mampu memprediksi data baru
  • Underfitting: Model kurang bisa menangkap pola di data train
  • Optimum: Model mampu mengikui pola data train tetapi masih memiliki kemampuan yang baik dalam memprediksi data baru

Untuk mengevaluasi model dan melihat kemampuannya memprediksi data baru, data kita bagi menjadi 2: data train dan data test. Proses ini kita sebut dengan cross-validation.

Misalkan saya menggunakan 80% dari seluruh data yang saya miliki menjadi data train dan sisanya akan digunakan sebagai data test.

Analogi:

  • 100 soal
  • 80 soal saya pakai untuk belajar (data train)
  • 20 soal saya pakai untuk ujian (data test)

tujuan dari cross validation adalah untuk mengetahui seberapa baik model yg sudah kita buat.

RNGkind(sample.kind = "Rounding")
## Warning in RNGkind(sample.kind = "Rounding"): non-uniform 'Rounding' sampler
## used
set.seed(123)

index <- sample(nrow(bank_clean), nrow(bank_clean)*0.8)
bank_train <- bank_clean[index,]
bank_test <- bank_clean[-index,]
nrow(bank_clean) * 0.8
## [1] 7774.4
nrow(bank_train)
## [1] 7774
nrow(bank_clean) * 0.2
## [1] 1943.6
nrow(bank_test)
## [1] 1944

Cek kembali proporsi data:

# re-check class imbalance
prop.table(table(bank_train$churn))
## 
##         0         1 
## 0.7962439 0.2037561

Data ini masih bisa diperbaiki lagi supaya lebih balance proporsinya.

LOGISTIC REGRESSION

  • Model
model_bank_all <- glm(formula = churn ~.,
                   data = bank_train,
                   family = "binomial")
summary(model_bank_all)
## 
## Call:
## glm(formula = churn ~ ., family = "binomial", data = bank_train)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -2.1496  -0.6352  -0.4192  -0.2328   3.1591  
## 
## Coefficients:
##                    Estimate Std. Error z value Pr(>|z|)    
## (Intercept)      -5.054e+00  2.837e-01 -17.813  < 2e-16 ***
## credit_score     -4.377e-04  3.263e-04  -1.341 0.179779    
## countryGermany    8.045e-01  7.850e-02  10.248  < 2e-16 ***
## countrySpain      3.231e-02  8.222e-02   0.393 0.694307    
## genderMale       -5.389e-01  6.331e-02  -8.513  < 2e-16 ***
## age               1.055e-01  3.635e-03  29.014  < 2e-16 ***
## tenure           -3.096e-03  1.082e-02  -0.286 0.774720    
## balance           2.062e-06  5.738e-07   3.594 0.000326 ***
## credit_card1     -1.746e-02  6.929e-02  -0.252 0.801032    
## active_member1   -9.794e-01  6.600e-02 -14.838  < 2e-16 ***
## estimated_salary  4.548e-07  5.518e-07   0.824 0.409803    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 7860.5  on 7773  degrees of freedom
## Residual deviance: 6379.6  on 7763  degrees of freedom
## AIC: 6401.6
## 
## Number of Fisher Scoring iterations: 5

Membuat model dengan feature selection.

# stepwise
model_step <- step(object = model_bank_all, direction = "backward", trace = F)
summary(model_step)
## 
## Call:
## glm(formula = churn ~ country + gender + age + balance + active_member, 
##     family = "binomial", data = bank_train)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -2.1578  -0.6348  -0.4206  -0.2357   3.1457  
## 
## Coefficients:
##                  Estimate Std. Error z value Pr(>|z|)    
## (Intercept)    -5.320e+00  1.628e-01 -32.683  < 2e-16 ***
## countryGermany  8.029e-01  7.844e-02  10.235  < 2e-16 ***
## countrySpain    3.129e-02  8.215e-02   0.381 0.703261    
## genderMale     -5.390e-01  6.328e-02  -8.519  < 2e-16 ***
## age             1.055e-01  3.632e-03  29.032  < 2e-16 ***
## balance         2.072e-06  5.735e-07   3.613 0.000302 ***
## active_member1 -9.796e-01  6.594e-02 -14.855  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 7860.5  on 7773  degrees of freedom
## Residual deviance: 6382.2  on 7767  degrees of freedom
## AIC: 6396.2
## 
## Number of Fisher Scoring iterations: 5
  • Interpretasi
# interpretasi koef. 
exp(coefficients(model_step))
##    (Intercept) countryGermany   countrySpain     genderMale            age 
##    0.004892448    2.231907431    1.031789379    0.583320387    1.111216252 
##        balance active_member1 
##    1.000002072    0.375449517

kemungkinan seorang nasabah yang berasal dari France, bergender Female, bukan member aktif, dengan nilai usia dan balance =0, adalah sebesar 0.004 kali

kemungkinan seorang nasabah asal Germany untuk churn adalah 2.23 kali lebih mungkin dibandingkan seorang nasabah asal France, dengan catatan bahwa nilai dari variabel/prediktor lain adalah konstan.

kemungkinan seorang nasabah asal Spain untuk churn adalah 1.03 kali lebih mungkin dibandingkan seorang nasabah asal France, dengan catatan bahwa nilai dari variabel/prediktor lain adalah konstan.

kemungkinan seorang nasabah bergender Male untuk churn adalah 0.583 kali lebih mungkin dibandingkan seorang nasabah bergender Female, dengan catatan bahwa nilai dari variabel/prediktor lain adalah konstan.

kemungkinan seorang nasabah untuk churn adalah 1.00 kali lebih besar dibandingkan dengan nasabah lain yang memiliki nilai ba;ance 1 satuan di bawahnya.

kemungkinan seorang nasabah yang aktif (active_member) untuk churn adalah 0.37 kali lebih mungkin dibandingkan nasabah yang tidak aktif.

  • Predict
head(bank_train)
##      credit_score country gender age tenure  balance credit_card active_member
## 2795          727  France Female  26      9 121508.3           1             1
## 7660          850 Germany Female  45      1 121874.9           0             0
## 3974          599 Germany   Male  39      2 188976.9           0             1
## 8579          638   Spain   Male  41      7      0.0           1             0
## 9136          766  France Female  52      7  92510.9           0             1
## 443           733  France   Male  33      3      0.0           1             1
##      estimated_salary churn
## 2795        146785.44     0
## 7660          6865.41     1
## 3974        176142.09     0
## 8579         43889.41     0
## 9136         66193.61     0
## 443           7666.73     0

Melakukan prediksi probability churn untuk data bank_test dan disimpan pada kolom baru bernama pred.churn. Note: type “response” memberikan hasil berupa probability.

bank_test$pred.churn <- predict(model_step, bank_test, type="response")

Mengklasifikasikan data bank.test berdasarkan pred.churn dan simpan pada kolom baru bernama pred.Label dengan threshold 0.5.

bank_test$pred.Label <- ifelse(bank_test$pred.churn > 0.5, "1", "0")

# ubah kelas target (aktual dan prediksi) menjadi factor

bank_test$pred.Label <- as.factor(bank_test$pred.Label)
# lihat hasil prediksi
bank_test %>% select(churn, pred.Label) %>% head()
##    churn pred.Label
## 4      0          0
## 13     0          0
## 14     0          0
## 15     0          0
## 18     0          0
## 19     0          0

Model Evaluation

  • Confusion Matrix

Setelah dilakukan prediksi menggunakan model, masih ada saja prediksi yang salah. Pada klasifikasi, selain menggunakan AIC, kita mengevaluasi model berdasarkan confusion matrix:

  • TP (True Positive) = Ketika kita memprediksi kelas positive, dan itu benar
  • TN (True Negative) = Ketika kita memprediksi kelas negative, dan itu benar
  • FP (False Positive) = Ketika kita memprediksi kelas positive, dan itu salah
  • FN (False Negative) = Ketika kita memprediksi kelas negative, dan itu salah
# confusion matrix
library(caret)

confusionMatrix(data = bank_test$pred.Label,
                reference = bank_test$churn,
                positive = "1")
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction    0    1
##          0 1481  316
##          1   53   94
##                                          
##                Accuracy : 0.8102         
##                  95% CI : (0.792, 0.8274)
##     No Information Rate : 0.7891         
##     P-Value [Acc > NIR] : 0.01146        
##                                          
##                   Kappa : 0.2545         
##                                          
##  Mcnemar's Test P-Value : < 2e-16        
##                                          
##             Sensitivity : 0.22927        
##             Specificity : 0.96545        
##          Pos Pred Value : 0.63946        
##          Neg Pred Value : 0.82415        
##              Prevalence : 0.21091        
##          Detection Rate : 0.04835        
##    Detection Prevalence : 0.07562        
##       Balanced Accuracy : 0.59736        
##                                          
##        'Positive' Class : 1              
##

Owner bank ingin mementingkan kelas not churn untuk merancang strategi mempertahankan nasabah. Maka metrics yang dipilih adalah precision (Pos Pred Value). Note: Mengurangi FP (Dianggap churn padahal not churn)

Maka nilai Pos Pred Value diusahakan tinggi, di atas 85%. Pada model ini didapatkan nilai Pos Pred Value 0.6394 (63.94%).

k-NN

k-NN adalah K-nearest neighboor. Metode ini akan mengkasifikasi data baru dengan membandingkan karakteristik data baru (data test) dengan data yang ada (data train). Kedekatan karakteristik tersebut diukur dengan Euclidean Distance hingga didapatkan jarak. Kemudian akan dipilih k tetangga terdekat dari data baru tersebut, kemudian ditentukan kelasnya menggunakan majority voting.

Menetapkan nilai k yang optimum

library(dplyr)
# prediktor
bank_train_x <- bank_train %>% select_if(is.numeric)
head(bank_train_x)
##      credit_score age tenure  balance estimated_salary
## 2795          727  26      9 121508.3        146785.44
## 7660          850  45      1 121874.9          6865.41
## 3974          599  39      2 188976.9        176142.09
## 8579          638  41      7      0.0         43889.41
## 9136          766  52      7  92510.9         66193.61
## 443           733  33      3      0.0          7666.73
bank_test_x <- bank_test %>% select_if(is.numeric)
head(bank_test_x)
##    credit_score age tenure balance estimated_salary pred.churn
## 4           699  39      1       0         93826.63 0.23017700
## 13          476  34     10       0         26260.98 0.15000170
## 14          549  25      5       0        190857.79 0.06394302
## 15          635  35      7       0         65951.65 0.07060261
## 18          549  24      9       0         14406.41 0.02326022
## 19          587  45      6       0        158684.81 0.25307000
# target
bank_train_y <- bank_train[,"churn"]
#bank_train_y

bank_test_y <- bank_test[,"churn"]
#bank_test_y

Data prediktor akan discaling menggunakan z-score standarization. Data test juga harus discaling menggunakan parameter dari data train (karena menganggap data test adalah unseen data).

# scaling data prediktor

bank_train_xs <- scale(bank_train_x)


bank_test_xk <- bank_test_x %>% 
  select(-c(pred.churn))


bank_test_xs <- scale(bank_test_xk,
                      center = attr(bank_train_xs, "scaled:center"),
                      scale = attr(bank_train_xs, "scaled:scale"))

k-NN tidak membuat model sehingga langsung ke predict.

Predict

# find optimum k
sqrt(nrow(bank_train_xs))
## [1] 88.17029

  • jumlah kelas target: 2

  • k: 89 Parameter pada fungsi knn() :

  • train : variabel prediktor data train

  • test : variabel predktor data test

  • cl : variabel target data train

  • k : banyak tetangga terdekat untuk voting class

library(class) # package untuk fungsi `knn()`

bank_pred <- knn(train = bank_train_xs,
                 test = bank_test_xs,
                 cl = bank_train_y,
                 k = 89)
# cek hasil prediksi
summary(bank_pred)
##    0    1 
## 1847   97

Model evaluation

# confusion matrix
library(caret)

confusionMatrix(data = as.factor(bank_pred),
                reference = bank_test_y,
                positive = "1")
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction    0    1
##          0 1494  353
##          1   40   57
##                                           
##                Accuracy : 0.7978          
##                  95% CI : (0.7793, 0.8155)
##     No Information Rate : 0.7891          
##     P-Value [Acc > NIR] : 0.1797          
##                                           
##                   Kappa : 0.1568          
##                                           
##  Mcnemar's Test P-Value : <2e-16          
##                                           
##             Sensitivity : 0.13902         
##             Specificity : 0.97392         
##          Pos Pred Value : 0.58763         
##          Neg Pred Value : 0.80888         
##              Prevalence : 0.21091         
##          Detection Rate : 0.02932         
##    Detection Prevalence : 0.04990         
##       Balanced Accuracy : 0.55647         
##                                           
##        'Positive' Class : 1               
##

Tingkat precision yang didapatkan dengan metode k-NN sebesar 0.5876 (58.76%).

KESIMPULAN

  • Metode logistic regression memberi nilai precision 63.94%, lebih tinggi dibandingkan metode k-NN yang memberikan nilai precision 58.76%

  • Nilai precision dari kedua model ini masih belum memuaskan, maka sebaiknya ditingkatkan lagi dengan membuat komposisi data train yang lebih balance.

  • Data imbalance pada data train sebesar 0.202 (churn) dan 0.797 (not churn) bisa diperbaiki dengan cara:

    • Menambah observasi/baris data (jika memungkinkan)
    • Seimbangkan kelas target : upsampling atau downsampling