1"[.design" <- function(x,i,j,drop.attr=TRUE,drop=FALSE){ 2 # if (missing(i)) i <- 1:nrow(x) 3 # if (missing(j)) j <- 1:ncol(x) 4 creator <- sys.call() 5 6 if (missing(j)){ 7 if (identical(sort(i),1:nrow(x)) | identical(i,rep(TRUE, nrow(x)))) { 8 ## only rearrange rows 9 class(x) <- "data.frame" 10 x<-x[i,] 11 attr(x,"run.order") <- attr(x,"run.order")[i,] 12 attr(x,"desnum") <- attr(x,"desnum")[i,] 13 di <- attr(x,"design.info") 14 di$creator <- list(original=di$creator, modify=creator) 15 attr(x,"design.info") <- di 16 class(x) <- c("design","data.frame") 17 return(x)} 18 else{ 19 if (is.logical(i)){ 20 if (!length(i) == nrow(x)) stop("i has wrong length") 21 i <- which(i) 22 } 23 nnew <- length(i) 24 repl <- nnew/nrow(x) 25 di <- design.info(x) 26 ro <- run.order(x) 27 dn <- desnum(x) 28 tab <- table(i) 29 ## replicate with reshuffle 30 if (all(1:nrow(x) %in% as.numeric(names(tab))) & 31 all(as.numeric(names(tab)) %in% 1:nrow(x)) & min(tab)==max(tab)){ 32 ## full replication of original experiment 33 ## allow proper repeated measurements and proper blocked replication only 34 ## otherwise loose attributes 35 replicated <- FALSE 36 if (di$replications>1) replicated <- TRUE 37 if (!is.null(di$wbreps)) if (di$wbreps>1 | di$bbreps>1) replicated <- TRUE 38 if (!replicated){ 39 ## repeat.only 40 if (all(rep(i[nnew%%repl==1],each=repl)==i)){ 41 class(x) <- "data.frame" 42 ro <- ro[rep(1:nrow(x),each=repl),] 43 ro$run.no <- 1:nnew 44 ro$run.no.std.rp <- paste(sapply(strsplit(as.character(ro$run.no.std.rp),".",fixed=TRUE), 45 function(obj) {if (length(obj)==1) obj else paste(obj[-length(obj)],collapse=".")}), 46 rep(1:(repl*di$replications),di$nruns),sep=".") 47 x <- x[i,] 48 rownames(x) <- 1:nnew 49 rownames(ro) <- 1:nnew 50 if (!di$type=="FrF2.blocked") di$replications <- repl 51 else di$wbreps <- repl 52 di$repeat.only <- TRUE 53 attr(x,"design.info") <- di 54 attr(x,"run.order") <- ro 55 dn <- dn[i,] 56 rownames(dn) <- 1:nnew 57 attr(x,"desnum") <- dn 58 class(x) <- c("design","data.frame") 59 return(x) 60 } 61 else{ 62 ## not repeat.only 63 ##cannot handle blocked designs 64 if (di$type == "FrF2.blocked") warning("design was reduced to data.frame without any attributes") 65 else{ 66 proper <- TRUE 67 for (a in 1:repl) 68 if (!all(1:nrow(x) %in% i[(a-1)*repl+(1:nrow(x))])) proper <- FALSE 69 if (proper){ 70 ## repl proper replications 71 class(x) <- "data.frame" 72 ro <- ro[i,] 73 ro$run.no <- 1:nnew 74 ro$run.no.std.rp <- paste(sapply(strsplit(as.character(ro$run.no.std.rp),".",fixed=TRUE), 75 function(obj) {if (length(obj)==1) obj else paste(obj[-length(obj)],collapse=".")}), 76 rep(1:(repl*di$replications),di$nruns),sep=".") 77 x <- x[i,] 78 rownames(x) <- 1:nnew 79 rownames(ro) <- 1:nnew 80 di$replications <- repl 81 di$repeat.only <- FALSE 82 di$creator <- list(original=di$creator, modify=creator) 83 attr(x,"design.info") <- di 84 attr(x,"run.order") <- ro 85 dn <- dn[i,] 86 rownames(dn) <- 1:nnew 87 attr(x,"desnum") <- dn 88 class(x) <- c("design","data.frame") 89 return(x) 90 } 91 } 92 }} 93 ## only rearrange rows with replication 94 ## both repeat.only 95 if (replicated & di$repeat.only & all(rep(i[nnew%%repl==1],each=repl)==i)){ 96 ## can handle blocked designs 97 class(x) <- "data.frame" 98 ro <- ro[rep(1:nrow(x),each=repl),] 99 ro$run.no <- 1:nnew 100 ro$run.no.std.rp <- paste(sapply(strsplit(as.character(ro$run.no.std.rp),".",fixed=TRUE), 101 function(obj) {if (length(obj)==1) obj else paste(obj[-length(obj)],collapse=".")}), 102 rep(1:(repl*di$replications),di$nruns),sep=".") 103 x <- x[i,] 104 rownames(x) <- 1:nnew 105 rownames(ro) <- 1:nnew 106 di$replications <- di$replications*repl 107 di$creator <- list(original=di$creator, modify=creator) 108 attr(x,"design.info") <- di 109 attr(x,"run.order") <- ro 110 dn <- dn[i,] 111 rownames(dn) <- 1:nnew 112 attr(x,"desnum") <- dn 113 class(x) <- c("design","data.frame") 114 return(x) 115 } 116 ## both not repeat.only 117 if (replicated & !di$repeat.only){ 118 ##cannot handle blocked designs 119 proper <- TRUE 120 for (a in 1:repl) 121 if (!all(1:nrow(x) %in% i[(a-1)*repl+(1:nrow(x))])) proper <- FALSE 122 if (proper){ 123 ## repl proper replications 124 class(x) <- "data.frame" 125 ro <- ro[i,] 126 ro$run.no <- 1:nnew 127 ro$run.no.std.rp <- paste(sapply(strsplit(as.character(ro$run.no.std.rp),".",fixed=TRUE), 128 function(obj) {if (length(obj)==1) obj else paste(obj[-length(obj)],collapse=".")}), 129 rep(1:(repl*di$replications),di$nruns),sep=".") 130 x <- x[i,] 131 rownames(x) <- 1:nnew 132 rownames(ro) <- 1:nnew 133 di$replications <- repl 134 di$repeat.only <- FALSE 135 di$creator <- list(original=di$creator, modify=creator) 136 attr(x,"design.info") <- di 137 attr(x,"run.order") <- ro 138 dn <- dn[i,] 139 rownames(dn) <- 1:nnew 140 attr(x,"desnum") <- dn 141 class(x) <- c("design","data.frame") 142 return(x) 143 } 144 } 145 } 146 ## subset rows 147 if (!drop.attr){ 148 class(x) <- "data.frame" 149 aus <- x[i, ,drop=drop] 150 class(aus) <- c("design","data.frame") 151 attr(aus, "desnum") <- dn[i, ,drop=drop] 152 attr(aus, "run.order") <- ro[i,,drop=FALSE] 153 attr(aus, "design.info") <- list(type="subset of design", 154 subset.rows=i, nruns=nnew, nfactors=di$nfactors, factor.names=di$factor.names, 155 replications=1,repeat.only=di$repeat.only, seed=di$seed, 156 randomize=di$randomize, creator=list(original=di$creator, modify=creator), 157 orig.design.info = di) 158 } 159 else{ 160 attr(x, "desnum") <- NULL 161 attr(x, "run.order") <- NULL 162 attr(x, "design.info") <- NULL 163 class(x) <- "data.frame" 164 aus <- x[i,,drop=drop] 165 } 166 } 167 ## next brace is end of missing j 168 } 169 else { class(x) <- "data.frame" 170 aus <- x[i,j,drop=drop]} 171 172 aus 173 } 174 175desnum <- function(design){ 176 if (!"design" %in% class(design)) stop("desnum is applicable for class design only.") 177 else attr(design,"desnum") 178 } 179`desnum<-` <- function(design, value){ 180 if (!"design" %in% class(design)) stop("desnum<- is applicable for class design only.") 181 if (!is.matrix(value)) stop("value for desnum must be a matrix") 182 if (!nrow(value)==nrow(design)) 183 stop("mismatch between numbers of rows for value and design") 184 if (!ncol(value)>=ncol(design)) 185 stop("value does not contain enough columns") 186 attr(design,"desnum") <- value 187 design 188 } 189 190run.order <- function(design){ 191 if (!"design" %in% class(design)) stop("run.order is applicable for class design only.") 192 else attr(design,"run.order") 193 } 194`run.order<-` <- function(design, value){ 195 if (!"design" %in% class(design)) stop("run.order<- is applicable for class design only.") 196 if (!is.data.frame(value)) stop("value for run.order must be a data frame") 197 if (!nrow(value)==nrow(design)) stop("value and design must have the same number of rows") 198 if (!(all(c("run.no.in.std.order","run.no","run.no.std.rp") %in% colnames(value)) 199 | all(c("run.no.in.std.order","run.no.1","run.no.std.rp.1") %in% colnames(value)))) 200 stop("value does not contain all necessary columns") 201 ## covers the long version and the wide reshape with standard settings 202 attr(design,"run.order") <- value 203 design 204 } 205 206design.info <- function(design){ 207 if (!"design" %in% class(design)) stop("design.info is applicable for class design only.") 208 else attr(design,"design.info") 209 } 210 211`design.info<-` <- function(design, value){ 212 if (!"design" %in% class(design)) stop("design.info<- is applicable for class design only.") 213 if (!is.list(value)) stop("value for design.info must be a list") 214 if (!value$nruns*value$replications==nrow(design)){ 215 if (is.null(value$wbreps)) stop("mismatch between content of value and number of rows in design") 216 else if(!value$nruns*value$bbreps*value$wbreps==nrow(design)) 217 stop("mismatch between content of value and number of rows in design")} 218 if (!all(c("type","nruns","nfactors","factor.names","replications", "randomize","seed", "repeat.only", "creator") %in% names(value))) 219 stop("value does not contain all necessary elements") 220 attr(design,"design.info") <- value 221 design 222 } 223 224factor.names <- function(design){ 225 if (!"design" %in% class(design)) stop("design.info is applicable for class design only.") 226 else attr(design,"design.info")$factor.names 227 } 228 229fnmap <- function(design){ 230 ## auxiliary function for function factor.names<- 231 ## function to map each factor level of the R factor 232 ## to the respective position of the factor level 233 ## in the factor.names element of the 234 ## design.info attribute 235 fn <- factor.names(design) 236 nlevels <- sapply(fn, length) 237 nf <- length(fn) 238 facs <- sapply(design, is.factor) 239 maps <- mapply(function(obj) 1:obj, nlevels, SIMPLIFY=FALSE) 240 for (i in 1:nf) 241 if (facs[i]) maps[[i]] <- sapply(levels(design[[i]]), function(obj) which(fn[[i]]==obj)) 242 maps 243} 244 245`factor.names<-` <- function(design, contr.modify=TRUE, levordold=FALSE, value){ 246 di <- design.info(design) 247 if (!(is.list(value) | is.character(value))) stop("value must be a list or a character vector") 248 fnold <- factor.names(design) 249 fnnold <- names(fnold) 250 fnmap <- fnmap(design) 251 252 if (is.character(value)){ 253 if (!length(value)==length(fnold)) stop("value has the wrong length") 254 names(fnold) <- value 255 value <- fnold 256 ## now value is a list 257 } 258 259 if (!length(unique(names(value)))==length(value)) 260 stop("factor names are not unique") 261 262 for (i in 1:length(value)) if (identical(value[[i]],"")) value[[i]] <- fnold[[i]][fnmap[[i]]] 263 264 if (!length(value)==length(fnold)) stop("value has wrong length") 265 ## fac <- sapply(design, "is.factor") 266 if (any(sapply(value,function(obj) !length(obj)==length(unique(obj))))) 267 stop("duplicate factor levels") 268 nlevelsold <- sapply(fnold,"length") 269 nlevelsnew <- sapply(value, "length") 270 if (!all(nlevelsold==nlevelsnew)) 271 stop("some elements of factor.names do not have the right length") 272 273 for (i in 1:length(value)){ 274 ersetze <- FALSE 275 if (nlevelsnew[i]>2 | is.null(di$quantitative[i])) ersetze <- TRUE 276 if (nlevelsnew[i]==2 & !is.null(di$quantitative)){ 277 if (!di$quantitative[i]) ersetze <- TRUE 278 } 279 if (ersetze){ 280 if (!is.factor(design[[fnnold[i]]])) 281 design[[fnnold[i]]] <- as.factor(design[[fnnold[i]]]) 282 if (is.factor(design[[fnnold[i]]])) { 283 #lev <- as.list(fnold[[i]]) 284 #names(lev) <- value[[i]] 285 if (levordold) 286 levels(design[[fnnold[i]]]) <- value[[i]] 287 else 288 levels(design[[fnnold[i]]]) <- value[[i]][fnmap[[i]]] 289 } 290 # else design[[fnnold[i]]] <- 291 # factor(design[[fnnold[i]]],levels=fnold[[i]],labels=value[[i]]) 292 if (contr.modify){ 293 if (nlevelsnew[i]==2) contrasts(design[[i]]) <- contr.FrF2(2) 294 else { 295 if (is.numeric(value[[i]])) contrasts(design[[i]]) <- contr.poly(nlevelsnew[i],scores=value[[i]]) 296 else contrasts(design[[i]]) <- contr.treatment(nlevelsnew[i])} 297 } 298 } 299 else{ 300 design[[fnnold[i]]] <- (design[[fnnold[i]]] - mean(fnold[[i]]))/(max(fnold[[i]])-min(fnold[[i]])) * 301 (max(value[[i]])-min(value[[i]]))+mean(value[[i]])} 302 } 303 304 ## must be outside loop, because otherwise problems with names occurring in both versions 305 colnames(design)[sapply(fnnold, function(obj) which(colnames(design)==obj))] <- names(value) 306 if (!is.null(di$aliased)){ 307 dial <- strsplit(di$aliased$legend,"=") 308 newnames <- names(value) 309 dial <- lapply(dial, function(obj){ obj[2] <- newnames[which(fnnold==obj[2])] 310 obj}) 311 di$aliased$legend <- sapply(dial, function(obj) paste(obj,collapse="=")) 312 } 313 ## how about blocks (block variable is currently a character variable; why ? 314 di$factor.names <- value 315 attr(design, "design.info") <- di 316 if (!di$type %in% c("lhs","ccd","bbd","bbd.blocked")) 317 desnum(design) <- model.matrix(~.,design)[,-1,drop=FALSE] 318 else {hilf <- desnum(design) 319 colnames(hilf)[sapply(fnnold, function(obj) which(colnames(hilf)==obj))] <- names(value) 320 desnum(design) <- hilf 321 } 322 design 323} 324 325response.names <- function(design){ 326 if (!"design" %in% class(design)) stop("design.info is applicable for class design only.") 327 else attr(design,"design.info")$response.names 328 } 329 330`response.names<-` <- function(design, remove=FALSE, value){ 331 di <- design.info(design) 332 if (!(is.character(value) | is.null(value))) 333 stop("value must be a character vector or NULL") 334 if (!length(unique(value))==length(value)) 335 stop("response.names elements are not unique") 336 ## dont know why changing response.names was suppressed earlier for wide designs 337 ## deactivated that 29 Jan 2011; changed it to impossibility to remove response 338 ## in order to be on the safe side 339# if (!is.null(design.info(design)$responselist)) 340# stop("this is a design in wide format, for which function response.names currently does not work") 341 if (!is.null(design.info(design)$responselist) && remove){ 342 warning("this is a design in wide format, for which function response.names does not remove responses") 343 remove <- FALSE 344 } 345 rnold <- di$response.names 346 newresp <- setdiff(value, rnold) 347 dropresp <- setdiff(rnold, value) 348 349 newrespdrop <- character(0) 350 351 if (length(newresp)>0){ 352 for (i in 1:length(newresp)) 353 if (!newresp[i] %in% colnames(design)){ 354 design[,newresp[i]] <- rep(NA,nrow(design)) 355 hilf <- desnum(design) 356 hilf <- cbind(hilf, as.matrix(design[,newresp[i]])) 357 attr(design, "desnum") <- hilf 358 } 359 else if (!is.numeric(design[,newresp[i],drop=TRUE])){ 360 newrespdrop <- c(newrespdrop, newresp[i]) 361 } 362 } 363 if (length(newrespdrop>0)) 364 warning("non-numeric response not permitted, responses ", paste(newrespdrop, collapse=","), " not valid") 365 366 di$response.names <- setdiff(value, newrespdrop) 367 attr(design,"design.info") <- di 368 if (length(dropresp)>0){ 369 if (remove) { 370 hilf <- desnum(design) 371 for (i in 1:length(dropresp)){ 372 design[dropresp[i]] <- NULL 373 hilf <- hilf[,setdiff(1:ncol(hilf),which(colnames(hilf)==dropresp[i]))] 374 } 375 attr(design, "desnum") <- hilf 376 message("previous responses ", paste(dropresp, collapse=","), " have been removed from the design") 377 } 378 else 379 message("previous responses ", paste(dropresp, collapse=","), " are not considered responses any longer") 380 } 381 design 382} 383 384undesign <- function(design){ 385 if (!"design" %in% class(design)) stop("design must be of class design") 386 ## make design loose its class design and all related attributes 387 attr(design,"desnum") <- NULL 388 attr(design,"run.order") <- NULL 389 attr(design,"design.info") <- NULL 390 class(design) <- setdiff(class(design),"design") 391 design 392} 393 394redesign <- function(design, undesigned){ 395 if (!"design" %in% class(design)) stop("design must be of class design") 396 if (!is.data.frame(undesigned)) stop("undesigned must be a data frame") 397 if (!nrow(undesigned) == nrow(design)) stop("design and undesigned must have the same number of rows") 398 if (!all(undesigned[,colnames(design)]==design)) 399 stop("undesign must contain all data columns from design with identical content" ) 400 class(undesigned) <- c("design",class(undesigned)) 401 desnum(undesigned) <- desnum(design) 402 newcols <- setdiff(colnames(undesigned),colnames(design)) 403 if (length(newcols)>0){ 404 newdat <- undesigned[,newcols,drop=FALSE] 405 for (i in 1:length(newcols)) 406 newdat[,newcols[i]] <- as.numeric(newdat[,newcols[i]]) 407 newdat <- as.matrix(newdat) 408 desnum(undesigned) <- cbind(desnum(undesigned), newdat) 409 } 410 run.order(undesigned) <- run.order(design) 411 design.info(undesigned) <- design.info(design) 412 undesigned 413} 414 415col.remove <- function(design, colnames){ 416 if (!"design" %in% class(design)) stop("design must be of class design") 417 di <- design.info(design) 418 if (!is.character(colnames)) stop("colnames must be character") 419 if (any(colnames %in% names(di$factor.names))) 420 stop("design factors cannot be removed") 421 if (!is.null(di$block.name)) 422 if (di$block.name %in% colnames) 423 stop("the block factor cannot be removed") 424 if (length(loeschresp <- intersect(colnames, di$response.names)) > 0){ 425 loeschrest <- setdiff(colnames, loeschresp) 426 if (length(loeschrest)>0){ 427 hilf <- desnum(design) 428 for (i in 1:length(loeschrest)){ 429 design[loeschrest[i]] <- NULL 430 hilf <- hilf[,setdiff(1:ncol(hilf),which(colnames(hilf)==loeschrest[i]))] 431 } 432 attr(design, "desnum") <- hilf 433 } 434 response.names(design, remove=TRUE) <- setdiff(di$response.names, loeschresp) 435 } 436 else { 437 hilf <- desnum(design) 438 for (i in 1:length(colnames)){ 439 design[colnames[i]] <- NULL 440 hilf <- hilf[,setdiff(1:ncol(hilf),which(colnames(hilf)==colnames[i]))] 441 } 442 attr(design, "desnum") <- hilf 443 } 444 design 445}