Wyodrębnij wiersze z data.frame na podstawie wspólnych wartości z listą

Question

Poszukuję łatwego sposobu filtrowania wierszy z data.frame, opartego na liście sekwencji liczbowych.

Oto exemple:

Moja początkowa ramka danych:

data <- data.frame(x=c(0,1,2,0,1,2,3,4,5,12,2,0,10,11,12,13),y="other_data") 

Moja lista:

list1 <- list(1:5,10:13) 

Moim celem jest, aby zachować tylko te wiersze z "danych", który zawiera dokładnie same sekwencje numeryczne "list1" jak w kolumnie "x" w "danych". Więc data.frame wyjście powinno być:

finaldata <- data.frame(x=c(1:5,10:13),y="other_data") 

Wszelkie pomysły na to robi?

Answer 1

Zacząłem z funkcji niestandardowej, aby uzyskać podzbiór dla jednej sekwencji, a następnie łatwo rozszerzyć z lapply.

#function that takes sequence and a vector 
#and returns indices of vector that have complete sequence 
get_row_indices<- function(sequence,v){ 
    #get run lengths of whether vector is in sequence 
    rle_d <- rle(v %in% sequence) 
    #test if it's complete, so both v in sequence and length of 
    #matches is length of sequence 
    select <- rep(length(sequence)==rle_d$lengths &rle_d$values,rle_d$lengths) 

    return(select) 

} 


#add row ID to data to show selection 
data$row_id <- 1:nrow(data) 
res <- do.call(rbind,lapply(list1,function(x){ 
    return(data[get_row_indices(sequence=x,v=data$x),]) 
})) 

res 

> res 
    x   y row_id 
5 1 other_data  5 
6 2 other_data  6 
7 3 other_data  7 
8 4 other_data  8 
9 5 other_data  9 
13 10 other_data  13 
14 11 other_data  14 
15 12 other_data  15 
16 13 other_data  16 

Answer 2

Dlaczego nie używając rollapply z zoo:

library(zoo) 

ind = lapply(list1, function(x) { 
    n = length(x) 
    which(rollapply(data$x, n, function(y) all(y==x))) + 0:(n-1) 
}) 

data[unlist(ind),] 
#x   y 
#5 1 other_data 
#6 2 other_data 
#7 3 other_data 
#8 4 other_data 
#9 5 other_data 
#13 10 other_data 
#14 11 other_data 
#15 12 other_data 
#16 13 other_data 

Answer 3

Funkcja match2 przechodzi przez każdą z wartości x i sprawdza go i następnych wartości n przed wektor o długości n. Następnie używa Reduce do utworzenia sekwencji do indeksowania.

match2 <- function(vec) { 
    start <- which(sapply(1:nrow(data), function(i) all(data$x[i:(i+length(vec)-1)] == vec))) 
    Reduce(':', c(start,start+length(vec)-1)) 
} 

Dzięki temu możemy wykorzystać funkcję zastosować aby powtórzyć proces dla każdego list1.

s <- sapply(list1, match2) 
data[unlist(s),] 
#  x   y 
# 5 1 other_data 
# 6 2 other_data 
# 7 3 other_data 
# 8 4 other_data 
# 9 5 other_data 
# 13 10 other_data 
# 14 11 other_data 
# 15 12 other_data 
# 16 13 other_data 

Answer 4

extract_fun <- function(x, dat){ 
    # Index where the sequences start 
    ind <- which(dat == x[1]) 
    # Indexes (within dat) where the sequence should be 
    ind_seq <- lapply(ind, seq, length.out = length(x)) 
    # Extract the values from dat at the position 
    dat_val <- mapply(`[`, list(dat), ind_seq) 
    # Check if values within dat == those in list1 
    i <- which(as.logical(apply(dat_val, 2, all.equal, x))) # which one is equal? 
    # Return the correct indices 
    ind_seq[[i]] 
} 

Get indeksy za sztukę w list1 i połączyć je do potrzebnych wskaźników

all_ind <- do.call(c, lapply(list1, extract_fun, data$x)) 
data[all_ind,] 

Wynik:

x   y 
5 1 other_data 
6 2 other_data 
7 3 other_data 
8 4 other_data 
9 5 other_data 
13 10 other_data 
14 11 other_data 
15 12 other_data 
16 13 other_data