Question

这是我的问题的简短版本。代码如下。

我使用optim（）计算了R中非线性von Bertalanffy增长方程的参数，现在我试图通过自举将95％置信区间加到von B生长系数K.对于至少一年的数据，当我总结增长系数K的自举输出时，自举的均值和中值参数估计与估计参数完全不同：

>summary(temp.store) # summary of bootstrap values
     Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
 0.002449 0.005777 0.010290 0.011700 0.016970 0.056720

> est.K [1] 0.01655956  # point-estimate from the optimization

我怀疑这种差异是因为随机抽取的引导程序中存在偏差结果的错误，尽管我已经使用try（）来阻止优化在导致错误的输入值组合时崩溃。所以我想知道如何解决这个问题。我认为我正在做正确的事情，因为拟合的曲线看起来正确。

此外，我已经为其他年份的数据运行此代码，并且至少在另一年中，bootrap估算和常规估算非常接近。

啰嗦版：

长度的von Bertalanffy生长曲线（VBGC）由下式给出： L（t）= L.inf * [1 - exp（-K *（t-t0））]（公式3.1.0.1，来自FAO）

其中L（t）是鱼的长度，L.inf是渐近最大长度，K是生长系数，t是时间步长，t0是生长开始时。 L（t）和t是观察到的数据。通常时间或年龄是以年为单位来衡量的，但在这里我看的是幼鱼数据，而且我从1月1日开始计算一年中的那一天（“doy”）。

为了估计优化的起始参数，我使用了VBGC方程的线性化。

doy <- c(156,205,228,276,319,380)
len <- c(36,56,60,68,68,71)
data06 <- data.frame(doy,len)

获取优化的起始参数的函数：

get.init <-function(dframe){ # linearization of the von B
  l.inf <- 80  # by eyeballing max juvenile fish
  # make a response variable and store it in the data frame:
  # Eqn. 3.3.3.1 in FAO document
  dframe$vonb.y <- - log(1 - (dframe$len)/l.inf  )
  lin.vonb <- lm(vonb.y ~ doy, data=dframe)
  icept <- lin.vonb$coef[1] #  0.01534013 # intercept is a
  slope <-  k.lin <- lin.vonb$coef[2] # slope is the K param
  t0 <- - icept/slope # get t0 from this relship: intercept= -K * t0
  pars <- c(l.inf,as.numeric(slope),as.numeric(t0))
}

von Bertalanffy生长方程的平方和

vbl.ssq <- function(theta, data){
  linf=theta[1]; k=theta[2]; t0=theta[3]
  # name variables for ease of use
  obs.length=data$len
  age=data$doy
  #von B equation
  pred.length=linf*(1-exp(-k*(age-t0)))
  #sums of squares
  ssq=sum((obs.length-pred.length)^2)
}

估算参数

#Get starting parameter values
theta_init <- get.init(dframe=data06)
# optimize VBGC by minimizing sums of square differences
len.fit <- optim(par=theta_init, fn=vbl.ssq, method="BFGS", data=data06)

est.linf <- len.fit$par[1] # vonB len-infinite
est.K <- len.fit$par[2]      # vonB K
est.t0 <- len.fit$par[3]     # vonB t0

自举

# set up for bootstrap loop
tmp.frame <- data.frame()
temp.store <- vector()

# bootstrap to get 95% conf ints on growth coef K
for (j in 1:1000){
  # choose indices at random, with replacement
  indices <- sample(1:length(data06[,1]),replace=T)
  # values from original data corresponding to those indices
  new.len <- data06$len[indices]
  new.doy <- data06$doy[indices]
  tmp.frame <- data.frame(new.doy,new.len)
  colnames(tmp.frame) <- c("doy","len")

  init.par <- get.init(tmp.frame)
  # now get the vonB params for the randomly selected samples
  # using try() to keep optimizing errors from crashing the program
  try(  len.fit.bs <- optim(par=init.par, fn=vbl.ssq, method="BFGS", data=tmp.frame))
  tmp.k <- len.fit.bs$par[2]
  temp.store[j] <- tmp.k
}

K参数的95％置信区间

k.ci <- quantile(temp.store,c(0.025,0.975))
#       2.5%       97.5% 
#0.004437702 0.019784178

问题在于：

#>summary(temp.store)
#     Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
# 0.002449 0.005777 0.010290 0.011700 0.016970 0.056720
# 
# est.K [1] 0.01655956

错误示例：

Error in optim(par = init.par, fn = vbl.ssq, method = "BFGS", data = tmp.frame) : 
  non-finite finite-difference value [2]

