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}