R nls函数执行得不好

我需要符合这个公式

 y ~ 1/(pi*a*(1+((x-2.15646)/a)^2))+1/(pi*b*(1+((x-2.16355)/b)^2))

对于变量x和y

 x<- c(2.15011, 2.15035, 2.15060, 2.15084, 2.15109, 2.15133, 2.15157, 2.15182, 2.15206, 2.15231, 2.15255, 2.15280, 2.15304, 2.15329, 2.15353, 2.15377, 2.15402, 2.15426, 2.15451, 2.15475, 2.15500, 2.15524, 2.15549, 2.15573, 2.15597, 2.15622, 2.15646, 2.15671, 2.15695, 2.15720, 2.15744, 2.15769, 2.15793, 2.15817, 2.15842, 2.15866, 2.15891, 2.15915, 2.15940, 2.15964, 2.15989, 2.16013, 2.16037, 2.16062, 2.16086, 2.16111, 2.16135, 2.16160, 2.16184, 2.16209, 2.16233, 2.16257, 2.16282, 2.16306, 2.16331, 2.16355, 2.16380, 2.16404, 2.16429, 2.16453, 2.16477, 2.16502, 2.16526, 2.16551, 2.16575, 2.16600, 2.16624, 2.16649, 2.16673, 2.16697, 2.16722, 2.16746, 2.16771, 2.16795, 2.16820, 2.16844, 2.16869, 2.16893, 2.16917, 2.16942, 2.16966, 2.16991)
 y<- c(3.77212,  3.79541,  3.84574,  3.91918, 4.01056,  4.11677,  4.23851,  4.37986, 4.54638,  4.74367,  4.97765,  5.25593,  5.58823,  5.98405,  6.44850,  6.98006, 7.57280,  8.22085,  8.92094,  9.66990, 10.45900, 11.26720, 12.05540, 12.76920, 13.34830, 13.74250, 13.92420, 13.89250, 13.67090, 13.29980, 12.82780, 12.30370, 11.76950, 11.25890, 10.80020, 10.41860, 10.13840,  9.98005,  9.95758, 10.07690, 10.33680, 10.73210, 11.25730, 11.90670, 12.67240, 13.54110, 14.49530, 15.51670, 16.58660, 17.67900, 18.75190, 19.74600, 20.59680, 21.24910, 21.66800, 21.83910, 21.76560, 21.46020, 20.94020, 20.22730, 19.35360, 18.36460, 17.31730, 16.26920, 15.26920, 14.35320, 13.54360, 12.85230, 12.28520, 11.84690, 11.54040, 11.36610, 11.32130, 11.39980, 11.59230, 11.88310, 12.25040, 12.66660, 13.09810, 13.50220, 13.82580, 14.01250)

控制台报告了以下错误：

singular gradient

---

有人能告诉我为什么控制台会打印此消息吗？

尝试使用a和b的倒数：

不幸的是，该模型并不像底部的图表所示那样工作得很好

plot(y ~ x, pch = 20)
lines(x, fitted(fm), col = "red")

增加：

在他的回答中，@jlhoward根据8个参数提供了一个更好的拟合模型。我只想指出，如果我们使用他的模型和他对a、b、p1和p2的起始值，我们不需要线性参数的起始值，如果我们指定alg=plinear，那么nls也可以工作

fo <- y ~ cbind(1/(pi*a*(1+((x-p1)/a)^2)), 1/(pi*b*(1+((x-p2)/b)^2)), 1, x)
start <- c(a = 0.001, b = 0.001, p1 = 2.157, p2 = 2.163)
fm2 <- nls(fo, start = start, alg = "plinear")

显示调频不匹配的图表：

---

修改以添加约束。

这提供了更好的拟合：

在进入下面的代码之前，您的模型存在几个问题：

假设这是质子核磁共振，峰下面积与质子丰度成正比，质子数。您的模型不允许这种情况，本质上强制所有峰值具有相同的面积。这是不合身的主要原因。我们可以通过为每个峰值包含一个高度因子来轻松适应这一点。 您的模型假设峰值位置。为什么不让算法找到真正的峰值位置呢？ 您的模型没有考虑基线漂移，正如您所见，基线漂移在数据集中相当严重。我们可以通过向模型中添加线性漂移函数来适应这种情况。 nls。。。对于这种类型的建模，它的性能很差-它使用的算法不是特别健壮。当拟合偏移数据时，默认的算法高斯-牛顿（Gauss-Newton）尤其糟糕。因此，在带有fx-p1、x-p2的模型中估计p1和p2几乎总是失败的

更好的方法是使用nls中实现的异常健壮的Levenberg-Marquardt算法。。。装在包装袋里。这个软件包使用起来有点困难，但它能够处理nls无法访问的问题。。。。如果您要做很多这方面的工作，您应该阅读以了解此示例的工作原理

最后，即使使用nls.lm。。。起点必须合理。在模型a和b中，是峰值宽度。很明显，它们必须与峰位置的差异相当或小于峰位置的差异，否则峰会被涂抹在一起。你对a，b=0.4，0.4的估计太大了

plot(x,y)
library(minpack.lm)
lorentzian <- function(par,x){ 
  a  <- par[1]
  b  <- par[2]
  p1 <- par[3]
  p2 <- par[4]
  h1 <- par[5]
  h2 <- par[6]
  drift.a <- par[7]
  drift.b <- par[8]
  h1/(pi*a*(1+((x-p1)/a)^2))+h2/(pi*b*(1+((x-p2)/b)^2)) + drift.a + drift.b*x
}

