substitute2 draft

R/programming.R

@@ -0,0 +1,31 @@
+substitute2 = function(expr, env, char.as.name=FALSE, sub.names=TRUE) {
+  if (missing(env)) {
+    stop("TODO")
+  } else if (is.environment(env)) {
+    env = as.list(env, all.names=TRUE) ## todo: try to use environment rather than list
+  } else if (!is.list(env)) {
+    stop("'env' must be a list of an environment")
+  }
+  env.names = names(env)
+  if (is.null(env.names)) {
+    stop("'env' argument does not have names")
+  } else if (any(!nzchar(env.names))) {
+    stop("'env' argument has an zero char names")
+  }
+  if (isTRUE(char.as.name)) {
+    char = vapply(env, is.character, FALSE)
+    if (any(char)) {
+      if (any(non.scalar.char <- lengths(env[char])!=1L)) {
+        stop("'char.as.name' was used but the following character elements provided in 'env' are not scalar: ",
+             paste(names(non.scalar.char)[non.scalar.char], collapse=", "))
+      }
+      env[char] = lapply(env[char], as.name)
+    }
+  }
+  expr.sub = eval(substitute(substitute(expr, env)))
+  if (isTRUE(sub.names)) {
+    .Call(Csubstitute_call_arg_namesR, expr.sub, env)
+  } else {
+    expr.sub
+  }
+}

R/wrappers.R

@@ -12,10 +12,3 @@ colnamesInt = function(x, cols, check_dups=FALSE) .Call(CcolnamesInt, x, cols, c
 coerceFill = function(x) .Call(CcoerceFillR, x)
 
 testMsg = function(status=0L, nx=2L, nk=2L) .Call(CtestMsgR, as.integer(status)[1L], as.integer(nx)[1L], as.integer(nk)[1L])
-
-replace_names = function(expr, env) {
-  #replace_names(quote(.(fvar1=fun(var1, arg1=TRUE), charhead=head(var2, 1L))), sapply(list(var1="myIntCol", fvar1="a_col", var2="myCharCol", fun="sum", arg1="na.rm"), as.symbol))
-  stopifnot(is.list(env), as.logical(length(env)), !is.null(names(env)), #sapply(env, is.character), sapply(env, nzchar), sapply(env, length)==1L,
-            is.language(expr))
-  .Call(Creplace_namesR, expr, env)
-}

src/data.table.h

@@ -247,4 +247,4 @@ SEXP fifelseR(SEXP l, SEXP a, SEXP b, SEXP na);
 SEXP fcaseR(SEXP na, SEXP rho, SEXP args);
 
 // programming.c
-SEXP replace_namesR(SEXP expr, SEXP env);
+SEXP substitute_call_arg_namesR(SEXP expr, SEXP env);

src/init.c

@@ -211,7 +211,7 @@ R_CallMethodDef callMethods[] = {
 {"CfrollapplyR", (DL_FUNC) &frollapplyR, -1},
 {"CtestMsgR", (DL_FUNC) &testMsgR, -1},
 {"C_allNAR", (DL_FUNC) &allNAR, -1},
-{"Creplace_namesR", (DL_FUNC) &replace_namesR, -1},
+{"Csubstitute_call_arg_namesR", (DL_FUNC) &substitute_call_arg_namesR, -1},
 {NULL, NULL, 0}
 };
 

src/programming.c

@@ -1,34 +1,30 @@
 #include "data.table.h"
 
-void replace_names(SEXP expr, SEXP env) {
+static void substitute_call_arg_names(SEXP expr, SEXP env) {
   R_len_t len = length(expr);
-  if (!isNull(expr) && len && isLanguage(expr)) { // isLanguage is R's is.call
-    SEXP exprnames = getAttrib(expr, R_NamesSymbol);
-    if (!isNull(exprnames)) {
-      SEXP envnames = getAttrib(env, R_NamesSymbol);
-      SEXP matches = PROTECT(chmatch(exprnames, envnames, 0));
-      int *imatches = INTEGER(matches);
-      const SEXP *sexpr = SEXPPTR_RO(exprnames);
-      const SEXP *senv = SEXPPTR_RO(env);
-      SEXP tmp = expr;
-      for (int i=0; i<len; i++) {
+  if (len && isLanguage(expr)) { // isLanguage is R's is.call
+    SEXP arg_names = getAttrib(expr, R_NamesSymbol);
+    if (!isNull(arg_names)) {
+      SEXP env_names = getAttrib(env, R_NamesSymbol);
+      int *imatches = INTEGER(PROTECT(chmatch(arg_names, env_names, 0)));
+      //const SEXP *expr_arg_names = SEXPPTR_RO(arg_names); // only for print, to be removed
+      const SEXP *env_sub = SEXPPTR_RO(env);
+      int i = 0;
+      for (SEXP tmp=expr; tmp!=R_NilValue; tmp=CDR(tmp)) {
         if (imatches[i]) {
-          Rprintf("substitute: %s -> %s\n", CHAR(sexpr[i]), CHAR(PRINTNAME(senv[imatches[i]-1])));
-          SET_TAG(tmp, senv[imatches[i]-1]);
+          //Rprintf("substitute names: %s -> %s\n", CHAR(expr_arg_names[i]), CHAR(PRINTNAME(env_sub[imatches[i]-1]))); // to be removed
+          SET_TAG(tmp, env_sub[imatches[i]-1]);
         }
-        tmp = CDR(tmp);
+        i++;
+        substitute_call_arg_names(CADR(tmp), env); // try substitute names in child calls
       }
-      UNPROTECT(1); // matches
-      // update also nested calls
-      for (SEXP t=expr; t!=R_NilValue; t=CDR(t))
-        replace_names(CADR(t), env);
+      UNPROTECT(1); // chmatch
     }
   }
 }
-SEXP replace_namesR(SEXP expr, SEXP env) {
-  // move R's checks here, escape for 0 length, etc
+SEXP substitute_call_arg_namesR(SEXP expr, SEXP env) {
   SEXP ans = PROTECT(MAYBE_REFERENCED(expr) ? duplicate(expr) : expr);
-  replace_names(ans, env); // updates in-place
+  substitute_call_arg_names(ans, env); // updates in-place
   UNPROTECT(1);
   return ans;
 }

tests/programming.R

@@ -0,0 +1,23 @@
+cc(F)
+
+substitute2(
+  .(fun_ans_var = fun(farg1, farg2=farg2val), timestamp=Sys.time(), col_head = head(head_arg, n=1L)),
+  list(
+    fun_ans_var = "my_mean_res",
+    fun = "mean",
+    farg1 = "my_x_col",
+    farg2 = "na.rm",
+    farg2val = TRUE,
+    col_head = "first_y",
+    head_arg = "y"
+  ),
+  char.as.name=TRUE
+)
+
+const1 = function() 1L
+substitute2(list(nm = fun()), env=list(a="b", fun="const1", nm="int1"), char.as.name=TRUE)
+substitute2(.(), env=list(a="b", fun="const1", nm="int1"), char.as.name=TRUE)
+
+substitute2(.("TRUE" = 1L, "FALSE" = 2L, "1" = 3L, "2" = 4L),
+            env=list("FALSE"="col2", "2"="col4"),
+            char.as.name=TRUE)