R 给定y值获取x值：线性/非线性插值函数的通用根查找

我对插值函数的一般求根问题感兴趣

假设我有以下

（x，y）

数据：

set.seed(0)
x <- 1:10 + runif(10, -0.1, 0.1)
y <- rnorm(10, 3, 1)

我知道之前关于这个话题的一些帖子，比如

建议我们简单地反转

x

和

y

，对

（y，x）

进行插值，并计算

y=y0处的插值

然而，这是一个虚假的想法。假设
y=f（x）
是
（x，y）
的插值函数，只有当
f（x）
是
x
的单调函数时，这个想法才有效，因此
f
是可逆的。否则
x
不是
y
的函数，插值
（y，x）
没有意义

以我的示例数据为例进行线性插值，这个伪想法给出了

fake_root <- approx(y, x, 2.85)[[2]]
# [1] 6.565559

不是2.85

我第一次尝试解决这个一般问题是在。该解对于线性插值是稳定的，但对于非线性插值不一定稳定。我现在正在寻找一个稳定的解决方案，特别是三次插值样条


解决方案如何在实践中有用？
有时在一个单变量线性回归
y~x
或一个单变量非线性回归
y~f（x）
之后，我们想要对目标
y
进行反解
x
。这个问答就是一个例子，它吸引了很多答案，但没有一个是真正适合的或易于在实践中使用的


使用
polyroot
的公认答案仅适用于简单多项式回归
对于解析解，使用二次公式的答案仅适用于二次多项式
我的答案是使用
predict
和
uniroot
通常有效，但并不方便，因为在实践中使用
uniroot
需要与用户交互（有关
uniroot
的更多信息，请参阅）

如果有一个自适应且易于使用的解决方案，那就太好了。
首先，让我复制中提出的线性插值的稳定解决方案

RootSpline3 <- function (f, y0 = 0, verbose = TRUE) {
  ## extract piecewise construction info
  info <- environment(f)$z
  n_pieces <- info$n - 1L
  x <- info$x; y <- info$y
  b <- info$b; c <- info$c; d <- info$d
  ## list of roots on each piece
  xr <- vector("list", n_pieces)
  ## loop through pieces
  i <- 1L
  while (i <= n_pieces) {
    ## complex roots
    croots <- polyroot(c(y[i] - y0, b[i], c[i], d[i]))
    ## real roots (be careful when testing 0 for floating point numbers)
    rroots <- Re(croots)[round(Im(croots), 10) == 0]
    ## the parametrization is for (x - x[i]), so need to shift the roots
    rroots <- rroots + x[i]
    ## real roots in (x[i], x[i + 1])
    xr[[i]] <- rroots[(rroots >= x[i]) & (rroots <= x[i + 1])]
    ## next piece
    i <- i + 1L
    }
  ## collapse list to atomic vector
  xr <- unlist(xr)
  ## make a plot?
  if (verbose) {
    curve(f, from = x[1], to = x[n_pieces + 1], xlab = "x", ylab = "f(x)")
    abline(h = y0, lty = 2)
    points(xr, rep.int(y0, length(xr)))
    }
  ## return roots
  xr
  }

它分段使用
polyroot
，首先在复数域上找到所有根，然后在分段区间上只保留实根。这是因为三次插值样条曲线只是一系列分段三次多项式。我在上的回答说明了如何获得分段多项式系数，因此使用
多根
非常简单

使用问题中的示例数据，
RootSpline1
和
RootSpline3
正确识别所有根

par(mfrow = c(1, 2))
RootSpline1(x, y, 2.85)
#[1] 3.495375 6.606465
RootSpline3(f3, 2.85)
#[1] 3.924512 6.435812 9.207171 9.886640

给定上述数据点和样条函数，只需应用pracma软件包中的
findzeros（）

库（pracma）
xs在我的R包中，
RootSpline3
函数已增强为
solve
：
SplinesUtils
：。通过
devtools:：install_github（“ZheyuanLi/SplinesUtils”）
pracma:：findzeros
和
rootSolve:：uniroot获得它。所有的
都有相同的逻辑：将区间划分为多个子区间，在每个区间上找到根，然后组合这些结果。对于样条函数，节点自然地将函数分割成若干部分，避免任何人为细分。此外，SplineUtils
中的
solve
函数也可以求解导数，基本上可以找到样条曲线的所有极值@李哲源  当样条线仅接触到
y=y0
线（未与之相交）时，函数
RootSpline3
似乎找不到根。例如，请参见
RootSpline3（f3，5.40650874247）
，它返回
数值（0）
，而
f3（5.10264982141）
等于此值（由
findzeros
找到）。当然，此示例是人为的，但可能会发生样条线接触到
y0=2.0
并搜索反向值的情况。出现了一些舍入错误，并且
base:：polyroot
无法以良好的精度返回根。需要一些时间来理解
polyroot
的行为，以找到修复方法。
f1(fake_root)
#[1] 2.906103

## given (x, y) data, find x where the linear interpolation crosses y = y0
## the default value y0 = 0 implies root finding
## since linear interpolation is just a linear spline interpolation
## the function is named RootSpline1
RootSpline1 <- function (x, y, y0 = 0, verbose = TRUE) {
  if (is.unsorted(x)) {
     ind <- order(x)
     x <- x[ind]; y <- y[ind]
     }
  z <- y - y0
  ## which piecewise linear segment crosses zero?
  k <- which(z[-1] * z[-length(z)] <= 0)
  ## analytical root finding
  xr <- x[k] - z[k] * (x[k + 1] - x[k]) / (z[k + 1] - z[k])
  ## make a plot?
  if (verbose) {
    plot(x, y, "l"); abline(h = y0, lty = 2)
    points(xr, rep.int(y0, length(xr)))
    }
  ## return roots
  xr
  }

RootSpline3 <- function (f, y0 = 0, verbose = TRUE) {
  ## extract piecewise construction info
  info <- environment(f)$z
  n_pieces <- info$n - 1L
  x <- info$x; y <- info$y
  b <- info$b; c <- info$c; d <- info$d
  ## list of roots on each piece
  xr <- vector("list", n_pieces)
  ## loop through pieces
  i <- 1L
  while (i <= n_pieces) {
    ## complex roots
    croots <- polyroot(c(y[i] - y0, b[i], c[i], d[i]))
    ## real roots (be careful when testing 0 for floating point numbers)
    rroots <- Re(croots)[round(Im(croots), 10) == 0]
    ## the parametrization is for (x - x[i]), so need to shift the roots
    rroots <- rroots + x[i]
    ## real roots in (x[i], x[i + 1])
    xr[[i]] <- rroots[(rroots >= x[i]) & (rroots <= x[i + 1])]
    ## next piece
    i <- i + 1L
    }
  ## collapse list to atomic vector
  xr <- unlist(xr)
  ## make a plot?
  if (verbose) {
    curve(f, from = x[1], to = x[n_pieces + 1], xlab = "x", ylab = "f(x)")
    abline(h = y0, lty = 2)
    points(xr, rep.int(y0, length(xr)))
    }
  ## return roots
  xr
  }

par(mfrow = c(1, 2))
RootSpline1(x, y, 2.85)
#[1] 3.495375 6.606465
RootSpline3(f3, 2.85)
#[1] 3.924512 6.435812 9.207171 9.886640

library(pracma)
xs <- findzeros(function(x) f3(x) - 2.85,min(x), max(x))

xs  # [1] 3.924513 6.435812 9.207169 9.886618
points(xs, f3(xs))