5 回答

• 3

  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
  

  回复于 2024-05-03T20:12:54+08:00
• 5

  在基础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")
  

  回复于 2024-05-03T20:12:54+08:00
• 6

  已经有一些很好的解决方案，但没有人使用 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
  

  ---

  Update: 我不敢相信我以前错过了这个，但表达方式

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

  可以替换为

  cnts[m]
  

  因此根本不需要调用 match() .

  我只是重新评估基准测试，发现它并没有以任何显着的方式改变我的解决方案的运行时间（可能只是在小规模测试中略微加速） . 推测这是因为索引带有字符名称的向量需要内部使用相同类型的 match() 逻辑，因此上述替换不会获得任何性能 . 但我会说简洁和简洁的改进是值得的 .

  ---

  基准测试

  我应该注意到，我对其他一些解决方案进行了一些小的修改，以便产生这些基准测试结果 . 最值得注意的是，我想避免为重复执行复制任何输入，但由于data.tables通过引用传递，我不得不修改 jota() 以使其成为幂等的 . 这只涉及目标 yname* 列的过滤，我通过 grep() 调用预先计算到一个名为 cns 的局部变量，就像我在自己的解决方案中一样 . 为了公平起见，我向所有解决方案添加了相同的 grep() 调用和过滤逻辑，但 markus() 除外，它不需要它，因为它分别显式处理每一列 . 我还将 jota() 中的 lookup 上的索引连接操作更改为 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
  

  回复于 2024-05-03T20:12:54+08:00
• 2

  我更喜欢上面的答案，但为了完整性，让我添加一个替代方案，它基于使用唯一字符串作为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
  

  Edit:

  看看其他答案，并且考虑到我们开始谈论性能，我意识到上面的内容是不必要的复杂，可以改进如下：

  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
  

  回复于 2024-05-03T20:12:54+08:00
• 6

  我认为找到每个唯一值的总和然后加入原始表会更快 .

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

  并为每一行重复合并 .

  回复于 2024-05-03T20:12:54+08:00