r - 从 0,1 和 NA 的向量创建组

Question

背景:

我正在尝试删除识别说话者的语料库。我已将从语料库中删除特定扬声器的问题减少到以下 1,0 和 NA (x) 流。 0 表示该人在讲话，1 表示其他人在讲话，NA 表示最后一个讲话者仍在讲话。

这是一个视觉示例:

0  1 S0: Hello, how are you today?
1  2 S1: I'm great thanks for asking!
NA 3 I'm a little tired though!
0  4 S0: I'm sorry to hear that. Are you ready for our discussion?
1  5 S1: Yes, I have everything I need.
NA 7 Let's begin.

所以从这个框架，我想取2、3、5和7。或者，。我希望结果是 0,1,1,0,1,1。

如何将 1 和 NA 的每次运行的位置拉到向量中下一个 0 之前的位置。

这是一个示例，以及我想要的输出:

示例输入:

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

示例输出:

这些是我想要的位置，因为它们确定“扬声器 1”正在说话(1，或 1 后跟 NA，直到下一个 0)

pos <- c(6,8,9,10,11,15,16,17)

另一种输出是填充:

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

其中前一个 1 或 0 的 NA 值被填充到下一个新值。

Answer 1

s <- which(x==1);
e <- c(which(x!=1),length(x)+1L);
unlist(Map(seq,s,e[findInterval(s,e)+1L]-1L));
## [1]  6  8  9 10 11 15 16 17

输入向量中每次出现 1 都是适用于说话者 1 的位置索引序列的开始。我们在 s 中捕获了这一点。与 which(x==1) .

对于每个起始索引，我们必须找到其包含序列的长度。长度由最接近的前向出现的 0 确定(或者，更一般地说，如果可能，则为 1 以外的任何非 NA 值)。因此，我们必须首先计算 which(x!=1)获取这些索引。因为最后出现的 1 可能没有前向出现的 0，所以我们必须在输入向量的末尾附加一个额外的虚拟索引，这就是为什么我们必须调用 c()结合 length(x)+1L .我们将其存储为 e ，反射(reflect)这些是(潜在的)结束索引。请注意，这些是排他的结束索引；它们实际上不是(潜在的)前面说话者 1 序列的一部分。

最后，我们必须生成实际的序列。为此，我们必须调用 seq() 的电话。对于 s 的每个元素，也从 e 传递其对应的结束索引.要找到结束索引，我们可以使用 findInterval()找到索引到 e其元素值(即 x 的结束索引)正好位于 s 的每个相应元素之前. (原因是 findInterval() 使用的算法是 v[i[j]] ≤ x[j] < v[i[j]+1]，如 doc 页面中所述。)然后我们必须在其中添加一个以获取 e 的索引。其元素值正好落在 s 的每个相应元素之后.然后我们索引 e有了它，我们将结束索引为 x s 的每个相应元素之后.我们必须从中减去一个，因为我们生成的序列必须排除(独占)结束元素。调用 seq() 的最简单方法是 Map()它的两个端点向量，返回每个序列的列表，我们可以 unlist()获得所需的输出。

s <- which(!is.na(x));
rep(c(0,x[s]),diff(c(1L,s,length(x)+1L)));
## [1] 0 0 0 0 0 1 0 1 1 1 1 0 0 0 1 1 1 0

输入向量中每次出现非 NA 值都是段的开始，在输出中，该段必须成为该开始索引处元素值的重复。我们在 s 中捕获这些索引与 which(!is.na(x)); .

然后我们必须重复每个起始元素足够的次数才能到达下一个片段。因此我们可以调用 rep()在 x[s]带有矢量化 times其值由 diff() 组成的参数调用 s .为了处理最后一段，我们必须在输入向量末尾添加一个索引， length(x)+1L .此外，为了处理 NA 引导输入向量的可能情况，我们必须在 x[s] 前面加上 0。和 1 到 diff()参数，它将重复 0 足够的次数以覆盖领先的 NA(如果存在)。

