“拟合曲线”；大约；R中的数据点

我有一个由点集合组成的数据集。这些点在平面上的分布方式使得它们可以大致以抛物线为边界。我试图找到一种方法，将抛物线拟合到点的边界上

这就是我目前的情况：

a = 1
b = 2
c = 3

parabola <- function(x) {
    a * x^2 + b * x + c
}

N = 10000

x <- runif(N, -4, 3)
y <- runif(N, 0, 10)

data <- data.frame(x, y)

data <- subset(data, y >= parabola(x))

plot(data, xlim = c(-5, 5), ylim = c(0, 10), col = "grey")

fr <- function(x) {
    PAR = x[1] * data$x^2 + x[2] * data$x + x[3]
    #
    sum((PAR - data$y)^2 + 100 * plogis(PAR - data$y, scale = 0.00001))
}

par = optim(c(0, 0, 0), fr)$par

a = par[1]
b = par[2]
c = par[3]

curve(parabola, add = TRUE, lty = "dashed")

a=1
b=2
c=3
抛物线我不能提供一个完整的答案。我唯一的特别想法是为优化算法提供更好的起点——希望你更接近你试图优化的函数的局部最小值

估算粗略的第一个版本相当简单。如果你把抛物线写成
b*（x-a）^2+c
你可以估计

a <- data$x[which.min(data$y)]
c <- min(data$y)
 
b1 <- (data$y[which.min(data$x)] - c) / (min(data$x) - a)^2
b2 <- (data$y[which.max(data$x)] - c) / (max(data$x) - a)^2
b <- mean(c(b1, b2))

（请原谅那些笨拙的乳胶书写公式，有时候只是更好而已）

现在，抛物线下的惩罚点可以用惩罚函数来完成，比如

\lambda (ax_i^2+bx_i+c - y_i)^2 if below parabola, 0 otherwise

从时间间隔中减去该函数应该会得到一个合适、平滑的目标函数。尽可能简化函数似乎比使用最小二乘法更好，最小二乘法试图拟合数据点中间的直线

不过，您仍然需要选择合适的lambda。但这是典型的：您需要在两个不同的目标（拟合数据、最大化抛物线）之间进行折衷。哪一个更重要的权重必须由您提交。
进一步感谢thilo提出了非常有用的建议并纠正了我的幼稚想法。根据thilo的建议，使用抛物线下的面积和合适的惩罚函数，下面的解决方案似乎有效。我也改为L-BFGS-B优化，因为它在小N时表现更好

parabola.objective <- function(p) {
    d = p[2] * (data$x - p[1])^2 + p[3] - data$y
    #
    area <- function(x) {
        p[2] / 3 * (x - p[1])^3 + p[3] * x
    }
    #
    sum(- area(max(data$x)) + area(min(data$x)) + 100 * ifelse(d > 0, d^2, 0))
}

A <- data$x[which.min(data$y)]
C <- min(data$y)

B1 <- (data$y[which.min(data$x)] - C) / (min(data$x) - A)^2
B2 <- (data$y[which.max(data$x)] - C) / (max(data$x) - A)^2
B <- mean(c(B1, B2))

# the key to getting this working with a small number of points is the
# optimisation method: BFGS works well with around 300 points or more
# but L-BFGS-B seems to perform better down to around 100 points.
#
O = optim(c(A, B, C), parabola.objective, method="L-BFGS-B")

par = O$par

A = par[1]
B = par[2]
C = par[3]

curve(parabola, add = TRUE, lty = "dashed")

parapola.objective
optim
中的默认算法不是很好。尝试指定
method=“BFGS”
或
method=“L-BFGS-B”
。设置随机数种子以获得问题的可重现示例。如果我设置.seed（999）
并运行您的代码，这是一个错误匹配的示例吗？给了我们一些可以合作的东西！在这种情况下，
method=“BFGS”
会产生更好的拟合效果……是的，准确地说：种子数为999时失败，但种子数为1时效果很好。谢谢，thilo，是的，这确实非常有效。从合适的参数值开始的想法是完全有意义的！我唯一剩下的问题是，目标函数感觉有点特别。我知道这是可行的，但我想相信一定有更好的解决方案，不依赖于任意的调谐参数100和0.00001。另一个小障碍：如果减少拟合的点数，那么性能会明显下降。设置N=100并使用969进行种子设定将说明此效果：许多点现在落在抛物线之外。我认为问题归结为如何使抛物线以外的点的惩罚相当严重，但不会严重到完全淹没平方误差项。最后，不，解决方案需要在自动化的基础上工作。我担心类似的事情-自动化算法通常更难开发，由于您可能总是遇到一些您没有想到的边界情况。。。我会用早餐时的想法编辑我的答案；）我得承认我有点惊讶。使用优化方法，拟合远大于给定点的抛物线应产生相同的目标函数值。我能想象的唯一原因是，起始值通常拟合一条“非常小”的抛物线，而优化恰好击中一个接近最佳拟合的函数。我仍然建议在大抛物线上增加一些惩罚项（即使它只是
+p[3]+c*p[2]
，这就足够了）hi thilo，你说得很对。这确实适用于我的示例代码生成的所有漂亮、整洁的“测试”案例。但当我把它带到现实世界时，它坏得可怕。我真是太天真了，以为这会奏效。如果初始抛物线开始于数据点之间，则该目标函数似乎产生了合理的结果。否则，它将惨败。所以你的惊喜是完全有道理的，我感到很谦卑。
\lambda (ax_i^2+bx_i+c - y_i)^2 if below parabola, 0 otherwise

parabola.objective <- function(p) {
    d = p[2] * (data$x - p[1])^2 + p[3] - data$y
    #
    area <- function(x) {
        p[2] / 3 * (x - p[1])^3 + p[3] * x
    }
    #
    sum(- area(max(data$x)) + area(min(data$x)) + 100 * ifelse(d > 0, d^2, 0))
}

A <- data$x[which.min(data$y)]
C <- min(data$y)

B1 <- (data$y[which.min(data$x)] - C) / (min(data$x) - A)^2
B2 <- (data$y[which.max(data$x)] - C) / (max(data$x) - A)^2
B <- mean(c(B1, B2))

# the key to getting this working with a small number of points is the
# optimisation method: BFGS works well with around 300 points or more
# but L-BFGS-B seems to perform better down to around 100 points.
#
O = optim(c(A, B, C), parabola.objective, method="L-BFGS-B")

par = O$par

A = par[1]
B = par[2]
C = par[3]

curve(parabola, add = TRUE, lty = "dashed")