在没有循环的情况下找到时间序列中最大的drops/rises(最好使用tidy/dplyr)?

Find the biggest drops/rises in a time series without a loop (preferably using tidy/dplyr)?

我有很多时间序列,想找到一种方法来确定每个时间序列的前 10 个最大涨幅和跌幅。

这并不像听起来那么容易,因为时间序列上最突出的特征有时会被相反方向的运动打断,即使只是很短的时间(例如一个时期)。这意味着任何简单地扫描同一方向上最连续周期运动的算法通常都无法找到最突出的特征(例如,人类可以识别的特征)。

有没有可以使用的标准方法'out of the box'?

例如,在下图中,如果要求识别最突出的跌倒,人们可能会指向带圆圈的区域。我们如何获得代码来识别这些跌倒(就像人类一样)?

注意:我想卷积神经网络可能可以做到这一点,但如果可能的话我会寻求更简单的解决方案(它不一定是完美的)

library(tidyverse)
library(priceR)
au <- historical_exchange_rates("AUD", to = "USD",
                          start_date = "2010-01-01", end_date = "2020-06-30")
au %>% 
  tail(365 * 8) %>% 
  rename(aud_to_usd = one_AUD_equivalent_to_x_USD) %>% 
  mutate(date = as.Date(date)) %>% 
  ggplot(aes(x = date, y = aud_to_usd, group = 1)) +
  geom_line() +
  geom_smooth(method = 'loess', se = TRUE) + 
  theme(axis.title.x=element_blank(),
        axis.ticks.x=element_blank()) + 
  scale_x_date(date_labels = "%Y", date_breaks = "1 year")  +
  ggtitle("AUD to USD over last 8 years")

这是一个您可以使用的函数。它利用 run-length 将时间序列编码成上升或下降的片段。它允许您设置一个 gap_width 参数,指示允许的伸展中断多长时间。它是基于 R 的,它并不完美,但对于你上面提到的情况似乎工作得很好。

rise_and_falls <- function(value, time, gap_width = 5, top = 10, type = "fall") {
  type <- match.arg(type, c("fall", "rise"))
  if (type == "fall") {
    rle <- rle(sign(diff(value)) == -1)
  } else {
    rle <- rle(sign(diff(value)) == 1)
  }
  rle$values <- !rle$values & rle$lengths <= gap_width | rle$values
  rle <- rle(inverse.rle(rle)) # Clean up changed runs
  df <- data.frame(
    start = cumsum(rle$lengths) - rle$lengths + 1,
    end = cumsum(rle$lengths),
    len = rle$lengths,
    drop = rle$values
  )
  df <- transform(
    df,
    start_value = value[start],
    end_value = value[end],
    start_time = time[start],
    end_time = time[end]
  )
  df$diff <- df$start_value - df$end_value
  df <- df[order(df$diff),]
  if (type == "fall") {
    tail(df, top)
  } else {
    head(df, top)
  }
}

我推荐你使用它如下:

au %>% 
  tail(365 * 8) %>% 
  rename(aud_to_usd = one_AUD_equivalent_to_x_USD) %>% 
  mutate(date = as.Date(date)) -> au

df <- rise_and_falls(au$aud_to_usd, au$date, type = "fall")

ggplot(au, aes(x = date, y = aud_to_usd, group = 1)) +
  geom_line() +
  geom_smooth(method = 'loess', se = TRUE) + 
  theme(axis.title.x=element_blank(),
        axis.ticks.x=element_blank()) + 
  scale_x_date(date_labels = "%Y", date_breaks = "1 year")  +
  ggtitle("AUD to USD over last 8 years") +
  geom_segment(data = df, aes(x = start_time, y = start_value,
                              xend = end_time, yend = end_value),
               size = 2, colour = "red")

如果有人想对此进行改进,cut-off 局部极值处的延伸可能是有意义的。

另一种选择是先使用高斯内核平滑线条,然后使用 gap_width = 0.

运行 rise_and_falls() 函数