Найти самые большие падения / подъемы во временном ряду без al oop (желательно с помощью tidy / dplyr)?

Question

У меня много временных рядов, и я хочу найти способ определить 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")

введите описание изображения здесь

Answer 1

Вот функция, которую вы могли бы использовать. Он использует кодирование длин серий таймсерий в сегменты, которые поднимаются или опускаются. Он позволяет вам установить аргумент 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")

введите описание изображения здесь

Если кто-то хочет улучшить это, вероятно, имеет смысл обрезать растяжки на локальных экстремумах.

Другой вариант - сначала сгладить линию с помощью ядра Гаусса а затем запустите функцию rise_and_falls() с gap_width = 0.