Biblioteka

Zaladowanie danych.

library(googlesheets4)
gs4_deauth()
kredyty <- read_sheet("1ZxsqdQ8NlfZ5etCP9LR1vXNWkIcS6mgcnbc_8L-x-pA")
## v Reading from "kredyty_auto_Scoring2025s".
## v Range 'Training'.
head(kredyty)
## # A tibble: 6 x 13
##      LP data_akceptacji     grupa_ryzyka kod_partnera typ_umowy scoring_FICO
##   <dbl> <dttm>                     <dbl>        <dbl> <chr>            <dbl>
## 1     1 2005-04-17 00:00:00            2            2 R                  702
## 2     2 2005-04-17 00:00:00            2            2 N                  719
## 3     3 2005-04-17 00:00:00            1            3 N                  802
## 4     4 2005-04-17 00:00:00            1            1 R                  723
## 5     5 2005-04-17 00:00:00            3            1 U                  690
## 6     6 2005-04-21 00:00:00            1            3 N                  681
## # i 7 more variables: okres_kredytu <dbl>, kwota_kredytu <dbl>,
## #   oproc_refin <dbl>, oproc_konkur <dbl>, koszt_pieniadza <dbl>,
## #   oproc_propon <dbl>, akceptacja_klienta <dbl>

Pierwszym krokiem jest sprawdzenie statystyk opisowych zmiennyc. w danych “kredyty” jest kilka pozycji, z ktorych nie trzeba opisywac takie jak LP, data_akceptacji, grupa_ryzyka, kod_partnera, typ_umowy, koszt_pieniadza, wiec je wykluczamy. Zmienne: grupa ryzyka, kod partnera oraz typ umowy zostaną przedstawione w tabeli.

stat_op<-psych::describe(kredyty %>% select(-c(LP,data_akceptacji,grupa_ryzyka,kod_partnera,typ_umowy, koszt_pieniadza))) 

stat_op 
##                    vars     n     mean       sd   median  trimmed      mad
## scoring_FICO          1 40000   720.73    46.58   717.00   719.12    51.89
## okres_kredytu         2 40000    57.19    11.39    60.00    57.98     8.90
## kwota_kredytu         3 40000 24211.65 11211.39 23000.00 23463.43 11079.79
## oproc_refin           4 40000     0.02     0.04     0.00     0.02     0.00
## oproc_konkur          5 40000     0.05     0.01     0.05     0.05     0.01
## oproc_propon          6 40000     0.07     0.02     0.06     0.06     0.02
## akceptacja_klienta    7 40000     0.26     0.44     0.00     0.20     0.00
##                        min      max    range  skew kurtosis    se
## scoring_FICO        601.00 8.51e+02   250.00  0.27    -0.71  0.23
## okres_kredytu        36.00 7.20e+01    36.00 -0.60    -0.53  0.06
## kwota_kredytu      4526.62 1.00e+05 95473.38  0.87     1.83 56.06
## oproc_refin           0.00 2.40e-01     0.24  1.63     2.06  0.00
## oproc_konkur          0.03 6.00e-02     0.03 -0.09     0.45  0.00
## oproc_propon          0.03 1.10e-01     0.09  0.64    -0.57  0.00
## akceptacja_klienta    0.00 1.00e+00     1.00  1.10    -0.79  0.00

Wykresy zmiennych.

#Histogram scoring_FICO
ggplot(kredyty, aes(x = scoring_FICO)) +
  geom_histogram(fill = "steelblue", color = "white", bins = 30) +
  theme_minimal() +
  labs(title = "Rozkład scoringu FICO", x = "Scoring FICO", y = "Liczba klientów")

# Histogram kwota_kredytu
ggplot(kredyty, aes(x = kwota_kredytu)) +
  geom_histogram(fill = "darkorange", color = "white", bins = 30) +
  theme_minimal() +
  labs(title = "Rozkład kwoty kredytu", x = "Kwota kredytu", y = "Liczba klientów")

# Wykres słupkowy typ_umowy
ggplot(kredyty, aes(x = typ_umowy)) +
  geom_bar(fill = "darkgreen") +
  theme_minimal() +
  labs(title = "Liczba przypadków według typu umowy", x = "Typ umowy", y = "Liczba") +
  theme(axis.text = element_text(size = 12), plot.title = element_text(size = 14, face = "bold"))

# Boxplot kwota kredytu vs akceptacja
ggplot(kredyty, aes(x = factor(akceptacja_klienta), y = kwota_kredytu, fill = factor(akceptacja_klienta))) +
  geom_boxplot() +
  scale_fill_manual(values = c("#F8766D", "#00BA38")) +
  theme_minimal() +
  labs(title = "Kwota kredytu a akceptacja klienta", x = "Akceptacja (0 = NIE, 1 = TAK)", y = "Kwota kredytu")

# Średni scoring FICO vs akceptacja
kredyty %>%
  group_by(akceptacja_klienta) %>%
  summarise(sredni_scor = mean(scoring_FICO, na.rm = TRUE)) %>%
  ggplot(aes(x = factor(akceptacja_klienta), y = sredni_scor, fill = factor(akceptacja_klienta))) +
  geom_col() +
  scale_fill_manual(values = c("#619CFF", "#F564E3")) +
  theme_minimal() +
  labs(title = "Średni scoring FICO wg akceptacji", x = "Akceptacja", y = "Średni scoring")