基准测试(位置)

library(zoo);
library(microbenchmark);
library(stringi);

marat <- function(x) { v <- na.locf(zoo(x)); index(v)[v==1]; };
rawr <- function(x) which(zoo::na.locf(c(0L, x))[-1L] == 1L);
jota1 <- function(x) { stringx <- paste(x, collapse = ""); stringx <- gsub("NA", "N", stringx, fixed = TRUE); while(grepl("(?<=1)N", stringx, perl = TRUE)) stringx <- gsub("(?<=1)N", "1", stringx, perl = TRUE); unlist(gregexpr("1", stringx)); };
jota2 <- function(x) { stringx <- paste(x, collapse = ""); stringx <- gsub("NA", "N", stringx, fixed = TRUE); while(grepl("(?<=1)N", stringx, perl = TRUE)) stringx <- gsub("(?<=1)N", "1", stringx, perl = TRUE); newx <-unlist(strsplit(stringx, "")); which(newx == 1); };
jota3 <- function(x) {x[is.na(x)] <- "N"; stringx <- stri_flatten(x); ones <- stri_locate_all_regex(stringx, "1N*")[[1]]; unlist(lapply(seq_along(ones[, 1]), function(ii) seq.int(ones[ii, "start"], ones[ii, "end"]))); };
bgoldst <- function(x) { s <- which(x==1); e <- c(which(x!=1),length(x)+1L); unlist(Map(seq,s,e[findInterval(s,e)+1L]-1L)); };

## OP's test case
x <- c(NA,NA,NA,NA,0,1,0,1,NA,NA,NA,0,NA,NA,1,NA,NA,0);

ex <- marat(x);
identical(ex,rawr(x));
## [1] TRUE
identical(ex,jota1(x));
## [1] TRUE
identical(ex,jota2(x));
## [1] TRUE
identical(ex,jota3(x));
## [1] TRUE
identical(ex,bgoldst(x));
## [1] TRUE

microbenchmark(marat(x),rawr(x),jota1(x),jota2(x),jota3(x),bgoldst(x));
## Unit: microseconds
##        expr     min       lq      mean   median       uq      max neval
##    marat(x) 411.830 438.5580 503.24486 453.7400 489.2345 2299.915   100
##     rawr(x) 115.466 143.0510 154.64822 153.5280 163.7920  276.692   100
##    jota1(x) 448.180 469.7770 484.47090 479.6125 491.1595  835.633   100
##    jota2(x) 440.911 464.4315 478.03050 472.1290 484.3170  661.579   100
##    jota3(x)  53.885  65.4315  74.34808  71.2050  76.9785  158.232   100
##  bgoldst(x)  34.212  44.2625  51.54556  48.5395  55.8095  139.843   100

## scale test, high probability of NA
set.seed(1L);
N <- 1e5L; probNA <- 0.8; x <- sample(c(NA,T),N,T,c(probNA,1-probNA)); x[which(x)] <- rep(c(0,1),len=sum(x,na.rm=T));

ex <- marat(x);
identical(ex,rawr(x));
## [1] TRUE
identical(ex,jota1(x));
## [1] TRUE
identical(ex,jota2(x));
## [1] TRUE
identical(ex,jota3(x));
## [1] TRUE
identical(ex,bgoldst(x));
## [1] TRUE

microbenchmark(marat(x),rawr(x),jota1(x),jota2(x),jota3(x),bgoldst(x));
## Unit: milliseconds
##        expr       min        lq      mean    median        uq       max neval
##    marat(x) 189.34479 196.70233 226.72926 233.39234 237.45738 293.95154   100
##     rawr(x)  24.46984  27.46084  43.91167  29.92112  68.86464  79.53008   100
##    jota1(x) 154.91450 157.09231 161.73505 158.18326 160.42694 206.04889   100
##    jota2(x) 149.47561 151.68187 155.92497 152.93682 154.79668 201.13302   100
##    jota3(x)  82.30768  83.89149  87.35308  84.99141  86.95028 129.94730   100
##  bgoldst(x)  80.94261  82.94125  87.80780  84.02107  86.10844 130.56440   100

