带中断的增量序列答案

【问题标题】：Incremental sequences with interruptions带中断的增量序列
【发布时间】：2018-10-23 18:28:01
【问题描述】：

我有一个包含TRUE 重复序列的数据集，我想根据某些条件标记它 - 通过id 和序列的增量值。 FALSE 会破坏TRUEs 的序列，并且第一个破坏TRUE 的任何给定序列的FALSE 应该包含在该序列中。 TRUEs 之间的连续 FALSEs 无关紧要，标记为 0。

例如：

> test
   id logical sequence
1   1    TRUE        1
2   1    TRUE        1
3   1   FALSE        1
4   1    TRUE        2
5   1    TRUE        2
6   1   FALSE        2
7   1    TRUE        3
8   2    TRUE        1
9   2    TRUE        1
10  2    TRUE        1
11  2   FALSE        1
12  2    TRUE        2
13  2    TRUE        2
14  2    TRUE        2
15  3   FALSE        0
16  3   FALSE        0
17  3   FALSE        0
18  3    TRUE        1
19  3   FALSE        1
20  3    TRUE        2
21  3   FALSE        2
22  3   FALSE        0
23  3   FALSE        0
24  3   FALSE        0
25  3    TRUE        3

等等。我考虑过使用rle() 产生

> rle(test$logical)
Run Length Encoding
  lengths: int [1:13] 2 1 2 1 4 1 3 3 1 1 ...
  values : logi [1:13] TRUE FALSE TRUE FALSE TRUE FALSE ...

但我不确定如何将其映射回数据框。关于如何解决这个问题的任何建议？

这里是示例数据：

> dput(test)
structure(list(id = c(1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 
2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3), logical = c(TRUE, TRUE, 
FALSE, TRUE, TRUE, FALSE, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, 
TRUE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, TRUE, FALSE, FALSE, 
FALSE, FALSE, TRUE)), .Names = c("id", "logical"), class = "data.frame", row.names = c(NA, 
-25L))

【问题讨论】：

嗯，有什么不清楚的地方？
第一个破坏任何给定 TRUE 序列的 FALSE 应该包含在序列中，这有意义吗？其中id =1，是因为如果第一个序列的2个TRUE被第一个序列中包含的一个FALSE打破（第一个序列是3行），第二个序列也是3行，因为有两个TRUE被一个 FALSE 打破。
感谢@akrun 我已经相应地编辑了问题
是的，现在好多了
没那么简单，但可以帮助您的功能是：lag, rleidv, cumsum

标签： r dplyr data.table run-length-encoding

【解决方案1】：

纯data.table解决方案：

# load the 'data.table'-package & convert 'test' to a data.table with 'setDT'
library(data.table)
setDT(test)

# calculate the new sequence
test[, new_seq := (rleid(logical) - !logical) * !(!logical & !shift(logical, fill = FALSE)), by = id
     ][new_seq != 0, new_seq := rleid(new_seq), by = id][]

给出：

    id logical new_seq
 1:  1    TRUE       1
 2:  1    TRUE       1
 3:  1   FALSE       1
 4:  1    TRUE       2
 5:  1    TRUE       2
 6:  1   FALSE       2
 7:  1    TRUE       3
 8:  2    TRUE       1
 9:  2    TRUE       1
10:  2    TRUE       1
11:  2   FALSE       1
12:  2    TRUE       2
13:  2    TRUE       2
14:  2    TRUE       2
15:  3   FALSE       0
16:  3   FALSE       0
17:  3   FALSE       0
18:  3    TRUE       1
19:  3   FALSE       1
20:  3    TRUE       2
21:  3   FALSE       2
22:  3   FALSE       0
23:  3   FALSE       0
24:  3   FALSE       0
25:  3    TRUE       3

这是做什么的：

rleid(logical) - !logical 创建一个数字运行长度 id 并减去 1，其中 logical 等于 FALSE
然后将上一步的结果与!(!logical & !shift(logical, fill = FALSE)) 的结果相乘，这是一个TRUE/FALSE 向量，用于除FALSE 序列的第一个值之外的后续FALSE 值。
最后，我们只为new_seq 不等于0 的行创建一个新的运行长度ID，并获得您想要的结果。

一个稍微改进的替代方案（正如@jogo 在 cmets 中所建议的那样）：

test[, new_seq := (rleid(logical) - !logical) * (logical | shift(logical, fill = FALSE)), by = id
     ][new_seq != 0, new_seq := rleid(new_seq), by = id][]

【讨论】：

@jogo 看了，确实是一个不错的改进！

【解决方案2】：

您可以将cumsum 用于您的rle 值，然后您必须返回并修复连续的FALSE 值。

library(dplyr)

test %>%
  group_by(id) %>%
  mutate(sum_rle = with(rle(logical), rep(cumsum(values), lengths))) %>% 
  mutate(sequence2 = if_else(logical == F & lag(logical) == F, 0L, sum_rle, missing = 0L)) %>% 
  print(n = 25)

