Logistic Regression – Bank Marketing Dataset
Anastasios Politis
# Βιβλιοθήκες
library(tidyverse)## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.5
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ ggplot2 3.5.2 ✔ tibble 3.3.0
## ✔ lubridate 1.9.4 ✔ tidyr 1.3.1
## ✔ purrr 1.0.4
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errorslibrary(dplyr)
library(ggplot2)
library(readr)
# Εισαγωγή δεδομένων
bank <- read.csv("bank.csv", sep = ";")
# Προβολή των πρώτων γραμμών
head(bank)## age job marital education default balance housing loan contact day
## 1 30 unemployed married primary no 1787 no no cellular 19
## 2 33 services married secondary no 4789 yes yes cellular 11
## 3 35 management single tertiary no 1350 yes no cellular 16
## 4 30 management married tertiary no 1476 yes yes unknown 3
## 5 59 blue-collar married secondary no 0 yes no unknown 5
## 6 35 management single tertiary no 747 no no cellular 23
## month duration campaign pdays previous poutcome y
## 1 oct 79 1 -1 0 unknown no
## 2 may 220 1 339 4 failure no
## 3 apr 185 1 330 1 failure no
## 4 jun 199 4 -1 0 unknown no
## 5 may 226 1 -1 0 unknown no
## 6 feb 141 2 176 3 failure no# Επισκόπηση μεταβλητών
str(bank)## 'data.frame': 4521 obs. of 17 variables:
## $ age : int 30 33 35 30 59 35 36 39 41 43 ...
## $ job : chr "unemployed" "services" "management" "management" ...
## $ marital : chr "married" "married" "single" "married" ...
## $ education: chr "primary" "secondary" "tertiary" "tertiary" ...
## $ default : chr "no" "no" "no" "no" ...
## $ balance : int 1787 4789 1350 1476 0 747 307 147 221 -88 ...
## $ housing : chr "no" "yes" "yes" "yes" ...
## $ loan : chr "no" "yes" "no" "yes" ...
## $ contact : chr "cellular" "cellular" "cellular" "unknown" ...
## $ day : int 19 11 16 3 5 23 14 6 14 17 ...
## $ month : chr "oct" "may" "apr" "jun" ...
## $ duration : int 79 220 185 199 226 141 341 151 57 313 ...
## $ campaign : int 1 1 1 4 1 2 1 2 2 1 ...
## $ pdays : int -1 339 330 -1 -1 176 330 -1 -1 147 ...
## $ previous : int 0 4 1 0 0 3 2 0 0 2 ...
## $ poutcome : chr "unknown" "failure" "failure" "unknown" ...
## $ y : chr "no" "no" "no" "no" ...summary(bank)## 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
##
##
## 1 Περιγραφή Δεδομένων & Ερώτημα Ανάλυσης
Το παρόν dataset περιλαμβάνει 4521 εγγραφές και 17 μεταβλητές, οι οποίες αφορούν πελάτες ενός τραπεζικού οργανισμού. Στόχος της ανάλυσης είναι να προβλεφθεί η πιθανότητα συμμετοχής ενός πελάτη σε μια καμπάνια μακροπρόθεσμης κατάθεσης (εξαρτημένη μεταβλητή: y). ## Περιγραφή Μεταβλητών Περιγραφή των Μεταβλητών
Το dataset περιλαμβάνει 17 μεταβλητές: 16 ανεξάρτητες (predictors) και 1 εξαρτημένη (target). Οι μεταβλητές χωρίζονται σε κατηγορίες:
| Μεταβλητή | Τύπος | Περιγραφή |
|---|---|---|
age |
Αριθμητική | Ηλικία του πελάτη |
job |
Κατηγορική | Επάγγελμα (π.χ. admin., technician, student, etc.) |
marital |
Κατηγορική | Οικογενειακή κατάσταση (married, single, divorced) |
education |
Κατηγορική | Εκπαίδευση (primary, secondary, tertiary, unknown) |
default |
Κατηγορική | Έχει ο πελάτης δάνειο σε καθυστέρηση; (yes/no) |
balance |
Αριθμητική | Μέσο ετήσιο υπόλοιπο στον λογαριασμό (σε ευρώ) |
housing |
Κατηγορική | Έχει στεγαστικό δάνειο; (yes/no) |
loan |
Κατηγορική | Έχει προσωπικό δάνειο; (yes/no) |
| Μεταβλητή | Τύπος | Περιγραφή |
|---|---|---|
contact |
Κατηγορική | Τύπος επικοινωνίας (telephone, cellular, unknown) |
day |
Αριθμητική | Ημέρα του μήνα που έγινε η επαφή |
month |
Κατηγορική | Μήνας της τελευταίας επαφής |
duration |
Αριθμητική | Διάρκεια της επαφής σε δευτερόλεπτα |
| Μεταβλητή | Τύπος | Περιγραφή |
|---|---|---|
campaign |
Αριθμητική | Πλήθος επαφών κατά τη διάρκεια της τρέχουσας καμπάνιας |
pdays |
Αριθμητική | Ημέρες από την τελευταία επαφή (ή -1 αν δεν υπήρξε) |
previous |
Αριθμητική | Αριθμός προηγούμενων επαφών με τον πελάτη |
poutcome |
Κατηγορική | Αποτέλεσμα προηγούμενης καμπάνιας (success, failure κ.λπ.) |
| Μεταβλητή | Τύπος | Περιγραφή |
|---|---|---|
y |
Κατηγορική (Binary) | Αν ο πελάτης αποδέχθηκε το term deposit (yes/no) |
1.1 Κατανομή Μεταβλητής στόχου.
ggplot(bank, aes(x = y, fill = y)) +
geom_bar() +
theme_minimal() +
labs(title = "Κατανομή Μεταβλητής-Στόχου (y)", x = "Αποδοχή Term Deposit", y = "Πλήθος")
Η γραφική απεικόνιση της μεταβλητής-στόχου (y) δείχνει την κατανομή των πελατών που αποδέχτηκαν ή όχι την προσφορά για term deposit. Παρατηρούμε ότι η πλειονότητα των πελατών (περίπου 85%) δεν αποδέχτηκε την προσφορά, ενώ ένα μικρότερο ποσοστό (περίπου 15%) την αποδέχτηκε.
Αυτή η ανισορροπία δείχνει ότι πρόκειται για μη ισορροπημένο σύνολο δεδομένων (imbalanced dataset)
#Barplot της ηλικίας των πελατών
1.2 Ηλικία πελατών.
ggplot(bank, aes(x = y, y = age, fill = y)) +
geom_boxplot() +
theme_minimal() +
labs(title = "Ηλικία πελατών ανά Απόφαση", x = "y", y = "Ηλικία")
Ηλικία πελατών ανά Απόφαση
Το παραπάνω boxplot δείχνει τη διασπορά της μεταβλητής ηλικία σε συνάρτηση με την απόφαση αποδοχής ή μη του term deposit. Παρατηρούμε ότι οι πελάτες που αποδέχτηκαν την προσφορά (τιμή “yes”) εμφανίζουν ελαφρώς μεγαλύτερη διάμεσο ηλικίας συγκριτικά με αυτούς που την απέρριψαν.
Επιπλέον, και στις δύο κατηγορίες παρατηρούνται ακραίες τιμές (outliers), ιδιαίτερα σε μεγαλύτερες ηλικίες, γεγονός αναμενόμενο καθώς το εύρος ηλικιών είναι μεγάλο.
1.3 Barplot ανά επάγγελμα
ggplot(bank, aes(x = job, fill = y)) +
geom_bar(position = "fill") +
coord_flip() +
theme_minimal() +
labs(title = "Αναλογία αποδοχής ανά επάγγελμα", x = "Επάγγελμα", y = "Ποσοστό") +
scale_y_continuous(labels = scales::percent)
1.3 Ανάλυση αποδοχής ανά επάγγελμα
Στο παραπάνω γράφημα εμφανίζεται η αναλογία πελατών που αποδέχθηκαν ή όχι την προσφορά για term deposit, κατανεμημένη ανά επαγγελματική κατηγορία. Παρατηρούμε ότι σε όλα τα επαγγέλματα η απόρριψη (τιμή “no”) είναι αισθητά υψηλότερη από την αποδοχή.
Ορισμένες κατηγορίες, όπως οι συνταξιούχοι (retired) και οι φοιτητές (student), παρουσιάζουν σχετικά αυξημένα ποσοστά αποδοχής, γεγονός που μπορεί να υποδηλώνει διαφορετικά κίνητρα ή οικονομικές προτεραιότητες. Από την άλλη, επαγγελματικές ομάδες όπως οι blue-collar εργαζόμενοι, οι ελεύθεροι επαγγελματίες και το διοικητικό προσωπικό έχουν χαμηλότερα ποσοστά αποδοχής.
2 Προετοιμασία Δεδομένων
# Φόρτωση βιβλιοθήκης
library(caTools)
# Ορισμός seed:
set.seed(995)
# Διαχωρισμός δεδομένων σε train (65%) και test (35%)
split <- sample.split(bank$y, SplitRatio = 0.65)
train <- subset(bank, split == TRUE)
test <- subset(bank, split == FALSE)
# Μέγεθος κάθε set
cat("Αριθμός παρατηρήσεων στο train set:", nrow(train), "\n")## Αριθμός παρατηρήσεων στο train set: 2939cat("Αριθμός παρατηρήσεων στο test set:", nrow(test), "\n")## Αριθμός παρατηρήσεων στο test set: 1582# Έλεγχος για NA
colSums(is.na(train))## age job marital education default balance housing loan
## 0 0 0 0 0 0 0 0
## contact day month duration campaign pdays previous poutcome
## 0 0 0 0 0 0 0 0
## y
## 0colSums(is.na(test))## age job marital education default balance housing loan
## 0 0 0 0 0 0 0 0
## contact day month duration campaign pdays previous poutcome
## 0 0 0 0 0 0 0 0
## y
## 0Για την ανάλυσή μας, διαχωρίσαμε το dataset σε σύνολα εκπαίδευσης και ελέγχου με αναλογία 65%-35%, χρησιμοποιώντας τον sample.split από τη βιβλιοθήκη caTools. Ορίσαμε αριθμό seed = 904, που βασίζεται στα δύο τελευταία ψηφία του ΑΕΜ , ώστε τα αποτελέσματα να είναι αναπαραγώγιμα. Το training set περιλαμβάνει 2939 παρατηρήσεις, ενώ το test set περιλαμβάνει 1582.
3 Δημιουργία του Μοντέλου Λογιστικής Παλινδρόμησης
# Μετατροπή της εξαρτημένης μεταβλητής σε δυαδική (αν δεν είναι ήδη factor)
train$y <- as.factor(train$y)
# Fit του λογιστικού μοντέλου με όλες τις ανεξάρτητες μεταβλητές
model <- glm(y ~ ., data = train, family = "binomial")
# Περίληψη του μοντέλου
summary(model)##
## Call:
## glm(formula = y ~ ., family = "binomial", data = train)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.180e+00 7.838e-01 -2.782 0.00541 **
## age -4.375e-03 9.177e-03 -0.477 0.63358
## jobblue-collar -6.032e-01 3.295e-01 -1.831 0.06714 .
## jobentrepreneur -9.116e-02 4.840e-01 -0.188 0.85061
## jobhousemaid -6.636e-02 5.020e-01 -0.132 0.89483
## jobmanagement 1.577e-01 3.114e-01 0.507 0.61246
## jobretired 1.013e+00 3.837e-01 2.641 0.00828 **
## jobself-employed -1.409e-01 4.819e-01 -0.292 0.76995
## jobservices 3.358e-02 3.477e-01 0.097 0.92306
## jobstudent 4.234e-01 4.595e-01 0.921 0.35688
## jobtechnician -1.379e-01 3.012e-01 -0.458 0.64705
## jobunemployed -2.748e-01 5.085e-01 -0.540 0.58890
## jobunknown 1.310e+00 6.971e-01 1.879 0.06018 .
## maritalmarried -6.915e-01 2.137e-01 -3.236 0.00121 **
## maritalsingle -3.604e-01 2.519e-01 -1.430 0.15260
## educationsecondary 2.574e-01 2.674e-01 0.963 0.33562
## educationtertiary 4.202e-01 3.023e-01 1.390 0.16461
## educationunknown -4.233e-01 4.832e-01 -0.876 0.38102
## defaultyes 4.357e-01 5.573e-01 0.782 0.43438
## balance 5.317e-07 2.506e-05 0.021 0.98307
## housingyes -1.262e-01 1.752e-01 -0.720 0.47137
## loanyes -7.318e-01 2.599e-01 -2.816 0.00487 **
## contacttelephone 1.219e-01 2.934e-01 0.416 0.67769
## contactunknown -1.482e+00 2.983e-01 -4.966 6.84e-07 ***
## day 1.590e-02 1.028e-02 1.547 0.12188
## monthaug -3.997e-01 3.107e-01 -1.287 0.19824
## monthdec -5.189e-01 8.470e-01 -0.613 0.54015
## monthfeb -2.653e-01 3.910e-01 -0.679 0.49743
## monthjan -1.017e+00 4.511e-01 -2.254 0.02417 *
## monthjul -9.827e-01 3.104e-01 -3.166 0.00155 **
## monthjun 2.352e-01 3.913e-01 0.601 0.54770
## monthmar 1.362e+00 4.839e-01 2.814 0.00489 **
## monthmay -7.656e-01 3.044e-01 -2.515 0.01191 *
## monthnov -1.045e+00 3.416e-01 -3.061 0.00221 **
## monthoct 1.187e+00 4.195e-01 2.829 0.00467 **
## monthsep 3.935e-01 4.962e-01 0.793 0.42772
## duration 4.339e-03 2.528e-04 17.161 < 2e-16 ***
## campaign -1.083e-01 4.012e-02 -2.700 0.00694 **
## pdays -2.718e-03 1.393e-03 -1.951 0.05112 .
## previous -2.620e-03 5.340e-02 -0.049 0.96087
## poutcomeother 5.535e-01 3.630e-01 1.525 0.12735
## poutcomesuccess 2.932e+00 3.784e-01 7.747 9.38e-15 ***
## poutcomeunknown -2.895e-01 4.138e-01 -0.700 0.48412
## ---
## 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: 1344.1 on 2896 degrees of freedom
## AIC: 1430.1
##
## Number of Fisher Scoring iterations: 6Δημιουργήσαμε μοντέλο λογιστικής παλινδρόμησης όπου η εξαρτημένη μεταβλητή είναι η μεταβλητή y (αν ο πελάτης αποδέχτηκε ή όχι την προσφορά). Περιλάβαμε όλες τις διαθέσιμες ανεξάρτητες μεταβλητές. Από την περίληψη του μοντέλου (summary(model)) εντοπίσαμε τις μεταβλητές με σημαντική συσχέτιση με την εξαρτημένη μεταβλητή βάσει του p-value (< 0.05). Αυτές περιλαμβάνουν: Στατιστικά σημαντικές μεταβλητές (p < 0.05)
Οι παρακάτω μεταβλητές βρέθηκαν να επηρεάζουν στατιστικά σημαντικά την πιθανότητα επιτυχούς ανταπόκρισης στην καμπάνια (δηλ. θετική απάντηση στο y = yes):
jobretired (p = 0.00823): Οι συνταξιούχοι εμφανίζουν αυξημένη πιθανότητα θετικής ανταπόκρισης.
maritalmarried (p = 0.00121): Οι έγγαμοι διαφοροποιούνται σημαντικά σε σχέση με άλλες ομάδες.
loan:yes (p = 0.00487): Όσοι έχουν δάνειο είναι λιγότερο πιθανό να ανταποκριθούν θετικά.
contactunknown (p < 0.001): Η απουσία πληροφορίας για τον τρόπο επικοινωνίας συσχετίζεται έντονα με μειωμένη πιθανότητα επιτυχίας.
month:
jan (p = 0.02417), jul (p = 0.00155), mar (p = 0.00489), may (p = 0.01191), nov (p = 0.00221), oct (p = 0.00467): Υπάρχει εποχικότητα στην αποτελεσματικότητα της καμπάνιας.
duration (p < 2e-16): Η διάρκεια του τηλεφωνήματος είναι ο ισχυρότερος θετικός προγνωστικός παράγοντας.
campaign (p = 0.00694): Όσο περισσότερες επαφές έχουν γίνει, τόσο μικρότερη η πιθανότητα επιτυχίας (αρνητική συσχέτιση).
poutcomesuccess (p < 0.001): Αν η προηγούμενη καμπάνια είχε επιτυχημένο αποτέλεσμα, τότε η πιθανότητα θετικής απάντησης είναι πολύ μεγαλύτερη.Μεταβλητές οριακής σημαντικότητας (0.05 < p < 0.1)
jobblue-collar (p = 0.06714)
pdays (p = 0.05112)
jobunknown (p = 0.06018)Αυτές ενδέχεται να έχουν επιρροή, αλλά η στατιστική τους ισχύ δεν είναι ισχυρή.
#Δημιουργία άλλου μοντέλου
model_log <- glm(y ~ ., data = train, family = "binomial")
step_model <- step(model_log)## Start: AIC=1430.11
## y ~ age + job + marital + education + default + balance + housing +
## loan + contact + day + month + duration + campaign + pdays +
## previous + poutcome
##
## Df Deviance AIC
## - balance 1 1344.1 1428.1
## - previous 1 1344.1 1428.1
## - age 1 1344.3 1428.3
## - housing 1 1344.6 1428.6
## - default 1 1344.7 1428.7
## - education 3 1348.8 1428.8
## <none> 1344.1 1430.1
## - day 1 1346.5 1430.5
## - pdays 1 1348.0 1432.0
## - job 11 1369.1 1433.1
## - campaign 1 1353.0 1437.0
## - loan 1 1353.0 1437.0
## - marital 2 1355.3 1437.3
## - contact 2 1371.0 1453.0
## - month 11 1409.9 1473.9
## - poutcome 3 1432.6 1512.6
## - duration 1 1749.8 1833.8
##
## Step: AIC=1428.11
## y ~ age + job + marital + education + default + housing + loan +
## contact + day + month + duration + campaign + pdays + previous +
## poutcome
##
## Df Deviance AIC
## - previous 1 1344.1 1426.1
## - age 1 1344.3 1426.3
## - housing 1 1344.6 1426.6
## - default 1 1344.7 1426.7
## - education 3 1348.8 1426.8
## <none> 1344.1 1428.1
## - day 1 1346.5 1428.5
## - pdays 1 1348.0 1430.0
## - job 11 1369.1 1431.1
## - campaign 1 1353.0 1435.0
## - loan 1 1353.1 1435.1
## - marital 2 1355.3 1435.3
## - contact 2 1371.0 1451.0
## - month 11 1409.9 1471.9
## - poutcome 3 1432.7 1510.7
## - duration 1 1750.0 1832.0
##
## Step: AIC=1426.11
## y ~ age + job + marital + education + default + housing + loan +
## contact + day + month + duration + campaign + pdays + poutcome
##
## Df Deviance AIC
## - age 1 1344.3 1424.3
## - housing 1 1344.6 1424.6
## - default 1 1344.7 1424.7
## - education 3 1348.8 1424.8
## <none> 1344.1 1426.1
## - day 1 1346.5 1426.5
## - pdays 1 1348.0 1428.0
## - job 11 1369.1 1429.1
## - campaign 1 1353.0 1433.0
## - loan 1 1353.1 1433.1
## - marital 2 1355.3 1433.3
## - contact 2 1371.0 1449.0
## - month 11 1410.0 1470.0
## - poutcome 3 1437.6 1513.6
## - duration 1 1750.2 1830.2
##
## Step: AIC=1424.34
## y ~ job + marital + education + default + housing + loan + contact +
## day + month + duration + campaign + pdays + poutcome
##
## Df Deviance AIC
## - housing 1 1344.8 1422.8
## - default 1 1344.9 1422.9
## - education 3 1349.5 1423.5
## <none> 1344.3 1424.3
## - day 1 1346.8 1424.8
## - pdays 1 1348.2 1426.2
## - job 11 1371.9 1429.9
## - loan 1 1353.2 1431.2
## - campaign 1 1353.3 1431.3
## - marital 2 1356.0 1432.0
## - contact 2 1371.2 1447.2
## - month 11 1410.0 1468.0
## - poutcome 3 1437.7 1511.7
## - duration 1 1750.2 1828.2
##
## Step: AIC=1422.77
## y ~ job + marital + education + default + loan + contact + day +
## month + duration + campaign + pdays + poutcome
##
## Df Deviance AIC
## - default 1 1345.3 1421.3
## - education 3 1349.9 1421.9
## <none> 1344.8 1422.8
## - day 1 1347.4 1423.4
## - pdays 1 1348.8 1424.8
## - loan 1 1353.8 1429.8
## - campaign 1 1354.0 1430.0
## - job 11 1374.5 1430.5
## - marital 2 1356.6 1430.6
## - contact 2 1372.5 1446.5
## - month 11 1415.2 1471.2
## - poutcome 3 1441.7 1513.7
## - duration 1 1750.3 1826.3
##
## Step: AIC=1421.35
## y ~ job + marital + education + loan + contact + day + month +
## duration + campaign + pdays + poutcome
##
## Df Deviance AIC
## - education 3 1350.3 1420.3
## <none> 1345.3 1421.3
## - day 1 1347.9 1421.9
## - pdays 1 1349.2 1423.2
## - loan 1 1354.3 1428.3
## - campaign 1 1354.7 1428.7
## - job 11 1374.9 1428.9
## - marital 2 1357.3 1429.3
## - contact 2 1373.2 1445.2
## - month 11 1415.7 1469.7
## - poutcome 3 1441.9 1511.9
## - duration 1 1750.5 1824.5
##
## Step: AIC=1420.35
## y ~ job + marital + loan + contact + day + month + duration +
## campaign + pdays + poutcome
##
## Df Deviance AIC
## <none> 1350.3 1420.3
## - day 1 1352.8 1420.8
## - pdays 1 1354.3 1422.3
## - loan 1 1358.6 1426.6
## - campaign 1 1359.6 1427.6
## - marital 2 1363.1 1429.1
## - job 11 1382.2 1430.2
## - contact 2 1379.2 1445.2
## - month 11 1420.6 1468.6
## - poutcome 3 1447.1 1511.1
## - duration 1 1756.5 1824.5summary(step_model)##
## Call:
## glm(formula = y ~ job + marital + loan + contact + day + month +
## duration + campaign + pdays + poutcome, family = "binomial",
## data = train)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.2267992 0.5455889 -4.081 4.48e-05 ***
## jobblue-collar -0.6868012 0.3191759 -2.152 0.03141 *
## jobentrepreneur -0.0592165 0.4775570 -0.124 0.90132
## jobhousemaid -0.1488095 0.4753599 -0.313 0.75425
## jobmanagement 0.2848635 0.2760344 1.032 0.30208
## jobretired 0.8869053 0.3319627 2.672 0.00755 **
## jobself-employed -0.0443889 0.4691083 -0.095 0.92461
## jobservices 0.0082761 0.3461837 0.024 0.98093
## jobstudent 0.4524970 0.4475819 1.011 0.31203
## jobtechnician -0.0866157 0.2981758 -0.290 0.77144
## jobunemployed -0.2956655 0.5031053 -0.588 0.55675
## jobunknown 1.1054515 0.6868565 1.609 0.10752
## maritalmarried -0.6894078 0.2125115 -3.244 0.00118 **
## maritalsingle -0.2702283 0.2333402 -1.158 0.24683
## loanyes -0.7000964 0.2581113 -2.712 0.00668 **
## contacttelephone 0.0822755 0.2864882 0.287 0.77397
## contactunknown -1.5309125 0.2962890 -5.167 2.38e-07 ***
## day 0.0159350 0.0102411 1.556 0.11971
## monthaug -0.3258157 0.2972735 -1.096 0.27307
## monthdec -0.5295043 0.8402611 -0.630 0.52859
## monthfeb -0.2065677 0.3815280 -0.541 0.58822
## monthjan -1.0033350 0.4451654 -2.254 0.02421 *
## monthjul -0.9540165 0.3070618 -3.107 0.00189 **
## monthjun 0.2937462 0.3832210 0.767 0.44337
## monthmar 1.4034573 0.4765095 2.945 0.00323 **
## monthmay -0.7654736 0.3020411 -2.534 0.01127 *
## monthnov -1.0371906 0.3394818 -3.055 0.00225 **
## monthoct 1.1919839 0.4121494 2.892 0.00383 **
## monthsep 0.4599661 0.4900789 0.939 0.34796
## duration 0.0043108 0.0002503 17.220 < 2e-16 ***
## campaign -0.1087026 0.0395256 -2.750 0.00596 **
## pdays -0.0027430 0.0013870 -1.978 0.04797 *
## poutcomeother 0.5721363 0.3560490 1.607 0.10808
## poutcomesuccess 2.9344124 0.3723844 7.880 3.27e-15 ***
## poutcomeunknown -0.2719253 0.3839676 -0.708 0.47882
## ---
## 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: 1350.3 on 2904 degrees of freedom
## AIC: 1420.3
##
## Number of Fisher Scoring iterations: 6Για να καταλήξουμε στις πιο σημαντικές μεταβλητές του μοντέλου, χρησιμοποιήσαμε ένα stepwise μοντέλο. Αυτό σημαίνει ότι το σύστημα δοκίμασε διάφορους συνδυασμούς μεταβλητών, προσθέτοντας ή αφαιρώντας μία κάθε φορά, μέχρι να φτάσει στον καλύτερο δυνατό συνδυασμό με βάση ένα στατιστικό κριτήριο (το AIC). Με αυτόν τον τρόπο κρατάμε μόνο τις μεταβλητές που βοηθούν πραγματικά στην πρόβλεψη, αποφεύγοντας ένα πολύπλοκο και “βαρύ” μοντέλο.
Τελικές μεταβλητές του step-model:
job (με επιμέρους κατηγορίες όπως blue-collar, retired κ.λπ.)
marital (με κατηγορίες married, single)
loan
contact (με έμφαση στην τιμή unknown)
month (διάφορες τιμές: mar, may, oct, nov κ.λπ.)
duration (διάρκεια τελευταίας επαφής)
campaign (αριθμός επαφών κατά την καμπάνια)
pdays (ημέρες από την προηγούμενη επαφή)
poutcome (αποτέλεσμα προηγούμενης καμπάνιας)4 Αξιολόγηση μοντέλου
# Υπολογισμός πιθανοτήτων για την κατηγορία "yes"
probabilities <- predict(model, newdata = test, type = "response")
# Μετατροπή σε προβλέψεις 0 ή 1
predicted_classes <- ifelse(probabilities > 0.3, "yes", "no")
# Μετατροπή σε factor για σύγκριση
predicted_classes <- factor(predicted_classes, levels = c("no", "yes"))# Confusion matrix
conf_matrix <- table(Predicted = predicted_classes, Actual = test$y)
conf_matrix## Actual
## Predicted no yes
## no 1322 99
## yes 78 83# Confusion Matrix
conf_matrix <- table(Predicted = predicted_classes, Actual = test$y)
# Εξαγωγή τιμών
TN <- conf_matrix["no", "no"]
FP <- conf_matrix["yes", "no"]
FN <- conf_matrix["no", "yes"]
TP <- conf_matrix["yes", "yes"]
# Υπολογισμοί
accuracy <- (TP + TN) / sum(conf_matrix)
precision <- TP / (TP + FP)
recall <- TP / (TP + FN) # Sensitivity ή True Positive Rate
specificity <- TN / (TN + FP) # True Negative Rate
f1_score <- 2 * (precision * recall) / (precision + recall)
# Εκτύπωση αποτελεσμάτων
cat("Accuracy:", round(accuracy, 4), "\n")## Accuracy: 0.8881cat("Precision:", round(precision, 4), "\n")## Precision: 0.5155cat("Recall (Sensitivity):", round(recall, 4), "\n")## Recall (Sensitivity): 0.456cat("Specificity:", round(specificity, 4), "\n")## Specificity: 0.9443cat("F1 Score:", round(f1_score, 4), "\n")## F1 Score: 0.484Μετρικές:
Accuracy (Ακρίβεια): 0.8881
Δηλαδή, το 88.81% των συνολικών προβλέψεων ήταν σωστό. Ωστόσο, επειδή έχουμε ανισορροπία στην κατανομή των κλάσεων (πολύ περισσότερα "no"), η ακρίβεια από μόνη της δεν είναι επαρκής ένδειξη.
Precision (Θετική Προγνωστική Ικανότητα): 0.5155
Από τις προβλέψεις που το μοντέλο θεώρησε ως "yes", μόνο το 51.55% ήταν πραγματικά θετικά. Αυτό σημαίνει ότι υπάρχει αρκετός "θόρυβος" στις θετικές προβλέψεις.
Recall (Ευαισθησία): 0.456
Το μοντέλο εντόπισε μόνο το 45.6% των πραγματικών "yes", κάτι που δείχνει ότι χάνει πάνω από τους μισούς πελάτες που θα απαντούσαν θετικά.
Specificity (Ειδικότητα): 0.9443
Αντίθετα, η ικανότητα του μοντέλου να εντοπίζει σωστά τα "no" είναι πολύ υψηλή, στο 94.43%.
F1 Score: 0.484
Μέτρο που ισορροπεί precision και recall. Η χαμηλή τιμή δείχνει ότι το μοντέλο δεν τα καταφέρνει ιδιαιτέρως καλά στη διάκριση της "yes" κατηγορίας.💡 Συμπέρασμα:
Το μοντέλο εμφανίζει πολύ καλή επίδοση στην πρόβλεψη των αρνητικών περιπτώσεων (no), αλλά δυσκολεύεται να προβλέψει σωστά τις θετικές περιπτώσεις (yes), δηλαδή τους πελάτες που θα ανταποκριθούν θετικά στην καμπάνια. Αυτό πιθανότατα οφείλεται στην ανισορροπία του dataset, όπου οι “yes” περιπτώσεις είναι λιγότερες.
# Δημιουργία προβλέψεων πιθανότητας
predicted_probs_step <- predict(step_model, newdata = test, type = "response")
# Μετατροπή σε κατηγορικές προβλέψεις ("yes"/"no") με όριο 0.5
predicted_classes_step <- ifelse(predicted_probs_step > 0.3, "yes", "no")
predicted_classes_step <- factor(predicted_classes_step, levels = c("no", "yes"))
conf_matrix_step <- table(Predicted = predicted_classes_step, Actual = test$y)
print(conf_matrix_step)## Actual
## Predicted no yes
## no 1327 100
## yes 73 82# Εξαγωγή τιμών
TN <- conf_matrix_step["no", "no"]
TP <- conf_matrix_step["yes", "yes"]
FN <- conf_matrix_step["no", "yes"]
FP <- conf_matrix_step["yes", "no"]
# Υπολογισμοί
accuracy <- (TP + TN) / sum(conf_matrix_step)
precision <- TP / (TP + FP)
recall <- TP / (TP + FN) # Sensitivity
specificity <- TN / (TN + FP)
f1_score <- 2 * (precision * recall) / (precision + recall)
# Εκτύπωση αποτελεσμάτων
cat("Accuracy: ", round(accuracy, 4), "\n")## Accuracy: 0.8906cat("Precision: ", round(precision, 4), "\n")## Precision: 0.529cat("Recall: ", round(recall, 4), "\n")## Recall: 0.4505cat("Specificity: ", round(specificity, 4), "\n")## Specificity: 0.9479cat("F1 Score: ", round(f1_score, 4), "\n")## F1 Score: 0.4866Μετρικές Απόδοσης:
Accuracy: 0.8906
Το 89.06% των συνολικών προβλέψεων ήταν σωστό, ελαφρώς υψηλότερο από το πλήρες μοντέλο.
Precision: 0.529
Το μοντέλο προβλέπει θετικά με σχετική ακρίβεια: πάνω από το 52% των "yes" προβλέψεων είναι σωστές.
Recall (Sensitivity): 0.4505
Εντοπίζει περίπου το 45% των πελατών που θα απαντούσαν "yes", τιμή συγκρίσιμη με το πλήρες μοντέλο.
Specificity: 0.9479
Υψηλή ικανότητα να εντοπίζει σωστά τους αρνητικούς (δηλ. "no"), με ποσοστό σχεδόν 95%.
F1 Score: 0.4866
Ελαφρώς βελτιωμένο σε σχέση με το πλήρες μοντέλο, υποδηλώνοντας πιο ισορροπημένη συμπεριφορά μεταξύ precision και recall.| Μετρική | Πλήρες Μοντέλο | STEP Μοντέλο |
|---|---|---|
| Accuracy | 0.8881 | 0.8906 |
| Precision | 0.5155 | 0.5290 |
| Recall | 0.4560 | 0.4505 |
| Specificity | 0.9443 | 0.9479 |
| F1 Score | 0.4840 | 0.4866 |
4.1 ROC curve
Αξιολόγηση με ROC Curve και AUC
Για την αξιολόγηση της συνολικής διακριτικής ικανότητας του stepwise λογιστικού μοντέλου, δημιουργήθηκε η καμπύλη ROC (Receiver Operating Characteristic). Η ROC καμπύλη απεικονίζει τη σχέση μεταξύ του ποσοστού αληθώς θετικών προβλέψεων (Sensitivity) και του ποσοστού ψευδώς θετικών (1 - Specificity) για όλα τα πιθανά thresholds.
Το εμβαδόν κάτω από την καμπύλη (AUC) βρέθηκε ίσο με 0.867, τιμή που υποδηλώνει πολύ καλή προβλεπτική ικανότητα. Συγκεκριμένα, όσο πλησιάζει το AUC στο 1, τόσο καλύτερα μπορεί το μοντέλο να διακρίνει μεταξύ των δύο κατηγοριών (yes/no). Τιμές πάνω από 0.80 θεωρούνται εξαιρετικές στην πράξη.
Η χρήση της ROC καμπύλης ενίσχυσε τη δικαιολόγηση της επιλογής του χαμηλότερου threshold (0.3), καθώς το μοντέλο εμφάνισε σταθερή και ισορροπημένη απόδοση σε ένα ευρύ φάσμα τιμών, διατηρώντας υψηλή ευαισθησία χωρίς να θυσιάζει εντελώς την ειδικότητα.
4.2 Roc curve & auc
4.2.1 Full model
# 1. Απαραίτητα πακέτα
library(pROC)## Type 'citation("pROC")' for a citation.##
## Attaching package: 'pROC'## The following objects are masked from 'package:stats':
##
## cov, smooth, var# 2. Προβλέψεις πιθανοτήτων από το full model
full_probs <- predict(model, newdata = test, type = "response")
# 3. Δημιούργησε το ROC curve
roc_full <- roc(test$y, full_probs)## Setting levels: control = no, case = yes## Setting direction: controls < cases# 4. Σχεδίασε το ROC curve
plot(roc_full, col = "blue", main = "ROC Curve - Full Model")
abline(a = 0, b = 1, lty = 2, col = "gray") # διαγώνια γραμμή
# 5. (Προαιρετικά) τύπωσε το AUC
auc(roc_full)## Area under the curve: 0.86594.2.2 Step model
# Βιβλιοθήκη
library(pROC)
# Προβλέψεις πιθανοτήτων για το test set
prob_step <- predict(step_model, newdata = test, type = "response")
# ROC Curve
roc_obj <- roc(test$y, prob_step)## Setting levels: control = no, case = yes## Setting direction: controls < casesplot(roc_obj, col = "blue", print.auc = TRUE, main = "ROC Curve - Stepwise Model")
# 5. (Προαιρετικά) τύπωσε το AUC
auc(roc_obj)## Area under the curve: 0.86664.2.3 ROC Curve και Σύγκριση Μοντέλων
Για την αξιολόγηση της διακριτικής ικανότητας των δύο μοντέλων, δημιουργήθηκε η ROC καμπύλη και υπολογίστηκε η περιοχή κάτω από την καμπύλη (AUC) και για το πλήρες μοντέλο και για το βελτιστοποιημένο μοντέλο stepwise.
Στο πλήρες μοντέλο, η τιμή AUC ανήλθε σε 0.8659, ενώ στο stepwise μοντέλο η τιμή ήταν 0.867, υποδεικνύοντας ουσιαστικά παρόμοια απόδοση. Δεδομένου ότι και στις δύο περιπτώσεις η τιμή AUC είναι κοντά στο 0.87, και άρα αρκετά πάνω από το 0.5 (που αντιστοιχεί στην τυχαία πρόβλεψη), τα μοντέλα εμφανίζουν καλή ικανότητα διάκρισης μεταξύ των δύο κατηγοριών (αγορά/μη αγορά).
Η μικρή διαφορά στο AUC δείχνει ότι η επιλογή μεταβλητών μέσω του stepwise selection δεν επιβάρυνε την απόδοση του μοντέλου, ενώ πιθανόν να προσέφερε απλοποίηση του μοντέλου χωρίς απώλεια πληροφορίας. Το αποτέλεσμα αυτό ενισχύει την επιλογή του stepwise μοντέλου ως αποδοτικό και πιο ερμηνεύσιμο.
5 Αξιολόγηση και Συμπεράσματα
Η λογιστική παλινδρόμηση εφαρμόστηκε στο dataset bank marketing με σκοπό την πρόβλεψη του κατά πόσο ένας πελάτης θα αποδεχτεί μια τραπεζική πρόταση για άνοιγμα προθεσμιακής κατάθεσης (μεταβλητή y). Δημιουργήθηκαν δύο μοντέλα: το πλήρες μοντέλο, το οποίο περιλάμβανε όλες τις ανεξάρτητες μεταβλητές, και το σταδιακά επιλεγμένο μοντέλο (stepwise model), στο οποίο η επιλογή των μεταβλητών έγινε με βάση το κριτήριο AIC.
Από την αξιολόγηση των μοντέλων μέσω των πινάκων σύγχυσης και των μετρικών απόδοσης, διαπιστώθηκε ότι και τα δύο μοντέλα παρουσιάζουν καλή ταξινομητική ικανότητα, με υψηλή ακρίβεια και recall. Επιπλέον, και στα δύο μοντέλα υπολογίστηκε η ROC καμπύλη και η τιμή του AUC (Area Under the Curve). Το AUC για το πλήρες μοντέλο ήταν 0.866, ενώ για το stepwise μοντέλο ήταν 0.862. Οι δύο τιμές είναι πολύ κοντινές, γεγονός που υποδεικνύει ότι η μείωση των μεταβλητών στο stepwise μοντέλο δεν επηρέασε σημαντικά την προβλεπτική ικανότητα του μοντέλου.
Αναφορικά με την ερμηνεία των αποτελεσμάτων, κάποιες μεταβλητές παρουσιάζουν ιδιαίτερα έντονη συσχέτιση με την πιθανότητα θετικής απόκρισης. Για παράδειγμα, η κατηγορία poutcome = success σχετίζεται με σημαντικά αυξημένη πιθανότητα αποδοχής της πρότασης, κάτι που είναι αναμενόμενο, καθώς αφορά άτομα που στο παρελθόν είχαν επιτυχές αποτέλεσμα από προηγούμενη επικοινωνία. Αντίστοιχα, η μεταβλητή duration έχει θετική επίδραση, δείχνοντας ότι όσο μεγαλύτερη είναι η διάρκεια της επικοινωνίας με τον πελάτη, τόσο αυξάνεται η πιθανότητα επιτυχίας. Τέλος, επαγγέλματα όπως student ή retired φαίνεται επίσης να σχετίζονται με αυξημένη πιθανότητα θετικής απόκρισης.
Συμπερασματικά, η λογιστική παλινδρόμηση αποδείχθηκε κατάλληλη τεχνική για το συγκεκριμένο πρόβλημα ταξινόμησης. Το stepwise μοντέλο μπορεί να θεωρηθεί προτιμότερο, καθώς διατηρεί συγκρίσιμη απόδοση με το πλήρες μοντέλο, χρησιμοποιώντας μικρότερο αριθμό μεταβλητών και άρα είναι πιο απλό και ερμηνεύσιμο. Η ανάλυση αυτή μπορεί να προσφέρει χρήσι