Bank Marketing - UCI Machine Learning Repository
Χαμαλίδης Βασίλειος Σωτήριος iis22183
2025-07-03
Εισαγωγή
Η ανάλυσή μας ξεκινά με διερεύνηση και έλεγχο των δεδομένων, ακολουθεί η οπτικοποίησή τους για καλύτερη κατανόηση των σχέσεων μεταξύ των μεταβλητών, και τελικά τα δεδομένα διαχωρίζονται σε σύνολα εκπαίδευσης (train) και αξιολόγησης (test). Στη συνέχεια, εκπαιδεύουμε ένα μοντέλο Λογιστικής Παλινδρόμησης (Logistic Regression) για την πρόβλεψη της συμφωνίας κατάθεσης.
Εισαγωγή Δεδομένων
library(readr)
df <- read_delim("~/R_Studio/EXAMS/bank.csv",
delim = ";", escape_double = FALSE, trim_ws = TRUE)library(knitr)
kable(df[1:10, ], caption = "Οπτικοποίηση Δεδομένων Τράπεζας")| age | job | marital | education | default | balance | housing | loan | contact | day | month | duration | campaign | pdays | previous | poutcome | y |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 30 | unemployed | married | primary | no | 1787 | no | no | cellular | 19 | oct | 79 | 1 | -1 | 0 | unknown | no |
| 33 | services | married | secondary | no | 4789 | yes | yes | cellular | 11 | may | 220 | 1 | 339 | 4 | failure | no |
| 35 | management | single | tertiary | no | 1350 | yes | no | cellular | 16 | apr | 185 | 1 | 330 | 1 | failure | no |
| 30 | management | married | tertiary | no | 1476 | yes | yes | unknown | 3 | jun | 199 | 4 | -1 | 0 | unknown | no |
| 59 | blue-collar | married | secondary | no | 0 | yes | no | unknown | 5 | may | 226 | 1 | -1 | 0 | unknown | no |
| 35 | management | single | tertiary | no | 747 | no | no | cellular | 23 | feb | 141 | 2 | 176 | 3 | failure | no |
| 36 | self-employed | married | tertiary | no | 307 | yes | no | cellular | 14 | may | 341 | 1 | 330 | 2 | other | no |
| 39 | technician | married | secondary | no | 147 | yes | no | cellular | 6 | may | 151 | 2 | -1 | 0 | unknown | no |
| 41 | entrepreneur | married | tertiary | no | 221 | yes | no | unknown | 14 | may | 57 | 2 | -1 | 0 | unknown | no |
| 43 | services | married | primary | no | -88 | yes | yes | cellular | 17 | apr | 313 | 1 | 147 | 2 | failure | no |
Προετοιμασία Δεδομένων
Πριν από τη χρήση των δεδομένων, είναι απαραίτητο να προηγηθεί μια διαδικασία προεπεξεργασίας, με στόχο τον εντοπισμό και την αντιμετώπιση πιθανών ατελειών. Η ποιότητα των δεδομένων αποτελεί καθοριστικό παράγοντα τόσο για την ακρίβεια της στατιστικής ανάλυσης όσο και για την αποτελεσματικότητα των προβλεπτικών μοντέλων. Στο πλαίσιο αυτό, εφαρμόστηκε μια σειρά διαδικασιών καθαρισμού και ελέγχου, οι οποίες περιγράφονται αναλυτικά στην παρούσα ενότητα.
Ελεγχος τύπου δεδομένων
summary(df)## age job marital education
## Min. :19.00 Length:4521 Length:4521 Length:4521
## 1st Qu.:33.00 Class :character Class :character Class :character
## Median :39.00 Mode :character Mode :character Mode :character
## Mean :41.17
## 3rd Qu.:49.00
## Max. :87.00
## default balance housing loan
## Length:4521 Min. :-3313 Length:4521 Length:4521
## Class :character 1st Qu.: 69 Class :character Class :character
## Mode :character Median : 444 Mode :character Mode :character
## Mean : 1423
## 3rd Qu.: 1480
## Max. :71188
## contact day month duration
## Length:4521 Min. : 1.00 Length:4521 Min. : 4
## Class :character 1st Qu.: 9.00 Class :character 1st Qu.: 104
## Mode :character Median :16.00 Mode :character Median : 185
## Mean :15.92 Mean : 264
## 3rd Qu.:21.00 3rd Qu.: 329
## Max. :31.00 Max. :3025
## campaign pdays previous poutcome
## Min. : 1.000 Min. : -1.00 Min. : 0.0000 Length:4521
## 1st Qu.: 1.000 1st Qu.: -1.00 1st Qu.: 0.0000 Class :character
## Median : 2.000 Median : -1.00 Median : 0.0000 Mode :character
## Mean : 2.794 Mean : 39.77 Mean : 0.5426
## 3rd Qu.: 3.000 3rd Qu.: -1.00 3rd Qu.: 0.0000
## Max. :50.000 Max. :871.00 Max. :25.0000
## y
## Length:4521
## Class :character
## Mode :character
##
##
## Παρατηρούμε ότι,
| Μεταβλητή | Περιγραφή |
|---|---|
age |
Ηλικία πελάτη (numeric) |
job |
Επάγγελμα πελάτη (categorical: “admin.”, “unknown”, “unemployed”, “management”, “housemaid”, “entrepreneur”, “student”, “blue-collar”, “self-employed”, “retired”, “technician”, “services”) |
marital |
Οικογενειακή κατάσταση (categorical: “married”, “divorced”,
“single”) Σημείωση: Το “divorced” περιλαμβάνει και “χήροι” |
education |
Επίπεδο εκπαίδευσης (categorical: “unknown”, “secondary”, “primary”, “tertiary”) |
default |
Υπάρχει χρεωστικό υπόλοιπο; (binary: “yes”, “no”) |
balance |
Μέσο ετήσιο υπόλοιπο σε ευρώ (numeric) |
housing |
Στεγαστικό δάνειο; (binary: “yes”, “no”) |
loan |
Προσωπικό δάνειο; (binary: “yes”, “no”) |
contact |
Τύπος επικοινωνίας (categorical: “unknown”, “telephone”, “cellular”) |
day |
Ημέρα του μήνα επικοινωνίας (numeric) |
month |
Μήνας επικοινωνίας (categorical: “jan”, “feb”, …, “dec”) |
duration |
Διάρκεια τελευταίας επικοινωνίας σε δευτερόλεπτα (numeric) |
campaign |
Αριθμός επαφών κατά την τρέχουσα καμπάνια (numeric) |
pdays |
Ημέρες από την τελευταία επαφή (ή -1 αν δεν υπήρξε) (numeric) |
previous |
Πλήθος προηγούμενων επαφών (numeric) |
poutcome |
Αποτέλεσμα προηγούμενης καμπάνιας (categorical: “unknown”, “other”, “failure”, “success”) |
y |
Έγινε κατάθεση; (binary: “yes”, “no”) |
Μοναδικές Τιμές
Βλέπουμε πως, δεν υπάρχουν χαρακτήρες σε αριθμητικά χαρακτηριστικά με βάση το summary.
kable(unique(df[, 2]))| job |
|---|
| unemployed |
| services |
| management |
| blue-collar |
| self-employed |
| technician |
| entrepreneur |
| admin. |
| student |
| housemaid |
| retired |
| unknown |
kable(unique(df[, 3]))| marital |
|---|
| married |
| single |
| divorced |
kable(unique(df[, 4]))| education |
|---|
| primary |
| secondary |
| tertiary |
| unknown |
kable(unique(df[, 5]))| default |
|---|
| no |
| yes |
kable(unique(df[, 7]))| housing |
|---|
| no |
| yes |
kable(unique(df[, 8]))| loan |
|---|
| no |
| yes |
kable(unique(df[, 9]))| contact |
|---|
| cellular |
| unknown |
| telephone |
kable(unique(df[, 11]))| month |
|---|
| oct |
| may |
| apr |
| jun |
| feb |
| aug |
| jan |
| jul |
| nov |
| sep |
| mar |
| dec |
kable(unique(df[, 16]))| poutcome |
|---|
| unknown |
| failure |
| other |
| success |
kable(unique(df[, 17]))| y |
|---|
| no |
| yes |
Με τη χρήση της συνάρτησης unique μπορούμε να ελέγξουμε ότι δεν υπάρχουν ορθογραφικά λάθη ή ασυνέπειες στον αριθμό χαρακτήρων των κατηγοριών. Επιπλέον, δεν χρειάζεται να μετατρέψουμε τις κατηγορικές μεταβλητές σε αριθμητικές, καθώς η συνάρτηση glm αναλαμβάνει αυτόματα τη μετατροπή τους σε κατάλληλες dummy μεταβλητές.
Έλεγχος Κενών Τιμών
| Missing_Values | Absolute | |
|---|---|---|
| age | 0 % | 0 |
| job | 0 % | 0 |
| marital | 0 % | 0 |
| education | 0 % | 0 |
| default | 0 % | 0 |
| balance | 0 % | 0 |
| housing | 0 % | 0 |
| loan | 0 % | 0 |
| contact | 0 % | 0 |
| day | 0 % | 0 |
| month | 0 % | 0 |
| duration | 0 % | 0 |
| campaign | 0 % | 0 |
| pdays | 0 % | 0 |
| previous | 0 % | 0 |
| poutcome | 0 % | 0 |
| y | 0 % | 0 |
## [1] "0 total empty values"Παρατηρούμε οτι δεν υπάρχουν κενές τιμές στο σύνολο δεδομένων μας.
Στατιστική Οπτικοποίηση Δεδομένων
Correlations
library("corrplot")
# Calculate correlation matrix
cor_matrix <- cor(
df[, sapply(df, is.numeric)],
method = "pearson"
)
# Visualize
corrplot(cor_matrix,
method = "color",
type = "upper",
tl.col = "black", # text label color
tl.srt = 45, # text label rotation
tl.cex = 0.8, # text label size (default is 1)
addCoef.col = "black", # show correlation coefficients
number.cex = 0.7 # coefficient number size
)
Χρησιμοποιόντας τα αριθμητικά χαρακτηριστικά, βλέπουμε οτι υπάρχει μηδενική συσχέτιση μεταξύ των μεταβλητών με την μέθοδο pearson. Εξαίρεση θα μπορούσε να θεωρηθεί το χαρακτηριστικό pdays με το previous που σχετίζονται κατα 58%.
Μέτρα Κεντρικής Τάσης
central_tendency_data <- data.frame(
Mean = round(sapply(df[, sapply(df, is.numeric)], mean, na.rm = TRUE), digits = 2),
Median = round(sapply(df[, sapply(df, is.numeric)], median, na.rm = TRUE), digits = 2),
Most_Frequent = sapply(round(df[, sapply(df, is.numeric)], digits = 2), function(x) {
as.numeric(names(sort(table(x), decreasing = TRUE)[1]))
})
)
kable(central_tendency_data, caption = "Μέτρα Κεντρικής Τάσης")| Mean | Median | Most_Frequent | |
|---|---|---|---|
| age | 41.17 | 39 | 34 |
| balance | 1422.66 | 444 | 0 |
| day | 15.92 | 16 | 20 |
| duration | 263.96 | 185 | 123 |
| campaign | 2.79 | 2 | 1 |
| pdays | 39.77 | -1 | -1 |
| previous | 0.54 | 0 | 0 |
Μέτρα Διασποράς
dispersion_data <- data.frame(
Standard_Deviation = round(sapply(df[, sapply(df, is.numeric)], sd, na.rm = TRUE), digits= 2),
Variance = round(sapply(df[, sapply(df, is.numeric)], var, na.rm = TRUE), digits= 2),
Range_Min = round(sapply(df[, sapply(df, is.numeric)], function(x) min(x, na.rm = TRUE)), digits=2),
Range_Max = round(sapply(df[, sapply(df, is.numeric)], function(x) max(x, na.rm = TRUE)), digits= 2)
)
kable(dispersion_data, caption = "Μέτρα Διασποράς")| Standard_Deviation | Variance | Range_Min | Range_Max | |
|---|---|---|---|---|
| age | 10.58 | 111.86 | 19 | 87 |
| balance | 3009.64 | 9057921.75 | -3313 | 71188 |
| day | 8.25 | 68.02 | 1 | 31 |
| duration | 259.86 | 67525.47 | 4 | 3025 |
| campaign | 3.11 | 9.67 | 1 | 50 |
| pdays | 100.12 | 10024.24 | -1 | 871 |
| previous | 1.69 | 2.87 | 0 | 25 |
library(ggplot2)
ggplot(df, aes(x = job, y = balance)) +
geom_boxplot() +
labs(x = "Jobs", y = "Balance in Dollar", title = "Jobs and balance - boxplot") +
coord_cartesian(ylim = c(0, 15000))
Στο διάγραμμα παρατηρούμε ότι υπάρχουν αρκετές παρατηρήσεις που ξεχωρίζουν ως outliers σε κάθε κατηγορία επαγγέλματος, γεγονός που δείχνει μεγάλες διακυμάνσεις στο υπόλοιπο λογαριασμού (balance) ανάμεσα στα άτομα. Μία σημαντική παρατήρηση είναι ότι τα άτομα που είναι σε σύνταξη (retired) έχουν, κατά μέσο όρο, υψηλότερο υπόλοιπο στον λογαριασμό τους σε σχέση με τις άλλες κατηγορίες επαγγελμάτων. Αυτό μπορεί να υποδηλώνει μεγαλύτερη οικονομική σταθερότητα ή αποταμίευση στη συγκεκριμένη ομάδα.
library(ggExtra)
library(dplyr)
p <- ggplot(df, aes(x = age, y = balance, color = y)) +
geom_point(alpha = 0.6) +
labs(x = "Age", y = "Balance", color = "y (Yes/No)") +
theme_minimal()
# Add marginal density plots
ggMarginal(p, type = "density", groupColour = TRUE, groupFill = TRUE)
Από το διάγραμμα παρατηρούμε ότι οι πελάτες με θετική απόκριση (yes) και αυτοί με αρνητική απόκριση (no) έχουν παρόμοιες κατανομές όσον αφορά την ηλικία (Age) και το υπόλοιπο λογαριασμού (Balance). Η πλειονότητα των πελατών βρίσκεται σε ηλικίες μεταξύ 25 και 60 ετών, με το υπόλοιπο να συγκεντρώνεται κυρίως κοντά στο μηδέν, ενώ υπάρχουν και λίγες ακραίες τιμές με πολύ υψηλά υπόλοιπα.
Παράλληλα, οι πελάτες που απάντησαν “yes” φαίνεται να είναι ελαφρώς πιο πυκνοί σε κάποιες περιοχές ηλικίας και υπολοίπου, αλλά η διαφορά δεν είναι έντονη. Οι κατανομές στα περιθώρια (marginal distributions) δείχνουν ότι δεν υπάρχει σημαντική διαφορά στη μέση ηλικία ή στο μέσο υπόλοιπο μεταξύ των δύο ομάδων, κάτι που υποδηλώνει πως αυτά τα χαρακτηριστικά ίσως να μην είναι ισχυροί διαχωριστικοί παράγοντες για το αποτέλεσμα της καμπάνιας.
ggplot(df, aes(x = education, fill = default)) +
geom_bar(position = "fill") +
labs(title = "Χρεωστικό Υπόλοιπο ανά Επίπεδο Εκπαίδευσης", x = "Επίπεδο Εκπαίδευσης", y = "Ποσοστό") +
scale_y_continuous(labels = scales::percent)
Απο το διάγραμμα δεν παρουσιάζεται κάποια σημαντική προτίμηση για το επίπεδο εκπαίδευσης.
ggplot(df, aes(x = duration, fill = y)) +
geom_histogram(position = "identity", alpha = 0.6, bins = 50) +
labs(
title = "Συσχέτιση Διάρκειας Τηλεφωνίας με Συμφωνία Κατάθεσης",
x = "Διάρκεια Τηλεφωνίας (δευτερόλεπτα)",
y = "Αριθμός Πελατών",
fill = "Αποτέλεσμα (y)"
) +
theme_minimal()
ggplot(df, aes(x = duration, y = as.numeric(y == "yes"))) +
geom_smooth(method = "glm", method.args = list(family = "binomial"), se = TRUE) +
labs(x = "Διάρκεια Τηλεφωνικής Κλήσης (sec)", y = "Πιθανότητα Κατάθεσης")
Υπάρχει θετική συσχέτιση μεταξύ της διάρκειας τηλεφωνικής επικοινωνίας και της πιθανότητας επιτυχούς κατάθεσης. Δηλαδή, οι πελάτες που αφιέρωσαν περισσότερο χρόνο στο τηλέφωνο, τείνουν να συμφωνούν πιο συχνά σε κατάθεση. Η διάρκεια της κλήσης φαίνεται να λειτουργεί ως ισχυρός προβλεπτικός δείκτης για το αποτέλεσμα της καμπάνιας.
Logistic Regression
Score Function
show_scores <- function(preds, df){
# ROC AUC function
rocr_preds <- prediction(preds, df$yn)
print("Test Results:")
table(df$yn, preds > 0.5)
predicted_binary <- preds > 0.5
TP <- sum(df$yn == 1 & predicted_binary)
TN <- sum(df$yn == 0 & !predicted_binary)
FP <- sum(df$yn == 0 & predicted_binary)
FN <- sum(df$yn == 1 & !predicted_binary)
rocr_perd <- performance(rocr_preds, "tpr", "fpr")
plot(rocr_perd,
colorize = TRUE,
print.cutoffs.at = seq(0, 1, 0.1),
text.adj = c(-0.2, 1.7),
main = "ROC curve"
)
score <- data.frame(
AUC = as.numeric(performance(rocr_preds, "auc")@y.values),
Accuracy = (TP + TN) / (TP + TN + FP + FN),
Precision = TP / (TP + FP),
Recall = TP / (TP + FN),
F1 = (2 * TP) / (2 * TP + FP + FN)
)
kable(score)
}
library(ROCR)
fit_and_predict <- function(cols, train, test) {
print("Training model...")
model <- glm(as.formula(colnames), data = train, family = "binomial")
print(summary(model))
print("Predicting Test set...")
preds <- predict(model, type = "response", newdata = test)
rocr_preds <- prediction(preds, test$yn)
show_scores(preds, test)
}Characteristics
## [1] "age + job + marital + education + default + balance + housing + loan + contact + day + month + duration + campaign + pdays + previous + poutcome + y"Η μέθοδος που θα χρησιμοποιηθεί για τα χαρακτηριστικά είναι η σταδιακή αφαίρεσή των πιο μη σημαντικών χαρακτηριστικών με βάση το Pr(>|z|).
df$yn <- ifelse(df$y == "yes", 1, 0)Μετατροπή του y σε αριθμητικό 0 κ 1.
Data Split
Το σύνολο δεδομένων διαχωρίζεται σε δύο υποσύνολα: το σύνολο εκπαίδευσης και το σύνολο ελέγχου. Στη συνέχεια, εκπαιδεύεται το μοντέλο λογιστικής παλινδρόμησης χρησιμοποιώντας το σύνολο εκπαίδευσης. Ο στόχος είναι να εξετάσουμε την απόδοση του μοντέλου και την ικανότητά του να προσεγγίζει τη σχέση μεταξύ των ανεξαρτήτων και εξαρτημένων μεταβλητών.
library(caTools)
set.seed(183)
split <- sample.split(df$y, SplitRatio = 0.65)
train <- subset(df, split == TRUE)
test <- subset(df, split == FALSE)
print(paste(
"Αναλογία Train / Test=", nrow(train), "/", nrow(test), "=",
round(nrow(train) / nrow(test), 3)
))## [1] "Αναλογία Train / Test= 2939 / 1582 = 1.858"Πριν από κάθε εκπαίδευση και αξιολόγηση του μοντέλου, το σύνολο δεδομένων διαχωρίζεται σε δύο κατηγορίες. Η πρώτη κατηγορία ονομάζεται Train set και χρησιμοποιείται για την εκπαίδευση του μοντέλου. Επιπλέον, σε ορισμένες περιπτώσεις, το Train set μπορεί να χρησιμοποιηθεί και ως validation set όταν δουλεύουμε με πιο σύνθετα μοντέλα, όπως τα νευρωνικά δίκτυα, για να αξιολογήσουμε την απόδοση του μοντέλου κατά τη διάρκεια της εκπαίδευσης.
Test 1
colnames <- "yn ~ age + job + marital + education + default + balance + housing + loan + contact + day + month + duration + campaign + pdays + previous + poutcome"
fit_and_predict(colnames, train, test)## [1] "Training model..."
##
## Call:
## glm(formula = as.formula(colnames), family = "binomial", data = train)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.471e+00 7.754e-01 -3.187 0.001437 **
## age -6.969e-03 8.839e-03 -0.788 0.430428
## jobblue-collar -4.477e-01 3.015e-01 -1.485 0.137584
## jobentrepreneur 3.364e-02 4.702e-01 0.072 0.942966
## jobhousemaid -1.101e-01 5.126e-01 -0.215 0.829880
## jobmanagement -1.310e-01 2.939e-01 -0.446 0.655712
## jobretired 7.497e-01 3.892e-01 1.926 0.054088 .
## jobself-employed -1.668e-01 4.130e-01 -0.404 0.686237
## jobservices -3.095e-02 3.241e-01 -0.095 0.923932
## jobstudent 4.921e-01 4.640e-01 1.061 0.288839
## jobtechnician -1.133e-01 2.785e-01 -0.407 0.684120
## jobunemployed -5.323e-01 5.267e-01 -1.011 0.312233
## jobunknown -1.932e-01 8.485e-01 -0.228 0.819908
## maritalmarried -5.014e-01 2.176e-01 -2.304 0.021204 *
## maritalsingle -3.248e-01 2.541e-01 -1.278 0.201227
## educationsecondary 1.244e-01 2.554e-01 0.487 0.626126
## educationtertiary 4.024e-01 2.909e-01 1.383 0.166616
## educationunknown -6.882e-01 4.687e-01 -1.468 0.142033
## defaultyes 1.238e-01 6.391e-01 0.194 0.846404
## balance -1.419e-05 2.154e-05 -0.659 0.509931
## housingyes -3.441e-01 1.723e-01 -1.998 0.045769 *
## loanyes -5.172e-01 2.435e-01 -2.124 0.033642 *
## contacttelephone -2.426e-01 3.059e-01 -0.793 0.427845
## contactunknown -1.570e+00 2.746e-01 -5.718 1.08e-08 ***
## day 1.559e-02 9.983e-03 1.561 0.118426
## monthaug -1.958e-01 3.114e-01 -0.629 0.529530
## monthdec 3.377e-01 8.991e-01 0.376 0.707235
## monthfeb 6.426e-02 3.924e-01 0.164 0.869931
## monthjan -1.151e+00 5.272e-01 -2.184 0.028960 *
## monthjul -8.468e-01 3.198e-01 -2.648 0.008103 **
## monthjun 7.565e-01 3.734e-01 2.026 0.042798 *
## monthmar 1.561e+00 4.655e-01 3.355 0.000795 ***
## monthmay -1.196e-01 2.926e-01 -0.409 0.682581
## monthnov -5.288e-01 3.368e-01 -1.570 0.116435
## monthoct 1.619e+00 4.052e-01 3.995 6.48e-05 ***
## monthsep 3.998e-01 5.380e-01 0.743 0.457427
## duration 4.233e-03 2.519e-04 16.805 < 2e-16 ***
## campaign -7.909e-02 3.625e-02 -2.182 0.029132 *
## pdays -6.051e-04 1.325e-03 -0.457 0.647883
## previous -2.745e-02 4.823e-02 -0.569 0.569309
## poutcomeother 7.142e-01 3.404e-01 2.098 0.035920 *
## poutcomesuccess 2.538e+00 3.684e-01 6.890 5.60e-12 ***
## poutcomeunknown 4.910e-03 4.113e-01 0.012 0.990475
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 2101.7 on 2938 degrees of freedom
## Residual deviance: 1428.9 on 2896 degrees of freedom
## AIC: 1514.9
##
## Number of Fisher Scoring iterations: 6
##
## [1] "Predicting Test set..."
## [1] "Test Results:"
| AUC | Accuracy | Precision | Recall | F1 |
|---|---|---|---|---|
| 0.8908242 | 0.903287 | 0.6494845 | 0.3461538 | 0.4516129 |
Πρώτα απόλλα βάσει του υψηλού Pr(>|z|) αφαιρούμε τα age, education, default, balance και previous χαρακτηριστικά.
Test 2
colnames <- "yn ~ housing + marital + loan + contact + day + month + duration + campaign + pdays + previous + poutcome"
fit_and_predict(colnames, train, test)## [1] "Training model..."
##
## Call:
## glm(formula = as.formula(colnames), family = "binomial", data = train)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.5593585 0.5467405 -4.681 2.85e-06 ***
## housingyes -0.3914196 0.1668566 -2.346 0.018984 *
## maritalmarried -0.5640987 0.2130641 -2.648 0.008108 **
## maritalsingle -0.2565484 0.2319695 -1.106 0.268745
## loanyes -0.5080175 0.2391412 -2.124 0.033642 *
## contacttelephone -0.1834162 0.2918864 -0.628 0.529754
## contactunknown -1.7019421 0.2709889 -6.280 3.38e-10 ***
## day 0.0173767 0.0098809 1.759 0.078641 .
## monthaug -0.1620174 0.3073443 -0.527 0.598087
## monthdec 0.3097249 0.8697515 0.356 0.721760
## monthfeb -0.0083921 0.3933931 -0.021 0.982980
## monthjan -1.1871331 0.5210682 -2.278 0.022711 *
## monthjul -0.8251086 0.3168208 -2.604 0.009205 **
## monthjun 0.8149017 0.3700319 2.202 0.027648 *
## monthmar 1.6640250 0.4577051 3.636 0.000277 ***
## monthmay -0.0855344 0.2888582 -0.296 0.767144
## monthnov -0.5820560 0.3333600 -1.746 0.080806 .
## monthoct 1.6353447 0.4024691 4.063 4.84e-05 ***
## monthsep 0.5971864 0.5243566 1.139 0.254747
## duration 0.0041426 0.0002440 16.976 < 2e-16 ***
## campaign -0.0779074 0.0356279 -2.187 0.028765 *
## pdays -0.0009464 0.0012978 -0.729 0.465854
## previous -0.0251855 0.0466100 -0.540 0.588959
## poutcomeother 0.6968872 0.3378308 2.063 0.039129 *
## poutcomesuccess 2.4295113 0.3619325 6.713 1.91e-11 ***
## poutcomeunknown -0.0708712 0.4037011 -0.176 0.860645
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 2101.7 on 2938 degrees of freedom
## Residual deviance: 1453.1 on 2913 degrees of freedom
## AIC: 1505.1
##
## Number of Fisher Scoring iterations: 6
##
## [1] "Predicting Test set..."
## [1] "Test Results:"
| AUC | Accuracy | Precision | Recall | F1 |
|---|---|---|---|---|
| 0.893489 | 0.9001264 | 0.6304348 | 0.3186813 | 0.4233577 |
Το 2o μοντέλο έχει ελαφρώς καλύτερο AUC (καλύτερη ικανότητα διάκρισης μεταξύ θετικών και αρνητικών), που είναι σημαντικός δείκτης για ταξινομητές.
Ωστόσο, σε όλες τις υπόλοιπες μετρικές (Accuracy, Precision, Recall, F1) έχει ελαφρώς χειρότερες επιδόσεις.
Test 3
Συνεχίζουμε σε 3ο τεστ
Αφαιρούμε pdays και το previous γιατι >0.52 Pr(>|z|)
colnames <- "yn ~ housing + marital + loan + contact + day + month + duration + campaign + poutcome"
fit_and_predict(colnames, train, test)## [1] "Training model..."
##
## Call:
## glm(formula = as.formula(colnames), family = "binomial", data = train)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.8520443 0.4329714 -6.587 4.48e-11 ***
## housingyes -0.4000122 0.1664389 -2.403 0.016245 *
## maritalmarried -0.5609770 0.2125706 -2.639 0.008315 **
## maritalsingle -0.2538446 0.2313586 -1.097 0.272558
## loanyes -0.5167462 0.2389976 -2.162 0.030607 *
## contacttelephone -0.1641772 0.2892564 -0.568 0.570318
## contactunknown -1.6886525 0.2708293 -6.235 4.51e-10 ***
## day 0.0178431 0.0098680 1.808 0.070579 .
## monthaug -0.1567387 0.3066645 -0.511 0.609275
## monthdec 0.3103011 0.8742638 0.355 0.722643
## monthfeb 0.0123411 0.3924444 0.031 0.974913
## monthjan -1.1898492 0.5213592 -2.282 0.022477 *
## monthjul -0.8212558 0.3165669 -2.594 0.009480 **
## monthjun 0.8197724 0.3706333 2.212 0.026979 *
## monthmar 1.6674716 0.4572522 3.647 0.000266 ***
## monthmay -0.1040225 0.2883731 -0.361 0.718307
## monthnov -0.5641505 0.3311397 -1.704 0.088444 .
## monthoct 1.6440146 0.4003467 4.106 4.02e-05 ***
## monthsep 0.5930471 0.5224089 1.135 0.256285
## duration 0.0041383 0.0002441 16.954 < 2e-16 ***
## campaign -0.0787423 0.0356280 -2.210 0.027097 *
## poutcomeother 0.6943477 0.3351100 2.072 0.038265 *
## poutcomesuccess 2.4720851 0.3539787 6.984 2.87e-12 ***
## poutcomeunknown 0.2161172 0.2428970 0.890 0.373601
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 2101.7 on 2938 degrees of freedom
## Residual deviance: 1453.9 on 2915 degrees of freedom
## AIC: 1501.9
##
## Number of Fisher Scoring iterations: 6
##
## [1] "Predicting Test set..."
## [1] "Test Results:"
| AUC | Accuracy | Precision | Recall | F1 |
|---|---|---|---|---|
| 0.8942268 | 0.8994943 | 0.6210526 | 0.3241758 | 0.4259928 |
Σε αυτό το τεστ παρατηρούμε μια πολύ μικρή αύξηση μόνο στον δείκτη AUC. Σε γενικές γράμμες, βάσει των άλλων 4 μετρικών, η απόδοση έπεσε.
Συμπεράσματα
Οι πιο σημαντικές μεταβλητές για την πρόβλεψη της κατάθεσης προθεσμίας (y) σύμφωνα με το μοντέλο είναι:
duration (διάρκεια τελευταίας κλήσης): Θετική και πολύ ισχυρή επίδραση (p < 2e-16). Όσο μεγαλύτερη η διάρκεια της κλήσης, τόσο μεγαλύτερη η πιθανότητα να γίνει κατάθεση.
poutcomesuccess: Πολύ σημαντική θετική επίδραση (p ~ 2.37e-11), δείχνει ότι αν ο πελάτης είχε ανταποκριθεί θετικά σε προηγούμενη καμπάνια, αυξάνεται σημαντικά η πιθανότητα νέας κατάθεσης.
contactunknown (άγνωστος τύπος επαφής): Ισχυρή αρνητική επίδραση (p ~ 1.36e-10), δηλαδή όταν δεν είναι γνωστός ο τύπος επαφής, μειώνεται η πιθανότητα κατάθεσης.
months: έχουν στατιστικά σημαντική επίδραση, δείχνοντας εποχιακές διακυμάνσεις στις καταθέσεις.
housingyes και loanyes έχουν αρνητική επίδραση, δηλαδή όσοι έχουν στεγαστικό ή προσωπικό δάνειο είναι λιγότερο πιθανό να κάνουν κατάθεση.
campaign (αριθμός επαφών στην τρέχουσα καμπάνια): Αρνητική επίδραση, που σημαίνει ότι πολλές επαφές μπορεί να μειώνουν την πιθανότητα κατάθεσης (ίσως λόγω κούρασης ή αρνητικής αντίδρασης).
poutcomeother (άλλο αποτέλεσμα προηγούμενης καμπάνιας): Θετική και σημαντική επίδραση.