Создать счетчик в последовательных прогонах определенных значений

Question

У меня есть почасовая стоимость. Я хочу посчитать, сколько часов подряд значение было равно нулю, так как в прошлый раз оно не было равно нулю. Это простая работа для электронных таблиц или циклов, но я надеюсь, что для выполнения этой задачи понадобится быстрый векторизованный однострочный.

x <- c(1, 0, 1, 0, 0, 0, 1, 1, 0, 0)
df <- data.frame(x, zcount = NA)

df$zcount[1] <- ifelse(df$x[1] == 0, 1, 0)
for(i in 2:nrow(df)) 
  df$zcount[i] <- ifelse(df$x[i] == 0, df$zcount[i - 1] + 1, 0)

Желаемый вывод:

R> df
   x zcount
1  1      0
2  0      1
3  1      0
4  0      1
5  0      2
6  0      3
7  1      0
8  1      0
9  0      1
10 0      2

Answer 1

Сообщения Уильяма Данлэпа о R-help - это место, где можно найти все, что касается длины пробежек. Его F7 от этот пост является

f7 <- function(x){ tmp<-cumsum(x);tmp-cummax((!x)*tmp)}

и в текущей ситуации f7(!x). С точки зрения производительности есть

> x <- sample(0:1, 1000000, TRUE)
> system.time(res7 <- f7(!x))
   user  system elapsed 
  0.076   0.000   0.077 
> system.time(res0 <- cumul_zeros(x))
   user  system elapsed 
  0.345   0.003   0.349 
> identical(res7, res0)
[1] TRUE

Answer 2

Вот способ, основанный на подходе Джошуа rle: (ИЗМЕНЕНО для использования seq_len и lapply согласно предложению Марека)

> (!x) * unlist(lapply(rle(x)$lengths, seq_len))
 [1] 0 1 0 1 2 3 0 0 1 2

UPDATE . Просто для удовольствия, вот еще один способ сделать это, примерно в 5 раз быстрее:

cumul_zeros <- function(x)  {
  x <- !x
  rl <- rle(x)
  len <- rl$lengths
  v <- rl$values
  cumLen <- cumsum(len)
  z <- x
  # replace the 0 at the end of each zero-block in z by the 
  # negative of the length of the preceding 1-block....
  iDrops <- c(0, diff(v)) < 0
  z[ cumLen[ iDrops ] ] <- -len[ c(iDrops[-1],FALSE) ]
  # ... to ensure that the cumsum below does the right thing.
  # We zap the cumsum with x so only the cumsums for the 1-blocks survive:
  x*cumsum(z)
}

Попробуйте пример:

> cumul_zeros(c(1,1,1,0,0,0,0,0,1,1,1,0,0,1,1))
 [1] 0 0 0 1 2 3 4 5 0 0 0 1 2 0 0

Теперь сравните время на векторе миллионной длины:

> x <- sample(0:1, 1000000,T)
> system.time( z <- cumul_zeros(x))
   user  system elapsed 
   0.15    0.00    0.14 
> system.time( z <- (!x) * unlist( lapply( rle(x)$lengths, seq_len)))
   user  system elapsed 
   0.75    0.00    0.75 

Мораль истории: однострочники приятнее и проще для понимания, но не всегда самые быстрые!

Answer 3

rle будет «подсчитывать, сколько часов подряд значение было нулевым с момента последнего времени, когда оно не было нулем», но не в формате вашего «желаемого результата».

Обратите внимание на длину элементов, в которых соответствующие значения равны нулю:

rle(x)
# Run Length Encoding
#   lengths: int [1:6] 1 1 1 3 2 2
#   values : num [1:6] 1 0 1 0 1 0

Answer 4

Однострочник, не совсем супер элегантный:

x <- c(1, 0, 1, 0, 0, 0, 1, 1, 0, 0) 

 unlist(lapply(split(x, c(0, cumsum(abs(diff(!x == 0))))), function(x) (x[1] == 0) * seq(length(x))))

Answer 5

Простой base R подход:

ave(!x, cumsum(x), FUN = cumsum)

#[1] 0 1 0 1 2 3 0 0 1 2