[英]R : Robust nonlinear least squares fitting of three-phase linear model with confidence & prediction intervals
I would like to fit a monotonically increasing three-phase linear model using nls
in R. Say I have data 我想在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)
I would like to get something like 我想得到像
ie with x breakpoints at
x=B1
and B2
, plus 95% confidence & prediction intervals, which I would like to calculate based on the nls
fit using the predFit
function in the investr
package. 即我有x断点位于
x=B1
和B2
,外加95%的置信度和预测间隔,我想使用investr
软件包中的predFit
函数基于nls
拟合来计算。
The model here would be 这里的模型是
y=(x < B1)*a +
(x >= B1)*(x <= B2)*(a + b*(x - B1)) +
(x > B2)*(a + b*(B2 - B1))
To take into account the desired constraints that B1
should be >min(x)
, I then set 考虑到
B1
应该>min(x)
的期望约束,然后设置
B1 = min(x)+exp(logB1minminx)
To make sure that B2 > B1
I set 为了确保我设置
B2 > B1
B2 = B1+exp(logB2minB1)
And to make sure that the slope of the middle section line b > 0
I set 并确保中间剖面线
b > 0
的斜率设置为
b = exp(logb)
[I didn't quite know how to put in the remaining constraint that B2<max(x)
] [我不太清楚如何放入
B2<max(x)
的剩余约束条件]
To get an idea of sensible starting values for the slope parameter b
I first calculated 为了初步了解斜率参数
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)
Optimizing the parameters then kind of works using optimx
with method="nlminb"
(=port algo): 优化参数,然后使用
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")
So this gives the fit as shown above. 因此,这给出了如上所述的拟合。 Most of the algorithms don't seem to converge though.
大多数算法似乎都没有收敛。 And calculation of the Hessian fails, which is a problem since I need that to be able to calculate standard errors on the coefficients & confidence intervals & prediction intervals on the overall fit.
而且,Hessian的计算失败了,这是一个问题,因为我需要能够计算出整体拟合的系数,置信区间和预测区间的标准误差。
Likewise, nls
and nlsLM
both return errors when I ask the coefficient summaries, and this prevents me from calculating the confidence & prediction intervals using the investr
package : 同样,当我询问系数汇总时,
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
Does anybody know how I could fit this kind of model robustly using either nls
or nlsLM
, perhaps through the use of a smooth continuous differentiable function that approaches the 3-phase linear model above, thereby allowing the first derivative to be passed to the optimizer? 有人知道我怎么能使用
nls
或nlsLM
稳健地拟合这种模型,也许通过使用接近上述三相线性模型的平滑连续可微函数,从而允许将一阶导数传递给优化器? I tried myself with the 4 parameter logistic model, but couldn't quite find a good smooth centrosymmetric function that was close enough to the 3-phase linear model. 我尝试使用4参数逻辑模型,但找不到与三相线性模型足够接近的良好平滑中心对称函数。 If there is no clear breakpoint in the data I would like
B1
to be estimated at min(x)
and B2
at max(x)
, if there is no lower breakpoint I would like B1
to be estimated at min(x)
and if there is no upper breakpoint I would like B2
to be estimated at max(x)
. 如果数据中没有明确的断点,我希望在
min(x)
处估计B1
,而在max(x)
B2
,我希望在min(x)
处估计B1
,如果有不是上限断点,我希望在max(x)
处估计B2
。 In other words, the fit should ideally also work for data where the points just follow a linear model. 换句话说,理想情况下,拟合也应该适用于点仅遵循线性模型的数据。 Any thoughts?
有什么想法吗?
EDIT: made a little bit of progress - I found a good smooth approximation and that fits OK with nlsLM
. 编辑:取得了一些进展-我发现了一个很好的平滑近似值,并且适合
nlsLM
。 If I try it on the data without the upper breakpoint it still doesn't work though - I guess I have to try to fit several models - with 2 breakpoints, just a single breakpoint at either the lower or upper end or no breakpoints and see which one has the best AIC or BIC... 如果我在没有最高断点的情况下在数据上尝试它,则仍然无法正常工作-我想我必须尝试适应多个模型-具有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")
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.