Merge branch 'dev_1.0.0'

# Conflicts: # NEWS.Rmd # NEWS.md
R-Lum · Sep 16, 2024 · aa1d263 · aa1d263
2 parents 446b655 + 3ab4064
commit aa1d263
Show file tree

Hide file tree

Showing 8 changed files with 79 additions and 80 deletions.
diff --git a/NEWS.Rmd b/NEWS.Rmd
@@ -21,9 +21,22 @@ affected was also `analyse_SAR.CWOSL()`.
 it shows a warning with instructions and set `plot = FALSE`. This should prevent "Figure margins too large" errors. 
 * The function will not crash anymore during the plotting in another edge case related to single grain data. 
 
+### `get_RLum()`
+* When the function was used on a list of `RLum.Analysis-class` objects with the argument `null.rm = TRUE` it would 
+remove all `NULL` objects, but not elements that became `list()` (empty list) during the selection; fixed.
+
+
+### `plot_RLum.Data.Spectrum()`
+* Add support for `lphi` and `ltheta` light direction arguments for `plot.type = "persp"`. 
+* Fix the reason for the unclear warning `In col.unique == col :  longer object length is not a multiple of shorter object length`
 
 ## 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. 
+
+## Internals
+
+
+
diff --git a/NEWS.md b/NEWS.md
@@ -5,7 +5,7 @@
 
 <!-- NEWS.md was auto-generated by NEWS.Rmd. Please DO NOT edit by hand!-->
 
-# Changes in version 0.9.25.9000-3 (2024-09-15)
+# Changes in version 0.9.25.9000-3 (2024-09-16)
 
 ## New functions
 
@@ -24,10 +24,26 @@
 - The function will not crash anymore during the plotting in another
   edge case related to single grain data.
 
+### `get_RLum()`
+
+- When the function was used on a list of `RLum.Analysis-class` objects
+  with the argument `null.rm = TRUE` it would remove all `NULL` objects,
+  but not elements that became `list()` (empty list) during the
+  selection; fixed.
+
+### `plot_RLum.Data.Spectrum()`
+
+- Add support for `lphi` and `ltheta` light direction arguments for
+  `plot.type = "persp"`.
+- Fix the reason for the unclear warning
+  `In col.unique == col :  longer object length is not a multiple of shorter object length`
+
 ## 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.
