Περιγραφή του Dataset και Πηγή

Το dataset περιλαμβάνει πληροφορίες για 45.000 πελάτες που έχουν αιτηθεί για προσωπικά δάνεια. Περιλαμβάνει χαρακτηριστικά όπως ηλικία, εισόδημα, σκοπός δανείου, εμπειρία, ιστορικό πίστωσης, και αν ο πελάτης αποπλήρωσε ή όχι το δάνειό του.

Πηγή: Το dataset διατίθεται από το Kaggle.

Επιχειρηματική Αναλυτική – Αιτιολόγηση Επιλογής

Η πρόβλεψη πιθανής καθυστέρησης πληρωμής ενός δανείου είναι κρίσιμη για τα χρηματοπιστωτικά ιδρύματα. Μέσω αυτής της ανάλυσης, μπορούμε να εντοπίσουμε προφίλ πελατών με αυξημένο ρίσκο, να διαμορφώσουμε καλύτερες πολιτικές αξιολόγησης και να βελτιώσουμε τις διαδικασίες έγκρισης δανείων.

Πιθανά Επιχειρηματικά Ερωτήματα

  • Ποιοι παράγοντες αυξάνουν τον κίνδυνο αθέτησης πληρωμής;
  • Ποιοι πελάτες είναι περισσότερο αξιόπιστοι;
  • Υπάρχουν δημογραφικά πρότυπα που επηρεάζουν το ρίσκο;

Διάβασμα δεδομένων

loan_data <- read.csv("C:/Users/User/Downloads/loan_data.csv")

Περιγραφή Μεταβλητών

Πίνακας Περιγραφής Μεταβλητών
Μεταβλητή Τύπος
person_age Αριθμητικό
person_gender Κατηγορική
person_education Κατηγορική
person_income Αριθμητικό
person_emp_exp Αριθμητικό
person_home_ownership Κατηγορική
loan_amnt Αριθμητικό
loan_intent Κατηγορική
loan_int_rate Αριθμητικό
loan_percent_income Αριθμητικό
cb_person_cred_hist_length Αριθμητικό
credit_score Αριθμητικό
previous_loan_defaults_on_file Κατηγορική
loan_status Δυαδικό

Περιγραφικά Στατιστικά

summary(loan_data)
##    person_age     person_gender      person_education   person_income    
##  Min.   : 20.00   Length:45000       Length:45000       Min.   :   8000  
##  1st Qu.: 24.00   Class :character   Class :character   1st Qu.:  47204  
##  Median : 26.00   Mode  :character   Mode  :character   Median :  67048  
##  Mean   : 27.76                                         Mean   :  80319  
##  3rd Qu.: 30.00                                         3rd Qu.:  95789  
##  Max.   :144.00                                         Max.   :7200766  
##  person_emp_exp   person_home_ownership   loan_amnt     loan_intent       
##  Min.   :  0.00   Length:45000          Min.   :  500   Length:45000      
##  1st Qu.:  1.00   Class :character      1st Qu.: 5000   Class :character  
##  Median :  4.00   Mode  :character      Median : 8000   Mode  :character  
##  Mean   :  5.41                         Mean   : 9583                     
##  3rd Qu.:  8.00                         3rd Qu.:12237                     
##  Max.   :125.00                         Max.   :35000                     
##  loan_int_rate   loan_percent_income cb_person_cred_hist_length  credit_score  
##  Min.   : 5.42   Min.   :0.0000      Min.   : 2.000             Min.   :390.0  
##  1st Qu.: 8.59   1st Qu.:0.0700      1st Qu.: 3.000             1st Qu.:601.0  
##  Median :11.01   Median :0.1200      Median : 4.000             Median :640.0  
##  Mean   :11.01   Mean   :0.1397      Mean   : 5.867             Mean   :632.6  
##  3rd Qu.:12.99   3rd Qu.:0.1900      3rd Qu.: 8.000             3rd Qu.:670.0  
##  Max.   :20.00   Max.   :0.6600      Max.   :30.000             Max.   :850.0  
##  previous_loan_defaults_on_file  loan_status    
##  Length:45000                   Min.   :0.0000  
##  Class :character               1st Qu.:0.0000  
##  Mode  :character               Median :0.0000  
##                                 Mean   :0.2222  
##                                 3rd Qu.:0.0000  
##                                 Max.   :1.0000

