Merge pull request #417 from R-Lum/issue_415_p2

Improve input validation in plot_RLum.Data.Spectrum() [skip ci]
R-Lum · Nov 13, 2024 · 5eb48d8 · 5eb48d8
2 parents e4a85ed + 12864c9
commit 5eb48d8
Show file tree

Hide file tree

Showing 2 changed files with 35 additions and 44 deletions.
diff --git a/R/plot_RLum.Data.Spectrum.R b/R/plot_RLum.Data.Spectrum.R
@@ -272,6 +272,12 @@ plot_RLum.Data.Spectrum <- function(
             "'RLum.Data.Spectrum' object using set_RLum()")
   }
 
+  .validate_args(norm, c("min", "max"), null.ok = TRUE)
+  .validate_args(plot.type, c("contour", "persp", "single", "multiple.lines",
+                              "image", "transect", "interactive"))
+  .validate_positive_scalar(bin.rows, int = TRUE)
+  .validate_positive_scalar(bin.cols, int = TRUE)
+
   ##XSYG
   ##check for curveDescripter
   if("curveDescripter" %in% names(object@info) == TRUE){
@@ -435,7 +441,8 @@ plot_RLum.Data.Spectrum <- function(
 
   # Background spectrum -------------------------------------------------------------------------
   if(!is.null(bg.spectrum)){
-    if(inherits(bg.spectrum, "RLum.Data.Spectrum") || inherits(bg.spectrum, "matrix")){
+    .validate_class(bg.spectrum, c("RLum.Data.Spectrum", "matrix"))
+
       ##case RLum
       if(inherits(bg.spectrum, "RLum.Data.Spectrum")) bg.xyz <- bg.spectrum@data
 
@@ -465,10 +472,6 @@ plot_RLum.Data.Spectrum <- function(
       ##reduce for xlim
       bg.xyz <- bg.xyz[as.numeric(rownames(bg.xyz)) >= xlim[1] &
                              as.numeric(rownames(bg.xyz)) <= xlim[2],,drop = FALSE]
-
-    }else{
-      .throw_error("Input for 'bg.spectrum' not supported")
-    }
   }
 
   # Background subtraction ---------------------------------------------------
@@ -504,14 +507,7 @@ plot_RLum.Data.Spectrum <- function(
     }
   }
 
-  # Channel binning ---------------------------------------------------------
-  ##rewrite arguments; makes things easier
-  bin.cols <- bin.cols[1]
-  bin.rows <- bin.rows[1]
-
-  ##fatal check (not needed anymore, but never change running code)
-  if(bin.cols < 1 | bin.rows < 1)
-    .throw_error("'bin.cols' and 'bin.rows' have to be > 1!")
+  ## Channel binning --------------------------------------------------------
 
   if(bin.rows > 1){
     temp.xyz <- .matrix_binning(temp.xyz, bin_size = bin.rows, bin_col = FALSE, names = "mean")
@@ -531,6 +527,7 @@ plot_RLum.Data.Spectrum <- function(
   if(bin.cols > 1){
     temp.xyz <- .matrix_binning(temp.xyz, bin_size = bin.cols, bin_col = TRUE, names = "groups")
     y <- as.numeric(colnames(temp.xyz))
+
     ##remove last channel (this is the channel that included less data)
     if (length(y) %% bin.cols != 0 && length(y) > bin.cols) {
       .throw_warning(length(y) %% bin.cols,
@@ -661,13 +658,13 @@ if(plot){
                    "reset to 'single'")
   }
 
-  ##do not let old code break down ...
-  if(plot.type == "persp3d"){
-    plot.type <- "interactive"
-    .throw_warning("'plot.type' has been automatically reset to interactive")
+  if (nrow(temp.xyz) == 1 && plot.type != "single") {
+    message("[plot_RLum.Data.Spectrum()] Insufficient data for plotting, ",
+            "NULL returned")
+    return(NULL)
   }
 
-  if (plot.type == "persp" && nrow(temp.xyz) > 1 && ncol(temp.xyz) > 1) {
+  if (plot.type == "persp") {
 
     ## Plot: perspective plot ----
     ## ==========================================================================#
@@ -800,7 +797,7 @@ if(plot){
     ##plot additional mtext
     mtext(mtext, side = 3, cex = cex * 0.8)
 
-  } else if (plot.type == "interactive" && nrow(temp.xyz) > 1 && ncol(temp.xyz) > 1) {
+  } else if (plot.type == "interactive") {
     ## ==========================================================================#
     ##interactive plot and former persp3d
     ## ==========================================================================#
@@ -825,13 +822,11 @@ if(plot){
          scene = list(
            xaxis = list(
              title = ylab
-
            ),
            yaxis = list(
              title = xlab
            ),
            zaxis = list(title = zlab)
-
          ),
          title = main
        )
@@ -840,7 +835,7 @@ if(plot){
        on.exit(return(p), add = TRUE)
 
 
-  } else if (plot.type == "contour" && nrow(temp.xyz) > 1 && ncol(temp.xyz) > 1) {
+  } else if (plot.type == "contour") {
     ## Plot: contour plot ----
     ## ==========================================================================#
     contour(x,y,temp.xyz,
@@ -854,20 +849,20 @@ if(plot){
     ##plot additional mtext
     mtext(mtext, side = 3, cex = cex*0.8)
 
-  } else if (plot.type == "image" && nrow(temp.xyz) > 1 && ncol(temp.xyz) > 1) {
+  } else if (plot.type == "image") {
     ## Plot: image plot ----
     ## ==========================================================================#
     graphics::image(x,y,temp.xyz,
             xlab = xlab,
             ylab = ylab,
             main = main,
-            col = if(is.null(list(...)$col)) grDevices::hcl.colors(50, palette = "Inferno") else
-              list(...)$col
+            col = if(is.null(extraArgs$col)) grDevices::hcl.colors(50, palette = "Inferno") else
+              extraArgs$col
     )
 
-    if(is.null(list(...)$contour) || list(...)$contour != FALSE) {
+    if (is.null(extraArgs$contour) || extraArgs$contour != FALSE) {
       contour(x, y, temp.xyz,
-              col = if(is.null(list(...)$contour.col)) rgb(1,1,1,0.8) else list(...)$contour.col,
+              col = if(is.null(extraArgs$contour.col)) rgb(1,1,1,0.8) else extraArgs$contour.col,
               labcex = 0.6 * cex,
               add = TRUE)
     }
@@ -947,13 +942,12 @@ if(plot){
 
       ## add box if needed
       if(box) graphics::box()
-
     }
 
     ##plot additional mtext
     mtext(mtext, side = 3, cex = cex*0.8)
 
-  } else if (plot.type == "multiple.lines" && nrow(temp.xyz) > 1 && ncol(temp.xyz) > 1) {
+  } else if (plot.type == "multiple.lines") {
     ## Plot: multiple.lines ----
     ## ========================================================================#
     col.rug <- col
@@ -1055,7 +1049,7 @@ if(plot){
     par(par.default)
     rm(par.default)
 
-  } else if (plot.type == "transect" && nrow(temp.xyz) > 1 && ncol(temp.xyz) > 1) {
+  } else if (plot.type == "transect") {
     ## Plot: transect plot ----
     ## ========================================================================#
 
@@ -1084,12 +1078,7 @@ if(plot){
 
     ##plot additional mtext
     mtext(mtext, side = 3, cex = cex*0.8)
-
-  }else{
-    .throw_error("Unknown plot type")
- }
-
-## option for plotting nothing
+  }
 }
 
 # Return ------------------------------------------------------------------
@@ -1099,5 +1088,4 @@ attr(temp.xyz, "pmat") <- pmat
 
 ## return visible or not
 if(plot) invisible(temp.xyz) else return(temp.xyz)
-
 }
diff --git a/tests/testthat/test_plot_RLum.Data.Spectrum.R b/tests/testthat/test_plot_RLum.Data.Spectrum.R
@@ -6,11 +6,15 @@ test_that("input validation", {
   expect_error(plot_RLum.Data.Spectrum("error"),
                "'object' should be of class 'RLum.Data.Spectrum' or 'matrix'")
   expect_error(plot_RLum.Data.Spectrum(TL.Spectrum, plot.type = "error"),
-               "Unknown plot type")
+               "'plot.type' should be one of 'contour', 'persp', 'single'")
+  expect_error(plot_RLum.Data.Spectrum(TL.Spectrum, norm = "error"),
+               "'norm' should be one of 'min', 'max' or NULL")
   expect_error(plot_RLum.Data.Spectrum(TL.Spectrum, bg.spectrum = "error"),
-               "Input for 'bg.spectrum' not supported")
+               "'bg.spectrum' should be of class 'RLum.Data.Spectrum' or 'matrix'")
+  expect_error(plot_RLum.Data.Spectrum(TL.Spectrum, bin.rows = 1.7),
+               "'bin.rows' should be a positive integer scalar")
   expect_error(plot_RLum.Data.Spectrum(TL.Spectrum, bin.cols = 0),
-               "'bin.cols' and 'bin.rows' have to be > 1")
+               "'bin.cols' should be a positive integer scalar")
 
   expect_error(plot_RLum.Data.Spectrum(TL.Spectrum, xlim = c(0, 100)),
       "No data left after applying 'xlim' and 'ylim'")
@@ -28,7 +32,6 @@ test_that("check functionality", {
     m <- TL.Spectrum@data
     bg.spectrum <- set_RLum(class = "RLum.Data.Spectrum", data = TL.Spectrum@data[,15:16, drop = FALSE])
 
-
     ##try a matrix as input
     expect_message(plot_RLum.Data.Spectrum(object = m),
                    "Input has been converted to a 'RLum.Data.Spectrum' object")
@@ -302,8 +305,8 @@ test_that("regression tests", {
   expect_silent(plot_RLum.Data.Spectrum(
       TL.Spectrum,
       bin.rows = 600))
-  expect_error(plot_RLum.Data.Spectrum(
+  expect_message(expect_null(plot_RLum.Data.Spectrum(
       TL.Spectrum,
-      bin.rows = 2000),
-      "Unknown plot type") # FIXME(mcol): it should do nothing instead
+      bin.rows = 2000)),
+      "Insufficient data for plotting, NULL returned")
 })