1 Επιλογή μεθόδου

Θέλουμε την πιθανότητα να φύγει κάθε πελάτης και να εξηγήσουμε ποιοι παράγοντες την αυξάνουν ή τη μειώνουν και κατά πόσο. Γι’ αυτό διαλέγω Λογιστική Παλινδρόμηση: δίνει πιθανότητα (0–1), οι συντελεστές γίνονται odds ratios με exp() και έχουμε p-values για το ποιοι παράγοντες είναι σημαντικοί. Δέντρα / Random Forest ίσως προβλέπουν λίγο καλύτερα, αλλά δεν εξηγούν τόσο εύκολa κατά πόσο αλλάζει η πιθανότητα ανά παράγοντα. Η μεταβλητή-στόχος Churn είναι δυαδική (Yes/No), δηλαδή έχουμε πρόβλημα κατάταξης — και η λογιστική είναι η πιο ερμηνεύσιμη επιλογή για τέτοιον στόχο. Άρα, με βάση το κριτήριο της ερμηνευσιμότητας, επιλέγουμε λογιστική παλινδρόμηση.

2 Πακέτα

library(caTools)  # split σε train/test
library(ROCR)     # ROC και AUC

3 Δεδομένα και καθάρισμα

# ΥΠΟΘΕΣΗ: το αρχείο του Kaggle είναι στον ίδιο φάκελο. Αν λείπει, το κατεβάζουμε
# από δημόσιο mirror ώστε να κάνει knit και χωρίς χειροκίνητο κατέβασμα.
csv_name <- "WA_Fn-UseC_-Telco-Customer-Churn.csv"
if (!file.exists(csv_name)) {
  url <- "https://raw.githubusercontent.com/IBM/telco-customer-churn-on-icp4d/master/data/Telco-Customer-Churn.csv"
  download.file(url, csv_name, quiet = TRUE, mode = "wb")
}
telco <- read.csv(csv_name, stringsAsFactors = TRUE)

telco$customerID <- NULL  # δεν χρειάζεται το ID
telco$TotalCharges <- as.numeric(as.character(telco$TotalCharges))  # ήταν κείμενο
telco <- na.omit(telco)  # φεύγουν 11 κενές γραμμές

dim(telco)
## [1] 7032   20
table(telco$Churn)
## 
##   No  Yes 
## 5163 1869
# baseline = accuracy της "μηδενικής" πρόβλεψης (πάντα την πλειοψηφική κλάση, δηλ. "No")
baseline <- max(prop.table(table(telco$Churn)))

Μένουν 7032 πελάτες, από τους οποίους έχει φύγει το 26.6%. Αν προβλέπαμε ότι δεν φεύγει κανείς, θα είχαμε accuracy 73.4% — αυτό είναι το baseline που θέλουμε να ξεπεράσει το μοντέλο.

4 Train / Test

set.seed(988) #(iis23088)
spl <- sample.split(telco$Churn, SplitRatio = 0.7)
Train <- subset(telco, spl == TRUE)
Test  <- subset(telco, spl == FALSE)
# Ο διαχωρισμός με sample.split είναι stratified: κρατά το ίδιο ποσοστό churn σε train και test. Κράτησα 70% train / 30% test.

5 Το μοντέλο