# Udział akceptacji wg grupy ryzyka
ggplot(kredyty, aes(x = factor(grupa_ryzyka), fill = factor(akceptacja_klienta))) +
  geom_bar(position = "fill") +
  scale_y_continuous(labels = scales::percent) +
  scale_fill_manual(values = c("gray70", "darkblue")) +
  theme_minimal() +
  labs(title = "Procent akceptacji w grupach ryzyka", x = "Grupa ryzyka", y = "Udział (%)")

# Scatterplot scoring vs kwota
ggplot(kredyty, aes(x = scoring_FICO, y = kwota_kredytu)) +
  geom_density_2d_filled(alpha = 0.7) +
  theme_minimal() +
  labs(title = "Gęstość 2D: scoring FICO vs kwota kredytu",
       x = "Scoring FICO", y = "Kwota kredytu", fill = "Gęstość")

Sprawdzamy za pomoca funkcji table, ile wystepuje grup ryzyka i ile jest akcetpacji w danej grupie ryzka i taki same pivoty robimy dla innych kombinacji.

table(kredyty$grupa_ryzyka) 
## 
##     1     2     3     4 
## 17448  8265  8977  5310
table(kredyty$kod_partnera) 
## 
##     1     2     3 
## 14810  6243 18947
table(kredyty$typ_umowy) 
## 
##     N     R     U 
## 14323 11298 14379
table(kredyty$akceptacja_klienta) 
## 
##     0     1 
## 29633 10367
table(kredyty$akceptacja_klienta, kredyty$grupa_ryzyka) 
##    
##         1     2     3     4
##   0 11357  6530  7432  4314
##   1  6091  1735  1545   996
table(kredyty$akceptacja_klienta, kredyty$kod_partnera) 
##    
##         1     2     3
##   0 10040  5701 13892
##   1  4770   542  5055
table(kredyty$akceptacja_klienta, kredyty$typ_umowy) 
##    
##         N     R     U
##   0 12625  6692 10316
##   1  1698  4606  4063
aggregate(scoring_FICO ~ grupa_ryzyka, data = kredyty, FUN = mean)
##   grupa_ryzyka scoring_FICO
## 1            1     759.5769
## 2            2     710.1155
## 3            3     693.6748
## 4            4     655.3380
aggregate(kwota_kredytu ~ grupa_ryzyka, data = kredyty, FUN = mean)
##   grupa_ryzyka kwota_kredytu
## 1            1      24387.22
## 2            2      25140.98
## 3            3      24941.85
## 4            4      20953.79

Opis wyników: najwiecej klientow znajduje sie w 1 grupie ryzyka. Najczesciej wystepujacy kod partnera to 2. Wnioski o finansowanie na nowe i uzywane samochodu sa skladane podobnie czesto. Okolo 25% klienktow zaakceptowalo oferte. Partner 2 ma bardzo niski współczynnik akceptacji: tylko 542 osoby zaakceptowane spośród 6 243. Im wyższa grupa ryzyka tym nizszy scroring FIC0. Im wyższa grupa ryzyka tym niższa kwota kredytu.

Dodanie zmiennych pochodnych

kredyty <- kredyty %>%
  mutate(
    koszt_marzy = oproc_propon - koszt_pieniadza,
    kwota_na_miesiac = kwota_kredytu / okres_kredytu,
    relacja_oproc_konkur = oproc_propon - oproc_konkur
  )

Zmienne grupa ryzyka, kod partera, typ_umowy oraz akceptacja_klienta sa zmiennymi skategoryzowanymi. Powinny byc zapisane jako facctor (oprocz akceptacja klienta) Zmienne scoring FICO, okres kredytu, kwota kredytu, oproc_refin, oproc_konkur, kost_pieniasza oraz oproc_proponowane to zmienne, ktĂłre wymagaja skubelkowania, zanim przejdziemy do obliczenia WOE i IV. Na razie dane zbinuje dzielac je na 10, a na podstawie WOE okresle czy takie zbinowanie jest sensowne Zapisanie zmiennych skateryzowanych jako faktor. Oprocentowanie konkur tez zmienilam na faktor, bo byky z nim problemy.

kredyty <- kredyty %>% 
  mutate( 
    grupa_ryzyka = factor(grupa_ryzyka), 
    kod_partnera = factor(kod_partnera), 
    typ_umowy = factor(typ_umowy), 
  ) 

kredyty <- kredyty %>%  
  select(-data_akceptacji, -LP)

Niektore zmienne zbinuje recznie.

kredyty$koszt_pieniadza <- cut(kredyty$koszt_pieniadza, 
                               breaks = seq(0.011, 0.021010, length.out =11), 
                               include.lowest = TRUE, 
                               right = FALSE) 

kredyty$oproc_konkur <- cut(kredyty$oproc_konkur, 
                            breaks = c(0.02, 0.04, 0.045, 0.05, 0.055, 0.07), 
                            include.lowest = TRUE, 
                            right = FALSE)  

bins <- 10 
kredyty$oproc_propon<- cut(kredyty$oproc_propon,  
                           breaks = seq(min(kredyty$oproc_propon),  
                                        max(kredyty$oproc_propon),  
                                        length.out = bins + 1), 
                           include.lowest = TRUE,  
                           right = FALSE)

Obliczenie IV i WOE.

IV <- create_infotables(data=kredyty,  y="akceptacja_klienta", bins=10, parallel=FALSE) 

