六本木で働くデータサイエンティストのブログ

元祖「銀座で働くデータサイエンティスト」です / 道玄坂→銀座→東京→六本木

Undersampling + baggingで不均衡データに対処した際の予測確率のバイアスを補正して、その結果を可視化してみる

この記事は以下の検証記事の続きです。


先日、Twitterでこんなお話を見かけました。


その記事がこちらです。


そう言えば、上記の検証記事の中でもコメントしたのですが「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)

f:id:TJO:20190804145511p:plain
ほんの僅かにある正例にちょこちょこっと決定境界が粒みたいにくっつくだけで、まともな結果になっていません。これは簡単に想像のつく結果だと思います。


オリジナルの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)

f:id:TJO:20190804145828p:plain
乱数シードなども揃えてあるので、基本的には以前の記事通りの結果になるはずです。確かに正例の周りを綺麗に囲む決定境界が引けますが、どう見てもfalse positiveも増えていてちょっとやり過ぎかも?感があります。


論文で提案されていたcalibrationをかけてみる


上記の例ではサンプリングレートは250/3750 = 1/15と設定されています。ということは、引用させていただいたブログ記事の定義の
 p = \frac{p_s}{ p_s + \frac{ (1 - p_s) }{\beta} }
 p_sにランダムフォレストが算出した予測確率を入れ、 \betaに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)

f:id:TJO:20190804150008p:plain
確かに決定境界が上のものよりshrinkして、より狭い範囲で正例の密度が高い領域だけに限定されるようになりました。


f:id:TJO:20190804171644p:plain
比較のためにcalibration前の決定境界を紫で、calibration後の決定境界を青で、それぞれ描いたものです。ご覧の通りでfalse negativeもかなり増えています。結局これは何を優先するかによって使うか使わないかを決めるしかないのかなというのが、個人的な感想です。