R中的覆盖概率（for循环）

Question

我正在尝试计算我计算的置信区间的覆盖概率，如下所示。我的代码不起作用。任何人都可以帮助我吗？

p1 <- 0.01
p2 <- 0.05
p3 <- 0.1
p4 <- 0.3
p5 <- 0.5
p6 <- 0.7
p7 <- 0.9
p8 <- 0.95
p9 <- 0.99
p10 <- 0.9999

n = 1000

的置信区间

 for (i in 1:10000){
   set.seed (123467)
   l1 <- (mean(rbinom(1000,1,p1))) - 1.96 * ((mean(rbinom(1000,1,p1))* (1 -mean(rbinom(1000,1,p1))))/1000)^(1/2)
   l2 <- (mean(rbinom(1000,1,p2))) - 1.96 * ((mean(rbinom(1000,1,p2))* (1 -mean(rbinom(1000,1,p2))))/1000)^(1/2)
   l3 <- (mean(rbinom(1000,1,p3))) - 1.96 * ((mean(rbinom(1000,1,p3))* (1 -mean(rbinom(1000,1,p3))))/1000)^(1/2)
   l4 <- (mean(rbinom(1000,1,p4))) - 1.96 * ((mean(rbinom(1000,1,p4))* (1 -mean(rbinom(1000,1,p4))))/1000)^(1/2)
   l5 <- (mean(rbinom(1000,1,p5))) - 1.96 * ((mean(rbinom(1000,1,p5))* (1 -mean(rbinom(1000,1,p5))))/1000)^(1/2)
   l6 <- (mean(rbinom(1000,1,p6))) - 1.96 * ((mean(rbinom(1000,1,p6))* (1 -mean(rbinom(1000,1,p6))))/1000)^(1/2)
   l7 <- (mean(rbinom(1000,1,p7))) - 1.96 * ((mean(rbinom(1000,1,p7))* (1 -mean(rbinom(1000,1,p7))))/1000)^(1/2)
   l8 <- (mean(rbinom(1000,1,p8))) - 1.96 * ((mean(rbinom(1000,1,p8))* (1 -mean(rbinom(1000,1,p8))))/1000)^(1/2)
   l9 <- (mean(rbinom(1000,1,p9))) - 1.96 * ((mean(rbinom(1000,1,p9))* (1 -mean(rbinom(1000,1,p9))))/1000)^(1/2)
   l10 <- (mean(rbinom(1000,1,p10))) - 1.96 * ((mean(rbinom(1000,1,p10))* (1 -mean(rbinom(1000,1,p10))))/1000)^(1/2)

   u1 <- (mean(rbinom(1000,1,p1))) + 1.96 * ((mean(rbinom(1000,1,p1))* (1 -mean(rbinom(1000,1,p1))))/1000)^(1/2)
   u2 <- (mean(rbinom(1000,1,p2))) + 1.96 * ((mean(rbinom(1000,1,p2))* (1 -mean(rbinom(1000,1,p2))))/1000)^(1/2)
   u3 <- (mean(rbinom(1000,1,p3))) + 1.96 * ((mean(rbinom(1000,1,p3))* (1 -mean(rbinom(1000,1,p3))))/1000)^(1/2)
   u4 <- (mean(rbinom(1000,1,p4))) + 1.96 * ((mean(rbinom(1000,1,p4))* (1 -mean(rbinom(1000,1,p4))))/1000)^(1/2)
   u5 <- (mean(rbinom(1000,1,p5))) + 1.96 * ((mean(rbinom(1000,1,p5))* (1 -mean(rbinom(1000,1,p5))))/1000)^(1/2)
   u6 <- (mean(rbinom(1000,1,p6))) + 1.96 * ((mean(rbinom(1000,1,p6))* (1 -mean(rbinom(1000,1,p6))))/1000)^(1/2)
   u7 <- (mean(rbinom(1000,1,p7))) + 1.96 * ((mean(rbinom(1000,1,p7))* (1 -mean(rbinom(1000,1,p7))))/1000)^(1/2)
   u8 <- (mean(rbinom(1000,1,p8))) + 1.96 * ((mean(rbinom(1000,1,p8))* (1 -mean(rbinom(1000,1,p8))))/1000)^(1/2)
   u9 <- (mean(rbinom(1000,1,p9))) + 1.96 * ((mean(rbinom(1000,1,p9))* (1 -mean(rbinom(1000,1,p9))))/1000)^(1/2)
   u10 <- (mean(rbinom(1000,1,p10))) + 1.96 * ((mean(rbinom(1000,1,p10))* (1 -mean(rbinom(1000,1,p10))))/1000)^(1/2)

 }



