Permutations: Speed up, predict and/or multithread

Question

I'm working on an algorithm, which needs to bruteforce N tests successively. The permutation of the tests is important for the outcome.

Problem: When some rules apply, I need to be able to restrict the combinatoric search space. For example:

Permutation "1,2,3" renders following tests useless. So I don't need permutations like "1,2,3,4" or "1,2,3,5" etc anymore. So I wrote some code, to do permutations by myself, but I'ts slow.

What can I do to make this code faster? Or is there a package out there I missed? Should I implement this in C myself? Is there an easy way to multithread this? Is there an easy way to predict the Nth permutation? (This would be neat, to implement parallel computing the easy way ;)

Thank you very much! Marc

# Example of permu.with.check.
# 02.05.2014; Marc Giesmann

# Set if needed Recursion limit
# options(expressions=1e5)

permu.with.check <- function(perm = c(1,2,3), current = NULL, fun){

  #Optional: Calculate all variants
  #if(is.null(current)){
  #  all.permutations <- 2* (sum(gamma(perm + 1)) - 1)
  #}

  for(i in 1: length(perm)){

    fix  <- perm[i]   # calculated elements; fix at this point
    rest <- perm[-i]  # elements yet to permutate

    #If this is a recursive call, use
    #"current" to complement current fix value
    if(!is.null(current)){
      fix <- c(current,fix)
    }

    #Call callback.
    #If callback returns "FALSE" don't calculate 
    #further permutations with this "fix". Skip i.
    if(fun(x=fix)){

      #if this is the call with the last
      #value (the deepest,recursive call), stop recursion
      if(length(rest) > 0){
        permu.with.check( rest, fix,fun ) #recursive. 
      }
    }
  }

}

# Callback for permu.with.check
# Ignores 3
perm.callback <- function(x){

  #CALCULATE STUFF HERE
  #cat(counter, ". permutation: ",x, "\n")
  counter <<- counter + 1

  #TEST - EXAMPLE:
  # if new number equals 3, we don't need further testing
  if(x[length(x)] == 3){
    return(FALSE)
  }else{
    return(TRUE)
  }

} 

########## MAIN ################

counter <- 0
permu.with.check(perm=1:8, fun=perm.callback)

#Compare with permutations from package Combinations
# counter (from permu.with.check) == 27399
# nrow(permutations(8))           == 40320

#OPTIONAL: Try out Combinations package
#if(!require(Combinations)){
#  install.packages("Combinations", repos = "http://www.omegahat.org/R")
#  require(Combinations)
#}

#nrow(permutations(8))

Answer 1

Marc, based on your recent comment, here is a suggested implementation.

This is a very iterative solution, and not hugely efficient as far as producing the permutations. It assumes that the computation in testfunc is much more expensive than the permutation generation.

Basic setup:

set.seed(123)
opts <- 1:5
library(combinat)
## a little inefficient but functional
permn.lim <- function(x, m=length(x)) {
    tmp <- permn(x)
    if (m >= length(x)) tmp
    else unique(lapply(tmp, `[`, 1:m))
}
testfunc <- function(...) list(results=list(), continue=(runif(1) < 0.3))

Run the first iteration of 3-tuples.

doe3 <- permn.lim(opts, 3)
length(doe3)
## [1] 60
str(head(doe3, n=2))
## List of 2
##  $ : int [1:3] 1 2 3
##  $ : int [1:3] 1 2 5
tmp3 <- lapply(doe3, testfunc)
str(head(tmp3, n=2))
## List of 2
##  $ :List of 2
##   ..$ results : list()
##   ..$ continue: logi TRUE
##  $ :List of 2
##   ..$ results : list()
##   ..$ continue: logi FALSE
results3 <- sapply(tmp3, function(zz) zz$results)
continue3 <- sapply(tmp3, function(zz) zz$continue)
head(continue3, n=2)
## [1]  TRUE FALSE
length(doe3.continue <- doe3[continue3])
## [1] 19

results3 is a list of each actual test result (allegedly captured in testfunc), and continue3 is a vector of bools indicating if continued work with that respective 3-tuple is justified. For lookup purposes , we then filter doe3 into doe3.continue.

We then generate the next series of experiments (4, in this case), and filter that based on the successful tests from the previous, as stored in doe3.continue.

doe4.all <- permn.lim(opts, 4)
length(doe4.all)
## [1] 120
doe4.filtered <- Filter(function(zz) list(zz[1:3]) %in% doe3.continue, doe4.all)
length(doe4.filtered)
## [1] 38
tmp4 <- lapply(doe4.filtered, testfunc)
results4 <- sapply(tmp4, function(zz) zz$results)
continue4 <- sapply(tmp4, function(zz) zz$continue)
doe4.continue <- doe4[continue4]
length(doe4.continue)
## [1] 35

This process can be repeated for as many elements are in opts. If this is for a fixed number of levels, then it's not hard to maintain in the current form. If you will be repeating this with different numbers of levels, then it wouldn't be too hard to make this a tail-recursive function, perhaps a little more refined.