Find abrupt slopes in data

Question

I have a high-resolution vertical profile of a pavement surface with X and Y coordinates and I'm looking for abrupt increases in Y which could be attributed to a trip hazard (classed as a 6 mm increase). I'm using the findpeaks command in pracma but it's not doing what I want (or I'm not using it properly). What I need to do is detect increases in Y of at least 6 mm over a specified distance of X, let's say 100 mm for this example, and to record the maximum value of Y over the increase. Essentially the highest point of the 'trip hazard'.

here's the data (units are mm for X and Y )

    x <- seq (0, 2080, by = 10)

y<- c(1.21, 1.67,   2.10,   2.50,   2.88,   3.24,   3.56,   3.85,   4.11,   4.33,   4.53,   4.70,   4.84,   4.94,   4.99,   4.98,   4.95,   4.95,   4.91,   4.82,   4.80,   4.95,   5.20,   5.39,   5.44,   5.44,   5.48,   5.58,   5.73,
5.93,   6.17,   6.60,   7.13,   7.45,   7.52,   7.53,   7.49,   7.11,   6.46,   6.03,   6.01,   6.16,   6.38,   6.57,   6.78,   7.05,   7.22,   7.14,   6.94,   6.82,   6.80,   6.79,   6.79,   6.86,   7.01,   7.17,   7.26,   7.26,   
7.21,   7.14,   7.13,   7.13,   7.04,   6.89,   6.72,   6.43,   5.90,   5.17,   4.42,   3.80,   3.30,   2.81,   2.38,   2.01,   1.69,   1.45,   1.29,   1.20,   1.17,   1.25,   1.44,   1.65,   1.80,   1.94,   2.11,   2.24,   2.19,   
2.04,   1.97,   2.05,   2.17,   2.29,   2.39,   2.50,   2.61,   2.70,   2.69,   2.62,   2.61,   2.71,   2.84,   2.97,   3.20,   3.50,   3.71,   3.79,   3.80,   3.77,   3.73,   3.67,   3.60,   3.52,   3.40,   3.24,   3.12,   3.10,   
3.14,   3.13,   3.06,   2.96,   2.83,   2.65,   2.32,   1.90,   1.64,   1.62, 1.66, 1.71,   1.85,   2.11,   2.30,   2.37,   2.42,   2.47,   2.53,   2.56,   2.56,   2.59,   2.83,   3.19,   3.43,   3.43,   3.33,   3.19,   2.96,   
2.64,   2.34,   2.18,   2.18,   2.22,   2.27,   2.46,   2.78,   2.96,   2.93,   2.83,   2.68,   2.43,   2.05, 1.65, 1.30,   0.98,   0.66,   0.41,   0.15,   -0.11,  -0.26,  -0.28,  -0.24,  -0.09,  0.30,   0.88,   1.51,
2.06,   2.56,   3.06,   3.49,   3.65,   3.67,   3.92,   4.36,   4.83,   5.47,   6.52,   7.88,   9.30,   10.48,  11.40,  12.24,  13.03,  13.65,  14.12,  14.65,  15.24,  15.81,  16.43,  17.16,  17.97,  18.76,
19.45,  20.04,  20.59,  21.04,  21.39,  21.67,  21.86,  21.95,  21.95,  21.87)

data<- data.frame(x,y)

and here's the code I'm using the moment

    plot(x, y, ylim=c(0, 30), xlim = c(0, 2200), cex=0.2, type='o')
    grid()

## FROM LEFT TO RIGHT

peaks_1<-data.frame(findpeaks(data$y, minpeakheight = 6, threshold = 0, 
                              nups = 10, ndowns = 0,  minpeakdistance = 1, sortstr=F))

## FROM RIGHT TO LEFT

peaks_2<-data.frame(findpeaks(data$y, minpeakheight = 6, threshold = 0, 
          nups = 0, ndowns = 10,  minpeakdistance = 1, sortstr=F))


peaks<-rbind(peaks_1, peaks_2)

colnames(peaks)<-c("y", "X2", "X3", "X4")

peak_points<- data.frame(merge(peaks, data, by='y'))


    ## NOTE: I HAVE ROUNDED THE RAW DATA FOR THIS EXAMPLE AND SO WHEN THE DATA ARE MERGED, 
    ## IT PRODUCES THREE ADDITIONAL VALUES WHICH WE WILL MANUALLY REMOVE HERE

peak_points<- peak_points[-c(1, 2, 5),]

points(peak_points$x, peak_points$y,pch=19, cex=1,col='maroon')

The one on the right (21.95 mm) seems correct, and maybe the one in the middle (7.13 mm), but the one on the left doesn't (7.53 mm). Is there a way I can use pracma (or anything else) to specify the minimum increase with the nups command?

Answer 1

You could calculate the position approximately by doing a step wise regression on a number of poly nomials. We use the best fit to get an estimate yhat .

