Identify all local extrema of a fitted smoothing spline via R function 'smooth.spline'

问题

I have a 2-dimensional data set.

I use the R's smooth.spline function to smooth my points graph following an example in this article:

https://stat.ethz.ch/R-manual/R-devel/library/stats/html/predict.smooth.spline.html

So that I get the spline graph similar to the green line on this picture

I'd like to know the X values, where the first derivative of the smoothing spline equals zero (to determine exact minimum or maximum).

My problem is that my initial dataset (or a dataset that I could auto-generate) to feed into the predict() function does not contain such exact X values that correspond to the smoothing spline extrema.

How can I find such X values?

Here is the picture of the first derivative of the green spline line above

But exact X coordinate of extremums are still not exact.

My approximate R script to generate the pictures looks like the following

sp1 <- smooth.spline(df)

pred.prime <- predict(sp1, deriv=1)
pred.second <- predict(sp1, deriv=2)

d1 <- data.frame(pred.prime)
d2 <- data.frame(pred.second)

dfMinimums <- d1[abs(d1$y) < 1e-4, c('x','y')]

回答1:

I think that there are two problems here.

You are using the original x-values and they are spaced too far apart AND
Because of the wide spacing of the x's, your threshold for where you consider the derivative "close enough" to zero is too high.

Here is basically your code but with many more x values and requiring smaller derivatives. Since you do not provide any data, I made a coarse approximation to it that should suffice for illustration.

## Coarse approximation of your data
x = runif(300, 0,45000)
y = sin(x/5000) + sin(x/950)/4 + rnorm(300, 0,0.05) 
df = data.frame(x,y)
sp1 <- smooth.spline(df)

Spline code

Sx = seq(0,45000,10)
pred.spline <- predict(sp1, Sx)
d0 <- data.frame(pred.spline)
pred.prime <- predict(sp1, Sx, deriv=1)
d1 <- data.frame(pred.prime)

Mins = which(abs(d1$y) < mean(abs(d1$y))/150)

plot(df, pch=20, col="navy")
lines(sp1, col="darkgreen")
points(d0[Mins,], pch=20, col="red")

The extrema look pretty good.

plot(d1, type="l")
points(d1[Mins,], pch=20, col="red")

The points identified look like zeros of the derivative.

回答2:

You can use my R package SplinesUtils: https://github.com/ZheyuanLi/SplinesUtils, which can be installed by

devtools::install_github("ZheyuanLi/SplinesUtils")

The function to be used are SmoothSplinesAsPiecePoly and solve. I will just use the example under the documentation.

library(SplinesUtils)

## a toy dataset
set.seed(0)
x <- 1:100 + runif(100, -0.1, 0.1)
y <- poly(x, 9) %*% rnorm(9)
y <- y + rnorm(length(y), 0, 0.2 * sd(y))

## fit a smoothing spline
sm <- smooth.spline(x, y)

## coerce "smooth.spline" object to "PiecePoly" object
oo <- SmoothSplineAsPiecePoly(sm)

## plot the spline
plot(oo)

## find all stationary / saddle points
xs <- solve(oo, deriv = 1)
#[1]  3.791103 15.957159 21.918534 23.034192 25.958486 39.799999 58.627431
#[8] 74.583000 87.049227 96.544430

## predict the "PiecePoly" at stationary / saddle points
ys <- predict(oo, xs)
#[1] -0.92224176  0.38751847  0.09951236  0.10764884  0.05960727  0.52068566
#[7] -0.51029209  0.15989592 -0.36464409  0.63471723
points(xs, ys, pch = 19)

回答3:

One caveat in the @G5W implementation that I found is that it sometimes returns multiple records close around extrema instead of a single one. On the diagram they cannot be seen, since they all fall into one point effectively.

The following snippet from here filters out single extrema points with the minimum value of the first derivative:

library(tidyverse)
df2 <- df  %>%
  group_by(round(y, 4)) %>% 
  filter(abs(d1) == min(abs(d1))) %>% 
  ungroup() %>% 
  select(-5)

来源：https://stackoverflow.com/questions/48720040/identify-all-local-extrema-of-a-fitted-smoothing-spline-via-r-function-smooth-s

标签

spline

smoothing