Creating Williams designs with even number of products

[This article was first published on Wiekvoet, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.

A Williams design is a special Latin square with the additional property of first order carry over (each product is followed equally often by each other product). In R the package crossdes can be used to create them.

> williams(4)
     [,1] [,2] [,3] [,4]
[1,]    1    2    4    3
[2,]    2    3    1    4
[3,]    3    4    2    1
[4,]    4    1    3    2
As a consequence of the carry over restriction, the design has the property that a row in this design is also reversed present in the design. Example, row 3 is row 1 reversed. For small designs this property can be used to generate the designs by brute force. Example; a four by four design has without loss of generality the first row and column designated 1 to 4 (using . as unknown).
1 2 3 4
2 . . .
3 . . .
4 . . .
Adding the reversal of the first row gives:
1 2 3 4
2 . . .
3 . . .
4 3 2 1
In practice, for an even number of products the last column can be created as reversed first column.
1 2 3 4
2 . . 3
3 . . 2
4 3 2 1
It is rather obvious that only one solution remains for the 2,2 location and the rest is simple filling in the blanks. The resulting design is the same as the solution of williams(4) with ‘3’ and ‘4’ permuted.
1 2 3 4
2 4 . 3
3 . . 2
4 3 2 1
It is possible to use the same approach for small designs with an even number of products. For an odd number of products the number of rows has to be doubled so this will follow in a later post. To create the design with 6 products a program it is more convenient than manual work. It appears, unknown to many, that using this approach there are two solutions for 6 products. These two solutions are not permutations of each other!
[[1]]
     [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    1    2    3    4    5    6
[2,]    2    4    1    6    3    5
[3,]    3    1    5    2    6    4
[4,]    4    6    2    5    1    3
[5,]    5    3    6    1    4    2
[6,]    6    5    4    3    2    1

[[2]]
     [,1] [,2] [,3] [,4] [,5] [,6]
[1,]    1    2    3    4    5    6
[2,]    2    4    6    1    3    5
[3,]    3    6    2    5    1    4
[4,]    4    1    5    2    6    3
[5,]    5    3    1    6    4    2
[6,]    6    5    4    3    2    1

There are 8 solutions for 8 products and 192 solutions for 10 products. Above that, calculation time is prohibitive. Even to get to 10, the program had to be streamlined considerably.

R code

gendesign <- function(n=6) {
nr <- as.integer(n)
nc <- nr
desmat <- matrix(NA,nrow=nr,ncol=nc)
desmat[1,] <- 1L:nc
desmat[,1] <- 1L:nr
desmat[nr,] <- nc:1L
desmat[,nc] <- nr:1L
carover <- matrix(0L,nrow=nr,ncol=nc)
for (i in 1L:(nc-1L)) carover[i+1,i] <- carover[i,i+1] <- 1L
desobject <- list(desmat=desmat,carover = carover)
desresult <- list()
addpoint(desobject,desresult)
}

nextpos <- function(desmat) which(is.na(desmat),arr.ind=TRUE)

checkdes <- function(desobject,row,col) {
# test for only once carry over 
all(desobject$carover<=1) & 
# each product only once in each row and each column
!any(desobject$desmat[row,-col]== desobject$desmat[row,col],na.rm=TRUE )  &
!any(desobject$desmat[-row,col]== desobject$desmat[row,col],na.rm=TRUE )  
}

addpoint <- function(desobject,desresult) {
todo <- nextpos(desobject$desmat)
if (length(todo)==0) {
l <- length(desresult)
desresult[[l+1]] <- desobject$desmat
return(desresult)
row <- todo[1L,1L]
col <- todo[1L,2L]
nc <- ncol(desobject$desmat)
dob <- desobject
for (i in 1L:nc) {
desobject$desmat[row,col] <- i
desobject$desmat[nc-row+1,nc-col+1] <- i
desobject$carover[desobject$desmat[row,col-1L],i] <- desobject$carover[desobject$desmat[row,col-1],i] + 1L
desobject$carover[i,desobject$desmat[row,col-1L]] <- desobject$carover[i,desobject$desmat[row,col-1L]] + 1L
other <- desobject$desmat[row,col+1L]
if (!is.na(other)) {
desobject$carover[other,i] <- desobject$carover[other,i] + 1
desobject$carover[i,other] <- desobject$carover[i,other] + 1
}
if (checkdes(desobject,row,col)) desresult <- addpoint(desobject,desresult)
desobject <- dob
}
desresult
}
gendesign(6)

To leave a comment for the author, please follow the link and comment on their blog: Wiekvoet.

R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.

Never miss an update!
Subscribe to R-bloggers to receive
e-mails with the latest R posts.
(You will not see this message again.)

Click here to close (This popup will not appear again)