r - 绘制图的切线并使用R查找X截距

Question

对于如下所示的数据框，该数据框的2列可以使用plot(data$x,data$y)绘制绘图，如下所示，我们如何在任意点上绘制一个切线，比如x=25，然后找到带有y=0轴的切线的x截距？

数据:

df <- structure(list(x = c(40, 39.8, 39.5999999999999, 39.3999999999999, 
39.1999999999998, 39, 38.8, 38.5999999999999, 38.3999999999999, 
38.1999999999998, 38, 37.8, 37.5999999999999, 37.3999999999999, 
37.1999999999998, 37, 36.8, 36.5999999999999, 36.3999999999999, 
36.1999999999998, 36, 35.8, 35.5999999999999, 35.3999999999999, 
35.1999999999998, 35, 34.8, 34.5999999999999, 34.3999999999999, 
34.1999999999998, 34, 33.8, 33.5999999999999, 33.3999999999999, 
33.1999999999998, 33, 32.8, 32.5999999999999, 32.3999999999999, 
32.1999999999998, 32, 31.8, 31.5999999999999, 31.3999999999999, 
31.1999999999998, 31, 30.8, 30.5999999999999, 30.3999999999999, 
30.1999999999998, 30, 29.8, 29.5999999999999, 29.3999999999999, 
29.1999999999998, 29, 28.8, 28.5999999999999, 28.3999999999999, 
28.1999999999998, 28, 27.8, 27.5999999999999, 27.3999999999999, 
27.1999999999998, 27, 26.8, 26.5999999999999, 26.3999999999999, 
26.1999999999998, 26, 25.8, 25.5999999999999, 25.3999999999999, 
25.1999999999998, 25, 24.8, 24.5999999999999, 24.3999999999999, 
24.1999999999998, 24, 23.8, 23.5999999999999, 23.3999999999999, 
23.1999999999998, 23, 22.8, 22.5999999999999, 22.3999999999999, 
22.1999999999998, 22, 21.8, 21.5999999999999, 21.3999999999999, 
21.1999999999998, 21, 20.8, 20.5999999999999, 20.3999999999999, 
20.1999999999998, 20, 19.8, 19.5999999999999, 19.3999999999999, 
19.1999999999998, 19, 18.8, 18.5999999999999, 18.3999999999999, 
18.1999999999998, 18, 17.8, 17.5999999999999, 17.3999999999999, 
17.1999999999998, 17, 16.8, 16.5999999999999, 16.3999999999999, 
16.1999999999998, 16, 15.8, 15.5999999999999, 15.3999999999999, 
15.1999999999998, 15, 14.8, 14.5999999999999, 14.3999999999999, 
14.1999999999998, 14, 13.8, 13.5999999999999, 13.3999999999999, 
13.1999999999998, 13, 12.8, 12.5999999999999, 12.3999999999999, 
12.1999999999998, 12, 11.8, 11.5999999999999, 11.3999999999999, 
11.1999999999998, 11, 10.8, 10.5999999999999, 10.3999999999999, 
10.1999999999998, 10, 9.79999999999995, 9.59999999999991, 9.39999999999986, 
9.19999999999982, 9, 8.79999999999995, 8.59999999999991, 8.39999999999986, 
8.19999999999982, 8, 7.79999999999995, 7.59999999999991, 7.39999999999986, 
7.19999999999982, 7, 6.79999999999995, 6.59999999999991, 6.39999999999986, 
6.19999999999982, 6, 5.79999999999995, 5.59999999999991, 5.39999999999986, 
5.19999999999982, 5, 4.79999999999995, 4.59999999999991, 4.39999999999986, 
4.19999999999982, 4, 3.79999999999995, 3.59999999999991, 3.39999999999986, 
3.19999999999982, 3, 2.79999999999995, 2.59999999999991, 2.39999999999986, 
2.19999999999982, 2, 1.79999999999995, 1.59999999999991, 1.39999999999986, 
1.19999999999982, 1, 0.799999999999955, 0.599999999999909, 0.399999999999864, 
0.199999999999818, 0, -0.200000000000045, -0.400000000000091, 
-0.600000000000136, -0.800000000000182, -1, -1.20000000000005, 
-1.40000000000009, -1.60000000000014, -1.80000000000018, -2, 
-2.20000000000005, -2.40000000000009, -2.60000000000014, -2.80000000000018, 
-3, -3.20000000000005, -3.40000000000009, -3.60000000000014, 
-3.80000000000018, -4, -4.20000000000005, -4.40000000000009, 
-4.60000000000014, -4.80000000000018, -5), y = c(35785, 34955.9, 
34448, 33632.6, 32905.1, 31976.5, 31332.4, 30851.3, 29547.2, 
29092, 28786.6, 28053.9, 27609.1, 27117.9, 26628.8, 26236.2, 
25997.6, 25248.5, 24876.7, 24697.4, 24745.8, 24403.1, 23935.2, 
23994.9, 23489, 23596, 23630.8, 23537, 23489.3, 23336.4, 23515.6, 
23373.7, 23191.3, 23455.6, 23510.1, 23653.3, 23574.3, 23504.9, 
23239.2, 22993.1, 23246.4, 23057.4, 22718.7, 22532.4, 22656.7, 
22362.9, 22184, 21929.7, 21511.1, 21579.2, 21692.3, 21839.3, 
21906.5, 22342, 22830.3, 23506.3, 24714.6, 26358.3, 28813.4, 
32087.4, 37048.2, 43795.1, 52583.3, 63510.6, 74687.6, 87307, 
98589.2, 109683, 123260, 143686, 173741, 206937, 225777, 213844, 
188426, 179882, 195311, 213540, 199136, 153434, 102167, 65320.5, 
43524.6, 31564.6, 24683.9, 20481.1, 17533.8, 15430.9, 13942.4, 
12742.8, 11795.2, 11032.4, 10758.8, 9999.94, 9620.13, 9242.19, 
8769.68, 8336.05, 7848.7, 7439.94, 7236.61, 6840.17, 6474.1, 
6314.83, 6119.46, 5984.71, 5838.92, 5482.56, 5592.16, 5479.21, 
5473.05, 5263.42, 5131.52, 5160.8, 5037.07, 5111.43, 4925.95, 
5044.38, 5073.06, 5163.09, 5395.14, 5685.84, 5781.48, 5927.53, 
5991.07, 5918.79, 6208.65, 6355.15, 6336.74, 6866.93, 6765.42, 
7010.48, 6975.84, 7173.03, 7208.73, 7167.87, 7150.69, 7066.63, 
6850.88, 6615.22, 6514.08, 6244.01, 6000.48, 5574.86, 5179.76, 
5093.81, 4797.62, 4561.38, 4378.95, 4480.99, 4454.68, 4528.07, 
4697.9, 4895.49, 5127.23, 5522.48, 5618.13, 5909.07, 6134.77, 
6444.93, 6347.01, 6890.34, 7092.59, 7232.97, 7125.42, 6986.75, 
6699.94, 6458.58, 6257.7, 6080.23, 5982.45, 5692.35, 5829.27, 
5843.41, 6057.06, 6181.98, 6516.04, 6597.08, 6776.47, 6912.55, 
7053.48, 7008.47, 7194.52, 7362.31, 7320.14, 7362.08, 7428.24, 
7096.13, 6704.73, 6217.18, 5835.08, 5424.88, 5640.08, 5687.38, 
5571.61, 5074.32, 4456.51, 3369.23, 2196.51, 1276.21, 756.717, 
484.31, 315.931, 265.893, 190.014, 161.302, 145.354, 126.608, 
90.857, 101.612, 76.3276, 84.7987, 83.5705, 77.3315, 53.2172, 
52.2799, 39.4456, 53.3765, 30.8025, 48.2821, 39.0606, 22.8557, 
34.3351, 25.2945, 25.4592, 21.7338)), .Names = c("x", "y"), class = "data.frame", row.names = c(NA, 
-226L))