IV_Value = data.frame(IV$Summary) 
print(IV_Value) 
##                Variable          IV
## 6         kwota_kredytu 0.966148739
## 12     kwota_na_miesiac 0.916174986
## 3             typ_umowy 0.403734127
## 7           oproc_refin 0.284525554
## 13 relacja_oproc_konkur 0.233783214
## 2          kod_partnera 0.220400987
## 11          koszt_marzy 0.204111988
## 10         oproc_propon 0.187659568
## 1          grupa_ryzyka 0.175409351
## 8          oproc_konkur 0.173245076
## 4          scoring_FICO 0.093247876
## 5         okres_kredytu 0.070220937
## 9       koszt_pieniadza 0.008085915

#Wyprintowanie wartosci WOE - podsumowanie

print(IV$Tables, row.names = FALSE) 
## $grupa_ryzyka
##  grupa_ryzyka     N  Percent        WOE         IV
##             1 17448 0.436200  0.4272389 0.08727731
##             2  8265 0.206625 -0.2751386 0.10186089
##             3  8977 0.224425 -0.5205102 0.15483367
##             4  5310 0.132750 -0.4156126 0.17540935
## 
## $kod_partnera
##  kod_partnera     N  Percent         WOE         IV
##             1 14810 0.370250  0.30603011 0.03712218
##             2  6243 0.156075 -1.30286995 0.21966154
##             3 18947 0.473675  0.03932564 0.22040099
## 
## $typ_umowy
##  typ_umowy     N  Percent        WOE        IV
##          N 14323 0.358075 -0.9559670 0.2507084
##          R 11298 0.282450  0.6767079 0.3985455
##          U 14379 0.359475  0.1184864 0.4037341
## 
## $scoring_FICO
##  scoring_FICO    N  Percent        WOE          IV
##     [601,659] 3892 0.097300 -0.1978831 0.003625452
##     [660,676] 3903 0.097575 -0.3021104 0.011868833
##     [677,690] 4068 0.101700 -0.3064896 0.020701165
##     [691,703] 3869 0.096725 -0.3683311 0.032630863
##     [704,716] 4131 0.103275 -0.1123181 0.033898104
##     [717,729] 3809 0.095225 -0.2446837 0.039256761
##     [730,745] 4209 0.105225  0.4941902 0.067770815
##     [746,763] 3945 0.098625  0.4057750 0.085499635
##     [764,786] 4148 0.103700  0.2389825 0.091752344
##     [787,851] 4026 0.100650  0.1201937 0.093247876
## 
## $okres_kredytu
##  okres_kredytu     N  Percent         WOE         IV
##        [36,36]  6109 0.152725  0.48111512 0.03913377
##        [48,48]  5590 0.139750  0.21146724 0.04569277
##        [60,60] 19376 0.484400 -0.22557601 0.06897765
##        [66,66]   988 0.024700 -0.22344522 0.07014330
##        [72,72]  7937 0.198425 -0.01982804 0.07022094
## 
## $kwota_kredytu
##       kwota_kredytu    N  Percent        WOE        IV
##  [4526.62,10837.33] 3999 0.099975  1.6154806 0.3183702
##    [10848.08,14521] 4000 0.100000  1.0772626 0.4572758
##       [14523,17114] 4000 0.100000  0.3891941 0.4737605
##    [17116,19999.99] 3744 0.093600  0.3000710 0.4827722
##    [20000,22999.99] 4110 0.102750 -0.1694886 0.4856016
##       [23000,25488] 4146 0.103650 -0.6266782 0.5199981
##    [25489,29999.88] 3898 0.097450 -0.4260002 0.5358210
##  [29999.99,33728.1] 4102 0.102550 -1.2373985 0.6462079
##       [33733,39897] 3999 0.099975 -1.4872749 0.7901769
##       [39900,1e+05] 4002 0.100050 -1.6973823 0.9661487
## 
## $oproc_refin
##  oproc_refin     N  Percent        WOE         IV
##     [0,0.06] 31871 0.796775 -0.2973024 0.06527248
##  [0.06,0.09]  4095 0.102375  0.6498807 0.11449319
##  [0.09,0.24]  4034 0.100850  1.1823316 0.28452555
## 
## $oproc_konkur
##  oproc_konkur     N  Percent         WOE           IV
##   [0.02,0.04)  2007 0.050175  0.01508932 1.146567e-05
##  [0.04,0.045)  8049 0.201225 -0.93381905 1.353520e-01
##  [0.045,0.05) 10976 0.274400  0.05539797 1.362053e-01
##  [0.05,0.055) 14173 0.354325  0.20333262 1.515533e-01
##  [0.055,0.07]  4795 0.119875  0.40706984 1.732451e-01
## 
## $koszt_pieniadza
##  koszt_pieniadza     N  Percent         WOE           IV
##             <NA>     1 0.000025  0.00000000 0.0000000000
##    [0.011,0.012) 12486 0.312150  0.03185066 0.0003190856
##    [0.012,0.013)  3358 0.083950 -0.15526107 0.0022660753
##    [0.013,0.014)  5121 0.128025 -0.07905035 0.0030507515
##    [0.014,0.015)  2454 0.061350 -0.01922309 0.0030733169
##    [0.015,0.016)  4906 0.122650  0.12224069 0.0049592201
##    [0.016,0.017)  4507 0.112675  0.10143682 0.0061465688
##    [0.017,0.018)  2357 0.058925  0.02443832 0.0061819672
##    [0.018,0.019)  4809 0.120225 -0.12785030 0.0080859146
##     [0.02,0.021]     1 0.000025  0.00000000 0.0080859146
## 
## $oproc_propon
##     oproc_propon     N  Percent         WOE         IV
##  [0.0259,0.0347)   395 0.009875  0.98441436 0.01135978
##  [0.0347,0.0434)  2372 0.059300  0.05683582 0.01155394
##  [0.0434,0.0522) 11697 0.292425  0.30784397 0.04123271
##  [0.0522,0.0609)  3979 0.099475  0.64521466 0.08834119
##  [0.0609,0.0697)  6024 0.150600 -0.19260466 0.09366457
##  [0.0697,0.0785)  4591 0.114775 -0.12746858 0.09547154
##  [0.0785,0.0872)  4728 0.118200 -0.71655228 0.14542216
##   [0.0872,0.096)  1864 0.046600 -0.41080257 0.15248817
##    [0.096,0.105)   895 0.022375 -0.35005892 0.15499331
##    [0.105,0.113]  3455 0.086375 -0.67359768 0.18765957
## 
## $koszt_marzy
##  koszt_marzy    N  Percent         WOE           IV
##  [0.01,0.03] 3995 0.099875 -0.04135484 0.0001691003
##  [0.03,0.03] 4003 0.100075  0.03422692 0.0002872991
##  [0.03,0.04] 4000 0.100000  0.58188199 0.0384196092
##  [0.04,0.04] 3978 0.099450  0.68423754 0.0916967242
##  [0.04,0.05] 4022 0.100550  0.30215072 0.1015163800
##  [0.05,0.05] 3997 0.099925 -0.03936479 0.1016697487
##  [0.05,0.06] 4004 0.100100 -0.22252209 0.1063558641
##  [0.06,0.07] 3963 0.099075 -0.79002559 0.1561544436
##  [0.07,0.09] 4036 0.100900 -0.34099623 0.1669005364
##   [0.09,0.1] 4002 0.100050 -0.66739058 0.2041119883
## 
## $kwota_na_miesiac
##  kwota_na_miesiac    N  Percent         WOE        IV
##    [69.44,208.33] 3987 0.099675  1.54413359 0.2900567
##   [208.33,263.89] 4008 0.100200  0.92134014 0.3903739
##    [263.89,312.5] 3925 0.098125  0.65645961 0.4385594
##    [312.5,354.17] 4077 0.101925  0.18055349 0.4420233
##    [354.17,409.4] 4002 0.100050  0.02815652 0.4421032
##   [409.44,445.82] 3998 0.099950 -0.67203409 0.4797453
##      [445.83,500] 3414 0.085350 -0.65275737 0.5102428
##      [500,575.76] 4584 0.114600 -1.08178478 0.6091312
##   [575.76,666.67] 3410 0.085250 -1.60940262 0.7476017
##  [666.67,2777.78] 4595 0.114875 -1.50558367 0.9161750
## 
## $relacja_oproc_konkur
##  relacja_oproc_konkur     N  Percent         WOE         IV
##             [-0.02,0]  3356 0.083900  0.61565666 0.03600958
##                 [0,0]  2531 0.063275  0.39656543 0.04685442
##              [0,0.01] 13990 0.349750  0.34475796 0.09170548
##           [0.01,0.02]  4090 0.102250 -0.01793815 0.09173824
##           [0.02,0.03]  4013 0.100325 -0.41025951 0.10691273
##           [0.03,0.03]  3931 0.098275 -0.73646225 0.15052598
##           [0.04,0.05]  4076 0.101900 -0.70840261 0.19271554
##           [0.05,0.08]  4013 0.100325 -0.70392063 0.23378321

