Wczytanie danych oraz pakietów
# Wczytanie kopii df, żeby nie ściągać znowu z chmury przy testowaniu
df <- df_copy
# Dodanie zmienny pochodnych
# Wcześniej koszt_propon i koszt_konkur służyły tylko do przekształceń -> teraz je uwzględniamy
df$bardzo_wysoka_kwota <- as.integer(df$kwota_kredytu > quantile(df$kwota_kredytu, 0.9, na.rm = TRUE))
df$roznica_oproc <- df$oproc_propon - df$oproc_konkur
df$fico_vs_oproc <- df$scoring_FICO * df$roznica_oproc
df$koszt_propon <- df$kwota_kredytu * (df$oproc_propon / 100) * (df$okres_kredytu / 12) # potrzebne do przekształceń
df$koszt_konkur <- df$kwota_kredytu * (df$oproc_konkur / 100) * (df$okres_kredytu / 12) # potrzebne do przekształceń
df$roznica_kosztu <- df$koszt_propon - df$koszt_konkur
df$ryzyko_vs_oproc <- df$grupa_ryzyka * df$roznica_oproc
df$stopien_refinansowania <- as.integer(df$oproc_refin > 0)
df$stosunek_refin_konkur <- df$oproc_refin / ifelse(df$oproc_konkur == 0, 0.0001, df$oproc_konkur)
df$umowa_N_roznica_oproc <- as.integer(df$typ_umowy == "N") * df$roznica_oproc
df$wartosc_refinansowania <- (df$oproc_refin / 100) * df$kwota_kredytu
df$wysoka_kwota <- as.integer(df$kwota_kredytu > quantile(df$kwota_kredytu, 0.75, na.rm = TRUE))
df$kwota_na_miesiac <- df$kwota_kredytu / df$okres_kredytu
# Usunięcie zmiennych służących do przekształceń
df <- df %>% select(-koszt_propon, -koszt_konkur)
# Sprawdzenie braków
sum(is.na(df))
## [1] 0
# Zdefiniowanie bad
df$bad <- ifelse(df$akceptacja_klienta == 1, 0, 1)
df <- df %>% select(-akceptacja_klienta)
# NOWE ZMIENNE
df$fico_znormalizowana_kwota <- log1p(df$kwota_kredytu) / (df$scoring_FICO + 1)
df$skorygowana_atrakcyjnosc <- (df$oproc_konkur - df$oproc_propon) - df$koszt_pieniadza
df$ryzyko_vs_kwota <- df$grupa_ryzyka * df$kwota_kredytu
df$wskaźnik_refin_zysku <- ifelse(df$typ_umowy == "R", (df$oproc_refin - df$oproc_konkur) * df$kwota_kredytu,0)
df$presja_ratalna <- df$kwota_kredytu / df$scoring_FICO * log1p(df$okres_kredytu)
df$obciazenie_vs_fico <- (df$kwota_kredytu / df$okres_kredytu) / df$scoring_FICO
df$atrakcyjnosc_oferty <- (df$oproc_konkur - df$oproc_propon) / df$oproc_konkur
#df$kwota_kredytu_ln <- log(df$kwota_kredytu)
#df$kwota_kredytu_pół <- df$kwota_kredytu / 2
#df$kwota_na_fico <- df$kwota_kredytu / df$scoring_FICO
#te 3 zmienne pogorszyły AUC,Gini, pomimo wysokiego IV
# Sprawdzenie liczby unikalnych wartości w każdej kolumnie
sapply(df, function(x) length(unique(x)))
## grupa_ryzyka kod_partnera typ_umowy
## 4 3 3
## scoring_FICO okres_kredytu kwota_kredytu
## 246 5 14344
## oproc_refin oproc_konkur koszt_pieniadza
## 688 37 71
## oproc_propon bardzo_wysoka_kwota roznica_oproc
## 468 2 1043
## fico_vs_oproc roznica_kosztu ryzyko_vs_oproc
## 11750 20476 1423
## stopien_refinansowania stosunek_refin_konkur umowa_N_roznica_oproc
## 2 2756 217
## wartosc_refinansowania wysoka_kwota kwota_na_miesiac
## 10057 2 15575
## bad fico_znormalizowana_kwota skorygowana_atrakcyjnosc
## 2 27776 4247
## ryzyko_vs_kwota wskaźnik_refin_zysku presja_ratalna
## 15652 10919 31979
## obciazenie_vs_fico atrakcyjnosc_oferty
## 29967 1713
binned <- c("grupa_ryzyka", "kod_partnera","typ_umowy", "bardzo_wysoka_kwota", "stopien_refinansowania", "wysoka_kwota", "okres_kredytu")
breaks_list <- lapply(binned, function(x) NULL)
names(breaks_list) <- binned
breaks_list <- list(
grupa_ryzyka = c(1, 2, 3, 4),
kod_partnera = c(1, 2, 3),
typ_umowy = c("R", "N", "U"),
bardzo_wysoka_kwota = c(0, 1),
stopien_refinansowania = c(0, 1),
wysoka_kwota = c(0, 1),
okres_kredytu = c(36,48,60,66,72)
)
# Kubełkowanie zmiennych metodą "tree"
#bins <- woebin(df, "bad", method = "tree", min_perc_fine_bin = 0.05, breaks_list=breaks_list)
# Kubełkowanie zmiennych metodą "chimerge"
bins <- woebin(df, "bad", method = "chimerge", min_perc_fine_bin = 0.05, breaks_list=breaks_list, bin_num_limit = 8)
## ℹ Creating woe binning ...
## ℹ The option bin_close_right was set to FALSE.
## Warning in check_breaks_list(breaks_list, xs): There are 21 x variables that
## are not specified in breaks_list, and instead are using optimal binning.
## ✔ Binning on 40000 rows and 29 columns in 00:00:06
df_woe <-woebin_ply(df, bins)
## ℹ Converting into woe values ...
## ✔ Woe transformating on 40000 rows and 28 columns in 00:00:02
# Wyznaczenie IV
iv_table <- iv(df_woe, y = "bad") %>%
select(variable, info_value)
# Liczba unikalnych wartości (binów) po WOE
bin_counts <- df_woe %>%
select(-bad) %>%
summarise(across(everything(), n_distinct)) %>%
pivot_longer(cols = everything(), names_to = "variable", values_to = "bins_count")
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(iv_table)
## variable info_value bins_count
## <char> <num> <int>
## 1: kwota_kredytu_woe 0.955631617 8
## 2: obciazenie_vs_fico_woe 0.952142396 8
## 3: ryzyko_vs_kwota_woe 0.939819672 8
## 4: kwota_na_miesiac_woe 0.895670415 8
## 5: presja_ratalna_woe 0.894304149 8
## 6: fico_znormalizowana_kwota_woe 0.556959467 8
## 7: roznica_kosztu_woe 0.469888837 7
## 8: wysoka_kwota_woe 0.412053905 2
## 9: typ_umowy_woe 0.403734127 3
## 10: umowa_N_roznica_oproc_woe 0.339554718 2
## 11: oproc_refin_woe 0.283733390 3
## 12: stosunek_refin_konkur_woe 0.272992843 3
## 13: atrakcyjnosc_oferty_woe 0.247819248 7
## 14: skorygowana_atrakcyjnosc_woe 0.235136052 8
## 15: ryzyko_vs_oproc_woe 0.232398005 8
## 16: fico_vs_oproc_woe 0.231643594 8
## 17: roznica_oproc_woe 0.231053148 8
## 18: wskaźnik_refin_zysku_woe 0.227169472 2
## 19: kod_partnera_woe 0.220400987 3
## 20: stopien_refinansowania_woe 0.220269966 2
## 21: oproc_konkur_woe 0.211246035 8
## 22: bardzo_wysoka_kwota_woe 0.187756872 2
## 23: oproc_propon_woe 0.182445249 8
## 24: grupa_ryzyka_woe 0.175409351 4
## 25: wartosc_refinansowania_woe 0.102656754 2
## 26: scoring_FICO_woe 0.092191078 8
## 27: okres_kredytu_woe 0.070220937 5
## 28: koszt_pieniadza_woe 0.007908854 8
## variable info_value bins_count
print(wykres)
# Filtrowanie zmiennych z IV > 0.1
iv_selected <- subset(iv_table, info_value > 0.1)
# 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(df_woe)]
selected_vars <- c("bad", selected_vars)
# Wybór kolumn
iv_df_woe <- df_woe[, ..selected_vars]
iv_df_woe <- as.data.frame(iv_df_woe)
# Model finalny
reg <- glm(bad ~ ., data = iv_df_woe, family = "binomial")
summary(reg)
##
## Call:
## glm(formula = bad ~ ., family = "binomial", data = iv_df_woe)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 1.07904 0.01455 74.176 < 2e-16 ***
## kwota_kredytu_woe 0.46048 0.06027 7.640 2.17e-14 ***
## obciazenie_vs_fico_woe 0.04789 0.06285 0.762 0.446008
## ryzyko_vs_kwota_woe 0.42720 0.03979 10.735 < 2e-16 ***
## kwota_na_miesiac_woe 0.52606 0.06646 7.916 2.45e-15 ***
## presja_ratalna_woe 0.17215 0.04702 3.661 0.000251 ***
## fico_znormalizowana_kwota_woe -0.38060 0.03830 -9.938 < 2e-16 ***
## roznica_kosztu_woe -0.25307 0.04697 -5.388 7.12e-08 ***
## wysoka_kwota_woe -0.28915 0.03580 -8.077 6.65e-16 ***
## typ_umowy_woe 0.07796 0.04358 1.789 0.073620 .
## umowa_N_roznica_oproc_woe 0.34149 0.04001 8.536 < 2e-16 ***
## oproc_refin_woe -0.02615 0.09203 -0.284 0.776288
## stosunek_refin_konkur_woe 0.03075 0.08836 0.348 0.727808
## atrakcyjnosc_oferty_woe 0.50233 0.12759 3.937 8.25e-05 ***
## skorygowana_atrakcyjnosc_woe 0.72462 0.11382 6.366 1.94e-10 ***
## ryzyko_vs_oproc_woe 0.52826 0.12606 4.190 2.78e-05 ***
## fico_vs_oproc_woe 0.47234 0.11992 3.939 8.19e-05 ***
## roznica_oproc_woe -0.70999 0.15853 -4.478 7.52e-06 ***
## wskaźnik_refin_zysku_woe 0.41439 0.08054 5.145 2.68e-07 ***
## kod_partnera_woe 1.18343 0.03573 33.121 < 2e-16 ***
## stopien_refinansowania_woe -0.75124 0.06819 -11.016 < 2e-16 ***
## oproc_konkur_woe 0.50787 0.04237 11.986 < 2e-16 ***
## bardzo_wysoka_kwota_woe 0.08380 0.04623 1.813 0.069866 .
## oproc_propon_woe -0.05315 0.07231 -0.735 0.462383
## grupa_ryzyka_woe -0.03616 0.09045 -0.400 0.689300
## wartosc_refinansowania_woe 1.30164 0.06797 19.151 < 2e-16 ***
## ---
## 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: 32977 on 39974 degrees of freedom
## AIC: 33029
##
## Number of Fisher Scoring iterations: 6
# Wyznaczenie punktacji
card_final <- scorecard(bins, reg)
# Niezbinowany zbiór z wybranymi zmiennymi
selected_vars_2 <- gsub("_woe", "", selected_vars)
iv_df <- df[, selected_vars_2, with=FALSE]
# Wyznaczenie AUC i Gini
auc <- bigstatsr::AUC(-scorecard_ply(iv_df, card_final)$score, iv_df$bad)
gini <- 2 * auc - 1
summary(scorecard_ply(iv_df, card_final)$score)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -92.0 197.0 270.0 274.7 363.0 599.0
print(paste("AUC:", round(auc, 4)))
## [1] "AUC: 0.8446"
print(paste("GINI:", round(gini, 4)))
## [1] "GINI: 0.6891"
# Zapisanie scorecarda
# Łą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_df, card_final)
# Dołączenie kolumny ze scoringiem
iv_data_with_scores_all <- cbind(iv_df, scored_data)
head(iv_data_with_scores_all)
## bad kwota_kredytu obciazenie_vs_fico ryzyko_vs_kwota kwota_na_miesiac
## 1 1 26500.00 0.7864435 53000.00 552.0833
## 2 1 34999.99 0.6760931 69999.98 486.1110
## 3 1 28000.00 0.5818786 28000.00 466.6667
## 4 0 20750.69 0.4783469 20750.69 345.8448
## 5 1 19999.99 0.4025763 59999.97 277.7776
## 6 1 38000.00 0.9300049 38000.00 633.3333
## presja_ratalna fico_znormalizowana_kwota roznica_kosztu wysoka_kwota
## 1 146.9134 0.01448782 16.960000 0
## 2 208.8540 0.01453213 25.199993 1
## 3 143.5218 0.01275217 -6.160000 0
## 4 117.9854 0.01372981 -1.037534 0
## 5 124.3611 0.01433218 17.999991 0
## 6 229.3880 0.01546242 -2.660000 1
## typ_umowy umowa_N_roznica_oproc oproc_refin stosunek_refin_konkur
## 1 R 0.0000 0.0399 0.7995992
## 2 N 0.0120 0.0000 0.0000000
## 3 N -0.0044 0.0000 0.0000000
## 4 R 0.0000 0.0675 1.3527054
## 5 U 0.0000 0.0000 0.0000000
## 6 N -0.0014 0.0000 0.0000000
## atrakcyjnosc_oferty skorygowana_atrakcyjnosc ryzyko_vs_oproc fico_vs_oproc
## 1 -0.32064128 -0.0270 0.0320 11.2320
## 2 -0.25052192 -0.0230 0.0240 8.6280
## 3 0.11027569 -0.0066 -0.0044 -3.5288
## 4 0.02004008 -0.0100 -0.0010 -0.7230
## 5 -0.28355388 -0.0260 0.0450 10.3500
## 6 0.03508772 -0.0096 -0.0014 -0.9534
## roznica_oproc wskaźnik_refin_zysku kod_partnera stopien_refinansowania
## 1 0.0160 -265.0000 2 1
## 2 0.0120 0.0000 2 0
## 3 -0.0044 0.0000 3 0
## 4 -0.0010 365.2121 1 1
## 5 0.0150 0.0000 1 0
## 6 -0.0014 0.0000 3 0
## oproc_konkur bardzo_wysoka_kwota oproc_propon grupa_ryzyka
## 1 0.0499 0 0.0659 2
## 2 0.0479 0 0.0599 2
## 3 0.0399 0 0.0355 1
## 4 0.0499 0 0.0489 1
## 5 0.0529 0 0.0679 3
## 6 0.0399 0 0.0385 1
## wartosc_refinansowania score
## 1 10.57350 55
## 2 0.00000 149
## 3 0.00000 291
## 4 14.00672 468
## 5 0.00000 359
## 6 0.00000 283
summary(iv_data_with_scores_all$score)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -92.0 197.0 270.0 274.7 363.0 599.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: 14 × 4
## score_bin bad_rate total liczba_bad
## <fct> <dbl> <int> <dbl>
## 1 [-92,-42) 1 284 284
## 2 [-42,8) 0.992 254 252
## 3 [8,58) 0.993 908 902
## 4 [58,108) 0.985 2470 2434
## 5 [108,158) 0.973 2566 2497
## 6 [158,208) 0.946 4906 4639
## 7 [208,258) 0.897 6806 6102
## 8 [258,308) 0.816 6334 5166
## 9 [308,358) 0.679 4992 3390
## 10 [358,408) 0.520 4209 2188
## 11 [408,458) 0.354 3244 1149
## 12 [458,508) 0.227 2284 518
## 13 [508,558) 0.157 687 108
## 14 [558,608) 0.0714 56 4
Wykres 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 < cases
auc_value <- auc(roc_obj)
gini_value <- 2*auc_value - 1
# Podstawowe informacje o krzywej ROC
cat(sprintf("AUC: %.4f\n", auc_value))
## AUC: 0.8446
cat(sprintf("Gini: %.4f\n", gini_value))
## Gini: 0.6891
# 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, 577)
# 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 524 526
## 2 100 3533 3569
## 3 200 10123 10452
## 4 300 21682 23762
## 5 400 27599 33199
## 6 500 29480 39024
## 7 577 29632 39988
Tabelka iv do worda
# Jeśli nie masz zainstalowanych tych pakietów:
# install.packages("flextable")
#install.packages("webshot2")
# webshot2::install_phantomjs() # uruchom raz, jeśli jeszcze nie masz PhantomJS
library(flextable)
library(webshot2)
## Warning: pakiet 'webshot2' został zbudowany w wersji R 4.4.3
# Przygotowanie tabeli
iv_selected <- subset(iv_table, info_value > 0.1)
iv_selected$Lp <- seq_len(nrow(iv_selected))
iv_selected <- iv_selected[, c("Lp", "variable", "info_value", "bins_count")]
# Tworzenie flextable
ft_iv <- flextable(iv_selected) %>%
set_header_labels(
Lp = "Lp",
variable = "Zmienna",
info_value = "IV",
bins_count = "Liczba binów"
) %>%
colformat_num(j = "info_value", digits = 4) %>%
autofit() %>%
theme_booktabs() %>%
add_header_lines(values = "Tabela zmiennych z IV > 0.1")
# Zapis jako plik HTML tymczasowy
html_path <- "iv_selected_table_temp.html"
save_as_html(ft_iv, path = html_path)
# Konwersja HTML do PNG
webshot2::webshot(url = html_path, file = "iv_selected_table.png", zoom = 2, vwidth = 1200)
## file:///C:/Users/mateu/Desktop/Semestr IV/Modele scoringowe/Projekt/Model konkursowy/iv_selected_table_temp.html screenshot completed
# Funkcja pozwalajaca wyznaczyć
score_function <- function(df) {
# Zmienne pochodne w modelu
df$bardzo_wysoka_kwota <- as.integer(df$kwota_kredytu > quantile(df$kwota_kredytu, 0.9, na.rm = TRUE))
df$roznica_oproc <- df$oproc_propon - df$oproc_konkur
df$fico_vs_oproc <- df$scoring_FICO * df$roznica_oproc
df$koszt_propon <- df$kwota_kredytu * (df$oproc_propon / 100) * (df$okres_kredytu / 12) # potrzebne do przekształceń
df$koszt_konkur <- df$kwota_kredytu * (df$oproc_konkur / 100) * (df$okres_kredytu / 12) # potrzebne do przekształceń
df$roznica_kosztu <- df$koszt_propon - df$koszt_konkur
df$ryzyko_vs_oproc <- df$grupa_ryzyka * df$roznica_oproc
df$stopien_refinansowania <- as.integer(df$oproc_refin > 0)
df$stosunek_refin_konkur <- df$oproc_refin / ifelse(df$oproc_konkur == 0, 0.0001, df$oproc_konkur)
df$umowa_N_roznica_oproc <- as.integer(df$typ_umowy == "N") * df$roznica_oproc
df$wartosc_refinansowania <- (df$oproc_refin / 100) * df$kwota_kredytu
df$wysoka_kwota <- as.integer(df$kwota_kredytu > quantile(df$kwota_kredytu, 0.75, na.rm = TRUE))
df$kwota_na_miesiac <- df$kwota_kredytu / df$okres_kredytu
df$fico_znormalizowana_kwota <- log1p(df$kwota_kredytu) / (df$scoring_FICO + 1)
df$skorygowana_atrakcyjnosc <- (df$oproc_konkur - df$oproc_propon) - df$koszt_pieniadza
df$ryzyko_vs_kwota <- df$grupa_ryzyka * df$kwota_kredytu ### GOAT
df$wskaźnik_refin_zysku <- ifelse(df$typ_umowy == "R", (df$oproc_refin - df$oproc_konkur) * df$kwota_kredytu,0)
df$presja_ratalna <- df$kwota_kredytu / df$scoring_FICO * log1p(df$okres_kredytu)
df$obciazenie_vs_fico <- (df$kwota_kredytu / df$okres_kredytu) / df$scoring_FICO
df$atrakcyjnosc_oferty <- (df$oproc_konkur - df$oproc_propon) / df$oproc_konkur
df$kwota_na_miesiac <- df$kwota_kredytu / df$okres_kredytu
# Wyliczenie wyniku scoringowego
score<- 310 +
case_when(df$atrakcyjnosc_oferty < -1 ~ -35,
df$atrakcyjnosc_oferty < -0.7 ~ -24,
df$atrakcyjnosc_oferty < -0.6 ~ -26,
df$atrakcyjnosc_oferty < -0.4 ~ -21,
df$atrakcyjnosc_oferty < -0.3 ~ -3,
df$atrakcyjnosc_oferty < -0.2 ~ 5,
TRUE ~ 15) +
case_when(df$bardzo_wysoka_kwota < 1 ~ 1,
TRUE ~ -10) +
case_when(df$fico_vs_oproc < 0 ~ 18,
df$fico_vs_oproc < 5 ~ 12,
df$fico_vs_oproc < 10 ~ 6,
df$fico_vs_oproc < 15 ~ -9,
df$fico_vs_oproc < 20 ~ -22,
df$fico_vs_oproc < 25 ~ -18,
df$fico_vs_oproc < 30 ~ -29,
TRUE ~ -23) +
case_when(df$fico_znormalizowana_kwota < 0.0125 ~ -38,
df$fico_znormalizowana_kwota < 0.013 ~ -16,
df$fico_znormalizowana_kwota < 0.0135 ~ -7,
df$fico_znormalizowana_kwota < 0.014 ~ 2,
df$fico_znormalizowana_kwota < 0.0145 ~ 11,
df$fico_znormalizowana_kwota < 0.015 ~ 22,
df$fico_znormalizowana_kwota < 0.0155 ~ 29,
TRUE ~ 32) +
case_when(df$grupa_ryzyka < 2 ~ -1,
df$grupa_ryzyka < 3 ~ 1,
df$grupa_ryzyka < 4 ~ 1,
TRUE ~ 1) +
case_when(df$kod_partnera < 2 ~ 26,
df$kod_partnera < 3 ~ -111,
TRUE ~ 3) +
case_when(df$kwota_kredytu < 10000 ~ 56,
df$kwota_kredytu < 15000 ~ 35,
df$kwota_kredytu < 20000 ~ 11,
df$kwota_kredytu < 25000 ~ -7,
df$kwota_kredytu < 30000 ~ -22,
df$kwota_kredytu < 35000 ~ -42,
df$kwota_kredytu < 45000 ~ -52,
TRUE ~ -56) +
case_when(df$kwota_na_miesiac < 200 ~ 60,
df$kwota_na_miesiac < 250 ~ 40,
df$kwota_na_miesiac < 300 ~ 25,
df$kwota_na_miesiac < 350 ~ 11,
df$kwota_na_miesiac < 400 ~ 3,
df$kwota_na_miesiac < 450 ~ -21,
df$kwota_na_miesiac < 500 ~ -26,
TRUE ~ -51) +
case_when(df$obciazenie_vs_fico < 0.3 ~ 5,
df$obciazenie_vs_fico < 0.4 ~ 3,
df$obciazenie_vs_fico < 0.5 ~ 1,
df$obciazenie_vs_fico < 0.6 ~ -1,
df$obciazenie_vs_fico < 0.7 ~ -3,
df$obciazenie_vs_fico < 0.8 ~ -4,
df$obciazenie_vs_fico < 1 ~ -5,
TRUE ~ -5) +
case_when(df$oproc_konkur < 0.04 ~ 1,
df$oproc_konkur < 0.044 ~ -29,
df$oproc_konkur < 0.046 ~ -31,
df$oproc_konkur < 0.048 ~ 6,
df$oproc_konkur < 0.052 ~ 7,
df$oproc_konkur < 0.054 ~ 3,
df$oproc_konkur < 0.056 ~ 20,
TRUE ~ 15) +
case_when(df$oproc_propon < 0.05 ~ -1,
df$oproc_propon < 0.06 ~ -2,
df$oproc_propon < 0.065 ~ 1,
df$oproc_propon < 0.07 ~ 0,
df$oproc_propon < 0.08 ~ 1,
df$oproc_propon < 0.085 ~ 3,
df$oproc_propon < 0.105 ~ 2,
TRUE ~ 3) +
case_when(df$oproc_refin < 0.06 ~ 1,
df$oproc_refin < 0.07 ~ -1,
TRUE ~ -2) +
case_when(df$presja_ratalna < 60 ~ 21,
df$presja_ratalna < 80 ~ 11,
df$presja_ratalna < 140 ~ 1,
df$presja_ratalna < 160 ~ -9,
df$presja_ratalna < 180 ~ -11,
df$presja_ratalna < 200 ~ -17,
df$presja_ratalna < 220 ~ -18,
TRUE ~ -19) +
case_when(df$roznica_kosztu < 0 ~ -10,
df$roznica_kosztu < 10 ~ -8,
df$roznica_kosztu < 20 ~ -2,
df$roznica_kosztu < 30 ~ 9,
df$roznica_kosztu < 40 ~ 15,
df$roznica_kosztu < 50 ~ 23,
TRUE ~ 29) +
case_when(df$roznica_oproc < 0.01 ~ -21,
df$roznica_oproc < 0.015 ~ -6,
df$roznica_oproc < 0.02 ~ 10,
df$roznica_oproc < 0.03 ~ 30,
df$roznica_oproc < 0.035 ~ 29,
df$roznica_oproc < 0.04 ~ 44,
df$roznica_oproc < 0.055 ~ 21,
TRUE ~ 48) +
case_when(df$ryzyko_vs_kwota < 20000 ~ 47,
df$ryzyko_vs_kwota < 30000 ~ 8,
df$ryzyko_vs_kwota < 40000 ~ -12,
df$ryzyko_vs_kwota < 50000 ~ -16,
df$ryzyko_vs_kwota < 60000 ~ -17,
df$ryzyko_vs_kwota < 70000 ~ -28,
df$ryzyko_vs_kwota < 80000 ~ -30,
TRUE ~ -43) +
case_when(df$ryzyko_vs_oproc < 0 ~ 20,
df$ryzyko_vs_oproc < 0.02 ~ 14,
df$ryzyko_vs_oproc < 0.04 ~ -5,
df$ryzyko_vs_oproc < 0.08 ~ -18,
df$ryzyko_vs_oproc < 0.1 ~ -22,
df$ryzyko_vs_oproc < 0.12 ~ -33,
df$ryzyko_vs_oproc < 0.22 ~ -13,
TRUE ~ -36) +
case_when(df$skorygowana_atrakcyjnosc < -0.07 ~ -46,
df$skorygowana_atrakcyjnosc < -0.055 ~ -33,
df$skorygowana_atrakcyjnosc < -0.035 ~ -36,
df$skorygowana_atrakcyjnosc < -0.03 ~ -10,
df$skorygowana_atrakcyjnosc < -0.02 ~ 5,
df$skorygowana_atrakcyjnosc < -0.015 ~ 18,
df$skorygowana_atrakcyjnosc < -0.01 ~ 20,
TRUE ~ 33) +
case_when(df$stopien_refinansowania < 1 ~ 18,
TRUE ~ -37) +
case_when(df$stosunek_refin_konkur < 1.2 ~ -1,
df$stosunek_refin_konkur < 1.4 ~ 1,
TRUE ~ 2) +
case_when(df$typ_umowy == "N" ~ -5,
df$typ_umowy == "R" ~ 4,
df$typ_umowy == "U" ~ 1,
TRUE ~ 0) +
case_when(df$umowa_N_roznica_oproc < 0.025 ~ 4,
TRUE ~ -57) +
case_when(df$wartosc_refinansowania < 12 ~ -14,
TRUE ~ 63) +
case_when(df$wskaźnik_refin_zysku < 200 ~ -8,
TRUE ~ 27) +
case_when(df$wysoka_kwota < 1 ~ -6,
TRUE ~ 30)
return(score)
}
# Wyznazcenie score na danych pierwotnych (bez przekształceń)
iv_data_with_scores_all$score_z_funkcji <- score_function(df_copy)
# Sprawdzenie, czy są różnice
iv_data_with_scores_all$scores_diff<- iv_data_with_scores_all$score-iv_data_with_scores_all$score_z_funkcji
summary(iv_data_with_scores_all$scores_diff)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0 0 0 0 0 0
# Testowy dataset
df3<-data.frame(
LP = c(1, 2, 3, 4, 5),
data_akceptacji = structure(c(1113696000, 1113696000, 1113696000, 1113696000,1113696000),
tzone = "UTC", class = c("POSIXct", "POSIXt")),
grupa_ryzyka = c(2, 2, 1, 1, 3),
kod_partnera = c(2, 2, 3, 1, 1),
typ_umowy = c("R", "N", "N", "R", "U"),
scoring_FICO = c(702, 719, 802, 723, 690),
okres_kredytu = c(48, 72, 60, 60, 72),
kwota_kredytu = c(26500, 34999.99, 28000, 20750.69, 19999.99),
oproc_refin = c(0.0399, 0, 0, 0.0675, 0),
oproc_konkur = c(0.0499, 0.0479, 0.0399, 0.0499, 0.0529),
koszt_pieniadza = c(0.011, 0.011, 0.011, 0.011, 0.011),
oproc_propon = c(0.0659, 0.0599, 0.0355, 0.0489, 0.0679),
akceptacja_klienta = c(0, 0, 0, 1, 0))
df3$score <- score_function(df3)