fit <- step(lm(as.formula(paste("y ~ ", paste0("I(x^", 1:(length(x)/2.3), ")",
                                               collapse=" + ")))))
yhat <- fit$fitted.values

Now we are able to calculate second derivatives; where it's greater than zero we have local minima, and where it's less than zero we have local maxima.

lmin <- which(c(FALSE, diff(diff(yhat) > 0) > 0))
lmax <- which(c(FALSE, diff(diff(yhat) < 0) > 0))
lmax <- lmax[lmax > min(lmin)]  ## delete lmax appearing before first lmin

Now we subtract lmax from lmin and those with difference > 6 are the POS itions we are looking for.

mp <- - mapply(`-`, yhat[lmin], yhat[lmax])
POS <- x[as.numeric(names(mp[mp > 6]))]

Looks like this:

plot(x, y, cex=0.2, type='o', main="Trip hazard")
grid()
lines(x, yhat, col=6, lty=2)
abline(v=x[lmin], lwd=1, lty=3, col=3)
abline(v=x[lmax], lwd=1, lty=3, col=4)
abline(v=POS, col="red", lwd=2)
legend("topleft", legend=c("y", "yhat", "lmin", "lmax", "POS"), 
       lwd=c(1, 1, 1, 1, 2), lty=c(1, 2, 3, 3, 1), col=c(1, 6, 3, 4, "red"))

Answer 2

Here's a simple brute-force approach; if your dataset isn't too big, it should be adequate.

# All the code below assumes that `data` is already sorted by x

# Flag every point within the range of the trip hazard
data$trip_hazard = F

# Iterate over every pair of points
for(i in 1:(nrow(data) - 1)) {
  for(j in (i + 1):nrow(data)) {
    # Get the x-coordinates of the points
    x1 = data$x[i]
    x2 = data$x[j]
    # If the points are no more than 100 mm apart, check whether there's a trip
    # hazard between them
    if(x2 - x1 <= 100) {
      # Get the y-coordinates of the points
      y1 = data$y[i]
      y2 = data$y[j]
      # If there's a rise or fall of at least 6 mm, we have a trip hazard; flag
      # all the points in the range accordingly
      if(abs(y2 - y1) >= 6) {
        data$trip_hazard[i:j] = T
      }
    }
    # If the points are more than 100 mm apart, we don't need to keep checking
    # points that are even further apart
    else {
      break
    }
  }
}

# Get the maximum y-value within each trip hazard
library(dplyr)
library(tidyr)
data = data %>%
  mutate(range_id = ifelse(trip_hazard != coalesce(lag(trip_hazard),
                                                   !trip_hazard),
                           x, NA)) %>%
  fill(range_id) %>%
  group_by(range_id) %>%
  mutate(peak = trip_hazard & y == max(y)) %>%
  ungroup() %>%
  dplyr::select(-range_id)

# Plot the sidewalk (repeated from question)
plot(x, y, ylim = c(0, 30), xlim = c(0, 2200), cex = 0.2, type = "o")
# Plot the trip hazards in red
points(data$x[data$trip_hazard], data$y[data$trip_hazard],
       lwd = 4, col = "red", type = "l")
# Plot the highest point within each trip hazard
points(data$x[data$peak], data$y[data$peak], pch = 19, cex = 2, col = "red")

Answer 3

I wrote a program whose output is the distinct points and end-points of trip hazards. It takes three arguments: the increment of data (how many x-data points is in your interval of interest), the elevation threshold, and the data set. From there, it will produce output that specifies both where the elevation change is greater than allowed and by virtue of the output will demonstrate in which direction.

get.vector.right <- function(i, increment, data){
  return(data$y[i:(i+increment)])
}

get.vector.left <- function(i, increment, data){
  return(data$y[(i - increment):i])
}

get.vector.right.abridged <- function(i, increment, data){
  return(data$y[i : nrow(data)])
}

get.vector.left.abridged <- function(i, increment, data){
  return(data$y[1 : i])
}

print.warning <- function(data, i, increment, direction){
  if(direction == "right"){
    print(paste0("Steep change in vertical distance noted between ", data$x[i], " and ", data$x[(i + increment)]))
  } else if(direction == "left"){
    print(paste0("Steep change in vertical distance noted between ", data$x[i], " and ", data$x[(i - increment)]))
  }
}

check.right.up <- function(vector, increment, vertical.distance, data, i){
  if(max(vector) - vector[1] >= vertical.distance){
    print.warning(data, i, increment, "right")
  }
}

check.right.down <- function(vector, increment, vertical.distance, data, i){
  if(vector[1] - min(vector) >= vertical.distance){
    print.warning(data, i, increment, "right")
  }
}

check.left.up <- function(vector, increment, vertical.distance, data, i){
  if(max(vector) - vector[length(vector)] >= vertical.distance){
    print.warning(data, i, increment, "left")
  }
}

