モデル評価基準 追加 - リフトチャートに関して１ - R{ROCR}

前回の「モデル評価基準 - ROCに関して - R{ROCR}」に関する追加。

highschoolstudent.hatenablog.com

リフトチャート/Lift Chartを描いてみる。

今回書く形式のリフトチャートは、累積反応曲線/Cumulative Response Curveと呼ばれることもあるようである。

ROCとの違いは、縦軸は真陽性率/True Positive Rate(TPR)と同じままだが、横軸を陽性予測率/Positive Prediction Rateとする。

データの読み込み。
d_roc1 <- read.delim("clipboard", header=TRUE)
d_roc1

ROCRパッケージのロード。
library(ROCR)

リフトチャートを描く際は、performance()関数の引数をx.measure="rpp"とする。

perf_p1 <- performance(pred_p1, measure="tpr", x.measure="rpp")
#rpp: Rate of positive predictions. (TP+FP)/(TP+FP+TN+FN).

ROCを書いた手順で、この関数部分を入れ替えればいいだけである。

データテーブルにまとめておく。
table_p1 <- data.frame(Cutoff=unlist(pred_p1@cutoffs),
     TP=unlist(pred_p1@tp), FP=unlist(pred_p1@fp),
     FN=unlist(pred_p1@fn), TN=unlist(pred_p1@tn),
     TPR=unlist(perf_p1@y.values), PosPredR=unlist(perf_p1@x.values),
     MissClasR=(unlist(pred_p1@fp)+unlist(pred_p1@fn)) / (unlist(pred_p1@tp)+unlist(pred_p1@fp)+unlist(pred_p1@fn)+unlist(pred_p1@tn))
)

   Cutoff TP FP FN TN TPR   PosPredR MissClasR
1     Inf  0  0  5 14 0.0 0.00000000 0.2631579
2    0.95  1  0  4 14 0.2 0.05263158 0.2105263
3    0.90  2  0  3 14 0.4 0.10526316 0.1578947
4    0.85  2  1  3 13 0.4 0.15789474 0.2105263
5    0.80  3  1  2 13 0.6 0.21052632 0.1578947
6    0.75  3  2  2 12 0.6 0.26315789 0.2105263
7    0.70  3  3  2 11 0.6 0.31578947 0.2631579
8    0.65  3  4  2 10 0.6 0.36842105 0.3157895
9    0.60  4  4  1 10 0.8 0.42105263 0.2631579
10   0.55  4  5  1  9 0.8 0.47368421 0.3157895
11   0.50  5  5  0  9 1.0 0.52631579 0.2631579
12   0.45  5  6  0  8 1.0 0.57894737 0.3157895
13   0.40  5  7  0  7 1.0 0.63157895 0.3684211
14   0.35  5  8  0  6 1.0 0.68421053 0.4210526
15   0.30  5  9  0  5 1.0 0.73684211 0.4736842
16   0.25  5 10  0  4 1.0 0.78947368 0.5263158
17   0.20  5 11  0  3 1.0 0.84210526 0.5789474
18   0.15  5 12  0  2 1.0 0.89473684 0.6315789
19   0.10  5 13  0  1 1.0 0.94736842 0.6842105
20   0.05  5 14  0  0 1.0 1.00000000 0.7368421

PosPredRは下のように計算もできる。
(table_p1$TP+table_p1$FP) / (table_p1$TP+table_p1$FP+table_p1$FN+table_p1$TN)

リフトチャートをプロットしてみる。

plot(perf_p1)
# 45 degree line
abline(a=0, b=1, col="yellow")
# grid
abline( h=(0:10)/10, v=(1:10)/10, lty=3 )

各行でのTPR、PosPredRの点も重ねておく。
par(new=TRUE)
plot(table_p1$PosPredR, table_p1$TPR, xlab="", ylab="")

 横軸が陽性予測率なので、例えば、予測値の高い順にならべ全データのうち20%を陽性と予測した場合（横軸が0.2 の位置）、予測正解率は60%（縦軸が0.6の位置）となりますよ、という解釈。

関数にまとめておく。

# リフトチャートを描く関数
fn_plot_CRC <- function(pred, obs, line45=TRUE, gridL=TRUE, color="black"){
     pred1 <- prediction(predictions=pred, labels=obs)
     perf1 <- performance(pred1, measure="tpr", x.measure="rpp")

     plot(perf1, col=color)

     # 45 degree line
     if(line45==TRUE){ abline(a=0, b=1, col="yellow") }

     # grid
     if(gridL==TRUE){ abline( h=(0:10)/10, v=(1:10)/10, lty=3 ) }
}

pred1とpred2の重ね合わせてみる。

fn_plot_CRC(d_roc1$pred1, d_roc1$observed)
par(new=TRUE)
fn_plot_CRC(d_roc1$pred2, d_roc1$observed, color="blue")