# # A tibble: 25 x 5
# # Groups:   id [3]
#       id logical sequence sum_rle sequence2
#    <int> <lgl>      <int>   <int>     <int>
#  1     1 TRUE           1       1         1
#  2     1 TRUE           1       1         1
#  3     1 FALSE          1       1         1
#  4     1 TRUE           2       2         2
#  5     1 TRUE           2       2         2
#  6     1 FALSE          2       2         2
#  7     1 TRUE           3       3         3
#  8     2 TRUE           1       1         1
#  9     2 TRUE           1       1         1
# 10     2 TRUE           1       1         1
# 11     2 FALSE          1       1         1
# 12     2 TRUE           2       2         2
# 13     2 TRUE           2       2         2
# 14     2 TRUE           2       2         2
# 15     3 FALSE          0       0         0
# 16     3 FALSE          0       0         0
# 17     3 FALSE          0       0         0
# 18     3 TRUE           1       1         1
# 19     3 FALSE          1       1         1
# 20     3 TRUE           2       2         2
# 21     3 FALSE          2       2         2
# 22     3 FALSE          0       2         0
# 23     3 FALSE          0       2         0
# 24     3 FALSE          0       2         0
# 25     3 TRUE           3       3         3

如果您更喜欢同一事物的真正简洁版本...

library(dplyr)

group_by(test, id) %>%
  mutate(sequence = if_else(!logical & !lag(logical), 0L, 
                            with(rle(logical), rep(cumsum(values), lengths)), 
                            missing = 0L))

【讨论】：

仅供参考，logical == FALSE = !logical

【解决方案3】：

在dtmtd2 中不使用 rle 以及一些计时：

dplyrmtd0 <- function() {
    test %>%
        group_by(id) %>%
        mutate(sum_rle = with(rle(logical), rep(cumsum(values), lengths))) %>% 
        mutate(sequence2 = if_else(logical == F & lag(logical) == F, 0L, sum_rle, missing = 0L))
}

setDT(test)    
makeSeq <- function(x) {
    res  <- ifelse(!x&!lag(x,default = F),T,x) %>% {!.} %>% lag(default=T) %>% cumsum
    IND2F<- ifelse(!x&!lag(x,default = F),T,x) != x
    res[IND2F]  <- 0
    res[!IND2F] <- rleidv(res[!IND2F])
    return(res)
}
dt0 <- copy(test)
dtmtd0 <- function() {
    dt0[,yourSEQ:=makeSeq(logical),by="id"]   
}

dt1 <- copy(test)
dtmtd1 <- function() {
    dt1[, new_seq := (rleid(logical) - !logical) * !(!logical & !shift(logical, fill = FALSE)), by = id
        ][new_seq != 0, new_seq := rleid(new_seq), by = id][]   
}

dt4 <- copy(test)
dtmtd2 <- function() {
    dt4[, sequence := {
            idx <- cumsum(diff(c(FALSE, logical))==1L)
            mask <- shift(logical, fill=FALSE) | logical
            idx * mask
        }, by=id]
}

microbenchmark(dplyrmtd0(), dtmtd0(), dtmtd1(), dtmtd2(), times=5L)

时间安排：

Unit: milliseconds
        expr      min       lq     mean   median       uq      max neval
 dplyrmtd0() 375.6089 376.7271 433.1885 380.7428 443.8844 588.9791     5
    dtmtd0() 481.5189 487.1245 492.9527 495.6855 500.1588 500.2759     5
    dtmtd1() 146.0376 147.0163 154.7501 152.7157 154.2976 173.6831     5
    dtmtd2() 106.3401 107.7728 112.7580 108.5239 119.4398 121.7131     5

数据：

library(data.table)
library(dplyr)
library(microbenchmark)
M <- 1e6
test <- data.frame(id=sample(LETTERS, M, replace=TRUE) ,
    logical=sample(c(TRUE, FALSE), M, replace=TRUE))
test <- test[order(test$id),]

【讨论】：

【解决方案4】：

makeSeq 函数肯定有更好的实现，但这是可行的。

这个使用库data.table、magrittr和dplyr

功能

makeSeq <- function(x) {
    res  <- ifelse(!x&!lag(x,default = F),T,x) %>% {!.} %>% lag(default=T) %>% cumsum
    IND2F<- ifelse(!x&!lag(x,default = F),T,x) != x
    res[IND2F]  <- 0
    res[!IND2F] <- rleidv(res[!IND2F])
    return(res)
}

data.table 解决方案

setDT(df)[,yourSEQ:=makeSeq(logical),by="id"]
df

tidyverse 粉丝使用

df %>% group_by(id) %>% mutate(yourSEQ = makeSeq(logical)) %>% ungroup

结果

> df
    id logical yourSEQ
 1:  1    TRUE       1
 2:  1    TRUE       1
 3:  1   FALSE       1
 4:  1    TRUE       2
 5:  1    TRUE       2
 6:  1   FALSE       2
 7:  1    TRUE       3
 8:  2    TRUE       1
 9:  2    TRUE       1
10:  2    TRUE       1
11:  2   FALSE       1
12:  2    TRUE       2
13:  2    TRUE       2
14:  2    TRUE       2
15:  3   FALSE       0
16:  3   FALSE       0
17:  3   FALSE       0
18:  3    TRUE       1
19:  3   FALSE       1
20:  3    TRUE       2
21:  3   FALSE       2
22:  3   FALSE       0
23:  3   FALSE       0
24:  3   FALSE       0
25:  3    TRUE       3
    id logical yourSEQ

【讨论】：