# ============================================================
# LAB 010 — Random Forests & Gradient Boosting
# Dataset: Breast Cancer (Wisconsin)
# Στόχος: Πρόβλεψη κακοήθειας από κυτταρολογικά χαρακτηριστικά
# ============================================================
# --- Φόρτωση πακέτων ---
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.2.0 ✔ readr 2.2.0
## ✔ forcats 1.0.1 ✔ stringr 1.6.0
## ✔ ggplot2 4.0.2 ✔ tibble 3.3.1
## ✔ lubridate 1.9.5 ✔ tidyr 1.3.2
## ✔ purrr 1.2.1
## ── 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 errors
library(mlbench)
## Warning: package 'mlbench' was built under R version 4.5.3
library(randomForest)
## Warning: package 'randomForest' was built under R version 4.5.3
## randomForest 4.7-1.2
## Type rfNews() to see new features/changes/bug fixes.
##
## Attaching package: 'randomForest'
##
## The following object is masked from 'package:dplyr':
##
## combine
##
## The following object is masked from 'package:ggplot2':
##
## margin
library(xgboost)
## Warning: package 'xgboost' was built under R version 4.5.3
library(caret)
## Warning: package 'caret' was built under R version 4.5.3
## Loading required package: lattice
##
## Attaching package: 'caret'
##
## The following object is masked from 'package:purrr':
##
## lift
library(pROC)
## Warning: package 'pROC' was built under R version 4.5.3
## Type 'citation("pROC")' for a citation.
##
## Attaching package: 'pROC'
##
## The following objects are masked from 'package:stats':
##
## cov, smooth, var
set.seed(42)
# --- Φόρτωση δεδομένων ---
data("BreastCancer", package = "mlbench")
bc <- BreastCancer
# Καθαρισμός: αφαίρεση ID, χειρισμός missing, μετατροπή σε numeric
bc$Id <- NULL
bc <- na.omit(bc)
bc[, 1:9] <- lapply(bc[, 1:9], function(x) as.numeric(as.character(x)))
str(bc)
## 'data.frame': 683 obs. of 10 variables:
## $ Cl.thickness : num 5 5 3 6 4 8 1 2 2 4 ...
## $ Cell.size : num 1 4 1 8 1 10 1 1 1 2 ...
## $ Cell.shape : num 1 4 1 8 1 10 1 2 1 1 ...
## $ Marg.adhesion : num 1 5 1 1 3 8 1 1 1 1 ...
## $ Epith.c.size : num 2 7 2 3 2 7 2 2 2 2 ...
## $ Bare.nuclei : num 1 10 2 4 1 10 10 1 1 1 ...
## $ Bl.cromatin : num 3 3 3 3 3 9 3 3 1 2 ...
## $ Normal.nucleoli: num 1 2 1 7 1 7 1 1 1 1 ...
## $ Mitoses : num 1 1 1 1 1 1 1 1 5 1 ...
## $ Class : Factor w/ 2 levels "benign","malignant": 1 1 1 1 1 2 1 1 1 1 ...
## - attr(*, "na.action")= 'omit' Named int [1:16] 24 41 140 146 159 165 236 250 276 293 ...
## ..- attr(*, "names")= chr [1:16] "24" "41" "140" "146" ...
table(bc$Class)
##
## benign malignant
## 444 239
#ola ta view etc...
head(bc)
## Cl.thickness Cell.size Cell.shape Marg.adhesion Epith.c.size Bare.nuclei
## 1 5 1 1 1 2 1
## 2 5 4 4 5 7 10
## 3 3 1 1 1 2 2
## 4 6 8 8 1 3 4
## 5 4 1 1 3 2 1
## 6 8 10 10 8 7 10
## Bl.cromatin Normal.nucleoli Mitoses Class
## 1 3 1 1 benign
## 2 3 2 1 benign
## 3 3 1 1 benign
## 4 3 7 1 benign
## 5 3 1 1 benign
## 6 9 7 1 malignant
View(BreastCancer)
============================================================
============================================================
set.seed(42)
train_rf <- createDataPartition(bc$Class, p = 0.7, list = FALSE)
train <- bc[train_rf, ]
test <- bc[-train_rf, ]
prop.table(table(train$Class)) %>% round(3)
##
## benign malignant
## 0.649 0.351
prop.table(table(test$Class)) %>% round(3)
##
## benign malignant
## 0.652 0.348
set.seed(42)
rf_model <- randomForest(
Class ~ ., # Όλα τα features
data = train,
ntree = 500, # Αριθμός δέντρων
importance = TRUE # Για να πάρουμε variable importance
)
print(rf_model)
##
## Call:
## randomForest(formula = Class ~ ., data = train, ntree = 500, importance = TRUE)
## Type of random forest: classification
## Number of trees: 500
## No. of variables tried at each split: 3
##
## OOB estimate of error rate: 3.76%
## Confusion matrix:
## benign malignant class.error
## benign 301 10 0.03215434
## malignant 8 160 0.04761905
Από το confusion matrix μπορούμε να παρατηρήσουμε ότι:
301 benign όγκοι ταξινομήθηκαν σωστά ως benign.
10 benign περιπτώσεις ταξινομήθηκαν λάθος ως malignant.
160 malignant περιπτώσεις ταξινομήθηκαν σωστά.
8 malignant περιπτώσεις ταξινομήθηκαν λανθασμένα ως benign
Επίσης, έχουμε περίπου 3.2% λάθος στους καλοηθείς όγκους και περίπου 4.8% λάθος στους κακοηθείς. Το μοντέλο κάνει ελάχιστα λάθη, έχει πολύ υψηλή ακρίβεια και αναγνωρίζει σωστά σχεδόν όλες τις περιπτώσεις με σοβαρότερα λάθη τα 8 false negative.
rf_pred <- predict(rf_model, test)
rf_prob <- predict(rf_model, test, type = "prob")[, "malignant"]
# Confusion Matrix
rf_cm <- confusionMatrix(rf_pred, test$Class, positive = "malignant")
print(rf_cm)
## Confusion Matrix and Statistics
##
## Reference
## Prediction benign malignant
## benign 131 2
## malignant 2 69
##
## Accuracy : 0.9804
## 95% CI : (0.9506, 0.9946)
## No Information Rate : 0.652
## P-Value [Acc > NIR] : <2e-16
##
## Kappa : 0.9568
##
## Mcnemar's Test P-Value : 1
##
## Sensitivity : 0.9718
## Specificity : 0.9850
## Pos Pred Value : 0.9718
## Neg Pred Value : 0.9850
## Prevalence : 0.3480
## Detection Rate : 0.3382
## Detection Prevalence : 0.3480
## Balanced Accuracy : 0.9784
##
## 'Positive' Class : malignant
##
# AUC
rf_auc <- roc(test$Class, rf_prob, levels = c("benign", "malignant"))$auc
## Setting direction: controls < cases
cat("RF AUC:", round(rf_auc, 3), "\n")
## RF AUC: 0.999
To μοντέλο έχει ακρίβεια = 98%, ευαισθησία = 97% και AUC = 99%. Πρακτικά πολύ κοντά σε ένα τέλειο μοντέλο, το οποίο όμως είναι αναμενόμενο για εξετάσεις προβλημάτων υγείας.
plot(rf_model, main = "OOB Error vs Number of Trees")
legend("topright", colnames(rf_model$err.rate), col = 1:3, lty = 1:3)
varImpPlot(rf_model, main = "Variable Importance — Random Forest")
importance(rf_model)
## benign malignant MeanDecreaseAccuracy MeanDecreaseGini
## Cl.thickness 12.702656 19.830096 19.363837 11.845927
## Cell.size 11.605774 16.330563 19.826188 60.344346
## Cell.shape 10.417048 20.502944 21.800283 53.561147
## Marg.adhesion 6.228395 12.425305 13.009741 5.977215
## Epith.c.size 10.510480 3.579421 11.128863 11.709247
## Bare.nuclei 20.271034 19.036320 26.035566 34.154820
## Bl.cromatin 6.086543 14.621620 14.691182 14.587449
## Normal.nucleoli 11.849778 11.676750 15.229482 23.815034
## Mitoses 4.984157 0.839361 4.608274 1.550928
Σύμφωνα με τα αποτελέσματα του πίνακα, οι 3 σημαντικότερες κατηγορίες, βασισμένες στο
MeanDecreaseAccuracy & MeanDecreaseGini
είναι οι
| Bare.nuclei | 26.04 |
| Cell.shape | 21.80 |
| Cell.size | 19.83 |
Επεξήγηση: Η μορφή των “γυμνών πυρήνων” (bare.nuclei) βοηθά περισσότερο στον διαχωρισμό καλοηθών και κακοηθών καταστάσεων. Το σχήμα /παραμόρφωση των κυττάρων (cell.shape) αποτελεί ισχυρό δείκτη κακοήθειας. Το μέγεθος (cell.size) είναι επίσης πολύ σημαντικός παράγοντας εντοπισμού κακοηθή όγκου.
============================================================
============================================================
# Μετατροπή σε numeric matrix
train_x <- data.matrix(train[, -10]) # χωρίς τη στήλη class giati den einai numeric
train_y <- ifelse(train$Class == "malignant", 1, 0)
test_x <- data.matrix(test[, -10])
test_y <- ifelse(test$Class == "malignant", 1, 0)
#xgbm
# Δημιουργία xgb.DMatrix (το optimized format του XGBoost)
dtrain <- xgb.DMatrix(data = train_x, label = train_y)
dtest <- xgb.DMatrix(data = test_x, label = test_y)
set.seed(42)
params <- list(
objective = "binary:logistic",
eval_metric = "auc",
max_depth = 4,
eta = 0.1, # learning rate
subsample = 0.8,
colsample_bytree = 0.8
)
xgb_model <- xgb.train(
params = params,
data = dtrain,
nrounds = 500,
watchlist = list(train = dtrain, test = dtest),
early_stopping_rounds = 20,
print_every_n = 25,
verbose = 1
)
## Warning in throw_err_or_depr_msg("Parameter '", match_old, "' has been renamed
## to '", : Parameter 'watchlist' has been renamed to 'evals'. This warning will
## become an error in a future version.
## Multiple eval metrics are present. Will use test_auc for early stopping.
## Will train until test_auc hasn't improved in 20 rounds.
##
## [1] train-auc:0.977109 test-auc:0.967489
## [26] train-auc:0.997722 test-auc:0.995446
## [51] train-auc:0.999541 test-auc:0.997458
## [76] train-auc:0.999847 test-auc:0.997564
## Stopping. Best iteration:
## [95] train-auc:0.999923 test-auc:0.997458
##
## [95] train-auc:0.999923 test-auc:0.997458
To μοντέλο με early stopping μας έβγαλε μέγιστο αποτέλεσμα περίπου κοντά στο 99.99%.
Stopping. Best iteration: [95] train-auc:0.999923 test-auc:0.997458 [95] train-auc:0.999923 test-auc:0.997458
xgb_prob <- predict(xgb_model, dtest)
xgb_pred <- factor(ifelse(xgb_prob > 0.5, "malignant", "benign"),
levels = c("benign", "malignant"))
xgb_cm <- confusionMatrix(xgb_pred, test$Class, positive = "malignant")
print(xgb_cm)
## Confusion Matrix and Statistics
##
## Reference
## Prediction benign malignant
## benign 131 3
## malignant 2 68
##
## Accuracy : 0.9755
## 95% CI : (0.9437, 0.992)
## No Information Rate : 0.652
## P-Value [Acc > NIR] : <2e-16
##
## Kappa : 0.9458
##
## Mcnemar's Test P-Value : 1
##
## Sensitivity : 0.9577
## Specificity : 0.9850
## Pos Pred Value : 0.9714
## Neg Pred Value : 0.9776
## Prevalence : 0.3480
## Detection Rate : 0.3333
## Detection Prevalence : 0.3431
## Balanced Accuracy : 0.9714
##
## 'Positive' Class : malignant
##
xgb_auc <- roc(test$Class, xgb_prob, levels = c("benign", "malignant"))$auc
## Setting direction: controls < cases
cat("XGBoost AUC:", round(xgb_auc, 3), "\n")
## XGBoost AUC: 0.998
imp_xgb <- xgb.importance(model = xgb_model)
print(imp_xgb)
## Feature Gain Cover Frequency
## <char> <num> <num> <num>
## 1: Cell.shape 0.41314930 0.17212968 0.10379242
## 2: Cell.size 0.26421488 0.14343242 0.09580838
## 3: Bare.nuclei 0.12418836 0.20984672 0.17964072
## 4: Cl.thickness 0.04996820 0.10978109 0.13772455
## 5: Normal.nucleoli 0.04993893 0.11101276 0.13972056
## 6: Bl.cromatin 0.04290336 0.10546435 0.08782435
## 7: Marg.adhesion 0.03863542 0.09280645 0.16566866
## 8: Epith.c.size 0.01144765 0.03618452 0.06986028
## 9: Mitoses 0.00555390 0.01934201 0.01996008
xgb.plot.importance(imp_xgb, top_n = 8,
main = "Feature Importance — XGBoost")
Σε αυτό το διάγραμμα βλέπουμε ότι το cell.shape είναι πολύ πιο σημαντικό από τις άλλες δύο μεταβλητές, που αν και ίδιες με αυτές που βρήκαμε πριν, τώρα έχουν αντιστραφεί οι δείκτες σημαντικότητας.
results <- data.frame(
Model = c("Random Forest", "XGBoost"),
Accuracy = c(
rf_cm$overall["Accuracy"],
xgb_cm$overall["Accuracy"]
),
Sensitivity = c(
rf_cm$byClass["Sensitivity"],
xgb_cm$byClass["Sensitivity"]
),
Specificity = c(
rf_cm$byClass["Specificity"],
xgb_cm$byClass["Specificity"]
),
F1 = c(
rf_cm$byClass["F1"],
xgb_cm$byClass["F1"]
),
AUC = c(rf_auc, xgb_auc)
)
results <- results %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
print(results)
## Model Accuracy Sensitivity Specificity F1 AUC
## 1 Random Forest 0.980 0.972 0.985 0.972 0.999
## 2 XGBoost 0.975 0.958 0.985 0.965 0.998
Αυτό το μοντέλο, το XGBoost, έχει ακρίβεια = 97%, ευαισθησία = 95% και AUC = 99%. Πάλι καλό αλλά όχι όσο το προηγούμενο.
Σε τελική ανάλυση, παρατηρούμε ότι το RF παρουσίασε καλύτερες μετρικές από το XGBoost που αν και πολυ μικρές σε διαφορά, είναι απαραίτητες σε ιατρικές καταστάσεις.
============================================================
============================================================
set.seed(42)
params1 <- list(
objective = "binary:logistic",
eval_metric = "auc",
max_depth = 4,
eta = 0.01,
subsample = 0.8,
colsample_bytree = 0.8
)
xgb_model1 <- xgb.train(
params = params1,
data = dtrain,
nrounds = 500,
watchlist = list(train = dtrain, test = dtest),
early_stopping_rounds = 20,
verbose = 0
)
## Warning in throw_err_or_depr_msg("Parameter '", match_old, "' has been renamed
## to '", : Parameter 'watchlist' has been renamed to 'evals'. This warning will
## become an error in a future version.
set.seed(42)
params2 <- list(
objective = "binary:logistic",
eval_metric = "auc",
max_depth = 4,
eta = 0.3,
subsample = 0.8,
colsample_bytree = 0.8
)
xgb_model2 <- xgb.train(
params = params2,
data = dtrain,
nrounds = 500,
watchlist = list(train = dtrain, test = dtest),
early_stopping_rounds = 20,
verbose = 0
)
## Warning in throw_err_or_depr_msg("Parameter '", match_old, "' has been renamed
## to '", : Parameter 'watchlist' has been renamed to 'evals'. This warning will
## become an error in a future version.
Παρατηρήθηκε ότι η τιμή του eta επηρεάζει σημαντικά τον αριθμό boosting rounds που απαιτούνται για την εκπαίδευση του μοντέλου. Με μικρό learning rate (eta = 0.01), το μοντέλο μάθαινε πιο αργά και χρειάστηκε περισσότερους γύρους μέχρι να σταθεροποιηθεί η απόδοσή του. Αντίθετα, με μεγαλύτερο learning rate (eta = 0.3), η σύγκλιση πραγματοποιήθηκε γρηγορότερα και το training ολοκληρώθηκε σε λιγότερους γύρους.
Αυτό συμβαίνει επειδή το μεγαλύτερο eta επιτρέπει στο μοντέλο να κάνει μεγαλύτερες διορθώσεις σε κάθε boosting step.
prob1 <- predict(xgb_model1, dtest)
prob2 <- predict(xgb_model2, dtest)
auc1 <- roc(test$Class, prob1,
levels = c("benign", "malignant"))$auc
## Setting direction: controls < cases
auc2 <- roc(test$Class, prob2,
levels = c("benign", "malignant"))$auc
## Setting direction: controls < cases
auc1
## Area under the curve: 0.9964
auc2
## Area under the curve: 0.9963
Το μοντέλο - παραλλαγή 1 με eta = 0.01 είναι καλύτερο από το 2 (eta = 0.3) κατά 0.0001 βαθμούς.
roc_rf <- roc(test$Class, rf_prob, levels = c("benign", "malignant"))
## Setting direction: controls < cases
roc_xgb <- roc(test$Class, xgb_prob, levels = c("benign", "malignant"))
## Setting direction: controls < cases
plot(roc_rf, col = "purple", lwd = 2, main = "ROC Curves Comparison")
lines(roc_xgb, col = "yellow", lwd = 2)
legend("bottomright",
legend = c(paste0("RF (AUC = ", round(rf_auc, 3), ")"),
paste0("XGB (AUC = ", round(xgb_auc, 3), ")")
),
col = c("purple", "yellow"),
lwd = 2)
Το ROC curve εμφανίζεται σχεδόν κάθετο λόγω του ότι τα AUC και από τα δύο μοντέλα είναι σχεδόν τέλεια, κοντά στο 100%, με το AUC του RF να υπερισχύει κατά 0.001 βαθμούς. Οι ROC καμπύλες βρίσκονται πολύ κοντά στο άνω αριστερό άκρο του διαγράμματος, γεγονός που υποδηλώνει σχεδον τέλειο διαχωρισμό μεταξύ των δύο κατηγοριών του dataset.
Accuracy : 0.9804
είχαμε top features τα bar.nuclei, cell.shape, cell.size με αυτή την σειρά ακριβώς.
Αν και Accuracy = 97% είναι πολύ καλό για ένα μοντέλο, όταν εξετάζουμε προβλήματα υγείας και ειδικά κακοηθείς περιπτώσεις όπως μπορεί να εξελιχθούν οι όγκοι, περιμένουμε ένα κάπως καλύτερο accuracy.
Παρόλα αυτά, η ακρίβεια δεν είναι το μόνο που επηρεάζει την ανίχνευση των αποτελεσμάτων, οπότε δεν μπορούμε να στηριχτούμε μόνο σε αυτό.
Το καλύτερο μοντέλο ήταν το Random Forest με μικρή διαφορά RF area under the curve: 0.9964 & XGBoost area under the curve: 0.9963, κατά 0.0001 βαθμούς.
Ένα ενδιαφέρον στοιχείο των αποτελεσμάτων ήταν ότι το Random Forest παρουσίασε οριακά καλύτερη απόδοση από το XGBoost, παρόλο που το XGBoost θεωρείται συνήθως πιο ισχυρό και πιο εξελιγμένο ensemble μοντέλο. Η διαφορά ήταν μικρή, ωστόσο το Random Forest πέτυχε ελαφρώς υψηλότερο AUC και πολύ σταθερή συμπεριφορά. Αυτό πιθανόν οφείλεται στο γεγονός ότι το συγκεκριμένο dataset είναι σχετικά «καθαρό» και εύκολα διαχωρίσιμο, επομένως ακόμη και ένα λιγότερο πολύπλοκο ensemble μοντέλο μπορεί να αποδώσει εξαιρετικά χωρίς την ανάγκη πιο επιθετικού boosting.
Η αλλαγή του eta επηρέασε κυρίως την ταχύτητα εκπαίδευσης του XGBoost. Με μικρό eta (0.01), το μοντέλο μάθαινε πιο αργά και χρειάστηκε περισσότερους boosting rounds μέχρι να επιτευχθεί καλή απόδοση. Αντίθετα, με μεγαλύτερο eta (0.3), η σύγκλιση έγινε πολύ γρηγορότερα και το μοντέλο ολοκλήρωσε την εκπαίδευση σε λιγότερους γύρους. Ενώ το μεσαίο eta (0.1) είχε μία ισορροπία ανάμεσα στα δύο, συγκλίνοντας όμως στην συμπεριφορά του 3ου eta (0.3).
Παρότι και οι τρεις τιμές παρήγαγαν υψηλό AUC, τα μεγαλύτερα eta εμφάνισαν τάση για πιο επιθετική μάθηση και πιθανό overfitting.
Fin