R 排列：加速、预测和/或多线程

我正在研究一种算法，它需要连续进行N次测试。测试的排列对结果很重要

问题: 当一些规则适用时，我需要能够限制组合搜索空间。例如：

排列“1,2,3”使下列测试无效。所以我不再需要像“1,2,3,4”或“1,2,3,5”这样的排列。所以我写了一些代码，自己做排列，但是速度很慢

我能做些什么来加快这段代码？还是有我错过的包裹？ 我应该自己在C中实现吗？有没有一种简单的多线程方法？有没有一种简单的方法来预测第n个排列？（这将是一种简洁的方式，以简单的方式实现并行计算；）

多谢各位！ 马克

#permu.with.check示例。
# 02.05.2014; 马克吉斯曼
#如果需要，设置递归限制
#选项（表达式=1e5）
permu.with.checkMarc，根据您最近的评论，这里是一个建议的实现

这是一个非常迭代的解决方案，而且效率不高
产生排列。它假设计算在
testfunc
比置换生成要昂贵得多

基本设置：

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

只要
opts
中有许多元素，就可以重复此过程。如果
这是一个固定数量的水平，那么它不难维持
以当前形式。如果你想用不同的方式重复这一点
如果有很多关卡，那么就不难做到这一点了
尾部递归函数，可能更精细一些。
我需要的是：带有回调的排列算法，它可以决定

如果在这一点上可以删减排列
是否应保存排列
和

能够进行多线程处理
到目前为止，我得到的是一个带有冗余的复杂代码，但到目前为止，它运行得还不错。
我仍然不满意，因为在多线程模式下，无法向用户提供反馈。这是我的代码，希望有人能重用它

如果有人知道如何优化它，请继续。我仍然不确定我关于全局/部分全局变量的想法是否正确

所附代码是一个工作示例，如果“3”是当前排列中的最后一个数字，则该代码将进行删减，并且仅当当前排列的数字总和在此点最高时才进行保存。多线程的缺点：它节省了许多冗余值，因为“最高数字总和”不能在线程中共享，这在这一点上是非常不幸的

问候,，
马克

