Generating all distinct permutations of a list in R

Question

I'm trying to create a list of permutations of a list, such that, for example, perms(list("a", "b", "c")) returns

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"))

I'm not sure how to proceed, any help would be greatly appreciated.

Answer 1

A while back I had to do this in base R without loading any packages.

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)
    }
}

Usage:

> 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" 

Answer 2

combinat::permn will do that work:

> 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"

Note that calculation is huge if the element is large.

Answer 3

base R can also provide the answer:

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}),]

Answer 4

You can try permutations() from the gtools package, but unlike permn() from combinat, it doesn't output a list:

> 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" 

Answer 5

A solution in base R, no dependencies on other packages:

> getPermutations <- 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)
    }
}

> getPermutations(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"

I hope this helps.

Answer 6

Try:

> 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

As suggested by @Adrian in comments, last line can be replaced by:

eg[apply(eg, 1, anyDuplicated) == 0, ]

Answer 7

# 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" 

Answer 8

A fun solution "probabilistic" using sample for base 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

basically you call many random samples, hoping to get them all, and you unique them.

Answer 9

Behold, the purrr solution:

> 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"

Answer 10

We can use base function combn with a little modifcation:

   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"   

Answer 11

In case this helps, there is the "arrangements" package, that allows you to simply do :

> 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" 

Answer 12

A generic version of rnso's answer is:

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, ]
}

Here are two examples:

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" 

One can also slightly alter Rick's answer by using lapply, only doing a single rbind, and reduce the number of [s]/[l]apply calls:

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)
}

Answer 13

What about

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. Then

pmsa(letters[1:3])