[R] Permutations

[Jordi Altirriba Gutiérrez]

  Dear R users,
  First of all, I want to thank the algorithms , time and suggestions to 
Rolf, Robert, Marc, Gabor, Adaikalavan, Cliff, Robin, Erich and Fernando.
  I want to sum up a little bit all the e-mails, the algorithms and the 
results of a test for 1000 permutations (in my last e-mail is explained (+ 
or -) what kind of permutations I wanted).


1.- Gabor Grothendieck
ordered.perm <- function(N) {
   samp <- function() c(apply(matrix(sample(12,12),3),2,sort))
   z <- vector(length=N, mode="character")
   for(i in 1:N)
      while( (z[i]<-paste(samp(),collapse=" ")) %in% z[seq(len=i-1)] ) {}
   matrix(as.numeric(unlist(strsplit(z, split = " "))), nc = 12, byrow = 
TRUE)
}
ordered.perm(1000)
##It's the correct algorithm, there isn't any repetition and there aren't 
"intra-block" permutations.

2.- Rolf Turner (1)
restr.perm <- function ()
{
S <- 4:12
G <- NULL
A <- list(1:3,4:6,7:9,10:12)
for(k in 1:4) {
	for(i in A[[k]]) {
		tmp <- union(i,S)
		tmp <- setdiff(tmp,G)
		if(length(tmp)==0) return(Recall())
		x <- if(length(tmp)==1) tmp else sample(tmp,1)
		G <- c(G,x)
		S <- setdiff(S,G)
	}
	S <- union(S,A[[k]])
	R <- if(k < 4) A[[k+1]] else NULL
	R <- union(R,G)
	S <- setdiff(S,R)
}
G
}

a<-matrix(1,1000,12)
for (i in 1:1000)
{
a[i,]<-restr.perm()
}
##With 1000 permutations I have found 3 "intra-block" permutations.

3.- Rolf Turner (2)
restr.perm2 <- function () {
#
okay <- function (x) {
	m1 <- cbind(1:12,rep(1:4,rep(3,4)))
	m2 <- m1[x,]
	all((m2[,1] == m1[,1]) | (m2[,2] != m1[,2]))
}
#
repeat{
	x <- sample(12,12)
	if(okay(x)) return(x)
}
}

a<-matrix(1,1000,12)
for (i in 1:1000)
{
a[i,]<-restr.perm2()
}
##With 1000 permutations I have found 4 "intra-block" permutations.

4.- Marc Schwartz
library(gregmisc)
  # Create non-allowable 'intra-block' permutations
  # Need a generalizable way to do this, but
  # good enough for now
  a <- permutations(3, 3, 1:3)
  b <- permutations(3, 3, 4:6)
  c <- permutations(3, 3, 7:9)
  d <- permutations(3, 3, 10:12)
  intra <- rbind(a[-1, ], b[-1, ], c[-1, ], d[-1, ])

restr.perm3 <- function(runs)
{
  results <- matrix(numeric(runs * 12), ncol = 12)

  # use Gabor's function to check for row matches
  # between 'x' and 'intra' to filter out in okay()
  f1a <- function(a,b,sep=":")
  {
    f <- function(...) paste(..., sep=sep)
    a2 <- do.call("f", as.data.frame(a))
    b2 <- do.call("f", as.data.frame(b))
    c(table(c(b2,unique(a2)))[a2] - 1)
  }

  okay <- function (x)
  {
    x.match <- matrix(x, ncol = 3, byrow = TRUE)
    all(f1a(x.match, intra) == 0)
  }

  for (i in 1:runs)
  {
    x <- sample(12,12)
    if (okay(x))
      results[i, ] <- x
    else
      results[i, ] <- rep(NA, 12)
  }

  unique(results[complete.cases(results), ])
}

a<-matrix(1,1000,12)
for (i in 1:1000)
{
a[i,]<-restr.perm3()
}
restr.perm3(1000)
##With 1000 permutations, the function has taken 960 and I have found 4 
"intra-block" permutations there.

5.- Fernando Tusell
permutations<-function(elements,blocks) {
   n <- length(elements)
   el.per.block <- n / blocks
   for (i in 1:n) {                    # For each element in turn,
     b <- floor(i/(el.per.block+.1))+1 # find which block it belongs to.
     if (b==blocks)                    # If in the last block, we are done.
       break
     allow.pos <- b*el.per.block + 1   # Find first position it could 
migrate to...
     for (j in (allow.pos:n)) {        # and create permutations with all 
allowable
       perm <- elements                # interchanges.
       perm[i] <- elements[j]
       perm[j] <- elements[i]
       print(perm)
     }
   }    }

permutations(1:12,3)
##There are only 48 permutations

6.- Cliff Lunneborg
swap<-function(data,blocks)
{
dd<- data
cc<- 1:length(data)
bb<- unique(blocks)
aa<- sample(bb,2,replace=FALSE)
a1<- sample(cc[blocks==aa[1]],1)
a2<- sample(cc[blocks==aa[2]],1)
dd[a1]<- data[a2]
dd[a2]<- data[a1]
dd
}

x.d<- c(1,2,3,4,5,6,7,8,9,10,11,12)
x.b<- c(1,1,1,2,2,2,3,3,3,4,4,4)

a<-matrix(1,1000,12)
for (i in 1:1000)
{
if (i==1)
{a[i,]<-swap(x.d,x.b)
f<-swap(x.d,x.b)}
else
{a[i,]<-swap(f,x.b)
f<-swap(f,x.b)}
}

##There are 2 repetitions a 2 "intra-block" permutations

7.- Robin Hankin
a<-matrix(1,200,12)
for (i in 1:200)
{
x <- c(1,2,3,4,5,6,7,8,9,10,11,12)
dim(x) <- c(3,4)
  jj <- t(apply(x,1,sample))
a[i,]<-as.vector(jj)
}
##In 200 permutations, there are 5 repetitions.

Thanks to all and sorryfor the confusion that have generated the 
"intra-block" permutation.

Jordi Altirriba
PhD student
Hospital Clinic - Barcelona - Spain

P.S. I think that I don't have forgot to anybody...(sorry if I have done it)