Silently ignore missing arguments in constructor

R/class.R

@@ -252,7 +252,7 @@ new_object <- function(.parent, ...) {
     stop(msg)
   }
 
-  args <- list(...)
+  args <- list2(...)
   if ("" %in% names2(args)) {
     stop("All arguments to `...` must be named")
   }

R/constructor.R

@@ -9,7 +9,8 @@ new_constructor <- function(parent, properties) {
       body = as.call(c(quote(`{`),
         # Force all promises here so that any errors are signaled from
         # the constructor() call instead of the new_object() call.
-        unname(self_args),
+        # allow missing.
+        lapply(unname(self_args), \(sym) bquote(if(!missing(.(sym))) .(sym))),
         new_call("new_object", c(list(quote(S7_object())), self_args))
       )),
       env = asNamespace("S7")

R/property.R

@@ -115,14 +115,6 @@ check_prop_default <- function(default, class, error_call = sys.call(-1)) {
   }
 
   if (is.symbol(default)) {
-    if (identical(default, quote(...))) {
-      # The meaning of a `...` prop default needs discussion
-      stop(simpleError("`default` cannot be `...`", error_call))
-    }
-    if (identical(default, quote(expr =))) {
-      # The meaning of a missing prop default needs discussion
-      stop(simpleError("`default` cannot be missing", error_call))
-    }
 
     # other symbols are treated as promises
     return()

R/utils.R

@@ -144,6 +144,9 @@ modify_list <- function (x, new_vals) {
   x
 }
 
+list2 <- function(...)
+  .Call(collect_dots_skip_missing_, environment(), substitute(list(...)))
+
 
 # For older versions of R ----------------------------------------------------
 deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) {

src/init.c

@@ -10,13 +10,15 @@ extern SEXP S7_class_(SEXP, SEXP);
 extern SEXP S7_object_(void);
 extern SEXP prop_(SEXP, SEXP);
 extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP);
+extern SEXP collect_dots_skip_missing_(SEXP, SEXP);
 
 static const R_CallMethodDef CallEntries[] = {
     {"method_", (DL_FUNC) &method_, 4},
     {"method_call_", (DL_FUNC) &method_call_, 3},
     {"S7_object_", (DL_FUNC) &S7_object_, 0},
     {"prop_", (DL_FUNC) &prop_, 2},
     {"prop_set_", (DL_FUNC) &prop_set_, 4},
+    {"collect_dots_skip_missing_", (DL_FUNC) &collect_dots_skip_missing_, 2},
     {NULL, NULL, 0}
 };
 

src/object.c

@@ -0,0 +1,80 @@
+#define R_NO_REMAP
+#include <R.h>
+#include <Rinternals.h>
+
+SEXP collect_dots_skip_missing_(SEXP env, SEXP list_dddExprs_call) {
+    // This function is equivalent to `base::list(...)`, except it
+    // silently skips missing arguments, and auto-names elements
+    // that are unnamed and supplied in the call as a symbol. I.e.,
+    // f(a, , b+1) becomes f(a = a, b+1)
+    //
+    // Implementation note: ideally we could iterate
+    // over the DOTSXP list of promises directly, but there is currently
+    // no non-"non-API" way to do this. Approved API promise accessors are
+    // pending. So, in the interim, we use `base::missing(..i)` to
+    // test for missingness, and use `substitute(list(...))` to get the
+    // promise expressions.
+    //
+    // This same C function can be use to add "skip-missing" and "auto-name" to
+    // any function that takes dots. E.g.:
+    //
+    // list2     <- function(...) .Call(collect_dots_skip_missing_, substitute(list(...)))
+    // c2        <- function(...) .Call(collect_dots_skip_missing_, substitute(c(...)))
+    // pairlist2 <- function(...) .Call(collect_dots_skip_missing_, substitute(pairlist(...)))
+    static SEXP missing_call = NULL;
+    if (missing_call == NULL) {
+        SEXP missing_fun = Rf_eval(Rf_install("missing"), R_BaseEnv);
+        missing_call = Rf_lang2(missing_fun, R_NilValue);
+        R_PreserveObject(missing_call);
+    }
+
+    static char ddi_buf[14] = "..";
+    static char *i_buf = ddi_buf + 2;
+
+    PROTECT_INDEX pi;
+    PROTECT_WITH_INDEX(R_NilValue, &pi);
+
+    {
+    unsigned int i = 1;
+    SEXP prev_node = list_dddExprs_call;
+    SEXP ddExpr_node = CDR(list_dddExprs_call);
+    for (; ddExpr_node != R_NilValue; i++) {
+        {
+        int ret = snprintf(i_buf, sizeof(ddi_buf) - 2, "%u", i);
+        if (ret < 0)
+            Rf_error("unknown snprintf error");
+        if (ret >= (int)(sizeof(ddi_buf) - 3))
+            Rf_error("snprintf truncated output, too many args in `...`");
+        ddi_buf[sizeof(ddi_buf) - 1] = '\0'; // just in case
+        }
+
+        SEXP ddSym = Rf_install(ddi_buf);
+
+        SETCADR(missing_call, ddSym);
+        SEXP is_missing = Rf_eval(missing_call, env);
+        REPROTECT(is_missing, pi);
+
+        if (Rf_asLogical(is_missing)) {
+            // splice out the node from the exprs list.
+            ddExpr_node = CDR(ddExpr_node);
+            SETCDR(prev_node, ddExpr_node);
+        } else {
+            // maybe auto-name if unnamed and expr is a symbol.
+            if (TAG(ddExpr_node) == R_NilValue) {
+                SEXP val_expr = CAR(ddExpr_node);
+                if (TYPEOF(val_expr) == SYMSXP) {
+                    SET_TAG(ddExpr_node, val_expr);
+                }
+            }
+            // replace the node expr with `..i`
+            SETCAR(ddExpr_node, ddSym);
+            // advance to the next node.
+            prev_node = ddExpr_node;
+            ddExpr_node = CDR(ddExpr_node);
+        }
+    }
+    }
+
+    UNPROTECT(1); // is_missing
+    return Rf_eval(list_dddExprs_call, env);
+}

tests/testthat/_snaps/constructor.md

@@ -13,8 +13,10 @@
     Output
       function (x = integer(0), y = integer(0)) 
       {
-          x
-          y
+          if (!missing(x)) 
+              x
+          if (!missing(y)) 
+              y
           new_object(S7_object(), x = x, y = y)
       }
       <environment: namespace:S7>
@@ -66,7 +68,8 @@
     Output
       function (y = numeric(0)) 
       {
-          y
+          if (!missing(y)) 
+              y
           new_object(S7_object(), y = y)
       }
       <environment: namespace:S7>

tests/testthat/test-constructor.R

@@ -102,14 +102,17 @@ test_that("can create constructors with missing or lazy defaults", {
     name = "Person",
     properties = list(
       # non-dynamic, default error call (required constructor arg)
-      first_name = new_property(class_character, default = quote(stop(
-        'argument "first_name" is missing, with no default'))),
+      first_name = new_property(
+        class_character,
+        default = quote(stop('argument "first_name" is missing, with no default'))
+      ),
 
       # non-dynamic, static default (optional constructor arg)
       middle_name = new_property(class_character, default = ""),
 
       # non-dynamic, nullable character
-      last_name = new_property(NULL | class_character),
+      last_name = new_property(NULL | class_character,
+                               default = quote(expr =)),
 
       # non-dynamic, but defaults to the value of another property
       nick_name = new_property(class_character, default = quote(first_name)),
@@ -136,7 +139,7 @@ test_that("can create constructors with missing or lazy defaults", {
   expect_equal(formals(Person), as.pairlist(alist(
     first_name = stop('argument "first_name" is missing, with no default'),
     middle_name = "",
-    last_name = NULL,
+    last_name = ,
     nick_name = first_name,
     birthdate = Sys.Date()
   ))) # no age

tests/testthat/test-utils.R

@@ -0,0 +1,38 @@
+test_that("list2() works", {
+  # list2() is equivalent to base::list(), with the following differences:
+  # - A missing arg value is silently ignored instead of signaling an error.
+  # - An argument is automatically named if it is unnamed and the value expression is a symbol.
+
+  expect_identical(list2(), list())
+  expect_identical(list2(a = 1),             list(a = 1))
+  expect_identical(list2(a = 1, b = ),       list(a = 1))
+  expect_identical(list2(a = 1, b = , , ),   list(a = 1))
+  expect_identical(list2(, a = 1, b = , , ), list(a = 1))
+  a <- 1
+  expect_identical(list2(a),               list(a = 1))
+  expect_identical(list2(a, b = ),         list(a = 1))
+  expect_identical(list2(a, b = , a, ),    list(a = 1, a = 1))
+  expect_identical(list2(a = identity(a)), list(a = 1))
+
+  expect_identical(list2((a)),             list(1))
+  expect_identical(list2(identity(a)),     list(1))
+
+  # make sure all this works if values in `...` are nested promises
+  f1 <- function(...) list2(...)
+  f2 <- function(..., b) f1(..., b)
+  f3 <- function(..., c) f2(..., c)
+  f4 <- function(..., d) f3(..., d)
+
+  a <- 1; b <- 2
+  for (f in list(f1, f2, f3, f4, list2)) {
+    expect_identical(f(), list())
+    expect_mapequal(f(a = 1),        list(a = 1))
+    expect_mapequal(f(a = 1, b =),   list(a = 1))
+    expect_mapequal(f(a = 1, b = 2), list(a = 1, b = 2))
+    expect_mapequal(f(a, b),         list(a = 1, b = 2))
+  }
+
+  expect_identical(list2(a, b, a + b),       list(a = 1, b = 2,     3))
+  expect_identical(list2(a, b, c = a + b),   list(a = 1, b = 2, c = 3))
+  expect_identical(list2((a), b, c = a + b), list(    1, b = 2, c = 3))
+})