Untitled
Αλέξανδρος Κοτταρίδης
2025-07-03
Δέντρα απόφασης
Περιγραφή του dataset
Αυτή η έρευνα στοχεύει στην περίπτωση των αθετήσεων πληρωμών πελατών στην Ταϊβάν και συγκρίνει την προγνωστική ακρίβεια της πιθανότητας αθέτησης μεταξύ έξι μεθόδων εξόρυξης δεδομένων. Από την άποψη της διαχείρισης κινδύνου, το αποτέλεσμα της προγνωστικής ακρίβειας της εκτιμώμενης πιθανότητας αθέτησης θα είναι πιο πολύτιμο από το δυαδικό αποτέλεσμα της ταξινόμησης - αξιόπιστοι ή μη αξιόπιστοι πελάτες. Με την πραγματική πιθανότητα αθέτησης ως μεταβλητή απόκρισης (Y) και την προγνωστική πιθανότητα αθέτησης ως ανεξάρτητη μεταβλητή (X).
Αυτή η έρευνα χρησιμοποίησε μια δυαδική μεταβλητή (Υ), την προεπιλεγμένη πληρωμή (Ναι = 1, Όχι = 0), ως μεταβλητή απόκρισης. Αυτή η μελέτη εξέτασε τη βιβλιογραφία και χρησιμοποίησε τις ακόλουθες 23 μεταβλητές ως επεξηγηματικές μεταβλητές:
X1: Ποσό της δεδομένης πίστωσης (δολάρια NT): περιλαμβάνει τόσο την ατομική καταναλωτική πίστωση όσο και την οικογενειακή (συμπληρωματική) πίστωση.
X2: Φύλο (1 = άνδρας· 2 = γυναίκα).
X3: Εκπαίδευση (1 = μεταπτυχιακή σχολή· 2 = πανεπιστήμιο· 3 = λύκειο· 4 = άλλα).
X4: Οικογενειακή κατάσταση (1 = έγγαμος· 2 = άγαμος· 3 = άλλα).
X5: Ηλικία (έτος).
X6 - X11: Ιστορικό προηγούμενων πληρωμών. Παρακολουθήσαμε τα προηγούμενα μηνιαία αρχεία πληρωμών (από Απρίλιο έως Σεπτέμβριο 2005) ως εξής: X6 = η κατάσταση αποπληρωμής τον Σεπτέμβριο 2005· X7 = η κατάσταση αποπληρωμής τον Αύγουστο 2005· . . .;X11 = η κατάσταση αποπληρωμής τον Απρίλιο του 2005. Η κλίμακα μέτρησης για την κατάσταση αποπληρωμής είναι: -1 = δέουσα πληρωμή· 1 = καθυστέρηση πληρωμής για ένα μήνα· 2 = καθυστέρηση πληρωμής για δύο μήνες· . . .; 8 = καθυστέρηση πληρωμής για οκτώ μήνες· 9 = καθυστέρηση πληρωμής για εννέα μήνες και άνω.
X12-X17: Ποσό λογαριασμού (δολάρια NT). X12 = ποσό λογαριασμού τον Σεπτέμβριο του 2005· X13 = ποσό λογαριασμού τον Αύγουστο του 2005· . . .; X17 = ποσό λογαριασμού τον Απρίλιο του 2005.
X18-X23: Ποσό προηγούμενης πληρωμής (δολάρια NT). X18 = ποσό που καταβλήθηκε τον Σεπτέμβριο του 2005· X19 = ποσό που καταβλήθηκε τον Αύγουστο του 2005· . . .;X23 = ποσό που καταβλήθηκε τον Απρίλιο του 2005.
Στο dataset δεν υπάρχουν κενές τιμές (Na) Υπάρχουν συνολικά 30.000 εγγραφές και 25 στήλες/μεταβλητές για κάθε εγγραφή.
Εμείς θέλουμε να προβλέψουμε ποιός πελάτης θα πραγματοποιήσει πληρωμή τον επόμενο μήνα (Υ=1)
Αυτό σημάινει πως το μοντέλο μας θα πρέπει να έχει ακρίβεια μεγαλύτερη από 77.9% διότι αν η πρόβλεψη μας ήταν συνέχεια πως ΟΧΙ(0), αυτό θα ήταν το ποσοστό επιτυχίας μας.
Περιγραφικά στατιστικά
Μέτρα κεντρικής τάσης
print(summary(credit_dataset))## ID X1 X2 X3
## Min. : 1 Min. : 10000 Min. :1.000 Min. :0.000
## 1st Qu.: 7501 1st Qu.: 50000 1st Qu.:1.000 1st Qu.:1.000
## Median :15000 Median : 140000 Median :2.000 Median :2.000
## Mean :15000 Mean : 167484 Mean :1.604 Mean :1.853
## 3rd Qu.:22500 3rd Qu.: 240000 3rd Qu.:2.000 3rd Qu.:2.000
## Max. :30000 Max. :1000000 Max. :2.000 Max. :6.000
## X4 X5 X6 X7
## Min. :0.000 Min. :21.00 Min. :-2.0000 Min. :-2.0000
## 1st Qu.:1.000 1st Qu.:28.00 1st Qu.:-1.0000 1st Qu.:-1.0000
## Median :2.000 Median :34.00 Median : 0.0000 Median : 0.0000
## Mean :1.552 Mean :35.49 Mean :-0.0167 Mean :-0.1338
## 3rd Qu.:2.000 3rd Qu.:41.00 3rd Qu.: 0.0000 3rd Qu.: 0.0000
## Max. :3.000 Max. :79.00 Max. : 8.0000 Max. : 8.0000
## X8 X9 X10 X11
## Min. :-2.0000 Min. :-2.0000 Min. :-2.0000 Min. :-2.0000
## 1st Qu.:-1.0000 1st Qu.:-1.0000 1st Qu.:-1.0000 1st Qu.:-1.0000
## Median : 0.0000 Median : 0.0000 Median : 0.0000 Median : 0.0000
## Mean :-0.1662 Mean :-0.2207 Mean :-0.2662 Mean :-0.2911
## 3rd Qu.: 0.0000 3rd Qu.: 0.0000 3rd Qu.: 0.0000 3rd Qu.: 0.0000
## Max. : 8.0000 Max. : 8.0000 Max. : 8.0000 Max. : 8.0000
## X12 X13 X14 X15
## Min. :-165580 Min. :-69777 Min. :-157264 Min. :-170000
## 1st Qu.: 3559 1st Qu.: 2985 1st Qu.: 2666 1st Qu.: 2327
## Median : 22382 Median : 21200 Median : 20089 Median : 19052
## Mean : 51223 Mean : 49179 Mean : 47013 Mean : 43263
## 3rd Qu.: 67091 3rd Qu.: 64006 3rd Qu.: 60165 3rd Qu.: 54506
## Max. : 964511 Max. :983931 Max. :1664089 Max. : 891586
## X16 X17 X18 X19
## Min. :-81334 Min. :-339603 Min. : 0 Min. : 0
## 1st Qu.: 1763 1st Qu.: 1256 1st Qu.: 1000 1st Qu.: 833
## Median : 18105 Median : 17071 Median : 2100 Median : 2009
## Mean : 40311 Mean : 38872 Mean : 5664 Mean : 5921
## 3rd Qu.: 50191 3rd Qu.: 49198 3rd Qu.: 5006 3rd Qu.: 5000
## Max. :927171 Max. : 961664 Max. :873552 Max. :1684259
## X20 X21 X22 X23
## Min. : 0 Min. : 0 Min. : 0.0 Min. : 0.0
## 1st Qu.: 390 1st Qu.: 296 1st Qu.: 252.5 1st Qu.: 117.8
## Median : 1800 Median : 1500 Median : 1500.0 Median : 1500.0
## Mean : 5226 Mean : 4826 Mean : 4799.4 Mean : 5215.5
## 3rd Qu.: 4505 3rd Qu.: 4013 3rd Qu.: 4031.5 3rd Qu.: 4000.0
## Max. :896040 Max. :621000 Max. :426529.0 Max. :528666.0
## Y
## Min. :0.0000
## 1st Qu.:0.0000
## Median :0.0000
## Mean :0.2212
## 3rd Qu.:0.0000
## Max. :1.0000Μέτρα διασποράς
# Rename the vars of the dataset :)
colnames(credit_dataset) <- c(
"ID",
"LimitBalance", # X1: Amount of given credit (NT dollars)
"Sex", # X2: Gender (1 = male, 2 = female)
"Education", # X3: Education (1 = graduate school, 2 = university, etc.)
"Marriage", # X4: Marital status
"Age", # X5: Age (years)
"PaySep", # X6: Repayment status in September 2005
"PayAug", # X7: Repayment status in August 2005
"PayJul", # X8: Repayment status in July 2005
"PayJun", # X9: Repayment status in June 2005
"PayMay", # X10: Repayment status in May 2005
"PayApr", # X11: Repayment status in April 2005
"BillSep", # X12: Bill amount in September 2005
"BillAug", # X13: Bill amount in August 2005
"BillJul", # X14: Bill amount in July 2005
"BillJun", # X15: Bill amount in June 2005
"BillMay", # X16: Bill amount in May 2005
"BillApr", # X17: Bill amount in April 2005
"PayAmtSep", # X18: Payment amount in September 2005
"PayAmtAug", # X19: Payment amount in August 2005
"PayAmtJul", # X20: Payment amount in July 2005
"PayAmtJun", # X21: Payment amount in June 2005
"PayAmtMay", # X22: Payment amount in May 2005
"PayAmtApr", # X23: Payment amount in April 2005
"Y" # Target variable: 1 = default, 0 = not
)
#par(mfrow = c(4, 4))
summary_stats <- data.frame(
Variance = sapply(credit_dataset, var, na.rm = TRUE),
SD = sapply(credit_dataset, sd, na.rm = TRUE),
Range = I(sapply(credit_dataset, function(x) range(x, na.rm = TRUE), simplify = FALSE))
)
print(summary_stats)## Variance SD Range
## ID 7.500250e+07 8.660398e+03 1, 30000
## LimitBalance 1.683446e+10 1.297477e+05 10000, 1e+06
## Sex 2.392474e-01 4.891292e-01 1, 2
## Education 6.246510e-01 7.903487e-01 0, 6
## Marriage 2.724523e-01 5.219696e-01 0, 3
## Age 8.496976e+01 9.217904e+00 21, 79
## PaySep 1.262930e+00 1.123802e+00 -2, 8
## PayAug 1.433254e+00 1.197186e+00 -2, 8
## PayJul 1.432492e+00 1.196868e+00 -2, 8
## PayJun 1.366885e+00 1.169139e+00 -2, 8
## PayMay 1.284114e+00 1.133187e+00 -2, 8
## PayApr 1.322472e+00 1.149988e+00 -2, 8
## BillSep 5.422240e+09 7.363586e+04 -165580,....
## BillAug 5.065705e+09 7.117377e+04 -69777, ....
## BillJul 4.809338e+09 6.934939e+04 -157264,....
## BillJun 4.138716e+09 6.433286e+04 -170000,....
## BillMay 3.696294e+09 6.079716e+04 -81334, ....
## BillApr 3.546692e+09 5.955411e+04 -339603,....
## PayAmtSep 2.743423e+08 1.656328e+04 0, 873552
## PayAmtAug 5.308817e+08 2.304087e+04 0, 1684259
## PayAmtJul 3.100051e+08 1.760696e+04 0, 896040
## PayAmtJun 2.454286e+08 1.566616e+04 0, 621000
## PayAmtMay 2.334266e+08 1.527831e+04 0, 426529
## PayAmtApr 3.160383e+08 1.777747e+04 0, 528666
## Y 1.722763e-01 4.150618e-01 0, 1Οπτικοποίηση Δεδομένων
Boxplot
par(mfrow = c(2, 2))
# Plot boxplot for each numeric variable
for (colname in names(credit_dataset)) {
boxplot(credit_dataset[[colname]], main = colname, horizontal = TRUE)
}
Από τα παραπάνω λαμβάνουμε σημαντικές πληροφορίες για τις μεταβλητές μας όπως, την κατανομή τους, πως είναι δομημένα τα τεταρτημόρια τους, αλλά πιο σημαντικά λαμβάνουμε χρήσιμε πληροφορίες για τις outlier τιμές τους.
Για παράδειγμα, βλέπουμε πως οι περισσότεροι πελάτες είναι γυναίκες.
Γενικά όλες οι μεταβλητές φαίνεται να έχουν outliers.
Histogram
par(mfrow = c(2, 2))
# Plot boxplot for each numeric variable
for (colname in names(credit_dataset)) {
hist(credit_dataset[[colname]],
xlab = colname,
main = colname,
sub = paste("Skewness:", round(e1071::skewness(credit_dataset[[colname]]), 2)))
}
Εδώ φαίνονται λίγο πιο ξεκάθαρα οι κατανομές των μεταβλητών μας.
Για παράδειγμα μπορούμε να δούμε πως η κατανομή της μεταβλητής LimitBalance είναι γεωμετρική
Επίσης εμφανές είναι πως οι μεταβλητές Pay{Month} έχουν εξαιρετικά όμοιες κατανομές μεταξύ τους οπότε είναι πολύ πιθανό στο μοντέλο μας οι μήνες να μην επηρεάζουν τόσο πολύ το αποτέλεσμα των προβλέψεων μας
Το ίδιο ισχύει και για τις Bill{Month}, PayAmt{Month}
Distplot
credit_dataset_long <- melt(credit_dataset[sapply(credit_dataset, is.numeric)])## No id variables; using all as measure variablesplots_per_page <- 8
total_vars <- length(unique(credit_dataset_long$variable))
pages <- 2
for (i in 1:pages) {
print(
ggplot(credit_dataset_long, aes(x = value)) +
geom_histogram(aes(y = ..density..), bins = 30, fill = "skyblue", alpha = 0.5) +
geom_density(color = "darkblue", size = 1) +
ggforce::facet_wrap_paginate(~ variable, scales = "free", ncol = 3, nrow = 3, page = i) +
theme_minimal() +
labs(title = paste("Histogram + Density (Page", i, ")"), x = "", y = "Density")
)
}
Scatter plot
## [1] -0.03996058
## [1] 0.01388983To φύλο και η ηλικία αρχικά φαίνεται να έχουν μικρή συσχέτιση με το Υ και μπορεί ατομικά να μην το επηρεάζουν όσο θα περιμέναμε.
Heatmap
# compute corel matrix
cor_matrix <- cor(credit_dataset, use = "complete.obs")
# Transform the correlation matrix into a long format suitable for ggplot2
melted_cor_matrix <- melt(cor_matrix)
#print(melted_cor_matrix)
ggplot(data = melted_cor_matrix, aes(x = Var1, y = Var2, fill = value)) +
geom_tile(color = "white") +
# print corel coefs
geom_text(aes(label = round(value, 2)), color = "black", size = 2) +
labs(
title = "Correlation Heat Map",
x = "",
y = "",
) +
scale_fill_gradient2(low = "blue", high = "red", mid = "white",
midpoint = 0, limit = c(-1, 1), space = "Lab",
name = "Correlation") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, vjust = 1, size = 12, hjust = 1)) +
coord_fixed()
Mπορούμε να δούμε κάποιες σχέσεις με το TenYearCHD, όπως η ηλικία(0.23), αν είναι υπερτασικοί(0.18), συστολική(0.22), διαστολική(0.15), γλικόζη(0.12). Χρησιμοποιείται η complete.obs