Silently ignore missing arguments in constructor

R/class.R

@@ -252,7 +252,7 @@ new_object <- function(.parent, ...) {
     stop(msg)
   }
 
-  args <- list(...)
+  args <- list2(...)
   nms <- names(args)
 
   # TODO: Some type checking on `.parent`?

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,56 @@
+#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. Ideally we could iterate
+    // over the DOTSXP list of promises directly, but there is currently
+    // no non-"non-API" way to do this. So we use `base::missing(..i)` to
+    // test for missingness, and use `substitute(list(...))` to get the
+    // promise expressions.
+    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);
+    }
+    // 14 = 2 for ".." + up to 10 digit number + '\0' + 1 extra for safety
+    static char ddi_buf[14] = "..";
+    static char *i_buf = ddi_buf + 2;
+    ddi_buf[13] = '\0'; // Technically not necessary, but just to be safe
+
+    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++) {
+        snprintf(i_buf, sizeof(ddi_buf) - 2, "%u", i);
+        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)) {
+            ddExpr_node = CDR(ddExpr_node);
+            SETCDR(prev_node, ddExpr_node);
+        } else {
+            if (TAG(ddExpr_node) == R_NilValue) {
+                SEXP val_expr = CAR(ddExpr_node);
+                if (TYPEOF(val_expr) == SYMSXP) {
+                    SET_TAG(ddExpr_node, val_expr);
+                }
+            }
+            SETCAR(ddExpr_node, ddSym);
+            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

@@ -69,3 +69,23 @@
       new_object(foo(...), y = y)
       <environment: 0x0>
 
+# can create constructors with missing or lazy defaults
+
+    Code
+      Person()
+    Condition
+      Error:
+      ! <Person> object properties are invalid:
+      - @first_name must be <character>, not <NULL>
+      - @last_name must be <MISSING> or <character>, not <NULL>
+      - @nick_name must be <character>, not <NULL>
+
+---
+
+    Code
+      Person("Alice")
+    Condition
+      Error:
+      ! <Person> object properties are invalid:
+      - @last_name must be <MISSING> or <character>, not <NULL>
+

tests/testthat/test-constructor.R

@@ -140,8 +140,8 @@ test_that("can create constructors with missing or lazy defaults", {
     birthdate = Sys.Date()
   ))) # no age
 
-  expect_error(Person(), 'argument "first_name" is missing, with no default')
-  expect_error(Person("Alice"), 'argument "last_name" is missing, with no default')
+  expect_snapshot(Person(), error = TRUE)
+  expect_snapshot(Person("Alice"), error = TRUE)
 
   p <- Person("Alice", ,"Smith")
 

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))
+})