model <- glm(Churn ~ ., data = Train, family = binomial)
summary(model)
## 
## Call:
## glm(formula = Churn ~ ., family = binomial, data = Train)
## 
## Coefficients: (7 not defined because of singularities)
##                                        Estimate Std. Error z value Pr(>|z|)    
## (Intercept)                           2.214e+00  9.756e-01   2.269 0.023243 *  
## genderMale                           -1.746e-02  7.720e-02  -0.226 0.821050    
## SeniorCitizen                         2.615e-01  1.013e-01   2.582 0.009830 ** 
## PartnerYes                            1.641e-02  9.337e-02   0.176 0.860463    
## DependentsYes                        -1.930e-01  1.078e-01  -1.789 0.073537 .  
## tenure                               -5.996e-02  7.505e-03  -7.988 1.37e-15 ***
## PhoneServiceYes                       9.981e-01  7.758e-01   1.286 0.198277    
## MultipleLinesNo phone service                NA         NA      NA       NA    
## MultipleLinesYes                      6.105e-01  2.122e-01   2.877 0.004020 ** 
## InternetServiceFiber optic            2.804e+00  9.557e-01   2.933 0.003352 ** 
## InternetServiceNo                    -2.748e+00  9.633e-01  -2.853 0.004329 ** 
## OnlineSecurityNo internet service            NA         NA      NA       NA    
## OnlineSecurityYes                     8.515e-02  2.132e-01   0.399 0.689569    
## OnlineBackupNo internet service              NA         NA      NA       NA    
## OnlineBackupYes                       2.407e-01  2.111e-01   1.140 0.254287    
## DeviceProtectionNo internet service          NA         NA      NA       NA    
## DeviceProtectionYes                   2.219e-01  2.113e-01   1.050 0.293741    
## TechSupportNo internet service               NA         NA      NA       NA    
## TechSupportYes                        1.618e-01  2.161e-01   0.749 0.453915    
## StreamingTVNo internet service               NA         NA      NA       NA    
## StreamingTVYes                        1.018e+00  3.902e-01   2.608 0.009095 ** 
## StreamingMoviesNo internet service           NA         NA      NA       NA    
## StreamingMoviesYes                    9.817e-01  3.903e-01   2.515 0.011906 *  
## ContractOne year                     -6.655e-01  1.286e-01  -5.176 2.27e-07 ***
## ContractTwo year                     -1.475e+00  2.256e-01  -6.537 6.27e-11 ***
## PaperlessBillingYes                   3.136e-01  8.879e-02   3.532 0.000412 ***
## PaymentMethodCredit card (automatic) -9.131e-02  1.355e-01  -0.674 0.500344    
## PaymentMethodElectronic check         2.717e-01  1.122e-01   2.423 0.015411 *  
## PaymentMethodMailed check            -1.079e-01  1.364e-01  -0.791 0.429191    
## MonthlyCharges                       -8.160e-02  3.799e-02  -2.148 0.031704 *  
## TotalCharges                          3.191e-04  8.517e-05   3.746 0.000180 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 5699.5  on 4921  degrees of freedom
## Residual deviance: 4101.2  on 4898  degrees of freedom
## AIC: 4149.2
## 
## Number of Fisher Scoring iterations: 6

Θετικός συντελεστής = αυξάνει την πιθανότητα αποχώρησης αρνητικός, όσο μεγαλώνει η σχέση με την εταιρεία, = τη μειώνει.

# προβλέψεις πιθανότητας στο test set (τις χρησιμοποιούμε παρακάτω)
pred <- predict(model, newdata = Test, type = "response")

6 Ερωτήσεις

6.1 Μηνιαίο συμβόλαιο και χαμηλό tenure

# παίρνω τους πελάτες του test με μηνιαίο συμβόλαιο και χαμηλό tenure (<=3 μήνες)
# και βλέπω τη μέση εκτιμώμενη πιθανότητά τους.
idx <- Test$Contract == "Month-to-month" & Test$tenure <= 3
prob1 <- mean(pred[idx])
prob1
## [1] 0.5069384

Η μέση εκτιμώμενη πιθανότητα αποχώρησης είναι 50.7%, δηλαδή περίπου διπλάσια από το συνολικό ποσοστό αποχώρησης (26.6%) — πελάτες υψηλού κινδύνου.

6.2 Odds ratio για το συμβόλαιο

exp(coef(model))[grep("Contract", names(coef(model)))]
## ContractOne year ContractTwo year 
##        0.5140159        0.2287583

Με αναφορά το μηνιαίο συμβόλαιο, το ετήσιο (One year) και το διετές (Two year) έχουν OR < 1, άρα μειώνουν τα odds αποχώρησης. Δηλαδή το μηνιαίο συμβόλαιο έχει πολύ μεγαλύτερα odds να φύγει ο πελάτης.

