Permute todas las enumeraciones únicas de un vector en R

Estoy tratando de encontrar una función que permute todas las permutaciones únicas de un vector, sin contar las yuxtaposiciones dentro de subconjuntos del mismo tipo de elemento. Por ejemplo:

dat <- c(1,0,3,4,1,0,0,3,0,4) 

tiene

 factorial(10) > 3628800 

posibles permutaciones, pero solo 10!/(2!*2!*4!*2!)

 factorial(10)/(factorial(2)*factorial(2)*factorial(2)*factorial(4)) > 18900 

permutaciones únicas al ignorar yuxtaposiciones dentro de subconjuntos del mismo tipo de elemento.

Puedo obtener esto usando la función unique() y permn() del paquete combinat

 unique( permn(dat) ) 

pero esto es computacionalmente muy costoso, ya que implica enumerar n! , que puede ser un orden de magnitud más permutaciones de las que necesito. ¿Hay alguna manera de hacerlo sin primero calcular n! ?

EDITAR: Aquí hay una respuesta más rápida; nuevamente basado en las ideas de Louisa Gray y Bryce Wagner, pero con un código R más rápido gracias al mejor uso de la indexación matricial. Es bastante más rápido que mi original:

 > 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 

Y el código:

 uniqueperm2 <- function(d) { dat <- factor(d) N <- length(dat) n <- tabulate(dat) ng <- length(n) if(ng==1) return(d) a <- Nc(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) } 

No devuelve el mismo orden, pero después de la clasificación, los resultados son idénticos.

 up1a <- up1[do.call(order, as.data.frame(up1)),] up2a <- up2[do.call(order, as.data.frame(up2)),] identical(up1a, up2a) 

Para mi primer bash, mira el historial de edición.

La siguiente función (que implementa la fórmula clásica para permutaciones repetidas tal como lo hizo manualmente en su pregunta) me parece bastante rápida:

 upermn <- function(x) { n <- length(x) duplicates <- as.numeric(table(x)) factorial(n) / prod(factorial(duplicates)) } 

Sí computa n! pero no como la función permn que genera todas las permutaciones primero.

Véalo en acción:

 > 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 

ACTUALIZACIÓN: Me acabo de dar cuenta de que la pregunta se trataba de generar todas las permutaciones únicas, no solo especificar el número de ellas, ¡lo siento por eso!

Puede mejorar la parte unique(perm(...)) con la especificación de permutaciones únicas para un elemento menos y luego agregar los elementos únicos delante de ellos. Bueno, mi explicación puede fallar, así que deja que la fuente hable:

 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) } 

De esta forma puedes ganar algo de velocidad. Fui perezoso para ejecutar el código en el vector que me proporcionó (tomó mucho tiempo), aquí hay una pequeña comparación en un vector más pequeño:

 > 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 

¡Creo que podrías ganar mucho más reescribiendo esta función para que sea recursiva!


ACTUALIZACIÓN (nuevamente): Intenté hacer una función recursiva con mi conocimiento limitado:

 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) } 

Lo cual tiene una gran ganancia:

 > 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 

Por favor, informe si esto funcionaría para usted.

Una opción que no se ha mencionado aquí es la función multicool paquete multicool . Se puede usar con bastante facilidad para obtener todas las permutaciones únicas:

 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 

En el benchmarking, encontré que es más rápido en dat que las soluciones de OP y daroczig, pero más lento que la solución de Aaron.

Realmente no sé R, pero así es como abordaría el problema:

Encuentre cuántos de cada tipo de elemento, es decir,

 4 X 0 2 X 1 2 X 3 2 X 4 

Ordenar por frecuencia (que ya es el anterior).

Comience con el valor más frecuente, que ocupa 4 de los 10 puntos. Determine las combinaciones únicas de 4 valores dentro de los 10 lugares disponibles. (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)

Vaya al segundo valor más frecuente, ocupa 2 de los 6 lugares disponibles y determine que se trata de combinaciones únicas de 2 de 6. (0,1), (0,2), (0,3), (0,4) , (0,5), (1,2), (1,3) … (4,6), (5,6)

Luego 2 de 4: (0,1), (0,2), (0,3), (1,2), (1,3), (2,3)

Y los valores restantes, 2 de 2: (0,1)

Entonces necesitas combinarlos en cada combinación posible. Aquí hay un pseudocódigo (estoy convencido de que hay un algoritmo más eficiente para esto, pero esto no debería ser tan malo):

 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 

Otra opción es el paquete iterpc , creo que es el más rápido del método existente. Más importante aún, el resultado está en orden de diccionario (que puede ser de alguna manera preferible).

 dat <- c(1, 0, 3, 4, 1, 0, 0, 3, 0, 4) library(iterpc) getall(iterpc(table(dat), order=TRUE)) 

El punto de referencia indica que iterpc es significativamente más rápido que todos los demás métodos descritos aquí

 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