Nothing
get.xblocks.multidim <- function(nrank, blocks, itf, item_not, min, show.warnings){
warn <- 0
if(min){
# If some items should not be used first, separate blocks
if(!is.null(item_not)){
tmp <- apply(matrix(blocks%in%item_not,ncol=nrank),1,any)
not_blocks <- matrix(blocks[tmp,],ncol=nrank)
not_left <- split.matrix(not_blocks,1,nrank)
blocks <- blocks[!tmp,]
}
# Init
tmp_block <- matrix(nrow=0,ncol=nrank)
left <- split.matrix(blocks,1,nrank)
# First iteration of connecting
while(length(left)>=nrank){
tmp <- left[1:nrank]
tmp_left <- unlist(tmp)
left[1:nrank] <- NULL
tmp_choose <- c()
tmp_itf <- c()
for(i in 1:nrank){
tmp2 <- which(itf[tmp[[i]]]%in%tmp_itf)
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
tmp_block <- rbind(tmp_block,matrix(tmp_choose,ncol=nrank))
left[[(length(left)+1)]] <- tmp_left
}
# If some items should not be used first, 1. connect them
if(!is.null(item_not)){
while(length(not_left)>=nrank){
tmp <- not_left[1:nrank]
tmp_left <- unlist(tmp)
not_left[1:nrank] <- NULL
whole_not <- unlist(lapply(lapply(tmp, function(x) x%in%item_not),all))
tmp_choose <- c()
tmp_itf <- c()
warn <- 0
if(any(whole_not)){
for(i in 1:length(tmp)){
tmp2 <- unique(c(which(!tmp[[i]]%in%item_not),which(itf[tmp[[i]]]%in%tmp_itf)))
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
warn <- tmptmp[[2]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
}else{
for(i in 1:length(tmp)){
tmp2 <- unique(c(which(tmp[[i]]%in%item_not),which(itf[tmp[[i]]]%in%tmp_itf)))
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
warn <- tmptmp[[2]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
}
tmp_choose <- matrix(tmp_choose,ncol=nrank)
tmp_block <- rbind(tmp_block,tmp_choose)
if(warn>0&show.warnings){
warning(paste0("The addition of one mixed key block was unavoidable. This concerns block ",nrow(tmp_block),'.'))
}
not_left[[(length(not_left)+1)]] <- tmp_left
}
# 2. add them to the rest
left <- c(not_left,left)
# 3. connect blocks with as least different keyed blocks as possible
while(length(left)>=nrank){
tmp <- left[1:nrank]
tmp_left <- unlist(tmp)
left[1:nrank] <- NULL
any_not <- unlist(lapply(lapply(tmp, function(x) x%in%item_not),any))
whole_not <- unlist(lapply(lapply(tmp, function(x) x%in%item_not),all))
tmp_choose <- c()
tmp_itf <- c()
warn <- 0
if(any(whole_not)&all(any_not)){
for(i in 1:length(tmp)){
tmp2 <- unique(c(which(!tmp[[i]]%in%item_not),which(itf[tmp[[i]]]%in%tmp_itf)))
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
warn <- tmptmp[[2]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
}else{
for(i in 1:length(tmp)){
tmp2 <- unique(c(which(tmp[[i]]%in%item_not),which(itf[tmp[[i]]]%in%tmp_itf)))
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
warn <- tmptmp[[2]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
tmp_block <- rbind(tmp_block,matrix(tmp_choose,ncol=nrank))
if(warn>0&show.warnings){
warning(paste0("The addition of one mixed key block was unavoidable. This concerns block ",nrow(tmp_block),'.'))
}
left[[(length(left)+1)]] <- tmp_left
}
}
}
# Last block
tmp_choose <- c()
tmp_itf <- c()
warn <- 0
if(length(left)!=1){
missing <- nrank-length(left)
tmp <- left
# If some items should not be used first
if(!is.null(item_not)){
any_not <- unlist(lapply(lapply(tmp, function(x) x%in%item_not),any))
whole_not <- unlist(lapply(lapply(tmp, function(x) x%in%item_not),all))
if(any(whole_not)==T){
for(i in 1:length(tmp)){
tmp2 <- which(itf[tmp[[i]]]%in%tmp_itf)
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
warn <- tmptmp[[2]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
}else{
for(i in 1:length(tmp)){
tmp2 <- unique(c(which(tmp[[i]]%in%item_not),which(itf[tmp[[i]]]%in%tmp_itf)))
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
warn <- tmptmp[[2]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
}
num_items <- rev(order(unlist(lapply(left,length))))
for(i in 1:missing){
j <- ifelse(i%%length(left)==0,length(left),i%%length(left))
tmp2 <- unique(c(which(left[[j]]%in%item_not),which(itf[left[[j]]]%in%tmp_itf)))
tmp_choose[length(left)+i] <- sample(unlist(left[num_items[j]])[-c(which(unlist(left[num_items[j]])%in%c(tmp_choose)),tmp2)], size=1)
}
tmp_choose <- matrix(tmp_choose,ncol=nrank)
tmp_block <- rbind(tmp_block,tmp_choose)
left <- unlist(left)
}else{#else
for(i in 1:length(tmp)){
tmp2 <- which(itf[tmp[[i]]]%in%tmp_itf)
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
num_items <- rev(order(unlist(lapply(left,length))))
for(i in 1:missing){
j <- ifelse(i%%length(left)==0,length(left),i%%length(left))
tmp2 <- which(itf[tmp[[j]]]%in%tmp_itf)
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
tmp_choose <- matrix(tmp_choose,ncol=nrank)
tmp_block <- rbind(tmp_block,tmp_choose)
if(warn>0&show.warnings){
warning(paste0("The addition of one mixed key block was unavoidable. This concerns block ",nrow(tmp_block),'.'))
}
left <- unlist(left)
}
}
}else{
# Init
tmp_block <- matrix(nrow=0,ncol=nrank)
left <- split.matrix(blocks,1,nrank)
# First iteration of connecting
while(length(left)>=nrank){
tmp <- left[1:nrank]
tmp_left <- unlist(tmp)
left[1:nrank] <- NULL
tmp_choose <- c()
tmp_itf <- c()
for(i in 1:nrank){
tmp2 <- which(itf[tmp[[i]]]%in%tmp_itf)
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
tmp_block <- rbind(tmp_block,matrix(tmp_choose,ncol=nrank))
left[[(length(left)+1)]] <- tmp_left
}
# Last block
if(length(left)!=1){
tests <- TRUE
while(any(tests)){
tmp_choose <- c()
tmp_itf <- c()
missing <- nrank-length(left)
tmp <- left
for(i in 1:length(tmp)){
tmp2 <- which(itf[tmp[[i]]]%in%tmp_itf)
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
num_items <- rev(order(unlist(lapply(left,length))))
for(i in 1:missing){
j <- ifelse(i%%length(left)==0,length(left),i%%length(left))
tmp2 <- which(itf[tmp[[j]]]%in%tmp_itf)
tmptmp <- choose.item(tmp,tmp2,i,T,itf,tmp_itf,warn)
tmp3 <- tmptmp[[1]]
tmp_itf <- c(tmp_itf,itf[tmp3])
tmp_choose <- c(tmp_choose,tmp3)
}
tests <- c(any(apply(apply(pair.combn(blocksort(rbind(blocks,tmp_block))),1,function(x) x%in%pair.combn(blocksort(matrix(tmp_choose,ncol=nrank)))[1,]),2,all)),
any(apply(apply(pair.combn(blocksort(rbind(blocks,tmp_block))),1,function(x) x%in%pair.combn(blocksort(matrix(tmp_choose,ncol=nrank)))[2,]),2,all)),
any(apply(apply(pair.combn(blocksort(rbind(blocks,tmp_block))),1,function(x) x%in%pair.combn(blocksort(matrix(tmp_choose,ncol=nrank)))[3,]),2,all)))
}
tmp_choose <- matrix(tmp_choose,ncol=nrank)
tmp_block <- rbind(tmp_block,tmp_choose)
left <- unlist(left)
}
}
return(tmp_block)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.