堆栈内存溢出
  繁体   English   中英

R：具有置信度和预测间隔的三相线性模型的鲁棒非线性最小二乘拟合

[英]R : Robust nonlinear least squares fitting of three-phase linear model with confidence & prediction intervals

 原文  2018-03-17 20:12:50  3   1    r/ mathematical-optimization/ nls/ non-linear-regression

问题描述

我想在R中使用nls拟合单调递增的三相线性模型。说我有数据 

y <- c(4.5,4.3,2.57,4.40,4.52,1.39,4.15,3.55,2.49,4.27,4.42,4.10,2.21,2.90,1.42,1.50,1.45,1.7,4.6,3.8,1.9)
x <- 1500-c(320,419,650,340,400,800,300,570,720,480,425,460,675,600,850,920,975,1022,450,520,780)

我想得到像 在此处输入图片说明 即我有x断点位于x=B1和B2 ，外加95％的置信度和预测间隔，我想使用investr软件包中的predFit函数基于nls拟合来计算。

这里的模型是 

y=(x < B1)*a +
  (x >= B1)*(x <= B2)*(a + b*(x - B1)) +
  (x > B2)*(a + b*(B2 - B1))

考虑到B1应该>min(x)的期望约束，然后设置 

B1 = min(x)+exp(logB1minminx)

为了确保我设置B2 > B1 

B2 = B1+exp(logB2minB1)

并确保中间剖面线b > 0的斜率设置为 

b = exp(logb)

[我不太清楚如何放入B2<max(x)的剩余约束条件]

为了初步了解斜率参数b的合理起始值 

f <- function (d) {
  m <- lm(y~x, as.data.frame(d))
  return(coef(m)[2])
}
require(zoo)
slopes <- rollapply(data.frame(x=x,y=y), 3, f, by.column=F)

优化参数，然后使用optimx和method="nlminb" （=端口算法）一起工作： 

    preds = function (par) { 
  B1 = min(x)+exp(par[["logB1minminx"]]) # to make sure that B1 > min(x)
  B2 = B1+exp(par[["logB2minB1"]]) # to make sure that B2 > B1
  b = exp(par[["logb"]]) # to make sure that slope b > 0
  a = par[["a"]]
  pred = (x < B1)*a +
    (x >= B1)*(x <= B2)*(a + b*(x - B1)) +
    (x > B2)*(a + b*(B2 - B1))
  return(pred)
  }
SSR <- function (par, x=x, y=y) { # sums of squares
  fitted = preds(par)
  SS = sum((y - fitted)^2)
  return(SS) }
library(optimx)
fits = optimx(par = c(logB1minminx=log(650-min(x)), logB2minB1=log(1000-650), a=1.5, logb=log(mean(slopes))),
       lower = c(logB1minminx=-100, logB2minB1=-100, a=min(y), logb=-100),
       upper = c(logB1minminx=log(mean(x)-min(x)), logB2minB1=log(max(x)-min(x)), a=max(y), logb=log(max(slopes))),
       fn = SSR, 
       x = x,
       y = y,
       method = "nlminb",
       hessian=TRUE,
       control=list(all.methods=TRUE, maxit=1000, starttests=FALSE))
fits
#          logB1minminx logB2minB1        a      logb         value fevals gevals niter convcode kkt1 kkt2 xtimes
# L-BFGS-B     5.402100   5.859305 1.511979 -4.804957  6.405210e-01     41     41    NA        0   NA   NA   0.01
# nlminb       5.402677   5.858434 1.512409 -4.804421  6.404725e-01     65    155    31        1   NA   NA   0.00
# spg          5.402677   5.858560 1.512154 -4.804395  6.404726e-01    349     NA   195        0   NA   NA   0.11
# Rcgmin             NA         NA       NA        NA 8.988466e+307     NA     NA    NA     9999   NA   NA   0.00
# Rvmmin             NA         NA       NA        NA 8.988466e+307     NA     NA    NA     9999   NA   NA   0.00
# bobyqa       5.402677   5.859331 1.511529 -4.804637  6.404949e-01    148     NA    NA        0   NA   NA   0.00
# nmkb               NA         NA       NA        NA 8.988466e+307     NA     NA    NA     9999   NA   NA   0.00
# hjkb         5.147494   5.857933 1.500000 -5.218677  9.533185e+00      1     NA     0     9999   NA   NA   0.00
xvals=seq(min(x),max(x),length.out=1000)
plot(x, y, col="black",pch=16)
lines(xvals, 
      preds(coef(fits)["nlminb",], xvals), col="blue")