Δημιουργία του καθαρισμένου dataset (αφαίρεση outliers)

Βλέπουμε μερικά πολύ σημαντικά outliers στο σύνολο δεδομένων μας.Είναι σημαντικό να αφαιρεθούν ώστε να μην επηρεαστούν αρνητικά οι προβλέψεις μας.

loan_data_clean <- loan_data %>%
  filter(person_age <= 90, person_emp_exp <= 70, person_income <= 5000000)

Διαγράμματα

1. Scatterplot – Ηλικία και Χρόνια Εργασιακής Εμπειρίας

ggplot(loan_data_clean, aes(x = person_age, y = person_emp_exp, color = factor(loan_status))) +
  geom_jitter(alpha = 0.5, width = 0.3, height = 0.3) +
  labs(title = "Years of Experience vs. Age (Colored by Loan Status)",
       x = "Age", y = "Employment Experience",
       color = "Loan Status\n(0 = No Default, 1 = Defaulted)") +
  scale_color_manual(values = c("red", "blue"),
                     labels = c("No Default", "Defaulted")) +
  theme_minimal()

Διάγραμμα 1. Σχέση Ηλικίας και Εμπειρίας ανά Κατάσταση Δανείου.

Σχόλιο: Οι περισσότερες καθυστερήσεις συμβαίνουν σε άτομα με χαμηλή εμπειρία και ηλικία.

2. Boxplot – Ποσό Δανείου ανά Κατοχή Κατοικίας

ggplot(loan_data_clean, aes(x = person_home_ownership, y = loan_amnt, fill = factor(loan_status))) +
  geom_boxplot() +
  labs(title = "Loan Amount by Home Ownership",
       x = "Home Ownership", y = "Loan Amount ($)",
       fill = "Loan Status") +
  theme_minimal()

Διάγραμμα 2. Ποσό Δανείου ανά Κατοχή Κατοικίας.

Σχόλιο: Οι ιδιοκτήτες κατοικίας φαίνεται να λαμβάνουν μικρότερα δάνεια με λιγότερες καθυστερήσεις, ενώ οι ενοικιαστές εμφανίζουν μεγαλύτερη διακύμανση και υψηλότερο ρίσκο καθυστέρησης.

3. Ιστόγραμμα – Εισόδημα και Κατάσταση Δανείου

ggplot(loan_data_clean, aes(x = person_income, fill = factor(loan_status))) +
  geom_histogram(position = "identity", alpha = 0.6, bins = 50) +
  labs(title = "Income Distribution by Loan Status",
       x = "Income", y = "Count", fill = "Loan Status") +
  theme_minimal()

Διάγραμμα 3. Κατανομή Εισοδήματος με βάση την Κατάσταση Δανείου.

Σχόλιο: Οι χαμηλότεροι μισθοί σχετίζονται με υψηλότερο ποσοστό καθυστέρησης.

4. Bar Chart – Εκπαίδευση και Κατάσταση Δανείου

ggplot(loan_data_clean, aes(x = person_education, fill = factor(loan_status))) +
  geom_bar(position = "dodge", color = "black") +
  labs(title = "Loan Status by Person Education",
       x = "Education Level", y = "Count",
       fill = "Loan Status\n(0 = No Default, 1 = Defaulted)") +
  theme_light()

Διάγραμμα 4. Κατάσταση Δανείου ως προς την Εκπαίδευση.

Σχόλιο: Οι δανειολήπτες με υψηλότερη εκπαίδευση φαίνεται να έχουν μικρότερα ποσοστά καθυστέρησης.

Λογιστική Παλινδρόμηση

Βήμα 1: Προετοιμασία Δεδομένων

Αφού βρούμε την ακρίβεια του μοντέλου βάσης, για την εκπαίδευση και αξιολόγηση του μοντέλου λογιστικής παλινδρόμησης, το αρχικό σύνολο δεδομένων διαχωρίζεται τυχαία σε δύο υποσύνολα: training set (65% των παρατηρήσεων) και testing set (35% των παρατηρήσεων). Ο διαχωρισμός πραγματοποιείται με χρήση της εντολής sample() και ορίζεται τιμή seed ίση με 930, ώστε τα αποτελέσματα να είναι αναπαραγώγιμα. Η επιλογή της συγκεκριμένης τιμής προκύπτει από τα δύο τελευταία ψηφία του ιδρυματικού email.

