Как получить все уникальные перестановки двоичной матрицы и их ранги в R

Question

Я пытаюсь создать al oop, который получит все уникальные матрицы. Единственными параметрами будут диапазон от 0: 1 и матрица размером 4x4. Это будет означать, что будет 65 536 уникальных матриц (2 ^ 16). Я определяю уникальность, поскольку никакие две матрицы не имеют одинаковых элементов в одинаковых координатах. Вот что у меня есть:

binary <- function(m, n)
matrix(sample(0:1, m * n, replace = TRUE), m, n)

, где m = 4 и n = 4.

Не уверен, как сгенерировать al oop, который будет вычислять все уникальные перестановки.

Answer 1

Очень быстрое решение с использованием RcppAlgos::permuteGeneral.

binary2 <- function(m, n) {
  mn <- m*n
  perm <- RcppAlgos::permuteGeneral(v=0:1, m=mn, repetition=TRUE)
  lapply(1:nrow(perm), function(i) matrix(perm[i, ], nrow=m, ncol=n))
}

Изменить: Тест (см. Ниже) показал комбинацию rcpp и @ Onyambu s array решение очень быстрое:

binary3.2 <- function(m, n) {
  mn <- m*n
  perm <- RcppAlgos::permuteGeneral(0:1, mn, TRUE)
  asplit(array(t(perm), c(m, n, 2^(m*n))), 3)
}

Пример с использованием матрицы 2 x 2

binary3.2(2, 2)
# [[1]]
#      [,1] [,2]
# [1,]    0    0
# [2,]    0    0
# 
# [[2]]
#      [,1] [,2]
# [1,]    0    0
# [2,]    0    1
# 
# [[3]]
#      [,1] [,2]
# [1,]    0    1
# [2,]    0    0
# 
# [[4]]
#      [,1] [,2]
# [1,]    0    1
# [2,]    0    1
# 
# [[5]]
#      [,1] [,2]
# [1,]    0    0
# [2,]    1    0
# 
# [[6]]
#      [,1] [,2]
# [1,]    0    0
# [2,]    1    1
# 
# [[7]]
#      [,1] [,2]
# [1,]    0    1
# [2,]    1    0
# 
# [[8]]
#      [,1] [,2]
# [1,]    0    1
# [2,]    1    1
# 
# [[9]]
#      [,1] [,2]
# [1,]    1    0
# [2,]    0    0
# 
# [[10]]
#      [,1] [,2]
# [1,]    1    0
# [2,]    0    1
# 
# [[11]]
#      [,1] [,2]
# [1,]    1    1
# [2,]    0    0
# 
# [[12]]
#      [,1] [,2]
# [1,]    1    1
# [2,]    0    1
# 
# [[13]]
#      [,1] [,2]
# [1,]    1    0
# [2,]    1    0
# 
# [[14]]
#      [,1] [,2]
# [1,]    1    0
# [2,]    1    1
# 
# [[15]]
#      [,1] [,2]
# [1,]    1    1
# [2,]    1    0
# 
# [[16]]
#      [,1] [,2]
# [1,]    1    1
# [2,]    1    1

... и вот microbenchmark

Примечание: используется m <- 4; n <- 4

microbenchmark::microbenchmark(b.rcpp(), b.apply.exp(), b.apply.simp(), 
                               b.asplit.array(), b.array(), b.array_tree(),
                               b.rcpp.array(), b.rcpp.arr.aspl(),
                               times=5L, control=list(warmup=5L))

# Unit: milliseconds
#              expr       min        lq      mean    median        uq      max neval   cld
#          b.rcpp() 388.82227 389.27565 419.43537 408.99157 448.78494 461.3024     5   cd 
#     b.apply.exp() 446.85891 484.10602 502.78558 488.01344 518.98317 575.9664     5    de
#    b.apply.simp() 512.89587 553.52379 588.59234 569.65709 577.65281 729.2322     5     e
#  b.asplit.array() 273.01535 325.13691 320.53399 328.99840 335.36864 340.1507     5  bc  
#         b.array()  27.37996  29.33839  84.25181  39.65228  44.44757 280.4408     5 a    
#    b.array_tree() 322.98764 364.64733 424.07656 391.41701 439.77709 601.5537     5   cd 
#    b.rcpp.array()  51.87000  52.19530  66.88202  53.49471  61.88716 114.9629     5 a    
# b.rcpp.arr.aspl() 261.10201 263.29439 272.21605 278.05505 278.37984 280.2490     5  b   

