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