1#' Quote variables to create a list of unevaluated expressions for later
2#' evaluation.
3#'
4#' This function is similar to \code{\link{~}} in that it is used to
5#' capture the name of variables, not their current value.  This is used
6#' throughout plyr to specify the names of variables (or more complicated
7#' expressions).
8#'
9#' Similar tricks can be performed with \code{\link{substitute}}, but when
10#' functions can be called in multiple ways it becomes increasingly tricky
11#' to ensure that the values are extracted from the correct frame.  Substitute
12#' tricks also make it difficult to program against the functions that use
13#' them, while the \code{quoted} class provides
14#' \code{as.quoted.character} to convert strings to the appropriate
15#' data structure.
16#'
17#' @param ... unevaluated expressions to be recorded.  Specify names if you
18#'   want the set the names of the resultant variables
19#' @param .env environment in which unbound symbols in \code{...} should be
20#'   evaluated.  Defaults to the environment in which \code{.} was executed.
21#' @return list of symbol and language primitives
22#' @aliases . quoted is.quoted
23#' @export . is.quoted
24#' @rdname quoted
25#' @examples
26#' .(a, b, c)
27#' .(first = a, second = b, third = c)
28#' .(a ^ 2, b - d, log(c))
29#' as.quoted(~ a + b + c)
30#' as.quoted(a ~ b + c)
31#' as.quoted(c("a", "b", "c"))
32#'
33#' # Some examples using ddply - look at the column names
34#' ddply(mtcars, "cyl", each(nrow, ncol))
35#' ddply(mtcars, ~ cyl, each(nrow, ncol))
36#' ddply(mtcars, .(cyl), each(nrow, ncol))
37#' ddply(mtcars, .(log(cyl)), each(nrow, ncol))
38#' ddply(mtcars, .(logcyl = log(cyl)), each(nrow, ncol))
39#' ddply(mtcars, .(vs + am), each(nrow, ncol))
40#' ddply(mtcars, .(vsam = vs + am), each(nrow, ncol))
41. <- function(..., .env = parent.frame()) {
42  structure(as.list(match.call()[-1]), env = .env, class="quoted")
43}
44
45is.quoted <- function(x) inherits(x, "quoted")
46
47#' Print quoted variables.
48#'
49#' Display the \code{\link{str}}ucture of quoted variables
50#'
51#' @keywords internal
52#' @export
53print.quoted <- function(x, ...) utils::str(x)
54
55#' Compute names of quoted variables.
56#'
57#' Figure out names of quoted variables, using specified names if they exist,
58#' otherwise converting the values to character strings.  This may create
59#' variable names that can only be accessed using \code{``}.
60#'
61#' @keywords internal
62#' @export
63names.quoted <- function(x) {
64  deparse2 <- function(x) paste(deparse(x), collapse = "")
65  part_names <- unlist(lapply(x, deparse2))
66  user_names <- names(unclass(x))
67
68  if (!is.null(user_names)) {
69    part_names[user_names != ""] <- user_names[user_names != ""]
70  }
71
72  unname(part_names)
73}
74
75#' Evaluate a quoted list of variables.
76#'
77#' Evaluates quoted variables in specified environment
78#'
79#' @return a list
80#' @keywords internal
81#' @param expr quoted object to evalution
82#' @param try if TRUE, return \code{NULL} if evaluation unsuccesful
83#' @export
84eval.quoted <- function(exprs, envir = NULL, enclos = NULL, try = FALSE) {
85  if (is.numeric(exprs)) return(envir[exprs])
86
87  if (!is.null(envir) && !is.list(envir) && !is.environment(envir)) {
88    stop("envir must be either NULL, a list, or an environment.")
89  }
90
91  qenv <- if (is.quoted(exprs)) attr(exprs, "env") else parent.frame()
92  if (is.null(envir)) envir <- qenv
93  if (is.data.frame(envir) && is.null(enclos)) enclos <- qenv
94
95  if (try) {
96    results <- lapply(exprs, failwith(NULL, eval, quiet = TRUE),
97      envir = envir, enclos = enclos)
98  } else {
99    results <- lapply(exprs, eval, envir = envir, enclos = enclos)
100  }
101  names(results) <- names(exprs)
102
103  results
104}
105
106#' Convert input to quoted variables.
107#'
108#' Convert characters, formulas and calls to quoted .variables
109#'
110#' This method is called by default on all plyr functions that take a
111#' \code{.variables} argument, so that equivalent forms can be used anywhere.
112#'
113#' Currently conversions exist for character vectors, formulas and
114#' call objects.
115#'
116#' @return a list of quoted variables
117#' @seealso \code{\link[=quoted]{.}}
118#' @param x input to quote
119#' @param env environment in which unbound symbols in expression should be
120#'   evaluated. Defaults to the environment in which \code{as.quoted} was
121#'   executed.
122#' @export
123#' @examples
124#' as.quoted(c("a", "b", "log(d)"))
125#' as.quoted(a ~ b + log(d))
126as.quoted <- function(x, env = parent.frame()) UseMethod("as.quoted")
127
128#' @export
129as.quoted.call <- function(x, env = parent.frame()) {
130  structure(as.list(x)[-1], env = env, class = "quoted")
131}
132
133#' @export
134as.quoted.character <- function(x, env = parent.frame()) {
135  structure(
136    lapply(x, function(x) parse(text = x)[[1]]),
137    env = env, class = "quoted"
138  )
139}
140
141#' @export
142as.quoted.numeric <- function(x, env = parent.frame()) {
143  structure(x, env = env, class = c("quoted", "numeric"))
144}
145
146#' @export
147as.quoted.formula <- function(x, env = parent.frame()) {
148  simplify <- function(x) {
149    if (length(x) == 2 && x[[1]] == as.name("~")) {
150      return(simplify(x[[2]]))
151    }
152    if (length(x) < 3) return(list(x))
153    op <- x[[1]]; a <- x[[2]]; b <- x[[3]]
154
155    if (op == as.name("+") || op == as.name("*") || op == as.name("~")) {
156      c(simplify(a), simplify(b))
157    } else if (op == as.name("-")) {
158      c(simplify(a), bquote(-.(x), list(x=simplify(b))))
159    } else {
160      list(x)
161    }
162  }
163
164  structure(simplify(x), env = env, class = "quoted")
165}
166
167#' @export
168as.quoted.quoted <- function(x, env = parent.frame()) x
169
170#' @export
171as.quoted.NULL <- function(x, env = parent.frame()) {
172  structure(list(), env = env, class = "quoted")
173}
174
175#' @export
176as.quoted.name <- function(x, env = parent.frame()) {
177  structure(list(x), env = env, class = "quoted")
178}
179
180#' @export
181as.quoted.factor <- function(x, env = parent.frame()) {
182  as.quoted(as.character(x), env)
183}
184
185#' @export
186c.quoted <- function(..., recursive = FALSE) {
187  structure(NextMethod("c"), class = "quoted",
188    env = attr(list(...)[[1]], "env"))
189}
190
191#' @export
192"[.quoted" <- function(x, i, ...) {
193  structure(NextMethod("["), env = attr(x, "env"), class = "quoted")
194}
195