Zapisanie wynikow do tabeli

grupa_ryzyka = data.frame(IV$Tables$grupa_ryzyka) 
kod_partnera = data.frame(IV$Tables$kod_partnera) 
typ_umowy = data.frame(IV$Tables$typ_umowy) 
scoring_FICO =  data.frame(IV$Tables$scoring_FICO) 
okres_kredytu = data.frame(IV$Tables$okres_kredytu) 
kwota_kredytu = data.frame(IV$Tables$kwota_kredytu) 
oproc_refin = data.frame(IV$Tables$oproc_refin) 
oproc_konkur = data.frame(IV$Tables$oproc_konkur) 
koszt_pieniadza = data.frame(IV$Tables$koszt_pieniadza) 
oproc_propon = data.frame(IV$Tables$oproc_propon)

Rysowanie wykresow wartosci WOE

plot_infotables(IV, "grupa_ryzyka", same_scale = FALSE) 

plot_infotables(IV, "kod_partnera", same_scale = FALSE) 

plot_infotables(IV, "typ_umowy", same_scale = FALSE) 

plot_infotables(IV, "scoring_FICO", same_scale = FALSE) 

plot_infotables(IV, "okres_kredytu", same_scale = FALSE) 

plot_infotables(IV, "kwota_kredytu", same_scale = FALSE) 

plot_infotables(IV, "oproc_refin", same_scale = FALSE) 

plot_infotables(IV, "oproc_konkur", same_scale = FALSE) 

plot_infotables(IV, "koszt_pieniadza", same_scale = FALSE) 

plot_infotables(IV, "oproc_propon", same_scale = FALSE)

Czesc 2

