Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Silently ignore missing arguments in constructor #446

Draft
wants to merge 6 commits into
base: main
Choose a base branch
from
Draft
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion R/class.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")
}
Expand Down
3 changes: 2 additions & 1 deletion R/constructor.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")
Expand Down
8 changes: 0 additions & 8 deletions R/property.R
Original file line number Diff line number Diff line change
Expand Up @@ -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()
Expand Down
3 changes: 3 additions & 0 deletions R/utils.R
Original file line number Diff line number Diff line change
Expand Up @@ -144,6 +144,9 @@ modify_list <- function (x, new_vals) {
x
}

list2 <- function(...)
t-kalinowski marked this conversation as resolved.
Show resolved Hide resolved
.Call(collect_dots_skip_missing_, environment(), substitute(list(...)))


# For older versions of R ----------------------------------------------------
deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) {
Expand Down
2 changes: 2 additions & 0 deletions src/init.c
Original file line number Diff line number Diff line change
Expand Up @@ -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}
};

Expand Down
80 changes: 80 additions & 0 deletions src/object.c
Original file line number Diff line number Diff line change
@@ -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);
}
9 changes: 6 additions & 3 deletions tests/testthat/_snaps/constructor.md
Original file line number Diff line number Diff line change
Expand Up @@ -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>
Expand Down Expand Up @@ -66,7 +68,8 @@
Output
function (y = numeric(0))
{
y
if (!missing(y))
y
new_object(S7_object(), y = y)
}
<environment: namespace:S7>
Expand Down
11 changes: 7 additions & 4 deletions tests/testthat/test-constructor.R
Original file line number Diff line number Diff line change
Expand Up @@ -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)),
Expand All @@ -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
Expand Down
38 changes: 38 additions & 0 deletions tests/testthat/test-utils.R
Original file line number Diff line number Diff line change
@@ -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))
})
Loading