Das Projekt

In diesem Projekt wurde das Ziel verfolgt, die Vorhersagengenauigkeit eines Klassifikationsmodells im Hinblick auf die Sensitivity unter den Bedingungen eines Class Imbalance Problems zu erhöhen. . Die Sensitivity ist hierbei von besonderem Interesse, da sie die Fähigkeit misst, die positive Klasse korrekt zu identifizieren.

Um dieses Ziel zu erreichen, wurden verschiedene Ansätze verfolgt:

Unterschiedliche Modelle: Es wurden verschiedene Klassifikationsalgorithmen (Random Forest, GLM, Naive Bayes, K-Nearest Neighbor, Conditional Inference Trees) getestet, um ihre Leistung hinsichtlich der Sensitivity zu vergleichen.
Sampling-Methoden: Um das Ungleichgewicht der Klassen auszugleichen, kamen Methoden Random Oversampling, Random Undersampling, SMOTE, Nearmiss, Tomek, SMOTETomek und ADASYN zum Einsatz.

Die Ergebnisse wurden analysiert, um die optimale Kombination aus Modell und Sampling-Methode identifizieren, die eine deutliche Steigerung der Sensitivity ermöglichen.

Ladung der benötigten Pakete:

library(ggplot2)
library(caret)
library(ggmosaic)
library(ROSE)
library(knitr)
library(tidyr)
library(themis)
library(recipes)
library(ggfortify)
library(corrplot)
library(patchwork)
library(dplyr)
library(kableExtra)
library(reshape2)

Daten

Das für dieses Projekt genutzte Dataset Binary stammt von der Plattform Kaggle. Binary ist ein simuliertes Dataset, das Informationen zu den Zulassungen von Studierenden an eine Bildungseinrichtung enthält. Es umfasst 400 Fälle und 4 verschiedene Variablen, die für den Zulassungsprozess relevant sind, und dient als Muster-Dataset für Bildungs- und Analysezwecke.

Ladung der Daten:

data <- read.csv("binary.csv", sep = ",")
head(data) %>%
  kable(caption = "Binary") %>%
  kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE,
                position = "left")

Binary
admit	gre	gpa	rank
0	380	3.61	3
1	660	3.67	3
1	800	4.00	1
1	640	3.19	4
0	520	2.93	4
1	760	3.00	2

dim(data)

## [1] 400   4

summary(data)

##      admit             gre             gpa             rank      
##  Min.   :0.0000   Min.   :220.0   Min.   :2.260   Min.   :1.000  
##  1st Qu.:0.0000   1st Qu.:520.0   1st Qu.:3.130   1st Qu.:2.000  
##  Median :0.0000   Median :580.0   Median :3.395   Median :2.000  
##  Mean   :0.3175   Mean   :587.7   Mean   :3.390   Mean   :2.485  
##  3rd Qu.:1.0000   3rd Qu.:660.0   3rd Qu.:3.670   3rd Qu.:3.000  
##  Max.   :1.0000   Max.   :800.0   Max.   :4.000   Max.   :4.000

Variablen:

admit: Die binäre Zielvariable gibt an, ob die Schühler in eine Bildungseinrichtung aufgenommen wurden oder nicht
- 0 = nicht aufgenommen
- 1 = aufgenommen
gre (Graduate Record Examination): Die kontinuierliche Variable gibt die Ergebnisse des Tests zur Aufnahme in US-amerikanische Graduiertenschulen an.
gpa (Grade Point Average): Die kontinuierliche Variable stellt das GPA der Schüler dar und spiegelt somit ihre schulische Leistungen wider.
rank: Die Variable gibt den Rang der Schulen auf einer Skala von 1 bis 4 an, die von den Schülern besucht wurden. Je kleiner die Zahl, desto besser ist der Rang.

Sichtung der Daten

Ermittlung der fehlenden Werte:

sapply(data, function(x) sum(is.na(x)))

## admit   gre   gpa  rank 
##     0     0     0     0

Ermittlung der Klassen der Variablen:

sapply(data, FUN = class)

##     admit       gre       gpa      rank 
## "integer" "integer" "numeric" "integer"

Faktorisierung der Zielvariable:

data$admit <- as.factor(data$admit)

ggplot(data, aes(x = admit, fill = admit)) + geom_bar(width = 0.3, alpha = 0.8) +
  geom_text(stat = 'count', aes(label = scales::percent(after_stat(count)/sum(after_stat(count)))), vjust = -0.5, size = 3) +
  theme_minimal() +
  scale_fill_manual(values = c("skyblue", "#04B4AE")) +
  geom_hline(yintercept = 0, size = 1, colour="#333333") +
  labs(y = "Häufigkeit") +
  theme(legend.position = "none") +
  ggtitle("Verteilung der Zielvariable")

Der Anteil der aufgenommenen Personen beträgt 32 %, während der Anteil der nicht aufgenommenen Personen mit 68 % deutlich höher ist.

ggplot(data, aes(x = rank, fill = after_stat(count))) + geom_bar(width = 0.3, alpha = 0.8) + 
  labs(x = "Rank", y = "Häufigkeit") +
  geom_text(stat = 'count', aes(label = after_stat(count)), vjust = -0.5, size = 3)+
  theme_minimal() +
  geom_hline(yintercept = 0, size = 1, colour="#333333") +
  theme(legend.position = "none") +
  ggtitle("Verteilung des Schulrangs")

Korrelation von gpa und gre:

cor(data$gpa, data$gre)

## [1] 0.3842659