table(loan_data_clean$loan_status)
## 
##     0     1 
## 34992 10000
baseacc <- 34992/44992
propability <- (34992/44992)*100
cat(propability)
## 77.77383

Σχόλιο: Από τη στιγμή που οι μη αθετήσεις δανείων είναι πιο συνηθισμένες απο τις αθετήσεις, θα προβλέπαμε ότι όλοι οι πελάτες αποπλήρωσαν το δάνειο.Αν θεωρούσαμε κάτι τέτοιο, θα προέκυπτε ότι θα είχαμε ακρίβεια της τάξης του 77.77%. Άρα το μοντέλο βάσης μας έχει ακρίβεια 77.77%. Αυτό το ποσοστό θα πρέπει να ξεπεράσουμε με το μοντέλο λογιστικής παλινδρόμησης ώστε να είναι χρήσιμο.

set.seed(930)
split <- sample.split(loan_data_clean$loan_status,SplitRatio=0.65)
Train = subset(loan_data_clean,split==TRUE)
Test = subset(loan_data_clean,split==FALSE)

cat("Train set:", nrow(Train), "καταχωρήσεις\n")
## Train set: 29245 καταχωρήσεις
cat("Test set:", nrow(Test), "καταχωρήσεις\n")
## Test set: 15747 καταχωρήσεις

Βήμα 2: Δημιουργία μοντέλων λογιστικής παλινδρόμησης

Ας εντοπίσουμε τις σημαντικότερες μεταβλητές

model_full <- glm(loan_status ~ ., data = Train, family = "binomial")
summary(model_full)
## 
## Call:
## glm(formula = loan_status ~ ., family = "binomial", data = Train)
## 
## Coefficients:
##                                     Estimate Std. Error z value Pr(>|z|)    
## (Intercept)                       -6.612e-01  4.514e-01  -1.465  0.14295    
## person_age                         4.056e-02  1.368e-02   2.965  0.00303 ** 
## person_gendermale                  3.037e-02  4.389e-02   0.692  0.48894    
## person_educationBachelor           2.289e-02  5.843e-02   0.392  0.69527    
## person_educationDoctorate          1.031e-01  1.841e-01   0.560  0.57539    
## person_educationHigh School        8.637e-03  6.100e-02   0.142  0.88741    
## person_educationMaster            -1.359e-02  6.953e-02  -0.196  0.84499    
## person_income                      2.556e-06  6.194e-07   4.127 3.68e-05 ***
## person_emp_exp                    -2.446e-02  1.202e-02  -2.035  0.04186 *  
## person_home_ownershipOTHER         1.087e-01  3.809e-01   0.285  0.77542    
## person_home_ownershipOWN          -1.420e+00  1.244e-01 -11.408  < 2e-16 ***
## person_home_ownershipRENT          7.122e-01  4.983e-02  14.291  < 2e-16 ***
## loan_amnt                         -1.170e-04  6.193e-06 -18.896  < 2e-16 ***
## loan_intentEDUCATION              -9.418e-01  7.231e-02 -13.024  < 2e-16 ***
## loan_intentHOMEIMPROVEMENT        -4.569e-02  8.090e-02  -0.565  0.57221    
## loan_intentMEDICAL                -3.394e-01  7.007e-02  -4.844 1.27e-06 ***
## loan_intentPERSONAL               -7.400e-01  7.434e-02  -9.954  < 2e-16 ***
## loan_intentVENTURE                -1.250e+00  7.849e-02 -15.927  < 2e-16 ***
## loan_int_rate                      3.258e-01  8.086e-03  40.296  < 2e-16 ***
## loan_percent_income                1.690e+01  4.707e-01  35.894  < 2e-16 ***
## cb_person_cred_hist_length        -2.006e-02  1.166e-02  -1.720  0.08536 .  
## credit_score                      -8.965e-03  5.071e-04 -17.680  < 2e-16 ***
## previous_loan_defaults_on_fileYes -2.043e+01  1.275e+02  -0.160  0.87267    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 30985  on 29244  degrees of freedom
## Residual deviance: 12932  on 29222  degrees of freedom
## AIC: 12978
## 
## Number of Fisher Scoring iterations: 19

