r - 在一小时内改变下一个唯一值并扩展和聚合

Question

我正在尝试实现滑动窗口聚合。我尝试使用 tidyr功能，但我相信有更好/更快的方法来实现。

让我解释一下我想要实现的目标:

我有一个输入数据框 dat :

dat <- tibble(timestamp = seq.POSIXt(as.POSIXct("2019-01-01 00:00:00"), as.POSIXct("2019-01-01 02:00:00"), by = "15 min"))
set.seed(42)
dat$value <- sample(1:5, nrow(dat), replace = T)
dat
# A tibble: 9 x 2
  timestamp           value
  <dttm>              <int>
1 2019-01-01 00:00:00     5
2 2019-01-01 00:15:00     5
3 2019-01-01 00:30:00     2
4 2019-01-01 00:45:00     5
5 2019-01-01 01:00:00     4
6 2019-01-01 01:15:00     3
7 2019-01-01 01:30:00     4
8 2019-01-01 01:45:00     1
9 2019-01-01 02:00:00     4

对于每一行，我想从 value 中找到唯一值的列表。在接下来的 60 分钟内出现的字段(但如果存在则忽略自身)。让我们将该列表称为 nextvalue然后展开每一行以在 value 之间生成对和 nextvalue .然后 group_by , value和 nextvalue和 summarise计数并按降序排序。

我阅读了文档并放置了以下代码。

t <- dat$timestamp
value <- dat$value

getCI <- function(start, end) {
  paste(value[(start+1):end], collapse = "|")
}

LETTERS <- LETTERS[1:(length(unique(value)) - 1)]

dat %>%
  mutate(time_next = timestamp + 60*60) %>%
  rowwise() %>%
  mutate(flag = max(which(time_next >= t))) %>%
  ungroup() %>%
  mutate(row = row_number()) %>%
  rowwise() %>%
  mutate(nextvalue = getCI(row, flag)) %>%
  select(value, nextvalue) %>%
  separate(nextvalue, c(LETTERS), extra = "warn", fill = "right") %>%
  pivot_longer(LETTERS, names_to = c("Letter"), values_to = "nextvalue") %>%
  filter(!is.na(nextvalue)) %>%
  filter(value != nextvalue) %>%
  select(value, nextvalue) %>%
  group_by(value, nextvalue) %>%
  summarise(count = n()) %>%
  arrange(desc(count))
# A tibble: 13 x 3
# Groups:   value [5]
   value nextvalue count
   <int> <chr>     <int>
 1     5 4             4
 2     2 4             2
 3     3 4             2
 4     4 1             2
 5     5 2             2
 6     5 3             2
 7     1 4             1
 8     2 3             1
 9     2 5             1
10     3 1             1
11     4 3             1
12     4 NA            1
13     5 1             1

但我想看到有趣的方法以更少的代码和更简单的方式实现这一目标。 我很想知道如何将多核方法应用于这个问题以加速整个计算 .
请给出意见

Answer 1

可以使用 data.table 以计算效率高的方式解决此问题。包裹。

library(data.table)

dat <- data.table(timestamp = seq.POSIXt(as.POSIXct("2019-01-01 00:00:00"), as.POSIXct("2019-01-01 02:00:00"), by = "15 min"),
                  value = c(5L,5L,2L,5L,4L,3L,4L,1L,4L))

dat[,time_next := timestamp + 60*60]


dat[dat,.(value = i.value,
          nextvalue = value), on = .(timestamp>timestamp,
                                     timestamp<=time_next)
    ][!value == nextvalue, .(count = .N), by = .(value,nextvalue)
      ][order(-count)]

#     value nextvalue count
#  1:     5         4     4
#  2:     5         2     2
#  3:     5         3     2
#  4:     2         4     2
#  5:     4         1     2
#  6:     3         4     2
#  7:     2         5     1
#  8:     2         3     1
#  9:     5         1     1
# 10:     4         3     1
# 11:     3         1     1
# 12:     1         4     1

分解解决方案:

首先，我们使用非对等连接在给定行的 timestamp 的行上将表连接到自身。落在另一行的 timestamp 之间和 time_next值。

dat[dat,.(value = i.value,
          nextvalue = value), on = .(timestamp>timestamp,
                                     timestamp<=time_next)
    ]

然后“链接”两个额外的步骤。

结果在哪里 value与 nextvalue 相同被排除在第一个子句中(在 data.table 文档中称为 i 子句)，分组变量在第三个 (k) 子句中定义，我们在第二个 (j) 子句中执行按组计算出现次数的操作.

[!value == nextvalue, .(count = .N), by = .(value,nextvalue)
      ]

最后，按计数降序对结果进行排序的附加步骤链接在:

[order(-count)]

表现

生成一些包含一百万行的合成数据，此解决方案在我的计算机上运行不到一秒钟，并使用大约 657Mb 的内存。

library(data.table)
RowCount <- 1e6
dat <- data.table(timestamp = seq.POSIXt(from = as.POSIXct("2019-01-01 00:00:00"),
                                         by = "15 min",
                                         length.out = RowCount),
                  value = sample.int(5L,RowCount,replace=TRUE))

dat[,time_next := timestamp + 60*60]

system.time({

  dat[dat,.(value = i.value,
            nextvalue = value), on = .(timestamp>timestamp,
                                       timestamp<=time_next)
      ][!value == nextvalue, .(count = .N), by = .(value,nextvalue)
        ][order(-count)]

})

#  user  system elapsed 
# 0.988   0.048   0.884