Eine Korrelation von 0,38 zwischen den Variablen gpa (Schulnotendurchsnitt) und gre (Testergebnisse) weist auf eine positive, aber moderate Korrelation hin. Diese Korrelation deutet darauf hin, dass es einen gewissen Zusammenhang zwischen den Schulnoten und den Testergebnissen gibt. Studierende mit besseren Noten tendieren also dazu, auch höhere Testergebnisse zu erzielen. Dennoch gibt es wahrscheinlich auch weitere Faktoren, die die Testergebnisse beeinflussen können, da die Korrelation nicht sehr stark ist.

to.plot <- data[, c('gre','gpa')]
to.plot.r <- melt(to.plot)
ggplot(to.plot.r, aes(x = factor(variable), y = value, fill = variable, color = variable)) + 
  geom_violin(trim=T, alpha = 0.5) +
  ggtitle("Verteilung gre und gpa") +
  geom_boxplot(width=0.2, outlier.color = "red", outlier.shape = 16) +
  facet_wrap(.~variable, scales = 'free') +
  scale_fill_manual(values = c("lightblue", "lightgreen")) +
  scale_color_manual(values = c("navy", "darkgreen")) +
  labs(x = "", y = "Wert") +
  theme_minimal() +
  theme(legend.position = "none")

Die wenigen Außreiser werden in diesem Projekt nicht entfernt.

data_prop <- data %>% 
     group_by(rank, admit) %>% 
     summarise(count = n()) %>%
     mutate(prozent = count / sum(count) * 100)
ggplot(data_prop, aes(x = rank, y = prozent, fill = as.factor(admit))) + 
  geom_bar(stat="identity", position = position_dodge(width = 0.6), width = 0.8) +
  labs(x = "Rank", y = "Prozent") +
  scale_fill_manual(
    values = c("lightblue", "#04B4AE"), 
    labels = c("Nicht aufgenommen", "Aufgenommen"),
    name = "Admit"
  ) +
  geom_text(aes(label = paste0(round(prozent), "%")), 
                               position = position_dodge(width = 0.6), 
                               vjust = -0.4,
                               size = 2.5) +
  theme_minimal() +
  ggtitle("Schulrang und Aufnahme")

Die Abbildung zeigt, dass der Rang der besuchten Schule eine wichtige Rolle bei der Aufnahmequote spielt. Ein höherer Rang der Schule korreliert mit einer höheren Wahrscheinlichkeit der Aufnahme in die Bildungseinrichtung.

ggplot(data, aes(x = gpa, y = gre, shape = factor(rank), color = factor(admit))) +
  geom_point() +
  geom_hline(yintercept = 587.7, linetype = "dashed", colour = "navy") +
  geom_vline(xintercept = 3.390, linetype = "dashed", colour = "navy") +
  labs(color = "Admit", shape = "Rank", x = "gpa", y = "gre") +
  scale_color_manual(values = c("skyblue", "darkred")) +
  theme_minimal()

Die Abbildung zeigt die Zusammenhänge zwischen den Variablen gre, gpa, admit und rank. Die dunkelblauen gestrichelten Linien markieren die Durchschnittswerte von gpa (Schulnoten) und gre (Testergebnisse). Die Abbildung deutet darauf hin, dass die Aufnahmeentscheidungen nicht ausschließlich auf akademischen Leistungen basieren. Die Schulqualität (rank) scheint ebenfalls eine Rolle zu spielen, ist jedoch kein garantierter Faktor für eine Aufnahme. So lässt sich erkennen, dass in einigen Fällen selbst ein hoher Schulrang (bessere Schulen) in Kombination mit überdurchschnittlichen Leistungen nicht zu einer Aufnahme führte. Ebenso gab es einige wenige Fälle, in denen Personen mit unterdurchschnittlichen Schulnoten und Testergebnissen aus Schulen mit niedrigem Rang dennoch aufgenommen wurden.

Split

Um ein Vorhersagemodell zu erstellen, müssen die Daten zunächst in ein Trainings- und ein Testset aufgeteilt werden. In diesem Projekt wurde ein Verhältnis von 70:30 zwischen den beiden Sets festgelegt.

set.seed(404)
sapply(data, FUN = class)

##     admit       gre       gpa      rank 
##  "factor" "integer" "numeric" "integer"

train.index <- createDataPartition(data$admit, 
                                   p=0.7, 
                                   list=FALSE)
head(train.index)

##      Resample1
## [1,]         1
## [2,]         2
## [3,]         3
## [4,]         5
## [5,]        11
## [6,]        12

training <- data[train.index,]
testing<- data[-train.index,]
nrow(training); nrow(testing)

## [1] 281

## [1] 119

Vergleich der Modelle

Im nächsten Schritt werden die Modelle Naive Bayes, KNN, GLM, Ctree und Random Forest trainiert und getestet.

set.seed(404)
model.nb <-  train(admit ~ .,
                 data = training, 
                 method = 'naive_bayes') 
model.knn <-  train(admit ~ .,
                 data = training, 
                 method = 'knn')
model.glm <-  train(admit ~ .,
                 data = training, 
                 method = 'glm')
model.ctree <-  train(admit ~ .,
                 data = training, 
                 method = 'ctree')
model.rf <-  train(admit ~ .,
                 data = training, 
                 method = 'rf')

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

model_list <- list("glm" = model.glm, "tree" = model.ctree, "knn" = model.knn,
                   "nb" = model.nb, "rf" = model.rf)