我不相信我在优化时出现任何错误，因为VBGC适合看起来合理。以下是情节：

plot(x=data06$doy,y=data06$len,xlim=c(0,550),ylim=c(0,100))
legend(x="topleft",legend=paste("Length curve 2006"), bty="n")
curve(est.linf*(1-exp(-est.K*(x-est.t0))), add=T,type="l")

plot(x=2006,y=est.K, main="von B growth coefficient for length; 95% CIs",
    ylim=c(0,0.025))
arrows(x0=2006,y0=k.ci[1],x1=2006,y1=k.ci[2], code=3,
    angle=90,length=0.1)

Answer 1

首先，您拥有的数值非常少，可能太少而无法信任引导方法。然后，经典引导程序的高比例适合失败，因为由于重新采样，您通常没有足够的不同x值。

以下是使用带有自启动模型和启动包的nls的实现。

doy <- c(156,205,228,276,319,380)
len <- c(36,56,60,68,68,71)
data06 <- data.frame(doy,len)

plot(len ~ doy, data = data06)

fit <- nls(len ~ SSasympOff(doy, Asym, lrc, c0), data = data06)
summary(fit)
#profiling CI
proCI <- confint(fit)
#          2.5%      97.5%
#Asym 68.290477  75.922174
#lrc  -4.453895  -3.779994
#c0   94.777335 126.112523

curve(predict(fit, newdata = data.frame(doy = x)), add = TRUE)

#classic bootstrap
library(boot)
set.seed(42)
boot1 <- boot(data06, function(DF, i) {
  tryCatch(coef(nls(len ~ SSasympOff(doy, Asym, lrc, c0), data = DF[i,])),
           error = function(e) c(Asym = NA, lrc = NA, c0 = NA))
}, R = 1e3)

#proportion of unsuccessful fits
mean(is.na(boot1$t[, 1]))
#[1] 0.256

#bootstrap CI
boot1CI <- apply(boot1$t, 2, quantile, probs = c(0.025, 0.5, 0.975), na.rm = TRUE)
#          [,1]      [,2]      [,3]
#2.5%  69.70360 -4.562608  67.60152
#50%   71.56527 -4.100148 113.9287
#97.5% 74.79921 -3.697461 151.03541


#bootstrap of the residuals
data06$res <- residuals(fit)
data06$fit <- fitted(fit)

set.seed(42)
boot2 <- boot(data06, function(DF, i) {
  DF$lenboot <- DF$fit + DF[i, "res"]
  tryCatch(coef(nls(lenboot ~ SSasympOff(doy, Asym, lrc, c0), data = DF)),
           error = function(e) c(Asym = NA, lrc = NA, c0 = NA))
}, R = 1e3)

#proportion of unsuccessful fits
mean(is.na(boot2$t[, 1]))
#[1] 0

#(residuals) bootstrap CI
boot2CI <- apply(boot2$t, 2, quantile, probs = c(0.025, 0.5, 0.975), na.rm = TRUE)
#          [,1]      [,2]     [,3]
#2.5%  70.19380 -4.255165 106.3136
#50%   71.56527 -4.100148 113.9287
#97.5% 73.37461 -3.969012 119.2380
proCI[2,1]

CIs_k <- data.frame(lwr = c(exp(proCI[2, 1]),
                            exp(boot1CI[1, 2]),
                            exp(boot2CI[1, 2])),
                    upr = c(exp(proCI[2, 2]),
                            exp(boot1CI[3, 2]),
                            exp(boot2CI[3, 2])),
                    med = c(NA,
                            exp(boot1CI[2, 2]),
                            exp(boot2CI[2, 2])),
                    estimate = exp(coef(fit)[2]),
                    method = c("profile", "boot", "boot res"))

library(ggplot2)
ggplot(CIs_k, aes(y = estimate, ymin = lwr, ymax = upr, x = method)) +
  geom_errorbar() +
  geom_point(aes(color = "estimate"), size = 5) +
  geom_point(aes(y = med, color = "boot median"), size = 5) +
  ylab("k") + xlab("") +
  scale_color_brewer(name = "", type = "qual", palette = 2) +
  theme_bw(base_size = 22)

如您所见，自举CI比配置文件CI更宽，并且引导残差导致更窄的估计CI。所有这些几乎都是对称的。此外，中位数接近点估计值。

作为调查代码中出现问题的第一步，您应该查看程序中失败拟合的比例。

R中非线性优化的Bootstrap参数估计：为什么它与常规参数估计不同？

1 个答案: