Добавление дополнительного условия в исходный пост "R - сгенерировать все возможные попарные комбинации бинарных векторов"
Мой вопрос почти полностью решен в следующем посте.
Исходное сообщение: R - генерировать все возможные попарные комбинации бинарных векторов
Однако у меня есть дополнительное условие, которое сделает некоторые решения недействительными, и мне нужно их удалить. Например, рассмотрим следующие 6 парных выходных данных:
[,1] [,2] [,3]
[1,] 1 0 0
[2,] 0 1 0
[1,] 1 0 0
[2,] 0 0 1
[1,] 0 1 0
[2,] 1 0 0
[1,] 0 1 0
[2,] 0 0 1
[1,] 0 0 1
[2,] 1 0 0
[1,] 0 0 1
[2,] 0 1 0
В моей проблеме 3-я, 5-я и 6-я пары должны быть удалены как недействительные. Условие: следующий вектор не может иметь 1 в позиции, предшествующей предыдущему вектору. Если в первом векторе 1 стоит на 2-й позиции, то во втором векторе 1 может быть либо на 2-й, либо на 3-й позиции, но НЕ В первой.
Возможно ли это реализовать в решении, опубликованном в исходном сообщении? Возможно ли быстрое решение для этого, так как мне нужно работать с большим количеством комбинаций?
Ответы 2
Вы можете получить все такие уникальные комбинации в списке с помощью одной строки в базе R:
lapply(as.data.frame(combn(3, 2)), function(x) +rbind(1:3 == x[1], 1:3 == x[2]))
#> $V1
#> [,1] [,2] [,3]
#> [1,] 1 0 0
#> [2,] 0 1 0
#>
#> $V2
#> [,1] [,2] [,3]
#> [1,] 1 0 0
#> [2,] 0 0 1
#>
#> $V3
#> [,1] [,2] [,3]
#> [1,] 0 1 0
#> [2,] 0 0 1
И это работает для любой разумной длины вектора. Например, длина 4:
lapply(as.data.frame(combn(4, 2)), function(x) +rbind(1:4 == x[1], 1:4 == x[2]))
#> $V1
#> [,1] [,2] [,3] [,4]
#> [1,] 1 0 0 0
#> [2,] 0 1 0 0
#>
#> $V2
#> [,1] [,2] [,3] [,4]
#> [1,] 1 0 0 0
#> [2,] 0 0 1 0
#>
#> $V3
#> [,1] [,2] [,3] [,4]
#> [1,] 1 0 0 0
#> [2,] 0 0 0 1
#>
#> $V4
#> [,1] [,2] [,3] [,4]
#> [1,] 0 1 0 0
#> [2,] 0 0 1 0
#>
#> $V5
#> [,1] [,2] [,3] [,4]
#> [1,] 0 1 0 0
#> [2,] 0 0 0 1
#>
#> $V6
#> [,1] [,2] [,3] [,4]
#> [1,] 0 0 1 0
#> [2,] 0 0 0 1
РЕДАКТИРОВАТЬ
Общее решение для произвольного количества векторов произвольной длины:
get_unique <- function(n_vectors, length)
{
df <- as.data.frame(combn(length, n_vectors))
lapply(df, function(x) {
+do.call(rbind, lapply(x, function(i) seq(length) == i))
})
}
Или, если разрешены повторы:
get_unique <- function(n_vectors, length)
{
df <- as.data.frame(cbind(combn(length, n_vectors),
matrix(rep(seq(length), each = n_vectors),
ncol = length)))
lapply(df, function(x) {
+do.call(rbind, lapply(x, function(i) seq(length) == i))
})
}
Created on 2020-12-12 by the reprex package (v0.3.0)
@Rel_Ai, посмотри мое обновление. Функцию можно использовать для произвольного количества векторов произвольной длины.
Для первоначально опубликованной проблемы ваше решение работает нормально. Однако мне было интересно, можно ли добавить замену? Например, get_unique(2,3) также должен возвращать [(1,0,0):(1,0,0)], [(0,1,0):(0,1,0)], [( 0,0,1):(0,0,1)] как допустимые комбинации?
Я вижу проблему, но не знаю, как представить ее в комментарии. Первая проблема: отсутствуют некоторые допустимые решения (попробуйте с get_unique(3,4)) 2-я проблема: это не работает, когда n_vectors >= length.
Вы можете заменить элемент nth вектора из нулей на 1.
FUN <- function(m, n, ...) {
combn(n, m, function(i, ...) t(sapply(i, function(j, ...) `[<-`(rep(0, n), j, 1))), ...)
}
FUN(2, 3, simplify=FALSE)
# [[1]]
# [,1] [,2] [,3]
# [1,] 1 0 0
# [2,] 0 1 0
#
# [[2]]
# [,1] [,2] [,3]
# [1,] 1 0 0
# [2,] 0 0 1
#
# [[3]]
# [,1] [,2] [,3]
# [1,] 0 1 0
# [2,] 0 0 1
Точки используются для перебора необязательного аргумента simplify=FALSE. Если вы опустите его, вы получите массив. Не знаю, что вы предпочитаете, вы можете установить его по умолчанию.
FUN(2, 3)
# , , 1
#
# [,1] [,2] [,3]
# [1,] 1 0 0
# [2,] 0 1 0
#
# , , 2
#
# [,1] [,2] [,3]
# [1,] 1 0 0
# [2,] 0 0 1
#
# , , 3
#
# [,1] [,2] [,3]
# [1,] 0 1 0
# [2,] 0 0 1
Это также работает с большим количеством строк и столбцов.
FUN(8, 10, simplify=FALSE)
# [[1]]
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
# [1,] 1 0 0 0 0 0 0 0 0 0
# [2,] 0 1 0 0 0 0 0 0 0 0
# [3,] 0 0 1 0 0 0 0 0 0 0
# [4,] 0 0 0 1 0 0 0 0 0 0
# [5,] 0 0 0 0 1 0 0 0 0 0
# [6,] 0 0 0 0 0 1 0 0 0 0
# [7,] 0 0 0 0 0 0 1 0 0 0
# [8,] 0 0 0 0 0 0 0 1 0 0
#
# [[2]]
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
# [1,] 1 0 0 0 0 0 0 0 0 0
# [2,] 0 1 0 0 0 0 0 0 0 0
# [3,] 0 0 1 0 0 0 0 0 0 0
# [4,] 0 0 0 1 0 0 0 0 0 0
# [5,] 0 0 0 0 1 0 0 0 0 0
# [6,] 0 0 0 0 0 1 0 0 0 0
# [7,] 0 0 0 0 0 0 1 0 0 0
# [8,] 0 0 0 0 0 0 0 0 1 0
# ...
РЕДАКТИРОВАТЬ 1
Если вы хотите, чтобы повторяющиеся строки были действительными матрицами, вы можете использовать RcppAlgos::permuteGeneral и проверить, все ли differences больше или равны нулю.
FUN2 <- function(m, n) {
v <- RcppAlgos::permuteGeneral(n, m, rep=T)
v <- as.data.frame(t(v[apply(v, 1, function(x) all(diff(x) >= 0)), ]))
unname(lapply(v, function(j) t(sapply(j, function(k) `[<-`(rep(0, n), k, 1)))))
}
FUN2(2, 3)
# [[1]]
# [,1] [,2] [,3]
# [1,] 1 0 0
# [2,] 1 0 0
#
# [[2]]
# [,1] [,2] [,3]
# [1,] 1 0 0
# [2,] 0 1 0
#
# [[3]]
# [,1] [,2] [,3]
# [1,] 1 0 0
# [2,] 0 0 1
#
# [[4]]
# [,1] [,2] [,3]
# [1,] 0 1 0
# [2,] 0 1 0
#
# [[5]]
# [,1] [,2] [,3]
# [1,] 0 1 0
# [2,] 0 0 1
#
# [[6]]
# [,1] [,2] [,3]
# [1,] 0 0 1
# [2,] 0 0 1
И это быстро!
system.time(FUN2(5, 10))
# user system elapsed
# 1.31 0.00 1.40
Обратите внимание, что есть также функция RcppAlgos::comboGeneral, похожая на базовую combn, но, возможно, более быстрая.
РЕДАКТИРОВАТЬ 2
Мы можем сделать это еще быстрее, используя matrixStats::rowDiffs.
FUN3 <- function(m, n) {
v <- RcppAlgos::permuteGeneral(n, m, rep=T)
v <- as.data.frame(t(v[apply(matrixStats::rowDiffs(v) >= 0, 1, all), ]))
unname(lapply(v, function(j) t(sapply(j, function(k) `[<-`(rep(0, n), k, 1)))))
}
system.time(FUN3(6, 11))
# user system elapsed
# 3.80 0.03 3.96
Я думаю, что ваше решение более полное и работает хорошо. Одной из проблем является скорость, поскольку для FUN2 (5,10) это заняло около 29 секунд.
Да, кажется, вы правы, comboGeneral занял всего 1,21 секунды. Позвольте мне немного поиграть с вашим кодом, но это похоже на отличное решение, которое вы здесь предоставили. Спасибо
@Rel_Ai Посмотрите мое редактирование FUN2, лучше вычислить diff перед созданием матриц, теперь это довольно быстро :)
Есть пара интересных вещей. 1) Я не могу выйти за пределы m=11, когда n=5. хотя количество комбинаций невелико (всего 1365 для этого). 2) FUN3(10,5):12,59 с (1001 комбинация). но FUN3(5,20):4,49 с (42504) комбинаций. Когда m>n, функция работает плохо. Вы видите какой-то выход из этого? Спасибо
@Rel_Ai Я думаю, что это проблема вычислений. Вы можете проверить количество перестановок, используя, например. RcppAlgos::permuteCount(6, 12, repetition=TRUE) и делайте выводы.
Спасибо за ваше решение. На самом деле я ищу общий подход, при котором я могу взять любое количество и длину векторов. например 5 векторов длины 10 или 3 вектора длины 8, что-то в этом роде. Я пытался изменить ваш, но не мог найти выход.