results_model <- data.frame()
for (model_name in names(model_list)) {
  predictions <- predict(model_list[[model_name]], newdata = testing)
  conf_matrix <- confusionMatrix(predictions, testing$admit, positive = '1')
  kappa <- conf_matrix$overall["Kappa"]
  accuracy <- conf_matrix$overall["Accuracy"]
  sensitivity <- conf_matrix$byClass["Sensitivity"]
  specificity <- conf_matrix$byClass["Specificity"]
  f1 <- conf_matrix$byClass["F1"]
  results_model <- rbind(results_model, data.frame(Model = model_name, Accuracy = accuracy, Kappa = kappa, Sensitivity = sensitivity,
             Specificity = specificity, F1 = f1))
}

Das Ziel des Projekts besteht darin, die Vorhersagegenauigkeit für die kleinere positive Klasse zu verbessern. Daher wurden die Modellergebnisse nach der Sensitivity sortiert.

rownames(results_model) <- NULL
sorted_results <- results_model %>%
  arrange(desc(Sensitivity))
kable(sorted_results, caption = "Model Performance Metrics")

Model Performance Metrics
Model	Accuracy	Kappa	Sensitivity	Specificity	F1
rf	0.7394958	0.3306115	0.3947368	0.9012346	0.4918033
nb	0.7394958	0.2977346	0.3157895	0.9382716	0.4363636
glm	0.7394958	0.2485231	0.2105263	0.9876543	0.3404255
knn	0.6890756	0.1334383	0.1842105	0.9259259	0.2745098
tree	0.6806723	0.0000000	0.0000000	1.0000000	NA

df_long <- pivot_longer(results_model, 
                        cols = c(Accuracy, Kappa, Sensitivity, Specificity, F1),
                        names_to = "Wert",       
                        values_to = "Zahl")

ggplot(df_long, aes(x = Wert, y = Zahl, color = Model, group = Model)) + geom_point(size = 2) + geom_line() + 
 scale_color_manual(
    values = c("blue","red", "#04B4AE", "#D358F7", "lightblue"))+
theme_minimal() + labs(x = "Kennzahl", y = "Wert")

Die besten Ergebnisse hinsichtlich der Sensitivity, aber auch in Bezug auf Kappa, F1 und Accuracy, erzielten die Modelle Random Forest, Naive Bayes und GLM. Diese Modelle wurden daher für die weitere Analyse ausgewählt.

Wichtigsten Variablen

Im nächsten Schritt werden die wichigsten Variablen der ausgewählten Modelle Random Forest, Naive Bayes und GLM ermittelt.

create_importance_plot <- function(model, title, colors, importance_col) {
  coefs <- varImp(model)
  df_imp <- data.frame(coefs$importance)
  df_imp$Vars <- row.names(df_imp)
  
  colnames(df_imp)[1] <- importance_col
  
  df_imp <- df_imp[order(df_imp[[importance_col]], decreasing = TRUE), ]
  df_imp$Vars <- factor(df_imp$Vars, levels = df_imp$Vars)

  ggplot(df_imp, aes(y = Vars, x = .data[[importance_col]], fill = Vars)) + 
    geom_vline(xintercept = 0, size = 0.8, colour = "#333333") +
    geom_bar(stat = "identity", width = 0.03) +  
    geom_point(size = 3, aes(color = Vars)) +  
    scale_fill_manual(values = colors) +       
    scale_color_manual(values = colors) +      
    labs(y = "", x = "Importance") +
    ggtitle(title) +
    theme_minimal() +
    theme(legend.position = "none")
}
colors <- c("gre" = "#FF5733", "gpa" = "#58d68d", "rank" = "#3357FF")
plot_rf <- create_importance_plot(model.rf, "Variable Importance in Random Forest", colors, "Importance")
plot_nb <- create_importance_plot(model.nb, "Variable Importance in Naive Bayes", colors, "Importance")
plot_glm <- create_importance_plot(model.glm, "Variable Importance in GLM", colors, "Importance")

(plot_rf + plot_nb) / (plot_glm + plot_spacer())

Die Abbildung zeigt, dass in den verschiedenen Modellen unterschiedliche Variablen als wichtig erachtet werden. Im Random Forest sind die Variablen gre und insbesondere gpa von großer Bedeutung, während die Variable rank keine Rolle spielt. Im Naive Bayes hingegen ist rank die wichtigste Variable, während gre nur eine geringe und gpa keine Bedeutung hat. Im GLM ist ebenfalls rank die wichtigste Variable, während gpa eine geringe und gre keine Bedeutung aufweist.

Konfusionsmatrix

Im nächsten Schritt werden die Konfusionsmatrizen der ausgewählten Modelle als Balkendiagramme dargestellt. Diese dienen später als Grundlage für den Vergleich mit den Modellen, die auf den gesampelten Daten basieren.

plot_confusion_matrices <- function(models, testing_data, target_variable) {
  plots <- list()
  for (model_name in names(models)) {
    model <- models[[model_name]]
    predictions <- predict(model, newdata = testing_data)
    conf_matrix <- confusionMatrix(predictions, testing_data[[target_variable]], positive = '1')
    conf_df <- as.data.frame(as.table(conf_matrix$table))
    colnames(conf_df) <- c("Prediction", "Reference", "Freq")
    conf_prop <- conf_df %>%
      group_by(Reference) %>%
      mutate(Percentage = Freq / sum(Freq) * 100)
    plot <- ggplot(conf_prop, aes(x = Reference, y = Freq, fill = Prediction)) +
      geom_bar(stat = "identity", position = "stack", alpha = 0.7) +
      scale_fill_manual(values = c("#04B486", "#5882FA")) +
       geom_text(aes(label = ifelse(Percentage > 2, paste0(round(Percentage, 1), "%"), "")),  
            position = position_stack(vjust = 0.5),  
            color = "white", size = 3) +  
      labs(title = model_name,
           x = "Reference",
           y = "Häufigkeit",
           fill = "Prediction") +
      theme_minimal()
    plots[[model_name]] <- plot
  }
  
  return(plots)
}

