Merge pull request #256 from R-Lum/issue_254

Replace the implementation of .throw_error() and .throw_warning() [skip ci]

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).
 

R/CW2pHMi.R

@@ -114,9 +114,9 @@
 #'
 #' Bulur, E., 2000. A simple transformation for converting CW-OSL curves to
 #' LM-OSL curves. Radiation Measurements, 32, 141-145.
-#' 
+#'
 #' @keywords manip
-#' 
+#'
 #' @examples
 #'
 #' ##(1) - simple transformation
@@ -197,8 +197,9 @@
 CW2pHMi<- function(
   values,
   delta
-){
-
+) {
+  .set_function_name("CW2pHMi")
+  on.exit(.unset_function_name(), add = TRUE)
 
   ##(1) data.frame or RLum.Data.Curve object?
   if(is(values, "data.frame") == FALSE & is(values, "RLum.Data.Curve") == FALSE){

R/RLum.Analysis-class.R

@@ -352,6 +352,8 @@ setMethod("get_RLum",
           function(object, record.id = NULL, recordType = NULL, curveType = NULL, RLum.type = NULL,
                    protocol = "UNKNOWN", get.index = NULL, drop = TRUE, recursive = TRUE,
                    info.object = NULL, subset = NULL, env = parent.frame(2)) {
+            .set_function_name("get_RLum")
+            on.exit(.unset_function_name(), add = TRUE)
 
             if (!is.null(substitute(subset))) {
               # To account for different lengths and elements in the @info slot we first
@@ -383,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)))
@@ -416,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)
               }
@@ -431,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)
               }
 
