ggplot - 逐步在R中找到列表中最频繁的项目




r plot title size (3)

我想通过一个列表,并检查该项目是否是列表中最频繁的项目,直到那一点。 我现在使用的解决方案与Python相比非常慢。 有没有一种有效的方法来加速?

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

更一般地说,我最终希望看看一个项目是否是最频繁的项目之一,直到某一点,或者是否有一个k值最高的项目直到某一点。

为了比较,这里是一个非常快速的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

条件自动成立,直到观察到k + 1个值:

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

您可以预先计算V1的值到目前为止的出现次数:

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

在循环过程中,我们可以检查第k个最频繁的值是否被当前值剔除。

  1. 抓住第一个k值和他们的计数,直到startrowtopk <- sort(tapply(ct[1:(startrow-1)],v[1:(startrow-1)],max))
  2. 请注意,第一项是加入top-k俱乐部的门槛: thresh <- unname(topk[1])
  3. startrow循环到length(v) ,每当满足阈值时更新correct (这里是一个向量,而不是一个正在运行的总和); 并且如果达到阈值并且价值还没有在俱乐部中,则更新最高k俱乐部。

而已; 其余的只是细节。 这是我的功能:

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

这是非常快的,但不同于@ MaratTalipov和OP的结果:

set.seed(1)
dat <- data.table(sample(1:50,10000,replace=T))
k   <- 5

f1(dat) # 1012
f3(dat) # 1015
ff(dat) # 1719

这里是我的基准(不包括OP的方法封装在f1() ,因为我很不耐烦):

> 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

我的函数给出比@ Marat和OP更多的匹配,因为它允许在阈值处的关系被计算为“正确”,而他们只计算匹配的最多k个值由任何算法R的order函数使用。


这个解决方案如何:

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

现在,第8个观察值的第二个唯一值的等级存储在:

cum_ranks[8, 2]

您可以像这样逐行获取每个项目的排名(并将其显示在可读的表格中)。 如果第i行的rank <= k,那么V1的第i项是观察值i中的第k个最频繁项。

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

第一个代码块在我的机器上只需要0.6883929秒(根据一个粗糙的now <- Sys.time(); [code block in here]; Sys.time() - now计时),用dat <- data.table(sample(1:50, 10000, replace=T))


[新解决方案]

对于k=1有一个闪电般快速且非常简单的dplyr解决方案。 下面的fC1同样对待领带,也就是说,没有打破平局。 你会看到,你可以强加任何打破规则。 而且,它真的很快。

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 

您可以自由地对fC1的结果施加一些打破平局的规则,以达成不同的解决方案。 例如,为了达到f3mf3解决方案,我们限制一些行的选择如下

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

和更早的例子

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

不知何故,我无法扩展一般k>1的解决方案,所以我诉诸于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;
}

对于k=1 ,值得注意的是fC1至少和下面的Rcpp版本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)])
}

同样,你可以用最小的努力强加任何平局规则。

[ f3, f3m功能]

f3是来自@Marat Talipov, f3mf3m的一些修改(虽然看起来是多余的)。

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

请参阅先前解决方案的编辑历史记录。





data.table