Οι μεταβλητές person_income, loan_amnt, loan_intent, loan_int_rate, loan_percent_income, credit_score, και οι κατηγορίες ιδιοκτησίας person_home_ownership OWN και RENT έχουν πολύ χαμηλά p-values (p < 0.001) και επομένως θεωρούνται στατιστικά σημαντικές. Αυτές οι μεταβλητές παρουσιάζουν ισχυρή συσχέτιση με την πιθανότητα αθέτησης δανείου. Οι μεταβλητές person_age και person_emp_exp είναι επίσης στατιστικά σημαντικές, αλλά σε μικρότερο βαθμό. Οι υπόλοιπες μεταβλητές όπως person_gender, education, και previous_loan_defaults δεν εμφανίζουν στατιστικά σημαντική συσχέτιση με την εξαρτημένη μεταβλητή, καθώς τα p-values τους είναι σημαντικά μεγαλύτερα από 0.05.

Το πρόσημο των Estimate δείχνει την κατεύθυνση της επίδρασης:

Θετικό Estimate (π.χ. loan_percent_income, loan_int_rate) σημαίνει ότι αυξάνεται η πιθανότητα αθέτησης.

Αρνητικό Estimate (π.χ. credit_score, loan_amnt) σημαίνει ότι μειώνεται η πιθανότητα αθέτησης.

# Model 1
model1 <- glm(loan_status ~ person_income + credit_score, data = Train, family = "binomial")
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
summary(model1)
## 
## Call:
## glm(formula = loan_status ~ person_income + credit_score, family = "binomial", 
##     data = Train)
## 
## Coefficients:
##                 Estimate Std. Error z value Pr(>|z|)    
## (Intercept)    1.335e-01  1.832e-01   0.729    0.466    
## person_income -1.719e-05  4.818e-07 -35.686   <2e-16 ***
## credit_score  -3.030e-04  2.858e-04  -1.060    0.289    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 30985  on 29244  degrees of freedom
## Residual deviance: 29232  on 29242  degrees of freedom
## AIC: 29238
## 
## Number of Fisher Scoring iterations: 5
aic1 <- AIC(model1)

pred1 <- predict(model1, newdata = Test, type = "response")
acc1 <- mean(ifelse(pred1 > 0.5, 1, 0) == Test$loan_status)
predTrain1 <- predict(model1, newdata = Train, type = "response")
cat("Model 1 - Μέση πιθανότητα default ανά loan_status:\n")
## Model 1 - Μέση πιθανότητα default ανά loan_status:
print(tapply(predTrain1, Train$loan_status, mean))
##         0         1 
## 0.2081557 0.2716153
ggplot(Train, aes(x = person_income, y = loan_status)) +
  geom_point(alpha = 0.3, position = position_jitter(height = 0.05)) +
  geom_smooth(method = "glm", method.args = list(family = "binomial")) +
  labs(title = "Logistic Regression: Model 1",
       x = "Εισόδημα (person_income)",
       y = "Πιθανότητα Default") +
  theme_minimal()
## `geom_smooth()` using formula = 'y ~ x'
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

Σχόλιο:Η καμπύλη λογιστικής παλινδρόμησης δείχνει ότι όσο αυξάνεται το εισόδημα, η πιθανότητα αθέτησης δανείου μειώνεται δραματικά και τείνει στο 0. Αυτό είναι σύμφωνο με την κοινή λογική: τα άτομα με υψηλό εισόδημα είναι λιγότερο πιθανό να αθετήσουν ένα δάνειο. Ωστόσο, παρατηρείται μεγάλη συσσώρευση παρατηρήσεων σε χαμηλές τιμές εισοδήματος, και αρκετά ακραίες τιμές (outliers) σε υψηλά εισοδήματα που ίσως επηρεάζουν την ομαλότητα της καμπύλης.

