promises.cpp

#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
RObject makeExplicit(SEXP prom) {
  if (TYPEOF(prom) != PROMSXP) {
    stop("Not a promise");
  }

  // recurse until we find the real promise, not a promise of a promise
  while(true) {
    SEXP code = PRCODE(prom);
    if(TYPEOF(code) != PROMSXP) break;
    prom = code;
  }

  RObject formula = Rf_lcons(Rf_install("~"), Rf_lcons(PRCODE(prom), R_NilValue));
  formula.attr(".Environment") = PRENV(prom);
  formula.attr("class") = "formula";

  return formula;
}

// [[Rcpp::export]]
RObject explicitPromise(Symbol name, Environment env) {
  SEXP prom = Rf_findVar(name, env);
  return makeExplicit(prom);
}

// [[Rcpp::export]]
RObject explicitDots(Environment env) {
  SEXP dots = env.find("...");

  // Count number of elements in dots
  int n = 0;
  while(dots != R_NilValue ){
    n++;
    dots = CDR(dots);
  }

  // Turn promises into formulas
  List out(n);
  dots = env.find("...");
  int i = 0;
  while(dots != R_NilValue ){
    out(i) = makeExplicit(CAR(dots));

    i++;
    dots = CDR(dots);
  }

  // Figure out names
  dots = env.find("...");
  CharacterVector names(n);

  i = 0;
  while(dots != R_NilValue){
    SEXP name = TAG(dots);
    if (Rf_isNull(name)) {
      names[i] = "";
    } else {
      names[i] = CHAR(PRINTNAME(name));
    }

    i++;
    dots = CDR(dots);
  }
  out.names() = names;


  return out;
}

/*** R
capture <- function(x) {
  explicitPromise(quote(x), environment())
}
explicit <- function(x) {
  explicitPromise(substitute(x), parent.frame())
}


eval2 <- function(x, data = NULL, env = parent.frame()) {
  if (is.formula(x)) {
    env <- environment(x)
    x <- x[[2]] # RHS of the formula
  }
  stopifnot(is.call(x) || is.formula(x))

  if (!is.null(data)) {
    eval(x, data, env)
  } else {
    eval(x, env)
  }
}

subset_q <- function(data, cond, env = parent.frame()) {
  r <- eval2(cond, data, env)
  r <- r & !is.na(r)
  data[r, , drop = FALSE]
}
subset_q(mtcars, quote(mpg > 31))
subset_q(mtcars, ~ mpg > 31)
f <- function(x) ~mpg > x
subset_q(mtcars, f(31))

subset <- function(data, cond) {
  cond <- explicit(cond)
  subset_q(data, cond)
}
subset(mtcars, mpg > 31)

*/