Pode-se usar um método de Monte Carlo para obter estimativas empíricas para as relações entre os x1 1. . . .xEu e o intervalo de previsão para xi + n.
Motivação: Se estimarmos o intervalo de previsão com base nos quartis / CDF de uma distribuição que segue das estimativas de probabilidade máxima (ou outro tipo de estimativa de parâmetros), subestimamos o tamanho do intervalo. Efetivamente, na prática, o pontoxi + n cairá fora da faixa com mais frequência do que o previsto.
A figura abaixo demonstra o quanto subestimamos o tamanho do intervalo, expressando quantas vezes mais uma nova medição xEuestá fora do intervalo preditivo com base nas estimativas de parâmetros. (com base em cálculos com 2000 repetições para a previsão)
Por exemplo, se usarmos um intervalo de previsão de 99% (portanto, esperamos 1% de erros), obteremos 5 vezes mais erros se o tamanho da amostra for 3.
Esse tipo de cálculo pode ser usado para estabelecer relações empíricas sobre como podemos corrigir o intervalo, assim como os cálculos mostram que, para grandes n a diferença se torna menor (e em algum momento pode-se considerar irrelevante).
set.seed(1)
# likelihood calculation
like<-function(par, x){
scale = abs(par[2])
pos = par[1]
n <- length(x)
like <- -n*log(scale*pi) - sum(log(1+((x-pos)/scale)^2))
-like
}
# obtain effective predictive failure rate rate
tryf <- function(pos, scale, perc, n) {
# random distribution
draw <- rcauchy(n, pos, scale)
# estimating distribution parameters based on median and interquartile range
first_est <- c(median(draw), 0.5*IQR(draw))
# estimating distribution parameters based on likelihood
out <- optim(par=first_est, like, method='CG', x=draw)
# making scale parameter positive (we used an absolute valuer in the optim function)
out$par[2] <- abs(out$par[2])
# calculate predictive interval
ql <- qcauchy(perc/2, out$par[1], out$par[2])
qh <- qcauchy(1-perc/2, out$par[1], out$par[2])
# calculate effective percentage outside predicted predictive interval
pl <- pcauchy(ql, pos, scale)
ph <- pcauchy(qh, pos, scale)
error <- pl+1-ph
error
}
# obtain mean of predictive interval in 2000 runs
meanf <- function(pos,scale,perc,n) {
trueval <- sapply(1:2000,FUN <- function(x) tryf(pos,scale,perc,n))
mean(trueval)
}
#################### generate image
# x-axis chosen desired interval percentage
percentages <- 0.2/1.2^c(0:30)
# desired sample sizes n
ns <- c(3,4,5,6,7,8,9,10,20,30)
# computations
y <- matrix(rep(percentages, length(ns)), length(percentages))
for (i in which(ns>0)) {
y[,i] <- sapply(percentages, FUN <- function(x) meanf(0,1,x,ns[i]))
}
# plotting
plot(NULL,
xlim=c(0.0008,1), ylim=c(0,10),
log="x",
xlab="aimed error rate",
ylab="effective error rate / aimed error rate",
yaxt="n",xaxt="n",axes=FALSE)
axis(1,las=2,tck=-0.0,cex.axis=1,labels=rep("",2),at=c(0.0008,1),pos=0.0008)
axis(1,las=2,tck=-0.005,cex.axis=1,at=c(0.001*c(1:9),0.01*c(1:9),0.1*c(1:9)),labels=rep("",27),mgp=c(1.5,1,0),pos=0.0008)
axis(1,las=2,tck=-0.01,cex.axis=1,labels=c(0.001,0.01,0.1,1), at=c(0.001,0.01,0.1,1),mgp=c(1.5,1,0),pos=0.000)
#axis(2,las=1,tck=-0.0,cex.axis=1,labels=rep("",2),at=c(0.0008,1),pos=0.0008)
#axis(2,las=1,tck=-0.005,cex.axis=1,at=c(0.001*c(1:9),0.01*c(1:9),0.1*c(1:9)),labels=rep("",27),mgp=c(1.5,1,0),pos=0.0008)
#axis(2,las=1,tck=-0.01,cex.axis=1,labels=c(0.001,0.01,0.1,1), at=c(0.001,0.01,0.1,1),mgp=c(1.5,1,0),pos=0.0008)
axis(2,las=2,tck=-0.01,cex.axis=1,labels=0:15, at=0:15,mgp=c(1.5,1,0),pos=0.0008)
colours <- hsv(c(1:10)/20,1,1-c(1:10)/15)
for (i in which(ns>0)) {
points(percentages,y[,i]/percentages,pch=21,cex=0.5,col=colours[i],bg=colours[i])
}
legend(x=0.4,y=4.5,pch=21,legend=ns,col=colours,pt.bg=colours,title="sample size")
title("difference between confidence interval and effective confidence interval")
plot(ns,y[31,]/percentages[31],log="")