tabla - listas en r

Encontrar progresivamente el elemento más frecuente en la lista en R

Question

Me gustaría revisar una lista y verificar si ese elemento es el más frecuente en la lista hasta ese momento. La solución que tengo actualmente es increíblemente lenta en comparación con Python. ¿Hay alguna manera efectiva de acelerarlo?

 dat<-data.table(sample(1:50,10000,replace=T))
k<-1
correct <- 0 # total correct predictions
for (i in 2:(nrow(dat)-1)) {
if (dat[i,V1] %in% dat[1:(i-1),.N,by=V1][order(-N),head(.SD,k)][,V1]) {
correct <- correct + 1
}
}

En términos más generales, eventualmente quisiera ver si un artículo es uno de los k artículos más frecuentes hasta un punto, o si tiene uno de los k valores más altos hasta un punto.

A modo de comparación, aquí hay una implementación muy rápida en Python:

dat=[random.randint(1,50) for i in range(10000)]
correct=0
k=1
list={}
for i in dat:
toplist=heapq.nlargest(k,list.iteritems(),key=operator.itemgetter(1))
toplist=[j[0] for j in toplist]
if i in toplist:
correct+=1
if list.has_key(i):
list[i]=list[i]+1
else:
list[i]=1

Answer 1

¿Qué tal esta solución?

# unique values
unq_vals <- sort(dat[, unique(V1)])
# cumulative count for each unique value by row
cum_count <- as.data.table(lapply(unq_vals, function(x) cumsum(dat$V1==x)))
# running ranking for each unique value by row
cum_ranks <- t(apply(-cum_count, 1, rank, ties.method=''max''))

Ahora el rango de (por ejemplo) el 2º valor único a partir de la 8º observación se almacena en:

cum_ranks[8, 2]

Puede obtener el rango de cada elemento por fila (y presentarlo en una tabla legible) como este. Si el rank <= k para la fila i, entonces el i-ésimo ítem de V1 encuentra entre los k-ésimos ítems más frecuentes a partir de la observación i.

dat[, .(V1, rank=sapply(1:length(V1), function(x) cum_ranks[x, V1[x]]))]

El primer bloque de código toma solo 0.6883929 segundos en mi máquina (de acuerdo con un crudo now <- Sys.time(); [code block in here]; Sys.time() - now tiempo), con dat <- data.table(sample(1:50, 10000, replace=T))

Answer 2

Esto es lo que tengo hasta ahora (mi solución es f3):

set.seed(10)
dat<-data.table(sample(1:3,100,replace=T))
k<-1
f3 <- function(dat) {
correct <- 0 # total correct predictions
vf <- factor(dat$V1)
v <- as.integer(vf)
tabs <- integer(max(v))
for (i in 2:(nrow(dat)-1)) {
tabs[v[i-1]] <- tabs[v[i-1]] + 1
#print(tabs)
#print(v[1:i])
if (match(v[i],order(tabs,decreasing = T))<=k) {
correct <- correct + 1
}
#print(correct)
#print('''')
}
correct
}
f1 <- function(dat) {
correct <- 0 # total correct predictions
for (i in 2:(nrow(dat)-1)) {
if (dat[i,V1] %in% dat[1:(i-1),.N,by=V1][order(-N),head(.SD,k)]) {
correct <- correct + 1
}
}
correct
}
library(rbenchmark)
print(f1(dat)==f3(dat))
library(rbenchmark)
benchmark(f1(dat),f3(dat),replications=10)

Los resultados de referencia:

 test replications elapsed relative user.self sys.self user.child sys.child
1 f1(dat) 10 2.939 163.278 2.931 0.008 0 0
2 f3(dat) 10 0.018 1.000 0.018 0.000 0 0

son alentadores, pero f3 tiene dos problemas:

1. No siempre proporciona la misma respuesta que el algoritmo de OP porque los lazos se tratan de manera diferente,

2. Hay mucho margen de mejora, porque las tabs se ordenan cada vez.

Answer 3

La condición se cumple automáticamente hasta que se hayan observado los valores k + 1:

startrow <- dat[,list(.I,.GRP),by=V1][.GRP==k+1]$.I[1]
correct <- rep(0L,length(v))
correct[1:(startrow-1)] <- 1L

Puede calcular previamente el número de apariciones que ha tenido hasta ahora un valor de V1 :

ct <- dat[,ct:=1:.N,by=V1]$ct

Durante el ciclo, podemos verificar si el k-ésimo valor más frecuente es eliminado por el valor actual.

1. Coge los primeros k valores y sus cuentas hasta topk <- sort(tapply(ct[1:(startrow-1)],v[1:(startrow-1)],max)) : topk <- sort(tapply(ct[1:(startrow-1)],v[1:(startrow-1)],max))
2. Tenga en cuenta que el primer elemento es el umbral para unirse al club top-k: thresh <- unname(topk[1])
3. Lazo desde el startrow hasta la length(v) , actualizando correct (aquí un vector, no una suma continua) siempre que se cumpla el umbral; y actualizar el club top-k si se cumple el umbral y el valor no está ya en el club.

Eso es; el resto son solo detalles. Aquí está mi función:

