有效地計算跨多個列的字符串的出現次數

Question

我有一個大型數據框（> 400萬行）， yname3包含存儲字符串的列yname1 ， yname2 ， yname3 ：

yname1 | yname2 | yname3
aaaaaa | bbbaaa | bbaaaa
aaabbb | cccccc | aaaaaa
aaaaaa | aaabbb | dddddd
cccccc | dddddd | eeeeee

現在我想計算所有列中每個字符串的出現總次數。 這些應作為附加列添加：

yname1 | yname2 | yname3 | rcount1 | rcount2 | rcount3
aaaaaa | bbbaaa | bbaaaa |       3 |       1 |       1
aaabbb | cccccc | aaaaaa |       2 |       2 |       3
aaaaaa | aaabbb | dddddd |       3 |       2 |       2
cccccc | dddddd | eeeeee |       2 |       2 |       1

我已經編寫了以下代碼，它完成了這項工作：

data3$rcount1 <- sapply(data3$yname1, function(x) sum(data2$yname1==x)+sum(data2$yname2==x)+sum(data2$yname3==x))
data3$rcount2 <- sapply(data3$yname2, function(x) sum(data2$yname1==x)+sum(data2$yname2==x)+sum(data2$yname3==x))
data3$rcount3 <- sapply(data3$yname3, function(x) sum(data2$yname1==x)+sum(data2$yname2==x)+sum(data2$yname3==x))

但是，這確實很慢，需要花費數天才能計算出來。 我有什么想法可以加快速度嗎？

Answer 1

data.table方法怎么樣：

library(data.table)
setDT(d)

lookup <- melt(d, measure.vars = paste0("yname", 1:3))[, .N, by = value]
#    value N
#1: aaaaaa 3
#2: aaabbb 2
#3: cccccc 2
#4: bbbaaa 1
#5: dddddd 2
#6: bbaaaa 1
#7: eeeeee 1

d[, paste0("rcount", 1:3) :=
   lapply(d, function(x) lookup[x, , on = .(value)][, N])]

#   yname1 yname2 yname3 rcount1 rcount2 rcount3
#1: aaaaaa bbbaaa bbaaaa       3       1       1
#2: aaabbb cccccc aaaaaa       2       2       3
#3: aaaaaa aaabbb dddddd       3       2       2
#4: cccccc dddddd eeeeee       2       2       1

Microbenchmark輸出復制來自bgoldst的例子，但有400,000行。

Unit: seconds
          expr       min        lq      mean    median        uq       max neval
   bgoldst(df) 21.445961 21.628228 21.876051 21.810496 22.091096 22.371697     3  
 alistaire(df) 20.685357 20.961761 21.255457 21.238164 21.540507 21.842850     3  
      jota(dt)  2.629337  2.692613  2.719207  2.755889  2.764141  2.772394     3   
    mhairi(df) 40.780441 41.048345 41.669798 41.316249 42.114476 42.912702     3
   coffein(df) 35.669630 35.678719 36.453257 35.687808 36.845071 38.002334     3 
  espresso(df) 20.823840 20.976175 21.317218 21.128509 21.563907 21.999306     3

Answer 2

在基礎R中，您可以構建一個包含data.frame的未列出值的表，並按值對其進行索引。 確保你索引的是一個字符串，而不是一個因子（因此是as.character ），或者它將被數字而不是名稱索引。

data.frame(df, 
           lapply(df, function(x){data.frame(table(unlist(df))[as.character(x)])['Freq']})
)
#   yname1 yname2 yname3 Freq Freq.1 Freq.2
# 1 aaaaaa bbbaaa bbaaaa    3      1      1
# 2 aaabbb cccccc aaaaaa    2      2      3
# 3 aaaaaa aaabbb dddddd    3      2      2
# 4 cccccc dddddd eeeeee    2      2      1

如果data.frame足夠大而且速度很慢，那么你可以在lapply之外構建表，這樣它只運行一次：

df_table <- table(unlist(df))
data.frame(df, lapply(df, function(x){data.frame(df_table[as.character(x)])['Freq']}))

您也可以將它放在dplyr ，這使它更具可讀性：

       # look up times repeated
