Решите оптимальные полиномиальные и графические вырезы

Ответ 1

Вы можете использовать квадратичную формулу для вычисления значений:

betas <- coef(fit2)    # get coefficients
betas[1] <- betas[1] - 4    # adjust intercept to look for values where y = 4

# note degree increases, so betas[1] is c, etc.
betas
##             (Intercept) poly(x, 2, raw = TRUE)1 poly(x, 2, raw = TRUE)2 
##               8.7555833               6.0807302               0.7319848 

solns <- c((-betas[2] + sqrt(betas[2]^2 - 4 * betas[3] * betas[1])) / (2 * betas[3]), 
           (-betas[2] - sqrt(betas[2]^2 - 4 * betas[3] * betas[1])) / (2 * betas[3]))

solns
## poly(x, 2, raw = TRUE)1 poly(x, 2, raw = TRUE)1 
##               -1.853398               -6.453783 

segments(solns, -1, solns, 4, col = 'green')    # add segments to graph

Гораздо проще (если вы его найдете) polyroot:

polyroot(betas)
## [1] -1.853398+0i -6.453783+0i

Так как он возвращает сложный вектор, вам нужно обернуть его в as.numeric, если вы хотите передать его в segments.

Ответ 2

Я абсолютно понимаю, что существует аналитическое решение для этого простого квадратичного многочлена. Причина, по которой я показываю вам численное решение, заключается в том, что вы задаете этот вопрос в настройке регрессии. Численное решение всегда может быть вашим решением в целом, когда у вас более сложная кривая регрессии.

В дальнейшем я буду использовать функцию uniroot. Если вы не знакомы с этим, сначала прочтите этот короткий ответ: Решение Uniroot в R.

Это сюжет, созданный с помощью вашего кода. Вы почти там. Это проблема поиска корней, и вы можете численно использовать uniroot. Пусть определим функцию:

f <- function (x) {
  ## subtract 4
  predict(fit2, newdata = data.frame(x = x)) - 4
  }

Из рисунка видно, что есть два корня, один внутри [-7, -6], другой внутри [-3, -1]. Мы используем uniroot для поиска обоих:

x1 <- uniroot(f, c(-7, -6))$root
#[1] -6.453769

x2 <- uniroot(f, c(-3, -1))$root
#[1] -1.853406

Теперь вы можете отбросить вертикальную линию от этих точек до оси x:

y1 <- f(x1) + 4  ## add 4 back
y2 <- f(x2) + 4  

abline(h = 0, col = 4)  ## x-axis
segments(x1, 0, x1, y1, lty = 2)
segments(x2, 0, x2, y2, lty = 2)

Ответ 3

У вас есть квадратичное уравнение

0.73198 * x^2 + 6.08073 * x + 12.75558 = 4
OR
0.73198 * x^2 + 6.08073 * x + 8.75558 = 0

Вы можете просто использовать квадратичную формулу для ее решения аналитически. R дает два корня:

(-6.08073 + sqrt(6.08073^2 -4*0.73198 * 8.75558)) / (2 * 0.73198)
[1] -1.853392
(-6.08073 - sqrt(6.08073^2 -4*0.73198 * 8.75558)) / (2 * 0.73198)
[1] -6.453843

abline (v = c (-1.853392, -6.453843))

Ответ 4

Вот еще одно решение, основанное на этом

attach(v1)
fit2 = lm(y~poly(x,2,raw=TRUE))
xx = seq(-8,0, length=50)

vector1 = predict(fit2, data.frame(x=xx)) 
vector2= replicate(length(vector1),4)

# Find points where vector1 is above vector2.
above = vector1 > vector2

# Points always intersect when above=TRUE, then FALSE or reverse
intersect.points = which(diff(above)!=0)    

# Find the slopes for each line segment.
vector1.slopes = vector1[intersect.points+1] - vector1[intersect.points]
vector2.slopes = vector2[intersect.points+1] - vector2[intersect.points]

# Find the intersection for each segment.
x.points = intersect.points + ((vector2[intersect.points] - vector1[intersect.points]) / (vector1.slopes-vector2.slopes))
y.points = vector1[intersect.points] + (vector1.slopes*(x.points-intersect.points))

#Scale x.points to the axis value of xx
x.points = xx[1] + ((x.points - 1)/(49))*(xx[50]-xx[1])

plot(xx, y = vector1, type= "l", col = "blue")
points(x,y,pch = 20)
lines(x = c(x.points[1],x.points[1]), y = c(0,y.points[1]), col='red')
lines(x = c(x.points[2],x.points[2]), y = c(0,y.points[2]), col='red')

Ответ 5

Многие решения уже предложены, вот еще один.

Как очевидно, нам интересно найти значения x, которые удовлетворяют многочленному (квадратичному) уравнению a_0 + a_1.x + a_2.x^2 = 4, где a_0, a_1, a_2 - коэффициенты установленного многочлена. Мы можем переписать уравнение как стандартное квадратичное уравнение ax^2+bx+c=0 и найти корни, используя формулу Sridhar's, используя коэффициенты подогнанного многочлена с полиномиальной регрессией следующим образом:

a <- fit2$coefficients[3]
b <- fit2$coefficients[2]
c <- fit2$coefficients[1] - 4

as.numeric((-b + sqrt(b^2-4*a*c)) / (2*a))
#[1] -1.853398
as.numeric((-b-+ sqrt(b^2-4*a*c)) / (2*a))
#[1] -6.453783

Мы можем использовать некоторые числовые методы, такие как Newton-Raphson, чтобы найти корни (хотя существуют более быстрые численные методы, но это решит нашу цель, и это довольно быстро, принимает ~160 ms на моей машине), так как мы можно видеть из следующего кода, согласуются численные и теоретические решения.

a <- fit2$coefficients  # fitted quadratic polynomial coefficients

f <- function(x) {
  as.numeric(a[1] + a[2]*x + a[3]*x^2-4)
}

df <- function(x) {
  as.numeric(a[2] + 2*a[3]*x)
} 

Newton.Raphson <- function(x0) {
  eps <- 1e-6
  x <- x0
  while(TRUE) {
    x <- x0 - f(x0) / df(x0)
    if (abs(x - x0) < eps) {
      return(x0)
    }
    x0 <- x
  }
}

t1 <- Sys.time()
x1 <- Newton.Raphson(-10)
x2 <- Newton.Raphson(10)
x1
#[1] -6.453783
x2
#[1] -1.853398
s2
print(paste('time taken to compute the roots:' ,Sys.time() - t1))
#[1] "time taken to compute the roots: 0.0160109996795654"
points(x1, 4, pch=19, col='green')
points(x2, 4, pch=19, col='green')
abline(v=x1, col='green')
abline(v=x2, col='green')