+
+## Internals
diff --git a/R/RLum.Analysis-class.R b/R/RLum.Analysis-class.R
@@ -349,12 +349,10 @@ setMethod(
 #' @export
 setMethod("get_RLum",
           signature = ("RLum.Analysis"),
-
           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)) {
 
             if (!is.null(substitute(subset))) {
-
               # To account for different lengths and elements in the @info slot we first
               # check all unique elements (in all records)
               info_el <- unique(unlist(lapply(object@records, function(el) names(el@info))))
@@ -431,7 +429,6 @@ setMethod("get_RLum",
 
               ##check for records
               if (length(object@records) == 0) {
-
                 .throw_warning("This 'RLum.Analysis' object has no records, ",
                                "NULL returned", nframe = 3)
                 return(NULL)
@@ -518,27 +515,23 @@ setMethod("get_RLum",
               ##select curves according to the chosen parameter
               if (length(record.id) > 1) {
                 temp <- lapply(record.id, function(x) {
-                  if (is(object@records[[x]])[1] %in% RLum.type == TRUE) {
+                  if (is(object@records[[x]])[1] %in% RLum.type) {
                     ##as input a vector is allowed
                     temp <- lapply(1:length(recordType), function(k) {
                       ##translate input to regular expression
                       recordType[k] <- glob2rx(recordType[k])
                       recordType[k] <- substr(recordType[k], start = 2, stop = nchar(recordType[k]) - 1)
 
-                      if (grepl(recordType[k], object@records[[x]]@recordType) == TRUE &
+                      ## get the results object and if requested, get the index
+                      if (grepl(recordType[k], object@records[[x]]@recordType) &
                           object@records[[x]]@curveType %in% curveType) {
-                        if (!get.index) {
-                          object@records[[x]]
+                        if (!get.index) object@records[[x]] else x
 
-                        } else{
-                          x
-                        }
                       }
-
                     })
 
                     ##remove empty entries and select just one to unlist
-                    temp <- temp[!sapply(temp, is.null)]
+                    temp <- temp[!vapply(temp, is.null,logical(1))]
 
                     ##if list has length 0 skip entry
                     if (length(temp) != 0) {
@@ -549,9 +542,8 @@ setMethod("get_RLum",
                   }
                 })
 
-
                 ##remove empty list element
-                temp <- temp[!sapply(temp, is.null)]
+                temp <- temp[!vapply(temp, is.null, logical(1))]
 
                 ##check if the produced object is empty and show warning message
                 if (length(temp) == 0)
@@ -563,7 +555,6 @@ setMethod("get_RLum",
                   return(unlist(temp))
 
                 } else{
-
                   if (!drop) {
                     temp <- set_RLum(
                       class = "RLum.Analysis",
@@ -586,7 +577,7 @@ setMethod("get_RLum",
                 }
 
               } else{
-                if (get.index == FALSE) {
+                if (!get.index[1]) {
                   if (drop == FALSE) {
                     ##needed to keep the argument drop == TRUE
                     temp <- set_RLum(

diff --git a/R/analyse_pIRIRSequence.R b/R/analyse_pIRIRSequence.R
@@ -615,7 +615,6 @@ analyse_pIRIRSequence <- function(
 
   }
 
-
 ##============================================================================##
 # Plotting additional --------------------------------------------------------
 ##============================================================================##
@@ -649,7 +648,6 @@ if(plot){
     x <- seq(0,max(LnLxTnTx.table$Dose)*1.05, length.out = 100)
 
     for(j in 1:length(pIRIR.curve.names)){
-
      ##dose points
      temp.curve.points <-  LnLxTnTx.table[,c("Dose", "LxTx", "LxTx.Error", "Signal")]
 
@@ -687,7 +685,6 @@ if(plot){
 
     rm(x)
 
-
     ##plot legend
     legend("bottomright", legend = pIRIR.curve.names,
            lty = 1, col = c(1:length(pIRIR.curve.names)),
@@ -741,7 +738,6 @@ if(plot){
          pch = c(1:length(pIRIR.curve.names))
          )
 
-
    ##Rejection criteria
    temp.rejection.criteria <- get_RLum(temp.results.final,
                                                data.object = "rejection.criteria")
@@ -774,7 +770,6 @@ if(plot){
           y = c(21,29,29,21), col = "gray", border = NA)
     polygon(x = c(-0.3,-0.3,0.3,0.3) , y = c(21,29,29,21))
 
-
    ##consider possibility of multiple pIRIR signals and multiple recycling ratios
    col.id  <- 1
 
@@ -784,7 +779,6 @@ if(plot){
    for(i in seq(1,nrow(temp.rc.recuperation.rate),
                   length(unique(temp.rc.recuperation.rate[,"Criteria"])))){
 
-
         for(j in 0:length(unique(temp.rc.recuperation.rate[,"Criteria"]))){
          points(temp.rc.reycling.ratio[i+j, "Value"]-1,
                y = 25,
@@ -798,8 +792,6 @@ if(plot){
 
     rm(col.id)
 
-
-
    ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++##
    ##polygon for recuperation rate
    text(x = -.4, y = 20, "Recuperation rate", pos = 1, srt = 0)
@@ -836,13 +828,12 @@ if(plot){
    polygon(x = c(-0.3,-0.3,0.3,0.3) , y = c(1,9,9,1))
    polygon(x = c(-0.3,-0.3,0,0) , y = c(1,9,9,1), border = NA, density = 10, angle = 45)
 
-
    for(i in 1:nrow(temp.rc.palaedose.error)){
-
-     points(temp.rc.palaedose.error[i, "Value"],
-            y = 5,
-            pch = i,
-            col = i)
+     if(length(temp.rc.palaedose.error[i, "Value"]) > 0 && !is.na(temp.rc.palaedose.error[i, "Value"]))
+       points(temp.rc.palaedose.error[i, "Value"],
+              y = 5,
+              pch = i,
+              col = i)
 
    }
 

diff --git a/R/get_RLum.R b/R/get_RLum.R
@@ -61,7 +61,6 @@ setGeneric("get_RLum", function (object, ...) {standardGeneric("get_RLum") })
 setMethod("get_RLum",
           signature = "list",
           function(object, class = NULL, null.rm = FALSE, ...){
-
             ##take care of the class argument
             if(!is.null(class)){
               sel <- class[1] == vapply(object, function(x) class(x), character(1))
@@ -71,24 +70,19 @@ setMethod("get_RLum",
               rm(sel)
             }
 
-
             ##make remove all non-RLum objects
             selection <- lapply(1:length(object), function(x){
-
               ##get rid of all objects that are not of type RLum, this is better than leaving that
               ##to the user
               if(inherits(object[[x]], what = "RLum")){
-
                 ##it might be the case the object already comes with empty objects, this would
                 ##cause a crash
                 if(inherits(object[[x]], "RLum.Analysis") && length(object[[x]]@records) == 0)
                   return(NULL)
 
                 get_RLum(object[[x]], ...)
 
-
               } else {
-
                 warning(paste0("[get_RLum()] object #",x," in the list was not of type 'RLum' and has been removed!"),
                         call. = FALSE)
                 return(NULL)
@@ -99,31 +93,24 @@ setMethod("get_RLum",
 
             ##remove empty or NULL objects after the selection ... if wanted
             if(null.rm){
-
-
               ##first set all empty objects to NULL ... for RLum.Analysis objects
               selection <- lapply(1:length(selection), function(x){
-                if(inherits(selection[[x]], "RLum.Analysis") && length(selection[[x]]@records) == 0){
+                if(length(selection[[x]]) == 0 ||
+                   (inherits(selection[[x]], "RLum.Analysis") &&
+                    length(selection[[x]]@records) == 0))
                   return(NULL)
-
-                }else{
+                else
                   return(selection[[x]])
 
-                }
-
               })
-
               ##get rid of all NULL objects
-              selection <- selection[!sapply(selection, is.null)]
-
+              selection <- selection[!vapply(selection, is.null, logical(1))]
 
             }
-
             return(selection)
 
           })
 
-
 #' Method to handle NULL if the user calls get_RLum
 #'
 #' @describeIn get_RLum