add ?~!

R/ask.R

@@ -1,14 +1,6 @@
 .onLoad   <- function(libname, pkgname) options("ask.thread" = 1L) #nocov
 .onUnload <- function(libpath) library.dynam.unload("ask", libpath) #nocov
 
-`?` <- \(x, y = NULL) {
-  if (is.logical(x)) {
-    .Call(ifelse, x, y, PACKAGE = "ask")
-  } else if (is.null(y <- substitute(y))) {
-    do.call(utils::`?`, list(substitute(x)))
-  } else {
-    .Call(isas, x, y, PACKAGE = "ask")
-  }
 `?` <- function(x, y) {
   switch(
     nargs(),
@@ -24,13 +16,12 @@
 ask <- function(threads = NULL, pct = NULL) {
   if (!nargs()) {
     .Call(c_get_threads)
-  } else if (!is.null(pct)) {
-    if (!is.null(threads)) stop("Threads or percent, not both.")
-    if (length(pct) != 1L) stop("Scalar value needed for percent.")
-    pct <- as.integer(pct)
-    if (is.na(pct) || pct < 2L || pct > 100L) stop("pct in [2, 100] please.")
-    .Call(c_set_threads, pct, TRUE, integer(0))
+  } else if (pct ?! nil) {
+    threads ? nil                       ?~! "Pass threads or pct, not both."
+    length(pct) == 1L                   ?~! "Pass scalar pct value."
+    !is.na(pct) & pct >= 0 & pct <= 100 ?~! "Pass pct value in [2, 100]."
+    .Call(c_set_threads, pct ?~ int, TRUE, integer())
   } else {
-    .Call(c_set_threads, as.integer(threads), FALSE, integer(0))
+    .Call(c_set_threads, threads ?~ int, FALSE, integer())
   }
 }

inst/tinytest/test_err.R

@@ -0,0 +1,7 @@
+`:=` <- expect_identical
+error <- expect_error
+
+err <- "err"
+
+(TRUE ?~! er) := NULL
+error(FALSE ?~! err, err)

inst/tinytest/test_help.R

@@ -3,4 +3,5 @@ error <- expect_error
 
 expect_true(inherits(?integer, "help_files_with_topic")) # exists
 expect_true(inherits(??integer, "hsearch"))
-error(?test, "object") # does not exist
+length(?Syntax) := 1L
+length(?test) := 0L # does not exist, prints

inst/tinytest/test_threads.R

@@ -6,5 +6,5 @@ ask() := 1L
 ask(pct = 100) := ask(0)
 
 error(ask(threads = 1, pct = 1), "not both")
-error(ask(pct = c(1, 2)), "Scalar")
+error(ask(pct = c(1, 2)), "scalar")
 error(ask(pct = 101), "[0, 100]")

src/ifelse.c

@@ -8,20 +8,32 @@ S ENV(S fml) {return Rf_getAttrib(fml, Rf_install(".Environment"));}
 S lhs(S fml) {
   if (isFormula(fml)) {
     switch(Rf_length(fml)) {
-    case 2: return R_NilValue; // T ?~ 1
-    case 3: return Rf_eval(CADR(fml), ENV(fml)); // T ? x ~ y
+    case 2: return R_NilValue;                                    // T ?~ 1
+    case 3: return Rf_eval(CADR(fml), ENV(fml));                  // T ? x ~ y
     default: err("Malformed `~` in `?`.");
     };
   } else {
-    return fml; // T ? 1, default NULL at R level
+    return fml; // default NULL at R level                           T ? x
   }
 }
 
+const char * str2char(S s) {
+  return CHAR(STRING_ELT(Rf_coerceVector(s, STRSXP), 0));
+}
+
 S rhs(S fml) {
   if (isFormula(fml)) {
     switch(Rf_length(fml)) {
-    case 2: return Rf_eval(CADR(fml), ENV(fml)); // ~x
-    case 3: return Rf_eval(CADDR(fml), ENV(fml)); // x ~ y
+    case 2: {
+    SEXP expr = CADR(fml);
+    if(TYPEOF(expr) == LANGSXP && CAR(expr) == Rf_install("!")) {  // x ?~! y
+      SEXP msg = CADR(expr);
+      err(str2char(TYPEOF(msg) == STRSXP ? msg : Rf_eval(msg, ENV(fml))));
+    } else {
+      return Rf_eval(CADR(fml), ENV(fml));                         // ~x
+    }
+    }
+    case 3: return Rf_eval(CADDR(fml), ENV(fml));                  // x ~ y
     default: err("Malformed `~` in `?`.");
     };
   } else {

src/isas.c

@@ -20,7 +20,7 @@ SEXPTYPE abb2type(S abb) {
     if (!strcmp(s, AbbCoerceTable[i].abb))
       return (SEXPTYPE) AbbCoerceTable[i].type;
   }
-  Rf_errorcall(R_NilValue, "Abbreviation not found");       // x ?~ bla
+  err("Abbreviation not found");                           // x ?~ bla
 }
 
 S is(S x, S fml, bool negate) {