Creare gruppi dal vettore 0,1 e NA

Question

Contesto:

Sto provando a spogliare un corpus dove viene identificato l'altoparlante. Ho ridotto il problema di rimuovere un particolare altoparlante dal corpuse al seguente flusso di 1,0 e NA (x). 0 significa che la persona sta parlando, 1 sta parlando qualcun altro, NA significa che chiunque è stato l'ultimo oratore sta ancora parlando.

Ecco un esempio visivo:

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. 

Quindi da questo telaio, mi piacerebbe prendere 2,3,5 e 7. Or ,. Vorrei che il risultato fosse 0,1,1,0,1,1.

Come faccio a tirare le posizioni di ciascuna serie di 1 e NA fino alla posizione precedente allo 0 successivo in un vettore.

Ecco un esempio, e il mio output desiderato: ingresso

Esempio:

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

uscita Esempio:

Queste sono le posizioni che voglio perché identificano che "speaker 1" sta parlando (1, o 1 seguito da NA fino al prossimo 0)

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

Un'uscita alternativa sarebbe un ripieno:

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

Se i valori NA della precedente 1 o 0 sono riempiti fino al successivo nuovo valore.

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 

Ogni occorrenza di un 1 nel vettore di ingresso è l'inizio di una sequenza di indici di posizione applicabili all'altoparlante 1. Noi catturare questo s con which(x==1).

Per ogni indice iniziale, dobbiamo trovare la lunghezza della sequenza di contenimento. La lunghezza è determinata dalla più prossima occorrenza in avanti di uno 0 (o, più in generale, qualsiasi valore non NA diverso da 1, se tale fosse possibile). Quindi, dobbiamo prima calcolare which(x!=1) per ottenere questi indici. Poiché l'occorrenza finale di un 1 potrebbe non avere un'occorrenza in avanti di uno 0, dobbiamo aggiungere un indice virtuale extra un'unità oltre la fine del vettore di input, motivo per cui dobbiamo chiamare c() per combinare length(x)+1L. Lo memorizziamo come e, a conferma che si tratta di (potenziali) indici finali. Si noti che questi sono esclusivi indici; in realtà non fanno parte della (potenziale) precedente sequenza di speaker 1.

Infine, dobbiamo generare le sequenze effettive. Per fare ciò, dobbiamo effettuare una chiamata a seq() per ogni elemento di s, passando anche il relativo indice finale corrispondente da e. Per trovare l'indice finale, è possibile utilizzare findInterval() per trovare l'indice in e il cui valore elemento (ovvero l'indice finale in x) cade appena prima dello ogni rispettivo elemento di s. (Il motivo per cui è solo prima è che l'algoritmo utilizzato da findInterval() è v[i[j]] ≤ x[j] < v[i[j]+1] come spiegato nella pagina doc.) Bisogna poi aggiungere uno ad esso per ottenere l'indice in e cui valore dell'elemento cade appena dopo ogni rispettivo elemento di s. Quindi indicizziamo e con esso, dandoci gli indici finali in x che seguono ogni rispettivo elemento di s. Dobbiamo sottrarre uno da quello perché la sequenza che generiamo deve escludere l'elemento finale (esclusivo). Il modo più semplice per effettuare chiamate a seq() equivale a Map() i due vettori di endpoint, restituendo un elenco di ciascuna sequenza, che possiamo unlist() per ottenere l'output richiesto.

---

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 

Ogni occorrenza di un non-NA valore nel vettore di ingresso è l'inizio di un segmento che, in uscita, deve diventare una ripetizione del valore dell'elemento a tale indice iniziale. Catturiamo questi indici in s con which(!is.na(x));.

Dobbiamo quindi ripetere ogni elemento di avvio un numero sufficiente di volte per raggiungere il segmento successivo. Quindi possiamo chiamare rep() su x[s] con un argomento vettoriale times i cui valori sono costituiti da diff() chiamato s. Per gestire il segmento finale, dobbiamo aggiungere un indice una unità oltre la fine del vettore di input, length(x)+1L. Inoltre, per trattare il possibile caso di NA che guidano il vettore di input, dobbiamo anteporre un 0 a x[s] e un 1 all'argomento diff(), che ripeterà 0 un numero sufficiente di volte per coprire gli AN principali, se tale esiste.

---

Benchmarking (posizione)

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 

---

Benchmarking (Fill)

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

incollare la sequenza in una stringa e utilizzando un ciclo while che controlla (con grep) se esistono NA s preceduti da 1 s e sostituti (con gsub) tali casi con un 1 faranno:

# 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) 
} 

Quindi è possibile utilizzare gregexpr per ottenere gli indici di 1s.

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

Oppure si può dividere la stringa e guardare attraverso di trovare gli indici di 1s nel vettore risultante:

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 

---

---

Utilizzando stri_flatten dal pacchetto stringi invece di paste e stri_locate_all_fixed anziché gregexpr o un percorso di suddivisione delle stringhe può fornire un po 'più di prestazioni se si tratta di un vecto più grande stai elaborando. Se il vettore non è grande, non si otterranno guadagni in termini di prestazioni.

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"] 

---

L'approccio seguito è abbastanza semplice e funziona relativamente bene (sulla base di eccellente esempio di bgoldst benchmarking) su campioni piccoli e grandi (molto bene su alta probabilità di bgoldst di NA esempio)

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 

Answer 3

Si può fare uso del na.locf dal pacchetto 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 4

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) 

uscita:

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