Regression: the new internal functions for .throw_warning() and throw…

…_error() were flushing the terminal in case of do.call()

+ fx calls
+ ad tests

R/analyse_SAR.CWOSL.R

@@ -1255,6 +1255,7 @@ error.list <- list()
         D02 = NA,
         D02.ERROR = NA,
         Dc = NA,
+        n_N = NA,
         De.MC = NA,
         Fit = NA,
         HPDI68_L = NA,

R/internals_RLum.R

@@ -843,11 +843,21 @@ fancy_scientific <- function(l) {
 #'@md
 #'@noRd
 .throw_error <- function(..., nframe = 1) {
-  ## get name of calling function
-  f_calling <- paste0("[", deparse(sys.call(-nframe)[1]), "] ")
+  ##1st try to get the name of the calling
+  f_calling <- deparse(sys.call(-nframe)[1])
+
+  ##2nd try if the length is > 1 than something went wrong
+  ##so we go one deeper
+  if(length(f_calling) > 1)
+    f_calling <- deparse(sys.call(- nframe -1)[2])
+
+  ##3rd here we stop otherwise it takes to long to go
+  ##down in the stack
+  if(length(f_calling) > 1)
+    f_calling <- "unknown()"
 
   ## stop
-  stop(paste0(f_calling, ...), call. = FALSE)
+  stop(paste0("[", f_calling, "] ", ...), call. = FALSE)
 
 }
 
@@ -863,11 +873,21 @@ fancy_scientific <- function(l) {
 #'@md
 #'@noRd
 .throw_warning <- function(..., nframe = 1) {
-  ## get name of calling function
-  f_calling <- paste0("[", deparse(sys.call(-nframe)[1]), "] ")
+  ##1st try to get the name of the calling
+  f_calling <- deparse(sys.call(-nframe)[1])
 
-  ## stop
-  warning(paste0(f_calling, ...), call. = FALSE)
+  ##2nd try if the length is > 1 than something went wrong
+  ##so we go one deeper
+  if(length(f_calling) > 1)
+    f_calling <- deparse(sys.call(- nframe -1)[2])
+
+  ##3rd here we stop otherwise it takes to long to go
+  ##down in the stack
+  if(length(f_calling) > 1)
+    f_calling <- "unknown()"
+
+  ## warning
+  warning(paste0("[", f_calling, "] ", ...), call. = FALSE)
 
 }
 

tests/testthat/test_internals.R

@@ -140,10 +140,16 @@ test_that("Test internals", {
   ## .throw_error() ---------------------------------------------------------
   fun.int <- function() .throw_error("Error message")
   fun.ext <- function() fun.int()
+  fun.docall <- function() do.call(fun.ext, args = list())
+  fun.docall_do <- function() fun.docall()
   expect_error(fun.int(),
                "[fun.int()] Error message", fixed = TRUE)
   expect_error(fun.ext(),
                "[fun.int()] Error message", fixed = TRUE)
+  expect_error(fun.docall(),
+               "[fun.int()] Error message", fixed = TRUE)
+  expect_error(fun.docall_do(),
+               "[fun.int()] Error message", fixed = TRUE)
 
   fun.int <- function() .throw_error("Error message", nframe = 2)
   fun.ext <- function() fun.int()
@@ -153,10 +159,13 @@ test_that("Test internals", {
   ## .throw_warning() -------------------------------------------------------
   fun.int <- function() .throw_warning("Warning message")
   fun.ext <- function() fun.int()
+  fun.docall <- function() do.call(fun.ext, args = list())
   expect_warning(fun.int(),
                  "[fun.int()] Warning message", fixed = TRUE)
   expect_warning(fun.ext(),
                  "[fun.int()] Warning message", fixed = TRUE)
+  expect_warning(fun.docall(),
+                 "[fun.int()] Warning message", fixed = TRUE)
 
   fun.int <- function() .throw_warning("Warning message", nframe = 2)
   fun.ext <- function() fun.int()