# Model 2
model2 <- glm(loan_status ~ person_income + credit_score + loan_int_rate + loan_amnt, data = Train, family = "binomial")
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
summary(model2)
## 
## Call:
## glm(formula = loan_status ~ person_income + credit_score + loan_int_rate + 
##     loan_amnt, family = "binomial", data = Train)
## 
## Coefficients:
##                 Estimate Std. Error z value Pr(>|z|)    
## (Intercept)   -3.406e+00  2.114e-01 -16.113   <2e-16 ***
## person_income -2.982e-05  6.639e-07 -44.920   <2e-16 ***
## credit_score  -4.416e-04  3.141e-04  -1.406     0.16    
## loan_int_rate  2.946e-01  5.933e-03  49.662   <2e-16 ***
## loan_amnt      1.035e-04  2.965e-06  34.911   <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: 30985  on 29244  degrees of freedom
## Residual deviance: 24528  on 29240  degrees of freedom
## AIC: 24538
## 
## Number of Fisher Scoring iterations: 6
aic2 <- AIC(model2)
pred2 <- predict(model2, newdata = Test, type = "response")
acc2 <- mean(ifelse(pred2 > 0.5, 1, 0) == Test$loan_status)
predTrain2 <- predict(model2, newdata = Train, type = "response")
cat("Model 2 - Μέση πιθανότητα default ανά loan_status:\n")
## Model 2 - Μέση πιθανότητα default ανά loan_status:
print(tapply(predTrain2, Train$loan_status, mean))
##         0         1 
## 0.1705776 0.4031097
ggplot(Train, aes(x = loan_int_rate, y = loan_status)) +
  geom_point(alpha = 0.3, position = position_jitter(height = 0.05)) +
  geom_smooth(method = "glm", method.args = list(family = "binomial")) +
  labs(title = "Logistic Regression: Model 2",
       x = "Επιτόκιο Δανείου (loan_int_rate)",
       y = "Πιθανότητα Default") +
  theme_minimal()
## `geom_smooth()` using formula = 'y ~ x'

Σχόλιο:Η καμπύλη δείχνει ξεκάθαρα ότι όσο αυξάνεται το επιτόκιο δανείου, αυξάνεται και η πιθανότητα αθέτησης. Αυτό έχει επιχειρηματική λογική, καθώς υψηλότερο επιτόκιο σημαίνει και μεγαλύτερο κόστος δανεισμού, άρα μεγαλύτερος κίνδυνος αδυναμίας αποπληρωμής. Η σχέση είναι σχεδόν εκθετική και αποτυπώνει ισχυρή θετική συσχέτιση.

# Model 3
model3 <- glm(loan_status ~ person_income + credit_score + loan_int_rate + loan_amnt +
                            loan_percent_income + loan_intent, data = Train, family = "binomial")
summary(model3)
## 
## Call:
## glm(formula = loan_status ~ person_income + credit_score + loan_int_rate + 
##     loan_amnt + loan_percent_income + loan_intent, family = "binomial", 
##     data = Train)
## 
## Coefficients:
##                              Estimate Std. Error z value Pr(>|z|)    
## (Intercept)                -5.908e+00  2.344e-01 -25.199  < 2e-16 ***
## person_income               1.139e-06  4.902e-07   2.324 0.020135 *  
## credit_score               -2.191e-04  3.344e-04  -0.655 0.512356    
## loan_int_rate               3.340e-01  6.439e-03  51.875  < 2e-16 ***
## loan_amnt                  -1.180e-04  4.695e-06 -25.136  < 2e-16 ***
## loan_percent_income         1.636e+01  3.349e-01  48.860  < 2e-16 ***
## loan_intentEDUCATION       -1.038e+00  5.615e-02 -18.493  < 2e-16 ***
## loan_intentHOMEIMPROVEMENT -2.301e-01  6.197e-02  -3.713 0.000205 ***
## loan_intentMEDICAL         -3.446e-01  5.304e-02  -6.497 8.22e-11 ***
## loan_intentPERSONAL        -7.708e-01  5.735e-02 -13.441  < 2e-16 ***
## loan_intentVENTURE         -1.306e+00  6.122e-02 -21.326  < 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: 30985  on 29244  degrees of freedom
## Residual deviance: 22210  on 29234  degrees of freedom
## AIC: 22232
## 
## Number of Fisher Scoring iterations: 5
aic3 <- AIC(model3)

pred3 <- predict(model3, newdata = Test, type = "response")
acc3 <- mean(ifelse(pred3 > 0.5, 1, 0) == Test$loan_status)
predTrain3 <- predict(model3, newdata = Train, type = "response")
cat("Model 3 - Μέση πιθανότητα default ανά loan_status:\n")
## Model 3 - Μέση πιθανότητα default ανά loan_status:
print(tapply(predTrain3, Train$loan_status, mean))
##         0         1 
## 0.1528924 0.4649943
ggplot(Train, aes(x = loan_percent_income, y = loan_status)) +
  geom_point(alpha = 0.3, position = position_jitter(height = 0.05)) +
  geom_smooth(method = "glm", method.args = list(family = "binomial")) +
  labs(title = "Logistic Regression: Model 3",
       x = "Ποσοστό δανείου ως προς εισόδημα",
       y = "Πιθανότητα Default") +
  theme_minimal()