df %>% mutate_each(funs(table(unlist(df))[as.character(.)])) %>%   # or mutate_each(funs(df_table[as.character(.)]))
    # fix column names
    select(rcount = starts_with('yname')) %>% 
    # add original df back in
    bind_cols(df, .)
# Source: local data frame [4 x 6]
# 
#   yname1 yname2 yname3 rcount1 rcount2 rcount3
#   (fctr) (fctr) (fctr)  (tabl)  (tabl)  (tabl)
# 1 aaaaaa bbbaaa bbaaaa       3       1       1
# 2 aaabbb cccccc aaaaaa       2       2       3
# 3 aaaaaa aaabbb dddddd       3       2       2
# 4 cccccc dddddd eeeeee       2       2       1

---

數據

df <- structure(list(yname1 = c("aaaaaa", "aaabbb", "aaaaaa", "cccccc"
    ), yname2 = c("bbbaaa", "cccccc", "aaabbb", "dddddd"), yname3 = c("bbaaaa", 
    "aaaaaa", "dddddd", "eeeeee")), .Names = c("yname1", "yname2", 
    "yname3"), row.names = c(NA, -4L), class = "data.frame")

Answer 3

已經有一些很好的解決方案，但是沒有一個使用match()來查找預先計算的頻率表中的每個字符串。 以下是如何做到這一點。 請注意，我選擇as.matrix()為table()的參數和match()的第一個參數生成yname*列的矩陣。

cns <- grep(value=T,'^yname',names(df));
m <- as.matrix(df[cns]);
cnts <- table(m);
df[,paste0('rcount',seq_along(cns))] <- matrix(cnts[match(m,names(cnts))],nrow(df));
df;
##   yname1 yname2 yname3 rcount1 rcount2 rcount3
## 1 aaaaaa bbbaaa bbaaaa       3       1       1
## 2 aaabbb cccccc aaaaaa       2       2       3
## 3 aaaaaa aaabbb dddddd       3       2       2
## 4 cccccc dddddd eeeeee       2       2       1

---

更新：我不敢相信我以前錯過了這個，但表達方式

cnts[match(m,names(cnts))]

可以替換為

cnts[m]

所以根本不需要調用match() 。

我只是重新評估基准測試，發現它並沒有以任何顯着的方式改變我的解決方案的運行時間（可能只是在小規模測試中略微加速）。 推測這是因為索引帶有字符名稱的向量需要內部使用相同類型的match()邏輯，因此上述替換不會獲得任何性能。 但我會說簡潔和簡潔的改進是值得的。

---

標桿

我應該注意到，我對其他一些解決方案進行了一些小的修改，以便產生這些基准測試結果。 最值得注意的是，我想避免為重復執行復制任何輸入，但由於data.tables通過引用傳遞，我不得不修改jota()以使其成為冪等的。 這只涉及對目標yname*列的過濾，我通過grep()調用預先計算到一個名為cns的局部變量，就像我在自己的解決方案中一樣。 為了公平起見，我向所有解決方案添加了相同的grep()調用和過濾邏輯，但markus()除外，它不需要它，因為它分別顯式處理每個列。 我也改變了指數聯接操作上lookup在jota()來lookup[.(value=x),,on='value']因為它不是為我工作，否則。 最后，對於mhairi() ，我通過在所有yname*列中添加Reduce()調用來完成解決方案。

library(microbenchmark);
library(data.table);
library(dplyr);

