Replace the implementation of .throw_error() and .throw_warning().

Rather than relying on the parsing of sys.call() and the setting of the correct nframe value, this uses the most up-to-date function name stored in the .LuminescenceEnv list.
R-Lum · Sep 20, 2024 · 6120173 · 6120173
1 parent 906e2cc
commit 6120173
Show file tree

Hide file tree

Showing 10 changed files with 33 additions and 89 deletions.
diff --git a/NEWS.Rmd b/NEWS.Rmd
@@ -48,6 +48,7 @@ file export. To avoid this now all non-ASCII characters are replaced by `_` befo
 ## Internals
 
 * Two new internal functions `.throw_warning()` and `.throw_error()` sometimes flushed the
-terminal with messages if call (internally) in particular circumstances. Now the functions
-make only two attempts to get the name of their called and then return an `unknown()` as function name. 
+terminal with messages if call (internally) in particular circumstances. Now we maintain a
+stack of function names, so that at any time we can report correctly the name of the
+function where an error or a warning is thrown (#254, fixed in #256).
 
diff --git a/R/RLum.Analysis-class.R b/R/RLum.Analysis-class.R
@@ -385,12 +385,11 @@ setMethod("get_RLum",
               ),
               error = function(e) {
                 .throw_error("Invalid subset expression, valid terms are: ",
-                             paste(names(envir), collapse = ", "), nframe = 6)
+                             paste(names(envir), collapse = ", "))
               })
 
               if (!is.logical(sel)) {
-                .throw_error("'subset' must contain a logical expression",
-                             nframe = 2)
+                .throw_error("'subset' must contain a logical expression")
               }
 
               if (all(is.na(sel)))
@@ -418,12 +417,10 @@ setMethod("get_RLum",
                 ##check for entries
                 if(length(object@info) == 0){
                   .throw_warning("This 'RLum.Analysis' object has no info ",
-                                 "objects, NULL returned",
-                                 nframe = 3)
+                                 "objects, NULL returned")
                 }else{
                   .throw_warning("Invalid 'info.object' name, valid names are: ",
-                                 paste(names(object@info), collapse = ", "),
-                                 nframe = 3)
+                                 paste(names(object@info), collapse = ", "))
                 }
                 return(NULL)
               }
@@ -433,7 +430,7 @@ setMethod("get_RLum",
               ##check for records
               if (length(object@records) == 0) {
                 .throw_warning("This 'RLum.Analysis' object has no records, ",
-                               "NULL returned", nframe = 3)
+                               "NULL returned")
                 return(NULL)
               }
 
@@ -444,7 +441,7 @@ setMethod("get_RLum",
               } else if (!is.numeric(record.id) &
                          !is.logical(record.id)) {
                 .throw_error("'record.id' has to be of type 'numeric' or ",
-                             "'logical'", nframe = 3)
+                             "'logical'")
               }
               ##logical needs a slightly different treatment
               ##Why do we need this? Because a lot of standard R functions work with logical
@@ -468,8 +465,7 @@ setMethod("get_RLum",
                     x@recordType, character(1)))
 
               } else if (!inherits(recordType, "character")){
-                .throw_error("'recordType' has to be of type 'character'",
-                             nframe = 3)
+                .throw_error("'recordType' has to be of type 'character'")
               }
 
               ##curveType
@@ -480,26 +476,23 @@ setMethod("get_RLum",
                                                   })))
 
               } else if (!is(curveType, "character")) {
-                .throw_error("'curveType' has to be of type 'character'",
-                             nframe = 3)
+                .throw_error("'curveType' has to be of type 'character'")
               }
 
               ##RLum.type
               if (is.null(RLum.type)) {
                 RLum.type <- c("RLum.Data.Curve", "RLum.Data.Spectrum", "RLum.Data.Image")
 
               } else if (!is(RLum.type, "character")) {
-                .throw_error("'RLum.type' has to be of type 'character'",
-                             nframe = 3)
+                .throw_error("'RLum.type' has to be of type 'character'")
               }
 
               ##get.index
               if (is.null(get.index)) {
                 get.index <- FALSE
 
               } else if (!is(get.index, "logical")) {
-                .throw_error("'get.index' has to be of type 'logical'",
-                             nframe = 3)
+                .throw_error("'get.index' has to be of type 'logical'")
               }
 
               ##get originator
