Перечислим все уникальные перечисления вектора в 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!
?
Ответы
Ответ 1
EDIT: Здесь более быстрый ответ; снова основанный на идеях Луизы Грей и Брайса Вагнера, но с более быстрым 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)
Для первой попытки см. историю изменений.
Ответ 2
Следующая функция (которая реализует классическую формулу для повторных перестановок, так же, как вы делали вручную в своем вопросе) выглядит довольно быстро:
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
ОБНОВЛЕНИЕ: Я только что понял, что вопрос состоял в том, чтобы генерировать все уникальные перестановки, а не просто указывать их число - извините за это!
Вы можете улучшить часть unique(perm(...))
с указанием уникальных перестановок для одного меньшего элемента, а затем добавить элементы uniqe перед ними. Ну, мое объяснение может потерпеть неудачу, поэтому пусть источник говорит:
uperm <- function(x) {
u <- unique(x) # unique values of the vector
result <- x # let 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
Пожалуйста, сообщите, если это сработает для вас!
Ответ 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.
Ответ 4
Я действительно не знаю R, но вот как я подошел к проблеме:
Найдите количество элементов каждого типа, т.е.
4 X 0
2 X 1
2 X 3
2 X 4
Сортировка по частоте (которая уже выше).
Начните с наиболее частого значения, которое занимает 4 из 10 точек. Определите уникальные комбинации из 4 значений в 10 доступных местах.
(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)
Перейдите ко второму наиболее частому значению, он занимает 2 из 6 доступных мест и определит его уникальные комбинации из 2 из 6.
(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
Ответ 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