ScoreEgz
2025-06-12
Kodziki
Zadanie 1. Należy obliczyć score (ocenę punktową) dla każdego z klientów (kolejne
wiersze/rekordy w danych). Klientów jest 20 tysięcy (dane wygenerowane sztucznie).
install.packages("googlesheets4")
library(googlesheets4)
googlesheets4::gs4_deauth()
df <- read_sheet("1MRCJpZq9ecnKxwVh2Un71QcxgGVowVKHCecYfOEPXrM")
df$utilpoints <- ifelse(df$util <= 0.30, 35, #Util to nazwa kolumny
ifelse(df$util <= 0.50, 25,
ifelse(df$util <= 0.70, 10,
0)))
df$dpdpoints <- ifelse(df$times30dpd == 0, 50,
ifelse(df$times30dpd == 1, 20,
0))
df$dtipoints <- ifelse(df$dti <= 0.20, 75,
ifelse(df$dti <= 0.40, 30,
0))
df$score <- df$utilpoints+df$dpdpoints+df$dtipoints
write.csv2(df, "mojedane.csv")
hist(df$score)Liczenie bad rate - score = 0 -> BAD
library(dplyr)
df %>%
group_by(score) %>%
summarize(bad_rate = mean(bad),
total = n(),
bads = sum(bad)) -> brGenerowanie Tablicy pomyłek
table(
ifelse(df$bad==1, "rzeczywisty bad", "rzeczywisty good")
,
ifelse(df$score < 100, "przewidywany bad", "przewidywany good")
) Czułość - przewidywany bad rzeczywisty good / przewidywany bad+przewidywany good
Swoistość - ze wszystkich rzeczywistych goodów jaki ułamek zaklasyfikowaliśmy do goodów (rzeczywisty przewidywany good / rzeczywisty good przewidywany bad +rzeczwisty przewidywany good)
Napisać funkcję P2L w R przekształcającą prawdopodobieństwo w logarytm szansy.
P2L <- function(p) {log(p/(1-p))}
P2L(0.2) # prawdopodobieństwo w szanse P2S <- function(p) {p / (1 - p)} # szanse w prawdopodobieństwo S2P <- function(s) {s / (1 + s)} # prawdopodobieństwo w log szans P2L <- function(p) {log(p / (1 - p))} # log szans w prawdopodobieństwo L2P <- function(l) {exp(l) / (1 + exp(l))} # szanse w log szans S2L <- function(s) {log(s)} # log szans w szanse L2S <- function(l) {exp(l)}
Liczenie AUC w R
install.packages("bigstatsr")
library(bigstatsr)
install.packages("googlesheets4")
library(googlesheets4)
gs4_deauth()
dane <-
read_sheet("https://docs.google.com/spreadsheets/d/1b5UOt72MeKRnyzU
UwTHmKwYfCdII45doztAHWjS8rPA/edit?gid=0#gid=0")
AUC(-dane$ocena_punktowa, dane$zly) # nazwy zależy od danych Regresja logistyczna
install.packages("HistData")
library(HistData)
View(GaltonFamilies)
r <- GaltonFamilies
r$child_cm <- r$childHeight * 2.54
r$father_cm <- r$father * 2.54
r$mother_cm <- r$mother * 2.54
r$male <- 1*(r$gender == "male")
# Zbudujmy model regresji logistycznej “model1”.
# Zmienna objaśniana 0/1: male
# Zmienna objaśniająca: wzrost osoby w cm (child_cm)
model1 <- glm(male ~ child_cm, data = r, family = binomial())
summary(model1)
# 1 cm wzrostu przekłada średnio na zwiększenie logarytmu szansy na
# to, że dana osoba jest mężczyzną o 0,31567exp(0.31567)
# 1 cm wzrostu przekłada według modelu na zwiększenie szansy na to,
#że dana osoba jest mężczyzną o ok. 37%**Zadanie 1. Na podstawie poniższych danych obliczyć IV (information
value) dla zmiennej wiek kubełkowanej do czterech przedziałów (jw.).**
| Age up to 25 | Age 25-34 | Age (35-40 | Age (40+) | |
|---|---|---|---|---|
| G | 100 | 120 | 140 | 200 |
| B | 20 | 20 | 10 | 5 |
bad <- c(rep(0, 100+120+140+200), rep(1, 20+18+10+5))
age_bin <- c(rep("bin1", 100),
rep("bin2", 120),
rep("bin3", 140),
rep("bin4", 200),
rep("bin1", 20),
rep("bin2", 18),
rep("bin3", 10),
rep("bin4", 5))
d <- data.frame(bad, age_bin)
table(d$bad, d$age_bin)
#Jeżeli nie ma pakietu scorecard na komputerze, to instalujemy
install.packages("scorecard")
#Wywołujemy pakiet scorecard
library(scorecard)
iv(d, "bad", "age_bin") **Zadanie 3.2. Obliczyć Information Value (IV) dla zmiennej employment_duration w danych
SouthGerman:**
#Wciągamy SouthGerman dataset z Google do R:
# install.packages("googlesheets4")
library(googlesheets4)
gs4_deauth()
a <- read_sheet("1sQnRtinzf4b3Q4N54IKSIBhq0MJDE68ikyA20PsVPFU")
scorecard::iv(a, "credit_risk", "employment_duration") Liczenie IV dla wszystkich zmiennych w zbiorze
Uwaga! Żeby liczyć IV (żeby móc sensownie interpretować wyniki), trzeba mieć wszystkie zmienne kubełkowane (podzielone na poziomy/przedziały) ang. bins. Kubełkowanie = binning. W pakiecie scorecard można na szybko podzielić wszystkie zmienne na kubełki.
#PRZYKŁĄD scorecard::woebin(a, "credit_risk", "age")
a2 <- woebin_ply(a, woebin(a, "credit_risk"), to="bin")
iv(a2, "credit_risk") Notatki
Score - ocena punktowa
Scoring - nadawanie oceny punktowej
Credit score - ocena punktowa nadawana przez bank (lub kredytodawcę) klientowi powiązana z ryzykiem niespłacenia kredytu (jedna liczba podsumowująca zdolność i wiarygodność kredytową klienta banku). Zwykle: im więcej punktów, tym niższe ryzyko.
Modele scoringowe - algorytmy wyznaczające tę ocenę punktową.
Krzywa ROC - krzywa ilustrująca działanie algorytmu przewidującego przenależność obiektu do jednej z dwóch klas. OS X : 1 - swoistość ( false positive rate) OS Y: czułość (true positive rate)
Scoring idealny: AUC = 1; Gini = 1 , Scoring niedziałający, przypadkowy: AUC = 0,5; Gini = 0
Scoring: typologia ze względu na zmienną celu
zmienna celu spłaci/nie spłaci - scoring kredytowy
response scoring - czy jest skłonny skorzystać z (nowej) oferty
fraud scoring - oszustwo, wyłudzenie
over-indebtedness scoring - przewiduje nadmierne zadłużenie/spiralę długów
recovery scoring - przewidywanie odzysków (przestanie spłacać i chcemy wiedzieć, jaka jest szansa na odzysk
promise scoring - dotrzyma/nie dotrzyma obietnicy (spłacenia zaległego zadłużenia
contactability scoring - czy dodzwonimy się do klienta
profit scoring
Scoring - typologia ze względu na moment zastosowania
application scoring. - na wejściu - wniosek itp
account management
collections ( windykacja) klient przestaje spłacać
scoring transakcyjny - ocena ryzyka w momencie transakcji
Scoring - typologia ze względu na zastosowane dane
dane aplikacyjne (podawane przy okazji wniosku kredytowego)
dane behawioralne (historyczne dane zebrane przez bank
dane zewnętrzne (BIK - biuro kredytowe)
dane alternatywne (media społecznościowe, aktywność w internecie)
Jeszcze jest typologia- ze względu na zastosowane narzędzie (np. regresja logistyczna, karta scoringowa), scoring ekspercki- ze względu na obiekt (wniosek, klient indywidualny/mała firma, transakcja, inne)- ze względu na dostawcę (wewnętrzny, zewnętrzny)
Wzory
P(G) - prawdopodobieństwo wylosowania dobrej obserwacji (częstość dobrych, good rate) :
\[P(G) = 1- P(B)\]
Banki komercyjne
Kredyty | depozyt , kapitał
Banki inwestycyjne
Portfel tradingowy | Finansowanie hurtowe , kapitał
Bank uniwersalny
Portfel tradingowy , Kredyty | Finansowanie hurtowe , depozyty , kapitał ( czyli combo powyższych)
Wynik odestkowy
Źródłem wyniku odsetkowego są przede wszystkim odsetki zapłacone przez kredytobiorców i uzyskane z papierów wartościowych
Wynik odsetkowy = Przychody odsetkowe minus koszty odsetkowe
Straty kredytowe
Źródłem „strat kredytowych” są przede wszystkim udzielone kredyty, ale również papiery wartościowe (np. bankructwo lub pogorszenie ratingu emitenta obligacji)
W BIK-U udział kategorii informacji w ocenie w kolejności jest następujący:
Jakość kredytów(spłacalność terminowa) , Aktywność kredytowa(długa historia kredytowa) , Wykorzystanie limitów(wysokie wykorzystanie generuje ryzyko) , Wnioskowanie o kredyt (wielokrotne występowanie o kredyt generuje ryzyko)
Zadania z enauczania:
library(pROC)## Type 'citation("pROC")' for a citation.##
## Dołączanie pakietu: 'pROC'## Następujące obiekty zostały zakryte z 'package:stats':
##
## cov, smooth, var# Wczytanie danych
df <- read.csv("dane.csv", sep = ";", stringsAsFactors = FALSE)
# Wyświetlenie struktury danych do sprawdzenia
str(df)## 'data.frame': 2000 obs. of 3 variables:
## $ liczba_opozn: int 1 0 1 0 0 0 0 0 2 0 ...
## $ wykorz_limit: chr "0,37" "0,22" "0,42" "0,01" ...
## $ bad_flag : int 0 0 0 0 0 1 0 0 0 0 ...head(df)## liczba_opozn wykorz_limit bad_flag
## 1 1 0,37 0
## 2 0 0,22 0
## 3 1 0,42 0
## 4 0 0,01 0
## 5 0 0,16 0
## 6 0 0,47 1# Konwersja zmiennej wykorzystanie limitu (zamiana przecinków na kropki)
df$wykorz_limit <- as.numeric(gsub(",", ".", df$wykorz_limit))
# Funkcja scoringowa zgodna z tabelą punktacji
score_func <- function(opozn, limit) {
pkt1 <- ifelse(opozn == 0, 25, # 0 opóźnień = 25 pkt
ifelse(opozn == 1, 13, # 1 opóźnienie = 13 pkt
0)) # więcej niż 1 = 0 pkt
# Konwersja limitu na procenty (jeśli podany w ułamkach dziesiętnych)
if(max(limit, na.rm = TRUE) <= 1) {
limit <- limit * 100
}
# Punkty za wykorzystanie limitu odnawialnego w %
pkt2 <- ifelse(limit >= 0 & limit <= 16, 33, # (0;16] = 33 pkt
ifelse(limit > 16 & limit <= 28, 26, # (16;28] = 26 pkt
ifelse(limit > 28 & limit <= 40, 16, # (28;40] = 16 pkt
0))) # >40 = 0 pkt
return(pkt1 + pkt2)
}
# Obliczenie scoringu dla każdego wiersza
df$score <- mapply(score_func, df$liczba_opozn, df$wykorz_limit)
# Sprawdzenie rozkładu scoringu
table(df$score)##
## 0 13 16 25 26 29 33 39 41 46 51 58
## 201 100 152 184 94 117 40 111 229 71 318 383cat("\nStatystyki opisowe punktacji:\n")##
## Statystyki opisowe punktacji:summary(df$score)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.00 25.00 41.00 35.45 51.00 58.00# Pytanie 1: Ile wynosi średnia ocena punktowa (dwie cyfry po przecinku)?
srednia <- round(mean(df$score, na.rm = TRUE), 2)
cat("1. Średnia ocena punktowa:", srednia, "\n")## 1. Średnia ocena punktowa: 35.45# Pytanie 2: Ile wynosi minimalna ocena punktowa?
minimum <- min(df$score, na.rm = TRUE)
cat("2. Minimalna ocena punktowa:", minimum, "\n")## 2. Minimalna ocena punktowa: 0# Pytanie 3: Ile wynosi maksymalna ocena punktowa?
maksimum <- max(df$score, na.rm = TRUE)
cat("3. Maksymalna ocena punktowa:", maksimum, "\n")## 3. Maksymalna ocena punktowa: 58# Pytanie 4: Ile wynosi mediana ocen punktowych?
mediana <- median(df$score, na.rm = TRUE)
cat("4. Mediana ocen punktowych:", mediana, "\n")## 4. Mediana ocen punktowych: 41# Pytanie 5: Ile wynosi AUC (trzy cyfry po przecinku)?
# Obliczenie ROC i AUC
roc_obj <- roc(df$bad_flag, df$score, quiet = TRUE)
auc_value <- round(as.numeric(roc_obj$auc), 3)
cat("5. AUC:", sprintf("%.3f", auc_value), "\n")## 5. AUC: 0.731 # Pytanie 6: Ile wynosi Gini (trzy cyfry po przecinku)?
gini_value <- round(2 * auc_value - 1, 3)
cat("6. Gini:", sprintf("%.3f", gini_value), "\n")## 6. Gini: 0.462Zadanie 2
library(pROC)
x <- c(0,0.17,0.27,0.49,1) # False Positive Rate (FPR)
y <- c(0,0.64,0.86,0.92,1) # True Positive Rate (TPR)
auc_manual <- sum(diff(x) * (head(y, -1) + tail(y, -1)) / 2)
auc_manual## [1] 0.8148Gini= 2*auc_manual-1
Gini## [1] 0.6296Zadanie 3
bad_rate=0.13
good_ods= (1-bad_rate)/bad_rate
good_ods## [1] 6.692308good_log_odds= log(good_ods)
good_log_odds## [1] 1.900959bad_log_odds = log(bad_rate/(1-bad_rate))
bad_log_odds## [1] -1.900959Zadanie 4
good_log_odds = 2.5
Pgood= exp(good_log_odds)/(1+exp(good_log_odds))
Pbad = 1- Pgood
Pbad## [1] 0.07585818Bad_odds = Pbad/Pgood
Bad_odds## [1] 0.082085Good_odds=Pgood/Pbad
Good_odds## [1] 12.18249Zadanie 5
library(scorecard)
df <- read.csv("dane (3).csv", sep = ";")
head(df)## grupa_wiekowa grupa_dochodowa bad
## 1 (51,67] [3000-4000) 0
## 2 (51,67] [4000-5000) 1
## 3 (18,34] [2000-3000) 0
## 4 (34,51] [3000-4000) 0
## 5 (51,67] [4000-5000) 1
## 6 (34,51] [1000-2000) 0iv_result <- iv(df, y = "bad")
subset(iv_result, variable %in% c("grupa_wiekowa", "grupa_dochodowa"))## variable info_value
## <char> <num>
## 1: grupa_wiekowa 0.24531065
## 2: grupa_dochodowa 0.02000355Zadanie 6
rolnik= 100/101
bibliotekarz = 1/101
Niesmiala= 0.05*rolnik+0.76*bibliotekarz
Niesmiala## [1] 0.0570297N_b= 0.76*bibliotekarz /Niesmiala
N_b## [1] 0.1319444