Projekt - Model scoringowy
Mateusz Surowiec
2025-04-27
Część Opisowa
Wczytanie danych i pakietów
Sprawdzenie danych
str(Dane_projekt)## tibble [40,000 × 13] (S3: tbl_df/tbl/data.frame)
## $ LP : num [1:40000] 1 2 3 4 5 6 7 8 9 10 ...
## $ data_akceptacji : POSIXct[1:40000], format: "2005-04-17" "2005-04-17" ...
## $ grupa_ryzyka : num [1:40000] 2 2 1 1 3 1 1 2 1 3 ...
## $ kod_partnera : num [1:40000] 2 2 3 1 1 3 1 2 1 2 ...
## $ typ_umowy : chr [1:40000] "R" "N" "N" "R" ...
## $ scoring_FICO : num [1:40000] 702 719 802 723 690 681 805 726 765 693 ...
## $ okres_kredytu : num [1:40000] 48 72 60 60 72 60 36 60 60 60 ...
## $ kwota_kredytu : num [1:40000] 26500 35000 28000 20751 20000 ...
## $ oproc_refin : num [1:40000] 0.0399 0 0 0.0675 0 0 0 0.0599 0 0 ...
## $ oproc_konkur : num [1:40000] 0.0499 0.0479 0.0399 0.0499 0.0529 0.0399 0.0405 0.0499 0.0399 0.0399 ...
## $ koszt_pieniadza : num [1:40000] 0.011 0.011 0.011 0.011 0.011 0.011 0.011 0.011 0.011 0.011 ...
## $ oproc_propon : num [1:40000] 0.0659 0.0599 0.0355 0.0489 0.0679 0.0385 0.0389 0.0525 0.0385 0.0609 ...
## $ akceptacja_klienta: num [1:40000] 0 0 0 1 0 0 1 0 0 0 ...sapply(Dane_projekt, class)## $LP
## [1] "numeric"
##
## $data_akceptacji
## [1] "POSIXct" "POSIXt"
##
## $grupa_ryzyka
## [1] "numeric"
##
## $kod_partnera
## [1] "numeric"
##
## $typ_umowy
## [1] "character"
##
## $scoring_FICO
## [1] "numeric"
##
## $okres_kredytu
## [1] "numeric"
##
## $kwota_kredytu
## [1] "numeric"
##
## $oproc_refin
## [1] "numeric"
##
## $oproc_konkur
## [1] "numeric"
##
## $koszt_pieniadza
## [1] "numeric"
##
## $oproc_propon
## [1] "numeric"
##
## $akceptacja_klienta
## [1] "numeric"# Zmienne:
# data_akceptacji - data
# grupa_ryzyka - kategoria
# kod_partnera - kategoria
# typ_umowy - kategoria („N” – nowy samochód, „U” – samochód używany, „R” – refinansowanie kredytu)
# scoring_FICO - liczba
# okres_kredytu - liczba (miesiące)
# kwota_kredytu - liczba
# oproc.refin - liczba (dla typu umowy „R”)
# oproc_konkur - liczba
# koszt_pieniadza - liczba
# oproc_propon - liczba
# akceptacja_klienta - kategoria (zmienna celu -> 0 = brak akceptacji, 1 = akceptacja )
# Sprawdzenie braków
sum(is.na(Dane_projekt))## [1] 0# nie ma brakówStatystyki opisowe - dla ilościowych
zm_ilosciowe <- c("scoring_FICO", "kwota_kredytu", "oproc_konkur", "koszt_pieniadza", "oproc_propon")
oprocentowanie_refin <- Dane_projekt[Dane_projekt$typ_umowy == "R", ] # osobno, tylko dla typu umowy "R"
# Funkcja do obliczenia statystyk
calculate_stats <- function(data, var_name) {
stats <- c(
Mean = mean(data[[var_name]], na.rm = TRUE),
Median = median(data[[var_name]], na.rm = TRUE),
Max = max(data[[var_name]], na.rm = TRUE),
Min = min(data[[var_name]], na.rm = TRUE),
SD = sd(data[[var_name]], na.rm = TRUE),
Range = diff(range(data[[var_name]], na.rm = TRUE)),
Skewness = skewness(data[[var_name]], na.rm = TRUE),
Kurtosis = kurtosis(data[[var_name]], na.rm = TRUE),
IQR = IQR(data[[var_name]], na.rm = TRUE)
)
return(stats)
}
# Obliczenia dla zmiennych ilościowych
stats_table <- sapply(zm_ilosciowe, function(var) calculate_stats(Dane_projekt, var))
# Dla zmiennej 'oprocentowanie.refin'
stats_table_refin <- sapply("oproc_refin", function(var) calculate_stats(oprocentowanie_refin, var))
# Połączenie wyników
final_stats <- cbind(stats_table, stats_table_refin)
final_stats <- t(final_stats)
options(scipen = 999)
print(final_stats)## Mean Median Max Min
## scoring_FICO 720.72917500 717.0000 851.00000 601.0000
## kwota_kredytu 24211.65153625 23000.0000 100000.00000 4526.6200
## oproc_konkur 0.04963096 0.0499 0.06290 0.0299
## koszt_pieniadza 0.01416949 0.0138 0.02101 0.0109
## oproc_propon 0.06586651 0.0634 0.11350 0.0259
## oproc_refin 0.08370916 0.0775 0.24000 0.0300
## SD Range Skewness Kurtosis IQR
## scoring_FICO 46.580677569 250.00000 0.27005853 -0.7113702 71.000000
## kwota_kredytu 11211.386637014 95473.38000 0.87032954 1.8349262 15203.232500
## oproc_konkur 0.005794450 0.03300 -0.08879177 0.4516448 0.009000
## koszt_pieniadza 0.002618089 0.01011 0.20035865 -1.3486528 0.005162
## oproc_propon 0.020703963 0.08760 0.64076629 -0.5706685 0.034200
## oproc_refin 0.031016218 0.21000 1.54075988 3.0408174 0.036500write.xlsx(final_stats, file = "Wyniki.xlsx", sheetName = "stat_opis_il", rowNames = TRUE)# Ustaw układ wykresów 3/3/1
par(mfrow = c(3, 3))
# Rysowanie wykresów
for (zm in zm_ilosciowe) {
hist(Dane_projekt[[zm]],
main = paste("Histogram:", zm),
xlab = "",
col = "lightblue",
border = "black")
}
hist(oprocentowanie_refin$oproc_refin,
main = "Histogram: oproc_refin",
xlab = "",
col = "lightblue",
border = "black")
Tabele liczebności - dla kategorycznych
zm_kategotyczne <- c("grupa_ryzyka", "kod_partnera", "okres_kredytu", "typ_umowy", "akceptacja_klienta")
for (var in zm_kategotyczne) {
cat_table <- table(Dane_projekt[[var]], useNA = "ifany")
cat_prop <- prop.table(cat_table) # Częstości (proporcje)
cat_df <- data.frame(
Category = names(cat_table),
Count = as.vector(cat_table),
Proportion = as.vector(cat_prop)
)
cat("Tabela dla zmiennej:", var, "\n")
print(cat_df)
cat("\n")
}## Tabela dla zmiennej: grupa_ryzyka
## Category Count Proportion
## 1 1 17448 0.436200
## 2 2 8265 0.206625
## 3 3 8977 0.224425
## 4 4 5310 0.132750
##
## Tabela dla zmiennej: kod_partnera
## Category Count Proportion
## 1 1 14810 0.370250
## 2 2 6243 0.156075
## 3 3 18947 0.473675
##
## Tabela dla zmiennej: okres_kredytu
## Category Count Proportion
## 1 36 6109 0.152725
## 2 48 5590 0.139750
## 3 60 19376 0.484400
## 4 66 988 0.024700
## 5 72 7937 0.198425
##
## Tabela dla zmiennej: typ_umowy
## Category Count Proportion
## 1 N 14323 0.358075
## 2 R 11298 0.282450
## 3 U 14379 0.359475
##
## Tabela dla zmiennej: akceptacja_klienta
## Category Count Proportion
## 1 0 29633 0.740825
## 2 1 10367 0.259175Histogramy dla kategorycznych
# grupa_ryzyka
plot1 <- ggplot(Dane_projekt, aes(x = grupa_ryzyka)) +
geom_histogram(stat = "count", fill = "skyblue", color = "black") +
labs(title = "Histogram dla grupy ryzyka",
y = "Liczba obserwacji") + theme_minimal()+
theme(
axis.title.x = element_blank(),
axis.text.x = element_text(hjust = 1, size = 12),
axis.text.y = element_text(size = 10)) ## Warning in geom_histogram(stat = "count", fill = "skyblue", color = "black"):
## Ignoring unknown parameters: `binwidth`, `bins`, and `pad`# kod_partnera
plot2 <- ggplot(Dane_projekt, aes(x = kod_partnera)) +
geom_histogram(stat = "count", fill = "yellow", color = "black") +
labs(title = "Histogram dla kodu partnera",
y = "Liczba obserwacji") + theme_minimal()+
theme(
axis.title.x = element_blank(),
axis.text.x = element_text(hjust = 1, size = 12),
axis.text.y = element_text(size = 10)) ## Warning in geom_histogram(stat = "count", fill = "yellow", color = "black"):
## Ignoring unknown parameters: `binwidth`, `bins`, and `pad`# typ_umowy
plot3 <- ggplot(Dane_projekt, aes(x = typ_umowy)) +
geom_histogram(stat = "count", fill = "green", color = "black") +
labs(title = "Histogram dla typu umowy",
y = "Liczba obserwacji") + theme_minimal()+
theme(
axis.title.x = element_blank(),
axis.text.x = element_text(hjust = 1, size = 12),
axis.text.y = element_text(size = 10)) ## Warning in geom_histogram(stat = "count", fill = "green", color = "black"):
## Ignoring unknown parameters: `binwidth`, `bins`, and `pad`# okres_kredytu
plot4 <- ggplot(Dane_projekt, aes(x = factor(okres_kredytu))) +
geom_bar(fill = "orange", color = "black") +
labs(title = "Histogram dla akceptacji klienta",
y = "Liczba obserwacji") +
theme_minimal() +
theme(
axis.title.x = element_blank(),
axis.text.x = element_text(hjust = 1, size = 12),
axis.text.y = element_text(size = 10)
)
# akceptacja_klienta
plot5 <- ggplot(Dane_projekt, aes(x = factor(akceptacja_klienta))) +
geom_bar(fill = "red", color = "black") +
labs(title = "Histogram dla akceptacji klienta",
y = "Liczba obserwacji") +
theme_minimal() +
theme(
axis.title.x = element_blank(),
axis.text.x = element_text(hjust = 1, size = 12),
axis.text.y = element_text(size = 10)
)
grid.arrange(plot1, plot2, plot3, plot4, ncol = 2, nrow = 2)
print(plot5)
Załadowanie danych z utworzonymi zmiennymi pochodnymi oraz potrzebnych bibliotek. Kod tworzący zmienne pochodne został wykonany w pythonie i dodany będzie w osobnym pliku.
library(Information)## Warning: pakiet 'Information' został zbudowany w wersji R 4.4.3library(scorecard)
library(pROC)
library(dplyr)
library(readxl)
project_data <- read.csv("C:/Users/mateu/Desktop/Semestr IV/Modele scoringowe/Projekt/project_data.csv")
#project_data <- read.csv("~/Desktop/szkola/AG_magisterka/semestr 4/modele_scoringowe/project_data.csv")
#project_data <- read.csv("C:/Users/micha/Downloads/project_data.csv")
project_data$kod_partnera <- as.factor(project_data$kod_partnera)
project_data$grupa_ryzyka <- as.factor(project_data$grupa_ryzyka)
exclude_cols <- c("LP", "data_akceptacji"
, "kwota_kredytu", "oproc_refin",
"oproc_konkur", "koszt_pieniadza", "oproc_propon",
"umowa_N", "koszt_propon", "koszt_konkur")
vars_to_analyze <- setdiff(names(project_data), c(exclude_cols, "akceptacja_klienta"))Wstępna analiza IV, bins odgórnie ustalone na 10
# Przygotowanie danych do analizy IV
iv_data <- project_data[, c(vars_to_analyze, "akceptacja_klienta")]
# Upewnienie się, że zmienna celu jest typu numeric (zgodnie z błędem)
iv_data$akceptacja_klienta <- as.numeric(as.character(iv_data$akceptacja_klienta))
# Zdefiniowanie bad
iv_data$bad <- ifelse(iv_data$akceptacja_klienta == 1, 0, 1)
# Sprawdzenie, czy zmienna celu ma wartości 0 i 1
cat("Unikalne wartości zmiennej bad:", unique(iv_data$bad), "\n")## Unikalne wartości zmiennej bad: 1 0# Obliczenie IV dla wszystkich zmiennych za pomocą funkcji create_infotables
# Ta funkcja automatycznie obliczy IV dla wszystkich zmiennych w zbiorze danych
iv_results <- Information::create_infotables(data = iv_data,
y = "bad",
bins = 10,
parallel = FALSE)
# Wyodrębnienie wyników IV
iv_values <- iv_results$Summary
# Sortowanie wartości IV w kolejności malejącej
iv_values <- iv_values[order(-iv_values$IV), ]
# Wyświetlenie wyników
cat("\n=== Wartości IV dla zmiennych (posortowane) ===\n")##
## === Wartości IV dla zmiennych (posortowane) ===for (i in 1:nrow(iv_values)) {
cat(sprintf("%s: %.4f\n", iv_values$Variable[i], iv_values$IV[i]))
}## kwota_kredytu_num: 0.9774
## kwota_na_miesiac: 0.9191
## roznica_kosztu: 0.5058
## wysoka_kwota: 0.4121
## typ_umowy: 0.4037
## umowa_N_roznica_oproc: 0.2939
## oproc_refin_num: 0.2845
## stosunek_refin_konkur: 0.2760
## oproc_propon_num: 0.2406
## roznica_oproc: 0.2384
## fico_vs_oproc: 0.2351
## ryzyko_vs_oproc: 0.2244
## kod_partnera: 0.2204
## stopien_refinansowania: 0.2203
## bardzo_wysoka_kwota: 0.1878
## oproc_konkur_num: 0.1871
## grupa_ryzyka: 0.1754
## wartosc_refinansowania: 0.1266
## scoring_FICO: 0.0932
## okres_kredytu: 0.0702
## koszt_pieniadza_num: 0.0090
## akceptacja_klienta: 0.0000Próbujemy poprawić IV poprzez iteracyjne dobranie najlepszej wartość binsów dla każdej ze zmiennych
# Przygotowanie danych do analizy IV
# Tutaj pomijamy już zmienną akceptacja klienta
iv_data <- iv_data[, c(vars_to_analyze, "bad")]
# Upewnienie się, że zmienna celu jest typu numeric
iv_data$bad <- as.numeric(as.character(iv_data$bad))
# Sprawdzenie, czy zmienna celu ma wartości 0 i 1
cat("Unikalne wartości zmiennej bad:", unique(iv_data$bad), "\n")## Unikalne wartości zmiennej bad: 1 0# Funkcja do znalezienia optymalnej liczby bins dla każdej zmiennej
find_optimal_bins <- function(data, variable, target, max_bins = 20) {
best_iv <- -Inf
best_bins <- 10
for (bins in 2:max_bins) {
iv_result <- Information::create_infotables(data = data[, c(variable, target)],
y = target,
bins = bins,
parallel = FALSE)
iv_value <- iv_result$Summary$IV[1]
if (iv_value > best_iv) {
best_iv <- iv_value
best_bins <- bins
}
}
return(list(best_bins = best_bins, best_iv = best_iv))
}
# Obliczenie optymalnych bins dla każdej zmiennej
optimal_bins <- list()
for (var in vars_to_analyze) {
result <- find_optimal_bins(iv_data, var, "bad")
optimal_bins[[var]] <- result
cat(sprintf("Zmienna: %s, Optymalne bins: %d, IV: %.4f\n", var, result$best_bins, result$best_iv))
}## Zmienna: grupa_ryzyka, Optymalne bins: 2, IV: 0.1754
## Zmienna: kod_partnera, Optymalne bins: 2, IV: 0.2204
## Zmienna: typ_umowy, Optymalne bins: 2, IV: 0.4037
## Zmienna: scoring_FICO, Optymalne bins: 20, IV: 0.1002
## Zmienna: okres_kredytu, Optymalne bins: 9, IV: 0.0702
## Zmienna: kwota_kredytu_num, Optymalne bins: 20, IV: 1.0305
## Zmienna: oproc_refin_num, Optymalne bins: 20, IV: 0.3062
## Zmienna: oproc_konkur_num, Optymalne bins: 18, IV: 0.2848
## Zmienna: koszt_pieniadza_num, Optymalne bins: 16, IV: 0.0117
## Zmienna: oproc_propon_num, Optymalne bins: 17, IV: 0.2951
## Zmienna: roznica_oproc, Optymalne bins: 15, IV: 0.2591
## Zmienna: umowa_N_roznica_oproc, Optymalne bins: 18, IV: 0.4813
## Zmienna: bardzo_wysoka_kwota, Optymalne bins: 2, IV: 0.1878
## Zmienna: wysoka_kwota, Optymalne bins: 2, IV: 0.4121
## Zmienna: roznica_kosztu, Optymalne bins: 20, IV: 0.5413
## Zmienna: stosunek_refin_konkur, Optymalne bins: 20, IV: 0.2984
## Zmienna: wartosc_refinansowania, Optymalne bins: 2, IV: 0.2203
## Zmienna: stopien_refinansowania, Optymalne bins: 2, IV: 0.2203
## Zmienna: ryzyko_vs_oproc, Optymalne bins: 16, IV: 0.2616
## Zmienna: fico_vs_oproc, Optymalne bins: 17, IV: 0.2590
## Zmienna: kwota_na_miesiac, Optymalne bins: 20, IV: 0.9564# Obliczenie IV z optymalnymi bins
iv_results <- lapply(vars_to_analyze, function(var) {
bins <- optimal_bins[[var]]$best_bins
Information::create_infotables(data = iv_data[, c(var, "bad")],
y = "bad",
bins = bins,
parallel = FALSE)
})
# Wyodrębnienie wyników IV
iv_values <- do.call(rbind, lapply(iv_results, function(res) res$Summary))
iv_values <- iv_values[order(-iv_values$IV), ]
# Wyświetlenie wyników
cat("\n=== Wartości IV dla zmiennych (posortowane) ===\n")##
## === Wartości IV dla zmiennych (posortowane) ===for (i in 1:nrow(iv_values)) {
cat(sprintf("%s: %.4f\n", iv_values$Variable[i], iv_values$IV[i]))
}## kwota_kredytu_num: 1.0305
## kwota_na_miesiac: 0.9564
## roznica_kosztu: 0.5413
## umowa_N_roznica_oproc: 0.4813
## wysoka_kwota: 0.4121
## typ_umowy: 0.4037
## oproc_refin_num: 0.3062
## stosunek_refin_konkur: 0.2984
## oproc_propon_num: 0.2951
## oproc_konkur_num: 0.2848
## ryzyko_vs_oproc: 0.2616
## roznica_oproc: 0.2591
## fico_vs_oproc: 0.2590
## kod_partnera: 0.2204
## wartosc_refinansowania: 0.2203
## stopien_refinansowania: 0.2203
## bardzo_wysoka_kwota: 0.1878
## grupa_ryzyka: 0.1754
## scoring_FICO: 0.1002
## okres_kredytu: 0.0702
## koszt_pieniadza_num: 0.0117#Tworzymy elegancką tabelę dla wartości IV i optymalnej liczby binsów
# Konwersja optimal_bins na data frame
optimal_bins_df <- do.call(rbind, lapply(names(optimal_bins), function(var) {
data.frame(Variable = var,
Optimal_Bins = optimal_bins[[var]]$best_bins,
IV = optimal_bins[[var]]$best_iv)
}))
# Wyświetlenie wyników
optimal_bins_df <- optimal_bins_df[order(-optimal_bins_df$IV), ]
print(optimal_bins_df)## Variable Optimal_Bins IV
## 6 kwota_kredytu_num 20 1.03047627
## 21 kwota_na_miesiac 20 0.95644003
## 15 roznica_kosztu 20 0.54127936
## 12 umowa_N_roznica_oproc 18 0.48133134
## 14 wysoka_kwota 2 0.41205391
## 3 typ_umowy 2 0.40373413
## 7 oproc_refin_num 20 0.30620758
## 16 stosunek_refin_konkur 20 0.29844482
## 10 oproc_propon_num 17 0.29514163
## 8 oproc_konkur_num 18 0.28481305
## 19 ryzyko_vs_oproc 16 0.26159217
## 11 roznica_oproc 15 0.25906765
## 20 fico_vs_oproc 17 0.25903322
## 2 kod_partnera 2 0.22040099
## 17 wartosc_refinansowania 2 0.22026997
## 18 stopien_refinansowania 2 0.22026997
## 13 bardzo_wysoka_kwota 2 0.18775687
## 1 grupa_ryzyka 2 0.17540935
## 4 scoring_FICO 20 0.10017365
## 5 okres_kredytu 9 0.07022094
## 9 koszt_pieniadza_num 16 0.01166724Wykres IV i liczby koszyków dla danej zmiennej
# Załadowanie biblioteki ggplot2
library(ggplot2)
# Utworzenie wykresu kolumnowego
wykres <- ggplot(optimal_bins_df, aes(x = reorder(Variable, -IV), y = IV, fill = as.factor(Optimal_Bins))) +
geom_bar(stat = "identity", position = "dodge") +
labs(title = "Wartości IV dla zmiennych i liczba optymalnych bins",
x = "Zmienna",
y = "Information Value (IV)",
fill = "Liczba bins") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
print(wykres)
Kryteria IV ze slajdu:
< 0.02 - Uesless
0.02 - 0.1 - Weak
0.1 - 0.3 - Medium
0.3 - 0.5 - Strong
0.5 - 1.0 - Suspicious
Zgodnie z treścią, powinniśmy uwzględniać tylko zmienne o IV na poziomie Medium/Strong
# Wybieramy tylko te zmienne z IV na optymalnym poziomie
selected_vars <- optimal_bins_df %>%
filter(IV > 0.1 & IV < 0.5) %>%
pull(Variable)
# Stworzenie nowego DF z wybranymi zmiennymi
iv_data_selected <- iv_data %>%
select(all_of(selected_vars), bad)
head(iv_data_selected)## umowa_N_roznica_oproc wysoka_kwota typ_umowy oproc_refin_num
## 1 0.00 0 R 3.99
## 2 1.20 1 N 0.00
## 3 -0.44 0 N 0.00
## 4 0.00 0 R 6.75
## 5 0.00 0 U 0.00
## 6 -0.14 1 N 0.00
## stosunek_refin_konkur oproc_propon_num oproc_konkur_num ryzyko_vs_oproc
## 1 0.7995992 6.59 4.99 3.20
## 2 0.0000000 5.99 4.79 2.40
## 3 0.0000000 3.55 3.99 -0.44
## 4 1.3527054 4.89 4.99 -0.10
## 5 0.0000000 6.79 5.29 4.50
## 6 0.0000000 3.85 3.99 -0.14
## roznica_oproc fico_vs_oproc kod_partnera wartosc_refinansowania
## 1 1.60 1123.20 2 1057.350
## 2 1.20 862.80 2 0.000
## 3 -0.44 -352.88 3 0.000
## 4 -0.10 -72.30 1 1400.693
## 5 1.50 1035.00 1 0.000
## 6 -0.14 -95.34 3 0.000
## stopien_refinansowania bardzo_wysoka_kwota grupa_ryzyka scoring_FICO bad
## 1 1 0 2 702 1
## 2 0 0 2 719 1
## 3 0 0 1 802 1
## 4 1 0 1 723 0
## 5 0 0 3 690 1
## 6 0 0 1 681 1# Tworzymy scorecarda na podstawie najlepszego modelu
# Po wielu testach najlepszy okazał się model ze wszystkimi zmiennymi
# Wykorzystano metodę tree, poneiważ chimerge dawała ogromne liczby binów
# dodatkowo nie działał w niej limit maksymalnej liczby binów
bins <- woebin(iv_data, "bad", method = "tree")## ℹ Creating woe binning ...## ✔ Binning on 40000 rows and 22 columns in 00:00:13iv_data_woe <-woebin_ply(iv_data, bins)## ℹ Converting into woe values ...## ✔ Woe transformating on 40000 rows and 21 columns in 00:00:11# Wyznaczenie IV
iv_table <- iv(iv_data_woe, y = "bad")# Tabela IV (zawiera więcej kolumn — wybieramy tylko potrzebne)
iv_table <- iv(iv_data_woe, y = "bad") %>%
select(variable, info_value)
# Liczba unikalnych wartości (binów) po WOE
bin_counts <- iv_data_woe %>%
select(-bad) %>%
summarise(across(everything(), n_distinct)) %>%
pivot_longer(cols = everything(), names_to = "variable", values_to = "bins_count")
# Połączenie IV z liczbą binów
iv_table <- left_join(iv_table, bin_counts, by = "variable")
# Wykres
wykres <- ggplot(iv_table, aes(x = reorder(variable, -info_value), y = info_value, fill = as.factor(bins_count))) +
geom_bar(stat = "identity", position = "dodge") +
labs(title = "Wartości IV dla zmiennych i liczba wyznaczonych bins",
x = "Zmienna",
y = "Information Value (IV)",
fill = "Liczba bins") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
print(wykres)
# Filtrowanie zmiennych z IV > 0.1 i < 0.5
iv_selected <- subset(iv_table, info_value > 0.1 & info_value < 0.5)
# Pobranie nazw zmiennych spełniających kryteria
selected_vars <- as.character(iv_selected$variable)
# Weryfikacja: tylko zmienne, które faktycznie istnieją w danych
selected_vars <- selected_vars[selected_vars %in% colnames(iv_data_woe)]
# Dołączenie zmiennej celu do zbioru danych
vars_to_select <- c("bad", selected_vars)
# Wybór kolumn (ze wzg na składnię data.table — używamy ..)
iv_data_selected <- iv_data_woe[, ..vars_to_select]
#Konwersja do data.frame, żeby glm ogarnął
iv_data_selected_df <- as.data.frame(iv_data_selected)# Model finalny
reg <- glm(bad ~ ., data = iv_data_selected_df, family = "binomial")
summary(reg)##
## Call:
## glm(formula = bad ~ ., family = "binomial", data = iv_data_selected_df)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 1.08473 0.01390 78.020 < 0.0000000000000002 ***
## umowa_N_roznica_oproc_woe 0.12856 0.03521 3.652 0.000261 ***
## roznica_kosztu_woe 0.53949 0.03754 14.370 < 0.0000000000000002 ***
## wysoka_kwota_woe 0.64030 0.02954 21.676 < 0.0000000000000002 ***
## typ_umowy_woe 0.58052 0.04415 13.148 < 0.0000000000000002 ***
## oproc_refin_num_woe 0.44448 0.07256 6.126 0.000000000904 ***
## stosunek_refin_konkur_woe 0.32967 0.06975 4.726 0.000002286742 ***
## oproc_propon_num_woe -0.21937 0.05188 -4.228 0.000023558424 ***
## fico_vs_oproc_woe 0.10657 0.10987 0.970 0.332080
## wartosc_refinansowania_woe 0.91484 0.28086 3.257 0.001125 **
## kod_partnera_woe 1.19913 0.03403 35.234 < 0.0000000000000002 ***
## stopien_refinansowania_woe -1.47018 0.30253 -4.860 0.000001176013 ***
## ryzyko_vs_oproc_woe 0.17932 0.07459 2.404 0.016215 *
## roznica_oproc_woe -0.04542 0.10056 -0.452 0.651485
## oproc_konkur_num_woe 0.69190 0.03994 17.325 < 0.0000000000000002 ***
## bardzo_wysoka_kwota_woe 0.20004 0.04624 4.326 0.000015193265 ***
## grupa_ryzyka_woe 0.76249 0.06674 11.425 < 0.0000000000000002 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 45775 on 39999 degrees of freedom
## Residual deviance: 36502 on 39983 degrees of freedom
## AIC: 36536
##
## Number of Fisher Scoring iterations: 6# Wyznaczenie punktacji
card_final <- scorecard(bins, reg)
# Utworzenie NIEZBINOWANEGO zbioru danych na którym tworzymy scoring
# Usunięcie '_woe' z nazw zmiennych (poza zmienną celu)
vars_to_select_not_woe <- gsub("_woe$", "", vars_to_select[vars_to_select != "bad"])
# Dodanie zmiennej celu z powrotem na początek
vars_to_select_not_woe <- c("bad", vars_to_select_not_woe)
# Wybór zmiennych z niezbinowanego zbioru
iv_data_not_woe <- iv_data[, vars_to_select_not_woe]
# Wyznaczenie AUC i Gini
auc <- bigstatsr::AUC(-scorecard_ply(iv_data_not_woe, card_final)$score, iv_data_not_woe$bad)
gini <- 2 * auc - 1
#2*bigstatsr::AUC(-scorecard_ply(iv_data_selected, card_1)$score, iv_data_selected$bad)-1
auc## [1] 0.7992655gini## [1] 0.598531library(data.table)## Warning: pakiet 'data.table' został zbudowany w wersji R 4.4.3##
## Dołączanie pakietu: 'data.table'## Następujący obiekt został zakryty z 'package:purrr':
##
## transpose## Następujące obiekty zostały zakryte z 'package:dplyr':
##
## between, first, lastlibrary(officer)## Warning: pakiet 'officer' został zbudowany w wersji R 4.4.3##
## Dołączanie pakietu: 'officer'## Następujący obiekt został zakryty z 'package:readxl':
##
## read_xlsxlibrary(flextable)## Warning: pakiet 'flextable' został zbudowany w wersji R 4.4.3##
## Dołączanie pakietu: 'flextable'## Następujący obiekt został zakryty z 'package:purrr':
##
## compose# Łączymy wszystkie data.table z card_final w jedną tabelę
card_final_df <- rbindlist(card_final,fill=TRUE)
# Wybieramy interesujace nas kolumny i sortujemy
card_final_df <- card_final_df[, .(variable, bin, points, count)]
setorder(card_final_df, variable, bin)
# Tworzymy flextable i scalamy komórki w kolumnie 'variable' posiadające tą samą wartość
ft <- flextable(card_final_df) %>%
merge_v(j = "variable") %>% # <- SCALANIE komórek w kolumnie 'variable'
valign(j = "variable", valign = "top") %>% # estetyka
autofit()
# Eksportujemy do worda
doc <- read_docx()
doc <- body_add_par(doc, "Scorecard Table", style = "heading 1")
doc <- body_add_flextable(doc, ft)
print(doc, target = "scorecard_merged.docx")# Obliczanie score'u dla każdego rekordu
scored_data <- scorecard_ply(iv_data_not_woe, card_final)
# Dołączenie kolumny ze scoringiem
iv_data_with_scores_all <- cbind(iv_data_not_woe, scored_data)
head(iv_data_with_scores_all)## bad umowa_N_roznica_oproc roznica_kosztu wysoka_kwota typ_umowy
## 1 1 0.00 1696.000 0 R
## 2 1 1.20 2520.000 1 N
## 3 1 -0.44 -616.000 0 N
## 4 0 0.00 -103.755 0 R
## 5 1 0.00 1800.000 0 U
## 6 1 -0.14 -266.000 1 N
## oproc_refin_num stosunek_refin_konkur oproc_propon_num fico_vs_oproc
## 1 3.99 0.7995992 6.59 1123.20
## 2 0.00 0.0000000 5.99 862.80
## 3 0.00 0.0000000 3.55 -352.88
## 4 6.75 1.3527054 4.89 -72.30
## 5 0.00 0.0000000 6.79 1035.00
## 6 0.00 0.0000000 3.85 -95.34
## wartosc_refinansowania kod_partnera stopien_refinansowania ryzyko_vs_oproc
## 1 1057.350 2 1 3.20
## 2 0.000 2 0 2.40
## 3 0.000 3 0 -0.44
## 4 1400.693 1 1 -0.10
## 5 0.000 1 0 4.50
## 6 0.000 3 0 -0.14
## roznica_oproc oproc_konkur_num bardzo_wysoka_kwota grupa_ryzyka score
## 1 1.60 4.99 0 2 179
## 2 1.20 4.79 0 2 16
## 3 -0.44 3.99 0 1 337
## 4 -0.10 4.99 0 1 440
## 5 1.50 5.29 0 3 327
## 6 -0.14 3.99 0 1 257summary(iv_data_with_scores_all$score)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -89.0 209.0 293.0 277.2 363.0 508.0# Obliczanie przedziałów dla score'u
breaks_seq <- seq(floor(min(iv_data_with_scores_all$score)), ceiling(max(iv_data_with_scores_all$score)) + 24, by = 50)
# Tworzenie przedziałów co 20 punktów
iv_data_with_scores_all %>%
mutate(score_bin = cut(score, breaks = breaks_seq, right = FALSE)) %>%
group_by(score_bin) %>%
summarize(
bad_rate = mean(bad),
total = n(),
liczba_bad = sum(bad)
) -> goodrates_bins
# Wyświetlenie wyników
print(goodrates_bins)## # A tibble: 12 × 4
## score_bin bad_rate total liczba_bad
## <fct> <dbl> <int> <dbl>
## 1 [-89,-39) 0.995 375 373
## 2 [-39,11) 0.986 288 284
## 3 [11,61) 0.992 893 886
## 4 [61,111) 0.984 2070 2036
## 5 [111,161) 0.964 2702 2604
## 6 [161,211) 0.940 3984 3745
## 7 [211,261) 0.898 4672 4194
## 8 [261,311) 0.805 8033 6465
## 9 [311,361) 0.647 6453 4172
## 10 [361,411) 0.523 7358 3848
## 11 [411,461) 0.334 2880 962
## 12 [461,511) 0.219 292 64# Obliczony zakres punktacji
min_score <- floor(min(iv_data_with_scores_all$score))
max_score <- max(iv_data_with_scores_all$score)
# Budujemy breaks co 20 punktów, ostatni punkt to dokładnie max(score)
breaks_seq <- c(seq(min_score, max_score, by = 20), max_score)
# Usuwamy ewentualny duplikat ostatniego punktu
breaks_seq <- unique(breaks_seq)
# Tworzymy przedziały
iv_data_with_scores_all %>%
mutate(score_bin = cut(score, breaks = breaks_seq, right = TRUE, include.lowest = TRUE)) %>%
group_by(score_bin) %>%
summarize(
bad_rate = mean(bad),
total = n(),
liczba_bad = sum(bad)
) -> badrates_binsWykres good(bad) rate w zależności od przedziałów score
ggplot(goodrates_bins, aes(x = score_bin, y = bad_rate, group = 1)) +
geom_line(color = "steelblue", size = 1) +
geom_point(color = "darkblue", size = 2) +
labs(
title = "Bad rate względem przedziałów score",
x = "Przedział score",
y = "Bad rate"
) +
scale_y_continuous(
limits = c(0, 1),
breaks = seq(0, 1, 0.2)
) +
theme_minimal() +
theme(
axis.text.x = element_text(angle = 45, hjust = 1)
)## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
Wykres krzyewj ROC
# Tworzenie krzywej ROC
roc_obj <- roc(iv_data_with_scores_all$bad, -iv_data_with_scores_all$score)## Setting levels: control = 0, case = 1## Setting direction: controls < casesauc_value <- auc(roc_obj)
gini_value <- 2*auc_value - 1
# Podstawowe informacje o krzywej ROC
cat(sprintf("AUC: %.4f\n", auc_value))## AUC: 0.7993cat(sprintf("Gini: %.4f\n", gini_value))## Gini: 0.5985# Wizualizacja krzywej ROC
roc_data <- data.frame(
specificity = roc_obj$specificities,
sensitivity = roc_obj$sensitivities
)
# Tworzenie wykresu
ggplot(roc_data, aes(x = 1 - specificity, y = sensitivity)) +
geom_line(color = "blue", size = 1) +
geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "gray") +
labs(
title = "Krzywa ROC dla modelu scoringowego",
subtitle = sprintf("AUC = %.4f, Gini = %.4f", auc_value, gini_value),
x = "1 - Swoistość", # Polska nazwa dla 1-Specificity
y = "Czułość" # Polska nazwa dla Sensitivity
) +
theme_minimal() +
coord_equal() +
annotate("text", x = 0.75, y = 0.25,
label = sprintf("AUC = %.4f\nGini = %.4f", auc_value, gini_value),
hjust = 0, size = 4) +
theme(
plot.title = element_text(size = 14, face = "bold"),
plot.subtitle = element_text(size = 10),
axis.title = element_text(size = 10),
panel.grid.minor = element_blank()
)
# Definiujemy wartości progowe score
thresholds <- c(0,100,200,300, 400, 500, 508)
# Tworzymy tabelę progową
#u nas bad to de facto good
threshold_table <- data.frame(score = thresholds) %>%
rowwise() %>%
mutate(
rzeczywisty_bad = sum(iv_data_with_scores_all$bad[iv_data_with_scores_all$score <= score], na.rm = TRUE),
przewidywany_bad = sum(iv_data_with_scores_all$score <= score, na.rm = TRUE)
) %>%
ungroup()
# Wyświetlenie wyniku
print(threshold_table)## # A tibble: 7 × 3
## score rzeczywisty_bad przewidywany_bad
## <dbl> <dbl> <int>
## 1 0 580 584
## 2 100 3374 3412
## 3 200 8990 9309
## 4 300 19809 21971
## 5 400 27456 34332
## 6 500 29632 39996
## 7 508 29633 40000