Накопительная сумма, которая сбрасывается, когда встречается 0

Я хотел бы сделать кумулятивную сумму для поля, но сбрасывать агрегированное значение всякий раз, когда встречается 0.

Вот пример того, что я хочу:

data.frame(campaign = letters[1:4] , 
       date=c("jan","feb","march","april"),
       b = c(1,0,1,1) ,
       whatiwant = c(1,0,1,2)
       )

 campaign  date b whatiwant
1        a   jan 1         1
2        b   feb 0         0
3        c march 1         1
4        d april 1         2
Источник

5 ответов

Решение

Другая база будет просто

with(df, ave(b, cumsum(b == 0), FUN = cumsum))
## [1] 1 0 1 2

Это будет просто разделить столбец b группам по 0 Появления и вычислить совокупную сумму b по этим группам

Еще одно решение с использованием последних data.table версия (v 1.9.6+)

library(data.table) ## v 1.9.6+
setDT(df)[, whatiwant := cumsum(b), by = rleid(b == 0L)]
#    campaign  date b whatiwant
# 1:        a   jan 1         1
# 2:        b   feb 0         0
# 3:        c march 1         1
# 4:        d april 1         2

Некоторые показатели в комментариях

set.seed(123)
x <- sample(0:1e3, 1e7, replace = TRUE)
system.time(res1 <- ave(x, cumsum(x == 0), FUN = cumsum))
# user  system elapsed 
# 1.54    0.24    1.81 
system.time(res2 <- Reduce(function(x, y) if (y == 0) 0 else x+y, x, accumulate=TRUE))
# user  system elapsed 
# 33.94    0.39   34.85 
library(data.table)
system.time(res3 <- data.table(x)[, whatiwant := cumsum(x), by = rleid(x == 0L)])
# user  system elapsed 
# 0.20    0.00    0.21 

identical(res1, as.integer(res2))
## [1] TRUE
identical(res1, res3$whatiwant)
## [1] TRUE
Источник

Еще одна поздняя идея:

ff = function(x)
{
    cs = cumsum(x)
    cs - cummax((x == 0) * cs)
}
ff(c(0, 1, 3, 0, 0, 5, 2))
#[1] 0 1 4 0 0 5 7

И сравнить:

library(data.table)
ffdt = function(x) 
    data.table(x)[, whatiwant := cumsum(x), by = rleid(x == 0L)]$whatiwant

x = as.numeric(x) ##because 'cumsum' causes integer overflow
identical(ff(x), ffdt(x))
#[1] TRUE
microbenchmark::microbenchmark(ff(x), ffdt(x), times = 25)
#Unit: milliseconds
#    expr      min       lq   median       uq      max neval
#   ff(x) 315.8010 362.1089 372.1273 386.3892 405.5218    25
# ffdt(x) 374.6315 407.2754 417.6675 447.8305 534.8153    25
Источник

Вы могли бы использовать Reduce функция с пользовательской функцией, которая возвращает 0, когда новое значение равно 0, и в противном случае добавляет новое значение к накопленному значению:

Reduce(function(x, y) if (y == 0) 0 else x+y, c(1, 0, 1, 1), accumulate=TRUE)
# [1] 1 0 1 2
Источник

Другой вариант с использованиемrepзначений в местах сброса. Это используетcumsumтолько один раз, но этот недостаток приведет к большим числам и может вызвать переполнение целых чисел или неточные числовые значения, которые будут распространяться.NAко всем следующим группам.

      x <- cumsum(DF$b)
i <- which(DF$b == 0)
x - rep(c(0, x[i]), diff(c(1L, i, length(x)+1L)))
#[1] 1 0 1 2

Другой способ — использоватьRcpp- в данном случае для целого числа .

      Rcpp::cppFunction('IntegerVector csrA(const IntegerVector x, int z=0) {
  IntegerVector out(no_init(x.size()));
  int init = z == NA_INTEGER ? 0 : z;
  int s = 0;
  for(int i = 0; i < x.size(); ++i) {
    if(x[i] == z) s = init;
    else [[likely]] s += x[i];
    out[i] = s;
  }
  return out;
}')
csrA(DF$b)
#[1] 1 0 1 2

Вариант, также учитывающий NA, может выглядеть так:

      Rcpp::cppFunction('IntegerVector csr(const IntegerVector x, int z=0) {
  IntegerVector out(no_init(x.size()));
  int init = z == NA_INTEGER ? 0 : z;
  LogicalVector isNA = is_na(x);
  int s = 0;
  for(int i = 0; i < x.size(); ++i) {
    if(x[i] == z) s = init;
    else [[likely]] if(isNA[i] || s == NA_INTEGER) s = NA_INTEGER;
      else [[likely]] s += x[i];
    out[i] = s;
  }
  return out;
}')

csr(c(2,4,3,0,3,5), 0)
#[1] 2 6 9 0 3 8

csr(c(2,NA,3,0,3,5), 0)
#[1]  2 NA NA  0  3  8

csr(c(2,4,3,1,3,5), 1)
#[1] 2 6 9 1 4 9

csr(c(2,4,3,NA,3,5), NA)
#[1] 2 6 9 0 3 8

Данные

      DF <- data.frame(campaign = letters[1:4] , 
                 date=c("jan","feb","march","april"),
                 b = c(1,0,1,1) ,
                 whatiwant = c(1,0,1,2)
                 )

Тест – на основе @David Arenburg

      set.seed(123)
#Using 1e3 instead of 1e2 would lead to an integer overflow for whichRep and cummax
x <- sample(0:1e2, 1e7, TRUE)

library(data.table)

bench::mark(
ave = ave(x, cumsum(x == 0), FUN = cumsum),
data.table = data.table(x)[, whatiwant := cumsum(x), by = rleid(x == 0L)]$whatiwant,
cummax = {cs = cumsum(x)
  cs - cummax((x == 0) * cs)},
whichRep = {y <- cumsum(x)
i <- which(x == 0)
y - rep(c(0, y[i]), diff(c(1L, i, length(x)+1L)))},
RcppNA = csr(x),
RcppSimple = csrA(x)
)

Результат

        expression      min   median `itr/sec` mem_alloc `gc/sec` n_itr  n_gc total_…¹
  <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl> <int> <dbl> <bch:tm>
1 ave           1.06s    1.06s     0.945   751.8MB     3.78     1     4    1.06s
2 data.table 199.01ms 266.26ms     3.76    231.9MB     1.88     2     1 532.53ms
3 cummax      90.57ms  93.76ms    10.4     152.6MB     6.92     6     4  578.4ms
4 whichRep     74.5ms  77.05ms    12.9     195.6MB    11.1      7     6 541.63ms
5 RcppNA      39.55ms  40.84ms    24.2      76.3MB     5.60    13     3  536.1ms
6 RcppSimple  29.73ms  30.59ms    32.3      38.1MB     3.80    17     2  526.1ms
Источник

hutilscpp::cumsum_resetпредназначен для этой цели. Первый аргумент - это логический вектор, указывающий, когда должна продолжаться накопительная сумма. Второй аргумент - это ввод самой совокупной суммы.

library(hutilscpp)
b <- c(1, 0, 1, 1)
cumsum_reset(as.logical(b), b)

На моей машине по сравнению с data.table функция выше, это использование cumsum_reset примерно в 3 раза быстрее.

Источник
Другие вопросы по тегам