Logistic Regression - bank
2025-07-03
1.Περιγραφή του Dataset
Το bank.csv προέρχεται από το UC Irvine Machine Learning Repository και αφορά καμπάνιες άμεσου μάρκετινγκ μιας πορτογαλικής τράπεζας, οι οποίες έγιναν μέσω τηλεφωνικών κλήσεων. Στόχος των καμπανιών ήταν να πειστεί ο πελάτης να εγγραφεί σε ένα τραπεζικό προθεσμιακό προϊόν (term deposit). Η στήλη-στόχος είναι η y, η οποία παίρνει την τιμές ‘yes’ ή ‘no’ αν Ο πελάτης αποδέχτηκε να εγγραφεί ή όχι. Το dataset περιλαμβάνει 4521 εγγραφές-πελάτες και 17 στήλες-χαρακτηριστικά για κάυε εγγραφή.
2.Περιγραφή των Μεταβλητών
age: Ηλικία του πελάτη. (Integer)
job: Επάγγελμα (π.χ. ‘admin.’,‘technician’,‘student’
κ.ά.). (Categorical)
marital: Οικογενειακή κατάσταση. (Categorical)
education: Επίπεδο εκπαίδευσης. (Categorical)
default: Αν έχει καθυστερήσει πληρωμές στο παρελθόν.
(Binary)
balance: Μέσο ετήσιο υπόλοιπο λογαριασμού (σε ευρώ).
(Integer)
housing: Αν έχει προσωπικό δάνειο. (Binary)
loan: Αν έχει στεγαστικό δάνειο. (Binary)
contact: Τύπος τηλεφωνικής επαφής. (Categorical)
day_of_week: Ημέρα της εβδομάδας της τελευταίας επαφής.
(Date (string))
month: Μήνας της τελευταίας επαφής. (Date
(string))
duration: Διάρκεια τηλεφωνικής επαφής (σε
δευτερόλεπτα). (Integer)
campaign: Πλήθος επαφών στην τρέχουσα καμπάνια
(συμπεριλαμβανομένης της τελευταίας). (Integer)
pdays: Ημέρες από την προηγούμενη επαφή σε παλιά
καμπάνια (-1 = καμία προηγούμενη επαφή). (Integer)
previous: Πλήθος προηγούμενων επαφών. (Integer)
poutcome: Αποτέλεσμα προηγούμενης καμπάνιας.
(Categorical)
y: Αν ο πελάτης υπέγραψε προθεσμιακή κατάθεση.
(Binary)
3.Περιγραφά Στατιστικά
3.1 Ανάγνωση Dataset
dataset <- read.csv("C:\\Users\\maria\\Downloads\\bank.csv", sep = ";")
head(dataset)## 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 no3.2 Περιγραφικά Στατιστικά
Αge:
summary(dataset$age) ## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 19.00 33.00 39.00 41.17 49.00 87.00mode_age <- as.numeric(names(sort(table(dataset$age), decreasing = TRUE)[1]))
std_dev_age <- sd(dataset$age, na.rm = TRUE)
var_age <- var(dataset$age, na.rm = TRUE)
range_age <- range(dataset$age, na.rm = TRUE) Επικρατούσα τιμή: 34
Τυπική Απόκλιση: 10.576211
Διακύμανση: 111.8562382
Εύρος τιμών: 19 - 87
Balance:
summary(dataset$balance)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -3313 69 444 1423 1480 71188mode_balance <- as.numeric(names(sort(table(dataset$balance), decreasing = TRUE)[1]))
std_dev_balance <- sd(dataset$balance, na.rm = TRUE)
var_balance <- var(dataset$balance, na.rm = TRUE)
range_balance <- range(dataset$balance, na.rm = TRUE)Επικρατούσα τιμή: 0
Τυπική Απόκλιση: 3009.6381425
Διακύμανση: 9.0579217^{6}
Εύρος τιμών: -3313 - 71188
4.Διερεύνηση Συσχετίσεων
library(ggplot2)
ggplot(dataset, aes(x = age, y = balance)) +
geom_point(alpha = 0.4, color = "blue") +
theme_minimal() +
labs(
title = "Σχέση μεταξύ ηλικίας και υπολοίπου",
x = "Ηλικία",
y = "Υπόλοιπο (σε ευρώ)"
) +
theme(
plot.title = element_text(hjust = 0.5, size = 16, face = "bold"),
axis.title = element_text(size = 13)
)
Παρατηρείται έντονη διασπορά χωρίς σαφή γραμμική σχέση. Υπάρχουν όμως
αρκετοί πελάτες μικρότερης ηλικίας με υψηλότερα υπόλοιπα.
5.Λογιστική Παλινδρόμηση
library(caTools)
library(ROCR)set.seed(908)
split <- sample.split(dataset$y, SplitRatio = 0.65)
train <- subset(dataset, split == TRUE)
test <- subset(dataset, split == FALSE)# Μετατρέπουμε τη μεταβλητή y σε binary (1=yes, 0=no)
train$y_bin <- ifelse(train$y == "yes", 1, 0)
test$y_bin <- ifelse(test$y == "yes", 1, 0)
model <- glm(y_bin ~ age + balance + duration + campaign + pdays + previous + housing + contact,
data = train, family = "binomial")
summary(model)##
## Call:
## glm(formula = y_bin ~ age + balance + duration + campaign + pdays +
## previous + housing + contact, family = "binomial", data = train)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.087e+00 3.031e-01 -10.183 < 2e-16 ***
## age 7.602e-03 6.046e-03 1.257 0.208595
## balance 1.949e-05 1.737e-05 1.122 0.261967
## duration 4.145e-03 2.374e-04 17.457 < 2e-16 ***
## campaign -1.271e-01 3.589e-02 -3.543 0.000396 ***
## pdays 1.279e-03 6.619e-04 1.932 0.053334 .
## previous 9.376e-02 3.409e-02 2.750 0.005951 **
## housingyes -6.277e-01 1.420e-01 -4.420 9.87e-06 ***
## contacttelephone -1.974e-02 2.547e-01 -0.077 0.938233
## contactunknown -1.137e+00 2.049e-01 -5.550 2.86e-08 ***
## ---
## 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: 1595.6 on 2929 degrees of freedom
## AIC: 1615.6
##
## Number of Fisher Scoring iterations: 6Σημαντικότερα αποτελέσματα που προκύπτουν:
1. Η ηλικία δεν επηρεάζει ξεκάθαρα την πιθανότητα απάντησης “yes”.
2. Πολλές επαναλήψεις/επαφές μειώνουν την πιθανότητα να πει κάποιος
“ναι”. Ίσως κουράζεται.
3. Όσο περισσότερες μέρες έχουν περάσει από την τελευταία επαφή, τόσο
ελαφρώς αυξάνεται η πιθανότητα να είναι “ναι”.
4. Πελάτες με περισσότερες προηγούμενες επαφές έχουν μεγαλύτερη
πιθανότητα να πουν “ναι”.
5. Όσοι έχουν στεγαστικό δάνειο έχουν μικρότερη πιθανότητα να αποδεχθούν
την προσφορά.
* Όσο μεγαλύτερη η διάρκεια της κλήσης, τόσο αυξάνεται η πιθανότητα
να πει ο πελάτης “ναι”. Ωστόσο, η μεταβλητή αυτή δεν μπορεί να
χρησιμοποιηθεί για πρόβλεψη
Προβλέψεις στο Testing Set:
# Προβλέψεις πιθανοτήτων
pred_probs <- predict(model, newdata = test, type = "response")
# Μετατροπή σε κλάση (0.5 cutoff)
pred_class <- ifelse(pred_probs > 0.5, 1, 0)# Πίνακας σύγχυσης
table(Πραγματική = test$y_bin, Προβλεπόμενη = pred_class)## Προβλεπόμενη
## Πραγματική 0 1
## 0 1363 37
## 1 147 35actual <- test$y
probabilities <- predict(model, newdata = test, type = "response")
predictClass <- ifelse(probabilities > 0.5, 1, 0)Accuracy: 0.8836915
Precision: 0.4861111
Recall: 0.1923077
F1-Score: 0.2755906
Παρά το υψηλό accuracy, το μοντέλο έχει κακή απόδοση για την “θετική”
κλάση, όπως δείχνουν το χαμηλό recall και το χαμηλό F1-score.Αυτό
πιθανόν σημαίνει ότι το dataset είναι ανισόρροπο (πολύ περισσότερα
αρνητικά από θετικά δείγματα).
Καμπύλη ROC και AUC:
pred <- prediction(pred_probs, test$y_bin)
perf <- performance(pred, "tpr", "fpr")
# ROC plot
plot(perf, col = "blue", lwd = 2, main = "ROC Curve")
abline(a = 0, b = 1, lty = 2, col = "gray")
# Υπολογισμός AUC
auc <- performance(pred, measure = "auc")
auc_value <- auc@y.values[[1]]
auc_value## [1] 0.8644584Το μοντέλο έχει καλή διαχωριστική ικανότητα (AUC = 0.864), άρα μπορεί να ξεχωρίζει θετικά από αρνητικά δείγματα. Ωστόσο, οι χαμηλές τιμές σε Precision, Recall και F1-Score δείχνουν ότι στο συγκεκριμένο threshold που χρησιμοποιείται, το μοντέλο δεν αναγνωρίζει σωστά τις θετικές περιπτώσεις. Πιθανόν υπάρχει ανισορροπία στις κατηγορίες. Με αναπροσαρμογή του threshold και χρήση τεχνικών εξισορρόπησης ίσως γίνει καλύτερη η απόδοση.