Skip to content

Commit

Permalink
Experimental f_list() #59
Browse files Browse the repository at this point in the history
hadley committed Apr 8, 2016

Verified

This commit was signed with the committer’s verified signature.
sdispater Sébastien Eustace
1 parent dbab8c8 commit 5ac45d5
Showing 6 changed files with 86 additions and 8 deletions.
1 change: 1 addition & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
@@ -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)
5 changes: 5 additions & 0 deletions R/formula.R
Original file line number Diff line number Diff line change
@@ -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(...))
}
33 changes: 33 additions & 0 deletions src/name.c
Original file line number Diff line number Diff line change
@@ -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;
}
28 changes: 20 additions & 8 deletions src/utils.c
Original file line number Diff line number Diff line change
@@ -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"));
}
3 changes: 3 additions & 0 deletions src/utils.h
Original file line number Diff line number Diff line change
@@ -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);
24 changes: 24 additions & 0 deletions tests/testthat/test-f-list.R
Original file line number Diff line number Diff line change
@@ -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))
})

0 comments on commit 5ac45d5

Please sign in to comment.