Идентифицировать и считать заклинания (Отличительные события в каждой группе) - PullRequest
Новая
       34

Идентифицировать и считать заклинания (Отличительные события в каждой группе)

7 голосов
/ 01 апреля 2019

Я ищу эффективный способ определения заклинаний / прогонов во временном ряду. На изображении ниже первые три столбца - это то, что у меня есть, четвертый столбец, spell - это то, что я пытаюсь вычислить. Я пытался использовать dplyr lead и lag, но это слишком сложно. Я пробовал rle, но ничего не получилось.

enter image description here

ReprEx 

df <- structure(list(time = structure(c(1538876340, 1538876400, 
1538876460,1538876520, 1538876580, 1538876640, 1538876700, 1538876760, 1526824800, 
1526824860, 1526824920, 1526824980, 1526825040, 1526825100), class = c("POSIXct", 
"POSIXt"), tzone = "UTC"), group = c("A", "A", "A", "A", "A", "A", "A", "A", "B", 
"B", "B", "B", "B", "B"), is.5 = c(0, 1, 1, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 1)), 
class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -14L))

Я предпочитаю решение tidyverse.

Предположения

  1. Данные сортируются по group, а затем по time

  2. В каждой группе time нет пробелов


Обновление

Спасибо за вклад. Я рассчитал некоторые из предложенных подходов на полных данных (n = 2 583 360)

  1. подход rle @markus занял 0,53 секунды
  2. cumsum заход @ M-M занял 2,85 секунды
  3. функция подхода @MrFlick заняла 0,66 секунды
  4. rle и dense_rank @tmfmnk заняли 0,89

В итоге я выбрал (1) @markus, потому что он быстрый и все же несколько интуитивный (субъективный). (2) by @ M-M наилучшим образом удовлетворило мое желание dplyr решения, хотя оно неэффективно в вычислительном отношении.

Ответы [ 6 ]

7 голосов
/ 02 апреля 2019

Один вариант с использованием rle

library(dplyr)
df %>% 
  group_by(group) %>% 
  mutate(
    spell = {
      r <- rle(is.5)
      r$values <- cumsum(r$values) * r$values
      inverse.rle(r) 
      }
  )
# A tibble: 14 x 4
# Groups:   group [2]
#   time                group  is.5 spell
#   <dttm>              <chr> <dbl> <dbl>
# 1 2018-10-07 01:39:00 A         0     0
# 2 2018-10-07 01:40:00 A         1     1
# 3 2018-10-07 01:41:00 A         1     1
# 4 2018-10-07 01:42:00 A         0     0
# 5 2018-10-07 01:43:00 A         1     2
# 6 2018-10-07 01:44:00 A         0     0
# 7 2018-10-07 01:45:00 A         0     0
# 8 2018-10-07 01:46:00 A         1     3
# 9 2018-05-20 14:00:00 B         0     0
#10 2018-05-20 14:01:00 B         0     0
#11 2018-05-20 14:02:00 B         1     1
#12 2018-05-20 14:03:00 B         1     1
#13 2018-05-20 14:04:00 B         0     0
#14 2018-05-20 14:05:00 B         1     2

Вы запросили решение tidyverse, но если вам нужна скорость, вы можете использовать data.table.Синтаксис очень похож 

library(data.table)
setDT(df)[, spell := {
  r <- rle(is.5)
  r$values <- cumsum(r$values) * r$values
  inverse.rle(r) 
  }, by = group][] # the [] at the end prints the data.table

объяснение

Когда мы вызываем 

r <- rle(df$is.5)

, результат, который мы получаем, равен 

r
#Run Length Encoding
#  lengths: int [1:10] 1 2 1 1 2 1 2 2 1 1
#  values : num [1:10] 0 1 0 1 0 1 0 1 0 1

Нам нужно заменить values на кумулятивную сумму, где values == 1, тогда как values в противном случае должно остаться равным нулю.

Мы можем достичь этого, умножив cumsum(r$values) на r$values;где последний является вектором 0 с и 1 с. 

r$values <- cumsum(r$values) * r$values
r$values
# [1] 0 1 0 2 0 3 0 4 0 5

Наконец, мы вызываем inverse.rle, чтобы получить вектор такой же длины, как is.5. 

inverse.rle(r)
# [1] 0 1 1 0 2 0 0 3 0 0 4 4 0 5

Мы делаем это для каждого group.

5 голосов
/ 01 апреля 2019

Вот вспомогательная функция, которая может вернуть то, что вы после 

spell_index <- function(time, flag) {
  change <- time-lag(time)==1 & flag==1 & lag(flag)!=1
  cumsum(change) * (flag==1)+0
}

И вы можете использовать ее с вашими данными, такими как 

library(dplyr)
df %>% 
  group_by(group) %>% 
  mutate(
    spell = spell_index(time, is.5)
  )

В основном вспомогательные функции используют lag() дляищите изменения.Мы используем cumsum() для увеличения количества изменений.Затем мы умножаем на логическое значение, чтобы обнулить значения, которые вы хотите обнулить.

2 голосов
/ 02 апреля 2019

Вот один вариант с rleid из data.table.Преобразовать data.frame в data.table (setDT(df)), сгруппировать по group, получить идентификатор длины выполнения (rleid) из is.5 и умножить на значенияis.5 ', чтобы заменить идентификаторы, соответствующие 0 в is.5 на 0, назначьте его' spell ', затем укажите i с логическим вектором, чтобы выбрать строки, у которых значения' spell 'не равны нулю, match эти значения «заклинания» с помощью unique «заклинания» и присвоение его «заклинания» 

