Improve input validation against an empty RLum.Results object

R/analyse_Al2O3C_CrossTalk.R

@@ -3,7 +3,7 @@
 #' @description The function provides the analysis of cross-talk measurements on a
 #' FI lexsyg SMART reader using Al2O3:C chips
 #'
-#' @param object [RLum.Analysis-class] **(required)**:
+#' @param object [RLum.Analysis-class] or [list] **(required)**:
 #' measurement input
 #'
 #' @param signal_integral [numeric] (*optional*):
@@ -99,6 +99,7 @@ analyse_Al2O3C_CrossTalk <- function(
 
   ## Integrity tests --------------------------------------------------------
 
+  .validate_class(object, c("RLum.Analysis", "list"))
   lapply(object,
          function(x) .validate_class(x, "RLum.Analysis",
                                      name = "All elements of 'object'"))

R/calc_AverageDose.R

@@ -239,6 +239,12 @@ calc_AverageDose <- function(
     data <- get_RLum(data)
   }
 
+  ## check that we actually have data
+  if (length(data) == 0 || nrow(data) == 0) {
+    message("[calc_AverageDose()] Error: 'data' contains no data, NULL returned")
+    return(NULL)
+  }
+
   ##problem: the entire code refers to column names the user may not provide...
   ##  >> to avoid changing the entire code, the data will shape to a format that
   ##  >> fits to the code
@@ -264,7 +270,8 @@ calc_AverageDose <- function(
 
   ##check data set
   if(nrow(data) == 0){
-    .throw_message("Data set contains 0 rows, NULL returned")
+    .throw_message("After NA removal, nothing is left from the data set, ",
+                   "NULL returned")
     return(NULL)
   }
 

R/calc_CosmicDoseRate.R

@@ -261,6 +261,12 @@ calc_CosmicDoseRate<- function(
   ## CONSISTENCY CHECK OF INPUT DATA
   ##============================================================================##
 
+  .validate_class(depth, "numeric")
+  .validate_class(density, "numeric")
+  .validate_class(latitude, "numeric")
+  .validate_class(longitude, "numeric")
+  .validate_class(altitude, "numeric")
+
   if(any(depth < 0) || any(density < 0)) {
     .throw_error("No negative values allowed for 'depth' and 'density'")
   }

R/calc_IEU.R

@@ -87,6 +87,11 @@ calc_IEU <- function(
   if (inherits(data, "RLum.Results")) {
     data <- get_RLum(data)
   }
+
+  ## check that we actually have data
+  if (length(data) == 0 || nrow(data) == 0) {
+    .throw_error("'data' contains no data")
+  }
   if (ncol(data) < 2) {
     .throw_error("'data' should have at least two columns")
   }

R/github.R

@@ -118,6 +118,9 @@ github_branches <- function(user = "r-lum", repo = "luminescence") {
   .set_function_name("github_branches")
   on.exit(.unset_function_name(), add = TRUE)
 
+  .validate_class(user, "character")
+  .validate_class(repo, "character")
+
   # build URL and retrieve content
   url <- paste0("https://api.github.com/repos/", user, "/", repo, "/branches")
   content <- .github_getContent(url)
@@ -165,6 +168,9 @@ github_issues <- function(user = "r-lum", repo = "luminescence", verbose = TRUE)
   .set_function_name("github_issues")
   on.exit(.unset_function_name(), add = TRUE)
 
+  .validate_class(user, "character")
+  .validate_class(repo, "character")
+
   # build URL and retrieve content
   url <- paste0("https://api.github.com/repos/", user,"/", repo, "/issues")
   content <- .github_getContent(url)

R/plot_DRTResults.R

@@ -217,10 +217,19 @@ plot_DRTResults <- function(
     .validate_class(values[[i]], c("data.frame", "RLum.Results"),
                     name = "'values'")
     if (inherits(values[[i]], "RLum.Results")) {
-      values[[i]] <- get_RLum(values[[i]])[,1:2]
+      val <- get_RLum(values[[i]])[, 1:2]
+      if (is.null(val))
+        val <- NA
+      values[[i]] <- val
     }
   }
 
+  ## remove invalid records
+  values[is.na(values)] <- NULL
+  if (length(values) == 0) {
+    .throw_error("No valid records in 'values'")
+  }
+
   ## Check input arguments ----------------------------------------------------
   for(i in 1:length(values)) {
 

R/plot_Histogram.R

@@ -138,6 +138,11 @@ plot_Histogram <- function(
     data <- get_RLum(data)[,1:2]
   }
 
+  ## check that we actually have data
+  if (length(data) == 0 || nrow(data) == 0) {
+    .throw_error("'data' contains no data")
+  }
+
   ## handle error-free data sets
   if(length(data) < 2) {
     data <- cbind(data, rep(NA, length(data)))

R/plot_OSLAgeSummary.R

@@ -51,12 +51,17 @@ plot_OSLAgeSummary <- function(
   ## Integrity tests --------------------------------------------------------
   .validate_class(object, c("RLum.Results", "numeric"))
 
-  if(is(object, "RLum.Results") &&
-     object@originator %in% c(".calc_BayesianCentralAgeModel", ".calc_IndividualAgeModel"))
-    object <- get_RLum(object, data.object = "A")
-
-  if(is(object, "RLum.Results") && object@originator == "combine_De_Dr")
-    object <- get_RLum(object, data.object = "Ages")
+  if (inherits(object, "RLum.Results")) {
+    if (object@originator %in% c(".calc_BayesianCentralAgeModel",
+                                 ".calc_IndividualAgeModel")) {
+      data.object <- "A"
+    } else if (object@originator %in% "combine_De_Dr") {
+      data.object <- "Ages"
+    } else {
+      .throw_error("Object originator '", object@originator, "' not supported")
+    }
+    object <- get_RLum(object, data.object = data.object)
+  }
 
   ## A should be a matrix
   A <- as.matrix(object, ncol = 1)

R/plot_RLum.Results.R

@@ -66,6 +66,9 @@ plot_RLum.Results<- function(
   ##============================================================================##
 
   .validate_class(object, "RLum.Results")
+  if (is.null(object@originator) || is.na(object@originator)) {
+    .throw_error("Object originator not supported")
+  }
 
   ##============================================================================##
   ## SAFE AND RESTORE PLOT PARAMETERS ON EXIT
@@ -119,7 +122,7 @@ plot_RLum.Results<- function(
     )
 
   ## CASE 1: Minimum Age Model / Maximum Age Model -------
-  if(object@originator=="calc_MinDose" || object@originator=="calc_MaxDose") {
+  if (object@originator %in% c("calc_MinDose", "calc_MaxDose")) {
 
     ## single MAM estimate
     # plot profile log likelihood
@@ -410,7 +413,6 @@ plot_RLum.Results<- function(
 
         # add vertical lines of the mean values
         #points(x = 80, y = 100,type = "l")
-
       }
 
       #### ------ PLOT DE

R/plot_ROI.R

@@ -74,9 +74,13 @@ plot_ROI <- function(
 
   ##helper function to extract content
   .spatial_data <- function(x) {
+    .validate_class(x, c("RLum.Analysis", "RLum.Results"),
+                    extra = "a 'list' of such objects",
+                    name = "'object'")
+
     ##ignore all none RLum.Analysis
     if (!inherits(x, "RLum.Analysis") || x@originator != "read_RF2R")
-      .throw_error("Input for 'object' not supported, please check documentation")
+      .throw_error("Object originator '", x@originator, "' not supported")
 
     ##extract some of the elements
     info <- x@info
@@ -93,7 +97,9 @@ plot_ROI <- function(
       grain_d = info$grain_d)
   }
 
-  if(is(object, "RLum.Results") && object@originator == "extract_ROI") {
+  if (inherits(object, "RLum.Results") &&
+      ## use %in% instead of == to support the case when originator is NULL
+      object@originator %in% "extract_ROI") {
     m <- object@data$roi_coord
 
   } else {

R/set_RLum.R

@@ -13,8 +13,9 @@
 #' - [RLum.Analysis-class], 
 #' - [RLum.Results-class]
 #'
-#' @param class [RLum-class] (**required**): 
-#' name of the S4 class to create
+#' @param class [character] (**required**):
+#' name of the S4 class to create, must correspond to one of the [RLum-class]
+#' classes.
 #'
 #' @param originator [character] (*automatic*): 
 #' contains the name of the calling function (the function that produces this object); 
@@ -59,10 +60,14 @@
 #'
 #' ##plot this curve object
 #' plot_RLum(object)
-#' 
+#'
 #' @md
 #' @export
 setGeneric("set_RLum", function (class, originator, .uid = create_UID(), .pid = NA_character_, ... ) {
+  .set_function_name("set_RLum")
+  on.exit(.unset_function_name(), add = TRUE)
+
+  .validate_class(class, "character")
   class(class) <- as.character(class)
 
   if(missing(originator)) {
@@ -82,4 +87,3 @@ setGeneric("set_RLum", function (class, originator, .uid = create_UID(), .pid =
 
   standardGeneric("set_RLum")
 })
-

R/write_RLum2CSV.R

@@ -190,12 +190,15 @@ write_RLum2CSV <- function(
       ##remove unwanted objects
       object_list <- object_list[object_list_rm]
 
-
       ##set warning
       if(any(!object_list_rm))
         .throw_warning(length(which(!object_list_rm)),
                        " elements could not be converted to CSV")
 
+      if (length(object_list) == 0) {
+        .throw_error("No valid records in 'object'")
+      }
+
       ##adjust the names
       names(object_list) <- paste0(1:length(object_list),"_",names(object_list))
 

R/zzz.R

@@ -78,6 +78,12 @@ assign("fn_stack", list(),
 #' @md
 #' @export
 sTeve<- function(n_frames = 10, t_animation = 2, n.tree = 7, type) {
+  .set_function_name("sTeve")
+  on.exit(.unset_function_name(), add = TRUE)
+
+  .validate_class(n_frames, c("integer", "numeric"))
+  .validate_class(t_animation, c("integer", "numeric"))
+  .validate_class(n.tree, c("integer", "numeric"))
 
   ## allow new overlay plot
   par(new = TRUE)
@@ -97,7 +103,7 @@ sTeve<- function(n_frames = 10, t_animation = 2, n.tree = 7, type) {
     }
     # nocov end
   }
-
+  .validate_class(type, c("integer", "numeric"))
 
 
   if(type == 1) {

tests/testthat/test_RLum.Results-class.R

@@ -24,6 +24,14 @@ test_that("check class", {
                c("summary", "data", "args", "usedDeValues"))
 })
 
+test_that("set_RLum", {
+  testthat::skip_on_cran()
+
+  ## input validation
+  expect_error(set_RLum(obj, TRUE),
+               "'class' should be of class 'character'")
+})
+
 test_that("get_RLum", {
   testthat::skip_on_cran()
 

tests/testthat/test_analyse_Al2O3C_CrossTalk.R

@@ -4,7 +4,9 @@ data(ExampleData.Al2O3C, envir = environment())
 test_that("input validation", {
   skip_on_cran()
 
-  expect_error(analyse_Al2O3C_CrossTalk("test"),
+  expect_error(analyse_Al2O3C_CrossTalk("error"),
+               "'object' should be of class 'RLum.Analysis' or 'list")
+  expect_error(analyse_Al2O3C_CrossTalk(list("error")),
                "All elements of 'object' should be of class 'RLum.Analysis'")
   expect_error(analyse_Al2O3C_CrossTalk(data_CrossTalk,
                                         method_control = "EXP"),

tests/testthat/test_calc_AverageDose.R

@@ -19,13 +19,16 @@ test_that("input validation", {
       "Error: 'data' contains < 2 columns")
   expect_message(expect_null(
       calc_AverageDose(data[0, ], sigma_m = 0.1)),
-      "Error: Data set contains 0 rows")
+      "Error: 'data' contains no data, NULL returned")
 
   SW({
   expect_warning(calc_AverageDose(cbind(data, data), sigma_m = 0.1),
                  "'data' contains > 2 columns")
   expect_warning(calc_AverageDose(rbind(data, NA), sigma_m = 0.1),
                  "NA values in 'data' detected")
+  expect_message(expect_null(
+      calc_AverageDose(data.frame(NA, NA), sigma_m = 0.1)),
+      "Error: After NA removal, nothing is left from the data set")
   })
 })
 

tests/testthat/test_calc_CosmicDoseRate.R

@@ -1,19 +1,23 @@
 test_that("input validation", {
   testthat::skip_on_cran()
 
-  expect_error(calc_CosmicDoseRate(depth = -2),
+  expect_error(calc_CosmicDoseRate(depth = "error"),
+               "'depth' should be of class 'numeric'")
+  expect_error(calc_CosmicDoseRate(depth = -2, density = 1.7, altitude = 364,
+                                   latitude = 38.1, longitude = 1.4),
                "No negative values allowed for 'depth' and 'density'")
-  expect_error(calc_CosmicDoseRate(depth = 2.78, density = 1.7,
+  expect_error(calc_CosmicDoseRate(depth = 2.78, density = 1.7, altitude = 364,
+                                   latitude = 38.1, longitude = 1.4,
                                    corr.fieldChanges = TRUE),
                "requires an age estimate")
   expect_error(calc_CosmicDoseRate(depth = 2.78, density = 1.7,
                                    corr.fieldChanges = TRUE, est.age = 20,
                                    latitude = 38.06451),
-               "is missing, with no default")
+               "'longitude' should be of class 'numeric'")
   expect_error(calc_CosmicDoseRate(depth = 2.78, density = 1.7,
                                    corr.fieldChanges = TRUE, est.age = 20,
                                    latitude = 38.06451, longitude = 1.49646),
-               "is missing, with no default")
+               "'altitude' should be of class 'numeric'")
   expect_error(calc_CosmicDoseRate(depth = 2.78, density = c(1.7, 2.9),
                                    corr.fieldChanges = TRUE, est.age = 20,
                                    latitude = 38.06451, longitude = 1.49646,

tests/testthat/test_calc_IEU.R

@@ -15,6 +15,10 @@ test_that("input validation", {
                "'b' should be of class 'numeric'")
   expect_error(calc_IEU(df, a = 0.2, b = 1.9, interval = "error"),
                "'interval' should be of class 'numeric'")
+  expect_error(calc_IEU(data.frame(), a = 0.2, b = 1.9, interval = 1),
+               "'data' contains no data")
+  expect_error(calc_IEU(iris[0, ], a = 0.2, b = 1.9, interval = 1),
+               "'data' contains no data")
 })
 
 test_that("check functionality", {