Answer 1

这是一个使用拟合样条函数的导数的选项(smooth.spline-您可能需要根据情况调整参数spar):

x <- seq(0,40)
y <- dnorm(seq(0,40), mean=25, sd=5)
plot(x, y)
spl <- smooth.spline(y ~ x)
lines(spl, col=2)

newx <- 20
pred0 <- predict(spl, x=newx, deriv=0)
pred1 <- predict(spl, x=newx, deriv=1)

yint <- pred0$y - (pred1$y*newx)
xint <- -yint/pred1$y
xint

视觉结果:

plot(x, y)
abline(h=0, col=8)
lines(spl, col=2) # spline
points(pred0, col=2, pch=19) # point to predict tangent 
lines(x, yint + pred1$y*x, col=3) # tangent (1st deriv. of spline at newx)
points(xint, 0, col=3, pch=19) # x intercept

更新
这是使用您的数据集( df)的示例:

# fit smooth spline
plot(y ~ x, df)
spl <- smooth.spline(df$x, df$y, spar=0.3)
newx <- seq(min(df$x), max(df$x), 0.1)
pred <- predict(spl, x=newx, deriv=0)
lines(pred, col=2)

# solve for tangent at a given x
newx <- 25
pred0 <- predict(spl, x=newx, deriv=0)
pred1 <- predict(spl, x=newx, deriv=1)
yint <- pred0$y - (pred1$y*newx)
xint <- -yint/pred1$y
xint

# plot results
plot(y ~ x, df)
abline(h=0, col=8)
lines(spl, col=2) # spline
points(pred0, col=2, pch=19) # point to predict tangent 
lines(x, yint + pred1$y*x, col=3) # tangent (1st deriv. of spline at newx)
points(xint, 0, col=3, pch=19) # x intercept

我不确定您的数据中有多少噪音，但是通过在 spar中使用较小的 smooth.spline设置，您可以增加拟合函数的细节。