Перечислим все уникальные перечисления вектора в 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