# *****************************************************
# ----------------- Home Loan Approval ----------------
# Beschreibung: Datenimport und Preprocessing
# *****************************************************
# 1. Vorarbeiten --------------------------------------
# Workspace aufräumen
rm(list = ls())
setwd("C:/Users/daves/OneDrive/Desktop/Portfolio - DS/Assignment 1 - ML/portfolio-dave-assignment-ml")
# Package für Imputationen
if(!require("Hmisc")) install.packages("Hmisc")
# Lade Software aus R Packages
library(tidyverse)
library(tidymodels)
library(Hmisc)
# Wichtige Anmerkung zu Beginn - Variablenerklärung:
# Die Variable Credit_History zeigt gemäss Kaggle-Informationen,
# ob die Kredithistorie den Richtlinien entspricht (1) oder nicht (0).MDS Project Machine Learning
Assignment Machine Learning
1. Import & Preprocess
# *****************************************************
# 2. Datenimport --------------------------------------
# Importiere den CSV-Datensatz loan_sanction
home_loan <- read_csv("daten/loan_sanction.csv")# Datensatz inspizieren - Was für Spalten bzw. Datentypen haben wir in den Daten?
glimpse(home_loan)Rows: 614
Columns: 13
$ Loan_ID <chr> "LP001002", "LP001003", "LP001005", "LP001006", "LP0…
$ Gender <chr> "Male", "Male", "Male", "Male", "Male", "Male", "Mal…
$ Married <chr> "No", "Yes", "Yes", "Yes", "No", "Yes", "Yes", "Yes"…
$ Dependents <chr> "0", "1", "0", "0", "0", "2", "0", "3+", "2", "1", "…
$ Education <chr> "Graduate", "Graduate", "Graduate", "Not Graduate", …
$ Self_Employed <chr> "No", "No", "Yes", "No", "No", "Yes", "No", "No", "N…
$ ApplicantIncome <dbl> 5849, 4583, 3000, 2583, 6000, 5417, 2333, 3036, 4006…
$ CoapplicantIncome <dbl> 0, 1508, 0, 2358, 0, 4196, 1516, 2504, 1526, 10968, …
$ LoanAmount <dbl> NA, 128, 66, 120, 141, 267, 95, 158, 168, 349, 70, 1…
$ Loan_Amount_Term <dbl> 360, 360, 360, 360, 360, 360, 360, 360, 360, 360, 36…
$ Credit_History <dbl> 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, NA, …
$ Property_Area <chr> "Urban", "Rural", "Urban", "Urban", "Urban", "Urban"…
$ Loan_Status <chr> "Y", "N", "Y", "Y", "Y", "Y", "Y", "N", "Y", "N", "Y…# Es gibt 13 Spalten (Variablen) und 614 Zeilen (Beobachtungen) im home_loan-Datensatz
# Die Datentypen lauten wie folgt:
#chr (8): Loan_ID, Gender, Married, Dependents, Education, Self_Employed, Property_Area, Loan_Status
#dbl (5): ApplicantIncome, CoapplicantIncome, LoanAmount, Loan_Amount_Term, Credit_History# Zählen von fehlenden Werten (Missing Values) pro Spalte
sapply(home_loan, function(x) sum(is.na(x))) Loan_ID Gender Married Dependents
0 13 3 15
Education Self_Employed ApplicantIncome CoapplicantIncome
0 32 0 0
LoanAmount Loan_Amount_Term Credit_History Property_Area
22 14 50 0
Loan_Status
0 # Wir sehen in folgenden Spalten NA-Werte:
# Gender - 13
# Married - 3
# Dependents - 15
# Self_Employed - 32
# LoanAmount - 22
# Loan_Amount_Term - 14
# Credit_History - 50# *****************************************************
# 3. Preprocessing ------------------------------------
# Faktortransformationen durchführen
home_loan$Gender <- as.factor(home_loan$Gender)
home_loan$Married <- as.factor(home_loan$Married)
home_loan$Dependents <- as.factor(home_loan$Dependents)
home_loan$Education <- as.factor(home_loan$Education)
home_loan$Self_Employed <- as.factor(home_loan$Self_Employed)
home_loan$Credit_History <- as.factor(home_loan$Credit_History)
home_loan$Property_Area <- as.factor(home_loan$Property_Area)
home_loan$Loan_Status <- as.factor(home_loan$Loan_Status)# Struktur nach Transformation prüfen
glimpse(home_loan)Rows: 614
Columns: 13
$ Loan_ID <chr> "LP001002", "LP001003", "LP001005", "LP001006", "LP0…
$ Gender <fct> Male, Male, Male, Male, Male, Male, Male, Male, Male…
$ Married <fct> No, Yes, Yes, Yes, No, Yes, Yes, Yes, Yes, Yes, Yes,…
$ Dependents <fct> 0, 1, 0, 0, 0, 2, 0, 3+, 2, 1, 2, 2, 2, 0, 2, 0, 1, …
$ Education <fct> Graduate, Graduate, Graduate, Not Graduate, Graduate…
$ Self_Employed <fct> No, No, Yes, No, No, Yes, No, No, No, No, No, NA, No…
$ ApplicantIncome <dbl> 5849, 4583, 3000, 2583, 6000, 5417, 2333, 3036, 4006…
$ CoapplicantIncome <dbl> 0, 1508, 0, 2358, 0, 4196, 1516, 2504, 1526, 10968, …
$ LoanAmount <dbl> NA, 128, 66, 120, 141, 267, 95, 158, 168, 349, 70, 1…
$ Loan_Amount_Term <dbl> 360, 360, 360, 360, 360, 360, 360, 360, 360, 360, 36…
$ Credit_History <fct> 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, NA, …
$ Property_Area <fct> Urban, Rural, Urban, Urban, Urban, Urban, Urban, Sem…
$ Loan_Status <fct> Y, N, Y, Y, Y, Y, Y, N, Y, N, Y, Y, Y, N, Y, Y, Y, N…# Behebung der Fehlwerte:
# Im nächsten Schritt definieren wir pro Spalte, wie wir die Fehlwerte eliminieren möchten.
# Grundsätzlich versuchen wir das Löschen von Zeilen zu meiden, da wir einen eher kleinen Datensatz haben.# Gender - 13 / Married - 3 / Dependents - 15
# -> Modus-Imputation: Die Anzahl Fehlwerte sind hier eher gering: Wir ergänzen über den Modus.
summary(home_loan$Gender) # Wird "Mann" ergänzen -> 489 zu 112Female Male NA's
112 489 13 summary(home_loan$Married) # Wird "Yes" ergänzen -> 398 zu 213 No Yes NA's
213 398 3 summary(home_loan$Dependents) # Wird "0" ergänzen -> kommt am häufigsten vor 0 1 2 3+ NA's
345 102 101 51 15 # Self_Employed - 32
# -> Modus-Imputation: "No" ist stark überlegen, aus diesem Grund macht die Modusimputation Sinn.
summary(home_loan$Self_Employed) # Wird "No" ergänzen -> 500 zu 82 No Yes NA's
500 82 32 # Credit_History - 50
# -> Modus-Imputation: Wird "1" ergänzen. Wir gehen davon aus, dass die Kredithistorie der meisten Leute die Richtlinien
# erfüllt. Dies zeigt sich auch in den Daten (475 zu 89). Würde man 50x 0 zuweisen,
# würde sich der Wert der nicht passenden Historien um 56% erhöhen.
# Aber Achtung, dies könnte ein heikler Schritt sein. Die Historie ist, wie wir später explorativ
# erkennen werden und auch hier über table() sehen, ein wesentlicher Einflussfaktor für den Kredit-
# entscheid und es müssten die Gründe abgeklärt werden, wieso es hier so viele Fehlwerte gibt.
summary(home_loan$Credit_History) 0 1 NA's
89 475 50 table(home_loan$Credit_History, home_loan$Loan_Status)
N Y
0 82 7
1 97 378 # N & Y stehen für abgelehnt/angenommen und 0 & 1 steht für Credit-History widerspricht den Richtlinien / entspricht den Richtlinien
# Wir sehen hier also zum Beispiel, dass 82 von 89 Anträgen abgelehnt wurden, welche nicht den Richtlinien entsprachen.# Modusimputation
home_loan$Gender <- impute(home_loan$Gender, fun=mode)
home_loan$Married <- impute(home_loan$Married, fun=mode)
home_loan$Dependents <- impute(home_loan$Dependents, fun=mode)
home_loan$Self_Employed <- impute(home_loan$Self_Employed, fun=mode)
home_loan$Credit_History <- impute(home_loan$Credit_History, fun=mode)# Loan_Amount_Term - 14
# -> Median-Imputation: Wird "360" ergänzen, dies macht aus unserer Sicht Sinn, da dieser Wert deutlich am häufigsten
# vorkommt (512 von 613).
table(home_loan$Loan_Amount_Term)
12 36 60 84 120 180 240 300 360 480
1 2 2 4 3 44 4 13 512 15 # Medianimputation
home_loan$Loan_Amount_Term <- impute(home_loan$Loan_Amount_Term, fun=median)# LoanAmount - 22
# Da wir diese Variable als zentral erachten, führen wir zuerst ein paar Analysen durch, um die Entscheidung
# zur Imputation zu treffen:
# Summary und Boxplot
summary(home_loan$LoanAmount) Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
9.0 100.0 128.0 146.4 168.0 700.0 22 boxplot(home_loan$LoanAmount)
# Wir erkennen einen grösseren Mittelwert als Median und gegen oben einige Ausreisser.# Punktediagramm - JointIncome vs. Loan Amount
# Feature Engineering: Hinzufügen des gemeinsamen Einkommens
home_loan <- home_loan %>%
mutate(JointIncome = ApplicantIncome + CoapplicantIncome)
# Punktediagramm ausgeben
home_loan %>%
ggplot(aes(JointIncome, LoanAmount)) +
geom_point() +
scale_x_log10() +
geom_smooth(method = "lm")
# Aus der Grafik erkennen wir tendenziell eine positive Korrelation zwischen der Antragssumme und des
# JointIncome (zumindest im Einkommensbereich bis 10'000). Um die fehlenden NA-Werte möglichst gut zu
# imputieren, verwenden wir die lineare Regression zur Schätzung des Imputationswertes# Implementierung eines linearen Regressionsmodelles für die Schätzung der NA-Werte
modell <- lm(LoanAmount ~ log10(JointIncome), data = home_loan)
# Im oben eingeführten Modell, haben wir als Y-Wert die LoanAmount-Werte und als X-Werte die logarithmierten JointIncome-Werte aus dem Dataframe "home_loan" festgelegt und anschliessend ein lineares
# Regressionsmodell geschätzt. Als nächstes erstellen wir eine neue Spalte "PredictedLoanAmount", wo wir die Vorhersagewerte (unter Anwendung der JointIncome-Spalte aus dem Datensatz home_loan) speichern.
# Danach wird mit dem Code "mutate + ifelse" die LoanAmount Spalte mit unserer Vorhersage überschrieben, falls dort ein NA-Wert vorliegt, sonst wird der beobachtete Wert belassen.
# Abschliessend wird die "PredictedLoanAmount"-Spalte wieder entfernt, da sie nicht mehr benötigt wird.
home_loan$PredictedLoanAmount <- predict(modell, newdata = home_loan)
home_loan <- home_loan %>%
mutate(LoanAmount = ifelse(is.na(LoanAmount), PredictedLoanAmount, LoanAmount))
home_loan <- home_loan %>%
select(-PredictedLoanAmount)
# Das Modell wird ebenfalls nicht mehr benötigt und kann entfernt werden
rm(modell)# Überprüfung ob nun alle NA-Werte erfolgreich entfernt wurden
sapply(home_loan, function(x) sum(is.na(x))) Loan_ID Gender Married Dependents
0 0 0 0
Education Self_Employed ApplicantIncome CoapplicantIncome
0 0 0 0
LoanAmount Loan_Amount_Term Credit_History Property_Area
0 0 0 0
Loan_Status JointIncome
0 0 # Anmerkung:
# Wir wollten Werte z.B. Gender mit der K-nearest neighbors Methode einfügen, jedoch gab uns der R-Code die Information aus,
# dass unser Datensatz für die Berechnung der K-nächsten Nachbarn bei unserer vorliegenden Komplexität (Variablenanzahl) nicht möglich sei.# Sind Duplikate enthalten? / Achtung: ID-Variable muss ausgeschlossen werden
dpl_home_loan_idx <- duplicated(home_loan %>% select(-Loan_ID))
sum(dpl_home_loan_idx)[1] 0# Unser Datensatz weist keine Duplikate auf# Wir entfernen das Objekt dpl_train_idx wieder
rm(dpl_home_loan_idx)# *****************************************************
# 4. Zwischenresultate speichern ----------------------
# Wir speichern home_loan in dem Ordner 'zwischenresultate'
# write_rds(home_loan, "zwischenresultate/home_loan.rds")
# Das Ziel ist das Projekt modular aufzubauen, damit wir R nicht jedes Mal komplett laufen lassen müssen.
2. Train-Test-Split & Exploration
# *****************************************************
# ----------------- Home Loan Approval ----------------
# Beschreibung: Explorative Analyse
# *****************************************************
# 1. Vorarbeiten --------------------------------------
# Workspace aufräumen
rm(list = ls())
# Package zur Darstellung von Plots nebeneinander und übereinander
if(!require("gridExtra")) install.packages("gridExtra")
# Lade Software aus R Packages
library(tidyverse)
library(tidymodels)
library(ggplot2)
library(dplyr)
library(gridExtra)
# Lade Zwischenresultate
home_loan <- read_rds("zwischenresultate/home_loan.rds")# *****************************************************
# 2. Train-Test Split ---------------------------------
# Der Train-Test-Split wurde in unserem Beispieldatensatz von Kaggle
# zwar durchgeführt, jedoch fehlte die Zielvariable (Loan_Status). Aus
# diesem Grund muss hier nochmals ein Split gemacht werden.
# Wir entscheiden uns für einen 75 (Train) - 25 (Test) Split. Leider
# liegen nicht so viele Daten vor, so ergeben sich aber trotzdem
# 450 Daten zum trainieren und 150 zum Testen.
# Seed, um den Train-Test Split reproduzierbar zu machen
set.seed(123)
# Stratifizierter Split (75% Training, 25% Test)
train_test_split <- initial_split(home_loan, prop = 3/4, strata = Loan_Status)
train <- training(train_test_split)
test <- testing(train_test_split)
# Verhältnis Y (Yes) zu N (No) der Variable Loan_Status prüfen
# -> War der stratifizierte Split effektiv?
sum(train$Loan_Status=="Y")/nrow(train)[1] 0.6869565sum(test$Loan_Status=="Y")/nrow(test)[1] 0.6883117# Verhältnis des Splits prüfen
nrow(train) / (nrow(train)+nrow(test))[1] 0.7491857# Dem Trainingsdatensatz wurden korrekt 75% der Daten zugewiesen
# Wir speichern den test-Datensatz in die "zwischenresultate",
# so können wir ihn von dort laden, sobald wir ihn benötigen.
write_rds(test, "zwischenresultate/test.rds")
# Wir entfernen nun den Datensatz test wieder (ohne ihn zu betrachten)
rm(test)
# Wir entfernen ebenfalls den home_loan-Data-Frame, da wir diesen nicht mehr benötigen
rm(home_loan)
# Das Splitting-Objekt wird auch nicht mehr benötigen
rm(train_test_split)# *****************************************************
# 3. Explorative Analyse ------------------------------
# UNIVARIATE ANALYSE
# Sammlung von Kreisdiagrammen (4 univariate Variablenauswertungen, um einen Überblick zu erhalten)
# Geschlechterverteilung, Verteilung Zivilstand, Verteilung Ausbildung, Anstellungsverhältnis
# Erste Grafik
# Berechne die Prozentsätze
train_percent1 <- train %>%
group_by(Gender) %>%
summarise(Count = n()) %>%
mutate(Percent = Count / sum(Count) * 100)
# Kreisdiagramm erstellen
grafik1 <- ggplot(train_percent1, aes(x = "", y = Percent, fill = Gender)) +
geom_bar(stat = "identity") +
theme_minimal() +
labs(title = "Geschlechterverteilung", x = NULL, y = NULL) +
coord_polar("y", start = 0) + # Wandle das Balkendiagramm in ein Kreisdiagramm um
theme(plot.title = element_text(hjust = 0.5)) +
geom_text(aes(label = paste(round(Percent, 1), "%")), position = position_stack(vjust = 0.5), color = "white") +
theme(plot.title = element_text(hjust = 0.5),
legend.position = "bottom") +
scale_fill_discrete(name = "Geschlecht", breaks = c("Female", "Male"),
labels=c("Weiblich","Männlich"))
# Zweite Grafik
# Berechne die Prozentsätze
train_percent2 <- train %>%
group_by(Married) %>%
summarise(Count = n()) %>%
mutate(Percent = Count / sum(Count) * 100)
# Kreisdiagramm erstellen
grafik2 <- ggplot(train_percent2, aes(x = "", y = Percent, fill = Married)) +
geom_bar(stat = "identity") +
theme_minimal() +
labs(title = "Verteilung Zivilstand", x = NULL, y = NULL) +
coord_polar("y", start = 0) + # Wandle das Balkendiagramm in ein Kreisdiagramm um
theme(plot.title = element_text(hjust = 0.5)) +
geom_text(aes(label = paste(round(Percent, 1), "%")), position = position_stack(vjust = 0.5), color = "white") +
theme(plot.title = element_text(hjust = 0.5),
legend.position = "bottom") +
scale_fill_discrete(name = "Zivilstand", breaks = c("No", "Yes"),
labels=c("Ledig","Verheiratet"))
# Dritte Grafik
# Berechne die Prozentsätze
train_percent3 <- train %>%
group_by(Education) %>%
summarise(Count = n()) %>%
mutate(Percent = Count / sum(Count) * 100)
# Kreisdiagramm erstellen
grafik3 <- ggplot(train_percent3, aes(x = "", y = Percent, fill = Education)) +
geom_bar(stat = "identity") +
theme_minimal() +
labs(title = "Verteilung Ausbildung", x = NULL, y = NULL) +
coord_polar("y", start = 0) + # Wandle das Balkendiagramm in ein Kreisdiagramm um
theme(plot.title = element_text(hjust = 0.5)) +
geom_text(aes(label = paste(round(Percent, 1), "%")), position = position_stack(vjust = 0.5), color = "white") +
theme(plot.title = element_text(hjust = 0.5),
legend.position = "bottom") +
scale_fill_discrete(name = "Ausbildungsgrad", breaks = c("Graduate", "Not Graduate"),
labels=c("Mit Hochschulabschluss","Ohne Hochschulabschluss"))
# Vierte Grafik
# Berechne die Prozentsätze
train_percent4 <- train %>%
group_by(Self_Employed) %>%
summarise(Count = n()) %>%
mutate(Percent = Count / sum(Count) * 100)
# Kreisdiagramm erstellen
grafik4 <- ggplot(train_percent4, aes(x = "", y = Percent, fill = Self_Employed)) +
geom_bar(stat = "identity") +
theme_minimal() +
labs(title = "Anstellungsverhältnis", x = NULL, y = NULL) +
coord_polar("y", start = 0) + # Wandle das Balkendiagramm in ein Kreisdiagramm um
theme(plot.title = element_text(hjust = 0.5)) +
geom_text(aes(label = paste(round(Percent, 1), "%")), position = position_stack(vjust = 0.5), color = "white") +
theme(plot.title = element_text(hjust = 0.5),
legend.position = "bottom") +
scale_fill_discrete(name = "Anstellungsverhältnis", breaks = c("No", "Yes"),
labels=c("Angestellt","Selbstständig"))
# Darstellung von Grafiken 1 bis 4 in einem Plot
grid.arrange(grafik1, grafik2, grafik3, grafik4, ncol = 2, nrow = 2)
# Löschen der für die Grafiken erstellten Data Frames und Grafik-Objekten
rm(grafik1, grafik2, grafik3, grafik4)
rm(train_percent1, train_percent2, train_percent3, train_percent4)# Balkendiagramm zu den Dependents (also abhängigen Personen im gleichen Haushalt z.B. Kinder)
ggplot() +
geom_bar(data=train, aes(x=Dependents, fill=Dependents))+
theme_minimal() +
labs(title = "Anzahl abhängiger Personen im Haushalt (z.B. Kinder)",
x = "",
y = "Anzahl") +
theme(plot.title=element_text(hjust=0.5)) +
geom_text(data=train, aes(x=Dependents, label = ..count..), stat = "count",
vjust=2,
color="white",
size=3) +
theme(axis.title.y = element_text(angle = 0,
vjust = 0.5)) +
theme(legend.position = "none") +
scale_x_discrete(labels = c("0" = "0", "1" = "1", "2" = "2", "3+" = "3 und mehr")) #x-Achsenbeschriftungen umbenennen v.a. 3+ zu 3 und mehr
# 2er-Diagramm (Histogramme)
# Diagramm 1: Histogramm zur angefragten Kredithöhe
grafik6 <- ggplot()+
geom_histogram(data = train, aes(x = LoanAmount), fill = "steelblue", color = "black", bins = 20) +
theme_minimal() +
scale_x_log10() +
labs(title = "Angefragte Kredithöhe",
x = "Kredithöhe - Achse log(10) skaliert",
y = "Anzahl") +
theme(plot.title=element_text(hjust=0.5)) +
theme(axis.title.y = element_text(angle = 0,
vjust = 0.5)) +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 10, unit = "pt"))
# Diagramm 2: Histogramm mit dem gemeinsamen Einkommen (Beachte das JointIncome wurde von uns erstellt und zeigt die Summe der Variablen ApplicantIncome und CoapplicantIncome)
grafik7 <- ggplot()+
geom_histogram(data = train, aes(x = JointIncome), fill = "steelblue", color = "black", bins = 20) +
theme_minimal() +
scale_x_log10() +
labs(title = "Haushaltseinkommen",
x = "Einkommen - Achse log(10) skaliert",
y = "Anzahl") +
theme(plot.title=element_text(hjust=0.5)) +
theme(axis.title.y = element_text(angle = 0,
vjust = 0.5)) +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 10, unit = "pt"))
# Darstellung von Grafik6 und Grafik7 in einem Plot
grid.arrange(grafik6, grafik7, ncol = 2)
# Löschen der für die gemeinsame Darstellung erstellten Grafik-Objekten
rm(grafik6, grafik7)# BIVARIATE ANALYSE
# Spannend wird es nun mit den bivariaten Analysen. Wir knüpfen bei der letzten Grafik an und verbinden
# die angefragte Kredithöhe mit dem Haushaltseinkommen (JointIncome) -> Die Grafik wird einem bekannt
# vorkommen. Es ist diejenige, welche wir im 01_import_preprocess bereits für die Imputation mittels
# linearer Regression erstellt haben. -> Hier wird sie noch etwas (optisch) verfeinert.
train %>%
ggplot(aes(JointIncome, LoanAmount)) +
geom_point() +
theme_minimal() +
scale_x_log10() +
geom_smooth(method = "lm", se=FALSE) +
labs(title = "Gegenüberstellung Gesamteinkommen vs. Kredithöhe",
x = "Einkommen - Achse log(10) skaliert",
y = "Kredithöhe") +
theme(plot.title=element_text(hjust=0.5)) +
theme(axis.title.y = element_text(angle = 0,
vjust = 0.5)) +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 10, unit = "pt"))
# Erweiterung von der vorherigen Grafik mit der Färbung nach Kreditstatus
# Multivariate Grafik x-Achse: JointIncome / y-Achse: LoanAmount und Färbung nach Kreditstatus
ggplot(train, aes(x = JointIncome, y = LoanAmount, color = Loan_Status)) +
geom_point(alpha = 0.6) + # alpha für Transparenz, damit überlappende Punkte sichtbar sind
theme_minimal() +
labs(title = "Gegenüberstellung Gesamteinkommen vs. Kredithöhe", x = "Einkommen - Achse log(10) skaliert", y = "Kredithöhe", color = "Kreditstatus") +
theme(plot.title=element_text(hjust=0.5)) +
scale_x_log10() +
geom_smooth(method = "lm", se = FALSE) + # Linien für lineare Modelle
scale_color_manual(name = "Kreditstatus",
values = c("N" = "Red", "Y" = "Steelblue"),
labels = c("N" = "Abgelehnt", "Y" = "Angenommen")) +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 10, unit = "pt"))
# Wir sehen im unteren Bereich bis ca. 100'000 einen leichten linearen Zusammenhang, danach gibt es mehrere Ausreisser nach oben.
# Diese Ausreisser ziehen auch v.a. die blaue Kurve sicherlich etwas nach oben
# Im Unteren Bereich, bei geringen Einkommen, können wir gut erkennen, dass dort hohe Kreditanträge (zumindest in Relation zu den Einkommen)
# oft abgelehnt wurden, wohingegen die Anträge mit tiefen Kredithöhen grundsätzlich angenommen wurden.# Gruppiertes Balkendiagramm (relativ)
# Gegenüberstellung Kredithistorie vs. Kreditentscheid
# Eine wesentliche Erkenntnis haben wir bei folgender Grafik erhalten.
# Gemäss Beschrieb auf Kaggle beschreibt die Credit_History, ob diese
# die Richtlinien der Bank erfüllen. -> Das Ergebnis aus folgender bivariaten
# Analyse zeigt, dass diese Variable einen zentralen Einfluss auf die Annahme /
# Ablehnung eines Antrages hat.
train_grafik10 <- train %>%
count(Credit_History, Loan_Status) %>%
group_by(Credit_History) %>%
mutate(Prop = n / sum(n)) %>%
ungroup()
ggplot()+
geom_bar(data=train, aes(x = Credit_History, fill = Loan_Status),
position = "fill") +
theme_minimal() +
labs(title = "Gegenüberstellung Kredithistorie vs. Kreditentscheid",
x = "", y = "Relativer Anteil") +
theme(plot.title=element_text(hjust=0.5)) +
geom_text(data = train_grafik10,
aes(x = Credit_History, y = Prop, label = scales::percent(Prop), group = Loan_Status),
position = position_fill(vjust = 0.5),
color = "white", size = 3.5) +
scale_x_discrete(breaks = c("0", "1"),
labels=c("Weicht von den Richtlinien ab", "Erfüllt die Richtlinien")) +
scale_y_continuous(labels = percent_format(accuracy = 1)) +
scale_fill_discrete(name = "Kreditstatus", breaks=c("N","Y"),
labels=c("Abgelehnt", "Angenommen")) +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 20, unit = "pt"))
# Löschen des für die Grafik erstellten dataFrames aus dem Environment
rm(train_grafik10)# Boxplot: Gegenüberstellung Gesamteinkommen vs. Wohnort (ländlich, agglomeration, städtisch)
ggplot()+
geom_boxplot(data=train, aes(x = Property_Area, y = JointIncome, fill = Property_Area)) + #NEU x-Achse unterscheidet nun nach Feiertag und gefüllt wird auch nach diesen
labs(title = "Gegenüberstellung Gesamteinkommen vs. Wohnort (ländlich, agglomeration, städtisch)",
x = "",
y = "Gesamteinkommen - Achse log(10) skaliert") +
scale_y_log10() +
theme(plot.title = element_text(hjust = 0.5),
axis.text.x = element_text(angle = 60, vjust = 1, hjust = 1)) +
theme(legend.position = "none") +
scale_x_discrete(breaks = c("Rural", "Semiurban", "Urban"),
labels=c("Ländlich", "Agglomeration", "Städtisch")) +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 10, unit = "pt"))
# Die Grafiken (Boxen) sehen sehr ähnlich aus, es gibt keine markanten Unterschiede
# in den Gesamteinkommen. In den Agglomeraten und städtischen Regionen gibt es aber
# gegen oben ein paar extremere Ausreisser. Die Top-Verdiener leben somit tendenziell
# eher in der Agglomeration oder der Stadt.# Gruppiertes Balkendiagramm (relativ)
# Gegenüberstellung Anstellungsverhältnis vs. Kreditentscheid
train_grafik12 <- train %>%
count(Self_Employed, Loan_Status) %>%
group_by(Self_Employed) %>%
mutate(Prop = n / sum(n)) %>%
ungroup()
ggplot()+
geom_bar(data=train, aes(x = Self_Employed, fill = Loan_Status),
position = "fill") +
theme_minimal() +
labs(title = "Gegenüberstellung Anstellungsverhältnis vs. Kreditentscheid",
x = "", y = "Relativer Anteil") +
theme(plot.title=element_text(hjust=0.5)) +
geom_text(data = train_grafik12,
aes(x = Self_Employed, y = Prop, label = scales::percent(Prop), group = Loan_Status),
position = position_fill(vjust = 0.5),
color = "white", size = 3.5) +
scale_x_discrete(breaks = c("No", "Yes"),
labels=c("Angestellt", "Selbständig")) +
scale_y_continuous(labels = percent_format(accuracy = 1)) +
scale_fill_discrete(name = "Kreditstatus", breaks=c("N","Y"),
labels=c("Abgelehnt", "Angenommen")) +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 20, unit = "pt"))
# Wir erkennen hier einen Unterschied. Die Ablehnungsrate ist bei den selbständigen etwas höher als bei den Angestellten.
#Löschen des für die Grafik erstellten dataFrames aus dem Environment entfernen
rm(train_grafik12)# *****************************************************
# 4. Zwischenresultate speichern ----------------------
# Wir speichern 'train' in dem Ordner 'zwischenresultate'
# write_rds(train, "zwischenresultate/train.rds")
# Den Datensatz 'test' haben wir bereits oben abgespeichert und entfernt.
3. Feature Engineering & Cleaning
# *****************************************************
# ----------------- Home Loan Approval ----------------
# Beschreibung: Feature Engineering & Data Cleaning
# *****************************************************
# 1. Vorarbeiten --------------------------------------
# Workspace aufräumen
rm(list = ls())
# Lade Software aus R Packages
library(tidyverse)
library(tidymodels)
library(corrplot)
# Lade Zwischenresultate
train1 <- read_rds("zwischenresultate/train.rds")# *****************************************************
# 2. Feature Engineering-------------------------------
# Die Variable Joint Income wurde bereits im R-Skript 01_import_preprocess erstellt,
# da dies aus unserer Sicht für diverse vorherige Schritte bereits Sinn ergeben hat.
# Im Folgen fügen wir 4 neue Variablen hinzu:
# MonthlyPayment -> Zeigt die monatliche Rückzahlungshöhe (Zins + Amortisation)
# PaymentIncomeRatio -> Verhältniss der Rückzahlungshöhe zum gemeinsamen Einkommen
# BooleanDependents -> Klassifizierung in Dependents "Ja" oder "Nein"
train1 <- train1 %>%
mutate(MonthlyPayment = LoanAmount*1000/Loan_Amount_Term,
PaymentIncomeRatio = MonthlyPayment/JointIncome,
BooleanDependents = as.factor(ifelse(Dependents == 0, "No", "Yes")))ggplot()+
geom_boxplot(data=train1, aes(x = Loan_Status, y = MonthlyPayment, fill = Loan_Status)) + #NEU x-Achse unterscheidet nun nach Feiertag und gefüllt wird auch nach diesen
labs(title = "Gegenüberstellung Monaltiche Zahlungen vs. Kreditentscheid",
x = "",
y = "Monatliche Zahlungen - Achse log(10) skaliert") +
scale_y_log10() +
theme(plot.title = element_text(hjust = 0.5)) +
theme(legend.position = "none") +
scale_x_discrete(breaks = c("N", "Y"),
labels=c("Abgelehnt", "Angenommen")) +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 10, unit = "pt"))
# Bei Betrachtung der Grafik zwischen dem monatlichen Zahlbetrag und dem Antragsentscheid kann man keine
# eindeutigen Unterschiede erkennen. Was wir sehen können ist, dass es bei den abgelehnten Anträgen ein
# paar mehr Ausreisser nach unten gibt. Bei den angenommenen Anträgen ein paar mehr nach oben.
# Wichtig wird eher der Vergleich zum Einkommen. Wenn man ein höheres Einkommen hat, kann man
# sich auch eine höhere monaltiche Zahlung leisten, weshalb nicht per se gesagt werden kann, dass
# ein höherer monatlicher Zahlbetrag eher zu einer Ablehnung führt.ggplot(train1, aes(x = JointIncome, y = MonthlyPayment, color = Loan_Status)) +
geom_point(alpha = 0.6) + # alpha für Transparenz, damit überlappende Punkte sichtbar sind
labs(x = "Einkommen - Achse: log(10) transformiert", y = "Monatliche Zahlungen", color = "Kreditstatus") +
theme_minimal() +
scale_x_log10() +
scale_y_log10() +
geom_smooth(method = "lm", se = FALSE) + # Linien für lineare Modelle
scale_color_manual(name = "Kreditstatus",
values = c("N" = "Red", "Y" = "Steelblue"),
labels = c("N" = "Abgelehnt", "Y" = "Angenommen")) +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 10, unit = "pt"))
# Auf der linken Seite sehen wir zuerst ein paar rote Punkte, dort wird das Einkommen zu tief sein
# für eine Annahme des Antrages.
# Die Ergebnisse sind aber eher durchmischt.
# Beachten muss man sicher, dass wir hier nur zwei Variablen miteinander anschauen, für eine
# Annahme/Ablehnung des Antrages werden noch weitere einen wesentlichen Einfluss haben
# Beachten muss man auch, dass wohl noch ein paar fehlerhafte Eingaben in den Daten sind z.B.
# eine monatliche Zahlrate von 9'250 vs. ein Einkommen von ca. 7'500.- (welcher sogar angenommen wurde)ggplot()+
geom_boxplot(data=train1, aes(x = Loan_Status, y = PaymentIncomeRatio, fill = Loan_Status)) + #NEU x-Achse unterscheidet nun nach Feiertag und gefüllt wird auch nach diesen
labs(title = "Gegenüberstellung Einkommen-Rückzahlungs-Ratio vs. Kreditentscheid",
x = "",
y = "Einkommen-Rückzahlungs-Ratio log(10) transformiert") +
scale_y_log10() +
theme(plot.title = element_text(hjust = 0.5)) +
theme(legend.position = "none") +
scale_x_discrete(breaks = c("N", "Y"),
labels=c("Abgelehnt", "Angenommen")) +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 10, unit = "pt"))
# Wir sehen auch bei der Einkommen-Rückzahluns-Ratio eher ein ähnliches Bild.
# Ein paar Ausreisser (v.a. oben, aber auch unten) fallen sehr stark auf.
# z.B. ein Ratio von ca. 1.25 wie oben bereits zahlenmässig erwähnt (9'250 Rückzahlungsbetrag)
# bei ca. 7'500 Einkommen, deutet auf eine fehlerhafte Eingabe hin.
# Aber auch hier lässt sich nicht eindeutig sagen, dass es einen erkennbaren Unterschied gibt
# zwischen den angenommenen und abgelehnten Anträgen anhand der Einkommen-Rückzahlungs-Ratiotrain1_grafik4 <- train1 %>%
count(BooleanDependents, Loan_Status) %>%
group_by(BooleanDependents) %>%
mutate(Prop = n / sum(n)) %>%
ungroup()ggplot() +
geom_bar(data=train1, aes(x = BooleanDependents, fill = Loan_Status),
position = "fill") +
theme_minimal() +
labs(title = "Gegenüberstellung abhängiger Personen im Haushalt (z.B. Kinder) vs. Kreditentscheid",
x = "", y = "") +
theme(plot.title=element_text(hjust=0.5)) +
geom_text(data = train1_grafik4,
aes(x = BooleanDependents, y = Prop, label = scales::percent(Prop), group = Loan_Status),
position = position_fill(vjust = 0.5),
color = "white", size = 3.5) +
scale_x_discrete(breaks = c("Yes", "No"),
labels=c("Vorhanden", "Nicht vorhanden")) +
scale_y_continuous(labels = percent_format(accuracy = 1)) +
scale_fill_discrete(name = "Kreditstatus", breaks=c("N","Y"),
labels=c("Abgelehnt", "Angenommen")) +
coord_flip() +
theme(plot.margin = margin(t = 20, r = 20, b = 20, l = 20, unit = "pt"))
# Auch hier erkennen wir praktisch keine Unterschiede.
# Eine wesenltiche Erkenntnis nach dem Feature Engineering und der explorativen Analyse ist,
# dass vor allem die Variable Credit_History (ob die Historie die Richtlinien der Bank erfüllt oder nicht)
# visuell einen erheblichen Zusammenhang zur Annahme oder Ablehnung des Antrages beiträgt.
#Löschen des für die Grafik erstellten Data Frames
rm(train1_grafik4)# Second Feature Engineering (Zum austesten)
train1 <- train1 %>% mutate(JointIncome_log = log10(JointIncome))# *****************************************************
# 3. Cleaning Up --------------------------------------
# Über str() verschaffen wir uns nochmals einen Überblick über die Variablen
str(train1)tibble [460 × 18] (S3: tbl_df/tbl/data.frame)
$ Loan_ID : chr [1:460] "LP001003" "LP001029" "LP001036" "LP001038" ...
$ Gender : Factor w/ 2 levels "Female","Male": 2 2 1 2 2 2 2 2 2 2 ...
..- attr(*, "imputed")= int [1:13] 24 127 172 189 315 335 461 468 478 508 ...
..- attr(*, "names")= chr [1:460] "2" "14" "18" "19" ...
$ Married : Factor w/ 2 levels "No","Yes": 2 1 1 2 2 2 2 2 1 1 ...
..- attr(*, "imputed")= int [1:3] 105 229 436
..- attr(*, "names")= chr [1:460] "2" "14" "18" "19" ...
$ Dependents : Factor w/ 4 levels "0","1","2","3+": 2 1 1 1 1 1 3 2 1 2 ...
..- attr(*, "imputed")= int [1:15] 103 105 121 227 229 294 302 333 336 347 ...
..- attr(*, "names")= chr [1:460] "2" "14" "18" "19" ...
$ Education : Factor w/ 2 levels "Graduate","Not Graduate": 1 1 1 2 2 2 2 1 1 1 ...
$ Self_Employed : Factor w/ 2 levels "No","Yes": 1 1 1 1 1 1 1 1 1 2 ...
..- attr(*, "imputed")= int [1:32] 12 20 25 30 31 96 108 112 115 159 ...
..- attr(*, "names")= chr [1:460] "2" "14" "18" "19" ...
$ ApplicantIncome : num [1:460] 4583 1853 3510 4887 7660 ...
$ CoapplicantIncome : num [1:460] 1508 2840 0 0 0 ...
$ LoanAmount : num [1:460] 128 114 76 133 104 116 112 201 74 106 ...
$ Loan_Amount_Term : 'impute' Named num [1:460] 360 360 360 360 360 360 360 360 360 360 ...
..- attr(*, "names")= chr [1:460] "2" "14" "18" "19" ...
..- attr(*, "imputed")= int [1:9] 11 29 86 98 99 164 165 228 242
$ Credit_History : Factor w/ 2 levels "0","1": 2 2 1 2 1 1 1 2 2 2 ...
..- attr(*, "imputed")= int [1:50] 17 25 31 43 80 84 87 96 118 126 ...
..- attr(*, "names")= chr [1:460] "2" "14" "18" "19" ...
$ Property_Area : Factor w/ 3 levels "Rural","Semiurban",..: 1 1 3 1 3 2 1 3 3 1 ...
$ Loan_Status : Factor w/ 2 levels "N","Y": 1 1 1 1 1 1 1 1 1 1 ...
$ JointIncome : num [1:460] 6091 4693 3510 4887 7660 ...
$ MonthlyPayment : 'impute' Named num [1:460] 356 317 211 369 289 ...
..- attr(*, "imputed")= int [1:9] 11 29 86 98 99 164 165 228 242
..- attr(*, "names")= chr [1:460] "2" "14" "18" "19" ...
$ PaymentIncomeRatio: 'impute' Named num [1:460] 0.0584 0.0675 0.0601 0.0756 0.0377 ...
..- attr(*, "imputed")= int [1:9] 11 29 86 98 99 164 165 228 242
..- attr(*, "names")= chr [1:460] "2" "14" "18" "19" ...
$ BooleanDependents : Factor w/ 2 levels "No","Yes": 2 1 1 1 1 1 2 2 1 2 ...
$ JointIncome_log : num [1:460] 3.78 3.67 3.55 3.69 3.88 ...# Keine Notwendigkeit für ein clean up sehen wir bei:
# "Loan_ID" -> Informativ (wird dann bei Recipe ausgeschlossen)
# "Gender" -> Gut, 2 Levels: Männlich, weiblich
# "Married" -> Gut, 2 Levels: Yes, No
# "Dependents" -> Gut, 4 Levels: 0, 1, 2, 3+
# 3+ für drei oder mehr belassen wir, da wir es als Faktor klassifiziert haben
# "Education" -> Gut, 2 Levels: Graduate, Not Graduate
# "Self_Employed" -> Gut, 2 Levels Yes, No
# "Credit_History" -> Gut, 2 Levels 0 (erfüllt die Richtlinien NICHT), 1 (erfüllt die Richtlinien)
# "Property_Area" -> Gut, 3 Levels Rural, Semiurban, Urban
# "Loan_Status" -> Informativ (wird dann bei Recipe ausgeschlossen)
# BooleanDependents -> Gut, 2 Levels Yes, No#Wir schauen uns nun die anderen Variablen an:
summary(train1$ApplicantIncome) Min. 1st Qu. Median Mean 3rd Qu. Max.
150 2891 3812 5182 5746 51763 summary(train1$CoapplicantIncome) Min. 1st Qu. Median Mean 3rd Qu. Max.
0 0 1036 1592 2209 41667 summary(train1$JointIncome) Min. 1st Qu. Median Mean 3rd Qu. Max.
1880 4164 5394 6774 7495 51763 # Wir sehen eine grosse Range, was mit fehlerhaften Eingaben zusammenhangen könnte# Kurze Boxplot-Betrachtung
ggplot()+
geom_boxplot(data=train1, aes(x = JointIncome))
# Es gibt extrem grosse Ausreisser nach oben
# Wir treffen die Entscheidung Werte auszuschliessen, welche dem 10-fachen des IQA entsprechen
# Normalerweise gilt ein Wert als Ausreisser ab 1.5
# Damit soll der Effekt begrenzt werden, dass extrem hohe Werte das Ergebnis beeinflussen z.B.
# weil das jährliche statt monatliche Gehalt eingegeben wurde.
iqr <- IQR(train1$JointIncome)
train1 %>%
filter(JointIncome > 10*iqr) %>%
select(JointIncome, PaymentIncomeRatio, LoanAmount, Loan_Amount_Term, MonthlyPayment, Loan_Status)# A tibble: 6 × 6
JointIncome PaymentIncomeRatio LoanAmount Loan_Amount_Term MonthlyPayment
<dbl> <dbl> <dbl> <dbl> <dbl>
1 33846 0.0213 260 360 722.
2 35673 0.00701 90 360 250
3 42083 0.0462 350 180 1944.
4 39999 0.0833 600 180 3333.
5 51763 0.0451 700 300 2333.
6 37719 0.0112 152 360 422.
# ℹ 1 more variable: Loan_Status <fct>summary(train1$LoanAmount) Min. 1st Qu. Median Mean 3rd Qu. Max.
9.0 101.8 128.0 143.8 163.2 700.0 train1 %>%
select(LoanAmount, Loan_Amount_Term, JointIncome, Loan_Status, MonthlyPayment, PaymentIncomeRatio) %>%
arrange(LoanAmount)# A tibble: 460 × 6
LoanAmount Loan_Amount_Term JointIncome Loan_Status MonthlyPayment
<dbl> <dbl> <dbl> <fct> <dbl>
1 9 360 2378 N 25
2 17 120 2385 Y 142.
3 25 120 3459 Y 208.
4 26 360 6500 Y 72.2
5 28.5 360 2000 N 79.2
6 40 360 13262 Y 111.
7 40 180 4106 Y 222.
8 42 180 3716 Y 233.
9 44 360 5649 Y 122.
10 45 360 3934 Y 125
# ℹ 450 more rows
# ℹ 1 more variable: PaymentIncomeRatio <dbl># Die Range geht von 9'000 bis 700'000
# Wir erachten v.a. die extrem tiefen LoanAmounts, als etwas merkwürdig.
# Wir werden später diese nochmals betrachten beim MonthlyPayment, denn
# dort wird nicht nur die absolute Summe betrachtet, sondern in Abhängigkeit
# von der Laufzeit.
summary(train1$Loan_Amount_Term)
9 values imputed to 360 Min. 1st Qu. Median Mean 3rd Qu. Max.
12.0 360.0 360.0 342.5 360.0 480.0 table(train1$Loan_Amount_Term)
12 36 60 84 120 180 240 300 360 480
1 2 2 3 2 32 3 10 392 13 # Die Range geht von 12 Monaten bis 480
# Davon ist ein Eintrag bei 12 Monaten und 2 bei 36 Monaten (3 Beobachtungen von Total 614)
# Wenn wir dazu die Rückzahlungsbeträge anschauen, scheinen diese extrem hoch. Ebenfalls
# erachten wir so kurze Hypothekarkredite als unwahrscheinlich, v.a. im Vergleich zu allen
# anderen Hypothekarlaufzeiten.
# Aus diesem Grund entschliessen wir uns alle Werte mit einer Laufzeit unter 60 Monaten (5 Jahre)
# auszuschliessen. In der Praxis könnte man natürlich bei der Bank anfragen, was die Mindestlaufzeit ist.# Die besprochenen Zeilen anschauen:
train1 %>%
filter(Loan_Amount_Term <60) %>%
select(Loan_Amount_Term, LoanAmount, MonthlyPayment, JointIncome, PaymentIncomeRatio, Loan_Status)# A tibble: 3 × 6
Loan_Amount_Term LoanAmount MonthlyPayment JointIncome PaymentIncomeRatio
<dbl> <dbl> <dbl> <dbl> <dbl>
1 36 155 4306. 3481 1.24
2 36 80 2222. 3358 0.662
3 12 111 9250 7482 1.24
# ℹ 1 more variable: Loan_Status <fct>summary(train1$MonthlyPayment)
Imputed Values:
37 113 368 422 424 45 46 166
277.7778 422.2222 344.4444 222.2222 305.5556 266.6667 244.4444 505.5556
198
333.3333 Min. 1st Qu. Median Mean 3rd Qu. Max.
25.0 288.9 362.5 477.9 500.0 9250.0 train1 %>%
select(MonthlyPayment, LoanAmount, Loan_Amount_Term, JointIncome, Loan_Status, PaymentIncomeRatio) %>%
arrange(MonthlyPayment)# A tibble: 460 × 6
MonthlyPayment LoanAmount Loan_Amount_Term JointIncome Loan_Status
<dbl> <dbl> <dbl> <dbl> <fct>
1 25 9 360 2378 N
2 72.2 26 360 6500 Y
3 79.2 28.5 360 2000 N
4 111. 40 360 13262 Y
5 122. 44 360 5649 Y
6 125 45 360 3934 Y
7 128. 46 360 2378 N
8 131. 47 360 3013 Y
9 131. 63 480 2237 N
10 133. 48 360 4885 Y
# ℹ 450 more rows
# ℹ 1 more variable: PaymentIncomeRatio <dbl># Wir definieren nun, dass eine angenommene Hypotheksumme von 20'000 über 30 Jahre das Minimum darstellt
# Dies würde ein monatlicher Zahlbetrag von 56.- ergeben. Wir beschliessen hiermit die Werte auszuschliessen,
# welche diesen Betrag monatlich unterschreiten.# Die besprochenen Zeilen anschauen:
train1 %>%
filter(MonthlyPayment < 56) %>%
select(MonthlyPayment, Loan_Amount_Term, LoanAmount, JointIncome, PaymentIncomeRatio, Loan_Status)# A tibble: 1 × 6
MonthlyPayment Loan_Amount_Term LoanAmount JointIncome PaymentIncomeRatio
<dbl> <dbl> <dbl> <dbl> <dbl>
1 25 360 9 2378 0.0105
# ℹ 1 more variable: Loan_Status <fct>summary(train1$PaymentIncomeRatio)
Imputed Values:
37 113 368 422 424 45 46
0.08796003 0.05493393 0.06722179 0.08169935 0.03426663 0.05679801 0.07168459
166 198
0.07355675 0.07802747 Min. 1st Qu. Median Mean 3rd Qu. Max.
0.007008 0.056381 0.069371 0.078921 0.081404 1.236873 # aufsteigend:
train1 %>%
select(PaymentIncomeRatio, LoanAmount, Loan_Amount_Term, MonthlyPayment, JointIncome, Loan_Status) %>%
arrange(PaymentIncomeRatio)# A tibble: 460 × 6
PaymentIncomeRatio LoanAmount Loan_Amount_Term MonthlyPayment JointIncome
<dbl> <dbl> <dbl> <dbl> <dbl>
1 0.00701 90 360 250 35673
2 0.00838 40 360 111. 13262
3 0.00969 55 360 153. 15759
4 0.0105 9 360 25 2378
5 0.0111 26 360 72.2 6500
6 0.0112 152 360 422. 37719
7 0.0127 103 360 286. 22500
8 0.0131 70 360 194. 14866
9 0.0179 96 360 267. 14880
10 0.0183 110 360 306. 16692
# ℹ 450 more rows
# ℹ 1 more variable: Loan_Status <fct># erachten wir als plausibel (konservativ betrachtet)# absteigend:
train1 %>%
select(PaymentIncomeRatio, LoanAmount, Loan_Amount_Term, MonthlyPayment, JointIncome, Loan_Status) %>%
arrange(desc(PaymentIncomeRatio))# A tibble: 460 × 6
PaymentIncomeRatio LoanAmount Loan_Amount_Term MonthlyPayment JointIncome
<dbl> <dbl> <dbl> <dbl> <dbl>
1 1.24 155 36 4306. 3481
2 1.24 111 12 9250 7482
3 0.662 80 36 2222. 3358
4 0.355 108 84 1286. 3620
5 0.298 144 84 1714. 5746
6 0.298 155 60 2583. 8666
7 0.293 125 60 2083. 7100
8 0.281 172 84 2048. 7283
9 0.192 135 360 375 1950
10 0.173 140 180 778. 4493
# ℹ 450 more rows
# ℹ 1 more variable: Loan_Status <fct># Wir erkennen hier teils sehr hohe oder sogar komplett unrealistische Werte (>1)
# Wir entschliessen uns alle Werte auszuschliessen, welche über 50% ausmachen
# Gemäss Internetrecherche sollten die Zahlungen nicht mehr als ca. 30% ausmachen
# Interessant ist hier ebenfalls, dass wir wieder die Werte 12 und 36 sehen.
# Wir könnten uns durchaus vorstellen, dass diese 120 oder 360 hätten sein sollen.# Die besprochenen Zeilen anschauen:
train1 %>%
filter(PaymentIncomeRatio > 0.5) %>%
select(PaymentIncomeRatio, LoanAmount, Loan_Amount_Term, MonthlyPayment, JointIncome, Loan_Status)# A tibble: 3 × 6
PaymentIncomeRatio LoanAmount Loan_Amount_Term MonthlyPayment JointIncome
<dbl> <dbl> <dbl> <dbl> <dbl>
1 1.24 155 36 4306. 3481
2 0.662 80 36 2222. 3358
3 1.24 111 12 9250 7482
# ℹ 1 more variable: Loan_Status <fct># Wir schliessen nun die oben erwähnten Zeilen aus (dataCleaning):
# Ausschliessen
train1 <- train1 %>%
filter(JointIncome < 10*iqr,
Loan_Amount_Term >= 60,
MonthlyPayment >= 56,
PaymentIncomeRatio <= 0.5)
# In diesem Beispiel entfernen wir 10 von 460 Werten, was wir mit einem konservativen Ansatz gleichstellen.
# Wir können nun noch den iqr entfernen
rm(iqr)# Korrelationsmatrix
train1 %>%
select(-Loan_ID, -JointIncome, -MonthlyPayment, -PaymentIncomeRatio, -BooleanDependents) %>%
mutate(Gender = as.integer(Gender),
Married = as.integer(Married),
Dependents = as.integer(Dependents),
Education = as.integer(Education),
Self_Employed = as.integer(Self_Employed),
ApplicantIncome = as.integer(ApplicantIncome),
CoapplicantIncome = as.integer(CoapplicantIncome),
LoanAmount = as.integer(LoanAmount),
Loan_Amount_Term = as.integer(Loan_Amount_Term),
Credit_History = as.integer(Credit_History),
Property_Area = as.integer(Property_Area),
Loan_Status = as.integer(Loan_Status),
JointIncome_log = as.integer(JointIncome_log)) %>%
select(Loan_Status, everything()) %>%
cor(use = "complete.obs", method = "spearman") %>%
corrplot(type = "lower", diag = FALSE, tl.col = "black", tl.cex = 0.7)
# Wir entfernen im ersten Schritt die nicht relevanten Variablen: Loan_ID: Keine Aussagekraft, JointIncome -> Ist eine Zusammensetzung
# aus ApplicantIncome und Coapplicantincome (welche wir separat hineinnehmen um allfällige Korrelationen dort zu erkennen).
# MonthlyPayment und PaymentIncomeRatio entfernen wir ebenfalls, da sie einfach in anderer Form Aussagen zu bereits bestehenden Variabeln machen.
# BolleanDependents fliesst über die Ursprungsvariable Dependents detaillierter ein.
# Wenn wir die erste Spalte betrachten, also wie Loan_Status korreliert ist mit anderen Variablen, sehen wir, dass sie sehr stark Korreliert
# mit der Credit_History (was wir auch bei der explorativen Analyse erkannt haben), sowie ebenfalls leicht korreliert mit der Education und dem Zivilstand.# *****************************************************
# 4. Zwischenresultate speichern ----------------------
# Wir speichern 'train1' in dem Ordner 'Zwischenresultate'.
# write_rds(train1, "zwischenresultate/train1.rds")
4. Modelling
# *****************************************************
# ----------------- Home Loan Approval ----------------
# Beschreibung: Modelling
# *****************************************************
# 1. Vorarbeiten --------------------------------------
# Workspace aufräumen
rm(list = ls())
# Lade Software aus R Packages
library(tidyverse)
library(tidymodels)
library(vetiver) # Um das finale Modell zu exportieren.
# Lade Zwischenresultate
train2 <- read_rds("zwischenresultate/train1.rds")
test2 <- read_rds("zwischenresultate/test.rds")# *****************************************************
# 2. test2 analog zu train2 aufbauen ------------------
# Feature Engineering auf Testdatensatz anwenden
test2 <- test2 %>%
mutate(MonthlyPayment = LoanAmount*1000/Loan_Amount_Term,
PaymentIncomeRatio = MonthlyPayment/JointIncome,
BooleanDependents = as.factor(ifelse(Dependents == 0, "No", "Yes")),
JointIncome_log = log10(JointIncome))
# Data Cleaning auf Testdatensatz anwenden
iqr <- IQR(test2$JointIncome)
test2 <- test2 %>%
filter(JointIncome < 10*iqr,
Loan_Amount_Term >= 60,
MonthlyPayment >= 56,
PaymentIncomeRatio <= 0.5)
# Es werden hier 4 von 154 Werte entfernt, was ebenfalls als konservativ zu betrachten ist.
rm(iqr)# *****************************************************
# 3. Recipe erstellen ---------------------------------
#Loan_Amount_Term, MonthlyPayment, PaymentIncomeRatio -> Umwandlung in Double (ist später notwendig)
train2$Loan_Amount_Term <- as.double(train2$Loan_Amount_Term)
train2$MonthlyPayment <- as.double(train2$MonthlyPayment)
train2$PaymentIncomeRatio <- as.double(train2$PaymentIncomeRatio)
train2$JointIncome_log <- as.double(train2$JointIncome_log)
test2$Loan_Amount_Term <- as.double(test2$Loan_Amount_Term)
test2$MonthlyPayment <- as.double(test2$MonthlyPayment)
test2$PaymentIncomeRatio <- as.double(test2$PaymentIncomeRatio)
test2$JointIncome_log <- as.double(test2$JointIncome_log)
# Als erstes schauen wir uns nochmal die Datentypen der Spalten genau an.
glimpse(train2)Rows: 450
Columns: 18
$ Loan_ID <chr> "LP001003", "LP001029", "LP001036", "LP001038", "LP…
$ Gender <fct> Male, Male, Female, Male, Male, Male, Male, Male, M…
$ Married <fct> Yes, No, No, Yes, Yes, Yes, Yes, Yes, No, No, Yes, …
$ Dependents <fct> 1, 0, 0, 0, 0, 0, 2, 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, …
$ Education <fct> Graduate, Graduate, Graduate, Not Graduate, Not Gra…
$ Self_Employed <fct> No, No, No, No, No, No, No, No, No, Yes, No, No, No…
$ ApplicantIncome <dbl> 4583, 1853, 3510, 4887, 7660, 2600, 3365, 4166, 316…
$ CoapplicantIncome <dbl> 1508, 2840, 0, 0, 0, 1911, 1917, 3369, 0, 0, 1330, …
$ LoanAmount <dbl> 128.0000, 114.0000, 76.0000, 133.0000, 104.0000, 11…
$ Loan_Amount_Term <dbl> 360, 360, 360, 360, 360, 360, 360, 360, 360, 360, 3…
$ Credit_History <fct> 1, 1, 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 1, 0, 1, 0, 0, …
$ Property_Area <fct> Rural, Rural, Urban, Rural, Urban, Semiurban, Rural…
$ Loan_Status <fct> N, N, N, N, N, N, N, N, N, N, N, N, N, N, N, N, N, …
$ JointIncome <dbl> 6091, 4693, 3510, 4887, 7660, 4511, 5282, 7535, 316…
$ MonthlyPayment <dbl> 355.5556, 316.6667, 211.1111, 369.4444, 288.8889, 3…
$ PaymentIncomeRatio <dbl> 0.05837392, 0.06747638, 0.06014562, 0.07559739, 0.0…
$ BooleanDependents <fct> Yes, No, No, No, No, No, Yes, Yes, No, Yes, No, No,…
$ JointIncome_log <dbl> 3.784689, 3.671451, 3.545307, 3.689042, 3.884229, 3…# Recipe aufsetzen
status_rec <-
recipe(Loan_Status ~ ., data = train2) %>%
update_role(Loan_ID, new_role = "ID") %>% # Weist der Loan_ID den Typ "ID"-zu
step_dummy(all_nominal_predictors(), one_hot = TRUE) %>% # Führt ein One-Hot-Encoding durch
step_zv(all_predictors()) %>% # Entfernt 'zero-variance' Variablen.
step_normalize(all_predictors()) # Standardisiert alle numerischen Variablen# Zusammenfassung des 'recipe'
summary(status_rec) %>%
print(n = 18)# A tibble: 18 × 4
variable type role source
<chr> <list> <chr> <chr>
1 Loan_ID <chr [3]> ID original
2 Gender <chr [3]> predictor original
3 Married <chr [3]> predictor original
4 Dependents <chr [3]> predictor original
5 Education <chr [3]> predictor original
6 Self_Employed <chr [3]> predictor original
7 ApplicantIncome <chr [2]> predictor original
8 CoapplicantIncome <chr [2]> predictor original
9 LoanAmount <chr [2]> predictor original
10 Loan_Amount_Term <chr [2]> predictor original
11 Credit_History <chr [3]> predictor original
12 Property_Area <chr [3]> predictor original
13 JointIncome <chr [2]> predictor original
14 MonthlyPayment <chr [2]> predictor original
15 PaymentIncomeRatio <chr [2]> predictor original
16 BooleanDependents <chr [3]> predictor original
17 JointIncome_log <chr [2]> predictor original
18 Loan_Status <chr [3]> outcome original# *****************************************************
# 4. Cross-Validation-Split ---------------------------
# Seed für Reproduzierbarkeit
set.seed(123)
# 5-Fold CV
folds <- vfold_cv(train2, v = 5, repeats = 1, strata = Loan_Status)
# v = Anzahl Folds
# repeats = Wie oft die Cross Validation wiederholt werden soll
# strata = y : Macht einen stratifizierten Split nach Loan_Status, dass der Anteil Yes/No in jedem Fold gleich stark vorhanden ist.# *****************************************************
# 5. Logistische Regression ---------------------------
# Logistische Regression initieren
lr_mod <-
logistic_reg(penalty = tune(), mixture = tune()) %>%
set_engine("glmnet")
# logistisches Regressionsmodell initieren, getunt wird penalty und mixture
# set_engine("glmnet") -> Welches Package wir für die Modellberechnung verwenden -> glmnet berechnet regularisierte Modelle!
# Workflow
lr_workflow <-
workflow() %>%
add_model(lr_mod) %>%
add_recipe(status_rec)
# Aufsetzen des Workflows -> workflow()
# Das Modell hinzufügen add_model(lr_mod)
# recipe dazugeben
# Tuning Grid
lr_grid <- expand.grid(penalty = 10^seq(-5, 3, by = 1), mixture = c(0, 1))
#mit expand.grid alle Kombinationen durchtesten (Lambda von 10^-5 bis 10^3) + jeweils 0 oder 1 für mixture
# Wie sieht Grid aus?
print(lr_grid) penalty mixture
1 1e-05 0
2 1e-04 0
3 1e-03 0
4 1e-02 0
5 1e-01 0
6 1e+00 0
7 1e+01 0
8 1e+02 0
9 1e+03 0
10 1e-05 1
11 1e-04 1
12 1e-03 1
13 1e-02 1
14 1e-01 1
15 1e+00 1
16 1e+01 1
17 1e+02 1
18 1e+03 1# Tuning / Model Fitting
lr_res <-
lr_workflow %>%
tune_grid(
resamples = folds,
grid = lr_grid,
control = control_grid(save_pred = TRUE),
metrics = metric_set(roc_auc))
# tune_grid() -> Durchführen des Hyperparametertunings
# resamples = folds -> Die vordefinierten Folds werden genutzt, um dann jedes Parameter-Set zu evaluieren
# Übergabe des hierfür definierten grid = lr_grid
# control = control_grid(save_pred = TRUE) -> speichert die Vorhersagen für die verschiedenen Hyperparameterwerte -> benötgen wir für die spätere Berechnung der Modellgüte
# metrics = metric_set(roc_auc) -> definiert das Modellgütemass
# Wir sortieren die Hyperparameter Spezifikationen nach ROC AUC
lr_res %>%
show_best("roc_auc", n = 18) %>%
arrange(desc(mean))# A tibble: 18 × 8
penalty mixture .metric .estimator mean n std_err .config
<dbl> <dbl> <chr> <chr> <dbl> <int> <dbl> <chr>
1 0.1 0 roc_auc binary 0.752 5 0.0285 Preprocessor1_Mode…
2 0.01 1 roc_auc binary 0.751 5 0.0269 Preprocessor1_Mode…
3 0.00001 0 roc_auc binary 0.751 5 0.0278 Preprocessor1_Mode…
4 0.0001 0 roc_auc binary 0.751 5 0.0278 Preprocessor1_Mode…
5 0.001 0 roc_auc binary 0.751 5 0.0278 Preprocessor1_Mode…
6 0.01 0 roc_auc binary 0.751 5 0.0278 Preprocessor1_Mode…
7 1 0 roc_auc binary 0.746 5 0.0258 Preprocessor1_Mode…
8 0.001 1 roc_auc binary 0.746 5 0.0250 Preprocessor1_Mode…
9 0.00001 1 roc_auc binary 0.746 5 0.0245 Preprocessor1_Mode…
10 0.0001 1 roc_auc binary 0.746 5 0.0245 Preprocessor1_Mode…
11 100 0 roc_auc binary 0.744 5 0.0223 Preprocessor1_Mode…
12 10 0 roc_auc binary 0.744 5 0.0228 Preprocessor1_Mode…
13 0.1 1 roc_auc binary 0.700 5 0.0135 Preprocessor1_Mode…
14 1000 0 roc_auc binary 0.5 5 0 Preprocessor1_Mode…
15 1 1 roc_auc binary 0.5 5 0 Preprocessor1_Mode…
16 10 1 roc_auc binary 0.5 5 0 Preprocessor1_Mode…
17 100 1 roc_auc binary 0.5 5 0 Preprocessor1_Mode…
18 1000 1 roc_auc binary 0.5 5 0 Preprocessor1_Mode…# Plot der Resultate
lr_res %>%
collect_metrics() %>%
filter(.metric == "roc_auc") %>%
ggplot(aes(x = penalty, y = mean, color = factor(mixture), linetype = factor(mixture))) +
geom_point() +
geom_line() +
labs(x = "Penalty", y = "AUC ROC") +
scale_x_log10() +
theme_bw()
# Wir wählen das besten Modell
lr_best <-
lr_res %>%
show_best("roc_auc", n = 18) %>%
arrange(desc(mean)) %>%
slice(1)
# Resultate vorbereiten für Konfusionsmatrix
thres <- 0.5
lr_konfusionsmatrix <-
lr_res %>%
collect_predictions(parameters = lr_best) %>%
mutate(pred = ifelse(.pred_Y >= thres, "Y", "N"))
# Konfusionsmatrix
table(lr_konfusionsmatrix$pred, lr_konfusionsmatrix$Loan_Status, dnn = c("pred", "true")) true
pred N Y
N 58 4
Y 80 308# Wir sehen eine hohe Anzahl an False Positive (FP) fehlern, was bedeutet, dass das lineare
# Regressionsmodell einen Antrag mit Annehmen vorhersagt, obwohl er in der Realität abgelehnt
# wurde. Dies ist eher ein schlechtes Zeichen. (Wir schauen dann bei Naive Bayes nochmals)# Resultate vorbereiten für ROC Kurve
lr_auc <-
lr_res %>%
collect_predictions(parameters = lr_best) %>%
roc_curve(Loan_Status, .pred_Y, event_level = "second") %>%
mutate(model = "Logistic Regression")
# collect_predictions(parameters = lr_best) -> Extrahiert die Vorhersagen des Modells für die besten Hyperparameter-Einstellungen (lr_best), die aus dem vorherigen Hyperparametertuning ermittelt wurden.
# roc_curve -> Berechnet die ROC-Kurve für die vorhergesagten Werte und die tatsächlichen Werte (y), wobei .pred_Y die Spalte mit den vorhergesagten Wahrscheinlichkeiten für die Yes-Klasse ist. Die Option event_level = "second" bedeutet, dass Yes als zweites Level definiert ist.
# mutate(model = "Logistic Regression"): Fügt der ROC-Kurve eine Spalte hinzu, um das Modell anzugeben, das für die Kurve verwendet wurde, in diesem Fall "Logistic Regression".
# ROC Kurve
autoplot(lr_auc)
# Last Fit
# Last Fit Spezifikation (optimale Hyperparameter Werte)
last_lr_mod <-
logistic_reg(penalty = 0.1, mixture = 0) %>%
set_engine("glmnet")
# Workflow anpassen (optimales Modell)
last_lr_workflow <-
lr_workflow %>%
update_model(last_lr_mod)
# Das Modell im lr_workflow wird upgedatet durch das last_lr_mod
# Last Fit (auf ganzem Trainingsdatensatz)
last_lr_fit <-
last_lr_workflow %>%
fit(data = train2)
# Extrahieren der Parameter (Übersicht)
last_lr_fit %>%
extract_fit_parsnip() %>%
tidy() %>%
print(n = 28)# A tibble: 28 × 3
term estimate penalty
<chr> <dbl> <dbl>
1 (Intercept) 0.889 0.1
2 ApplicantIncome -0.0526 0.1
3 CoapplicantIncome -0.0130 0.1
4 LoanAmount -0.132 0.1
5 Loan_Amount_Term -0.125 0.1
6 JointIncome -0.0573 0.1
7 MonthlyPayment -0.0224 0.1
8 PaymentIncomeRatio -0.0956 0.1
9 JointIncome_log 0.0623 0.1
10 Gender_Female 0.00892 0.1
11 Gender_Male -0.00892 0.1
12 Married_No -0.0919 0.1
13 Married_Yes 0.0919 0.1
14 Dependents_X0 0.00856 0.1
15 Dependents_X1 -0.0803 0.1
16 Dependents_X2 0.0573 0.1
17 Dependents_X3. 0.0190 0.1
18 Education_Graduate 0.0414 0.1
19 Education_Not.Graduate -0.0414 0.1
20 Self_Employed_No 0.0274 0.1
21 Self_Employed_Yes -0.0274 0.1
22 Credit_History_X0 -0.466 0.1
23 Credit_History_X1 0.466 0.1
24 Property_Area_Rural -0.0892 0.1
25 Property_Area_Semiurban 0.158 0.1
26 Property_Area_Urban -0.0729 0.1
27 BooleanDependents_No 0.00861 0.1
28 BooleanDependents_Yes -0.00859 0.1# extract_fit_parsnip(): Extrahiert die Parameter des trainierten Modells in einem für das Parsnip-Paket geeigneten Format.
# tidy() %>%: Verwendet die tidy()-Funktion, um die extrahierten Modellparameter in eine saubere, tabellarische Form zu bringen.# Variable importance
# Barplot der Parameter
last_lr_fit %>%
extract_fit_parsnip() %>%
tidy() %>%
filter(abs(estimate) > 0.05 & term != "(Intercept)") %>%
mutate(pos = estimate >= 0) %>%
arrange(desc(estimate)) %>%
ggplot(aes(x = reorder(term, estimate, sort), y = estimate, fill = pos)) +
geom_bar(stat = "identity") +
coord_flip() +
labs(x = NULL, y = "Stärke des Koeffizienten") +
guides(fill = "none") +
theme_bw()
# Wir sehen, dass die Credit-History (yes / no) extrem wichtig ist
# Andere Variablen z.B. LoanAmount und Loan Amount Term wie auch Wohngegend sind ebefalls wichtig
# Danach folgend noch einige andere Variablen, mit ähnlichem Einfluss# *****************************************************
# 6. Naive Bayes --------------------------------------
# Wir laden zwei zusätzliche R-Packages
library(discrim)
library(naivebayes)
# Modell Spezifikation
nb_mod <-
naive_Bayes(Laplace = 1.0) %>%
set_engine("naivebayes")
# naive_Bayes(Laplace = 1.0) -> Inititierung Modell + Count-Initierung bei 1, damit das Problem behoben wird, dass wenn ein Spam ein Wort nicht hat, dass dann die W'keit gesamt auf 0 gesetzt wird -> wurde etwas weiter oben mal genau beschrieben.
# Package das verwendet wird -> naivebayes
train2.2 <- train2 %>% select(-Loan_ID)
test2.2 <- test2 %>% select(-Loan_ID)
# Recipe für Naive Bayes
nb_recipe <-
recipe(Loan_Status ~ ., data = train2.2) %>%
step_mutate_at(all_predictors(), fn = factor)
# Workflow für Naive Bayes
nb_workflow <-
workflow() %>%
add_model(nb_mod) %>%
add_recipe(nb_recipe)
# Model Fitting Naive Bayes
nb_fit <-
nb_workflow %>%
fit(data = train2.2)
# Schauen wir uns das Fit Objekt an
nb_fit %>%
extract_fit_parsnip()parsnip model object
================================= Naive Bayes ==================================
Call:
naive_bayes.default(x = maybe_data_frame(x), y = y, laplace = ~1,
usekernel = TRUE)
--------------------------------------------------------------------------------
Laplace smoothing: 1
--------------------------------------------------------------------------------
A priori probabilities:
N Y
0.3066667 0.6933333
--------------------------------------------------------------------------------
Tables:
--------------------------------------------------------------------------------
:: Gender (Bernoulli)
--------------------------------------------------------------------------------
Gender N Y
Female 0.1857143 0.1783439
Male 0.8142857 0.8216561
--------------------------------------------------------------------------------
:: Married (Bernoulli)
--------------------------------------------------------------------------------
Married N Y
No 0.4000000 0.3280255
Yes 0.6000000 0.6719745
--------------------------------------------------------------------------------
:: Dependents (Categorical)
--------------------------------------------------------------------------------
Dependents N Y
0 0.58450704 0.58860759
1 0.21126761 0.15506329
2 0.13380282 0.17405063
3+ 0.07042254 0.08227848
--------------------------------------------------------------------------------
:: Education (Bernoulli)
--------------------------------------------------------------------------------
Education N Y
Graduate 0.7357143 0.7961783
Not Graduate 0.2642857 0.2038217
--------------------------------------------------------------------------------
:: Self_Employed (Bernoulli)
--------------------------------------------------------------------------------
Self_Employed N Y
No 0.8285714 0.8726115
Yes 0.1714286 0.1273885
--------------------------------------------------------------------------------
# ... and 11 more tables
--------------------------------------------------------------------------------# Wir rechnen die Vorhersagen auf Training- und Testset
train2.2_pred <- predict(nb_fit, train2.2, type = "prob")
test2.2_pred <- predict(nb_fit, test2.2, type = "prob")
# Resultate vorbereiten für Konfusionsmatrix
thres <- 0.5
nb_konfusionsmatrix <-
train2.2_pred %>%
bind_cols(train2.2) %>%
mutate(pred = ifelse(.pred_Y >= thres, "Y", "N"))
# Konfusionsmatrix
table(nb_konfusionsmatrix$pred, nb_konfusionsmatrix$Loan_Status, dnn = c("pred", "true")) true
pred N Y
N 134 2
Y 4 310# Wir sehen praktisch nur True Negative und True Positive Predications. Dies ist im
# Vergleich zum logistischen Regressionsmodell viel besser. Dies sehen wir ebenfalls mit
# der nächsten Grafik zur ROC-Kurve. * Beachte die spätere Anmerkung hierzu# Resultate vorbereiten für ROC Kurve
nb_auc <-
train2.2_pred %>%
bind_cols(train2.2["Loan_Status"]) %>%
roc_curve(Loan_Status, .pred_Y, event_level = "second") %>%
mutate(model = "Naive Bayes")
# ROC Kurve
autoplot(nb_auc)
# Vergleich der ROC Kurven
bind_rows(nb_auc, lr_auc) %>%
ggplot(aes(x = 1 - specificity, y = sensitivity, col = model)) +
geom_path(linewidth = 0.7, alpha = 0.8) +
geom_abline(lty = 3) +
coord_equal() +
scale_color_viridis_d(option = "plasma", end = .6) +
theme_bw()
# Beachte: Die Naive-Bayes Kurve sieht hier viel besser aus und liefert viel bessere Ergebnisse.
# Dies werden wir später sehen, täuscht jedoch, da Naive Bays das Training auf allen Werten durchführt
# Die logistische Regression hingegen macht das Hyperparamtertuning mit 5 Cross Fold Validation Sets.
# Bedeutet jedes Mal wird mit 1/5 der Daten, welche NICHT für das Training verwendet wurden, evaluiert.
# Dies werden wir nun bei der Testset-Performance sehen.# *****************************************************
# 7. Testset-Performance ------------------------------
# Testset-Performance Last Fit (LR und NB)
test_lr_aug <- augment(last_lr_fit, test2)
test_nb_aug <- augment(nb_fit, test2.2)
# ROC AUC für Logistische Regression
test_lr_aug %>%
roc_auc(truth = Loan_Status, .pred_Y, event_level = "second")# A tibble: 1 × 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 roc_auc binary 0.810# Die Fläche unter der ROC-Kurve ist 0.810# Vergleich ROC AUC - Logistische Regression auf Train-Datensatz
last_lr_fit %>% augment(train2) %>% roc_auc(truth = Loan_Status, .pred_Y, event_level = "second")# A tibble: 1 × 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 roc_auc binary 0.803# Wir sehen auf den Train-Daten war die ROC-AUC 0.803# ROC AUC für Naive Bayes
test_nb_aug %>%
roc_auc(truth = Loan_Status, .pred_Y, event_level = "second")# A tibble: 1 × 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 roc_auc binary 0.771# Die Fläche unter der ROC-Kurve ist 0.771# Vergleich der ROC Kurven auf dem Testdatensatz
test_lr_aug %>% roc_curve(Loan_Status, .pred_Y, event_level = "second") %>% mutate(model = "logistische Regression") %>%
bind_rows(test_nb_aug %>% roc_curve(Loan_Status, .pred_Y, event_level = "second") %>% mutate(model = "Naive Bayes")) %>%
ggplot(aes(x = 1 - specificity, y = sensitivity, col = model)) +
geom_path(linewidth = 0.7, alpha = 0.8) +
geom_abline(lty = 3) +
coord_equal() +
scale_color_viridis_d(option = "plasma", end = .6) +
theme_bw()
# Wir sehen nun, dass die logistische Regression besser ist. Der Unterschied zum Vergleich der ROC-Kurven von oben (Train-Set)
# ist signifikant. Die Gründe haben wir oben bereits erwähnt.# *********************************************
# 8. Baseline-Vergleich -----------------------
# Das Verhältnis zwischen YES und NO haben wir herausgefunden beträgt 0.68 (siehe 02_split_explore)
test2 %>%
mutate(.pred_Y = 0.68) %>%
roc_auc(truth = Loan_Status, .pred_Y, event_level = "second")# A tibble: 1 × 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 roc_auc binary 0.5train2 %>%
mutate(.pred_Y = 0.68) %>%
roc_auc(truth = Loan_Status, .pred_Y, event_level = "second")# A tibble: 1 × 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 roc_auc binary 0.5# Verbesserung unseres Modelles zur Baseline
(0.810-0.5)/0.5[1] 0.62# 0.810: ROC-AUC aus unserem logistischen Regressionsmodell
# 0.5: ROC-AUC aus der Baseline oben
# Die führt zu einer Verbesserung von 62%# *****************************************************
# 9. Modell speichern ---------------------------------
# Mit dem R-Package vetiver können wir unser finales Modell
# in einer Form speichern, so dass es parat ist für das Deployment.
final_model <- vetiver_model(last_lr_fit, "last_lr_fit")
# Was für ein Objekt ist es?
final_model
── last_lr_fit ─ <bundled_workflow> model for deployment
A glmnet classification modeling workflow using 16 features# Wir speichern das Objekt anschliessend als RDS File.
# Das braucht VIEL Speicherplatz!
# write_rds(final_model, "zwischenresultate/final_model.rds")