## `geom_smooth()` using formula = 'y ~ x'

Σχόλιο:Η σχέση εδώ είναι εντυπωσιακά καθαρή: όσο μεγαλύτερο ποσοστό του εισοδήματος απορροφάται από το δάνειο, τόσο αυξάνεται η πιθανότητα default. Η καμπύλη φτάνει πολύ κοντά στο 1 όταν το ποσοστό ξεπερνά ~0.5 (δηλαδή όταν το δάνειο αντιστοιχεί στο 50% του εισοδήματος). Πρόκειται για μία από τις ισχυρότερες μεταβλητές πρόβλεψης, όπως φαίνεται από τη γραφική απεικόνιση.

Σύγκριση μοντέλων λογιστικής παλινδρόμησησς και συμπεράσματα

comparison <- data.frame(
  Μοντέλο = c("Baseline", "Model 1", "Model 2", "Model 3"),
  AIC = c(NA, aic1, aic2, aic3),
  Accuracy = round(c(baseacc, acc1, acc2, acc3) * 100, 2)
)

print(comparison)
##    Μοντέλο      AIC Accuracy
## 1 Baseline       NA    77.77
## 2  Model 1 29237.81    77.77
## 3  Model 2 24538.37    82.42
## 4  Model 3 22232.23    83.41

Σχόλιο: Model 1: Το πρώτο μοντέλο, το οποίο περιέχει μόνο τις μεταβλητές person_income και credit_score, έχει AIC ίσο με 29237.81 και ακρίβεια 77.77%, δηλαδή δεν βελτιώνει την απόδοση σε σχέση με τη baseline πρόβλεψη.

Model 2: Με την προσθήκη των επιπλέον μεταβλητών loan_int_rate και loan_amnt, το Model 2 μειώνει το AIC σε 24538.37 και αυξάνει την ακρίβεια στο 82.42%. Αυτό υποδηλώνει σημαντική βελτίωση στην προσαρμογή του μοντέλου και την απόδοση πρόβλεψης.

Model 3: Με περαιτέρω προσθήκη των μεταβλητών loan_percent_income και loan_intent, το AIC πέφτει ακόμα περισσότερο, σε 22232.23, ενώ η ακρίβεια ανεβαίνει στο 83.41%. Αυτή η σταδιακή βελτίωση δείχνει ότι οι επιπλέον μεταβλητές συμβάλλουν θετικά στο μοντέλο.

Η μέση προβλεπόμενη πιθανότητα αθέτησης δανείου για κάθε κατηγορία loan_status δείχνει πώς το κάθε μοντέλο διαχωρίζει τις περιπτώσεις default από τις μη-default. Το πρώτο μοντέλο εμφανίζει μικρή διαφορά και περιορισμένη διαχωριστική ικανότητα. Ωστόσο, με την προσθήκη σημαντικών μεταβλητών στα επόμενα μοντέλα, η διαφορά αυξάνεται σημαντικά (μέχρι και 31.2 ποσοστιαίες μονάδες στο μοντέλο 3), γεγονός που υποδηλώνει σαφώς βελτιωμένη απόδοση ταξινόμησης και καλύτερη κατανόηση των υποκείμενων σχέσεων στο dataset.

Η εντολή predict() με type = “response” επιστρέφει τις προβλεπόμενες πιθανότητες το δάνειο να αθετηθεί (loan_status = 1). Οι τιμές κυμαίνονται από 0 έως 1 και εκφράζουν το πόσο σίγουρο είναι το μοντέλο για την κάθε πρόβλεψη. Οι πιθανότητες αυτές μπορούν στη συνέχεια να μετατραπούν σε κατηγορίες (0 ή 1) με χρήση ενός κατωφλίου (π.χ. 0.5) για την εξαγωγή της τελικής απόφασης.

Δημιουργία μοντέλου CART

Για λόγους δίκαιης σύγκρισης, θα χρησιμοποιήσουμε στο μοντέλο CART τις ίδιες ανεξάρτητες μεταβλητές όπως στο καλύτερο μοντέλο λογιστικής παλινδρόμησης το οποίο είναι το μοντέλο 3). Έτσι, μπορούμε να αξιολογήσουμε τη σχετική απόδοση και ερμηνευσιμότητα των δύο μοντέλων κάτω από τις ίδιες συνθήκες. Ξεκινάμε με το cross-validation και αναζητούμε το καλύτερο cp ενώ εκπαιδεύουμε το μοντέλο με τις ίδιες μεταβλητές του μοντέλου 3.