models <- list(
  RF = model.rf,  
  NB = model.nb,      
  GLM = model.glm     
)

confusion_plots <- plot_confusion_matrices(models, testing, "admit")

conf_rf <- confusion_plots$RF   
conf_nb <- confusion_plots$NB   
conf_glm <- confusion_plots$GLM

conf_rf

conf_nb

conf_glm

Die Sensitivity in Random Forest liegt bei 39,5%, in Naive Bayes bei 31,6% und in GLM bei 21,1%.

Sampling

Im nächsten Schritt wird das Trainingsdatenset mit verschiedenen Sampling-Methoden bearbeitet, um die Performance der Modelle zu verbessern. Die folgenden Sampling-Methoden wurden ausgewählt:

Random Undersampling: Bei dieser Methode werden zufällig Fälle der Mehrheitsklasse entfernt, um das Ungleichgewicht im Datensatz zu reduzieren
Random Oversampling: Hierbei werden zufällig Fälle der Minderheitsklasse dupliziert, um das Ungleichgewicht zu verringern und mehr Beispiele der Minderheitsklasse bereitzustellen
SMOTE: SMOTE bewirkt eine Erhöhung der Beobachtungen der Minderheitsklassen durch die Generierung neuer synthetischer Daten, welche auf den ursprünglichen Daten des Datensatzes basieren
Tomek Links: Die Methode identifiziert und entfernt Beobachtungen aus den Mehrheitsklassen, die nahe zu jenen aus der Minderheitsklasse liegen
SMOTETomek: Eine Kombination aus SMOTE und Tomek Links, die sowohl synthetische Instanzen erzeugt als auch Rauschen durch Entfernen von Tomek Links reduziert
Nearmiss: NearMiss ist ein Undersampling-Verfahren, das Instanzen der Mehrheitsklasse entfernt, die zu den nächsten Nachbarn der Minderheitsklasse gehören, um die Trennung zwischen den Klassen zu optimieren
Adasyn: ADASYN ist eine Erweiterung von SMOTE, die sich auf die schwieriger zu klassifizierenden Instanzen der Minderheitsklasse konzentriert und mehr synthetische Beispiele für diese erzeugt

Zwischen den oben aufgelisteten Methoden gibt es eine Unterteilung in verschiedene Kategorien: Die Methoden des Oversampling (Random Oversampling, SMOTE, ADASYN), die Methoden des Undersampling (Random Undersampling, NearMiss, Tomek Links) sowie die Hybrid-Sampling-Methode (SMOTETomek).

table(training$admit)

## 
##   0   1 
## 192  89

Random Undersampling:

#set.seed(404)
under <- ovun.sample(admit~., data = training, method = "under", N = 178)$data
table(under$admit)

## 
##  0  1 
## 89 89

Random Oversampling:

set.seed(404)
over <- ovun.sample(admit~., data = training, method = "over", N = 384)$data
table(over$admit)

## 
##   0   1 
## 192 192

SMOTE:

set.seed(404)
recipe <- recipe(admit ~ ., data = training) %>%
  step_smote(admit, over_ratio = 1)
prepared_recipe <- prep(recipe, training = training)
smote <- juice(prepared_recipe)
table(smote$admit)

## 
##   0   1 
## 192 192

Tomek Links:

set.seed(404)
recipe <- recipe(admit ~ ., data = training) %>%
  step_tomek(admit)
prepared_recipe <- prep(recipe, training = training)
tomek<- juice(prepared_recipe)
table(tomek$admit)

## 
##   0   1 
## 158  55

SMOTETomek:

set.seed(404)
recipe <- recipe(admit ~ ., data = training) %>%
  step_smote(admit, over_ratio = 1) %>%  # Zuerst SMOTE
  step_tomek(admit)
prepared_recipe <- prep(recipe, training = training)
stomek<- juice(prepared_recipe)
table(stomek$admit)

## 
##   0   1 
## 159 159

Nearmiss:

set.seed(404)
recipe <- recipe(admit ~ ., data = training) %>%
  step_nearmiss(admit, under_ratio = 1, neighbors = 3)
prepared_recipe <- prep(recipe, training = training)
nearmiss <- juice(prepared_recipe)
table(nearmiss$admit)

## 
##  0  1 
## 89 89

Adasyn:

set.seed(404)
recipe <- recipe(admit ~ ., data = training) %>%
  step_adasyn(admit, over_ratio = 1, neighbors = 3)
prepared_recipe <- prep(recipe, training = training)
adasyn <- juice(prepared_recipe)
table(adasyn$admit)

## 
##   0   1 
## 192 192

Nach dem Sampling der Trainingsdaten werden diese mit den ausgewählten Modellen trainiert und anschließend getestet.

Sampling und Random Forrest

set.seed(404)
model.over <-  train(admit ~ .,
                 data = over, 
                 method = 'rf')

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

model.under <-  train(admit ~ .,
                 data = under, 
                 method = 'rf')

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

model.smote <-  train(admit ~ .,
                 data = smote, 
                 method = 'rf')

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

