1P3.3 <- function (ID, digits = 4, rela = FALSE, parft=FALSE, parftdf=FALSE, 2 detailed=FALSE) 3{ 4 ## function used for calculations in the paper 5 ## final updated function P3.3 for R package DoE.base will omit "newdf" 6 ## and will rename "new" to "parft" 7 8 ## function to calculate pattern of numbers of generalized length 3 words 9 ## for projections into three factors 10 if (!is.logical(rela)) 11 stop("rela must be TRUE or FALSE") 12 if (!is.logical(parft)) 13 stop("parft must be TRUE or FALSE") 14 if (!is.logical(parftdf)) 15 stop("parft must be TRUE or FALSE") 16 17 ## retrieve child array or array identified by character string 18 ## gsub for case where ID is character string 19 IDname <- gsub("\"", "", deparse(substitute(ID))) 20 if (all(IDname %in% oacat$name)) { 21 if (!exists(IDname)) 22 ID <- eval(parse(text = paste("oa.design(", IDname, 23 ")"))) 24 else if (is.character(ID)) 25 ID <- eval(parse(text = paste("oa.design(", IDname, 26 ")"))) 27 } 28 if ((rela || parft || parftdf) & !(isTRUE(all.equal(length2(ID), 0)))) 29 stop(IDname, " is not an orthogonal array, \nP3.3 with rela, parft or parftdf TRUE is inadequate.") 30 if (!(is.data.frame(ID) | is.matrix(ID))) 31 stop("ID must be a data frame or a matrix") 32 if (is.matrix(ID)) 33 ID <- as.data.frame(ID) 34 if (!ncol(ID) >= 3) 35 return(NULL) 36 hilf <- length3(ID, J = TRUE) 37 fhilf <- factor(names(hilf), levels=unique(names(hilf))) ## bug fix 2 Sep 2013 38 ## hilf was in unexpected order before, 39 ## yielding wrong calculations for rela in designs 40 ## with many columns due to character instead of 41 ## numeric sorting 42 hilf <- sapply(split(hilf, fhilf), function(obj) sum(obj^2)) 43 if (rela) { 44 # divisors are created from nlevels by relative numbers 45 waehl <- nchoosek(ncol(ID), 3) 46 nlevels <- sapply(ID, function(obj) length(unique(obj))) 47 div <- apply(waehl, 2, function(obj) min((nlevels[obj] - 48 1))) 49 } 50 if (parft) { 51 waehl <- nchoosek(ncol(ID), 3) 52 nlevels <- sapply(ID, function(obj) length(unique(obj))) 53 div <- apply(waehl, 2, function(obj) 3/sum(1/(nlevels[obj] - 54 1))) ## divisor, multiplier is 1/divisor 55 } 56 if (parftdf) { 57 waehl <- nchoosek(ncol(ID), 3) 58 nlevels <- sapply(ID, function(obj) length(unique(obj))) 59 div <- apply(waehl, 2, function(obj) mean(nlevels[obj] - 60 1)) ## divisor, multiplier is 1/divisor 61 } 62 63 aus <- table(round(hilf, digits)) 64 if (rela || parft || parftdf) 65 aus <- table(round(hilf/div, digits)) 66 67 ## formatting the table for output 68 aus <- cbind(length3 = as.numeric(names(aus)), frequency = aus) 69 if (rela) 70 colnames(aus) <- c("length3.rela", "frequency") 71 if (parft) 72 colnames(aus) <- c("length3.parft", "frequency") 73 if (parftdf) 74 colnames(aus) <- c("length3.parftdf", "frequency") 75 rownames(aus) <- rep("", nrow(aus)) 76 77 ## attaching attributes 78 attr(aus, "A3") <- A3 <- sum(hilf) 79 if (detailed & A3 > 0 & !(rela || parft || parftdf)) 80 attr(aus, "detail") <- round(hilf, digits) 81 82 if (rela) { 83 attr(aus, "rA3") <- rA3 <- sum(hilf/div) 84 if (detailed & rA3 > 0) attr(aus, "detail") <- round(hilf/div, digits) 85 if (rA3 > 0) attr(aus, "GR") <- round(3+1-sqrt(max(hilf/div)),digits) 86 else attr(aus, "GR") <- ">=4" 87 } 88 if (parft){ 89 attr(aus, "sumPARFT3") <- sumPARFT3 <- sum(hilf/div) 90 if (detailed & sumPARFT3 > 0) 91 attr(aus, "detail") <- round(hilf/div, digits) 92 } 93 if (parftdf){ 94 attr(aus, "sumPARFTdf3") <- sumPARFTdf3 <- sum(hilf/div) 95 if (detailed & sumPARFTdf3 > 0) 96 attr(aus, "detail") <- round(hilf/div, digits) 97 } 98 aus 99} 100