1getblock <- function(design, combine=FALSE, ...){ 2 di <- design.info(design) 3 aw <- FALSE 4 awro <- FALSE 5 bl <- FALSE 6 sp <- FALSE 7 if (di$replications>1 & !di$repeat.only) aw <- TRUE 8 if (di$replications>1 & di$repeat.only) awro <- TRUE 9 if (length(grep("blocked", di$type, fixed=TRUE))>0) bl <- TRUE 10 if (length(grep("splitplot", di$type, fixed=TRUE))>0) sp <- TRUE 11 if (bl) { 12 if (di$bbreps>1 | (di$wbreps>1 & !di$repeat.only)) aw <- TRUE 13 if (di$wbreps>1 & di$repeat.only) awro <- TRUE 14 } 15 if (bl & !(aw | awro)) stop("Nothing was done, the design contains the appropriate block factor ", di$block.name) 16 if ((!aw) & (!awro) & (!sp)) stop("Nothing was done, as the design does not contain replications or repeated measurements") 17 if (combine & !(bl | (sp & (aw | awro)))) combine <- FALSE ## nothing to combine for aw only 18 ro <- run.order(design) 19 if (!all(ro$run.no == sort(ro$run.no))) 20 stop("getblock does not work for designs that have been reordered after creation") 21 rov <- ro$run.no.std.rp 22 if (is.factor(rov)) rov <- as.character(rov) 23 rovs <- strsplit(rov,".",fixed=TRUE) 24 rovs <- lapply(rovs, as.numeric) 25 26 ncenter <- di$ncenter 27 if (is.null(di$ncenter)) ncenter <- 0 28 29 ## replications only 30 if (!(bl | sp)) { 31 if (aw) blocks <- as.factor(sapply(rovs, function(obj) obj[2])) 32 if (awro) blocks <- as.factor(rep(1:(di$nruns+ncenter), each=di$replications)) 33 } 34 else{ 35 if (bl){ 36 ## blocked designs 37 ## distinguish within and between or both 38 blocks <- factor(sapply(rovs, function(obj) obj[2]), levels=1:di$nblocks) 39 if (di$bbreps > 1) between.reps <- factor(sapply(rovs, function(obj) obj[4]), levels=1:di$bbreps) 40 else { ## then di$wbreps must be larger than 1 41 if (aw) within.reps <- factor(sapply(rovs, function(obj) obj[4]), levels=1:di$wbreps) 42 if (awro) within.reps <- as.factor(rep(1:(di$blocksize+ncenter), each=di$wbreps,times=di$nblocks*di$bbreps)) 43 } 44 ## both 45 if (di$bbreps > 1 & di$wbreps > 1){ 46 if (aw) within.reps <- factor(sapply(rovs, function(obj) obj[5]), levels=1:di$wbreps) 47 if (awro) within.reps <- as.factor(rep(1:(di$blocksize+ncenter), each=di$wbreps,times=di$nblocks*di$bbreps)) 48 } 49 blocks <- data.frame(blocks) 50 if (exists("between.reps")) blocks <- cbind(blocks, between.reps) 51 if (exists("within.reps")) blocks <- cbind(blocks, within.reps) 52 } 53 if (sp){ 54 ## split plot 55 blocks <- factor(sapply(rovs, function(obj) obj[2]), levels=1:di$nWPs) 56 if (aw) 57 blocks <- data.frame(plots=blocks, reps=sapply(strsplit(rov,".",fixed=TRUE), function(obj) obj[4])) 58 if (awro) 59 blocks <- data.frame(plots=blocks, reps=as.factor(rep(1:di$plotsize, each=di$replications,times=di$nWPs))) 60 } 61 if (combine) { 62 ## create single factor from multi-column data frame 63 reihenfolge <- ord(blocks) 64 blocks <- apply(as.matrix(blocks), 1, function(obj) paste(obj,collapse=".")) 65 blocks <- factor(blocks, levels=unique(blocks[reihenfolge])) 66 } 67 } 68 blocks 69} 70