model.tomek <-  train(admit ~ .,
                 data = tomek, 
                 method = 'rf')

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

model.stomek <-  train(admit ~ .,
                 data = stomek, 
                 method = 'rf')

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

model.nearmiss <-  train(admit ~ .,
                 data = stomek, 
                 method = 'rf')

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

model.adasyn <-  train(admit ~ .,
                 data = adasyn, 
                 method = 'rf')

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

set.seed(404)
model_list <- list("over" = model.over, "under" = model.under, "smote" = model.smote, "tomek" = model.tomek, "stomek" = model.stomek, "nearmiss" = model.nearmiss, "adasyn" = model.adasyn, "origin_rf" = model.rf)
results_model <- data.frame()
for (model_name in names(model_list)) {
  predictions <- predict(model_list[[model_name]], newdata = testing)
  conf_matrix <- confusionMatrix(predictions, testing$admit, positive = '1')
  kappa <- conf_matrix$overall["Kappa"]
  accuracy <- conf_matrix$overall["Accuracy"]
  sensitivity <- conf_matrix$byClass["Sensitivity"]
  specificity <- conf_matrix$byClass["Specificity"]
  f1 <- conf_matrix$byClass["F1"]
  results_model <- rbind(results_model, data.frame(Model = model_name, Accuracy = accuracy, Kappa = kappa, Sensitivity = sensitivity,
             Specificity = specificity, F1 = f1))
}

Die Ergebnisse werden nach Sensitivity sortiert und ausgegeben.

rownames(results_model) <- NULL
sorted_results <- results_model %>%
  arrange(desc(Sensitivity))
kable(sorted_results, caption = "Model Performance Metrics")

Model Performance Metrics
Model	Accuracy	Kappa	Sensitivity	Specificity	F1
under	0.6050420	0.1562830	0.5263158	0.6419753	0.4597701
adasyn	0.6806723	0.2443182	0.4473684	0.7901235	0.4722222
smote	0.6806723	0.2332994	0.4210526	0.8024691	0.4571429
stomek	0.6470588	0.1647727	0.3947368	0.7654321	0.4166667
nearmiss	0.6554622	0.1787578	0.3947368	0.7777778	0.4225352
origin_rf	0.7310924	0.3143680	0.3947368	0.8888889	0.4838710
over	0.6554622	0.1542728	0.3421053	0.8024691	0.3880597
tomek	0.6722689	0.1578661	0.2894737	0.8518519	0.3606557

df_long <- pivot_longer(results_model, 
                        cols = c(Accuracy, Kappa, Sensitivity, Specificity, F1),
                        names_to = "Wert",       
                        values_to = "Zahl")
df_long <- df_long %>%
  mutate(Linientyp = ifelse(Model %in% "origin_rf", "solid", "dashed"))
ggplot(df_long, aes(x = Wert, y = Zahl, color = Model, group = Model, linetype = Linientyp)) + geom_point(size = 2) + geom_line() +
scale_color_manual(
    values = c("blue","red", "black", "#04B4AE", "#D358F7", "lightblue", "lightgreen", "#d35400"))+
theme_minimal() + labs(x = "Kennzahl", y = "Wert") +
guides(linetype = "none") +
  ggtitle("Sampling und Random Forest")

Die Abbildung zeigt die Ergebnisse der Random Forest-Modellierung unter Anwendung verschiedener Sampling-Methoden. Die schwarze gestrichelte Linie repräsentiert die Ergebnisse des Random Forest-Modells mit dem ursprünglichen, nicht gesampelten Datensatz.

Der höchste Sensitivity-Wert wird mit der Methode Random Undersampling erreicht und beträgt 52,6 %. Allerdings ist der Kappa-Wert im Vergleich zum Basismodell deutlich gesunken und liegt nur noch bei 15,6 %, während er im Basismodell 31,4 % beträgt.

Dies verdeutlicht, dass die Steigerung der Sensitivität in diesem Fall mit einem deutlichen Verlust an Modellqualität (gemessen am Kappa-Wert) einhergeht.

set.seed(404)
predictions <- predict(model.under, newdata = testing)
under_matrix <- confusionMatrix(predictions, testing$admit, positive = '1')
under_df <- as.data.frame(as.table(under_matrix$table))
colnames(under_df) <- c("Prediction", "Reference", "Freq")
conf_prop <- under_df %>%
  group_by(Reference) %>%
  mutate(Percentage = Freq / sum(Freq) * 100)
under_plot <- ggplot(conf_prop, aes(x = Reference, y = Freq, fill = Prediction)) +
  geom_bar(stat = "identity", position = "stack", alpha=0.7) +
  scale_fill_manual(values = c("#04B486", "#5882FA")) +
  geom_text(aes(label = paste0(round(Percentage, 1), "%")),  
            position = position_stack(vjust = 0.5),  
            color = "white", size = 3) +  
  labs(title = "RF mit Undersampling",
       x = "Reference",
       y = "Häufigkeit",
       fill = "Prediction") +
  theme_minimal()

(conf_rf + under_plot) + 
  plot_layout(guides = "collect")

Der maximale Zugewinn der Sensitivity nach Sampling beträgt beim Random Forest 13,2 %. Der Verlust der Specificity beträgt 24,7%.

set.seed(404)
filtered_under <- results_model %>%
  filter(Model %in% c("origin_rf", "under"))
rownames(results_model) <- NULL
kable(filtered_under, caption = "Model Performance Metrics")

