class= argument for condition calls

R/translation.R

@@ -4,18 +4,32 @@ catf = function(fmt, ..., sep=" ", domain="R-data.table") {
   cat(gettextf(fmt, ..., domain=domain), sep=sep)
 }
 
-stopf = function(fmt, ..., domain="R-data.table") {
-  stop(gettextf(fmt, ..., domain=domain), domain=NA, call. = FALSE)
+raise_condition = function(signal, message, classes, immediate=FALSE, appendLF=FALSE) {
+  obj = list(message=message, call=sys.call(2))
+  # NB: append _after_ translation
+  if (appendLF) obj$message = paste0(obj$message, "\n")
+  setattr(obj, "class", classes)
+  # cannot set immediate.=TRUE through warning(), so use the description in ?warning to replicate this behavior ourselves. tested manually.
+  if (immediate) {
+    old = options(warn=1)
+    on.exit(options(old))
+  }
+  signal(obj)
 }
 
-warningf = function(fmt, ..., immediate.=FALSE, noBreaks.=FALSE, domain="R-data.table") {
-  warning(gettextf(fmt, ..., domain=domain), domain=NA, call.=FALSE, immediate.=immediate., noBreaks.=noBreaks.)
+stopf = function(fmt, ..., class=NULL, domain="R-data.table") {
+  raise_condition(stop, gettextf(fmt, ..., domain=domain), c(class, "simpleError", "error", "condition"))
 }
 
-messagef = function(fmt, ..., appendLF=TRUE, domain="R-data.table") {
-  message(gettextf(fmt, ..., domain=domain), domain=NA, appendLF=appendLF)
+warningf = function(fmt, ..., immediate.=FALSE, class=NULL, domain="R-data.table") {
+  raise_condition(warning, gettextf(fmt, ..., domain=domain), c(class, "simpleWarning", "warning", "condition"), immediate=immediate.)
 }
 
-packageStartupMessagef = function(fmt, ..., appendLF=TRUE, domain="R-data.table") {
-  packageStartupMessage(gettextf(fmt, ..., domain=domain), domain=NA, appendLF=appendLF)
+messagef = function(fmt, ..., appendLF=TRUE, class=NULL, domain="R-data.table") {
+  raise_condition(message, gettextf(fmt, ..., domain=domain), c(class, "simpleMessage", "message", "condition"), appendLF=appendLF)
+}
+
+packageStartupMessagef = function(fmt, ..., appendLF=TRUE, class=NULL, domain="R-data.table") {
+  # NB: packageStartupMessage() itself calls message(.packageStartupMessage(...))
+  messagef(fmt, ..., appendLF=appendLF, class=c(class, "packageStartupMessage"), domain=domain)
 }

inst/tests/tests.Rraw

@@ -53,7 +53,9 @@ if (exists("test.data.table", .GlobalEnv, inherits=FALSE)) {
   isRealReallyInt = data.table:::isRealReallyInt
   is_utc = data.table:::is_utc
   melt.data.table = data.table:::melt.data.table  # for test 1953.4
+  messagef = data.table:::messagef
   null.data.table = data.table:::null.data.table
+  packageStartupMessagef = data.table:::packageStartupMessagef
   print.data.table = data.table:::print.data.table
   replace_dot_alias = data.table:::replace_dot_alias
   rollup.data.table = data.table:::rollup.data.table
@@ -66,9 +68,11 @@ if (exists("test.data.table", .GlobalEnv, inherits=FALSE)) {
   .shallow = data.table:::.shallow
   split.data.table = data.table:::split.data.table
   if (!exists('startsWith', 'package:base', inherits=FALSE)) startsWith = data.table:::startsWith
+  stopf = data.table:::stopf
   test = data.table:::test
   uniqlengths = data.table:::uniqlengths
   uniqlist = data.table:::uniqlist
+  warningf = data.table:::warningf
   which_ = data.table:::which_
   which.first = data.table:::which.first
   which.last = data.table:::which.last
@@ -18499,3 +18503,26 @@ test(2258.9, capture.output(print(DT, na.print=".", topn=2)), c("    x", " 1: ."
 x = data.table(rep(1:2, each=5L), 1:5, 1:10)
 test(2259.1, names(split(x, by = c("V1", "V2"), sep = "|")), sort(names(split(x, list(x$V1, x$V2), sep = "|"))))
 test(2259.2, names(split(x, by = c("V1", "V2"), sep = "||")), sort(names(split(x, list(x$V1, x$V2), sep = "||"))))
+
+# custom signaling functions
+## basics: default signals with/without formats
+test(2260.01, tryCatch(stopf("%s", "abc"), error=function(x) conditionMessage(x)), "abc")
+test(2260.02, tryCatch(stopf("abc"), error=function(x) conditionMessage(x)), "abc")
+test(2260.03, tryCatch(warningf("%s", "abc"), warning=function(x) conditionMessage(x)), "abc")
+test(2260.04, tryCatch(warningf("abc"), warning=function(x) conditionMessage(x)), "abc")
+test(2260.05, tryCatch(messagef("%s", "abc"), message=function(x) conditionMessage(x)), "abc\n")
+test(2260.06, tryCatch(messagef("abc"), message=function(x) conditionMessage(x)), "abc\n")
+test(2260.07, tryCatch(messagef("abc", appendLF=FALSE), message=function(x) conditionMessage(x)), "abc")
+test(2260.08, tryCatch(packageStartupMessagef("%s", "abc"), packageStartupMessage=function(x) conditionMessage(x)), "abc\n")
+test(2260.09, tryCatch(packageStartupMessagef("abc"), packageStartupMessage=function(x) conditionMessage(x)), "abc\n")
+test(2260.10, tryCatch(packageStartupMessagef("abc", appendLF=FALSE), packageStartupMessage=function(x) conditionMessage(x)), "abc")
+
+## custom signal classes
+test(2260.11, inherits(tryCatch(stopf("x", class="test_error"), condition=identity), "test_error"))
+test(2260.12, inherits(tryCatch(stopf("x", class="test_error"), condition=identity), "error"))
+test(2260.13, inherits(tryCatch(warningf("x", class="test_warning"), condition=identity), "test_warning"))
+test(2260.14, inherits(tryCatch(warningf("x", class="test_warning"), condition=identity), "warning"))
+test(2260.15, inherits(tryCatch(messagef("x", class="test_message"), condition=identity), "test_message"))
+test(2260.16, inherits(tryCatch(messagef("x", class="test_message"), condition=identity), "message"))
+test(2260.17, inherits(tryCatch(packageStartupMessagef("x", class="test_psm"), condition=identity), "test_psm"))
+test(2260.18, inherits(tryCatch(packageStartupMessagef("x", class="test_psm"), condition=identity), "packageStartupMessage"))