#permu.new示例
# 05.05.2014; 马克吉斯曼
#如果需要，设置递归限制
#选项（表达式=1e5）
要求（编译器）
compilePKGS（enable=TRUE）
启用JIT（3）
要求（doMC）
CONST_SKIP您是否尝试过分析函数以找到瓶颈？好主意！不知道，R中有一个内置的探查器。“尾巴（x，n=1）”使它变慢了（约46秒，1:10）。使用“x[长度（x）]”时，1:10为~7秒。哇！非常感谢。你对我的实施有什么反馈吗？我既不是R专业人士，也不是数学家……；）马克，@RomanLuštrik的评论是关键。如果瓶颈在测试函数中，那么确定实验条件设计的方法通常不是计算上的问题。进一步的问题：你的排列有多少层？您是否希望耗尽级别的数量？（我有一种机制，可以迭代5+级别置换测试的前3个，然后过滤4个，然后过滤5个，但它假设您的测试更昂贵。）除了与缓存组织有关的极少数例外，多线程最多可以给您n倍的加速，其中n是物理处理器的数量。这可能不是最好地利用你的时间，因为你的剪枝规则可能会带来更大的算法改进。@davidesenstat。我想吃蛋糕。使用“组合”软件包，我每秒计算758000次单芯。我的算法能够智能地修剪，我只有243000左右。修剪很重要，但我两者都需要。如果有办法“教”组合包我的修剪方法。一个平行版本就是我蛋糕上的糖霜；）谢谢你的代码！在我看来，您严重依赖combinat-package中的“permn”。当与大于10 a的置换混在一起时，combinat软件包是。我试图使用它的回调功能，但它使我的盒子不稳定（似乎它预先分配了一个矩阵，这在排列>=15时是个坏主意）。稍后我将分析您的代码。在多线程或置换预处理方面：是什么使您的代码比我的代码更快/更高效/更好？提前感谢您的帮助！：）坦白说，不确定是不是。。。我误读了你的帖子，以为你要的是功能代码，而不是比你更好的代码，对不起。我对
combinat
和
permn
没有太多经验，因为我的公司通常对
combn
和
expand.grid
感到满意。
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))

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

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

  # Example of permu.new
  # 05.05.2014; Marc Giesmann

  # Set if needed Recursion limit
  # options(expressions=1e5)
  require(compiler)
  compilePKGS(enable=TRUE)
  enableJIT(3)

  require(doMC)

  CONST_SKIP <- 1
  CONST_SAVE <- 2
  CONST_VAL  <- 3

  #--------------------- 

  permu.new <- function(perm,fun, values = 0, savemax = 1000){

    #DEFINE INTERNAL FUNCTIONS
    permu.worker.save.max   <- savemax
    permu.worker.save.count <- 1

    permu.worker.global.savelist <- vector(mode="list",length = permu.worker.save.max)

    #Saves permutation. If there are more to save than in savemax defined,
    #it primitlively appends a entry to the list
    permu.worker.save <- function(permutation, values){
      if(permu.worker.save.count > permu.worker.save.max){
        permu.worker.global.savelist[[length(permu.worker.global.savelist)+1]] <<- list(perm=permutation,values=values)
      }else{
        permu.worker.global.savelist[[permu.worker.save.count]] <<- list(perm=permutation,values=values)
      }
      permu.worker.save.count <<- permu.worker.save.count + 1 
    }

    #CREATES RESULTOBJECT
    robj <- function(vals){
      return(vector(mode="numeric",length=2+vals))
    }

    #WORKERBEE. Does the funpart of recursion and calling the callbacks
    permu.worker <- function(perm, current, resultobject, fun){
      #resultobject<- robj.reset(resultobject)  #reset internal values.
      resultobject[1:2] <- 0 #reset internal values.

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

        fix  <- c(current,perm[i])   # calculated elements; fix at this point
        rest <- perm[-i]  # elements yet to permutate

        #Call callback.
        resultobject <- fun(x=fix, resultobject = resultobject)

        #Save permutation?
        if(resultobject[CONST_SAVE]){
          permu.worker.save(fix, resultobject[CONST_VAL])
        }

        #if this is the call with the last
        #value (the deepest,recursive call) or object wanted
        #to skip next iterations stop recursion
        if(length(rest) && !resultobject[CONST_SKIP]){
          resultobject <- permu.worker(rest, fix, resultobject, fun)
        } 
      }#end for

      return(resultobject)
    }

    #DEFINE INTERNAL END
    #BEGIN FUNCTION
    resultobject <- robj(values) #vector(mode="numeric", length=2+values)

    #for(i in 1: length(perm)){
    i<-0
    res<-foreach(i=1: length(perm), .combine=c) %dopar% {
        #calculate the first permutation manually
        resultobject <- permu.worker(perm[i], NULL, resultobject, fun)

        #now do the funny, recursive stuff
        resultobject <- permu.worker(perm[-i], perm[i], resultobject, fun)

        # Now we're ready for the next permutation.
        # Save all the things we need
        return(permu.worker.global.savelist[1:permu.worker.save.count-1])

    }#end foreach

  return(res) 
  }

  #----------------------------------------------------------------
  #EXAMPLE CALLBACK
  # Prunes, if 3 is last number in permutation
  # Saves only, if sum() of permutation is the highes found yet.
  # IMPORTANT: return has to be a "resultobject", which is provided
  # through the parameters. 
  # Use 
  # resultobject[CONST_SKIP] <- TRUE/FALSE (prune after this permutation T/F)
  # resultobject[CONST_SAVE] <- TRUE/FALSE (return this permutation, save it T/F)
  # resultobject[CONST_VAL]  <- NUMERIC (use this to save something for the process)
  #-----------------------------------------------------------------
  perm.callback <- function(x,resultobject){

    #CALCULATE STUFF HERE;
    #Example a global counter;(works only singlethreaded)
    counter <<- counter + 1

    #SKIP EXAMPLE
    #Skip this one? skip next permutations if the last number is 3
    resultobject[CONST_SKIP] <- (x[length(x)] == 3)

    if(resultobject[CONST_SKIP]){
      #another global counter (works only singlethreaded)
      skipped <<- skipped + 1 
    }

    #SAVE EXAMPLE
    #Should we save this permutation?
    #Save only, if sum of permutation is bigger than own value 
    s <- sum(x)
    if(s > resultobject[CONST_VAL]){
      resultobject[CONST_VAL]  <- s
      resultobject[CONST_SAVE] <-TRUE

      #yet another example-counter. (works only singlethreaded)
      saved <<- saved + 1 
    }else{
      resultobject[CONST_SAVE] <-FALSE
    }

    return(resultobject)
  }


  #---------- MAIN
  #counter/skipped/saved are working in singlethreading mode,
  #See usage in perm.callback().
  #
  #Variables show, how many...
  counter <- 0 # ...permutations have been calculated 
  skipped <- 0 # ... have been skipped (last digit was 3)
  saved   <- 0 # ... were saved and returned

  #registerDoMC(4) #uncomment for multithreading
  stime <- system.time(gcFirst = TRUE, expr ={
  result <- permu.new(perm=1:10, fun=perm.callback,values=1)
  })
  cat(as.double(stime[3]), "seconds; ~", (counter / as.double(stime[3])), " calculations/second")