/
quote.r
203 lines (179 loc) · 6.26 KB
/
quote.r
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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
#' Quote variables to create a list of unevaluated expressions for later
#' evaluation.
#'
#' This function is similar to \code{\link{~}} in that it is used to
#' capture the name of variables, not their current value. This is used
#' throughout plyr to specify the names of variables (or more complicated
#' expressions).
#'
#' Similar tricks can be performed with \code{\link{substitute}}, but when
#' functions can be called in multiple ways it becomes increasingly tricky
#' to ensure that the values are extracted from the correct frame. Substitute
#' tricks also make it difficult to program against the functions that use
#' them, while the \code{quoted} class provides
#' \code{as.quoted.character} to convert strings to the appropriate
#' data structure.
#'
#' @param ... unevaluated expressions to be recorded. Specify names if you
#' want the set the names of the resultant variables
#' @param .env environment in which unbound symbols in \code{...} should be
#' evaluated. Defaults to the environment in which \code{.} was executed.
#' @return list of symbol and language primitives
#' @aliases . quoted is.quoted
#' @export . is.quoted
#' @rdname quoted
#' @examples
#' .(a, b, c)
#' .(first = a, second = b, third = c)
#' .(a ^ 2, b - d, log(c))
#' as.quoted(~ a + b + c)
#' as.quoted(a ~ b + c)
#' as.quoted(c("a", "b", "c"))
#'
#' # Some examples using ddply - look at the column names
#' ddply(mtcars, "cyl", each(nrow, ncol))
#' ddply(mtcars, ~ cyl, each(nrow, ncol))
#' ddply(mtcars, .(cyl), each(nrow, ncol))
#' ddply(mtcars, .(log(cyl)), each(nrow, ncol))
#' ddply(mtcars, .(logcyl = log(cyl)), each(nrow, ncol))
#' ddply(mtcars, .(vs + am), each(nrow, ncol))
#' ddply(mtcars, .(vsam = vs + am), each(nrow, ncol))
. <- function(..., .env = parent.frame()) {
structure(as.list(match.call()[-1]), env = .env, class="quoted")
}
is.quoted <- function(x) inherits(x, "quoted")
#' Print quoted variables.
#'
#' Display the \code{\link{str}}ucture of quoted variables
#'
#' @keywords internal
#' @S3method print quoted
#' @method print quoted
print.quoted <- function(x, ...) str(x)
#' Compute names of quoted variables.
#'
#' Figure out names of quoted variables, using specified names if they exist,
#' otherwise converting the values to character strings. This may create
#' variable names that can only be accessed using \code{``}.
#'
#' @keywords internal
#' @S3method names quoted
#' @method names quoted
names.quoted <- function(x) {
deparse2 <- function(x) paste(deparse(x), collapse = "")
part_names <- unlist(lapply(x, deparse2))
user_names <- names(unclass(x))
if (!is.null(user_names)) {
part_names[user_names != ""] <- user_names[user_names != ""]
}
unname(part_names)
}
#' Evaluate a quoted list of variables.
#'
#' Evaluates quoted variables in specified environment
#'
#' @return a list
#' @keywords internal
#' @param expr quoted object to evalution
#' @param try if TRUE, return \code{NULL} if evaluation unsuccesful
#' @export
eval.quoted <- function(exprs, envir = NULL, enclos = NULL, try = FALSE) {
if (is.numeric(exprs)) return(envir[exprs])
if (!is.null(envir) && !is.list(envir) && !is.environment(envir)) {
stop("envir must be either NULL, a list, or an environment.")
}
qenv <- if (is.quoted(exprs)) attr(exprs, "env") else parent.frame()
if (is.null(envir)) envir <- qenv
if (is.data.frame(envir) && is.null(enclos)) enclos <- qenv
if (try) {
results <- lapply(exprs, failwith(NULL, eval, quiet = TRUE),
envir = envir, enclos = enclos)
} else {
results <- lapply(exprs, eval, envir = envir, enclos = enclos)
}
names(results) <- names(exprs)
results
}
#' Convert input to quoted variables.
#'
#' Convert characters, formulas and calls to quoted .variables
#'
#' This method is called by default on all plyr functions that take a
#' \code{.variables} argument, so that equivalent forms can be used anywhere.
#'
#' Currently conversions exist for character vectors, formulas and
#' call objects.
#'
#' @return a list of quoted variables
#' @seealso \code{\link[=quoted]{.}}
#' @param x input to quote
#' @param env environment in which unbound symbols in expression should be
#' evaluated. Defaults to the environment in which \code{as.quoted} was
#' executed.
#' @export
#' @examples
#' as.quoted(c("a", "b", "log(d)"))
#' as.quoted(a ~ b + log(d))
as.quoted <- function(x, env = parent.frame()) UseMethod("as.quoted")
#' @S3method as.quoted call
as.quoted.call <- function(x, env = parent.frame()) {
structure(as.list(x)[-1], env = env, class = "quoted")
}
#' @S3method as.quoted character
as.quoted.character <- function(x, env = parent.frame()) {
structure(
lapply(x, function(x) parse(text = x)[[1]]),
env = env, class = "quoted"
)
}
#' @S3method as.quoted numeric
as.quoted.numeric <- function(x, env = parent.frame()) {
structure(x, env = env, class = c("quoted", "numeric"))
}
#' @S3method as.quoted formula
as.quoted.formula <- function(x, env = parent.frame()) {
simplify <- function(x) {
if (length(x) == 2 && x[[1]] == as.name("~")) {
return(simplify(x[[2]]))
}
if (length(x) < 3) return(list(x))
op <- x[[1]]; a <- x[[2]]; b <- x[[3]]
if (op == as.name("+") || op == as.name("*") || op == as.name("~")) {
c(simplify(a), simplify(b))
} else if (op == as.name("-")) {
c(simplify(a), bquote(-.(x), list(x=simplify(b))))
} else {
list(x)
}
}
structure(simplify(x), env = env, class = "quoted")
}
#' @S3method as.quoted quoted
as.quoted.quoted <- function(x, env = parent.frame()) x
#' @S3method as.quoted NULL
as.quoted.NULL <- function(x, env = parent.frame()) {
structure(list(), env = env, class = "quoted")
}
#' @S3method as.quoted name
as.quoted.name <- function(x, env = parent.frame()) {
structure(list(x), env = env, class = "quoted")
}
#' @S3method as.quoted factor
as.quoted.factor <- function(x, env = parent.frame()) {
as.quoted(as.character(x), env)
}
#' @S3method c quoted
c.quoted <- function(..., recursive = FALSE) {
structure(NextMethod("c"), class = "quoted",
env = attr(list(...)[[1]], "env"))
}
#' @S3method [ quoted
"[.quoted" <- function(x, i, ...) {
structure(NextMethod("["), env = attr(x, "env"), class = "quoted")
}
#' Is a formula?
#' Checks if argument is a formula
#'
#' @keywords internal
#' @export
is.formula <- function(x) inherits(x, "formula")