提问人：Steve 提问时间：4/15/2011 最后编辑：Aaron left Stack OverflowSteve 更新时间：5/31/2020 访问量：5843
在 R 中置换向量的所有唯一枚举
Permute all unique enumerations of a vector in R
问：
我正在尝试找到一个函数，该函数将置换向量的所有唯一排列，同时不计算相同元素类型的子集中的并列。例如：
dat <- c(1,0,3,4,1,0,0,3,0,4)
有
factorial(10)
> 3628800
可能的排列，但仅10!/(2!*2!*4!*2!)
factorial(10)/(factorial(2)*factorial(2)*factorial(2)*factorial(4))
> 18900
忽略相同元素类型的子集中的并列时的唯一排列。
我可以通过使用包中的函数来获取它unique()permn()combinat
unique( permn(dat) )
但这在计算上非常昂贵，因为它涉及枚举，这可能比我需要的排列多一个数量级。有没有办法在不首先计算的情况下做到这一点？n!n!
答：
4赞
daroczig
4/15/2011
#1
以下函数（实现重复排列的经典公式，就像您在问题中手动执行的那样）对我来说似乎很快：
upermn <- function(x) {
n <- length(x)
duplicates <- as.numeric(table(x))
factorial(n) / prod(factorial(duplicates))
}
它确实计算，但不像首先生成所有排列的函数。n!permn
查看实际操作：
> dat <- c(1,0,3,4,1,0,0,3,0,4)
> upermn(dat)
[1] 18900
> system.time(uperm(dat))
user system elapsed
0.000 0.000 0.001
更新：我刚刚意识到问题是关于生成所有唯一的排列，而不仅仅是指定它们的数量 - 对不起！
您可以通过为少一个元素指定唯一排列并在其前面添加 uniqe 元素来改进零件。好吧，我的解释可能会失败，所以让消息来源说话：unique(perm(...))
uperm <- function(x) {
u <- unique(x) # unique values of the vector
result <- x # let's start the result matrix with the vector
for (i in 1:length(u)) {
v <- x[-which(x==u[i])[1]] # leave the first occurance of duplicated values
result <- rbind(result, cbind(u[i], do.call(rbind, unique(permn(v)))))
}
return(result)
}
这样你就可以获得一些速度。我懒得在你提供的向量上运行代码（花了很多时间），这是一个较小向量的小比较：
> dat <- c(1,0,3,4,1,0,0)
> system.time(unique(permn(dat)))
user system elapsed
0.264 0.000 0.268
> system.time(uperm(dat))
user system elapsed
0.147 0.000 0.150
我认为你可以通过将这个函数重写为递归来获得更多收益！
更新（再次）：我试图用我有限的知识来编造一个递归函数：
uperm <- function(x) {
u <- sort(unique(x))
l <- length(u)
if (l == length(x)) {
return(do.call(rbind,permn(x)))
}
if (l == 1) return(x)
result <- matrix(NA, upermn(x), length(x))
index <- 1
for (i in 1:l) {
v <- x[-which(x==u[i])[1]]
newindex <- upermn(v)
if (table(x)[i] == 1) {
result[index:(index+newindex-1),] <- cbind(u[i], do.call(rbind, unique(permn(v))))
} else {
result[index:(index+newindex-1),] <- cbind(u[i], uperm(v))
}
index <- index+newindex
}
return(result)
}
这有很大的收获：
> system.time(unique(permn(c(1,0,3,4,1,0,0,3,0))))
user system elapsed
22.808 0.103 23.241
> system.time(uperm(c(1,0,3,4,1,0,0,3,0)))
user system elapsed
4.613 0.003 4.645
如果这对您有用，请报告！
评论
0赞
Steve
4/16/2011
我只是收到最后一个错误 - 错误：评估嵌套太深：无限递归/options（expressions=）？不过，第一个递归函数运行良好 - 在时间上有很大的改进。非常感谢您抽出宝贵时间。如果你能解决错误，那就太棒了。
0赞
daroczig
4/16/2011
@Steve：最后一个函数在我的机器上运行良好，使用您提供的数据。这里计算需要 17 秒。您是否检查过该函数的最新版本？我已经在 25 分钟前编辑了我的答案。upermuperm(c(1,0,3,4,1,0,0,3,0,4))
0赞
daroczig
4/16/2011
@Steve：你可以在我上面的帖子中找到功能。只需在运行函数之前运行它即可。这用于计算和声明结果矩阵的行数，不要混淆（这对性能有好处）。upermnupermrbind
2赞
Bryce Wagner
4/16/2011
#2
我实际上并不了解 R，但以下是我处理该问题的方法：
找出每种元素类型的数量，即
4 X 0
2 X 1
2 X 3
2 X 4
按频率排序（上面已经是这样了）。
从最频繁的值开始，它占据了 10 个点中的 4 个。确定 10 个可用点内 4 个值的唯一组合。 (0,1,2,3),(0,1,2,4),(0,1,2,5),(0,1,2,6) ...(0,1,2,9),(0,1,3,4),(0,1,3,5) ...(6,7,8,9)
转到第二个最频繁的值，它占据了 6 个可用点中的 2 个，并确定它是 6 个点中的 2 个的唯一组合。 (0,1),(0,2),(0,3),(0,4),(0,5),(1,2),(1,3) ...(4,6),(5,6)
然后是 2 的 4： (0,1),(0,2),(0,3),(1,2),(1,3),(2,3)
其余值为 2/2： (0,1)
然后，您需要将它们组合成每个可能的组合。这里有一些伪代码（我相信有一个更有效的算法，但这应该不会太糟糕）：
lookup = (0,1,3,4)
For each of the above sets of combinations, example: input = ((0,2,4,6),(0,2),(2,3),(0,1))
newPermutation = (-1,-1,-1,-1,-1,-1,-1,-1,-1,-1)
for i = 0 to 3
index = 0
for j = 0 to 9
if newPermutation(j) = -1
if index = input(i)(j)
newPermutation(j) = lookup(i)
break
else
index = index + 1
12赞
Aaron left Stack Overflow
4/16/2011
#3
编辑：这是一个更快的答案;同样基于 Louisa Grey 和 Bryce Wagner 的想法，但由于更好地使用了矩阵索引，R 代码速度更快。它比我原来的要快得多：
> ddd <- c(1,0,3,4,1,0,0,3,0,4)
> system.time(up1 <- uniqueperm(d))
user system elapsed
0.183 0.000 0.186
> system.time(up2 <- uniqueperm2(d))
user system elapsed
0.037 0.000 0.038
代码：
uniqueperm2 <- function(d) {
dat <- factor(d)
N <- length(dat)
n <- tabulate(dat)
ng <- length(n)
if(ng==1) return(d)
a <- N-c(0,cumsum(n))[-(ng+1)]
foo <- lapply(1:ng, function(i) matrix(combn(a[i],n[i]),nrow=n[i]))
out <- matrix(NA, nrow=N, ncol=prod(sapply(foo, ncol)))
xxx <- c(0,cumsum(sapply(foo, nrow)))
xxx <- cbind(xxx[-length(xxx)]+1, xxx[-1])
miss <- matrix(1:N,ncol=1)
for(i in seq_len(length(foo)-1)) {
l1 <- foo[[i]]
nn <- ncol(miss)
miss <- matrix(rep(miss, ncol(l1)), nrow=nrow(miss))
k <- (rep(0:(ncol(miss)-1), each=nrow(l1)))*nrow(miss) +
l1[,rep(1:ncol(l1), each=nn)]
out[xxx[i,1]:xxx[i,2],] <- matrix(miss[k], ncol=ncol(miss))
miss <- matrix(miss[-k], ncol=ncol(miss))
}
k <- length(foo)
out[xxx[k,1]:xxx[k,2],] <- miss
out <- out[rank(as.numeric(dat), ties="first"),]
foo <- cbind(as.vector(out), as.vector(col(out)))
out[foo] <- d
t(out)
}
它不会返回相同的顺序，但排序后，结果是相同的。
up1a <- up1[do.call(order, as.data.frame(up1)),]
up2a <- up2[do.call(order, as.data.frame(up2)),]
identical(up1a, up2a)
对于我的第一次尝试，请参阅编辑历史记录。
评论
0赞
caracal
4/17/2011
功能很好，谢谢！一件小事：长度为 1 的（不是很明智的）边缘情况在循环中失败，因为从那时起只有 1 个分量。dfor(i in 2:ng)foo
0赞
Steve
4/18/2011
@Aaron：有没有一种简单的方法可以修复上面 caracal 提到的错误？
0赞
Aaron left Stack Overflow
4/18/2011
也刚刚意识到这与布莱斯建议的相同。很有可能通过在 R 中更加小心或在 C 中重写来更快地完成组合;如果有人想加快速度，请随意。首先，我确信我在此过程中创建的矩阵比必要的要多。
0赞
jebyrnes
12/8/2011
我想知道 - 有没有办法使用多核或 foreach 来使用多核并加快速度？看起来 out 在 for 循环中不断被覆盖，所以，也许这是不可能的。
0赞
Aaron left Stack Overflow
12/9/2011
不是我在这里使用的算法，不，正是出于你注意到的原因。我相信它可以以一种更聪明的方式重写，其中至少有一部分可以使用多个内核，但我怀疑将它们组合在一起可能取决于所有结果，并且会减慢它的速度。我的直觉是，通过更努力地思考算法或用 C 重写，你可以更容易地获得更多的加速。
3赞
josliber
9/18/2015
#4
这里没有提到的一个选项是包中的函数。它可以很容易地用于获取所有独特的排列：allPermmulticool
library(multicool)
perms <- allPerm(initMC(dat))
dim(perms)
# [1] 18900 10
head(perms)
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
# [1,] 4 4 3 3 1 1 0 0 0 0
# [2,] 0 4 4 3 3 1 1 0 0 0
# [3,] 4 0 4 3 3 1 1 0 0 0
# [4,] 4 4 0 3 3 1 1 0 0 0
# [5,] 3 4 4 0 3 1 1 0 0 0
# [6,] 4 3 4 0 3 1 1 0 0 0
在基准测试中，我发现它比 OP 和 daroczig 的解决方案更快，但比 Aaron 的解决方案慢。dat
评论
0赞
ruggero
9/21/2015
在我的 PC 上，告诉我速度快了大约 7 倍。.microbenchmark(uniqueperm2(dat),allPerm(initMC(dat)))allperm
0赞
Randy Lai
3/26/2016
@ruggero 在我的 Mac 上，比 慢 100 倍，但知道为什么。您能否测试一下以下解决方案的速度？allPerm(initMC())uniqueperm2iterpc
2赞
Randy Lai
3/26/2016
#5
另一种选择是软件包，我相信它是现有方法中最快的。更重要的是，结果是按字典顺序排列的（这可能在某种程度上更可取）。iterpc
dat <- c(1, 0, 3, 4, 1, 0, 0, 3, 0, 4)
library(iterpc)
getall(iterpc(table(dat), order=TRUE))
基准测试表明，这比此处描述的所有其他方法都要快得多iterpc
library(multicool)
library(microbenchmark)
microbenchmark(uniqueperm2(dat),
allPerm(initMC(dat)),
getall(iterpc(table(dat), order=TRUE))
)
Unit: milliseconds
expr min lq mean median
uniqueperm2(dat) 23.011864 25.33241 40.141907 27.143952
allPerm(initMC(dat)) 1713.549069 1771.83972 1814.434743 1810.331342
getall(iterpc(table(dat), order = TRUE)) 4.332674 5.18348 7.656063 5.989448
uq max neval
64.147399 74.66312 100
1855.869670 1937.48088 100
6.705741 49.98038 100
评论
0赞
Randy Lai
9/22/2019
iterpc 已被弃用，请检查软件包。arrangements
0赞
Andrés Felipe Flórez Rivera
2/13/2020
#6
另一种选择是使用 Rcpp 包。不同之处在于它返回一个列表。
//[[Rcpp::export]]
std::vector<std::vector< int > > UniqueP(std::vector<int> v){
std::vector< std::vector<int> > out;
std::sort (v.begin(),v.end());
do {
out.push_back(v);
} while ( std::next_permutation(v.begin(),v.end()));
return out;
}
Unit: milliseconds
expr min lq mean median uq max neval cld
uniqueperm2(dat) 10.753426 13.5283 15.61438 13.751179 16.16061 34.03334 100 b
UniqueP(dat) 9.090222 9.6371 10.30185 9.838324 10.20819 24.50451 100 a
1赞
2 revsJoseph Wood
#7
由于这个问题已经过时了，并且继续吸引着许多观点，因此这篇文章只是为了告知用户该语言在执行 OP 概述的流行任务方面的当前状态。正如@RandyLai所暗示的，有一些软件包是针对此任务开发的。它们是：安排和 RcppAlgos*。R
效率
它们非常有效且非常容易用于生成多集的排列。
dat <- c(1, 0, 3, 4, 1, 0, 0, 3, 0, 4)
dim(RcppAlgos::permuteGeneral(sort(unique(dat)), freqs = table(dat)))
[1] 18900 10
microbenchmark(algos = RcppAlgos::permuteGeneral(sort(unique(dat)), freqs = table(dat)),
arngmnt = arrangements::permutations(sort(unique(dat)), freq = table(dat)),
curaccptd = uniqueperm2(dat), unit = "relative")
Unit: relative
expr min lq mean median uq max neval
algos 1.000000 1.000000 1.0000000 1.000000 1.000000 1.0000000 100
arngmnt 1.501262 1.093072 0.8783185 1.089927 1.133112 0.3238829 100
curaccptd 19.847457 12.573657 10.2272080 11.705090 11.872955 3.9007364 100
通过并行处理，我们可以在更大的示例上获得更高的效率。RcppAlgos
hugeDat <- rep(dat, 2)[-(1:5)]
RcppAlgos::permuteCount(sort(unique(hugeDat)), freqs = table(hugeDat))
[1] 3603600
microbenchmark(algospar = RcppAlgos::permuteGeneral(sort(unique(hugeDat)),
freqs = table(hugeDat), nThreads = 4),
arngmnt = arrangements::permutations(sort(unique(hugeDat)), freq = table(hugeDat)),
curaccptd = uniqueperm2(hugeDat), unit = "relative", times = 10)
Unit: relative
expr min lq mean median uq max neval
algospar 1.00000 1.000000 1.000000 1.000000 1.00000 1.00000 10
arngmnt 3.23193 3.109092 2.427836 2.598058 2.15965 1.79889 10
curaccptd 49.46989 45.910901 34.533521 39.399481 28.87192 22.95247 10
词典顺序
这些包的一个很好的好处是输出是按字典顺序排列的：
head(RcppAlgos::permuteGeneral(sort(unique(dat)), freqs = table(dat)))
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 0 0 0 0 1 1 3 3 4 4
[2,] 0 0 0 0 1 1 3 4 3 4
[3,] 0 0 0 0 1 1 3 4 4 3
[4,] 0 0 0 0 1 1 4 3 3 4
[5,] 0 0 0 0 1 1 4 3 4 3
[6,] 0 0 0 0 1 1 4 4 3 3
tail(RcppAlgos::permuteGeneral(sort(unique(dat)), freqs = table(dat)))
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[18895,] 4 4 3 3 0 1 1 0 0 0
[18896,] 4 4 3 3 1 0 0 0 0 1
[18897,] 4 4 3 3 1 0 0 0 1 0
[18898,] 4 4 3 3 1 0 0 1 0 0
[18899,] 4 4 3 3 1 0 1 0 0 0
[18900,] 4 4 3 3 1 1 0 0 0 0
identical(RcppAlgos::permuteGeneral(sort(unique(dat)), freqs = table(dat)),
arrangements::permutations(sort(unique(dat)), freq = table(dat)))
[1] TRUE
迭代器
此外，这两个软件包都提供了迭代器，允许逐个生成内存高效的排列：
algosIter <- RcppAlgos::permuteIter(sort(unique(dat)), freqs = table(dat))
algosIter$nextIter()
[1] 0 0 0 0 1 1 3 3 4 4
algosIter$nextNIter(5)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 0 0 0 0 1 1 3 4 3 4
[2,] 0 0 0 0 1 1 3 4 4 3
[3,] 0 0 0 0 1 1 4 3 3 4
[4,] 0 0 0 0 1 1 4 3 4 3
[5,] 0 0 0 0 1 1 4 4 3 3
## last permutation
algosIter$back()
[1] 4 4 3 3 1 1 0 0 0 0
## use reverse iterator methods
algosIter$prevNIter(5)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 4 4 3 3 1 0 1 0 0 0
[2,] 4 4 3 3 1 0 0 1 0 0
[3,] 4 4 3 3 1 0 0 0 1 0
[4,] 4 4 3 3 1 0 0 0 0 1
[5,] 4 4 3 3 0 1 1 0 0 0
*我是RcppAlgos
评论
c(0,0,2)permn(c(0,0,2))