前回の記事 では AIC と AICc を比較した。今回はそれに BIC を追加してみた。BICはあまり使ったことがなかったが、個人的には結構おどろきの結果が得られた。
BIC は以下で定義される。n はデータ数、k はモデルのパラメータ数。
\begin{align}
BIC=-2\times\{\text{Maximum Likelihood}\}+(\log n)\times k
\end{align}
実際のデータ分析では当然、n は固定なので AIC とのちがいは k の前の係数が 2 という定数か、 \(\log n\) という定数か、の違いがあるが、これって同じようなもんでしょ、と思って BIC はわりとノーマークだったけど、今回実験してみて考えを改めることなった。
実験の条件については、前々回の記事
AICc については、前回の記事
にそれぞれ書いた。
結果
まずはデータを増やしていった時に「真のモデルを選択する確率」がどのように振る舞うかを次のグラフに示す。BIC すごい。ぶっちぎりですね。
Image may be NSFW.
Clik here to view.
- AIC と AICc については前回と同じ（実験条件が同じなので当然）。データを増やしていっても正解率は頭打ちになる。
- BIC はデータを増やしていくと正解率が 1 に近づいていく。
以下は、これまでの記事と同様の図を示す。まずは n=20 のケース。AICc と BIC はほとんど同じモデル選択傾向にある。これは常に正しいわけじゃなくて、小標本かつ真のモデルのパラメータ数が少ないときにだけ正しいと勝手に推論。
Image may be NSFW.
Clik here to view.
n=40。このあたりから BIC の「よさ」が目立ってくる。
Image may be NSFW.
Clik here to view.
n=60。BIC 一人勝ちの図。
Image may be NSFW.
Clik here to view.
n=80, 100。以下同様。
Image may be NSFW.
Clik here to view.
Image may be NSFW.
Clik here to view.
まとめと感想
前々回から今回まで、3回にわたって延々とモデル選択について書いたが、あくまでも数値実験なので得られた結果が普遍的なものなのかはまだよくわからない。いろいろ検索してみると BIC は \(n\to\infty\) で真のモデルを選択するという「一致性」があるらしいが、証明は読んでいない。
最大のギモンは、BICが今回の実験のようにAICをぶっちぎって素晴らしい性能を出すならば、AICなんてもう使わずにBICだけ使いましょう、ということになりそうなもんだが、そうなっていない。推察するにBICにはなにか弱点があるのかもしれないが、今回の実験ではそれは見えなかった。
そのような弱点を見出すためにもう少し実験をしてみるとすれば
- 今回の実験を通して真のモデルのパラメータは2つであると仮定し続けたが、これをもっと大きな値とした時にどのような変化が起こるか
- 想定するモデル集合が真のモデルを含まない時に何が起こるか
というあたりになりそうだが、一旦これでおしまい。気が向いたらまたやります。
実験に使った R スクリプト
library(mvtnorm)
library(AICcmodavg)
library(ggplot2)
generate.data <- function(n){
X <- rmvnorm(n,c(0,0),matrix(c(1,0.7,0.7,1),nc=2))
mu <- exp(0.5*X[,1]+1)
Y <- rpois(n,mu)
d <- as.data.frame(cbind(X,Y))
colnames(d) <- c("x1","x2","y")
d
}
#------------------
# estimating GLM
#------------------
estimate.models <- function(dat,wgt=rep(1,dim(dat)[1])){
models <- list()
# Model 0
models[[1]] <- glm(y~1,data=dat,family=poisson,weights=wgt)
# Model 1
models[[2]] <- glm(y~x1,data=dat,family=poisson,weights=wgt)
# Model 2
models[[3]] <- glm(y~x2,data=dat,family=poisson,weights=wgt)
# Model 3
models[[4]] <- glm(y~x1+x2,data=dat,family=poisson,weights=wgt)
models
}
#--------------------------
# Model selection by AIC
#--------------------------
model.select.aic <- function(models){
which.min(sapply(models,AIC)) # Which model has minimum AIC?
}
#---------------------------
# Model selection by AICc
#---------------------------
model.select.aicc <- function(models){
# AICc is provided by AICcmodavg package
which.min(sapply(models,AICc)) # Which model has minimum AICc?
}
#---------------------------
# Model selection by BIC
#---------------------------
model.select.bic <- function(models){
# AICc is provided by AICcmodavg package
which.min(sapply(models,BIC)) # Which model has minimum AICc?
}
#----------------------------
# Experiment / AIC vs. AICc
#----------------------------
library(tabplot)
ns <- 20*(1:5)
correct <- matrix(0,length(ns),3)
for( j in 1:length(ns) ){
n <- ns[j]
n.experiments <- 10000
results <- matrix(0,n.experiments,6)
colnames(results) <- c("AIC.selected","AICc.selected","BIC.selected",
"p.val.Intersept","p.val.x1","p.val.x2")
for(i in 1:n.experiments){
d <- generate.data(n)
models <- estimate.models(d)
p.values <- summary(models[[4]])$coef[,4]
results[i,] <- c(model.select.aic(models),
model.select.aicc(models),
model.select.bic(models),
p.values)
}
results.df <- transform(data.frame(results),
AIC.selected=factor(AIC.selected,levels=1:4),
AICc.selected=factor(AICc.selected,levels=1:4),
BIC.selected=factor(BIC.selected,levels=1:4))
levels(results.df[,1]) <- paste("Model",levels(results.df[,1]))
levels(results.df[,2]) <- paste("Model",levels(results.df[,2]))
levels(results.df[,3]) <- paste("Model",levels(results.df[,3]))
correct[j,] <- colSums(results.df[,1:3]=="Model 2")
tblobj <- tableplot(results.df,sortCol=6,nBins=100,scales="lin")
plot(tblobj,title=paste("Data size =",n),showTitle=T,fontsize=12)
dev2bitmap(paste("AicVsAICcVsBIC_n_",n,".jpg",sep=""),
width=10,height=10,gaa=4,taa=4)
}
correct.df <- data.frame(N=c(ns,ns,ns),
CorrectRatio=c(correct[,1],correct[,2],correct[,3])/10000,
Method=rep(c("AIC","AICc","BIC"),each=length(ns)))
ggplot(aes(x=N,y=CorrectRatio),data=correct.df,colour=Method) +
geom_line(aes(colour=Method),size=2) +
geom_point(aes(colour=Method),size=5) +
xlab("\nNumber of data used for estimation") +
ylab("Correct ratio\n") +
opts(legend.position=c(0.8,0.2),
legend.background=theme_rect(fill="white"))
ggsave("AICvsAICcvsBIC.png",height=4,width=4)