Model Performance Metrics
Model	Accuracy	Kappa	Sensitivity	Specificity	F1
under	0.6050420	0.156283	0.5263158	0.6419753	0.4597701
origin_rf	0.7310924	0.314368	0.3947368	0.8888889	0.4838710

Sampling in Naive Bayes

set.seed(404)
model.over <-  train(admit ~ .,
                 data = over, 
                 method = 'nb') 
model.under <-  train(admit ~ .,
                 data = under, 
                 method = 'nb')
model.smote <-  train(admit ~ .,
                 data = smote, 
                 method = 'nb')
model.tomek <-  train(admit ~ .,
                 data = tomek, 
                 method = 'nb')
model.stomek <-  train(admit ~ .,
                 data = stomek, 
                 method = 'nb')
model.nearmiss <-  train(admit ~ .,
                 data = stomek, 
                 method = 'nb')
model.adasyn <-  train(admit ~ .,
                 data = adasyn, 
                 method = 'nb')

set.seed(404)
model_list <- list("over" = model.over, "under" = model.under, "smote" = model.smote, "tomek" = model.tomek, "stomek" = model.stomek, "nearmiss" = model.nearmiss, "adasyn" = model.adasyn, "origin_nb" = model.nb)
results_model <- data.frame()
for (model_name in names(model_list)) {
  predictions <- predict(model_list[[model_name]], newdata = testing)
  conf_matrix <- confusionMatrix(predictions, testing$admit, positive = '1')
  kappa <- conf_matrix$overall["Kappa"]
  accuracy <- conf_matrix$overall["Accuracy"]
  sensitivity <- conf_matrix$byClass["Sensitivity"]
  specificity <- conf_matrix$byClass["Specificity"]
  f1 <- conf_matrix$byClass["F1"]
  results_model <- rbind(results_model, data.frame(Model = model_name, Accuracy = accuracy, Kappa = kappa, Sensitivity = sensitivity,
             Specificity = specificity, F1 = f1))
}

rownames(results_model) <- NULL
sorted_results <- results_model %>%
  arrange(desc(Sensitivity))
kable(sorted_results, caption = "Model Performance Metrics")

Model Performance Metrics
Model	Accuracy	Kappa	Sensitivity	Specificity	F1
smote	0.6470588	0.2697253	0.6578947	0.6419753	0.5434783
adasyn	0.6386555	0.2570060	0.6578947	0.6296296	0.5376344
stomek	0.6470588	0.2604321	0.6315789	0.6543210	0.5333333
nearmiss	0.6470588	0.2604321	0.6315789	0.6543210	0.5333333
over	0.6806723	0.2949797	0.5789474	0.7283951	0.5365854
under	0.6974790	0.3230088	0.5789474	0.7530864	0.5500000
origin_nb	0.7394958	0.2977346	0.3157895	0.9382716	0.4363636
tomek	0.7478992	0.2790792	0.2368421	0.9876543	0.3750000

df_long <- pivot_longer(results_model, 
                        cols = c(Accuracy, Kappa, Sensitivity, Specificity, F1),
                        names_to = "Wert",       
                        values_to = "Zahl")
df_long <- df_long %>%
  mutate(Linientyp = ifelse(Model %in% "origin_nb", "solid", "dashed"))
ggplot(df_long, aes(x = Wert, y = Zahl, color = Model, group = Model, linetype = Linientyp)) + geom_point(size = 2) + geom_line() + 
scale_color_manual(
    values = c("blue","red", "black", "#04B4AE", "#D358F7", "lightblue", "lightgreen", "#d35400"))+ 
  guides(linetype = "none") +
theme_minimal() + labs(x = "Kennzahl", y = "Wert")

Die Abbildung zeigt die Ergebnisse der Naive-Bayes-Modellierung unter Anwendung verschiedener Sampling-Methoden. Die schwarze gestrichelte Linie repräsentiert die Ergebnisse des Naive-Bayes-Modells mit dem ursprünglichen, nicht gesampelten Datensatz.

Der höchste Sensitivity-Wert wird mit den Methoden SMOTE und ADASYN erreicht und beträgt 65,8 %. Als bestes Modell wird SMOTE ausgewählt, da der Kappa-Wert mit SMOTE-Sampling höher ist als mit ADASYN-Sampling. Der Kappa-Wert des besten Modells beträgt 26,97 %. Damit ist der Kappa-Wert im Vergleich zum Basismodell um 2,8 % gesunken.

set.seed(404)
predictions <- predict(model.smote, newdata = testing)
smote_matrix <- confusionMatrix(predictions, testing$admit, positive = '1')
smote_df <- as.data.frame(as.table(smote_matrix$table))
colnames(smote_df) <- c("Prediction", "Reference", "Freq")
conf_prop <- smote_df %>%
  group_by(Reference) %>%
  mutate(Percentage = Freq / sum(Freq) * 100)
smote_plot <- ggplot(conf_prop, aes(x = Reference, y = Freq, fill = Prediction)) +
  geom_bar(stat = "identity", position = "stack", alpha=0.7) +
  scale_fill_manual(values = c("#04B486", "#5882FA")) +
  geom_text(aes(label = paste0(round(Percentage, 1), "%")),  
            position = position_stack(vjust = 0.5),  
            color = "white", size = 3) +  
  labs(title = "NB mit SMOTE",
       x = "Reference",
       y = "Häufigkeit",
       fill = "Prediction") +
  theme_minimal()

(conf_nb + smote_plot) + 
  plot_layout(guides = "collect")

Der maximale Zugewinn der Sensitivity nach Sampling mit SMOTE beträgt beim Naive-Bayes-Modell 34,2 % im Vergleich zum Basismodell. Der Verlust der Specificity beträgt hingegen 29,6 %.

