Re-implement plyr::eval.quoted, plyr::as.quoted

NAMESPACE

@@ -1,5 +1,13 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(as.quoted,character)
+S3method(as.quoted,formula)
+S3method(as.quoted,call)
+S3method(as.quoted,name)
+S3method(as.quoted,numeric)
+S3method(as.quoted,NULL)
+S3method(as.quoted,quoted)
+S3method(as.quoted,default)
 S3method(melt,array)
 S3method(melt,data.frame)
 S3method(melt,default)
@@ -16,13 +24,12 @@ import(stringr)
 importFrom(Rcpp,evalCpp)
 importFrom(plyr,alply)
 importFrom(plyr,amv_dimnames)
-importFrom(plyr,as.quoted)
-importFrom(plyr,eval.quoted)
 importFrom(plyr,id)
 importFrom(plyr,llply)
 importFrom(plyr,rbind.fill)
 importFrom(plyr,split_labels)
 importFrom(plyr,vaggregate)
+importFrom(stats,as.formula)
 importFrom(stats,setNames)
 importFrom(utils,type.convert)
 useDynLib(reshape2)

R/cast.r

@@ -41,7 +41,7 @@
 #' @param value.var name of column which stores values, see
 #'   \code{\link{guess_value}} for default strategies to figure this out.
 #' @seealso \code{\link{melt}},  \url{http://had.co.nz/reshape/}
-#' @importFrom plyr alply amv_dimnames as.quoted eval.quoted id llply rbind.fill split_labels vaggregate
+#' @importFrom plyr alply amv_dimnames id llply rbind.fill split_labels vaggregate
 #' @import stringr
 #' @examples
 #' #Air quality example

R/utils.r

@@ -52,3 +52,72 @@ normalize_melt_arguments <- function(data, measure.ind, factorsAsStrings) {
 is.string <- function(x) {
   is.character(x) && length(x) == 1
 }
+
+as.quoted <- function(x, env = parent.frame()) UseMethod("as.quoted")
+
+as.quoted.character <- function(x, env = parent.frame()) {
+  res <- lapply(x, function(expr) str2lang(expr))
+  names(res) <- x
+  attr(res, "env") <- env
+  class(res) <- "quoted"
+  res
+}
+
+as.quoted.formula <- function(x, env = environment(x)) {
+  rhs <- x[[length(x)]]
+  extract_terms <- function(expr) {
+    if (is.name(expr) || (is.call(expr) && as.character(expr[[1]]) != "+")) {
+      return(list(expr))
+    }
+    if (is.call(expr) && as.character(expr[[1]]) == "+") {
+      return(c(extract_terms(expr[[2]]), extract_terms(expr[[3]])))
+    }
+    list(expr)
+  }
+  res <- extract_terms(rhs)
+  names(res) <- vapply(res, function(e) deparse(e)[1], character(1))
+  attr(res, "env") <- env
+  class(res) <- "quoted"
+  res
+}
+
+as.quoted.call <- function(x, env = parent.frame()) {
+  res <- as.quoted.formula(as.formula(paste("~", deparse(x))), env)
+  res
+}
+
+as.quoted.name <- function(x, env = parent.frame()) {
+  res <- list(x)
+  names(res) <- as.character(x)
+  attr(res, "env") <- env
+  class(res) <- "quoted"
+  res
+}
+
+as.quoted.numeric <- function(x, env = parent.frame()) {
+  res <- list(x)
+  names(res) <- as.character(x)
+  attr(res, "env") <- env
+  class(res) <- "quoted"
+  res
+}
+
+as.quoted.NULL <- function(x, env = parent.frame()) {
+  res <- list()
+  attr(res, "env") <- env
+  class(res) <- "quoted"
+  res
+}
+
+as.quoted.quoted <- function(x, env = parent.frame()) x
+
+as.quoted.default <- function(x, env = parent.frame()) {
+  stop("Unsupported type in as.quoted", call. = FALSE)
+}
+
+eval.quoted <- function(exprs, envir = NULL, enclos = NULL) {
+  if (is.null(enclos)) enclos <- attr(exprs, "env")
+  if (is.null(envir)) envir <- enclos
+
+  lapply(exprs, eval, envir = envir, enclos = enclos)
+}

tests/testthat/test-utils.r

@@ -0,0 +1,32 @@
+test_that("as.quoted works like plyr::as.quoted", {
+  q1 <- as.quoted(~ a + b)
+  expect_equal(names(q1), c("a", "b"))
+  expect_true(is.name(q1[[1]]))
+  expect_true(is.name(q1[[2]]))
+  expect_identical(class(q1), "quoted")
+
+  q2 <- as.quoted(c("a", "b"))
+  expect_equal(names(q2), c("a", "b"))
+  expect_true(is.name(q2[[1]]))
+  expect_true(is.name(q2[[2]]))
+  expect_identical(class(q2), "quoted")
+
+  q3 <- as.quoted(c("a", "log(b)"))
+  expect_equal(names(q3), c("a", "log(b)"))
+  expect_true(is.name(q3[[1]]))
+  expect_true(is.call(q3[[2]]))
+})
+
+test_that("eval.quoted evaluates expressions in supplied environment", {
+  df <- data.frame(a = 1:2, b = 3:4)
+  q <- as.quoted(~ a + b)
+  res <- eval.quoted(q, envir = df)
+
+  expect_equal(res$a, 1:2)
+  expect_equal(res$b, 3:4)
+
+  q2 <- as.quoted(c("a", "log(b)"))
+  res2 <- eval.quoted(q2, envir = df)
+  expect_equal(res2$a, 1:2)
+  expect_equal(res2$`log(b)`, log(3:4))
+})