6.3 Σημαντικά χαρακτηριστικά

est <- summary(model)$coefficients
sig <- est[est[, 4] < 0.05, c(1, 4)]   # Estimate και p-value των σημαντικών (p<0.05)
round(sig, 4)
##                               Estimate Pr(>|z|)
## (Intercept)                     2.2141   0.0232
## SeniorCitizen                   0.2615   0.0098
## tenure                         -0.0600   0.0000
## MultipleLinesYes                0.6105   0.0040
## InternetServiceFiber optic      2.8036   0.0034
## InternetServiceNo              -2.7485   0.0043
## StreamingTVYes                  1.0179   0.0091
## StreamingMoviesYes              0.9817   0.0119
## ContractOne year               -0.6655   0.0000
## ContractTwo year               -1.4751   0.0000
## PaperlessBillingYes             0.3136   0.0004
## PaymentMethodElectronic check   0.2717   0.0154
## MonthlyCharges                 -0.0816   0.0317
## TotalCharges                    0.0003   0.0002

Όσες μεταβλητές έχουν p < 0.05 και θετικό Estimate αυξάνουν σημαντικά την πιθανότητα αποχώρησης — τυπικά το μηνιαίο συμβόλαιο, το Fiber optic, το PaperlessBilling και το Electronic check. Το μεγάλο tenure τη μειώνει. Το (Intercept) στον πίνακα δεν είναι χαρακτηριστικό — είναι η σταθερά του μοντέλου.*

6.4 Απόδοση στο κατώφλι 0.5

# Προβλέψεις πιθανότητας στο test set
pred_class <- ifelse(pred > 0.5, "Yes", "No")
cm <- table(Πραγματικό = Test$Churn, Πρόβλεψη = pred_class)
cm
##           Πρόβλεψη
## Πραγματικό   No  Yes
##        No  1409  140
##        Yes  256  305
accuracy <- sum(diag(cm)) / sum(cm)
recall   <- cm["Yes", "Yes"] / sum(cm["Yes", ])   # recall για τους αποχωρούντες

# AUC με ROCR
rocr <- prediction(pred, ifelse(Test$Churn == "Yes", 1, 0))
auc  <- performance(rocr, "auc")@y.values[[1]]

c(accuracy = round(accuracy, 3), recall = round(recall, 3), AUC = round(auc, 3))
## accuracy   recall      AUC 
##    0.812    0.544    0.851
plot(performance(rocr, "tpr", "fpr"), colorize = TRUE, main = "ROC")
abline(0, 1, lty = 2)

Accuracy 81.2% — πάνω από το baseline (73.4%) — και AUC 0.851, δηλαδή διακρίνει καλά όσους φεύγουν από όσους μένουν. Το recall είναι μόνο 54.4%, άρα στο 0.5 χάνουμε αρκετούς που όντως φεύγουν.

6.5 Στόχευση του top 20%

n20 <- round(0.20 * length(pred))                 # πόσοι πελάτες είναι το 20%
top <- order(pred, decreasing = TRUE)[1:n20]      # οι 20% με τη μεγαλύτερη πιθανότητα
capture <- sum(Test$Churn[top] == "Yes") / sum(Test$Churn == "Yes")
round(capture, 3)
## [1] 0.52

Στοχεύοντας μόνο το 20% με την υψηλότερη πιθανότητα, πιάνουμε το 52% των πραγματικών αποχωρήσεων — περίπου 2.6 φορές καλύτερα από τυχαία στόχευση. Άρα το μοντέλο είναι πολύ χρήσιμο για στοχευμένες προσφορές με περιορισμένο budget.

7 Συμπέρασμα

Η λογιστική παλινδρόμηση δίνει και πιθανότητες και εξηγήσεις. Οι πιο επικίνδυνοι πελάτες είναι όσοι έχουν μηνιαίο συμβόλαιο και χαμηλό tenure. Με AUC ≈ 0.85 και στοχεύοντας το top 20% πιάνουμε το 52% των αποχωρήσεων, που είναι πολύ χρήσιμο για το marketing.