基准（位置）

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)

前一个或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的位置索引序列的 start 。我们使用s在which(x==1)中捕获此内容。< / p>

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

最后，我们必须生成实际的序列。为此，我们必须为e的每个元素调用seq()，同时从s传递相应的结束索引。要查找结束索引，我们可以使用e查找findInterval()的索引，其元素值（即e的结束索引）在之前只是 x的每个元素。（之前之前的原因是s使用的算法是findInterval()，如doc页面所述。）我们必须添加一个它将索引转换为v[i[j]] ≤ x[j] < v[i[j]+1]，其元素值仅落在之后 <{em>} e的每个元素之后。然后，我们使用它对s进行索引，将结束索引提供给e，跟随x的每个元素。我们必须从中减去一个，因为我们生成的序列必须排除（不包括）end元素。调用s的最简单方法是seq()两个端点向量，返回每个序列的列表，我们可以Map()获取所需的输出。

unlist()

输入向量中每次出现的非NA值都是段的 start ，在输出中，它必须成为该起始索引处元素值的重复。我们使用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在s中捕获这些索引。

然后我们必须重复每个开始元素足够次以到达以下段。因此，我们可以使用向量化which(!is.na(x));参数在rep()上调用x[s]，该参数的值由times上的diff()组成。要处理最终段，我们必须在输入向量s的末尾附加一个索引。另外，为了处理引导输入向量的NAs的可能情况，我们必须在length(x)+1L和x[s]参数前加一个0，这将重复0足够的次数来覆盖领先的NA，如果存在的话。

基准（位置）

diff()

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

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

Answer 4

将序列粘贴到字符串中并使用while循环检查（grep）是否有NA s前面有1 s和替换（gsub } 1这样的情况会这样做：

# substitute NA for "N" for later ease of processing and locating 1s by position
x[is.na(x)] <- "N"
# Collapse vector into a string
stringx <- paste(x, collapse = "")

while(grepl("(?<=1)N", stringx, perl = TRUE)) {
    stringx <- gsub("(?<=1)N", "1", stringx, perl = TRUE)
}

然后您可以使用gregexpr获取1s的索引。

unlist(gregexpr("1", stringx))
#[1]  6  8  9 10 11 15 16 17

或者您可以拆分字符串并查看结果向量中找到1的索引：

newx <-unlist(strsplit(stringx, ""))
#[1] "N" "N" "N" "N" "0" "1" "0" "1" "1" "1" "1" "0" "N" "N" "1" "1" "1" "0"

which(newx == "1") 
#[1]  6  8  9 10 11 15 16 17

使用stri_flatten包中的stringi代替paste和stri_locate_all_fixed而不是gregexpr或字符串拆分路由可以提供更高的性能这是你正在处理的更大的矢量。如果向量不大，则不会产生性能提升。

library(stringi)
x[is.na(x)] <- "N"
stringx <- stri_flatten(x)

while(grepl("(?<=1)N", stringx, perl = TRUE)) {
    stringx <- gsub("(?<=1)N", "1", stringx, perl = TRUE) 
}

stri_locate_all_fixed(stringx, "1")[[1]][,"start"]

以下方法相当简单，并且在小样本和大样本上表现相对较好（基于bgoldst的优秀基准测试示例）（非常好的bgoldst NA概率NA示例）

x[is.na(x)] <- "N"
stringx <- stri_flatten(x)

ones <- stri_locate_all_regex(stringx, "1N*")[[1]]

#[[1]]
#
#     start end
#[1,]     6   6
#[2,]     8  11
#[3,]    15  17

unlist(lapply(seq_along(ones[, 1]),
    function(ii) seq.int(ones[ii, "start"], ones[ii, "end"])))
#[1]  6  8  9 10 11 15 16 17

从矢量0,1和NA

4 个答案:

基准（位置）

基准测试（填充）