Перестановка всех уникальных перечислений вектора в R - PullRequest
Новая
       1

Перестановка всех уникальных перечислений вектора в R

18 голосов
/ 15 апреля 2011

Я пытаюсь найти функцию, которая будет переставлять все уникальные перестановки вектора, не считая сопоставления внутри подмножеств одного и того же типа элемента. Например: 

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!?

Ответы [ 5 ]

11 голосов
/ 16 апреля 2011

РЕДАКТИРОВАТЬ: Вот более быстрый ответ; опять же на основе идей Луизы Грей и Брайса Вагнера, но с более быстрым 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)

Для моей первой попытки см. Историю изменений.

4 голосов
/ 15 апреля 2011

Следующая функция (которая реализует классическую формулу для повторных перестановок так же, как вы делали вручную в своем вопросе) мне кажется довольно быстрой: 

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(...)), указав уникальные перестановки для одного элемента меньше и позжедобавив уникальные элементы перед ними.Ну, моё объяснение может не сработать, поэтому позвольте источнику говорить: 

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

Пожалуйста, сообщите, если это сработает для вас!

3 голосов
/ 18 сентября 2015

Одной из опций, которая здесь не упоминалась, является функция 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.

2 голосов
/ 15 апреля 2011

Я на самом деле не знаю 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
1 голос
/ 25 марта 2016

Другой вариант - пакет 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
...