1add.response <- function(design, response, rdapath=NULL, replace=FALSE,
2     InDec=options("OutDec")[[1]], tol=.Machine$double.eps ^ 0.5, ...){
3     ## invalid paths are reasonably warned about outside of this program
4     if (!is.null(rdapath)){
5        load(rdapath)
6        if (!exists(design)) stop(design, " not found in ", rdapath)
7        ## desnam <- design  ## that is not needed, is it ?
8        assign(design, get(design))  ## why this?
9        design <- get(design)
10        if (!"design" %in% class(design)) stop("design must be of class design")
11        }
12     if (is.character(response)){
13        if (!substr(response, nchar(response)-2,nchar(response))=="csv")
14            stop("response must be a numeric vector or matrix, a data frame or the name of a csv-file")
15        if (InDec==".") assign("response", read.csv(response))
16             else assign("response", read.csv2(response))
17     }
18
19### take care of name that is automatically stored and should subsequently only be added if
20### it has been changed in the mean time
21
22    rn <- make.names(deparse(substitute(response)))    ## make.names makes valid R names from e.g. rnorm(8)
23
24    if (!"design" %in% class(design)) stop("add.response works on class design objects only.")
25    di <- design.info(design)
26
27    if (!(is.numeric(response) | is.data.frame(response)))
28        stop("response must be a numeric vector or matrix or a data frame.")
29
30    ## response to become a data frame with reasonable column names
31    if (is.matrix(response)) {
32        if (ncol(response) == 1 & is.null(colnames(response))) colnames(response) <- rn
33        response <- data.frame(response)
34        }
35    if (is.numeric(response)) {
36            response <- data.frame(response)
37            colnames(response) <- rn
38            }
39
40    if (is.data.frame(response)){
41        numc <- sapply(response, is.numeric)
42        if (!any(numc))
43            stop("response does not contain any numeric variables.")
44            }
45        else if (is.matrix(response)) numc <- rep(TRUE,ncol(response))
46        else numc <- TRUE
47    if (is.data.frame(response) | is.matrix(response))
48        if ("run.no" %in% colnames(response)){
49            rrno <- response[,"run.no"]
50            drno <- run.order(design)$run.no
51            if (is.factor(drno)) response[,"run.no"] <- rrno <- factor(rrno, levels=levels(drno))
52            else if (is.factor(rrno)) response[,"run.no"] <- rrno <- as.numeric(as.character(rrno))
53            if (!all(rrno==drno)){
54               design <- design[ord(matrix(as.numeric(run.order(design)$run.no),ncol=1)),]
55               response <- response[ord(matrix(as.numeric(response[,"run.no"]),ncol=1)),]
56            }}
57
58    fnam <- names(di$factor.names)
59    blocknam <- di$block.name
60    if (!nrow(response) ==nrow(design))
61            stop("wrong number of observations in response")
62    respnam <- setdiff(colnames(response)[which(numc)], c(fnam, blocknam, colnames(run.order(design)), "Name", "name"))
63    if (length(respnam)==0) stop("no response variables in response")
64
65     ## check consistency in case of overlapping variables
66     ## NA variables must be removed from this, in order to allow adding only some response variables comfortably
67     ## response variables are checked later
68       ## this part also prevents replacement for ill-sorted designs, if the Factor variables are also kept
69
70       ## gleich contains the non-NA variables occurring in both design and hilf but not in respnam
71     gleich <- setdiff(intersect(colnames(design)[which(!sapply(design, function(.x) all(is.na(.x))))],colnames(response)),respnam)
72     if (length(gleich)>0){
73       if (!all(response[,gleich]==design[,gleich])){
74            fn <- intersect(fnam,gleich)
75            if (length(fn) > 0)
76                for (ffn in fn) if (all(as.character(design[[ffn]])==as.character(response[[ffn]]))){
77                          response[[ffn]] <- design[[ffn]]
78                          gleich <- setdiff(gleich, ffn)
79                          }
80                          else{
81                              if (isTRUE(all.equal(as.numeric(as.character(design[[ffn]])),as.numeric(as.character(response[[ffn]])),tolerance=tol))){
82                                response[[ffn]] <- design[[ffn]]
83                                gleich <- setdiff(gleich, ffn)
84                                }
85                             else{
86                                print(ffn)
87                                print(cbind(as.character(design[[ffn]]), as.character(response[[ffn]])))
88                                stop("There are variables of same names but with different content in design and response")
89                             }
90                          }
91            }
92            }
93
94    ## treat response variables
95    ## if overlap and design contains any response neither equal to update nor NA --> prevent replacement
96       ## now gleich contains the new names that are already in the design
97    gleich <- intersect(colnames(design),respnam)
98    if (length(gleich) > 0 & !replace){
99        ## check non-NA values for approximate equality
100              dm <- as.matrix(design[,gleich])
101              rm <- as.matrix(response[,gleich])
102        if (!(all(is.na(dm)) |
103               isTRUE(all.equal(dm[!is.na(dm)],rm[!is.na(dm)],tolerance=tol))))
104           stop("response variables ", paste(gleich, sep=", "), " already exist in the design with partly different values!")
105        if (!identical(dm[!is.na(dm)],rm[!is.na(dm)])){
106              ## replace rm values with small numeric differences (all.equal was TRUE) by dm values
107              ## necessary because of inadequate forced rounding in software like Excel
108              ##             for calculated responses with many decimal places
109              rm[!is.na(dm)] <- dm[!is.na(dm)]
110              response[,gleich] <- as.data.frame(rm)
111            }
112        }
113    design[,respnam] <- response[,respnam]
114    attr(design,"desnum") <- cbind(desnum(design), as.matrix(response[,respnam,drop=FALSE]))
115    attr(design,"design.info")$response.names <- union(response.names(design), respnam)
116         ## union for the case that some added response overwrite existing ones
117         ## if no existing ones, NULL causes no problem
118    design
119}