从向量0、1和NA创建组

Question

背景：

我想去掉一个说话人被识别的语料库。我把把特定发言人从身体上移除的问题降到了下面的1,0和NA (x)流。0表示那个人在说话，另一个人在说话，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，1，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，反映出这些都是(潜在的)最终索引。请注意，这些都是独占的结束索引；它们实际上并不是(潜在的)前面的扬声器1序列的一部分。

最后，我们必须生成实际的序列。要做到这一点，我们必须对seq()的每个元素调用一个s，并从e中传递相应的结束索引。要找到结束索引，我们可以使用findInterval()将索引查找到e中，该索引的元素值(即x中的结束索引)正好落在s的每个元素之前。(前面的原因是findInterval()使用的算法是v[i[j]] ≤ x[j] < v[i[j]+1]，这在文档页面上已经解释过了。)然后，我们必须添加一个索引到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));捕获这些索引。

然后，我们必须重复每个start元素足够的次数，才能到达下面的部分。因此，我们可以使用一个向量化的rep()参数在x[s]上调用diff()，该参数的值由在s上调用的diff()组成。要处理最后一个段，我们必须在输入向量length(x)+1L结束后附加一个索引单元。此外，为了处理导致输入向量的NAs的可能情况，我们必须将0加到x[s]，将1加到diff()参数，如果存在，这将重复0次，足以覆盖前面的NAs。

基准(职位)

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

Answer 2

您可以使用来自na.locf包的zoo：

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

v <- na.locf(zoo(x))
index(v)[v==1]
#[1]  6  8  9 10 11 15 16 17

Answer 3

x <- c(NA,NA,NA,NA,0,1,0,1,NA,NA,NA,0,NA,NA,1,NA,NA,0)
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)

输出：

[1] 0 0 0 0 0 1 0 1 1 1 1 0 0 0 1 1 1 0