check.left.down <- function(vector, increment, vertical.distance, data, i){
  if(vector[length(vector)] - min(vector) >= vertical.distance){
    print.warning(data, i, increment, "left")
  }
}

check.function <- function(left.vector, right.vector, increment, vertical.distance, data, i){
  check.left.up(left.vector, increment, vertical.distance, data, i)
  check.left.down(left.vector, increment, vertical.distance, data, i)
  check.right.up(right.vector, increment, vertical.distance, data, i)
  check.right.down(right.vector, increment, vertical.distance, data, i)
}



trip.function <- function(increment, vertical.distance, data){
  for(i in 1:nrow(data)){
    if(data$x[i] == min(data$x)){
      get.vector.right(i, increment, data) -> right.vector
      check.right.up(right.vector, increment, vertical.distance, data, i)
      check.right.down(right.vector, increment, vertical.distance, data, i)
    } else if (data$x[i] == max(data$x)){
      get.vector.left(i, increment, data) -> left.vector
      check.left.up(left.vector, increment, vertical.distance, data, i)
      check.left.down(left.vector, increment, vertical.distance, data, i)
    } else {
      if(nrow(data[1:i, ]) <= increment){
        get.vector.left.abridged(i, increment, data) -> left.abridged.vector
        get.vector.right(i, increment, data) -> right.vector
        check.function(left.abridged.vector, right.vector, increment, vertical.distance, data, i)
      } else if (nrow(data[i:nrow(data), ]) <= increment){
        get.vector.right.abridged(i, increment, data) -> right.abridged.vector
        get.vector.left(i, increment, data) -> left.vector
        check.function(left.vector, right.abridged.vector, increment, vertical.distance, data, i)
      } else {
        get.vector.left(i, increment, data) -> left.vector
        get.vector.right(i, increment, data) -> right.vector
        check.function(left.vector, right.vector, increment, vertical.distance, data, i)
      }
    }
    rm(right.vector, left.vector, left.abridged.vector, right.abridged.vector)
  }
}

Thus, if you wanted to know if there were any 6mm changes within 100mm, you would type (assuming 10 data points on the x-axis represents 100mm and the y-axis is recorded in mm):

trip.function(10, 6, data)

and the output would be:

[1] "Steep change in vertical distance noted between 1750 and 1850"
[1] "Steep change in vertical distance noted between 1760 and 1860"
[1] "Steep change in vertical distance noted between 1770 and 1870"
[1] "Steep change in vertical distance noted between 1780 and 1880"
[1] "Steep change in vertical distance noted between 1790 and 1890"
[1] "Steep change in vertical distance noted between 1800 and 1900"
[1] "Steep change in vertical distance noted between 1810 and 1910"
[1] "Steep change in vertical distance noted between 1820 and 1920"
[1] "Steep change in vertical distance noted between 1830 and 1930"
[1] "Steep change in vertical distance noted between 1840 and 1940"
[1] "Steep change in vertical distance noted between 1850 and 1750"
[1] "Steep change in vertical distance noted between 1850 and 1950"
[1] "Steep change in vertical distance noted between 1860 and 1760"
[1] "Steep change in vertical distance noted between 1860 and 1960"
[1] "Steep change in vertical distance noted between 1870 and 1770"
[1] "Steep change in vertical distance noted between 1870 and 1970"
[1] "Steep change in vertical distance noted between 1880 and 1780"
[1] "Steep change in vertical distance noted between 1880 and 1980"
[1] "Steep change in vertical distance noted between 1890 and 1790"
[1] "Steep change in vertical distance noted between 1890 and 1990"
[1] "Steep change in vertical distance noted between 1900 and 1800"
[1] "Steep change in vertical distance noted between 1900 and 2000"
[1] "Steep change in vertical distance noted between 1910 and 1810"
[1] "Steep change in vertical distance noted between 1910 and 2010"
[1] "Steep change in vertical distance noted between 1920 and 1820"
[1] "Steep change in vertical distance noted between 1920 and 2020"
[1] "Steep change in vertical distance noted between 1930 and 1830"
[1] "Steep change in vertical distance noted between 1930 and 2030"
[1] "Steep change in vertical distance noted between 1940 and 1840"
[1] "Steep change in vertical distance noted between 1950 and 1850"
[1] "Steep change in vertical distance noted between 1960 and 1860"
[1] "Steep change in vertical distance noted between 1970 and 1870"
[1] "Steep change in vertical distance noted between 1980 and 1880"
[1] "Steep change in vertical distance noted between 1990 and 1890"
[1] "Steep change in vertical distance noted between 2000 and 1900"
[1] "Steep change in vertical distance noted between 2010 and 1910"
[1] "Steep change in vertical distance noted between 2020 and 1920"
[1] "Steep change in vertical distance noted between 2030 and 1930"

The order of the numbers indicate in which direction: 2030 and 1930 indicates movement from x = 2030 to x = 1930 (left-ward movement) and vice versa.