因此，这给出了如上所述的拟合。 大多数算法似乎都没有收敛。 而且，Hessian的计算失败了，这是一个问题，因为我需要能够计算出整体拟合的系数，置信区间和预测区间的标准误差。

同样，当我询问系数汇总时， nls和nlsLM都返回错误，这使我无法使用investr软件包来计算置信度和预测间隔： 

nlsfit = nls(y ~ (x < (min(x)+logB1minminx))*
               a + 
               (x >= (min(x)+logB1minminx))*
               (x <= (min(x)+exp(logB1minminx)+exp(logB2minB1)))*(a + exp(logb)*(x - (min(x)+logB1minminx))) + 
               (x > (min(x)+exp(logB1minminx)+exp(logB2minB1)))*
               (a + exp(logb)*((min(x)+exp(logB1minminx)+exp(logB2minB1)) - (min(x)+logB1minminx))),
             data = data.frame(x=x, y=y),
             algorithm = "port",
             start = c(logB1minminx=log(650-min(x)), logB2minB1=log(1000-650), a=1.6, logb=log(mean(slopes))),
             control = nls.control(maxiter=1000, warnOnly=TRUE) )
summary(nlsfit)
# Error in chol2inv(object$m$Rmat()) : 
#  element (4, 4) is zero, so the inverse cannot be computed
library(investr)
predFit(nlsfit, newdata=data.frame(x=xvals), interval="prediction")
# Error in solve.default(crossprod(R1)) : 
#   Lapack routine dgesv: system is exactly singular: U[4,4] = 0

require(minpack.lm)
nlslmfit = nlsLM(y ~ (x < (min(x)+logB1minminx))*
                   a + 
                   (x >= (min(x)+logB1minminx))*
                   (x <= (min(x)+exp(logB1minminx)+exp(logB2minB1)))*(a + exp(logb)*(x - (min(x)+logB1minminx))) + 
                   (x > (min(x)+exp(logB1minminx)+exp(logB2minB1)))*
                   (a + exp(logb)*((min(x)+exp(logB1minminx)+exp(logB2minB1)) - (min(x)+logB1minminx))),
                 data = data.frame(x=x, y=y),
      start = c(logB1minminx=log(650-min(x)), logB2minB1=log(1000-650), a=1.6, logb=log(mean(slopes))) )
# Error in nlsModel(formula, mf, start, wts) : 
#   singular gradient matrix at initial parameter estimates

有人知道我怎么能使用nls或nlsLM稳健地拟合这种模型，也许通过使用接近上述三相线性模型的平滑连续可微函数，从而允许将一阶导数传递给优化器？ 我尝试使用4参数逻辑模型，但找不到与三相线性模型足够接近的良好平滑中心对称函数。 如果数据中没有明确的断点，我希望在min(x)处估计B1 ，而在max(x) B2 ，我希望在min(x)处估计B1 ，如果有不是上限断点，我希望在max(x)处估计B2 。 换句话说，理想情况下，拟合也应该适用于点仅遵循线性模型的数据。 有什么想法吗？

编辑：取得了一些进展-我发现了一个很好的平滑近似值，并且适合nlsLM 。 如果我在没有最高断点的情况下在数据上尝试它，则仍然无法正常工作-我想我必须尝试适应多个模型-具有2个断点，低端或上端只有一个断点，或者没有断点，请参见哪一个拥有最好的AIC或BIC ... 

