强制nls拟合通过指定点的曲线

Question

我正在尝试将Boltzmann sigmoid 1/(1+exp((x-p1)/p2))拟合到这个小的实验数据集中：

xdata <- c(-60,-50,-40,-30,-20,-10,-0,10)
ydata <- c(0.04, 0.09, 0.38, 0.63, 0.79, 1, 0.83, 0.56)

我知道这样做非常简单。例如，使用nls：

fit <-nls(ydata ~ 1/(1+exp((xdata-p1)/p2)),start=list(p1=mean(xdata),p2=-5))

我得到以下结果：

Formula: ydata ~ 1/(1 + exp((xdata - p1)/p2))

Parameters:
   Estimate Std. Error t value Pr(>|t|)    
p1  -33.671      4.755  -7.081 0.000398 ***
p2  -10.336      4.312  -2.397 0.053490 .  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.1904 on 6 degrees of freedom

Number of iterations to convergence: 13 
Achieved convergence tolerance: 7.079e-06

然而，我需要（由于理论上的原因）拟合曲线准确地通过点(-70, 0)。虽然上面所示的拟合表达式的值在x = -70处接近零，但它并不完全为零，这不是我想要的。

所以，问题是：有没有办法告诉nls（或其他一些函数）适合相同的表达式，但强制它通过指定的点？

更新

正如评论中提到的那样，在数学上不可能使用我提供的函数（Boltzmann sigmoid）强制拟合通过点（-70,0）。另一方面，@ Cleb和@BenBolker已经解释了如何强制拟合通过任何其他点，例如（-50,0.09）。

Answer 1

如我们在您的问题下面的评论中所讨论的那样，不可能使用您提供的功能（没有偏移）强制拟合通过0。

但是，您可以通过为各个数据点设置weights来强制曲线通过其他数据点。所以例如如果你给一个数据点A一个权重等于1而一个数据点B一个权重等于1000，那么数据点B对于拟合更为重要（就残差总和的贡献而言）因此，契约将被迫通过B.

以下是整个代码，我将在下面详细解释：

# your data
xdata <- c(-60, -50, -40, -30, -20, -10, -0, 10)
ydata <- c(0.04, 0.09, 0.38, 0.63, 0.79, 1, 0.83, 0.56)
plot(xdata, ydata, ylim=c(0, 1.1))
fit <-nls(ydata ~ 1 / (1 + exp((xdata - p1) / p2)), start=list(p1=mean(xdata), p2=-5))

# plot the fit
xr = data.frame(xdata = seq(min(xdata), max(xdata), len=200))
lines(xr$xdata, predict(fit, newdata=xr))

# set all weights to 1, do the fit again; the plot looks identical to the previous one
we = rep(1, length(xdata))
fit2 = nls(ydata ~ 1 / (1 + exp((xdata - p1) / p2)), weights=we, start=list(p1=mean(xdata) ,p2=-5))
lines(xr$xdata, predict(fit2, newdata=xr), col='blue')

# set weight for the data point -30,0.38, and fit again
we[3] = 1000
fit3 = nls(ydata ~ 1 / (1 + exp((xdata - p1) / p2)), weights=we, start=list(p1=mean(xdata), p2=-5))
lines(xr$xdata, predict(fit3, newdata=xr), col='red')
legend('topleft', c('fit without weights', 'fit with weights 1', 'weighted fit for -40,0.38'), 
       lty=c(1, 1, 1),
       lwd=c(2.5, 2.5, 2.5),
       col=c('black', 'blue', 'red'))

输出如下;如你所见，拟合现在通过所需的数据点（红线）：

所以发生了什么：我首先适合你，然后我适合权重，所有权重都设置为1;因此，该图看起来与之前的图相同，蓝线隐藏黑线。然后 - 对于fit3 - 我将第三个数据点的权重更改为1000，这意味着它现在更加重要＆＃34;对于最小二乘拟合而不是其他点，新拟合遍历此数据点（红线）。

这是我改变第<

行的第二个例子

we[3] = 1000

到

we[2] = 1000

强制拟合通过第二个数据点：

如果您想了解有关weights参数的更多信息，请参阅此处：documentation

Answer 2

在@ Cleb的答案的基础上，这是一种选择函数必须通过的指定点并解决其中一个参数的结果等式的方法：

dd <- data.frame(x=c(-60,-50,-40,-30,-20,-10,-0,10),
                 y=c(0.04, 0.09, 0.38, 0.63, 0.79, 1, 0.83, 0.56))

初始拟合（为方便起见，使用plogis()而不是1/(1+exp(-...))）：

fit <- nls(y ~ plogis(-(x-p1)/p2),
           data=dd,
           start=list(p1=mean(dd$x),p2=-5))

现在插入(x3,y3)并解决p2：

y3 = 1/(1+exp((x-p1)/p2))
logit(x) = qlogis(-x) = log(x/(1-x))
e.g. plogis(2)=0.88 -> qlogis(0.88)=2
qlogis(y3) = -(x-p1)/p2
p2 = -(x3-p1)/qlogis(y3)

设置一个功能并将其插入p2：

p2 <- function(p1,x,y) {
    -(x-p1)/qlogis(y)
}
fit2 <- nls(y ~ plogis(-(x-p1)/p2(p1,dd$x[3],dd$y[3])),
    data=dd,
    start=list(p1=mean(dd$x)))

绘制结果：

plot(y~x,data=dd,ylim=c(0,1.1))
xr <- data.frame(x = seq(min(dd$x),max(dd$x),len=200))
lines(xr$x,predict(fit,newdata=xr))
lines(xr$x,predict(fit2,newdata=xr),col=2)