Το σύνολο δεδομένων μας χαρακτηρίζεται imbalanced και για αυτό θα χρειαστεί εξισορρόπηση. Περίπου 78% των περιπτώσεων αφορούν πελάτες που δεν αθέτησαν το δάνειο (τιμή = 0 ή “no”) και μόνο 22% αυτούς που το αθέτησαν (τιμή = 1 ή “yes”). Αυτή η ασυμμετρία μπορεί να προκαλέσει προκατάληψη των μοντέλων προς την πλειοψηφική τάξη.

Για να αντιμετωπιστεί αυτό, εφαρμόστηκε τεχνική εξισορρόπησης με SMOTE στο training set μέσω της συνάρτησης step_smote() του πακέτου themis. Αυτό δημιούργησε συνθετικά δείγματα της μειοψηφικής τάξης (“yes”), ενισχύοντας έτσι την ικανότητα του μοντέλου να μάθει σωστά και τις δύο κατηγορίες.

Ωστόσο για να χρησιμοποιηθεί η συνάρτηση recipe που είναι απαραίτητη για την εφαρμογή SMOTE, ειναι σημαντική η μετατροπή των κατηγορικών μεταβλητών σε αριθμητικές. Για τον σκοπό αυτό, χρησιμοποιήθηκε το βήμα step_dummy. Επίσης, οι τιμές 0 και 1 των κλάσεων μας λαμβάνονταν ως αρηθμητικές, κάτι το οποίο εμπόδιζε την χρήση της συνάρτησης step_smote, και έτσι χρησιμοποιήθηκε το factor ώστε να μετατραπούν σε δυαδικές.

Train$loan_status <- factor(Train$loan_status, levels = c(0, 1), labels = c("no", "yes"))
Test$loan_status  <- factor(Test$loan_status, levels = c(0, 1), labels = c("no", "yes"))

# Recipe: dummy encoding + SMOTE
rec <- recipe(loan_status ~ person_income + credit_score + loan_int_rate + loan_amnt +
                loan_percent_income + loan_intent, data = Train) %>%
  step_dummy(all_nominal_predictors()) %>%
  step_smote(loan_status)

numFolds <- trainControl(
  method = "cv",
  number = 5,
  classProbs = TRUE
)

# cp values to try
cpGrid <- expand.grid(.cp = seq(0.01, 0.7, 0.01))

# Training the model
cart_cv <- train(
  rec,
  data = Train,
  method = "rpart",
  trControl = numFolds,
  tuneGrid = cpGrid
)

# Get best cp
best_cp <- cart_cv$bestTune$cp
cat("Best cp selected from cross-validation:", format(best_cp), "\n")
## Best cp selected from cross-validation: 0.01

Αφού εξετάσουμε τις τιμές του cp, επιλέγουμε την καλύτερη ώστε να δημιουργήσουμε το τελικό μοντέλο.

tree <- rpart(
  loan_status ~ person_income + credit_score + loan_int_rate + loan_amnt +
    loan_percent_income + loan_intent,
  data = Train,
  method = "class",         
  cp = 0.01,                
  minbucket = 25            
)

Ας οπτικοποιήσουμε το Δέντρο Απόφασης του μοντέλου.

# Οπτικοποίηση δέντρου
prp(tree)

Ρίζα

  • Κόμβος 1:loan_percent_income < 0.25

Αν < 0.25 → Πάμε αριστερά.

Αν ≥ 0.25 → Πάμε δεξιά και η πρόβλεψη είναι yes (θα υπάρξει default).

Εάν το δάνειο αντιστοιχεί σε πάνω από το 25% του εισοδήματος, θεωρείται υψηλό βάρος → αυξημένος κίνδυνος αθέτησης.

  • Κόμβος 2: loan_int_rate < 14

Αν < 14% → Πάμε αριστερά.

Αν ≥ 14% → Πάμε δεξιά.

Αριστερό Υπόδεντρο (loan_int_rate < 14)

  • Κόμβος 3: person_income >= 24.000

Αν ναι → πρόβλεψη: no

