計算和 plot 廣義非線性 model 的 95% 置信區間

Question

我已經用R package nlme和包含的gnls() ZC1C425268E68385D1AB5074C17A94F14 建立了幾個廣義非線性最小二乘模型（指數衰減）。 我不簡單地使用基礎nls() function 構建非線性最小二乘模型的原因是因為我希望能夠使用 model 異方差來避免轉換。 我的模型看起來像這樣：

model <- gnls(Response ~ C * exp(k * Explanatory1) + A,
              start = list(C = c(C1,C1), k = c(k1,k1), A = c(A1,A1)),
              params = list(C ~ Explanatory2, k ~ Explanatory2, 
                            A ~ Explanatory2),
              weights = varPower(), 
              data = Data)

與簡單的nls() model 的主要區別在於weights參數，它可以通過解釋變量對異方差進行建模。 與gnls()等價的線性是廣義最小二乘法，它與nlme的gls() function 一起運行。

Now I would like to calculate confidence intervals in R and plot them alongside my model fit in ggplot() ( ggplot2 package). 我為gls() object 執行此操作的方式是：

NewData <- data.frame(Explanatory1 = c(...), Explanatory2 = c(...)) 
NewData$fit <- predict(model, newdata = NewData)

到目前為止，一切正常，我的 model 很合適。

modmat <-  model.matrix(formula(model)[-2], NewData)
int <- diag(modmat %*% vcov(model) %*% t(modmat))
NewData$lo <- with(NewData, fit - 1.96*sqrt(int))
NewData$hi <- with(NewData, fit + 1.96*sqrt(int))

這部分不適用於gnls()所以我無法獲得我的上下 model 預測。

由於這似乎不適用於gnls()對象，因此我查閱了教科書以及以前提出的問題，但似乎沒有一個適合我的需要。 我發現的唯一類似問題是如何計算 r 中非線性最小二乘的置信區間？ . 在最佳答案中，建議使用investr::predFit()或使用drc::drm()構建model，然后使用常規predict() function。 這些解決方案都沒有幫助我gnls() 。

我目前最好的解決方案是使用confint() function 計算所有三個參數（C、k、A）的 95% 置信區間，然后為置信上限和下限編寫兩個單獨的函數，即一個使用 Cmin、kmin 和 Amin一種使用 Cmax、kmax 和 Amax。 然后我使用這些函數來預測值，然后用ggplot()預測 plot 。 但是，我對結果並不完全滿意，並且不確定這種方法是否最佳。

這是一個最小的可重現示例，為簡單起見，忽略了第二個分類解釋變量：

# generate data
set.seed(10)
x <-  rep(1:100,2)
r <- rnorm(x, mean = 10, sd = sqrt(x^-1.3))
y <- exp(-0.05*x) + r
df <-  data.frame(x = x, y = y)

# find starting values
m <- nls(y ~ SSasymp(x, A, C, logk))
summary(m) # A = 9.98071, C = 10.85413, logk = -3.14108
plot(m) # clear heteroskedasticity

# fit generalised nonlinear least squares
require(nlme)
mgnls <- gnls(y ~ C * exp(k * x) + A, 
              start = list(C = 10.85413, k = -exp(-3.14108), A = 9.98071),
              weights = varExp(),
              data = df)
plot(mgnls) # more homogenous

# plot predicted values 
df$fit <- predict(mgnls)
require(ggplot2)
ggplot(df) +
  geom_point(aes(x, y)) +
  geom_line(aes(x, fit)) +
  theme_minimal()

按照 Ben Bolker 的回答進行編輯

標准的非參數自舉解決方案應用於第二個模擬數據集，該數據集更接近我的原始數據並包括第二個分類解釋變量：

# generate data
set.seed(2)
x <- rep(sample(1:100, 9), 12)
set.seed(15)
r <- rnorm(x, mean = 0, sd = 200*x^-0.8)
y <- c(200, 300) * exp(c(-0.08, -0.05)*x) + c(120, 100) + r
df <-  data.frame(x = x, y = y, 
                  group = rep(letters[1:2], length.out = length(x)))

# find starting values
m <- nls(y ~ SSasymp(x, A, C, logk))
summary(m) # A = 108.9860, C = 356.6851, k = -2.9356
plot(m) # clear heteroskedasticity