resid   <- function(par,obs,xx) {obs-lorentzian(par,xx)}
par=c(a=0.001,b=0.001, p1=2.157, p2=2.163, h1=1, h2=1, drift.a=0, drift.b=0)
lower=c(a=0,b=0,p1=0,p2=0,h1=0, h2=0,drift.a=NA,drift.b=NA)
nls.out <- nls.lm(par=par, lower=lower, fn=resid, obs=y, xx=x, 
                  control = nls.lm.control(maxiter=500))
coef(nls.out)
#             a             b            p1            p2            h1            h2       drift.a       drift.b 
#  1.679632e-03  1.879690e-03  2.156308e+00  2.163500e+00  4.318793e-02  8.199394e-02 -9.273083e+02  4.323897e+02 

lines(x,lorentzian(coef(nls.out), x), col=2, lwd=2)

---

最后一件事：SO的惯例是等待一天再接受答案。原因是，带有已接受答案的问题很少得到额外关注-一旦你接受了答案，其他人就不会看它了。

你的起始值不好，如果模型确实适合数据，使用不同的优化器可能会更好。你建议使用哪种优化器？我尝试了“nls2”软件包，但也出现了同样的错误。理论上，该模型与数据吻合较好。这是核磁共振谱的一部分，所有的峰都是洛伦兹形状。正如我观察到的两个重叠峰，我选择的输入公式是两条洛伦兹曲线的总和。将一对峰与数据w/2峰拟合通常不起作用。只是没那么简单。你知道理论上这个模型是有效的。在实践中，这个理论并不适用于你的情况，数据的缺乏将使得很难很好地拟合任何模型公式。你的意思是，有了更多的数据点，我应该能够得到任何近似值吗？或者我还有其他我忽略的障碍吗？我不会。我可能会运行一个样条线平滑算法spline或smooth.spline，然后使用许多峰值查找工具中的一个，然后使用它来完成。您已经多次发布关于此问题的变体；现在还不清楚为什么需要拟合曲线而不是识别峰值。事实上，“a”不应该是负数，但我猜这是因为数据的最后一点对应于函数中未定义的第三个峰值。你知道当“nls”试图找到我的参数值时，我是否可以定义任何约束？优化例程不能很好地处理平面函数，在这里使用倒数有助于实现这一点。我现在也添加了约束条件，但我们的视觉拟合仍然很差。“lower=1”是否意味着“a”或“b”的最大值是1，不是吗？还是说“a”和“b”只能是正的？明天我将尝试在整个数据集中复制您的实验，它包括5个重叠的峰值，并发布在这里。我想如果谱的两边都接近0，结果会更好。当取倒数时，约束区间0,1映射到区间1，Inf。同意这是一个更好的答案@G.Grothendieck的答案是正确的，但这一个更完整哇！我对你的实施感到震惊！你真是个天才！我在这方面花了太多的时间，以至于我无法找出我的代码有多错。我只想指出，2我无法使我的函数工作，我从公式中删除了峰值位置变量，试图更快但效率不高。此外，3该数据先前用特殊的N处理 MR软件，所以它可能不会有一个尖锐的漂移。在这种特殊情况下，我从五元组中选取数据，因为我不想在SO中使用太多变量。

plot(y ~ x, pch = 20)
lines(x, fitted(fm), col = "red")

fo <- y ~ cbind(1/(pi*a*(1+((x-p1)/a)^2)), 1/(pi*b*(1+((x-p2)/b)^2)), 1, x)
start <- c(a = 0.001, b = 0.001, p1 = 2.157, p2 = 2.163)
fm2 <- nls(fo, start = start, alg = "plinear")

> coef(fm2)
            a             b            p1            p2         .lin1 
 1.679635e-03  1.879682e-03  2.156308e+00  2.163500e+00  4.318798e-02 
        .lin2         .lin3        .lin.x 
 8.199364e-02 -9.273104e+02  4.323907e+02 

plot(x,y)
library(minpack.lm)
lorentzian <- function(par,x){ 
  a  <- par[1]
  b  <- par[2]
  p1 <- par[3]
  p2 <- par[4]
  h1 <- par[5]
  h2 <- par[6]
  drift.a <- par[7]
  drift.b <- par[8]
  h1/(pi*a*(1+((x-p1)/a)^2))+h2/(pi*b*(1+((x-p2)/b)^2)) + drift.a + drift.b*x
}

resid   <- function(par,obs,xx) {obs-lorentzian(par,xx)}
par=c(a=0.001,b=0.001, p1=2.157, p2=2.163, h1=1, h2=1, drift.a=0, drift.b=0)
lower=c(a=0,b=0,p1=0,p2=0,h1=0, h2=0,drift.a=NA,drift.b=NA)
nls.out <- nls.lm(par=par, lower=lower, fn=resid, obs=y, xx=x, 
                  control = nls.lm.control(maxiter=500))
coef(nls.out)
#             a             b            p1            p2            h1            h2       drift.a       drift.b 
#  1.679632e-03  1.879690e-03  2.156308e+00  2.163500e+00  4.318793e-02  8.199394e-02 -9.273083e+02  4.323897e+02 

lines(x,lorentzian(coef(nls.out), x), col=2, lwd=2)