@@ -557,8 +550,7 @@ setMethod("get_RLum",
 
                 ##check if the produced object is empty and show warning message
                 if (length(temp) == 0)
-                  .throw_warning("This request produced an empty list of records",
-                                 nframe = 3)
+                  .throw_warning("This request produced an empty list of records")
 
                 ##remove list for get.index
                 if (get.index) {

diff --git a/R/analyse_baSAR.R b/R/analyse_baSAR.R
@@ -643,14 +643,12 @@ analyse_baSAR <- function(
         .throw_error("No pre-defined model for the requested distribution. ",
                      "Please select one of '",
                      paste(rev(names(baSAR_models))[-1], collapse = "', '"),
-                     "', or define an own model using argument 'baSAR_model'",
-                     nframe = 7)
+                     "', or define an own model using argument 'baSAR_model'")
       }
 
       if (distribution == "user_defined" && is.null(baSAR_model)) {
         .throw_error("You specified a 'user_defined' distribution, ",
-                     "but did not provide a model via 'baSAR_model'",
-                     nframe = 7)
+                     "but did not provide a model via 'baSAR_model'")
       }
 
       ### Bayesian inputs

diff --git a/R/calc_FastRatio.R b/R/calc_FastRatio.R
@@ -242,8 +242,7 @@ calc_FastRatio <- function(object,
     } else {
       if (any(Ch_L3 > nrow(A))) {
         .throw_error("Value in Ch_L3 (", paste(Ch_L3, collapse = ", "),
-                     ") exceeds number of available channels (", nrow(A), ")",
-                     nframe = 3) # we are inside an lapply closure
+                     ") exceeds number of available channels (", nrow(A), ")")
       }
       t_L3_start <- A[Ch_L3[1], 1]
       t_L3_end <- A[Ch_L3[2], 1]

diff --git a/R/fit_EmissionSpectra.R b/R/fit_EmissionSpectra.R
@@ -207,7 +207,7 @@ fit_EmissionSpectra <- function(
       }else{
         if(max(frame) > ncol(o@data)|| min(frame) < 1){
           .throw_error("'frame' invalid. Allowed range min: 1 and max: ",
-                       ncol(o@data), nframe = 3) # we are inside an lapply closure
+                       ncol(o@data))
         }
       }
 
@@ -239,7 +239,7 @@ fit_EmissionSpectra <- function(
     }else{
       if(max(frame) > (ncol(object)-1) || min(frame) < 1){
         .throw_error("'frame' invalid. Allowed range min: 1 and max: ",
-                     ncol(object) - 1, nframe = 3) # we are inside an lapply closure
+                     ncol(object) - 1)
       }
     }
 
@@ -372,7 +372,7 @@ fit_EmissionSpectra <- function(
   ## check graining parameter
   if (method_control$graining >= nrow(m))
     .throw_error("method_control$graining cannot exceed the ",
-                 "available channels (", nrow(m) ,")", nframe = 5)
+                 "available channels (", nrow(m) ,")")
 
   ##initialise objects
   success_counter <- 0

