diff --git a/R/evaluation.R b/R/evaluation.R index 37f5b4b..4e2bc17 100644 --- a/R/evaluation.R +++ b/R/evaluation.R @@ -1,5 +1,139 @@ +is_expression <- function(e) { + + ifelse(any(c("call", "name") %in% class(e)), TRUE, FALSE) + +} + +is_list_expression <- function(e) { + + ifelse(is_expression(e) && deparse(as.list(e)[[1]]) == "list", TRUE, FALSE) + +} + +is_dollar_expression <- function(e) { + + ifelse(is_expression(e) && deparse(as.list(e)[[1]]) == "$", TRUE, FALSE) + +} + + +is_variable <- function(x) { + + varModes <- c("numeric", "complex", "logical", "character", "raw") + + ifelse(mode(x) %in% varModes, TRUE, FALSE) + +} + + +evalArg <- function(arg, ...) { + UseMethod("evalArg") +} + + +evalArg.default <- function(arg, env, enc) { + if (is.list(arg)) { + arg <- as.list(arg) + } else if (is_variable(arg)) { + l <- list(arg) + } + return(arg) +} + +evalArg.name <- function(arg, env, enc) { + d <- deparse(arg) + out <- try(get(d, envir = env, inherits = FALSE), silent = TRUE) + if (inherits(out, "try-error")) { + out <- try(get(d, envir = enc, inherits = FALSE), silent = TRUE) + } + if (inherits(out, "try-error")) { + stop("Could not find object ", d, ".") + } + out <- list(out) + names(out) <- d + out +} + +evalArg.call <- function(arg, env, enc) { + + out <- eval(arg, env = env, enc = enc) + if (is.list(out)) { + out <- as.list(out) + } else if (is_variable(out)) { + out <- list(out) + names(out) <- paste0(deparse(arg), collapse = "") + } + out +} + +evalArg.character <- function(arg, env, enc) { + ## NOTE: enc unused + se <- substitute(env) + out <- lapply(arg, function(stri) { + try({ + get(stri, envir = as.environment(env), inherits = FALSE) + }, silent = TRUE) + }) + + notFound <- arg[sapply(out, inherits, "try-error")] + + if (length(notFound)) { + stop("Could not find object(s): ", + paste0(head(notFound, 5), collapse = ", "), ".") + } + names(out) <- arg + out +} + +evalArg.formula <- function(arg, env, enc) { + + rhsl <- as.list(RHS2DT(arg, data = env, enclos = enc)) + + rhsl + +} + + +method_classes <- function(f) { + + stopifnot(is.character(f)) + e <- utils::methods(f) + e <- sapply(e, as.character) + sapply(e, sub, pattern = paste0(f, "."), replacement = "") + +} + + +evalPopArg2 <- function(data, arg, enclos, DT = TRUE) { + + tick <- 1L + use_env <- data + use_enc <- enclos + r <- arg + eam <- setdiff(method_classes("evalArg"), "default") + while (any(class(r) %in% eam)) { + if (is_dollar_expression(r)) { + use_env <- use_enc + use_enc <- baseenv() + } + + r <- evalArg(arg, env = use_env, enc = use_enc) + + + use_env <- data + use_enc <- enclos + tick <- tick + 1L + } + + r +} + + + + + evalPopArg <- function(data, arg, n = 1L, DT = TRUE, enclos = NULL, recursive = TRUE, types = c("NULL","character", "list", "expression"), naming = c("DT", "model")) { ## arg: an unevaluated AND substitute()'d argument within a function, which may be ## * an expression @@ -235,6 +369,7 @@ popArg2ModelNames <- function(arg, type) { + uses_dollar <- function(q, data.names) { ## INTENTION: determine whether q is an expressions that is evaluated ## outside a data.frame, i.e. one that uses the dollar operator.