library(dplyr)
library(scorecard)
library(kableExtra)
## Warning: pakiet 'kableExtra' został zbudowany w wersji R 4.1.3
## 
## Dołączanie pakietu: 'kableExtra'
## Następujący obiekt został zakryty z 'package:dplyr':
## 
##     group_rows
library(pROC)
## Warning: pakiet 'pROC' został zbudowany w wersji R 4.1.3
## Type 'citation("pROC")' for a citation.
## 
## Dołączanie pakietu: 'pROC'
## Następujące obiekty zostały zakryte z 'package:stats':
## 
##     cov, smooth, var
library(bigstatsr)
## Warning: pakiet 'bigstatsr' został zbudowany w wersji R 4.1.3
## 
## Dołączanie pakietu: 'bigstatsr'
## Następujący obiekt został zakryty z 'package:psych':
## 
##     AUC
library(dplyr)
library(scorecard)
library(kableExtra)
library(pROC)
library(bigstatsr)
library(readxl)

knitr::opts_chunk$set(
  echo = TRUE,
  message = FALSE,
  warning = FALSE
)

Definicja ręcznych podziałów dla zmiennych kategorycznych

breaks_list = list(
  grupa_ryzyka = as.character(sort(unique(kredyty$grupa_ryzyka))),
  kod_partnera = as.character(sort(unique(kredyty$kod_partnera))),
  typ_umowy = as.character(sort(unique(kredyty$typ_umowy)))
)

Fragment kodu tworzy listę breaks_list, która zawiera unikalne, posortowane wartości dla trzech zmiennych kategorycznych: grupa_ryzyka, kod_partnera oraz typ_umowy. Każda z tych zmiennych jest konwertowana na typ tekstowy, aby mogła być wykorzystana do ręcznego binningowania w funkcji woebin(). Zapewni to, że zmienne zostaną zaklasyfikowane dokładnie według istniejących kategorii, bez automatycznego łączenia grup.

Tworzenie binów WOE dla zmiennych

bins <- woebin(
  kredyty,
  y = "akceptacja_klienta",
  var_skip = c("LP", "data_akceptacji"),
  breaks_list = breaks_list
)
## v Binning on 40000 rows and 14 columns in 00:00:03

Utworzono biny WOE dla zmiennych z danych kredyty, przyjmując akceptacja_klienta jako zmienną docelową. Zmiennym LP i data_akceptacji pomija binning, a dla zmiennych kategorycznych używa ręcznie zdefiniowanych przedziałów z breaks_list.

Przekształcenie danych na wartości WOE

kredyty_woe <- woebin_ply(kredyty, bins, to = "woe")
## v Woe transformating on 40000 rows and 13 columns in 00:00:11

Ten kod przekształca dane kredyty na wersję binarną odpowiadającą przypisanym przedziałom WOE, zgodnie z wcześniej stworzonymi binami. Utworzy to nową ramkę danych na podstawie której będzie ustawiany model.

Budowa modelu regresji logistycznej

model <- glm(
  akceptacja_klienta ~ .,
  family = binomial(),
  data = kredyty_woe %>% select(-any_of(c("LP", "data_akceptacji")))
)

Na podstawie zbioru treningowego opracowano model regresji logistycznej, wykorzystując zmienne przekształcone do formatu WOE (Weight of Evidence). Taka transformacja pozwala uwzględnić relacje nieliniowe między zmiennymi a zmienną celu, a także ogranicza wpływ wartości odstających. Model prognozuje prawdopodobieństwo zaakceptowania klienta (akceptacja_klienta = 1) w oparciu o cechy kredytu, klienta i oferty.

Zmienne objaśniające zostały wcześniej zbinowane na podstawie optymalnych lub zdefiniowanych przedziałów, co umożliwiło ich jednoznaczne zakodowanie. Wśród predyktorów znalazły się zarówno zmienne liczbowe, jak i kategoryczne, m.in.:

grupa_ryzyka — gdzie wyższe grupy (np. 3 i 4) istotnie obniżają szanse akceptacji,

kod_partnera_bin2 — o silnym negatywnym wpływie (Estimate = -1.88, p < 0.001),

typ_umowy_binR i typ_umowy_binU — które zwiększają prawdopodobieństwo akceptacji (Estimate ≈ 1.1, p < 0.001),

a także scoring_FICO, kwota_kredytu, oproc_refin, kwota_na_miesiac i inne.

Zdecydowana większość zmiennych osiągnęła istotność statystyczną (p < 0.05), co wskazuje na ich wysoką wartość predykcyjną. Wyjątki (np. część przedziałów koszt_pieniadza czy relacja_oproc_konkur) wykazały mniejszą istotność, co może sugerować ich ograniczoną przydatność w końcowej wersji modelu.

Oceniając jakość modelu:

AUC wynosi 0.84, co oznacza wysoką zdolność modelu do rozróżniania pomiędzy klientami zaakceptowanymi a odrzuconymi,

Wskaźnik Gini = 0.68, również potwierdza dobrą separację klas,

Redukcja deviance z 32051 do 23282 wskazuje na dobrą poprawę dopasowania względem modelu zerowego,

AIC = 23360, co może być wykorzystane jako punkt odniesienia przy porównywaniu alternatywnych modeli.

Predykcja prawdopodobieństw na zbiorze testowym

#pred_probs <- predict(model, newdata = test_data, type = "response")

Krzywa ROC i AUC

# Oblicz predykcje na całym zbiorze
pred_probs <- predict(model, newdata = kredyty_woe, type = "response")

