diff --git a/NAMESPACE b/NAMESPACE index 7472f90..fb9dbd0 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/cast.r b/R/cast.r index b77c301..40499be 100644 --- a/R/cast.r +++ b/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 diff --git a/R/utils.r b/R/utils.r index e26ecf3..de6afc2 100644 --- a/R/utils.r +++ b/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) +} diff --git a/tests/testthat/test-utils.r b/tests/testthat/test-utils.r new file mode 100644 index 0000000..1e65cfe --- /dev/null +++ b/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)) +})