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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
#############################################################################
## Copyright (c) 2010-2022 Rune Haubo Bojesen Christensen
##
## This file is part of the ordinal package for R (*ordinal*)
##
## *ordinal* is free software: you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation, either version 2 of the License, or
## (at your option) any later version.
##
## *ordinal* is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## A copy of the GNU General Public License is available at
## <https://www.r-project.org/Licenses/> and/or
## <http://www.gnu.org/licenses/>.
#############################################################################
## This file contains:
## Functions to process lmer-style mixed-model formulae. These
## functions are borrowed from the lme4 package but have later been
## modified.
findbars <- function(term)
### Return the pairs of expressions that separated by vertical bars
{
if (is.name(term) || !is.language(term)) return(NULL)
if (term[[1]] == as.name("(")) return(findbars(term[[2]]))
if (!is.call(term)) stop("term must be of class call")
if (term[[1]] == as.name('|')) return(term)
if (length(term) == 2) return(findbars(term[[2]]))
c(findbars(term[[2]]), findbars(term[[3]]))
}
nobars <- function(term)
### term - usually the third element of a formula object: formula[[3]]
### returns a list of terms
### Return the formula omitting the pairs of expressions that are
### separated by vertical bars
{
if (!('|' %in% all.names(term))) return(term)
if (is.call(term) && term[[1]] == as.name('|')) return(NULL)
if (length(term) == 2) {
nb <- nobars(term[[2]])
if (is.null(nb)) return(NULL)
term[[2]] <- nb
return(term)
}
nb2 <- nobars(term[[2]])
nb3 <- nobars(term[[3]])
if (is.null(nb2)) return(nb3)
if (is.null(nb3)) return(nb2)
term[[2]] <- nb2
term[[3]] <- nb3
term
}
subbars <- function(term)
### Substitute the '+' function for the '|' function
{
if (is.name(term) || !is.language(term)) return(term)
if (length(term) == 2) {
term[[2]] <- subbars(term[[2]])
return(term)
}
stopifnot(length(term) >= 3)
if (is.call(term) && term[[1]] == as.name('|'))
term[[1]] <- as.name('+')
for (j in 2:length(term)) term[[j]] <- subbars(term[[j]])
term
}
subnms <- function(term, nlist)
### Substitute any names from nlist in term with 1
{
if (!is.language(term)) return(term)
if (is.name(term)) {
if (any(unlist(lapply(nlist, get("=="), term)))) return(1)
return(term)
}
stopifnot(length(term) >= 2)
for (j in 2:length(term)) term[[j]] <- subnms(term[[j]], nlist)
term
}
slashTerms <- function(x)
### Return the list of '/'-separated terms in an expression that
### contains slashes
{
if (!("/" %in% all.names(x))) return(x)
if (x[[1]] != as.name("/"))
stop("unparseable formula for grouping factor")
list(slashTerms(x[[2]]), slashTerms(x[[3]]))
}
makeInteraction <- function(x)
### from a list of length 2 return recursive interaction terms
{
if (length(x) < 2) return(x)
trm1 <- makeInteraction(x[[1]])
trm11 <- if(is.list(trm1)) trm1[[1]] else trm1
list(substitute(foo:bar, list(foo=x[[2]], bar = trm11)), trm1)
}
expandSlash <- function(bb)
### expand any slashes in the grouping factors returned by findbars
{
if (!is.list(bb)) return(expandSlash(list(bb)))
## I really do mean lapply(unlist(... - unlist returns a
## flattened list in this case
unlist(lapply(bb, function(x) {
if (length(x) > 2 && is.list(trms <- slashTerms(x[[3]])))
return(lapply(unlist(makeInteraction(trms)),
function(trm) substitute(foo|bar,
list(foo = x[[2]],
bar = trm))))
x
}))
}
|
