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}