require(minpack.lm)
nlslmfit = nlsLM(y ~ a + (1/2)*exp(logb)*(B2-B1) + # we fit exp(logb) to force b > 0
                   (1/2)*sqrt(abs(exp(logb)*(4*1E-10+exp(logb)*(B1-x)^2))) - # now set s to 1E-10, we could also fit exp(logs) 
                   (1/2)*sqrt(abs(exp(logb)*(4*1E-10+exp(logb)*(B2-x)^2))),
                 data = data.frame(x=x, y=y),
                 start = c(B1=min(x)+1E-10, B2=max(x)-1E-10, a=min(y)+1E-10, logb=log(max(slopes))),
                 # lower = c(B1=min(x), B2=mean(x), a=min(y), logb=log(min(slopes[slopes>0]))),
                 # upper = c(B1=mean(x), B2=max(x), a=mean(y), logb=log(max(slopes))),
                 control = nls.control(maxiter=1000, warnOnly=TRUE) )
# as s->0 this smooth model approximates more closely the piecewise linear one
summary(nlslmfit)
# Parameters:
#   Estimate Std. Error t value Pr(>|t|)    
#   B1    699.99988   19.23569   36.39  < 2e-16 ***
#   B2   1050.00069   15.49283   67.77  < 2e-16 ***
#   a       1.50817    0.09636   15.65 1.57e-11 ***
#   logb   -4.80172    0.06347  -75.65  < 2e-16 ***
require(investr)
xvals=seq(min(x),max(x),length.out=100)
predintervals = data.frame(x=xvals,predFit(nlslmfit, newdata=data.frame(x=xvals), interval="prediction"))
confintervals = data.frame(x=xvals,predFit(nlslmfit, newdata=data.frame(x=xvals), interval="confidence"))
require(ggplot2)
qplot(data=predintervals, x=x, y=fit, ymin=lwr, ymax=upr, geom="ribbon", fill=I("red"), alpha=I(0.2)) +
  geom_ribbon(data=confintervals, aes(x=x, ymin=lwr, ymax=upr), fill=I("blue"), alpha=I(0.2)) +
  geom_line(data=confintervals, aes(x=x, y=fit), colour=I("blue"), lwd=2) +
  geom_point(data=data.frame(x=x,y=y), aes(x=x, y=y, ymin=NULL, ymax=NULL), size=5, col="blue") +
  ylab("y")

在此处输入图片说明 

# on subset of data without lower breakpoint:
nlslmfit = nlsLM(y ~ a + (1/2)*exp(logb)*(B2-B1) + # we fit exp(logb) to force b > 0
                   (1/2)*sqrt(abs(exp(logb)*(4*1E-10+exp(logb)*(B1-x)^2))) - # now set s to 1E-10, we could also fit exp(logs) 
                   (1/2)*sqrt(abs(exp(logb)*(4*1E-10+exp(logb)*(B2-x)^2))),
                 data = data.frame(x=x, y=y),
                 subset = x>760,
                 start = c(B1=min(x[x>760])+1E-10, B2=max(x)-1E-10, a=min(y)+1E-10, logb=log(max(slopes))),
                 # lower = c(B1=min(x), B2=mean(x), a=min(y), logb=log(min(slopes[slopes>0]))),
                 # upper = c(B1=mean(x), B2=max(x), a=mean(y), logb=log(max(slopes))),
                 control = nls.control(maxiter=1000, warnOnly=TRUE) )
