Ste*_*eve 18 algorithm r permutation combinatorics
我试图找到一个函数来置换向量的所有唯一排列,同时不计算相同元素类型的子集内的并置.例如:
dat <- c(1,0,3,4,1,0,0,3,0,4)
Run Code Online (Sandbox Code Playgroud)
具有
factorial(10)
> 3628800
Run Code Online (Sandbox Code Playgroud)
可能的排列,但仅限于 10!/(2!*2!*4!*2!)
factorial(10)/(factorial(2)*factorial(2)*factorial(2)*factorial(4))
> 18900
Run Code Online (Sandbox Code Playgroud)
忽略同一元素类型的子集内的并置时的唯一排列.
我可以通过使用unique()和permn()包中的函数来获得这个combinat
unique( permn(dat) )
Run Code Online (Sandbox Code Playgroud)
但这在计算上非常昂贵,因为它涉及枚举n!,这可能比我需要的排列多一个数量级.没有先计算,有没有办法做到这一点n!?
Aar*_*ica 11
编辑:这是一个更快的答案; 再次基于Louisa Gray和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
Run Code Online (Sandbox Code Playgroud)
和代码:
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)
}
Run Code Online (Sandbox Code Playgroud)
它不会返回相同的顺序,但在排序后,结果是相同的.
up1a <- up1[do.call(order, as.data.frame(up1)),]
up2a <- up2[do.call(order, as.data.frame(up2)),]
identical(up1a, up2a)
Run Code Online (Sandbox Code Playgroud)
对于我的第一次尝试,请参阅编辑历史记录.