library(data.table)
setDT(df)[, spell := rleid(is.5) * as.integer(is.5), group
       ][!!spell, spell := match(spell, unique(spell))][]
#                   time group is.5 spell
# 1: 2018-10-07 01:39:00     A    0     0
# 2: 2018-10-07 01:40:00     A    1     1
# 3: 2018-10-07 01:41:00     A    1     1
# 4: 2018-10-07 01:42:00     A    0     0
# 5: 2018-10-07 01:43:00     A    1     2
# 6: 2018-10-07 01:44:00     A    0     0
# 7: 2018-10-07 01:45:00     A    0     0
# 8: 2018-10-07 01:46:00     A    1     3
# 9: 2018-05-20 14:00:00     B    0     0
#10: 2018-05-20 14:01:00     B    0     0
#11: 2018-05-20 14:02:00     B    1     1
#12: 2018-05-20 14:03:00     B    1     1
#13: 2018-05-20 14:04:00     B    0     0
#14: 2018-05-20 14:05:00     B    1     2

Или после первого шага используйте .GRP

df[!!spell, spell := .GRP, spell]
1 голос
/ 02 апреля 2019

Один из вариантов использует cumsum: 

library(dplyr)
df %>% group_by(group) %>%  arrange(group, time) %>% 
   mutate(spell = is.5 * cumsum( c(0,lag(is.5)[-1]) != is.5 & is.5!=0) )


# # A tibble: 14 x 4
# # Groups:   group [2]
#   time                  group     is.5   spell
#   <dttm>                <chr>     <dbl>  <dbl>
# 1 2018-10-07 01:39:00   A         0      0
# 2 2018-10-07 01:40:00   A         1      1
# 3 2018-10-07 01:41:00   A         1      1
# 4 2018-10-07 01:42:00   A         0      0
# 5 2018-10-07 01:43:00   A         1      2
# 6 2018-10-07 01:44:00   A         0      0
# 7 2018-10-07 01:45:00   A         0      0
# 8 2018-10-07 01:46:00   A         1      3
# 9 2018-05-20 14:00:00   B         0      0
# 10 2018-05-20 14:01:00  B         0      0
# 11 2018-05-20 14:02:00  B         1      1
# 12 2018-05-20 14:03:00  B         1      1
# 13 2018-05-20 14:04:00  B         0      0
# 14 2018-05-20 14:05:00  B         1      2

c(0,lag(is.5)[-1]) != is.5 это обеспечивает назначение нового идентификатора (т. Е. spell) при каждом изменении is.5; но мы хотим избежать назначения новых строк этим строкам is.5, равным 0, и поэтому у меня есть второе правило в функции cumsum (т.е. (is.5!=0)).

Однако, это второе правило только запрещает присваивать новый идентификатор (добавляя 1 к предыдущему идентификатору), но не устанавливает идентификатор на 0. Вот почему я умножил ответ на is.5.

1 голос
/ 02 апреля 2019

Как-то иначе (не включая cumsum()) может быть: 

df %>%
 group_by(group) %>%
 mutate(spell = with(rle(is.5), rep(seq_along(lengths), lengths))) %>%
 group_by(group, is.5) %>%
 mutate(spell = dense_rank(spell)) %>%
 ungroup() %>%
 mutate(spell = ifelse(is.5 == 0, 0, spell))

   time                group  is.5 spell
   <dttm>              <chr> <dbl> <dbl>
 1 2018-10-07 01:39:00 A         0     0
 2 2018-10-07 01:40:00 A         1     1
 3 2018-10-07 01:41:00 A         1     1
 4 2018-10-07 01:42:00 A         0     0
 5 2018-10-07 01:43:00 A         1     2
 6 2018-10-07 01:44:00 A         0     0
 7 2018-10-07 01:45:00 A         0     0
 8 2018-10-07 01:46:00 A         1     3
 9 2018-05-20 14:00:00 B         0     0
10 2018-05-20 14:01:00 B         0     0
11 2018-05-20 14:02:00 B         1     1
12 2018-05-20 14:03:00 B         1     1
13 2018-05-20 14:04:00 B         0     0
14 2018-05-20 14:05:00 B         1     2

Здесь он сначала группируется по "группе", а затем получает идентификатор длины пробега "is.5". Во-вторых, он группируется по группам и is.5 и ранжирует значения по идентификатору длины серии. Наконец, он присваивает 0 строкам, где "is.5" == 0.

1 голос
/ 02 апреля 2019

Это работает,

Данные, 

df <- structure(list(time = structure(c(1538876340, 1538876400, 1538876460,1538876520, 1538876580, 1538876640, 1538876700, 1538876760, 1526824800, 1526824860, 1526824920, 1526824980, 1526825040, 1526825100), class = c("POSIXct", "POSIXt"), tzone = "UTC"), group = c("A", "A", "A", "A", "A", "A", "A", "A", "B", "B", "B", "B", "B", "B"), is.5 = c(0, 1, 1, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 1)), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -14L))

Мы разбиваем наши данные по группам, 

df2 <- split(df, df$group)

Создайте функцию, которую мы можем применить к списку, 

my_func <- function(dat){
  rst <- dat %>% 
    mutate(change = diff(c(0,is.5))) %>% 
    mutate(flag = change*abs(is.5)) %>% 
    mutate(spell = ifelse(is.5 == 0 | change == -1, 0, cumsum(flag))) %>% 
    dplyr::select(time, group, is.5, spell)
  return(rst)
}

Затем примените, 

l <- lapply(df2, my_func)

Теперь мы можем превратить этот список обратно во фрейм данных : 

do.call(rbind.data.frame, l)
...