Add the replace_metadata<-() method for the RLum.Analysis class

DESCRIPTION

@@ -79,6 +79,7 @@ Collate:
     'replicate_RLum.R'
     'RLum-class.R'
     'view.R'
+    'metadata.R'
     'melt_RLum.R'
     'smooth_RLum.R'
     'names_RLum.R'
@@ -87,7 +88,6 @@ Collate:
     'set_RLum.R'
     'get_RLum.R'
     'RLum.Analysis-class.R'
-    'metadata.R'
     'RLum.Data-class.R'
     'bin_RLum.Data.R'
     'RLum.Data.Curve-class.R'

NEWS.Rmd

@@ -28,7 +28,8 @@ and `RLum.Analysis-class` objects and lists of such objects.
 more `RLum.Data.Spectrum` objects in different ways (#368, fixed in #419).
 
 * `replace_metadata()`: This function allows to manipulate the metadata of
-`Risoe.BINfileData` and `RLum.Data` objects (#480, fixed in #514 and #524).
+`Risoe.BINfileData`, `RLum.Analysis` and `RLum.Data` objects (#480, fixed
+in #514, #524 and #525).
 
 * `view()`: Provides a shortcut to the `utils::View()` spreadsheet-like data
 viewer tailored to the objects in the package (#489, fixed in #490).

NEWS.md

@@ -29,8 +29,8 @@
   \#419).
 
 - `replace_metadata()`: This function allows to manipulate the metadata
-  of `Risoe.BINfileData` and `RLum.Data` objects (#480, fixed in \#514
-  and \#524).
+  of `Risoe.BINfileData`, `RLum.Analysis` and `RLum.Data` objects (#480,
+  fixed in \#514, \#524 and \#525).
 
 - `view()`: Provides a shortcut to the `utils::View()` spreadsheet-like
   data viewer tailored to the objects in the package (#489, fixed in

R/RLum.Analysis-class.R

@@ -1,4 +1,4 @@
-#' @include get_RLum.R set_RLum.R length_RLum.R structure_RLum.R names_RLum.R smooth_RLum.R melt_RLum.R view.R
+#' @include get_RLum.R set_RLum.R length_RLum.R structure_RLum.R names_RLum.R smooth_RLum.R melt_RLum.R metadata.R view.R
 NULL
 
 #' Class `"RLum.Analysis"`
@@ -282,7 +282,7 @@ setMethod(
 #' The selection of a specific RLum.type object superimposes the default selection.
 #' Currently supported objects are: RLum.Data.Curve and RLum.Data.Spectrum
 #'
-#' @param object [`get_RLum`]: [`names_RLum`], [`length_RLum`], [`structure_RLum`] (**required**):
+#' @param object (**required**):
 #' an object of class [RLum.Analysis-class]
 #'
 #' @param record.id [`get_RLum`]: [numeric] or [logical] (*optional*):
@@ -741,6 +741,43 @@ setMethod("names_RLum",
           })
 
 
+# replace_metadata() --------------------------------------------------------
+#' @describeIn RLum.Analysis
+#' Replaces metadata of [RLum.Analysis-class] objects
+#'
+#' @param info_element [character] (**required**) name of the metadata field
+#' to replace
+#'
+#' @param value (**required**) The value assigned to the selected elements
+#' of the metadata field.
+#'
+#' @keywords internal
+#'
+#' @md
+#' @export
+setMethod("replace_metadata<-",
+          signature= "RLum.Analysis",
+          definition = function(object, info_element, subset = NULL, value) {
+            .set_function_name("replace_metadata")
+            on.exit(.unset_function_name(), add = TRUE)
+
+            ## this must be evaluated now, as inside the lapply() inner
+            ## function it would be evaluated differently
+            subset.expr <- substitute(subset)
+
+            ## replace the metadata in all records
+            records <- lapply(object@records, function(x) {
+              do.call(`replace_metadata<-`,
+                      list(x, info_element = info_element,
+                           subset = subset.expr,  verbose = FALSE,
+                           value = value))
+            })
+
+            object@records <- records
+            assign(x = deparse(substitute(object))[1], object)
+          })
+
+
 # smooth_RLum() -------------------------------------------------------------------------------
 #' @describeIn RLum.Analysis
 #'
@@ -795,8 +832,6 @@ setMethod(
 #'
 #' View method for [RLum.Analysis-class] objects
 #'
-#' @param object an object of class [RLum.Analysis-class]
-#'
 #' @param ... other arguments that might be passed
 #'
 #' @keywords internal

R/RLum.Data-class.R

@@ -47,6 +47,9 @@ setClass("RLum.Data",
 #' @param subset [expression] (*optional*) logical expression to limit the
 #' substitution only to the selected subset of elements
 #'
+#' @param verbose [logical] (*with default*) enable/disable output to the
+#' terminal
+#'
 #' @param value (**required**) The value assigned to the selected elements
 #' of the metadata field.
 #'
@@ -56,7 +59,8 @@ setClass("RLum.Data",
 #' @export
 setMethod("replace_metadata<-",
           signature = "RLum.Data",
-          definition = function(object, info_element, subset = NULL, value) {
+          definition = function(object, info_element, subset = NULL,
+                                verbose = TRUE, value) {
             .set_function_name("replace_metadata")
             on.exit(.unset_function_name(), add = TRUE)
 
@@ -87,8 +91,9 @@ setMethod("replace_metadata<-",
                 sel <- FALSE
               }
               if (!any(sel)) {
-                .throw_message("'subset' expression produced an ",
-                               "empty selection, nothing done")
+                if (verbose)
+                  .throw_message("'subset' expression produced an ",
+                                 "empty selection, nothing done")
                 return(object)
               }
             }

tests/testthat/test_metadata.R

@@ -2,7 +2,7 @@
 bin.v8 <- system.file("extdata/BINfile_V8.binx", package = "Luminescence")
 risoe <- read_BIN2R(bin.v8, verbose = FALSE)
 SW({
-analysis <- Risoe.BINfileData2RLum.Analysis(risoe)[[1]]
+analysis <- merge_RLum(Risoe.BINfileData2RLum.Analysis(risoe))
 })
 curve <- analysis@records[[1]]
 
@@ -47,6 +47,24 @@ test_that("check functionality for Risoe.BINfileData", {
                rep("TL", nrow(res@METADATA)))
 })
 
+test_that("check functionality for RLum.Analysis", {
+  testthat::skip_on_cran()
+
+  res <- analysis
+  replace_metadata(res, "SEL") <- FALSE
+  expect_equal(sapply(res@records, function(x) x@info[["SEL"]]),
+               c(FALSE, FALSE))
+  replace_metadata(res, "LTYPE", subset = SET == 2 & POSITION == 1) <- "OSL"
+  expect_equal(sapply(res@records, function(x) x@info[["LTYPE"]]),
+               c("OSL", "TL"))
+
+  ## the original object is unchanged
+  expect_equal(sapply(analysis@records, function(x) x@info[["SEL"]]),
+               rep(TRUE, length(res@records)))
+  expect_equal(sapply(analysis@records, function(x) x@info[["LTYPE"]]),
+               rep("TL", length(analysis@records)))
+})
+
 test_that("check functionality for RLum.Data", {
   testthat::skip_on_cran()