diff --git a/NEWS.Rmd b/NEWS.Rmd index 7b8d44eb8..9fed2c3c5 100644 --- 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 index 42931e595..7d32dc3df 100644 --- 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,8 +476,7 @@ 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 @@ -489,8 +484,7 @@ setMethod("get_RLum", 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 @@ -498,8 +492,7 @@ setMethod("get_RLum", 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 index 84dba39c9..794a3914a 100644 --- 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 index 8222fae94..399b86ff6 100644 --- 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 index 9348a2cfa..e5200a9c2 100644 --- 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 index d55e4ee1b..c5be9018a 100644 --- 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 index dcdc74145..0651716dc 100644 --- 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 index ffac490d4..3ef042b16 100644 --- 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 index 0f228a42b..3b0dece20 100644 --- 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 index a485a46a8..71158fa23 100644 --- 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")