Kalibracija rejting skale

Zadatak: Nakom detaljne analize centralne tendencije vjerovatnoće defaulta analiziranog portfolija, došlo se do zaključka da je neophodno rekalibrirati postojeću rejting skalu. Nova vrijednost centralne tendencije iznosi 4.7%. Izvršiti rekalibraciju date rejting skale (data frame rs, rejting – class, broj klijenata – ne, vjerovatnoća defaulta – pd) u odnosu na novu vrijednost centralne tendencije, primjenjujući sljedeće metode:

1. linearnog reskaliranja pd vrijednosti;

2. optimizacije koeficijenta presjeka logit link funckije;

3. optimizacije koeficijenta presjeka i nagiba logit link funckije;

4. minimiziranja sume kvadrata odstupanja postojećih pd vrijednosti u odnosu na rekalibrirane uz uslov održavanja monotonosti rejting skale.

> #rejting skala
> rs <- data.frame(class = 1:8,
+      ne = c(100, 250, 400, 750, 700, 300, 100, 50),
+      pd = c(0.003, 0.01, 0.025, 0.03, 0.045, 0.08, 0.1, 0.13))
> rs
  class  ne    pd
1     1 100 0.003
2     2 250 0.010
3     3 400 0.025
4     4 750 0.030
5     5 700 0.045
6     6 300 0.080
7     7 100 0.100
8     8  50 0.130
> #centralna tendencija trenutne rejting skale (portfolio pd)
> ct.c <- weighted.mean(x = rs$pd, w = rs$ne)
> ct.c
[1] 0.04049057
> #nova vrijednost centralne tendencije
> ct.n <- 0.047

Metod 1

> #definisati faktor reskaliranja
> rf <- ct.n / ct.c
> rf
[1] 1.160764
> #izvrsiti reskaliranje
> rs$pd.rescaling <-  rs$pd * rf
> rs[, c("class", "ne", "pd", "pd.rescaling")]
  class  ne    pd pd.rescaling
1     1 100 0.003  0.003482293
2     2 250 0.010  0.011607642
3     3 400 0.025  0.029019105
4     4 750 0.030  0.034822926
5     5 700 0.045  0.052234390
6     6 300 0.080  0.092861137
7     7 100 0.100  0.116076421
8     8  50 0.130  0.150899348
> #provjera
> weighted.mean(x = rs$pd.rescaling, w = rs$ne)
[1] 0.047

Metod 2

> #izracunati log odds za date pd vrijednosti
> log.odds <- log((1 - rs$pd) / rs$pd)
> #definisati optimizacionu funkciju
> opt.f <- function(x, lo, w, ct) {
+   pd.inverse <- 1 / ( 1 + exp(lo - x))
+ opt <- sum(w * pd.inverse / sum(w)) - ct
+ return(opt)
+ }
> #optimizacija
> lo.ic <- uniroot(f = opt.f, 
+      lo = log.odds, 
+      w = rs$ne,
+      ct = ct.n, 
+      interval =c(-5, 5))
> lo.ic$root
[1] 0.1588443
> #primijeniti optimizovani koeficijent presjeka
> rs$pd.intercept.opt <- 1 / (1 + exp(log.odds - lo.ic$root))
> rs[, c("class", "ne", "pd", "pd.intercept.opt")]
  class  ne    pd pd.intercept.opt
1     1 100 0.003      0.003514651
2     2 250 0.010      0.011701409
3     3 400 0.025      0.029178304
4     4 750 0.030      0.034983981
5     5 700 0.045      0.052341502
6     6 300 0.080      0.092498500
7     7 100 0.100      0.115231760
8     8  50 0.130      0.149044551
> #provjera
> weighted.mean(x = rs$pd.intercept.opt, w = rs$ne)
[1] 0.04700005

Metod 3

> #izracunati log odds za date pd vrijednosti
> log.odds <- log((1 - rs$pd) / rs$pd)
> #definisati optimizacionu funkciju
> opt.f <- function(x, lo, w, ct) {
+ a <- x[1]
+ b <- x[2]
+   pd.inverse <- 1 / ( 1 + exp(b * lo - a))
+ opt <- (sum(w * pd.inverse / sum(w)) - ct)^2
+ return(opt)
+ }
> #optimizacija
> lo.is <- optim(par = c(1, 0), 
+    fn = opt.f, 
+    lo = log.odds, 
+    w = rs$ne,
+    ct = ct.n,
+    method = "BFGS")
> param <- lo.is$par
> param
[1] 0.6474028 1.1652761
> #primijeniti optimizovane koeficijente
> rs$pd.inter.slope.opt <- 1 / (1 + exp(param[2] * log.odds - param[1]))
> rs[, c("class", "ne", "pd", "pd.inter.slope.opt")]
  class  ne    pd pd.inter.slope.opt
1     1 100 0.003        0.002197244
2     2 250 0.010        0.008949386
3     3 400 0.025        0.026041985
4     4 750 0.030        0.032195231
5     5 700 0.045        0.051535537
6     6 300 0.080        0.099875749
7     7 100 0.100        0.128647493
8     8  50 0.130        0.172538944
> #provjera
> weighted.mean(x = rs$pd.inter.slope.opt, w = rs$ne)
[1] 0.04699984

Metod 4

> #narednu komandu izvrsiti ukoliko CVXR paket vec nije instaliran
> #install.packages("CVXR")
> library(CVXR)
> x.start <- rs$pd
> x <- Variable(nrow(rs))
> objective <- Minimize(sum((x - x.start)^2))
> constraints <- list(sum(x * rs$ne / sum(rs$ne)) == ct.n, 
+   x[2] >= x[1] , 
+   x[3] >= x[2], 
+   x[4] >= x[3], 
+   x[5] >= x[4],
+   x[6] >= x[5], 
+   x[7] >= x[6], 
+   x[8] >= x[7])
> opt.problem <- Problem(objective, constraints)
> opt.res <- solve(opt.problem)
> rs$pd.ssq.min <- opt.res$getValue(x)
> rs[, c("class", "ne", "pd", "pd.ssq.min")]
  class  ne    pd  pd.ssq.min
1     1 100 0.003 0.004243243
2     2 250 0.010 0.013108108
3     3 400 0.025 0.029972973
4     4 750 0.030 0.039324324
5     5 700 0.045 0.053702703
6     6 300 0.080 0.083729730
7     7 100 0.100 0.101243243
8     8  50 0.130 0.130621622
> #provjera
> weighted.mean(x = rs$pd.inter.slope.opt, w = rs$ne)
[1] 0.04699984

Sumiranje rezultata:

> rs
  class  ne    pd pd.rescaling pd.intercept.opt pd.inter.slope.opt  pd.ssq.min
1     1 100 0.003  0.003482293      0.003514651        0.002197244 0.004243243
2     2 250 0.010  0.011607642      0.011701409        0.008949386 0.013108108
3     3 400 0.025  0.029019105      0.029178304        0.026041985 0.029972973
4     4 750 0.030  0.034822926      0.034983981        0.032195231 0.039324324
5     5 700 0.045  0.052234390      0.052341502        0.051535537 0.053702703
6     6 300 0.080  0.092861137      0.092498500        0.099875749 0.083729730
7     7 100 0.100  0.116076421      0.115231760        0.128647493 0.101243243
8     8  50 0.130  0.150899348      0.149044551        0.172538944 0.130621622