set.seed(404)
filtered_smote <- results_model %>%
  filter(Model %in% c("smote", "origin_nb"))
kable(filtered_smote, caption = "Model Performance Metrics")

Model Performance Metrics
Model	Accuracy	Kappa	Sensitivity	Specificity	F1
smote	0.6470588	0.2697253	0.6578947	0.6419753	0.5434783
origin_nb	0.7394958	0.2977346	0.3157895	0.9382716	0.4363636

Sampling und GLM

set.seed(404)
model.over <-  train(admit ~ .,
                 data = over, 
                 method = 'glm') 
model.under <-  train(admit ~ .,
                 data = under, 
                 method = 'glm')
model.smote <-  train(admit ~ .,
                 data = smote, 
                 method = 'glm')
model.tomek <-  train(admit ~ .,
                 data = tomek, 
                 method = 'glm')
model.stomek <-  train(admit ~ .,
                 data = stomek, 
                 method = 'glm')
model.nearmiss <-  train(admit ~ .,
                 data = stomek, 
                 method = 'glm')
model.adasyn <-  train(admit ~ .,
                 data = adasyn, 
                 method = 'glm')

set.seed(404)
model_list <- list("over" = model.over, "under" = model.under, "smote" = model.smote, "tomek" = model.tomek, "stomek" = model.stomek, "nearmiss" = model.nearmiss, "adasyn" = model.adasyn, "origin_glm" = model.glm)
results_model <- data.frame()
for (model_name in names(model_list)) {
  predictions <- predict(model_list[[model_name]], newdata = testing)
  conf_matrix <- confusionMatrix(predictions, testing$admit, positive = '1')
  kappa <- conf_matrix$overall["Kappa"]
  accuracy <- conf_matrix$overall["Accuracy"]
  sensitivity <- conf_matrix$byClass["Sensitivity"]
  specificity <- conf_matrix$byClass["Specificity"]
  f1 <- conf_matrix$byClass["F1"]
  results_model <- rbind(results_model, data.frame(Model = model_name, Accuracy = accuracy, Kappa = kappa, Sensitivity = sensitivity,
             Specificity = specificity, F1 = f1))
}

rownames(results_model) <- NULL
sorted_results <- results_model %>%
  arrange(desc(Sensitivity))
kable(sorted_results, caption = "Model Performance Metrics")

Model Performance Metrics
Model	Accuracy	Kappa	Sensitivity	Specificity	F1
adasyn	0.6302521	0.2252146	0.6052632	0.6419753	0.5111111
over	0.6050420	0.1776209	0.5789474	0.6172840	0.4835165
smote	0.6386555	0.2280887	0.5789474	0.6666667	0.5057471
stomek	0.6134454	0.1899970	0.5789474	0.6296296	0.4888889
nearmiss	0.6134454	0.1899970	0.5789474	0.6296296	0.4888889
under	0.6638655	0.2578734	0.5526316	0.7160494	0.5121951
tomek	0.7478992	0.2790792	0.2368421	0.9876543	0.3750000
origin_glm	0.7394958	0.2485231	0.2105263	0.9876543	0.3404255

df_long <- pivot_longer(results_model, 
                        cols = c(Accuracy, Kappa, Sensitivity, Specificity, F1),
                        names_to = "Wert",       
                        values_to = "Zahl")
df_long <- df_long %>%
  mutate(Linientyp = ifelse(Model %in% "origin_glm", "solid", "dashed"))
ggplot(df_long, aes(x = Wert, y = Zahl, color = Model, group = Model, linetype = Linientyp)) + geom_point(size = 2) + geom_line() + 
scale_color_manual(
    values = c("blue","red", "black", "#04B4AE", "#D358F7", "lightblue", "lightgreen", "#d35400"))+
  guides(linetype = "none") +
theme_minimal() + labs(x = "Kennzahl", y = "Wert")

Die Abbildung zeigt die Ergebnisse der GLM-Modellierung unter Anwendung verschiedener Sampling-Methoden. Die schwarze gestrichelte Linie repräsentiert die Ergebnisse des GLM-Modells mit dem ursprünglichen, nicht gesampelten Datensatz.

Der höchste Sensitivity-Wert wird mit den Methoden ADASYN erreicht und beträgt 60,5 %. Allerdings ist der Kappa-Wert im Vergleich zum Basismodell leicht gesunken und liegt bei 22,5,6 %, während er im Basismodell 24,8 % beträgt.

set.seed(404)
predictions <- predict(model.adasyn, newdata = testing)
adasyn_matrix <- confusionMatrix(predictions, testing$admit, positive = '1')
adasyn_df <- as.data.frame(as.table(adasyn_matrix$table))
colnames(adasyn_df) <- c("Prediction", "Reference", "Freq")
conf_prop <- adasyn_df %>%
  group_by(Reference) %>%
  mutate(Percentage = Freq / sum(Freq) * 100)
adasyn_plot <- ggplot(conf_prop, aes(x = Reference, y = Freq, fill = Prediction)) +
  geom_bar(stat = "identity", position = "stack", alpha=0.7) +
  scale_fill_manual(values = c("#04B486", "#5882FA")) +
  geom_text(aes(label = paste0(round(Percentage, 1), "%")),  
            position = position_stack(vjust = 0.5),  
            color = "white", size = 3) +  
  labs(title = "GLM mit ADASYN",
       x = "Reference",
       y = "Häufigkeit",
       fill = "Prediction") +
  theme_minimal()

