1P4.4 <- 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 P4.4 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 4 words
9    ## for projections into four 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("parftdf must be TRUE or FALSE")
16    ## retrieve child array or array identified by character string
17          ## gsub for case where ID is character string
18    IDname <- gsub("\"", "", deparse(substitute(ID)))
19    if (all(IDname %in% oacat$name)) {
20        if (!exists(IDname))
21            ID <- eval(parse(text = paste("oa.design(", IDname,
22                ")")))
23        else if (is.character(ID))
24            ID <- eval(parse(text = paste("oa.design(", IDname,
25                ")")))
26    }
27    if ((rela || parft || parftdf) & !(isTRUE(all.equal(length2(ID), 0)) & isTRUE(all.equal(length3(ID),
28        0))))
29        stop(IDname, " is not a strength 3 array, \nP4.4 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) >= 4)
35        return(NULL)
36    hilf <- length4(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        waehl <- nchoosek(ncol(ID), 4)
45        nlevels <- sapply(ID, function(obj) length(unique(obj)))
46        div <- apply(waehl, 2, function(obj) min((nlevels[obj] -
47            1)))
48    }
49    if (parft) {
50        waehl <- nchoosek(ncol(ID), 4)
51        nlevels <- sapply(ID, function(obj) length(unique(obj)))
52        div <- apply(waehl, 2, function(obj) 4/sum(1/(nlevels[obj] -
53            1)))  ## divisor, multiplier is 1/divisor
54    }
55    if (parftdf) {
56        waehl <- nchoosek(ncol(ID), 4)
57        nlevels <- sapply(ID, function(obj) length(unique(obj)))
58        div <- apply(waehl, 2, function(obj) mean(nlevels[obj] -
59            1))  ## divisor, multiplier is 1/divisor
60    }
61
62    aus <- table(round(hilf, digits))
63    if (rela || parft || parftdf) aus <- table(round(hilf/div, digits))
64
65    ## formatting the table for output
66    aus <- cbind(length4 = as.numeric(names(aus)), frequency = aus)
67    if (rela)
68        colnames(aus) <- c("length4.rela", "frequency")
69    if (parft)
70        colnames(aus) <- c("length4.parft", "frequency")
71    if (parftdf)
72        colnames(aus) <- c("length4.parftdf", "frequency")
73
74    rownames(aus) <- rep("", nrow(aus))
75
76    ## attaching attributes
77    attr(aus, "A4") <- A4 <- sum(hilf)
78    if (!(rela || parft || parftdf) & detailed & A4>0)
79        attr(aus, "detail") <- round(hilf, digits)
80    if (rela) {
81        attr(aus, "rA4") <- rA4 <- sum(hilf/div)
82        if (rA4 > 0) attr(aus, "GR") <- round(4+1-sqrt(max(hilf/div)),digits)
83          else attr(aus, "GR") <- ">=5"
84        if (rA4 > 0 & detailed) attr(aus, "detail") <- round(hilf/div, digits)
85        }
86      if (parft){
87        attr(aus, "sumPARFT4") <- sumPARFT4 <- sum(hilf/div)
88        if (sumPARFT4 > 0 & detailed)
89            attr(aus, "detail") <- round(hilf/div, digits)
90        }
91      if (parftdf){
92        attr(aus, "sumPARFTdf4") <- sumPARFTdf4 <- sum(hilf/div)
93        if (sumPARFTdf4 > 0 & detailed)
94            attr(aus, "detail") <- round(hilf/div, digits)
95        }
96    aus
97}
98