bgoldst <- function(df) { cns <- grep(value=T,'^yname',names(df)); m <- as.matrix(df[cns]); cnts <- table(m); df[,paste0('rcount',seq_along(cns))] <- matrix(cnts[match(m,names(cnts))],nrow(df)); df; };
markus <- function(df) { df$rcount1 <- sapply(df$yname1, function(x) sum(df$yname1==x)+sum(df$yname2==x)+sum(df$yname3==x)); df$rcount2 <- sapply(df$yname2, function(x) sum(df$yname1==x)+sum(df$yname2==x)+sum(df$yname3==x)); df$rcount3 <- sapply(df$yname3, function(x) sum(df$yname1==x)+sum(df$yname2==x)+sum(df$yname3==x)); df; };
alistaire <- function(df) { cns <- grep(value=T,'^yname',names(df)); df_table <- table(unlist(df[cns])); data.frame(df[cns],lapply(df[cns],function(x){data.frame(Freq=df_table[as.character(x)])})); };
jota <- function(dt) { cns <- grep(value=T,'^yname',names(df)); lookup <- melt(dt, measure.vars = cns)[, .N, by = value]; dt[, paste0("rcount", 1:3) := lapply(dt[,cns,with=F], function(x) lookup[.(value=x), , on = 'value'][, N])]; };
mhairi <- function(df) { cns <- grep(value=T,'^yname',names(df)); all_yname <-do.call(c,df[cns]); rcount <- as.data.frame(table(all_yname)); Reduce(function(df,cn) merge(df, rcount, by.x = cn, by.y = 'all_yname'),cns,df); };
coffein <- function(df) { cns <- grep(value=T,'^yname',names(df)); df2 <- melt(df[cns], id.vars = NULL); df2 <- df2 %>% group_by(value) %>% summarise(n=n()) %>% as.data.frame(); rownames(df2) <- df2$value; df2$value <- NULL; df$r1 <- df2[df$yname1,]; df$r2 <- df2[df$yname2,]; df$r3 <- df2[df$yname3,]; df; };

---

## OP's test case
df <- data.frame(yname1=c('aaaaaa','aaabbb','aaaaaa','cccccc'),yname2=c('bbbaaa','cccccc','aaabbb','dddddd'),yname3=c('bbaaaa','aaaaaa','dddddd','eeeeee'),stringsAsFactors=F);
dt <- as.data.table(df);

ex <- bgoldst(df);
identical(ex,markus(df));
## [1] TRUE
identical(ex,{ y <- alistaire(df); names(y) <- names(ex); rownames(y) <- NULL; cis <- seq_along(df)+ncol(df); y[cis] <- lapply(y[cis],as.integer); y; });
## [1] TRUE
identical(ex,as.data.frame(jota(dt)));
## [1] TRUE
identical(ex,{ y <- mhairi(df); y <- y[c(cns,names(y)[!names(y)%in%cns])]; names(y) <- names(ex); y <- y[do.call(order,Map(match,ex,y)),]; rownames(y) <- NULL; y; });
## [1] TRUE
identical(ex,{ y <- coffein(df); names(y) <- names(ex); y; });
## [1] TRUE

microbenchmark(bgoldst(df),markus(df),alistaire(df),jota(dt),mhairi(df),coffein(df));
## Unit: microseconds
##           expr      min        lq      mean    median       uq      max neval
##    bgoldst(df)  491.373  544.6165  597.4743  575.8350  609.192 2054.872   100
##     markus(df)  375.907  435.5645  463.7258  467.4250  489.022  549.962   100
##  alistaire(df)  754.380  816.1755  849.8749  840.3385  888.021  959.654   100
##       jota(dt) 4143.955 4425.7785 4741.8354 4656.2835 4854.928 7347.930   100
##     mhairi(df) 1938.122 2047.1740 2182.1841 2135.4850 2209.896 3969.045   100
##    coffein(df) 1286.380 1430.9265 1546.3245 1511.3255 1562.430 3319.441   100

---

## scale test
set.seed(1L);
NR <- 4e3L; NC <- 3L; SL <- 6L;
df <- as.data.frame(setNames(nm=paste0('yname',seq_len(NC)),replicate(NC,do.call(paste0,replicate(SL,sample(letters,NR,T),simplify=F)),simplify=F)),stringsAsFactors=F);
dt <- as.data.table(df);

ex <- bgoldst(df);
identical(ex,markus(df));
## [1] TRUE
identical(ex,{ y <- alistaire(df); names(y) <- names(ex); rownames(y) <- NULL; cis <- seq_along(df)+ncol(df); y[cis] <- lapply(y[cis],as.integer); y; });
## [1] TRUE
identical(ex,as.data.frame(jota(dt)));
## [1] TRUE
identical(ex,{ y <- mhairi(df); y <- y[c(cns,names(y)[!names(y)%in%cns])]; names(y) <- names(ex); y <- y[do.call(order,Map(match,y,ex)),]; rownames(y) <- NULL; y; });
## [1] TRUE
identical(ex,{ y <- coffein(df); names(y) <- names(ex); y; });
## [1] TRUE