summary(nlslmfit)
require(investr)
xvals=seq(760,max(x),length.out=100)
predintervals = data.frame(x=xvals,predFit(nlslmfit, newdata=data.frame(x=xvals), interval="prediction"))
confintervals = data.frame(x=xvals,predFit(nlslmfit, newdata=data.frame(x=xvals), interval="confidence"))
require(ggplot2)
qplot(data=predintervals, x=x, y=fit, ymin=lwr, ymax=upr, geom="ribbon", fill=I("red"), alpha=I(0.2)) +
  geom_ribbon(data=confintervals, aes(x=x, ymin=lwr, ymax=upr), fill=I("blue"), alpha=I(0.2)) +
  geom_line(data=confintervals, aes(x=x, y=fit), colour=I("blue"), lwd=2) +
  geom_point(data=data.frame(x=x,y=y)[x>760,], aes(x=x, y=y, ymin=NULL, ymax=NULL), size=5, col="blue") +
  ylab("y")

在此处输入图片说明 

# on subset of data without upper breakpoint - here I still get an error:
nlslmfit = nlsLM(y ~ a + (1/2)*exp(logb)*(B2-B1) + # we fit exp(logb) to force b > 0
                   (1/2)*sqrt(abs(exp(logb)*(4*1E-10+exp(logb)*(B1-x)^2))) - # now set s to 1E-10, we could also fit exp(logs) 
                   (1/2)*sqrt(abs(exp(logb)*(4*1E-10+exp(logb)*(B2-x)^2))),
                 data = data.frame(x=x, y=y),
                 subset = x<1040,
                 start = c(B1=min(x)+1E-10, B2=max(x[x<1040])-1E-10, a=min(y)+1E-10, logb=log(max(slopes))),
                 # lower = c(B1=min(x), B2=mean(x), a=min(y), logb=log(min(slopes[slopes>0]))),
                 # upper = c(B1=mean(x), B2=max(x), a=mean(y), logb=log(max(slopes))),
                 control = nls.control(maxiter=1000, warnOnly=TRUE) )
summary(nlslmfit)
require(investr)
xvals=seq(min(x),1040,length.out=100)
# here prediction & confidence intervals still fail though:
predintervals = data.frame(x=xvals,predFit(nlslmfit, newdata=data.frame(x=xvals), interval="prediction"))
# Error in solve.default(crossprod(R1)) : 
# system is computationally singular: reciprocal condition number = 2.65525e-23
confintervals = data.frame(x=xvals,predFit(nlslmfit, newdata=data.frame(x=xvals), interval="confidence"))
require(ggplot2)
qplot(data=predintervals, x=x, y=fit, ymin=lwr, ymax=upr, geom="ribbon", fill=I("red"), alpha=I(0.2)) +
  geom_ribbon(data=confintervals, aes(x=x, ymin=lwr, ymax=upr), fill=I("blue"), alpha=I(0.2)) +
  geom_line(data=confintervals, aes(x=x, y=fit), colour=I("blue"), lwd=2) +
  geom_point(data=data.frame(x=x,y=y)[x<1040,], aes(x=x, y=y, ymin=NULL, ymax=NULL), size=5, col="blue") +
  ylab("y")

1 个解决方案

解决方案1
 0  2018-03-18 13:49:36

library(minpack.lm)
fo <- y ~ pmax(a1, pmin(a2 + b * x, a3)) 
co <- coef(lm(y ~ x))
fm <- nlsLM(fo, start = list(a1 = min(y), a2 = co[[1]], b = co[[2]], a3 = max(y)))

o <- order(x)
plot(y ~ x, subset = o)
lines(fitted(fm) ~ x, subset = o, col = "red")

summary(fm)

library(investr)
predFit(fm, data.frame(x), se = TRUE)

屏幕截图

暂无
暂无

声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

相关问题 R非线性最小二乘（nls）模型拟合 如何计算 r 中非线性最小二乘的置信区间？ R中的非线性最小二乘曲线拟合 R中非线性最小二乘拟合的预测 线性最小二乘拟合 R 中的 Function 计算线性回归的异方差稳健置信区间 R：置信区间和预测 如何在 r 中合并稳健混合 model 的 MI 置信区间？ R中具有任意数量的拟合参数的非线性最小二乘 R 用稳健的线性回归模型 (rlm) 绘制置信区间线
相关标签
 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM