使用 slice() 过滤峰值间隔

Question

考虑以下数据集：

df <- tibble(
  interval = rep(1:10, 4),
  channel = rep(1:2, each = 20),
  date = parse_date(rep(c("2020-07-01", "2020-07-02", "2020-07-03", "2020-07-04"), 
             times = 2, each = 5)), 
  time = parse_time(
    rep(format(seq.POSIXt(as.POSIXct(Sys.Date() + 0.05), 
                          as.POSIXct(Sys.Date() + 0.95), length.out = 5),
               "%H:%M:%S", tz="GMT"), 8), format = "%H:%M:%S"),
  trigger = c(rep(0,5),        # Ch 1, day 1; no max
              0, 2, 0, 2, 0,   # Ch 1, day 2; 2 maxes
              rep(0, 5),       # Ch 1, day 3; no max
              0, 0, 2, 0, 0,   # Ch 1, day 4
              0, 0, 10, 0, 0,  # Ch 2, day 1
              10, rep(0, 4),   # Ch 2, day 2; max at head
              rep(0, 4), 10,   # Ch 2, day 3; max at tail
              4, 10, 4, 10, 0) # Ch 2, day 4; 2 maxes
)
# A tibble: 40 x 5
   interval channel date       time   trigger
      <int>   <int> <date>     <time>   <dbl>
 1        1       1 2020-07-01 01:12        0
 2        2       1 2020-07-01 06:36        0
 3        3       1 2020-07-01 12:00        0
 4        4       1 2020-07-01 17:24        0
 5        5       1 2020-07-01 22:48        0
 6        6       1 2020-07-02 01:12        0
 7        7       1 2020-07-02 06:36        2
 8        8       1 2020-07-02 12:00        0
 9        9       1 2020-07-02 17:24        2
10       10       1 2020-07-02 22:48        0
# ... with 30 more rows

我的数据有 10,000 多行来自传感器，每天记录它在某个时间间隔内被触发的次数。我想使用 slice() 过滤每天峰值触发时间前后的 2 小时间隔。我有可以工作的代码，但它会针对特定情况产生警告，稍后我会解释。虽然警告不会影响结果，但如果我没有警告，我会更放心。我需要考虑的条件是：

• 超过 1 天未触发传感器（触发器 = 0）
• 触发器在一天的开始或结束时达到峰值
• 触发器一天不止一次达到峰值（不同时间的最大值相同）

我主要使用 tidyverse 和 lubridate 函数编写代码。到目前为止，我最好的工作代码如下：

df %>% 
  group_by(date, channel) %>%
  slice(abs(which.max(trigger) + (-1:1))) %>% # Simplifying my interval with 1 row around the peak
  ungroup() %>%
  arrange(channel) %>% 
  print()
# A tibble: 20 x 5
   interval channel date       time   trigger
      <int>   <int> <date>     <time>   <dbl>
 1        1       1 2020-07-01 01:12        0
 2        2       1 2020-07-01 06:36        0
 3        6       1 2020-07-02 01:12        0
 4        7       1 2020-07-02 06:36        2
 5        8       1 2020-07-02 12:00        0
 6        1       1 2020-07-03 01:12        0
 7        2       1 2020-07-03 06:36        0
 8        7       1 2020-07-04 06:36        0
 9        8       1 2020-07-04 12:00        2
10        9       1 2020-07-04 17:24        0
11        2       2 2020-07-01 06:36        0
12        3       2 2020-07-01 12:00       10
13        4       2 2020-07-01 17:24        0
14        6       2 2020-07-02 01:12       10
15        7       2 2020-07-02 06:36        0
16        4       2 2020-07-03 17:24        0
17        5       2 2020-07-03 22:48       10
18        6       2 2020-07-04 01:12        4
19        7       2 2020-07-04 06:36       10
20        8       2 2020-07-04 12:00        4

我曾想过按间隔而不是按峰值进行切片，但间隔并不总是连续的；这取决于我何时重置程序。如果有 2 个或更多峰值，我不介意过滤第一个峰值。如果我能确定哪里有多个峰值，那就太好了！最后，如果一天没有触发器，我不希望包括那一天。我想我可以对不活动进行后过滤，但我仍然会收到警告。

快速回顾：

我的目标是在峰值触发时间前后过滤 2 小时的间隔。如果您可以推荐 tidyverse/lubridate（或任何真正的！）解决方案，我将不胜感激。谢谢！

Answer 1

您可以编写自定义函数来测试各种条件，以免产生警告。

custom_fun <- function(trigger) {
   #trigger value greater than 0
   inds <- trigger > 0
   #If any value greater than 0
   if(any(inds)) {
    #return the 2-hour interval
    vals <- which.max(trigger) + -1:1
    #remove values during head and tail of the day   
    return(vals[vals > 0 & vals <= length(trigger)])
   }
      #Don't select anything if no trigger > 0
      else return(0)
}

然后将其应用于每个date 和channel。

library(dplyr)

df %>% 
  group_by(date, channel) %>%
  #If multiple peaks present.
  mutate(mulitple_peak = sum(trigger == max(trigger)) > 1) %>%
  slice(custom_fun(trigger)) %>%
  ungroup()


# A tibble: 16 x 6
#   interval channel date       time   trigger mulitple_peak
#      <int>   <int> <date>     <time>   <dbl> <lgl>        
# 1        2       2 2020-07-01 06:36        0 FALSE        
# 2        3       2 2020-07-01 12:00       10 FALSE        
# 3        4       2 2020-07-01 17:24        0 FALSE        
# 4        6       1 2020-07-02 01:12        0 TRUE         
# 5        7       1 2020-07-02 06:36        2 TRUE         
# 6        8       1 2020-07-02 12:00        0 TRUE         
# 7        6       2 2020-07-02 01:12       10 FALSE        
# 8        7       2 2020-07-02 06:36        0 FALSE        
# 9        4       2 2020-07-03 17:24        0 FALSE        
#10        5       2 2020-07-03 22:48       10 FALSE        
#11        7       1 2020-07-04 06:36        0 FALSE        
#12        8       1 2020-07-04 12:00        2 FALSE        
#13        9       1 2020-07-04 17:24        0 FALSE        
#14        6       2 2020-07-04 01:12        4 TRUE         
#15        7       2 2020-07-04 06:36       10 TRUE         
#16        8       2 2020-07-04 12:00        4 TRUE