Αν όχι, εξετάζουμε:

  • Κόμβος 4: loan_percent_income < 0.13

Αν ναι → πρόβλεψη: yes

Αν όχι → πρόβλεψη: no

Εάν το εισόδημα είναι υψηλό ή το ποσοστό δανείου πολύ μικρό, ο πελάτης πιθανώς δεν αθετεί.

Δεξί Υποδέντρο (loan_int_rate >= 14):

  • Κόμβος 5: loan_intent = EDU, HOM, PER, VEN

Αν ανήκει σε αυτές τις κατηγορίες → Πάμε δεξιά.

Αν όχι → πρόβλεψη: yes

  • Κόμβος 6: person_income >= 43.000

Αν ναι → πρόβλεψη: yes

Αν όχι → πρόβλεψη: no

Οι σκοποί “education”, “home improvement”, “personal”, και “venture” φαίνεται να σχετίζονται με μεγαλύτερο ρίσκο. Αν το εισόδημα είναι αρκετά υψηλό, η πιθανότητα default μειώνεται λίγο.

Τελική Σύγκριση Μοντέλων

Έπειτα εφαρμόζουμε τις προβλέψεις ώστε να συγκρίνουμε τα 2 μας μοντέλα.

# Πρόβλεψη
cart_pred <- predict(cart_cv, newdata = Test)
confusionMatrix(cart_pred, Test$loan_status)
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction    no   yes
##        no  10812  1080
##        yes  1435  2420
##                                          
##                Accuracy : 0.8403         
##                  95% CI : (0.8345, 0.846)
##     No Information Rate : 0.7777         
##     P-Value [Acc > NIR] : < 2.2e-16      
##                                          
##                   Kappa : 0.5542         
##                                          
##  Mcnemar's Test P-Value : 1.679e-12      
##                                          
##             Sensitivity : 0.8828         
##             Specificity : 0.6914         
##          Pos Pred Value : 0.9092         
##          Neg Pred Value : 0.6278         
##              Prevalence : 0.7777         
##          Detection Rate : 0.6866         
##    Detection Prevalence : 0.7552         
##       Balanced Accuracy : 0.7871         
##                                          
##        'Positive' Class : no             
## 
# Πρόβλεψη με Model 3
logistic_pred <- predict(model3, newdata = Test, type = "response")
logistic_class <- ifelse(logistic_pred > 0.5, "yes", "no")
logistic_class <- factor(logistic_class, levels = c("no", "yes"))

confusionMatrix(logistic_class, Test$loan_status)
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction    no   yes
##        no  11586  1951
##        yes   661  1549
##                                           
##                Accuracy : 0.8341          
##                  95% CI : (0.8282, 0.8399)
##     No Information Rate : 0.7777          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.4475          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 0.9460          
##             Specificity : 0.4426          
##          Pos Pred Value : 0.8559          
##          Neg Pred Value : 0.7009          
##              Prevalence : 0.7777          
##          Detection Rate : 0.7358          
##    Detection Prevalence : 0.8597          
##       Balanced Accuracy : 0.6943          
##                                           
##        'Positive' Class : no              
## 
accuracy_cart <- mean(cart_pred == Test$loan_status)
accuracy_logit <- mean(logistic_class == Test$loan_status)

data.frame(
  Μοντέλο = c("CART", "Logistic Regression"),
  Ακρίβεια = c(round(accuracy_cart * 100, 2), round(accuracy_logit * 100, 2))
)
##               Μοντέλο Ακρίβεια
## 1                CART    84.03
## 2 Logistic Regression    83.41

Το CART μοντέλο πέτυχε ελαφρώς υψηλότερη ακρίβεια σε σχέση με τη λογιστική παλινδρόμηση, ενώ παρουσίασε και καλύτερη ισορροπία στην ταξινόμηση των δύο τάξεων.Αποδείχθηκε έτσι όχι μόνο ερμηνεύσιμο αλλά και αποτελεσματικότερο, ειδικά σε context όπου η απόφαση δανεισμού πρέπει να εξηγείται καθαρά σε όρους “κανόνων”. Η χρήση του SMOTE βελτίωσε ουσιαστικά την ταξινόμηση της μειοψηφικής κατηγορίας και ανέδειξε σημαντικά μοτίβα που ίσως να αγνοούνταν από πιο περιοριστικά γραμμικά μοντέλα.