この記事は以下の検証記事の続きです。
先日、Twitterでこんなお話を見かけました。
分類問題で不均衡データを扱う際、ダウンサンプリングして学習すると予測確率にバイアスが生じるので、calibrationしようという話を書きましたhttps://t.co/qujK29crNY
— 岸本ばなな (@unpuy_tw) July 22, 2019
その記事がこちらです。
そう言えば、上記の検証記事の中でもコメントしたのですが「undersampling + baggingで不均衡データを補正するとfalse positiveは物凄く多くなる」んですよね。これは僕も結構気になっていて、もう少し巧みに正例の領域にだけ限局して決定境界を引けないものか?と思っていました。この方法を使えばそれが実現できるのかどうか、実際に試してみようと思います。
なお、前回の記事同様面倒なのでRでランダムフォレストのみ、baggingも100に固定します。またRスクリプト自体も対して汎用性高く書いていませんので、お手元でより汎用的に書きたいという方は適宜ご自身でパラメータのところは調整してください。
全く不均衡データ補正をせずにやってみる
以下のRスクリプトを回すだけです。
library(randomForest) library(tcltk) set.seed(1001) x1 <- cbind(rnorm(1000, 1, 1), rnorm(1000, 1, 1)) set.seed(1002) x2 <- cbind(rnorm(1000, -1, 1), rnorm(1000, 1, 1)) set.seed(1003) x3 <- cbind(rnorm(1000, -1, 1), rnorm(1000, -1, 1)) set.seed(4001) x41 <- cbind(rnorm(250, 0.5, 0.5), rnorm(250, -0.5, 0.5)) set.seed(4002) x42 <- cbind(rnorm(250, 1, 0.5), rnorm(250, -0.5, 0.5)) set.seed(4003) x43 <- cbind(rnorm(250, 0.5, 0.5), rnorm(250, -1, 0.5)) set.seed(4004) x44 <- cbind(rnorm(250, 1, 0.5), rnorm(250, -1, 0.5)) d <- rbind(x1,x2,x3,x41,x42,x43,x44) d <- data.frame(x = d[,1], y = d[,2], label = c(rep(0, 3000), rep(1, 250), rep(0, 750))) px <- seq(-4, 4, 0.05) py <- seq(-4, 4, 0.05) pgrid <- expand.grid(px, py) names(pgrid) <- names(d)[-3] fit <- randomForest(as.factor(label)~., d) rf.grid <- predict(fit, newdata = pgrid) plot(d[,-3], col = d[, 3] + 1, xlim = c(-4, 4), ylim = c(-4, 4), cex = 0.3, pch = 19) par(new=T) contour(px, py, array(rf.grid, c(length(px), length(py))), levels = 0.5, col = 'purple', lwd = 3, drawlabels = F)
ほんの僅かにある正例にちょこちょこっと決定境界が粒みたいにくっつくだけで、まともな結果になっていません。これは簡単に想像のつく結果だと思います。
オリジナルのcalibrationなしバージョンを再掲する
これまた以下のRスクリプトを回すだけです。
library(tcltk) outbag.rf <- c() pb <- txtProgressBar(min = 1, max = 100, style = 3) for (i in 1:100){ set.seed(i) train.tmp <- d[d$label==0, ] train0 <- train.tmp[sample(3750, 250, replace=F),] train1 <- d[3001:3250, ] train <- rbind(train0, train1) model <- randomForest(as.factor(label)~., train) tmp <- predict(model, newdata=pgrid) outbag.rf <- cbind(outbag.rf, tmp) setTxtProgressBar(pb, i) } outbag.rf.grid <- apply(outbag.rf, 1, mean) - 1 plot(d[,-3], col = d[, 3] + 1, xlim = c(-4, 4), ylim = c(-4, 4), cex = 0.3, pch = 19) par(new=T) contour(px, py, array(outbag.rf.grid, c(length(px), length(py))), levels = 0.5, col = 'purple', lwd = 3, drawlabels = F)
乱数シードなども揃えてあるので、基本的には以前の記事通りの結果になるはずです。確かに正例の周りを綺麗に囲む決定境界が引けますが、どう見てもfalse positiveも増えていてちょっとやり過ぎかも?感があります。
論文で提案されていたcalibrationをかけてみる
上記の例ではサンプリングレートは250/3750 = 1/15と設定されています。ということは、引用させていただいたブログ記事の定義の
のにランダムフォレストが算出した予測確率を入れ、に1/15を入れれば良いということだと思われます。実際にやってみましょう。
outbag.rf <- c() pb <- txtProgressBar(min = 1, max = 100, style = 3) for (i in 1:100){ set.seed(i) train.tmp <- d[d$label==0, ] train0 <- train.tmp[sample(3750, 250, replace=F),] train1 <- d[3001:3250, ] train <- rbind(train0, train1) model <- randomForest(as.factor(label)~., train) prob <- predict(model, newdata=pgrid, type = 'prob') prob.tmp <- prob[, 2] / (prob[, 2] + (1 - prob[, 2])/(250/3750)) outbag.rf <- cbind(outbag.rf, prob.tmp) setTxtProgressBar(pb, i) } outbag.rf.grid <- apply(outbag.rf, 1, mean) plot(d[,-3], col = d[, 3] + 1, xlim = c(-4, 4), ylim = c(-4, 4), cex = 0.3, pch = 19) par(new=T) contour(px, py, array(outbag.rf.grid, c(length(px), length(py))), levels = 0.5, col = 'purple', lwd = 3, drawlabels = F)
確かに決定境界が上のものよりshrinkして、より狭い範囲で正例の密度が高い領域だけに限定されるようになりました。
比較のためにcalibration前の決定境界を紫で、calibration後の決定境界を青で、それぞれ描いたものです。ご覧の通りでfalse negativeもかなり増えています。結局これは何を優先するかによって使うか使わないかを決めるしかないのかなというのが、個人的な感想です。