CI1000 <- matrix(c(l1,l2,l3,l4,l5,l6,l7,l8,l9,l10, u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u1-l1, u2-l2, u3-l3, u4-l4, u5-l5, u6-l6, u7-l7, u8-l8, u9-l9, u10-l10),ncol=3,nrow=10,byrow=F)
rownames(CI1000) <- c("p=0,01","p=0.05","p=0.1","p=0,3","p=0,5","p=0,7", "p=0,9","p=0.95","p=0.99", "p=0.9999")
colnames(CI1000) <- c("lower bound","upper bound", "width")

覆盖概率

for (i in 1:10000){
   set.seed (123467)
   badl1 <- sum(ifelse(p1 < (mean(rbinom(1000,1,p1))) - 1.96 * ((mean(rbinom(1000,1,p1))* (1 -mean(rbinom(1000,1,p1))))/1000)^(1/2), 0,1))
   badu1 <- sum(ifelse(p1 > (mean(rbinom(1000,1,p1))) + 1.96 * ((mean(rbinom(1000,1,p1))* (1 -mean(rbinom(1000,1,p1))))/1000)^(1/2), 0,1))

 }
(badl1 + badu1) /1000 -> bad.frac1

谢谢！

Answer 1

这更简单，也是对的。 （不需要width，但我保留了它。不知道为什么。）

ci <- function(i){
    lo <- m[i] - 1.96 * (m[i]*(1 - m[i])/n)^0.5
    hi <- m[i] + 1.96 * (m[i]*(1 - m[i])/n)^0.5
    c(lo, hi)
}

p <- c(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10)

m <- length(p)
n <- 1000
Runs <- 10000
CI <- array(NA, dim = c(m, 3, Runs))
set.seed (123467)    # do this just once outside the loop
for (i in 1:Runs){
    x <- matrix(rbinom(10*n, 1, rep(p, each = n)), ncol = 10)
    m <- colMeans(x)
    CI[, 1:2, i] <- t(sapply(seq_along(m), ci))
    CI[, 3, i] <- CI[, 2, i] - CI[, 1, i]
}
dimnames(CI) <- list(c("p=0,01","p=0.05","p=0.1","p=0,3","p=0,5","p=0,7", "p=0,9","p=0,95","p=0,99", "p=0,9999"),
                     c("lower.bound","upper.bound", "width"),
                     sprintf("R%05d", 1:Runs))

CI[,, 200]  # example result of loop

bad <- array(NA, dim = c(length(p), Runs))
for(i in 1:Runs){
    bad[, i] <- as.integer(!(CI[, 1, i] < p & p < CI[, 2, i]))
}

prop_bad <- rowMeans(bad)
names(prop_bad) <- c("p=0,01","p=0.05","p=0.1","p=0,3","p=0,5","p=0,7", "p=0,9","p=0,95","p=0,99", "p=0,9999")
prop_bad
#  p=0,01   p=0.05    p=0.1    p=0,3    p=0,5    p=0,7    p=0,9   p=0,95 
#  0.0742   0.0582   0.0460   0.0498   0.0508   0.0535   0.0436   0.0582 
#  p=0,99 p=0,9999 
#  0.0742   0.9027

请注意，最后一个结果，bad的比例等于0.9027并非异常，因为标准区间在边缘0和{1附近具有真实比例的众所周知的覆盖问题{1}}。

Answer 2

cp <- function(n=10, nrep=10000, alpha=0.05){

    z <- qnorm(1-alpha/2)
    p <- seq(0.01, 0.99, 0.01)

    phm <- matrix(nrow=nrep, ncol=length(p))

    for (i in 1:nrep) {
        for (j in 1:length(p)) {
            phm[i, j]  <-   mean(rbinom(n, 1, p[j]))
        }
    }

    lo <- function(i) {
          i - z*sqrt(i*(1-i)/n)
          }
    up <- function(i) {
          i + z*sqrt(i*(1-i)/n)
          }

    lom <- apply(phm, 2, lo)
    upm <- apply(phm, 2, up)

    cpvec <- numeric()
    for (i in 1:ncol(phm)) {
        cpvec[i] <- sum(lom[,i] <= p[i] & p[i] <= upm[,i])/nrep
    }
    plot(p, cpvec, type="l", ylim=c(0.7,1))
    abline(h=1-alpha, col=5)
}

cp()