# fit generalised nonlinear least squares
require(nlme)
mgnls <- gnls(y ~ C * exp(k * x) + A, 
              start = list(C = c(356.6851,356.6851), 
                           k = c(-exp(-2.9356),-exp(-2.9356)), 
                           A = c(108.9860,108.9860)),
              params = list(C ~ group, k ~ group, A ~ group),
              weights = varExp(),
              data = df)
plot(mgnls) # more homogenous

# calculate predicted values 
new <- data.frame(x = c(1:100, 1:100),
                  group = rep(letters[1:2], each = 100))
new$fit <- predict(mgnls, newdata = new)

# calculate bootstrap confidence intervals
bootfun <- function(newdata) {
  start <- coef(mgnls)
  dfboot <- df[sample(nrow(df), size = nrow(df), replace = TRUE),]
  bootfit <- try(update(mgnls,
                        start = start,
                        data = dfboot),
                 silent = TRUE)
  if(inherits(bootfit, "try-error")) return(rep(NA, nrow(newdata)))
  predict(bootfit, newdata)
}

set.seed(10)
bmat <- replicate(500, bootfun(new))
new$lwr <- apply(bmat, 1, quantile, 0.025, na.rm = TRUE)
new$upr <- apply(bmat, 1, quantile, 0.975, na.rm = TRUE)

# plot data and predictions
require(ggplot2)
ggplot() +
  geom_point(data = df, aes(x, y, colour = group)) +
  geom_ribbon(data = new, aes(x = x, ymin = lwr, ymax = upr, fill = group), 
              alpha = 0.3) +
  geom_line(data = new, aes(x, fit, colour = group)) +
  theme_minimal()

這是生成的 plot，看起來很整潔！

Answer 1

我實現了一個引導解決方案。 我最初做了標准的非參數引導，它對觀察結果重新采樣，但這會產生 95% 的 CI，看起來很寬——我認為這是因為這種引導形式無法保持 x 分布中的平衡（例如，通過重新采樣，你最終可能會沒有觀察到 x 的小值）。 （我的代碼中也可能只有一個錯誤。）

作為第二個鏡頭，我切換到從初始擬合重新采樣殘差並將它們添加到預測值； 這是一種相當標准的方法，例如在引導時間序列中（盡管我忽略了殘差中自相關的可能性，這需要塊引導）。

這是基本的引導重采樣器。

df$res <- df$y-df$fit
bootfun <- function(newdata=df, perturb=0, boot_res=FALSE) {
    start <- coef(mgnls)
    ## if we start exactly from the previously fitted coefficients we end
    ## up getting all-identical answers? Not sure what's going on here, but
    ## we can fix it by perturbing the starting conditions slightly
    if (perturb>0) {
        start <- start * runif(length(start), 1-perturb, 1+perturb)
    }
    if (!boot_res) {
        ## bootstrap raw data
        dfboot <- df[sample(nrow(df),size=nrow(df), replace=TRUE),]
    } else {
        ## bootstrap residuals
        dfboot <- transform(df,
                            y=fit+sample(res, size=nrow(df), replace=TRUE))
    }
    bootfit <- try(update(mgnls,
                      start = start,
                      data=dfboot),
                   silent=TRUE)
    if (inherits(bootfit, "try-error")) return(rep(NA,nrow(newdata)))
    predict(bootfit,newdata=newdata)
}

set.seed(101)
bmat <- replicate(500,bootfun(perturb=0.1,boot_res=TRUE))   ## resample residuals
bmat2 <- replicate(500,bootfun(perturb=0.1,boot_res=FALSE)) ## resample observations
## construct envelopes (pointwise percentile bootstrap CIs)
df$lwr <- apply(bmat, 1, quantile, 0.025, na.rm=TRUE)
df$upr <- apply(bmat, 1, quantile, 0.975, na.rm=TRUE)
df$lwr2 <- apply(bmat2, 1, quantile, 0.025, na.rm=TRUE)
df$upr2 <- apply(bmat2, 1, quantile, 0.975, na.rm=TRUE)

現在畫圖：

ggplot(df, aes(x,y)) +
    geom_point() +
    geom_ribbon(aes(ymin=lwr, ymax=upr), colour=NA, alpha=0.3) +
    geom_ribbon(aes(ymin=lwr2, ymax=upr2), fill="red", colour=NA, alpha=0.3) +
    geom_line(aes(y=fit)) +
    theme_minimal()

粉紅色/淺紅色區域是觀察級引導 CI（可疑）； 灰色區域是剩余的引導 CI。

也可以嘗試使用 delta 方法，但是（1）它比自舉做出更強的假設/近似，並且（2）我沒時間了。