1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
sumsplit <- function(x, ...) {
plus <- strsplit(x, "\\+")[[1]]
spl <- unlist(lapply(plus, function(x) {
val <- strsplit(x, "\\-")[[1]]
val[-1] <- paste0("-", val[-1])
setdiff(val, "")
}))
res <- c()
for (st in spl) {
st <- gsub(" ", "", st)
st0 <- gsub("^[-0-9\\*]*", "", st)
val <- gsub(
"\\*", "",
regmatches(st, gregexpr("^[-0-9\\*]*", st))[[1]]
)
if (val == "") val <- "1"
val <- switch(val, "-"=-1, val)
res <- c(res, val, st0)
}
return(res)
}
##' @export
parsedesign <- function(coef, x, ..., regex=FALSE, diff=TRUE) {
if (!is.vector(coef)) coef <- stats::coef(coef)
if (is.numeric(coef) && !is.null(names(coef))) coef <- names(coef)
dots <- lapply(substitute(list(...)), function(x) x)[-1]
expr <- suppressWarnings(inherits(try(x, silent=TRUE), "try-error"))
if (expr) {
ee <- c(deparse(substitute(x)), unlist(lapply(dots, deparse)))
} else {
ee <- c(deparse(x), sapply(dots, function(x) deparse(x)))
}
if (!expr && is.numeric(x)) {
return(do.call(
contr,
list(c(list(x), list(...)),
n = length(coef), diff = diff)
))
}
res <- c()
diff <- rep(diff, length.out=length(ee))
count <- 0
for (e in ee) {
count <- count+1
diff0 <- FALSE
Val <- rbind(rep(0, length(coef)))
if (grepl('\"', e)) {
diff0 <- diff[count] && grepl("^c\\(", e)
e0 <- gsub(" |\\)$|^c\\(", "", e)
ff <- strsplit(e0, '\"')[[1L]]
} else {
ff <- sumsplit(e)
}
for (i in seq(length(ff)/2)) {
val0 <- gsub("[*()]", "", ff[2*(i-1)+1])
val <- char2num(val0)
if (is.na(val)) {
val <- switch(val0, "-"=-1, 1)
}
par0 <- ff[2*i]
par0int <- as.integer(char2num(par0))
if (!regex) par0 <- glob2rx(par0)
if (is.na(par0int)) par0int <- grep(par0, coef)
if (length(par0int)>1) {
diff0 <- diff[count]
for (k in seq_along(par0int)) {
if (par0int[k]<=length(Val)) {
if (diff[count]) {
Val[par0int[k]] <- val
} else {
Val0 <- Val
Val0[] <- 0
Val0[par0int[k]] <- val
res <- rbind(res, Val0)
}
}
}
} else {
if (length(par0int) > 0 && par0int <= length(Val)) {
Val[par0int] <- val
}
}
}
if (diff0) {
n <- sum(Val!=0)
if (n>1) {
Val0 <- Val
ii <- which(Val0!=0)
Val <- matrix(0, nrow=n-1, ncol=length(Val))
for (i in seq(n-1)) {
Val[i, ii[c(1, i+1)]] <- Val0[ii[c(1, i+1)]]*c(1, -1)
}
}
}
if (any(Val!=0)) res <- rbind(res, Val)
}
res
}
|
