Генерация всех различных перестановок списка в R
Я пытаюсь создать список перестановок списка, таких, например, что perms(list("a", "b", "c")) возвращается
list(list("a", "b", "c"), list("a", "c", "b"), list("b", "a", "c"),
list("b", "c", "a"), list("c", "a", "b"), list("c", "b", "a"))
Я не уверен, как поступить, любая помощь будет принята с благодарностью.
13 ответов
Решение
combinat::permn сделаем эту работу:
> library(combinat)
> permn(letters[1:3])
[[1]]
[1] "a" "b" "c"
[[2]]
[1] "a" "c" "b"
[[3]]
[1] "c" "a" "b"
[[4]]
[1] "c" "b" "a"
[[5]]
[1] "b" "c" "a"
[[6]]
[1] "b" "a" "c"
Обратите внимание, что расчет велик, если элемент большой.
Некоторое время назад я должен был сделать это в базе R без загрузки каких-либо пакетов.
permutations <- function(n){
if(n==1){
return(matrix(1))
} else {
sp <- permutations(n-1)
p <- nrow(sp)
A <- matrix(nrow=n*p,ncol=n)
for(i in 1:n){
A[(i-1)*p+1:p,] <- cbind(i,sp+(sp>=i))
}
return(A)
}
}
Использование:
> matrix(letters[permutations(3)],ncol=3)
[,1] [,2] [,3]
[1,] "a" "b" "c"
[2,] "a" "c" "b"
[3,] "b" "a" "c"
[4,] "b" "c" "a"
[5,] "c" "a" "b"
[6,] "c" "b" "a"
База R также может дать ответ:
all <- expand.grid(p1 = letters[1:3], p2 = letters[1:3], p3 = letters[1:3], stringsAsFactors = FALSE)
perms <- all[apply(all, 1, function(x) {length(unique(x)) == 3}),]
Ты можешь попробовать permutations() от gtools пакет, но в отличие от permn() от combinat, он не выводит список:
> library(gtools)
> permutations(3, 3, letters[1:3])
[,1] [,2] [,3]
[1,] "a" "b" "c"
[2,] "a" "c" "b"
[3,] "b" "a" "c"
[4,] "b" "c" "a"
[5,] "c" "a" "b"
[6,] "c" "b" "a"
Решение в базе R, без зависимостей от других пакетов:
> getPerms <- function(x) {
if (length(x) == 1) {
return(x)
}
else {
res <- matrix(nrow = 0, ncol = length(x))
for (i in seq_along(x)) {
res <- rbind(res, cbind(x[i], Recall(x[-i])))
}
return(res)
}
}
> getPerms(letters[1:3])
[,1] [,2] [,3]
[1,] "a" "b" "c"
[2,] "a" "c" "b"
[3,] "b" "a" "c"
[4,] "b" "c" "a"
[5,] "c" "a" "b"
[6,] "c" "b" "a"
Надеюсь, это поможет.
Пытаться:
> a = letters[1:3]
> eg = expand.grid(a,a,a)
> eg[!(eg$Var1==eg$Var2 | eg$Var2==eg$Var3 | eg$Var1==eg$Var3),]
Var1 Var2 Var3
6 c b a
8 b c a
12 c a b
16 a c b
20 b a c
22 a b c
Как предложено @Adrian в комментариях, последняя строка может быть заменена на:
eg[apply(eg, 1, anyDuplicated) == 0, ]
# Another recursive implementation
# for those who like to roll their own, no package required
permutations <- function( x, prefix = c() )
{
if(length(x) == 0 ) return(prefix)
do.call(rbind, sapply(1:length(x), FUN = function(idx) permutations( x[-idx], c( prefix, x[idx])), simplify = FALSE))
}
permutations(letters[1:3])
# [,1] [,2] [,3]
#[1,] "a" "b" "c"
#[2,] "a" "c" "b"
#[3,] "b" "a" "c"
#[4,] "b" "c" "a"
#[5,] "c" "a" "b"
#[6,] "c" "b" "a"
Веселое решение "вероятностный" с использованием образца для базы R:
elements <- c("a", "b", "c")
k <- length(elements)
res=unique(t(sapply(1:200, function(x) sample(elements, k))))
# below, check you have all the permutations you need (if not, try again)
nrow(res) == factorial(k)
res
в основном вы вызываете много случайных выборок, надеясь получить их все, и вы их уникальны.
Вот,
purrr 🐾 решение:
> map(1:3, ~ c('a', 'b', 'c')) %>%
cross() %>%
keep(~ length(unique(.x)) == 3) %>%
map(unlist)
#> [[1]]
#> [1] "c" "b" "a"
#>
#> [[2]]
#> [1] "b" "c" "a"
#>
#> [[3]]
#> [1] "c" "a" "b"
#>
#> [[4]]
#> [1] "a" "c" "b"
#>
#> [[5]]
#> [1] "b" "a" "c"
#>
#> [[6]]
#> [1] "a" "b" "c"
Мы можем использовать базовую функцию combn с небольшой доработкой:
combn_n <- function(x) {
m <- length(x) - 1 # number of elements to choose: n-1
xr <- rev(x) # reversed x
part_1 <- rbind(combn(x, m), xr, deparse.level = 0)
part_2 <- rbind(combn(xr, m), x, deparse.level = 0)
cbind(part_1, part_2)
}
combn_n(letters[1:3])
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] "a" "a" "b" "c" "c" "b"
[2,] "b" "c" "c" "b" "a" "a"
[3,] "c" "b" "a" "a" "b" "c"
В случае, если это поможет, есть пакет "договоренностей", который позволяет вам просто:
> abc = letters[1:3]
> permutations(abc)
[,1] [,2] [,3]
[1,] "a" "b" "c"
[2,] "a" "c" "b"
[3,] "b" "a" "c"
[4,] "b" "c" "a"
[5,] "c" "a" "b"
[6,] "c" "b" "a"
Общая версия ответа rnso :
get_perms <- function(x){
stopifnot(is.atomic(x)) # for the matrix call to make sense
out <- as.matrix(expand.grid(
replicate(length(x), x, simplify = FALSE), stringsAsFactors = FALSE))
out[apply(out,1, anyDuplicated) == 0, ]
}
Вот два примера:
get_perms(letters[1:3])
#R> Var1 Var2 Var3
#R> [1,] "c" "b" "a"
#R> [2,] "b" "c" "a"
#R> [3,] "c" "a" "b"
#R> [4,] "a" "c" "b"
#R> [5,] "b" "a" "c"
#R> [6,] "a" "b" "c"
get_perms(letters[1:4])
#R> Var1 Var2 Var3 Var4
#R> [1,] "d" "c" "b" "a"
#R> [2,] "c" "d" "b" "a"
#R> [3,] "d" "b" "c" "a"
#R> [4,] "b" "d" "c" "a"
#R> [5,] "c" "b" "d" "a"
#R> [6,] "b" "c" "d" "a"
#R> [7,] "d" "c" "a" "b"
#R> [8,] "c" "d" "a" "b"
#R> [9,] "d" "a" "c" "b"
#R> [10,] "a" "d" "c" "b"
#R> [11,] "c" "a" "d" "b"
#R> [12,] "a" "c" "d" "b"
#R> [13,] "d" "b" "a" "c"
#R> [14,] "b" "d" "a" "c"
#R> [15,] "d" "a" "b" "c"
#R> [16,] "a" "d" "b" "c"
#R> [17,] "b" "a" "d" "c"
#R> [18,] "a" "b" "d" "c"
#R> [19,] "c" "b" "a" "d"
#R> [20,] "b" "c" "a" "d"
#R> [21,] "c" "a" "b" "d"
#R> [22,] "a" "c" "b" "d"
#R> [23,] "b" "a" "c" "d"
#R> [24,] "a" "b" "c" "d"
Можно также немного изменить ответ Рика, используя
lapply, только один
rbind, и уменьшить количество
[s]/[l]apply звонки:
permutations <- function(x, prefix = c()){
if(length(x) == 1) # was zero before
return(list(c(prefix, x)))
out <- do.call(c, lapply(1:length(x), function(idx)
permutations(x[-idx], c(prefix, x[idx]))))
if(length(prefix) > 0L)
return(out)
do.call(rbind, out)
}
Как насчет
pmsa <- function(l) {
pms <- function(n) if(n==1) return(list(1)) else unlist(lapply(pms(n-1),function(v) lapply(0:(n-1),function(k) append(v,n,k))),recursive = F)
lapply(pms(length(l)),function(.) l[.])
}
This gives a list. затем
pmsa(letters[1:3])