Reputation: 23
df <- structure(list(X = c(92.4521,92.0254,91.5875,91.1383,90.678,90.2065,89.724,89.2305,88.7261,88.2108,87.6848,87.1481,86.6007,86.0429,85.4745,84.8959,84.3069,83.7078,83.0986,82.4795,81.8505,81.2118,80.5635,79.9056,79.2384,78.5619,77.8763,77.1818,76.4783,75.7662,75.0456,74.3165,73.5792,72.8338,72.0805,71.3195,70.5509,69.775),
Y = c(1181,1165.75,1149.98,1134.28,1117.82,1101.02,1083.57,1066.03,1048.63,1031.61,1014.47,997.856,981.415,965.633,949.894,934.635,919.485,904.537,890.024,875.757,862.089,849.174,839.817,832.383,827.669,822.792,820.797,821.44,823.974,824.072,823.151,822.334,822.993,823.691,822.498,821.435,821.255,822.094)), .Names = c("X",
"Y"), row.names = c(NA, 35L), class = "data.frame")
NEW SAMPLE: df <- structure(list(X =c(29.882,30.7231,31.5696,32.421,33.2772,34.1377,35.0024,35.8707,36.7425,37.6173,38.495,39.3751,40.2573,41.1414,42.027,42.9139,43.8016,44.6899,45.5786,46.4672,47.3555,48.2432,49.13,50.0157,50.8999,51.7823,52.6627,53.5408,54.4163,55.2889,56.1585,57.0246,57.8872,58.7458,59.6003,60.4504,61.2958,62.1364,62.9719,63.8021,64.6267,65.4456,66.2584,67.065,67.8653,68.6589,69.4457,70.2254,70.998,71.7632,72.5208,73.2707,74.0127,74.7465,75.4721,76.1894,76.898,77.5979,78.289,78.971,79.6439),
Y=c(1838.24,1817.44,1798.18,1776.34,1760.32,1741.34,1721.79,1706.63,1686.31,1666.29,1651.03,1636.91,1614.5,1601.82,1583.12,1565.48,1552.13,1536.49,1517.7,1505.78,1490.81,1476.41,1462.29,1448.08,1433.3,1419.57,1406.5,1392.96,1381.04,1367.88,1352.04,1342.79,1331.16,1319.14,1309.03,1299.02,1287.77,1277.08,1266.59,1255.53,1252.38,1249.62,1244.66,1239.03,1247.43,1244.37,1236.36,1246.38,1245.14,1237.98,1245.9,1251.24,1246.57,1249.62,1255.63,1252.48,1257.25,1259.82,1256.1,1259.35,1263.26)), .Names = c("X","Y"), row.names = c(NA, 60L), class = "data.frame")
I am looking for suggestions on how I can find the x-value corresponding to the point where the graph almost flattens out (shown using arrow). I was thinking about rate of change of y-value or slope and find the first max but not sure how to define the first max. TIA
Upvotes: 1
Views: 69
Reputation: 73437
You could fit a small poly
nomial model and look where the slope of the tangent (i.e. the derivative) exceeds the abs
olute value of the minimum. Here I show the second degree, but you could also try higher degree polynomials.
cf <- lm(Y ~ poly(X, 2, raw=T), df)$coefficients
d <- cf[2] + 2*cf[3]*df$X ## derivative
p <- df$X[which(d > abs(min(d)))[1]]
p
# [1] 79.9056
plot(df, type="p")
curve(cf[1] + cf[2]*x^1 + cf[3]*x^2, add=T, col=3)
abline(v=p, col=2)
legend("topleft", legend=c("polyn. fit", "changepoint"), lty=1, col=3:2, cex=.9)
Upvotes: 1
Reputation: 3888
All you need to is calculate the rate of change which is basically diff(Y)/diff(X)
:
df <- structure(list(X = c(92.4521,92.0254,91.5875,91.1383,90.678,90.2065,89.724,89.2305,88.7261,88.2108,87.6848,87.1481,86.6007,86.0429,85.4745,84.8959,84.3069,83.7078,83.0986,82.4795,81.8505,81.2118,80.5635,79.9056,79.2384,78.5619,77.8763,77.1818,76.4783,75.7662,75.0456,74.3165,73.5792,72.8338,72.0805,71.3195,70.5509,69.775),
Y = c(1181,1165.75,1149.98,1134.28,1117.82,1101.02,1083.57,1066.03,1048.63,1031.61,1014.47,997.856,981.415,965.633,949.894,934.635,919.485,904.537,890.024,875.757,862.089,849.174,839.817,832.383,827.669,822.792,820.797,821.44,823.974,824.072,823.151,822.334,822.993,823.691,822.498,821.435,821.255,822.094)), .Names = c("X",
"Y"), row.names = c(NA, 38L), class = "data.frame")
library(data.table)
setDT(df)
# first [] calculate rate of change
# pick only the rows where the rate.of.change is superior to cst*lead(rate.of.change)
# cst=2.1
# then get the maximum
df[, df:=c(diff(Y)/diff(X),NA)][which(df>shift(2.1*df,type="lead")), ][which.max(df)]
# X Y df
#1: 79.2384 827.669 7.209165
Upvotes: 0