Bootstrap模拟在R中生成错误...有时候

Question

我在R中组合了一个简单的bootstrap模拟。问题是它有时会产生错误，而其他时候却没有。

这是我的代码：

library(investr)

library(mgcv) 

library(rootSolve) 

library(boot) 

inv.predict2 <- function(object, y, x.name, interval = FALSE, 
                     lower, upper, level = 0.95,...) {
  .fun1 <- function(x) {
predFit(object, newdata = setNames(data.frame(x), x.name)) - y
  }
  .fun2 <- function(x) {
predFit(object, newdata = setNames(data.frame(x), x.name), 
        interval = "confidence")[, "upr"] - y
  }
  .fun3 <- function(x) {
predFit(object, newdata = setNames(data.frame(x), x.name), 
        interval = "confidence")[, "lwr"] - y
  }
  x0.est <- uniroot.all(lower = lower, upper = upper, ..., f = .fun1)
  res <- if (interval) {
lwr <- uniroot.all(lower = lower, upper = x0.est, ..., f = .fun2)
upr <- uniroot.all(lower = x0.est, upper = upper, ..., f = .fun3)
lwr <- min(c(lwr, upr))
upr <- max(c(lwr, upr))
c("estimate" = x0.est, "lower" = lwr, "upper" = upr)
} else {
x0.est
}
res
}

predFit.gam <- function(object, newdata, type = c("link", "response"), 
                    interval = c("none", "confidence", "prediction"), 
                    level = 0.95, ...) {
type <- match.arg(type)
interval <- match.arg(interval)
res <- if (interval == "none") {
predict.gam(object, newdata = newdata, type = type, ...)
} else if (interval == "confidence") {
pred <- predict.gam(object, newdata = newdata, se.fit = TRUE, type = "link", 
                ...)
out <- cbind("fit" = pred$fit,
             "lwr" = pred$fit - pred$se.fit * stats::qnorm((level + 1) / 2),
             "upr" = pred$fit + pred$se.fit * stats::qnorm((level + 1) / 2))
if (type == "response") {
  out <- apply(out, MARGIN = 2, FUN = function(x) {
    stats::family(object)$linkinv(x)
  })
}
out
} else {
stop("Prediction intervals are currently not supported for GAMs.")
}
res
}

predFit.scam <- function(object, newdata, type = c("link", "response"), 
                    interval = c("none", "confidence", "prediction"), 
                    level = 0.95, ...) {
   type <- match.arg(type)
   interval <- match.arg(interval)
   res <- if (interval == "none") {
predict.scam(object, newdata = newdata, type = type, ...)
  } else if (interval == "confidence") {
pred <- predict.scam(object, newdata = newdata, se.fit = TRUE, type = "link", 
                ...)
out <- cbind("fit" = pred$fit,
             "lwr" = pred$fit - pred$se.fit * stats::qnorm((level + 1) / 2),
             "upr" = pred$fit + pred$se.fit * stats::qnorm((level + 1) / 2))
if (type == "response") {
  out <- apply(out, MARGIN = 2, FUN = function(x) {
    stats::family(object)$linkinv(x)
  })
}
out
} else {
stop("Prediction intervals are currently not supported for SCAMs.")
}
res
}

ptm <- proc.time() 

K <- 1  

N <- 100 

Hstar <- 10 

perms <- 10000 

p <- 0.95

specs <- 1:N 


pop <- array(dim = c(c(perms, N), K))

haps <- as.character(1:Hstar)

probs <- rep(1/Hstar, Hstar) 

K1 <- c(1:5)

K2 <- c(6:10)

for(j in 1:perms){
    for(i in 1:K){ 
        if(i == 1){
            pop[j, specs, i] <- sample(haps, size = N, replace = TRUE, prob = probs)
    }
        else{
            pop[j ,, 1] <- sample(haps[K1], size = N, replace = TRUE, prob = probs[K1])
            pop[j ,, 2] <- sample(haps[K2], size = N, replace = TRUE, prob = probs[K2]) 
        }
}
}

HAC.mat <- array(dim = c(c(perms, N), K))

for(k in specs){
    for(j in 1:perms){
        for(i in 1:K){ 
            ind.index <- sample(specs, size = k, replace = FALSE) 
            hap.plot <- pop[sample(1:nrow(pop), size = 1, replace = TRUE), ind.index, sample(1:K, size = 1, replace = TRUE)] 
            HAC.mat[j, k, i] <- length(unique(hap.plot)) 
    }
  }
}

means <- apply(HAC.mat, MARGIN = 2, mean)

d <- data.frame(specs, means)

lower <- 1

upper <- 10000

k <- 20

HAC.cr <- gam(means ~ s(specs, bs = "cr", k = 2*k), optimizer = c("outer", "bfgs"), data = d) 

res <- resid(HAC.cr) - mean(resid(HAC.cr))

n <- length(res)

boot.data <- data.frame(d, res = res, fit = fitted(HAC.cr))

boot.fun <- function(data, i) {

boot.fit <- gam(boot.data$means + res[i] ~ s(specs, bs = "cr", k = 2*k), optimizer = c("outer", "bfgs"), data = data)

 if (all(i == 1:n)) {
    inv.predict2(HAC.cr, y = p*Hstar, x.name = "specs", lower = lower, upper = upper) 
} else {
    inv.predict2(boot.fit, y = p*Hstar, x.name = "specs", lower = lower, upper = upper)
}
}

res <- boot(boot.data, boot.fun, R = 1000)  # collect bootstrap samples
res
plot(res) # histogram and QQplot for x0
boot.ci(res, type = "all")  # obtain bootstrap confidence intervals for x0

以下代码工作正常（或应该......）（更改这些参数）：

N <- 240

Hstar <- 15

probs <- c(220/N, rep(3/N, 2), rep(2/N, 2), rep(1/N, 10))

有谁知道这里发生了什么？具体来说，我得到的错误如“$对原子矢量无效”和“boot [，...]越界”。

非常感谢任何帮助。