ff <- function(dat){
vf <- factor(dat$V1)
v <- as.integer(vf)
ct <- dat[,ct:=1:.N,by=V1]$ct
n <- length(v)
ct <- setNames(ct,v)
startrow <- dat[,list(.I,.GRP),by=V1][.GRP==k+1]$.I[1]
topk <- sort(tapply(ct[1:(startrow-1)],v[1:(startrow-1)],max))
thresh <- unname(topk[1])
correct <- rep(0L,n)
correct[1:(startrow-1)] <- 1L
for (i in startrow:n) {
cti = ct[i]
if ( cti >= thresh ){
correct[i] <- 1L
if ( cti > thresh & !( names(cti) %in% names(topk) ) ){
topk <- sort(c(cti,topk))[-1]
thresh <- unname(topk[1])
}
}
}
sum(correct)
}

Es muy rápido, pero difiere de @MaratTalipov y OP en sus resultados:

set.seed(1)
dat <- data.table(sample(1:50,10000,replace=T))
k <- 5
f1(dat) # 1012
f3(dat) # 1015
ff(dat) # 1719

Aquí está mi punto de referencia (excluyendo el enfoque de OP como encapsulado en f1() , ya que estoy impaciente):

> benchmark(f3(dat),ff(dat),replications=10)[,1:5]
test replications elapsed relative user.self
1 f3(dat) 10 2.68 2.602 2.67
2 ff(dat) 10 1.03 1.000 1.03

Mi función ofrece más coincidencias que las de @Marat y OP porque permite que las relaciones en el umbral cuenten como "correctas", mientras que las suyas solo cuentan las coincidencias para un máximo de k valores seleccionados por cualquier algoritmo que utilice la función de order de R.

Answer 4

[Nueva solución]

Hay una solución dplyr muy rápida y muy dplyr para k=1 . El fC1 continuación trata los lazos por igual, es decir, sin desempate. Verás que puedes imponer cualquier regla de desempate. Y, es realmente rápido.

library(dplyr)
fC1 <- function(dat){
dat1 <- tbl_df(dat) %>%
group_by(V1) %>%
mutate(count=row_number()-1) %>% ungroup() %>% slice(2:n()-1) %>%
filter(count!=0) %>%
mutate(z=cummax(count)) %>%
filter(count==z)
z <- dat1$z
length(z)
}
set.seed(1234)
dat<-data.table(sample(1:5000, 100000, replace=T))
system.time(a1 <- fC1(dat))[3] #returns 120
elapsed
0.04
system.time(a3m <- f3m(dat, 1))[3] #returns 29, same to the Python result which runs about 60s
elapsed
89.72
system.time(a3 <- f3(dat, 1))[3] #returns 31.
elapsed
95.07 

Puede imponer libremente alguna regla de desempate sobre el resultado de fC1 para llegar a soluciones diferentes. Por ejemplo, para llegar a las soluciones f3m o f3 , restringimos la selección de algunas filas de la siguiente manera

fC1_ <- function(dat){
b <- tbl_df(dat) %>%
group_by(V1) %>%
mutate(count=row_number()-1) %>%
ungroup() %>%
mutate(L=cummax(count+1))# %>%
b1 <- b %>% slice(2:(n()-1)) %>%
group_by(L) %>%
slice(1) %>%
filter(count+1>=L& count>0)
b2 <- b %>% group_by(L) %>%
slice(1) %>%
ungroup() %>%
select(-L) %>%
mutate(L=count)
semi_join(b1, b2, by=c("V1", "L")) %>% nrow
}
set.seed(1234)
dat <- data.table(sample(1:50,10000,replace=T))
fC1_(dat)
#[1] 218
f3m(dat, 1)
#[1] 217
f3(dat, 1)
#[1] 218

y para un ejemplo anterior

set.seed(1234)
dat<-data.table(sample(1:5000, 100000, replace=T))
system.time(fC1_(dat))[3];fC1_(dat)
#elapsed
# 0.05
#[1] 29

De alguna manera, no pude extender la solución para general k>1 , así que recurrí a Rcpp.

#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
std::vector<int> countrank(std::vector<int> y, int k) {
std::vector<int> v(y.begin(), y.begin() + k);
std::make_heap(v.begin(), v.end());
std::vector<int> count(y.size());
for(int i=0; i < y.size(); i++){
if(y[i]==0){count[i]=0;}
else{
v.push_back(y[i]); std::push_heap(v.begin(), v.end());
std::pop_heap(v.begin(), v.end()); v.pop_back();
std::vector<int>::iterator it = std::find (v.begin(), v.end(), y[i]);
if (it != v.end()) {count[i]=1;};
}
}
return count;
}

Para k=1 , vale la pena señalar que fC1 es al menos tan rápido como la siguiente versión de fCpp .

 fCpp <- function(dat, k) {
dat1 <- tbl_df(dat) %>%
group_by(V1) %>%
mutate(count=row_number())
x <- dat1$V1
y <- dat1$count-1
z <- countrank(-y, k)
sum(z[2:(nrow(dat)-1)])
}

De nuevo, puede imponer cualquier regla de desempate con un mínimo esfuerzo.

[ f3, f3m funciones]

f3 es de @Marat Talipov y f3m es una enmienda (sin embargo, parece superfluo).

f3m <- function(dat, k){
n <- nrow(dat)
dat1 <- tbl_df(dat) %>%
group_by(V1) %>%
mutate(count=row_number())
x <- dat1$V1
y <- dat1$count
rank <- rep(NA, n)
tablex <- numeric(max(x))
for(i in 2:(n-1)){
if(y[i]==1){rank[i]=NA} #this condition was originally missing
else{
tablex[x[i-1]] = y[i-1]
rank[i]=match(x[i], order(tablex, decreasing = T))
}
}
rank <- rank[2:(n-1)]
sum(rank<=k, na.rm=T)
} 

Consulte el historial de edición para una solución anterior.