Progressively find most frequent item in list in R - r

Question

I would like to go through a list, and check to see if that item is the most frequent item in the list up until that point. The solution I currently have is incredibly slow compared to Python. Is there an effective way to speed it up?
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
}
}
More generally, I would eventually like to see if an item is one of the k most
frequent items up until a point, or if it has one of the k highest values up until a point.
For comparison, here is a very fast implementation in 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

Here's what I've got so far (my solution is 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)
The benchmark results:
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
are encouraging, but f3 has two problems:
It doesn't always provide the same answer as OP's algorithm because the ties are treated differently,
There is a lot of room for improvement, because tabs are sorted every time anew.

Answer 2

The condition is automatically true up until k+1 values have been observed:
startrow <- dat[,list(.I,.GRP),by=V1][.GRP==k+1]$.I[1]
correct <- rep(0L,length(v))
correct[1:(startrow-1)] <- 1L
You can precompute the number of appearances a value of V1 has had so far:
ct <- dat[,ct:=1:.N,by=V1]$ct
During the loop, we can check if the kth most frequent value is knocked out by the current value.
Grab the first k values and their counts up until startrow: topk <- sort(tapply(ct[1:(startrow-1)],v[1:(startrow-1)],max))
Note that the first item is the threshold for joining the top-k club: thresh <- unname(topk[1])
Loop from startrow to length(v), updating correct (here a vector, not a running sum) whenever the threshold is met; and updating the top-k club if the threshold is met and the value is not already in the club.
That's it; the rest is just details. Here's my function:
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)
}
It is very fast, but differs from #MaratTalipov's and the OP's in its results:
set.seed(1)
dat <- data.table(sample(1:50,10000,replace=T))
k <- 5
f1(dat) # 1012
f3(dat) # 1015
ff(dat) # 1719
Here's my benchmark (excluding the OP's approach as encapsulated in f1(), since I'm impatient):
> 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
My function gives more matches than #Marat's and the OP's because it allows ties at the threshold to count as "correct", while theirs only count matches for at most k values selected by whatever algorithm R's order function uses.

Answer 3

[New Solution]
There is a lightning fast and very easy dplyr solution for k=1. The fC1 below treats the ties equally, i.e., no tie-breaking. You'll see that you can impose any tie-breaking rule on it. And, it is really fast.
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
You can freely impose some tie-breaking rule on the result of fC1 to arrive at a different solutions. For instance, in order to arrive at f3m or f3 solutions, we restrict the selection of some rows as follows
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
and for earlier example
set.seed(1234)
dat<-data.table(sample(1:5000, 100000, replace=T))
system.time(fC1_(dat))[3];fC1_(dat)
#elapsed
# 0.05
#[1] 29
Somehow, I couldn't extend the solution for general k>1, so I resorted to 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;
}
For k=1, it is worth noting that fC1 is at least as fast as the following Rcpp version 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)])
}
Again, you can impose any tie-breaking rule with minimal effort.
[f3, f3m functions]
f3 is from #Marat Talipov and f3m is some amendment to it (seems superfluous though).
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)
}
Refer to the edit history for earlier solution.

Answer 4

How about this solution:
# 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'))
Now the rank of (e.g.) the 2nd unique value as of the 8th observation is stored in:
cum_ranks[8, 2]
You can get the rank of each item by row (and present it in a readable table) like this. If rank <= k for row i, then the i-th item of V1 is among the k-th most frequent items as of observation i.
dat[, .(V1, rank=sapply(1:length(V1), function(x) cum_ranks[x, V1[x]]))]
The first code block takes only 0.6883929 secs on my machine (according to a crude now <- Sys.time(); [code block in here]; Sys.time() - now timing), with dat <- data.table(sample(1:50, 10000, replace=T))