@@ -442,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
@@ -466,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
@@ -478,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
@@ -555,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) {
@@ -631,6 +625,8 @@ setMethod("get_RLum",
 setMethod("structure_RLum",
           signature= "RLum.Analysis",
           definition = function(object, fullExtent = FALSE) {
+            .set_function_name("structure_RLum")
+            on.exit(.unset_function_name(), add = TRUE)
 
             ##check if the object containing other elements than allowed
             if(!all(vapply(object@records, FUN = class, character(1)) == "RLum.Data.Curve"))

R/Risoe.BINfileData2RLum.Analysis.R

@@ -87,8 +87,9 @@ Risoe.BINfileData2RLum.Analysis<- function(
   protocol = "unknown",
   keep.empty = TRUE,
   txtProgressBar = FALSE
-){
-
+) {
+  .set_function_name("Risoe.BINfileData2RLum.Analysis")
+  on.exit(.unset_function_name(), add = TRUE)
 
   # Integrity Check ---------------------------------------------------------
 

R/analyse_Al2O3C_ITC.R

@@ -114,8 +114,9 @@ analyse_Al2O3C_ITC <- function(
   verbose = TRUE,
   plot = TRUE,
   ...
-){
-
+) {
+  .set_function_name("analyse_Al2O3C_ITC")
+  on.exit(.unset_function_name(), add = TRUE)
 
   # SELF CALL -----------------------------------------------------------------------------------
   if(is.list(object)){

R/analyse_Al2O3C_Measurement.R

@@ -147,7 +147,9 @@ analyse_Al2O3C_Measurement <- function(
   verbose = TRUE,
   plot = TRUE,
   ...
-){
+) {
+  .set_function_name("analyse_Al2O3C_Measurement")
+  on.exit(.unset_function_name(), add = TRUE)
 
   # Self call -----------------------------------------------------------------------------------
   if(is(object, "list")){

R/analyse_FadingMeasurement.R

@@ -196,7 +196,9 @@ analyse_FadingMeasurement <- function(
   plot = TRUE,
   plot.single = FALSE,
   ...
-){
+) {
+  .set_function_name("analyse_FadingMeasurement")
+  on.exit(.unset_function_name(), add = TRUE)
 
   # Integrity Tests -----------------------------------------------------------------------------
   if (is(object, "list")) {

R/analyse_IRSAR.RF.R

@@ -424,7 +424,9 @@ analyse_IRSAR.RF<- function(
   plot = TRUE,
   plot_reduced = FALSE,
   ...
-){
+) {
+  .set_function_name("analyse_IRSAR.RF")
+  on.exit(.unset_function_name(), add = TRUE)
 
   ##TODO
   ## - if a file path is given, the function should try to find out whether an XSYG-file or

R/analyse_SAR.CWOSL.R

@@ -270,6 +270,8 @@ analyse_SAR.CWOSL<- function(
   onlyLxTxTable = FALSE,
   ...
 ) {
+  .set_function_name("analyse_SAR.CWOSL")
+  on.exit(.unset_function_name(), add = TRUE)
 
 # SELF CALL -----------------------------------------------------------------------------------
 if(is.list(object)){

R/analyse_SAR.TL.R

@@ -119,7 +119,9 @@ analyse_SAR.TL <- function(
   dose.points,
   log = "",
   ...
-){
+) {
+  .set_function_name("analyse_SAR.TL")
+  on.exit(.unset_function_name(), add = TRUE)
 
   if (missing("object")) {
     stop("[analyse_SAR.TL()] No value set for 'object'!", call. = FALSE)

R/analyse_baSAR.R

@@ -437,7 +437,9 @@ analyse_baSAR <- function(
   plot.single = FALSE,
   verbose = TRUE,
   ...
-){
+) {
+  .set_function_name("analyse_baSAR")
+  on.exit(.unset_function_name(), add = TRUE)
 
   ##////////////////////////////////////////////////////////////////////////////////////////////////
   ##FUNCTION TO BE CALLED to RUN the Bayesian Model
@@ -641,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

R/analyse_pIRIRSequence.R

@@ -178,7 +178,9 @@ analyse_pIRIRSequence <- function(
   plot = TRUE,
   plot.single = FALSE,
   ...
-){
+) {
+  .set_function_name("analyse_pIRIRSequence")
+  on.exit(.unset_function_name(), add = TRUE)
 
   if (missing("object"))
     stop("[analyse_pIRIRSequence()] No value set for 'object'!")

R/analyse_portableOSL.R

@@ -114,8 +114,10 @@ analyse_portableOSL <- function(
   mode = "profile",
   coord = NULL,
   plot = TRUE,
-  ...)
-  {
+  ...
+) {
+  .set_function_name("analyse_portableOSL")
+  on.exit(.unset_function_name(), add = TRUE)
 
   ## TODO
   ## - add tests for background image option

R/calc_AliquotSize.R

@@ -147,7 +147,10 @@ calc_AliquotSize <- function(
   grains.counted,
   plot=TRUE,
   ...
-){
+) {
+  .set_function_name("calc_AliquotSize")
+  on.exit(.unset_function_name(), add = TRUE)
+
   ##==========================================================================##
   ## CONSISTENCY CHECK OF INPUT DATA
   ##==========================================================================##

R/calc_AverageDose.R

@@ -133,7 +133,9 @@ calc_AverageDose <- function(
   plot = TRUE,
   verbose = TRUE,
   ...
-){
+) {
+  .set_function_name("calc_AverageDose")
+  on.exit(.unset_function_name(), add = TRUE)
 
   # Define internal functions ------------------------------------------------------------------
 

R/calc_FastRatio.R

@@ -123,6 +123,8 @@ calc_FastRatio <- function(object,
                            fitCW.curve = FALSE,
                            plot = TRUE,
                            ...) {
+  .set_function_name("calc_FastRatio")
+  on.exit(.unset_function_name(), add = TRUE)
 
   ## Input verification --------------------------------------------------------
   .validate_positive_scalar(Ch_L1, int = TRUE)
@@ -240,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]

R/calc_Huntley2006.R

@@ -285,8 +285,7 @@
 #' }
 #' @md
 #' @export
-calc_Huntley2006 <-
-  function(
+calc_Huntley2006 <- function(
     data,
     LnTn = NULL,
     rhop,
@@ -298,7 +297,10 @@ calc_Huntley2006 <-
     summary = TRUE,
     plot = TRUE,
     ...
-){
+) {
+  .set_function_name("calc_Huntley2006")
+  on.exit(.unset_function_name(), add = TRUE)
+
   ## Validate Input ------------------------------------------------------------
 
   ## Check fit method

R/calc_MinDose.R

@@ -337,7 +337,9 @@ calc_MinDose <- function(
   plot = TRUE,
   multicore = FALSE,
   ...
-){
+) {
+  .set_function_name("calc_MinDose")
+  on.exit(.unset_function_name(), add = TRUE)
 
   ## ============================================================================##
   ## CONSISTENCY CHECK OF INPUT DATA

R/calc_OSLLxTxDecomposed.R

@@ -64,7 +64,9 @@ calc_OSLLxTxDecomposed <- function(
   OSL.component = 1L,
   sig0 = 0,
   digits = NULL
-){
+) {
+  .set_function_name("calc_OSLLxTxDecomposed")
+  on.exit(.unset_function_name(), add = TRUE)
 
   # ToDo:
   # - Integrity checks for the component table

R/calc_ThermalLifetime.R

@@ -150,8 +150,9 @@ calc_ThermalLifetime <- function(
   verbose = TRUE,
   plot = TRUE,
   ...
-
-){
+) {
+  .set_function_name("calc_ThermalLifetime")
+  on.exit(.unset_function_name(), add = TRUE)
 
 # Integrity -----------------------------------------------------------------------------------
 

R/calc_WodaFuchs2008.R

@@ -55,6 +55,8 @@ calc_WodaFuchs2008 <- function(
   plot = TRUE,
   ...
 ) {
+  .set_function_name("calc_WodaFuchs2008")
+  on.exit(.unset_function_name(), add = TRUE)
 
   ##TODO
   # - complete manual

R/calc_gSGC.R

@@ -82,7 +82,9 @@ calc_gSGC<- function(
   verbose = TRUE,
   plot = TRUE,
   ...
-){
+) {
+  .set_function_name("calc_gSGC")
+  on.exit(.unset_function_name(), add = TRUE)
 
 ##============================================================================##
 ##CHECK INPUT DATA