I'm looking for an efficient way to identify spells/runs in a time series. In the image below, the first three columns is what I have, the fourth column, spell is what I'm trying to compute. I've tried using dplyr's lead and lag, but that gets too complicated. I've tried rle but got nowhere.

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))

I prefer a tidyverse solution.

Assumptions

1. Data is sorted by group and then by time




2. There are no gaps in time within each group

Update

Thanks for the contributions. I've timed some of the proposed approaches on the full data (n=2,583,360)

1. the rle approach by @markus took 0.53 seconds


2. the cumsum approach by @M-M took 2.85 seconds


3. the function approach by @MrFlick took 0.66 seconds


4. the rle and dense_rank by @tmfmnk took 0.89

One option using 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

explanation

When we call

r <- rle(df$is.5)

the result we get is

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

We need to replace values with the cumulative sum where values == 1 while values should remain zero otherwise.

We can achieve this when we multiple cumsum(r$values) with r$values; where the latter is a vector of 0s and 1s.

r$values <- cumsum(r$values) * r$values

r$values

# [1] 0 1 0 2 0 3 0 4 0 5

Finally we call inverse.rle to get back a vector of the same length as is.5.

inverse.rle(r)

# [1] 0 1 1 0 2 0 0 3 0 0 4 4 0 5

We do this for every group.

Here's a helper function that can return what you are after

spell_index <- function(time, flag) {

  change <- time-lag(time)==1 & flag==1 & lag(flag)!=1

  cumsum(change) * (flag==1)+0

}

And you can use it with your data like

library(dplyr)

df %>% 

  group_by(group) %>% 

  mutate(

    spell = spell_index(time, is.5)

  )

Basically the helper functions uses lag() to look for changes. We use cumsum() to increment the number of changes. Then we multiply by a boolean value so zero-out the values you want to be zeroed out.

This works,

The data,

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))

We split our data by group,

df2 <- split(df, df$group)

Build a function we can apply to the list,

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)

}

Then apply it,

l <- lapply(df2, my_func)

We can now turn this list back into a data frame:

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

One options is using 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 this takes care of assigning a new id (i.e. spell) whenever is.5 changes; but we want to avoid assigning new ones to those rows is.5 equal to 0 and that's why I have the second rule in cumsum function (i.e. (is.5!=0)).

However, that second rule only prevents assigning a new id (adding 1 to the previous id) but it won't set the id to 0. That's why I have multiplied the answer by is.5.

Here is one option with rleid from data.table. Convert the 'data.frame' to 'data.table' (setDT(df)), grouped by 'group', get the run-length-id (rleid) of 'is.5' and multiply with the values of 'is.5' so as to replace the ids corresponding to 0s in is.5 to 0, assign it to 'spell', then specify the i with a logical vector to select rows that have 'spell' values not zero, match those values of 'spell' with unique 'spell' and assign it to 'spell'

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

Or after the first step, use .GRP

df[!!spell, spell := .GRP, spell]

A somehow different possibility (not involving cumsum()) could be:

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

Here it, first, groups by "group" and then gets the run-length-ID of "is.5". Second, it groups by "group" and "is.5" and ranks the values on the run-length-ID. Finally, it assigns 0 to rows where "is.5" == 0.