(conf_glm + adasyn_plot) + 
  plot_layout(guides = "collect")

Der maximale Zugewinn der Sensitivity nach Sampling mit ADASYN beträgt beim GLM-Modell 39,4 % im Vergleich zum Basismodell. Der Verlust der Specificity beträgt hingegen 34,5 %.

set.seed(404)
filtered_adasyn <- results_model %>%
  filter(Model %in% c("adasyn", "origin_glm"))
kable(filtered_adasyn, caption = "Model Performance Metrics")

Model Performance Metrics
Model	Accuracy	Kappa	Sensitivity	Specificity	F1
adasyn	0.6302521	0.2252146	0.6052632	0.6419753	0.5111111
origin_glm	0.7394958	0.2485231	0.2105263	0.9876543	0.3404255

Vergleich der Ergebnisse

Zuletzt werden die Ergebnisse der Modellirung und der Sampling miteinander verglichen.

final_df <- rbind(filtered_under[1, ], filtered_smote[1, ], filtered_adasyn[1, ])
final_df <- final_df %>%
  mutate(Model = case_when(
    Model == "under" ~ "under_rf",
    Model == "smote" ~ "smote_nb",
    Model == "adasyn" ~ "adasyn_glm",
    TRUE ~ Model  # Fallback, falls es andere Werte gibt
  ))

sorted_final_df <- final_df %>%
  arrange(desc(Sensitivity))
rownames(sorted_final_df) <- NULL
kable(sorted_final_df, caption = "Models Performance Metrics")

Models Performance Metrics
Model	Accuracy	Kappa	Sensitivity	Specificity	F1
smote_nb	0.6470588	0.2697253	0.6578947	0.6419753	0.5434783
adasyn_glm	0.6302521	0.2252146	0.6052632	0.6419753	0.5111111
under_rf	0.6050420	0.1562830	0.5263158	0.6419753	0.4597701

df_long <- pivot_longer(final_df, 
                        cols = c(Accuracy, Kappa, Sensitivity, Specificity, F1),
                        names_to = "Wert",       
                        values_to = "Zahl")
ggplot(df_long, aes(x = Wert, y = Zahl, color = Model, group = Model)) + geom_point(size = 2) + geom_line() + 
  scale_color_manual(
    values = c("#04B4AE", "#D358F7", "lightgreen"))+
theme_minimal() + labs(x = "Kennzahl", y = "Wert")

Die Abbildung zeigt die Ergebnisse der Modellierung nach Anwendung verschiedener Sampling-Methoden. Die besten Ergebnisse wurden für den Random Forest mit Random Undersampling, für Naive Bayes mit SMOTE und für GLM mit ADASYN erzielt.
Den höchsten Sensitivity-Wert zeigt das Naive-Bayes-Modell mit SMOTE. Dieses Modell weist zudem die höchsten Werte für Accuracy, Kappa und F1 auf. Die Specificity-Werte sind bei allen drei Modellen identisch.

df_final <- rbind(sorted_final_df[1,], filtered_under[filtered_under == "origin_rf",], filtered_smote[filtered_smote == "origin_nb",], filtered_adasyn[filtered_adasyn == "origin_glm",])
sorted_df_final <- df_final %>%
  arrange(desc(Sensitivity))
rownames(sorted_df_final) <- NULL
kable(sorted_df_final, caption = "Models Performance Metrics")

Models Performance Metrics
Model	Accuracy	Kappa	Sensitivity	Specificity	F1
smote_nb	0.6470588	0.2697253	0.6578947	0.6419753	0.5434783
origin_rf	0.7310924	0.3143680	0.3947368	0.8888889	0.4838710
origin_nb	0.7394958	0.2977346	0.3157895	0.9382716	0.4363636
origin_glm	0.7394958	0.2485231	0.2105263	0.9876543	0.3404255

df_long <- pivot_longer(df_final, 
                        cols = c(Accuracy, Kappa, Sensitivity, Specificity, F1),
                        names_to = "Wert",       
                        values_to = "Zahl")
df_long <- df_long %>%
  mutate(Linientyp = ifelse(Model %in% "smote_nb", "dashed", "solid"))
ggplot(df_long, aes(x = Wert, y = Zahl, color = Model, group = Model, linetype = Linientyp)) + geom_point(size = 2) + geom_line() + 
  scale_color_manual(
    values = c("#04B4AE", "#D358F7", "blue", "red"))+
  guides(linetype = "none") +
theme_minimal() + labs(x = "Kennzahl", y = "Wert")

Abschließend wird das beste Modell, Naive Bayes mit SMOTE-Sampling, mit allen drei Basismodellen ohne Sampling verglichen. Die schwarze gestrichelte Linien repräsentieren die Basismodelle ohne Sampling. Wie erwartet wird durch das Sampling der Sensitivity-Wert deutlich verbessert. Auch der F1-Wert des besten Modells mit Sampling ist höher als der F1-Wert der Basismodelle ohne Sampling. Schlechtere Ergebnisse erzielt das beste Modell mit Sampling hingegen bei den Werten Accuracy und insbesondere bei Specificity. Der Kappa-Wert des besten Modells mit Sampling ist um 4,45 % niedriger als beim Basismodell Random Forest, um 3,1 % niedriger als beim Basismodell Naive Bayes, aber um 2,1 % höher als beim Basismodell GLM.

Supervised Machine Learning

Verbesserung der Vorhersagengenauigkeit bei Class Imbalance

Maja Lichman

2024-11-22