# Krzywa ROC i AUC na całym zbiorze
library(pROC)
kredyty_woe$akceptacja_klienta <- as.numeric(as.character(kredyty_woe$akceptacja_klienta))
roc_obj <- roc(kredyty_woe$akceptacja_klienta, pred_probs)
auc_val <- auc(roc_obj)

Wykres ROC

plot(roc_obj, 
     col = "blue", 
     lwd = 2, 
     main = paste("Krzywa ROC - AUC =", round(auc_val, 3)))

Wartość Gini

gini_val <- 2 * auc_val - 1
gini_val
## [1] 0.6654948

Wskaźnik Gini na poziomie 0.68 świadczy o bardzo dobrej zdolności modelu do rozróżniania pomiędzy klientami zaakceptowanymi a odrzuconymi, co oznacza, że model efektywnie klasyfikuje ryzyko i może być skutecznie wykorzystywany w procesie decyzyjnym.

Wyznaczenie optymalnego punktu odcięcia

optimal_cutoff <- coords(roc_obj, "best", ret = "threshold")

Predykcja klasy na podstawie progu dla KAŻDEGO rekordu w zbiorze testowym

pred_class <- ifelse(pred_probs >= optimal_cutoff, 1, 0)

Stworzenie karty scoringowej

# Karta scoringowa (bez jawnego ustawiania points0, zachowuje sumę 108) ---
card <- scorecard(bins, model)

# Funkcja do zebrania pełnej tabeli scoringowej ---
scoring_ranges_df <- function(card) {
  dplyr::bind_rows(card, .id = "zmienna")
}

#Stworzenie i wyświetlenie tabeli scoringowej ---
tabela_scoringowa <- scoring_ranges_df(card)

#View(tabela_scoringowa)

# Lub wyświetlić w RMarkdown
tabela_scoringowa %>%
  kbl(caption = "Pełna tabela scoringowa") %>%
  kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