diff --git a/R/internals_RLum.R b/R/internals_RLum.R
@@ -877,61 +877,23 @@ fancy_scientific <- function(l) {
 #'@title Throws a Custom Tailored Error Message
 #'
 #'@param ... the error message to throw
-#'@param nframe [numeric] (*with default*): the frame where the function
-#'       name to return in the error message should be searched: the
-#'       default value of 1 is generally fine, unless [throw_error] is
-#'       called from an internal function (whose name is not of interest
-#'       to the user), in which case a value of 2 should be used.
 #'
 #'@md
 #'@noRd
-.throw_error <- function(..., 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)
-
+.throw_error <- function(...) {
+  top.idx <- length(.LuminescenceEnv$fn_stack)
+  stop("[", .LuminescenceEnv$fn_stack[[top.idx]], "()] ", ..., call. = FALSE)
 }
 
 #'@title Throws a Custom Tailored Warning Message
 #'
 #'@param ... the warning message to throw
-#'@param nframe [numeric] (*with default*): the frame where the function
-#'       name to return in the warning message should be searched: the
-#'       default value of 1 is generally fine, unless [throw_warning] is
-#'       called from an internal function (whose name is not of interest
-#'       to the user), in which case a value of 2 should be used
 #'
 #'@md
 #'@noRd
-.throw_warning <- function(..., 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()"
-
-  ## warning
-  warning(paste0("[", f_calling, "] ", ...), call. = FALSE)
-
+.throw_warning <- function(...) {
+  top.idx <- length(.LuminescenceEnv$fn_stack)
+  warning("[", .LuminescenceEnv$fn_stack[[top.idx]], "()] ", ..., call. = FALSE)
 }
 
 #' @title Silence Output and Warnings during Tests
@@ -981,6 +943,6 @@ SW <- function(expr) {
     if (is.null(name))
       name <- all.vars(match.call())[1]
     .throw_error("'", name, "' must be a positive ", if (int) "integer ",
-                 "scalar", nframe = 2)
+                 "scalar")
   }
 }
diff --git a/R/plot_RLum.Analysis.R b/R/plot_RLum.Analysis.R
@@ -577,7 +577,7 @@ plot_RLum.Analysis <- function(
           if(any(is.infinite(temp.data[[2]])) || anyNA(temp.data[[2]])){
             temp.data[[2]][is.infinite(temp.data[[2]]) | is.na(temp.data[[2]])] <- 0
             .throw_warning("Normalisation led to Inf or NaN values, ",
-                           "values replaced by 0", nframe = 3)
+                           "values replaced by 0")
           }
         }
 

diff --git a/tests/testthat/test_analyse_SAR.TL.R b/tests/testthat/test_analyse_SAR.TL.R
@@ -106,5 +106,6 @@ test_that("regression tests", {
                    signal.integral.min = 210, signal.integral.max = 220,
                    sequence.structure = c("SIGNAL", "BACKGROUND"))
   ),
-  "Error: All points have the same dose, NULL returned")
+  "[plot_GrowthCurve()] Error: All points have the same dose, NULL returned",
+  fixed = TRUE)
 })
diff --git a/tests/testthat/test_internals.R b/tests/testthat/test_internals.R
@@ -161,11 +161,6 @@ test_that("Test internals", {
   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()
-  expect_error(fun.ext(),
-               "[fun.ext()] Error message", fixed = TRUE)
-
   ## .throw_warning() -------------------------------------------------------
   fun.int <- function() {
     .set_function_name("fun.int")
@@ -182,12 +177,7 @@ test_that("Test internals", {
   expect_warning(fun.docall(),
                  "[fun.int()] Warning message", fixed = TRUE)
   expect_warning(fun.docall_do(),
-               "[fun.int()] Warning message", fixed = TRUE)
-
-  fun.int <- function() .throw_warning("Warning message", nframe = 2)
-  fun.ext <- function() fun.int()
-  expect_warning(fun.ext(),
-                 "[fun.ext()] Warning message", fixed = TRUE)
+                 "[fun.int()] Warning message", fixed = TRUE)
 
   ## SW() ------------------------------------------------------------------
   expect_silent(SW(cat("silenced message")))

diff --git a/tests/testthat/test_subset_RLum.R b/tests/testthat/test_subset_RLum.R
@@ -13,7 +13,8 @@ test_that("subset RLum.Analysis", {
 
   ### errors
   expect_error(subset(temp, LTYPE == "RF"),
-               "Invalid subset expression, valid terms are") # FIXME(mcol): long function name produced by .throw_error()
+               "[get_RLum()] Invalid subset expression, valid terms are",
+               fixed = TRUE)
   SW({
   expect_message(expect_null(subset(temp, recordType == "xx")),
                  "'subset' expression produced an empty selection, NULL returned")