« back to all changes in this revision
Viewing changes to R/Formula.R
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Package Import Robot
- Author(s): Dirk Eddelbuettel
- Date: 2013-07-13 13:00:23 UTC
- Revision ID: package-import@ubuntu.com-20130713130023-1pu1cw0oivugt9fs
Tags: upstream-1.1-1
Import upstream version 1.1-1
- files added:
- R
- inst
- inst/doc
- man
- tests
- tests/Examples
- vignettes
added
removed
R/Formula.R
1
Formula <- function(object) {
2
3
stopifnot(inherits(object, "formula"))
4
5
object_split <- split_formula(object)
6
7
structure(object, lhs = object_split$lhs, rhs = object_split$rhs,
8
class = c("Formula", "formula"))
9
}
10
11
as.Formula <- function(x, ...) UseMethod("as.Formula")
12
13
as.Formula.default <- function(x, ..., env = parent.frame()) Formula(as.formula(x, env = env))
14
15
as.Formula.Formula <- function(x, ...) x
16
17
as.Formula.formula <- function(x, ..., env) {
18
19
## preserve original environment
20
if(missing(env)) env <- environment(x)
21
22
## combine all arguments to formula list
23
x <- c(list(x), list(...))
24
x <- lapply(x, as.formula)
25
26
## split all
27
x_split <- lapply(x, split_formula)
28
x_lhs <- do.call("c", lapply(x_split, "[[", "lhs"))
29
x_rhs <- do.call("c", lapply(x_split, "[[", "rhs"))
30
31
## recombine
32
x_all <- paste_formula(x_lhs, x_rhs)
33
34
## create formula
35
## (we have everything to do this by hand, but for encapsulating code
36
## call Formula() again...which splits again)
37
rval <- Formula(x_all)
38
39
## re-attach original environment
40
environment(rval) <- env
41
return(rval)
42
}
43
44
is.Formula <- function(object) inherits(object, "Formula")
45
46
formula.Formula <- function(x, lhs = NULL, rhs = NULL, collapse = FALSE,
47
update = FALSE, drop = TRUE, ...)
48
{
49
## available parts
50
lpart <- 1:length(attr(x, "lhs"))
51
rpart <- 1:length(attr(x, "rhs"))
52
53
## default: keep all parts
54
lhs <- if(is.null(lhs)) lpart else lpart[lhs]
55
rhs <- if(is.null(rhs)) rpart else rpart[rhs]
56
if(any(is.na(lhs))) {
57
lhs <- as.vector(na.omit(lhs))
58
if(length(lhs) < 1) lhs <- 0
59
warning("subscript out of bounds, not all 'lhs' available")
60
}
61
if(any(is.na(rhs))) {
62
rhs <- as.vector(na.omit(rhs))
63
if(length(rhs) < 1) rhs <- 0
64
warning("subscript out of bounds, not all 'rhs' available")
65
}
66
67
## collapse: keep parts separated by "|" or collapse with "+"
68
collapse <- rep(as.logical(collapse), length.out = 2)
69
70
rval <- paste_formula(attr(x, "lhs")[lhs], attr(x, "rhs")[rhs],
71
lsep = ifelse(collapse[1], "+", "|"),
72
rsep = ifelse(collapse[2], "+", "|"))
73
74
## omit potentially redundant terms
75
if(all(collapse) & update) rval <- update(rval, if(length(rval) > 2) . ~ . else ~ .)
76
77
## reconvert to Formula if desired
78
if(!drop) rval <- Formula(rval)
79
80
## re-attach original environment
81
environment(rval) <- environment(x)
82
83
return(rval)
84
}
85
86
terms.Formula <- function(x, ..., lhs = NULL, rhs = NULL) {
87
88
## simplify a Formula to a formula that can be processed with
89
## terms/model.frame etc.
90
simplify_to_formula <- function(Formula, lhs = NULL, rhs = NULL) {
91
92
## get desired subset as formula and Formula
93
form <- formula(Formula, lhs = lhs, rhs = rhs)
94
Form <- Formula(form)
95
96
## convenience functions for checking extended features
97
is_lhs_extended <- function(Formula) {
98
## check for multiple parts
99
if(length(attr(Formula, "lhs")) > 1) {
100
return(TRUE)
101
} else {
102
## and multiple responses
103
if(length(attr(Formula, "lhs")) < 1) return(FALSE)
104
return(length(attr(terms(paste_formula(NULL,
105
attr(Formula, "lhs"), rsep = "+")), "term.labels")) > 1)
106
}
107
}
108
109
is_rhs_extended <- function(Formula) {
110
## check for muliple parts
111
length(attr(Formula, "rhs")) > 1
112
}
113
114
## simplify (if necessary)
115
ext_lhs <- is_lhs_extended(Form)
116
if(ext_lhs | is_rhs_extended(Form)) {
117
form <- if(ext_lhs) {
118
if(length(attr(Form, "rhs")) == 1 & identical(attr(Form, "rhs")[[1]], 0)) {
119
paste_formula(NULL, attr(Form, "lhs"), rsep = "+")
120
} else {
121
paste_formula(NULL, c(attr(Form, "lhs"), attr(Form, "rhs")), rsep = "+")
122
}
123
} else {
124
paste_formula(attr(Form, "lhs"), attr(Form, "rhs"), rsep = "+")
125
}
126
}
127
128
## re-attach original environment and return
129
environment(form) <- environment(Formula)
130
return(form)
131
}
132
133
## simplify and then call traditional terms()
134
form <- simplify_to_formula(x, lhs = lhs, rhs = rhs)
135
terms(form, ...)
136
}
137
138
model.frame.Formula <- function(formula, data = NULL, ..., lhs = NULL, rhs = NULL)
139
{
140
model.frame(terms(formula, lhs = lhs, rhs = rhs, data = data), data = data, ...)
141
}
142
143
model.matrix.Formula <- function(object, data = environment(object), ..., lhs = NULL, rhs = 1)
144
{
145
form <- formula(object, lhs = lhs, rhs = rhs, collapse = c(FALSE, TRUE))
146
mt <- delete.response(terms(form, data = data))
147
model.matrix(mt, data = data, ...)
148
}
149
150
## as model.response() is not generic, we do this:
151
model.part <- function(object, ...)
152
UseMethod("model.part")
153
154
model.part.formula <- function(formula, data, ..., drop = FALSE) {
155
formula <- Formula(formula)
156
NextMethod()
157
}
158
159
model.part.Formula <- function(object, data, lhs = 0, rhs = 0, drop = FALSE, terms = FALSE, ...) {
160
161
## *hs = NULL: keep all parts
162
if(is.null(lhs)) lhs <- 1:length(attr(object, "lhs"))
163
if(is.null(rhs)) rhs <- 1:length(attr(object, "rhs"))
164
165
if(isTRUE(all.equal(as.numeric(lhs), rep(0, length(lhs)))) &
166
isTRUE(all.equal(as.numeric(rhs), rep(0, length(rhs)))))
167
stop("Either some 'lhs' or 'rhs' has to be selected.")
168
169
## construct auxiliary terms object
170
mt <- terms(object, lhs = lhs, rhs = rhs, data = data)
171
172
## subset model frame
173
ix <- attr(mt, "variables")[-1]
174
if(is.null(ix)) {
175
ix <- 0
176
} else {
177
ix <- sapply(ix, deparse)
178
if(!all(ix %in% names(data))) stop(
179
paste("'data' does not seem to be an appropriate 'model.frame':",
180
paste(paste("'", ix[!(ix %in% names(data))], "'", sep = ""), collapse = ", "),
181
"not found")
182
)
183
}
184
rval <- data[, ix, drop = drop]
185
if(!is.data.frame(rval)) names(rval) <- rownames(data)
186
if(terms) attr(rval, "terms") <- mt
187
return(rval)
188
}
189
190
update.Formula <- function(object, new,...) {
191
192
new <- Formula(new)
193
194
## extract all building blocks
195
o_lhs <- attr(object, "lhs")
196
o_rhs <- attr(object, "rhs")
197
n_lhs <- attr(new, "lhs")
198
n_rhs <- attr(new, "rhs")
199
lhs <- rep(list(NULL), length = max(length(o_lhs), length(n_lhs)))
200
rhs <- rep(list(NULL), length = max(length(o_rhs), length(n_rhs)))
201
202
## convenience function for updating components
203
update_components <- function(x, y) {
204
xf <- yf <- ~ .
205
xf[[2]] <- x
206
yf[[2]] <- y
207
update(xf, yf)[[2]]
208
}
209
210
if(length(lhs) > 0) for(i in 1:length(lhs)) {
211
lhs[[i]] <- if(length(o_lhs) < i) n_lhs[[i]]
212
else if(length(n_lhs) < i) o_lhs[[i]]
213
else update_components(o_lhs[[i]], n_lhs[[i]])
214
}
215
216
if(length(rhs) > 0) for(i in 1:length(rhs)) {
217
rhs[[i]] <- if(length(o_rhs) < i) n_rhs[[i]]
218
else if(length(n_rhs) < i) o_rhs[[i]]
219
else update_components(o_rhs[[i]], n_rhs[[i]])
220
}
221
222
## recombine
223
rval <- paste_formula(lhs, rhs)
224
225
## create formula
226
## (we have everything to do this by hand, but for encapsulating code
227
## call Formula() again...which splits again)
228
rval <- Formula(rval)
229
230
## preserve original environment
231
environment(rval) <- environment(object)
232
233
return(rval)
234
}
235
236
length.Formula <- function(x) {
237
## NOTE: return length of both sides, not only rhs
238
c(length(attr(x, "lhs")), length(attr(x, "rhs")))
239
}
240
241
print.Formula <- function(x, ...) {
242
## we could avoid calling formula() by computing on the internal
243
## structure attr(x, "rhs") <- attr(x, "lhs") <- NULL
244
## but this is probably cleaner...
245
print(formula(x))
246
invisible(x)
247
}
248
249
all.equal.Formula <- function(target, current, ...) {
250
rval <- NULL
251
252
if(length(target)[1] != length(current)[1]) {
253
rval <- c(rval, paste("Length mismatch: target, current differ in number of LHS parts: ",
254
length(target)[1], ", ", length(current)[1], sep = ""))
255
} else if(!isTRUE(all.equal(attr(target, "lhs"), attr(current, "lhs")))) {
256
rval <- c(rval, "Formula mismatch: LHS formulas differ in contents")
257
}
258
259
if(length(target)[2] != length(current)[2]) {
260
rval <- c(rval, paste("Length mismatch: target, current differ in number of RHS parts: ",
261
length(target)[2], ", ", length(current)[2], sep = ""))
262
} else if(!isTRUE(all.equal(attr(target, "rhs"), attr(current, "rhs")))) {
263
rval <- c(rval, "Formula mismatch: RHS formulas differ in contents")
264
}
265
266
if(is.null(rval)) TRUE else rval
267
}
268
269
## convenience tools #################################################
270
271
## split formulas
272
split_formula <- function(f) {
273
274
stopifnot(inherits(f, "formula"))
275
276
rhs <- if(length(f) > 2) f[[3]] else f[[2]]
277
lhs <- if(length(f) > 2) f[[2]] else NULL
278
279
extract_parts <- function(x, sep = "|") {
280
if(is.null(x)) return(NULL)
281
282
rval <- list()
283
if(length(x) > 1 && x[[1]] == sep) {
284
while(length(x) > 1 && x[[1]] == sep) {
285
rval <- c(x[[3]], rval)
286
x <- x[[2]]
287
}
288
}
289
return(c(x, rval))
290
}
291
292
list(lhs = extract_parts(lhs), rhs = extract_parts(rhs))
293
}
294
295
## reassemble formulas
296
paste_formula <- function(lhs, rhs, lsep = "|", rsep = "|") {
297
298
## combine (parts of) formulas
299
c_formula <- function(f1, f2, sep = "~") {
300
301
stopifnot(length(sep) == 1, nchar(sep) == 1,
302
sep %in% c("~", "+", "|", "&"))
303
304
if(sep == "~") {
305
rval <- . ~ .
306
rval[[3]] <- f2
307
rval[[2]] <- f1
308
} else {
309
rval <- as.formula(paste(". ~ .", sep, "."))
310
rval[[3]][[3]] <- f2
311
rval[[3]][[2]] <- f1
312
rval <- rval[[3]]
313
}
314
315
return(rval)
316
}
317
318
stopifnot(all(nchar(lsep) == 1), all(lsep %in% c("+", "|", "&")))
319
stopifnot(all(nchar(rsep) == 1), all(rsep %in% c("+", "|", "&")))
320
321
if(length(lhs) > 1) lsep <- rep(lsep, length.out = length(lhs) - 1)
322
if(length(rhs) > 1) rsep <- rep(rsep, length.out = length(rhs) - 1)
323
324
if(is.null(lhs)) lhs <- list()
325
if(is.null(rhs)) rhs <- list()
326
327
if(!is.list(lhs)) lhs <- list(lhs)
328
if(!is.list(rhs)) rhs <- list(rhs)
329
330
lval <- if(length(lhs) > 0) lhs[[1]] else NULL
331
if(length(lhs) > 1) {
332
for(i in 2:length(lhs)) lval <- c_formula(lval, lhs[[i]], sep = lsep[[i-1]])
333
}
334
rval <- if(length(rhs) > 0) rhs[[1]] else 0 ## FIXME: Is there something better?
335
if(length(rhs) > 1) {
336
for(i in 2:length(rhs)) rval <- c_formula(rval, rhs[[i]], sep = rsep[[i-1]])
337
}
338
339
c_formula(lval, rval, sep = "~")
340
}
341
Loggerhead is a web-based interface for Breezy
Version: 2.0.1