Pełna tabela scoringowa
zmienna variable bin woe points count count_distr neg pos posprob bin_iv total_iv breaks is_special_values
basepoints basepoints NA NA 464 NA NA NA NA NA NA NA NA NA
grupa_ryzyka grupa_ryzyka 1 0.4272389 -28 17448 0.436200 11357 6091 0.3490945 0.0872773 0.1754094 1 FALSE
grupa_ryzyka grupa_ryzyka 2 -0.2751386 18 8265 0.206625 6530 1735 0.2099214 0.0145836 0.1754094 2 FALSE
grupa_ryzyka grupa_ryzyka 3 -0.5205102 34 8977 0.224425 7432 1545 0.1721065 0.0529728 0.1754094 3 FALSE
grupa_ryzyka grupa_ryzyka 4 -0.4156126 27 5310 0.132750 4314 996 0.1875706 0.0205757 0.1754094 4 FALSE
kod_partnera kod_partnera 1 0.3060301 -26 14810 0.370250 10040 4770 0.3220797 0.0371222 0.2204010 1 FALSE
kod_partnera kod_partnera 2 -1.3028700 112 6243 0.156075 5701 542 0.0868172 0.1825394 0.2204010 2 FALSE
kod_partnera kod_partnera 3 0.0393256 -3 18947 0.473675 13892 5055 0.2667969 0.0007394 0.2204010 3 FALSE
typ_umowy typ_umowy N -0.9559670 18 14323 0.358075 12625 1698 0.1185506 0.2507084 0.4037341 N FALSE
typ_umowy typ_umowy R 0.6767079 -13 11298 0.282450 6692 4606 0.4076828 0.1478371 0.4037341 R FALSE
typ_umowy typ_umowy U 0.1184864 -2 14379 0.359475 10316 4063 0.2825649 0.0051887 0.4037341 U FALSE
scoring_FICO scoring_FICO [-Inf,700) -0.3144567 -8 14390 0.359750 11462 2928 0.2034746 0.0328179 0.0922810 700 FALSE
scoring_FICO scoring_FICO [700,730) -0.1597909 -4 9282 0.232050 7150 2132 0.2296919 0.0056938 0.0922810 730 FALSE
scoring_FICO scoring_FICO [730,770) 0.4393000 11 9402 0.235050 6094 3308 0.3518400 0.0498343 0.0922810 770 FALSE
scoring_FICO scoring_FICO [770, Inf) 0.1481777 4 6926 0.173150 4927 1999 0.2886226 0.0039350 0.0922810 Inf FALSE
okres_kredytu okres_kredytu [-Inf,48) 0.4811151 0 6109 0.152725 3901 2208 0.3614339 0.0391338 0.0702208 48 FALSE
okres_kredytu okres_kredytu [48,60) 0.2114672 0 5590 0.139750 3903 1687 0.3017889 0.0065590 0.0702208 60 FALSE
okres_kredytu okres_kredytu [60,72) -0.2254726 0 20364 0.509100 15919 4445 0.2182774 0.0244504 0.0702208 72 FALSE
okres_kredytu okres_kredytu [72, Inf) -0.0198280 0 7937 0.198425 5910 2027 0.2553862 0.0000776 0.0702208 Inf FALSE
kwota_kredytu kwota_kredytu [-Inf,10000) 1.6729663 -56 3179 0.079475 1110 2069 0.6508336 0.2712168 0.9361042 10000 FALSE
kwota_kredytu kwota_kredytu [10000,14000) 1.1687825 -39 4156 0.103900 1955 2201 0.5295958 0.1710333 0.9361042 14000 FALSE
kwota_kredytu kwota_kredytu [14000,20000) 0.3929395 -13 8408 0.210200 5538 2870 0.3413416 0.0353464 0.9361042 20000 FALSE
kwota_kredytu kwota_kredytu [20000,30000) -0.4129267 14 12363 0.309075 10039 2324 0.1879803 0.0473234 0.9361042 30000 FALSE
kwota_kredytu kwota_kredytu [30000, Inf) -1.4488486 48 11894 0.297350 10991 903 0.0759206 0.4111843 0.9361042 Inf FALSE
oproc_refin oproc_refin [-Inf,0.065) -0.2973024 10 31871 0.796775 25297 6574 0.2062690 0.0652725 0.2837004 0.065 FALSE
oproc_refin oproc_refin [0.065,0.1) 0.7360215 -24 5480 0.137000 3167 2313 0.4220803 0.0855535 0.2837004 0.1 FALSE
oproc_refin oproc_refin [0.1, Inf) 1.2861543 -43 2649 0.066225 1169 1480 0.5587014 0.1328744 0.2837004 Inf FALSE
oproc_konkur oproc_konkur [0.02,0.04) 0.0150893 -1 2007 0.050175 1481 526 0.2620827 0.0000115 0.1697603 0.04 FALSE
oproc_konkur oproc_konkur [0.04,0.045) -0.9338191 35 8049 0.201225 7076 973 0.1208846 0.1353406 0.1697603 0.045 FALSE
oproc_konkur oproc_konkur [0.045,0.05)%,%[0.05,0.055) 0.1399191 -5 25149 0.628725 17933 7216 0.2869299 0.0127165 0.1697603 0.055 FALSE
oproc_konkur oproc_konkur [0.055,0.07] 0.4070698 -15 4795 0.119875 3143 1652 0.3445255 0.0216918 0.1697603 [0.055,0.07] FALSE
koszt_pieniadza koszt_pieniadza [0.011,0.012)%,%missing 0.0317416 -1 12487 0.312175 9174 3313 0.2653159 0.0003169 0.0075512 0.012%,%missing FALSE
koszt_pieniadza koszt_pieniadza [0.012,0.013) -0.1552611 3 3358 0.083950 2584 774 0.2304943 0.0019470 0.0075512 0.013 FALSE
koszt_pieniadza koszt_pieniadza [0.013,0.014)%,%[0.014,0.015) -0.0594714 1 7575 0.189375 5697 1878 0.2479208 0.0006601 0.0075512 0.015 FALSE
koszt_pieniadza koszt_pieniadza [0.015,0.016)%,%[0.016,0.017)%,%[0.017,0.018) 0.0949847 -2 11770 0.294250 8500 3270 0.2778250 0.0027148 0.0075512 0.018 FALSE
koszt_pieniadza koszt_pieniadza [0.018,0.019)%,%[0.02,0.021] -0.1281222 2 4810 0.120250 3678 1132 0.2353430 0.0019123 0.0075512 0.019%,%[0.02,0.021] FALSE
oproc_propon oproc_propon [0.0259,0.0347)%,%[0.0347,0.0434)%,%[0.0434,0.0522) 0.2887002 -8 14464 0.361600 9860 4604 0.3183075 0.0321509 0.1737405 0.0522 FALSE
oproc_propon oproc_propon [0.0522,0.0609) 0.6452147 -19 3979 0.099475 2387 1592 0.4001005 0.0471085 0.1737405 0.0609 FALSE
oproc_propon oproc_propon [0.0609,0.0697)%,%[0.0697,0.0785) -0.1641510 5 10615 0.265375 8185 2430 0.2289213 0.0068639 0.1737405 0.0785 FALSE
oproc_propon oproc_propon [0.0785,0.0872)%,%[0.0872,0.096)%,%[0.096,0.105)%,%[0.105,0.113] -0.6145916 18 10942 0.273550 9201 1741 0.1591117 0.0876172 0.1737405 0.105%,%[0.105,0.113] FALSE
koszt_marzy koszt_marzy [-Inf,0.032) -0.0043320 0 7730 0.193250 5733 1997 0.2583441 0.0000036 0.2226622 0.032 FALSE
koszt_marzy koszt_marzy [0.032,0.044) 0.6472858 9 9703 0.242575 5816 3887 0.4005978 0.1156519 0.2226622 0.044 FALSE
koszt_marzy koszt_marzy [0.044,0.052) -0.0977319 -1 5468 0.136700 4151 1317 0.2408559 0.0012747 0.2226622 0.052 FALSE
koszt_marzy koszt_marzy [0.052,0.058) 0.2098067 3 2571 0.064275 1796 775 0.3014391 0.0029684 0.2226622 0.058 FALSE
koszt_marzy koszt_marzy [0.058, Inf) -0.5742860 -8 14528 0.363200 12137 2391 0.1645787 0.1027636 0.2226622 Inf FALSE
kwota_na_miesiac kwota_na_miesiac [-Inf,240) 1.3686085 -54 6101 0.152525 2569 3532 0.5789215 0.3476300 0.8573478 240 FALSE
kwota_na_miesiac kwota_na_miesiac [240,400) 0.3861469 -15 13266 0.331650 8758 4508 0.3398161 0.0537874 0.8573478 400 FALSE
kwota_na_miesiac kwota_na_miesiac [400,500) -0.6080042 24 8044 0.201100 6757 1287 0.1599950 0.0631588 0.8573478 500 FALSE
kwota_na_miesiac kwota_na_miesiac [500, Inf) -1.3571172 54 12589 0.314725 11549 1040 0.0826118 0.3927716 0.8573478 Inf FALSE
relacja_oproc_konkur relacja_oproc_konkur [-Inf,0.012) 0.3985631 -21 19877 0.496925 13067 6810 0.3426070 0.0860621 0.2217037 0.012 FALSE
relacja_oproc_konkur relacja_oproc_konkur [0.012,0.018) -0.0179382 1 4090 0.102250 3044 1046 0.2557457 0.0000328 0.2217037 0.018 FALSE
relacja_oproc_konkur relacja_oproc_konkur [0.018, Inf) -0.6333760 34 16033 0.400825 13522 2511 0.1566145 0.1356088 0.2217037 Inf FALSE 
# Funkcja scoringowa ---
score_zespol <- function(df){
  scorecard_ply(df %>% select(-LP), card)$score
}

