Exams
Anastasia Valma
2025-07-03
Διερεύνηση Δεδομένων
Το σύνολο δεδομένων αφορά τηλεφωνικές εκστρατείες άμεσου μάρκετινγκ πορτογαλικής τράπεζας, με στόχο την πρόβλεψη αν ο πελάτης θα συνάψει προθεσμιακή κατάθεση. Περιλαμβάνει 45.211 εγγραφές και 16 μεταβλητές με κατηγορικά, ακέραια και δυαδικά δεδομένα. Ο στόχος είναι η μεταβλητή y (ναι/όχι). Οι μεταβλητές καλύπτουν δημογραφικά χαρακτηριστικά, οικονομικές πληροφορίες και λεπτομέρειες επαφών. Δεν υπάρχουν σημαντικές ελλείψεις στα δεδομένα. Το αρχείο που θα φορτωθεί είναι ένα υποσύνολο του συνόλου με 10% εγγραφές.
## [1] 4521 17Βλέπουμε ότι το σύνολο δεδομένων έχει 4521 εγγραφές(10% του μεγάλου) και 17 χαρακτηριστικά.
Ας δούμε τις στήλες και μερικές μετρικές για το σύνολο δεδομένων μας.
## 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 job marital education default balance housing loan contact
## 1 30 unemployed married primary no 1787 no no cellular
## 2 33 services married secondary no 4789 yes yes cellular
## 3 35 management single tertiary no 1350 yes no cellular
## 4 30 management married tertiary no 1476 yes yes unknown
## 5 59 blue-collar married secondary no 0 yes no unknown
## 6 35 management single tertiary no 747 no no cellular
## 7 36 self-employed married tertiary no 307 yes no cellular
## 8 39 technician married secondary no 147 yes no cellular
## 9 41 entrepreneur married tertiary no 221 yes no unknown
## 10 43 services married primary no -88 yes yes cellular
## day month duration campaign pdays previous poutcome y
## 1 19 oct 79 1 -1 0 unknown no
## 2 11 may 220 1 339 4 failure no
## 3 16 apr 185 1 330 1 failure no
## 4 3 jun 199 4 -1 0 unknown no
## 5 5 may 226 1 -1 0 unknown no
## 6 23 feb 141 2 176 3 failure no
## 7 14 may 341 1 330 2 other no
## 8 6 may 151 2 -1 0 unknown no
## 9 14 may 57 2 -1 0 unknown no
## 10 17 apr 313 1 147 2 failure no| Μεταβλητή | Τύπος |
|---|---|
| age | Αριθμητικό |
| job | Αλφαριθμητικό |
| marital | Αλφαριθμητικό |
| education | Αλφαριθμητικό |
| default | Αλφαριθμητικό |
| balance | Αριθμητικό |
| housing | Αλφαριθμητικό |
| loan | Αλφαριθμητικό |
| contact | Αλφαριθμητικό |
| day | Αριθμητικό |
| month | Αλφαριθμητικό |
| duration | Αριθμητικό |
| campaign | Αριθμητικό |
| pdays | Αριθμητικό |
| previous | Αριθμητικό |
| poutcome | Αλφαριθμητικό |
| y | Αλφαριθμητικό/Δυαδικό |
Ας ελέγξουμε την ύπαρξη διπλότυπων τιμών και στην συνέχεια null τιμών ώστε να τις αφαιρέσουμε.
## [1] 0## [1] 0Βλέπουμε ότι δεν έχουμε ούτε κενές ούτε διπλότυπες τιμές στο σύνολο δεδομένων.
Διαγράμματα
Ας συνεχίσουμε με διαγράμματα για καλύτερη κατανόηση του συνόλου δεδομένων.
Διάγραμμα Κατανομής τιμής στόχου
Ας ξεκινήσουμε με το να δούμε τον διαχωρισμό της target μεταβλητής, y , ώστε να δούμε αν το σύνολο δεδομένων μας είναι imbalanced.
ggplot(df, aes(x = y)) +
geom_bar(fill = "steelblue") +
labs(title = "Κατανομή στόχου", x = "Subscribed (y)", y = "Πλήθος")
Σχόλια: Από το διάγραμμα βλέπουμε ότι η πλειονότητα των πελατών δεν υπέγραψαν προθεσμιακή κατάθεση (no), ενώ το ποσοστό των yes είναι πολύ μικρό σε σύγκριση. Αυτό σημαίνει ότι η κλάση που σε ενδιαφέρει (η θετική) είναι σπάνια.
Διάγραμμα Κατανομής ηλικίας
Ας δούμε την κατανομή της ηλικίας, ώστε να δούμε τυχόν ακραίες τιμές και την συχνότητα της κάθε ηλικίας.
ggplot(df, aes(x = age)) +
geom_histogram(binwidth = 5, fill = "skyblue", color = "black") +
labs(title = "Κατανομή ηλικίας πελατών", x = "Ηλικία", y = "Πλήθος")
Σχολια: Η κατανομή είναι ασύμμετρη — οι περισσότεροι πελάτες είναι μεταξύ 30 και 50 ετών. Υπάρχουν λίγοι πελάτες πάνω από 60–70, αλλά φτάνει μέχρι και ~90. Αυτό σημαίνει πως έχουμε μακριά ουρά. Δεν βλέπουμε περίεργες ακραίες τιμές — άρα δεν φαίνεται πρόβλημα ποιότητας δεδομένων. Η κορυφή είναι γύρω στα 35–40.
Διάγραμμα Σχέσης επαγγέλματος με συνδρομή κατάθεσης
Το γράφημα επαγγέλματος σε σχέση με το αν ο πελάτης συνάπτει κατάθεση μάς βοηθά να εντοπίσουμε ποιες επαγγελματικές ομάδες έχουν μεγαλύτερη ή μικρότερη πιθανότητα να απαντήσουν θετικά. Είναι σύνηθες, για παράδειγμα, φοιτητές ή συνταξιούχοι να έχουν διαφορετική συμπεριφορά σε σχέση με άλλες ομάδες. Αν κάποια κατηγορία εμφανίζει μηδενικά «ναι», αυτό μπορεί να δείχνει ότι χρειάζεται να συγχωνευτεί με άλλη ή να εξεταστεί ξεχωριστά, ώστε το μοντέλο να είναι πιο σταθερό και ακριβές.
ggplot(df, aes(x = job, fill = y)) +
geom_bar(position = "fill") +
labs(title = "Σχέση επαγγέλματος με συνδρομή κατάθεσης", x = "Επάγγελμα", y = "Ποσοστό") +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
Σχόλια: Το διάγραμμα δείχνει ξεκάθαρα ότι οι περισσότερες επαγγελματικές κατηγορίες έχουν χαμηλά ποσοστά θετικής απόκρισης (συνδρομή σε προθεσμιακή κατάθεση). Η πλειονότητα των πελατών σε όλες τις κατηγορίες απαντά «όχι». Ωστόσο, παρατηρούμε ότι συγκεκριμένες κατηγορίες, όπως οι retired και οι student, έχουν αισθητά υψηλότερο ποσοστό θετικών απαντήσεων σε σύγκριση με άλλες ομάδες, όπως οι blue-collar ή services. Αυτό υποδηλώνει ότι οι συνταξιούχοι και οι φοιτητές είναι πιο δεκτικοί στο προϊόν, πιθανώς λόγω διαφορετικών οικονομικών προτεραιοτήτων ή κινήτρων αποταμίευσης.Επίσης, φαίνεται ότι κάποιες επαγγελματικές κατηγορίες, όπως οι unknown ή οι housemaid, έχουν σχετικά λίγες παρατηρήσεις και μέτρια ποσοστά «ναι», κάτι που μπορεί να σημαίνει ότι αυτές οι κατηγορίες είτε χρειάζονται περισσότερη διερεύνηση είτε πιθανώς να συγχωνευτούν για στατιστικούς λόγους, ώστε να αποφευχθεί η υπερεκτίμηση ή υποεκτίμηση της σημασίας τους.
Διάγραμμα Υπολοίπου ανά κατηγορία στόχου
Το υπόλοιπο (balance) αντικατοπτρίζει την οικονομική κατάσταση του πελάτη και μπορεί να σχετίζεται άμεσα με την ικανότητα ή διάθεση για αποταμίευση. Μέσα από το boxplot μπορούμε να δούμε αν όσοι τελικά συνάπτουν προθεσμιακή κατάθεση έχουν κατά μέσο όρο μεγαλύτερα υπόλοιπα σε σχέση με όσους λένε «όχι». Αν προκύπτει τέτοια διαφορά, τότε το balance είναι ισχυρός προβλεπτικός παράγοντας. Παράλληλα, το boxplot βοηθά να εντοπιστούν ακραίες τιμές, οι οποίες μπορεί να επηρεάσουν την εκτίμηση του μοντέλου και να χρειάζονται ειδικό χειρισμό (π.χ. μετασχηματισμό ή αποκοπή).
ggplot(df, aes(x = y, y = balance, fill = y)) +
geom_boxplot() +
labs(title = "Υπόλοιπο ανά κατηγορία στόχου", x = "Subscribed (y)", y = "Υπόλοιπο (€)")
Σχόλια: Από το boxplot παρατηρούμε ότι οι πελάτες που τελικά συνάπτουν προθεσμιακή κατάθεση (yes) έχουν γενικά υψηλότερα υπόλοιπα σε σύγκριση με αυτούς που απαντούν αρνητικά (no). Αυτό δείχνει ότι το διαθέσιμο υπόλοιπο σχετίζεται θετικά με την πιθανότητα αποδοχής του προϊόντος. Παράλληλα, το διάγραμμα αποκαλύπτει την ύπαρξη αρκετών ακραίων τιμών (outliers) με πολύ υψηλά υπόλοιπα — κάτι που φαίνεται από τα πολλά σημεία πάνω από το ανώτατο όριο του boxplot.
Διάγραμμα Πλήθους επαφών και αποτελεσμάτων
Το διάγραμμα του Πλήθους επαφών και αποτελέσματος μάς βοηθά να εξετάσουμε αν ο αριθμός των επαφών που πραγματοποιείται σε κάθε πελάτη συνδέεται θετικά ή αρνητικά με την πιθανότητα επιτυχίας της καμπάνιας. Στόχος είναι να διαπιστώσουμε αν περισσότερες προσπάθειες πώλησης αυξάνουν το ποσοστό των θετικών απαντήσεων ή αν, αντίθετα, οι πολλαπλές κλήσεις λειτουργούν αποτρεπτικά και ενοχλούν τον πελάτη, μειώνοντας τελικά την πιθανότητα συνδρομής.
ggplot(df, aes(x = campaign, fill = y)) +
geom_histogram(binwidth = 1, position = "identity", alpha = 0.6) +
labs(title = "Πλήθος επαφών & αποτέλεσμα", x = "Campaign contacts", y = "Πλήθος")
Σχόλια: Το διάγραμμα δείχνει τη σχέση ανάμεσα στον αριθμό των επαφών που έγιναν σε κάθε πελάτη και στο τελικό αποτέλεσμα της καμπάνιας. Παρατηρούμε ότι η πλειονότητα των πελατών δέχεται πολύ λίγες επαφές, συνήθως 1–2 κλήσεις, και σε αυτές τις περιπτώσεις καταγράφεται το μεγαλύτερο ποσοστό θετικών απαντήσεων. Καθώς ο αριθμός επαφών αυξάνεται, βλέπουμε ότι το ποσοστό των «ναι» μειώνεται αισθητά — η πλειονότητα των επαφών με περισσότερες από 5–10 προσπάθειες καταλήγει σε «όχι». Αυτό δείχνει ότι οι επιπλέον προσπάθειες επικοινωνίας δεν αυξάνουν την πιθανότητα επιτυχίας, αλλά μάλλον λειτουργούν αντιστρόφως, πιθανόν λόγω ενόχλησης του πελάτη.Η κατανομή αυτή υπογραμμίζει ότι το campaign μπορεί να είναι σημαντικός αρνητικός δείκτης: οι πολλαπλές επαφές ίσως συνδέονται με χαμηλότερη πιθανότητα αποδοχής.
Λογιστική Παλινδρόμηση
Βήμα 1: Προετοιμασία Δεδομένων
Οι κατηγορικές μεταβλητές μετατρέπονται σε factor ώστε το λογιστικό μοντέλο (logistic regression) να μπορεί να τις χειριστεί σωστά ως διακριτές κατηγορίες. Αν μείνουν ως character, η R δεν τις αναγνωρίζει ως ονομαστικές αλλά ως απλές συμβολοσειρές, οπότε δεν δημιουργεί τις κατάλληλες ψευδομεταβλητές (dummy variables) που απαιτούνται για την εκτίμηση των συντελεστών κάθε επιπέδου. Ο καθορισμός τους ως factor εξασφαλίζει ότι το μοντέλο θα συγκρίνει σωστά τις επιμέρους ομάδες μεταξύ τους και θα εκτιμήσει τη συμβολή κάθε κατηγορίας στην πιθανότητα επιτυχίας. Έτσι, αποφεύγονται λανθασμένες εκτιμήσεις και διατηρείται η ερμηνευσιμότητα του μοντέλου.
df$job <- factor(df$job)
df$marital <- factor(df$marital)
df$education <- factor(df$education)
df$default <- factor(df$default)
df$housing <- factor(df$housing)
df$loan <- factor(df$loan)
df$contact <- factor(df$contact)
df$month <- factor(df$month)
df$poutcome <- factor(df$poutcome)
df$y <- factor(df$y)
summary(df)## age job marital education default
## Min. :19.00 management :969 divorced: 528 primary : 678 no :4445
## 1st Qu.:33.00 blue-collar:946 married :2797 secondary:2306 yes: 76
## Median :39.00 technician :768 single :1196 tertiary :1350
## Mean :41.17 admin. :478 unknown : 187
## 3rd Qu.:49.00 services :417
## Max. :87.00 retired :230
## (Other) :713
## balance housing loan contact day
## Min. :-3313 no :1962 no :3830 cellular :2896 Min. : 1.00
## 1st Qu.: 69 yes:2559 yes: 691 telephone: 301 1st Qu.: 9.00
## Median : 444 unknown :1324 Median :16.00
## Mean : 1423 Mean :15.92
## 3rd Qu.: 1480 3rd Qu.:21.00
## Max. :71188 Max. :31.00
##
## month duration campaign pdays
## may :1398 Min. : 4 Min. : 1.000 Min. : -1.00
## jul : 706 1st Qu.: 104 1st Qu.: 1.000 1st Qu.: -1.00
## aug : 633 Median : 185 Median : 2.000 Median : -1.00
## jun : 531 Mean : 264 Mean : 2.794 Mean : 39.77
## nov : 389 3rd Qu.: 329 3rd Qu.: 3.000 3rd Qu.: -1.00
## apr : 293 Max. :3025 Max. :50.000 Max. :871.00
## (Other): 571
## previous poutcome y
## Min. : 0.0000 failure: 490 no :4000
## 1st Qu.: 0.0000 other : 197 yes: 521
## Median : 0.0000 success: 129
## Mean : 0.5426 unknown:3705
## 3rd Qu.: 0.0000
## Max. :25.0000
## Ας υπολογίσουμε το μοντέλο βάσης.
##
## no yes
## 4000 521## 88.476Σχόλιο: Από τη στιγμή που οι περιπτώσεις της κλάσης y που ισούνται με no είναι πολύ περισσότερες από αυτές που ισούνται με yes, αν υποθέταμε ότι προβλέπουμε πάντα «όχι» για όλους τους πελάτες, τότε θα πετυχαίναμε ακρίβεια περίπου 88,5%. Συνεπώς, αυτό το ποσοστό αποτελεί το baseline του προβλήματος: είναι η ακρίβεια που πρέπει να ξεπεράσει το μοντέλο λογιστικής παλινδρόμησης για να θεωρηθεί ότι προσφέρει ουσιαστική βελτίωση και έχει πρακτική αξία.
Αφού βρούμε την ακρίβεια του μοντέλου βάσης, για την εκπαίδευση και αξιολόγηση του μοντέλου λογιστικής παλινδρόμησης, το αρχικό σύνολο δεδομένων διαχωρίζεται τυχαία σε δύο υποσύνολα: training set (75% των παρατηρήσεων) και testing set (25% των παρατηρήσεων). Ο διαχωρισμός πραγματοποιείται με χρήση της εντολής sample() και ορίζεται τιμή seed ίση με 930, ώστε τα αποτελέσματα να είναι αναπαραγώγιμα. Η επιλογή της συγκεκριμένης τιμής προκύπτει από τα δύο τελευταία ψηφία του ιδρυματικού email.
set.seed(930)
split <- sample.split(df$y,SplitRatio=0.75)
dfTrain = subset(df,split==TRUE)
dfTest = subset(df,split==FALSE)
cat("Train set:", nrow(dfTrain), "καταχωρήσεις\n")## Train set: 3391 καταχωρήσεις## Test set: 1130 καταχωρήσειςΒήμα 2: Δημιουργία μοντέλων λογιστικής παλινδρόμησης
Για να κατασκευάσουμε ένα αξιόπιστο μοντέλο λογιστικής παλινδρόμησης, ξεκινήσαμε με ανάλυση του πλήρους μοντέλου ώστε να εντοπίσουμε ποιες μεταβλητές εμφανίζουν στατιστική σημασία και ποια είναι η συνεισφορά τους στο διαχωρισμό της πιθανότητας για θετική απάντηση. Από το συνολικό μοντέλο προκύπτει ότι κάποιες μεταβλητές έχουν πολύ χαμηλή στατιστική σημασία, ενώ άλλες ξεχωρίζουν σταθερά με μικρά p-values(Pr(>|z|)) και ισχυρούς συντελεστές.
##
## Call:
## glm(formula = y ~ ., family = "binomial", data = dfTrain)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.194e+00 7.066e-01 -4.521 6.17e-06 ***
## age -1.674e-03 8.394e-03 -0.199 0.84195
## jobblue-collar -3.194e-01 2.844e-01 -1.123 0.26136
## jobentrepreneur -3.382e-01 4.499e-01 -0.752 0.45216
## jobhousemaid -7.450e-01 5.256e-01 -1.417 0.15635
## jobmanagement -1.461e-01 2.832e-01 -0.516 0.60599
## jobretired 6.837e-01 3.644e-01 1.876 0.06061 .
## jobself-employed -1.883e-01 4.138e-01 -0.455 0.64898
## jobservices -3.514e-01 3.331e-01 -1.055 0.29154
## jobstudent 4.205e-01 4.578e-01 0.918 0.35837
## jobtechnician -1.428e-01 2.706e-01 -0.528 0.59761
## jobunemployed -5.550e-01 4.663e-01 -1.190 0.23391
## jobunknown 5.456e-01 6.644e-01 0.821 0.41152
## maritalmarried -3.212e-01 2.097e-01 -1.531 0.12566
## maritalsingle -1.956e-01 2.454e-01 -0.797 0.42555
## educationsecondary 9.100e-02 2.342e-01 0.388 0.69766
## educationtertiary 4.222e-01 2.736e-01 1.543 0.12276
## educationunknown -2.560e-01 4.033e-01 -0.635 0.52560
## defaultyes 7.957e-01 4.609e-01 1.726 0.08428 .
## balance -8.707e-06 2.629e-05 -0.331 0.74048
## housingyes -1.527e-01 1.610e-01 -0.948 0.34304
## loanyes -5.605e-01 2.310e-01 -2.427 0.01524 *
## contacttelephone 4.087e-02 2.756e-01 0.148 0.88208
## contactunknown -1.281e+00 2.646e-01 -4.843 1.28e-06 ***
## day 1.944e-02 9.657e-03 2.013 0.04412 *
## monthaug -1.132e-01 2.956e-01 -0.383 0.70182
## monthdec 7.878e-01 9.664e-01 0.815 0.41497
## monthfeb 2.825e-01 3.543e-01 0.797 0.42531
## monthjan -9.001e-01 4.356e-01 -2.067 0.03878 *
## monthjul -7.653e-01 3.039e-01 -2.518 0.01179 *
## monthjun 5.468e-01 3.600e-01 1.519 0.12880
## monthmar 2.091e+00 4.559e-01 4.588 4.48e-06 ***
## monthmay -5.647e-01 2.841e-01 -1.988 0.04685 *
## monthnov -6.321e-01 3.235e-01 -1.954 0.05070 .
## monthoct 1.846e+00 3.843e-01 4.804 1.56e-06 ***
## monthsep 6.474e-01 4.649e-01 1.392 0.16377
## duration 4.543e-03 2.466e-04 18.421 < 2e-16 ***
## campaign -7.699e-02 3.253e-02 -2.366 0.01796 *
## pdays 6.133e-04 1.102e-03 0.557 0.57782
## previous -4.298e-02 4.674e-02 -0.919 0.35788
## poutcomeother 8.942e-01 3.166e-01 2.824 0.00474 **
## poutcomesuccess 2.887e+00 3.350e-01 8.619 < 2e-16 ***
## poutcomeunknown 4.753e-02 3.709e-01 0.128 0.89803
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 2424.3 on 3390 degrees of freedom
## Residual deviance: 1590.8 on 3348 degrees of freedom
## AIC: 1676.8
##
## Number of Fisher Scoring iterations: 6Ενδεικτικά, οι μεταβλητές που σχετίζονται με το είδος επικοινωνίας (contact), το αποτέλεσμα προηγούμενης επικοινωνίας (poutcome), οι μήνες επικοινωνίας (month), ο αριθμός επαφών στην τρέχουσα καμπάνια (campaign), η ύπαρξη προσωπικού δανείου (loan) και η ημέρα επαφής (day) εμφανίζουν σταθερά στατιστικά σημαντικούς συντελεστές στα περισσότερα μοντέλα. Επιπλέον, οι δημογραφικές μεταβλητές όπως το επάγγελμα (job) και η οικογενειακή κατάσταση (marital) προστέθηκαν στο τελευταίο μοντέλο, όχι γιατί είναι όλες ισχυρά στατιστικά σημαντικές, αλλά επειδή ενισχύουν την ερμηνευσιμότητα και δίνουν πληροφορία για ενδεχόμενες κοινωνικές τάσεις πίσω από την απόφαση αποταμίευσης.
##
## Call:
## glm(formula = y ~ contact + poutcome, family = "binomial", data = dfTrain)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.9728301 0.1615703 -12.210 < 2e-16 ***
## contacttelephone 0.0007923 0.2069793 0.004 0.99695
## contactunknown -1.1469587 0.1727228 -6.640 3.13e-11 ***
## poutcomeother 0.8068015 0.2560907 3.150 0.00163 **
## poutcomesuccess 2.5498866 0.2695853 9.459 < 2e-16 ***
## poutcomeunknown -0.0242349 0.1765019 -0.137 0.89079
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 2424.3 on 3390 degrees of freedom
## Residual deviance: 2196.1 on 3385 degrees of freedom
## AIC: 2208.1
##
## Number of Fisher Scoring iterations: 5model2 <- glm(y ~ contact + poutcome + month + campaign, data = dfTrain, family = "binomial")
summary(model2)##
## Call:
## glm(formula = y ~ contact + poutcome + month + campaign, family = "binomial",
## data = dfTrain)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.72662 0.23713 -7.281 3.30e-13 ***
## contacttelephone -0.02037 0.21882 -0.093 0.925826
## contactunknown -1.27417 0.22512 -5.660 1.51e-08 ***
## poutcomeother 0.84712 0.26710 3.172 0.001516 **
## poutcomesuccess 2.44546 0.28256 8.655 < 2e-16 ***
## poutcomeunknown 0.08266 0.18990 0.435 0.663363
## monthaug -0.10165 0.24006 -0.423 0.671982
## monthdec 0.65796 0.79040 0.832 0.405163
## monthfeb 0.09026 0.28433 0.317 0.750906
## monthjan -0.62593 0.36098 -1.734 0.082926 .
## monthjul -0.60836 0.25650 -2.372 0.017705 *
## monthjun 0.45281 0.29602 1.530 0.126097
## monthmar 1.48981 0.40844 3.648 0.000265 ***
## monthmay -0.54565 0.23934 -2.280 0.022621 *
## monthnov -0.50403 0.27220 -1.852 0.064073 .
## monthoct 1.62162 0.33259 4.876 1.08e-06 ***
## monthsep 0.45669 0.40771 1.120 0.262661
## campaign -0.05775 0.02671 -2.162 0.030581 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 2424.3 on 3390 degrees of freedom
## Residual deviance: 2091.4 on 3373 degrees of freedom
## AIC: 2127.4
##
## Number of Fisher Scoring iterations: 6model3 <- glm(y ~ contact + poutcome + month + campaign + loan + day, data = dfTrain, family = "binomial")
summary(model3)##
## Call:
## glm(formula = y ~ contact + poutcome + month + campaign + loan +
## day, family = "binomial", data = dfTrain)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.929006 0.274737 -7.021 2.20e-12 ***
## contacttelephone -0.043931 0.218132 -0.201 0.840389
## contactunknown -1.292403 0.226820 -5.698 1.21e-08 ***
## poutcomeother 0.864051 0.268161 3.222 0.001272 **
## poutcomesuccess 2.443159 0.283948 8.604 < 2e-16 ***
## poutcomeunknown 0.081263 0.190763 0.426 0.670116
## monthaug -0.058183 0.242153 -0.240 0.810117
## monthdec 0.610692 0.796131 0.767 0.443037
## monthfeb 0.263207 0.300649 0.875 0.381324
## monthjan -0.763572 0.369872 -2.064 0.038978 *
## monthjul -0.534009 0.258778 -2.064 0.039058 *
## monthjun 0.562069 0.305198 1.842 0.065526 .
## monthmar 1.519267 0.409533 3.710 0.000207 ***
## monthmay -0.482010 0.243566 -1.979 0.047819 *
## monthnov -0.470717 0.273411 -1.722 0.085133 .
## monthoct 1.602225 0.334475 4.790 1.67e-06 ***
## monthsep 0.502757 0.408839 1.230 0.218802
## campaign -0.066770 0.027539 -2.425 0.015328 *
## loanyes -0.502231 0.198393 -2.531 0.011358 *
## day 0.015135 0.008285 1.827 0.067708 .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 2424.3 on 3390 degrees of freedom
## Residual deviance: 2080.6 on 3371 degrees of freedom
## AIC: 2120.6
##
## Number of Fisher Scoring iterations: 6model4 <- glm(y ~ contact + poutcome + month + campaign + loan + day + job + marital, data = dfTrain, family = "binomial")
summary(model4)##
## Call:
## glm(formula = y ~ contact + poutcome + month + campaign + loan +
## day + job + marital, family = "binomial", data = dfTrain)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.738003 0.357336 -4.864 1.15e-06 ***
## contacttelephone -0.082319 0.226285 -0.364 0.716019
## contactunknown -1.213284 0.229393 -5.289 1.23e-07 ***
## poutcomeother 0.898361 0.270790 3.318 0.000908 ***
## poutcomesuccess 2.536812 0.288551 8.792 < 2e-16 ***
## poutcomeunknown 0.102176 0.192793 0.530 0.596126
## monthaug -0.100118 0.249891 -0.401 0.688681
## monthdec 0.580229 0.814852 0.712 0.476423
## monthfeb 0.176633 0.305711 0.578 0.563415
## monthjan -0.836106 0.377526 -2.215 0.026781 *
## monthjul -0.581719 0.262970 -2.212 0.026959 *
## monthjun 0.468059 0.309543 1.512 0.130510
## monthmar 1.387373 0.419767 3.305 0.000949 ***
## monthmay -0.522080 0.246717 -2.116 0.034335 *
## monthnov -0.489371 0.278386 -1.758 0.078767 .
## monthoct 1.491053 0.341418 4.367 1.26e-05 ***
## monthsep 0.336803 0.417204 0.807 0.419501
## campaign -0.061430 0.027390 -2.243 0.024908 *
## loanyes -0.482424 0.199800 -2.415 0.015755 *
## day 0.014266 0.008369 1.705 0.088272 .
## jobblue-collar -0.037618 0.238375 -0.158 0.874605
## jobentrepreneur 0.302550 0.366625 0.825 0.409241
## jobhousemaid -0.152237 0.439081 -0.347 0.728805
## jobmanagement 0.153248 0.220783 0.694 0.487612
## jobretired 0.845009 0.279000 3.029 0.002456 **
## jobself-employed 0.313686 0.336985 0.931 0.351926
## jobservices -0.039261 0.285093 -0.138 0.890468
## jobstudent 0.284221 0.405288 0.701 0.483128
## jobtechnician -0.028482 0.234786 -0.121 0.903444
## jobunemployed -0.131574 0.394054 -0.334 0.738456
## jobunknown 0.426473 0.549006 0.777 0.437271
## maritalmarried -0.439741 0.181003 -2.429 0.015121 *
## maritalsingle -0.082445 0.197280 -0.418 0.676013
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 2424.3 on 3390 degrees of freedom
## Residual deviance: 2055.1 on 3358 degrees of freedom
## AIC: 2121.1
##
## Number of Fisher Scoring iterations: 6Η σταδιακή προσθήκη μεταβλητών γίνεται ώστε να παρακολουθούμε πώς επηρεάζεται το AIC και η συνολική προσαρμογή. Όπως δείχνουν τα αποτελέσματα, η τιμή του AIC μειώνεται από το πρώτο προς το τρίτο μοντέλο, γεγονός που επιβεβαιώνει ότι κάθε βήμα βελτιώνει την εφαρμογή του μοντέλου στα δεδομένα. Στο τέταρτο μοντέλο παρατηρείται ελαφρά αύξηση του AIC, γεγονός που υποδηλώνει ότι η προσθήκη πολλών δημογραφικών μεταβλητών αυξάνει την πολυπλοκότητα χωρίς αντίστοιχη βελτίωση στην απόδοση. Αυτό δείχνει τη σημασία της ισορροπίας ανάμεσα στην πολυπλοκότητα και στη στατιστική ισχύ.
Εφαρμογή σε δεδομένα
Συνεχίζουμε με τις προβλέψεις και το κατώφλι.Το κατώφλι ορίζει το σημείο πάνω από το οποίο το μοντέλο χαρακτηρίζει μια παρατήρηση ως «ναι». Το προεπιλεγμένο κατώφλι στη δυαδική λογιστική παλινδρόμηση είναι 0.5, όμως όταν τα δεδομένα είναι ανισόρροπα και η θετική κλάση είναι σπάνια, ένα τόσο υψηλό όριο οδηγεί σχεδόν πάντα σε αποτυχία ανίχνευσης των λίγων θετικών περιπτώσεων. Επιλέγοντας χαμηλότερο κατώφλι, όπως 0.3, δίνουμε στο μοντέλο περισσότερες ευκαιρίες να προβλέψει «ναι» και να αυξήσει την ευαισθησία του (recall), θυσιάζοντας λίγη από την ακρίβεια της αρνητικής κλάσης. Το χαμηλότερο όριο είναι πρακτική επιλογή για να βρούμε καλύτερη ισορροπία μεταξύ ψευδώς αρνητικών και ψευδώς θετικών προβλέψεων, ειδικά όταν μας ενδιαφέρει περισσότερο να εντοπίσουμε όσο το δυνατόν περισσότερους πελάτες που μπορεί να ενδιαφέρονται.
# Υπολόγισε πιθανότητες
prob1 <- predict(model1, newdata = dfTest, type = "response")
prob2 <- predict(model2, newdata = dfTest, type = "response")
prob3 <- predict(model3, newdata = dfTest, type = "response")
prob4 <- predict(model4, newdata = dfTest, type = "response")
# Κλάση με threshold 0.3
pred1 <- ifelse(prob1 >= 0.3, 1, 0)
pred2 <- ifelse(prob2 >= 0.3, 1, 0)
pred3 <- ifelse(prob3 >= 0.3, 1, 0)
pred4 <- ifelse(prob4 >= 0.3, 1, 0)Επίσης υπολογίζουμε accuracy και AIC των μοντέλων μας.
dfTest$y_num <- ifelse(dfTest$y == "yes", 1, 0)
acc1 <- mean(pred1 == dfTest$y_num)
acc2 <- mean(pred2 == dfTest$y_num)
acc3 <- mean(pred3 == dfTest$y_num)
acc4 <- mean(pred4 == dfTest$y_num)
aic1 <- AIC(model1)
aic2 <- AIC(model2)
aic3 <- AIC(model3)
aic4 <- AIC(model4)Το confusion matrix μας δείχνει πόσο καλά ταξινομεί το μοντέλο τις παρατηρήσεις σε σωστές και λάθος κατηγορίες. Μέσα από αυτή βλέπουμε πόσες θετικές περιπτώσεις προβλέφθηκαν σωστά, πόσες χάθηκαν και πόσα ψευδώς θετικά ή αρνητικά προκύπτουν. Είναι πολύ σημαντικό εργαλείο για να καταλάβουμε αν το μοντέλο κάνει σωστά τη διάκριση ανάμεσα στις δύο κατηγορίες, ειδικά όταν υπάρχει έντονη ανισορροπία στις κλάσεις όπως εδώ. Το απλό ποσοστό ακρίβειας από μόνο του δεν αρκεί γιατί μπορεί να κρύβει μεγάλες αστοχίες στην πρόβλεψη των σπάνιων «ναι».
# Confusion Matrices
cm1 <- table(Predicted = pred1, Actual = dfTest$y)
cm2 <- table(Predicted = pred2, Actual = dfTest$y)
cm3 <- table(Predicted = pred3, Actual = dfTest$y)
cm4 <- table(Predicted = pred4, Actual = dfTest$y)
print("Confusion Matrix Model 1")## [1] "Confusion Matrix Model 1"## Actual
## Predicted no yes
## 0 988 106
## 1 12 24## [1] "Confusion Matrix Model 2"## Actual
## Predicted no yes
## 0 964 96
## 1 36 34## [1] "Confusion Matrix Model 3"## Actual
## Predicted no yes
## 0 963 96
## 1 37 34## [1] "Confusion Matrix Model 4"## Actual
## Predicted no yes
## 0 963 93
## 1 37 37Οι πίνακες δείχνουν ότι τα μοντέλα καταφέρνουν να ταξινομήσουν σωστά το μεγαλύτερο μέρος των «όχι», αλλά δυσκολεύονται να αναγνωρίσουν τα «ναι». Παρά τις βελτιώσεις από μοντέλο σε μοντέλο, η πλειονότητα των θετικών περιπτώσεων χάνεται καθώς οι ψευδώς αρνητικές παραμένουν πολλές. Η αύξηση των true positives από το Model 1 έως το Model 4 δείχνει ότι η προσθήκη μεταβλητών βελτιώνει λίγο την ευαισθησία, αλλά το πρόβλημα ανισορροπίας παραμένει.
Ο μέσος όρος των πιθανοτήτων που δίνει το μοντέλο για κάθε πραγματική κατηγορία δείχνει αν το μοντέλο όντως διαχωρίζει τις ομάδες. Αν οι μέσες πιθανότητες για τα «ναι» είναι σαφώς υψηλότερες από τα «όχι», το μοντέλο έχει μάθει να ξεχωρίζει τις δύο ομάδες έστω και αν στην τελική ταξινόμηση κάποια «ναι» χάνονται λόγω του ορίου.
## Model 1 - Mean Prob by Actual:## no yes
## 0.1095105 0.2097728## Model 2 - Mean Prob by Actual:## no yes
## 0.1068928 0.2377768## Model 3 - Mean Prob by Actual:## no yes
## 0.1069763 0.2422977## Model 4 - Mean Prob by Actual:## no yes
## 0.1068268 0.2560728Οι μέσες πιθανότητες δείχνουν ότι το μοντέλο δίνει μεγαλύτερες τιμές στα «ναι» σε σχέση με τα «όχι», κάτι που σημαίνει ότι εντοπίζει το σήμα. Παρατηρείται ότι όσο προσθέτουμε μεταβλητές, η μέση πιθανότητα για τα «ναι» ανεβαίνει σταθερά, γεγονός που επιβεβαιώνει ότι οι έξτρα μεταβλητές προσφέρουν διαχωριστική πληροφορία. Ωστόσο, οι τιμές παραμένουν χαμηλές, κάτι που σημαίνει ότι το μοντέλο είναι συντηρητικό και πολλές φορές δεν περνά το όριο ταξινόμησης.
Ας συγκρίνουμε τα μοντέλα
comparison <- data.frame(
Μοντέλο = c("Baseline", "Model 1", "Model 2", "Model 3", "Model 4"),
AIC = c(NA, aic1, aic2, aic3, aic4),
Accuracy = round(c(baseacc, acc1, acc2, acc3, acc4) * 100, 2)
)
print(comparison)## Μοντέλο AIC Accuracy
## 1 Baseline NA 88.48
## 2 Model 1 2208.116 89.56
## 3 Model 2 2127.377 88.32
## 4 Model 3 2120.619 88.23
## 5 Model 4 2121.133 88.50Τελικά συμπεράσματα
Ο πίνακας δείχνει ότι το AIC μειώνεται καθώς προστίθενται μεταβλητές, κάτι που σημαίνει ότι τα μοντέλα γίνονται πιο ικανά να περιγράψουν τα δεδομένα. Ωστόσο, η συνολική ακρίβεια δεν βελτιώνεται σημαντικά γιατί τα δεδομένα κυριαρχούνται από την κατηγορία «όχι», που έτσι κι αλλιώς προβλέπεται σωστά. Αυτό υποδεικνύει ότι οι νέες μεταβλητές όντως περιέχουν πληροφορία, αλλά το όριο ταξινόμησης ίσως χρειάζεται αναπροσαρμογή ή επιπλέον τεχνικές όπως αναδειγματοληψία για να βελτιωθεί η πρόβλεψη των θετικών περιπτώσεων. Επομένως, καλύτερο μοντέλο σύμφωνα με όλους τους δείκτες φαίνεται να είναι τελικά το 4ο, καθώς έχει το μεγαλύτερο accuracy, αν και με μικρή διαφορά, και παρόλο την πολύ μικρή αύξηση του δείκτη ΑΙC, από το προηγούμενο μοντέλο, έχει την καλύτερη διαχωριστικότητα στις κλάσεις όπως φάνηκε με το tapply και περισσότερες σωστές προβλέψεις για την κλάση της μειονότητας όπως φάνηκε από τον πίνακα σύγχυσης.