﻿ R – 给定矩阵和幂,生成包含矩阵列的所有唯一组合的多个矩阵 - 代码日志

#### R – 给定矩阵和幂,生成包含矩阵列的所有唯一组合的多个矩阵

``````# all combinations of p elements out of M with repetiton
# c.f. http://www.mathsisfun.com/combinatorics/combinations-permutations.html
comb_rep <- function(p, M) {
combn(M + p - 1, p) - 0:(p - 1)
}

# use cols from mat to form a new matrix
# take row products
col_prod <- function(cols, mat) {
apply(mat[ ,cols], 1, prod)
}

N <- 5
M <- 3
p <- 3
mat <- matrix(1:(N*M),N,M)

col_comb <- lapply(2:p, comb_rep, M)
col_comb
#> [[1]]
#>      [,1] [,2] [,3] [,4] [,5] [,6]
#> [1,]    1    1    1    2    2    3
#> [2,]    1    2    3    2    3    3
#>
#> [[2]]
#>      [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
#> [1,]    1    1    1    1    1    1    2    2    2     3
#> [2,]    1    1    1    2    2    3    2    2    3     3
#> [3,]    1    2    3    2    3    3    2    3    3     3

# prepend original matrix
res_mat <- list()
res_mat[[1]] <- mat
c(res_mat,
lapply(col_comb, function(cols) apply(cols, 2, col_prod, mat)))
#> [[1]]
#>      [,1] [,2] [,3]
#> [1,]    1    6   11
#> [2,]    2    7   12
#> [3,]    3    8   13
#> [4,]    4    9   14
#> [5,]    5   10   15
#>
#> [[2]]
#>      [,1] [,2] [,3] [,4] [,5] [,6]
#> [1,]    1    6   11   36   66  121
#> [2,]    4   14   24   49   84  144
#> [3,]    9   24   39   64  104  169
#> [4,]   16   36   56   81  126  196
#> [5,]   25   50   75  100  150  225
#>
#> [[3]]
#>      [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
#> [1,]    1    6   11   36   66  121  216  396  726  1331
#> [2,]    8   28   48   98  168  288  343  588 1008  1728
#> [3,]   27   72  117  192  312  507  512  832 1352  2197
#> [4,]   64  144  224  324  504  784  729 1134 1764  2744
#> [5,]  125  250  375  500  750 1125 1000 1500 2250  3375
``````

``````# original function from @Moody_Mudskipper's answer
fun <- function(mat,p) {
mat <- as.data.frame(mat)
combs <- do.call(expand.grid,rep(list(seq(ncol(mat))),p)) # all combinations including permutations of same values
combs <- combs[!apply(combs,1,is.unsorted),]              # "unique" permutations only
rownames(combs) <- apply(combs,1,paste,collapse="-")      # Just for display of output, we keep info of combinations in rownames
combs <- combs[order(rownames(combs)),]                   # sort to have desired column order on output
apply(combs,1,function(x) Reduce(`*`,mat[,x]))            # multiply the relevant columns
}
combined <- function(mat, p) {
mat <- as.data.frame(mat)
combs <- combn(ncol(mat) + p - 1, p) - 0:(p - 1)          # all combinations with repetition
colnames(combs) <- apply(combs, 2, paste, collapse = "-") # Just for display of output, we keep info of combinations in colnames
apply(combs, 2, function(x) Reduce(`*`, mat[ ,x]))        # multiply the relevant columns
}
N <- 10000
M <- 25
p <- 4
mat <- matrix(runif(N*M),N,M)
microbenchmark::microbenchmark(
fun(mat, p),
combined(mat, p),
times = 10
)
#> Unit: seconds
#>              expr      min       lq     mean   median       uq      max neval
#>       fun(mat, p) 3.456853 3.698680 4.067995 4.032647 4.341944 4.869527    10
#>  combined(mat, p) 2.543994 2.738313 2.870446 2.793768 3.090498 3.254232    10
``````