通过将现有矩阵分成组（按因子）并将函数应用于每个子矩阵来创建矩阵答案

【问题标题】：create a matrix by seperating an existing matrix into groups(by factor) and applying a function to each sub-matrix通过将现有矩阵分成组（按因子）并将函数应用于每个子矩阵来创建矩阵
【发布时间】：2019-12-05 11:42:39
【问题描述】：

这个问题最好通过例子来解决：

设置

x1 <- c(1,4,5,6,7,1)
x2 <- c(1,1,2,3,4,1)
x3 <- c(3,4,5,6,7,1)
x4 <- c(1,2,3,5,7,2)
x5 <- c(6,2,3,9,7,2)
x6 <- c(5,2,4,3,2,3)
x7 <- c(6,4,3,1,8,3)



matrix <- t(data.frame(x1,x2,x3,x4,x5,x6,x7))
colnames(matrix)[6] <- "factor"```

我的目标是创建一个矩阵，其中矩阵元素是根据组中元素的列总和计算的，不包括行 (i)。然后我将其除以组中元素的数量减去 1。因此组 1 中的 3 个对象意味着除以 (3-1) =2。

对于每个组，如第 6 列或“因子”所述，我想计算一个相应的矩阵，然后将这些矩阵绑定在一起。

对于第 1 组，所需的矩阵是

output1 <- c(1+3/2, 1+4/2, 2+5/2 ...)
output2 <- c(1+3/2, 4+4/2, 5+5/2...)
output3 <- c(1+1/2, 4+1/2, 5+2/2, 6+3/2 ...)

mat_output1 <- rbind(output1, output2, output3)

对于第 2 组，所需的矩阵是

output4 <- c(6/1 , 2/1, 3/1, 9/1, 7/1 ...)
output5 <- c(1/1,2/1,3/1,5/1,7/1,2/1)
mat_output2 <- rbind(output4, output5)

对于第 3 组

output6 <- c(6/1,4/1,3/1,1/1,8/1,3/1)
output7 <- c(5/1,2/1,4/1,3/1,2/1,3/1)
mat_output3 <- rbind(output6, output7)

具有所需的表单输出：

mat_output <- rbind(mat_output1, mat_output2, mat_output3)

【问题讨论】：

标签： r function group-by apply column-sum

【解决方案1】：

这种方法是一次将每一列相加，然后从列总和中减去每个 i。

#here's a pretty quick base R solution:

do.call(rbind
        ,tapply(seq_len(nrow(matrix))
                , matrix[, 'factor']
                , FUN = function(i) sweep(-matrix[i, -length(matrix)]
                                          , 2
                                          , colSums(matrix[i, -length(matrix)]), `+`) / (length(i)-1)
                )
)

   <NA> <NA> <NA> <NA> <NA> factor
x1    2  2.5  3.5  4.5  5.5      1
x2    2  4.0  5.0  6.0  7.0      1
x3    1  2.5  3.5  4.5  5.5      1
x4    6  2.0  3.0  9.0  7.0      2
x5    1  2.0  3.0  5.0  7.0      2
x6    6  4.0  3.0  1.0  8.0      3
x7    5  2.0  4.0  3.0  2.0      3

# similar but MUCH slower

do.call(rbind
        , by(matrix[, -6]
             , matrix[, 6]
             #, function(x) sweep(-x, 2,colSums(x), FUN = '+') / (nrow(x)-1))
             , function(x) mapply(`-`, colSums(x), x) / (nrow(x) - 1)) #mapply is faster
)

一些表现。请注意，@Ronak 提供了一个警告，因此我更改为 dplyr 建议的代码 mutate_at(vars(-group_cols), ...) 而不是 mutate_all(...)。此外，虽然data.table 在@akrun 中，但我正要在@akrun 发布之前对其进行编辑，它基本上是@Ronak 的dplyr 翻译方式。

@G。 Fernando 的解决方案大约需要 20 秒，因此我将其从配置文件中排除。 @akrun 的基本解决方案是最快的。我个人最喜欢@Ronak 的基础，因为它读起来很好。

#10,000 rows
#1,000 groups
Unit: milliseconds
        expr       min        lq       mean     median        uq       max neval
  dt_version  191.4823  193.7294  201.39367  200.61610  210.0798  211.0581    10
  cole_base2 7688.4689 7948.5534 8159.32689 8224.02570 8358.9145 8560.0802    10
  cole_base3  760.9410  761.6176  789.35789  791.22520  812.1285  822.8938    10
  Ronak_base  378.2914  381.9018  403.30458  403.65600  418.5159  431.2887    10
 Ronak_dplyr 7025.7606 7045.9863 7217.55143 7150.09070 7395.1977 7505.7091    10
  akrun_base   26.3189   27.2791   28.90526   28.03645   29.3622   33.5207    10

#10,000 rows
#100 groups
Unit: milliseconds
        expr      min       lq      mean    median       uq      max neval
  dt_version  32.6928  33.4362  36.27415  37.34835  38.8137  39.9793    10
  cole_base2 770.1962 817.3142 847.01249 846.13940 893.4095 900.8028    10
  cole_base3  97.5201 101.1023 108.46434 102.01210 105.9185 165.3160    10
  Ronak_base 115.7445 117.9968 128.06018 124.27730 129.9934 170.3994    10
 Ronak_dplyr 721.4570 734.6108 747.46815 735.65990 756.1121 787.0906    10
  akrun_base  23.3171  24.4940  26.79405  26.55190  29.1286  30.2099    10

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

n_cols <- 10
n_rows <- 1E5
n_row_per_group <- 100


set.seed(1)
matrix <- matrix(sample(100, n_rows*n_cols, replace = T), ncol = n_cols)
matrix <- cbind(matrix, factor = rep(1:(n_rows / n_row_per_group), each = n_row_per_group))
df <- data.frame(matrix)
dt <- as.data.table(df)

do.call(rbind
        , lapply(unique(matrix[,'factor'])
                 , function(x) {
                   sub_mat <- matrix[matrix[, 'factor'] == x,] 
                   sweep(-sub_mat, 2, colSums(sub_mat), '+') / (nrow(sub_mat) - 1)
         })
)



microbenchmark(
  # cole_base = { #too slow for lots of little groups
  #   do.call(rbind
  #           ,by(matrix[, -6]
  #               , matrix[, 6]
  #               , function(x) mapply(`-`, colSums(x), x) / (nrow(x) - 1)
  #           )
  #   )
  # },
   dt_version = {
    dt[, lapply(.SD, function(x) (sum(x) - x) / (.N - 1)) , by = 'factor']
  }
  ,cole_base2 = {
    do.call(rbind
            , lapply(unique(matrix[,'factor'])
                     , function(x) {
                       sub_mat <- matrix[matrix[, 'factor'] == x,] 
                       sweep(-sub_mat, 2, colSums(sub_mat), '+') / (nrow(sub_mat) - 1)
                     })
    )
  }
  ,cole_base3 = {
    do.call(rbind
            ,tapply(seq_len(nrow(matrix))
                    , matrix[, 'factor']
                    , FUN = function(i) sweep(-matrix[i, -length(matrix)], 2, colSums(matrix[i, -length(matrix)]), `+`) / (length(i)-1)
                    , simplify = F)
    )
  }

  ,Ronak_base = {

    lapply(df[-ncol(df)], function(x) 
      ave(x, df$factor, FUN = function(x) (sum(x) - x)/(length(x) - 1)))
  }
  # ,G_fern_base = { #pretty slow, i hardcoded the factor row - it needs fixed slightly
  #   do.call(rbind,
  #           lapply(levels(factor(matrix[,11])),function(x) {
  #             list=as.list(NULL)
  #             index=which(matrix[,11]==x)
  #             for(i in 1:length(index)){
  #               if(length(index)>2){
  #                 list[[i]]=colSums(matrix[index[-i],])
  #               }else{
  #                 list[[i]]=matrix[index[-i],] 
  #               }
  #               list[[i]]=list[[i]][-11]/(length(index)-1)
  #             }
  #             return(do.call(rbind,list))
  #           })
  #   )
  # }
  , Ronak_dplyr = {
    df %>%
      group_by(factor) %>%
      mutate_at(vars(-group_cols()), ~(sum(.)-.)/ (n() - 1))
  }
  , akrun_base = {
    n1 <- tabulate(matrix[, ncol(matrix)])
    m1 <- rowsum(matrix[,-ncol(matrix)], group = matrix[,ncol(matrix)])
    (m1[rep(seq_len(nrow(m1)), n1),] - matrix[, -ncol(matrix)])/rep(n1 - 1, n1)

  }
  , times = 10
)

【讨论】：

谢谢科尔，我正在寻找类似于 G.Fernandes 所描述的输出（下面的评论）。有没有办法仅根据您的理解来做到这一点？抱歉，如果我没有很好地传达问题。
查看编辑以获取类似于@G 的输出。费尔南德斯。这就是为什么还包括示例输出很重要的原因。

【解决方案2】：

如果我理解你的问题正确，下面的代码可能会解决问题

do.call(rbind,
lapply(levels(factor(matrix[,which(colnames=='factor')])),function(x) {
        list=as.list(NULL)
        index=which(matrix[,which(colnames=='factor')]==x)
        for(i in 1:length(index)){
                if(length(index)>2){
                        list[[i]]=colSums(matrix[index[-i],])
                }else{
                        list[[i]]=matrix[index[-i],] 
                }
                list[[i]]=list[[i]][-which(colnames=='factor')]/(length(index)-1)
        }
        return(do.call(rbind,list))
})
)

从提供的示例代码中获取：

     <NA> <NA> <NA> <NA> <NA>
[1,]    2  2.5  3.5  4.5  5.5
[2,]    2  4.0  5.0  6.0  7.0
[3,]    1  2.5  3.5  4.5  5.5
[4,]    6  2.0  3.0  9.0  7.0
[5,]    1  2.0  3.0  5.0  7.0
[6,]    6  4.0  3.0  1.0  8.0
[7,]    5  2.0  4.0  3.0  2.0

【讨论】：

这太棒了！理想情况下，我想将此代码应用于任何矩阵（任何大小），其中矩阵中的最后一列被命名为“因子”。这段代码会很容易扩展吗？
实际上，因子列不需要在您提供代码的矩阵中。您可以作为独立向量传递（只需更改 matrix[,6] 出现的部分）或将其从最后一列移动到第一列并在代码中将任何 6 更改为 1

【解决方案3】：

如果您将数据转换为数据框而不是具有正确名称的矩阵会更容易。

df <- setNames(data.frame(matrix), c(letters[1:5], "factor"))

然后我们可以使用dplyr 并计算该组的sum 并将其减去当前值除以该组中的行数减1。

library(dplyr)

df %>%
  group_by(factor) %>%
  mutate_all(~(sum(.)-.)/ (n() - 1))

#      a     b     c     d     e factor
#  <dbl> <dbl> <dbl> <dbl> <dbl>  <dbl>
#1     2   2.5   3.5   4.5   5.5      1
#2     2   4     5     6     7        1
#3     1   2.5   3.5   4.5   5.5      1
#4     6   2     3     9     7        2
#5     1   2     3     5     7        2
#6     6   4     3     1     8        3
#7     5   2     4     3     2        3

使用基础 R，您可以使用 lapply 和 ave

df[-ncol(df)] <- lapply(df[-ncol(df)], function(x) 
      ave(x, df$factor, FUN = function(x) (sum(x) - x)/(length(x) - 1)))

【讨论】：

【解决方案4】：

使用data.table的选项

library(data.table)
setDT(df1)[, lapply(.SD, function(x) (sum(x) - x)/(.N-1)), .(factor)]
#   factor a   b   c   d   e
#1:      1 2 2.5 3.5 4.5 5.5
#2:      1 2 4.0 5.0 6.0 7.0
#3:      1 1 2.5 3.5 4.5 5.5
#4:      2 6 2.0 3.0 9.0 7.0
#5:      2 1 2.0 3.0 5.0 7.0
#6:      3 6 4.0 3.0 1.0 8.0
#7:      3 5 2.0 4.0 3.0 2.0

或者我们可以使用base R 和rowsum

n1 <- tabulate(matrix[, 6])
m1 <- rowsum(matrix[,-6], group = matrix[,6])
matrix[, -6] <- (m1[rep(seq_len(nrow(m1)), n1),] - matrix[, -6])/rep(n1 - 1, n1)
matrix
#   [,1] [,2] [,3] [,4] [,5] [,6]
#x1    2  2.5  3.5  4.5  5.5    1
#x2    2  4.0  5.0  6.0  7.0    1
#x3    1  2.5  3.5  4.5  5.5    1
#x4    6  2.0  3.0  9.0  7.0    2
#x5    1  2.0  3.0  5.0  7.0    2
#x6    6  4.0  3.0  1.0  8.0    3
#x7    5  2.0  4.0  3.0  2.0    3

数据

df1 <- as.data.frame(matrix)
names(df1) <- c(letters[1:5], "factor")

【讨论】：

在我对 10 列 * 10,000 行的有限测试中，这些是最快的解决方案，data.table 比您的 base R 快 50%。
@Cole 好的，您能否在您的帖子中更新您的发现。谢谢