microbenchmark(bgoldst(df),markus(df),alistaire(df),jota(dt),mhairi(df),coffein(df),times=3L);
## Unit: milliseconds
##           expr        min         lq       mean     median         uq        max neval
##    bgoldst(df)   85.20766   87.00487   88.39154   88.80209   89.98348   91.16487     3
##     markus(df) 3771.08606 3788.97413 3799.08405 3806.86220 3813.08305 3819.30390     3
##  alistaire(df)   83.03348   83.10276   83.18116   83.17204   83.25500   83.33797     3
##       jota(dt)   12.49174   13.82088   14.44939   15.15002   15.42821   15.70640     3
##     mhairi(df)  156.06459  156.36608  158.27256  156.66758  159.37654  162.08551     3
##    coffein(df)  154.02853  154.97215  156.52246  155.91576  157.76942  159.62309     3

Answer 4

我更喜歡上面的答案，但為了完整性，讓我添加一個替代方案，它基於使用唯一字符串作為rownames：

df2 <- melt(df, id.vars = NULL)
df2 <- df2 %>% group_by(value) %>% summarise(n=n()) %>% as.data.frame()
rownames(df2) <- df2$value
df2$value <- NULL

現在我們有一個數據幀，其中包含唯一字符向量的出現次數，字符向量是rownames。 我們可以使用這些來表示所述數據幀。

# df[] <- lapply(df, as.character) # in case they are stored as factors
df$r1 <- df2[df$yname1,]
df$r2 <- df2[df$yname2,]
df$r3 <- df2[df$yname3,]

> df
  yname1 yname2 yname3 r1 r2 r3
1 aaaaaa bbbaaa bbaaaa  3  1  1
2 aaabbb cccccc aaaaaa  2  2  3
3 aaaaaa aaabbb dddddd  3  2  2
4 cccccc dddddd eeeeee  2  2  1

編輯：

看看其他答案，並且考慮到我們開始談論性能，我意識到上面的內容是不必要的復雜，可以改進如下：

df2 <- data.frame(table(unlist(df)), row.names = 1)
df$r1 <- df2[df$yname1,]
df$r2 <- df2[df$yname2,]
df$r3 <- df2[df$yname3,]

這樣可以避免完全調用reshape2和dplyr ，並相應地提高性能。 運用

espresso <- function(df) { 
  cns <- grep(value=T,'^yname',names(df)); 
  df2 <- data.frame(table(unlist(df[cns])), row.names = 1)
  df$r1 <- df2[df$yname1,]; df$r2 <- df2[df$yname2,]; df$r3 <- df2[df$yname3,]; df
};

這個解決方案現在要快得多，但速度不如某些替代方案快。 看到

microbenchmark(bgoldst(df),markus(df),alistaire(df),jota(dt),mhairi(df),coffein(df), espresso(df), times=1000);
Unit: microseconds
          expr      min       lq      mean    median        uq       max neval
   bgoldst(df)  579.447  673.956  739.9614  713.2980  759.0550  3719.153  1000
    markus(df)  549.514  630.123  681.1892  655.1390  679.0870  3767.048  1000
 alistaire(df) 1662.650 1796.287 1957.4346 1851.8795 1921.5840 26532.692  1000
      jota(dt) 5551.147 5897.745 6333.6954 6041.8590 6283.6880 22457.746  1000
    mhairi(df) 2538.450 2717.843 2990.8535 2793.1070 2910.9205 65752.067  1000
   coffein(df) 1636.565 1858.936 2006.7821 1941.2555 2016.7330  4553.044  1000
  espresso(df)  753.496  825.766  910.6520  865.5365  925.4055  4662.091  1000

Answer 5

我認為找到每個唯一值的總和然后加入原始表會更快。

all_yname <-c(df$yname1, df$yname2, df$yname3)
rcount <- as.data.frame(table(all_yname))

merge(df, rcount, by.x = 'yname1', by.y = 'all_yname')

並為每一行重復合並。