## scale test, low probability of NA
set.seed(1L);
N <- 1e5L; probNA <- 0.2; x <- sample(c(NA,T),N,T,c(probNA,1-probNA)); x[which(x)] <- rep(c(0,1),len=sum(x,na.rm=T));

ex <- marat(x);
identical(ex,rawr(x));
## [1] TRUE
identical(ex,jota1(x));
## [1] TRUE
identical(ex,jota2(x));
## [1] TRUE
identical(ex,jota3(x));
## [1] TRUE
identical(ex,bgoldst(x));
## [1] TRUE

microbenchmark(marat(x),rawr(x),jota1(x),jota2(x),jota3(x),bgoldst(x));
## Unit: milliseconds
##        expr       min        lq      mean    median        uq      max neval
##    marat(x) 178.93359 189.56032 216.68963 226.01940 234.06610 294.6927   100
##     rawr(x)  17.75869  20.39367  36.16953  24.44931  60.23612  79.5861   100
##    jota1(x) 100.10614 101.49238 104.11655 102.27712 103.84383 150.9420   100
##    jota2(x)  94.59927  96.04494  98.65276  97.20965  99.26645 137.0036   100
##    jota3(x) 193.15175 202.02810 216.68833 209.56654 227.94255 295.5672   100
##  bgoldst(x) 253.33013 266.34765 292.52171 292.18406 311.20518 387.3093   100

基准测试(填充)

library(microbenchmark);

bgoldst <- function(x) { s <- which(!is.na(x)); rep(c(0,x[s]),diff(c(1L,s,length(x)+1L))); };
user31264 <- function(x) { x[is.na(x)]=2; x.rle=rle(x); val=x.rle$v; if (val[1]==2) val[1]=0; ind = (val==2); val[ind]=val[which(ind)-1]; rep(val,x.rle$l); };

## OP's test case
x <- c(NA,NA,NA,NA,0,1,0,1,NA,NA,NA,0,NA,NA,1,NA,NA,0);

ex <- bgoldst(x);
identical(ex,user31264(x));
## [1] TRUE

microbenchmark(bgoldst(x),user31264(x));
## Unit: microseconds
##          expr    min     lq     mean median     uq    max neval
##    bgoldst(x) 10.264 11.548 14.39548 12.403 13.258 73.557   100
##  user31264(x) 31.646 32.930 35.74805 33.785 35.068 84.676   100

## scale test, high probability of NA
set.seed(1L);
N <- 1e5L; probNA <- 0.8; x <- sample(c(NA,T),N,T,c(probNA,1-probNA)); x[which(x)] <- rep(c(0,1),len=sum(x,na.rm=T));

ex <- bgoldst(x);
identical(ex,user31264(x));
## [1] TRUE

microbenchmark(bgoldst(x),user31264(x));
## Unit: milliseconds
##          expr      min       lq     mean   median       uq      max neval
##    bgoldst(x) 10.94491 11.21860 12.50473 11.53015 12.28945 50.25899   100
##  user31264(x) 17.18649 18.35634 22.50400 18.91848 19.53708 65.02668   100

## scale test, low probability of NA
set.seed(1L);
N <- 1e5L; probNA <- 0.2; x <- sample(c(NA,T),N,T,c(probNA,1-probNA)); x[which(x)] <- rep(c(0,1),len=sum(x,na.rm=T));

ex <- bgoldst(x);
identical(ex,user31264(x));
## [1] TRUE

microbenchmark(bgoldst(x),user31264(x));
## Unit: milliseconds
##          expr      min        lq      mean    median        uq      max neval
##    bgoldst(x)  5.24815  6.351279  7.723068  6.635454  6.923264 45.04077   100
##  user31264(x) 11.79423 13.063710 22.367334 13.986584 14.908603 55.45453   100