Experimental f_list() #59

NAMESPACE

@@ -62,6 +62,7 @@ export(uqf)
 export(uqs)
 useDynLib(lazyeval,find_expr_)
 useDynLib(lazyeval,lhs)
+useDynLib(lazyeval,lhs_name)
 useDynLib(lazyeval,make_lazy)
 useDynLib(lazyeval,make_lazy_dots)
 useDynLib(lazyeval,quasiquote_c)

R/formula.R

@@ -77,3 +77,8 @@ f_unwrap <- function(f) {
     f_new(substitute_(f_rhs(f), e), parent.env(e))
   }
 }
+
+#' @useDynLib lazyeval lhs_name
+f_list <- function(...) {
+  .Call(lhs_name, list(...))
+}

src/name.c

@@ -0,0 +1,33 @@
+#define R_NO_REMAP
+#include <R.h>
+#include <Rinternals.h>
+#include "utils.h"
+
+SEXP lhs_name(SEXP x) {
+  if (TYPEOF(x) != VECSXP)
+    Rf_errorcall(R_NilValue, "`x` must be a list (not a %s)", Rf_type2char(TYPEOF(x)));
+
+  int n = Rf_length(x);
+  SEXP x2 = Rf_shallow_duplicate(x);
+
+  SEXP names = Rf_getAttrib(x2, R_NamesSymbol);
+  if (names == R_NilValue) {
+    names = Rf_allocVector(STRSXP, n);
+    Rf_setAttrib(x2, R_NamesSymbol, names);
+  }
+
+  for (int i = 0; i < n; ++i) {
+    SEXP xi = VECTOR_ELT(x2, i);
+    if (!is_formula(xi) || Rf_length(xi) != 3)
+      continue;
+
+    SEXP name = Rf_eval(lhs(xi), f_env(xi));
+    if (TYPEOF(name) != STRSXP || Rf_length(name) != 1)
+      Rf_errorcall(R_NilValue, "LHS must evaluate to a single string");
+
+    SET_VECTOR_ELT(x2, i, Rf_lang2(CAR(xi), CADDR(xi)));
+    SET_STRING_ELT(names, i, STRING_ELT(name, 0));
+  }
+
+  return x2;
+}

src/utils.c

@@ -25,8 +25,22 @@ bool is_lazy_load(SEXP x) {
   return is_call_to(PREXPR(x), "lazyLoadDBfetch");
 }
 
+SEXP findLast(SEXP x) {
+  SEXP cons = x;
+  while(CDR(cons) != R_NilValue)
+    cons = CDR(cons);
+
+  return cons;
+}
+
+// Formulas --------------------------------------------------------------------
+
+bool is_formula(SEXP x) {
+  return TYPEOF(x) == LANGSXP && Rf_inherits(x, "formula");
+}
+
 SEXP rhs(SEXP f) {
-  if (TYPEOF(f) != LANGSXP || !Rf_inherits(f, "formula"))
+  if (!is_formula(f))
     Rf_errorcall(R_NilValue, "`x` is not a formula");
 
   switch (Rf_length(f)) {
@@ -37,7 +51,7 @@ SEXP rhs(SEXP f) {
 }
 
 SEXP lhs(SEXP f) {
-  if (TYPEOF(f) != LANGSXP || !Rf_inherits(f, "formula"))
+  if (!is_formula(f))
     Rf_errorcall(R_NilValue, "`x` is not a formula");
 
   switch (Rf_length(f)) {
@@ -47,11 +61,9 @@ SEXP lhs(SEXP f) {
   }
 }
 
+SEXP f_env(SEXP f) {
+  if (!is_formula(f))
+    Rf_errorcall(R_NilValue, "`x` is not a formula");
 
-SEXP findLast(SEXP x) {
-  SEXP cons = x;
-  while(CDR(cons) != R_NilValue)
-    cons = CDR(cons);
-
-  return cons;
+  return Rf_getAttrib(f, Rf_install(".Environment"));
 }

src/utils.h

@@ -6,5 +6,8 @@
 bool is_lazy_load(SEXP x);
 bool is_scalar(SEXP x);
 bool is_call_to(SEXP x, const char* f);
+bool is_formula(SEXP x);
 SEXP rhs(SEXP f);
+SEXP lhs(SEXP f);
+SEXP f_env(SEXP f);
 SEXP findLast(SEXP x);

tests/testthat/test-f-list.R

@@ -0,0 +1,24 @@
+context("f_list")
+
+test_that("regular elements are left as is", {
+  expect_equal(f_list(x = 1:10), list(x = 1:10))
+  expect_equal(f_list(x = ~x), list(x = ~x))
+})
+
+test_that("output always has names", {
+  out <- f_list(1, 2, 3)
+  expect_equal(names(out), c("", "", ""))
+})
+
+test_that("names taken from LHS of formula", {
+  out <- f_list("x" ~ y)
+  expect_equal(out, list(x = ~y))
+})
+
+test_that("LHS evaluated in formula environment", {
+  f <- function(x) {
+    paste0(x, 1) ~ y
+  }
+
+  expect_equal(f_list(f("y")), list(y1 = ~ y))
+})