второй тест

> b.array <- function(m, n) {
+   array(t(expand.grid(rep(list(0:1),m*n))),c(m,n,2^(m*n)))
+ }
> 
> b.asplit.array <- function(m, n) {
+   asplit(array(t(expand.grid(rep(list(0:1),m*n))),c(m,n,2^(m*n))), 3)
+ }
> b.rcpp.arr <- function(m, n) {
+   perm <- RcppAlgos::permuteGeneral(0:1, m*n, TRUE)
+   array(t(perm), c(m, n, 2^(m*n)))
+ }
> 
> b.rcpp.asp.arr <- function(m, n) {
+   perm <- RcppAlgos::permuteGeneral(0:1, m*n, TRUE)
+   asplit(array(t(perm), c(m, n, 2^(m*n))), 3)
+ }
> 
> microbenchmark::microbenchmark(b.array(4, 4), b.asplit.array(4, 4),
+                                b.rcpp.arr(4, 4), b.rcpp.asp.arr(4, 4),
+                                times=100L, control=list(warmup=100L))
Unit: milliseconds
                 expr       min        lq      mean    median        uq      max neval cld
        b.array(4, 4)  22.69801  27.03368  41.87245  33.35203  37.11160 213.8378   100  a 
 b.asplit.array(4, 4) 231.28149 251.42609 302.35571 295.42282 331.09442 492.8092   100   b
     b.rcpp.arr(4, 4)  32.03322  35.92215  55.64920  50.98276  56.55712 220.2534   100  a 
 b.rcpp.asp.arr(4, 4) 245.92865 272.14143 316.28854 307.01918 335.84227 493.5027   100   b
>

Answer 2

Вы можете получить трехмерный массив, выполнив:

 x <- array(t(expand.grid(rep(list(c(0, 1)), 16))), c(4, 4, 2^16))

Чтобы просмотреть первые 2

x[,,1:2]
, , 1

     [,1] [,2] [,3] [,4]
[1,]    0    0    0    0
[2,]    0    0    0    0
[3,]    0    0    0    0
[4,]    0    0    0    0

, , 2

     [,1] [,2] [,3] [,4]
[1,]    1    0    0    0
[2,]    0    0    0    0
[3,]    0    0    0    0
[4,]    0    0    0    0

Чтобы получить это как список матриц:

 asplit(x, 3) # in R version >=4.0.0

или вы могли бы сделать:

 purrr::array_tree(x, 3) 

Answer 3

Более простая (и быстрая) версия кода в @ ответе Бруно . Алгоритм тот же, создать список из 16 векторов 0:1, расширить его до всех возможных двоичных строк и преобразовать каждую строку этого набора данных в матрицу 4x4.

x <- replicate(4*4, 0:1, simplify = FALSE)
apply(expand.grid(x, KEEP.OUT.ATTRS = FALSE), 1, function(x) list(matrix(x, nrow = 4, ncol = 4)))

Теперь окончательная очистка -up.

rm(x)

Редактировать.

Спасибо пользователю @Onyambu.

Даже проще ,

a <- apply(expand.grid(rep(list(0:1),16), KEEP.OUT.ATTRS = FALSE), 1, function(x) list(matrix(x, nrow = 4, ncol = 4)))
unlist(a, rec = FALSE)

И этот с результатом в виде трехмерного массива.

array(t(expand.grid(rep(list(0:1),16))),c(4,4,2^16))

Answer 4

Вот очень медленный код

# Create options
option <- replicate(16, c(0, 1), simplify = FALSE)
vector_possibilities <- expand.grid(option)



matrixes <- list()

for (i in seq_len(nrow(vector_possibilities)))  {
  matrixes[[i]] <- matrix(vector_possibilities[i,],4)
}


matrixes[1]