W karcie scoringowej wartość bazowa (basepoints) została ustalona na poziomie 217 punktów i stanowi punkt wyjścia do obliczania końcowego wyniku scoringowego dla każdego klienta. Do tej wartości dodawane lub odejmowane są punkty przypisane do konkretnych przedziałów zmiennych (binów), co pozwala uzyskać ostateczny wynik punktacji indywidualnej. Taka konstrukcja ułatwia interpretację oraz porównywanie klientów pod względem ryzyka.

rmarkdown::render(“projekt_scoring_1.Rmd”, output_format = “html_document”)

#funkcja scoringowa

# --- 1. Wczytaj dane z Google Sheet ---
gs4_deauth()
dane <- read_sheet("https://docs.google.com/spreadsheets/d/1ZxsqdQ8NlfZ5etCP9LR1vXNWkIcS6mgcnbc_8L-x-pA")

# --- 2. Dodaj zmienne pochodne ---
dane <- dane %>%
  mutate(
    koszt_marzy = oproc_propon - koszt_pieniadza,
    kwota_na_miesiac = kwota_kredytu / okres_kredytu,
    relacja_oproc_konkur = oproc_propon - oproc_konkur
  )

# --- 3. Funkcja scoringowa zgodna z kartą scoringową ---
oblicz_score <- function(df) {
  464 +
    ifelse(df$grupa_ryzyka == 1, -28,
           ifelse(df$grupa_ryzyka == 2, 18,
                  ifelse(df$grupa_ryzyka == 3, 34, 27))) +
    ifelse(df$kod_partnera == 1, -26,
           ifelse(df$kod_partnera == 2, 112, -3)) +
    ifelse(df$typ_umowy == "N", 18,
           ifelse(df$typ_umowy == "R", -13, -2)) +
    ifelse(df$scoring_FICO < 700, -8,
           ifelse(df$scoring_FICO < 730, -4,
                  ifelse(df$scoring_FICO < 770, 11, 4))) +
    ifelse(df$okres_kredytu < 48, 0,
           ifelse(df$okres_kredytu < 60, 0,
                  ifelse(df$okres_kredytu < 72, 0, 0))) +
    ifelse(df$kwota_kredytu < 10000, -56,
           ifelse(df$kwota_kredytu < 14000, -39,
                  ifelse(df$kwota_kredytu < 20000, -13,
                         ifelse(df$kwota_kredytu < 30000, 14, 48)))) +
    ifelse(df$oproc_refin < 0.065, 10,
           ifelse(df$oproc_refin < 0.1, -24, -43)) +
    ifelse(df$oproc_konkur < 0.04, -1,
           ifelse(df$oproc_konkur < 0.045, 35,
                  ifelse(df$oproc_konkur < 0.055, -5, -15))) +
    ifelse(df$koszt_pieniadza < 0.012, -1,
           ifelse(df$koszt_pieniadza < 0.013, 3,
                  ifelse(df$koszt_pieniadza < 0.015, 1,
                         ifelse(df$koszt_pieniadza < 0.018, -2, 2)))) +
    ifelse(df$oproc_propon < 0.0522, -8,
           ifelse(df$oproc_propon < 0.0609, -19,
                  ifelse(df$oproc_propon < 0.0785, 5, 18))) +
    ifelse(df$koszt_marzy < 0.032, 0,
           ifelse(df$koszt_marzy < 0.044, 9,
                  ifelse(df$koszt_marzy < 0.052, -1,
                         ifelse(df$koszt_marzy < 0.058, 3, -8)))) +
    ifelse(df$kwota_na_miesiac < 240, -54,
           ifelse(df$kwota_na_miesiac < 400, -15,
                  ifelse(df$kwota_na_miesiac < 500, 24, 54))) +
    ifelse(df$relacja_oproc_konkur < 0.012, -21,
           ifelse(df$relacja_oproc_konkur < 0.018, 1, 34))
}

# --- 4. Oblicz scoring ---
dane$score <- oblicz_score(dane)

# --- 5. AUC i Gini ---
roc_obj <- roc(dane$akceptacja_klienta, -dane$score)
auc_val <- auc(roc_obj)
gini_val <- 2 * auc_val - 1

print(paste("AUC =", round(auc_val, 4)))
## [1] "AUC = 0.8328"
print(paste("Gini =", round(gini_val, 4)))
## [1] "Gini = 0.6656"

```