Người ta có thể sử dụng phương pháp Monte Carlo để có được ước tính thực nghiệm cho các mối quan hệ giữa x1. . . .xTôi và khoảng dự đoán cho xtôi + n.
Động lực: Nếu chúng tôi ước tính khoảng dự đoán dựa trên các phần tư / CDF của phân phối theo ước tính khả năng tối đa (hoặc loại ước tính tham số khác), thì chúng tôi đánh giá thấp kích thước của khoảng. Hiệu quả, trong thực tế, điểmxtôi + n sẽ rơi ra khỏi phạm vi thường xuyên hơn dự đoán.
Hình dưới đây thể hiện bằng cách chúng ta đánh giá thấp kích thước của khoảng đó, bằng cách biểu thị số lần đo mới hơn bao nhiêu lần xTôinằm ngoài phạm vi dự đoán dựa trên ước tính tham số. (dựa trên các tính toán với 2000 lần lặp lại cho dự đoán)
Chẳng hạn, nếu chúng ta sử dụng khoảng dự đoán là 99% (do đó sẽ xảy ra lỗi 1%), thì chúng ta sẽ nhận được lỗi gấp 5 lần nếu kích thước mẫu là 3.
Các loại tính toán này có thể được sử dụng để tạo mối quan hệ theo kinh nghiệm về cách chúng ta có thể sửa phạm vi, cũng như các tính toán cho thấy rằng lớn n sự khác biệt trở nên nhỏ hơn (và tại một số điểm người ta có thể coi nó không liên quan).
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="")
