我正在尝试找到一个函数来置换向量的所有唯一排列，同时不计算同一元素类型的子集中的并置。例如：
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!？
答案 0 :(得分：11)
> 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)
首次尝试时，请参阅编辑记录。
答案 1 :(得分：4)
以下函数（实现重复排列的经典公式就像你在问题中手动完成一样）对我来说似乎很快：
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
请报告这是否适合您！
答案 2 :(得分：3)
此处未提及的一个选项是allPerm包中的multicool函数。它可以非常容易地用于获得所有独特的排列：
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
在基准测试中，我发现dat比OP和daroczig的解决方案更快，但比Aaron的解决方案慢。
答案 3 :(得分：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）
然后4个中的2个： （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
答案 4 :(得分：1)
另一个选项是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
答案 5 :(得分：0)
另一个选择是使用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
答案 6 :(得分：0)
由于这个问题已经很久了，并且继续吸引着很多人的意见，因此本帖子仅旨在向R用户告知该语言的当前状态，以执行OP概述的流行任务。正如@RandyLai所暗示的那样，考虑到此任务开发了一些软件包。它们是：arrangements和 RcppAlgos * 。
它们非常高效，并且非常易于使用，可以生成multiset的排列。
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
这些软件包的一个好处是输出在lexicographical order中：
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