Let C level vec_ptype_common() optionally opt out of ptype finalization

Then use this in `list_combine()` to delay finalization until `default` has been considered.

Author: DavisVaughan

R/type.R

@@ -120,11 +120,18 @@ vec_ptype_common <- function(
 vec_ptype_common_params <- function(
   ...,
   .ptype = NULL,
+  .finalise = TRUE,
   .fallback_opts = fallback_opts(),
   .arg = "",
   .call = caller_env()
 ) {
-  .External2(ffi_ptype_common_params, list2(...), .ptype, .fallback_opts)
+  .External2(
+    ffi_ptype_common_params,
+    list2(...),
+    .ptype,
+    .finalise,
+    .fallback_opts
+  )
 }
 
 vec_ptype_common_fallback <- function(

src/bind.c

@@ -74,6 +74,7 @@ r_obj* vec_rbind(r_obj* xs,
   ptype = vec_ptype_common(
     xs,
     ptype,
+    PTYPE_FINALISE_DEFAULT,
     S3_FALLBACK_true,
     p_arg,
     error_call
@@ -498,6 +499,7 @@ r_obj* vec_cbind(r_obj* xs,
   r_obj* type = KEEP(vec_ptype_common(
     xs_data_frames,
     ptype,
+    PTYPE_FINALISE_DEFAULT,
     S3_FALLBACK_false,
     p_arg,
     error_call

src/cast.c

@@ -255,6 +255,7 @@ r_obj* vec_cast_common_opts(r_obj* xs,
   r_obj* type = KEEP(vec_ptype_common(
     xs,
     to,
+    PTYPE_FINALISE_DEFAULT,
     opts->s3_fallback,
     opts->p_arg,
     opts->call

src/init.c

@@ -390,7 +390,7 @@ extern r_obj* ffi_new_data_frame(r_obj*);
 static
 const R_ExternalMethodDef ExtEntries[] = {
   {"ffi_ptype_common",                 (DL_FUNC) &ffi_ptype_common, 2},
-  {"ffi_ptype_common_params",          (DL_FUNC) &ffi_ptype_common_params, 3},
+  {"ffi_ptype_common_params",          (DL_FUNC) &ffi_ptype_common_params, 4},
   {"ffi_size_common",                  (DL_FUNC) &ffi_size_common, 3},
   {"ffi_recycle_common",               (DL_FUNC) &ffi_recycle_common, 2},
   {"ffi_cast_common",                  (DL_FUNC) &ffi_cast_common, 2},

src/list-combine.c

@@ -809,6 +809,7 @@ r_obj* list_combine_common_class_fallback(
     vec_ptype_common(
       xs,
       ptype,
+      PTYPE_FINALISE_DEFAULT,
       s3_fallback,
       p_xs_arg,
       error_call
@@ -1802,10 +1803,12 @@ r_obj* ptype_common_with_default(
 
   // Okay `ptype` is `NULL`. We determine it from `xs` and `default`.
 
-  // Use only `xs` and `p_xs_arg` first for best errors
+  // Use only `xs` and `p_xs_arg` first for best errors.
+  // Not finalising `ptype` yet in case we need to incorporating `default`!
   ptype = KEEP(vec_ptype_common(
     xs,
     ptype,
+    PTYPE_FINALISE_false,
     s3_fallback,
     p_xs_arg,
     error_call
@@ -1826,7 +1829,10 @@ r_obj* ptype_common_with_default(
   }
   KEEP(ptype);
 
-  FREE(2);
+  // Now finalise after incorporating `default`
+  ptype = KEEP(vec_ptype_finalise(ptype));
+
+  FREE(3);
   return ptype;
 }
 

src/ptype-common.c

@@ -18,10 +18,15 @@ r_obj* ffi_ptype_common(r_obj* ffi_call, r_obj* op, r_obj* args, r_obj* env) {
   struct r_lazy xs_arg_lazy = { .x = syms.dot_arg, .env = env };
   struct vctrs_arg xs_arg = new_lazy_arg(&xs_arg_lazy);
 
+  // User calls to `vec_ptype_common()` are always finalised and never fall back
+  const enum ptype_finalise finalise = PTYPE_FINALISE_true;
+  const enum s3_fallback s3_fallback = S3_FALLBACK_false;
+
   r_obj* out = vec_ptype_common(
     xs,
     ptype,
-    S3_FALLBACK_false,
+    finalise,
+    s3_fallback,
     &xs_arg,
     call
   );
@@ -35,17 +40,22 @@ r_obj* ffi_ptype_common_params(r_obj* ffi_call, r_obj* op, r_obj* args, r_obj* e
 
   r_obj* xs = r_node_car(args); args = r_node_cdr(args);
   r_obj* ptype = r_node_car(args); args = r_node_cdr(args);
+  r_obj* ffi_finalise = r_node_car(args); args = r_node_cdr(args);
   r_obj* opts = r_node_car(args);
 
   struct r_lazy call = { .x = syms.dot_call, .env = env };
   struct r_lazy xs_arg_lazy = { .x = syms.dot_arg, .env = env };
   struct vctrs_arg xs_arg = new_lazy_arg(&xs_arg_lazy);
 
+  const enum ptype_finalise finalise = r_arg_as_bool(ffi_finalise, "finalise") ?
+    PTYPE_FINALISE_true :
+    PTYPE_FINALISE_false;
   const enum s3_fallback s3_fallback = s3_fallback_from_opts(opts);
 
   r_obj* out = vec_ptype_common(
     xs,
     ptype,
+    finalise,
     s3_fallback,
     &xs_arg,
     call
@@ -55,39 +65,50 @@ r_obj* ffi_ptype_common_params(r_obj* ffi_call, r_obj* op, r_obj* args, r_obj* e
 }
 
 // Invariant of `vec_ptype_common()` is that the output is always a finalised `ptype`,
-// even if the user provided their own
+// even if the user provided their own, unless `PTYPE_FINALISE_false` is specified.
 r_obj* vec_ptype_common(
   r_obj* dots,
   r_obj* ptype,
+  enum ptype_finalise finalise,
   enum s3_fallback s3_fallback,
   struct vctrs_arg* p_arg,
   struct r_lazy call
 ) {
+  int n_prot = 0;
+
+  r_obj* out;
+
   if (ptype != r_null) {
-    return vec_ptype_final(ptype, vec_args.dot_ptype, call);
+    out = KEEP_N(vec_ptype(ptype, vec_args.dot_ptype, call), &n_prot);
+  } else {
+    if (r_is_true(r_peek_option("vctrs.no_guessing"))) {
+      r_abort_lazy_call(r_lazy_null, "strict mode is activated; you must supply complete `.ptype`.");
+    }
+
+    struct ptype_common_reduce_opts reduce_opts = {
+      .call = call,
+      .s3_fallback = s3_fallback
+    };
+
+    out = KEEP_N(
+      reduce(
+        r_null,
+        vec_args.empty,
+        p_arg,
+        dots,
+        &ptype2_common,
+        &reduce_opts
+      ),
+      &n_prot
+    );
   }
 
-  if (r_is_true(r_peek_option("vctrs.no_guessing"))) {
-    r_abort_lazy_call(r_lazy_null, "strict mode is activated; you must supply complete `.ptype`.");
+  if (should_finalise(finalise)) {
+    out = KEEP_N(vec_ptype_finalise(out), &n_prot);
   }
 
-  struct ptype_common_reduce_opts reduce_opts = {
-    .call = call,
-    .s3_fallback = s3_fallback
-  };
-
-  r_obj* type = KEEP(reduce(
-    r_null,
-    vec_args.empty,
-    p_arg,
-    dots,
-    &ptype2_common,
-    &reduce_opts
-  ));
-  type = vec_ptype_finalise(type);
-
-  FREE(1);
-  return type;
+  FREE(n_prot);
+  return out;
 }
 
 static

src/ptype-common.h

@@ -3,6 +3,7 @@
 
 #include "vctrs-core.h"
 #include "ptype2.h"
+#include "unspecified.h"
 #include "utils.h"
 
 static inline
@@ -13,6 +14,7 @@ bool vec_is_common_class_fallback(r_obj* ptype) {
 r_obj* vec_ptype_common(
   r_obj* dots,
   r_obj* ptype,
+  enum ptype_finalise finalise,
   enum s3_fallback s3_fallback,
   struct vctrs_arg* p_arg,
   struct r_lazy call

src/recode.c

@@ -777,6 +777,7 @@ r_obj* ptype_finalize(
     ptype = KEEP(vec_ptype_common(
       to,
       r_null,
+      PTYPE_FINALISE_DEFAULT,
       S3_FALLBACK_DEFAULT,
       p_to_arg,
       error_call

src/unspecified.h

@@ -6,6 +6,18 @@
 SEXP vec_unspecified(R_len_t n);
 bool vec_is_unspecified(SEXP x);
 
+enum ptype_finalise {
+  PTYPE_FINALISE_false,
+  PTYPE_FINALISE_true
+};
+
+#define PTYPE_FINALISE_DEFAULT PTYPE_FINALISE_true
+
+static inline
+bool should_finalise(enum ptype_finalise finalise) {
+  return finalise == PTYPE_FINALISE_true;
+}
+
 r_obj* vec_ptype_finalise(r_obj* x);
 
 #endif

tests/testthat/test-case-when.R

@@ -272,6 +272,17 @@ test_that("`default` that is an unused logical `NA` can still be cast to `values
   expect_identical(vec_case_when(list(TRUE), list("x"), default = NA), "x")
 })
 
+test_that("`default` type is used when all values are logical `NA` (#2094)", {
+  expect_identical(
+    vec_case_when(list(TRUE), list(NA), default = "a"),
+    NA_character_
+  )
+  expect_identical(
+    vec_case_when(list(c(TRUE, FALSE)), list(NA), default = "a"),
+    c(NA_character_, "a")
+  )
+})
+
 test_that("`default_arg` can be customized", {
   expect_snapshot(error = TRUE, {
     vec_case_when(list(FALSE), list(1L), default = 2:3, default_arg = "foo")